From 020348bb87860c8294be64a17b7de732c8265fbc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 24 Mar 2009 23:37:41 +0100 Subject: [PATCH 001/375] Include in `gsubr.c'. * libguile/gsubr.c: Include . Reported by Carlo Bramini . --- libguile/gsubr.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 2b9a29dd1..5e5b4c10e 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -20,6 +20,8 @@ # include #endif +#include + #include #include From 0ea47a3a09704684d4d8af70a2f9e851300845a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 20 Mar 2009 01:11:16 +0100 Subject: [PATCH 002/375] Aggregate `Makefile.am' files under `examples/'. * configure.in: Don't produce `examples/*/Makefile'. * examples/Makefile.am (SUBDIRS): Remove. (EXTRA_DIST, AM_CFLAGS, AM_LIBS): New. (box/box, box/box.o, box-module/box, box-module/box.o, libbox.la, box-dynamic/box.lo, libbox-module.la, box-dynamic-module/box.lo, installcheck, CLEANFILES, clean-local): New targets, aggregated from `Makefile.am' files formerly in sub-directories. * examples/check.test: New file, aggregated from `check.test' files in sub-directories. --- configure.in | 7 - examples/Makefile.am | 77 +++++++- examples/box-dynamic-module/Makefile.am | 36 ---- examples/box-dynamic-module/check.test | 48 ----- examples/box-dynamic/Makefile.am | 36 ---- examples/box-dynamic/check.test | 38 ---- examples/box-module/Makefile.am | 36 ---- examples/box-module/check.test | 38 ---- examples/box/Makefile.am | 36 ---- examples/box/check.test | 38 ---- examples/check.test | 238 ++++++++++++++++++++++++ examples/modules/Makefile.am | 25 --- examples/modules/check.test | 27 --- examples/safe/Makefile.am | 25 --- examples/safe/check.test | 40 ---- examples/scripts/Makefile.am | 25 --- examples/scripts/check.test | 53 ------ 17 files changed, 311 insertions(+), 512 deletions(-) delete mode 100644 examples/box-dynamic-module/Makefile.am delete mode 100755 examples/box-dynamic-module/check.test delete mode 100644 examples/box-dynamic/Makefile.am delete mode 100755 examples/box-dynamic/check.test delete mode 100644 examples/box-module/Makefile.am delete mode 100755 examples/box-module/check.test delete mode 100644 examples/box/Makefile.am delete mode 100755 examples/box/check.test create mode 100755 examples/check.test delete mode 100644 examples/modules/Makefile.am delete mode 100755 examples/modules/check.test delete mode 100644 examples/safe/Makefile.am delete mode 100755 examples/safe/check.test delete mode 100644 examples/scripts/Makefile.am delete mode 100755 examples/scripts/check.test diff --git a/configure.in b/configure.in index 589053aa6..60166d80f 100644 --- a/configure.in +++ b/configure.in @@ -1532,13 +1532,6 @@ AC_CONFIG_FILES([ doc/tutorial/Makefile emacs/Makefile examples/Makefile - examples/box-dynamic-module/Makefile - examples/box-dynamic/Makefile - examples/box-module/Makefile - examples/box/Makefile - examples/modules/Makefile - examples/safe/Makefile - examples/scripts/Makefile guile-config/Makefile lang/Makefile libguile/Makefile diff --git a/examples/Makefile.am b/examples/Makefile.am index 84503088f..1b995b521 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. +## Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -19,7 +19,76 @@ ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA -SUBDIRS = scripts box box-module box-dynamic box-dynamic-module\ - modules safe +EXTRA_DIST = README ChangeLog-2008 check.test \ + \ + scripts/README scripts/simple-hello.scm scripts/hello \ + scripts/fact \ + \ + box/README box/box.c \ + \ + box-module/README box-module/box.c \ + \ + box-dynamic/README box-dynamic/box.c \ + \ + box-dynamic-module/README box-dynamic-module/box.c \ + box-dynamic-module/box-module.scm box-dynamic-module/box-mixed.scm \ + \ + modules/README modules/module-0.scm modules/module-1.scm \ + modules/module-2.scm modules/main \ + \ + safe/README safe/safe safe/untrusted.scm safe/evil.scm -EXTRA_DIST = README ChangeLog-2008 +AM_CFLAGS = `$(bindir)/guile-config compile` +AM_LIBS = `$(bindir)/guile-config link` + + +box/box: box/box.o + -$(MKDIR_P) box + $(CC) $< $(AM_LIBS) -o $@ + +box/box.o: box/box.c + -$(MKDIR_P) box + $(CC) $(AM_CFLAGS) -c $< -o $@ + + +box-module/box: box-module/box.o + -$(MKDIR_P) box-module + $(CC) $< $(AM_LIBS) -o $@ + +box-module/box.o: box-module/box.c + -$(MKDIR_P) box-module + $(CC) $(AM_CFLAGS) -c $< -o $@ + + +libbox.la: box-dynamic/box.lo + $(top_builddir)/libtool --mode=link $(CC) $< $(AM_LIBS) -rpath $(libdir) -o $@ + +box-dynamic/box.lo: box-dynamic/box.c + -$(MKDIR_P) box-dynamic + $(top_builddir)/libtool --mode=compile $(CC) $(AM_CFLAGS) -c $< -o $@ + + +libbox-module.la: box-dynamic-module/box.lo + $(top_builddir)/libtool --mode=link $(CC) $< $(AM_LIBS) -rpath $(libdir) -o $@ + +box-dynamic-module/box.lo: box-dynamic-module/box.c + -$(MKDIR_P) box-dynamic-module + $(top_builddir)/libtool --mode=compile $(CC) $(AM_CFLAGS) -c $< -o $@ + + +installcheck: box/box box-module/box libbox.la libbox-module.la + LD_LIBRARY_PATH="$(libdir):$$LD_LIBRARY_PATH" \ + LTDL_LIBRARY_PATH="$(builddir):$$LTDL_LIBRARY_PATH" \ + GUILE_LOAD_PATH="$(abs_top_srcdir):$$GUILE_LOAD_PATH" \ + PATH="$(bindir):$$PATH" \ + srcdir="$(srcdir)" \ + $(srcdir)/check.test + +CLEANFILES = \ + box/box box/box.o \ + box-module/box box-module/box.o + +clean-local: + $(top_builddir)/libtool --mode=clean rm -f \ + box-dynamic/box.lo libbox.la \ + box-dynamic-module/box.lo libbox-module.la diff --git a/examples/box-dynamic-module/Makefile.am b/examples/box-dynamic-module/Makefile.am deleted file mode 100644 index bf18f4f66..000000000 --- a/examples/box-dynamic-module/Makefile.am +++ /dev/null @@ -1,36 +0,0 @@ -## Process this file with Automake to create Makefile.in -## -## Copyright (C) 2001, 2006 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -EXTRA_DIST = README box.c box-module.scm box-mixed.scm check.test - -CFLAGS=`$(bindir)/guile-config compile` -LIBS=`$(bindir)/guile-config link` - -libbox-module: box.lo - sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(libdir) -o libbox-module.la - -box.lo: box.c - sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< - -installcheck: libbox-module - LTDL_LIBRARY_PATH=.libs GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test - -CLEANFILES=libbox-module.la box.lo box.o diff --git a/examples/box-dynamic-module/check.test b/examples/box-dynamic-module/check.test deleted file mode 100755 index 935176d20..000000000 --- a/examples/box-dynamic-module/check.test +++ /dev/null @@ -1,48 +0,0 @@ -#!/bin/sh - -# must be run from this directory -guile=${GUILE-../../libguile/guile} - -set -e - -# -# ./box test #1 -# -$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP -cat < -EOF -rm -f TMP - -# -# ./box test #2 -# -$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP -cat < -# -EOF -rm -f TMP - -# -# ./box test #3 -# -$guile -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP -cat < -# -1 -EOF -rm -f TMP - -# -# ./box test #4 -# -$guile -c '(begin (use-modules (box-mixed)) (let ((b (make-box-list 1 2 3))) (display b) (newline) (display (box-map 1+ b)) (newline)))' > TMP -cat < # #) -(# # #) -EOF -rm -f TMP - -# check.test ends here diff --git a/examples/box-dynamic/Makefile.am b/examples/box-dynamic/Makefile.am deleted file mode 100644 index 6fa20c59c..000000000 --- a/examples/box-dynamic/Makefile.am +++ /dev/null @@ -1,36 +0,0 @@ -## Process this file with Automake to create Makefile.in -## -## Copyright (C) 2001, 2006 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -EXTRA_DIST = README box.c check.test - -CFLAGS=`$(bindir)/guile-config compile` -LIBS=`$(bindir)/guile-config link` - -libbox: box.lo - sh ../../libtool --mode=link $(CC) $< $(LIBS) -rpath $(libdir) -o libbox.la - -box.lo: box.c - sh ../../libtool --mode=compile $(CC) $(CFLAGS) -c $< - -installcheck: libbox - LTDL_LIBRARY_PATH=.libs GUILE_LOAD_PATH=$(top_srcdir):$(srcdir) $(srcdir)/check.test - -CLEANFILES=libbox.la box.lo box.o diff --git a/examples/box-dynamic/check.test b/examples/box-dynamic/check.test deleted file mode 100755 index c0923365c..000000000 --- a/examples/box-dynamic/check.test +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh - -# must be run from this directory -guile=${GUILE-../../libguile/guile} - -set -e - -# -# ./box test #1 -# -$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline)))' > TMP -cat < -EOF -rm -f TMP - -# -# ./box test #2 -# -$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP -cat < -# -EOF -rm -f TMP - -# -# ./box test #3 -# -$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP -cat < -# -1 -EOF -rm -f TMP - -# check.test ends here diff --git a/examples/box-module/Makefile.am b/examples/box-module/Makefile.am deleted file mode 100644 index 4790a296c..000000000 --- a/examples/box-module/Makefile.am +++ /dev/null @@ -1,36 +0,0 @@ -## Process this file with Automake to create Makefile.in -## -## Copyright (C) 2001, 2006 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -EXTRA_DIST = README box.c check.test - -CFLAGS=`$(bindir)/guile-config compile` -LIBS=`$(bindir)/guile-config link` - -box: box.o - $(CC) $< $(LIBS) -o box - -box.o: box.c - $(CC) $(CFLAGS) -c $< - -installcheck: box - LD_LIBRARY_PATH=$(libdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test - -CLEANFILES=box box.o diff --git a/examples/box-module/check.test b/examples/box-module/check.test deleted file mode 100755 index 28a79d45b..000000000 --- a/examples/box-module/check.test +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh - -# must be run from this directory -guile=${GUILE-../../libguile/guile} - -set -e - -# -# ./box test #1 -# -./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP -cat < -EOF -rm -f TMP - -# -# ./box test #2 -# -./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP -cat < -# -EOF -rm -f TMP - -# -# ./box test #3 -# -./box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP -cat < -# -1 -EOF -rm -f TMP - -# check.test ends here diff --git a/examples/box/Makefile.am b/examples/box/Makefile.am deleted file mode 100644 index 4790a296c..000000000 --- a/examples/box/Makefile.am +++ /dev/null @@ -1,36 +0,0 @@ -## Process this file with Automake to create Makefile.in -## -## Copyright (C) 2001, 2006 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -EXTRA_DIST = README box.c check.test - -CFLAGS=`$(bindir)/guile-config compile` -LIBS=`$(bindir)/guile-config link` - -box: box.o - $(CC) $< $(LIBS) -o box - -box.o: box.c - $(CC) $(CFLAGS) -c $< - -installcheck: box - LD_LIBRARY_PATH=$(libdir) GUILE_LOAD_PATH=$(top_srcdir) $(srcdir)/check.test - -CLEANFILES=box box.o diff --git a/examples/box/check.test b/examples/box/check.test deleted file mode 100755 index 1909ffb7e..000000000 --- a/examples/box/check.test +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh - -# must be run from this directory -guile=${GUILE-../../libguile/guile} - -set -e - -# -# ./box test #1 -# -./box -c '(let ((b (make-box))) (display b) (newline))' > TMP -cat < -EOF -rm -f TMP - -# -# ./box test #2 -# -./box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline))' > TMP -cat < -# -EOF -rm -f TMP - -# -# ./box test #3 -# -./box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline))' > TMP -cat < -# -1 -EOF -rm -f TMP - -# check.test ends here diff --git a/examples/check.test b/examples/check.test new file mode 100755 index 000000000..b659ce8dc --- /dev/null +++ b/examples/check.test @@ -0,0 +1,238 @@ +#!/bin/sh + +# must be run from this directory +guile=${GUILE-../libguile/guile} +if [ -x $guile ] ; then + : +else + echo could not find guile interpreter. + echo '(are you running this script from' `dirname $0` '?)' + echo GUILE env var: ${GUILE-not set} + exit 1 +fi + +if test "X$srcdir" = X; then + srcdir=. +fi + +set -e + +# +# simple-hello.scm +# +$guile -s $srcdir/scripts/simple-hello.scm > TMP +cat < TMP +echo "Hello, World!" | diff -u - TMP +rm -f TMP + +$guile -s $srcdir/scripts/hello --version > TMP +echo "hello 0.0.1" | diff -u - TMP +rm -f TMP + +$guile -s $srcdir/scripts/hello --help > TMP +cat < TMP +cat < +EOF +rm -f TMP + +# +# ./box/box test #2 +# +./box/box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box/box test #3 +# +./box/box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline))' > TMP +cat < +# +1 +EOF +rm -f TMP + + + +# +# ./box-module/box test #1 +# +./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box-module/box test #2 +# +./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box-module/box test #3 +# +./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + + +# +# ./box-dynamic/box test #1 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box-dynamic/box test #2 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box-dynamic/box test #3 +# +$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + + +# +# ./box-dynamic-module/box test #1 +# +$guile -L $srcdir/box-dynamic-module \ + -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP +cat < +EOF +rm -f TMP + +# +# ./box-dynamic-module/box test #2 +# +$guile -L $srcdir/box-dynamic-module \ + -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP +cat < +# +EOF +rm -f TMP + +# +# ./box-dynamic-module/box test #3 +# +$guile -L $srcdir/box-dynamic-module \ + -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP +cat < +# +1 +EOF +rm -f TMP + +# +# ./box-dynamic-module/box test #4 +# +$guile -L $srcdir/box-dynamic-module \ + -c '(begin (use-modules (box-mixed)) (let ((b (make-box-list 1 2 3))) (display b) (newline) (display (box-map 1+ b)) (newline)))' > TMP +cat < # #) +(# # #) +EOF +rm -f TMP + + + +# +# ./main test +# +$guile -L $srcdir/modules -s $srcdir/modules/main > TMP +cat < TMP +cat < TMP +cat < TMP -cat < TMP -cat < TMP -cat < TMP -cat < TMP -echo "Hello, World!" | diff -u - TMP -rm -f TMP - -$guile -s $srcdir/hello --version > TMP -echo "hello 0.0.1" | diff -u - TMP -rm -f TMP - -$guile -s $srcdir/hello --help > TMP -cat < Date: Wed, 25 Mar 2009 00:23:23 +0100 Subject: [PATCH 003/375] Fix `testsuite/Makefile.am' for `distcheck'. * testsuite/Makefile.am (check_SCRIPTS): Remove, renamed to `TESTS'. (EXTRA_DIST): Add $(TESTS). --- testsuite/Makefile.am | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am index 3c7ed7341..c523eff8d 100644 --- a/testsuite/Makefile.am +++ b/testsuite/Makefile.am @@ -2,7 +2,7 @@ TESTS_ENVIRONMENT = \ $(top_builddir)/pre-inst-guile \ -l $(srcdir)/run-vm-tests.scm -e run-vm-tests -check_SCRIPTS = \ +TESTS = \ t-basic-contructs.scm \ t-global-bindings.scm \ t-catch.scm \ @@ -24,6 +24,4 @@ check_SCRIPTS = \ t-match.scm \ t-mutual-toplevel-defines.scm -TESTS = $(check_SCRIPTS) - -EXTRA_DIST = run-vm-tests.scm +EXTRA_DIST = run-vm-tests.scm $(TESTS) From 6cc323e2ff4e555d58e115032016a50ef15a1948 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 26 Mar 2009 18:47:28 +0100 Subject: [PATCH 004/375] Remove multiple definition of `scm_i_marking'. * libguile/private-gc.h (scm_i_marking): Turn definition into a declaration. (scm_mark_all): Mark as `SCM_INTERNAL'. * libguile/gc-mark.c (scm_i_marking): New definition. --- libguile/gc-mark.c | 2 ++ libguile/private-gc.h | 9 ++++----- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c index 4eef19102..88bea8052 100644 --- a/libguile/gc-mark.c +++ b/libguile/gc-mark.c @@ -64,6 +64,8 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include #endif +int scm_i_marking = 0; + /* Entry point for this file. */ diff --git a/libguile/private-gc.h b/libguile/private-gc.h index f5331ab1e..125ef3a23 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -1,7 +1,7 @@ /* * private-gc.h - private declarations for garbage collection. * - * Copyright (C) 2002, 03, 04, 05, 06, 07, 08 Free Software Foundation, Inc. + * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -164,11 +164,10 @@ scm_i_gc_heap_size_delta (scm_t_cell_type_statistics * freelist); gc-mark */ -/* this can be used to ensure that set/clear gc marks only happen when - allowed. */ -int scm_i_marking; +/* Non-zero while in the mark phase. */ +SCM_INTERNAL int scm_i_marking; -void scm_mark_all (void); +SCM_INTERNAL void scm_mark_all (void); /* gc-segment: From 7ca96180f00800414a9cf855e5ca4dceb9baca07 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 26 Mar 2009 19:17:26 +0100 Subject: [PATCH 005/375] Run the stack calibration script before running the compiler. * am/guilec (.scm.go): Use `pre-inst-guile' and load `stack-limit-calibration.scm'. This is particularly useful when building the first `.go' files where the compiler is run using the interpreter, which may end up using a lot of stack space. * libguile/Makefile.am (BUILT_SOURCES): Add `stack-limit-calibration.scm'. (TESTS, TESTS_ENVIRONMENT): Remove. (stack-limit-calibration.scm): Prepend `-' so that any errors during the calibration are ignored. --- am/guilec | 4 +++- libguile/Makefile.am | 24 ++++++++++-------------- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/am/guilec b/am/guilec index 939ea76c4..aaa1747eb 100644 --- a/am/guilec +++ b/am/guilec @@ -10,4 +10,6 @@ CLEANFILES = $(GOBJECTS) SUFFIXES = .scm .go .scm.go: $(MKDIR_P) `dirname $@` - $(top_builddir)/pre-inst-guile-env $(top_builddir)/guile-tools compile -o "$@" "$<" + $(top_builddir)/pre-inst-guile \ + -l $(top_builddir)/libguile/stack-limit-calibration.scm \ + $(top_srcdir)/scripts/compile -o "$@" "$<" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 00f319f1e..044e0b6d0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -351,28 +351,24 @@ guile-procedures.txt: guile-procedures.texi endif -# Stack limit calibration for `make check'. (For why we do this, see +# Stack limit calibration to allow the compiler to run when creating +# the initial `.go' files and for `make check'. (For why we do this, see # the comments in measure-hwm.scm.) We're relying here on a couple of # bits of Automake magic. # -# 1. The fact that "libguile" comes before "test-suite" in SUBDIRS in -# our toplevel Makefile.am. This ensures that the -# stack-limit-calibration.scm "test" will be run before any of the -# tests under test-suite. +# 1. The fact that "libguile" comes before "module" and "test-suite" +# in SUBDIRS in our toplevel Makefile.am. This ensures that the +# stack-limit-calibration.scm program will be run before we compile +# files or run tests. # -# 2. The fact that each test is invoked as $TESTS_ENVIRONMENT $test. -# This allows us to ensure that the test will be considered to have -# passed, by using `true' as TESTS_ENVIRONMENT. -# -# Why don't we care about the test "actually passing"? Because the +# 2. Why don't we care about the test "actually passing"? Because the # important thing about stack-limit-calibration.scm is just that it is # generated in the first place, so that other tests under test-suite # can use it. -TESTS = stack-limit-calibration.scm -TESTS_ENVIRONMENT = true +BUILT_SOURCES += stack-limit-calibration.scm stack-limit-calibration.scm: measure-hwm.scm guile$(EXEEXT) - $(preinstguile) -s $(srcdir)/measure-hwm.scm > $@ + -$(preinstguile) -s $(srcdir)/measure-hwm.scm > $@ c-tokenize.c: c-tokenize.lex flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; } From 0fe95f9c4ce063781e79a15bc123c57c33ef9755 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 27 Mar 2009 09:50:06 +0100 Subject: [PATCH 006/375] Improve wording in `libguile/Makefile.am' regarding stack calibration. * libguile/Makefile.am (stack-limit-calibration.scm): Improve wording of the comment. Suggested by Neil Jerram. --- libguile/Makefile.am | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 044e0b6d0..580114093 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -353,18 +353,17 @@ endif # Stack limit calibration to allow the compiler to run when creating # the initial `.go' files and for `make check'. (For why we do this, see -# the comments in measure-hwm.scm.) We're relying here on a couple of -# bits of Automake magic. +# the comments in measure-hwm.scm.) # -# 1. The fact that "libguile" comes before "module" and "test-suite" -# in SUBDIRS in our toplevel Makefile.am. This ensures that the +# The fact that "libguile" comes before "module" and "test-suite" +# in SUBDIRS in our toplevel Makefile.am ensures that the # stack-limit-calibration.scm program will be run before we compile # files or run tests. # -# 2. Why don't we care about the test "actually passing"? Because the +# We don't care about the exit code of `measure-hwm.scm' because the # important thing about stack-limit-calibration.scm is just that it is -# generated in the first place, so that other tests under test-suite -# can use it. +# generated in the first place, so that it can be loaded in `am/guilec' +# and by the test suite. BUILT_SOURCES += stack-limit-calibration.scm stack-limit-calibration.scm: measure-hwm.scm guile$(EXEEXT) From 0b6d8fdc28ed8af56e93157179c305fef037e0a0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 14:03:03 -0700 Subject: [PATCH 007/375] allow building against uninstalled guile; move some things to meta/ * README: Add more info about building against an uninstalled Guile. * meta/: New directory. The proximate cause of its creation is that I want to be able to build external packages against uninstalled Guile, and to do that I need guile-tools in the PATH, but I don't want $top_builddir/libtool in the path. But it seems like a good reorganization, for things that are /about/ Guile: pkg-config files, m4 files, guile-config... then we also include uninstalled info: the environment, the pre-inst-guile script, etc. * meta/guile-1.8-uninstalled.pc.in: New pkg-config template. pkg-config prefers -uninstalled pkg-config files, if they are in its path. * meta/Makefile.am: * meta/ChangeLog-2008: * meta/gdb-uninstalled-guile.in: * meta/guile-1.8.pc.in: * meta/guile-config.in: * meta/guile.m4: * meta/guile-tools.in: Moved to meta/. * meta/guile.in: This is the new name of pre-inst-guile.in. * meta/uninstalled-env.in: And this, pre-inst-guile-env.in. * Makefile.am: * am/guilec: * am/pre-inst-guile: * check-guile.in: * configure.in: * doc/ref/Makefile.am: * gc-benchmarks/run-benchmark.scm: * test-suite/standalone/Makefile.am: * test-suite/standalone/README: * testsuite/Makefile.am: Adapt to meta/ change. --- Makefile.am | 9 ++----- README | 20 ++++++++++++--- am/guilec | 2 +- am/pre-inst-guile | 2 +- check-guile.in | 4 +-- configure.in | 14 ++++++----- doc/ref/Makefile.am | 4 +-- gc-benchmarks/run-benchmark.scm | 2 +- {guile-config => meta}/ChangeLog-2008 | 0 {guile-config => meta}/Makefile.am | 25 +++++-------------- .../gdb-uninstalled-guile.in | 10 ++++---- meta/guile-1.8-uninstalled.pc.in | 8 ++++++ guile-1.8.pc.in => meta/guile-1.8.pc.in | 0 {guile-config => meta}/guile-config.in | 4 +-- guile-tools.in => meta/guile-tools.in | 0 pre-inst-guile.in => meta/guile.in | 6 ++--- {guile-config => meta}/guile.m4 | 0 .../uninstalled-env.in | 17 ++++++++++--- test-suite/standalone/Makefile.am | 2 +- test-suite/standalone/README | 2 +- testsuite/Makefile.am | 2 +- 21 files changed, 74 insertions(+), 59 deletions(-) rename {guile-config => meta}/ChangeLog-2008 (100%) rename {guile-config => meta}/Makefile.am (59%) rename gdb-pre-inst-guile.in => meta/gdb-uninstalled-guile.in (79%) create mode 100644 meta/guile-1.8-uninstalled.pc.in rename guile-1.8.pc.in => meta/guile-1.8.pc.in (100%) rename {guile-config => meta}/guile-config.in (99%) rename guile-tools.in => meta/guile-tools.in (100%) rename pre-inst-guile.in => meta/guile.in (93%) rename {guile-config => meta}/guile.m4 (100%) rename pre-inst-guile-env.in => meta/uninstalled-env.in (87%) diff --git a/Makefile.am b/Makefile.am index 556b32141..0e61f531d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -24,16 +24,14 @@ # AUTOMAKE_OPTIONS = 1.10 -SUBDIRS = lib libguile guile-config guile-readline emacs \ +SUBDIRS = lib meta libguile guile-readline emacs \ scripts srfi doc examples test-suite benchmark-suite lang am \ module testsuite -bin_SCRIPTS = guile-tools - include_HEADERS = libguile.h EXTRA_DIST = LICENSE HACKING GUILE-VERSION \ - m4/ChangeLog-2008 FAQ guile-1.8.pc.in \ + m4/ChangeLog-2008 FAQ \ m4/autobuild.m4 ChangeLog-2008 TESTS = check-guile @@ -42,7 +40,4 @@ ACLOCAL_AMFLAGS = -I m4 DISTCLEANFILES = check-guile.log -pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = guile-1.8.pc - # Makefile.am ends here diff --git a/README b/README index 3af511b38..4e295f805 100644 --- a/README +++ b/README @@ -223,9 +223,23 @@ GUILE_FOR_BUILD variable, it defaults to just "guile". Using Guile Without Installing It ========================================= -The top directory of the Guile sources contains a script called -"pre-inst-guile" that can be used to run the Guile that has just been -built. +The "meta/" subdirectory of the Guile sources contains a script called +"guile" that can be used to run the Guile that has just been built. Note +that this is not the same "guile" as the one that is installed; this +"guile" is a wrapper script that sets up the environment appropriately, +then invokes the Guile binary. + +You may also build against an uninstalled Guile build tree. The +"uninstalled-env" script in the "meta/" subdirectory will set up an +environment with a path including "meta/", a modified dynamic linker +path, a modified PKG_CONFIG_PATH, etc. + +For example, you can enter this environment via invoking + + meta/uninstalled-env bash + +Within that shell, other packages should be able to build against +uninstalled Guile. Installing SLIB =========================================================== diff --git a/am/guilec b/am/guilec index aaa1747eb..fc2bdd0fa 100644 --- a/am/guilec +++ b/am/guilec @@ -10,6 +10,6 @@ CLEANFILES = $(GOBJECTS) SUFFIXES = .scm .go .scm.go: $(MKDIR_P) `dirname $@` - $(top_builddir)/pre-inst-guile \ + $(top_builddir)/meta/guile \ -l $(top_builddir)/libguile/stack-limit-calibration.scm \ $(top_srcdir)/scripts/compile -o "$@" "$<" diff --git a/am/pre-inst-guile b/am/pre-inst-guile index c1a7407c9..353908dfb 100644 --- a/am/pre-inst-guile +++ b/am/pre-inst-guile @@ -28,7 +28,7 @@ ## Code: -preinstguile = $(top_builddir_absolute)/pre-inst-guile +preinstguile = $(top_builddir_absolute)/meta/guile preinstguiletool = GUILE="$(preinstguile)" $(top_srcdir)/scripts ## am/pre-inst-guile ends here diff --git a/check-guile.in b/check-guile.in index 9ee2ea3f6..1c0101275 100644 --- a/check-guile.in +++ b/check-guile.in @@ -1,6 +1,6 @@ #! /bin/sh # Usage: check-guile [-i GUILE-INTERPRETER] [GUILE-TEST-ARGS] -# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/pre-inst-guile. +# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/meta/guile. # See ${top_srcdir}/test-suite/guile-test for documentation on GUILE-TEST-ARGS. # # Example invocations: @@ -21,7 +21,7 @@ if [ x"$1" = x-i ] ; then shift shift else - guile=${top_builddir}/pre-inst-guile + guile=${top_builddir}/meta/guile fi GUILE_LOAD_PATH=$TEST_SUITE_DIR diff --git a/configure.in b/configure.in index 60166d80f..68d0d6a24 100644 --- a/configure.in +++ b/configure.in @@ -1532,13 +1532,13 @@ AC_CONFIG_FILES([ doc/tutorial/Makefile emacs/Makefile examples/Makefile - guile-config/Makefile lang/Makefile libguile/Makefile scripts/Makefile srfi/Makefile test-suite/Makefile test-suite/standalone/Makefile + meta/Makefile module/Makefile module/ice-9/Makefile module/ice-9/debugger/Makefile @@ -1549,13 +1549,15 @@ AC_CONFIG_FILES([ testsuite/Makefile ]) -AC_CONFIG_FILES([guile-1.8.pc]) +AC_CONFIG_FILES([meta/guile-1.8.pc]) +AC_CONFIG_FILES([meta/guile-1.8-uninstalled.pc]) AC_CONFIG_FILES([check-guile], [chmod +x check-guile]) AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile]) -AC_CONFIG_FILES([guile-tools], [chmod +x guile-tools]) -AC_CONFIG_FILES([pre-inst-guile], [chmod +x pre-inst-guile]) -AC_CONFIG_FILES([pre-inst-guile-env], [chmod +x pre-inst-guile-env]) -AC_CONFIG_FILES([gdb-pre-inst-guile], [chmod +x gdb-pre-inst-guile]) +AC_CONFIG_FILES([meta/guile-config], [chmod +x meta/guile-config]) +AC_CONFIG_FILES([meta/guile-tools], [chmod +x meta/guile-tools]) +AC_CONFIG_FILES([meta/guile], [chmod +x meta/guile]) +AC_CONFIG_FILES([meta/uninstalled-env], [chmod +x meta/uninstalled-env]) +AC_CONFIG_FILES([meta/gdb-uninstalled-guile], [chmod +x meta/gdb-uninstalled-guile]) AC_CONFIG_FILES([libguile/guile-snarf], [chmod +x libguile/guile-snarf]) AC_CONFIG_FILES([libguile/guile-doc-snarf], diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 9799a5e0b..d534351dd 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -89,8 +89,8 @@ include $(top_srcdir)/am/pre-inst-guile # Automated snarfing autoconf.texi: autoconf-macros.texi -autoconf-macros.texi: $(top_srcdir)/guile-config/guile.m4 - $(preinstguiletool)/snarf-guile-m4-docs $(top_srcdir)/guile-config/guile.m4 \ +autoconf-macros.texi: $(top_srcdir)/meta/guile.m4 + $(preinstguiletool)/snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \ > $(srcdir)/$@ lib-version.texi: $(top_srcdir)/GUILE-VERSION diff --git a/gc-benchmarks/run-benchmark.scm b/gc-benchmarks/run-benchmark.scm index 509f978ee..a50fb48c2 100755 --- a/gc-benchmarks/run-benchmark.scm +++ b/gc-benchmarks/run-benchmark.scm @@ -233,7 +233,7 @@ Report bugs to .~%")) (ref-env (assoc-ref args 'reference-environment)) (bdwgc-env (or (assoc-ref args 'bdwgc-environment) (string-append "GUILE=" bench-dir - "/../pre-inst-guile"))) + "/../meta/guile"))) (prof-opts (assoc-ref args 'profile-options))) (for-each (lambda (benchmark) (let ((ref (parse-result (run-reference-guile ref-env diff --git a/guile-config/ChangeLog-2008 b/meta/ChangeLog-2008 similarity index 100% rename from guile-config/ChangeLog-2008 rename to meta/ChangeLog-2008 diff --git a/guile-config/Makefile.am b/meta/Makefile.am similarity index 59% rename from guile-config/Makefile.am rename to meta/Makefile.am index cedcba968..76544b30d 100644 --- a/guile-config/Makefile.am +++ b/meta/Makefile.am @@ -20,27 +20,14 @@ ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA -bin_SCRIPTS=guile-config -CLEANFILES=guile-config -EXTRA_DIST=guile-config.in guile.m4 ChangeLog-2008 +bin_SCRIPTS=guile-config guile-tools +EXTRA_DIST=guile-config.in guile-tools.in guile.m4 ChangeLog-2008 \ + guile-1.8.pc.in guile-1.8-uninstalled.pc.in + +pkgconfigdir = $(libdir)/pkgconfig +pkgconfig_DATA = guile-1.8.pc ## FIXME: in the future there will be direct automake support for ## doing this. When that happens, switch over. aclocaldir = $(datadir)/aclocal aclocal_DATA = guile.m4 - -## We use @-...-@ as the substitution brackets here, instead of the -## usual @...@, so autoconf doesn't go and substitute the values -## directly into the left-hand sides of the sed substitutions. *sigh* -guile-config: guile-config.in ${top_builddir}/libguile/libpath.h - rm -f guile-config.tmp - sed < ${srcdir}/guile-config.in > guile-config.tmp \ - -e 's|@-bindir-@|${bindir}|' \ - -e s:@-GUILE_VERSION-@:${GUILE_VERSION}: - chmod +x guile-config.tmp - mv guile-config.tmp guile-config - -## Get rid of any copies of the configuration script under the old -## name, so people don't end up running ancient copies of it. -install-exec-local: - rm -f ${bindir}/build-guile diff --git a/gdb-pre-inst-guile.in b/meta/gdb-uninstalled-guile.in similarity index 79% rename from gdb-pre-inst-guile.in rename to meta/gdb-uninstalled-guile.in index d1f4e38ec..457ab2bd7 100644 --- a/gdb-pre-inst-guile.in +++ b/meta/gdb-uninstalled-guile.in @@ -21,18 +21,18 @@ # Commentary: -# Usage: gdb-pre-inst-guile [ARGS] +# Usage: gdb-uninstalled-guile [ARGS] # # This script runs Guile from the build tree under GDB. See -# ./pre-inst-guile for more information. +# ./guile for more information. # -# In addition to running ./gdb-pre-inst-guile, sometimes it's useful to -# run e.g. ./check-guile -i ./gdb-pre-inst-guile foo.test. +# In addition to running ./gdb-uninstalled-guile, sometimes it's useful to +# run e.g. ./check-guile -i meta/gdb-uninstalled-guile foo.test. # Code: set -e # env (set by configure) top_builddir="@top_builddir_absolute@" -exec ${top_builddir}/pre-inst-guile-env libtool --mode=execute \ +exec ${top_builddir}/uninstalled-env libtool --mode=execute \ gdb --args ${top_builddir}/libguile/guile "$@" diff --git a/meta/guile-1.8-uninstalled.pc.in b/meta/guile-1.8-uninstalled.pc.in new file mode 100644 index 000000000..50d337fd3 --- /dev/null +++ b/meta/guile-1.8-uninstalled.pc.in @@ -0,0 +1,8 @@ +builddir=@abs_top_builddir@ +srcdir=@abs_top_srcdir@ + +Name: GNU Guile (uninstalled) +Description: GNU's Ubiquitous Intelligent Language for Extension (uninstalled) +Version: @GUILE_VERSION@ +Libs: -L${builddir}/libguile -lguile @GUILE_LIBS@ +Cflags: -I${srcdir} -I${builddir} @GUILE_CFLAGS@ diff --git a/guile-1.8.pc.in b/meta/guile-1.8.pc.in similarity index 100% rename from guile-1.8.pc.in rename to meta/guile-1.8.pc.in diff --git a/guile-config/guile-config.in b/meta/guile-config.in similarity index 99% rename from guile-config/guile-config.in rename to meta/guile-config.in index b782292d8..23c72e237 100644 --- a/guile-config/guile-config.in +++ b/meta/guile-config.in @@ -1,4 +1,4 @@ -#!@-bindir-@/guile \ +#!@bindir@/guile \ -e main -s !# ;;;; guile-config --- utility for linking programs with Guile @@ -47,7 +47,7 @@ (define program-name #f) (define subcommand-name #f) -(define program-version "@-GUILE_VERSION-@") +(define program-version "@GUILE_VERSION@") ;;; Given an executable path PATH, set program-name to something ;;; appropriate f or use in error messages (i.e., with leading diff --git a/guile-tools.in b/meta/guile-tools.in similarity index 100% rename from guile-tools.in rename to meta/guile-tools.in diff --git a/pre-inst-guile.in b/meta/guile.in similarity index 93% rename from pre-inst-guile.in rename to meta/guile.in index 5adbabea2..d7bc893e6 100644 --- a/pre-inst-guile.in +++ b/meta/guile.in @@ -21,7 +21,7 @@ # Commentary: -# Usage: pre-inst-guile [ARGS] +# Usage: guile [ARGS] # # This script arranges for the environment to support, and eventaully execs, # the uninstalled binary guile executable located somewhere under libguile/, @@ -43,9 +43,9 @@ GUILE=${top_builddir}/libguile/guile export GUILE # do it -exec ${top_builddir}/pre-inst-guile-env $GUILE "$@" +exec ${top_builddir}/meta/uninstalled-env $GUILE "$@" # never reached exit 1 -# pre-inst-guile ends here +# guile ends here diff --git a/guile-config/guile.m4 b/meta/guile.m4 similarity index 100% rename from guile-config/guile.m4 rename to meta/guile.m4 diff --git a/pre-inst-guile-env.in b/meta/uninstalled-env.in similarity index 87% rename from pre-inst-guile-env.in rename to meta/uninstalled-env.in index bb0a81c06..fa8285d94 100644 --- a/pre-inst-guile-env.in +++ b/meta/uninstalled-env.in @@ -18,17 +18,17 @@ # License along with this library; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -# NOTE: If you update this file, please update pre-inst-guile.in as +# NOTE: If you update this file, please update uninstalled.in as # well, if appropriate. -# Usage: pre-inst-guile-env [ARGS] +# Usage: uninstalled-env [ARGS] # This script arranges for the environment to support running Guile # from the build tree. The following env vars are modified (but not # clobbered): GUILE_LOAD_PATH, LTDL_LIBRARY_PATH, and PATH. -# Example: pre-inst-guile-env guile -c '(display "hello\n")' -# Example: ../../pre-inst-guile-env ./guile-test-foo +# Example: uninstalled-env guile -c '(display "hello\n")' +# Example: ../../uninstalled-env ./guile-test-foo # config subdirs_with_ltlibs="srfi guile-readline libguile" # maintain me @@ -83,9 +83,18 @@ export LTDL_LIBRARY_PATH DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH" export DYLD_LIBRARY_PATH +if [ x"$PKG_CONFIG_PATH" = x ] +then + PKG_CONFIG_PATH="${top_builddir}" +else + PKG_CONFIG_PATH="${top_builddir}:$PKG_CONFIG_PATH" +fi +export PKG_CONFIG_PATH + # handle PATH (no clobber) PATH="${top_builddir}/guile-config:${PATH}" PATH="${top_builddir}/libguile:${PATH}" +PATH="${top_builddir}/meta:${PATH}" export PATH exec "$@" diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 854a4a028..b8d6e81e4 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -28,7 +28,7 @@ check_SCRIPTS = BUILT_SOURCES = EXTRA_DIST = -TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env" +TESTS_ENVIRONMENT = "${top_builddir}/meta/uninstalled-env" test_cflags = \ -I$(top_srcdir)/test-suite/standalone \ diff --git a/test-suite/standalone/README b/test-suite/standalone/README index 4e0bd652e..164c6ab46 100644 --- a/test-suite/standalone/README +++ b/test-suite/standalone/README @@ -12,7 +12,7 @@ If you want to use a scheme script, prefix it as follows: !# Makefile.am will arrange for all tests (scripts or executables) to be -run under pre-inst-guile-env so that the PATH, LD_LIBRARY_PATH, and +run under uninstalled-env so that the PATH, LD_LIBRARY_PATH, and GUILE_LOAD_PATH will be augmented appropriately. The Makefile.am has an example of creating a shared library to be used diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am index c523eff8d..2bc78142c 100644 --- a/testsuite/Makefile.am +++ b/testsuite/Makefile.am @@ -1,5 +1,5 @@ TESTS_ENVIRONMENT = \ - $(top_builddir)/pre-inst-guile \ + $(top_builddir)/meta/guile \ -l $(srcdir)/run-vm-tests.scm -e run-vm-tests TESTS = \ From 4ea9429edc9c95d521b68b9880b646a328650079 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 15:06:41 -0700 Subject: [PATCH 008/375] add getrlimit and setrlimit wrappers * README: Some rewording. * configure.in: Check for getrlimit and setrlimit. * libguile/posix.h: * libguile/posix.c: Add some getrlimit and setrlimit wrappers. They're documented, but I suspect something else has to be done to get them into the manual. --- README | 8 +-- configure.in | 2 + libguile/posix.c | 174 +++++++++++++++++++++++++++++++++++++++++++++++ libguile/posix.h | 2 + 4 files changed, 182 insertions(+), 4 deletions(-) diff --git a/README b/README index 4e295f805..9993fcfaf 100644 --- a/README +++ b/README @@ -229,10 +229,10 @@ that this is not the same "guile" as the one that is installed; this "guile" is a wrapper script that sets up the environment appropriately, then invokes the Guile binary. -You may also build against an uninstalled Guile build tree. The -"uninstalled-env" script in the "meta/" subdirectory will set up an -environment with a path including "meta/", a modified dynamic linker -path, a modified PKG_CONFIG_PATH, etc. +You may also build external packages against an uninstalled Guile build +tree. The "uninstalled-env" script in the "meta/" subdirectory will set +up an environment with a path including "meta/", a modified dynamic +linker path, a modified PKG_CONFIG_PATH, etc. For example, you can enter this environment via invoking diff --git a/configure.in b/configure.in index 68d0d6a24..9503fcbcd 100644 --- a/configure.in +++ b/configure.in @@ -883,6 +883,8 @@ if test -n "$have_sys_un_h" ; then [Define if the system supports Unix-domain (file-domain) sockets.]) fi +AC_CHECK_FUNCS(getrlimit setrlimit) + AC_CHECK_FUNCS(socketpair getgroups setgroups setpwent pause tzset) AC_CHECK_FUNCS(sethostent gethostent endhostent dnl diff --git a/libguile/posix.c b/libguile/posix.c index 00e0fa1a3..78fd295b5 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -33,6 +33,7 @@ #include "libguile/srfi-13.h" #include "libguile/srfi-14.h" #include "libguile/vectors.h" +#include "libguile/values.h" #include "libguile/lang.h" #include "libguile/validate.h" @@ -463,6 +464,179 @@ SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0, #endif /* HAVE_GETGRENT */ +#ifdef HAVE_GETRLIMIT +#ifdef RLIMIT_AS +SCM_SYMBOL (sym_as, "as"); +#endif +#ifdef RLIMIT_CORE +SCM_SYMBOL (sym_core, "core"); +#endif +#ifdef RLIMIT_CPU +SCM_SYMBOL (sym_cpu, "cpu"); +#endif +#ifdef RLIMIT_DATA +SCM_SYMBOL (sym_data, "data"); +#endif +#ifdef RLIMIT_FSIZE +SCM_SYMBOL (sym_fsize, "fsize"); +#endif +#ifdef RLIMIT_MEMLOCK +SCM_SYMBOL (sym_memlock, "memlock"); +#endif +#ifdef RLIMIT_MSGQUEUE +SCM_SYMBOL (sym_msgqueue, "msgqueue"); +#endif +#ifdef RLIMIT_NICE +SCM_SYMBOL (sym_nice, "nice"); +#endif +#ifdef RLIMIT_NOFILE +SCM_SYMBOL (sym_nofile, "nofile"); +#endif +#ifdef RLIMIT_NPROC +SCM_SYMBOL (sym_nproc, "nproc"); +#endif +#ifdef RLIMIT_RSS +SCM_SYMBOL (sym_rss, "rss"); +#endif +#ifdef RLIMIT_RTPRIO +SCM_SYMBOL (sym_rtprio, "rtprio"); +#endif +#ifdef RLIMIT_RTPRIO +SCM_SYMBOL (sym_rttime, "rttime"); +#endif +#ifdef RLIMIT_SIGPENDING +SCM_SYMBOL (sym_sigpending, "sigpending"); +#endif +#ifdef RLIMIT_STACK +SCM_SYMBOL (sym_stack, "stack"); +#endif + +static int +scm_to_resource (SCM s, const char *func, int pos) +{ + if (scm_is_number (s)) + return scm_to_int (s); + + SCM_ASSERT_TYPE (scm_is_symbol (s), s, pos, func, "symbol"); + +#ifdef RLIMIT_AS + if (s == sym_as) + return RLIMIT_AS; +#endif +#ifdef RLIMIT_CORE + if (s == sym_core) + return RLIMIT_CORE; +#endif +#ifdef RLIMIT_CPU + if (s == sym_cpu) + return RLIMIT_CPU; +#endif +#ifdef RLIMIT_DATA + if (s == sym_data) + return RLIMIT_DATA; +#endif +#ifdef RLIMIT_FSIZE + if (s == sym_fsize) + return RLIMIT_FSIZE; +#endif +#ifdef RLIMIT_MEMLOCK + if (s == sym_memlock) + return RLIMIT_MEMLOCK; +#endif +#ifdef RLIMIT_MSGQUEUE + if (s == sym_msgqueue) + return RLIMIT_MSGQUEUE; +#endif +#ifdef RLIMIT_NICE + if (s == sym_nice) + return RLIMIT_NICE; +#endif +#ifdef RLIMIT_NOFILE + if (s == sym_nofile) + return RLIMIT_NOFILE; +#endif +#ifdef RLIMIT_NPROC + if (s == sym_nproc) + return RLIMIT_NPROC; +#endif +#ifdef RLIMIT_RSS + if (s == sym_rss) + return RLIMIT_RSS; +#endif +#ifdef RLIMIT_RTPRIO + if (s == sym_rtprio) + return RLIMIT_RTPRIO; +#endif +#ifdef RLIMIT_RTPRIO + if (s == sym_rttime) + return RLIMIT_RTPRIO; +#endif +#ifdef RLIMIT_SIGPENDING + if (s == sym_sigpending) + return RLIMIT_SIGPENDING; +#endif +#ifdef RLIMIT_STACK + if (s == sym_stack) + return RLIMIT_STACK; +#endif + + scm_misc_error (func, "invalid rlimit resource ~A", scm_list_1 (s)); + return 0; +} + +SCM_DEFINE (scm_getrlimit, "getrlimit", 1, 0, 0, + (SCM resource), + "Get a resource limit for this process. @var{resource} identifies the resource,\n" + "either as an integer or as a symbol. For example, @code{(getrlimit 'stack)}\n" + "gets the limits associated with @code{RLIMIT_STACK}.\n\n" + "@code{getrlimit} returns two values, the soft and the hard limit. If no\n" + "limit is set for the resource in question, the returned limit will be @code{#f}.") +#define FUNC_NAME s_scm_getrlimit +{ + int iresource; + struct rlimit lim = { 0, 0 }; + + iresource = scm_to_resource (resource, FUNC_NAME, 1); + + if (getrlimit (iresource, &lim) != 0) + scm_syserror (FUNC_NAME); + + return scm_values (scm_list_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F + : scm_from_long (lim.rlim_cur), + (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F + : scm_from_long (lim.rlim_max))); +} +#undef FUNC_NAME + + +#ifdef HAVE_SETRLIMIT +SCM_DEFINE (scm_setrlimit, "setrlimit", 3, 0, 0, + (SCM resource, SCM soft, SCM hard), + "Set a resource limit for this process. @var{resource} identifies the resource,\n" + "either as an integer or as a symbol. @var{soft} and @var{hard} should be integers,\n" + "or @code{#f} to indicate no limit (i.e., @code{RLIM_INFINITY}).\n\n" + "For example, @code{(setrlimit 'stack 150000 300000)} sets the @code{RLIMIT_STACK}\n" + "limit to 150 kilobytes, with a hard limit of 300 kB.") +#define FUNC_NAME s_scm_setrlimit +{ + int iresource; + struct rlimit lim = { 0, 0 }; + + iresource = scm_to_resource (resource, FUNC_NAME, 1); + + lim.rlim_cur = (soft == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (soft); + lim.rlim_max = (hard == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (hard); + + if (setrlimit (iresource, &lim) != 0) + scm_syserror (FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_SETRLIMIT */ +#endif /* HAVE_GETRLIMIT */ + + SCM_DEFINE (scm_kill, "kill", 2, 0, 0, (SCM pid, SCM sig), "Sends a signal to the specified process or group of processes.\n\n" diff --git a/libguile/posix.h b/libguile/posix.h index 34e1fc77f..6d282e0bf 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -41,6 +41,8 @@ SCM_API SCM scm_getpwuid (SCM user); SCM_API SCM scm_setpwent (SCM arg); SCM_API SCM scm_getgrgid (SCM name); SCM_API SCM scm_setgrent (SCM arg); +SCM_API SCM scm_getrlimit (SCM resource); +SCM_API SCM scm_setrlimit (SCM resource, SCM soft, SCM hard); SCM_API SCM scm_kill (SCM pid, SCM sig); SCM_API SCM scm_waitpid (SCM pid, SCM options); SCM_API SCM scm_status_exit_val (SCM status); From ec900eacb71bbf66b85a5605f67f83b43f2c6ca8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 15:44:17 -0700 Subject: [PATCH 009/375] getrlimit-based stack limits * libguile/debug.c (init_stack_limit): Initialize the stack limit based on operating system limits (via getrlimit(2)), or 1 MB -- whichever is smaller. --- libguile/debug.c | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/libguile/debug.c b/libguile/debug.c index 5d0e20899..ec37d3aaa 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -21,6 +21,11 @@ # include #endif +#ifdef HAVE_GETRLIMIT +#include +#include +#endif + #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/eval.h" @@ -513,11 +518,42 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, #undef FUNC_NAME #endif +static void +init_stack_limit (void) +{ +#ifdef HAVE_GETRLIMIT + struct rlimit lim; + if (getrlimit (RLIMIT_STACK, &lim) == 0) + { + int bytes = lim.rlim_cur, words; + + /* set our internal stack limit to 1 MB or 80% of the rlimit, whichever + is lower. */ + if (bytes == RLIM_INFINITY) + bytes = lim.rlim_max; + + if (bytes == RLIM_INFINITY) + words = 1024 * 1024 / sizeof (scm_t_bits); + else + { + bytes = bytes * 8 / 10; + if (bytes > 1024 * 1024) + bytes = 1024 * 1024; + words = bytes / sizeof (scm_t_bits); + } + + SCM_STACK_LIMIT = words; + } + errno = 0; +#endif +} + void scm_init_debug () { + init_stack_limit (); scm_init_opts (scm_debug_options, scm_debug_opts); scm_tc16_memoized = scm_make_smob_type ("memoized", 0); From 23ccb831ff1565072a1977d5fbc1f98aed388e57 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 15:51:16 -0700 Subject: [PATCH 010/375] rely on getrlimit to DTRT, don't make stack calibration file * libguile/measure-hwm.scm: Remove. * .gitignore: Update for removal. * test-suite/standalone/test-fast-slot-ref.in: * test-suite/standalone/test-use-srfi.in: * am/guilec: * check-guile.in: Revert back to normal guile invocation. * libguile/Makefile.am: Don't make a stack calibration file, as the getrlimit-based limit setting should work fine. --- .gitignore | 1 - am/guilec | 4 +- check-guile.in | 1 - libguile/Makefile.am | 22 +--- libguile/measure-hwm.scm | 136 -------------------- test-suite/standalone/test-fast-slot-ref.in | 2 +- test-suite/standalone/test-use-srfi.in | 6 +- 7 files changed, 7 insertions(+), 165 deletions(-) delete mode 100644 libguile/measure-hwm.scm diff --git a/.gitignore b/.gitignore index 884d819f1..3aa1f0471 100644 --- a/.gitignore +++ b/.gitignore @@ -72,7 +72,6 @@ guile-readline/guile-readline-config.h.in TAGS guile-1.8.pc gdb-pre-inst-guile -libguile/stack-limit-calibration.scm cscope.out cscope.files *.log diff --git a/am/guilec b/am/guilec index fc2bdd0fa..f8690d305 100644 --- a/am/guilec +++ b/am/guilec @@ -10,6 +10,4 @@ CLEANFILES = $(GOBJECTS) SUFFIXES = .scm .go .scm.go: $(MKDIR_P) `dirname $@` - $(top_builddir)/meta/guile \ - -l $(top_builddir)/libguile/stack-limit-calibration.scm \ - $(top_srcdir)/scripts/compile -o "$@" "$<" + $(top_builddir)/meta/uninstalled-env guile-tools compile -o "$@" "$<" diff --git a/check-guile.in b/check-guile.in index 1c0101275..3162fa6fc 100644 --- a/check-guile.in +++ b/check-guile.in @@ -41,7 +41,6 @@ if [ ! -f guile-procedures.txt ] ; then fi exec $guile \ - -l ${top_builddir}/libguile/stack-limit-calibration.scm \ -e main -s "$TEST_SUITE_DIR/guile-test" \ --test-suite "$TEST_SUITE_DIR/tests" \ --log-file check-guile.log "$@" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 580114093..0f9a542ad 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -256,7 +256,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ c-tokenize.lex version.h.in \ - scmconfig.h.top libgettext.h measure-hwm.scm + scmconfig.h.top libgettext.h # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi @@ -351,24 +351,6 @@ guile-procedures.txt: guile-procedures.texi endif -# Stack limit calibration to allow the compiler to run when creating -# the initial `.go' files and for `make check'. (For why we do this, see -# the comments in measure-hwm.scm.) -# -# The fact that "libguile" comes before "module" and "test-suite" -# in SUBDIRS in our toplevel Makefile.am ensures that the -# stack-limit-calibration.scm program will be run before we compile -# files or run tests. -# -# We don't care about the exit code of `measure-hwm.scm' because the -# important thing about stack-limit-calibration.scm is just that it is -# generated in the first place, so that it can be loaded in `am/guilec' -# and by the test suite. -BUILT_SOURCES += stack-limit-calibration.scm - -stack-limit-calibration.scm: measure-hwm.scm guile$(EXEEXT) - -$(preinstguile) -s $(srcdir)/measure-hwm.scm > $@ - c-tokenize.c: c-tokenize.lex flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; } @@ -423,7 +405,7 @@ MOSTLYCLEANFILES = \ cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \ cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new \ version.h version.h.tmp \ - scmconfig.h scmconfig.h.tmp stack-limit-calibration.scm + scmconfig.h scmconfig.h.tmp CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi diff --git a/libguile/measure-hwm.scm b/libguile/measure-hwm.scm deleted file mode 100644 index 53a30d560..000000000 --- a/libguile/measure-hwm.scm +++ /dev/null @@ -1,136 +0,0 @@ -;;;; Copyright (C) 2008 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; - -;;; Commentary: - -;;; This code is run during the Guile build, in order to set the stack -;;; limit to a value that will allow the `make check' tests to pass, -;;; taking into account the average stack usage on the build platform. -;;; For more detail, see the text below that gets written out to the -;;; stack limit calibration file. - -;;; Code: - -;; Store off Guile's default stack limit. -(define default-stack-limit (cadr (memq 'stack (debug-options)))) - -;; Now disable the stack limit, so that we don't get a stack overflow -;; while running this code! -(debug-set! stack 0) - -;; Define a variable to hold the measured stack high water mark (HWM). -(define top-repl-hwm-measured 0) - -;; Use an evaluator trap to measure the stack size at every -;; evaluation step, and increase top-repl-hwm-measured if it is less -;; than the measured stack size. -(trap-set! enter-frame-handler - (lambda _ - (let ((stack-size (%get-stack-size))) - (if (< top-repl-hwm-measured stack-size) - (set! top-repl-hwm-measured stack-size))))) -(trap-enable 'enter-frame) -(trap-enable 'traps) - -;; Call (turn-on-debugging) and (top-repl) in order to simulate as -;; closely as possible what happens - and in particular, how much -;; stack is used - when a standard Guile REPL is started up. -;; -;; `make check' stack overflow errors have been reported in the past -;; for: -;; -;; - test-suite/standalone/test-use-srfi, which runs `guile -q -;; --use-srfi=...' a few times, with standard input for the REPL -;; coming from a shell script -;; -;; - test-suite/tests/elisp.test, which does not involve the REPL, but -;; has a lot of `use-modules' calls. -;; -;; Stack high water mark (HWM) measurements show that the HWM is -;; higher in the test-use-srfi case - specifically because of the -;; complexity of (top-repl) - so that is what we simulate for our -;; calibration model here. -(turn-on-debugging) -(with-output-to-port (%make-void-port "w") - (lambda () - (with-input-from-string "\n" top-repl))) - -;; top-repl-hwm-measured now contains the stack HWM that resulted from -;; running that code. - -;; This is the value of top-repl-hwm-measured that we get on a -;; `canonical' build platform. (See text below for what that means.) -(define top-repl-hwm-i686-pc-linux-gnu 9461) - -;; Using the above results, output code that tests can run in order to -;; configure the stack limit correctly for the current build platform. -(format #t "\ -;; Stack limit calibration file. -;; -;; This file is automatically generated by Guile when it builds, in -;; order to set the stack limit to a value that reflects the stack -;; usage of the build platform (OS + compiler + compilation options), -;; specifically so that none of Guile's own tests (which are run by -;; `make check') fail because of a benign stack overflow condition. -;; -;; By a `benign' stack overflow condition, we mean one where the test -;; code is behaving correctly, but exceeds the configured stack limit -;; because the limit is set too low. A non-benign stack overflow -;; condition would be if a piece of test code behaved significantly -;; differently on some platform to how it does normally, and as a -;; result consumed a lot more stack. Although they seem pretty -;; unlikely, we would want to catch non-benign conditions like this, -;; and that is why we don't just do `(debug-set! stack 0)' when -;; running `make check'. -;; -;; Although the primary purpose of this file is to prevent `make -;; check' from failing without good reason, Guile developers and users -;; may also find the following information useful, when determining -;; what stack limit to configure for their own programs. - - (let (;; The stack high water mark measured when starting up the - ;; standard Guile REPL on the current build platform. - (top-repl-hwm-measured ~a) - - ;; The value of top-repl-hwm-measured that we get when building - ;; Guile on an i686 PC GNU/Linux system, after configuring with - ;; `./configure --enable-maintainer-mode --with-threads'. - ;; (Hereafter referred to as the `canonical' build platform.) - (top-repl-hwm-i686-pc-linux-gnu ~a) - - ;; Guile's default stack limit (i.e. the initial, C-coded value - ;; of the 'stack debug option). In the context of this file, - ;; the important thing about this number is that we know that - ;; it allows all of the `make check' tests to pass on the - ;; canonical build platform. - (default-stack-limit ~a) - - ;; Calibrated stack limit. This is the default stack limit, - ;; scaled by the factor between top-repl-hwm-i686-pc-linux-gnu - ;; and top-repl-hwm-measured. - (calibrated-stack-limit ~a)) - - ;; Configure the calibrated stack limit. - (debug-set! stack calibrated-stack-limit)) -" - top-repl-hwm-measured - top-repl-hwm-i686-pc-linux-gnu - default-stack-limit - ;; Use quotient here to get an integer result, rather than a - ;; rational. - (quotient (* default-stack-limit top-repl-hwm-measured) - top-repl-hwm-i686-pc-linux-gnu)) diff --git a/test-suite/standalone/test-fast-slot-ref.in b/test-suite/standalone/test-fast-slot-ref.in index 5bd063876..774cfe269 100644 --- a/test-suite/standalone/test-fast-slot-ref.in +++ b/test-suite/standalone/test-fast-slot-ref.in @@ -25,7 +25,7 @@ # executing the (%fast-slot-ref i 3) line. For reasons as yet # unknown, it does not cause a segmentation fault if the same code is # loaded as a script; that is why we run it here using "guile -q </dev/null 2>&1 </dev/null 2>&1 < () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3)) diff --git a/test-suite/standalone/test-use-srfi.in b/test-suite/standalone/test-use-srfi.in index 57f84afe4..7186b5a24 100755 --- a/test-suite/standalone/test-use-srfi.in +++ b/test-suite/standalone/test-use-srfi.in @@ -19,7 +19,7 @@ # Test that two srfi numbers on the command line work. # -guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1,10 >/dev/null </dev/null </dev/null </dev/null </dev/null </dev/null < Date: Fri, 27 Mar 2009 16:01:12 -0700 Subject: [PATCH 011/375] fix check for guile-tools running uninstalled * meta/guile-tools.in (mydir): Fix check for running uninstalled. --- meta/guile-tools.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/meta/guile-tools.in b/meta/guile-tools.in index ca940a0da..68db26887 100644 --- a/meta/guile-tools.in +++ b/meta/guile-tools.in @@ -53,7 +53,7 @@ top_builddir="@top_builddir_absolute@" # pre-install invocation frob mydir=$(cd $(dirname $0) && pwd) -if [ "$mydir" = "$top_builddir" ] ; then +if [ "$mydir" = "$top_builddir/meta" ] ; then default_scriptsdir=$top_srcdir/scripts fi From 7f864744889aea02c14604ede2b181f6e72a7504 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 16:11:43 -0700 Subject: [PATCH 012/375] fix "linking" of guile-config * meta/guile-config.in: Adjust "linking"; @bindir@ doesn't get fully expanded. So instead use a shell trampoline. --- meta/guile-config.in | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/meta/guile-config.in b/meta/guile-config.in index 23c72e237..b1640b629 100644 --- a/meta/guile-config.in +++ b/meta/guile-config.in @@ -1,5 +1,6 @@ -#!@bindir@/guile \ --e main -s +#!/bin/sh +bindir=`dirname $0` +exec $bindir/guile -e main -s $0 "$@" !# ;;;; guile-config --- utility for linking programs with Guile ;;;; Jim Blandy --- September 1997 From 845952664b24861b40d23660bb4509a967d1a271 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 16:21:20 -0700 Subject: [PATCH 013/375] fix distcheck hopefully, by cleaning the vm-i-*.i files * libguile/Makefile.am (CLEANFILES): Clean vm-i-*.i. --- libguile/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 0f9a542ad..8f26e34d2 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -407,6 +407,7 @@ MOSTLYCLEANFILES = \ version.h version.h.tmp \ scmconfig.h scmconfig.h.tmp -CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi +CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi \ + vm-i-*.i MAINTAINERCLEANFILES = c-tokenize.c From 60ae5ca2a31a89b8930089f7dbfa3a99ac727383 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 18:40:15 -0700 Subject: [PATCH 014/375] frame, program, objcode, etc inits use load-extension * libguile/extensions.h: Define a scm_t_extension_init_func. * libguile/frames.c: * libguile/instructions.c: * libguile/objcodes.c: * libguile/programs.c: * libguile/vm.c: Register extension init funcs. Should play nicer with a static Guile, in addition to working on Darwin with non-default installation prefixes without munging DYLD_LIBRARY_PATH. * module/system/vm/frame.scm: * module/system/vm/instruction.scm: * module/system/vm/objcode.scm: * module/system/vm/program.scm: * module/system/vm/vm.scm: Use load-extension. --- libguile/extensions.h | 2 ++ libguile/frames.c | 2 ++ libguile/instructions.c | 3 +++ libguile/objcodes.c | 2 ++ libguile/programs.c | 2 ++ libguile/vm.c | 3 +++ module/system/vm/frame.scm | 3 +-- module/system/vm/instruction.scm | 2 +- module/system/vm/objcode.scm | 2 +- module/system/vm/program.scm | 2 +- module/system/vm/vm.scm | 2 +- 11 files changed, 19 insertions(+), 6 deletions(-) diff --git a/libguile/extensions.h b/libguile/extensions.h index 596b43ae0..260567e51 100644 --- a/libguile/extensions.h +++ b/libguile/extensions.h @@ -26,6 +26,8 @@ +typedef void (*scm_t_extension_init_func)(void*); + SCM_API void scm_c_register_extension (const char *lib, const char *init, void (*func) (void *), void *data); diff --git a/libguile/frames.c b/libguile/frames.c index 647cb608d..eb3bc22ee 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -297,6 +297,8 @@ scm_bootstrap_frames (void) scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark); scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free); scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print); + scm_c_register_extension ("libguile", "scm_init_frames", + (scm_t_extension_init_func)scm_init_frames, NULL); } void diff --git a/libguile/instructions.c b/libguile/instructions.c index b33c8d203..4f504f0a2 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -215,6 +215,9 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0, void scm_bootstrap_instructions (void) { + scm_c_register_extension ("libguile", "scm_init_instructions", + (scm_t_extension_init_func)scm_init_instructions, + NULL); } void diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 3e30b2d60..c53cf2253 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -266,6 +266,8 @@ scm_bootstrap_objcodes (void) { scm_tc16_objcode = scm_make_smob_type ("objcode", 0); scm_set_smob_mark (scm_tc16_objcode, objcode_mark); + scm_c_register_extension ("libguile", "scm_init_objcodes", + (scm_t_extension_init_func)scm_init_objcodes, NULL); } /* Before, we used __BYTE_ORDER, but that is not defined on all diff --git a/libguile/programs.c b/libguile/programs.c index 1d6318c6c..c97f61e13 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -368,6 +368,8 @@ scm_bootstrap_programs (void) scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1; scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2; scm_set_smob_print (scm_tc16_program, program_print); + scm_c_register_extension ("libguile", "scm_init_programs", + (scm_t_extension_init_func)scm_init_programs, NULL); } void diff --git a/libguile/vm.c b/libguile/vm.c index 0646becdb..53e9e154e 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -662,6 +662,9 @@ scm_bootstrap_vm (void) sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error")); sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug")); + scm_c_register_extension ("libguile", "scm_init_vm", + (scm_t_extension_init_func)scm_init_vm, NULL); + strappage = 1; } diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index a74d903da..33a1e1b60 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -42,8 +42,7 @@ frame-return-address frame-program frame-dynamic-link heap-frame?)) -;; fixme: avoid the dynamic-call? -(dynamic-call "scm_init_frames" (dynamic-link "libguile")) +(load-extension "libguile" "scm_init_frames") ;;; ;;; Frame chain diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm index c820e9952..3ad718ea8 100644 --- a/module/system/vm/instruction.scm +++ b/module/system/vm/instruction.scm @@ -25,4 +25,4 @@ instruction-pops instruction-pushes instruction->opcode opcode->instruction)) -(dynamic-call "scm_init_instructions" (dynamic-link "libguile")) +(load-extension "libguile" "scm_init_instructions") diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm index df1ff26e4..ab6bb4bae 100644 --- a/module/system/vm/objcode.scm +++ b/module/system/vm/objcode.scm @@ -25,4 +25,4 @@ load-objcode write-objcode word-size byte-order)) -(dynamic-call "scm_init_objcodes" (dynamic-link "libguile")) +(load-extension "libguile" "scm_init_objcodes") diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 7e4007b75..5a490b9d9 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -36,7 +36,7 @@ program-objcode program? program-objects program-module program-base program-external)) -(dynamic-call "scm_init_programs" (dynamic-link "libguile")) +(load-extension "libguile" "scm_init_programs") (define arity:nargs car) (define arity:nrest cadr) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm index de5c3fa21..48dc4f2b8 100644 --- a/module/system/vm/vm.scm +++ b/module/system/vm/vm.scm @@ -32,7 +32,7 @@ vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook)) -(dynamic-call "scm_init_vm" (dynamic-link "libguile")) +(load-extension "libguile" "scm_init_vm") (define (vms:time stat) (vector-ref stat 0)) (define (vms:clock stat) (vector-ref stat 1)) From a5fc657043e1af9b2e79799059069f8172afb66c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Mar 2009 18:47:13 -0700 Subject: [PATCH 015/375] bugfix: don't dynamic link if we found a registered extension * libguile/extensions.c (load_extension): Don't do dynamic linking if we actually did find an extension in the list. --- libguile/extensions.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/extensions.c b/libguile/extensions.c index 1090b8bd5..29cb58cbe 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -76,6 +76,7 @@ load_extension (SCM lib, SCM init) { extension_t *ext; char *clib, *cinit; + int found = 0; scm_dynwind_begin (0); @@ -89,10 +90,14 @@ load_extension (SCM lib, SCM init) && !strcmp (ext->init, cinit)) { ext->func (ext->data); + found = 1; break; } scm_dynwind_end (); + + if (found) + return; } /* Dynamically link the library. */ From 154a6116699b5be1bc7b4968e497c8542fca7076 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 28 Mar 2009 21:57:26 -0700 Subject: [PATCH 016/375] fix spurious duplicates in procedure-callees and callers * module/system/xref.scm (program-callee-rev-vars): It's possible to get duplicates when combining callees of inner procedures, so ignore dups. Quadratic, boo. --- module/system/xref.scm | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/module/system/xref.scm b/module/system/xref.scm index ea419079f..db6823844 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -20,11 +20,14 @@ #:use-module (system base pmatch) #:use-module (system base compile) #:use-module (system vm program) + #:use-module (srfi srfi-1) #:export (*xref-ignored-modules* procedure-callees procedure-callers)) (define (program-callee-rev-vars prog) + (define (cons-uniq x y) + (if (memq x y) y (cons x y))) (cond ((program-objects prog) => (lambda (objects) @@ -44,19 +47,19 @@ ((= i n) out) ((program? (vector-ref objects i)) (lp (1+ i) - (append (program-callee-rev-vars (vector-ref objects i)) - out))) + (fold cons-uniq out + (program-callee-rev-vars (vector-ref objects i))))) ((vector-ref progv i) (let ((obj (vector-ref objects i))) (if (variable? obj) - (lp (1+ i) (cons obj out)) + (lp (1+ i) (cons-uniq obj out)) ;; otherwise it's an unmemoized binding (pmatch obj (,sym (guard (symbol? sym)) (let ((v (module-variable (or (program-module prog) the-root-module) sym))) - (lp (1+ i) (if v (cons v out) out)))) + (lp (1+ i) (if v (cons-uniq v out) out)))) ((,mod ,sym ,public?) ;; hm, hacky. (let* ((m (nested-ref the-root-module @@ -68,7 +71,7 @@ m) sym)))) (lp (1+ i) - (if v (cons v out) out)))))))) + (if v (cons-uniq v out) out)))))))) (else (lp (1+ i) out))))))) (else '()))) @@ -102,8 +105,8 @@ (for-each (lambda (callee) (if (variable-bound? callee) - (let ((y (variable-ref callee))) - (hashq-set! db callee (cons x (hashq-ref db callee '())))))) + (hashq-set! db callee + (cons x (hashq-ref db callee '()))))) (procedure-callee-rev-vars x))) ((and (module? x) (not (memq x visited))) (visit-module x)))))) @@ -130,6 +133,6 @@ ((,modname . ,sym) (module-variable (resolve-module modname) sym)) (else - (error "expected a variable, symbol, or (modname sym)" var))))))) + (error "expected a variable, symbol, or (modname . sym)" var))))))) (ensure-callers-db) (hashq-ref *callers-db* v '()))) From 6ecae97fb8dca2e5e26af44a649a706431c65756 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 28 Mar 2009 22:21:00 -0700 Subject: [PATCH 017/375] fix duplicates in procedure-callers * module/system/xref.scm (ensure-callers-db): OK! Since we can see the same variable twice, e.g. in different modules, keep a unified hash of seen vars and modules. Prevents duplicates in procedure-callers. --- module/system/xref.scm | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/module/system/xref.scm b/module/system/xref.scm index db6823844..be44225f3 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -95,24 +95,26 @@ (set! *callers-db* #f))) (define (ensure-callers-db) - (let ((visited '()) + (let ((visited #f) (db #f)) (define (visit-variable var) (if (variable-bound? var) (let ((x (variable-ref var))) (cond + ((hashq-ref visited x)) ((procedure? x) + (hashq-set! visited x #t) (for-each (lambda (callee) (if (variable-bound? callee) (hashq-set! db callee (cons x (hashq-ref db callee '()))))) (procedure-callee-rev-vars x))) - ((and (module? x) (not (memq x visited))) + ((module? x) (visit-module x)))))) (define (visit-module mod) - (set! visited (cons mod visited)) + (hashq-set! visited mod #t) (if (not (memq on-module-modified (module-observers mod))) (module-observe mod on-module-modified)) (module-for-each (lambda (sym var) @@ -121,7 +123,8 @@ (if (not *callers-db*) (begin - (set! db (make-hash-table)) + (set! db (make-hash-table 1000)) + (set! visited (make-hash-table 1000)) (visit-module the-root-module) (set! *callers-db* db))))) From a44c43368b5a6c423e0498b6df734b969df2fdde Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 Mar 2009 20:28:30 -0700 Subject: [PATCH 018/375] add test case for load-extension bug, fix gdb-uninstalled-guile * test-suite/standalone/test-extensions: * test-suite/standalone/test-extensions-lib.c: * test-suite/standalone/Makefile.am: Add a test case for the load-extension bug. * meta/gdb-uninstalled-guile.in: Fix the path to include meta/. --- meta/gdb-uninstalled-guile.in | 2 +- test-suite/standalone/Makefile.am | 9 +++++ test-suite/standalone/test-extensions | 14 +++++++ test-suite/standalone/test-extensions-lib.c | 43 +++++++++++++++++++++ 4 files changed, 67 insertions(+), 1 deletion(-) create mode 100755 test-suite/standalone/test-extensions create mode 100644 test-suite/standalone/test-extensions-lib.c diff --git a/meta/gdb-uninstalled-guile.in b/meta/gdb-uninstalled-guile.in index 457ab2bd7..aa33e0799 100644 --- a/meta/gdb-uninstalled-guile.in +++ b/meta/gdb-uninstalled-guile.in @@ -34,5 +34,5 @@ set -e # env (set by configure) top_builddir="@top_builddir_absolute@" -exec ${top_builddir}/uninstalled-env libtool --mode=execute \ +exec ${top_builddir}/meta/uninstalled-env libtool --mode=execute \ gdb --args ${top_builddir}/libguile/guile "$@" diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index b8d6e81e4..9bfd801d8 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -125,6 +125,15 @@ test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/libguile.la check_PROGRAMS += test-scm-take-locale-symbol TESTS += test-scm-take-locale-symbol +# test-extensions +noinst_LTLIBRARIES += libtest-extensions.la +libtest_extensions_la_SOURCES = test-extensions-lib.c +libtest_extensions_la_CFLAGS = ${test_cflags} +libtest_extensions_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so +libtest_extensions_la_LIBADD = ${top_builddir}/libguile/libguile.la +check_SCRIPTS += test-extensions +TESTS += test-extensions + if BUILD_PTHREAD_SUPPORT diff --git a/test-suite/standalone/test-extensions b/test-suite/standalone/test-extensions new file mode 100755 index 000000000..bea432de2 --- /dev/null +++ b/test-suite/standalone/test-extensions @@ -0,0 +1,14 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# + +(load-extension "libtest-extensions" "libtest_extensions_init") +(load-extension "libtest-extensions" "libtest_extensions_init2") + +(or (= init2-count 1) + (error "init2 called more or less than one time")) + + +;; Local Variables: +;; mode: scheme +;; End: \ No newline at end of file diff --git a/test-suite/standalone/test-extensions-lib.c b/test-suite/standalone/test-extensions-lib.c new file mode 100644 index 000000000..25b3a38a9 --- /dev/null +++ b/test-suite/standalone/test-extensions-lib.c @@ -0,0 +1,43 @@ +/* Copyright (C) 1999,2000,2001,2003, 2006, 2008 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#ifndef HAVE_CONFIG_H +# include +#endif + +#include + +SCM init2_count; + +void libtest_extensions_init2 (void); +void libtest_extensions_init (void); + +void +libtest_extensions_init2 (void) +{ + scm_variable_set_x (init2_count, + scm_from_int (scm_to_int (scm_variable_ref (init2_count)) + 1)); +} + +void +libtest_extensions_init (void) +{ + scm_c_define ("init2-count", scm_from_int (0)); + init2_count = scm_permanent_object (scm_c_lookup ("init2-count")); + scm_c_register_extension ("libtest-extensions", "libtest_extensions_init2", + (scm_t_extension_init_func)libtest_extensions_init2, NULL); +} From 6f36dbbe48506eccfc6a1df7d626dfe94ba3f696 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 3 Apr 2009 10:38:30 -0700 Subject: [PATCH 019/375] no hard-coded stack limitations if the user has getrlimit * libguile/debug.c (init_stack_limit): Instead of "1 MB or 80% of rlimit, whichever is lower", just use 80% of the rlimit, if set. --- libguile/debug.c | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index ec37d3aaa..20c8d4e6b 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -525,24 +525,14 @@ init_stack_limit (void) struct rlimit lim; if (getrlimit (RLIMIT_STACK, &lim) == 0) { - int bytes = lim.rlim_cur, words; + rlim_t bytes = lim.rlim_cur; - /* set our internal stack limit to 1 MB or 80% of the rlimit, whichever - is lower. */ + /* set our internal stack limit to 80% of the rlimit. */ if (bytes == RLIM_INFINITY) bytes = lim.rlim_max; - if (bytes == RLIM_INFINITY) - words = 1024 * 1024 / sizeof (scm_t_bits); - else - { - bytes = bytes * 8 / 10; - if (bytes > 1024 * 1024) - bytes = 1024 * 1024; - words = bytes / sizeof (scm_t_bits); - } - - SCM_STACK_LIMIT = words; + if (bytes != RLIM_INFINITY) + SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); } errno = 0; #endif From 2c0f99a28bc5a289bead58983da1510867162745 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 4 Apr 2009 11:36:18 -0700 Subject: [PATCH 020/375] fix nondeterminism in vm-i-system.c * libguile/vm-i-system.c (br-if-eq, br-if-not-eq): Fix some nondeterminism caught by GCC 4.4. --- libguile/vm-i-system.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index c1ea1c161..9280b189d 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -446,12 +446,14 @@ VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0) VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0) { - BR (SCM_EQ_P (sp[0], sp--[1])); + sp--; /* underflow? */ + BR (SCM_EQ_P (sp[0], sp[1])); } VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0) { - BR (!SCM_EQ_P (sp[0], sp--[1])); + sp--; /* underflow? */ + BR (!SCM_EQ_P (sp[0], sp[1])); } VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0) From aa49787b5eb500807e82ce2698651515a7bdc743 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 4 Apr 2009 11:59:57 +0200 Subject: [PATCH 021/375] Improved handling of callers cache in (system xref). * We cache callees in each module, and keep a list of modified ('tainted') modules, which is used to reconstruct the callers database incrementally. * `procedure-callers' now returns an a-list, keyed by module name. --- module/system/xref.scm | 105 ++++++++++++++++++++++++++++------------- 1 file changed, 73 insertions(+), 32 deletions(-) diff --git a/module/system/xref.scm b/module/system/xref.scm index be44225f3..0613754ab 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -1,19 +1,19 @@ ;;;; Copyright (C) 2009 Free Software Foundation, Inc. -;;;; +;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; +;;;; (define-module (system xref) @@ -81,54 +81,95 @@ (else '()))) (define (procedure-callees prog) + "Evaluates to a list of the given program callees." (let lp ((in (procedure-callee-rev-vars prog)) (out '())) (cond ((null? in) out) ((variable-bound? (car in)) (lp (cdr in) (cons (variable-ref (car in)) out))) (else (lp (cdr in) out))))) +;; var -> ((module-name caller ...) ...) (define *callers-db* #f) +;; module-name -> (callee ...) +(define *module-callees-db* (make-hash-table)) +;; (module-name ...) +(define *tainted-modules* '()) (define *xref-ignored-modules* '((value-history))) (define (on-module-modified m) - (if (not (member (module-name m) *xref-ignored-modules*)) - (set! *callers-db* #f))) + (let ((name (module-name m))) + (if (and (not (member name *xref-ignored-modules*)) + (not (member name *tainted-modules*)) + (pair? name)) + (set! *tainted-modules* (cons name *tainted-modules*))))) -(define (ensure-callers-db) - (let ((visited #f) - (db #f)) - (define (visit-variable var) +(define (add-caller callee caller mod-name) + (let ((all-callers (hashq-ref *callers-db* callee))) + (if (not all-callers) + (hashq-set! *callers-db* callee `((,mod-name ,caller))) + (let ((callers (assoc mod-name all-callers))) + (if callers + (if (not (member caller callers)) + (set-cdr! callers (cons caller (cdr callers)))) + (hashq-set! *callers-db* callee + (cons `(,mod-name ,caller) all-callers))))))) + +(define (forget-callers callee mod-name) + (hashq-set! *callers-db* callee + (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name))) + +(define (add-callees callees mod-name) + (hash-set! *module-callees-db* mod-name + (append callees (hash-ref *module-callees-db* mod-name '())))) + +(define (untaint-modules) + (define (untaint m) + (for-each (lambda (callee) (forget-callers callee m)) + (hash-ref *module-callees-db* m '())) + (ensure-callers-db m)) + (ensure-callers-db #f) + (for-each untaint *tainted-modules*) + (set! *tainted-modules* '())) + +(define (ensure-callers-db mod-name) + (let ((mod (and mod-name (resolve-module mod-name))) + (visited #f)) + (define (visit-variable var recurse mod-name) (if (variable-bound? var) (let ((x (variable-ref var))) (cond - ((hashq-ref visited x)) + ((and visited (hashq-ref visited x))) ((procedure? x) - (hashq-set! visited x #t) - (for-each - (lambda (callee) - (if (variable-bound? callee) - (hashq-set! db callee - (cons x (hashq-ref db callee '()))))) - (procedure-callee-rev-vars x))) - ((module? x) - (visit-module x)))))) + (if visited (hashq-set! visited x #t)) + (let ((callees (filter variable-bound? + (procedure-callee-rev-vars x)))) + (for-each (lambda (callee) + (add-caller callee x mod-name)) + callees) + (add-callees callees mod-name))) + ((and recurse (module? x)) + (visit-module x #t)))))) - (define (visit-module mod) - (hashq-set! visited mod #t) + (define (visit-module mod recurse) + (if visited (hashq-set! visited mod #t)) (if (not (memq on-module-modified (module-observers mod))) (module-observe mod on-module-modified)) - (module-for-each (lambda (sym var) - (visit-variable var)) - mod)) + (let ((name (module-name mod))) + (module-for-each (lambda (sym var) + (visit-variable var recurse name)) + mod))) - (if (not *callers-db*) - (begin - (set! db (make-hash-table 1000)) - (set! visited (make-hash-table 1000)) - (visit-module the-root-module) - (set! *callers-db* db))))) + (cond ((and (not mod-name) (not *callers-db*)) + (set! *callers-db* (make-hash-table 1000)) + (set! visited (make-hash-table 1000)) + (visit-module the-root-module #t)) + (mod-name (visit-module mod #f))))) (define (procedure-callers var) + "Returns an association list, keyed by module name, of known callers +of the given procedure. The latter can specified directly as a +variable, a symbol (which gets resolved in the current module) or a +pair of the form (module-name . variable-name), " (let ((v (cond ((variable? var) var) ((symbol? var) (module-variable (current-module) var)) (else @@ -137,5 +178,5 @@ (module-variable (resolve-module modname) sym)) (else (error "expected a variable, symbol, or (modname . sym)" var))))))) - (ensure-callers-db) + (untaint-modules) (hashq-ref *callers-db* v '()))) From 6ab8238d99f477ee7ac12f1f1a3ec70aab3e68c7 Mon Sep 17 00:00:00 2001 From: daniel Date: Fri, 13 Feb 2009 14:27:41 +0100 Subject: [PATCH 022/375] Make `--disable-deprecated' work. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * configure.in (enable_deprecated): Set SCM_WARN_DEPRECATED_DEFAULT even when --disable-deprecated is passed. * libguile/deprecation.h: Declare deprecation-issuing methods even if SCM_ENABLE_DEPRECATED is not set. * libguile/deprecation.c: Ditto. (scm_init_deprecation): Include full body even for unset SCM_ENABLE_DEPRECATED. Signed-off-by: Ludovic Courtès --- configure.in | 5 +++-- libguile/deprecation.c | 6 ------ libguile/deprecation.h | 14 ++++---------- 3 files changed, 7 insertions(+), 18 deletions(-) diff --git a/configure.in b/configure.in index 9503fcbcd..2c9c478eb 100644 --- a/configure.in +++ b/configure.in @@ -159,6 +159,7 @@ AC_ARG_ENABLE([deprecated], if test "$enable_deprecated" = no; then SCM_I_GSC_ENABLE_DEPRECATED=0 + warn_default=no else if test "$enable_deprecated" = yes || test "$enable_deprecated" = ""; then warn_default=summary @@ -168,9 +169,9 @@ else warn_default=$enable_deprecated fi SCM_I_GSC_ENABLE_DEPRECATED=1 - AC_DEFINE_UNQUOTED(SCM_WARN_DEPRECATED_DEFAULT, "$warn_default", - [Define this to control the default warning level for deprecated features.]) fi +AC_DEFINE_UNQUOTED(SCM_WARN_DEPRECATED_DEFAULT, "$warn_default", +[Define this to control the default warning level for deprecated features.]) AC_ARG_ENABLE(elisp, [ --disable-elisp omit Emacs Lisp support],, diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 338c47c20..780e246f0 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -41,8 +41,6 @@ -#if (SCM_ENABLE_DEPRECATED == 1) - struct issued_warning { struct issued_warning *prev; const char *message; @@ -138,8 +136,6 @@ print_deprecation_summary (void) } } -#endif /* SCM_ENABLE_DEPRECATED == 1 */ - SCM_DEFINE(scm_include_deprecated_features, "include-deprecated-features", 0, 0, 0, (), @@ -157,7 +153,6 @@ SCM_DEFINE(scm_include_deprecated_features, void scm_init_deprecation () { -#if (SCM_ENABLE_DEPRECATED == 1) const char *level = getenv ("GUILE_WARN_DEPRECATED"); if (level == NULL) level = SCM_WARN_DEPRECATED_DEFAULT; @@ -170,7 +165,6 @@ scm_init_deprecation () SCM_WARN_DEPRECATED = 0; atexit (print_deprecation_summary); } -#endif #include "libguile/deprecation.x" } diff --git a/libguile/deprecation.h b/libguile/deprecation.h index 78853277b..9752d9b16 100644 --- a/libguile/deprecation.h +++ b/libguile/deprecation.h @@ -3,7 +3,7 @@ #ifndef SCM_DEPRECATION_H #define SCM_DEPRECATION_H -/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -26,20 +26,14 @@ -#if (SCM_ENABLE_DEPRECATED == 1) - -/* These functions are _not_ deprecated, but we exclude them along - with the really deprecated features to be sure that no-one is - trying to emit deprecation warnings when libguile is supposed to be - clean of them. -*/ +/* These functions are a possibly useful part of the API and not only used + internally, thus they are exported always, not depending on + SCM_ENABLE_DEPRECATED. */ SCM_API void scm_c_issue_deprecation_warning (const char *msg); SCM_API void scm_c_issue_deprecation_warning_fmt (const char *msg, ...); SCM_API SCM scm_issue_deprecation_warning (SCM msgs); -#endif - SCM_API SCM scm_include_deprecated_features (void); SCM_INTERNAL void scm_init_deprecation (void); From da8b47478e08976ac4569a3030e43aa520e76b01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 5 Apr 2009 20:15:11 +0200 Subject: [PATCH 023/375] Avoid uses of deprecated forms in the VM code. Reported by Daniel Kraft . * libguile/frames.c, libguile/vm.c: Include , use `size_t' instead of `scm_sizet'. * libguile/objcodes.c, libguile/programs.c, libguile/vm-engine.c, libguile/vm-i-loader.c, libguile/vm-i-system.c: Use `scm_list_X ()' instead of the deprecated `SCM_LISTX ()'. --- libguile/frames.c | 3 ++- libguile/objcodes.c | 18 +++++++++--------- libguile/programs.c | 8 ++++---- libguile/vm-engine.c | 11 ++++++----- libguile/vm-i-loader.c | 2 +- libguile/vm-i-system.c | 8 ++++---- libguile/vm.c | 5 +++-- 7 files changed, 29 insertions(+), 26 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index eb3bc22ee..f53cade95 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -43,6 +43,7 @@ # include #endif +#include #include #include "vm-bootstrap.h" #include "frames.h" @@ -85,7 +86,7 @@ vm_frame_mark (SCM obj) return SCM_VM_FRAME_STACK_HOLDER (obj); } -static scm_sizet +static size_t vm_frame_free (SCM obj) { struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj); diff --git a/libguile/objcodes.c b/libguile/objcodes.c index c53cf2253..8bc203dda 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -81,7 +81,7 @@ make_objcode_by_mmap (int fd) if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE)) scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", - SCM_LIST1 (SCM_I_MAKINUM (st.st_size))); + scm_list_1 (SCM_I_MAKINUM (st.st_size))); addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); if (addr == MAP_FAILED) @@ -94,8 +94,8 @@ make_objcode_by_mmap (int fd) if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE))) scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)", - SCM_LIST2 (scm_from_size_t (st.st_size), - scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); + scm_list_2 (scm_from_size_t (st.st_size), + scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE), SCM_PACK (SCM_BOOL_F), fd); @@ -121,10 +121,10 @@ scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr) || ptr >= (parent_data->base + parent_data->len + parent_data->metalen - sizeof (struct scm_objcode))) scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)", - SCM_LIST4 (scm_from_ulong ((unsigned long)ptr), - scm_from_ulong ((unsigned long)parent_data->base), - scm_from_uint32 (parent_data->len), - scm_from_uint32 (parent_data->metalen))); + scm_list_4 (scm_from_ulong ((unsigned long)ptr), + scm_from_ulong ((unsigned long)parent_data->base), + scm_from_uint32 (parent_data->len), + scm_from_uint32 (parent_data->metalen))); data = (struct scm_objcode*)ptr; if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen) @@ -194,8 +194,8 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0, SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); if (data->len + data->metalen != (size - sizeof (*data))) scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)", - SCM_LIST2 (scm_from_size_t (size), - scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); + scm_list_2 (scm_from_size_t (size), + scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); assert (increment == 1); SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR); diff --git a/libguile/programs.c b/libguile/programs.c index c97f61e13..8e8982994 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -173,10 +173,10 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0, SCM_VALIDATE_PROGRAM (1, program); p = SCM_PROGRAM_DATA (program); - return SCM_LIST4 (SCM_I_MAKINUM (p->nargs), - SCM_I_MAKINUM (p->nrest), - SCM_I_MAKINUM (p->nlocs), - SCM_I_MAKINUM (p->nexts)); + return scm_list_4 (SCM_I_MAKINUM (p->nargs), + SCM_I_MAKINUM (p->nrest), + SCM_I_MAKINUM (p->nlocs), + SCM_I_MAKINUM (p->nexts)); } #undef FUNC_NAME diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 58ed43db6..45251fd70 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -175,7 +175,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) vm_error_bad_instruction: err_msg = scm_from_locale_string ("VM: Bad instruction: ~A"); - finish_args = SCM_LIST1 (scm_from_uchar (ip[-1])); + finish_args = scm_list_1 (scm_from_uchar (ip[-1])); goto vm_error; vm_error_unbound: @@ -189,7 +189,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) vm_error_too_many_args: err_msg = scm_from_locale_string ("VM: Too many arguments"); - finish_args = SCM_LIST1 (scm_from_int (nargs)); + finish_args = scm_list_1 (scm_from_int (nargs)); goto vm_error; vm_error_wrong_num_args: @@ -202,8 +202,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) vm_error_wrong_type_apply: err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S " "[IP offset: ~a]"); - finish_args = SCM_LIST2 (program, - SCM_I_MAKINUM (ip - bp->base)); + finish_args = scm_list_2 (program, + SCM_I_MAKINUM (ip - bp->base)); goto vm_error; vm_error_stack_overflow: @@ -264,7 +264,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) vm_error: SYNC_ALL (); - scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, finish_args), 1); + scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args), + 1); } abort (); /* never reached */ diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index bba4f4b9c..515001d61 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -140,7 +140,7 @@ VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1) mod = scm_module_public_interface (mod); if (SCM_FALSEP (mod)) { - finish_args = SCM_LIST1 (SCM_CAR (what)); + finish_args = scm_list_1 (SCM_CAR (what)); goto vm_error_no_such_module; } /* might longjmp */ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 9280b189d..303ef315d 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -253,7 +253,7 @@ VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1) if (!VARIABLE_BOUNDP (x)) { - finish_args = SCM_LIST1 (x); + finish_args = scm_list_1 (x); /* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */ goto vm_error_unbound; } @@ -298,7 +298,7 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) mod = scm_module_public_interface (mod); if (SCM_FALSEP (mod)) { - finish_args = SCM_LIST1 (mod); + finish_args = scm_list_1 (mod); goto vm_error_no_such_module; } /* might longjmp */ @@ -307,7 +307,7 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) if (!VARIABLE_BOUNDP (what)) { - finish_args = SCM_LIST1 (what); + finish_args = scm_list_1 (what); goto vm_error_unbound; } @@ -381,7 +381,7 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) mod = scm_module_public_interface (mod); if (SCM_FALSEP (mod)) { - finish_args = SCM_LIST1 (what); + finish_args = scm_list_1 (what); goto vm_error_no_such_module; } /* might longjmp */ diff --git a/libguile/vm.c b/libguile/vm.c index 53e9e154e..4314a6847 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -43,6 +43,7 @@ # include #endif +#include #include #include #include "vm-bootstrap.h" @@ -129,7 +130,7 @@ vm_cont_mark (SCM obj) return SCM_BOOL_F; } -static scm_sizet +static size_t vm_cont_free (SCM obj) { struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj); @@ -368,7 +369,7 @@ vm_mark (SCM obj) return vp->options; } -static scm_sizet +static size_t vm_free (SCM obj) { struct scm_vm *vp = SCM_VM_DATA (obj); From 275baf01136895093570725fe55c4104725a9387 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 6 Apr 2009 11:07:22 -0700 Subject: [PATCH 024/375] guile-config rebased on top of pkg-config * configure.in: * meta/Makefile.am (EXTRA_DIST): Remove guile-config.in bits. * meta/guile-config: Reimplement to work on top of pkg-config. This lets guile-config not be substed by configure. * meta/uninstalled-env.in: Remove the path to guile-config, belatedly. Set the pkg-config path correctly. --- configure.in | 1 - meta/Makefile.am | 2 +- meta/{guile-config.in => guile-config} | 148 ++++++------------------- meta/uninstalled-env.in | 5 +- 4 files changed, 36 insertions(+), 120 deletions(-) rename meta/{guile-config.in => guile-config} (54%) mode change 100644 => 100755 diff --git a/configure.in b/configure.in index 2c9c478eb..e547ff00e 100644 --- a/configure.in +++ b/configure.in @@ -1556,7 +1556,6 @@ AC_CONFIG_FILES([meta/guile-1.8.pc]) AC_CONFIG_FILES([meta/guile-1.8-uninstalled.pc]) AC_CONFIG_FILES([check-guile], [chmod +x check-guile]) AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile]) -AC_CONFIG_FILES([meta/guile-config], [chmod +x meta/guile-config]) AC_CONFIG_FILES([meta/guile-tools], [chmod +x meta/guile-tools]) AC_CONFIG_FILES([meta/guile], [chmod +x meta/guile]) AC_CONFIG_FILES([meta/uninstalled-env], [chmod +x meta/uninstalled-env]) diff --git a/meta/Makefile.am b/meta/Makefile.am index 76544b30d..da587e33d 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -21,7 +21,7 @@ ## Floor, Boston, MA 02110-1301 USA bin_SCRIPTS=guile-config guile-tools -EXTRA_DIST=guile-config.in guile-tools.in guile.m4 ChangeLog-2008 \ +EXTRA_DIST=guile-tools.in guile.m4 ChangeLog-2008 \ guile-1.8.pc.in guile-1.8-uninstalled.pc.in pkgconfigdir = $(libdir)/pkgconfig diff --git a/meta/guile-config.in b/meta/guile-config old mode 100644 new mode 100755 similarity index 54% rename from meta/guile-config.in rename to meta/guile-config index b1640b629..669934b96 --- a/meta/guile-config.in +++ b/meta/guile-config @@ -1,6 +1,5 @@ #!/bin/sh -bindir=`dirname $0` -exec $bindir/guile -e main -s $0 "$@" +exec guile -e main -s $0 "$@" !# ;;;; guile-config --- utility for linking programs with Guile ;;;; Jim Blandy --- September 1997 @@ -21,13 +20,10 @@ exec $bindir/guile -e main -s $0 "$@" ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;; TODO: -;;; * Add some plausible structure for returning the right exit status, -;;; just something that encourages people to do the correct thing. -;;; * Implement the static library support. This requires that -;;; some portion of the module system be done. +;;; This script has been deprecated. Just use pkg-config. -(use-modules (ice-9 string-fun)) +(use-modules (ice-9 popen) + (ice-9 rdelim)) ;;;; main function, command-line processing @@ -48,7 +44,6 @@ exec $bindir/guile -e main -s $0 "$@" (define program-name #f) (define subcommand-name #f) -(define program-version "@GUILE_VERSION@") ;;; Given an executable path PATH, set program-name to something ;;; appropriate f or use in error messages (i.e., with leading @@ -75,8 +70,20 @@ exec $bindir/guile -e main -s $0 "$@" (dle " " p " --help - show usage info (this message)") (dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND"))) +(define guile-module "guile-1.8") + +(define (pkg-config . args) + (let* ((real-args (cons "pkg-config" args)) + (pipe (apply open-pipe* OPEN_READ real-args)) + (output (read-delimited "" pipe)) + (ret (close-pipe pipe))) + (case (status:exit-val ret) + ((0) (if (eof-object? output) "" output)) + (else (error "error calling pkg-config: ~A" output))))) + (define (show-version args) - (display-line-error program-name " - Guile version " program-version)) + (format (current-error-port) "~A - Guile version ~A" + program-name (pkg-config "--modversion" guile-module))) (define (help-version) (let ((dle display-line-error)) @@ -99,69 +106,7 @@ exec $bindir/guile -e main -s $0 "$@" ;;; now, we're just going to reach into Guile's configuration info and ;;; hack it out. (define (build-link args) - - ;; If PATH has the form FOO/libBAR.a, return the substring - ;; BAR, otherwise return #f. - (define (match-lib path) - (let* ((base (basename path)) - (len (string-length base))) - (if (and (> len 5) - (string=? (substring base 0 3) "lib") - (string=? (substring base (- len 2)) ".a")) - (substring base 3 (- len 2)) - #f))) - - (if (> (length args) 0) - (error - (string-append program-name - " link: arguments to subcommand not yet implemented"))) - - (let ((libdir (get-build-info 'libdir)) - (other-flags - (let loop ((libs - ;; Get the string of linker flags we used to build - ;; Guile, and break it up into a list. - (separate-fields-discarding-char #\space - (get-build-info 'LIBS) - list))) - - (cond - ((null? libs) '()) - - ;; Turn any "FOO/libBAR.a" elements into "-lBAR". - ((match-lib (car libs)) - => (lambda (bar) - (cons (string-append "-l" bar) - (loop (cdr libs))))) - - ;; Remove any empty strings that may have seeped in there. - ((string=? (car libs) "") (loop (cdr libs))) - - (else (cons (car libs) (loop (cdr libs)))))))) - - ;; Include libguile itself in the list, along with the directory - ;; it was installed in, but do *not* add /usr/lib since that may - ;; prevent other programs from specifying non-/usr/lib versions - ;; via their foo-config scripts. If *any* app puts -L/usr/lib in - ;; the output of its foo-config script then it may prevent the use - ;; a non-/usr/lib install of anything that also has a /usr/lib - ;; install. For now we hard-code /usr/lib, but later maybe we can - ;; do something more dynamic (i.e. what do we need. - - ;; Display the flags, separated by spaces. - (display (string-join - (list - (get-build-info 'CFLAGS) - (if (or (string=? libdir "/usr/lib") - (string=? libdir "/usr/lib/")) - "" - (string-append "-L" (get-build-info 'libdir))) - "-lguile -lltdl" - (string-join other-flags) - - ))) - (newline))) - + (display (apply pkg-config "--libs" guile-module args))) (define (help-link) (let ((dle display-line-error)) @@ -179,23 +124,7 @@ exec $bindir/guile -e main -s $0 "$@" ;;;; The "compile" subcommand (define (build-compile args) - (if (> (length args) 0) - (error - (string-append program-name - " compile: no arguments expected"))) - - ;; See gcc manual wrt fixincludes. Search for "Use of - ;; `-I/usr/include' may cause trouble." For now we hard-code this. - ;; Later maybe we can do something more dynamic. - (display - (string-append - (if (not (string=? (get-build-info 'includedir) "/usr/include")) - (string-append "-I" (get-build-info 'includedir) " ") - " ") - - (get-build-info 'CFLAGS) - "\n" - ))) + (display (apply pkg-config "--cflags" guile-module args))) (define (help-compile) (let ((dle display-line-error)) @@ -212,44 +141,33 @@ exec $bindir/guile -e main -s $0 "$@" (define (build-info args) (cond - ((null? args) (show-all-vars)) - ((null? (cdr args)) (show-var (car args))) - (else (display-line-error "Usage: " program-name " info [VAR]") + ((null? args) + (display-line-error "guile-config info with no args has been removed") + (quit 2)) + ((null? (cdr args)) + (cond + ((string=? (car args) "guileversion") + (display (pkg-config "--modversion" guile-module))) + (else + (display (pkg-config (format #f (car args) guile-module)))))) + (else (display-line-error "Usage: " program-name " info VAR") (quit 2)))) -(define (show-all-vars) - (for-each (lambda (binding) - (display-line (car binding) " = " (cdr binding))) - %guile-build-info)) - -(define (show-var var) - (display (get-build-info (string->symbol var))) - (newline)) - (define (help-info) (let ((d display-line-error)) - (d "Usage: " program-name " info [VAR]") - (d "Display the value of the Makefile variable VAR used when Guile") - (d "was built. If VAR is omitted, display all Makefile variables.") + (d "Usage: " program-name " info VAR") + (d "Display the value of the pkg-config variable VAR used when Guile") + (d "was built.\n") (d "Use this command to find out where Guile was installed,") (d "where it will look for Scheme code at run-time, and so on."))) (define (usage-info) (display-line-error - " " program-name " info [VAR] - print Guile build directories")) + " " program-name " info VAR - print Guile build directories")) ;;;; trivial utilities -(define (get-build-info name) - (let ((val (assq name %guile-build-info))) - (if (not (pair? val)) - (begin - (display-line-error - program-name " " subcommand-name ": no such build-info: " name) - (quit 2))) - (cdr val))) - (define (display-line . args) (apply display-line-port (current-output-port) args)) diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index fa8285d94..02c0e315e 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -85,14 +85,13 @@ export DYLD_LIBRARY_PATH if [ x"$PKG_CONFIG_PATH" = x ] then - PKG_CONFIG_PATH="${top_builddir}" + PKG_CONFIG_PATH="${top_builddir}/meta" else - PKG_CONFIG_PATH="${top_builddir}:$PKG_CONFIG_PATH" + PKG_CONFIG_PATH="${top_builddir}/meta:$PKG_CONFIG_PATH" fi export PKG_CONFIG_PATH # handle PATH (no clobber) -PATH="${top_builddir}/guile-config:${PATH}" PATH="${top_builddir}/libguile:${PATH}" PATH="${top_builddir}/meta:${PATH}" export PATH From b41b92c9d1c439ddfc5c081b3949e9d1763de181 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Apr 2009 15:20:40 +0200 Subject: [PATCH 025/375] compilation passes return third value: the continuation environment * module/system/base/compile.scm: Expect compile passes to produce three values, not two. The third is the "continuation environment", the environment that can be used to compile a subsequent expression from the same source language. For example, expansion-time side effects can set the current module, which would be reflected appropriately in the continuation environment. * module/language/assembly/compile-bytecode.scm: * module/language/bytecode/spec.scm: * module/language/ecmascript/compile-ghil.scm: * module/language/ghil/compile-glil.scm: * module/language/glil/spec.scm: * module/language/objcode/spec.scm: * module/language/scheme/compile-ghil.scm: * module/system/base/compile.scm: Update compile passes to return a continuation environment. --- module/language/assembly/compile-bytecode.scm | 2 +- module/language/bytecode/spec.scm | 2 +- module/language/ecmascript/compile-ghil.scm | 1 + module/language/ghil/compile-glil.scm | 3 ++- module/language/glil/spec.scm | 2 +- module/language/objcode/spec.scm | 4 ++-- module/language/scheme/compile-ghil.scm | 15 ++++++++++----- module/system/base/compile.scm | 2 +- 8 files changed, 19 insertions(+), 12 deletions(-) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 6e7e34efc..00a324c31 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -40,7 +40,7 @@ (get-addr (lambda () i))) (write-bytecode assembly write-byte get-addr '()) (if (= i (u8vector-length v)) - (values v env) + (values v env env) (error "incorrect length in assembly" i (u8vector-length v))))) (else (error "bad assembly" assembly)))) diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm index 7d9b955a7..dff724a63 100644 --- a/module/language/bytecode/spec.scm +++ b/module/language/bytecode/spec.scm @@ -25,7 +25,7 @@ #:export (bytecode)) (define (compile-objcode x e opts) - (values (bytecode->objcode x) e)) + (values (bytecode->objcode x) e e)) (define (decompile-objcode x e opts) (values (objcode->bytecode x) e)) diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm index d4c2261a0..92d71ec16 100644 --- a/module/language/ecmascript/compile-ghil.scm +++ b/module/language/ecmascript/compile-ghil.scm @@ -41,6 +41,7 @@ (-> (lambda vars #f '() (-> (begin (list (@impl js-init '()) (comp exp e))))))))) + env env)) (define (location x) diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm index c816b0e6c..863d2603b 100644 --- a/module/language/ghil/compile-glil.scm +++ b/module/language/ghil/compile-glil.scm @@ -29,7 +29,8 @@ (define (compile-glil x e opts) (if (memq #:O opts) (set! x (optimize x))) (values (codegen x) - (and e (cons (car e) (cddr e))))) + (and e (cons (car e) (cddr e))) + e)) ;;; diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm index 3e4e10c6a..dbe379e70 100644 --- a/module/language/glil/spec.scm +++ b/module/language/glil/spec.scm @@ -30,7 +30,7 @@ (apply write (unparse-glil exp) port)) (define (compile-asm x e opts) - (values (compile-assembly x) e)) + (values (compile-assembly x) e e)) (define-language glil #:title "Guile Lowlevel Intermediate Language (GLIL)" diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm index 9ce8bf5e5..c60829974 100644 --- a/module/language/objcode/spec.scm +++ b/module/language/objcode/spec.scm @@ -40,8 +40,8 @@ (save-module-excursion (lambda () (set-current-module (objcode-env-module e)) - (values (thunk) #f))) - (values (thunk) #f)))) + (values (thunk) #f e))) + (values (thunk) #f e)))) ;; since locals are allocated on the stack and can have limited scope, ;; in many cases we use one local for more than one lexical variable. so diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 587a173fe..f1816e18c 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -56,6 +56,8 @@ ((pair? env) (cddr env)) (else (error "bad environment" env)))) +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) @@ -65,11 +67,14 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x)) - (and e - (cons* (cenv-module e) - (ghil-env-parent env) - (cenv-externals e))))))))) + (let ((x (make-ghil-lambda env #f vars #f '() + (translate-1 env #f x)))) + (values x + (and e + (cons* (cenv-module e) + (ghil-env-parent env) + (cenv-externals e))) + (make-cenv (current-module) '() '())))))))) ;;; diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 891902367..99c80b2fd 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -157,7 +157,7 @@ (define (compile-fold passes exp env opts) (if (null? passes) exp - (receive (exp env) ((car passes) exp env opts) + (receive (exp env cenv) ((car passes) exp env opts) (compile-fold (cdr passes) exp env opts)))) (define (compile-time-environment) From b8076ec6cc3a18a92186d954684f88a735a42018 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Apr 2009 17:49:59 +0200 Subject: [PATCH 026/375] support expression-by-expression compilation * module/language/ghil.scm (unparse-ghil): Fix unparsing of quasiquoted expressions. * module/language/ghil/spec.scm (join): Define a joiner for GHIL. * module/language/scheme/compile-ghil.scm (cenv-ghil-env): Expand the definition of a CENV so it can have an actual ghil-env, if available. (compile-ghil): Return the actual ghil env in the cenv. * module/system/base/compile.scm (compile-file): Rewrite. `output-file' is now a keyword argument, along with the new kwargs `env' and `from'. We now allow exceptions to propagate up, and instead of printing the output file to the console, we return a string corresponding to its location. (compile-and-load): Use read-and-compile. (compile-fold): Thread around the cenv as well. Return all three values. (find-language-joint, read-and-compile): New exciting helpers. The idea is that compiling a file should be semantically equivalent to compiling each expression in it, one by one. Compilation can have side effects, e.g. affecting the current language or the current reader. So what we do is find a point in the compilation path at which different expressions of a given language can be joined into one. Expressions from the source language are compiled to the joint language, then joined and compiled to the target. (compile): Just return the first value from compile-fold. * module/system/base/language.scm (language-joiner): New optional field. * scripts/compile: Rework for changes to compile-file. --- module/language/ghil.scm | 5 +- module/language/ghil/spec.scm | 19 ++++++ module/language/scheme/compile-ghil.scm | 18 ++--- module/system/base/compile.scm | 87 ++++++++++++++++--------- module/system/base/language.scm | 4 +- scripts/compile | 61 +++++++++-------- 6 files changed, 119 insertions(+), 75 deletions(-) diff --git a/module/language/ghil.scm b/module/language/ghil.scm index 00a2c9afd..273d0aa20 100644 --- a/module/language/ghil.scm +++ b/module/language/ghil.scm @@ -432,7 +432,10 @@ (( env loc obj) `(,'quote ,obj)) (( env loc exp) - `(,'quasiquote ,(map unparse-ghil exp))) + `(,'quasiquote ,(let lp ((x exp)) + (cond ((struct? x) (unparse-ghil x)) + ((pair? x) (cons (lp (car x)) (lp (cdr x)))) + (else x))))) (( env loc exp) `(,'unquote ,(unparse-ghil exp))) (( env loc exp) diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm index ee574b50b..c9d38aa69 100644 --- a/module/language/ghil/spec.scm +++ b/module/language/ghil/spec.scm @@ -34,11 +34,30 @@ (lambda (env vars) (make-ghil-lambda env #f vars #f '() (parse-ghil env x))))) +(define (join exps env) + (if (or-map (lambda (x) + (or (not (ghil-lambda? x)) + (ghil-lambda-rest x) + (memq 'argument + (map ghil-var-kind + (ghil-env-variables (ghil-lambda-env x)))))) + exps) + (error "GHIL expressions to join must be thunks")) + + (let ((env (make-ghil-env env '() + (apply append + (map ghil-env-variables + (map ghil-lambda-env exps)))))) + (make-ghil-lambda env #f '() #f '() + (make-ghil-begin env #f + (map ghil-lambda-body exps))))) + (define-language ghil #:title "Guile High Intermediate Language (GHIL)" #:version "0.3" #:reader read #:printer write-ghil #:parser parse + #:joiner join #:compilers `((glil . ,compile-glil)) ) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index f1816e18c..fcca8a940 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -36,7 +36,7 @@ ;;; environment := #f ;;; | MODULE ;;; | COMPILE-ENV -;;; compile-env := (MODULE LEXICALS . EXTERNALS) +;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS) (define (cenv-module env) (cond ((not env) #f) ((module? env) env) @@ -47,7 +47,9 @@ (cond ((not env) (make-ghil-toplevel-env)) ((module? env) (make-ghil-toplevel-env)) ((pair? env) - (ghil-env-dereify (cadr env))) + (if (struct? (cadr env)) + (cadr env) + (ghil-env-dereify (cadr env)))) (else (error "bad environment" env)))) (define (cenv-externals env) @@ -68,13 +70,11 @@ (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) (let ((x (make-ghil-lambda env #f vars #f '() - (translate-1 env #f x)))) - (values x - (and e - (cons* (cenv-module e) - (ghil-env-parent env) - (cenv-externals e))) - (make-cenv (current-module) '() '())))))))) + (translate-1 env #f x))) + (cenv (make-cenv (current-module) + (ghil-env-parent env) + (if e (cenv-externals e) '())))) + (values x cenv cenv))))))) ;;; diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 99c80b2fd..7d54947e3 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -92,33 +92,24 @@ x (lookup-language x))) -(define* (compile-file file #:optional output-file - #:key (to 'objcode) (opts '())) +(define* (compile-file file #:key + (output-file #f) + (env #f) + (from (current-language)) + (to 'objcode) + (opts '())) (let ((comp (or output-file (compiled-file-name file))) - (lang (ensure-language (current-language))) - (to (ensure-language to))) - (catch 'nothing-at-all - (lambda () - (call-with-compile-error-catch - (lambda () - (call-with-output-file/atomic comp - (lambda (port) - (let ((print (language-printer to))) - (print (compile (read-file-in file lang) - #:from lang #:to to #:opts opts) - port)))) - (format #t "wrote `~A'\n" comp)))) - (lambda (key . args) - (format #t "ERROR: during compilation of ~A:\n" file) - (display "ERROR: ") - (apply format #t (cadr args) (caddr args)) - (newline) - (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args)) - (delete-file comp))))) + (in (open-input-file file))) + (call-with-output-file/atomic comp + (lambda (port) + ((language-printer (ensure-language to)) + (read-and-compile in #:env env #:from from #:to to #:opts opts) + port))) + comp)) (define* (compile-and-load file #:key (to 'value) (opts '())) - (let ((lang (ensure-language (current-language)))) - (compile (read-file-in file lang) #:to 'value #:opts opts))) + (read-and-compile (open-input-port file) + #:from lang #:to to #:opts opts)) (define (compiled-file-name file) (let ((base (basename file)) @@ -155,10 +146,11 @@ (error "no way to compile" from "to" to)))) (define (compile-fold passes exp env opts) - (if (null? passes) - exp - (receive (exp env cenv) ((car passes) exp env opts) - (compile-fold (cdr passes) exp env opts)))) + (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t)) + (if (null? passes) + (values x e cenv) + (receive (x e new-cenv) ((car passes) x e opts) + (lp (cdr passes) x e (if first? new-cenv cenv) #f))))) (define (compile-time-environment) "A special function known to the compiler that, when compiled, will @@ -167,15 +159,46 @@ time. Useful for supporting some forms of dynamic compilation. Returns #f if called from the interpreter." #f) +(define (find-language-joint from to) + (let lp ((in (reverse (or (lookup-compilation-order from to) + (error "no way to compile" from "to" to)))) + (lang to)) + (cond ((null? in) + (error "don't know how to join expressions" from to)) + ((language-joiner lang) lang) + (else + (lp (cdr in) (caar in)))))) + +(define* (read-and-compile port #:key + (env #f) + (from (current-language)) + (to 'objcode) + (opts '())) + (let ((from (ensure-language from)) + (to (ensure-language to))) + (let ((joint (find-language-joint from to))) + (with-fluids ((*current-language* from)) + (let lp ((exps '()) (env #f) (cenv env)) + (let ((x ((language-reader (current-language)) port))) + (cond + ((eof-object? x) + (compile ((language-joiner joint) (reverse exps) env) + #:from joint #:to to #:env env #:opts opts)) + (else + ;; compile-fold instead of compile so we get the env too + (receive (jexp jenv jcenv) + (compile-fold (compile-passes (current-language) joint opts) + x cenv opts) + (lp (cons jexp exps) jenv jcenv)))))))))) + (define* (compile x #:key (env #f) (from (current-language)) (to 'value) (opts '())) - (compile-fold (compile-passes from to opts) - x - env - opts)) + (receive (exp env cenv) + (compile-fold (compile-passes from to opts) x env opts) + exp)) ;;; diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 70000c551..649137c4d 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -25,6 +25,7 @@ language-name language-title language-version language-reader language-printer language-parser language-read-file language-compilers language-decompilers language-evaluator + language-joiner lookup-compilation-order lookup-decompilation-order invalidate-compilation-cache!)) @@ -44,7 +45,8 @@ (read-file #f) (compilers '()) (decompilers '()) - (evaluator #f)) + (evaluator #f) + (joiner #f)) (define-macro (define-language name . spec) `(begin diff --git a/scripts/compile b/scripts/compile index 6651722f0..41f542c1d 100755 --- a/scripts/compile +++ b/scripts/compile @@ -28,9 +28,7 @@ exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@" ;; Usage: compile [ARGS] ;; -;; PROGRAM does something. -;; -;; TODO: Write it! +;; A command-line interface to the Guile compiler. ;;; Code: @@ -67,15 +65,16 @@ exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@" (option '(#\O "optimize") #f #f (lambda (opt name arg result) (alist-cons 'optimize? #t result))) - (option '(#\e "expand-only") #f #f + (option '(#\f "from") #t #f (lambda (opt name arg result) - (alist-cons 'expand-only? #t result))) - (option '(#\t "translate-only") #f #f + (if (assoc-ref result 'from) + (fail "`--from' option cannot be specified more than once") + (alist-cons 'from (string->symbol arg) result)))) + (option '(#\t "to") #t #f (lambda (opt name arg result) - (alist-cons 'translate-only? #t result))) - (option '(#\c "compile-only") #f #f - (lambda (opt name arg result) - (alist-cons 'compile-only? #t result))))) + (if (assoc-ref result 'to) + (fail "`--to' option cannot be specified more than once") + (alist-cons 'to (string->symbol arg) result)))))) (define (parse-args args) "Parse argument list @var{args} and return an alist with all the relevant @@ -97,46 +96,44 @@ options." (define (compile args) (let* ((options (parse-args (cdr args))) (help? (assoc-ref options 'help?)) - (optimize? (assoc-ref options 'optimize?)) - (expand-only? (assoc-ref options 'expand-only?)) - (translate-only? (assoc-ref options 'translate-only?)) - (compile-only? (assoc-ref options 'compile-only?)) + (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '())) + (from (or (assoc-ref options 'from) 'scheme)) + (to (or (assoc-ref options 'to) 'objcode)) (input-files (assoc-ref options 'input-files)) (output-file (assoc-ref options 'output-file)) (load-path (assoc-ref options 'load-path))) (if (or help? (null? input-files)) (begin (format #t "Usage: compile [OPTION] FILE... -Compile each Guile Scheme source file FILE into a Guile object. +Compile each Guile source file FILE into a Guile object. -h, --help print this help message -L, --load-path=DIR add DIR to the front of the module load path -o, --output=OFILE write output to OFILE - -O, --optimize turn on optimizations - -e, --expand-only only go through the code expansion stage - -t, --translate-only stop after the translation to GHIL - -c, --compile-only stop after the compilation to GLIL + -f, --from=LANG specify a source language other than `scheme' + -t, --to=LANG specify a target language other than `objcode' Report bugs to .~%") (exit 0))) (set! %load-path (append load-path %load-path)) - (let ((compile-opts (append (if optimize? '(#:O) '()) - (if expand-only? '(#:e) '()) - (if translate-only? '(#:t) '()) - (if compile-only? '(#:c) '())))) - (if output-file - (if (and (not (null? input-files)) - (null? (cdr input-files))) - (compile-file (car input-files) output-file) - (fail "`-o' option can only be specified " - "when compiling a single file")) - (for-each (lambda (file) - (apply compile-file file compile-opts)) - input-files))))) + (if (and output-file + (or (null? input-files) + (not (null? (cdr input-files))))) + (fail "`-o' option can only be specified " + "when compiling a single file")) + + (for-each (lambda (file) + (format #t "wrote `~A'\n" + (compile-file file + #:output-file output-file + #:from from + #:to to + #:opts compile-opts))) + input-files))) ;;; Local Variables: ;;; coding: latin-1 From 798244609bfd3b4d2b12f722d9130d47abcfeb1a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Apr 2009 09:27:32 +0200 Subject: [PATCH 027/375] fix a couple gc-related continuations bugs Thanks to Juhani Rantanen for the report. * libguile/continuations.c (scm_make_continuation): Delay making the smob until the data is fully initialized. Fixes a bug whereby a GC in scm_vm_capture_continuations would catch the us with an undefined continuation->vm_conts, leading to marking badness. * libguile/vm.c (vm_cont_free): Report the correct size to scm_gc_free. --- libguile/continuations.c | 4 ++-- libguile/vm.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index 2b10126cf..dc1456985 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -121,8 +121,6 @@ scm_make_continuation (int *first) continuation->root = thread->continuation_root; continuation->dframe = scm_i_last_debug_frame (); src = thread->continuation_base; - SCM_NEWSMOB (cont, scm_tc16_continuation, continuation); - #if ! SCM_STACK_GROWS_UP src -= stack_size; #endif @@ -130,6 +128,8 @@ scm_make_continuation (int *first) memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); continuation->vm_conts = scm_vm_capture_continuations (); + SCM_NEWSMOB (cont, scm_tc16_continuation, continuation); + *first = !setjmp (continuation->jmpbuf); if (*first) { diff --git a/libguile/vm.c b/libguile/vm.c index 4314a6847..38d085c99 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -136,7 +136,7 @@ vm_cont_free (SCM obj) struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj); scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base"); - scm_gc_free (p, sizeof (struct scm_vm), "vm"); + scm_gc_free (p, sizeof (*p), "vm-cont"); return 0; } From 6d66647d5b2c6649bb4dade734f6d583d10d797c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Apr 2009 11:19:42 +0200 Subject: [PATCH 028/375] guile-tools is a scheme script that loads scheme modules * meta/guile-tools: Changed to be a scheme script. Instead of looking for executables in a "scripts dir", we just look for modules in (scripts), and load the modules directly. * module/Makefile.am: * module/scripts/: Move the scripts into module/ so they can be compiled. Rename scripts from `foo' to `foo.scm'. * libguile/Makefile.am: Invoke the snarf->texi code via guile-tools. * configure.in: * .gitignore: Update for changes. --- .gitignore | 1 - Makefile.am | 2 +- configure.in | 2 - libguile/Makefile.am | 2 +- meta/Makefile.am | 2 +- meta/guile-tools | 98 +++++++++++++++ meta/guile-tools.in | 118 ------------------ module/Makefile.am | 32 ++++- {scripts => module/scripts}/ChangeLog-2008 | 0 scripts/PROGRAM => module/scripts/PROGRAM.scm | 5 - {scripts => module/scripts}/README | 0 .../api-diff => module/scripts/api-diff.scm | 5 - .../autofrisk => module/scripts/autofrisk.scm | 5 - scripts/compile => module/scripts/compile.scm | 6 +- .../scripts/disassemble.scm | 6 +- .../scripts/display-commentary.scm | 5 - .../doc-snarf => module/scripts/doc-snarf.scm | 5 - scripts/frisk => module/scripts/frisk.scm | 5 - .../scripts/generate-autoload.scm | 5 - scripts/lint => module/scripts/lint.scm | 5 - scripts/punify => module/scripts/punify.scm | 5 - .../scripts/read-rfc822.scm | 5 - .../scripts/read-scheme-source.scm | 5 - .../scripts/read-text-outline.scm | 5 - .../scan-api => module/scripts/scan-api.scm | 5 - .../scripts/snarf-check-and-output-texi.scm | 5 - .../scripts/snarf-guile-m4-docs.scm | 5 - .../scripts/summarize-guile-TODO.scm | 5 - scripts/use2dot => module/scripts/use2dot.scm | 5 - scripts/Makefile.am | 70 ----------- 30 files changed, 134 insertions(+), 290 deletions(-) create mode 100755 meta/guile-tools delete mode 100644 meta/guile-tools.in rename {scripts => module/scripts}/ChangeLog-2008 (100%) rename scripts/PROGRAM => module/scripts/PROGRAM.scm (82%) mode change 100755 => 100644 rename {scripts => module/scripts}/README (100%) rename scripts/api-diff => module/scripts/api-diff.scm (97%) mode change 100755 => 100644 rename scripts/autofrisk => module/scripts/autofrisk.scm (97%) mode change 100755 => 100644 rename scripts/compile => module/scripts/compile.scm (98%) mode change 100755 => 100644 rename scripts/disassemble => module/scripts/disassemble.scm (92%) mode change 100755 => 100644 rename scripts/display-commentary => module/scripts/display-commentary.scm (90%) mode change 100755 => 100644 rename scripts/doc-snarf => module/scripts/doc-snarf.scm (98%) mode change 100755 => 100644 rename scripts/frisk => module/scripts/frisk.scm (98%) mode change 100755 => 100644 rename scripts/generate-autoload => module/scripts/generate-autoload.scm (96%) mode change 100755 => 100644 rename scripts/lint => module/scripts/lint.scm (97%) mode change 100755 => 100644 rename scripts/punify => module/scripts/punify.scm (92%) mode change 100755 => 100644 rename scripts/read-rfc822 => module/scripts/read-rfc822.scm (95%) mode change 100755 => 100644 rename scripts/read-scheme-source => module/scripts/read-scheme-source.scm (98%) mode change 100755 => 100644 rename scripts/read-text-outline => module/scripts/read-text-outline.scm (97%) mode change 100755 => 100644 rename scripts/scan-api => module/scripts/scan-api.scm (97%) mode change 100755 => 100644 rename scripts/snarf-check-and-output-texi => module/scripts/snarf-check-and-output-texi.scm (97%) mode change 100755 => 100644 rename scripts/snarf-guile-m4-docs => module/scripts/snarf-guile-m4-docs.scm (92%) mode change 100755 => 100644 rename scripts/summarize-guile-TODO => module/scripts/summarize-guile-TODO.scm (97%) mode change 100755 => 100644 rename scripts/use2dot => module/scripts/use2dot.scm (94%) mode change 100755 => 100644 delete mode 100644 scripts/Makefile.am diff --git a/.gitignore b/.gitignore index 3aa1f0471..0b2ff7cf2 100644 --- a/.gitignore +++ b/.gitignore @@ -53,7 +53,6 @@ conftest.c depcomp elisp-comp guile-*.tar.gz -guile-tools install-sh libtool ltconfig diff --git a/Makefile.am b/Makefile.am index 0e61f531d..a82143b78 100644 --- a/Makefile.am +++ b/Makefile.am @@ -25,7 +25,7 @@ AUTOMAKE_OPTIONS = 1.10 SUBDIRS = lib meta libguile guile-readline emacs \ - scripts srfi doc examples test-suite benchmark-suite lang am \ + srfi doc examples test-suite benchmark-suite lang am \ module testsuite include_HEADERS = libguile.h diff --git a/configure.in b/configure.in index e547ff00e..354e93c54 100644 --- a/configure.in +++ b/configure.in @@ -1537,7 +1537,6 @@ AC_CONFIG_FILES([ examples/Makefile lang/Makefile libguile/Makefile - scripts/Makefile srfi/Makefile test-suite/Makefile test-suite/standalone/Makefile @@ -1556,7 +1555,6 @@ AC_CONFIG_FILES([meta/guile-1.8.pc]) AC_CONFIG_FILES([meta/guile-1.8-uninstalled.pc]) AC_CONFIG_FILES([check-guile], [chmod +x check-guile]) AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile]) -AC_CONFIG_FILES([meta/guile-tools], [chmod +x meta/guile-tools]) AC_CONFIG_FILES([meta/guile], [chmod +x meta/guile]) AC_CONFIG_FILES([meta/uninstalled-env], [chmod +x meta/uninstalled-env]) AC_CONFIG_FILES([meta/gdb-uninstalled-guile], [chmod +x meta/gdb-uninstalled-guile]) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8f26e34d2..369b24951 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -329,7 +329,7 @@ load.x: libpath.h include $(top_srcdir)/am/pre-inst-guile alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) -snarf2checkedtexi = GUILE="$(GUILE_FOR_BUILD)" $(top_srcdir)/scripts/snarf-check-and-output-texi +snarf2checkedtexi = $(top_builddir)/meta/uninstalled-env guile-tools snarf-check-and-output-texi dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi) guile.texi: $(alldotdocfiles) guile$(EXEEXT) diff --git a/meta/Makefile.am b/meta/Makefile.am index da587e33d..6614ab349 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -21,7 +21,7 @@ ## Floor, Boston, MA 02110-1301 USA bin_SCRIPTS=guile-config guile-tools -EXTRA_DIST=guile-tools.in guile.m4 ChangeLog-2008 \ +EXTRA_DIST=guile.m4 ChangeLog-2008 \ guile-1.8.pc.in guile-1.8-uninstalled.pc.in pkgconfigdir = $(libdir)/pkgconfig diff --git a/meta/guile-tools b/meta/guile-tools new file mode 100755 index 000000000..6df88effa --- /dev/null +++ b/meta/guile-tools @@ -0,0 +1,98 @@ +#!/bin/sh +# -*- scheme -*- +exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" +!# + +;;;; guile-tools --- running scripts bundled with Guile +;;;; Jim Blandy --- September 1997 +;;;; +;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (guile-tools) + #:use-module (srfi srfi-1)) + +(define (help) + (display "\ +Usage: guile-tools --version + guile-tools --help + guile-tools PROGRAM [ARGS] + +If PROGRAM is \"list\" or omitted, display available scripts, otherwise +PROGRAM is run with ARGS. +")) + +(define (directory-files dir) + (if (and (file-exists? dir) (file-is-directory? dir)) + (let ((dir-stream (opendir dir))) + (let loop ((new (readdir dir-stream)) + (acc '())) + (if (eof-object? new) + (begin + (closedir dir-stream) + acc) + (loop (readdir dir-stream) + (if (or (string=? "." new) ; ignore + (string=? ".." new)) ; ignore + acc + (cons new acc)))))) + '())) + +(define (strip-extensions path) + (or-map (lambda (ext) + (and + (string-suffix? ext path) + (substring path 0 + (- (string-length path) (string-length ext))))) + (append %load-extensions %load-compiled-extensions))) + +(define (unique l) + (cond ((null? l) l) + ((null? (cdr l)) l) + ((equal? (car l) (cadr l)) (unique (cdr l))) + (else (cons (car l) (unique (cdr l)))))) + +(define (find-submodules head) + (let ((shead (map symbol->string head))) + (unique + (sort + (append-map (lambda (path) + (fold (lambda (x rest) + (let ((stripped (strip-extensions x))) + (if stripped (cons stripped rest) rest))) + '() + (directory-files + (fold (lambda (x y) (in-vicinity y x)) path shead)))) + %load-path) + stringsymbol s)))))) + (and (module-public-interface m) + m))) + +(define (main args) + (if (or (equal? (cdr args) '()) + (equal? (cdr args) '("list"))) + (list-scripts) + (let ((mod (find-script (cadr args)))) + (exit ((module-ref mod 'main) (cdr args)))))) diff --git a/meta/guile-tools.in b/meta/guile-tools.in deleted file mode 100644 index 68db26887..000000000 --- a/meta/guile-tools.in +++ /dev/null @@ -1,118 +0,0 @@ -#!/bin/sh - -# Copyright (C) 2001, 2003, 2006, 2008 Free Software Foundation, Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License as -# published by the Free Software Foundation; either version 2, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -# Boston, MA 02110-1301 USA - -# Usage: See `help' func below. -# -# TODO -# - handle pre-install invocation -# - "full" option processing (but see comment below) -# -# Author: Thien-Thi Nguyen - -help () -{ - cat <.~%") #:opts compile-opts))) input-files))) +(define main compile) + ;;; Local Variables: ;;; coding: latin-1 ;;; End: diff --git a/scripts/disassemble b/module/scripts/disassemble.scm old mode 100755 new mode 100644 similarity index 92% rename from scripts/disassemble rename to module/scripts/disassemble.scm index 71ec05705..46ef0c744 --- a/scripts/disassemble +++ b/module/scripts/disassemble.scm @@ -1,7 +1,3 @@ -#!/bin/sh -# -*- scheme -*- -exec ${GUILE-guile} -e '(@ (scripts disassemble) disassemble)' -s $0 "$@" -!# ;;; Disassemble --- Disassemble .go files into something human-readable ;; Copyright 2005,2008 Free Software Foundation, Inc. @@ -39,3 +35,5 @@ exec ${GUILE-guile} -e '(@ (scripts disassemble) disassemble)' -s $0 "$@" (for-each (lambda (file) (disassemble (load-objcode file))) (cdr args))) + +(define main disassemble) diff --git a/scripts/display-commentary b/module/scripts/display-commentary.scm old mode 100755 new mode 100644 similarity index 90% rename from scripts/display-commentary rename to module/scripts/display-commentary.scm index a12dae8c7..fd1ffd004 --- a/scripts/display-commentary +++ b/module/scripts/display-commentary.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; display-commentary --- As advertized ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. diff --git a/scripts/doc-snarf b/module/scripts/doc-snarf.scm old mode 100755 new mode 100644 similarity index 98% rename from scripts/doc-snarf rename to module/scripts/doc-snarf.scm index 4bc09f57c..4ceddc152 --- a/scripts/doc-snarf +++ b/module/scripts/doc-snarf.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; doc-snarf --- Extract documentation from source files ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. diff --git a/scripts/frisk b/module/scripts/frisk.scm old mode 100755 new mode 100644 similarity index 98% rename from scripts/frisk rename to module/scripts/frisk.scm index 609a5e6a9..374bb4e3c --- a/scripts/frisk +++ b/module/scripts/frisk.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; frisk --- Grok the module interfaces of a body of files ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. diff --git a/scripts/generate-autoload b/module/scripts/generate-autoload.scm old mode 100755 new mode 100644 similarity index 96% rename from scripts/generate-autoload rename to module/scripts/generate-autoload.scm index b08be8357..10f158c98 --- a/scripts/generate-autoload +++ b/module/scripts/generate-autoload.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; generate-autoload --- Display define-module form with autoload info ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. diff --git a/scripts/lint b/module/scripts/lint.scm old mode 100755 new mode 100644 similarity index 97% rename from scripts/lint rename to module/scripts/lint.scm index 354420751..2ee9b7863 --- a/scripts/lint +++ b/module/scripts/lint.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts lint)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; lint --- Preemptive checks for coding errors in Guile Scheme code ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. diff --git a/scripts/punify b/module/scripts/punify.scm old mode 100755 new mode 100644 similarity index 92% rename from scripts/punify rename to module/scripts/punify.scm index 0f6a36114..098c4b935 --- a/scripts/punify +++ b/module/scripts/punify.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts punify)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; punify --- Display Scheme code w/o unnecessary comments / whitespace ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. diff --git a/scripts/read-rfc822 b/module/scripts/read-rfc822.scm old mode 100755 new mode 100644 similarity index 95% rename from scripts/read-rfc822 rename to module/scripts/read-rfc822.scm index 0904d61d1..ed3aced7d --- a/scripts/read-rfc822 +++ b/module/scripts/read-rfc822.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts read-rfc822)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout ;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc. diff --git a/scripts/read-scheme-source b/module/scripts/read-scheme-source.scm old mode 100755 new mode 100644 similarity index 98% rename from scripts/read-scheme-source rename to module/scripts/read-scheme-source.scm index 05bb1064c..c593d64e3 --- a/scripts/read-scheme-source +++ b/module/scripts/read-scheme-source.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. diff --git a/scripts/read-text-outline b/module/scripts/read-text-outline.scm old mode 100755 new mode 100644 similarity index 97% rename from scripts/read-text-outline rename to module/scripts/read-text-outline.scm index c85026952..579fb6934 --- a/scripts/read-text-outline +++ b/module/scripts/read-text-outline.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; read-text-outline --- Read a text outline and display it as a sexp ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. diff --git a/scripts/scan-api b/module/scripts/scan-api.scm old mode 100755 new mode 100644 similarity index 97% rename from scripts/scan-api rename to module/scripts/scan-api.scm index 3ea10dbe6..ceaac43d4 --- a/scripts/scan-api +++ b/module/scripts/scan-api.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; scan-api --- Scan and group interpreter and libguile interface elements ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. diff --git a/scripts/snarf-check-and-output-texi b/module/scripts/snarf-check-and-output-texi.scm old mode 100755 new mode 100644 similarity index 97% rename from scripts/snarf-check-and-output-texi rename to module/scripts/snarf-check-and-output-texi.scm index ea33e1797..049d08411 --- a/scripts/snarf-check-and-output-texi +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)" -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; snarf-check-and-output-texi --- called by the doc snarfer. ;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. diff --git a/scripts/snarf-guile-m4-docs b/module/scripts/snarf-guile-m4-docs.scm old mode 100755 new mode 100644 similarity index 92% rename from scripts/snarf-guile-m4-docs rename to module/scripts/snarf-guile-m4-docs.scm index b80f187fe..11fb82b3d --- a/scripts/snarf-guile-m4-docs +++ b/module/scripts/snarf-guile-m4-docs.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts snarf-guile-m4-docs)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. diff --git a/scripts/summarize-guile-TODO b/module/scripts/summarize-guile-TODO.scm old mode 100755 new mode 100644 similarity index 97% rename from scripts/summarize-guile-TODO rename to module/scripts/summarize-guile-TODO.scm index 79543fe27..bf4f14535 --- a/scripts/summarize-guile-TODO +++ b/module/scripts/summarize-guile-TODO.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts summarize-guile-TODO)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; summarize-guile-TODO --- Display Guile TODO list in various ways ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. diff --git a/scripts/use2dot b/module/scripts/use2dot.scm old mode 100755 new mode 100644 similarity index 94% rename from scripts/use2dot rename to module/scripts/use2dot.scm index 30b4690e0..bf1fdbddb --- a/scripts/use2dot +++ b/module/scripts/use2dot.scm @@ -1,8 +1,3 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# ;;; use2dot --- Display module dependencies as a DOT specification ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. diff --git a/scripts/Makefile.am b/scripts/Makefile.am deleted file mode 100644 index ca96da78d..000000000 --- a/scripts/Makefile.am +++ /dev/null @@ -1,70 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2002, 2006, 2008 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -# These should be installed and distributed. -scripts_sources = \ - PROGRAM \ - autofrisk \ - compile \ - disassemble \ - display-commentary \ - doc-snarf \ - frisk \ - generate-autoload \ - lint \ - punify \ - read-scheme-source \ - read-text-outline \ - use2dot \ - snarf-check-and-output-texi \ - summarize-guile-TODO \ - scan-api \ - api-diff \ - read-rfc822 \ - snarf-guile-m4-docs - -subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/scripts -subpkgdata_SCRIPTS = $(scripts_sources) - -EXTRA_DIST = $(scripts_sources) ChangeLog-2008 - -list: - @echo $(scripts_sources) - -include $(top_srcdir)/am/pre-inst-guile - -overview: $(scripts_sources) - @echo '----------------------------' - @echo Overview - @echo I. Commentaries - @echo II. Module Interfaces - @echo '----------------------------' - @echo I. Commentaries - @echo '----------------------------' - $(preinstguiletool)/display-commentary $^ - @echo '----------------------------' - @echo II. Module Interfaces - @echo '----------------------------' - $(preinstguiletool)/frisk $^ - -# Makefile.am ends here From 17df23e324eec8b8541bdd283e361c19a4159fa3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Apr 2009 15:18:46 +0200 Subject: [PATCH 029/375] fix a tricky GC bug in scm_c_make_subr * libguile/procs.c (scm_c_make_subr): Fix a really tricky bug!!! If scm_double_cell caused GC, the symbolic name wouldn't be marked. But the symptom wouldn't appear until you accessed that symbol much later, for example during tab completion / apropos grovelling. Not sure why we didn't see this earlier. --- libguile/procs.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/procs.c b/libguile/procs.c index 8230e07ae..b3a0d3215 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -45,15 +45,19 @@ SCM scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { register SCM z; + SCM sname; SCM *meta_info; meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info"); - meta_info[0] = scm_from_locale_symbol (name); + sname = scm_from_locale_symbol (name); + meta_info[0] = sname; meta_info[1] = SCM_EOL; /* properties */ z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn, 0 /* generic */, (scm_t_bits) meta_info); + scm_remember_upto_here_1 (sname); + return z; } From 9d80c15649e21fd3798eae06e15a120839a9e14e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 29 Mar 2009 10:41:27 -0700 Subject: [PATCH 030/375] serialize module information into syncase's output -- getting ready for hygiene * module/ice-9/Makefile.am: Replace annotate.scm with expand-support.scm. * module/ice-9/annotate.scm: Removed; subsumed into expand-support.scm. * module/ice-9/compile-psyntax.scm: Strip out expansion structures before writing to disk. * module/ice-9/expand-support.scm: New file. Provides annotation support, and other compound data types for use by the expander. Currently the only one that is used is the toplevel reference, , but we will record lexicals this way soon. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/psyntax.scm (build-global-reference) (build-global-assignment): Instead of expanding out global references as symbols, expand them as structures, with space to record the module that they should be scoped against. This is in anticipation of us actually threading the module info through the syntax transformation, so that we can get hygiene with respect to modules. * module/ice-9/syncase.scm: Replace eval-when. Since sc-expand will give us something that isn't Scheme because we put the structures in it, strip that info whenever we actually do need scheme. * module/language/scheme/compile-ghil.scm (lookup-transformer): Strip expansion structures here too. * module/language/scheme/expand.scm (language): Swap annotate for expand-support. But this file will die soon, I think. --- module/ice-9/Makefile.am | 2 +- module/ice-9/compile-psyntax.scm | 4 +- .../{annotate.scm => expand-support.scm} | 86 ++++++++++++++++++- module/ice-9/psyntax-pp.scm | 22 ++--- module/ice-9/psyntax.scm | 4 +- module/ice-9/syncase.scm | 15 ++-- module/language/scheme/compile-ghil.scm | 4 +- module/language/scheme/expand.scm | 2 +- 8 files changed, 113 insertions(+), 26 deletions(-) rename module/ice-9/{annotate.scm => expand-support.scm} (53%) diff --git a/module/ice-9/Makefile.am b/module/ice-9/Makefile.am index 8c94d8320..a93ec817b 100644 --- a/module/ice-9/Makefile.am +++ b/module/ice-9/Makefile.am @@ -30,7 +30,7 @@ modpath = ice-9 # and forth between interpreted and compiled code, we end up using more # of the C stack than the interpreter would have; so avoid that by # putting these core modules first. -SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \ +SOURCES = psyntax-pp.scm expand-support.scm boot-9.scm \ and-let-star.scm calling.scm common-list.scm \ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ format.scm getopt-long.scm hcons.scm i18n.scm \ diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index a2fe77546..51e3de11f 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -20,7 +20,9 @@ (close-port out) (close-port in)) (begin - (write (sc-expand3 x 'c '(compile load eval)) out) + (write (strip-expansion-structures + (sc-expand3 x 'c '(compile load eval))) + out) (newline out) (loop (read in))))))) diff --git a/module/ice-9/annotate.scm b/module/ice-9/expand-support.scm similarity index 53% rename from module/ice-9/annotate.scm rename to module/ice-9/expand-support.scm index 30f49d710..597e7ff38 100644 --- a/module/ice-9/annotate.scm +++ b/module/ice-9/expand-support.scm @@ -16,11 +16,19 @@ ;;;; -(define-module (ice-9 annotate) +(define-module (ice-9 expand-support) :export ( annotation? annotate deannotate make-annotation annotation-expression annotation-source annotation-stripped set-annotation-stripped! - deannotate/source-properties)) + deannotate/source-properties + + make-module-ref + module-ref-symbol module-ref-modname module-ref-public? + + make-lexical + lexical-name lexical-gensym + + strip-expansion-structures)) (define (make-vtable "prprpw" @@ -78,3 +86,77 @@ (set-source-properties! e source)) e)) (else e))) + + + +(define + (make-vtable "prprpr" + (lambda (struct port) + (display "#<" port) + (display (if (module-ref-public? struct) "@ " "@@ ") port) + (display (module-ref-modname struct) port) + (display " " port) + (display (module-ref-symbol struct) port) + (display ">" port)))) + +(define (module-ref? x) + (and (struct? x) (eq? (struct-vtable x) ))) + +(define (make-module-ref modname symbol public?) + (make-struct 0 modname symbol public?)) + +(define (module-ref-modname a) + (struct-ref a 0)) +(define (module-ref-symbol a) + (struct-ref a 1)) +(define (module-ref-public? a) + (struct-ref a 2)) + + + +(define + (make-vtable "prpr" + (lambda (struct port) + (display "#" port)))) + +(define (lexical? x) + (and (struct? x) (eq? (struct-vtable x) ))) + +(define (make-lexical name gensym) + (make-struct 0 name gensym)) + +(define (lexical-name a) + (struct-ref a 0)) +(define (lexical-gensym a) + (struct-ref a 1)) + + + +(define (strip-expansion-structures e) + (cond ((list? e) + (map strip-expansion-structures e)) + ((pair? e) + (cons (strip-expansion-structures (car e)) + (strip-expansion-structures (cdr e)))) + ((annotation? e) + (let ((e (strip-expansion-structures (annotation-expression e))) + (source (annotation-source e))) + (if (pair? e) + (set-source-properties! e source)) + e)) + ((module-ref? e) + (if (module-ref-modname e) + `(,(if (module-ref-public? e) '@ '@@) + ,(module-ref-modname e) + ,(module-ref-symbol e)) + (module-ref-symbol e))) + ((lexical? e) + (lexical-gensym e)) + ((record? e) + (error "unexpected record in expansion" e)) + (else e))) + diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 1fde489a8..3c4cee9d1 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-151 (lambda (syntmp-vars-536) (let syntmp-lvl-537 ((syntmp-vars-538 syntmp-vars-536) (syntmp-ls-539 (quote ())) (syntmp-w-540 (quote (())))) (cond ((pair? syntmp-vars-538) (syntmp-lvl-537 (cdr syntmp-vars-538) (cons (syntmp-wrap-130 (car syntmp-vars-538) syntmp-w-540) syntmp-ls-539) syntmp-w-540)) ((syntmp-id?-102 syntmp-vars-538) (cons (syntmp-wrap-130 syntmp-vars-538 syntmp-w-540) syntmp-ls-539)) ((null? syntmp-vars-538) syntmp-ls-539) ((syntmp-syntax-object?-88 syntmp-vars-538) (syntmp-lvl-537 (syntmp-syntax-object-expression-89 syntmp-vars-538) syntmp-ls-539 (syntmp-join-wraps-121 syntmp-w-540 (syntmp-syntax-object-wrap-90 syntmp-vars-538)))) ((annotation? syntmp-vars-538) (syntmp-lvl-537 (annotation-expression syntmp-vars-538) syntmp-ls-539 syntmp-w-540)) (else (cons syntmp-vars-538 syntmp-ls-539)))))) (syntmp-gen-var-150 (lambda (syntmp-id-541) (let ((syntmp-id-542 (if (syntmp-syntax-object?-88 syntmp-id-541) (syntmp-syntax-object-expression-89 syntmp-id-541) syntmp-id-541))) (if (annotation? syntmp-id-542) (syntmp-build-annotated-81 (annotation-source syntmp-id-542) (gensym (symbol->string (annotation-expression syntmp-id-542)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-542))))))) (syntmp-strip-149 (lambda (syntmp-x-543 syntmp-w-544) (if (memq (quote top) (syntmp-wrap-marks-105 syntmp-w-544)) (if (or (annotation? syntmp-x-543) (and (pair? syntmp-x-543) (annotation? (car syntmp-x-543)))) (syntmp-strip-annotation-148 syntmp-x-543 #f) syntmp-x-543) (let syntmp-f-545 ((syntmp-x-546 syntmp-x-543)) (cond ((syntmp-syntax-object?-88 syntmp-x-546) (syntmp-strip-149 (syntmp-syntax-object-expression-89 syntmp-x-546) (syntmp-syntax-object-wrap-90 syntmp-x-546))) ((pair? syntmp-x-546) (let ((syntmp-a-547 (syntmp-f-545 (car syntmp-x-546))) (syntmp-d-548 (syntmp-f-545 (cdr syntmp-x-546)))) (if (and (eq? syntmp-a-547 (car syntmp-x-546)) (eq? syntmp-d-548 (cdr syntmp-x-546))) syntmp-x-546 (cons syntmp-a-547 syntmp-d-548)))) ((vector? syntmp-x-546) (let ((syntmp-old-549 (vector->list syntmp-x-546))) (let ((syntmp-new-550 (map syntmp-f-545 syntmp-old-549))) (if (andmap eq? syntmp-old-549 syntmp-new-550) syntmp-x-546 (list->vector syntmp-new-550))))) (else syntmp-x-546)))))) (syntmp-strip-annotation-148 (lambda (syntmp-x-551 syntmp-parent-552) (cond ((pair? syntmp-x-551) (let ((syntmp-new-553 (cons #f #f))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-553)) (set-car! syntmp-new-553 (syntmp-strip-annotation-148 (car syntmp-x-551) #f)) (set-cdr! syntmp-new-553 (syntmp-strip-annotation-148 (cdr syntmp-x-551) #f)) syntmp-new-553))) ((annotation? syntmp-x-551) (or (annotation-stripped syntmp-x-551) (syntmp-strip-annotation-148 (annotation-expression syntmp-x-551) syntmp-x-551))) ((vector? syntmp-x-551) (let ((syntmp-new-554 (make-vector (vector-length syntmp-x-551)))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-554)) (let syntmp-loop-555 ((syntmp-i-556 (- (vector-length syntmp-x-551) 1))) (unless (syntmp-fx<-75 syntmp-i-556 0) (vector-set! syntmp-new-554 syntmp-i-556 (syntmp-strip-annotation-148 (vector-ref syntmp-x-551 syntmp-i-556) #f)) (syntmp-loop-555 (syntmp-fx--73 syntmp-i-556 1)))) syntmp-new-554))) (else syntmp-x-551)))) (syntmp-ellipsis?-147 (lambda (syntmp-x-557) (and (syntmp-nonsymbol-id?-101 syntmp-x-557) (syntmp-free-id=?-125 syntmp-x-557 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-146 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-145 (lambda (syntmp-expanded-558) (let ((syntmp-p-559 (syntmp-local-eval-hook-77 syntmp-expanded-558))) (if (procedure? syntmp-p-559) syntmp-p-559 (syntax-error syntmp-p-559 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-144 (lambda (syntmp-rec?-560 syntmp-e-561 syntmp-r-562 syntmp-w-563 syntmp-s-564 syntmp-k-565) ((lambda (syntmp-tmp-566) ((lambda (syntmp-tmp-567) (if syntmp-tmp-567 (apply (lambda (syntmp-_-568 syntmp-id-569 syntmp-val-570 syntmp-e1-571 syntmp-e2-572) (let ((syntmp-ids-573 syntmp-id-569)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-573)) (syntax-error syntmp-e-561 "duplicate bound keyword in") (let ((syntmp-labels-575 (syntmp-gen-labels-108 syntmp-ids-573))) (let ((syntmp-new-w-576 (syntmp-make-binding-wrap-119 syntmp-ids-573 syntmp-labels-575 syntmp-w-563))) (syntmp-k-565 (cons syntmp-e1-571 syntmp-e2-572) (syntmp-extend-env-96 syntmp-labels-575 (let ((syntmp-w-578 (if syntmp-rec?-560 syntmp-new-w-576 syntmp-w-563)) (syntmp-trans-r-579 (syntmp-macros-only-env-98 syntmp-r-562))) (map (lambda (syntmp-x-580) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-580 syntmp-trans-r-579 syntmp-w-578)))) syntmp-val-570)) syntmp-r-562) syntmp-new-w-576 syntmp-s-564)))))) syntmp-tmp-567) ((lambda (syntmp-_-582) (syntax-error (syntmp-source-wrap-131 syntmp-e-561 syntmp-w-563 syntmp-s-564))) syntmp-tmp-566))) (syntax-dispatch syntmp-tmp-566 (quote (any #(each (any any)) any . each-any))))) syntmp-e-561))) (syntmp-chi-lambda-clause-143 (lambda (syntmp-e-583 syntmp-c-584 syntmp-r-585 syntmp-w-586 syntmp-k-587) ((lambda (syntmp-tmp-588) ((lambda (syntmp-tmp-589) (if syntmp-tmp-589 (apply (lambda (syntmp-id-590 syntmp-e1-591 syntmp-e2-592) (let ((syntmp-ids-593 syntmp-id-590)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-593)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-595 (syntmp-gen-labels-108 syntmp-ids-593)) (syntmp-new-vars-596 (map syntmp-gen-var-150 syntmp-ids-593))) (syntmp-k-587 syntmp-new-vars-596 (syntmp-chi-body-142 (cons syntmp-e1-591 syntmp-e2-592) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-595 syntmp-new-vars-596 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-ids-593 syntmp-labels-595 syntmp-w-586))))))) syntmp-tmp-589) ((lambda (syntmp-tmp-598) (if syntmp-tmp-598 (apply (lambda (syntmp-ids-599 syntmp-e1-600 syntmp-e2-601) (let ((syntmp-old-ids-602 (syntmp-lambda-var-list-151 syntmp-ids-599))) (if (not (syntmp-valid-bound-ids?-127 syntmp-old-ids-602)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-603 (syntmp-gen-labels-108 syntmp-old-ids-602)) (syntmp-new-vars-604 (map syntmp-gen-var-150 syntmp-old-ids-602))) (syntmp-k-587 (let syntmp-f-605 ((syntmp-ls1-606 (cdr syntmp-new-vars-604)) (syntmp-ls2-607 (car syntmp-new-vars-604))) (if (null? syntmp-ls1-606) syntmp-ls2-607 (syntmp-f-605 (cdr syntmp-ls1-606) (cons (car syntmp-ls1-606) syntmp-ls2-607)))) (syntmp-chi-body-142 (cons syntmp-e1-600 syntmp-e2-601) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-603 syntmp-new-vars-604 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-old-ids-602 syntmp-labels-603 syntmp-w-586))))))) syntmp-tmp-598) ((lambda (syntmp-_-609) (syntax-error syntmp-e-583)) syntmp-tmp-588))) (syntax-dispatch syntmp-tmp-588 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-588 (quote (each-any any . each-any))))) syntmp-c-584))) (syntmp-chi-body-142 (lambda (syntmp-body-610 syntmp-outer-form-611 syntmp-r-612 syntmp-w-613) (let ((syntmp-r-614 (cons (quote ("placeholder" placeholder)) syntmp-r-612))) (let ((syntmp-ribcage-615 (syntmp-make-ribcage-109 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-616 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-613) (cons syntmp-ribcage-615 (syntmp-wrap-subst-106 syntmp-w-613))))) (let syntmp-parse-617 ((syntmp-body-618 (map (lambda (syntmp-x-624) (cons syntmp-r-614 (syntmp-wrap-130 syntmp-x-624 syntmp-w-616))) syntmp-body-610)) (syntmp-ids-619 (quote ())) (syntmp-labels-620 (quote ())) (syntmp-vars-621 (quote ())) (syntmp-vals-622 (quote ())) (syntmp-bindings-623 (quote ()))) (if (null? syntmp-body-618) (syntax-error syntmp-outer-form-611 "no expressions in body") (let ((syntmp-e-625 (cdar syntmp-body-618)) (syntmp-er-626 (caar syntmp-body-618))) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-625 syntmp-er-626 (quote (())) #f syntmp-ribcage-615)) (lambda (syntmp-type-627 syntmp-value-628 syntmp-e-629 syntmp-w-630 syntmp-s-631) (let ((syntmp-t-632 syntmp-type-627)) (if (memv syntmp-t-632 (quote (define-form))) (let ((syntmp-id-633 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-634 (syntmp-gen-label-107))) (let ((syntmp-var-635 (syntmp-gen-var-150 syntmp-id-633))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-633 syntmp-label-634) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-633 syntmp-ids-619) (cons syntmp-label-634 syntmp-labels-620) (cons syntmp-var-635 syntmp-vars-621) (cons (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630)) syntmp-vals-622) (cons (cons (quote lexical) syntmp-var-635) syntmp-bindings-623))))) (if (memv syntmp-t-632 (quote (define-syntax-form))) (let ((syntmp-id-636 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-637 (syntmp-gen-label-107))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-636 syntmp-label-637) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-636 syntmp-ids-619) (cons syntmp-label-637 syntmp-labels-620) syntmp-vars-621 syntmp-vals-622 (cons (cons (quote macro) (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630))) syntmp-bindings-623)))) (if (memv syntmp-t-632 (quote (begin-form))) ((lambda (syntmp-tmp-638) ((lambda (syntmp-tmp-639) (if syntmp-tmp-639 (apply (lambda (syntmp-_-640 syntmp-e1-641) (syntmp-parse-617 (let syntmp-f-642 ((syntmp-forms-643 syntmp-e1-641)) (if (null? syntmp-forms-643) (cdr syntmp-body-618) (cons (cons syntmp-er-626 (syntmp-wrap-130 (car syntmp-forms-643) syntmp-w-630)) (syntmp-f-642 (cdr syntmp-forms-643))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623)) syntmp-tmp-639) (syntax-error syntmp-tmp-638))) (syntax-dispatch syntmp-tmp-638 (quote (any . each-any))))) syntmp-e-629) (if (memv syntmp-t-632 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-628 syntmp-e-629 syntmp-er-626 syntmp-w-630 syntmp-s-631 (lambda (syntmp-forms-645 syntmp-er-646 syntmp-w-647 syntmp-s-648) (syntmp-parse-617 (let syntmp-f-649 ((syntmp-forms-650 syntmp-forms-645)) (if (null? syntmp-forms-650) (cdr syntmp-body-618) (cons (cons syntmp-er-646 (syntmp-wrap-130 (car syntmp-forms-650) syntmp-w-647)) (syntmp-f-649 (cdr syntmp-forms-650))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623))) (if (null? syntmp-ids-619) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-651) (syntmp-chi-138 (cdr syntmp-x-651) (car syntmp-x-651) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))) (begin (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-619)) (syntax-error syntmp-outer-form-611 "invalid or duplicate identifier in definition")) (let syntmp-loop-652 ((syntmp-bs-653 syntmp-bindings-623) (syntmp-er-cache-654 #f) (syntmp-r-cache-655 #f)) (if (not (null? syntmp-bs-653)) (let ((syntmp-b-656 (car syntmp-bs-653))) (if (eq? (car syntmp-b-656) (quote macro)) (let ((syntmp-er-657 (cadr syntmp-b-656))) (let ((syntmp-r-cache-658 (if (eq? syntmp-er-657 syntmp-er-cache-654) syntmp-r-cache-655 (syntmp-macros-only-env-98 syntmp-er-657)))) (begin (set-cdr! syntmp-b-656 (syntmp-eval-local-transformer-145 (syntmp-chi-138 (cddr syntmp-b-656) syntmp-r-cache-658 (quote (()))))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-657 syntmp-r-cache-658)))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-cache-654 syntmp-r-cache-655))))) (set-cdr! syntmp-r-614 (syntmp-extend-env-96 syntmp-labels-620 syntmp-bindings-623 (cdr syntmp-r-614))) (syntmp-build-letrec-86 #f syntmp-vars-621 (map (lambda (syntmp-x-659) (syntmp-chi-138 (cdr syntmp-x-659) (car syntmp-x-659) (quote (())))) syntmp-vals-622) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-660) (syntmp-chi-138 (cdr syntmp-x-660) (car syntmp-x-660) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))))))))))))))))))))) (syntmp-chi-macro-141 (lambda (syntmp-p-661 syntmp-e-662 syntmp-r-663 syntmp-w-664 syntmp-rib-665) (letrec ((syntmp-rebuild-macro-output-666 (lambda (syntmp-x-667 syntmp-m-668) (cond ((pair? syntmp-x-667) (cons (syntmp-rebuild-macro-output-666 (car syntmp-x-667) syntmp-m-668) (syntmp-rebuild-macro-output-666 (cdr syntmp-x-667) syntmp-m-668))) ((syntmp-syntax-object?-88 syntmp-x-667) (let ((syntmp-w-669 (syntmp-syntax-object-wrap-90 syntmp-x-667))) (let ((syntmp-ms-670 (syntmp-wrap-marks-105 syntmp-w-669)) (syntmp-s-671 (syntmp-wrap-subst-106 syntmp-w-669))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-667) (if (and (pair? syntmp-ms-670) (eq? (car syntmp-ms-670) #f)) (syntmp-make-wrap-104 (cdr syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cdr syntmp-s-671)) (cdr syntmp-s-671))) (syntmp-make-wrap-104 (cons syntmp-m-668 syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cons (quote shift) syntmp-s-671)) (cons (quote shift) syntmp-s-671)))))))) ((vector? syntmp-x-667) (let ((syntmp-n-672 (vector-length syntmp-x-667))) (let ((syntmp-v-673 (make-vector syntmp-n-672))) (let syntmp-doloop-674 ((syntmp-i-675 0)) (if (syntmp-fx=-74 syntmp-i-675 syntmp-n-672) syntmp-v-673 (begin (vector-set! syntmp-v-673 syntmp-i-675 (syntmp-rebuild-macro-output-666 (vector-ref syntmp-x-667 syntmp-i-675) syntmp-m-668)) (syntmp-doloop-674 (syntmp-fx+-72 syntmp-i-675 1)))))))) ((symbol? syntmp-x-667) (syntax-error syntmp-x-667 "encountered raw symbol in macro output")) (else syntmp-x-667))))) (syntmp-rebuild-macro-output-666 (syntmp-p-661 (syntmp-wrap-130 syntmp-e-662 (syntmp-anti-mark-117 syntmp-w-664))) (string #\m))))) (syntmp-chi-application-140 (lambda (syntmp-x-676 syntmp-e-677 syntmp-r-678 syntmp-w-679 syntmp-s-680) ((lambda (syntmp-tmp-681) ((lambda (syntmp-tmp-682) (if syntmp-tmp-682 (apply (lambda (syntmp-e0-683 syntmp-e1-684) (syntmp-build-annotated-81 syntmp-s-680 (cons syntmp-x-676 (map (lambda (syntmp-e-685) (syntmp-chi-138 syntmp-e-685 syntmp-r-678 syntmp-w-679)) syntmp-e1-684)))) syntmp-tmp-682) (syntax-error syntmp-tmp-681))) (syntax-dispatch syntmp-tmp-681 (quote (any . each-any))))) syntmp-e-677))) (syntmp-chi-expr-139 (lambda (syntmp-type-687 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (let ((syntmp-t-693 syntmp-type-687)) (if (memv syntmp-t-693 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (core external-macro))) (syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (lexical-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (global-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (constant))) (syntmp-build-data-82 syntmp-s-692 (syntmp-strip-149 (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) (quote (())))) (if (memv syntmp-t-693 (quote (global))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (call))) (syntmp-chi-application-140 (syntmp-chi-138 (car syntmp-e-689) syntmp-r-690 syntmp-w-691) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (begin-form))) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-_-696 syntmp-e1-697 syntmp-e2-698) (syntmp-chi-sequence-132 (cons syntmp-e1-697 syntmp-e2-698) syntmp-r-690 syntmp-w-691 syntmp-s-692)) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692 syntmp-chi-sequence-132) (if (memv syntmp-t-693 (quote (eval-when-form))) ((lambda (syntmp-tmp-700) ((lambda (syntmp-tmp-701) (if syntmp-tmp-701 (apply (lambda (syntmp-_-702 syntmp-x-703 syntmp-e1-704 syntmp-e2-705) (let ((syntmp-when-list-706 (syntmp-chi-when-list-135 syntmp-e-689 syntmp-x-703 syntmp-w-691))) (if (memq (quote eval) syntmp-when-list-706) (syntmp-chi-sequence-132 (cons syntmp-e1-704 syntmp-e2-705) syntmp-r-690 syntmp-w-691 syntmp-s-692) (syntmp-chi-void-146)))) syntmp-tmp-701) (syntax-error syntmp-tmp-700))) (syntax-dispatch syntmp-tmp-700 (quote (any each-any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-130 syntmp-value-688 syntmp-w-691) "invalid context for definition of") (if (memv syntmp-t-693 (quote (syntax))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to pattern variable outside syntax form") (if (memv syntmp-t-693 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692)))))))))))))))))) (syntmp-chi-138 (lambda (syntmp-e-709 syntmp-r-710 syntmp-w-711) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-709 syntmp-r-710 syntmp-w-711 #f #f)) (lambda (syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-w-715 syntmp-s-716) (syntmp-chi-expr-139 syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-r-710 syntmp-w-715 syntmp-s-716))))) (syntmp-chi-top-137 (lambda (syntmp-e-717 syntmp-r-718 syntmp-w-719 syntmp-m-720 syntmp-esew-721) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-717 syntmp-r-718 syntmp-w-719 #f #f)) (lambda (syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-w-737 syntmp-s-738) (let ((syntmp-t-739 syntmp-type-734)) (if (memv syntmp-t-739 (quote (begin-form))) ((lambda (syntmp-tmp-740) ((lambda (syntmp-tmp-741) (if syntmp-tmp-741 (apply (lambda (syntmp-_-742) (syntmp-chi-void-146)) syntmp-tmp-741) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744 syntmp-e1-745 syntmp-e2-746) (syntmp-chi-top-sequence-133 (cons syntmp-e1-745 syntmp-e2-746) syntmp-r-718 syntmp-w-737 syntmp-s-738 syntmp-m-720 syntmp-esew-721)) syntmp-tmp-743) (syntax-error syntmp-tmp-740))) (syntax-dispatch syntmp-tmp-740 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-740 (quote (any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738 (lambda (syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751) (syntmp-chi-top-sequence-133 syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751 syntmp-m-720 syntmp-esew-721))) (if (memv syntmp-t-739 (quote (eval-when-form))) ((lambda (syntmp-tmp-752) ((lambda (syntmp-tmp-753) (if syntmp-tmp-753 (apply (lambda (syntmp-_-754 syntmp-x-755 syntmp-e1-756 syntmp-e2-757) (let ((syntmp-when-list-758 (syntmp-chi-when-list-135 syntmp-e-736 syntmp-x-755 syntmp-w-737)) (syntmp-body-759 (cons syntmp-e1-756 syntmp-e2-757))) (cond ((eq? syntmp-m-720 (quote e)) (if (memq (quote eval) syntmp-when-list-758) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval))) (syntmp-chi-void-146))) ((memq (quote load) syntmp-when-list-758) (if (or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c&e) (quote (compile load))) (if (memq syntmp-m-720 (quote (c c&e))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c) (quote (load))) (syntmp-chi-void-146)))) ((or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval)))) (syntmp-chi-void-146)) (else (syntmp-chi-void-146))))) syntmp-tmp-753) (syntax-error syntmp-tmp-752))) (syntax-dispatch syntmp-tmp-752 (quote (any each-any any . each-any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (define-syntax-form))) (let ((syntmp-n-762 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737)) (syntmp-r-763 (syntmp-macros-only-env-98 syntmp-r-718))) (let ((syntmp-t-764 syntmp-m-720)) (if (memv syntmp-t-764 (quote (c))) (if (memq (quote compile) syntmp-esew-721) (let ((syntmp-e-765 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-765) (if (memq (quote load) syntmp-esew-721) syntmp-e-765 (syntmp-chi-void-146)))) (if (memq (quote load) syntmp-esew-721) (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)) (syntmp-chi-void-146))) (if (memv syntmp-t-764 (quote (c&e))) (let ((syntmp-e-766 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-766) syntmp-e-766)) (begin (if (memq (quote eval) syntmp-esew-721) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (syntmp-chi-void-146)))))) (if (memv syntmp-t-739 (quote (define-form))) (let ((syntmp-n-767 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737))) (let ((syntmp-type-768 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-767 syntmp-r-718)))) (let ((syntmp-t-769 syntmp-type-768)) (if (memv syntmp-t-769 (quote (global))) (let ((syntmp-x-770 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-770)) syntmp-x-770)) (if (memv syntmp-t-769 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "identifier out of context") (if (eq? syntmp-type-768 (quote external-macro)) (let ((syntmp-x-771 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-771)) syntmp-x-771)) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "cannot define keyword at top level"))))))) (let ((syntmp-x-772 (syntmp-chi-expr-139 syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)))))))))))) (syntmp-syntax-type-136 (lambda (syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-rib-777) (cond ((symbol? syntmp-e-773) (let ((syntmp-n-778 (syntmp-id-var-name-124 syntmp-e-773 syntmp-w-775))) (let ((syntmp-b-779 (syntmp-lookup-99 syntmp-n-778 syntmp-r-774))) (let ((syntmp-type-780 (syntmp-binding-type-94 syntmp-b-779))) (let ((syntmp-t-781 syntmp-type-780)) (if (memv syntmp-t-781 (quote (lexical))) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (global))) (values syntmp-type-780 syntmp-n-778 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776))))))))) ((pair? syntmp-e-773) (let ((syntmp-first-782 (car syntmp-e-773))) (if (syntmp-id?-102 syntmp-first-782) (let ((syntmp-n-783 (syntmp-id-var-name-124 syntmp-first-782 syntmp-w-775))) (let ((syntmp-b-784 (syntmp-lookup-99 syntmp-n-783 syntmp-r-774))) (let ((syntmp-type-785 (syntmp-binding-type-94 syntmp-b-784))) (let ((syntmp-t-786 syntmp-type-785)) (if (memv syntmp-t-786 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (global))) (values (quote global-call) syntmp-n-783 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (if (memv syntmp-t-786 (quote (core external-macro))) (values syntmp-type-785 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (begin))) (values (quote begin-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (define))) ((lambda (syntmp-tmp-787) ((lambda (syntmp-tmp-788) (if (if syntmp-tmp-788 (apply (lambda (syntmp-_-789 syntmp-name-790 syntmp-val-791) (syntmp-id?-102 syntmp-name-790)) syntmp-tmp-788) #f) (apply (lambda (syntmp-_-792 syntmp-name-793 syntmp-val-794) (values (quote define-form) syntmp-name-793 syntmp-val-794 syntmp-w-775 syntmp-s-776)) syntmp-tmp-788) ((lambda (syntmp-tmp-795) (if (if syntmp-tmp-795 (apply (lambda (syntmp-_-796 syntmp-name-797 syntmp-args-798 syntmp-e1-799 syntmp-e2-800) (and (syntmp-id?-102 syntmp-name-797) (syntmp-valid-bound-ids?-127 (syntmp-lambda-var-list-151 syntmp-args-798)))) syntmp-tmp-795) #f) (apply (lambda (syntmp-_-801 syntmp-name-802 syntmp-args-803 syntmp-e1-804 syntmp-e2-805) (values (quote define-form) (syntmp-wrap-130 syntmp-name-802 syntmp-w-775) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-130 (cons syntmp-args-803 (cons syntmp-e1-804 syntmp-e2-805)) syntmp-w-775)) (quote (())) syntmp-s-776)) syntmp-tmp-795) ((lambda (syntmp-tmp-807) (if (if syntmp-tmp-807 (apply (lambda (syntmp-_-808 syntmp-name-809) (syntmp-id?-102 syntmp-name-809)) syntmp-tmp-807) #f) (apply (lambda (syntmp-_-810 syntmp-name-811) (values (quote define-form) (syntmp-wrap-130 syntmp-name-811 syntmp-w-775) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-776)) syntmp-tmp-807) (syntax-error syntmp-tmp-787))) (syntax-dispatch syntmp-tmp-787 (quote (any any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any any any))))) syntmp-e-773) (if (memv syntmp-t-786 (quote (define-syntax))) ((lambda (syntmp-tmp-812) ((lambda (syntmp-tmp-813) (if (if syntmp-tmp-813 (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-val-816) (syntmp-id?-102 syntmp-name-815)) syntmp-tmp-813) #f) (apply (lambda (syntmp-_-817 syntmp-name-818 syntmp-val-819) (values (quote define-syntax-form) syntmp-name-818 syntmp-val-819 syntmp-w-775 syntmp-s-776)) syntmp-tmp-813) (syntax-error syntmp-tmp-812))) (syntax-dispatch syntmp-tmp-812 (quote (any any any))))) syntmp-e-773) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))))))))))))) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))) ((syntmp-syntax-object?-88 syntmp-e-773) (syntmp-syntax-type-136 (syntmp-syntax-object-expression-89 syntmp-e-773) syntmp-r-774 (syntmp-join-wraps-121 syntmp-w-775 (syntmp-syntax-object-wrap-90 syntmp-e-773)) #f syntmp-rib-777)) ((annotation? syntmp-e-773) (syntmp-syntax-type-136 (annotation-expression syntmp-e-773) syntmp-r-774 syntmp-w-775 (annotation-source syntmp-e-773) syntmp-rib-777)) ((self-evaluating? syntmp-e-773) (values (quote constant) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)) (else (values (quote other) #f syntmp-e-773 syntmp-w-775 syntmp-s-776))))) (syntmp-chi-when-list-135 (lambda (syntmp-e-820 syntmp-when-list-821 syntmp-w-822) (let syntmp-f-823 ((syntmp-when-list-824 syntmp-when-list-821) (syntmp-situations-825 (quote ()))) (if (null? syntmp-when-list-824) syntmp-situations-825 (syntmp-f-823 (cdr syntmp-when-list-824) (cons (let ((syntmp-x-826 (car syntmp-when-list-824))) (cond ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-130 syntmp-x-826 syntmp-w-822) "invalid eval-when situation")))) syntmp-situations-825)))))) (syntmp-chi-install-global-134 (lambda (syntmp-name-827 syntmp-e-828) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-827) syntmp-e-828)))) (syntmp-chi-top-sequence-133 (lambda (syntmp-body-829 syntmp-r-830 syntmp-w-831 syntmp-s-832 syntmp-m-833 syntmp-esew-834) (syntmp-build-sequence-83 syntmp-s-832 (let syntmp-dobody-835 ((syntmp-body-836 syntmp-body-829) (syntmp-r-837 syntmp-r-830) (syntmp-w-838 syntmp-w-831) (syntmp-m-839 syntmp-m-833) (syntmp-esew-840 syntmp-esew-834)) (if (null? syntmp-body-836) (quote ()) (let ((syntmp-first-841 (syntmp-chi-top-137 (car syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840))) (cons syntmp-first-841 (syntmp-dobody-835 (cdr syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840)))))))) (syntmp-chi-sequence-132 (lambda (syntmp-body-842 syntmp-r-843 syntmp-w-844 syntmp-s-845) (syntmp-build-sequence-83 syntmp-s-845 (let syntmp-dobody-846 ((syntmp-body-847 syntmp-body-842) (syntmp-r-848 syntmp-r-843) (syntmp-w-849 syntmp-w-844)) (if (null? syntmp-body-847) (quote ()) (let ((syntmp-first-850 (syntmp-chi-138 (car syntmp-body-847) syntmp-r-848 syntmp-w-849))) (cons syntmp-first-850 (syntmp-dobody-846 (cdr syntmp-body-847) syntmp-r-848 syntmp-w-849)))))))) (syntmp-source-wrap-131 (lambda (syntmp-x-851 syntmp-w-852 syntmp-s-853) (syntmp-wrap-130 (if syntmp-s-853 (make-annotation syntmp-x-851 syntmp-s-853 #f) syntmp-x-851) syntmp-w-852))) (syntmp-wrap-130 (lambda (syntmp-x-854 syntmp-w-855) (cond ((and (null? (syntmp-wrap-marks-105 syntmp-w-855)) (null? (syntmp-wrap-subst-106 syntmp-w-855))) syntmp-x-854) ((syntmp-syntax-object?-88 syntmp-x-854) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-854) (syntmp-join-wraps-121 syntmp-w-855 (syntmp-syntax-object-wrap-90 syntmp-x-854)))) ((null? syntmp-x-854) syntmp-x-854) (else (syntmp-make-syntax-object-87 syntmp-x-854 syntmp-w-855))))) (syntmp-bound-id-member?-129 (lambda (syntmp-x-856 syntmp-list-857) (and (not (null? syntmp-list-857)) (or (syntmp-bound-id=?-126 syntmp-x-856 (car syntmp-list-857)) (syntmp-bound-id-member?-129 syntmp-x-856 (cdr syntmp-list-857)))))) (syntmp-distinct-bound-ids?-128 (lambda (syntmp-ids-858) (let syntmp-distinct?-859 ((syntmp-ids-860 syntmp-ids-858)) (or (null? syntmp-ids-860) (and (not (syntmp-bound-id-member?-129 (car syntmp-ids-860) (cdr syntmp-ids-860))) (syntmp-distinct?-859 (cdr syntmp-ids-860))))))) (syntmp-valid-bound-ids?-127 (lambda (syntmp-ids-861) (and (let syntmp-all-ids?-862 ((syntmp-ids-863 syntmp-ids-861)) (or (null? syntmp-ids-863) (and (syntmp-id?-102 (car syntmp-ids-863)) (syntmp-all-ids?-862 (cdr syntmp-ids-863))))) (syntmp-distinct-bound-ids?-128 syntmp-ids-861)))) (syntmp-bound-id=?-126 (lambda (syntmp-i-864 syntmp-j-865) (if (and (syntmp-syntax-object?-88 syntmp-i-864) (syntmp-syntax-object?-88 syntmp-j-865)) (and (eq? (let ((syntmp-e-866 (syntmp-syntax-object-expression-89 syntmp-i-864))) (if (annotation? syntmp-e-866) (annotation-expression syntmp-e-866) syntmp-e-866)) (let ((syntmp-e-867 (syntmp-syntax-object-expression-89 syntmp-j-865))) (if (annotation? syntmp-e-867) (annotation-expression syntmp-e-867) syntmp-e-867))) (syntmp-same-marks?-123 (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-i-864)) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-j-865)))) (eq? (let ((syntmp-e-868 syntmp-i-864)) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 syntmp-j-865)) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869)))))) (syntmp-free-id=?-125 (lambda (syntmp-i-870 syntmp-j-871) (and (eq? (let ((syntmp-x-872 syntmp-i-870)) (let ((syntmp-e-873 (if (syntmp-syntax-object?-88 syntmp-x-872) (syntmp-syntax-object-expression-89 syntmp-x-872) syntmp-x-872))) (if (annotation? syntmp-e-873) (annotation-expression syntmp-e-873) syntmp-e-873))) (let ((syntmp-x-874 syntmp-j-871)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875)))) (eq? (syntmp-id-var-name-124 syntmp-i-870 (quote (()))) (syntmp-id-var-name-124 syntmp-j-871 (quote (()))))))) (syntmp-id-var-name-124 (lambda (syntmp-id-876 syntmp-w-877) (letrec ((syntmp-search-vector-rib-880 (lambda (syntmp-sym-891 syntmp-subst-892 syntmp-marks-893 syntmp-symnames-894 syntmp-ribcage-895) (let ((syntmp-n-896 (vector-length syntmp-symnames-894))) (let syntmp-f-897 ((syntmp-i-898 0)) (cond ((syntmp-fx=-74 syntmp-i-898 syntmp-n-896) (syntmp-search-878 syntmp-sym-891 (cdr syntmp-subst-892) syntmp-marks-893)) ((and (eq? (vector-ref syntmp-symnames-894 syntmp-i-898) syntmp-sym-891) (syntmp-same-marks?-123 syntmp-marks-893 (vector-ref (syntmp-ribcage-marks-112 syntmp-ribcage-895) syntmp-i-898))) (values (vector-ref (syntmp-ribcage-labels-113 syntmp-ribcage-895) syntmp-i-898) syntmp-marks-893)) (else (syntmp-f-897 (syntmp-fx+-72 syntmp-i-898 1)))))))) (syntmp-search-list-rib-879 (lambda (syntmp-sym-899 syntmp-subst-900 syntmp-marks-901 syntmp-symnames-902 syntmp-ribcage-903) (let syntmp-f-904 ((syntmp-symnames-905 syntmp-symnames-902) (syntmp-i-906 0)) (cond ((null? syntmp-symnames-905) (syntmp-search-878 syntmp-sym-899 (cdr syntmp-subst-900) syntmp-marks-901)) ((and (eq? (car syntmp-symnames-905) syntmp-sym-899) (syntmp-same-marks?-123 syntmp-marks-901 (list-ref (syntmp-ribcage-marks-112 syntmp-ribcage-903) syntmp-i-906))) (values (list-ref (syntmp-ribcage-labels-113 syntmp-ribcage-903) syntmp-i-906) syntmp-marks-901)) (else (syntmp-f-904 (cdr syntmp-symnames-905) (syntmp-fx+-72 syntmp-i-906 1))))))) (syntmp-search-878 (lambda (syntmp-sym-907 syntmp-subst-908 syntmp-marks-909) (if (null? syntmp-subst-908) (values #f syntmp-marks-909) (let ((syntmp-fst-910 (car syntmp-subst-908))) (if (eq? syntmp-fst-910 (quote shift)) (syntmp-search-878 syntmp-sym-907 (cdr syntmp-subst-908) (cdr syntmp-marks-909)) (let ((syntmp-symnames-911 (syntmp-ribcage-symnames-111 syntmp-fst-910))) (if (vector? syntmp-symnames-911) (syntmp-search-vector-rib-880 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910) (syntmp-search-list-rib-879 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910))))))))) (cond ((symbol? syntmp-id-876) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-876 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-913 . syntmp-ignore-912) syntmp-x-913)) syntmp-id-876)) ((syntmp-syntax-object?-88 syntmp-id-876) (let ((syntmp-id-914 (let ((syntmp-e-916 (syntmp-syntax-object-expression-89 syntmp-id-876))) (if (annotation? syntmp-e-916) (annotation-expression syntmp-e-916) syntmp-e-916))) (syntmp-w1-915 (syntmp-syntax-object-wrap-90 syntmp-id-876))) (let ((syntmp-marks-917 (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w1-915)))) (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w-877) syntmp-marks-917)) (lambda (syntmp-new-id-918 syntmp-marks-919) (or syntmp-new-id-918 (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w1-915) syntmp-marks-919)) (lambda (syntmp-x-921 . syntmp-ignore-920) syntmp-x-921)) syntmp-id-914)))))) ((annotation? syntmp-id-876) (let ((syntmp-id-922 (let ((syntmp-e-923 syntmp-id-876)) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)))) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-922 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-925 . syntmp-ignore-924) syntmp-x-925)) syntmp-id-922))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-876)))))) (syntmp-same-marks?-123 (lambda (syntmp-x-926 syntmp-y-927) (or (eq? syntmp-x-926 syntmp-y-927) (and (not (null? syntmp-x-926)) (not (null? syntmp-y-927)) (eq? (car syntmp-x-926) (car syntmp-y-927)) (syntmp-same-marks?-123 (cdr syntmp-x-926) (cdr syntmp-y-927)))))) (syntmp-join-marks-122 (lambda (syntmp-m1-928 syntmp-m2-929) (syntmp-smart-append-120 syntmp-m1-928 syntmp-m2-929))) (syntmp-join-wraps-121 (lambda (syntmp-w1-930 syntmp-w2-931) (let ((syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w1-930)) (syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w1-930))) (if (null? syntmp-m1-932) (if (null? syntmp-s1-933) syntmp-w2-931 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w2-931) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931)))) (syntmp-make-wrap-104 (syntmp-smart-append-120 syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w2-931)) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931))))))) (syntmp-smart-append-120 (lambda (syntmp-m1-934 syntmp-m2-935) (if (null? syntmp-m2-935) syntmp-m1-934 (append syntmp-m1-934 syntmp-m2-935)))) (syntmp-make-binding-wrap-119 (lambda (syntmp-ids-936 syntmp-labels-937 syntmp-w-938) (if (null? syntmp-ids-936) syntmp-w-938 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-938) (cons (let ((syntmp-labelvec-939 (list->vector syntmp-labels-937))) (let ((syntmp-n-940 (vector-length syntmp-labelvec-939))) (let ((syntmp-symnamevec-941 (make-vector syntmp-n-940)) (syntmp-marksvec-942 (make-vector syntmp-n-940))) (begin (let syntmp-f-943 ((syntmp-ids-944 syntmp-ids-936) (syntmp-i-945 0)) (if (not (null? syntmp-ids-944)) (call-with-values (lambda () (syntmp-id-sym-name&marks-103 (car syntmp-ids-944) syntmp-w-938)) (lambda (syntmp-symname-946 syntmp-marks-947) (begin (vector-set! syntmp-symnamevec-941 syntmp-i-945 syntmp-symname-946) (vector-set! syntmp-marksvec-942 syntmp-i-945 syntmp-marks-947) (syntmp-f-943 (cdr syntmp-ids-944) (syntmp-fx+-72 syntmp-i-945 1))))))) (syntmp-make-ribcage-109 syntmp-symnamevec-941 syntmp-marksvec-942 syntmp-labelvec-939))))) (syntmp-wrap-subst-106 syntmp-w-938)))))) (syntmp-extend-ribcage!-118 (lambda (syntmp-ribcage-948 syntmp-id-949 syntmp-label-950) (begin (syntmp-set-ribcage-symnames!-114 syntmp-ribcage-948 (cons (let ((syntmp-e-951 (syntmp-syntax-object-expression-89 syntmp-id-949))) (if (annotation? syntmp-e-951) (annotation-expression syntmp-e-951) syntmp-e-951)) (syntmp-ribcage-symnames-111 syntmp-ribcage-948))) (syntmp-set-ribcage-marks!-115 syntmp-ribcage-948 (cons (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-id-949)) (syntmp-ribcage-marks-112 syntmp-ribcage-948))) (syntmp-set-ribcage-labels!-116 syntmp-ribcage-948 (cons syntmp-label-950 (syntmp-ribcage-labels-113 syntmp-ribcage-948)))))) (syntmp-anti-mark-117 (lambda (syntmp-w-952) (syntmp-make-wrap-104 (cons #f (syntmp-wrap-marks-105 syntmp-w-952)) (cons (quote shift) (syntmp-wrap-subst-106 syntmp-w-952))))) (syntmp-set-ribcage-labels!-116 (lambda (syntmp-x-953 syntmp-update-954) (vector-set! syntmp-x-953 3 syntmp-update-954))) (syntmp-set-ribcage-marks!-115 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 2 syntmp-update-956))) (syntmp-set-ribcage-symnames!-114 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 1 syntmp-update-958))) (syntmp-ribcage-labels-113 (lambda (syntmp-x-959) (vector-ref syntmp-x-959 3))) (syntmp-ribcage-marks-112 (lambda (syntmp-x-960) (vector-ref syntmp-x-960 2))) (syntmp-ribcage-symnames-111 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 1))) (syntmp-ribcage?-110 (lambda (syntmp-x-962) (and (vector? syntmp-x-962) (= (vector-length syntmp-x-962) 4) (eq? (vector-ref syntmp-x-962 0) (quote ribcage))))) (syntmp-make-ribcage-109 (lambda (syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965) (vector (quote ribcage) syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965))) (syntmp-gen-labels-108 (lambda (syntmp-ls-966) (if (null? syntmp-ls-966) (quote ()) (cons (syntmp-gen-label-107) (syntmp-gen-labels-108 (cdr syntmp-ls-966)))))) (syntmp-gen-label-107 (lambda () (string #\i))) (syntmp-wrap-subst-106 cdr) (syntmp-wrap-marks-105 car) (syntmp-make-wrap-104 cons) (syntmp-id-sym-name&marks-103 (lambda (syntmp-x-967 syntmp-w-968) (if (syntmp-syntax-object?-88 syntmp-x-967) (values (let ((syntmp-e-969 (syntmp-syntax-object-expression-89 syntmp-x-967))) (if (annotation? syntmp-e-969) (annotation-expression syntmp-e-969) syntmp-e-969)) (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-968) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-x-967)))) (values (let ((syntmp-e-970 syntmp-x-967)) (if (annotation? syntmp-e-970) (annotation-expression syntmp-e-970) syntmp-e-970)) (syntmp-wrap-marks-105 syntmp-w-968))))) (syntmp-id?-102 (lambda (syntmp-x-971) (cond ((symbol? syntmp-x-971) #t) ((syntmp-syntax-object?-88 syntmp-x-971) (symbol? (let ((syntmp-e-972 (syntmp-syntax-object-expression-89 syntmp-x-971))) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)))) ((annotation? syntmp-x-971) (symbol? (annotation-expression syntmp-x-971))) (else #f)))) (syntmp-nonsymbol-id?-101 (lambda (syntmp-x-973) (and (syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))))) (syntmp-global-extend-100 (lambda (syntmp-type-975 syntmp-sym-976 syntmp-val-977) (syntmp-put-global-definition-hook-79 syntmp-sym-976 (cons syntmp-type-975 syntmp-val-977)))) (syntmp-lookup-99 (lambda (syntmp-x-978 syntmp-r-979) (cond ((assq syntmp-x-978 syntmp-r-979) => cdr) ((symbol? syntmp-x-978) (or (syntmp-get-global-definition-hook-80 syntmp-x-978) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-98 (lambda (syntmp-r-980) (if (null? syntmp-r-980) (quote ()) (let ((syntmp-a-981 (car syntmp-r-980))) (if (eq? (cadr syntmp-a-981) (quote macro)) (cons syntmp-a-981 (syntmp-macros-only-env-98 (cdr syntmp-r-980))) (syntmp-macros-only-env-98 (cdr syntmp-r-980))))))) (syntmp-extend-var-env-97 (lambda (syntmp-labels-982 syntmp-vars-983 syntmp-r-984) (if (null? syntmp-labels-982) syntmp-r-984 (syntmp-extend-var-env-97 (cdr syntmp-labels-982) (cdr syntmp-vars-983) (cons (cons (car syntmp-labels-982) (cons (quote lexical) (car syntmp-vars-983))) syntmp-r-984))))) (syntmp-extend-env-96 (lambda (syntmp-labels-985 syntmp-bindings-986 syntmp-r-987) (if (null? syntmp-labels-985) syntmp-r-987 (syntmp-extend-env-96 (cdr syntmp-labels-985) (cdr syntmp-bindings-986) (cons (cons (car syntmp-labels-985) (car syntmp-bindings-986)) syntmp-r-987))))) (syntmp-binding-value-95 cdr) (syntmp-binding-type-94 car) (syntmp-source-annotation-93 (lambda (syntmp-x-988) (cond ((annotation? syntmp-x-988) (annotation-source syntmp-x-988)) ((syntmp-syntax-object?-88 syntmp-x-988) (syntmp-source-annotation-93 (syntmp-syntax-object-expression-89 syntmp-x-988))) (else #f)))) (syntmp-set-syntax-object-wrap!-92 (lambda (syntmp-x-989 syntmp-update-990) (vector-set! syntmp-x-989 2 syntmp-update-990))) (syntmp-set-syntax-object-expression!-91 (lambda (syntmp-x-991 syntmp-update-992) (vector-set! syntmp-x-991 1 syntmp-update-992))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 3) (eq? (vector-ref syntmp-x-995 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-996 syntmp-wrap-997) (vector (quote syntax-object) syntmp-expression-996 syntmp-wrap-997))) (syntmp-build-letrec-86 (lambda (syntmp-src-998 syntmp-vars-999 syntmp-val-exps-1000 syntmp-body-exp-1001) (if (null? syntmp-vars-999) (syntmp-build-annotated-81 syntmp-src-998 syntmp-body-exp-1001) (syntmp-build-annotated-81 syntmp-src-998 (list (quote letrec) (map list syntmp-vars-999 syntmp-val-exps-1000) syntmp-body-exp-1001))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1002 syntmp-vars-1003 syntmp-val-exps-1004 syntmp-body-exp-1005) (if (null? syntmp-vars-1003) (syntmp-build-annotated-81 syntmp-src-1002 syntmp-body-exp-1005) (syntmp-build-annotated-81 syntmp-src-1002 (list (quote let) (car syntmp-vars-1003) (map list (cdr syntmp-vars-1003) syntmp-val-exps-1004) syntmp-body-exp-1005))))) (syntmp-build-let-84 (lambda (syntmp-src-1006 syntmp-vars-1007 syntmp-val-exps-1008 syntmp-body-exp-1009) (if (null? syntmp-vars-1007) (syntmp-build-annotated-81 syntmp-src-1006 syntmp-body-exp-1009) (syntmp-build-annotated-81 syntmp-src-1006 (list (quote let) (map list syntmp-vars-1007 syntmp-val-exps-1008) syntmp-body-exp-1009))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1010 syntmp-exps-1011) (if (null? (cdr syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (car syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (cons (quote begin) syntmp-exps-1011))))) (syntmp-build-data-82 (lambda (syntmp-src-1012 syntmp-exp-1013) (if (and (self-evaluating? syntmp-exp-1013) (not (vector? syntmp-exp-1013))) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-exp-1013) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote quote) syntmp-exp-1013))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1014 syntmp-exp-1015) (if (and syntmp-src-1014 (not (annotation? syntmp-exp-1015))) (make-annotation syntmp-exp-1015 syntmp-src-1014 #t) syntmp-exp-1015))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1016) (getprop syntmp-symbol-1016 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1017 syntmp-binding-1018) (putprop syntmp-symbol-1017 (quote *sc-expander*) syntmp-binding-1018))) (syntmp-error-hook-78 (lambda (syntmp-who-1019 syntmp-why-1020 syntmp-what-1021) (error syntmp-who-1019 "~a ~s" syntmp-why-1020 syntmp-what-1021))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1022) (eval (list syntmp-noexpand-71 syntmp-x-1022) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1023) (eval (list syntmp-noexpand-71 syntmp-x-1023) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-100 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-100 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-100 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1024 syntmp-r-1025 syntmp-w-1026 syntmp-s-1027) ((lambda (syntmp-tmp-1028) ((lambda (syntmp-tmp-1029) (if (if syntmp-tmp-1029 (apply (lambda (syntmp-_-1030 syntmp-var-1031 syntmp-val-1032 syntmp-e1-1033 syntmp-e2-1034) (syntmp-valid-bound-ids?-127 syntmp-var-1031)) syntmp-tmp-1029) #f) (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (let ((syntmp-names-1041 (map (lambda (syntmp-x-1042) (syntmp-id-var-name-124 syntmp-x-1042 syntmp-w-1026)) syntmp-var-1037))) (begin (for-each (lambda (syntmp-id-1044 syntmp-n-1045) (let ((syntmp-t-1046 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-1045 syntmp-r-1025)))) (if (memv syntmp-t-1046 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-id-1044 syntmp-w-1026 syntmp-s-1027) "identifier out of context")))) syntmp-var-1037 syntmp-names-1041) (syntmp-chi-body-142 (cons syntmp-e1-1039 syntmp-e2-1040) (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027) (syntmp-extend-env-96 syntmp-names-1041 (let ((syntmp-trans-r-1049 (syntmp-macros-only-env-98 syntmp-r-1025))) (map (lambda (syntmp-x-1050) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-1050 syntmp-trans-r-1049 syntmp-w-1026)))) syntmp-val-1038)) syntmp-r-1025) syntmp-w-1026)))) syntmp-tmp-1029) ((lambda (syntmp-_-1052) (syntax-error (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027))) syntmp-tmp-1028))) (syntax-dispatch syntmp-tmp-1028 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1024))) (syntmp-global-extend-100 (quote core) (quote quote) (lambda (syntmp-e-1053 syntmp-r-1054 syntmp-w-1055 syntmp-s-1056) ((lambda (syntmp-tmp-1057) ((lambda (syntmp-tmp-1058) (if syntmp-tmp-1058 (apply (lambda (syntmp-_-1059 syntmp-e-1060) (syntmp-build-data-82 syntmp-s-1056 (syntmp-strip-149 syntmp-e-1060 syntmp-w-1055))) syntmp-tmp-1058) ((lambda (syntmp-_-1061) (syntax-error (syntmp-source-wrap-131 syntmp-e-1053 syntmp-w-1055 syntmp-s-1056))) syntmp-tmp-1057))) (syntax-dispatch syntmp-tmp-1057 (quote (any any))))) syntmp-e-1053))) (syntmp-global-extend-100 (quote core) (quote syntax) (letrec ((syntmp-regen-1069 (lambda (syntmp-x-1070) (let ((syntmp-t-1071 (car syntmp-x-1070))) (if (memv syntmp-t-1071 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1070) (syntmp-regen-1069 (caddr syntmp-x-1070)))) (if (memv syntmp-t-1071 (quote (map))) (let ((syntmp-ls-1072 (map syntmp-regen-1069 (cdr syntmp-x-1070)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1072) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1072))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1070)) (map syntmp-regen-1069 (cdr syntmp-x-1070)))))))))))) (syntmp-gen-vector-1068 (lambda (syntmp-x-1073) (cond ((eq? (car syntmp-x-1073) (quote list)) (cons (quote vector) (cdr syntmp-x-1073))) ((eq? (car syntmp-x-1073) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1073)))) (else (list (quote list->vector) syntmp-x-1073))))) (syntmp-gen-append-1067 (lambda (syntmp-x-1074 syntmp-y-1075) (if (equal? syntmp-y-1075 (quote (quote ()))) syntmp-x-1074 (list (quote append) syntmp-x-1074 syntmp-y-1075)))) (syntmp-gen-cons-1066 (lambda (syntmp-x-1076 syntmp-y-1077) (let ((syntmp-t-1078 (car syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (quote))) (if (eq? (car syntmp-x-1076) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1076) (cadr syntmp-y-1077))) (if (eq? (cadr syntmp-y-1077) (quote ())) (list (quote list) syntmp-x-1076) (list (quote cons) syntmp-x-1076 syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (list))) (cons (quote list) (cons syntmp-x-1076 (cdr syntmp-y-1077))) (list (quote cons) syntmp-x-1076 syntmp-y-1077)))))) (syntmp-gen-map-1065 (lambda (syntmp-e-1079 syntmp-map-env-1080) (let ((syntmp-formals-1081 (map cdr syntmp-map-env-1080)) (syntmp-actuals-1082 (map (lambda (syntmp-x-1083) (list (quote ref) (car syntmp-x-1083))) syntmp-map-env-1080))) (cond ((eq? (car syntmp-e-1079) (quote ref)) (car syntmp-actuals-1082)) ((andmap (lambda (syntmp-x-1084) (and (eq? (car syntmp-x-1084) (quote ref)) (memq (cadr syntmp-x-1084) syntmp-formals-1081))) (cdr syntmp-e-1079)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1079)) (map (let ((syntmp-r-1085 (map cons syntmp-formals-1081 syntmp-actuals-1082))) (lambda (syntmp-x-1086) (cdr (assq (cadr syntmp-x-1086) syntmp-r-1085)))) (cdr syntmp-e-1079))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1081 syntmp-e-1079) syntmp-actuals-1082))))))) (syntmp-gen-mappend-1064 (lambda (syntmp-e-1087 syntmp-map-env-1088) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1065 syntmp-e-1087 syntmp-map-env-1088)))) (syntmp-gen-ref-1063 (lambda (syntmp-src-1089 syntmp-var-1090 syntmp-level-1091 syntmp-maps-1092) (if (syntmp-fx=-74 syntmp-level-1091 0) (values syntmp-var-1090 syntmp-maps-1092) (if (null? syntmp-maps-1092) (syntax-error syntmp-src-1089 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1063 syntmp-src-1089 syntmp-var-1090 (syntmp-fx--73 syntmp-level-1091 1) (cdr syntmp-maps-1092))) (lambda (syntmp-outer-var-1093 syntmp-outer-maps-1094) (let ((syntmp-b-1095 (assq syntmp-outer-var-1093 (car syntmp-maps-1092)))) (if syntmp-b-1095 (values (cdr syntmp-b-1095) syntmp-maps-1092) (let ((syntmp-inner-var-1096 (syntmp-gen-var-150 (quote tmp)))) (values syntmp-inner-var-1096 (cons (cons (cons syntmp-outer-var-1093 syntmp-inner-var-1096) (car syntmp-maps-1092)) syntmp-outer-maps-1094))))))))))) (syntmp-gen-syntax-1062 (lambda (syntmp-src-1097 syntmp-e-1098 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101) (if (syntmp-id?-102 syntmp-e-1098) (let ((syntmp-label-1102 (syntmp-id-var-name-124 syntmp-e-1098 (quote (()))))) (let ((syntmp-b-1103 (syntmp-lookup-99 syntmp-label-1102 syntmp-r-1099))) (if (eq? (syntmp-binding-type-94 syntmp-b-1103) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1104 (syntmp-binding-value-95 syntmp-b-1103))) (syntmp-gen-ref-1063 syntmp-src-1097 (car syntmp-var.lev-1104) (cdr syntmp-var.lev-1104) syntmp-maps-1100))) (lambda (syntmp-var-1105 syntmp-maps-1106) (values (list (quote ref) syntmp-var-1105) syntmp-maps-1106))) (if (syntmp-ellipsis?-1101 syntmp-e-1098) (syntax-error syntmp-src-1097 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100))))) ((lambda (syntmp-tmp-1107) ((lambda (syntmp-tmp-1108) (if (if syntmp-tmp-1108 (apply (lambda (syntmp-dots-1109 syntmp-e-1110) (syntmp-ellipsis?-1101 syntmp-dots-1109)) syntmp-tmp-1108) #f) (apply (lambda (syntmp-dots-1111 syntmp-e-1112) (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-e-1112 syntmp-r-1099 syntmp-maps-1100 (lambda (syntmp-x-1113) #f))) syntmp-tmp-1108) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-x-1115 syntmp-dots-1116 syntmp-y-1117) (syntmp-ellipsis?-1101 syntmp-dots-1116)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-x-1118 syntmp-dots-1119 syntmp-y-1120) (let syntmp-f-1121 ((syntmp-y-1122 syntmp-y-1120) (syntmp-k-1123 (lambda (syntmp-maps-1124) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1118 syntmp-r-1099 (cons (quote ()) syntmp-maps-1124) syntmp-ellipsis?-1101)) (lambda (syntmp-x-1125 syntmp-maps-1126) (if (null? (car syntmp-maps-1126)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-map-1065 syntmp-x-1125 (car syntmp-maps-1126)) (cdr syntmp-maps-1126)))))))) ((lambda (syntmp-tmp-1127) ((lambda (syntmp-tmp-1128) (if (if syntmp-tmp-1128 (apply (lambda (syntmp-dots-1129 syntmp-y-1130) (syntmp-ellipsis?-1101 syntmp-dots-1129)) syntmp-tmp-1128) #f) (apply (lambda (syntmp-dots-1131 syntmp-y-1132) (syntmp-f-1121 syntmp-y-1132 (lambda (syntmp-maps-1133) (call-with-values (lambda () (syntmp-k-1123 (cons (quote ()) syntmp-maps-1133))) (lambda (syntmp-x-1134 syntmp-maps-1135) (if (null? (car syntmp-maps-1135)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1064 syntmp-x-1134 (car syntmp-maps-1135)) (cdr syntmp-maps-1135)))))))) syntmp-tmp-1128) ((lambda (syntmp-_-1136) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1122 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1137 syntmp-maps-1138) (call-with-values (lambda () (syntmp-k-1123 syntmp-maps-1138)) (lambda (syntmp-x-1139 syntmp-maps-1140) (values (syntmp-gen-append-1067 syntmp-x-1139 syntmp-y-1137) syntmp-maps-1140)))))) syntmp-tmp-1127))) (syntax-dispatch syntmp-tmp-1127 (quote (any . any))))) syntmp-y-1122))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1141) (if syntmp-tmp-1141 (apply (lambda (syntmp-x-1142 syntmp-y-1143) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1142 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-x-1144 syntmp-maps-1145) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1143 syntmp-r-1099 syntmp-maps-1145 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1146 syntmp-maps-1147) (values (syntmp-gen-cons-1066 syntmp-x-1144 syntmp-y-1146) syntmp-maps-1147)))))) syntmp-tmp-1141) ((lambda (syntmp-tmp-1148) (if syntmp-tmp-1148 (apply (lambda (syntmp-e1-1149 syntmp-e2-1150) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 (cons syntmp-e1-1149 syntmp-e2-1150) syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-e-1152 syntmp-maps-1153) (values (syntmp-gen-vector-1068 syntmp-e-1152) syntmp-maps-1153)))) syntmp-tmp-1148) ((lambda (syntmp-_-1154) (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100)) syntmp-tmp-1107))) (syntax-dispatch syntmp-tmp-1107 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1107 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any))))) syntmp-e-1098))))) (lambda (syntmp-e-1155 syntmp-r-1156 syntmp-w-1157 syntmp-s-1158) (let ((syntmp-e-1159 (syntmp-source-wrap-131 syntmp-e-1155 syntmp-w-1157 syntmp-s-1158))) ((lambda (syntmp-tmp-1160) ((lambda (syntmp-tmp-1161) (if syntmp-tmp-1161 (apply (lambda (syntmp-_-1162 syntmp-x-1163) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-e-1159 syntmp-x-1163 syntmp-r-1156 (quote ()) syntmp-ellipsis?-147)) (lambda (syntmp-e-1164 syntmp-maps-1165) (syntmp-regen-1069 syntmp-e-1164)))) syntmp-tmp-1161) ((lambda (syntmp-_-1166) (syntax-error syntmp-e-1159)) syntmp-tmp-1160))) (syntax-dispatch syntmp-tmp-1160 (quote (any any))))) syntmp-e-1159))))) (syntmp-global-extend-100 (quote core) (quote lambda) (lambda (syntmp-e-1167 syntmp-r-1168 syntmp-w-1169 syntmp-s-1170) ((lambda (syntmp-tmp-1171) ((lambda (syntmp-tmp-1172) (if syntmp-tmp-1172 (apply (lambda (syntmp-_-1173 syntmp-c-1174) (syntmp-chi-lambda-clause-143 (syntmp-source-wrap-131 syntmp-e-1167 syntmp-w-1169 syntmp-s-1170) syntmp-c-1174 syntmp-r-1168 syntmp-w-1169 (lambda (syntmp-vars-1175 syntmp-body-1176) (syntmp-build-annotated-81 syntmp-s-1170 (list (quote lambda) syntmp-vars-1175 syntmp-body-1176))))) syntmp-tmp-1172) (syntax-error syntmp-tmp-1171))) (syntax-dispatch syntmp-tmp-1171 (quote (any . any))))) syntmp-e-1167))) (syntmp-global-extend-100 (quote core) (quote let) (letrec ((syntmp-chi-let-1177 (lambda (syntmp-e-1178 syntmp-r-1179 syntmp-w-1180 syntmp-s-1181 syntmp-constructor-1182 syntmp-ids-1183 syntmp-vals-1184 syntmp-exps-1185) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1183)) (syntax-error syntmp-e-1178 "duplicate bound variable in") (let ((syntmp-labels-1186 (syntmp-gen-labels-108 syntmp-ids-1183)) (syntmp-new-vars-1187 (map syntmp-gen-var-150 syntmp-ids-1183))) (let ((syntmp-nw-1188 (syntmp-make-binding-wrap-119 syntmp-ids-1183 syntmp-labels-1186 syntmp-w-1180)) (syntmp-nr-1189 (syntmp-extend-var-env-97 syntmp-labels-1186 syntmp-new-vars-1187 syntmp-r-1179))) (syntmp-constructor-1182 syntmp-s-1181 syntmp-new-vars-1187 (map (lambda (syntmp-x-1190) (syntmp-chi-138 syntmp-x-1190 syntmp-r-1179 syntmp-w-1180)) syntmp-vals-1184) (syntmp-chi-body-142 syntmp-exps-1185 (syntmp-source-wrap-131 syntmp-e-1178 syntmp-nw-1188 syntmp-s-1181) syntmp-nr-1189 syntmp-nw-1188)))))))) (lambda (syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194) ((lambda (syntmp-tmp-1195) ((lambda (syntmp-tmp-1196) (if syntmp-tmp-1196 (apply (lambda (syntmp-_-1197 syntmp-id-1198 syntmp-val-1199 syntmp-e1-1200 syntmp-e2-1201) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-let-84 syntmp-id-1198 syntmp-val-1199 (cons syntmp-e1-1200 syntmp-e2-1201))) syntmp-tmp-1196) ((lambda (syntmp-tmp-1205) (if (if syntmp-tmp-1205 (apply (lambda (syntmp-_-1206 syntmp-f-1207 syntmp-id-1208 syntmp-val-1209 syntmp-e1-1210 syntmp-e2-1211) (syntmp-id?-102 syntmp-f-1207)) syntmp-tmp-1205) #f) (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-named-let-85 (cons syntmp-f-1213 syntmp-id-1214) syntmp-val-1215 (cons syntmp-e1-1216 syntmp-e2-1217))) syntmp-tmp-1205) ((lambda (syntmp-_-1221) (syntax-error (syntmp-source-wrap-131 syntmp-e-1191 syntmp-w-1193 syntmp-s-1194))) syntmp-tmp-1195))) (syntax-dispatch syntmp-tmp-1195 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1195 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1191)))) (syntmp-global-extend-100 (quote core) (quote letrec) (lambda (syntmp-e-1222 syntmp-r-1223 syntmp-w-1224 syntmp-s-1225) ((lambda (syntmp-tmp-1226) ((lambda (syntmp-tmp-1227) (if syntmp-tmp-1227 (apply (lambda (syntmp-_-1228 syntmp-id-1229 syntmp-val-1230 syntmp-e1-1231 syntmp-e2-1232) (let ((syntmp-ids-1233 syntmp-id-1229)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1233)) (syntax-error syntmp-e-1222 "duplicate bound variable in") (let ((syntmp-labels-1235 (syntmp-gen-labels-108 syntmp-ids-1233)) (syntmp-new-vars-1236 (map syntmp-gen-var-150 syntmp-ids-1233))) (let ((syntmp-w-1237 (syntmp-make-binding-wrap-119 syntmp-ids-1233 syntmp-labels-1235 syntmp-w-1224)) (syntmp-r-1238 (syntmp-extend-var-env-97 syntmp-labels-1235 syntmp-new-vars-1236 syntmp-r-1223))) (syntmp-build-letrec-86 syntmp-s-1225 syntmp-new-vars-1236 (map (lambda (syntmp-x-1239) (syntmp-chi-138 syntmp-x-1239 syntmp-r-1238 syntmp-w-1237)) syntmp-val-1230) (syntmp-chi-body-142 (cons syntmp-e1-1231 syntmp-e2-1232) (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1237 syntmp-s-1225) syntmp-r-1238 syntmp-w-1237))))))) syntmp-tmp-1227) ((lambda (syntmp-_-1242) (syntax-error (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1224 syntmp-s-1225))) syntmp-tmp-1226))) (syntax-dispatch syntmp-tmp-1226 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1222))) (syntmp-global-extend-100 (quote core) (quote set!) (lambda (syntmp-e-1243 syntmp-r-1244 syntmp-w-1245 syntmp-s-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-id-1250 syntmp-val-1251) (syntmp-id?-102 syntmp-id-1250)) syntmp-tmp-1248) #f) (apply (lambda (syntmp-_-1252 syntmp-id-1253 syntmp-val-1254) (let ((syntmp-val-1255 (syntmp-chi-138 syntmp-val-1254 syntmp-r-1244 syntmp-w-1245)) (syntmp-n-1256 (syntmp-id-var-name-124 syntmp-id-1253 syntmp-w-1245))) (let ((syntmp-b-1257 (syntmp-lookup-99 syntmp-n-1256 syntmp-r-1244))) (let ((syntmp-t-1258 (syntmp-binding-type-94 syntmp-b-1257))) (if (memv syntmp-t-1258 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) (syntmp-binding-value-95 syntmp-b-1257) syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) syntmp-n-1256 syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-id-1253 syntmp-w-1245) "identifier out of context") (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))))))))) syntmp-tmp-1248) ((lambda (syntmp-tmp-1259) (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-getter-1261 syntmp-arg-1262 syntmp-val-1263) (syntmp-build-annotated-81 syntmp-s-1246 (cons (syntmp-chi-138 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1261) syntmp-r-1244 syntmp-w-1245) (map (lambda (syntmp-e-1264) (syntmp-chi-138 syntmp-e-1264 syntmp-r-1244 syntmp-w-1245)) (append syntmp-arg-1262 (list syntmp-val-1263)))))) syntmp-tmp-1259) ((lambda (syntmp-_-1266) (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))) syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1247 (quote (any any any))))) syntmp-e-1243))) (syntmp-global-extend-100 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-100 (quote define) (quote define) (quote ())) (syntmp-global-extend-100 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-100 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-100 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1270 (lambda (syntmp-x-1271 syntmp-keys-1272 syntmp-clauses-1273 syntmp-r-1274) (if (null? syntmp-clauses-1273) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1271)) ((lambda (syntmp-tmp-1275) ((lambda (syntmp-tmp-1276) (if syntmp-tmp-1276 (apply (lambda (syntmp-pat-1277 syntmp-exp-1278) (if (and (syntmp-id?-102 syntmp-pat-1277) (andmap (lambda (syntmp-x-1279) (not (syntmp-free-id=?-125 syntmp-pat-1277 syntmp-x-1279))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1272))) (let ((syntmp-labels-1280 (list (syntmp-gen-label-107))) (syntmp-var-1281 (syntmp-gen-var-150 syntmp-pat-1277))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1281) (syntmp-chi-138 syntmp-exp-1278 (syntmp-extend-env-96 syntmp-labels-1280 (list (cons (quote syntax) (cons syntmp-var-1281 0))) syntmp-r-1274) (syntmp-make-binding-wrap-119 (list syntmp-pat-1277) syntmp-labels-1280 (quote (())))))) syntmp-x-1271))) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1277 #t syntmp-exp-1278))) syntmp-tmp-1276) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285)) syntmp-tmp-1282) ((lambda (syntmp-_-1286) (syntax-error (car syntmp-clauses-1273) "invalid syntax-case clause")) syntmp-tmp-1275))) (syntax-dispatch syntmp-tmp-1275 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1275 (quote (any any))))) (car syntmp-clauses-1273))))) (syntmp-gen-clause-1269 (lambda (syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290 syntmp-pat-1291 syntmp-fender-1292 syntmp-exp-1293) (call-with-values (lambda () (syntmp-convert-pattern-1267 syntmp-pat-1291 syntmp-keys-1288)) (lambda (syntmp-p-1294 syntmp-pvars-1295) (cond ((not (syntmp-distinct-bound-ids?-128 (map car syntmp-pvars-1295))) (syntax-error syntmp-pat-1291 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1296) (not (syntmp-ellipsis?-147 (car syntmp-x-1296)))) syntmp-pvars-1295)) (syntax-error syntmp-pat-1291 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1297 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1297) (let ((syntmp-y-1298 (syntmp-build-annotated-81 #f syntmp-y-1297))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1299) ((lambda (syntmp-tmp-1300) (if syntmp-tmp-1300 (apply (lambda () syntmp-y-1298) syntmp-tmp-1300) ((lambda (syntmp-_-1301) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1298 (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-fender-1292 syntmp-y-1298 syntmp-r-1290) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1299))) (syntax-dispatch syntmp-tmp-1299 (quote #(atom #t))))) syntmp-fender-1292) (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-exp-1293 syntmp-y-1298 syntmp-r-1290) (syntmp-gen-syntax-case-1270 syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290)))))) (if (eq? syntmp-p-1294 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1287)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1287 (syntmp-build-data-82 #f syntmp-p-1294))))))))))))) (syntmp-build-dispatch-call-1268 (lambda (syntmp-pvars-1302 syntmp-exp-1303 syntmp-y-1304 syntmp-r-1305) (let ((syntmp-ids-1306 (map car syntmp-pvars-1302)) (syntmp-levels-1307 (map cdr syntmp-pvars-1302))) (let ((syntmp-labels-1308 (syntmp-gen-labels-108 syntmp-ids-1306)) (syntmp-new-vars-1309 (map syntmp-gen-var-150 syntmp-ids-1306))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1309 (syntmp-chi-138 syntmp-exp-1303 (syntmp-extend-env-96 syntmp-labels-1308 (map (lambda (syntmp-var-1310 syntmp-level-1311) (cons (quote syntax) (cons syntmp-var-1310 syntmp-level-1311))) syntmp-new-vars-1309 (map cdr syntmp-pvars-1302)) syntmp-r-1305) (syntmp-make-binding-wrap-119 syntmp-ids-1306 syntmp-labels-1308 (quote (())))))) syntmp-y-1304)))))) (syntmp-convert-pattern-1267 (lambda (syntmp-pattern-1312 syntmp-keys-1313) (let syntmp-cvt-1314 ((syntmp-p-1315 syntmp-pattern-1312) (syntmp-n-1316 0) (syntmp-ids-1317 (quote ()))) (if (syntmp-id?-102 syntmp-p-1315) (if (syntmp-bound-id-member?-129 syntmp-p-1315 syntmp-keys-1313) (values (vector (quote free-id) syntmp-p-1315) syntmp-ids-1317) (values (quote any) (cons (cons syntmp-p-1315 syntmp-n-1316) syntmp-ids-1317))) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-tmp-1319) (if (if syntmp-tmp-1319 (apply (lambda (syntmp-x-1320 syntmp-dots-1321) (syntmp-ellipsis?-147 syntmp-dots-1321)) syntmp-tmp-1319) #f) (apply (lambda (syntmp-x-1322 syntmp-dots-1323) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1322 (syntmp-fx+-72 syntmp-n-1316 1) syntmp-ids-1317)) (lambda (syntmp-p-1324 syntmp-ids-1325) (values (if (eq? syntmp-p-1324 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1324)) syntmp-ids-1325)))) syntmp-tmp-1319) ((lambda (syntmp-tmp-1326) (if syntmp-tmp-1326 (apply (lambda (syntmp-x-1327 syntmp-y-1328) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-y-1328 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-y-1329 syntmp-ids-1330) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1327 syntmp-n-1316 syntmp-ids-1330)) (lambda (syntmp-x-1331 syntmp-ids-1332) (values (cons syntmp-x-1331 syntmp-y-1329) syntmp-ids-1332)))))) syntmp-tmp-1326) ((lambda (syntmp-tmp-1333) (if syntmp-tmp-1333 (apply (lambda () (values (quote ()) syntmp-ids-1317)) syntmp-tmp-1333) ((lambda (syntmp-tmp-1334) (if syntmp-tmp-1334 (apply (lambda (syntmp-x-1335) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1335 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-p-1337 syntmp-ids-1338) (values (vector (quote vector) syntmp-p-1337) syntmp-ids-1338)))) syntmp-tmp-1334) ((lambda (syntmp-x-1339) (values (vector (quote atom) (syntmp-strip-149 syntmp-p-1315 (quote (())))) syntmp-ids-1317)) syntmp-tmp-1318))) (syntax-dispatch syntmp-tmp-1318 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1318 (quote ()))))) (syntax-dispatch syntmp-tmp-1318 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1318 (quote (any any))))) syntmp-p-1315)))))) (lambda (syntmp-e-1340 syntmp-r-1341 syntmp-w-1342 syntmp-s-1343) (let ((syntmp-e-1344 (syntmp-source-wrap-131 syntmp-e-1340 syntmp-w-1342 syntmp-s-1343))) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-val-1348 syntmp-key-1349 syntmp-m-1350) (if (andmap (lambda (syntmp-x-1351) (and (syntmp-id?-102 syntmp-x-1351) (not (syntmp-ellipsis?-147 syntmp-x-1351)))) syntmp-key-1349) (let ((syntmp-x-1353 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1343 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1353) (syntmp-gen-syntax-case-1270 (syntmp-build-annotated-81 #f syntmp-x-1353) syntmp-key-1349 syntmp-m-1350 syntmp-r-1341))) (syntmp-chi-138 syntmp-val-1348 syntmp-r-1341 (quote (())))))) (syntax-error syntmp-e-1344 "invalid literals list in"))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any any each-any . each-any))))) syntmp-e-1344))))) (set! sc-expand (let ((syntmp-m-1356 (quote e)) (syntmp-esew-1357 (quote (eval)))) (lambda (syntmp-x-1358) (if (and (pair? syntmp-x-1358) (equal? (car syntmp-x-1358) syntmp-noexpand-71)) (cadr syntmp-x-1358) (syntmp-chi-top-137 syntmp-x-1358 (quote ()) (quote ((top))) syntmp-m-1356 syntmp-esew-1357))))) (set! sc-expand3 (let ((syntmp-m-1359 (quote e)) (syntmp-esew-1360 (quote (eval)))) (lambda (syntmp-x-1362 . syntmp-rest-1361) (if (and (pair? syntmp-x-1362) (equal? (car syntmp-x-1362) syntmp-noexpand-71)) (cadr syntmp-x-1362) (syntmp-chi-top-137 syntmp-x-1362 (quote ()) (quote ((top))) (if (null? syntmp-rest-1361) syntmp-m-1359 (car syntmp-rest-1361)) (if (or (null? syntmp-rest-1361) (null? (cdr syntmp-rest-1361))) syntmp-esew-1360 (cadr syntmp-rest-1361))))))) (set! identifier? (lambda (syntmp-x-1363) (syntmp-nonsymbol-id?-101 syntmp-x-1363))) (set! datum->syntax-object (lambda (syntmp-id-1364 syntmp-datum-1365) (syntmp-make-syntax-object-87 syntmp-datum-1365 (syntmp-syntax-object-wrap-90 syntmp-id-1364)))) (set! syntax-object->datum (lambda (syntmp-x-1366) (syntmp-strip-149 syntmp-x-1366 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1367) (begin (let ((syntmp-x-1368 syntmp-ls-1367)) (if (not (list? syntmp-x-1368)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1368))) (map (lambda (syntmp-x-1369) (syntmp-wrap-130 (gensym) (quote ((top))))) syntmp-ls-1367)))) (set! free-identifier=? (lambda (syntmp-x-1370 syntmp-y-1371) (begin (let ((syntmp-x-1372 syntmp-x-1370)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1372)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1372))) (let ((syntmp-x-1373 syntmp-y-1371)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1373)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1373))) (syntmp-free-id=?-125 syntmp-x-1370 syntmp-y-1371)))) (set! bound-identifier=? (lambda (syntmp-x-1374 syntmp-y-1375) (begin (let ((syntmp-x-1376 syntmp-x-1374)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1376)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1376))) (let ((syntmp-x-1377 syntmp-y-1375)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1377)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1377))) (syntmp-bound-id=?-126 syntmp-x-1374 syntmp-y-1375)))) (set! syntax-error (lambda (syntmp-object-1379 . syntmp-messages-1378) (begin (for-each (lambda (syntmp-x-1380) (let ((syntmp-x-1381 syntmp-x-1380)) (if (not (string? syntmp-x-1381)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1381)))) syntmp-messages-1378) (let ((syntmp-message-1382 (if (null? syntmp-messages-1378) "invalid syntax" (apply string-append syntmp-messages-1378)))) (syntmp-error-hook-78 #f syntmp-message-1382 (syntmp-strip-149 syntmp-object-1379 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1383 syntmp-v-1384) (begin (let ((syntmp-x-1385 syntmp-sym-1383)) (if (not (symbol? syntmp-x-1385)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1385))) (let ((syntmp-x-1386 syntmp-v-1384)) (if (not (procedure? syntmp-x-1386)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1386))) (syntmp-global-extend-100 (quote macro) syntmp-sym-1383 syntmp-v-1384)))) (letrec ((syntmp-match-1391 (lambda (syntmp-e-1392 syntmp-p-1393 syntmp-w-1394 syntmp-r-1395) (cond ((not syntmp-r-1395) #f) ((eq? syntmp-p-1393 (quote any)) (cons (syntmp-wrap-130 syntmp-e-1392 syntmp-w-1394) syntmp-r-1395)) ((syntmp-syntax-object?-88 syntmp-e-1392) (syntmp-match*-1390 (let ((syntmp-e-1396 (syntmp-syntax-object-expression-89 syntmp-e-1392))) (if (annotation? syntmp-e-1396) (annotation-expression syntmp-e-1396) syntmp-e-1396)) syntmp-p-1393 (syntmp-join-wraps-121 syntmp-w-1394 (syntmp-syntax-object-wrap-90 syntmp-e-1392)) syntmp-r-1395)) (else (syntmp-match*-1390 (let ((syntmp-e-1397 syntmp-e-1392)) (if (annotation? syntmp-e-1397) (annotation-expression syntmp-e-1397) syntmp-e-1397)) syntmp-p-1393 syntmp-w-1394 syntmp-r-1395))))) (syntmp-match*-1390 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((null? syntmp-p-1399) (and (null? syntmp-e-1398) syntmp-r-1401)) ((pair? syntmp-p-1399) (and (pair? syntmp-e-1398) (syntmp-match-1391 (car syntmp-e-1398) (car syntmp-p-1399) syntmp-w-1400 (syntmp-match-1391 (cdr syntmp-e-1398) (cdr syntmp-p-1399) syntmp-w-1400 syntmp-r-1401)))) ((eq? syntmp-p-1399 (quote each-any)) (let ((syntmp-l-1402 (syntmp-match-each-any-1388 syntmp-e-1398 syntmp-w-1400))) (and syntmp-l-1402 (cons syntmp-l-1402 syntmp-r-1401)))) (else (let ((syntmp-t-1403 (vector-ref syntmp-p-1399 0))) (if (memv syntmp-t-1403 (quote (each))) (if (null? syntmp-e-1398) (syntmp-match-empty-1389 (vector-ref syntmp-p-1399 1) syntmp-r-1401) (let ((syntmp-l-1404 (syntmp-match-each-1387 syntmp-e-1398 (vector-ref syntmp-p-1399 1) syntmp-w-1400))) (and syntmp-l-1404 (let syntmp-collect-1405 ((syntmp-l-1406 syntmp-l-1404)) (if (null? (car syntmp-l-1406)) syntmp-r-1401 (cons (map car syntmp-l-1406) (syntmp-collect-1405 (map cdr syntmp-l-1406)))))))) (if (memv syntmp-t-1403 (quote (free-id))) (and (syntmp-id?-102 syntmp-e-1398) (syntmp-free-id=?-125 (syntmp-wrap-130 syntmp-e-1398 syntmp-w-1400) (vector-ref syntmp-p-1399 1)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (atom))) (and (equal? (vector-ref syntmp-p-1399 1) (syntmp-strip-149 syntmp-e-1398 syntmp-w-1400)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (vector))) (and (vector? syntmp-e-1398) (syntmp-match-1391 (vector->list syntmp-e-1398) (vector-ref syntmp-p-1399 1) syntmp-w-1400 syntmp-r-1401))))))))))) (syntmp-match-empty-1389 (lambda (syntmp-p-1407 syntmp-r-1408) (cond ((null? syntmp-p-1407) syntmp-r-1408) ((eq? syntmp-p-1407 (quote any)) (cons (quote ()) syntmp-r-1408)) ((pair? syntmp-p-1407) (syntmp-match-empty-1389 (car syntmp-p-1407) (syntmp-match-empty-1389 (cdr syntmp-p-1407) syntmp-r-1408))) ((eq? syntmp-p-1407 (quote each-any)) (cons (quote ()) syntmp-r-1408)) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1407 0))) (if (memv syntmp-t-1409 (quote (each))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408) (if (memv syntmp-t-1409 (quote (free-id atom))) syntmp-r-1408 (if (memv syntmp-t-1409 (quote (vector))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408))))))))) (syntmp-match-each-any-1388 (lambda (syntmp-e-1410 syntmp-w-1411) (cond ((annotation? syntmp-e-1410) (syntmp-match-each-any-1388 (annotation-expression syntmp-e-1410) syntmp-w-1411)) ((pair? syntmp-e-1410) (let ((syntmp-l-1412 (syntmp-match-each-any-1388 (cdr syntmp-e-1410) syntmp-w-1411))) (and syntmp-l-1412 (cons (syntmp-wrap-130 (car syntmp-e-1410) syntmp-w-1411) syntmp-l-1412)))) ((null? syntmp-e-1410) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1410) (syntmp-match-each-any-1388 (syntmp-syntax-object-expression-89 syntmp-e-1410) (syntmp-join-wraps-121 syntmp-w-1411 (syntmp-syntax-object-wrap-90 syntmp-e-1410)))) (else #f)))) (syntmp-match-each-1387 (lambda (syntmp-e-1413 syntmp-p-1414 syntmp-w-1415) (cond ((annotation? syntmp-e-1413) (syntmp-match-each-1387 (annotation-expression syntmp-e-1413) syntmp-p-1414 syntmp-w-1415)) ((pair? syntmp-e-1413) (let ((syntmp-first-1416 (syntmp-match-1391 (car syntmp-e-1413) syntmp-p-1414 syntmp-w-1415 (quote ())))) (and syntmp-first-1416 (let ((syntmp-rest-1417 (syntmp-match-each-1387 (cdr syntmp-e-1413) syntmp-p-1414 syntmp-w-1415))) (and syntmp-rest-1417 (cons syntmp-first-1416 syntmp-rest-1417)))))) ((null? syntmp-e-1413) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1413) (syntmp-match-each-1387 (syntmp-syntax-object-expression-89 syntmp-e-1413) syntmp-p-1414 (syntmp-join-wraps-121 syntmp-w-1415 (syntmp-syntax-object-wrap-90 syntmp-e-1413)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1418 syntmp-p-1419) (cond ((eq? syntmp-p-1419 (quote any)) (list syntmp-e-1418)) ((syntmp-syntax-object?-88 syntmp-e-1418) (syntmp-match*-1390 (let ((syntmp-e-1420 (syntmp-syntax-object-expression-89 syntmp-e-1418))) (if (annotation? syntmp-e-1420) (annotation-expression syntmp-e-1420) syntmp-e-1420)) syntmp-p-1419 (syntmp-syntax-object-wrap-90 syntmp-e-1418) (quote ()))) (else (syntmp-match*-1390 (let ((syntmp-e-1421 syntmp-e-1418)) (if (annotation? syntmp-e-1421) (annotation-expression syntmp-e-1421) syntmp-e-1421)) syntmp-p-1419 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-138))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1422) ((lambda (syntmp-tmp-1423) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda (syntmp-_-1425 syntmp-e1-1426 syntmp-e2-1427) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1426 syntmp-e2-1427))) syntmp-tmp-1424) ((lambda (syntmp-tmp-1429) (if syntmp-tmp-1429 (apply (lambda (syntmp-_-1430 syntmp-out-1431 syntmp-in-1432 syntmp-e1-1433 syntmp-e2-1434) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1432 (quote ()) (list syntmp-out-1431 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1433 syntmp-e2-1434))))) syntmp-tmp-1429) ((lambda (syntmp-tmp-1436) (if syntmp-tmp-1436 (apply (lambda (syntmp-_-1437 syntmp-out-1438 syntmp-in-1439 syntmp-e1-1440 syntmp-e2-1441) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1439) (quote ()) (list syntmp-out-1438 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1440 syntmp-e2-1441))))) syntmp-tmp-1436) (syntax-error syntmp-tmp-1423))) (syntax-dispatch syntmp-tmp-1423 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any () any . each-any))))) syntmp-x-1422))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1463) ((lambda (syntmp-tmp-1464) ((lambda (syntmp-tmp-1465) (if syntmp-tmp-1465 (apply (lambda (syntmp-_-1466 syntmp-k-1467 syntmp-keyword-1468 syntmp-pattern-1469 syntmp-template-1470) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1467 (map (lambda (syntmp-tmp-1473 syntmp-tmp-1472) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1472) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1473))) syntmp-template-1470 syntmp-pattern-1469)))))) syntmp-tmp-1465) (syntax-error syntmp-tmp-1464))) (syntax-dispatch syntmp-tmp-1464 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1463))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1484) ((lambda (syntmp-tmp-1485) ((lambda (syntmp-tmp-1486) (if (if syntmp-tmp-1486 (apply (lambda (syntmp-let*-1487 syntmp-x-1488 syntmp-v-1489 syntmp-e1-1490 syntmp-e2-1491) (andmap identifier? syntmp-x-1488)) syntmp-tmp-1486) #f) (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (let syntmp-f-1498 ((syntmp-bindings-1499 (map list syntmp-x-1494 syntmp-v-1495))) (if (null? syntmp-bindings-1499) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1496 syntmp-e2-1497))) ((lambda (syntmp-tmp-1503) ((lambda (syntmp-tmp-1504) (if syntmp-tmp-1504 (apply (lambda (syntmp-body-1505 syntmp-binding-1506) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1506) syntmp-body-1505)) syntmp-tmp-1504) (syntax-error syntmp-tmp-1503))) (syntax-dispatch syntmp-tmp-1503 (quote (any any))))) (list (syntmp-f-1498 (cdr syntmp-bindings-1499)) (car syntmp-bindings-1499)))))) syntmp-tmp-1486) (syntax-error syntmp-tmp-1485))) (syntax-dispatch syntmp-tmp-1485 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1484))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1526) ((lambda (syntmp-tmp-1527) ((lambda (syntmp-tmp-1528) (if syntmp-tmp-1528 (apply (lambda (syntmp-_-1529 syntmp-var-1530 syntmp-init-1531 syntmp-step-1532 syntmp-e0-1533 syntmp-e1-1534 syntmp-c-1535) ((lambda (syntmp-tmp-1536) ((lambda (syntmp-tmp-1537) (if syntmp-tmp-1537 (apply (lambda (syntmp-step-1538) ((lambda (syntmp-tmp-1539) ((lambda (syntmp-tmp-1540) (if syntmp-tmp-1540 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1533) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1535 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1538))))))) syntmp-tmp-1540) ((lambda (syntmp-tmp-1545) (if syntmp-tmp-1545 (apply (lambda (syntmp-e1-1546 syntmp-e2-1547) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1533 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1546 syntmp-e2-1547)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1535 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1538))))))) syntmp-tmp-1545) (syntax-error syntmp-tmp-1539))) (syntax-dispatch syntmp-tmp-1539 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1539 (quote ())))) syntmp-e1-1534)) syntmp-tmp-1537) (syntax-error syntmp-tmp-1536))) (syntax-dispatch syntmp-tmp-1536 (quote each-any)))) (map (lambda (syntmp-v-1554 syntmp-s-1555) ((lambda (syntmp-tmp-1556) ((lambda (syntmp-tmp-1557) (if syntmp-tmp-1557 (apply (lambda () syntmp-v-1554) syntmp-tmp-1557) ((lambda (syntmp-tmp-1558) (if syntmp-tmp-1558 (apply (lambda (syntmp-e-1559) syntmp-e-1559) syntmp-tmp-1558) ((lambda (syntmp-_-1560) (syntax-error syntmp-orig-x-1526)) syntmp-tmp-1556))) (syntax-dispatch syntmp-tmp-1556 (quote (any)))))) (syntax-dispatch syntmp-tmp-1556 (quote ())))) syntmp-s-1555)) syntmp-var-1530 syntmp-step-1532))) syntmp-tmp-1528) (syntax-error syntmp-tmp-1527))) (syntax-dispatch syntmp-tmp-1527 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1526))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1588 (lambda (syntmp-x-1592 syntmp-y-1593) ((lambda (syntmp-tmp-1594) ((lambda (syntmp-tmp-1595) (if syntmp-tmp-1595 (apply (lambda (syntmp-x-1596 syntmp-y-1597) ((lambda (syntmp-tmp-1598) ((lambda (syntmp-tmp-1599) (if syntmp-tmp-1599 (apply (lambda (syntmp-dy-1600) ((lambda (syntmp-tmp-1601) ((lambda (syntmp-tmp-1602) (if syntmp-tmp-1602 (apply (lambda (syntmp-dx-1603) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1603 syntmp-dy-1600))) syntmp-tmp-1602) ((lambda (syntmp-_-1604) (if (null? syntmp-dy-1600) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597))) syntmp-tmp-1601))) (syntax-dispatch syntmp-tmp-1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1596)) syntmp-tmp-1599) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-stuff-1606) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1596 syntmp-stuff-1606))) syntmp-tmp-1605) ((lambda (syntmp-else-1607) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597)) syntmp-tmp-1598))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1597)) syntmp-tmp-1595) (syntax-error syntmp-tmp-1594))) (syntax-dispatch syntmp-tmp-1594 (quote (any any))))) (list syntmp-x-1592 syntmp-y-1593)))) (syntmp-quasiappend-1589 (lambda (syntmp-x-1608 syntmp-y-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-x-1612 syntmp-y-1613) ((lambda (syntmp-tmp-1614) ((lambda (syntmp-tmp-1615) (if syntmp-tmp-1615 (apply (lambda () syntmp-x-1612) syntmp-tmp-1615) ((lambda (syntmp-_-1616) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1612 syntmp-y-1613)) syntmp-tmp-1614))) (syntax-dispatch syntmp-tmp-1614 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1613)) syntmp-tmp-1611) (syntax-error syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (any any))))) (list syntmp-x-1608 syntmp-y-1609)))) (syntmp-quasivector-1590 (lambda (syntmp-x-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-x-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda (syntmp-x-1622) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1622))) syntmp-tmp-1621) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-x-1625) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1625)) syntmp-tmp-1624) ((lambda (syntmp-_-1627) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1619)) syntmp-tmp-1618)) syntmp-x-1617))) (syntmp-quasi-1591 (lambda (syntmp-p-1628 syntmp-lev-1629) ((lambda (syntmp-tmp-1630) ((lambda (syntmp-tmp-1631) (if syntmp-tmp-1631 (apply (lambda (syntmp-p-1632) (if (= syntmp-lev-1629 0) syntmp-p-1632 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1632) (- syntmp-lev-1629 1))))) syntmp-tmp-1631) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-p-1634 syntmp-q-1635) (if (= syntmp-lev-1629 0) (syntmp-quasiappend-1589 syntmp-p-1634 (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)) (syntmp-quasicons-1588 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1634) (- syntmp-lev-1629 1))) (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)))) syntmp-tmp-1633) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda (syntmp-p-1637) (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1637) (+ syntmp-lev-1629 1)))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1638) (if syntmp-tmp-1638 (apply (lambda (syntmp-p-1639 syntmp-q-1640) (syntmp-quasicons-1588 (syntmp-quasi-1591 syntmp-p-1639 syntmp-lev-1629) (syntmp-quasi-1591 syntmp-q-1640 syntmp-lev-1629))) syntmp-tmp-1638) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-x-1642) (syntmp-quasivector-1590 (syntmp-quasi-1591 syntmp-x-1642 syntmp-lev-1629))) syntmp-tmp-1641) ((lambda (syntmp-p-1644) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1644)) syntmp-tmp-1630))) (syntax-dispatch syntmp-tmp-1630 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1630 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1628)))) (lambda (syntmp-x-1645) ((lambda (syntmp-tmp-1646) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-_-1648 syntmp-e-1649) (syntmp-quasi-1591 syntmp-e-1649 0)) syntmp-tmp-1647) (syntax-error syntmp-tmp-1646))) (syntax-dispatch syntmp-tmp-1646 (quote (any any))))) syntmp-x-1645)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1709) (letrec ((syntmp-read-file-1710 (lambda (syntmp-fn-1711 syntmp-k-1712) (let ((syntmp-p-1713 (open-input-file syntmp-fn-1711))) (let syntmp-f-1714 ((syntmp-x-1715 (read syntmp-p-1713))) (if (eof-object? syntmp-x-1715) (begin (close-input-port syntmp-p-1713) (quote ())) (cons (datum->syntax-object syntmp-k-1712 syntmp-x-1715) (syntmp-f-1714 (read syntmp-p-1713))))))))) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-k-1718 syntmp-filename-1719) (let ((syntmp-fn-1720 (syntax-object->datum syntmp-filename-1719))) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-exp-1723) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1723)) syntmp-tmp-1722) (syntax-error syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote each-any)))) (syntmp-read-file-1710 syntmp-fn-1720 syntmp-k-1718)))) syntmp-tmp-1717) (syntax-error syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (any any))))) syntmp-x-1709)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1740) ((lambda (syntmp-tmp-1741) ((lambda (syntmp-tmp-1742) (if syntmp-tmp-1742 (apply (lambda (syntmp-_-1743 syntmp-e-1744) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1744))) syntmp-tmp-1742) (syntax-error syntmp-tmp-1741))) (syntax-dispatch syntmp-tmp-1741 (quote (any any))))) syntmp-x-1740))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1750) ((lambda (syntmp-tmp-1751) ((lambda (syntmp-tmp-1752) (if syntmp-tmp-1752 (apply (lambda (syntmp-_-1753 syntmp-e-1754) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1754))) syntmp-tmp-1752) (syntax-error syntmp-tmp-1751))) (syntax-dispatch syntmp-tmp-1751 (quote (any any))))) syntmp-x-1750))) -(install-global-transformer (quote case) (lambda (syntmp-x-1760) ((lambda (syntmp-tmp-1761) ((lambda (syntmp-tmp-1762) (if syntmp-tmp-1762 (apply (lambda (syntmp-_-1763 syntmp-e-1764 syntmp-m1-1765 syntmp-m2-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-body-1768) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1764)) syntmp-body-1768)) syntmp-tmp-1767)) (let syntmp-f-1769 ((syntmp-clause-1770 syntmp-m1-1765) (syntmp-clauses-1771 syntmp-m2-1766)) (if (null? syntmp-clauses-1771) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-tmp-1774) (if syntmp-tmp-1774 (apply (lambda (syntmp-e1-1775 syntmp-e2-1776) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1775 syntmp-e2-1776))) syntmp-tmp-1774) ((lambda (syntmp-tmp-1778) (if syntmp-tmp-1778 (apply (lambda (syntmp-k-1779 syntmp-e1-1780 syntmp-e2-1781) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1779)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1780 syntmp-e2-1781)))) syntmp-tmp-1778) ((lambda (syntmp-_-1784) (syntax-error syntmp-x-1760)) syntmp-tmp-1773))) (syntax-dispatch syntmp-tmp-1773 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1773 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1770) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-rest-1786) ((lambda (syntmp-tmp-1787) ((lambda (syntmp-tmp-1788) (if syntmp-tmp-1788 (apply (lambda (syntmp-k-1789 syntmp-e1-1790 syntmp-e2-1791) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1789)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1790 syntmp-e2-1791)) syntmp-rest-1786)) syntmp-tmp-1788) ((lambda (syntmp-_-1794) (syntax-error syntmp-x-1760)) syntmp-tmp-1787))) (syntax-dispatch syntmp-tmp-1787 (quote (each-any any . each-any))))) syntmp-clause-1770)) syntmp-tmp-1785)) (syntmp-f-1769 (car syntmp-clauses-1771) (cdr syntmp-clauses-1771))))))) syntmp-tmp-1762) (syntax-error syntmp-tmp-1761))) (syntax-dispatch syntmp-tmp-1761 (quote (any any any . each-any))))) syntmp-x-1760))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1824) ((lambda (syntmp-tmp-1825) ((lambda (syntmp-tmp-1826) (if syntmp-tmp-1826 (apply (lambda (syntmp-_-1827 syntmp-e-1828) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1828)) (list (cons syntmp-_-1827 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1828 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1826) (syntax-error syntmp-tmp-1825))) (syntax-dispatch syntmp-tmp-1825 (quote (any any))))) syntmp-x-1824))) +(letrec ((syntmp-lambda-var-list-164 (lambda (syntmp-vars-549) (let syntmp-lvl-550 ((syntmp-vars-551 syntmp-vars-549) (syntmp-ls-552 (quote ())) (syntmp-w-553 (quote (())))) (cond ((pair? syntmp-vars-551) (syntmp-lvl-550 (cdr syntmp-vars-551) (cons (syntmp-wrap-143 (car syntmp-vars-551) syntmp-w-553) syntmp-ls-552) syntmp-w-553)) ((syntmp-id?-115 syntmp-vars-551) (cons (syntmp-wrap-143 syntmp-vars-551 syntmp-w-553) syntmp-ls-552)) ((null? syntmp-vars-551) syntmp-ls-552) ((syntmp-syntax-object?-101 syntmp-vars-551) (syntmp-lvl-550 (syntmp-syntax-object-expression-102 syntmp-vars-551) syntmp-ls-552 (syntmp-join-wraps-134 syntmp-w-553 (syntmp-syntax-object-wrap-103 syntmp-vars-551)))) ((annotation? syntmp-vars-551) (syntmp-lvl-550 (annotation-expression syntmp-vars-551) syntmp-ls-552 syntmp-w-553)) (else (cons syntmp-vars-551 syntmp-ls-552)))))) (syntmp-gen-var-163 (lambda (syntmp-id-554) (let ((syntmp-id-555 (if (syntmp-syntax-object?-101 syntmp-id-554) (syntmp-syntax-object-expression-102 syntmp-id-554) syntmp-id-554))) (if (annotation? syntmp-id-555) (syntmp-build-annotated-94 (annotation-source syntmp-id-555) (gensym (symbol->string (annotation-expression syntmp-id-555)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-555))))))) (syntmp-strip-162 (lambda (syntmp-x-556 syntmp-w-557) (if (memq (quote top) (syntmp-wrap-marks-118 syntmp-w-557)) (if (or (annotation? syntmp-x-556) (and (pair? syntmp-x-556) (annotation? (car syntmp-x-556)))) (syntmp-strip-annotation-161 syntmp-x-556 #f) syntmp-x-556) (let syntmp-f-558 ((syntmp-x-559 syntmp-x-556)) (cond ((syntmp-syntax-object?-101 syntmp-x-559) (syntmp-strip-162 (syntmp-syntax-object-expression-102 syntmp-x-559) (syntmp-syntax-object-wrap-103 syntmp-x-559))) ((pair? syntmp-x-559) (let ((syntmp-a-560 (syntmp-f-558 (car syntmp-x-559))) (syntmp-d-561 (syntmp-f-558 (cdr syntmp-x-559)))) (if (and (eq? syntmp-a-560 (car syntmp-x-559)) (eq? syntmp-d-561 (cdr syntmp-x-559))) syntmp-x-559 (cons syntmp-a-560 syntmp-d-561)))) ((vector? syntmp-x-559) (let ((syntmp-old-562 (vector->list syntmp-x-559))) (let ((syntmp-new-563 (map syntmp-f-558 syntmp-old-562))) (if (andmap eq? syntmp-old-562 syntmp-new-563) syntmp-x-559 (list->vector syntmp-new-563))))) (else syntmp-x-559)))))) (syntmp-strip-annotation-161 (lambda (syntmp-x-564 syntmp-parent-565) (cond ((pair? syntmp-x-564) (let ((syntmp-new-566 (cons #f #f))) (begin (if syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-566)) (set-car! syntmp-new-566 (syntmp-strip-annotation-161 (car syntmp-x-564) #f)) (set-cdr! syntmp-new-566 (syntmp-strip-annotation-161 (cdr syntmp-x-564) #f)) syntmp-new-566))) ((annotation? syntmp-x-564) (or (annotation-stripped syntmp-x-564) (syntmp-strip-annotation-161 (annotation-expression syntmp-x-564) syntmp-x-564))) ((vector? syntmp-x-564) (let ((syntmp-new-567 (make-vector (vector-length syntmp-x-564)))) (begin (if syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-567)) (let syntmp-loop-568 ((syntmp-i-569 (- (vector-length syntmp-x-564) 1))) (unless (syntmp-fx<-88 syntmp-i-569 0) (vector-set! syntmp-new-567 syntmp-i-569 (syntmp-strip-annotation-161 (vector-ref syntmp-x-564 syntmp-i-569) #f)) (syntmp-loop-568 (syntmp-fx--86 syntmp-i-569 1)))) syntmp-new-567))) (else syntmp-x-564)))) (syntmp-ellipsis?-160 (lambda (syntmp-x-570) (and (syntmp-nonsymbol-id?-114 syntmp-x-570) (syntmp-free-id=?-138 syntmp-x-570 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-159 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-158 (lambda (syntmp-expanded-571) (let ((syntmp-p-572 (syntmp-local-eval-hook-90 syntmp-expanded-571))) (if (procedure? syntmp-p-572) syntmp-p-572 (syntax-error syntmp-p-572 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-157 (lambda (syntmp-rec?-573 syntmp-e-574 syntmp-r-575 syntmp-w-576 syntmp-s-577 syntmp-k-578) ((lambda (syntmp-tmp-579) ((lambda (syntmp-tmp-580) (if syntmp-tmp-580 (apply (lambda (syntmp-_-581 syntmp-id-582 syntmp-val-583 syntmp-e1-584 syntmp-e2-585) (let ((syntmp-ids-586 syntmp-id-582)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-586)) (syntax-error syntmp-e-574 "duplicate bound keyword in") (let ((syntmp-labels-588 (syntmp-gen-labels-121 syntmp-ids-586))) (let ((syntmp-new-w-589 (syntmp-make-binding-wrap-132 syntmp-ids-586 syntmp-labels-588 syntmp-w-576))) (syntmp-k-578 (cons syntmp-e1-584 syntmp-e2-585) (syntmp-extend-env-109 syntmp-labels-588 (let ((syntmp-w-591 (if syntmp-rec?-573 syntmp-new-w-589 syntmp-w-576)) (syntmp-trans-r-592 (syntmp-macros-only-env-111 syntmp-r-575))) (map (lambda (syntmp-x-593) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-593 syntmp-trans-r-592 syntmp-w-591)))) syntmp-val-583)) syntmp-r-575) syntmp-new-w-589 syntmp-s-577)))))) syntmp-tmp-580) ((lambda (syntmp-_-595) (syntax-error (syntmp-source-wrap-144 syntmp-e-574 syntmp-w-576 syntmp-s-577))) syntmp-tmp-579))) (syntax-dispatch syntmp-tmp-579 (quote (any #(each (any any)) any . each-any))))) syntmp-e-574))) (syntmp-chi-lambda-clause-156 (lambda (syntmp-e-596 syntmp-c-597 syntmp-r-598 syntmp-w-599 syntmp-k-600) ((lambda (syntmp-tmp-601) ((lambda (syntmp-tmp-602) (if syntmp-tmp-602 (apply (lambda (syntmp-id-603 syntmp-e1-604 syntmp-e2-605) (let ((syntmp-ids-606 syntmp-id-603)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-606)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-608 (syntmp-gen-labels-121 syntmp-ids-606)) (syntmp-new-vars-609 (map syntmp-gen-var-163 syntmp-ids-606))) (syntmp-k-600 syntmp-new-vars-609 (syntmp-chi-body-155 (cons syntmp-e1-604 syntmp-e2-605) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-608 syntmp-new-vars-609 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-ids-606 syntmp-labels-608 syntmp-w-599))))))) syntmp-tmp-602) ((lambda (syntmp-tmp-611) (if syntmp-tmp-611 (apply (lambda (syntmp-ids-612 syntmp-e1-613 syntmp-e2-614) (let ((syntmp-old-ids-615 (syntmp-lambda-var-list-164 syntmp-ids-612))) (if (not (syntmp-valid-bound-ids?-140 syntmp-old-ids-615)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-616 (syntmp-gen-labels-121 syntmp-old-ids-615)) (syntmp-new-vars-617 (map syntmp-gen-var-163 syntmp-old-ids-615))) (syntmp-k-600 (let syntmp-f-618 ((syntmp-ls1-619 (cdr syntmp-new-vars-617)) (syntmp-ls2-620 (car syntmp-new-vars-617))) (if (null? syntmp-ls1-619) syntmp-ls2-620 (syntmp-f-618 (cdr syntmp-ls1-619) (cons (car syntmp-ls1-619) syntmp-ls2-620)))) (syntmp-chi-body-155 (cons syntmp-e1-613 syntmp-e2-614) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-616 syntmp-new-vars-617 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-old-ids-615 syntmp-labels-616 syntmp-w-599))))))) syntmp-tmp-611) ((lambda (syntmp-_-622) (syntax-error syntmp-e-596)) syntmp-tmp-601))) (syntax-dispatch syntmp-tmp-601 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-601 (quote (each-any any . each-any))))) syntmp-c-597))) (syntmp-chi-body-155 (lambda (syntmp-body-623 syntmp-outer-form-624 syntmp-r-625 syntmp-w-626) (let ((syntmp-r-627 (cons (quote ("placeholder" placeholder)) syntmp-r-625))) (let ((syntmp-ribcage-628 (syntmp-make-ribcage-122 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-629 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-626) (cons syntmp-ribcage-628 (syntmp-wrap-subst-119 syntmp-w-626))))) (let syntmp-parse-630 ((syntmp-body-631 (map (lambda (syntmp-x-637) (cons syntmp-r-627 (syntmp-wrap-143 syntmp-x-637 syntmp-w-629))) syntmp-body-623)) (syntmp-ids-632 (quote ())) (syntmp-labels-633 (quote ())) (syntmp-vars-634 (quote ())) (syntmp-vals-635 (quote ())) (syntmp-bindings-636 (quote ()))) (if (null? syntmp-body-631) (syntax-error syntmp-outer-form-624 "no expressions in body") (let ((syntmp-e-638 (cdar syntmp-body-631)) (syntmp-er-639 (caar syntmp-body-631))) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-638 syntmp-er-639 (quote (())) #f syntmp-ribcage-628)) (lambda (syntmp-type-640 syntmp-value-641 syntmp-e-642 syntmp-w-643 syntmp-s-644) (let ((syntmp-t-645 syntmp-type-640)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-647 (syntmp-gen-label-120))) (let ((syntmp-var-648 (syntmp-gen-var-163 syntmp-id-646))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-646 syntmp-label-647) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-646 syntmp-ids-632) (cons syntmp-label-647 syntmp-labels-633) (cons syntmp-var-648 syntmp-vars-634) (cons (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643)) syntmp-vals-635) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-636))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-650 (syntmp-gen-label-120))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-649 syntmp-label-650) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-649 syntmp-ids-632) (cons syntmp-label-650 syntmp-labels-633) syntmp-vars-634 syntmp-vals-635 (cons (cons (quote macro) (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643))) syntmp-bindings-636)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-630 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-631) (cons (cons syntmp-er-639 (syntmp-wrap-143 (car syntmp-forms-656) syntmp-w-643)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-642) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-641 syntmp-e-642 syntmp-er-639 syntmp-w-643 syntmp-s-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661) (syntmp-parse-630 (let syntmp-f-662 ((syntmp-forms-663 syntmp-forms-658)) (if (null? syntmp-forms-663) (cdr syntmp-body-631) (cons (cons syntmp-er-659 (syntmp-wrap-143 (car syntmp-forms-663) syntmp-w-660)) (syntmp-f-662 (cdr syntmp-forms-663))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636))) (if (null? syntmp-ids-632) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-664) (syntmp-chi-151 (cdr syntmp-x-664) (car syntmp-x-664) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))) (begin (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-632)) (syntax-error syntmp-outer-form-624 "invalid or duplicate identifier in definition")) (let syntmp-loop-665 ((syntmp-bs-666 syntmp-bindings-636) (syntmp-er-cache-667 #f) (syntmp-r-cache-668 #f)) (if (not (null? syntmp-bs-666)) (let ((syntmp-b-669 (car syntmp-bs-666))) (if (eq? (car syntmp-b-669) (quote macro)) (let ((syntmp-er-670 (cadr syntmp-b-669))) (let ((syntmp-r-cache-671 (if (eq? syntmp-er-670 syntmp-er-cache-667) syntmp-r-cache-668 (syntmp-macros-only-env-111 syntmp-er-670)))) (begin (set-cdr! syntmp-b-669 (syntmp-eval-local-transformer-158 (syntmp-chi-151 (cddr syntmp-b-669) syntmp-r-cache-671 (quote (()))))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-670 syntmp-r-cache-671)))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-cache-667 syntmp-r-cache-668))))) (set-cdr! syntmp-r-627 (syntmp-extend-env-109 syntmp-labels-633 syntmp-bindings-636 (cdr syntmp-r-627))) (syntmp-build-letrec-99 #f syntmp-vars-634 (map (lambda (syntmp-x-672) (syntmp-chi-151 (cdr syntmp-x-672) (car syntmp-x-672) (quote (())))) syntmp-vals-635) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-673) (syntmp-chi-151 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))))))))))))))))))))) (syntmp-chi-macro-154 (lambda (syntmp-p-674 syntmp-e-675 syntmp-r-676 syntmp-w-677 syntmp-rib-678) (letrec ((syntmp-rebuild-macro-output-679 (lambda (syntmp-x-680 syntmp-m-681) (cond ((pair? syntmp-x-680) (cons (syntmp-rebuild-macro-output-679 (car syntmp-x-680) syntmp-m-681) (syntmp-rebuild-macro-output-679 (cdr syntmp-x-680) syntmp-m-681))) ((syntmp-syntax-object?-101 syntmp-x-680) (let ((syntmp-w-682 (syntmp-syntax-object-wrap-103 syntmp-x-680))) (let ((syntmp-ms-683 (syntmp-wrap-marks-118 syntmp-w-682)) (syntmp-s-684 (syntmp-wrap-subst-119 syntmp-w-682))) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-680) (if (and (pair? syntmp-ms-683) (eq? (car syntmp-ms-683) #f)) (syntmp-make-wrap-117 (cdr syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cdr syntmp-s-684)) (cdr syntmp-s-684))) (syntmp-make-wrap-117 (cons syntmp-m-681 syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cons (quote shift) syntmp-s-684)) (cons (quote shift) syntmp-s-684)))))))) ((vector? syntmp-x-680) (let ((syntmp-n-685 (vector-length syntmp-x-680))) (let ((syntmp-v-686 (make-vector syntmp-n-685))) (let syntmp-doloop-687 ((syntmp-i-688 0)) (if (syntmp-fx=-87 syntmp-i-688 syntmp-n-685) syntmp-v-686 (begin (vector-set! syntmp-v-686 syntmp-i-688 (syntmp-rebuild-macro-output-679 (vector-ref syntmp-x-680 syntmp-i-688) syntmp-m-681)) (syntmp-doloop-687 (syntmp-fx+-85 syntmp-i-688 1)))))))) ((symbol? syntmp-x-680) (syntax-error syntmp-x-680 "encountered raw symbol in macro output")) (else syntmp-x-680))))) (syntmp-rebuild-macro-output-679 (syntmp-p-674 (syntmp-wrap-143 syntmp-e-675 (syntmp-anti-mark-130 syntmp-w-677))) (string #\m))))) (syntmp-chi-application-153 (lambda (syntmp-x-689 syntmp-e-690 syntmp-r-691 syntmp-w-692 syntmp-s-693) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-e0-696 syntmp-e1-697) (syntmp-build-annotated-94 syntmp-s-693 (cons syntmp-x-689 (map (lambda (syntmp-e-698) (syntmp-chi-151 syntmp-e-698 syntmp-r-691 syntmp-w-692)) syntmp-e1-697)))) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any . each-any))))) syntmp-e-690))) (syntmp-chi-expr-152 (lambda (syntmp-type-700 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (let ((syntmp-t-706 syntmp-type-700)) (if (memv syntmp-t-706 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-705 syntmp-value-701) (if (memv syntmp-t-706 (quote (core external-macro))) (syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (lexical-call))) (syntmp-chi-application-153 (syntmp-build-annotated-94 (syntmp-source-annotation-106 (car syntmp-e-702)) syntmp-value-701) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (global-call))) (syntmp-chi-application-153 (syntmp-build-annotated-94 (syntmp-source-annotation-106 (car syntmp-e-702)) (make-module-ref #f syntmp-value-701 #f)) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (constant))) (syntmp-build-data-95 syntmp-s-705 (syntmp-strip-162 (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) (quote (())))) (if (memv syntmp-t-706 (quote (global))) (syntmp-build-annotated-94 syntmp-s-705 (make-module-ref #f syntmp-value-701 #f)) (if (memv syntmp-t-706 (quote (call))) (syntmp-chi-application-153 (syntmp-chi-151 (car syntmp-e-702) syntmp-r-703 syntmp-w-704) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (begin-form))) ((lambda (syntmp-tmp-707) ((lambda (syntmp-tmp-708) (if syntmp-tmp-708 (apply (lambda (syntmp-_-709 syntmp-e1-710 syntmp-e2-711) (syntmp-chi-sequence-145 (cons syntmp-e1-710 syntmp-e2-711) syntmp-r-703 syntmp-w-704 syntmp-s-705)) syntmp-tmp-708) (syntax-error syntmp-tmp-707))) (syntax-dispatch syntmp-tmp-707 (quote (any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705 syntmp-chi-sequence-145) (if (memv syntmp-t-706 (quote (eval-when-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-x-716 syntmp-e1-717 syntmp-e2-718) (let ((syntmp-when-list-719 (syntmp-chi-when-list-148 syntmp-e-702 syntmp-x-716 syntmp-w-704))) (if (memq (quote eval) syntmp-when-list-719) (syntmp-chi-sequence-145 (cons syntmp-e1-717 syntmp-e2-718) syntmp-r-703 syntmp-w-704 syntmp-s-705) (syntmp-chi-void-159)))) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any each-any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-143 syntmp-value-701 syntmp-w-704) "invalid context for definition of") (if (memv syntmp-t-706 (quote (syntax))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to pattern variable outside syntax form") (if (memv syntmp-t-706 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705)))))))))))))))))) (syntmp-chi-151 (lambda (syntmp-e-722 syntmp-r-723 syntmp-w-724) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-722 syntmp-r-723 syntmp-w-724 #f #f)) (lambda (syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-w-728 syntmp-s-729) (syntmp-chi-expr-152 syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-r-723 syntmp-w-728 syntmp-s-729))))) (syntmp-chi-top-150 (lambda (syntmp-e-730 syntmp-r-731 syntmp-w-732 syntmp-m-733 syntmp-esew-734) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-730 syntmp-r-731 syntmp-w-732 #f #f)) (lambda (syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-w-750 syntmp-s-751) (let ((syntmp-t-752 syntmp-type-747)) (if (memv syntmp-t-752 (quote (begin-form))) ((lambda (syntmp-tmp-753) ((lambda (syntmp-tmp-754) (if syntmp-tmp-754 (apply (lambda (syntmp-_-755) (syntmp-chi-void-159)) syntmp-tmp-754) ((lambda (syntmp-tmp-756) (if syntmp-tmp-756 (apply (lambda (syntmp-_-757 syntmp-e1-758 syntmp-e2-759) (syntmp-chi-top-sequence-146 (cons syntmp-e1-758 syntmp-e2-759) syntmp-r-731 syntmp-w-750 syntmp-s-751 syntmp-m-733 syntmp-esew-734)) syntmp-tmp-756) (syntax-error syntmp-tmp-753))) (syntax-dispatch syntmp-tmp-753 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-753 (quote (any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751 (lambda (syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764) (syntmp-chi-top-sequence-146 syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764 syntmp-m-733 syntmp-esew-734))) (if (memv syntmp-t-752 (quote (eval-when-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767 syntmp-x-768 syntmp-e1-769 syntmp-e2-770) (let ((syntmp-when-list-771 (syntmp-chi-when-list-148 syntmp-e-749 syntmp-x-768 syntmp-w-750)) (syntmp-body-772 (cons syntmp-e1-769 syntmp-e2-770))) (cond ((eq? syntmp-m-733 (quote e)) (if (memq (quote eval) syntmp-when-list-771) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval))) (syntmp-chi-void-159))) ((memq (quote load) syntmp-when-list-771) (if (or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c&e) (quote (compile load))) (if (memq syntmp-m-733 (quote (c c&e))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c) (quote (load))) (syntmp-chi-void-159)))) ((or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval)))) (syntmp-chi-void-159)) (else (syntmp-chi-void-159))))) syntmp-tmp-766) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any each-any any . each-any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (define-syntax-form))) (let ((syntmp-n-775 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750)) (syntmp-r-776 (syntmp-macros-only-env-111 syntmp-r-731))) (let ((syntmp-t-777 syntmp-m-733)) (if (memv syntmp-t-777 (quote (c))) (if (memq (quote compile) syntmp-esew-734) (let ((syntmp-e-778 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-778) (if (memq (quote load) syntmp-esew-734) syntmp-e-778 (syntmp-chi-void-159)))) (if (memq (quote load) syntmp-esew-734) (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)) (syntmp-chi-void-159))) (if (memv syntmp-t-777 (quote (c&e))) (let ((syntmp-e-779 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-779) syntmp-e-779)) (begin (if (memq (quote eval) syntmp-esew-734) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (syntmp-chi-void-159)))))) (if (memv syntmp-t-752 (quote (define-form))) (let ((syntmp-n-780 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750))) (let ((syntmp-type-781 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-780 syntmp-r-731)))) (let ((syntmp-t-782 syntmp-type-781)) (if (memv syntmp-t-782 (quote (global))) (let ((syntmp-x-783 (syntmp-build-annotated-94 syntmp-s-751 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750))))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-783)) syntmp-x-783)) (if (memv syntmp-t-782 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "identifier out of context") (if (eq? syntmp-type-781 (quote external-macro)) (let ((syntmp-x-784 (syntmp-build-annotated-94 syntmp-s-751 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750))))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-784)) syntmp-x-784)) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "cannot define keyword at top level"))))))) (let ((syntmp-x-785 (syntmp-chi-expr-152 syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-785)) syntmp-x-785)))))))))))) (syntmp-syntax-type-149 (lambda (syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-rib-790) (cond ((symbol? syntmp-e-786) (let ((syntmp-n-791 (syntmp-id-var-name-137 syntmp-e-786 syntmp-w-788))) (let ((syntmp-b-792 (syntmp-lookup-112 syntmp-n-791 syntmp-r-787))) (let ((syntmp-type-793 (syntmp-binding-type-107 syntmp-b-792))) (let ((syntmp-t-794 syntmp-type-793)) (if (memv syntmp-t-794 (quote (lexical))) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (global))) (values syntmp-type-793 syntmp-n-791 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789))))))))) ((pair? syntmp-e-786) (let ((syntmp-first-795 (car syntmp-e-786))) (if (syntmp-id?-115 syntmp-first-795) (let ((syntmp-n-796 (syntmp-id-var-name-137 syntmp-first-795 syntmp-w-788))) (let ((syntmp-b-797 (syntmp-lookup-112 syntmp-n-796 syntmp-r-787))) (let ((syntmp-type-798 (syntmp-binding-type-107 syntmp-b-797))) (let ((syntmp-t-799 syntmp-type-798)) (if (memv syntmp-t-799 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (global))) (values (quote global-call) syntmp-n-796 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (if (memv syntmp-t-799 (quote (core external-macro))) (values syntmp-type-798 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (begin))) (values (quote begin-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (define))) ((lambda (syntmp-tmp-800) ((lambda (syntmp-tmp-801) (if (if syntmp-tmp-801 (apply (lambda (syntmp-_-802 syntmp-name-803 syntmp-val-804) (syntmp-id?-115 syntmp-name-803)) syntmp-tmp-801) #f) (apply (lambda (syntmp-_-805 syntmp-name-806 syntmp-val-807) (values (quote define-form) syntmp-name-806 syntmp-val-807 syntmp-w-788 syntmp-s-789)) syntmp-tmp-801) ((lambda (syntmp-tmp-808) (if (if syntmp-tmp-808 (apply (lambda (syntmp-_-809 syntmp-name-810 syntmp-args-811 syntmp-e1-812 syntmp-e2-813) (and (syntmp-id?-115 syntmp-name-810) (syntmp-valid-bound-ids?-140 (syntmp-lambda-var-list-164 syntmp-args-811)))) syntmp-tmp-808) #f) (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-args-816 syntmp-e1-817 syntmp-e2-818) (values (quote define-form) (syntmp-wrap-143 syntmp-name-815 syntmp-w-788) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-143 (cons syntmp-args-816 (cons syntmp-e1-817 syntmp-e2-818)) syntmp-w-788)) (quote (())) syntmp-s-789)) syntmp-tmp-808) ((lambda (syntmp-tmp-820) (if (if syntmp-tmp-820 (apply (lambda (syntmp-_-821 syntmp-name-822) (syntmp-id?-115 syntmp-name-822)) syntmp-tmp-820) #f) (apply (lambda (syntmp-_-823 syntmp-name-824) (values (quote define-form) (syntmp-wrap-143 syntmp-name-824 syntmp-w-788) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-789)) syntmp-tmp-820) (syntax-error syntmp-tmp-800))) (syntax-dispatch syntmp-tmp-800 (quote (any any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any any any))))) syntmp-e-786) (if (memv syntmp-t-799 (quote (define-syntax))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-115 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-syntax-form) syntmp-name-831 syntmp-val-832 syntmp-w-788 syntmp-s-789)) syntmp-tmp-826) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-786) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))))))))))))) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))) ((syntmp-syntax-object?-101 syntmp-e-786) (syntmp-syntax-type-149 (syntmp-syntax-object-expression-102 syntmp-e-786) syntmp-r-787 (syntmp-join-wraps-134 syntmp-w-788 (syntmp-syntax-object-wrap-103 syntmp-e-786)) #f syntmp-rib-790)) ((annotation? syntmp-e-786) (syntmp-syntax-type-149 (annotation-expression syntmp-e-786) syntmp-r-787 syntmp-w-788 (annotation-source syntmp-e-786) syntmp-rib-790)) ((self-evaluating? syntmp-e-786) (values (quote constant) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)) (else (values (quote other) #f syntmp-e-786 syntmp-w-788 syntmp-s-789))))) (syntmp-chi-when-list-148 (lambda (syntmp-e-833 syntmp-when-list-834 syntmp-w-835) (let syntmp-f-836 ((syntmp-when-list-837 syntmp-when-list-834) (syntmp-situations-838 (quote ()))) (if (null? syntmp-when-list-837) syntmp-situations-838 (syntmp-f-836 (cdr syntmp-when-list-837) (cons (let ((syntmp-x-839 (car syntmp-when-list-837))) (cond ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-143 syntmp-x-839 syntmp-w-835) "invalid eval-when situation")))) syntmp-situations-838)))))) (syntmp-chi-install-global-147 (lambda (syntmp-name-851 syntmp-e-852) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-851) syntmp-e-852)))) (syntmp-chi-top-sequence-146 (lambda (syntmp-body-853 syntmp-r-854 syntmp-w-855 syntmp-s-856 syntmp-m-857 syntmp-esew-858) (syntmp-build-sequence-96 syntmp-s-856 (let syntmp-dobody-859 ((syntmp-body-860 syntmp-body-853) (syntmp-r-861 syntmp-r-854) (syntmp-w-862 syntmp-w-855) (syntmp-m-863 syntmp-m-857) (syntmp-esew-864 syntmp-esew-858)) (if (null? syntmp-body-860) (quote ()) (let ((syntmp-first-865 (syntmp-chi-top-150 (car syntmp-body-860) syntmp-r-861 syntmp-w-862 syntmp-m-863 syntmp-esew-864))) (cons syntmp-first-865 (syntmp-dobody-859 (cdr syntmp-body-860) syntmp-r-861 syntmp-w-862 syntmp-m-863 syntmp-esew-864)))))))) (syntmp-chi-sequence-145 (lambda (syntmp-body-866 syntmp-r-867 syntmp-w-868 syntmp-s-869) (syntmp-build-sequence-96 syntmp-s-869 (let syntmp-dobody-870 ((syntmp-body-871 syntmp-body-866) (syntmp-r-872 syntmp-r-867) (syntmp-w-873 syntmp-w-868)) (if (null? syntmp-body-871) (quote ()) (let ((syntmp-first-874 (syntmp-chi-151 (car syntmp-body-871) syntmp-r-872 syntmp-w-873))) (cons syntmp-first-874 (syntmp-dobody-870 (cdr syntmp-body-871) syntmp-r-872 syntmp-w-873)))))))) (syntmp-source-wrap-144 (lambda (syntmp-x-875 syntmp-w-876 syntmp-s-877) (syntmp-wrap-143 (if syntmp-s-877 (make-annotation syntmp-x-875 syntmp-s-877 #f) syntmp-x-875) syntmp-w-876))) (syntmp-wrap-143 (lambda (syntmp-x-878 syntmp-w-879) (cond ((and (null? (syntmp-wrap-marks-118 syntmp-w-879)) (null? (syntmp-wrap-subst-119 syntmp-w-879))) syntmp-x-878) ((syntmp-syntax-object?-101 syntmp-x-878) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-878) (syntmp-join-wraps-134 syntmp-w-879 (syntmp-syntax-object-wrap-103 syntmp-x-878)))) ((null? syntmp-x-878) syntmp-x-878) (else (syntmp-make-syntax-object-100 syntmp-x-878 syntmp-w-879))))) (syntmp-bound-id-member?-142 (lambda (syntmp-x-880 syntmp-list-881) (and (not (null? syntmp-list-881)) (or (syntmp-bound-id=?-139 syntmp-x-880 (car syntmp-list-881)) (syntmp-bound-id-member?-142 syntmp-x-880 (cdr syntmp-list-881)))))) (syntmp-distinct-bound-ids?-141 (lambda (syntmp-ids-882) (let syntmp-distinct?-883 ((syntmp-ids-884 syntmp-ids-882)) (or (null? syntmp-ids-884) (and (not (syntmp-bound-id-member?-142 (car syntmp-ids-884) (cdr syntmp-ids-884))) (syntmp-distinct?-883 (cdr syntmp-ids-884))))))) (syntmp-valid-bound-ids?-140 (lambda (syntmp-ids-885) (and (let syntmp-all-ids?-886 ((syntmp-ids-887 syntmp-ids-885)) (or (null? syntmp-ids-887) (and (syntmp-id?-115 (car syntmp-ids-887)) (syntmp-all-ids?-886 (cdr syntmp-ids-887))))) (syntmp-distinct-bound-ids?-141 syntmp-ids-885)))) (syntmp-bound-id=?-139 (lambda (syntmp-i-888 syntmp-j-889) (if (and (syntmp-syntax-object?-101 syntmp-i-888) (syntmp-syntax-object?-101 syntmp-j-889)) (and (eq? (let ((syntmp-e-890 (syntmp-syntax-object-expression-102 syntmp-i-888))) (if (annotation? syntmp-e-890) (annotation-expression syntmp-e-890) syntmp-e-890)) (let ((syntmp-e-891 (syntmp-syntax-object-expression-102 syntmp-j-889))) (if (annotation? syntmp-e-891) (annotation-expression syntmp-e-891) syntmp-e-891))) (syntmp-same-marks?-136 (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-i-888)) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-j-889)))) (eq? (let ((syntmp-e-892 syntmp-i-888)) (if (annotation? syntmp-e-892) (annotation-expression syntmp-e-892) syntmp-e-892)) (let ((syntmp-e-893 syntmp-j-889)) (if (annotation? syntmp-e-893) (annotation-expression syntmp-e-893) syntmp-e-893)))))) (syntmp-free-id=?-138 (lambda (syntmp-i-894 syntmp-j-895) (and (eq? (let ((syntmp-x-896 syntmp-i-894)) (let ((syntmp-e-897 (if (syntmp-syntax-object?-101 syntmp-x-896) (syntmp-syntax-object-expression-102 syntmp-x-896) syntmp-x-896))) (if (annotation? syntmp-e-897) (annotation-expression syntmp-e-897) syntmp-e-897))) (let ((syntmp-x-898 syntmp-j-895)) (let ((syntmp-e-899 (if (syntmp-syntax-object?-101 syntmp-x-898) (syntmp-syntax-object-expression-102 syntmp-x-898) syntmp-x-898))) (if (annotation? syntmp-e-899) (annotation-expression syntmp-e-899) syntmp-e-899)))) (eq? (syntmp-id-var-name-137 syntmp-i-894 (quote (()))) (syntmp-id-var-name-137 syntmp-j-895 (quote (()))))))) (syntmp-id-var-name-137 (lambda (syntmp-id-900 syntmp-w-901) (letrec ((syntmp-search-vector-rib-904 (lambda (syntmp-sym-915 syntmp-subst-916 syntmp-marks-917 syntmp-symnames-918 syntmp-ribcage-919) (let ((syntmp-n-920 (vector-length syntmp-symnames-918))) (let syntmp-f-921 ((syntmp-i-922 0)) (cond ((syntmp-fx=-87 syntmp-i-922 syntmp-n-920) (syntmp-search-902 syntmp-sym-915 (cdr syntmp-subst-916) syntmp-marks-917)) ((and (eq? (vector-ref syntmp-symnames-918 syntmp-i-922) syntmp-sym-915) (syntmp-same-marks?-136 syntmp-marks-917 (vector-ref (syntmp-ribcage-marks-125 syntmp-ribcage-919) syntmp-i-922))) (values (vector-ref (syntmp-ribcage-labels-126 syntmp-ribcage-919) syntmp-i-922) syntmp-marks-917)) (else (syntmp-f-921 (syntmp-fx+-85 syntmp-i-922 1)))))))) (syntmp-search-list-rib-903 (lambda (syntmp-sym-923 syntmp-subst-924 syntmp-marks-925 syntmp-symnames-926 syntmp-ribcage-927) (let syntmp-f-928 ((syntmp-symnames-929 syntmp-symnames-926) (syntmp-i-930 0)) (cond ((null? syntmp-symnames-929) (syntmp-search-902 syntmp-sym-923 (cdr syntmp-subst-924) syntmp-marks-925)) ((and (eq? (car syntmp-symnames-929) syntmp-sym-923) (syntmp-same-marks?-136 syntmp-marks-925 (list-ref (syntmp-ribcage-marks-125 syntmp-ribcage-927) syntmp-i-930))) (values (list-ref (syntmp-ribcage-labels-126 syntmp-ribcage-927) syntmp-i-930) syntmp-marks-925)) (else (syntmp-f-928 (cdr syntmp-symnames-929) (syntmp-fx+-85 syntmp-i-930 1))))))) (syntmp-search-902 (lambda (syntmp-sym-931 syntmp-subst-932 syntmp-marks-933) (if (null? syntmp-subst-932) (values #f syntmp-marks-933) (let ((syntmp-fst-934 (car syntmp-subst-932))) (if (eq? syntmp-fst-934 (quote shift)) (syntmp-search-902 syntmp-sym-931 (cdr syntmp-subst-932) (cdr syntmp-marks-933)) (let ((syntmp-symnames-935 (syntmp-ribcage-symnames-124 syntmp-fst-934))) (if (vector? syntmp-symnames-935) (syntmp-search-vector-rib-904 syntmp-sym-931 syntmp-subst-932 syntmp-marks-933 syntmp-symnames-935 syntmp-fst-934) (syntmp-search-list-rib-903 syntmp-sym-931 syntmp-subst-932 syntmp-marks-933 syntmp-symnames-935 syntmp-fst-934))))))))) (cond ((symbol? syntmp-id-900) (or (call-with-values (lambda () (syntmp-search-902 syntmp-id-900 (syntmp-wrap-subst-119 syntmp-w-901) (syntmp-wrap-marks-118 syntmp-w-901))) (lambda (syntmp-x-937 . syntmp-ignore-936) syntmp-x-937)) syntmp-id-900)) ((syntmp-syntax-object?-101 syntmp-id-900) (let ((syntmp-id-938 (let ((syntmp-e-940 (syntmp-syntax-object-expression-102 syntmp-id-900))) (if (annotation? syntmp-e-940) (annotation-expression syntmp-e-940) syntmp-e-940))) (syntmp-w1-939 (syntmp-syntax-object-wrap-103 syntmp-id-900))) (let ((syntmp-marks-941 (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-901) (syntmp-wrap-marks-118 syntmp-w1-939)))) (call-with-values (lambda () (syntmp-search-902 syntmp-id-938 (syntmp-wrap-subst-119 syntmp-w-901) syntmp-marks-941)) (lambda (syntmp-new-id-942 syntmp-marks-943) (or syntmp-new-id-942 (call-with-values (lambda () (syntmp-search-902 syntmp-id-938 (syntmp-wrap-subst-119 syntmp-w1-939) syntmp-marks-943)) (lambda (syntmp-x-945 . syntmp-ignore-944) syntmp-x-945)) syntmp-id-938)))))) ((annotation? syntmp-id-900) (let ((syntmp-id-946 (let ((syntmp-e-947 syntmp-id-900)) (if (annotation? syntmp-e-947) (annotation-expression syntmp-e-947) syntmp-e-947)))) (or (call-with-values (lambda () (syntmp-search-902 syntmp-id-946 (syntmp-wrap-subst-119 syntmp-w-901) (syntmp-wrap-marks-118 syntmp-w-901))) (lambda (syntmp-x-949 . syntmp-ignore-948) syntmp-x-949)) syntmp-id-946))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-900)))))) (syntmp-same-marks?-136 (lambda (syntmp-x-950 syntmp-y-951) (or (eq? syntmp-x-950 syntmp-y-951) (and (not (null? syntmp-x-950)) (not (null? syntmp-y-951)) (eq? (car syntmp-x-950) (car syntmp-y-951)) (syntmp-same-marks?-136 (cdr syntmp-x-950) (cdr syntmp-y-951)))))) (syntmp-join-marks-135 (lambda (syntmp-m1-952 syntmp-m2-953) (syntmp-smart-append-133 syntmp-m1-952 syntmp-m2-953))) (syntmp-join-wraps-134 (lambda (syntmp-w1-954 syntmp-w2-955) (let ((syntmp-m1-956 (syntmp-wrap-marks-118 syntmp-w1-954)) (syntmp-s1-957 (syntmp-wrap-subst-119 syntmp-w1-954))) (if (null? syntmp-m1-956) (if (null? syntmp-s1-957) syntmp-w2-955 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w2-955) (syntmp-smart-append-133 syntmp-s1-957 (syntmp-wrap-subst-119 syntmp-w2-955)))) (syntmp-make-wrap-117 (syntmp-smart-append-133 syntmp-m1-956 (syntmp-wrap-marks-118 syntmp-w2-955)) (syntmp-smart-append-133 syntmp-s1-957 (syntmp-wrap-subst-119 syntmp-w2-955))))))) (syntmp-smart-append-133 (lambda (syntmp-m1-958 syntmp-m2-959) (if (null? syntmp-m2-959) syntmp-m1-958 (append syntmp-m1-958 syntmp-m2-959)))) (syntmp-make-binding-wrap-132 (lambda (syntmp-ids-960 syntmp-labels-961 syntmp-w-962) (if (null? syntmp-ids-960) syntmp-w-962 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-962) (cons (let ((syntmp-labelvec-963 (list->vector syntmp-labels-961))) (let ((syntmp-n-964 (vector-length syntmp-labelvec-963))) (let ((syntmp-symnamevec-965 (make-vector syntmp-n-964)) (syntmp-marksvec-966 (make-vector syntmp-n-964))) (begin (let syntmp-f-967 ((syntmp-ids-968 syntmp-ids-960) (syntmp-i-969 0)) (if (not (null? syntmp-ids-968)) (call-with-values (lambda () (syntmp-id-sym-name&marks-116 (car syntmp-ids-968) syntmp-w-962)) (lambda (syntmp-symname-970 syntmp-marks-971) (begin (vector-set! syntmp-symnamevec-965 syntmp-i-969 syntmp-symname-970) (vector-set! syntmp-marksvec-966 syntmp-i-969 syntmp-marks-971) (syntmp-f-967 (cdr syntmp-ids-968) (syntmp-fx+-85 syntmp-i-969 1))))))) (syntmp-make-ribcage-122 syntmp-symnamevec-965 syntmp-marksvec-966 syntmp-labelvec-963))))) (syntmp-wrap-subst-119 syntmp-w-962)))))) (syntmp-extend-ribcage!-131 (lambda (syntmp-ribcage-972 syntmp-id-973 syntmp-label-974) (begin (syntmp-set-ribcage-symnames!-127 syntmp-ribcage-972 (cons (let ((syntmp-e-975 (syntmp-syntax-object-expression-102 syntmp-id-973))) (if (annotation? syntmp-e-975) (annotation-expression syntmp-e-975) syntmp-e-975)) (syntmp-ribcage-symnames-124 syntmp-ribcage-972))) (syntmp-set-ribcage-marks!-128 syntmp-ribcage-972 (cons (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-id-973)) (syntmp-ribcage-marks-125 syntmp-ribcage-972))) (syntmp-set-ribcage-labels!-129 syntmp-ribcage-972 (cons syntmp-label-974 (syntmp-ribcage-labels-126 syntmp-ribcage-972)))))) (syntmp-anti-mark-130 (lambda (syntmp-w-976) (syntmp-make-wrap-117 (cons #f (syntmp-wrap-marks-118 syntmp-w-976)) (cons (quote shift) (syntmp-wrap-subst-119 syntmp-w-976))))) (syntmp-set-ribcage-labels!-129 (lambda (syntmp-x-977 syntmp-update-978) (vector-set! syntmp-x-977 3 syntmp-update-978))) (syntmp-set-ribcage-marks!-128 (lambda (syntmp-x-979 syntmp-update-980) (vector-set! syntmp-x-979 2 syntmp-update-980))) (syntmp-set-ribcage-symnames!-127 (lambda (syntmp-x-981 syntmp-update-982) (vector-set! syntmp-x-981 1 syntmp-update-982))) (syntmp-ribcage-labels-126 (lambda (syntmp-x-983) (vector-ref syntmp-x-983 3))) (syntmp-ribcage-marks-125 (lambda (syntmp-x-984) (vector-ref syntmp-x-984 2))) (syntmp-ribcage-symnames-124 (lambda (syntmp-x-985) (vector-ref syntmp-x-985 1))) (syntmp-ribcage?-123 (lambda (syntmp-x-986) (and (vector? syntmp-x-986) (= (vector-length syntmp-x-986) 4) (eq? (vector-ref syntmp-x-986 0) (quote ribcage))))) (syntmp-make-ribcage-122 (lambda (syntmp-symnames-987 syntmp-marks-988 syntmp-labels-989) (vector (quote ribcage) syntmp-symnames-987 syntmp-marks-988 syntmp-labels-989))) (syntmp-gen-labels-121 (lambda (syntmp-ls-990) (if (null? syntmp-ls-990) (quote ()) (cons (syntmp-gen-label-120) (syntmp-gen-labels-121 (cdr syntmp-ls-990)))))) (syntmp-gen-label-120 (lambda () (string #\i))) (syntmp-wrap-subst-119 cdr) (syntmp-wrap-marks-118 car) (syntmp-make-wrap-117 cons) (syntmp-id-sym-name&marks-116 (lambda (syntmp-x-991 syntmp-w-992) (if (syntmp-syntax-object?-101 syntmp-x-991) (values (let ((syntmp-e-993 (syntmp-syntax-object-expression-102 syntmp-x-991))) (if (annotation? syntmp-e-993) (annotation-expression syntmp-e-993) syntmp-e-993)) (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-992) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-x-991)))) (values (let ((syntmp-e-994 syntmp-x-991)) (if (annotation? syntmp-e-994) (annotation-expression syntmp-e-994) syntmp-e-994)) (syntmp-wrap-marks-118 syntmp-w-992))))) (syntmp-id?-115 (lambda (syntmp-x-995) (cond ((symbol? syntmp-x-995) #t) ((syntmp-syntax-object?-101 syntmp-x-995) (symbol? (let ((syntmp-e-996 (syntmp-syntax-object-expression-102 syntmp-x-995))) (if (annotation? syntmp-e-996) (annotation-expression syntmp-e-996) syntmp-e-996)))) ((annotation? syntmp-x-995) (symbol? (annotation-expression syntmp-x-995))) (else #f)))) (syntmp-nonsymbol-id?-114 (lambda (syntmp-x-997) (and (syntmp-syntax-object?-101 syntmp-x-997) (symbol? (let ((syntmp-e-998 (syntmp-syntax-object-expression-102 syntmp-x-997))) (if (annotation? syntmp-e-998) (annotation-expression syntmp-e-998) syntmp-e-998)))))) (syntmp-global-extend-113 (lambda (syntmp-type-999 syntmp-sym-1000 syntmp-val-1001) (syntmp-put-global-definition-hook-92 syntmp-sym-1000 (cons syntmp-type-999 syntmp-val-1001)))) (syntmp-lookup-112 (lambda (syntmp-x-1002 syntmp-r-1003) (cond ((assq syntmp-x-1002 syntmp-r-1003) => cdr) ((symbol? syntmp-x-1002) (or (syntmp-get-global-definition-hook-93 syntmp-x-1002) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-111 (lambda (syntmp-r-1004) (if (null? syntmp-r-1004) (quote ()) (let ((syntmp-a-1005 (car syntmp-r-1004))) (if (eq? (cadr syntmp-a-1005) (quote macro)) (cons syntmp-a-1005 (syntmp-macros-only-env-111 (cdr syntmp-r-1004))) (syntmp-macros-only-env-111 (cdr syntmp-r-1004))))))) (syntmp-extend-var-env-110 (lambda (syntmp-labels-1006 syntmp-vars-1007 syntmp-r-1008) (if (null? syntmp-labels-1006) syntmp-r-1008 (syntmp-extend-var-env-110 (cdr syntmp-labels-1006) (cdr syntmp-vars-1007) (cons (cons (car syntmp-labels-1006) (cons (quote lexical) (car syntmp-vars-1007))) syntmp-r-1008))))) (syntmp-extend-env-109 (lambda (syntmp-labels-1009 syntmp-bindings-1010 syntmp-r-1011) (if (null? syntmp-labels-1009) syntmp-r-1011 (syntmp-extend-env-109 (cdr syntmp-labels-1009) (cdr syntmp-bindings-1010) (cons (cons (car syntmp-labels-1009) (car syntmp-bindings-1010)) syntmp-r-1011))))) (syntmp-binding-value-108 cdr) (syntmp-binding-type-107 car) (syntmp-source-annotation-106 (lambda (syntmp-x-1012) (cond ((annotation? syntmp-x-1012) (annotation-source syntmp-x-1012)) ((syntmp-syntax-object?-101 syntmp-x-1012) (syntmp-source-annotation-106 (syntmp-syntax-object-expression-102 syntmp-x-1012))) (else #f)))) (syntmp-set-syntax-object-wrap!-105 (lambda (syntmp-x-1013 syntmp-update-1014) (vector-set! syntmp-x-1013 2 syntmp-update-1014))) (syntmp-set-syntax-object-expression!-104 (lambda (syntmp-x-1015 syntmp-update-1016) (vector-set! syntmp-x-1015 1 syntmp-update-1016))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 3) (eq? (vector-ref syntmp-x-1019 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1020 syntmp-wrap-1021) (vector (quote syntax-object) syntmp-expression-1020 syntmp-wrap-1021))) (syntmp-build-letrec-99 (lambda (syntmp-src-1022 syntmp-vars-1023 syntmp-val-exps-1024 syntmp-body-exp-1025) (if (null? syntmp-vars-1023) (syntmp-build-annotated-94 syntmp-src-1022 syntmp-body-exp-1025) (syntmp-build-annotated-94 syntmp-src-1022 (list (quote letrec) (map list syntmp-vars-1023 syntmp-val-exps-1024) syntmp-body-exp-1025))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1026 syntmp-vars-1027 syntmp-val-exps-1028 syntmp-body-exp-1029) (if (null? syntmp-vars-1027) (syntmp-build-annotated-94 syntmp-src-1026 syntmp-body-exp-1029) (syntmp-build-annotated-94 syntmp-src-1026 (list (quote let) (car syntmp-vars-1027) (map list (cdr syntmp-vars-1027) syntmp-val-exps-1028) syntmp-body-exp-1029))))) (syntmp-build-let-97 (lambda (syntmp-src-1030 syntmp-vars-1031 syntmp-val-exps-1032 syntmp-body-exp-1033) (if (null? syntmp-vars-1031) (syntmp-build-annotated-94 syntmp-src-1030 syntmp-body-exp-1033) (syntmp-build-annotated-94 syntmp-src-1030 (list (quote let) (map list syntmp-vars-1031 syntmp-val-exps-1032) syntmp-body-exp-1033))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1034 syntmp-exps-1035) (if (null? (cdr syntmp-exps-1035)) (syntmp-build-annotated-94 syntmp-src-1034 (car syntmp-exps-1035)) (syntmp-build-annotated-94 syntmp-src-1034 (cons (quote begin) syntmp-exps-1035))))) (syntmp-build-data-95 (lambda (syntmp-src-1036 syntmp-exp-1037) (if (and (self-evaluating? syntmp-exp-1037) (not (vector? syntmp-exp-1037))) (syntmp-build-annotated-94 syntmp-src-1036 syntmp-exp-1037) (syntmp-build-annotated-94 syntmp-src-1036 (list (quote quote) syntmp-exp-1037))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1038 syntmp-exp-1039) (if (and syntmp-src-1038 (not (annotation? syntmp-exp-1039))) (make-annotation syntmp-exp-1039 syntmp-src-1038 #t) syntmp-exp-1039))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1040) (getprop syntmp-symbol-1040 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1041 syntmp-binding-1042) (putprop syntmp-symbol-1041 (quote *sc-expander*) syntmp-binding-1042))) (syntmp-error-hook-91 (lambda (syntmp-who-1043 syntmp-why-1044 syntmp-what-1045) (error syntmp-who-1043 "~a ~s" syntmp-why-1044 syntmp-what-1045))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1046) (eval (list syntmp-noexpand-84 syntmp-x-1046) (interaction-environment)))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1047) (eval (list syntmp-noexpand-84 syntmp-x-1047) (interaction-environment)))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-113 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-113 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-113 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1048 syntmp-r-1049 syntmp-w-1050 syntmp-s-1051) ((lambda (syntmp-tmp-1052) ((lambda (syntmp-tmp-1053) (if (if syntmp-tmp-1053 (apply (lambda (syntmp-_-1054 syntmp-var-1055 syntmp-val-1056 syntmp-e1-1057 syntmp-e2-1058) (syntmp-valid-bound-ids?-140 syntmp-var-1055)) syntmp-tmp-1053) #f) (apply (lambda (syntmp-_-1060 syntmp-var-1061 syntmp-val-1062 syntmp-e1-1063 syntmp-e2-1064) (let ((syntmp-names-1065 (map (lambda (syntmp-x-1066) (syntmp-id-var-name-137 syntmp-x-1066 syntmp-w-1050)) syntmp-var-1061))) (begin (for-each (lambda (syntmp-id-1068 syntmp-n-1069) (let ((syntmp-t-1070 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-1069 syntmp-r-1049)))) (if (memv syntmp-t-1070 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-id-1068 syntmp-w-1050 syntmp-s-1051) "identifier out of context")))) syntmp-var-1061 syntmp-names-1065) (syntmp-chi-body-155 (cons syntmp-e1-1063 syntmp-e2-1064) (syntmp-source-wrap-144 syntmp-e-1048 syntmp-w-1050 syntmp-s-1051) (syntmp-extend-env-109 syntmp-names-1065 (let ((syntmp-trans-r-1073 (syntmp-macros-only-env-111 syntmp-r-1049))) (map (lambda (syntmp-x-1074) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-1074 syntmp-trans-r-1073 syntmp-w-1050)))) syntmp-val-1062)) syntmp-r-1049) syntmp-w-1050)))) syntmp-tmp-1053) ((lambda (syntmp-_-1076) (syntax-error (syntmp-source-wrap-144 syntmp-e-1048 syntmp-w-1050 syntmp-s-1051))) syntmp-tmp-1052))) (syntax-dispatch syntmp-tmp-1052 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1048))) (syntmp-global-extend-113 (quote core) (quote quote) (lambda (syntmp-e-1077 syntmp-r-1078 syntmp-w-1079 syntmp-s-1080) ((lambda (syntmp-tmp-1081) ((lambda (syntmp-tmp-1082) (if syntmp-tmp-1082 (apply (lambda (syntmp-_-1083 syntmp-e-1084) (syntmp-build-data-95 syntmp-s-1080 (syntmp-strip-162 syntmp-e-1084 syntmp-w-1079))) syntmp-tmp-1082) ((lambda (syntmp-_-1085) (syntax-error (syntmp-source-wrap-144 syntmp-e-1077 syntmp-w-1079 syntmp-s-1080))) syntmp-tmp-1081))) (syntax-dispatch syntmp-tmp-1081 (quote (any any))))) syntmp-e-1077))) (syntmp-global-extend-113 (quote core) (quote syntax) (letrec ((syntmp-regen-1093 (lambda (syntmp-x-1094) (let ((syntmp-t-1095 (car syntmp-x-1094))) (if (memv syntmp-t-1095 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1094)) (if (memv syntmp-t-1095 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1094)) (if (memv syntmp-t-1095 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1094)) (if (memv syntmp-t-1095 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1094) (syntmp-regen-1093 (caddr syntmp-x-1094)))) (if (memv syntmp-t-1095 (quote (map))) (let ((syntmp-ls-1096 (map syntmp-regen-1093 (cdr syntmp-x-1094)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1096) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1096))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1094)) (map syntmp-regen-1093 (cdr syntmp-x-1094)))))))))))) (syntmp-gen-vector-1092 (lambda (syntmp-x-1097) (cond ((eq? (car syntmp-x-1097) (quote list)) (cons (quote vector) (cdr syntmp-x-1097))) ((eq? (car syntmp-x-1097) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1097)))) (else (list (quote list->vector) syntmp-x-1097))))) (syntmp-gen-append-1091 (lambda (syntmp-x-1098 syntmp-y-1099) (if (equal? syntmp-y-1099 (quote (quote ()))) syntmp-x-1098 (list (quote append) syntmp-x-1098 syntmp-y-1099)))) (syntmp-gen-cons-1090 (lambda (syntmp-x-1100 syntmp-y-1101) (let ((syntmp-t-1102 (car syntmp-y-1101))) (if (memv syntmp-t-1102 (quote (quote))) (if (eq? (car syntmp-x-1100) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1100) (cadr syntmp-y-1101))) (if (eq? (cadr syntmp-y-1101) (quote ())) (list (quote list) syntmp-x-1100) (list (quote cons) syntmp-x-1100 syntmp-y-1101))) (if (memv syntmp-t-1102 (quote (list))) (cons (quote list) (cons syntmp-x-1100 (cdr syntmp-y-1101))) (list (quote cons) syntmp-x-1100 syntmp-y-1101)))))) (syntmp-gen-map-1089 (lambda (syntmp-e-1103 syntmp-map-env-1104) (let ((syntmp-formals-1105 (map cdr syntmp-map-env-1104)) (syntmp-actuals-1106 (map (lambda (syntmp-x-1107) (list (quote ref) (car syntmp-x-1107))) syntmp-map-env-1104))) (cond ((eq? (car syntmp-e-1103) (quote ref)) (car syntmp-actuals-1106)) ((andmap (lambda (syntmp-x-1108) (and (eq? (car syntmp-x-1108) (quote ref)) (memq (cadr syntmp-x-1108) syntmp-formals-1105))) (cdr syntmp-e-1103)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1103)) (map (let ((syntmp-r-1109 (map cons syntmp-formals-1105 syntmp-actuals-1106))) (lambda (syntmp-x-1110) (cdr (assq (cadr syntmp-x-1110) syntmp-r-1109)))) (cdr syntmp-e-1103))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1105 syntmp-e-1103) syntmp-actuals-1106))))))) (syntmp-gen-mappend-1088 (lambda (syntmp-e-1111 syntmp-map-env-1112) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1089 syntmp-e-1111 syntmp-map-env-1112)))) (syntmp-gen-ref-1087 (lambda (syntmp-src-1113 syntmp-var-1114 syntmp-level-1115 syntmp-maps-1116) (if (syntmp-fx=-87 syntmp-level-1115 0) (values syntmp-var-1114 syntmp-maps-1116) (if (null? syntmp-maps-1116) (syntax-error syntmp-src-1113 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1087 syntmp-src-1113 syntmp-var-1114 (syntmp-fx--86 syntmp-level-1115 1) (cdr syntmp-maps-1116))) (lambda (syntmp-outer-var-1117 syntmp-outer-maps-1118) (let ((syntmp-b-1119 (assq syntmp-outer-var-1117 (car syntmp-maps-1116)))) (if syntmp-b-1119 (values (cdr syntmp-b-1119) syntmp-maps-1116) (let ((syntmp-inner-var-1120 (syntmp-gen-var-163 (quote tmp)))) (values syntmp-inner-var-1120 (cons (cons (cons syntmp-outer-var-1117 syntmp-inner-var-1120) (car syntmp-maps-1116)) syntmp-outer-maps-1118))))))))))) (syntmp-gen-syntax-1086 (lambda (syntmp-src-1121 syntmp-e-1122 syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125) (if (syntmp-id?-115 syntmp-e-1122) (let ((syntmp-label-1126 (syntmp-id-var-name-137 syntmp-e-1122 (quote (()))))) (let ((syntmp-b-1127 (syntmp-lookup-112 syntmp-label-1126 syntmp-r-1123))) (if (eq? (syntmp-binding-type-107 syntmp-b-1127) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1128 (syntmp-binding-value-108 syntmp-b-1127))) (syntmp-gen-ref-1087 syntmp-src-1121 (car syntmp-var.lev-1128) (cdr syntmp-var.lev-1128) syntmp-maps-1124))) (lambda (syntmp-var-1129 syntmp-maps-1130) (values (list (quote ref) syntmp-var-1129) syntmp-maps-1130))) (if (syntmp-ellipsis?-1125 syntmp-e-1122) (syntax-error syntmp-src-1121 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1122) syntmp-maps-1124))))) ((lambda (syntmp-tmp-1131) ((lambda (syntmp-tmp-1132) (if (if syntmp-tmp-1132 (apply (lambda (syntmp-dots-1133 syntmp-e-1134) (syntmp-ellipsis?-1125 syntmp-dots-1133)) syntmp-tmp-1132) #f) (apply (lambda (syntmp-dots-1135 syntmp-e-1136) (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-e-1136 syntmp-r-1123 syntmp-maps-1124 (lambda (syntmp-x-1137) #f))) syntmp-tmp-1132) ((lambda (syntmp-tmp-1138) (if (if syntmp-tmp-1138 (apply (lambda (syntmp-x-1139 syntmp-dots-1140 syntmp-y-1141) (syntmp-ellipsis?-1125 syntmp-dots-1140)) syntmp-tmp-1138) #f) (apply (lambda (syntmp-x-1142 syntmp-dots-1143 syntmp-y-1144) (let syntmp-f-1145 ((syntmp-y-1146 syntmp-y-1144) (syntmp-k-1147 (lambda (syntmp-maps-1148) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-x-1142 syntmp-r-1123 (cons (quote ()) syntmp-maps-1148) syntmp-ellipsis?-1125)) (lambda (syntmp-x-1149 syntmp-maps-1150) (if (null? (car syntmp-maps-1150)) (syntax-error syntmp-src-1121 "extra ellipsis in syntax form") (values (syntmp-gen-map-1089 syntmp-x-1149 (car syntmp-maps-1150)) (cdr syntmp-maps-1150)))))))) ((lambda (syntmp-tmp-1151) ((lambda (syntmp-tmp-1152) (if (if syntmp-tmp-1152 (apply (lambda (syntmp-dots-1153 syntmp-y-1154) (syntmp-ellipsis?-1125 syntmp-dots-1153)) syntmp-tmp-1152) #f) (apply (lambda (syntmp-dots-1155 syntmp-y-1156) (syntmp-f-1145 syntmp-y-1156 (lambda (syntmp-maps-1157) (call-with-values (lambda () (syntmp-k-1147 (cons (quote ()) syntmp-maps-1157))) (lambda (syntmp-x-1158 syntmp-maps-1159) (if (null? (car syntmp-maps-1159)) (syntax-error syntmp-src-1121 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1088 syntmp-x-1158 (car syntmp-maps-1159)) (cdr syntmp-maps-1159)))))))) syntmp-tmp-1152) ((lambda (syntmp-_-1160) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-y-1146 syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125)) (lambda (syntmp-y-1161 syntmp-maps-1162) (call-with-values (lambda () (syntmp-k-1147 syntmp-maps-1162)) (lambda (syntmp-x-1163 syntmp-maps-1164) (values (syntmp-gen-append-1091 syntmp-x-1163 syntmp-y-1161) syntmp-maps-1164)))))) syntmp-tmp-1151))) (syntax-dispatch syntmp-tmp-1151 (quote (any . any))))) syntmp-y-1146))) syntmp-tmp-1138) ((lambda (syntmp-tmp-1165) (if syntmp-tmp-1165 (apply (lambda (syntmp-x-1166 syntmp-y-1167) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-x-1166 syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125)) (lambda (syntmp-x-1168 syntmp-maps-1169) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-y-1167 syntmp-r-1123 syntmp-maps-1169 syntmp-ellipsis?-1125)) (lambda (syntmp-y-1170 syntmp-maps-1171) (values (syntmp-gen-cons-1090 syntmp-x-1168 syntmp-y-1170) syntmp-maps-1171)))))) syntmp-tmp-1165) ((lambda (syntmp-tmp-1172) (if syntmp-tmp-1172 (apply (lambda (syntmp-e1-1173 syntmp-e2-1174) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 (cons syntmp-e1-1173 syntmp-e2-1174) syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125)) (lambda (syntmp-e-1176 syntmp-maps-1177) (values (syntmp-gen-vector-1092 syntmp-e-1176) syntmp-maps-1177)))) syntmp-tmp-1172) ((lambda (syntmp-_-1178) (values (list (quote quote) syntmp-e-1122) syntmp-maps-1124)) syntmp-tmp-1131))) (syntax-dispatch syntmp-tmp-1131 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1131 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1131 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1131 (quote (any any))))) syntmp-e-1122))))) (lambda (syntmp-e-1179 syntmp-r-1180 syntmp-w-1181 syntmp-s-1182) (let ((syntmp-e-1183 (syntmp-source-wrap-144 syntmp-e-1179 syntmp-w-1181 syntmp-s-1182))) ((lambda (syntmp-tmp-1184) ((lambda (syntmp-tmp-1185) (if syntmp-tmp-1185 (apply (lambda (syntmp-_-1186 syntmp-x-1187) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-e-1183 syntmp-x-1187 syntmp-r-1180 (quote ()) syntmp-ellipsis?-160)) (lambda (syntmp-e-1188 syntmp-maps-1189) (syntmp-regen-1093 syntmp-e-1188)))) syntmp-tmp-1185) ((lambda (syntmp-_-1190) (syntax-error syntmp-e-1183)) syntmp-tmp-1184))) (syntax-dispatch syntmp-tmp-1184 (quote (any any))))) syntmp-e-1183))))) (syntmp-global-extend-113 (quote core) (quote lambda) (lambda (syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194) ((lambda (syntmp-tmp-1195) ((lambda (syntmp-tmp-1196) (if syntmp-tmp-1196 (apply (lambda (syntmp-_-1197 syntmp-c-1198) (syntmp-chi-lambda-clause-156 (syntmp-source-wrap-144 syntmp-e-1191 syntmp-w-1193 syntmp-s-1194) syntmp-c-1198 syntmp-r-1192 syntmp-w-1193 (lambda (syntmp-vars-1199 syntmp-body-1200) (syntmp-build-annotated-94 syntmp-s-1194 (list (quote lambda) syntmp-vars-1199 syntmp-body-1200))))) syntmp-tmp-1196) (syntax-error syntmp-tmp-1195))) (syntax-dispatch syntmp-tmp-1195 (quote (any . any))))) syntmp-e-1191))) (syntmp-global-extend-113 (quote core) (quote let) (letrec ((syntmp-chi-let-1201 (lambda (syntmp-e-1202 syntmp-r-1203 syntmp-w-1204 syntmp-s-1205 syntmp-constructor-1206 syntmp-ids-1207 syntmp-vals-1208 syntmp-exps-1209) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1207)) (syntax-error syntmp-e-1202 "duplicate bound variable in") (let ((syntmp-labels-1210 (syntmp-gen-labels-121 syntmp-ids-1207)) (syntmp-new-vars-1211 (map syntmp-gen-var-163 syntmp-ids-1207))) (let ((syntmp-nw-1212 (syntmp-make-binding-wrap-132 syntmp-ids-1207 syntmp-labels-1210 syntmp-w-1204)) (syntmp-nr-1213 (syntmp-extend-var-env-110 syntmp-labels-1210 syntmp-new-vars-1211 syntmp-r-1203))) (syntmp-constructor-1206 syntmp-s-1205 syntmp-new-vars-1211 (map (lambda (syntmp-x-1214) (syntmp-chi-151 syntmp-x-1214 syntmp-r-1203 syntmp-w-1204)) syntmp-vals-1208) (syntmp-chi-body-155 syntmp-exps-1209 (syntmp-source-wrap-144 syntmp-e-1202 syntmp-nw-1212 syntmp-s-1205) syntmp-nr-1213 syntmp-nw-1212)))))))) (lambda (syntmp-e-1215 syntmp-r-1216 syntmp-w-1217 syntmp-s-1218) ((lambda (syntmp-tmp-1219) ((lambda (syntmp-tmp-1220) (if syntmp-tmp-1220 (apply (lambda (syntmp-_-1221 syntmp-id-1222 syntmp-val-1223 syntmp-e1-1224 syntmp-e2-1225) (syntmp-chi-let-1201 syntmp-e-1215 syntmp-r-1216 syntmp-w-1217 syntmp-s-1218 syntmp-build-let-97 syntmp-id-1222 syntmp-val-1223 (cons syntmp-e1-1224 syntmp-e2-1225))) syntmp-tmp-1220) ((lambda (syntmp-tmp-1229) (if (if syntmp-tmp-1229 (apply (lambda (syntmp-_-1230 syntmp-f-1231 syntmp-id-1232 syntmp-val-1233 syntmp-e1-1234 syntmp-e2-1235) (syntmp-id?-115 syntmp-f-1231)) syntmp-tmp-1229) #f) (apply (lambda (syntmp-_-1236 syntmp-f-1237 syntmp-id-1238 syntmp-val-1239 syntmp-e1-1240 syntmp-e2-1241) (syntmp-chi-let-1201 syntmp-e-1215 syntmp-r-1216 syntmp-w-1217 syntmp-s-1218 syntmp-build-named-let-98 (cons syntmp-f-1237 syntmp-id-1238) syntmp-val-1239 (cons syntmp-e1-1240 syntmp-e2-1241))) syntmp-tmp-1229) ((lambda (syntmp-_-1245) (syntax-error (syntmp-source-wrap-144 syntmp-e-1215 syntmp-w-1217 syntmp-s-1218))) syntmp-tmp-1219))) (syntax-dispatch syntmp-tmp-1219 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1219 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1215)))) (syntmp-global-extend-113 (quote core) (quote letrec) (lambda (syntmp-e-1246 syntmp-r-1247 syntmp-w-1248 syntmp-s-1249) ((lambda (syntmp-tmp-1250) ((lambda (syntmp-tmp-1251) (if syntmp-tmp-1251 (apply (lambda (syntmp-_-1252 syntmp-id-1253 syntmp-val-1254 syntmp-e1-1255 syntmp-e2-1256) (let ((syntmp-ids-1257 syntmp-id-1253)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1257)) (syntax-error syntmp-e-1246 "duplicate bound variable in") (let ((syntmp-labels-1259 (syntmp-gen-labels-121 syntmp-ids-1257)) (syntmp-new-vars-1260 (map syntmp-gen-var-163 syntmp-ids-1257))) (let ((syntmp-w-1261 (syntmp-make-binding-wrap-132 syntmp-ids-1257 syntmp-labels-1259 syntmp-w-1248)) (syntmp-r-1262 (syntmp-extend-var-env-110 syntmp-labels-1259 syntmp-new-vars-1260 syntmp-r-1247))) (syntmp-build-letrec-99 syntmp-s-1249 syntmp-new-vars-1260 (map (lambda (syntmp-x-1263) (syntmp-chi-151 syntmp-x-1263 syntmp-r-1262 syntmp-w-1261)) syntmp-val-1254) (syntmp-chi-body-155 (cons syntmp-e1-1255 syntmp-e2-1256) (syntmp-source-wrap-144 syntmp-e-1246 syntmp-w-1261 syntmp-s-1249) syntmp-r-1262 syntmp-w-1261))))))) syntmp-tmp-1251) ((lambda (syntmp-_-1266) (syntax-error (syntmp-source-wrap-144 syntmp-e-1246 syntmp-w-1248 syntmp-s-1249))) syntmp-tmp-1250))) (syntax-dispatch syntmp-tmp-1250 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1246))) (syntmp-global-extend-113 (quote core) (quote set!) (lambda (syntmp-e-1267 syntmp-r-1268 syntmp-w-1269 syntmp-s-1270) ((lambda (syntmp-tmp-1271) ((lambda (syntmp-tmp-1272) (if (if syntmp-tmp-1272 (apply (lambda (syntmp-_-1273 syntmp-id-1274 syntmp-val-1275) (syntmp-id?-115 syntmp-id-1274)) syntmp-tmp-1272) #f) (apply (lambda (syntmp-_-1276 syntmp-id-1277 syntmp-val-1278) (let ((syntmp-val-1279 (syntmp-chi-151 syntmp-val-1278 syntmp-r-1268 syntmp-w-1269)) (syntmp-n-1280 (syntmp-id-var-name-137 syntmp-id-1277 syntmp-w-1269))) (let ((syntmp-b-1281 (syntmp-lookup-112 syntmp-n-1280 syntmp-r-1268))) (let ((syntmp-t-1282 (syntmp-binding-type-107 syntmp-b-1281))) (if (memv syntmp-t-1282 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1270 (list (quote set!) (syntmp-binding-value-108 syntmp-b-1281) syntmp-val-1279)) (if (memv syntmp-t-1282 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1270 (list (quote set!) (make-module-ref #f syntmp-n-1280 #f) syntmp-val-1279)) (if (memv syntmp-t-1282 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-id-1277 syntmp-w-1269) "identifier out of context") (syntax-error (syntmp-source-wrap-144 syntmp-e-1267 syntmp-w-1269 syntmp-s-1270))))))))) syntmp-tmp-1272) ((lambda (syntmp-tmp-1283) (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-getter-1285 syntmp-arg-1286 syntmp-val-1287) (syntmp-build-annotated-94 syntmp-s-1270 (cons (syntmp-chi-151 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1285) syntmp-r-1268 syntmp-w-1269) (map (lambda (syntmp-e-1288) (syntmp-chi-151 syntmp-e-1288 syntmp-r-1268 syntmp-w-1269)) (append syntmp-arg-1286 (list syntmp-val-1287)))))) syntmp-tmp-1283) ((lambda (syntmp-_-1290) (syntax-error (syntmp-source-wrap-144 syntmp-e-1267 syntmp-w-1269 syntmp-s-1270))) syntmp-tmp-1271))) (syntax-dispatch syntmp-tmp-1271 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1271 (quote (any any any))))) syntmp-e-1267))) (syntmp-global-extend-113 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-113 (quote define) (quote define) (quote ())) (syntmp-global-extend-113 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-113 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-113 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1294 (lambda (syntmp-x-1295 syntmp-keys-1296 syntmp-clauses-1297 syntmp-r-1298) (if (null? syntmp-clauses-1297) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1295)) ((lambda (syntmp-tmp-1299) ((lambda (syntmp-tmp-1300) (if syntmp-tmp-1300 (apply (lambda (syntmp-pat-1301 syntmp-exp-1302) (if (and (syntmp-id?-115 syntmp-pat-1301) (andmap (lambda (syntmp-x-1303) (not (syntmp-free-id=?-138 syntmp-pat-1301 syntmp-x-1303))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1296))) (let ((syntmp-labels-1304 (list (syntmp-gen-label-120))) (syntmp-var-1305 (syntmp-gen-var-163 syntmp-pat-1301))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1305) (syntmp-chi-151 syntmp-exp-1302 (syntmp-extend-env-109 syntmp-labels-1304 (list (cons (quote syntax) (cons syntmp-var-1305 0))) syntmp-r-1298) (syntmp-make-binding-wrap-132 (list syntmp-pat-1301) syntmp-labels-1304 (quote (())))))) syntmp-x-1295))) (syntmp-gen-clause-1293 syntmp-x-1295 syntmp-keys-1296 (cdr syntmp-clauses-1297) syntmp-r-1298 syntmp-pat-1301 #t syntmp-exp-1302))) syntmp-tmp-1300) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-pat-1307 syntmp-fender-1308 syntmp-exp-1309) (syntmp-gen-clause-1293 syntmp-x-1295 syntmp-keys-1296 (cdr syntmp-clauses-1297) syntmp-r-1298 syntmp-pat-1307 syntmp-fender-1308 syntmp-exp-1309)) syntmp-tmp-1306) ((lambda (syntmp-_-1310) (syntax-error (car syntmp-clauses-1297) "invalid syntax-case clause")) syntmp-tmp-1299))) (syntax-dispatch syntmp-tmp-1299 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1299 (quote (any any))))) (car syntmp-clauses-1297))))) (syntmp-gen-clause-1293 (lambda (syntmp-x-1311 syntmp-keys-1312 syntmp-clauses-1313 syntmp-r-1314 syntmp-pat-1315 syntmp-fender-1316 syntmp-exp-1317) (call-with-values (lambda () (syntmp-convert-pattern-1291 syntmp-pat-1315 syntmp-keys-1312)) (lambda (syntmp-p-1318 syntmp-pvars-1319) (cond ((not (syntmp-distinct-bound-ids?-141 (map car syntmp-pvars-1319))) (syntax-error syntmp-pat-1315 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1320) (not (syntmp-ellipsis?-160 (car syntmp-x-1320)))) syntmp-pvars-1319)) (syntax-error syntmp-pat-1315 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1321 (syntmp-gen-var-163 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1321) (let ((syntmp-y-1322 (syntmp-build-annotated-94 #f syntmp-y-1321))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1323) ((lambda (syntmp-tmp-1324) (if syntmp-tmp-1324 (apply (lambda () syntmp-y-1322) syntmp-tmp-1324) ((lambda (syntmp-_-1325) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1322 (syntmp-build-dispatch-call-1292 syntmp-pvars-1319 syntmp-fender-1316 syntmp-y-1322 syntmp-r-1314) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1323))) (syntax-dispatch syntmp-tmp-1323 (quote #(atom #t))))) syntmp-fender-1316) (syntmp-build-dispatch-call-1292 syntmp-pvars-1319 syntmp-exp-1317 syntmp-y-1322 syntmp-r-1314) (syntmp-gen-syntax-case-1294 syntmp-x-1311 syntmp-keys-1312 syntmp-clauses-1313 syntmp-r-1314)))))) (if (eq? syntmp-p-1318 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1311)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1311 (syntmp-build-data-95 #f syntmp-p-1318))))))))))))) (syntmp-build-dispatch-call-1292 (lambda (syntmp-pvars-1326 syntmp-exp-1327 syntmp-y-1328 syntmp-r-1329) (let ((syntmp-ids-1330 (map car syntmp-pvars-1326)) (syntmp-levels-1331 (map cdr syntmp-pvars-1326))) (let ((syntmp-labels-1332 (syntmp-gen-labels-121 syntmp-ids-1330)) (syntmp-new-vars-1333 (map syntmp-gen-var-163 syntmp-ids-1330))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1333 (syntmp-chi-151 syntmp-exp-1327 (syntmp-extend-env-109 syntmp-labels-1332 (map (lambda (syntmp-var-1334 syntmp-level-1335) (cons (quote syntax) (cons syntmp-var-1334 syntmp-level-1335))) syntmp-new-vars-1333 (map cdr syntmp-pvars-1326)) syntmp-r-1329) (syntmp-make-binding-wrap-132 syntmp-ids-1330 syntmp-labels-1332 (quote (())))))) syntmp-y-1328)))))) (syntmp-convert-pattern-1291 (lambda (syntmp-pattern-1336 syntmp-keys-1337) (let syntmp-cvt-1338 ((syntmp-p-1339 syntmp-pattern-1336) (syntmp-n-1340 0) (syntmp-ids-1341 (quote ()))) (if (syntmp-id?-115 syntmp-p-1339) (if (syntmp-bound-id-member?-142 syntmp-p-1339 syntmp-keys-1337) (values (vector (quote free-id) syntmp-p-1339) syntmp-ids-1341) (values (quote any) (cons (cons syntmp-p-1339 syntmp-n-1340) syntmp-ids-1341))) ((lambda (syntmp-tmp-1342) ((lambda (syntmp-tmp-1343) (if (if syntmp-tmp-1343 (apply (lambda (syntmp-x-1344 syntmp-dots-1345) (syntmp-ellipsis?-160 syntmp-dots-1345)) syntmp-tmp-1343) #f) (apply (lambda (syntmp-x-1346 syntmp-dots-1347) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-x-1346 (syntmp-fx+-85 syntmp-n-1340 1) syntmp-ids-1341)) (lambda (syntmp-p-1348 syntmp-ids-1349) (values (if (eq? syntmp-p-1348 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1348)) syntmp-ids-1349)))) syntmp-tmp-1343) ((lambda (syntmp-tmp-1350) (if syntmp-tmp-1350 (apply (lambda (syntmp-x-1351 syntmp-y-1352) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-y-1352 syntmp-n-1340 syntmp-ids-1341)) (lambda (syntmp-y-1353 syntmp-ids-1354) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-x-1351 syntmp-n-1340 syntmp-ids-1354)) (lambda (syntmp-x-1355 syntmp-ids-1356) (values (cons syntmp-x-1355 syntmp-y-1353) syntmp-ids-1356)))))) syntmp-tmp-1350) ((lambda (syntmp-tmp-1357) (if syntmp-tmp-1357 (apply (lambda () (values (quote ()) syntmp-ids-1341)) syntmp-tmp-1357) ((lambda (syntmp-tmp-1358) (if syntmp-tmp-1358 (apply (lambda (syntmp-x-1359) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-x-1359 syntmp-n-1340 syntmp-ids-1341)) (lambda (syntmp-p-1361 syntmp-ids-1362) (values (vector (quote vector) syntmp-p-1361) syntmp-ids-1362)))) syntmp-tmp-1358) ((lambda (syntmp-x-1363) (values (vector (quote atom) (syntmp-strip-162 syntmp-p-1339 (quote (())))) syntmp-ids-1341)) syntmp-tmp-1342))) (syntax-dispatch syntmp-tmp-1342 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1342 (quote ()))))) (syntax-dispatch syntmp-tmp-1342 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1342 (quote (any any))))) syntmp-p-1339)))))) (lambda (syntmp-e-1364 syntmp-r-1365 syntmp-w-1366 syntmp-s-1367) (let ((syntmp-e-1368 (syntmp-source-wrap-144 syntmp-e-1364 syntmp-w-1366 syntmp-s-1367))) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-val-1372 syntmp-key-1373 syntmp-m-1374) (if (andmap (lambda (syntmp-x-1375) (and (syntmp-id?-115 syntmp-x-1375) (not (syntmp-ellipsis?-160 syntmp-x-1375)))) syntmp-key-1373) (let ((syntmp-x-1377 (syntmp-gen-var-163 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1367 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1377) (syntmp-gen-syntax-case-1294 (syntmp-build-annotated-94 #f syntmp-x-1377) syntmp-key-1373 syntmp-m-1374 syntmp-r-1365))) (syntmp-chi-151 syntmp-val-1372 syntmp-r-1365 (quote (())))))) (syntax-error syntmp-e-1368 "invalid literals list in"))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any any each-any . each-any))))) syntmp-e-1368))))) (set! sc-expand (let ((syntmp-m-1380 (quote e)) (syntmp-esew-1381 (quote (eval)))) (lambda (syntmp-x-1382) (if (and (pair? syntmp-x-1382) (equal? (car syntmp-x-1382) syntmp-noexpand-84)) (cadr syntmp-x-1382) (syntmp-chi-top-150 syntmp-x-1382 (quote ()) (quote ((top))) syntmp-m-1380 syntmp-esew-1381))))) (set! sc-expand3 (let ((syntmp-m-1383 (quote e)) (syntmp-esew-1384 (quote (eval)))) (lambda (syntmp-x-1386 . syntmp-rest-1385) (if (and (pair? syntmp-x-1386) (equal? (car syntmp-x-1386) syntmp-noexpand-84)) (cadr syntmp-x-1386) (syntmp-chi-top-150 syntmp-x-1386 (quote ()) (quote ((top))) (if (null? syntmp-rest-1385) syntmp-m-1383 (car syntmp-rest-1385)) (if (or (null? syntmp-rest-1385) (null? (cdr syntmp-rest-1385))) syntmp-esew-1384 (cadr syntmp-rest-1385))))))) (set! identifier? (lambda (syntmp-x-1387) (syntmp-nonsymbol-id?-114 syntmp-x-1387))) (set! datum->syntax-object (lambda (syntmp-id-1388 syntmp-datum-1389) (syntmp-make-syntax-object-100 syntmp-datum-1389 (syntmp-syntax-object-wrap-103 syntmp-id-1388)))) (set! syntax-object->datum (lambda (syntmp-x-1390) (syntmp-strip-162 syntmp-x-1390 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1391) (begin (let ((syntmp-x-1392 syntmp-ls-1391)) (if (not (list? syntmp-x-1392)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1392))) (map (lambda (syntmp-x-1393) (syntmp-wrap-143 (gensym) (quote ((top))))) syntmp-ls-1391)))) (set! free-identifier=? (lambda (syntmp-x-1394 syntmp-y-1395) (begin (let ((syntmp-x-1396 syntmp-x-1394)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1396)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1396))) (let ((syntmp-x-1397 syntmp-y-1395)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1397)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1397))) (syntmp-free-id=?-138 syntmp-x-1394 syntmp-y-1395)))) (set! bound-identifier=? (lambda (syntmp-x-1398 syntmp-y-1399) (begin (let ((syntmp-x-1400 syntmp-x-1398)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1400)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1400))) (let ((syntmp-x-1401 syntmp-y-1399)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1401)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1401))) (syntmp-bound-id=?-139 syntmp-x-1398 syntmp-y-1399)))) (set! syntax-error (lambda (syntmp-object-1403 . syntmp-messages-1402) (begin (for-each (lambda (syntmp-x-1404) (let ((syntmp-x-1405 syntmp-x-1404)) (if (not (string? syntmp-x-1405)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1405)))) syntmp-messages-1402) (let ((syntmp-message-1406 (if (null? syntmp-messages-1402) "invalid syntax" (apply string-append syntmp-messages-1402)))) (syntmp-error-hook-91 #f syntmp-message-1406 (syntmp-strip-162 syntmp-object-1403 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1407 syntmp-v-1408) (begin (let ((syntmp-x-1409 syntmp-sym-1407)) (if (not (symbol? syntmp-x-1409)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1409))) (let ((syntmp-x-1410 syntmp-v-1408)) (if (not (procedure? syntmp-x-1410)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1410))) (syntmp-global-extend-113 (quote macro) syntmp-sym-1407 syntmp-v-1408)))) (letrec ((syntmp-match-1415 (lambda (syntmp-e-1416 syntmp-p-1417 syntmp-w-1418 syntmp-r-1419) (cond ((not syntmp-r-1419) #f) ((eq? syntmp-p-1417 (quote any)) (cons (syntmp-wrap-143 syntmp-e-1416 syntmp-w-1418) syntmp-r-1419)) ((syntmp-syntax-object?-101 syntmp-e-1416) (syntmp-match*-1414 (let ((syntmp-e-1420 (syntmp-syntax-object-expression-102 syntmp-e-1416))) (if (annotation? syntmp-e-1420) (annotation-expression syntmp-e-1420) syntmp-e-1420)) syntmp-p-1417 (syntmp-join-wraps-134 syntmp-w-1418 (syntmp-syntax-object-wrap-103 syntmp-e-1416)) syntmp-r-1419)) (else (syntmp-match*-1414 (let ((syntmp-e-1421 syntmp-e-1416)) (if (annotation? syntmp-e-1421) (annotation-expression syntmp-e-1421) syntmp-e-1421)) syntmp-p-1417 syntmp-w-1418 syntmp-r-1419))))) (syntmp-match*-1414 (lambda (syntmp-e-1422 syntmp-p-1423 syntmp-w-1424 syntmp-r-1425) (cond ((null? syntmp-p-1423) (and (null? syntmp-e-1422) syntmp-r-1425)) ((pair? syntmp-p-1423) (and (pair? syntmp-e-1422) (syntmp-match-1415 (car syntmp-e-1422) (car syntmp-p-1423) syntmp-w-1424 (syntmp-match-1415 (cdr syntmp-e-1422) (cdr syntmp-p-1423) syntmp-w-1424 syntmp-r-1425)))) ((eq? syntmp-p-1423 (quote each-any)) (let ((syntmp-l-1426 (syntmp-match-each-any-1412 syntmp-e-1422 syntmp-w-1424))) (and syntmp-l-1426 (cons syntmp-l-1426 syntmp-r-1425)))) (else (let ((syntmp-t-1427 (vector-ref syntmp-p-1423 0))) (if (memv syntmp-t-1427 (quote (each))) (if (null? syntmp-e-1422) (syntmp-match-empty-1413 (vector-ref syntmp-p-1423 1) syntmp-r-1425) (let ((syntmp-l-1428 (syntmp-match-each-1411 syntmp-e-1422 (vector-ref syntmp-p-1423 1) syntmp-w-1424))) (and syntmp-l-1428 (let syntmp-collect-1429 ((syntmp-l-1430 syntmp-l-1428)) (if (null? (car syntmp-l-1430)) syntmp-r-1425 (cons (map car syntmp-l-1430) (syntmp-collect-1429 (map cdr syntmp-l-1430)))))))) (if (memv syntmp-t-1427 (quote (free-id))) (and (syntmp-id?-115 syntmp-e-1422) (syntmp-free-id=?-138 (syntmp-wrap-143 syntmp-e-1422 syntmp-w-1424) (vector-ref syntmp-p-1423 1)) syntmp-r-1425) (if (memv syntmp-t-1427 (quote (atom))) (and (equal? (vector-ref syntmp-p-1423 1) (syntmp-strip-162 syntmp-e-1422 syntmp-w-1424)) syntmp-r-1425) (if (memv syntmp-t-1427 (quote (vector))) (and (vector? syntmp-e-1422) (syntmp-match-1415 (vector->list syntmp-e-1422) (vector-ref syntmp-p-1423 1) syntmp-w-1424 syntmp-r-1425))))))))))) (syntmp-match-empty-1413 (lambda (syntmp-p-1431 syntmp-r-1432) (cond ((null? syntmp-p-1431) syntmp-r-1432) ((eq? syntmp-p-1431 (quote any)) (cons (quote ()) syntmp-r-1432)) ((pair? syntmp-p-1431) (syntmp-match-empty-1413 (car syntmp-p-1431) (syntmp-match-empty-1413 (cdr syntmp-p-1431) syntmp-r-1432))) ((eq? syntmp-p-1431 (quote each-any)) (cons (quote ()) syntmp-r-1432)) (else (let ((syntmp-t-1433 (vector-ref syntmp-p-1431 0))) (if (memv syntmp-t-1433 (quote (each))) (syntmp-match-empty-1413 (vector-ref syntmp-p-1431 1) syntmp-r-1432) (if (memv syntmp-t-1433 (quote (free-id atom))) syntmp-r-1432 (if (memv syntmp-t-1433 (quote (vector))) (syntmp-match-empty-1413 (vector-ref syntmp-p-1431 1) syntmp-r-1432))))))))) (syntmp-match-each-any-1412 (lambda (syntmp-e-1434 syntmp-w-1435) (cond ((annotation? syntmp-e-1434) (syntmp-match-each-any-1412 (annotation-expression syntmp-e-1434) syntmp-w-1435)) ((pair? syntmp-e-1434) (let ((syntmp-l-1436 (syntmp-match-each-any-1412 (cdr syntmp-e-1434) syntmp-w-1435))) (and syntmp-l-1436 (cons (syntmp-wrap-143 (car syntmp-e-1434) syntmp-w-1435) syntmp-l-1436)))) ((null? syntmp-e-1434) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1434) (syntmp-match-each-any-1412 (syntmp-syntax-object-expression-102 syntmp-e-1434) (syntmp-join-wraps-134 syntmp-w-1435 (syntmp-syntax-object-wrap-103 syntmp-e-1434)))) (else #f)))) (syntmp-match-each-1411 (lambda (syntmp-e-1437 syntmp-p-1438 syntmp-w-1439) (cond ((annotation? syntmp-e-1437) (syntmp-match-each-1411 (annotation-expression syntmp-e-1437) syntmp-p-1438 syntmp-w-1439)) ((pair? syntmp-e-1437) (let ((syntmp-first-1440 (syntmp-match-1415 (car syntmp-e-1437) syntmp-p-1438 syntmp-w-1439 (quote ())))) (and syntmp-first-1440 (let ((syntmp-rest-1441 (syntmp-match-each-1411 (cdr syntmp-e-1437) syntmp-p-1438 syntmp-w-1439))) (and syntmp-rest-1441 (cons syntmp-first-1440 syntmp-rest-1441)))))) ((null? syntmp-e-1437) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1437) (syntmp-match-each-1411 (syntmp-syntax-object-expression-102 syntmp-e-1437) syntmp-p-1438 (syntmp-join-wraps-134 syntmp-w-1439 (syntmp-syntax-object-wrap-103 syntmp-e-1437)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1442 syntmp-p-1443) (cond ((eq? syntmp-p-1443 (quote any)) (list syntmp-e-1442)) ((syntmp-syntax-object?-101 syntmp-e-1442) (syntmp-match*-1414 (let ((syntmp-e-1444 (syntmp-syntax-object-expression-102 syntmp-e-1442))) (if (annotation? syntmp-e-1444) (annotation-expression syntmp-e-1444) syntmp-e-1444)) syntmp-p-1443 (syntmp-syntax-object-wrap-103 syntmp-e-1442) (quote ()))) (else (syntmp-match*-1414 (let ((syntmp-e-1445 syntmp-e-1442)) (if (annotation? syntmp-e-1445) (annotation-expression syntmp-e-1445) syntmp-e-1445)) syntmp-p-1443 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-151))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1446) ((lambda (syntmp-tmp-1447) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda (syntmp-_-1449 syntmp-e1-1450 syntmp-e2-1451) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1450 syntmp-e2-1451))) syntmp-tmp-1448) ((lambda (syntmp-tmp-1453) (if syntmp-tmp-1453 (apply (lambda (syntmp-_-1454 syntmp-out-1455 syntmp-in-1456 syntmp-e1-1457 syntmp-e2-1458) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1456 (quote ()) (list syntmp-out-1455 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1457 syntmp-e2-1458))))) syntmp-tmp-1453) ((lambda (syntmp-tmp-1460) (if syntmp-tmp-1460 (apply (lambda (syntmp-_-1461 syntmp-out-1462 syntmp-in-1463 syntmp-e1-1464 syntmp-e2-1465) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1463) (quote ()) (list syntmp-out-1462 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1464 syntmp-e2-1465))))) syntmp-tmp-1460) (syntax-error syntmp-tmp-1447))) (syntax-dispatch syntmp-tmp-1447 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1447 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1447 (quote (any () any . each-any))))) syntmp-x-1446))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1487) ((lambda (syntmp-tmp-1488) ((lambda (syntmp-tmp-1489) (if syntmp-tmp-1489 (apply (lambda (syntmp-_-1490 syntmp-k-1491 syntmp-keyword-1492 syntmp-pattern-1493 syntmp-template-1494) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1491 (map (lambda (syntmp-tmp-1497 syntmp-tmp-1496) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1496) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1497))) syntmp-template-1494 syntmp-pattern-1493)))))) syntmp-tmp-1489) (syntax-error syntmp-tmp-1488))) (syntax-dispatch syntmp-tmp-1488 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1487))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1508) ((lambda (syntmp-tmp-1509) ((lambda (syntmp-tmp-1510) (if (if syntmp-tmp-1510 (apply (lambda (syntmp-let*-1511 syntmp-x-1512 syntmp-v-1513 syntmp-e1-1514 syntmp-e2-1515) (andmap identifier? syntmp-x-1512)) syntmp-tmp-1510) #f) (apply (lambda (syntmp-let*-1517 syntmp-x-1518 syntmp-v-1519 syntmp-e1-1520 syntmp-e2-1521) (let syntmp-f-1522 ((syntmp-bindings-1523 (map list syntmp-x-1518 syntmp-v-1519))) (if (null? syntmp-bindings-1523) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1520 syntmp-e2-1521))) ((lambda (syntmp-tmp-1527) ((lambda (syntmp-tmp-1528) (if syntmp-tmp-1528 (apply (lambda (syntmp-body-1529 syntmp-binding-1530) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1530) syntmp-body-1529)) syntmp-tmp-1528) (syntax-error syntmp-tmp-1527))) (syntax-dispatch syntmp-tmp-1527 (quote (any any))))) (list (syntmp-f-1522 (cdr syntmp-bindings-1523)) (car syntmp-bindings-1523)))))) syntmp-tmp-1510) (syntax-error syntmp-tmp-1509))) (syntax-dispatch syntmp-tmp-1509 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1508))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1550) ((lambda (syntmp-tmp-1551) ((lambda (syntmp-tmp-1552) (if syntmp-tmp-1552 (apply (lambda (syntmp-_-1553 syntmp-var-1554 syntmp-init-1555 syntmp-step-1556 syntmp-e0-1557 syntmp-e1-1558 syntmp-c-1559) ((lambda (syntmp-tmp-1560) ((lambda (syntmp-tmp-1561) (if syntmp-tmp-1561 (apply (lambda (syntmp-step-1562) ((lambda (syntmp-tmp-1563) ((lambda (syntmp-tmp-1564) (if syntmp-tmp-1564 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1554 syntmp-init-1555) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1557) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1559 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1562))))))) syntmp-tmp-1564) ((lambda (syntmp-tmp-1569) (if syntmp-tmp-1569 (apply (lambda (syntmp-e1-1570 syntmp-e2-1571) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1554 syntmp-init-1555) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1557 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1570 syntmp-e2-1571)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1559 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1562))))))) syntmp-tmp-1569) (syntax-error syntmp-tmp-1563))) (syntax-dispatch syntmp-tmp-1563 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1563 (quote ())))) syntmp-e1-1558)) syntmp-tmp-1561) (syntax-error syntmp-tmp-1560))) (syntax-dispatch syntmp-tmp-1560 (quote each-any)))) (map (lambda (syntmp-v-1578 syntmp-s-1579) ((lambda (syntmp-tmp-1580) ((lambda (syntmp-tmp-1581) (if syntmp-tmp-1581 (apply (lambda () syntmp-v-1578) syntmp-tmp-1581) ((lambda (syntmp-tmp-1582) (if syntmp-tmp-1582 (apply (lambda (syntmp-e-1583) syntmp-e-1583) syntmp-tmp-1582) ((lambda (syntmp-_-1584) (syntax-error syntmp-orig-x-1550)) syntmp-tmp-1580))) (syntax-dispatch syntmp-tmp-1580 (quote (any)))))) (syntax-dispatch syntmp-tmp-1580 (quote ())))) syntmp-s-1579)) syntmp-var-1554 syntmp-step-1556))) syntmp-tmp-1552) (syntax-error syntmp-tmp-1551))) (syntax-dispatch syntmp-tmp-1551 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1550))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1612 (lambda (syntmp-x-1616 syntmp-y-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-tmp-1619) (if syntmp-tmp-1619 (apply (lambda (syntmp-x-1620 syntmp-y-1621) ((lambda (syntmp-tmp-1622) ((lambda (syntmp-tmp-1623) (if syntmp-tmp-1623 (apply (lambda (syntmp-dy-1624) ((lambda (syntmp-tmp-1625) ((lambda (syntmp-tmp-1626) (if syntmp-tmp-1626 (apply (lambda (syntmp-dx-1627) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1627 syntmp-dy-1624))) syntmp-tmp-1626) ((lambda (syntmp-_-1628) (if (null? syntmp-dy-1624) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1620) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1620 syntmp-y-1621))) syntmp-tmp-1625))) (syntax-dispatch syntmp-tmp-1625 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1620)) syntmp-tmp-1623) ((lambda (syntmp-tmp-1629) (if syntmp-tmp-1629 (apply (lambda (syntmp-stuff-1630) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1620 syntmp-stuff-1630))) syntmp-tmp-1629) ((lambda (syntmp-else-1631) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1620 syntmp-y-1621)) syntmp-tmp-1622))) (syntax-dispatch syntmp-tmp-1622 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1622 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1621)) syntmp-tmp-1619) (syntax-error syntmp-tmp-1618))) (syntax-dispatch syntmp-tmp-1618 (quote (any any))))) (list syntmp-x-1616 syntmp-y-1617)))) (syntmp-quasiappend-1613 (lambda (syntmp-x-1632 syntmp-y-1633) ((lambda (syntmp-tmp-1634) ((lambda (syntmp-tmp-1635) (if syntmp-tmp-1635 (apply (lambda (syntmp-x-1636 syntmp-y-1637) ((lambda (syntmp-tmp-1638) ((lambda (syntmp-tmp-1639) (if syntmp-tmp-1639 (apply (lambda () syntmp-x-1636) syntmp-tmp-1639) ((lambda (syntmp-_-1640) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1636 syntmp-y-1637)) syntmp-tmp-1638))) (syntax-dispatch syntmp-tmp-1638 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1637)) syntmp-tmp-1635) (syntax-error syntmp-tmp-1634))) (syntax-dispatch syntmp-tmp-1634 (quote (any any))))) (list syntmp-x-1632 syntmp-y-1633)))) (syntmp-quasivector-1614 (lambda (syntmp-x-1641) ((lambda (syntmp-tmp-1642) ((lambda (syntmp-x-1643) ((lambda (syntmp-tmp-1644) ((lambda (syntmp-tmp-1645) (if syntmp-tmp-1645 (apply (lambda (syntmp-x-1646) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1646))) syntmp-tmp-1645) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-x-1649) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1649)) syntmp-tmp-1648) ((lambda (syntmp-_-1651) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1643)) syntmp-tmp-1644))) (syntax-dispatch syntmp-tmp-1644 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1644 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1643)) syntmp-tmp-1642)) syntmp-x-1641))) (syntmp-quasi-1615 (lambda (syntmp-p-1652 syntmp-lev-1653) ((lambda (syntmp-tmp-1654) ((lambda (syntmp-tmp-1655) (if syntmp-tmp-1655 (apply (lambda (syntmp-p-1656) (if (= syntmp-lev-1653 0) syntmp-p-1656 (syntmp-quasicons-1612 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1615 (list syntmp-p-1656) (- syntmp-lev-1653 1))))) syntmp-tmp-1655) ((lambda (syntmp-tmp-1657) (if syntmp-tmp-1657 (apply (lambda (syntmp-p-1658 syntmp-q-1659) (if (= syntmp-lev-1653 0) (syntmp-quasiappend-1613 syntmp-p-1658 (syntmp-quasi-1615 syntmp-q-1659 syntmp-lev-1653)) (syntmp-quasicons-1612 (syntmp-quasicons-1612 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1615 (list syntmp-p-1658) (- syntmp-lev-1653 1))) (syntmp-quasi-1615 syntmp-q-1659 syntmp-lev-1653)))) syntmp-tmp-1657) ((lambda (syntmp-tmp-1660) (if syntmp-tmp-1660 (apply (lambda (syntmp-p-1661) (syntmp-quasicons-1612 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1615 (list syntmp-p-1661) (+ syntmp-lev-1653 1)))) syntmp-tmp-1660) ((lambda (syntmp-tmp-1662) (if syntmp-tmp-1662 (apply (lambda (syntmp-p-1663 syntmp-q-1664) (syntmp-quasicons-1612 (syntmp-quasi-1615 syntmp-p-1663 syntmp-lev-1653) (syntmp-quasi-1615 syntmp-q-1664 syntmp-lev-1653))) syntmp-tmp-1662) ((lambda (syntmp-tmp-1665) (if syntmp-tmp-1665 (apply (lambda (syntmp-x-1666) (syntmp-quasivector-1614 (syntmp-quasi-1615 syntmp-x-1666 syntmp-lev-1653))) syntmp-tmp-1665) ((lambda (syntmp-p-1668) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1668)) syntmp-tmp-1654))) (syntax-dispatch syntmp-tmp-1654 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1654 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1654 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1654 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1654 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1652)))) (lambda (syntmp-x-1669) ((lambda (syntmp-tmp-1670) ((lambda (syntmp-tmp-1671) (if syntmp-tmp-1671 (apply (lambda (syntmp-_-1672 syntmp-e-1673) (syntmp-quasi-1615 syntmp-e-1673 0)) syntmp-tmp-1671) (syntax-error syntmp-tmp-1670))) (syntax-dispatch syntmp-tmp-1670 (quote (any any))))) syntmp-x-1669)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1733) (letrec ((syntmp-read-file-1734 (lambda (syntmp-fn-1735 syntmp-k-1736) (let ((syntmp-p-1737 (open-input-file syntmp-fn-1735))) (let syntmp-f-1738 ((syntmp-x-1739 (read syntmp-p-1737))) (if (eof-object? syntmp-x-1739) (begin (close-input-port syntmp-p-1737) (quote ())) (cons (datum->syntax-object syntmp-k-1736 syntmp-x-1739) (syntmp-f-1738 (read syntmp-p-1737))))))))) ((lambda (syntmp-tmp-1740) ((lambda (syntmp-tmp-1741) (if syntmp-tmp-1741 (apply (lambda (syntmp-k-1742 syntmp-filename-1743) (let ((syntmp-fn-1744 (syntax-object->datum syntmp-filename-1743))) ((lambda (syntmp-tmp-1745) ((lambda (syntmp-tmp-1746) (if syntmp-tmp-1746 (apply (lambda (syntmp-exp-1747) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1747)) syntmp-tmp-1746) (syntax-error syntmp-tmp-1745))) (syntax-dispatch syntmp-tmp-1745 (quote each-any)))) (syntmp-read-file-1734 syntmp-fn-1744 syntmp-k-1742)))) syntmp-tmp-1741) (syntax-error syntmp-tmp-1740))) (syntax-dispatch syntmp-tmp-1740 (quote (any any))))) syntmp-x-1733)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1764) ((lambda (syntmp-tmp-1765) ((lambda (syntmp-tmp-1766) (if syntmp-tmp-1766 (apply (lambda (syntmp-_-1767 syntmp-e-1768) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1768))) syntmp-tmp-1766) (syntax-error syntmp-tmp-1765))) (syntax-dispatch syntmp-tmp-1765 (quote (any any))))) syntmp-x-1764))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1774) ((lambda (syntmp-tmp-1775) ((lambda (syntmp-tmp-1776) (if syntmp-tmp-1776 (apply (lambda (syntmp-_-1777 syntmp-e-1778) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1778))) syntmp-tmp-1776) (syntax-error syntmp-tmp-1775))) (syntax-dispatch syntmp-tmp-1775 (quote (any any))))) syntmp-x-1774))) +(install-global-transformer (quote case) (lambda (syntmp-x-1784) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-tmp-1786) (if syntmp-tmp-1786 (apply (lambda (syntmp-_-1787 syntmp-e-1788 syntmp-m1-1789 syntmp-m2-1790) ((lambda (syntmp-tmp-1791) ((lambda (syntmp-body-1792) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1788)) syntmp-body-1792)) syntmp-tmp-1791)) (let syntmp-f-1793 ((syntmp-clause-1794 syntmp-m1-1789) (syntmp-clauses-1795 syntmp-m2-1790)) (if (null? syntmp-clauses-1795) ((lambda (syntmp-tmp-1797) ((lambda (syntmp-tmp-1798) (if syntmp-tmp-1798 (apply (lambda (syntmp-e1-1799 syntmp-e2-1800) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1799 syntmp-e2-1800))) syntmp-tmp-1798) ((lambda (syntmp-tmp-1802) (if syntmp-tmp-1802 (apply (lambda (syntmp-k-1803 syntmp-e1-1804 syntmp-e2-1805) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1803)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1804 syntmp-e2-1805)))) syntmp-tmp-1802) ((lambda (syntmp-_-1808) (syntax-error syntmp-x-1784)) syntmp-tmp-1797))) (syntax-dispatch syntmp-tmp-1797 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1797 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1794) ((lambda (syntmp-tmp-1809) ((lambda (syntmp-rest-1810) ((lambda (syntmp-tmp-1811) ((lambda (syntmp-tmp-1812) (if syntmp-tmp-1812 (apply (lambda (syntmp-k-1813 syntmp-e1-1814 syntmp-e2-1815) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1813)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1814 syntmp-e2-1815)) syntmp-rest-1810)) syntmp-tmp-1812) ((lambda (syntmp-_-1818) (syntax-error syntmp-x-1784)) syntmp-tmp-1811))) (syntax-dispatch syntmp-tmp-1811 (quote (each-any any . each-any))))) syntmp-clause-1794)) syntmp-tmp-1809)) (syntmp-f-1793 (car syntmp-clauses-1795) (cdr syntmp-clauses-1795))))))) syntmp-tmp-1786) (syntax-error syntmp-tmp-1785))) (syntax-dispatch syntmp-tmp-1785 (quote (any any any . each-any))))) syntmp-x-1784))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1848) ((lambda (syntmp-tmp-1849) ((lambda (syntmp-tmp-1850) (if syntmp-tmp-1850 (apply (lambda (syntmp-_-1851 syntmp-e-1852) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1852)) (list (cons syntmp-_-1851 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1852 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1850) (syntax-error syntmp-tmp-1849))) (syntax-dispatch syntmp-tmp-1849 (quote (any any))))) syntmp-x-1848))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 687e0e5bf..40ec91642 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -373,12 +373,12 @@ (define-syntax build-global-reference (syntax-rules () ((_ source var) - (build-annotated source var)))) + (build-annotated source (make-module-ref #f var #f))))) (define-syntax build-global-assignment (syntax-rules () ((_ source var exp) - (build-annotated source `(set! ,var ,exp))))) + (build-annotated source `(set! ,(make-module-ref #f var #f) ,exp))))) (define-syntax build-global-definition (syntax-rules () diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index 5a5e1a6ea..63b3a52e4 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -17,10 +17,11 @@ (define-module (ice-9 syncase) + :use-module (ice-9 expand-support) :use-module (ice-9 debug) :use-module (ice-9 threads) :export-syntax (sc-macro define-syntax define-syntax-public - eval-when fluid-let-syntax + fluid-let-syntax identifier-syntax let-syntax letrec-syntax syntax syntax-case syntax-rules with-syntax @@ -30,7 +31,7 @@ datum->syntax-object free-identifier=? generate-temporaries identifier? syntax-object->datum void syncase) - :replace (eval)) + :replace (eval eval-when)) @@ -48,7 +49,7 @@ (procedure->memoizing-macro (lambda (exp env) (with-fluids ((expansion-eval-closure (env->eval-closure env))) - (sc-expand exp))))) + (strip-expansion-structures (sc-expand exp)))))) ;;; Exported variables @@ -147,7 +148,7 @@ e ;; perform Guile macro transform (let ((e ((macro-transformer m) - e + (strip-expansion-structures e) (append r (list eval-closure))))) (if (variable? e) e @@ -224,8 +225,8 @@ (define (eval x environment) (internal-eval (if (and (pair? x) (equal? (car x) "noexpand")) - (cadr x) - (sc-expand x)) + (strip-expansion-structures (cadr x)) + (strip-expansion-structures (sc-expand x))) environment)) ;;; Hack to make syncase macros work in the slib module @@ -238,7 +239,7 @@ (define (syncase exp) (with-fluids ((expansion-eval-closure (module-eval-closure (current-module)))) - (sc-expand exp))) + (strip-expansion-structures (sc-expand exp)))) (set-module-transformer! the-syncase-module syncase) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index fcca8a940..d622c277b 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,6 +27,7 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) + #:use-module (ice-9 expand-support) #:use-module ((ice-9 syncase) #:select (sc-macro)) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 @@ -119,7 +120,8 @@ (lambda (env loc exp) (retrans (with-fluids ((eec (module-eval-closure mod))) - (sc-expand3 exp 'c '(compile load eval))))))) + (strip-expansion-structures + (sc-expand3 exp 'c '(compile load eval)))))))) ((primitive-macro? val) (syntax-error #f "unhandled primitive macro" head)) diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm index ee689a092..18dc032c9 100644 --- a/module/language/scheme/expand.scm +++ b/module/language/scheme/expand.scm @@ -21,7 +21,7 @@ (define-module (language scheme expand) #:use-module (language scheme amatch) - #:use-module (ice-9 annotate) + #:use-module (ice-9 expand-support) #:use-module (ice-9 optargs) #:use-module ((ice-9 syncase) #:select (sc-macro)) #:use-module ((system base compile) #:select (syntax-error)) From 1641568c33de451b54fc7a8a6b682af51ab596af Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 29 Mar 2009 11:35:55 -0700 Subject: [PATCH 031/375] add modules to syntax objects (part 1, intermediate step) * module/ice-9/psyntax.scm (make-syntax-object): As an intermediate step to adding modules to syntax objects, replace the definition of syntax-object as a structure with an expanded-out definition that has (1) a constructor that takes 2 or 3 arguments, and (2) a predicate that works with vectors of length 3 or 4. I couldn't just redefine make-syntax-object, for example, because these are internal definitions, and we can't have duplicate bindings in a letrec. --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 21 ++++++++++++++++++++- 2 files changed, 31 insertions(+), 12 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 3c4cee9d1..bb7af90cc 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-164 (lambda (syntmp-vars-549) (let syntmp-lvl-550 ((syntmp-vars-551 syntmp-vars-549) (syntmp-ls-552 (quote ())) (syntmp-w-553 (quote (())))) (cond ((pair? syntmp-vars-551) (syntmp-lvl-550 (cdr syntmp-vars-551) (cons (syntmp-wrap-143 (car syntmp-vars-551) syntmp-w-553) syntmp-ls-552) syntmp-w-553)) ((syntmp-id?-115 syntmp-vars-551) (cons (syntmp-wrap-143 syntmp-vars-551 syntmp-w-553) syntmp-ls-552)) ((null? syntmp-vars-551) syntmp-ls-552) ((syntmp-syntax-object?-101 syntmp-vars-551) (syntmp-lvl-550 (syntmp-syntax-object-expression-102 syntmp-vars-551) syntmp-ls-552 (syntmp-join-wraps-134 syntmp-w-553 (syntmp-syntax-object-wrap-103 syntmp-vars-551)))) ((annotation? syntmp-vars-551) (syntmp-lvl-550 (annotation-expression syntmp-vars-551) syntmp-ls-552 syntmp-w-553)) (else (cons syntmp-vars-551 syntmp-ls-552)))))) (syntmp-gen-var-163 (lambda (syntmp-id-554) (let ((syntmp-id-555 (if (syntmp-syntax-object?-101 syntmp-id-554) (syntmp-syntax-object-expression-102 syntmp-id-554) syntmp-id-554))) (if (annotation? syntmp-id-555) (syntmp-build-annotated-94 (annotation-source syntmp-id-555) (gensym (symbol->string (annotation-expression syntmp-id-555)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-555))))))) (syntmp-strip-162 (lambda (syntmp-x-556 syntmp-w-557) (if (memq (quote top) (syntmp-wrap-marks-118 syntmp-w-557)) (if (or (annotation? syntmp-x-556) (and (pair? syntmp-x-556) (annotation? (car syntmp-x-556)))) (syntmp-strip-annotation-161 syntmp-x-556 #f) syntmp-x-556) (let syntmp-f-558 ((syntmp-x-559 syntmp-x-556)) (cond ((syntmp-syntax-object?-101 syntmp-x-559) (syntmp-strip-162 (syntmp-syntax-object-expression-102 syntmp-x-559) (syntmp-syntax-object-wrap-103 syntmp-x-559))) ((pair? syntmp-x-559) (let ((syntmp-a-560 (syntmp-f-558 (car syntmp-x-559))) (syntmp-d-561 (syntmp-f-558 (cdr syntmp-x-559)))) (if (and (eq? syntmp-a-560 (car syntmp-x-559)) (eq? syntmp-d-561 (cdr syntmp-x-559))) syntmp-x-559 (cons syntmp-a-560 syntmp-d-561)))) ((vector? syntmp-x-559) (let ((syntmp-old-562 (vector->list syntmp-x-559))) (let ((syntmp-new-563 (map syntmp-f-558 syntmp-old-562))) (if (andmap eq? syntmp-old-562 syntmp-new-563) syntmp-x-559 (list->vector syntmp-new-563))))) (else syntmp-x-559)))))) (syntmp-strip-annotation-161 (lambda (syntmp-x-564 syntmp-parent-565) (cond ((pair? syntmp-x-564) (let ((syntmp-new-566 (cons #f #f))) (begin (if syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-566)) (set-car! syntmp-new-566 (syntmp-strip-annotation-161 (car syntmp-x-564) #f)) (set-cdr! syntmp-new-566 (syntmp-strip-annotation-161 (cdr syntmp-x-564) #f)) syntmp-new-566))) ((annotation? syntmp-x-564) (or (annotation-stripped syntmp-x-564) (syntmp-strip-annotation-161 (annotation-expression syntmp-x-564) syntmp-x-564))) ((vector? syntmp-x-564) (let ((syntmp-new-567 (make-vector (vector-length syntmp-x-564)))) (begin (if syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-567)) (let syntmp-loop-568 ((syntmp-i-569 (- (vector-length syntmp-x-564) 1))) (unless (syntmp-fx<-88 syntmp-i-569 0) (vector-set! syntmp-new-567 syntmp-i-569 (syntmp-strip-annotation-161 (vector-ref syntmp-x-564 syntmp-i-569) #f)) (syntmp-loop-568 (syntmp-fx--86 syntmp-i-569 1)))) syntmp-new-567))) (else syntmp-x-564)))) (syntmp-ellipsis?-160 (lambda (syntmp-x-570) (and (syntmp-nonsymbol-id?-114 syntmp-x-570) (syntmp-free-id=?-138 syntmp-x-570 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-159 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-158 (lambda (syntmp-expanded-571) (let ((syntmp-p-572 (syntmp-local-eval-hook-90 syntmp-expanded-571))) (if (procedure? syntmp-p-572) syntmp-p-572 (syntax-error syntmp-p-572 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-157 (lambda (syntmp-rec?-573 syntmp-e-574 syntmp-r-575 syntmp-w-576 syntmp-s-577 syntmp-k-578) ((lambda (syntmp-tmp-579) ((lambda (syntmp-tmp-580) (if syntmp-tmp-580 (apply (lambda (syntmp-_-581 syntmp-id-582 syntmp-val-583 syntmp-e1-584 syntmp-e2-585) (let ((syntmp-ids-586 syntmp-id-582)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-586)) (syntax-error syntmp-e-574 "duplicate bound keyword in") (let ((syntmp-labels-588 (syntmp-gen-labels-121 syntmp-ids-586))) (let ((syntmp-new-w-589 (syntmp-make-binding-wrap-132 syntmp-ids-586 syntmp-labels-588 syntmp-w-576))) (syntmp-k-578 (cons syntmp-e1-584 syntmp-e2-585) (syntmp-extend-env-109 syntmp-labels-588 (let ((syntmp-w-591 (if syntmp-rec?-573 syntmp-new-w-589 syntmp-w-576)) (syntmp-trans-r-592 (syntmp-macros-only-env-111 syntmp-r-575))) (map (lambda (syntmp-x-593) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-593 syntmp-trans-r-592 syntmp-w-591)))) syntmp-val-583)) syntmp-r-575) syntmp-new-w-589 syntmp-s-577)))))) syntmp-tmp-580) ((lambda (syntmp-_-595) (syntax-error (syntmp-source-wrap-144 syntmp-e-574 syntmp-w-576 syntmp-s-577))) syntmp-tmp-579))) (syntax-dispatch syntmp-tmp-579 (quote (any #(each (any any)) any . each-any))))) syntmp-e-574))) (syntmp-chi-lambda-clause-156 (lambda (syntmp-e-596 syntmp-c-597 syntmp-r-598 syntmp-w-599 syntmp-k-600) ((lambda (syntmp-tmp-601) ((lambda (syntmp-tmp-602) (if syntmp-tmp-602 (apply (lambda (syntmp-id-603 syntmp-e1-604 syntmp-e2-605) (let ((syntmp-ids-606 syntmp-id-603)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-606)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-608 (syntmp-gen-labels-121 syntmp-ids-606)) (syntmp-new-vars-609 (map syntmp-gen-var-163 syntmp-ids-606))) (syntmp-k-600 syntmp-new-vars-609 (syntmp-chi-body-155 (cons syntmp-e1-604 syntmp-e2-605) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-608 syntmp-new-vars-609 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-ids-606 syntmp-labels-608 syntmp-w-599))))))) syntmp-tmp-602) ((lambda (syntmp-tmp-611) (if syntmp-tmp-611 (apply (lambda (syntmp-ids-612 syntmp-e1-613 syntmp-e2-614) (let ((syntmp-old-ids-615 (syntmp-lambda-var-list-164 syntmp-ids-612))) (if (not (syntmp-valid-bound-ids?-140 syntmp-old-ids-615)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-616 (syntmp-gen-labels-121 syntmp-old-ids-615)) (syntmp-new-vars-617 (map syntmp-gen-var-163 syntmp-old-ids-615))) (syntmp-k-600 (let syntmp-f-618 ((syntmp-ls1-619 (cdr syntmp-new-vars-617)) (syntmp-ls2-620 (car syntmp-new-vars-617))) (if (null? syntmp-ls1-619) syntmp-ls2-620 (syntmp-f-618 (cdr syntmp-ls1-619) (cons (car syntmp-ls1-619) syntmp-ls2-620)))) (syntmp-chi-body-155 (cons syntmp-e1-613 syntmp-e2-614) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-616 syntmp-new-vars-617 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-old-ids-615 syntmp-labels-616 syntmp-w-599))))))) syntmp-tmp-611) ((lambda (syntmp-_-622) (syntax-error syntmp-e-596)) syntmp-tmp-601))) (syntax-dispatch syntmp-tmp-601 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-601 (quote (each-any any . each-any))))) syntmp-c-597))) (syntmp-chi-body-155 (lambda (syntmp-body-623 syntmp-outer-form-624 syntmp-r-625 syntmp-w-626) (let ((syntmp-r-627 (cons (quote ("placeholder" placeholder)) syntmp-r-625))) (let ((syntmp-ribcage-628 (syntmp-make-ribcage-122 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-629 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-626) (cons syntmp-ribcage-628 (syntmp-wrap-subst-119 syntmp-w-626))))) (let syntmp-parse-630 ((syntmp-body-631 (map (lambda (syntmp-x-637) (cons syntmp-r-627 (syntmp-wrap-143 syntmp-x-637 syntmp-w-629))) syntmp-body-623)) (syntmp-ids-632 (quote ())) (syntmp-labels-633 (quote ())) (syntmp-vars-634 (quote ())) (syntmp-vals-635 (quote ())) (syntmp-bindings-636 (quote ()))) (if (null? syntmp-body-631) (syntax-error syntmp-outer-form-624 "no expressions in body") (let ((syntmp-e-638 (cdar syntmp-body-631)) (syntmp-er-639 (caar syntmp-body-631))) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-638 syntmp-er-639 (quote (())) #f syntmp-ribcage-628)) (lambda (syntmp-type-640 syntmp-value-641 syntmp-e-642 syntmp-w-643 syntmp-s-644) (let ((syntmp-t-645 syntmp-type-640)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-647 (syntmp-gen-label-120))) (let ((syntmp-var-648 (syntmp-gen-var-163 syntmp-id-646))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-646 syntmp-label-647) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-646 syntmp-ids-632) (cons syntmp-label-647 syntmp-labels-633) (cons syntmp-var-648 syntmp-vars-634) (cons (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643)) syntmp-vals-635) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-636))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-650 (syntmp-gen-label-120))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-649 syntmp-label-650) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-649 syntmp-ids-632) (cons syntmp-label-650 syntmp-labels-633) syntmp-vars-634 syntmp-vals-635 (cons (cons (quote macro) (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643))) syntmp-bindings-636)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-630 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-631) (cons (cons syntmp-er-639 (syntmp-wrap-143 (car syntmp-forms-656) syntmp-w-643)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-642) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-641 syntmp-e-642 syntmp-er-639 syntmp-w-643 syntmp-s-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661) (syntmp-parse-630 (let syntmp-f-662 ((syntmp-forms-663 syntmp-forms-658)) (if (null? syntmp-forms-663) (cdr syntmp-body-631) (cons (cons syntmp-er-659 (syntmp-wrap-143 (car syntmp-forms-663) syntmp-w-660)) (syntmp-f-662 (cdr syntmp-forms-663))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636))) (if (null? syntmp-ids-632) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-664) (syntmp-chi-151 (cdr syntmp-x-664) (car syntmp-x-664) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))) (begin (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-632)) (syntax-error syntmp-outer-form-624 "invalid or duplicate identifier in definition")) (let syntmp-loop-665 ((syntmp-bs-666 syntmp-bindings-636) (syntmp-er-cache-667 #f) (syntmp-r-cache-668 #f)) (if (not (null? syntmp-bs-666)) (let ((syntmp-b-669 (car syntmp-bs-666))) (if (eq? (car syntmp-b-669) (quote macro)) (let ((syntmp-er-670 (cadr syntmp-b-669))) (let ((syntmp-r-cache-671 (if (eq? syntmp-er-670 syntmp-er-cache-667) syntmp-r-cache-668 (syntmp-macros-only-env-111 syntmp-er-670)))) (begin (set-cdr! syntmp-b-669 (syntmp-eval-local-transformer-158 (syntmp-chi-151 (cddr syntmp-b-669) syntmp-r-cache-671 (quote (()))))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-670 syntmp-r-cache-671)))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-cache-667 syntmp-r-cache-668))))) (set-cdr! syntmp-r-627 (syntmp-extend-env-109 syntmp-labels-633 syntmp-bindings-636 (cdr syntmp-r-627))) (syntmp-build-letrec-99 #f syntmp-vars-634 (map (lambda (syntmp-x-672) (syntmp-chi-151 (cdr syntmp-x-672) (car syntmp-x-672) (quote (())))) syntmp-vals-635) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-673) (syntmp-chi-151 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))))))))))))))))))))) (syntmp-chi-macro-154 (lambda (syntmp-p-674 syntmp-e-675 syntmp-r-676 syntmp-w-677 syntmp-rib-678) (letrec ((syntmp-rebuild-macro-output-679 (lambda (syntmp-x-680 syntmp-m-681) (cond ((pair? syntmp-x-680) (cons (syntmp-rebuild-macro-output-679 (car syntmp-x-680) syntmp-m-681) (syntmp-rebuild-macro-output-679 (cdr syntmp-x-680) syntmp-m-681))) ((syntmp-syntax-object?-101 syntmp-x-680) (let ((syntmp-w-682 (syntmp-syntax-object-wrap-103 syntmp-x-680))) (let ((syntmp-ms-683 (syntmp-wrap-marks-118 syntmp-w-682)) (syntmp-s-684 (syntmp-wrap-subst-119 syntmp-w-682))) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-680) (if (and (pair? syntmp-ms-683) (eq? (car syntmp-ms-683) #f)) (syntmp-make-wrap-117 (cdr syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cdr syntmp-s-684)) (cdr syntmp-s-684))) (syntmp-make-wrap-117 (cons syntmp-m-681 syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cons (quote shift) syntmp-s-684)) (cons (quote shift) syntmp-s-684)))))))) ((vector? syntmp-x-680) (let ((syntmp-n-685 (vector-length syntmp-x-680))) (let ((syntmp-v-686 (make-vector syntmp-n-685))) (let syntmp-doloop-687 ((syntmp-i-688 0)) (if (syntmp-fx=-87 syntmp-i-688 syntmp-n-685) syntmp-v-686 (begin (vector-set! syntmp-v-686 syntmp-i-688 (syntmp-rebuild-macro-output-679 (vector-ref syntmp-x-680 syntmp-i-688) syntmp-m-681)) (syntmp-doloop-687 (syntmp-fx+-85 syntmp-i-688 1)))))))) ((symbol? syntmp-x-680) (syntax-error syntmp-x-680 "encountered raw symbol in macro output")) (else syntmp-x-680))))) (syntmp-rebuild-macro-output-679 (syntmp-p-674 (syntmp-wrap-143 syntmp-e-675 (syntmp-anti-mark-130 syntmp-w-677))) (string #\m))))) (syntmp-chi-application-153 (lambda (syntmp-x-689 syntmp-e-690 syntmp-r-691 syntmp-w-692 syntmp-s-693) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-e0-696 syntmp-e1-697) (syntmp-build-annotated-94 syntmp-s-693 (cons syntmp-x-689 (map (lambda (syntmp-e-698) (syntmp-chi-151 syntmp-e-698 syntmp-r-691 syntmp-w-692)) syntmp-e1-697)))) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any . each-any))))) syntmp-e-690))) (syntmp-chi-expr-152 (lambda (syntmp-type-700 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (let ((syntmp-t-706 syntmp-type-700)) (if (memv syntmp-t-706 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-705 syntmp-value-701) (if (memv syntmp-t-706 (quote (core external-macro))) (syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (lexical-call))) (syntmp-chi-application-153 (syntmp-build-annotated-94 (syntmp-source-annotation-106 (car syntmp-e-702)) syntmp-value-701) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (global-call))) (syntmp-chi-application-153 (syntmp-build-annotated-94 (syntmp-source-annotation-106 (car syntmp-e-702)) (make-module-ref #f syntmp-value-701 #f)) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (constant))) (syntmp-build-data-95 syntmp-s-705 (syntmp-strip-162 (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) (quote (())))) (if (memv syntmp-t-706 (quote (global))) (syntmp-build-annotated-94 syntmp-s-705 (make-module-ref #f syntmp-value-701 #f)) (if (memv syntmp-t-706 (quote (call))) (syntmp-chi-application-153 (syntmp-chi-151 (car syntmp-e-702) syntmp-r-703 syntmp-w-704) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (begin-form))) ((lambda (syntmp-tmp-707) ((lambda (syntmp-tmp-708) (if syntmp-tmp-708 (apply (lambda (syntmp-_-709 syntmp-e1-710 syntmp-e2-711) (syntmp-chi-sequence-145 (cons syntmp-e1-710 syntmp-e2-711) syntmp-r-703 syntmp-w-704 syntmp-s-705)) syntmp-tmp-708) (syntax-error syntmp-tmp-707))) (syntax-dispatch syntmp-tmp-707 (quote (any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705 syntmp-chi-sequence-145) (if (memv syntmp-t-706 (quote (eval-when-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-x-716 syntmp-e1-717 syntmp-e2-718) (let ((syntmp-when-list-719 (syntmp-chi-when-list-148 syntmp-e-702 syntmp-x-716 syntmp-w-704))) (if (memq (quote eval) syntmp-when-list-719) (syntmp-chi-sequence-145 (cons syntmp-e1-717 syntmp-e2-718) syntmp-r-703 syntmp-w-704 syntmp-s-705) (syntmp-chi-void-159)))) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any each-any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-143 syntmp-value-701 syntmp-w-704) "invalid context for definition of") (if (memv syntmp-t-706 (quote (syntax))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to pattern variable outside syntax form") (if (memv syntmp-t-706 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705)))))))))))))))))) (syntmp-chi-151 (lambda (syntmp-e-722 syntmp-r-723 syntmp-w-724) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-722 syntmp-r-723 syntmp-w-724 #f #f)) (lambda (syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-w-728 syntmp-s-729) (syntmp-chi-expr-152 syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-r-723 syntmp-w-728 syntmp-s-729))))) (syntmp-chi-top-150 (lambda (syntmp-e-730 syntmp-r-731 syntmp-w-732 syntmp-m-733 syntmp-esew-734) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-730 syntmp-r-731 syntmp-w-732 #f #f)) (lambda (syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-w-750 syntmp-s-751) (let ((syntmp-t-752 syntmp-type-747)) (if (memv syntmp-t-752 (quote (begin-form))) ((lambda (syntmp-tmp-753) ((lambda (syntmp-tmp-754) (if syntmp-tmp-754 (apply (lambda (syntmp-_-755) (syntmp-chi-void-159)) syntmp-tmp-754) ((lambda (syntmp-tmp-756) (if syntmp-tmp-756 (apply (lambda (syntmp-_-757 syntmp-e1-758 syntmp-e2-759) (syntmp-chi-top-sequence-146 (cons syntmp-e1-758 syntmp-e2-759) syntmp-r-731 syntmp-w-750 syntmp-s-751 syntmp-m-733 syntmp-esew-734)) syntmp-tmp-756) (syntax-error syntmp-tmp-753))) (syntax-dispatch syntmp-tmp-753 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-753 (quote (any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751 (lambda (syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764) (syntmp-chi-top-sequence-146 syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764 syntmp-m-733 syntmp-esew-734))) (if (memv syntmp-t-752 (quote (eval-when-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767 syntmp-x-768 syntmp-e1-769 syntmp-e2-770) (let ((syntmp-when-list-771 (syntmp-chi-when-list-148 syntmp-e-749 syntmp-x-768 syntmp-w-750)) (syntmp-body-772 (cons syntmp-e1-769 syntmp-e2-770))) (cond ((eq? syntmp-m-733 (quote e)) (if (memq (quote eval) syntmp-when-list-771) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval))) (syntmp-chi-void-159))) ((memq (quote load) syntmp-when-list-771) (if (or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c&e) (quote (compile load))) (if (memq syntmp-m-733 (quote (c c&e))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c) (quote (load))) (syntmp-chi-void-159)))) ((or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval)))) (syntmp-chi-void-159)) (else (syntmp-chi-void-159))))) syntmp-tmp-766) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any each-any any . each-any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (define-syntax-form))) (let ((syntmp-n-775 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750)) (syntmp-r-776 (syntmp-macros-only-env-111 syntmp-r-731))) (let ((syntmp-t-777 syntmp-m-733)) (if (memv syntmp-t-777 (quote (c))) (if (memq (quote compile) syntmp-esew-734) (let ((syntmp-e-778 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-778) (if (memq (quote load) syntmp-esew-734) syntmp-e-778 (syntmp-chi-void-159)))) (if (memq (quote load) syntmp-esew-734) (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)) (syntmp-chi-void-159))) (if (memv syntmp-t-777 (quote (c&e))) (let ((syntmp-e-779 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-779) syntmp-e-779)) (begin (if (memq (quote eval) syntmp-esew-734) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (syntmp-chi-void-159)))))) (if (memv syntmp-t-752 (quote (define-form))) (let ((syntmp-n-780 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750))) (let ((syntmp-type-781 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-780 syntmp-r-731)))) (let ((syntmp-t-782 syntmp-type-781)) (if (memv syntmp-t-782 (quote (global))) (let ((syntmp-x-783 (syntmp-build-annotated-94 syntmp-s-751 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750))))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-783)) syntmp-x-783)) (if (memv syntmp-t-782 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "identifier out of context") (if (eq? syntmp-type-781 (quote external-macro)) (let ((syntmp-x-784 (syntmp-build-annotated-94 syntmp-s-751 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750))))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-784)) syntmp-x-784)) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "cannot define keyword at top level"))))))) (let ((syntmp-x-785 (syntmp-chi-expr-152 syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-785)) syntmp-x-785)))))))))))) (syntmp-syntax-type-149 (lambda (syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-rib-790) (cond ((symbol? syntmp-e-786) (let ((syntmp-n-791 (syntmp-id-var-name-137 syntmp-e-786 syntmp-w-788))) (let ((syntmp-b-792 (syntmp-lookup-112 syntmp-n-791 syntmp-r-787))) (let ((syntmp-type-793 (syntmp-binding-type-107 syntmp-b-792))) (let ((syntmp-t-794 syntmp-type-793)) (if (memv syntmp-t-794 (quote (lexical))) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (global))) (values syntmp-type-793 syntmp-n-791 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789))))))))) ((pair? syntmp-e-786) (let ((syntmp-first-795 (car syntmp-e-786))) (if (syntmp-id?-115 syntmp-first-795) (let ((syntmp-n-796 (syntmp-id-var-name-137 syntmp-first-795 syntmp-w-788))) (let ((syntmp-b-797 (syntmp-lookup-112 syntmp-n-796 syntmp-r-787))) (let ((syntmp-type-798 (syntmp-binding-type-107 syntmp-b-797))) (let ((syntmp-t-799 syntmp-type-798)) (if (memv syntmp-t-799 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (global))) (values (quote global-call) syntmp-n-796 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (if (memv syntmp-t-799 (quote (core external-macro))) (values syntmp-type-798 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (begin))) (values (quote begin-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (define))) ((lambda (syntmp-tmp-800) ((lambda (syntmp-tmp-801) (if (if syntmp-tmp-801 (apply (lambda (syntmp-_-802 syntmp-name-803 syntmp-val-804) (syntmp-id?-115 syntmp-name-803)) syntmp-tmp-801) #f) (apply (lambda (syntmp-_-805 syntmp-name-806 syntmp-val-807) (values (quote define-form) syntmp-name-806 syntmp-val-807 syntmp-w-788 syntmp-s-789)) syntmp-tmp-801) ((lambda (syntmp-tmp-808) (if (if syntmp-tmp-808 (apply (lambda (syntmp-_-809 syntmp-name-810 syntmp-args-811 syntmp-e1-812 syntmp-e2-813) (and (syntmp-id?-115 syntmp-name-810) (syntmp-valid-bound-ids?-140 (syntmp-lambda-var-list-164 syntmp-args-811)))) syntmp-tmp-808) #f) (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-args-816 syntmp-e1-817 syntmp-e2-818) (values (quote define-form) (syntmp-wrap-143 syntmp-name-815 syntmp-w-788) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-143 (cons syntmp-args-816 (cons syntmp-e1-817 syntmp-e2-818)) syntmp-w-788)) (quote (())) syntmp-s-789)) syntmp-tmp-808) ((lambda (syntmp-tmp-820) (if (if syntmp-tmp-820 (apply (lambda (syntmp-_-821 syntmp-name-822) (syntmp-id?-115 syntmp-name-822)) syntmp-tmp-820) #f) (apply (lambda (syntmp-_-823 syntmp-name-824) (values (quote define-form) (syntmp-wrap-143 syntmp-name-824 syntmp-w-788) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-789)) syntmp-tmp-820) (syntax-error syntmp-tmp-800))) (syntax-dispatch syntmp-tmp-800 (quote (any any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any any any))))) syntmp-e-786) (if (memv syntmp-t-799 (quote (define-syntax))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-115 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-syntax-form) syntmp-name-831 syntmp-val-832 syntmp-w-788 syntmp-s-789)) syntmp-tmp-826) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-786) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))))))))))))) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))) ((syntmp-syntax-object?-101 syntmp-e-786) (syntmp-syntax-type-149 (syntmp-syntax-object-expression-102 syntmp-e-786) syntmp-r-787 (syntmp-join-wraps-134 syntmp-w-788 (syntmp-syntax-object-wrap-103 syntmp-e-786)) #f syntmp-rib-790)) ((annotation? syntmp-e-786) (syntmp-syntax-type-149 (annotation-expression syntmp-e-786) syntmp-r-787 syntmp-w-788 (annotation-source syntmp-e-786) syntmp-rib-790)) ((self-evaluating? syntmp-e-786) (values (quote constant) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)) (else (values (quote other) #f syntmp-e-786 syntmp-w-788 syntmp-s-789))))) (syntmp-chi-when-list-148 (lambda (syntmp-e-833 syntmp-when-list-834 syntmp-w-835) (let syntmp-f-836 ((syntmp-when-list-837 syntmp-when-list-834) (syntmp-situations-838 (quote ()))) (if (null? syntmp-when-list-837) syntmp-situations-838 (syntmp-f-836 (cdr syntmp-when-list-837) (cons (let ((syntmp-x-839 (car syntmp-when-list-837))) (cond ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-143 syntmp-x-839 syntmp-w-835) "invalid eval-when situation")))) syntmp-situations-838)))))) (syntmp-chi-install-global-147 (lambda (syntmp-name-851 syntmp-e-852) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-851) syntmp-e-852)))) (syntmp-chi-top-sequence-146 (lambda (syntmp-body-853 syntmp-r-854 syntmp-w-855 syntmp-s-856 syntmp-m-857 syntmp-esew-858) (syntmp-build-sequence-96 syntmp-s-856 (let syntmp-dobody-859 ((syntmp-body-860 syntmp-body-853) (syntmp-r-861 syntmp-r-854) (syntmp-w-862 syntmp-w-855) (syntmp-m-863 syntmp-m-857) (syntmp-esew-864 syntmp-esew-858)) (if (null? syntmp-body-860) (quote ()) (let ((syntmp-first-865 (syntmp-chi-top-150 (car syntmp-body-860) syntmp-r-861 syntmp-w-862 syntmp-m-863 syntmp-esew-864))) (cons syntmp-first-865 (syntmp-dobody-859 (cdr syntmp-body-860) syntmp-r-861 syntmp-w-862 syntmp-m-863 syntmp-esew-864)))))))) (syntmp-chi-sequence-145 (lambda (syntmp-body-866 syntmp-r-867 syntmp-w-868 syntmp-s-869) (syntmp-build-sequence-96 syntmp-s-869 (let syntmp-dobody-870 ((syntmp-body-871 syntmp-body-866) (syntmp-r-872 syntmp-r-867) (syntmp-w-873 syntmp-w-868)) (if (null? syntmp-body-871) (quote ()) (let ((syntmp-first-874 (syntmp-chi-151 (car syntmp-body-871) syntmp-r-872 syntmp-w-873))) (cons syntmp-first-874 (syntmp-dobody-870 (cdr syntmp-body-871) syntmp-r-872 syntmp-w-873)))))))) (syntmp-source-wrap-144 (lambda (syntmp-x-875 syntmp-w-876 syntmp-s-877) (syntmp-wrap-143 (if syntmp-s-877 (make-annotation syntmp-x-875 syntmp-s-877 #f) syntmp-x-875) syntmp-w-876))) (syntmp-wrap-143 (lambda (syntmp-x-878 syntmp-w-879) (cond ((and (null? (syntmp-wrap-marks-118 syntmp-w-879)) (null? (syntmp-wrap-subst-119 syntmp-w-879))) syntmp-x-878) ((syntmp-syntax-object?-101 syntmp-x-878) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-878) (syntmp-join-wraps-134 syntmp-w-879 (syntmp-syntax-object-wrap-103 syntmp-x-878)))) ((null? syntmp-x-878) syntmp-x-878) (else (syntmp-make-syntax-object-100 syntmp-x-878 syntmp-w-879))))) (syntmp-bound-id-member?-142 (lambda (syntmp-x-880 syntmp-list-881) (and (not (null? syntmp-list-881)) (or (syntmp-bound-id=?-139 syntmp-x-880 (car syntmp-list-881)) (syntmp-bound-id-member?-142 syntmp-x-880 (cdr syntmp-list-881)))))) (syntmp-distinct-bound-ids?-141 (lambda (syntmp-ids-882) (let syntmp-distinct?-883 ((syntmp-ids-884 syntmp-ids-882)) (or (null? syntmp-ids-884) (and (not (syntmp-bound-id-member?-142 (car syntmp-ids-884) (cdr syntmp-ids-884))) (syntmp-distinct?-883 (cdr syntmp-ids-884))))))) (syntmp-valid-bound-ids?-140 (lambda (syntmp-ids-885) (and (let syntmp-all-ids?-886 ((syntmp-ids-887 syntmp-ids-885)) (or (null? syntmp-ids-887) (and (syntmp-id?-115 (car syntmp-ids-887)) (syntmp-all-ids?-886 (cdr syntmp-ids-887))))) (syntmp-distinct-bound-ids?-141 syntmp-ids-885)))) (syntmp-bound-id=?-139 (lambda (syntmp-i-888 syntmp-j-889) (if (and (syntmp-syntax-object?-101 syntmp-i-888) (syntmp-syntax-object?-101 syntmp-j-889)) (and (eq? (let ((syntmp-e-890 (syntmp-syntax-object-expression-102 syntmp-i-888))) (if (annotation? syntmp-e-890) (annotation-expression syntmp-e-890) syntmp-e-890)) (let ((syntmp-e-891 (syntmp-syntax-object-expression-102 syntmp-j-889))) (if (annotation? syntmp-e-891) (annotation-expression syntmp-e-891) syntmp-e-891))) (syntmp-same-marks?-136 (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-i-888)) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-j-889)))) (eq? (let ((syntmp-e-892 syntmp-i-888)) (if (annotation? syntmp-e-892) (annotation-expression syntmp-e-892) syntmp-e-892)) (let ((syntmp-e-893 syntmp-j-889)) (if (annotation? syntmp-e-893) (annotation-expression syntmp-e-893) syntmp-e-893)))))) (syntmp-free-id=?-138 (lambda (syntmp-i-894 syntmp-j-895) (and (eq? (let ((syntmp-x-896 syntmp-i-894)) (let ((syntmp-e-897 (if (syntmp-syntax-object?-101 syntmp-x-896) (syntmp-syntax-object-expression-102 syntmp-x-896) syntmp-x-896))) (if (annotation? syntmp-e-897) (annotation-expression syntmp-e-897) syntmp-e-897))) (let ((syntmp-x-898 syntmp-j-895)) (let ((syntmp-e-899 (if (syntmp-syntax-object?-101 syntmp-x-898) (syntmp-syntax-object-expression-102 syntmp-x-898) syntmp-x-898))) (if (annotation? syntmp-e-899) (annotation-expression syntmp-e-899) syntmp-e-899)))) (eq? (syntmp-id-var-name-137 syntmp-i-894 (quote (()))) (syntmp-id-var-name-137 syntmp-j-895 (quote (()))))))) (syntmp-id-var-name-137 (lambda (syntmp-id-900 syntmp-w-901) (letrec ((syntmp-search-vector-rib-904 (lambda (syntmp-sym-915 syntmp-subst-916 syntmp-marks-917 syntmp-symnames-918 syntmp-ribcage-919) (let ((syntmp-n-920 (vector-length syntmp-symnames-918))) (let syntmp-f-921 ((syntmp-i-922 0)) (cond ((syntmp-fx=-87 syntmp-i-922 syntmp-n-920) (syntmp-search-902 syntmp-sym-915 (cdr syntmp-subst-916) syntmp-marks-917)) ((and (eq? (vector-ref syntmp-symnames-918 syntmp-i-922) syntmp-sym-915) (syntmp-same-marks?-136 syntmp-marks-917 (vector-ref (syntmp-ribcage-marks-125 syntmp-ribcage-919) syntmp-i-922))) (values (vector-ref (syntmp-ribcage-labels-126 syntmp-ribcage-919) syntmp-i-922) syntmp-marks-917)) (else (syntmp-f-921 (syntmp-fx+-85 syntmp-i-922 1)))))))) (syntmp-search-list-rib-903 (lambda (syntmp-sym-923 syntmp-subst-924 syntmp-marks-925 syntmp-symnames-926 syntmp-ribcage-927) (let syntmp-f-928 ((syntmp-symnames-929 syntmp-symnames-926) (syntmp-i-930 0)) (cond ((null? syntmp-symnames-929) (syntmp-search-902 syntmp-sym-923 (cdr syntmp-subst-924) syntmp-marks-925)) ((and (eq? (car syntmp-symnames-929) syntmp-sym-923) (syntmp-same-marks?-136 syntmp-marks-925 (list-ref (syntmp-ribcage-marks-125 syntmp-ribcage-927) syntmp-i-930))) (values (list-ref (syntmp-ribcage-labels-126 syntmp-ribcage-927) syntmp-i-930) syntmp-marks-925)) (else (syntmp-f-928 (cdr syntmp-symnames-929) (syntmp-fx+-85 syntmp-i-930 1))))))) (syntmp-search-902 (lambda (syntmp-sym-931 syntmp-subst-932 syntmp-marks-933) (if (null? syntmp-subst-932) (values #f syntmp-marks-933) (let ((syntmp-fst-934 (car syntmp-subst-932))) (if (eq? syntmp-fst-934 (quote shift)) (syntmp-search-902 syntmp-sym-931 (cdr syntmp-subst-932) (cdr syntmp-marks-933)) (let ((syntmp-symnames-935 (syntmp-ribcage-symnames-124 syntmp-fst-934))) (if (vector? syntmp-symnames-935) (syntmp-search-vector-rib-904 syntmp-sym-931 syntmp-subst-932 syntmp-marks-933 syntmp-symnames-935 syntmp-fst-934) (syntmp-search-list-rib-903 syntmp-sym-931 syntmp-subst-932 syntmp-marks-933 syntmp-symnames-935 syntmp-fst-934))))))))) (cond ((symbol? syntmp-id-900) (or (call-with-values (lambda () (syntmp-search-902 syntmp-id-900 (syntmp-wrap-subst-119 syntmp-w-901) (syntmp-wrap-marks-118 syntmp-w-901))) (lambda (syntmp-x-937 . syntmp-ignore-936) syntmp-x-937)) syntmp-id-900)) ((syntmp-syntax-object?-101 syntmp-id-900) (let ((syntmp-id-938 (let ((syntmp-e-940 (syntmp-syntax-object-expression-102 syntmp-id-900))) (if (annotation? syntmp-e-940) (annotation-expression syntmp-e-940) syntmp-e-940))) (syntmp-w1-939 (syntmp-syntax-object-wrap-103 syntmp-id-900))) (let ((syntmp-marks-941 (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-901) (syntmp-wrap-marks-118 syntmp-w1-939)))) (call-with-values (lambda () (syntmp-search-902 syntmp-id-938 (syntmp-wrap-subst-119 syntmp-w-901) syntmp-marks-941)) (lambda (syntmp-new-id-942 syntmp-marks-943) (or syntmp-new-id-942 (call-with-values (lambda () (syntmp-search-902 syntmp-id-938 (syntmp-wrap-subst-119 syntmp-w1-939) syntmp-marks-943)) (lambda (syntmp-x-945 . syntmp-ignore-944) syntmp-x-945)) syntmp-id-938)))))) ((annotation? syntmp-id-900) (let ((syntmp-id-946 (let ((syntmp-e-947 syntmp-id-900)) (if (annotation? syntmp-e-947) (annotation-expression syntmp-e-947) syntmp-e-947)))) (or (call-with-values (lambda () (syntmp-search-902 syntmp-id-946 (syntmp-wrap-subst-119 syntmp-w-901) (syntmp-wrap-marks-118 syntmp-w-901))) (lambda (syntmp-x-949 . syntmp-ignore-948) syntmp-x-949)) syntmp-id-946))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-900)))))) (syntmp-same-marks?-136 (lambda (syntmp-x-950 syntmp-y-951) (or (eq? syntmp-x-950 syntmp-y-951) (and (not (null? syntmp-x-950)) (not (null? syntmp-y-951)) (eq? (car syntmp-x-950) (car syntmp-y-951)) (syntmp-same-marks?-136 (cdr syntmp-x-950) (cdr syntmp-y-951)))))) (syntmp-join-marks-135 (lambda (syntmp-m1-952 syntmp-m2-953) (syntmp-smart-append-133 syntmp-m1-952 syntmp-m2-953))) (syntmp-join-wraps-134 (lambda (syntmp-w1-954 syntmp-w2-955) (let ((syntmp-m1-956 (syntmp-wrap-marks-118 syntmp-w1-954)) (syntmp-s1-957 (syntmp-wrap-subst-119 syntmp-w1-954))) (if (null? syntmp-m1-956) (if (null? syntmp-s1-957) syntmp-w2-955 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w2-955) (syntmp-smart-append-133 syntmp-s1-957 (syntmp-wrap-subst-119 syntmp-w2-955)))) (syntmp-make-wrap-117 (syntmp-smart-append-133 syntmp-m1-956 (syntmp-wrap-marks-118 syntmp-w2-955)) (syntmp-smart-append-133 syntmp-s1-957 (syntmp-wrap-subst-119 syntmp-w2-955))))))) (syntmp-smart-append-133 (lambda (syntmp-m1-958 syntmp-m2-959) (if (null? syntmp-m2-959) syntmp-m1-958 (append syntmp-m1-958 syntmp-m2-959)))) (syntmp-make-binding-wrap-132 (lambda (syntmp-ids-960 syntmp-labels-961 syntmp-w-962) (if (null? syntmp-ids-960) syntmp-w-962 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-962) (cons (let ((syntmp-labelvec-963 (list->vector syntmp-labels-961))) (let ((syntmp-n-964 (vector-length syntmp-labelvec-963))) (let ((syntmp-symnamevec-965 (make-vector syntmp-n-964)) (syntmp-marksvec-966 (make-vector syntmp-n-964))) (begin (let syntmp-f-967 ((syntmp-ids-968 syntmp-ids-960) (syntmp-i-969 0)) (if (not (null? syntmp-ids-968)) (call-with-values (lambda () (syntmp-id-sym-name&marks-116 (car syntmp-ids-968) syntmp-w-962)) (lambda (syntmp-symname-970 syntmp-marks-971) (begin (vector-set! syntmp-symnamevec-965 syntmp-i-969 syntmp-symname-970) (vector-set! syntmp-marksvec-966 syntmp-i-969 syntmp-marks-971) (syntmp-f-967 (cdr syntmp-ids-968) (syntmp-fx+-85 syntmp-i-969 1))))))) (syntmp-make-ribcage-122 syntmp-symnamevec-965 syntmp-marksvec-966 syntmp-labelvec-963))))) (syntmp-wrap-subst-119 syntmp-w-962)))))) (syntmp-extend-ribcage!-131 (lambda (syntmp-ribcage-972 syntmp-id-973 syntmp-label-974) (begin (syntmp-set-ribcage-symnames!-127 syntmp-ribcage-972 (cons (let ((syntmp-e-975 (syntmp-syntax-object-expression-102 syntmp-id-973))) (if (annotation? syntmp-e-975) (annotation-expression syntmp-e-975) syntmp-e-975)) (syntmp-ribcage-symnames-124 syntmp-ribcage-972))) (syntmp-set-ribcage-marks!-128 syntmp-ribcage-972 (cons (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-id-973)) (syntmp-ribcage-marks-125 syntmp-ribcage-972))) (syntmp-set-ribcage-labels!-129 syntmp-ribcage-972 (cons syntmp-label-974 (syntmp-ribcage-labels-126 syntmp-ribcage-972)))))) (syntmp-anti-mark-130 (lambda (syntmp-w-976) (syntmp-make-wrap-117 (cons #f (syntmp-wrap-marks-118 syntmp-w-976)) (cons (quote shift) (syntmp-wrap-subst-119 syntmp-w-976))))) (syntmp-set-ribcage-labels!-129 (lambda (syntmp-x-977 syntmp-update-978) (vector-set! syntmp-x-977 3 syntmp-update-978))) (syntmp-set-ribcage-marks!-128 (lambda (syntmp-x-979 syntmp-update-980) (vector-set! syntmp-x-979 2 syntmp-update-980))) (syntmp-set-ribcage-symnames!-127 (lambda (syntmp-x-981 syntmp-update-982) (vector-set! syntmp-x-981 1 syntmp-update-982))) (syntmp-ribcage-labels-126 (lambda (syntmp-x-983) (vector-ref syntmp-x-983 3))) (syntmp-ribcage-marks-125 (lambda (syntmp-x-984) (vector-ref syntmp-x-984 2))) (syntmp-ribcage-symnames-124 (lambda (syntmp-x-985) (vector-ref syntmp-x-985 1))) (syntmp-ribcage?-123 (lambda (syntmp-x-986) (and (vector? syntmp-x-986) (= (vector-length syntmp-x-986) 4) (eq? (vector-ref syntmp-x-986 0) (quote ribcage))))) (syntmp-make-ribcage-122 (lambda (syntmp-symnames-987 syntmp-marks-988 syntmp-labels-989) (vector (quote ribcage) syntmp-symnames-987 syntmp-marks-988 syntmp-labels-989))) (syntmp-gen-labels-121 (lambda (syntmp-ls-990) (if (null? syntmp-ls-990) (quote ()) (cons (syntmp-gen-label-120) (syntmp-gen-labels-121 (cdr syntmp-ls-990)))))) (syntmp-gen-label-120 (lambda () (string #\i))) (syntmp-wrap-subst-119 cdr) (syntmp-wrap-marks-118 car) (syntmp-make-wrap-117 cons) (syntmp-id-sym-name&marks-116 (lambda (syntmp-x-991 syntmp-w-992) (if (syntmp-syntax-object?-101 syntmp-x-991) (values (let ((syntmp-e-993 (syntmp-syntax-object-expression-102 syntmp-x-991))) (if (annotation? syntmp-e-993) (annotation-expression syntmp-e-993) syntmp-e-993)) (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-992) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-x-991)))) (values (let ((syntmp-e-994 syntmp-x-991)) (if (annotation? syntmp-e-994) (annotation-expression syntmp-e-994) syntmp-e-994)) (syntmp-wrap-marks-118 syntmp-w-992))))) (syntmp-id?-115 (lambda (syntmp-x-995) (cond ((symbol? syntmp-x-995) #t) ((syntmp-syntax-object?-101 syntmp-x-995) (symbol? (let ((syntmp-e-996 (syntmp-syntax-object-expression-102 syntmp-x-995))) (if (annotation? syntmp-e-996) (annotation-expression syntmp-e-996) syntmp-e-996)))) ((annotation? syntmp-x-995) (symbol? (annotation-expression syntmp-x-995))) (else #f)))) (syntmp-nonsymbol-id?-114 (lambda (syntmp-x-997) (and (syntmp-syntax-object?-101 syntmp-x-997) (symbol? (let ((syntmp-e-998 (syntmp-syntax-object-expression-102 syntmp-x-997))) (if (annotation? syntmp-e-998) (annotation-expression syntmp-e-998) syntmp-e-998)))))) (syntmp-global-extend-113 (lambda (syntmp-type-999 syntmp-sym-1000 syntmp-val-1001) (syntmp-put-global-definition-hook-92 syntmp-sym-1000 (cons syntmp-type-999 syntmp-val-1001)))) (syntmp-lookup-112 (lambda (syntmp-x-1002 syntmp-r-1003) (cond ((assq syntmp-x-1002 syntmp-r-1003) => cdr) ((symbol? syntmp-x-1002) (or (syntmp-get-global-definition-hook-93 syntmp-x-1002) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-111 (lambda (syntmp-r-1004) (if (null? syntmp-r-1004) (quote ()) (let ((syntmp-a-1005 (car syntmp-r-1004))) (if (eq? (cadr syntmp-a-1005) (quote macro)) (cons syntmp-a-1005 (syntmp-macros-only-env-111 (cdr syntmp-r-1004))) (syntmp-macros-only-env-111 (cdr syntmp-r-1004))))))) (syntmp-extend-var-env-110 (lambda (syntmp-labels-1006 syntmp-vars-1007 syntmp-r-1008) (if (null? syntmp-labels-1006) syntmp-r-1008 (syntmp-extend-var-env-110 (cdr syntmp-labels-1006) (cdr syntmp-vars-1007) (cons (cons (car syntmp-labels-1006) (cons (quote lexical) (car syntmp-vars-1007))) syntmp-r-1008))))) (syntmp-extend-env-109 (lambda (syntmp-labels-1009 syntmp-bindings-1010 syntmp-r-1011) (if (null? syntmp-labels-1009) syntmp-r-1011 (syntmp-extend-env-109 (cdr syntmp-labels-1009) (cdr syntmp-bindings-1010) (cons (cons (car syntmp-labels-1009) (car syntmp-bindings-1010)) syntmp-r-1011))))) (syntmp-binding-value-108 cdr) (syntmp-binding-type-107 car) (syntmp-source-annotation-106 (lambda (syntmp-x-1012) (cond ((annotation? syntmp-x-1012) (annotation-source syntmp-x-1012)) ((syntmp-syntax-object?-101 syntmp-x-1012) (syntmp-source-annotation-106 (syntmp-syntax-object-expression-102 syntmp-x-1012))) (else #f)))) (syntmp-set-syntax-object-wrap!-105 (lambda (syntmp-x-1013 syntmp-update-1014) (vector-set! syntmp-x-1013 2 syntmp-update-1014))) (syntmp-set-syntax-object-expression!-104 (lambda (syntmp-x-1015 syntmp-update-1016) (vector-set! syntmp-x-1015 1 syntmp-update-1016))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 3) (eq? (vector-ref syntmp-x-1019 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1020 syntmp-wrap-1021) (vector (quote syntax-object) syntmp-expression-1020 syntmp-wrap-1021))) (syntmp-build-letrec-99 (lambda (syntmp-src-1022 syntmp-vars-1023 syntmp-val-exps-1024 syntmp-body-exp-1025) (if (null? syntmp-vars-1023) (syntmp-build-annotated-94 syntmp-src-1022 syntmp-body-exp-1025) (syntmp-build-annotated-94 syntmp-src-1022 (list (quote letrec) (map list syntmp-vars-1023 syntmp-val-exps-1024) syntmp-body-exp-1025))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1026 syntmp-vars-1027 syntmp-val-exps-1028 syntmp-body-exp-1029) (if (null? syntmp-vars-1027) (syntmp-build-annotated-94 syntmp-src-1026 syntmp-body-exp-1029) (syntmp-build-annotated-94 syntmp-src-1026 (list (quote let) (car syntmp-vars-1027) (map list (cdr syntmp-vars-1027) syntmp-val-exps-1028) syntmp-body-exp-1029))))) (syntmp-build-let-97 (lambda (syntmp-src-1030 syntmp-vars-1031 syntmp-val-exps-1032 syntmp-body-exp-1033) (if (null? syntmp-vars-1031) (syntmp-build-annotated-94 syntmp-src-1030 syntmp-body-exp-1033) (syntmp-build-annotated-94 syntmp-src-1030 (list (quote let) (map list syntmp-vars-1031 syntmp-val-exps-1032) syntmp-body-exp-1033))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1034 syntmp-exps-1035) (if (null? (cdr syntmp-exps-1035)) (syntmp-build-annotated-94 syntmp-src-1034 (car syntmp-exps-1035)) (syntmp-build-annotated-94 syntmp-src-1034 (cons (quote begin) syntmp-exps-1035))))) (syntmp-build-data-95 (lambda (syntmp-src-1036 syntmp-exp-1037) (if (and (self-evaluating? syntmp-exp-1037) (not (vector? syntmp-exp-1037))) (syntmp-build-annotated-94 syntmp-src-1036 syntmp-exp-1037) (syntmp-build-annotated-94 syntmp-src-1036 (list (quote quote) syntmp-exp-1037))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1038 syntmp-exp-1039) (if (and syntmp-src-1038 (not (annotation? syntmp-exp-1039))) (make-annotation syntmp-exp-1039 syntmp-src-1038 #t) syntmp-exp-1039))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1040) (getprop syntmp-symbol-1040 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1041 syntmp-binding-1042) (putprop syntmp-symbol-1041 (quote *sc-expander*) syntmp-binding-1042))) (syntmp-error-hook-91 (lambda (syntmp-who-1043 syntmp-why-1044 syntmp-what-1045) (error syntmp-who-1043 "~a ~s" syntmp-why-1044 syntmp-what-1045))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1046) (eval (list syntmp-noexpand-84 syntmp-x-1046) (interaction-environment)))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1047) (eval (list syntmp-noexpand-84 syntmp-x-1047) (interaction-environment)))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-113 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-113 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-113 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1048 syntmp-r-1049 syntmp-w-1050 syntmp-s-1051) ((lambda (syntmp-tmp-1052) ((lambda (syntmp-tmp-1053) (if (if syntmp-tmp-1053 (apply (lambda (syntmp-_-1054 syntmp-var-1055 syntmp-val-1056 syntmp-e1-1057 syntmp-e2-1058) (syntmp-valid-bound-ids?-140 syntmp-var-1055)) syntmp-tmp-1053) #f) (apply (lambda (syntmp-_-1060 syntmp-var-1061 syntmp-val-1062 syntmp-e1-1063 syntmp-e2-1064) (let ((syntmp-names-1065 (map (lambda (syntmp-x-1066) (syntmp-id-var-name-137 syntmp-x-1066 syntmp-w-1050)) syntmp-var-1061))) (begin (for-each (lambda (syntmp-id-1068 syntmp-n-1069) (let ((syntmp-t-1070 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-1069 syntmp-r-1049)))) (if (memv syntmp-t-1070 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-id-1068 syntmp-w-1050 syntmp-s-1051) "identifier out of context")))) syntmp-var-1061 syntmp-names-1065) (syntmp-chi-body-155 (cons syntmp-e1-1063 syntmp-e2-1064) (syntmp-source-wrap-144 syntmp-e-1048 syntmp-w-1050 syntmp-s-1051) (syntmp-extend-env-109 syntmp-names-1065 (let ((syntmp-trans-r-1073 (syntmp-macros-only-env-111 syntmp-r-1049))) (map (lambda (syntmp-x-1074) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-1074 syntmp-trans-r-1073 syntmp-w-1050)))) syntmp-val-1062)) syntmp-r-1049) syntmp-w-1050)))) syntmp-tmp-1053) ((lambda (syntmp-_-1076) (syntax-error (syntmp-source-wrap-144 syntmp-e-1048 syntmp-w-1050 syntmp-s-1051))) syntmp-tmp-1052))) (syntax-dispatch syntmp-tmp-1052 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1048))) (syntmp-global-extend-113 (quote core) (quote quote) (lambda (syntmp-e-1077 syntmp-r-1078 syntmp-w-1079 syntmp-s-1080) ((lambda (syntmp-tmp-1081) ((lambda (syntmp-tmp-1082) (if syntmp-tmp-1082 (apply (lambda (syntmp-_-1083 syntmp-e-1084) (syntmp-build-data-95 syntmp-s-1080 (syntmp-strip-162 syntmp-e-1084 syntmp-w-1079))) syntmp-tmp-1082) ((lambda (syntmp-_-1085) (syntax-error (syntmp-source-wrap-144 syntmp-e-1077 syntmp-w-1079 syntmp-s-1080))) syntmp-tmp-1081))) (syntax-dispatch syntmp-tmp-1081 (quote (any any))))) syntmp-e-1077))) (syntmp-global-extend-113 (quote core) (quote syntax) (letrec ((syntmp-regen-1093 (lambda (syntmp-x-1094) (let ((syntmp-t-1095 (car syntmp-x-1094))) (if (memv syntmp-t-1095 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1094)) (if (memv syntmp-t-1095 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1094)) (if (memv syntmp-t-1095 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1094)) (if (memv syntmp-t-1095 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1094) (syntmp-regen-1093 (caddr syntmp-x-1094)))) (if (memv syntmp-t-1095 (quote (map))) (let ((syntmp-ls-1096 (map syntmp-regen-1093 (cdr syntmp-x-1094)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1096) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1096))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1094)) (map syntmp-regen-1093 (cdr syntmp-x-1094)))))))))))) (syntmp-gen-vector-1092 (lambda (syntmp-x-1097) (cond ((eq? (car syntmp-x-1097) (quote list)) (cons (quote vector) (cdr syntmp-x-1097))) ((eq? (car syntmp-x-1097) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1097)))) (else (list (quote list->vector) syntmp-x-1097))))) (syntmp-gen-append-1091 (lambda (syntmp-x-1098 syntmp-y-1099) (if (equal? syntmp-y-1099 (quote (quote ()))) syntmp-x-1098 (list (quote append) syntmp-x-1098 syntmp-y-1099)))) (syntmp-gen-cons-1090 (lambda (syntmp-x-1100 syntmp-y-1101) (let ((syntmp-t-1102 (car syntmp-y-1101))) (if (memv syntmp-t-1102 (quote (quote))) (if (eq? (car syntmp-x-1100) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1100) (cadr syntmp-y-1101))) (if (eq? (cadr syntmp-y-1101) (quote ())) (list (quote list) syntmp-x-1100) (list (quote cons) syntmp-x-1100 syntmp-y-1101))) (if (memv syntmp-t-1102 (quote (list))) (cons (quote list) (cons syntmp-x-1100 (cdr syntmp-y-1101))) (list (quote cons) syntmp-x-1100 syntmp-y-1101)))))) (syntmp-gen-map-1089 (lambda (syntmp-e-1103 syntmp-map-env-1104) (let ((syntmp-formals-1105 (map cdr syntmp-map-env-1104)) (syntmp-actuals-1106 (map (lambda (syntmp-x-1107) (list (quote ref) (car syntmp-x-1107))) syntmp-map-env-1104))) (cond ((eq? (car syntmp-e-1103) (quote ref)) (car syntmp-actuals-1106)) ((andmap (lambda (syntmp-x-1108) (and (eq? (car syntmp-x-1108) (quote ref)) (memq (cadr syntmp-x-1108) syntmp-formals-1105))) (cdr syntmp-e-1103)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1103)) (map (let ((syntmp-r-1109 (map cons syntmp-formals-1105 syntmp-actuals-1106))) (lambda (syntmp-x-1110) (cdr (assq (cadr syntmp-x-1110) syntmp-r-1109)))) (cdr syntmp-e-1103))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1105 syntmp-e-1103) syntmp-actuals-1106))))))) (syntmp-gen-mappend-1088 (lambda (syntmp-e-1111 syntmp-map-env-1112) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1089 syntmp-e-1111 syntmp-map-env-1112)))) (syntmp-gen-ref-1087 (lambda (syntmp-src-1113 syntmp-var-1114 syntmp-level-1115 syntmp-maps-1116) (if (syntmp-fx=-87 syntmp-level-1115 0) (values syntmp-var-1114 syntmp-maps-1116) (if (null? syntmp-maps-1116) (syntax-error syntmp-src-1113 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1087 syntmp-src-1113 syntmp-var-1114 (syntmp-fx--86 syntmp-level-1115 1) (cdr syntmp-maps-1116))) (lambda (syntmp-outer-var-1117 syntmp-outer-maps-1118) (let ((syntmp-b-1119 (assq syntmp-outer-var-1117 (car syntmp-maps-1116)))) (if syntmp-b-1119 (values (cdr syntmp-b-1119) syntmp-maps-1116) (let ((syntmp-inner-var-1120 (syntmp-gen-var-163 (quote tmp)))) (values syntmp-inner-var-1120 (cons (cons (cons syntmp-outer-var-1117 syntmp-inner-var-1120) (car syntmp-maps-1116)) syntmp-outer-maps-1118))))))))))) (syntmp-gen-syntax-1086 (lambda (syntmp-src-1121 syntmp-e-1122 syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125) (if (syntmp-id?-115 syntmp-e-1122) (let ((syntmp-label-1126 (syntmp-id-var-name-137 syntmp-e-1122 (quote (()))))) (let ((syntmp-b-1127 (syntmp-lookup-112 syntmp-label-1126 syntmp-r-1123))) (if (eq? (syntmp-binding-type-107 syntmp-b-1127) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1128 (syntmp-binding-value-108 syntmp-b-1127))) (syntmp-gen-ref-1087 syntmp-src-1121 (car syntmp-var.lev-1128) (cdr syntmp-var.lev-1128) syntmp-maps-1124))) (lambda (syntmp-var-1129 syntmp-maps-1130) (values (list (quote ref) syntmp-var-1129) syntmp-maps-1130))) (if (syntmp-ellipsis?-1125 syntmp-e-1122) (syntax-error syntmp-src-1121 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1122) syntmp-maps-1124))))) ((lambda (syntmp-tmp-1131) ((lambda (syntmp-tmp-1132) (if (if syntmp-tmp-1132 (apply (lambda (syntmp-dots-1133 syntmp-e-1134) (syntmp-ellipsis?-1125 syntmp-dots-1133)) syntmp-tmp-1132) #f) (apply (lambda (syntmp-dots-1135 syntmp-e-1136) (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-e-1136 syntmp-r-1123 syntmp-maps-1124 (lambda (syntmp-x-1137) #f))) syntmp-tmp-1132) ((lambda (syntmp-tmp-1138) (if (if syntmp-tmp-1138 (apply (lambda (syntmp-x-1139 syntmp-dots-1140 syntmp-y-1141) (syntmp-ellipsis?-1125 syntmp-dots-1140)) syntmp-tmp-1138) #f) (apply (lambda (syntmp-x-1142 syntmp-dots-1143 syntmp-y-1144) (let syntmp-f-1145 ((syntmp-y-1146 syntmp-y-1144) (syntmp-k-1147 (lambda (syntmp-maps-1148) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-x-1142 syntmp-r-1123 (cons (quote ()) syntmp-maps-1148) syntmp-ellipsis?-1125)) (lambda (syntmp-x-1149 syntmp-maps-1150) (if (null? (car syntmp-maps-1150)) (syntax-error syntmp-src-1121 "extra ellipsis in syntax form") (values (syntmp-gen-map-1089 syntmp-x-1149 (car syntmp-maps-1150)) (cdr syntmp-maps-1150)))))))) ((lambda (syntmp-tmp-1151) ((lambda (syntmp-tmp-1152) (if (if syntmp-tmp-1152 (apply (lambda (syntmp-dots-1153 syntmp-y-1154) (syntmp-ellipsis?-1125 syntmp-dots-1153)) syntmp-tmp-1152) #f) (apply (lambda (syntmp-dots-1155 syntmp-y-1156) (syntmp-f-1145 syntmp-y-1156 (lambda (syntmp-maps-1157) (call-with-values (lambda () (syntmp-k-1147 (cons (quote ()) syntmp-maps-1157))) (lambda (syntmp-x-1158 syntmp-maps-1159) (if (null? (car syntmp-maps-1159)) (syntax-error syntmp-src-1121 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1088 syntmp-x-1158 (car syntmp-maps-1159)) (cdr syntmp-maps-1159)))))))) syntmp-tmp-1152) ((lambda (syntmp-_-1160) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-y-1146 syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125)) (lambda (syntmp-y-1161 syntmp-maps-1162) (call-with-values (lambda () (syntmp-k-1147 syntmp-maps-1162)) (lambda (syntmp-x-1163 syntmp-maps-1164) (values (syntmp-gen-append-1091 syntmp-x-1163 syntmp-y-1161) syntmp-maps-1164)))))) syntmp-tmp-1151))) (syntax-dispatch syntmp-tmp-1151 (quote (any . any))))) syntmp-y-1146))) syntmp-tmp-1138) ((lambda (syntmp-tmp-1165) (if syntmp-tmp-1165 (apply (lambda (syntmp-x-1166 syntmp-y-1167) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-x-1166 syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125)) (lambda (syntmp-x-1168 syntmp-maps-1169) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 syntmp-y-1167 syntmp-r-1123 syntmp-maps-1169 syntmp-ellipsis?-1125)) (lambda (syntmp-y-1170 syntmp-maps-1171) (values (syntmp-gen-cons-1090 syntmp-x-1168 syntmp-y-1170) syntmp-maps-1171)))))) syntmp-tmp-1165) ((lambda (syntmp-tmp-1172) (if syntmp-tmp-1172 (apply (lambda (syntmp-e1-1173 syntmp-e2-1174) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-src-1121 (cons syntmp-e1-1173 syntmp-e2-1174) syntmp-r-1123 syntmp-maps-1124 syntmp-ellipsis?-1125)) (lambda (syntmp-e-1176 syntmp-maps-1177) (values (syntmp-gen-vector-1092 syntmp-e-1176) syntmp-maps-1177)))) syntmp-tmp-1172) ((lambda (syntmp-_-1178) (values (list (quote quote) syntmp-e-1122) syntmp-maps-1124)) syntmp-tmp-1131))) (syntax-dispatch syntmp-tmp-1131 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1131 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1131 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1131 (quote (any any))))) syntmp-e-1122))))) (lambda (syntmp-e-1179 syntmp-r-1180 syntmp-w-1181 syntmp-s-1182) (let ((syntmp-e-1183 (syntmp-source-wrap-144 syntmp-e-1179 syntmp-w-1181 syntmp-s-1182))) ((lambda (syntmp-tmp-1184) ((lambda (syntmp-tmp-1185) (if syntmp-tmp-1185 (apply (lambda (syntmp-_-1186 syntmp-x-1187) (call-with-values (lambda () (syntmp-gen-syntax-1086 syntmp-e-1183 syntmp-x-1187 syntmp-r-1180 (quote ()) syntmp-ellipsis?-160)) (lambda (syntmp-e-1188 syntmp-maps-1189) (syntmp-regen-1093 syntmp-e-1188)))) syntmp-tmp-1185) ((lambda (syntmp-_-1190) (syntax-error syntmp-e-1183)) syntmp-tmp-1184))) (syntax-dispatch syntmp-tmp-1184 (quote (any any))))) syntmp-e-1183))))) (syntmp-global-extend-113 (quote core) (quote lambda) (lambda (syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194) ((lambda (syntmp-tmp-1195) ((lambda (syntmp-tmp-1196) (if syntmp-tmp-1196 (apply (lambda (syntmp-_-1197 syntmp-c-1198) (syntmp-chi-lambda-clause-156 (syntmp-source-wrap-144 syntmp-e-1191 syntmp-w-1193 syntmp-s-1194) syntmp-c-1198 syntmp-r-1192 syntmp-w-1193 (lambda (syntmp-vars-1199 syntmp-body-1200) (syntmp-build-annotated-94 syntmp-s-1194 (list (quote lambda) syntmp-vars-1199 syntmp-body-1200))))) syntmp-tmp-1196) (syntax-error syntmp-tmp-1195))) (syntax-dispatch syntmp-tmp-1195 (quote (any . any))))) syntmp-e-1191))) (syntmp-global-extend-113 (quote core) (quote let) (letrec ((syntmp-chi-let-1201 (lambda (syntmp-e-1202 syntmp-r-1203 syntmp-w-1204 syntmp-s-1205 syntmp-constructor-1206 syntmp-ids-1207 syntmp-vals-1208 syntmp-exps-1209) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1207)) (syntax-error syntmp-e-1202 "duplicate bound variable in") (let ((syntmp-labels-1210 (syntmp-gen-labels-121 syntmp-ids-1207)) (syntmp-new-vars-1211 (map syntmp-gen-var-163 syntmp-ids-1207))) (let ((syntmp-nw-1212 (syntmp-make-binding-wrap-132 syntmp-ids-1207 syntmp-labels-1210 syntmp-w-1204)) (syntmp-nr-1213 (syntmp-extend-var-env-110 syntmp-labels-1210 syntmp-new-vars-1211 syntmp-r-1203))) (syntmp-constructor-1206 syntmp-s-1205 syntmp-new-vars-1211 (map (lambda (syntmp-x-1214) (syntmp-chi-151 syntmp-x-1214 syntmp-r-1203 syntmp-w-1204)) syntmp-vals-1208) (syntmp-chi-body-155 syntmp-exps-1209 (syntmp-source-wrap-144 syntmp-e-1202 syntmp-nw-1212 syntmp-s-1205) syntmp-nr-1213 syntmp-nw-1212)))))))) (lambda (syntmp-e-1215 syntmp-r-1216 syntmp-w-1217 syntmp-s-1218) ((lambda (syntmp-tmp-1219) ((lambda (syntmp-tmp-1220) (if syntmp-tmp-1220 (apply (lambda (syntmp-_-1221 syntmp-id-1222 syntmp-val-1223 syntmp-e1-1224 syntmp-e2-1225) (syntmp-chi-let-1201 syntmp-e-1215 syntmp-r-1216 syntmp-w-1217 syntmp-s-1218 syntmp-build-let-97 syntmp-id-1222 syntmp-val-1223 (cons syntmp-e1-1224 syntmp-e2-1225))) syntmp-tmp-1220) ((lambda (syntmp-tmp-1229) (if (if syntmp-tmp-1229 (apply (lambda (syntmp-_-1230 syntmp-f-1231 syntmp-id-1232 syntmp-val-1233 syntmp-e1-1234 syntmp-e2-1235) (syntmp-id?-115 syntmp-f-1231)) syntmp-tmp-1229) #f) (apply (lambda (syntmp-_-1236 syntmp-f-1237 syntmp-id-1238 syntmp-val-1239 syntmp-e1-1240 syntmp-e2-1241) (syntmp-chi-let-1201 syntmp-e-1215 syntmp-r-1216 syntmp-w-1217 syntmp-s-1218 syntmp-build-named-let-98 (cons syntmp-f-1237 syntmp-id-1238) syntmp-val-1239 (cons syntmp-e1-1240 syntmp-e2-1241))) syntmp-tmp-1229) ((lambda (syntmp-_-1245) (syntax-error (syntmp-source-wrap-144 syntmp-e-1215 syntmp-w-1217 syntmp-s-1218))) syntmp-tmp-1219))) (syntax-dispatch syntmp-tmp-1219 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1219 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1215)))) (syntmp-global-extend-113 (quote core) (quote letrec) (lambda (syntmp-e-1246 syntmp-r-1247 syntmp-w-1248 syntmp-s-1249) ((lambda (syntmp-tmp-1250) ((lambda (syntmp-tmp-1251) (if syntmp-tmp-1251 (apply (lambda (syntmp-_-1252 syntmp-id-1253 syntmp-val-1254 syntmp-e1-1255 syntmp-e2-1256) (let ((syntmp-ids-1257 syntmp-id-1253)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1257)) (syntax-error syntmp-e-1246 "duplicate bound variable in") (let ((syntmp-labels-1259 (syntmp-gen-labels-121 syntmp-ids-1257)) (syntmp-new-vars-1260 (map syntmp-gen-var-163 syntmp-ids-1257))) (let ((syntmp-w-1261 (syntmp-make-binding-wrap-132 syntmp-ids-1257 syntmp-labels-1259 syntmp-w-1248)) (syntmp-r-1262 (syntmp-extend-var-env-110 syntmp-labels-1259 syntmp-new-vars-1260 syntmp-r-1247))) (syntmp-build-letrec-99 syntmp-s-1249 syntmp-new-vars-1260 (map (lambda (syntmp-x-1263) (syntmp-chi-151 syntmp-x-1263 syntmp-r-1262 syntmp-w-1261)) syntmp-val-1254) (syntmp-chi-body-155 (cons syntmp-e1-1255 syntmp-e2-1256) (syntmp-source-wrap-144 syntmp-e-1246 syntmp-w-1261 syntmp-s-1249) syntmp-r-1262 syntmp-w-1261))))))) syntmp-tmp-1251) ((lambda (syntmp-_-1266) (syntax-error (syntmp-source-wrap-144 syntmp-e-1246 syntmp-w-1248 syntmp-s-1249))) syntmp-tmp-1250))) (syntax-dispatch syntmp-tmp-1250 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1246))) (syntmp-global-extend-113 (quote core) (quote set!) (lambda (syntmp-e-1267 syntmp-r-1268 syntmp-w-1269 syntmp-s-1270) ((lambda (syntmp-tmp-1271) ((lambda (syntmp-tmp-1272) (if (if syntmp-tmp-1272 (apply (lambda (syntmp-_-1273 syntmp-id-1274 syntmp-val-1275) (syntmp-id?-115 syntmp-id-1274)) syntmp-tmp-1272) #f) (apply (lambda (syntmp-_-1276 syntmp-id-1277 syntmp-val-1278) (let ((syntmp-val-1279 (syntmp-chi-151 syntmp-val-1278 syntmp-r-1268 syntmp-w-1269)) (syntmp-n-1280 (syntmp-id-var-name-137 syntmp-id-1277 syntmp-w-1269))) (let ((syntmp-b-1281 (syntmp-lookup-112 syntmp-n-1280 syntmp-r-1268))) (let ((syntmp-t-1282 (syntmp-binding-type-107 syntmp-b-1281))) (if (memv syntmp-t-1282 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1270 (list (quote set!) (syntmp-binding-value-108 syntmp-b-1281) syntmp-val-1279)) (if (memv syntmp-t-1282 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1270 (list (quote set!) (make-module-ref #f syntmp-n-1280 #f) syntmp-val-1279)) (if (memv syntmp-t-1282 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-id-1277 syntmp-w-1269) "identifier out of context") (syntax-error (syntmp-source-wrap-144 syntmp-e-1267 syntmp-w-1269 syntmp-s-1270))))))))) syntmp-tmp-1272) ((lambda (syntmp-tmp-1283) (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-getter-1285 syntmp-arg-1286 syntmp-val-1287) (syntmp-build-annotated-94 syntmp-s-1270 (cons (syntmp-chi-151 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1285) syntmp-r-1268 syntmp-w-1269) (map (lambda (syntmp-e-1288) (syntmp-chi-151 syntmp-e-1288 syntmp-r-1268 syntmp-w-1269)) (append syntmp-arg-1286 (list syntmp-val-1287)))))) syntmp-tmp-1283) ((lambda (syntmp-_-1290) (syntax-error (syntmp-source-wrap-144 syntmp-e-1267 syntmp-w-1269 syntmp-s-1270))) syntmp-tmp-1271))) (syntax-dispatch syntmp-tmp-1271 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1271 (quote (any any any))))) syntmp-e-1267))) (syntmp-global-extend-113 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-113 (quote define) (quote define) (quote ())) (syntmp-global-extend-113 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-113 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-113 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1294 (lambda (syntmp-x-1295 syntmp-keys-1296 syntmp-clauses-1297 syntmp-r-1298) (if (null? syntmp-clauses-1297) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1295)) ((lambda (syntmp-tmp-1299) ((lambda (syntmp-tmp-1300) (if syntmp-tmp-1300 (apply (lambda (syntmp-pat-1301 syntmp-exp-1302) (if (and (syntmp-id?-115 syntmp-pat-1301) (andmap (lambda (syntmp-x-1303) (not (syntmp-free-id=?-138 syntmp-pat-1301 syntmp-x-1303))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1296))) (let ((syntmp-labels-1304 (list (syntmp-gen-label-120))) (syntmp-var-1305 (syntmp-gen-var-163 syntmp-pat-1301))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1305) (syntmp-chi-151 syntmp-exp-1302 (syntmp-extend-env-109 syntmp-labels-1304 (list (cons (quote syntax) (cons syntmp-var-1305 0))) syntmp-r-1298) (syntmp-make-binding-wrap-132 (list syntmp-pat-1301) syntmp-labels-1304 (quote (())))))) syntmp-x-1295))) (syntmp-gen-clause-1293 syntmp-x-1295 syntmp-keys-1296 (cdr syntmp-clauses-1297) syntmp-r-1298 syntmp-pat-1301 #t syntmp-exp-1302))) syntmp-tmp-1300) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-pat-1307 syntmp-fender-1308 syntmp-exp-1309) (syntmp-gen-clause-1293 syntmp-x-1295 syntmp-keys-1296 (cdr syntmp-clauses-1297) syntmp-r-1298 syntmp-pat-1307 syntmp-fender-1308 syntmp-exp-1309)) syntmp-tmp-1306) ((lambda (syntmp-_-1310) (syntax-error (car syntmp-clauses-1297) "invalid syntax-case clause")) syntmp-tmp-1299))) (syntax-dispatch syntmp-tmp-1299 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1299 (quote (any any))))) (car syntmp-clauses-1297))))) (syntmp-gen-clause-1293 (lambda (syntmp-x-1311 syntmp-keys-1312 syntmp-clauses-1313 syntmp-r-1314 syntmp-pat-1315 syntmp-fender-1316 syntmp-exp-1317) (call-with-values (lambda () (syntmp-convert-pattern-1291 syntmp-pat-1315 syntmp-keys-1312)) (lambda (syntmp-p-1318 syntmp-pvars-1319) (cond ((not (syntmp-distinct-bound-ids?-141 (map car syntmp-pvars-1319))) (syntax-error syntmp-pat-1315 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1320) (not (syntmp-ellipsis?-160 (car syntmp-x-1320)))) syntmp-pvars-1319)) (syntax-error syntmp-pat-1315 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1321 (syntmp-gen-var-163 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1321) (let ((syntmp-y-1322 (syntmp-build-annotated-94 #f syntmp-y-1321))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1323) ((lambda (syntmp-tmp-1324) (if syntmp-tmp-1324 (apply (lambda () syntmp-y-1322) syntmp-tmp-1324) ((lambda (syntmp-_-1325) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1322 (syntmp-build-dispatch-call-1292 syntmp-pvars-1319 syntmp-fender-1316 syntmp-y-1322 syntmp-r-1314) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1323))) (syntax-dispatch syntmp-tmp-1323 (quote #(atom #t))))) syntmp-fender-1316) (syntmp-build-dispatch-call-1292 syntmp-pvars-1319 syntmp-exp-1317 syntmp-y-1322 syntmp-r-1314) (syntmp-gen-syntax-case-1294 syntmp-x-1311 syntmp-keys-1312 syntmp-clauses-1313 syntmp-r-1314)))))) (if (eq? syntmp-p-1318 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1311)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1311 (syntmp-build-data-95 #f syntmp-p-1318))))))))))))) (syntmp-build-dispatch-call-1292 (lambda (syntmp-pvars-1326 syntmp-exp-1327 syntmp-y-1328 syntmp-r-1329) (let ((syntmp-ids-1330 (map car syntmp-pvars-1326)) (syntmp-levels-1331 (map cdr syntmp-pvars-1326))) (let ((syntmp-labels-1332 (syntmp-gen-labels-121 syntmp-ids-1330)) (syntmp-new-vars-1333 (map syntmp-gen-var-163 syntmp-ids-1330))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1333 (syntmp-chi-151 syntmp-exp-1327 (syntmp-extend-env-109 syntmp-labels-1332 (map (lambda (syntmp-var-1334 syntmp-level-1335) (cons (quote syntax) (cons syntmp-var-1334 syntmp-level-1335))) syntmp-new-vars-1333 (map cdr syntmp-pvars-1326)) syntmp-r-1329) (syntmp-make-binding-wrap-132 syntmp-ids-1330 syntmp-labels-1332 (quote (())))))) syntmp-y-1328)))))) (syntmp-convert-pattern-1291 (lambda (syntmp-pattern-1336 syntmp-keys-1337) (let syntmp-cvt-1338 ((syntmp-p-1339 syntmp-pattern-1336) (syntmp-n-1340 0) (syntmp-ids-1341 (quote ()))) (if (syntmp-id?-115 syntmp-p-1339) (if (syntmp-bound-id-member?-142 syntmp-p-1339 syntmp-keys-1337) (values (vector (quote free-id) syntmp-p-1339) syntmp-ids-1341) (values (quote any) (cons (cons syntmp-p-1339 syntmp-n-1340) syntmp-ids-1341))) ((lambda (syntmp-tmp-1342) ((lambda (syntmp-tmp-1343) (if (if syntmp-tmp-1343 (apply (lambda (syntmp-x-1344 syntmp-dots-1345) (syntmp-ellipsis?-160 syntmp-dots-1345)) syntmp-tmp-1343) #f) (apply (lambda (syntmp-x-1346 syntmp-dots-1347) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-x-1346 (syntmp-fx+-85 syntmp-n-1340 1) syntmp-ids-1341)) (lambda (syntmp-p-1348 syntmp-ids-1349) (values (if (eq? syntmp-p-1348 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1348)) syntmp-ids-1349)))) syntmp-tmp-1343) ((lambda (syntmp-tmp-1350) (if syntmp-tmp-1350 (apply (lambda (syntmp-x-1351 syntmp-y-1352) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-y-1352 syntmp-n-1340 syntmp-ids-1341)) (lambda (syntmp-y-1353 syntmp-ids-1354) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-x-1351 syntmp-n-1340 syntmp-ids-1354)) (lambda (syntmp-x-1355 syntmp-ids-1356) (values (cons syntmp-x-1355 syntmp-y-1353) syntmp-ids-1356)))))) syntmp-tmp-1350) ((lambda (syntmp-tmp-1357) (if syntmp-tmp-1357 (apply (lambda () (values (quote ()) syntmp-ids-1341)) syntmp-tmp-1357) ((lambda (syntmp-tmp-1358) (if syntmp-tmp-1358 (apply (lambda (syntmp-x-1359) (call-with-values (lambda () (syntmp-cvt-1338 syntmp-x-1359 syntmp-n-1340 syntmp-ids-1341)) (lambda (syntmp-p-1361 syntmp-ids-1362) (values (vector (quote vector) syntmp-p-1361) syntmp-ids-1362)))) syntmp-tmp-1358) ((lambda (syntmp-x-1363) (values (vector (quote atom) (syntmp-strip-162 syntmp-p-1339 (quote (())))) syntmp-ids-1341)) syntmp-tmp-1342))) (syntax-dispatch syntmp-tmp-1342 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1342 (quote ()))))) (syntax-dispatch syntmp-tmp-1342 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1342 (quote (any any))))) syntmp-p-1339)))))) (lambda (syntmp-e-1364 syntmp-r-1365 syntmp-w-1366 syntmp-s-1367) (let ((syntmp-e-1368 (syntmp-source-wrap-144 syntmp-e-1364 syntmp-w-1366 syntmp-s-1367))) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-val-1372 syntmp-key-1373 syntmp-m-1374) (if (andmap (lambda (syntmp-x-1375) (and (syntmp-id?-115 syntmp-x-1375) (not (syntmp-ellipsis?-160 syntmp-x-1375)))) syntmp-key-1373) (let ((syntmp-x-1377 (syntmp-gen-var-163 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1367 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1377) (syntmp-gen-syntax-case-1294 (syntmp-build-annotated-94 #f syntmp-x-1377) syntmp-key-1373 syntmp-m-1374 syntmp-r-1365))) (syntmp-chi-151 syntmp-val-1372 syntmp-r-1365 (quote (())))))) (syntax-error syntmp-e-1368 "invalid literals list in"))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any any each-any . each-any))))) syntmp-e-1368))))) (set! sc-expand (let ((syntmp-m-1380 (quote e)) (syntmp-esew-1381 (quote (eval)))) (lambda (syntmp-x-1382) (if (and (pair? syntmp-x-1382) (equal? (car syntmp-x-1382) syntmp-noexpand-84)) (cadr syntmp-x-1382) (syntmp-chi-top-150 syntmp-x-1382 (quote ()) (quote ((top))) syntmp-m-1380 syntmp-esew-1381))))) (set! sc-expand3 (let ((syntmp-m-1383 (quote e)) (syntmp-esew-1384 (quote (eval)))) (lambda (syntmp-x-1386 . syntmp-rest-1385) (if (and (pair? syntmp-x-1386) (equal? (car syntmp-x-1386) syntmp-noexpand-84)) (cadr syntmp-x-1386) (syntmp-chi-top-150 syntmp-x-1386 (quote ()) (quote ((top))) (if (null? syntmp-rest-1385) syntmp-m-1383 (car syntmp-rest-1385)) (if (or (null? syntmp-rest-1385) (null? (cdr syntmp-rest-1385))) syntmp-esew-1384 (cadr syntmp-rest-1385))))))) (set! identifier? (lambda (syntmp-x-1387) (syntmp-nonsymbol-id?-114 syntmp-x-1387))) (set! datum->syntax-object (lambda (syntmp-id-1388 syntmp-datum-1389) (syntmp-make-syntax-object-100 syntmp-datum-1389 (syntmp-syntax-object-wrap-103 syntmp-id-1388)))) (set! syntax-object->datum (lambda (syntmp-x-1390) (syntmp-strip-162 syntmp-x-1390 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1391) (begin (let ((syntmp-x-1392 syntmp-ls-1391)) (if (not (list? syntmp-x-1392)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1392))) (map (lambda (syntmp-x-1393) (syntmp-wrap-143 (gensym) (quote ((top))))) syntmp-ls-1391)))) (set! free-identifier=? (lambda (syntmp-x-1394 syntmp-y-1395) (begin (let ((syntmp-x-1396 syntmp-x-1394)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1396)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1396))) (let ((syntmp-x-1397 syntmp-y-1395)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1397)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1397))) (syntmp-free-id=?-138 syntmp-x-1394 syntmp-y-1395)))) (set! bound-identifier=? (lambda (syntmp-x-1398 syntmp-y-1399) (begin (let ((syntmp-x-1400 syntmp-x-1398)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1400)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1400))) (let ((syntmp-x-1401 syntmp-y-1399)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1401)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1401))) (syntmp-bound-id=?-139 syntmp-x-1398 syntmp-y-1399)))) (set! syntax-error (lambda (syntmp-object-1403 . syntmp-messages-1402) (begin (for-each (lambda (syntmp-x-1404) (let ((syntmp-x-1405 syntmp-x-1404)) (if (not (string? syntmp-x-1405)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1405)))) syntmp-messages-1402) (let ((syntmp-message-1406 (if (null? syntmp-messages-1402) "invalid syntax" (apply string-append syntmp-messages-1402)))) (syntmp-error-hook-91 #f syntmp-message-1406 (syntmp-strip-162 syntmp-object-1403 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1407 syntmp-v-1408) (begin (let ((syntmp-x-1409 syntmp-sym-1407)) (if (not (symbol? syntmp-x-1409)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1409))) (let ((syntmp-x-1410 syntmp-v-1408)) (if (not (procedure? syntmp-x-1410)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1410))) (syntmp-global-extend-113 (quote macro) syntmp-sym-1407 syntmp-v-1408)))) (letrec ((syntmp-match-1415 (lambda (syntmp-e-1416 syntmp-p-1417 syntmp-w-1418 syntmp-r-1419) (cond ((not syntmp-r-1419) #f) ((eq? syntmp-p-1417 (quote any)) (cons (syntmp-wrap-143 syntmp-e-1416 syntmp-w-1418) syntmp-r-1419)) ((syntmp-syntax-object?-101 syntmp-e-1416) (syntmp-match*-1414 (let ((syntmp-e-1420 (syntmp-syntax-object-expression-102 syntmp-e-1416))) (if (annotation? syntmp-e-1420) (annotation-expression syntmp-e-1420) syntmp-e-1420)) syntmp-p-1417 (syntmp-join-wraps-134 syntmp-w-1418 (syntmp-syntax-object-wrap-103 syntmp-e-1416)) syntmp-r-1419)) (else (syntmp-match*-1414 (let ((syntmp-e-1421 syntmp-e-1416)) (if (annotation? syntmp-e-1421) (annotation-expression syntmp-e-1421) syntmp-e-1421)) syntmp-p-1417 syntmp-w-1418 syntmp-r-1419))))) (syntmp-match*-1414 (lambda (syntmp-e-1422 syntmp-p-1423 syntmp-w-1424 syntmp-r-1425) (cond ((null? syntmp-p-1423) (and (null? syntmp-e-1422) syntmp-r-1425)) ((pair? syntmp-p-1423) (and (pair? syntmp-e-1422) (syntmp-match-1415 (car syntmp-e-1422) (car syntmp-p-1423) syntmp-w-1424 (syntmp-match-1415 (cdr syntmp-e-1422) (cdr syntmp-p-1423) syntmp-w-1424 syntmp-r-1425)))) ((eq? syntmp-p-1423 (quote each-any)) (let ((syntmp-l-1426 (syntmp-match-each-any-1412 syntmp-e-1422 syntmp-w-1424))) (and syntmp-l-1426 (cons syntmp-l-1426 syntmp-r-1425)))) (else (let ((syntmp-t-1427 (vector-ref syntmp-p-1423 0))) (if (memv syntmp-t-1427 (quote (each))) (if (null? syntmp-e-1422) (syntmp-match-empty-1413 (vector-ref syntmp-p-1423 1) syntmp-r-1425) (let ((syntmp-l-1428 (syntmp-match-each-1411 syntmp-e-1422 (vector-ref syntmp-p-1423 1) syntmp-w-1424))) (and syntmp-l-1428 (let syntmp-collect-1429 ((syntmp-l-1430 syntmp-l-1428)) (if (null? (car syntmp-l-1430)) syntmp-r-1425 (cons (map car syntmp-l-1430) (syntmp-collect-1429 (map cdr syntmp-l-1430)))))))) (if (memv syntmp-t-1427 (quote (free-id))) (and (syntmp-id?-115 syntmp-e-1422) (syntmp-free-id=?-138 (syntmp-wrap-143 syntmp-e-1422 syntmp-w-1424) (vector-ref syntmp-p-1423 1)) syntmp-r-1425) (if (memv syntmp-t-1427 (quote (atom))) (and (equal? (vector-ref syntmp-p-1423 1) (syntmp-strip-162 syntmp-e-1422 syntmp-w-1424)) syntmp-r-1425) (if (memv syntmp-t-1427 (quote (vector))) (and (vector? syntmp-e-1422) (syntmp-match-1415 (vector->list syntmp-e-1422) (vector-ref syntmp-p-1423 1) syntmp-w-1424 syntmp-r-1425))))))))))) (syntmp-match-empty-1413 (lambda (syntmp-p-1431 syntmp-r-1432) (cond ((null? syntmp-p-1431) syntmp-r-1432) ((eq? syntmp-p-1431 (quote any)) (cons (quote ()) syntmp-r-1432)) ((pair? syntmp-p-1431) (syntmp-match-empty-1413 (car syntmp-p-1431) (syntmp-match-empty-1413 (cdr syntmp-p-1431) syntmp-r-1432))) ((eq? syntmp-p-1431 (quote each-any)) (cons (quote ()) syntmp-r-1432)) (else (let ((syntmp-t-1433 (vector-ref syntmp-p-1431 0))) (if (memv syntmp-t-1433 (quote (each))) (syntmp-match-empty-1413 (vector-ref syntmp-p-1431 1) syntmp-r-1432) (if (memv syntmp-t-1433 (quote (free-id atom))) syntmp-r-1432 (if (memv syntmp-t-1433 (quote (vector))) (syntmp-match-empty-1413 (vector-ref syntmp-p-1431 1) syntmp-r-1432))))))))) (syntmp-match-each-any-1412 (lambda (syntmp-e-1434 syntmp-w-1435) (cond ((annotation? syntmp-e-1434) (syntmp-match-each-any-1412 (annotation-expression syntmp-e-1434) syntmp-w-1435)) ((pair? syntmp-e-1434) (let ((syntmp-l-1436 (syntmp-match-each-any-1412 (cdr syntmp-e-1434) syntmp-w-1435))) (and syntmp-l-1436 (cons (syntmp-wrap-143 (car syntmp-e-1434) syntmp-w-1435) syntmp-l-1436)))) ((null? syntmp-e-1434) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1434) (syntmp-match-each-any-1412 (syntmp-syntax-object-expression-102 syntmp-e-1434) (syntmp-join-wraps-134 syntmp-w-1435 (syntmp-syntax-object-wrap-103 syntmp-e-1434)))) (else #f)))) (syntmp-match-each-1411 (lambda (syntmp-e-1437 syntmp-p-1438 syntmp-w-1439) (cond ((annotation? syntmp-e-1437) (syntmp-match-each-1411 (annotation-expression syntmp-e-1437) syntmp-p-1438 syntmp-w-1439)) ((pair? syntmp-e-1437) (let ((syntmp-first-1440 (syntmp-match-1415 (car syntmp-e-1437) syntmp-p-1438 syntmp-w-1439 (quote ())))) (and syntmp-first-1440 (let ((syntmp-rest-1441 (syntmp-match-each-1411 (cdr syntmp-e-1437) syntmp-p-1438 syntmp-w-1439))) (and syntmp-rest-1441 (cons syntmp-first-1440 syntmp-rest-1441)))))) ((null? syntmp-e-1437) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1437) (syntmp-match-each-1411 (syntmp-syntax-object-expression-102 syntmp-e-1437) syntmp-p-1438 (syntmp-join-wraps-134 syntmp-w-1439 (syntmp-syntax-object-wrap-103 syntmp-e-1437)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1442 syntmp-p-1443) (cond ((eq? syntmp-p-1443 (quote any)) (list syntmp-e-1442)) ((syntmp-syntax-object?-101 syntmp-e-1442) (syntmp-match*-1414 (let ((syntmp-e-1444 (syntmp-syntax-object-expression-102 syntmp-e-1442))) (if (annotation? syntmp-e-1444) (annotation-expression syntmp-e-1444) syntmp-e-1444)) syntmp-p-1443 (syntmp-syntax-object-wrap-103 syntmp-e-1442) (quote ()))) (else (syntmp-match*-1414 (let ((syntmp-e-1445 syntmp-e-1442)) (if (annotation? syntmp-e-1445) (annotation-expression syntmp-e-1445) syntmp-e-1445)) syntmp-p-1443 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-151))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1446) ((lambda (syntmp-tmp-1447) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda (syntmp-_-1449 syntmp-e1-1450 syntmp-e2-1451) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1450 syntmp-e2-1451))) syntmp-tmp-1448) ((lambda (syntmp-tmp-1453) (if syntmp-tmp-1453 (apply (lambda (syntmp-_-1454 syntmp-out-1455 syntmp-in-1456 syntmp-e1-1457 syntmp-e2-1458) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1456 (quote ()) (list syntmp-out-1455 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1457 syntmp-e2-1458))))) syntmp-tmp-1453) ((lambda (syntmp-tmp-1460) (if syntmp-tmp-1460 (apply (lambda (syntmp-_-1461 syntmp-out-1462 syntmp-in-1463 syntmp-e1-1464 syntmp-e2-1465) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1463) (quote ()) (list syntmp-out-1462 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1464 syntmp-e2-1465))))) syntmp-tmp-1460) (syntax-error syntmp-tmp-1447))) (syntax-dispatch syntmp-tmp-1447 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1447 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1447 (quote (any () any . each-any))))) syntmp-x-1446))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1487) ((lambda (syntmp-tmp-1488) ((lambda (syntmp-tmp-1489) (if syntmp-tmp-1489 (apply (lambda (syntmp-_-1490 syntmp-k-1491 syntmp-keyword-1492 syntmp-pattern-1493 syntmp-template-1494) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1491 (map (lambda (syntmp-tmp-1497 syntmp-tmp-1496) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1496) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1497))) syntmp-template-1494 syntmp-pattern-1493)))))) syntmp-tmp-1489) (syntax-error syntmp-tmp-1488))) (syntax-dispatch syntmp-tmp-1488 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1487))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1508) ((lambda (syntmp-tmp-1509) ((lambda (syntmp-tmp-1510) (if (if syntmp-tmp-1510 (apply (lambda (syntmp-let*-1511 syntmp-x-1512 syntmp-v-1513 syntmp-e1-1514 syntmp-e2-1515) (andmap identifier? syntmp-x-1512)) syntmp-tmp-1510) #f) (apply (lambda (syntmp-let*-1517 syntmp-x-1518 syntmp-v-1519 syntmp-e1-1520 syntmp-e2-1521) (let syntmp-f-1522 ((syntmp-bindings-1523 (map list syntmp-x-1518 syntmp-v-1519))) (if (null? syntmp-bindings-1523) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1520 syntmp-e2-1521))) ((lambda (syntmp-tmp-1527) ((lambda (syntmp-tmp-1528) (if syntmp-tmp-1528 (apply (lambda (syntmp-body-1529 syntmp-binding-1530) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1530) syntmp-body-1529)) syntmp-tmp-1528) (syntax-error syntmp-tmp-1527))) (syntax-dispatch syntmp-tmp-1527 (quote (any any))))) (list (syntmp-f-1522 (cdr syntmp-bindings-1523)) (car syntmp-bindings-1523)))))) syntmp-tmp-1510) (syntax-error syntmp-tmp-1509))) (syntax-dispatch syntmp-tmp-1509 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1508))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1550) ((lambda (syntmp-tmp-1551) ((lambda (syntmp-tmp-1552) (if syntmp-tmp-1552 (apply (lambda (syntmp-_-1553 syntmp-var-1554 syntmp-init-1555 syntmp-step-1556 syntmp-e0-1557 syntmp-e1-1558 syntmp-c-1559) ((lambda (syntmp-tmp-1560) ((lambda (syntmp-tmp-1561) (if syntmp-tmp-1561 (apply (lambda (syntmp-step-1562) ((lambda (syntmp-tmp-1563) ((lambda (syntmp-tmp-1564) (if syntmp-tmp-1564 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1554 syntmp-init-1555) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1557) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1559 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1562))))))) syntmp-tmp-1564) ((lambda (syntmp-tmp-1569) (if syntmp-tmp-1569 (apply (lambda (syntmp-e1-1570 syntmp-e2-1571) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1554 syntmp-init-1555) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1557 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1570 syntmp-e2-1571)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1559 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1562))))))) syntmp-tmp-1569) (syntax-error syntmp-tmp-1563))) (syntax-dispatch syntmp-tmp-1563 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1563 (quote ())))) syntmp-e1-1558)) syntmp-tmp-1561) (syntax-error syntmp-tmp-1560))) (syntax-dispatch syntmp-tmp-1560 (quote each-any)))) (map (lambda (syntmp-v-1578 syntmp-s-1579) ((lambda (syntmp-tmp-1580) ((lambda (syntmp-tmp-1581) (if syntmp-tmp-1581 (apply (lambda () syntmp-v-1578) syntmp-tmp-1581) ((lambda (syntmp-tmp-1582) (if syntmp-tmp-1582 (apply (lambda (syntmp-e-1583) syntmp-e-1583) syntmp-tmp-1582) ((lambda (syntmp-_-1584) (syntax-error syntmp-orig-x-1550)) syntmp-tmp-1580))) (syntax-dispatch syntmp-tmp-1580 (quote (any)))))) (syntax-dispatch syntmp-tmp-1580 (quote ())))) syntmp-s-1579)) syntmp-var-1554 syntmp-step-1556))) syntmp-tmp-1552) (syntax-error syntmp-tmp-1551))) (syntax-dispatch syntmp-tmp-1551 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1550))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1612 (lambda (syntmp-x-1616 syntmp-y-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-tmp-1619) (if syntmp-tmp-1619 (apply (lambda (syntmp-x-1620 syntmp-y-1621) ((lambda (syntmp-tmp-1622) ((lambda (syntmp-tmp-1623) (if syntmp-tmp-1623 (apply (lambda (syntmp-dy-1624) ((lambda (syntmp-tmp-1625) ((lambda (syntmp-tmp-1626) (if syntmp-tmp-1626 (apply (lambda (syntmp-dx-1627) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1627 syntmp-dy-1624))) syntmp-tmp-1626) ((lambda (syntmp-_-1628) (if (null? syntmp-dy-1624) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1620) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1620 syntmp-y-1621))) syntmp-tmp-1625))) (syntax-dispatch syntmp-tmp-1625 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1620)) syntmp-tmp-1623) ((lambda (syntmp-tmp-1629) (if syntmp-tmp-1629 (apply (lambda (syntmp-stuff-1630) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1620 syntmp-stuff-1630))) syntmp-tmp-1629) ((lambda (syntmp-else-1631) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1620 syntmp-y-1621)) syntmp-tmp-1622))) (syntax-dispatch syntmp-tmp-1622 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1622 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1621)) syntmp-tmp-1619) (syntax-error syntmp-tmp-1618))) (syntax-dispatch syntmp-tmp-1618 (quote (any any))))) (list syntmp-x-1616 syntmp-y-1617)))) (syntmp-quasiappend-1613 (lambda (syntmp-x-1632 syntmp-y-1633) ((lambda (syntmp-tmp-1634) ((lambda (syntmp-tmp-1635) (if syntmp-tmp-1635 (apply (lambda (syntmp-x-1636 syntmp-y-1637) ((lambda (syntmp-tmp-1638) ((lambda (syntmp-tmp-1639) (if syntmp-tmp-1639 (apply (lambda () syntmp-x-1636) syntmp-tmp-1639) ((lambda (syntmp-_-1640) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1636 syntmp-y-1637)) syntmp-tmp-1638))) (syntax-dispatch syntmp-tmp-1638 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1637)) syntmp-tmp-1635) (syntax-error syntmp-tmp-1634))) (syntax-dispatch syntmp-tmp-1634 (quote (any any))))) (list syntmp-x-1632 syntmp-y-1633)))) (syntmp-quasivector-1614 (lambda (syntmp-x-1641) ((lambda (syntmp-tmp-1642) ((lambda (syntmp-x-1643) ((lambda (syntmp-tmp-1644) ((lambda (syntmp-tmp-1645) (if syntmp-tmp-1645 (apply (lambda (syntmp-x-1646) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1646))) syntmp-tmp-1645) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-x-1649) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1649)) syntmp-tmp-1648) ((lambda (syntmp-_-1651) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1643)) syntmp-tmp-1644))) (syntax-dispatch syntmp-tmp-1644 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1644 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1643)) syntmp-tmp-1642)) syntmp-x-1641))) (syntmp-quasi-1615 (lambda (syntmp-p-1652 syntmp-lev-1653) ((lambda (syntmp-tmp-1654) ((lambda (syntmp-tmp-1655) (if syntmp-tmp-1655 (apply (lambda (syntmp-p-1656) (if (= syntmp-lev-1653 0) syntmp-p-1656 (syntmp-quasicons-1612 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1615 (list syntmp-p-1656) (- syntmp-lev-1653 1))))) syntmp-tmp-1655) ((lambda (syntmp-tmp-1657) (if syntmp-tmp-1657 (apply (lambda (syntmp-p-1658 syntmp-q-1659) (if (= syntmp-lev-1653 0) (syntmp-quasiappend-1613 syntmp-p-1658 (syntmp-quasi-1615 syntmp-q-1659 syntmp-lev-1653)) (syntmp-quasicons-1612 (syntmp-quasicons-1612 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1615 (list syntmp-p-1658) (- syntmp-lev-1653 1))) (syntmp-quasi-1615 syntmp-q-1659 syntmp-lev-1653)))) syntmp-tmp-1657) ((lambda (syntmp-tmp-1660) (if syntmp-tmp-1660 (apply (lambda (syntmp-p-1661) (syntmp-quasicons-1612 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1615 (list syntmp-p-1661) (+ syntmp-lev-1653 1)))) syntmp-tmp-1660) ((lambda (syntmp-tmp-1662) (if syntmp-tmp-1662 (apply (lambda (syntmp-p-1663 syntmp-q-1664) (syntmp-quasicons-1612 (syntmp-quasi-1615 syntmp-p-1663 syntmp-lev-1653) (syntmp-quasi-1615 syntmp-q-1664 syntmp-lev-1653))) syntmp-tmp-1662) ((lambda (syntmp-tmp-1665) (if syntmp-tmp-1665 (apply (lambda (syntmp-x-1666) (syntmp-quasivector-1614 (syntmp-quasi-1615 syntmp-x-1666 syntmp-lev-1653))) syntmp-tmp-1665) ((lambda (syntmp-p-1668) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1668)) syntmp-tmp-1654))) (syntax-dispatch syntmp-tmp-1654 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1654 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1654 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1654 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1654 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1652)))) (lambda (syntmp-x-1669) ((lambda (syntmp-tmp-1670) ((lambda (syntmp-tmp-1671) (if syntmp-tmp-1671 (apply (lambda (syntmp-_-1672 syntmp-e-1673) (syntmp-quasi-1615 syntmp-e-1673 0)) syntmp-tmp-1671) (syntax-error syntmp-tmp-1670))) (syntax-dispatch syntmp-tmp-1670 (quote (any any))))) syntmp-x-1669)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1733) (letrec ((syntmp-read-file-1734 (lambda (syntmp-fn-1735 syntmp-k-1736) (let ((syntmp-p-1737 (open-input-file syntmp-fn-1735))) (let syntmp-f-1738 ((syntmp-x-1739 (read syntmp-p-1737))) (if (eof-object? syntmp-x-1739) (begin (close-input-port syntmp-p-1737) (quote ())) (cons (datum->syntax-object syntmp-k-1736 syntmp-x-1739) (syntmp-f-1738 (read syntmp-p-1737))))))))) ((lambda (syntmp-tmp-1740) ((lambda (syntmp-tmp-1741) (if syntmp-tmp-1741 (apply (lambda (syntmp-k-1742 syntmp-filename-1743) (let ((syntmp-fn-1744 (syntax-object->datum syntmp-filename-1743))) ((lambda (syntmp-tmp-1745) ((lambda (syntmp-tmp-1746) (if syntmp-tmp-1746 (apply (lambda (syntmp-exp-1747) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1747)) syntmp-tmp-1746) (syntax-error syntmp-tmp-1745))) (syntax-dispatch syntmp-tmp-1745 (quote each-any)))) (syntmp-read-file-1734 syntmp-fn-1744 syntmp-k-1742)))) syntmp-tmp-1741) (syntax-error syntmp-tmp-1740))) (syntax-dispatch syntmp-tmp-1740 (quote (any any))))) syntmp-x-1733)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1764) ((lambda (syntmp-tmp-1765) ((lambda (syntmp-tmp-1766) (if syntmp-tmp-1766 (apply (lambda (syntmp-_-1767 syntmp-e-1768) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1768))) syntmp-tmp-1766) (syntax-error syntmp-tmp-1765))) (syntax-dispatch syntmp-tmp-1765 (quote (any any))))) syntmp-x-1764))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1774) ((lambda (syntmp-tmp-1775) ((lambda (syntmp-tmp-1776) (if syntmp-tmp-1776 (apply (lambda (syntmp-_-1777 syntmp-e-1778) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1778))) syntmp-tmp-1776) (syntax-error syntmp-tmp-1775))) (syntax-dispatch syntmp-tmp-1775 (quote (any any))))) syntmp-x-1774))) -(install-global-transformer (quote case) (lambda (syntmp-x-1784) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-tmp-1786) (if syntmp-tmp-1786 (apply (lambda (syntmp-_-1787 syntmp-e-1788 syntmp-m1-1789 syntmp-m2-1790) ((lambda (syntmp-tmp-1791) ((lambda (syntmp-body-1792) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1788)) syntmp-body-1792)) syntmp-tmp-1791)) (let syntmp-f-1793 ((syntmp-clause-1794 syntmp-m1-1789) (syntmp-clauses-1795 syntmp-m2-1790)) (if (null? syntmp-clauses-1795) ((lambda (syntmp-tmp-1797) ((lambda (syntmp-tmp-1798) (if syntmp-tmp-1798 (apply (lambda (syntmp-e1-1799 syntmp-e2-1800) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1799 syntmp-e2-1800))) syntmp-tmp-1798) ((lambda (syntmp-tmp-1802) (if syntmp-tmp-1802 (apply (lambda (syntmp-k-1803 syntmp-e1-1804 syntmp-e2-1805) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1803)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1804 syntmp-e2-1805)))) syntmp-tmp-1802) ((lambda (syntmp-_-1808) (syntax-error syntmp-x-1784)) syntmp-tmp-1797))) (syntax-dispatch syntmp-tmp-1797 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1797 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1794) ((lambda (syntmp-tmp-1809) ((lambda (syntmp-rest-1810) ((lambda (syntmp-tmp-1811) ((lambda (syntmp-tmp-1812) (if syntmp-tmp-1812 (apply (lambda (syntmp-k-1813 syntmp-e1-1814 syntmp-e2-1815) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1813)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1814 syntmp-e2-1815)) syntmp-rest-1810)) syntmp-tmp-1812) ((lambda (syntmp-_-1818) (syntax-error syntmp-x-1784)) syntmp-tmp-1811))) (syntax-dispatch syntmp-tmp-1811 (quote (each-any any . each-any))))) syntmp-clause-1794)) syntmp-tmp-1809)) (syntmp-f-1793 (car syntmp-clauses-1795) (cdr syntmp-clauses-1795))))))) syntmp-tmp-1786) (syntax-error syntmp-tmp-1785))) (syntax-dispatch syntmp-tmp-1785 (quote (any any any . each-any))))) syntmp-x-1784))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1848) ((lambda (syntmp-tmp-1849) ((lambda (syntmp-tmp-1850) (if syntmp-tmp-1850 (apply (lambda (syntmp-_-1851 syntmp-e-1852) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1852)) (list (cons syntmp-_-1851 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1852 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1850) (syntax-error syntmp-tmp-1849))) (syntax-dispatch syntmp-tmp-1849 (quote (any any))))) syntmp-x-1848))) +(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-538) (let syntmp-lvl-539 ((syntmp-vars-540 syntmp-vars-538) (syntmp-ls-541 (quote ())) (syntmp-w-542 (quote (())))) (cond ((pair? syntmp-vars-540) (syntmp-lvl-539 (cdr syntmp-vars-540) (cons (syntmp-wrap-132 (car syntmp-vars-540) syntmp-w-542) syntmp-ls-541) syntmp-w-542)) ((syntmp-id?-104 syntmp-vars-540) (cons (syntmp-wrap-132 syntmp-vars-540 syntmp-w-542) syntmp-ls-541)) ((null? syntmp-vars-540) syntmp-ls-541) ((syntmp-syntax-object?-88 syntmp-vars-540) (syntmp-lvl-539 (syntmp-syntax-object-expression-89 syntmp-vars-540) syntmp-ls-541 (syntmp-join-wraps-123 syntmp-w-542 (syntmp-syntax-object-wrap-90 syntmp-vars-540)))) ((annotation? syntmp-vars-540) (syntmp-lvl-539 (annotation-expression syntmp-vars-540) syntmp-ls-541 syntmp-w-542)) (else (cons syntmp-vars-540 syntmp-ls-541)))))) (syntmp-gen-var-152 (lambda (syntmp-id-543) (let ((syntmp-id-544 (if (syntmp-syntax-object?-88 syntmp-id-543) (syntmp-syntax-object-expression-89 syntmp-id-543) syntmp-id-543))) (if (annotation? syntmp-id-544) (syntmp-build-annotated-81 (annotation-source syntmp-id-544) (gensym (symbol->string (annotation-expression syntmp-id-544)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-544))))))) (syntmp-strip-151 (lambda (syntmp-x-545 syntmp-w-546) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-546)) (if (or (annotation? syntmp-x-545) (and (pair? syntmp-x-545) (annotation? (car syntmp-x-545)))) (syntmp-strip-annotation-150 syntmp-x-545 #f) syntmp-x-545) (let syntmp-f-547 ((syntmp-x-548 syntmp-x-545)) (cond ((syntmp-syntax-object?-88 syntmp-x-548) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-548) (syntmp-syntax-object-wrap-90 syntmp-x-548))) ((pair? syntmp-x-548) (let ((syntmp-a-549 (syntmp-f-547 (car syntmp-x-548))) (syntmp-d-550 (syntmp-f-547 (cdr syntmp-x-548)))) (if (and (eq? syntmp-a-549 (car syntmp-x-548)) (eq? syntmp-d-550 (cdr syntmp-x-548))) syntmp-x-548 (cons syntmp-a-549 syntmp-d-550)))) ((vector? syntmp-x-548) (let ((syntmp-old-551 (vector->list syntmp-x-548))) (let ((syntmp-new-552 (map syntmp-f-547 syntmp-old-551))) (if (andmap eq? syntmp-old-551 syntmp-new-552) syntmp-x-548 (list->vector syntmp-new-552))))) (else syntmp-x-548)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-553 syntmp-parent-554) (cond ((pair? syntmp-x-553) (let ((syntmp-new-555 (cons #f #f))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-555)) (set-car! syntmp-new-555 (syntmp-strip-annotation-150 (car syntmp-x-553) #f)) (set-cdr! syntmp-new-555 (syntmp-strip-annotation-150 (cdr syntmp-x-553) #f)) syntmp-new-555))) ((annotation? syntmp-x-553) (or (annotation-stripped syntmp-x-553) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-553) syntmp-x-553))) ((vector? syntmp-x-553) (let ((syntmp-new-556 (make-vector (vector-length syntmp-x-553)))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-556)) (let syntmp-loop-557 ((syntmp-i-558 (- (vector-length syntmp-x-553) 1))) (unless (syntmp-fx<-75 syntmp-i-558 0) (vector-set! syntmp-new-556 syntmp-i-558 (syntmp-strip-annotation-150 (vector-ref syntmp-x-553 syntmp-i-558) #f)) (syntmp-loop-557 (syntmp-fx--73 syntmp-i-558 1)))) syntmp-new-556))) (else syntmp-x-553)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-559) (and (syntmp-nonsymbol-id?-103 syntmp-x-559) (syntmp-free-id=?-127 syntmp-x-559 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-560) (let ((syntmp-p-561 (syntmp-local-eval-hook-77 syntmp-expanded-560))) (if (procedure? syntmp-p-561) syntmp-p-561 (syntax-error syntmp-p-561 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-562 syntmp-e-563 syntmp-r-564 syntmp-w-565 syntmp-s-566 syntmp-k-567) ((lambda (syntmp-tmp-568) ((lambda (syntmp-tmp-569) (if syntmp-tmp-569 (apply (lambda (syntmp-_-570 syntmp-id-571 syntmp-val-572 syntmp-e1-573 syntmp-e2-574) (let ((syntmp-ids-575 syntmp-id-571)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-575)) (syntax-error syntmp-e-563 "duplicate bound keyword in") (let ((syntmp-labels-577 (syntmp-gen-labels-110 syntmp-ids-575))) (let ((syntmp-new-w-578 (syntmp-make-binding-wrap-121 syntmp-ids-575 syntmp-labels-577 syntmp-w-565))) (syntmp-k-567 (cons syntmp-e1-573 syntmp-e2-574) (syntmp-extend-env-98 syntmp-labels-577 (let ((syntmp-w-580 (if syntmp-rec?-562 syntmp-new-w-578 syntmp-w-565)) (syntmp-trans-r-581 (syntmp-macros-only-env-100 syntmp-r-564))) (map (lambda (syntmp-x-582) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-582 syntmp-trans-r-581 syntmp-w-580)))) syntmp-val-572)) syntmp-r-564) syntmp-new-w-578 syntmp-s-566)))))) syntmp-tmp-569) ((lambda (syntmp-_-584) (syntax-error (syntmp-source-wrap-133 syntmp-e-563 syntmp-w-565 syntmp-s-566))) syntmp-tmp-568))) (syntax-dispatch syntmp-tmp-568 (quote (any #(each (any any)) any . each-any))))) syntmp-e-563))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-585 syntmp-c-586 syntmp-r-587 syntmp-w-588 syntmp-k-589) ((lambda (syntmp-tmp-590) ((lambda (syntmp-tmp-591) (if syntmp-tmp-591 (apply (lambda (syntmp-id-592 syntmp-e1-593 syntmp-e2-594) (let ((syntmp-ids-595 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-595)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-597 (syntmp-gen-labels-110 syntmp-ids-595)) (syntmp-new-vars-598 (map syntmp-gen-var-152 syntmp-ids-595))) (syntmp-k-589 syntmp-new-vars-598 (syntmp-chi-body-144 (cons syntmp-e1-593 syntmp-e2-594) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-597 syntmp-new-vars-598 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-ids-595 syntmp-labels-597 syntmp-w-588))))))) syntmp-tmp-591) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-ids-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-old-ids-604 (syntmp-lambda-var-list-153 syntmp-ids-601))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-604)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-605 (syntmp-gen-labels-110 syntmp-old-ids-604)) (syntmp-new-vars-606 (map syntmp-gen-var-152 syntmp-old-ids-604))) (syntmp-k-589 (let syntmp-f-607 ((syntmp-ls1-608 (cdr syntmp-new-vars-606)) (syntmp-ls2-609 (car syntmp-new-vars-606))) (if (null? syntmp-ls1-608) syntmp-ls2-609 (syntmp-f-607 (cdr syntmp-ls1-608) (cons (car syntmp-ls1-608) syntmp-ls2-609)))) (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-605 syntmp-new-vars-606 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-old-ids-604 syntmp-labels-605 syntmp-w-588))))))) syntmp-tmp-600) ((lambda (syntmp-_-611) (syntax-error syntmp-e-585)) syntmp-tmp-590))) (syntax-dispatch syntmp-tmp-590 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-590 (quote (each-any any . each-any))))) syntmp-c-586))) (syntmp-chi-body-144 (lambda (syntmp-body-612 syntmp-outer-form-613 syntmp-r-614 syntmp-w-615) (let ((syntmp-r-616 (cons (quote ("placeholder" placeholder)) syntmp-r-614))) (let ((syntmp-ribcage-617 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-618 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-615) (cons syntmp-ribcage-617 (syntmp-wrap-subst-108 syntmp-w-615))))) (let syntmp-parse-619 ((syntmp-body-620 (map (lambda (syntmp-x-626) (cons syntmp-r-616 (syntmp-wrap-132 syntmp-x-626 syntmp-w-618))) syntmp-body-612)) (syntmp-ids-621 (quote ())) (syntmp-labels-622 (quote ())) (syntmp-vars-623 (quote ())) (syntmp-vals-624 (quote ())) (syntmp-bindings-625 (quote ()))) (if (null? syntmp-body-620) (syntax-error syntmp-outer-form-613 "no expressions in body") (let ((syntmp-e-627 (cdar syntmp-body-620)) (syntmp-er-628 (caar syntmp-body-620))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-627 syntmp-er-628 (quote (())) #f syntmp-ribcage-617)) (lambda (syntmp-type-629 syntmp-value-630 syntmp-e-631 syntmp-w-632 syntmp-s-633) (let ((syntmp-t-634 syntmp-type-629)) (if (memv syntmp-t-634 (quote (define-form))) (let ((syntmp-id-635 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-636 (syntmp-gen-label-109))) (let ((syntmp-var-637 (syntmp-gen-var-152 syntmp-id-635))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-635 syntmp-label-636) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-635 syntmp-ids-621) (cons syntmp-label-636 syntmp-labels-622) (cons syntmp-var-637 syntmp-vars-623) (cons (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632)) syntmp-vals-624) (cons (cons (quote lexical) syntmp-var-637) syntmp-bindings-625))))) (if (memv syntmp-t-634 (quote (define-syntax-form))) (let ((syntmp-id-638 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-639 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-638 syntmp-label-639) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-638 syntmp-ids-621) (cons syntmp-label-639 syntmp-labels-622) syntmp-vars-623 syntmp-vals-624 (cons (cons (quote macro) (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632))) syntmp-bindings-625)))) (if (memv syntmp-t-634 (quote (begin-form))) ((lambda (syntmp-tmp-640) ((lambda (syntmp-tmp-641) (if syntmp-tmp-641 (apply (lambda (syntmp-_-642 syntmp-e1-643) (syntmp-parse-619 (let syntmp-f-644 ((syntmp-forms-645 syntmp-e1-643)) (if (null? syntmp-forms-645) (cdr syntmp-body-620) (cons (cons syntmp-er-628 (syntmp-wrap-132 (car syntmp-forms-645) syntmp-w-632)) (syntmp-f-644 (cdr syntmp-forms-645))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625)) syntmp-tmp-641) (syntax-error syntmp-tmp-640))) (syntax-dispatch syntmp-tmp-640 (quote (any . each-any))))) syntmp-e-631) (if (memv syntmp-t-634 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-630 syntmp-e-631 syntmp-er-628 syntmp-w-632 syntmp-s-633 (lambda (syntmp-forms-647 syntmp-er-648 syntmp-w-649 syntmp-s-650) (syntmp-parse-619 (let syntmp-f-651 ((syntmp-forms-652 syntmp-forms-647)) (if (null? syntmp-forms-652) (cdr syntmp-body-620) (cons (cons syntmp-er-648 (syntmp-wrap-132 (car syntmp-forms-652) syntmp-w-649)) (syntmp-f-651 (cdr syntmp-forms-652))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625))) (if (null? syntmp-ids-621) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-653) (syntmp-chi-140 (cdr syntmp-x-653) (car syntmp-x-653) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-621)) (syntax-error syntmp-outer-form-613 "invalid or duplicate identifier in definition")) (let syntmp-loop-654 ((syntmp-bs-655 syntmp-bindings-625) (syntmp-er-cache-656 #f) (syntmp-r-cache-657 #f)) (if (not (null? syntmp-bs-655)) (let ((syntmp-b-658 (car syntmp-bs-655))) (if (eq? (car syntmp-b-658) (quote macro)) (let ((syntmp-er-659 (cadr syntmp-b-658))) (let ((syntmp-r-cache-660 (if (eq? syntmp-er-659 syntmp-er-cache-656) syntmp-r-cache-657 (syntmp-macros-only-env-100 syntmp-er-659)))) (begin (set-cdr! syntmp-b-658 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-658) syntmp-r-cache-660 (quote (()))))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-659 syntmp-r-cache-660)))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-cache-656 syntmp-r-cache-657))))) (set-cdr! syntmp-r-616 (syntmp-extend-env-98 syntmp-labels-622 syntmp-bindings-625 (cdr syntmp-r-616))) (syntmp-build-letrec-86 #f syntmp-vars-623 (map (lambda (syntmp-x-661) (syntmp-chi-140 (cdr syntmp-x-661) (car syntmp-x-661) (quote (())))) syntmp-vals-624) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-662) (syntmp-chi-140 (cdr syntmp-x-662) (car syntmp-x-662) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-663 syntmp-e-664 syntmp-r-665 syntmp-w-666 syntmp-rib-667) (letrec ((syntmp-rebuild-macro-output-668 (lambda (syntmp-x-669 syntmp-m-670) (cond ((pair? syntmp-x-669) (cons (syntmp-rebuild-macro-output-668 (car syntmp-x-669) syntmp-m-670) (syntmp-rebuild-macro-output-668 (cdr syntmp-x-669) syntmp-m-670))) ((syntmp-syntax-object?-88 syntmp-x-669) (let ((syntmp-w-671 (syntmp-syntax-object-wrap-90 syntmp-x-669))) (let ((syntmp-ms-672 (syntmp-wrap-marks-107 syntmp-w-671)) (syntmp-s-673 (syntmp-wrap-subst-108 syntmp-w-671))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-669) (if (and (pair? syntmp-ms-672) (eq? (car syntmp-ms-672) #f)) (syntmp-make-wrap-106 (cdr syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cdr syntmp-s-673)) (cdr syntmp-s-673))) (syntmp-make-wrap-106 (cons syntmp-m-670 syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cons (quote shift) syntmp-s-673)) (cons (quote shift) syntmp-s-673)))))))) ((vector? syntmp-x-669) (let ((syntmp-n-674 (vector-length syntmp-x-669))) (let ((syntmp-v-675 (make-vector syntmp-n-674))) (let syntmp-doloop-676 ((syntmp-i-677 0)) (if (syntmp-fx=-74 syntmp-i-677 syntmp-n-674) syntmp-v-675 (begin (vector-set! syntmp-v-675 syntmp-i-677 (syntmp-rebuild-macro-output-668 (vector-ref syntmp-x-669 syntmp-i-677) syntmp-m-670)) (syntmp-doloop-676 (syntmp-fx+-72 syntmp-i-677 1)))))))) ((symbol? syntmp-x-669) (syntax-error syntmp-x-669 "encountered raw symbol in macro output")) (else syntmp-x-669))))) (syntmp-rebuild-macro-output-668 (syntmp-p-663 (syntmp-wrap-132 syntmp-e-664 (syntmp-anti-mark-119 syntmp-w-666))) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-678 syntmp-e-679 syntmp-r-680 syntmp-w-681 syntmp-s-682) ((lambda (syntmp-tmp-683) ((lambda (syntmp-tmp-684) (if syntmp-tmp-684 (apply (lambda (syntmp-e0-685 syntmp-e1-686) (syntmp-build-annotated-81 syntmp-s-682 (cons syntmp-x-678 (map (lambda (syntmp-e-687) (syntmp-chi-140 syntmp-e-687 syntmp-r-680 syntmp-w-681)) syntmp-e1-686)))) syntmp-tmp-684) (syntax-error syntmp-tmp-683))) (syntax-dispatch syntmp-tmp-683 (quote (any . each-any))))) syntmp-e-679))) (syntmp-chi-expr-141 (lambda (syntmp-type-689 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (let ((syntmp-t-695 syntmp-type-689)) (if (memv syntmp-t-695 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-694 syntmp-value-690) (if (memv syntmp-t-695 (quote (core external-macro))) (syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) syntmp-value-690) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) (make-module-ref #f syntmp-value-690 #f)) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (constant))) (syntmp-build-data-82 syntmp-s-694 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) (quote (())))) (if (memv syntmp-t-695 (quote (global))) (syntmp-build-annotated-81 syntmp-s-694 (make-module-ref #f syntmp-value-690 #f)) (if (memv syntmp-t-695 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-691) syntmp-r-692 syntmp-w-693) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (begin-form))) ((lambda (syntmp-tmp-696) ((lambda (syntmp-tmp-697) (if syntmp-tmp-697 (apply (lambda (syntmp-_-698 syntmp-e1-699 syntmp-e2-700) (syntmp-chi-sequence-134 (cons syntmp-e1-699 syntmp-e2-700) syntmp-r-692 syntmp-w-693 syntmp-s-694)) syntmp-tmp-697) (syntax-error syntmp-tmp-696))) (syntax-dispatch syntmp-tmp-696 (quote (any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694 syntmp-chi-sequence-134) (if (memv syntmp-t-695 (quote (eval-when-form))) ((lambda (syntmp-tmp-702) ((lambda (syntmp-tmp-703) (if syntmp-tmp-703 (apply (lambda (syntmp-_-704 syntmp-x-705 syntmp-e1-706 syntmp-e2-707) (let ((syntmp-when-list-708 (syntmp-chi-when-list-137 syntmp-e-691 syntmp-x-705 syntmp-w-693))) (if (memq (quote eval) syntmp-when-list-708) (syntmp-chi-sequence-134 (cons syntmp-e1-706 syntmp-e2-707) syntmp-r-692 syntmp-w-693 syntmp-s-694) (syntmp-chi-void-148)))) syntmp-tmp-703) (syntax-error syntmp-tmp-702))) (syntax-dispatch syntmp-tmp-702 (quote (any each-any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-690 syntmp-w-693) "invalid context for definition of") (if (memv syntmp-t-695 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to pattern variable outside syntax form") (if (memv syntmp-t-695 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694)))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-711 syntmp-r-712 syntmp-w-713) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-711 syntmp-r-712 syntmp-w-713 #f #f)) (lambda (syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-w-717 syntmp-s-718) (syntmp-chi-expr-141 syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-r-712 syntmp-w-717 syntmp-s-718))))) (syntmp-chi-top-139 (lambda (syntmp-e-719 syntmp-r-720 syntmp-w-721 syntmp-m-722 syntmp-esew-723) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-719 syntmp-r-720 syntmp-w-721 #f #f)) (lambda (syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-w-739 syntmp-s-740) (let ((syntmp-t-741 syntmp-type-736)) (if (memv syntmp-t-741 (quote (begin-form))) ((lambda (syntmp-tmp-742) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744) (syntmp-chi-void-148)) syntmp-tmp-743) ((lambda (syntmp-tmp-745) (if syntmp-tmp-745 (apply (lambda (syntmp-_-746 syntmp-e1-747 syntmp-e2-748) (syntmp-chi-top-sequence-135 (cons syntmp-e1-747 syntmp-e2-748) syntmp-r-720 syntmp-w-739 syntmp-s-740 syntmp-m-722 syntmp-esew-723)) syntmp-tmp-745) (syntax-error syntmp-tmp-742))) (syntax-dispatch syntmp-tmp-742 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-742 (quote (any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740 (lambda (syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753) (syntmp-chi-top-sequence-135 syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753 syntmp-m-722 syntmp-esew-723))) (if (memv syntmp-t-741 (quote (eval-when-form))) ((lambda (syntmp-tmp-754) ((lambda (syntmp-tmp-755) (if syntmp-tmp-755 (apply (lambda (syntmp-_-756 syntmp-x-757 syntmp-e1-758 syntmp-e2-759) (let ((syntmp-when-list-760 (syntmp-chi-when-list-137 syntmp-e-738 syntmp-x-757 syntmp-w-739)) (syntmp-body-761 (cons syntmp-e1-758 syntmp-e2-759))) (cond ((eq? syntmp-m-722 (quote e)) (if (memq (quote eval) syntmp-when-list-760) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval))) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-760) (if (or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c&e) (quote (compile load))) (if (memq syntmp-m-722 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c) (quote (load))) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval)))) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-755) (syntax-error syntmp-tmp-754))) (syntax-dispatch syntmp-tmp-754 (quote (any each-any any . each-any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (define-syntax-form))) (let ((syntmp-n-764 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739)) (syntmp-r-765 (syntmp-macros-only-env-100 syntmp-r-720))) (let ((syntmp-t-766 syntmp-m-722)) (if (memv syntmp-t-766 (quote (c))) (if (memq (quote compile) syntmp-esew-723) (let ((syntmp-e-767 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-767) (if (memq (quote load) syntmp-esew-723) syntmp-e-767 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-723) (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)) (syntmp-chi-void-148))) (if (memv syntmp-t-766 (quote (c&e))) (let ((syntmp-e-768 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-768) syntmp-e-768)) (begin (if (memq (quote eval) syntmp-esew-723) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (syntmp-chi-void-148)))))) (if (memv syntmp-t-741 (quote (define-form))) (let ((syntmp-n-769 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739))) (let ((syntmp-type-770 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-769 syntmp-r-720)))) (let ((syntmp-t-771 syntmp-type-770)) (if (memv syntmp-t-771 (quote (global))) (let ((syntmp-x-772 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)) (if (memv syntmp-t-771 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "identifier out of context") (if (eq? syntmp-type-770 (quote external-macro)) (let ((syntmp-x-773 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-773)) syntmp-x-773)) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "cannot define keyword at top level"))))))) (let ((syntmp-x-774 (syntmp-chi-expr-141 syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-774)) syntmp-x-774)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-s-778 syntmp-rib-779) (cond ((symbol? syntmp-e-775) (let ((syntmp-n-780 (syntmp-id-var-name-126 syntmp-e-775 syntmp-w-777))) (let ((syntmp-b-781 (syntmp-lookup-101 syntmp-n-780 syntmp-r-776))) (let ((syntmp-type-782 (syntmp-binding-type-96 syntmp-b-781))) (let ((syntmp-t-783 syntmp-type-782)) (if (memv syntmp-t-783 (quote (lexical))) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (global))) (values syntmp-type-782 syntmp-n-780 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778))))))))) ((pair? syntmp-e-775) (let ((syntmp-first-784 (car syntmp-e-775))) (if (syntmp-id?-104 syntmp-first-784) (let ((syntmp-n-785 (syntmp-id-var-name-126 syntmp-first-784 syntmp-w-777))) (let ((syntmp-b-786 (syntmp-lookup-101 syntmp-n-785 syntmp-r-776))) (let ((syntmp-type-787 (syntmp-binding-type-96 syntmp-b-786))) (let ((syntmp-t-788 syntmp-type-787)) (if (memv syntmp-t-788 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (global))) (values (quote global-call) syntmp-n-785 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (if (memv syntmp-t-788 (quote (core external-macro))) (values syntmp-type-787 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (begin))) (values (quote begin-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (define))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-name-792 syntmp-val-793) (syntmp-id?-104 syntmp-name-792)) syntmp-tmp-790) #f) (apply (lambda (syntmp-_-794 syntmp-name-795 syntmp-val-796) (values (quote define-form) syntmp-name-795 syntmp-val-796 syntmp-w-777 syntmp-s-778)) syntmp-tmp-790) ((lambda (syntmp-tmp-797) (if (if syntmp-tmp-797 (apply (lambda (syntmp-_-798 syntmp-name-799 syntmp-args-800 syntmp-e1-801 syntmp-e2-802) (and (syntmp-id?-104 syntmp-name-799) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-800)))) syntmp-tmp-797) #f) (apply (lambda (syntmp-_-803 syntmp-name-804 syntmp-args-805 syntmp-e1-806 syntmp-e2-807) (values (quote define-form) (syntmp-wrap-132 syntmp-name-804 syntmp-w-777) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-132 (cons syntmp-args-805 (cons syntmp-e1-806 syntmp-e2-807)) syntmp-w-777)) (quote (())) syntmp-s-778)) syntmp-tmp-797) ((lambda (syntmp-tmp-809) (if (if syntmp-tmp-809 (apply (lambda (syntmp-_-810 syntmp-name-811) (syntmp-id?-104 syntmp-name-811)) syntmp-tmp-809) #f) (apply (lambda (syntmp-_-812 syntmp-name-813) (values (quote define-form) (syntmp-wrap-132 syntmp-name-813 syntmp-w-777) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-778)) syntmp-tmp-809) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any any any))))) syntmp-e-775) (if (memv syntmp-t-788 (quote (define-syntax))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-syntax-form) syntmp-name-820 syntmp-val-821 syntmp-w-777 syntmp-s-778)) syntmp-tmp-815) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-775) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))))))))))))) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))) ((syntmp-syntax-object?-88 syntmp-e-775) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-775) syntmp-r-776 (syntmp-join-wraps-123 syntmp-w-777 (syntmp-syntax-object-wrap-90 syntmp-e-775)) #f syntmp-rib-779)) ((annotation? syntmp-e-775) (syntmp-syntax-type-138 (annotation-expression syntmp-e-775) syntmp-r-776 syntmp-w-777 (annotation-source syntmp-e-775) syntmp-rib-779)) ((self-evaluating? syntmp-e-775) (values (quote constant) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)) (else (values (quote other) #f syntmp-e-775 syntmp-w-777 syntmp-s-778))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-822 syntmp-when-list-823 syntmp-w-824) (let syntmp-f-825 ((syntmp-when-list-826 syntmp-when-list-823) (syntmp-situations-827 (quote ()))) (if (null? syntmp-when-list-826) syntmp-situations-827 (syntmp-f-825 (cdr syntmp-when-list-826) (cons (let ((syntmp-x-828 (car syntmp-when-list-826))) (cond ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-828 syntmp-w-824) "invalid eval-when situation")))) syntmp-situations-827)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-829 syntmp-e-830) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-829) syntmp-e-830)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-831 syntmp-r-832 syntmp-w-833 syntmp-s-834 syntmp-m-835 syntmp-esew-836) (syntmp-build-sequence-83 syntmp-s-834 (let syntmp-dobody-837 ((syntmp-body-838 syntmp-body-831) (syntmp-r-839 syntmp-r-832) (syntmp-w-840 syntmp-w-833) (syntmp-m-841 syntmp-m-835) (syntmp-esew-842 syntmp-esew-836)) (if (null? syntmp-body-838) (quote ()) (let ((syntmp-first-843 (syntmp-chi-top-139 (car syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842))) (cons syntmp-first-843 (syntmp-dobody-837 (cdr syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-844 syntmp-r-845 syntmp-w-846 syntmp-s-847) (syntmp-build-sequence-83 syntmp-s-847 (let syntmp-dobody-848 ((syntmp-body-849 syntmp-body-844) (syntmp-r-850 syntmp-r-845) (syntmp-w-851 syntmp-w-846)) (if (null? syntmp-body-849) (quote ()) (let ((syntmp-first-852 (syntmp-chi-140 (car syntmp-body-849) syntmp-r-850 syntmp-w-851))) (cons syntmp-first-852 (syntmp-dobody-848 (cdr syntmp-body-849) syntmp-r-850 syntmp-w-851)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-853 syntmp-w-854 syntmp-s-855) (syntmp-wrap-132 (if syntmp-s-855 (make-annotation syntmp-x-853 syntmp-s-855 #f) syntmp-x-853) syntmp-w-854))) (syntmp-wrap-132 (lambda (syntmp-x-856 syntmp-w-857) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-857)) (null? (syntmp-wrap-subst-108 syntmp-w-857))) syntmp-x-856) ((syntmp-syntax-object?-88 syntmp-x-856) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-856) (syntmp-join-wraps-123 syntmp-w-857 (syntmp-syntax-object-wrap-90 syntmp-x-856)))) ((null? syntmp-x-856) syntmp-x-856) (else (syntmp-make-syntax-object-87 syntmp-x-856 syntmp-w-857))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-858 syntmp-list-859) (and (not (null? syntmp-list-859)) (or (syntmp-bound-id=?-128 syntmp-x-858 (car syntmp-list-859)) (syntmp-bound-id-member?-131 syntmp-x-858 (cdr syntmp-list-859)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-860) (let syntmp-distinct?-861 ((syntmp-ids-862 syntmp-ids-860)) (or (null? syntmp-ids-862) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-862) (cdr syntmp-ids-862))) (syntmp-distinct?-861 (cdr syntmp-ids-862))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-863) (and (let syntmp-all-ids?-864 ((syntmp-ids-865 syntmp-ids-863)) (or (null? syntmp-ids-865) (and (syntmp-id?-104 (car syntmp-ids-865)) (syntmp-all-ids?-864 (cdr syntmp-ids-865))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-863)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-866 syntmp-j-867) (if (and (syntmp-syntax-object?-88 syntmp-i-866) (syntmp-syntax-object?-88 syntmp-j-867)) (and (eq? (let ((syntmp-e-868 (syntmp-syntax-object-expression-89 syntmp-i-866))) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 (syntmp-syntax-object-expression-89 syntmp-j-867))) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-866)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-867)))) (eq? (let ((syntmp-e-870 syntmp-i-866)) (if (annotation? syntmp-e-870) (annotation-expression syntmp-e-870) syntmp-e-870)) (let ((syntmp-e-871 syntmp-j-867)) (if (annotation? syntmp-e-871) (annotation-expression syntmp-e-871) syntmp-e-871)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-872 syntmp-j-873) (and (eq? (let ((syntmp-x-874 syntmp-i-872)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875))) (let ((syntmp-x-876 syntmp-j-873)) (let ((syntmp-e-877 (if (syntmp-syntax-object?-88 syntmp-x-876) (syntmp-syntax-object-expression-89 syntmp-x-876) syntmp-x-876))) (if (annotation? syntmp-e-877) (annotation-expression syntmp-e-877) syntmp-e-877)))) (eq? (syntmp-id-var-name-126 syntmp-i-872 (quote (()))) (syntmp-id-var-name-126 syntmp-j-873 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-878 syntmp-w-879) (letrec ((syntmp-search-vector-rib-882 (lambda (syntmp-sym-893 syntmp-subst-894 syntmp-marks-895 syntmp-symnames-896 syntmp-ribcage-897) (let ((syntmp-n-898 (vector-length syntmp-symnames-896))) (let syntmp-f-899 ((syntmp-i-900 0)) (cond ((syntmp-fx=-74 syntmp-i-900 syntmp-n-898) (syntmp-search-880 syntmp-sym-893 (cdr syntmp-subst-894) syntmp-marks-895)) ((and (eq? (vector-ref syntmp-symnames-896 syntmp-i-900) syntmp-sym-893) (syntmp-same-marks?-125 syntmp-marks-895 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-897) syntmp-i-900))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-897) syntmp-i-900) syntmp-marks-895)) (else (syntmp-f-899 (syntmp-fx+-72 syntmp-i-900 1)))))))) (syntmp-search-list-rib-881 (lambda (syntmp-sym-901 syntmp-subst-902 syntmp-marks-903 syntmp-symnames-904 syntmp-ribcage-905) (let syntmp-f-906 ((syntmp-symnames-907 syntmp-symnames-904) (syntmp-i-908 0)) (cond ((null? syntmp-symnames-907) (syntmp-search-880 syntmp-sym-901 (cdr syntmp-subst-902) syntmp-marks-903)) ((and (eq? (car syntmp-symnames-907) syntmp-sym-901) (syntmp-same-marks?-125 syntmp-marks-903 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-905) syntmp-i-908))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-905) syntmp-i-908) syntmp-marks-903)) (else (syntmp-f-906 (cdr syntmp-symnames-907) (syntmp-fx+-72 syntmp-i-908 1))))))) (syntmp-search-880 (lambda (syntmp-sym-909 syntmp-subst-910 syntmp-marks-911) (if (null? syntmp-subst-910) (values #f syntmp-marks-911) (let ((syntmp-fst-912 (car syntmp-subst-910))) (if (eq? syntmp-fst-912 (quote shift)) (syntmp-search-880 syntmp-sym-909 (cdr syntmp-subst-910) (cdr syntmp-marks-911)) (let ((syntmp-symnames-913 (syntmp-ribcage-symnames-113 syntmp-fst-912))) (if (vector? syntmp-symnames-913) (syntmp-search-vector-rib-882 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912) (syntmp-search-list-rib-881 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912))))))))) (cond ((symbol? syntmp-id-878) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-878 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-915 . syntmp-ignore-914) syntmp-x-915)) syntmp-id-878)) ((syntmp-syntax-object?-88 syntmp-id-878) (let ((syntmp-id-916 (let ((syntmp-e-918 (syntmp-syntax-object-expression-89 syntmp-id-878))) (if (annotation? syntmp-e-918) (annotation-expression syntmp-e-918) syntmp-e-918))) (syntmp-w1-917 (syntmp-syntax-object-wrap-90 syntmp-id-878))) (let ((syntmp-marks-919 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w1-917)))) (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w-879) syntmp-marks-919)) (lambda (syntmp-new-id-920 syntmp-marks-921) (or syntmp-new-id-920 (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w1-917) syntmp-marks-921)) (lambda (syntmp-x-923 . syntmp-ignore-922) syntmp-x-923)) syntmp-id-916)))))) ((annotation? syntmp-id-878) (let ((syntmp-id-924 (let ((syntmp-e-925 syntmp-id-878)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)))) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-924 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-927 . syntmp-ignore-926) syntmp-x-927)) syntmp-id-924))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-878)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-928 syntmp-y-929) (or (eq? syntmp-x-928 syntmp-y-929) (and (not (null? syntmp-x-928)) (not (null? syntmp-y-929)) (eq? (car syntmp-x-928) (car syntmp-y-929)) (syntmp-same-marks?-125 (cdr syntmp-x-928) (cdr syntmp-y-929)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-930 syntmp-m2-931) (syntmp-smart-append-122 syntmp-m1-930 syntmp-m2-931))) (syntmp-join-wraps-123 (lambda (syntmp-w1-932 syntmp-w2-933) (let ((syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w1-932)) (syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w1-932))) (if (null? syntmp-m1-934) (if (null? syntmp-s1-935) syntmp-w2-933 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-933) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w2-933)) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-936 syntmp-m2-937) (if (null? syntmp-m2-937) syntmp-m1-936 (append syntmp-m1-936 syntmp-m2-937)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-938 syntmp-labels-939 syntmp-w-940) (if (null? syntmp-ids-938) syntmp-w-940 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-940) (cons (let ((syntmp-labelvec-941 (list->vector syntmp-labels-939))) (let ((syntmp-n-942 (vector-length syntmp-labelvec-941))) (let ((syntmp-symnamevec-943 (make-vector syntmp-n-942)) (syntmp-marksvec-944 (make-vector syntmp-n-942))) (begin (let syntmp-f-945 ((syntmp-ids-946 syntmp-ids-938) (syntmp-i-947 0)) (if (not (null? syntmp-ids-946)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-946) syntmp-w-940)) (lambda (syntmp-symname-948 syntmp-marks-949) (begin (vector-set! syntmp-symnamevec-943 syntmp-i-947 syntmp-symname-948) (vector-set! syntmp-marksvec-944 syntmp-i-947 syntmp-marks-949) (syntmp-f-945 (cdr syntmp-ids-946) (syntmp-fx+-72 syntmp-i-947 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-943 syntmp-marksvec-944 syntmp-labelvec-941))))) (syntmp-wrap-subst-108 syntmp-w-940)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-950 syntmp-id-951 syntmp-label-952) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-950 (cons (let ((syntmp-e-953 (syntmp-syntax-object-expression-89 syntmp-id-951))) (if (annotation? syntmp-e-953) (annotation-expression syntmp-e-953) syntmp-e-953)) (syntmp-ribcage-symnames-113 syntmp-ribcage-950))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-950 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-951)) (syntmp-ribcage-marks-114 syntmp-ribcage-950))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-950 (cons syntmp-label-952 (syntmp-ribcage-labels-115 syntmp-ribcage-950)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-954) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-954)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-954))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 3 syntmp-update-956))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 2 syntmp-update-958))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-959 syntmp-update-960) (vector-set! syntmp-x-959 1 syntmp-update-960))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-962) (vector-ref syntmp-x-962 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-963) (vector-ref syntmp-x-963 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-964) (and (vector? syntmp-x-964) (= (vector-length syntmp-x-964) 4) (eq? (vector-ref syntmp-x-964 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967) (vector (quote ribcage) syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967))) (syntmp-gen-labels-110 (lambda (syntmp-ls-968) (if (null? syntmp-ls-968) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-968)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-969 syntmp-w-970) (if (syntmp-syntax-object?-88 syntmp-x-969) (values (let ((syntmp-e-971 (syntmp-syntax-object-expression-89 syntmp-x-969))) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-970) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-969)))) (values (let ((syntmp-e-972 syntmp-x-969)) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)) (syntmp-wrap-marks-107 syntmp-w-970))))) (syntmp-id?-104 (lambda (syntmp-x-973) (cond ((symbol? syntmp-x-973) #t) ((syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))) ((annotation? syntmp-x-973) (symbol? (annotation-expression syntmp-x-973))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-975) (and (syntmp-syntax-object?-88 syntmp-x-975) (symbol? (let ((syntmp-e-976 (syntmp-syntax-object-expression-89 syntmp-x-975))) (if (annotation? syntmp-e-976) (annotation-expression syntmp-e-976) syntmp-e-976)))))) (syntmp-global-extend-102 (lambda (syntmp-type-977 syntmp-sym-978 syntmp-val-979) (syntmp-put-global-definition-hook-79 syntmp-sym-978 (cons syntmp-type-977 syntmp-val-979)))) (syntmp-lookup-101 (lambda (syntmp-x-980 syntmp-r-981) (cond ((assq syntmp-x-980 syntmp-r-981) => cdr) ((symbol? syntmp-x-980) (or (syntmp-get-global-definition-hook-80 syntmp-x-980) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-982) (if (null? syntmp-r-982) (quote ()) (let ((syntmp-a-983 (car syntmp-r-982))) (if (eq? (cadr syntmp-a-983) (quote macro)) (cons syntmp-a-983 (syntmp-macros-only-env-100 (cdr syntmp-r-982))) (syntmp-macros-only-env-100 (cdr syntmp-r-982))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-984 syntmp-vars-985 syntmp-r-986) (if (null? syntmp-labels-984) syntmp-r-986 (syntmp-extend-var-env-99 (cdr syntmp-labels-984) (cdr syntmp-vars-985) (cons (cons (car syntmp-labels-984) (cons (quote lexical) (car syntmp-vars-985))) syntmp-r-986))))) (syntmp-extend-env-98 (lambda (syntmp-labels-987 syntmp-bindings-988 syntmp-r-989) (if (null? syntmp-labels-987) syntmp-r-989 (syntmp-extend-env-98 (cdr syntmp-labels-987) (cdr syntmp-bindings-988) (cons (cons (car syntmp-labels-987) (car syntmp-bindings-988)) syntmp-r-989))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-990) (cond ((annotation? syntmp-x-990) (annotation-source syntmp-x-990)) ((syntmp-syntax-object?-88 syntmp-x-990) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-990))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-991 syntmp-y-992) (vector-set! syntmp-x-991 3 syntmp-y-992))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-993 syntmp-y-994) (vector-set! syntmp-x-993 2 syntmp-y-994))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-995 syntmp-y-996) (vector-set! syntmp-x-995 1 syntmp-y-996))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-997) (vector-ref syntmp-x-997 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-998) (vector-ref syntmp-x-998 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-999) (vector-ref syntmp-x-999 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1000) (and (vector? syntmp-x-1000) (> (vector-length syntmp-x-1000) 0) (eq? (vector-ref syntmp-x-1000 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-exp-1003 syntmp-wrap-1002 . syntmp-mod-1001) (vector (quote syntax-object) syntmp-exp-1003 syntmp-wrap-1002 (if (null? syntmp-mod-1001) #f (car syntmp-mod-1001))))) (syntmp-build-letrec-86 (lambda (syntmp-src-1004 syntmp-vars-1005 syntmp-val-exps-1006 syntmp-body-exp-1007) (if (null? syntmp-vars-1005) (syntmp-build-annotated-81 syntmp-src-1004 syntmp-body-exp-1007) (syntmp-build-annotated-81 syntmp-src-1004 (list (quote letrec) (map list syntmp-vars-1005 syntmp-val-exps-1006) syntmp-body-exp-1007))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1008 syntmp-vars-1009 syntmp-val-exps-1010 syntmp-body-exp-1011) (if (null? syntmp-vars-1009) (syntmp-build-annotated-81 syntmp-src-1008 syntmp-body-exp-1011) (syntmp-build-annotated-81 syntmp-src-1008 (list (quote let) (car syntmp-vars-1009) (map list (cdr syntmp-vars-1009) syntmp-val-exps-1010) syntmp-body-exp-1011))))) (syntmp-build-let-84 (lambda (syntmp-src-1012 syntmp-vars-1013 syntmp-val-exps-1014 syntmp-body-exp-1015) (if (null? syntmp-vars-1013) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-body-exp-1015) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote let) (map list syntmp-vars-1013 syntmp-val-exps-1014) syntmp-body-exp-1015))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1016 syntmp-exps-1017) (if (null? (cdr syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (car syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (cons (quote begin) syntmp-exps-1017))))) (syntmp-build-data-82 (lambda (syntmp-src-1018 syntmp-exp-1019) (if (and (self-evaluating? syntmp-exp-1019) (not (vector? syntmp-exp-1019))) (syntmp-build-annotated-81 syntmp-src-1018 syntmp-exp-1019) (syntmp-build-annotated-81 syntmp-src-1018 (list (quote quote) syntmp-exp-1019))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1020 syntmp-exp-1021) (if (and syntmp-src-1020 (not (annotation? syntmp-exp-1021))) (make-annotation syntmp-exp-1021 syntmp-src-1020 #t) syntmp-exp-1021))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1022) (getprop syntmp-symbol-1022 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1023 syntmp-binding-1024) (putprop syntmp-symbol-1023 (quote *sc-expander*) syntmp-binding-1024))) (syntmp-error-hook-78 (lambda (syntmp-who-1025 syntmp-why-1026 syntmp-what-1027) (error syntmp-who-1025 "~a ~s" syntmp-why-1026 syntmp-what-1027))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1028) (eval (list syntmp-noexpand-71 syntmp-x-1028) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1029) (eval (list syntmp-noexpand-71 syntmp-x-1029) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1030 syntmp-r-1031 syntmp-w-1032 syntmp-s-1033) ((lambda (syntmp-tmp-1034) ((lambda (syntmp-tmp-1035) (if (if syntmp-tmp-1035 (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (syntmp-valid-bound-ids?-129 syntmp-var-1037)) syntmp-tmp-1035) #f) (apply (lambda (syntmp-_-1042 syntmp-var-1043 syntmp-val-1044 syntmp-e1-1045 syntmp-e2-1046) (let ((syntmp-names-1047 (map (lambda (syntmp-x-1048) (syntmp-id-var-name-126 syntmp-x-1048 syntmp-w-1032)) syntmp-var-1043))) (begin (for-each (lambda (syntmp-id-1050 syntmp-n-1051) (let ((syntmp-t-1052 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1051 syntmp-r-1031)))) (if (memv syntmp-t-1052 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1050 syntmp-w-1032 syntmp-s-1033) "identifier out of context")))) syntmp-var-1043 syntmp-names-1047) (syntmp-chi-body-144 (cons syntmp-e1-1045 syntmp-e2-1046) (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033) (syntmp-extend-env-98 syntmp-names-1047 (let ((syntmp-trans-r-1055 (syntmp-macros-only-env-100 syntmp-r-1031))) (map (lambda (syntmp-x-1056) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1056 syntmp-trans-r-1055 syntmp-w-1032)))) syntmp-val-1044)) syntmp-r-1031) syntmp-w-1032)))) syntmp-tmp-1035) ((lambda (syntmp-_-1058) (syntax-error (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033))) syntmp-tmp-1034))) (syntax-dispatch syntmp-tmp-1034 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1030))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1059 syntmp-r-1060 syntmp-w-1061 syntmp-s-1062) ((lambda (syntmp-tmp-1063) ((lambda (syntmp-tmp-1064) (if syntmp-tmp-1064 (apply (lambda (syntmp-_-1065 syntmp-e-1066) (syntmp-build-data-82 syntmp-s-1062 (syntmp-strip-151 syntmp-e-1066 syntmp-w-1061))) syntmp-tmp-1064) ((lambda (syntmp-_-1067) (syntax-error (syntmp-source-wrap-133 syntmp-e-1059 syntmp-w-1061 syntmp-s-1062))) syntmp-tmp-1063))) (syntax-dispatch syntmp-tmp-1063 (quote (any any))))) syntmp-e-1059))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1075 (lambda (syntmp-x-1076) (let ((syntmp-t-1077 (car syntmp-x-1076))) (if (memv syntmp-t-1077 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1076) (syntmp-regen-1075 (caddr syntmp-x-1076)))) (if (memv syntmp-t-1077 (quote (map))) (let ((syntmp-ls-1078 (map syntmp-regen-1075 (cdr syntmp-x-1076)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1078) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1078))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1076)) (map syntmp-regen-1075 (cdr syntmp-x-1076)))))))))))) (syntmp-gen-vector-1074 (lambda (syntmp-x-1079) (cond ((eq? (car syntmp-x-1079) (quote list)) (cons (quote vector) (cdr syntmp-x-1079))) ((eq? (car syntmp-x-1079) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1079)))) (else (list (quote list->vector) syntmp-x-1079))))) (syntmp-gen-append-1073 (lambda (syntmp-x-1080 syntmp-y-1081) (if (equal? syntmp-y-1081 (quote (quote ()))) syntmp-x-1080 (list (quote append) syntmp-x-1080 syntmp-y-1081)))) (syntmp-gen-cons-1072 (lambda (syntmp-x-1082 syntmp-y-1083) (let ((syntmp-t-1084 (car syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (quote))) (if (eq? (car syntmp-x-1082) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1082) (cadr syntmp-y-1083))) (if (eq? (cadr syntmp-y-1083) (quote ())) (list (quote list) syntmp-x-1082) (list (quote cons) syntmp-x-1082 syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (list))) (cons (quote list) (cons syntmp-x-1082 (cdr syntmp-y-1083))) (list (quote cons) syntmp-x-1082 syntmp-y-1083)))))) (syntmp-gen-map-1071 (lambda (syntmp-e-1085 syntmp-map-env-1086) (let ((syntmp-formals-1087 (map cdr syntmp-map-env-1086)) (syntmp-actuals-1088 (map (lambda (syntmp-x-1089) (list (quote ref) (car syntmp-x-1089))) syntmp-map-env-1086))) (cond ((eq? (car syntmp-e-1085) (quote ref)) (car syntmp-actuals-1088)) ((andmap (lambda (syntmp-x-1090) (and (eq? (car syntmp-x-1090) (quote ref)) (memq (cadr syntmp-x-1090) syntmp-formals-1087))) (cdr syntmp-e-1085)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1085)) (map (let ((syntmp-r-1091 (map cons syntmp-formals-1087 syntmp-actuals-1088))) (lambda (syntmp-x-1092) (cdr (assq (cadr syntmp-x-1092) syntmp-r-1091)))) (cdr syntmp-e-1085))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1087 syntmp-e-1085) syntmp-actuals-1088))))))) (syntmp-gen-mappend-1070 (lambda (syntmp-e-1093 syntmp-map-env-1094) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1071 syntmp-e-1093 syntmp-map-env-1094)))) (syntmp-gen-ref-1069 (lambda (syntmp-src-1095 syntmp-var-1096 syntmp-level-1097 syntmp-maps-1098) (if (syntmp-fx=-74 syntmp-level-1097 0) (values syntmp-var-1096 syntmp-maps-1098) (if (null? syntmp-maps-1098) (syntax-error syntmp-src-1095 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1069 syntmp-src-1095 syntmp-var-1096 (syntmp-fx--73 syntmp-level-1097 1) (cdr syntmp-maps-1098))) (lambda (syntmp-outer-var-1099 syntmp-outer-maps-1100) (let ((syntmp-b-1101 (assq syntmp-outer-var-1099 (car syntmp-maps-1098)))) (if syntmp-b-1101 (values (cdr syntmp-b-1101) syntmp-maps-1098) (let ((syntmp-inner-var-1102 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1102 (cons (cons (cons syntmp-outer-var-1099 syntmp-inner-var-1102) (car syntmp-maps-1098)) syntmp-outer-maps-1100))))))))))) (syntmp-gen-syntax-1068 (lambda (syntmp-src-1103 syntmp-e-1104 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107) (if (syntmp-id?-104 syntmp-e-1104) (let ((syntmp-label-1108 (syntmp-id-var-name-126 syntmp-e-1104 (quote (()))))) (let ((syntmp-b-1109 (syntmp-lookup-101 syntmp-label-1108 syntmp-r-1105))) (if (eq? (syntmp-binding-type-96 syntmp-b-1109) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1110 (syntmp-binding-value-97 syntmp-b-1109))) (syntmp-gen-ref-1069 syntmp-src-1103 (car syntmp-var.lev-1110) (cdr syntmp-var.lev-1110) syntmp-maps-1106))) (lambda (syntmp-var-1111 syntmp-maps-1112) (values (list (quote ref) syntmp-var-1111) syntmp-maps-1112))) (if (syntmp-ellipsis?-1107 syntmp-e-1104) (syntax-error syntmp-src-1103 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106))))) ((lambda (syntmp-tmp-1113) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-dots-1115 syntmp-e-1116) (syntmp-ellipsis?-1107 syntmp-dots-1115)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-dots-1117 syntmp-e-1118) (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-e-1118 syntmp-r-1105 syntmp-maps-1106 (lambda (syntmp-x-1119) #f))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1120) (if (if syntmp-tmp-1120 (apply (lambda (syntmp-x-1121 syntmp-dots-1122 syntmp-y-1123) (syntmp-ellipsis?-1107 syntmp-dots-1122)) syntmp-tmp-1120) #f) (apply (lambda (syntmp-x-1124 syntmp-dots-1125 syntmp-y-1126) (let syntmp-f-1127 ((syntmp-y-1128 syntmp-y-1126) (syntmp-k-1129 (lambda (syntmp-maps-1130) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1124 syntmp-r-1105 (cons (quote ()) syntmp-maps-1130) syntmp-ellipsis?-1107)) (lambda (syntmp-x-1131 syntmp-maps-1132) (if (null? (car syntmp-maps-1132)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-map-1071 syntmp-x-1131 (car syntmp-maps-1132)) (cdr syntmp-maps-1132)))))))) ((lambda (syntmp-tmp-1133) ((lambda (syntmp-tmp-1134) (if (if syntmp-tmp-1134 (apply (lambda (syntmp-dots-1135 syntmp-y-1136) (syntmp-ellipsis?-1107 syntmp-dots-1135)) syntmp-tmp-1134) #f) (apply (lambda (syntmp-dots-1137 syntmp-y-1138) (syntmp-f-1127 syntmp-y-1138 (lambda (syntmp-maps-1139) (call-with-values (lambda () (syntmp-k-1129 (cons (quote ()) syntmp-maps-1139))) (lambda (syntmp-x-1140 syntmp-maps-1141) (if (null? (car syntmp-maps-1141)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1070 syntmp-x-1140 (car syntmp-maps-1141)) (cdr syntmp-maps-1141)))))))) syntmp-tmp-1134) ((lambda (syntmp-_-1142) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1128 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1143 syntmp-maps-1144) (call-with-values (lambda () (syntmp-k-1129 syntmp-maps-1144)) (lambda (syntmp-x-1145 syntmp-maps-1146) (values (syntmp-gen-append-1073 syntmp-x-1145 syntmp-y-1143) syntmp-maps-1146)))))) syntmp-tmp-1133))) (syntax-dispatch syntmp-tmp-1133 (quote (any . any))))) syntmp-y-1128))) syntmp-tmp-1120) ((lambda (syntmp-tmp-1147) (if syntmp-tmp-1147 (apply (lambda (syntmp-x-1148 syntmp-y-1149) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1148 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-x-1150 syntmp-maps-1151) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1149 syntmp-r-1105 syntmp-maps-1151 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1152 syntmp-maps-1153) (values (syntmp-gen-cons-1072 syntmp-x-1150 syntmp-y-1152) syntmp-maps-1153)))))) syntmp-tmp-1147) ((lambda (syntmp-tmp-1154) (if syntmp-tmp-1154 (apply (lambda (syntmp-e1-1155 syntmp-e2-1156) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 (cons syntmp-e1-1155 syntmp-e2-1156) syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-e-1158 syntmp-maps-1159) (values (syntmp-gen-vector-1074 syntmp-e-1158) syntmp-maps-1159)))) syntmp-tmp-1154) ((lambda (syntmp-_-1160) (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106)) syntmp-tmp-1113))) (syntax-dispatch syntmp-tmp-1113 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1113 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any))))) syntmp-e-1104))))) (lambda (syntmp-e-1161 syntmp-r-1162 syntmp-w-1163 syntmp-s-1164) (let ((syntmp-e-1165 (syntmp-source-wrap-133 syntmp-e-1161 syntmp-w-1163 syntmp-s-1164))) ((lambda (syntmp-tmp-1166) ((lambda (syntmp-tmp-1167) (if syntmp-tmp-1167 (apply (lambda (syntmp-_-1168 syntmp-x-1169) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-e-1165 syntmp-x-1169 syntmp-r-1162 (quote ()) syntmp-ellipsis?-149)) (lambda (syntmp-e-1170 syntmp-maps-1171) (syntmp-regen-1075 syntmp-e-1170)))) syntmp-tmp-1167) ((lambda (syntmp-_-1172) (syntax-error syntmp-e-1165)) syntmp-tmp-1166))) (syntax-dispatch syntmp-tmp-1166 (quote (any any))))) syntmp-e-1165))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1173 syntmp-r-1174 syntmp-w-1175 syntmp-s-1176) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if syntmp-tmp-1178 (apply (lambda (syntmp-_-1179 syntmp-c-1180) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1173 syntmp-w-1175 syntmp-s-1176) syntmp-c-1180 syntmp-r-1174 syntmp-w-1175 (lambda (syntmp-vars-1181 syntmp-body-1182) (syntmp-build-annotated-81 syntmp-s-1176 (list (quote lambda) syntmp-vars-1181 syntmp-body-1182))))) syntmp-tmp-1178) (syntax-error syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-e-1173))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1183 (lambda (syntmp-e-1184 syntmp-r-1185 syntmp-w-1186 syntmp-s-1187 syntmp-constructor-1188 syntmp-ids-1189 syntmp-vals-1190 syntmp-exps-1191) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1189)) (syntax-error syntmp-e-1184 "duplicate bound variable in") (let ((syntmp-labels-1192 (syntmp-gen-labels-110 syntmp-ids-1189)) (syntmp-new-vars-1193 (map syntmp-gen-var-152 syntmp-ids-1189))) (let ((syntmp-nw-1194 (syntmp-make-binding-wrap-121 syntmp-ids-1189 syntmp-labels-1192 syntmp-w-1186)) (syntmp-nr-1195 (syntmp-extend-var-env-99 syntmp-labels-1192 syntmp-new-vars-1193 syntmp-r-1185))) (syntmp-constructor-1188 syntmp-s-1187 syntmp-new-vars-1193 (map (lambda (syntmp-x-1196) (syntmp-chi-140 syntmp-x-1196 syntmp-r-1185 syntmp-w-1186)) syntmp-vals-1190) (syntmp-chi-body-144 syntmp-exps-1191 (syntmp-source-wrap-133 syntmp-e-1184 syntmp-nw-1194 syntmp-s-1187) syntmp-nr-1195 syntmp-nw-1194)))))))) (lambda (syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if syntmp-tmp-1202 (apply (lambda (syntmp-_-1203 syntmp-id-1204 syntmp-val-1205 syntmp-e1-1206 syntmp-e2-1207) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-let-84 syntmp-id-1204 syntmp-val-1205 (cons syntmp-e1-1206 syntmp-e2-1207))) syntmp-tmp-1202) ((lambda (syntmp-tmp-1211) (if (if syntmp-tmp-1211 (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-id?-104 syntmp-f-1213)) syntmp-tmp-1211) #f) (apply (lambda (syntmp-_-1218 syntmp-f-1219 syntmp-id-1220 syntmp-val-1221 syntmp-e1-1222 syntmp-e2-1223) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-named-let-85 (cons syntmp-f-1219 syntmp-id-1220) syntmp-val-1221 (cons syntmp-e1-1222 syntmp-e2-1223))) syntmp-tmp-1211) ((lambda (syntmp-_-1227) (syntax-error (syntmp-source-wrap-133 syntmp-e-1197 syntmp-w-1199 syntmp-s-1200))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1201 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1197)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1228 syntmp-r-1229 syntmp-w-1230 syntmp-s-1231) ((lambda (syntmp-tmp-1232) ((lambda (syntmp-tmp-1233) (if syntmp-tmp-1233 (apply (lambda (syntmp-_-1234 syntmp-id-1235 syntmp-val-1236 syntmp-e1-1237 syntmp-e2-1238) (let ((syntmp-ids-1239 syntmp-id-1235)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1239)) (syntax-error syntmp-e-1228 "duplicate bound variable in") (let ((syntmp-labels-1241 (syntmp-gen-labels-110 syntmp-ids-1239)) (syntmp-new-vars-1242 (map syntmp-gen-var-152 syntmp-ids-1239))) (let ((syntmp-w-1243 (syntmp-make-binding-wrap-121 syntmp-ids-1239 syntmp-labels-1241 syntmp-w-1230)) (syntmp-r-1244 (syntmp-extend-var-env-99 syntmp-labels-1241 syntmp-new-vars-1242 syntmp-r-1229))) (syntmp-build-letrec-86 syntmp-s-1231 syntmp-new-vars-1242 (map (lambda (syntmp-x-1245) (syntmp-chi-140 syntmp-x-1245 syntmp-r-1244 syntmp-w-1243)) syntmp-val-1236) (syntmp-chi-body-144 (cons syntmp-e1-1237 syntmp-e2-1238) (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1243 syntmp-s-1231) syntmp-r-1244 syntmp-w-1243))))))) syntmp-tmp-1233) ((lambda (syntmp-_-1248) (syntax-error (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1230 syntmp-s-1231))) syntmp-tmp-1232))) (syntax-dispatch syntmp-tmp-1232 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1228))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1249 syntmp-r-1250 syntmp-w-1251 syntmp-s-1252) ((lambda (syntmp-tmp-1253) ((lambda (syntmp-tmp-1254) (if (if syntmp-tmp-1254 (apply (lambda (syntmp-_-1255 syntmp-id-1256 syntmp-val-1257) (syntmp-id?-104 syntmp-id-1256)) syntmp-tmp-1254) #f) (apply (lambda (syntmp-_-1258 syntmp-id-1259 syntmp-val-1260) (let ((syntmp-val-1261 (syntmp-chi-140 syntmp-val-1260 syntmp-r-1250 syntmp-w-1251)) (syntmp-n-1262 (syntmp-id-var-name-126 syntmp-id-1259 syntmp-w-1251))) (let ((syntmp-b-1263 (syntmp-lookup-101 syntmp-n-1262 syntmp-r-1250))) (let ((syntmp-t-1264 (syntmp-binding-type-96 syntmp-b-1263))) (if (memv syntmp-t-1264 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1263) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (make-module-ref #f syntmp-n-1262 #f) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1259 syntmp-w-1251) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))))))))) syntmp-tmp-1254) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (apply (lambda (syntmp-_-1266 syntmp-getter-1267 syntmp-arg-1268 syntmp-val-1269) (syntmp-build-annotated-81 syntmp-s-1252 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1267) syntmp-r-1250 syntmp-w-1251) (map (lambda (syntmp-e-1270) (syntmp-chi-140 syntmp-e-1270 syntmp-r-1250 syntmp-w-1251)) (append syntmp-arg-1268 (list syntmp-val-1269)))))) syntmp-tmp-1265) ((lambda (syntmp-_-1272) (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))) syntmp-tmp-1253))) (syntax-dispatch syntmp-tmp-1253 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1253 (quote (any any any))))) syntmp-e-1249))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1276 (lambda (syntmp-x-1277 syntmp-keys-1278 syntmp-clauses-1279 syntmp-r-1280) (if (null? syntmp-clauses-1279) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1277)) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-exp-1284) (if (and (syntmp-id?-104 syntmp-pat-1283) (andmap (lambda (syntmp-x-1285) (not (syntmp-free-id=?-127 syntmp-pat-1283 syntmp-x-1285))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1278))) (let ((syntmp-labels-1286 (list (syntmp-gen-label-109))) (syntmp-var-1287 (syntmp-gen-var-152 syntmp-pat-1283))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1287) (syntmp-chi-140 syntmp-exp-1284 (syntmp-extend-env-98 syntmp-labels-1286 (list (cons (quote syntax) (cons syntmp-var-1287 0))) syntmp-r-1280) (syntmp-make-binding-wrap-121 (list syntmp-pat-1283) syntmp-labels-1286 (quote (())))))) syntmp-x-1277))) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1283 #t syntmp-exp-1284))) syntmp-tmp-1282) ((lambda (syntmp-tmp-1288) (if syntmp-tmp-1288 (apply (lambda (syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291)) syntmp-tmp-1288) ((lambda (syntmp-_-1292) (syntax-error (car syntmp-clauses-1279) "invalid syntax-case clause")) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1281 (quote (any any))))) (car syntmp-clauses-1279))))) (syntmp-gen-clause-1275 (lambda (syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296 syntmp-pat-1297 syntmp-fender-1298 syntmp-exp-1299) (call-with-values (lambda () (syntmp-convert-pattern-1273 syntmp-pat-1297 syntmp-keys-1294)) (lambda (syntmp-p-1300 syntmp-pvars-1301) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1301))) (syntax-error syntmp-pat-1297 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1302) (not (syntmp-ellipsis?-149 (car syntmp-x-1302)))) syntmp-pvars-1301)) (syntax-error syntmp-pat-1297 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1303 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1303) (let ((syntmp-y-1304 (syntmp-build-annotated-81 #f syntmp-y-1303))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda () syntmp-y-1304) syntmp-tmp-1306) ((lambda (syntmp-_-1307) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1304 (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-fender-1298 syntmp-y-1304 syntmp-r-1296) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote #(atom #t))))) syntmp-fender-1298) (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-exp-1299 syntmp-y-1304 syntmp-r-1296) (syntmp-gen-syntax-case-1276 syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296)))))) (if (eq? syntmp-p-1300 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1293)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1293 (syntmp-build-data-82 #f syntmp-p-1300))))))))))))) (syntmp-build-dispatch-call-1274 (lambda (syntmp-pvars-1308 syntmp-exp-1309 syntmp-y-1310 syntmp-r-1311) (let ((syntmp-ids-1312 (map car syntmp-pvars-1308)) (syntmp-levels-1313 (map cdr syntmp-pvars-1308))) (let ((syntmp-labels-1314 (syntmp-gen-labels-110 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-152 syntmp-ids-1312))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1315 (syntmp-chi-140 syntmp-exp-1309 (syntmp-extend-env-98 syntmp-labels-1314 (map (lambda (syntmp-var-1316 syntmp-level-1317) (cons (quote syntax) (cons syntmp-var-1316 syntmp-level-1317))) syntmp-new-vars-1315 (map cdr syntmp-pvars-1308)) syntmp-r-1311) (syntmp-make-binding-wrap-121 syntmp-ids-1312 syntmp-labels-1314 (quote (())))))) syntmp-y-1310)))))) (syntmp-convert-pattern-1273 (lambda (syntmp-pattern-1318 syntmp-keys-1319) (let syntmp-cvt-1320 ((syntmp-p-1321 syntmp-pattern-1318) (syntmp-n-1322 0) (syntmp-ids-1323 (quote ()))) (if (syntmp-id?-104 syntmp-p-1321) (if (syntmp-bound-id-member?-131 syntmp-p-1321 syntmp-keys-1319) (values (vector (quote free-id) syntmp-p-1321) syntmp-ids-1323) (values (quote any) (cons (cons syntmp-p-1321 syntmp-n-1322) syntmp-ids-1323))) ((lambda (syntmp-tmp-1324) ((lambda (syntmp-tmp-1325) (if (if syntmp-tmp-1325 (apply (lambda (syntmp-x-1326 syntmp-dots-1327) (syntmp-ellipsis?-149 syntmp-dots-1327)) syntmp-tmp-1325) #f) (apply (lambda (syntmp-x-1328 syntmp-dots-1329) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1328 (syntmp-fx+-72 syntmp-n-1322 1) syntmp-ids-1323)) (lambda (syntmp-p-1330 syntmp-ids-1331) (values (if (eq? syntmp-p-1330 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1330)) syntmp-ids-1331)))) syntmp-tmp-1325) ((lambda (syntmp-tmp-1332) (if syntmp-tmp-1332 (apply (lambda (syntmp-x-1333 syntmp-y-1334) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-y-1334 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-y-1335 syntmp-ids-1336) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1333 syntmp-n-1322 syntmp-ids-1336)) (lambda (syntmp-x-1337 syntmp-ids-1338) (values (cons syntmp-x-1337 syntmp-y-1335) syntmp-ids-1338)))))) syntmp-tmp-1332) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda () (values (quote ()) syntmp-ids-1323)) syntmp-tmp-1339) ((lambda (syntmp-tmp-1340) (if syntmp-tmp-1340 (apply (lambda (syntmp-x-1341) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1341 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-p-1343 syntmp-ids-1344) (values (vector (quote vector) syntmp-p-1343) syntmp-ids-1344)))) syntmp-tmp-1340) ((lambda (syntmp-x-1345) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1321 (quote (())))) syntmp-ids-1323)) syntmp-tmp-1324))) (syntax-dispatch syntmp-tmp-1324 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1324 (quote ()))))) (syntax-dispatch syntmp-tmp-1324 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1324 (quote (any any))))) syntmp-p-1321)))))) (lambda (syntmp-e-1346 syntmp-r-1347 syntmp-w-1348 syntmp-s-1349) (let ((syntmp-e-1350 (syntmp-source-wrap-133 syntmp-e-1346 syntmp-w-1348 syntmp-s-1349))) ((lambda (syntmp-tmp-1351) ((lambda (syntmp-tmp-1352) (if syntmp-tmp-1352 (apply (lambda (syntmp-_-1353 syntmp-val-1354 syntmp-key-1355 syntmp-m-1356) (if (andmap (lambda (syntmp-x-1357) (and (syntmp-id?-104 syntmp-x-1357) (not (syntmp-ellipsis?-149 syntmp-x-1357)))) syntmp-key-1355) (let ((syntmp-x-1359 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1349 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1359) (syntmp-gen-syntax-case-1276 (syntmp-build-annotated-81 #f syntmp-x-1359) syntmp-key-1355 syntmp-m-1356 syntmp-r-1347))) (syntmp-chi-140 syntmp-val-1354 syntmp-r-1347 (quote (())))))) (syntax-error syntmp-e-1350 "invalid literals list in"))) syntmp-tmp-1352) (syntax-error syntmp-tmp-1351))) (syntax-dispatch syntmp-tmp-1351 (quote (any any each-any . each-any))))) syntmp-e-1350))))) (set! sc-expand (let ((syntmp-m-1362 (quote e)) (syntmp-esew-1363 (quote (eval)))) (lambda (syntmp-x-1364) (if (and (pair? syntmp-x-1364) (equal? (car syntmp-x-1364) syntmp-noexpand-71)) (cadr syntmp-x-1364) (syntmp-chi-top-139 syntmp-x-1364 (quote ()) (quote ((top))) syntmp-m-1362 syntmp-esew-1363))))) (set! sc-expand3 (let ((syntmp-m-1365 (quote e)) (syntmp-esew-1366 (quote (eval)))) (lambda (syntmp-x-1368 . syntmp-rest-1367) (if (and (pair? syntmp-x-1368) (equal? (car syntmp-x-1368) syntmp-noexpand-71)) (cadr syntmp-x-1368) (syntmp-chi-top-139 syntmp-x-1368 (quote ()) (quote ((top))) (if (null? syntmp-rest-1367) syntmp-m-1365 (car syntmp-rest-1367)) (if (or (null? syntmp-rest-1367) (null? (cdr syntmp-rest-1367))) syntmp-esew-1366 (cadr syntmp-rest-1367))))))) (set! identifier? (lambda (syntmp-x-1369) (syntmp-nonsymbol-id?-103 syntmp-x-1369))) (set! datum->syntax-object (lambda (syntmp-id-1370 syntmp-datum-1371) (syntmp-make-syntax-object-87 syntmp-datum-1371 (syntmp-syntax-object-wrap-90 syntmp-id-1370)))) (set! syntax-object->datum (lambda (syntmp-x-1372) (syntmp-strip-151 syntmp-x-1372 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1373) (begin (let ((syntmp-x-1374 syntmp-ls-1373)) (if (not (list? syntmp-x-1374)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1374))) (map (lambda (syntmp-x-1375) (syntmp-wrap-132 (gensym) (quote ((top))))) syntmp-ls-1373)))) (set! free-identifier=? (lambda (syntmp-x-1376 syntmp-y-1377) (begin (let ((syntmp-x-1378 syntmp-x-1376)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1378)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1378))) (let ((syntmp-x-1379 syntmp-y-1377)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1379)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1379))) (syntmp-free-id=?-127 syntmp-x-1376 syntmp-y-1377)))) (set! bound-identifier=? (lambda (syntmp-x-1380 syntmp-y-1381) (begin (let ((syntmp-x-1382 syntmp-x-1380)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1382)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1382))) (let ((syntmp-x-1383 syntmp-y-1381)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1383)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1383))) (syntmp-bound-id=?-128 syntmp-x-1380 syntmp-y-1381)))) (set! syntax-error (lambda (syntmp-object-1385 . syntmp-messages-1384) (begin (for-each (lambda (syntmp-x-1386) (let ((syntmp-x-1387 syntmp-x-1386)) (if (not (string? syntmp-x-1387)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1387)))) syntmp-messages-1384) (let ((syntmp-message-1388 (if (null? syntmp-messages-1384) "invalid syntax" (apply string-append syntmp-messages-1384)))) (syntmp-error-hook-78 #f syntmp-message-1388 (syntmp-strip-151 syntmp-object-1385 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1389 syntmp-v-1390) (begin (let ((syntmp-x-1391 syntmp-sym-1389)) (if (not (symbol? syntmp-x-1391)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1391))) (let ((syntmp-x-1392 syntmp-v-1390)) (if (not (procedure? syntmp-x-1392)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1392))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1389 syntmp-v-1390)))) (letrec ((syntmp-match-1397 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((not syntmp-r-1401) #f) ((eq? syntmp-p-1399 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1398 syntmp-w-1400) syntmp-r-1401)) ((syntmp-syntax-object?-88 syntmp-e-1398) (syntmp-match*-1396 (let ((syntmp-e-1402 (syntmp-syntax-object-expression-89 syntmp-e-1398))) (if (annotation? syntmp-e-1402) (annotation-expression syntmp-e-1402) syntmp-e-1402)) syntmp-p-1399 (syntmp-join-wraps-123 syntmp-w-1400 (syntmp-syntax-object-wrap-90 syntmp-e-1398)) syntmp-r-1401)) (else (syntmp-match*-1396 (let ((syntmp-e-1403 syntmp-e-1398)) (if (annotation? syntmp-e-1403) (annotation-expression syntmp-e-1403) syntmp-e-1403)) syntmp-p-1399 syntmp-w-1400 syntmp-r-1401))))) (syntmp-match*-1396 (lambda (syntmp-e-1404 syntmp-p-1405 syntmp-w-1406 syntmp-r-1407) (cond ((null? syntmp-p-1405) (and (null? syntmp-e-1404) syntmp-r-1407)) ((pair? syntmp-p-1405) (and (pair? syntmp-e-1404) (syntmp-match-1397 (car syntmp-e-1404) (car syntmp-p-1405) syntmp-w-1406 (syntmp-match-1397 (cdr syntmp-e-1404) (cdr syntmp-p-1405) syntmp-w-1406 syntmp-r-1407)))) ((eq? syntmp-p-1405 (quote each-any)) (let ((syntmp-l-1408 (syntmp-match-each-any-1394 syntmp-e-1404 syntmp-w-1406))) (and syntmp-l-1408 (cons syntmp-l-1408 syntmp-r-1407)))) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1405 0))) (if (memv syntmp-t-1409 (quote (each))) (if (null? syntmp-e-1404) (syntmp-match-empty-1395 (vector-ref syntmp-p-1405 1) syntmp-r-1407) (let ((syntmp-l-1410 (syntmp-match-each-1393 syntmp-e-1404 (vector-ref syntmp-p-1405 1) syntmp-w-1406))) (and syntmp-l-1410 (let syntmp-collect-1411 ((syntmp-l-1412 syntmp-l-1410)) (if (null? (car syntmp-l-1412)) syntmp-r-1407 (cons (map car syntmp-l-1412) (syntmp-collect-1411 (map cdr syntmp-l-1412)))))))) (if (memv syntmp-t-1409 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1404) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1404 syntmp-w-1406) (vector-ref syntmp-p-1405 1)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (atom))) (and (equal? (vector-ref syntmp-p-1405 1) (syntmp-strip-151 syntmp-e-1404 syntmp-w-1406)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (vector))) (and (vector? syntmp-e-1404) (syntmp-match-1397 (vector->list syntmp-e-1404) (vector-ref syntmp-p-1405 1) syntmp-w-1406 syntmp-r-1407))))))))))) (syntmp-match-empty-1395 (lambda (syntmp-p-1413 syntmp-r-1414) (cond ((null? syntmp-p-1413) syntmp-r-1414) ((eq? syntmp-p-1413 (quote any)) (cons (quote ()) syntmp-r-1414)) ((pair? syntmp-p-1413) (syntmp-match-empty-1395 (car syntmp-p-1413) (syntmp-match-empty-1395 (cdr syntmp-p-1413) syntmp-r-1414))) ((eq? syntmp-p-1413 (quote each-any)) (cons (quote ()) syntmp-r-1414)) (else (let ((syntmp-t-1415 (vector-ref syntmp-p-1413 0))) (if (memv syntmp-t-1415 (quote (each))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414) (if (memv syntmp-t-1415 (quote (free-id atom))) syntmp-r-1414 (if (memv syntmp-t-1415 (quote (vector))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414))))))))) (syntmp-match-each-any-1394 (lambda (syntmp-e-1416 syntmp-w-1417) (cond ((annotation? syntmp-e-1416) (syntmp-match-each-any-1394 (annotation-expression syntmp-e-1416) syntmp-w-1417)) ((pair? syntmp-e-1416) (let ((syntmp-l-1418 (syntmp-match-each-any-1394 (cdr syntmp-e-1416) syntmp-w-1417))) (and syntmp-l-1418 (cons (syntmp-wrap-132 (car syntmp-e-1416) syntmp-w-1417) syntmp-l-1418)))) ((null? syntmp-e-1416) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1416) (syntmp-match-each-any-1394 (syntmp-syntax-object-expression-89 syntmp-e-1416) (syntmp-join-wraps-123 syntmp-w-1417 (syntmp-syntax-object-wrap-90 syntmp-e-1416)))) (else #f)))) (syntmp-match-each-1393 (lambda (syntmp-e-1419 syntmp-p-1420 syntmp-w-1421) (cond ((annotation? syntmp-e-1419) (syntmp-match-each-1393 (annotation-expression syntmp-e-1419) syntmp-p-1420 syntmp-w-1421)) ((pair? syntmp-e-1419) (let ((syntmp-first-1422 (syntmp-match-1397 (car syntmp-e-1419) syntmp-p-1420 syntmp-w-1421 (quote ())))) (and syntmp-first-1422 (let ((syntmp-rest-1423 (syntmp-match-each-1393 (cdr syntmp-e-1419) syntmp-p-1420 syntmp-w-1421))) (and syntmp-rest-1423 (cons syntmp-first-1422 syntmp-rest-1423)))))) ((null? syntmp-e-1419) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1419) (syntmp-match-each-1393 (syntmp-syntax-object-expression-89 syntmp-e-1419) syntmp-p-1420 (syntmp-join-wraps-123 syntmp-w-1421 (syntmp-syntax-object-wrap-90 syntmp-e-1419)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1424 syntmp-p-1425) (cond ((eq? syntmp-p-1425 (quote any)) (list syntmp-e-1424)) ((syntmp-syntax-object?-88 syntmp-e-1424) (syntmp-match*-1396 (let ((syntmp-e-1426 (syntmp-syntax-object-expression-89 syntmp-e-1424))) (if (annotation? syntmp-e-1426) (annotation-expression syntmp-e-1426) syntmp-e-1426)) syntmp-p-1425 (syntmp-syntax-object-wrap-90 syntmp-e-1424) (quote ()))) (else (syntmp-match*-1396 (let ((syntmp-e-1427 syntmp-e-1424)) (if (annotation? syntmp-e-1427) (annotation-expression syntmp-e-1427) syntmp-e-1427)) syntmp-p-1425 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-140))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1428) ((lambda (syntmp-tmp-1429) ((lambda (syntmp-tmp-1430) (if syntmp-tmp-1430 (apply (lambda (syntmp-_-1431 syntmp-e1-1432 syntmp-e2-1433) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1432 syntmp-e2-1433))) syntmp-tmp-1430) ((lambda (syntmp-tmp-1435) (if syntmp-tmp-1435 (apply (lambda (syntmp-_-1436 syntmp-out-1437 syntmp-in-1438 syntmp-e1-1439 syntmp-e2-1440) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1438 (quote ()) (list syntmp-out-1437 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1439 syntmp-e2-1440))))) syntmp-tmp-1435) ((lambda (syntmp-tmp-1442) (if syntmp-tmp-1442 (apply (lambda (syntmp-_-1443 syntmp-out-1444 syntmp-in-1445 syntmp-e1-1446 syntmp-e2-1447) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1445) (quote ()) (list syntmp-out-1444 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1446 syntmp-e2-1447))))) syntmp-tmp-1442) (syntax-error syntmp-tmp-1429))) (syntax-dispatch syntmp-tmp-1429 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any () any . each-any))))) syntmp-x-1428))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1469) ((lambda (syntmp-tmp-1470) ((lambda (syntmp-tmp-1471) (if syntmp-tmp-1471 (apply (lambda (syntmp-_-1472 syntmp-k-1473 syntmp-keyword-1474 syntmp-pattern-1475 syntmp-template-1476) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1473 (map (lambda (syntmp-tmp-1479 syntmp-tmp-1478) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1478) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1479))) syntmp-template-1476 syntmp-pattern-1475)))))) syntmp-tmp-1471) (syntax-error syntmp-tmp-1470))) (syntax-dispatch syntmp-tmp-1470 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1469))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1490) ((lambda (syntmp-tmp-1491) ((lambda (syntmp-tmp-1492) (if (if syntmp-tmp-1492 (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (andmap identifier? syntmp-x-1494)) syntmp-tmp-1492) #f) (apply (lambda (syntmp-let*-1499 syntmp-x-1500 syntmp-v-1501 syntmp-e1-1502 syntmp-e2-1503) (let syntmp-f-1504 ((syntmp-bindings-1505 (map list syntmp-x-1500 syntmp-v-1501))) (if (null? syntmp-bindings-1505) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1502 syntmp-e2-1503))) ((lambda (syntmp-tmp-1509) ((lambda (syntmp-tmp-1510) (if syntmp-tmp-1510 (apply (lambda (syntmp-body-1511 syntmp-binding-1512) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1512) syntmp-body-1511)) syntmp-tmp-1510) (syntax-error syntmp-tmp-1509))) (syntax-dispatch syntmp-tmp-1509 (quote (any any))))) (list (syntmp-f-1504 (cdr syntmp-bindings-1505)) (car syntmp-bindings-1505)))))) syntmp-tmp-1492) (syntax-error syntmp-tmp-1491))) (syntax-dispatch syntmp-tmp-1491 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1490))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1532) ((lambda (syntmp-tmp-1533) ((lambda (syntmp-tmp-1534) (if syntmp-tmp-1534 (apply (lambda (syntmp-_-1535 syntmp-var-1536 syntmp-init-1537 syntmp-step-1538 syntmp-e0-1539 syntmp-e1-1540 syntmp-c-1541) ((lambda (syntmp-tmp-1542) ((lambda (syntmp-tmp-1543) (if syntmp-tmp-1543 (apply (lambda (syntmp-step-1544) ((lambda (syntmp-tmp-1545) ((lambda (syntmp-tmp-1546) (if syntmp-tmp-1546 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1539) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1544))))))) syntmp-tmp-1546) ((lambda (syntmp-tmp-1551) (if syntmp-tmp-1551 (apply (lambda (syntmp-e1-1552 syntmp-e2-1553) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1539 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1552 syntmp-e2-1553)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1544))))))) syntmp-tmp-1551) (syntax-error syntmp-tmp-1545))) (syntax-dispatch syntmp-tmp-1545 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1545 (quote ())))) syntmp-e1-1540)) syntmp-tmp-1543) (syntax-error syntmp-tmp-1542))) (syntax-dispatch syntmp-tmp-1542 (quote each-any)))) (map (lambda (syntmp-v-1560 syntmp-s-1561) ((lambda (syntmp-tmp-1562) ((lambda (syntmp-tmp-1563) (if syntmp-tmp-1563 (apply (lambda () syntmp-v-1560) syntmp-tmp-1563) ((lambda (syntmp-tmp-1564) (if syntmp-tmp-1564 (apply (lambda (syntmp-e-1565) syntmp-e-1565) syntmp-tmp-1564) ((lambda (syntmp-_-1566) (syntax-error syntmp-orig-x-1532)) syntmp-tmp-1562))) (syntax-dispatch syntmp-tmp-1562 (quote (any)))))) (syntax-dispatch syntmp-tmp-1562 (quote ())))) syntmp-s-1561)) syntmp-var-1536 syntmp-step-1538))) syntmp-tmp-1534) (syntax-error syntmp-tmp-1533))) (syntax-dispatch syntmp-tmp-1533 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1532))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1594 (lambda (syntmp-x-1598 syntmp-y-1599) ((lambda (syntmp-tmp-1600) ((lambda (syntmp-tmp-1601) (if syntmp-tmp-1601 (apply (lambda (syntmp-x-1602 syntmp-y-1603) ((lambda (syntmp-tmp-1604) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-dy-1606) ((lambda (syntmp-tmp-1607) ((lambda (syntmp-tmp-1608) (if syntmp-tmp-1608 (apply (lambda (syntmp-dx-1609) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1609 syntmp-dy-1606))) syntmp-tmp-1608) ((lambda (syntmp-_-1610) (if (null? syntmp-dy-1606) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1602) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1602 syntmp-y-1603))) syntmp-tmp-1607))) (syntax-dispatch syntmp-tmp-1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1602)) syntmp-tmp-1605) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-stuff-1612) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1602 syntmp-stuff-1612))) syntmp-tmp-1611) ((lambda (syntmp-else-1613) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1602 syntmp-y-1603)) syntmp-tmp-1604))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1603)) syntmp-tmp-1601) (syntax-error syntmp-tmp-1600))) (syntax-dispatch syntmp-tmp-1600 (quote (any any))))) (list syntmp-x-1598 syntmp-y-1599)))) (syntmp-quasiappend-1595 (lambda (syntmp-x-1614 syntmp-y-1615) ((lambda (syntmp-tmp-1616) ((lambda (syntmp-tmp-1617) (if syntmp-tmp-1617 (apply (lambda (syntmp-x-1618 syntmp-y-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda () syntmp-x-1618) syntmp-tmp-1621) ((lambda (syntmp-_-1622) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1618 syntmp-y-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1619)) syntmp-tmp-1617) (syntax-error syntmp-tmp-1616))) (syntax-dispatch syntmp-tmp-1616 (quote (any any))))) (list syntmp-x-1614 syntmp-y-1615)))) (syntmp-quasivector-1596 (lambda (syntmp-x-1623) ((lambda (syntmp-tmp-1624) ((lambda (syntmp-x-1625) ((lambda (syntmp-tmp-1626) ((lambda (syntmp-tmp-1627) (if syntmp-tmp-1627 (apply (lambda (syntmp-x-1628) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1628))) syntmp-tmp-1627) ((lambda (syntmp-tmp-1630) (if syntmp-tmp-1630 (apply (lambda (syntmp-x-1631) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1631)) syntmp-tmp-1630) ((lambda (syntmp-_-1633) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1625)) syntmp-tmp-1626))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1625)) syntmp-tmp-1624)) syntmp-x-1623))) (syntmp-quasi-1597 (lambda (syntmp-p-1634 syntmp-lev-1635) ((lambda (syntmp-tmp-1636) ((lambda (syntmp-tmp-1637) (if syntmp-tmp-1637 (apply (lambda (syntmp-p-1638) (if (= syntmp-lev-1635 0) syntmp-p-1638 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1597 (list syntmp-p-1638) (- syntmp-lev-1635 1))))) syntmp-tmp-1637) ((lambda (syntmp-tmp-1639) (if syntmp-tmp-1639 (apply (lambda (syntmp-p-1640 syntmp-q-1641) (if (= syntmp-lev-1635 0) (syntmp-quasiappend-1595 syntmp-p-1640 (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)) (syntmp-quasicons-1594 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1597 (list syntmp-p-1640) (- syntmp-lev-1635 1))) (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)))) syntmp-tmp-1639) ((lambda (syntmp-tmp-1642) (if syntmp-tmp-1642 (apply (lambda (syntmp-p-1643) (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1597 (list syntmp-p-1643) (+ syntmp-lev-1635 1)))) syntmp-tmp-1642) ((lambda (syntmp-tmp-1644) (if syntmp-tmp-1644 (apply (lambda (syntmp-p-1645 syntmp-q-1646) (syntmp-quasicons-1594 (syntmp-quasi-1597 syntmp-p-1645 syntmp-lev-1635) (syntmp-quasi-1597 syntmp-q-1646 syntmp-lev-1635))) syntmp-tmp-1644) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-x-1648) (syntmp-quasivector-1596 (syntmp-quasi-1597 syntmp-x-1648 syntmp-lev-1635))) syntmp-tmp-1647) ((lambda (syntmp-p-1650) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1650)) syntmp-tmp-1636))) (syntax-dispatch syntmp-tmp-1636 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1636 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1634)))) (lambda (syntmp-x-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda (syntmp-_-1654 syntmp-e-1655) (syntmp-quasi-1597 syntmp-e-1655 0)) syntmp-tmp-1653) (syntax-error syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any any))))) syntmp-x-1651)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1715) (letrec ((syntmp-read-file-1716 (lambda (syntmp-fn-1717 syntmp-k-1718) (let ((syntmp-p-1719 (open-input-file syntmp-fn-1717))) (let syntmp-f-1720 ((syntmp-x-1721 (read syntmp-p-1719))) (if (eof-object? syntmp-x-1721) (begin (close-input-port syntmp-p-1719) (quote ())) (cons (datum->syntax-object syntmp-k-1718 syntmp-x-1721) (syntmp-f-1720 (read syntmp-p-1719))))))))) ((lambda (syntmp-tmp-1722) ((lambda (syntmp-tmp-1723) (if syntmp-tmp-1723 (apply (lambda (syntmp-k-1724 syntmp-filename-1725) (let ((syntmp-fn-1726 (syntax-object->datum syntmp-filename-1725))) ((lambda (syntmp-tmp-1727) ((lambda (syntmp-tmp-1728) (if syntmp-tmp-1728 (apply (lambda (syntmp-exp-1729) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1729)) syntmp-tmp-1728) (syntax-error syntmp-tmp-1727))) (syntax-dispatch syntmp-tmp-1727 (quote each-any)))) (syntmp-read-file-1716 syntmp-fn-1726 syntmp-k-1724)))) syntmp-tmp-1723) (syntax-error syntmp-tmp-1722))) (syntax-dispatch syntmp-tmp-1722 (quote (any any))))) syntmp-x-1715)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1746) ((lambda (syntmp-tmp-1747) ((lambda (syntmp-tmp-1748) (if syntmp-tmp-1748 (apply (lambda (syntmp-_-1749 syntmp-e-1750) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1750))) syntmp-tmp-1748) (syntax-error syntmp-tmp-1747))) (syntax-dispatch syntmp-tmp-1747 (quote (any any))))) syntmp-x-1746))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1756) ((lambda (syntmp-tmp-1757) ((lambda (syntmp-tmp-1758) (if syntmp-tmp-1758 (apply (lambda (syntmp-_-1759 syntmp-e-1760) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1760))) syntmp-tmp-1758) (syntax-error syntmp-tmp-1757))) (syntax-dispatch syntmp-tmp-1757 (quote (any any))))) syntmp-x-1756))) +(install-global-transformer (quote case) (lambda (syntmp-x-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-tmp-1768) (if syntmp-tmp-1768 (apply (lambda (syntmp-_-1769 syntmp-e-1770 syntmp-m1-1771 syntmp-m2-1772) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-body-1774) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1770)) syntmp-body-1774)) syntmp-tmp-1773)) (let syntmp-f-1775 ((syntmp-clause-1776 syntmp-m1-1771) (syntmp-clauses-1777 syntmp-m2-1772)) (if (null? syntmp-clauses-1777) ((lambda (syntmp-tmp-1779) ((lambda (syntmp-tmp-1780) (if syntmp-tmp-1780 (apply (lambda (syntmp-e1-1781 syntmp-e2-1782) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1781 syntmp-e2-1782))) syntmp-tmp-1780) ((lambda (syntmp-tmp-1784) (if syntmp-tmp-1784 (apply (lambda (syntmp-k-1785 syntmp-e1-1786 syntmp-e2-1787) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1785)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1786 syntmp-e2-1787)))) syntmp-tmp-1784) ((lambda (syntmp-_-1790) (syntax-error syntmp-x-1766)) syntmp-tmp-1779))) (syntax-dispatch syntmp-tmp-1779 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1779 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1776) ((lambda (syntmp-tmp-1791) ((lambda (syntmp-rest-1792) ((lambda (syntmp-tmp-1793) ((lambda (syntmp-tmp-1794) (if syntmp-tmp-1794 (apply (lambda (syntmp-k-1795 syntmp-e1-1796 syntmp-e2-1797) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1795)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1796 syntmp-e2-1797)) syntmp-rest-1792)) syntmp-tmp-1794) ((lambda (syntmp-_-1800) (syntax-error syntmp-x-1766)) syntmp-tmp-1793))) (syntax-dispatch syntmp-tmp-1793 (quote (each-any any . each-any))))) syntmp-clause-1776)) syntmp-tmp-1791)) (syntmp-f-1775 (car syntmp-clauses-1777) (cdr syntmp-clauses-1777))))))) syntmp-tmp-1768) (syntax-error syntmp-tmp-1767))) (syntax-dispatch syntmp-tmp-1767 (quote (any any any . each-any))))) syntmp-x-1766))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1830) ((lambda (syntmp-tmp-1831) ((lambda (syntmp-tmp-1832) (if syntmp-tmp-1832 (apply (lambda (syntmp-_-1833 syntmp-e-1834) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1834)) (list (cons syntmp-_-1833 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1834 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1832) (syntax-error syntmp-tmp-1831))) (syntax-dispatch syntmp-tmp-1831 (quote (any any))))) syntmp-x-1830))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 40ec91642..3650aacbd 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -432,7 +432,26 @@ (syntax-rules () ((_ src id) (build-annotated src (gensym (symbol->string id)))))) -(define-structure (syntax-object expression wrap)) +;; (define-structure (syntax-object expression wrap module)) + +(define (make-syntax-object exp wrap . mod) + (vector 'syntax-object exp wrap (if (null? mod) #f (car mod)))) + +(define (syntax-object? x) + (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) 'syntax-object))) + +(define (syntax-object-expression x) + (vector-ref x 1)) +(define (syntax-object-wrap x) + (vector-ref x 2)) +(define (syntax-object-module x) + (vector-ref x 3)) +(define (set-syntax-object-expression! x y) + (vector-set! x 1 y)) +(define (set-syntax-object-wrap! x y) + (vector-set! x 2 y)) +(define (set-syntax-object-module! x y) + (vector-set! x 3 y)) (define-syntax unannotate (syntax-rules () From e02e84deedacc2209e05b935742cb8268f5f0f9a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 29 Mar 2009 11:41:02 -0700 Subject: [PATCH 032/375] finish bootstrap to syntax-objects with modules * module/ice-9/psyntax.scm: Now that we have gone through the intermediate step (in which both representations of syntax-object had to coexist), change all callers to make-syntax-object to pass the third argument, and restore the define-structure definition of syntax objects. * module/ice-9/psyntax-pp.scm: Recompile. --- module/ice-9/psyntax-pp.scm | 18 +++++++++--------- module/ice-9/psyntax.scm | 31 +++++++------------------------ 2 files changed, 16 insertions(+), 33 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index bb7af90cc..21f93f1da 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-538) (let syntmp-lvl-539 ((syntmp-vars-540 syntmp-vars-538) (syntmp-ls-541 (quote ())) (syntmp-w-542 (quote (())))) (cond ((pair? syntmp-vars-540) (syntmp-lvl-539 (cdr syntmp-vars-540) (cons (syntmp-wrap-132 (car syntmp-vars-540) syntmp-w-542) syntmp-ls-541) syntmp-w-542)) ((syntmp-id?-104 syntmp-vars-540) (cons (syntmp-wrap-132 syntmp-vars-540 syntmp-w-542) syntmp-ls-541)) ((null? syntmp-vars-540) syntmp-ls-541) ((syntmp-syntax-object?-88 syntmp-vars-540) (syntmp-lvl-539 (syntmp-syntax-object-expression-89 syntmp-vars-540) syntmp-ls-541 (syntmp-join-wraps-123 syntmp-w-542 (syntmp-syntax-object-wrap-90 syntmp-vars-540)))) ((annotation? syntmp-vars-540) (syntmp-lvl-539 (annotation-expression syntmp-vars-540) syntmp-ls-541 syntmp-w-542)) (else (cons syntmp-vars-540 syntmp-ls-541)))))) (syntmp-gen-var-152 (lambda (syntmp-id-543) (let ((syntmp-id-544 (if (syntmp-syntax-object?-88 syntmp-id-543) (syntmp-syntax-object-expression-89 syntmp-id-543) syntmp-id-543))) (if (annotation? syntmp-id-544) (syntmp-build-annotated-81 (annotation-source syntmp-id-544) (gensym (symbol->string (annotation-expression syntmp-id-544)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-544))))))) (syntmp-strip-151 (lambda (syntmp-x-545 syntmp-w-546) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-546)) (if (or (annotation? syntmp-x-545) (and (pair? syntmp-x-545) (annotation? (car syntmp-x-545)))) (syntmp-strip-annotation-150 syntmp-x-545 #f) syntmp-x-545) (let syntmp-f-547 ((syntmp-x-548 syntmp-x-545)) (cond ((syntmp-syntax-object?-88 syntmp-x-548) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-548) (syntmp-syntax-object-wrap-90 syntmp-x-548))) ((pair? syntmp-x-548) (let ((syntmp-a-549 (syntmp-f-547 (car syntmp-x-548))) (syntmp-d-550 (syntmp-f-547 (cdr syntmp-x-548)))) (if (and (eq? syntmp-a-549 (car syntmp-x-548)) (eq? syntmp-d-550 (cdr syntmp-x-548))) syntmp-x-548 (cons syntmp-a-549 syntmp-d-550)))) ((vector? syntmp-x-548) (let ((syntmp-old-551 (vector->list syntmp-x-548))) (let ((syntmp-new-552 (map syntmp-f-547 syntmp-old-551))) (if (andmap eq? syntmp-old-551 syntmp-new-552) syntmp-x-548 (list->vector syntmp-new-552))))) (else syntmp-x-548)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-553 syntmp-parent-554) (cond ((pair? syntmp-x-553) (let ((syntmp-new-555 (cons #f #f))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-555)) (set-car! syntmp-new-555 (syntmp-strip-annotation-150 (car syntmp-x-553) #f)) (set-cdr! syntmp-new-555 (syntmp-strip-annotation-150 (cdr syntmp-x-553) #f)) syntmp-new-555))) ((annotation? syntmp-x-553) (or (annotation-stripped syntmp-x-553) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-553) syntmp-x-553))) ((vector? syntmp-x-553) (let ((syntmp-new-556 (make-vector (vector-length syntmp-x-553)))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-556)) (let syntmp-loop-557 ((syntmp-i-558 (- (vector-length syntmp-x-553) 1))) (unless (syntmp-fx<-75 syntmp-i-558 0) (vector-set! syntmp-new-556 syntmp-i-558 (syntmp-strip-annotation-150 (vector-ref syntmp-x-553 syntmp-i-558) #f)) (syntmp-loop-557 (syntmp-fx--73 syntmp-i-558 1)))) syntmp-new-556))) (else syntmp-x-553)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-559) (and (syntmp-nonsymbol-id?-103 syntmp-x-559) (syntmp-free-id=?-127 syntmp-x-559 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-560) (let ((syntmp-p-561 (syntmp-local-eval-hook-77 syntmp-expanded-560))) (if (procedure? syntmp-p-561) syntmp-p-561 (syntax-error syntmp-p-561 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-562 syntmp-e-563 syntmp-r-564 syntmp-w-565 syntmp-s-566 syntmp-k-567) ((lambda (syntmp-tmp-568) ((lambda (syntmp-tmp-569) (if syntmp-tmp-569 (apply (lambda (syntmp-_-570 syntmp-id-571 syntmp-val-572 syntmp-e1-573 syntmp-e2-574) (let ((syntmp-ids-575 syntmp-id-571)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-575)) (syntax-error syntmp-e-563 "duplicate bound keyword in") (let ((syntmp-labels-577 (syntmp-gen-labels-110 syntmp-ids-575))) (let ((syntmp-new-w-578 (syntmp-make-binding-wrap-121 syntmp-ids-575 syntmp-labels-577 syntmp-w-565))) (syntmp-k-567 (cons syntmp-e1-573 syntmp-e2-574) (syntmp-extend-env-98 syntmp-labels-577 (let ((syntmp-w-580 (if syntmp-rec?-562 syntmp-new-w-578 syntmp-w-565)) (syntmp-trans-r-581 (syntmp-macros-only-env-100 syntmp-r-564))) (map (lambda (syntmp-x-582) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-582 syntmp-trans-r-581 syntmp-w-580)))) syntmp-val-572)) syntmp-r-564) syntmp-new-w-578 syntmp-s-566)))))) syntmp-tmp-569) ((lambda (syntmp-_-584) (syntax-error (syntmp-source-wrap-133 syntmp-e-563 syntmp-w-565 syntmp-s-566))) syntmp-tmp-568))) (syntax-dispatch syntmp-tmp-568 (quote (any #(each (any any)) any . each-any))))) syntmp-e-563))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-585 syntmp-c-586 syntmp-r-587 syntmp-w-588 syntmp-k-589) ((lambda (syntmp-tmp-590) ((lambda (syntmp-tmp-591) (if syntmp-tmp-591 (apply (lambda (syntmp-id-592 syntmp-e1-593 syntmp-e2-594) (let ((syntmp-ids-595 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-595)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-597 (syntmp-gen-labels-110 syntmp-ids-595)) (syntmp-new-vars-598 (map syntmp-gen-var-152 syntmp-ids-595))) (syntmp-k-589 syntmp-new-vars-598 (syntmp-chi-body-144 (cons syntmp-e1-593 syntmp-e2-594) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-597 syntmp-new-vars-598 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-ids-595 syntmp-labels-597 syntmp-w-588))))))) syntmp-tmp-591) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-ids-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-old-ids-604 (syntmp-lambda-var-list-153 syntmp-ids-601))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-604)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-605 (syntmp-gen-labels-110 syntmp-old-ids-604)) (syntmp-new-vars-606 (map syntmp-gen-var-152 syntmp-old-ids-604))) (syntmp-k-589 (let syntmp-f-607 ((syntmp-ls1-608 (cdr syntmp-new-vars-606)) (syntmp-ls2-609 (car syntmp-new-vars-606))) (if (null? syntmp-ls1-608) syntmp-ls2-609 (syntmp-f-607 (cdr syntmp-ls1-608) (cons (car syntmp-ls1-608) syntmp-ls2-609)))) (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-605 syntmp-new-vars-606 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-old-ids-604 syntmp-labels-605 syntmp-w-588))))))) syntmp-tmp-600) ((lambda (syntmp-_-611) (syntax-error syntmp-e-585)) syntmp-tmp-590))) (syntax-dispatch syntmp-tmp-590 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-590 (quote (each-any any . each-any))))) syntmp-c-586))) (syntmp-chi-body-144 (lambda (syntmp-body-612 syntmp-outer-form-613 syntmp-r-614 syntmp-w-615) (let ((syntmp-r-616 (cons (quote ("placeholder" placeholder)) syntmp-r-614))) (let ((syntmp-ribcage-617 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-618 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-615) (cons syntmp-ribcage-617 (syntmp-wrap-subst-108 syntmp-w-615))))) (let syntmp-parse-619 ((syntmp-body-620 (map (lambda (syntmp-x-626) (cons syntmp-r-616 (syntmp-wrap-132 syntmp-x-626 syntmp-w-618))) syntmp-body-612)) (syntmp-ids-621 (quote ())) (syntmp-labels-622 (quote ())) (syntmp-vars-623 (quote ())) (syntmp-vals-624 (quote ())) (syntmp-bindings-625 (quote ()))) (if (null? syntmp-body-620) (syntax-error syntmp-outer-form-613 "no expressions in body") (let ((syntmp-e-627 (cdar syntmp-body-620)) (syntmp-er-628 (caar syntmp-body-620))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-627 syntmp-er-628 (quote (())) #f syntmp-ribcage-617)) (lambda (syntmp-type-629 syntmp-value-630 syntmp-e-631 syntmp-w-632 syntmp-s-633) (let ((syntmp-t-634 syntmp-type-629)) (if (memv syntmp-t-634 (quote (define-form))) (let ((syntmp-id-635 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-636 (syntmp-gen-label-109))) (let ((syntmp-var-637 (syntmp-gen-var-152 syntmp-id-635))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-635 syntmp-label-636) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-635 syntmp-ids-621) (cons syntmp-label-636 syntmp-labels-622) (cons syntmp-var-637 syntmp-vars-623) (cons (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632)) syntmp-vals-624) (cons (cons (quote lexical) syntmp-var-637) syntmp-bindings-625))))) (if (memv syntmp-t-634 (quote (define-syntax-form))) (let ((syntmp-id-638 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-639 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-638 syntmp-label-639) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-638 syntmp-ids-621) (cons syntmp-label-639 syntmp-labels-622) syntmp-vars-623 syntmp-vals-624 (cons (cons (quote macro) (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632))) syntmp-bindings-625)))) (if (memv syntmp-t-634 (quote (begin-form))) ((lambda (syntmp-tmp-640) ((lambda (syntmp-tmp-641) (if syntmp-tmp-641 (apply (lambda (syntmp-_-642 syntmp-e1-643) (syntmp-parse-619 (let syntmp-f-644 ((syntmp-forms-645 syntmp-e1-643)) (if (null? syntmp-forms-645) (cdr syntmp-body-620) (cons (cons syntmp-er-628 (syntmp-wrap-132 (car syntmp-forms-645) syntmp-w-632)) (syntmp-f-644 (cdr syntmp-forms-645))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625)) syntmp-tmp-641) (syntax-error syntmp-tmp-640))) (syntax-dispatch syntmp-tmp-640 (quote (any . each-any))))) syntmp-e-631) (if (memv syntmp-t-634 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-630 syntmp-e-631 syntmp-er-628 syntmp-w-632 syntmp-s-633 (lambda (syntmp-forms-647 syntmp-er-648 syntmp-w-649 syntmp-s-650) (syntmp-parse-619 (let syntmp-f-651 ((syntmp-forms-652 syntmp-forms-647)) (if (null? syntmp-forms-652) (cdr syntmp-body-620) (cons (cons syntmp-er-648 (syntmp-wrap-132 (car syntmp-forms-652) syntmp-w-649)) (syntmp-f-651 (cdr syntmp-forms-652))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625))) (if (null? syntmp-ids-621) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-653) (syntmp-chi-140 (cdr syntmp-x-653) (car syntmp-x-653) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-621)) (syntax-error syntmp-outer-form-613 "invalid or duplicate identifier in definition")) (let syntmp-loop-654 ((syntmp-bs-655 syntmp-bindings-625) (syntmp-er-cache-656 #f) (syntmp-r-cache-657 #f)) (if (not (null? syntmp-bs-655)) (let ((syntmp-b-658 (car syntmp-bs-655))) (if (eq? (car syntmp-b-658) (quote macro)) (let ((syntmp-er-659 (cadr syntmp-b-658))) (let ((syntmp-r-cache-660 (if (eq? syntmp-er-659 syntmp-er-cache-656) syntmp-r-cache-657 (syntmp-macros-only-env-100 syntmp-er-659)))) (begin (set-cdr! syntmp-b-658 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-658) syntmp-r-cache-660 (quote (()))))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-659 syntmp-r-cache-660)))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-cache-656 syntmp-r-cache-657))))) (set-cdr! syntmp-r-616 (syntmp-extend-env-98 syntmp-labels-622 syntmp-bindings-625 (cdr syntmp-r-616))) (syntmp-build-letrec-86 #f syntmp-vars-623 (map (lambda (syntmp-x-661) (syntmp-chi-140 (cdr syntmp-x-661) (car syntmp-x-661) (quote (())))) syntmp-vals-624) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-662) (syntmp-chi-140 (cdr syntmp-x-662) (car syntmp-x-662) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-663 syntmp-e-664 syntmp-r-665 syntmp-w-666 syntmp-rib-667) (letrec ((syntmp-rebuild-macro-output-668 (lambda (syntmp-x-669 syntmp-m-670) (cond ((pair? syntmp-x-669) (cons (syntmp-rebuild-macro-output-668 (car syntmp-x-669) syntmp-m-670) (syntmp-rebuild-macro-output-668 (cdr syntmp-x-669) syntmp-m-670))) ((syntmp-syntax-object?-88 syntmp-x-669) (let ((syntmp-w-671 (syntmp-syntax-object-wrap-90 syntmp-x-669))) (let ((syntmp-ms-672 (syntmp-wrap-marks-107 syntmp-w-671)) (syntmp-s-673 (syntmp-wrap-subst-108 syntmp-w-671))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-669) (if (and (pair? syntmp-ms-672) (eq? (car syntmp-ms-672) #f)) (syntmp-make-wrap-106 (cdr syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cdr syntmp-s-673)) (cdr syntmp-s-673))) (syntmp-make-wrap-106 (cons syntmp-m-670 syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cons (quote shift) syntmp-s-673)) (cons (quote shift) syntmp-s-673)))))))) ((vector? syntmp-x-669) (let ((syntmp-n-674 (vector-length syntmp-x-669))) (let ((syntmp-v-675 (make-vector syntmp-n-674))) (let syntmp-doloop-676 ((syntmp-i-677 0)) (if (syntmp-fx=-74 syntmp-i-677 syntmp-n-674) syntmp-v-675 (begin (vector-set! syntmp-v-675 syntmp-i-677 (syntmp-rebuild-macro-output-668 (vector-ref syntmp-x-669 syntmp-i-677) syntmp-m-670)) (syntmp-doloop-676 (syntmp-fx+-72 syntmp-i-677 1)))))))) ((symbol? syntmp-x-669) (syntax-error syntmp-x-669 "encountered raw symbol in macro output")) (else syntmp-x-669))))) (syntmp-rebuild-macro-output-668 (syntmp-p-663 (syntmp-wrap-132 syntmp-e-664 (syntmp-anti-mark-119 syntmp-w-666))) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-678 syntmp-e-679 syntmp-r-680 syntmp-w-681 syntmp-s-682) ((lambda (syntmp-tmp-683) ((lambda (syntmp-tmp-684) (if syntmp-tmp-684 (apply (lambda (syntmp-e0-685 syntmp-e1-686) (syntmp-build-annotated-81 syntmp-s-682 (cons syntmp-x-678 (map (lambda (syntmp-e-687) (syntmp-chi-140 syntmp-e-687 syntmp-r-680 syntmp-w-681)) syntmp-e1-686)))) syntmp-tmp-684) (syntax-error syntmp-tmp-683))) (syntax-dispatch syntmp-tmp-683 (quote (any . each-any))))) syntmp-e-679))) (syntmp-chi-expr-141 (lambda (syntmp-type-689 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (let ((syntmp-t-695 syntmp-type-689)) (if (memv syntmp-t-695 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-694 syntmp-value-690) (if (memv syntmp-t-695 (quote (core external-macro))) (syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) syntmp-value-690) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) (make-module-ref #f syntmp-value-690 #f)) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (constant))) (syntmp-build-data-82 syntmp-s-694 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) (quote (())))) (if (memv syntmp-t-695 (quote (global))) (syntmp-build-annotated-81 syntmp-s-694 (make-module-ref #f syntmp-value-690 #f)) (if (memv syntmp-t-695 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-691) syntmp-r-692 syntmp-w-693) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (begin-form))) ((lambda (syntmp-tmp-696) ((lambda (syntmp-tmp-697) (if syntmp-tmp-697 (apply (lambda (syntmp-_-698 syntmp-e1-699 syntmp-e2-700) (syntmp-chi-sequence-134 (cons syntmp-e1-699 syntmp-e2-700) syntmp-r-692 syntmp-w-693 syntmp-s-694)) syntmp-tmp-697) (syntax-error syntmp-tmp-696))) (syntax-dispatch syntmp-tmp-696 (quote (any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694 syntmp-chi-sequence-134) (if (memv syntmp-t-695 (quote (eval-when-form))) ((lambda (syntmp-tmp-702) ((lambda (syntmp-tmp-703) (if syntmp-tmp-703 (apply (lambda (syntmp-_-704 syntmp-x-705 syntmp-e1-706 syntmp-e2-707) (let ((syntmp-when-list-708 (syntmp-chi-when-list-137 syntmp-e-691 syntmp-x-705 syntmp-w-693))) (if (memq (quote eval) syntmp-when-list-708) (syntmp-chi-sequence-134 (cons syntmp-e1-706 syntmp-e2-707) syntmp-r-692 syntmp-w-693 syntmp-s-694) (syntmp-chi-void-148)))) syntmp-tmp-703) (syntax-error syntmp-tmp-702))) (syntax-dispatch syntmp-tmp-702 (quote (any each-any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-690 syntmp-w-693) "invalid context for definition of") (if (memv syntmp-t-695 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to pattern variable outside syntax form") (if (memv syntmp-t-695 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694)))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-711 syntmp-r-712 syntmp-w-713) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-711 syntmp-r-712 syntmp-w-713 #f #f)) (lambda (syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-w-717 syntmp-s-718) (syntmp-chi-expr-141 syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-r-712 syntmp-w-717 syntmp-s-718))))) (syntmp-chi-top-139 (lambda (syntmp-e-719 syntmp-r-720 syntmp-w-721 syntmp-m-722 syntmp-esew-723) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-719 syntmp-r-720 syntmp-w-721 #f #f)) (lambda (syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-w-739 syntmp-s-740) (let ((syntmp-t-741 syntmp-type-736)) (if (memv syntmp-t-741 (quote (begin-form))) ((lambda (syntmp-tmp-742) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744) (syntmp-chi-void-148)) syntmp-tmp-743) ((lambda (syntmp-tmp-745) (if syntmp-tmp-745 (apply (lambda (syntmp-_-746 syntmp-e1-747 syntmp-e2-748) (syntmp-chi-top-sequence-135 (cons syntmp-e1-747 syntmp-e2-748) syntmp-r-720 syntmp-w-739 syntmp-s-740 syntmp-m-722 syntmp-esew-723)) syntmp-tmp-745) (syntax-error syntmp-tmp-742))) (syntax-dispatch syntmp-tmp-742 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-742 (quote (any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740 (lambda (syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753) (syntmp-chi-top-sequence-135 syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753 syntmp-m-722 syntmp-esew-723))) (if (memv syntmp-t-741 (quote (eval-when-form))) ((lambda (syntmp-tmp-754) ((lambda (syntmp-tmp-755) (if syntmp-tmp-755 (apply (lambda (syntmp-_-756 syntmp-x-757 syntmp-e1-758 syntmp-e2-759) (let ((syntmp-when-list-760 (syntmp-chi-when-list-137 syntmp-e-738 syntmp-x-757 syntmp-w-739)) (syntmp-body-761 (cons syntmp-e1-758 syntmp-e2-759))) (cond ((eq? syntmp-m-722 (quote e)) (if (memq (quote eval) syntmp-when-list-760) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval))) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-760) (if (or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c&e) (quote (compile load))) (if (memq syntmp-m-722 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c) (quote (load))) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval)))) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-755) (syntax-error syntmp-tmp-754))) (syntax-dispatch syntmp-tmp-754 (quote (any each-any any . each-any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (define-syntax-form))) (let ((syntmp-n-764 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739)) (syntmp-r-765 (syntmp-macros-only-env-100 syntmp-r-720))) (let ((syntmp-t-766 syntmp-m-722)) (if (memv syntmp-t-766 (quote (c))) (if (memq (quote compile) syntmp-esew-723) (let ((syntmp-e-767 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-767) (if (memq (quote load) syntmp-esew-723) syntmp-e-767 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-723) (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)) (syntmp-chi-void-148))) (if (memv syntmp-t-766 (quote (c&e))) (let ((syntmp-e-768 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-768) syntmp-e-768)) (begin (if (memq (quote eval) syntmp-esew-723) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (syntmp-chi-void-148)))))) (if (memv syntmp-t-741 (quote (define-form))) (let ((syntmp-n-769 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739))) (let ((syntmp-type-770 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-769 syntmp-r-720)))) (let ((syntmp-t-771 syntmp-type-770)) (if (memv syntmp-t-771 (quote (global))) (let ((syntmp-x-772 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)) (if (memv syntmp-t-771 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "identifier out of context") (if (eq? syntmp-type-770 (quote external-macro)) (let ((syntmp-x-773 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-773)) syntmp-x-773)) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "cannot define keyword at top level"))))))) (let ((syntmp-x-774 (syntmp-chi-expr-141 syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-774)) syntmp-x-774)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-s-778 syntmp-rib-779) (cond ((symbol? syntmp-e-775) (let ((syntmp-n-780 (syntmp-id-var-name-126 syntmp-e-775 syntmp-w-777))) (let ((syntmp-b-781 (syntmp-lookup-101 syntmp-n-780 syntmp-r-776))) (let ((syntmp-type-782 (syntmp-binding-type-96 syntmp-b-781))) (let ((syntmp-t-783 syntmp-type-782)) (if (memv syntmp-t-783 (quote (lexical))) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (global))) (values syntmp-type-782 syntmp-n-780 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778))))))))) ((pair? syntmp-e-775) (let ((syntmp-first-784 (car syntmp-e-775))) (if (syntmp-id?-104 syntmp-first-784) (let ((syntmp-n-785 (syntmp-id-var-name-126 syntmp-first-784 syntmp-w-777))) (let ((syntmp-b-786 (syntmp-lookup-101 syntmp-n-785 syntmp-r-776))) (let ((syntmp-type-787 (syntmp-binding-type-96 syntmp-b-786))) (let ((syntmp-t-788 syntmp-type-787)) (if (memv syntmp-t-788 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (global))) (values (quote global-call) syntmp-n-785 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (if (memv syntmp-t-788 (quote (core external-macro))) (values syntmp-type-787 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (begin))) (values (quote begin-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (define))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-name-792 syntmp-val-793) (syntmp-id?-104 syntmp-name-792)) syntmp-tmp-790) #f) (apply (lambda (syntmp-_-794 syntmp-name-795 syntmp-val-796) (values (quote define-form) syntmp-name-795 syntmp-val-796 syntmp-w-777 syntmp-s-778)) syntmp-tmp-790) ((lambda (syntmp-tmp-797) (if (if syntmp-tmp-797 (apply (lambda (syntmp-_-798 syntmp-name-799 syntmp-args-800 syntmp-e1-801 syntmp-e2-802) (and (syntmp-id?-104 syntmp-name-799) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-800)))) syntmp-tmp-797) #f) (apply (lambda (syntmp-_-803 syntmp-name-804 syntmp-args-805 syntmp-e1-806 syntmp-e2-807) (values (quote define-form) (syntmp-wrap-132 syntmp-name-804 syntmp-w-777) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-132 (cons syntmp-args-805 (cons syntmp-e1-806 syntmp-e2-807)) syntmp-w-777)) (quote (())) syntmp-s-778)) syntmp-tmp-797) ((lambda (syntmp-tmp-809) (if (if syntmp-tmp-809 (apply (lambda (syntmp-_-810 syntmp-name-811) (syntmp-id?-104 syntmp-name-811)) syntmp-tmp-809) #f) (apply (lambda (syntmp-_-812 syntmp-name-813) (values (quote define-form) (syntmp-wrap-132 syntmp-name-813 syntmp-w-777) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-778)) syntmp-tmp-809) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any any any))))) syntmp-e-775) (if (memv syntmp-t-788 (quote (define-syntax))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-syntax-form) syntmp-name-820 syntmp-val-821 syntmp-w-777 syntmp-s-778)) syntmp-tmp-815) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-775) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))))))))))))) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))) ((syntmp-syntax-object?-88 syntmp-e-775) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-775) syntmp-r-776 (syntmp-join-wraps-123 syntmp-w-777 (syntmp-syntax-object-wrap-90 syntmp-e-775)) #f syntmp-rib-779)) ((annotation? syntmp-e-775) (syntmp-syntax-type-138 (annotation-expression syntmp-e-775) syntmp-r-776 syntmp-w-777 (annotation-source syntmp-e-775) syntmp-rib-779)) ((self-evaluating? syntmp-e-775) (values (quote constant) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)) (else (values (quote other) #f syntmp-e-775 syntmp-w-777 syntmp-s-778))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-822 syntmp-when-list-823 syntmp-w-824) (let syntmp-f-825 ((syntmp-when-list-826 syntmp-when-list-823) (syntmp-situations-827 (quote ()))) (if (null? syntmp-when-list-826) syntmp-situations-827 (syntmp-f-825 (cdr syntmp-when-list-826) (cons (let ((syntmp-x-828 (car syntmp-when-list-826))) (cond ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-828 syntmp-w-824) "invalid eval-when situation")))) syntmp-situations-827)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-829 syntmp-e-830) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-829) syntmp-e-830)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-831 syntmp-r-832 syntmp-w-833 syntmp-s-834 syntmp-m-835 syntmp-esew-836) (syntmp-build-sequence-83 syntmp-s-834 (let syntmp-dobody-837 ((syntmp-body-838 syntmp-body-831) (syntmp-r-839 syntmp-r-832) (syntmp-w-840 syntmp-w-833) (syntmp-m-841 syntmp-m-835) (syntmp-esew-842 syntmp-esew-836)) (if (null? syntmp-body-838) (quote ()) (let ((syntmp-first-843 (syntmp-chi-top-139 (car syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842))) (cons syntmp-first-843 (syntmp-dobody-837 (cdr syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-844 syntmp-r-845 syntmp-w-846 syntmp-s-847) (syntmp-build-sequence-83 syntmp-s-847 (let syntmp-dobody-848 ((syntmp-body-849 syntmp-body-844) (syntmp-r-850 syntmp-r-845) (syntmp-w-851 syntmp-w-846)) (if (null? syntmp-body-849) (quote ()) (let ((syntmp-first-852 (syntmp-chi-140 (car syntmp-body-849) syntmp-r-850 syntmp-w-851))) (cons syntmp-first-852 (syntmp-dobody-848 (cdr syntmp-body-849) syntmp-r-850 syntmp-w-851)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-853 syntmp-w-854 syntmp-s-855) (syntmp-wrap-132 (if syntmp-s-855 (make-annotation syntmp-x-853 syntmp-s-855 #f) syntmp-x-853) syntmp-w-854))) (syntmp-wrap-132 (lambda (syntmp-x-856 syntmp-w-857) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-857)) (null? (syntmp-wrap-subst-108 syntmp-w-857))) syntmp-x-856) ((syntmp-syntax-object?-88 syntmp-x-856) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-856) (syntmp-join-wraps-123 syntmp-w-857 (syntmp-syntax-object-wrap-90 syntmp-x-856)))) ((null? syntmp-x-856) syntmp-x-856) (else (syntmp-make-syntax-object-87 syntmp-x-856 syntmp-w-857))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-858 syntmp-list-859) (and (not (null? syntmp-list-859)) (or (syntmp-bound-id=?-128 syntmp-x-858 (car syntmp-list-859)) (syntmp-bound-id-member?-131 syntmp-x-858 (cdr syntmp-list-859)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-860) (let syntmp-distinct?-861 ((syntmp-ids-862 syntmp-ids-860)) (or (null? syntmp-ids-862) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-862) (cdr syntmp-ids-862))) (syntmp-distinct?-861 (cdr syntmp-ids-862))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-863) (and (let syntmp-all-ids?-864 ((syntmp-ids-865 syntmp-ids-863)) (or (null? syntmp-ids-865) (and (syntmp-id?-104 (car syntmp-ids-865)) (syntmp-all-ids?-864 (cdr syntmp-ids-865))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-863)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-866 syntmp-j-867) (if (and (syntmp-syntax-object?-88 syntmp-i-866) (syntmp-syntax-object?-88 syntmp-j-867)) (and (eq? (let ((syntmp-e-868 (syntmp-syntax-object-expression-89 syntmp-i-866))) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 (syntmp-syntax-object-expression-89 syntmp-j-867))) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-866)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-867)))) (eq? (let ((syntmp-e-870 syntmp-i-866)) (if (annotation? syntmp-e-870) (annotation-expression syntmp-e-870) syntmp-e-870)) (let ((syntmp-e-871 syntmp-j-867)) (if (annotation? syntmp-e-871) (annotation-expression syntmp-e-871) syntmp-e-871)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-872 syntmp-j-873) (and (eq? (let ((syntmp-x-874 syntmp-i-872)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875))) (let ((syntmp-x-876 syntmp-j-873)) (let ((syntmp-e-877 (if (syntmp-syntax-object?-88 syntmp-x-876) (syntmp-syntax-object-expression-89 syntmp-x-876) syntmp-x-876))) (if (annotation? syntmp-e-877) (annotation-expression syntmp-e-877) syntmp-e-877)))) (eq? (syntmp-id-var-name-126 syntmp-i-872 (quote (()))) (syntmp-id-var-name-126 syntmp-j-873 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-878 syntmp-w-879) (letrec ((syntmp-search-vector-rib-882 (lambda (syntmp-sym-893 syntmp-subst-894 syntmp-marks-895 syntmp-symnames-896 syntmp-ribcage-897) (let ((syntmp-n-898 (vector-length syntmp-symnames-896))) (let syntmp-f-899 ((syntmp-i-900 0)) (cond ((syntmp-fx=-74 syntmp-i-900 syntmp-n-898) (syntmp-search-880 syntmp-sym-893 (cdr syntmp-subst-894) syntmp-marks-895)) ((and (eq? (vector-ref syntmp-symnames-896 syntmp-i-900) syntmp-sym-893) (syntmp-same-marks?-125 syntmp-marks-895 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-897) syntmp-i-900))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-897) syntmp-i-900) syntmp-marks-895)) (else (syntmp-f-899 (syntmp-fx+-72 syntmp-i-900 1)))))))) (syntmp-search-list-rib-881 (lambda (syntmp-sym-901 syntmp-subst-902 syntmp-marks-903 syntmp-symnames-904 syntmp-ribcage-905) (let syntmp-f-906 ((syntmp-symnames-907 syntmp-symnames-904) (syntmp-i-908 0)) (cond ((null? syntmp-symnames-907) (syntmp-search-880 syntmp-sym-901 (cdr syntmp-subst-902) syntmp-marks-903)) ((and (eq? (car syntmp-symnames-907) syntmp-sym-901) (syntmp-same-marks?-125 syntmp-marks-903 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-905) syntmp-i-908))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-905) syntmp-i-908) syntmp-marks-903)) (else (syntmp-f-906 (cdr syntmp-symnames-907) (syntmp-fx+-72 syntmp-i-908 1))))))) (syntmp-search-880 (lambda (syntmp-sym-909 syntmp-subst-910 syntmp-marks-911) (if (null? syntmp-subst-910) (values #f syntmp-marks-911) (let ((syntmp-fst-912 (car syntmp-subst-910))) (if (eq? syntmp-fst-912 (quote shift)) (syntmp-search-880 syntmp-sym-909 (cdr syntmp-subst-910) (cdr syntmp-marks-911)) (let ((syntmp-symnames-913 (syntmp-ribcage-symnames-113 syntmp-fst-912))) (if (vector? syntmp-symnames-913) (syntmp-search-vector-rib-882 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912) (syntmp-search-list-rib-881 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912))))))))) (cond ((symbol? syntmp-id-878) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-878 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-915 . syntmp-ignore-914) syntmp-x-915)) syntmp-id-878)) ((syntmp-syntax-object?-88 syntmp-id-878) (let ((syntmp-id-916 (let ((syntmp-e-918 (syntmp-syntax-object-expression-89 syntmp-id-878))) (if (annotation? syntmp-e-918) (annotation-expression syntmp-e-918) syntmp-e-918))) (syntmp-w1-917 (syntmp-syntax-object-wrap-90 syntmp-id-878))) (let ((syntmp-marks-919 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w1-917)))) (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w-879) syntmp-marks-919)) (lambda (syntmp-new-id-920 syntmp-marks-921) (or syntmp-new-id-920 (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w1-917) syntmp-marks-921)) (lambda (syntmp-x-923 . syntmp-ignore-922) syntmp-x-923)) syntmp-id-916)))))) ((annotation? syntmp-id-878) (let ((syntmp-id-924 (let ((syntmp-e-925 syntmp-id-878)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)))) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-924 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-927 . syntmp-ignore-926) syntmp-x-927)) syntmp-id-924))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-878)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-928 syntmp-y-929) (or (eq? syntmp-x-928 syntmp-y-929) (and (not (null? syntmp-x-928)) (not (null? syntmp-y-929)) (eq? (car syntmp-x-928) (car syntmp-y-929)) (syntmp-same-marks?-125 (cdr syntmp-x-928) (cdr syntmp-y-929)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-930 syntmp-m2-931) (syntmp-smart-append-122 syntmp-m1-930 syntmp-m2-931))) (syntmp-join-wraps-123 (lambda (syntmp-w1-932 syntmp-w2-933) (let ((syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w1-932)) (syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w1-932))) (if (null? syntmp-m1-934) (if (null? syntmp-s1-935) syntmp-w2-933 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-933) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w2-933)) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-936 syntmp-m2-937) (if (null? syntmp-m2-937) syntmp-m1-936 (append syntmp-m1-936 syntmp-m2-937)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-938 syntmp-labels-939 syntmp-w-940) (if (null? syntmp-ids-938) syntmp-w-940 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-940) (cons (let ((syntmp-labelvec-941 (list->vector syntmp-labels-939))) (let ((syntmp-n-942 (vector-length syntmp-labelvec-941))) (let ((syntmp-symnamevec-943 (make-vector syntmp-n-942)) (syntmp-marksvec-944 (make-vector syntmp-n-942))) (begin (let syntmp-f-945 ((syntmp-ids-946 syntmp-ids-938) (syntmp-i-947 0)) (if (not (null? syntmp-ids-946)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-946) syntmp-w-940)) (lambda (syntmp-symname-948 syntmp-marks-949) (begin (vector-set! syntmp-symnamevec-943 syntmp-i-947 syntmp-symname-948) (vector-set! syntmp-marksvec-944 syntmp-i-947 syntmp-marks-949) (syntmp-f-945 (cdr syntmp-ids-946) (syntmp-fx+-72 syntmp-i-947 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-943 syntmp-marksvec-944 syntmp-labelvec-941))))) (syntmp-wrap-subst-108 syntmp-w-940)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-950 syntmp-id-951 syntmp-label-952) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-950 (cons (let ((syntmp-e-953 (syntmp-syntax-object-expression-89 syntmp-id-951))) (if (annotation? syntmp-e-953) (annotation-expression syntmp-e-953) syntmp-e-953)) (syntmp-ribcage-symnames-113 syntmp-ribcage-950))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-950 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-951)) (syntmp-ribcage-marks-114 syntmp-ribcage-950))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-950 (cons syntmp-label-952 (syntmp-ribcage-labels-115 syntmp-ribcage-950)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-954) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-954)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-954))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 3 syntmp-update-956))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 2 syntmp-update-958))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-959 syntmp-update-960) (vector-set! syntmp-x-959 1 syntmp-update-960))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-962) (vector-ref syntmp-x-962 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-963) (vector-ref syntmp-x-963 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-964) (and (vector? syntmp-x-964) (= (vector-length syntmp-x-964) 4) (eq? (vector-ref syntmp-x-964 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967) (vector (quote ribcage) syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967))) (syntmp-gen-labels-110 (lambda (syntmp-ls-968) (if (null? syntmp-ls-968) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-968)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-969 syntmp-w-970) (if (syntmp-syntax-object?-88 syntmp-x-969) (values (let ((syntmp-e-971 (syntmp-syntax-object-expression-89 syntmp-x-969))) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-970) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-969)))) (values (let ((syntmp-e-972 syntmp-x-969)) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)) (syntmp-wrap-marks-107 syntmp-w-970))))) (syntmp-id?-104 (lambda (syntmp-x-973) (cond ((symbol? syntmp-x-973) #t) ((syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))) ((annotation? syntmp-x-973) (symbol? (annotation-expression syntmp-x-973))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-975) (and (syntmp-syntax-object?-88 syntmp-x-975) (symbol? (let ((syntmp-e-976 (syntmp-syntax-object-expression-89 syntmp-x-975))) (if (annotation? syntmp-e-976) (annotation-expression syntmp-e-976) syntmp-e-976)))))) (syntmp-global-extend-102 (lambda (syntmp-type-977 syntmp-sym-978 syntmp-val-979) (syntmp-put-global-definition-hook-79 syntmp-sym-978 (cons syntmp-type-977 syntmp-val-979)))) (syntmp-lookup-101 (lambda (syntmp-x-980 syntmp-r-981) (cond ((assq syntmp-x-980 syntmp-r-981) => cdr) ((symbol? syntmp-x-980) (or (syntmp-get-global-definition-hook-80 syntmp-x-980) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-982) (if (null? syntmp-r-982) (quote ()) (let ((syntmp-a-983 (car syntmp-r-982))) (if (eq? (cadr syntmp-a-983) (quote macro)) (cons syntmp-a-983 (syntmp-macros-only-env-100 (cdr syntmp-r-982))) (syntmp-macros-only-env-100 (cdr syntmp-r-982))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-984 syntmp-vars-985 syntmp-r-986) (if (null? syntmp-labels-984) syntmp-r-986 (syntmp-extend-var-env-99 (cdr syntmp-labels-984) (cdr syntmp-vars-985) (cons (cons (car syntmp-labels-984) (cons (quote lexical) (car syntmp-vars-985))) syntmp-r-986))))) (syntmp-extend-env-98 (lambda (syntmp-labels-987 syntmp-bindings-988 syntmp-r-989) (if (null? syntmp-labels-987) syntmp-r-989 (syntmp-extend-env-98 (cdr syntmp-labels-987) (cdr syntmp-bindings-988) (cons (cons (car syntmp-labels-987) (car syntmp-bindings-988)) syntmp-r-989))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-990) (cond ((annotation? syntmp-x-990) (annotation-source syntmp-x-990)) ((syntmp-syntax-object?-88 syntmp-x-990) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-990))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-991 syntmp-y-992) (vector-set! syntmp-x-991 3 syntmp-y-992))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-993 syntmp-y-994) (vector-set! syntmp-x-993 2 syntmp-y-994))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-995 syntmp-y-996) (vector-set! syntmp-x-995 1 syntmp-y-996))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-997) (vector-ref syntmp-x-997 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-998) (vector-ref syntmp-x-998 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-999) (vector-ref syntmp-x-999 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1000) (and (vector? syntmp-x-1000) (> (vector-length syntmp-x-1000) 0) (eq? (vector-ref syntmp-x-1000 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-exp-1003 syntmp-wrap-1002 . syntmp-mod-1001) (vector (quote syntax-object) syntmp-exp-1003 syntmp-wrap-1002 (if (null? syntmp-mod-1001) #f (car syntmp-mod-1001))))) (syntmp-build-letrec-86 (lambda (syntmp-src-1004 syntmp-vars-1005 syntmp-val-exps-1006 syntmp-body-exp-1007) (if (null? syntmp-vars-1005) (syntmp-build-annotated-81 syntmp-src-1004 syntmp-body-exp-1007) (syntmp-build-annotated-81 syntmp-src-1004 (list (quote letrec) (map list syntmp-vars-1005 syntmp-val-exps-1006) syntmp-body-exp-1007))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1008 syntmp-vars-1009 syntmp-val-exps-1010 syntmp-body-exp-1011) (if (null? syntmp-vars-1009) (syntmp-build-annotated-81 syntmp-src-1008 syntmp-body-exp-1011) (syntmp-build-annotated-81 syntmp-src-1008 (list (quote let) (car syntmp-vars-1009) (map list (cdr syntmp-vars-1009) syntmp-val-exps-1010) syntmp-body-exp-1011))))) (syntmp-build-let-84 (lambda (syntmp-src-1012 syntmp-vars-1013 syntmp-val-exps-1014 syntmp-body-exp-1015) (if (null? syntmp-vars-1013) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-body-exp-1015) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote let) (map list syntmp-vars-1013 syntmp-val-exps-1014) syntmp-body-exp-1015))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1016 syntmp-exps-1017) (if (null? (cdr syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (car syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (cons (quote begin) syntmp-exps-1017))))) (syntmp-build-data-82 (lambda (syntmp-src-1018 syntmp-exp-1019) (if (and (self-evaluating? syntmp-exp-1019) (not (vector? syntmp-exp-1019))) (syntmp-build-annotated-81 syntmp-src-1018 syntmp-exp-1019) (syntmp-build-annotated-81 syntmp-src-1018 (list (quote quote) syntmp-exp-1019))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1020 syntmp-exp-1021) (if (and syntmp-src-1020 (not (annotation? syntmp-exp-1021))) (make-annotation syntmp-exp-1021 syntmp-src-1020 #t) syntmp-exp-1021))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1022) (getprop syntmp-symbol-1022 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1023 syntmp-binding-1024) (putprop syntmp-symbol-1023 (quote *sc-expander*) syntmp-binding-1024))) (syntmp-error-hook-78 (lambda (syntmp-who-1025 syntmp-why-1026 syntmp-what-1027) (error syntmp-who-1025 "~a ~s" syntmp-why-1026 syntmp-what-1027))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1028) (eval (list syntmp-noexpand-71 syntmp-x-1028) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1029) (eval (list syntmp-noexpand-71 syntmp-x-1029) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1030 syntmp-r-1031 syntmp-w-1032 syntmp-s-1033) ((lambda (syntmp-tmp-1034) ((lambda (syntmp-tmp-1035) (if (if syntmp-tmp-1035 (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (syntmp-valid-bound-ids?-129 syntmp-var-1037)) syntmp-tmp-1035) #f) (apply (lambda (syntmp-_-1042 syntmp-var-1043 syntmp-val-1044 syntmp-e1-1045 syntmp-e2-1046) (let ((syntmp-names-1047 (map (lambda (syntmp-x-1048) (syntmp-id-var-name-126 syntmp-x-1048 syntmp-w-1032)) syntmp-var-1043))) (begin (for-each (lambda (syntmp-id-1050 syntmp-n-1051) (let ((syntmp-t-1052 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1051 syntmp-r-1031)))) (if (memv syntmp-t-1052 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1050 syntmp-w-1032 syntmp-s-1033) "identifier out of context")))) syntmp-var-1043 syntmp-names-1047) (syntmp-chi-body-144 (cons syntmp-e1-1045 syntmp-e2-1046) (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033) (syntmp-extend-env-98 syntmp-names-1047 (let ((syntmp-trans-r-1055 (syntmp-macros-only-env-100 syntmp-r-1031))) (map (lambda (syntmp-x-1056) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1056 syntmp-trans-r-1055 syntmp-w-1032)))) syntmp-val-1044)) syntmp-r-1031) syntmp-w-1032)))) syntmp-tmp-1035) ((lambda (syntmp-_-1058) (syntax-error (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033))) syntmp-tmp-1034))) (syntax-dispatch syntmp-tmp-1034 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1030))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1059 syntmp-r-1060 syntmp-w-1061 syntmp-s-1062) ((lambda (syntmp-tmp-1063) ((lambda (syntmp-tmp-1064) (if syntmp-tmp-1064 (apply (lambda (syntmp-_-1065 syntmp-e-1066) (syntmp-build-data-82 syntmp-s-1062 (syntmp-strip-151 syntmp-e-1066 syntmp-w-1061))) syntmp-tmp-1064) ((lambda (syntmp-_-1067) (syntax-error (syntmp-source-wrap-133 syntmp-e-1059 syntmp-w-1061 syntmp-s-1062))) syntmp-tmp-1063))) (syntax-dispatch syntmp-tmp-1063 (quote (any any))))) syntmp-e-1059))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1075 (lambda (syntmp-x-1076) (let ((syntmp-t-1077 (car syntmp-x-1076))) (if (memv syntmp-t-1077 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1076) (syntmp-regen-1075 (caddr syntmp-x-1076)))) (if (memv syntmp-t-1077 (quote (map))) (let ((syntmp-ls-1078 (map syntmp-regen-1075 (cdr syntmp-x-1076)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1078) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1078))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1076)) (map syntmp-regen-1075 (cdr syntmp-x-1076)))))))))))) (syntmp-gen-vector-1074 (lambda (syntmp-x-1079) (cond ((eq? (car syntmp-x-1079) (quote list)) (cons (quote vector) (cdr syntmp-x-1079))) ((eq? (car syntmp-x-1079) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1079)))) (else (list (quote list->vector) syntmp-x-1079))))) (syntmp-gen-append-1073 (lambda (syntmp-x-1080 syntmp-y-1081) (if (equal? syntmp-y-1081 (quote (quote ()))) syntmp-x-1080 (list (quote append) syntmp-x-1080 syntmp-y-1081)))) (syntmp-gen-cons-1072 (lambda (syntmp-x-1082 syntmp-y-1083) (let ((syntmp-t-1084 (car syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (quote))) (if (eq? (car syntmp-x-1082) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1082) (cadr syntmp-y-1083))) (if (eq? (cadr syntmp-y-1083) (quote ())) (list (quote list) syntmp-x-1082) (list (quote cons) syntmp-x-1082 syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (list))) (cons (quote list) (cons syntmp-x-1082 (cdr syntmp-y-1083))) (list (quote cons) syntmp-x-1082 syntmp-y-1083)))))) (syntmp-gen-map-1071 (lambda (syntmp-e-1085 syntmp-map-env-1086) (let ((syntmp-formals-1087 (map cdr syntmp-map-env-1086)) (syntmp-actuals-1088 (map (lambda (syntmp-x-1089) (list (quote ref) (car syntmp-x-1089))) syntmp-map-env-1086))) (cond ((eq? (car syntmp-e-1085) (quote ref)) (car syntmp-actuals-1088)) ((andmap (lambda (syntmp-x-1090) (and (eq? (car syntmp-x-1090) (quote ref)) (memq (cadr syntmp-x-1090) syntmp-formals-1087))) (cdr syntmp-e-1085)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1085)) (map (let ((syntmp-r-1091 (map cons syntmp-formals-1087 syntmp-actuals-1088))) (lambda (syntmp-x-1092) (cdr (assq (cadr syntmp-x-1092) syntmp-r-1091)))) (cdr syntmp-e-1085))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1087 syntmp-e-1085) syntmp-actuals-1088))))))) (syntmp-gen-mappend-1070 (lambda (syntmp-e-1093 syntmp-map-env-1094) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1071 syntmp-e-1093 syntmp-map-env-1094)))) (syntmp-gen-ref-1069 (lambda (syntmp-src-1095 syntmp-var-1096 syntmp-level-1097 syntmp-maps-1098) (if (syntmp-fx=-74 syntmp-level-1097 0) (values syntmp-var-1096 syntmp-maps-1098) (if (null? syntmp-maps-1098) (syntax-error syntmp-src-1095 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1069 syntmp-src-1095 syntmp-var-1096 (syntmp-fx--73 syntmp-level-1097 1) (cdr syntmp-maps-1098))) (lambda (syntmp-outer-var-1099 syntmp-outer-maps-1100) (let ((syntmp-b-1101 (assq syntmp-outer-var-1099 (car syntmp-maps-1098)))) (if syntmp-b-1101 (values (cdr syntmp-b-1101) syntmp-maps-1098) (let ((syntmp-inner-var-1102 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1102 (cons (cons (cons syntmp-outer-var-1099 syntmp-inner-var-1102) (car syntmp-maps-1098)) syntmp-outer-maps-1100))))))))))) (syntmp-gen-syntax-1068 (lambda (syntmp-src-1103 syntmp-e-1104 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107) (if (syntmp-id?-104 syntmp-e-1104) (let ((syntmp-label-1108 (syntmp-id-var-name-126 syntmp-e-1104 (quote (()))))) (let ((syntmp-b-1109 (syntmp-lookup-101 syntmp-label-1108 syntmp-r-1105))) (if (eq? (syntmp-binding-type-96 syntmp-b-1109) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1110 (syntmp-binding-value-97 syntmp-b-1109))) (syntmp-gen-ref-1069 syntmp-src-1103 (car syntmp-var.lev-1110) (cdr syntmp-var.lev-1110) syntmp-maps-1106))) (lambda (syntmp-var-1111 syntmp-maps-1112) (values (list (quote ref) syntmp-var-1111) syntmp-maps-1112))) (if (syntmp-ellipsis?-1107 syntmp-e-1104) (syntax-error syntmp-src-1103 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106))))) ((lambda (syntmp-tmp-1113) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-dots-1115 syntmp-e-1116) (syntmp-ellipsis?-1107 syntmp-dots-1115)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-dots-1117 syntmp-e-1118) (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-e-1118 syntmp-r-1105 syntmp-maps-1106 (lambda (syntmp-x-1119) #f))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1120) (if (if syntmp-tmp-1120 (apply (lambda (syntmp-x-1121 syntmp-dots-1122 syntmp-y-1123) (syntmp-ellipsis?-1107 syntmp-dots-1122)) syntmp-tmp-1120) #f) (apply (lambda (syntmp-x-1124 syntmp-dots-1125 syntmp-y-1126) (let syntmp-f-1127 ((syntmp-y-1128 syntmp-y-1126) (syntmp-k-1129 (lambda (syntmp-maps-1130) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1124 syntmp-r-1105 (cons (quote ()) syntmp-maps-1130) syntmp-ellipsis?-1107)) (lambda (syntmp-x-1131 syntmp-maps-1132) (if (null? (car syntmp-maps-1132)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-map-1071 syntmp-x-1131 (car syntmp-maps-1132)) (cdr syntmp-maps-1132)))))))) ((lambda (syntmp-tmp-1133) ((lambda (syntmp-tmp-1134) (if (if syntmp-tmp-1134 (apply (lambda (syntmp-dots-1135 syntmp-y-1136) (syntmp-ellipsis?-1107 syntmp-dots-1135)) syntmp-tmp-1134) #f) (apply (lambda (syntmp-dots-1137 syntmp-y-1138) (syntmp-f-1127 syntmp-y-1138 (lambda (syntmp-maps-1139) (call-with-values (lambda () (syntmp-k-1129 (cons (quote ()) syntmp-maps-1139))) (lambda (syntmp-x-1140 syntmp-maps-1141) (if (null? (car syntmp-maps-1141)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1070 syntmp-x-1140 (car syntmp-maps-1141)) (cdr syntmp-maps-1141)))))))) syntmp-tmp-1134) ((lambda (syntmp-_-1142) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1128 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1143 syntmp-maps-1144) (call-with-values (lambda () (syntmp-k-1129 syntmp-maps-1144)) (lambda (syntmp-x-1145 syntmp-maps-1146) (values (syntmp-gen-append-1073 syntmp-x-1145 syntmp-y-1143) syntmp-maps-1146)))))) syntmp-tmp-1133))) (syntax-dispatch syntmp-tmp-1133 (quote (any . any))))) syntmp-y-1128))) syntmp-tmp-1120) ((lambda (syntmp-tmp-1147) (if syntmp-tmp-1147 (apply (lambda (syntmp-x-1148 syntmp-y-1149) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1148 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-x-1150 syntmp-maps-1151) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1149 syntmp-r-1105 syntmp-maps-1151 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1152 syntmp-maps-1153) (values (syntmp-gen-cons-1072 syntmp-x-1150 syntmp-y-1152) syntmp-maps-1153)))))) syntmp-tmp-1147) ((lambda (syntmp-tmp-1154) (if syntmp-tmp-1154 (apply (lambda (syntmp-e1-1155 syntmp-e2-1156) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 (cons syntmp-e1-1155 syntmp-e2-1156) syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-e-1158 syntmp-maps-1159) (values (syntmp-gen-vector-1074 syntmp-e-1158) syntmp-maps-1159)))) syntmp-tmp-1154) ((lambda (syntmp-_-1160) (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106)) syntmp-tmp-1113))) (syntax-dispatch syntmp-tmp-1113 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1113 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any))))) syntmp-e-1104))))) (lambda (syntmp-e-1161 syntmp-r-1162 syntmp-w-1163 syntmp-s-1164) (let ((syntmp-e-1165 (syntmp-source-wrap-133 syntmp-e-1161 syntmp-w-1163 syntmp-s-1164))) ((lambda (syntmp-tmp-1166) ((lambda (syntmp-tmp-1167) (if syntmp-tmp-1167 (apply (lambda (syntmp-_-1168 syntmp-x-1169) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-e-1165 syntmp-x-1169 syntmp-r-1162 (quote ()) syntmp-ellipsis?-149)) (lambda (syntmp-e-1170 syntmp-maps-1171) (syntmp-regen-1075 syntmp-e-1170)))) syntmp-tmp-1167) ((lambda (syntmp-_-1172) (syntax-error syntmp-e-1165)) syntmp-tmp-1166))) (syntax-dispatch syntmp-tmp-1166 (quote (any any))))) syntmp-e-1165))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1173 syntmp-r-1174 syntmp-w-1175 syntmp-s-1176) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if syntmp-tmp-1178 (apply (lambda (syntmp-_-1179 syntmp-c-1180) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1173 syntmp-w-1175 syntmp-s-1176) syntmp-c-1180 syntmp-r-1174 syntmp-w-1175 (lambda (syntmp-vars-1181 syntmp-body-1182) (syntmp-build-annotated-81 syntmp-s-1176 (list (quote lambda) syntmp-vars-1181 syntmp-body-1182))))) syntmp-tmp-1178) (syntax-error syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-e-1173))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1183 (lambda (syntmp-e-1184 syntmp-r-1185 syntmp-w-1186 syntmp-s-1187 syntmp-constructor-1188 syntmp-ids-1189 syntmp-vals-1190 syntmp-exps-1191) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1189)) (syntax-error syntmp-e-1184 "duplicate bound variable in") (let ((syntmp-labels-1192 (syntmp-gen-labels-110 syntmp-ids-1189)) (syntmp-new-vars-1193 (map syntmp-gen-var-152 syntmp-ids-1189))) (let ((syntmp-nw-1194 (syntmp-make-binding-wrap-121 syntmp-ids-1189 syntmp-labels-1192 syntmp-w-1186)) (syntmp-nr-1195 (syntmp-extend-var-env-99 syntmp-labels-1192 syntmp-new-vars-1193 syntmp-r-1185))) (syntmp-constructor-1188 syntmp-s-1187 syntmp-new-vars-1193 (map (lambda (syntmp-x-1196) (syntmp-chi-140 syntmp-x-1196 syntmp-r-1185 syntmp-w-1186)) syntmp-vals-1190) (syntmp-chi-body-144 syntmp-exps-1191 (syntmp-source-wrap-133 syntmp-e-1184 syntmp-nw-1194 syntmp-s-1187) syntmp-nr-1195 syntmp-nw-1194)))))))) (lambda (syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if syntmp-tmp-1202 (apply (lambda (syntmp-_-1203 syntmp-id-1204 syntmp-val-1205 syntmp-e1-1206 syntmp-e2-1207) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-let-84 syntmp-id-1204 syntmp-val-1205 (cons syntmp-e1-1206 syntmp-e2-1207))) syntmp-tmp-1202) ((lambda (syntmp-tmp-1211) (if (if syntmp-tmp-1211 (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-id?-104 syntmp-f-1213)) syntmp-tmp-1211) #f) (apply (lambda (syntmp-_-1218 syntmp-f-1219 syntmp-id-1220 syntmp-val-1221 syntmp-e1-1222 syntmp-e2-1223) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-named-let-85 (cons syntmp-f-1219 syntmp-id-1220) syntmp-val-1221 (cons syntmp-e1-1222 syntmp-e2-1223))) syntmp-tmp-1211) ((lambda (syntmp-_-1227) (syntax-error (syntmp-source-wrap-133 syntmp-e-1197 syntmp-w-1199 syntmp-s-1200))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1201 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1197)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1228 syntmp-r-1229 syntmp-w-1230 syntmp-s-1231) ((lambda (syntmp-tmp-1232) ((lambda (syntmp-tmp-1233) (if syntmp-tmp-1233 (apply (lambda (syntmp-_-1234 syntmp-id-1235 syntmp-val-1236 syntmp-e1-1237 syntmp-e2-1238) (let ((syntmp-ids-1239 syntmp-id-1235)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1239)) (syntax-error syntmp-e-1228 "duplicate bound variable in") (let ((syntmp-labels-1241 (syntmp-gen-labels-110 syntmp-ids-1239)) (syntmp-new-vars-1242 (map syntmp-gen-var-152 syntmp-ids-1239))) (let ((syntmp-w-1243 (syntmp-make-binding-wrap-121 syntmp-ids-1239 syntmp-labels-1241 syntmp-w-1230)) (syntmp-r-1244 (syntmp-extend-var-env-99 syntmp-labels-1241 syntmp-new-vars-1242 syntmp-r-1229))) (syntmp-build-letrec-86 syntmp-s-1231 syntmp-new-vars-1242 (map (lambda (syntmp-x-1245) (syntmp-chi-140 syntmp-x-1245 syntmp-r-1244 syntmp-w-1243)) syntmp-val-1236) (syntmp-chi-body-144 (cons syntmp-e1-1237 syntmp-e2-1238) (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1243 syntmp-s-1231) syntmp-r-1244 syntmp-w-1243))))))) syntmp-tmp-1233) ((lambda (syntmp-_-1248) (syntax-error (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1230 syntmp-s-1231))) syntmp-tmp-1232))) (syntax-dispatch syntmp-tmp-1232 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1228))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1249 syntmp-r-1250 syntmp-w-1251 syntmp-s-1252) ((lambda (syntmp-tmp-1253) ((lambda (syntmp-tmp-1254) (if (if syntmp-tmp-1254 (apply (lambda (syntmp-_-1255 syntmp-id-1256 syntmp-val-1257) (syntmp-id?-104 syntmp-id-1256)) syntmp-tmp-1254) #f) (apply (lambda (syntmp-_-1258 syntmp-id-1259 syntmp-val-1260) (let ((syntmp-val-1261 (syntmp-chi-140 syntmp-val-1260 syntmp-r-1250 syntmp-w-1251)) (syntmp-n-1262 (syntmp-id-var-name-126 syntmp-id-1259 syntmp-w-1251))) (let ((syntmp-b-1263 (syntmp-lookup-101 syntmp-n-1262 syntmp-r-1250))) (let ((syntmp-t-1264 (syntmp-binding-type-96 syntmp-b-1263))) (if (memv syntmp-t-1264 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1263) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (make-module-ref #f syntmp-n-1262 #f) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1259 syntmp-w-1251) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))))))))) syntmp-tmp-1254) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (apply (lambda (syntmp-_-1266 syntmp-getter-1267 syntmp-arg-1268 syntmp-val-1269) (syntmp-build-annotated-81 syntmp-s-1252 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1267) syntmp-r-1250 syntmp-w-1251) (map (lambda (syntmp-e-1270) (syntmp-chi-140 syntmp-e-1270 syntmp-r-1250 syntmp-w-1251)) (append syntmp-arg-1268 (list syntmp-val-1269)))))) syntmp-tmp-1265) ((lambda (syntmp-_-1272) (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))) syntmp-tmp-1253))) (syntax-dispatch syntmp-tmp-1253 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1253 (quote (any any any))))) syntmp-e-1249))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1276 (lambda (syntmp-x-1277 syntmp-keys-1278 syntmp-clauses-1279 syntmp-r-1280) (if (null? syntmp-clauses-1279) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1277)) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-exp-1284) (if (and (syntmp-id?-104 syntmp-pat-1283) (andmap (lambda (syntmp-x-1285) (not (syntmp-free-id=?-127 syntmp-pat-1283 syntmp-x-1285))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1278))) (let ((syntmp-labels-1286 (list (syntmp-gen-label-109))) (syntmp-var-1287 (syntmp-gen-var-152 syntmp-pat-1283))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1287) (syntmp-chi-140 syntmp-exp-1284 (syntmp-extend-env-98 syntmp-labels-1286 (list (cons (quote syntax) (cons syntmp-var-1287 0))) syntmp-r-1280) (syntmp-make-binding-wrap-121 (list syntmp-pat-1283) syntmp-labels-1286 (quote (())))))) syntmp-x-1277))) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1283 #t syntmp-exp-1284))) syntmp-tmp-1282) ((lambda (syntmp-tmp-1288) (if syntmp-tmp-1288 (apply (lambda (syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291)) syntmp-tmp-1288) ((lambda (syntmp-_-1292) (syntax-error (car syntmp-clauses-1279) "invalid syntax-case clause")) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1281 (quote (any any))))) (car syntmp-clauses-1279))))) (syntmp-gen-clause-1275 (lambda (syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296 syntmp-pat-1297 syntmp-fender-1298 syntmp-exp-1299) (call-with-values (lambda () (syntmp-convert-pattern-1273 syntmp-pat-1297 syntmp-keys-1294)) (lambda (syntmp-p-1300 syntmp-pvars-1301) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1301))) (syntax-error syntmp-pat-1297 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1302) (not (syntmp-ellipsis?-149 (car syntmp-x-1302)))) syntmp-pvars-1301)) (syntax-error syntmp-pat-1297 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1303 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1303) (let ((syntmp-y-1304 (syntmp-build-annotated-81 #f syntmp-y-1303))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda () syntmp-y-1304) syntmp-tmp-1306) ((lambda (syntmp-_-1307) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1304 (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-fender-1298 syntmp-y-1304 syntmp-r-1296) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote #(atom #t))))) syntmp-fender-1298) (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-exp-1299 syntmp-y-1304 syntmp-r-1296) (syntmp-gen-syntax-case-1276 syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296)))))) (if (eq? syntmp-p-1300 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1293)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1293 (syntmp-build-data-82 #f syntmp-p-1300))))))))))))) (syntmp-build-dispatch-call-1274 (lambda (syntmp-pvars-1308 syntmp-exp-1309 syntmp-y-1310 syntmp-r-1311) (let ((syntmp-ids-1312 (map car syntmp-pvars-1308)) (syntmp-levels-1313 (map cdr syntmp-pvars-1308))) (let ((syntmp-labels-1314 (syntmp-gen-labels-110 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-152 syntmp-ids-1312))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1315 (syntmp-chi-140 syntmp-exp-1309 (syntmp-extend-env-98 syntmp-labels-1314 (map (lambda (syntmp-var-1316 syntmp-level-1317) (cons (quote syntax) (cons syntmp-var-1316 syntmp-level-1317))) syntmp-new-vars-1315 (map cdr syntmp-pvars-1308)) syntmp-r-1311) (syntmp-make-binding-wrap-121 syntmp-ids-1312 syntmp-labels-1314 (quote (())))))) syntmp-y-1310)))))) (syntmp-convert-pattern-1273 (lambda (syntmp-pattern-1318 syntmp-keys-1319) (let syntmp-cvt-1320 ((syntmp-p-1321 syntmp-pattern-1318) (syntmp-n-1322 0) (syntmp-ids-1323 (quote ()))) (if (syntmp-id?-104 syntmp-p-1321) (if (syntmp-bound-id-member?-131 syntmp-p-1321 syntmp-keys-1319) (values (vector (quote free-id) syntmp-p-1321) syntmp-ids-1323) (values (quote any) (cons (cons syntmp-p-1321 syntmp-n-1322) syntmp-ids-1323))) ((lambda (syntmp-tmp-1324) ((lambda (syntmp-tmp-1325) (if (if syntmp-tmp-1325 (apply (lambda (syntmp-x-1326 syntmp-dots-1327) (syntmp-ellipsis?-149 syntmp-dots-1327)) syntmp-tmp-1325) #f) (apply (lambda (syntmp-x-1328 syntmp-dots-1329) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1328 (syntmp-fx+-72 syntmp-n-1322 1) syntmp-ids-1323)) (lambda (syntmp-p-1330 syntmp-ids-1331) (values (if (eq? syntmp-p-1330 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1330)) syntmp-ids-1331)))) syntmp-tmp-1325) ((lambda (syntmp-tmp-1332) (if syntmp-tmp-1332 (apply (lambda (syntmp-x-1333 syntmp-y-1334) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-y-1334 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-y-1335 syntmp-ids-1336) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1333 syntmp-n-1322 syntmp-ids-1336)) (lambda (syntmp-x-1337 syntmp-ids-1338) (values (cons syntmp-x-1337 syntmp-y-1335) syntmp-ids-1338)))))) syntmp-tmp-1332) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda () (values (quote ()) syntmp-ids-1323)) syntmp-tmp-1339) ((lambda (syntmp-tmp-1340) (if syntmp-tmp-1340 (apply (lambda (syntmp-x-1341) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1341 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-p-1343 syntmp-ids-1344) (values (vector (quote vector) syntmp-p-1343) syntmp-ids-1344)))) syntmp-tmp-1340) ((lambda (syntmp-x-1345) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1321 (quote (())))) syntmp-ids-1323)) syntmp-tmp-1324))) (syntax-dispatch syntmp-tmp-1324 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1324 (quote ()))))) (syntax-dispatch syntmp-tmp-1324 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1324 (quote (any any))))) syntmp-p-1321)))))) (lambda (syntmp-e-1346 syntmp-r-1347 syntmp-w-1348 syntmp-s-1349) (let ((syntmp-e-1350 (syntmp-source-wrap-133 syntmp-e-1346 syntmp-w-1348 syntmp-s-1349))) ((lambda (syntmp-tmp-1351) ((lambda (syntmp-tmp-1352) (if syntmp-tmp-1352 (apply (lambda (syntmp-_-1353 syntmp-val-1354 syntmp-key-1355 syntmp-m-1356) (if (andmap (lambda (syntmp-x-1357) (and (syntmp-id?-104 syntmp-x-1357) (not (syntmp-ellipsis?-149 syntmp-x-1357)))) syntmp-key-1355) (let ((syntmp-x-1359 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1349 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1359) (syntmp-gen-syntax-case-1276 (syntmp-build-annotated-81 #f syntmp-x-1359) syntmp-key-1355 syntmp-m-1356 syntmp-r-1347))) (syntmp-chi-140 syntmp-val-1354 syntmp-r-1347 (quote (())))))) (syntax-error syntmp-e-1350 "invalid literals list in"))) syntmp-tmp-1352) (syntax-error syntmp-tmp-1351))) (syntax-dispatch syntmp-tmp-1351 (quote (any any each-any . each-any))))) syntmp-e-1350))))) (set! sc-expand (let ((syntmp-m-1362 (quote e)) (syntmp-esew-1363 (quote (eval)))) (lambda (syntmp-x-1364) (if (and (pair? syntmp-x-1364) (equal? (car syntmp-x-1364) syntmp-noexpand-71)) (cadr syntmp-x-1364) (syntmp-chi-top-139 syntmp-x-1364 (quote ()) (quote ((top))) syntmp-m-1362 syntmp-esew-1363))))) (set! sc-expand3 (let ((syntmp-m-1365 (quote e)) (syntmp-esew-1366 (quote (eval)))) (lambda (syntmp-x-1368 . syntmp-rest-1367) (if (and (pair? syntmp-x-1368) (equal? (car syntmp-x-1368) syntmp-noexpand-71)) (cadr syntmp-x-1368) (syntmp-chi-top-139 syntmp-x-1368 (quote ()) (quote ((top))) (if (null? syntmp-rest-1367) syntmp-m-1365 (car syntmp-rest-1367)) (if (or (null? syntmp-rest-1367) (null? (cdr syntmp-rest-1367))) syntmp-esew-1366 (cadr syntmp-rest-1367))))))) (set! identifier? (lambda (syntmp-x-1369) (syntmp-nonsymbol-id?-103 syntmp-x-1369))) (set! datum->syntax-object (lambda (syntmp-id-1370 syntmp-datum-1371) (syntmp-make-syntax-object-87 syntmp-datum-1371 (syntmp-syntax-object-wrap-90 syntmp-id-1370)))) (set! syntax-object->datum (lambda (syntmp-x-1372) (syntmp-strip-151 syntmp-x-1372 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1373) (begin (let ((syntmp-x-1374 syntmp-ls-1373)) (if (not (list? syntmp-x-1374)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1374))) (map (lambda (syntmp-x-1375) (syntmp-wrap-132 (gensym) (quote ((top))))) syntmp-ls-1373)))) (set! free-identifier=? (lambda (syntmp-x-1376 syntmp-y-1377) (begin (let ((syntmp-x-1378 syntmp-x-1376)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1378)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1378))) (let ((syntmp-x-1379 syntmp-y-1377)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1379)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1379))) (syntmp-free-id=?-127 syntmp-x-1376 syntmp-y-1377)))) (set! bound-identifier=? (lambda (syntmp-x-1380 syntmp-y-1381) (begin (let ((syntmp-x-1382 syntmp-x-1380)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1382)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1382))) (let ((syntmp-x-1383 syntmp-y-1381)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1383)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1383))) (syntmp-bound-id=?-128 syntmp-x-1380 syntmp-y-1381)))) (set! syntax-error (lambda (syntmp-object-1385 . syntmp-messages-1384) (begin (for-each (lambda (syntmp-x-1386) (let ((syntmp-x-1387 syntmp-x-1386)) (if (not (string? syntmp-x-1387)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1387)))) syntmp-messages-1384) (let ((syntmp-message-1388 (if (null? syntmp-messages-1384) "invalid syntax" (apply string-append syntmp-messages-1384)))) (syntmp-error-hook-78 #f syntmp-message-1388 (syntmp-strip-151 syntmp-object-1385 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1389 syntmp-v-1390) (begin (let ((syntmp-x-1391 syntmp-sym-1389)) (if (not (symbol? syntmp-x-1391)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1391))) (let ((syntmp-x-1392 syntmp-v-1390)) (if (not (procedure? syntmp-x-1392)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1392))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1389 syntmp-v-1390)))) (letrec ((syntmp-match-1397 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((not syntmp-r-1401) #f) ((eq? syntmp-p-1399 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1398 syntmp-w-1400) syntmp-r-1401)) ((syntmp-syntax-object?-88 syntmp-e-1398) (syntmp-match*-1396 (let ((syntmp-e-1402 (syntmp-syntax-object-expression-89 syntmp-e-1398))) (if (annotation? syntmp-e-1402) (annotation-expression syntmp-e-1402) syntmp-e-1402)) syntmp-p-1399 (syntmp-join-wraps-123 syntmp-w-1400 (syntmp-syntax-object-wrap-90 syntmp-e-1398)) syntmp-r-1401)) (else (syntmp-match*-1396 (let ((syntmp-e-1403 syntmp-e-1398)) (if (annotation? syntmp-e-1403) (annotation-expression syntmp-e-1403) syntmp-e-1403)) syntmp-p-1399 syntmp-w-1400 syntmp-r-1401))))) (syntmp-match*-1396 (lambda (syntmp-e-1404 syntmp-p-1405 syntmp-w-1406 syntmp-r-1407) (cond ((null? syntmp-p-1405) (and (null? syntmp-e-1404) syntmp-r-1407)) ((pair? syntmp-p-1405) (and (pair? syntmp-e-1404) (syntmp-match-1397 (car syntmp-e-1404) (car syntmp-p-1405) syntmp-w-1406 (syntmp-match-1397 (cdr syntmp-e-1404) (cdr syntmp-p-1405) syntmp-w-1406 syntmp-r-1407)))) ((eq? syntmp-p-1405 (quote each-any)) (let ((syntmp-l-1408 (syntmp-match-each-any-1394 syntmp-e-1404 syntmp-w-1406))) (and syntmp-l-1408 (cons syntmp-l-1408 syntmp-r-1407)))) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1405 0))) (if (memv syntmp-t-1409 (quote (each))) (if (null? syntmp-e-1404) (syntmp-match-empty-1395 (vector-ref syntmp-p-1405 1) syntmp-r-1407) (let ((syntmp-l-1410 (syntmp-match-each-1393 syntmp-e-1404 (vector-ref syntmp-p-1405 1) syntmp-w-1406))) (and syntmp-l-1410 (let syntmp-collect-1411 ((syntmp-l-1412 syntmp-l-1410)) (if (null? (car syntmp-l-1412)) syntmp-r-1407 (cons (map car syntmp-l-1412) (syntmp-collect-1411 (map cdr syntmp-l-1412)))))))) (if (memv syntmp-t-1409 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1404) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1404 syntmp-w-1406) (vector-ref syntmp-p-1405 1)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (atom))) (and (equal? (vector-ref syntmp-p-1405 1) (syntmp-strip-151 syntmp-e-1404 syntmp-w-1406)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (vector))) (and (vector? syntmp-e-1404) (syntmp-match-1397 (vector->list syntmp-e-1404) (vector-ref syntmp-p-1405 1) syntmp-w-1406 syntmp-r-1407))))))))))) (syntmp-match-empty-1395 (lambda (syntmp-p-1413 syntmp-r-1414) (cond ((null? syntmp-p-1413) syntmp-r-1414) ((eq? syntmp-p-1413 (quote any)) (cons (quote ()) syntmp-r-1414)) ((pair? syntmp-p-1413) (syntmp-match-empty-1395 (car syntmp-p-1413) (syntmp-match-empty-1395 (cdr syntmp-p-1413) syntmp-r-1414))) ((eq? syntmp-p-1413 (quote each-any)) (cons (quote ()) syntmp-r-1414)) (else (let ((syntmp-t-1415 (vector-ref syntmp-p-1413 0))) (if (memv syntmp-t-1415 (quote (each))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414) (if (memv syntmp-t-1415 (quote (free-id atom))) syntmp-r-1414 (if (memv syntmp-t-1415 (quote (vector))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414))))))))) (syntmp-match-each-any-1394 (lambda (syntmp-e-1416 syntmp-w-1417) (cond ((annotation? syntmp-e-1416) (syntmp-match-each-any-1394 (annotation-expression syntmp-e-1416) syntmp-w-1417)) ((pair? syntmp-e-1416) (let ((syntmp-l-1418 (syntmp-match-each-any-1394 (cdr syntmp-e-1416) syntmp-w-1417))) (and syntmp-l-1418 (cons (syntmp-wrap-132 (car syntmp-e-1416) syntmp-w-1417) syntmp-l-1418)))) ((null? syntmp-e-1416) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1416) (syntmp-match-each-any-1394 (syntmp-syntax-object-expression-89 syntmp-e-1416) (syntmp-join-wraps-123 syntmp-w-1417 (syntmp-syntax-object-wrap-90 syntmp-e-1416)))) (else #f)))) (syntmp-match-each-1393 (lambda (syntmp-e-1419 syntmp-p-1420 syntmp-w-1421) (cond ((annotation? syntmp-e-1419) (syntmp-match-each-1393 (annotation-expression syntmp-e-1419) syntmp-p-1420 syntmp-w-1421)) ((pair? syntmp-e-1419) (let ((syntmp-first-1422 (syntmp-match-1397 (car syntmp-e-1419) syntmp-p-1420 syntmp-w-1421 (quote ())))) (and syntmp-first-1422 (let ((syntmp-rest-1423 (syntmp-match-each-1393 (cdr syntmp-e-1419) syntmp-p-1420 syntmp-w-1421))) (and syntmp-rest-1423 (cons syntmp-first-1422 syntmp-rest-1423)))))) ((null? syntmp-e-1419) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1419) (syntmp-match-each-1393 (syntmp-syntax-object-expression-89 syntmp-e-1419) syntmp-p-1420 (syntmp-join-wraps-123 syntmp-w-1421 (syntmp-syntax-object-wrap-90 syntmp-e-1419)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1424 syntmp-p-1425) (cond ((eq? syntmp-p-1425 (quote any)) (list syntmp-e-1424)) ((syntmp-syntax-object?-88 syntmp-e-1424) (syntmp-match*-1396 (let ((syntmp-e-1426 (syntmp-syntax-object-expression-89 syntmp-e-1424))) (if (annotation? syntmp-e-1426) (annotation-expression syntmp-e-1426) syntmp-e-1426)) syntmp-p-1425 (syntmp-syntax-object-wrap-90 syntmp-e-1424) (quote ()))) (else (syntmp-match*-1396 (let ((syntmp-e-1427 syntmp-e-1424)) (if (annotation? syntmp-e-1427) (annotation-expression syntmp-e-1427) syntmp-e-1427)) syntmp-p-1425 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-140))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1428) ((lambda (syntmp-tmp-1429) ((lambda (syntmp-tmp-1430) (if syntmp-tmp-1430 (apply (lambda (syntmp-_-1431 syntmp-e1-1432 syntmp-e2-1433) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1432 syntmp-e2-1433))) syntmp-tmp-1430) ((lambda (syntmp-tmp-1435) (if syntmp-tmp-1435 (apply (lambda (syntmp-_-1436 syntmp-out-1437 syntmp-in-1438 syntmp-e1-1439 syntmp-e2-1440) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1438 (quote ()) (list syntmp-out-1437 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1439 syntmp-e2-1440))))) syntmp-tmp-1435) ((lambda (syntmp-tmp-1442) (if syntmp-tmp-1442 (apply (lambda (syntmp-_-1443 syntmp-out-1444 syntmp-in-1445 syntmp-e1-1446 syntmp-e2-1447) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1445) (quote ()) (list syntmp-out-1444 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1446 syntmp-e2-1447))))) syntmp-tmp-1442) (syntax-error syntmp-tmp-1429))) (syntax-dispatch syntmp-tmp-1429 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any () any . each-any))))) syntmp-x-1428))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1469) ((lambda (syntmp-tmp-1470) ((lambda (syntmp-tmp-1471) (if syntmp-tmp-1471 (apply (lambda (syntmp-_-1472 syntmp-k-1473 syntmp-keyword-1474 syntmp-pattern-1475 syntmp-template-1476) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1473 (map (lambda (syntmp-tmp-1479 syntmp-tmp-1478) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1478) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1479))) syntmp-template-1476 syntmp-pattern-1475)))))) syntmp-tmp-1471) (syntax-error syntmp-tmp-1470))) (syntax-dispatch syntmp-tmp-1470 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1469))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1490) ((lambda (syntmp-tmp-1491) ((lambda (syntmp-tmp-1492) (if (if syntmp-tmp-1492 (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (andmap identifier? syntmp-x-1494)) syntmp-tmp-1492) #f) (apply (lambda (syntmp-let*-1499 syntmp-x-1500 syntmp-v-1501 syntmp-e1-1502 syntmp-e2-1503) (let syntmp-f-1504 ((syntmp-bindings-1505 (map list syntmp-x-1500 syntmp-v-1501))) (if (null? syntmp-bindings-1505) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1502 syntmp-e2-1503))) ((lambda (syntmp-tmp-1509) ((lambda (syntmp-tmp-1510) (if syntmp-tmp-1510 (apply (lambda (syntmp-body-1511 syntmp-binding-1512) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1512) syntmp-body-1511)) syntmp-tmp-1510) (syntax-error syntmp-tmp-1509))) (syntax-dispatch syntmp-tmp-1509 (quote (any any))))) (list (syntmp-f-1504 (cdr syntmp-bindings-1505)) (car syntmp-bindings-1505)))))) syntmp-tmp-1492) (syntax-error syntmp-tmp-1491))) (syntax-dispatch syntmp-tmp-1491 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1490))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1532) ((lambda (syntmp-tmp-1533) ((lambda (syntmp-tmp-1534) (if syntmp-tmp-1534 (apply (lambda (syntmp-_-1535 syntmp-var-1536 syntmp-init-1537 syntmp-step-1538 syntmp-e0-1539 syntmp-e1-1540 syntmp-c-1541) ((lambda (syntmp-tmp-1542) ((lambda (syntmp-tmp-1543) (if syntmp-tmp-1543 (apply (lambda (syntmp-step-1544) ((lambda (syntmp-tmp-1545) ((lambda (syntmp-tmp-1546) (if syntmp-tmp-1546 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1539) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1544))))))) syntmp-tmp-1546) ((lambda (syntmp-tmp-1551) (if syntmp-tmp-1551 (apply (lambda (syntmp-e1-1552 syntmp-e2-1553) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1539 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1552 syntmp-e2-1553)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1544))))))) syntmp-tmp-1551) (syntax-error syntmp-tmp-1545))) (syntax-dispatch syntmp-tmp-1545 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1545 (quote ())))) syntmp-e1-1540)) syntmp-tmp-1543) (syntax-error syntmp-tmp-1542))) (syntax-dispatch syntmp-tmp-1542 (quote each-any)))) (map (lambda (syntmp-v-1560 syntmp-s-1561) ((lambda (syntmp-tmp-1562) ((lambda (syntmp-tmp-1563) (if syntmp-tmp-1563 (apply (lambda () syntmp-v-1560) syntmp-tmp-1563) ((lambda (syntmp-tmp-1564) (if syntmp-tmp-1564 (apply (lambda (syntmp-e-1565) syntmp-e-1565) syntmp-tmp-1564) ((lambda (syntmp-_-1566) (syntax-error syntmp-orig-x-1532)) syntmp-tmp-1562))) (syntax-dispatch syntmp-tmp-1562 (quote (any)))))) (syntax-dispatch syntmp-tmp-1562 (quote ())))) syntmp-s-1561)) syntmp-var-1536 syntmp-step-1538))) syntmp-tmp-1534) (syntax-error syntmp-tmp-1533))) (syntax-dispatch syntmp-tmp-1533 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1532))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1594 (lambda (syntmp-x-1598 syntmp-y-1599) ((lambda (syntmp-tmp-1600) ((lambda (syntmp-tmp-1601) (if syntmp-tmp-1601 (apply (lambda (syntmp-x-1602 syntmp-y-1603) ((lambda (syntmp-tmp-1604) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-dy-1606) ((lambda (syntmp-tmp-1607) ((lambda (syntmp-tmp-1608) (if syntmp-tmp-1608 (apply (lambda (syntmp-dx-1609) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1609 syntmp-dy-1606))) syntmp-tmp-1608) ((lambda (syntmp-_-1610) (if (null? syntmp-dy-1606) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1602) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1602 syntmp-y-1603))) syntmp-tmp-1607))) (syntax-dispatch syntmp-tmp-1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1602)) syntmp-tmp-1605) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-stuff-1612) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1602 syntmp-stuff-1612))) syntmp-tmp-1611) ((lambda (syntmp-else-1613) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1602 syntmp-y-1603)) syntmp-tmp-1604))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1603)) syntmp-tmp-1601) (syntax-error syntmp-tmp-1600))) (syntax-dispatch syntmp-tmp-1600 (quote (any any))))) (list syntmp-x-1598 syntmp-y-1599)))) (syntmp-quasiappend-1595 (lambda (syntmp-x-1614 syntmp-y-1615) ((lambda (syntmp-tmp-1616) ((lambda (syntmp-tmp-1617) (if syntmp-tmp-1617 (apply (lambda (syntmp-x-1618 syntmp-y-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda () syntmp-x-1618) syntmp-tmp-1621) ((lambda (syntmp-_-1622) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1618 syntmp-y-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1619)) syntmp-tmp-1617) (syntax-error syntmp-tmp-1616))) (syntax-dispatch syntmp-tmp-1616 (quote (any any))))) (list syntmp-x-1614 syntmp-y-1615)))) (syntmp-quasivector-1596 (lambda (syntmp-x-1623) ((lambda (syntmp-tmp-1624) ((lambda (syntmp-x-1625) ((lambda (syntmp-tmp-1626) ((lambda (syntmp-tmp-1627) (if syntmp-tmp-1627 (apply (lambda (syntmp-x-1628) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1628))) syntmp-tmp-1627) ((lambda (syntmp-tmp-1630) (if syntmp-tmp-1630 (apply (lambda (syntmp-x-1631) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1631)) syntmp-tmp-1630) ((lambda (syntmp-_-1633) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1625)) syntmp-tmp-1626))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1625)) syntmp-tmp-1624)) syntmp-x-1623))) (syntmp-quasi-1597 (lambda (syntmp-p-1634 syntmp-lev-1635) ((lambda (syntmp-tmp-1636) ((lambda (syntmp-tmp-1637) (if syntmp-tmp-1637 (apply (lambda (syntmp-p-1638) (if (= syntmp-lev-1635 0) syntmp-p-1638 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1597 (list syntmp-p-1638) (- syntmp-lev-1635 1))))) syntmp-tmp-1637) ((lambda (syntmp-tmp-1639) (if syntmp-tmp-1639 (apply (lambda (syntmp-p-1640 syntmp-q-1641) (if (= syntmp-lev-1635 0) (syntmp-quasiappend-1595 syntmp-p-1640 (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)) (syntmp-quasicons-1594 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1597 (list syntmp-p-1640) (- syntmp-lev-1635 1))) (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)))) syntmp-tmp-1639) ((lambda (syntmp-tmp-1642) (if syntmp-tmp-1642 (apply (lambda (syntmp-p-1643) (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1597 (list syntmp-p-1643) (+ syntmp-lev-1635 1)))) syntmp-tmp-1642) ((lambda (syntmp-tmp-1644) (if syntmp-tmp-1644 (apply (lambda (syntmp-p-1645 syntmp-q-1646) (syntmp-quasicons-1594 (syntmp-quasi-1597 syntmp-p-1645 syntmp-lev-1635) (syntmp-quasi-1597 syntmp-q-1646 syntmp-lev-1635))) syntmp-tmp-1644) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-x-1648) (syntmp-quasivector-1596 (syntmp-quasi-1597 syntmp-x-1648 syntmp-lev-1635))) syntmp-tmp-1647) ((lambda (syntmp-p-1650) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1650)) syntmp-tmp-1636))) (syntax-dispatch syntmp-tmp-1636 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1636 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1634)))) (lambda (syntmp-x-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda (syntmp-_-1654 syntmp-e-1655) (syntmp-quasi-1597 syntmp-e-1655 0)) syntmp-tmp-1653) (syntax-error syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any any))))) syntmp-x-1651)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1715) (letrec ((syntmp-read-file-1716 (lambda (syntmp-fn-1717 syntmp-k-1718) (let ((syntmp-p-1719 (open-input-file syntmp-fn-1717))) (let syntmp-f-1720 ((syntmp-x-1721 (read syntmp-p-1719))) (if (eof-object? syntmp-x-1721) (begin (close-input-port syntmp-p-1719) (quote ())) (cons (datum->syntax-object syntmp-k-1718 syntmp-x-1721) (syntmp-f-1720 (read syntmp-p-1719))))))))) ((lambda (syntmp-tmp-1722) ((lambda (syntmp-tmp-1723) (if syntmp-tmp-1723 (apply (lambda (syntmp-k-1724 syntmp-filename-1725) (let ((syntmp-fn-1726 (syntax-object->datum syntmp-filename-1725))) ((lambda (syntmp-tmp-1727) ((lambda (syntmp-tmp-1728) (if syntmp-tmp-1728 (apply (lambda (syntmp-exp-1729) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1729)) syntmp-tmp-1728) (syntax-error syntmp-tmp-1727))) (syntax-dispatch syntmp-tmp-1727 (quote each-any)))) (syntmp-read-file-1716 syntmp-fn-1726 syntmp-k-1724)))) syntmp-tmp-1723) (syntax-error syntmp-tmp-1722))) (syntax-dispatch syntmp-tmp-1722 (quote (any any))))) syntmp-x-1715)))) +(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-538) (let syntmp-lvl-539 ((syntmp-vars-540 syntmp-vars-538) (syntmp-ls-541 (quote ())) (syntmp-w-542 (quote (())))) (cond ((pair? syntmp-vars-540) (syntmp-lvl-539 (cdr syntmp-vars-540) (cons (syntmp-wrap-132 (car syntmp-vars-540) syntmp-w-542) syntmp-ls-541) syntmp-w-542)) ((syntmp-id?-104 syntmp-vars-540) (cons (syntmp-wrap-132 syntmp-vars-540 syntmp-w-542) syntmp-ls-541)) ((null? syntmp-vars-540) syntmp-ls-541) ((syntmp-syntax-object?-88 syntmp-vars-540) (syntmp-lvl-539 (syntmp-syntax-object-expression-89 syntmp-vars-540) syntmp-ls-541 (syntmp-join-wraps-123 syntmp-w-542 (syntmp-syntax-object-wrap-90 syntmp-vars-540)))) ((annotation? syntmp-vars-540) (syntmp-lvl-539 (annotation-expression syntmp-vars-540) syntmp-ls-541 syntmp-w-542)) (else (cons syntmp-vars-540 syntmp-ls-541)))))) (syntmp-gen-var-152 (lambda (syntmp-id-543) (let ((syntmp-id-544 (if (syntmp-syntax-object?-88 syntmp-id-543) (syntmp-syntax-object-expression-89 syntmp-id-543) syntmp-id-543))) (if (annotation? syntmp-id-544) (syntmp-build-annotated-81 (annotation-source syntmp-id-544) (gensym (symbol->string (annotation-expression syntmp-id-544)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-544))))))) (syntmp-strip-151 (lambda (syntmp-x-545 syntmp-w-546) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-546)) (if (or (annotation? syntmp-x-545) (and (pair? syntmp-x-545) (annotation? (car syntmp-x-545)))) (syntmp-strip-annotation-150 syntmp-x-545 #f) syntmp-x-545) (let syntmp-f-547 ((syntmp-x-548 syntmp-x-545)) (cond ((syntmp-syntax-object?-88 syntmp-x-548) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-548) (syntmp-syntax-object-wrap-90 syntmp-x-548))) ((pair? syntmp-x-548) (let ((syntmp-a-549 (syntmp-f-547 (car syntmp-x-548))) (syntmp-d-550 (syntmp-f-547 (cdr syntmp-x-548)))) (if (and (eq? syntmp-a-549 (car syntmp-x-548)) (eq? syntmp-d-550 (cdr syntmp-x-548))) syntmp-x-548 (cons syntmp-a-549 syntmp-d-550)))) ((vector? syntmp-x-548) (let ((syntmp-old-551 (vector->list syntmp-x-548))) (let ((syntmp-new-552 (map syntmp-f-547 syntmp-old-551))) (if (andmap eq? syntmp-old-551 syntmp-new-552) syntmp-x-548 (list->vector syntmp-new-552))))) (else syntmp-x-548)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-553 syntmp-parent-554) (cond ((pair? syntmp-x-553) (let ((syntmp-new-555 (cons #f #f))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-555)) (set-car! syntmp-new-555 (syntmp-strip-annotation-150 (car syntmp-x-553) #f)) (set-cdr! syntmp-new-555 (syntmp-strip-annotation-150 (cdr syntmp-x-553) #f)) syntmp-new-555))) ((annotation? syntmp-x-553) (or (annotation-stripped syntmp-x-553) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-553) syntmp-x-553))) ((vector? syntmp-x-553) (let ((syntmp-new-556 (make-vector (vector-length syntmp-x-553)))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-556)) (let syntmp-loop-557 ((syntmp-i-558 (- (vector-length syntmp-x-553) 1))) (unless (syntmp-fx<-75 syntmp-i-558 0) (vector-set! syntmp-new-556 syntmp-i-558 (syntmp-strip-annotation-150 (vector-ref syntmp-x-553 syntmp-i-558) #f)) (syntmp-loop-557 (syntmp-fx--73 syntmp-i-558 1)))) syntmp-new-556))) (else syntmp-x-553)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-559) (and (syntmp-nonsymbol-id?-103 syntmp-x-559) (syntmp-free-id=?-127 syntmp-x-559 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-560) (let ((syntmp-p-561 (syntmp-local-eval-hook-77 syntmp-expanded-560))) (if (procedure? syntmp-p-561) syntmp-p-561 (syntax-error syntmp-p-561 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-562 syntmp-e-563 syntmp-r-564 syntmp-w-565 syntmp-s-566 syntmp-k-567) ((lambda (syntmp-tmp-568) ((lambda (syntmp-tmp-569) (if syntmp-tmp-569 (apply (lambda (syntmp-_-570 syntmp-id-571 syntmp-val-572 syntmp-e1-573 syntmp-e2-574) (let ((syntmp-ids-575 syntmp-id-571)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-575)) (syntax-error syntmp-e-563 "duplicate bound keyword in") (let ((syntmp-labels-577 (syntmp-gen-labels-110 syntmp-ids-575))) (let ((syntmp-new-w-578 (syntmp-make-binding-wrap-121 syntmp-ids-575 syntmp-labels-577 syntmp-w-565))) (syntmp-k-567 (cons syntmp-e1-573 syntmp-e2-574) (syntmp-extend-env-98 syntmp-labels-577 (let ((syntmp-w-580 (if syntmp-rec?-562 syntmp-new-w-578 syntmp-w-565)) (syntmp-trans-r-581 (syntmp-macros-only-env-100 syntmp-r-564))) (map (lambda (syntmp-x-582) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-582 syntmp-trans-r-581 syntmp-w-580)))) syntmp-val-572)) syntmp-r-564) syntmp-new-w-578 syntmp-s-566)))))) syntmp-tmp-569) ((lambda (syntmp-_-584) (syntax-error (syntmp-source-wrap-133 syntmp-e-563 syntmp-w-565 syntmp-s-566))) syntmp-tmp-568))) (syntax-dispatch syntmp-tmp-568 (quote (any #(each (any any)) any . each-any))))) syntmp-e-563))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-585 syntmp-c-586 syntmp-r-587 syntmp-w-588 syntmp-k-589) ((lambda (syntmp-tmp-590) ((lambda (syntmp-tmp-591) (if syntmp-tmp-591 (apply (lambda (syntmp-id-592 syntmp-e1-593 syntmp-e2-594) (let ((syntmp-ids-595 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-595)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-597 (syntmp-gen-labels-110 syntmp-ids-595)) (syntmp-new-vars-598 (map syntmp-gen-var-152 syntmp-ids-595))) (syntmp-k-589 syntmp-new-vars-598 (syntmp-chi-body-144 (cons syntmp-e1-593 syntmp-e2-594) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-597 syntmp-new-vars-598 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-ids-595 syntmp-labels-597 syntmp-w-588))))))) syntmp-tmp-591) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-ids-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-old-ids-604 (syntmp-lambda-var-list-153 syntmp-ids-601))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-604)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-605 (syntmp-gen-labels-110 syntmp-old-ids-604)) (syntmp-new-vars-606 (map syntmp-gen-var-152 syntmp-old-ids-604))) (syntmp-k-589 (let syntmp-f-607 ((syntmp-ls1-608 (cdr syntmp-new-vars-606)) (syntmp-ls2-609 (car syntmp-new-vars-606))) (if (null? syntmp-ls1-608) syntmp-ls2-609 (syntmp-f-607 (cdr syntmp-ls1-608) (cons (car syntmp-ls1-608) syntmp-ls2-609)))) (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-605 syntmp-new-vars-606 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-old-ids-604 syntmp-labels-605 syntmp-w-588))))))) syntmp-tmp-600) ((lambda (syntmp-_-611) (syntax-error syntmp-e-585)) syntmp-tmp-590))) (syntax-dispatch syntmp-tmp-590 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-590 (quote (each-any any . each-any))))) syntmp-c-586))) (syntmp-chi-body-144 (lambda (syntmp-body-612 syntmp-outer-form-613 syntmp-r-614 syntmp-w-615) (let ((syntmp-r-616 (cons (quote ("placeholder" placeholder)) syntmp-r-614))) (let ((syntmp-ribcage-617 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-618 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-615) (cons syntmp-ribcage-617 (syntmp-wrap-subst-108 syntmp-w-615))))) (let syntmp-parse-619 ((syntmp-body-620 (map (lambda (syntmp-x-626) (cons syntmp-r-616 (syntmp-wrap-132 syntmp-x-626 syntmp-w-618))) syntmp-body-612)) (syntmp-ids-621 (quote ())) (syntmp-labels-622 (quote ())) (syntmp-vars-623 (quote ())) (syntmp-vals-624 (quote ())) (syntmp-bindings-625 (quote ()))) (if (null? syntmp-body-620) (syntax-error syntmp-outer-form-613 "no expressions in body") (let ((syntmp-e-627 (cdar syntmp-body-620)) (syntmp-er-628 (caar syntmp-body-620))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-627 syntmp-er-628 (quote (())) #f syntmp-ribcage-617)) (lambda (syntmp-type-629 syntmp-value-630 syntmp-e-631 syntmp-w-632 syntmp-s-633) (let ((syntmp-t-634 syntmp-type-629)) (if (memv syntmp-t-634 (quote (define-form))) (let ((syntmp-id-635 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-636 (syntmp-gen-label-109))) (let ((syntmp-var-637 (syntmp-gen-var-152 syntmp-id-635))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-635 syntmp-label-636) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-635 syntmp-ids-621) (cons syntmp-label-636 syntmp-labels-622) (cons syntmp-var-637 syntmp-vars-623) (cons (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632)) syntmp-vals-624) (cons (cons (quote lexical) syntmp-var-637) syntmp-bindings-625))))) (if (memv syntmp-t-634 (quote (define-syntax-form))) (let ((syntmp-id-638 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-639 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-638 syntmp-label-639) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-638 syntmp-ids-621) (cons syntmp-label-639 syntmp-labels-622) syntmp-vars-623 syntmp-vals-624 (cons (cons (quote macro) (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632))) syntmp-bindings-625)))) (if (memv syntmp-t-634 (quote (begin-form))) ((lambda (syntmp-tmp-640) ((lambda (syntmp-tmp-641) (if syntmp-tmp-641 (apply (lambda (syntmp-_-642 syntmp-e1-643) (syntmp-parse-619 (let syntmp-f-644 ((syntmp-forms-645 syntmp-e1-643)) (if (null? syntmp-forms-645) (cdr syntmp-body-620) (cons (cons syntmp-er-628 (syntmp-wrap-132 (car syntmp-forms-645) syntmp-w-632)) (syntmp-f-644 (cdr syntmp-forms-645))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625)) syntmp-tmp-641) (syntax-error syntmp-tmp-640))) (syntax-dispatch syntmp-tmp-640 (quote (any . each-any))))) syntmp-e-631) (if (memv syntmp-t-634 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-630 syntmp-e-631 syntmp-er-628 syntmp-w-632 syntmp-s-633 (lambda (syntmp-forms-647 syntmp-er-648 syntmp-w-649 syntmp-s-650) (syntmp-parse-619 (let syntmp-f-651 ((syntmp-forms-652 syntmp-forms-647)) (if (null? syntmp-forms-652) (cdr syntmp-body-620) (cons (cons syntmp-er-648 (syntmp-wrap-132 (car syntmp-forms-652) syntmp-w-649)) (syntmp-f-651 (cdr syntmp-forms-652))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625))) (if (null? syntmp-ids-621) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-653) (syntmp-chi-140 (cdr syntmp-x-653) (car syntmp-x-653) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-621)) (syntax-error syntmp-outer-form-613 "invalid or duplicate identifier in definition")) (let syntmp-loop-654 ((syntmp-bs-655 syntmp-bindings-625) (syntmp-er-cache-656 #f) (syntmp-r-cache-657 #f)) (if (not (null? syntmp-bs-655)) (let ((syntmp-b-658 (car syntmp-bs-655))) (if (eq? (car syntmp-b-658) (quote macro)) (let ((syntmp-er-659 (cadr syntmp-b-658))) (let ((syntmp-r-cache-660 (if (eq? syntmp-er-659 syntmp-er-cache-656) syntmp-r-cache-657 (syntmp-macros-only-env-100 syntmp-er-659)))) (begin (set-cdr! syntmp-b-658 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-658) syntmp-r-cache-660 (quote (()))))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-659 syntmp-r-cache-660)))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-cache-656 syntmp-r-cache-657))))) (set-cdr! syntmp-r-616 (syntmp-extend-env-98 syntmp-labels-622 syntmp-bindings-625 (cdr syntmp-r-616))) (syntmp-build-letrec-86 #f syntmp-vars-623 (map (lambda (syntmp-x-661) (syntmp-chi-140 (cdr syntmp-x-661) (car syntmp-x-661) (quote (())))) syntmp-vals-624) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-662) (syntmp-chi-140 (cdr syntmp-x-662) (car syntmp-x-662) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-663 syntmp-e-664 syntmp-r-665 syntmp-w-666 syntmp-rib-667) (letrec ((syntmp-rebuild-macro-output-668 (lambda (syntmp-x-669 syntmp-m-670) (cond ((pair? syntmp-x-669) (cons (syntmp-rebuild-macro-output-668 (car syntmp-x-669) syntmp-m-670) (syntmp-rebuild-macro-output-668 (cdr syntmp-x-669) syntmp-m-670))) ((syntmp-syntax-object?-88 syntmp-x-669) (let ((syntmp-w-671 (syntmp-syntax-object-wrap-90 syntmp-x-669))) (let ((syntmp-ms-672 (syntmp-wrap-marks-107 syntmp-w-671)) (syntmp-s-673 (syntmp-wrap-subst-108 syntmp-w-671))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-669) (if (and (pair? syntmp-ms-672) (eq? (car syntmp-ms-672) #f)) (syntmp-make-wrap-106 (cdr syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cdr syntmp-s-673)) (cdr syntmp-s-673))) (syntmp-make-wrap-106 (cons syntmp-m-670 syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cons (quote shift) syntmp-s-673)) (cons (quote shift) syntmp-s-673)))) (syntmp-syntax-object-module-91 syntmp-x-669))))) ((vector? syntmp-x-669) (let ((syntmp-n-674 (vector-length syntmp-x-669))) (let ((syntmp-v-675 (make-vector syntmp-n-674))) (let syntmp-doloop-676 ((syntmp-i-677 0)) (if (syntmp-fx=-74 syntmp-i-677 syntmp-n-674) syntmp-v-675 (begin (vector-set! syntmp-v-675 syntmp-i-677 (syntmp-rebuild-macro-output-668 (vector-ref syntmp-x-669 syntmp-i-677) syntmp-m-670)) (syntmp-doloop-676 (syntmp-fx+-72 syntmp-i-677 1)))))))) ((symbol? syntmp-x-669) (syntax-error syntmp-x-669 "encountered raw symbol in macro output")) (else syntmp-x-669))))) (syntmp-rebuild-macro-output-668 (syntmp-p-663 (syntmp-wrap-132 syntmp-e-664 (syntmp-anti-mark-119 syntmp-w-666))) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-678 syntmp-e-679 syntmp-r-680 syntmp-w-681 syntmp-s-682) ((lambda (syntmp-tmp-683) ((lambda (syntmp-tmp-684) (if syntmp-tmp-684 (apply (lambda (syntmp-e0-685 syntmp-e1-686) (syntmp-build-annotated-81 syntmp-s-682 (cons syntmp-x-678 (map (lambda (syntmp-e-687) (syntmp-chi-140 syntmp-e-687 syntmp-r-680 syntmp-w-681)) syntmp-e1-686)))) syntmp-tmp-684) (syntax-error syntmp-tmp-683))) (syntax-dispatch syntmp-tmp-683 (quote (any . each-any))))) syntmp-e-679))) (syntmp-chi-expr-141 (lambda (syntmp-type-689 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (let ((syntmp-t-695 syntmp-type-689)) (if (memv syntmp-t-695 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-694 syntmp-value-690) (if (memv syntmp-t-695 (quote (core external-macro))) (syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) syntmp-value-690) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) (make-module-ref #f syntmp-value-690 #f)) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (constant))) (syntmp-build-data-82 syntmp-s-694 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) (quote (())))) (if (memv syntmp-t-695 (quote (global))) (syntmp-build-annotated-81 syntmp-s-694 (make-module-ref #f syntmp-value-690 #f)) (if (memv syntmp-t-695 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-691) syntmp-r-692 syntmp-w-693) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (begin-form))) ((lambda (syntmp-tmp-696) ((lambda (syntmp-tmp-697) (if syntmp-tmp-697 (apply (lambda (syntmp-_-698 syntmp-e1-699 syntmp-e2-700) (syntmp-chi-sequence-134 (cons syntmp-e1-699 syntmp-e2-700) syntmp-r-692 syntmp-w-693 syntmp-s-694)) syntmp-tmp-697) (syntax-error syntmp-tmp-696))) (syntax-dispatch syntmp-tmp-696 (quote (any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694 syntmp-chi-sequence-134) (if (memv syntmp-t-695 (quote (eval-when-form))) ((lambda (syntmp-tmp-702) ((lambda (syntmp-tmp-703) (if syntmp-tmp-703 (apply (lambda (syntmp-_-704 syntmp-x-705 syntmp-e1-706 syntmp-e2-707) (let ((syntmp-when-list-708 (syntmp-chi-when-list-137 syntmp-e-691 syntmp-x-705 syntmp-w-693))) (if (memq (quote eval) syntmp-when-list-708) (syntmp-chi-sequence-134 (cons syntmp-e1-706 syntmp-e2-707) syntmp-r-692 syntmp-w-693 syntmp-s-694) (syntmp-chi-void-148)))) syntmp-tmp-703) (syntax-error syntmp-tmp-702))) (syntax-dispatch syntmp-tmp-702 (quote (any each-any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-690 syntmp-w-693) "invalid context for definition of") (if (memv syntmp-t-695 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to pattern variable outside syntax form") (if (memv syntmp-t-695 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694)))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-711 syntmp-r-712 syntmp-w-713) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-711 syntmp-r-712 syntmp-w-713 #f #f)) (lambda (syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-w-717 syntmp-s-718) (syntmp-chi-expr-141 syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-r-712 syntmp-w-717 syntmp-s-718))))) (syntmp-chi-top-139 (lambda (syntmp-e-719 syntmp-r-720 syntmp-w-721 syntmp-m-722 syntmp-esew-723) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-719 syntmp-r-720 syntmp-w-721 #f #f)) (lambda (syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-w-739 syntmp-s-740) (let ((syntmp-t-741 syntmp-type-736)) (if (memv syntmp-t-741 (quote (begin-form))) ((lambda (syntmp-tmp-742) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744) (syntmp-chi-void-148)) syntmp-tmp-743) ((lambda (syntmp-tmp-745) (if syntmp-tmp-745 (apply (lambda (syntmp-_-746 syntmp-e1-747 syntmp-e2-748) (syntmp-chi-top-sequence-135 (cons syntmp-e1-747 syntmp-e2-748) syntmp-r-720 syntmp-w-739 syntmp-s-740 syntmp-m-722 syntmp-esew-723)) syntmp-tmp-745) (syntax-error syntmp-tmp-742))) (syntax-dispatch syntmp-tmp-742 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-742 (quote (any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740 (lambda (syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753) (syntmp-chi-top-sequence-135 syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753 syntmp-m-722 syntmp-esew-723))) (if (memv syntmp-t-741 (quote (eval-when-form))) ((lambda (syntmp-tmp-754) ((lambda (syntmp-tmp-755) (if syntmp-tmp-755 (apply (lambda (syntmp-_-756 syntmp-x-757 syntmp-e1-758 syntmp-e2-759) (let ((syntmp-when-list-760 (syntmp-chi-when-list-137 syntmp-e-738 syntmp-x-757 syntmp-w-739)) (syntmp-body-761 (cons syntmp-e1-758 syntmp-e2-759))) (cond ((eq? syntmp-m-722 (quote e)) (if (memq (quote eval) syntmp-when-list-760) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval))) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-760) (if (or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c&e) (quote (compile load))) (if (memq syntmp-m-722 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c) (quote (load))) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval)))) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-755) (syntax-error syntmp-tmp-754))) (syntax-dispatch syntmp-tmp-754 (quote (any each-any any . each-any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (define-syntax-form))) (let ((syntmp-n-764 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739)) (syntmp-r-765 (syntmp-macros-only-env-100 syntmp-r-720))) (let ((syntmp-t-766 syntmp-m-722)) (if (memv syntmp-t-766 (quote (c))) (if (memq (quote compile) syntmp-esew-723) (let ((syntmp-e-767 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-767) (if (memq (quote load) syntmp-esew-723) syntmp-e-767 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-723) (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)) (syntmp-chi-void-148))) (if (memv syntmp-t-766 (quote (c&e))) (let ((syntmp-e-768 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-768) syntmp-e-768)) (begin (if (memq (quote eval) syntmp-esew-723) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (syntmp-chi-void-148)))))) (if (memv syntmp-t-741 (quote (define-form))) (let ((syntmp-n-769 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739))) (let ((syntmp-type-770 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-769 syntmp-r-720)))) (let ((syntmp-t-771 syntmp-type-770)) (if (memv syntmp-t-771 (quote (global))) (let ((syntmp-x-772 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)) (if (memv syntmp-t-771 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "identifier out of context") (if (eq? syntmp-type-770 (quote external-macro)) (let ((syntmp-x-773 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-773)) syntmp-x-773)) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "cannot define keyword at top level"))))))) (let ((syntmp-x-774 (syntmp-chi-expr-141 syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-774)) syntmp-x-774)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-s-778 syntmp-rib-779) (cond ((symbol? syntmp-e-775) (let ((syntmp-n-780 (syntmp-id-var-name-126 syntmp-e-775 syntmp-w-777))) (let ((syntmp-b-781 (syntmp-lookup-101 syntmp-n-780 syntmp-r-776))) (let ((syntmp-type-782 (syntmp-binding-type-96 syntmp-b-781))) (let ((syntmp-t-783 syntmp-type-782)) (if (memv syntmp-t-783 (quote (lexical))) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (global))) (values syntmp-type-782 syntmp-n-780 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778))))))))) ((pair? syntmp-e-775) (let ((syntmp-first-784 (car syntmp-e-775))) (if (syntmp-id?-104 syntmp-first-784) (let ((syntmp-n-785 (syntmp-id-var-name-126 syntmp-first-784 syntmp-w-777))) (let ((syntmp-b-786 (syntmp-lookup-101 syntmp-n-785 syntmp-r-776))) (let ((syntmp-type-787 (syntmp-binding-type-96 syntmp-b-786))) (let ((syntmp-t-788 syntmp-type-787)) (if (memv syntmp-t-788 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (global))) (values (quote global-call) syntmp-n-785 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (if (memv syntmp-t-788 (quote (core external-macro))) (values syntmp-type-787 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (begin))) (values (quote begin-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (define))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-name-792 syntmp-val-793) (syntmp-id?-104 syntmp-name-792)) syntmp-tmp-790) #f) (apply (lambda (syntmp-_-794 syntmp-name-795 syntmp-val-796) (values (quote define-form) syntmp-name-795 syntmp-val-796 syntmp-w-777 syntmp-s-778)) syntmp-tmp-790) ((lambda (syntmp-tmp-797) (if (if syntmp-tmp-797 (apply (lambda (syntmp-_-798 syntmp-name-799 syntmp-args-800 syntmp-e1-801 syntmp-e2-802) (and (syntmp-id?-104 syntmp-name-799) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-800)))) syntmp-tmp-797) #f) (apply (lambda (syntmp-_-803 syntmp-name-804 syntmp-args-805 syntmp-e1-806 syntmp-e2-807) (values (quote define-form) (syntmp-wrap-132 syntmp-name-804 syntmp-w-777) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) (syntmp-wrap-132 (cons syntmp-args-805 (cons syntmp-e1-806 syntmp-e2-807)) syntmp-w-777)) (quote (())) syntmp-s-778)) syntmp-tmp-797) ((lambda (syntmp-tmp-809) (if (if syntmp-tmp-809 (apply (lambda (syntmp-_-810 syntmp-name-811) (syntmp-id?-104 syntmp-name-811)) syntmp-tmp-809) #f) (apply (lambda (syntmp-_-812 syntmp-name-813) (values (quote define-form) (syntmp-wrap-132 syntmp-name-813 syntmp-w-777) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote (())) syntmp-s-778)) syntmp-tmp-809) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any any any))))) syntmp-e-775) (if (memv syntmp-t-788 (quote (define-syntax))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-syntax-form) syntmp-name-820 syntmp-val-821 syntmp-w-777 syntmp-s-778)) syntmp-tmp-815) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-775) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))))))))))))) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))) ((syntmp-syntax-object?-88 syntmp-e-775) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-775) syntmp-r-776 (syntmp-join-wraps-123 syntmp-w-777 (syntmp-syntax-object-wrap-90 syntmp-e-775)) #f syntmp-rib-779)) ((annotation? syntmp-e-775) (syntmp-syntax-type-138 (annotation-expression syntmp-e-775) syntmp-r-776 syntmp-w-777 (annotation-source syntmp-e-775) syntmp-rib-779)) ((self-evaluating? syntmp-e-775) (values (quote constant) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)) (else (values (quote other) #f syntmp-e-775 syntmp-w-777 syntmp-s-778))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-822 syntmp-when-list-823 syntmp-w-824) (let syntmp-f-825 ((syntmp-when-list-826 syntmp-when-list-823) (syntmp-situations-827 (quote ()))) (if (null? syntmp-when-list-826) syntmp-situations-827 (syntmp-f-825 (cdr syntmp-when-list-826) (cons (let ((syntmp-x-828 (car syntmp-when-list-826))) (cond ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-828 syntmp-w-824) "invalid eval-when situation")))) syntmp-situations-827)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-829 syntmp-e-830) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-829) syntmp-e-830)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-831 syntmp-r-832 syntmp-w-833 syntmp-s-834 syntmp-m-835 syntmp-esew-836) (syntmp-build-sequence-83 syntmp-s-834 (let syntmp-dobody-837 ((syntmp-body-838 syntmp-body-831) (syntmp-r-839 syntmp-r-832) (syntmp-w-840 syntmp-w-833) (syntmp-m-841 syntmp-m-835) (syntmp-esew-842 syntmp-esew-836)) (if (null? syntmp-body-838) (quote ()) (let ((syntmp-first-843 (syntmp-chi-top-139 (car syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842))) (cons syntmp-first-843 (syntmp-dobody-837 (cdr syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-844 syntmp-r-845 syntmp-w-846 syntmp-s-847) (syntmp-build-sequence-83 syntmp-s-847 (let syntmp-dobody-848 ((syntmp-body-849 syntmp-body-844) (syntmp-r-850 syntmp-r-845) (syntmp-w-851 syntmp-w-846)) (if (null? syntmp-body-849) (quote ()) (let ((syntmp-first-852 (syntmp-chi-140 (car syntmp-body-849) syntmp-r-850 syntmp-w-851))) (cons syntmp-first-852 (syntmp-dobody-848 (cdr syntmp-body-849) syntmp-r-850 syntmp-w-851)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-853 syntmp-w-854 syntmp-s-855) (syntmp-wrap-132 (if syntmp-s-855 (make-annotation syntmp-x-853 syntmp-s-855 #f) syntmp-x-853) syntmp-w-854))) (syntmp-wrap-132 (lambda (syntmp-x-856 syntmp-w-857) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-857)) (null? (syntmp-wrap-subst-108 syntmp-w-857))) syntmp-x-856) ((syntmp-syntax-object?-88 syntmp-x-856) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-856) (syntmp-join-wraps-123 syntmp-w-857 (syntmp-syntax-object-wrap-90 syntmp-x-856)) (syntmp-syntax-object-module-91 syntmp-x-856))) ((null? syntmp-x-856) syntmp-x-856) (else (syntmp-make-syntax-object-87 syntmp-x-856 syntmp-w-857 #f))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-858 syntmp-list-859) (and (not (null? syntmp-list-859)) (or (syntmp-bound-id=?-128 syntmp-x-858 (car syntmp-list-859)) (syntmp-bound-id-member?-131 syntmp-x-858 (cdr syntmp-list-859)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-860) (let syntmp-distinct?-861 ((syntmp-ids-862 syntmp-ids-860)) (or (null? syntmp-ids-862) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-862) (cdr syntmp-ids-862))) (syntmp-distinct?-861 (cdr syntmp-ids-862))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-863) (and (let syntmp-all-ids?-864 ((syntmp-ids-865 syntmp-ids-863)) (or (null? syntmp-ids-865) (and (syntmp-id?-104 (car syntmp-ids-865)) (syntmp-all-ids?-864 (cdr syntmp-ids-865))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-863)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-866 syntmp-j-867) (if (and (syntmp-syntax-object?-88 syntmp-i-866) (syntmp-syntax-object?-88 syntmp-j-867)) (and (eq? (let ((syntmp-e-868 (syntmp-syntax-object-expression-89 syntmp-i-866))) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 (syntmp-syntax-object-expression-89 syntmp-j-867))) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-866)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-867)))) (eq? (let ((syntmp-e-870 syntmp-i-866)) (if (annotation? syntmp-e-870) (annotation-expression syntmp-e-870) syntmp-e-870)) (let ((syntmp-e-871 syntmp-j-867)) (if (annotation? syntmp-e-871) (annotation-expression syntmp-e-871) syntmp-e-871)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-872 syntmp-j-873) (and (eq? (let ((syntmp-x-874 syntmp-i-872)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875))) (let ((syntmp-x-876 syntmp-j-873)) (let ((syntmp-e-877 (if (syntmp-syntax-object?-88 syntmp-x-876) (syntmp-syntax-object-expression-89 syntmp-x-876) syntmp-x-876))) (if (annotation? syntmp-e-877) (annotation-expression syntmp-e-877) syntmp-e-877)))) (eq? (syntmp-id-var-name-126 syntmp-i-872 (quote (()))) (syntmp-id-var-name-126 syntmp-j-873 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-878 syntmp-w-879) (letrec ((syntmp-search-vector-rib-882 (lambda (syntmp-sym-893 syntmp-subst-894 syntmp-marks-895 syntmp-symnames-896 syntmp-ribcage-897) (let ((syntmp-n-898 (vector-length syntmp-symnames-896))) (let syntmp-f-899 ((syntmp-i-900 0)) (cond ((syntmp-fx=-74 syntmp-i-900 syntmp-n-898) (syntmp-search-880 syntmp-sym-893 (cdr syntmp-subst-894) syntmp-marks-895)) ((and (eq? (vector-ref syntmp-symnames-896 syntmp-i-900) syntmp-sym-893) (syntmp-same-marks?-125 syntmp-marks-895 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-897) syntmp-i-900))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-897) syntmp-i-900) syntmp-marks-895)) (else (syntmp-f-899 (syntmp-fx+-72 syntmp-i-900 1)))))))) (syntmp-search-list-rib-881 (lambda (syntmp-sym-901 syntmp-subst-902 syntmp-marks-903 syntmp-symnames-904 syntmp-ribcage-905) (let syntmp-f-906 ((syntmp-symnames-907 syntmp-symnames-904) (syntmp-i-908 0)) (cond ((null? syntmp-symnames-907) (syntmp-search-880 syntmp-sym-901 (cdr syntmp-subst-902) syntmp-marks-903)) ((and (eq? (car syntmp-symnames-907) syntmp-sym-901) (syntmp-same-marks?-125 syntmp-marks-903 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-905) syntmp-i-908))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-905) syntmp-i-908) syntmp-marks-903)) (else (syntmp-f-906 (cdr syntmp-symnames-907) (syntmp-fx+-72 syntmp-i-908 1))))))) (syntmp-search-880 (lambda (syntmp-sym-909 syntmp-subst-910 syntmp-marks-911) (if (null? syntmp-subst-910) (values #f syntmp-marks-911) (let ((syntmp-fst-912 (car syntmp-subst-910))) (if (eq? syntmp-fst-912 (quote shift)) (syntmp-search-880 syntmp-sym-909 (cdr syntmp-subst-910) (cdr syntmp-marks-911)) (let ((syntmp-symnames-913 (syntmp-ribcage-symnames-113 syntmp-fst-912))) (if (vector? syntmp-symnames-913) (syntmp-search-vector-rib-882 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912) (syntmp-search-list-rib-881 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912))))))))) (cond ((symbol? syntmp-id-878) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-878 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-915 . syntmp-ignore-914) syntmp-x-915)) syntmp-id-878)) ((syntmp-syntax-object?-88 syntmp-id-878) (let ((syntmp-id-916 (let ((syntmp-e-918 (syntmp-syntax-object-expression-89 syntmp-id-878))) (if (annotation? syntmp-e-918) (annotation-expression syntmp-e-918) syntmp-e-918))) (syntmp-w1-917 (syntmp-syntax-object-wrap-90 syntmp-id-878))) (let ((syntmp-marks-919 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w1-917)))) (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w-879) syntmp-marks-919)) (lambda (syntmp-new-id-920 syntmp-marks-921) (or syntmp-new-id-920 (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w1-917) syntmp-marks-921)) (lambda (syntmp-x-923 . syntmp-ignore-922) syntmp-x-923)) syntmp-id-916)))))) ((annotation? syntmp-id-878) (let ((syntmp-id-924 (let ((syntmp-e-925 syntmp-id-878)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)))) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-924 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-927 . syntmp-ignore-926) syntmp-x-927)) syntmp-id-924))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-878)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-928 syntmp-y-929) (or (eq? syntmp-x-928 syntmp-y-929) (and (not (null? syntmp-x-928)) (not (null? syntmp-y-929)) (eq? (car syntmp-x-928) (car syntmp-y-929)) (syntmp-same-marks?-125 (cdr syntmp-x-928) (cdr syntmp-y-929)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-930 syntmp-m2-931) (syntmp-smart-append-122 syntmp-m1-930 syntmp-m2-931))) (syntmp-join-wraps-123 (lambda (syntmp-w1-932 syntmp-w2-933) (let ((syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w1-932)) (syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w1-932))) (if (null? syntmp-m1-934) (if (null? syntmp-s1-935) syntmp-w2-933 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-933) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w2-933)) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-936 syntmp-m2-937) (if (null? syntmp-m2-937) syntmp-m1-936 (append syntmp-m1-936 syntmp-m2-937)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-938 syntmp-labels-939 syntmp-w-940) (if (null? syntmp-ids-938) syntmp-w-940 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-940) (cons (let ((syntmp-labelvec-941 (list->vector syntmp-labels-939))) (let ((syntmp-n-942 (vector-length syntmp-labelvec-941))) (let ((syntmp-symnamevec-943 (make-vector syntmp-n-942)) (syntmp-marksvec-944 (make-vector syntmp-n-942))) (begin (let syntmp-f-945 ((syntmp-ids-946 syntmp-ids-938) (syntmp-i-947 0)) (if (not (null? syntmp-ids-946)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-946) syntmp-w-940)) (lambda (syntmp-symname-948 syntmp-marks-949) (begin (vector-set! syntmp-symnamevec-943 syntmp-i-947 syntmp-symname-948) (vector-set! syntmp-marksvec-944 syntmp-i-947 syntmp-marks-949) (syntmp-f-945 (cdr syntmp-ids-946) (syntmp-fx+-72 syntmp-i-947 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-943 syntmp-marksvec-944 syntmp-labelvec-941))))) (syntmp-wrap-subst-108 syntmp-w-940)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-950 syntmp-id-951 syntmp-label-952) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-950 (cons (let ((syntmp-e-953 (syntmp-syntax-object-expression-89 syntmp-id-951))) (if (annotation? syntmp-e-953) (annotation-expression syntmp-e-953) syntmp-e-953)) (syntmp-ribcage-symnames-113 syntmp-ribcage-950))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-950 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-951)) (syntmp-ribcage-marks-114 syntmp-ribcage-950))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-950 (cons syntmp-label-952 (syntmp-ribcage-labels-115 syntmp-ribcage-950)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-954) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-954)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-954))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 3 syntmp-update-956))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 2 syntmp-update-958))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-959 syntmp-update-960) (vector-set! syntmp-x-959 1 syntmp-update-960))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-962) (vector-ref syntmp-x-962 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-963) (vector-ref syntmp-x-963 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-964) (and (vector? syntmp-x-964) (= (vector-length syntmp-x-964) 4) (eq? (vector-ref syntmp-x-964 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967) (vector (quote ribcage) syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967))) (syntmp-gen-labels-110 (lambda (syntmp-ls-968) (if (null? syntmp-ls-968) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-968)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-969 syntmp-w-970) (if (syntmp-syntax-object?-88 syntmp-x-969) (values (let ((syntmp-e-971 (syntmp-syntax-object-expression-89 syntmp-x-969))) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-970) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-969)))) (values (let ((syntmp-e-972 syntmp-x-969)) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)) (syntmp-wrap-marks-107 syntmp-w-970))))) (syntmp-id?-104 (lambda (syntmp-x-973) (cond ((symbol? syntmp-x-973) #t) ((syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))) ((annotation? syntmp-x-973) (symbol? (annotation-expression syntmp-x-973))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-975) (and (syntmp-syntax-object?-88 syntmp-x-975) (symbol? (let ((syntmp-e-976 (syntmp-syntax-object-expression-89 syntmp-x-975))) (if (annotation? syntmp-e-976) (annotation-expression syntmp-e-976) syntmp-e-976)))))) (syntmp-global-extend-102 (lambda (syntmp-type-977 syntmp-sym-978 syntmp-val-979) (syntmp-put-global-definition-hook-79 syntmp-sym-978 (cons syntmp-type-977 syntmp-val-979)))) (syntmp-lookup-101 (lambda (syntmp-x-980 syntmp-r-981) (cond ((assq syntmp-x-980 syntmp-r-981) => cdr) ((symbol? syntmp-x-980) (or (syntmp-get-global-definition-hook-80 syntmp-x-980) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-982) (if (null? syntmp-r-982) (quote ()) (let ((syntmp-a-983 (car syntmp-r-982))) (if (eq? (cadr syntmp-a-983) (quote macro)) (cons syntmp-a-983 (syntmp-macros-only-env-100 (cdr syntmp-r-982))) (syntmp-macros-only-env-100 (cdr syntmp-r-982))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-984 syntmp-vars-985 syntmp-r-986) (if (null? syntmp-labels-984) syntmp-r-986 (syntmp-extend-var-env-99 (cdr syntmp-labels-984) (cdr syntmp-vars-985) (cons (cons (car syntmp-labels-984) (cons (quote lexical) (car syntmp-vars-985))) syntmp-r-986))))) (syntmp-extend-env-98 (lambda (syntmp-labels-987 syntmp-bindings-988 syntmp-r-989) (if (null? syntmp-labels-987) syntmp-r-989 (syntmp-extend-env-98 (cdr syntmp-labels-987) (cdr syntmp-bindings-988) (cons (cons (car syntmp-labels-987) (car syntmp-bindings-988)) syntmp-r-989))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-990) (cond ((annotation? syntmp-x-990) (annotation-source syntmp-x-990)) ((syntmp-syntax-object?-88 syntmp-x-990) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-990))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-991 syntmp-update-992) (vector-set! syntmp-x-991 3 syntmp-update-992))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-993 syntmp-update-994) (vector-set! syntmp-x-993 2 syntmp-update-994))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-995 syntmp-update-996) (vector-set! syntmp-x-995 1 syntmp-update-996))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-997) (vector-ref syntmp-x-997 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-998) (vector-ref syntmp-x-998 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-999) (vector-ref syntmp-x-999 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1000) (and (vector? syntmp-x-1000) (= (vector-length syntmp-x-1000) 4) (eq? (vector-ref syntmp-x-1000 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-1001 syntmp-wrap-1002 syntmp-module-1003) (vector (quote syntax-object) syntmp-expression-1001 syntmp-wrap-1002 syntmp-module-1003))) (syntmp-build-letrec-86 (lambda (syntmp-src-1004 syntmp-vars-1005 syntmp-val-exps-1006 syntmp-body-exp-1007) (if (null? syntmp-vars-1005) (syntmp-build-annotated-81 syntmp-src-1004 syntmp-body-exp-1007) (syntmp-build-annotated-81 syntmp-src-1004 (list (quote letrec) (map list syntmp-vars-1005 syntmp-val-exps-1006) syntmp-body-exp-1007))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1008 syntmp-vars-1009 syntmp-val-exps-1010 syntmp-body-exp-1011) (if (null? syntmp-vars-1009) (syntmp-build-annotated-81 syntmp-src-1008 syntmp-body-exp-1011) (syntmp-build-annotated-81 syntmp-src-1008 (list (quote let) (car syntmp-vars-1009) (map list (cdr syntmp-vars-1009) syntmp-val-exps-1010) syntmp-body-exp-1011))))) (syntmp-build-let-84 (lambda (syntmp-src-1012 syntmp-vars-1013 syntmp-val-exps-1014 syntmp-body-exp-1015) (if (null? syntmp-vars-1013) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-body-exp-1015) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote let) (map list syntmp-vars-1013 syntmp-val-exps-1014) syntmp-body-exp-1015))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1016 syntmp-exps-1017) (if (null? (cdr syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (car syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (cons (quote begin) syntmp-exps-1017))))) (syntmp-build-data-82 (lambda (syntmp-src-1018 syntmp-exp-1019) (if (and (self-evaluating? syntmp-exp-1019) (not (vector? syntmp-exp-1019))) (syntmp-build-annotated-81 syntmp-src-1018 syntmp-exp-1019) (syntmp-build-annotated-81 syntmp-src-1018 (list (quote quote) syntmp-exp-1019))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1020 syntmp-exp-1021) (if (and syntmp-src-1020 (not (annotation? syntmp-exp-1021))) (make-annotation syntmp-exp-1021 syntmp-src-1020 #t) syntmp-exp-1021))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1022) (getprop syntmp-symbol-1022 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1023 syntmp-binding-1024) (putprop syntmp-symbol-1023 (quote *sc-expander*) syntmp-binding-1024))) (syntmp-error-hook-78 (lambda (syntmp-who-1025 syntmp-why-1026 syntmp-what-1027) (error syntmp-who-1025 "~a ~s" syntmp-why-1026 syntmp-what-1027))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1028) (eval (list syntmp-noexpand-71 syntmp-x-1028) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1029) (eval (list syntmp-noexpand-71 syntmp-x-1029) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1030 syntmp-r-1031 syntmp-w-1032 syntmp-s-1033) ((lambda (syntmp-tmp-1034) ((lambda (syntmp-tmp-1035) (if (if syntmp-tmp-1035 (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (syntmp-valid-bound-ids?-129 syntmp-var-1037)) syntmp-tmp-1035) #f) (apply (lambda (syntmp-_-1042 syntmp-var-1043 syntmp-val-1044 syntmp-e1-1045 syntmp-e2-1046) (let ((syntmp-names-1047 (map (lambda (syntmp-x-1048) (syntmp-id-var-name-126 syntmp-x-1048 syntmp-w-1032)) syntmp-var-1043))) (begin (for-each (lambda (syntmp-id-1050 syntmp-n-1051) (let ((syntmp-t-1052 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1051 syntmp-r-1031)))) (if (memv syntmp-t-1052 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1050 syntmp-w-1032 syntmp-s-1033) "identifier out of context")))) syntmp-var-1043 syntmp-names-1047) (syntmp-chi-body-144 (cons syntmp-e1-1045 syntmp-e2-1046) (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033) (syntmp-extend-env-98 syntmp-names-1047 (let ((syntmp-trans-r-1055 (syntmp-macros-only-env-100 syntmp-r-1031))) (map (lambda (syntmp-x-1056) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1056 syntmp-trans-r-1055 syntmp-w-1032)))) syntmp-val-1044)) syntmp-r-1031) syntmp-w-1032)))) syntmp-tmp-1035) ((lambda (syntmp-_-1058) (syntax-error (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033))) syntmp-tmp-1034))) (syntax-dispatch syntmp-tmp-1034 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1030))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1059 syntmp-r-1060 syntmp-w-1061 syntmp-s-1062) ((lambda (syntmp-tmp-1063) ((lambda (syntmp-tmp-1064) (if syntmp-tmp-1064 (apply (lambda (syntmp-_-1065 syntmp-e-1066) (syntmp-build-data-82 syntmp-s-1062 (syntmp-strip-151 syntmp-e-1066 syntmp-w-1061))) syntmp-tmp-1064) ((lambda (syntmp-_-1067) (syntax-error (syntmp-source-wrap-133 syntmp-e-1059 syntmp-w-1061 syntmp-s-1062))) syntmp-tmp-1063))) (syntax-dispatch syntmp-tmp-1063 (quote (any any))))) syntmp-e-1059))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1075 (lambda (syntmp-x-1076) (let ((syntmp-t-1077 (car syntmp-x-1076))) (if (memv syntmp-t-1077 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1076) (syntmp-regen-1075 (caddr syntmp-x-1076)))) (if (memv syntmp-t-1077 (quote (map))) (let ((syntmp-ls-1078 (map syntmp-regen-1075 (cdr syntmp-x-1076)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1078) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1078))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1076)) (map syntmp-regen-1075 (cdr syntmp-x-1076)))))))))))) (syntmp-gen-vector-1074 (lambda (syntmp-x-1079) (cond ((eq? (car syntmp-x-1079) (quote list)) (cons (quote vector) (cdr syntmp-x-1079))) ((eq? (car syntmp-x-1079) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1079)))) (else (list (quote list->vector) syntmp-x-1079))))) (syntmp-gen-append-1073 (lambda (syntmp-x-1080 syntmp-y-1081) (if (equal? syntmp-y-1081 (quote (quote ()))) syntmp-x-1080 (list (quote append) syntmp-x-1080 syntmp-y-1081)))) (syntmp-gen-cons-1072 (lambda (syntmp-x-1082 syntmp-y-1083) (let ((syntmp-t-1084 (car syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (quote))) (if (eq? (car syntmp-x-1082) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1082) (cadr syntmp-y-1083))) (if (eq? (cadr syntmp-y-1083) (quote ())) (list (quote list) syntmp-x-1082) (list (quote cons) syntmp-x-1082 syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (list))) (cons (quote list) (cons syntmp-x-1082 (cdr syntmp-y-1083))) (list (quote cons) syntmp-x-1082 syntmp-y-1083)))))) (syntmp-gen-map-1071 (lambda (syntmp-e-1085 syntmp-map-env-1086) (let ((syntmp-formals-1087 (map cdr syntmp-map-env-1086)) (syntmp-actuals-1088 (map (lambda (syntmp-x-1089) (list (quote ref) (car syntmp-x-1089))) syntmp-map-env-1086))) (cond ((eq? (car syntmp-e-1085) (quote ref)) (car syntmp-actuals-1088)) ((andmap (lambda (syntmp-x-1090) (and (eq? (car syntmp-x-1090) (quote ref)) (memq (cadr syntmp-x-1090) syntmp-formals-1087))) (cdr syntmp-e-1085)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1085)) (map (let ((syntmp-r-1091 (map cons syntmp-formals-1087 syntmp-actuals-1088))) (lambda (syntmp-x-1092) (cdr (assq (cadr syntmp-x-1092) syntmp-r-1091)))) (cdr syntmp-e-1085))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1087 syntmp-e-1085) syntmp-actuals-1088))))))) (syntmp-gen-mappend-1070 (lambda (syntmp-e-1093 syntmp-map-env-1094) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1071 syntmp-e-1093 syntmp-map-env-1094)))) (syntmp-gen-ref-1069 (lambda (syntmp-src-1095 syntmp-var-1096 syntmp-level-1097 syntmp-maps-1098) (if (syntmp-fx=-74 syntmp-level-1097 0) (values syntmp-var-1096 syntmp-maps-1098) (if (null? syntmp-maps-1098) (syntax-error syntmp-src-1095 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1069 syntmp-src-1095 syntmp-var-1096 (syntmp-fx--73 syntmp-level-1097 1) (cdr syntmp-maps-1098))) (lambda (syntmp-outer-var-1099 syntmp-outer-maps-1100) (let ((syntmp-b-1101 (assq syntmp-outer-var-1099 (car syntmp-maps-1098)))) (if syntmp-b-1101 (values (cdr syntmp-b-1101) syntmp-maps-1098) (let ((syntmp-inner-var-1102 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1102 (cons (cons (cons syntmp-outer-var-1099 syntmp-inner-var-1102) (car syntmp-maps-1098)) syntmp-outer-maps-1100))))))))))) (syntmp-gen-syntax-1068 (lambda (syntmp-src-1103 syntmp-e-1104 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107) (if (syntmp-id?-104 syntmp-e-1104) (let ((syntmp-label-1108 (syntmp-id-var-name-126 syntmp-e-1104 (quote (()))))) (let ((syntmp-b-1109 (syntmp-lookup-101 syntmp-label-1108 syntmp-r-1105))) (if (eq? (syntmp-binding-type-96 syntmp-b-1109) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1110 (syntmp-binding-value-97 syntmp-b-1109))) (syntmp-gen-ref-1069 syntmp-src-1103 (car syntmp-var.lev-1110) (cdr syntmp-var.lev-1110) syntmp-maps-1106))) (lambda (syntmp-var-1111 syntmp-maps-1112) (values (list (quote ref) syntmp-var-1111) syntmp-maps-1112))) (if (syntmp-ellipsis?-1107 syntmp-e-1104) (syntax-error syntmp-src-1103 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106))))) ((lambda (syntmp-tmp-1113) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-dots-1115 syntmp-e-1116) (syntmp-ellipsis?-1107 syntmp-dots-1115)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-dots-1117 syntmp-e-1118) (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-e-1118 syntmp-r-1105 syntmp-maps-1106 (lambda (syntmp-x-1119) #f))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1120) (if (if syntmp-tmp-1120 (apply (lambda (syntmp-x-1121 syntmp-dots-1122 syntmp-y-1123) (syntmp-ellipsis?-1107 syntmp-dots-1122)) syntmp-tmp-1120) #f) (apply (lambda (syntmp-x-1124 syntmp-dots-1125 syntmp-y-1126) (let syntmp-f-1127 ((syntmp-y-1128 syntmp-y-1126) (syntmp-k-1129 (lambda (syntmp-maps-1130) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1124 syntmp-r-1105 (cons (quote ()) syntmp-maps-1130) syntmp-ellipsis?-1107)) (lambda (syntmp-x-1131 syntmp-maps-1132) (if (null? (car syntmp-maps-1132)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-map-1071 syntmp-x-1131 (car syntmp-maps-1132)) (cdr syntmp-maps-1132)))))))) ((lambda (syntmp-tmp-1133) ((lambda (syntmp-tmp-1134) (if (if syntmp-tmp-1134 (apply (lambda (syntmp-dots-1135 syntmp-y-1136) (syntmp-ellipsis?-1107 syntmp-dots-1135)) syntmp-tmp-1134) #f) (apply (lambda (syntmp-dots-1137 syntmp-y-1138) (syntmp-f-1127 syntmp-y-1138 (lambda (syntmp-maps-1139) (call-with-values (lambda () (syntmp-k-1129 (cons (quote ()) syntmp-maps-1139))) (lambda (syntmp-x-1140 syntmp-maps-1141) (if (null? (car syntmp-maps-1141)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1070 syntmp-x-1140 (car syntmp-maps-1141)) (cdr syntmp-maps-1141)))))))) syntmp-tmp-1134) ((lambda (syntmp-_-1142) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1128 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1143 syntmp-maps-1144) (call-with-values (lambda () (syntmp-k-1129 syntmp-maps-1144)) (lambda (syntmp-x-1145 syntmp-maps-1146) (values (syntmp-gen-append-1073 syntmp-x-1145 syntmp-y-1143) syntmp-maps-1146)))))) syntmp-tmp-1133))) (syntax-dispatch syntmp-tmp-1133 (quote (any . any))))) syntmp-y-1128))) syntmp-tmp-1120) ((lambda (syntmp-tmp-1147) (if syntmp-tmp-1147 (apply (lambda (syntmp-x-1148 syntmp-y-1149) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1148 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-x-1150 syntmp-maps-1151) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1149 syntmp-r-1105 syntmp-maps-1151 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1152 syntmp-maps-1153) (values (syntmp-gen-cons-1072 syntmp-x-1150 syntmp-y-1152) syntmp-maps-1153)))))) syntmp-tmp-1147) ((lambda (syntmp-tmp-1154) (if syntmp-tmp-1154 (apply (lambda (syntmp-e1-1155 syntmp-e2-1156) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 (cons syntmp-e1-1155 syntmp-e2-1156) syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-e-1158 syntmp-maps-1159) (values (syntmp-gen-vector-1074 syntmp-e-1158) syntmp-maps-1159)))) syntmp-tmp-1154) ((lambda (syntmp-_-1160) (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106)) syntmp-tmp-1113))) (syntax-dispatch syntmp-tmp-1113 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1113 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any))))) syntmp-e-1104))))) (lambda (syntmp-e-1161 syntmp-r-1162 syntmp-w-1163 syntmp-s-1164) (let ((syntmp-e-1165 (syntmp-source-wrap-133 syntmp-e-1161 syntmp-w-1163 syntmp-s-1164))) ((lambda (syntmp-tmp-1166) ((lambda (syntmp-tmp-1167) (if syntmp-tmp-1167 (apply (lambda (syntmp-_-1168 syntmp-x-1169) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-e-1165 syntmp-x-1169 syntmp-r-1162 (quote ()) syntmp-ellipsis?-149)) (lambda (syntmp-e-1170 syntmp-maps-1171) (syntmp-regen-1075 syntmp-e-1170)))) syntmp-tmp-1167) ((lambda (syntmp-_-1172) (syntax-error syntmp-e-1165)) syntmp-tmp-1166))) (syntax-dispatch syntmp-tmp-1166 (quote (any any))))) syntmp-e-1165))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1173 syntmp-r-1174 syntmp-w-1175 syntmp-s-1176) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if syntmp-tmp-1178 (apply (lambda (syntmp-_-1179 syntmp-c-1180) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1173 syntmp-w-1175 syntmp-s-1176) syntmp-c-1180 syntmp-r-1174 syntmp-w-1175 (lambda (syntmp-vars-1181 syntmp-body-1182) (syntmp-build-annotated-81 syntmp-s-1176 (list (quote lambda) syntmp-vars-1181 syntmp-body-1182))))) syntmp-tmp-1178) (syntax-error syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-e-1173))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1183 (lambda (syntmp-e-1184 syntmp-r-1185 syntmp-w-1186 syntmp-s-1187 syntmp-constructor-1188 syntmp-ids-1189 syntmp-vals-1190 syntmp-exps-1191) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1189)) (syntax-error syntmp-e-1184 "duplicate bound variable in") (let ((syntmp-labels-1192 (syntmp-gen-labels-110 syntmp-ids-1189)) (syntmp-new-vars-1193 (map syntmp-gen-var-152 syntmp-ids-1189))) (let ((syntmp-nw-1194 (syntmp-make-binding-wrap-121 syntmp-ids-1189 syntmp-labels-1192 syntmp-w-1186)) (syntmp-nr-1195 (syntmp-extend-var-env-99 syntmp-labels-1192 syntmp-new-vars-1193 syntmp-r-1185))) (syntmp-constructor-1188 syntmp-s-1187 syntmp-new-vars-1193 (map (lambda (syntmp-x-1196) (syntmp-chi-140 syntmp-x-1196 syntmp-r-1185 syntmp-w-1186)) syntmp-vals-1190) (syntmp-chi-body-144 syntmp-exps-1191 (syntmp-source-wrap-133 syntmp-e-1184 syntmp-nw-1194 syntmp-s-1187) syntmp-nr-1195 syntmp-nw-1194)))))))) (lambda (syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if syntmp-tmp-1202 (apply (lambda (syntmp-_-1203 syntmp-id-1204 syntmp-val-1205 syntmp-e1-1206 syntmp-e2-1207) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-let-84 syntmp-id-1204 syntmp-val-1205 (cons syntmp-e1-1206 syntmp-e2-1207))) syntmp-tmp-1202) ((lambda (syntmp-tmp-1211) (if (if syntmp-tmp-1211 (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-id?-104 syntmp-f-1213)) syntmp-tmp-1211) #f) (apply (lambda (syntmp-_-1218 syntmp-f-1219 syntmp-id-1220 syntmp-val-1221 syntmp-e1-1222 syntmp-e2-1223) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-named-let-85 (cons syntmp-f-1219 syntmp-id-1220) syntmp-val-1221 (cons syntmp-e1-1222 syntmp-e2-1223))) syntmp-tmp-1211) ((lambda (syntmp-_-1227) (syntax-error (syntmp-source-wrap-133 syntmp-e-1197 syntmp-w-1199 syntmp-s-1200))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1201 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1197)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1228 syntmp-r-1229 syntmp-w-1230 syntmp-s-1231) ((lambda (syntmp-tmp-1232) ((lambda (syntmp-tmp-1233) (if syntmp-tmp-1233 (apply (lambda (syntmp-_-1234 syntmp-id-1235 syntmp-val-1236 syntmp-e1-1237 syntmp-e2-1238) (let ((syntmp-ids-1239 syntmp-id-1235)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1239)) (syntax-error syntmp-e-1228 "duplicate bound variable in") (let ((syntmp-labels-1241 (syntmp-gen-labels-110 syntmp-ids-1239)) (syntmp-new-vars-1242 (map syntmp-gen-var-152 syntmp-ids-1239))) (let ((syntmp-w-1243 (syntmp-make-binding-wrap-121 syntmp-ids-1239 syntmp-labels-1241 syntmp-w-1230)) (syntmp-r-1244 (syntmp-extend-var-env-99 syntmp-labels-1241 syntmp-new-vars-1242 syntmp-r-1229))) (syntmp-build-letrec-86 syntmp-s-1231 syntmp-new-vars-1242 (map (lambda (syntmp-x-1245) (syntmp-chi-140 syntmp-x-1245 syntmp-r-1244 syntmp-w-1243)) syntmp-val-1236) (syntmp-chi-body-144 (cons syntmp-e1-1237 syntmp-e2-1238) (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1243 syntmp-s-1231) syntmp-r-1244 syntmp-w-1243))))))) syntmp-tmp-1233) ((lambda (syntmp-_-1248) (syntax-error (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1230 syntmp-s-1231))) syntmp-tmp-1232))) (syntax-dispatch syntmp-tmp-1232 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1228))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1249 syntmp-r-1250 syntmp-w-1251 syntmp-s-1252) ((lambda (syntmp-tmp-1253) ((lambda (syntmp-tmp-1254) (if (if syntmp-tmp-1254 (apply (lambda (syntmp-_-1255 syntmp-id-1256 syntmp-val-1257) (syntmp-id?-104 syntmp-id-1256)) syntmp-tmp-1254) #f) (apply (lambda (syntmp-_-1258 syntmp-id-1259 syntmp-val-1260) (let ((syntmp-val-1261 (syntmp-chi-140 syntmp-val-1260 syntmp-r-1250 syntmp-w-1251)) (syntmp-n-1262 (syntmp-id-var-name-126 syntmp-id-1259 syntmp-w-1251))) (let ((syntmp-b-1263 (syntmp-lookup-101 syntmp-n-1262 syntmp-r-1250))) (let ((syntmp-t-1264 (syntmp-binding-type-96 syntmp-b-1263))) (if (memv syntmp-t-1264 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1263) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (make-module-ref #f syntmp-n-1262 #f) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1259 syntmp-w-1251) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))))))))) syntmp-tmp-1254) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (apply (lambda (syntmp-_-1266 syntmp-getter-1267 syntmp-arg-1268 syntmp-val-1269) (syntmp-build-annotated-81 syntmp-s-1252 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-getter-1267) syntmp-r-1250 syntmp-w-1251) (map (lambda (syntmp-e-1270) (syntmp-chi-140 syntmp-e-1270 syntmp-r-1250 syntmp-w-1251)) (append syntmp-arg-1268 (list syntmp-val-1269)))))) syntmp-tmp-1265) ((lambda (syntmp-_-1272) (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))) syntmp-tmp-1253))) (syntax-dispatch syntmp-tmp-1253 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1253 (quote (any any any))))) syntmp-e-1249))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1276 (lambda (syntmp-x-1277 syntmp-keys-1278 syntmp-clauses-1279 syntmp-r-1280) (if (null? syntmp-clauses-1279) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1277)) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-exp-1284) (if (and (syntmp-id?-104 syntmp-pat-1283) (andmap (lambda (syntmp-x-1285) (not (syntmp-free-id=?-127 syntmp-pat-1283 syntmp-x-1285))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-keys-1278))) (let ((syntmp-labels-1286 (list (syntmp-gen-label-109))) (syntmp-var-1287 (syntmp-gen-var-152 syntmp-pat-1283))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1287) (syntmp-chi-140 syntmp-exp-1284 (syntmp-extend-env-98 syntmp-labels-1286 (list (cons (quote syntax) (cons syntmp-var-1287 0))) syntmp-r-1280) (syntmp-make-binding-wrap-121 (list syntmp-pat-1283) syntmp-labels-1286 (quote (())))))) syntmp-x-1277))) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1283 #t syntmp-exp-1284))) syntmp-tmp-1282) ((lambda (syntmp-tmp-1288) (if syntmp-tmp-1288 (apply (lambda (syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291)) syntmp-tmp-1288) ((lambda (syntmp-_-1292) (syntax-error (car syntmp-clauses-1279) "invalid syntax-case clause")) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1281 (quote (any any))))) (car syntmp-clauses-1279))))) (syntmp-gen-clause-1275 (lambda (syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296 syntmp-pat-1297 syntmp-fender-1298 syntmp-exp-1299) (call-with-values (lambda () (syntmp-convert-pattern-1273 syntmp-pat-1297 syntmp-keys-1294)) (lambda (syntmp-p-1300 syntmp-pvars-1301) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1301))) (syntax-error syntmp-pat-1297 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1302) (not (syntmp-ellipsis?-149 (car syntmp-x-1302)))) syntmp-pvars-1301)) (syntax-error syntmp-pat-1297 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1303 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1303) (let ((syntmp-y-1304 (syntmp-build-annotated-81 #f syntmp-y-1303))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda () syntmp-y-1304) syntmp-tmp-1306) ((lambda (syntmp-_-1307) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1304 (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-fender-1298 syntmp-y-1304 syntmp-r-1296) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote #(atom #t))))) syntmp-fender-1298) (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-exp-1299 syntmp-y-1304 syntmp-r-1296) (syntmp-gen-syntax-case-1276 syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296)))))) (if (eq? syntmp-p-1300 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1293)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1293 (syntmp-build-data-82 #f syntmp-p-1300))))))))))))) (syntmp-build-dispatch-call-1274 (lambda (syntmp-pvars-1308 syntmp-exp-1309 syntmp-y-1310 syntmp-r-1311) (let ((syntmp-ids-1312 (map car syntmp-pvars-1308)) (syntmp-levels-1313 (map cdr syntmp-pvars-1308))) (let ((syntmp-labels-1314 (syntmp-gen-labels-110 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-152 syntmp-ids-1312))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1315 (syntmp-chi-140 syntmp-exp-1309 (syntmp-extend-env-98 syntmp-labels-1314 (map (lambda (syntmp-var-1316 syntmp-level-1317) (cons (quote syntax) (cons syntmp-var-1316 syntmp-level-1317))) syntmp-new-vars-1315 (map cdr syntmp-pvars-1308)) syntmp-r-1311) (syntmp-make-binding-wrap-121 syntmp-ids-1312 syntmp-labels-1314 (quote (())))))) syntmp-y-1310)))))) (syntmp-convert-pattern-1273 (lambda (syntmp-pattern-1318 syntmp-keys-1319) (let syntmp-cvt-1320 ((syntmp-p-1321 syntmp-pattern-1318) (syntmp-n-1322 0) (syntmp-ids-1323 (quote ()))) (if (syntmp-id?-104 syntmp-p-1321) (if (syntmp-bound-id-member?-131 syntmp-p-1321 syntmp-keys-1319) (values (vector (quote free-id) syntmp-p-1321) syntmp-ids-1323) (values (quote any) (cons (cons syntmp-p-1321 syntmp-n-1322) syntmp-ids-1323))) ((lambda (syntmp-tmp-1324) ((lambda (syntmp-tmp-1325) (if (if syntmp-tmp-1325 (apply (lambda (syntmp-x-1326 syntmp-dots-1327) (syntmp-ellipsis?-149 syntmp-dots-1327)) syntmp-tmp-1325) #f) (apply (lambda (syntmp-x-1328 syntmp-dots-1329) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1328 (syntmp-fx+-72 syntmp-n-1322 1) syntmp-ids-1323)) (lambda (syntmp-p-1330 syntmp-ids-1331) (values (if (eq? syntmp-p-1330 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1330)) syntmp-ids-1331)))) syntmp-tmp-1325) ((lambda (syntmp-tmp-1332) (if syntmp-tmp-1332 (apply (lambda (syntmp-x-1333 syntmp-y-1334) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-y-1334 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-y-1335 syntmp-ids-1336) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1333 syntmp-n-1322 syntmp-ids-1336)) (lambda (syntmp-x-1337 syntmp-ids-1338) (values (cons syntmp-x-1337 syntmp-y-1335) syntmp-ids-1338)))))) syntmp-tmp-1332) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda () (values (quote ()) syntmp-ids-1323)) syntmp-tmp-1339) ((lambda (syntmp-tmp-1340) (if syntmp-tmp-1340 (apply (lambda (syntmp-x-1341) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1341 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-p-1343 syntmp-ids-1344) (values (vector (quote vector) syntmp-p-1343) syntmp-ids-1344)))) syntmp-tmp-1340) ((lambda (syntmp-x-1345) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1321 (quote (())))) syntmp-ids-1323)) syntmp-tmp-1324))) (syntax-dispatch syntmp-tmp-1324 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1324 (quote ()))))) (syntax-dispatch syntmp-tmp-1324 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1324 (quote (any any))))) syntmp-p-1321)))))) (lambda (syntmp-e-1346 syntmp-r-1347 syntmp-w-1348 syntmp-s-1349) (let ((syntmp-e-1350 (syntmp-source-wrap-133 syntmp-e-1346 syntmp-w-1348 syntmp-s-1349))) ((lambda (syntmp-tmp-1351) ((lambda (syntmp-tmp-1352) (if syntmp-tmp-1352 (apply (lambda (syntmp-_-1353 syntmp-val-1354 syntmp-key-1355 syntmp-m-1356) (if (andmap (lambda (syntmp-x-1357) (and (syntmp-id?-104 syntmp-x-1357) (not (syntmp-ellipsis?-149 syntmp-x-1357)))) syntmp-key-1355) (let ((syntmp-x-1359 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1349 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1359) (syntmp-gen-syntax-case-1276 (syntmp-build-annotated-81 #f syntmp-x-1359) syntmp-key-1355 syntmp-m-1356 syntmp-r-1347))) (syntmp-chi-140 syntmp-val-1354 syntmp-r-1347 (quote (())))))) (syntax-error syntmp-e-1350 "invalid literals list in"))) syntmp-tmp-1352) (syntax-error syntmp-tmp-1351))) (syntax-dispatch syntmp-tmp-1351 (quote (any any each-any . each-any))))) syntmp-e-1350))))) (set! sc-expand (let ((syntmp-m-1362 (quote e)) (syntmp-esew-1363 (quote (eval)))) (lambda (syntmp-x-1364) (if (and (pair? syntmp-x-1364) (equal? (car syntmp-x-1364) syntmp-noexpand-71)) (cadr syntmp-x-1364) (syntmp-chi-top-139 syntmp-x-1364 (quote ()) (quote ((top))) syntmp-m-1362 syntmp-esew-1363))))) (set! sc-expand3 (let ((syntmp-m-1365 (quote e)) (syntmp-esew-1366 (quote (eval)))) (lambda (syntmp-x-1368 . syntmp-rest-1367) (if (and (pair? syntmp-x-1368) (equal? (car syntmp-x-1368) syntmp-noexpand-71)) (cadr syntmp-x-1368) (syntmp-chi-top-139 syntmp-x-1368 (quote ()) (quote ((top))) (if (null? syntmp-rest-1367) syntmp-m-1365 (car syntmp-rest-1367)) (if (or (null? syntmp-rest-1367) (null? (cdr syntmp-rest-1367))) syntmp-esew-1366 (cadr syntmp-rest-1367))))))) (set! identifier? (lambda (syntmp-x-1369) (syntmp-nonsymbol-id?-103 syntmp-x-1369))) (set! datum->syntax-object (lambda (syntmp-id-1370 syntmp-datum-1371) (syntmp-make-syntax-object-87 syntmp-datum-1371 (syntmp-syntax-object-wrap-90 syntmp-id-1370) #f))) (set! syntax-object->datum (lambda (syntmp-x-1372) (syntmp-strip-151 syntmp-x-1372 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1373) (begin (let ((syntmp-x-1374 syntmp-ls-1373)) (if (not (list? syntmp-x-1374)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1374))) (map (lambda (syntmp-x-1375) (syntmp-wrap-132 (gensym) (quote ((top))))) syntmp-ls-1373)))) (set! free-identifier=? (lambda (syntmp-x-1376 syntmp-y-1377) (begin (let ((syntmp-x-1378 syntmp-x-1376)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1378)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1378))) (let ((syntmp-x-1379 syntmp-y-1377)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1379)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1379))) (syntmp-free-id=?-127 syntmp-x-1376 syntmp-y-1377)))) (set! bound-identifier=? (lambda (syntmp-x-1380 syntmp-y-1381) (begin (let ((syntmp-x-1382 syntmp-x-1380)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1382)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1382))) (let ((syntmp-x-1383 syntmp-y-1381)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1383)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1383))) (syntmp-bound-id=?-128 syntmp-x-1380 syntmp-y-1381)))) (set! syntax-error (lambda (syntmp-object-1385 . syntmp-messages-1384) (begin (for-each (lambda (syntmp-x-1386) (let ((syntmp-x-1387 syntmp-x-1386)) (if (not (string? syntmp-x-1387)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1387)))) syntmp-messages-1384) (let ((syntmp-message-1388 (if (null? syntmp-messages-1384) "invalid syntax" (apply string-append syntmp-messages-1384)))) (syntmp-error-hook-78 #f syntmp-message-1388 (syntmp-strip-151 syntmp-object-1385 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1389 syntmp-v-1390) (begin (let ((syntmp-x-1391 syntmp-sym-1389)) (if (not (symbol? syntmp-x-1391)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1391))) (let ((syntmp-x-1392 syntmp-v-1390)) (if (not (procedure? syntmp-x-1392)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1392))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1389 syntmp-v-1390)))) (letrec ((syntmp-match-1397 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((not syntmp-r-1401) #f) ((eq? syntmp-p-1399 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1398 syntmp-w-1400) syntmp-r-1401)) ((syntmp-syntax-object?-88 syntmp-e-1398) (syntmp-match*-1396 (let ((syntmp-e-1402 (syntmp-syntax-object-expression-89 syntmp-e-1398))) (if (annotation? syntmp-e-1402) (annotation-expression syntmp-e-1402) syntmp-e-1402)) syntmp-p-1399 (syntmp-join-wraps-123 syntmp-w-1400 (syntmp-syntax-object-wrap-90 syntmp-e-1398)) syntmp-r-1401)) (else (syntmp-match*-1396 (let ((syntmp-e-1403 syntmp-e-1398)) (if (annotation? syntmp-e-1403) (annotation-expression syntmp-e-1403) syntmp-e-1403)) syntmp-p-1399 syntmp-w-1400 syntmp-r-1401))))) (syntmp-match*-1396 (lambda (syntmp-e-1404 syntmp-p-1405 syntmp-w-1406 syntmp-r-1407) (cond ((null? syntmp-p-1405) (and (null? syntmp-e-1404) syntmp-r-1407)) ((pair? syntmp-p-1405) (and (pair? syntmp-e-1404) (syntmp-match-1397 (car syntmp-e-1404) (car syntmp-p-1405) syntmp-w-1406 (syntmp-match-1397 (cdr syntmp-e-1404) (cdr syntmp-p-1405) syntmp-w-1406 syntmp-r-1407)))) ((eq? syntmp-p-1405 (quote each-any)) (let ((syntmp-l-1408 (syntmp-match-each-any-1394 syntmp-e-1404 syntmp-w-1406))) (and syntmp-l-1408 (cons syntmp-l-1408 syntmp-r-1407)))) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1405 0))) (if (memv syntmp-t-1409 (quote (each))) (if (null? syntmp-e-1404) (syntmp-match-empty-1395 (vector-ref syntmp-p-1405 1) syntmp-r-1407) (let ((syntmp-l-1410 (syntmp-match-each-1393 syntmp-e-1404 (vector-ref syntmp-p-1405 1) syntmp-w-1406))) (and syntmp-l-1410 (let syntmp-collect-1411 ((syntmp-l-1412 syntmp-l-1410)) (if (null? (car syntmp-l-1412)) syntmp-r-1407 (cons (map car syntmp-l-1412) (syntmp-collect-1411 (map cdr syntmp-l-1412)))))))) (if (memv syntmp-t-1409 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1404) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1404 syntmp-w-1406) (vector-ref syntmp-p-1405 1)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (atom))) (and (equal? (vector-ref syntmp-p-1405 1) (syntmp-strip-151 syntmp-e-1404 syntmp-w-1406)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (vector))) (and (vector? syntmp-e-1404) (syntmp-match-1397 (vector->list syntmp-e-1404) (vector-ref syntmp-p-1405 1) syntmp-w-1406 syntmp-r-1407))))))))))) (syntmp-match-empty-1395 (lambda (syntmp-p-1413 syntmp-r-1414) (cond ((null? syntmp-p-1413) syntmp-r-1414) ((eq? syntmp-p-1413 (quote any)) (cons (quote ()) syntmp-r-1414)) ((pair? syntmp-p-1413) (syntmp-match-empty-1395 (car syntmp-p-1413) (syntmp-match-empty-1395 (cdr syntmp-p-1413) syntmp-r-1414))) ((eq? syntmp-p-1413 (quote each-any)) (cons (quote ()) syntmp-r-1414)) (else (let ((syntmp-t-1415 (vector-ref syntmp-p-1413 0))) (if (memv syntmp-t-1415 (quote (each))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414) (if (memv syntmp-t-1415 (quote (free-id atom))) syntmp-r-1414 (if (memv syntmp-t-1415 (quote (vector))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414))))))))) (syntmp-match-each-any-1394 (lambda (syntmp-e-1416 syntmp-w-1417) (cond ((annotation? syntmp-e-1416) (syntmp-match-each-any-1394 (annotation-expression syntmp-e-1416) syntmp-w-1417)) ((pair? syntmp-e-1416) (let ((syntmp-l-1418 (syntmp-match-each-any-1394 (cdr syntmp-e-1416) syntmp-w-1417))) (and syntmp-l-1418 (cons (syntmp-wrap-132 (car syntmp-e-1416) syntmp-w-1417) syntmp-l-1418)))) ((null? syntmp-e-1416) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1416) (syntmp-match-each-any-1394 (syntmp-syntax-object-expression-89 syntmp-e-1416) (syntmp-join-wraps-123 syntmp-w-1417 (syntmp-syntax-object-wrap-90 syntmp-e-1416)))) (else #f)))) (syntmp-match-each-1393 (lambda (syntmp-e-1419 syntmp-p-1420 syntmp-w-1421) (cond ((annotation? syntmp-e-1419) (syntmp-match-each-1393 (annotation-expression syntmp-e-1419) syntmp-p-1420 syntmp-w-1421)) ((pair? syntmp-e-1419) (let ((syntmp-first-1422 (syntmp-match-1397 (car syntmp-e-1419) syntmp-p-1420 syntmp-w-1421 (quote ())))) (and syntmp-first-1422 (let ((syntmp-rest-1423 (syntmp-match-each-1393 (cdr syntmp-e-1419) syntmp-p-1420 syntmp-w-1421))) (and syntmp-rest-1423 (cons syntmp-first-1422 syntmp-rest-1423)))))) ((null? syntmp-e-1419) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1419) (syntmp-match-each-1393 (syntmp-syntax-object-expression-89 syntmp-e-1419) syntmp-p-1420 (syntmp-join-wraps-123 syntmp-w-1421 (syntmp-syntax-object-wrap-90 syntmp-e-1419)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1424 syntmp-p-1425) (cond ((eq? syntmp-p-1425 (quote any)) (list syntmp-e-1424)) ((syntmp-syntax-object?-88 syntmp-e-1424) (syntmp-match*-1396 (let ((syntmp-e-1426 (syntmp-syntax-object-expression-89 syntmp-e-1424))) (if (annotation? syntmp-e-1426) (annotation-expression syntmp-e-1426) syntmp-e-1426)) syntmp-p-1425 (syntmp-syntax-object-wrap-90 syntmp-e-1424) (quote ()))) (else (syntmp-match*-1396 (let ((syntmp-e-1427 syntmp-e-1424)) (if (annotation? syntmp-e-1427) (annotation-expression syntmp-e-1427) syntmp-e-1427)) syntmp-p-1425 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-140))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1428) ((lambda (syntmp-tmp-1429) ((lambda (syntmp-tmp-1430) (if syntmp-tmp-1430 (apply (lambda (syntmp-_-1431 syntmp-e1-1432 syntmp-e2-1433) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1432 syntmp-e2-1433))) syntmp-tmp-1430) ((lambda (syntmp-tmp-1435) (if syntmp-tmp-1435 (apply (lambda (syntmp-_-1436 syntmp-out-1437 syntmp-in-1438 syntmp-e1-1439 syntmp-e2-1440) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1438 (quote ()) (list syntmp-out-1437 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1439 syntmp-e2-1440))))) syntmp-tmp-1435) ((lambda (syntmp-tmp-1442) (if syntmp-tmp-1442 (apply (lambda (syntmp-_-1443 syntmp-out-1444 syntmp-in-1445 syntmp-e1-1446 syntmp-e2-1447) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1445) (quote ()) (list syntmp-out-1444 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1446 syntmp-e2-1447))))) syntmp-tmp-1442) (syntax-error syntmp-tmp-1429))) (syntax-dispatch syntmp-tmp-1429 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any () any . each-any))))) syntmp-x-1428))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1469) ((lambda (syntmp-tmp-1470) ((lambda (syntmp-tmp-1471) (if syntmp-tmp-1471 (apply (lambda (syntmp-_-1472 syntmp-k-1473 syntmp-keyword-1474 syntmp-pattern-1475 syntmp-template-1476) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-k-1473 (map (lambda (syntmp-tmp-1479 syntmp-tmp-1478) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1478) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1479))) syntmp-template-1476 syntmp-pattern-1475)))))) syntmp-tmp-1471) (syntax-error syntmp-tmp-1470))) (syntax-dispatch syntmp-tmp-1470 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1469))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1490) ((lambda (syntmp-tmp-1491) ((lambda (syntmp-tmp-1492) (if (if syntmp-tmp-1492 (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (andmap identifier? syntmp-x-1494)) syntmp-tmp-1492) #f) (apply (lambda (syntmp-let*-1499 syntmp-x-1500 syntmp-v-1501 syntmp-e1-1502 syntmp-e2-1503) (let syntmp-f-1504 ((syntmp-bindings-1505 (map list syntmp-x-1500 syntmp-v-1501))) (if (null? syntmp-bindings-1505) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote ()) (cons syntmp-e1-1502 syntmp-e2-1503))) ((lambda (syntmp-tmp-1509) ((lambda (syntmp-tmp-1510) (if syntmp-tmp-1510 (apply (lambda (syntmp-body-1511 syntmp-binding-1512) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list syntmp-binding-1512) syntmp-body-1511)) syntmp-tmp-1510) (syntax-error syntmp-tmp-1509))) (syntax-dispatch syntmp-tmp-1509 (quote (any any))))) (list (syntmp-f-1504 (cdr syntmp-bindings-1505)) (car syntmp-bindings-1505)))))) syntmp-tmp-1492) (syntax-error syntmp-tmp-1491))) (syntax-dispatch syntmp-tmp-1491 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1490))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1532) ((lambda (syntmp-tmp-1533) ((lambda (syntmp-tmp-1534) (if syntmp-tmp-1534 (apply (lambda (syntmp-_-1535 syntmp-var-1536 syntmp-init-1537 syntmp-step-1538 syntmp-e0-1539 syntmp-e1-1540 syntmp-c-1541) ((lambda (syntmp-tmp-1542) ((lambda (syntmp-tmp-1543) (if syntmp-tmp-1543 (apply (lambda (syntmp-step-1544) ((lambda (syntmp-tmp-1545) ((lambda (syntmp-tmp-1546) (if syntmp-tmp-1546 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1539) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1544))))))) syntmp-tmp-1546) ((lambda (syntmp-tmp-1551) (if syntmp-tmp-1551 (apply (lambda (syntmp-e1-1552 syntmp-e2-1553) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1539 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (cons syntmp-e1-1552 syntmp-e2-1553)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1544))))))) syntmp-tmp-1551) (syntax-error syntmp-tmp-1545))) (syntax-dispatch syntmp-tmp-1545 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1545 (quote ())))) syntmp-e1-1540)) syntmp-tmp-1543) (syntax-error syntmp-tmp-1542))) (syntax-dispatch syntmp-tmp-1542 (quote each-any)))) (map (lambda (syntmp-v-1560 syntmp-s-1561) ((lambda (syntmp-tmp-1562) ((lambda (syntmp-tmp-1563) (if syntmp-tmp-1563 (apply (lambda () syntmp-v-1560) syntmp-tmp-1563) ((lambda (syntmp-tmp-1564) (if syntmp-tmp-1564 (apply (lambda (syntmp-e-1565) syntmp-e-1565) syntmp-tmp-1564) ((lambda (syntmp-_-1566) (syntax-error syntmp-orig-x-1532)) syntmp-tmp-1562))) (syntax-dispatch syntmp-tmp-1562 (quote (any)))))) (syntax-dispatch syntmp-tmp-1562 (quote ())))) syntmp-s-1561)) syntmp-var-1536 syntmp-step-1538))) syntmp-tmp-1534) (syntax-error syntmp-tmp-1533))) (syntax-dispatch syntmp-tmp-1533 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1532))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1594 (lambda (syntmp-x-1598 syntmp-y-1599) ((lambda (syntmp-tmp-1600) ((lambda (syntmp-tmp-1601) (if syntmp-tmp-1601 (apply (lambda (syntmp-x-1602 syntmp-y-1603) ((lambda (syntmp-tmp-1604) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-dy-1606) ((lambda (syntmp-tmp-1607) ((lambda (syntmp-tmp-1608) (if syntmp-tmp-1608 (apply (lambda (syntmp-dx-1609) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-dx-1609 syntmp-dy-1606))) syntmp-tmp-1608) ((lambda (syntmp-_-1610) (if (null? syntmp-dy-1606) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1602) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1602 syntmp-y-1603))) syntmp-tmp-1607))) (syntax-dispatch syntmp-tmp-1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-x-1602)) syntmp-tmp-1605) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-stuff-1612) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-x-1602 syntmp-stuff-1612))) syntmp-tmp-1611) ((lambda (syntmp-else-1613) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1602 syntmp-y-1603)) syntmp-tmp-1604))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . any)))))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-y-1603)) syntmp-tmp-1601) (syntax-error syntmp-tmp-1600))) (syntax-dispatch syntmp-tmp-1600 (quote (any any))))) (list syntmp-x-1598 syntmp-y-1599)))) (syntmp-quasiappend-1595 (lambda (syntmp-x-1614 syntmp-y-1615) ((lambda (syntmp-tmp-1616) ((lambda (syntmp-tmp-1617) (if syntmp-tmp-1617 (apply (lambda (syntmp-x-1618 syntmp-y-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda () syntmp-x-1618) syntmp-tmp-1621) ((lambda (syntmp-_-1622) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1618 syntmp-y-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) ()))))) syntmp-y-1619)) syntmp-tmp-1617) (syntax-error syntmp-tmp-1616))) (syntax-dispatch syntmp-tmp-1616 (quote (any any))))) (list syntmp-x-1614 syntmp-y-1615)))) (syntmp-quasivector-1596 (lambda (syntmp-x-1623) ((lambda (syntmp-tmp-1624) ((lambda (syntmp-x-1625) ((lambda (syntmp-tmp-1626) ((lambda (syntmp-tmp-1627) (if syntmp-tmp-1627 (apply (lambda (syntmp-x-1628) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (list->vector syntmp-x-1628))) syntmp-tmp-1627) ((lambda (syntmp-tmp-1630) (if syntmp-tmp-1630 (apply (lambda (syntmp-x-1631) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1631)) syntmp-tmp-1630) ((lambda (syntmp-_-1633) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1625)) syntmp-tmp-1626))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . each-any)))))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) each-any))))) syntmp-x-1625)) syntmp-tmp-1624)) syntmp-x-1623))) (syntmp-quasi-1597 (lambda (syntmp-p-1634 syntmp-lev-1635) ((lambda (syntmp-tmp-1636) ((lambda (syntmp-tmp-1637) (if syntmp-tmp-1637 (apply (lambda (syntmp-p-1638) (if (= syntmp-lev-1635 0) syntmp-p-1638 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1597 (list syntmp-p-1638) (- syntmp-lev-1635 1))))) syntmp-tmp-1637) ((lambda (syntmp-tmp-1639) (if syntmp-tmp-1639 (apply (lambda (syntmp-p-1640 syntmp-q-1641) (if (= syntmp-lev-1635 0) (syntmp-quasiappend-1595 syntmp-p-1640 (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)) (syntmp-quasicons-1594 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1597 (list syntmp-p-1640) (- syntmp-lev-1635 1))) (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)))) syntmp-tmp-1639) ((lambda (syntmp-tmp-1642) (if syntmp-tmp-1642 (apply (lambda (syntmp-p-1643) (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1597 (list syntmp-p-1643) (+ syntmp-lev-1635 1)))) syntmp-tmp-1642) ((lambda (syntmp-tmp-1644) (if syntmp-tmp-1644 (apply (lambda (syntmp-p-1645 syntmp-q-1646) (syntmp-quasicons-1594 (syntmp-quasi-1597 syntmp-p-1645 syntmp-lev-1635) (syntmp-quasi-1597 syntmp-q-1646 syntmp-lev-1635))) syntmp-tmp-1644) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-x-1648) (syntmp-quasivector-1596 (syntmp-quasi-1597 syntmp-x-1648 syntmp-lev-1635))) syntmp-tmp-1647) ((lambda (syntmp-p-1650) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-p-1650)) syntmp-tmp-1636))) (syntax-dispatch syntmp-tmp-1636 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any)))))) (syntax-dispatch syntmp-tmp-1636 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any) . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-p-1634)))) (lambda (syntmp-x-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda (syntmp-_-1654 syntmp-e-1655) (syntmp-quasi-1597 syntmp-e-1655 0)) syntmp-tmp-1653) (syntax-error syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any any))))) syntmp-x-1651)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1715) (letrec ((syntmp-read-file-1716 (lambda (syntmp-fn-1717 syntmp-k-1718) (let ((syntmp-p-1719 (open-input-file syntmp-fn-1717))) (let syntmp-f-1720 ((syntmp-x-1721 (read syntmp-p-1719))) (if (eof-object? syntmp-x-1721) (begin (close-input-port syntmp-p-1719) (quote ())) (cons (datum->syntax-object syntmp-k-1718 syntmp-x-1721) (syntmp-f-1720 (read syntmp-p-1719))))))))) ((lambda (syntmp-tmp-1722) ((lambda (syntmp-tmp-1723) (if syntmp-tmp-1723 (apply (lambda (syntmp-k-1724 syntmp-filename-1725) (let ((syntmp-fn-1726 (syntax-object->datum syntmp-filename-1725))) ((lambda (syntmp-tmp-1727) ((lambda (syntmp-tmp-1728) (if syntmp-tmp-1728 (apply (lambda (syntmp-exp-1729) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-exp-1729)) syntmp-tmp-1728) (syntax-error syntmp-tmp-1727))) (syntax-dispatch syntmp-tmp-1727 (quote each-any)))) (syntmp-read-file-1716 syntmp-fn-1726 syntmp-k-1724)))) syntmp-tmp-1723) (syntax-error syntmp-tmp-1722))) (syntax-dispatch syntmp-tmp-1722 (quote (any any))))) syntmp-x-1715)))) (install-global-transformer (quote unquote) (lambda (syntmp-x-1746) ((lambda (syntmp-tmp-1747) ((lambda (syntmp-tmp-1748) (if syntmp-tmp-1748 (apply (lambda (syntmp-_-1749 syntmp-e-1750) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1750))) syntmp-tmp-1748) (syntax-error syntmp-tmp-1747))) (syntax-dispatch syntmp-tmp-1747 (quote (any any))))) syntmp-x-1746))) (install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1756) ((lambda (syntmp-tmp-1757) ((lambda (syntmp-tmp-1758) (if syntmp-tmp-1758 (apply (lambda (syntmp-_-1759 syntmp-e-1760) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1760))) syntmp-tmp-1758) (syntax-error syntmp-tmp-1757))) (syntax-dispatch syntmp-tmp-1757 (quote (any any))))) syntmp-x-1756))) -(install-global-transformer (quote case) (lambda (syntmp-x-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-tmp-1768) (if syntmp-tmp-1768 (apply (lambda (syntmp-_-1769 syntmp-e-1770 syntmp-m1-1771 syntmp-m2-1772) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-body-1774) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1770)) syntmp-body-1774)) syntmp-tmp-1773)) (let syntmp-f-1775 ((syntmp-clause-1776 syntmp-m1-1771) (syntmp-clauses-1777 syntmp-m2-1772)) (if (null? syntmp-clauses-1777) ((lambda (syntmp-tmp-1779) ((lambda (syntmp-tmp-1780) (if syntmp-tmp-1780 (apply (lambda (syntmp-e1-1781 syntmp-e2-1782) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1781 syntmp-e2-1782))) syntmp-tmp-1780) ((lambda (syntmp-tmp-1784) (if syntmp-tmp-1784 (apply (lambda (syntmp-k-1785 syntmp-e1-1786 syntmp-e2-1787) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1785)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1786 syntmp-e2-1787)))) syntmp-tmp-1784) ((lambda (syntmp-_-1790) (syntax-error syntmp-x-1766)) syntmp-tmp-1779))) (syntax-dispatch syntmp-tmp-1779 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1779 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1776) ((lambda (syntmp-tmp-1791) ((lambda (syntmp-rest-1792) ((lambda (syntmp-tmp-1793) ((lambda (syntmp-tmp-1794) (if syntmp-tmp-1794 (apply (lambda (syntmp-k-1795 syntmp-e1-1796 syntmp-e2-1797) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1795)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1796 syntmp-e2-1797)) syntmp-rest-1792)) syntmp-tmp-1794) ((lambda (syntmp-_-1800) (syntax-error syntmp-x-1766)) syntmp-tmp-1793))) (syntax-dispatch syntmp-tmp-1793 (quote (each-any any . each-any))))) syntmp-clause-1776)) syntmp-tmp-1791)) (syntmp-f-1775 (car syntmp-clauses-1777) (cdr syntmp-clauses-1777))))))) syntmp-tmp-1768) (syntax-error syntmp-tmp-1767))) (syntax-dispatch syntmp-tmp-1767 (quote (any any any . each-any))))) syntmp-x-1766))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1830) ((lambda (syntmp-tmp-1831) ((lambda (syntmp-tmp-1832) (if syntmp-tmp-1832 (apply (lambda (syntmp-_-1833 syntmp-e-1834) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1834)) (list (cons syntmp-_-1833 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1834 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1832) (syntax-error syntmp-tmp-1831))) (syntax-dispatch syntmp-tmp-1831 (quote (any any))))) syntmp-x-1830))) +(install-global-transformer (quote case) (lambda (syntmp-x-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-tmp-1768) (if syntmp-tmp-1768 (apply (lambda (syntmp-_-1769 syntmp-e-1770 syntmp-m1-1771 syntmp-m2-1772) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-body-1774) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1770)) syntmp-body-1774)) syntmp-tmp-1773)) (let syntmp-f-1775 ((syntmp-clause-1776 syntmp-m1-1771) (syntmp-clauses-1777 syntmp-m2-1772)) (if (null? syntmp-clauses-1777) ((lambda (syntmp-tmp-1779) ((lambda (syntmp-tmp-1780) (if syntmp-tmp-1780 (apply (lambda (syntmp-e1-1781 syntmp-e2-1782) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1781 syntmp-e2-1782))) syntmp-tmp-1780) ((lambda (syntmp-tmp-1784) (if syntmp-tmp-1784 (apply (lambda (syntmp-k-1785 syntmp-e1-1786 syntmp-e2-1787) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1785)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1786 syntmp-e2-1787)))) syntmp-tmp-1784) ((lambda (syntmp-_-1790) (syntax-error syntmp-x-1766)) syntmp-tmp-1779))) (syntax-dispatch syntmp-tmp-1779 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1779 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) any . each-any))))) syntmp-clause-1776) ((lambda (syntmp-tmp-1791) ((lambda (syntmp-rest-1792) ((lambda (syntmp-tmp-1793) ((lambda (syntmp-tmp-1794) (if syntmp-tmp-1794 (apply (lambda (syntmp-k-1795 syntmp-e1-1796 syntmp-e2-1797) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1795)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1796 syntmp-e2-1797)) syntmp-rest-1792)) syntmp-tmp-1794) ((lambda (syntmp-_-1800) (syntax-error syntmp-x-1766)) syntmp-tmp-1793))) (syntax-dispatch syntmp-tmp-1793 (quote (each-any any . each-any))))) syntmp-clause-1776)) syntmp-tmp-1791)) (syntmp-f-1775 (car syntmp-clauses-1777) (cdr syntmp-clauses-1777))))))) syntmp-tmp-1768) (syntax-error syntmp-tmp-1767))) (syntax-dispatch syntmp-tmp-1767 (quote (any any any . each-any))))) syntmp-x-1766))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1830) ((lambda (syntmp-tmp-1831) ((lambda (syntmp-tmp-1832) (if syntmp-tmp-1832 (apply (lambda (syntmp-_-1833 syntmp-e-1834) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1834)) (list (cons syntmp-_-1833 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e-1834 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))))))))) syntmp-tmp-1832) (syntax-error syntmp-tmp-1831))) (syntax-dispatch syntmp-tmp-1831 (quote (any any))))) syntmp-x-1830))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 3650aacbd..7d00d7197 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -432,26 +432,7 @@ (syntax-rules () ((_ src id) (build-annotated src (gensym (symbol->string id)))))) -;; (define-structure (syntax-object expression wrap module)) - -(define (make-syntax-object exp wrap . mod) - (vector 'syntax-object exp wrap (if (null? mod) #f (car mod)))) - -(define (syntax-object? x) - (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) 'syntax-object))) - -(define (syntax-object-expression x) - (vector-ref x 1)) -(define (syntax-object-wrap x) - (vector-ref x 2)) -(define (syntax-object-module x) - (vector-ref x 3)) -(define (set-syntax-object-expression! x y) - (vector-set! x 1 y)) -(define (set-syntax-object-wrap! x y) - (vector-set! x 2 y)) -(define (set-syntax-object-module! x y) - (vector-set! x 3 y)) +(define-structure (syntax-object expression wrap module)) (define-syntax unannotate (syntax-rules () @@ -857,9 +838,10 @@ ((syntax-object? x) (make-syntax-object (syntax-object-expression x) - (join-wraps w (syntax-object-wrap x)))) + (join-wraps w (syntax-object-wrap x)) + (syntax-object-module x))) ((null? x) x) - (else (make-syntax-object x w))))) + (else (make-syntax-object x w #f))))) (define source-wrap (lambda (x w s) @@ -1159,7 +1141,8 @@ (make-wrap (cons m ms) (if rib (cons rib (cons 'shift s)) - (cons 'shift s)))))))) + (cons 'shift s)))) + (syntax-object-module x))))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -1902,7 +1885,7 @@ (set! datum->syntax-object (lambda (id datum) - (make-syntax-object datum (syntax-object-wrap id)))) + (make-syntax-object datum (syntax-object-wrap id) #f))) (set! syntax-object->datum ; accepts any object, since syntax objects may consist partially From 4e237f1460c06c8e13dd2db4a2c690342a532664 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 29 Mar 2009 17:15:25 -0700 Subject: [PATCH 033/375] thread the module through syntax-case's expansion * libguile/debug.h: * libguile/debug.c (scm_procedure_module): New procedure, returns the module that was current when the given procedure was defined. Used by syncase to scope free identifiers. * module/ice-9/psyntax-pp.scm: Recompiled. * module/ice-9/psyntax.scm: Thread the module through the syntax expansion. This is harder than it would appear because in many places the different components of syntax objects are destructured. * module/ice-9/syncase.scm (guile-macro): Adapt to new signature for syntax transformer functions. --- libguile/debug.c | 31 +++ libguile/debug.h | 1 + module/ice-9/psyntax-pp.scm | 22 +- module/ice-9/psyntax.scm | 426 ++++++++++++++++++++---------------- module/ice-9/syncase.scm | 8 +- 5 files changed, 279 insertions(+), 209 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index 20c8d4e6b..fe54b64df 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -400,6 +400,37 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0, + (SCM proc), + "Return the module that was current when this procedure was defined.\n" + "Free variables in this procedure are resolved relative to the\n" + "procedure's module.") +#define FUNC_NAME s_scm_procedure_module +{ + SCM_VALIDATE_PROC (SCM_ARG1, proc); + + if (scm_is_true (scm_program_p (proc))) + return scm_program_module (proc); + else + { + SCM env = scm_procedure_environment (proc); + + if (scm_is_null (env)) + return SCM_BOOL_F; + else + { + for (; !scm_is_null (scm_cdr (env)); env = scm_cdr (env)) + ; + if (SCM_EVAL_CLOSURE_P (scm_car (env))) + return SCM_PACK (SCM_SMOB_DATA (scm_car (env))); + else + return SCM_BOOL_F; + } + } +} +#undef FUNC_NAME + + /* Eval in a local environment. We would like to have the ability to diff --git a/libguile/debug.h b/libguile/debug.h index 4e94b3c15..4d16fd83a 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -140,6 +140,7 @@ SCM_API SCM scm_local_eval (SCM exp, SCM env); SCM_API SCM scm_reverse_lookup (SCM env, SCM data); SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk); SCM_API SCM scm_procedure_environment (SCM proc); +SCM_API SCM scm_procedure_module (SCM proc); SCM_API SCM scm_procedure_source (SCM proc); SCM_API SCM scm_procedure_name (SCM proc); SCM_API SCM scm_memoized_environment (SCM m); diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 21f93f1da..0d560bb92 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-538) (let syntmp-lvl-539 ((syntmp-vars-540 syntmp-vars-538) (syntmp-ls-541 (quote ())) (syntmp-w-542 (quote (())))) (cond ((pair? syntmp-vars-540) (syntmp-lvl-539 (cdr syntmp-vars-540) (cons (syntmp-wrap-132 (car syntmp-vars-540) syntmp-w-542) syntmp-ls-541) syntmp-w-542)) ((syntmp-id?-104 syntmp-vars-540) (cons (syntmp-wrap-132 syntmp-vars-540 syntmp-w-542) syntmp-ls-541)) ((null? syntmp-vars-540) syntmp-ls-541) ((syntmp-syntax-object?-88 syntmp-vars-540) (syntmp-lvl-539 (syntmp-syntax-object-expression-89 syntmp-vars-540) syntmp-ls-541 (syntmp-join-wraps-123 syntmp-w-542 (syntmp-syntax-object-wrap-90 syntmp-vars-540)))) ((annotation? syntmp-vars-540) (syntmp-lvl-539 (annotation-expression syntmp-vars-540) syntmp-ls-541 syntmp-w-542)) (else (cons syntmp-vars-540 syntmp-ls-541)))))) (syntmp-gen-var-152 (lambda (syntmp-id-543) (let ((syntmp-id-544 (if (syntmp-syntax-object?-88 syntmp-id-543) (syntmp-syntax-object-expression-89 syntmp-id-543) syntmp-id-543))) (if (annotation? syntmp-id-544) (syntmp-build-annotated-81 (annotation-source syntmp-id-544) (gensym (symbol->string (annotation-expression syntmp-id-544)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-544))))))) (syntmp-strip-151 (lambda (syntmp-x-545 syntmp-w-546) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-546)) (if (or (annotation? syntmp-x-545) (and (pair? syntmp-x-545) (annotation? (car syntmp-x-545)))) (syntmp-strip-annotation-150 syntmp-x-545 #f) syntmp-x-545) (let syntmp-f-547 ((syntmp-x-548 syntmp-x-545)) (cond ((syntmp-syntax-object?-88 syntmp-x-548) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-548) (syntmp-syntax-object-wrap-90 syntmp-x-548))) ((pair? syntmp-x-548) (let ((syntmp-a-549 (syntmp-f-547 (car syntmp-x-548))) (syntmp-d-550 (syntmp-f-547 (cdr syntmp-x-548)))) (if (and (eq? syntmp-a-549 (car syntmp-x-548)) (eq? syntmp-d-550 (cdr syntmp-x-548))) syntmp-x-548 (cons syntmp-a-549 syntmp-d-550)))) ((vector? syntmp-x-548) (let ((syntmp-old-551 (vector->list syntmp-x-548))) (let ((syntmp-new-552 (map syntmp-f-547 syntmp-old-551))) (if (andmap eq? syntmp-old-551 syntmp-new-552) syntmp-x-548 (list->vector syntmp-new-552))))) (else syntmp-x-548)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-553 syntmp-parent-554) (cond ((pair? syntmp-x-553) (let ((syntmp-new-555 (cons #f #f))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-555)) (set-car! syntmp-new-555 (syntmp-strip-annotation-150 (car syntmp-x-553) #f)) (set-cdr! syntmp-new-555 (syntmp-strip-annotation-150 (cdr syntmp-x-553) #f)) syntmp-new-555))) ((annotation? syntmp-x-553) (or (annotation-stripped syntmp-x-553) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-553) syntmp-x-553))) ((vector? syntmp-x-553) (let ((syntmp-new-556 (make-vector (vector-length syntmp-x-553)))) (begin (if syntmp-parent-554 (set-annotation-stripped! syntmp-parent-554 syntmp-new-556)) (let syntmp-loop-557 ((syntmp-i-558 (- (vector-length syntmp-x-553) 1))) (unless (syntmp-fx<-75 syntmp-i-558 0) (vector-set! syntmp-new-556 syntmp-i-558 (syntmp-strip-annotation-150 (vector-ref syntmp-x-553 syntmp-i-558) #f)) (syntmp-loop-557 (syntmp-fx--73 syntmp-i-558 1)))) syntmp-new-556))) (else syntmp-x-553)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-559) (and (syntmp-nonsymbol-id?-103 syntmp-x-559) (syntmp-free-id=?-127 syntmp-x-559 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-560) (let ((syntmp-p-561 (syntmp-local-eval-hook-77 syntmp-expanded-560))) (if (procedure? syntmp-p-561) syntmp-p-561 (syntax-error syntmp-p-561 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-562 syntmp-e-563 syntmp-r-564 syntmp-w-565 syntmp-s-566 syntmp-k-567) ((lambda (syntmp-tmp-568) ((lambda (syntmp-tmp-569) (if syntmp-tmp-569 (apply (lambda (syntmp-_-570 syntmp-id-571 syntmp-val-572 syntmp-e1-573 syntmp-e2-574) (let ((syntmp-ids-575 syntmp-id-571)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-575)) (syntax-error syntmp-e-563 "duplicate bound keyword in") (let ((syntmp-labels-577 (syntmp-gen-labels-110 syntmp-ids-575))) (let ((syntmp-new-w-578 (syntmp-make-binding-wrap-121 syntmp-ids-575 syntmp-labels-577 syntmp-w-565))) (syntmp-k-567 (cons syntmp-e1-573 syntmp-e2-574) (syntmp-extend-env-98 syntmp-labels-577 (let ((syntmp-w-580 (if syntmp-rec?-562 syntmp-new-w-578 syntmp-w-565)) (syntmp-trans-r-581 (syntmp-macros-only-env-100 syntmp-r-564))) (map (lambda (syntmp-x-582) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-582 syntmp-trans-r-581 syntmp-w-580)))) syntmp-val-572)) syntmp-r-564) syntmp-new-w-578 syntmp-s-566)))))) syntmp-tmp-569) ((lambda (syntmp-_-584) (syntax-error (syntmp-source-wrap-133 syntmp-e-563 syntmp-w-565 syntmp-s-566))) syntmp-tmp-568))) (syntax-dispatch syntmp-tmp-568 (quote (any #(each (any any)) any . each-any))))) syntmp-e-563))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-585 syntmp-c-586 syntmp-r-587 syntmp-w-588 syntmp-k-589) ((lambda (syntmp-tmp-590) ((lambda (syntmp-tmp-591) (if syntmp-tmp-591 (apply (lambda (syntmp-id-592 syntmp-e1-593 syntmp-e2-594) (let ((syntmp-ids-595 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-595)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-597 (syntmp-gen-labels-110 syntmp-ids-595)) (syntmp-new-vars-598 (map syntmp-gen-var-152 syntmp-ids-595))) (syntmp-k-589 syntmp-new-vars-598 (syntmp-chi-body-144 (cons syntmp-e1-593 syntmp-e2-594) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-597 syntmp-new-vars-598 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-ids-595 syntmp-labels-597 syntmp-w-588))))))) syntmp-tmp-591) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-ids-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-old-ids-604 (syntmp-lambda-var-list-153 syntmp-ids-601))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-604)) (syntax-error syntmp-e-585 "invalid parameter list in") (let ((syntmp-labels-605 (syntmp-gen-labels-110 syntmp-old-ids-604)) (syntmp-new-vars-606 (map syntmp-gen-var-152 syntmp-old-ids-604))) (syntmp-k-589 (let syntmp-f-607 ((syntmp-ls1-608 (cdr syntmp-new-vars-606)) (syntmp-ls2-609 (car syntmp-new-vars-606))) (if (null? syntmp-ls1-608) syntmp-ls2-609 (syntmp-f-607 (cdr syntmp-ls1-608) (cons (car syntmp-ls1-608) syntmp-ls2-609)))) (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-585 (syntmp-extend-var-env-99 syntmp-labels-605 syntmp-new-vars-606 syntmp-r-587) (syntmp-make-binding-wrap-121 syntmp-old-ids-604 syntmp-labels-605 syntmp-w-588))))))) syntmp-tmp-600) ((lambda (syntmp-_-611) (syntax-error syntmp-e-585)) syntmp-tmp-590))) (syntax-dispatch syntmp-tmp-590 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-590 (quote (each-any any . each-any))))) syntmp-c-586))) (syntmp-chi-body-144 (lambda (syntmp-body-612 syntmp-outer-form-613 syntmp-r-614 syntmp-w-615) (let ((syntmp-r-616 (cons (quote ("placeholder" placeholder)) syntmp-r-614))) (let ((syntmp-ribcage-617 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-618 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-615) (cons syntmp-ribcage-617 (syntmp-wrap-subst-108 syntmp-w-615))))) (let syntmp-parse-619 ((syntmp-body-620 (map (lambda (syntmp-x-626) (cons syntmp-r-616 (syntmp-wrap-132 syntmp-x-626 syntmp-w-618))) syntmp-body-612)) (syntmp-ids-621 (quote ())) (syntmp-labels-622 (quote ())) (syntmp-vars-623 (quote ())) (syntmp-vals-624 (quote ())) (syntmp-bindings-625 (quote ()))) (if (null? syntmp-body-620) (syntax-error syntmp-outer-form-613 "no expressions in body") (let ((syntmp-e-627 (cdar syntmp-body-620)) (syntmp-er-628 (caar syntmp-body-620))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-627 syntmp-er-628 (quote (())) #f syntmp-ribcage-617)) (lambda (syntmp-type-629 syntmp-value-630 syntmp-e-631 syntmp-w-632 syntmp-s-633) (let ((syntmp-t-634 syntmp-type-629)) (if (memv syntmp-t-634 (quote (define-form))) (let ((syntmp-id-635 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-636 (syntmp-gen-label-109))) (let ((syntmp-var-637 (syntmp-gen-var-152 syntmp-id-635))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-635 syntmp-label-636) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-635 syntmp-ids-621) (cons syntmp-label-636 syntmp-labels-622) (cons syntmp-var-637 syntmp-vars-623) (cons (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632)) syntmp-vals-624) (cons (cons (quote lexical) syntmp-var-637) syntmp-bindings-625))))) (if (memv syntmp-t-634 (quote (define-syntax-form))) (let ((syntmp-id-638 (syntmp-wrap-132 syntmp-value-630 syntmp-w-632)) (syntmp-label-639 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-617 syntmp-id-638 syntmp-label-639) (syntmp-parse-619 (cdr syntmp-body-620) (cons syntmp-id-638 syntmp-ids-621) (cons syntmp-label-639 syntmp-labels-622) syntmp-vars-623 syntmp-vals-624 (cons (cons (quote macro) (cons syntmp-er-628 (syntmp-wrap-132 syntmp-e-631 syntmp-w-632))) syntmp-bindings-625)))) (if (memv syntmp-t-634 (quote (begin-form))) ((lambda (syntmp-tmp-640) ((lambda (syntmp-tmp-641) (if syntmp-tmp-641 (apply (lambda (syntmp-_-642 syntmp-e1-643) (syntmp-parse-619 (let syntmp-f-644 ((syntmp-forms-645 syntmp-e1-643)) (if (null? syntmp-forms-645) (cdr syntmp-body-620) (cons (cons syntmp-er-628 (syntmp-wrap-132 (car syntmp-forms-645) syntmp-w-632)) (syntmp-f-644 (cdr syntmp-forms-645))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625)) syntmp-tmp-641) (syntax-error syntmp-tmp-640))) (syntax-dispatch syntmp-tmp-640 (quote (any . each-any))))) syntmp-e-631) (if (memv syntmp-t-634 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-630 syntmp-e-631 syntmp-er-628 syntmp-w-632 syntmp-s-633 (lambda (syntmp-forms-647 syntmp-er-648 syntmp-w-649 syntmp-s-650) (syntmp-parse-619 (let syntmp-f-651 ((syntmp-forms-652 syntmp-forms-647)) (if (null? syntmp-forms-652) (cdr syntmp-body-620) (cons (cons syntmp-er-648 (syntmp-wrap-132 (car syntmp-forms-652) syntmp-w-649)) (syntmp-f-651 (cdr syntmp-forms-652))))) syntmp-ids-621 syntmp-labels-622 syntmp-vars-623 syntmp-vals-624 syntmp-bindings-625))) (if (null? syntmp-ids-621) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-653) (syntmp-chi-140 (cdr syntmp-x-653) (car syntmp-x-653) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-621)) (syntax-error syntmp-outer-form-613 "invalid or duplicate identifier in definition")) (let syntmp-loop-654 ((syntmp-bs-655 syntmp-bindings-625) (syntmp-er-cache-656 #f) (syntmp-r-cache-657 #f)) (if (not (null? syntmp-bs-655)) (let ((syntmp-b-658 (car syntmp-bs-655))) (if (eq? (car syntmp-b-658) (quote macro)) (let ((syntmp-er-659 (cadr syntmp-b-658))) (let ((syntmp-r-cache-660 (if (eq? syntmp-er-659 syntmp-er-cache-656) syntmp-r-cache-657 (syntmp-macros-only-env-100 syntmp-er-659)))) (begin (set-cdr! syntmp-b-658 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-658) syntmp-r-cache-660 (quote (()))))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-659 syntmp-r-cache-660)))) (syntmp-loop-654 (cdr syntmp-bs-655) syntmp-er-cache-656 syntmp-r-cache-657))))) (set-cdr! syntmp-r-616 (syntmp-extend-env-98 syntmp-labels-622 syntmp-bindings-625 (cdr syntmp-r-616))) (syntmp-build-letrec-86 #f syntmp-vars-623 (map (lambda (syntmp-x-661) (syntmp-chi-140 (cdr syntmp-x-661) (car syntmp-x-661) (quote (())))) syntmp-vals-624) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-662) (syntmp-chi-140 (cdr syntmp-x-662) (car syntmp-x-662) (quote (())))) (cons (cons syntmp-er-628 (syntmp-source-wrap-133 syntmp-e-631 syntmp-w-632 syntmp-s-633)) (cdr syntmp-body-620)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-663 syntmp-e-664 syntmp-r-665 syntmp-w-666 syntmp-rib-667) (letrec ((syntmp-rebuild-macro-output-668 (lambda (syntmp-x-669 syntmp-m-670) (cond ((pair? syntmp-x-669) (cons (syntmp-rebuild-macro-output-668 (car syntmp-x-669) syntmp-m-670) (syntmp-rebuild-macro-output-668 (cdr syntmp-x-669) syntmp-m-670))) ((syntmp-syntax-object?-88 syntmp-x-669) (let ((syntmp-w-671 (syntmp-syntax-object-wrap-90 syntmp-x-669))) (let ((syntmp-ms-672 (syntmp-wrap-marks-107 syntmp-w-671)) (syntmp-s-673 (syntmp-wrap-subst-108 syntmp-w-671))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-669) (if (and (pair? syntmp-ms-672) (eq? (car syntmp-ms-672) #f)) (syntmp-make-wrap-106 (cdr syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cdr syntmp-s-673)) (cdr syntmp-s-673))) (syntmp-make-wrap-106 (cons syntmp-m-670 syntmp-ms-672) (if syntmp-rib-667 (cons syntmp-rib-667 (cons (quote shift) syntmp-s-673)) (cons (quote shift) syntmp-s-673)))) (syntmp-syntax-object-module-91 syntmp-x-669))))) ((vector? syntmp-x-669) (let ((syntmp-n-674 (vector-length syntmp-x-669))) (let ((syntmp-v-675 (make-vector syntmp-n-674))) (let syntmp-doloop-676 ((syntmp-i-677 0)) (if (syntmp-fx=-74 syntmp-i-677 syntmp-n-674) syntmp-v-675 (begin (vector-set! syntmp-v-675 syntmp-i-677 (syntmp-rebuild-macro-output-668 (vector-ref syntmp-x-669 syntmp-i-677) syntmp-m-670)) (syntmp-doloop-676 (syntmp-fx+-72 syntmp-i-677 1)))))))) ((symbol? syntmp-x-669) (syntax-error syntmp-x-669 "encountered raw symbol in macro output")) (else syntmp-x-669))))) (syntmp-rebuild-macro-output-668 (syntmp-p-663 (syntmp-wrap-132 syntmp-e-664 (syntmp-anti-mark-119 syntmp-w-666))) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-678 syntmp-e-679 syntmp-r-680 syntmp-w-681 syntmp-s-682) ((lambda (syntmp-tmp-683) ((lambda (syntmp-tmp-684) (if syntmp-tmp-684 (apply (lambda (syntmp-e0-685 syntmp-e1-686) (syntmp-build-annotated-81 syntmp-s-682 (cons syntmp-x-678 (map (lambda (syntmp-e-687) (syntmp-chi-140 syntmp-e-687 syntmp-r-680 syntmp-w-681)) syntmp-e1-686)))) syntmp-tmp-684) (syntax-error syntmp-tmp-683))) (syntax-dispatch syntmp-tmp-683 (quote (any . each-any))))) syntmp-e-679))) (syntmp-chi-expr-141 (lambda (syntmp-type-689 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (let ((syntmp-t-695 syntmp-type-689)) (if (memv syntmp-t-695 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-694 syntmp-value-690) (if (memv syntmp-t-695 (quote (core external-macro))) (syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) syntmp-value-690) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-691)) (make-module-ref #f syntmp-value-690 #f)) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (constant))) (syntmp-build-data-82 syntmp-s-694 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) (quote (())))) (if (memv syntmp-t-695 (quote (global))) (syntmp-build-annotated-81 syntmp-s-694 (make-module-ref #f syntmp-value-690 #f)) (if (memv syntmp-t-695 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-691) syntmp-r-692 syntmp-w-693) syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694) (if (memv syntmp-t-695 (quote (begin-form))) ((lambda (syntmp-tmp-696) ((lambda (syntmp-tmp-697) (if syntmp-tmp-697 (apply (lambda (syntmp-_-698 syntmp-e1-699 syntmp-e2-700) (syntmp-chi-sequence-134 (cons syntmp-e1-699 syntmp-e2-700) syntmp-r-692 syntmp-w-693 syntmp-s-694)) syntmp-tmp-697) (syntax-error syntmp-tmp-696))) (syntax-dispatch syntmp-tmp-696 (quote (any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-690 syntmp-e-691 syntmp-r-692 syntmp-w-693 syntmp-s-694 syntmp-chi-sequence-134) (if (memv syntmp-t-695 (quote (eval-when-form))) ((lambda (syntmp-tmp-702) ((lambda (syntmp-tmp-703) (if syntmp-tmp-703 (apply (lambda (syntmp-_-704 syntmp-x-705 syntmp-e1-706 syntmp-e2-707) (let ((syntmp-when-list-708 (syntmp-chi-when-list-137 syntmp-e-691 syntmp-x-705 syntmp-w-693))) (if (memq (quote eval) syntmp-when-list-708) (syntmp-chi-sequence-134 (cons syntmp-e1-706 syntmp-e2-707) syntmp-r-692 syntmp-w-693 syntmp-s-694) (syntmp-chi-void-148)))) syntmp-tmp-703) (syntax-error syntmp-tmp-702))) (syntax-dispatch syntmp-tmp-702 (quote (any each-any any . each-any))))) syntmp-e-691) (if (memv syntmp-t-695 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-690 syntmp-w-693) "invalid context for definition of") (if (memv syntmp-t-695 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to pattern variable outside syntax form") (if (memv syntmp-t-695 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-691 syntmp-w-693 syntmp-s-694)))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-711 syntmp-r-712 syntmp-w-713) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-711 syntmp-r-712 syntmp-w-713 #f #f)) (lambda (syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-w-717 syntmp-s-718) (syntmp-chi-expr-141 syntmp-type-714 syntmp-value-715 syntmp-e-716 syntmp-r-712 syntmp-w-717 syntmp-s-718))))) (syntmp-chi-top-139 (lambda (syntmp-e-719 syntmp-r-720 syntmp-w-721 syntmp-m-722 syntmp-esew-723) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-719 syntmp-r-720 syntmp-w-721 #f #f)) (lambda (syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-w-739 syntmp-s-740) (let ((syntmp-t-741 syntmp-type-736)) (if (memv syntmp-t-741 (quote (begin-form))) ((lambda (syntmp-tmp-742) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744) (syntmp-chi-void-148)) syntmp-tmp-743) ((lambda (syntmp-tmp-745) (if syntmp-tmp-745 (apply (lambda (syntmp-_-746 syntmp-e1-747 syntmp-e2-748) (syntmp-chi-top-sequence-135 (cons syntmp-e1-747 syntmp-e2-748) syntmp-r-720 syntmp-w-739 syntmp-s-740 syntmp-m-722 syntmp-esew-723)) syntmp-tmp-745) (syntax-error syntmp-tmp-742))) (syntax-dispatch syntmp-tmp-742 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-742 (quote (any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740 (lambda (syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753) (syntmp-chi-top-sequence-135 syntmp-body-750 syntmp-r-751 syntmp-w-752 syntmp-s-753 syntmp-m-722 syntmp-esew-723))) (if (memv syntmp-t-741 (quote (eval-when-form))) ((lambda (syntmp-tmp-754) ((lambda (syntmp-tmp-755) (if syntmp-tmp-755 (apply (lambda (syntmp-_-756 syntmp-x-757 syntmp-e1-758 syntmp-e2-759) (let ((syntmp-when-list-760 (syntmp-chi-when-list-137 syntmp-e-738 syntmp-x-757 syntmp-w-739)) (syntmp-body-761 (cons syntmp-e1-758 syntmp-e2-759))) (cond ((eq? syntmp-m-722 (quote e)) (if (memq (quote eval) syntmp-when-list-760) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval))) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-760) (if (or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c&e) (quote (compile load))) (if (memq syntmp-m-722 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote c) (quote (load))) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-760) (and (eq? syntmp-m-722 (quote c&e)) (memq (quote eval) syntmp-when-list-760))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-761 syntmp-r-720 syntmp-w-739 syntmp-s-740 (quote e) (quote (eval)))) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-755) (syntax-error syntmp-tmp-754))) (syntax-dispatch syntmp-tmp-754 (quote (any each-any any . each-any))))) syntmp-e-738) (if (memv syntmp-t-741 (quote (define-syntax-form))) (let ((syntmp-n-764 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739)) (syntmp-r-765 (syntmp-macros-only-env-100 syntmp-r-720))) (let ((syntmp-t-766 syntmp-m-722)) (if (memv syntmp-t-766 (quote (c))) (if (memq (quote compile) syntmp-esew-723) (let ((syntmp-e-767 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-767) (if (memq (quote load) syntmp-esew-723) syntmp-e-767 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-723) (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)) (syntmp-chi-void-148))) (if (memv syntmp-t-766 (quote (c&e))) (let ((syntmp-e-768 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-768) syntmp-e-768)) (begin (if (memq (quote eval) syntmp-esew-723) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-764 (syntmp-chi-140 syntmp-e-738 syntmp-r-765 syntmp-w-739)))) (syntmp-chi-void-148)))))) (if (memv syntmp-t-741 (quote (define-form))) (let ((syntmp-n-769 (syntmp-id-var-name-126 syntmp-value-737 syntmp-w-739))) (let ((syntmp-type-770 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-769 syntmp-r-720)))) (let ((syntmp-t-771 syntmp-type-770)) (if (memv syntmp-t-771 (quote (global))) (let ((syntmp-x-772 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)) (if (memv syntmp-t-771 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "identifier out of context") (if (eq? syntmp-type-770 (quote external-macro)) (let ((syntmp-x-773 (syntmp-build-annotated-81 syntmp-s-740 (list (quote define) syntmp-n-769 (syntmp-chi-140 syntmp-e-738 syntmp-r-720 syntmp-w-739))))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-773)) syntmp-x-773)) (syntax-error (syntmp-wrap-132 syntmp-value-737 syntmp-w-739) "cannot define keyword at top level"))))))) (let ((syntmp-x-774 (syntmp-chi-expr-141 syntmp-type-736 syntmp-value-737 syntmp-e-738 syntmp-r-720 syntmp-w-739 syntmp-s-740))) (begin (if (eq? syntmp-m-722 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-774)) syntmp-x-774)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-s-778 syntmp-rib-779) (cond ((symbol? syntmp-e-775) (let ((syntmp-n-780 (syntmp-id-var-name-126 syntmp-e-775 syntmp-w-777))) (let ((syntmp-b-781 (syntmp-lookup-101 syntmp-n-780 syntmp-r-776))) (let ((syntmp-type-782 (syntmp-binding-type-96 syntmp-b-781))) (let ((syntmp-t-783 syntmp-type-782)) (if (memv syntmp-t-783 (quote (lexical))) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (global))) (values syntmp-type-782 syntmp-n-780 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-783 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (values syntmp-type-782 (syntmp-binding-value-97 syntmp-b-781) syntmp-e-775 syntmp-w-777 syntmp-s-778))))))))) ((pair? syntmp-e-775) (let ((syntmp-first-784 (car syntmp-e-775))) (if (syntmp-id?-104 syntmp-first-784) (let ((syntmp-n-785 (syntmp-id-var-name-126 syntmp-first-784 syntmp-w-777))) (let ((syntmp-b-786 (syntmp-lookup-101 syntmp-n-785 syntmp-r-776))) (let ((syntmp-type-787 (syntmp-binding-type-96 syntmp-b-786))) (let ((syntmp-t-788 syntmp-type-787)) (if (memv syntmp-t-788 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (global))) (values (quote global-call) syntmp-n-785 syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-r-776 syntmp-w-777 syntmp-rib-779) syntmp-r-776 (quote (())) syntmp-s-778 syntmp-rib-779) (if (memv syntmp-t-788 (quote (core external-macro))) (values syntmp-type-787 (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-786) syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (begin))) (values (quote begin-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-775 syntmp-w-777 syntmp-s-778) (if (memv syntmp-t-788 (quote (define))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-name-792 syntmp-val-793) (syntmp-id?-104 syntmp-name-792)) syntmp-tmp-790) #f) (apply (lambda (syntmp-_-794 syntmp-name-795 syntmp-val-796) (values (quote define-form) syntmp-name-795 syntmp-val-796 syntmp-w-777 syntmp-s-778)) syntmp-tmp-790) ((lambda (syntmp-tmp-797) (if (if syntmp-tmp-797 (apply (lambda (syntmp-_-798 syntmp-name-799 syntmp-args-800 syntmp-e1-801 syntmp-e2-802) (and (syntmp-id?-104 syntmp-name-799) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-800)))) syntmp-tmp-797) #f) (apply (lambda (syntmp-_-803 syntmp-name-804 syntmp-args-805 syntmp-e1-806 syntmp-e2-807) (values (quote define-form) (syntmp-wrap-132 syntmp-name-804 syntmp-w-777) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) (syntmp-wrap-132 (cons syntmp-args-805 (cons syntmp-e1-806 syntmp-e2-807)) syntmp-w-777)) (quote (())) syntmp-s-778)) syntmp-tmp-797) ((lambda (syntmp-tmp-809) (if (if syntmp-tmp-809 (apply (lambda (syntmp-_-810 syntmp-name-811) (syntmp-id?-104 syntmp-name-811)) syntmp-tmp-809) #f) (apply (lambda (syntmp-_-812 syntmp-name-813) (values (quote define-form) (syntmp-wrap-132 syntmp-name-813 syntmp-w-777) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote (())) syntmp-s-778)) syntmp-tmp-809) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-789 (quote (any any any))))) syntmp-e-775) (if (memv syntmp-t-788 (quote (define-syntax))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-syntax-form) syntmp-name-820 syntmp-val-821 syntmp-w-777 syntmp-s-778)) syntmp-tmp-815) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-775) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))))))))))))) (values (quote call) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)))) ((syntmp-syntax-object?-88 syntmp-e-775) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-775) syntmp-r-776 (syntmp-join-wraps-123 syntmp-w-777 (syntmp-syntax-object-wrap-90 syntmp-e-775)) #f syntmp-rib-779)) ((annotation? syntmp-e-775) (syntmp-syntax-type-138 (annotation-expression syntmp-e-775) syntmp-r-776 syntmp-w-777 (annotation-source syntmp-e-775) syntmp-rib-779)) ((self-evaluating? syntmp-e-775) (values (quote constant) #f syntmp-e-775 syntmp-w-777 syntmp-s-778)) (else (values (quote other) #f syntmp-e-775 syntmp-w-777 syntmp-s-778))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-822 syntmp-when-list-823 syntmp-w-824) (let syntmp-f-825 ((syntmp-when-list-826 syntmp-when-list-823) (syntmp-situations-827 (quote ()))) (if (null? syntmp-when-list-826) syntmp-situations-827 (syntmp-f-825 (cdr syntmp-when-list-826) (cons (let ((syntmp-x-828 (car syntmp-when-list-826))) (cond ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-828 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-828 syntmp-w-824) "invalid eval-when situation")))) syntmp-situations-827)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-829 syntmp-e-830) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-829) syntmp-e-830)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-831 syntmp-r-832 syntmp-w-833 syntmp-s-834 syntmp-m-835 syntmp-esew-836) (syntmp-build-sequence-83 syntmp-s-834 (let syntmp-dobody-837 ((syntmp-body-838 syntmp-body-831) (syntmp-r-839 syntmp-r-832) (syntmp-w-840 syntmp-w-833) (syntmp-m-841 syntmp-m-835) (syntmp-esew-842 syntmp-esew-836)) (if (null? syntmp-body-838) (quote ()) (let ((syntmp-first-843 (syntmp-chi-top-139 (car syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842))) (cons syntmp-first-843 (syntmp-dobody-837 (cdr syntmp-body-838) syntmp-r-839 syntmp-w-840 syntmp-m-841 syntmp-esew-842)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-844 syntmp-r-845 syntmp-w-846 syntmp-s-847) (syntmp-build-sequence-83 syntmp-s-847 (let syntmp-dobody-848 ((syntmp-body-849 syntmp-body-844) (syntmp-r-850 syntmp-r-845) (syntmp-w-851 syntmp-w-846)) (if (null? syntmp-body-849) (quote ()) (let ((syntmp-first-852 (syntmp-chi-140 (car syntmp-body-849) syntmp-r-850 syntmp-w-851))) (cons syntmp-first-852 (syntmp-dobody-848 (cdr syntmp-body-849) syntmp-r-850 syntmp-w-851)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-853 syntmp-w-854 syntmp-s-855) (syntmp-wrap-132 (if syntmp-s-855 (make-annotation syntmp-x-853 syntmp-s-855 #f) syntmp-x-853) syntmp-w-854))) (syntmp-wrap-132 (lambda (syntmp-x-856 syntmp-w-857) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-857)) (null? (syntmp-wrap-subst-108 syntmp-w-857))) syntmp-x-856) ((syntmp-syntax-object?-88 syntmp-x-856) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-856) (syntmp-join-wraps-123 syntmp-w-857 (syntmp-syntax-object-wrap-90 syntmp-x-856)) (syntmp-syntax-object-module-91 syntmp-x-856))) ((null? syntmp-x-856) syntmp-x-856) (else (syntmp-make-syntax-object-87 syntmp-x-856 syntmp-w-857 #f))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-858 syntmp-list-859) (and (not (null? syntmp-list-859)) (or (syntmp-bound-id=?-128 syntmp-x-858 (car syntmp-list-859)) (syntmp-bound-id-member?-131 syntmp-x-858 (cdr syntmp-list-859)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-860) (let syntmp-distinct?-861 ((syntmp-ids-862 syntmp-ids-860)) (or (null? syntmp-ids-862) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-862) (cdr syntmp-ids-862))) (syntmp-distinct?-861 (cdr syntmp-ids-862))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-863) (and (let syntmp-all-ids?-864 ((syntmp-ids-865 syntmp-ids-863)) (or (null? syntmp-ids-865) (and (syntmp-id?-104 (car syntmp-ids-865)) (syntmp-all-ids?-864 (cdr syntmp-ids-865))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-863)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-866 syntmp-j-867) (if (and (syntmp-syntax-object?-88 syntmp-i-866) (syntmp-syntax-object?-88 syntmp-j-867)) (and (eq? (let ((syntmp-e-868 (syntmp-syntax-object-expression-89 syntmp-i-866))) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 (syntmp-syntax-object-expression-89 syntmp-j-867))) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-866)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-867)))) (eq? (let ((syntmp-e-870 syntmp-i-866)) (if (annotation? syntmp-e-870) (annotation-expression syntmp-e-870) syntmp-e-870)) (let ((syntmp-e-871 syntmp-j-867)) (if (annotation? syntmp-e-871) (annotation-expression syntmp-e-871) syntmp-e-871)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-872 syntmp-j-873) (and (eq? (let ((syntmp-x-874 syntmp-i-872)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875))) (let ((syntmp-x-876 syntmp-j-873)) (let ((syntmp-e-877 (if (syntmp-syntax-object?-88 syntmp-x-876) (syntmp-syntax-object-expression-89 syntmp-x-876) syntmp-x-876))) (if (annotation? syntmp-e-877) (annotation-expression syntmp-e-877) syntmp-e-877)))) (eq? (syntmp-id-var-name-126 syntmp-i-872 (quote (()))) (syntmp-id-var-name-126 syntmp-j-873 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-878 syntmp-w-879) (letrec ((syntmp-search-vector-rib-882 (lambda (syntmp-sym-893 syntmp-subst-894 syntmp-marks-895 syntmp-symnames-896 syntmp-ribcage-897) (let ((syntmp-n-898 (vector-length syntmp-symnames-896))) (let syntmp-f-899 ((syntmp-i-900 0)) (cond ((syntmp-fx=-74 syntmp-i-900 syntmp-n-898) (syntmp-search-880 syntmp-sym-893 (cdr syntmp-subst-894) syntmp-marks-895)) ((and (eq? (vector-ref syntmp-symnames-896 syntmp-i-900) syntmp-sym-893) (syntmp-same-marks?-125 syntmp-marks-895 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-897) syntmp-i-900))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-897) syntmp-i-900) syntmp-marks-895)) (else (syntmp-f-899 (syntmp-fx+-72 syntmp-i-900 1)))))))) (syntmp-search-list-rib-881 (lambda (syntmp-sym-901 syntmp-subst-902 syntmp-marks-903 syntmp-symnames-904 syntmp-ribcage-905) (let syntmp-f-906 ((syntmp-symnames-907 syntmp-symnames-904) (syntmp-i-908 0)) (cond ((null? syntmp-symnames-907) (syntmp-search-880 syntmp-sym-901 (cdr syntmp-subst-902) syntmp-marks-903)) ((and (eq? (car syntmp-symnames-907) syntmp-sym-901) (syntmp-same-marks?-125 syntmp-marks-903 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-905) syntmp-i-908))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-905) syntmp-i-908) syntmp-marks-903)) (else (syntmp-f-906 (cdr syntmp-symnames-907) (syntmp-fx+-72 syntmp-i-908 1))))))) (syntmp-search-880 (lambda (syntmp-sym-909 syntmp-subst-910 syntmp-marks-911) (if (null? syntmp-subst-910) (values #f syntmp-marks-911) (let ((syntmp-fst-912 (car syntmp-subst-910))) (if (eq? syntmp-fst-912 (quote shift)) (syntmp-search-880 syntmp-sym-909 (cdr syntmp-subst-910) (cdr syntmp-marks-911)) (let ((syntmp-symnames-913 (syntmp-ribcage-symnames-113 syntmp-fst-912))) (if (vector? syntmp-symnames-913) (syntmp-search-vector-rib-882 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912) (syntmp-search-list-rib-881 syntmp-sym-909 syntmp-subst-910 syntmp-marks-911 syntmp-symnames-913 syntmp-fst-912))))))))) (cond ((symbol? syntmp-id-878) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-878 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-915 . syntmp-ignore-914) syntmp-x-915)) syntmp-id-878)) ((syntmp-syntax-object?-88 syntmp-id-878) (let ((syntmp-id-916 (let ((syntmp-e-918 (syntmp-syntax-object-expression-89 syntmp-id-878))) (if (annotation? syntmp-e-918) (annotation-expression syntmp-e-918) syntmp-e-918))) (syntmp-w1-917 (syntmp-syntax-object-wrap-90 syntmp-id-878))) (let ((syntmp-marks-919 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w1-917)))) (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w-879) syntmp-marks-919)) (lambda (syntmp-new-id-920 syntmp-marks-921) (or syntmp-new-id-920 (call-with-values (lambda () (syntmp-search-880 syntmp-id-916 (syntmp-wrap-subst-108 syntmp-w1-917) syntmp-marks-921)) (lambda (syntmp-x-923 . syntmp-ignore-922) syntmp-x-923)) syntmp-id-916)))))) ((annotation? syntmp-id-878) (let ((syntmp-id-924 (let ((syntmp-e-925 syntmp-id-878)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)))) (or (call-with-values (lambda () (syntmp-search-880 syntmp-id-924 (syntmp-wrap-subst-108 syntmp-w-879) (syntmp-wrap-marks-107 syntmp-w-879))) (lambda (syntmp-x-927 . syntmp-ignore-926) syntmp-x-927)) syntmp-id-924))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-878)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-928 syntmp-y-929) (or (eq? syntmp-x-928 syntmp-y-929) (and (not (null? syntmp-x-928)) (not (null? syntmp-y-929)) (eq? (car syntmp-x-928) (car syntmp-y-929)) (syntmp-same-marks?-125 (cdr syntmp-x-928) (cdr syntmp-y-929)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-930 syntmp-m2-931) (syntmp-smart-append-122 syntmp-m1-930 syntmp-m2-931))) (syntmp-join-wraps-123 (lambda (syntmp-w1-932 syntmp-w2-933) (let ((syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w1-932)) (syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w1-932))) (if (null? syntmp-m1-934) (if (null? syntmp-s1-935) syntmp-w2-933 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-933) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-934 (syntmp-wrap-marks-107 syntmp-w2-933)) (syntmp-smart-append-122 syntmp-s1-935 (syntmp-wrap-subst-108 syntmp-w2-933))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-936 syntmp-m2-937) (if (null? syntmp-m2-937) syntmp-m1-936 (append syntmp-m1-936 syntmp-m2-937)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-938 syntmp-labels-939 syntmp-w-940) (if (null? syntmp-ids-938) syntmp-w-940 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-940) (cons (let ((syntmp-labelvec-941 (list->vector syntmp-labels-939))) (let ((syntmp-n-942 (vector-length syntmp-labelvec-941))) (let ((syntmp-symnamevec-943 (make-vector syntmp-n-942)) (syntmp-marksvec-944 (make-vector syntmp-n-942))) (begin (let syntmp-f-945 ((syntmp-ids-946 syntmp-ids-938) (syntmp-i-947 0)) (if (not (null? syntmp-ids-946)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-946) syntmp-w-940)) (lambda (syntmp-symname-948 syntmp-marks-949) (begin (vector-set! syntmp-symnamevec-943 syntmp-i-947 syntmp-symname-948) (vector-set! syntmp-marksvec-944 syntmp-i-947 syntmp-marks-949) (syntmp-f-945 (cdr syntmp-ids-946) (syntmp-fx+-72 syntmp-i-947 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-943 syntmp-marksvec-944 syntmp-labelvec-941))))) (syntmp-wrap-subst-108 syntmp-w-940)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-950 syntmp-id-951 syntmp-label-952) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-950 (cons (let ((syntmp-e-953 (syntmp-syntax-object-expression-89 syntmp-id-951))) (if (annotation? syntmp-e-953) (annotation-expression syntmp-e-953) syntmp-e-953)) (syntmp-ribcage-symnames-113 syntmp-ribcage-950))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-950 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-951)) (syntmp-ribcage-marks-114 syntmp-ribcage-950))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-950 (cons syntmp-label-952 (syntmp-ribcage-labels-115 syntmp-ribcage-950)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-954) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-954)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-954))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 3 syntmp-update-956))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 2 syntmp-update-958))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-959 syntmp-update-960) (vector-set! syntmp-x-959 1 syntmp-update-960))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-962) (vector-ref syntmp-x-962 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-963) (vector-ref syntmp-x-963 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-964) (and (vector? syntmp-x-964) (= (vector-length syntmp-x-964) 4) (eq? (vector-ref syntmp-x-964 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967) (vector (quote ribcage) syntmp-symnames-965 syntmp-marks-966 syntmp-labels-967))) (syntmp-gen-labels-110 (lambda (syntmp-ls-968) (if (null? syntmp-ls-968) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-968)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-969 syntmp-w-970) (if (syntmp-syntax-object?-88 syntmp-x-969) (values (let ((syntmp-e-971 (syntmp-syntax-object-expression-89 syntmp-x-969))) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-970) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-969)))) (values (let ((syntmp-e-972 syntmp-x-969)) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)) (syntmp-wrap-marks-107 syntmp-w-970))))) (syntmp-id?-104 (lambda (syntmp-x-973) (cond ((symbol? syntmp-x-973) #t) ((syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))) ((annotation? syntmp-x-973) (symbol? (annotation-expression syntmp-x-973))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-975) (and (syntmp-syntax-object?-88 syntmp-x-975) (symbol? (let ((syntmp-e-976 (syntmp-syntax-object-expression-89 syntmp-x-975))) (if (annotation? syntmp-e-976) (annotation-expression syntmp-e-976) syntmp-e-976)))))) (syntmp-global-extend-102 (lambda (syntmp-type-977 syntmp-sym-978 syntmp-val-979) (syntmp-put-global-definition-hook-79 syntmp-sym-978 (cons syntmp-type-977 syntmp-val-979)))) (syntmp-lookup-101 (lambda (syntmp-x-980 syntmp-r-981) (cond ((assq syntmp-x-980 syntmp-r-981) => cdr) ((symbol? syntmp-x-980) (or (syntmp-get-global-definition-hook-80 syntmp-x-980) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-982) (if (null? syntmp-r-982) (quote ()) (let ((syntmp-a-983 (car syntmp-r-982))) (if (eq? (cadr syntmp-a-983) (quote macro)) (cons syntmp-a-983 (syntmp-macros-only-env-100 (cdr syntmp-r-982))) (syntmp-macros-only-env-100 (cdr syntmp-r-982))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-984 syntmp-vars-985 syntmp-r-986) (if (null? syntmp-labels-984) syntmp-r-986 (syntmp-extend-var-env-99 (cdr syntmp-labels-984) (cdr syntmp-vars-985) (cons (cons (car syntmp-labels-984) (cons (quote lexical) (car syntmp-vars-985))) syntmp-r-986))))) (syntmp-extend-env-98 (lambda (syntmp-labels-987 syntmp-bindings-988 syntmp-r-989) (if (null? syntmp-labels-987) syntmp-r-989 (syntmp-extend-env-98 (cdr syntmp-labels-987) (cdr syntmp-bindings-988) (cons (cons (car syntmp-labels-987) (car syntmp-bindings-988)) syntmp-r-989))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-990) (cond ((annotation? syntmp-x-990) (annotation-source syntmp-x-990)) ((syntmp-syntax-object?-88 syntmp-x-990) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-990))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-991 syntmp-update-992) (vector-set! syntmp-x-991 3 syntmp-update-992))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-993 syntmp-update-994) (vector-set! syntmp-x-993 2 syntmp-update-994))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-995 syntmp-update-996) (vector-set! syntmp-x-995 1 syntmp-update-996))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-997) (vector-ref syntmp-x-997 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-998) (vector-ref syntmp-x-998 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-999) (vector-ref syntmp-x-999 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1000) (and (vector? syntmp-x-1000) (= (vector-length syntmp-x-1000) 4) (eq? (vector-ref syntmp-x-1000 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-1001 syntmp-wrap-1002 syntmp-module-1003) (vector (quote syntax-object) syntmp-expression-1001 syntmp-wrap-1002 syntmp-module-1003))) (syntmp-build-letrec-86 (lambda (syntmp-src-1004 syntmp-vars-1005 syntmp-val-exps-1006 syntmp-body-exp-1007) (if (null? syntmp-vars-1005) (syntmp-build-annotated-81 syntmp-src-1004 syntmp-body-exp-1007) (syntmp-build-annotated-81 syntmp-src-1004 (list (quote letrec) (map list syntmp-vars-1005 syntmp-val-exps-1006) syntmp-body-exp-1007))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1008 syntmp-vars-1009 syntmp-val-exps-1010 syntmp-body-exp-1011) (if (null? syntmp-vars-1009) (syntmp-build-annotated-81 syntmp-src-1008 syntmp-body-exp-1011) (syntmp-build-annotated-81 syntmp-src-1008 (list (quote let) (car syntmp-vars-1009) (map list (cdr syntmp-vars-1009) syntmp-val-exps-1010) syntmp-body-exp-1011))))) (syntmp-build-let-84 (lambda (syntmp-src-1012 syntmp-vars-1013 syntmp-val-exps-1014 syntmp-body-exp-1015) (if (null? syntmp-vars-1013) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-body-exp-1015) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote let) (map list syntmp-vars-1013 syntmp-val-exps-1014) syntmp-body-exp-1015))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1016 syntmp-exps-1017) (if (null? (cdr syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (car syntmp-exps-1017)) (syntmp-build-annotated-81 syntmp-src-1016 (cons (quote begin) syntmp-exps-1017))))) (syntmp-build-data-82 (lambda (syntmp-src-1018 syntmp-exp-1019) (if (and (self-evaluating? syntmp-exp-1019) (not (vector? syntmp-exp-1019))) (syntmp-build-annotated-81 syntmp-src-1018 syntmp-exp-1019) (syntmp-build-annotated-81 syntmp-src-1018 (list (quote quote) syntmp-exp-1019))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1020 syntmp-exp-1021) (if (and syntmp-src-1020 (not (annotation? syntmp-exp-1021))) (make-annotation syntmp-exp-1021 syntmp-src-1020 #t) syntmp-exp-1021))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1022) (getprop syntmp-symbol-1022 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1023 syntmp-binding-1024) (putprop syntmp-symbol-1023 (quote *sc-expander*) syntmp-binding-1024))) (syntmp-error-hook-78 (lambda (syntmp-who-1025 syntmp-why-1026 syntmp-what-1027) (error syntmp-who-1025 "~a ~s" syntmp-why-1026 syntmp-what-1027))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1028) (eval (list syntmp-noexpand-71 syntmp-x-1028) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1029) (eval (list syntmp-noexpand-71 syntmp-x-1029) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1030 syntmp-r-1031 syntmp-w-1032 syntmp-s-1033) ((lambda (syntmp-tmp-1034) ((lambda (syntmp-tmp-1035) (if (if syntmp-tmp-1035 (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (syntmp-valid-bound-ids?-129 syntmp-var-1037)) syntmp-tmp-1035) #f) (apply (lambda (syntmp-_-1042 syntmp-var-1043 syntmp-val-1044 syntmp-e1-1045 syntmp-e2-1046) (let ((syntmp-names-1047 (map (lambda (syntmp-x-1048) (syntmp-id-var-name-126 syntmp-x-1048 syntmp-w-1032)) syntmp-var-1043))) (begin (for-each (lambda (syntmp-id-1050 syntmp-n-1051) (let ((syntmp-t-1052 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1051 syntmp-r-1031)))) (if (memv syntmp-t-1052 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1050 syntmp-w-1032 syntmp-s-1033) "identifier out of context")))) syntmp-var-1043 syntmp-names-1047) (syntmp-chi-body-144 (cons syntmp-e1-1045 syntmp-e2-1046) (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033) (syntmp-extend-env-98 syntmp-names-1047 (let ((syntmp-trans-r-1055 (syntmp-macros-only-env-100 syntmp-r-1031))) (map (lambda (syntmp-x-1056) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1056 syntmp-trans-r-1055 syntmp-w-1032)))) syntmp-val-1044)) syntmp-r-1031) syntmp-w-1032)))) syntmp-tmp-1035) ((lambda (syntmp-_-1058) (syntax-error (syntmp-source-wrap-133 syntmp-e-1030 syntmp-w-1032 syntmp-s-1033))) syntmp-tmp-1034))) (syntax-dispatch syntmp-tmp-1034 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1030))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1059 syntmp-r-1060 syntmp-w-1061 syntmp-s-1062) ((lambda (syntmp-tmp-1063) ((lambda (syntmp-tmp-1064) (if syntmp-tmp-1064 (apply (lambda (syntmp-_-1065 syntmp-e-1066) (syntmp-build-data-82 syntmp-s-1062 (syntmp-strip-151 syntmp-e-1066 syntmp-w-1061))) syntmp-tmp-1064) ((lambda (syntmp-_-1067) (syntax-error (syntmp-source-wrap-133 syntmp-e-1059 syntmp-w-1061 syntmp-s-1062))) syntmp-tmp-1063))) (syntax-dispatch syntmp-tmp-1063 (quote (any any))))) syntmp-e-1059))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1075 (lambda (syntmp-x-1076) (let ((syntmp-t-1077 (car syntmp-x-1076))) (if (memv syntmp-t-1077 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1076)) (if (memv syntmp-t-1077 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1076) (syntmp-regen-1075 (caddr syntmp-x-1076)))) (if (memv syntmp-t-1077 (quote (map))) (let ((syntmp-ls-1078 (map syntmp-regen-1075 (cdr syntmp-x-1076)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1078) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1078))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1076)) (map syntmp-regen-1075 (cdr syntmp-x-1076)))))))))))) (syntmp-gen-vector-1074 (lambda (syntmp-x-1079) (cond ((eq? (car syntmp-x-1079) (quote list)) (cons (quote vector) (cdr syntmp-x-1079))) ((eq? (car syntmp-x-1079) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1079)))) (else (list (quote list->vector) syntmp-x-1079))))) (syntmp-gen-append-1073 (lambda (syntmp-x-1080 syntmp-y-1081) (if (equal? syntmp-y-1081 (quote (quote ()))) syntmp-x-1080 (list (quote append) syntmp-x-1080 syntmp-y-1081)))) (syntmp-gen-cons-1072 (lambda (syntmp-x-1082 syntmp-y-1083) (let ((syntmp-t-1084 (car syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (quote))) (if (eq? (car syntmp-x-1082) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1082) (cadr syntmp-y-1083))) (if (eq? (cadr syntmp-y-1083) (quote ())) (list (quote list) syntmp-x-1082) (list (quote cons) syntmp-x-1082 syntmp-y-1083))) (if (memv syntmp-t-1084 (quote (list))) (cons (quote list) (cons syntmp-x-1082 (cdr syntmp-y-1083))) (list (quote cons) syntmp-x-1082 syntmp-y-1083)))))) (syntmp-gen-map-1071 (lambda (syntmp-e-1085 syntmp-map-env-1086) (let ((syntmp-formals-1087 (map cdr syntmp-map-env-1086)) (syntmp-actuals-1088 (map (lambda (syntmp-x-1089) (list (quote ref) (car syntmp-x-1089))) syntmp-map-env-1086))) (cond ((eq? (car syntmp-e-1085) (quote ref)) (car syntmp-actuals-1088)) ((andmap (lambda (syntmp-x-1090) (and (eq? (car syntmp-x-1090) (quote ref)) (memq (cadr syntmp-x-1090) syntmp-formals-1087))) (cdr syntmp-e-1085)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1085)) (map (let ((syntmp-r-1091 (map cons syntmp-formals-1087 syntmp-actuals-1088))) (lambda (syntmp-x-1092) (cdr (assq (cadr syntmp-x-1092) syntmp-r-1091)))) (cdr syntmp-e-1085))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1087 syntmp-e-1085) syntmp-actuals-1088))))))) (syntmp-gen-mappend-1070 (lambda (syntmp-e-1093 syntmp-map-env-1094) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1071 syntmp-e-1093 syntmp-map-env-1094)))) (syntmp-gen-ref-1069 (lambda (syntmp-src-1095 syntmp-var-1096 syntmp-level-1097 syntmp-maps-1098) (if (syntmp-fx=-74 syntmp-level-1097 0) (values syntmp-var-1096 syntmp-maps-1098) (if (null? syntmp-maps-1098) (syntax-error syntmp-src-1095 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1069 syntmp-src-1095 syntmp-var-1096 (syntmp-fx--73 syntmp-level-1097 1) (cdr syntmp-maps-1098))) (lambda (syntmp-outer-var-1099 syntmp-outer-maps-1100) (let ((syntmp-b-1101 (assq syntmp-outer-var-1099 (car syntmp-maps-1098)))) (if syntmp-b-1101 (values (cdr syntmp-b-1101) syntmp-maps-1098) (let ((syntmp-inner-var-1102 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1102 (cons (cons (cons syntmp-outer-var-1099 syntmp-inner-var-1102) (car syntmp-maps-1098)) syntmp-outer-maps-1100))))))))))) (syntmp-gen-syntax-1068 (lambda (syntmp-src-1103 syntmp-e-1104 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107) (if (syntmp-id?-104 syntmp-e-1104) (let ((syntmp-label-1108 (syntmp-id-var-name-126 syntmp-e-1104 (quote (()))))) (let ((syntmp-b-1109 (syntmp-lookup-101 syntmp-label-1108 syntmp-r-1105))) (if (eq? (syntmp-binding-type-96 syntmp-b-1109) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1110 (syntmp-binding-value-97 syntmp-b-1109))) (syntmp-gen-ref-1069 syntmp-src-1103 (car syntmp-var.lev-1110) (cdr syntmp-var.lev-1110) syntmp-maps-1106))) (lambda (syntmp-var-1111 syntmp-maps-1112) (values (list (quote ref) syntmp-var-1111) syntmp-maps-1112))) (if (syntmp-ellipsis?-1107 syntmp-e-1104) (syntax-error syntmp-src-1103 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106))))) ((lambda (syntmp-tmp-1113) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-dots-1115 syntmp-e-1116) (syntmp-ellipsis?-1107 syntmp-dots-1115)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-dots-1117 syntmp-e-1118) (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-e-1118 syntmp-r-1105 syntmp-maps-1106 (lambda (syntmp-x-1119) #f))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1120) (if (if syntmp-tmp-1120 (apply (lambda (syntmp-x-1121 syntmp-dots-1122 syntmp-y-1123) (syntmp-ellipsis?-1107 syntmp-dots-1122)) syntmp-tmp-1120) #f) (apply (lambda (syntmp-x-1124 syntmp-dots-1125 syntmp-y-1126) (let syntmp-f-1127 ((syntmp-y-1128 syntmp-y-1126) (syntmp-k-1129 (lambda (syntmp-maps-1130) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1124 syntmp-r-1105 (cons (quote ()) syntmp-maps-1130) syntmp-ellipsis?-1107)) (lambda (syntmp-x-1131 syntmp-maps-1132) (if (null? (car syntmp-maps-1132)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-map-1071 syntmp-x-1131 (car syntmp-maps-1132)) (cdr syntmp-maps-1132)))))))) ((lambda (syntmp-tmp-1133) ((lambda (syntmp-tmp-1134) (if (if syntmp-tmp-1134 (apply (lambda (syntmp-dots-1135 syntmp-y-1136) (syntmp-ellipsis?-1107 syntmp-dots-1135)) syntmp-tmp-1134) #f) (apply (lambda (syntmp-dots-1137 syntmp-y-1138) (syntmp-f-1127 syntmp-y-1138 (lambda (syntmp-maps-1139) (call-with-values (lambda () (syntmp-k-1129 (cons (quote ()) syntmp-maps-1139))) (lambda (syntmp-x-1140 syntmp-maps-1141) (if (null? (car syntmp-maps-1141)) (syntax-error syntmp-src-1103 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1070 syntmp-x-1140 (car syntmp-maps-1141)) (cdr syntmp-maps-1141)))))))) syntmp-tmp-1134) ((lambda (syntmp-_-1142) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1128 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1143 syntmp-maps-1144) (call-with-values (lambda () (syntmp-k-1129 syntmp-maps-1144)) (lambda (syntmp-x-1145 syntmp-maps-1146) (values (syntmp-gen-append-1073 syntmp-x-1145 syntmp-y-1143) syntmp-maps-1146)))))) syntmp-tmp-1133))) (syntax-dispatch syntmp-tmp-1133 (quote (any . any))))) syntmp-y-1128))) syntmp-tmp-1120) ((lambda (syntmp-tmp-1147) (if syntmp-tmp-1147 (apply (lambda (syntmp-x-1148 syntmp-y-1149) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-x-1148 syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-x-1150 syntmp-maps-1151) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 syntmp-y-1149 syntmp-r-1105 syntmp-maps-1151 syntmp-ellipsis?-1107)) (lambda (syntmp-y-1152 syntmp-maps-1153) (values (syntmp-gen-cons-1072 syntmp-x-1150 syntmp-y-1152) syntmp-maps-1153)))))) syntmp-tmp-1147) ((lambda (syntmp-tmp-1154) (if syntmp-tmp-1154 (apply (lambda (syntmp-e1-1155 syntmp-e2-1156) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-src-1103 (cons syntmp-e1-1155 syntmp-e2-1156) syntmp-r-1105 syntmp-maps-1106 syntmp-ellipsis?-1107)) (lambda (syntmp-e-1158 syntmp-maps-1159) (values (syntmp-gen-vector-1074 syntmp-e-1158) syntmp-maps-1159)))) syntmp-tmp-1154) ((lambda (syntmp-_-1160) (values (list (quote quote) syntmp-e-1104) syntmp-maps-1106)) syntmp-tmp-1113))) (syntax-dispatch syntmp-tmp-1113 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1113 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1113 (quote (any any))))) syntmp-e-1104))))) (lambda (syntmp-e-1161 syntmp-r-1162 syntmp-w-1163 syntmp-s-1164) (let ((syntmp-e-1165 (syntmp-source-wrap-133 syntmp-e-1161 syntmp-w-1163 syntmp-s-1164))) ((lambda (syntmp-tmp-1166) ((lambda (syntmp-tmp-1167) (if syntmp-tmp-1167 (apply (lambda (syntmp-_-1168 syntmp-x-1169) (call-with-values (lambda () (syntmp-gen-syntax-1068 syntmp-e-1165 syntmp-x-1169 syntmp-r-1162 (quote ()) syntmp-ellipsis?-149)) (lambda (syntmp-e-1170 syntmp-maps-1171) (syntmp-regen-1075 syntmp-e-1170)))) syntmp-tmp-1167) ((lambda (syntmp-_-1172) (syntax-error syntmp-e-1165)) syntmp-tmp-1166))) (syntax-dispatch syntmp-tmp-1166 (quote (any any))))) syntmp-e-1165))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1173 syntmp-r-1174 syntmp-w-1175 syntmp-s-1176) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if syntmp-tmp-1178 (apply (lambda (syntmp-_-1179 syntmp-c-1180) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1173 syntmp-w-1175 syntmp-s-1176) syntmp-c-1180 syntmp-r-1174 syntmp-w-1175 (lambda (syntmp-vars-1181 syntmp-body-1182) (syntmp-build-annotated-81 syntmp-s-1176 (list (quote lambda) syntmp-vars-1181 syntmp-body-1182))))) syntmp-tmp-1178) (syntax-error syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-e-1173))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1183 (lambda (syntmp-e-1184 syntmp-r-1185 syntmp-w-1186 syntmp-s-1187 syntmp-constructor-1188 syntmp-ids-1189 syntmp-vals-1190 syntmp-exps-1191) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1189)) (syntax-error syntmp-e-1184 "duplicate bound variable in") (let ((syntmp-labels-1192 (syntmp-gen-labels-110 syntmp-ids-1189)) (syntmp-new-vars-1193 (map syntmp-gen-var-152 syntmp-ids-1189))) (let ((syntmp-nw-1194 (syntmp-make-binding-wrap-121 syntmp-ids-1189 syntmp-labels-1192 syntmp-w-1186)) (syntmp-nr-1195 (syntmp-extend-var-env-99 syntmp-labels-1192 syntmp-new-vars-1193 syntmp-r-1185))) (syntmp-constructor-1188 syntmp-s-1187 syntmp-new-vars-1193 (map (lambda (syntmp-x-1196) (syntmp-chi-140 syntmp-x-1196 syntmp-r-1185 syntmp-w-1186)) syntmp-vals-1190) (syntmp-chi-body-144 syntmp-exps-1191 (syntmp-source-wrap-133 syntmp-e-1184 syntmp-nw-1194 syntmp-s-1187) syntmp-nr-1195 syntmp-nw-1194)))))))) (lambda (syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if syntmp-tmp-1202 (apply (lambda (syntmp-_-1203 syntmp-id-1204 syntmp-val-1205 syntmp-e1-1206 syntmp-e2-1207) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-let-84 syntmp-id-1204 syntmp-val-1205 (cons syntmp-e1-1206 syntmp-e2-1207))) syntmp-tmp-1202) ((lambda (syntmp-tmp-1211) (if (if syntmp-tmp-1211 (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-id?-104 syntmp-f-1213)) syntmp-tmp-1211) #f) (apply (lambda (syntmp-_-1218 syntmp-f-1219 syntmp-id-1220 syntmp-val-1221 syntmp-e1-1222 syntmp-e2-1223) (syntmp-chi-let-1183 syntmp-e-1197 syntmp-r-1198 syntmp-w-1199 syntmp-s-1200 syntmp-build-named-let-85 (cons syntmp-f-1219 syntmp-id-1220) syntmp-val-1221 (cons syntmp-e1-1222 syntmp-e2-1223))) syntmp-tmp-1211) ((lambda (syntmp-_-1227) (syntax-error (syntmp-source-wrap-133 syntmp-e-1197 syntmp-w-1199 syntmp-s-1200))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1201 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1197)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1228 syntmp-r-1229 syntmp-w-1230 syntmp-s-1231) ((lambda (syntmp-tmp-1232) ((lambda (syntmp-tmp-1233) (if syntmp-tmp-1233 (apply (lambda (syntmp-_-1234 syntmp-id-1235 syntmp-val-1236 syntmp-e1-1237 syntmp-e2-1238) (let ((syntmp-ids-1239 syntmp-id-1235)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1239)) (syntax-error syntmp-e-1228 "duplicate bound variable in") (let ((syntmp-labels-1241 (syntmp-gen-labels-110 syntmp-ids-1239)) (syntmp-new-vars-1242 (map syntmp-gen-var-152 syntmp-ids-1239))) (let ((syntmp-w-1243 (syntmp-make-binding-wrap-121 syntmp-ids-1239 syntmp-labels-1241 syntmp-w-1230)) (syntmp-r-1244 (syntmp-extend-var-env-99 syntmp-labels-1241 syntmp-new-vars-1242 syntmp-r-1229))) (syntmp-build-letrec-86 syntmp-s-1231 syntmp-new-vars-1242 (map (lambda (syntmp-x-1245) (syntmp-chi-140 syntmp-x-1245 syntmp-r-1244 syntmp-w-1243)) syntmp-val-1236) (syntmp-chi-body-144 (cons syntmp-e1-1237 syntmp-e2-1238) (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1243 syntmp-s-1231) syntmp-r-1244 syntmp-w-1243))))))) syntmp-tmp-1233) ((lambda (syntmp-_-1248) (syntax-error (syntmp-source-wrap-133 syntmp-e-1228 syntmp-w-1230 syntmp-s-1231))) syntmp-tmp-1232))) (syntax-dispatch syntmp-tmp-1232 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1228))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1249 syntmp-r-1250 syntmp-w-1251 syntmp-s-1252) ((lambda (syntmp-tmp-1253) ((lambda (syntmp-tmp-1254) (if (if syntmp-tmp-1254 (apply (lambda (syntmp-_-1255 syntmp-id-1256 syntmp-val-1257) (syntmp-id?-104 syntmp-id-1256)) syntmp-tmp-1254) #f) (apply (lambda (syntmp-_-1258 syntmp-id-1259 syntmp-val-1260) (let ((syntmp-val-1261 (syntmp-chi-140 syntmp-val-1260 syntmp-r-1250 syntmp-w-1251)) (syntmp-n-1262 (syntmp-id-var-name-126 syntmp-id-1259 syntmp-w-1251))) (let ((syntmp-b-1263 (syntmp-lookup-101 syntmp-n-1262 syntmp-r-1250))) (let ((syntmp-t-1264 (syntmp-binding-type-96 syntmp-b-1263))) (if (memv syntmp-t-1264 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1263) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1252 (list (quote set!) (make-module-ref #f syntmp-n-1262 #f) syntmp-val-1261)) (if (memv syntmp-t-1264 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1259 syntmp-w-1251) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))))))))) syntmp-tmp-1254) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (apply (lambda (syntmp-_-1266 syntmp-getter-1267 syntmp-arg-1268 syntmp-val-1269) (syntmp-build-annotated-81 syntmp-s-1252 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-getter-1267) syntmp-r-1250 syntmp-w-1251) (map (lambda (syntmp-e-1270) (syntmp-chi-140 syntmp-e-1270 syntmp-r-1250 syntmp-w-1251)) (append syntmp-arg-1268 (list syntmp-val-1269)))))) syntmp-tmp-1265) ((lambda (syntmp-_-1272) (syntax-error (syntmp-source-wrap-133 syntmp-e-1249 syntmp-w-1251 syntmp-s-1252))) syntmp-tmp-1253))) (syntax-dispatch syntmp-tmp-1253 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1253 (quote (any any any))))) syntmp-e-1249))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1276 (lambda (syntmp-x-1277 syntmp-keys-1278 syntmp-clauses-1279 syntmp-r-1280) (if (null? syntmp-clauses-1279) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1277)) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-exp-1284) (if (and (syntmp-id?-104 syntmp-pat-1283) (andmap (lambda (syntmp-x-1285) (not (syntmp-free-id=?-127 syntmp-pat-1283 syntmp-x-1285))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-keys-1278))) (let ((syntmp-labels-1286 (list (syntmp-gen-label-109))) (syntmp-var-1287 (syntmp-gen-var-152 syntmp-pat-1283))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1287) (syntmp-chi-140 syntmp-exp-1284 (syntmp-extend-env-98 syntmp-labels-1286 (list (cons (quote syntax) (cons syntmp-var-1287 0))) syntmp-r-1280) (syntmp-make-binding-wrap-121 (list syntmp-pat-1283) syntmp-labels-1286 (quote (())))))) syntmp-x-1277))) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1283 #t syntmp-exp-1284))) syntmp-tmp-1282) ((lambda (syntmp-tmp-1288) (if syntmp-tmp-1288 (apply (lambda (syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291) (syntmp-gen-clause-1275 syntmp-x-1277 syntmp-keys-1278 (cdr syntmp-clauses-1279) syntmp-r-1280 syntmp-pat-1289 syntmp-fender-1290 syntmp-exp-1291)) syntmp-tmp-1288) ((lambda (syntmp-_-1292) (syntax-error (car syntmp-clauses-1279) "invalid syntax-case clause")) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1281 (quote (any any))))) (car syntmp-clauses-1279))))) (syntmp-gen-clause-1275 (lambda (syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296 syntmp-pat-1297 syntmp-fender-1298 syntmp-exp-1299) (call-with-values (lambda () (syntmp-convert-pattern-1273 syntmp-pat-1297 syntmp-keys-1294)) (lambda (syntmp-p-1300 syntmp-pvars-1301) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1301))) (syntax-error syntmp-pat-1297 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1302) (not (syntmp-ellipsis?-149 (car syntmp-x-1302)))) syntmp-pvars-1301)) (syntax-error syntmp-pat-1297 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1303 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1303) (let ((syntmp-y-1304 (syntmp-build-annotated-81 #f syntmp-y-1303))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda () syntmp-y-1304) syntmp-tmp-1306) ((lambda (syntmp-_-1307) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1304 (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-fender-1298 syntmp-y-1304 syntmp-r-1296) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote #(atom #t))))) syntmp-fender-1298) (syntmp-build-dispatch-call-1274 syntmp-pvars-1301 syntmp-exp-1299 syntmp-y-1304 syntmp-r-1296) (syntmp-gen-syntax-case-1276 syntmp-x-1293 syntmp-keys-1294 syntmp-clauses-1295 syntmp-r-1296)))))) (if (eq? syntmp-p-1300 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1293)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1293 (syntmp-build-data-82 #f syntmp-p-1300))))))))))))) (syntmp-build-dispatch-call-1274 (lambda (syntmp-pvars-1308 syntmp-exp-1309 syntmp-y-1310 syntmp-r-1311) (let ((syntmp-ids-1312 (map car syntmp-pvars-1308)) (syntmp-levels-1313 (map cdr syntmp-pvars-1308))) (let ((syntmp-labels-1314 (syntmp-gen-labels-110 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-152 syntmp-ids-1312))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1315 (syntmp-chi-140 syntmp-exp-1309 (syntmp-extend-env-98 syntmp-labels-1314 (map (lambda (syntmp-var-1316 syntmp-level-1317) (cons (quote syntax) (cons syntmp-var-1316 syntmp-level-1317))) syntmp-new-vars-1315 (map cdr syntmp-pvars-1308)) syntmp-r-1311) (syntmp-make-binding-wrap-121 syntmp-ids-1312 syntmp-labels-1314 (quote (())))))) syntmp-y-1310)))))) (syntmp-convert-pattern-1273 (lambda (syntmp-pattern-1318 syntmp-keys-1319) (let syntmp-cvt-1320 ((syntmp-p-1321 syntmp-pattern-1318) (syntmp-n-1322 0) (syntmp-ids-1323 (quote ()))) (if (syntmp-id?-104 syntmp-p-1321) (if (syntmp-bound-id-member?-131 syntmp-p-1321 syntmp-keys-1319) (values (vector (quote free-id) syntmp-p-1321) syntmp-ids-1323) (values (quote any) (cons (cons syntmp-p-1321 syntmp-n-1322) syntmp-ids-1323))) ((lambda (syntmp-tmp-1324) ((lambda (syntmp-tmp-1325) (if (if syntmp-tmp-1325 (apply (lambda (syntmp-x-1326 syntmp-dots-1327) (syntmp-ellipsis?-149 syntmp-dots-1327)) syntmp-tmp-1325) #f) (apply (lambda (syntmp-x-1328 syntmp-dots-1329) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1328 (syntmp-fx+-72 syntmp-n-1322 1) syntmp-ids-1323)) (lambda (syntmp-p-1330 syntmp-ids-1331) (values (if (eq? syntmp-p-1330 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1330)) syntmp-ids-1331)))) syntmp-tmp-1325) ((lambda (syntmp-tmp-1332) (if syntmp-tmp-1332 (apply (lambda (syntmp-x-1333 syntmp-y-1334) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-y-1334 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-y-1335 syntmp-ids-1336) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1333 syntmp-n-1322 syntmp-ids-1336)) (lambda (syntmp-x-1337 syntmp-ids-1338) (values (cons syntmp-x-1337 syntmp-y-1335) syntmp-ids-1338)))))) syntmp-tmp-1332) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda () (values (quote ()) syntmp-ids-1323)) syntmp-tmp-1339) ((lambda (syntmp-tmp-1340) (if syntmp-tmp-1340 (apply (lambda (syntmp-x-1341) (call-with-values (lambda () (syntmp-cvt-1320 syntmp-x-1341 syntmp-n-1322 syntmp-ids-1323)) (lambda (syntmp-p-1343 syntmp-ids-1344) (values (vector (quote vector) syntmp-p-1343) syntmp-ids-1344)))) syntmp-tmp-1340) ((lambda (syntmp-x-1345) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1321 (quote (())))) syntmp-ids-1323)) syntmp-tmp-1324))) (syntax-dispatch syntmp-tmp-1324 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1324 (quote ()))))) (syntax-dispatch syntmp-tmp-1324 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1324 (quote (any any))))) syntmp-p-1321)))))) (lambda (syntmp-e-1346 syntmp-r-1347 syntmp-w-1348 syntmp-s-1349) (let ((syntmp-e-1350 (syntmp-source-wrap-133 syntmp-e-1346 syntmp-w-1348 syntmp-s-1349))) ((lambda (syntmp-tmp-1351) ((lambda (syntmp-tmp-1352) (if syntmp-tmp-1352 (apply (lambda (syntmp-_-1353 syntmp-val-1354 syntmp-key-1355 syntmp-m-1356) (if (andmap (lambda (syntmp-x-1357) (and (syntmp-id?-104 syntmp-x-1357) (not (syntmp-ellipsis?-149 syntmp-x-1357)))) syntmp-key-1355) (let ((syntmp-x-1359 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1349 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1359) (syntmp-gen-syntax-case-1276 (syntmp-build-annotated-81 #f syntmp-x-1359) syntmp-key-1355 syntmp-m-1356 syntmp-r-1347))) (syntmp-chi-140 syntmp-val-1354 syntmp-r-1347 (quote (())))))) (syntax-error syntmp-e-1350 "invalid literals list in"))) syntmp-tmp-1352) (syntax-error syntmp-tmp-1351))) (syntax-dispatch syntmp-tmp-1351 (quote (any any each-any . each-any))))) syntmp-e-1350))))) (set! sc-expand (let ((syntmp-m-1362 (quote e)) (syntmp-esew-1363 (quote (eval)))) (lambda (syntmp-x-1364) (if (and (pair? syntmp-x-1364) (equal? (car syntmp-x-1364) syntmp-noexpand-71)) (cadr syntmp-x-1364) (syntmp-chi-top-139 syntmp-x-1364 (quote ()) (quote ((top))) syntmp-m-1362 syntmp-esew-1363))))) (set! sc-expand3 (let ((syntmp-m-1365 (quote e)) (syntmp-esew-1366 (quote (eval)))) (lambda (syntmp-x-1368 . syntmp-rest-1367) (if (and (pair? syntmp-x-1368) (equal? (car syntmp-x-1368) syntmp-noexpand-71)) (cadr syntmp-x-1368) (syntmp-chi-top-139 syntmp-x-1368 (quote ()) (quote ((top))) (if (null? syntmp-rest-1367) syntmp-m-1365 (car syntmp-rest-1367)) (if (or (null? syntmp-rest-1367) (null? (cdr syntmp-rest-1367))) syntmp-esew-1366 (cadr syntmp-rest-1367))))))) (set! identifier? (lambda (syntmp-x-1369) (syntmp-nonsymbol-id?-103 syntmp-x-1369))) (set! datum->syntax-object (lambda (syntmp-id-1370 syntmp-datum-1371) (syntmp-make-syntax-object-87 syntmp-datum-1371 (syntmp-syntax-object-wrap-90 syntmp-id-1370) #f))) (set! syntax-object->datum (lambda (syntmp-x-1372) (syntmp-strip-151 syntmp-x-1372 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1373) (begin (let ((syntmp-x-1374 syntmp-ls-1373)) (if (not (list? syntmp-x-1374)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1374))) (map (lambda (syntmp-x-1375) (syntmp-wrap-132 (gensym) (quote ((top))))) syntmp-ls-1373)))) (set! free-identifier=? (lambda (syntmp-x-1376 syntmp-y-1377) (begin (let ((syntmp-x-1378 syntmp-x-1376)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1378)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1378))) (let ((syntmp-x-1379 syntmp-y-1377)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1379)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1379))) (syntmp-free-id=?-127 syntmp-x-1376 syntmp-y-1377)))) (set! bound-identifier=? (lambda (syntmp-x-1380 syntmp-y-1381) (begin (let ((syntmp-x-1382 syntmp-x-1380)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1382)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1382))) (let ((syntmp-x-1383 syntmp-y-1381)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1383)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1383))) (syntmp-bound-id=?-128 syntmp-x-1380 syntmp-y-1381)))) (set! syntax-error (lambda (syntmp-object-1385 . syntmp-messages-1384) (begin (for-each (lambda (syntmp-x-1386) (let ((syntmp-x-1387 syntmp-x-1386)) (if (not (string? syntmp-x-1387)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1387)))) syntmp-messages-1384) (let ((syntmp-message-1388 (if (null? syntmp-messages-1384) "invalid syntax" (apply string-append syntmp-messages-1384)))) (syntmp-error-hook-78 #f syntmp-message-1388 (syntmp-strip-151 syntmp-object-1385 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1389 syntmp-v-1390) (begin (let ((syntmp-x-1391 syntmp-sym-1389)) (if (not (symbol? syntmp-x-1391)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1391))) (let ((syntmp-x-1392 syntmp-v-1390)) (if (not (procedure? syntmp-x-1392)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1392))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1389 syntmp-v-1390)))) (letrec ((syntmp-match-1397 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((not syntmp-r-1401) #f) ((eq? syntmp-p-1399 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1398 syntmp-w-1400) syntmp-r-1401)) ((syntmp-syntax-object?-88 syntmp-e-1398) (syntmp-match*-1396 (let ((syntmp-e-1402 (syntmp-syntax-object-expression-89 syntmp-e-1398))) (if (annotation? syntmp-e-1402) (annotation-expression syntmp-e-1402) syntmp-e-1402)) syntmp-p-1399 (syntmp-join-wraps-123 syntmp-w-1400 (syntmp-syntax-object-wrap-90 syntmp-e-1398)) syntmp-r-1401)) (else (syntmp-match*-1396 (let ((syntmp-e-1403 syntmp-e-1398)) (if (annotation? syntmp-e-1403) (annotation-expression syntmp-e-1403) syntmp-e-1403)) syntmp-p-1399 syntmp-w-1400 syntmp-r-1401))))) (syntmp-match*-1396 (lambda (syntmp-e-1404 syntmp-p-1405 syntmp-w-1406 syntmp-r-1407) (cond ((null? syntmp-p-1405) (and (null? syntmp-e-1404) syntmp-r-1407)) ((pair? syntmp-p-1405) (and (pair? syntmp-e-1404) (syntmp-match-1397 (car syntmp-e-1404) (car syntmp-p-1405) syntmp-w-1406 (syntmp-match-1397 (cdr syntmp-e-1404) (cdr syntmp-p-1405) syntmp-w-1406 syntmp-r-1407)))) ((eq? syntmp-p-1405 (quote each-any)) (let ((syntmp-l-1408 (syntmp-match-each-any-1394 syntmp-e-1404 syntmp-w-1406))) (and syntmp-l-1408 (cons syntmp-l-1408 syntmp-r-1407)))) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1405 0))) (if (memv syntmp-t-1409 (quote (each))) (if (null? syntmp-e-1404) (syntmp-match-empty-1395 (vector-ref syntmp-p-1405 1) syntmp-r-1407) (let ((syntmp-l-1410 (syntmp-match-each-1393 syntmp-e-1404 (vector-ref syntmp-p-1405 1) syntmp-w-1406))) (and syntmp-l-1410 (let syntmp-collect-1411 ((syntmp-l-1412 syntmp-l-1410)) (if (null? (car syntmp-l-1412)) syntmp-r-1407 (cons (map car syntmp-l-1412) (syntmp-collect-1411 (map cdr syntmp-l-1412)))))))) (if (memv syntmp-t-1409 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1404) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1404 syntmp-w-1406) (vector-ref syntmp-p-1405 1)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (atom))) (and (equal? (vector-ref syntmp-p-1405 1) (syntmp-strip-151 syntmp-e-1404 syntmp-w-1406)) syntmp-r-1407) (if (memv syntmp-t-1409 (quote (vector))) (and (vector? syntmp-e-1404) (syntmp-match-1397 (vector->list syntmp-e-1404) (vector-ref syntmp-p-1405 1) syntmp-w-1406 syntmp-r-1407))))))))))) (syntmp-match-empty-1395 (lambda (syntmp-p-1413 syntmp-r-1414) (cond ((null? syntmp-p-1413) syntmp-r-1414) ((eq? syntmp-p-1413 (quote any)) (cons (quote ()) syntmp-r-1414)) ((pair? syntmp-p-1413) (syntmp-match-empty-1395 (car syntmp-p-1413) (syntmp-match-empty-1395 (cdr syntmp-p-1413) syntmp-r-1414))) ((eq? syntmp-p-1413 (quote each-any)) (cons (quote ()) syntmp-r-1414)) (else (let ((syntmp-t-1415 (vector-ref syntmp-p-1413 0))) (if (memv syntmp-t-1415 (quote (each))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414) (if (memv syntmp-t-1415 (quote (free-id atom))) syntmp-r-1414 (if (memv syntmp-t-1415 (quote (vector))) (syntmp-match-empty-1395 (vector-ref syntmp-p-1413 1) syntmp-r-1414))))))))) (syntmp-match-each-any-1394 (lambda (syntmp-e-1416 syntmp-w-1417) (cond ((annotation? syntmp-e-1416) (syntmp-match-each-any-1394 (annotation-expression syntmp-e-1416) syntmp-w-1417)) ((pair? syntmp-e-1416) (let ((syntmp-l-1418 (syntmp-match-each-any-1394 (cdr syntmp-e-1416) syntmp-w-1417))) (and syntmp-l-1418 (cons (syntmp-wrap-132 (car syntmp-e-1416) syntmp-w-1417) syntmp-l-1418)))) ((null? syntmp-e-1416) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1416) (syntmp-match-each-any-1394 (syntmp-syntax-object-expression-89 syntmp-e-1416) (syntmp-join-wraps-123 syntmp-w-1417 (syntmp-syntax-object-wrap-90 syntmp-e-1416)))) (else #f)))) (syntmp-match-each-1393 (lambda (syntmp-e-1419 syntmp-p-1420 syntmp-w-1421) (cond ((annotation? syntmp-e-1419) (syntmp-match-each-1393 (annotation-expression syntmp-e-1419) syntmp-p-1420 syntmp-w-1421)) ((pair? syntmp-e-1419) (let ((syntmp-first-1422 (syntmp-match-1397 (car syntmp-e-1419) syntmp-p-1420 syntmp-w-1421 (quote ())))) (and syntmp-first-1422 (let ((syntmp-rest-1423 (syntmp-match-each-1393 (cdr syntmp-e-1419) syntmp-p-1420 syntmp-w-1421))) (and syntmp-rest-1423 (cons syntmp-first-1422 syntmp-rest-1423)))))) ((null? syntmp-e-1419) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1419) (syntmp-match-each-1393 (syntmp-syntax-object-expression-89 syntmp-e-1419) syntmp-p-1420 (syntmp-join-wraps-123 syntmp-w-1421 (syntmp-syntax-object-wrap-90 syntmp-e-1419)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1424 syntmp-p-1425) (cond ((eq? syntmp-p-1425 (quote any)) (list syntmp-e-1424)) ((syntmp-syntax-object?-88 syntmp-e-1424) (syntmp-match*-1396 (let ((syntmp-e-1426 (syntmp-syntax-object-expression-89 syntmp-e-1424))) (if (annotation? syntmp-e-1426) (annotation-expression syntmp-e-1426) syntmp-e-1426)) syntmp-p-1425 (syntmp-syntax-object-wrap-90 syntmp-e-1424) (quote ()))) (else (syntmp-match*-1396 (let ((syntmp-e-1427 syntmp-e-1424)) (if (annotation? syntmp-e-1427) (annotation-expression syntmp-e-1427) syntmp-e-1427)) syntmp-p-1425 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-140))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1428) ((lambda (syntmp-tmp-1429) ((lambda (syntmp-tmp-1430) (if syntmp-tmp-1430 (apply (lambda (syntmp-_-1431 syntmp-e1-1432 syntmp-e2-1433) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1432 syntmp-e2-1433))) syntmp-tmp-1430) ((lambda (syntmp-tmp-1435) (if syntmp-tmp-1435 (apply (lambda (syntmp-_-1436 syntmp-out-1437 syntmp-in-1438 syntmp-e1-1439 syntmp-e2-1440) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1438 (quote ()) (list syntmp-out-1437 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1439 syntmp-e2-1440))))) syntmp-tmp-1435) ((lambda (syntmp-tmp-1442) (if syntmp-tmp-1442 (apply (lambda (syntmp-_-1443 syntmp-out-1444 syntmp-in-1445 syntmp-e1-1446 syntmp-e2-1447) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1445) (quote ()) (list syntmp-out-1444 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1446 syntmp-e2-1447))))) syntmp-tmp-1442) (syntax-error syntmp-tmp-1429))) (syntax-dispatch syntmp-tmp-1429 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1429 (quote (any () any . each-any))))) syntmp-x-1428))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1469) ((lambda (syntmp-tmp-1470) ((lambda (syntmp-tmp-1471) (if syntmp-tmp-1471 (apply (lambda (syntmp-_-1472 syntmp-k-1473 syntmp-keyword-1474 syntmp-pattern-1475 syntmp-template-1476) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-k-1473 (map (lambda (syntmp-tmp-1479 syntmp-tmp-1478) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1478) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1479))) syntmp-template-1476 syntmp-pattern-1475)))))) syntmp-tmp-1471) (syntax-error syntmp-tmp-1470))) (syntax-dispatch syntmp-tmp-1470 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1469))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1490) ((lambda (syntmp-tmp-1491) ((lambda (syntmp-tmp-1492) (if (if syntmp-tmp-1492 (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (andmap identifier? syntmp-x-1494)) syntmp-tmp-1492) #f) (apply (lambda (syntmp-let*-1499 syntmp-x-1500 syntmp-v-1501 syntmp-e1-1502 syntmp-e2-1503) (let syntmp-f-1504 ((syntmp-bindings-1505 (map list syntmp-x-1500 syntmp-v-1501))) (if (null? syntmp-bindings-1505) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote ()) (cons syntmp-e1-1502 syntmp-e2-1503))) ((lambda (syntmp-tmp-1509) ((lambda (syntmp-tmp-1510) (if syntmp-tmp-1510 (apply (lambda (syntmp-body-1511 syntmp-binding-1512) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list syntmp-binding-1512) syntmp-body-1511)) syntmp-tmp-1510) (syntax-error syntmp-tmp-1509))) (syntax-dispatch syntmp-tmp-1509 (quote (any any))))) (list (syntmp-f-1504 (cdr syntmp-bindings-1505)) (car syntmp-bindings-1505)))))) syntmp-tmp-1492) (syntax-error syntmp-tmp-1491))) (syntax-dispatch syntmp-tmp-1491 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1490))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1532) ((lambda (syntmp-tmp-1533) ((lambda (syntmp-tmp-1534) (if syntmp-tmp-1534 (apply (lambda (syntmp-_-1535 syntmp-var-1536 syntmp-init-1537 syntmp-step-1538 syntmp-e0-1539 syntmp-e1-1540 syntmp-c-1541) ((lambda (syntmp-tmp-1542) ((lambda (syntmp-tmp-1543) (if syntmp-tmp-1543 (apply (lambda (syntmp-step-1544) ((lambda (syntmp-tmp-1545) ((lambda (syntmp-tmp-1546) (if syntmp-tmp-1546 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1539) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1544))))))) syntmp-tmp-1546) ((lambda (syntmp-tmp-1551) (if syntmp-tmp-1551 (apply (lambda (syntmp-e1-1552 syntmp-e2-1553) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1536 syntmp-init-1537) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1539 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (cons syntmp-e1-1552 syntmp-e2-1553)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1541 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1544))))))) syntmp-tmp-1551) (syntax-error syntmp-tmp-1545))) (syntax-dispatch syntmp-tmp-1545 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1545 (quote ())))) syntmp-e1-1540)) syntmp-tmp-1543) (syntax-error syntmp-tmp-1542))) (syntax-dispatch syntmp-tmp-1542 (quote each-any)))) (map (lambda (syntmp-v-1560 syntmp-s-1561) ((lambda (syntmp-tmp-1562) ((lambda (syntmp-tmp-1563) (if syntmp-tmp-1563 (apply (lambda () syntmp-v-1560) syntmp-tmp-1563) ((lambda (syntmp-tmp-1564) (if syntmp-tmp-1564 (apply (lambda (syntmp-e-1565) syntmp-e-1565) syntmp-tmp-1564) ((lambda (syntmp-_-1566) (syntax-error syntmp-orig-x-1532)) syntmp-tmp-1562))) (syntax-dispatch syntmp-tmp-1562 (quote (any)))))) (syntax-dispatch syntmp-tmp-1562 (quote ())))) syntmp-s-1561)) syntmp-var-1536 syntmp-step-1538))) syntmp-tmp-1534) (syntax-error syntmp-tmp-1533))) (syntax-dispatch syntmp-tmp-1533 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1532))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1594 (lambda (syntmp-x-1598 syntmp-y-1599) ((lambda (syntmp-tmp-1600) ((lambda (syntmp-tmp-1601) (if syntmp-tmp-1601 (apply (lambda (syntmp-x-1602 syntmp-y-1603) ((lambda (syntmp-tmp-1604) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-dy-1606) ((lambda (syntmp-tmp-1607) ((lambda (syntmp-tmp-1608) (if syntmp-tmp-1608 (apply (lambda (syntmp-dx-1609) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-dx-1609 syntmp-dy-1606))) syntmp-tmp-1608) ((lambda (syntmp-_-1610) (if (null? syntmp-dy-1606) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1602) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1602 syntmp-y-1603))) syntmp-tmp-1607))) (syntax-dispatch syntmp-tmp-1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-x-1602)) syntmp-tmp-1605) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-stuff-1612) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-x-1602 syntmp-stuff-1612))) syntmp-tmp-1611) ((lambda (syntmp-else-1613) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1602 syntmp-y-1603)) syntmp-tmp-1604))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . any)))))) (syntax-dispatch syntmp-tmp-1604 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-y-1603)) syntmp-tmp-1601) (syntax-error syntmp-tmp-1600))) (syntax-dispatch syntmp-tmp-1600 (quote (any any))))) (list syntmp-x-1598 syntmp-y-1599)))) (syntmp-quasiappend-1595 (lambda (syntmp-x-1614 syntmp-y-1615) ((lambda (syntmp-tmp-1616) ((lambda (syntmp-tmp-1617) (if syntmp-tmp-1617 (apply (lambda (syntmp-x-1618 syntmp-y-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda () syntmp-x-1618) syntmp-tmp-1621) ((lambda (syntmp-_-1622) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1618 syntmp-y-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) ()))))) syntmp-y-1619)) syntmp-tmp-1617) (syntax-error syntmp-tmp-1616))) (syntax-dispatch syntmp-tmp-1616 (quote (any any))))) (list syntmp-x-1614 syntmp-y-1615)))) (syntmp-quasivector-1596 (lambda (syntmp-x-1623) ((lambda (syntmp-tmp-1624) ((lambda (syntmp-x-1625) ((lambda (syntmp-tmp-1626) ((lambda (syntmp-tmp-1627) (if syntmp-tmp-1627 (apply (lambda (syntmp-x-1628) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (list->vector syntmp-x-1628))) syntmp-tmp-1627) ((lambda (syntmp-tmp-1630) (if syntmp-tmp-1630 (apply (lambda (syntmp-x-1631) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1631)) syntmp-tmp-1630) ((lambda (syntmp-_-1633) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1625)) syntmp-tmp-1626))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . each-any)))))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) each-any))))) syntmp-x-1625)) syntmp-tmp-1624)) syntmp-x-1623))) (syntmp-quasi-1597 (lambda (syntmp-p-1634 syntmp-lev-1635) ((lambda (syntmp-tmp-1636) ((lambda (syntmp-tmp-1637) (if syntmp-tmp-1637 (apply (lambda (syntmp-p-1638) (if (= syntmp-lev-1635 0) syntmp-p-1638 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1597 (list syntmp-p-1638) (- syntmp-lev-1635 1))))) syntmp-tmp-1637) ((lambda (syntmp-tmp-1639) (if syntmp-tmp-1639 (apply (lambda (syntmp-p-1640 syntmp-q-1641) (if (= syntmp-lev-1635 0) (syntmp-quasiappend-1595 syntmp-p-1640 (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)) (syntmp-quasicons-1594 (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1597 (list syntmp-p-1640) (- syntmp-lev-1635 1))) (syntmp-quasi-1597 syntmp-q-1641 syntmp-lev-1635)))) syntmp-tmp-1639) ((lambda (syntmp-tmp-1642) (if syntmp-tmp-1642 (apply (lambda (syntmp-p-1643) (syntmp-quasicons-1594 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1597 (list syntmp-p-1643) (+ syntmp-lev-1635 1)))) syntmp-tmp-1642) ((lambda (syntmp-tmp-1644) (if syntmp-tmp-1644 (apply (lambda (syntmp-p-1645 syntmp-q-1646) (syntmp-quasicons-1594 (syntmp-quasi-1597 syntmp-p-1645 syntmp-lev-1635) (syntmp-quasi-1597 syntmp-q-1646 syntmp-lev-1635))) syntmp-tmp-1644) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-x-1648) (syntmp-quasivector-1596 (syntmp-quasi-1597 syntmp-x-1648 syntmp-lev-1635))) syntmp-tmp-1647) ((lambda (syntmp-p-1650) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-p-1650)) syntmp-tmp-1636))) (syntax-dispatch syntmp-tmp-1636 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any)))))) (syntax-dispatch syntmp-tmp-1636 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any) . any)))))) (syntax-dispatch syntmp-tmp-1636 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-p-1634)))) (lambda (syntmp-x-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda (syntmp-_-1654 syntmp-e-1655) (syntmp-quasi-1597 syntmp-e-1655 0)) syntmp-tmp-1653) (syntax-error syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any any))))) syntmp-x-1651)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1715) (letrec ((syntmp-read-file-1716 (lambda (syntmp-fn-1717 syntmp-k-1718) (let ((syntmp-p-1719 (open-input-file syntmp-fn-1717))) (let syntmp-f-1720 ((syntmp-x-1721 (read syntmp-p-1719))) (if (eof-object? syntmp-x-1721) (begin (close-input-port syntmp-p-1719) (quote ())) (cons (datum->syntax-object syntmp-k-1718 syntmp-x-1721) (syntmp-f-1720 (read syntmp-p-1719))))))))) ((lambda (syntmp-tmp-1722) ((lambda (syntmp-tmp-1723) (if syntmp-tmp-1723 (apply (lambda (syntmp-k-1724 syntmp-filename-1725) (let ((syntmp-fn-1726 (syntax-object->datum syntmp-filename-1725))) ((lambda (syntmp-tmp-1727) ((lambda (syntmp-tmp-1728) (if syntmp-tmp-1728 (apply (lambda (syntmp-exp-1729) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-exp-1729)) syntmp-tmp-1728) (syntax-error syntmp-tmp-1727))) (syntax-dispatch syntmp-tmp-1727 (quote each-any)))) (syntmp-read-file-1716 syntmp-fn-1726 syntmp-k-1724)))) syntmp-tmp-1723) (syntax-error syntmp-tmp-1722))) (syntax-dispatch syntmp-tmp-1722 (quote (any any))))) syntmp-x-1715)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1746) ((lambda (syntmp-tmp-1747) ((lambda (syntmp-tmp-1748) (if syntmp-tmp-1748 (apply (lambda (syntmp-_-1749 syntmp-e-1750) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1750))) syntmp-tmp-1748) (syntax-error syntmp-tmp-1747))) (syntax-dispatch syntmp-tmp-1747 (quote (any any))))) syntmp-x-1746))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1756) ((lambda (syntmp-tmp-1757) ((lambda (syntmp-tmp-1758) (if syntmp-tmp-1758 (apply (lambda (syntmp-_-1759 syntmp-e-1760) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1760))) syntmp-tmp-1758) (syntax-error syntmp-tmp-1757))) (syntax-dispatch syntmp-tmp-1757 (quote (any any))))) syntmp-x-1756))) -(install-global-transformer (quote case) (lambda (syntmp-x-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-tmp-1768) (if syntmp-tmp-1768 (apply (lambda (syntmp-_-1769 syntmp-e-1770 syntmp-m1-1771 syntmp-m2-1772) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-body-1774) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1770)) syntmp-body-1774)) syntmp-tmp-1773)) (let syntmp-f-1775 ((syntmp-clause-1776 syntmp-m1-1771) (syntmp-clauses-1777 syntmp-m2-1772)) (if (null? syntmp-clauses-1777) ((lambda (syntmp-tmp-1779) ((lambda (syntmp-tmp-1780) (if syntmp-tmp-1780 (apply (lambda (syntmp-e1-1781 syntmp-e2-1782) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1781 syntmp-e2-1782))) syntmp-tmp-1780) ((lambda (syntmp-tmp-1784) (if syntmp-tmp-1784 (apply (lambda (syntmp-k-1785 syntmp-e1-1786 syntmp-e2-1787) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1785)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1786 syntmp-e2-1787)))) syntmp-tmp-1784) ((lambda (syntmp-_-1790) (syntax-error syntmp-x-1766)) syntmp-tmp-1779))) (syntax-dispatch syntmp-tmp-1779 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1779 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) any . each-any))))) syntmp-clause-1776) ((lambda (syntmp-tmp-1791) ((lambda (syntmp-rest-1792) ((lambda (syntmp-tmp-1793) ((lambda (syntmp-tmp-1794) (if syntmp-tmp-1794 (apply (lambda (syntmp-k-1795 syntmp-e1-1796 syntmp-e2-1797) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1795)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1796 syntmp-e2-1797)) syntmp-rest-1792)) syntmp-tmp-1794) ((lambda (syntmp-_-1800) (syntax-error syntmp-x-1766)) syntmp-tmp-1793))) (syntax-dispatch syntmp-tmp-1793 (quote (each-any any . each-any))))) syntmp-clause-1776)) syntmp-tmp-1791)) (syntmp-f-1775 (car syntmp-clauses-1777) (cdr syntmp-clauses-1777))))))) syntmp-tmp-1768) (syntax-error syntmp-tmp-1767))) (syntax-dispatch syntmp-tmp-1767 (quote (any any any . each-any))))) syntmp-x-1766))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1830) ((lambda (syntmp-tmp-1831) ((lambda (syntmp-tmp-1832) (if syntmp-tmp-1832 (apply (lambda (syntmp-_-1833 syntmp-e-1834) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1834)) (list (cons syntmp-_-1833 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e-1834 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))))))))) syntmp-tmp-1832) (syntax-error syntmp-tmp-1831))) (syntax-dispatch syntmp-tmp-1831 (quote (any any))))) syntmp-x-1830))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (procedure-module syntmp-p-688)))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref #f syntmp-value-717 syntmp-mod-722)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref #f syntmp-value-717 syntmp-mod-722)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-724) ((lambda (syntmp-tmp-725) (if syntmp-tmp-725 (apply (lambda (syntmp-_-726 syntmp-e1-727 syntmp-e2-728) (syntmp-chi-sequence-147 (cons syntmp-e1-727 syntmp-e2-728) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-725) (syntax-error syntmp-tmp-724))) (syntax-dispatch syntmp-tmp-724 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-730) ((lambda (syntmp-tmp-731) (if syntmp-tmp-731 (apply (lambda (syntmp-_-732 syntmp-x-733 syntmp-e1-734 syntmp-e2-735) (let ((syntmp-when-list-736 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-733 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-736) (syntmp-chi-sequence-147 (cons syntmp-e1-734 syntmp-e2-735) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-731) (syntax-error syntmp-tmp-730))) (syntax-dispatch syntmp-tmp-730 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 #f) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722)))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-739 syntmp-r-740 syntmp-w-741 syntmp-mod-742) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-739 syntmp-r-740 syntmp-w-741 #f #f syntmp-mod-742)) (lambda (syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-w-746 syntmp-s-747 syntmp-mod-748) (syntmp-chi-expr-154 syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-r-740 syntmp-w-746 syntmp-s-747 syntmp-mod-748))))) (syntmp-chi-top-152 (lambda (syntmp-e-749 syntmp-r-750 syntmp-w-751 syntmp-m-752 syntmp-esew-753 syntmp-mod-754) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-749 syntmp-r-750 syntmp-w-751 #f #f syntmp-mod-754)) (lambda (syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-w-772 syntmp-s-773 syntmp-mod-774) (let ((syntmp-t-775 syntmp-type-769)) (if (memv syntmp-t-775 (quote (begin-form))) ((lambda (syntmp-tmp-776) ((lambda (syntmp-tmp-777) (if syntmp-tmp-777 (apply (lambda (syntmp-_-778) (syntmp-chi-void-161)) syntmp-tmp-777) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-e1-781 syntmp-e2-782) (syntmp-chi-top-sequence-148 (cons syntmp-e1-781 syntmp-e2-782) syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-m-752 syntmp-esew-753 syntmp-mod-774)) syntmp-tmp-779) (syntax-error syntmp-tmp-776))) (syntax-dispatch syntmp-tmp-776 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-776 (quote (any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774 (lambda (syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-mod-788) (syntmp-chi-top-sequence-148 syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-m-752 syntmp-esew-753 syntmp-mod-788))) (if (memv syntmp-t-775 (quote (eval-when-form))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-x-792 syntmp-e1-793 syntmp-e2-794) (let ((syntmp-when-list-795 (syntmp-chi-when-list-150 syntmp-e-771 syntmp-x-792 syntmp-w-772)) (syntmp-body-796 (cons syntmp-e1-793 syntmp-e2-794))) (cond ((eq? syntmp-m-752 (quote e)) (if (memq (quote eval) syntmp-when-list-795) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-795) (if (or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c&e) (quote (compile load)) syntmp-mod-774) (if (memq syntmp-m-752 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c) (quote (load)) syntmp-mod-774) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) syntmp-mod-774) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-790) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any each-any any . each-any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (define-syntax-form))) (let ((syntmp-n-799 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772)) (syntmp-r-800 (syntmp-macros-only-env-113 syntmp-r-750))) (let ((syntmp-t-801 syntmp-m-752)) (if (memv syntmp-t-801 (quote (c))) (if (memq (quote compile) syntmp-esew-753) (let ((syntmp-e-802 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-802 syntmp-mod-774) (if (memq (quote load) syntmp-esew-753) syntmp-e-802 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-753) (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) (syntmp-chi-void-161))) (if (memv syntmp-t-801 (quote (c&e))) (let ((syntmp-e-803 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-803 syntmp-mod-774) syntmp-e-803)) (begin (if (memq (quote eval) syntmp-esew-753) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) syntmp-mod-774)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-775 (quote (define-form))) (let ((syntmp-n-804 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772))) (let ((syntmp-type-805 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-804 syntmp-r-750)))) (let ((syntmp-t-806 syntmp-type-805)) (if (memv syntmp-t-806 (quote (global))) (let ((syntmp-x-807 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-807 syntmp-mod-774)) syntmp-x-807)) (if (memv syntmp-t-806 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 #f) "identifier out of context") (if (eq? syntmp-type-805 (quote external-macro)) (let ((syntmp-x-808 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-808 syntmp-mod-774)) syntmp-x-808)) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 #f) "cannot define keyword at top level"))))))) (let ((syntmp-x-809 (syntmp-chi-expr-154 syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-774)) syntmp-x-809)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (cond ((symbol? syntmp-e-810) (let ((syntmp-n-816 (syntmp-id-var-name-139 syntmp-e-810 syntmp-w-812))) (let ((syntmp-b-817 (syntmp-lookup-114 syntmp-n-816 syntmp-r-811))) (let ((syntmp-type-818 (syntmp-binding-type-109 syntmp-b-817))) (let ((syntmp-t-819 syntmp-type-818)) (if (memv syntmp-t-819 (quote (lexical))) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 #f) (if (memv syntmp-t-819 (quote (global))) (values syntmp-type-818 syntmp-n-816 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))))))) ((pair? syntmp-e-810) (let ((syntmp-first-820 (car syntmp-e-810))) (if (syntmp-id?-117 syntmp-first-820) (let ((syntmp-n-821 (syntmp-id-var-name-139 syntmp-first-820 syntmp-w-812))) (let ((syntmp-b-822 (syntmp-lookup-114 syntmp-n-821 syntmp-r-811))) (let ((syntmp-type-823 (syntmp-binding-type-109 syntmp-b-822))) (let ((syntmp-t-824 syntmp-type-823)) (if (memv syntmp-t-824 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (global))) (values (quote global-call) syntmp-n-821 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (if (memv syntmp-t-824 (quote (core external-macro))) (values syntmp-type-823 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (begin))) (values (quote begin-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (define))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-117 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-form) syntmp-name-831 syntmp-val-832 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-826) ((lambda (syntmp-tmp-833) (if (if syntmp-tmp-833 (apply (lambda (syntmp-_-834 syntmp-name-835 syntmp-args-836 syntmp-e1-837 syntmp-e2-838) (and (syntmp-id?-117 syntmp-name-835) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-836)))) syntmp-tmp-833) #f) (apply (lambda (syntmp-_-839 syntmp-name-840 syntmp-args-841 syntmp-e1-842 syntmp-e2-843) (values (quote define-form) (syntmp-wrap-145 syntmp-name-840 syntmp-w-812 #f) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) (syntmp-wrap-145 (cons syntmp-args-841 (cons syntmp-e1-842 syntmp-e2-843)) syntmp-w-812 syntmp-mod-815)) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-833) ((lambda (syntmp-tmp-845) (if (if syntmp-tmp-845 (apply (lambda (syntmp-_-846 syntmp-name-847) (syntmp-id?-117 syntmp-name-847)) syntmp-tmp-845) #f) (apply (lambda (syntmp-_-848 syntmp-name-849) (values (quote define-form) (syntmp-wrap-145 syntmp-name-849 syntmp-w-812 #f) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-845) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-810) (if (memv syntmp-t-824 (quote (define-syntax))) ((lambda (syntmp-tmp-850) ((lambda (syntmp-tmp-851) (if (if syntmp-tmp-851 (apply (lambda (syntmp-_-852 syntmp-name-853 syntmp-val-854) (syntmp-id?-117 syntmp-name-853)) syntmp-tmp-851) #f) (apply (lambda (syntmp-_-855 syntmp-name-856 syntmp-val-857) (values (quote define-syntax-form) syntmp-name-856 syntmp-val-857 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-851) (syntax-error syntmp-tmp-850))) (syntax-dispatch syntmp-tmp-850 (quote (any any any))))) syntmp-e-810) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))))))))))))) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))) ((syntmp-syntax-object?-101 syntmp-e-810) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-810) syntmp-r-811 (syntmp-join-wraps-136 syntmp-w-812 (syntmp-syntax-object-wrap-103 syntmp-e-810)) #f syntmp-rib-814 (syntmp-syntax-object-module-104 syntmp-e-810))) ((annotation? syntmp-e-810) (syntmp-syntax-type-151 (annotation-expression syntmp-e-810) syntmp-r-811 syntmp-w-812 (annotation-source syntmp-e-810) syntmp-rib-814 syntmp-mod-815)) ((self-evaluating? syntmp-e-810) (values (quote constant) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) (else (values (quote other) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-858 syntmp-when-list-859 syntmp-w-860) (let syntmp-f-861 ((syntmp-when-list-862 syntmp-when-list-859) (syntmp-situations-863 (quote ()))) (if (null? syntmp-when-list-862) syntmp-situations-863 (syntmp-f-861 (cdr syntmp-when-list-862) (cons (let ((syntmp-x-864 (car syntmp-when-list-862))) (cond ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-864 syntmp-w-860 #f) "invalid eval-when situation")))) syntmp-situations-863)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-876 syntmp-e-877) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-876) syntmp-e-877)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-878 syntmp-r-879 syntmp-w-880 syntmp-s-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884) (syntmp-build-sequence-96 syntmp-s-881 (let syntmp-dobody-885 ((syntmp-body-886 syntmp-body-878) (syntmp-r-887 syntmp-r-879) (syntmp-w-888 syntmp-w-880) (syntmp-m-889 syntmp-m-882) (syntmp-esew-890 syntmp-esew-883) (syntmp-mod-891 syntmp-mod-884)) (if (null? syntmp-body-886) (quote ()) (let ((syntmp-first-892 (syntmp-chi-top-152 (car syntmp-body-886) syntmp-r-887 syntmp-w-888 syntmp-m-889 syntmp-esew-890 syntmp-mod-891))) (cons syntmp-first-892 (syntmp-dobody-885 (cdr syntmp-body-886) syntmp-r-887 syntmp-w-888 syntmp-m-889 syntmp-esew-890 syntmp-mod-891)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-893 syntmp-r-894 syntmp-w-895 syntmp-s-896 syntmp-mod-897) (syntmp-build-sequence-96 syntmp-s-896 (let syntmp-dobody-898 ((syntmp-body-899 syntmp-body-893) (syntmp-r-900 syntmp-r-894) (syntmp-w-901 syntmp-w-895) (syntmp-mod-902 syntmp-mod-897)) (if (null? syntmp-body-899) (quote ()) (let ((syntmp-first-903 (syntmp-chi-153 (car syntmp-body-899) syntmp-r-900 syntmp-w-901 syntmp-mod-902))) (cons syntmp-first-903 (syntmp-dobody-898 (cdr syntmp-body-899) syntmp-r-900 syntmp-w-901 syntmp-mod-902)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-904 syntmp-w-905 syntmp-s-906 syntmp-defmod-907) (syntmp-wrap-145 (if syntmp-s-906 (make-annotation syntmp-x-904 syntmp-s-906 #f) syntmp-x-904) syntmp-w-905 syntmp-defmod-907))) (syntmp-wrap-145 (lambda (syntmp-x-908 syntmp-w-909 syntmp-defmod-910) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-909)) (null? (syntmp-wrap-subst-121 syntmp-w-909))) syntmp-x-908) ((syntmp-syntax-object?-101 syntmp-x-908) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-908) (syntmp-join-wraps-136 syntmp-w-909 (syntmp-syntax-object-wrap-103 syntmp-x-908)) (syntmp-syntax-object-module-104 syntmp-x-908))) ((null? syntmp-x-908) syntmp-x-908) (else (syntmp-make-syntax-object-100 syntmp-x-908 syntmp-w-909 syntmp-defmod-910))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-911 syntmp-list-912) (and (not (null? syntmp-list-912)) (or (syntmp-bound-id=?-141 syntmp-x-911 (car syntmp-list-912)) (syntmp-bound-id-member?-144 syntmp-x-911 (cdr syntmp-list-912)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-913) (let syntmp-distinct?-914 ((syntmp-ids-915 syntmp-ids-913)) (or (null? syntmp-ids-915) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-915) (cdr syntmp-ids-915))) (syntmp-distinct?-914 (cdr syntmp-ids-915))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-916) (and (let syntmp-all-ids?-917 ((syntmp-ids-918 syntmp-ids-916)) (or (null? syntmp-ids-918) (and (syntmp-id?-117 (car syntmp-ids-918)) (syntmp-all-ids?-917 (cdr syntmp-ids-918))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-916)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-919 syntmp-j-920) (if (and (syntmp-syntax-object?-101 syntmp-i-919) (syntmp-syntax-object?-101 syntmp-j-920)) (and (eq? (let ((syntmp-e-921 (syntmp-syntax-object-expression-102 syntmp-i-919))) (if (annotation? syntmp-e-921) (annotation-expression syntmp-e-921) syntmp-e-921)) (let ((syntmp-e-922 (syntmp-syntax-object-expression-102 syntmp-j-920))) (if (annotation? syntmp-e-922) (annotation-expression syntmp-e-922) syntmp-e-922))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-919)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-920)))) (eq? (let ((syntmp-e-923 syntmp-i-919)) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 syntmp-j-920)) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-925 syntmp-j-926) (and (eq? (let ((syntmp-x-927 syntmp-i-925)) (let ((syntmp-e-928 (if (syntmp-syntax-object?-101 syntmp-x-927) (syntmp-syntax-object-expression-102 syntmp-x-927) syntmp-x-927))) (if (annotation? syntmp-e-928) (annotation-expression syntmp-e-928) syntmp-e-928))) (let ((syntmp-x-929 syntmp-j-926)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930)))) (eq? (syntmp-id-var-name-139 syntmp-i-925 (quote (()))) (syntmp-id-var-name-139 syntmp-j-926 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-931 syntmp-w-932) (letrec ((syntmp-search-vector-rib-935 (lambda (syntmp-sym-946 syntmp-subst-947 syntmp-marks-948 syntmp-symnames-949 syntmp-ribcage-950) (let ((syntmp-n-951 (vector-length syntmp-symnames-949))) (let syntmp-f-952 ((syntmp-i-953 0)) (cond ((syntmp-fx=-87 syntmp-i-953 syntmp-n-951) (syntmp-search-933 syntmp-sym-946 (cdr syntmp-subst-947) syntmp-marks-948)) ((and (eq? (vector-ref syntmp-symnames-949 syntmp-i-953) syntmp-sym-946) (syntmp-same-marks?-138 syntmp-marks-948 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-950) syntmp-i-953))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-950) syntmp-i-953) syntmp-marks-948)) (else (syntmp-f-952 (syntmp-fx+-85 syntmp-i-953 1)))))))) (syntmp-search-list-rib-934 (lambda (syntmp-sym-954 syntmp-subst-955 syntmp-marks-956 syntmp-symnames-957 syntmp-ribcage-958) (let syntmp-f-959 ((syntmp-symnames-960 syntmp-symnames-957) (syntmp-i-961 0)) (cond ((null? syntmp-symnames-960) (syntmp-search-933 syntmp-sym-954 (cdr syntmp-subst-955) syntmp-marks-956)) ((and (eq? (car syntmp-symnames-960) syntmp-sym-954) (syntmp-same-marks?-138 syntmp-marks-956 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-958) syntmp-i-961))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-958) syntmp-i-961) syntmp-marks-956)) (else (syntmp-f-959 (cdr syntmp-symnames-960) (syntmp-fx+-85 syntmp-i-961 1))))))) (syntmp-search-933 (lambda (syntmp-sym-962 syntmp-subst-963 syntmp-marks-964) (if (null? syntmp-subst-963) (values #f syntmp-marks-964) (let ((syntmp-fst-965 (car syntmp-subst-963))) (if (eq? syntmp-fst-965 (quote shift)) (syntmp-search-933 syntmp-sym-962 (cdr syntmp-subst-963) (cdr syntmp-marks-964)) (let ((syntmp-symnames-966 (syntmp-ribcage-symnames-126 syntmp-fst-965))) (if (vector? syntmp-symnames-966) (syntmp-search-vector-rib-935 syntmp-sym-962 syntmp-subst-963 syntmp-marks-964 syntmp-symnames-966 syntmp-fst-965) (syntmp-search-list-rib-934 syntmp-sym-962 syntmp-subst-963 syntmp-marks-964 syntmp-symnames-966 syntmp-fst-965))))))))) (cond ((symbol? syntmp-id-931) (or (call-with-values (lambda () (syntmp-search-933 syntmp-id-931 (syntmp-wrap-subst-121 syntmp-w-932) (syntmp-wrap-marks-120 syntmp-w-932))) (lambda (syntmp-x-968 . syntmp-ignore-967) syntmp-x-968)) syntmp-id-931)) ((syntmp-syntax-object?-101 syntmp-id-931) (let ((syntmp-id-969 (let ((syntmp-e-971 (syntmp-syntax-object-expression-102 syntmp-id-931))) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971))) (syntmp-w1-970 (syntmp-syntax-object-wrap-103 syntmp-id-931))) (let ((syntmp-marks-972 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-932) (syntmp-wrap-marks-120 syntmp-w1-970)))) (call-with-values (lambda () (syntmp-search-933 syntmp-id-969 (syntmp-wrap-subst-121 syntmp-w-932) syntmp-marks-972)) (lambda (syntmp-new-id-973 syntmp-marks-974) (or syntmp-new-id-973 (call-with-values (lambda () (syntmp-search-933 syntmp-id-969 (syntmp-wrap-subst-121 syntmp-w1-970) syntmp-marks-974)) (lambda (syntmp-x-976 . syntmp-ignore-975) syntmp-x-976)) syntmp-id-969)))))) ((annotation? syntmp-id-931) (let ((syntmp-id-977 (let ((syntmp-e-978 syntmp-id-931)) (if (annotation? syntmp-e-978) (annotation-expression syntmp-e-978) syntmp-e-978)))) (or (call-with-values (lambda () (syntmp-search-933 syntmp-id-977 (syntmp-wrap-subst-121 syntmp-w-932) (syntmp-wrap-marks-120 syntmp-w-932))) (lambda (syntmp-x-980 . syntmp-ignore-979) syntmp-x-980)) syntmp-id-977))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-931)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-981 syntmp-y-982) (or (eq? syntmp-x-981 syntmp-y-982) (and (not (null? syntmp-x-981)) (not (null? syntmp-y-982)) (eq? (car syntmp-x-981) (car syntmp-y-982)) (syntmp-same-marks?-138 (cdr syntmp-x-981) (cdr syntmp-y-982)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-983 syntmp-m2-984) (syntmp-smart-append-135 syntmp-m1-983 syntmp-m2-984))) (syntmp-join-wraps-136 (lambda (syntmp-w1-985 syntmp-w2-986) (let ((syntmp-m1-987 (syntmp-wrap-marks-120 syntmp-w1-985)) (syntmp-s1-988 (syntmp-wrap-subst-121 syntmp-w1-985))) (if (null? syntmp-m1-987) (if (null? syntmp-s1-988) syntmp-w2-986 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-986) (syntmp-smart-append-135 syntmp-s1-988 (syntmp-wrap-subst-121 syntmp-w2-986)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-987 (syntmp-wrap-marks-120 syntmp-w2-986)) (syntmp-smart-append-135 syntmp-s1-988 (syntmp-wrap-subst-121 syntmp-w2-986))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-989 syntmp-m2-990) (if (null? syntmp-m2-990) syntmp-m1-989 (append syntmp-m1-989 syntmp-m2-990)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-991 syntmp-labels-992 syntmp-w-993) (if (null? syntmp-ids-991) syntmp-w-993 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-993) (cons (let ((syntmp-labelvec-994 (list->vector syntmp-labels-992))) (let ((syntmp-n-995 (vector-length syntmp-labelvec-994))) (let ((syntmp-symnamevec-996 (make-vector syntmp-n-995)) (syntmp-marksvec-997 (make-vector syntmp-n-995))) (begin (let syntmp-f-998 ((syntmp-ids-999 syntmp-ids-991) (syntmp-i-1000 0)) (if (not (null? syntmp-ids-999)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-999) syntmp-w-993)) (lambda (syntmp-symname-1001 syntmp-marks-1002) (begin (vector-set! syntmp-symnamevec-996 syntmp-i-1000 syntmp-symname-1001) (vector-set! syntmp-marksvec-997 syntmp-i-1000 syntmp-marks-1002) (syntmp-f-998 (cdr syntmp-ids-999) (syntmp-fx+-85 syntmp-i-1000 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-996 syntmp-marksvec-997 syntmp-labelvec-994))))) (syntmp-wrap-subst-121 syntmp-w-993)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1003 syntmp-id-1004 syntmp-label-1005) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1003 (cons (let ((syntmp-e-1006 (syntmp-syntax-object-expression-102 syntmp-id-1004))) (if (annotation? syntmp-e-1006) (annotation-expression syntmp-e-1006) syntmp-e-1006)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1003))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1003 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1004)) (syntmp-ribcage-marks-127 syntmp-ribcage-1003))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1003 (cons syntmp-label-1005 (syntmp-ribcage-labels-128 syntmp-ribcage-1003)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1007) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1007)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1007))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1008 syntmp-update-1009) (vector-set! syntmp-x-1008 3 syntmp-update-1009))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 2 syntmp-update-1011))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 1 syntmp-update-1013))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1014) (vector-ref syntmp-x-1014 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1015) (vector-ref syntmp-x-1015 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1017) (and (vector? syntmp-x-1017) (= (vector-length syntmp-x-1017) 4) (eq? (vector-ref syntmp-x-1017 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1018 syntmp-marks-1019 syntmp-labels-1020) (vector (quote ribcage) syntmp-symnames-1018 syntmp-marks-1019 syntmp-labels-1020))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1021) (if (null? syntmp-ls-1021) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1021)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1022 syntmp-w-1023) (if (syntmp-syntax-object?-101 syntmp-x-1022) (values (let ((syntmp-e-1024 (syntmp-syntax-object-expression-102 syntmp-x-1022))) (if (annotation? syntmp-e-1024) (annotation-expression syntmp-e-1024) syntmp-e-1024)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1023) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1022)))) (values (let ((syntmp-e-1025 syntmp-x-1022)) (if (annotation? syntmp-e-1025) (annotation-expression syntmp-e-1025) syntmp-e-1025)) (syntmp-wrap-marks-120 syntmp-w-1023))))) (syntmp-id?-117 (lambda (syntmp-x-1026) (cond ((symbol? syntmp-x-1026) #t) ((syntmp-syntax-object?-101 syntmp-x-1026) (symbol? (let ((syntmp-e-1027 (syntmp-syntax-object-expression-102 syntmp-x-1026))) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)))) ((annotation? syntmp-x-1026) (symbol? (annotation-expression syntmp-x-1026))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1028) (and (syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1030 syntmp-sym-1031 syntmp-val-1032) (syntmp-put-global-definition-hook-92 syntmp-sym-1031 (cons syntmp-type-1030 syntmp-val-1032)))) (syntmp-lookup-114 (lambda (syntmp-x-1033 syntmp-r-1034) (cond ((assq syntmp-x-1033 syntmp-r-1034) => cdr) ((symbol? syntmp-x-1033) (or (syntmp-get-global-definition-hook-93 syntmp-x-1033) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1035) (if (null? syntmp-r-1035) (quote ()) (let ((syntmp-a-1036 (car syntmp-r-1035))) (if (eq? (cadr syntmp-a-1036) (quote macro)) (cons syntmp-a-1036 (syntmp-macros-only-env-113 (cdr syntmp-r-1035))) (syntmp-macros-only-env-113 (cdr syntmp-r-1035))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1037 syntmp-vars-1038 syntmp-r-1039) (if (null? syntmp-labels-1037) syntmp-r-1039 (syntmp-extend-var-env-112 (cdr syntmp-labels-1037) (cdr syntmp-vars-1038) (cons (cons (car syntmp-labels-1037) (cons (quote lexical) (car syntmp-vars-1038))) syntmp-r-1039))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1040 syntmp-bindings-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-env-111 (cdr syntmp-labels-1040) (cdr syntmp-bindings-1041) (cons (cons (car syntmp-labels-1040) (car syntmp-bindings-1041)) syntmp-r-1042))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1043) (cond ((annotation? syntmp-x-1043) (annotation-source syntmp-x-1043)) ((syntmp-syntax-object?-101 syntmp-x-1043) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1043))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1044 syntmp-update-1045) (vector-set! syntmp-x-1044 3 syntmp-update-1045))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1046 syntmp-update-1047) (vector-set! syntmp-x-1046 2 syntmp-update-1047))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1048 syntmp-update-1049) (vector-set! syntmp-x-1048 1 syntmp-update-1049))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1050) (vector-ref syntmp-x-1050 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1051) (vector-ref syntmp-x-1051 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1052) (vector-ref syntmp-x-1052 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1053) (and (vector? syntmp-x-1053) (= (vector-length syntmp-x-1053) 4) (eq? (vector-ref syntmp-x-1053 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1054 syntmp-wrap-1055 syntmp-module-1056) (vector (quote syntax-object) syntmp-expression-1054 syntmp-wrap-1055 syntmp-module-1056))) (syntmp-build-letrec-99 (lambda (syntmp-src-1057 syntmp-vars-1058 syntmp-val-exps-1059 syntmp-body-exp-1060) (if (null? syntmp-vars-1058) (syntmp-build-annotated-94 syntmp-src-1057 syntmp-body-exp-1060) (syntmp-build-annotated-94 syntmp-src-1057 (list (quote letrec) (map list syntmp-vars-1058 syntmp-val-exps-1059) syntmp-body-exp-1060))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1061 syntmp-vars-1062 syntmp-val-exps-1063 syntmp-body-exp-1064) (if (null? syntmp-vars-1062) (syntmp-build-annotated-94 syntmp-src-1061 syntmp-body-exp-1064) (syntmp-build-annotated-94 syntmp-src-1061 (list (quote let) (car syntmp-vars-1062) (map list (cdr syntmp-vars-1062) syntmp-val-exps-1063) syntmp-body-exp-1064))))) (syntmp-build-let-97 (lambda (syntmp-src-1065 syntmp-vars-1066 syntmp-val-exps-1067 syntmp-body-exp-1068) (if (null? syntmp-vars-1066) (syntmp-build-annotated-94 syntmp-src-1065 syntmp-body-exp-1068) (syntmp-build-annotated-94 syntmp-src-1065 (list (quote let) (map list syntmp-vars-1066 syntmp-val-exps-1067) syntmp-body-exp-1068))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1069 syntmp-exps-1070) (if (null? (cdr syntmp-exps-1070)) (syntmp-build-annotated-94 syntmp-src-1069 (car syntmp-exps-1070)) (syntmp-build-annotated-94 syntmp-src-1069 (cons (quote begin) syntmp-exps-1070))))) (syntmp-build-data-95 (lambda (syntmp-src-1071 syntmp-exp-1072) (if (and (self-evaluating? syntmp-exp-1072) (not (vector? syntmp-exp-1072))) (syntmp-build-annotated-94 syntmp-src-1071 syntmp-exp-1072) (syntmp-build-annotated-94 syntmp-src-1071 (list (quote quote) syntmp-exp-1072))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1073 syntmp-exp-1074) (if (and syntmp-src-1073 (not (annotation? syntmp-exp-1074))) (make-annotation syntmp-exp-1074 syntmp-src-1073 #t) syntmp-exp-1074))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1075) (getprop syntmp-symbol-1075 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1076 syntmp-binding-1077) (putprop syntmp-symbol-1076 (quote *sc-expander*) syntmp-binding-1077))) (syntmp-error-hook-91 (lambda (syntmp-who-1078 syntmp-why-1079 syntmp-what-1080) (error syntmp-who-1078 "~a ~s" syntmp-why-1079 syntmp-what-1080))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1081 syntmp-mod-1082) (eval (list syntmp-noexpand-84 syntmp-x-1081) (or syntmp-mod-1082 (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1083 syntmp-mod-1084) (eval (list syntmp-noexpand-84 syntmp-x-1083) (or syntmp-mod-1084 (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1085 syntmp-r-1086 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089) ((lambda (syntmp-tmp-1090) ((lambda (syntmp-tmp-1091) (if (if syntmp-tmp-1091 (apply (lambda (syntmp-_-1092 syntmp-var-1093 syntmp-val-1094 syntmp-e1-1095 syntmp-e2-1096) (syntmp-valid-bound-ids?-142 syntmp-var-1093)) syntmp-tmp-1091) #f) (apply (lambda (syntmp-_-1098 syntmp-var-1099 syntmp-val-1100 syntmp-e1-1101 syntmp-e2-1102) (let ((syntmp-names-1103 (map (lambda (syntmp-x-1104) (syntmp-id-var-name-139 syntmp-x-1104 syntmp-w-1087)) syntmp-var-1099))) (begin (for-each (lambda (syntmp-id-1106 syntmp-n-1107) (let ((syntmp-t-1108 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1107 syntmp-r-1086)))) (if (memv syntmp-t-1108 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1106 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089) "identifier out of context")))) syntmp-var-1099 syntmp-names-1103) (syntmp-chi-body-157 (cons syntmp-e1-1101 syntmp-e2-1102) (syntmp-source-wrap-146 syntmp-e-1085 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089) (syntmp-extend-env-111 syntmp-names-1103 (let ((syntmp-trans-r-1111 (syntmp-macros-only-env-113 syntmp-r-1086))) (map (lambda (syntmp-x-1112) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1112 syntmp-trans-r-1111 syntmp-w-1087 syntmp-mod-1089) syntmp-mod-1089))) syntmp-val-1100)) syntmp-r-1086) syntmp-w-1087 syntmp-mod-1089)))) syntmp-tmp-1091) ((lambda (syntmp-_-1114) (syntax-error (syntmp-source-wrap-146 syntmp-e-1085 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089))) syntmp-tmp-1090))) (syntax-dispatch syntmp-tmp-1090 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1085))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1115 syntmp-r-1116 syntmp-w-1117 syntmp-s-1118 syntmp-mod-1119) ((lambda (syntmp-tmp-1120) ((lambda (syntmp-tmp-1121) (if syntmp-tmp-1121 (apply (lambda (syntmp-_-1122 syntmp-e-1123) (syntmp-build-data-95 syntmp-s-1118 (syntmp-strip-164 syntmp-e-1123 syntmp-w-1117))) syntmp-tmp-1121) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1115 syntmp-w-1117 syntmp-s-1118 syntmp-mod-1119))) syntmp-tmp-1120))) (syntax-dispatch syntmp-tmp-1120 (quote (any any))))) syntmp-e-1115))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1132 (lambda (syntmp-x-1133) (let ((syntmp-t-1134 (car syntmp-x-1133))) (if (memv syntmp-t-1134 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1133)) (if (memv syntmp-t-1134 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1133)) (if (memv syntmp-t-1134 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1133)) (if (memv syntmp-t-1134 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1133) (syntmp-regen-1132 (caddr syntmp-x-1133)))) (if (memv syntmp-t-1134 (quote (map))) (let ((syntmp-ls-1135 (map syntmp-regen-1132 (cdr syntmp-x-1133)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1135) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1135))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1133)) (map syntmp-regen-1132 (cdr syntmp-x-1133)))))))))))) (syntmp-gen-vector-1131 (lambda (syntmp-x-1136) (cond ((eq? (car syntmp-x-1136) (quote list)) (cons (quote vector) (cdr syntmp-x-1136))) ((eq? (car syntmp-x-1136) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1136)))) (else (list (quote list->vector) syntmp-x-1136))))) (syntmp-gen-append-1130 (lambda (syntmp-x-1137 syntmp-y-1138) (if (equal? syntmp-y-1138 (quote (quote ()))) syntmp-x-1137 (list (quote append) syntmp-x-1137 syntmp-y-1138)))) (syntmp-gen-cons-1129 (lambda (syntmp-x-1139 syntmp-y-1140) (let ((syntmp-t-1141 (car syntmp-y-1140))) (if (memv syntmp-t-1141 (quote (quote))) (if (eq? (car syntmp-x-1139) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1139) (cadr syntmp-y-1140))) (if (eq? (cadr syntmp-y-1140) (quote ())) (list (quote list) syntmp-x-1139) (list (quote cons) syntmp-x-1139 syntmp-y-1140))) (if (memv syntmp-t-1141 (quote (list))) (cons (quote list) (cons syntmp-x-1139 (cdr syntmp-y-1140))) (list (quote cons) syntmp-x-1139 syntmp-y-1140)))))) (syntmp-gen-map-1128 (lambda (syntmp-e-1142 syntmp-map-env-1143) (let ((syntmp-formals-1144 (map cdr syntmp-map-env-1143)) (syntmp-actuals-1145 (map (lambda (syntmp-x-1146) (list (quote ref) (car syntmp-x-1146))) syntmp-map-env-1143))) (cond ((eq? (car syntmp-e-1142) (quote ref)) (car syntmp-actuals-1145)) ((andmap (lambda (syntmp-x-1147) (and (eq? (car syntmp-x-1147) (quote ref)) (memq (cadr syntmp-x-1147) syntmp-formals-1144))) (cdr syntmp-e-1142)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1142)) (map (let ((syntmp-r-1148 (map cons syntmp-formals-1144 syntmp-actuals-1145))) (lambda (syntmp-x-1149) (cdr (assq (cadr syntmp-x-1149) syntmp-r-1148)))) (cdr syntmp-e-1142))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1144 syntmp-e-1142) syntmp-actuals-1145))))))) (syntmp-gen-mappend-1127 (lambda (syntmp-e-1150 syntmp-map-env-1151) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1128 syntmp-e-1150 syntmp-map-env-1151)))) (syntmp-gen-ref-1126 (lambda (syntmp-src-1152 syntmp-var-1153 syntmp-level-1154 syntmp-maps-1155) (if (syntmp-fx=-87 syntmp-level-1154 0) (values syntmp-var-1153 syntmp-maps-1155) (if (null? syntmp-maps-1155) (syntax-error syntmp-src-1152 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1126 syntmp-src-1152 syntmp-var-1153 (syntmp-fx--86 syntmp-level-1154 1) (cdr syntmp-maps-1155))) (lambda (syntmp-outer-var-1156 syntmp-outer-maps-1157) (let ((syntmp-b-1158 (assq syntmp-outer-var-1156 (car syntmp-maps-1155)))) (if syntmp-b-1158 (values (cdr syntmp-b-1158) syntmp-maps-1155) (let ((syntmp-inner-var-1159 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1159 (cons (cons (cons syntmp-outer-var-1156 syntmp-inner-var-1159) (car syntmp-maps-1155)) syntmp-outer-maps-1157))))))))))) (syntmp-gen-syntax-1125 (lambda (syntmp-src-1160 syntmp-e-1161 syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164) (if (syntmp-id?-117 syntmp-e-1161) (let ((syntmp-label-1165 (syntmp-id-var-name-139 syntmp-e-1161 (quote (()))))) (let ((syntmp-b-1166 (syntmp-lookup-114 syntmp-label-1165 syntmp-r-1162))) (if (eq? (syntmp-binding-type-109 syntmp-b-1166) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1167 (syntmp-binding-value-110 syntmp-b-1166))) (syntmp-gen-ref-1126 syntmp-src-1160 (car syntmp-var.lev-1167) (cdr syntmp-var.lev-1167) syntmp-maps-1163))) (lambda (syntmp-var-1168 syntmp-maps-1169) (values (list (quote ref) syntmp-var-1168) syntmp-maps-1169))) (if (syntmp-ellipsis?-1164 syntmp-e-1161) (syntax-error syntmp-src-1160 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1161) syntmp-maps-1163))))) ((lambda (syntmp-tmp-1170) ((lambda (syntmp-tmp-1171) (if (if syntmp-tmp-1171 (apply (lambda (syntmp-dots-1172 syntmp-e-1173) (syntmp-ellipsis?-1164 syntmp-dots-1172)) syntmp-tmp-1171) #f) (apply (lambda (syntmp-dots-1174 syntmp-e-1175) (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-e-1175 syntmp-r-1162 syntmp-maps-1163 (lambda (syntmp-x-1176) #f))) syntmp-tmp-1171) ((lambda (syntmp-tmp-1177) (if (if syntmp-tmp-1177 (apply (lambda (syntmp-x-1178 syntmp-dots-1179 syntmp-y-1180) (syntmp-ellipsis?-1164 syntmp-dots-1179)) syntmp-tmp-1177) #f) (apply (lambda (syntmp-x-1181 syntmp-dots-1182 syntmp-y-1183) (let syntmp-f-1184 ((syntmp-y-1185 syntmp-y-1183) (syntmp-k-1186 (lambda (syntmp-maps-1187) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-x-1181 syntmp-r-1162 (cons (quote ()) syntmp-maps-1187) syntmp-ellipsis?-1164)) (lambda (syntmp-x-1188 syntmp-maps-1189) (if (null? (car syntmp-maps-1189)) (syntax-error syntmp-src-1160 "extra ellipsis in syntax form") (values (syntmp-gen-map-1128 syntmp-x-1188 (car syntmp-maps-1189)) (cdr syntmp-maps-1189)))))))) ((lambda (syntmp-tmp-1190) ((lambda (syntmp-tmp-1191) (if (if syntmp-tmp-1191 (apply (lambda (syntmp-dots-1192 syntmp-y-1193) (syntmp-ellipsis?-1164 syntmp-dots-1192)) syntmp-tmp-1191) #f) (apply (lambda (syntmp-dots-1194 syntmp-y-1195) (syntmp-f-1184 syntmp-y-1195 (lambda (syntmp-maps-1196) (call-with-values (lambda () (syntmp-k-1186 (cons (quote ()) syntmp-maps-1196))) (lambda (syntmp-x-1197 syntmp-maps-1198) (if (null? (car syntmp-maps-1198)) (syntax-error syntmp-src-1160 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1127 syntmp-x-1197 (car syntmp-maps-1198)) (cdr syntmp-maps-1198)))))))) syntmp-tmp-1191) ((lambda (syntmp-_-1199) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-y-1185 syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164)) (lambda (syntmp-y-1200 syntmp-maps-1201) (call-with-values (lambda () (syntmp-k-1186 syntmp-maps-1201)) (lambda (syntmp-x-1202 syntmp-maps-1203) (values (syntmp-gen-append-1130 syntmp-x-1202 syntmp-y-1200) syntmp-maps-1203)))))) syntmp-tmp-1190))) (syntax-dispatch syntmp-tmp-1190 (quote (any . any))))) syntmp-y-1185))) syntmp-tmp-1177) ((lambda (syntmp-tmp-1204) (if syntmp-tmp-1204 (apply (lambda (syntmp-x-1205 syntmp-y-1206) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-x-1205 syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164)) (lambda (syntmp-x-1207 syntmp-maps-1208) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-y-1206 syntmp-r-1162 syntmp-maps-1208 syntmp-ellipsis?-1164)) (lambda (syntmp-y-1209 syntmp-maps-1210) (values (syntmp-gen-cons-1129 syntmp-x-1207 syntmp-y-1209) syntmp-maps-1210)))))) syntmp-tmp-1204) ((lambda (syntmp-tmp-1211) (if syntmp-tmp-1211 (apply (lambda (syntmp-e1-1212 syntmp-e2-1213) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 (cons syntmp-e1-1212 syntmp-e2-1213) syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164)) (lambda (syntmp-e-1215 syntmp-maps-1216) (values (syntmp-gen-vector-1131 syntmp-e-1215) syntmp-maps-1216)))) syntmp-tmp-1211) ((lambda (syntmp-_-1217) (values (list (quote quote) syntmp-e-1161) syntmp-maps-1163)) syntmp-tmp-1170))) (syntax-dispatch syntmp-tmp-1170 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1170 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1170 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1170 (quote (any any))))) syntmp-e-1161))))) (lambda (syntmp-e-1218 syntmp-r-1219 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) (let ((syntmp-e-1223 (syntmp-source-wrap-146 syntmp-e-1218 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222))) ((lambda (syntmp-tmp-1224) ((lambda (syntmp-tmp-1225) (if syntmp-tmp-1225 (apply (lambda (syntmp-_-1226 syntmp-x-1227) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-e-1223 syntmp-x-1227 syntmp-r-1219 (quote ()) syntmp-ellipsis?-162)) (lambda (syntmp-e-1228 syntmp-maps-1229) (syntmp-regen-1132 syntmp-e-1228)))) syntmp-tmp-1225) ((lambda (syntmp-_-1230) (syntax-error syntmp-e-1223)) syntmp-tmp-1224))) (syntax-dispatch syntmp-tmp-1224 (quote (any any))))) syntmp-e-1223))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1231 syntmp-r-1232 syntmp-w-1233 syntmp-s-1234 syntmp-mod-1235) ((lambda (syntmp-tmp-1236) ((lambda (syntmp-tmp-1237) (if syntmp-tmp-1237 (apply (lambda (syntmp-_-1238 syntmp-c-1239) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1231 syntmp-w-1233 syntmp-s-1234 syntmp-mod-1235) syntmp-c-1239 syntmp-r-1232 syntmp-w-1233 syntmp-mod-1235 (lambda (syntmp-vars-1240 syntmp-body-1241) (syntmp-build-annotated-94 syntmp-s-1234 (list (quote lambda) syntmp-vars-1240 syntmp-body-1241))))) syntmp-tmp-1237) (syntax-error syntmp-tmp-1236))) (syntax-dispatch syntmp-tmp-1236 (quote (any . any))))) syntmp-e-1231))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1242 (lambda (syntmp-e-1243 syntmp-r-1244 syntmp-w-1245 syntmp-s-1246 syntmp-mod-1247 syntmp-constructor-1248 syntmp-ids-1249 syntmp-vals-1250 syntmp-exps-1251) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1249)) (syntax-error syntmp-e-1243 "duplicate bound variable in") (let ((syntmp-labels-1252 (syntmp-gen-labels-123 syntmp-ids-1249)) (syntmp-new-vars-1253 (map syntmp-gen-var-165 syntmp-ids-1249))) (let ((syntmp-nw-1254 (syntmp-make-binding-wrap-134 syntmp-ids-1249 syntmp-labels-1252 syntmp-w-1245)) (syntmp-nr-1255 (syntmp-extend-var-env-112 syntmp-labels-1252 syntmp-new-vars-1253 syntmp-r-1244))) (syntmp-constructor-1248 syntmp-s-1246 syntmp-new-vars-1253 (map (lambda (syntmp-x-1256) (syntmp-chi-153 syntmp-x-1256 syntmp-r-1244 syntmp-w-1245 syntmp-mod-1247)) syntmp-vals-1250) (syntmp-chi-body-157 syntmp-exps-1251 (syntmp-source-wrap-146 syntmp-e-1243 syntmp-nw-1254 syntmp-s-1246 syntmp-mod-1247) syntmp-nr-1255 syntmp-nw-1254 syntmp-mod-1247)))))))) (lambda (syntmp-e-1257 syntmp-r-1258 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261) ((lambda (syntmp-tmp-1262) ((lambda (syntmp-tmp-1263) (if syntmp-tmp-1263 (apply (lambda (syntmp-_-1264 syntmp-id-1265 syntmp-val-1266 syntmp-e1-1267 syntmp-e2-1268) (syntmp-chi-let-1242 syntmp-e-1257 syntmp-r-1258 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261 syntmp-build-let-97 syntmp-id-1265 syntmp-val-1266 (cons syntmp-e1-1267 syntmp-e2-1268))) syntmp-tmp-1263) ((lambda (syntmp-tmp-1272) (if (if syntmp-tmp-1272 (apply (lambda (syntmp-_-1273 syntmp-f-1274 syntmp-id-1275 syntmp-val-1276 syntmp-e1-1277 syntmp-e2-1278) (syntmp-id?-117 syntmp-f-1274)) syntmp-tmp-1272) #f) (apply (lambda (syntmp-_-1279 syntmp-f-1280 syntmp-id-1281 syntmp-val-1282 syntmp-e1-1283 syntmp-e2-1284) (syntmp-chi-let-1242 syntmp-e-1257 syntmp-r-1258 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261 syntmp-build-named-let-98 (cons syntmp-f-1280 syntmp-id-1281) syntmp-val-1282 (cons syntmp-e1-1283 syntmp-e2-1284))) syntmp-tmp-1272) ((lambda (syntmp-_-1288) (syntax-error (syntmp-source-wrap-146 syntmp-e-1257 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261))) syntmp-tmp-1262))) (syntax-dispatch syntmp-tmp-1262 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1262 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1257)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1289 syntmp-r-1290 syntmp-w-1291 syntmp-s-1292 syntmp-mod-1293) ((lambda (syntmp-tmp-1294) ((lambda (syntmp-tmp-1295) (if syntmp-tmp-1295 (apply (lambda (syntmp-_-1296 syntmp-id-1297 syntmp-val-1298 syntmp-e1-1299 syntmp-e2-1300) (let ((syntmp-ids-1301 syntmp-id-1297)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1301)) (syntax-error syntmp-e-1289 "duplicate bound variable in") (let ((syntmp-labels-1303 (syntmp-gen-labels-123 syntmp-ids-1301)) (syntmp-new-vars-1304 (map syntmp-gen-var-165 syntmp-ids-1301))) (let ((syntmp-w-1305 (syntmp-make-binding-wrap-134 syntmp-ids-1301 syntmp-labels-1303 syntmp-w-1291)) (syntmp-r-1306 (syntmp-extend-var-env-112 syntmp-labels-1303 syntmp-new-vars-1304 syntmp-r-1290))) (syntmp-build-letrec-99 syntmp-s-1292 syntmp-new-vars-1304 (map (lambda (syntmp-x-1307) (syntmp-chi-153 syntmp-x-1307 syntmp-r-1306 syntmp-w-1305 syntmp-mod-1293)) syntmp-val-1298) (syntmp-chi-body-157 (cons syntmp-e1-1299 syntmp-e2-1300) (syntmp-source-wrap-146 syntmp-e-1289 syntmp-w-1305 syntmp-s-1292 syntmp-mod-1293) syntmp-r-1306 syntmp-w-1305 syntmp-mod-1293))))))) syntmp-tmp-1295) ((lambda (syntmp-_-1310) (syntax-error (syntmp-source-wrap-146 syntmp-e-1289 syntmp-w-1291 syntmp-s-1292 syntmp-mod-1293))) syntmp-tmp-1294))) (syntax-dispatch syntmp-tmp-1294 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1289))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1311 syntmp-r-1312 syntmp-w-1313 syntmp-s-1314 syntmp-mod-1315) ((lambda (syntmp-tmp-1316) ((lambda (syntmp-tmp-1317) (if (if syntmp-tmp-1317 (apply (lambda (syntmp-_-1318 syntmp-id-1319 syntmp-val-1320) (syntmp-id?-117 syntmp-id-1319)) syntmp-tmp-1317) #f) (apply (lambda (syntmp-_-1321 syntmp-id-1322 syntmp-val-1323) (let ((syntmp-val-1324 (syntmp-chi-153 syntmp-val-1323 syntmp-r-1312 syntmp-w-1313 syntmp-mod-1315)) (syntmp-n-1325 (syntmp-id-var-name-139 syntmp-id-1322 syntmp-w-1313))) (let ((syntmp-b-1326 (syntmp-lookup-114 syntmp-n-1325 syntmp-r-1312))) (let ((syntmp-t-1327 (syntmp-binding-type-109 syntmp-b-1326))) (if (memv syntmp-t-1327 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1314 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1326) syntmp-val-1324)) (if (memv syntmp-t-1327 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1314 (list (quote set!) (make-module-ref #f syntmp-n-1325 syntmp-mod-1315) syntmp-val-1324)) (if (memv syntmp-t-1327 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1322 syntmp-w-1313 #f) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1311 syntmp-w-1313 syntmp-s-1314 syntmp-mod-1315))))))))) syntmp-tmp-1317) ((lambda (syntmp-tmp-1328) (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-getter-1330 syntmp-arg-1331 syntmp-val-1332) (syntmp-build-annotated-94 syntmp-s-1314 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-getter-1330) syntmp-r-1312 syntmp-w-1313 syntmp-mod-1315) (map (lambda (syntmp-e-1333) (syntmp-chi-153 syntmp-e-1333 syntmp-r-1312 syntmp-w-1313 syntmp-mod-1315)) (append syntmp-arg-1331 (list syntmp-val-1332)))))) syntmp-tmp-1328) ((lambda (syntmp-_-1335) (syntax-error (syntmp-source-wrap-146 syntmp-e-1311 syntmp-w-1313 syntmp-s-1314 syntmp-mod-1315))) syntmp-tmp-1316))) (syntax-dispatch syntmp-tmp-1316 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1316 (quote (any any any))))) syntmp-e-1311))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1339 (lambda (syntmp-x-1340 syntmp-keys-1341 syntmp-clauses-1342 syntmp-r-1343 syntmp-mod-1344) (if (null? syntmp-clauses-1342) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1340)) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-pat-1347 syntmp-exp-1348) (if (and (syntmp-id?-117 syntmp-pat-1347) (andmap (lambda (syntmp-x-1349) (not (syntmp-free-id=?-140 syntmp-pat-1347 syntmp-x-1349))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-keys-1341))) (let ((syntmp-labels-1350 (list (syntmp-gen-label-122))) (syntmp-var-1351 (syntmp-gen-var-165 syntmp-pat-1347))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1351) (syntmp-chi-153 syntmp-exp-1348 (syntmp-extend-env-111 syntmp-labels-1350 (list (cons (quote syntax) (cons syntmp-var-1351 0))) syntmp-r-1343) (syntmp-make-binding-wrap-134 (list syntmp-pat-1347) syntmp-labels-1350 (quote (()))) syntmp-mod-1344))) syntmp-x-1340))) (syntmp-gen-clause-1338 syntmp-x-1340 syntmp-keys-1341 (cdr syntmp-clauses-1342) syntmp-r-1343 syntmp-pat-1347 #t syntmp-exp-1348 syntmp-mod-1344))) syntmp-tmp-1346) ((lambda (syntmp-tmp-1352) (if syntmp-tmp-1352 (apply (lambda (syntmp-pat-1353 syntmp-fender-1354 syntmp-exp-1355) (syntmp-gen-clause-1338 syntmp-x-1340 syntmp-keys-1341 (cdr syntmp-clauses-1342) syntmp-r-1343 syntmp-pat-1353 syntmp-fender-1354 syntmp-exp-1355 syntmp-mod-1344)) syntmp-tmp-1352) ((lambda (syntmp-_-1356) (syntax-error (car syntmp-clauses-1342) "invalid syntax-case clause")) syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1345 (quote (any any))))) (car syntmp-clauses-1342))))) (syntmp-gen-clause-1338 (lambda (syntmp-x-1357 syntmp-keys-1358 syntmp-clauses-1359 syntmp-r-1360 syntmp-pat-1361 syntmp-fender-1362 syntmp-exp-1363 syntmp-mod-1364) (call-with-values (lambda () (syntmp-convert-pattern-1336 syntmp-pat-1361 syntmp-keys-1358)) (lambda (syntmp-p-1365 syntmp-pvars-1366) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1366))) (syntax-error syntmp-pat-1361 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1367) (not (syntmp-ellipsis?-162 (car syntmp-x-1367)))) syntmp-pvars-1366)) (syntax-error syntmp-pat-1361 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1368 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1368) (let ((syntmp-y-1369 (syntmp-build-annotated-94 #f syntmp-y-1368))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1370) ((lambda (syntmp-tmp-1371) (if syntmp-tmp-1371 (apply (lambda () syntmp-y-1369) syntmp-tmp-1371) ((lambda (syntmp-_-1372) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1369 (syntmp-build-dispatch-call-1337 syntmp-pvars-1366 syntmp-fender-1362 syntmp-y-1369 syntmp-r-1360 syntmp-mod-1364) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1370))) (syntax-dispatch syntmp-tmp-1370 (quote #(atom #t))))) syntmp-fender-1362) (syntmp-build-dispatch-call-1337 syntmp-pvars-1366 syntmp-exp-1363 syntmp-y-1369 syntmp-r-1360 syntmp-mod-1364) (syntmp-gen-syntax-case-1339 syntmp-x-1357 syntmp-keys-1358 syntmp-clauses-1359 syntmp-r-1360 syntmp-mod-1364)))))) (if (eq? syntmp-p-1365 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1357)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1357 (syntmp-build-data-95 #f syntmp-p-1365))))))))))))) (syntmp-build-dispatch-call-1337 (lambda (syntmp-pvars-1373 syntmp-exp-1374 syntmp-y-1375 syntmp-r-1376 syntmp-mod-1377) (let ((syntmp-ids-1378 (map car syntmp-pvars-1373)) (syntmp-levels-1379 (map cdr syntmp-pvars-1373))) (let ((syntmp-labels-1380 (syntmp-gen-labels-123 syntmp-ids-1378)) (syntmp-new-vars-1381 (map syntmp-gen-var-165 syntmp-ids-1378))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1381 (syntmp-chi-153 syntmp-exp-1374 (syntmp-extend-env-111 syntmp-labels-1380 (map (lambda (syntmp-var-1382 syntmp-level-1383) (cons (quote syntax) (cons syntmp-var-1382 syntmp-level-1383))) syntmp-new-vars-1381 (map cdr syntmp-pvars-1373)) syntmp-r-1376) (syntmp-make-binding-wrap-134 syntmp-ids-1378 syntmp-labels-1380 (quote (()))) syntmp-mod-1377))) syntmp-y-1375)))))) (syntmp-convert-pattern-1336 (lambda (syntmp-pattern-1384 syntmp-keys-1385) (let syntmp-cvt-1386 ((syntmp-p-1387 syntmp-pattern-1384) (syntmp-n-1388 0) (syntmp-ids-1389 (quote ()))) (if (syntmp-id?-117 syntmp-p-1387) (if (syntmp-bound-id-member?-144 syntmp-p-1387 syntmp-keys-1385) (values (vector (quote free-id) syntmp-p-1387) syntmp-ids-1389) (values (quote any) (cons (cons syntmp-p-1387 syntmp-n-1388) syntmp-ids-1389))) ((lambda (syntmp-tmp-1390) ((lambda (syntmp-tmp-1391) (if (if syntmp-tmp-1391 (apply (lambda (syntmp-x-1392 syntmp-dots-1393) (syntmp-ellipsis?-162 syntmp-dots-1393)) syntmp-tmp-1391) #f) (apply (lambda (syntmp-x-1394 syntmp-dots-1395) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-x-1394 (syntmp-fx+-85 syntmp-n-1388 1) syntmp-ids-1389)) (lambda (syntmp-p-1396 syntmp-ids-1397) (values (if (eq? syntmp-p-1396 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1396)) syntmp-ids-1397)))) syntmp-tmp-1391) ((lambda (syntmp-tmp-1398) (if syntmp-tmp-1398 (apply (lambda (syntmp-x-1399 syntmp-y-1400) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-y-1400 syntmp-n-1388 syntmp-ids-1389)) (lambda (syntmp-y-1401 syntmp-ids-1402) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-x-1399 syntmp-n-1388 syntmp-ids-1402)) (lambda (syntmp-x-1403 syntmp-ids-1404) (values (cons syntmp-x-1403 syntmp-y-1401) syntmp-ids-1404)))))) syntmp-tmp-1398) ((lambda (syntmp-tmp-1405) (if syntmp-tmp-1405 (apply (lambda () (values (quote ()) syntmp-ids-1389)) syntmp-tmp-1405) ((lambda (syntmp-tmp-1406) (if syntmp-tmp-1406 (apply (lambda (syntmp-x-1407) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-x-1407 syntmp-n-1388 syntmp-ids-1389)) (lambda (syntmp-p-1409 syntmp-ids-1410) (values (vector (quote vector) syntmp-p-1409) syntmp-ids-1410)))) syntmp-tmp-1406) ((lambda (syntmp-x-1411) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1387 (quote (())))) syntmp-ids-1389)) syntmp-tmp-1390))) (syntax-dispatch syntmp-tmp-1390 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1390 (quote ()))))) (syntax-dispatch syntmp-tmp-1390 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1390 (quote (any any))))) syntmp-p-1387)))))) (lambda (syntmp-e-1412 syntmp-r-1413 syntmp-w-1414 syntmp-s-1415 syntmp-mod-1416) (let ((syntmp-e-1417 (syntmp-source-wrap-146 syntmp-e-1412 syntmp-w-1414 syntmp-s-1415 syntmp-mod-1416))) ((lambda (syntmp-tmp-1418) ((lambda (syntmp-tmp-1419) (if syntmp-tmp-1419 (apply (lambda (syntmp-_-1420 syntmp-val-1421 syntmp-key-1422 syntmp-m-1423) (if (andmap (lambda (syntmp-x-1424) (and (syntmp-id?-117 syntmp-x-1424) (not (syntmp-ellipsis?-162 syntmp-x-1424)))) syntmp-key-1422) (let ((syntmp-x-1426 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1415 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1426) (syntmp-gen-syntax-case-1339 (syntmp-build-annotated-94 #f syntmp-x-1426) syntmp-key-1422 syntmp-m-1423 syntmp-r-1413 syntmp-mod-1416))) (syntmp-chi-153 syntmp-val-1421 syntmp-r-1413 (quote (())) syntmp-mod-1416)))) (syntax-error syntmp-e-1417 "invalid literals list in"))) syntmp-tmp-1419) (syntax-error syntmp-tmp-1418))) (syntax-dispatch syntmp-tmp-1418 (quote (any any each-any . each-any))))) syntmp-e-1417))))) (set! sc-expand (let ((syntmp-m-1429 (quote e)) (syntmp-esew-1430 (quote (eval)))) (lambda (syntmp-x-1431) (if (and (pair? syntmp-x-1431) (equal? (car syntmp-x-1431) syntmp-noexpand-84)) (cadr syntmp-x-1431) (syntmp-chi-top-152 syntmp-x-1431 (quote ()) (quote ((top))) syntmp-m-1429 syntmp-esew-1430 (current-module)))))) (set! sc-expand3 (let ((syntmp-m-1432 (quote e)) (syntmp-esew-1433 (quote (eval)))) (lambda (syntmp-x-1435 . syntmp-rest-1434) (if (and (pair? syntmp-x-1435) (equal? (car syntmp-x-1435) syntmp-noexpand-84)) (cadr syntmp-x-1435) (syntmp-chi-top-152 syntmp-x-1435 (quote ()) (quote ((top))) (if (null? syntmp-rest-1434) syntmp-m-1432 (car syntmp-rest-1434)) (if (or (null? syntmp-rest-1434) (null? (cdr syntmp-rest-1434))) syntmp-esew-1433 (cadr syntmp-rest-1434)) (current-module)))))) (set! identifier? (lambda (syntmp-x-1436) (syntmp-nonsymbol-id?-116 syntmp-x-1436))) (set! datum->syntax-object (lambda (syntmp-id-1437 syntmp-datum-1438) (syntmp-make-syntax-object-100 syntmp-datum-1438 (syntmp-syntax-object-wrap-103 syntmp-id-1437) #f))) (set! syntax-object->datum (lambda (syntmp-x-1439) (syntmp-strip-164 syntmp-x-1439 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1440) (begin (let ((syntmp-x-1441 syntmp-ls-1440)) (if (not (list? syntmp-x-1441)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1441))) (map (lambda (syntmp-x-1442) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1440)))) (set! free-identifier=? (lambda (syntmp-x-1443 syntmp-y-1444) (begin (let ((syntmp-x-1445 syntmp-x-1443)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1445)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1445))) (let ((syntmp-x-1446 syntmp-y-1444)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1446)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1446))) (syntmp-free-id=?-140 syntmp-x-1443 syntmp-y-1444)))) (set! bound-identifier=? (lambda (syntmp-x-1447 syntmp-y-1448) (begin (let ((syntmp-x-1449 syntmp-x-1447)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1449)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1449))) (let ((syntmp-x-1450 syntmp-y-1448)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1450)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1450))) (syntmp-bound-id=?-141 syntmp-x-1447 syntmp-y-1448)))) (set! syntax-error (lambda (syntmp-object-1452 . syntmp-messages-1451) (begin (for-each (lambda (syntmp-x-1453) (let ((syntmp-x-1454 syntmp-x-1453)) (if (not (string? syntmp-x-1454)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1454)))) syntmp-messages-1451) (let ((syntmp-message-1455 (if (null? syntmp-messages-1451) "invalid syntax" (apply string-append syntmp-messages-1451)))) (syntmp-error-hook-91 #f syntmp-message-1455 (syntmp-strip-164 syntmp-object-1452 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1456 syntmp-v-1457) (begin (let ((syntmp-x-1458 syntmp-sym-1456)) (if (not (symbol? syntmp-x-1458)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1458))) (let ((syntmp-x-1459 syntmp-v-1457)) (if (not (procedure? syntmp-x-1459)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1459))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1456 syntmp-v-1457)))) (letrec ((syntmp-match-1464 (lambda (syntmp-e-1465 syntmp-p-1466 syntmp-w-1467 syntmp-r-1468) (cond ((not syntmp-r-1468) #f) ((eq? syntmp-p-1466 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1465 syntmp-w-1467 #f) syntmp-r-1468)) ((syntmp-syntax-object?-101 syntmp-e-1465) (syntmp-match*-1463 (let ((syntmp-e-1469 (syntmp-syntax-object-expression-102 syntmp-e-1465))) (if (annotation? syntmp-e-1469) (annotation-expression syntmp-e-1469) syntmp-e-1469)) syntmp-p-1466 (syntmp-join-wraps-136 syntmp-w-1467 (syntmp-syntax-object-wrap-103 syntmp-e-1465)) syntmp-r-1468)) (else (syntmp-match*-1463 (let ((syntmp-e-1470 syntmp-e-1465)) (if (annotation? syntmp-e-1470) (annotation-expression syntmp-e-1470) syntmp-e-1470)) syntmp-p-1466 syntmp-w-1467 syntmp-r-1468))))) (syntmp-match*-1463 (lambda (syntmp-e-1471 syntmp-p-1472 syntmp-w-1473 syntmp-r-1474) (cond ((null? syntmp-p-1472) (and (null? syntmp-e-1471) syntmp-r-1474)) ((pair? syntmp-p-1472) (and (pair? syntmp-e-1471) (syntmp-match-1464 (car syntmp-e-1471) (car syntmp-p-1472) syntmp-w-1473 (syntmp-match-1464 (cdr syntmp-e-1471) (cdr syntmp-p-1472) syntmp-w-1473 syntmp-r-1474)))) ((eq? syntmp-p-1472 (quote each-any)) (let ((syntmp-l-1475 (syntmp-match-each-any-1461 syntmp-e-1471 syntmp-w-1473))) (and syntmp-l-1475 (cons syntmp-l-1475 syntmp-r-1474)))) (else (let ((syntmp-t-1476 (vector-ref syntmp-p-1472 0))) (if (memv syntmp-t-1476 (quote (each))) (if (null? syntmp-e-1471) (syntmp-match-empty-1462 (vector-ref syntmp-p-1472 1) syntmp-r-1474) (let ((syntmp-l-1477 (syntmp-match-each-1460 syntmp-e-1471 (vector-ref syntmp-p-1472 1) syntmp-w-1473))) (and syntmp-l-1477 (let syntmp-collect-1478 ((syntmp-l-1479 syntmp-l-1477)) (if (null? (car syntmp-l-1479)) syntmp-r-1474 (cons (map car syntmp-l-1479) (syntmp-collect-1478 (map cdr syntmp-l-1479)))))))) (if (memv syntmp-t-1476 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1471) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1471 syntmp-w-1473 #f) (vector-ref syntmp-p-1472 1)) syntmp-r-1474) (if (memv syntmp-t-1476 (quote (atom))) (and (equal? (vector-ref syntmp-p-1472 1) (syntmp-strip-164 syntmp-e-1471 syntmp-w-1473)) syntmp-r-1474) (if (memv syntmp-t-1476 (quote (vector))) (and (vector? syntmp-e-1471) (syntmp-match-1464 (vector->list syntmp-e-1471) (vector-ref syntmp-p-1472 1) syntmp-w-1473 syntmp-r-1474))))))))))) (syntmp-match-empty-1462 (lambda (syntmp-p-1480 syntmp-r-1481) (cond ((null? syntmp-p-1480) syntmp-r-1481) ((eq? syntmp-p-1480 (quote any)) (cons (quote ()) syntmp-r-1481)) ((pair? syntmp-p-1480) (syntmp-match-empty-1462 (car syntmp-p-1480) (syntmp-match-empty-1462 (cdr syntmp-p-1480) syntmp-r-1481))) ((eq? syntmp-p-1480 (quote each-any)) (cons (quote ()) syntmp-r-1481)) (else (let ((syntmp-t-1482 (vector-ref syntmp-p-1480 0))) (if (memv syntmp-t-1482 (quote (each))) (syntmp-match-empty-1462 (vector-ref syntmp-p-1480 1) syntmp-r-1481) (if (memv syntmp-t-1482 (quote (free-id atom))) syntmp-r-1481 (if (memv syntmp-t-1482 (quote (vector))) (syntmp-match-empty-1462 (vector-ref syntmp-p-1480 1) syntmp-r-1481))))))))) (syntmp-match-each-any-1461 (lambda (syntmp-e-1483 syntmp-w-1484) (cond ((annotation? syntmp-e-1483) (syntmp-match-each-any-1461 (annotation-expression syntmp-e-1483) syntmp-w-1484)) ((pair? syntmp-e-1483) (let ((syntmp-l-1485 (syntmp-match-each-any-1461 (cdr syntmp-e-1483) syntmp-w-1484))) (and syntmp-l-1485 (cons (syntmp-wrap-145 (car syntmp-e-1483) syntmp-w-1484 #f) syntmp-l-1485)))) ((null? syntmp-e-1483) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1483) (syntmp-match-each-any-1461 (syntmp-syntax-object-expression-102 syntmp-e-1483) (syntmp-join-wraps-136 syntmp-w-1484 (syntmp-syntax-object-wrap-103 syntmp-e-1483)))) (else #f)))) (syntmp-match-each-1460 (lambda (syntmp-e-1486 syntmp-p-1487 syntmp-w-1488) (cond ((annotation? syntmp-e-1486) (syntmp-match-each-1460 (annotation-expression syntmp-e-1486) syntmp-p-1487 syntmp-w-1488)) ((pair? syntmp-e-1486) (let ((syntmp-first-1489 (syntmp-match-1464 (car syntmp-e-1486) syntmp-p-1487 syntmp-w-1488 (quote ())))) (and syntmp-first-1489 (let ((syntmp-rest-1490 (syntmp-match-each-1460 (cdr syntmp-e-1486) syntmp-p-1487 syntmp-w-1488))) (and syntmp-rest-1490 (cons syntmp-first-1489 syntmp-rest-1490)))))) ((null? syntmp-e-1486) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1486) (syntmp-match-each-1460 (syntmp-syntax-object-expression-102 syntmp-e-1486) syntmp-p-1487 (syntmp-join-wraps-136 syntmp-w-1488 (syntmp-syntax-object-wrap-103 syntmp-e-1486)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1491 syntmp-p-1492) (cond ((eq? syntmp-p-1492 (quote any)) (list syntmp-e-1491)) ((syntmp-syntax-object?-101 syntmp-e-1491) (syntmp-match*-1463 (let ((syntmp-e-1493 (syntmp-syntax-object-expression-102 syntmp-e-1491))) (if (annotation? syntmp-e-1493) (annotation-expression syntmp-e-1493) syntmp-e-1493)) syntmp-p-1492 (syntmp-syntax-object-wrap-103 syntmp-e-1491) (quote ()))) (else (syntmp-match*-1463 (let ((syntmp-e-1494 syntmp-e-1491)) (if (annotation? syntmp-e-1494) (annotation-expression syntmp-e-1494) syntmp-e-1494)) syntmp-p-1492 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-153))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1495) ((lambda (syntmp-tmp-1496) ((lambda (syntmp-tmp-1497) (if syntmp-tmp-1497 (apply (lambda (syntmp-_-1498 syntmp-e1-1499 syntmp-e2-1500) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1499 syntmp-e2-1500))) syntmp-tmp-1497) ((lambda (syntmp-tmp-1502) (if syntmp-tmp-1502 (apply (lambda (syntmp-_-1503 syntmp-out-1504 syntmp-in-1505 syntmp-e1-1506 syntmp-e2-1507) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1505 (quote ()) (list syntmp-out-1504 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1506 syntmp-e2-1507))))) syntmp-tmp-1502) ((lambda (syntmp-tmp-1509) (if syntmp-tmp-1509 (apply (lambda (syntmp-_-1510 syntmp-out-1511 syntmp-in-1512 syntmp-e1-1513 syntmp-e2-1514) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1512) (quote ()) (list syntmp-out-1511 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1513 syntmp-e2-1514))))) syntmp-tmp-1509) (syntax-error syntmp-tmp-1496))) (syntax-dispatch syntmp-tmp-1496 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1496 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1496 (quote (any () any . each-any))))) syntmp-x-1495))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1536) ((lambda (syntmp-tmp-1537) ((lambda (syntmp-tmp-1538) (if syntmp-tmp-1538 (apply (lambda (syntmp-_-1539 syntmp-k-1540 syntmp-keyword-1541 syntmp-pattern-1542 syntmp-template-1543) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-k-1540 (map (lambda (syntmp-tmp-1546 syntmp-tmp-1545) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1545) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1546))) syntmp-template-1543 syntmp-pattern-1542)))))) syntmp-tmp-1538) (syntax-error syntmp-tmp-1537))) (syntax-dispatch syntmp-tmp-1537 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1536))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1557) ((lambda (syntmp-tmp-1558) ((lambda (syntmp-tmp-1559) (if (if syntmp-tmp-1559 (apply (lambda (syntmp-let*-1560 syntmp-x-1561 syntmp-v-1562 syntmp-e1-1563 syntmp-e2-1564) (andmap identifier? syntmp-x-1561)) syntmp-tmp-1559) #f) (apply (lambda (syntmp-let*-1566 syntmp-x-1567 syntmp-v-1568 syntmp-e1-1569 syntmp-e2-1570) (let syntmp-f-1571 ((syntmp-bindings-1572 (map list syntmp-x-1567 syntmp-v-1568))) (if (null? syntmp-bindings-1572) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote ()) (cons syntmp-e1-1569 syntmp-e2-1570))) ((lambda (syntmp-tmp-1576) ((lambda (syntmp-tmp-1577) (if syntmp-tmp-1577 (apply (lambda (syntmp-body-1578 syntmp-binding-1579) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list syntmp-binding-1579) syntmp-body-1578)) syntmp-tmp-1577) (syntax-error syntmp-tmp-1576))) (syntax-dispatch syntmp-tmp-1576 (quote (any any))))) (list (syntmp-f-1571 (cdr syntmp-bindings-1572)) (car syntmp-bindings-1572)))))) syntmp-tmp-1559) (syntax-error syntmp-tmp-1558))) (syntax-dispatch syntmp-tmp-1558 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1557))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1599) ((lambda (syntmp-tmp-1600) ((lambda (syntmp-tmp-1601) (if syntmp-tmp-1601 (apply (lambda (syntmp-_-1602 syntmp-var-1603 syntmp-init-1604 syntmp-step-1605 syntmp-e0-1606 syntmp-e1-1607 syntmp-c-1608) ((lambda (syntmp-tmp-1609) ((lambda (syntmp-tmp-1610) (if syntmp-tmp-1610 (apply (lambda (syntmp-step-1611) ((lambda (syntmp-tmp-1612) ((lambda (syntmp-tmp-1613) (if syntmp-tmp-1613 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1603 syntmp-init-1604) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1606) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1608 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1611))))))) syntmp-tmp-1613) ((lambda (syntmp-tmp-1618) (if syntmp-tmp-1618 (apply (lambda (syntmp-e1-1619 syntmp-e2-1620) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1603 syntmp-init-1604) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1606 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (cons syntmp-e1-1619 syntmp-e2-1620)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1608 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1611))))))) syntmp-tmp-1618) (syntax-error syntmp-tmp-1612))) (syntax-dispatch syntmp-tmp-1612 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1612 (quote ())))) syntmp-e1-1607)) syntmp-tmp-1610) (syntax-error syntmp-tmp-1609))) (syntax-dispatch syntmp-tmp-1609 (quote each-any)))) (map (lambda (syntmp-v-1627 syntmp-s-1628) ((lambda (syntmp-tmp-1629) ((lambda (syntmp-tmp-1630) (if syntmp-tmp-1630 (apply (lambda () syntmp-v-1627) syntmp-tmp-1630) ((lambda (syntmp-tmp-1631) (if syntmp-tmp-1631 (apply (lambda (syntmp-e-1632) syntmp-e-1632) syntmp-tmp-1631) ((lambda (syntmp-_-1633) (syntax-error syntmp-orig-x-1599)) syntmp-tmp-1629))) (syntax-dispatch syntmp-tmp-1629 (quote (any)))))) (syntax-dispatch syntmp-tmp-1629 (quote ())))) syntmp-s-1628)) syntmp-var-1603 syntmp-step-1605))) syntmp-tmp-1601) (syntax-error syntmp-tmp-1600))) (syntax-dispatch syntmp-tmp-1600 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1599))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1661 (lambda (syntmp-x-1665 syntmp-y-1666) ((lambda (syntmp-tmp-1667) ((lambda (syntmp-tmp-1668) (if syntmp-tmp-1668 (apply (lambda (syntmp-x-1669 syntmp-y-1670) ((lambda (syntmp-tmp-1671) ((lambda (syntmp-tmp-1672) (if syntmp-tmp-1672 (apply (lambda (syntmp-dy-1673) ((lambda (syntmp-tmp-1674) ((lambda (syntmp-tmp-1675) (if syntmp-tmp-1675 (apply (lambda (syntmp-dx-1676) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-dx-1676 syntmp-dy-1673))) syntmp-tmp-1675) ((lambda (syntmp-_-1677) (if (null? syntmp-dy-1673) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1669) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1669 syntmp-y-1670))) syntmp-tmp-1674))) (syntax-dispatch syntmp-tmp-1674 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-x-1669)) syntmp-tmp-1672) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-stuff-1679) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-x-1669 syntmp-stuff-1679))) syntmp-tmp-1678) ((lambda (syntmp-else-1680) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1669 syntmp-y-1670)) syntmp-tmp-1671))) (syntax-dispatch syntmp-tmp-1671 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . any)))))) (syntax-dispatch syntmp-tmp-1671 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-y-1670)) syntmp-tmp-1668) (syntax-error syntmp-tmp-1667))) (syntax-dispatch syntmp-tmp-1667 (quote (any any))))) (list syntmp-x-1665 syntmp-y-1666)))) (syntmp-quasiappend-1662 (lambda (syntmp-x-1681 syntmp-y-1682) ((lambda (syntmp-tmp-1683) ((lambda (syntmp-tmp-1684) (if syntmp-tmp-1684 (apply (lambda (syntmp-x-1685 syntmp-y-1686) ((lambda (syntmp-tmp-1687) ((lambda (syntmp-tmp-1688) (if syntmp-tmp-1688 (apply (lambda () syntmp-x-1685) syntmp-tmp-1688) ((lambda (syntmp-_-1689) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1685 syntmp-y-1686)) syntmp-tmp-1687))) (syntax-dispatch syntmp-tmp-1687 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) ()))))) syntmp-y-1686)) syntmp-tmp-1684) (syntax-error syntmp-tmp-1683))) (syntax-dispatch syntmp-tmp-1683 (quote (any any))))) (list syntmp-x-1681 syntmp-y-1682)))) (syntmp-quasivector-1663 (lambda (syntmp-x-1690) ((lambda (syntmp-tmp-1691) ((lambda (syntmp-x-1692) ((lambda (syntmp-tmp-1693) ((lambda (syntmp-tmp-1694) (if syntmp-tmp-1694 (apply (lambda (syntmp-x-1695) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (list->vector syntmp-x-1695))) syntmp-tmp-1694) ((lambda (syntmp-tmp-1697) (if syntmp-tmp-1697 (apply (lambda (syntmp-x-1698) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1698)) syntmp-tmp-1697) ((lambda (syntmp-_-1700) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1692)) syntmp-tmp-1693))) (syntax-dispatch syntmp-tmp-1693 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . each-any)))))) (syntax-dispatch syntmp-tmp-1693 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) each-any))))) syntmp-x-1692)) syntmp-tmp-1691)) syntmp-x-1690))) (syntmp-quasi-1664 (lambda (syntmp-p-1701 syntmp-lev-1702) ((lambda (syntmp-tmp-1703) ((lambda (syntmp-tmp-1704) (if syntmp-tmp-1704 (apply (lambda (syntmp-p-1705) (if (= syntmp-lev-1702 0) syntmp-p-1705 (syntmp-quasicons-1661 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1664 (list syntmp-p-1705) (- syntmp-lev-1702 1))))) syntmp-tmp-1704) ((lambda (syntmp-tmp-1706) (if syntmp-tmp-1706 (apply (lambda (syntmp-p-1707 syntmp-q-1708) (if (= syntmp-lev-1702 0) (syntmp-quasiappend-1662 syntmp-p-1707 (syntmp-quasi-1664 syntmp-q-1708 syntmp-lev-1702)) (syntmp-quasicons-1661 (syntmp-quasicons-1661 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1664 (list syntmp-p-1707) (- syntmp-lev-1702 1))) (syntmp-quasi-1664 syntmp-q-1708 syntmp-lev-1702)))) syntmp-tmp-1706) ((lambda (syntmp-tmp-1709) (if syntmp-tmp-1709 (apply (lambda (syntmp-p-1710) (syntmp-quasicons-1661 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1664 (list syntmp-p-1710) (+ syntmp-lev-1702 1)))) syntmp-tmp-1709) ((lambda (syntmp-tmp-1711) (if syntmp-tmp-1711 (apply (lambda (syntmp-p-1712 syntmp-q-1713) (syntmp-quasicons-1661 (syntmp-quasi-1664 syntmp-p-1712 syntmp-lev-1702) (syntmp-quasi-1664 syntmp-q-1713 syntmp-lev-1702))) syntmp-tmp-1711) ((lambda (syntmp-tmp-1714) (if syntmp-tmp-1714 (apply (lambda (syntmp-x-1715) (syntmp-quasivector-1663 (syntmp-quasi-1664 syntmp-x-1715 syntmp-lev-1702))) syntmp-tmp-1714) ((lambda (syntmp-p-1717) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-p-1717)) syntmp-tmp-1703))) (syntax-dispatch syntmp-tmp-1703 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1703 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1703 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any)))))) (syntax-dispatch syntmp-tmp-1703 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any) . any)))))) (syntax-dispatch syntmp-tmp-1703 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-p-1701)))) (lambda (syntmp-x-1718) ((lambda (syntmp-tmp-1719) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-_-1721 syntmp-e-1722) (syntmp-quasi-1664 syntmp-e-1722 0)) syntmp-tmp-1720) (syntax-error syntmp-tmp-1719))) (syntax-dispatch syntmp-tmp-1719 (quote (any any))))) syntmp-x-1718)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1782) (letrec ((syntmp-read-file-1783 (lambda (syntmp-fn-1784 syntmp-k-1785) (let ((syntmp-p-1786 (open-input-file syntmp-fn-1784))) (let syntmp-f-1787 ((syntmp-x-1788 (read syntmp-p-1786))) (if (eof-object? syntmp-x-1788) (begin (close-input-port syntmp-p-1786) (quote ())) (cons (datum->syntax-object syntmp-k-1785 syntmp-x-1788) (syntmp-f-1787 (read syntmp-p-1786))))))))) ((lambda (syntmp-tmp-1789) ((lambda (syntmp-tmp-1790) (if syntmp-tmp-1790 (apply (lambda (syntmp-k-1791 syntmp-filename-1792) (let ((syntmp-fn-1793 (syntax-object->datum syntmp-filename-1792))) ((lambda (syntmp-tmp-1794) ((lambda (syntmp-tmp-1795) (if syntmp-tmp-1795 (apply (lambda (syntmp-exp-1796) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-exp-1796)) syntmp-tmp-1795) (syntax-error syntmp-tmp-1794))) (syntax-dispatch syntmp-tmp-1794 (quote each-any)))) (syntmp-read-file-1783 syntmp-fn-1793 syntmp-k-1791)))) syntmp-tmp-1790) (syntax-error syntmp-tmp-1789))) (syntax-dispatch syntmp-tmp-1789 (quote (any any))))) syntmp-x-1782)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1813) ((lambda (syntmp-tmp-1814) ((lambda (syntmp-tmp-1815) (if syntmp-tmp-1815 (apply (lambda (syntmp-_-1816 syntmp-e-1817) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1817))) syntmp-tmp-1815) (syntax-error syntmp-tmp-1814))) (syntax-dispatch syntmp-tmp-1814 (quote (any any))))) syntmp-x-1813))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1823) ((lambda (syntmp-tmp-1824) ((lambda (syntmp-tmp-1825) (if syntmp-tmp-1825 (apply (lambda (syntmp-_-1826 syntmp-e-1827) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1827))) syntmp-tmp-1825) (syntax-error syntmp-tmp-1824))) (syntax-dispatch syntmp-tmp-1824 (quote (any any))))) syntmp-x-1823))) +(install-global-transformer (quote case) (lambda (syntmp-x-1833) ((lambda (syntmp-tmp-1834) ((lambda (syntmp-tmp-1835) (if syntmp-tmp-1835 (apply (lambda (syntmp-_-1836 syntmp-e-1837 syntmp-m1-1838 syntmp-m2-1839) ((lambda (syntmp-tmp-1840) ((lambda (syntmp-body-1841) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1837)) syntmp-body-1841)) syntmp-tmp-1840)) (let syntmp-f-1842 ((syntmp-clause-1843 syntmp-m1-1838) (syntmp-clauses-1844 syntmp-m2-1839)) (if (null? syntmp-clauses-1844) ((lambda (syntmp-tmp-1846) ((lambda (syntmp-tmp-1847) (if syntmp-tmp-1847 (apply (lambda (syntmp-e1-1848 syntmp-e2-1849) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1848 syntmp-e2-1849))) syntmp-tmp-1847) ((lambda (syntmp-tmp-1851) (if syntmp-tmp-1851 (apply (lambda (syntmp-k-1852 syntmp-e1-1853 syntmp-e2-1854) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1852)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1853 syntmp-e2-1854)))) syntmp-tmp-1851) ((lambda (syntmp-_-1857) (syntax-error syntmp-x-1833)) syntmp-tmp-1846))) (syntax-dispatch syntmp-tmp-1846 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1846 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) any . each-any))))) syntmp-clause-1843) ((lambda (syntmp-tmp-1858) ((lambda (syntmp-rest-1859) ((lambda (syntmp-tmp-1860) ((lambda (syntmp-tmp-1861) (if syntmp-tmp-1861 (apply (lambda (syntmp-k-1862 syntmp-e1-1863 syntmp-e2-1864) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1862)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1863 syntmp-e2-1864)) syntmp-rest-1859)) syntmp-tmp-1861) ((lambda (syntmp-_-1867) (syntax-error syntmp-x-1833)) syntmp-tmp-1860))) (syntax-dispatch syntmp-tmp-1860 (quote (each-any any . each-any))))) syntmp-clause-1843)) syntmp-tmp-1858)) (syntmp-f-1842 (car syntmp-clauses-1844) (cdr syntmp-clauses-1844))))))) syntmp-tmp-1835) (syntax-error syntmp-tmp-1834))) (syntax-dispatch syntmp-tmp-1834 (quote (any any any . each-any))))) syntmp-x-1833))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1897) ((lambda (syntmp-tmp-1898) ((lambda (syntmp-tmp-1899) (if syntmp-tmp-1899 (apply (lambda (syntmp-_-1900 syntmp-e-1901) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1901)) (list (cons syntmp-_-1900 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e-1901 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))))))))) syntmp-tmp-1899) (syntax-error syntmp-tmp-1898))) (syntax-dispatch syntmp-tmp-1898 (quote (any any))))) syntmp-x-1897))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 7d00d7197..096934217 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -319,12 +319,12 @@ (define fx< <) (define top-level-eval-hook - (lambda (x) - (eval `(,noexpand ,x) (interaction-environment)))) + (lambda (x mod) + (eval `(,noexpand ,x) (or mod (interaction-environment))))) (define local-eval-hook - (lambda (x) - (eval `(,noexpand ,x) (interaction-environment)))) + (lambda (x mod) + (eval `(,noexpand ,x) (or mod (interaction-environment))))) (define error-hook (lambda (who why what) @@ -334,6 +334,7 @@ (syntax-rules () ((_) (gensym)))) +;; wingo: FIXME: use modules natively? (define put-global-definition-hook (lambda (symbol binding) (putprop symbol '*sc-expander* binding))) @@ -372,17 +373,17 @@ (define-syntax build-global-reference (syntax-rules () - ((_ source var) - (build-annotated source (make-module-ref #f var #f))))) + ((_ source var mod) + (build-annotated source (make-module-ref #f var mod))))) (define-syntax build-global-assignment (syntax-rules () - ((_ source var exp) - (build-annotated source `(set! ,(make-module-ref #f var #f) ,exp))))) + ((_ source var exp mod) + (build-annotated source `(set! ,(make-module-ref #f var mod) ,exp))))) (define-syntax build-global-definition (syntax-rules () - ((_ source var exp) + ((_ source var exp mod) (build-annotated source `(define ,var ,exp))))) (define-syntax build-lambda @@ -390,6 +391,7 @@ ((_ src vars exp) (build-annotated src `(lambda ,vars ,exp))))) +;; FIXME: wingo: add modules here somehow? (define-syntax build-primref (syntax-rules () ((_ src name) (build-annotated src name)) @@ -428,6 +430,7 @@ (build-annotated src `(letrec ,(map list vars val-exps) ,body-exp))))) +;; FIXME: wingo: use make-lexical (define-syntax build-lexical-var (syntax-rules () ((_ src id) (build-annotated src (gensym (symbol->string id)))))) @@ -832,7 +835,7 @@ ;;; wrapping expressions and identifiers (define wrap - (lambda (x w) + (lambda (x w defmod) (cond ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x) ((syntax-object? x) @@ -841,32 +844,33 @@ (join-wraps w (syntax-object-wrap x)) (syntax-object-module x))) ((null? x) x) - (else (make-syntax-object x w #f))))) + (else (make-syntax-object x w defmod))))) (define source-wrap - (lambda (x w s) - (wrap (if s (make-annotation x s #f) x) w))) + (lambda (x w s defmod) + (wrap (if s (make-annotation x s #f) x) w defmod))) ;;; expanding (define chi-sequence - (lambda (body r w s) + (lambda (body r w s mod) (build-sequence s - (let dobody ((body body) (r r) (w w)) + (let dobody ((body body) (r r) (w w) (mod mod)) (if (null? body) '() - (let ((first (chi (car body) r w))) - (cons first (dobody (cdr body) r w)))))))) + (let ((first (chi (car body) r w mod))) + (cons first (dobody (cdr body) r w mod)))))))) (define chi-top-sequence - (lambda (body r w s m esew) + (lambda (body r w s m esew mod) (build-sequence s - (let dobody ((body body) (r r) (w w) (m m) (esew esew)) + (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod)) (if (null? body) '() - (let ((first (chi-top (car body) r w m esew))) - (cons first (dobody (cdr body) r w m esew)))))))) + (let ((first (chi-top (car body) r w m esew mod))) + (cons first (dobody (cdr body) r w m esew mod)))))))) +;; FIXME: module? (define chi-install-global (lambda (name e) (build-application no-source @@ -885,12 +889,12 @@ ((free-id=? x (syntax compile)) 'compile) ((free-id=? x (syntax load)) 'load) ((free-id=? x (syntax eval)) 'eval) - (else (syntax-error (wrap x w) + (else (syntax-error (wrap x w #f) "invalid eval-when situation")))) situations)))))) -;;; syntax-type returns five values: type, value, e, w, and s. The first -;;; two are described in the table below. +;;; syntax-type returns six values: type, value, e, w, s, and mod. The +;;; first two are described in the table below. ;;; ;;; type value explanation ;;; ------------------------------------------------------------------- @@ -918,25 +922,26 @@ ;;; ;;; For define-form and define-syntax-form, e is the rhs expression. ;;; For all others, e is the entire form. w is the wrap for e. -;;; s is the source for the entire form. +;;; s is the source for the entire form. mod is the module for e. ;;; ;;; syntax-type expands macros and unwraps as necessary to get to ;;; one of the forms above. It also parses define and define-syntax ;;; forms, although perhaps this should be done by the consumer. (define syntax-type - (lambda (e r w s rib) + (lambda (e r w s rib mod) (cond ((symbol? e) (let* ((n (id-var-name e w)) (b (lookup n r)) (type (binding-type b))) (case type - ((lexical) (values type (binding-value b) e w s)) - ((global) (values type n e w s)) + ((lexical) (values type (binding-value b) e w s #f)) + ((global) (values type n e w s mod)) ((macro) - (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib)) - (else (values type (binding-value b) e w s))))) + (syntax-type (chi-macro (binding-value b) e r w rib mod) + r empty-wrap s rib mod)) + (else (values type (binding-value b) e w s mod))))) ((pair? e) (let ((first (car e))) (if (id? first) @@ -944,73 +949,79 @@ (b (lookup n r)) (type (binding-type b))) (case type - ((lexical) (values 'lexical-call (binding-value b) e w s)) - ((global) (values 'global-call n e w s)) + ((lexical) + (values 'lexical-call (binding-value b) e w s mod)) + ((global) + (values 'global-call n e w s mod)) ((macro) - (syntax-type (chi-macro (binding-value b) e r w rib) - r empty-wrap s rib)) - ((core external-macro) (values type (binding-value b) e w s)) + (syntax-type (chi-macro (binding-value b) e r w rib mod) + r empty-wrap s rib mod)) + ((core external-macro) + (values type (binding-value b) e w s mod)) ((local-syntax) - (values 'local-syntax-form (binding-value b) e w s)) - ((begin) (values 'begin-form #f e w s)) - ((eval-when) (values 'eval-when-form #f e w s)) + (values 'local-syntax-form (binding-value b) e w s mod)) + ((begin) + (values 'begin-form #f e w s mod)) + ((eval-when) + (values 'eval-when-form #f e w s mod)) ((define) (syntax-case e () ((_ name val) (id? (syntax name)) - (values 'define-form (syntax name) (syntax val) w s)) + (values 'define-form (syntax name) (syntax val) w s mod)) ((_ (name . args) e1 e2 ...) (and (id? (syntax name)) (valid-bound-ids? (lambda-var-list (syntax args)))) ; need lambda here... - (values 'define-form (wrap (syntax name) w) - (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w)) - empty-wrap s)) + (values 'define-form (wrap (syntax name) w #f) + (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) + empty-wrap s mod)) ((_ name) (id? (syntax name)) - (values 'define-form (wrap (syntax name) w) + (values 'define-form (wrap (syntax name) w #f) (syntax (void)) - empty-wrap s)))) + empty-wrap s mod)))) ((define-syntax) (syntax-case e () ((_ name val) (id? (syntax name)) (values 'define-syntax-form (syntax name) - (syntax val) w s)))) - (else (values 'call #f e w s)))) - (values 'call #f e w s)))) + (syntax val) w s mod)))) + (else + (values 'call #f e w s mod)))) + (values 'call #f e w s mod)))) ((syntax-object? e) ;; s can't be valid source if we've unwrapped (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) - no-source rib)) + no-source rib (syntax-object-module e))) ((annotation? e) - (syntax-type (annotation-expression e) r w (annotation-source e) rib)) - ((self-evaluating? e) (values 'constant #f e w s)) - (else (values 'other #f e w s))))) + (syntax-type (annotation-expression e) r w (annotation-source e) rib mod)) + ((self-evaluating? e) (values 'constant #f e w s mod)) + (else (values 'other #f e w s mod))))) (define chi-top - (lambda (e r w m esew) + (lambda (e r w m esew mod) (define-syntax eval-if-c&e (syntax-rules () - ((_ m e) + ((_ m e mod) (let ((x e)) - (if (eq? m 'c&e) (top-level-eval-hook x)) + (if (eq? m 'c&e) (top-level-eval-hook x mod)) x)))) (call-with-values - (lambda () (syntax-type e r w no-source #f)) - (lambda (type value e w s) + (lambda () (syntax-type e r w no-source #f mod)) + (lambda (type value e w s mod) (case type ((begin-form) (syntax-case e () ((_) (chi-void)) ((_ e1 e2 ...) - (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew)))) + (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod)))) ((local-syntax-form) - (chi-local-syntax value e r w s - (lambda (body r w s) - (chi-top-sequence body r w s m esew)))) + (chi-local-syntax value e r w s mod + (lambda (body r w s mod) + (chi-top-sequence body r w s m esew mod)))) ((eval-when-form) (syntax-case e () ((_ (x ...) e1 e2 ...) @@ -1019,19 +1030,20 @@ (cond ((eq? m 'e) (if (memq 'eval when-list) - (chi-top-sequence body r w s 'e '(eval)) + (chi-top-sequence body r w s 'e '(eval) mod) (chi-void))) ((memq 'load when-list) (if (or (memq 'compile when-list) (and (eq? m 'c&e) (memq 'eval when-list))) - (chi-top-sequence body r w s 'c&e '(compile load)) + (chi-top-sequence body r w s 'c&e '(compile load) mod) (if (memq m '(c c&e)) - (chi-top-sequence body r w s 'c '(load)) + (chi-top-sequence body r w s 'c '(load) mod) (chi-void)))) ((or (memq 'compile when-list) (and (eq? m 'c&e) (memq 'eval when-list))) (top-level-eval-hook - (chi-top-sequence body r w s 'e '(eval))) + (chi-top-sequence body r w s 'e '(eval) mod) + mod) (chi-void)) (else (chi-void))))))) ((define-syntax-form) @@ -1039,20 +1051,21 @@ (case m ((c) (if (memq 'compile esew) - (let ((e (chi-install-global n (chi e r w)))) - (top-level-eval-hook e) + (let ((e (chi-install-global n (chi e r w mod)))) + (top-level-eval-hook e mod) (if (memq 'load esew) e (chi-void))) (if (memq 'load esew) - (chi-install-global n (chi e r w)) + (chi-install-global n (chi e r w mod)) (chi-void)))) ((c&e) - (let ((e (chi-install-global n (chi e r w)))) - (top-level-eval-hook e) + (let ((e (chi-install-global n (chi e r w mod)))) + (top-level-eval-hook e mod) e)) (else (if (memq 'eval esew) (top-level-eval-hook - (chi-install-global n (chi e r w)))) + (chi-install-global n (chi e r w mod)) + mod)) (chi-void))))) ((define-form) (let* ((n (id-var-name value w)) @@ -1060,72 +1073,76 @@ (case type ((global) (eval-if-c&e m - (build-global-definition s n (chi e r w)))) + (build-global-definition s n (chi e r w mod) mod) + mod)) ((displaced-lexical) - (syntax-error (wrap value w) "identifier out of context")) + (syntax-error (wrap value w #f) "identifier out of context")) (else (if (eq? type 'external-macro) (eval-if-c&e m - (build-global-definition s n (chi e r w))) - (syntax-error (wrap value w) + (build-global-definition s n (chi e r w mod) mod) + mod) + (syntax-error (wrap value w #f) "cannot define keyword at top level")))))) - (else (eval-if-c&e m (chi-expr type value e r w s)))))))) + (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) (define chi - (lambda (e r w) + (lambda (e r w mod) (call-with-values - (lambda () (syntax-type e r w no-source #f)) - (lambda (type value e w s) - (chi-expr type value e r w s))))) + (lambda () (syntax-type e r w no-source #f mod)) + (lambda (type value e w s mod) + (chi-expr type value e r w s mod))))) (define chi-expr - (lambda (type value e r w s) + (lambda (type value e r w s mod) (case type ((lexical) (build-lexical-reference 'value s value)) - ((core external-macro) (value e r w s)) + ((core external-macro) + ;; apply transformer + (value e r w s mod)) ((lexical-call) (chi-application (build-lexical-reference 'fun (source-annotation (car e)) value) - e r w s)) + e r w s mod)) ((global-call) (chi-application - (build-global-reference (source-annotation (car e)) value) - e r w s)) - ((constant) (build-data s (strip (source-wrap e w s) empty-wrap))) - ((global) (build-global-reference s value)) - ((call) (chi-application (chi (car e) r w) e r w s)) + (build-global-reference (source-annotation (car e)) value mod) + e r w s mod)) + ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) + ((global) (build-global-reference s value mod)) + ((call) (chi-application (chi (car e) r w mod) e r w s mod)) ((begin-form) (syntax-case e () - ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s)))) + ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod)))) ((local-syntax-form) - (chi-local-syntax value e r w s chi-sequence)) + (chi-local-syntax value e r w s mod chi-sequence)) ((eval-when-form) (syntax-case e () ((_ (x ...) e1 e2 ...) (let ((when-list (chi-when-list e (syntax (x ...)) w))) (if (memq 'eval when-list) - (chi-sequence (syntax (e1 e2 ...)) r w s) + (chi-sequence (syntax (e1 e2 ...)) r w s mod) (chi-void)))))) ((define-form define-syntax-form) - (syntax-error (wrap value w) "invalid context for definition of")) + (syntax-error (wrap value w #f) "invalid context for definition of")) ((syntax) - (syntax-error (source-wrap e w s) + (syntax-error (source-wrap e w s mod) "reference to pattern variable outside syntax form")) ((displaced-lexical) - (syntax-error (source-wrap e w s) + (syntax-error (source-wrap e w s mod) "reference to identifier outside its scope")) - (else (syntax-error (source-wrap e w s)))))) + (else (syntax-error (source-wrap e w s mod)))))) (define chi-application - (lambda (x e r w s) + (lambda (x e r w s mod) (syntax-case e () ((e0 e1 ...) (build-application s x - (map (lambda (e) (chi e r w)) (syntax (e1 ...)))))))) + (map (lambda (e) (chi e r w mod)) (syntax (e1 ...)))))))) (define chi-macro - (lambda (p e r w rib) + (lambda (p e r w rib mod) (define rebuild-macro-output (lambda (x m) (cond ((pair? x) @@ -1134,15 +1151,20 @@ ((syntax-object? x) (let ((w (syntax-object-wrap x))) (let ((ms (wrap-marks w)) (s (wrap-subst w))) - (make-syntax-object (syntax-object-expression x) - (if (and (pair? ms) (eq? (car ms) the-anti-mark)) - (make-wrap (cdr ms) - (if rib (cons rib (cdr s)) (cdr s))) - (make-wrap (cons m ms) - (if rib - (cons rib (cons 'shift s)) - (cons 'shift s)))) - (syntax-object-module x))))) + (if (and (pair? ms) (eq? (car ms) the-anti-mark)) + ;; output is from original text + (make-syntax-object + (syntax-object-expression x) + (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) + (syntax-object-module x)) + ;; output introduced by macro + (make-syntax-object + (syntax-object-expression x) + (make-wrap (cons m ms) + (if rib + (cons rib (cons 'shift s)) + (cons 'shift s))) + (procedure-module p)))))) ;; hither the hygiene ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -1152,7 +1174,7 @@ ((symbol? x) (syntax-error x "encountered raw symbol in macro output")) (else x)))) - (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark)))) + (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark)))) (define chi-body ;; In processing the forms of the body, we create a new, empty wrap. @@ -1193,34 +1215,34 @@ ;; into the body. ;; ;; outer-form is fully wrapped w/source - (lambda (body outer-form r w) + (lambda (body outer-form r w mod) (let* ((r (cons '("placeholder" . (placeholder)) r)) (ribcage (make-empty-ribcage)) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) - (let parse ((body (map (lambda (x) (cons r (wrap x w))) body)) + (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) (ids '()) (labels '()) (vars '()) (vals '()) (bindings '())) (if (null? body) (syntax-error outer-form "no expressions in body") (let ((e (cdar body)) (er (caar body))) (call-with-values - (lambda () (syntax-type e er empty-wrap no-source ribcage)) - (lambda (type value e w s) + (lambda () (syntax-type e er empty-wrap no-source ribcage mod)) + (lambda (type value e w s mod) (case type ((define-form) - (let ((id (wrap value w)) (label (gen-label))) + (let ((id (wrap value w mod)) (label (gen-label))) (let ((var (gen-var id))) (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) - (cons var vars) (cons (cons er (wrap e w)) vals) + (cons var vars) (cons (cons er (wrap e w mod)) vals) (cons (make-binding 'lexical var) bindings))))) ((define-syntax-form) - (let ((id (wrap value w)) (label (gen-label))) + (let ((id (wrap value w mod)) (label (gen-label))) (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) vars vals - (cons (make-binding 'macro (cons er (wrap e w))) + (cons (make-binding 'macro (cons er (wrap e w mod))) bindings)))) ((begin-form) (syntax-case e () @@ -1228,24 +1250,24 @@ (parse (let f ((forms (syntax (e1 ...)))) (if (null? forms) (cdr body) - (cons (cons er (wrap (car forms) w)) + (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) ids labels vars vals bindings)))) ((local-syntax-form) - (chi-local-syntax value e er w s - (lambda (forms er w s) + (chi-local-syntax value e er w s mod + (lambda (forms er w s mod) (parse (let f ((forms forms)) (if (null? forms) (cdr body) - (cons (cons er (wrap (car forms) w)) + (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) ids labels vars vals bindings)))) (else ; found a non-definition (if (null? ids) (build-sequence no-source (map (lambda (x) - (chi (cdr x) (car x) empty-wrap)) - (cons (cons er (source-wrap e w s)) + (chi (cdr x) (car x) empty-wrap mod)) + (cons (cons er (source-wrap e w s mod)) (cdr body)))) (begin (if (not (valid-bound-ids? ids)) @@ -1262,23 +1284,24 @@ (macros-only-env er)))) (set-cdr! b (eval-local-transformer - (chi (cddr b) r-cache empty-wrap))) + (chi (cddr b) r-cache empty-wrap mod) + mod)) (loop (cdr bs) er r-cache)) (loop (cdr bs) er-cache r-cache))))) (set-cdr! r (extend-env labels bindings (cdr r))) (build-letrec no-source vars (map (lambda (x) - (chi (cdr x) (car x) empty-wrap)) + (chi (cdr x) (car x) empty-wrap mod)) vals) (build-sequence no-source (map (lambda (x) - (chi (cdr x) (car x) empty-wrap)) - (cons (cons er (source-wrap e w s)) + (chi (cdr x) (car x) empty-wrap mod)) + (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))) (define chi-lambda-clause - (lambda (e c r w k) + (lambda (e c r w mod k) (syntax-case c () (((id ...) e1 e2 ...) (let ((ids (syntax (id ...)))) @@ -1290,7 +1313,8 @@ (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) - (make-binding-wrap ids labels w))))))) + (make-binding-wrap ids labels w) + mod)))))) ((ids e1 e2 ...) (let ((old-ids (lambda-var-list (syntax ids)))) (if (not (valid-bound-ids? old-ids)) @@ -1304,11 +1328,12 @@ (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) - (make-binding-wrap old-ids labels w))))))) + (make-binding-wrap old-ids labels w) + mod)))))) (_ (syntax-error e))))) (define chi-local-syntax - (lambda (rec? e r w s k) + (lambda (rec? e r w s mod k) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) @@ -1323,16 +1348,19 @@ (trans-r (macros-only-env r))) (map (lambda (x) (make-binding 'macro - (eval-local-transformer (chi x trans-r w)))) + (eval-local-transformer + (chi x trans-r w mod) + mod))) (syntax (val ...)))) r) new-w - s)))))) - (_ (syntax-error (source-wrap e w s)))))) + s + mod)))))) + (_ (syntax-error (source-wrap e w s mod)))))) (define eval-local-transformer - (lambda (expanded) - (let ((p (local-eval-hook expanded))) + (lambda (expanded mod) + (let ((p (local-eval-hook expanded mod))) (if (procedure? p) p (syntax-error p "nonprocedure transformer"))))) @@ -1412,8 +1440,8 @@ (lambda (vars) (let lvl ((vars vars) (ls '()) (w empty-wrap)) (cond - ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w)) - ((id? vars) (cons (wrap vars w) ls)) + ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) + ((id? vars) (cons (wrap vars w #f) ls)) ((null? vars) ls) ((syntax-object? vars) (lvl (syntax-object-expression vars) @@ -1431,7 +1459,7 @@ (global-extend 'local-syntax 'let-syntax #f) (global-extend 'core 'fluid-let-syntax - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ ((var val) ...) e1 e2 ...) (valid-bound-ids? (syntax (var ...))) @@ -1440,29 +1468,31 @@ (lambda (id n) (case (binding-type (lookup n r)) ((displaced-lexical) - (syntax-error (source-wrap id w s) + (syntax-error (source-wrap id w s mod) "identifier out of context")))) (syntax (var ...)) names) (chi-body (syntax (e1 e2 ...)) - (source-wrap e w s) + (source-wrap e w s mod) (extend-env names (let ((trans-r (macros-only-env r))) (map (lambda (x) (make-binding 'macro - (eval-local-transformer (chi x trans-r w)))) + (eval-local-transformer (chi x trans-r w mod) + mod))) (syntax (val ...)))) r) - w))) - (_ (syntax-error (source-wrap e w s)))))) + w + mod))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'core 'quote - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ e) (build-data s (strip (syntax e) w))) - (_ (syntax-error (source-wrap e w s)))))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'core 'syntax (let () @@ -1620,27 +1650,29 @@ (build-primref no-source (car x)) (map regen (cdr x))))))) - (lambda (e r w s) - (let ((e (source-wrap e w s))) + (lambda (e r w s mod) + (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ x) (call-with-values (lambda () (gen-syntax e (syntax x) r '() ellipsis?)) + ;; It doesn't seem we need `mod' here as `syntax' only + ;; references lexical vars and primitives. (lambda (e maps) (regen e)))) (_ (syntax-error e))))))) (global-extend 'core 'lambda - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ . c) - (chi-lambda-clause (source-wrap e w s) (syntax c) r w + (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod (lambda (vars body) (build-lambda s vars body))))))) (global-extend 'core 'let (let () - (define (chi-let e r w s constructor ids vals exps) + (define (chi-let e r w s mod constructor ids vals exps) (if (not (valid-bound-ids? ids)) (syntax-error e "duplicate bound variable in") (let ((labels (gen-labels ids)) @@ -1649,28 +1681,29 @@ (nr (extend-var-env labels new-vars r))) (constructor s new-vars - (map (lambda (x) (chi x r w)) vals) - (chi-body exps (source-wrap e nw s) nr nw)))))) - (lambda (e r w s) + (map (lambda (x) (chi x r w mod)) vals) + (chi-body exps (source-wrap e nw s mod) + nr nw mod)))))) + (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) - (chi-let e r w s + (chi-let e r w s mod build-let (syntax (id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) ((_ f ((id val) ...) e1 e2 ...) (id? (syntax f)) - (chi-let e r w s + (chi-let e r w s mod build-named-let (syntax (f id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) - (_ (syntax-error (source-wrap e w s))))))) + (_ (syntax-error (source-wrap e w s mod))))))) (global-extend 'core 'letrec - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) @@ -1682,33 +1715,34 @@ (r (extend-var-env labels new-vars r))) (build-letrec s new-vars - (map (lambda (x) (chi x r w)) (syntax (val ...))) - (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w))))))) - (_ (syntax-error (source-wrap e w s)))))) + (map (lambda (x) (chi x r w mod)) (syntax (val ...))) + (chi-body (syntax (e1 e2 ...)) + (source-wrap e w s mod) r w mod))))))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'core 'set! - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ id val) (id? (syntax id)) - (let ((val (chi (syntax val) r w)) + (let ((val (chi (syntax val) r w mod)) (n (id-var-name (syntax id) w))) (let ((b (lookup n r))) (case (binding-type b) ((lexical) (build-lexical-assignment s (binding-value b) val)) - ((global) (build-global-assignment s n val)) + ((global) (build-global-assignment s n val mod)) ((displaced-lexical) - (syntax-error (wrap (syntax id) w) + (syntax-error (wrap (syntax id) w #f) "identifier out of context")) - (else (syntax-error (source-wrap e w s))))))) + (else (syntax-error (source-wrap e w s mod))))))) ((_ (getter arg ...) val) (build-application s - (chi (syntax (setter getter)) r w) - (map (lambda (e) (chi e r w)) + (chi (syntax (setter getter)) r w mod) + (map (lambda (e) (chi e r w mod)) (syntax (arg ... val))))) - (_ (syntax-error (source-wrap e w s)))))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'begin 'begin '()) @@ -1753,25 +1787,26 @@ (x (values (vector 'atom (strip p empty-wrap)) ids))))))) (define build-dispatch-call - (lambda (pvars exp y r) + (lambda (pvars exp y r mod) (let ((ids (map car pvars)) (levels (map cdr pvars))) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (build-application no-source (build-primref no-source 'apply) (list (build-lambda no-source new-vars (chi exp - (extend-env - labels - (map (lambda (var level) - (make-binding 'syntax `(,var . ,level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap))) + (extend-env + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) y)))))) (define gen-clause - (lambda (x keys clauses r pat fender exp) + (lambda (x keys clauses r pat fender exp mod) (call-with-values (lambda () (convert-pattern pat keys)) (lambda (p pvars) @@ -1793,10 +1828,10 @@ (#t y) (_ (build-conditional no-source y - (build-dispatch-call pvars fender y r) + (build-dispatch-call pvars fender y r mod) (build-data no-source #f)))) - (build-dispatch-call pvars exp y r) - (gen-syntax-case x keys clauses r)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) (list (if (eq? p 'any) (build-application no-source (build-primref no-source 'list) @@ -1806,7 +1841,7 @@ (list x (build-data no-source p))))))))))))) (define gen-syntax-case - (lambda (x keys clauses r) + (lambda (x keys clauses r mod) (if (null? clauses) (build-application no-source (build-primref no-source 'syntax-error) @@ -1825,17 +1860,18 @@ (list (make-binding 'syntax `(,var . 0))) r) (make-binding-wrap (syntax (pat)) - labels empty-wrap))) + labels empty-wrap) + mod)) (list x))) (gen-clause x keys (cdr clauses) r - (syntax pat) #t (syntax exp)))) + (syntax pat) #t (syntax exp) mod))) ((pat fender exp) (gen-clause x keys (cdr clauses) r - (syntax pat) (syntax fender) (syntax exp))) + (syntax pat) (syntax fender) (syntax exp) mod)) (_ (syntax-error (car clauses) "invalid syntax-case clause")))))) - (lambda (e r w s) - (let ((e (source-wrap e w s))) + (lambda (e r w s mod) + (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ val (key ...) m ...) (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) @@ -1846,8 +1882,9 @@ (build-lambda no-source (list x) (gen-syntax-case (build-lexical-reference 'value no-source x) (syntax (key ...)) (syntax (m ...)) - r)) - (list (chi (syntax val) r empty-wrap)))) + r + mod)) + (list (chi (syntax val) r empty-wrap mod)))) (syntax-error e "invalid literals list in")))))))) ;;; The portable sc-expand seeds chi-top's mode m with 'e (for @@ -1864,7 +1901,7 @@ (lambda (x) (if (and (pair? x) (equal? (car x) noexpand)) (cadr x) - (chi-top x null-env top-wrap m esew))))) + (chi-top x null-env top-wrap m esew (current-module)))))) (set! sc-expand3 (let ((m 'e) (esew '(eval))) @@ -1877,7 +1914,8 @@ (if (null? rest) m (car rest)) (if (or (null? rest) (null? (cdr rest))) esew - (cadr rest))))))) + (cadr rest)) + (current-module)))))) (set! identifier? (lambda (x) @@ -1896,7 +1934,7 @@ (set! generate-temporaries (lambda (ls) (arg-check list? ls 'generate-temporaries) - (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls))) + (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls))) (set! free-identifier=? (lambda (x y) @@ -1972,7 +2010,7 @@ (match-each-any (annotation-expression e) w)) ((pair? e) (let ((l (match-each-any (cdr e) w))) - (and l (cons (wrap (car e) w) l)))) + (and l (cons (wrap (car e) w #f) l)))) ((null? e) '()) ((syntax-object? e) (match-each-any (syntax-object-expression e) @@ -2012,7 +2050,7 @@ (if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))))) - ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r)) + ((free-id) (and (id? e) (free-id=? (wrap e w #f) (vector-ref p 1)) r)) ((atom) (and (equal? (vector-ref p 1) (strip e w)) r)) ((vector) (and (vector? e) @@ -2022,7 +2060,7 @@ (lambda (e p w r) (cond ((not r) #f) - ((eq? p 'any) (cons (wrap e w) r)) + ((eq? p 'any) (cons (wrap e w #f) r)) ((syntax-object? e) (match* (unannotate (syntax-object-expression e)) diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index 63b3a52e4..ec6da56c8 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -136,7 +136,7 @@ (define guile-macro (cons 'external-macro - (lambda (e r w s) + (lambda (e r w s mod) (let ((e (syntax-object->datum e))) (if (symbol? e) ;; pass the expression through @@ -154,7 +154,7 @@ e (if (null? r) (sc-expand e) - (sc-chi e r w))))))))))) + (sc-chi e r w mod))))))))))) (define generated-symbols (make-weak-key-hash-table 1019)) @@ -208,8 +208,8 @@ (set! old-debug (debug-options)) (set! old-read (read-options))) (lambda () - (debug-disable 'debug 'procnames) - (read-disable 'positions) + (debug-disable 'debug 'procnames) + (read-disable 'positions) (load-from-path "ice-9/psyntax-pp")) (lambda () (debug-options old-debug) From daedb4920acdf6db31c375b4fdd142b002ddc77a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 Mar 2009 21:20:44 -0700 Subject: [PATCH 034/375] eval-closure-module, here hopefully not for long * libguile/modules.h: * libguile/modules.c (scm_eval_closure_module): Define a new-yet-deprecated accessor, to ease a transition. --- libguile/modules.c | 15 +++++++++++++++ libguile/modules.h | 1 + 2 files changed, 16 insertions(+) diff --git a/libguile/modules.c b/libguile/modules.c index beee0e2a5..428cb607d 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -544,6 +544,21 @@ SCM_DEFINE (scm_standard_interface_eval_closure, } #undef FUNC_NAME +SCM_DEFINE (scm_eval_closure_module, + "eval-closure-module", 1, 0, 0, + (SCM eval_closure), + "Return the module associated with this eval closure.") +/* the idea is that eval closures are really not the way to do things, they're + superfluous given our module system. this function lets mmacros migrate away + from eval closures. */ +#define FUNC_NAME s_scm_eval_closure_module +{ + SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P, + "eval-closure"); + return SCM_SMOB_OBJECT (eval_closure); +} +#undef FUNC_NAME + SCM scm_module_lookup_closure (SCM module) { diff --git a/libguile/modules.h b/libguile/modules.h index 4f42e1888..3cd090476 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -109,6 +109,7 @@ SCM_API SCM scm_current_module_transformer (void); SCM_API SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep); SCM_API SCM scm_standard_eval_closure (SCM module); SCM_API SCM scm_standard_interface_eval_closure (SCM module); +SCM_API SCM scm_eval_closure_module (SCM eval_closure); /* deprecated already */ SCM_API SCM scm_get_pre_modules_obarray (void); SCM_API SCM scm_lookup_closure_module (SCM proc); From 8e1d0d507ac3400fb57fce4196cc8cbc91977135 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 Mar 2009 22:06:35 -0700 Subject: [PATCH 035/375] more work on modules and hygiene, not finished yet, alas. * module/ice-9/compile-psyntax.scm: No more expansion-eval-closure. * module/ice-9/expand-support.scm (strip-expansion-structures): Only @@ names whose module is not the current module. Actually @@ serialization is disabled for this commit, just to get this one in and keep things working. * module/ice-9/psyntax-pp.scm: Recompiled. * module/ice-9/psyntax.scm (put-global-definition-hook) (get-global-definition-hook): Instead of going through that stupid getprop/putprop interface, let's just inline Guile-specific code here. (build-global-reference, build-global-assignment): Fix a bug where the module and public? were switched, which happily allowed things to compile. (We reintroduce a similar bug above in expand-support.) (lookup): Add a module argument. (global-extend): Adapt for put-global-definition-hook invocation. (syntax-type): Lookup with mod. Return mod even for lexicals and define-form -- why not. (chi-top, fluid-let-syntax, syntax, set!): Lookup with mod. Wrap with mod. * module/ice-9/syncase.scm (expansion-eval-closure) (current-eval-closure, env->eval-closure): OK! So the idea is: module hygiene is syncase's business, not ours. So lose the eval-closure fluid. Also, eval closures are so 1990s. (sc-macro): But, we have to take the module from the env, sadly. In the future this will be different. Remove the rest of the eval-closure bits. Enable source reporting, while we're debugging. * module/language/scheme/compile-ghil.scm (lookup-transformer): Adapt for eval closure fluid changes. --- module/ice-9/compile-psyntax.scm | 24 ++++--- module/ice-9/expand-support.scm | 6 +- module/ice-9/psyntax-pp.scm | 22 +++---- module/ice-9/psyntax.scm | 88 +++++++++++++++---------- module/ice-9/syncase.scm | 61 +++-------------- module/language/scheme/compile-ghil.scm | 8 +-- 6 files changed, 91 insertions(+), 118 deletions(-) diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 51e3de11f..10a307be1 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -12,18 +12,16 @@ (let ((in (open-input-file source)) (out (open-output-file (string-append target ".tmp")))) - (with-fluids ((expansion-eval-closure - (module-eval-closure (current-module)))) - (let loop ((x (read in))) - (if (eof-object? x) - (begin - (close-port out) - (close-port in)) - (begin - (write (strip-expansion-structures - (sc-expand3 x 'c '(compile load eval))) - out) - (newline out) - (loop (read in))))))) + (let loop ((x (read in))) + (if (eof-object? x) + (begin + (close-port out) + (close-port in)) + (begin + (write (strip-expansion-structures + (sc-expand3 x 'c '(compile load eval))) + out) + (newline out) + (loop (read in)))))) (system (format #f "mv -f ~s.tmp ~s" target target)) diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm index 597e7ff38..fc9290050 100644 --- a/module/ice-9/expand-support.scm +++ b/module/ice-9/expand-support.scm @@ -149,7 +149,10 @@ (set-source-properties! e source)) e)) ((module-ref? e) - (if (module-ref-modname e) + (if (and (module-ref-modname e) + (not (eq? (module-ref-modname e) + (module-name (current-module)))) + #f) `(,(if (module-ref-public? e) '@ '@@) ,(module-ref-modname e) ,(module-ref-symbol e)) @@ -159,4 +162,3 @@ ((record? e) (error "unexpected record in expansion" e)) (else e))) - diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0d560bb92..436361644 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (procedure-module syntmp-p-688)))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref #f syntmp-value-717 syntmp-mod-722)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref #f syntmp-value-717 syntmp-mod-722)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-724) ((lambda (syntmp-tmp-725) (if syntmp-tmp-725 (apply (lambda (syntmp-_-726 syntmp-e1-727 syntmp-e2-728) (syntmp-chi-sequence-147 (cons syntmp-e1-727 syntmp-e2-728) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-725) (syntax-error syntmp-tmp-724))) (syntax-dispatch syntmp-tmp-724 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-730) ((lambda (syntmp-tmp-731) (if syntmp-tmp-731 (apply (lambda (syntmp-_-732 syntmp-x-733 syntmp-e1-734 syntmp-e2-735) (let ((syntmp-when-list-736 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-733 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-736) (syntmp-chi-sequence-147 (cons syntmp-e1-734 syntmp-e2-735) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-731) (syntax-error syntmp-tmp-730))) (syntax-dispatch syntmp-tmp-730 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 #f) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722)))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-739 syntmp-r-740 syntmp-w-741 syntmp-mod-742) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-739 syntmp-r-740 syntmp-w-741 #f #f syntmp-mod-742)) (lambda (syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-w-746 syntmp-s-747 syntmp-mod-748) (syntmp-chi-expr-154 syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-r-740 syntmp-w-746 syntmp-s-747 syntmp-mod-748))))) (syntmp-chi-top-152 (lambda (syntmp-e-749 syntmp-r-750 syntmp-w-751 syntmp-m-752 syntmp-esew-753 syntmp-mod-754) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-749 syntmp-r-750 syntmp-w-751 #f #f syntmp-mod-754)) (lambda (syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-w-772 syntmp-s-773 syntmp-mod-774) (let ((syntmp-t-775 syntmp-type-769)) (if (memv syntmp-t-775 (quote (begin-form))) ((lambda (syntmp-tmp-776) ((lambda (syntmp-tmp-777) (if syntmp-tmp-777 (apply (lambda (syntmp-_-778) (syntmp-chi-void-161)) syntmp-tmp-777) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-e1-781 syntmp-e2-782) (syntmp-chi-top-sequence-148 (cons syntmp-e1-781 syntmp-e2-782) syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-m-752 syntmp-esew-753 syntmp-mod-774)) syntmp-tmp-779) (syntax-error syntmp-tmp-776))) (syntax-dispatch syntmp-tmp-776 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-776 (quote (any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774 (lambda (syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-mod-788) (syntmp-chi-top-sequence-148 syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-m-752 syntmp-esew-753 syntmp-mod-788))) (if (memv syntmp-t-775 (quote (eval-when-form))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-x-792 syntmp-e1-793 syntmp-e2-794) (let ((syntmp-when-list-795 (syntmp-chi-when-list-150 syntmp-e-771 syntmp-x-792 syntmp-w-772)) (syntmp-body-796 (cons syntmp-e1-793 syntmp-e2-794))) (cond ((eq? syntmp-m-752 (quote e)) (if (memq (quote eval) syntmp-when-list-795) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-795) (if (or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c&e) (quote (compile load)) syntmp-mod-774) (if (memq syntmp-m-752 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c) (quote (load)) syntmp-mod-774) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) syntmp-mod-774) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-790) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any each-any any . each-any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (define-syntax-form))) (let ((syntmp-n-799 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772)) (syntmp-r-800 (syntmp-macros-only-env-113 syntmp-r-750))) (let ((syntmp-t-801 syntmp-m-752)) (if (memv syntmp-t-801 (quote (c))) (if (memq (quote compile) syntmp-esew-753) (let ((syntmp-e-802 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-802 syntmp-mod-774) (if (memq (quote load) syntmp-esew-753) syntmp-e-802 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-753) (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) (syntmp-chi-void-161))) (if (memv syntmp-t-801 (quote (c&e))) (let ((syntmp-e-803 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-803 syntmp-mod-774) syntmp-e-803)) (begin (if (memq (quote eval) syntmp-esew-753) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) syntmp-mod-774)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-775 (quote (define-form))) (let ((syntmp-n-804 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772))) (let ((syntmp-type-805 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-804 syntmp-r-750)))) (let ((syntmp-t-806 syntmp-type-805)) (if (memv syntmp-t-806 (quote (global))) (let ((syntmp-x-807 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-807 syntmp-mod-774)) syntmp-x-807)) (if (memv syntmp-t-806 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 #f) "identifier out of context") (if (eq? syntmp-type-805 (quote external-macro)) (let ((syntmp-x-808 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-808 syntmp-mod-774)) syntmp-x-808)) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 #f) "cannot define keyword at top level"))))))) (let ((syntmp-x-809 (syntmp-chi-expr-154 syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-774)) syntmp-x-809)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (cond ((symbol? syntmp-e-810) (let ((syntmp-n-816 (syntmp-id-var-name-139 syntmp-e-810 syntmp-w-812))) (let ((syntmp-b-817 (syntmp-lookup-114 syntmp-n-816 syntmp-r-811))) (let ((syntmp-type-818 (syntmp-binding-type-109 syntmp-b-817))) (let ((syntmp-t-819 syntmp-type-818)) (if (memv syntmp-t-819 (quote (lexical))) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 #f) (if (memv syntmp-t-819 (quote (global))) (values syntmp-type-818 syntmp-n-816 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))))))) ((pair? syntmp-e-810) (let ((syntmp-first-820 (car syntmp-e-810))) (if (syntmp-id?-117 syntmp-first-820) (let ((syntmp-n-821 (syntmp-id-var-name-139 syntmp-first-820 syntmp-w-812))) (let ((syntmp-b-822 (syntmp-lookup-114 syntmp-n-821 syntmp-r-811))) (let ((syntmp-type-823 (syntmp-binding-type-109 syntmp-b-822))) (let ((syntmp-t-824 syntmp-type-823)) (if (memv syntmp-t-824 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (global))) (values (quote global-call) syntmp-n-821 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (if (memv syntmp-t-824 (quote (core external-macro))) (values syntmp-type-823 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (begin))) (values (quote begin-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (define))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-117 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-form) syntmp-name-831 syntmp-val-832 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-826) ((lambda (syntmp-tmp-833) (if (if syntmp-tmp-833 (apply (lambda (syntmp-_-834 syntmp-name-835 syntmp-args-836 syntmp-e1-837 syntmp-e2-838) (and (syntmp-id?-117 syntmp-name-835) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-836)))) syntmp-tmp-833) #f) (apply (lambda (syntmp-_-839 syntmp-name-840 syntmp-args-841 syntmp-e1-842 syntmp-e2-843) (values (quote define-form) (syntmp-wrap-145 syntmp-name-840 syntmp-w-812 #f) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) (syntmp-wrap-145 (cons syntmp-args-841 (cons syntmp-e1-842 syntmp-e2-843)) syntmp-w-812 syntmp-mod-815)) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-833) ((lambda (syntmp-tmp-845) (if (if syntmp-tmp-845 (apply (lambda (syntmp-_-846 syntmp-name-847) (syntmp-id?-117 syntmp-name-847)) syntmp-tmp-845) #f) (apply (lambda (syntmp-_-848 syntmp-name-849) (values (quote define-form) (syntmp-wrap-145 syntmp-name-849 syntmp-w-812 #f) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-845) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-810) (if (memv syntmp-t-824 (quote (define-syntax))) ((lambda (syntmp-tmp-850) ((lambda (syntmp-tmp-851) (if (if syntmp-tmp-851 (apply (lambda (syntmp-_-852 syntmp-name-853 syntmp-val-854) (syntmp-id?-117 syntmp-name-853)) syntmp-tmp-851) #f) (apply (lambda (syntmp-_-855 syntmp-name-856 syntmp-val-857) (values (quote define-syntax-form) syntmp-name-856 syntmp-val-857 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-851) (syntax-error syntmp-tmp-850))) (syntax-dispatch syntmp-tmp-850 (quote (any any any))))) syntmp-e-810) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))))))))))))) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))) ((syntmp-syntax-object?-101 syntmp-e-810) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-810) syntmp-r-811 (syntmp-join-wraps-136 syntmp-w-812 (syntmp-syntax-object-wrap-103 syntmp-e-810)) #f syntmp-rib-814 (syntmp-syntax-object-module-104 syntmp-e-810))) ((annotation? syntmp-e-810) (syntmp-syntax-type-151 (annotation-expression syntmp-e-810) syntmp-r-811 syntmp-w-812 (annotation-source syntmp-e-810) syntmp-rib-814 syntmp-mod-815)) ((self-evaluating? syntmp-e-810) (values (quote constant) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) (else (values (quote other) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-858 syntmp-when-list-859 syntmp-w-860) (let syntmp-f-861 ((syntmp-when-list-862 syntmp-when-list-859) (syntmp-situations-863 (quote ()))) (if (null? syntmp-when-list-862) syntmp-situations-863 (syntmp-f-861 (cdr syntmp-when-list-862) (cons (let ((syntmp-x-864 (car syntmp-when-list-862))) (cond ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-864 syntmp-w-860 #f) "invalid eval-when situation")))) syntmp-situations-863)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-876 syntmp-e-877) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-876) syntmp-e-877)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-878 syntmp-r-879 syntmp-w-880 syntmp-s-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884) (syntmp-build-sequence-96 syntmp-s-881 (let syntmp-dobody-885 ((syntmp-body-886 syntmp-body-878) (syntmp-r-887 syntmp-r-879) (syntmp-w-888 syntmp-w-880) (syntmp-m-889 syntmp-m-882) (syntmp-esew-890 syntmp-esew-883) (syntmp-mod-891 syntmp-mod-884)) (if (null? syntmp-body-886) (quote ()) (let ((syntmp-first-892 (syntmp-chi-top-152 (car syntmp-body-886) syntmp-r-887 syntmp-w-888 syntmp-m-889 syntmp-esew-890 syntmp-mod-891))) (cons syntmp-first-892 (syntmp-dobody-885 (cdr syntmp-body-886) syntmp-r-887 syntmp-w-888 syntmp-m-889 syntmp-esew-890 syntmp-mod-891)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-893 syntmp-r-894 syntmp-w-895 syntmp-s-896 syntmp-mod-897) (syntmp-build-sequence-96 syntmp-s-896 (let syntmp-dobody-898 ((syntmp-body-899 syntmp-body-893) (syntmp-r-900 syntmp-r-894) (syntmp-w-901 syntmp-w-895) (syntmp-mod-902 syntmp-mod-897)) (if (null? syntmp-body-899) (quote ()) (let ((syntmp-first-903 (syntmp-chi-153 (car syntmp-body-899) syntmp-r-900 syntmp-w-901 syntmp-mod-902))) (cons syntmp-first-903 (syntmp-dobody-898 (cdr syntmp-body-899) syntmp-r-900 syntmp-w-901 syntmp-mod-902)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-904 syntmp-w-905 syntmp-s-906 syntmp-defmod-907) (syntmp-wrap-145 (if syntmp-s-906 (make-annotation syntmp-x-904 syntmp-s-906 #f) syntmp-x-904) syntmp-w-905 syntmp-defmod-907))) (syntmp-wrap-145 (lambda (syntmp-x-908 syntmp-w-909 syntmp-defmod-910) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-909)) (null? (syntmp-wrap-subst-121 syntmp-w-909))) syntmp-x-908) ((syntmp-syntax-object?-101 syntmp-x-908) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-908) (syntmp-join-wraps-136 syntmp-w-909 (syntmp-syntax-object-wrap-103 syntmp-x-908)) (syntmp-syntax-object-module-104 syntmp-x-908))) ((null? syntmp-x-908) syntmp-x-908) (else (syntmp-make-syntax-object-100 syntmp-x-908 syntmp-w-909 syntmp-defmod-910))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-911 syntmp-list-912) (and (not (null? syntmp-list-912)) (or (syntmp-bound-id=?-141 syntmp-x-911 (car syntmp-list-912)) (syntmp-bound-id-member?-144 syntmp-x-911 (cdr syntmp-list-912)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-913) (let syntmp-distinct?-914 ((syntmp-ids-915 syntmp-ids-913)) (or (null? syntmp-ids-915) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-915) (cdr syntmp-ids-915))) (syntmp-distinct?-914 (cdr syntmp-ids-915))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-916) (and (let syntmp-all-ids?-917 ((syntmp-ids-918 syntmp-ids-916)) (or (null? syntmp-ids-918) (and (syntmp-id?-117 (car syntmp-ids-918)) (syntmp-all-ids?-917 (cdr syntmp-ids-918))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-916)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-919 syntmp-j-920) (if (and (syntmp-syntax-object?-101 syntmp-i-919) (syntmp-syntax-object?-101 syntmp-j-920)) (and (eq? (let ((syntmp-e-921 (syntmp-syntax-object-expression-102 syntmp-i-919))) (if (annotation? syntmp-e-921) (annotation-expression syntmp-e-921) syntmp-e-921)) (let ((syntmp-e-922 (syntmp-syntax-object-expression-102 syntmp-j-920))) (if (annotation? syntmp-e-922) (annotation-expression syntmp-e-922) syntmp-e-922))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-919)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-920)))) (eq? (let ((syntmp-e-923 syntmp-i-919)) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 syntmp-j-920)) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-925 syntmp-j-926) (and (eq? (let ((syntmp-x-927 syntmp-i-925)) (let ((syntmp-e-928 (if (syntmp-syntax-object?-101 syntmp-x-927) (syntmp-syntax-object-expression-102 syntmp-x-927) syntmp-x-927))) (if (annotation? syntmp-e-928) (annotation-expression syntmp-e-928) syntmp-e-928))) (let ((syntmp-x-929 syntmp-j-926)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930)))) (eq? (syntmp-id-var-name-139 syntmp-i-925 (quote (()))) (syntmp-id-var-name-139 syntmp-j-926 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-931 syntmp-w-932) (letrec ((syntmp-search-vector-rib-935 (lambda (syntmp-sym-946 syntmp-subst-947 syntmp-marks-948 syntmp-symnames-949 syntmp-ribcage-950) (let ((syntmp-n-951 (vector-length syntmp-symnames-949))) (let syntmp-f-952 ((syntmp-i-953 0)) (cond ((syntmp-fx=-87 syntmp-i-953 syntmp-n-951) (syntmp-search-933 syntmp-sym-946 (cdr syntmp-subst-947) syntmp-marks-948)) ((and (eq? (vector-ref syntmp-symnames-949 syntmp-i-953) syntmp-sym-946) (syntmp-same-marks?-138 syntmp-marks-948 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-950) syntmp-i-953))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-950) syntmp-i-953) syntmp-marks-948)) (else (syntmp-f-952 (syntmp-fx+-85 syntmp-i-953 1)))))))) (syntmp-search-list-rib-934 (lambda (syntmp-sym-954 syntmp-subst-955 syntmp-marks-956 syntmp-symnames-957 syntmp-ribcage-958) (let syntmp-f-959 ((syntmp-symnames-960 syntmp-symnames-957) (syntmp-i-961 0)) (cond ((null? syntmp-symnames-960) (syntmp-search-933 syntmp-sym-954 (cdr syntmp-subst-955) syntmp-marks-956)) ((and (eq? (car syntmp-symnames-960) syntmp-sym-954) (syntmp-same-marks?-138 syntmp-marks-956 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-958) syntmp-i-961))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-958) syntmp-i-961) syntmp-marks-956)) (else (syntmp-f-959 (cdr syntmp-symnames-960) (syntmp-fx+-85 syntmp-i-961 1))))))) (syntmp-search-933 (lambda (syntmp-sym-962 syntmp-subst-963 syntmp-marks-964) (if (null? syntmp-subst-963) (values #f syntmp-marks-964) (let ((syntmp-fst-965 (car syntmp-subst-963))) (if (eq? syntmp-fst-965 (quote shift)) (syntmp-search-933 syntmp-sym-962 (cdr syntmp-subst-963) (cdr syntmp-marks-964)) (let ((syntmp-symnames-966 (syntmp-ribcage-symnames-126 syntmp-fst-965))) (if (vector? syntmp-symnames-966) (syntmp-search-vector-rib-935 syntmp-sym-962 syntmp-subst-963 syntmp-marks-964 syntmp-symnames-966 syntmp-fst-965) (syntmp-search-list-rib-934 syntmp-sym-962 syntmp-subst-963 syntmp-marks-964 syntmp-symnames-966 syntmp-fst-965))))))))) (cond ((symbol? syntmp-id-931) (or (call-with-values (lambda () (syntmp-search-933 syntmp-id-931 (syntmp-wrap-subst-121 syntmp-w-932) (syntmp-wrap-marks-120 syntmp-w-932))) (lambda (syntmp-x-968 . syntmp-ignore-967) syntmp-x-968)) syntmp-id-931)) ((syntmp-syntax-object?-101 syntmp-id-931) (let ((syntmp-id-969 (let ((syntmp-e-971 (syntmp-syntax-object-expression-102 syntmp-id-931))) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971))) (syntmp-w1-970 (syntmp-syntax-object-wrap-103 syntmp-id-931))) (let ((syntmp-marks-972 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-932) (syntmp-wrap-marks-120 syntmp-w1-970)))) (call-with-values (lambda () (syntmp-search-933 syntmp-id-969 (syntmp-wrap-subst-121 syntmp-w-932) syntmp-marks-972)) (lambda (syntmp-new-id-973 syntmp-marks-974) (or syntmp-new-id-973 (call-with-values (lambda () (syntmp-search-933 syntmp-id-969 (syntmp-wrap-subst-121 syntmp-w1-970) syntmp-marks-974)) (lambda (syntmp-x-976 . syntmp-ignore-975) syntmp-x-976)) syntmp-id-969)))))) ((annotation? syntmp-id-931) (let ((syntmp-id-977 (let ((syntmp-e-978 syntmp-id-931)) (if (annotation? syntmp-e-978) (annotation-expression syntmp-e-978) syntmp-e-978)))) (or (call-with-values (lambda () (syntmp-search-933 syntmp-id-977 (syntmp-wrap-subst-121 syntmp-w-932) (syntmp-wrap-marks-120 syntmp-w-932))) (lambda (syntmp-x-980 . syntmp-ignore-979) syntmp-x-980)) syntmp-id-977))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-931)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-981 syntmp-y-982) (or (eq? syntmp-x-981 syntmp-y-982) (and (not (null? syntmp-x-981)) (not (null? syntmp-y-982)) (eq? (car syntmp-x-981) (car syntmp-y-982)) (syntmp-same-marks?-138 (cdr syntmp-x-981) (cdr syntmp-y-982)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-983 syntmp-m2-984) (syntmp-smart-append-135 syntmp-m1-983 syntmp-m2-984))) (syntmp-join-wraps-136 (lambda (syntmp-w1-985 syntmp-w2-986) (let ((syntmp-m1-987 (syntmp-wrap-marks-120 syntmp-w1-985)) (syntmp-s1-988 (syntmp-wrap-subst-121 syntmp-w1-985))) (if (null? syntmp-m1-987) (if (null? syntmp-s1-988) syntmp-w2-986 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-986) (syntmp-smart-append-135 syntmp-s1-988 (syntmp-wrap-subst-121 syntmp-w2-986)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-987 (syntmp-wrap-marks-120 syntmp-w2-986)) (syntmp-smart-append-135 syntmp-s1-988 (syntmp-wrap-subst-121 syntmp-w2-986))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-989 syntmp-m2-990) (if (null? syntmp-m2-990) syntmp-m1-989 (append syntmp-m1-989 syntmp-m2-990)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-991 syntmp-labels-992 syntmp-w-993) (if (null? syntmp-ids-991) syntmp-w-993 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-993) (cons (let ((syntmp-labelvec-994 (list->vector syntmp-labels-992))) (let ((syntmp-n-995 (vector-length syntmp-labelvec-994))) (let ((syntmp-symnamevec-996 (make-vector syntmp-n-995)) (syntmp-marksvec-997 (make-vector syntmp-n-995))) (begin (let syntmp-f-998 ((syntmp-ids-999 syntmp-ids-991) (syntmp-i-1000 0)) (if (not (null? syntmp-ids-999)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-999) syntmp-w-993)) (lambda (syntmp-symname-1001 syntmp-marks-1002) (begin (vector-set! syntmp-symnamevec-996 syntmp-i-1000 syntmp-symname-1001) (vector-set! syntmp-marksvec-997 syntmp-i-1000 syntmp-marks-1002) (syntmp-f-998 (cdr syntmp-ids-999) (syntmp-fx+-85 syntmp-i-1000 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-996 syntmp-marksvec-997 syntmp-labelvec-994))))) (syntmp-wrap-subst-121 syntmp-w-993)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1003 syntmp-id-1004 syntmp-label-1005) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1003 (cons (let ((syntmp-e-1006 (syntmp-syntax-object-expression-102 syntmp-id-1004))) (if (annotation? syntmp-e-1006) (annotation-expression syntmp-e-1006) syntmp-e-1006)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1003))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1003 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1004)) (syntmp-ribcage-marks-127 syntmp-ribcage-1003))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1003 (cons syntmp-label-1005 (syntmp-ribcage-labels-128 syntmp-ribcage-1003)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1007) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1007)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1007))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1008 syntmp-update-1009) (vector-set! syntmp-x-1008 3 syntmp-update-1009))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 2 syntmp-update-1011))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 1 syntmp-update-1013))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1014) (vector-ref syntmp-x-1014 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1015) (vector-ref syntmp-x-1015 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1017) (and (vector? syntmp-x-1017) (= (vector-length syntmp-x-1017) 4) (eq? (vector-ref syntmp-x-1017 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1018 syntmp-marks-1019 syntmp-labels-1020) (vector (quote ribcage) syntmp-symnames-1018 syntmp-marks-1019 syntmp-labels-1020))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1021) (if (null? syntmp-ls-1021) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1021)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1022 syntmp-w-1023) (if (syntmp-syntax-object?-101 syntmp-x-1022) (values (let ((syntmp-e-1024 (syntmp-syntax-object-expression-102 syntmp-x-1022))) (if (annotation? syntmp-e-1024) (annotation-expression syntmp-e-1024) syntmp-e-1024)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1023) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1022)))) (values (let ((syntmp-e-1025 syntmp-x-1022)) (if (annotation? syntmp-e-1025) (annotation-expression syntmp-e-1025) syntmp-e-1025)) (syntmp-wrap-marks-120 syntmp-w-1023))))) (syntmp-id?-117 (lambda (syntmp-x-1026) (cond ((symbol? syntmp-x-1026) #t) ((syntmp-syntax-object?-101 syntmp-x-1026) (symbol? (let ((syntmp-e-1027 (syntmp-syntax-object-expression-102 syntmp-x-1026))) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)))) ((annotation? syntmp-x-1026) (symbol? (annotation-expression syntmp-x-1026))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1028) (and (syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1030 syntmp-sym-1031 syntmp-val-1032) (syntmp-put-global-definition-hook-92 syntmp-sym-1031 (cons syntmp-type-1030 syntmp-val-1032)))) (syntmp-lookup-114 (lambda (syntmp-x-1033 syntmp-r-1034) (cond ((assq syntmp-x-1033 syntmp-r-1034) => cdr) ((symbol? syntmp-x-1033) (or (syntmp-get-global-definition-hook-93 syntmp-x-1033) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1035) (if (null? syntmp-r-1035) (quote ()) (let ((syntmp-a-1036 (car syntmp-r-1035))) (if (eq? (cadr syntmp-a-1036) (quote macro)) (cons syntmp-a-1036 (syntmp-macros-only-env-113 (cdr syntmp-r-1035))) (syntmp-macros-only-env-113 (cdr syntmp-r-1035))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1037 syntmp-vars-1038 syntmp-r-1039) (if (null? syntmp-labels-1037) syntmp-r-1039 (syntmp-extend-var-env-112 (cdr syntmp-labels-1037) (cdr syntmp-vars-1038) (cons (cons (car syntmp-labels-1037) (cons (quote lexical) (car syntmp-vars-1038))) syntmp-r-1039))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1040 syntmp-bindings-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-env-111 (cdr syntmp-labels-1040) (cdr syntmp-bindings-1041) (cons (cons (car syntmp-labels-1040) (car syntmp-bindings-1041)) syntmp-r-1042))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1043) (cond ((annotation? syntmp-x-1043) (annotation-source syntmp-x-1043)) ((syntmp-syntax-object?-101 syntmp-x-1043) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1043))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1044 syntmp-update-1045) (vector-set! syntmp-x-1044 3 syntmp-update-1045))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1046 syntmp-update-1047) (vector-set! syntmp-x-1046 2 syntmp-update-1047))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1048 syntmp-update-1049) (vector-set! syntmp-x-1048 1 syntmp-update-1049))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1050) (vector-ref syntmp-x-1050 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1051) (vector-ref syntmp-x-1051 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1052) (vector-ref syntmp-x-1052 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1053) (and (vector? syntmp-x-1053) (= (vector-length syntmp-x-1053) 4) (eq? (vector-ref syntmp-x-1053 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1054 syntmp-wrap-1055 syntmp-module-1056) (vector (quote syntax-object) syntmp-expression-1054 syntmp-wrap-1055 syntmp-module-1056))) (syntmp-build-letrec-99 (lambda (syntmp-src-1057 syntmp-vars-1058 syntmp-val-exps-1059 syntmp-body-exp-1060) (if (null? syntmp-vars-1058) (syntmp-build-annotated-94 syntmp-src-1057 syntmp-body-exp-1060) (syntmp-build-annotated-94 syntmp-src-1057 (list (quote letrec) (map list syntmp-vars-1058 syntmp-val-exps-1059) syntmp-body-exp-1060))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1061 syntmp-vars-1062 syntmp-val-exps-1063 syntmp-body-exp-1064) (if (null? syntmp-vars-1062) (syntmp-build-annotated-94 syntmp-src-1061 syntmp-body-exp-1064) (syntmp-build-annotated-94 syntmp-src-1061 (list (quote let) (car syntmp-vars-1062) (map list (cdr syntmp-vars-1062) syntmp-val-exps-1063) syntmp-body-exp-1064))))) (syntmp-build-let-97 (lambda (syntmp-src-1065 syntmp-vars-1066 syntmp-val-exps-1067 syntmp-body-exp-1068) (if (null? syntmp-vars-1066) (syntmp-build-annotated-94 syntmp-src-1065 syntmp-body-exp-1068) (syntmp-build-annotated-94 syntmp-src-1065 (list (quote let) (map list syntmp-vars-1066 syntmp-val-exps-1067) syntmp-body-exp-1068))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1069 syntmp-exps-1070) (if (null? (cdr syntmp-exps-1070)) (syntmp-build-annotated-94 syntmp-src-1069 (car syntmp-exps-1070)) (syntmp-build-annotated-94 syntmp-src-1069 (cons (quote begin) syntmp-exps-1070))))) (syntmp-build-data-95 (lambda (syntmp-src-1071 syntmp-exp-1072) (if (and (self-evaluating? syntmp-exp-1072) (not (vector? syntmp-exp-1072))) (syntmp-build-annotated-94 syntmp-src-1071 syntmp-exp-1072) (syntmp-build-annotated-94 syntmp-src-1071 (list (quote quote) syntmp-exp-1072))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1073 syntmp-exp-1074) (if (and syntmp-src-1073 (not (annotation? syntmp-exp-1074))) (make-annotation syntmp-exp-1074 syntmp-src-1073 #t) syntmp-exp-1074))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1075) (getprop syntmp-symbol-1075 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1076 syntmp-binding-1077) (putprop syntmp-symbol-1076 (quote *sc-expander*) syntmp-binding-1077))) (syntmp-error-hook-91 (lambda (syntmp-who-1078 syntmp-why-1079 syntmp-what-1080) (error syntmp-who-1078 "~a ~s" syntmp-why-1079 syntmp-what-1080))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1081 syntmp-mod-1082) (eval (list syntmp-noexpand-84 syntmp-x-1081) (or syntmp-mod-1082 (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1083 syntmp-mod-1084) (eval (list syntmp-noexpand-84 syntmp-x-1083) (or syntmp-mod-1084 (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1085 syntmp-r-1086 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089) ((lambda (syntmp-tmp-1090) ((lambda (syntmp-tmp-1091) (if (if syntmp-tmp-1091 (apply (lambda (syntmp-_-1092 syntmp-var-1093 syntmp-val-1094 syntmp-e1-1095 syntmp-e2-1096) (syntmp-valid-bound-ids?-142 syntmp-var-1093)) syntmp-tmp-1091) #f) (apply (lambda (syntmp-_-1098 syntmp-var-1099 syntmp-val-1100 syntmp-e1-1101 syntmp-e2-1102) (let ((syntmp-names-1103 (map (lambda (syntmp-x-1104) (syntmp-id-var-name-139 syntmp-x-1104 syntmp-w-1087)) syntmp-var-1099))) (begin (for-each (lambda (syntmp-id-1106 syntmp-n-1107) (let ((syntmp-t-1108 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1107 syntmp-r-1086)))) (if (memv syntmp-t-1108 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1106 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089) "identifier out of context")))) syntmp-var-1099 syntmp-names-1103) (syntmp-chi-body-157 (cons syntmp-e1-1101 syntmp-e2-1102) (syntmp-source-wrap-146 syntmp-e-1085 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089) (syntmp-extend-env-111 syntmp-names-1103 (let ((syntmp-trans-r-1111 (syntmp-macros-only-env-113 syntmp-r-1086))) (map (lambda (syntmp-x-1112) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1112 syntmp-trans-r-1111 syntmp-w-1087 syntmp-mod-1089) syntmp-mod-1089))) syntmp-val-1100)) syntmp-r-1086) syntmp-w-1087 syntmp-mod-1089)))) syntmp-tmp-1091) ((lambda (syntmp-_-1114) (syntax-error (syntmp-source-wrap-146 syntmp-e-1085 syntmp-w-1087 syntmp-s-1088 syntmp-mod-1089))) syntmp-tmp-1090))) (syntax-dispatch syntmp-tmp-1090 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1085))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1115 syntmp-r-1116 syntmp-w-1117 syntmp-s-1118 syntmp-mod-1119) ((lambda (syntmp-tmp-1120) ((lambda (syntmp-tmp-1121) (if syntmp-tmp-1121 (apply (lambda (syntmp-_-1122 syntmp-e-1123) (syntmp-build-data-95 syntmp-s-1118 (syntmp-strip-164 syntmp-e-1123 syntmp-w-1117))) syntmp-tmp-1121) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1115 syntmp-w-1117 syntmp-s-1118 syntmp-mod-1119))) syntmp-tmp-1120))) (syntax-dispatch syntmp-tmp-1120 (quote (any any))))) syntmp-e-1115))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1132 (lambda (syntmp-x-1133) (let ((syntmp-t-1134 (car syntmp-x-1133))) (if (memv syntmp-t-1134 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1133)) (if (memv syntmp-t-1134 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1133)) (if (memv syntmp-t-1134 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1133)) (if (memv syntmp-t-1134 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1133) (syntmp-regen-1132 (caddr syntmp-x-1133)))) (if (memv syntmp-t-1134 (quote (map))) (let ((syntmp-ls-1135 (map syntmp-regen-1132 (cdr syntmp-x-1133)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1135) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1135))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1133)) (map syntmp-regen-1132 (cdr syntmp-x-1133)))))))))))) (syntmp-gen-vector-1131 (lambda (syntmp-x-1136) (cond ((eq? (car syntmp-x-1136) (quote list)) (cons (quote vector) (cdr syntmp-x-1136))) ((eq? (car syntmp-x-1136) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1136)))) (else (list (quote list->vector) syntmp-x-1136))))) (syntmp-gen-append-1130 (lambda (syntmp-x-1137 syntmp-y-1138) (if (equal? syntmp-y-1138 (quote (quote ()))) syntmp-x-1137 (list (quote append) syntmp-x-1137 syntmp-y-1138)))) (syntmp-gen-cons-1129 (lambda (syntmp-x-1139 syntmp-y-1140) (let ((syntmp-t-1141 (car syntmp-y-1140))) (if (memv syntmp-t-1141 (quote (quote))) (if (eq? (car syntmp-x-1139) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1139) (cadr syntmp-y-1140))) (if (eq? (cadr syntmp-y-1140) (quote ())) (list (quote list) syntmp-x-1139) (list (quote cons) syntmp-x-1139 syntmp-y-1140))) (if (memv syntmp-t-1141 (quote (list))) (cons (quote list) (cons syntmp-x-1139 (cdr syntmp-y-1140))) (list (quote cons) syntmp-x-1139 syntmp-y-1140)))))) (syntmp-gen-map-1128 (lambda (syntmp-e-1142 syntmp-map-env-1143) (let ((syntmp-formals-1144 (map cdr syntmp-map-env-1143)) (syntmp-actuals-1145 (map (lambda (syntmp-x-1146) (list (quote ref) (car syntmp-x-1146))) syntmp-map-env-1143))) (cond ((eq? (car syntmp-e-1142) (quote ref)) (car syntmp-actuals-1145)) ((andmap (lambda (syntmp-x-1147) (and (eq? (car syntmp-x-1147) (quote ref)) (memq (cadr syntmp-x-1147) syntmp-formals-1144))) (cdr syntmp-e-1142)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1142)) (map (let ((syntmp-r-1148 (map cons syntmp-formals-1144 syntmp-actuals-1145))) (lambda (syntmp-x-1149) (cdr (assq (cadr syntmp-x-1149) syntmp-r-1148)))) (cdr syntmp-e-1142))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1144 syntmp-e-1142) syntmp-actuals-1145))))))) (syntmp-gen-mappend-1127 (lambda (syntmp-e-1150 syntmp-map-env-1151) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1128 syntmp-e-1150 syntmp-map-env-1151)))) (syntmp-gen-ref-1126 (lambda (syntmp-src-1152 syntmp-var-1153 syntmp-level-1154 syntmp-maps-1155) (if (syntmp-fx=-87 syntmp-level-1154 0) (values syntmp-var-1153 syntmp-maps-1155) (if (null? syntmp-maps-1155) (syntax-error syntmp-src-1152 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1126 syntmp-src-1152 syntmp-var-1153 (syntmp-fx--86 syntmp-level-1154 1) (cdr syntmp-maps-1155))) (lambda (syntmp-outer-var-1156 syntmp-outer-maps-1157) (let ((syntmp-b-1158 (assq syntmp-outer-var-1156 (car syntmp-maps-1155)))) (if syntmp-b-1158 (values (cdr syntmp-b-1158) syntmp-maps-1155) (let ((syntmp-inner-var-1159 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1159 (cons (cons (cons syntmp-outer-var-1156 syntmp-inner-var-1159) (car syntmp-maps-1155)) syntmp-outer-maps-1157))))))))))) (syntmp-gen-syntax-1125 (lambda (syntmp-src-1160 syntmp-e-1161 syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164) (if (syntmp-id?-117 syntmp-e-1161) (let ((syntmp-label-1165 (syntmp-id-var-name-139 syntmp-e-1161 (quote (()))))) (let ((syntmp-b-1166 (syntmp-lookup-114 syntmp-label-1165 syntmp-r-1162))) (if (eq? (syntmp-binding-type-109 syntmp-b-1166) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1167 (syntmp-binding-value-110 syntmp-b-1166))) (syntmp-gen-ref-1126 syntmp-src-1160 (car syntmp-var.lev-1167) (cdr syntmp-var.lev-1167) syntmp-maps-1163))) (lambda (syntmp-var-1168 syntmp-maps-1169) (values (list (quote ref) syntmp-var-1168) syntmp-maps-1169))) (if (syntmp-ellipsis?-1164 syntmp-e-1161) (syntax-error syntmp-src-1160 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1161) syntmp-maps-1163))))) ((lambda (syntmp-tmp-1170) ((lambda (syntmp-tmp-1171) (if (if syntmp-tmp-1171 (apply (lambda (syntmp-dots-1172 syntmp-e-1173) (syntmp-ellipsis?-1164 syntmp-dots-1172)) syntmp-tmp-1171) #f) (apply (lambda (syntmp-dots-1174 syntmp-e-1175) (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-e-1175 syntmp-r-1162 syntmp-maps-1163 (lambda (syntmp-x-1176) #f))) syntmp-tmp-1171) ((lambda (syntmp-tmp-1177) (if (if syntmp-tmp-1177 (apply (lambda (syntmp-x-1178 syntmp-dots-1179 syntmp-y-1180) (syntmp-ellipsis?-1164 syntmp-dots-1179)) syntmp-tmp-1177) #f) (apply (lambda (syntmp-x-1181 syntmp-dots-1182 syntmp-y-1183) (let syntmp-f-1184 ((syntmp-y-1185 syntmp-y-1183) (syntmp-k-1186 (lambda (syntmp-maps-1187) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-x-1181 syntmp-r-1162 (cons (quote ()) syntmp-maps-1187) syntmp-ellipsis?-1164)) (lambda (syntmp-x-1188 syntmp-maps-1189) (if (null? (car syntmp-maps-1189)) (syntax-error syntmp-src-1160 "extra ellipsis in syntax form") (values (syntmp-gen-map-1128 syntmp-x-1188 (car syntmp-maps-1189)) (cdr syntmp-maps-1189)))))))) ((lambda (syntmp-tmp-1190) ((lambda (syntmp-tmp-1191) (if (if syntmp-tmp-1191 (apply (lambda (syntmp-dots-1192 syntmp-y-1193) (syntmp-ellipsis?-1164 syntmp-dots-1192)) syntmp-tmp-1191) #f) (apply (lambda (syntmp-dots-1194 syntmp-y-1195) (syntmp-f-1184 syntmp-y-1195 (lambda (syntmp-maps-1196) (call-with-values (lambda () (syntmp-k-1186 (cons (quote ()) syntmp-maps-1196))) (lambda (syntmp-x-1197 syntmp-maps-1198) (if (null? (car syntmp-maps-1198)) (syntax-error syntmp-src-1160 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1127 syntmp-x-1197 (car syntmp-maps-1198)) (cdr syntmp-maps-1198)))))))) syntmp-tmp-1191) ((lambda (syntmp-_-1199) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-y-1185 syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164)) (lambda (syntmp-y-1200 syntmp-maps-1201) (call-with-values (lambda () (syntmp-k-1186 syntmp-maps-1201)) (lambda (syntmp-x-1202 syntmp-maps-1203) (values (syntmp-gen-append-1130 syntmp-x-1202 syntmp-y-1200) syntmp-maps-1203)))))) syntmp-tmp-1190))) (syntax-dispatch syntmp-tmp-1190 (quote (any . any))))) syntmp-y-1185))) syntmp-tmp-1177) ((lambda (syntmp-tmp-1204) (if syntmp-tmp-1204 (apply (lambda (syntmp-x-1205 syntmp-y-1206) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-x-1205 syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164)) (lambda (syntmp-x-1207 syntmp-maps-1208) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 syntmp-y-1206 syntmp-r-1162 syntmp-maps-1208 syntmp-ellipsis?-1164)) (lambda (syntmp-y-1209 syntmp-maps-1210) (values (syntmp-gen-cons-1129 syntmp-x-1207 syntmp-y-1209) syntmp-maps-1210)))))) syntmp-tmp-1204) ((lambda (syntmp-tmp-1211) (if syntmp-tmp-1211 (apply (lambda (syntmp-e1-1212 syntmp-e2-1213) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-src-1160 (cons syntmp-e1-1212 syntmp-e2-1213) syntmp-r-1162 syntmp-maps-1163 syntmp-ellipsis?-1164)) (lambda (syntmp-e-1215 syntmp-maps-1216) (values (syntmp-gen-vector-1131 syntmp-e-1215) syntmp-maps-1216)))) syntmp-tmp-1211) ((lambda (syntmp-_-1217) (values (list (quote quote) syntmp-e-1161) syntmp-maps-1163)) syntmp-tmp-1170))) (syntax-dispatch syntmp-tmp-1170 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1170 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1170 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1170 (quote (any any))))) syntmp-e-1161))))) (lambda (syntmp-e-1218 syntmp-r-1219 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) (let ((syntmp-e-1223 (syntmp-source-wrap-146 syntmp-e-1218 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222))) ((lambda (syntmp-tmp-1224) ((lambda (syntmp-tmp-1225) (if syntmp-tmp-1225 (apply (lambda (syntmp-_-1226 syntmp-x-1227) (call-with-values (lambda () (syntmp-gen-syntax-1125 syntmp-e-1223 syntmp-x-1227 syntmp-r-1219 (quote ()) syntmp-ellipsis?-162)) (lambda (syntmp-e-1228 syntmp-maps-1229) (syntmp-regen-1132 syntmp-e-1228)))) syntmp-tmp-1225) ((lambda (syntmp-_-1230) (syntax-error syntmp-e-1223)) syntmp-tmp-1224))) (syntax-dispatch syntmp-tmp-1224 (quote (any any))))) syntmp-e-1223))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1231 syntmp-r-1232 syntmp-w-1233 syntmp-s-1234 syntmp-mod-1235) ((lambda (syntmp-tmp-1236) ((lambda (syntmp-tmp-1237) (if syntmp-tmp-1237 (apply (lambda (syntmp-_-1238 syntmp-c-1239) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1231 syntmp-w-1233 syntmp-s-1234 syntmp-mod-1235) syntmp-c-1239 syntmp-r-1232 syntmp-w-1233 syntmp-mod-1235 (lambda (syntmp-vars-1240 syntmp-body-1241) (syntmp-build-annotated-94 syntmp-s-1234 (list (quote lambda) syntmp-vars-1240 syntmp-body-1241))))) syntmp-tmp-1237) (syntax-error syntmp-tmp-1236))) (syntax-dispatch syntmp-tmp-1236 (quote (any . any))))) syntmp-e-1231))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1242 (lambda (syntmp-e-1243 syntmp-r-1244 syntmp-w-1245 syntmp-s-1246 syntmp-mod-1247 syntmp-constructor-1248 syntmp-ids-1249 syntmp-vals-1250 syntmp-exps-1251) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1249)) (syntax-error syntmp-e-1243 "duplicate bound variable in") (let ((syntmp-labels-1252 (syntmp-gen-labels-123 syntmp-ids-1249)) (syntmp-new-vars-1253 (map syntmp-gen-var-165 syntmp-ids-1249))) (let ((syntmp-nw-1254 (syntmp-make-binding-wrap-134 syntmp-ids-1249 syntmp-labels-1252 syntmp-w-1245)) (syntmp-nr-1255 (syntmp-extend-var-env-112 syntmp-labels-1252 syntmp-new-vars-1253 syntmp-r-1244))) (syntmp-constructor-1248 syntmp-s-1246 syntmp-new-vars-1253 (map (lambda (syntmp-x-1256) (syntmp-chi-153 syntmp-x-1256 syntmp-r-1244 syntmp-w-1245 syntmp-mod-1247)) syntmp-vals-1250) (syntmp-chi-body-157 syntmp-exps-1251 (syntmp-source-wrap-146 syntmp-e-1243 syntmp-nw-1254 syntmp-s-1246 syntmp-mod-1247) syntmp-nr-1255 syntmp-nw-1254 syntmp-mod-1247)))))))) (lambda (syntmp-e-1257 syntmp-r-1258 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261) ((lambda (syntmp-tmp-1262) ((lambda (syntmp-tmp-1263) (if syntmp-tmp-1263 (apply (lambda (syntmp-_-1264 syntmp-id-1265 syntmp-val-1266 syntmp-e1-1267 syntmp-e2-1268) (syntmp-chi-let-1242 syntmp-e-1257 syntmp-r-1258 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261 syntmp-build-let-97 syntmp-id-1265 syntmp-val-1266 (cons syntmp-e1-1267 syntmp-e2-1268))) syntmp-tmp-1263) ((lambda (syntmp-tmp-1272) (if (if syntmp-tmp-1272 (apply (lambda (syntmp-_-1273 syntmp-f-1274 syntmp-id-1275 syntmp-val-1276 syntmp-e1-1277 syntmp-e2-1278) (syntmp-id?-117 syntmp-f-1274)) syntmp-tmp-1272) #f) (apply (lambda (syntmp-_-1279 syntmp-f-1280 syntmp-id-1281 syntmp-val-1282 syntmp-e1-1283 syntmp-e2-1284) (syntmp-chi-let-1242 syntmp-e-1257 syntmp-r-1258 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261 syntmp-build-named-let-98 (cons syntmp-f-1280 syntmp-id-1281) syntmp-val-1282 (cons syntmp-e1-1283 syntmp-e2-1284))) syntmp-tmp-1272) ((lambda (syntmp-_-1288) (syntax-error (syntmp-source-wrap-146 syntmp-e-1257 syntmp-w-1259 syntmp-s-1260 syntmp-mod-1261))) syntmp-tmp-1262))) (syntax-dispatch syntmp-tmp-1262 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1262 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1257)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1289 syntmp-r-1290 syntmp-w-1291 syntmp-s-1292 syntmp-mod-1293) ((lambda (syntmp-tmp-1294) ((lambda (syntmp-tmp-1295) (if syntmp-tmp-1295 (apply (lambda (syntmp-_-1296 syntmp-id-1297 syntmp-val-1298 syntmp-e1-1299 syntmp-e2-1300) (let ((syntmp-ids-1301 syntmp-id-1297)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1301)) (syntax-error syntmp-e-1289 "duplicate bound variable in") (let ((syntmp-labels-1303 (syntmp-gen-labels-123 syntmp-ids-1301)) (syntmp-new-vars-1304 (map syntmp-gen-var-165 syntmp-ids-1301))) (let ((syntmp-w-1305 (syntmp-make-binding-wrap-134 syntmp-ids-1301 syntmp-labels-1303 syntmp-w-1291)) (syntmp-r-1306 (syntmp-extend-var-env-112 syntmp-labels-1303 syntmp-new-vars-1304 syntmp-r-1290))) (syntmp-build-letrec-99 syntmp-s-1292 syntmp-new-vars-1304 (map (lambda (syntmp-x-1307) (syntmp-chi-153 syntmp-x-1307 syntmp-r-1306 syntmp-w-1305 syntmp-mod-1293)) syntmp-val-1298) (syntmp-chi-body-157 (cons syntmp-e1-1299 syntmp-e2-1300) (syntmp-source-wrap-146 syntmp-e-1289 syntmp-w-1305 syntmp-s-1292 syntmp-mod-1293) syntmp-r-1306 syntmp-w-1305 syntmp-mod-1293))))))) syntmp-tmp-1295) ((lambda (syntmp-_-1310) (syntax-error (syntmp-source-wrap-146 syntmp-e-1289 syntmp-w-1291 syntmp-s-1292 syntmp-mod-1293))) syntmp-tmp-1294))) (syntax-dispatch syntmp-tmp-1294 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1289))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1311 syntmp-r-1312 syntmp-w-1313 syntmp-s-1314 syntmp-mod-1315) ((lambda (syntmp-tmp-1316) ((lambda (syntmp-tmp-1317) (if (if syntmp-tmp-1317 (apply (lambda (syntmp-_-1318 syntmp-id-1319 syntmp-val-1320) (syntmp-id?-117 syntmp-id-1319)) syntmp-tmp-1317) #f) (apply (lambda (syntmp-_-1321 syntmp-id-1322 syntmp-val-1323) (let ((syntmp-val-1324 (syntmp-chi-153 syntmp-val-1323 syntmp-r-1312 syntmp-w-1313 syntmp-mod-1315)) (syntmp-n-1325 (syntmp-id-var-name-139 syntmp-id-1322 syntmp-w-1313))) (let ((syntmp-b-1326 (syntmp-lookup-114 syntmp-n-1325 syntmp-r-1312))) (let ((syntmp-t-1327 (syntmp-binding-type-109 syntmp-b-1326))) (if (memv syntmp-t-1327 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1314 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1326) syntmp-val-1324)) (if (memv syntmp-t-1327 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1314 (list (quote set!) (make-module-ref #f syntmp-n-1325 syntmp-mod-1315) syntmp-val-1324)) (if (memv syntmp-t-1327 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1322 syntmp-w-1313 #f) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1311 syntmp-w-1313 syntmp-s-1314 syntmp-mod-1315))))))))) syntmp-tmp-1317) ((lambda (syntmp-tmp-1328) (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-getter-1330 syntmp-arg-1331 syntmp-val-1332) (syntmp-build-annotated-94 syntmp-s-1314 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-getter-1330) syntmp-r-1312 syntmp-w-1313 syntmp-mod-1315) (map (lambda (syntmp-e-1333) (syntmp-chi-153 syntmp-e-1333 syntmp-r-1312 syntmp-w-1313 syntmp-mod-1315)) (append syntmp-arg-1331 (list syntmp-val-1332)))))) syntmp-tmp-1328) ((lambda (syntmp-_-1335) (syntax-error (syntmp-source-wrap-146 syntmp-e-1311 syntmp-w-1313 syntmp-s-1314 syntmp-mod-1315))) syntmp-tmp-1316))) (syntax-dispatch syntmp-tmp-1316 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1316 (quote (any any any))))) syntmp-e-1311))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1339 (lambda (syntmp-x-1340 syntmp-keys-1341 syntmp-clauses-1342 syntmp-r-1343 syntmp-mod-1344) (if (null? syntmp-clauses-1342) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1340)) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-pat-1347 syntmp-exp-1348) (if (and (syntmp-id?-117 syntmp-pat-1347) (andmap (lambda (syntmp-x-1349) (not (syntmp-free-id=?-140 syntmp-pat-1347 syntmp-x-1349))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-keys-1341))) (let ((syntmp-labels-1350 (list (syntmp-gen-label-122))) (syntmp-var-1351 (syntmp-gen-var-165 syntmp-pat-1347))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1351) (syntmp-chi-153 syntmp-exp-1348 (syntmp-extend-env-111 syntmp-labels-1350 (list (cons (quote syntax) (cons syntmp-var-1351 0))) syntmp-r-1343) (syntmp-make-binding-wrap-134 (list syntmp-pat-1347) syntmp-labels-1350 (quote (()))) syntmp-mod-1344))) syntmp-x-1340))) (syntmp-gen-clause-1338 syntmp-x-1340 syntmp-keys-1341 (cdr syntmp-clauses-1342) syntmp-r-1343 syntmp-pat-1347 #t syntmp-exp-1348 syntmp-mod-1344))) syntmp-tmp-1346) ((lambda (syntmp-tmp-1352) (if syntmp-tmp-1352 (apply (lambda (syntmp-pat-1353 syntmp-fender-1354 syntmp-exp-1355) (syntmp-gen-clause-1338 syntmp-x-1340 syntmp-keys-1341 (cdr syntmp-clauses-1342) syntmp-r-1343 syntmp-pat-1353 syntmp-fender-1354 syntmp-exp-1355 syntmp-mod-1344)) syntmp-tmp-1352) ((lambda (syntmp-_-1356) (syntax-error (car syntmp-clauses-1342) "invalid syntax-case clause")) syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1345 (quote (any any))))) (car syntmp-clauses-1342))))) (syntmp-gen-clause-1338 (lambda (syntmp-x-1357 syntmp-keys-1358 syntmp-clauses-1359 syntmp-r-1360 syntmp-pat-1361 syntmp-fender-1362 syntmp-exp-1363 syntmp-mod-1364) (call-with-values (lambda () (syntmp-convert-pattern-1336 syntmp-pat-1361 syntmp-keys-1358)) (lambda (syntmp-p-1365 syntmp-pvars-1366) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1366))) (syntax-error syntmp-pat-1361 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1367) (not (syntmp-ellipsis?-162 (car syntmp-x-1367)))) syntmp-pvars-1366)) (syntax-error syntmp-pat-1361 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1368 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1368) (let ((syntmp-y-1369 (syntmp-build-annotated-94 #f syntmp-y-1368))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1370) ((lambda (syntmp-tmp-1371) (if syntmp-tmp-1371 (apply (lambda () syntmp-y-1369) syntmp-tmp-1371) ((lambda (syntmp-_-1372) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1369 (syntmp-build-dispatch-call-1337 syntmp-pvars-1366 syntmp-fender-1362 syntmp-y-1369 syntmp-r-1360 syntmp-mod-1364) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1370))) (syntax-dispatch syntmp-tmp-1370 (quote #(atom #t))))) syntmp-fender-1362) (syntmp-build-dispatch-call-1337 syntmp-pvars-1366 syntmp-exp-1363 syntmp-y-1369 syntmp-r-1360 syntmp-mod-1364) (syntmp-gen-syntax-case-1339 syntmp-x-1357 syntmp-keys-1358 syntmp-clauses-1359 syntmp-r-1360 syntmp-mod-1364)))))) (if (eq? syntmp-p-1365 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1357)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1357 (syntmp-build-data-95 #f syntmp-p-1365))))))))))))) (syntmp-build-dispatch-call-1337 (lambda (syntmp-pvars-1373 syntmp-exp-1374 syntmp-y-1375 syntmp-r-1376 syntmp-mod-1377) (let ((syntmp-ids-1378 (map car syntmp-pvars-1373)) (syntmp-levels-1379 (map cdr syntmp-pvars-1373))) (let ((syntmp-labels-1380 (syntmp-gen-labels-123 syntmp-ids-1378)) (syntmp-new-vars-1381 (map syntmp-gen-var-165 syntmp-ids-1378))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1381 (syntmp-chi-153 syntmp-exp-1374 (syntmp-extend-env-111 syntmp-labels-1380 (map (lambda (syntmp-var-1382 syntmp-level-1383) (cons (quote syntax) (cons syntmp-var-1382 syntmp-level-1383))) syntmp-new-vars-1381 (map cdr syntmp-pvars-1373)) syntmp-r-1376) (syntmp-make-binding-wrap-134 syntmp-ids-1378 syntmp-labels-1380 (quote (()))) syntmp-mod-1377))) syntmp-y-1375)))))) (syntmp-convert-pattern-1336 (lambda (syntmp-pattern-1384 syntmp-keys-1385) (let syntmp-cvt-1386 ((syntmp-p-1387 syntmp-pattern-1384) (syntmp-n-1388 0) (syntmp-ids-1389 (quote ()))) (if (syntmp-id?-117 syntmp-p-1387) (if (syntmp-bound-id-member?-144 syntmp-p-1387 syntmp-keys-1385) (values (vector (quote free-id) syntmp-p-1387) syntmp-ids-1389) (values (quote any) (cons (cons syntmp-p-1387 syntmp-n-1388) syntmp-ids-1389))) ((lambda (syntmp-tmp-1390) ((lambda (syntmp-tmp-1391) (if (if syntmp-tmp-1391 (apply (lambda (syntmp-x-1392 syntmp-dots-1393) (syntmp-ellipsis?-162 syntmp-dots-1393)) syntmp-tmp-1391) #f) (apply (lambda (syntmp-x-1394 syntmp-dots-1395) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-x-1394 (syntmp-fx+-85 syntmp-n-1388 1) syntmp-ids-1389)) (lambda (syntmp-p-1396 syntmp-ids-1397) (values (if (eq? syntmp-p-1396 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1396)) syntmp-ids-1397)))) syntmp-tmp-1391) ((lambda (syntmp-tmp-1398) (if syntmp-tmp-1398 (apply (lambda (syntmp-x-1399 syntmp-y-1400) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-y-1400 syntmp-n-1388 syntmp-ids-1389)) (lambda (syntmp-y-1401 syntmp-ids-1402) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-x-1399 syntmp-n-1388 syntmp-ids-1402)) (lambda (syntmp-x-1403 syntmp-ids-1404) (values (cons syntmp-x-1403 syntmp-y-1401) syntmp-ids-1404)))))) syntmp-tmp-1398) ((lambda (syntmp-tmp-1405) (if syntmp-tmp-1405 (apply (lambda () (values (quote ()) syntmp-ids-1389)) syntmp-tmp-1405) ((lambda (syntmp-tmp-1406) (if syntmp-tmp-1406 (apply (lambda (syntmp-x-1407) (call-with-values (lambda () (syntmp-cvt-1386 syntmp-x-1407 syntmp-n-1388 syntmp-ids-1389)) (lambda (syntmp-p-1409 syntmp-ids-1410) (values (vector (quote vector) syntmp-p-1409) syntmp-ids-1410)))) syntmp-tmp-1406) ((lambda (syntmp-x-1411) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1387 (quote (())))) syntmp-ids-1389)) syntmp-tmp-1390))) (syntax-dispatch syntmp-tmp-1390 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1390 (quote ()))))) (syntax-dispatch syntmp-tmp-1390 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1390 (quote (any any))))) syntmp-p-1387)))))) (lambda (syntmp-e-1412 syntmp-r-1413 syntmp-w-1414 syntmp-s-1415 syntmp-mod-1416) (let ((syntmp-e-1417 (syntmp-source-wrap-146 syntmp-e-1412 syntmp-w-1414 syntmp-s-1415 syntmp-mod-1416))) ((lambda (syntmp-tmp-1418) ((lambda (syntmp-tmp-1419) (if syntmp-tmp-1419 (apply (lambda (syntmp-_-1420 syntmp-val-1421 syntmp-key-1422 syntmp-m-1423) (if (andmap (lambda (syntmp-x-1424) (and (syntmp-id?-117 syntmp-x-1424) (not (syntmp-ellipsis?-162 syntmp-x-1424)))) syntmp-key-1422) (let ((syntmp-x-1426 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1415 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1426) (syntmp-gen-syntax-case-1339 (syntmp-build-annotated-94 #f syntmp-x-1426) syntmp-key-1422 syntmp-m-1423 syntmp-r-1413 syntmp-mod-1416))) (syntmp-chi-153 syntmp-val-1421 syntmp-r-1413 (quote (())) syntmp-mod-1416)))) (syntax-error syntmp-e-1417 "invalid literals list in"))) syntmp-tmp-1419) (syntax-error syntmp-tmp-1418))) (syntax-dispatch syntmp-tmp-1418 (quote (any any each-any . each-any))))) syntmp-e-1417))))) (set! sc-expand (let ((syntmp-m-1429 (quote e)) (syntmp-esew-1430 (quote (eval)))) (lambda (syntmp-x-1431) (if (and (pair? syntmp-x-1431) (equal? (car syntmp-x-1431) syntmp-noexpand-84)) (cadr syntmp-x-1431) (syntmp-chi-top-152 syntmp-x-1431 (quote ()) (quote ((top))) syntmp-m-1429 syntmp-esew-1430 (current-module)))))) (set! sc-expand3 (let ((syntmp-m-1432 (quote e)) (syntmp-esew-1433 (quote (eval)))) (lambda (syntmp-x-1435 . syntmp-rest-1434) (if (and (pair? syntmp-x-1435) (equal? (car syntmp-x-1435) syntmp-noexpand-84)) (cadr syntmp-x-1435) (syntmp-chi-top-152 syntmp-x-1435 (quote ()) (quote ((top))) (if (null? syntmp-rest-1434) syntmp-m-1432 (car syntmp-rest-1434)) (if (or (null? syntmp-rest-1434) (null? (cdr syntmp-rest-1434))) syntmp-esew-1433 (cadr syntmp-rest-1434)) (current-module)))))) (set! identifier? (lambda (syntmp-x-1436) (syntmp-nonsymbol-id?-116 syntmp-x-1436))) (set! datum->syntax-object (lambda (syntmp-id-1437 syntmp-datum-1438) (syntmp-make-syntax-object-100 syntmp-datum-1438 (syntmp-syntax-object-wrap-103 syntmp-id-1437) #f))) (set! syntax-object->datum (lambda (syntmp-x-1439) (syntmp-strip-164 syntmp-x-1439 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1440) (begin (let ((syntmp-x-1441 syntmp-ls-1440)) (if (not (list? syntmp-x-1441)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1441))) (map (lambda (syntmp-x-1442) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1440)))) (set! free-identifier=? (lambda (syntmp-x-1443 syntmp-y-1444) (begin (let ((syntmp-x-1445 syntmp-x-1443)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1445)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1445))) (let ((syntmp-x-1446 syntmp-y-1444)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1446)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1446))) (syntmp-free-id=?-140 syntmp-x-1443 syntmp-y-1444)))) (set! bound-identifier=? (lambda (syntmp-x-1447 syntmp-y-1448) (begin (let ((syntmp-x-1449 syntmp-x-1447)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1449)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1449))) (let ((syntmp-x-1450 syntmp-y-1448)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1450)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1450))) (syntmp-bound-id=?-141 syntmp-x-1447 syntmp-y-1448)))) (set! syntax-error (lambda (syntmp-object-1452 . syntmp-messages-1451) (begin (for-each (lambda (syntmp-x-1453) (let ((syntmp-x-1454 syntmp-x-1453)) (if (not (string? syntmp-x-1454)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1454)))) syntmp-messages-1451) (let ((syntmp-message-1455 (if (null? syntmp-messages-1451) "invalid syntax" (apply string-append syntmp-messages-1451)))) (syntmp-error-hook-91 #f syntmp-message-1455 (syntmp-strip-164 syntmp-object-1452 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1456 syntmp-v-1457) (begin (let ((syntmp-x-1458 syntmp-sym-1456)) (if (not (symbol? syntmp-x-1458)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1458))) (let ((syntmp-x-1459 syntmp-v-1457)) (if (not (procedure? syntmp-x-1459)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1459))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1456 syntmp-v-1457)))) (letrec ((syntmp-match-1464 (lambda (syntmp-e-1465 syntmp-p-1466 syntmp-w-1467 syntmp-r-1468) (cond ((not syntmp-r-1468) #f) ((eq? syntmp-p-1466 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1465 syntmp-w-1467 #f) syntmp-r-1468)) ((syntmp-syntax-object?-101 syntmp-e-1465) (syntmp-match*-1463 (let ((syntmp-e-1469 (syntmp-syntax-object-expression-102 syntmp-e-1465))) (if (annotation? syntmp-e-1469) (annotation-expression syntmp-e-1469) syntmp-e-1469)) syntmp-p-1466 (syntmp-join-wraps-136 syntmp-w-1467 (syntmp-syntax-object-wrap-103 syntmp-e-1465)) syntmp-r-1468)) (else (syntmp-match*-1463 (let ((syntmp-e-1470 syntmp-e-1465)) (if (annotation? syntmp-e-1470) (annotation-expression syntmp-e-1470) syntmp-e-1470)) syntmp-p-1466 syntmp-w-1467 syntmp-r-1468))))) (syntmp-match*-1463 (lambda (syntmp-e-1471 syntmp-p-1472 syntmp-w-1473 syntmp-r-1474) (cond ((null? syntmp-p-1472) (and (null? syntmp-e-1471) syntmp-r-1474)) ((pair? syntmp-p-1472) (and (pair? syntmp-e-1471) (syntmp-match-1464 (car syntmp-e-1471) (car syntmp-p-1472) syntmp-w-1473 (syntmp-match-1464 (cdr syntmp-e-1471) (cdr syntmp-p-1472) syntmp-w-1473 syntmp-r-1474)))) ((eq? syntmp-p-1472 (quote each-any)) (let ((syntmp-l-1475 (syntmp-match-each-any-1461 syntmp-e-1471 syntmp-w-1473))) (and syntmp-l-1475 (cons syntmp-l-1475 syntmp-r-1474)))) (else (let ((syntmp-t-1476 (vector-ref syntmp-p-1472 0))) (if (memv syntmp-t-1476 (quote (each))) (if (null? syntmp-e-1471) (syntmp-match-empty-1462 (vector-ref syntmp-p-1472 1) syntmp-r-1474) (let ((syntmp-l-1477 (syntmp-match-each-1460 syntmp-e-1471 (vector-ref syntmp-p-1472 1) syntmp-w-1473))) (and syntmp-l-1477 (let syntmp-collect-1478 ((syntmp-l-1479 syntmp-l-1477)) (if (null? (car syntmp-l-1479)) syntmp-r-1474 (cons (map car syntmp-l-1479) (syntmp-collect-1478 (map cdr syntmp-l-1479)))))))) (if (memv syntmp-t-1476 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1471) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1471 syntmp-w-1473 #f) (vector-ref syntmp-p-1472 1)) syntmp-r-1474) (if (memv syntmp-t-1476 (quote (atom))) (and (equal? (vector-ref syntmp-p-1472 1) (syntmp-strip-164 syntmp-e-1471 syntmp-w-1473)) syntmp-r-1474) (if (memv syntmp-t-1476 (quote (vector))) (and (vector? syntmp-e-1471) (syntmp-match-1464 (vector->list syntmp-e-1471) (vector-ref syntmp-p-1472 1) syntmp-w-1473 syntmp-r-1474))))))))))) (syntmp-match-empty-1462 (lambda (syntmp-p-1480 syntmp-r-1481) (cond ((null? syntmp-p-1480) syntmp-r-1481) ((eq? syntmp-p-1480 (quote any)) (cons (quote ()) syntmp-r-1481)) ((pair? syntmp-p-1480) (syntmp-match-empty-1462 (car syntmp-p-1480) (syntmp-match-empty-1462 (cdr syntmp-p-1480) syntmp-r-1481))) ((eq? syntmp-p-1480 (quote each-any)) (cons (quote ()) syntmp-r-1481)) (else (let ((syntmp-t-1482 (vector-ref syntmp-p-1480 0))) (if (memv syntmp-t-1482 (quote (each))) (syntmp-match-empty-1462 (vector-ref syntmp-p-1480 1) syntmp-r-1481) (if (memv syntmp-t-1482 (quote (free-id atom))) syntmp-r-1481 (if (memv syntmp-t-1482 (quote (vector))) (syntmp-match-empty-1462 (vector-ref syntmp-p-1480 1) syntmp-r-1481))))))))) (syntmp-match-each-any-1461 (lambda (syntmp-e-1483 syntmp-w-1484) (cond ((annotation? syntmp-e-1483) (syntmp-match-each-any-1461 (annotation-expression syntmp-e-1483) syntmp-w-1484)) ((pair? syntmp-e-1483) (let ((syntmp-l-1485 (syntmp-match-each-any-1461 (cdr syntmp-e-1483) syntmp-w-1484))) (and syntmp-l-1485 (cons (syntmp-wrap-145 (car syntmp-e-1483) syntmp-w-1484 #f) syntmp-l-1485)))) ((null? syntmp-e-1483) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1483) (syntmp-match-each-any-1461 (syntmp-syntax-object-expression-102 syntmp-e-1483) (syntmp-join-wraps-136 syntmp-w-1484 (syntmp-syntax-object-wrap-103 syntmp-e-1483)))) (else #f)))) (syntmp-match-each-1460 (lambda (syntmp-e-1486 syntmp-p-1487 syntmp-w-1488) (cond ((annotation? syntmp-e-1486) (syntmp-match-each-1460 (annotation-expression syntmp-e-1486) syntmp-p-1487 syntmp-w-1488)) ((pair? syntmp-e-1486) (let ((syntmp-first-1489 (syntmp-match-1464 (car syntmp-e-1486) syntmp-p-1487 syntmp-w-1488 (quote ())))) (and syntmp-first-1489 (let ((syntmp-rest-1490 (syntmp-match-each-1460 (cdr syntmp-e-1486) syntmp-p-1487 syntmp-w-1488))) (and syntmp-rest-1490 (cons syntmp-first-1489 syntmp-rest-1490)))))) ((null? syntmp-e-1486) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1486) (syntmp-match-each-1460 (syntmp-syntax-object-expression-102 syntmp-e-1486) syntmp-p-1487 (syntmp-join-wraps-136 syntmp-w-1488 (syntmp-syntax-object-wrap-103 syntmp-e-1486)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1491 syntmp-p-1492) (cond ((eq? syntmp-p-1492 (quote any)) (list syntmp-e-1491)) ((syntmp-syntax-object?-101 syntmp-e-1491) (syntmp-match*-1463 (let ((syntmp-e-1493 (syntmp-syntax-object-expression-102 syntmp-e-1491))) (if (annotation? syntmp-e-1493) (annotation-expression syntmp-e-1493) syntmp-e-1493)) syntmp-p-1492 (syntmp-syntax-object-wrap-103 syntmp-e-1491) (quote ()))) (else (syntmp-match*-1463 (let ((syntmp-e-1494 syntmp-e-1491)) (if (annotation? syntmp-e-1494) (annotation-expression syntmp-e-1494) syntmp-e-1494)) syntmp-p-1492 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-153))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1495) ((lambda (syntmp-tmp-1496) ((lambda (syntmp-tmp-1497) (if syntmp-tmp-1497 (apply (lambda (syntmp-_-1498 syntmp-e1-1499 syntmp-e2-1500) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1499 syntmp-e2-1500))) syntmp-tmp-1497) ((lambda (syntmp-tmp-1502) (if syntmp-tmp-1502 (apply (lambda (syntmp-_-1503 syntmp-out-1504 syntmp-in-1505 syntmp-e1-1506 syntmp-e2-1507) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1505 (quote ()) (list syntmp-out-1504 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1506 syntmp-e2-1507))))) syntmp-tmp-1502) ((lambda (syntmp-tmp-1509) (if syntmp-tmp-1509 (apply (lambda (syntmp-_-1510 syntmp-out-1511 syntmp-in-1512 syntmp-e1-1513 syntmp-e2-1514) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1512) (quote ()) (list syntmp-out-1511 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1513 syntmp-e2-1514))))) syntmp-tmp-1509) (syntax-error syntmp-tmp-1496))) (syntax-dispatch syntmp-tmp-1496 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1496 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1496 (quote (any () any . each-any))))) syntmp-x-1495))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1536) ((lambda (syntmp-tmp-1537) ((lambda (syntmp-tmp-1538) (if syntmp-tmp-1538 (apply (lambda (syntmp-_-1539 syntmp-k-1540 syntmp-keyword-1541 syntmp-pattern-1542 syntmp-template-1543) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-k-1540 (map (lambda (syntmp-tmp-1546 syntmp-tmp-1545) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1545) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1546))) syntmp-template-1543 syntmp-pattern-1542)))))) syntmp-tmp-1538) (syntax-error syntmp-tmp-1537))) (syntax-dispatch syntmp-tmp-1537 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1536))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1557) ((lambda (syntmp-tmp-1558) ((lambda (syntmp-tmp-1559) (if (if syntmp-tmp-1559 (apply (lambda (syntmp-let*-1560 syntmp-x-1561 syntmp-v-1562 syntmp-e1-1563 syntmp-e2-1564) (andmap identifier? syntmp-x-1561)) syntmp-tmp-1559) #f) (apply (lambda (syntmp-let*-1566 syntmp-x-1567 syntmp-v-1568 syntmp-e1-1569 syntmp-e2-1570) (let syntmp-f-1571 ((syntmp-bindings-1572 (map list syntmp-x-1567 syntmp-v-1568))) (if (null? syntmp-bindings-1572) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote ()) (cons syntmp-e1-1569 syntmp-e2-1570))) ((lambda (syntmp-tmp-1576) ((lambda (syntmp-tmp-1577) (if syntmp-tmp-1577 (apply (lambda (syntmp-body-1578 syntmp-binding-1579) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list syntmp-binding-1579) syntmp-body-1578)) syntmp-tmp-1577) (syntax-error syntmp-tmp-1576))) (syntax-dispatch syntmp-tmp-1576 (quote (any any))))) (list (syntmp-f-1571 (cdr syntmp-bindings-1572)) (car syntmp-bindings-1572)))))) syntmp-tmp-1559) (syntax-error syntmp-tmp-1558))) (syntax-dispatch syntmp-tmp-1558 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1557))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1599) ((lambda (syntmp-tmp-1600) ((lambda (syntmp-tmp-1601) (if syntmp-tmp-1601 (apply (lambda (syntmp-_-1602 syntmp-var-1603 syntmp-init-1604 syntmp-step-1605 syntmp-e0-1606 syntmp-e1-1607 syntmp-c-1608) ((lambda (syntmp-tmp-1609) ((lambda (syntmp-tmp-1610) (if syntmp-tmp-1610 (apply (lambda (syntmp-step-1611) ((lambda (syntmp-tmp-1612) ((lambda (syntmp-tmp-1613) (if syntmp-tmp-1613 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1603 syntmp-init-1604) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1606) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1608 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1611))))))) syntmp-tmp-1613) ((lambda (syntmp-tmp-1618) (if syntmp-tmp-1618 (apply (lambda (syntmp-e1-1619 syntmp-e2-1620) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1603 syntmp-init-1604) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1606 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (cons syntmp-e1-1619 syntmp-e2-1620)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1608 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1611))))))) syntmp-tmp-1618) (syntax-error syntmp-tmp-1612))) (syntax-dispatch syntmp-tmp-1612 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1612 (quote ())))) syntmp-e1-1607)) syntmp-tmp-1610) (syntax-error syntmp-tmp-1609))) (syntax-dispatch syntmp-tmp-1609 (quote each-any)))) (map (lambda (syntmp-v-1627 syntmp-s-1628) ((lambda (syntmp-tmp-1629) ((lambda (syntmp-tmp-1630) (if syntmp-tmp-1630 (apply (lambda () syntmp-v-1627) syntmp-tmp-1630) ((lambda (syntmp-tmp-1631) (if syntmp-tmp-1631 (apply (lambda (syntmp-e-1632) syntmp-e-1632) syntmp-tmp-1631) ((lambda (syntmp-_-1633) (syntax-error syntmp-orig-x-1599)) syntmp-tmp-1629))) (syntax-dispatch syntmp-tmp-1629 (quote (any)))))) (syntax-dispatch syntmp-tmp-1629 (quote ())))) syntmp-s-1628)) syntmp-var-1603 syntmp-step-1605))) syntmp-tmp-1601) (syntax-error syntmp-tmp-1600))) (syntax-dispatch syntmp-tmp-1600 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1599))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1661 (lambda (syntmp-x-1665 syntmp-y-1666) ((lambda (syntmp-tmp-1667) ((lambda (syntmp-tmp-1668) (if syntmp-tmp-1668 (apply (lambda (syntmp-x-1669 syntmp-y-1670) ((lambda (syntmp-tmp-1671) ((lambda (syntmp-tmp-1672) (if syntmp-tmp-1672 (apply (lambda (syntmp-dy-1673) ((lambda (syntmp-tmp-1674) ((lambda (syntmp-tmp-1675) (if syntmp-tmp-1675 (apply (lambda (syntmp-dx-1676) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-dx-1676 syntmp-dy-1673))) syntmp-tmp-1675) ((lambda (syntmp-_-1677) (if (null? syntmp-dy-1673) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1669) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1669 syntmp-y-1670))) syntmp-tmp-1674))) (syntax-dispatch syntmp-tmp-1674 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-x-1669)) syntmp-tmp-1672) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-stuff-1679) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-x-1669 syntmp-stuff-1679))) syntmp-tmp-1678) ((lambda (syntmp-else-1680) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1669 syntmp-y-1670)) syntmp-tmp-1671))) (syntax-dispatch syntmp-tmp-1671 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . any)))))) (syntax-dispatch syntmp-tmp-1671 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-y-1670)) syntmp-tmp-1668) (syntax-error syntmp-tmp-1667))) (syntax-dispatch syntmp-tmp-1667 (quote (any any))))) (list syntmp-x-1665 syntmp-y-1666)))) (syntmp-quasiappend-1662 (lambda (syntmp-x-1681 syntmp-y-1682) ((lambda (syntmp-tmp-1683) ((lambda (syntmp-tmp-1684) (if syntmp-tmp-1684 (apply (lambda (syntmp-x-1685 syntmp-y-1686) ((lambda (syntmp-tmp-1687) ((lambda (syntmp-tmp-1688) (if syntmp-tmp-1688 (apply (lambda () syntmp-x-1685) syntmp-tmp-1688) ((lambda (syntmp-_-1689) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1685 syntmp-y-1686)) syntmp-tmp-1687))) (syntax-dispatch syntmp-tmp-1687 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) ()))))) syntmp-y-1686)) syntmp-tmp-1684) (syntax-error syntmp-tmp-1683))) (syntax-dispatch syntmp-tmp-1683 (quote (any any))))) (list syntmp-x-1681 syntmp-y-1682)))) (syntmp-quasivector-1663 (lambda (syntmp-x-1690) ((lambda (syntmp-tmp-1691) ((lambda (syntmp-x-1692) ((lambda (syntmp-tmp-1693) ((lambda (syntmp-tmp-1694) (if syntmp-tmp-1694 (apply (lambda (syntmp-x-1695) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (list->vector syntmp-x-1695))) syntmp-tmp-1694) ((lambda (syntmp-tmp-1697) (if syntmp-tmp-1697 (apply (lambda (syntmp-x-1698) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1698)) syntmp-tmp-1697) ((lambda (syntmp-_-1700) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1692)) syntmp-tmp-1693))) (syntax-dispatch syntmp-tmp-1693 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . each-any)))))) (syntax-dispatch syntmp-tmp-1693 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) each-any))))) syntmp-x-1692)) syntmp-tmp-1691)) syntmp-x-1690))) (syntmp-quasi-1664 (lambda (syntmp-p-1701 syntmp-lev-1702) ((lambda (syntmp-tmp-1703) ((lambda (syntmp-tmp-1704) (if syntmp-tmp-1704 (apply (lambda (syntmp-p-1705) (if (= syntmp-lev-1702 0) syntmp-p-1705 (syntmp-quasicons-1661 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1664 (list syntmp-p-1705) (- syntmp-lev-1702 1))))) syntmp-tmp-1704) ((lambda (syntmp-tmp-1706) (if syntmp-tmp-1706 (apply (lambda (syntmp-p-1707 syntmp-q-1708) (if (= syntmp-lev-1702 0) (syntmp-quasiappend-1662 syntmp-p-1707 (syntmp-quasi-1664 syntmp-q-1708 syntmp-lev-1702)) (syntmp-quasicons-1661 (syntmp-quasicons-1661 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1664 (list syntmp-p-1707) (- syntmp-lev-1702 1))) (syntmp-quasi-1664 syntmp-q-1708 syntmp-lev-1702)))) syntmp-tmp-1706) ((lambda (syntmp-tmp-1709) (if syntmp-tmp-1709 (apply (lambda (syntmp-p-1710) (syntmp-quasicons-1661 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1664 (list syntmp-p-1710) (+ syntmp-lev-1702 1)))) syntmp-tmp-1709) ((lambda (syntmp-tmp-1711) (if syntmp-tmp-1711 (apply (lambda (syntmp-p-1712 syntmp-q-1713) (syntmp-quasicons-1661 (syntmp-quasi-1664 syntmp-p-1712 syntmp-lev-1702) (syntmp-quasi-1664 syntmp-q-1713 syntmp-lev-1702))) syntmp-tmp-1711) ((lambda (syntmp-tmp-1714) (if syntmp-tmp-1714 (apply (lambda (syntmp-x-1715) (syntmp-quasivector-1663 (syntmp-quasi-1664 syntmp-x-1715 syntmp-lev-1702))) syntmp-tmp-1714) ((lambda (syntmp-p-1717) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-p-1717)) syntmp-tmp-1703))) (syntax-dispatch syntmp-tmp-1703 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1703 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1703 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any)))))) (syntax-dispatch syntmp-tmp-1703 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any) . any)))))) (syntax-dispatch syntmp-tmp-1703 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-p-1701)))) (lambda (syntmp-x-1718) ((lambda (syntmp-tmp-1719) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-_-1721 syntmp-e-1722) (syntmp-quasi-1664 syntmp-e-1722 0)) syntmp-tmp-1720) (syntax-error syntmp-tmp-1719))) (syntax-dispatch syntmp-tmp-1719 (quote (any any))))) syntmp-x-1718)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1782) (letrec ((syntmp-read-file-1783 (lambda (syntmp-fn-1784 syntmp-k-1785) (let ((syntmp-p-1786 (open-input-file syntmp-fn-1784))) (let syntmp-f-1787 ((syntmp-x-1788 (read syntmp-p-1786))) (if (eof-object? syntmp-x-1788) (begin (close-input-port syntmp-p-1786) (quote ())) (cons (datum->syntax-object syntmp-k-1785 syntmp-x-1788) (syntmp-f-1787 (read syntmp-p-1786))))))))) ((lambda (syntmp-tmp-1789) ((lambda (syntmp-tmp-1790) (if syntmp-tmp-1790 (apply (lambda (syntmp-k-1791 syntmp-filename-1792) (let ((syntmp-fn-1793 (syntax-object->datum syntmp-filename-1792))) ((lambda (syntmp-tmp-1794) ((lambda (syntmp-tmp-1795) (if syntmp-tmp-1795 (apply (lambda (syntmp-exp-1796) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-exp-1796)) syntmp-tmp-1795) (syntax-error syntmp-tmp-1794))) (syntax-dispatch syntmp-tmp-1794 (quote each-any)))) (syntmp-read-file-1783 syntmp-fn-1793 syntmp-k-1791)))) syntmp-tmp-1790) (syntax-error syntmp-tmp-1789))) (syntax-dispatch syntmp-tmp-1789 (quote (any any))))) syntmp-x-1782)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1813) ((lambda (syntmp-tmp-1814) ((lambda (syntmp-tmp-1815) (if syntmp-tmp-1815 (apply (lambda (syntmp-_-1816 syntmp-e-1817) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1817))) syntmp-tmp-1815) (syntax-error syntmp-tmp-1814))) (syntax-dispatch syntmp-tmp-1814 (quote (any any))))) syntmp-x-1813))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1823) ((lambda (syntmp-tmp-1824) ((lambda (syntmp-tmp-1825) (if syntmp-tmp-1825 (apply (lambda (syntmp-_-1826 syntmp-e-1827) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1827))) syntmp-tmp-1825) (syntax-error syntmp-tmp-1824))) (syntax-dispatch syntmp-tmp-1824 (quote (any any))))) syntmp-x-1823))) -(install-global-transformer (quote case) (lambda (syntmp-x-1833) ((lambda (syntmp-tmp-1834) ((lambda (syntmp-tmp-1835) (if syntmp-tmp-1835 (apply (lambda (syntmp-_-1836 syntmp-e-1837 syntmp-m1-1838 syntmp-m2-1839) ((lambda (syntmp-tmp-1840) ((lambda (syntmp-body-1841) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1837)) syntmp-body-1841)) syntmp-tmp-1840)) (let syntmp-f-1842 ((syntmp-clause-1843 syntmp-m1-1838) (syntmp-clauses-1844 syntmp-m2-1839)) (if (null? syntmp-clauses-1844) ((lambda (syntmp-tmp-1846) ((lambda (syntmp-tmp-1847) (if syntmp-tmp-1847 (apply (lambda (syntmp-e1-1848 syntmp-e2-1849) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1848 syntmp-e2-1849))) syntmp-tmp-1847) ((lambda (syntmp-tmp-1851) (if syntmp-tmp-1851 (apply (lambda (syntmp-k-1852 syntmp-e1-1853 syntmp-e2-1854) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1852)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1853 syntmp-e2-1854)))) syntmp-tmp-1851) ((lambda (syntmp-_-1857) (syntax-error syntmp-x-1833)) syntmp-tmp-1846))) (syntax-dispatch syntmp-tmp-1846 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1846 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) any . each-any))))) syntmp-clause-1843) ((lambda (syntmp-tmp-1858) ((lambda (syntmp-rest-1859) ((lambda (syntmp-tmp-1860) ((lambda (syntmp-tmp-1861) (if syntmp-tmp-1861 (apply (lambda (syntmp-k-1862 syntmp-e1-1863 syntmp-e2-1864) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1862)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1863 syntmp-e2-1864)) syntmp-rest-1859)) syntmp-tmp-1861) ((lambda (syntmp-_-1867) (syntax-error syntmp-x-1833)) syntmp-tmp-1860))) (syntax-dispatch syntmp-tmp-1860 (quote (each-any any . each-any))))) syntmp-clause-1843)) syntmp-tmp-1858)) (syntmp-f-1842 (car syntmp-clauses-1844) (cdr syntmp-clauses-1844))))))) syntmp-tmp-1835) (syntax-error syntmp-tmp-1834))) (syntax-dispatch syntmp-tmp-1834 (quote (any any any . each-any))))) syntmp-x-1833))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1897) ((lambda (syntmp-tmp-1898) ((lambda (syntmp-tmp-1899) (if syntmp-tmp-1899 (apply (lambda (syntmp-_-1900 syntmp-e-1901) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1901)) (list (cons syntmp-_-1900 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e-1901 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))))))))) syntmp-tmp-1899) (syntax-error syntmp-tmp-1898))) (syntax-dispatch syntmp-tmp-1898 (quote (any any))))) syntmp-x-1897))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (procedure-module syntmp-p-688)))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (and syntmp-mod-722 (module-name syntmp-mod-722)) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref (and syntmp-mod-722 (module-name syntmp-mod-722)) syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-724) ((lambda (syntmp-tmp-725) (if syntmp-tmp-725 (apply (lambda (syntmp-_-726 syntmp-e1-727 syntmp-e2-728) (syntmp-chi-sequence-147 (cons syntmp-e1-727 syntmp-e2-728) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-725) (syntax-error syntmp-tmp-724))) (syntax-dispatch syntmp-tmp-724 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-730) ((lambda (syntmp-tmp-731) (if syntmp-tmp-731 (apply (lambda (syntmp-_-732 syntmp-x-733 syntmp-e1-734 syntmp-e2-735) (let ((syntmp-when-list-736 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-733 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-736) (syntmp-chi-sequence-147 (cons syntmp-e1-734 syntmp-e2-735) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-731) (syntax-error syntmp-tmp-730))) (syntax-dispatch syntmp-tmp-730 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722)))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-739 syntmp-r-740 syntmp-w-741 syntmp-mod-742) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-739 syntmp-r-740 syntmp-w-741 #f #f syntmp-mod-742)) (lambda (syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-w-746 syntmp-s-747 syntmp-mod-748) (syntmp-chi-expr-154 syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-r-740 syntmp-w-746 syntmp-s-747 syntmp-mod-748))))) (syntmp-chi-top-152 (lambda (syntmp-e-749 syntmp-r-750 syntmp-w-751 syntmp-m-752 syntmp-esew-753 syntmp-mod-754) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-749 syntmp-r-750 syntmp-w-751 #f #f syntmp-mod-754)) (lambda (syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-w-772 syntmp-s-773 syntmp-mod-774) (let ((syntmp-t-775 syntmp-type-769)) (if (memv syntmp-t-775 (quote (begin-form))) ((lambda (syntmp-tmp-776) ((lambda (syntmp-tmp-777) (if syntmp-tmp-777 (apply (lambda (syntmp-_-778) (syntmp-chi-void-161)) syntmp-tmp-777) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-e1-781 syntmp-e2-782) (syntmp-chi-top-sequence-148 (cons syntmp-e1-781 syntmp-e2-782) syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-m-752 syntmp-esew-753 syntmp-mod-774)) syntmp-tmp-779) (syntax-error syntmp-tmp-776))) (syntax-dispatch syntmp-tmp-776 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-776 (quote (any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774 (lambda (syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-mod-788) (syntmp-chi-top-sequence-148 syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-m-752 syntmp-esew-753 syntmp-mod-788))) (if (memv syntmp-t-775 (quote (eval-when-form))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-x-792 syntmp-e1-793 syntmp-e2-794) (let ((syntmp-when-list-795 (syntmp-chi-when-list-150 syntmp-e-771 syntmp-x-792 syntmp-w-772)) (syntmp-body-796 (cons syntmp-e1-793 syntmp-e2-794))) (cond ((eq? syntmp-m-752 (quote e)) (if (memq (quote eval) syntmp-when-list-795) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-795) (if (or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c&e) (quote (compile load)) syntmp-mod-774) (if (memq syntmp-m-752 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c) (quote (load)) syntmp-mod-774) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) syntmp-mod-774) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-790) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any each-any any . each-any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (define-syntax-form))) (let ((syntmp-n-799 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772)) (syntmp-r-800 (syntmp-macros-only-env-113 syntmp-r-750))) (let ((syntmp-t-801 syntmp-m-752)) (if (memv syntmp-t-801 (quote (c))) (if (memq (quote compile) syntmp-esew-753) (let ((syntmp-e-802 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-802 syntmp-mod-774) (if (memq (quote load) syntmp-esew-753) syntmp-e-802 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-753) (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) (syntmp-chi-void-161))) (if (memv syntmp-t-801 (quote (c&e))) (let ((syntmp-e-803 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-803 syntmp-mod-774) syntmp-e-803)) (begin (if (memq (quote eval) syntmp-esew-753) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) syntmp-mod-774)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-775 (quote (define-form))) (let ((syntmp-n-804 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772))) (let ((syntmp-type-805 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-804 syntmp-r-750 syntmp-mod-774)))) (let ((syntmp-t-806 syntmp-type-805)) (if (memv syntmp-t-806 (quote (global))) (let ((syntmp-x-807 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-807 syntmp-mod-774)) syntmp-x-807)) (if (memv syntmp-t-806 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "identifier out of context") (if (eq? syntmp-type-805 (quote external-macro)) (let ((syntmp-x-808 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-808 syntmp-mod-774)) syntmp-x-808)) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "cannot define keyword at top level"))))))) (let ((syntmp-x-809 (syntmp-chi-expr-154 syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-774)) syntmp-x-809)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (cond ((symbol? syntmp-e-810) (let ((syntmp-n-816 (syntmp-id-var-name-139 syntmp-e-810 syntmp-w-812))) (let ((syntmp-b-817 (syntmp-lookup-114 syntmp-n-816 syntmp-r-811 syntmp-mod-815))) (let ((syntmp-type-818 (syntmp-binding-type-109 syntmp-b-817))) (let ((syntmp-t-819 syntmp-type-818)) (if (memv syntmp-t-819 (quote (lexical))) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (global))) (values syntmp-type-818 syntmp-n-816 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))))))) ((pair? syntmp-e-810) (let ((syntmp-first-820 (car syntmp-e-810))) (if (syntmp-id?-117 syntmp-first-820) (let ((syntmp-n-821 (syntmp-id-var-name-139 syntmp-first-820 syntmp-w-812))) (let ((syntmp-b-822 (syntmp-lookup-114 syntmp-n-821 syntmp-r-811 syntmp-mod-815))) (let ((syntmp-type-823 (syntmp-binding-type-109 syntmp-b-822))) (let ((syntmp-t-824 syntmp-type-823)) (if (memv syntmp-t-824 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (global))) (values (quote global-call) syntmp-n-821 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (if (memv syntmp-t-824 (quote (core external-macro))) (values syntmp-type-823 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (begin))) (values (quote begin-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (define))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-117 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-form) syntmp-name-831 syntmp-val-832 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-826) ((lambda (syntmp-tmp-833) (if (if syntmp-tmp-833 (apply (lambda (syntmp-_-834 syntmp-name-835 syntmp-args-836 syntmp-e1-837 syntmp-e2-838) (and (syntmp-id?-117 syntmp-name-835) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-836)))) syntmp-tmp-833) #f) (apply (lambda (syntmp-_-839 syntmp-name-840 syntmp-args-841 syntmp-e1-842 syntmp-e2-843) (values (quote define-form) (syntmp-wrap-145 syntmp-name-840 syntmp-w-812 syntmp-mod-815) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) (syntmp-wrap-145 (cons syntmp-args-841 (cons syntmp-e1-842 syntmp-e2-843)) syntmp-w-812 syntmp-mod-815)) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-833) ((lambda (syntmp-tmp-845) (if (if syntmp-tmp-845 (apply (lambda (syntmp-_-846 syntmp-name-847) (syntmp-id?-117 syntmp-name-847)) syntmp-tmp-845) #f) (apply (lambda (syntmp-_-848 syntmp-name-849) (values (quote define-form) (syntmp-wrap-145 syntmp-name-849 syntmp-w-812 syntmp-mod-815) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-845) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-810) (if (memv syntmp-t-824 (quote (define-syntax))) ((lambda (syntmp-tmp-850) ((lambda (syntmp-tmp-851) (if (if syntmp-tmp-851 (apply (lambda (syntmp-_-852 syntmp-name-853 syntmp-val-854) (syntmp-id?-117 syntmp-name-853)) syntmp-tmp-851) #f) (apply (lambda (syntmp-_-855 syntmp-name-856 syntmp-val-857) (values (quote define-syntax-form) syntmp-name-856 syntmp-val-857 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-851) (syntax-error syntmp-tmp-850))) (syntax-dispatch syntmp-tmp-850 (quote (any any any))))) syntmp-e-810) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))))))))))))) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))) ((syntmp-syntax-object?-101 syntmp-e-810) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-810) syntmp-r-811 (syntmp-join-wraps-136 syntmp-w-812 (syntmp-syntax-object-wrap-103 syntmp-e-810)) #f syntmp-rib-814 (or (syntmp-syntax-object-module-104 syntmp-e-810) syntmp-mod-815))) ((annotation? syntmp-e-810) (syntmp-syntax-type-151 (annotation-expression syntmp-e-810) syntmp-r-811 syntmp-w-812 (annotation-source syntmp-e-810) syntmp-rib-814 syntmp-mod-815)) ((self-evaluating? syntmp-e-810) (values (quote constant) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) (else (values (quote other) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-858 syntmp-when-list-859 syntmp-w-860) (let syntmp-f-861 ((syntmp-when-list-862 syntmp-when-list-859) (syntmp-situations-863 (quote ()))) (if (null? syntmp-when-list-862) syntmp-situations-863 (syntmp-f-861 (cdr syntmp-when-list-862) (cons (let ((syntmp-x-864 (car syntmp-when-list-862))) (cond ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-864 syntmp-w-860 #f) "invalid eval-when situation")))) syntmp-situations-863)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-865 syntmp-e-866) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-865) syntmp-e-866)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-867 syntmp-r-868 syntmp-w-869 syntmp-s-870 syntmp-m-871 syntmp-esew-872 syntmp-mod-873) (syntmp-build-sequence-96 syntmp-s-870 (let syntmp-dobody-874 ((syntmp-body-875 syntmp-body-867) (syntmp-r-876 syntmp-r-868) (syntmp-w-877 syntmp-w-869) (syntmp-m-878 syntmp-m-871) (syntmp-esew-879 syntmp-esew-872) (syntmp-mod-880 syntmp-mod-873)) (if (null? syntmp-body-875) (quote ()) (let ((syntmp-first-881 (syntmp-chi-top-152 (car syntmp-body-875) syntmp-r-876 syntmp-w-877 syntmp-m-878 syntmp-esew-879 syntmp-mod-880))) (cons syntmp-first-881 (syntmp-dobody-874 (cdr syntmp-body-875) syntmp-r-876 syntmp-w-877 syntmp-m-878 syntmp-esew-879 syntmp-mod-880)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-882 syntmp-r-883 syntmp-w-884 syntmp-s-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-885 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-882) (syntmp-r-889 syntmp-r-883) (syntmp-w-890 syntmp-w-884) (syntmp-mod-891 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-892 (syntmp-chi-153 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-mod-891))) (cons syntmp-first-892 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-mod-891)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-893 syntmp-w-894 syntmp-s-895 syntmp-defmod-896) (syntmp-wrap-145 (if syntmp-s-895 (make-annotation syntmp-x-893 syntmp-s-895 #f) syntmp-x-893) syntmp-w-894 syntmp-defmod-896))) (syntmp-wrap-145 (lambda (syntmp-x-897 syntmp-w-898 syntmp-defmod-899) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-898)) (null? (syntmp-wrap-subst-121 syntmp-w-898))) syntmp-x-897) ((syntmp-syntax-object?-101 syntmp-x-897) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-897) (syntmp-join-wraps-136 syntmp-w-898 (syntmp-syntax-object-wrap-103 syntmp-x-897)) (syntmp-syntax-object-module-104 syntmp-x-897))) ((null? syntmp-x-897) syntmp-x-897) (else (syntmp-make-syntax-object-100 syntmp-x-897 syntmp-w-898 syntmp-defmod-899))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-900 syntmp-list-901) (and (not (null? syntmp-list-901)) (or (syntmp-bound-id=?-141 syntmp-x-900 (car syntmp-list-901)) (syntmp-bound-id-member?-144 syntmp-x-900 (cdr syntmp-list-901)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-902) (let syntmp-distinct?-903 ((syntmp-ids-904 syntmp-ids-902)) (or (null? syntmp-ids-904) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-904) (cdr syntmp-ids-904))) (syntmp-distinct?-903 (cdr syntmp-ids-904))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-905) (and (let syntmp-all-ids?-906 ((syntmp-ids-907 syntmp-ids-905)) (or (null? syntmp-ids-907) (and (syntmp-id?-117 (car syntmp-ids-907)) (syntmp-all-ids?-906 (cdr syntmp-ids-907))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-905)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-908 syntmp-j-909) (if (and (syntmp-syntax-object?-101 syntmp-i-908) (syntmp-syntax-object?-101 syntmp-j-909)) (and (eq? (let ((syntmp-e-910 (syntmp-syntax-object-expression-102 syntmp-i-908))) (if (annotation? syntmp-e-910) (annotation-expression syntmp-e-910) syntmp-e-910)) (let ((syntmp-e-911 (syntmp-syntax-object-expression-102 syntmp-j-909))) (if (annotation? syntmp-e-911) (annotation-expression syntmp-e-911) syntmp-e-911))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-908)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-909)))) (eq? (let ((syntmp-e-912 syntmp-i-908)) (if (annotation? syntmp-e-912) (annotation-expression syntmp-e-912) syntmp-e-912)) (let ((syntmp-e-913 syntmp-j-909)) (if (annotation? syntmp-e-913) (annotation-expression syntmp-e-913) syntmp-e-913)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-914 syntmp-j-915) (and (eq? (let ((syntmp-x-916 syntmp-i-914)) (let ((syntmp-e-917 (if (syntmp-syntax-object?-101 syntmp-x-916) (syntmp-syntax-object-expression-102 syntmp-x-916) syntmp-x-916))) (if (annotation? syntmp-e-917) (annotation-expression syntmp-e-917) syntmp-e-917))) (let ((syntmp-x-918 syntmp-j-915)) (let ((syntmp-e-919 (if (syntmp-syntax-object?-101 syntmp-x-918) (syntmp-syntax-object-expression-102 syntmp-x-918) syntmp-x-918))) (if (annotation? syntmp-e-919) (annotation-expression syntmp-e-919) syntmp-e-919)))) (eq? (syntmp-id-var-name-139 syntmp-i-914 (quote (()))) (syntmp-id-var-name-139 syntmp-j-915 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-920 syntmp-w-921) (letrec ((syntmp-search-vector-rib-924 (lambda (syntmp-sym-935 syntmp-subst-936 syntmp-marks-937 syntmp-symnames-938 syntmp-ribcage-939) (let ((syntmp-n-940 (vector-length syntmp-symnames-938))) (let syntmp-f-941 ((syntmp-i-942 0)) (cond ((syntmp-fx=-87 syntmp-i-942 syntmp-n-940) (syntmp-search-922 syntmp-sym-935 (cdr syntmp-subst-936) syntmp-marks-937)) ((and (eq? (vector-ref syntmp-symnames-938 syntmp-i-942) syntmp-sym-935) (syntmp-same-marks?-138 syntmp-marks-937 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-939) syntmp-i-942))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-939) syntmp-i-942) syntmp-marks-937)) (else (syntmp-f-941 (syntmp-fx+-85 syntmp-i-942 1)))))))) (syntmp-search-list-rib-923 (lambda (syntmp-sym-943 syntmp-subst-944 syntmp-marks-945 syntmp-symnames-946 syntmp-ribcage-947) (let syntmp-f-948 ((syntmp-symnames-949 syntmp-symnames-946) (syntmp-i-950 0)) (cond ((null? syntmp-symnames-949) (syntmp-search-922 syntmp-sym-943 (cdr syntmp-subst-944) syntmp-marks-945)) ((and (eq? (car syntmp-symnames-949) syntmp-sym-943) (syntmp-same-marks?-138 syntmp-marks-945 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-947) syntmp-i-950))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-947) syntmp-i-950) syntmp-marks-945)) (else (syntmp-f-948 (cdr syntmp-symnames-949) (syntmp-fx+-85 syntmp-i-950 1))))))) (syntmp-search-922 (lambda (syntmp-sym-951 syntmp-subst-952 syntmp-marks-953) (if (null? syntmp-subst-952) (values #f syntmp-marks-953) (let ((syntmp-fst-954 (car syntmp-subst-952))) (if (eq? syntmp-fst-954 (quote shift)) (syntmp-search-922 syntmp-sym-951 (cdr syntmp-subst-952) (cdr syntmp-marks-953)) (let ((syntmp-symnames-955 (syntmp-ribcage-symnames-126 syntmp-fst-954))) (if (vector? syntmp-symnames-955) (syntmp-search-vector-rib-924 syntmp-sym-951 syntmp-subst-952 syntmp-marks-953 syntmp-symnames-955 syntmp-fst-954) (syntmp-search-list-rib-923 syntmp-sym-951 syntmp-subst-952 syntmp-marks-953 syntmp-symnames-955 syntmp-fst-954))))))))) (cond ((symbol? syntmp-id-920) (or (call-with-values (lambda () (syntmp-search-922 syntmp-id-920 (syntmp-wrap-subst-121 syntmp-w-921) (syntmp-wrap-marks-120 syntmp-w-921))) (lambda (syntmp-x-957 . syntmp-ignore-956) syntmp-x-957)) syntmp-id-920)) ((syntmp-syntax-object?-101 syntmp-id-920) (let ((syntmp-id-958 (let ((syntmp-e-960 (syntmp-syntax-object-expression-102 syntmp-id-920))) (if (annotation? syntmp-e-960) (annotation-expression syntmp-e-960) syntmp-e-960))) (syntmp-w1-959 (syntmp-syntax-object-wrap-103 syntmp-id-920))) (let ((syntmp-marks-961 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-921) (syntmp-wrap-marks-120 syntmp-w1-959)))) (call-with-values (lambda () (syntmp-search-922 syntmp-id-958 (syntmp-wrap-subst-121 syntmp-w-921) syntmp-marks-961)) (lambda (syntmp-new-id-962 syntmp-marks-963) (or syntmp-new-id-962 (call-with-values (lambda () (syntmp-search-922 syntmp-id-958 (syntmp-wrap-subst-121 syntmp-w1-959) syntmp-marks-963)) (lambda (syntmp-x-965 . syntmp-ignore-964) syntmp-x-965)) syntmp-id-958)))))) ((annotation? syntmp-id-920) (let ((syntmp-id-966 (let ((syntmp-e-967 syntmp-id-920)) (if (annotation? syntmp-e-967) (annotation-expression syntmp-e-967) syntmp-e-967)))) (or (call-with-values (lambda () (syntmp-search-922 syntmp-id-966 (syntmp-wrap-subst-121 syntmp-w-921) (syntmp-wrap-marks-120 syntmp-w-921))) (lambda (syntmp-x-969 . syntmp-ignore-968) syntmp-x-969)) syntmp-id-966))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-920)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-970 syntmp-y-971) (or (eq? syntmp-x-970 syntmp-y-971) (and (not (null? syntmp-x-970)) (not (null? syntmp-y-971)) (eq? (car syntmp-x-970) (car syntmp-y-971)) (syntmp-same-marks?-138 (cdr syntmp-x-970) (cdr syntmp-y-971)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-972 syntmp-m2-973) (syntmp-smart-append-135 syntmp-m1-972 syntmp-m2-973))) (syntmp-join-wraps-136 (lambda (syntmp-w1-974 syntmp-w2-975) (let ((syntmp-m1-976 (syntmp-wrap-marks-120 syntmp-w1-974)) (syntmp-s1-977 (syntmp-wrap-subst-121 syntmp-w1-974))) (if (null? syntmp-m1-976) (if (null? syntmp-s1-977) syntmp-w2-975 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-975) (syntmp-smart-append-135 syntmp-s1-977 (syntmp-wrap-subst-121 syntmp-w2-975)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-976 (syntmp-wrap-marks-120 syntmp-w2-975)) (syntmp-smart-append-135 syntmp-s1-977 (syntmp-wrap-subst-121 syntmp-w2-975))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-978 syntmp-m2-979) (if (null? syntmp-m2-979) syntmp-m1-978 (append syntmp-m1-978 syntmp-m2-979)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-980 syntmp-labels-981 syntmp-w-982) (if (null? syntmp-ids-980) syntmp-w-982 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-982) (cons (let ((syntmp-labelvec-983 (list->vector syntmp-labels-981))) (let ((syntmp-n-984 (vector-length syntmp-labelvec-983))) (let ((syntmp-symnamevec-985 (make-vector syntmp-n-984)) (syntmp-marksvec-986 (make-vector syntmp-n-984))) (begin (let syntmp-f-987 ((syntmp-ids-988 syntmp-ids-980) (syntmp-i-989 0)) (if (not (null? syntmp-ids-988)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-988) syntmp-w-982)) (lambda (syntmp-symname-990 syntmp-marks-991) (begin (vector-set! syntmp-symnamevec-985 syntmp-i-989 syntmp-symname-990) (vector-set! syntmp-marksvec-986 syntmp-i-989 syntmp-marks-991) (syntmp-f-987 (cdr syntmp-ids-988) (syntmp-fx+-85 syntmp-i-989 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-985 syntmp-marksvec-986 syntmp-labelvec-983))))) (syntmp-wrap-subst-121 syntmp-w-982)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-992 syntmp-id-993 syntmp-label-994) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-992 (cons (let ((syntmp-e-995 (syntmp-syntax-object-expression-102 syntmp-id-993))) (if (annotation? syntmp-e-995) (annotation-expression syntmp-e-995) syntmp-e-995)) (syntmp-ribcage-symnames-126 syntmp-ribcage-992))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-992 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-993)) (syntmp-ribcage-marks-127 syntmp-ribcage-992))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-992 (cons syntmp-label-994 (syntmp-ribcage-labels-128 syntmp-ribcage-992)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-996) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-996)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-996))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-997 syntmp-update-998) (vector-set! syntmp-x-997 3 syntmp-update-998))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-999 syntmp-update-1000) (vector-set! syntmp-x-999 2 syntmp-update-1000))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1001 syntmp-update-1002) (vector-set! syntmp-x-1001 1 syntmp-update-1002))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1003) (vector-ref syntmp-x-1003 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1004) (vector-ref syntmp-x-1004 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1005) (vector-ref syntmp-x-1005 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1006) (and (vector? syntmp-x-1006) (= (vector-length syntmp-x-1006) 4) (eq? (vector-ref syntmp-x-1006 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1007 syntmp-marks-1008 syntmp-labels-1009) (vector (quote ribcage) syntmp-symnames-1007 syntmp-marks-1008 syntmp-labels-1009))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1010) (if (null? syntmp-ls-1010) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1010)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1011 syntmp-w-1012) (if (syntmp-syntax-object?-101 syntmp-x-1011) (values (let ((syntmp-e-1013 (syntmp-syntax-object-expression-102 syntmp-x-1011))) (if (annotation? syntmp-e-1013) (annotation-expression syntmp-e-1013) syntmp-e-1013)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1012) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1011)))) (values (let ((syntmp-e-1014 syntmp-x-1011)) (if (annotation? syntmp-e-1014) (annotation-expression syntmp-e-1014) syntmp-e-1014)) (syntmp-wrap-marks-120 syntmp-w-1012))))) (syntmp-id?-117 (lambda (syntmp-x-1015) (cond ((symbol? syntmp-x-1015) #t) ((syntmp-syntax-object?-101 syntmp-x-1015) (symbol? (let ((syntmp-e-1016 (syntmp-syntax-object-expression-102 syntmp-x-1015))) (if (annotation? syntmp-e-1016) (annotation-expression syntmp-e-1016) syntmp-e-1016)))) ((annotation? syntmp-x-1015) (symbol? (annotation-expression syntmp-x-1015))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1017) (and (syntmp-syntax-object?-101 syntmp-x-1017) (symbol? (let ((syntmp-e-1018 (syntmp-syntax-object-expression-102 syntmp-x-1017))) (if (annotation? syntmp-e-1018) (annotation-expression syntmp-e-1018) syntmp-e-1018)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1019 syntmp-sym-1020 syntmp-val-1021) (syntmp-put-global-definition-hook-92 syntmp-sym-1020 (cons syntmp-type-1019 syntmp-val-1021) (current-module)))) (syntmp-lookup-114 (lambda (syntmp-x-1022 syntmp-r-1023 syntmp-mod-1024) (cond ((assq syntmp-x-1022 syntmp-r-1023) => cdr) ((symbol? syntmp-x-1022) (or (syntmp-get-global-definition-hook-93 syntmp-x-1022 syntmp-mod-1024) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1025) (if (null? syntmp-r-1025) (quote ()) (let ((syntmp-a-1026 (car syntmp-r-1025))) (if (eq? (cadr syntmp-a-1026) (quote macro)) (cons syntmp-a-1026 (syntmp-macros-only-env-113 (cdr syntmp-r-1025))) (syntmp-macros-only-env-113 (cdr syntmp-r-1025))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1027 syntmp-vars-1028 syntmp-r-1029) (if (null? syntmp-labels-1027) syntmp-r-1029 (syntmp-extend-var-env-112 (cdr syntmp-labels-1027) (cdr syntmp-vars-1028) (cons (cons (car syntmp-labels-1027) (cons (quote lexical) (car syntmp-vars-1028))) syntmp-r-1029))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1030 syntmp-bindings-1031 syntmp-r-1032) (if (null? syntmp-labels-1030) syntmp-r-1032 (syntmp-extend-env-111 (cdr syntmp-labels-1030) (cdr syntmp-bindings-1031) (cons (cons (car syntmp-labels-1030) (car syntmp-bindings-1031)) syntmp-r-1032))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1033) (cond ((annotation? syntmp-x-1033) (annotation-source syntmp-x-1033)) ((syntmp-syntax-object?-101 syntmp-x-1033) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1033))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1034 syntmp-update-1035) (vector-set! syntmp-x-1034 3 syntmp-update-1035))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1036 syntmp-update-1037) (vector-set! syntmp-x-1036 2 syntmp-update-1037))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1038 syntmp-update-1039) (vector-set! syntmp-x-1038 1 syntmp-update-1039))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1040) (vector-ref syntmp-x-1040 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1041) (vector-ref syntmp-x-1041 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1042) (vector-ref syntmp-x-1042 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1043) (and (vector? syntmp-x-1043) (= (vector-length syntmp-x-1043) 4) (eq? (vector-ref syntmp-x-1043 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1044 syntmp-wrap-1045 syntmp-module-1046) (vector (quote syntax-object) syntmp-expression-1044 syntmp-wrap-1045 syntmp-module-1046))) (syntmp-build-letrec-99 (lambda (syntmp-src-1047 syntmp-vars-1048 syntmp-val-exps-1049 syntmp-body-exp-1050) (if (null? syntmp-vars-1048) (syntmp-build-annotated-94 syntmp-src-1047 syntmp-body-exp-1050) (syntmp-build-annotated-94 syntmp-src-1047 (list (quote letrec) (map list syntmp-vars-1048 syntmp-val-exps-1049) syntmp-body-exp-1050))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1051 syntmp-vars-1052 syntmp-val-exps-1053 syntmp-body-exp-1054) (if (null? syntmp-vars-1052) (syntmp-build-annotated-94 syntmp-src-1051 syntmp-body-exp-1054) (syntmp-build-annotated-94 syntmp-src-1051 (list (quote let) (car syntmp-vars-1052) (map list (cdr syntmp-vars-1052) syntmp-val-exps-1053) syntmp-body-exp-1054))))) (syntmp-build-let-97 (lambda (syntmp-src-1055 syntmp-vars-1056 syntmp-val-exps-1057 syntmp-body-exp-1058) (if (null? syntmp-vars-1056) (syntmp-build-annotated-94 syntmp-src-1055 syntmp-body-exp-1058) (syntmp-build-annotated-94 syntmp-src-1055 (list (quote let) (map list syntmp-vars-1056 syntmp-val-exps-1057) syntmp-body-exp-1058))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1059 syntmp-exps-1060) (if (null? (cdr syntmp-exps-1060)) (syntmp-build-annotated-94 syntmp-src-1059 (car syntmp-exps-1060)) (syntmp-build-annotated-94 syntmp-src-1059 (cons (quote begin) syntmp-exps-1060))))) (syntmp-build-data-95 (lambda (syntmp-src-1061 syntmp-exp-1062) (if (and (self-evaluating? syntmp-exp-1062) (not (vector? syntmp-exp-1062))) (syntmp-build-annotated-94 syntmp-src-1061 syntmp-exp-1062) (syntmp-build-annotated-94 syntmp-src-1061 (list (quote quote) syntmp-exp-1062))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1063 syntmp-exp-1064) (if (and syntmp-src-1063 (not (annotation? syntmp-exp-1064))) (make-annotation syntmp-exp-1064 syntmp-src-1063 #t) syntmp-exp-1064))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1065 syntmp-module-1066) (let ((syntmp-module-1067 (or syntmp-module-1066 (warn "wha" syntmp-symbol-1065 (current-module))))) (let ((syntmp-v-1068 (module-variable syntmp-module-1067 syntmp-symbol-1065))) (and syntmp-v-1068 (or (object-property syntmp-v-1068 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1068) (macro? (variable-ref syntmp-v-1068)) (macro-transformer (variable-ref syntmp-v-1068)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1069 syntmp-binding-1070 syntmp-module-1071) (let ((syntmp-module-1072 (or syntmp-module-1071 (warn "wha" syntmp-symbol-1069 (current-module))))) (let ((syntmp-v-1073 (or (module-variable syntmp-module-1072 syntmp-symbol-1069) (let ((syntmp-v-1074 (make-variable sc-macro))) (begin (module-add! syntmp-module-1072 syntmp-symbol-1069 syntmp-v-1074) syntmp-v-1074))))) (begin (if (not (and (symbol-property syntmp-symbol-1069 (quote primitive-syntax)) (eq? syntmp-module-1072 the-syncase-module))) (variable-set! syntmp-v-1073 sc-macro)) (set-object-property! syntmp-v-1073 (quote *sc-expander*) syntmp-binding-1070)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1075 syntmp-why-1076 syntmp-what-1077) (error syntmp-who-1075 "~a ~s" syntmp-why-1076 syntmp-what-1077))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1078 syntmp-mod-1079) (eval (list syntmp-noexpand-84 syntmp-x-1078) (or syntmp-mod-1079 (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1080 syntmp-mod-1081) (eval (list syntmp-noexpand-84 syntmp-x-1080) (or syntmp-mod-1081 (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1082 syntmp-r-1083 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086) ((lambda (syntmp-tmp-1087) ((lambda (syntmp-tmp-1088) (if (if syntmp-tmp-1088 (apply (lambda (syntmp-_-1089 syntmp-var-1090 syntmp-val-1091 syntmp-e1-1092 syntmp-e2-1093) (syntmp-valid-bound-ids?-142 syntmp-var-1090)) syntmp-tmp-1088) #f) (apply (lambda (syntmp-_-1095 syntmp-var-1096 syntmp-val-1097 syntmp-e1-1098 syntmp-e2-1099) (let ((syntmp-names-1100 (map (lambda (syntmp-x-1101) (syntmp-id-var-name-139 syntmp-x-1101 syntmp-w-1084)) syntmp-var-1096))) (begin (for-each (lambda (syntmp-id-1103 syntmp-n-1104) (let ((syntmp-t-1105 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1104 syntmp-r-1083 syntmp-mod-1086)))) (if (memv syntmp-t-1105 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1103 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086) "identifier out of context")))) syntmp-var-1096 syntmp-names-1100) (syntmp-chi-body-157 (cons syntmp-e1-1098 syntmp-e2-1099) (syntmp-source-wrap-146 syntmp-e-1082 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086) (syntmp-extend-env-111 syntmp-names-1100 (let ((syntmp-trans-r-1108 (syntmp-macros-only-env-113 syntmp-r-1083))) (map (lambda (syntmp-x-1109) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1109 syntmp-trans-r-1108 syntmp-w-1084 syntmp-mod-1086) syntmp-mod-1086))) syntmp-val-1097)) syntmp-r-1083) syntmp-w-1084 syntmp-mod-1086)))) syntmp-tmp-1088) ((lambda (syntmp-_-1111) (syntax-error (syntmp-source-wrap-146 syntmp-e-1082 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086))) syntmp-tmp-1087))) (syntax-dispatch syntmp-tmp-1087 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1082))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1112 syntmp-r-1113 syntmp-w-1114 syntmp-s-1115 syntmp-mod-1116) ((lambda (syntmp-tmp-1117) ((lambda (syntmp-tmp-1118) (if syntmp-tmp-1118 (apply (lambda (syntmp-_-1119 syntmp-e-1120) (syntmp-build-data-95 syntmp-s-1115 (syntmp-strip-164 syntmp-e-1120 syntmp-w-1114))) syntmp-tmp-1118) ((lambda (syntmp-_-1121) (syntax-error (syntmp-source-wrap-146 syntmp-e-1112 syntmp-w-1114 syntmp-s-1115 syntmp-mod-1116))) syntmp-tmp-1117))) (syntax-dispatch syntmp-tmp-1117 (quote (any any))))) syntmp-e-1112))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1129 (lambda (syntmp-x-1130) (let ((syntmp-t-1131 (car syntmp-x-1130))) (if (memv syntmp-t-1131 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1130)) (if (memv syntmp-t-1131 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1130)) (if (memv syntmp-t-1131 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1130)) (if (memv syntmp-t-1131 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1130) (syntmp-regen-1129 (caddr syntmp-x-1130)))) (if (memv syntmp-t-1131 (quote (map))) (let ((syntmp-ls-1132 (map syntmp-regen-1129 (cdr syntmp-x-1130)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1132) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1132))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1130)) (map syntmp-regen-1129 (cdr syntmp-x-1130)))))))))))) (syntmp-gen-vector-1128 (lambda (syntmp-x-1133) (cond ((eq? (car syntmp-x-1133) (quote list)) (cons (quote vector) (cdr syntmp-x-1133))) ((eq? (car syntmp-x-1133) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1133)))) (else (list (quote list->vector) syntmp-x-1133))))) (syntmp-gen-append-1127 (lambda (syntmp-x-1134 syntmp-y-1135) (if (equal? syntmp-y-1135 (quote (quote ()))) syntmp-x-1134 (list (quote append) syntmp-x-1134 syntmp-y-1135)))) (syntmp-gen-cons-1126 (lambda (syntmp-x-1136 syntmp-y-1137) (let ((syntmp-t-1138 (car syntmp-y-1137))) (if (memv syntmp-t-1138 (quote (quote))) (if (eq? (car syntmp-x-1136) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1136) (cadr syntmp-y-1137))) (if (eq? (cadr syntmp-y-1137) (quote ())) (list (quote list) syntmp-x-1136) (list (quote cons) syntmp-x-1136 syntmp-y-1137))) (if (memv syntmp-t-1138 (quote (list))) (cons (quote list) (cons syntmp-x-1136 (cdr syntmp-y-1137))) (list (quote cons) syntmp-x-1136 syntmp-y-1137)))))) (syntmp-gen-map-1125 (lambda (syntmp-e-1139 syntmp-map-env-1140) (let ((syntmp-formals-1141 (map cdr syntmp-map-env-1140)) (syntmp-actuals-1142 (map (lambda (syntmp-x-1143) (list (quote ref) (car syntmp-x-1143))) syntmp-map-env-1140))) (cond ((eq? (car syntmp-e-1139) (quote ref)) (car syntmp-actuals-1142)) ((andmap (lambda (syntmp-x-1144) (and (eq? (car syntmp-x-1144) (quote ref)) (memq (cadr syntmp-x-1144) syntmp-formals-1141))) (cdr syntmp-e-1139)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1139)) (map (let ((syntmp-r-1145 (map cons syntmp-formals-1141 syntmp-actuals-1142))) (lambda (syntmp-x-1146) (cdr (assq (cadr syntmp-x-1146) syntmp-r-1145)))) (cdr syntmp-e-1139))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1141 syntmp-e-1139) syntmp-actuals-1142))))))) (syntmp-gen-mappend-1124 (lambda (syntmp-e-1147 syntmp-map-env-1148) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1125 syntmp-e-1147 syntmp-map-env-1148)))) (syntmp-gen-ref-1123 (lambda (syntmp-src-1149 syntmp-var-1150 syntmp-level-1151 syntmp-maps-1152) (if (syntmp-fx=-87 syntmp-level-1151 0) (values syntmp-var-1150 syntmp-maps-1152) (if (null? syntmp-maps-1152) (syntax-error syntmp-src-1149 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1123 syntmp-src-1149 syntmp-var-1150 (syntmp-fx--86 syntmp-level-1151 1) (cdr syntmp-maps-1152))) (lambda (syntmp-outer-var-1153 syntmp-outer-maps-1154) (let ((syntmp-b-1155 (assq syntmp-outer-var-1153 (car syntmp-maps-1152)))) (if syntmp-b-1155 (values (cdr syntmp-b-1155) syntmp-maps-1152) (let ((syntmp-inner-var-1156 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1156 (cons (cons (cons syntmp-outer-var-1153 syntmp-inner-var-1156) (car syntmp-maps-1152)) syntmp-outer-maps-1154))))))))))) (syntmp-gen-syntax-1122 (lambda (syntmp-src-1157 syntmp-e-1158 syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162) (if (syntmp-id?-117 syntmp-e-1158) (let ((syntmp-label-1163 (syntmp-id-var-name-139 syntmp-e-1158 (quote (()))))) (let ((syntmp-b-1164 (syntmp-lookup-114 syntmp-label-1163 syntmp-r-1159 syntmp-mod-1162))) (if (eq? (syntmp-binding-type-109 syntmp-b-1164) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1165 (syntmp-binding-value-110 syntmp-b-1164))) (syntmp-gen-ref-1123 syntmp-src-1157 (car syntmp-var.lev-1165) (cdr syntmp-var.lev-1165) syntmp-maps-1160))) (lambda (syntmp-var-1166 syntmp-maps-1167) (values (list (quote ref) syntmp-var-1166) syntmp-maps-1167))) (if (syntmp-ellipsis?-1161 syntmp-e-1158) (syntax-error syntmp-src-1157 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1158) syntmp-maps-1160))))) ((lambda (syntmp-tmp-1168) ((lambda (syntmp-tmp-1169) (if (if syntmp-tmp-1169 (apply (lambda (syntmp-dots-1170 syntmp-e-1171) (syntmp-ellipsis?-1161 syntmp-dots-1170)) syntmp-tmp-1169) #f) (apply (lambda (syntmp-dots-1172 syntmp-e-1173) (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-e-1173 syntmp-r-1159 syntmp-maps-1160 (lambda (syntmp-x-1174) #f) syntmp-mod-1162)) syntmp-tmp-1169) ((lambda (syntmp-tmp-1175) (if (if syntmp-tmp-1175 (apply (lambda (syntmp-x-1176 syntmp-dots-1177 syntmp-y-1178) (syntmp-ellipsis?-1161 syntmp-dots-1177)) syntmp-tmp-1175) #f) (apply (lambda (syntmp-x-1179 syntmp-dots-1180 syntmp-y-1181) (let syntmp-f-1182 ((syntmp-y-1183 syntmp-y-1181) (syntmp-k-1184 (lambda (syntmp-maps-1185) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-x-1179 syntmp-r-1159 (cons (quote ()) syntmp-maps-1185) syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-x-1186 syntmp-maps-1187) (if (null? (car syntmp-maps-1187)) (syntax-error syntmp-src-1157 "extra ellipsis in syntax form") (values (syntmp-gen-map-1125 syntmp-x-1186 (car syntmp-maps-1187)) (cdr syntmp-maps-1187)))))))) ((lambda (syntmp-tmp-1188) ((lambda (syntmp-tmp-1189) (if (if syntmp-tmp-1189 (apply (lambda (syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1161 syntmp-dots-1190)) syntmp-tmp-1189) #f) (apply (lambda (syntmp-dots-1192 syntmp-y-1193) (syntmp-f-1182 syntmp-y-1193 (lambda (syntmp-maps-1194) (call-with-values (lambda () (syntmp-k-1184 (cons (quote ()) syntmp-maps-1194))) (lambda (syntmp-x-1195 syntmp-maps-1196) (if (null? (car syntmp-maps-1196)) (syntax-error syntmp-src-1157 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1124 syntmp-x-1195 (car syntmp-maps-1196)) (cdr syntmp-maps-1196)))))))) syntmp-tmp-1189) ((lambda (syntmp-_-1197) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-y-1183 syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-y-1198 syntmp-maps-1199) (call-with-values (lambda () (syntmp-k-1184 syntmp-maps-1199)) (lambda (syntmp-x-1200 syntmp-maps-1201) (values (syntmp-gen-append-1127 syntmp-x-1200 syntmp-y-1198) syntmp-maps-1201)))))) syntmp-tmp-1188))) (syntax-dispatch syntmp-tmp-1188 (quote (any . any))))) syntmp-y-1183))) syntmp-tmp-1175) ((lambda (syntmp-tmp-1202) (if syntmp-tmp-1202 (apply (lambda (syntmp-x-1203 syntmp-y-1204) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-x-1203 syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-x-1205 syntmp-maps-1206) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-y-1204 syntmp-r-1159 syntmp-maps-1206 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-y-1207 syntmp-maps-1208) (values (syntmp-gen-cons-1126 syntmp-x-1205 syntmp-y-1207) syntmp-maps-1208)))))) syntmp-tmp-1202) ((lambda (syntmp-tmp-1209) (if syntmp-tmp-1209 (apply (lambda (syntmp-e1-1210 syntmp-e2-1211) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 (cons syntmp-e1-1210 syntmp-e2-1211) syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-e-1213 syntmp-maps-1214) (values (syntmp-gen-vector-1128 syntmp-e-1213) syntmp-maps-1214)))) syntmp-tmp-1209) ((lambda (syntmp-_-1215) (values (list (quote quote) syntmp-e-1158) syntmp-maps-1160)) syntmp-tmp-1168))) (syntax-dispatch syntmp-tmp-1168 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1168 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1168 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1168 (quote (any any))))) syntmp-e-1158))))) (lambda (syntmp-e-1216 syntmp-r-1217 syntmp-w-1218 syntmp-s-1219 syntmp-mod-1220) (let ((syntmp-e-1221 (syntmp-source-wrap-146 syntmp-e-1216 syntmp-w-1218 syntmp-s-1219 syntmp-mod-1220))) ((lambda (syntmp-tmp-1222) ((lambda (syntmp-tmp-1223) (if syntmp-tmp-1223 (apply (lambda (syntmp-_-1224 syntmp-x-1225) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-e-1221 syntmp-x-1225 syntmp-r-1217 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1220)) (lambda (syntmp-e-1226 syntmp-maps-1227) (syntmp-regen-1129 syntmp-e-1226)))) syntmp-tmp-1223) ((lambda (syntmp-_-1228) (syntax-error syntmp-e-1221)) syntmp-tmp-1222))) (syntax-dispatch syntmp-tmp-1222 (quote (any any))))) syntmp-e-1221))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) ((lambda (syntmp-tmp-1234) ((lambda (syntmp-tmp-1235) (if syntmp-tmp-1235 (apply (lambda (syntmp-_-1236 syntmp-c-1237) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) syntmp-c-1237 syntmp-r-1230 syntmp-w-1231 syntmp-mod-1233 (lambda (syntmp-vars-1238 syntmp-body-1239) (syntmp-build-annotated-94 syntmp-s-1232 (list (quote lambda) syntmp-vars-1238 syntmp-body-1239))))) syntmp-tmp-1235) (syntax-error syntmp-tmp-1234))) (syntax-dispatch syntmp-tmp-1234 (quote (any . any))))) syntmp-e-1229))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1240 (lambda (syntmp-e-1241 syntmp-r-1242 syntmp-w-1243 syntmp-s-1244 syntmp-mod-1245 syntmp-constructor-1246 syntmp-ids-1247 syntmp-vals-1248 syntmp-exps-1249) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1247)) (syntax-error syntmp-e-1241 "duplicate bound variable in") (let ((syntmp-labels-1250 (syntmp-gen-labels-123 syntmp-ids-1247)) (syntmp-new-vars-1251 (map syntmp-gen-var-165 syntmp-ids-1247))) (let ((syntmp-nw-1252 (syntmp-make-binding-wrap-134 syntmp-ids-1247 syntmp-labels-1250 syntmp-w-1243)) (syntmp-nr-1253 (syntmp-extend-var-env-112 syntmp-labels-1250 syntmp-new-vars-1251 syntmp-r-1242))) (syntmp-constructor-1246 syntmp-s-1244 syntmp-new-vars-1251 (map (lambda (syntmp-x-1254) (syntmp-chi-153 syntmp-x-1254 syntmp-r-1242 syntmp-w-1243 syntmp-mod-1245)) syntmp-vals-1248) (syntmp-chi-body-157 syntmp-exps-1249 (syntmp-source-wrap-146 syntmp-e-1241 syntmp-nw-1252 syntmp-s-1244 syntmp-mod-1245) syntmp-nr-1253 syntmp-nw-1252 syntmp-mod-1245)))))))) (lambda (syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259) ((lambda (syntmp-tmp-1260) ((lambda (syntmp-tmp-1261) (if syntmp-tmp-1261 (apply (lambda (syntmp-_-1262 syntmp-id-1263 syntmp-val-1264 syntmp-e1-1265 syntmp-e2-1266) (syntmp-chi-let-1240 syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259 syntmp-build-let-97 syntmp-id-1263 syntmp-val-1264 (cons syntmp-e1-1265 syntmp-e2-1266))) syntmp-tmp-1261) ((lambda (syntmp-tmp-1270) (if (if syntmp-tmp-1270 (apply (lambda (syntmp-_-1271 syntmp-f-1272 syntmp-id-1273 syntmp-val-1274 syntmp-e1-1275 syntmp-e2-1276) (syntmp-id?-117 syntmp-f-1272)) syntmp-tmp-1270) #f) (apply (lambda (syntmp-_-1277 syntmp-f-1278 syntmp-id-1279 syntmp-val-1280 syntmp-e1-1281 syntmp-e2-1282) (syntmp-chi-let-1240 syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259 syntmp-build-named-let-98 (cons syntmp-f-1278 syntmp-id-1279) syntmp-val-1280 (cons syntmp-e1-1281 syntmp-e2-1282))) syntmp-tmp-1270) ((lambda (syntmp-_-1286) (syntax-error (syntmp-source-wrap-146 syntmp-e-1255 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259))) syntmp-tmp-1260))) (syntax-dispatch syntmp-tmp-1260 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1260 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1255)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1287 syntmp-r-1288 syntmp-w-1289 syntmp-s-1290 syntmp-mod-1291) ((lambda (syntmp-tmp-1292) ((lambda (syntmp-tmp-1293) (if syntmp-tmp-1293 (apply (lambda (syntmp-_-1294 syntmp-id-1295 syntmp-val-1296 syntmp-e1-1297 syntmp-e2-1298) (let ((syntmp-ids-1299 syntmp-id-1295)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1299)) (syntax-error syntmp-e-1287 "duplicate bound variable in") (let ((syntmp-labels-1301 (syntmp-gen-labels-123 syntmp-ids-1299)) (syntmp-new-vars-1302 (map syntmp-gen-var-165 syntmp-ids-1299))) (let ((syntmp-w-1303 (syntmp-make-binding-wrap-134 syntmp-ids-1299 syntmp-labels-1301 syntmp-w-1289)) (syntmp-r-1304 (syntmp-extend-var-env-112 syntmp-labels-1301 syntmp-new-vars-1302 syntmp-r-1288))) (syntmp-build-letrec-99 syntmp-s-1290 syntmp-new-vars-1302 (map (lambda (syntmp-x-1305) (syntmp-chi-153 syntmp-x-1305 syntmp-r-1304 syntmp-w-1303 syntmp-mod-1291)) syntmp-val-1296) (syntmp-chi-body-157 (cons syntmp-e1-1297 syntmp-e2-1298) (syntmp-source-wrap-146 syntmp-e-1287 syntmp-w-1303 syntmp-s-1290 syntmp-mod-1291) syntmp-r-1304 syntmp-w-1303 syntmp-mod-1291))))))) syntmp-tmp-1293) ((lambda (syntmp-_-1308) (syntax-error (syntmp-source-wrap-146 syntmp-e-1287 syntmp-w-1289 syntmp-s-1290 syntmp-mod-1291))) syntmp-tmp-1292))) (syntax-dispatch syntmp-tmp-1292 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1287))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1309 syntmp-r-1310 syntmp-w-1311 syntmp-s-1312 syntmp-mod-1313) ((lambda (syntmp-tmp-1314) ((lambda (syntmp-tmp-1315) (if (if syntmp-tmp-1315 (apply (lambda (syntmp-_-1316 syntmp-id-1317 syntmp-val-1318) (syntmp-id?-117 syntmp-id-1317)) syntmp-tmp-1315) #f) (apply (lambda (syntmp-_-1319 syntmp-id-1320 syntmp-val-1321) (let ((syntmp-val-1322 (syntmp-chi-153 syntmp-val-1321 syntmp-r-1310 syntmp-w-1311 syntmp-mod-1313)) (syntmp-n-1323 (syntmp-id-var-name-139 syntmp-id-1320 syntmp-w-1311))) (let ((syntmp-b-1324 (syntmp-lookup-114 syntmp-n-1323 syntmp-r-1310 syntmp-mod-1313))) (let ((syntmp-t-1325 (syntmp-binding-type-109 syntmp-b-1324))) (if (memv syntmp-t-1325 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1312 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1324) syntmp-val-1322)) (if (memv syntmp-t-1325 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1312 (list (quote set!) (make-module-ref (and syntmp-mod-1313 (module-name syntmp-mod-1313)) syntmp-n-1323 #f) syntmp-val-1322)) (if (memv syntmp-t-1325 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1320 syntmp-w-1311 syntmp-mod-1313) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1309 syntmp-w-1311 syntmp-s-1312 syntmp-mod-1313))))))))) syntmp-tmp-1315) ((lambda (syntmp-tmp-1326) (if syntmp-tmp-1326 (apply (lambda (syntmp-_-1327 syntmp-getter-1328 syntmp-arg-1329 syntmp-val-1330) (syntmp-build-annotated-94 syntmp-s-1312 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-getter-1328) syntmp-r-1310 syntmp-w-1311 syntmp-mod-1313) (map (lambda (syntmp-e-1331) (syntmp-chi-153 syntmp-e-1331 syntmp-r-1310 syntmp-w-1311 syntmp-mod-1313)) (append syntmp-arg-1329 (list syntmp-val-1330)))))) syntmp-tmp-1326) ((lambda (syntmp-_-1333) (syntax-error (syntmp-source-wrap-146 syntmp-e-1309 syntmp-w-1311 syntmp-s-1312 syntmp-mod-1313))) syntmp-tmp-1314))) (syntax-dispatch syntmp-tmp-1314 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1314 (quote (any any any))))) syntmp-e-1309))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1337 (lambda (syntmp-x-1338 syntmp-keys-1339 syntmp-clauses-1340 syntmp-r-1341 syntmp-mod-1342) (if (null? syntmp-clauses-1340) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1338)) ((lambda (syntmp-tmp-1343) ((lambda (syntmp-tmp-1344) (if syntmp-tmp-1344 (apply (lambda (syntmp-pat-1345 syntmp-exp-1346) (if (and (syntmp-id?-117 syntmp-pat-1345) (andmap (lambda (syntmp-x-1347) (not (syntmp-free-id=?-140 syntmp-pat-1345 syntmp-x-1347))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-keys-1339))) (let ((syntmp-labels-1348 (list (syntmp-gen-label-122))) (syntmp-var-1349 (syntmp-gen-var-165 syntmp-pat-1345))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1349) (syntmp-chi-153 syntmp-exp-1346 (syntmp-extend-env-111 syntmp-labels-1348 (list (cons (quote syntax) (cons syntmp-var-1349 0))) syntmp-r-1341) (syntmp-make-binding-wrap-134 (list syntmp-pat-1345) syntmp-labels-1348 (quote (()))) syntmp-mod-1342))) syntmp-x-1338))) (syntmp-gen-clause-1336 syntmp-x-1338 syntmp-keys-1339 (cdr syntmp-clauses-1340) syntmp-r-1341 syntmp-pat-1345 #t syntmp-exp-1346 syntmp-mod-1342))) syntmp-tmp-1344) ((lambda (syntmp-tmp-1350) (if syntmp-tmp-1350 (apply (lambda (syntmp-pat-1351 syntmp-fender-1352 syntmp-exp-1353) (syntmp-gen-clause-1336 syntmp-x-1338 syntmp-keys-1339 (cdr syntmp-clauses-1340) syntmp-r-1341 syntmp-pat-1351 syntmp-fender-1352 syntmp-exp-1353 syntmp-mod-1342)) syntmp-tmp-1350) ((lambda (syntmp-_-1354) (syntax-error (car syntmp-clauses-1340) "invalid syntax-case clause")) syntmp-tmp-1343))) (syntax-dispatch syntmp-tmp-1343 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1343 (quote (any any))))) (car syntmp-clauses-1340))))) (syntmp-gen-clause-1336 (lambda (syntmp-x-1355 syntmp-keys-1356 syntmp-clauses-1357 syntmp-r-1358 syntmp-pat-1359 syntmp-fender-1360 syntmp-exp-1361 syntmp-mod-1362) (call-with-values (lambda () (syntmp-convert-pattern-1334 syntmp-pat-1359 syntmp-keys-1356)) (lambda (syntmp-p-1363 syntmp-pvars-1364) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1364))) (syntax-error syntmp-pat-1359 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1365) (not (syntmp-ellipsis?-162 (car syntmp-x-1365)))) syntmp-pvars-1364)) (syntax-error syntmp-pat-1359 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1366 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1366) (let ((syntmp-y-1367 (syntmp-build-annotated-94 #f syntmp-y-1366))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1368) ((lambda (syntmp-tmp-1369) (if syntmp-tmp-1369 (apply (lambda () syntmp-y-1367) syntmp-tmp-1369) ((lambda (syntmp-_-1370) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1367 (syntmp-build-dispatch-call-1335 syntmp-pvars-1364 syntmp-fender-1360 syntmp-y-1367 syntmp-r-1358 syntmp-mod-1362) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1368))) (syntax-dispatch syntmp-tmp-1368 (quote #(atom #t))))) syntmp-fender-1360) (syntmp-build-dispatch-call-1335 syntmp-pvars-1364 syntmp-exp-1361 syntmp-y-1367 syntmp-r-1358 syntmp-mod-1362) (syntmp-gen-syntax-case-1337 syntmp-x-1355 syntmp-keys-1356 syntmp-clauses-1357 syntmp-r-1358 syntmp-mod-1362)))))) (if (eq? syntmp-p-1363 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1355)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1355 (syntmp-build-data-95 #f syntmp-p-1363))))))))))))) (syntmp-build-dispatch-call-1335 (lambda (syntmp-pvars-1371 syntmp-exp-1372 syntmp-y-1373 syntmp-r-1374 syntmp-mod-1375) (let ((syntmp-ids-1376 (map car syntmp-pvars-1371)) (syntmp-levels-1377 (map cdr syntmp-pvars-1371))) (let ((syntmp-labels-1378 (syntmp-gen-labels-123 syntmp-ids-1376)) (syntmp-new-vars-1379 (map syntmp-gen-var-165 syntmp-ids-1376))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1379 (syntmp-chi-153 syntmp-exp-1372 (syntmp-extend-env-111 syntmp-labels-1378 (map (lambda (syntmp-var-1380 syntmp-level-1381) (cons (quote syntax) (cons syntmp-var-1380 syntmp-level-1381))) syntmp-new-vars-1379 (map cdr syntmp-pvars-1371)) syntmp-r-1374) (syntmp-make-binding-wrap-134 syntmp-ids-1376 syntmp-labels-1378 (quote (()))) syntmp-mod-1375))) syntmp-y-1373)))))) (syntmp-convert-pattern-1334 (lambda (syntmp-pattern-1382 syntmp-keys-1383) (let syntmp-cvt-1384 ((syntmp-p-1385 syntmp-pattern-1382) (syntmp-n-1386 0) (syntmp-ids-1387 (quote ()))) (if (syntmp-id?-117 syntmp-p-1385) (if (syntmp-bound-id-member?-144 syntmp-p-1385 syntmp-keys-1383) (values (vector (quote free-id) syntmp-p-1385) syntmp-ids-1387) (values (quote any) (cons (cons syntmp-p-1385 syntmp-n-1386) syntmp-ids-1387))) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if (if syntmp-tmp-1389 (apply (lambda (syntmp-x-1390 syntmp-dots-1391) (syntmp-ellipsis?-162 syntmp-dots-1391)) syntmp-tmp-1389) #f) (apply (lambda (syntmp-x-1392 syntmp-dots-1393) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-x-1392 (syntmp-fx+-85 syntmp-n-1386 1) syntmp-ids-1387)) (lambda (syntmp-p-1394 syntmp-ids-1395) (values (if (eq? syntmp-p-1394 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1394)) syntmp-ids-1395)))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1396) (if syntmp-tmp-1396 (apply (lambda (syntmp-x-1397 syntmp-y-1398) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-y-1398 syntmp-n-1386 syntmp-ids-1387)) (lambda (syntmp-y-1399 syntmp-ids-1400) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-x-1397 syntmp-n-1386 syntmp-ids-1400)) (lambda (syntmp-x-1401 syntmp-ids-1402) (values (cons syntmp-x-1401 syntmp-y-1399) syntmp-ids-1402)))))) syntmp-tmp-1396) ((lambda (syntmp-tmp-1403) (if syntmp-tmp-1403 (apply (lambda () (values (quote ()) syntmp-ids-1387)) syntmp-tmp-1403) ((lambda (syntmp-tmp-1404) (if syntmp-tmp-1404 (apply (lambda (syntmp-x-1405) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-x-1405 syntmp-n-1386 syntmp-ids-1387)) (lambda (syntmp-p-1407 syntmp-ids-1408) (values (vector (quote vector) syntmp-p-1407) syntmp-ids-1408)))) syntmp-tmp-1404) ((lambda (syntmp-x-1409) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1385 (quote (())))) syntmp-ids-1387)) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1388 (quote ()))))) (syntax-dispatch syntmp-tmp-1388 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) syntmp-p-1385)))))) (lambda (syntmp-e-1410 syntmp-r-1411 syntmp-w-1412 syntmp-s-1413 syntmp-mod-1414) (let ((syntmp-e-1415 (syntmp-source-wrap-146 syntmp-e-1410 syntmp-w-1412 syntmp-s-1413 syntmp-mod-1414))) ((lambda (syntmp-tmp-1416) ((lambda (syntmp-tmp-1417) (if syntmp-tmp-1417 (apply (lambda (syntmp-_-1418 syntmp-val-1419 syntmp-key-1420 syntmp-m-1421) (if (andmap (lambda (syntmp-x-1422) (and (syntmp-id?-117 syntmp-x-1422) (not (syntmp-ellipsis?-162 syntmp-x-1422)))) syntmp-key-1420) (let ((syntmp-x-1424 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1413 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1424) (syntmp-gen-syntax-case-1337 (syntmp-build-annotated-94 #f syntmp-x-1424) syntmp-key-1420 syntmp-m-1421 syntmp-r-1411 syntmp-mod-1414))) (syntmp-chi-153 syntmp-val-1419 syntmp-r-1411 (quote (())) syntmp-mod-1414)))) (syntax-error syntmp-e-1415 "invalid literals list in"))) syntmp-tmp-1417) (syntax-error syntmp-tmp-1416))) (syntax-dispatch syntmp-tmp-1416 (quote (any any each-any . each-any))))) syntmp-e-1415))))) (set! sc-expand (let ((syntmp-m-1427 (quote e)) (syntmp-esew-1428 (quote (eval)))) (lambda (syntmp-x-1429) (if (and (pair? syntmp-x-1429) (equal? (car syntmp-x-1429) syntmp-noexpand-84)) (cadr syntmp-x-1429) (syntmp-chi-top-152 syntmp-x-1429 (quote ()) (quote ((top))) syntmp-m-1427 syntmp-esew-1428 (current-module)))))) (set! sc-expand3 (let ((syntmp-m-1430 (quote e)) (syntmp-esew-1431 (quote (eval)))) (lambda (syntmp-x-1433 . syntmp-rest-1432) (if (and (pair? syntmp-x-1433) (equal? (car syntmp-x-1433) syntmp-noexpand-84)) (cadr syntmp-x-1433) (syntmp-chi-top-152 syntmp-x-1433 (quote ()) (quote ((top))) (if (null? syntmp-rest-1432) syntmp-m-1430 (car syntmp-rest-1432)) (if (or (null? syntmp-rest-1432) (null? (cdr syntmp-rest-1432))) syntmp-esew-1431 (cadr syntmp-rest-1432)) (current-module)))))) (set! identifier? (lambda (syntmp-x-1434) (syntmp-nonsymbol-id?-116 syntmp-x-1434))) (set! datum->syntax-object (lambda (syntmp-id-1435 syntmp-datum-1436) (syntmp-make-syntax-object-100 syntmp-datum-1436 (syntmp-syntax-object-wrap-103 syntmp-id-1435) #f))) (set! syntax-object->datum (lambda (syntmp-x-1437) (syntmp-strip-164 syntmp-x-1437 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1438) (begin (let ((syntmp-x-1439 syntmp-ls-1438)) (if (not (list? syntmp-x-1439)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1439))) (map (lambda (syntmp-x-1440) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1438)))) (set! free-identifier=? (lambda (syntmp-x-1441 syntmp-y-1442) (begin (let ((syntmp-x-1443 syntmp-x-1441)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1443)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1443))) (let ((syntmp-x-1444 syntmp-y-1442)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1444)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1444))) (syntmp-free-id=?-140 syntmp-x-1441 syntmp-y-1442)))) (set! bound-identifier=? (lambda (syntmp-x-1445 syntmp-y-1446) (begin (let ((syntmp-x-1447 syntmp-x-1445)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1447)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1447))) (let ((syntmp-x-1448 syntmp-y-1446)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1448)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1448))) (syntmp-bound-id=?-141 syntmp-x-1445 syntmp-y-1446)))) (set! syntax-error (lambda (syntmp-object-1450 . syntmp-messages-1449) (begin (for-each (lambda (syntmp-x-1451) (let ((syntmp-x-1452 syntmp-x-1451)) (if (not (string? syntmp-x-1452)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1452)))) syntmp-messages-1449) (let ((syntmp-message-1453 (if (null? syntmp-messages-1449) "invalid syntax" (apply string-append syntmp-messages-1449)))) (syntmp-error-hook-91 #f syntmp-message-1453 (syntmp-strip-164 syntmp-object-1450 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1454 syntmp-v-1455) (begin (let ((syntmp-x-1456 syntmp-sym-1454)) (if (not (symbol? syntmp-x-1456)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1456))) (let ((syntmp-x-1457 syntmp-v-1455)) (if (not (procedure? syntmp-x-1457)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1457))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1454 syntmp-v-1455)))) (letrec ((syntmp-match-1462 (lambda (syntmp-e-1463 syntmp-p-1464 syntmp-w-1465 syntmp-r-1466) (cond ((not syntmp-r-1466) #f) ((eq? syntmp-p-1464 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1463 syntmp-w-1465 #f) syntmp-r-1466)) ((syntmp-syntax-object?-101 syntmp-e-1463) (syntmp-match*-1461 (let ((syntmp-e-1467 (syntmp-syntax-object-expression-102 syntmp-e-1463))) (if (annotation? syntmp-e-1467) (annotation-expression syntmp-e-1467) syntmp-e-1467)) syntmp-p-1464 (syntmp-join-wraps-136 syntmp-w-1465 (syntmp-syntax-object-wrap-103 syntmp-e-1463)) syntmp-r-1466)) (else (syntmp-match*-1461 (let ((syntmp-e-1468 syntmp-e-1463)) (if (annotation? syntmp-e-1468) (annotation-expression syntmp-e-1468) syntmp-e-1468)) syntmp-p-1464 syntmp-w-1465 syntmp-r-1466))))) (syntmp-match*-1461 (lambda (syntmp-e-1469 syntmp-p-1470 syntmp-w-1471 syntmp-r-1472) (cond ((null? syntmp-p-1470) (and (null? syntmp-e-1469) syntmp-r-1472)) ((pair? syntmp-p-1470) (and (pair? syntmp-e-1469) (syntmp-match-1462 (car syntmp-e-1469) (car syntmp-p-1470) syntmp-w-1471 (syntmp-match-1462 (cdr syntmp-e-1469) (cdr syntmp-p-1470) syntmp-w-1471 syntmp-r-1472)))) ((eq? syntmp-p-1470 (quote each-any)) (let ((syntmp-l-1473 (syntmp-match-each-any-1459 syntmp-e-1469 syntmp-w-1471))) (and syntmp-l-1473 (cons syntmp-l-1473 syntmp-r-1472)))) (else (let ((syntmp-t-1474 (vector-ref syntmp-p-1470 0))) (if (memv syntmp-t-1474 (quote (each))) (if (null? syntmp-e-1469) (syntmp-match-empty-1460 (vector-ref syntmp-p-1470 1) syntmp-r-1472) (let ((syntmp-l-1475 (syntmp-match-each-1458 syntmp-e-1469 (vector-ref syntmp-p-1470 1) syntmp-w-1471))) (and syntmp-l-1475 (let syntmp-collect-1476 ((syntmp-l-1477 syntmp-l-1475)) (if (null? (car syntmp-l-1477)) syntmp-r-1472 (cons (map car syntmp-l-1477) (syntmp-collect-1476 (map cdr syntmp-l-1477)))))))) (if (memv syntmp-t-1474 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1469) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1469 syntmp-w-1471 #f) (vector-ref syntmp-p-1470 1)) syntmp-r-1472) (if (memv syntmp-t-1474 (quote (atom))) (and (equal? (vector-ref syntmp-p-1470 1) (syntmp-strip-164 syntmp-e-1469 syntmp-w-1471)) syntmp-r-1472) (if (memv syntmp-t-1474 (quote (vector))) (and (vector? syntmp-e-1469) (syntmp-match-1462 (vector->list syntmp-e-1469) (vector-ref syntmp-p-1470 1) syntmp-w-1471 syntmp-r-1472))))))))))) (syntmp-match-empty-1460 (lambda (syntmp-p-1478 syntmp-r-1479) (cond ((null? syntmp-p-1478) syntmp-r-1479) ((eq? syntmp-p-1478 (quote any)) (cons (quote ()) syntmp-r-1479)) ((pair? syntmp-p-1478) (syntmp-match-empty-1460 (car syntmp-p-1478) (syntmp-match-empty-1460 (cdr syntmp-p-1478) syntmp-r-1479))) ((eq? syntmp-p-1478 (quote each-any)) (cons (quote ()) syntmp-r-1479)) (else (let ((syntmp-t-1480 (vector-ref syntmp-p-1478 0))) (if (memv syntmp-t-1480 (quote (each))) (syntmp-match-empty-1460 (vector-ref syntmp-p-1478 1) syntmp-r-1479) (if (memv syntmp-t-1480 (quote (free-id atom))) syntmp-r-1479 (if (memv syntmp-t-1480 (quote (vector))) (syntmp-match-empty-1460 (vector-ref syntmp-p-1478 1) syntmp-r-1479))))))))) (syntmp-match-each-any-1459 (lambda (syntmp-e-1481 syntmp-w-1482) (cond ((annotation? syntmp-e-1481) (syntmp-match-each-any-1459 (annotation-expression syntmp-e-1481) syntmp-w-1482)) ((pair? syntmp-e-1481) (let ((syntmp-l-1483 (syntmp-match-each-any-1459 (cdr syntmp-e-1481) syntmp-w-1482))) (and syntmp-l-1483 (cons (syntmp-wrap-145 (car syntmp-e-1481) syntmp-w-1482 #f) syntmp-l-1483)))) ((null? syntmp-e-1481) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1481) (syntmp-match-each-any-1459 (syntmp-syntax-object-expression-102 syntmp-e-1481) (syntmp-join-wraps-136 syntmp-w-1482 (syntmp-syntax-object-wrap-103 syntmp-e-1481)))) (else #f)))) (syntmp-match-each-1458 (lambda (syntmp-e-1484 syntmp-p-1485 syntmp-w-1486) (cond ((annotation? syntmp-e-1484) (syntmp-match-each-1458 (annotation-expression syntmp-e-1484) syntmp-p-1485 syntmp-w-1486)) ((pair? syntmp-e-1484) (let ((syntmp-first-1487 (syntmp-match-1462 (car syntmp-e-1484) syntmp-p-1485 syntmp-w-1486 (quote ())))) (and syntmp-first-1487 (let ((syntmp-rest-1488 (syntmp-match-each-1458 (cdr syntmp-e-1484) syntmp-p-1485 syntmp-w-1486))) (and syntmp-rest-1488 (cons syntmp-first-1487 syntmp-rest-1488)))))) ((null? syntmp-e-1484) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1484) (syntmp-match-each-1458 (syntmp-syntax-object-expression-102 syntmp-e-1484) syntmp-p-1485 (syntmp-join-wraps-136 syntmp-w-1486 (syntmp-syntax-object-wrap-103 syntmp-e-1484)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1489 syntmp-p-1490) (cond ((eq? syntmp-p-1490 (quote any)) (list syntmp-e-1489)) ((syntmp-syntax-object?-101 syntmp-e-1489) (syntmp-match*-1461 (let ((syntmp-e-1491 (syntmp-syntax-object-expression-102 syntmp-e-1489))) (if (annotation? syntmp-e-1491) (annotation-expression syntmp-e-1491) syntmp-e-1491)) syntmp-p-1490 (syntmp-syntax-object-wrap-103 syntmp-e-1489) (quote ()))) (else (syntmp-match*-1461 (let ((syntmp-e-1492 syntmp-e-1489)) (if (annotation? syntmp-e-1492) (annotation-expression syntmp-e-1492) syntmp-e-1492)) syntmp-p-1490 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-153))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1493) ((lambda (syntmp-tmp-1494) ((lambda (syntmp-tmp-1495) (if syntmp-tmp-1495 (apply (lambda (syntmp-_-1496 syntmp-e1-1497 syntmp-e2-1498) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1497 syntmp-e2-1498))) syntmp-tmp-1495) ((lambda (syntmp-tmp-1500) (if syntmp-tmp-1500 (apply (lambda (syntmp-_-1501 syntmp-out-1502 syntmp-in-1503 syntmp-e1-1504 syntmp-e2-1505) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1503 (quote ()) (list syntmp-out-1502 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1504 syntmp-e2-1505))))) syntmp-tmp-1500) ((lambda (syntmp-tmp-1507) (if syntmp-tmp-1507 (apply (lambda (syntmp-_-1508 syntmp-out-1509 syntmp-in-1510 syntmp-e1-1511 syntmp-e2-1512) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1510) (quote ()) (list syntmp-out-1509 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1511 syntmp-e2-1512))))) syntmp-tmp-1507) (syntax-error syntmp-tmp-1494))) (syntax-dispatch syntmp-tmp-1494 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1494 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1494 (quote (any () any . each-any))))) syntmp-x-1493))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1534) ((lambda (syntmp-tmp-1535) ((lambda (syntmp-tmp-1536) (if syntmp-tmp-1536 (apply (lambda (syntmp-_-1537 syntmp-k-1538 syntmp-keyword-1539 syntmp-pattern-1540 syntmp-template-1541) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-k-1538 (map (lambda (syntmp-tmp-1544 syntmp-tmp-1543) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1543) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1544))) syntmp-template-1541 syntmp-pattern-1540)))))) syntmp-tmp-1536) (syntax-error syntmp-tmp-1535))) (syntax-dispatch syntmp-tmp-1535 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1534))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1555) ((lambda (syntmp-tmp-1556) ((lambda (syntmp-tmp-1557) (if (if syntmp-tmp-1557 (apply (lambda (syntmp-let*-1558 syntmp-x-1559 syntmp-v-1560 syntmp-e1-1561 syntmp-e2-1562) (andmap identifier? syntmp-x-1559)) syntmp-tmp-1557) #f) (apply (lambda (syntmp-let*-1564 syntmp-x-1565 syntmp-v-1566 syntmp-e1-1567 syntmp-e2-1568) (let syntmp-f-1569 ((syntmp-bindings-1570 (map list syntmp-x-1565 syntmp-v-1566))) (if (null? syntmp-bindings-1570) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote ()) (cons syntmp-e1-1567 syntmp-e2-1568))) ((lambda (syntmp-tmp-1574) ((lambda (syntmp-tmp-1575) (if syntmp-tmp-1575 (apply (lambda (syntmp-body-1576 syntmp-binding-1577) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list syntmp-binding-1577) syntmp-body-1576)) syntmp-tmp-1575) (syntax-error syntmp-tmp-1574))) (syntax-dispatch syntmp-tmp-1574 (quote (any any))))) (list (syntmp-f-1569 (cdr syntmp-bindings-1570)) (car syntmp-bindings-1570)))))) syntmp-tmp-1557) (syntax-error syntmp-tmp-1556))) (syntax-dispatch syntmp-tmp-1556 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1555))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1597) ((lambda (syntmp-tmp-1598) ((lambda (syntmp-tmp-1599) (if syntmp-tmp-1599 (apply (lambda (syntmp-_-1600 syntmp-var-1601 syntmp-init-1602 syntmp-step-1603 syntmp-e0-1604 syntmp-e1-1605 syntmp-c-1606) ((lambda (syntmp-tmp-1607) ((lambda (syntmp-tmp-1608) (if syntmp-tmp-1608 (apply (lambda (syntmp-step-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1601 syntmp-init-1602) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1604) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1606 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1609))))))) syntmp-tmp-1611) ((lambda (syntmp-tmp-1616) (if syntmp-tmp-1616 (apply (lambda (syntmp-e1-1617 syntmp-e2-1618) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1601 syntmp-init-1602) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1604 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (cons syntmp-e1-1617 syntmp-e2-1618)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1606 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1609))))))) syntmp-tmp-1616) (syntax-error syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1610 (quote ())))) syntmp-e1-1605)) syntmp-tmp-1608) (syntax-error syntmp-tmp-1607))) (syntax-dispatch syntmp-tmp-1607 (quote each-any)))) (map (lambda (syntmp-v-1625 syntmp-s-1626) ((lambda (syntmp-tmp-1627) ((lambda (syntmp-tmp-1628) (if syntmp-tmp-1628 (apply (lambda () syntmp-v-1625) syntmp-tmp-1628) ((lambda (syntmp-tmp-1629) (if syntmp-tmp-1629 (apply (lambda (syntmp-e-1630) syntmp-e-1630) syntmp-tmp-1629) ((lambda (syntmp-_-1631) (syntax-error syntmp-orig-x-1597)) syntmp-tmp-1627))) (syntax-dispatch syntmp-tmp-1627 (quote (any)))))) (syntax-dispatch syntmp-tmp-1627 (quote ())))) syntmp-s-1626)) syntmp-var-1601 syntmp-step-1603))) syntmp-tmp-1599) (syntax-error syntmp-tmp-1598))) (syntax-dispatch syntmp-tmp-1598 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1597))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1659 (lambda (syntmp-x-1663 syntmp-y-1664) ((lambda (syntmp-tmp-1665) ((lambda (syntmp-tmp-1666) (if syntmp-tmp-1666 (apply (lambda (syntmp-x-1667 syntmp-y-1668) ((lambda (syntmp-tmp-1669) ((lambda (syntmp-tmp-1670) (if syntmp-tmp-1670 (apply (lambda (syntmp-dy-1671) ((lambda (syntmp-tmp-1672) ((lambda (syntmp-tmp-1673) (if syntmp-tmp-1673 (apply (lambda (syntmp-dx-1674) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-dx-1674 syntmp-dy-1671))) syntmp-tmp-1673) ((lambda (syntmp-_-1675) (if (null? syntmp-dy-1671) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1667) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1667 syntmp-y-1668))) syntmp-tmp-1672))) (syntax-dispatch syntmp-tmp-1672 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-x-1667)) syntmp-tmp-1670) ((lambda (syntmp-tmp-1676) (if syntmp-tmp-1676 (apply (lambda (syntmp-stuff-1677) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-x-1667 syntmp-stuff-1677))) syntmp-tmp-1676) ((lambda (syntmp-else-1678) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1667 syntmp-y-1668)) syntmp-tmp-1669))) (syntax-dispatch syntmp-tmp-1669 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . any)))))) (syntax-dispatch syntmp-tmp-1669 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-y-1668)) syntmp-tmp-1666) (syntax-error syntmp-tmp-1665))) (syntax-dispatch syntmp-tmp-1665 (quote (any any))))) (list syntmp-x-1663 syntmp-y-1664)))) (syntmp-quasiappend-1660 (lambda (syntmp-x-1679 syntmp-y-1680) ((lambda (syntmp-tmp-1681) ((lambda (syntmp-tmp-1682) (if syntmp-tmp-1682 (apply (lambda (syntmp-x-1683 syntmp-y-1684) ((lambda (syntmp-tmp-1685) ((lambda (syntmp-tmp-1686) (if syntmp-tmp-1686 (apply (lambda () syntmp-x-1683) syntmp-tmp-1686) ((lambda (syntmp-_-1687) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1683 syntmp-y-1684)) syntmp-tmp-1685))) (syntax-dispatch syntmp-tmp-1685 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) ()))))) syntmp-y-1684)) syntmp-tmp-1682) (syntax-error syntmp-tmp-1681))) (syntax-dispatch syntmp-tmp-1681 (quote (any any))))) (list syntmp-x-1679 syntmp-y-1680)))) (syntmp-quasivector-1661 (lambda (syntmp-x-1688) ((lambda (syntmp-tmp-1689) ((lambda (syntmp-x-1690) ((lambda (syntmp-tmp-1691) ((lambda (syntmp-tmp-1692) (if syntmp-tmp-1692 (apply (lambda (syntmp-x-1693) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (list->vector syntmp-x-1693))) syntmp-tmp-1692) ((lambda (syntmp-tmp-1695) (if syntmp-tmp-1695 (apply (lambda (syntmp-x-1696) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1696)) syntmp-tmp-1695) ((lambda (syntmp-_-1698) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1690)) syntmp-tmp-1691))) (syntax-dispatch syntmp-tmp-1691 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . each-any)))))) (syntax-dispatch syntmp-tmp-1691 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) each-any))))) syntmp-x-1690)) syntmp-tmp-1689)) syntmp-x-1688))) (syntmp-quasi-1662 (lambda (syntmp-p-1699 syntmp-lev-1700) ((lambda (syntmp-tmp-1701) ((lambda (syntmp-tmp-1702) (if syntmp-tmp-1702 (apply (lambda (syntmp-p-1703) (if (= syntmp-lev-1700 0) syntmp-p-1703 (syntmp-quasicons-1659 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1662 (list syntmp-p-1703) (- syntmp-lev-1700 1))))) syntmp-tmp-1702) ((lambda (syntmp-tmp-1704) (if syntmp-tmp-1704 (apply (lambda (syntmp-p-1705 syntmp-q-1706) (if (= syntmp-lev-1700 0) (syntmp-quasiappend-1660 syntmp-p-1705 (syntmp-quasi-1662 syntmp-q-1706 syntmp-lev-1700)) (syntmp-quasicons-1659 (syntmp-quasicons-1659 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1662 (list syntmp-p-1705) (- syntmp-lev-1700 1))) (syntmp-quasi-1662 syntmp-q-1706 syntmp-lev-1700)))) syntmp-tmp-1704) ((lambda (syntmp-tmp-1707) (if syntmp-tmp-1707 (apply (lambda (syntmp-p-1708) (syntmp-quasicons-1659 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1662 (list syntmp-p-1708) (+ syntmp-lev-1700 1)))) syntmp-tmp-1707) ((lambda (syntmp-tmp-1709) (if syntmp-tmp-1709 (apply (lambda (syntmp-p-1710 syntmp-q-1711) (syntmp-quasicons-1659 (syntmp-quasi-1662 syntmp-p-1710 syntmp-lev-1700) (syntmp-quasi-1662 syntmp-q-1711 syntmp-lev-1700))) syntmp-tmp-1709) ((lambda (syntmp-tmp-1712) (if syntmp-tmp-1712 (apply (lambda (syntmp-x-1713) (syntmp-quasivector-1661 (syntmp-quasi-1662 syntmp-x-1713 syntmp-lev-1700))) syntmp-tmp-1712) ((lambda (syntmp-p-1715) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-p-1715)) syntmp-tmp-1701))) (syntax-dispatch syntmp-tmp-1701 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1701 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1701 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any)))))) (syntax-dispatch syntmp-tmp-1701 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any) . any)))))) (syntax-dispatch syntmp-tmp-1701 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-p-1699)))) (lambda (syntmp-x-1716) ((lambda (syntmp-tmp-1717) ((lambda (syntmp-tmp-1718) (if syntmp-tmp-1718 (apply (lambda (syntmp-_-1719 syntmp-e-1720) (syntmp-quasi-1662 syntmp-e-1720 0)) syntmp-tmp-1718) (syntax-error syntmp-tmp-1717))) (syntax-dispatch syntmp-tmp-1717 (quote (any any))))) syntmp-x-1716)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1780) (letrec ((syntmp-read-file-1781 (lambda (syntmp-fn-1782 syntmp-k-1783) (let ((syntmp-p-1784 (open-input-file syntmp-fn-1782))) (let syntmp-f-1785 ((syntmp-x-1786 (read syntmp-p-1784))) (if (eof-object? syntmp-x-1786) (begin (close-input-port syntmp-p-1784) (quote ())) (cons (datum->syntax-object syntmp-k-1783 syntmp-x-1786) (syntmp-f-1785 (read syntmp-p-1784))))))))) ((lambda (syntmp-tmp-1787) ((lambda (syntmp-tmp-1788) (if syntmp-tmp-1788 (apply (lambda (syntmp-k-1789 syntmp-filename-1790) (let ((syntmp-fn-1791 (syntax-object->datum syntmp-filename-1790))) ((lambda (syntmp-tmp-1792) ((lambda (syntmp-tmp-1793) (if syntmp-tmp-1793 (apply (lambda (syntmp-exp-1794) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-exp-1794)) syntmp-tmp-1793) (syntax-error syntmp-tmp-1792))) (syntax-dispatch syntmp-tmp-1792 (quote each-any)))) (syntmp-read-file-1781 syntmp-fn-1791 syntmp-k-1789)))) syntmp-tmp-1788) (syntax-error syntmp-tmp-1787))) (syntax-dispatch syntmp-tmp-1787 (quote (any any))))) syntmp-x-1780)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1811) ((lambda (syntmp-tmp-1812) ((lambda (syntmp-tmp-1813) (if syntmp-tmp-1813 (apply (lambda (syntmp-_-1814 syntmp-e-1815) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1815))) syntmp-tmp-1813) (syntax-error syntmp-tmp-1812))) (syntax-dispatch syntmp-tmp-1812 (quote (any any))))) syntmp-x-1811))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1821) ((lambda (syntmp-tmp-1822) ((lambda (syntmp-tmp-1823) (if syntmp-tmp-1823 (apply (lambda (syntmp-_-1824 syntmp-e-1825) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1825))) syntmp-tmp-1823) (syntax-error syntmp-tmp-1822))) (syntax-dispatch syntmp-tmp-1822 (quote (any any))))) syntmp-x-1821))) +(install-global-transformer (quote case) (lambda (syntmp-x-1831) ((lambda (syntmp-tmp-1832) ((lambda (syntmp-tmp-1833) (if syntmp-tmp-1833 (apply (lambda (syntmp-_-1834 syntmp-e-1835 syntmp-m1-1836 syntmp-m2-1837) ((lambda (syntmp-tmp-1838) ((lambda (syntmp-body-1839) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1835)) syntmp-body-1839)) syntmp-tmp-1838)) (let syntmp-f-1840 ((syntmp-clause-1841 syntmp-m1-1836) (syntmp-clauses-1842 syntmp-m2-1837)) (if (null? syntmp-clauses-1842) ((lambda (syntmp-tmp-1844) ((lambda (syntmp-tmp-1845) (if syntmp-tmp-1845 (apply (lambda (syntmp-e1-1846 syntmp-e2-1847) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1846 syntmp-e2-1847))) syntmp-tmp-1845) ((lambda (syntmp-tmp-1849) (if syntmp-tmp-1849 (apply (lambda (syntmp-k-1850 syntmp-e1-1851 syntmp-e2-1852) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1850)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1851 syntmp-e2-1852)))) syntmp-tmp-1849) ((lambda (syntmp-_-1855) (syntax-error syntmp-x-1831)) syntmp-tmp-1844))) (syntax-dispatch syntmp-tmp-1844 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1844 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) any . each-any))))) syntmp-clause-1841) ((lambda (syntmp-tmp-1856) ((lambda (syntmp-rest-1857) ((lambda (syntmp-tmp-1858) ((lambda (syntmp-tmp-1859) (if syntmp-tmp-1859 (apply (lambda (syntmp-k-1860 syntmp-e1-1861 syntmp-e2-1862) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1860)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1861 syntmp-e2-1862)) syntmp-rest-1857)) syntmp-tmp-1859) ((lambda (syntmp-_-1865) (syntax-error syntmp-x-1831)) syntmp-tmp-1858))) (syntax-dispatch syntmp-tmp-1858 (quote (each-any any . each-any))))) syntmp-clause-1841)) syntmp-tmp-1856)) (syntmp-f-1840 (car syntmp-clauses-1842) (cdr syntmp-clauses-1842))))))) syntmp-tmp-1833) (syntax-error syntmp-tmp-1832))) (syntax-dispatch syntmp-tmp-1832 (quote (any any any . each-any))))) syntmp-x-1831))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1895) ((lambda (syntmp-tmp-1896) ((lambda (syntmp-tmp-1897) (if syntmp-tmp-1897 (apply (lambda (syntmp-_-1898 syntmp-e-1899) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1899)) (list (cons syntmp-_-1898 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e-1899 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))))))))) syntmp-tmp-1897) (syntax-error syntmp-tmp-1896))) (syntax-dispatch syntmp-tmp-1896 (quote (any any))))) syntmp-x-1895))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 096934217..a7c8c563f 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -334,14 +334,31 @@ (syntax-rules () ((_) (gensym)))) -;; wingo: FIXME: use modules natively? (define put-global-definition-hook - (lambda (symbol binding) - (putprop symbol '*sc-expander* binding))) + (lambda (symbol binding module) + (let* ((module (or module (warn "wha" symbol (current-module)))) + (v (or (module-variable module symbol) + (let ((v (make-variable sc-macro))) + (module-add! module symbol v) + v)))) + ;; Don't destroy Guile macros corresponding to primitive syntax + ;; when syncase boots. + (if (not (and (symbol-property symbol 'primitive-syntax) + (eq? module the-syncase-module))) + (variable-set! v sc-macro)) + ;; Properties are tied to variable objects + (set-object-property! v '*sc-expander* binding)))) (define get-global-definition-hook - (lambda (symbol) - (getprop symbol '*sc-expander*))) + (lambda (symbol module) + (let* ((module (or module (warn "wha" symbol (current-module)))) + (v (module-variable module symbol))) + (and v + (or (object-property v '*sc-expander*) + (and (variable-bound? v) + (macro? (variable-ref v)) + (macro-transformer (variable-ref v)) ;non-primitive + guile-macro)))))) ) @@ -374,12 +391,15 @@ (define-syntax build-global-reference (syntax-rules () ((_ source var mod) - (build-annotated source (make-module-ref #f var mod))))) + (build-annotated source + (make-module-ref (and mod (module-name mod)) var #f))))) (define-syntax build-global-assignment (syntax-rules () ((_ source var exp mod) - (build-annotated source `(set! ,(make-module-ref #f var mod) ,exp))))) + (build-annotated source + `(set! ,(make-module-ref (and mod (module-name mod)) var #f) + ,exp))))) (define-syntax build-global-definition (syntax-rules () @@ -558,16 +578,17 @@ ; although symbols are usually global, we check the environment first ; anyway because a temporary binding may have been established by ; fluid-let-syntax - (lambda (x r) + (lambda (x r mod) (cond ((assq x r) => cdr) ((symbol? x) - (or (get-global-definition-hook x) (make-binding 'global))) + (or (get-global-definition-hook x mod) (make-binding 'global))) (else (make-binding 'displaced-lexical))))) (define global-extend (lambda (type sym val) - (put-global-definition-hook sym (make-binding type val)))) + (put-global-definition-hook sym (make-binding type val) + (current-module)))) ;;; Conceptually, identifiers are always syntax objects. Internally, @@ -933,10 +954,10 @@ (cond ((symbol? e) (let* ((n (id-var-name e w)) - (b (lookup n r)) + (b (lookup n r mod)) (type (binding-type b))) (case type - ((lexical) (values type (binding-value b) e w s #f)) + ((lexical) (values type (binding-value b) e w s mod)) ((global) (values type n e w s mod)) ((macro) (syntax-type (chi-macro (binding-value b) e r w rib mod) @@ -946,7 +967,7 @@ (let ((first (car e))) (if (id? first) (let* ((n (id-var-name first w)) - (b (lookup n r)) + (b (lookup n r mod)) (type (binding-type b))) (case type ((lexical) @@ -973,12 +994,12 @@ (and (id? (syntax name)) (valid-bound-ids? (lambda-var-list (syntax args)))) ; need lambda here... - (values 'define-form (wrap (syntax name) w #f) + (values 'define-form (wrap (syntax name) w mod) (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) empty-wrap s mod)) ((_ name) (id? (syntax name)) - (values 'define-form (wrap (syntax name) w #f) + (values 'define-form (wrap (syntax name) w mod) (syntax (void)) empty-wrap s mod)))) ((define-syntax) @@ -995,7 +1016,7 @@ (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) - no-source rib (syntax-object-module e))) + no-source rib (or (syntax-object-module e) mod))) ((annotation? e) (syntax-type (annotation-expression e) r w (annotation-source e) rib mod)) ((self-evaluating? e) (values 'constant #f e w s mod)) @@ -1069,20 +1090,20 @@ (chi-void))))) ((define-form) (let* ((n (id-var-name value w)) - (type (binding-type (lookup n r)))) + (type (binding-type (lookup n r mod)))) (case type ((global) (eval-if-c&e m (build-global-definition s n (chi e r w mod) mod) mod)) ((displaced-lexical) - (syntax-error (wrap value w #f) "identifier out of context")) + (syntax-error (wrap value w mod) "identifier out of context")) (else (if (eq? type 'external-macro) (eval-if-c&e m (build-global-definition s n (chi e r w mod) mod) mod) - (syntax-error (wrap value w #f) + (syntax-error (wrap value w mod) "cannot define keyword at top level")))))) (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) @@ -1125,7 +1146,7 @@ (chi-sequence (syntax (e1 e2 ...)) r w s mod) (chi-void)))))) ((define-form define-syntax-form) - (syntax-error (wrap value w #f) "invalid context for definition of")) + (syntax-error (wrap value w mod) "invalid context for definition of")) ((syntax) (syntax-error (source-wrap e w s mod) "reference to pattern variable outside syntax form")) @@ -1466,7 +1487,7 @@ (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...))))) (for-each (lambda (id n) - (case (binding-type (lookup n r)) + (case (binding-type (lookup n r mod)) ((displaced-lexical) (syntax-error (source-wrap id w s mod) "identifier out of context")))) @@ -1497,10 +1518,10 @@ (global-extend 'core 'syntax (let () (define gen-syntax - (lambda (src e r maps ellipsis?) + (lambda (src e r maps ellipsis? mod) (if (id? e) (let ((label (id-var-name e empty-wrap))) - (let ((b (lookup label r))) + (let ((b (lookup label r mod))) (if (eq? (binding-type b) 'syntax) (call-with-values (lambda () @@ -1513,7 +1534,7 @@ (syntax-case e () ((dots e) (ellipsis? (syntax dots)) - (gen-syntax src (syntax e) r maps (lambda (x) #f))) + (gen-syntax src (syntax e) r maps (lambda (x) #f) mod)) ((x dots . y) ; this could be about a dozen lines of code, except that we ; choose to handle (syntax (x ... ...)) forms @@ -1523,7 +1544,7 @@ (call-with-values (lambda () (gen-syntax src (syntax x) r - (cons '() maps) ellipsis?)) + (cons '() maps) ellipsis? mod)) (lambda (x maps) (if (null? (car maps)) (syntax-error src @@ -1544,7 +1565,7 @@ (values (gen-mappend x (car maps)) (cdr maps)))))))) (_ (call-with-values - (lambda () (gen-syntax src y r maps ellipsis?)) + (lambda () (gen-syntax src y r maps ellipsis? mod)) (lambda (y maps) (call-with-values (lambda () (k maps)) @@ -1552,15 +1573,15 @@ (values (gen-append x y) maps))))))))) ((x . y) (call-with-values - (lambda () (gen-syntax src (syntax x) r maps ellipsis?)) + (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod)) (lambda (x maps) (call-with-values - (lambda () (gen-syntax src (syntax y) r maps ellipsis?)) + (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod)) (lambda (y maps) (values (gen-cons x y) maps)))))) (#(e1 e2 ...) (call-with-values (lambda () - (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?)) + (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod)) (lambda (e maps) (values (gen-vector e) maps)))) (_ (values `(quote ,e) maps)))))) @@ -1655,9 +1676,7 @@ (syntax-case e () ((_ x) (call-with-values - (lambda () (gen-syntax e (syntax x) r '() ellipsis?)) - ;; It doesn't seem we need `mod' here as `syntax' only - ;; references lexical vars and primitives. + (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod)) (lambda (e maps) (regen e)))) (_ (syntax-error e))))))) @@ -1728,13 +1747,13 @@ (id? (syntax id)) (let ((val (chi (syntax val) r w mod)) (n (id-var-name (syntax id) w))) - (let ((b (lookup n r))) + (let ((b (lookup n r mod))) (case (binding-type b) ((lexical) (build-lexical-assignment s (binding-value b) val)) ((global) (build-global-assignment s n val mod)) ((displaced-lexical) - (syntax-error (wrap (syntax id) w #f) + (syntax-error (wrap (syntax id) w mod) "identifier out of context")) (else (syntax-error (source-wrap e w s mod))))))) ((_ (getter arg ...) val) @@ -2253,4 +2272,3 @@ (syntax e)) ((_ x (... ...)) (syntax (e x (... ...))))))))))) - diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index ec6da56c8..ba9ed7114 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -35,21 +35,15 @@ -(define expansion-eval-closure (make-fluid)) -(define (current-eval-closure) - (or (fluid-ref expansion-eval-closure) - (module-eval-closure (current-module)))) - -(define (env->eval-closure env) - (and env (car (last-pair env)))) - (define (annotation? x) #f) (define sc-macro (procedure->memoizing-macro (lambda (exp env) - (with-fluids ((expansion-eval-closure (env->eval-closure env))) - (strip-expansion-structures (sc-expand exp)))))) + (save-module-excursion + (lambda () + (set-current-module (eval-closure-module (car (last-pair env)))) + (strip-expansion-structures (sc-expand exp))))))) ;;; Exported variables @@ -106,33 +100,6 @@ '()))) (define the-syncase-module (current-module)) -(define the-syncase-eval-closure (module-eval-closure the-syncase-module)) - -(fluid-set! expansion-eval-closure the-syncase-eval-closure) - -(define (putprop symbol key binding) - (let* ((eval-closure (current-eval-closure)) - ;; Why not simply do (eval-closure symbol #t)? - ;; Answer: That would overwrite imported bindings - (v (or (eval-closure symbol #f) ;lookup - (eval-closure symbol #t) ;create it locally - ))) - ;; Don't destroy Guile macros corresponding to - ;; primitive syntax when syncase boots. - (if (not (and (symbol-property symbol 'primitive-syntax) - (eq? eval-closure the-syncase-eval-closure))) - (variable-set! v sc-macro)) - ;; Properties are tied to variable objects - (set-object-property! v key binding))) - -(define (getprop symbol key) - (let* ((v ((current-eval-closure) symbol #f))) - (and v - (or (object-property v key) - (and (variable-bound? v) - (macro? (variable-ref v)) - (macro-transformer (variable-ref v)) ;non-primitive - guile-macro))))) (define guile-macro (cons 'external-macro @@ -141,15 +108,14 @@ (if (symbol? e) ;; pass the expression through e - (let* ((eval-closure (current-eval-closure)) - (m (variable-ref (eval-closure (car e) #f)))) + (let ((m (module-ref mod (car e)))) (if (eq? (macro-type m) 'syntax) ;; pass the expression through e ;; perform Guile macro transform (let ((e ((macro-transformer m) (strip-expansion-structures e) - (append r (list eval-closure))))) + (append r (list (module-eval-closure mod)))))) (if (variable? e) e (if (null? r) @@ -208,18 +174,13 @@ (set! old-debug (debug-options)) (set! old-read (read-options))) (lambda () - (debug-disable 'debug 'procnames) - (read-disable 'positions) + ;(debug-disable 'debug 'procnames) + ;(read-disable 'positions) (load-from-path "ice-9/psyntax-pp")) (lambda () (debug-options old-debug) (read-options old-read)))) - -;;; The following lines are necessary only if we start making changes -;; (use-syntax sc-expand) -;; (load-from-path "ice-9/psyntax") - (define internal-eval (nested-ref the-scm-module '(%app modules guile eval))) (define (eval x environment) @@ -237,9 +198,7 @@ '(define)))) (define (syncase exp) - (with-fluids ((expansion-eval-closure - (module-eval-closure (current-module)))) - (strip-expansion-structures (sc-expand exp)))) + (strip-expansion-structures (sc-expand exp))) (set-module-transformer! the-syncase-module syncase) @@ -249,5 +208,3 @@ (begin ;(eval-case ((load-toplevel) (export-syntax name))) (define-syntax name rules ...))))) - -(fluid-set! expansion-eval-closure #f) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index d622c277b..bd4fc2cfe 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -115,13 +115,11 @@ ((eq? val sc-macro) ;; syncase! - (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure)) - (sc-expand3 (@@ (ice-9 syncase) sc-expand3))) + (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3))) (lambda (env loc exp) (retrans - (with-fluids ((eec (module-eval-closure mod))) - (strip-expansion-structures - (sc-expand3 exp 'c '(compile load eval)))))))) + (strip-expansion-structures + (sc-expand3 exp 'c '(compile load eval))))))) ((primitive-macro? val) (syntax-error #f "unhandled primitive macro" head)) From d2b61fe0ffd15cce274d9284cd88c9bb9bd78126 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 31 Mar 2009 00:00:04 -0700 Subject: [PATCH 036/375] houston, we have hygiene * module/ice-9/expand-support.scm (strip-expansion-structures): Enable @/@@ substitution. * module/ice-9/psyntax-pp.scm: Recompile. * module/ice-9/psyntax.scm: Since syntax objects are quotable, make the module field the module name, not the module itself. Scope the operand of global calls appropriately. Thread modules through syntax-dispatch destructuring. Houston, we have hygiene. * module/ice-9/syncase.scm: Adapt to module / module-name changes. --- module/ice-9/expand-support.scm | 3 +- module/ice-9/psyntax-pp.scm | 9481 ++++++++++++++++++++++++++++++- module/ice-9/psyntax.scm | 81 +- module/ice-9/syncase.scm | 5 +- 4 files changed, 9521 insertions(+), 49 deletions(-) diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm index fc9290050..63ea2d2b1 100644 --- a/module/ice-9/expand-support.scm +++ b/module/ice-9/expand-support.scm @@ -151,8 +151,7 @@ ((module-ref? e) (if (and (module-ref-modname e) (not (eq? (module-ref-modname e) - (module-name (current-module)))) - #f) + (module-name (current-module))))) `(,(if (module-ref-public? e) '@ '@@) ,(module-ref-modname e) ,(module-ref-symbol e)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 436361644..0138c53a7 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,9470 @@ -(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (procedure-module syntmp-p-688)))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (and syntmp-mod-722 (module-name syntmp-mod-722)) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref (and syntmp-mod-722 (module-name syntmp-mod-722)) syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-724) ((lambda (syntmp-tmp-725) (if syntmp-tmp-725 (apply (lambda (syntmp-_-726 syntmp-e1-727 syntmp-e2-728) (syntmp-chi-sequence-147 (cons syntmp-e1-727 syntmp-e2-728) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-725) (syntax-error syntmp-tmp-724))) (syntax-dispatch syntmp-tmp-724 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-730) ((lambda (syntmp-tmp-731) (if syntmp-tmp-731 (apply (lambda (syntmp-_-732 syntmp-x-733 syntmp-e1-734 syntmp-e2-735) (let ((syntmp-when-list-736 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-733 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-736) (syntmp-chi-sequence-147 (cons syntmp-e1-734 syntmp-e2-735) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-731) (syntax-error syntmp-tmp-730))) (syntax-dispatch syntmp-tmp-730 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722)))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-739 syntmp-r-740 syntmp-w-741 syntmp-mod-742) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-739 syntmp-r-740 syntmp-w-741 #f #f syntmp-mod-742)) (lambda (syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-w-746 syntmp-s-747 syntmp-mod-748) (syntmp-chi-expr-154 syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-r-740 syntmp-w-746 syntmp-s-747 syntmp-mod-748))))) (syntmp-chi-top-152 (lambda (syntmp-e-749 syntmp-r-750 syntmp-w-751 syntmp-m-752 syntmp-esew-753 syntmp-mod-754) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-749 syntmp-r-750 syntmp-w-751 #f #f syntmp-mod-754)) (lambda (syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-w-772 syntmp-s-773 syntmp-mod-774) (let ((syntmp-t-775 syntmp-type-769)) (if (memv syntmp-t-775 (quote (begin-form))) ((lambda (syntmp-tmp-776) ((lambda (syntmp-tmp-777) (if syntmp-tmp-777 (apply (lambda (syntmp-_-778) (syntmp-chi-void-161)) syntmp-tmp-777) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-e1-781 syntmp-e2-782) (syntmp-chi-top-sequence-148 (cons syntmp-e1-781 syntmp-e2-782) syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-m-752 syntmp-esew-753 syntmp-mod-774)) syntmp-tmp-779) (syntax-error syntmp-tmp-776))) (syntax-dispatch syntmp-tmp-776 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-776 (quote (any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774 (lambda (syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-mod-788) (syntmp-chi-top-sequence-148 syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-m-752 syntmp-esew-753 syntmp-mod-788))) (if (memv syntmp-t-775 (quote (eval-when-form))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-x-792 syntmp-e1-793 syntmp-e2-794) (let ((syntmp-when-list-795 (syntmp-chi-when-list-150 syntmp-e-771 syntmp-x-792 syntmp-w-772)) (syntmp-body-796 (cons syntmp-e1-793 syntmp-e2-794))) (cond ((eq? syntmp-m-752 (quote e)) (if (memq (quote eval) syntmp-when-list-795) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-795) (if (or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c&e) (quote (compile load)) syntmp-mod-774) (if (memq syntmp-m-752 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c) (quote (load)) syntmp-mod-774) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) syntmp-mod-774) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-790) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any each-any any . each-any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (define-syntax-form))) (let ((syntmp-n-799 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772)) (syntmp-r-800 (syntmp-macros-only-env-113 syntmp-r-750))) (let ((syntmp-t-801 syntmp-m-752)) (if (memv syntmp-t-801 (quote (c))) (if (memq (quote compile) syntmp-esew-753) (let ((syntmp-e-802 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-802 syntmp-mod-774) (if (memq (quote load) syntmp-esew-753) syntmp-e-802 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-753) (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) (syntmp-chi-void-161))) (if (memv syntmp-t-801 (quote (c&e))) (let ((syntmp-e-803 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-803 syntmp-mod-774) syntmp-e-803)) (begin (if (memq (quote eval) syntmp-esew-753) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) syntmp-mod-774)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-775 (quote (define-form))) (let ((syntmp-n-804 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772))) (let ((syntmp-type-805 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-804 syntmp-r-750 syntmp-mod-774)))) (let ((syntmp-t-806 syntmp-type-805)) (if (memv syntmp-t-806 (quote (global))) (let ((syntmp-x-807 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-807 syntmp-mod-774)) syntmp-x-807)) (if (memv syntmp-t-806 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "identifier out of context") (if (eq? syntmp-type-805 (quote external-macro)) (let ((syntmp-x-808 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-808 syntmp-mod-774)) syntmp-x-808)) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "cannot define keyword at top level"))))))) (let ((syntmp-x-809 (syntmp-chi-expr-154 syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-774)) syntmp-x-809)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (cond ((symbol? syntmp-e-810) (let ((syntmp-n-816 (syntmp-id-var-name-139 syntmp-e-810 syntmp-w-812))) (let ((syntmp-b-817 (syntmp-lookup-114 syntmp-n-816 syntmp-r-811 syntmp-mod-815))) (let ((syntmp-type-818 (syntmp-binding-type-109 syntmp-b-817))) (let ((syntmp-t-819 syntmp-type-818)) (if (memv syntmp-t-819 (quote (lexical))) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (global))) (values syntmp-type-818 syntmp-n-816 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))))))) ((pair? syntmp-e-810) (let ((syntmp-first-820 (car syntmp-e-810))) (if (syntmp-id?-117 syntmp-first-820) (let ((syntmp-n-821 (syntmp-id-var-name-139 syntmp-first-820 syntmp-w-812))) (let ((syntmp-b-822 (syntmp-lookup-114 syntmp-n-821 syntmp-r-811 syntmp-mod-815))) (let ((syntmp-type-823 (syntmp-binding-type-109 syntmp-b-822))) (let ((syntmp-t-824 syntmp-type-823)) (if (memv syntmp-t-824 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (global))) (values (quote global-call) syntmp-n-821 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (if (memv syntmp-t-824 (quote (core external-macro))) (values syntmp-type-823 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (begin))) (values (quote begin-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (define))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-117 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-form) syntmp-name-831 syntmp-val-832 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-826) ((lambda (syntmp-tmp-833) (if (if syntmp-tmp-833 (apply (lambda (syntmp-_-834 syntmp-name-835 syntmp-args-836 syntmp-e1-837 syntmp-e2-838) (and (syntmp-id?-117 syntmp-name-835) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-836)))) syntmp-tmp-833) #f) (apply (lambda (syntmp-_-839 syntmp-name-840 syntmp-args-841 syntmp-e1-842 syntmp-e2-843) (values (quote define-form) (syntmp-wrap-145 syntmp-name-840 syntmp-w-812 syntmp-mod-815) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) (syntmp-wrap-145 (cons syntmp-args-841 (cons syntmp-e1-842 syntmp-e2-843)) syntmp-w-812 syntmp-mod-815)) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-833) ((lambda (syntmp-tmp-845) (if (if syntmp-tmp-845 (apply (lambda (syntmp-_-846 syntmp-name-847) (syntmp-id?-117 syntmp-name-847)) syntmp-tmp-845) #f) (apply (lambda (syntmp-_-848 syntmp-name-849) (values (quote define-form) (syntmp-wrap-145 syntmp-name-849 syntmp-w-812 syntmp-mod-815) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-845) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-810) (if (memv syntmp-t-824 (quote (define-syntax))) ((lambda (syntmp-tmp-850) ((lambda (syntmp-tmp-851) (if (if syntmp-tmp-851 (apply (lambda (syntmp-_-852 syntmp-name-853 syntmp-val-854) (syntmp-id?-117 syntmp-name-853)) syntmp-tmp-851) #f) (apply (lambda (syntmp-_-855 syntmp-name-856 syntmp-val-857) (values (quote define-syntax-form) syntmp-name-856 syntmp-val-857 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-851) (syntax-error syntmp-tmp-850))) (syntax-dispatch syntmp-tmp-850 (quote (any any any))))) syntmp-e-810) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))))))))))))) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))) ((syntmp-syntax-object?-101 syntmp-e-810) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-810) syntmp-r-811 (syntmp-join-wraps-136 syntmp-w-812 (syntmp-syntax-object-wrap-103 syntmp-e-810)) #f syntmp-rib-814 (or (syntmp-syntax-object-module-104 syntmp-e-810) syntmp-mod-815))) ((annotation? syntmp-e-810) (syntmp-syntax-type-151 (annotation-expression syntmp-e-810) syntmp-r-811 syntmp-w-812 (annotation-source syntmp-e-810) syntmp-rib-814 syntmp-mod-815)) ((self-evaluating? syntmp-e-810) (values (quote constant) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) (else (values (quote other) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-858 syntmp-when-list-859 syntmp-w-860) (let syntmp-f-861 ((syntmp-when-list-862 syntmp-when-list-859) (syntmp-situations-863 (quote ()))) (if (null? syntmp-when-list-862) syntmp-situations-863 (syntmp-f-861 (cdr syntmp-when-list-862) (cons (let ((syntmp-x-864 (car syntmp-when-list-862))) (cond ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-864 syntmp-w-860 #f) "invalid eval-when situation")))) syntmp-situations-863)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-865 syntmp-e-866) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-865) syntmp-e-866)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-867 syntmp-r-868 syntmp-w-869 syntmp-s-870 syntmp-m-871 syntmp-esew-872 syntmp-mod-873) (syntmp-build-sequence-96 syntmp-s-870 (let syntmp-dobody-874 ((syntmp-body-875 syntmp-body-867) (syntmp-r-876 syntmp-r-868) (syntmp-w-877 syntmp-w-869) (syntmp-m-878 syntmp-m-871) (syntmp-esew-879 syntmp-esew-872) (syntmp-mod-880 syntmp-mod-873)) (if (null? syntmp-body-875) (quote ()) (let ((syntmp-first-881 (syntmp-chi-top-152 (car syntmp-body-875) syntmp-r-876 syntmp-w-877 syntmp-m-878 syntmp-esew-879 syntmp-mod-880))) (cons syntmp-first-881 (syntmp-dobody-874 (cdr syntmp-body-875) syntmp-r-876 syntmp-w-877 syntmp-m-878 syntmp-esew-879 syntmp-mod-880)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-882 syntmp-r-883 syntmp-w-884 syntmp-s-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-885 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-882) (syntmp-r-889 syntmp-r-883) (syntmp-w-890 syntmp-w-884) (syntmp-mod-891 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-892 (syntmp-chi-153 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-mod-891))) (cons syntmp-first-892 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-mod-891)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-893 syntmp-w-894 syntmp-s-895 syntmp-defmod-896) (syntmp-wrap-145 (if syntmp-s-895 (make-annotation syntmp-x-893 syntmp-s-895 #f) syntmp-x-893) syntmp-w-894 syntmp-defmod-896))) (syntmp-wrap-145 (lambda (syntmp-x-897 syntmp-w-898 syntmp-defmod-899) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-898)) (null? (syntmp-wrap-subst-121 syntmp-w-898))) syntmp-x-897) ((syntmp-syntax-object?-101 syntmp-x-897) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-897) (syntmp-join-wraps-136 syntmp-w-898 (syntmp-syntax-object-wrap-103 syntmp-x-897)) (syntmp-syntax-object-module-104 syntmp-x-897))) ((null? syntmp-x-897) syntmp-x-897) (else (syntmp-make-syntax-object-100 syntmp-x-897 syntmp-w-898 syntmp-defmod-899))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-900 syntmp-list-901) (and (not (null? syntmp-list-901)) (or (syntmp-bound-id=?-141 syntmp-x-900 (car syntmp-list-901)) (syntmp-bound-id-member?-144 syntmp-x-900 (cdr syntmp-list-901)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-902) (let syntmp-distinct?-903 ((syntmp-ids-904 syntmp-ids-902)) (or (null? syntmp-ids-904) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-904) (cdr syntmp-ids-904))) (syntmp-distinct?-903 (cdr syntmp-ids-904))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-905) (and (let syntmp-all-ids?-906 ((syntmp-ids-907 syntmp-ids-905)) (or (null? syntmp-ids-907) (and (syntmp-id?-117 (car syntmp-ids-907)) (syntmp-all-ids?-906 (cdr syntmp-ids-907))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-905)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-908 syntmp-j-909) (if (and (syntmp-syntax-object?-101 syntmp-i-908) (syntmp-syntax-object?-101 syntmp-j-909)) (and (eq? (let ((syntmp-e-910 (syntmp-syntax-object-expression-102 syntmp-i-908))) (if (annotation? syntmp-e-910) (annotation-expression syntmp-e-910) syntmp-e-910)) (let ((syntmp-e-911 (syntmp-syntax-object-expression-102 syntmp-j-909))) (if (annotation? syntmp-e-911) (annotation-expression syntmp-e-911) syntmp-e-911))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-908)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-909)))) (eq? (let ((syntmp-e-912 syntmp-i-908)) (if (annotation? syntmp-e-912) (annotation-expression syntmp-e-912) syntmp-e-912)) (let ((syntmp-e-913 syntmp-j-909)) (if (annotation? syntmp-e-913) (annotation-expression syntmp-e-913) syntmp-e-913)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-914 syntmp-j-915) (and (eq? (let ((syntmp-x-916 syntmp-i-914)) (let ((syntmp-e-917 (if (syntmp-syntax-object?-101 syntmp-x-916) (syntmp-syntax-object-expression-102 syntmp-x-916) syntmp-x-916))) (if (annotation? syntmp-e-917) (annotation-expression syntmp-e-917) syntmp-e-917))) (let ((syntmp-x-918 syntmp-j-915)) (let ((syntmp-e-919 (if (syntmp-syntax-object?-101 syntmp-x-918) (syntmp-syntax-object-expression-102 syntmp-x-918) syntmp-x-918))) (if (annotation? syntmp-e-919) (annotation-expression syntmp-e-919) syntmp-e-919)))) (eq? (syntmp-id-var-name-139 syntmp-i-914 (quote (()))) (syntmp-id-var-name-139 syntmp-j-915 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-920 syntmp-w-921) (letrec ((syntmp-search-vector-rib-924 (lambda (syntmp-sym-935 syntmp-subst-936 syntmp-marks-937 syntmp-symnames-938 syntmp-ribcage-939) (let ((syntmp-n-940 (vector-length syntmp-symnames-938))) (let syntmp-f-941 ((syntmp-i-942 0)) (cond ((syntmp-fx=-87 syntmp-i-942 syntmp-n-940) (syntmp-search-922 syntmp-sym-935 (cdr syntmp-subst-936) syntmp-marks-937)) ((and (eq? (vector-ref syntmp-symnames-938 syntmp-i-942) syntmp-sym-935) (syntmp-same-marks?-138 syntmp-marks-937 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-939) syntmp-i-942))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-939) syntmp-i-942) syntmp-marks-937)) (else (syntmp-f-941 (syntmp-fx+-85 syntmp-i-942 1)))))))) (syntmp-search-list-rib-923 (lambda (syntmp-sym-943 syntmp-subst-944 syntmp-marks-945 syntmp-symnames-946 syntmp-ribcage-947) (let syntmp-f-948 ((syntmp-symnames-949 syntmp-symnames-946) (syntmp-i-950 0)) (cond ((null? syntmp-symnames-949) (syntmp-search-922 syntmp-sym-943 (cdr syntmp-subst-944) syntmp-marks-945)) ((and (eq? (car syntmp-symnames-949) syntmp-sym-943) (syntmp-same-marks?-138 syntmp-marks-945 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-947) syntmp-i-950))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-947) syntmp-i-950) syntmp-marks-945)) (else (syntmp-f-948 (cdr syntmp-symnames-949) (syntmp-fx+-85 syntmp-i-950 1))))))) (syntmp-search-922 (lambda (syntmp-sym-951 syntmp-subst-952 syntmp-marks-953) (if (null? syntmp-subst-952) (values #f syntmp-marks-953) (let ((syntmp-fst-954 (car syntmp-subst-952))) (if (eq? syntmp-fst-954 (quote shift)) (syntmp-search-922 syntmp-sym-951 (cdr syntmp-subst-952) (cdr syntmp-marks-953)) (let ((syntmp-symnames-955 (syntmp-ribcage-symnames-126 syntmp-fst-954))) (if (vector? syntmp-symnames-955) (syntmp-search-vector-rib-924 syntmp-sym-951 syntmp-subst-952 syntmp-marks-953 syntmp-symnames-955 syntmp-fst-954) (syntmp-search-list-rib-923 syntmp-sym-951 syntmp-subst-952 syntmp-marks-953 syntmp-symnames-955 syntmp-fst-954))))))))) (cond ((symbol? syntmp-id-920) (or (call-with-values (lambda () (syntmp-search-922 syntmp-id-920 (syntmp-wrap-subst-121 syntmp-w-921) (syntmp-wrap-marks-120 syntmp-w-921))) (lambda (syntmp-x-957 . syntmp-ignore-956) syntmp-x-957)) syntmp-id-920)) ((syntmp-syntax-object?-101 syntmp-id-920) (let ((syntmp-id-958 (let ((syntmp-e-960 (syntmp-syntax-object-expression-102 syntmp-id-920))) (if (annotation? syntmp-e-960) (annotation-expression syntmp-e-960) syntmp-e-960))) (syntmp-w1-959 (syntmp-syntax-object-wrap-103 syntmp-id-920))) (let ((syntmp-marks-961 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-921) (syntmp-wrap-marks-120 syntmp-w1-959)))) (call-with-values (lambda () (syntmp-search-922 syntmp-id-958 (syntmp-wrap-subst-121 syntmp-w-921) syntmp-marks-961)) (lambda (syntmp-new-id-962 syntmp-marks-963) (or syntmp-new-id-962 (call-with-values (lambda () (syntmp-search-922 syntmp-id-958 (syntmp-wrap-subst-121 syntmp-w1-959) syntmp-marks-963)) (lambda (syntmp-x-965 . syntmp-ignore-964) syntmp-x-965)) syntmp-id-958)))))) ((annotation? syntmp-id-920) (let ((syntmp-id-966 (let ((syntmp-e-967 syntmp-id-920)) (if (annotation? syntmp-e-967) (annotation-expression syntmp-e-967) syntmp-e-967)))) (or (call-with-values (lambda () (syntmp-search-922 syntmp-id-966 (syntmp-wrap-subst-121 syntmp-w-921) (syntmp-wrap-marks-120 syntmp-w-921))) (lambda (syntmp-x-969 . syntmp-ignore-968) syntmp-x-969)) syntmp-id-966))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-920)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-970 syntmp-y-971) (or (eq? syntmp-x-970 syntmp-y-971) (and (not (null? syntmp-x-970)) (not (null? syntmp-y-971)) (eq? (car syntmp-x-970) (car syntmp-y-971)) (syntmp-same-marks?-138 (cdr syntmp-x-970) (cdr syntmp-y-971)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-972 syntmp-m2-973) (syntmp-smart-append-135 syntmp-m1-972 syntmp-m2-973))) (syntmp-join-wraps-136 (lambda (syntmp-w1-974 syntmp-w2-975) (let ((syntmp-m1-976 (syntmp-wrap-marks-120 syntmp-w1-974)) (syntmp-s1-977 (syntmp-wrap-subst-121 syntmp-w1-974))) (if (null? syntmp-m1-976) (if (null? syntmp-s1-977) syntmp-w2-975 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-975) (syntmp-smart-append-135 syntmp-s1-977 (syntmp-wrap-subst-121 syntmp-w2-975)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-976 (syntmp-wrap-marks-120 syntmp-w2-975)) (syntmp-smart-append-135 syntmp-s1-977 (syntmp-wrap-subst-121 syntmp-w2-975))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-978 syntmp-m2-979) (if (null? syntmp-m2-979) syntmp-m1-978 (append syntmp-m1-978 syntmp-m2-979)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-980 syntmp-labels-981 syntmp-w-982) (if (null? syntmp-ids-980) syntmp-w-982 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-982) (cons (let ((syntmp-labelvec-983 (list->vector syntmp-labels-981))) (let ((syntmp-n-984 (vector-length syntmp-labelvec-983))) (let ((syntmp-symnamevec-985 (make-vector syntmp-n-984)) (syntmp-marksvec-986 (make-vector syntmp-n-984))) (begin (let syntmp-f-987 ((syntmp-ids-988 syntmp-ids-980) (syntmp-i-989 0)) (if (not (null? syntmp-ids-988)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-988) syntmp-w-982)) (lambda (syntmp-symname-990 syntmp-marks-991) (begin (vector-set! syntmp-symnamevec-985 syntmp-i-989 syntmp-symname-990) (vector-set! syntmp-marksvec-986 syntmp-i-989 syntmp-marks-991) (syntmp-f-987 (cdr syntmp-ids-988) (syntmp-fx+-85 syntmp-i-989 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-985 syntmp-marksvec-986 syntmp-labelvec-983))))) (syntmp-wrap-subst-121 syntmp-w-982)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-992 syntmp-id-993 syntmp-label-994) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-992 (cons (let ((syntmp-e-995 (syntmp-syntax-object-expression-102 syntmp-id-993))) (if (annotation? syntmp-e-995) (annotation-expression syntmp-e-995) syntmp-e-995)) (syntmp-ribcage-symnames-126 syntmp-ribcage-992))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-992 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-993)) (syntmp-ribcage-marks-127 syntmp-ribcage-992))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-992 (cons syntmp-label-994 (syntmp-ribcage-labels-128 syntmp-ribcage-992)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-996) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-996)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-996))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-997 syntmp-update-998) (vector-set! syntmp-x-997 3 syntmp-update-998))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-999 syntmp-update-1000) (vector-set! syntmp-x-999 2 syntmp-update-1000))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1001 syntmp-update-1002) (vector-set! syntmp-x-1001 1 syntmp-update-1002))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1003) (vector-ref syntmp-x-1003 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1004) (vector-ref syntmp-x-1004 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1005) (vector-ref syntmp-x-1005 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1006) (and (vector? syntmp-x-1006) (= (vector-length syntmp-x-1006) 4) (eq? (vector-ref syntmp-x-1006 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1007 syntmp-marks-1008 syntmp-labels-1009) (vector (quote ribcage) syntmp-symnames-1007 syntmp-marks-1008 syntmp-labels-1009))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1010) (if (null? syntmp-ls-1010) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1010)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1011 syntmp-w-1012) (if (syntmp-syntax-object?-101 syntmp-x-1011) (values (let ((syntmp-e-1013 (syntmp-syntax-object-expression-102 syntmp-x-1011))) (if (annotation? syntmp-e-1013) (annotation-expression syntmp-e-1013) syntmp-e-1013)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1012) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1011)))) (values (let ((syntmp-e-1014 syntmp-x-1011)) (if (annotation? syntmp-e-1014) (annotation-expression syntmp-e-1014) syntmp-e-1014)) (syntmp-wrap-marks-120 syntmp-w-1012))))) (syntmp-id?-117 (lambda (syntmp-x-1015) (cond ((symbol? syntmp-x-1015) #t) ((syntmp-syntax-object?-101 syntmp-x-1015) (symbol? (let ((syntmp-e-1016 (syntmp-syntax-object-expression-102 syntmp-x-1015))) (if (annotation? syntmp-e-1016) (annotation-expression syntmp-e-1016) syntmp-e-1016)))) ((annotation? syntmp-x-1015) (symbol? (annotation-expression syntmp-x-1015))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1017) (and (syntmp-syntax-object?-101 syntmp-x-1017) (symbol? (let ((syntmp-e-1018 (syntmp-syntax-object-expression-102 syntmp-x-1017))) (if (annotation? syntmp-e-1018) (annotation-expression syntmp-e-1018) syntmp-e-1018)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1019 syntmp-sym-1020 syntmp-val-1021) (syntmp-put-global-definition-hook-92 syntmp-sym-1020 (cons syntmp-type-1019 syntmp-val-1021) (current-module)))) (syntmp-lookup-114 (lambda (syntmp-x-1022 syntmp-r-1023 syntmp-mod-1024) (cond ((assq syntmp-x-1022 syntmp-r-1023) => cdr) ((symbol? syntmp-x-1022) (or (syntmp-get-global-definition-hook-93 syntmp-x-1022 syntmp-mod-1024) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1025) (if (null? syntmp-r-1025) (quote ()) (let ((syntmp-a-1026 (car syntmp-r-1025))) (if (eq? (cadr syntmp-a-1026) (quote macro)) (cons syntmp-a-1026 (syntmp-macros-only-env-113 (cdr syntmp-r-1025))) (syntmp-macros-only-env-113 (cdr syntmp-r-1025))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1027 syntmp-vars-1028 syntmp-r-1029) (if (null? syntmp-labels-1027) syntmp-r-1029 (syntmp-extend-var-env-112 (cdr syntmp-labels-1027) (cdr syntmp-vars-1028) (cons (cons (car syntmp-labels-1027) (cons (quote lexical) (car syntmp-vars-1028))) syntmp-r-1029))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1030 syntmp-bindings-1031 syntmp-r-1032) (if (null? syntmp-labels-1030) syntmp-r-1032 (syntmp-extend-env-111 (cdr syntmp-labels-1030) (cdr syntmp-bindings-1031) (cons (cons (car syntmp-labels-1030) (car syntmp-bindings-1031)) syntmp-r-1032))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1033) (cond ((annotation? syntmp-x-1033) (annotation-source syntmp-x-1033)) ((syntmp-syntax-object?-101 syntmp-x-1033) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1033))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1034 syntmp-update-1035) (vector-set! syntmp-x-1034 3 syntmp-update-1035))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1036 syntmp-update-1037) (vector-set! syntmp-x-1036 2 syntmp-update-1037))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1038 syntmp-update-1039) (vector-set! syntmp-x-1038 1 syntmp-update-1039))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1040) (vector-ref syntmp-x-1040 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1041) (vector-ref syntmp-x-1041 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1042) (vector-ref syntmp-x-1042 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1043) (and (vector? syntmp-x-1043) (= (vector-length syntmp-x-1043) 4) (eq? (vector-ref syntmp-x-1043 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1044 syntmp-wrap-1045 syntmp-module-1046) (vector (quote syntax-object) syntmp-expression-1044 syntmp-wrap-1045 syntmp-module-1046))) (syntmp-build-letrec-99 (lambda (syntmp-src-1047 syntmp-vars-1048 syntmp-val-exps-1049 syntmp-body-exp-1050) (if (null? syntmp-vars-1048) (syntmp-build-annotated-94 syntmp-src-1047 syntmp-body-exp-1050) (syntmp-build-annotated-94 syntmp-src-1047 (list (quote letrec) (map list syntmp-vars-1048 syntmp-val-exps-1049) syntmp-body-exp-1050))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1051 syntmp-vars-1052 syntmp-val-exps-1053 syntmp-body-exp-1054) (if (null? syntmp-vars-1052) (syntmp-build-annotated-94 syntmp-src-1051 syntmp-body-exp-1054) (syntmp-build-annotated-94 syntmp-src-1051 (list (quote let) (car syntmp-vars-1052) (map list (cdr syntmp-vars-1052) syntmp-val-exps-1053) syntmp-body-exp-1054))))) (syntmp-build-let-97 (lambda (syntmp-src-1055 syntmp-vars-1056 syntmp-val-exps-1057 syntmp-body-exp-1058) (if (null? syntmp-vars-1056) (syntmp-build-annotated-94 syntmp-src-1055 syntmp-body-exp-1058) (syntmp-build-annotated-94 syntmp-src-1055 (list (quote let) (map list syntmp-vars-1056 syntmp-val-exps-1057) syntmp-body-exp-1058))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1059 syntmp-exps-1060) (if (null? (cdr syntmp-exps-1060)) (syntmp-build-annotated-94 syntmp-src-1059 (car syntmp-exps-1060)) (syntmp-build-annotated-94 syntmp-src-1059 (cons (quote begin) syntmp-exps-1060))))) (syntmp-build-data-95 (lambda (syntmp-src-1061 syntmp-exp-1062) (if (and (self-evaluating? syntmp-exp-1062) (not (vector? syntmp-exp-1062))) (syntmp-build-annotated-94 syntmp-src-1061 syntmp-exp-1062) (syntmp-build-annotated-94 syntmp-src-1061 (list (quote quote) syntmp-exp-1062))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1063 syntmp-exp-1064) (if (and syntmp-src-1063 (not (annotation? syntmp-exp-1064))) (make-annotation syntmp-exp-1064 syntmp-src-1063 #t) syntmp-exp-1064))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1065 syntmp-module-1066) (let ((syntmp-module-1067 (or syntmp-module-1066 (warn "wha" syntmp-symbol-1065 (current-module))))) (let ((syntmp-v-1068 (module-variable syntmp-module-1067 syntmp-symbol-1065))) (and syntmp-v-1068 (or (object-property syntmp-v-1068 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1068) (macro? (variable-ref syntmp-v-1068)) (macro-transformer (variable-ref syntmp-v-1068)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1069 syntmp-binding-1070 syntmp-module-1071) (let ((syntmp-module-1072 (or syntmp-module-1071 (warn "wha" syntmp-symbol-1069 (current-module))))) (let ((syntmp-v-1073 (or (module-variable syntmp-module-1072 syntmp-symbol-1069) (let ((syntmp-v-1074 (make-variable sc-macro))) (begin (module-add! syntmp-module-1072 syntmp-symbol-1069 syntmp-v-1074) syntmp-v-1074))))) (begin (if (not (and (symbol-property syntmp-symbol-1069 (quote primitive-syntax)) (eq? syntmp-module-1072 the-syncase-module))) (variable-set! syntmp-v-1073 sc-macro)) (set-object-property! syntmp-v-1073 (quote *sc-expander*) syntmp-binding-1070)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1075 syntmp-why-1076 syntmp-what-1077) (error syntmp-who-1075 "~a ~s" syntmp-why-1076 syntmp-what-1077))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1078 syntmp-mod-1079) (eval (list syntmp-noexpand-84 syntmp-x-1078) (or syntmp-mod-1079 (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1080 syntmp-mod-1081) (eval (list syntmp-noexpand-84 syntmp-x-1080) (or syntmp-mod-1081 (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1082 syntmp-r-1083 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086) ((lambda (syntmp-tmp-1087) ((lambda (syntmp-tmp-1088) (if (if syntmp-tmp-1088 (apply (lambda (syntmp-_-1089 syntmp-var-1090 syntmp-val-1091 syntmp-e1-1092 syntmp-e2-1093) (syntmp-valid-bound-ids?-142 syntmp-var-1090)) syntmp-tmp-1088) #f) (apply (lambda (syntmp-_-1095 syntmp-var-1096 syntmp-val-1097 syntmp-e1-1098 syntmp-e2-1099) (let ((syntmp-names-1100 (map (lambda (syntmp-x-1101) (syntmp-id-var-name-139 syntmp-x-1101 syntmp-w-1084)) syntmp-var-1096))) (begin (for-each (lambda (syntmp-id-1103 syntmp-n-1104) (let ((syntmp-t-1105 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1104 syntmp-r-1083 syntmp-mod-1086)))) (if (memv syntmp-t-1105 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1103 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086) "identifier out of context")))) syntmp-var-1096 syntmp-names-1100) (syntmp-chi-body-157 (cons syntmp-e1-1098 syntmp-e2-1099) (syntmp-source-wrap-146 syntmp-e-1082 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086) (syntmp-extend-env-111 syntmp-names-1100 (let ((syntmp-trans-r-1108 (syntmp-macros-only-env-113 syntmp-r-1083))) (map (lambda (syntmp-x-1109) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1109 syntmp-trans-r-1108 syntmp-w-1084 syntmp-mod-1086) syntmp-mod-1086))) syntmp-val-1097)) syntmp-r-1083) syntmp-w-1084 syntmp-mod-1086)))) syntmp-tmp-1088) ((lambda (syntmp-_-1111) (syntax-error (syntmp-source-wrap-146 syntmp-e-1082 syntmp-w-1084 syntmp-s-1085 syntmp-mod-1086))) syntmp-tmp-1087))) (syntax-dispatch syntmp-tmp-1087 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1082))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1112 syntmp-r-1113 syntmp-w-1114 syntmp-s-1115 syntmp-mod-1116) ((lambda (syntmp-tmp-1117) ((lambda (syntmp-tmp-1118) (if syntmp-tmp-1118 (apply (lambda (syntmp-_-1119 syntmp-e-1120) (syntmp-build-data-95 syntmp-s-1115 (syntmp-strip-164 syntmp-e-1120 syntmp-w-1114))) syntmp-tmp-1118) ((lambda (syntmp-_-1121) (syntax-error (syntmp-source-wrap-146 syntmp-e-1112 syntmp-w-1114 syntmp-s-1115 syntmp-mod-1116))) syntmp-tmp-1117))) (syntax-dispatch syntmp-tmp-1117 (quote (any any))))) syntmp-e-1112))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1129 (lambda (syntmp-x-1130) (let ((syntmp-t-1131 (car syntmp-x-1130))) (if (memv syntmp-t-1131 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1130)) (if (memv syntmp-t-1131 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1130)) (if (memv syntmp-t-1131 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1130)) (if (memv syntmp-t-1131 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1130) (syntmp-regen-1129 (caddr syntmp-x-1130)))) (if (memv syntmp-t-1131 (quote (map))) (let ((syntmp-ls-1132 (map syntmp-regen-1129 (cdr syntmp-x-1130)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1132) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1132))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1130)) (map syntmp-regen-1129 (cdr syntmp-x-1130)))))))))))) (syntmp-gen-vector-1128 (lambda (syntmp-x-1133) (cond ((eq? (car syntmp-x-1133) (quote list)) (cons (quote vector) (cdr syntmp-x-1133))) ((eq? (car syntmp-x-1133) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1133)))) (else (list (quote list->vector) syntmp-x-1133))))) (syntmp-gen-append-1127 (lambda (syntmp-x-1134 syntmp-y-1135) (if (equal? syntmp-y-1135 (quote (quote ()))) syntmp-x-1134 (list (quote append) syntmp-x-1134 syntmp-y-1135)))) (syntmp-gen-cons-1126 (lambda (syntmp-x-1136 syntmp-y-1137) (let ((syntmp-t-1138 (car syntmp-y-1137))) (if (memv syntmp-t-1138 (quote (quote))) (if (eq? (car syntmp-x-1136) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1136) (cadr syntmp-y-1137))) (if (eq? (cadr syntmp-y-1137) (quote ())) (list (quote list) syntmp-x-1136) (list (quote cons) syntmp-x-1136 syntmp-y-1137))) (if (memv syntmp-t-1138 (quote (list))) (cons (quote list) (cons syntmp-x-1136 (cdr syntmp-y-1137))) (list (quote cons) syntmp-x-1136 syntmp-y-1137)))))) (syntmp-gen-map-1125 (lambda (syntmp-e-1139 syntmp-map-env-1140) (let ((syntmp-formals-1141 (map cdr syntmp-map-env-1140)) (syntmp-actuals-1142 (map (lambda (syntmp-x-1143) (list (quote ref) (car syntmp-x-1143))) syntmp-map-env-1140))) (cond ((eq? (car syntmp-e-1139) (quote ref)) (car syntmp-actuals-1142)) ((andmap (lambda (syntmp-x-1144) (and (eq? (car syntmp-x-1144) (quote ref)) (memq (cadr syntmp-x-1144) syntmp-formals-1141))) (cdr syntmp-e-1139)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1139)) (map (let ((syntmp-r-1145 (map cons syntmp-formals-1141 syntmp-actuals-1142))) (lambda (syntmp-x-1146) (cdr (assq (cadr syntmp-x-1146) syntmp-r-1145)))) (cdr syntmp-e-1139))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1141 syntmp-e-1139) syntmp-actuals-1142))))))) (syntmp-gen-mappend-1124 (lambda (syntmp-e-1147 syntmp-map-env-1148) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1125 syntmp-e-1147 syntmp-map-env-1148)))) (syntmp-gen-ref-1123 (lambda (syntmp-src-1149 syntmp-var-1150 syntmp-level-1151 syntmp-maps-1152) (if (syntmp-fx=-87 syntmp-level-1151 0) (values syntmp-var-1150 syntmp-maps-1152) (if (null? syntmp-maps-1152) (syntax-error syntmp-src-1149 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1123 syntmp-src-1149 syntmp-var-1150 (syntmp-fx--86 syntmp-level-1151 1) (cdr syntmp-maps-1152))) (lambda (syntmp-outer-var-1153 syntmp-outer-maps-1154) (let ((syntmp-b-1155 (assq syntmp-outer-var-1153 (car syntmp-maps-1152)))) (if syntmp-b-1155 (values (cdr syntmp-b-1155) syntmp-maps-1152) (let ((syntmp-inner-var-1156 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1156 (cons (cons (cons syntmp-outer-var-1153 syntmp-inner-var-1156) (car syntmp-maps-1152)) syntmp-outer-maps-1154))))))))))) (syntmp-gen-syntax-1122 (lambda (syntmp-src-1157 syntmp-e-1158 syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162) (if (syntmp-id?-117 syntmp-e-1158) (let ((syntmp-label-1163 (syntmp-id-var-name-139 syntmp-e-1158 (quote (()))))) (let ((syntmp-b-1164 (syntmp-lookup-114 syntmp-label-1163 syntmp-r-1159 syntmp-mod-1162))) (if (eq? (syntmp-binding-type-109 syntmp-b-1164) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1165 (syntmp-binding-value-110 syntmp-b-1164))) (syntmp-gen-ref-1123 syntmp-src-1157 (car syntmp-var.lev-1165) (cdr syntmp-var.lev-1165) syntmp-maps-1160))) (lambda (syntmp-var-1166 syntmp-maps-1167) (values (list (quote ref) syntmp-var-1166) syntmp-maps-1167))) (if (syntmp-ellipsis?-1161 syntmp-e-1158) (syntax-error syntmp-src-1157 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1158) syntmp-maps-1160))))) ((lambda (syntmp-tmp-1168) ((lambda (syntmp-tmp-1169) (if (if syntmp-tmp-1169 (apply (lambda (syntmp-dots-1170 syntmp-e-1171) (syntmp-ellipsis?-1161 syntmp-dots-1170)) syntmp-tmp-1169) #f) (apply (lambda (syntmp-dots-1172 syntmp-e-1173) (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-e-1173 syntmp-r-1159 syntmp-maps-1160 (lambda (syntmp-x-1174) #f) syntmp-mod-1162)) syntmp-tmp-1169) ((lambda (syntmp-tmp-1175) (if (if syntmp-tmp-1175 (apply (lambda (syntmp-x-1176 syntmp-dots-1177 syntmp-y-1178) (syntmp-ellipsis?-1161 syntmp-dots-1177)) syntmp-tmp-1175) #f) (apply (lambda (syntmp-x-1179 syntmp-dots-1180 syntmp-y-1181) (let syntmp-f-1182 ((syntmp-y-1183 syntmp-y-1181) (syntmp-k-1184 (lambda (syntmp-maps-1185) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-x-1179 syntmp-r-1159 (cons (quote ()) syntmp-maps-1185) syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-x-1186 syntmp-maps-1187) (if (null? (car syntmp-maps-1187)) (syntax-error syntmp-src-1157 "extra ellipsis in syntax form") (values (syntmp-gen-map-1125 syntmp-x-1186 (car syntmp-maps-1187)) (cdr syntmp-maps-1187)))))))) ((lambda (syntmp-tmp-1188) ((lambda (syntmp-tmp-1189) (if (if syntmp-tmp-1189 (apply (lambda (syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1161 syntmp-dots-1190)) syntmp-tmp-1189) #f) (apply (lambda (syntmp-dots-1192 syntmp-y-1193) (syntmp-f-1182 syntmp-y-1193 (lambda (syntmp-maps-1194) (call-with-values (lambda () (syntmp-k-1184 (cons (quote ()) syntmp-maps-1194))) (lambda (syntmp-x-1195 syntmp-maps-1196) (if (null? (car syntmp-maps-1196)) (syntax-error syntmp-src-1157 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1124 syntmp-x-1195 (car syntmp-maps-1196)) (cdr syntmp-maps-1196)))))))) syntmp-tmp-1189) ((lambda (syntmp-_-1197) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-y-1183 syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-y-1198 syntmp-maps-1199) (call-with-values (lambda () (syntmp-k-1184 syntmp-maps-1199)) (lambda (syntmp-x-1200 syntmp-maps-1201) (values (syntmp-gen-append-1127 syntmp-x-1200 syntmp-y-1198) syntmp-maps-1201)))))) syntmp-tmp-1188))) (syntax-dispatch syntmp-tmp-1188 (quote (any . any))))) syntmp-y-1183))) syntmp-tmp-1175) ((lambda (syntmp-tmp-1202) (if syntmp-tmp-1202 (apply (lambda (syntmp-x-1203 syntmp-y-1204) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-x-1203 syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-x-1205 syntmp-maps-1206) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 syntmp-y-1204 syntmp-r-1159 syntmp-maps-1206 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-y-1207 syntmp-maps-1208) (values (syntmp-gen-cons-1126 syntmp-x-1205 syntmp-y-1207) syntmp-maps-1208)))))) syntmp-tmp-1202) ((lambda (syntmp-tmp-1209) (if syntmp-tmp-1209 (apply (lambda (syntmp-e1-1210 syntmp-e2-1211) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-src-1157 (cons syntmp-e1-1210 syntmp-e2-1211) syntmp-r-1159 syntmp-maps-1160 syntmp-ellipsis?-1161 syntmp-mod-1162)) (lambda (syntmp-e-1213 syntmp-maps-1214) (values (syntmp-gen-vector-1128 syntmp-e-1213) syntmp-maps-1214)))) syntmp-tmp-1209) ((lambda (syntmp-_-1215) (values (list (quote quote) syntmp-e-1158) syntmp-maps-1160)) syntmp-tmp-1168))) (syntax-dispatch syntmp-tmp-1168 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1168 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1168 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1168 (quote (any any))))) syntmp-e-1158))))) (lambda (syntmp-e-1216 syntmp-r-1217 syntmp-w-1218 syntmp-s-1219 syntmp-mod-1220) (let ((syntmp-e-1221 (syntmp-source-wrap-146 syntmp-e-1216 syntmp-w-1218 syntmp-s-1219 syntmp-mod-1220))) ((lambda (syntmp-tmp-1222) ((lambda (syntmp-tmp-1223) (if syntmp-tmp-1223 (apply (lambda (syntmp-_-1224 syntmp-x-1225) (call-with-values (lambda () (syntmp-gen-syntax-1122 syntmp-e-1221 syntmp-x-1225 syntmp-r-1217 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1220)) (lambda (syntmp-e-1226 syntmp-maps-1227) (syntmp-regen-1129 syntmp-e-1226)))) syntmp-tmp-1223) ((lambda (syntmp-_-1228) (syntax-error syntmp-e-1221)) syntmp-tmp-1222))) (syntax-dispatch syntmp-tmp-1222 (quote (any any))))) syntmp-e-1221))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) ((lambda (syntmp-tmp-1234) ((lambda (syntmp-tmp-1235) (if syntmp-tmp-1235 (apply (lambda (syntmp-_-1236 syntmp-c-1237) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) syntmp-c-1237 syntmp-r-1230 syntmp-w-1231 syntmp-mod-1233 (lambda (syntmp-vars-1238 syntmp-body-1239) (syntmp-build-annotated-94 syntmp-s-1232 (list (quote lambda) syntmp-vars-1238 syntmp-body-1239))))) syntmp-tmp-1235) (syntax-error syntmp-tmp-1234))) (syntax-dispatch syntmp-tmp-1234 (quote (any . any))))) syntmp-e-1229))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1240 (lambda (syntmp-e-1241 syntmp-r-1242 syntmp-w-1243 syntmp-s-1244 syntmp-mod-1245 syntmp-constructor-1246 syntmp-ids-1247 syntmp-vals-1248 syntmp-exps-1249) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1247)) (syntax-error syntmp-e-1241 "duplicate bound variable in") (let ((syntmp-labels-1250 (syntmp-gen-labels-123 syntmp-ids-1247)) (syntmp-new-vars-1251 (map syntmp-gen-var-165 syntmp-ids-1247))) (let ((syntmp-nw-1252 (syntmp-make-binding-wrap-134 syntmp-ids-1247 syntmp-labels-1250 syntmp-w-1243)) (syntmp-nr-1253 (syntmp-extend-var-env-112 syntmp-labels-1250 syntmp-new-vars-1251 syntmp-r-1242))) (syntmp-constructor-1246 syntmp-s-1244 syntmp-new-vars-1251 (map (lambda (syntmp-x-1254) (syntmp-chi-153 syntmp-x-1254 syntmp-r-1242 syntmp-w-1243 syntmp-mod-1245)) syntmp-vals-1248) (syntmp-chi-body-157 syntmp-exps-1249 (syntmp-source-wrap-146 syntmp-e-1241 syntmp-nw-1252 syntmp-s-1244 syntmp-mod-1245) syntmp-nr-1253 syntmp-nw-1252 syntmp-mod-1245)))))))) (lambda (syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259) ((lambda (syntmp-tmp-1260) ((lambda (syntmp-tmp-1261) (if syntmp-tmp-1261 (apply (lambda (syntmp-_-1262 syntmp-id-1263 syntmp-val-1264 syntmp-e1-1265 syntmp-e2-1266) (syntmp-chi-let-1240 syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259 syntmp-build-let-97 syntmp-id-1263 syntmp-val-1264 (cons syntmp-e1-1265 syntmp-e2-1266))) syntmp-tmp-1261) ((lambda (syntmp-tmp-1270) (if (if syntmp-tmp-1270 (apply (lambda (syntmp-_-1271 syntmp-f-1272 syntmp-id-1273 syntmp-val-1274 syntmp-e1-1275 syntmp-e2-1276) (syntmp-id?-117 syntmp-f-1272)) syntmp-tmp-1270) #f) (apply (lambda (syntmp-_-1277 syntmp-f-1278 syntmp-id-1279 syntmp-val-1280 syntmp-e1-1281 syntmp-e2-1282) (syntmp-chi-let-1240 syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259 syntmp-build-named-let-98 (cons syntmp-f-1278 syntmp-id-1279) syntmp-val-1280 (cons syntmp-e1-1281 syntmp-e2-1282))) syntmp-tmp-1270) ((lambda (syntmp-_-1286) (syntax-error (syntmp-source-wrap-146 syntmp-e-1255 syntmp-w-1257 syntmp-s-1258 syntmp-mod-1259))) syntmp-tmp-1260))) (syntax-dispatch syntmp-tmp-1260 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1260 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1255)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1287 syntmp-r-1288 syntmp-w-1289 syntmp-s-1290 syntmp-mod-1291) ((lambda (syntmp-tmp-1292) ((lambda (syntmp-tmp-1293) (if syntmp-tmp-1293 (apply (lambda (syntmp-_-1294 syntmp-id-1295 syntmp-val-1296 syntmp-e1-1297 syntmp-e2-1298) (let ((syntmp-ids-1299 syntmp-id-1295)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1299)) (syntax-error syntmp-e-1287 "duplicate bound variable in") (let ((syntmp-labels-1301 (syntmp-gen-labels-123 syntmp-ids-1299)) (syntmp-new-vars-1302 (map syntmp-gen-var-165 syntmp-ids-1299))) (let ((syntmp-w-1303 (syntmp-make-binding-wrap-134 syntmp-ids-1299 syntmp-labels-1301 syntmp-w-1289)) (syntmp-r-1304 (syntmp-extend-var-env-112 syntmp-labels-1301 syntmp-new-vars-1302 syntmp-r-1288))) (syntmp-build-letrec-99 syntmp-s-1290 syntmp-new-vars-1302 (map (lambda (syntmp-x-1305) (syntmp-chi-153 syntmp-x-1305 syntmp-r-1304 syntmp-w-1303 syntmp-mod-1291)) syntmp-val-1296) (syntmp-chi-body-157 (cons syntmp-e1-1297 syntmp-e2-1298) (syntmp-source-wrap-146 syntmp-e-1287 syntmp-w-1303 syntmp-s-1290 syntmp-mod-1291) syntmp-r-1304 syntmp-w-1303 syntmp-mod-1291))))))) syntmp-tmp-1293) ((lambda (syntmp-_-1308) (syntax-error (syntmp-source-wrap-146 syntmp-e-1287 syntmp-w-1289 syntmp-s-1290 syntmp-mod-1291))) syntmp-tmp-1292))) (syntax-dispatch syntmp-tmp-1292 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1287))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1309 syntmp-r-1310 syntmp-w-1311 syntmp-s-1312 syntmp-mod-1313) ((lambda (syntmp-tmp-1314) ((lambda (syntmp-tmp-1315) (if (if syntmp-tmp-1315 (apply (lambda (syntmp-_-1316 syntmp-id-1317 syntmp-val-1318) (syntmp-id?-117 syntmp-id-1317)) syntmp-tmp-1315) #f) (apply (lambda (syntmp-_-1319 syntmp-id-1320 syntmp-val-1321) (let ((syntmp-val-1322 (syntmp-chi-153 syntmp-val-1321 syntmp-r-1310 syntmp-w-1311 syntmp-mod-1313)) (syntmp-n-1323 (syntmp-id-var-name-139 syntmp-id-1320 syntmp-w-1311))) (let ((syntmp-b-1324 (syntmp-lookup-114 syntmp-n-1323 syntmp-r-1310 syntmp-mod-1313))) (let ((syntmp-t-1325 (syntmp-binding-type-109 syntmp-b-1324))) (if (memv syntmp-t-1325 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1312 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1324) syntmp-val-1322)) (if (memv syntmp-t-1325 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1312 (list (quote set!) (make-module-ref (and syntmp-mod-1313 (module-name syntmp-mod-1313)) syntmp-n-1323 #f) syntmp-val-1322)) (if (memv syntmp-t-1325 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1320 syntmp-w-1311 syntmp-mod-1313) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1309 syntmp-w-1311 syntmp-s-1312 syntmp-mod-1313))))))))) syntmp-tmp-1315) ((lambda (syntmp-tmp-1326) (if syntmp-tmp-1326 (apply (lambda (syntmp-_-1327 syntmp-getter-1328 syntmp-arg-1329 syntmp-val-1330) (syntmp-build-annotated-94 syntmp-s-1312 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-getter-1328) syntmp-r-1310 syntmp-w-1311 syntmp-mod-1313) (map (lambda (syntmp-e-1331) (syntmp-chi-153 syntmp-e-1331 syntmp-r-1310 syntmp-w-1311 syntmp-mod-1313)) (append syntmp-arg-1329 (list syntmp-val-1330)))))) syntmp-tmp-1326) ((lambda (syntmp-_-1333) (syntax-error (syntmp-source-wrap-146 syntmp-e-1309 syntmp-w-1311 syntmp-s-1312 syntmp-mod-1313))) syntmp-tmp-1314))) (syntax-dispatch syntmp-tmp-1314 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1314 (quote (any any any))))) syntmp-e-1309))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1337 (lambda (syntmp-x-1338 syntmp-keys-1339 syntmp-clauses-1340 syntmp-r-1341 syntmp-mod-1342) (if (null? syntmp-clauses-1340) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1338)) ((lambda (syntmp-tmp-1343) ((lambda (syntmp-tmp-1344) (if syntmp-tmp-1344 (apply (lambda (syntmp-pat-1345 syntmp-exp-1346) (if (and (syntmp-id?-117 syntmp-pat-1345) (andmap (lambda (syntmp-x-1347) (not (syntmp-free-id=?-140 syntmp-pat-1345 syntmp-x-1347))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) #f)) syntmp-keys-1339))) (let ((syntmp-labels-1348 (list (syntmp-gen-label-122))) (syntmp-var-1349 (syntmp-gen-var-165 syntmp-pat-1345))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1349) (syntmp-chi-153 syntmp-exp-1346 (syntmp-extend-env-111 syntmp-labels-1348 (list (cons (quote syntax) (cons syntmp-var-1349 0))) syntmp-r-1341) (syntmp-make-binding-wrap-134 (list syntmp-pat-1345) syntmp-labels-1348 (quote (()))) syntmp-mod-1342))) syntmp-x-1338))) (syntmp-gen-clause-1336 syntmp-x-1338 syntmp-keys-1339 (cdr syntmp-clauses-1340) syntmp-r-1341 syntmp-pat-1345 #t syntmp-exp-1346 syntmp-mod-1342))) syntmp-tmp-1344) ((lambda (syntmp-tmp-1350) (if syntmp-tmp-1350 (apply (lambda (syntmp-pat-1351 syntmp-fender-1352 syntmp-exp-1353) (syntmp-gen-clause-1336 syntmp-x-1338 syntmp-keys-1339 (cdr syntmp-clauses-1340) syntmp-r-1341 syntmp-pat-1351 syntmp-fender-1352 syntmp-exp-1353 syntmp-mod-1342)) syntmp-tmp-1350) ((lambda (syntmp-_-1354) (syntax-error (car syntmp-clauses-1340) "invalid syntax-case clause")) syntmp-tmp-1343))) (syntax-dispatch syntmp-tmp-1343 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1343 (quote (any any))))) (car syntmp-clauses-1340))))) (syntmp-gen-clause-1336 (lambda (syntmp-x-1355 syntmp-keys-1356 syntmp-clauses-1357 syntmp-r-1358 syntmp-pat-1359 syntmp-fender-1360 syntmp-exp-1361 syntmp-mod-1362) (call-with-values (lambda () (syntmp-convert-pattern-1334 syntmp-pat-1359 syntmp-keys-1356)) (lambda (syntmp-p-1363 syntmp-pvars-1364) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1364))) (syntax-error syntmp-pat-1359 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1365) (not (syntmp-ellipsis?-162 (car syntmp-x-1365)))) syntmp-pvars-1364)) (syntax-error syntmp-pat-1359 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1366 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1366) (let ((syntmp-y-1367 (syntmp-build-annotated-94 #f syntmp-y-1366))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1368) ((lambda (syntmp-tmp-1369) (if syntmp-tmp-1369 (apply (lambda () syntmp-y-1367) syntmp-tmp-1369) ((lambda (syntmp-_-1370) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1367 (syntmp-build-dispatch-call-1335 syntmp-pvars-1364 syntmp-fender-1360 syntmp-y-1367 syntmp-r-1358 syntmp-mod-1362) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1368))) (syntax-dispatch syntmp-tmp-1368 (quote #(atom #t))))) syntmp-fender-1360) (syntmp-build-dispatch-call-1335 syntmp-pvars-1364 syntmp-exp-1361 syntmp-y-1367 syntmp-r-1358 syntmp-mod-1362) (syntmp-gen-syntax-case-1337 syntmp-x-1355 syntmp-keys-1356 syntmp-clauses-1357 syntmp-r-1358 syntmp-mod-1362)))))) (if (eq? syntmp-p-1363 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1355)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1355 (syntmp-build-data-95 #f syntmp-p-1363))))))))))))) (syntmp-build-dispatch-call-1335 (lambda (syntmp-pvars-1371 syntmp-exp-1372 syntmp-y-1373 syntmp-r-1374 syntmp-mod-1375) (let ((syntmp-ids-1376 (map car syntmp-pvars-1371)) (syntmp-levels-1377 (map cdr syntmp-pvars-1371))) (let ((syntmp-labels-1378 (syntmp-gen-labels-123 syntmp-ids-1376)) (syntmp-new-vars-1379 (map syntmp-gen-var-165 syntmp-ids-1376))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1379 (syntmp-chi-153 syntmp-exp-1372 (syntmp-extend-env-111 syntmp-labels-1378 (map (lambda (syntmp-var-1380 syntmp-level-1381) (cons (quote syntax) (cons syntmp-var-1380 syntmp-level-1381))) syntmp-new-vars-1379 (map cdr syntmp-pvars-1371)) syntmp-r-1374) (syntmp-make-binding-wrap-134 syntmp-ids-1376 syntmp-labels-1378 (quote (()))) syntmp-mod-1375))) syntmp-y-1373)))))) (syntmp-convert-pattern-1334 (lambda (syntmp-pattern-1382 syntmp-keys-1383) (let syntmp-cvt-1384 ((syntmp-p-1385 syntmp-pattern-1382) (syntmp-n-1386 0) (syntmp-ids-1387 (quote ()))) (if (syntmp-id?-117 syntmp-p-1385) (if (syntmp-bound-id-member?-144 syntmp-p-1385 syntmp-keys-1383) (values (vector (quote free-id) syntmp-p-1385) syntmp-ids-1387) (values (quote any) (cons (cons syntmp-p-1385 syntmp-n-1386) syntmp-ids-1387))) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if (if syntmp-tmp-1389 (apply (lambda (syntmp-x-1390 syntmp-dots-1391) (syntmp-ellipsis?-162 syntmp-dots-1391)) syntmp-tmp-1389) #f) (apply (lambda (syntmp-x-1392 syntmp-dots-1393) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-x-1392 (syntmp-fx+-85 syntmp-n-1386 1) syntmp-ids-1387)) (lambda (syntmp-p-1394 syntmp-ids-1395) (values (if (eq? syntmp-p-1394 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1394)) syntmp-ids-1395)))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1396) (if syntmp-tmp-1396 (apply (lambda (syntmp-x-1397 syntmp-y-1398) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-y-1398 syntmp-n-1386 syntmp-ids-1387)) (lambda (syntmp-y-1399 syntmp-ids-1400) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-x-1397 syntmp-n-1386 syntmp-ids-1400)) (lambda (syntmp-x-1401 syntmp-ids-1402) (values (cons syntmp-x-1401 syntmp-y-1399) syntmp-ids-1402)))))) syntmp-tmp-1396) ((lambda (syntmp-tmp-1403) (if syntmp-tmp-1403 (apply (lambda () (values (quote ()) syntmp-ids-1387)) syntmp-tmp-1403) ((lambda (syntmp-tmp-1404) (if syntmp-tmp-1404 (apply (lambda (syntmp-x-1405) (call-with-values (lambda () (syntmp-cvt-1384 syntmp-x-1405 syntmp-n-1386 syntmp-ids-1387)) (lambda (syntmp-p-1407 syntmp-ids-1408) (values (vector (quote vector) syntmp-p-1407) syntmp-ids-1408)))) syntmp-tmp-1404) ((lambda (syntmp-x-1409) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1385 (quote (())))) syntmp-ids-1387)) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1388 (quote ()))))) (syntax-dispatch syntmp-tmp-1388 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) syntmp-p-1385)))))) (lambda (syntmp-e-1410 syntmp-r-1411 syntmp-w-1412 syntmp-s-1413 syntmp-mod-1414) (let ((syntmp-e-1415 (syntmp-source-wrap-146 syntmp-e-1410 syntmp-w-1412 syntmp-s-1413 syntmp-mod-1414))) ((lambda (syntmp-tmp-1416) ((lambda (syntmp-tmp-1417) (if syntmp-tmp-1417 (apply (lambda (syntmp-_-1418 syntmp-val-1419 syntmp-key-1420 syntmp-m-1421) (if (andmap (lambda (syntmp-x-1422) (and (syntmp-id?-117 syntmp-x-1422) (not (syntmp-ellipsis?-162 syntmp-x-1422)))) syntmp-key-1420) (let ((syntmp-x-1424 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1413 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1424) (syntmp-gen-syntax-case-1337 (syntmp-build-annotated-94 #f syntmp-x-1424) syntmp-key-1420 syntmp-m-1421 syntmp-r-1411 syntmp-mod-1414))) (syntmp-chi-153 syntmp-val-1419 syntmp-r-1411 (quote (())) syntmp-mod-1414)))) (syntax-error syntmp-e-1415 "invalid literals list in"))) syntmp-tmp-1417) (syntax-error syntmp-tmp-1416))) (syntax-dispatch syntmp-tmp-1416 (quote (any any each-any . each-any))))) syntmp-e-1415))))) (set! sc-expand (let ((syntmp-m-1427 (quote e)) (syntmp-esew-1428 (quote (eval)))) (lambda (syntmp-x-1429) (if (and (pair? syntmp-x-1429) (equal? (car syntmp-x-1429) syntmp-noexpand-84)) (cadr syntmp-x-1429) (syntmp-chi-top-152 syntmp-x-1429 (quote ()) (quote ((top))) syntmp-m-1427 syntmp-esew-1428 (current-module)))))) (set! sc-expand3 (let ((syntmp-m-1430 (quote e)) (syntmp-esew-1431 (quote (eval)))) (lambda (syntmp-x-1433 . syntmp-rest-1432) (if (and (pair? syntmp-x-1433) (equal? (car syntmp-x-1433) syntmp-noexpand-84)) (cadr syntmp-x-1433) (syntmp-chi-top-152 syntmp-x-1433 (quote ()) (quote ((top))) (if (null? syntmp-rest-1432) syntmp-m-1430 (car syntmp-rest-1432)) (if (or (null? syntmp-rest-1432) (null? (cdr syntmp-rest-1432))) syntmp-esew-1431 (cadr syntmp-rest-1432)) (current-module)))))) (set! identifier? (lambda (syntmp-x-1434) (syntmp-nonsymbol-id?-116 syntmp-x-1434))) (set! datum->syntax-object (lambda (syntmp-id-1435 syntmp-datum-1436) (syntmp-make-syntax-object-100 syntmp-datum-1436 (syntmp-syntax-object-wrap-103 syntmp-id-1435) #f))) (set! syntax-object->datum (lambda (syntmp-x-1437) (syntmp-strip-164 syntmp-x-1437 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1438) (begin (let ((syntmp-x-1439 syntmp-ls-1438)) (if (not (list? syntmp-x-1439)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1439))) (map (lambda (syntmp-x-1440) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1438)))) (set! free-identifier=? (lambda (syntmp-x-1441 syntmp-y-1442) (begin (let ((syntmp-x-1443 syntmp-x-1441)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1443)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1443))) (let ((syntmp-x-1444 syntmp-y-1442)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1444)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1444))) (syntmp-free-id=?-140 syntmp-x-1441 syntmp-y-1442)))) (set! bound-identifier=? (lambda (syntmp-x-1445 syntmp-y-1446) (begin (let ((syntmp-x-1447 syntmp-x-1445)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1447)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1447))) (let ((syntmp-x-1448 syntmp-y-1446)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1448)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1448))) (syntmp-bound-id=?-141 syntmp-x-1445 syntmp-y-1446)))) (set! syntax-error (lambda (syntmp-object-1450 . syntmp-messages-1449) (begin (for-each (lambda (syntmp-x-1451) (let ((syntmp-x-1452 syntmp-x-1451)) (if (not (string? syntmp-x-1452)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1452)))) syntmp-messages-1449) (let ((syntmp-message-1453 (if (null? syntmp-messages-1449) "invalid syntax" (apply string-append syntmp-messages-1449)))) (syntmp-error-hook-91 #f syntmp-message-1453 (syntmp-strip-164 syntmp-object-1450 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1454 syntmp-v-1455) (begin (let ((syntmp-x-1456 syntmp-sym-1454)) (if (not (symbol? syntmp-x-1456)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1456))) (let ((syntmp-x-1457 syntmp-v-1455)) (if (not (procedure? syntmp-x-1457)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1457))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1454 syntmp-v-1455)))) (letrec ((syntmp-match-1462 (lambda (syntmp-e-1463 syntmp-p-1464 syntmp-w-1465 syntmp-r-1466) (cond ((not syntmp-r-1466) #f) ((eq? syntmp-p-1464 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1463 syntmp-w-1465 #f) syntmp-r-1466)) ((syntmp-syntax-object?-101 syntmp-e-1463) (syntmp-match*-1461 (let ((syntmp-e-1467 (syntmp-syntax-object-expression-102 syntmp-e-1463))) (if (annotation? syntmp-e-1467) (annotation-expression syntmp-e-1467) syntmp-e-1467)) syntmp-p-1464 (syntmp-join-wraps-136 syntmp-w-1465 (syntmp-syntax-object-wrap-103 syntmp-e-1463)) syntmp-r-1466)) (else (syntmp-match*-1461 (let ((syntmp-e-1468 syntmp-e-1463)) (if (annotation? syntmp-e-1468) (annotation-expression syntmp-e-1468) syntmp-e-1468)) syntmp-p-1464 syntmp-w-1465 syntmp-r-1466))))) (syntmp-match*-1461 (lambda (syntmp-e-1469 syntmp-p-1470 syntmp-w-1471 syntmp-r-1472) (cond ((null? syntmp-p-1470) (and (null? syntmp-e-1469) syntmp-r-1472)) ((pair? syntmp-p-1470) (and (pair? syntmp-e-1469) (syntmp-match-1462 (car syntmp-e-1469) (car syntmp-p-1470) syntmp-w-1471 (syntmp-match-1462 (cdr syntmp-e-1469) (cdr syntmp-p-1470) syntmp-w-1471 syntmp-r-1472)))) ((eq? syntmp-p-1470 (quote each-any)) (let ((syntmp-l-1473 (syntmp-match-each-any-1459 syntmp-e-1469 syntmp-w-1471))) (and syntmp-l-1473 (cons syntmp-l-1473 syntmp-r-1472)))) (else (let ((syntmp-t-1474 (vector-ref syntmp-p-1470 0))) (if (memv syntmp-t-1474 (quote (each))) (if (null? syntmp-e-1469) (syntmp-match-empty-1460 (vector-ref syntmp-p-1470 1) syntmp-r-1472) (let ((syntmp-l-1475 (syntmp-match-each-1458 syntmp-e-1469 (vector-ref syntmp-p-1470 1) syntmp-w-1471))) (and syntmp-l-1475 (let syntmp-collect-1476 ((syntmp-l-1477 syntmp-l-1475)) (if (null? (car syntmp-l-1477)) syntmp-r-1472 (cons (map car syntmp-l-1477) (syntmp-collect-1476 (map cdr syntmp-l-1477)))))))) (if (memv syntmp-t-1474 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1469) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1469 syntmp-w-1471 #f) (vector-ref syntmp-p-1470 1)) syntmp-r-1472) (if (memv syntmp-t-1474 (quote (atom))) (and (equal? (vector-ref syntmp-p-1470 1) (syntmp-strip-164 syntmp-e-1469 syntmp-w-1471)) syntmp-r-1472) (if (memv syntmp-t-1474 (quote (vector))) (and (vector? syntmp-e-1469) (syntmp-match-1462 (vector->list syntmp-e-1469) (vector-ref syntmp-p-1470 1) syntmp-w-1471 syntmp-r-1472))))))))))) (syntmp-match-empty-1460 (lambda (syntmp-p-1478 syntmp-r-1479) (cond ((null? syntmp-p-1478) syntmp-r-1479) ((eq? syntmp-p-1478 (quote any)) (cons (quote ()) syntmp-r-1479)) ((pair? syntmp-p-1478) (syntmp-match-empty-1460 (car syntmp-p-1478) (syntmp-match-empty-1460 (cdr syntmp-p-1478) syntmp-r-1479))) ((eq? syntmp-p-1478 (quote each-any)) (cons (quote ()) syntmp-r-1479)) (else (let ((syntmp-t-1480 (vector-ref syntmp-p-1478 0))) (if (memv syntmp-t-1480 (quote (each))) (syntmp-match-empty-1460 (vector-ref syntmp-p-1478 1) syntmp-r-1479) (if (memv syntmp-t-1480 (quote (free-id atom))) syntmp-r-1479 (if (memv syntmp-t-1480 (quote (vector))) (syntmp-match-empty-1460 (vector-ref syntmp-p-1478 1) syntmp-r-1479))))))))) (syntmp-match-each-any-1459 (lambda (syntmp-e-1481 syntmp-w-1482) (cond ((annotation? syntmp-e-1481) (syntmp-match-each-any-1459 (annotation-expression syntmp-e-1481) syntmp-w-1482)) ((pair? syntmp-e-1481) (let ((syntmp-l-1483 (syntmp-match-each-any-1459 (cdr syntmp-e-1481) syntmp-w-1482))) (and syntmp-l-1483 (cons (syntmp-wrap-145 (car syntmp-e-1481) syntmp-w-1482 #f) syntmp-l-1483)))) ((null? syntmp-e-1481) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1481) (syntmp-match-each-any-1459 (syntmp-syntax-object-expression-102 syntmp-e-1481) (syntmp-join-wraps-136 syntmp-w-1482 (syntmp-syntax-object-wrap-103 syntmp-e-1481)))) (else #f)))) (syntmp-match-each-1458 (lambda (syntmp-e-1484 syntmp-p-1485 syntmp-w-1486) (cond ((annotation? syntmp-e-1484) (syntmp-match-each-1458 (annotation-expression syntmp-e-1484) syntmp-p-1485 syntmp-w-1486)) ((pair? syntmp-e-1484) (let ((syntmp-first-1487 (syntmp-match-1462 (car syntmp-e-1484) syntmp-p-1485 syntmp-w-1486 (quote ())))) (and syntmp-first-1487 (let ((syntmp-rest-1488 (syntmp-match-each-1458 (cdr syntmp-e-1484) syntmp-p-1485 syntmp-w-1486))) (and syntmp-rest-1488 (cons syntmp-first-1487 syntmp-rest-1488)))))) ((null? syntmp-e-1484) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1484) (syntmp-match-each-1458 (syntmp-syntax-object-expression-102 syntmp-e-1484) syntmp-p-1485 (syntmp-join-wraps-136 syntmp-w-1486 (syntmp-syntax-object-wrap-103 syntmp-e-1484)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1489 syntmp-p-1490) (cond ((eq? syntmp-p-1490 (quote any)) (list syntmp-e-1489)) ((syntmp-syntax-object?-101 syntmp-e-1489) (syntmp-match*-1461 (let ((syntmp-e-1491 (syntmp-syntax-object-expression-102 syntmp-e-1489))) (if (annotation? syntmp-e-1491) (annotation-expression syntmp-e-1491) syntmp-e-1491)) syntmp-p-1490 (syntmp-syntax-object-wrap-103 syntmp-e-1489) (quote ()))) (else (syntmp-match*-1461 (let ((syntmp-e-1492 syntmp-e-1489)) (if (annotation? syntmp-e-1492) (annotation-expression syntmp-e-1492) syntmp-e-1492)) syntmp-p-1490 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-153))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1493) ((lambda (syntmp-tmp-1494) ((lambda (syntmp-tmp-1495) (if syntmp-tmp-1495 (apply (lambda (syntmp-_-1496 syntmp-e1-1497 syntmp-e2-1498) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1497 syntmp-e2-1498))) syntmp-tmp-1495) ((lambda (syntmp-tmp-1500) (if syntmp-tmp-1500 (apply (lambda (syntmp-_-1501 syntmp-out-1502 syntmp-in-1503 syntmp-e1-1504 syntmp-e2-1505) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1503 (quote ()) (list syntmp-out-1502 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1504 syntmp-e2-1505))))) syntmp-tmp-1500) ((lambda (syntmp-tmp-1507) (if syntmp-tmp-1507 (apply (lambda (syntmp-_-1508 syntmp-out-1509 syntmp-in-1510 syntmp-e1-1511 syntmp-e2-1512) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-in-1510) (quote ()) (list syntmp-out-1509 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1511 syntmp-e2-1512))))) syntmp-tmp-1507) (syntax-error syntmp-tmp-1494))) (syntax-dispatch syntmp-tmp-1494 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1494 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1494 (quote (any () any . each-any))))) syntmp-x-1493))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1534) ((lambda (syntmp-tmp-1535) ((lambda (syntmp-tmp-1536) (if syntmp-tmp-1536 (apply (lambda (syntmp-_-1537 syntmp-k-1538 syntmp-keyword-1539 syntmp-pattern-1540 syntmp-template-1541) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-k-1538 (map (lambda (syntmp-tmp-1544 syntmp-tmp-1543) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1543) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-tmp-1544))) syntmp-template-1541 syntmp-pattern-1540)))))) syntmp-tmp-1536) (syntax-error syntmp-tmp-1535))) (syntax-dispatch syntmp-tmp-1535 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1534))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1555) ((lambda (syntmp-tmp-1556) ((lambda (syntmp-tmp-1557) (if (if syntmp-tmp-1557 (apply (lambda (syntmp-let*-1558 syntmp-x-1559 syntmp-v-1560 syntmp-e1-1561 syntmp-e2-1562) (andmap identifier? syntmp-x-1559)) syntmp-tmp-1557) #f) (apply (lambda (syntmp-let*-1564 syntmp-x-1565 syntmp-v-1566 syntmp-e1-1567 syntmp-e2-1568) (let syntmp-f-1569 ((syntmp-bindings-1570 (map list syntmp-x-1565 syntmp-v-1566))) (if (null? syntmp-bindings-1570) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons (quote ()) (cons syntmp-e1-1567 syntmp-e2-1568))) ((lambda (syntmp-tmp-1574) ((lambda (syntmp-tmp-1575) (if syntmp-tmp-1575 (apply (lambda (syntmp-body-1576 syntmp-binding-1577) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list syntmp-binding-1577) syntmp-body-1576)) syntmp-tmp-1575) (syntax-error syntmp-tmp-1574))) (syntax-dispatch syntmp-tmp-1574 (quote (any any))))) (list (syntmp-f-1569 (cdr syntmp-bindings-1570)) (car syntmp-bindings-1570)))))) syntmp-tmp-1557) (syntax-error syntmp-tmp-1556))) (syntax-dispatch syntmp-tmp-1556 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1555))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1597) ((lambda (syntmp-tmp-1598) ((lambda (syntmp-tmp-1599) (if syntmp-tmp-1599 (apply (lambda (syntmp-_-1600 syntmp-var-1601 syntmp-init-1602 syntmp-step-1603 syntmp-e0-1604 syntmp-e1-1605 syntmp-c-1606) ((lambda (syntmp-tmp-1607) ((lambda (syntmp-tmp-1608) (if syntmp-tmp-1608 (apply (lambda (syntmp-step-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1601 syntmp-init-1602) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1604) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1606 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1609))))))) syntmp-tmp-1611) ((lambda (syntmp-tmp-1616) (if syntmp-tmp-1616 (apply (lambda (syntmp-e1-1617 syntmp-e2-1618) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (map list syntmp-var-1601 syntmp-init-1602) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-e0-1604 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (cons syntmp-e1-1617 syntmp-e2-1618)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) (append syntmp-c-1606 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) #f)) syntmp-step-1609))))))) syntmp-tmp-1616) (syntax-error syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1610 (quote ())))) syntmp-e1-1605)) syntmp-tmp-1608) (syntax-error syntmp-tmp-1607))) (syntax-dispatch syntmp-tmp-1607 (quote each-any)))) (map (lambda (syntmp-v-1625 syntmp-s-1626) ((lambda (syntmp-tmp-1627) ((lambda (syntmp-tmp-1628) (if syntmp-tmp-1628 (apply (lambda () syntmp-v-1625) syntmp-tmp-1628) ((lambda (syntmp-tmp-1629) (if syntmp-tmp-1629 (apply (lambda (syntmp-e-1630) syntmp-e-1630) syntmp-tmp-1629) ((lambda (syntmp-_-1631) (syntax-error syntmp-orig-x-1597)) syntmp-tmp-1627))) (syntax-dispatch syntmp-tmp-1627 (quote (any)))))) (syntax-dispatch syntmp-tmp-1627 (quote ())))) syntmp-s-1626)) syntmp-var-1601 syntmp-step-1603))) syntmp-tmp-1599) (syntax-error syntmp-tmp-1598))) (syntax-dispatch syntmp-tmp-1598 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1597))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1659 (lambda (syntmp-x-1663 syntmp-y-1664) ((lambda (syntmp-tmp-1665) ((lambda (syntmp-tmp-1666) (if syntmp-tmp-1666 (apply (lambda (syntmp-x-1667 syntmp-y-1668) ((lambda (syntmp-tmp-1669) ((lambda (syntmp-tmp-1670) (if syntmp-tmp-1670 (apply (lambda (syntmp-dy-1671) ((lambda (syntmp-tmp-1672) ((lambda (syntmp-tmp-1673) (if syntmp-tmp-1673 (apply (lambda (syntmp-dx-1674) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-dx-1674 syntmp-dy-1671))) syntmp-tmp-1673) ((lambda (syntmp-_-1675) (if (null? syntmp-dy-1671) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1667) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1667 syntmp-y-1668))) syntmp-tmp-1672))) (syntax-dispatch syntmp-tmp-1672 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-x-1667)) syntmp-tmp-1670) ((lambda (syntmp-tmp-1676) (if syntmp-tmp-1676 (apply (lambda (syntmp-stuff-1677) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (cons syntmp-x-1667 syntmp-stuff-1677))) syntmp-tmp-1676) ((lambda (syntmp-else-1678) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1667 syntmp-y-1668)) syntmp-tmp-1669))) (syntax-dispatch syntmp-tmp-1669 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . any)))))) (syntax-dispatch syntmp-tmp-1669 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-y-1668)) syntmp-tmp-1666) (syntax-error syntmp-tmp-1665))) (syntax-dispatch syntmp-tmp-1665 (quote (any any))))) (list syntmp-x-1663 syntmp-y-1664)))) (syntmp-quasiappend-1660 (lambda (syntmp-x-1679 syntmp-y-1680) ((lambda (syntmp-tmp-1681) ((lambda (syntmp-tmp-1682) (if syntmp-tmp-1682 (apply (lambda (syntmp-x-1683 syntmp-y-1684) ((lambda (syntmp-tmp-1685) ((lambda (syntmp-tmp-1686) (if syntmp-tmp-1686 (apply (lambda () syntmp-x-1683) syntmp-tmp-1686) ((lambda (syntmp-_-1687) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1683 syntmp-y-1684)) syntmp-tmp-1685))) (syntax-dispatch syntmp-tmp-1685 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) ()))))) syntmp-y-1684)) syntmp-tmp-1682) (syntax-error syntmp-tmp-1681))) (syntax-dispatch syntmp-tmp-1681 (quote (any any))))) (list syntmp-x-1679 syntmp-y-1680)))) (syntmp-quasivector-1661 (lambda (syntmp-x-1688) ((lambda (syntmp-tmp-1689) ((lambda (syntmp-x-1690) ((lambda (syntmp-tmp-1691) ((lambda (syntmp-tmp-1692) (if syntmp-tmp-1692 (apply (lambda (syntmp-x-1693) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) (list->vector syntmp-x-1693))) syntmp-tmp-1692) ((lambda (syntmp-tmp-1695) (if syntmp-tmp-1695 (apply (lambda (syntmp-x-1696) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1696)) syntmp-tmp-1695) ((lambda (syntmp-_-1698) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-x-1690)) syntmp-tmp-1691))) (syntax-dispatch syntmp-tmp-1691 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) . each-any)))))) (syntax-dispatch syntmp-tmp-1691 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) each-any))))) syntmp-x-1690)) syntmp-tmp-1689)) syntmp-x-1688))) (syntmp-quasi-1662 (lambda (syntmp-p-1699 syntmp-lev-1700) ((lambda (syntmp-tmp-1701) ((lambda (syntmp-tmp-1702) (if syntmp-tmp-1702 (apply (lambda (syntmp-p-1703) (if (= syntmp-lev-1700 0) syntmp-p-1703 (syntmp-quasicons-1659 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1662 (list syntmp-p-1703) (- syntmp-lev-1700 1))))) syntmp-tmp-1702) ((lambda (syntmp-tmp-1704) (if syntmp-tmp-1704 (apply (lambda (syntmp-p-1705 syntmp-q-1706) (if (= syntmp-lev-1700 0) (syntmp-quasiappend-1660 syntmp-p-1705 (syntmp-quasi-1662 syntmp-q-1706 syntmp-lev-1700)) (syntmp-quasicons-1659 (syntmp-quasicons-1659 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1662 (list syntmp-p-1705) (- syntmp-lev-1700 1))) (syntmp-quasi-1662 syntmp-q-1706 syntmp-lev-1700)))) syntmp-tmp-1704) ((lambda (syntmp-tmp-1707) (if syntmp-tmp-1707 (apply (lambda (syntmp-p-1708) (syntmp-quasicons-1659 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f))) (syntmp-quasi-1662 (list syntmp-p-1708) (+ syntmp-lev-1700 1)))) syntmp-tmp-1707) ((lambda (syntmp-tmp-1709) (if syntmp-tmp-1709 (apply (lambda (syntmp-p-1710 syntmp-q-1711) (syntmp-quasicons-1659 (syntmp-quasi-1662 syntmp-p-1710 syntmp-lev-1700) (syntmp-quasi-1662 syntmp-q-1711 syntmp-lev-1700))) syntmp-tmp-1709) ((lambda (syntmp-tmp-1712) (if syntmp-tmp-1712 (apply (lambda (syntmp-x-1713) (syntmp-quasivector-1661 (syntmp-quasi-1662 syntmp-x-1713 syntmp-lev-1700))) syntmp-tmp-1712) ((lambda (syntmp-p-1715) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) syntmp-p-1715)) syntmp-tmp-1701))) (syntax-dispatch syntmp-tmp-1701 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1701 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1701 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any)))))) (syntax-dispatch syntmp-tmp-1701 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any) . any)))))) (syntax-dispatch syntmp-tmp-1701 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) #f)) any))))) syntmp-p-1699)))) (lambda (syntmp-x-1716) ((lambda (syntmp-tmp-1717) ((lambda (syntmp-tmp-1718) (if syntmp-tmp-1718 (apply (lambda (syntmp-_-1719 syntmp-e-1720) (syntmp-quasi-1662 syntmp-e-1720 0)) syntmp-tmp-1718) (syntax-error syntmp-tmp-1717))) (syntax-dispatch syntmp-tmp-1717 (quote (any any))))) syntmp-x-1716)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1780) (letrec ((syntmp-read-file-1781 (lambda (syntmp-fn-1782 syntmp-k-1783) (let ((syntmp-p-1784 (open-input-file syntmp-fn-1782))) (let syntmp-f-1785 ((syntmp-x-1786 (read syntmp-p-1784))) (if (eof-object? syntmp-x-1786) (begin (close-input-port syntmp-p-1784) (quote ())) (cons (datum->syntax-object syntmp-k-1783 syntmp-x-1786) (syntmp-f-1785 (read syntmp-p-1784))))))))) ((lambda (syntmp-tmp-1787) ((lambda (syntmp-tmp-1788) (if syntmp-tmp-1788 (apply (lambda (syntmp-k-1789 syntmp-filename-1790) (let ((syntmp-fn-1791 (syntax-object->datum syntmp-filename-1790))) ((lambda (syntmp-tmp-1792) ((lambda (syntmp-tmp-1793) (if syntmp-tmp-1793 (apply (lambda (syntmp-exp-1794) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-exp-1794)) syntmp-tmp-1793) (syntax-error syntmp-tmp-1792))) (syntax-dispatch syntmp-tmp-1792 (quote each-any)))) (syntmp-read-file-1781 syntmp-fn-1791 syntmp-k-1789)))) syntmp-tmp-1788) (syntax-error syntmp-tmp-1787))) (syntax-dispatch syntmp-tmp-1787 (quote (any any))))) syntmp-x-1780)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1811) ((lambda (syntmp-tmp-1812) ((lambda (syntmp-tmp-1813) (if syntmp-tmp-1813 (apply (lambda (syntmp-_-1814 syntmp-e-1815) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1815))) syntmp-tmp-1813) (syntax-error syntmp-tmp-1812))) (syntax-dispatch syntmp-tmp-1812 (quote (any any))))) syntmp-x-1811))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1821) ((lambda (syntmp-tmp-1822) ((lambda (syntmp-tmp-1823) (if syntmp-tmp-1823 (apply (lambda (syntmp-_-1824 syntmp-e-1825) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1825))) syntmp-tmp-1823) (syntax-error syntmp-tmp-1822))) (syntax-dispatch syntmp-tmp-1822 (quote (any any))))) syntmp-x-1821))) -(install-global-transformer (quote case) (lambda (syntmp-x-1831) ((lambda (syntmp-tmp-1832) ((lambda (syntmp-tmp-1833) (if syntmp-tmp-1833 (apply (lambda (syntmp-_-1834 syntmp-e-1835 syntmp-m1-1836 syntmp-m2-1837) ((lambda (syntmp-tmp-1838) ((lambda (syntmp-body-1839) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1835)) syntmp-body-1839)) syntmp-tmp-1838)) (let syntmp-f-1840 ((syntmp-clause-1841 syntmp-m1-1836) (syntmp-clauses-1842 syntmp-m2-1837)) (if (null? syntmp-clauses-1842) ((lambda (syntmp-tmp-1844) ((lambda (syntmp-tmp-1845) (if syntmp-tmp-1845 (apply (lambda (syntmp-e1-1846 syntmp-e2-1847) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1846 syntmp-e2-1847))) syntmp-tmp-1845) ((lambda (syntmp-tmp-1849) (if syntmp-tmp-1849 (apply (lambda (syntmp-k-1850 syntmp-e1-1851 syntmp-e2-1852) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1850)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1851 syntmp-e2-1852)))) syntmp-tmp-1849) ((lambda (syntmp-_-1855) (syntax-error syntmp-x-1831)) syntmp-tmp-1844))) (syntax-dispatch syntmp-tmp-1844 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1844 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) any . each-any))))) syntmp-clause-1841) ((lambda (syntmp-tmp-1856) ((lambda (syntmp-rest-1857) ((lambda (syntmp-tmp-1858) ((lambda (syntmp-tmp-1859) (if syntmp-tmp-1859 (apply (lambda (syntmp-k-1860 syntmp-e1-1861 syntmp-e2-1862) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-k-1860)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e1-1861 syntmp-e2-1862)) syntmp-rest-1857)) syntmp-tmp-1859) ((lambda (syntmp-_-1865) (syntax-error syntmp-x-1831)) syntmp-tmp-1858))) (syntax-dispatch syntmp-tmp-1858 (quote (each-any any . each-any))))) syntmp-clause-1841)) syntmp-tmp-1856)) (syntmp-f-1840 (car syntmp-clauses-1842) (cdr syntmp-clauses-1842))))))) syntmp-tmp-1833) (syntax-error syntmp-tmp-1832))) (syntax-dispatch syntmp-tmp-1832 (quote (any any any . each-any))))) syntmp-x-1831))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1895) ((lambda (syntmp-tmp-1896) ((lambda (syntmp-tmp-1897) (if syntmp-tmp-1897 (apply (lambda (syntmp-_-1898 syntmp-e-1899) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) syntmp-e-1899)) (list (cons syntmp-_-1898 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f)) (cons syntmp-e-1899 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) #f))))))))) syntmp-tmp-1897) (syntax-error syntmp-tmp-1896))) (syntax-dispatch syntmp-tmp-1896 (quote (any any))))) syntmp-x-1895))) +(letrec ((syntmp-lambda-var-list-168 + (lambda (syntmp-vars-559) + (let syntmp-lvl-560 ((syntmp-vars-561 syntmp-vars-559) + (syntmp-ls-562 (quote ())) + (syntmp-w-563 (quote (())))) + (cond ((pair? syntmp-vars-561) + (syntmp-lvl-560 + (cdr syntmp-vars-561) + (cons (syntmp-wrap-147 + (car syntmp-vars-561) + syntmp-w-563 + #f) + syntmp-ls-562) + syntmp-w-563)) + ((syntmp-id?-119 syntmp-vars-561) + (cons (syntmp-wrap-147 syntmp-vars-561 syntmp-w-563 #f) + syntmp-ls-562)) + ((null? syntmp-vars-561) syntmp-ls-562) + ((syntmp-syntax-object?-103 syntmp-vars-561) + (syntmp-lvl-560 + (syntmp-syntax-object-expression-104 + syntmp-vars-561) + syntmp-ls-562 + (syntmp-join-wraps-138 + syntmp-w-563 + (syntmp-syntax-object-wrap-105 syntmp-vars-561)))) + ((annotation? syntmp-vars-561) + (syntmp-lvl-560 + (annotation-expression syntmp-vars-561) + syntmp-ls-562 + syntmp-w-563)) + (else (cons syntmp-vars-561 syntmp-ls-562)))))) + (syntmp-gen-var-167 + (lambda (syntmp-id-564) + (let ((syntmp-id-565 + (if (syntmp-syntax-object?-103 syntmp-id-564) + (syntmp-syntax-object-expression-104 + syntmp-id-564) + syntmp-id-564))) + (if (annotation? syntmp-id-565) + (syntmp-build-annotated-96 + (annotation-source syntmp-id-565) + (gensym + (symbol->string + (annotation-expression syntmp-id-565)))) + (syntmp-build-annotated-96 + #f + (gensym (symbol->string syntmp-id-565))))))) + (syntmp-strip-166 + (lambda (syntmp-x-566 syntmp-w-567) + (if (memq 'top + (syntmp-wrap-marks-122 syntmp-w-567)) + (if (or (annotation? syntmp-x-566) + (and (pair? syntmp-x-566) + (annotation? (car syntmp-x-566)))) + (syntmp-strip-annotation-165 syntmp-x-566 #f) + syntmp-x-566) + (let syntmp-f-568 ((syntmp-x-569 syntmp-x-566)) + (cond ((syntmp-syntax-object?-103 syntmp-x-569) + (syntmp-strip-166 + (syntmp-syntax-object-expression-104 + syntmp-x-569) + (syntmp-syntax-object-wrap-105 syntmp-x-569))) + ((pair? syntmp-x-569) + (let ((syntmp-a-570 (syntmp-f-568 (car syntmp-x-569))) + (syntmp-d-571 (syntmp-f-568 (cdr syntmp-x-569)))) + (if (and (eq? syntmp-a-570 (car syntmp-x-569)) + (eq? syntmp-d-571 (cdr syntmp-x-569))) + syntmp-x-569 + (cons syntmp-a-570 syntmp-d-571)))) + ((vector? syntmp-x-569) + (let ((syntmp-old-572 (vector->list syntmp-x-569))) + (let ((syntmp-new-573 + (map syntmp-f-568 syntmp-old-572))) + (if (andmap eq? syntmp-old-572 syntmp-new-573) + syntmp-x-569 + (list->vector syntmp-new-573))))) + (else syntmp-x-569)))))) + (syntmp-strip-annotation-165 + (lambda (syntmp-x-574 syntmp-parent-575) + (cond ((pair? syntmp-x-574) + (let ((syntmp-new-576 (cons #f #f))) + (begin + (if syntmp-parent-575 + (set-annotation-stripped! + syntmp-parent-575 + syntmp-new-576)) + (set-car! + syntmp-new-576 + (syntmp-strip-annotation-165 + (car syntmp-x-574) + #f)) + (set-cdr! + syntmp-new-576 + (syntmp-strip-annotation-165 + (cdr syntmp-x-574) + #f)) + syntmp-new-576))) + ((annotation? syntmp-x-574) + (or (annotation-stripped syntmp-x-574) + (syntmp-strip-annotation-165 + (annotation-expression syntmp-x-574) + syntmp-x-574))) + ((vector? syntmp-x-574) + (let ((syntmp-new-577 + (make-vector (vector-length syntmp-x-574)))) + (begin + (if syntmp-parent-575 + (set-annotation-stripped! + syntmp-parent-575 + syntmp-new-577)) + (let syntmp-loop-578 ((syntmp-i-579 + (- (vector-length syntmp-x-574) + 1))) + (unless + (syntmp-fx<-90 syntmp-i-579 0) + (vector-set! + syntmp-new-577 + syntmp-i-579 + (syntmp-strip-annotation-165 + (vector-ref syntmp-x-574 syntmp-i-579) + #f)) + (syntmp-loop-578 (syntmp-fx--88 syntmp-i-579 1)))) + syntmp-new-577))) + (else syntmp-x-574)))) + (syntmp-ellipsis?-164 + (lambda (syntmp-x-580) + (and (syntmp-nonsymbol-id?-118 syntmp-x-580) + (syntmp-free-id=?-142 + syntmp-x-580 + '#(syntax-object + ... + ((top) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage (define-structure) ((top)) ("i"))) + (ice-9 syncase)))))) + (syntmp-chi-void-163 + (lambda () + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 #f (quote void)))))) + (syntmp-eval-local-transformer-162 + (lambda (syntmp-expanded-581 syntmp-mod-582) + (let ((syntmp-p-583 + (syntmp-local-eval-hook-92 + syntmp-expanded-581 + syntmp-mod-582))) + (if (procedure? syntmp-p-583) + syntmp-p-583 + (syntax-error + syntmp-p-583 + "nonprocedure transformer"))))) + (syntmp-chi-local-syntax-161 + (lambda (syntmp-rec?-584 + syntmp-e-585 + syntmp-r-586 + syntmp-w-587 + syntmp-s-588 + syntmp-mod-589 + syntmp-k-590) + ((lambda (syntmp-tmp-591) + ((lambda (syntmp-tmp-592) + (if syntmp-tmp-592 + (apply (lambda (syntmp-_-593 + syntmp-id-594 + syntmp-val-595 + syntmp-e1-596 + syntmp-e2-597) + (let ((syntmp-ids-598 syntmp-id-594)) + (if (not (syntmp-valid-bound-ids?-144 + syntmp-ids-598)) + (syntax-error + syntmp-e-585 + "duplicate bound keyword in") + (let ((syntmp-labels-600 + (syntmp-gen-labels-125 + syntmp-ids-598))) + (let ((syntmp-new-w-601 + (syntmp-make-binding-wrap-136 + syntmp-ids-598 + syntmp-labels-600 + syntmp-w-587))) + (syntmp-k-590 + (cons syntmp-e1-596 syntmp-e2-597) + (syntmp-extend-env-113 + syntmp-labels-600 + (let ((syntmp-w-603 + (if syntmp-rec?-584 + syntmp-new-w-601 + syntmp-w-587)) + (syntmp-trans-r-604 + (syntmp-macros-only-env-115 + syntmp-r-586))) + (map (lambda (syntmp-x-605) + (cons 'macro + (syntmp-eval-local-transformer-162 + (syntmp-chi-155 + syntmp-x-605 + syntmp-trans-r-604 + syntmp-w-603 + syntmp-mod-589) + syntmp-mod-589))) + syntmp-val-595)) + syntmp-r-586) + syntmp-new-w-601 + syntmp-s-588 + syntmp-mod-589)))))) + syntmp-tmp-592) + ((lambda (syntmp-_-607) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-585 + syntmp-w-587 + syntmp-s-588 + syntmp-mod-589))) + syntmp-tmp-591))) + (syntax-dispatch + syntmp-tmp-591 + '(any #(each (any any)) any . each-any)))) + syntmp-e-585))) + (syntmp-chi-lambda-clause-160 + (lambda (syntmp-e-608 + syntmp-c-609 + syntmp-r-610 + syntmp-w-611 + syntmp-mod-612 + syntmp-k-613) + ((lambda (syntmp-tmp-614) + ((lambda (syntmp-tmp-615) + (if syntmp-tmp-615 + (apply (lambda (syntmp-id-616 syntmp-e1-617 syntmp-e2-618) + (let ((syntmp-ids-619 syntmp-id-616)) + (if (not (syntmp-valid-bound-ids?-144 + syntmp-ids-619)) + (syntax-error + syntmp-e-608 + "invalid parameter list in") + (let ((syntmp-labels-621 + (syntmp-gen-labels-125 + syntmp-ids-619)) + (syntmp-new-vars-622 + (map syntmp-gen-var-167 + syntmp-ids-619))) + (syntmp-k-613 + syntmp-new-vars-622 + (syntmp-chi-body-159 + (cons syntmp-e1-617 syntmp-e2-618) + syntmp-e-608 + (syntmp-extend-var-env-114 + syntmp-labels-621 + syntmp-new-vars-622 + syntmp-r-610) + (syntmp-make-binding-wrap-136 + syntmp-ids-619 + syntmp-labels-621 + syntmp-w-611) + syntmp-mod-612)))))) + syntmp-tmp-615) + ((lambda (syntmp-tmp-624) + (if syntmp-tmp-624 + (apply (lambda (syntmp-ids-625 + syntmp-e1-626 + syntmp-e2-627) + (let ((syntmp-old-ids-628 + (syntmp-lambda-var-list-168 + syntmp-ids-625))) + (if (not (syntmp-valid-bound-ids?-144 + syntmp-old-ids-628)) + (syntax-error + syntmp-e-608 + "invalid parameter list in") + (let ((syntmp-labels-629 + (syntmp-gen-labels-125 + syntmp-old-ids-628)) + (syntmp-new-vars-630 + (map syntmp-gen-var-167 + syntmp-old-ids-628))) + (syntmp-k-613 + (let syntmp-f-631 ((syntmp-ls1-632 + (cdr syntmp-new-vars-630)) + (syntmp-ls2-633 + (car syntmp-new-vars-630))) + (if (null? syntmp-ls1-632) + syntmp-ls2-633 + (syntmp-f-631 + (cdr syntmp-ls1-632) + (cons (car syntmp-ls1-632) + syntmp-ls2-633)))) + (syntmp-chi-body-159 + (cons syntmp-e1-626 syntmp-e2-627) + syntmp-e-608 + (syntmp-extend-var-env-114 + syntmp-labels-629 + syntmp-new-vars-630 + syntmp-r-610) + (syntmp-make-binding-wrap-136 + syntmp-old-ids-628 + syntmp-labels-629 + syntmp-w-611) + syntmp-mod-612)))))) + syntmp-tmp-624) + ((lambda (syntmp-_-635) + (syntax-error syntmp-e-608)) + syntmp-tmp-614))) + (syntax-dispatch + syntmp-tmp-614 + '(any any . each-any))))) + (syntax-dispatch + syntmp-tmp-614 + '(each-any any . each-any)))) + syntmp-c-609))) + (syntmp-chi-body-159 + (lambda (syntmp-body-636 + syntmp-outer-form-637 + syntmp-r-638 + syntmp-w-639 + syntmp-mod-640) + (let ((syntmp-r-641 + (cons '("placeholder" placeholder) + syntmp-r-638))) + (let ((syntmp-ribcage-642 + (syntmp-make-ribcage-126 + '() + '() + '()))) + (let ((syntmp-w-643 + (syntmp-make-wrap-121 + (syntmp-wrap-marks-122 syntmp-w-639) + (cons syntmp-ribcage-642 + (syntmp-wrap-subst-123 syntmp-w-639))))) + (let syntmp-parse-644 ((syntmp-body-645 + (map (lambda (syntmp-x-651) + (cons syntmp-r-641 + (syntmp-wrap-147 + syntmp-x-651 + syntmp-w-643 + syntmp-mod-640))) + syntmp-body-636)) + (syntmp-ids-646 (quote ())) + (syntmp-labels-647 (quote ())) + (syntmp-vars-648 (quote ())) + (syntmp-vals-649 (quote ())) + (syntmp-bindings-650 (quote ()))) + (if (null? syntmp-body-645) + (syntax-error + syntmp-outer-form-637 + "no expressions in body") + (let ((syntmp-e-652 (cdar syntmp-body-645)) + (syntmp-er-653 (caar syntmp-body-645))) + (call-with-values + (lambda () + (syntmp-syntax-type-153 + syntmp-e-652 + syntmp-er-653 + '(()) + #f + syntmp-ribcage-642 + syntmp-mod-640)) + (lambda (syntmp-type-654 + syntmp-value-655 + syntmp-e-656 + syntmp-w-657 + syntmp-s-658 + syntmp-mod-659) + (let ((syntmp-t-660 syntmp-type-654)) + (if (memv syntmp-t-660 (quote (define-form))) + (let ((syntmp-id-661 + (syntmp-wrap-147 + syntmp-value-655 + syntmp-w-657 + syntmp-mod-659)) + (syntmp-label-662 + (syntmp-gen-label-124))) + (let ((syntmp-var-663 + (syntmp-gen-var-167 syntmp-id-661))) + (begin + (syntmp-extend-ribcage!-135 + syntmp-ribcage-642 + syntmp-id-661 + syntmp-label-662) + (syntmp-parse-644 + (cdr syntmp-body-645) + (cons syntmp-id-661 syntmp-ids-646) + (cons syntmp-label-662 + syntmp-labels-647) + (cons syntmp-var-663 syntmp-vars-648) + (cons (cons syntmp-er-653 + (syntmp-wrap-147 + syntmp-e-656 + syntmp-w-657 + syntmp-mod-659)) + syntmp-vals-649) + (cons (cons 'lexical + syntmp-var-663) + syntmp-bindings-650))))) + (if (memv syntmp-t-660 + '(define-syntax-form)) + (let ((syntmp-id-664 + (syntmp-wrap-147 + syntmp-value-655 + syntmp-w-657 + syntmp-mod-659)) + (syntmp-label-665 + (syntmp-gen-label-124))) + (begin + (syntmp-extend-ribcage!-135 + syntmp-ribcage-642 + syntmp-id-664 + syntmp-label-665) + (syntmp-parse-644 + (cdr syntmp-body-645) + (cons syntmp-id-664 syntmp-ids-646) + (cons syntmp-label-665 + syntmp-labels-647) + syntmp-vars-648 + syntmp-vals-649 + (cons (cons 'macro + (cons syntmp-er-653 + (syntmp-wrap-147 + syntmp-e-656 + syntmp-w-657 + syntmp-mod-659))) + syntmp-bindings-650)))) + (if (memv syntmp-t-660 (quote (begin-form))) + ((lambda (syntmp-tmp-666) + ((lambda (syntmp-tmp-667) + (if syntmp-tmp-667 + (apply (lambda (syntmp-_-668 + syntmp-e1-669) + (syntmp-parse-644 + (let syntmp-f-670 ((syntmp-forms-671 + syntmp-e1-669)) + (if (null? syntmp-forms-671) + (cdr syntmp-body-645) + (cons (cons syntmp-er-653 + (syntmp-wrap-147 + (car syntmp-forms-671) + syntmp-w-657 + syntmp-mod-659)) + (syntmp-f-670 + (cdr syntmp-forms-671))))) + syntmp-ids-646 + syntmp-labels-647 + syntmp-vars-648 + syntmp-vals-649 + syntmp-bindings-650)) + syntmp-tmp-667) + (syntax-error syntmp-tmp-666))) + (syntax-dispatch + syntmp-tmp-666 + '(any . each-any)))) + syntmp-e-656) + (if (memv syntmp-t-660 + '(local-syntax-form)) + (syntmp-chi-local-syntax-161 + syntmp-value-655 + syntmp-e-656 + syntmp-er-653 + syntmp-w-657 + syntmp-s-658 + syntmp-mod-659 + (lambda (syntmp-forms-673 + syntmp-er-674 + syntmp-w-675 + syntmp-s-676 + syntmp-mod-677) + (syntmp-parse-644 + (let syntmp-f-678 ((syntmp-forms-679 + syntmp-forms-673)) + (if (null? syntmp-forms-679) + (cdr syntmp-body-645) + (cons (cons syntmp-er-674 + (syntmp-wrap-147 + (car syntmp-forms-679) + syntmp-w-675 + syntmp-mod-677)) + (syntmp-f-678 + (cdr syntmp-forms-679))))) + syntmp-ids-646 + syntmp-labels-647 + syntmp-vars-648 + syntmp-vals-649 + syntmp-bindings-650))) + (if (null? syntmp-ids-646) + (syntmp-build-sequence-98 + #f + (map (lambda (syntmp-x-680) + (syntmp-chi-155 + (cdr syntmp-x-680) + (car syntmp-x-680) + '(()) + syntmp-mod-659)) + (cons (cons syntmp-er-653 + (syntmp-source-wrap-148 + syntmp-e-656 + syntmp-w-657 + syntmp-s-658 + syntmp-mod-659)) + (cdr syntmp-body-645)))) + (begin + (if (not (syntmp-valid-bound-ids?-144 + syntmp-ids-646)) + (syntax-error + syntmp-outer-form-637 + "invalid or duplicate identifier in definition")) + (let syntmp-loop-681 ((syntmp-bs-682 + syntmp-bindings-650) + (syntmp-er-cache-683 + #f) + (syntmp-r-cache-684 + #f)) + (if (not (null? syntmp-bs-682)) + (let ((syntmp-b-685 + (car syntmp-bs-682))) + (if (eq? (car syntmp-b-685) + 'macro) + (let ((syntmp-er-686 + (cadr syntmp-b-685))) + (let ((syntmp-r-cache-687 + (if (eq? syntmp-er-686 + syntmp-er-cache-683) + syntmp-r-cache-684 + (syntmp-macros-only-env-115 + syntmp-er-686)))) + (begin + (set-cdr! + syntmp-b-685 + (syntmp-eval-local-transformer-162 + (syntmp-chi-155 + (cddr syntmp-b-685) + syntmp-r-cache-687 + '(()) + syntmp-mod-659) + syntmp-mod-659)) + (syntmp-loop-681 + (cdr syntmp-bs-682) + syntmp-er-686 + syntmp-r-cache-687)))) + (syntmp-loop-681 + (cdr syntmp-bs-682) + syntmp-er-cache-683 + syntmp-r-cache-684))))) + (set-cdr! + syntmp-r-641 + (syntmp-extend-env-113 + syntmp-labels-647 + syntmp-bindings-650 + (cdr syntmp-r-641))) + (syntmp-build-letrec-101 + #f + syntmp-vars-648 + (map (lambda (syntmp-x-688) + (syntmp-chi-155 + (cdr syntmp-x-688) + (car syntmp-x-688) + '(()) + syntmp-mod-659)) + syntmp-vals-649) + (syntmp-build-sequence-98 + #f + (map (lambda (syntmp-x-689) + (syntmp-chi-155 + (cdr syntmp-x-689) + (car syntmp-x-689) + '(()) + syntmp-mod-659)) + (cons (cons syntmp-er-653 + (syntmp-source-wrap-148 + syntmp-e-656 + syntmp-w-657 + syntmp-s-658 + syntmp-mod-659)) + (cdr syntmp-body-645)))))))))))))))))))))) + (syntmp-chi-macro-158 + (lambda (syntmp-p-690 + syntmp-e-691 + syntmp-r-692 + syntmp-w-693 + syntmp-rib-694 + syntmp-mod-695) + (letrec ((syntmp-rebuild-macro-output-696 + (lambda (syntmp-x-697 syntmp-m-698) + (cond ((pair? syntmp-x-697) + (cons (syntmp-rebuild-macro-output-696 + (car syntmp-x-697) + syntmp-m-698) + (syntmp-rebuild-macro-output-696 + (cdr syntmp-x-697) + syntmp-m-698))) + ((syntmp-syntax-object?-103 syntmp-x-697) + (let ((syntmp-w-699 + (syntmp-syntax-object-wrap-105 + syntmp-x-697))) + (let ((syntmp-ms-700 + (syntmp-wrap-marks-122 + syntmp-w-699)) + (syntmp-s-701 + (syntmp-wrap-subst-123 + syntmp-w-699))) + (if (and (pair? syntmp-ms-700) + (eq? (car syntmp-ms-700) #f)) + (syntmp-make-syntax-object-102 + (syntmp-syntax-object-expression-104 + syntmp-x-697) + (syntmp-make-wrap-121 + (cdr syntmp-ms-700) + (if syntmp-rib-694 + (cons syntmp-rib-694 + (cdr syntmp-s-701)) + (cdr syntmp-s-701))) + (syntmp-syntax-object-module-106 + syntmp-x-697)) + (syntmp-make-syntax-object-102 + (syntmp-syntax-object-expression-104 + syntmp-x-697) + (syntmp-make-wrap-121 + (cons syntmp-m-698 syntmp-ms-700) + (if syntmp-rib-694 + (cons syntmp-rib-694 + (cons 'shift + syntmp-s-701)) + (cons 'shift + syntmp-s-701))) + (module-name + (procedure-module + syntmp-p-690))))))) + ((vector? syntmp-x-697) + (let ((syntmp-n-702 + (vector-length syntmp-x-697))) + (let ((syntmp-v-703 + (make-vector syntmp-n-702))) + (let syntmp-doloop-704 ((syntmp-i-705 0)) + (if (syntmp-fx=-89 + syntmp-i-705 + syntmp-n-702) + syntmp-v-703 + (begin + (vector-set! + syntmp-v-703 + syntmp-i-705 + (syntmp-rebuild-macro-output-696 + (vector-ref + syntmp-x-697 + syntmp-i-705) + syntmp-m-698)) + (syntmp-doloop-704 + (syntmp-fx+-87 + syntmp-i-705 + 1)))))))) + ((symbol? syntmp-x-697) + (syntax-error + syntmp-x-697 + "encountered raw symbol in macro output")) + (else syntmp-x-697))))) + (syntmp-rebuild-macro-output-696 + (syntmp-p-690 + (syntmp-wrap-147 + syntmp-e-691 + (syntmp-anti-mark-134 syntmp-w-693) + syntmp-mod-695)) + (string #\m))))) + (syntmp-chi-application-157 + (lambda (syntmp-x-706 + syntmp-e-707 + syntmp-r-708 + syntmp-w-709 + syntmp-s-710 + syntmp-mod-711) + ((lambda (syntmp-tmp-712) + ((lambda (syntmp-tmp-713) + (if syntmp-tmp-713 + (apply (lambda (syntmp-e0-714 syntmp-e1-715) + (syntmp-build-annotated-96 + syntmp-s-710 + (cons syntmp-x-706 + (map (lambda (syntmp-e-716) + (syntmp-chi-155 + syntmp-e-716 + syntmp-r-708 + syntmp-w-709 + syntmp-mod-711)) + syntmp-e1-715)))) + syntmp-tmp-713) + (syntax-error syntmp-tmp-712))) + (syntax-dispatch + syntmp-tmp-712 + '(any . each-any)))) + syntmp-e-707))) + (syntmp-chi-expr-156 + (lambda (syntmp-type-718 + syntmp-value-719 + syntmp-e-720 + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + (let ((syntmp-t-725 syntmp-type-718)) + (if (memv syntmp-t-725 (quote (lexical))) + (syntmp-build-annotated-96 + syntmp-s-723 + syntmp-value-719) + (if (memv syntmp-t-725 (quote (core external-macro))) + (syntmp-value-719 + syntmp-e-720 + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + (if (memv syntmp-t-725 (quote (lexical-call))) + (syntmp-chi-application-157 + (syntmp-build-annotated-96 + (syntmp-source-annotation-110 (car syntmp-e-720)) + syntmp-value-719) + syntmp-e-720 + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + (if (memv syntmp-t-725 (quote (global-call))) + (syntmp-chi-application-157 + (syntmp-build-annotated-96 + (syntmp-source-annotation-110 (car syntmp-e-720)) + (make-module-ref + (if (syntmp-syntax-object?-103 (car syntmp-e-720)) + (syntmp-syntax-object-module-106 + (car syntmp-e-720)) + syntmp-mod-724) + syntmp-value-719 + #f)) + syntmp-e-720 + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + (if (memv syntmp-t-725 (quote (constant))) + (syntmp-build-data-97 + syntmp-s-723 + (syntmp-strip-166 + (syntmp-source-wrap-148 + syntmp-e-720 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + '(()))) + (if (memv syntmp-t-725 (quote (global))) + (syntmp-build-annotated-96 + syntmp-s-723 + (make-module-ref + syntmp-mod-724 + syntmp-value-719 + #f)) + (if (memv syntmp-t-725 (quote (call))) + (syntmp-chi-application-157 + (syntmp-chi-155 + (car syntmp-e-720) + syntmp-r-721 + syntmp-w-722 + syntmp-mod-724) + syntmp-e-720 + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + (if (memv syntmp-t-725 (quote (begin-form))) + ((lambda (syntmp-tmp-726) + ((lambda (syntmp-tmp-727) + (if syntmp-tmp-727 + (apply (lambda (syntmp-_-728 + syntmp-e1-729 + syntmp-e2-730) + (syntmp-chi-sequence-149 + (cons syntmp-e1-729 + syntmp-e2-730) + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724)) + syntmp-tmp-727) + (syntax-error syntmp-tmp-726))) + (syntax-dispatch + syntmp-tmp-726 + '(any any . each-any)))) + syntmp-e-720) + (if (memv syntmp-t-725 + '(local-syntax-form)) + (syntmp-chi-local-syntax-161 + syntmp-value-719 + syntmp-e-720 + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724 + syntmp-chi-sequence-149) + (if (memv syntmp-t-725 + '(eval-when-form)) + ((lambda (syntmp-tmp-732) + ((lambda (syntmp-tmp-733) + (if syntmp-tmp-733 + (apply (lambda (syntmp-_-734 + syntmp-x-735 + syntmp-e1-736 + syntmp-e2-737) + (let ((syntmp-when-list-738 + (syntmp-chi-when-list-152 + syntmp-e-720 + syntmp-x-735 + syntmp-w-722))) + (if (memq 'eval + syntmp-when-list-738) + (syntmp-chi-sequence-149 + (cons syntmp-e1-736 + syntmp-e2-737) + syntmp-r-721 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + (syntmp-chi-void-163)))) + syntmp-tmp-733) + (syntax-error syntmp-tmp-732))) + (syntax-dispatch + syntmp-tmp-732 + '(any each-any any . each-any)))) + syntmp-e-720) + (if (memv syntmp-t-725 + '(define-form define-syntax-form)) + (syntax-error + (syntmp-wrap-147 + syntmp-value-719 + syntmp-w-722 + syntmp-mod-724) + "invalid context for definition of") + (if (memv syntmp-t-725 (quote (syntax))) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-720 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + "reference to pattern variable outside syntax form") + (if (memv syntmp-t-725 + '(displaced-lexical)) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-720 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724) + "reference to identifier outside its scope") + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-720 + syntmp-w-722 + syntmp-s-723 + syntmp-mod-724)))))))))))))))))) + (syntmp-chi-155 + (lambda (syntmp-e-741 + syntmp-r-742 + syntmp-w-743 + syntmp-mod-744) + (call-with-values + (lambda () + (syntmp-syntax-type-153 + syntmp-e-741 + syntmp-r-742 + syntmp-w-743 + #f + #f + syntmp-mod-744)) + (lambda (syntmp-type-745 + syntmp-value-746 + syntmp-e-747 + syntmp-w-748 + syntmp-s-749 + syntmp-mod-750) + (syntmp-chi-expr-156 + syntmp-type-745 + syntmp-value-746 + syntmp-e-747 + syntmp-r-742 + syntmp-w-748 + syntmp-s-749 + syntmp-mod-750))))) + (syntmp-chi-top-154 + (lambda (syntmp-e-751 + syntmp-r-752 + syntmp-w-753 + syntmp-m-754 + syntmp-esew-755 + syntmp-mod-756) + (call-with-values + (lambda () + (syntmp-syntax-type-153 + syntmp-e-751 + syntmp-r-752 + syntmp-w-753 + #f + #f + syntmp-mod-756)) + (lambda (syntmp-type-771 + syntmp-value-772 + syntmp-e-773 + syntmp-w-774 + syntmp-s-775 + syntmp-mod-776) + (let ((syntmp-t-777 syntmp-type-771)) + (if (memv syntmp-t-777 (quote (begin-form))) + ((lambda (syntmp-tmp-778) + ((lambda (syntmp-tmp-779) + (if syntmp-tmp-779 + (apply (lambda (syntmp-_-780) + (syntmp-chi-void-163)) + syntmp-tmp-779) + ((lambda (syntmp-tmp-781) + (if syntmp-tmp-781 + (apply (lambda (syntmp-_-782 + syntmp-e1-783 + syntmp-e2-784) + (syntmp-chi-top-sequence-150 + (cons syntmp-e1-783 syntmp-e2-784) + syntmp-r-752 + syntmp-w-774 + syntmp-s-775 + syntmp-m-754 + syntmp-esew-755 + syntmp-mod-776)) + syntmp-tmp-781) + (syntax-error syntmp-tmp-778))) + (syntax-dispatch + syntmp-tmp-778 + '(any any . each-any))))) + (syntax-dispatch syntmp-tmp-778 (quote (any))))) + syntmp-e-773) + (if (memv syntmp-t-777 (quote (local-syntax-form))) + (syntmp-chi-local-syntax-161 + syntmp-value-772 + syntmp-e-773 + syntmp-r-752 + syntmp-w-774 + syntmp-s-775 + syntmp-mod-776 + (lambda (syntmp-body-786 + syntmp-r-787 + syntmp-w-788 + syntmp-s-789 + syntmp-mod-790) + (syntmp-chi-top-sequence-150 + syntmp-body-786 + syntmp-r-787 + syntmp-w-788 + syntmp-s-789 + syntmp-m-754 + syntmp-esew-755 + syntmp-mod-790))) + (if (memv syntmp-t-777 (quote (eval-when-form))) + ((lambda (syntmp-tmp-791) + ((lambda (syntmp-tmp-792) + (if syntmp-tmp-792 + (apply (lambda (syntmp-_-793 + syntmp-x-794 + syntmp-e1-795 + syntmp-e2-796) + (let ((syntmp-when-list-797 + (syntmp-chi-when-list-152 + syntmp-e-773 + syntmp-x-794 + syntmp-w-774)) + (syntmp-body-798 + (cons syntmp-e1-795 + syntmp-e2-796))) + (cond ((eq? syntmp-m-754 (quote e)) + (if (memq 'eval + syntmp-when-list-797) + (syntmp-chi-top-sequence-150 + syntmp-body-798 + syntmp-r-752 + syntmp-w-774 + syntmp-s-775 + 'e + '(eval) + syntmp-mod-776) + (syntmp-chi-void-163))) + ((memq 'load + syntmp-when-list-797) + (if (or (memq 'compile + syntmp-when-list-797) + (and (eq? syntmp-m-754 + 'c&e) + (memq 'eval + syntmp-when-list-797))) + (syntmp-chi-top-sequence-150 + syntmp-body-798 + syntmp-r-752 + syntmp-w-774 + syntmp-s-775 + 'c&e + '(compile load) + syntmp-mod-776) + (if (memq syntmp-m-754 + '(c c&e)) + (syntmp-chi-top-sequence-150 + syntmp-body-798 + syntmp-r-752 + syntmp-w-774 + syntmp-s-775 + 'c + '(load) + syntmp-mod-776) + (syntmp-chi-void-163)))) + ((or (memq 'compile + syntmp-when-list-797) + (and (eq? syntmp-m-754 + 'c&e) + (memq 'eval + syntmp-when-list-797))) + (syntmp-top-level-eval-hook-91 + (syntmp-chi-top-sequence-150 + syntmp-body-798 + syntmp-r-752 + syntmp-w-774 + syntmp-s-775 + 'e + '(eval) + syntmp-mod-776) + syntmp-mod-776) + (syntmp-chi-void-163)) + (else + (syntmp-chi-void-163))))) + syntmp-tmp-792) + (syntax-error syntmp-tmp-791))) + (syntax-dispatch + syntmp-tmp-791 + '(any each-any any . each-any)))) + syntmp-e-773) + (if (memv syntmp-t-777 (quote (define-syntax-form))) + (let ((syntmp-n-801 + (syntmp-id-var-name-141 + syntmp-value-772 + syntmp-w-774)) + (syntmp-r-802 + (syntmp-macros-only-env-115 syntmp-r-752))) + (let ((syntmp-t-803 syntmp-m-754)) + (if (memv syntmp-t-803 (quote (c))) + (if (memq (quote compile) syntmp-esew-755) + (let ((syntmp-e-804 + (syntmp-chi-install-global-151 + syntmp-n-801 + (syntmp-chi-155 + syntmp-e-773 + syntmp-r-802 + syntmp-w-774 + syntmp-mod-776)))) + (begin + (syntmp-top-level-eval-hook-91 + syntmp-e-804 + syntmp-mod-776) + (if (memq (quote load) syntmp-esew-755) + syntmp-e-804 + (syntmp-chi-void-163)))) + (if (memq (quote load) syntmp-esew-755) + (syntmp-chi-install-global-151 + syntmp-n-801 + (syntmp-chi-155 + syntmp-e-773 + syntmp-r-802 + syntmp-w-774 + syntmp-mod-776)) + (syntmp-chi-void-163))) + (if (memv syntmp-t-803 (quote (c&e))) + (let ((syntmp-e-805 + (syntmp-chi-install-global-151 + syntmp-n-801 + (syntmp-chi-155 + syntmp-e-773 + syntmp-r-802 + syntmp-w-774 + syntmp-mod-776)))) + (begin + (syntmp-top-level-eval-hook-91 + syntmp-e-805 + syntmp-mod-776) + syntmp-e-805)) + (begin + (if (memq (quote eval) syntmp-esew-755) + (syntmp-top-level-eval-hook-91 + (syntmp-chi-install-global-151 + syntmp-n-801 + (syntmp-chi-155 + syntmp-e-773 + syntmp-r-802 + syntmp-w-774 + syntmp-mod-776)) + syntmp-mod-776)) + (syntmp-chi-void-163)))))) + (if (memv syntmp-t-777 (quote (define-form))) + (let ((syntmp-n-806 + (syntmp-id-var-name-141 + syntmp-value-772 + syntmp-w-774))) + (let ((syntmp-type-807 + (syntmp-binding-type-111 + (syntmp-lookup-116 + syntmp-n-806 + syntmp-r-752 + syntmp-mod-776)))) + (let ((syntmp-t-808 syntmp-type-807)) + (if (memv syntmp-t-808 (quote (global))) + (let ((syntmp-x-809 + (syntmp-build-annotated-96 + syntmp-s-775 + (list 'define + syntmp-n-806 + (syntmp-chi-155 + syntmp-e-773 + syntmp-r-752 + syntmp-w-774 + syntmp-mod-776))))) + (begin + (if (eq? syntmp-m-754 (quote c&e)) + (syntmp-top-level-eval-hook-91 + syntmp-x-809 + syntmp-mod-776)) + syntmp-x-809)) + (if (memv syntmp-t-808 + '(displaced-lexical)) + (syntax-error + (syntmp-wrap-147 + syntmp-value-772 + syntmp-w-774 + syntmp-mod-776) + "identifier out of context") + (if (eq? syntmp-type-807 + 'external-macro) + (let ((syntmp-x-810 + (syntmp-build-annotated-96 + syntmp-s-775 + (list 'define + syntmp-n-806 + (syntmp-chi-155 + syntmp-e-773 + syntmp-r-752 + syntmp-w-774 + syntmp-mod-776))))) + (begin + (if (eq? syntmp-m-754 (quote c&e)) + (syntmp-top-level-eval-hook-91 + syntmp-x-810 + syntmp-mod-776)) + syntmp-x-810)) + (syntax-error + (syntmp-wrap-147 + syntmp-value-772 + syntmp-w-774 + syntmp-mod-776) + "cannot define keyword at top level"))))))) + (let ((syntmp-x-811 + (syntmp-chi-expr-156 + syntmp-type-771 + syntmp-value-772 + syntmp-e-773 + syntmp-r-752 + syntmp-w-774 + syntmp-s-775 + syntmp-mod-776))) + (begin + (if (eq? syntmp-m-754 (quote c&e)) + (syntmp-top-level-eval-hook-91 + syntmp-x-811 + syntmp-mod-776)) + syntmp-x-811)))))))))))) + (syntmp-syntax-type-153 + (lambda (syntmp-e-812 + syntmp-r-813 + syntmp-w-814 + syntmp-s-815 + syntmp-rib-816 + syntmp-mod-817) + (cond ((symbol? syntmp-e-812) + (let ((syntmp-n-818 + (syntmp-id-var-name-141 + syntmp-e-812 + syntmp-w-814))) + (let ((syntmp-b-819 + (syntmp-lookup-116 + syntmp-n-818 + syntmp-r-813 + syntmp-mod-817))) + (let ((syntmp-type-820 + (syntmp-binding-type-111 syntmp-b-819))) + (let ((syntmp-t-821 syntmp-type-820)) + (if (memv syntmp-t-821 (quote (lexical))) + (values + syntmp-type-820 + (syntmp-binding-value-112 syntmp-b-819) + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-821 (quote (global))) + (values + syntmp-type-820 + syntmp-n-818 + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-821 (quote (macro))) + (syntmp-syntax-type-153 + (syntmp-chi-macro-158 + (syntmp-binding-value-112 syntmp-b-819) + syntmp-e-812 + syntmp-r-813 + syntmp-w-814 + syntmp-rib-816 + syntmp-mod-817) + syntmp-r-813 + '(()) + syntmp-s-815 + syntmp-rib-816 + syntmp-mod-817) + (values + syntmp-type-820 + (syntmp-binding-value-112 syntmp-b-819) + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817))))))))) + ((pair? syntmp-e-812) + (let ((syntmp-first-822 (car syntmp-e-812))) + (if (syntmp-id?-119 syntmp-first-822) + (let ((syntmp-n-823 + (syntmp-id-var-name-141 + syntmp-first-822 + syntmp-w-814))) + (let ((syntmp-b-824 + (syntmp-lookup-116 + syntmp-n-823 + syntmp-r-813 + syntmp-mod-817))) + (let ((syntmp-type-825 + (syntmp-binding-type-111 syntmp-b-824))) + (let ((syntmp-t-826 syntmp-type-825)) + (if (memv syntmp-t-826 (quote (lexical))) + (values + 'lexical-call + (syntmp-binding-value-112 syntmp-b-824) + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-826 (quote (global))) + (values + 'global-call + syntmp-n-823 + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-826 (quote (macro))) + (syntmp-syntax-type-153 + (syntmp-chi-macro-158 + (syntmp-binding-value-112 + syntmp-b-824) + syntmp-e-812 + syntmp-r-813 + syntmp-w-814 + syntmp-rib-816 + syntmp-mod-817) + syntmp-r-813 + '(()) + syntmp-s-815 + syntmp-rib-816 + syntmp-mod-817) + (if (memv syntmp-t-826 + '(core external-macro)) + (values + syntmp-type-825 + (syntmp-binding-value-112 + syntmp-b-824) + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-826 + '(local-syntax)) + (values + 'local-syntax-form + (syntmp-binding-value-112 + syntmp-b-824) + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-826 + '(begin)) + (values + 'begin-form + #f + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-826 + '(eval-when)) + (values + 'eval-when-form + #f + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817) + (if (memv syntmp-t-826 + '(define)) + ((lambda (syntmp-tmp-827) + ((lambda (syntmp-tmp-828) + (if (if syntmp-tmp-828 + (apply (lambda (syntmp-_-829 + syntmp-name-830 + syntmp-val-831) + (syntmp-id?-119 + syntmp-name-830)) + syntmp-tmp-828) + #f) + (apply (lambda (syntmp-_-832 + syntmp-name-833 + syntmp-val-834) + (values + 'define-form + syntmp-name-833 + syntmp-val-834 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817)) + syntmp-tmp-828) + ((lambda (syntmp-tmp-835) + (if (if syntmp-tmp-835 + (apply (lambda (syntmp-_-836 + syntmp-name-837 + syntmp-args-838 + syntmp-e1-839 + syntmp-e2-840) + (and (syntmp-id?-119 + syntmp-name-837) + (syntmp-valid-bound-ids?-144 + (syntmp-lambda-var-list-168 + syntmp-args-838)))) + syntmp-tmp-835) + #f) + (apply (lambda (syntmp-_-841 + syntmp-name-842 + syntmp-args-843 + syntmp-e1-844 + syntmp-e2-845) + (values + 'define-form + (syntmp-wrap-147 + syntmp-name-842 + syntmp-w-814 + syntmp-mod-817) + (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ + name + args + e1 + e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(t) + #(("m" + top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(type) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(b) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(n) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(first) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib + mod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure) + ((top)) + ("i"))) + (ice-9 syncase)) + (syntmp-wrap-147 + (cons syntmp-args-843 + (cons syntmp-e1-844 + syntmp-e2-845)) + syntmp-w-814 + syntmp-mod-817)) + '(()) + syntmp-s-815 + syntmp-mod-817)) + syntmp-tmp-835) + ((lambda (syntmp-tmp-847) + (if (if syntmp-tmp-847 + (apply (lambda (syntmp-_-848 + syntmp-name-849) + (syntmp-id?-119 + syntmp-name-849)) + syntmp-tmp-847) + #f) + (apply (lambda (syntmp-_-850 + syntmp-name-851) + (values + 'define-form + (syntmp-wrap-147 + syntmp-name-851 + syntmp-w-814 + syntmp-mod-817) + '(#(syntax-object + void + ((top) + #(ribcage + #(_ + name) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(t) + #(("m" + top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(type) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(b) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(n) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(first) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib + mod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure) + ((top)) + ("i"))) + (ice-9 syncase))) + '(()) + syntmp-s-815 + syntmp-mod-817)) + syntmp-tmp-847) + (syntax-error + syntmp-tmp-827))) + (syntax-dispatch + syntmp-tmp-827 + '(any any))))) + (syntax-dispatch + syntmp-tmp-827 + '(any (any . any) + any + . + each-any))))) + (syntax-dispatch + syntmp-tmp-827 + '(any any any)))) + syntmp-e-812) + (if (memv syntmp-t-826 + '(define-syntax)) + ((lambda (syntmp-tmp-852) + ((lambda (syntmp-tmp-853) + (if (if syntmp-tmp-853 + (apply (lambda (syntmp-_-854 + syntmp-name-855 + syntmp-val-856) + (syntmp-id?-119 + syntmp-name-855)) + syntmp-tmp-853) + #f) + (apply (lambda (syntmp-_-857 + syntmp-name-858 + syntmp-val-859) + (values + 'define-syntax-form + syntmp-name-858 + syntmp-val-859 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817)) + syntmp-tmp-853) + (syntax-error + syntmp-tmp-852))) + (syntax-dispatch + syntmp-tmp-852 + '(any any any)))) + syntmp-e-812) + (values + 'call + #f + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817)))))))))))))) + (values + 'call + #f + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817)))) + ((syntmp-syntax-object?-103 syntmp-e-812) + (syntmp-syntax-type-153 + (syntmp-syntax-object-expression-104 + syntmp-e-812) + syntmp-r-813 + (syntmp-join-wraps-138 + syntmp-w-814 + (syntmp-syntax-object-wrap-105 syntmp-e-812)) + #f + syntmp-rib-816 + (or (syntmp-syntax-object-module-106 syntmp-e-812) + syntmp-mod-817))) + ((annotation? syntmp-e-812) + (syntmp-syntax-type-153 + (annotation-expression syntmp-e-812) + syntmp-r-813 + syntmp-w-814 + (annotation-source syntmp-e-812) + syntmp-rib-816 + syntmp-mod-817)) + ((self-evaluating? syntmp-e-812) + (values + 'constant + #f + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817)) + (else + (values + 'other + #f + syntmp-e-812 + syntmp-w-814 + syntmp-s-815 + syntmp-mod-817))))) + (syntmp-chi-when-list-152 + (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) + (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) + (syntmp-situations-865 (quote ()))) + (if (null? syntmp-when-list-864) + syntmp-situations-865 + (syntmp-f-863 + (cdr syntmp-when-list-864) + (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) + (cond ((syntmp-free-id=?-142 + syntmp-x-866 + '#(syntax-object + compile + ((top) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(f when-list situations) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure) + ((top)) + ("i"))) + (ice-9 syncase))) + 'compile) + ((syntmp-free-id=?-142 + syntmp-x-866 + '#(syntax-object + load + ((top) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(f when-list situations) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure) + ((top)) + ("i"))) + (ice-9 syncase))) + 'load) + ((syntmp-free-id=?-142 + syntmp-x-866 + '#(syntax-object + eval + ((top) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(f when-list situations) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure) + ((top)) + ("i"))) + (ice-9 syncase))) + 'eval) + (else + (syntax-error + (syntmp-wrap-147 + syntmp-x-866 + syntmp-w-862 + #f) + "invalid eval-when situation")))) + syntmp-situations-865)))))) + (syntmp-chi-install-global-151 + (lambda (syntmp-name-877 syntmp-e-878) + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 + #f + 'install-global-transformer) + (syntmp-build-data-97 #f syntmp-name-877) + syntmp-e-878)))) + (syntmp-chi-top-sequence-150 + (lambda (syntmp-body-879 + syntmp-r-880 + syntmp-w-881 + syntmp-s-882 + syntmp-m-883 + syntmp-esew-884 + syntmp-mod-885) + (syntmp-build-sequence-98 + syntmp-s-882 + (let syntmp-dobody-886 ((syntmp-body-887 syntmp-body-879) + (syntmp-r-888 syntmp-r-880) + (syntmp-w-889 syntmp-w-881) + (syntmp-m-890 syntmp-m-883) + (syntmp-esew-891 syntmp-esew-884) + (syntmp-mod-892 syntmp-mod-885)) + (if (null? syntmp-body-887) + '() + (let ((syntmp-first-893 + (syntmp-chi-top-154 + (car syntmp-body-887) + syntmp-r-888 + syntmp-w-889 + syntmp-m-890 + syntmp-esew-891 + syntmp-mod-892))) + (cons syntmp-first-893 + (syntmp-dobody-886 + (cdr syntmp-body-887) + syntmp-r-888 + syntmp-w-889 + syntmp-m-890 + syntmp-esew-891 + syntmp-mod-892)))))))) + (syntmp-chi-sequence-149 + (lambda (syntmp-body-894 + syntmp-r-895 + syntmp-w-896 + syntmp-s-897 + syntmp-mod-898) + (syntmp-build-sequence-98 + syntmp-s-897 + (let syntmp-dobody-899 ((syntmp-body-900 syntmp-body-894) + (syntmp-r-901 syntmp-r-895) + (syntmp-w-902 syntmp-w-896) + (syntmp-mod-903 syntmp-mod-898)) + (if (null? syntmp-body-900) + '() + (let ((syntmp-first-904 + (syntmp-chi-155 + (car syntmp-body-900) + syntmp-r-901 + syntmp-w-902 + syntmp-mod-903))) + (cons syntmp-first-904 + (syntmp-dobody-899 + (cdr syntmp-body-900) + syntmp-r-901 + syntmp-w-902 + syntmp-mod-903)))))))) + (syntmp-source-wrap-148 + (lambda (syntmp-x-905 + syntmp-w-906 + syntmp-s-907 + syntmp-defmod-908) + (syntmp-wrap-147 + (if syntmp-s-907 + (make-annotation syntmp-x-905 syntmp-s-907 #f) + syntmp-x-905) + syntmp-w-906 + syntmp-defmod-908))) + (syntmp-wrap-147 + (lambda (syntmp-x-909 syntmp-w-910 syntmp-defmod-911) + (cond ((and (null? (syntmp-wrap-marks-122 syntmp-w-910)) + (null? (syntmp-wrap-subst-123 syntmp-w-910))) + syntmp-x-909) + ((syntmp-syntax-object?-103 syntmp-x-909) + (syntmp-make-syntax-object-102 + (syntmp-syntax-object-expression-104 + syntmp-x-909) + (syntmp-join-wraps-138 + syntmp-w-910 + (syntmp-syntax-object-wrap-105 syntmp-x-909)) + (syntmp-syntax-object-module-106 syntmp-x-909))) + ((null? syntmp-x-909) syntmp-x-909) + (else + (syntmp-make-syntax-object-102 + syntmp-x-909 + syntmp-w-910 + syntmp-defmod-911))))) + (syntmp-bound-id-member?-146 + (lambda (syntmp-x-912 syntmp-list-913) + (and (not (null? syntmp-list-913)) + (or (syntmp-bound-id=?-143 + syntmp-x-912 + (car syntmp-list-913)) + (syntmp-bound-id-member?-146 + syntmp-x-912 + (cdr syntmp-list-913)))))) + (syntmp-distinct-bound-ids?-145 + (lambda (syntmp-ids-914) + (let syntmp-distinct?-915 ((syntmp-ids-916 syntmp-ids-914)) + (or (null? syntmp-ids-916) + (and (not (syntmp-bound-id-member?-146 + (car syntmp-ids-916) + (cdr syntmp-ids-916))) + (syntmp-distinct?-915 (cdr syntmp-ids-916))))))) + (syntmp-valid-bound-ids?-144 + (lambda (syntmp-ids-917) + (and (let syntmp-all-ids?-918 ((syntmp-ids-919 syntmp-ids-917)) + (or (null? syntmp-ids-919) + (and (syntmp-id?-119 (car syntmp-ids-919)) + (syntmp-all-ids?-918 (cdr syntmp-ids-919))))) + (syntmp-distinct-bound-ids?-145 syntmp-ids-917)))) + (syntmp-bound-id=?-143 + (lambda (syntmp-i-920 syntmp-j-921) + (if (and (syntmp-syntax-object?-103 syntmp-i-920) + (syntmp-syntax-object?-103 syntmp-j-921)) + (and (eq? (let ((syntmp-e-922 + (syntmp-syntax-object-expression-104 + syntmp-i-920))) + (if (annotation? syntmp-e-922) + (annotation-expression syntmp-e-922) + syntmp-e-922)) + (let ((syntmp-e-923 + (syntmp-syntax-object-expression-104 + syntmp-j-921))) + (if (annotation? syntmp-e-923) + (annotation-expression syntmp-e-923) + syntmp-e-923))) + (syntmp-same-marks?-140 + (syntmp-wrap-marks-122 + (syntmp-syntax-object-wrap-105 syntmp-i-920)) + (syntmp-wrap-marks-122 + (syntmp-syntax-object-wrap-105 syntmp-j-921)))) + (eq? (let ((syntmp-e-924 syntmp-i-920)) + (if (annotation? syntmp-e-924) + (annotation-expression syntmp-e-924) + syntmp-e-924)) + (let ((syntmp-e-925 syntmp-j-921)) + (if (annotation? syntmp-e-925) + (annotation-expression syntmp-e-925) + syntmp-e-925)))))) + (syntmp-free-id=?-142 + (lambda (syntmp-i-926 syntmp-j-927) + (and (eq? (let ((syntmp-x-928 syntmp-i-926)) + (let ((syntmp-e-929 + (if (syntmp-syntax-object?-103 syntmp-x-928) + (syntmp-syntax-object-expression-104 + syntmp-x-928) + syntmp-x-928))) + (if (annotation? syntmp-e-929) + (annotation-expression syntmp-e-929) + syntmp-e-929))) + (let ((syntmp-x-930 syntmp-j-927)) + (let ((syntmp-e-931 + (if (syntmp-syntax-object?-103 syntmp-x-930) + (syntmp-syntax-object-expression-104 + syntmp-x-930) + syntmp-x-930))) + (if (annotation? syntmp-e-931) + (annotation-expression syntmp-e-931) + syntmp-e-931)))) + (eq? (syntmp-id-var-name-141 + syntmp-i-926 + '(())) + (syntmp-id-var-name-141 + syntmp-j-927 + '(())))))) + (syntmp-id-var-name-141 + (lambda (syntmp-id-932 syntmp-w-933) + (letrec ((syntmp-search-vector-rib-936 + (lambda (syntmp-sym-947 + syntmp-subst-948 + syntmp-marks-949 + syntmp-symnames-950 + syntmp-ribcage-951) + (let ((syntmp-n-952 + (vector-length syntmp-symnames-950))) + (let syntmp-f-953 ((syntmp-i-954 0)) + (cond ((syntmp-fx=-89 syntmp-i-954 syntmp-n-952) + (syntmp-search-934 + syntmp-sym-947 + (cdr syntmp-subst-948) + syntmp-marks-949)) + ((and (eq? (vector-ref + syntmp-symnames-950 + syntmp-i-954) + syntmp-sym-947) + (syntmp-same-marks?-140 + syntmp-marks-949 + (vector-ref + (syntmp-ribcage-marks-129 + syntmp-ribcage-951) + syntmp-i-954))) + (values + (vector-ref + (syntmp-ribcage-labels-130 + syntmp-ribcage-951) + syntmp-i-954) + syntmp-marks-949)) + (else + (syntmp-f-953 + (syntmp-fx+-87 syntmp-i-954 1)))))))) + (syntmp-search-list-rib-935 + (lambda (syntmp-sym-955 + syntmp-subst-956 + syntmp-marks-957 + syntmp-symnames-958 + syntmp-ribcage-959) + (let syntmp-f-960 ((syntmp-symnames-961 + syntmp-symnames-958) + (syntmp-i-962 0)) + (cond ((null? syntmp-symnames-961) + (syntmp-search-934 + syntmp-sym-955 + (cdr syntmp-subst-956) + syntmp-marks-957)) + ((and (eq? (car syntmp-symnames-961) + syntmp-sym-955) + (syntmp-same-marks?-140 + syntmp-marks-957 + (list-ref + (syntmp-ribcage-marks-129 + syntmp-ribcage-959) + syntmp-i-962))) + (values + (list-ref + (syntmp-ribcage-labels-130 + syntmp-ribcage-959) + syntmp-i-962) + syntmp-marks-957)) + (else + (syntmp-f-960 + (cdr syntmp-symnames-961) + (syntmp-fx+-87 syntmp-i-962 1))))))) + (syntmp-search-934 + (lambda (syntmp-sym-963 + syntmp-subst-964 + syntmp-marks-965) + (if (null? syntmp-subst-964) + (values #f syntmp-marks-965) + (let ((syntmp-fst-966 (car syntmp-subst-964))) + (if (eq? syntmp-fst-966 (quote shift)) + (syntmp-search-934 + syntmp-sym-963 + (cdr syntmp-subst-964) + (cdr syntmp-marks-965)) + (let ((syntmp-symnames-967 + (syntmp-ribcage-symnames-128 + syntmp-fst-966))) + (if (vector? syntmp-symnames-967) + (syntmp-search-vector-rib-936 + syntmp-sym-963 + syntmp-subst-964 + syntmp-marks-965 + syntmp-symnames-967 + syntmp-fst-966) + (syntmp-search-list-rib-935 + syntmp-sym-963 + syntmp-subst-964 + syntmp-marks-965 + syntmp-symnames-967 + syntmp-fst-966))))))))) + (cond ((symbol? syntmp-id-932) + (or (call-with-values + (lambda () + (syntmp-search-934 + syntmp-id-932 + (syntmp-wrap-subst-123 syntmp-w-933) + (syntmp-wrap-marks-122 syntmp-w-933))) + (lambda (syntmp-x-969 . syntmp-ignore-968) + syntmp-x-969)) + syntmp-id-932)) + ((syntmp-syntax-object?-103 syntmp-id-932) + (let ((syntmp-id-970 + (let ((syntmp-e-972 + (syntmp-syntax-object-expression-104 + syntmp-id-932))) + (if (annotation? syntmp-e-972) + (annotation-expression syntmp-e-972) + syntmp-e-972))) + (syntmp-w1-971 + (syntmp-syntax-object-wrap-105 syntmp-id-932))) + (let ((syntmp-marks-973 + (syntmp-join-marks-139 + (syntmp-wrap-marks-122 syntmp-w-933) + (syntmp-wrap-marks-122 syntmp-w1-971)))) + (call-with-values + (lambda () + (syntmp-search-934 + syntmp-id-970 + (syntmp-wrap-subst-123 syntmp-w-933) + syntmp-marks-973)) + (lambda (syntmp-new-id-974 syntmp-marks-975) + (or syntmp-new-id-974 + (call-with-values + (lambda () + (syntmp-search-934 + syntmp-id-970 + (syntmp-wrap-subst-123 syntmp-w1-971) + syntmp-marks-975)) + (lambda (syntmp-x-977 . syntmp-ignore-976) + syntmp-x-977)) + syntmp-id-970)))))) + ((annotation? syntmp-id-932) + (let ((syntmp-id-978 + (let ((syntmp-e-979 syntmp-id-932)) + (if (annotation? syntmp-e-979) + (annotation-expression syntmp-e-979) + syntmp-e-979)))) + (or (call-with-values + (lambda () + (syntmp-search-934 + syntmp-id-978 + (syntmp-wrap-subst-123 syntmp-w-933) + (syntmp-wrap-marks-122 syntmp-w-933))) + (lambda (syntmp-x-981 . syntmp-ignore-980) + syntmp-x-981)) + syntmp-id-978))) + (else + (syntmp-error-hook-93 + 'id-var-name + "invalid id" + syntmp-id-932)))))) + (syntmp-same-marks?-140 + (lambda (syntmp-x-982 syntmp-y-983) + (or (eq? syntmp-x-982 syntmp-y-983) + (and (not (null? syntmp-x-982)) + (not (null? syntmp-y-983)) + (eq? (car syntmp-x-982) (car syntmp-y-983)) + (syntmp-same-marks?-140 + (cdr syntmp-x-982) + (cdr syntmp-y-983)))))) + (syntmp-join-marks-139 + (lambda (syntmp-m1-984 syntmp-m2-985) + (syntmp-smart-append-137 + syntmp-m1-984 + syntmp-m2-985))) + (syntmp-join-wraps-138 + (lambda (syntmp-w1-986 syntmp-w2-987) + (let ((syntmp-m1-988 + (syntmp-wrap-marks-122 syntmp-w1-986)) + (syntmp-s1-989 + (syntmp-wrap-subst-123 syntmp-w1-986))) + (if (null? syntmp-m1-988) + (if (null? syntmp-s1-989) + syntmp-w2-987 + (syntmp-make-wrap-121 + (syntmp-wrap-marks-122 syntmp-w2-987) + (syntmp-smart-append-137 + syntmp-s1-989 + (syntmp-wrap-subst-123 syntmp-w2-987)))) + (syntmp-make-wrap-121 + (syntmp-smart-append-137 + syntmp-m1-988 + (syntmp-wrap-marks-122 syntmp-w2-987)) + (syntmp-smart-append-137 + syntmp-s1-989 + (syntmp-wrap-subst-123 syntmp-w2-987))))))) + (syntmp-smart-append-137 + (lambda (syntmp-m1-990 syntmp-m2-991) + (if (null? syntmp-m2-991) + syntmp-m1-990 + (append syntmp-m1-990 syntmp-m2-991)))) + (syntmp-make-binding-wrap-136 + (lambda (syntmp-ids-992 syntmp-labels-993 syntmp-w-994) + (if (null? syntmp-ids-992) + syntmp-w-994 + (syntmp-make-wrap-121 + (syntmp-wrap-marks-122 syntmp-w-994) + (cons (let ((syntmp-labelvec-995 + (list->vector syntmp-labels-993))) + (let ((syntmp-n-996 + (vector-length syntmp-labelvec-995))) + (let ((syntmp-symnamevec-997 + (make-vector syntmp-n-996)) + (syntmp-marksvec-998 + (make-vector syntmp-n-996))) + (begin + (let syntmp-f-999 ((syntmp-ids-1000 + syntmp-ids-992) + (syntmp-i-1001 0)) + (if (not (null? syntmp-ids-1000)) + (call-with-values + (lambda () + (syntmp-id-sym-name&marks-120 + (car syntmp-ids-1000) + syntmp-w-994)) + (lambda (syntmp-symname-1002 + syntmp-marks-1003) + (begin + (vector-set! + syntmp-symnamevec-997 + syntmp-i-1001 + syntmp-symname-1002) + (vector-set! + syntmp-marksvec-998 + syntmp-i-1001 + syntmp-marks-1003) + (syntmp-f-999 + (cdr syntmp-ids-1000) + (syntmp-fx+-87 + syntmp-i-1001 + 1))))))) + (syntmp-make-ribcage-126 + syntmp-symnamevec-997 + syntmp-marksvec-998 + syntmp-labelvec-995))))) + (syntmp-wrap-subst-123 syntmp-w-994)))))) + (syntmp-extend-ribcage!-135 + (lambda (syntmp-ribcage-1004 + syntmp-id-1005 + syntmp-label-1006) + (begin + (syntmp-set-ribcage-symnames!-131 + syntmp-ribcage-1004 + (cons (let ((syntmp-e-1007 + (syntmp-syntax-object-expression-104 + syntmp-id-1005))) + (if (annotation? syntmp-e-1007) + (annotation-expression syntmp-e-1007) + syntmp-e-1007)) + (syntmp-ribcage-symnames-128 syntmp-ribcage-1004))) + (syntmp-set-ribcage-marks!-132 + syntmp-ribcage-1004 + (cons (syntmp-wrap-marks-122 + (syntmp-syntax-object-wrap-105 syntmp-id-1005)) + (syntmp-ribcage-marks-129 syntmp-ribcage-1004))) + (syntmp-set-ribcage-labels!-133 + syntmp-ribcage-1004 + (cons syntmp-label-1006 + (syntmp-ribcage-labels-130 syntmp-ribcage-1004)))))) + (syntmp-anti-mark-134 + (lambda (syntmp-w-1008) + (syntmp-make-wrap-121 + (cons #f (syntmp-wrap-marks-122 syntmp-w-1008)) + (cons 'shift + (syntmp-wrap-subst-123 syntmp-w-1008))))) + (syntmp-set-ribcage-labels!-133 + (lambda (syntmp-x-1009 syntmp-update-1010) + (vector-set! syntmp-x-1009 3 syntmp-update-1010))) + (syntmp-set-ribcage-marks!-132 + (lambda (syntmp-x-1011 syntmp-update-1012) + (vector-set! syntmp-x-1011 2 syntmp-update-1012))) + (syntmp-set-ribcage-symnames!-131 + (lambda (syntmp-x-1013 syntmp-update-1014) + (vector-set! syntmp-x-1013 1 syntmp-update-1014))) + (syntmp-ribcage-labels-130 + (lambda (syntmp-x-1015) + (vector-ref syntmp-x-1015 3))) + (syntmp-ribcage-marks-129 + (lambda (syntmp-x-1016) + (vector-ref syntmp-x-1016 2))) + (syntmp-ribcage-symnames-128 + (lambda (syntmp-x-1017) + (vector-ref syntmp-x-1017 1))) + (syntmp-ribcage?-127 + (lambda (syntmp-x-1018) + (and (vector? syntmp-x-1018) + (= (vector-length syntmp-x-1018) 4) + (eq? (vector-ref syntmp-x-1018 0) + 'ribcage)))) + (syntmp-make-ribcage-126 + (lambda (syntmp-symnames-1019 + syntmp-marks-1020 + syntmp-labels-1021) + (vector + 'ribcage + syntmp-symnames-1019 + syntmp-marks-1020 + syntmp-labels-1021))) + (syntmp-gen-labels-125 + (lambda (syntmp-ls-1022) + (if (null? syntmp-ls-1022) + '() + (cons (syntmp-gen-label-124) + (syntmp-gen-labels-125 (cdr syntmp-ls-1022)))))) + (syntmp-gen-label-124 (lambda () (string #\i))) + (syntmp-wrap-subst-123 cdr) + (syntmp-wrap-marks-122 car) + (syntmp-make-wrap-121 cons) + (syntmp-id-sym-name&marks-120 + (lambda (syntmp-x-1023 syntmp-w-1024) + (if (syntmp-syntax-object?-103 syntmp-x-1023) + (values + (let ((syntmp-e-1025 + (syntmp-syntax-object-expression-104 + syntmp-x-1023))) + (if (annotation? syntmp-e-1025) + (annotation-expression syntmp-e-1025) + syntmp-e-1025)) + (syntmp-join-marks-139 + (syntmp-wrap-marks-122 syntmp-w-1024) + (syntmp-wrap-marks-122 + (syntmp-syntax-object-wrap-105 syntmp-x-1023)))) + (values + (let ((syntmp-e-1026 syntmp-x-1023)) + (if (annotation? syntmp-e-1026) + (annotation-expression syntmp-e-1026) + syntmp-e-1026)) + (syntmp-wrap-marks-122 syntmp-w-1024))))) + (syntmp-id?-119 + (lambda (syntmp-x-1027) + (cond ((symbol? syntmp-x-1027) #t) + ((syntmp-syntax-object?-103 syntmp-x-1027) + (symbol? + (let ((syntmp-e-1028 + (syntmp-syntax-object-expression-104 + syntmp-x-1027))) + (if (annotation? syntmp-e-1028) + (annotation-expression syntmp-e-1028) + syntmp-e-1028)))) + ((annotation? syntmp-x-1027) + (symbol? (annotation-expression syntmp-x-1027))) + (else #f)))) + (syntmp-nonsymbol-id?-118 + (lambda (syntmp-x-1029) + (and (syntmp-syntax-object?-103 syntmp-x-1029) + (symbol? + (let ((syntmp-e-1030 + (syntmp-syntax-object-expression-104 + syntmp-x-1029))) + (if (annotation? syntmp-e-1030) + (annotation-expression syntmp-e-1030) + syntmp-e-1030)))))) + (syntmp-global-extend-117 + (lambda (syntmp-type-1031 + syntmp-sym-1032 + syntmp-val-1033) + (syntmp-put-global-definition-hook-94 + syntmp-sym-1032 + (cons syntmp-type-1031 syntmp-val-1033) + (module-name (current-module))))) + (syntmp-lookup-116 + (lambda (syntmp-x-1034 syntmp-r-1035 syntmp-mod-1036) + (cond ((assq syntmp-x-1034 syntmp-r-1035) => cdr) + ((symbol? syntmp-x-1034) + (or (syntmp-get-global-definition-hook-95 + syntmp-x-1034 + syntmp-mod-1036) + '(global))) + (else (quote (displaced-lexical)))))) + (syntmp-macros-only-env-115 + (lambda (syntmp-r-1037) + (if (null? syntmp-r-1037) + '() + (let ((syntmp-a-1038 (car syntmp-r-1037))) + (if (eq? (cadr syntmp-a-1038) (quote macro)) + (cons syntmp-a-1038 + (syntmp-macros-only-env-115 (cdr syntmp-r-1037))) + (syntmp-macros-only-env-115 (cdr syntmp-r-1037))))))) + (syntmp-extend-var-env-114 + (lambda (syntmp-labels-1039 + syntmp-vars-1040 + syntmp-r-1041) + (if (null? syntmp-labels-1039) + syntmp-r-1041 + (syntmp-extend-var-env-114 + (cdr syntmp-labels-1039) + (cdr syntmp-vars-1040) + (cons (cons (car syntmp-labels-1039) + (cons (quote lexical) (car syntmp-vars-1040))) + syntmp-r-1041))))) + (syntmp-extend-env-113 + (lambda (syntmp-labels-1042 + syntmp-bindings-1043 + syntmp-r-1044) + (if (null? syntmp-labels-1042) + syntmp-r-1044 + (syntmp-extend-env-113 + (cdr syntmp-labels-1042) + (cdr syntmp-bindings-1043) + (cons (cons (car syntmp-labels-1042) + (car syntmp-bindings-1043)) + syntmp-r-1044))))) + (syntmp-binding-value-112 cdr) + (syntmp-binding-type-111 car) + (syntmp-source-annotation-110 + (lambda (syntmp-x-1045) + (cond ((annotation? syntmp-x-1045) + (annotation-source syntmp-x-1045)) + ((syntmp-syntax-object?-103 syntmp-x-1045) + (syntmp-source-annotation-110 + (syntmp-syntax-object-expression-104 + syntmp-x-1045))) + (else #f)))) + (syntmp-set-syntax-object-module!-109 + (lambda (syntmp-x-1046 syntmp-update-1047) + (vector-set! syntmp-x-1046 3 syntmp-update-1047))) + (syntmp-set-syntax-object-wrap!-108 + (lambda (syntmp-x-1048 syntmp-update-1049) + (vector-set! syntmp-x-1048 2 syntmp-update-1049))) + (syntmp-set-syntax-object-expression!-107 + (lambda (syntmp-x-1050 syntmp-update-1051) + (vector-set! syntmp-x-1050 1 syntmp-update-1051))) + (syntmp-syntax-object-module-106 + (lambda (syntmp-x-1052) + (vector-ref syntmp-x-1052 3))) + (syntmp-syntax-object-wrap-105 + (lambda (syntmp-x-1053) + (vector-ref syntmp-x-1053 2))) + (syntmp-syntax-object-expression-104 + (lambda (syntmp-x-1054) + (vector-ref syntmp-x-1054 1))) + (syntmp-syntax-object?-103 + (lambda (syntmp-x-1055) + (and (vector? syntmp-x-1055) + (= (vector-length syntmp-x-1055) 4) + (eq? (vector-ref syntmp-x-1055 0) + 'syntax-object)))) + (syntmp-make-syntax-object-102 + (lambda (syntmp-expression-1056 + syntmp-wrap-1057 + syntmp-module-1058) + (vector + 'syntax-object + syntmp-expression-1056 + syntmp-wrap-1057 + syntmp-module-1058))) + (syntmp-build-letrec-101 + (lambda (syntmp-src-1059 + syntmp-vars-1060 + syntmp-val-exps-1061 + syntmp-body-exp-1062) + (if (null? syntmp-vars-1060) + (syntmp-build-annotated-96 + syntmp-src-1059 + syntmp-body-exp-1062) + (syntmp-build-annotated-96 + syntmp-src-1059 + (list 'letrec + (map list syntmp-vars-1060 syntmp-val-exps-1061) + syntmp-body-exp-1062))))) + (syntmp-build-named-let-100 + (lambda (syntmp-src-1063 + syntmp-vars-1064 + syntmp-val-exps-1065 + syntmp-body-exp-1066) + (if (null? syntmp-vars-1064) + (syntmp-build-annotated-96 + syntmp-src-1063 + syntmp-body-exp-1066) + (syntmp-build-annotated-96 + syntmp-src-1063 + (list 'let + (car syntmp-vars-1064) + (map list + (cdr syntmp-vars-1064) + syntmp-val-exps-1065) + syntmp-body-exp-1066))))) + (syntmp-build-let-99 + (lambda (syntmp-src-1067 + syntmp-vars-1068 + syntmp-val-exps-1069 + syntmp-body-exp-1070) + (if (null? syntmp-vars-1068) + (syntmp-build-annotated-96 + syntmp-src-1067 + syntmp-body-exp-1070) + (syntmp-build-annotated-96 + syntmp-src-1067 + (list 'let + (map list syntmp-vars-1068 syntmp-val-exps-1069) + syntmp-body-exp-1070))))) + (syntmp-build-sequence-98 + (lambda (syntmp-src-1071 syntmp-exps-1072) + (if (null? (cdr syntmp-exps-1072)) + (syntmp-build-annotated-96 + syntmp-src-1071 + (car syntmp-exps-1072)) + (syntmp-build-annotated-96 + syntmp-src-1071 + (cons (quote begin) syntmp-exps-1072))))) + (syntmp-build-data-97 + (lambda (syntmp-src-1073 syntmp-exp-1074) + (if (and (self-evaluating? syntmp-exp-1074) + (not (vector? syntmp-exp-1074))) + (syntmp-build-annotated-96 + syntmp-src-1073 + syntmp-exp-1074) + (syntmp-build-annotated-96 + syntmp-src-1073 + (list (quote quote) syntmp-exp-1074))))) + (syntmp-build-annotated-96 + (lambda (syntmp-src-1075 syntmp-exp-1076) + (if (and syntmp-src-1075 + (not (annotation? syntmp-exp-1076))) + (make-annotation + syntmp-exp-1076 + syntmp-src-1075 + #t) + syntmp-exp-1076))) + (syntmp-get-global-definition-hook-95 + (lambda (syntmp-symbol-1077 syntmp-module-1078) + (let ((syntmp-module-1079 + (if syntmp-module-1078 + (resolve-module syntmp-module-1078) + (warn "wha" syntmp-symbol-1077 (current-module))))) + (let ((syntmp-v-1080 + (module-variable + syntmp-module-1079 + syntmp-symbol-1077))) + (and syntmp-v-1080 + (or (object-property + syntmp-v-1080 + '*sc-expander*) + (and (variable-bound? syntmp-v-1080) + (macro? (variable-ref syntmp-v-1080)) + (macro-transformer (variable-ref syntmp-v-1080)) + guile-macro))))))) + (syntmp-put-global-definition-hook-94 + (lambda (syntmp-symbol-1081 + syntmp-binding-1082 + syntmp-module-1083) + (let ((syntmp-module-1084 + (if syntmp-module-1083 + (resolve-module syntmp-module-1083) + (warn "wha" syntmp-symbol-1081 (current-module))))) + (let ((syntmp-v-1085 + (or (module-variable + syntmp-module-1084 + syntmp-symbol-1081) + (let ((syntmp-v-1086 (make-variable sc-macro))) + (begin + (module-add! + syntmp-module-1084 + syntmp-symbol-1081 + syntmp-v-1086) + syntmp-v-1086))))) + (begin + (if (not (and (symbol-property + syntmp-symbol-1081 + 'primitive-syntax) + (eq? syntmp-module-1084 the-syncase-module))) + (variable-set! syntmp-v-1085 sc-macro)) + (set-object-property! + syntmp-v-1085 + '*sc-expander* + syntmp-binding-1082)))))) + (syntmp-error-hook-93 + (lambda (syntmp-who-1087 + syntmp-why-1088 + syntmp-what-1089) + (error syntmp-who-1087 + "~a ~s" + syntmp-why-1088 + syntmp-what-1089))) + (syntmp-local-eval-hook-92 + (lambda (syntmp-x-1090 syntmp-mod-1091) + (eval (list syntmp-noexpand-86 syntmp-x-1090) + (if syntmp-mod-1091 + (resolve-module syntmp-mod-1091) + (interaction-environment))))) + (syntmp-top-level-eval-hook-91 + (lambda (syntmp-x-1092 syntmp-mod-1093) + (eval (list syntmp-noexpand-86 syntmp-x-1092) + (if syntmp-mod-1093 + (resolve-module syntmp-mod-1093) + (interaction-environment))))) + (syntmp-fx<-90 <) + (syntmp-fx=-89 =) + (syntmp-fx--88 -) + (syntmp-fx+-87 +) + (syntmp-noexpand-86 "noexpand")) + (begin + (syntmp-global-extend-117 + 'local-syntax + 'letrec-syntax + #t) + (syntmp-global-extend-117 + 'local-syntax + 'let-syntax + #f) + (syntmp-global-extend-117 + 'core + 'fluid-let-syntax + (lambda (syntmp-e-1094 + syntmp-r-1095 + syntmp-w-1096 + syntmp-s-1097 + syntmp-mod-1098) + ((lambda (syntmp-tmp-1099) + ((lambda (syntmp-tmp-1100) + (if (if syntmp-tmp-1100 + (apply (lambda (syntmp-_-1101 + syntmp-var-1102 + syntmp-val-1103 + syntmp-e1-1104 + syntmp-e2-1105) + (syntmp-valid-bound-ids?-144 syntmp-var-1102)) + syntmp-tmp-1100) + #f) + (apply (lambda (syntmp-_-1107 + syntmp-var-1108 + syntmp-val-1109 + syntmp-e1-1110 + syntmp-e2-1111) + (let ((syntmp-names-1112 + (map (lambda (syntmp-x-1113) + (syntmp-id-var-name-141 + syntmp-x-1113 + syntmp-w-1096)) + syntmp-var-1108))) + (begin + (for-each + (lambda (syntmp-id-1115 syntmp-n-1116) + (let ((syntmp-t-1117 + (syntmp-binding-type-111 + (syntmp-lookup-116 + syntmp-n-1116 + syntmp-r-1095 + syntmp-mod-1098)))) + (if (memv syntmp-t-1117 + '(displaced-lexical)) + (syntax-error + (syntmp-source-wrap-148 + syntmp-id-1115 + syntmp-w-1096 + syntmp-s-1097 + syntmp-mod-1098) + "identifier out of context")))) + syntmp-var-1108 + syntmp-names-1112) + (syntmp-chi-body-159 + (cons syntmp-e1-1110 syntmp-e2-1111) + (syntmp-source-wrap-148 + syntmp-e-1094 + syntmp-w-1096 + syntmp-s-1097 + syntmp-mod-1098) + (syntmp-extend-env-113 + syntmp-names-1112 + (let ((syntmp-trans-r-1120 + (syntmp-macros-only-env-115 + syntmp-r-1095))) + (map (lambda (syntmp-x-1121) + (cons 'macro + (syntmp-eval-local-transformer-162 + (syntmp-chi-155 + syntmp-x-1121 + syntmp-trans-r-1120 + syntmp-w-1096 + syntmp-mod-1098) + syntmp-mod-1098))) + syntmp-val-1109)) + syntmp-r-1095) + syntmp-w-1096 + syntmp-mod-1098)))) + syntmp-tmp-1100) + ((lambda (syntmp-_-1123) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-1094 + syntmp-w-1096 + syntmp-s-1097 + syntmp-mod-1098))) + syntmp-tmp-1099))) + (syntax-dispatch + syntmp-tmp-1099 + '(any #(each (any any)) any . each-any)))) + syntmp-e-1094))) + (syntmp-global-extend-117 + 'core + 'quote + (lambda (syntmp-e-1124 + syntmp-r-1125 + syntmp-w-1126 + syntmp-s-1127 + syntmp-mod-1128) + ((lambda (syntmp-tmp-1129) + ((lambda (syntmp-tmp-1130) + (if syntmp-tmp-1130 + (apply (lambda (syntmp-_-1131 syntmp-e-1132) + (syntmp-build-data-97 + syntmp-s-1127 + (syntmp-strip-166 syntmp-e-1132 syntmp-w-1126))) + syntmp-tmp-1130) + ((lambda (syntmp-_-1133) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-1124 + syntmp-w-1126 + syntmp-s-1127 + syntmp-mod-1128))) + syntmp-tmp-1129))) + (syntax-dispatch + syntmp-tmp-1129 + '(any any)))) + syntmp-e-1124))) + (syntmp-global-extend-117 + 'core + 'syntax + (letrec ((syntmp-regen-1141 + (lambda (syntmp-x-1142) + (let ((syntmp-t-1143 (car syntmp-x-1142))) + (if (memv syntmp-t-1143 (quote (ref))) + (syntmp-build-annotated-96 + #f + (cadr syntmp-x-1142)) + (if (memv syntmp-t-1143 (quote (primitive))) + (syntmp-build-annotated-96 + #f + (cadr syntmp-x-1142)) + (if (memv syntmp-t-1143 (quote (quote))) + (syntmp-build-data-97 #f (cadr syntmp-x-1142)) + (if (memv syntmp-t-1143 (quote (lambda))) + (syntmp-build-annotated-96 + #f + (list 'lambda + (cadr syntmp-x-1142) + (syntmp-regen-1141 + (caddr syntmp-x-1142)))) + (if (memv syntmp-t-1143 (quote (map))) + (let ((syntmp-ls-1144 + (map syntmp-regen-1141 + (cdr syntmp-x-1142)))) + (syntmp-build-annotated-96 + #f + (cons (if (syntmp-fx=-89 + (length syntmp-ls-1144) + 2) + (syntmp-build-annotated-96 + #f + 'map) + (syntmp-build-annotated-96 + #f + 'map)) + syntmp-ls-1144))) + (syntmp-build-annotated-96 + #f + (cons (syntmp-build-annotated-96 + #f + (car syntmp-x-1142)) + (map syntmp-regen-1141 + (cdr syntmp-x-1142)))))))))))) + (syntmp-gen-vector-1140 + (lambda (syntmp-x-1145) + (cond ((eq? (car syntmp-x-1145) (quote list)) + (cons (quote vector) (cdr syntmp-x-1145))) + ((eq? (car syntmp-x-1145) (quote quote)) + (list 'quote + (list->vector (cadr syntmp-x-1145)))) + (else (list (quote list->vector) syntmp-x-1145))))) + (syntmp-gen-append-1139 + (lambda (syntmp-x-1146 syntmp-y-1147) + (if (equal? syntmp-y-1147 (quote (quote ()))) + syntmp-x-1146 + (list (quote append) syntmp-x-1146 syntmp-y-1147)))) + (syntmp-gen-cons-1138 + (lambda (syntmp-x-1148 syntmp-y-1149) + (let ((syntmp-t-1150 (car syntmp-y-1149))) + (if (memv syntmp-t-1150 (quote (quote))) + (if (eq? (car syntmp-x-1148) (quote quote)) + (list 'quote + (cons (cadr syntmp-x-1148) + (cadr syntmp-y-1149))) + (if (eq? (cadr syntmp-y-1149) (quote ())) + (list (quote list) syntmp-x-1148) + (list (quote cons) syntmp-x-1148 syntmp-y-1149))) + (if (memv syntmp-t-1150 (quote (list))) + (cons 'list + (cons syntmp-x-1148 (cdr syntmp-y-1149))) + (list (quote cons) syntmp-x-1148 syntmp-y-1149)))))) + (syntmp-gen-map-1137 + (lambda (syntmp-e-1151 syntmp-map-env-1152) + (let ((syntmp-formals-1153 + (map cdr syntmp-map-env-1152)) + (syntmp-actuals-1154 + (map (lambda (syntmp-x-1155) + (list (quote ref) (car syntmp-x-1155))) + syntmp-map-env-1152))) + (cond ((eq? (car syntmp-e-1151) (quote ref)) + (car syntmp-actuals-1154)) + ((andmap + (lambda (syntmp-x-1156) + (and (eq? (car syntmp-x-1156) (quote ref)) + (memq (cadr syntmp-x-1156) + syntmp-formals-1153))) + (cdr syntmp-e-1151)) + (cons 'map + (cons (list 'primitive + (car syntmp-e-1151)) + (map (let ((syntmp-r-1157 + (map cons + syntmp-formals-1153 + syntmp-actuals-1154))) + (lambda (syntmp-x-1158) + (cdr (assq (cadr syntmp-x-1158) + syntmp-r-1157)))) + (cdr syntmp-e-1151))))) + (else + (cons 'map + (cons (list 'lambda + syntmp-formals-1153 + syntmp-e-1151) + syntmp-actuals-1154))))))) + (syntmp-gen-mappend-1136 + (lambda (syntmp-e-1159 syntmp-map-env-1160) + (list 'apply + '(primitive append) + (syntmp-gen-map-1137 + syntmp-e-1159 + syntmp-map-env-1160)))) + (syntmp-gen-ref-1135 + (lambda (syntmp-src-1161 + syntmp-var-1162 + syntmp-level-1163 + syntmp-maps-1164) + (if (syntmp-fx=-89 syntmp-level-1163 0) + (values syntmp-var-1162 syntmp-maps-1164) + (if (null? syntmp-maps-1164) + (syntax-error + syntmp-src-1161 + "missing ellipsis in syntax form") + (call-with-values + (lambda () + (syntmp-gen-ref-1135 + syntmp-src-1161 + syntmp-var-1162 + (syntmp-fx--88 syntmp-level-1163 1) + (cdr syntmp-maps-1164))) + (lambda (syntmp-outer-var-1165 syntmp-outer-maps-1166) + (let ((syntmp-b-1167 + (assq syntmp-outer-var-1165 + (car syntmp-maps-1164)))) + (if syntmp-b-1167 + (values (cdr syntmp-b-1167) syntmp-maps-1164) + (let ((syntmp-inner-var-1168 + (syntmp-gen-var-167 (quote tmp)))) + (values + syntmp-inner-var-1168 + (cons (cons (cons syntmp-outer-var-1165 + syntmp-inner-var-1168) + (car syntmp-maps-1164)) + syntmp-outer-maps-1166))))))))))) + (syntmp-gen-syntax-1134 + (lambda (syntmp-src-1169 + syntmp-e-1170 + syntmp-r-1171 + syntmp-maps-1172 + syntmp-ellipsis?-1173 + syntmp-mod-1174) + (if (syntmp-id?-119 syntmp-e-1170) + (let ((syntmp-label-1175 + (syntmp-id-var-name-141 + syntmp-e-1170 + '(())))) + (let ((syntmp-b-1176 + (syntmp-lookup-116 + syntmp-label-1175 + syntmp-r-1171 + syntmp-mod-1174))) + (if (eq? (syntmp-binding-type-111 syntmp-b-1176) + 'syntax) + (call-with-values + (lambda () + (let ((syntmp-var.lev-1177 + (syntmp-binding-value-112 + syntmp-b-1176))) + (syntmp-gen-ref-1135 + syntmp-src-1169 + (car syntmp-var.lev-1177) + (cdr syntmp-var.lev-1177) + syntmp-maps-1172))) + (lambda (syntmp-var-1178 syntmp-maps-1179) + (values + (list (quote ref) syntmp-var-1178) + syntmp-maps-1179))) + (if (syntmp-ellipsis?-1173 syntmp-e-1170) + (syntax-error + syntmp-src-1169 + "misplaced ellipsis in syntax form") + (values + (list (quote quote) syntmp-e-1170) + syntmp-maps-1172))))) + ((lambda (syntmp-tmp-1180) + ((lambda (syntmp-tmp-1181) + (if (if syntmp-tmp-1181 + (apply (lambda (syntmp-dots-1182 + syntmp-e-1183) + (syntmp-ellipsis?-1173 + syntmp-dots-1182)) + syntmp-tmp-1181) + #f) + (apply (lambda (syntmp-dots-1184 syntmp-e-1185) + (syntmp-gen-syntax-1134 + syntmp-src-1169 + syntmp-e-1185 + syntmp-r-1171 + syntmp-maps-1172 + (lambda (syntmp-x-1186) #f) + syntmp-mod-1174)) + syntmp-tmp-1181) + ((lambda (syntmp-tmp-1187) + (if (if syntmp-tmp-1187 + (apply (lambda (syntmp-x-1188 + syntmp-dots-1189 + syntmp-y-1190) + (syntmp-ellipsis?-1173 + syntmp-dots-1189)) + syntmp-tmp-1187) + #f) + (apply (lambda (syntmp-x-1191 + syntmp-dots-1192 + syntmp-y-1193) + (let syntmp-f-1194 ((syntmp-y-1195 + syntmp-y-1193) + (syntmp-k-1196 + (lambda (syntmp-maps-1197) + (call-with-values + (lambda () + (syntmp-gen-syntax-1134 + syntmp-src-1169 + syntmp-x-1191 + syntmp-r-1171 + (cons '() + syntmp-maps-1197) + syntmp-ellipsis?-1173 + syntmp-mod-1174)) + (lambda (syntmp-x-1198 + syntmp-maps-1199) + (if (null? (car syntmp-maps-1199)) + (syntax-error + syntmp-src-1169 + "extra ellipsis in syntax form") + (values + (syntmp-gen-map-1137 + syntmp-x-1198 + (car syntmp-maps-1199)) + (cdr syntmp-maps-1199)))))))) + ((lambda (syntmp-tmp-1200) + ((lambda (syntmp-tmp-1201) + (if (if syntmp-tmp-1201 + (apply (lambda (syntmp-dots-1202 + syntmp-y-1203) + (syntmp-ellipsis?-1173 + syntmp-dots-1202)) + syntmp-tmp-1201) + #f) + (apply (lambda (syntmp-dots-1204 + syntmp-y-1205) + (syntmp-f-1194 + syntmp-y-1205 + (lambda (syntmp-maps-1206) + (call-with-values + (lambda () + (syntmp-k-1196 + (cons '() + syntmp-maps-1206))) + (lambda (syntmp-x-1207 + syntmp-maps-1208) + (if (null? (car syntmp-maps-1208)) + (syntax-error + syntmp-src-1169 + "extra ellipsis in syntax form") + (values + (syntmp-gen-mappend-1136 + syntmp-x-1207 + (car syntmp-maps-1208)) + (cdr syntmp-maps-1208)))))))) + syntmp-tmp-1201) + ((lambda (syntmp-_-1209) + (call-with-values + (lambda () + (syntmp-gen-syntax-1134 + syntmp-src-1169 + syntmp-y-1195 + syntmp-r-1171 + syntmp-maps-1172 + syntmp-ellipsis?-1173 + syntmp-mod-1174)) + (lambda (syntmp-y-1210 + syntmp-maps-1211) + (call-with-values + (lambda () + (syntmp-k-1196 + syntmp-maps-1211)) + (lambda (syntmp-x-1212 + syntmp-maps-1213) + (values + (syntmp-gen-append-1139 + syntmp-x-1212 + syntmp-y-1210) + syntmp-maps-1213)))))) + syntmp-tmp-1200))) + (syntax-dispatch + syntmp-tmp-1200 + '(any . any)))) + syntmp-y-1195))) + syntmp-tmp-1187) + ((lambda (syntmp-tmp-1214) + (if syntmp-tmp-1214 + (apply (lambda (syntmp-x-1215 + syntmp-y-1216) + (call-with-values + (lambda () + (syntmp-gen-syntax-1134 + syntmp-src-1169 + syntmp-x-1215 + syntmp-r-1171 + syntmp-maps-1172 + syntmp-ellipsis?-1173 + syntmp-mod-1174)) + (lambda (syntmp-x-1217 + syntmp-maps-1218) + (call-with-values + (lambda () + (syntmp-gen-syntax-1134 + syntmp-src-1169 + syntmp-y-1216 + syntmp-r-1171 + syntmp-maps-1218 + syntmp-ellipsis?-1173 + syntmp-mod-1174)) + (lambda (syntmp-y-1219 + syntmp-maps-1220) + (values + (syntmp-gen-cons-1138 + syntmp-x-1217 + syntmp-y-1219) + syntmp-maps-1220)))))) + syntmp-tmp-1214) + ((lambda (syntmp-tmp-1221) + (if syntmp-tmp-1221 + (apply (lambda (syntmp-e1-1222 + syntmp-e2-1223) + (call-with-values + (lambda () + (syntmp-gen-syntax-1134 + syntmp-src-1169 + (cons syntmp-e1-1222 + syntmp-e2-1223) + syntmp-r-1171 + syntmp-maps-1172 + syntmp-ellipsis?-1173 + syntmp-mod-1174)) + (lambda (syntmp-e-1225 + syntmp-maps-1226) + (values + (syntmp-gen-vector-1140 + syntmp-e-1225) + syntmp-maps-1226)))) + syntmp-tmp-1221) + ((lambda (syntmp-_-1227) + (values + (list 'quote + syntmp-e-1170) + syntmp-maps-1172)) + syntmp-tmp-1180))) + (syntax-dispatch + syntmp-tmp-1180 + '#(vector (any . each-any)))))) + (syntax-dispatch + syntmp-tmp-1180 + '(any . any))))) + (syntax-dispatch + syntmp-tmp-1180 + '(any any . any))))) + (syntax-dispatch + syntmp-tmp-1180 + '(any any)))) + syntmp-e-1170))))) + (lambda (syntmp-e-1228 + syntmp-r-1229 + syntmp-w-1230 + syntmp-s-1231 + syntmp-mod-1232) + (let ((syntmp-e-1233 + (syntmp-source-wrap-148 + syntmp-e-1228 + syntmp-w-1230 + syntmp-s-1231 + syntmp-mod-1232))) + ((lambda (syntmp-tmp-1234) + ((lambda (syntmp-tmp-1235) + (if syntmp-tmp-1235 + (apply (lambda (syntmp-_-1236 syntmp-x-1237) + (call-with-values + (lambda () + (syntmp-gen-syntax-1134 + syntmp-e-1233 + syntmp-x-1237 + syntmp-r-1229 + '() + syntmp-ellipsis?-164 + syntmp-mod-1232)) + (lambda (syntmp-e-1238 syntmp-maps-1239) + (syntmp-regen-1141 syntmp-e-1238)))) + syntmp-tmp-1235) + ((lambda (syntmp-_-1240) + (syntax-error syntmp-e-1233)) + syntmp-tmp-1234))) + (syntax-dispatch + syntmp-tmp-1234 + '(any any)))) + syntmp-e-1233))))) + (syntmp-global-extend-117 + 'core + 'lambda + (lambda (syntmp-e-1241 + syntmp-r-1242 + syntmp-w-1243 + syntmp-s-1244 + syntmp-mod-1245) + ((lambda (syntmp-tmp-1246) + ((lambda (syntmp-tmp-1247) + (if syntmp-tmp-1247 + (apply (lambda (syntmp-_-1248 syntmp-c-1249) + (syntmp-chi-lambda-clause-160 + (syntmp-source-wrap-148 + syntmp-e-1241 + syntmp-w-1243 + syntmp-s-1244 + syntmp-mod-1245) + syntmp-c-1249 + syntmp-r-1242 + syntmp-w-1243 + syntmp-mod-1245 + (lambda (syntmp-vars-1250 syntmp-body-1251) + (syntmp-build-annotated-96 + syntmp-s-1244 + (list 'lambda + syntmp-vars-1250 + syntmp-body-1251))))) + syntmp-tmp-1247) + (syntax-error syntmp-tmp-1246))) + (syntax-dispatch + syntmp-tmp-1246 + '(any . any)))) + syntmp-e-1241))) + (syntmp-global-extend-117 + 'core + 'let + (letrec ((syntmp-chi-let-1252 + (lambda (syntmp-e-1253 + syntmp-r-1254 + syntmp-w-1255 + syntmp-s-1256 + syntmp-mod-1257 + syntmp-constructor-1258 + syntmp-ids-1259 + syntmp-vals-1260 + syntmp-exps-1261) + (if (not (syntmp-valid-bound-ids?-144 syntmp-ids-1259)) + (syntax-error + syntmp-e-1253 + "duplicate bound variable in") + (let ((syntmp-labels-1262 + (syntmp-gen-labels-125 syntmp-ids-1259)) + (syntmp-new-vars-1263 + (map syntmp-gen-var-167 syntmp-ids-1259))) + (let ((syntmp-nw-1264 + (syntmp-make-binding-wrap-136 + syntmp-ids-1259 + syntmp-labels-1262 + syntmp-w-1255)) + (syntmp-nr-1265 + (syntmp-extend-var-env-114 + syntmp-labels-1262 + syntmp-new-vars-1263 + syntmp-r-1254))) + (syntmp-constructor-1258 + syntmp-s-1256 + syntmp-new-vars-1263 + (map (lambda (syntmp-x-1266) + (syntmp-chi-155 + syntmp-x-1266 + syntmp-r-1254 + syntmp-w-1255 + syntmp-mod-1257)) + syntmp-vals-1260) + (syntmp-chi-body-159 + syntmp-exps-1261 + (syntmp-source-wrap-148 + syntmp-e-1253 + syntmp-nw-1264 + syntmp-s-1256 + syntmp-mod-1257) + syntmp-nr-1265 + syntmp-nw-1264 + syntmp-mod-1257)))))))) + (lambda (syntmp-e-1267 + syntmp-r-1268 + syntmp-w-1269 + syntmp-s-1270 + syntmp-mod-1271) + ((lambda (syntmp-tmp-1272) + ((lambda (syntmp-tmp-1273) + (if syntmp-tmp-1273 + (apply (lambda (syntmp-_-1274 + syntmp-id-1275 + syntmp-val-1276 + syntmp-e1-1277 + syntmp-e2-1278) + (syntmp-chi-let-1252 + syntmp-e-1267 + syntmp-r-1268 + syntmp-w-1269 + syntmp-s-1270 + syntmp-mod-1271 + syntmp-build-let-99 + syntmp-id-1275 + syntmp-val-1276 + (cons syntmp-e1-1277 syntmp-e2-1278))) + syntmp-tmp-1273) + ((lambda (syntmp-tmp-1282) + (if (if syntmp-tmp-1282 + (apply (lambda (syntmp-_-1283 + syntmp-f-1284 + syntmp-id-1285 + syntmp-val-1286 + syntmp-e1-1287 + syntmp-e2-1288) + (syntmp-id?-119 syntmp-f-1284)) + syntmp-tmp-1282) + #f) + (apply (lambda (syntmp-_-1289 + syntmp-f-1290 + syntmp-id-1291 + syntmp-val-1292 + syntmp-e1-1293 + syntmp-e2-1294) + (syntmp-chi-let-1252 + syntmp-e-1267 + syntmp-r-1268 + syntmp-w-1269 + syntmp-s-1270 + syntmp-mod-1271 + syntmp-build-named-let-100 + (cons syntmp-f-1290 syntmp-id-1291) + syntmp-val-1292 + (cons syntmp-e1-1293 syntmp-e2-1294))) + syntmp-tmp-1282) + ((lambda (syntmp-_-1298) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-1267 + syntmp-w-1269 + syntmp-s-1270 + syntmp-mod-1271))) + syntmp-tmp-1272))) + (syntax-dispatch + syntmp-tmp-1272 + '(any any #(each (any any)) any . each-any))))) + (syntax-dispatch + syntmp-tmp-1272 + '(any #(each (any any)) any . each-any)))) + syntmp-e-1267)))) + (syntmp-global-extend-117 + 'core + 'letrec + (lambda (syntmp-e-1299 + syntmp-r-1300 + syntmp-w-1301 + syntmp-s-1302 + syntmp-mod-1303) + ((lambda (syntmp-tmp-1304) + ((lambda (syntmp-tmp-1305) + (if syntmp-tmp-1305 + (apply (lambda (syntmp-_-1306 + syntmp-id-1307 + syntmp-val-1308 + syntmp-e1-1309 + syntmp-e2-1310) + (let ((syntmp-ids-1311 syntmp-id-1307)) + (if (not (syntmp-valid-bound-ids?-144 + syntmp-ids-1311)) + (syntax-error + syntmp-e-1299 + "duplicate bound variable in") + (let ((syntmp-labels-1313 + (syntmp-gen-labels-125 syntmp-ids-1311)) + (syntmp-new-vars-1314 + (map syntmp-gen-var-167 syntmp-ids-1311))) + (let ((syntmp-w-1315 + (syntmp-make-binding-wrap-136 + syntmp-ids-1311 + syntmp-labels-1313 + syntmp-w-1301)) + (syntmp-r-1316 + (syntmp-extend-var-env-114 + syntmp-labels-1313 + syntmp-new-vars-1314 + syntmp-r-1300))) + (syntmp-build-letrec-101 + syntmp-s-1302 + syntmp-new-vars-1314 + (map (lambda (syntmp-x-1317) + (syntmp-chi-155 + syntmp-x-1317 + syntmp-r-1316 + syntmp-w-1315 + syntmp-mod-1303)) + syntmp-val-1308) + (syntmp-chi-body-159 + (cons syntmp-e1-1309 syntmp-e2-1310) + (syntmp-source-wrap-148 + syntmp-e-1299 + syntmp-w-1315 + syntmp-s-1302 + syntmp-mod-1303) + syntmp-r-1316 + syntmp-w-1315 + syntmp-mod-1303))))))) + syntmp-tmp-1305) + ((lambda (syntmp-_-1320) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-1299 + syntmp-w-1301 + syntmp-s-1302 + syntmp-mod-1303))) + syntmp-tmp-1304))) + (syntax-dispatch + syntmp-tmp-1304 + '(any #(each (any any)) any . each-any)))) + syntmp-e-1299))) + (syntmp-global-extend-117 + 'core + 'set! + (lambda (syntmp-e-1321 + syntmp-r-1322 + syntmp-w-1323 + syntmp-s-1324 + syntmp-mod-1325) + ((lambda (syntmp-tmp-1326) + ((lambda (syntmp-tmp-1327) + (if (if syntmp-tmp-1327 + (apply (lambda (syntmp-_-1328 + syntmp-id-1329 + syntmp-val-1330) + (syntmp-id?-119 syntmp-id-1329)) + syntmp-tmp-1327) + #f) + (apply (lambda (syntmp-_-1331 syntmp-id-1332 syntmp-val-1333) + (let ((syntmp-val-1334 + (syntmp-chi-155 + syntmp-val-1333 + syntmp-r-1322 + syntmp-w-1323 + syntmp-mod-1325)) + (syntmp-n-1335 + (syntmp-id-var-name-141 + syntmp-id-1332 + syntmp-w-1323))) + (let ((syntmp-b-1336 + (syntmp-lookup-116 + syntmp-n-1335 + syntmp-r-1322 + syntmp-mod-1325))) + (let ((syntmp-t-1337 + (syntmp-binding-type-111 syntmp-b-1336))) + (if (memv syntmp-t-1337 (quote (lexical))) + (syntmp-build-annotated-96 + syntmp-s-1324 + (list 'set! + (syntmp-binding-value-112 + syntmp-b-1336) + syntmp-val-1334)) + (if (memv syntmp-t-1337 (quote (global))) + (syntmp-build-annotated-96 + syntmp-s-1324 + (list 'set! + (make-module-ref + syntmp-mod-1325 + syntmp-n-1335 + #f) + syntmp-val-1334)) + (if (memv syntmp-t-1337 + '(displaced-lexical)) + (syntax-error + (syntmp-wrap-147 + syntmp-id-1332 + syntmp-w-1323 + syntmp-mod-1325) + "identifier out of context") + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-1321 + syntmp-w-1323 + syntmp-s-1324 + syntmp-mod-1325))))))))) + syntmp-tmp-1327) + ((lambda (syntmp-tmp-1338) + (if syntmp-tmp-1338 + (apply (lambda (syntmp-_-1339 + syntmp-getter-1340 + syntmp-arg-1341 + syntmp-val-1342) + (syntmp-build-annotated-96 + syntmp-s-1324 + (cons (syntmp-chi-155 + (list '#(syntax-object + setter + ((top) + #(ribcage + #(_ getter arg val) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e r w s mod) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure) + ((top)) + ("i"))) + (ice-9 syncase)) + syntmp-getter-1340) + syntmp-r-1322 + syntmp-w-1323 + syntmp-mod-1325) + (map (lambda (syntmp-e-1343) + (syntmp-chi-155 + syntmp-e-1343 + syntmp-r-1322 + syntmp-w-1323 + syntmp-mod-1325)) + (append + syntmp-arg-1341 + (list syntmp-val-1342)))))) + syntmp-tmp-1338) + ((lambda (syntmp-_-1345) + (syntax-error + (syntmp-source-wrap-148 + syntmp-e-1321 + syntmp-w-1323 + syntmp-s-1324 + syntmp-mod-1325))) + syntmp-tmp-1326))) + (syntax-dispatch + syntmp-tmp-1326 + '(any (any . each-any) any))))) + (syntax-dispatch + syntmp-tmp-1326 + '(any any any)))) + syntmp-e-1321))) + (syntmp-global-extend-117 + 'begin + 'begin + '()) + (syntmp-global-extend-117 + 'define + 'define + '()) + (syntmp-global-extend-117 + 'define-syntax + 'define-syntax + '()) + (syntmp-global-extend-117 + 'eval-when + 'eval-when + '()) + (syntmp-global-extend-117 + 'core + 'syntax-case + (letrec ((syntmp-gen-syntax-case-1349 + (lambda (syntmp-x-1350 + syntmp-keys-1351 + syntmp-clauses-1352 + syntmp-r-1353 + syntmp-mod-1354) + (if (null? syntmp-clauses-1352) + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 + #f + 'syntax-error) + syntmp-x-1350)) + ((lambda (syntmp-tmp-1355) + ((lambda (syntmp-tmp-1356) + (if syntmp-tmp-1356 + (apply (lambda (syntmp-pat-1357 syntmp-exp-1358) + (if (and (syntmp-id?-119 syntmp-pat-1357) + (andmap + (lambda (syntmp-x-1359) + (not (syntmp-free-id=?-142 + syntmp-pat-1357 + syntmp-x-1359))) + (cons '#(syntax-object + ... + ((top) + #(ribcage + #(pat exp) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x + keys + clauses + r + mod) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + (gen-syntax-case + gen-clause + build-dispatch-call + convert-pattern) + ((top) + (top) + (top) + (top)) + ("i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip-annotation + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-annotated + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure) + ((top)) + ("i"))) + (ice-9 syncase)) + syntmp-keys-1351))) + (let ((syntmp-labels-1360 + (list (syntmp-gen-label-124))) + (syntmp-var-1361 + (syntmp-gen-var-167 + syntmp-pat-1357))) + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 + #f + (list 'lambda + (list syntmp-var-1361) + (syntmp-chi-155 + syntmp-exp-1358 + (syntmp-extend-env-113 + syntmp-labels-1360 + (list (cons 'syntax + (cons syntmp-var-1361 + 0))) + syntmp-r-1353) + (syntmp-make-binding-wrap-136 + (list syntmp-pat-1357) + syntmp-labels-1360 + '(())) + syntmp-mod-1354))) + syntmp-x-1350))) + (syntmp-gen-clause-1348 + syntmp-x-1350 + syntmp-keys-1351 + (cdr syntmp-clauses-1352) + syntmp-r-1353 + syntmp-pat-1357 + #t + syntmp-exp-1358 + syntmp-mod-1354))) + syntmp-tmp-1356) + ((lambda (syntmp-tmp-1362) + (if syntmp-tmp-1362 + (apply (lambda (syntmp-pat-1363 + syntmp-fender-1364 + syntmp-exp-1365) + (syntmp-gen-clause-1348 + syntmp-x-1350 + syntmp-keys-1351 + (cdr syntmp-clauses-1352) + syntmp-r-1353 + syntmp-pat-1363 + syntmp-fender-1364 + syntmp-exp-1365 + syntmp-mod-1354)) + syntmp-tmp-1362) + ((lambda (syntmp-_-1366) + (syntax-error + (car syntmp-clauses-1352) + "invalid syntax-case clause")) + syntmp-tmp-1355))) + (syntax-dispatch + syntmp-tmp-1355 + '(any any any))))) + (syntax-dispatch + syntmp-tmp-1355 + '(any any)))) + (car syntmp-clauses-1352))))) + (syntmp-gen-clause-1348 + (lambda (syntmp-x-1367 + syntmp-keys-1368 + syntmp-clauses-1369 + syntmp-r-1370 + syntmp-pat-1371 + syntmp-fender-1372 + syntmp-exp-1373 + syntmp-mod-1374) + (call-with-values + (lambda () + (syntmp-convert-pattern-1346 + syntmp-pat-1371 + syntmp-keys-1368)) + (lambda (syntmp-p-1375 syntmp-pvars-1376) + (cond ((not (syntmp-distinct-bound-ids?-145 + (map car syntmp-pvars-1376))) + (syntax-error + syntmp-pat-1371 + "duplicate pattern variable in syntax-case pattern")) + ((not (andmap + (lambda (syntmp-x-1377) + (not (syntmp-ellipsis?-164 + (car syntmp-x-1377)))) + syntmp-pvars-1376)) + (syntax-error + syntmp-pat-1371 + "misplaced ellipsis in syntax-case pattern")) + (else + (let ((syntmp-y-1378 + (syntmp-gen-var-167 (quote tmp)))) + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 + #f + (list 'lambda + (list syntmp-y-1378) + (let ((syntmp-y-1379 + (syntmp-build-annotated-96 + #f + syntmp-y-1378))) + (syntmp-build-annotated-96 + #f + (list 'if + ((lambda (syntmp-tmp-1380) + ((lambda (syntmp-tmp-1381) + (if syntmp-tmp-1381 + (apply (lambda () + syntmp-y-1379) + syntmp-tmp-1381) + ((lambda (syntmp-_-1382) + (syntmp-build-annotated-96 + #f + (list 'if + syntmp-y-1379 + (syntmp-build-dispatch-call-1347 + syntmp-pvars-1376 + syntmp-fender-1372 + syntmp-y-1379 + syntmp-r-1370 + syntmp-mod-1374) + (syntmp-build-data-97 + #f + #f)))) + syntmp-tmp-1380))) + (syntax-dispatch + syntmp-tmp-1380 + '#(atom #t)))) + syntmp-fender-1372) + (syntmp-build-dispatch-call-1347 + syntmp-pvars-1376 + syntmp-exp-1373 + syntmp-y-1379 + syntmp-r-1370 + syntmp-mod-1374) + (syntmp-gen-syntax-case-1349 + syntmp-x-1367 + syntmp-keys-1368 + syntmp-clauses-1369 + syntmp-r-1370 + syntmp-mod-1374)))))) + (if (eq? syntmp-p-1375 (quote any)) + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 + #f + 'list) + syntmp-x-1367)) + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 + #f + 'syntax-dispatch) + syntmp-x-1367 + (syntmp-build-data-97 + #f + syntmp-p-1375))))))))))))) + (syntmp-build-dispatch-call-1347 + (lambda (syntmp-pvars-1383 + syntmp-exp-1384 + syntmp-y-1385 + syntmp-r-1386 + syntmp-mod-1387) + (let ((syntmp-ids-1388 (map car syntmp-pvars-1383)) + (syntmp-levels-1389 (map cdr syntmp-pvars-1383))) + (let ((syntmp-labels-1390 + (syntmp-gen-labels-125 syntmp-ids-1388)) + (syntmp-new-vars-1391 + (map syntmp-gen-var-167 syntmp-ids-1388))) + (syntmp-build-annotated-96 + #f + (list (syntmp-build-annotated-96 #f (quote apply)) + (syntmp-build-annotated-96 + #f + (list 'lambda + syntmp-new-vars-1391 + (syntmp-chi-155 + syntmp-exp-1384 + (syntmp-extend-env-113 + syntmp-labels-1390 + (map (lambda (syntmp-var-1392 + syntmp-level-1393) + (cons 'syntax + (cons syntmp-var-1392 + syntmp-level-1393))) + syntmp-new-vars-1391 + (map cdr syntmp-pvars-1383)) + syntmp-r-1386) + (syntmp-make-binding-wrap-136 + syntmp-ids-1388 + syntmp-labels-1390 + '(())) + syntmp-mod-1387))) + syntmp-y-1385)))))) + (syntmp-convert-pattern-1346 + (lambda (syntmp-pattern-1394 syntmp-keys-1395) + (let syntmp-cvt-1396 ((syntmp-p-1397 syntmp-pattern-1394) + (syntmp-n-1398 0) + (syntmp-ids-1399 (quote ()))) + (if (syntmp-id?-119 syntmp-p-1397) + (if (syntmp-bound-id-member?-146 + syntmp-p-1397 + syntmp-keys-1395) + (values + (vector (quote free-id) syntmp-p-1397) + syntmp-ids-1399) + (values + 'any + (cons (cons syntmp-p-1397 syntmp-n-1398) + syntmp-ids-1399))) + ((lambda (syntmp-tmp-1400) + ((lambda (syntmp-tmp-1401) + (if (if syntmp-tmp-1401 + (apply (lambda (syntmp-x-1402 + syntmp-dots-1403) + (syntmp-ellipsis?-164 + syntmp-dots-1403)) + syntmp-tmp-1401) + #f) + (apply (lambda (syntmp-x-1404 syntmp-dots-1405) + (call-with-values + (lambda () + (syntmp-cvt-1396 + syntmp-x-1404 + (syntmp-fx+-87 syntmp-n-1398 1) + syntmp-ids-1399)) + (lambda (syntmp-p-1406 + syntmp-ids-1407) + (values + (if (eq? syntmp-p-1406 + 'any) + 'each-any + (vector + 'each + syntmp-p-1406)) + syntmp-ids-1407)))) + syntmp-tmp-1401) + ((lambda (syntmp-tmp-1408) + (if syntmp-tmp-1408 + (apply (lambda (syntmp-x-1409 + syntmp-y-1410) + (call-with-values + (lambda () + (syntmp-cvt-1396 + syntmp-y-1410 + syntmp-n-1398 + syntmp-ids-1399)) + (lambda (syntmp-y-1411 + syntmp-ids-1412) + (call-with-values + (lambda () + (syntmp-cvt-1396 + syntmp-x-1409 + syntmp-n-1398 + syntmp-ids-1412)) + (lambda (syntmp-x-1413 + syntmp-ids-1414) + (values + (cons syntmp-x-1413 + syntmp-y-1411) + syntmp-ids-1414)))))) + syntmp-tmp-1408) + ((lambda (syntmp-tmp-1415) + (if syntmp-tmp-1415 + (apply (lambda () + (values + '() + syntmp-ids-1399)) + syntmp-tmp-1415) + ((lambda (syntmp-tmp-1416) + (if syntmp-tmp-1416 + (apply (lambda (syntmp-x-1417) + (call-with-values + (lambda () + (syntmp-cvt-1396 + syntmp-x-1417 + syntmp-n-1398 + syntmp-ids-1399)) + (lambda (syntmp-p-1419 + syntmp-ids-1420) + (values + (vector + 'vector + syntmp-p-1419) + syntmp-ids-1420)))) + syntmp-tmp-1416) + ((lambda (syntmp-x-1421) + (values + (vector + 'atom + (syntmp-strip-166 + syntmp-p-1397 + '(()))) + syntmp-ids-1399)) + syntmp-tmp-1400))) + (syntax-dispatch + syntmp-tmp-1400 + '#(vector each-any))))) + (syntax-dispatch + syntmp-tmp-1400 + '())))) + (syntax-dispatch + syntmp-tmp-1400 + '(any . any))))) + (syntax-dispatch + syntmp-tmp-1400 + '(any any)))) + syntmp-p-1397)))))) + (lambda (syntmp-e-1422 + syntmp-r-1423 + syntmp-w-1424 + syntmp-s-1425 + syntmp-mod-1426) + (let ((syntmp-e-1427 + (syntmp-source-wrap-148 + syntmp-e-1422 + syntmp-w-1424 + syntmp-s-1425 + syntmp-mod-1426))) + ((lambda (syntmp-tmp-1428) + ((lambda (syntmp-tmp-1429) + (if syntmp-tmp-1429 + (apply (lambda (syntmp-_-1430 + syntmp-val-1431 + syntmp-key-1432 + syntmp-m-1433) + (if (andmap + (lambda (syntmp-x-1434) + (and (syntmp-id?-119 syntmp-x-1434) + (not (syntmp-ellipsis?-164 + syntmp-x-1434)))) + syntmp-key-1432) + (let ((syntmp-x-1436 + (syntmp-gen-var-167 (quote tmp)))) + (syntmp-build-annotated-96 + syntmp-s-1425 + (list (syntmp-build-annotated-96 + #f + (list 'lambda + (list syntmp-x-1436) + (syntmp-gen-syntax-case-1349 + (syntmp-build-annotated-96 + #f + syntmp-x-1436) + syntmp-key-1432 + syntmp-m-1433 + syntmp-r-1423 + syntmp-mod-1426))) + (syntmp-chi-155 + syntmp-val-1431 + syntmp-r-1423 + '(()) + syntmp-mod-1426)))) + (syntax-error + syntmp-e-1427 + "invalid literals list in"))) + syntmp-tmp-1429) + (syntax-error syntmp-tmp-1428))) + (syntax-dispatch + syntmp-tmp-1428 + '(any any each-any . each-any)))) + syntmp-e-1427))))) + (set! sc-expand + (let ((syntmp-m-1439 (quote e)) + (syntmp-esew-1440 (quote (eval)))) + (lambda (syntmp-x-1441) + (if (and (pair? syntmp-x-1441) + (equal? (car syntmp-x-1441) syntmp-noexpand-86)) + (cadr syntmp-x-1441) + (syntmp-chi-top-154 + syntmp-x-1441 + '() + '((top)) + syntmp-m-1439 + syntmp-esew-1440 + (module-name (current-module))))))) + (set! sc-expand3 + (let ((syntmp-m-1442 (quote e)) + (syntmp-esew-1443 (quote (eval)))) + (lambda (syntmp-x-1445 . syntmp-rest-1444) + (if (and (pair? syntmp-x-1445) + (equal? (car syntmp-x-1445) syntmp-noexpand-86)) + (cadr syntmp-x-1445) + (syntmp-chi-top-154 + syntmp-x-1445 + '() + '((top)) + (if (null? syntmp-rest-1444) + syntmp-m-1442 + (car syntmp-rest-1444)) + (if (or (null? syntmp-rest-1444) + (null? (cdr syntmp-rest-1444))) + syntmp-esew-1443 + (cadr syntmp-rest-1444)) + (module-name (current-module))))))) + (set! identifier? + (lambda (syntmp-x-1446) + (syntmp-nonsymbol-id?-118 syntmp-x-1446))) + (set! datum->syntax-object + (lambda (syntmp-id-1447 syntmp-datum-1448) + (syntmp-make-syntax-object-102 + syntmp-datum-1448 + (syntmp-syntax-object-wrap-105 syntmp-id-1447) + #f))) + (set! syntax-object->datum + (lambda (syntmp-x-1449) + (syntmp-strip-166 syntmp-x-1449 (quote (()))))) + (set! generate-temporaries + (lambda (syntmp-ls-1450) + (begin + (let ((syntmp-x-1451 syntmp-ls-1450)) + (if (not (list? syntmp-x-1451)) + (syntmp-error-hook-93 + 'generate-temporaries + "invalid argument" + syntmp-x-1451))) + (map (lambda (syntmp-x-1452) + (syntmp-wrap-147 (gensym) (quote ((top))) #f)) + syntmp-ls-1450)))) + (set! free-identifier=? + (lambda (syntmp-x-1453 syntmp-y-1454) + (begin + (let ((syntmp-x-1455 syntmp-x-1453)) + (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1455)) + (syntmp-error-hook-93 + 'free-identifier=? + "invalid argument" + syntmp-x-1455))) + (let ((syntmp-x-1456 syntmp-y-1454)) + (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1456)) + (syntmp-error-hook-93 + 'free-identifier=? + "invalid argument" + syntmp-x-1456))) + (syntmp-free-id=?-142 + syntmp-x-1453 + syntmp-y-1454)))) + (set! bound-identifier=? + (lambda (syntmp-x-1457 syntmp-y-1458) + (begin + (let ((syntmp-x-1459 syntmp-x-1457)) + (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1459)) + (syntmp-error-hook-93 + 'bound-identifier=? + "invalid argument" + syntmp-x-1459))) + (let ((syntmp-x-1460 syntmp-y-1458)) + (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1460)) + (syntmp-error-hook-93 + 'bound-identifier=? + "invalid argument" + syntmp-x-1460))) + (syntmp-bound-id=?-143 + syntmp-x-1457 + syntmp-y-1458)))) + (set! syntax-error + (lambda (syntmp-object-1462 . syntmp-messages-1461) + (begin + (for-each + (lambda (syntmp-x-1463) + (let ((syntmp-x-1464 syntmp-x-1463)) + (if (not (string? syntmp-x-1464)) + (syntmp-error-hook-93 + 'syntax-error + "invalid argument" + syntmp-x-1464)))) + syntmp-messages-1461) + (let ((syntmp-message-1465 + (if (null? syntmp-messages-1461) + "invalid syntax" + (apply string-append syntmp-messages-1461)))) + (syntmp-error-hook-93 + #f + syntmp-message-1465 + (syntmp-strip-166 + syntmp-object-1462 + '(()))))))) + (set! install-global-transformer + (lambda (syntmp-sym-1466 syntmp-v-1467) + (begin + (let ((syntmp-x-1468 syntmp-sym-1466)) + (if (not (symbol? syntmp-x-1468)) + (syntmp-error-hook-93 + 'define-syntax + "invalid argument" + syntmp-x-1468))) + (let ((syntmp-x-1469 syntmp-v-1467)) + (if (not (procedure? syntmp-x-1469)) + (syntmp-error-hook-93 + 'define-syntax + "invalid argument" + syntmp-x-1469))) + (syntmp-global-extend-117 + 'macro + syntmp-sym-1466 + syntmp-v-1467)))) + (letrec ((syntmp-match-1474 + (lambda (syntmp-e-1475 + syntmp-p-1476 + syntmp-w-1477 + syntmp-r-1478 + syntmp-mod-1479) + (cond ((not syntmp-r-1478) #f) + ((eq? syntmp-p-1476 (quote any)) + (cons (syntmp-wrap-147 + syntmp-e-1475 + syntmp-w-1477 + syntmp-mod-1479) + syntmp-r-1478)) + ((syntmp-syntax-object?-103 syntmp-e-1475) + (syntmp-match*-1473 + (let ((syntmp-e-1480 + (syntmp-syntax-object-expression-104 + syntmp-e-1475))) + (if (annotation? syntmp-e-1480) + (annotation-expression syntmp-e-1480) + syntmp-e-1480)) + syntmp-p-1476 + (syntmp-join-wraps-138 + syntmp-w-1477 + (syntmp-syntax-object-wrap-105 syntmp-e-1475)) + syntmp-r-1478 + (syntmp-syntax-object-module-106 syntmp-e-1475))) + (else + (syntmp-match*-1473 + (let ((syntmp-e-1481 syntmp-e-1475)) + (if (annotation? syntmp-e-1481) + (annotation-expression syntmp-e-1481) + syntmp-e-1481)) + syntmp-p-1476 + syntmp-w-1477 + syntmp-r-1478 + syntmp-mod-1479))))) + (syntmp-match*-1473 + (lambda (syntmp-e-1482 + syntmp-p-1483 + syntmp-w-1484 + syntmp-r-1485 + syntmp-mod-1486) + (cond ((null? syntmp-p-1483) + (and (null? syntmp-e-1482) syntmp-r-1485)) + ((pair? syntmp-p-1483) + (and (pair? syntmp-e-1482) + (syntmp-match-1474 + (car syntmp-e-1482) + (car syntmp-p-1483) + syntmp-w-1484 + (syntmp-match-1474 + (cdr syntmp-e-1482) + (cdr syntmp-p-1483) + syntmp-w-1484 + syntmp-r-1485 + syntmp-mod-1486) + syntmp-mod-1486))) + ((eq? syntmp-p-1483 (quote each-any)) + (let ((syntmp-l-1487 + (syntmp-match-each-any-1471 + syntmp-e-1482 + syntmp-w-1484 + syntmp-mod-1486))) + (and syntmp-l-1487 + (cons syntmp-l-1487 syntmp-r-1485)))) + (else + (let ((syntmp-t-1488 (vector-ref syntmp-p-1483 0))) + (if (memv syntmp-t-1488 (quote (each))) + (if (null? syntmp-e-1482) + (syntmp-match-empty-1472 + (vector-ref syntmp-p-1483 1) + syntmp-r-1485) + (let ((syntmp-l-1489 + (syntmp-match-each-1470 + syntmp-e-1482 + (vector-ref syntmp-p-1483 1) + syntmp-w-1484 + syntmp-mod-1486))) + (and syntmp-l-1489 + (let syntmp-collect-1490 ((syntmp-l-1491 + syntmp-l-1489)) + (if (null? (car syntmp-l-1491)) + syntmp-r-1485 + (cons (map car syntmp-l-1491) + (syntmp-collect-1490 + (map cdr syntmp-l-1491)))))))) + (if (memv syntmp-t-1488 (quote (free-id))) + (and (syntmp-id?-119 syntmp-e-1482) + (syntmp-free-id=?-142 + (syntmp-wrap-147 + syntmp-e-1482 + syntmp-w-1484 + syntmp-mod-1486) + (vector-ref syntmp-p-1483 1)) + syntmp-r-1485) + (if (memv syntmp-t-1488 (quote (atom))) + (and (equal? + (vector-ref syntmp-p-1483 1) + (syntmp-strip-166 + syntmp-e-1482 + syntmp-w-1484)) + syntmp-r-1485) + (if (memv syntmp-t-1488 (quote (vector))) + (and (vector? syntmp-e-1482) + (syntmp-match-1474 + (vector->list syntmp-e-1482) + (vector-ref syntmp-p-1483 1) + syntmp-w-1484 + syntmp-r-1485 + syntmp-mod-1486))))))))))) + (syntmp-match-empty-1472 + (lambda (syntmp-p-1492 syntmp-r-1493) + (cond ((null? syntmp-p-1492) syntmp-r-1493) + ((eq? syntmp-p-1492 (quote any)) + (cons (quote ()) syntmp-r-1493)) + ((pair? syntmp-p-1492) + (syntmp-match-empty-1472 + (car syntmp-p-1492) + (syntmp-match-empty-1472 + (cdr syntmp-p-1492) + syntmp-r-1493))) + ((eq? syntmp-p-1492 (quote each-any)) + (cons (quote ()) syntmp-r-1493)) + (else + (let ((syntmp-t-1494 (vector-ref syntmp-p-1492 0))) + (if (memv syntmp-t-1494 (quote (each))) + (syntmp-match-empty-1472 + (vector-ref syntmp-p-1492 1) + syntmp-r-1493) + (if (memv syntmp-t-1494 (quote (free-id atom))) + syntmp-r-1493 + (if (memv syntmp-t-1494 (quote (vector))) + (syntmp-match-empty-1472 + (vector-ref syntmp-p-1492 1) + syntmp-r-1493))))))))) + (syntmp-match-each-any-1471 + (lambda (syntmp-e-1495 syntmp-w-1496 syntmp-mod-1497) + (cond ((annotation? syntmp-e-1495) + (syntmp-match-each-any-1471 + (annotation-expression syntmp-e-1495) + syntmp-w-1496 + syntmp-mod-1497)) + ((pair? syntmp-e-1495) + (let ((syntmp-l-1498 + (syntmp-match-each-any-1471 + (cdr syntmp-e-1495) + syntmp-w-1496 + syntmp-mod-1497))) + (and syntmp-l-1498 + (cons (syntmp-wrap-147 + (car syntmp-e-1495) + syntmp-w-1496 + syntmp-mod-1497) + syntmp-l-1498)))) + ((null? syntmp-e-1495) (quote ())) + ((syntmp-syntax-object?-103 syntmp-e-1495) + (syntmp-match-each-any-1471 + (syntmp-syntax-object-expression-104 + syntmp-e-1495) + (syntmp-join-wraps-138 + syntmp-w-1496 + (syntmp-syntax-object-wrap-105 syntmp-e-1495)) + syntmp-mod-1497)) + (else #f)))) + (syntmp-match-each-1470 + (lambda (syntmp-e-1499 + syntmp-p-1500 + syntmp-w-1501 + syntmp-mod-1502) + (cond ((annotation? syntmp-e-1499) + (syntmp-match-each-1470 + (annotation-expression syntmp-e-1499) + syntmp-p-1500 + syntmp-w-1501 + syntmp-mod-1502)) + ((pair? syntmp-e-1499) + (let ((syntmp-first-1503 + (syntmp-match-1474 + (car syntmp-e-1499) + syntmp-p-1500 + syntmp-w-1501 + '() + syntmp-mod-1502))) + (and syntmp-first-1503 + (let ((syntmp-rest-1504 + (syntmp-match-each-1470 + (cdr syntmp-e-1499) + syntmp-p-1500 + syntmp-w-1501 + syntmp-mod-1502))) + (and syntmp-rest-1504 + (cons syntmp-first-1503 + syntmp-rest-1504)))))) + ((null? syntmp-e-1499) (quote ())) + ((syntmp-syntax-object?-103 syntmp-e-1499) + (syntmp-match-each-1470 + (syntmp-syntax-object-expression-104 + syntmp-e-1499) + syntmp-p-1500 + (syntmp-join-wraps-138 + syntmp-w-1501 + (syntmp-syntax-object-wrap-105 syntmp-e-1499)) + (syntmp-syntax-object-module-106 syntmp-e-1499))) + (else #f))))) + (begin + (set! syntax-dispatch + (lambda (syntmp-e-1505 syntmp-p-1506) + (cond ((eq? syntmp-p-1506 (quote any)) + (list syntmp-e-1505)) + ((syntmp-syntax-object?-103 syntmp-e-1505) + (syntmp-match*-1473 + (let ((syntmp-e-1507 + (syntmp-syntax-object-expression-104 + syntmp-e-1505))) + (if (annotation? syntmp-e-1507) + (annotation-expression syntmp-e-1507) + syntmp-e-1507)) + syntmp-p-1506 + (syntmp-syntax-object-wrap-105 syntmp-e-1505) + '() + (syntmp-syntax-object-module-106 syntmp-e-1505))) + (else + (syntmp-match*-1473 + (let ((syntmp-e-1508 syntmp-e-1505)) + (if (annotation? syntmp-e-1508) + (annotation-expression syntmp-e-1508) + syntmp-e-1508)) + syntmp-p-1506 + '(()) + '() + #f))))) + (set! sc-chi syntmp-chi-155))))) +(install-global-transformer + 'with-syntax + (lambda (syntmp-x-1509) + ((lambda (syntmp-tmp-1510) + ((lambda (syntmp-tmp-1511) + (if syntmp-tmp-1511 + (apply (lambda (syntmp-_-1512 syntmp-e1-1513 syntmp-e2-1514) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ e1 e2) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + (cons syntmp-e1-1513 syntmp-e2-1514))) + syntmp-tmp-1511) + ((lambda (syntmp-tmp-1516) + (if syntmp-tmp-1516 + (apply (lambda (syntmp-_-1517 + syntmp-out-1518 + syntmp-in-1519 + syntmp-e1-1520 + syntmp-e2-1521) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + syntmp-in-1519 + '() + (list syntmp-out-1518 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (cons syntmp-e1-1520 + syntmp-e2-1521))))) + syntmp-tmp-1516) + ((lambda (syntmp-tmp-1523) + (if syntmp-tmp-1523 + (apply (lambda (syntmp-_-1524 + syntmp-out-1525 + syntmp-in-1526 + syntmp-e1-1527 + syntmp-e2-1528) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + syntmp-in-1526) + '() + (list syntmp-out-1525 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (cons syntmp-e1-1527 + syntmp-e2-1528))))) + syntmp-tmp-1523) + (syntax-error syntmp-tmp-1510))) + (syntax-dispatch + syntmp-tmp-1510 + '(any #(each (any any)) any . each-any))))) + (syntax-dispatch + syntmp-tmp-1510 + '(any ((any any)) any . each-any))))) + (syntax-dispatch + syntmp-tmp-1510 + '(any () any . each-any)))) + syntmp-x-1509))) +(install-global-transformer + 'syntax-rules + (lambda (syntmp-x-1550) + ((lambda (syntmp-tmp-1551) + ((lambda (syntmp-tmp-1552) + (if syntmp-tmp-1552 + (apply (lambda (syntmp-_-1553 + syntmp-k-1554 + syntmp-keyword-1555 + syntmp-pattern-1556 + syntmp-template-1557) + (list '#(syntax-object + lambda + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + '(#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase))) + (cons '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + (cons '#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + (cons syntmp-k-1554 + (map (lambda (syntmp-tmp-1560 + syntmp-tmp-1559) + (list (cons '#(syntax-object + dummy + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-tmp-1559) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-tmp-1560))) + syntmp-template-1557 + syntmp-pattern-1556)))))) + syntmp-tmp-1552) + (syntax-error syntmp-tmp-1551))) + (syntax-dispatch + syntmp-tmp-1551 + '(any each-any . #(each ((any . any) any)))))) + syntmp-x-1550))) +(install-global-transformer + 'let* + (lambda (syntmp-x-1571) + ((lambda (syntmp-tmp-1572) + ((lambda (syntmp-tmp-1573) + (if (if syntmp-tmp-1573 + (apply (lambda (syntmp-let*-1574 + syntmp-x-1575 + syntmp-v-1576 + syntmp-e1-1577 + syntmp-e2-1578) + (andmap identifier? syntmp-x-1575)) + syntmp-tmp-1573) + #f) + (apply (lambda (syntmp-let*-1580 + syntmp-x-1581 + syntmp-v-1582 + syntmp-e1-1583 + syntmp-e2-1584) + (let syntmp-f-1585 ((syntmp-bindings-1586 + (map list + syntmp-x-1581 + syntmp-v-1582))) + (if (null? syntmp-bindings-1586) + (cons '#(syntax-object + let + ((top) + #(ribcage () () ()) + #(ribcage + #(f bindings) + #((top) (top)) + #("i" "i")) + #(ribcage + #(let* x v e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + (cons '() + (cons syntmp-e1-1583 syntmp-e2-1584))) + ((lambda (syntmp-tmp-1590) + ((lambda (syntmp-tmp-1591) + (if syntmp-tmp-1591 + (apply (lambda (syntmp-body-1592 + syntmp-binding-1593) + (list '#(syntax-object + let + ((top) + #(ribcage + #(body binding) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(f bindings) + #((top) (top)) + #("i" "i")) + #(ribcage + #(let* x v e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (list syntmp-binding-1593) + syntmp-body-1592)) + syntmp-tmp-1591) + (syntax-error syntmp-tmp-1590))) + (syntax-dispatch + syntmp-tmp-1590 + '(any any)))) + (list (syntmp-f-1585 (cdr syntmp-bindings-1586)) + (car syntmp-bindings-1586)))))) + syntmp-tmp-1573) + (syntax-error syntmp-tmp-1572))) + (syntax-dispatch + syntmp-tmp-1572 + '(any #(each (any any)) any . each-any)))) + syntmp-x-1571))) +(install-global-transformer + 'do + (lambda (syntmp-orig-x-1613) + ((lambda (syntmp-tmp-1614) + ((lambda (syntmp-tmp-1615) + (if syntmp-tmp-1615 + (apply (lambda (syntmp-_-1616 + syntmp-var-1617 + syntmp-init-1618 + syntmp-step-1619 + syntmp-e0-1620 + syntmp-e1-1621 + syntmp-c-1622) + ((lambda (syntmp-tmp-1623) + ((lambda (syntmp-tmp-1624) + (if syntmp-tmp-1624 + (apply (lambda (syntmp-step-1625) + ((lambda (syntmp-tmp-1626) + ((lambda (syntmp-tmp-1627) + (if syntmp-tmp-1627 + (apply (lambda () + (list '#(syntax-object + let + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + (map list + syntmp-var-1617 + syntmp-init-1618) + (list '#(syntax-object + if + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + (list '#(syntax-object + not + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-e0-1620) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + (append + syntmp-c-1622 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-step-1625))))))) + syntmp-tmp-1627) + ((lambda (syntmp-tmp-1632) + (if syntmp-tmp-1632 + (apply (lambda (syntmp-e1-1633 + syntmp-e2-1634) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + (map list + syntmp-var-1617 + syntmp-init-1618) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-e0-1620 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + (cons syntmp-e1-1633 + syntmp-e2-1634)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + (append + syntmp-c-1622 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-step-1625))))))) + syntmp-tmp-1632) + (syntax-error + syntmp-tmp-1626))) + (syntax-dispatch + syntmp-tmp-1626 + '(any . each-any))))) + (syntax-dispatch + syntmp-tmp-1626 + '()))) + syntmp-e1-1621)) + syntmp-tmp-1624) + (syntax-error syntmp-tmp-1623))) + (syntax-dispatch + syntmp-tmp-1623 + 'each-any))) + (map (lambda (syntmp-v-1641 syntmp-s-1642) + ((lambda (syntmp-tmp-1643) + ((lambda (syntmp-tmp-1644) + (if syntmp-tmp-1644 + (apply (lambda () syntmp-v-1641) + syntmp-tmp-1644) + ((lambda (syntmp-tmp-1645) + (if syntmp-tmp-1645 + (apply (lambda (syntmp-e-1646) + syntmp-e-1646) + syntmp-tmp-1645) + ((lambda (syntmp-_-1647) + (syntax-error syntmp-orig-x-1613)) + syntmp-tmp-1643))) + (syntax-dispatch + syntmp-tmp-1643 + '(any))))) + (syntax-dispatch syntmp-tmp-1643 (quote ())))) + syntmp-s-1642)) + syntmp-var-1617 + syntmp-step-1619))) + syntmp-tmp-1615) + (syntax-error syntmp-tmp-1614))) + (syntax-dispatch + syntmp-tmp-1614 + '(any #(each (any any . any)) + (any . each-any) + . + each-any)))) + syntmp-orig-x-1613))) +(install-global-transformer + 'quasiquote + (letrec ((syntmp-quasicons-1675 + (lambda (syntmp-x-1679 syntmp-y-1680) + ((lambda (syntmp-tmp-1681) + ((lambda (syntmp-tmp-1682) + (if syntmp-tmp-1682 + (apply (lambda (syntmp-x-1683 syntmp-y-1684) + ((lambda (syntmp-tmp-1685) + ((lambda (syntmp-tmp-1686) + (if syntmp-tmp-1686 + (apply (lambda (syntmp-dy-1687) + ((lambda (syntmp-tmp-1688) + ((lambda (syntmp-tmp-1689) + (if syntmp-tmp-1689 + (apply (lambda (syntmp-dx-1690) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(dx) + #((top)) + #("i")) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (ice-9 syncase)) + (cons syntmp-dx-1690 + syntmp-dy-1687))) + syntmp-tmp-1689) + ((lambda (syntmp-_-1691) + (if (null? syntmp-dy-1687) + (list '#(syntax-object + list + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (ice-9 syncase)) + syntmp-x-1683) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (ice-9 syncase)) + syntmp-x-1683 + syntmp-y-1684))) + syntmp-tmp-1688))) + (syntax-dispatch + syntmp-tmp-1688 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (ice-9 syncase))) + any)))) + syntmp-x-1683)) + syntmp-tmp-1686) + ((lambda (syntmp-tmp-1692) + (if syntmp-tmp-1692 + (apply (lambda (syntmp-stuff-1693) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(stuff) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) + (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (ice-9 syncase)) + (cons syntmp-x-1683 + syntmp-stuff-1693))) + syntmp-tmp-1692) + ((lambda (syntmp-else-1694) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(else) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (ice-9 syncase)) + syntmp-x-1683 + syntmp-y-1684)) + syntmp-tmp-1685))) + (syntax-dispatch + syntmp-tmp-1685 + '(#(free-id + #(syntax-object + list + ((top) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + . + any))))) + (syntax-dispatch + syntmp-tmp-1685 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + any)))) + syntmp-y-1684)) + syntmp-tmp-1682) + (syntax-error syntmp-tmp-1681))) + (syntax-dispatch + syntmp-tmp-1681 + '(any any)))) + (list syntmp-x-1679 syntmp-y-1680)))) + (syntmp-quasiappend-1676 + (lambda (syntmp-x-1695 syntmp-y-1696) + ((lambda (syntmp-tmp-1697) + ((lambda (syntmp-tmp-1698) + (if syntmp-tmp-1698 + (apply (lambda (syntmp-x-1699 syntmp-y-1700) + ((lambda (syntmp-tmp-1701) + ((lambda (syntmp-tmp-1702) + (if syntmp-tmp-1702 + (apply (lambda () syntmp-x-1699) + syntmp-tmp-1702) + ((lambda (syntmp-_-1703) + (list '#(syntax-object + append + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + syntmp-x-1699 + syntmp-y-1700)) + syntmp-tmp-1701))) + (syntax-dispatch + syntmp-tmp-1701 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + ())))) + syntmp-y-1700)) + syntmp-tmp-1698) + (syntax-error syntmp-tmp-1697))) + (syntax-dispatch + syntmp-tmp-1697 + '(any any)))) + (list syntmp-x-1695 syntmp-y-1696)))) + (syntmp-quasivector-1677 + (lambda (syntmp-x-1704) + ((lambda (syntmp-tmp-1705) + ((lambda (syntmp-x-1706) + ((lambda (syntmp-tmp-1707) + ((lambda (syntmp-tmp-1708) + (if syntmp-tmp-1708 + (apply (lambda (syntmp-x-1709) + (list '#(syntax-object + quote + ((top) + #(ribcage #(x) #((top)) #("i")) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + (list->vector syntmp-x-1709))) + syntmp-tmp-1708) + ((lambda (syntmp-tmp-1711) + (if syntmp-tmp-1711 + (apply (lambda (syntmp-x-1712) + (cons '#(syntax-object + vector + ((top) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + syntmp-x-1712)) + syntmp-tmp-1711) + ((lambda (syntmp-_-1714) + (list '#(syntax-object + list->vector + ((top) + #(ribcage #(_) #((top)) #("i")) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + syntmp-x-1706)) + syntmp-tmp-1707))) + (syntax-dispatch + syntmp-tmp-1707 + '(#(free-id + #(syntax-object + list + ((top) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + . + each-any))))) + (syntax-dispatch + syntmp-tmp-1707 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(quasicons quasiappend quasivector quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + each-any)))) + syntmp-x-1706)) + syntmp-tmp-1705)) + syntmp-x-1704))) + (syntmp-quasi-1678 + (lambda (syntmp-p-1715 syntmp-lev-1716) + ((lambda (syntmp-tmp-1717) + ((lambda (syntmp-tmp-1718) + (if syntmp-tmp-1718 + (apply (lambda (syntmp-p-1719) + (if (= syntmp-lev-1716 0) + syntmp-p-1719 + (syntmp-quasicons-1675 + '(#(syntax-object + quote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + #(syntax-object + unquote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + (syntmp-quasi-1678 + (list syntmp-p-1719) + (- syntmp-lev-1716 1))))) + syntmp-tmp-1718) + ((lambda (syntmp-tmp-1720) + (if syntmp-tmp-1720 + (apply (lambda (syntmp-p-1721 syntmp-q-1722) + (if (= syntmp-lev-1716 0) + (syntmp-quasiappend-1676 + syntmp-p-1721 + (syntmp-quasi-1678 + syntmp-q-1722 + syntmp-lev-1716)) + (syntmp-quasicons-1675 + (syntmp-quasicons-1675 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + #(syntax-object + unquote-splicing + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + (syntmp-quasi-1678 + (list syntmp-p-1721) + (- syntmp-lev-1716 1))) + (syntmp-quasi-1678 + syntmp-q-1722 + syntmp-lev-1716)))) + syntmp-tmp-1720) + ((lambda (syntmp-tmp-1723) + (if syntmp-tmp-1723 + (apply (lambda (syntmp-p-1724) + (syntmp-quasicons-1675 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + #(syntax-object + quasiquote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + (syntmp-quasi-1678 + (list syntmp-p-1724) + (+ syntmp-lev-1716 1)))) + syntmp-tmp-1723) + ((lambda (syntmp-tmp-1725) + (if syntmp-tmp-1725 + (apply (lambda (syntmp-p-1726 + syntmp-q-1727) + (syntmp-quasicons-1675 + (syntmp-quasi-1678 + syntmp-p-1726 + syntmp-lev-1716) + (syntmp-quasi-1678 + syntmp-q-1727 + syntmp-lev-1716))) + syntmp-tmp-1725) + ((lambda (syntmp-tmp-1728) + (if syntmp-tmp-1728 + (apply (lambda (syntmp-x-1729) + (syntmp-quasivector-1677 + (syntmp-quasi-1678 + syntmp-x-1729 + syntmp-lev-1716))) + syntmp-tmp-1728) + ((lambda (syntmp-p-1731) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase)) + syntmp-p-1731)) + syntmp-tmp-1717))) + (syntax-dispatch + syntmp-tmp-1717 + '#(vector each-any))))) + (syntax-dispatch + syntmp-tmp-1717 + '(any . any))))) + (syntax-dispatch + syntmp-tmp-1717 + '(#(free-id + #(syntax-object + quasiquote + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + any))))) + (syntax-dispatch + syntmp-tmp-1717 + '((#(free-id + #(syntax-object + unquote-splicing + ((top) + #(ribcage () () ()) + #(ribcage #(p lev) #((top) (top)) #("i" "i")) + #(ribcage + #(quasicons quasiappend quasivector quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + any) + . + any))))) + (syntax-dispatch + syntmp-tmp-1717 + '(#(free-id + #(syntax-object + unquote + ((top) + #(ribcage () () ()) + #(ribcage #(p lev) #((top) (top)) #("i" "i")) + #(ribcage + #(quasicons quasiappend quasivector quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (ice-9 syncase))) + any)))) + syntmp-p-1715)))) + (lambda (syntmp-x-1732) + ((lambda (syntmp-tmp-1733) + ((lambda (syntmp-tmp-1734) + (if syntmp-tmp-1734 + (apply (lambda (syntmp-_-1735 syntmp-e-1736) + (syntmp-quasi-1678 syntmp-e-1736 0)) + syntmp-tmp-1734) + (syntax-error syntmp-tmp-1733))) + (syntax-dispatch + syntmp-tmp-1733 + '(any any)))) + syntmp-x-1732)))) +(install-global-transformer + 'include + (lambda (syntmp-x-1796) + (letrec ((syntmp-read-file-1797 + (lambda (syntmp-fn-1798 syntmp-k-1799) + (let ((syntmp-p-1800 (open-input-file syntmp-fn-1798))) + (let syntmp-f-1801 ((syntmp-x-1802 (read syntmp-p-1800))) + (if (eof-object? syntmp-x-1802) + (begin + (close-input-port syntmp-p-1800) + '()) + (cons (datum->syntax-object + syntmp-k-1799 + syntmp-x-1802) + (syntmp-f-1801 (read syntmp-p-1800))))))))) + ((lambda (syntmp-tmp-1803) + ((lambda (syntmp-tmp-1804) + (if syntmp-tmp-1804 + (apply (lambda (syntmp-k-1805 syntmp-filename-1806) + (let ((syntmp-fn-1807 + (syntax-object->datum syntmp-filename-1806))) + ((lambda (syntmp-tmp-1808) + ((lambda (syntmp-tmp-1809) + (if syntmp-tmp-1809 + (apply (lambda (syntmp-exp-1810) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(exp) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(fn) + #((top)) + #("i")) + #(ribcage + #(k filename) + #((top) (top)) + #("i" "i")) + #(ribcage + (read-file) + ((top)) + ("i")) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-exp-1810)) + syntmp-tmp-1809) + (syntax-error syntmp-tmp-1808))) + (syntax-dispatch + syntmp-tmp-1808 + 'each-any))) + (syntmp-read-file-1797 + syntmp-fn-1807 + syntmp-k-1805)))) + syntmp-tmp-1804) + (syntax-error syntmp-tmp-1803))) + (syntax-dispatch + syntmp-tmp-1803 + '(any any)))) + syntmp-x-1796)))) +(install-global-transformer + 'unquote + (lambda (syntmp-x-1827) + ((lambda (syntmp-tmp-1828) + ((lambda (syntmp-tmp-1829) + (if syntmp-tmp-1829 + (apply (lambda (syntmp-_-1830 syntmp-e-1831) + (error 'unquote + "expression ,~s not valid outside of quasiquote" + (syntax-object->datum syntmp-e-1831))) + syntmp-tmp-1829) + (syntax-error syntmp-tmp-1828))) + (syntax-dispatch + syntmp-tmp-1828 + '(any any)))) + syntmp-x-1827))) +(install-global-transformer + 'unquote-splicing + (lambda (syntmp-x-1837) + ((lambda (syntmp-tmp-1838) + ((lambda (syntmp-tmp-1839) + (if syntmp-tmp-1839 + (apply (lambda (syntmp-_-1840 syntmp-e-1841) + (error 'unquote-splicing + "expression ,@~s not valid outside of quasiquote" + (syntax-object->datum syntmp-e-1841))) + syntmp-tmp-1839) + (syntax-error syntmp-tmp-1838))) + (syntax-dispatch + syntmp-tmp-1838 + '(any any)))) + syntmp-x-1837))) +(install-global-transformer + 'case + (lambda (syntmp-x-1847) + ((lambda (syntmp-tmp-1848) + ((lambda (syntmp-tmp-1849) + (if syntmp-tmp-1849 + (apply (lambda (syntmp-_-1850 + syntmp-e-1851 + syntmp-m1-1852 + syntmp-m2-1853) + ((lambda (syntmp-tmp-1854) + ((lambda (syntmp-body-1855) + (list '#(syntax-object + let + ((top) + #(ribcage #(body) #((top)) #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(body) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-e-1851)) + syntmp-body-1855)) + syntmp-tmp-1854)) + (let syntmp-f-1856 ((syntmp-clause-1857 syntmp-m1-1852) + (syntmp-clauses-1858 syntmp-m2-1853)) + (if (null? syntmp-clauses-1858) + ((lambda (syntmp-tmp-1860) + ((lambda (syntmp-tmp-1861) + (if syntmp-tmp-1861 + (apply (lambda (syntmp-e1-1862 + syntmp-e2-1863) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 e2) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(f clause clauses) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (cons syntmp-e1-1862 + syntmp-e2-1863))) + syntmp-tmp-1861) + ((lambda (syntmp-tmp-1865) + (if syntmp-tmp-1865 + (apply (lambda (syntmp-k-1866 + syntmp-e1-1867 + syntmp-e2-1868) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(f clause clauses) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + '#(syntax-object + t + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-k-1866)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (cons syntmp-e1-1867 + syntmp-e2-1868)))) + syntmp-tmp-1865) + ((lambda (syntmp-_-1871) + (syntax-error syntmp-x-1847)) + syntmp-tmp-1860))) + (syntax-dispatch + syntmp-tmp-1860 + '(each-any any . each-any))))) + (syntax-dispatch + syntmp-tmp-1860 + '(#(free-id + #(syntax-object + else + ((top) + #(ribcage () () ()) + #(ribcage + #(f clause clauses) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase))) + any + . + each-any)))) + syntmp-clause-1857) + ((lambda (syntmp-tmp-1872) + ((lambda (syntmp-rest-1873) + ((lambda (syntmp-tmp-1874) + ((lambda (syntmp-tmp-1875) + (if syntmp-tmp-1875 + (apply (lambda (syntmp-k-1876 + syntmp-e1-1877 + syntmp-e2-1878) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + '#(syntax-object + t + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-k-1876)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k e1 e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (cons syntmp-e1-1877 + syntmp-e2-1878)) + syntmp-rest-1873)) + syntmp-tmp-1875) + ((lambda (syntmp-_-1881) + (syntax-error syntmp-x-1847)) + syntmp-tmp-1874))) + (syntax-dispatch + syntmp-tmp-1874 + '(each-any any . each-any)))) + syntmp-clause-1857)) + syntmp-tmp-1872)) + (syntmp-f-1856 + (car syntmp-clauses-1858) + (cdr syntmp-clauses-1858))))))) + syntmp-tmp-1849) + (syntax-error syntmp-tmp-1848))) + (syntax-dispatch + syntmp-tmp-1848 + '(any any any . each-any)))) + syntmp-x-1847))) +(install-global-transformer + 'identifier-syntax + (lambda (syntmp-x-1911) + ((lambda (syntmp-tmp-1912) + ((lambda (syntmp-tmp-1913) + (if syntmp-tmp-1913 + (apply (lambda (syntmp-_-1914 syntmp-e-1915) + (list '#(syntax-object + lambda + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + '(#(syntax-object + x + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase))) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + '#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + '() + (list '#(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + '(#(syntax-object + identifier? + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + (#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)) + #(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (ice-9 syncase)))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + syntmp-e-1915)) + (list (cons syntmp-_-1914 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + (cons syntmp-e-1915 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase)) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (ice-9 syncase))))))))) + syntmp-tmp-1913) + (syntax-error syntmp-tmp-1912))) + (syntax-dispatch + syntmp-tmp-1912 + '(any any)))) + syntmp-x-1911))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index a7c8c563f..e3dd528a5 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -320,11 +320,13 @@ (define top-level-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (or mod (interaction-environment))))) + (eval `(,noexpand ,x) (if mod (resolve-module mod) + (interaction-environment))))) (define local-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (or mod (interaction-environment))))) + (eval `(,noexpand ,x) (if mod (resolve-module mod) + (interaction-environment))))) (define error-hook (lambda (who why what) @@ -336,7 +338,9 @@ (define put-global-definition-hook (lambda (symbol binding module) - (let* ((module (or module (warn "wha" symbol (current-module)))) + (let* ((module (if module + (resolve-module module) + (warn "wha" symbol (current-module)))) (v (or (module-variable module symbol) (let ((v (make-variable sc-macro))) (module-add! module symbol v) @@ -351,7 +355,9 @@ (define get-global-definition-hook (lambda (symbol module) - (let* ((module (or module (warn "wha" symbol (current-module)))) + (let* ((module (if module + (resolve-module module) + (warn "wha" symbol (current-module)))) (v (module-variable module symbol))) (and v (or (object-property v '*sc-expander*) @@ -392,14 +398,13 @@ (syntax-rules () ((_ source var mod) (build-annotated source - (make-module-ref (and mod (module-name mod)) var #f))))) + (make-module-ref mod var #f))))) (define-syntax build-global-assignment (syntax-rules () ((_ source var exp mod) (build-annotated source - `(set! ,(make-module-ref (and mod (module-name mod)) var #f) - ,exp))))) + `(set! ,(make-module-ref mod var #f) ,exp))))) (define-syntax build-global-definition (syntax-rules () @@ -588,7 +593,7 @@ (define global-extend (lambda (type sym val) (put-global-definition-hook sym (make-binding type val) - (current-module)))) + (module-name (current-module))))) ;;; Conceptually, identifiers are always syntax objects. Internally, @@ -1128,7 +1133,10 @@ e r w s mod)) ((global-call) (chi-application - (build-global-reference (source-annotation (car e)) value mod) + (build-global-reference (source-annotation (car e)) value + (if (syntax-object? (car e)) + (syntax-object-module (car e)) + mod)) e r w s mod)) ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) ((global) (build-global-reference s value mod)) @@ -1185,7 +1193,7 @@ (if rib (cons rib (cons 'shift s)) (cons 'shift s))) - (procedure-module p)))))) ;; hither the hygiene + (module-name (procedure-module p))))))) ;; hither the hygiene ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -1920,7 +1928,8 @@ (lambda (x) (if (and (pair? x) (equal? (car x) noexpand)) (cadr x) - (chi-top x null-env top-wrap m esew (current-module)))))) + (chi-top x null-env top-wrap m esew + (module-name (current-module))))))) (set! sc-expand3 (let ((m 'e) (esew '(eval))) @@ -1934,7 +1943,7 @@ (if (or (null? rest) (null? (cdr rest))) esew (cadr rest)) - (current-module)))))) + (module-name (current-module))))))) (set! identifier? (lambda (x) @@ -2006,34 +2015,36 @@ (let () (define match-each - (lambda (e p w) + (lambda (e p w mod) (cond ((annotation? e) - (match-each (annotation-expression e) p w)) + (match-each (annotation-expression e) p w mod)) ((pair? e) - (let ((first (match (car e) p w '()))) + (let ((first (match (car e) p w '() mod))) (and first - (let ((rest (match-each (cdr e) p w))) + (let ((rest (match-each (cdr e) p w mod))) (and rest (cons first rest)))))) ((null? e) '()) ((syntax-object? e) (match-each (syntax-object-expression e) p - (join-wraps w (syntax-object-wrap e)))) + (join-wraps w (syntax-object-wrap e)) + (syntax-object-module e))) (else #f)))) (define match-each-any - (lambda (e w) + (lambda (e w mod) (cond ((annotation? e) - (match-each-any (annotation-expression e) w)) + (match-each-any (annotation-expression e) w mod)) ((pair? e) - (let ((l (match-each-any (cdr e) w))) - (and l (cons (wrap (car e) w #f) l)))) + (let ((l (match-each-any (cdr e) w mod))) + (and l (cons (wrap (car e) w mod) l)))) ((null? e) '()) ((syntax-object? e) (match-each-any (syntax-object-expression e) - (join-wraps w (syntax-object-wrap e)))) + (join-wraps w (syntax-object-wrap e)) + mod)) (else #f)))) (define match-empty @@ -2050,43 +2061,45 @@ ((vector) (match-empty (vector-ref p 1) r))))))) (define match* - (lambda (e p w r) + (lambda (e p w r mod) (cond ((null? p) (and (null? e) r)) ((pair? p) (and (pair? e) (match (car e) (car p) w - (match (cdr e) (cdr p) w r)))) + (match (cdr e) (cdr p) w r mod) + mod))) ((eq? p 'each-any) - (let ((l (match-each-any e w))) (and l (cons l r)))) + (let ((l (match-each-any e w mod))) (and l (cons l r)))) (else (case (vector-ref p 0) ((each) (if (null? e) (match-empty (vector-ref p 1) r) - (let ((l (match-each e (vector-ref p 1) w))) + (let ((l (match-each e (vector-ref p 1) w mod))) (and l (let collect ((l l)) (if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))))) - ((free-id) (and (id? e) (free-id=? (wrap e w #f) (vector-ref p 1)) r)) + ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) ((atom) (and (equal? (vector-ref p 1) (strip e w)) r)) ((vector) (and (vector? e) - (match (vector->list e) (vector-ref p 1) w r)))))))) + (match (vector->list e) (vector-ref p 1) w r mod)))))))) (define match - (lambda (e p w r) + (lambda (e p w r mod) (cond ((not r) #f) - ((eq? p 'any) (cons (wrap e w #f) r)) + ((eq? p 'any) (cons (wrap e w mod) r)) ((syntax-object? e) (match* (unannotate (syntax-object-expression e)) p (join-wraps w (syntax-object-wrap e)) - r)) - (else (match* (unannotate e) p w r))))) + r + (syntax-object-module e))) + (else (match* (unannotate e) p w r mod))))) (set! syntax-dispatch (lambda (e p) @@ -2094,8 +2107,8 @@ ((eq? p 'any) (list e)) ((syntax-object? e) (match* (unannotate (syntax-object-expression e)) - p (syntax-object-wrap e) '())) - (else (match* (unannotate e) p empty-wrap '()))))) + p (syntax-object-wrap e) '() (syntax-object-module e))) + (else (match* (unannotate e) p empty-wrap '() #f))))) (set! sc-chi chi) )) diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index ba9ed7114..8fed4d8d6 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -108,7 +108,8 @@ (if (symbol? e) ;; pass the expression through e - (let ((m (module-ref mod (car e)))) + (let* ((mod (resolve-module mod)) + (m (module-ref mod (car e)))) (if (eq? (macro-type m) 'syntax) ;; pass the expression through e @@ -120,7 +121,7 @@ e (if (null? r) (sc-expand e) - (sc-chi e r w mod))))))))))) + (sc-chi e r w (module-name mod)))))))))))) (define generated-symbols (make-weak-key-hash-table 1019)) From 900761bc8dd8713609c9adc886dec3f3aafb2d7b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 5 Apr 2009 11:52:22 -0700 Subject: [PATCH 037/375] hygienic compilation * module/language/scheme/compile-ghil.scm (lookup-transformer): Recognize macros as initial (@ ...) or (@@ ...) forms, enabling hygienic compilation. --- module/language/scheme/compile-ghil.scm | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index bd4fc2cfe..86234059e 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -94,17 +94,25 @@ ;; ;; FIXME shadowing lexicals? (define (lookup-transformer head retrans) + (define (module-ref/safe mod sym) + (and mod + (and=> (module-variable mod sym) + (lambda (var) + ;; unbound vars can happen if the module + ;; definition forward-declared them + (and (variable-bound? var) (variable-ref var)))))) (let* ((mod (current-module)) (val (cond - ((symbol? head) - (and=> (module-variable mod head) - (lambda (var) - ;; unbound vars can happen if the module - ;; definition forward-declared them - (and (variable-bound? var) (variable-ref var))))) + ((symbol? head) (module-ref/safe mod head)) ;; allow macros to be unquoted into the output of a macro ;; expansion ((macro? head) head) + ((pmatch head + ((@ ,modname ,sym) + (module-ref/safe (resolve-interface modname) sym)) + ((@@ ,modname ,sym) + (module-ref/safe (resolve-module modname) sym)) + (else #f))) (else #f)))) (cond ((hashq-ref *translate-table* val)) From 249bab1c5341d957c69d1258e73898a2281c317f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 9 Mar 2009 21:26:44 +0100 Subject: [PATCH 038/375] @ and @@ as primitive macros * libguile/eval.h: * libguile/eval.c (error_unbound_variable, error_defined_variable): Move these prototypes up earlier. (scm_m_at, scm_m_atat): New functions, provide the @ and @@ functionality. Moved here from defmacros because they are "special", inasmuch as syncase doesn't really understand them in interpreted code. * module/ice-9/boot-9.scm (@, @@): Don't define as defmacros, as defmacros have to actually return source now. --- libguile/eval.c | 46 ++++++++++++++++++++++++++++++++++++++--- libguile/eval.h | 4 ++++ module/ice-9/boot-9.scm | 25 ---------------------- 3 files changed, 47 insertions(+), 28 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 48b229903..12888c2fe 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -306,6 +306,9 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) { if (SCM_UNLIKELY (!(cond))) \ syntax_error (message, form, expr); } +static void error_unbound_variable (SCM symbol) SCM_NORETURN; +static void error_defined_variable (SCM symbol) SCM_NORETURN; + /* {Ilocs} @@ -1976,6 +1979,46 @@ unmemoize_set_x (const SCM expr, const SCM env) /* Start of the memoizers for non-R5RS builtin macros. */ +SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at); +SCM_GLOBAL_SYMBOL (scm_sym_at, s_at); + +SCM +scm_m_at (SCM expr, SCM env SCM_UNUSED) +{ + SCM mod, var; + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + mod = scm_resolve_module (scm_cadr (expr)); + if (scm_is_false (mod)) + error_unbound_variable (expr); + var = scm_module_variable (scm_module_public_interface (mod), scm_caddr (expr)); + if (scm_is_false (var)) + error_unbound_variable (expr); + + return var; +} + +SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat); +SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat); + +SCM +scm_m_atat (SCM expr, SCM env SCM_UNUSED) +{ + SCM mod, var; + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + mod = scm_resolve_module (scm_cadr (expr)); + if (scm_is_false (mod)) + error_unbound_variable (expr); + var = scm_module_variable (mod, scm_caddr (expr)); + if (scm_is_false (var)) + error_unbound_variable (expr); + + return var; +} + SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply); SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); @@ -2662,9 +2705,6 @@ scm_ilookup (SCM iloc, SCM env) SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); -static void error_unbound_variable (SCM symbol) SCM_NORETURN; -static void error_defined_variable (SCM symbol) SCM_NORETURN; - /* Call this for variables that are unfound. */ static void diff --git a/libguile/eval.h b/libguile/eval.h index 333265263..f3ec2e19c 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -94,6 +94,8 @@ SCM_API SCM scm_sym_quasiquote; SCM_API SCM scm_sym_unquote; SCM_API SCM scm_sym_uq_splicing; +SCM_API SCM scm_sym_at; +SCM_API SCM scm_sym_atat; SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; @@ -131,6 +133,8 @@ SCM_API SCM scm_m_future (SCM xorig, SCM env); SCM_API SCM scm_m_define (SCM x, SCM env); SCM_API SCM scm_m_letrec (SCM xorig, SCM env); SCM_API SCM scm_m_let (SCM xorig, SCM env); +SCM_API SCM scm_m_at (SCM xorig, SCM env); +SCM_API SCM scm_m_atat (SCM xorig, SCM env); SCM_API SCM scm_m_apply (SCM xorig, SCM env); SCM_API SCM scm_m_cont (SCM xorig, SCM env); #if SCM_ENABLE_ELISP diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 29c89b1f9..03d876907 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2936,31 +2936,6 @@ module '(ice-9 q) '(make-q q-length))}." (define load load-module) -;; The following macro allows one to write, for example, -;; -;; (@ (ice-9 pretty-print) pretty-print) -;; -;; to refer directly to the pretty-print variable in module (ice-9 -;; pretty-print). It works by looking up the variable and inserting -;; it directly into the code. This is understood by the evaluator. -;; Indeed, all references to global variables are memoized into such -;; variable objects. - -(define-macro (@ mod-name var-name) - (let ((var (module-variable (resolve-interface mod-name) var-name))) - (if (not var) - (error "no such public variable" (list '@ mod-name var-name))) - var)) - -;; The '@@' macro is like '@' but it can also access bindings that -;; have not been explicitely exported. - -(define-macro (@@ mod-name var-name) - (let ((var (module-variable (resolve-module mod-name) var-name))) - (if (not var) - (error "no such variable" (list '@@ mod-name var-name))) - var)) - ;;; {Compiler interface} From 196b40932e34dc481d9c0450695726086febc476 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 9 Mar 2009 20:32:05 +0100 Subject: [PATCH 039/375] fix handling of pre-modules errors in the vm * libguile/vm-i-system.c (toplevel-ref, toplevel-set): Correct situation whereby we would not throw when toplevel vars were unbound, before modules had booted. --- libguile/vm-i-system.c | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 303ef315d..5468604d2 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -284,7 +284,13 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) /* might longjmp */ what = scm_module_lookup (mod, what); else - what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + { + SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + if (scm_is_false (v)) + SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what)); + else + what = v; + } } else { @@ -367,7 +373,13 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) /* might longjmp */ what = scm_module_lookup (mod, what); else - what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + { + SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + if (scm_is_false (v)) + SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what)); + else + what = v; + } } else { From c5cc65ac0ce636f93572592c7a63f4ecea17dc4b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 6 Apr 2009 22:48:03 -0700 Subject: [PATCH 040/375] fix hygiene + modules + local macros * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/psyntax.scm (syntax-type): Look up the type of the car of a form relative to its module, if it is a syntax object. Fixes hygiene wrt modules and private macros. * module/ice-9/syncase.scm (sc-macro): Add a comment. * module/system/base/pmatch.scm: The big test case: just export pmatch, not ppat too. --- module/ice-9/psyntax-pp.scm | 9481 +-------------------------------- module/ice-9/psyntax.scm | 4 +- module/ice-9/syncase.scm | 2 + module/system/base/pmatch.scm | 2 +- 4 files changed, 17 insertions(+), 9472 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0138c53a7..0ae942270 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,9470 +1,11 @@ -(letrec ((syntmp-lambda-var-list-168 - (lambda (syntmp-vars-559) - (let syntmp-lvl-560 ((syntmp-vars-561 syntmp-vars-559) - (syntmp-ls-562 (quote ())) - (syntmp-w-563 (quote (())))) - (cond ((pair? syntmp-vars-561) - (syntmp-lvl-560 - (cdr syntmp-vars-561) - (cons (syntmp-wrap-147 - (car syntmp-vars-561) - syntmp-w-563 - #f) - syntmp-ls-562) - syntmp-w-563)) - ((syntmp-id?-119 syntmp-vars-561) - (cons (syntmp-wrap-147 syntmp-vars-561 syntmp-w-563 #f) - syntmp-ls-562)) - ((null? syntmp-vars-561) syntmp-ls-562) - ((syntmp-syntax-object?-103 syntmp-vars-561) - (syntmp-lvl-560 - (syntmp-syntax-object-expression-104 - syntmp-vars-561) - syntmp-ls-562 - (syntmp-join-wraps-138 - syntmp-w-563 - (syntmp-syntax-object-wrap-105 syntmp-vars-561)))) - ((annotation? syntmp-vars-561) - (syntmp-lvl-560 - (annotation-expression syntmp-vars-561) - syntmp-ls-562 - syntmp-w-563)) - (else (cons syntmp-vars-561 syntmp-ls-562)))))) - (syntmp-gen-var-167 - (lambda (syntmp-id-564) - (let ((syntmp-id-565 - (if (syntmp-syntax-object?-103 syntmp-id-564) - (syntmp-syntax-object-expression-104 - syntmp-id-564) - syntmp-id-564))) - (if (annotation? syntmp-id-565) - (syntmp-build-annotated-96 - (annotation-source syntmp-id-565) - (gensym - (symbol->string - (annotation-expression syntmp-id-565)))) - (syntmp-build-annotated-96 - #f - (gensym (symbol->string syntmp-id-565))))))) - (syntmp-strip-166 - (lambda (syntmp-x-566 syntmp-w-567) - (if (memq 'top - (syntmp-wrap-marks-122 syntmp-w-567)) - (if (or (annotation? syntmp-x-566) - (and (pair? syntmp-x-566) - (annotation? (car syntmp-x-566)))) - (syntmp-strip-annotation-165 syntmp-x-566 #f) - syntmp-x-566) - (let syntmp-f-568 ((syntmp-x-569 syntmp-x-566)) - (cond ((syntmp-syntax-object?-103 syntmp-x-569) - (syntmp-strip-166 - (syntmp-syntax-object-expression-104 - syntmp-x-569) - (syntmp-syntax-object-wrap-105 syntmp-x-569))) - ((pair? syntmp-x-569) - (let ((syntmp-a-570 (syntmp-f-568 (car syntmp-x-569))) - (syntmp-d-571 (syntmp-f-568 (cdr syntmp-x-569)))) - (if (and (eq? syntmp-a-570 (car syntmp-x-569)) - (eq? syntmp-d-571 (cdr syntmp-x-569))) - syntmp-x-569 - (cons syntmp-a-570 syntmp-d-571)))) - ((vector? syntmp-x-569) - (let ((syntmp-old-572 (vector->list syntmp-x-569))) - (let ((syntmp-new-573 - (map syntmp-f-568 syntmp-old-572))) - (if (andmap eq? syntmp-old-572 syntmp-new-573) - syntmp-x-569 - (list->vector syntmp-new-573))))) - (else syntmp-x-569)))))) - (syntmp-strip-annotation-165 - (lambda (syntmp-x-574 syntmp-parent-575) - (cond ((pair? syntmp-x-574) - (let ((syntmp-new-576 (cons #f #f))) - (begin - (if syntmp-parent-575 - (set-annotation-stripped! - syntmp-parent-575 - syntmp-new-576)) - (set-car! - syntmp-new-576 - (syntmp-strip-annotation-165 - (car syntmp-x-574) - #f)) - (set-cdr! - syntmp-new-576 - (syntmp-strip-annotation-165 - (cdr syntmp-x-574) - #f)) - syntmp-new-576))) - ((annotation? syntmp-x-574) - (or (annotation-stripped syntmp-x-574) - (syntmp-strip-annotation-165 - (annotation-expression syntmp-x-574) - syntmp-x-574))) - ((vector? syntmp-x-574) - (let ((syntmp-new-577 - (make-vector (vector-length syntmp-x-574)))) - (begin - (if syntmp-parent-575 - (set-annotation-stripped! - syntmp-parent-575 - syntmp-new-577)) - (let syntmp-loop-578 ((syntmp-i-579 - (- (vector-length syntmp-x-574) - 1))) - (unless - (syntmp-fx<-90 syntmp-i-579 0) - (vector-set! - syntmp-new-577 - syntmp-i-579 - (syntmp-strip-annotation-165 - (vector-ref syntmp-x-574 syntmp-i-579) - #f)) - (syntmp-loop-578 (syntmp-fx--88 syntmp-i-579 1)))) - syntmp-new-577))) - (else syntmp-x-574)))) - (syntmp-ellipsis?-164 - (lambda (syntmp-x-580) - (and (syntmp-nonsymbol-id?-118 syntmp-x-580) - (syntmp-free-id=?-142 - syntmp-x-580 - '#(syntax-object - ... - ((top) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage (define-structure) ((top)) ("i"))) - (ice-9 syncase)))))) - (syntmp-chi-void-163 - (lambda () - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 #f (quote void)))))) - (syntmp-eval-local-transformer-162 - (lambda (syntmp-expanded-581 syntmp-mod-582) - (let ((syntmp-p-583 - (syntmp-local-eval-hook-92 - syntmp-expanded-581 - syntmp-mod-582))) - (if (procedure? syntmp-p-583) - syntmp-p-583 - (syntax-error - syntmp-p-583 - "nonprocedure transformer"))))) - (syntmp-chi-local-syntax-161 - (lambda (syntmp-rec?-584 - syntmp-e-585 - syntmp-r-586 - syntmp-w-587 - syntmp-s-588 - syntmp-mod-589 - syntmp-k-590) - ((lambda (syntmp-tmp-591) - ((lambda (syntmp-tmp-592) - (if syntmp-tmp-592 - (apply (lambda (syntmp-_-593 - syntmp-id-594 - syntmp-val-595 - syntmp-e1-596 - syntmp-e2-597) - (let ((syntmp-ids-598 syntmp-id-594)) - (if (not (syntmp-valid-bound-ids?-144 - syntmp-ids-598)) - (syntax-error - syntmp-e-585 - "duplicate bound keyword in") - (let ((syntmp-labels-600 - (syntmp-gen-labels-125 - syntmp-ids-598))) - (let ((syntmp-new-w-601 - (syntmp-make-binding-wrap-136 - syntmp-ids-598 - syntmp-labels-600 - syntmp-w-587))) - (syntmp-k-590 - (cons syntmp-e1-596 syntmp-e2-597) - (syntmp-extend-env-113 - syntmp-labels-600 - (let ((syntmp-w-603 - (if syntmp-rec?-584 - syntmp-new-w-601 - syntmp-w-587)) - (syntmp-trans-r-604 - (syntmp-macros-only-env-115 - syntmp-r-586))) - (map (lambda (syntmp-x-605) - (cons 'macro - (syntmp-eval-local-transformer-162 - (syntmp-chi-155 - syntmp-x-605 - syntmp-trans-r-604 - syntmp-w-603 - syntmp-mod-589) - syntmp-mod-589))) - syntmp-val-595)) - syntmp-r-586) - syntmp-new-w-601 - syntmp-s-588 - syntmp-mod-589)))))) - syntmp-tmp-592) - ((lambda (syntmp-_-607) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-585 - syntmp-w-587 - syntmp-s-588 - syntmp-mod-589))) - syntmp-tmp-591))) - (syntax-dispatch - syntmp-tmp-591 - '(any #(each (any any)) any . each-any)))) - syntmp-e-585))) - (syntmp-chi-lambda-clause-160 - (lambda (syntmp-e-608 - syntmp-c-609 - syntmp-r-610 - syntmp-w-611 - syntmp-mod-612 - syntmp-k-613) - ((lambda (syntmp-tmp-614) - ((lambda (syntmp-tmp-615) - (if syntmp-tmp-615 - (apply (lambda (syntmp-id-616 syntmp-e1-617 syntmp-e2-618) - (let ((syntmp-ids-619 syntmp-id-616)) - (if (not (syntmp-valid-bound-ids?-144 - syntmp-ids-619)) - (syntax-error - syntmp-e-608 - "invalid parameter list in") - (let ((syntmp-labels-621 - (syntmp-gen-labels-125 - syntmp-ids-619)) - (syntmp-new-vars-622 - (map syntmp-gen-var-167 - syntmp-ids-619))) - (syntmp-k-613 - syntmp-new-vars-622 - (syntmp-chi-body-159 - (cons syntmp-e1-617 syntmp-e2-618) - syntmp-e-608 - (syntmp-extend-var-env-114 - syntmp-labels-621 - syntmp-new-vars-622 - syntmp-r-610) - (syntmp-make-binding-wrap-136 - syntmp-ids-619 - syntmp-labels-621 - syntmp-w-611) - syntmp-mod-612)))))) - syntmp-tmp-615) - ((lambda (syntmp-tmp-624) - (if syntmp-tmp-624 - (apply (lambda (syntmp-ids-625 - syntmp-e1-626 - syntmp-e2-627) - (let ((syntmp-old-ids-628 - (syntmp-lambda-var-list-168 - syntmp-ids-625))) - (if (not (syntmp-valid-bound-ids?-144 - syntmp-old-ids-628)) - (syntax-error - syntmp-e-608 - "invalid parameter list in") - (let ((syntmp-labels-629 - (syntmp-gen-labels-125 - syntmp-old-ids-628)) - (syntmp-new-vars-630 - (map syntmp-gen-var-167 - syntmp-old-ids-628))) - (syntmp-k-613 - (let syntmp-f-631 ((syntmp-ls1-632 - (cdr syntmp-new-vars-630)) - (syntmp-ls2-633 - (car syntmp-new-vars-630))) - (if (null? syntmp-ls1-632) - syntmp-ls2-633 - (syntmp-f-631 - (cdr syntmp-ls1-632) - (cons (car syntmp-ls1-632) - syntmp-ls2-633)))) - (syntmp-chi-body-159 - (cons syntmp-e1-626 syntmp-e2-627) - syntmp-e-608 - (syntmp-extend-var-env-114 - syntmp-labels-629 - syntmp-new-vars-630 - syntmp-r-610) - (syntmp-make-binding-wrap-136 - syntmp-old-ids-628 - syntmp-labels-629 - syntmp-w-611) - syntmp-mod-612)))))) - syntmp-tmp-624) - ((lambda (syntmp-_-635) - (syntax-error syntmp-e-608)) - syntmp-tmp-614))) - (syntax-dispatch - syntmp-tmp-614 - '(any any . each-any))))) - (syntax-dispatch - syntmp-tmp-614 - '(each-any any . each-any)))) - syntmp-c-609))) - (syntmp-chi-body-159 - (lambda (syntmp-body-636 - syntmp-outer-form-637 - syntmp-r-638 - syntmp-w-639 - syntmp-mod-640) - (let ((syntmp-r-641 - (cons '("placeholder" placeholder) - syntmp-r-638))) - (let ((syntmp-ribcage-642 - (syntmp-make-ribcage-126 - '() - '() - '()))) - (let ((syntmp-w-643 - (syntmp-make-wrap-121 - (syntmp-wrap-marks-122 syntmp-w-639) - (cons syntmp-ribcage-642 - (syntmp-wrap-subst-123 syntmp-w-639))))) - (let syntmp-parse-644 ((syntmp-body-645 - (map (lambda (syntmp-x-651) - (cons syntmp-r-641 - (syntmp-wrap-147 - syntmp-x-651 - syntmp-w-643 - syntmp-mod-640))) - syntmp-body-636)) - (syntmp-ids-646 (quote ())) - (syntmp-labels-647 (quote ())) - (syntmp-vars-648 (quote ())) - (syntmp-vals-649 (quote ())) - (syntmp-bindings-650 (quote ()))) - (if (null? syntmp-body-645) - (syntax-error - syntmp-outer-form-637 - "no expressions in body") - (let ((syntmp-e-652 (cdar syntmp-body-645)) - (syntmp-er-653 (caar syntmp-body-645))) - (call-with-values - (lambda () - (syntmp-syntax-type-153 - syntmp-e-652 - syntmp-er-653 - '(()) - #f - syntmp-ribcage-642 - syntmp-mod-640)) - (lambda (syntmp-type-654 - syntmp-value-655 - syntmp-e-656 - syntmp-w-657 - syntmp-s-658 - syntmp-mod-659) - (let ((syntmp-t-660 syntmp-type-654)) - (if (memv syntmp-t-660 (quote (define-form))) - (let ((syntmp-id-661 - (syntmp-wrap-147 - syntmp-value-655 - syntmp-w-657 - syntmp-mod-659)) - (syntmp-label-662 - (syntmp-gen-label-124))) - (let ((syntmp-var-663 - (syntmp-gen-var-167 syntmp-id-661))) - (begin - (syntmp-extend-ribcage!-135 - syntmp-ribcage-642 - syntmp-id-661 - syntmp-label-662) - (syntmp-parse-644 - (cdr syntmp-body-645) - (cons syntmp-id-661 syntmp-ids-646) - (cons syntmp-label-662 - syntmp-labels-647) - (cons syntmp-var-663 syntmp-vars-648) - (cons (cons syntmp-er-653 - (syntmp-wrap-147 - syntmp-e-656 - syntmp-w-657 - syntmp-mod-659)) - syntmp-vals-649) - (cons (cons 'lexical - syntmp-var-663) - syntmp-bindings-650))))) - (if (memv syntmp-t-660 - '(define-syntax-form)) - (let ((syntmp-id-664 - (syntmp-wrap-147 - syntmp-value-655 - syntmp-w-657 - syntmp-mod-659)) - (syntmp-label-665 - (syntmp-gen-label-124))) - (begin - (syntmp-extend-ribcage!-135 - syntmp-ribcage-642 - syntmp-id-664 - syntmp-label-665) - (syntmp-parse-644 - (cdr syntmp-body-645) - (cons syntmp-id-664 syntmp-ids-646) - (cons syntmp-label-665 - syntmp-labels-647) - syntmp-vars-648 - syntmp-vals-649 - (cons (cons 'macro - (cons syntmp-er-653 - (syntmp-wrap-147 - syntmp-e-656 - syntmp-w-657 - syntmp-mod-659))) - syntmp-bindings-650)))) - (if (memv syntmp-t-660 (quote (begin-form))) - ((lambda (syntmp-tmp-666) - ((lambda (syntmp-tmp-667) - (if syntmp-tmp-667 - (apply (lambda (syntmp-_-668 - syntmp-e1-669) - (syntmp-parse-644 - (let syntmp-f-670 ((syntmp-forms-671 - syntmp-e1-669)) - (if (null? syntmp-forms-671) - (cdr syntmp-body-645) - (cons (cons syntmp-er-653 - (syntmp-wrap-147 - (car syntmp-forms-671) - syntmp-w-657 - syntmp-mod-659)) - (syntmp-f-670 - (cdr syntmp-forms-671))))) - syntmp-ids-646 - syntmp-labels-647 - syntmp-vars-648 - syntmp-vals-649 - syntmp-bindings-650)) - syntmp-tmp-667) - (syntax-error syntmp-tmp-666))) - (syntax-dispatch - syntmp-tmp-666 - '(any . each-any)))) - syntmp-e-656) - (if (memv syntmp-t-660 - '(local-syntax-form)) - (syntmp-chi-local-syntax-161 - syntmp-value-655 - syntmp-e-656 - syntmp-er-653 - syntmp-w-657 - syntmp-s-658 - syntmp-mod-659 - (lambda (syntmp-forms-673 - syntmp-er-674 - syntmp-w-675 - syntmp-s-676 - syntmp-mod-677) - (syntmp-parse-644 - (let syntmp-f-678 ((syntmp-forms-679 - syntmp-forms-673)) - (if (null? syntmp-forms-679) - (cdr syntmp-body-645) - (cons (cons syntmp-er-674 - (syntmp-wrap-147 - (car syntmp-forms-679) - syntmp-w-675 - syntmp-mod-677)) - (syntmp-f-678 - (cdr syntmp-forms-679))))) - syntmp-ids-646 - syntmp-labels-647 - syntmp-vars-648 - syntmp-vals-649 - syntmp-bindings-650))) - (if (null? syntmp-ids-646) - (syntmp-build-sequence-98 - #f - (map (lambda (syntmp-x-680) - (syntmp-chi-155 - (cdr syntmp-x-680) - (car syntmp-x-680) - '(()) - syntmp-mod-659)) - (cons (cons syntmp-er-653 - (syntmp-source-wrap-148 - syntmp-e-656 - syntmp-w-657 - syntmp-s-658 - syntmp-mod-659)) - (cdr syntmp-body-645)))) - (begin - (if (not (syntmp-valid-bound-ids?-144 - syntmp-ids-646)) - (syntax-error - syntmp-outer-form-637 - "invalid or duplicate identifier in definition")) - (let syntmp-loop-681 ((syntmp-bs-682 - syntmp-bindings-650) - (syntmp-er-cache-683 - #f) - (syntmp-r-cache-684 - #f)) - (if (not (null? syntmp-bs-682)) - (let ((syntmp-b-685 - (car syntmp-bs-682))) - (if (eq? (car syntmp-b-685) - 'macro) - (let ((syntmp-er-686 - (cadr syntmp-b-685))) - (let ((syntmp-r-cache-687 - (if (eq? syntmp-er-686 - syntmp-er-cache-683) - syntmp-r-cache-684 - (syntmp-macros-only-env-115 - syntmp-er-686)))) - (begin - (set-cdr! - syntmp-b-685 - (syntmp-eval-local-transformer-162 - (syntmp-chi-155 - (cddr syntmp-b-685) - syntmp-r-cache-687 - '(()) - syntmp-mod-659) - syntmp-mod-659)) - (syntmp-loop-681 - (cdr syntmp-bs-682) - syntmp-er-686 - syntmp-r-cache-687)))) - (syntmp-loop-681 - (cdr syntmp-bs-682) - syntmp-er-cache-683 - syntmp-r-cache-684))))) - (set-cdr! - syntmp-r-641 - (syntmp-extend-env-113 - syntmp-labels-647 - syntmp-bindings-650 - (cdr syntmp-r-641))) - (syntmp-build-letrec-101 - #f - syntmp-vars-648 - (map (lambda (syntmp-x-688) - (syntmp-chi-155 - (cdr syntmp-x-688) - (car syntmp-x-688) - '(()) - syntmp-mod-659)) - syntmp-vals-649) - (syntmp-build-sequence-98 - #f - (map (lambda (syntmp-x-689) - (syntmp-chi-155 - (cdr syntmp-x-689) - (car syntmp-x-689) - '(()) - syntmp-mod-659)) - (cons (cons syntmp-er-653 - (syntmp-source-wrap-148 - syntmp-e-656 - syntmp-w-657 - syntmp-s-658 - syntmp-mod-659)) - (cdr syntmp-body-645)))))))))))))))))))))) - (syntmp-chi-macro-158 - (lambda (syntmp-p-690 - syntmp-e-691 - syntmp-r-692 - syntmp-w-693 - syntmp-rib-694 - syntmp-mod-695) - (letrec ((syntmp-rebuild-macro-output-696 - (lambda (syntmp-x-697 syntmp-m-698) - (cond ((pair? syntmp-x-697) - (cons (syntmp-rebuild-macro-output-696 - (car syntmp-x-697) - syntmp-m-698) - (syntmp-rebuild-macro-output-696 - (cdr syntmp-x-697) - syntmp-m-698))) - ((syntmp-syntax-object?-103 syntmp-x-697) - (let ((syntmp-w-699 - (syntmp-syntax-object-wrap-105 - syntmp-x-697))) - (let ((syntmp-ms-700 - (syntmp-wrap-marks-122 - syntmp-w-699)) - (syntmp-s-701 - (syntmp-wrap-subst-123 - syntmp-w-699))) - (if (and (pair? syntmp-ms-700) - (eq? (car syntmp-ms-700) #f)) - (syntmp-make-syntax-object-102 - (syntmp-syntax-object-expression-104 - syntmp-x-697) - (syntmp-make-wrap-121 - (cdr syntmp-ms-700) - (if syntmp-rib-694 - (cons syntmp-rib-694 - (cdr syntmp-s-701)) - (cdr syntmp-s-701))) - (syntmp-syntax-object-module-106 - syntmp-x-697)) - (syntmp-make-syntax-object-102 - (syntmp-syntax-object-expression-104 - syntmp-x-697) - (syntmp-make-wrap-121 - (cons syntmp-m-698 syntmp-ms-700) - (if syntmp-rib-694 - (cons syntmp-rib-694 - (cons 'shift - syntmp-s-701)) - (cons 'shift - syntmp-s-701))) - (module-name - (procedure-module - syntmp-p-690))))))) - ((vector? syntmp-x-697) - (let ((syntmp-n-702 - (vector-length syntmp-x-697))) - (let ((syntmp-v-703 - (make-vector syntmp-n-702))) - (let syntmp-doloop-704 ((syntmp-i-705 0)) - (if (syntmp-fx=-89 - syntmp-i-705 - syntmp-n-702) - syntmp-v-703 - (begin - (vector-set! - syntmp-v-703 - syntmp-i-705 - (syntmp-rebuild-macro-output-696 - (vector-ref - syntmp-x-697 - syntmp-i-705) - syntmp-m-698)) - (syntmp-doloop-704 - (syntmp-fx+-87 - syntmp-i-705 - 1)))))))) - ((symbol? syntmp-x-697) - (syntax-error - syntmp-x-697 - "encountered raw symbol in macro output")) - (else syntmp-x-697))))) - (syntmp-rebuild-macro-output-696 - (syntmp-p-690 - (syntmp-wrap-147 - syntmp-e-691 - (syntmp-anti-mark-134 syntmp-w-693) - syntmp-mod-695)) - (string #\m))))) - (syntmp-chi-application-157 - (lambda (syntmp-x-706 - syntmp-e-707 - syntmp-r-708 - syntmp-w-709 - syntmp-s-710 - syntmp-mod-711) - ((lambda (syntmp-tmp-712) - ((lambda (syntmp-tmp-713) - (if syntmp-tmp-713 - (apply (lambda (syntmp-e0-714 syntmp-e1-715) - (syntmp-build-annotated-96 - syntmp-s-710 - (cons syntmp-x-706 - (map (lambda (syntmp-e-716) - (syntmp-chi-155 - syntmp-e-716 - syntmp-r-708 - syntmp-w-709 - syntmp-mod-711)) - syntmp-e1-715)))) - syntmp-tmp-713) - (syntax-error syntmp-tmp-712))) - (syntax-dispatch - syntmp-tmp-712 - '(any . each-any)))) - syntmp-e-707))) - (syntmp-chi-expr-156 - (lambda (syntmp-type-718 - syntmp-value-719 - syntmp-e-720 - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - (let ((syntmp-t-725 syntmp-type-718)) - (if (memv syntmp-t-725 (quote (lexical))) - (syntmp-build-annotated-96 - syntmp-s-723 - syntmp-value-719) - (if (memv syntmp-t-725 (quote (core external-macro))) - (syntmp-value-719 - syntmp-e-720 - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - (if (memv syntmp-t-725 (quote (lexical-call))) - (syntmp-chi-application-157 - (syntmp-build-annotated-96 - (syntmp-source-annotation-110 (car syntmp-e-720)) - syntmp-value-719) - syntmp-e-720 - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - (if (memv syntmp-t-725 (quote (global-call))) - (syntmp-chi-application-157 - (syntmp-build-annotated-96 - (syntmp-source-annotation-110 (car syntmp-e-720)) - (make-module-ref - (if (syntmp-syntax-object?-103 (car syntmp-e-720)) - (syntmp-syntax-object-module-106 - (car syntmp-e-720)) - syntmp-mod-724) - syntmp-value-719 - #f)) - syntmp-e-720 - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - (if (memv syntmp-t-725 (quote (constant))) - (syntmp-build-data-97 - syntmp-s-723 - (syntmp-strip-166 - (syntmp-source-wrap-148 - syntmp-e-720 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - '(()))) - (if (memv syntmp-t-725 (quote (global))) - (syntmp-build-annotated-96 - syntmp-s-723 - (make-module-ref - syntmp-mod-724 - syntmp-value-719 - #f)) - (if (memv syntmp-t-725 (quote (call))) - (syntmp-chi-application-157 - (syntmp-chi-155 - (car syntmp-e-720) - syntmp-r-721 - syntmp-w-722 - syntmp-mod-724) - syntmp-e-720 - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - (if (memv syntmp-t-725 (quote (begin-form))) - ((lambda (syntmp-tmp-726) - ((lambda (syntmp-tmp-727) - (if syntmp-tmp-727 - (apply (lambda (syntmp-_-728 - syntmp-e1-729 - syntmp-e2-730) - (syntmp-chi-sequence-149 - (cons syntmp-e1-729 - syntmp-e2-730) - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724)) - syntmp-tmp-727) - (syntax-error syntmp-tmp-726))) - (syntax-dispatch - syntmp-tmp-726 - '(any any . each-any)))) - syntmp-e-720) - (if (memv syntmp-t-725 - '(local-syntax-form)) - (syntmp-chi-local-syntax-161 - syntmp-value-719 - syntmp-e-720 - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724 - syntmp-chi-sequence-149) - (if (memv syntmp-t-725 - '(eval-when-form)) - ((lambda (syntmp-tmp-732) - ((lambda (syntmp-tmp-733) - (if syntmp-tmp-733 - (apply (lambda (syntmp-_-734 - syntmp-x-735 - syntmp-e1-736 - syntmp-e2-737) - (let ((syntmp-when-list-738 - (syntmp-chi-when-list-152 - syntmp-e-720 - syntmp-x-735 - syntmp-w-722))) - (if (memq 'eval - syntmp-when-list-738) - (syntmp-chi-sequence-149 - (cons syntmp-e1-736 - syntmp-e2-737) - syntmp-r-721 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - (syntmp-chi-void-163)))) - syntmp-tmp-733) - (syntax-error syntmp-tmp-732))) - (syntax-dispatch - syntmp-tmp-732 - '(any each-any any . each-any)))) - syntmp-e-720) - (if (memv syntmp-t-725 - '(define-form define-syntax-form)) - (syntax-error - (syntmp-wrap-147 - syntmp-value-719 - syntmp-w-722 - syntmp-mod-724) - "invalid context for definition of") - (if (memv syntmp-t-725 (quote (syntax))) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-720 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - "reference to pattern variable outside syntax form") - (if (memv syntmp-t-725 - '(displaced-lexical)) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-720 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724) - "reference to identifier outside its scope") - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-720 - syntmp-w-722 - syntmp-s-723 - syntmp-mod-724)))))))))))))))))) - (syntmp-chi-155 - (lambda (syntmp-e-741 - syntmp-r-742 - syntmp-w-743 - syntmp-mod-744) - (call-with-values - (lambda () - (syntmp-syntax-type-153 - syntmp-e-741 - syntmp-r-742 - syntmp-w-743 - #f - #f - syntmp-mod-744)) - (lambda (syntmp-type-745 - syntmp-value-746 - syntmp-e-747 - syntmp-w-748 - syntmp-s-749 - syntmp-mod-750) - (syntmp-chi-expr-156 - syntmp-type-745 - syntmp-value-746 - syntmp-e-747 - syntmp-r-742 - syntmp-w-748 - syntmp-s-749 - syntmp-mod-750))))) - (syntmp-chi-top-154 - (lambda (syntmp-e-751 - syntmp-r-752 - syntmp-w-753 - syntmp-m-754 - syntmp-esew-755 - syntmp-mod-756) - (call-with-values - (lambda () - (syntmp-syntax-type-153 - syntmp-e-751 - syntmp-r-752 - syntmp-w-753 - #f - #f - syntmp-mod-756)) - (lambda (syntmp-type-771 - syntmp-value-772 - syntmp-e-773 - syntmp-w-774 - syntmp-s-775 - syntmp-mod-776) - (let ((syntmp-t-777 syntmp-type-771)) - (if (memv syntmp-t-777 (quote (begin-form))) - ((lambda (syntmp-tmp-778) - ((lambda (syntmp-tmp-779) - (if syntmp-tmp-779 - (apply (lambda (syntmp-_-780) - (syntmp-chi-void-163)) - syntmp-tmp-779) - ((lambda (syntmp-tmp-781) - (if syntmp-tmp-781 - (apply (lambda (syntmp-_-782 - syntmp-e1-783 - syntmp-e2-784) - (syntmp-chi-top-sequence-150 - (cons syntmp-e1-783 syntmp-e2-784) - syntmp-r-752 - syntmp-w-774 - syntmp-s-775 - syntmp-m-754 - syntmp-esew-755 - syntmp-mod-776)) - syntmp-tmp-781) - (syntax-error syntmp-tmp-778))) - (syntax-dispatch - syntmp-tmp-778 - '(any any . each-any))))) - (syntax-dispatch syntmp-tmp-778 (quote (any))))) - syntmp-e-773) - (if (memv syntmp-t-777 (quote (local-syntax-form))) - (syntmp-chi-local-syntax-161 - syntmp-value-772 - syntmp-e-773 - syntmp-r-752 - syntmp-w-774 - syntmp-s-775 - syntmp-mod-776 - (lambda (syntmp-body-786 - syntmp-r-787 - syntmp-w-788 - syntmp-s-789 - syntmp-mod-790) - (syntmp-chi-top-sequence-150 - syntmp-body-786 - syntmp-r-787 - syntmp-w-788 - syntmp-s-789 - syntmp-m-754 - syntmp-esew-755 - syntmp-mod-790))) - (if (memv syntmp-t-777 (quote (eval-when-form))) - ((lambda (syntmp-tmp-791) - ((lambda (syntmp-tmp-792) - (if syntmp-tmp-792 - (apply (lambda (syntmp-_-793 - syntmp-x-794 - syntmp-e1-795 - syntmp-e2-796) - (let ((syntmp-when-list-797 - (syntmp-chi-when-list-152 - syntmp-e-773 - syntmp-x-794 - syntmp-w-774)) - (syntmp-body-798 - (cons syntmp-e1-795 - syntmp-e2-796))) - (cond ((eq? syntmp-m-754 (quote e)) - (if (memq 'eval - syntmp-when-list-797) - (syntmp-chi-top-sequence-150 - syntmp-body-798 - syntmp-r-752 - syntmp-w-774 - syntmp-s-775 - 'e - '(eval) - syntmp-mod-776) - (syntmp-chi-void-163))) - ((memq 'load - syntmp-when-list-797) - (if (or (memq 'compile - syntmp-when-list-797) - (and (eq? syntmp-m-754 - 'c&e) - (memq 'eval - syntmp-when-list-797))) - (syntmp-chi-top-sequence-150 - syntmp-body-798 - syntmp-r-752 - syntmp-w-774 - syntmp-s-775 - 'c&e - '(compile load) - syntmp-mod-776) - (if (memq syntmp-m-754 - '(c c&e)) - (syntmp-chi-top-sequence-150 - syntmp-body-798 - syntmp-r-752 - syntmp-w-774 - syntmp-s-775 - 'c - '(load) - syntmp-mod-776) - (syntmp-chi-void-163)))) - ((or (memq 'compile - syntmp-when-list-797) - (and (eq? syntmp-m-754 - 'c&e) - (memq 'eval - syntmp-when-list-797))) - (syntmp-top-level-eval-hook-91 - (syntmp-chi-top-sequence-150 - syntmp-body-798 - syntmp-r-752 - syntmp-w-774 - syntmp-s-775 - 'e - '(eval) - syntmp-mod-776) - syntmp-mod-776) - (syntmp-chi-void-163)) - (else - (syntmp-chi-void-163))))) - syntmp-tmp-792) - (syntax-error syntmp-tmp-791))) - (syntax-dispatch - syntmp-tmp-791 - '(any each-any any . each-any)))) - syntmp-e-773) - (if (memv syntmp-t-777 (quote (define-syntax-form))) - (let ((syntmp-n-801 - (syntmp-id-var-name-141 - syntmp-value-772 - syntmp-w-774)) - (syntmp-r-802 - (syntmp-macros-only-env-115 syntmp-r-752))) - (let ((syntmp-t-803 syntmp-m-754)) - (if (memv syntmp-t-803 (quote (c))) - (if (memq (quote compile) syntmp-esew-755) - (let ((syntmp-e-804 - (syntmp-chi-install-global-151 - syntmp-n-801 - (syntmp-chi-155 - syntmp-e-773 - syntmp-r-802 - syntmp-w-774 - syntmp-mod-776)))) - (begin - (syntmp-top-level-eval-hook-91 - syntmp-e-804 - syntmp-mod-776) - (if (memq (quote load) syntmp-esew-755) - syntmp-e-804 - (syntmp-chi-void-163)))) - (if (memq (quote load) syntmp-esew-755) - (syntmp-chi-install-global-151 - syntmp-n-801 - (syntmp-chi-155 - syntmp-e-773 - syntmp-r-802 - syntmp-w-774 - syntmp-mod-776)) - (syntmp-chi-void-163))) - (if (memv syntmp-t-803 (quote (c&e))) - (let ((syntmp-e-805 - (syntmp-chi-install-global-151 - syntmp-n-801 - (syntmp-chi-155 - syntmp-e-773 - syntmp-r-802 - syntmp-w-774 - syntmp-mod-776)))) - (begin - (syntmp-top-level-eval-hook-91 - syntmp-e-805 - syntmp-mod-776) - syntmp-e-805)) - (begin - (if (memq (quote eval) syntmp-esew-755) - (syntmp-top-level-eval-hook-91 - (syntmp-chi-install-global-151 - syntmp-n-801 - (syntmp-chi-155 - syntmp-e-773 - syntmp-r-802 - syntmp-w-774 - syntmp-mod-776)) - syntmp-mod-776)) - (syntmp-chi-void-163)))))) - (if (memv syntmp-t-777 (quote (define-form))) - (let ((syntmp-n-806 - (syntmp-id-var-name-141 - syntmp-value-772 - syntmp-w-774))) - (let ((syntmp-type-807 - (syntmp-binding-type-111 - (syntmp-lookup-116 - syntmp-n-806 - syntmp-r-752 - syntmp-mod-776)))) - (let ((syntmp-t-808 syntmp-type-807)) - (if (memv syntmp-t-808 (quote (global))) - (let ((syntmp-x-809 - (syntmp-build-annotated-96 - syntmp-s-775 - (list 'define - syntmp-n-806 - (syntmp-chi-155 - syntmp-e-773 - syntmp-r-752 - syntmp-w-774 - syntmp-mod-776))))) - (begin - (if (eq? syntmp-m-754 (quote c&e)) - (syntmp-top-level-eval-hook-91 - syntmp-x-809 - syntmp-mod-776)) - syntmp-x-809)) - (if (memv syntmp-t-808 - '(displaced-lexical)) - (syntax-error - (syntmp-wrap-147 - syntmp-value-772 - syntmp-w-774 - syntmp-mod-776) - "identifier out of context") - (if (eq? syntmp-type-807 - 'external-macro) - (let ((syntmp-x-810 - (syntmp-build-annotated-96 - syntmp-s-775 - (list 'define - syntmp-n-806 - (syntmp-chi-155 - syntmp-e-773 - syntmp-r-752 - syntmp-w-774 - syntmp-mod-776))))) - (begin - (if (eq? syntmp-m-754 (quote c&e)) - (syntmp-top-level-eval-hook-91 - syntmp-x-810 - syntmp-mod-776)) - syntmp-x-810)) - (syntax-error - (syntmp-wrap-147 - syntmp-value-772 - syntmp-w-774 - syntmp-mod-776) - "cannot define keyword at top level"))))))) - (let ((syntmp-x-811 - (syntmp-chi-expr-156 - syntmp-type-771 - syntmp-value-772 - syntmp-e-773 - syntmp-r-752 - syntmp-w-774 - syntmp-s-775 - syntmp-mod-776))) - (begin - (if (eq? syntmp-m-754 (quote c&e)) - (syntmp-top-level-eval-hook-91 - syntmp-x-811 - syntmp-mod-776)) - syntmp-x-811)))))))))))) - (syntmp-syntax-type-153 - (lambda (syntmp-e-812 - syntmp-r-813 - syntmp-w-814 - syntmp-s-815 - syntmp-rib-816 - syntmp-mod-817) - (cond ((symbol? syntmp-e-812) - (let ((syntmp-n-818 - (syntmp-id-var-name-141 - syntmp-e-812 - syntmp-w-814))) - (let ((syntmp-b-819 - (syntmp-lookup-116 - syntmp-n-818 - syntmp-r-813 - syntmp-mod-817))) - (let ((syntmp-type-820 - (syntmp-binding-type-111 syntmp-b-819))) - (let ((syntmp-t-821 syntmp-type-820)) - (if (memv syntmp-t-821 (quote (lexical))) - (values - syntmp-type-820 - (syntmp-binding-value-112 syntmp-b-819) - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-821 (quote (global))) - (values - syntmp-type-820 - syntmp-n-818 - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-821 (quote (macro))) - (syntmp-syntax-type-153 - (syntmp-chi-macro-158 - (syntmp-binding-value-112 syntmp-b-819) - syntmp-e-812 - syntmp-r-813 - syntmp-w-814 - syntmp-rib-816 - syntmp-mod-817) - syntmp-r-813 - '(()) - syntmp-s-815 - syntmp-rib-816 - syntmp-mod-817) - (values - syntmp-type-820 - (syntmp-binding-value-112 syntmp-b-819) - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817))))))))) - ((pair? syntmp-e-812) - (let ((syntmp-first-822 (car syntmp-e-812))) - (if (syntmp-id?-119 syntmp-first-822) - (let ((syntmp-n-823 - (syntmp-id-var-name-141 - syntmp-first-822 - syntmp-w-814))) - (let ((syntmp-b-824 - (syntmp-lookup-116 - syntmp-n-823 - syntmp-r-813 - syntmp-mod-817))) - (let ((syntmp-type-825 - (syntmp-binding-type-111 syntmp-b-824))) - (let ((syntmp-t-826 syntmp-type-825)) - (if (memv syntmp-t-826 (quote (lexical))) - (values - 'lexical-call - (syntmp-binding-value-112 syntmp-b-824) - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-826 (quote (global))) - (values - 'global-call - syntmp-n-823 - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-826 (quote (macro))) - (syntmp-syntax-type-153 - (syntmp-chi-macro-158 - (syntmp-binding-value-112 - syntmp-b-824) - syntmp-e-812 - syntmp-r-813 - syntmp-w-814 - syntmp-rib-816 - syntmp-mod-817) - syntmp-r-813 - '(()) - syntmp-s-815 - syntmp-rib-816 - syntmp-mod-817) - (if (memv syntmp-t-826 - '(core external-macro)) - (values - syntmp-type-825 - (syntmp-binding-value-112 - syntmp-b-824) - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-826 - '(local-syntax)) - (values - 'local-syntax-form - (syntmp-binding-value-112 - syntmp-b-824) - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-826 - '(begin)) - (values - 'begin-form - #f - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-826 - '(eval-when)) - (values - 'eval-when-form - #f - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817) - (if (memv syntmp-t-826 - '(define)) - ((lambda (syntmp-tmp-827) - ((lambda (syntmp-tmp-828) - (if (if syntmp-tmp-828 - (apply (lambda (syntmp-_-829 - syntmp-name-830 - syntmp-val-831) - (syntmp-id?-119 - syntmp-name-830)) - syntmp-tmp-828) - #f) - (apply (lambda (syntmp-_-832 - syntmp-name-833 - syntmp-val-834) - (values - 'define-form - syntmp-name-833 - syntmp-val-834 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817)) - syntmp-tmp-828) - ((lambda (syntmp-tmp-835) - (if (if syntmp-tmp-835 - (apply (lambda (syntmp-_-836 - syntmp-name-837 - syntmp-args-838 - syntmp-e1-839 - syntmp-e2-840) - (and (syntmp-id?-119 - syntmp-name-837) - (syntmp-valid-bound-ids?-144 - (syntmp-lambda-var-list-168 - syntmp-args-838)))) - syntmp-tmp-835) - #f) - (apply (lambda (syntmp-_-841 - syntmp-name-842 - syntmp-args-843 - syntmp-e1-844 - syntmp-e2-845) - (values - 'define-form - (syntmp-wrap-147 - syntmp-name-842 - syntmp-w-814 - syntmp-mod-817) - (cons '#(syntax-object - lambda - ((top) - #(ribcage - #(_ - name - args - e1 - e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(t) - #(("m" - top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(type) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(b) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(n) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(first) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(e - r - w - s - rib - mod) - #((top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure) - ((top)) - ("i"))) - (ice-9 syncase)) - (syntmp-wrap-147 - (cons syntmp-args-843 - (cons syntmp-e1-844 - syntmp-e2-845)) - syntmp-w-814 - syntmp-mod-817)) - '(()) - syntmp-s-815 - syntmp-mod-817)) - syntmp-tmp-835) - ((lambda (syntmp-tmp-847) - (if (if syntmp-tmp-847 - (apply (lambda (syntmp-_-848 - syntmp-name-849) - (syntmp-id?-119 - syntmp-name-849)) - syntmp-tmp-847) - #f) - (apply (lambda (syntmp-_-850 - syntmp-name-851) - (values - 'define-form - (syntmp-wrap-147 - syntmp-name-851 - syntmp-w-814 - syntmp-mod-817) - '(#(syntax-object - void - ((top) - #(ribcage - #(_ - name) - #((top) - (top)) - #("i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(t) - #(("m" - top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(type) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(b) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(n) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(first) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(e - r - w - s - rib - mod) - #((top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure) - ((top)) - ("i"))) - (ice-9 syncase))) - '(()) - syntmp-s-815 - syntmp-mod-817)) - syntmp-tmp-847) - (syntax-error - syntmp-tmp-827))) - (syntax-dispatch - syntmp-tmp-827 - '(any any))))) - (syntax-dispatch - syntmp-tmp-827 - '(any (any . any) - any - . - each-any))))) - (syntax-dispatch - syntmp-tmp-827 - '(any any any)))) - syntmp-e-812) - (if (memv syntmp-t-826 - '(define-syntax)) - ((lambda (syntmp-tmp-852) - ((lambda (syntmp-tmp-853) - (if (if syntmp-tmp-853 - (apply (lambda (syntmp-_-854 - syntmp-name-855 - syntmp-val-856) - (syntmp-id?-119 - syntmp-name-855)) - syntmp-tmp-853) - #f) - (apply (lambda (syntmp-_-857 - syntmp-name-858 - syntmp-val-859) - (values - 'define-syntax-form - syntmp-name-858 - syntmp-val-859 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817)) - syntmp-tmp-853) - (syntax-error - syntmp-tmp-852))) - (syntax-dispatch - syntmp-tmp-852 - '(any any any)))) - syntmp-e-812) - (values - 'call - #f - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817)))))))))))))) - (values - 'call - #f - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817)))) - ((syntmp-syntax-object?-103 syntmp-e-812) - (syntmp-syntax-type-153 - (syntmp-syntax-object-expression-104 - syntmp-e-812) - syntmp-r-813 - (syntmp-join-wraps-138 - syntmp-w-814 - (syntmp-syntax-object-wrap-105 syntmp-e-812)) - #f - syntmp-rib-816 - (or (syntmp-syntax-object-module-106 syntmp-e-812) - syntmp-mod-817))) - ((annotation? syntmp-e-812) - (syntmp-syntax-type-153 - (annotation-expression syntmp-e-812) - syntmp-r-813 - syntmp-w-814 - (annotation-source syntmp-e-812) - syntmp-rib-816 - syntmp-mod-817)) - ((self-evaluating? syntmp-e-812) - (values - 'constant - #f - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817)) - (else - (values - 'other - #f - syntmp-e-812 - syntmp-w-814 - syntmp-s-815 - syntmp-mod-817))))) - (syntmp-chi-when-list-152 - (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) - (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) - (syntmp-situations-865 (quote ()))) - (if (null? syntmp-when-list-864) - syntmp-situations-865 - (syntmp-f-863 - (cdr syntmp-when-list-864) - (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) - (cond ((syntmp-free-id=?-142 - syntmp-x-866 - '#(syntax-object - compile - ((top) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage - #(f when-list situations) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(e when-list w) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure) - ((top)) - ("i"))) - (ice-9 syncase))) - 'compile) - ((syntmp-free-id=?-142 - syntmp-x-866 - '#(syntax-object - load - ((top) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage - #(f when-list situations) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(e when-list w) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure) - ((top)) - ("i"))) - (ice-9 syncase))) - 'load) - ((syntmp-free-id=?-142 - syntmp-x-866 - '#(syntax-object - eval - ((top) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage - #(f when-list situations) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(e when-list w) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure) - ((top)) - ("i"))) - (ice-9 syncase))) - 'eval) - (else - (syntax-error - (syntmp-wrap-147 - syntmp-x-866 - syntmp-w-862 - #f) - "invalid eval-when situation")))) - syntmp-situations-865)))))) - (syntmp-chi-install-global-151 - (lambda (syntmp-name-877 syntmp-e-878) - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 - #f - 'install-global-transformer) - (syntmp-build-data-97 #f syntmp-name-877) - syntmp-e-878)))) - (syntmp-chi-top-sequence-150 - (lambda (syntmp-body-879 - syntmp-r-880 - syntmp-w-881 - syntmp-s-882 - syntmp-m-883 - syntmp-esew-884 - syntmp-mod-885) - (syntmp-build-sequence-98 - syntmp-s-882 - (let syntmp-dobody-886 ((syntmp-body-887 syntmp-body-879) - (syntmp-r-888 syntmp-r-880) - (syntmp-w-889 syntmp-w-881) - (syntmp-m-890 syntmp-m-883) - (syntmp-esew-891 syntmp-esew-884) - (syntmp-mod-892 syntmp-mod-885)) - (if (null? syntmp-body-887) - '() - (let ((syntmp-first-893 - (syntmp-chi-top-154 - (car syntmp-body-887) - syntmp-r-888 - syntmp-w-889 - syntmp-m-890 - syntmp-esew-891 - syntmp-mod-892))) - (cons syntmp-first-893 - (syntmp-dobody-886 - (cdr syntmp-body-887) - syntmp-r-888 - syntmp-w-889 - syntmp-m-890 - syntmp-esew-891 - syntmp-mod-892)))))))) - (syntmp-chi-sequence-149 - (lambda (syntmp-body-894 - syntmp-r-895 - syntmp-w-896 - syntmp-s-897 - syntmp-mod-898) - (syntmp-build-sequence-98 - syntmp-s-897 - (let syntmp-dobody-899 ((syntmp-body-900 syntmp-body-894) - (syntmp-r-901 syntmp-r-895) - (syntmp-w-902 syntmp-w-896) - (syntmp-mod-903 syntmp-mod-898)) - (if (null? syntmp-body-900) - '() - (let ((syntmp-first-904 - (syntmp-chi-155 - (car syntmp-body-900) - syntmp-r-901 - syntmp-w-902 - syntmp-mod-903))) - (cons syntmp-first-904 - (syntmp-dobody-899 - (cdr syntmp-body-900) - syntmp-r-901 - syntmp-w-902 - syntmp-mod-903)))))))) - (syntmp-source-wrap-148 - (lambda (syntmp-x-905 - syntmp-w-906 - syntmp-s-907 - syntmp-defmod-908) - (syntmp-wrap-147 - (if syntmp-s-907 - (make-annotation syntmp-x-905 syntmp-s-907 #f) - syntmp-x-905) - syntmp-w-906 - syntmp-defmod-908))) - (syntmp-wrap-147 - (lambda (syntmp-x-909 syntmp-w-910 syntmp-defmod-911) - (cond ((and (null? (syntmp-wrap-marks-122 syntmp-w-910)) - (null? (syntmp-wrap-subst-123 syntmp-w-910))) - syntmp-x-909) - ((syntmp-syntax-object?-103 syntmp-x-909) - (syntmp-make-syntax-object-102 - (syntmp-syntax-object-expression-104 - syntmp-x-909) - (syntmp-join-wraps-138 - syntmp-w-910 - (syntmp-syntax-object-wrap-105 syntmp-x-909)) - (syntmp-syntax-object-module-106 syntmp-x-909))) - ((null? syntmp-x-909) syntmp-x-909) - (else - (syntmp-make-syntax-object-102 - syntmp-x-909 - syntmp-w-910 - syntmp-defmod-911))))) - (syntmp-bound-id-member?-146 - (lambda (syntmp-x-912 syntmp-list-913) - (and (not (null? syntmp-list-913)) - (or (syntmp-bound-id=?-143 - syntmp-x-912 - (car syntmp-list-913)) - (syntmp-bound-id-member?-146 - syntmp-x-912 - (cdr syntmp-list-913)))))) - (syntmp-distinct-bound-ids?-145 - (lambda (syntmp-ids-914) - (let syntmp-distinct?-915 ((syntmp-ids-916 syntmp-ids-914)) - (or (null? syntmp-ids-916) - (and (not (syntmp-bound-id-member?-146 - (car syntmp-ids-916) - (cdr syntmp-ids-916))) - (syntmp-distinct?-915 (cdr syntmp-ids-916))))))) - (syntmp-valid-bound-ids?-144 - (lambda (syntmp-ids-917) - (and (let syntmp-all-ids?-918 ((syntmp-ids-919 syntmp-ids-917)) - (or (null? syntmp-ids-919) - (and (syntmp-id?-119 (car syntmp-ids-919)) - (syntmp-all-ids?-918 (cdr syntmp-ids-919))))) - (syntmp-distinct-bound-ids?-145 syntmp-ids-917)))) - (syntmp-bound-id=?-143 - (lambda (syntmp-i-920 syntmp-j-921) - (if (and (syntmp-syntax-object?-103 syntmp-i-920) - (syntmp-syntax-object?-103 syntmp-j-921)) - (and (eq? (let ((syntmp-e-922 - (syntmp-syntax-object-expression-104 - syntmp-i-920))) - (if (annotation? syntmp-e-922) - (annotation-expression syntmp-e-922) - syntmp-e-922)) - (let ((syntmp-e-923 - (syntmp-syntax-object-expression-104 - syntmp-j-921))) - (if (annotation? syntmp-e-923) - (annotation-expression syntmp-e-923) - syntmp-e-923))) - (syntmp-same-marks?-140 - (syntmp-wrap-marks-122 - (syntmp-syntax-object-wrap-105 syntmp-i-920)) - (syntmp-wrap-marks-122 - (syntmp-syntax-object-wrap-105 syntmp-j-921)))) - (eq? (let ((syntmp-e-924 syntmp-i-920)) - (if (annotation? syntmp-e-924) - (annotation-expression syntmp-e-924) - syntmp-e-924)) - (let ((syntmp-e-925 syntmp-j-921)) - (if (annotation? syntmp-e-925) - (annotation-expression syntmp-e-925) - syntmp-e-925)))))) - (syntmp-free-id=?-142 - (lambda (syntmp-i-926 syntmp-j-927) - (and (eq? (let ((syntmp-x-928 syntmp-i-926)) - (let ((syntmp-e-929 - (if (syntmp-syntax-object?-103 syntmp-x-928) - (syntmp-syntax-object-expression-104 - syntmp-x-928) - syntmp-x-928))) - (if (annotation? syntmp-e-929) - (annotation-expression syntmp-e-929) - syntmp-e-929))) - (let ((syntmp-x-930 syntmp-j-927)) - (let ((syntmp-e-931 - (if (syntmp-syntax-object?-103 syntmp-x-930) - (syntmp-syntax-object-expression-104 - syntmp-x-930) - syntmp-x-930))) - (if (annotation? syntmp-e-931) - (annotation-expression syntmp-e-931) - syntmp-e-931)))) - (eq? (syntmp-id-var-name-141 - syntmp-i-926 - '(())) - (syntmp-id-var-name-141 - syntmp-j-927 - '(())))))) - (syntmp-id-var-name-141 - (lambda (syntmp-id-932 syntmp-w-933) - (letrec ((syntmp-search-vector-rib-936 - (lambda (syntmp-sym-947 - syntmp-subst-948 - syntmp-marks-949 - syntmp-symnames-950 - syntmp-ribcage-951) - (let ((syntmp-n-952 - (vector-length syntmp-symnames-950))) - (let syntmp-f-953 ((syntmp-i-954 0)) - (cond ((syntmp-fx=-89 syntmp-i-954 syntmp-n-952) - (syntmp-search-934 - syntmp-sym-947 - (cdr syntmp-subst-948) - syntmp-marks-949)) - ((and (eq? (vector-ref - syntmp-symnames-950 - syntmp-i-954) - syntmp-sym-947) - (syntmp-same-marks?-140 - syntmp-marks-949 - (vector-ref - (syntmp-ribcage-marks-129 - syntmp-ribcage-951) - syntmp-i-954))) - (values - (vector-ref - (syntmp-ribcage-labels-130 - syntmp-ribcage-951) - syntmp-i-954) - syntmp-marks-949)) - (else - (syntmp-f-953 - (syntmp-fx+-87 syntmp-i-954 1)))))))) - (syntmp-search-list-rib-935 - (lambda (syntmp-sym-955 - syntmp-subst-956 - syntmp-marks-957 - syntmp-symnames-958 - syntmp-ribcage-959) - (let syntmp-f-960 ((syntmp-symnames-961 - syntmp-symnames-958) - (syntmp-i-962 0)) - (cond ((null? syntmp-symnames-961) - (syntmp-search-934 - syntmp-sym-955 - (cdr syntmp-subst-956) - syntmp-marks-957)) - ((and (eq? (car syntmp-symnames-961) - syntmp-sym-955) - (syntmp-same-marks?-140 - syntmp-marks-957 - (list-ref - (syntmp-ribcage-marks-129 - syntmp-ribcage-959) - syntmp-i-962))) - (values - (list-ref - (syntmp-ribcage-labels-130 - syntmp-ribcage-959) - syntmp-i-962) - syntmp-marks-957)) - (else - (syntmp-f-960 - (cdr syntmp-symnames-961) - (syntmp-fx+-87 syntmp-i-962 1))))))) - (syntmp-search-934 - (lambda (syntmp-sym-963 - syntmp-subst-964 - syntmp-marks-965) - (if (null? syntmp-subst-964) - (values #f syntmp-marks-965) - (let ((syntmp-fst-966 (car syntmp-subst-964))) - (if (eq? syntmp-fst-966 (quote shift)) - (syntmp-search-934 - syntmp-sym-963 - (cdr syntmp-subst-964) - (cdr syntmp-marks-965)) - (let ((syntmp-symnames-967 - (syntmp-ribcage-symnames-128 - syntmp-fst-966))) - (if (vector? syntmp-symnames-967) - (syntmp-search-vector-rib-936 - syntmp-sym-963 - syntmp-subst-964 - syntmp-marks-965 - syntmp-symnames-967 - syntmp-fst-966) - (syntmp-search-list-rib-935 - syntmp-sym-963 - syntmp-subst-964 - syntmp-marks-965 - syntmp-symnames-967 - syntmp-fst-966))))))))) - (cond ((symbol? syntmp-id-932) - (or (call-with-values - (lambda () - (syntmp-search-934 - syntmp-id-932 - (syntmp-wrap-subst-123 syntmp-w-933) - (syntmp-wrap-marks-122 syntmp-w-933))) - (lambda (syntmp-x-969 . syntmp-ignore-968) - syntmp-x-969)) - syntmp-id-932)) - ((syntmp-syntax-object?-103 syntmp-id-932) - (let ((syntmp-id-970 - (let ((syntmp-e-972 - (syntmp-syntax-object-expression-104 - syntmp-id-932))) - (if (annotation? syntmp-e-972) - (annotation-expression syntmp-e-972) - syntmp-e-972))) - (syntmp-w1-971 - (syntmp-syntax-object-wrap-105 syntmp-id-932))) - (let ((syntmp-marks-973 - (syntmp-join-marks-139 - (syntmp-wrap-marks-122 syntmp-w-933) - (syntmp-wrap-marks-122 syntmp-w1-971)))) - (call-with-values - (lambda () - (syntmp-search-934 - syntmp-id-970 - (syntmp-wrap-subst-123 syntmp-w-933) - syntmp-marks-973)) - (lambda (syntmp-new-id-974 syntmp-marks-975) - (or syntmp-new-id-974 - (call-with-values - (lambda () - (syntmp-search-934 - syntmp-id-970 - (syntmp-wrap-subst-123 syntmp-w1-971) - syntmp-marks-975)) - (lambda (syntmp-x-977 . syntmp-ignore-976) - syntmp-x-977)) - syntmp-id-970)))))) - ((annotation? syntmp-id-932) - (let ((syntmp-id-978 - (let ((syntmp-e-979 syntmp-id-932)) - (if (annotation? syntmp-e-979) - (annotation-expression syntmp-e-979) - syntmp-e-979)))) - (or (call-with-values - (lambda () - (syntmp-search-934 - syntmp-id-978 - (syntmp-wrap-subst-123 syntmp-w-933) - (syntmp-wrap-marks-122 syntmp-w-933))) - (lambda (syntmp-x-981 . syntmp-ignore-980) - syntmp-x-981)) - syntmp-id-978))) - (else - (syntmp-error-hook-93 - 'id-var-name - "invalid id" - syntmp-id-932)))))) - (syntmp-same-marks?-140 - (lambda (syntmp-x-982 syntmp-y-983) - (or (eq? syntmp-x-982 syntmp-y-983) - (and (not (null? syntmp-x-982)) - (not (null? syntmp-y-983)) - (eq? (car syntmp-x-982) (car syntmp-y-983)) - (syntmp-same-marks?-140 - (cdr syntmp-x-982) - (cdr syntmp-y-983)))))) - (syntmp-join-marks-139 - (lambda (syntmp-m1-984 syntmp-m2-985) - (syntmp-smart-append-137 - syntmp-m1-984 - syntmp-m2-985))) - (syntmp-join-wraps-138 - (lambda (syntmp-w1-986 syntmp-w2-987) - (let ((syntmp-m1-988 - (syntmp-wrap-marks-122 syntmp-w1-986)) - (syntmp-s1-989 - (syntmp-wrap-subst-123 syntmp-w1-986))) - (if (null? syntmp-m1-988) - (if (null? syntmp-s1-989) - syntmp-w2-987 - (syntmp-make-wrap-121 - (syntmp-wrap-marks-122 syntmp-w2-987) - (syntmp-smart-append-137 - syntmp-s1-989 - (syntmp-wrap-subst-123 syntmp-w2-987)))) - (syntmp-make-wrap-121 - (syntmp-smart-append-137 - syntmp-m1-988 - (syntmp-wrap-marks-122 syntmp-w2-987)) - (syntmp-smart-append-137 - syntmp-s1-989 - (syntmp-wrap-subst-123 syntmp-w2-987))))))) - (syntmp-smart-append-137 - (lambda (syntmp-m1-990 syntmp-m2-991) - (if (null? syntmp-m2-991) - syntmp-m1-990 - (append syntmp-m1-990 syntmp-m2-991)))) - (syntmp-make-binding-wrap-136 - (lambda (syntmp-ids-992 syntmp-labels-993 syntmp-w-994) - (if (null? syntmp-ids-992) - syntmp-w-994 - (syntmp-make-wrap-121 - (syntmp-wrap-marks-122 syntmp-w-994) - (cons (let ((syntmp-labelvec-995 - (list->vector syntmp-labels-993))) - (let ((syntmp-n-996 - (vector-length syntmp-labelvec-995))) - (let ((syntmp-symnamevec-997 - (make-vector syntmp-n-996)) - (syntmp-marksvec-998 - (make-vector syntmp-n-996))) - (begin - (let syntmp-f-999 ((syntmp-ids-1000 - syntmp-ids-992) - (syntmp-i-1001 0)) - (if (not (null? syntmp-ids-1000)) - (call-with-values - (lambda () - (syntmp-id-sym-name&marks-120 - (car syntmp-ids-1000) - syntmp-w-994)) - (lambda (syntmp-symname-1002 - syntmp-marks-1003) - (begin - (vector-set! - syntmp-symnamevec-997 - syntmp-i-1001 - syntmp-symname-1002) - (vector-set! - syntmp-marksvec-998 - syntmp-i-1001 - syntmp-marks-1003) - (syntmp-f-999 - (cdr syntmp-ids-1000) - (syntmp-fx+-87 - syntmp-i-1001 - 1))))))) - (syntmp-make-ribcage-126 - syntmp-symnamevec-997 - syntmp-marksvec-998 - syntmp-labelvec-995))))) - (syntmp-wrap-subst-123 syntmp-w-994)))))) - (syntmp-extend-ribcage!-135 - (lambda (syntmp-ribcage-1004 - syntmp-id-1005 - syntmp-label-1006) - (begin - (syntmp-set-ribcage-symnames!-131 - syntmp-ribcage-1004 - (cons (let ((syntmp-e-1007 - (syntmp-syntax-object-expression-104 - syntmp-id-1005))) - (if (annotation? syntmp-e-1007) - (annotation-expression syntmp-e-1007) - syntmp-e-1007)) - (syntmp-ribcage-symnames-128 syntmp-ribcage-1004))) - (syntmp-set-ribcage-marks!-132 - syntmp-ribcage-1004 - (cons (syntmp-wrap-marks-122 - (syntmp-syntax-object-wrap-105 syntmp-id-1005)) - (syntmp-ribcage-marks-129 syntmp-ribcage-1004))) - (syntmp-set-ribcage-labels!-133 - syntmp-ribcage-1004 - (cons syntmp-label-1006 - (syntmp-ribcage-labels-130 syntmp-ribcage-1004)))))) - (syntmp-anti-mark-134 - (lambda (syntmp-w-1008) - (syntmp-make-wrap-121 - (cons #f (syntmp-wrap-marks-122 syntmp-w-1008)) - (cons 'shift - (syntmp-wrap-subst-123 syntmp-w-1008))))) - (syntmp-set-ribcage-labels!-133 - (lambda (syntmp-x-1009 syntmp-update-1010) - (vector-set! syntmp-x-1009 3 syntmp-update-1010))) - (syntmp-set-ribcage-marks!-132 - (lambda (syntmp-x-1011 syntmp-update-1012) - (vector-set! syntmp-x-1011 2 syntmp-update-1012))) - (syntmp-set-ribcage-symnames!-131 - (lambda (syntmp-x-1013 syntmp-update-1014) - (vector-set! syntmp-x-1013 1 syntmp-update-1014))) - (syntmp-ribcage-labels-130 - (lambda (syntmp-x-1015) - (vector-ref syntmp-x-1015 3))) - (syntmp-ribcage-marks-129 - (lambda (syntmp-x-1016) - (vector-ref syntmp-x-1016 2))) - (syntmp-ribcage-symnames-128 - (lambda (syntmp-x-1017) - (vector-ref syntmp-x-1017 1))) - (syntmp-ribcage?-127 - (lambda (syntmp-x-1018) - (and (vector? syntmp-x-1018) - (= (vector-length syntmp-x-1018) 4) - (eq? (vector-ref syntmp-x-1018 0) - 'ribcage)))) - (syntmp-make-ribcage-126 - (lambda (syntmp-symnames-1019 - syntmp-marks-1020 - syntmp-labels-1021) - (vector - 'ribcage - syntmp-symnames-1019 - syntmp-marks-1020 - syntmp-labels-1021))) - (syntmp-gen-labels-125 - (lambda (syntmp-ls-1022) - (if (null? syntmp-ls-1022) - '() - (cons (syntmp-gen-label-124) - (syntmp-gen-labels-125 (cdr syntmp-ls-1022)))))) - (syntmp-gen-label-124 (lambda () (string #\i))) - (syntmp-wrap-subst-123 cdr) - (syntmp-wrap-marks-122 car) - (syntmp-make-wrap-121 cons) - (syntmp-id-sym-name&marks-120 - (lambda (syntmp-x-1023 syntmp-w-1024) - (if (syntmp-syntax-object?-103 syntmp-x-1023) - (values - (let ((syntmp-e-1025 - (syntmp-syntax-object-expression-104 - syntmp-x-1023))) - (if (annotation? syntmp-e-1025) - (annotation-expression syntmp-e-1025) - syntmp-e-1025)) - (syntmp-join-marks-139 - (syntmp-wrap-marks-122 syntmp-w-1024) - (syntmp-wrap-marks-122 - (syntmp-syntax-object-wrap-105 syntmp-x-1023)))) - (values - (let ((syntmp-e-1026 syntmp-x-1023)) - (if (annotation? syntmp-e-1026) - (annotation-expression syntmp-e-1026) - syntmp-e-1026)) - (syntmp-wrap-marks-122 syntmp-w-1024))))) - (syntmp-id?-119 - (lambda (syntmp-x-1027) - (cond ((symbol? syntmp-x-1027) #t) - ((syntmp-syntax-object?-103 syntmp-x-1027) - (symbol? - (let ((syntmp-e-1028 - (syntmp-syntax-object-expression-104 - syntmp-x-1027))) - (if (annotation? syntmp-e-1028) - (annotation-expression syntmp-e-1028) - syntmp-e-1028)))) - ((annotation? syntmp-x-1027) - (symbol? (annotation-expression syntmp-x-1027))) - (else #f)))) - (syntmp-nonsymbol-id?-118 - (lambda (syntmp-x-1029) - (and (syntmp-syntax-object?-103 syntmp-x-1029) - (symbol? - (let ((syntmp-e-1030 - (syntmp-syntax-object-expression-104 - syntmp-x-1029))) - (if (annotation? syntmp-e-1030) - (annotation-expression syntmp-e-1030) - syntmp-e-1030)))))) - (syntmp-global-extend-117 - (lambda (syntmp-type-1031 - syntmp-sym-1032 - syntmp-val-1033) - (syntmp-put-global-definition-hook-94 - syntmp-sym-1032 - (cons syntmp-type-1031 syntmp-val-1033) - (module-name (current-module))))) - (syntmp-lookup-116 - (lambda (syntmp-x-1034 syntmp-r-1035 syntmp-mod-1036) - (cond ((assq syntmp-x-1034 syntmp-r-1035) => cdr) - ((symbol? syntmp-x-1034) - (or (syntmp-get-global-definition-hook-95 - syntmp-x-1034 - syntmp-mod-1036) - '(global))) - (else (quote (displaced-lexical)))))) - (syntmp-macros-only-env-115 - (lambda (syntmp-r-1037) - (if (null? syntmp-r-1037) - '() - (let ((syntmp-a-1038 (car syntmp-r-1037))) - (if (eq? (cadr syntmp-a-1038) (quote macro)) - (cons syntmp-a-1038 - (syntmp-macros-only-env-115 (cdr syntmp-r-1037))) - (syntmp-macros-only-env-115 (cdr syntmp-r-1037))))))) - (syntmp-extend-var-env-114 - (lambda (syntmp-labels-1039 - syntmp-vars-1040 - syntmp-r-1041) - (if (null? syntmp-labels-1039) - syntmp-r-1041 - (syntmp-extend-var-env-114 - (cdr syntmp-labels-1039) - (cdr syntmp-vars-1040) - (cons (cons (car syntmp-labels-1039) - (cons (quote lexical) (car syntmp-vars-1040))) - syntmp-r-1041))))) - (syntmp-extend-env-113 - (lambda (syntmp-labels-1042 - syntmp-bindings-1043 - syntmp-r-1044) - (if (null? syntmp-labels-1042) - syntmp-r-1044 - (syntmp-extend-env-113 - (cdr syntmp-labels-1042) - (cdr syntmp-bindings-1043) - (cons (cons (car syntmp-labels-1042) - (car syntmp-bindings-1043)) - syntmp-r-1044))))) - (syntmp-binding-value-112 cdr) - (syntmp-binding-type-111 car) - (syntmp-source-annotation-110 - (lambda (syntmp-x-1045) - (cond ((annotation? syntmp-x-1045) - (annotation-source syntmp-x-1045)) - ((syntmp-syntax-object?-103 syntmp-x-1045) - (syntmp-source-annotation-110 - (syntmp-syntax-object-expression-104 - syntmp-x-1045))) - (else #f)))) - (syntmp-set-syntax-object-module!-109 - (lambda (syntmp-x-1046 syntmp-update-1047) - (vector-set! syntmp-x-1046 3 syntmp-update-1047))) - (syntmp-set-syntax-object-wrap!-108 - (lambda (syntmp-x-1048 syntmp-update-1049) - (vector-set! syntmp-x-1048 2 syntmp-update-1049))) - (syntmp-set-syntax-object-expression!-107 - (lambda (syntmp-x-1050 syntmp-update-1051) - (vector-set! syntmp-x-1050 1 syntmp-update-1051))) - (syntmp-syntax-object-module-106 - (lambda (syntmp-x-1052) - (vector-ref syntmp-x-1052 3))) - (syntmp-syntax-object-wrap-105 - (lambda (syntmp-x-1053) - (vector-ref syntmp-x-1053 2))) - (syntmp-syntax-object-expression-104 - (lambda (syntmp-x-1054) - (vector-ref syntmp-x-1054 1))) - (syntmp-syntax-object?-103 - (lambda (syntmp-x-1055) - (and (vector? syntmp-x-1055) - (= (vector-length syntmp-x-1055) 4) - (eq? (vector-ref syntmp-x-1055 0) - 'syntax-object)))) - (syntmp-make-syntax-object-102 - (lambda (syntmp-expression-1056 - syntmp-wrap-1057 - syntmp-module-1058) - (vector - 'syntax-object - syntmp-expression-1056 - syntmp-wrap-1057 - syntmp-module-1058))) - (syntmp-build-letrec-101 - (lambda (syntmp-src-1059 - syntmp-vars-1060 - syntmp-val-exps-1061 - syntmp-body-exp-1062) - (if (null? syntmp-vars-1060) - (syntmp-build-annotated-96 - syntmp-src-1059 - syntmp-body-exp-1062) - (syntmp-build-annotated-96 - syntmp-src-1059 - (list 'letrec - (map list syntmp-vars-1060 syntmp-val-exps-1061) - syntmp-body-exp-1062))))) - (syntmp-build-named-let-100 - (lambda (syntmp-src-1063 - syntmp-vars-1064 - syntmp-val-exps-1065 - syntmp-body-exp-1066) - (if (null? syntmp-vars-1064) - (syntmp-build-annotated-96 - syntmp-src-1063 - syntmp-body-exp-1066) - (syntmp-build-annotated-96 - syntmp-src-1063 - (list 'let - (car syntmp-vars-1064) - (map list - (cdr syntmp-vars-1064) - syntmp-val-exps-1065) - syntmp-body-exp-1066))))) - (syntmp-build-let-99 - (lambda (syntmp-src-1067 - syntmp-vars-1068 - syntmp-val-exps-1069 - syntmp-body-exp-1070) - (if (null? syntmp-vars-1068) - (syntmp-build-annotated-96 - syntmp-src-1067 - syntmp-body-exp-1070) - (syntmp-build-annotated-96 - syntmp-src-1067 - (list 'let - (map list syntmp-vars-1068 syntmp-val-exps-1069) - syntmp-body-exp-1070))))) - (syntmp-build-sequence-98 - (lambda (syntmp-src-1071 syntmp-exps-1072) - (if (null? (cdr syntmp-exps-1072)) - (syntmp-build-annotated-96 - syntmp-src-1071 - (car syntmp-exps-1072)) - (syntmp-build-annotated-96 - syntmp-src-1071 - (cons (quote begin) syntmp-exps-1072))))) - (syntmp-build-data-97 - (lambda (syntmp-src-1073 syntmp-exp-1074) - (if (and (self-evaluating? syntmp-exp-1074) - (not (vector? syntmp-exp-1074))) - (syntmp-build-annotated-96 - syntmp-src-1073 - syntmp-exp-1074) - (syntmp-build-annotated-96 - syntmp-src-1073 - (list (quote quote) syntmp-exp-1074))))) - (syntmp-build-annotated-96 - (lambda (syntmp-src-1075 syntmp-exp-1076) - (if (and syntmp-src-1075 - (not (annotation? syntmp-exp-1076))) - (make-annotation - syntmp-exp-1076 - syntmp-src-1075 - #t) - syntmp-exp-1076))) - (syntmp-get-global-definition-hook-95 - (lambda (syntmp-symbol-1077 syntmp-module-1078) - (let ((syntmp-module-1079 - (if syntmp-module-1078 - (resolve-module syntmp-module-1078) - (warn "wha" syntmp-symbol-1077 (current-module))))) - (let ((syntmp-v-1080 - (module-variable - syntmp-module-1079 - syntmp-symbol-1077))) - (and syntmp-v-1080 - (or (object-property - syntmp-v-1080 - '*sc-expander*) - (and (variable-bound? syntmp-v-1080) - (macro? (variable-ref syntmp-v-1080)) - (macro-transformer (variable-ref syntmp-v-1080)) - guile-macro))))))) - (syntmp-put-global-definition-hook-94 - (lambda (syntmp-symbol-1081 - syntmp-binding-1082 - syntmp-module-1083) - (let ((syntmp-module-1084 - (if syntmp-module-1083 - (resolve-module syntmp-module-1083) - (warn "wha" syntmp-symbol-1081 (current-module))))) - (let ((syntmp-v-1085 - (or (module-variable - syntmp-module-1084 - syntmp-symbol-1081) - (let ((syntmp-v-1086 (make-variable sc-macro))) - (begin - (module-add! - syntmp-module-1084 - syntmp-symbol-1081 - syntmp-v-1086) - syntmp-v-1086))))) - (begin - (if (not (and (symbol-property - syntmp-symbol-1081 - 'primitive-syntax) - (eq? syntmp-module-1084 the-syncase-module))) - (variable-set! syntmp-v-1085 sc-macro)) - (set-object-property! - syntmp-v-1085 - '*sc-expander* - syntmp-binding-1082)))))) - (syntmp-error-hook-93 - (lambda (syntmp-who-1087 - syntmp-why-1088 - syntmp-what-1089) - (error syntmp-who-1087 - "~a ~s" - syntmp-why-1088 - syntmp-what-1089))) - (syntmp-local-eval-hook-92 - (lambda (syntmp-x-1090 syntmp-mod-1091) - (eval (list syntmp-noexpand-86 syntmp-x-1090) - (if syntmp-mod-1091 - (resolve-module syntmp-mod-1091) - (interaction-environment))))) - (syntmp-top-level-eval-hook-91 - (lambda (syntmp-x-1092 syntmp-mod-1093) - (eval (list syntmp-noexpand-86 syntmp-x-1092) - (if syntmp-mod-1093 - (resolve-module syntmp-mod-1093) - (interaction-environment))))) - (syntmp-fx<-90 <) - (syntmp-fx=-89 =) - (syntmp-fx--88 -) - (syntmp-fx+-87 +) - (syntmp-noexpand-86 "noexpand")) - (begin - (syntmp-global-extend-117 - 'local-syntax - 'letrec-syntax - #t) - (syntmp-global-extend-117 - 'local-syntax - 'let-syntax - #f) - (syntmp-global-extend-117 - 'core - 'fluid-let-syntax - (lambda (syntmp-e-1094 - syntmp-r-1095 - syntmp-w-1096 - syntmp-s-1097 - syntmp-mod-1098) - ((lambda (syntmp-tmp-1099) - ((lambda (syntmp-tmp-1100) - (if (if syntmp-tmp-1100 - (apply (lambda (syntmp-_-1101 - syntmp-var-1102 - syntmp-val-1103 - syntmp-e1-1104 - syntmp-e2-1105) - (syntmp-valid-bound-ids?-144 syntmp-var-1102)) - syntmp-tmp-1100) - #f) - (apply (lambda (syntmp-_-1107 - syntmp-var-1108 - syntmp-val-1109 - syntmp-e1-1110 - syntmp-e2-1111) - (let ((syntmp-names-1112 - (map (lambda (syntmp-x-1113) - (syntmp-id-var-name-141 - syntmp-x-1113 - syntmp-w-1096)) - syntmp-var-1108))) - (begin - (for-each - (lambda (syntmp-id-1115 syntmp-n-1116) - (let ((syntmp-t-1117 - (syntmp-binding-type-111 - (syntmp-lookup-116 - syntmp-n-1116 - syntmp-r-1095 - syntmp-mod-1098)))) - (if (memv syntmp-t-1117 - '(displaced-lexical)) - (syntax-error - (syntmp-source-wrap-148 - syntmp-id-1115 - syntmp-w-1096 - syntmp-s-1097 - syntmp-mod-1098) - "identifier out of context")))) - syntmp-var-1108 - syntmp-names-1112) - (syntmp-chi-body-159 - (cons syntmp-e1-1110 syntmp-e2-1111) - (syntmp-source-wrap-148 - syntmp-e-1094 - syntmp-w-1096 - syntmp-s-1097 - syntmp-mod-1098) - (syntmp-extend-env-113 - syntmp-names-1112 - (let ((syntmp-trans-r-1120 - (syntmp-macros-only-env-115 - syntmp-r-1095))) - (map (lambda (syntmp-x-1121) - (cons 'macro - (syntmp-eval-local-transformer-162 - (syntmp-chi-155 - syntmp-x-1121 - syntmp-trans-r-1120 - syntmp-w-1096 - syntmp-mod-1098) - syntmp-mod-1098))) - syntmp-val-1109)) - syntmp-r-1095) - syntmp-w-1096 - syntmp-mod-1098)))) - syntmp-tmp-1100) - ((lambda (syntmp-_-1123) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-1094 - syntmp-w-1096 - syntmp-s-1097 - syntmp-mod-1098))) - syntmp-tmp-1099))) - (syntax-dispatch - syntmp-tmp-1099 - '(any #(each (any any)) any . each-any)))) - syntmp-e-1094))) - (syntmp-global-extend-117 - 'core - 'quote - (lambda (syntmp-e-1124 - syntmp-r-1125 - syntmp-w-1126 - syntmp-s-1127 - syntmp-mod-1128) - ((lambda (syntmp-tmp-1129) - ((lambda (syntmp-tmp-1130) - (if syntmp-tmp-1130 - (apply (lambda (syntmp-_-1131 syntmp-e-1132) - (syntmp-build-data-97 - syntmp-s-1127 - (syntmp-strip-166 syntmp-e-1132 syntmp-w-1126))) - syntmp-tmp-1130) - ((lambda (syntmp-_-1133) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-1124 - syntmp-w-1126 - syntmp-s-1127 - syntmp-mod-1128))) - syntmp-tmp-1129))) - (syntax-dispatch - syntmp-tmp-1129 - '(any any)))) - syntmp-e-1124))) - (syntmp-global-extend-117 - 'core - 'syntax - (letrec ((syntmp-regen-1141 - (lambda (syntmp-x-1142) - (let ((syntmp-t-1143 (car syntmp-x-1142))) - (if (memv syntmp-t-1143 (quote (ref))) - (syntmp-build-annotated-96 - #f - (cadr syntmp-x-1142)) - (if (memv syntmp-t-1143 (quote (primitive))) - (syntmp-build-annotated-96 - #f - (cadr syntmp-x-1142)) - (if (memv syntmp-t-1143 (quote (quote))) - (syntmp-build-data-97 #f (cadr syntmp-x-1142)) - (if (memv syntmp-t-1143 (quote (lambda))) - (syntmp-build-annotated-96 - #f - (list 'lambda - (cadr syntmp-x-1142) - (syntmp-regen-1141 - (caddr syntmp-x-1142)))) - (if (memv syntmp-t-1143 (quote (map))) - (let ((syntmp-ls-1144 - (map syntmp-regen-1141 - (cdr syntmp-x-1142)))) - (syntmp-build-annotated-96 - #f - (cons (if (syntmp-fx=-89 - (length syntmp-ls-1144) - 2) - (syntmp-build-annotated-96 - #f - 'map) - (syntmp-build-annotated-96 - #f - 'map)) - syntmp-ls-1144))) - (syntmp-build-annotated-96 - #f - (cons (syntmp-build-annotated-96 - #f - (car syntmp-x-1142)) - (map syntmp-regen-1141 - (cdr syntmp-x-1142)))))))))))) - (syntmp-gen-vector-1140 - (lambda (syntmp-x-1145) - (cond ((eq? (car syntmp-x-1145) (quote list)) - (cons (quote vector) (cdr syntmp-x-1145))) - ((eq? (car syntmp-x-1145) (quote quote)) - (list 'quote - (list->vector (cadr syntmp-x-1145)))) - (else (list (quote list->vector) syntmp-x-1145))))) - (syntmp-gen-append-1139 - (lambda (syntmp-x-1146 syntmp-y-1147) - (if (equal? syntmp-y-1147 (quote (quote ()))) - syntmp-x-1146 - (list (quote append) syntmp-x-1146 syntmp-y-1147)))) - (syntmp-gen-cons-1138 - (lambda (syntmp-x-1148 syntmp-y-1149) - (let ((syntmp-t-1150 (car syntmp-y-1149))) - (if (memv syntmp-t-1150 (quote (quote))) - (if (eq? (car syntmp-x-1148) (quote quote)) - (list 'quote - (cons (cadr syntmp-x-1148) - (cadr syntmp-y-1149))) - (if (eq? (cadr syntmp-y-1149) (quote ())) - (list (quote list) syntmp-x-1148) - (list (quote cons) syntmp-x-1148 syntmp-y-1149))) - (if (memv syntmp-t-1150 (quote (list))) - (cons 'list - (cons syntmp-x-1148 (cdr syntmp-y-1149))) - (list (quote cons) syntmp-x-1148 syntmp-y-1149)))))) - (syntmp-gen-map-1137 - (lambda (syntmp-e-1151 syntmp-map-env-1152) - (let ((syntmp-formals-1153 - (map cdr syntmp-map-env-1152)) - (syntmp-actuals-1154 - (map (lambda (syntmp-x-1155) - (list (quote ref) (car syntmp-x-1155))) - syntmp-map-env-1152))) - (cond ((eq? (car syntmp-e-1151) (quote ref)) - (car syntmp-actuals-1154)) - ((andmap - (lambda (syntmp-x-1156) - (and (eq? (car syntmp-x-1156) (quote ref)) - (memq (cadr syntmp-x-1156) - syntmp-formals-1153))) - (cdr syntmp-e-1151)) - (cons 'map - (cons (list 'primitive - (car syntmp-e-1151)) - (map (let ((syntmp-r-1157 - (map cons - syntmp-formals-1153 - syntmp-actuals-1154))) - (lambda (syntmp-x-1158) - (cdr (assq (cadr syntmp-x-1158) - syntmp-r-1157)))) - (cdr syntmp-e-1151))))) - (else - (cons 'map - (cons (list 'lambda - syntmp-formals-1153 - syntmp-e-1151) - syntmp-actuals-1154))))))) - (syntmp-gen-mappend-1136 - (lambda (syntmp-e-1159 syntmp-map-env-1160) - (list 'apply - '(primitive append) - (syntmp-gen-map-1137 - syntmp-e-1159 - syntmp-map-env-1160)))) - (syntmp-gen-ref-1135 - (lambda (syntmp-src-1161 - syntmp-var-1162 - syntmp-level-1163 - syntmp-maps-1164) - (if (syntmp-fx=-89 syntmp-level-1163 0) - (values syntmp-var-1162 syntmp-maps-1164) - (if (null? syntmp-maps-1164) - (syntax-error - syntmp-src-1161 - "missing ellipsis in syntax form") - (call-with-values - (lambda () - (syntmp-gen-ref-1135 - syntmp-src-1161 - syntmp-var-1162 - (syntmp-fx--88 syntmp-level-1163 1) - (cdr syntmp-maps-1164))) - (lambda (syntmp-outer-var-1165 syntmp-outer-maps-1166) - (let ((syntmp-b-1167 - (assq syntmp-outer-var-1165 - (car syntmp-maps-1164)))) - (if syntmp-b-1167 - (values (cdr syntmp-b-1167) syntmp-maps-1164) - (let ((syntmp-inner-var-1168 - (syntmp-gen-var-167 (quote tmp)))) - (values - syntmp-inner-var-1168 - (cons (cons (cons syntmp-outer-var-1165 - syntmp-inner-var-1168) - (car syntmp-maps-1164)) - syntmp-outer-maps-1166))))))))))) - (syntmp-gen-syntax-1134 - (lambda (syntmp-src-1169 - syntmp-e-1170 - syntmp-r-1171 - syntmp-maps-1172 - syntmp-ellipsis?-1173 - syntmp-mod-1174) - (if (syntmp-id?-119 syntmp-e-1170) - (let ((syntmp-label-1175 - (syntmp-id-var-name-141 - syntmp-e-1170 - '(())))) - (let ((syntmp-b-1176 - (syntmp-lookup-116 - syntmp-label-1175 - syntmp-r-1171 - syntmp-mod-1174))) - (if (eq? (syntmp-binding-type-111 syntmp-b-1176) - 'syntax) - (call-with-values - (lambda () - (let ((syntmp-var.lev-1177 - (syntmp-binding-value-112 - syntmp-b-1176))) - (syntmp-gen-ref-1135 - syntmp-src-1169 - (car syntmp-var.lev-1177) - (cdr syntmp-var.lev-1177) - syntmp-maps-1172))) - (lambda (syntmp-var-1178 syntmp-maps-1179) - (values - (list (quote ref) syntmp-var-1178) - syntmp-maps-1179))) - (if (syntmp-ellipsis?-1173 syntmp-e-1170) - (syntax-error - syntmp-src-1169 - "misplaced ellipsis in syntax form") - (values - (list (quote quote) syntmp-e-1170) - syntmp-maps-1172))))) - ((lambda (syntmp-tmp-1180) - ((lambda (syntmp-tmp-1181) - (if (if syntmp-tmp-1181 - (apply (lambda (syntmp-dots-1182 - syntmp-e-1183) - (syntmp-ellipsis?-1173 - syntmp-dots-1182)) - syntmp-tmp-1181) - #f) - (apply (lambda (syntmp-dots-1184 syntmp-e-1185) - (syntmp-gen-syntax-1134 - syntmp-src-1169 - syntmp-e-1185 - syntmp-r-1171 - syntmp-maps-1172 - (lambda (syntmp-x-1186) #f) - syntmp-mod-1174)) - syntmp-tmp-1181) - ((lambda (syntmp-tmp-1187) - (if (if syntmp-tmp-1187 - (apply (lambda (syntmp-x-1188 - syntmp-dots-1189 - syntmp-y-1190) - (syntmp-ellipsis?-1173 - syntmp-dots-1189)) - syntmp-tmp-1187) - #f) - (apply (lambda (syntmp-x-1191 - syntmp-dots-1192 - syntmp-y-1193) - (let syntmp-f-1194 ((syntmp-y-1195 - syntmp-y-1193) - (syntmp-k-1196 - (lambda (syntmp-maps-1197) - (call-with-values - (lambda () - (syntmp-gen-syntax-1134 - syntmp-src-1169 - syntmp-x-1191 - syntmp-r-1171 - (cons '() - syntmp-maps-1197) - syntmp-ellipsis?-1173 - syntmp-mod-1174)) - (lambda (syntmp-x-1198 - syntmp-maps-1199) - (if (null? (car syntmp-maps-1199)) - (syntax-error - syntmp-src-1169 - "extra ellipsis in syntax form") - (values - (syntmp-gen-map-1137 - syntmp-x-1198 - (car syntmp-maps-1199)) - (cdr syntmp-maps-1199)))))))) - ((lambda (syntmp-tmp-1200) - ((lambda (syntmp-tmp-1201) - (if (if syntmp-tmp-1201 - (apply (lambda (syntmp-dots-1202 - syntmp-y-1203) - (syntmp-ellipsis?-1173 - syntmp-dots-1202)) - syntmp-tmp-1201) - #f) - (apply (lambda (syntmp-dots-1204 - syntmp-y-1205) - (syntmp-f-1194 - syntmp-y-1205 - (lambda (syntmp-maps-1206) - (call-with-values - (lambda () - (syntmp-k-1196 - (cons '() - syntmp-maps-1206))) - (lambda (syntmp-x-1207 - syntmp-maps-1208) - (if (null? (car syntmp-maps-1208)) - (syntax-error - syntmp-src-1169 - "extra ellipsis in syntax form") - (values - (syntmp-gen-mappend-1136 - syntmp-x-1207 - (car syntmp-maps-1208)) - (cdr syntmp-maps-1208)))))))) - syntmp-tmp-1201) - ((lambda (syntmp-_-1209) - (call-with-values - (lambda () - (syntmp-gen-syntax-1134 - syntmp-src-1169 - syntmp-y-1195 - syntmp-r-1171 - syntmp-maps-1172 - syntmp-ellipsis?-1173 - syntmp-mod-1174)) - (lambda (syntmp-y-1210 - syntmp-maps-1211) - (call-with-values - (lambda () - (syntmp-k-1196 - syntmp-maps-1211)) - (lambda (syntmp-x-1212 - syntmp-maps-1213) - (values - (syntmp-gen-append-1139 - syntmp-x-1212 - syntmp-y-1210) - syntmp-maps-1213)))))) - syntmp-tmp-1200))) - (syntax-dispatch - syntmp-tmp-1200 - '(any . any)))) - syntmp-y-1195))) - syntmp-tmp-1187) - ((lambda (syntmp-tmp-1214) - (if syntmp-tmp-1214 - (apply (lambda (syntmp-x-1215 - syntmp-y-1216) - (call-with-values - (lambda () - (syntmp-gen-syntax-1134 - syntmp-src-1169 - syntmp-x-1215 - syntmp-r-1171 - syntmp-maps-1172 - syntmp-ellipsis?-1173 - syntmp-mod-1174)) - (lambda (syntmp-x-1217 - syntmp-maps-1218) - (call-with-values - (lambda () - (syntmp-gen-syntax-1134 - syntmp-src-1169 - syntmp-y-1216 - syntmp-r-1171 - syntmp-maps-1218 - syntmp-ellipsis?-1173 - syntmp-mod-1174)) - (lambda (syntmp-y-1219 - syntmp-maps-1220) - (values - (syntmp-gen-cons-1138 - syntmp-x-1217 - syntmp-y-1219) - syntmp-maps-1220)))))) - syntmp-tmp-1214) - ((lambda (syntmp-tmp-1221) - (if syntmp-tmp-1221 - (apply (lambda (syntmp-e1-1222 - syntmp-e2-1223) - (call-with-values - (lambda () - (syntmp-gen-syntax-1134 - syntmp-src-1169 - (cons syntmp-e1-1222 - syntmp-e2-1223) - syntmp-r-1171 - syntmp-maps-1172 - syntmp-ellipsis?-1173 - syntmp-mod-1174)) - (lambda (syntmp-e-1225 - syntmp-maps-1226) - (values - (syntmp-gen-vector-1140 - syntmp-e-1225) - syntmp-maps-1226)))) - syntmp-tmp-1221) - ((lambda (syntmp-_-1227) - (values - (list 'quote - syntmp-e-1170) - syntmp-maps-1172)) - syntmp-tmp-1180))) - (syntax-dispatch - syntmp-tmp-1180 - '#(vector (any . each-any)))))) - (syntax-dispatch - syntmp-tmp-1180 - '(any . any))))) - (syntax-dispatch - syntmp-tmp-1180 - '(any any . any))))) - (syntax-dispatch - syntmp-tmp-1180 - '(any any)))) - syntmp-e-1170))))) - (lambda (syntmp-e-1228 - syntmp-r-1229 - syntmp-w-1230 - syntmp-s-1231 - syntmp-mod-1232) - (let ((syntmp-e-1233 - (syntmp-source-wrap-148 - syntmp-e-1228 - syntmp-w-1230 - syntmp-s-1231 - syntmp-mod-1232))) - ((lambda (syntmp-tmp-1234) - ((lambda (syntmp-tmp-1235) - (if syntmp-tmp-1235 - (apply (lambda (syntmp-_-1236 syntmp-x-1237) - (call-with-values - (lambda () - (syntmp-gen-syntax-1134 - syntmp-e-1233 - syntmp-x-1237 - syntmp-r-1229 - '() - syntmp-ellipsis?-164 - syntmp-mod-1232)) - (lambda (syntmp-e-1238 syntmp-maps-1239) - (syntmp-regen-1141 syntmp-e-1238)))) - syntmp-tmp-1235) - ((lambda (syntmp-_-1240) - (syntax-error syntmp-e-1233)) - syntmp-tmp-1234))) - (syntax-dispatch - syntmp-tmp-1234 - '(any any)))) - syntmp-e-1233))))) - (syntmp-global-extend-117 - 'core - 'lambda - (lambda (syntmp-e-1241 - syntmp-r-1242 - syntmp-w-1243 - syntmp-s-1244 - syntmp-mod-1245) - ((lambda (syntmp-tmp-1246) - ((lambda (syntmp-tmp-1247) - (if syntmp-tmp-1247 - (apply (lambda (syntmp-_-1248 syntmp-c-1249) - (syntmp-chi-lambda-clause-160 - (syntmp-source-wrap-148 - syntmp-e-1241 - syntmp-w-1243 - syntmp-s-1244 - syntmp-mod-1245) - syntmp-c-1249 - syntmp-r-1242 - syntmp-w-1243 - syntmp-mod-1245 - (lambda (syntmp-vars-1250 syntmp-body-1251) - (syntmp-build-annotated-96 - syntmp-s-1244 - (list 'lambda - syntmp-vars-1250 - syntmp-body-1251))))) - syntmp-tmp-1247) - (syntax-error syntmp-tmp-1246))) - (syntax-dispatch - syntmp-tmp-1246 - '(any . any)))) - syntmp-e-1241))) - (syntmp-global-extend-117 - 'core - 'let - (letrec ((syntmp-chi-let-1252 - (lambda (syntmp-e-1253 - syntmp-r-1254 - syntmp-w-1255 - syntmp-s-1256 - syntmp-mod-1257 - syntmp-constructor-1258 - syntmp-ids-1259 - syntmp-vals-1260 - syntmp-exps-1261) - (if (not (syntmp-valid-bound-ids?-144 syntmp-ids-1259)) - (syntax-error - syntmp-e-1253 - "duplicate bound variable in") - (let ((syntmp-labels-1262 - (syntmp-gen-labels-125 syntmp-ids-1259)) - (syntmp-new-vars-1263 - (map syntmp-gen-var-167 syntmp-ids-1259))) - (let ((syntmp-nw-1264 - (syntmp-make-binding-wrap-136 - syntmp-ids-1259 - syntmp-labels-1262 - syntmp-w-1255)) - (syntmp-nr-1265 - (syntmp-extend-var-env-114 - syntmp-labels-1262 - syntmp-new-vars-1263 - syntmp-r-1254))) - (syntmp-constructor-1258 - syntmp-s-1256 - syntmp-new-vars-1263 - (map (lambda (syntmp-x-1266) - (syntmp-chi-155 - syntmp-x-1266 - syntmp-r-1254 - syntmp-w-1255 - syntmp-mod-1257)) - syntmp-vals-1260) - (syntmp-chi-body-159 - syntmp-exps-1261 - (syntmp-source-wrap-148 - syntmp-e-1253 - syntmp-nw-1264 - syntmp-s-1256 - syntmp-mod-1257) - syntmp-nr-1265 - syntmp-nw-1264 - syntmp-mod-1257)))))))) - (lambda (syntmp-e-1267 - syntmp-r-1268 - syntmp-w-1269 - syntmp-s-1270 - syntmp-mod-1271) - ((lambda (syntmp-tmp-1272) - ((lambda (syntmp-tmp-1273) - (if syntmp-tmp-1273 - (apply (lambda (syntmp-_-1274 - syntmp-id-1275 - syntmp-val-1276 - syntmp-e1-1277 - syntmp-e2-1278) - (syntmp-chi-let-1252 - syntmp-e-1267 - syntmp-r-1268 - syntmp-w-1269 - syntmp-s-1270 - syntmp-mod-1271 - syntmp-build-let-99 - syntmp-id-1275 - syntmp-val-1276 - (cons syntmp-e1-1277 syntmp-e2-1278))) - syntmp-tmp-1273) - ((lambda (syntmp-tmp-1282) - (if (if syntmp-tmp-1282 - (apply (lambda (syntmp-_-1283 - syntmp-f-1284 - syntmp-id-1285 - syntmp-val-1286 - syntmp-e1-1287 - syntmp-e2-1288) - (syntmp-id?-119 syntmp-f-1284)) - syntmp-tmp-1282) - #f) - (apply (lambda (syntmp-_-1289 - syntmp-f-1290 - syntmp-id-1291 - syntmp-val-1292 - syntmp-e1-1293 - syntmp-e2-1294) - (syntmp-chi-let-1252 - syntmp-e-1267 - syntmp-r-1268 - syntmp-w-1269 - syntmp-s-1270 - syntmp-mod-1271 - syntmp-build-named-let-100 - (cons syntmp-f-1290 syntmp-id-1291) - syntmp-val-1292 - (cons syntmp-e1-1293 syntmp-e2-1294))) - syntmp-tmp-1282) - ((lambda (syntmp-_-1298) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-1267 - syntmp-w-1269 - syntmp-s-1270 - syntmp-mod-1271))) - syntmp-tmp-1272))) - (syntax-dispatch - syntmp-tmp-1272 - '(any any #(each (any any)) any . each-any))))) - (syntax-dispatch - syntmp-tmp-1272 - '(any #(each (any any)) any . each-any)))) - syntmp-e-1267)))) - (syntmp-global-extend-117 - 'core - 'letrec - (lambda (syntmp-e-1299 - syntmp-r-1300 - syntmp-w-1301 - syntmp-s-1302 - syntmp-mod-1303) - ((lambda (syntmp-tmp-1304) - ((lambda (syntmp-tmp-1305) - (if syntmp-tmp-1305 - (apply (lambda (syntmp-_-1306 - syntmp-id-1307 - syntmp-val-1308 - syntmp-e1-1309 - syntmp-e2-1310) - (let ((syntmp-ids-1311 syntmp-id-1307)) - (if (not (syntmp-valid-bound-ids?-144 - syntmp-ids-1311)) - (syntax-error - syntmp-e-1299 - "duplicate bound variable in") - (let ((syntmp-labels-1313 - (syntmp-gen-labels-125 syntmp-ids-1311)) - (syntmp-new-vars-1314 - (map syntmp-gen-var-167 syntmp-ids-1311))) - (let ((syntmp-w-1315 - (syntmp-make-binding-wrap-136 - syntmp-ids-1311 - syntmp-labels-1313 - syntmp-w-1301)) - (syntmp-r-1316 - (syntmp-extend-var-env-114 - syntmp-labels-1313 - syntmp-new-vars-1314 - syntmp-r-1300))) - (syntmp-build-letrec-101 - syntmp-s-1302 - syntmp-new-vars-1314 - (map (lambda (syntmp-x-1317) - (syntmp-chi-155 - syntmp-x-1317 - syntmp-r-1316 - syntmp-w-1315 - syntmp-mod-1303)) - syntmp-val-1308) - (syntmp-chi-body-159 - (cons syntmp-e1-1309 syntmp-e2-1310) - (syntmp-source-wrap-148 - syntmp-e-1299 - syntmp-w-1315 - syntmp-s-1302 - syntmp-mod-1303) - syntmp-r-1316 - syntmp-w-1315 - syntmp-mod-1303))))))) - syntmp-tmp-1305) - ((lambda (syntmp-_-1320) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-1299 - syntmp-w-1301 - syntmp-s-1302 - syntmp-mod-1303))) - syntmp-tmp-1304))) - (syntax-dispatch - syntmp-tmp-1304 - '(any #(each (any any)) any . each-any)))) - syntmp-e-1299))) - (syntmp-global-extend-117 - 'core - 'set! - (lambda (syntmp-e-1321 - syntmp-r-1322 - syntmp-w-1323 - syntmp-s-1324 - syntmp-mod-1325) - ((lambda (syntmp-tmp-1326) - ((lambda (syntmp-tmp-1327) - (if (if syntmp-tmp-1327 - (apply (lambda (syntmp-_-1328 - syntmp-id-1329 - syntmp-val-1330) - (syntmp-id?-119 syntmp-id-1329)) - syntmp-tmp-1327) - #f) - (apply (lambda (syntmp-_-1331 syntmp-id-1332 syntmp-val-1333) - (let ((syntmp-val-1334 - (syntmp-chi-155 - syntmp-val-1333 - syntmp-r-1322 - syntmp-w-1323 - syntmp-mod-1325)) - (syntmp-n-1335 - (syntmp-id-var-name-141 - syntmp-id-1332 - syntmp-w-1323))) - (let ((syntmp-b-1336 - (syntmp-lookup-116 - syntmp-n-1335 - syntmp-r-1322 - syntmp-mod-1325))) - (let ((syntmp-t-1337 - (syntmp-binding-type-111 syntmp-b-1336))) - (if (memv syntmp-t-1337 (quote (lexical))) - (syntmp-build-annotated-96 - syntmp-s-1324 - (list 'set! - (syntmp-binding-value-112 - syntmp-b-1336) - syntmp-val-1334)) - (if (memv syntmp-t-1337 (quote (global))) - (syntmp-build-annotated-96 - syntmp-s-1324 - (list 'set! - (make-module-ref - syntmp-mod-1325 - syntmp-n-1335 - #f) - syntmp-val-1334)) - (if (memv syntmp-t-1337 - '(displaced-lexical)) - (syntax-error - (syntmp-wrap-147 - syntmp-id-1332 - syntmp-w-1323 - syntmp-mod-1325) - "identifier out of context") - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-1321 - syntmp-w-1323 - syntmp-s-1324 - syntmp-mod-1325))))))))) - syntmp-tmp-1327) - ((lambda (syntmp-tmp-1338) - (if syntmp-tmp-1338 - (apply (lambda (syntmp-_-1339 - syntmp-getter-1340 - syntmp-arg-1341 - syntmp-val-1342) - (syntmp-build-annotated-96 - syntmp-s-1324 - (cons (syntmp-chi-155 - (list '#(syntax-object - setter - ((top) - #(ribcage - #(_ getter arg val) - #((top) (top) (top) (top)) - #("i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(e r w s mod) - #((top) - (top) - (top) - (top) - (top)) - #("i" "i" "i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure) - ((top)) - ("i"))) - (ice-9 syncase)) - syntmp-getter-1340) - syntmp-r-1322 - syntmp-w-1323 - syntmp-mod-1325) - (map (lambda (syntmp-e-1343) - (syntmp-chi-155 - syntmp-e-1343 - syntmp-r-1322 - syntmp-w-1323 - syntmp-mod-1325)) - (append - syntmp-arg-1341 - (list syntmp-val-1342)))))) - syntmp-tmp-1338) - ((lambda (syntmp-_-1345) - (syntax-error - (syntmp-source-wrap-148 - syntmp-e-1321 - syntmp-w-1323 - syntmp-s-1324 - syntmp-mod-1325))) - syntmp-tmp-1326))) - (syntax-dispatch - syntmp-tmp-1326 - '(any (any . each-any) any))))) - (syntax-dispatch - syntmp-tmp-1326 - '(any any any)))) - syntmp-e-1321))) - (syntmp-global-extend-117 - 'begin - 'begin - '()) - (syntmp-global-extend-117 - 'define - 'define - '()) - (syntmp-global-extend-117 - 'define-syntax - 'define-syntax - '()) - (syntmp-global-extend-117 - 'eval-when - 'eval-when - '()) - (syntmp-global-extend-117 - 'core - 'syntax-case - (letrec ((syntmp-gen-syntax-case-1349 - (lambda (syntmp-x-1350 - syntmp-keys-1351 - syntmp-clauses-1352 - syntmp-r-1353 - syntmp-mod-1354) - (if (null? syntmp-clauses-1352) - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 - #f - 'syntax-error) - syntmp-x-1350)) - ((lambda (syntmp-tmp-1355) - ((lambda (syntmp-tmp-1356) - (if syntmp-tmp-1356 - (apply (lambda (syntmp-pat-1357 syntmp-exp-1358) - (if (and (syntmp-id?-119 syntmp-pat-1357) - (andmap - (lambda (syntmp-x-1359) - (not (syntmp-free-id=?-142 - syntmp-pat-1357 - syntmp-x-1359))) - (cons '#(syntax-object - ... - ((top) - #(ribcage - #(pat exp) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(x - keys - clauses - r - mod) - #((top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) - (top) - (top) - (top)) - ("i" "i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - strip-annotation - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - unannotate - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - build-global-assignment - build-global-reference - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-annotated - get-global-definition-hook - put-global-definition-hook - gensym-hook - error-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure) - ((top)) - ("i"))) - (ice-9 syncase)) - syntmp-keys-1351))) - (let ((syntmp-labels-1360 - (list (syntmp-gen-label-124))) - (syntmp-var-1361 - (syntmp-gen-var-167 - syntmp-pat-1357))) - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 - #f - (list 'lambda - (list syntmp-var-1361) - (syntmp-chi-155 - syntmp-exp-1358 - (syntmp-extend-env-113 - syntmp-labels-1360 - (list (cons 'syntax - (cons syntmp-var-1361 - 0))) - syntmp-r-1353) - (syntmp-make-binding-wrap-136 - (list syntmp-pat-1357) - syntmp-labels-1360 - '(())) - syntmp-mod-1354))) - syntmp-x-1350))) - (syntmp-gen-clause-1348 - syntmp-x-1350 - syntmp-keys-1351 - (cdr syntmp-clauses-1352) - syntmp-r-1353 - syntmp-pat-1357 - #t - syntmp-exp-1358 - syntmp-mod-1354))) - syntmp-tmp-1356) - ((lambda (syntmp-tmp-1362) - (if syntmp-tmp-1362 - (apply (lambda (syntmp-pat-1363 - syntmp-fender-1364 - syntmp-exp-1365) - (syntmp-gen-clause-1348 - syntmp-x-1350 - syntmp-keys-1351 - (cdr syntmp-clauses-1352) - syntmp-r-1353 - syntmp-pat-1363 - syntmp-fender-1364 - syntmp-exp-1365 - syntmp-mod-1354)) - syntmp-tmp-1362) - ((lambda (syntmp-_-1366) - (syntax-error - (car syntmp-clauses-1352) - "invalid syntax-case clause")) - syntmp-tmp-1355))) - (syntax-dispatch - syntmp-tmp-1355 - '(any any any))))) - (syntax-dispatch - syntmp-tmp-1355 - '(any any)))) - (car syntmp-clauses-1352))))) - (syntmp-gen-clause-1348 - (lambda (syntmp-x-1367 - syntmp-keys-1368 - syntmp-clauses-1369 - syntmp-r-1370 - syntmp-pat-1371 - syntmp-fender-1372 - syntmp-exp-1373 - syntmp-mod-1374) - (call-with-values - (lambda () - (syntmp-convert-pattern-1346 - syntmp-pat-1371 - syntmp-keys-1368)) - (lambda (syntmp-p-1375 syntmp-pvars-1376) - (cond ((not (syntmp-distinct-bound-ids?-145 - (map car syntmp-pvars-1376))) - (syntax-error - syntmp-pat-1371 - "duplicate pattern variable in syntax-case pattern")) - ((not (andmap - (lambda (syntmp-x-1377) - (not (syntmp-ellipsis?-164 - (car syntmp-x-1377)))) - syntmp-pvars-1376)) - (syntax-error - syntmp-pat-1371 - "misplaced ellipsis in syntax-case pattern")) - (else - (let ((syntmp-y-1378 - (syntmp-gen-var-167 (quote tmp)))) - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 - #f - (list 'lambda - (list syntmp-y-1378) - (let ((syntmp-y-1379 - (syntmp-build-annotated-96 - #f - syntmp-y-1378))) - (syntmp-build-annotated-96 - #f - (list 'if - ((lambda (syntmp-tmp-1380) - ((lambda (syntmp-tmp-1381) - (if syntmp-tmp-1381 - (apply (lambda () - syntmp-y-1379) - syntmp-tmp-1381) - ((lambda (syntmp-_-1382) - (syntmp-build-annotated-96 - #f - (list 'if - syntmp-y-1379 - (syntmp-build-dispatch-call-1347 - syntmp-pvars-1376 - syntmp-fender-1372 - syntmp-y-1379 - syntmp-r-1370 - syntmp-mod-1374) - (syntmp-build-data-97 - #f - #f)))) - syntmp-tmp-1380))) - (syntax-dispatch - syntmp-tmp-1380 - '#(atom #t)))) - syntmp-fender-1372) - (syntmp-build-dispatch-call-1347 - syntmp-pvars-1376 - syntmp-exp-1373 - syntmp-y-1379 - syntmp-r-1370 - syntmp-mod-1374) - (syntmp-gen-syntax-case-1349 - syntmp-x-1367 - syntmp-keys-1368 - syntmp-clauses-1369 - syntmp-r-1370 - syntmp-mod-1374)))))) - (if (eq? syntmp-p-1375 (quote any)) - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 - #f - 'list) - syntmp-x-1367)) - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 - #f - 'syntax-dispatch) - syntmp-x-1367 - (syntmp-build-data-97 - #f - syntmp-p-1375))))))))))))) - (syntmp-build-dispatch-call-1347 - (lambda (syntmp-pvars-1383 - syntmp-exp-1384 - syntmp-y-1385 - syntmp-r-1386 - syntmp-mod-1387) - (let ((syntmp-ids-1388 (map car syntmp-pvars-1383)) - (syntmp-levels-1389 (map cdr syntmp-pvars-1383))) - (let ((syntmp-labels-1390 - (syntmp-gen-labels-125 syntmp-ids-1388)) - (syntmp-new-vars-1391 - (map syntmp-gen-var-167 syntmp-ids-1388))) - (syntmp-build-annotated-96 - #f - (list (syntmp-build-annotated-96 #f (quote apply)) - (syntmp-build-annotated-96 - #f - (list 'lambda - syntmp-new-vars-1391 - (syntmp-chi-155 - syntmp-exp-1384 - (syntmp-extend-env-113 - syntmp-labels-1390 - (map (lambda (syntmp-var-1392 - syntmp-level-1393) - (cons 'syntax - (cons syntmp-var-1392 - syntmp-level-1393))) - syntmp-new-vars-1391 - (map cdr syntmp-pvars-1383)) - syntmp-r-1386) - (syntmp-make-binding-wrap-136 - syntmp-ids-1388 - syntmp-labels-1390 - '(())) - syntmp-mod-1387))) - syntmp-y-1385)))))) - (syntmp-convert-pattern-1346 - (lambda (syntmp-pattern-1394 syntmp-keys-1395) - (let syntmp-cvt-1396 ((syntmp-p-1397 syntmp-pattern-1394) - (syntmp-n-1398 0) - (syntmp-ids-1399 (quote ()))) - (if (syntmp-id?-119 syntmp-p-1397) - (if (syntmp-bound-id-member?-146 - syntmp-p-1397 - syntmp-keys-1395) - (values - (vector (quote free-id) syntmp-p-1397) - syntmp-ids-1399) - (values - 'any - (cons (cons syntmp-p-1397 syntmp-n-1398) - syntmp-ids-1399))) - ((lambda (syntmp-tmp-1400) - ((lambda (syntmp-tmp-1401) - (if (if syntmp-tmp-1401 - (apply (lambda (syntmp-x-1402 - syntmp-dots-1403) - (syntmp-ellipsis?-164 - syntmp-dots-1403)) - syntmp-tmp-1401) - #f) - (apply (lambda (syntmp-x-1404 syntmp-dots-1405) - (call-with-values - (lambda () - (syntmp-cvt-1396 - syntmp-x-1404 - (syntmp-fx+-87 syntmp-n-1398 1) - syntmp-ids-1399)) - (lambda (syntmp-p-1406 - syntmp-ids-1407) - (values - (if (eq? syntmp-p-1406 - 'any) - 'each-any - (vector - 'each - syntmp-p-1406)) - syntmp-ids-1407)))) - syntmp-tmp-1401) - ((lambda (syntmp-tmp-1408) - (if syntmp-tmp-1408 - (apply (lambda (syntmp-x-1409 - syntmp-y-1410) - (call-with-values - (lambda () - (syntmp-cvt-1396 - syntmp-y-1410 - syntmp-n-1398 - syntmp-ids-1399)) - (lambda (syntmp-y-1411 - syntmp-ids-1412) - (call-with-values - (lambda () - (syntmp-cvt-1396 - syntmp-x-1409 - syntmp-n-1398 - syntmp-ids-1412)) - (lambda (syntmp-x-1413 - syntmp-ids-1414) - (values - (cons syntmp-x-1413 - syntmp-y-1411) - syntmp-ids-1414)))))) - syntmp-tmp-1408) - ((lambda (syntmp-tmp-1415) - (if syntmp-tmp-1415 - (apply (lambda () - (values - '() - syntmp-ids-1399)) - syntmp-tmp-1415) - ((lambda (syntmp-tmp-1416) - (if syntmp-tmp-1416 - (apply (lambda (syntmp-x-1417) - (call-with-values - (lambda () - (syntmp-cvt-1396 - syntmp-x-1417 - syntmp-n-1398 - syntmp-ids-1399)) - (lambda (syntmp-p-1419 - syntmp-ids-1420) - (values - (vector - 'vector - syntmp-p-1419) - syntmp-ids-1420)))) - syntmp-tmp-1416) - ((lambda (syntmp-x-1421) - (values - (vector - 'atom - (syntmp-strip-166 - syntmp-p-1397 - '(()))) - syntmp-ids-1399)) - syntmp-tmp-1400))) - (syntax-dispatch - syntmp-tmp-1400 - '#(vector each-any))))) - (syntax-dispatch - syntmp-tmp-1400 - '())))) - (syntax-dispatch - syntmp-tmp-1400 - '(any . any))))) - (syntax-dispatch - syntmp-tmp-1400 - '(any any)))) - syntmp-p-1397)))))) - (lambda (syntmp-e-1422 - syntmp-r-1423 - syntmp-w-1424 - syntmp-s-1425 - syntmp-mod-1426) - (let ((syntmp-e-1427 - (syntmp-source-wrap-148 - syntmp-e-1422 - syntmp-w-1424 - syntmp-s-1425 - syntmp-mod-1426))) - ((lambda (syntmp-tmp-1428) - ((lambda (syntmp-tmp-1429) - (if syntmp-tmp-1429 - (apply (lambda (syntmp-_-1430 - syntmp-val-1431 - syntmp-key-1432 - syntmp-m-1433) - (if (andmap - (lambda (syntmp-x-1434) - (and (syntmp-id?-119 syntmp-x-1434) - (not (syntmp-ellipsis?-164 - syntmp-x-1434)))) - syntmp-key-1432) - (let ((syntmp-x-1436 - (syntmp-gen-var-167 (quote tmp)))) - (syntmp-build-annotated-96 - syntmp-s-1425 - (list (syntmp-build-annotated-96 - #f - (list 'lambda - (list syntmp-x-1436) - (syntmp-gen-syntax-case-1349 - (syntmp-build-annotated-96 - #f - syntmp-x-1436) - syntmp-key-1432 - syntmp-m-1433 - syntmp-r-1423 - syntmp-mod-1426))) - (syntmp-chi-155 - syntmp-val-1431 - syntmp-r-1423 - '(()) - syntmp-mod-1426)))) - (syntax-error - syntmp-e-1427 - "invalid literals list in"))) - syntmp-tmp-1429) - (syntax-error syntmp-tmp-1428))) - (syntax-dispatch - syntmp-tmp-1428 - '(any any each-any . each-any)))) - syntmp-e-1427))))) - (set! sc-expand - (let ((syntmp-m-1439 (quote e)) - (syntmp-esew-1440 (quote (eval)))) - (lambda (syntmp-x-1441) - (if (and (pair? syntmp-x-1441) - (equal? (car syntmp-x-1441) syntmp-noexpand-86)) - (cadr syntmp-x-1441) - (syntmp-chi-top-154 - syntmp-x-1441 - '() - '((top)) - syntmp-m-1439 - syntmp-esew-1440 - (module-name (current-module))))))) - (set! sc-expand3 - (let ((syntmp-m-1442 (quote e)) - (syntmp-esew-1443 (quote (eval)))) - (lambda (syntmp-x-1445 . syntmp-rest-1444) - (if (and (pair? syntmp-x-1445) - (equal? (car syntmp-x-1445) syntmp-noexpand-86)) - (cadr syntmp-x-1445) - (syntmp-chi-top-154 - syntmp-x-1445 - '() - '((top)) - (if (null? syntmp-rest-1444) - syntmp-m-1442 - (car syntmp-rest-1444)) - (if (or (null? syntmp-rest-1444) - (null? (cdr syntmp-rest-1444))) - syntmp-esew-1443 - (cadr syntmp-rest-1444)) - (module-name (current-module))))))) - (set! identifier? - (lambda (syntmp-x-1446) - (syntmp-nonsymbol-id?-118 syntmp-x-1446))) - (set! datum->syntax-object - (lambda (syntmp-id-1447 syntmp-datum-1448) - (syntmp-make-syntax-object-102 - syntmp-datum-1448 - (syntmp-syntax-object-wrap-105 syntmp-id-1447) - #f))) - (set! syntax-object->datum - (lambda (syntmp-x-1449) - (syntmp-strip-166 syntmp-x-1449 (quote (()))))) - (set! generate-temporaries - (lambda (syntmp-ls-1450) - (begin - (let ((syntmp-x-1451 syntmp-ls-1450)) - (if (not (list? syntmp-x-1451)) - (syntmp-error-hook-93 - 'generate-temporaries - "invalid argument" - syntmp-x-1451))) - (map (lambda (syntmp-x-1452) - (syntmp-wrap-147 (gensym) (quote ((top))) #f)) - syntmp-ls-1450)))) - (set! free-identifier=? - (lambda (syntmp-x-1453 syntmp-y-1454) - (begin - (let ((syntmp-x-1455 syntmp-x-1453)) - (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1455)) - (syntmp-error-hook-93 - 'free-identifier=? - "invalid argument" - syntmp-x-1455))) - (let ((syntmp-x-1456 syntmp-y-1454)) - (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1456)) - (syntmp-error-hook-93 - 'free-identifier=? - "invalid argument" - syntmp-x-1456))) - (syntmp-free-id=?-142 - syntmp-x-1453 - syntmp-y-1454)))) - (set! bound-identifier=? - (lambda (syntmp-x-1457 syntmp-y-1458) - (begin - (let ((syntmp-x-1459 syntmp-x-1457)) - (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1459)) - (syntmp-error-hook-93 - 'bound-identifier=? - "invalid argument" - syntmp-x-1459))) - (let ((syntmp-x-1460 syntmp-y-1458)) - (if (not (syntmp-nonsymbol-id?-118 syntmp-x-1460)) - (syntmp-error-hook-93 - 'bound-identifier=? - "invalid argument" - syntmp-x-1460))) - (syntmp-bound-id=?-143 - syntmp-x-1457 - syntmp-y-1458)))) - (set! syntax-error - (lambda (syntmp-object-1462 . syntmp-messages-1461) - (begin - (for-each - (lambda (syntmp-x-1463) - (let ((syntmp-x-1464 syntmp-x-1463)) - (if (not (string? syntmp-x-1464)) - (syntmp-error-hook-93 - 'syntax-error - "invalid argument" - syntmp-x-1464)))) - syntmp-messages-1461) - (let ((syntmp-message-1465 - (if (null? syntmp-messages-1461) - "invalid syntax" - (apply string-append syntmp-messages-1461)))) - (syntmp-error-hook-93 - #f - syntmp-message-1465 - (syntmp-strip-166 - syntmp-object-1462 - '(()))))))) - (set! install-global-transformer - (lambda (syntmp-sym-1466 syntmp-v-1467) - (begin - (let ((syntmp-x-1468 syntmp-sym-1466)) - (if (not (symbol? syntmp-x-1468)) - (syntmp-error-hook-93 - 'define-syntax - "invalid argument" - syntmp-x-1468))) - (let ((syntmp-x-1469 syntmp-v-1467)) - (if (not (procedure? syntmp-x-1469)) - (syntmp-error-hook-93 - 'define-syntax - "invalid argument" - syntmp-x-1469))) - (syntmp-global-extend-117 - 'macro - syntmp-sym-1466 - syntmp-v-1467)))) - (letrec ((syntmp-match-1474 - (lambda (syntmp-e-1475 - syntmp-p-1476 - syntmp-w-1477 - syntmp-r-1478 - syntmp-mod-1479) - (cond ((not syntmp-r-1478) #f) - ((eq? syntmp-p-1476 (quote any)) - (cons (syntmp-wrap-147 - syntmp-e-1475 - syntmp-w-1477 - syntmp-mod-1479) - syntmp-r-1478)) - ((syntmp-syntax-object?-103 syntmp-e-1475) - (syntmp-match*-1473 - (let ((syntmp-e-1480 - (syntmp-syntax-object-expression-104 - syntmp-e-1475))) - (if (annotation? syntmp-e-1480) - (annotation-expression syntmp-e-1480) - syntmp-e-1480)) - syntmp-p-1476 - (syntmp-join-wraps-138 - syntmp-w-1477 - (syntmp-syntax-object-wrap-105 syntmp-e-1475)) - syntmp-r-1478 - (syntmp-syntax-object-module-106 syntmp-e-1475))) - (else - (syntmp-match*-1473 - (let ((syntmp-e-1481 syntmp-e-1475)) - (if (annotation? syntmp-e-1481) - (annotation-expression syntmp-e-1481) - syntmp-e-1481)) - syntmp-p-1476 - syntmp-w-1477 - syntmp-r-1478 - syntmp-mod-1479))))) - (syntmp-match*-1473 - (lambda (syntmp-e-1482 - syntmp-p-1483 - syntmp-w-1484 - syntmp-r-1485 - syntmp-mod-1486) - (cond ((null? syntmp-p-1483) - (and (null? syntmp-e-1482) syntmp-r-1485)) - ((pair? syntmp-p-1483) - (and (pair? syntmp-e-1482) - (syntmp-match-1474 - (car syntmp-e-1482) - (car syntmp-p-1483) - syntmp-w-1484 - (syntmp-match-1474 - (cdr syntmp-e-1482) - (cdr syntmp-p-1483) - syntmp-w-1484 - syntmp-r-1485 - syntmp-mod-1486) - syntmp-mod-1486))) - ((eq? syntmp-p-1483 (quote each-any)) - (let ((syntmp-l-1487 - (syntmp-match-each-any-1471 - syntmp-e-1482 - syntmp-w-1484 - syntmp-mod-1486))) - (and syntmp-l-1487 - (cons syntmp-l-1487 syntmp-r-1485)))) - (else - (let ((syntmp-t-1488 (vector-ref syntmp-p-1483 0))) - (if (memv syntmp-t-1488 (quote (each))) - (if (null? syntmp-e-1482) - (syntmp-match-empty-1472 - (vector-ref syntmp-p-1483 1) - syntmp-r-1485) - (let ((syntmp-l-1489 - (syntmp-match-each-1470 - syntmp-e-1482 - (vector-ref syntmp-p-1483 1) - syntmp-w-1484 - syntmp-mod-1486))) - (and syntmp-l-1489 - (let syntmp-collect-1490 ((syntmp-l-1491 - syntmp-l-1489)) - (if (null? (car syntmp-l-1491)) - syntmp-r-1485 - (cons (map car syntmp-l-1491) - (syntmp-collect-1490 - (map cdr syntmp-l-1491)))))))) - (if (memv syntmp-t-1488 (quote (free-id))) - (and (syntmp-id?-119 syntmp-e-1482) - (syntmp-free-id=?-142 - (syntmp-wrap-147 - syntmp-e-1482 - syntmp-w-1484 - syntmp-mod-1486) - (vector-ref syntmp-p-1483 1)) - syntmp-r-1485) - (if (memv syntmp-t-1488 (quote (atom))) - (and (equal? - (vector-ref syntmp-p-1483 1) - (syntmp-strip-166 - syntmp-e-1482 - syntmp-w-1484)) - syntmp-r-1485) - (if (memv syntmp-t-1488 (quote (vector))) - (and (vector? syntmp-e-1482) - (syntmp-match-1474 - (vector->list syntmp-e-1482) - (vector-ref syntmp-p-1483 1) - syntmp-w-1484 - syntmp-r-1485 - syntmp-mod-1486))))))))))) - (syntmp-match-empty-1472 - (lambda (syntmp-p-1492 syntmp-r-1493) - (cond ((null? syntmp-p-1492) syntmp-r-1493) - ((eq? syntmp-p-1492 (quote any)) - (cons (quote ()) syntmp-r-1493)) - ((pair? syntmp-p-1492) - (syntmp-match-empty-1472 - (car syntmp-p-1492) - (syntmp-match-empty-1472 - (cdr syntmp-p-1492) - syntmp-r-1493))) - ((eq? syntmp-p-1492 (quote each-any)) - (cons (quote ()) syntmp-r-1493)) - (else - (let ((syntmp-t-1494 (vector-ref syntmp-p-1492 0))) - (if (memv syntmp-t-1494 (quote (each))) - (syntmp-match-empty-1472 - (vector-ref syntmp-p-1492 1) - syntmp-r-1493) - (if (memv syntmp-t-1494 (quote (free-id atom))) - syntmp-r-1493 - (if (memv syntmp-t-1494 (quote (vector))) - (syntmp-match-empty-1472 - (vector-ref syntmp-p-1492 1) - syntmp-r-1493))))))))) - (syntmp-match-each-any-1471 - (lambda (syntmp-e-1495 syntmp-w-1496 syntmp-mod-1497) - (cond ((annotation? syntmp-e-1495) - (syntmp-match-each-any-1471 - (annotation-expression syntmp-e-1495) - syntmp-w-1496 - syntmp-mod-1497)) - ((pair? syntmp-e-1495) - (let ((syntmp-l-1498 - (syntmp-match-each-any-1471 - (cdr syntmp-e-1495) - syntmp-w-1496 - syntmp-mod-1497))) - (and syntmp-l-1498 - (cons (syntmp-wrap-147 - (car syntmp-e-1495) - syntmp-w-1496 - syntmp-mod-1497) - syntmp-l-1498)))) - ((null? syntmp-e-1495) (quote ())) - ((syntmp-syntax-object?-103 syntmp-e-1495) - (syntmp-match-each-any-1471 - (syntmp-syntax-object-expression-104 - syntmp-e-1495) - (syntmp-join-wraps-138 - syntmp-w-1496 - (syntmp-syntax-object-wrap-105 syntmp-e-1495)) - syntmp-mod-1497)) - (else #f)))) - (syntmp-match-each-1470 - (lambda (syntmp-e-1499 - syntmp-p-1500 - syntmp-w-1501 - syntmp-mod-1502) - (cond ((annotation? syntmp-e-1499) - (syntmp-match-each-1470 - (annotation-expression syntmp-e-1499) - syntmp-p-1500 - syntmp-w-1501 - syntmp-mod-1502)) - ((pair? syntmp-e-1499) - (let ((syntmp-first-1503 - (syntmp-match-1474 - (car syntmp-e-1499) - syntmp-p-1500 - syntmp-w-1501 - '() - syntmp-mod-1502))) - (and syntmp-first-1503 - (let ((syntmp-rest-1504 - (syntmp-match-each-1470 - (cdr syntmp-e-1499) - syntmp-p-1500 - syntmp-w-1501 - syntmp-mod-1502))) - (and syntmp-rest-1504 - (cons syntmp-first-1503 - syntmp-rest-1504)))))) - ((null? syntmp-e-1499) (quote ())) - ((syntmp-syntax-object?-103 syntmp-e-1499) - (syntmp-match-each-1470 - (syntmp-syntax-object-expression-104 - syntmp-e-1499) - syntmp-p-1500 - (syntmp-join-wraps-138 - syntmp-w-1501 - (syntmp-syntax-object-wrap-105 syntmp-e-1499)) - (syntmp-syntax-object-module-106 syntmp-e-1499))) - (else #f))))) - (begin - (set! syntax-dispatch - (lambda (syntmp-e-1505 syntmp-p-1506) - (cond ((eq? syntmp-p-1506 (quote any)) - (list syntmp-e-1505)) - ((syntmp-syntax-object?-103 syntmp-e-1505) - (syntmp-match*-1473 - (let ((syntmp-e-1507 - (syntmp-syntax-object-expression-104 - syntmp-e-1505))) - (if (annotation? syntmp-e-1507) - (annotation-expression syntmp-e-1507) - syntmp-e-1507)) - syntmp-p-1506 - (syntmp-syntax-object-wrap-105 syntmp-e-1505) - '() - (syntmp-syntax-object-module-106 syntmp-e-1505))) - (else - (syntmp-match*-1473 - (let ((syntmp-e-1508 syntmp-e-1505)) - (if (annotation? syntmp-e-1508) - (annotation-expression syntmp-e-1508) - syntmp-e-1508)) - syntmp-p-1506 - '(()) - '() - #f))))) - (set! sc-chi syntmp-chi-155))))) -(install-global-transformer - 'with-syntax - (lambda (syntmp-x-1509) - ((lambda (syntmp-tmp-1510) - ((lambda (syntmp-tmp-1511) - (if syntmp-tmp-1511 - (apply (lambda (syntmp-_-1512 syntmp-e1-1513 syntmp-e2-1514) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(_ e1 e2) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - (cons syntmp-e1-1513 syntmp-e2-1514))) - syntmp-tmp-1511) - ((lambda (syntmp-tmp-1516) - (if syntmp-tmp-1516 - (apply (lambda (syntmp-_-1517 - syntmp-out-1518 - syntmp-in-1519 - syntmp-e1-1520 - syntmp-e2-1521) - (list '#(syntax-object - syntax-case - ((top) - #(ribcage - #(_ out in e1 e2) - #((top) (top) (top) (top) (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - syntmp-in-1519 - '() - (list syntmp-out-1518 - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(_ out in e1 e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (cons syntmp-e1-1520 - syntmp-e2-1521))))) - syntmp-tmp-1516) - ((lambda (syntmp-tmp-1523) - (if syntmp-tmp-1523 - (apply (lambda (syntmp-_-1524 - syntmp-out-1525 - syntmp-in-1526 - syntmp-e1-1527 - syntmp-e2-1528) - (list '#(syntax-object - syntax-case - ((top) - #(ribcage - #(_ out in e1 e2) - #((top) (top) (top) (top) (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - (cons '#(syntax-object - list - ((top) - #(ribcage - #(_ out in e1 e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - syntmp-in-1526) - '() - (list syntmp-out-1525 - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(_ out in e1 e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (cons syntmp-e1-1527 - syntmp-e2-1528))))) - syntmp-tmp-1523) - (syntax-error syntmp-tmp-1510))) - (syntax-dispatch - syntmp-tmp-1510 - '(any #(each (any any)) any . each-any))))) - (syntax-dispatch - syntmp-tmp-1510 - '(any ((any any)) any . each-any))))) - (syntax-dispatch - syntmp-tmp-1510 - '(any () any . each-any)))) - syntmp-x-1509))) -(install-global-transformer - 'syntax-rules - (lambda (syntmp-x-1550) - ((lambda (syntmp-tmp-1551) - ((lambda (syntmp-tmp-1552) - (if syntmp-tmp-1552 - (apply (lambda (syntmp-_-1553 - syntmp-k-1554 - syntmp-keyword-1555 - syntmp-pattern-1556 - syntmp-template-1557) - (list '#(syntax-object - lambda - ((top) - #(ribcage - #(_ k keyword pattern template) - #((top) (top) (top) (top) (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - '(#(syntax-object - x - ((top) - #(ribcage - #(_ k keyword pattern template) - #((top) (top) (top) (top) (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase))) - (cons '#(syntax-object - syntax-case - ((top) - #(ribcage - #(_ k keyword pattern template) - #((top) (top) (top) (top) (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - (cons '#(syntax-object - x - ((top) - #(ribcage - #(_ k keyword pattern template) - #((top) (top) (top) (top) (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - (cons syntmp-k-1554 - (map (lambda (syntmp-tmp-1560 - syntmp-tmp-1559) - (list (cons '#(syntax-object - dummy - ((top) - #(ribcage - #(_ - k - keyword - pattern - template) - #((top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-tmp-1559) - (list '#(syntax-object - syntax - ((top) - #(ribcage - #(_ - k - keyword - pattern - template) - #((top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-tmp-1560))) - syntmp-template-1557 - syntmp-pattern-1556)))))) - syntmp-tmp-1552) - (syntax-error syntmp-tmp-1551))) - (syntax-dispatch - syntmp-tmp-1551 - '(any each-any . #(each ((any . any) any)))))) - syntmp-x-1550))) -(install-global-transformer - 'let* - (lambda (syntmp-x-1571) - ((lambda (syntmp-tmp-1572) - ((lambda (syntmp-tmp-1573) - (if (if syntmp-tmp-1573 - (apply (lambda (syntmp-let*-1574 - syntmp-x-1575 - syntmp-v-1576 - syntmp-e1-1577 - syntmp-e2-1578) - (andmap identifier? syntmp-x-1575)) - syntmp-tmp-1573) - #f) - (apply (lambda (syntmp-let*-1580 - syntmp-x-1581 - syntmp-v-1582 - syntmp-e1-1583 - syntmp-e2-1584) - (let syntmp-f-1585 ((syntmp-bindings-1586 - (map list - syntmp-x-1581 - syntmp-v-1582))) - (if (null? syntmp-bindings-1586) - (cons '#(syntax-object - let - ((top) - #(ribcage () () ()) - #(ribcage - #(f bindings) - #((top) (top)) - #("i" "i")) - #(ribcage - #(let* x v e1 e2) - #((top) (top) (top) (top) (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - (cons '() - (cons syntmp-e1-1583 syntmp-e2-1584))) - ((lambda (syntmp-tmp-1590) - ((lambda (syntmp-tmp-1591) - (if syntmp-tmp-1591 - (apply (lambda (syntmp-body-1592 - syntmp-binding-1593) - (list '#(syntax-object - let - ((top) - #(ribcage - #(body binding) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(f bindings) - #((top) (top)) - #("i" "i")) - #(ribcage - #(let* x v e1 e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (list syntmp-binding-1593) - syntmp-body-1592)) - syntmp-tmp-1591) - (syntax-error syntmp-tmp-1590))) - (syntax-dispatch - syntmp-tmp-1590 - '(any any)))) - (list (syntmp-f-1585 (cdr syntmp-bindings-1586)) - (car syntmp-bindings-1586)))))) - syntmp-tmp-1573) - (syntax-error syntmp-tmp-1572))) - (syntax-dispatch - syntmp-tmp-1572 - '(any #(each (any any)) any . each-any)))) - syntmp-x-1571))) -(install-global-transformer - 'do - (lambda (syntmp-orig-x-1613) - ((lambda (syntmp-tmp-1614) - ((lambda (syntmp-tmp-1615) - (if syntmp-tmp-1615 - (apply (lambda (syntmp-_-1616 - syntmp-var-1617 - syntmp-init-1618 - syntmp-step-1619 - syntmp-e0-1620 - syntmp-e1-1621 - syntmp-c-1622) - ((lambda (syntmp-tmp-1623) - ((lambda (syntmp-tmp-1624) - (if syntmp-tmp-1624 - (apply (lambda (syntmp-step-1625) - ((lambda (syntmp-tmp-1626) - ((lambda (syntmp-tmp-1627) - (if syntmp-tmp-1627 - (apply (lambda () - (list '#(syntax-object - let - ((top) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - '#(syntax-object - doloop - ((top) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - (map list - syntmp-var-1617 - syntmp-init-1618) - (list '#(syntax-object - if - ((top) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - (list '#(syntax-object - not - ((top) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-e0-1620) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - (append - syntmp-c-1622 - (list (cons '#(syntax-object - doloop - ((top) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-step-1625))))))) - syntmp-tmp-1627) - ((lambda (syntmp-tmp-1632) - (if syntmp-tmp-1632 - (apply (lambda (syntmp-e1-1633 - syntmp-e2-1634) - (list '#(syntax-object - let - ((top) - #(ribcage - #(e1 - e2) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - '#(syntax-object - doloop - ((top) - #(ribcage - #(e1 - e2) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - (map list - syntmp-var-1617 - syntmp-init-1618) - (list '#(syntax-object - if - ((top) - #(ribcage - #(e1 - e2) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-e0-1620 - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(e1 - e2) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - (cons syntmp-e1-1633 - syntmp-e2-1634)) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(e1 - e2) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - (append - syntmp-c-1622 - (list (cons '#(syntax-object - doloop - ((top) - #(ribcage - #(e1 - e2) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(step) - #((top)) - #("i")) - #(ribcage - #(_ - var - init - step - e0 - e1 - c) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(orig-x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-step-1625))))))) - syntmp-tmp-1632) - (syntax-error - syntmp-tmp-1626))) - (syntax-dispatch - syntmp-tmp-1626 - '(any . each-any))))) - (syntax-dispatch - syntmp-tmp-1626 - '()))) - syntmp-e1-1621)) - syntmp-tmp-1624) - (syntax-error syntmp-tmp-1623))) - (syntax-dispatch - syntmp-tmp-1623 - 'each-any))) - (map (lambda (syntmp-v-1641 syntmp-s-1642) - ((lambda (syntmp-tmp-1643) - ((lambda (syntmp-tmp-1644) - (if syntmp-tmp-1644 - (apply (lambda () syntmp-v-1641) - syntmp-tmp-1644) - ((lambda (syntmp-tmp-1645) - (if syntmp-tmp-1645 - (apply (lambda (syntmp-e-1646) - syntmp-e-1646) - syntmp-tmp-1645) - ((lambda (syntmp-_-1647) - (syntax-error syntmp-orig-x-1613)) - syntmp-tmp-1643))) - (syntax-dispatch - syntmp-tmp-1643 - '(any))))) - (syntax-dispatch syntmp-tmp-1643 (quote ())))) - syntmp-s-1642)) - syntmp-var-1617 - syntmp-step-1619))) - syntmp-tmp-1615) - (syntax-error syntmp-tmp-1614))) - (syntax-dispatch - syntmp-tmp-1614 - '(any #(each (any any . any)) - (any . each-any) - . - each-any)))) - syntmp-orig-x-1613))) -(install-global-transformer - 'quasiquote - (letrec ((syntmp-quasicons-1675 - (lambda (syntmp-x-1679 syntmp-y-1680) - ((lambda (syntmp-tmp-1681) - ((lambda (syntmp-tmp-1682) - (if syntmp-tmp-1682 - (apply (lambda (syntmp-x-1683 syntmp-y-1684) - ((lambda (syntmp-tmp-1685) - ((lambda (syntmp-tmp-1686) - (if syntmp-tmp-1686 - (apply (lambda (syntmp-dy-1687) - ((lambda (syntmp-tmp-1688) - ((lambda (syntmp-tmp-1689) - (if syntmp-tmp-1689 - (apply (lambda (syntmp-dx-1690) - (list '#(syntax-object - quote - ((top) - #(ribcage - #(dx) - #((top)) - #("i")) - #(ribcage - #(dy) - #((top)) - #("i")) - #(ribcage - #(x - y) - #((top) - (top)) - #("i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x - y) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i"))) - (ice-9 syncase)) - (cons syntmp-dx-1690 - syntmp-dy-1687))) - syntmp-tmp-1689) - ((lambda (syntmp-_-1691) - (if (null? syntmp-dy-1687) - (list '#(syntax-object - list - ((top) - #(ribcage - #(_) - #((top)) - #("i")) - #(ribcage - #(dy) - #((top)) - #("i")) - #(ribcage - #(x - y) - #((top) - (top)) - #("i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x - y) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i"))) - (ice-9 syncase)) - syntmp-x-1683) - (list '#(syntax-object - cons - ((top) - #(ribcage - #(_) - #((top)) - #("i")) - #(ribcage - #(dy) - #((top)) - #("i")) - #(ribcage - #(x - y) - #((top) - (top)) - #("i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x - y) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i"))) - (ice-9 syncase)) - syntmp-x-1683 - syntmp-y-1684))) - syntmp-tmp-1688))) - (syntax-dispatch - syntmp-tmp-1688 - '(#(free-id - #(syntax-object - quote - ((top) - #(ribcage - #(dy) - #((top)) - #("i")) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i"))) - (ice-9 syncase))) - any)))) - syntmp-x-1683)) - syntmp-tmp-1686) - ((lambda (syntmp-tmp-1692) - (if syntmp-tmp-1692 - (apply (lambda (syntmp-stuff-1693) - (cons '#(syntax-object - list - ((top) - #(ribcage - #(stuff) - #((top)) - #("i")) - #(ribcage - #(x y) - #((top) - (top)) - #("i" "i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x y) - #((top) - (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i"))) - (ice-9 syncase)) - (cons syntmp-x-1683 - syntmp-stuff-1693))) - syntmp-tmp-1692) - ((lambda (syntmp-else-1694) - (list '#(syntax-object - cons - ((top) - #(ribcage - #(else) - #((top)) - #("i")) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i"))) - (ice-9 syncase)) - syntmp-x-1683 - syntmp-y-1684)) - syntmp-tmp-1685))) - (syntax-dispatch - syntmp-tmp-1685 - '(#(free-id - #(syntax-object - list - ((top) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - . - any))))) - (syntax-dispatch - syntmp-tmp-1685 - '(#(free-id - #(syntax-object - quote - ((top) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - any)))) - syntmp-y-1684)) - syntmp-tmp-1682) - (syntax-error syntmp-tmp-1681))) - (syntax-dispatch - syntmp-tmp-1681 - '(any any)))) - (list syntmp-x-1679 syntmp-y-1680)))) - (syntmp-quasiappend-1676 - (lambda (syntmp-x-1695 syntmp-y-1696) - ((lambda (syntmp-tmp-1697) - ((lambda (syntmp-tmp-1698) - (if syntmp-tmp-1698 - (apply (lambda (syntmp-x-1699 syntmp-y-1700) - ((lambda (syntmp-tmp-1701) - ((lambda (syntmp-tmp-1702) - (if syntmp-tmp-1702 - (apply (lambda () syntmp-x-1699) - syntmp-tmp-1702) - ((lambda (syntmp-_-1703) - (list '#(syntax-object - append - ((top) - #(ribcage - #(_) - #((top)) - #("i")) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - syntmp-x-1699 - syntmp-y-1700)) - syntmp-tmp-1701))) - (syntax-dispatch - syntmp-tmp-1701 - '(#(free-id - #(syntax-object - quote - ((top) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x y) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - ())))) - syntmp-y-1700)) - syntmp-tmp-1698) - (syntax-error syntmp-tmp-1697))) - (syntax-dispatch - syntmp-tmp-1697 - '(any any)))) - (list syntmp-x-1695 syntmp-y-1696)))) - (syntmp-quasivector-1677 - (lambda (syntmp-x-1704) - ((lambda (syntmp-tmp-1705) - ((lambda (syntmp-x-1706) - ((lambda (syntmp-tmp-1707) - ((lambda (syntmp-tmp-1708) - (if syntmp-tmp-1708 - (apply (lambda (syntmp-x-1709) - (list '#(syntax-object - quote - ((top) - #(ribcage #(x) #((top)) #("i")) - #(ribcage #(x) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - (list->vector syntmp-x-1709))) - syntmp-tmp-1708) - ((lambda (syntmp-tmp-1711) - (if syntmp-tmp-1711 - (apply (lambda (syntmp-x-1712) - (cons '#(syntax-object - vector - ((top) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - syntmp-x-1712)) - syntmp-tmp-1711) - ((lambda (syntmp-_-1714) - (list '#(syntax-object - list->vector - ((top) - #(ribcage #(_) #((top)) #("i")) - #(ribcage #(x) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - syntmp-x-1706)) - syntmp-tmp-1707))) - (syntax-dispatch - syntmp-tmp-1707 - '(#(free-id - #(syntax-object - list - ((top) - #(ribcage #(x) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - . - each-any))))) - (syntax-dispatch - syntmp-tmp-1707 - '(#(free-id - #(syntax-object - quote - ((top) - #(ribcage #(x) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i")) - #(ribcage - #(quasicons quasiappend quasivector quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - each-any)))) - syntmp-x-1706)) - syntmp-tmp-1705)) - syntmp-x-1704))) - (syntmp-quasi-1678 - (lambda (syntmp-p-1715 syntmp-lev-1716) - ((lambda (syntmp-tmp-1717) - ((lambda (syntmp-tmp-1718) - (if syntmp-tmp-1718 - (apply (lambda (syntmp-p-1719) - (if (= syntmp-lev-1716 0) - syntmp-p-1719 - (syntmp-quasicons-1675 - '(#(syntax-object - quote - ((top) - #(ribcage #(p) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - #(syntax-object - unquote - ((top) - #(ribcage #(p) #((top)) #("i")) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - (syntmp-quasi-1678 - (list syntmp-p-1719) - (- syntmp-lev-1716 1))))) - syntmp-tmp-1718) - ((lambda (syntmp-tmp-1720) - (if syntmp-tmp-1720 - (apply (lambda (syntmp-p-1721 syntmp-q-1722) - (if (= syntmp-lev-1716 0) - (syntmp-quasiappend-1676 - syntmp-p-1721 - (syntmp-quasi-1678 - syntmp-q-1722 - syntmp-lev-1716)) - (syntmp-quasicons-1675 - (syntmp-quasicons-1675 - '(#(syntax-object - quote - ((top) - #(ribcage - #(p q) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - #(syntax-object - unquote-splicing - ((top) - #(ribcage - #(p q) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - (syntmp-quasi-1678 - (list syntmp-p-1721) - (- syntmp-lev-1716 1))) - (syntmp-quasi-1678 - syntmp-q-1722 - syntmp-lev-1716)))) - syntmp-tmp-1720) - ((lambda (syntmp-tmp-1723) - (if syntmp-tmp-1723 - (apply (lambda (syntmp-p-1724) - (syntmp-quasicons-1675 - '(#(syntax-object - quote - ((top) - #(ribcage - #(p) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - #(syntax-object - quasiquote - ((top) - #(ribcage - #(p) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - (syntmp-quasi-1678 - (list syntmp-p-1724) - (+ syntmp-lev-1716 1)))) - syntmp-tmp-1723) - ((lambda (syntmp-tmp-1725) - (if syntmp-tmp-1725 - (apply (lambda (syntmp-p-1726 - syntmp-q-1727) - (syntmp-quasicons-1675 - (syntmp-quasi-1678 - syntmp-p-1726 - syntmp-lev-1716) - (syntmp-quasi-1678 - syntmp-q-1727 - syntmp-lev-1716))) - syntmp-tmp-1725) - ((lambda (syntmp-tmp-1728) - (if syntmp-tmp-1728 - (apply (lambda (syntmp-x-1729) - (syntmp-quasivector-1677 - (syntmp-quasi-1678 - syntmp-x-1729 - syntmp-lev-1716))) - syntmp-tmp-1728) - ((lambda (syntmp-p-1731) - (list '#(syntax-object - quote - ((top) - #(ribcage - #(p) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) - (top) - (top) - (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase)) - syntmp-p-1731)) - syntmp-tmp-1717))) - (syntax-dispatch - syntmp-tmp-1717 - '#(vector each-any))))) - (syntax-dispatch - syntmp-tmp-1717 - '(any . any))))) - (syntax-dispatch - syntmp-tmp-1717 - '(#(free-id - #(syntax-object - quasiquote - ((top) - #(ribcage () () ()) - #(ribcage - #(p lev) - #((top) (top)) - #("i" "i")) - #(ribcage - #(quasicons - quasiappend - quasivector - quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - any))))) - (syntax-dispatch - syntmp-tmp-1717 - '((#(free-id - #(syntax-object - unquote-splicing - ((top) - #(ribcage () () ()) - #(ribcage #(p lev) #((top) (top)) #("i" "i")) - #(ribcage - #(quasicons quasiappend quasivector quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - any) - . - any))))) - (syntax-dispatch - syntmp-tmp-1717 - '(#(free-id - #(syntax-object - unquote - ((top) - #(ribcage () () ()) - #(ribcage #(p lev) #((top) (top)) #("i" "i")) - #(ribcage - #(quasicons quasiappend quasivector quasi) - #((top) (top) (top) (top)) - #("i" "i" "i" "i"))) - (ice-9 syncase))) - any)))) - syntmp-p-1715)))) - (lambda (syntmp-x-1732) - ((lambda (syntmp-tmp-1733) - ((lambda (syntmp-tmp-1734) - (if syntmp-tmp-1734 - (apply (lambda (syntmp-_-1735 syntmp-e-1736) - (syntmp-quasi-1678 syntmp-e-1736 0)) - syntmp-tmp-1734) - (syntax-error syntmp-tmp-1733))) - (syntax-dispatch - syntmp-tmp-1733 - '(any any)))) - syntmp-x-1732)))) -(install-global-transformer - 'include - (lambda (syntmp-x-1796) - (letrec ((syntmp-read-file-1797 - (lambda (syntmp-fn-1798 syntmp-k-1799) - (let ((syntmp-p-1800 (open-input-file syntmp-fn-1798))) - (let syntmp-f-1801 ((syntmp-x-1802 (read syntmp-p-1800))) - (if (eof-object? syntmp-x-1802) - (begin - (close-input-port syntmp-p-1800) - '()) - (cons (datum->syntax-object - syntmp-k-1799 - syntmp-x-1802) - (syntmp-f-1801 (read syntmp-p-1800))))))))) - ((lambda (syntmp-tmp-1803) - ((lambda (syntmp-tmp-1804) - (if syntmp-tmp-1804 - (apply (lambda (syntmp-k-1805 syntmp-filename-1806) - (let ((syntmp-fn-1807 - (syntax-object->datum syntmp-filename-1806))) - ((lambda (syntmp-tmp-1808) - ((lambda (syntmp-tmp-1809) - (if syntmp-tmp-1809 - (apply (lambda (syntmp-exp-1810) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(exp) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(fn) - #((top)) - #("i")) - #(ribcage - #(k filename) - #((top) (top)) - #("i" "i")) - #(ribcage - (read-file) - ((top)) - ("i")) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-exp-1810)) - syntmp-tmp-1809) - (syntax-error syntmp-tmp-1808))) - (syntax-dispatch - syntmp-tmp-1808 - 'each-any))) - (syntmp-read-file-1797 - syntmp-fn-1807 - syntmp-k-1805)))) - syntmp-tmp-1804) - (syntax-error syntmp-tmp-1803))) - (syntax-dispatch - syntmp-tmp-1803 - '(any any)))) - syntmp-x-1796)))) -(install-global-transformer - 'unquote - (lambda (syntmp-x-1827) - ((lambda (syntmp-tmp-1828) - ((lambda (syntmp-tmp-1829) - (if syntmp-tmp-1829 - (apply (lambda (syntmp-_-1830 syntmp-e-1831) - (error 'unquote - "expression ,~s not valid outside of quasiquote" - (syntax-object->datum syntmp-e-1831))) - syntmp-tmp-1829) - (syntax-error syntmp-tmp-1828))) - (syntax-dispatch - syntmp-tmp-1828 - '(any any)))) - syntmp-x-1827))) -(install-global-transformer - 'unquote-splicing - (lambda (syntmp-x-1837) - ((lambda (syntmp-tmp-1838) - ((lambda (syntmp-tmp-1839) - (if syntmp-tmp-1839 - (apply (lambda (syntmp-_-1840 syntmp-e-1841) - (error 'unquote-splicing - "expression ,@~s not valid outside of quasiquote" - (syntax-object->datum syntmp-e-1841))) - syntmp-tmp-1839) - (syntax-error syntmp-tmp-1838))) - (syntax-dispatch - syntmp-tmp-1838 - '(any any)))) - syntmp-x-1837))) -(install-global-transformer - 'case - (lambda (syntmp-x-1847) - ((lambda (syntmp-tmp-1848) - ((lambda (syntmp-tmp-1849) - (if syntmp-tmp-1849 - (apply (lambda (syntmp-_-1850 - syntmp-e-1851 - syntmp-m1-1852 - syntmp-m2-1853) - ((lambda (syntmp-tmp-1854) - ((lambda (syntmp-body-1855) - (list '#(syntax-object - let - ((top) - #(ribcage #(body) #((top)) #("i")) - #(ribcage - #(_ e m1 m2) - #((top) (top) (top) (top)) - #("i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - (list (list '#(syntax-object - t - ((top) - #(ribcage - #(body) - #((top)) - #("i")) - #(ribcage - #(_ e m1 m2) - #((top) (top) (top) (top)) - #("i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-e-1851)) - syntmp-body-1855)) - syntmp-tmp-1854)) - (let syntmp-f-1856 ((syntmp-clause-1857 syntmp-m1-1852) - (syntmp-clauses-1858 syntmp-m2-1853)) - (if (null? syntmp-clauses-1858) - ((lambda (syntmp-tmp-1860) - ((lambda (syntmp-tmp-1861) - (if syntmp-tmp-1861 - (apply (lambda (syntmp-e1-1862 - syntmp-e2-1863) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(e1 e2) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(f clause clauses) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (cons syntmp-e1-1862 - syntmp-e2-1863))) - syntmp-tmp-1861) - ((lambda (syntmp-tmp-1865) - (if syntmp-tmp-1865 - (apply (lambda (syntmp-k-1866 - syntmp-e1-1867 - syntmp-e2-1868) - (list '#(syntax-object - if - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(f clause clauses) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (list '#(syntax-object - memv - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - '#(syntax-object - t - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (list '#(syntax-object - quote - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-k-1866)) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (cons syntmp-e1-1867 - syntmp-e2-1868)))) - syntmp-tmp-1865) - ((lambda (syntmp-_-1871) - (syntax-error syntmp-x-1847)) - syntmp-tmp-1860))) - (syntax-dispatch - syntmp-tmp-1860 - '(each-any any . each-any))))) - (syntax-dispatch - syntmp-tmp-1860 - '(#(free-id - #(syntax-object - else - ((top) - #(ribcage () () ()) - #(ribcage - #(f clause clauses) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage - #(_ e m1 m2) - #((top) (top) (top) (top)) - #("i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase))) - any - . - each-any)))) - syntmp-clause-1857) - ((lambda (syntmp-tmp-1872) - ((lambda (syntmp-rest-1873) - ((lambda (syntmp-tmp-1874) - ((lambda (syntmp-tmp-1875) - (if syntmp-tmp-1875 - (apply (lambda (syntmp-k-1876 - syntmp-e1-1877 - syntmp-e2-1878) - (list '#(syntax-object - if - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (list '#(syntax-object - memv - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - '#(syntax-object - t - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (list '#(syntax-object - quote - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-k-1876)) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(k e1 e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (cons syntmp-e1-1877 - syntmp-e2-1878)) - syntmp-rest-1873)) - syntmp-tmp-1875) - ((lambda (syntmp-_-1881) - (syntax-error syntmp-x-1847)) - syntmp-tmp-1874))) - (syntax-dispatch - syntmp-tmp-1874 - '(each-any any . each-any)))) - syntmp-clause-1857)) - syntmp-tmp-1872)) - (syntmp-f-1856 - (car syntmp-clauses-1858) - (cdr syntmp-clauses-1858))))))) - syntmp-tmp-1849) - (syntax-error syntmp-tmp-1848))) - (syntax-dispatch - syntmp-tmp-1848 - '(any any any . each-any)))) - syntmp-x-1847))) -(install-global-transformer - 'identifier-syntax - (lambda (syntmp-x-1911) - ((lambda (syntmp-tmp-1912) - ((lambda (syntmp-tmp-1913) - (if syntmp-tmp-1913 - (apply (lambda (syntmp-_-1914 syntmp-e-1915) - (list '#(syntax-object - lambda - ((top) - #(ribcage #(_ e) #((top) (top)) #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - '(#(syntax-object - x - ((top) - #(ribcage #(_ e) #((top) (top)) #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase))) - (list '#(syntax-object - syntax-case - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - '#(syntax-object - x - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - '() - (list '#(syntax-object - id - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - '(#(syntax-object - identifier? - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - (#(syntax-object - syntax - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)) - #(syntax-object - id - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i"))) - (ice-9 syncase)))) - (list '#(syntax-object - syntax - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - syntmp-e-1915)) - (list (cons syntmp-_-1914 - '(#(syntax-object - x - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - #(syntax-object - ... - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)))) - (list '#(syntax-object - syntax - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - (cons syntmp-e-1915 - '(#(syntax-object - x - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase)) - #(syntax-object - ... - ((top) - #(ribcage - #(_ e) - #((top) (top)) - #("i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (ice-9 syncase))))))))) - syntmp-tmp-1913) - (syntax-error syntmp-tmp-1912))) - (syntax-dispatch - syntmp-tmp-1912 - '(any any)))) - syntmp-x-1911))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-724) ((lambda (syntmp-tmp-725) (if syntmp-tmp-725 (apply (lambda (syntmp-_-726 syntmp-e1-727 syntmp-e2-728) (syntmp-chi-sequence-147 (cons syntmp-e1-727 syntmp-e2-728) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-725) (syntax-error syntmp-tmp-724))) (syntax-dispatch syntmp-tmp-724 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-730) ((lambda (syntmp-tmp-731) (if syntmp-tmp-731 (apply (lambda (syntmp-_-732 syntmp-x-733 syntmp-e1-734 syntmp-e2-735) (let ((syntmp-when-list-736 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-733 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-736) (syntmp-chi-sequence-147 (cons syntmp-e1-734 syntmp-e2-735) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-731) (syntax-error syntmp-tmp-730))) (syntax-dispatch syntmp-tmp-730 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722)))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-739 syntmp-r-740 syntmp-w-741 syntmp-mod-742) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-739 syntmp-r-740 syntmp-w-741 #f #f syntmp-mod-742)) (lambda (syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-w-746 syntmp-s-747 syntmp-mod-748) (syntmp-chi-expr-154 syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-r-740 syntmp-w-746 syntmp-s-747 syntmp-mod-748))))) (syntmp-chi-top-152 (lambda (syntmp-e-749 syntmp-r-750 syntmp-w-751 syntmp-m-752 syntmp-esew-753 syntmp-mod-754) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-749 syntmp-r-750 syntmp-w-751 #f #f syntmp-mod-754)) (lambda (syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-w-772 syntmp-s-773 syntmp-mod-774) (let ((syntmp-t-775 syntmp-type-769)) (if (memv syntmp-t-775 (quote (begin-form))) ((lambda (syntmp-tmp-776) ((lambda (syntmp-tmp-777) (if syntmp-tmp-777 (apply (lambda (syntmp-_-778) (syntmp-chi-void-161)) syntmp-tmp-777) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-e1-781 syntmp-e2-782) (syntmp-chi-top-sequence-148 (cons syntmp-e1-781 syntmp-e2-782) syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-m-752 syntmp-esew-753 syntmp-mod-774)) syntmp-tmp-779) (syntax-error syntmp-tmp-776))) (syntax-dispatch syntmp-tmp-776 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-776 (quote (any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774 (lambda (syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-mod-788) (syntmp-chi-top-sequence-148 syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-m-752 syntmp-esew-753 syntmp-mod-788))) (if (memv syntmp-t-775 (quote (eval-when-form))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-x-792 syntmp-e1-793 syntmp-e2-794) (let ((syntmp-when-list-795 (syntmp-chi-when-list-150 syntmp-e-771 syntmp-x-792 syntmp-w-772)) (syntmp-body-796 (cons syntmp-e1-793 syntmp-e2-794))) (cond ((eq? syntmp-m-752 (quote e)) (if (memq (quote eval) syntmp-when-list-795) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-795) (if (or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c&e) (quote (compile load)) syntmp-mod-774) (if (memq syntmp-m-752 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c) (quote (load)) syntmp-mod-774) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) syntmp-mod-774) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-790) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any each-any any . each-any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (define-syntax-form))) (let ((syntmp-n-799 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772)) (syntmp-r-800 (syntmp-macros-only-env-113 syntmp-r-750))) (let ((syntmp-t-801 syntmp-m-752)) (if (memv syntmp-t-801 (quote (c))) (if (memq (quote compile) syntmp-esew-753) (let ((syntmp-e-802 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-802 syntmp-mod-774) (if (memq (quote load) syntmp-esew-753) syntmp-e-802 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-753) (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) (syntmp-chi-void-161))) (if (memv syntmp-t-801 (quote (c&e))) (let ((syntmp-e-803 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-803 syntmp-mod-774) syntmp-e-803)) (begin (if (memq (quote eval) syntmp-esew-753) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) syntmp-mod-774)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-775 (quote (define-form))) (let ((syntmp-n-804 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772))) (let ((syntmp-type-805 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-804 syntmp-r-750 syntmp-mod-774)))) (let ((syntmp-t-806 syntmp-type-805)) (if (memv syntmp-t-806 (quote (global))) (let ((syntmp-x-807 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-807 syntmp-mod-774)) syntmp-x-807)) (if (memv syntmp-t-806 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "identifier out of context") (if (eq? syntmp-type-805 (quote external-macro)) (let ((syntmp-x-808 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-808 syntmp-mod-774)) syntmp-x-808)) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "cannot define keyword at top level"))))))) (let ((syntmp-x-809 (syntmp-chi-expr-154 syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-774)) syntmp-x-809)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (cond ((symbol? syntmp-e-810) (let ((syntmp-n-816 (syntmp-id-var-name-139 syntmp-e-810 syntmp-w-812))) (let ((syntmp-b-817 (syntmp-lookup-114 syntmp-n-816 syntmp-r-811 syntmp-mod-815))) (let ((syntmp-type-818 (syntmp-binding-type-109 syntmp-b-817))) (let ((syntmp-t-819 syntmp-type-818)) (if (memv syntmp-t-819 (quote (lexical))) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (global))) (values syntmp-type-818 syntmp-n-816 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))))))) ((pair? syntmp-e-810) (let ((syntmp-first-820 (car syntmp-e-810))) (if (syntmp-id?-117 syntmp-first-820) (let ((syntmp-n-821 (syntmp-id-var-name-139 syntmp-first-820 syntmp-w-812))) (let ((syntmp-b-822 (syntmp-lookup-114 syntmp-n-821 syntmp-r-811 (or (and (syntmp-syntax-object?-101 syntmp-first-820) (syntmp-syntax-object-module-104 syntmp-first-820)) syntmp-mod-815)))) (let ((syntmp-type-823 (syntmp-binding-type-109 syntmp-b-822))) (let ((syntmp-t-824 syntmp-type-823)) (if (memv syntmp-t-824 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (global))) (values (quote global-call) syntmp-n-821 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (if (memv syntmp-t-824 (quote (core external-macro))) (values syntmp-type-823 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (begin))) (values (quote begin-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (define))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-117 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-form) syntmp-name-831 syntmp-val-832 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-826) ((lambda (syntmp-tmp-833) (if (if syntmp-tmp-833 (apply (lambda (syntmp-_-834 syntmp-name-835 syntmp-args-836 syntmp-e1-837 syntmp-e2-838) (and (syntmp-id?-117 syntmp-name-835) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-836)))) syntmp-tmp-833) #f) (apply (lambda (syntmp-_-839 syntmp-name-840 syntmp-args-841 syntmp-e1-842 syntmp-e2-843) (values (quote define-form) (syntmp-wrap-145 syntmp-name-840 syntmp-w-812 syntmp-mod-815) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-841 (cons syntmp-e1-842 syntmp-e2-843)) syntmp-w-812 syntmp-mod-815)) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-833) ((lambda (syntmp-tmp-845) (if (if syntmp-tmp-845 (apply (lambda (syntmp-_-846 syntmp-name-847) (syntmp-id?-117 syntmp-name-847)) syntmp-tmp-845) #f) (apply (lambda (syntmp-_-848 syntmp-name-849) (values (quote define-form) (syntmp-wrap-145 syntmp-name-849 syntmp-w-812 syntmp-mod-815) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-845) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-810) (if (memv syntmp-t-824 (quote (define-syntax))) ((lambda (syntmp-tmp-850) ((lambda (syntmp-tmp-851) (if (if syntmp-tmp-851 (apply (lambda (syntmp-_-852 syntmp-name-853 syntmp-val-854) (syntmp-id?-117 syntmp-name-853)) syntmp-tmp-851) #f) (apply (lambda (syntmp-_-855 syntmp-name-856 syntmp-val-857) (values (quote define-syntax-form) syntmp-name-856 syntmp-val-857 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-851) (syntax-error syntmp-tmp-850))) (syntax-dispatch syntmp-tmp-850 (quote (any any any))))) syntmp-e-810) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))))))))))))) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))) ((syntmp-syntax-object?-101 syntmp-e-810) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-810) syntmp-r-811 (syntmp-join-wraps-136 syntmp-w-812 (syntmp-syntax-object-wrap-103 syntmp-e-810)) #f syntmp-rib-814 (or (syntmp-syntax-object-module-104 syntmp-e-810) syntmp-mod-815))) ((annotation? syntmp-e-810) (syntmp-syntax-type-151 (annotation-expression syntmp-e-810) syntmp-r-811 syntmp-w-812 (annotation-source syntmp-e-810) syntmp-rib-814 syntmp-mod-815)) ((self-evaluating? syntmp-e-810) (values (quote constant) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) (else (values (quote other) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-858 syntmp-when-list-859 syntmp-w-860) (let syntmp-f-861 ((syntmp-when-list-862 syntmp-when-list-859) (syntmp-situations-863 (quote ()))) (if (null? syntmp-when-list-862) syntmp-situations-863 (syntmp-f-861 (cdr syntmp-when-list-862) (cons (let ((syntmp-x-864 (car syntmp-when-list-862))) (cond ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-864 syntmp-w-860 #f) "invalid eval-when situation")))) syntmp-situations-863)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-869 syntmp-e-870) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-869) syntmp-e-870)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873 syntmp-s-874 syntmp-m-875 syntmp-esew-876 syntmp-mod-877) (syntmp-build-sequence-96 syntmp-s-874 (let syntmp-dobody-878 ((syntmp-body-879 syntmp-body-871) (syntmp-r-880 syntmp-r-872) (syntmp-w-881 syntmp-w-873) (syntmp-m-882 syntmp-m-875) (syntmp-esew-883 syntmp-esew-876) (syntmp-mod-884 syntmp-mod-877)) (if (null? syntmp-body-879) (quote ()) (let ((syntmp-first-885 (syntmp-chi-top-152 (car syntmp-body-879) syntmp-r-880 syntmp-w-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884))) (cons syntmp-first-885 (syntmp-dobody-878 (cdr syntmp-body-879) syntmp-r-880 syntmp-w-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-886 syntmp-r-887 syntmp-w-888 syntmp-s-889 syntmp-mod-890) (syntmp-build-sequence-96 syntmp-s-889 (let syntmp-dobody-891 ((syntmp-body-892 syntmp-body-886) (syntmp-r-893 syntmp-r-887) (syntmp-w-894 syntmp-w-888) (syntmp-mod-895 syntmp-mod-890)) (if (null? syntmp-body-892) (quote ()) (let ((syntmp-first-896 (syntmp-chi-153 (car syntmp-body-892) syntmp-r-893 syntmp-w-894 syntmp-mod-895))) (cons syntmp-first-896 (syntmp-dobody-891 (cdr syntmp-body-892) syntmp-r-893 syntmp-w-894 syntmp-mod-895)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-897 syntmp-w-898 syntmp-s-899 syntmp-defmod-900) (syntmp-wrap-145 (if syntmp-s-899 (make-annotation syntmp-x-897 syntmp-s-899 #f) syntmp-x-897) syntmp-w-898 syntmp-defmod-900))) (syntmp-wrap-145 (lambda (syntmp-x-901 syntmp-w-902 syntmp-defmod-903) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-902)) (null? (syntmp-wrap-subst-121 syntmp-w-902))) syntmp-x-901) ((syntmp-syntax-object?-101 syntmp-x-901) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-901) (syntmp-join-wraps-136 syntmp-w-902 (syntmp-syntax-object-wrap-103 syntmp-x-901)) (syntmp-syntax-object-module-104 syntmp-x-901))) ((null? syntmp-x-901) syntmp-x-901) (else (syntmp-make-syntax-object-100 syntmp-x-901 syntmp-w-902 syntmp-defmod-903))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-904 syntmp-list-905) (and (not (null? syntmp-list-905)) (or (syntmp-bound-id=?-141 syntmp-x-904 (car syntmp-list-905)) (syntmp-bound-id-member?-144 syntmp-x-904 (cdr syntmp-list-905)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-906) (let syntmp-distinct?-907 ((syntmp-ids-908 syntmp-ids-906)) (or (null? syntmp-ids-908) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-908) (cdr syntmp-ids-908))) (syntmp-distinct?-907 (cdr syntmp-ids-908))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-909) (and (let syntmp-all-ids?-910 ((syntmp-ids-911 syntmp-ids-909)) (or (null? syntmp-ids-911) (and (syntmp-id?-117 (car syntmp-ids-911)) (syntmp-all-ids?-910 (cdr syntmp-ids-911))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-909)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-912 syntmp-j-913) (if (and (syntmp-syntax-object?-101 syntmp-i-912) (syntmp-syntax-object?-101 syntmp-j-913)) (and (eq? (let ((syntmp-e-914 (syntmp-syntax-object-expression-102 syntmp-i-912))) (if (annotation? syntmp-e-914) (annotation-expression syntmp-e-914) syntmp-e-914)) (let ((syntmp-e-915 (syntmp-syntax-object-expression-102 syntmp-j-913))) (if (annotation? syntmp-e-915) (annotation-expression syntmp-e-915) syntmp-e-915))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-912)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-913)))) (eq? (let ((syntmp-e-916 syntmp-i-912)) (if (annotation? syntmp-e-916) (annotation-expression syntmp-e-916) syntmp-e-916)) (let ((syntmp-e-917 syntmp-j-913)) (if (annotation? syntmp-e-917) (annotation-expression syntmp-e-917) syntmp-e-917)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-918 syntmp-j-919) (and (eq? (let ((syntmp-x-920 syntmp-i-918)) (let ((syntmp-e-921 (if (syntmp-syntax-object?-101 syntmp-x-920) (syntmp-syntax-object-expression-102 syntmp-x-920) syntmp-x-920))) (if (annotation? syntmp-e-921) (annotation-expression syntmp-e-921) syntmp-e-921))) (let ((syntmp-x-922 syntmp-j-919)) (let ((syntmp-e-923 (if (syntmp-syntax-object?-101 syntmp-x-922) (syntmp-syntax-object-expression-102 syntmp-x-922) syntmp-x-922))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)))) (eq? (syntmp-id-var-name-139 syntmp-i-918 (quote (()))) (syntmp-id-var-name-139 syntmp-j-919 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-924 syntmp-w-925) (letrec ((syntmp-search-vector-rib-928 (lambda (syntmp-sym-939 syntmp-subst-940 syntmp-marks-941 syntmp-symnames-942 syntmp-ribcage-943) (let ((syntmp-n-944 (vector-length syntmp-symnames-942))) (let syntmp-f-945 ((syntmp-i-946 0)) (cond ((syntmp-fx=-87 syntmp-i-946 syntmp-n-944) (syntmp-search-926 syntmp-sym-939 (cdr syntmp-subst-940) syntmp-marks-941)) ((and (eq? (vector-ref syntmp-symnames-942 syntmp-i-946) syntmp-sym-939) (syntmp-same-marks?-138 syntmp-marks-941 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-943) syntmp-i-946))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-943) syntmp-i-946) syntmp-marks-941)) (else (syntmp-f-945 (syntmp-fx+-85 syntmp-i-946 1)))))))) (syntmp-search-list-rib-927 (lambda (syntmp-sym-947 syntmp-subst-948 syntmp-marks-949 syntmp-symnames-950 syntmp-ribcage-951) (let syntmp-f-952 ((syntmp-symnames-953 syntmp-symnames-950) (syntmp-i-954 0)) (cond ((null? syntmp-symnames-953) (syntmp-search-926 syntmp-sym-947 (cdr syntmp-subst-948) syntmp-marks-949)) ((and (eq? (car syntmp-symnames-953) syntmp-sym-947) (syntmp-same-marks?-138 syntmp-marks-949 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-951) syntmp-i-954))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-951) syntmp-i-954) syntmp-marks-949)) (else (syntmp-f-952 (cdr syntmp-symnames-953) (syntmp-fx+-85 syntmp-i-954 1))))))) (syntmp-search-926 (lambda (syntmp-sym-955 syntmp-subst-956 syntmp-marks-957) (if (null? syntmp-subst-956) (values #f syntmp-marks-957) (let ((syntmp-fst-958 (car syntmp-subst-956))) (if (eq? syntmp-fst-958 (quote shift)) (syntmp-search-926 syntmp-sym-955 (cdr syntmp-subst-956) (cdr syntmp-marks-957)) (let ((syntmp-symnames-959 (syntmp-ribcage-symnames-126 syntmp-fst-958))) (if (vector? syntmp-symnames-959) (syntmp-search-vector-rib-928 syntmp-sym-955 syntmp-subst-956 syntmp-marks-957 syntmp-symnames-959 syntmp-fst-958) (syntmp-search-list-rib-927 syntmp-sym-955 syntmp-subst-956 syntmp-marks-957 syntmp-symnames-959 syntmp-fst-958))))))))) (cond ((symbol? syntmp-id-924) (or (call-with-values (lambda () (syntmp-search-926 syntmp-id-924 (syntmp-wrap-subst-121 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w-925))) (lambda (syntmp-x-961 . syntmp-ignore-960) syntmp-x-961)) syntmp-id-924)) ((syntmp-syntax-object?-101 syntmp-id-924) (let ((syntmp-id-962 (let ((syntmp-e-964 (syntmp-syntax-object-expression-102 syntmp-id-924))) (if (annotation? syntmp-e-964) (annotation-expression syntmp-e-964) syntmp-e-964))) (syntmp-w1-963 (syntmp-syntax-object-wrap-103 syntmp-id-924))) (let ((syntmp-marks-965 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w1-963)))) (call-with-values (lambda () (syntmp-search-926 syntmp-id-962 (syntmp-wrap-subst-121 syntmp-w-925) syntmp-marks-965)) (lambda (syntmp-new-id-966 syntmp-marks-967) (or syntmp-new-id-966 (call-with-values (lambda () (syntmp-search-926 syntmp-id-962 (syntmp-wrap-subst-121 syntmp-w1-963) syntmp-marks-967)) (lambda (syntmp-x-969 . syntmp-ignore-968) syntmp-x-969)) syntmp-id-962)))))) ((annotation? syntmp-id-924) (let ((syntmp-id-970 (let ((syntmp-e-971 syntmp-id-924)) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971)))) (or (call-with-values (lambda () (syntmp-search-926 syntmp-id-970 (syntmp-wrap-subst-121 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w-925))) (lambda (syntmp-x-973 . syntmp-ignore-972) syntmp-x-973)) syntmp-id-970))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-924)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-974 syntmp-y-975) (or (eq? syntmp-x-974 syntmp-y-975) (and (not (null? syntmp-x-974)) (not (null? syntmp-y-975)) (eq? (car syntmp-x-974) (car syntmp-y-975)) (syntmp-same-marks?-138 (cdr syntmp-x-974) (cdr syntmp-y-975)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-976 syntmp-m2-977) (syntmp-smart-append-135 syntmp-m1-976 syntmp-m2-977))) (syntmp-join-wraps-136 (lambda (syntmp-w1-978 syntmp-w2-979) (let ((syntmp-m1-980 (syntmp-wrap-marks-120 syntmp-w1-978)) (syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w1-978))) (if (null? syntmp-m1-980) (if (null? syntmp-s1-981) syntmp-w2-979 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-979) (syntmp-smart-append-135 syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w2-979)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-980 (syntmp-wrap-marks-120 syntmp-w2-979)) (syntmp-smart-append-135 syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w2-979))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-982 syntmp-m2-983) (if (null? syntmp-m2-983) syntmp-m1-982 (append syntmp-m1-982 syntmp-m2-983)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-984 syntmp-labels-985 syntmp-w-986) (if (null? syntmp-ids-984) syntmp-w-986 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-986) (cons (let ((syntmp-labelvec-987 (list->vector syntmp-labels-985))) (let ((syntmp-n-988 (vector-length syntmp-labelvec-987))) (let ((syntmp-symnamevec-989 (make-vector syntmp-n-988)) (syntmp-marksvec-990 (make-vector syntmp-n-988))) (begin (let syntmp-f-991 ((syntmp-ids-992 syntmp-ids-984) (syntmp-i-993 0)) (if (not (null? syntmp-ids-992)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-992) syntmp-w-986)) (lambda (syntmp-symname-994 syntmp-marks-995) (begin (vector-set! syntmp-symnamevec-989 syntmp-i-993 syntmp-symname-994) (vector-set! syntmp-marksvec-990 syntmp-i-993 syntmp-marks-995) (syntmp-f-991 (cdr syntmp-ids-992) (syntmp-fx+-85 syntmp-i-993 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-989 syntmp-marksvec-990 syntmp-labelvec-987))))) (syntmp-wrap-subst-121 syntmp-w-986)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-996 syntmp-id-997 syntmp-label-998) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-996 (cons (let ((syntmp-e-999 (syntmp-syntax-object-expression-102 syntmp-id-997))) (if (annotation? syntmp-e-999) (annotation-expression syntmp-e-999) syntmp-e-999)) (syntmp-ribcage-symnames-126 syntmp-ribcage-996))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-996 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-997)) (syntmp-ribcage-marks-127 syntmp-ribcage-996))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-996 (cons syntmp-label-998 (syntmp-ribcage-labels-128 syntmp-ribcage-996)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1000) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1000)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1000))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1001 syntmp-update-1002) (vector-set! syntmp-x-1001 3 syntmp-update-1002))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1003 syntmp-update-1004) (vector-set! syntmp-x-1003 2 syntmp-update-1004))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1005 syntmp-update-1006) (vector-set! syntmp-x-1005 1 syntmp-update-1006))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1007) (vector-ref syntmp-x-1007 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1008) (vector-ref syntmp-x-1008 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1009) (vector-ref syntmp-x-1009 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1010) (and (vector? syntmp-x-1010) (= (vector-length syntmp-x-1010) 4) (eq? (vector-ref syntmp-x-1010 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1011 syntmp-marks-1012 syntmp-labels-1013) (vector (quote ribcage) syntmp-symnames-1011 syntmp-marks-1012 syntmp-labels-1013))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1014) (if (null? syntmp-ls-1014) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1014)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1015 syntmp-w-1016) (if (syntmp-syntax-object?-101 syntmp-x-1015) (values (let ((syntmp-e-1017 (syntmp-syntax-object-expression-102 syntmp-x-1015))) (if (annotation? syntmp-e-1017) (annotation-expression syntmp-e-1017) syntmp-e-1017)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1016) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1015)))) (values (let ((syntmp-e-1018 syntmp-x-1015)) (if (annotation? syntmp-e-1018) (annotation-expression syntmp-e-1018) syntmp-e-1018)) (syntmp-wrap-marks-120 syntmp-w-1016))))) (syntmp-id?-117 (lambda (syntmp-x-1019) (cond ((symbol? syntmp-x-1019) #t) ((syntmp-syntax-object?-101 syntmp-x-1019) (symbol? (let ((syntmp-e-1020 (syntmp-syntax-object-expression-102 syntmp-x-1019))) (if (annotation? syntmp-e-1020) (annotation-expression syntmp-e-1020) syntmp-e-1020)))) ((annotation? syntmp-x-1019) (symbol? (annotation-expression syntmp-x-1019))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1021) (and (syntmp-syntax-object?-101 syntmp-x-1021) (symbol? (let ((syntmp-e-1022 (syntmp-syntax-object-expression-102 syntmp-x-1021))) (if (annotation? syntmp-e-1022) (annotation-expression syntmp-e-1022) syntmp-e-1022)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1023 syntmp-sym-1024 syntmp-val-1025) (syntmp-put-global-definition-hook-92 syntmp-sym-1024 (cons syntmp-type-1023 syntmp-val-1025) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1026 syntmp-r-1027 syntmp-mod-1028) (cond ((assq syntmp-x-1026 syntmp-r-1027) => cdr) ((symbol? syntmp-x-1026) (or (syntmp-get-global-definition-hook-93 syntmp-x-1026 syntmp-mod-1028) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1029) (if (null? syntmp-r-1029) (quote ()) (let ((syntmp-a-1030 (car syntmp-r-1029))) (if (eq? (cadr syntmp-a-1030) (quote macro)) (cons syntmp-a-1030 (syntmp-macros-only-env-113 (cdr syntmp-r-1029))) (syntmp-macros-only-env-113 (cdr syntmp-r-1029))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1031 syntmp-vars-1032 syntmp-r-1033) (if (null? syntmp-labels-1031) syntmp-r-1033 (syntmp-extend-var-env-112 (cdr syntmp-labels-1031) (cdr syntmp-vars-1032) (cons (cons (car syntmp-labels-1031) (cons (quote lexical) (car syntmp-vars-1032))) syntmp-r-1033))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1034 syntmp-bindings-1035 syntmp-r-1036) (if (null? syntmp-labels-1034) syntmp-r-1036 (syntmp-extend-env-111 (cdr syntmp-labels-1034) (cdr syntmp-bindings-1035) (cons (cons (car syntmp-labels-1034) (car syntmp-bindings-1035)) syntmp-r-1036))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1037) (cond ((annotation? syntmp-x-1037) (annotation-source syntmp-x-1037)) ((syntmp-syntax-object?-101 syntmp-x-1037) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1037))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1038 syntmp-update-1039) (vector-set! syntmp-x-1038 3 syntmp-update-1039))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1040 syntmp-update-1041) (vector-set! syntmp-x-1040 2 syntmp-update-1041))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1042 syntmp-update-1043) (vector-set! syntmp-x-1042 1 syntmp-update-1043))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1044) (vector-ref syntmp-x-1044 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1045) (vector-ref syntmp-x-1045 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1046) (vector-ref syntmp-x-1046 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1047) (and (vector? syntmp-x-1047) (= (vector-length syntmp-x-1047) 4) (eq? (vector-ref syntmp-x-1047 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1048 syntmp-wrap-1049 syntmp-module-1050) (vector (quote syntax-object) syntmp-expression-1048 syntmp-wrap-1049 syntmp-module-1050))) (syntmp-build-letrec-99 (lambda (syntmp-src-1051 syntmp-vars-1052 syntmp-val-exps-1053 syntmp-body-exp-1054) (if (null? syntmp-vars-1052) (syntmp-build-annotated-94 syntmp-src-1051 syntmp-body-exp-1054) (syntmp-build-annotated-94 syntmp-src-1051 (list (quote letrec) (map list syntmp-vars-1052 syntmp-val-exps-1053) syntmp-body-exp-1054))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1055 syntmp-vars-1056 syntmp-val-exps-1057 syntmp-body-exp-1058) (if (null? syntmp-vars-1056) (syntmp-build-annotated-94 syntmp-src-1055 syntmp-body-exp-1058) (syntmp-build-annotated-94 syntmp-src-1055 (list (quote let) (car syntmp-vars-1056) (map list (cdr syntmp-vars-1056) syntmp-val-exps-1057) syntmp-body-exp-1058))))) (syntmp-build-let-97 (lambda (syntmp-src-1059 syntmp-vars-1060 syntmp-val-exps-1061 syntmp-body-exp-1062) (if (null? syntmp-vars-1060) (syntmp-build-annotated-94 syntmp-src-1059 syntmp-body-exp-1062) (syntmp-build-annotated-94 syntmp-src-1059 (list (quote let) (map list syntmp-vars-1060 syntmp-val-exps-1061) syntmp-body-exp-1062))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1063 syntmp-exps-1064) (if (null? (cdr syntmp-exps-1064)) (syntmp-build-annotated-94 syntmp-src-1063 (car syntmp-exps-1064)) (syntmp-build-annotated-94 syntmp-src-1063 (cons (quote begin) syntmp-exps-1064))))) (syntmp-build-data-95 (lambda (syntmp-src-1065 syntmp-exp-1066) (if (and (self-evaluating? syntmp-exp-1066) (not (vector? syntmp-exp-1066))) (syntmp-build-annotated-94 syntmp-src-1065 syntmp-exp-1066) (syntmp-build-annotated-94 syntmp-src-1065 (list (quote quote) syntmp-exp-1066))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1067 syntmp-exp-1068) (if (and syntmp-src-1067 (not (annotation? syntmp-exp-1068))) (make-annotation syntmp-exp-1068 syntmp-src-1067 #t) syntmp-exp-1068))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1069 syntmp-module-1070) (let ((syntmp-module-1071 (if syntmp-module-1070 (resolve-module syntmp-module-1070) (warn "wha" syntmp-symbol-1069 (current-module))))) (let ((syntmp-v-1072 (module-variable syntmp-module-1071 syntmp-symbol-1069))) (and syntmp-v-1072 (or (object-property syntmp-v-1072 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1072) (macro? (variable-ref syntmp-v-1072)) (macro-transformer (variable-ref syntmp-v-1072)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1073 syntmp-binding-1074 syntmp-module-1075) (let ((syntmp-module-1076 (if syntmp-module-1075 (resolve-module syntmp-module-1075) (warn "wha" syntmp-symbol-1073 (current-module))))) (let ((syntmp-v-1077 (or (module-variable syntmp-module-1076 syntmp-symbol-1073) (let ((syntmp-v-1078 (make-variable sc-macro))) (begin (module-add! syntmp-module-1076 syntmp-symbol-1073 syntmp-v-1078) syntmp-v-1078))))) (begin (if (not (and (symbol-property syntmp-symbol-1073 (quote primitive-syntax)) (eq? syntmp-module-1076 the-syncase-module))) (variable-set! syntmp-v-1077 sc-macro)) (set-object-property! syntmp-v-1077 (quote *sc-expander*) syntmp-binding-1074)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1079 syntmp-why-1080 syntmp-what-1081) (error syntmp-who-1079 "~a ~s" syntmp-why-1080 syntmp-what-1081))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1082 syntmp-mod-1083) (eval (list syntmp-noexpand-84 syntmp-x-1082) (if syntmp-mod-1083 (resolve-module syntmp-mod-1083) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1084 syntmp-mod-1085) (eval (list syntmp-noexpand-84 syntmp-x-1084) (if syntmp-mod-1085 (resolve-module syntmp-mod-1085) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1086 syntmp-r-1087 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) ((lambda (syntmp-tmp-1091) ((lambda (syntmp-tmp-1092) (if (if syntmp-tmp-1092 (apply (lambda (syntmp-_-1093 syntmp-var-1094 syntmp-val-1095 syntmp-e1-1096 syntmp-e2-1097) (syntmp-valid-bound-ids?-142 syntmp-var-1094)) syntmp-tmp-1092) #f) (apply (lambda (syntmp-_-1099 syntmp-var-1100 syntmp-val-1101 syntmp-e1-1102 syntmp-e2-1103) (let ((syntmp-names-1104 (map (lambda (syntmp-x-1105) (syntmp-id-var-name-139 syntmp-x-1105 syntmp-w-1088)) syntmp-var-1100))) (begin (for-each (lambda (syntmp-id-1107 syntmp-n-1108) (let ((syntmp-t-1109 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1108 syntmp-r-1087 syntmp-mod-1090)))) (if (memv syntmp-t-1109 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1107 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) "identifier out of context")))) syntmp-var-1100 syntmp-names-1104) (syntmp-chi-body-157 (cons syntmp-e1-1102 syntmp-e2-1103) (syntmp-source-wrap-146 syntmp-e-1086 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) (syntmp-extend-env-111 syntmp-names-1104 (let ((syntmp-trans-r-1112 (syntmp-macros-only-env-113 syntmp-r-1087))) (map (lambda (syntmp-x-1113) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1113 syntmp-trans-r-1112 syntmp-w-1088 syntmp-mod-1090) syntmp-mod-1090))) syntmp-val-1101)) syntmp-r-1087) syntmp-w-1088 syntmp-mod-1090)))) syntmp-tmp-1092) ((lambda (syntmp-_-1115) (syntax-error (syntmp-source-wrap-146 syntmp-e-1086 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090))) syntmp-tmp-1091))) (syntax-dispatch syntmp-tmp-1091 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1086))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1116 syntmp-r-1117 syntmp-w-1118 syntmp-s-1119 syntmp-mod-1120) ((lambda (syntmp-tmp-1121) ((lambda (syntmp-tmp-1122) (if syntmp-tmp-1122 (apply (lambda (syntmp-_-1123 syntmp-e-1124) (syntmp-build-data-95 syntmp-s-1119 (syntmp-strip-164 syntmp-e-1124 syntmp-w-1118))) syntmp-tmp-1122) ((lambda (syntmp-_-1125) (syntax-error (syntmp-source-wrap-146 syntmp-e-1116 syntmp-w-1118 syntmp-s-1119 syntmp-mod-1120))) syntmp-tmp-1121))) (syntax-dispatch syntmp-tmp-1121 (quote (any any))))) syntmp-e-1116))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1133 (lambda (syntmp-x-1134) (let ((syntmp-t-1135 (car syntmp-x-1134))) (if (memv syntmp-t-1135 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1134) (syntmp-regen-1133 (caddr syntmp-x-1134)))) (if (memv syntmp-t-1135 (quote (map))) (let ((syntmp-ls-1136 (map syntmp-regen-1133 (cdr syntmp-x-1134)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1136) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1136))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1134)) (map syntmp-regen-1133 (cdr syntmp-x-1134)))))))))))) (syntmp-gen-vector-1132 (lambda (syntmp-x-1137) (cond ((eq? (car syntmp-x-1137) (quote list)) (cons (quote vector) (cdr syntmp-x-1137))) ((eq? (car syntmp-x-1137) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1137)))) (else (list (quote list->vector) syntmp-x-1137))))) (syntmp-gen-append-1131 (lambda (syntmp-x-1138 syntmp-y-1139) (if (equal? syntmp-y-1139 (quote (quote ()))) syntmp-x-1138 (list (quote append) syntmp-x-1138 syntmp-y-1139)))) (syntmp-gen-cons-1130 (lambda (syntmp-x-1140 syntmp-y-1141) (let ((syntmp-t-1142 (car syntmp-y-1141))) (if (memv syntmp-t-1142 (quote (quote))) (if (eq? (car syntmp-x-1140) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1140) (cadr syntmp-y-1141))) (if (eq? (cadr syntmp-y-1141) (quote ())) (list (quote list) syntmp-x-1140) (list (quote cons) syntmp-x-1140 syntmp-y-1141))) (if (memv syntmp-t-1142 (quote (list))) (cons (quote list) (cons syntmp-x-1140 (cdr syntmp-y-1141))) (list (quote cons) syntmp-x-1140 syntmp-y-1141)))))) (syntmp-gen-map-1129 (lambda (syntmp-e-1143 syntmp-map-env-1144) (let ((syntmp-formals-1145 (map cdr syntmp-map-env-1144)) (syntmp-actuals-1146 (map (lambda (syntmp-x-1147) (list (quote ref) (car syntmp-x-1147))) syntmp-map-env-1144))) (cond ((eq? (car syntmp-e-1143) (quote ref)) (car syntmp-actuals-1146)) ((andmap (lambda (syntmp-x-1148) (and (eq? (car syntmp-x-1148) (quote ref)) (memq (cadr syntmp-x-1148) syntmp-formals-1145))) (cdr syntmp-e-1143)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1143)) (map (let ((syntmp-r-1149 (map cons syntmp-formals-1145 syntmp-actuals-1146))) (lambda (syntmp-x-1150) (cdr (assq (cadr syntmp-x-1150) syntmp-r-1149)))) (cdr syntmp-e-1143))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1145 syntmp-e-1143) syntmp-actuals-1146))))))) (syntmp-gen-mappend-1128 (lambda (syntmp-e-1151 syntmp-map-env-1152) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1129 syntmp-e-1151 syntmp-map-env-1152)))) (syntmp-gen-ref-1127 (lambda (syntmp-src-1153 syntmp-var-1154 syntmp-level-1155 syntmp-maps-1156) (if (syntmp-fx=-87 syntmp-level-1155 0) (values syntmp-var-1154 syntmp-maps-1156) (if (null? syntmp-maps-1156) (syntax-error syntmp-src-1153 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1127 syntmp-src-1153 syntmp-var-1154 (syntmp-fx--86 syntmp-level-1155 1) (cdr syntmp-maps-1156))) (lambda (syntmp-outer-var-1157 syntmp-outer-maps-1158) (let ((syntmp-b-1159 (assq syntmp-outer-var-1157 (car syntmp-maps-1156)))) (if syntmp-b-1159 (values (cdr syntmp-b-1159) syntmp-maps-1156) (let ((syntmp-inner-var-1160 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1160 (cons (cons (cons syntmp-outer-var-1157 syntmp-inner-var-1160) (car syntmp-maps-1156)) syntmp-outer-maps-1158))))))))))) (syntmp-gen-syntax-1126 (lambda (syntmp-src-1161 syntmp-e-1162 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166) (if (syntmp-id?-117 syntmp-e-1162) (let ((syntmp-label-1167 (syntmp-id-var-name-139 syntmp-e-1162 (quote (()))))) (let ((syntmp-b-1168 (syntmp-lookup-114 syntmp-label-1167 syntmp-r-1163 syntmp-mod-1166))) (if (eq? (syntmp-binding-type-109 syntmp-b-1168) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1169 (syntmp-binding-value-110 syntmp-b-1168))) (syntmp-gen-ref-1127 syntmp-src-1161 (car syntmp-var.lev-1169) (cdr syntmp-var.lev-1169) syntmp-maps-1164))) (lambda (syntmp-var-1170 syntmp-maps-1171) (values (list (quote ref) syntmp-var-1170) syntmp-maps-1171))) (if (syntmp-ellipsis?-1165 syntmp-e-1162) (syntax-error syntmp-src-1161 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1162) syntmp-maps-1164))))) ((lambda (syntmp-tmp-1172) ((lambda (syntmp-tmp-1173) (if (if syntmp-tmp-1173 (apply (lambda (syntmp-dots-1174 syntmp-e-1175) (syntmp-ellipsis?-1165 syntmp-dots-1174)) syntmp-tmp-1173) #f) (apply (lambda (syntmp-dots-1176 syntmp-e-1177) (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-e-1177 syntmp-r-1163 syntmp-maps-1164 (lambda (syntmp-x-1178) #f) syntmp-mod-1166)) syntmp-tmp-1173) ((lambda (syntmp-tmp-1179) (if (if syntmp-tmp-1179 (apply (lambda (syntmp-x-1180 syntmp-dots-1181 syntmp-y-1182) (syntmp-ellipsis?-1165 syntmp-dots-1181)) syntmp-tmp-1179) #f) (apply (lambda (syntmp-x-1183 syntmp-dots-1184 syntmp-y-1185) (let syntmp-f-1186 ((syntmp-y-1187 syntmp-y-1185) (syntmp-k-1188 (lambda (syntmp-maps-1189) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-x-1183 syntmp-r-1163 (cons (quote ()) syntmp-maps-1189) syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-x-1190 syntmp-maps-1191) (if (null? (car syntmp-maps-1191)) (syntax-error syntmp-src-1161 "extra ellipsis in syntax form") (values (syntmp-gen-map-1129 syntmp-x-1190 (car syntmp-maps-1191)) (cdr syntmp-maps-1191)))))))) ((lambda (syntmp-tmp-1192) ((lambda (syntmp-tmp-1193) (if (if syntmp-tmp-1193 (apply (lambda (syntmp-dots-1194 syntmp-y-1195) (syntmp-ellipsis?-1165 syntmp-dots-1194)) syntmp-tmp-1193) #f) (apply (lambda (syntmp-dots-1196 syntmp-y-1197) (syntmp-f-1186 syntmp-y-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-k-1188 (cons (quote ()) syntmp-maps-1198))) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1161 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1128 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) syntmp-tmp-1193) ((lambda (syntmp-_-1201) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-y-1187 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-y-1202 syntmp-maps-1203) (call-with-values (lambda () (syntmp-k-1188 syntmp-maps-1203)) (lambda (syntmp-x-1204 syntmp-maps-1205) (values (syntmp-gen-append-1131 syntmp-x-1204 syntmp-y-1202) syntmp-maps-1205)))))) syntmp-tmp-1192))) (syntax-dispatch syntmp-tmp-1192 (quote (any . any))))) syntmp-y-1187))) syntmp-tmp-1179) ((lambda (syntmp-tmp-1206) (if syntmp-tmp-1206 (apply (lambda (syntmp-x-1207 syntmp-y-1208) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-x-1207 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-x-1209 syntmp-maps-1210) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-y-1208 syntmp-r-1163 syntmp-maps-1210 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-y-1211 syntmp-maps-1212) (values (syntmp-gen-cons-1130 syntmp-x-1209 syntmp-y-1211) syntmp-maps-1212)))))) syntmp-tmp-1206) ((lambda (syntmp-tmp-1213) (if syntmp-tmp-1213 (apply (lambda (syntmp-e1-1214 syntmp-e2-1215) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 (cons syntmp-e1-1214 syntmp-e2-1215) syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-e-1217 syntmp-maps-1218) (values (syntmp-gen-vector-1132 syntmp-e-1217) syntmp-maps-1218)))) syntmp-tmp-1213) ((lambda (syntmp-_-1219) (values (list (quote quote) syntmp-e-1162) syntmp-maps-1164)) syntmp-tmp-1172))) (syntax-dispatch syntmp-tmp-1172 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1172 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1172 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1172 (quote (any any))))) syntmp-e-1162))))) (lambda (syntmp-e-1220 syntmp-r-1221 syntmp-w-1222 syntmp-s-1223 syntmp-mod-1224) (let ((syntmp-e-1225 (syntmp-source-wrap-146 syntmp-e-1220 syntmp-w-1222 syntmp-s-1223 syntmp-mod-1224))) ((lambda (syntmp-tmp-1226) ((lambda (syntmp-tmp-1227) (if syntmp-tmp-1227 (apply (lambda (syntmp-_-1228 syntmp-x-1229) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-e-1225 syntmp-x-1229 syntmp-r-1221 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1224)) (lambda (syntmp-e-1230 syntmp-maps-1231) (syntmp-regen-1133 syntmp-e-1230)))) syntmp-tmp-1227) ((lambda (syntmp-_-1232) (syntax-error syntmp-e-1225)) syntmp-tmp-1226))) (syntax-dispatch syntmp-tmp-1226 (quote (any any))))) syntmp-e-1225))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1233 syntmp-r-1234 syntmp-w-1235 syntmp-s-1236 syntmp-mod-1237) ((lambda (syntmp-tmp-1238) ((lambda (syntmp-tmp-1239) (if syntmp-tmp-1239 (apply (lambda (syntmp-_-1240 syntmp-c-1241) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1233 syntmp-w-1235 syntmp-s-1236 syntmp-mod-1237) syntmp-c-1241 syntmp-r-1234 syntmp-w-1235 syntmp-mod-1237 (lambda (syntmp-vars-1242 syntmp-body-1243) (syntmp-build-annotated-94 syntmp-s-1236 (list (quote lambda) syntmp-vars-1242 syntmp-body-1243))))) syntmp-tmp-1239) (syntax-error syntmp-tmp-1238))) (syntax-dispatch syntmp-tmp-1238 (quote (any . any))))) syntmp-e-1233))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1244 (lambda (syntmp-e-1245 syntmp-r-1246 syntmp-w-1247 syntmp-s-1248 syntmp-mod-1249 syntmp-constructor-1250 syntmp-ids-1251 syntmp-vals-1252 syntmp-exps-1253) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1251)) (syntax-error syntmp-e-1245 "duplicate bound variable in") (let ((syntmp-labels-1254 (syntmp-gen-labels-123 syntmp-ids-1251)) (syntmp-new-vars-1255 (map syntmp-gen-var-165 syntmp-ids-1251))) (let ((syntmp-nw-1256 (syntmp-make-binding-wrap-134 syntmp-ids-1251 syntmp-labels-1254 syntmp-w-1247)) (syntmp-nr-1257 (syntmp-extend-var-env-112 syntmp-labels-1254 syntmp-new-vars-1255 syntmp-r-1246))) (syntmp-constructor-1250 syntmp-s-1248 syntmp-new-vars-1255 (map (lambda (syntmp-x-1258) (syntmp-chi-153 syntmp-x-1258 syntmp-r-1246 syntmp-w-1247 syntmp-mod-1249)) syntmp-vals-1252) (syntmp-chi-body-157 syntmp-exps-1253 (syntmp-source-wrap-146 syntmp-e-1245 syntmp-nw-1256 syntmp-s-1248 syntmp-mod-1249) syntmp-nr-1257 syntmp-nw-1256 syntmp-mod-1249)))))))) (lambda (syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263) ((lambda (syntmp-tmp-1264) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (apply (lambda (syntmp-_-1266 syntmp-id-1267 syntmp-val-1268 syntmp-e1-1269 syntmp-e2-1270) (syntmp-chi-let-1244 syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263 syntmp-build-let-97 syntmp-id-1267 syntmp-val-1268 (cons syntmp-e1-1269 syntmp-e2-1270))) syntmp-tmp-1265) ((lambda (syntmp-tmp-1274) (if (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-f-1276 syntmp-id-1277 syntmp-val-1278 syntmp-e1-1279 syntmp-e2-1280) (syntmp-id?-117 syntmp-f-1276)) syntmp-tmp-1274) #f) (apply (lambda (syntmp-_-1281 syntmp-f-1282 syntmp-id-1283 syntmp-val-1284 syntmp-e1-1285 syntmp-e2-1286) (syntmp-chi-let-1244 syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263 syntmp-build-named-let-98 (cons syntmp-f-1282 syntmp-id-1283) syntmp-val-1284 (cons syntmp-e1-1285 syntmp-e2-1286))) syntmp-tmp-1274) ((lambda (syntmp-_-1290) (syntax-error (syntmp-source-wrap-146 syntmp-e-1259 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263))) syntmp-tmp-1264))) (syntax-dispatch syntmp-tmp-1264 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1264 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1259)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1291 syntmp-r-1292 syntmp-w-1293 syntmp-s-1294 syntmp-mod-1295) ((lambda (syntmp-tmp-1296) ((lambda (syntmp-tmp-1297) (if syntmp-tmp-1297 (apply (lambda (syntmp-_-1298 syntmp-id-1299 syntmp-val-1300 syntmp-e1-1301 syntmp-e2-1302) (let ((syntmp-ids-1303 syntmp-id-1299)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1303)) (syntax-error syntmp-e-1291 "duplicate bound variable in") (let ((syntmp-labels-1305 (syntmp-gen-labels-123 syntmp-ids-1303)) (syntmp-new-vars-1306 (map syntmp-gen-var-165 syntmp-ids-1303))) (let ((syntmp-w-1307 (syntmp-make-binding-wrap-134 syntmp-ids-1303 syntmp-labels-1305 syntmp-w-1293)) (syntmp-r-1308 (syntmp-extend-var-env-112 syntmp-labels-1305 syntmp-new-vars-1306 syntmp-r-1292))) (syntmp-build-letrec-99 syntmp-s-1294 syntmp-new-vars-1306 (map (lambda (syntmp-x-1309) (syntmp-chi-153 syntmp-x-1309 syntmp-r-1308 syntmp-w-1307 syntmp-mod-1295)) syntmp-val-1300) (syntmp-chi-body-157 (cons syntmp-e1-1301 syntmp-e2-1302) (syntmp-source-wrap-146 syntmp-e-1291 syntmp-w-1307 syntmp-s-1294 syntmp-mod-1295) syntmp-r-1308 syntmp-w-1307 syntmp-mod-1295))))))) syntmp-tmp-1297) ((lambda (syntmp-_-1312) (syntax-error (syntmp-source-wrap-146 syntmp-e-1291 syntmp-w-1293 syntmp-s-1294 syntmp-mod-1295))) syntmp-tmp-1296))) (syntax-dispatch syntmp-tmp-1296 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1291))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1313 syntmp-r-1314 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-tmp-1319) (if (if syntmp-tmp-1319 (apply (lambda (syntmp-_-1320 syntmp-id-1321 syntmp-val-1322) (syntmp-id?-117 syntmp-id-1321)) syntmp-tmp-1319) #f) (apply (lambda (syntmp-_-1323 syntmp-id-1324 syntmp-val-1325) (let ((syntmp-val-1326 (syntmp-chi-153 syntmp-val-1325 syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317)) (syntmp-n-1327 (syntmp-id-var-name-139 syntmp-id-1324 syntmp-w-1315))) (let ((syntmp-b-1328 (syntmp-lookup-114 syntmp-n-1327 syntmp-r-1314 syntmp-mod-1317))) (let ((syntmp-t-1329 (syntmp-binding-type-109 syntmp-b-1328))) (if (memv syntmp-t-1329 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1316 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1328) syntmp-val-1326)) (if (memv syntmp-t-1329 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1316 (list (quote set!) (make-module-ref syntmp-mod-1317 syntmp-n-1327 #f) syntmp-val-1326)) (if (memv syntmp-t-1329 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1324 syntmp-w-1315 syntmp-mod-1317) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1313 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317))))))))) syntmp-tmp-1319) ((lambda (syntmp-tmp-1330) (if syntmp-tmp-1330 (apply (lambda (syntmp-_-1331 syntmp-getter-1332 syntmp-arg-1333 syntmp-val-1334) (syntmp-build-annotated-94 syntmp-s-1316 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-getter-1332) syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317) (map (lambda (syntmp-e-1335) (syntmp-chi-153 syntmp-e-1335 syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317)) (append syntmp-arg-1333 (list syntmp-val-1334)))))) syntmp-tmp-1330) ((lambda (syntmp-_-1337) (syntax-error (syntmp-source-wrap-146 syntmp-e-1313 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317))) syntmp-tmp-1318))) (syntax-dispatch syntmp-tmp-1318 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1318 (quote (any any any))))) syntmp-e-1313))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1341 (lambda (syntmp-x-1342 syntmp-keys-1343 syntmp-clauses-1344 syntmp-r-1345 syntmp-mod-1346) (if (null? syntmp-clauses-1344) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1342)) ((lambda (syntmp-tmp-1347) ((lambda (syntmp-tmp-1348) (if syntmp-tmp-1348 (apply (lambda (syntmp-pat-1349 syntmp-exp-1350) (if (and (syntmp-id?-117 syntmp-pat-1349) (andmap (lambda (syntmp-x-1351) (not (syntmp-free-id=?-140 syntmp-pat-1349 syntmp-x-1351))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1343))) (let ((syntmp-labels-1352 (list (syntmp-gen-label-122))) (syntmp-var-1353 (syntmp-gen-var-165 syntmp-pat-1349))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1353) (syntmp-chi-153 syntmp-exp-1350 (syntmp-extend-env-111 syntmp-labels-1352 (list (cons (quote syntax) (cons syntmp-var-1353 0))) syntmp-r-1345) (syntmp-make-binding-wrap-134 (list syntmp-pat-1349) syntmp-labels-1352 (quote (()))) syntmp-mod-1346))) syntmp-x-1342))) (syntmp-gen-clause-1340 syntmp-x-1342 syntmp-keys-1343 (cdr syntmp-clauses-1344) syntmp-r-1345 syntmp-pat-1349 #t syntmp-exp-1350 syntmp-mod-1346))) syntmp-tmp-1348) ((lambda (syntmp-tmp-1354) (if syntmp-tmp-1354 (apply (lambda (syntmp-pat-1355 syntmp-fender-1356 syntmp-exp-1357) (syntmp-gen-clause-1340 syntmp-x-1342 syntmp-keys-1343 (cdr syntmp-clauses-1344) syntmp-r-1345 syntmp-pat-1355 syntmp-fender-1356 syntmp-exp-1357 syntmp-mod-1346)) syntmp-tmp-1354) ((lambda (syntmp-_-1358) (syntax-error (car syntmp-clauses-1344) "invalid syntax-case clause")) syntmp-tmp-1347))) (syntax-dispatch syntmp-tmp-1347 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1347 (quote (any any))))) (car syntmp-clauses-1344))))) (syntmp-gen-clause-1340 (lambda (syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-pat-1363 syntmp-fender-1364 syntmp-exp-1365 syntmp-mod-1366) (call-with-values (lambda () (syntmp-convert-pattern-1338 syntmp-pat-1363 syntmp-keys-1360)) (lambda (syntmp-p-1367 syntmp-pvars-1368) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1368))) (syntax-error syntmp-pat-1363 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1369) (not (syntmp-ellipsis?-162 (car syntmp-x-1369)))) syntmp-pvars-1368)) (syntax-error syntmp-pat-1363 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1370 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1370) (let ((syntmp-y-1371 (syntmp-build-annotated-94 #f syntmp-y-1370))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1372) ((lambda (syntmp-tmp-1373) (if syntmp-tmp-1373 (apply (lambda () syntmp-y-1371) syntmp-tmp-1373) ((lambda (syntmp-_-1374) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1371 (syntmp-build-dispatch-call-1339 syntmp-pvars-1368 syntmp-fender-1364 syntmp-y-1371 syntmp-r-1362 syntmp-mod-1366) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1372))) (syntax-dispatch syntmp-tmp-1372 (quote #(atom #t))))) syntmp-fender-1364) (syntmp-build-dispatch-call-1339 syntmp-pvars-1368 syntmp-exp-1365 syntmp-y-1371 syntmp-r-1362 syntmp-mod-1366) (syntmp-gen-syntax-case-1341 syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1366)))))) (if (eq? syntmp-p-1367 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1359)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1359 (syntmp-build-data-95 #f syntmp-p-1367))))))))))))) (syntmp-build-dispatch-call-1339 (lambda (syntmp-pvars-1375 syntmp-exp-1376 syntmp-y-1377 syntmp-r-1378 syntmp-mod-1379) (let ((syntmp-ids-1380 (map car syntmp-pvars-1375)) (syntmp-levels-1381 (map cdr syntmp-pvars-1375))) (let ((syntmp-labels-1382 (syntmp-gen-labels-123 syntmp-ids-1380)) (syntmp-new-vars-1383 (map syntmp-gen-var-165 syntmp-ids-1380))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1383 (syntmp-chi-153 syntmp-exp-1376 (syntmp-extend-env-111 syntmp-labels-1382 (map (lambda (syntmp-var-1384 syntmp-level-1385) (cons (quote syntax) (cons syntmp-var-1384 syntmp-level-1385))) syntmp-new-vars-1383 (map cdr syntmp-pvars-1375)) syntmp-r-1378) (syntmp-make-binding-wrap-134 syntmp-ids-1380 syntmp-labels-1382 (quote (()))) syntmp-mod-1379))) syntmp-y-1377)))))) (syntmp-convert-pattern-1338 (lambda (syntmp-pattern-1386 syntmp-keys-1387) (let syntmp-cvt-1388 ((syntmp-p-1389 syntmp-pattern-1386) (syntmp-n-1390 0) (syntmp-ids-1391 (quote ()))) (if (syntmp-id?-117 syntmp-p-1389) (if (syntmp-bound-id-member?-144 syntmp-p-1389 syntmp-keys-1387) (values (vector (quote free-id) syntmp-p-1389) syntmp-ids-1391) (values (quote any) (cons (cons syntmp-p-1389 syntmp-n-1390) syntmp-ids-1391))) ((lambda (syntmp-tmp-1392) ((lambda (syntmp-tmp-1393) (if (if syntmp-tmp-1393 (apply (lambda (syntmp-x-1394 syntmp-dots-1395) (syntmp-ellipsis?-162 syntmp-dots-1395)) syntmp-tmp-1393) #f) (apply (lambda (syntmp-x-1396 syntmp-dots-1397) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1396 (syntmp-fx+-85 syntmp-n-1390 1) syntmp-ids-1391)) (lambda (syntmp-p-1398 syntmp-ids-1399) (values (if (eq? syntmp-p-1398 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1398)) syntmp-ids-1399)))) syntmp-tmp-1393) ((lambda (syntmp-tmp-1400) (if syntmp-tmp-1400 (apply (lambda (syntmp-x-1401 syntmp-y-1402) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-y-1402 syntmp-n-1390 syntmp-ids-1391)) (lambda (syntmp-y-1403 syntmp-ids-1404) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1401 syntmp-n-1390 syntmp-ids-1404)) (lambda (syntmp-x-1405 syntmp-ids-1406) (values (cons syntmp-x-1405 syntmp-y-1403) syntmp-ids-1406)))))) syntmp-tmp-1400) ((lambda (syntmp-tmp-1407) (if syntmp-tmp-1407 (apply (lambda () (values (quote ()) syntmp-ids-1391)) syntmp-tmp-1407) ((lambda (syntmp-tmp-1408) (if syntmp-tmp-1408 (apply (lambda (syntmp-x-1409) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1409 syntmp-n-1390 syntmp-ids-1391)) (lambda (syntmp-p-1411 syntmp-ids-1412) (values (vector (quote vector) syntmp-p-1411) syntmp-ids-1412)))) syntmp-tmp-1408) ((lambda (syntmp-x-1413) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1389 (quote (())))) syntmp-ids-1391)) syntmp-tmp-1392))) (syntax-dispatch syntmp-tmp-1392 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1392 (quote ()))))) (syntax-dispatch syntmp-tmp-1392 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1392 (quote (any any))))) syntmp-p-1389)))))) (lambda (syntmp-e-1414 syntmp-r-1415 syntmp-w-1416 syntmp-s-1417 syntmp-mod-1418) (let ((syntmp-e-1419 (syntmp-source-wrap-146 syntmp-e-1414 syntmp-w-1416 syntmp-s-1417 syntmp-mod-1418))) ((lambda (syntmp-tmp-1420) ((lambda (syntmp-tmp-1421) (if syntmp-tmp-1421 (apply (lambda (syntmp-_-1422 syntmp-val-1423 syntmp-key-1424 syntmp-m-1425) (if (andmap (lambda (syntmp-x-1426) (and (syntmp-id?-117 syntmp-x-1426) (not (syntmp-ellipsis?-162 syntmp-x-1426)))) syntmp-key-1424) (let ((syntmp-x-1428 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1417 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1428) (syntmp-gen-syntax-case-1341 (syntmp-build-annotated-94 #f syntmp-x-1428) syntmp-key-1424 syntmp-m-1425 syntmp-r-1415 syntmp-mod-1418))) (syntmp-chi-153 syntmp-val-1423 syntmp-r-1415 (quote (())) syntmp-mod-1418)))) (syntax-error syntmp-e-1419 "invalid literals list in"))) syntmp-tmp-1421) (syntax-error syntmp-tmp-1420))) (syntax-dispatch syntmp-tmp-1420 (quote (any any each-any . each-any))))) syntmp-e-1419))))) (set! sc-expand (let ((syntmp-m-1431 (quote e)) (syntmp-esew-1432 (quote (eval)))) (lambda (syntmp-x-1433) (if (and (pair? syntmp-x-1433) (equal? (car syntmp-x-1433) syntmp-noexpand-84)) (cadr syntmp-x-1433) (syntmp-chi-top-152 syntmp-x-1433 (quote ()) (quote ((top))) syntmp-m-1431 syntmp-esew-1432 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1434 (quote e)) (syntmp-esew-1435 (quote (eval)))) (lambda (syntmp-x-1437 . syntmp-rest-1436) (if (and (pair? syntmp-x-1437) (equal? (car syntmp-x-1437) syntmp-noexpand-84)) (cadr syntmp-x-1437) (syntmp-chi-top-152 syntmp-x-1437 (quote ()) (quote ((top))) (if (null? syntmp-rest-1436) syntmp-m-1434 (car syntmp-rest-1436)) (if (or (null? syntmp-rest-1436) (null? (cdr syntmp-rest-1436))) syntmp-esew-1435 (cadr syntmp-rest-1436)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1438) (syntmp-nonsymbol-id?-116 syntmp-x-1438))) (set! datum->syntax-object (lambda (syntmp-id-1439 syntmp-datum-1440) (syntmp-make-syntax-object-100 syntmp-datum-1440 (syntmp-syntax-object-wrap-103 syntmp-id-1439) #f))) (set! syntax-object->datum (lambda (syntmp-x-1441) (syntmp-strip-164 syntmp-x-1441 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1442) (begin (let ((syntmp-x-1443 syntmp-ls-1442)) (if (not (list? syntmp-x-1443)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1443))) (map (lambda (syntmp-x-1444) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1442)))) (set! free-identifier=? (lambda (syntmp-x-1445 syntmp-y-1446) (begin (let ((syntmp-x-1447 syntmp-x-1445)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1447)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1447))) (let ((syntmp-x-1448 syntmp-y-1446)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1448)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1448))) (syntmp-free-id=?-140 syntmp-x-1445 syntmp-y-1446)))) (set! bound-identifier=? (lambda (syntmp-x-1449 syntmp-y-1450) (begin (let ((syntmp-x-1451 syntmp-x-1449)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1451)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1451))) (let ((syntmp-x-1452 syntmp-y-1450)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1452)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1452))) (syntmp-bound-id=?-141 syntmp-x-1449 syntmp-y-1450)))) (set! syntax-error (lambda (syntmp-object-1454 . syntmp-messages-1453) (begin (for-each (lambda (syntmp-x-1455) (let ((syntmp-x-1456 syntmp-x-1455)) (if (not (string? syntmp-x-1456)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1456)))) syntmp-messages-1453) (let ((syntmp-message-1457 (if (null? syntmp-messages-1453) "invalid syntax" (apply string-append syntmp-messages-1453)))) (syntmp-error-hook-91 #f syntmp-message-1457 (syntmp-strip-164 syntmp-object-1454 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1458 syntmp-v-1459) (begin (let ((syntmp-x-1460 syntmp-sym-1458)) (if (not (symbol? syntmp-x-1460)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1460))) (let ((syntmp-x-1461 syntmp-v-1459)) (if (not (procedure? syntmp-x-1461)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1461))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1458 syntmp-v-1459)))) (letrec ((syntmp-match-1466 (lambda (syntmp-e-1467 syntmp-p-1468 syntmp-w-1469 syntmp-r-1470 syntmp-mod-1471) (cond ((not syntmp-r-1470) #f) ((eq? syntmp-p-1468 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1467 syntmp-w-1469 syntmp-mod-1471) syntmp-r-1470)) ((syntmp-syntax-object?-101 syntmp-e-1467) (syntmp-match*-1465 (let ((syntmp-e-1472 (syntmp-syntax-object-expression-102 syntmp-e-1467))) (if (annotation? syntmp-e-1472) (annotation-expression syntmp-e-1472) syntmp-e-1472)) syntmp-p-1468 (syntmp-join-wraps-136 syntmp-w-1469 (syntmp-syntax-object-wrap-103 syntmp-e-1467)) syntmp-r-1470 (syntmp-syntax-object-module-104 syntmp-e-1467))) (else (syntmp-match*-1465 (let ((syntmp-e-1473 syntmp-e-1467)) (if (annotation? syntmp-e-1473) (annotation-expression syntmp-e-1473) syntmp-e-1473)) syntmp-p-1468 syntmp-w-1469 syntmp-r-1470 syntmp-mod-1471))))) (syntmp-match*-1465 (lambda (syntmp-e-1474 syntmp-p-1475 syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478) (cond ((null? syntmp-p-1475) (and (null? syntmp-e-1474) syntmp-r-1477)) ((pair? syntmp-p-1475) (and (pair? syntmp-e-1474) (syntmp-match-1466 (car syntmp-e-1474) (car syntmp-p-1475) syntmp-w-1476 (syntmp-match-1466 (cdr syntmp-e-1474) (cdr syntmp-p-1475) syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478) syntmp-mod-1478))) ((eq? syntmp-p-1475 (quote each-any)) (let ((syntmp-l-1479 (syntmp-match-each-any-1463 syntmp-e-1474 syntmp-w-1476 syntmp-mod-1478))) (and syntmp-l-1479 (cons syntmp-l-1479 syntmp-r-1477)))) (else (let ((syntmp-t-1480 (vector-ref syntmp-p-1475 0))) (if (memv syntmp-t-1480 (quote (each))) (if (null? syntmp-e-1474) (syntmp-match-empty-1464 (vector-ref syntmp-p-1475 1) syntmp-r-1477) (let ((syntmp-l-1481 (syntmp-match-each-1462 syntmp-e-1474 (vector-ref syntmp-p-1475 1) syntmp-w-1476 syntmp-mod-1478))) (and syntmp-l-1481 (let syntmp-collect-1482 ((syntmp-l-1483 syntmp-l-1481)) (if (null? (car syntmp-l-1483)) syntmp-r-1477 (cons (map car syntmp-l-1483) (syntmp-collect-1482 (map cdr syntmp-l-1483)))))))) (if (memv syntmp-t-1480 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1474) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1474 syntmp-w-1476 syntmp-mod-1478) (vector-ref syntmp-p-1475 1)) syntmp-r-1477) (if (memv syntmp-t-1480 (quote (atom))) (and (equal? (vector-ref syntmp-p-1475 1) (syntmp-strip-164 syntmp-e-1474 syntmp-w-1476)) syntmp-r-1477) (if (memv syntmp-t-1480 (quote (vector))) (and (vector? syntmp-e-1474) (syntmp-match-1466 (vector->list syntmp-e-1474) (vector-ref syntmp-p-1475 1) syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478))))))))))) (syntmp-match-empty-1464 (lambda (syntmp-p-1484 syntmp-r-1485) (cond ((null? syntmp-p-1484) syntmp-r-1485) ((eq? syntmp-p-1484 (quote any)) (cons (quote ()) syntmp-r-1485)) ((pair? syntmp-p-1484) (syntmp-match-empty-1464 (car syntmp-p-1484) (syntmp-match-empty-1464 (cdr syntmp-p-1484) syntmp-r-1485))) ((eq? syntmp-p-1484 (quote each-any)) (cons (quote ()) syntmp-r-1485)) (else (let ((syntmp-t-1486 (vector-ref syntmp-p-1484 0))) (if (memv syntmp-t-1486 (quote (each))) (syntmp-match-empty-1464 (vector-ref syntmp-p-1484 1) syntmp-r-1485) (if (memv syntmp-t-1486 (quote (free-id atom))) syntmp-r-1485 (if (memv syntmp-t-1486 (quote (vector))) (syntmp-match-empty-1464 (vector-ref syntmp-p-1484 1) syntmp-r-1485))))))))) (syntmp-match-each-any-1463 (lambda (syntmp-e-1487 syntmp-w-1488 syntmp-mod-1489) (cond ((annotation? syntmp-e-1487) (syntmp-match-each-any-1463 (annotation-expression syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489)) ((pair? syntmp-e-1487) (let ((syntmp-l-1490 (syntmp-match-each-any-1463 (cdr syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489))) (and syntmp-l-1490 (cons (syntmp-wrap-145 (car syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489) syntmp-l-1490)))) ((null? syntmp-e-1487) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1487) (syntmp-match-each-any-1463 (syntmp-syntax-object-expression-102 syntmp-e-1487) (syntmp-join-wraps-136 syntmp-w-1488 (syntmp-syntax-object-wrap-103 syntmp-e-1487)) syntmp-mod-1489)) (else #f)))) (syntmp-match-each-1462 (lambda (syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494) (cond ((annotation? syntmp-e-1491) (syntmp-match-each-1462 (annotation-expression syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494)) ((pair? syntmp-e-1491) (let ((syntmp-first-1495 (syntmp-match-1466 (car syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 (quote ()) syntmp-mod-1494))) (and syntmp-first-1495 (let ((syntmp-rest-1496 (syntmp-match-each-1462 (cdr syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494))) (and syntmp-rest-1496 (cons syntmp-first-1495 syntmp-rest-1496)))))) ((null? syntmp-e-1491) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1491) (syntmp-match-each-1462 (syntmp-syntax-object-expression-102 syntmp-e-1491) syntmp-p-1492 (syntmp-join-wraps-136 syntmp-w-1493 (syntmp-syntax-object-wrap-103 syntmp-e-1491)) (syntmp-syntax-object-module-104 syntmp-e-1491))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1497 syntmp-p-1498) (cond ((eq? syntmp-p-1498 (quote any)) (list syntmp-e-1497)) ((syntmp-syntax-object?-101 syntmp-e-1497) (syntmp-match*-1465 (let ((syntmp-e-1499 (syntmp-syntax-object-expression-102 syntmp-e-1497))) (if (annotation? syntmp-e-1499) (annotation-expression syntmp-e-1499) syntmp-e-1499)) syntmp-p-1498 (syntmp-syntax-object-wrap-103 syntmp-e-1497) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1497))) (else (syntmp-match*-1465 (let ((syntmp-e-1500 syntmp-e-1497)) (if (annotation? syntmp-e-1500) (annotation-expression syntmp-e-1500) syntmp-e-1500)) syntmp-p-1498 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1501) ((lambda (syntmp-tmp-1502) ((lambda (syntmp-tmp-1503) (if syntmp-tmp-1503 (apply (lambda (syntmp-_-1504 syntmp-e1-1505 syntmp-e2-1506) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1505 syntmp-e2-1506))) syntmp-tmp-1503) ((lambda (syntmp-tmp-1508) (if syntmp-tmp-1508 (apply (lambda (syntmp-_-1509 syntmp-out-1510 syntmp-in-1511 syntmp-e1-1512 syntmp-e2-1513) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1511 (quote ()) (list syntmp-out-1510 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1512 syntmp-e2-1513))))) syntmp-tmp-1508) ((lambda (syntmp-tmp-1515) (if syntmp-tmp-1515 (apply (lambda (syntmp-_-1516 syntmp-out-1517 syntmp-in-1518 syntmp-e1-1519 syntmp-e2-1520) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1518) (quote ()) (list syntmp-out-1517 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1519 syntmp-e2-1520))))) syntmp-tmp-1515) (syntax-error syntmp-tmp-1502))) (syntax-dispatch syntmp-tmp-1502 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1502 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1502 (quote (any () any . each-any))))) syntmp-x-1501))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-k-1546 syntmp-keyword-1547 syntmp-pattern-1548 syntmp-template-1549) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1546 (map (lambda (syntmp-tmp-1552 syntmp-tmp-1551) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1551) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1552))) syntmp-template-1549 syntmp-pattern-1548)))))) syntmp-tmp-1544) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1542))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1563) ((lambda (syntmp-tmp-1564) ((lambda (syntmp-tmp-1565) (if (if syntmp-tmp-1565 (apply (lambda (syntmp-let*-1566 syntmp-x-1567 syntmp-v-1568 syntmp-e1-1569 syntmp-e2-1570) (andmap identifier? syntmp-x-1567)) syntmp-tmp-1565) #f) (apply (lambda (syntmp-let*-1572 syntmp-x-1573 syntmp-v-1574 syntmp-e1-1575 syntmp-e2-1576) (let syntmp-f-1577 ((syntmp-bindings-1578 (map list syntmp-x-1573 syntmp-v-1574))) (if (null? syntmp-bindings-1578) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1575 syntmp-e2-1576))) ((lambda (syntmp-tmp-1582) ((lambda (syntmp-tmp-1583) (if syntmp-tmp-1583 (apply (lambda (syntmp-body-1584 syntmp-binding-1585) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1585) syntmp-body-1584)) syntmp-tmp-1583) (syntax-error syntmp-tmp-1582))) (syntax-dispatch syntmp-tmp-1582 (quote (any any))))) (list (syntmp-f-1577 (cdr syntmp-bindings-1578)) (car syntmp-bindings-1578)))))) syntmp-tmp-1565) (syntax-error syntmp-tmp-1564))) (syntax-dispatch syntmp-tmp-1564 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1563))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1605) ((lambda (syntmp-tmp-1606) ((lambda (syntmp-tmp-1607) (if syntmp-tmp-1607 (apply (lambda (syntmp-_-1608 syntmp-var-1609 syntmp-init-1610 syntmp-step-1611 syntmp-e0-1612 syntmp-e1-1613 syntmp-c-1614) ((lambda (syntmp-tmp-1615) ((lambda (syntmp-tmp-1616) (if syntmp-tmp-1616 (apply (lambda (syntmp-step-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-tmp-1619) (if syntmp-tmp-1619 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1609 syntmp-init-1610) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1612) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1614 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1617))))))) syntmp-tmp-1619) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-e1-1625 syntmp-e2-1626) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1609 syntmp-init-1610) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1612 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1625 syntmp-e2-1626)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1614 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1617))))))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1618))) (syntax-dispatch syntmp-tmp-1618 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1618 (quote ())))) syntmp-e1-1613)) syntmp-tmp-1616) (syntax-error syntmp-tmp-1615))) (syntax-dispatch syntmp-tmp-1615 (quote each-any)))) (map (lambda (syntmp-v-1633 syntmp-s-1634) ((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda () syntmp-v-1633) syntmp-tmp-1636) ((lambda (syntmp-tmp-1637) (if syntmp-tmp-1637 (apply (lambda (syntmp-e-1638) syntmp-e-1638) syntmp-tmp-1637) ((lambda (syntmp-_-1639) (syntax-error syntmp-orig-x-1605)) syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-s-1634)) syntmp-var-1609 syntmp-step-1611))) syntmp-tmp-1607) (syntax-error syntmp-tmp-1606))) (syntax-dispatch syntmp-tmp-1606 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1605))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1667 (lambda (syntmp-x-1671 syntmp-y-1672) ((lambda (syntmp-tmp-1673) ((lambda (syntmp-tmp-1674) (if syntmp-tmp-1674 (apply (lambda (syntmp-x-1675 syntmp-y-1676) ((lambda (syntmp-tmp-1677) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-dy-1679) ((lambda (syntmp-tmp-1680) ((lambda (syntmp-tmp-1681) (if syntmp-tmp-1681 (apply (lambda (syntmp-dx-1682) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1682 syntmp-dy-1679))) syntmp-tmp-1681) ((lambda (syntmp-_-1683) (if (null? syntmp-dy-1679) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675 syntmp-y-1676))) syntmp-tmp-1680))) (syntax-dispatch syntmp-tmp-1680 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1675)) syntmp-tmp-1678) ((lambda (syntmp-tmp-1684) (if syntmp-tmp-1684 (apply (lambda (syntmp-stuff-1685) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1675 syntmp-stuff-1685))) syntmp-tmp-1684) ((lambda (syntmp-else-1686) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675 syntmp-y-1676)) syntmp-tmp-1677))) (syntax-dispatch syntmp-tmp-1677 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1677 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1676)) syntmp-tmp-1674) (syntax-error syntmp-tmp-1673))) (syntax-dispatch syntmp-tmp-1673 (quote (any any))))) (list syntmp-x-1671 syntmp-y-1672)))) (syntmp-quasiappend-1668 (lambda (syntmp-x-1687 syntmp-y-1688) ((lambda (syntmp-tmp-1689) ((lambda (syntmp-tmp-1690) (if syntmp-tmp-1690 (apply (lambda (syntmp-x-1691 syntmp-y-1692) ((lambda (syntmp-tmp-1693) ((lambda (syntmp-tmp-1694) (if syntmp-tmp-1694 (apply (lambda () syntmp-x-1691) syntmp-tmp-1694) ((lambda (syntmp-_-1695) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1691 syntmp-y-1692)) syntmp-tmp-1693))) (syntax-dispatch syntmp-tmp-1693 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1692)) syntmp-tmp-1690) (syntax-error syntmp-tmp-1689))) (syntax-dispatch syntmp-tmp-1689 (quote (any any))))) (list syntmp-x-1687 syntmp-y-1688)))) (syntmp-quasivector-1669 (lambda (syntmp-x-1696) ((lambda (syntmp-tmp-1697) ((lambda (syntmp-x-1698) ((lambda (syntmp-tmp-1699) ((lambda (syntmp-tmp-1700) (if syntmp-tmp-1700 (apply (lambda (syntmp-x-1701) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1701))) syntmp-tmp-1700) ((lambda (syntmp-tmp-1703) (if syntmp-tmp-1703 (apply (lambda (syntmp-x-1704) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1704)) syntmp-tmp-1703) ((lambda (syntmp-_-1706) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1698)) syntmp-tmp-1699))) (syntax-dispatch syntmp-tmp-1699 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1699 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1698)) syntmp-tmp-1697)) syntmp-x-1696))) (syntmp-quasi-1670 (lambda (syntmp-p-1707 syntmp-lev-1708) ((lambda (syntmp-tmp-1709) ((lambda (syntmp-tmp-1710) (if syntmp-tmp-1710 (apply (lambda (syntmp-p-1711) (if (= syntmp-lev-1708 0) syntmp-p-1711 (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1711) (- syntmp-lev-1708 1))))) syntmp-tmp-1710) ((lambda (syntmp-tmp-1712) (if syntmp-tmp-1712 (apply (lambda (syntmp-p-1713 syntmp-q-1714) (if (= syntmp-lev-1708 0) (syntmp-quasiappend-1668 syntmp-p-1713 (syntmp-quasi-1670 syntmp-q-1714 syntmp-lev-1708)) (syntmp-quasicons-1667 (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1713) (- syntmp-lev-1708 1))) (syntmp-quasi-1670 syntmp-q-1714 syntmp-lev-1708)))) syntmp-tmp-1712) ((lambda (syntmp-tmp-1715) (if syntmp-tmp-1715 (apply (lambda (syntmp-p-1716) (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1716) (+ syntmp-lev-1708 1)))) syntmp-tmp-1715) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-p-1718 syntmp-q-1719) (syntmp-quasicons-1667 (syntmp-quasi-1670 syntmp-p-1718 syntmp-lev-1708) (syntmp-quasi-1670 syntmp-q-1719 syntmp-lev-1708))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (syntmp-quasivector-1669 (syntmp-quasi-1670 syntmp-x-1721 syntmp-lev-1708))) syntmp-tmp-1720) ((lambda (syntmp-p-1723) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1723)) syntmp-tmp-1709))) (syntax-dispatch syntmp-tmp-1709 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1709 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1707)))) (lambda (syntmp-x-1724) ((lambda (syntmp-tmp-1725) ((lambda (syntmp-tmp-1726) (if syntmp-tmp-1726 (apply (lambda (syntmp-_-1727 syntmp-e-1728) (syntmp-quasi-1670 syntmp-e-1728 0)) syntmp-tmp-1726) (syntax-error syntmp-tmp-1725))) (syntax-dispatch syntmp-tmp-1725 (quote (any any))))) syntmp-x-1724)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1788) (letrec ((syntmp-read-file-1789 (lambda (syntmp-fn-1790 syntmp-k-1791) (let ((syntmp-p-1792 (open-input-file syntmp-fn-1790))) (let syntmp-f-1793 ((syntmp-x-1794 (read syntmp-p-1792))) (if (eof-object? syntmp-x-1794) (begin (close-input-port syntmp-p-1792) (quote ())) (cons (datum->syntax-object syntmp-k-1791 syntmp-x-1794) (syntmp-f-1793 (read syntmp-p-1792))))))))) ((lambda (syntmp-tmp-1795) ((lambda (syntmp-tmp-1796) (if syntmp-tmp-1796 (apply (lambda (syntmp-k-1797 syntmp-filename-1798) (let ((syntmp-fn-1799 (syntax-object->datum syntmp-filename-1798))) ((lambda (syntmp-tmp-1800) ((lambda (syntmp-tmp-1801) (if syntmp-tmp-1801 (apply (lambda (syntmp-exp-1802) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1802)) syntmp-tmp-1801) (syntax-error syntmp-tmp-1800))) (syntax-dispatch syntmp-tmp-1800 (quote each-any)))) (syntmp-read-file-1789 syntmp-fn-1799 syntmp-k-1797)))) syntmp-tmp-1796) (syntax-error syntmp-tmp-1795))) (syntax-dispatch syntmp-tmp-1795 (quote (any any))))) syntmp-x-1788)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1819) ((lambda (syntmp-tmp-1820) ((lambda (syntmp-tmp-1821) (if syntmp-tmp-1821 (apply (lambda (syntmp-_-1822 syntmp-e-1823) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1823))) syntmp-tmp-1821) (syntax-error syntmp-tmp-1820))) (syntax-dispatch syntmp-tmp-1820 (quote (any any))))) syntmp-x-1819))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1829) ((lambda (syntmp-tmp-1830) ((lambda (syntmp-tmp-1831) (if syntmp-tmp-1831 (apply (lambda (syntmp-_-1832 syntmp-e-1833) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1833))) syntmp-tmp-1831) (syntax-error syntmp-tmp-1830))) (syntax-dispatch syntmp-tmp-1830 (quote (any any))))) syntmp-x-1829))) +(install-global-transformer (quote case) (lambda (syntmp-x-1839) ((lambda (syntmp-tmp-1840) ((lambda (syntmp-tmp-1841) (if syntmp-tmp-1841 (apply (lambda (syntmp-_-1842 syntmp-e-1843 syntmp-m1-1844 syntmp-m2-1845) ((lambda (syntmp-tmp-1846) ((lambda (syntmp-body-1847) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1843)) syntmp-body-1847)) syntmp-tmp-1846)) (let syntmp-f-1848 ((syntmp-clause-1849 syntmp-m1-1844) (syntmp-clauses-1850 syntmp-m2-1845)) (if (null? syntmp-clauses-1850) ((lambda (syntmp-tmp-1852) ((lambda (syntmp-tmp-1853) (if syntmp-tmp-1853 (apply (lambda (syntmp-e1-1854 syntmp-e2-1855) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1854 syntmp-e2-1855))) syntmp-tmp-1853) ((lambda (syntmp-tmp-1857) (if syntmp-tmp-1857 (apply (lambda (syntmp-k-1858 syntmp-e1-1859 syntmp-e2-1860) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1858)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1859 syntmp-e2-1860)))) syntmp-tmp-1857) ((lambda (syntmp-_-1863) (syntax-error syntmp-x-1839)) syntmp-tmp-1852))) (syntax-dispatch syntmp-tmp-1852 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1852 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1849) ((lambda (syntmp-tmp-1864) ((lambda (syntmp-rest-1865) ((lambda (syntmp-tmp-1866) ((lambda (syntmp-tmp-1867) (if syntmp-tmp-1867 (apply (lambda (syntmp-k-1868 syntmp-e1-1869 syntmp-e2-1870) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1868)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1869 syntmp-e2-1870)) syntmp-rest-1865)) syntmp-tmp-1867) ((lambda (syntmp-_-1873) (syntax-error syntmp-x-1839)) syntmp-tmp-1866))) (syntax-dispatch syntmp-tmp-1866 (quote (each-any any . each-any))))) syntmp-clause-1849)) syntmp-tmp-1864)) (syntmp-f-1848 (car syntmp-clauses-1850) (cdr syntmp-clauses-1850))))))) syntmp-tmp-1841) (syntax-error syntmp-tmp-1840))) (syntax-dispatch syntmp-tmp-1840 (quote (any any any . each-any))))) syntmp-x-1839))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1903) ((lambda (syntmp-tmp-1904) ((lambda (syntmp-tmp-1905) (if syntmp-tmp-1905 (apply (lambda (syntmp-_-1906 syntmp-e-1907) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1907)) (list (cons syntmp-_-1906 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1907 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1905) (syntax-error syntmp-tmp-1904))) (syntax-dispatch syntmp-tmp-1904 (quote (any any))))) syntmp-x-1903))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index e3dd528a5..2518fc982 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -972,7 +972,9 @@ (let ((first (car e))) (if (id? first) (let* ((n (id-var-name first w)) - (b (lookup n r mod)) + (b (lookup n r (or (and (syntax-object? first) + (syntax-object-module first)) + mod))) (type (binding-type b))) (case type ((lexical) diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index 8fed4d8d6..79e98f993 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -42,6 +42,8 @@ (lambda (exp env) (save-module-excursion (lambda () + ;; Because memoization happens lazily, env's module isn't + ;; necessarily the current module. (set-current-module (eval-closure-module (car (last-pair env)))) (strip-expansion-structures (sc-expand exp))))))) diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm index ed61464f0..902fc49a5 100644 --- a/module/system/base/pmatch.scm +++ b/module/system/base/pmatch.scm @@ -1,6 +1,6 @@ (define-module (system base pmatch) #:use-module (ice-9 syncase) - #:export (pmatch ppat)) + #:export (pmatch)) ;; FIXME: shouldn't have to export ppat... ;; Originally written by Oleg Kiselyov. Taken from: From 69dd78d7c85141463ae93e9901a70ed4d7136fbc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Apr 2009 17:02:33 +0200 Subject: [PATCH 041/375] no positions when reading psyntax-pp, validation in @/@@, cleanups * module/ice-9/syncase.scm (old-debug): Re-disable position recording when reading psyntax-pp. * libguile/eval.c (scm_m_at, scm_m_atat): More input validation. * libguile/debug.c (scm_procedure_module): Use scm_env_module. Remove extraneous docstring. --- libguile/debug.c | 20 ++------------------ libguile/eval.c | 2 ++ module/ice-9/syncase.scm | 4 ++-- 3 files changed, 6 insertions(+), 20 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index fe54b64df..5042fbb73 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -402,9 +402,7 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0, (SCM proc), - "Return the module that was current when this procedure was defined.\n" - "Free variables in this procedure are resolved relative to the\n" - "procedure's module.") + "Return the module that was current when @var{proc} was defined.") #define FUNC_NAME s_scm_procedure_module { SCM_VALIDATE_PROC (SCM_ARG1, proc); @@ -412,21 +410,7 @@ SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0, if (scm_is_true (scm_program_p (proc))) return scm_program_module (proc); else - { - SCM env = scm_procedure_environment (proc); - - if (scm_is_null (env)) - return SCM_BOOL_F; - else - { - for (; !scm_is_null (scm_cdr (env)); env = scm_cdr (env)) - ; - if (SCM_EVAL_CLOSURE_P (scm_car (env))) - return SCM_PACK (SCM_SMOB_DATA (scm_car (env))); - else - return SCM_BOOL_F; - } - } + return scm_env_module (scm_procedure_environment (proc)); } #undef FUNC_NAME diff --git a/libguile/eval.c b/libguile/eval.c index 12888c2fe..4c79b166c 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1988,6 +1988,7 @@ scm_m_at (SCM expr, SCM env SCM_UNUSED) SCM mod, var; ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr); mod = scm_resolve_module (scm_cadr (expr)); if (scm_is_false (mod)) @@ -2008,6 +2009,7 @@ scm_m_atat (SCM expr, SCM env SCM_UNUSED) SCM mod, var; ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr); mod = scm_resolve_module (scm_cadr (expr)); if (scm_is_false (mod)) diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index 79e98f993..a6bdaa4a9 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -177,8 +177,8 @@ (set! old-debug (debug-options)) (set! old-read (read-options))) (lambda () - ;(debug-disable 'debug 'procnames) - ;(read-disable 'positions) + (debug-disable 'debug 'procnames) + (read-disable 'positions) (load-from-path "ice-9/psyntax-pp")) (lambda () (debug-options old-debug) From d1529ddfcbe24e1465982e959916f7865cdf778a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Apr 2009 11:42:24 +0200 Subject: [PATCH 042/375] fix m4->texi snarfage after the guile-tools change * doc/ref/Makefile.am: Fix to work after a make clean with the recent guile-tools changes. --- doc/ref/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index d534351dd..368b82321 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -90,7 +90,8 @@ include $(top_srcdir)/am/pre-inst-guile autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/meta/guile.m4 - $(preinstguiletool)/snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \ + $(top_builddir)/meta/uninstalled-env guile-tools \ + snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \ > $(srcdir)/$@ lib-version.texi: $(top_srcdir)/GUILE-VERSION From 2b4b555b8fd10d369dbb2ee1f90d9e6035a5cd9e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Apr 2009 17:23:40 +0200 Subject: [PATCH 043/375] fix build errors on fresh checkout * meta/guile-tools: We can't use srfi-1, because on a fresh checkout the srfi-1 shlib isn't built yet. Bummer. * meta/uninstalled-env.in: Fix up the DYLD lines for BSDen. * module/scripts/snart-guile-m4-docs.scm: Fix expected arguments. --- meta/guile-tools | 11 +++++++++-- meta/uninstalled-env.in | 2 +- module/scripts/snarf-guile-m4-docs.scm | 2 +- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/meta/guile-tools b/meta/guile-tools index 6df88effa..c30f02655 100755 --- a/meta/guile-tools +++ b/meta/guile-tools @@ -22,8 +22,15 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(define-module (guile-tools) - #:use-module (srfi srfi-1)) +(define-module (guile-tools)) + +;; We can't import srfi-1, unfortunately, as we are used early in the +;; boot process, before the srfi-1 shlib is built. + +(define (fold kons seed seq) + (if (null? seq) + seed + (fold kons (kons (car seq) seed) (cdr seq)))) (define (help) (display "\ diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 02c0e315e..56bbc307f 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -80,7 +80,7 @@ for dir in $subdirs_with_ltlibs ; do done LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH" export LTDL_LIBRARY_PATH -DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH" +DYLD_LIBRARY_PATH="${dyld_prefix}$DYLD_LIBRARY_PATH" export DYLD_LIBRARY_PATH if [ x"$PKG_CONFIG_PATH" = x ] diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm index 11fb82b3d..614fc0fe5 100644 --- a/module/scripts/snarf-guile-m4-docs.scm +++ b/module/scripts/snarf-guile-m4-docs.scm @@ -63,7 +63,7 @@ (else (car line))) acc))))) -(define (snarf-guile-m4-docs . args) +(define (snarf-guile-m4-docs args) (let* ((p (open-file (car args) "r")) (next (lambda () (read-line p)))) (let loop ((line (next)) (acc #f)) From 807da8804c1bf5bb0468de332401352870f2e157 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Apr 2009 17:42:35 +0200 Subject: [PATCH 044/375] some more build fixes for bugs that I introduced * meta/guile-1.8.pc.in: Include a pkgdatadir, which will map down to `guile-config info pkgdatadir', used in existing guile.m4 files. * meta/guile-config: Fix guile-config info varname. Facepalm. * meta/guile.m4: Make GUILE_SITE_DIR use the sitedir variable instead. Really it should use pkg-config directly, though. --- meta/guile-1.8.pc.in | 1 + meta/guile-config | 3 ++- meta/guile.m4 | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/meta/guile-1.8.pc.in b/meta/guile-1.8.pc.in index 15c83d84b..1b43cbc5e 100644 --- a/meta/guile-1.8.pc.in +++ b/meta/guile-1.8.pc.in @@ -4,6 +4,7 @@ libdir=@libdir@ includedir=@includedir@ datarootdir=@datarootdir@ datadir=@datadir@ +pkgdatadir=@datadir@/guile sitedir=@sitedir@ libguileinterface=@LIBGUILE_INTERFACE@ diff --git a/meta/guile-config b/meta/guile-config index 669934b96..b90a5e599 100755 --- a/meta/guile-config +++ b/meta/guile-config @@ -149,7 +149,8 @@ exec guile -e main -s $0 "$@" ((string=? (car args) "guileversion") (display (pkg-config "--modversion" guile-module))) (else - (display (pkg-config (format #f (car args) guile-module)))))) + (display (pkg-config (format #f "--variable=~A" (car args)) + guile-module))))) (else (display-line-error "Usage: " program-name " info VAR") (quit 2)))) diff --git a/meta/guile.m4 b/meta/guile.m4 index bcded2bdc..c7344937f 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -107,7 +107,7 @@ AC_DEFUN([GUILE_FLAGS], AC_DEFUN([GUILE_SITE_DIR], [AC_REQUIRE([GUILE_PROGS])dnl AC_MSG_CHECKING(for Guile site directory) - GUILE_SITE=`[$GUILE_CONFIG] info pkgdatadir`/site + GUILE_SITE=`[$GUILE_CONFIG] info sitedir`/site AC_MSG_RESULT($GUILE_SITE) AC_SUBST(GUILE_SITE) ]) From fb3807793f2f4b386ad6cd2946c2fddbf0cc6131 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Apr 2009 18:20:01 +0200 Subject: [PATCH 045/375] scripts take rest args * meta/guile-tools: Instead of fixing scripts I should have been fixing the script runner. * module/scripts/compile.scm: * module/scripts/snarf-guile-m4-docs.scm: Fix to take rest args. --- meta/guile-tools | 8 ++++++-- module/scripts/compile.scm | 4 ++-- module/scripts/snarf-guile-m4-docs.scm | 2 +- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/meta/guile-tools b/meta/guile-tools index c30f02655..6fb93c13a 100755 --- a/meta/guile-tools +++ b/meta/guile-tools @@ -64,7 +64,7 @@ PROGRAM is run with ARGS. (string-suffix? ext path) (substring path 0 (- (string-length path) (string-length ext))))) - (append %load-extensions %load-compiled-extensions))) + (append %load-compiled-extensions %load-extensions))) (define (unique l) (cond ((null? l) l) @@ -72,6 +72,10 @@ PROGRAM is run with ARGS. ((equal? (car l) (cadr l)) (unique (cdr l))) (else (cons (car l) (unique (cdr l)))))) +;; for want of srfi-1 +(define (append-map f l) + (apply append (map f l))) + (define (find-submodules head) (let ((shead (map symbol->string head))) (unique @@ -102,4 +106,4 @@ PROGRAM is run with ARGS. (equal? (cdr args) '("list"))) (list-scripts) (let ((mod (find-script (cadr args)))) - (exit ((module-ref mod 'main) (cdr args)))))) + (exit (apply (module-ref mod 'main) (cddr args)))))) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 7c812ad1e..f0294b5d6 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -89,8 +89,8 @@ options." (load-path)))) -(define (compile args) - (let* ((options (parse-args (cdr args))) +(define (compile . args) + (let* ((options (parse-args args)) (help? (assoc-ref options 'help?)) (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '())) (from (or (assoc-ref options 'from) 'scheme)) diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm index 614fc0fe5..11fb82b3d 100644 --- a/module/scripts/snarf-guile-m4-docs.scm +++ b/module/scripts/snarf-guile-m4-docs.scm @@ -63,7 +63,7 @@ (else (car line))) acc))))) -(define (snarf-guile-m4-docs args) +(define (snarf-guile-m4-docs . args) (let* ((p (open-file (car args) "r")) (next (lambda () (read-line p)))) (let loop ((line (next)) (acc #f)) From 922d369578781ee5424c995d7c6a236ceb54a786 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Apr 2009 18:23:11 +0200 Subject: [PATCH 046/375] fix guile.m4 for sitedir change * meta/guile.m4 --- meta/guile.m4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/meta/guile.m4 b/meta/guile.m4 index c7344937f..1e30d508a 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -107,7 +107,7 @@ AC_DEFUN([GUILE_FLAGS], AC_DEFUN([GUILE_SITE_DIR], [AC_REQUIRE([GUILE_PROGS])dnl AC_MSG_CHECKING(for Guile site directory) - GUILE_SITE=`[$GUILE_CONFIG] info sitedir`/site + GUILE_SITE=`[$GUILE_CONFIG] info sitedir` AC_MSG_RESULT($GUILE_SITE) AC_SUBST(GUILE_SITE) ]) From d4876cb4133625d1cdddf044a1b434e292ee82d7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Apr 2009 12:41:19 +0200 Subject: [PATCH 047/375] distcheck fixen * examples/Makefile.am: Fix the installed guile-config invocation to set PKG_CONFIG_PATH. * meta/Makefile.am (EXTRA_DIST): Dist the bin_SCRIPTS. * meta/guile-config (pkg-config): Better error messages if pkg-config invocation fails. * meta/uninstalled-env.in (PATH): Now that guile-config and guile-tools are not generated, make it the srcdir/meta instead of the builddir. (Guile itself will be picked up from libguile.) --- examples/Makefile.am | 4 ++-- meta/Makefile.am | 3 ++- meta/guile-config | 6 +++++- meta/uninstalled-env.in | 2 +- 4 files changed, 10 insertions(+), 5 deletions(-) diff --git a/examples/Makefile.am b/examples/Makefile.am index 1b995b521..873f34ce0 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -38,8 +38,8 @@ EXTRA_DIST = README ChangeLog-2008 check.test \ \ safe/README safe/safe safe/untrusted.scm safe/evil.scm -AM_CFLAGS = `$(bindir)/guile-config compile` -AM_LIBS = `$(bindir)/guile-config link` +AM_CFLAGS = `PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config compile` +AM_LIBS = `PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config link` box/box: box/box.o diff --git a/meta/Makefile.am b/meta/Makefile.am index 6614ab349..7f655e535 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -21,7 +21,8 @@ ## Floor, Boston, MA 02110-1301 USA bin_SCRIPTS=guile-config guile-tools -EXTRA_DIST=guile.m4 ChangeLog-2008 \ +EXTRA_DIST= $(bin_SCRIPTS) \ + guile.m4 ChangeLog-2008 \ guile-1.8.pc.in guile-1.8-uninstalled.pc.in pkgconfigdir = $(libdir)/pkgconfig diff --git a/meta/guile-config b/meta/guile-config index b90a5e599..815414a38 100755 --- a/meta/guile-config +++ b/meta/guile-config @@ -79,7 +79,11 @@ exec guile -e main -s $0 "$@" (ret (close-pipe pipe))) (case (status:exit-val ret) ((0) (if (eof-object? output) "" output)) - (else (error "error calling pkg-config: ~A" output))))) + (else (display-line-error + (format #f "error: ~s exited with non-zero error code ~A" + (cons "pkg-config" args) (status:exit-val ret))) + ;; assume pkg-config sent diagnostics to stdout + (exit (status:exit-val ret)))))) (define (show-version args) (format (current-error-port) "~A - Guile version ~A" diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 56bbc307f..d5c7949f5 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -93,7 +93,7 @@ export PKG_CONFIG_PATH # handle PATH (no clobber) PATH="${top_builddir}/libguile:${PATH}" -PATH="${top_builddir}/meta:${PATH}" +PATH="${top_srcdir}/meta:${PATH}" export PATH exec "$@" From 265e61273df38c3b3cca7add41807ded3678907c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Apr 2009 22:26:27 +0200 Subject: [PATCH 048/375] syncase knows about @ / @@ * module/ice-9/psyntax.scm (syntax-type): Handle a new type, module-ref. Like external-macro, it also has a procedure as a binding. (chi-expr): module-ref forms -- that is to say, (@ (foo ...) bar) -- as expressions they are global references, but with respect to a specific module. (@, @@): Define module-ref syntax handlers. * module/ice-9/psyntax-pp.scm: Regenerated. * module/ice-9/syncase.scm: Mark as primitive syntax so we don't clobber their definitions. The reason I'm doing things like this is so as to support (set! (@@ ...) ...) sensibly, which will be the next patch. --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 26 +++++++++++++++++++++++++- module/ice-9/syncase.scm | 2 +- 3 files changed, 37 insertions(+), 13 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0ae942270..e1fd72a37 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-724) ((lambda (syntmp-tmp-725) (if syntmp-tmp-725 (apply (lambda (syntmp-_-726 syntmp-e1-727 syntmp-e2-728) (syntmp-chi-sequence-147 (cons syntmp-e1-727 syntmp-e2-728) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-725) (syntax-error syntmp-tmp-724))) (syntax-dispatch syntmp-tmp-724 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-730) ((lambda (syntmp-tmp-731) (if syntmp-tmp-731 (apply (lambda (syntmp-_-732 syntmp-x-733 syntmp-e1-734 syntmp-e2-735) (let ((syntmp-when-list-736 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-733 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-736) (syntmp-chi-sequence-147 (cons syntmp-e1-734 syntmp-e2-735) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-731) (syntax-error syntmp-tmp-730))) (syntax-dispatch syntmp-tmp-730 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722)))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-739 syntmp-r-740 syntmp-w-741 syntmp-mod-742) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-739 syntmp-r-740 syntmp-w-741 #f #f syntmp-mod-742)) (lambda (syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-w-746 syntmp-s-747 syntmp-mod-748) (syntmp-chi-expr-154 syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-r-740 syntmp-w-746 syntmp-s-747 syntmp-mod-748))))) (syntmp-chi-top-152 (lambda (syntmp-e-749 syntmp-r-750 syntmp-w-751 syntmp-m-752 syntmp-esew-753 syntmp-mod-754) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-749 syntmp-r-750 syntmp-w-751 #f #f syntmp-mod-754)) (lambda (syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-w-772 syntmp-s-773 syntmp-mod-774) (let ((syntmp-t-775 syntmp-type-769)) (if (memv syntmp-t-775 (quote (begin-form))) ((lambda (syntmp-tmp-776) ((lambda (syntmp-tmp-777) (if syntmp-tmp-777 (apply (lambda (syntmp-_-778) (syntmp-chi-void-161)) syntmp-tmp-777) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-e1-781 syntmp-e2-782) (syntmp-chi-top-sequence-148 (cons syntmp-e1-781 syntmp-e2-782) syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-m-752 syntmp-esew-753 syntmp-mod-774)) syntmp-tmp-779) (syntax-error syntmp-tmp-776))) (syntax-dispatch syntmp-tmp-776 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-776 (quote (any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774 (lambda (syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-mod-788) (syntmp-chi-top-sequence-148 syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-m-752 syntmp-esew-753 syntmp-mod-788))) (if (memv syntmp-t-775 (quote (eval-when-form))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-x-792 syntmp-e1-793 syntmp-e2-794) (let ((syntmp-when-list-795 (syntmp-chi-when-list-150 syntmp-e-771 syntmp-x-792 syntmp-w-772)) (syntmp-body-796 (cons syntmp-e1-793 syntmp-e2-794))) (cond ((eq? syntmp-m-752 (quote e)) (if (memq (quote eval) syntmp-when-list-795) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-795) (if (or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c&e) (quote (compile load)) syntmp-mod-774) (if (memq syntmp-m-752 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c) (quote (load)) syntmp-mod-774) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) syntmp-mod-774) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-790) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any each-any any . each-any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (define-syntax-form))) (let ((syntmp-n-799 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772)) (syntmp-r-800 (syntmp-macros-only-env-113 syntmp-r-750))) (let ((syntmp-t-801 syntmp-m-752)) (if (memv syntmp-t-801 (quote (c))) (if (memq (quote compile) syntmp-esew-753) (let ((syntmp-e-802 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-802 syntmp-mod-774) (if (memq (quote load) syntmp-esew-753) syntmp-e-802 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-753) (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) (syntmp-chi-void-161))) (if (memv syntmp-t-801 (quote (c&e))) (let ((syntmp-e-803 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-803 syntmp-mod-774) syntmp-e-803)) (begin (if (memq (quote eval) syntmp-esew-753) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) syntmp-mod-774)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-775 (quote (define-form))) (let ((syntmp-n-804 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772))) (let ((syntmp-type-805 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-804 syntmp-r-750 syntmp-mod-774)))) (let ((syntmp-t-806 syntmp-type-805)) (if (memv syntmp-t-806 (quote (global))) (let ((syntmp-x-807 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-807 syntmp-mod-774)) syntmp-x-807)) (if (memv syntmp-t-806 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "identifier out of context") (if (eq? syntmp-type-805 (quote external-macro)) (let ((syntmp-x-808 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-808 syntmp-mod-774)) syntmp-x-808)) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "cannot define keyword at top level"))))))) (let ((syntmp-x-809 (syntmp-chi-expr-154 syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-774)) syntmp-x-809)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (cond ((symbol? syntmp-e-810) (let ((syntmp-n-816 (syntmp-id-var-name-139 syntmp-e-810 syntmp-w-812))) (let ((syntmp-b-817 (syntmp-lookup-114 syntmp-n-816 syntmp-r-811 syntmp-mod-815))) (let ((syntmp-type-818 (syntmp-binding-type-109 syntmp-b-817))) (let ((syntmp-t-819 syntmp-type-818)) (if (memv syntmp-t-819 (quote (lexical))) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (global))) (values syntmp-type-818 syntmp-n-816 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))))))) ((pair? syntmp-e-810) (let ((syntmp-first-820 (car syntmp-e-810))) (if (syntmp-id?-117 syntmp-first-820) (let ((syntmp-n-821 (syntmp-id-var-name-139 syntmp-first-820 syntmp-w-812))) (let ((syntmp-b-822 (syntmp-lookup-114 syntmp-n-821 syntmp-r-811 (or (and (syntmp-syntax-object?-101 syntmp-first-820) (syntmp-syntax-object-module-104 syntmp-first-820)) syntmp-mod-815)))) (let ((syntmp-type-823 (syntmp-binding-type-109 syntmp-b-822))) (let ((syntmp-t-824 syntmp-type-823)) (if (memv syntmp-t-824 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (global))) (values (quote global-call) syntmp-n-821 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (if (memv syntmp-t-824 (quote (core external-macro))) (values syntmp-type-823 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (begin))) (values (quote begin-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (define))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-117 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-form) syntmp-name-831 syntmp-val-832 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-826) ((lambda (syntmp-tmp-833) (if (if syntmp-tmp-833 (apply (lambda (syntmp-_-834 syntmp-name-835 syntmp-args-836 syntmp-e1-837 syntmp-e2-838) (and (syntmp-id?-117 syntmp-name-835) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-836)))) syntmp-tmp-833) #f) (apply (lambda (syntmp-_-839 syntmp-name-840 syntmp-args-841 syntmp-e1-842 syntmp-e2-843) (values (quote define-form) (syntmp-wrap-145 syntmp-name-840 syntmp-w-812 syntmp-mod-815) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-841 (cons syntmp-e1-842 syntmp-e2-843)) syntmp-w-812 syntmp-mod-815)) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-833) ((lambda (syntmp-tmp-845) (if (if syntmp-tmp-845 (apply (lambda (syntmp-_-846 syntmp-name-847) (syntmp-id?-117 syntmp-name-847)) syntmp-tmp-845) #f) (apply (lambda (syntmp-_-848 syntmp-name-849) (values (quote define-form) (syntmp-wrap-145 syntmp-name-849 syntmp-w-812 syntmp-mod-815) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-845) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-810) (if (memv syntmp-t-824 (quote (define-syntax))) ((lambda (syntmp-tmp-850) ((lambda (syntmp-tmp-851) (if (if syntmp-tmp-851 (apply (lambda (syntmp-_-852 syntmp-name-853 syntmp-val-854) (syntmp-id?-117 syntmp-name-853)) syntmp-tmp-851) #f) (apply (lambda (syntmp-_-855 syntmp-name-856 syntmp-val-857) (values (quote define-syntax-form) syntmp-name-856 syntmp-val-857 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-851) (syntax-error syntmp-tmp-850))) (syntax-dispatch syntmp-tmp-850 (quote (any any any))))) syntmp-e-810) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))))))))))))) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))) ((syntmp-syntax-object?-101 syntmp-e-810) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-810) syntmp-r-811 (syntmp-join-wraps-136 syntmp-w-812 (syntmp-syntax-object-wrap-103 syntmp-e-810)) #f syntmp-rib-814 (or (syntmp-syntax-object-module-104 syntmp-e-810) syntmp-mod-815))) ((annotation? syntmp-e-810) (syntmp-syntax-type-151 (annotation-expression syntmp-e-810) syntmp-r-811 syntmp-w-812 (annotation-source syntmp-e-810) syntmp-rib-814 syntmp-mod-815)) ((self-evaluating? syntmp-e-810) (values (quote constant) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) (else (values (quote other) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-858 syntmp-when-list-859 syntmp-w-860) (let syntmp-f-861 ((syntmp-when-list-862 syntmp-when-list-859) (syntmp-situations-863 (quote ()))) (if (null? syntmp-when-list-862) syntmp-situations-863 (syntmp-f-861 (cdr syntmp-when-list-862) (cons (let ((syntmp-x-864 (car syntmp-when-list-862))) (cond ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-864 syntmp-w-860 #f) "invalid eval-when situation")))) syntmp-situations-863)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-869 syntmp-e-870) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-869) syntmp-e-870)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873 syntmp-s-874 syntmp-m-875 syntmp-esew-876 syntmp-mod-877) (syntmp-build-sequence-96 syntmp-s-874 (let syntmp-dobody-878 ((syntmp-body-879 syntmp-body-871) (syntmp-r-880 syntmp-r-872) (syntmp-w-881 syntmp-w-873) (syntmp-m-882 syntmp-m-875) (syntmp-esew-883 syntmp-esew-876) (syntmp-mod-884 syntmp-mod-877)) (if (null? syntmp-body-879) (quote ()) (let ((syntmp-first-885 (syntmp-chi-top-152 (car syntmp-body-879) syntmp-r-880 syntmp-w-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884))) (cons syntmp-first-885 (syntmp-dobody-878 (cdr syntmp-body-879) syntmp-r-880 syntmp-w-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-886 syntmp-r-887 syntmp-w-888 syntmp-s-889 syntmp-mod-890) (syntmp-build-sequence-96 syntmp-s-889 (let syntmp-dobody-891 ((syntmp-body-892 syntmp-body-886) (syntmp-r-893 syntmp-r-887) (syntmp-w-894 syntmp-w-888) (syntmp-mod-895 syntmp-mod-890)) (if (null? syntmp-body-892) (quote ()) (let ((syntmp-first-896 (syntmp-chi-153 (car syntmp-body-892) syntmp-r-893 syntmp-w-894 syntmp-mod-895))) (cons syntmp-first-896 (syntmp-dobody-891 (cdr syntmp-body-892) syntmp-r-893 syntmp-w-894 syntmp-mod-895)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-897 syntmp-w-898 syntmp-s-899 syntmp-defmod-900) (syntmp-wrap-145 (if syntmp-s-899 (make-annotation syntmp-x-897 syntmp-s-899 #f) syntmp-x-897) syntmp-w-898 syntmp-defmod-900))) (syntmp-wrap-145 (lambda (syntmp-x-901 syntmp-w-902 syntmp-defmod-903) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-902)) (null? (syntmp-wrap-subst-121 syntmp-w-902))) syntmp-x-901) ((syntmp-syntax-object?-101 syntmp-x-901) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-901) (syntmp-join-wraps-136 syntmp-w-902 (syntmp-syntax-object-wrap-103 syntmp-x-901)) (syntmp-syntax-object-module-104 syntmp-x-901))) ((null? syntmp-x-901) syntmp-x-901) (else (syntmp-make-syntax-object-100 syntmp-x-901 syntmp-w-902 syntmp-defmod-903))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-904 syntmp-list-905) (and (not (null? syntmp-list-905)) (or (syntmp-bound-id=?-141 syntmp-x-904 (car syntmp-list-905)) (syntmp-bound-id-member?-144 syntmp-x-904 (cdr syntmp-list-905)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-906) (let syntmp-distinct?-907 ((syntmp-ids-908 syntmp-ids-906)) (or (null? syntmp-ids-908) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-908) (cdr syntmp-ids-908))) (syntmp-distinct?-907 (cdr syntmp-ids-908))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-909) (and (let syntmp-all-ids?-910 ((syntmp-ids-911 syntmp-ids-909)) (or (null? syntmp-ids-911) (and (syntmp-id?-117 (car syntmp-ids-911)) (syntmp-all-ids?-910 (cdr syntmp-ids-911))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-909)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-912 syntmp-j-913) (if (and (syntmp-syntax-object?-101 syntmp-i-912) (syntmp-syntax-object?-101 syntmp-j-913)) (and (eq? (let ((syntmp-e-914 (syntmp-syntax-object-expression-102 syntmp-i-912))) (if (annotation? syntmp-e-914) (annotation-expression syntmp-e-914) syntmp-e-914)) (let ((syntmp-e-915 (syntmp-syntax-object-expression-102 syntmp-j-913))) (if (annotation? syntmp-e-915) (annotation-expression syntmp-e-915) syntmp-e-915))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-912)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-913)))) (eq? (let ((syntmp-e-916 syntmp-i-912)) (if (annotation? syntmp-e-916) (annotation-expression syntmp-e-916) syntmp-e-916)) (let ((syntmp-e-917 syntmp-j-913)) (if (annotation? syntmp-e-917) (annotation-expression syntmp-e-917) syntmp-e-917)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-918 syntmp-j-919) (and (eq? (let ((syntmp-x-920 syntmp-i-918)) (let ((syntmp-e-921 (if (syntmp-syntax-object?-101 syntmp-x-920) (syntmp-syntax-object-expression-102 syntmp-x-920) syntmp-x-920))) (if (annotation? syntmp-e-921) (annotation-expression syntmp-e-921) syntmp-e-921))) (let ((syntmp-x-922 syntmp-j-919)) (let ((syntmp-e-923 (if (syntmp-syntax-object?-101 syntmp-x-922) (syntmp-syntax-object-expression-102 syntmp-x-922) syntmp-x-922))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)))) (eq? (syntmp-id-var-name-139 syntmp-i-918 (quote (()))) (syntmp-id-var-name-139 syntmp-j-919 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-924 syntmp-w-925) (letrec ((syntmp-search-vector-rib-928 (lambda (syntmp-sym-939 syntmp-subst-940 syntmp-marks-941 syntmp-symnames-942 syntmp-ribcage-943) (let ((syntmp-n-944 (vector-length syntmp-symnames-942))) (let syntmp-f-945 ((syntmp-i-946 0)) (cond ((syntmp-fx=-87 syntmp-i-946 syntmp-n-944) (syntmp-search-926 syntmp-sym-939 (cdr syntmp-subst-940) syntmp-marks-941)) ((and (eq? (vector-ref syntmp-symnames-942 syntmp-i-946) syntmp-sym-939) (syntmp-same-marks?-138 syntmp-marks-941 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-943) syntmp-i-946))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-943) syntmp-i-946) syntmp-marks-941)) (else (syntmp-f-945 (syntmp-fx+-85 syntmp-i-946 1)))))))) (syntmp-search-list-rib-927 (lambda (syntmp-sym-947 syntmp-subst-948 syntmp-marks-949 syntmp-symnames-950 syntmp-ribcage-951) (let syntmp-f-952 ((syntmp-symnames-953 syntmp-symnames-950) (syntmp-i-954 0)) (cond ((null? syntmp-symnames-953) (syntmp-search-926 syntmp-sym-947 (cdr syntmp-subst-948) syntmp-marks-949)) ((and (eq? (car syntmp-symnames-953) syntmp-sym-947) (syntmp-same-marks?-138 syntmp-marks-949 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-951) syntmp-i-954))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-951) syntmp-i-954) syntmp-marks-949)) (else (syntmp-f-952 (cdr syntmp-symnames-953) (syntmp-fx+-85 syntmp-i-954 1))))))) (syntmp-search-926 (lambda (syntmp-sym-955 syntmp-subst-956 syntmp-marks-957) (if (null? syntmp-subst-956) (values #f syntmp-marks-957) (let ((syntmp-fst-958 (car syntmp-subst-956))) (if (eq? syntmp-fst-958 (quote shift)) (syntmp-search-926 syntmp-sym-955 (cdr syntmp-subst-956) (cdr syntmp-marks-957)) (let ((syntmp-symnames-959 (syntmp-ribcage-symnames-126 syntmp-fst-958))) (if (vector? syntmp-symnames-959) (syntmp-search-vector-rib-928 syntmp-sym-955 syntmp-subst-956 syntmp-marks-957 syntmp-symnames-959 syntmp-fst-958) (syntmp-search-list-rib-927 syntmp-sym-955 syntmp-subst-956 syntmp-marks-957 syntmp-symnames-959 syntmp-fst-958))))))))) (cond ((symbol? syntmp-id-924) (or (call-with-values (lambda () (syntmp-search-926 syntmp-id-924 (syntmp-wrap-subst-121 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w-925))) (lambda (syntmp-x-961 . syntmp-ignore-960) syntmp-x-961)) syntmp-id-924)) ((syntmp-syntax-object?-101 syntmp-id-924) (let ((syntmp-id-962 (let ((syntmp-e-964 (syntmp-syntax-object-expression-102 syntmp-id-924))) (if (annotation? syntmp-e-964) (annotation-expression syntmp-e-964) syntmp-e-964))) (syntmp-w1-963 (syntmp-syntax-object-wrap-103 syntmp-id-924))) (let ((syntmp-marks-965 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w1-963)))) (call-with-values (lambda () (syntmp-search-926 syntmp-id-962 (syntmp-wrap-subst-121 syntmp-w-925) syntmp-marks-965)) (lambda (syntmp-new-id-966 syntmp-marks-967) (or syntmp-new-id-966 (call-with-values (lambda () (syntmp-search-926 syntmp-id-962 (syntmp-wrap-subst-121 syntmp-w1-963) syntmp-marks-967)) (lambda (syntmp-x-969 . syntmp-ignore-968) syntmp-x-969)) syntmp-id-962)))))) ((annotation? syntmp-id-924) (let ((syntmp-id-970 (let ((syntmp-e-971 syntmp-id-924)) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971)))) (or (call-with-values (lambda () (syntmp-search-926 syntmp-id-970 (syntmp-wrap-subst-121 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w-925))) (lambda (syntmp-x-973 . syntmp-ignore-972) syntmp-x-973)) syntmp-id-970))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-924)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-974 syntmp-y-975) (or (eq? syntmp-x-974 syntmp-y-975) (and (not (null? syntmp-x-974)) (not (null? syntmp-y-975)) (eq? (car syntmp-x-974) (car syntmp-y-975)) (syntmp-same-marks?-138 (cdr syntmp-x-974) (cdr syntmp-y-975)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-976 syntmp-m2-977) (syntmp-smart-append-135 syntmp-m1-976 syntmp-m2-977))) (syntmp-join-wraps-136 (lambda (syntmp-w1-978 syntmp-w2-979) (let ((syntmp-m1-980 (syntmp-wrap-marks-120 syntmp-w1-978)) (syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w1-978))) (if (null? syntmp-m1-980) (if (null? syntmp-s1-981) syntmp-w2-979 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-979) (syntmp-smart-append-135 syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w2-979)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-980 (syntmp-wrap-marks-120 syntmp-w2-979)) (syntmp-smart-append-135 syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w2-979))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-982 syntmp-m2-983) (if (null? syntmp-m2-983) syntmp-m1-982 (append syntmp-m1-982 syntmp-m2-983)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-984 syntmp-labels-985 syntmp-w-986) (if (null? syntmp-ids-984) syntmp-w-986 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-986) (cons (let ((syntmp-labelvec-987 (list->vector syntmp-labels-985))) (let ((syntmp-n-988 (vector-length syntmp-labelvec-987))) (let ((syntmp-symnamevec-989 (make-vector syntmp-n-988)) (syntmp-marksvec-990 (make-vector syntmp-n-988))) (begin (let syntmp-f-991 ((syntmp-ids-992 syntmp-ids-984) (syntmp-i-993 0)) (if (not (null? syntmp-ids-992)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-992) syntmp-w-986)) (lambda (syntmp-symname-994 syntmp-marks-995) (begin (vector-set! syntmp-symnamevec-989 syntmp-i-993 syntmp-symname-994) (vector-set! syntmp-marksvec-990 syntmp-i-993 syntmp-marks-995) (syntmp-f-991 (cdr syntmp-ids-992) (syntmp-fx+-85 syntmp-i-993 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-989 syntmp-marksvec-990 syntmp-labelvec-987))))) (syntmp-wrap-subst-121 syntmp-w-986)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-996 syntmp-id-997 syntmp-label-998) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-996 (cons (let ((syntmp-e-999 (syntmp-syntax-object-expression-102 syntmp-id-997))) (if (annotation? syntmp-e-999) (annotation-expression syntmp-e-999) syntmp-e-999)) (syntmp-ribcage-symnames-126 syntmp-ribcage-996))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-996 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-997)) (syntmp-ribcage-marks-127 syntmp-ribcage-996))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-996 (cons syntmp-label-998 (syntmp-ribcage-labels-128 syntmp-ribcage-996)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1000) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1000)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1000))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1001 syntmp-update-1002) (vector-set! syntmp-x-1001 3 syntmp-update-1002))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1003 syntmp-update-1004) (vector-set! syntmp-x-1003 2 syntmp-update-1004))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1005 syntmp-update-1006) (vector-set! syntmp-x-1005 1 syntmp-update-1006))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1007) (vector-ref syntmp-x-1007 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1008) (vector-ref syntmp-x-1008 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1009) (vector-ref syntmp-x-1009 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1010) (and (vector? syntmp-x-1010) (= (vector-length syntmp-x-1010) 4) (eq? (vector-ref syntmp-x-1010 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1011 syntmp-marks-1012 syntmp-labels-1013) (vector (quote ribcage) syntmp-symnames-1011 syntmp-marks-1012 syntmp-labels-1013))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1014) (if (null? syntmp-ls-1014) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1014)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1015 syntmp-w-1016) (if (syntmp-syntax-object?-101 syntmp-x-1015) (values (let ((syntmp-e-1017 (syntmp-syntax-object-expression-102 syntmp-x-1015))) (if (annotation? syntmp-e-1017) (annotation-expression syntmp-e-1017) syntmp-e-1017)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1016) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1015)))) (values (let ((syntmp-e-1018 syntmp-x-1015)) (if (annotation? syntmp-e-1018) (annotation-expression syntmp-e-1018) syntmp-e-1018)) (syntmp-wrap-marks-120 syntmp-w-1016))))) (syntmp-id?-117 (lambda (syntmp-x-1019) (cond ((symbol? syntmp-x-1019) #t) ((syntmp-syntax-object?-101 syntmp-x-1019) (symbol? (let ((syntmp-e-1020 (syntmp-syntax-object-expression-102 syntmp-x-1019))) (if (annotation? syntmp-e-1020) (annotation-expression syntmp-e-1020) syntmp-e-1020)))) ((annotation? syntmp-x-1019) (symbol? (annotation-expression syntmp-x-1019))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1021) (and (syntmp-syntax-object?-101 syntmp-x-1021) (symbol? (let ((syntmp-e-1022 (syntmp-syntax-object-expression-102 syntmp-x-1021))) (if (annotation? syntmp-e-1022) (annotation-expression syntmp-e-1022) syntmp-e-1022)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1023 syntmp-sym-1024 syntmp-val-1025) (syntmp-put-global-definition-hook-92 syntmp-sym-1024 (cons syntmp-type-1023 syntmp-val-1025) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1026 syntmp-r-1027 syntmp-mod-1028) (cond ((assq syntmp-x-1026 syntmp-r-1027) => cdr) ((symbol? syntmp-x-1026) (or (syntmp-get-global-definition-hook-93 syntmp-x-1026 syntmp-mod-1028) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1029) (if (null? syntmp-r-1029) (quote ()) (let ((syntmp-a-1030 (car syntmp-r-1029))) (if (eq? (cadr syntmp-a-1030) (quote macro)) (cons syntmp-a-1030 (syntmp-macros-only-env-113 (cdr syntmp-r-1029))) (syntmp-macros-only-env-113 (cdr syntmp-r-1029))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1031 syntmp-vars-1032 syntmp-r-1033) (if (null? syntmp-labels-1031) syntmp-r-1033 (syntmp-extend-var-env-112 (cdr syntmp-labels-1031) (cdr syntmp-vars-1032) (cons (cons (car syntmp-labels-1031) (cons (quote lexical) (car syntmp-vars-1032))) syntmp-r-1033))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1034 syntmp-bindings-1035 syntmp-r-1036) (if (null? syntmp-labels-1034) syntmp-r-1036 (syntmp-extend-env-111 (cdr syntmp-labels-1034) (cdr syntmp-bindings-1035) (cons (cons (car syntmp-labels-1034) (car syntmp-bindings-1035)) syntmp-r-1036))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1037) (cond ((annotation? syntmp-x-1037) (annotation-source syntmp-x-1037)) ((syntmp-syntax-object?-101 syntmp-x-1037) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1037))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1038 syntmp-update-1039) (vector-set! syntmp-x-1038 3 syntmp-update-1039))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1040 syntmp-update-1041) (vector-set! syntmp-x-1040 2 syntmp-update-1041))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1042 syntmp-update-1043) (vector-set! syntmp-x-1042 1 syntmp-update-1043))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1044) (vector-ref syntmp-x-1044 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1045) (vector-ref syntmp-x-1045 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1046) (vector-ref syntmp-x-1046 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1047) (and (vector? syntmp-x-1047) (= (vector-length syntmp-x-1047) 4) (eq? (vector-ref syntmp-x-1047 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1048 syntmp-wrap-1049 syntmp-module-1050) (vector (quote syntax-object) syntmp-expression-1048 syntmp-wrap-1049 syntmp-module-1050))) (syntmp-build-letrec-99 (lambda (syntmp-src-1051 syntmp-vars-1052 syntmp-val-exps-1053 syntmp-body-exp-1054) (if (null? syntmp-vars-1052) (syntmp-build-annotated-94 syntmp-src-1051 syntmp-body-exp-1054) (syntmp-build-annotated-94 syntmp-src-1051 (list (quote letrec) (map list syntmp-vars-1052 syntmp-val-exps-1053) syntmp-body-exp-1054))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1055 syntmp-vars-1056 syntmp-val-exps-1057 syntmp-body-exp-1058) (if (null? syntmp-vars-1056) (syntmp-build-annotated-94 syntmp-src-1055 syntmp-body-exp-1058) (syntmp-build-annotated-94 syntmp-src-1055 (list (quote let) (car syntmp-vars-1056) (map list (cdr syntmp-vars-1056) syntmp-val-exps-1057) syntmp-body-exp-1058))))) (syntmp-build-let-97 (lambda (syntmp-src-1059 syntmp-vars-1060 syntmp-val-exps-1061 syntmp-body-exp-1062) (if (null? syntmp-vars-1060) (syntmp-build-annotated-94 syntmp-src-1059 syntmp-body-exp-1062) (syntmp-build-annotated-94 syntmp-src-1059 (list (quote let) (map list syntmp-vars-1060 syntmp-val-exps-1061) syntmp-body-exp-1062))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1063 syntmp-exps-1064) (if (null? (cdr syntmp-exps-1064)) (syntmp-build-annotated-94 syntmp-src-1063 (car syntmp-exps-1064)) (syntmp-build-annotated-94 syntmp-src-1063 (cons (quote begin) syntmp-exps-1064))))) (syntmp-build-data-95 (lambda (syntmp-src-1065 syntmp-exp-1066) (if (and (self-evaluating? syntmp-exp-1066) (not (vector? syntmp-exp-1066))) (syntmp-build-annotated-94 syntmp-src-1065 syntmp-exp-1066) (syntmp-build-annotated-94 syntmp-src-1065 (list (quote quote) syntmp-exp-1066))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1067 syntmp-exp-1068) (if (and syntmp-src-1067 (not (annotation? syntmp-exp-1068))) (make-annotation syntmp-exp-1068 syntmp-src-1067 #t) syntmp-exp-1068))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1069 syntmp-module-1070) (let ((syntmp-module-1071 (if syntmp-module-1070 (resolve-module syntmp-module-1070) (warn "wha" syntmp-symbol-1069 (current-module))))) (let ((syntmp-v-1072 (module-variable syntmp-module-1071 syntmp-symbol-1069))) (and syntmp-v-1072 (or (object-property syntmp-v-1072 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1072) (macro? (variable-ref syntmp-v-1072)) (macro-transformer (variable-ref syntmp-v-1072)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1073 syntmp-binding-1074 syntmp-module-1075) (let ((syntmp-module-1076 (if syntmp-module-1075 (resolve-module syntmp-module-1075) (warn "wha" syntmp-symbol-1073 (current-module))))) (let ((syntmp-v-1077 (or (module-variable syntmp-module-1076 syntmp-symbol-1073) (let ((syntmp-v-1078 (make-variable sc-macro))) (begin (module-add! syntmp-module-1076 syntmp-symbol-1073 syntmp-v-1078) syntmp-v-1078))))) (begin (if (not (and (symbol-property syntmp-symbol-1073 (quote primitive-syntax)) (eq? syntmp-module-1076 the-syncase-module))) (variable-set! syntmp-v-1077 sc-macro)) (set-object-property! syntmp-v-1077 (quote *sc-expander*) syntmp-binding-1074)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1079 syntmp-why-1080 syntmp-what-1081) (error syntmp-who-1079 "~a ~s" syntmp-why-1080 syntmp-what-1081))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1082 syntmp-mod-1083) (eval (list syntmp-noexpand-84 syntmp-x-1082) (if syntmp-mod-1083 (resolve-module syntmp-mod-1083) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1084 syntmp-mod-1085) (eval (list syntmp-noexpand-84 syntmp-x-1084) (if syntmp-mod-1085 (resolve-module syntmp-mod-1085) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1086 syntmp-r-1087 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) ((lambda (syntmp-tmp-1091) ((lambda (syntmp-tmp-1092) (if (if syntmp-tmp-1092 (apply (lambda (syntmp-_-1093 syntmp-var-1094 syntmp-val-1095 syntmp-e1-1096 syntmp-e2-1097) (syntmp-valid-bound-ids?-142 syntmp-var-1094)) syntmp-tmp-1092) #f) (apply (lambda (syntmp-_-1099 syntmp-var-1100 syntmp-val-1101 syntmp-e1-1102 syntmp-e2-1103) (let ((syntmp-names-1104 (map (lambda (syntmp-x-1105) (syntmp-id-var-name-139 syntmp-x-1105 syntmp-w-1088)) syntmp-var-1100))) (begin (for-each (lambda (syntmp-id-1107 syntmp-n-1108) (let ((syntmp-t-1109 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1108 syntmp-r-1087 syntmp-mod-1090)))) (if (memv syntmp-t-1109 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1107 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) "identifier out of context")))) syntmp-var-1100 syntmp-names-1104) (syntmp-chi-body-157 (cons syntmp-e1-1102 syntmp-e2-1103) (syntmp-source-wrap-146 syntmp-e-1086 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) (syntmp-extend-env-111 syntmp-names-1104 (let ((syntmp-trans-r-1112 (syntmp-macros-only-env-113 syntmp-r-1087))) (map (lambda (syntmp-x-1113) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1113 syntmp-trans-r-1112 syntmp-w-1088 syntmp-mod-1090) syntmp-mod-1090))) syntmp-val-1101)) syntmp-r-1087) syntmp-w-1088 syntmp-mod-1090)))) syntmp-tmp-1092) ((lambda (syntmp-_-1115) (syntax-error (syntmp-source-wrap-146 syntmp-e-1086 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090))) syntmp-tmp-1091))) (syntax-dispatch syntmp-tmp-1091 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1086))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1116 syntmp-r-1117 syntmp-w-1118 syntmp-s-1119 syntmp-mod-1120) ((lambda (syntmp-tmp-1121) ((lambda (syntmp-tmp-1122) (if syntmp-tmp-1122 (apply (lambda (syntmp-_-1123 syntmp-e-1124) (syntmp-build-data-95 syntmp-s-1119 (syntmp-strip-164 syntmp-e-1124 syntmp-w-1118))) syntmp-tmp-1122) ((lambda (syntmp-_-1125) (syntax-error (syntmp-source-wrap-146 syntmp-e-1116 syntmp-w-1118 syntmp-s-1119 syntmp-mod-1120))) syntmp-tmp-1121))) (syntax-dispatch syntmp-tmp-1121 (quote (any any))))) syntmp-e-1116))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1133 (lambda (syntmp-x-1134) (let ((syntmp-t-1135 (car syntmp-x-1134))) (if (memv syntmp-t-1135 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1134) (syntmp-regen-1133 (caddr syntmp-x-1134)))) (if (memv syntmp-t-1135 (quote (map))) (let ((syntmp-ls-1136 (map syntmp-regen-1133 (cdr syntmp-x-1134)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1136) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1136))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1134)) (map syntmp-regen-1133 (cdr syntmp-x-1134)))))))))))) (syntmp-gen-vector-1132 (lambda (syntmp-x-1137) (cond ((eq? (car syntmp-x-1137) (quote list)) (cons (quote vector) (cdr syntmp-x-1137))) ((eq? (car syntmp-x-1137) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1137)))) (else (list (quote list->vector) syntmp-x-1137))))) (syntmp-gen-append-1131 (lambda (syntmp-x-1138 syntmp-y-1139) (if (equal? syntmp-y-1139 (quote (quote ()))) syntmp-x-1138 (list (quote append) syntmp-x-1138 syntmp-y-1139)))) (syntmp-gen-cons-1130 (lambda (syntmp-x-1140 syntmp-y-1141) (let ((syntmp-t-1142 (car syntmp-y-1141))) (if (memv syntmp-t-1142 (quote (quote))) (if (eq? (car syntmp-x-1140) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1140) (cadr syntmp-y-1141))) (if (eq? (cadr syntmp-y-1141) (quote ())) (list (quote list) syntmp-x-1140) (list (quote cons) syntmp-x-1140 syntmp-y-1141))) (if (memv syntmp-t-1142 (quote (list))) (cons (quote list) (cons syntmp-x-1140 (cdr syntmp-y-1141))) (list (quote cons) syntmp-x-1140 syntmp-y-1141)))))) (syntmp-gen-map-1129 (lambda (syntmp-e-1143 syntmp-map-env-1144) (let ((syntmp-formals-1145 (map cdr syntmp-map-env-1144)) (syntmp-actuals-1146 (map (lambda (syntmp-x-1147) (list (quote ref) (car syntmp-x-1147))) syntmp-map-env-1144))) (cond ((eq? (car syntmp-e-1143) (quote ref)) (car syntmp-actuals-1146)) ((andmap (lambda (syntmp-x-1148) (and (eq? (car syntmp-x-1148) (quote ref)) (memq (cadr syntmp-x-1148) syntmp-formals-1145))) (cdr syntmp-e-1143)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1143)) (map (let ((syntmp-r-1149 (map cons syntmp-formals-1145 syntmp-actuals-1146))) (lambda (syntmp-x-1150) (cdr (assq (cadr syntmp-x-1150) syntmp-r-1149)))) (cdr syntmp-e-1143))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1145 syntmp-e-1143) syntmp-actuals-1146))))))) (syntmp-gen-mappend-1128 (lambda (syntmp-e-1151 syntmp-map-env-1152) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1129 syntmp-e-1151 syntmp-map-env-1152)))) (syntmp-gen-ref-1127 (lambda (syntmp-src-1153 syntmp-var-1154 syntmp-level-1155 syntmp-maps-1156) (if (syntmp-fx=-87 syntmp-level-1155 0) (values syntmp-var-1154 syntmp-maps-1156) (if (null? syntmp-maps-1156) (syntax-error syntmp-src-1153 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1127 syntmp-src-1153 syntmp-var-1154 (syntmp-fx--86 syntmp-level-1155 1) (cdr syntmp-maps-1156))) (lambda (syntmp-outer-var-1157 syntmp-outer-maps-1158) (let ((syntmp-b-1159 (assq syntmp-outer-var-1157 (car syntmp-maps-1156)))) (if syntmp-b-1159 (values (cdr syntmp-b-1159) syntmp-maps-1156) (let ((syntmp-inner-var-1160 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1160 (cons (cons (cons syntmp-outer-var-1157 syntmp-inner-var-1160) (car syntmp-maps-1156)) syntmp-outer-maps-1158))))))))))) (syntmp-gen-syntax-1126 (lambda (syntmp-src-1161 syntmp-e-1162 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166) (if (syntmp-id?-117 syntmp-e-1162) (let ((syntmp-label-1167 (syntmp-id-var-name-139 syntmp-e-1162 (quote (()))))) (let ((syntmp-b-1168 (syntmp-lookup-114 syntmp-label-1167 syntmp-r-1163 syntmp-mod-1166))) (if (eq? (syntmp-binding-type-109 syntmp-b-1168) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1169 (syntmp-binding-value-110 syntmp-b-1168))) (syntmp-gen-ref-1127 syntmp-src-1161 (car syntmp-var.lev-1169) (cdr syntmp-var.lev-1169) syntmp-maps-1164))) (lambda (syntmp-var-1170 syntmp-maps-1171) (values (list (quote ref) syntmp-var-1170) syntmp-maps-1171))) (if (syntmp-ellipsis?-1165 syntmp-e-1162) (syntax-error syntmp-src-1161 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1162) syntmp-maps-1164))))) ((lambda (syntmp-tmp-1172) ((lambda (syntmp-tmp-1173) (if (if syntmp-tmp-1173 (apply (lambda (syntmp-dots-1174 syntmp-e-1175) (syntmp-ellipsis?-1165 syntmp-dots-1174)) syntmp-tmp-1173) #f) (apply (lambda (syntmp-dots-1176 syntmp-e-1177) (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-e-1177 syntmp-r-1163 syntmp-maps-1164 (lambda (syntmp-x-1178) #f) syntmp-mod-1166)) syntmp-tmp-1173) ((lambda (syntmp-tmp-1179) (if (if syntmp-tmp-1179 (apply (lambda (syntmp-x-1180 syntmp-dots-1181 syntmp-y-1182) (syntmp-ellipsis?-1165 syntmp-dots-1181)) syntmp-tmp-1179) #f) (apply (lambda (syntmp-x-1183 syntmp-dots-1184 syntmp-y-1185) (let syntmp-f-1186 ((syntmp-y-1187 syntmp-y-1185) (syntmp-k-1188 (lambda (syntmp-maps-1189) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-x-1183 syntmp-r-1163 (cons (quote ()) syntmp-maps-1189) syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-x-1190 syntmp-maps-1191) (if (null? (car syntmp-maps-1191)) (syntax-error syntmp-src-1161 "extra ellipsis in syntax form") (values (syntmp-gen-map-1129 syntmp-x-1190 (car syntmp-maps-1191)) (cdr syntmp-maps-1191)))))))) ((lambda (syntmp-tmp-1192) ((lambda (syntmp-tmp-1193) (if (if syntmp-tmp-1193 (apply (lambda (syntmp-dots-1194 syntmp-y-1195) (syntmp-ellipsis?-1165 syntmp-dots-1194)) syntmp-tmp-1193) #f) (apply (lambda (syntmp-dots-1196 syntmp-y-1197) (syntmp-f-1186 syntmp-y-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-k-1188 (cons (quote ()) syntmp-maps-1198))) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1161 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1128 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) syntmp-tmp-1193) ((lambda (syntmp-_-1201) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-y-1187 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-y-1202 syntmp-maps-1203) (call-with-values (lambda () (syntmp-k-1188 syntmp-maps-1203)) (lambda (syntmp-x-1204 syntmp-maps-1205) (values (syntmp-gen-append-1131 syntmp-x-1204 syntmp-y-1202) syntmp-maps-1205)))))) syntmp-tmp-1192))) (syntax-dispatch syntmp-tmp-1192 (quote (any . any))))) syntmp-y-1187))) syntmp-tmp-1179) ((lambda (syntmp-tmp-1206) (if syntmp-tmp-1206 (apply (lambda (syntmp-x-1207 syntmp-y-1208) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-x-1207 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-x-1209 syntmp-maps-1210) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-y-1208 syntmp-r-1163 syntmp-maps-1210 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-y-1211 syntmp-maps-1212) (values (syntmp-gen-cons-1130 syntmp-x-1209 syntmp-y-1211) syntmp-maps-1212)))))) syntmp-tmp-1206) ((lambda (syntmp-tmp-1213) (if syntmp-tmp-1213 (apply (lambda (syntmp-e1-1214 syntmp-e2-1215) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 (cons syntmp-e1-1214 syntmp-e2-1215) syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-e-1217 syntmp-maps-1218) (values (syntmp-gen-vector-1132 syntmp-e-1217) syntmp-maps-1218)))) syntmp-tmp-1213) ((lambda (syntmp-_-1219) (values (list (quote quote) syntmp-e-1162) syntmp-maps-1164)) syntmp-tmp-1172))) (syntax-dispatch syntmp-tmp-1172 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1172 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1172 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1172 (quote (any any))))) syntmp-e-1162))))) (lambda (syntmp-e-1220 syntmp-r-1221 syntmp-w-1222 syntmp-s-1223 syntmp-mod-1224) (let ((syntmp-e-1225 (syntmp-source-wrap-146 syntmp-e-1220 syntmp-w-1222 syntmp-s-1223 syntmp-mod-1224))) ((lambda (syntmp-tmp-1226) ((lambda (syntmp-tmp-1227) (if syntmp-tmp-1227 (apply (lambda (syntmp-_-1228 syntmp-x-1229) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-e-1225 syntmp-x-1229 syntmp-r-1221 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1224)) (lambda (syntmp-e-1230 syntmp-maps-1231) (syntmp-regen-1133 syntmp-e-1230)))) syntmp-tmp-1227) ((lambda (syntmp-_-1232) (syntax-error syntmp-e-1225)) syntmp-tmp-1226))) (syntax-dispatch syntmp-tmp-1226 (quote (any any))))) syntmp-e-1225))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1233 syntmp-r-1234 syntmp-w-1235 syntmp-s-1236 syntmp-mod-1237) ((lambda (syntmp-tmp-1238) ((lambda (syntmp-tmp-1239) (if syntmp-tmp-1239 (apply (lambda (syntmp-_-1240 syntmp-c-1241) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1233 syntmp-w-1235 syntmp-s-1236 syntmp-mod-1237) syntmp-c-1241 syntmp-r-1234 syntmp-w-1235 syntmp-mod-1237 (lambda (syntmp-vars-1242 syntmp-body-1243) (syntmp-build-annotated-94 syntmp-s-1236 (list (quote lambda) syntmp-vars-1242 syntmp-body-1243))))) syntmp-tmp-1239) (syntax-error syntmp-tmp-1238))) (syntax-dispatch syntmp-tmp-1238 (quote (any . any))))) syntmp-e-1233))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1244 (lambda (syntmp-e-1245 syntmp-r-1246 syntmp-w-1247 syntmp-s-1248 syntmp-mod-1249 syntmp-constructor-1250 syntmp-ids-1251 syntmp-vals-1252 syntmp-exps-1253) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1251)) (syntax-error syntmp-e-1245 "duplicate bound variable in") (let ((syntmp-labels-1254 (syntmp-gen-labels-123 syntmp-ids-1251)) (syntmp-new-vars-1255 (map syntmp-gen-var-165 syntmp-ids-1251))) (let ((syntmp-nw-1256 (syntmp-make-binding-wrap-134 syntmp-ids-1251 syntmp-labels-1254 syntmp-w-1247)) (syntmp-nr-1257 (syntmp-extend-var-env-112 syntmp-labels-1254 syntmp-new-vars-1255 syntmp-r-1246))) (syntmp-constructor-1250 syntmp-s-1248 syntmp-new-vars-1255 (map (lambda (syntmp-x-1258) (syntmp-chi-153 syntmp-x-1258 syntmp-r-1246 syntmp-w-1247 syntmp-mod-1249)) syntmp-vals-1252) (syntmp-chi-body-157 syntmp-exps-1253 (syntmp-source-wrap-146 syntmp-e-1245 syntmp-nw-1256 syntmp-s-1248 syntmp-mod-1249) syntmp-nr-1257 syntmp-nw-1256 syntmp-mod-1249)))))))) (lambda (syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263) ((lambda (syntmp-tmp-1264) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (apply (lambda (syntmp-_-1266 syntmp-id-1267 syntmp-val-1268 syntmp-e1-1269 syntmp-e2-1270) (syntmp-chi-let-1244 syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263 syntmp-build-let-97 syntmp-id-1267 syntmp-val-1268 (cons syntmp-e1-1269 syntmp-e2-1270))) syntmp-tmp-1265) ((lambda (syntmp-tmp-1274) (if (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-f-1276 syntmp-id-1277 syntmp-val-1278 syntmp-e1-1279 syntmp-e2-1280) (syntmp-id?-117 syntmp-f-1276)) syntmp-tmp-1274) #f) (apply (lambda (syntmp-_-1281 syntmp-f-1282 syntmp-id-1283 syntmp-val-1284 syntmp-e1-1285 syntmp-e2-1286) (syntmp-chi-let-1244 syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263 syntmp-build-named-let-98 (cons syntmp-f-1282 syntmp-id-1283) syntmp-val-1284 (cons syntmp-e1-1285 syntmp-e2-1286))) syntmp-tmp-1274) ((lambda (syntmp-_-1290) (syntax-error (syntmp-source-wrap-146 syntmp-e-1259 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263))) syntmp-tmp-1264))) (syntax-dispatch syntmp-tmp-1264 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1264 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1259)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1291 syntmp-r-1292 syntmp-w-1293 syntmp-s-1294 syntmp-mod-1295) ((lambda (syntmp-tmp-1296) ((lambda (syntmp-tmp-1297) (if syntmp-tmp-1297 (apply (lambda (syntmp-_-1298 syntmp-id-1299 syntmp-val-1300 syntmp-e1-1301 syntmp-e2-1302) (let ((syntmp-ids-1303 syntmp-id-1299)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1303)) (syntax-error syntmp-e-1291 "duplicate bound variable in") (let ((syntmp-labels-1305 (syntmp-gen-labels-123 syntmp-ids-1303)) (syntmp-new-vars-1306 (map syntmp-gen-var-165 syntmp-ids-1303))) (let ((syntmp-w-1307 (syntmp-make-binding-wrap-134 syntmp-ids-1303 syntmp-labels-1305 syntmp-w-1293)) (syntmp-r-1308 (syntmp-extend-var-env-112 syntmp-labels-1305 syntmp-new-vars-1306 syntmp-r-1292))) (syntmp-build-letrec-99 syntmp-s-1294 syntmp-new-vars-1306 (map (lambda (syntmp-x-1309) (syntmp-chi-153 syntmp-x-1309 syntmp-r-1308 syntmp-w-1307 syntmp-mod-1295)) syntmp-val-1300) (syntmp-chi-body-157 (cons syntmp-e1-1301 syntmp-e2-1302) (syntmp-source-wrap-146 syntmp-e-1291 syntmp-w-1307 syntmp-s-1294 syntmp-mod-1295) syntmp-r-1308 syntmp-w-1307 syntmp-mod-1295))))))) syntmp-tmp-1297) ((lambda (syntmp-_-1312) (syntax-error (syntmp-source-wrap-146 syntmp-e-1291 syntmp-w-1293 syntmp-s-1294 syntmp-mod-1295))) syntmp-tmp-1296))) (syntax-dispatch syntmp-tmp-1296 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1291))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1313 syntmp-r-1314 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-tmp-1319) (if (if syntmp-tmp-1319 (apply (lambda (syntmp-_-1320 syntmp-id-1321 syntmp-val-1322) (syntmp-id?-117 syntmp-id-1321)) syntmp-tmp-1319) #f) (apply (lambda (syntmp-_-1323 syntmp-id-1324 syntmp-val-1325) (let ((syntmp-val-1326 (syntmp-chi-153 syntmp-val-1325 syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317)) (syntmp-n-1327 (syntmp-id-var-name-139 syntmp-id-1324 syntmp-w-1315))) (let ((syntmp-b-1328 (syntmp-lookup-114 syntmp-n-1327 syntmp-r-1314 syntmp-mod-1317))) (let ((syntmp-t-1329 (syntmp-binding-type-109 syntmp-b-1328))) (if (memv syntmp-t-1329 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1316 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1328) syntmp-val-1326)) (if (memv syntmp-t-1329 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1316 (list (quote set!) (make-module-ref syntmp-mod-1317 syntmp-n-1327 #f) syntmp-val-1326)) (if (memv syntmp-t-1329 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1324 syntmp-w-1315 syntmp-mod-1317) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1313 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317))))))))) syntmp-tmp-1319) ((lambda (syntmp-tmp-1330) (if syntmp-tmp-1330 (apply (lambda (syntmp-_-1331 syntmp-getter-1332 syntmp-arg-1333 syntmp-val-1334) (syntmp-build-annotated-94 syntmp-s-1316 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-getter-1332) syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317) (map (lambda (syntmp-e-1335) (syntmp-chi-153 syntmp-e-1335 syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317)) (append syntmp-arg-1333 (list syntmp-val-1334)))))) syntmp-tmp-1330) ((lambda (syntmp-_-1337) (syntax-error (syntmp-source-wrap-146 syntmp-e-1313 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317))) syntmp-tmp-1318))) (syntax-dispatch syntmp-tmp-1318 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1318 (quote (any any any))))) syntmp-e-1313))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1341 (lambda (syntmp-x-1342 syntmp-keys-1343 syntmp-clauses-1344 syntmp-r-1345 syntmp-mod-1346) (if (null? syntmp-clauses-1344) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1342)) ((lambda (syntmp-tmp-1347) ((lambda (syntmp-tmp-1348) (if syntmp-tmp-1348 (apply (lambda (syntmp-pat-1349 syntmp-exp-1350) (if (and (syntmp-id?-117 syntmp-pat-1349) (andmap (lambda (syntmp-x-1351) (not (syntmp-free-id=?-140 syntmp-pat-1349 syntmp-x-1351))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1343))) (let ((syntmp-labels-1352 (list (syntmp-gen-label-122))) (syntmp-var-1353 (syntmp-gen-var-165 syntmp-pat-1349))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1353) (syntmp-chi-153 syntmp-exp-1350 (syntmp-extend-env-111 syntmp-labels-1352 (list (cons (quote syntax) (cons syntmp-var-1353 0))) syntmp-r-1345) (syntmp-make-binding-wrap-134 (list syntmp-pat-1349) syntmp-labels-1352 (quote (()))) syntmp-mod-1346))) syntmp-x-1342))) (syntmp-gen-clause-1340 syntmp-x-1342 syntmp-keys-1343 (cdr syntmp-clauses-1344) syntmp-r-1345 syntmp-pat-1349 #t syntmp-exp-1350 syntmp-mod-1346))) syntmp-tmp-1348) ((lambda (syntmp-tmp-1354) (if syntmp-tmp-1354 (apply (lambda (syntmp-pat-1355 syntmp-fender-1356 syntmp-exp-1357) (syntmp-gen-clause-1340 syntmp-x-1342 syntmp-keys-1343 (cdr syntmp-clauses-1344) syntmp-r-1345 syntmp-pat-1355 syntmp-fender-1356 syntmp-exp-1357 syntmp-mod-1346)) syntmp-tmp-1354) ((lambda (syntmp-_-1358) (syntax-error (car syntmp-clauses-1344) "invalid syntax-case clause")) syntmp-tmp-1347))) (syntax-dispatch syntmp-tmp-1347 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1347 (quote (any any))))) (car syntmp-clauses-1344))))) (syntmp-gen-clause-1340 (lambda (syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-pat-1363 syntmp-fender-1364 syntmp-exp-1365 syntmp-mod-1366) (call-with-values (lambda () (syntmp-convert-pattern-1338 syntmp-pat-1363 syntmp-keys-1360)) (lambda (syntmp-p-1367 syntmp-pvars-1368) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1368))) (syntax-error syntmp-pat-1363 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1369) (not (syntmp-ellipsis?-162 (car syntmp-x-1369)))) syntmp-pvars-1368)) (syntax-error syntmp-pat-1363 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1370 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1370) (let ((syntmp-y-1371 (syntmp-build-annotated-94 #f syntmp-y-1370))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1372) ((lambda (syntmp-tmp-1373) (if syntmp-tmp-1373 (apply (lambda () syntmp-y-1371) syntmp-tmp-1373) ((lambda (syntmp-_-1374) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1371 (syntmp-build-dispatch-call-1339 syntmp-pvars-1368 syntmp-fender-1364 syntmp-y-1371 syntmp-r-1362 syntmp-mod-1366) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1372))) (syntax-dispatch syntmp-tmp-1372 (quote #(atom #t))))) syntmp-fender-1364) (syntmp-build-dispatch-call-1339 syntmp-pvars-1368 syntmp-exp-1365 syntmp-y-1371 syntmp-r-1362 syntmp-mod-1366) (syntmp-gen-syntax-case-1341 syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1366)))))) (if (eq? syntmp-p-1367 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1359)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1359 (syntmp-build-data-95 #f syntmp-p-1367))))))))))))) (syntmp-build-dispatch-call-1339 (lambda (syntmp-pvars-1375 syntmp-exp-1376 syntmp-y-1377 syntmp-r-1378 syntmp-mod-1379) (let ((syntmp-ids-1380 (map car syntmp-pvars-1375)) (syntmp-levels-1381 (map cdr syntmp-pvars-1375))) (let ((syntmp-labels-1382 (syntmp-gen-labels-123 syntmp-ids-1380)) (syntmp-new-vars-1383 (map syntmp-gen-var-165 syntmp-ids-1380))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1383 (syntmp-chi-153 syntmp-exp-1376 (syntmp-extend-env-111 syntmp-labels-1382 (map (lambda (syntmp-var-1384 syntmp-level-1385) (cons (quote syntax) (cons syntmp-var-1384 syntmp-level-1385))) syntmp-new-vars-1383 (map cdr syntmp-pvars-1375)) syntmp-r-1378) (syntmp-make-binding-wrap-134 syntmp-ids-1380 syntmp-labels-1382 (quote (()))) syntmp-mod-1379))) syntmp-y-1377)))))) (syntmp-convert-pattern-1338 (lambda (syntmp-pattern-1386 syntmp-keys-1387) (let syntmp-cvt-1388 ((syntmp-p-1389 syntmp-pattern-1386) (syntmp-n-1390 0) (syntmp-ids-1391 (quote ()))) (if (syntmp-id?-117 syntmp-p-1389) (if (syntmp-bound-id-member?-144 syntmp-p-1389 syntmp-keys-1387) (values (vector (quote free-id) syntmp-p-1389) syntmp-ids-1391) (values (quote any) (cons (cons syntmp-p-1389 syntmp-n-1390) syntmp-ids-1391))) ((lambda (syntmp-tmp-1392) ((lambda (syntmp-tmp-1393) (if (if syntmp-tmp-1393 (apply (lambda (syntmp-x-1394 syntmp-dots-1395) (syntmp-ellipsis?-162 syntmp-dots-1395)) syntmp-tmp-1393) #f) (apply (lambda (syntmp-x-1396 syntmp-dots-1397) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1396 (syntmp-fx+-85 syntmp-n-1390 1) syntmp-ids-1391)) (lambda (syntmp-p-1398 syntmp-ids-1399) (values (if (eq? syntmp-p-1398 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1398)) syntmp-ids-1399)))) syntmp-tmp-1393) ((lambda (syntmp-tmp-1400) (if syntmp-tmp-1400 (apply (lambda (syntmp-x-1401 syntmp-y-1402) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-y-1402 syntmp-n-1390 syntmp-ids-1391)) (lambda (syntmp-y-1403 syntmp-ids-1404) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1401 syntmp-n-1390 syntmp-ids-1404)) (lambda (syntmp-x-1405 syntmp-ids-1406) (values (cons syntmp-x-1405 syntmp-y-1403) syntmp-ids-1406)))))) syntmp-tmp-1400) ((lambda (syntmp-tmp-1407) (if syntmp-tmp-1407 (apply (lambda () (values (quote ()) syntmp-ids-1391)) syntmp-tmp-1407) ((lambda (syntmp-tmp-1408) (if syntmp-tmp-1408 (apply (lambda (syntmp-x-1409) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1409 syntmp-n-1390 syntmp-ids-1391)) (lambda (syntmp-p-1411 syntmp-ids-1412) (values (vector (quote vector) syntmp-p-1411) syntmp-ids-1412)))) syntmp-tmp-1408) ((lambda (syntmp-x-1413) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1389 (quote (())))) syntmp-ids-1391)) syntmp-tmp-1392))) (syntax-dispatch syntmp-tmp-1392 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1392 (quote ()))))) (syntax-dispatch syntmp-tmp-1392 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1392 (quote (any any))))) syntmp-p-1389)))))) (lambda (syntmp-e-1414 syntmp-r-1415 syntmp-w-1416 syntmp-s-1417 syntmp-mod-1418) (let ((syntmp-e-1419 (syntmp-source-wrap-146 syntmp-e-1414 syntmp-w-1416 syntmp-s-1417 syntmp-mod-1418))) ((lambda (syntmp-tmp-1420) ((lambda (syntmp-tmp-1421) (if syntmp-tmp-1421 (apply (lambda (syntmp-_-1422 syntmp-val-1423 syntmp-key-1424 syntmp-m-1425) (if (andmap (lambda (syntmp-x-1426) (and (syntmp-id?-117 syntmp-x-1426) (not (syntmp-ellipsis?-162 syntmp-x-1426)))) syntmp-key-1424) (let ((syntmp-x-1428 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1417 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1428) (syntmp-gen-syntax-case-1341 (syntmp-build-annotated-94 #f syntmp-x-1428) syntmp-key-1424 syntmp-m-1425 syntmp-r-1415 syntmp-mod-1418))) (syntmp-chi-153 syntmp-val-1423 syntmp-r-1415 (quote (())) syntmp-mod-1418)))) (syntax-error syntmp-e-1419 "invalid literals list in"))) syntmp-tmp-1421) (syntax-error syntmp-tmp-1420))) (syntax-dispatch syntmp-tmp-1420 (quote (any any each-any . each-any))))) syntmp-e-1419))))) (set! sc-expand (let ((syntmp-m-1431 (quote e)) (syntmp-esew-1432 (quote (eval)))) (lambda (syntmp-x-1433) (if (and (pair? syntmp-x-1433) (equal? (car syntmp-x-1433) syntmp-noexpand-84)) (cadr syntmp-x-1433) (syntmp-chi-top-152 syntmp-x-1433 (quote ()) (quote ((top))) syntmp-m-1431 syntmp-esew-1432 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1434 (quote e)) (syntmp-esew-1435 (quote (eval)))) (lambda (syntmp-x-1437 . syntmp-rest-1436) (if (and (pair? syntmp-x-1437) (equal? (car syntmp-x-1437) syntmp-noexpand-84)) (cadr syntmp-x-1437) (syntmp-chi-top-152 syntmp-x-1437 (quote ()) (quote ((top))) (if (null? syntmp-rest-1436) syntmp-m-1434 (car syntmp-rest-1436)) (if (or (null? syntmp-rest-1436) (null? (cdr syntmp-rest-1436))) syntmp-esew-1435 (cadr syntmp-rest-1436)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1438) (syntmp-nonsymbol-id?-116 syntmp-x-1438))) (set! datum->syntax-object (lambda (syntmp-id-1439 syntmp-datum-1440) (syntmp-make-syntax-object-100 syntmp-datum-1440 (syntmp-syntax-object-wrap-103 syntmp-id-1439) #f))) (set! syntax-object->datum (lambda (syntmp-x-1441) (syntmp-strip-164 syntmp-x-1441 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1442) (begin (let ((syntmp-x-1443 syntmp-ls-1442)) (if (not (list? syntmp-x-1443)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1443))) (map (lambda (syntmp-x-1444) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1442)))) (set! free-identifier=? (lambda (syntmp-x-1445 syntmp-y-1446) (begin (let ((syntmp-x-1447 syntmp-x-1445)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1447)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1447))) (let ((syntmp-x-1448 syntmp-y-1446)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1448)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1448))) (syntmp-free-id=?-140 syntmp-x-1445 syntmp-y-1446)))) (set! bound-identifier=? (lambda (syntmp-x-1449 syntmp-y-1450) (begin (let ((syntmp-x-1451 syntmp-x-1449)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1451)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1451))) (let ((syntmp-x-1452 syntmp-y-1450)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1452)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1452))) (syntmp-bound-id=?-141 syntmp-x-1449 syntmp-y-1450)))) (set! syntax-error (lambda (syntmp-object-1454 . syntmp-messages-1453) (begin (for-each (lambda (syntmp-x-1455) (let ((syntmp-x-1456 syntmp-x-1455)) (if (not (string? syntmp-x-1456)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1456)))) syntmp-messages-1453) (let ((syntmp-message-1457 (if (null? syntmp-messages-1453) "invalid syntax" (apply string-append syntmp-messages-1453)))) (syntmp-error-hook-91 #f syntmp-message-1457 (syntmp-strip-164 syntmp-object-1454 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1458 syntmp-v-1459) (begin (let ((syntmp-x-1460 syntmp-sym-1458)) (if (not (symbol? syntmp-x-1460)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1460))) (let ((syntmp-x-1461 syntmp-v-1459)) (if (not (procedure? syntmp-x-1461)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1461))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1458 syntmp-v-1459)))) (letrec ((syntmp-match-1466 (lambda (syntmp-e-1467 syntmp-p-1468 syntmp-w-1469 syntmp-r-1470 syntmp-mod-1471) (cond ((not syntmp-r-1470) #f) ((eq? syntmp-p-1468 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1467 syntmp-w-1469 syntmp-mod-1471) syntmp-r-1470)) ((syntmp-syntax-object?-101 syntmp-e-1467) (syntmp-match*-1465 (let ((syntmp-e-1472 (syntmp-syntax-object-expression-102 syntmp-e-1467))) (if (annotation? syntmp-e-1472) (annotation-expression syntmp-e-1472) syntmp-e-1472)) syntmp-p-1468 (syntmp-join-wraps-136 syntmp-w-1469 (syntmp-syntax-object-wrap-103 syntmp-e-1467)) syntmp-r-1470 (syntmp-syntax-object-module-104 syntmp-e-1467))) (else (syntmp-match*-1465 (let ((syntmp-e-1473 syntmp-e-1467)) (if (annotation? syntmp-e-1473) (annotation-expression syntmp-e-1473) syntmp-e-1473)) syntmp-p-1468 syntmp-w-1469 syntmp-r-1470 syntmp-mod-1471))))) (syntmp-match*-1465 (lambda (syntmp-e-1474 syntmp-p-1475 syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478) (cond ((null? syntmp-p-1475) (and (null? syntmp-e-1474) syntmp-r-1477)) ((pair? syntmp-p-1475) (and (pair? syntmp-e-1474) (syntmp-match-1466 (car syntmp-e-1474) (car syntmp-p-1475) syntmp-w-1476 (syntmp-match-1466 (cdr syntmp-e-1474) (cdr syntmp-p-1475) syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478) syntmp-mod-1478))) ((eq? syntmp-p-1475 (quote each-any)) (let ((syntmp-l-1479 (syntmp-match-each-any-1463 syntmp-e-1474 syntmp-w-1476 syntmp-mod-1478))) (and syntmp-l-1479 (cons syntmp-l-1479 syntmp-r-1477)))) (else (let ((syntmp-t-1480 (vector-ref syntmp-p-1475 0))) (if (memv syntmp-t-1480 (quote (each))) (if (null? syntmp-e-1474) (syntmp-match-empty-1464 (vector-ref syntmp-p-1475 1) syntmp-r-1477) (let ((syntmp-l-1481 (syntmp-match-each-1462 syntmp-e-1474 (vector-ref syntmp-p-1475 1) syntmp-w-1476 syntmp-mod-1478))) (and syntmp-l-1481 (let syntmp-collect-1482 ((syntmp-l-1483 syntmp-l-1481)) (if (null? (car syntmp-l-1483)) syntmp-r-1477 (cons (map car syntmp-l-1483) (syntmp-collect-1482 (map cdr syntmp-l-1483)))))))) (if (memv syntmp-t-1480 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1474) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1474 syntmp-w-1476 syntmp-mod-1478) (vector-ref syntmp-p-1475 1)) syntmp-r-1477) (if (memv syntmp-t-1480 (quote (atom))) (and (equal? (vector-ref syntmp-p-1475 1) (syntmp-strip-164 syntmp-e-1474 syntmp-w-1476)) syntmp-r-1477) (if (memv syntmp-t-1480 (quote (vector))) (and (vector? syntmp-e-1474) (syntmp-match-1466 (vector->list syntmp-e-1474) (vector-ref syntmp-p-1475 1) syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478))))))))))) (syntmp-match-empty-1464 (lambda (syntmp-p-1484 syntmp-r-1485) (cond ((null? syntmp-p-1484) syntmp-r-1485) ((eq? syntmp-p-1484 (quote any)) (cons (quote ()) syntmp-r-1485)) ((pair? syntmp-p-1484) (syntmp-match-empty-1464 (car syntmp-p-1484) (syntmp-match-empty-1464 (cdr syntmp-p-1484) syntmp-r-1485))) ((eq? syntmp-p-1484 (quote each-any)) (cons (quote ()) syntmp-r-1485)) (else (let ((syntmp-t-1486 (vector-ref syntmp-p-1484 0))) (if (memv syntmp-t-1486 (quote (each))) (syntmp-match-empty-1464 (vector-ref syntmp-p-1484 1) syntmp-r-1485) (if (memv syntmp-t-1486 (quote (free-id atom))) syntmp-r-1485 (if (memv syntmp-t-1486 (quote (vector))) (syntmp-match-empty-1464 (vector-ref syntmp-p-1484 1) syntmp-r-1485))))))))) (syntmp-match-each-any-1463 (lambda (syntmp-e-1487 syntmp-w-1488 syntmp-mod-1489) (cond ((annotation? syntmp-e-1487) (syntmp-match-each-any-1463 (annotation-expression syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489)) ((pair? syntmp-e-1487) (let ((syntmp-l-1490 (syntmp-match-each-any-1463 (cdr syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489))) (and syntmp-l-1490 (cons (syntmp-wrap-145 (car syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489) syntmp-l-1490)))) ((null? syntmp-e-1487) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1487) (syntmp-match-each-any-1463 (syntmp-syntax-object-expression-102 syntmp-e-1487) (syntmp-join-wraps-136 syntmp-w-1488 (syntmp-syntax-object-wrap-103 syntmp-e-1487)) syntmp-mod-1489)) (else #f)))) (syntmp-match-each-1462 (lambda (syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494) (cond ((annotation? syntmp-e-1491) (syntmp-match-each-1462 (annotation-expression syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494)) ((pair? syntmp-e-1491) (let ((syntmp-first-1495 (syntmp-match-1466 (car syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 (quote ()) syntmp-mod-1494))) (and syntmp-first-1495 (let ((syntmp-rest-1496 (syntmp-match-each-1462 (cdr syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494))) (and syntmp-rest-1496 (cons syntmp-first-1495 syntmp-rest-1496)))))) ((null? syntmp-e-1491) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1491) (syntmp-match-each-1462 (syntmp-syntax-object-expression-102 syntmp-e-1491) syntmp-p-1492 (syntmp-join-wraps-136 syntmp-w-1493 (syntmp-syntax-object-wrap-103 syntmp-e-1491)) (syntmp-syntax-object-module-104 syntmp-e-1491))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1497 syntmp-p-1498) (cond ((eq? syntmp-p-1498 (quote any)) (list syntmp-e-1497)) ((syntmp-syntax-object?-101 syntmp-e-1497) (syntmp-match*-1465 (let ((syntmp-e-1499 (syntmp-syntax-object-expression-102 syntmp-e-1497))) (if (annotation? syntmp-e-1499) (annotation-expression syntmp-e-1499) syntmp-e-1499)) syntmp-p-1498 (syntmp-syntax-object-wrap-103 syntmp-e-1497) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1497))) (else (syntmp-match*-1465 (let ((syntmp-e-1500 syntmp-e-1497)) (if (annotation? syntmp-e-1500) (annotation-expression syntmp-e-1500) syntmp-e-1500)) syntmp-p-1498 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1501) ((lambda (syntmp-tmp-1502) ((lambda (syntmp-tmp-1503) (if syntmp-tmp-1503 (apply (lambda (syntmp-_-1504 syntmp-e1-1505 syntmp-e2-1506) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1505 syntmp-e2-1506))) syntmp-tmp-1503) ((lambda (syntmp-tmp-1508) (if syntmp-tmp-1508 (apply (lambda (syntmp-_-1509 syntmp-out-1510 syntmp-in-1511 syntmp-e1-1512 syntmp-e2-1513) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1511 (quote ()) (list syntmp-out-1510 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1512 syntmp-e2-1513))))) syntmp-tmp-1508) ((lambda (syntmp-tmp-1515) (if syntmp-tmp-1515 (apply (lambda (syntmp-_-1516 syntmp-out-1517 syntmp-in-1518 syntmp-e1-1519 syntmp-e2-1520) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1518) (quote ()) (list syntmp-out-1517 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1519 syntmp-e2-1520))))) syntmp-tmp-1515) (syntax-error syntmp-tmp-1502))) (syntax-dispatch syntmp-tmp-1502 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1502 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1502 (quote (any () any . each-any))))) syntmp-x-1501))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-k-1546 syntmp-keyword-1547 syntmp-pattern-1548 syntmp-template-1549) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1546 (map (lambda (syntmp-tmp-1552 syntmp-tmp-1551) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1551) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1552))) syntmp-template-1549 syntmp-pattern-1548)))))) syntmp-tmp-1544) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1542))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1563) ((lambda (syntmp-tmp-1564) ((lambda (syntmp-tmp-1565) (if (if syntmp-tmp-1565 (apply (lambda (syntmp-let*-1566 syntmp-x-1567 syntmp-v-1568 syntmp-e1-1569 syntmp-e2-1570) (andmap identifier? syntmp-x-1567)) syntmp-tmp-1565) #f) (apply (lambda (syntmp-let*-1572 syntmp-x-1573 syntmp-v-1574 syntmp-e1-1575 syntmp-e2-1576) (let syntmp-f-1577 ((syntmp-bindings-1578 (map list syntmp-x-1573 syntmp-v-1574))) (if (null? syntmp-bindings-1578) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1575 syntmp-e2-1576))) ((lambda (syntmp-tmp-1582) ((lambda (syntmp-tmp-1583) (if syntmp-tmp-1583 (apply (lambda (syntmp-body-1584 syntmp-binding-1585) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1585) syntmp-body-1584)) syntmp-tmp-1583) (syntax-error syntmp-tmp-1582))) (syntax-dispatch syntmp-tmp-1582 (quote (any any))))) (list (syntmp-f-1577 (cdr syntmp-bindings-1578)) (car syntmp-bindings-1578)))))) syntmp-tmp-1565) (syntax-error syntmp-tmp-1564))) (syntax-dispatch syntmp-tmp-1564 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1563))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1605) ((lambda (syntmp-tmp-1606) ((lambda (syntmp-tmp-1607) (if syntmp-tmp-1607 (apply (lambda (syntmp-_-1608 syntmp-var-1609 syntmp-init-1610 syntmp-step-1611 syntmp-e0-1612 syntmp-e1-1613 syntmp-c-1614) ((lambda (syntmp-tmp-1615) ((lambda (syntmp-tmp-1616) (if syntmp-tmp-1616 (apply (lambda (syntmp-step-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-tmp-1619) (if syntmp-tmp-1619 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1609 syntmp-init-1610) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1612) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1614 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1617))))))) syntmp-tmp-1619) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-e1-1625 syntmp-e2-1626) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1609 syntmp-init-1610) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1612 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1625 syntmp-e2-1626)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1614 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1617))))))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1618))) (syntax-dispatch syntmp-tmp-1618 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1618 (quote ())))) syntmp-e1-1613)) syntmp-tmp-1616) (syntax-error syntmp-tmp-1615))) (syntax-dispatch syntmp-tmp-1615 (quote each-any)))) (map (lambda (syntmp-v-1633 syntmp-s-1634) ((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda () syntmp-v-1633) syntmp-tmp-1636) ((lambda (syntmp-tmp-1637) (if syntmp-tmp-1637 (apply (lambda (syntmp-e-1638) syntmp-e-1638) syntmp-tmp-1637) ((lambda (syntmp-_-1639) (syntax-error syntmp-orig-x-1605)) syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-s-1634)) syntmp-var-1609 syntmp-step-1611))) syntmp-tmp-1607) (syntax-error syntmp-tmp-1606))) (syntax-dispatch syntmp-tmp-1606 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1605))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1667 (lambda (syntmp-x-1671 syntmp-y-1672) ((lambda (syntmp-tmp-1673) ((lambda (syntmp-tmp-1674) (if syntmp-tmp-1674 (apply (lambda (syntmp-x-1675 syntmp-y-1676) ((lambda (syntmp-tmp-1677) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-dy-1679) ((lambda (syntmp-tmp-1680) ((lambda (syntmp-tmp-1681) (if syntmp-tmp-1681 (apply (lambda (syntmp-dx-1682) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1682 syntmp-dy-1679))) syntmp-tmp-1681) ((lambda (syntmp-_-1683) (if (null? syntmp-dy-1679) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675 syntmp-y-1676))) syntmp-tmp-1680))) (syntax-dispatch syntmp-tmp-1680 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1675)) syntmp-tmp-1678) ((lambda (syntmp-tmp-1684) (if syntmp-tmp-1684 (apply (lambda (syntmp-stuff-1685) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1675 syntmp-stuff-1685))) syntmp-tmp-1684) ((lambda (syntmp-else-1686) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675 syntmp-y-1676)) syntmp-tmp-1677))) (syntax-dispatch syntmp-tmp-1677 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1677 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1676)) syntmp-tmp-1674) (syntax-error syntmp-tmp-1673))) (syntax-dispatch syntmp-tmp-1673 (quote (any any))))) (list syntmp-x-1671 syntmp-y-1672)))) (syntmp-quasiappend-1668 (lambda (syntmp-x-1687 syntmp-y-1688) ((lambda (syntmp-tmp-1689) ((lambda (syntmp-tmp-1690) (if syntmp-tmp-1690 (apply (lambda (syntmp-x-1691 syntmp-y-1692) ((lambda (syntmp-tmp-1693) ((lambda (syntmp-tmp-1694) (if syntmp-tmp-1694 (apply (lambda () syntmp-x-1691) syntmp-tmp-1694) ((lambda (syntmp-_-1695) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1691 syntmp-y-1692)) syntmp-tmp-1693))) (syntax-dispatch syntmp-tmp-1693 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1692)) syntmp-tmp-1690) (syntax-error syntmp-tmp-1689))) (syntax-dispatch syntmp-tmp-1689 (quote (any any))))) (list syntmp-x-1687 syntmp-y-1688)))) (syntmp-quasivector-1669 (lambda (syntmp-x-1696) ((lambda (syntmp-tmp-1697) ((lambda (syntmp-x-1698) ((lambda (syntmp-tmp-1699) ((lambda (syntmp-tmp-1700) (if syntmp-tmp-1700 (apply (lambda (syntmp-x-1701) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1701))) syntmp-tmp-1700) ((lambda (syntmp-tmp-1703) (if syntmp-tmp-1703 (apply (lambda (syntmp-x-1704) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1704)) syntmp-tmp-1703) ((lambda (syntmp-_-1706) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1698)) syntmp-tmp-1699))) (syntax-dispatch syntmp-tmp-1699 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1699 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1698)) syntmp-tmp-1697)) syntmp-x-1696))) (syntmp-quasi-1670 (lambda (syntmp-p-1707 syntmp-lev-1708) ((lambda (syntmp-tmp-1709) ((lambda (syntmp-tmp-1710) (if syntmp-tmp-1710 (apply (lambda (syntmp-p-1711) (if (= syntmp-lev-1708 0) syntmp-p-1711 (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1711) (- syntmp-lev-1708 1))))) syntmp-tmp-1710) ((lambda (syntmp-tmp-1712) (if syntmp-tmp-1712 (apply (lambda (syntmp-p-1713 syntmp-q-1714) (if (= syntmp-lev-1708 0) (syntmp-quasiappend-1668 syntmp-p-1713 (syntmp-quasi-1670 syntmp-q-1714 syntmp-lev-1708)) (syntmp-quasicons-1667 (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1713) (- syntmp-lev-1708 1))) (syntmp-quasi-1670 syntmp-q-1714 syntmp-lev-1708)))) syntmp-tmp-1712) ((lambda (syntmp-tmp-1715) (if syntmp-tmp-1715 (apply (lambda (syntmp-p-1716) (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1716) (+ syntmp-lev-1708 1)))) syntmp-tmp-1715) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-p-1718 syntmp-q-1719) (syntmp-quasicons-1667 (syntmp-quasi-1670 syntmp-p-1718 syntmp-lev-1708) (syntmp-quasi-1670 syntmp-q-1719 syntmp-lev-1708))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (syntmp-quasivector-1669 (syntmp-quasi-1670 syntmp-x-1721 syntmp-lev-1708))) syntmp-tmp-1720) ((lambda (syntmp-p-1723) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1723)) syntmp-tmp-1709))) (syntax-dispatch syntmp-tmp-1709 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1709 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1707)))) (lambda (syntmp-x-1724) ((lambda (syntmp-tmp-1725) ((lambda (syntmp-tmp-1726) (if syntmp-tmp-1726 (apply (lambda (syntmp-_-1727 syntmp-e-1728) (syntmp-quasi-1670 syntmp-e-1728 0)) syntmp-tmp-1726) (syntax-error syntmp-tmp-1725))) (syntax-dispatch syntmp-tmp-1725 (quote (any any))))) syntmp-x-1724)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1788) (letrec ((syntmp-read-file-1789 (lambda (syntmp-fn-1790 syntmp-k-1791) (let ((syntmp-p-1792 (open-input-file syntmp-fn-1790))) (let syntmp-f-1793 ((syntmp-x-1794 (read syntmp-p-1792))) (if (eof-object? syntmp-x-1794) (begin (close-input-port syntmp-p-1792) (quote ())) (cons (datum->syntax-object syntmp-k-1791 syntmp-x-1794) (syntmp-f-1793 (read syntmp-p-1792))))))))) ((lambda (syntmp-tmp-1795) ((lambda (syntmp-tmp-1796) (if syntmp-tmp-1796 (apply (lambda (syntmp-k-1797 syntmp-filename-1798) (let ((syntmp-fn-1799 (syntax-object->datum syntmp-filename-1798))) ((lambda (syntmp-tmp-1800) ((lambda (syntmp-tmp-1801) (if syntmp-tmp-1801 (apply (lambda (syntmp-exp-1802) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1802)) syntmp-tmp-1801) (syntax-error syntmp-tmp-1800))) (syntax-dispatch syntmp-tmp-1800 (quote each-any)))) (syntmp-read-file-1789 syntmp-fn-1799 syntmp-k-1797)))) syntmp-tmp-1796) (syntax-error syntmp-tmp-1795))) (syntax-dispatch syntmp-tmp-1795 (quote (any any))))) syntmp-x-1788)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1819) ((lambda (syntmp-tmp-1820) ((lambda (syntmp-tmp-1821) (if syntmp-tmp-1821 (apply (lambda (syntmp-_-1822 syntmp-e-1823) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1823))) syntmp-tmp-1821) (syntax-error syntmp-tmp-1820))) (syntax-dispatch syntmp-tmp-1820 (quote (any any))))) syntmp-x-1819))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1829) ((lambda (syntmp-tmp-1830) ((lambda (syntmp-tmp-1831) (if syntmp-tmp-1831 (apply (lambda (syntmp-_-1832 syntmp-e-1833) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1833))) syntmp-tmp-1831) (syntax-error syntmp-tmp-1830))) (syntax-dispatch syntmp-tmp-1830 (quote (any any))))) syntmp-x-1829))) -(install-global-transformer (quote case) (lambda (syntmp-x-1839) ((lambda (syntmp-tmp-1840) ((lambda (syntmp-tmp-1841) (if syntmp-tmp-1841 (apply (lambda (syntmp-_-1842 syntmp-e-1843 syntmp-m1-1844 syntmp-m2-1845) ((lambda (syntmp-tmp-1846) ((lambda (syntmp-body-1847) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1843)) syntmp-body-1847)) syntmp-tmp-1846)) (let syntmp-f-1848 ((syntmp-clause-1849 syntmp-m1-1844) (syntmp-clauses-1850 syntmp-m2-1845)) (if (null? syntmp-clauses-1850) ((lambda (syntmp-tmp-1852) ((lambda (syntmp-tmp-1853) (if syntmp-tmp-1853 (apply (lambda (syntmp-e1-1854 syntmp-e2-1855) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1854 syntmp-e2-1855))) syntmp-tmp-1853) ((lambda (syntmp-tmp-1857) (if syntmp-tmp-1857 (apply (lambda (syntmp-k-1858 syntmp-e1-1859 syntmp-e2-1860) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1858)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1859 syntmp-e2-1860)))) syntmp-tmp-1857) ((lambda (syntmp-_-1863) (syntax-error syntmp-x-1839)) syntmp-tmp-1852))) (syntax-dispatch syntmp-tmp-1852 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1852 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1849) ((lambda (syntmp-tmp-1864) ((lambda (syntmp-rest-1865) ((lambda (syntmp-tmp-1866) ((lambda (syntmp-tmp-1867) (if syntmp-tmp-1867 (apply (lambda (syntmp-k-1868 syntmp-e1-1869 syntmp-e2-1870) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1868)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1869 syntmp-e2-1870)) syntmp-rest-1865)) syntmp-tmp-1867) ((lambda (syntmp-_-1873) (syntax-error syntmp-x-1839)) syntmp-tmp-1866))) (syntax-dispatch syntmp-tmp-1866 (quote (each-any any . each-any))))) syntmp-clause-1849)) syntmp-tmp-1864)) (syntmp-f-1848 (car syntmp-clauses-1850) (cdr syntmp-clauses-1850))))))) syntmp-tmp-1841) (syntax-error syntmp-tmp-1840))) (syntax-dispatch syntmp-tmp-1840 (quote (any any any . each-any))))) syntmp-x-1839))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1903) ((lambda (syntmp-tmp-1904) ((lambda (syntmp-tmp-1905) (if syntmp-tmp-1905 (apply (lambda (syntmp-_-1906 syntmp-e-1907) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1907)) (list (cons syntmp-_-1906 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1907 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1905) (syntax-error syntmp-tmp-1904))) (syntax-dispatch syntmp-tmp-1904 (quote (any any))))) syntmp-x-1903))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-module-1084) (let ((syntmp-module-1085 (if syntmp-module-1084 (resolve-module syntmp-module-1084) (warn "wha" syntmp-symbol-1082 (current-module))))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable sc-macro))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (and (symbol-property syntmp-symbol-1082 (quote primitive-syntax)) (eq? syntmp-module-1085 the-syncase-module))) (variable-set! syntmp-v-1086 sc-macro)) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-getter-1341 syntmp-arg-1342 syntmp-val-1343) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-getter-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1344) (syntmp-chi-153 syntmp-e-1344 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-arg-1342 (list syntmp-val-1343)))))) syntmp-tmp-1339) ((lambda (syntmp-_-1346) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1347 syntmp-r-1348 syntmp-w-1349 syntmp-s-1350 syntmp-mod-1351) ((lambda (syntmp-tmp-1352) ((lambda (syntmp-tmp-1353) (if (if syntmp-tmp-1353 (apply (lambda (syntmp-_-1354 syntmp-mod-1355 syntmp-id-1356) (and (andmap syntmp-id?-117 syntmp-mod-1355) (syntmp-id?-117 syntmp-id-1356))) syntmp-tmp-1353) #f) (apply (lambda (syntmp-_-1358 syntmp-mod-1359 syntmp-id-1360) (values (syntax-object->datum syntmp-id-1360) (syntax-object->datum (append syntmp-mod-1359 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1353) (syntax-error syntmp-tmp-1352))) (syntax-dispatch syntmp-tmp-1352 (quote (any each-any any))))) syntmp-e-1347))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1362 syntmp-r-1363 syntmp-w-1364 syntmp-s-1365 syntmp-mod-1366) ((lambda (syntmp-tmp-1367) ((lambda (syntmp-tmp-1368) (if (if syntmp-tmp-1368 (apply (lambda (syntmp-_-1369 syntmp-mod-1370 syntmp-id-1371) (and (andmap syntmp-id?-117 syntmp-mod-1370) (syntmp-id?-117 syntmp-id-1371))) syntmp-tmp-1368) #f) (apply (lambda (syntmp-_-1373 syntmp-mod-1374 syntmp-id-1375) (values (syntax-object->datum syntmp-id-1375) (syntax-object->datum syntmp-mod-1374))) syntmp-tmp-1368) (syntax-error syntmp-tmp-1367))) (syntax-dispatch syntmp-tmp-1367 (quote (any each-any any))))) syntmp-e-1362))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1380 (lambda (syntmp-x-1381 syntmp-keys-1382 syntmp-clauses-1383 syntmp-r-1384 syntmp-mod-1385) (if (null? syntmp-clauses-1383) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1381)) ((lambda (syntmp-tmp-1386) ((lambda (syntmp-tmp-1387) (if syntmp-tmp-1387 (apply (lambda (syntmp-pat-1388 syntmp-exp-1389) (if (and (syntmp-id?-117 syntmp-pat-1388) (andmap (lambda (syntmp-x-1390) (not (syntmp-free-id=?-140 syntmp-pat-1388 syntmp-x-1390))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1382))) (let ((syntmp-labels-1391 (list (syntmp-gen-label-122))) (syntmp-var-1392 (syntmp-gen-var-165 syntmp-pat-1388))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1392) (syntmp-chi-153 syntmp-exp-1389 (syntmp-extend-env-111 syntmp-labels-1391 (list (cons (quote syntax) (cons syntmp-var-1392 0))) syntmp-r-1384) (syntmp-make-binding-wrap-134 (list syntmp-pat-1388) syntmp-labels-1391 (quote (()))) syntmp-mod-1385))) syntmp-x-1381))) (syntmp-gen-clause-1379 syntmp-x-1381 syntmp-keys-1382 (cdr syntmp-clauses-1383) syntmp-r-1384 syntmp-pat-1388 #t syntmp-exp-1389 syntmp-mod-1385))) syntmp-tmp-1387) ((lambda (syntmp-tmp-1393) (if syntmp-tmp-1393 (apply (lambda (syntmp-pat-1394 syntmp-fender-1395 syntmp-exp-1396) (syntmp-gen-clause-1379 syntmp-x-1381 syntmp-keys-1382 (cdr syntmp-clauses-1383) syntmp-r-1384 syntmp-pat-1394 syntmp-fender-1395 syntmp-exp-1396 syntmp-mod-1385)) syntmp-tmp-1393) ((lambda (syntmp-_-1397) (syntax-error (car syntmp-clauses-1383) "invalid syntax-case clause")) syntmp-tmp-1386))) (syntax-dispatch syntmp-tmp-1386 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1386 (quote (any any))))) (car syntmp-clauses-1383))))) (syntmp-gen-clause-1379 (lambda (syntmp-x-1398 syntmp-keys-1399 syntmp-clauses-1400 syntmp-r-1401 syntmp-pat-1402 syntmp-fender-1403 syntmp-exp-1404 syntmp-mod-1405) (call-with-values (lambda () (syntmp-convert-pattern-1377 syntmp-pat-1402 syntmp-keys-1399)) (lambda (syntmp-p-1406 syntmp-pvars-1407) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1407))) (syntax-error syntmp-pat-1402 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1408) (not (syntmp-ellipsis?-162 (car syntmp-x-1408)))) syntmp-pvars-1407)) (syntax-error syntmp-pat-1402 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1409 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1409) (let ((syntmp-y-1410 (syntmp-build-annotated-94 #f syntmp-y-1409))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1411) ((lambda (syntmp-tmp-1412) (if syntmp-tmp-1412 (apply (lambda () syntmp-y-1410) syntmp-tmp-1412) ((lambda (syntmp-_-1413) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1410 (syntmp-build-dispatch-call-1378 syntmp-pvars-1407 syntmp-fender-1403 syntmp-y-1410 syntmp-r-1401 syntmp-mod-1405) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1411))) (syntax-dispatch syntmp-tmp-1411 (quote #(atom #t))))) syntmp-fender-1403) (syntmp-build-dispatch-call-1378 syntmp-pvars-1407 syntmp-exp-1404 syntmp-y-1410 syntmp-r-1401 syntmp-mod-1405) (syntmp-gen-syntax-case-1380 syntmp-x-1398 syntmp-keys-1399 syntmp-clauses-1400 syntmp-r-1401 syntmp-mod-1405)))))) (if (eq? syntmp-p-1406 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1398)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1398 (syntmp-build-data-95 #f syntmp-p-1406))))))))))))) (syntmp-build-dispatch-call-1378 (lambda (syntmp-pvars-1414 syntmp-exp-1415 syntmp-y-1416 syntmp-r-1417 syntmp-mod-1418) (let ((syntmp-ids-1419 (map car syntmp-pvars-1414)) (syntmp-levels-1420 (map cdr syntmp-pvars-1414))) (let ((syntmp-labels-1421 (syntmp-gen-labels-123 syntmp-ids-1419)) (syntmp-new-vars-1422 (map syntmp-gen-var-165 syntmp-ids-1419))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1422 (syntmp-chi-153 syntmp-exp-1415 (syntmp-extend-env-111 syntmp-labels-1421 (map (lambda (syntmp-var-1423 syntmp-level-1424) (cons (quote syntax) (cons syntmp-var-1423 syntmp-level-1424))) syntmp-new-vars-1422 (map cdr syntmp-pvars-1414)) syntmp-r-1417) (syntmp-make-binding-wrap-134 syntmp-ids-1419 syntmp-labels-1421 (quote (()))) syntmp-mod-1418))) syntmp-y-1416)))))) (syntmp-convert-pattern-1377 (lambda (syntmp-pattern-1425 syntmp-keys-1426) (let syntmp-cvt-1427 ((syntmp-p-1428 syntmp-pattern-1425) (syntmp-n-1429 0) (syntmp-ids-1430 (quote ()))) (if (syntmp-id?-117 syntmp-p-1428) (if (syntmp-bound-id-member?-144 syntmp-p-1428 syntmp-keys-1426) (values (vector (quote free-id) syntmp-p-1428) syntmp-ids-1430) (values (quote any) (cons (cons syntmp-p-1428 syntmp-n-1429) syntmp-ids-1430))) ((lambda (syntmp-tmp-1431) ((lambda (syntmp-tmp-1432) (if (if syntmp-tmp-1432 (apply (lambda (syntmp-x-1433 syntmp-dots-1434) (syntmp-ellipsis?-162 syntmp-dots-1434)) syntmp-tmp-1432) #f) (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-x-1435 (syntmp-fx+-85 syntmp-n-1429 1) syntmp-ids-1430)) (lambda (syntmp-p-1437 syntmp-ids-1438) (values (if (eq? syntmp-p-1437 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1437)) syntmp-ids-1438)))) syntmp-tmp-1432) ((lambda (syntmp-tmp-1439) (if syntmp-tmp-1439 (apply (lambda (syntmp-x-1440 syntmp-y-1441) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-y-1441 syntmp-n-1429 syntmp-ids-1430)) (lambda (syntmp-y-1442 syntmp-ids-1443) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-x-1440 syntmp-n-1429 syntmp-ids-1443)) (lambda (syntmp-x-1444 syntmp-ids-1445) (values (cons syntmp-x-1444 syntmp-y-1442) syntmp-ids-1445)))))) syntmp-tmp-1439) ((lambda (syntmp-tmp-1446) (if syntmp-tmp-1446 (apply (lambda () (values (quote ()) syntmp-ids-1430)) syntmp-tmp-1446) ((lambda (syntmp-tmp-1447) (if syntmp-tmp-1447 (apply (lambda (syntmp-x-1448) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-x-1448 syntmp-n-1429 syntmp-ids-1430)) (lambda (syntmp-p-1450 syntmp-ids-1451) (values (vector (quote vector) syntmp-p-1450) syntmp-ids-1451)))) syntmp-tmp-1447) ((lambda (syntmp-x-1452) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1428 (quote (())))) syntmp-ids-1430)) syntmp-tmp-1431))) (syntax-dispatch syntmp-tmp-1431 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1431 (quote ()))))) (syntax-dispatch syntmp-tmp-1431 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1431 (quote (any any))))) syntmp-p-1428)))))) (lambda (syntmp-e-1453 syntmp-r-1454 syntmp-w-1455 syntmp-s-1456 syntmp-mod-1457) (let ((syntmp-e-1458 (syntmp-source-wrap-146 syntmp-e-1453 syntmp-w-1455 syntmp-s-1456 syntmp-mod-1457))) ((lambda (syntmp-tmp-1459) ((lambda (syntmp-tmp-1460) (if syntmp-tmp-1460 (apply (lambda (syntmp-_-1461 syntmp-val-1462 syntmp-key-1463 syntmp-m-1464) (if (andmap (lambda (syntmp-x-1465) (and (syntmp-id?-117 syntmp-x-1465) (not (syntmp-ellipsis?-162 syntmp-x-1465)))) syntmp-key-1463) (let ((syntmp-x-1467 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1456 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1467) (syntmp-gen-syntax-case-1380 (syntmp-build-annotated-94 #f syntmp-x-1467) syntmp-key-1463 syntmp-m-1464 syntmp-r-1454 syntmp-mod-1457))) (syntmp-chi-153 syntmp-val-1462 syntmp-r-1454 (quote (())) syntmp-mod-1457)))) (syntax-error syntmp-e-1458 "invalid literals list in"))) syntmp-tmp-1460) (syntax-error syntmp-tmp-1459))) (syntax-dispatch syntmp-tmp-1459 (quote (any any each-any . each-any))))) syntmp-e-1458))))) (set! sc-expand (let ((syntmp-m-1470 (quote e)) (syntmp-esew-1471 (quote (eval)))) (lambda (syntmp-x-1472) (if (and (pair? syntmp-x-1472) (equal? (car syntmp-x-1472) syntmp-noexpand-84)) (cadr syntmp-x-1472) (syntmp-chi-top-152 syntmp-x-1472 (quote ()) (quote ((top))) syntmp-m-1470 syntmp-esew-1471 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1473 (quote e)) (syntmp-esew-1474 (quote (eval)))) (lambda (syntmp-x-1476 . syntmp-rest-1475) (if (and (pair? syntmp-x-1476) (equal? (car syntmp-x-1476) syntmp-noexpand-84)) (cadr syntmp-x-1476) (syntmp-chi-top-152 syntmp-x-1476 (quote ()) (quote ((top))) (if (null? syntmp-rest-1475) syntmp-m-1473 (car syntmp-rest-1475)) (if (or (null? syntmp-rest-1475) (null? (cdr syntmp-rest-1475))) syntmp-esew-1474 (cadr syntmp-rest-1475)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1477) (syntmp-nonsymbol-id?-116 syntmp-x-1477))) (set! datum->syntax-object (lambda (syntmp-id-1478 syntmp-datum-1479) (syntmp-make-syntax-object-100 syntmp-datum-1479 (syntmp-syntax-object-wrap-103 syntmp-id-1478) #f))) (set! syntax-object->datum (lambda (syntmp-x-1480) (syntmp-strip-164 syntmp-x-1480 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1481) (begin (let ((syntmp-x-1482 syntmp-ls-1481)) (if (not (list? syntmp-x-1482)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1482))) (map (lambda (syntmp-x-1483) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1481)))) (set! free-identifier=? (lambda (syntmp-x-1484 syntmp-y-1485) (begin (let ((syntmp-x-1486 syntmp-x-1484)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1486)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1486))) (let ((syntmp-x-1487 syntmp-y-1485)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1487)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1487))) (syntmp-free-id=?-140 syntmp-x-1484 syntmp-y-1485)))) (set! bound-identifier=? (lambda (syntmp-x-1488 syntmp-y-1489) (begin (let ((syntmp-x-1490 syntmp-x-1488)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1490)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1490))) (let ((syntmp-x-1491 syntmp-y-1489)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1491)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1491))) (syntmp-bound-id=?-141 syntmp-x-1488 syntmp-y-1489)))) (set! syntax-error (lambda (syntmp-object-1493 . syntmp-messages-1492) (begin (for-each (lambda (syntmp-x-1494) (let ((syntmp-x-1495 syntmp-x-1494)) (if (not (string? syntmp-x-1495)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1495)))) syntmp-messages-1492) (let ((syntmp-message-1496 (if (null? syntmp-messages-1492) "invalid syntax" (apply string-append syntmp-messages-1492)))) (syntmp-error-hook-91 #f syntmp-message-1496 (syntmp-strip-164 syntmp-object-1493 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1497 syntmp-v-1498) (begin (let ((syntmp-x-1499 syntmp-sym-1497)) (if (not (symbol? syntmp-x-1499)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1499))) (let ((syntmp-x-1500 syntmp-v-1498)) (if (not (procedure? syntmp-x-1500)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1500))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1497 syntmp-v-1498)))) (letrec ((syntmp-match-1505 (lambda (syntmp-e-1506 syntmp-p-1507 syntmp-w-1508 syntmp-r-1509 syntmp-mod-1510) (cond ((not syntmp-r-1509) #f) ((eq? syntmp-p-1507 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1506 syntmp-w-1508 syntmp-mod-1510) syntmp-r-1509)) ((syntmp-syntax-object?-101 syntmp-e-1506) (syntmp-match*-1504 (let ((syntmp-e-1511 (syntmp-syntax-object-expression-102 syntmp-e-1506))) (if (annotation? syntmp-e-1511) (annotation-expression syntmp-e-1511) syntmp-e-1511)) syntmp-p-1507 (syntmp-join-wraps-136 syntmp-w-1508 (syntmp-syntax-object-wrap-103 syntmp-e-1506)) syntmp-r-1509 (syntmp-syntax-object-module-104 syntmp-e-1506))) (else (syntmp-match*-1504 (let ((syntmp-e-1512 syntmp-e-1506)) (if (annotation? syntmp-e-1512) (annotation-expression syntmp-e-1512) syntmp-e-1512)) syntmp-p-1507 syntmp-w-1508 syntmp-r-1509 syntmp-mod-1510))))) (syntmp-match*-1504 (lambda (syntmp-e-1513 syntmp-p-1514 syntmp-w-1515 syntmp-r-1516 syntmp-mod-1517) (cond ((null? syntmp-p-1514) (and (null? syntmp-e-1513) syntmp-r-1516)) ((pair? syntmp-p-1514) (and (pair? syntmp-e-1513) (syntmp-match-1505 (car syntmp-e-1513) (car syntmp-p-1514) syntmp-w-1515 (syntmp-match-1505 (cdr syntmp-e-1513) (cdr syntmp-p-1514) syntmp-w-1515 syntmp-r-1516 syntmp-mod-1517) syntmp-mod-1517))) ((eq? syntmp-p-1514 (quote each-any)) (let ((syntmp-l-1518 (syntmp-match-each-any-1502 syntmp-e-1513 syntmp-w-1515 syntmp-mod-1517))) (and syntmp-l-1518 (cons syntmp-l-1518 syntmp-r-1516)))) (else (let ((syntmp-t-1519 (vector-ref syntmp-p-1514 0))) (if (memv syntmp-t-1519 (quote (each))) (if (null? syntmp-e-1513) (syntmp-match-empty-1503 (vector-ref syntmp-p-1514 1) syntmp-r-1516) (let ((syntmp-l-1520 (syntmp-match-each-1501 syntmp-e-1513 (vector-ref syntmp-p-1514 1) syntmp-w-1515 syntmp-mod-1517))) (and syntmp-l-1520 (let syntmp-collect-1521 ((syntmp-l-1522 syntmp-l-1520)) (if (null? (car syntmp-l-1522)) syntmp-r-1516 (cons (map car syntmp-l-1522) (syntmp-collect-1521 (map cdr syntmp-l-1522)))))))) (if (memv syntmp-t-1519 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1513) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1513 syntmp-w-1515 syntmp-mod-1517) (vector-ref syntmp-p-1514 1)) syntmp-r-1516) (if (memv syntmp-t-1519 (quote (atom))) (and (equal? (vector-ref syntmp-p-1514 1) (syntmp-strip-164 syntmp-e-1513 syntmp-w-1515)) syntmp-r-1516) (if (memv syntmp-t-1519 (quote (vector))) (and (vector? syntmp-e-1513) (syntmp-match-1505 (vector->list syntmp-e-1513) (vector-ref syntmp-p-1514 1) syntmp-w-1515 syntmp-r-1516 syntmp-mod-1517))))))))))) (syntmp-match-empty-1503 (lambda (syntmp-p-1523 syntmp-r-1524) (cond ((null? syntmp-p-1523) syntmp-r-1524) ((eq? syntmp-p-1523 (quote any)) (cons (quote ()) syntmp-r-1524)) ((pair? syntmp-p-1523) (syntmp-match-empty-1503 (car syntmp-p-1523) (syntmp-match-empty-1503 (cdr syntmp-p-1523) syntmp-r-1524))) ((eq? syntmp-p-1523 (quote each-any)) (cons (quote ()) syntmp-r-1524)) (else (let ((syntmp-t-1525 (vector-ref syntmp-p-1523 0))) (if (memv syntmp-t-1525 (quote (each))) (syntmp-match-empty-1503 (vector-ref syntmp-p-1523 1) syntmp-r-1524) (if (memv syntmp-t-1525 (quote (free-id atom))) syntmp-r-1524 (if (memv syntmp-t-1525 (quote (vector))) (syntmp-match-empty-1503 (vector-ref syntmp-p-1523 1) syntmp-r-1524))))))))) (syntmp-match-each-any-1502 (lambda (syntmp-e-1526 syntmp-w-1527 syntmp-mod-1528) (cond ((annotation? syntmp-e-1526) (syntmp-match-each-any-1502 (annotation-expression syntmp-e-1526) syntmp-w-1527 syntmp-mod-1528)) ((pair? syntmp-e-1526) (let ((syntmp-l-1529 (syntmp-match-each-any-1502 (cdr syntmp-e-1526) syntmp-w-1527 syntmp-mod-1528))) (and syntmp-l-1529 (cons (syntmp-wrap-145 (car syntmp-e-1526) syntmp-w-1527 syntmp-mod-1528) syntmp-l-1529)))) ((null? syntmp-e-1526) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1526) (syntmp-match-each-any-1502 (syntmp-syntax-object-expression-102 syntmp-e-1526) (syntmp-join-wraps-136 syntmp-w-1527 (syntmp-syntax-object-wrap-103 syntmp-e-1526)) syntmp-mod-1528)) (else #f)))) (syntmp-match-each-1501 (lambda (syntmp-e-1530 syntmp-p-1531 syntmp-w-1532 syntmp-mod-1533) (cond ((annotation? syntmp-e-1530) (syntmp-match-each-1501 (annotation-expression syntmp-e-1530) syntmp-p-1531 syntmp-w-1532 syntmp-mod-1533)) ((pair? syntmp-e-1530) (let ((syntmp-first-1534 (syntmp-match-1505 (car syntmp-e-1530) syntmp-p-1531 syntmp-w-1532 (quote ()) syntmp-mod-1533))) (and syntmp-first-1534 (let ((syntmp-rest-1535 (syntmp-match-each-1501 (cdr syntmp-e-1530) syntmp-p-1531 syntmp-w-1532 syntmp-mod-1533))) (and syntmp-rest-1535 (cons syntmp-first-1534 syntmp-rest-1535)))))) ((null? syntmp-e-1530) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1530) (syntmp-match-each-1501 (syntmp-syntax-object-expression-102 syntmp-e-1530) syntmp-p-1531 (syntmp-join-wraps-136 syntmp-w-1532 (syntmp-syntax-object-wrap-103 syntmp-e-1530)) (syntmp-syntax-object-module-104 syntmp-e-1530))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1536 syntmp-p-1537) (cond ((eq? syntmp-p-1537 (quote any)) (list syntmp-e-1536)) ((syntmp-syntax-object?-101 syntmp-e-1536) (syntmp-match*-1504 (let ((syntmp-e-1538 (syntmp-syntax-object-expression-102 syntmp-e-1536))) (if (annotation? syntmp-e-1538) (annotation-expression syntmp-e-1538) syntmp-e-1538)) syntmp-p-1537 (syntmp-syntax-object-wrap-103 syntmp-e-1536) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1536))) (else (syntmp-match*-1504 (let ((syntmp-e-1539 syntmp-e-1536)) (if (annotation? syntmp-e-1539) (annotation-expression syntmp-e-1539) syntmp-e-1539)) syntmp-p-1537 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1540) ((lambda (syntmp-tmp-1541) ((lambda (syntmp-tmp-1542) (if syntmp-tmp-1542 (apply (lambda (syntmp-_-1543 syntmp-e1-1544 syntmp-e2-1545) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1544 syntmp-e2-1545))) syntmp-tmp-1542) ((lambda (syntmp-tmp-1547) (if syntmp-tmp-1547 (apply (lambda (syntmp-_-1548 syntmp-out-1549 syntmp-in-1550 syntmp-e1-1551 syntmp-e2-1552) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1550 (quote ()) (list syntmp-out-1549 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1551 syntmp-e2-1552))))) syntmp-tmp-1547) ((lambda (syntmp-tmp-1554) (if syntmp-tmp-1554 (apply (lambda (syntmp-_-1555 syntmp-out-1556 syntmp-in-1557 syntmp-e1-1558 syntmp-e2-1559) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1557) (quote ()) (list syntmp-out-1556 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1558 syntmp-e2-1559))))) syntmp-tmp-1554) (syntax-error syntmp-tmp-1541))) (syntax-dispatch syntmp-tmp-1541 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1541 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1541 (quote (any () any . each-any))))) syntmp-x-1540))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1581) ((lambda (syntmp-tmp-1582) ((lambda (syntmp-tmp-1583) (if syntmp-tmp-1583 (apply (lambda (syntmp-_-1584 syntmp-k-1585 syntmp-keyword-1586 syntmp-pattern-1587 syntmp-template-1588) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1585 (map (lambda (syntmp-tmp-1591 syntmp-tmp-1590) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1590) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1591))) syntmp-template-1588 syntmp-pattern-1587)))))) syntmp-tmp-1583) (syntax-error syntmp-tmp-1582))) (syntax-dispatch syntmp-tmp-1582 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1581))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1602) ((lambda (syntmp-tmp-1603) ((lambda (syntmp-tmp-1604) (if (if syntmp-tmp-1604 (apply (lambda (syntmp-let*-1605 syntmp-x-1606 syntmp-v-1607 syntmp-e1-1608 syntmp-e2-1609) (andmap identifier? syntmp-x-1606)) syntmp-tmp-1604) #f) (apply (lambda (syntmp-let*-1611 syntmp-x-1612 syntmp-v-1613 syntmp-e1-1614 syntmp-e2-1615) (let syntmp-f-1616 ((syntmp-bindings-1617 (map list syntmp-x-1612 syntmp-v-1613))) (if (null? syntmp-bindings-1617) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1614 syntmp-e2-1615))) ((lambda (syntmp-tmp-1621) ((lambda (syntmp-tmp-1622) (if syntmp-tmp-1622 (apply (lambda (syntmp-body-1623 syntmp-binding-1624) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1624) syntmp-body-1623)) syntmp-tmp-1622) (syntax-error syntmp-tmp-1621))) (syntax-dispatch syntmp-tmp-1621 (quote (any any))))) (list (syntmp-f-1616 (cdr syntmp-bindings-1617)) (car syntmp-bindings-1617)))))) syntmp-tmp-1604) (syntax-error syntmp-tmp-1603))) (syntax-dispatch syntmp-tmp-1603 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1602))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1644) ((lambda (syntmp-tmp-1645) ((lambda (syntmp-tmp-1646) (if syntmp-tmp-1646 (apply (lambda (syntmp-_-1647 syntmp-var-1648 syntmp-init-1649 syntmp-step-1650 syntmp-e0-1651 syntmp-e1-1652 syntmp-c-1653) ((lambda (syntmp-tmp-1654) ((lambda (syntmp-tmp-1655) (if syntmp-tmp-1655 (apply (lambda (syntmp-step-1656) ((lambda (syntmp-tmp-1657) ((lambda (syntmp-tmp-1658) (if syntmp-tmp-1658 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1648 syntmp-init-1649) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1651) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1653 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1656))))))) syntmp-tmp-1658) ((lambda (syntmp-tmp-1663) (if syntmp-tmp-1663 (apply (lambda (syntmp-e1-1664 syntmp-e2-1665) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1648 syntmp-init-1649) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1651 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1664 syntmp-e2-1665)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1653 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1656))))))) syntmp-tmp-1663) (syntax-error syntmp-tmp-1657))) (syntax-dispatch syntmp-tmp-1657 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1657 (quote ())))) syntmp-e1-1652)) syntmp-tmp-1655) (syntax-error syntmp-tmp-1654))) (syntax-dispatch syntmp-tmp-1654 (quote each-any)))) (map (lambda (syntmp-v-1672 syntmp-s-1673) ((lambda (syntmp-tmp-1674) ((lambda (syntmp-tmp-1675) (if syntmp-tmp-1675 (apply (lambda () syntmp-v-1672) syntmp-tmp-1675) ((lambda (syntmp-tmp-1676) (if syntmp-tmp-1676 (apply (lambda (syntmp-e-1677) syntmp-e-1677) syntmp-tmp-1676) ((lambda (syntmp-_-1678) (syntax-error syntmp-orig-x-1644)) syntmp-tmp-1674))) (syntax-dispatch syntmp-tmp-1674 (quote (any)))))) (syntax-dispatch syntmp-tmp-1674 (quote ())))) syntmp-s-1673)) syntmp-var-1648 syntmp-step-1650))) syntmp-tmp-1646) (syntax-error syntmp-tmp-1645))) (syntax-dispatch syntmp-tmp-1645 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1644))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1706 (lambda (syntmp-x-1710 syntmp-y-1711) ((lambda (syntmp-tmp-1712) ((lambda (syntmp-tmp-1713) (if syntmp-tmp-1713 (apply (lambda (syntmp-x-1714 syntmp-y-1715) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-dy-1718) ((lambda (syntmp-tmp-1719) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-dx-1721) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1721 syntmp-dy-1718))) syntmp-tmp-1720) ((lambda (syntmp-_-1722) (if (null? syntmp-dy-1718) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1714) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1714 syntmp-y-1715))) syntmp-tmp-1719))) (syntax-dispatch syntmp-tmp-1719 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1714)) syntmp-tmp-1717) ((lambda (syntmp-tmp-1723) (if syntmp-tmp-1723 (apply (lambda (syntmp-stuff-1724) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1714 syntmp-stuff-1724))) syntmp-tmp-1723) ((lambda (syntmp-else-1725) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1714 syntmp-y-1715)) syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1715)) syntmp-tmp-1713) (syntax-error syntmp-tmp-1712))) (syntax-dispatch syntmp-tmp-1712 (quote (any any))))) (list syntmp-x-1710 syntmp-y-1711)))) (syntmp-quasiappend-1707 (lambda (syntmp-x-1726 syntmp-y-1727) ((lambda (syntmp-tmp-1728) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-x-1730 syntmp-y-1731) ((lambda (syntmp-tmp-1732) ((lambda (syntmp-tmp-1733) (if syntmp-tmp-1733 (apply (lambda () syntmp-x-1730) syntmp-tmp-1733) ((lambda (syntmp-_-1734) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1730 syntmp-y-1731)) syntmp-tmp-1732))) (syntax-dispatch syntmp-tmp-1732 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1731)) syntmp-tmp-1729) (syntax-error syntmp-tmp-1728))) (syntax-dispatch syntmp-tmp-1728 (quote (any any))))) (list syntmp-x-1726 syntmp-y-1727)))) (syntmp-quasivector-1708 (lambda (syntmp-x-1735) ((lambda (syntmp-tmp-1736) ((lambda (syntmp-x-1737) ((lambda (syntmp-tmp-1738) ((lambda (syntmp-tmp-1739) (if syntmp-tmp-1739 (apply (lambda (syntmp-x-1740) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1740))) syntmp-tmp-1739) ((lambda (syntmp-tmp-1742) (if syntmp-tmp-1742 (apply (lambda (syntmp-x-1743) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1743)) syntmp-tmp-1742) ((lambda (syntmp-_-1745) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1737)) syntmp-tmp-1738))) (syntax-dispatch syntmp-tmp-1738 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1738 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1737)) syntmp-tmp-1736)) syntmp-x-1735))) (syntmp-quasi-1709 (lambda (syntmp-p-1746 syntmp-lev-1747) ((lambda (syntmp-tmp-1748) ((lambda (syntmp-tmp-1749) (if syntmp-tmp-1749 (apply (lambda (syntmp-p-1750) (if (= syntmp-lev-1747 0) syntmp-p-1750 (syntmp-quasicons-1706 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1709 (list syntmp-p-1750) (- syntmp-lev-1747 1))))) syntmp-tmp-1749) ((lambda (syntmp-tmp-1751) (if syntmp-tmp-1751 (apply (lambda (syntmp-p-1752 syntmp-q-1753) (if (= syntmp-lev-1747 0) (syntmp-quasiappend-1707 syntmp-p-1752 (syntmp-quasi-1709 syntmp-q-1753 syntmp-lev-1747)) (syntmp-quasicons-1706 (syntmp-quasicons-1706 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1709 (list syntmp-p-1752) (- syntmp-lev-1747 1))) (syntmp-quasi-1709 syntmp-q-1753 syntmp-lev-1747)))) syntmp-tmp-1751) ((lambda (syntmp-tmp-1754) (if syntmp-tmp-1754 (apply (lambda (syntmp-p-1755) (syntmp-quasicons-1706 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1709 (list syntmp-p-1755) (+ syntmp-lev-1747 1)))) syntmp-tmp-1754) ((lambda (syntmp-tmp-1756) (if syntmp-tmp-1756 (apply (lambda (syntmp-p-1757 syntmp-q-1758) (syntmp-quasicons-1706 (syntmp-quasi-1709 syntmp-p-1757 syntmp-lev-1747) (syntmp-quasi-1709 syntmp-q-1758 syntmp-lev-1747))) syntmp-tmp-1756) ((lambda (syntmp-tmp-1759) (if syntmp-tmp-1759 (apply (lambda (syntmp-x-1760) (syntmp-quasivector-1708 (syntmp-quasi-1709 syntmp-x-1760 syntmp-lev-1747))) syntmp-tmp-1759) ((lambda (syntmp-p-1762) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1762)) syntmp-tmp-1748))) (syntax-dispatch syntmp-tmp-1748 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1748 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1748 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1748 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1748 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1746)))) (lambda (syntmp-x-1763) ((lambda (syntmp-tmp-1764) ((lambda (syntmp-tmp-1765) (if syntmp-tmp-1765 (apply (lambda (syntmp-_-1766 syntmp-e-1767) (syntmp-quasi-1709 syntmp-e-1767 0)) syntmp-tmp-1765) (syntax-error syntmp-tmp-1764))) (syntax-dispatch syntmp-tmp-1764 (quote (any any))))) syntmp-x-1763)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1827) (letrec ((syntmp-read-file-1828 (lambda (syntmp-fn-1829 syntmp-k-1830) (let ((syntmp-p-1831 (open-input-file syntmp-fn-1829))) (let syntmp-f-1832 ((syntmp-x-1833 (read syntmp-p-1831))) (if (eof-object? syntmp-x-1833) (begin (close-input-port syntmp-p-1831) (quote ())) (cons (datum->syntax-object syntmp-k-1830 syntmp-x-1833) (syntmp-f-1832 (read syntmp-p-1831))))))))) ((lambda (syntmp-tmp-1834) ((lambda (syntmp-tmp-1835) (if syntmp-tmp-1835 (apply (lambda (syntmp-k-1836 syntmp-filename-1837) (let ((syntmp-fn-1838 (syntax-object->datum syntmp-filename-1837))) ((lambda (syntmp-tmp-1839) ((lambda (syntmp-tmp-1840) (if syntmp-tmp-1840 (apply (lambda (syntmp-exp-1841) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1841)) syntmp-tmp-1840) (syntax-error syntmp-tmp-1839))) (syntax-dispatch syntmp-tmp-1839 (quote each-any)))) (syntmp-read-file-1828 syntmp-fn-1838 syntmp-k-1836)))) syntmp-tmp-1835) (syntax-error syntmp-tmp-1834))) (syntax-dispatch syntmp-tmp-1834 (quote (any any))))) syntmp-x-1827)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1858) ((lambda (syntmp-tmp-1859) ((lambda (syntmp-tmp-1860) (if syntmp-tmp-1860 (apply (lambda (syntmp-_-1861 syntmp-e-1862) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1862))) syntmp-tmp-1860) (syntax-error syntmp-tmp-1859))) (syntax-dispatch syntmp-tmp-1859 (quote (any any))))) syntmp-x-1858))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1868) ((lambda (syntmp-tmp-1869) ((lambda (syntmp-tmp-1870) (if syntmp-tmp-1870 (apply (lambda (syntmp-_-1871 syntmp-e-1872) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1872))) syntmp-tmp-1870) (syntax-error syntmp-tmp-1869))) (syntax-dispatch syntmp-tmp-1869 (quote (any any))))) syntmp-x-1868))) +(install-global-transformer (quote case) (lambda (syntmp-x-1878) ((lambda (syntmp-tmp-1879) ((lambda (syntmp-tmp-1880) (if syntmp-tmp-1880 (apply (lambda (syntmp-_-1881 syntmp-e-1882 syntmp-m1-1883 syntmp-m2-1884) ((lambda (syntmp-tmp-1885) ((lambda (syntmp-body-1886) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1882)) syntmp-body-1886)) syntmp-tmp-1885)) (let syntmp-f-1887 ((syntmp-clause-1888 syntmp-m1-1883) (syntmp-clauses-1889 syntmp-m2-1884)) (if (null? syntmp-clauses-1889) ((lambda (syntmp-tmp-1891) ((lambda (syntmp-tmp-1892) (if syntmp-tmp-1892 (apply (lambda (syntmp-e1-1893 syntmp-e2-1894) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1893 syntmp-e2-1894))) syntmp-tmp-1892) ((lambda (syntmp-tmp-1896) (if syntmp-tmp-1896 (apply (lambda (syntmp-k-1897 syntmp-e1-1898 syntmp-e2-1899) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1897)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1898 syntmp-e2-1899)))) syntmp-tmp-1896) ((lambda (syntmp-_-1902) (syntax-error syntmp-x-1878)) syntmp-tmp-1891))) (syntax-dispatch syntmp-tmp-1891 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1891 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1888) ((lambda (syntmp-tmp-1903) ((lambda (syntmp-rest-1904) ((lambda (syntmp-tmp-1905) ((lambda (syntmp-tmp-1906) (if syntmp-tmp-1906 (apply (lambda (syntmp-k-1907 syntmp-e1-1908 syntmp-e2-1909) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1907)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1908 syntmp-e2-1909)) syntmp-rest-1904)) syntmp-tmp-1906) ((lambda (syntmp-_-1912) (syntax-error syntmp-x-1878)) syntmp-tmp-1905))) (syntax-dispatch syntmp-tmp-1905 (quote (each-any any . each-any))))) syntmp-clause-1888)) syntmp-tmp-1903)) (syntmp-f-1887 (car syntmp-clauses-1889) (cdr syntmp-clauses-1889))))))) syntmp-tmp-1880) (syntax-error syntmp-tmp-1879))) (syntax-dispatch syntmp-tmp-1879 (quote (any any any . each-any))))) syntmp-x-1878))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1942) ((lambda (syntmp-tmp-1943) ((lambda (syntmp-tmp-1944) (if syntmp-tmp-1944 (apply (lambda (syntmp-_-1945 syntmp-e-1946) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1946)) (list (cons syntmp-_-1945 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1946 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1944) (syntax-error syntmp-tmp-1943))) (syntax-dispatch syntmp-tmp-1943 (quote (any any))))) syntmp-x-1942))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 2518fc982..d016b2f6d 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -508,6 +508,7 @@ ;;; ::= (macro . ) macros ;;; (core . ) core forms ;;; (external-macro . ) external-macro +;;; (module-ref . ) @ or @@ ;;; (begin) begin ;;; (define) define ;;; (define-syntax) define-syntax @@ -926,6 +927,7 @@ ;;; ------------------------------------------------------------------- ;;; core procedure core form (including singleton) ;;; external-macro procedure external macro +;;; module-ref procedure @ or @@ form ;;; lexical name lexical variable reference ;;; global name global variable reference ;;; begin none begin keyword @@ -984,7 +986,7 @@ ((macro) (syntax-type (chi-macro (binding-value b) e r w rib mod) r empty-wrap s rib mod)) - ((core external-macro) + ((core external-macro module-ref) (values type (binding-value b) e w s mod)) ((local-syntax) (values 'local-syntax-form (binding-value b) e w s mod)) @@ -1129,6 +1131,10 @@ ((core external-macro) ;; apply transformer (value e r w s mod)) + ((module-ref) + (call-with-values (lambda () (value e r w s mod)) + ;; we could add a public? arg here + (lambda (id mod) (build-global-reference s id mod)))) ((lexical-call) (chi-application (build-lexical-reference 'fun (source-annotation (car e)) value) @@ -1773,6 +1779,24 @@ (syntax (arg ... val))))) (_ (syntax-error (source-wrap e w s mod)))))) +(global-extend 'module-ref '@ + (lambda (e r w s mod) + (syntax-case e (%module-public-interface) + ((_ (mod ...) id) + (and (andmap id? (syntax (mod ...))) (id? (syntax id))) + (values (syntax-object->datum (syntax id)) + (syntax-object->datum + (syntax (mod ... %module-public-interface)))))))) + +(global-extend 'module-ref '@@ + (lambda (e r w s mod) + (syntax-case e () + ((_ (mod ...) id) + (and (andmap id? (syntax (mod ...))) (id? (syntax id))) + (values (syntax-object->datum (syntax id)) + (syntax-object->datum + (syntax (mod ...)))))))) + (global-extend 'begin 'begin '()) (global-extend 'define 'define '()) diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index a6bdaa4a9..d8fdeb4c9 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -65,7 +65,7 @@ (define primitive-syntax '(quote lambda letrec if set! begin define or and let let* cond do quasiquote unquote - unquote-splicing case)) + unquote-splicing case @ @@)) (for-each (lambda (symbol) (set-symbol-property! symbol 'primitive-syntax #t)) From dec62b5ef8f03c17f95a89a38c27128b10a41f28 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Apr 2009 22:56:51 +0200 Subject: [PATCH 049/375] make syncase aware of (set! (@ (foo) bar) baz) * module/ice-9/psyntax.scm (set!): Handle (set! (@ (foo ..) bar) val) inside syncase. Heh heh heh. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 25 +++++++++++++++++-------- 2 files changed, 28 insertions(+), 19 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index e1fd72a37..02d9e9975 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-module-1084) (let ((syntmp-module-1085 (if syntmp-module-1084 (resolve-module syntmp-module-1084) (warn "wha" syntmp-symbol-1082 (current-module))))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable sc-macro))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (and (symbol-property syntmp-symbol-1082 (quote primitive-syntax)) (eq? syntmp-module-1085 the-syncase-module))) (variable-set! syntmp-v-1086 sc-macro)) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-getter-1341 syntmp-arg-1342 syntmp-val-1343) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-getter-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1344) (syntmp-chi-153 syntmp-e-1344 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-arg-1342 (list syntmp-val-1343)))))) syntmp-tmp-1339) ((lambda (syntmp-_-1346) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1347 syntmp-r-1348 syntmp-w-1349 syntmp-s-1350 syntmp-mod-1351) ((lambda (syntmp-tmp-1352) ((lambda (syntmp-tmp-1353) (if (if syntmp-tmp-1353 (apply (lambda (syntmp-_-1354 syntmp-mod-1355 syntmp-id-1356) (and (andmap syntmp-id?-117 syntmp-mod-1355) (syntmp-id?-117 syntmp-id-1356))) syntmp-tmp-1353) #f) (apply (lambda (syntmp-_-1358 syntmp-mod-1359 syntmp-id-1360) (values (syntax-object->datum syntmp-id-1360) (syntax-object->datum (append syntmp-mod-1359 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1353) (syntax-error syntmp-tmp-1352))) (syntax-dispatch syntmp-tmp-1352 (quote (any each-any any))))) syntmp-e-1347))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1362 syntmp-r-1363 syntmp-w-1364 syntmp-s-1365 syntmp-mod-1366) ((lambda (syntmp-tmp-1367) ((lambda (syntmp-tmp-1368) (if (if syntmp-tmp-1368 (apply (lambda (syntmp-_-1369 syntmp-mod-1370 syntmp-id-1371) (and (andmap syntmp-id?-117 syntmp-mod-1370) (syntmp-id?-117 syntmp-id-1371))) syntmp-tmp-1368) #f) (apply (lambda (syntmp-_-1373 syntmp-mod-1374 syntmp-id-1375) (values (syntax-object->datum syntmp-id-1375) (syntax-object->datum syntmp-mod-1374))) syntmp-tmp-1368) (syntax-error syntmp-tmp-1367))) (syntax-dispatch syntmp-tmp-1367 (quote (any each-any any))))) syntmp-e-1362))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1380 (lambda (syntmp-x-1381 syntmp-keys-1382 syntmp-clauses-1383 syntmp-r-1384 syntmp-mod-1385) (if (null? syntmp-clauses-1383) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1381)) ((lambda (syntmp-tmp-1386) ((lambda (syntmp-tmp-1387) (if syntmp-tmp-1387 (apply (lambda (syntmp-pat-1388 syntmp-exp-1389) (if (and (syntmp-id?-117 syntmp-pat-1388) (andmap (lambda (syntmp-x-1390) (not (syntmp-free-id=?-140 syntmp-pat-1388 syntmp-x-1390))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1382))) (let ((syntmp-labels-1391 (list (syntmp-gen-label-122))) (syntmp-var-1392 (syntmp-gen-var-165 syntmp-pat-1388))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1392) (syntmp-chi-153 syntmp-exp-1389 (syntmp-extend-env-111 syntmp-labels-1391 (list (cons (quote syntax) (cons syntmp-var-1392 0))) syntmp-r-1384) (syntmp-make-binding-wrap-134 (list syntmp-pat-1388) syntmp-labels-1391 (quote (()))) syntmp-mod-1385))) syntmp-x-1381))) (syntmp-gen-clause-1379 syntmp-x-1381 syntmp-keys-1382 (cdr syntmp-clauses-1383) syntmp-r-1384 syntmp-pat-1388 #t syntmp-exp-1389 syntmp-mod-1385))) syntmp-tmp-1387) ((lambda (syntmp-tmp-1393) (if syntmp-tmp-1393 (apply (lambda (syntmp-pat-1394 syntmp-fender-1395 syntmp-exp-1396) (syntmp-gen-clause-1379 syntmp-x-1381 syntmp-keys-1382 (cdr syntmp-clauses-1383) syntmp-r-1384 syntmp-pat-1394 syntmp-fender-1395 syntmp-exp-1396 syntmp-mod-1385)) syntmp-tmp-1393) ((lambda (syntmp-_-1397) (syntax-error (car syntmp-clauses-1383) "invalid syntax-case clause")) syntmp-tmp-1386))) (syntax-dispatch syntmp-tmp-1386 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1386 (quote (any any))))) (car syntmp-clauses-1383))))) (syntmp-gen-clause-1379 (lambda (syntmp-x-1398 syntmp-keys-1399 syntmp-clauses-1400 syntmp-r-1401 syntmp-pat-1402 syntmp-fender-1403 syntmp-exp-1404 syntmp-mod-1405) (call-with-values (lambda () (syntmp-convert-pattern-1377 syntmp-pat-1402 syntmp-keys-1399)) (lambda (syntmp-p-1406 syntmp-pvars-1407) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1407))) (syntax-error syntmp-pat-1402 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1408) (not (syntmp-ellipsis?-162 (car syntmp-x-1408)))) syntmp-pvars-1407)) (syntax-error syntmp-pat-1402 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1409 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1409) (let ((syntmp-y-1410 (syntmp-build-annotated-94 #f syntmp-y-1409))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1411) ((lambda (syntmp-tmp-1412) (if syntmp-tmp-1412 (apply (lambda () syntmp-y-1410) syntmp-tmp-1412) ((lambda (syntmp-_-1413) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1410 (syntmp-build-dispatch-call-1378 syntmp-pvars-1407 syntmp-fender-1403 syntmp-y-1410 syntmp-r-1401 syntmp-mod-1405) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1411))) (syntax-dispatch syntmp-tmp-1411 (quote #(atom #t))))) syntmp-fender-1403) (syntmp-build-dispatch-call-1378 syntmp-pvars-1407 syntmp-exp-1404 syntmp-y-1410 syntmp-r-1401 syntmp-mod-1405) (syntmp-gen-syntax-case-1380 syntmp-x-1398 syntmp-keys-1399 syntmp-clauses-1400 syntmp-r-1401 syntmp-mod-1405)))))) (if (eq? syntmp-p-1406 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1398)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1398 (syntmp-build-data-95 #f syntmp-p-1406))))))))))))) (syntmp-build-dispatch-call-1378 (lambda (syntmp-pvars-1414 syntmp-exp-1415 syntmp-y-1416 syntmp-r-1417 syntmp-mod-1418) (let ((syntmp-ids-1419 (map car syntmp-pvars-1414)) (syntmp-levels-1420 (map cdr syntmp-pvars-1414))) (let ((syntmp-labels-1421 (syntmp-gen-labels-123 syntmp-ids-1419)) (syntmp-new-vars-1422 (map syntmp-gen-var-165 syntmp-ids-1419))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1422 (syntmp-chi-153 syntmp-exp-1415 (syntmp-extend-env-111 syntmp-labels-1421 (map (lambda (syntmp-var-1423 syntmp-level-1424) (cons (quote syntax) (cons syntmp-var-1423 syntmp-level-1424))) syntmp-new-vars-1422 (map cdr syntmp-pvars-1414)) syntmp-r-1417) (syntmp-make-binding-wrap-134 syntmp-ids-1419 syntmp-labels-1421 (quote (()))) syntmp-mod-1418))) syntmp-y-1416)))))) (syntmp-convert-pattern-1377 (lambda (syntmp-pattern-1425 syntmp-keys-1426) (let syntmp-cvt-1427 ((syntmp-p-1428 syntmp-pattern-1425) (syntmp-n-1429 0) (syntmp-ids-1430 (quote ()))) (if (syntmp-id?-117 syntmp-p-1428) (if (syntmp-bound-id-member?-144 syntmp-p-1428 syntmp-keys-1426) (values (vector (quote free-id) syntmp-p-1428) syntmp-ids-1430) (values (quote any) (cons (cons syntmp-p-1428 syntmp-n-1429) syntmp-ids-1430))) ((lambda (syntmp-tmp-1431) ((lambda (syntmp-tmp-1432) (if (if syntmp-tmp-1432 (apply (lambda (syntmp-x-1433 syntmp-dots-1434) (syntmp-ellipsis?-162 syntmp-dots-1434)) syntmp-tmp-1432) #f) (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-x-1435 (syntmp-fx+-85 syntmp-n-1429 1) syntmp-ids-1430)) (lambda (syntmp-p-1437 syntmp-ids-1438) (values (if (eq? syntmp-p-1437 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1437)) syntmp-ids-1438)))) syntmp-tmp-1432) ((lambda (syntmp-tmp-1439) (if syntmp-tmp-1439 (apply (lambda (syntmp-x-1440 syntmp-y-1441) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-y-1441 syntmp-n-1429 syntmp-ids-1430)) (lambda (syntmp-y-1442 syntmp-ids-1443) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-x-1440 syntmp-n-1429 syntmp-ids-1443)) (lambda (syntmp-x-1444 syntmp-ids-1445) (values (cons syntmp-x-1444 syntmp-y-1442) syntmp-ids-1445)))))) syntmp-tmp-1439) ((lambda (syntmp-tmp-1446) (if syntmp-tmp-1446 (apply (lambda () (values (quote ()) syntmp-ids-1430)) syntmp-tmp-1446) ((lambda (syntmp-tmp-1447) (if syntmp-tmp-1447 (apply (lambda (syntmp-x-1448) (call-with-values (lambda () (syntmp-cvt-1427 syntmp-x-1448 syntmp-n-1429 syntmp-ids-1430)) (lambda (syntmp-p-1450 syntmp-ids-1451) (values (vector (quote vector) syntmp-p-1450) syntmp-ids-1451)))) syntmp-tmp-1447) ((lambda (syntmp-x-1452) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1428 (quote (())))) syntmp-ids-1430)) syntmp-tmp-1431))) (syntax-dispatch syntmp-tmp-1431 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1431 (quote ()))))) (syntax-dispatch syntmp-tmp-1431 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1431 (quote (any any))))) syntmp-p-1428)))))) (lambda (syntmp-e-1453 syntmp-r-1454 syntmp-w-1455 syntmp-s-1456 syntmp-mod-1457) (let ((syntmp-e-1458 (syntmp-source-wrap-146 syntmp-e-1453 syntmp-w-1455 syntmp-s-1456 syntmp-mod-1457))) ((lambda (syntmp-tmp-1459) ((lambda (syntmp-tmp-1460) (if syntmp-tmp-1460 (apply (lambda (syntmp-_-1461 syntmp-val-1462 syntmp-key-1463 syntmp-m-1464) (if (andmap (lambda (syntmp-x-1465) (and (syntmp-id?-117 syntmp-x-1465) (not (syntmp-ellipsis?-162 syntmp-x-1465)))) syntmp-key-1463) (let ((syntmp-x-1467 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1456 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1467) (syntmp-gen-syntax-case-1380 (syntmp-build-annotated-94 #f syntmp-x-1467) syntmp-key-1463 syntmp-m-1464 syntmp-r-1454 syntmp-mod-1457))) (syntmp-chi-153 syntmp-val-1462 syntmp-r-1454 (quote (())) syntmp-mod-1457)))) (syntax-error syntmp-e-1458 "invalid literals list in"))) syntmp-tmp-1460) (syntax-error syntmp-tmp-1459))) (syntax-dispatch syntmp-tmp-1459 (quote (any any each-any . each-any))))) syntmp-e-1458))))) (set! sc-expand (let ((syntmp-m-1470 (quote e)) (syntmp-esew-1471 (quote (eval)))) (lambda (syntmp-x-1472) (if (and (pair? syntmp-x-1472) (equal? (car syntmp-x-1472) syntmp-noexpand-84)) (cadr syntmp-x-1472) (syntmp-chi-top-152 syntmp-x-1472 (quote ()) (quote ((top))) syntmp-m-1470 syntmp-esew-1471 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1473 (quote e)) (syntmp-esew-1474 (quote (eval)))) (lambda (syntmp-x-1476 . syntmp-rest-1475) (if (and (pair? syntmp-x-1476) (equal? (car syntmp-x-1476) syntmp-noexpand-84)) (cadr syntmp-x-1476) (syntmp-chi-top-152 syntmp-x-1476 (quote ()) (quote ((top))) (if (null? syntmp-rest-1475) syntmp-m-1473 (car syntmp-rest-1475)) (if (or (null? syntmp-rest-1475) (null? (cdr syntmp-rest-1475))) syntmp-esew-1474 (cadr syntmp-rest-1475)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1477) (syntmp-nonsymbol-id?-116 syntmp-x-1477))) (set! datum->syntax-object (lambda (syntmp-id-1478 syntmp-datum-1479) (syntmp-make-syntax-object-100 syntmp-datum-1479 (syntmp-syntax-object-wrap-103 syntmp-id-1478) #f))) (set! syntax-object->datum (lambda (syntmp-x-1480) (syntmp-strip-164 syntmp-x-1480 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1481) (begin (let ((syntmp-x-1482 syntmp-ls-1481)) (if (not (list? syntmp-x-1482)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1482))) (map (lambda (syntmp-x-1483) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1481)))) (set! free-identifier=? (lambda (syntmp-x-1484 syntmp-y-1485) (begin (let ((syntmp-x-1486 syntmp-x-1484)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1486)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1486))) (let ((syntmp-x-1487 syntmp-y-1485)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1487)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1487))) (syntmp-free-id=?-140 syntmp-x-1484 syntmp-y-1485)))) (set! bound-identifier=? (lambda (syntmp-x-1488 syntmp-y-1489) (begin (let ((syntmp-x-1490 syntmp-x-1488)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1490)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1490))) (let ((syntmp-x-1491 syntmp-y-1489)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1491)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1491))) (syntmp-bound-id=?-141 syntmp-x-1488 syntmp-y-1489)))) (set! syntax-error (lambda (syntmp-object-1493 . syntmp-messages-1492) (begin (for-each (lambda (syntmp-x-1494) (let ((syntmp-x-1495 syntmp-x-1494)) (if (not (string? syntmp-x-1495)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1495)))) syntmp-messages-1492) (let ((syntmp-message-1496 (if (null? syntmp-messages-1492) "invalid syntax" (apply string-append syntmp-messages-1492)))) (syntmp-error-hook-91 #f syntmp-message-1496 (syntmp-strip-164 syntmp-object-1493 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1497 syntmp-v-1498) (begin (let ((syntmp-x-1499 syntmp-sym-1497)) (if (not (symbol? syntmp-x-1499)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1499))) (let ((syntmp-x-1500 syntmp-v-1498)) (if (not (procedure? syntmp-x-1500)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1500))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1497 syntmp-v-1498)))) (letrec ((syntmp-match-1505 (lambda (syntmp-e-1506 syntmp-p-1507 syntmp-w-1508 syntmp-r-1509 syntmp-mod-1510) (cond ((not syntmp-r-1509) #f) ((eq? syntmp-p-1507 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1506 syntmp-w-1508 syntmp-mod-1510) syntmp-r-1509)) ((syntmp-syntax-object?-101 syntmp-e-1506) (syntmp-match*-1504 (let ((syntmp-e-1511 (syntmp-syntax-object-expression-102 syntmp-e-1506))) (if (annotation? syntmp-e-1511) (annotation-expression syntmp-e-1511) syntmp-e-1511)) syntmp-p-1507 (syntmp-join-wraps-136 syntmp-w-1508 (syntmp-syntax-object-wrap-103 syntmp-e-1506)) syntmp-r-1509 (syntmp-syntax-object-module-104 syntmp-e-1506))) (else (syntmp-match*-1504 (let ((syntmp-e-1512 syntmp-e-1506)) (if (annotation? syntmp-e-1512) (annotation-expression syntmp-e-1512) syntmp-e-1512)) syntmp-p-1507 syntmp-w-1508 syntmp-r-1509 syntmp-mod-1510))))) (syntmp-match*-1504 (lambda (syntmp-e-1513 syntmp-p-1514 syntmp-w-1515 syntmp-r-1516 syntmp-mod-1517) (cond ((null? syntmp-p-1514) (and (null? syntmp-e-1513) syntmp-r-1516)) ((pair? syntmp-p-1514) (and (pair? syntmp-e-1513) (syntmp-match-1505 (car syntmp-e-1513) (car syntmp-p-1514) syntmp-w-1515 (syntmp-match-1505 (cdr syntmp-e-1513) (cdr syntmp-p-1514) syntmp-w-1515 syntmp-r-1516 syntmp-mod-1517) syntmp-mod-1517))) ((eq? syntmp-p-1514 (quote each-any)) (let ((syntmp-l-1518 (syntmp-match-each-any-1502 syntmp-e-1513 syntmp-w-1515 syntmp-mod-1517))) (and syntmp-l-1518 (cons syntmp-l-1518 syntmp-r-1516)))) (else (let ((syntmp-t-1519 (vector-ref syntmp-p-1514 0))) (if (memv syntmp-t-1519 (quote (each))) (if (null? syntmp-e-1513) (syntmp-match-empty-1503 (vector-ref syntmp-p-1514 1) syntmp-r-1516) (let ((syntmp-l-1520 (syntmp-match-each-1501 syntmp-e-1513 (vector-ref syntmp-p-1514 1) syntmp-w-1515 syntmp-mod-1517))) (and syntmp-l-1520 (let syntmp-collect-1521 ((syntmp-l-1522 syntmp-l-1520)) (if (null? (car syntmp-l-1522)) syntmp-r-1516 (cons (map car syntmp-l-1522) (syntmp-collect-1521 (map cdr syntmp-l-1522)))))))) (if (memv syntmp-t-1519 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1513) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1513 syntmp-w-1515 syntmp-mod-1517) (vector-ref syntmp-p-1514 1)) syntmp-r-1516) (if (memv syntmp-t-1519 (quote (atom))) (and (equal? (vector-ref syntmp-p-1514 1) (syntmp-strip-164 syntmp-e-1513 syntmp-w-1515)) syntmp-r-1516) (if (memv syntmp-t-1519 (quote (vector))) (and (vector? syntmp-e-1513) (syntmp-match-1505 (vector->list syntmp-e-1513) (vector-ref syntmp-p-1514 1) syntmp-w-1515 syntmp-r-1516 syntmp-mod-1517))))))))))) (syntmp-match-empty-1503 (lambda (syntmp-p-1523 syntmp-r-1524) (cond ((null? syntmp-p-1523) syntmp-r-1524) ((eq? syntmp-p-1523 (quote any)) (cons (quote ()) syntmp-r-1524)) ((pair? syntmp-p-1523) (syntmp-match-empty-1503 (car syntmp-p-1523) (syntmp-match-empty-1503 (cdr syntmp-p-1523) syntmp-r-1524))) ((eq? syntmp-p-1523 (quote each-any)) (cons (quote ()) syntmp-r-1524)) (else (let ((syntmp-t-1525 (vector-ref syntmp-p-1523 0))) (if (memv syntmp-t-1525 (quote (each))) (syntmp-match-empty-1503 (vector-ref syntmp-p-1523 1) syntmp-r-1524) (if (memv syntmp-t-1525 (quote (free-id atom))) syntmp-r-1524 (if (memv syntmp-t-1525 (quote (vector))) (syntmp-match-empty-1503 (vector-ref syntmp-p-1523 1) syntmp-r-1524))))))))) (syntmp-match-each-any-1502 (lambda (syntmp-e-1526 syntmp-w-1527 syntmp-mod-1528) (cond ((annotation? syntmp-e-1526) (syntmp-match-each-any-1502 (annotation-expression syntmp-e-1526) syntmp-w-1527 syntmp-mod-1528)) ((pair? syntmp-e-1526) (let ((syntmp-l-1529 (syntmp-match-each-any-1502 (cdr syntmp-e-1526) syntmp-w-1527 syntmp-mod-1528))) (and syntmp-l-1529 (cons (syntmp-wrap-145 (car syntmp-e-1526) syntmp-w-1527 syntmp-mod-1528) syntmp-l-1529)))) ((null? syntmp-e-1526) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1526) (syntmp-match-each-any-1502 (syntmp-syntax-object-expression-102 syntmp-e-1526) (syntmp-join-wraps-136 syntmp-w-1527 (syntmp-syntax-object-wrap-103 syntmp-e-1526)) syntmp-mod-1528)) (else #f)))) (syntmp-match-each-1501 (lambda (syntmp-e-1530 syntmp-p-1531 syntmp-w-1532 syntmp-mod-1533) (cond ((annotation? syntmp-e-1530) (syntmp-match-each-1501 (annotation-expression syntmp-e-1530) syntmp-p-1531 syntmp-w-1532 syntmp-mod-1533)) ((pair? syntmp-e-1530) (let ((syntmp-first-1534 (syntmp-match-1505 (car syntmp-e-1530) syntmp-p-1531 syntmp-w-1532 (quote ()) syntmp-mod-1533))) (and syntmp-first-1534 (let ((syntmp-rest-1535 (syntmp-match-each-1501 (cdr syntmp-e-1530) syntmp-p-1531 syntmp-w-1532 syntmp-mod-1533))) (and syntmp-rest-1535 (cons syntmp-first-1534 syntmp-rest-1535)))))) ((null? syntmp-e-1530) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1530) (syntmp-match-each-1501 (syntmp-syntax-object-expression-102 syntmp-e-1530) syntmp-p-1531 (syntmp-join-wraps-136 syntmp-w-1532 (syntmp-syntax-object-wrap-103 syntmp-e-1530)) (syntmp-syntax-object-module-104 syntmp-e-1530))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1536 syntmp-p-1537) (cond ((eq? syntmp-p-1537 (quote any)) (list syntmp-e-1536)) ((syntmp-syntax-object?-101 syntmp-e-1536) (syntmp-match*-1504 (let ((syntmp-e-1538 (syntmp-syntax-object-expression-102 syntmp-e-1536))) (if (annotation? syntmp-e-1538) (annotation-expression syntmp-e-1538) syntmp-e-1538)) syntmp-p-1537 (syntmp-syntax-object-wrap-103 syntmp-e-1536) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1536))) (else (syntmp-match*-1504 (let ((syntmp-e-1539 syntmp-e-1536)) (if (annotation? syntmp-e-1539) (annotation-expression syntmp-e-1539) syntmp-e-1539)) syntmp-p-1537 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1540) ((lambda (syntmp-tmp-1541) ((lambda (syntmp-tmp-1542) (if syntmp-tmp-1542 (apply (lambda (syntmp-_-1543 syntmp-e1-1544 syntmp-e2-1545) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1544 syntmp-e2-1545))) syntmp-tmp-1542) ((lambda (syntmp-tmp-1547) (if syntmp-tmp-1547 (apply (lambda (syntmp-_-1548 syntmp-out-1549 syntmp-in-1550 syntmp-e1-1551 syntmp-e2-1552) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1550 (quote ()) (list syntmp-out-1549 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1551 syntmp-e2-1552))))) syntmp-tmp-1547) ((lambda (syntmp-tmp-1554) (if syntmp-tmp-1554 (apply (lambda (syntmp-_-1555 syntmp-out-1556 syntmp-in-1557 syntmp-e1-1558 syntmp-e2-1559) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1557) (quote ()) (list syntmp-out-1556 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1558 syntmp-e2-1559))))) syntmp-tmp-1554) (syntax-error syntmp-tmp-1541))) (syntax-dispatch syntmp-tmp-1541 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1541 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1541 (quote (any () any . each-any))))) syntmp-x-1540))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1581) ((lambda (syntmp-tmp-1582) ((lambda (syntmp-tmp-1583) (if syntmp-tmp-1583 (apply (lambda (syntmp-_-1584 syntmp-k-1585 syntmp-keyword-1586 syntmp-pattern-1587 syntmp-template-1588) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1585 (map (lambda (syntmp-tmp-1591 syntmp-tmp-1590) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1590) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1591))) syntmp-template-1588 syntmp-pattern-1587)))))) syntmp-tmp-1583) (syntax-error syntmp-tmp-1582))) (syntax-dispatch syntmp-tmp-1582 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1581))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1602) ((lambda (syntmp-tmp-1603) ((lambda (syntmp-tmp-1604) (if (if syntmp-tmp-1604 (apply (lambda (syntmp-let*-1605 syntmp-x-1606 syntmp-v-1607 syntmp-e1-1608 syntmp-e2-1609) (andmap identifier? syntmp-x-1606)) syntmp-tmp-1604) #f) (apply (lambda (syntmp-let*-1611 syntmp-x-1612 syntmp-v-1613 syntmp-e1-1614 syntmp-e2-1615) (let syntmp-f-1616 ((syntmp-bindings-1617 (map list syntmp-x-1612 syntmp-v-1613))) (if (null? syntmp-bindings-1617) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1614 syntmp-e2-1615))) ((lambda (syntmp-tmp-1621) ((lambda (syntmp-tmp-1622) (if syntmp-tmp-1622 (apply (lambda (syntmp-body-1623 syntmp-binding-1624) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1624) syntmp-body-1623)) syntmp-tmp-1622) (syntax-error syntmp-tmp-1621))) (syntax-dispatch syntmp-tmp-1621 (quote (any any))))) (list (syntmp-f-1616 (cdr syntmp-bindings-1617)) (car syntmp-bindings-1617)))))) syntmp-tmp-1604) (syntax-error syntmp-tmp-1603))) (syntax-dispatch syntmp-tmp-1603 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1602))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1644) ((lambda (syntmp-tmp-1645) ((lambda (syntmp-tmp-1646) (if syntmp-tmp-1646 (apply (lambda (syntmp-_-1647 syntmp-var-1648 syntmp-init-1649 syntmp-step-1650 syntmp-e0-1651 syntmp-e1-1652 syntmp-c-1653) ((lambda (syntmp-tmp-1654) ((lambda (syntmp-tmp-1655) (if syntmp-tmp-1655 (apply (lambda (syntmp-step-1656) ((lambda (syntmp-tmp-1657) ((lambda (syntmp-tmp-1658) (if syntmp-tmp-1658 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1648 syntmp-init-1649) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1651) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1653 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1656))))))) syntmp-tmp-1658) ((lambda (syntmp-tmp-1663) (if syntmp-tmp-1663 (apply (lambda (syntmp-e1-1664 syntmp-e2-1665) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1648 syntmp-init-1649) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1651 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1664 syntmp-e2-1665)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1653 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1656))))))) syntmp-tmp-1663) (syntax-error syntmp-tmp-1657))) (syntax-dispatch syntmp-tmp-1657 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1657 (quote ())))) syntmp-e1-1652)) syntmp-tmp-1655) (syntax-error syntmp-tmp-1654))) (syntax-dispatch syntmp-tmp-1654 (quote each-any)))) (map (lambda (syntmp-v-1672 syntmp-s-1673) ((lambda (syntmp-tmp-1674) ((lambda (syntmp-tmp-1675) (if syntmp-tmp-1675 (apply (lambda () syntmp-v-1672) syntmp-tmp-1675) ((lambda (syntmp-tmp-1676) (if syntmp-tmp-1676 (apply (lambda (syntmp-e-1677) syntmp-e-1677) syntmp-tmp-1676) ((lambda (syntmp-_-1678) (syntax-error syntmp-orig-x-1644)) syntmp-tmp-1674))) (syntax-dispatch syntmp-tmp-1674 (quote (any)))))) (syntax-dispatch syntmp-tmp-1674 (quote ())))) syntmp-s-1673)) syntmp-var-1648 syntmp-step-1650))) syntmp-tmp-1646) (syntax-error syntmp-tmp-1645))) (syntax-dispatch syntmp-tmp-1645 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1644))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1706 (lambda (syntmp-x-1710 syntmp-y-1711) ((lambda (syntmp-tmp-1712) ((lambda (syntmp-tmp-1713) (if syntmp-tmp-1713 (apply (lambda (syntmp-x-1714 syntmp-y-1715) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-dy-1718) ((lambda (syntmp-tmp-1719) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-dx-1721) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1721 syntmp-dy-1718))) syntmp-tmp-1720) ((lambda (syntmp-_-1722) (if (null? syntmp-dy-1718) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1714) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1714 syntmp-y-1715))) syntmp-tmp-1719))) (syntax-dispatch syntmp-tmp-1719 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1714)) syntmp-tmp-1717) ((lambda (syntmp-tmp-1723) (if syntmp-tmp-1723 (apply (lambda (syntmp-stuff-1724) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1714 syntmp-stuff-1724))) syntmp-tmp-1723) ((lambda (syntmp-else-1725) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1714 syntmp-y-1715)) syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1715)) syntmp-tmp-1713) (syntax-error syntmp-tmp-1712))) (syntax-dispatch syntmp-tmp-1712 (quote (any any))))) (list syntmp-x-1710 syntmp-y-1711)))) (syntmp-quasiappend-1707 (lambda (syntmp-x-1726 syntmp-y-1727) ((lambda (syntmp-tmp-1728) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-x-1730 syntmp-y-1731) ((lambda (syntmp-tmp-1732) ((lambda (syntmp-tmp-1733) (if syntmp-tmp-1733 (apply (lambda () syntmp-x-1730) syntmp-tmp-1733) ((lambda (syntmp-_-1734) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1730 syntmp-y-1731)) syntmp-tmp-1732))) (syntax-dispatch syntmp-tmp-1732 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1731)) syntmp-tmp-1729) (syntax-error syntmp-tmp-1728))) (syntax-dispatch syntmp-tmp-1728 (quote (any any))))) (list syntmp-x-1726 syntmp-y-1727)))) (syntmp-quasivector-1708 (lambda (syntmp-x-1735) ((lambda (syntmp-tmp-1736) ((lambda (syntmp-x-1737) ((lambda (syntmp-tmp-1738) ((lambda (syntmp-tmp-1739) (if syntmp-tmp-1739 (apply (lambda (syntmp-x-1740) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1740))) syntmp-tmp-1739) ((lambda (syntmp-tmp-1742) (if syntmp-tmp-1742 (apply (lambda (syntmp-x-1743) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1743)) syntmp-tmp-1742) ((lambda (syntmp-_-1745) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1737)) syntmp-tmp-1738))) (syntax-dispatch syntmp-tmp-1738 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1738 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1737)) syntmp-tmp-1736)) syntmp-x-1735))) (syntmp-quasi-1709 (lambda (syntmp-p-1746 syntmp-lev-1747) ((lambda (syntmp-tmp-1748) ((lambda (syntmp-tmp-1749) (if syntmp-tmp-1749 (apply (lambda (syntmp-p-1750) (if (= syntmp-lev-1747 0) syntmp-p-1750 (syntmp-quasicons-1706 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1709 (list syntmp-p-1750) (- syntmp-lev-1747 1))))) syntmp-tmp-1749) ((lambda (syntmp-tmp-1751) (if syntmp-tmp-1751 (apply (lambda (syntmp-p-1752 syntmp-q-1753) (if (= syntmp-lev-1747 0) (syntmp-quasiappend-1707 syntmp-p-1752 (syntmp-quasi-1709 syntmp-q-1753 syntmp-lev-1747)) (syntmp-quasicons-1706 (syntmp-quasicons-1706 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1709 (list syntmp-p-1752) (- syntmp-lev-1747 1))) (syntmp-quasi-1709 syntmp-q-1753 syntmp-lev-1747)))) syntmp-tmp-1751) ((lambda (syntmp-tmp-1754) (if syntmp-tmp-1754 (apply (lambda (syntmp-p-1755) (syntmp-quasicons-1706 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1709 (list syntmp-p-1755) (+ syntmp-lev-1747 1)))) syntmp-tmp-1754) ((lambda (syntmp-tmp-1756) (if syntmp-tmp-1756 (apply (lambda (syntmp-p-1757 syntmp-q-1758) (syntmp-quasicons-1706 (syntmp-quasi-1709 syntmp-p-1757 syntmp-lev-1747) (syntmp-quasi-1709 syntmp-q-1758 syntmp-lev-1747))) syntmp-tmp-1756) ((lambda (syntmp-tmp-1759) (if syntmp-tmp-1759 (apply (lambda (syntmp-x-1760) (syntmp-quasivector-1708 (syntmp-quasi-1709 syntmp-x-1760 syntmp-lev-1747))) syntmp-tmp-1759) ((lambda (syntmp-p-1762) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1762)) syntmp-tmp-1748))) (syntax-dispatch syntmp-tmp-1748 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1748 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1748 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1748 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1748 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1746)))) (lambda (syntmp-x-1763) ((lambda (syntmp-tmp-1764) ((lambda (syntmp-tmp-1765) (if syntmp-tmp-1765 (apply (lambda (syntmp-_-1766 syntmp-e-1767) (syntmp-quasi-1709 syntmp-e-1767 0)) syntmp-tmp-1765) (syntax-error syntmp-tmp-1764))) (syntax-dispatch syntmp-tmp-1764 (quote (any any))))) syntmp-x-1763)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1827) (letrec ((syntmp-read-file-1828 (lambda (syntmp-fn-1829 syntmp-k-1830) (let ((syntmp-p-1831 (open-input-file syntmp-fn-1829))) (let syntmp-f-1832 ((syntmp-x-1833 (read syntmp-p-1831))) (if (eof-object? syntmp-x-1833) (begin (close-input-port syntmp-p-1831) (quote ())) (cons (datum->syntax-object syntmp-k-1830 syntmp-x-1833) (syntmp-f-1832 (read syntmp-p-1831))))))))) ((lambda (syntmp-tmp-1834) ((lambda (syntmp-tmp-1835) (if syntmp-tmp-1835 (apply (lambda (syntmp-k-1836 syntmp-filename-1837) (let ((syntmp-fn-1838 (syntax-object->datum syntmp-filename-1837))) ((lambda (syntmp-tmp-1839) ((lambda (syntmp-tmp-1840) (if syntmp-tmp-1840 (apply (lambda (syntmp-exp-1841) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1841)) syntmp-tmp-1840) (syntax-error syntmp-tmp-1839))) (syntax-dispatch syntmp-tmp-1839 (quote each-any)))) (syntmp-read-file-1828 syntmp-fn-1838 syntmp-k-1836)))) syntmp-tmp-1835) (syntax-error syntmp-tmp-1834))) (syntax-dispatch syntmp-tmp-1834 (quote (any any))))) syntmp-x-1827)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1858) ((lambda (syntmp-tmp-1859) ((lambda (syntmp-tmp-1860) (if syntmp-tmp-1860 (apply (lambda (syntmp-_-1861 syntmp-e-1862) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1862))) syntmp-tmp-1860) (syntax-error syntmp-tmp-1859))) (syntax-dispatch syntmp-tmp-1859 (quote (any any))))) syntmp-x-1858))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1868) ((lambda (syntmp-tmp-1869) ((lambda (syntmp-tmp-1870) (if syntmp-tmp-1870 (apply (lambda (syntmp-_-1871 syntmp-e-1872) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1872))) syntmp-tmp-1870) (syntax-error syntmp-tmp-1869))) (syntax-dispatch syntmp-tmp-1869 (quote (any any))))) syntmp-x-1868))) -(install-global-transformer (quote case) (lambda (syntmp-x-1878) ((lambda (syntmp-tmp-1879) ((lambda (syntmp-tmp-1880) (if syntmp-tmp-1880 (apply (lambda (syntmp-_-1881 syntmp-e-1882 syntmp-m1-1883 syntmp-m2-1884) ((lambda (syntmp-tmp-1885) ((lambda (syntmp-body-1886) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1882)) syntmp-body-1886)) syntmp-tmp-1885)) (let syntmp-f-1887 ((syntmp-clause-1888 syntmp-m1-1883) (syntmp-clauses-1889 syntmp-m2-1884)) (if (null? syntmp-clauses-1889) ((lambda (syntmp-tmp-1891) ((lambda (syntmp-tmp-1892) (if syntmp-tmp-1892 (apply (lambda (syntmp-e1-1893 syntmp-e2-1894) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1893 syntmp-e2-1894))) syntmp-tmp-1892) ((lambda (syntmp-tmp-1896) (if syntmp-tmp-1896 (apply (lambda (syntmp-k-1897 syntmp-e1-1898 syntmp-e2-1899) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1897)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1898 syntmp-e2-1899)))) syntmp-tmp-1896) ((lambda (syntmp-_-1902) (syntax-error syntmp-x-1878)) syntmp-tmp-1891))) (syntax-dispatch syntmp-tmp-1891 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1891 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1888) ((lambda (syntmp-tmp-1903) ((lambda (syntmp-rest-1904) ((lambda (syntmp-tmp-1905) ((lambda (syntmp-tmp-1906) (if syntmp-tmp-1906 (apply (lambda (syntmp-k-1907 syntmp-e1-1908 syntmp-e2-1909) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1907)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1908 syntmp-e2-1909)) syntmp-rest-1904)) syntmp-tmp-1906) ((lambda (syntmp-_-1912) (syntax-error syntmp-x-1878)) syntmp-tmp-1905))) (syntax-dispatch syntmp-tmp-1905 (quote (each-any any . each-any))))) syntmp-clause-1888)) syntmp-tmp-1903)) (syntmp-f-1887 (car syntmp-clauses-1889) (cdr syntmp-clauses-1889))))))) syntmp-tmp-1880) (syntax-error syntmp-tmp-1879))) (syntax-dispatch syntmp-tmp-1879 (quote (any any any . each-any))))) syntmp-x-1878))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1942) ((lambda (syntmp-tmp-1943) ((lambda (syntmp-tmp-1944) (if syntmp-tmp-1944 (apply (lambda (syntmp-_-1945 syntmp-e-1946) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1946)) (list (cons syntmp-_-1945 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1946 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1944) (syntax-error syntmp-tmp-1943))) (syntax-dispatch syntmp-tmp-1943 (quote (any any))))) syntmp-x-1942))) +(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-544) (let syntmp-lvl-545 ((syntmp-vars-546 syntmp-vars-544) (syntmp-ls-547 (quote ())) (syntmp-w-548 (quote (())))) (cond ((pair? syntmp-vars-546) (syntmp-lvl-545 (cdr syntmp-vars-546) (cons (syntmp-wrap-132 (car syntmp-vars-546) syntmp-w-548 #f) syntmp-ls-547) syntmp-w-548)) ((syntmp-id?-104 syntmp-vars-546) (cons (syntmp-wrap-132 syntmp-vars-546 syntmp-w-548 #f) syntmp-ls-547)) ((null? syntmp-vars-546) syntmp-ls-547) ((syntmp-syntax-object?-88 syntmp-vars-546) (syntmp-lvl-545 (syntmp-syntax-object-expression-89 syntmp-vars-546) syntmp-ls-547 (syntmp-join-wraps-123 syntmp-w-548 (syntmp-syntax-object-wrap-90 syntmp-vars-546)))) ((annotation? syntmp-vars-546) (syntmp-lvl-545 (annotation-expression syntmp-vars-546) syntmp-ls-547 syntmp-w-548)) (else (cons syntmp-vars-546 syntmp-ls-547)))))) (syntmp-gen-var-152 (lambda (syntmp-id-549) (let ((syntmp-id-550 (if (syntmp-syntax-object?-88 syntmp-id-549) (syntmp-syntax-object-expression-89 syntmp-id-549) syntmp-id-549))) (if (annotation? syntmp-id-550) (syntmp-build-annotated-81 (annotation-source syntmp-id-550) (gensym (symbol->string (annotation-expression syntmp-id-550)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-550))))))) (syntmp-strip-151 (lambda (syntmp-x-551 syntmp-w-552) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-552)) (if (or (annotation? syntmp-x-551) (and (pair? syntmp-x-551) (annotation? (car syntmp-x-551)))) (syntmp-strip-annotation-150 syntmp-x-551 #f) syntmp-x-551) (let syntmp-f-553 ((syntmp-x-554 syntmp-x-551)) (cond ((syntmp-syntax-object?-88 syntmp-x-554) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-554) (syntmp-syntax-object-wrap-90 syntmp-x-554))) ((pair? syntmp-x-554) (let ((syntmp-a-555 (syntmp-f-553 (car syntmp-x-554))) (syntmp-d-556 (syntmp-f-553 (cdr syntmp-x-554)))) (if (and (eq? syntmp-a-555 (car syntmp-x-554)) (eq? syntmp-d-556 (cdr syntmp-x-554))) syntmp-x-554 (cons syntmp-a-555 syntmp-d-556)))) ((vector? syntmp-x-554) (let ((syntmp-old-557 (vector->list syntmp-x-554))) (let ((syntmp-new-558 (map syntmp-f-553 syntmp-old-557))) (if (andmap eq? syntmp-old-557 syntmp-new-558) syntmp-x-554 (list->vector syntmp-new-558))))) (else syntmp-x-554)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-559 syntmp-parent-560) (cond ((pair? syntmp-x-559) (let ((syntmp-new-561 (cons #f #f))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-561)) (set-car! syntmp-new-561 (syntmp-strip-annotation-150 (car syntmp-x-559) #f)) (set-cdr! syntmp-new-561 (syntmp-strip-annotation-150 (cdr syntmp-x-559) #f)) syntmp-new-561))) ((annotation? syntmp-x-559) (or (annotation-stripped syntmp-x-559) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-559) syntmp-x-559))) ((vector? syntmp-x-559) (let ((syntmp-new-562 (make-vector (vector-length syntmp-x-559)))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-562)) (let syntmp-loop-563 ((syntmp-i-564 (- (vector-length syntmp-x-559) 1))) (unless (syntmp-fx<-75 syntmp-i-564 0) (vector-set! syntmp-new-562 syntmp-i-564 (syntmp-strip-annotation-150 (vector-ref syntmp-x-559 syntmp-i-564) #f)) (syntmp-loop-563 (syntmp-fx--73 syntmp-i-564 1)))) syntmp-new-562))) (else syntmp-x-559)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-565) (and (syntmp-nonsymbol-id?-103 syntmp-x-565) (syntmp-free-id=?-127 syntmp-x-565 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-566 syntmp-mod-567) (let ((syntmp-p-568 (syntmp-local-eval-hook-77 syntmp-expanded-566 syntmp-mod-567))) (if (procedure? syntmp-p-568) syntmp-p-568 (syntax-error syntmp-p-568 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-569 syntmp-e-570 syntmp-r-571 syntmp-w-572 syntmp-s-573 syntmp-mod-574 syntmp-k-575) ((lambda (syntmp-tmp-576) ((lambda (syntmp-tmp-577) (if syntmp-tmp-577 (apply (lambda (syntmp-_-578 syntmp-id-579 syntmp-val-580 syntmp-e1-581 syntmp-e2-582) (let ((syntmp-ids-583 syntmp-id-579)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-583)) (syntax-error syntmp-e-570 "duplicate bound keyword in") (let ((syntmp-labels-585 (syntmp-gen-labels-110 syntmp-ids-583))) (let ((syntmp-new-w-586 (syntmp-make-binding-wrap-121 syntmp-ids-583 syntmp-labels-585 syntmp-w-572))) (syntmp-k-575 (cons syntmp-e1-581 syntmp-e2-582) (syntmp-extend-env-98 syntmp-labels-585 (let ((syntmp-w-588 (if syntmp-rec?-569 syntmp-new-w-586 syntmp-w-572)) (syntmp-trans-r-589 (syntmp-macros-only-env-100 syntmp-r-571))) (map (lambda (syntmp-x-590) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-590 syntmp-trans-r-589 syntmp-w-588 syntmp-mod-574) syntmp-mod-574))) syntmp-val-580)) syntmp-r-571) syntmp-new-w-586 syntmp-s-573 syntmp-mod-574)))))) syntmp-tmp-577) ((lambda (syntmp-_-592) (syntax-error (syntmp-source-wrap-133 syntmp-e-570 syntmp-w-572 syntmp-s-573 syntmp-mod-574))) syntmp-tmp-576))) (syntax-dispatch syntmp-tmp-576 (quote (any #(each (any any)) any . each-any))))) syntmp-e-570))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-593 syntmp-c-594 syntmp-r-595 syntmp-w-596 syntmp-mod-597 syntmp-k-598) ((lambda (syntmp-tmp-599) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-id-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-ids-604 syntmp-id-601)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-604)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-606 (syntmp-gen-labels-110 syntmp-ids-604)) (syntmp-new-vars-607 (map syntmp-gen-var-152 syntmp-ids-604))) (syntmp-k-598 syntmp-new-vars-607 (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-606 syntmp-new-vars-607 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-ids-604 syntmp-labels-606 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-600) ((lambda (syntmp-tmp-609) (if syntmp-tmp-609 (apply (lambda (syntmp-ids-610 syntmp-e1-611 syntmp-e2-612) (let ((syntmp-old-ids-613 (syntmp-lambda-var-list-153 syntmp-ids-610))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-613)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-614 (syntmp-gen-labels-110 syntmp-old-ids-613)) (syntmp-new-vars-615 (map syntmp-gen-var-152 syntmp-old-ids-613))) (syntmp-k-598 (let syntmp-f-616 ((syntmp-ls1-617 (cdr syntmp-new-vars-615)) (syntmp-ls2-618 (car syntmp-new-vars-615))) (if (null? syntmp-ls1-617) syntmp-ls2-618 (syntmp-f-616 (cdr syntmp-ls1-617) (cons (car syntmp-ls1-617) syntmp-ls2-618)))) (syntmp-chi-body-144 (cons syntmp-e1-611 syntmp-e2-612) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-614 syntmp-new-vars-615 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-old-ids-613 syntmp-labels-614 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-609) ((lambda (syntmp-_-620) (syntax-error syntmp-e-593)) syntmp-tmp-599))) (syntax-dispatch syntmp-tmp-599 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-599 (quote (each-any any . each-any))))) syntmp-c-594))) (syntmp-chi-body-144 (lambda (syntmp-body-621 syntmp-outer-form-622 syntmp-r-623 syntmp-w-624 syntmp-mod-625) (let ((syntmp-r-626 (cons (quote ("placeholder" placeholder)) syntmp-r-623))) (let ((syntmp-ribcage-627 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-628 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-624) (cons syntmp-ribcage-627 (syntmp-wrap-subst-108 syntmp-w-624))))) (let syntmp-parse-629 ((syntmp-body-630 (map (lambda (syntmp-x-636) (cons syntmp-r-626 (syntmp-wrap-132 syntmp-x-636 syntmp-w-628 syntmp-mod-625))) syntmp-body-621)) (syntmp-ids-631 (quote ())) (syntmp-labels-632 (quote ())) (syntmp-vars-633 (quote ())) (syntmp-vals-634 (quote ())) (syntmp-bindings-635 (quote ()))) (if (null? syntmp-body-630) (syntax-error syntmp-outer-form-622 "no expressions in body") (let ((syntmp-e-637 (cdar syntmp-body-630)) (syntmp-er-638 (caar syntmp-body-630))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-637 syntmp-er-638 (quote (())) #f syntmp-ribcage-627 syntmp-mod-625)) (lambda (syntmp-type-639 syntmp-value-640 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644) (let ((syntmp-t-645 syntmp-type-639)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-647 (syntmp-gen-label-109))) (let ((syntmp-var-648 (syntmp-gen-var-152 syntmp-id-646))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-646 syntmp-label-647) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-646 syntmp-ids-631) (cons syntmp-label-647 syntmp-labels-632) (cons syntmp-var-648 syntmp-vars-633) (cons (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644)) syntmp-vals-634) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-635))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-650 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-649 syntmp-label-650) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-649 syntmp-ids-631) (cons syntmp-label-650 syntmp-labels-632) syntmp-vars-633 syntmp-vals-634 (cons (cons (quote macro) (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644))) syntmp-bindings-635)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-629 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-630) (cons (cons syntmp-er-638 (syntmp-wrap-132 (car syntmp-forms-656) syntmp-w-642 syntmp-mod-644)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-641) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-640 syntmp-e-641 syntmp-er-638 syntmp-w-642 syntmp-s-643 syntmp-mod-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661 syntmp-mod-662) (syntmp-parse-629 (let syntmp-f-663 ((syntmp-forms-664 syntmp-forms-658)) (if (null? syntmp-forms-664) (cdr syntmp-body-630) (cons (cons syntmp-er-659 (syntmp-wrap-132 (car syntmp-forms-664) syntmp-w-660 syntmp-mod-662)) (syntmp-f-663 (cdr syntmp-forms-664))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635))) (if (null? syntmp-ids-631) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-665) (syntmp-chi-140 (cdr syntmp-x-665) (car syntmp-x-665) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-631)) (syntax-error syntmp-outer-form-622 "invalid or duplicate identifier in definition")) (let syntmp-loop-666 ((syntmp-bs-667 syntmp-bindings-635) (syntmp-er-cache-668 #f) (syntmp-r-cache-669 #f)) (if (not (null? syntmp-bs-667)) (let ((syntmp-b-670 (car syntmp-bs-667))) (if (eq? (car syntmp-b-670) (quote macro)) (let ((syntmp-er-671 (cadr syntmp-b-670))) (let ((syntmp-r-cache-672 (if (eq? syntmp-er-671 syntmp-er-cache-668) syntmp-r-cache-669 (syntmp-macros-only-env-100 syntmp-er-671)))) (begin (set-cdr! syntmp-b-670 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-670) syntmp-r-cache-672 (quote (())) syntmp-mod-644) syntmp-mod-644)) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-671 syntmp-r-cache-672)))) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-cache-668 syntmp-r-cache-669))))) (set-cdr! syntmp-r-626 (syntmp-extend-env-98 syntmp-labels-632 syntmp-bindings-635 (cdr syntmp-r-626))) (syntmp-build-letrec-86 #f syntmp-vars-633 (map (lambda (syntmp-x-673) (syntmp-chi-140 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())) syntmp-mod-644)) syntmp-vals-634) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-674) (syntmp-chi-140 (cdr syntmp-x-674) (car syntmp-x-674) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-675 syntmp-e-676 syntmp-r-677 syntmp-w-678 syntmp-rib-679 syntmp-mod-680) (letrec ((syntmp-rebuild-macro-output-681 (lambda (syntmp-x-682 syntmp-m-683) (cond ((pair? syntmp-x-682) (cons (syntmp-rebuild-macro-output-681 (car syntmp-x-682) syntmp-m-683) (syntmp-rebuild-macro-output-681 (cdr syntmp-x-682) syntmp-m-683))) ((syntmp-syntax-object?-88 syntmp-x-682) (let ((syntmp-w-684 (syntmp-syntax-object-wrap-90 syntmp-x-682))) (let ((syntmp-ms-685 (syntmp-wrap-marks-107 syntmp-w-684)) (syntmp-s-686 (syntmp-wrap-subst-108 syntmp-w-684))) (if (and (pair? syntmp-ms-685) (eq? (car syntmp-ms-685) #f)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cdr syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cdr syntmp-s-686)) (cdr syntmp-s-686))) (syntmp-syntax-object-module-91 syntmp-x-682)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cons syntmp-m-683 syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cons (quote shift) syntmp-s-686)) (cons (quote shift) syntmp-s-686))) (module-name (procedure-module syntmp-p-675))))))) ((vector? syntmp-x-682) (let ((syntmp-n-687 (vector-length syntmp-x-682))) (let ((syntmp-v-688 (make-vector syntmp-n-687))) (let syntmp-doloop-689 ((syntmp-i-690 0)) (if (syntmp-fx=-74 syntmp-i-690 syntmp-n-687) syntmp-v-688 (begin (vector-set! syntmp-v-688 syntmp-i-690 (syntmp-rebuild-macro-output-681 (vector-ref syntmp-x-682 syntmp-i-690) syntmp-m-683)) (syntmp-doloop-689 (syntmp-fx+-72 syntmp-i-690 1)))))))) ((symbol? syntmp-x-682) (syntax-error syntmp-x-682 "encountered raw symbol in macro output")) (else syntmp-x-682))))) (syntmp-rebuild-macro-output-681 (syntmp-p-675 (syntmp-wrap-132 syntmp-e-676 (syntmp-anti-mark-119 syntmp-w-678) syntmp-mod-680)) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-691 syntmp-e-692 syntmp-r-693 syntmp-w-694 syntmp-s-695 syntmp-mod-696) ((lambda (syntmp-tmp-697) ((lambda (syntmp-tmp-698) (if syntmp-tmp-698 (apply (lambda (syntmp-e0-699 syntmp-e1-700) (syntmp-build-annotated-81 syntmp-s-695 (cons syntmp-x-691 (map (lambda (syntmp-e-701) (syntmp-chi-140 syntmp-e-701 syntmp-r-693 syntmp-w-694 syntmp-mod-696)) syntmp-e1-700)))) syntmp-tmp-698) (syntax-error syntmp-tmp-697))) (syntax-dispatch syntmp-tmp-697 (quote (any . each-any))))) syntmp-e-692))) (syntmp-chi-expr-141 (lambda (syntmp-type-703 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (let ((syntmp-t-710 syntmp-type-703)) (if (memv syntmp-t-710 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-708 syntmp-value-704) (if (memv syntmp-t-710 (quote (core external-macro))) (syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-704 syntmp-e-705)) (lambda (syntmp-id-711 syntmp-mod-712) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-712 syntmp-id-711 #f)))) (if (memv syntmp-t-710 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) syntmp-value-704) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) (make-module-ref (if (syntmp-syntax-object?-88 (car syntmp-e-705)) (syntmp-syntax-object-module-91 (car syntmp-e-705)) syntmp-mod-709) syntmp-value-704 #f)) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (constant))) (syntmp-build-data-82 syntmp-s-708 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (quote (())))) (if (memv syntmp-t-710 (quote (global))) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-709 syntmp-value-704 #f)) (if (memv syntmp-t-710 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-705) syntmp-r-706 syntmp-w-707 syntmp-mod-709) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (begin-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-e1-716 syntmp-e2-717) (syntmp-chi-sequence-134 (cons syntmp-e1-716 syntmp-e2-717) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709)) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709 syntmp-chi-sequence-134) (if (memv syntmp-t-710 (quote (eval-when-form))) ((lambda (syntmp-tmp-719) ((lambda (syntmp-tmp-720) (if syntmp-tmp-720 (apply (lambda (syntmp-_-721 syntmp-x-722 syntmp-e1-723 syntmp-e2-724) (let ((syntmp-when-list-725 (syntmp-chi-when-list-137 syntmp-e-705 syntmp-x-722 syntmp-w-707))) (if (memq (quote eval) syntmp-when-list-725) (syntmp-chi-sequence-134 (cons syntmp-e1-723 syntmp-e2-724) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (syntmp-chi-void-148)))) syntmp-tmp-720) (syntax-error syntmp-tmp-719))) (syntax-dispatch syntmp-tmp-719 (quote (any each-any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-704 syntmp-w-707 syntmp-mod-709) "invalid context for definition of") (if (memv syntmp-t-710 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to pattern variable outside syntax form") (if (memv syntmp-t-710 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709))))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-728 syntmp-r-729 syntmp-w-730 syntmp-mod-731) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-728 syntmp-r-729 syntmp-w-730 #f #f syntmp-mod-731)) (lambda (syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-w-735 syntmp-s-736 syntmp-mod-737) (syntmp-chi-expr-141 syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-r-729 syntmp-w-735 syntmp-s-736 syntmp-mod-737))))) (syntmp-chi-top-139 (lambda (syntmp-e-738 syntmp-r-739 syntmp-w-740 syntmp-m-741 syntmp-esew-742 syntmp-mod-743) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-738 syntmp-r-739 syntmp-w-740 #f #f syntmp-mod-743)) (lambda (syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-w-761 syntmp-s-762 syntmp-mod-763) (let ((syntmp-t-764 syntmp-type-758)) (if (memv syntmp-t-764 (quote (begin-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767) (syntmp-chi-void-148)) syntmp-tmp-766) ((lambda (syntmp-tmp-768) (if syntmp-tmp-768 (apply (lambda (syntmp-_-769 syntmp-e1-770 syntmp-e2-771) (syntmp-chi-top-sequence-135 (cons syntmp-e1-770 syntmp-e2-771) syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-m-741 syntmp-esew-742 syntmp-mod-763)) syntmp-tmp-768) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-765 (quote (any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763 (lambda (syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-mod-777) (syntmp-chi-top-sequence-135 syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-m-741 syntmp-esew-742 syntmp-mod-777))) (if (memv syntmp-t-764 (quote (eval-when-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-x-781 syntmp-e1-782 syntmp-e2-783) (let ((syntmp-when-list-784 (syntmp-chi-when-list-137 syntmp-e-760 syntmp-x-781 syntmp-w-761)) (syntmp-body-785 (cons syntmp-e1-782 syntmp-e2-783))) (cond ((eq? syntmp-m-741 (quote e)) (if (memq (quote eval) syntmp-when-list-784) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-784) (if (or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c&e) (quote (compile load)) syntmp-mod-763) (if (memq syntmp-m-741 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c) (quote (load)) syntmp-mod-763) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) syntmp-mod-763) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-779) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any each-any any . each-any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (define-syntax-form))) (let ((syntmp-n-788 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761)) (syntmp-r-789 (syntmp-macros-only-env-100 syntmp-r-739))) (let ((syntmp-t-790 syntmp-m-741)) (if (memv syntmp-t-790 (quote (c))) (if (memq (quote compile) syntmp-esew-742) (let ((syntmp-e-791 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-791 syntmp-mod-763) (if (memq (quote load) syntmp-esew-742) syntmp-e-791 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-742) (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) (syntmp-chi-void-148))) (if (memv syntmp-t-790 (quote (c&e))) (let ((syntmp-e-792 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-792 syntmp-mod-763) syntmp-e-792)) (begin (if (memq (quote eval) syntmp-esew-742) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) syntmp-mod-763)) (syntmp-chi-void-148)))))) (if (memv syntmp-t-764 (quote (define-form))) (let ((syntmp-n-793 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761))) (let ((syntmp-type-794 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-793 syntmp-r-739 syntmp-mod-763)))) (let ((syntmp-t-795 syntmp-type-794)) (if (memv syntmp-t-795 (quote (global))) (let ((syntmp-x-796 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-796 syntmp-mod-763)) syntmp-x-796)) (if (memv syntmp-t-795 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "identifier out of context") (if (eq? syntmp-type-794 (quote external-macro)) (let ((syntmp-x-797 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-797 syntmp-mod-763)) syntmp-x-797)) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "cannot define keyword at top level"))))))) (let ((syntmp-x-798 (syntmp-chi-expr-141 syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-798 syntmp-mod-763)) syntmp-x-798)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (cond ((symbol? syntmp-e-799) (let ((syntmp-n-805 (syntmp-id-var-name-126 syntmp-e-799 syntmp-w-801))) (let ((syntmp-b-806 (syntmp-lookup-101 syntmp-n-805 syntmp-r-800 syntmp-mod-804))) (let ((syntmp-type-807 (syntmp-binding-type-96 syntmp-b-806))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (lexical))) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (global))) (values syntmp-type-807 syntmp-n-805 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))))))) ((pair? syntmp-e-799) (let ((syntmp-first-809 (car syntmp-e-799))) (if (syntmp-id?-104 syntmp-first-809) (let ((syntmp-n-810 (syntmp-id-var-name-126 syntmp-first-809 syntmp-w-801))) (let ((syntmp-b-811 (syntmp-lookup-101 syntmp-n-810 syntmp-r-800 (or (and (syntmp-syntax-object?-88 syntmp-first-809) (syntmp-syntax-object-module-91 syntmp-first-809)) syntmp-mod-804)))) (let ((syntmp-type-812 (syntmp-binding-type-96 syntmp-b-811))) (let ((syntmp-t-813 syntmp-type-812)) (if (memv syntmp-t-813 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (global))) (values (quote global-call) syntmp-n-810 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (if (memv syntmp-t-813 (quote (core external-macro module-ref))) (values syntmp-type-812 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (begin))) (values (quote begin-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (define))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-form) syntmp-name-820 syntmp-val-821 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-815) ((lambda (syntmp-tmp-822) (if (if syntmp-tmp-822 (apply (lambda (syntmp-_-823 syntmp-name-824 syntmp-args-825 syntmp-e1-826 syntmp-e2-827) (and (syntmp-id?-104 syntmp-name-824) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-825)))) syntmp-tmp-822) #f) (apply (lambda (syntmp-_-828 syntmp-name-829 syntmp-args-830 syntmp-e1-831 syntmp-e2-832) (values (quote define-form) (syntmp-wrap-132 syntmp-name-829 syntmp-w-801 syntmp-mod-804) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-132 (cons syntmp-args-830 (cons syntmp-e1-831 syntmp-e2-832)) syntmp-w-801 syntmp-mod-804)) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-822) ((lambda (syntmp-tmp-834) (if (if syntmp-tmp-834 (apply (lambda (syntmp-_-835 syntmp-name-836) (syntmp-id?-104 syntmp-name-836)) syntmp-tmp-834) #f) (apply (lambda (syntmp-_-837 syntmp-name-838) (values (quote define-form) (syntmp-wrap-132 syntmp-name-838 syntmp-w-801 syntmp-mod-804) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-834) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-799) (if (memv syntmp-t-813 (quote (define-syntax))) ((lambda (syntmp-tmp-839) ((lambda (syntmp-tmp-840) (if (if syntmp-tmp-840 (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-val-843) (syntmp-id?-104 syntmp-name-842)) syntmp-tmp-840) #f) (apply (lambda (syntmp-_-844 syntmp-name-845 syntmp-val-846) (values (quote define-syntax-form) syntmp-name-845 syntmp-val-846 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-840) (syntax-error syntmp-tmp-839))) (syntax-dispatch syntmp-tmp-839 (quote (any any any))))) syntmp-e-799) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))))))))))))) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))) ((syntmp-syntax-object?-88 syntmp-e-799) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-799) syntmp-r-800 (syntmp-join-wraps-123 syntmp-w-801 (syntmp-syntax-object-wrap-90 syntmp-e-799)) #f syntmp-rib-803 (or (syntmp-syntax-object-module-91 syntmp-e-799) syntmp-mod-804))) ((annotation? syntmp-e-799) (syntmp-syntax-type-138 (annotation-expression syntmp-e-799) syntmp-r-800 syntmp-w-801 (annotation-source syntmp-e-799) syntmp-rib-803 syntmp-mod-804)) ((self-evaluating? syntmp-e-799) (values (quote constant) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) (else (values (quote other) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-847 syntmp-when-list-848 syntmp-w-849) (let syntmp-f-850 ((syntmp-when-list-851 syntmp-when-list-848) (syntmp-situations-852 (quote ()))) (if (null? syntmp-when-list-851) syntmp-situations-852 (syntmp-f-850 (cdr syntmp-when-list-851) (cons (let ((syntmp-x-853 (car syntmp-when-list-851))) (cond ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-853 syntmp-w-849 #f) "invalid eval-when situation")))) syntmp-situations-852)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-854 syntmp-e-855) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-854) syntmp-e-855)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-856 syntmp-r-857 syntmp-w-858 syntmp-s-859 syntmp-m-860 syntmp-esew-861 syntmp-mod-862) (syntmp-build-sequence-83 syntmp-s-859 (let syntmp-dobody-863 ((syntmp-body-864 syntmp-body-856) (syntmp-r-865 syntmp-r-857) (syntmp-w-866 syntmp-w-858) (syntmp-m-867 syntmp-m-860) (syntmp-esew-868 syntmp-esew-861) (syntmp-mod-869 syntmp-mod-862)) (if (null? syntmp-body-864) (quote ()) (let ((syntmp-first-870 (syntmp-chi-top-139 (car syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869))) (cons syntmp-first-870 (syntmp-dobody-863 (cdr syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873 syntmp-s-874 syntmp-mod-875) (syntmp-build-sequence-83 syntmp-s-874 (let syntmp-dobody-876 ((syntmp-body-877 syntmp-body-871) (syntmp-r-878 syntmp-r-872) (syntmp-w-879 syntmp-w-873) (syntmp-mod-880 syntmp-mod-875)) (if (null? syntmp-body-877) (quote ()) (let ((syntmp-first-881 (syntmp-chi-140 (car syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880))) (cons syntmp-first-881 (syntmp-dobody-876 (cdr syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-882 syntmp-w-883 syntmp-s-884 syntmp-defmod-885) (syntmp-wrap-132 (if syntmp-s-884 (make-annotation syntmp-x-882 syntmp-s-884 #f) syntmp-x-882) syntmp-w-883 syntmp-defmod-885))) (syntmp-wrap-132 (lambda (syntmp-x-886 syntmp-w-887 syntmp-defmod-888) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-887)) (null? (syntmp-wrap-subst-108 syntmp-w-887))) syntmp-x-886) ((syntmp-syntax-object?-88 syntmp-x-886) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-886) (syntmp-join-wraps-123 syntmp-w-887 (syntmp-syntax-object-wrap-90 syntmp-x-886)) (syntmp-syntax-object-module-91 syntmp-x-886))) ((null? syntmp-x-886) syntmp-x-886) (else (syntmp-make-syntax-object-87 syntmp-x-886 syntmp-w-887 syntmp-defmod-888))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-889 syntmp-list-890) (and (not (null? syntmp-list-890)) (or (syntmp-bound-id=?-128 syntmp-x-889 (car syntmp-list-890)) (syntmp-bound-id-member?-131 syntmp-x-889 (cdr syntmp-list-890)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-891) (let syntmp-distinct?-892 ((syntmp-ids-893 syntmp-ids-891)) (or (null? syntmp-ids-893) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-893) (cdr syntmp-ids-893))) (syntmp-distinct?-892 (cdr syntmp-ids-893))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-894) (and (let syntmp-all-ids?-895 ((syntmp-ids-896 syntmp-ids-894)) (or (null? syntmp-ids-896) (and (syntmp-id?-104 (car syntmp-ids-896)) (syntmp-all-ids?-895 (cdr syntmp-ids-896))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-894)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-897 syntmp-j-898) (if (and (syntmp-syntax-object?-88 syntmp-i-897) (syntmp-syntax-object?-88 syntmp-j-898)) (and (eq? (let ((syntmp-e-899 (syntmp-syntax-object-expression-89 syntmp-i-897))) (if (annotation? syntmp-e-899) (annotation-expression syntmp-e-899) syntmp-e-899)) (let ((syntmp-e-900 (syntmp-syntax-object-expression-89 syntmp-j-898))) (if (annotation? syntmp-e-900) (annotation-expression syntmp-e-900) syntmp-e-900))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-897)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-898)))) (eq? (let ((syntmp-e-901 syntmp-i-897)) (if (annotation? syntmp-e-901) (annotation-expression syntmp-e-901) syntmp-e-901)) (let ((syntmp-e-902 syntmp-j-898)) (if (annotation? syntmp-e-902) (annotation-expression syntmp-e-902) syntmp-e-902)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-903 syntmp-j-904) (and (eq? (let ((syntmp-x-905 syntmp-i-903)) (let ((syntmp-e-906 (if (syntmp-syntax-object?-88 syntmp-x-905) (syntmp-syntax-object-expression-89 syntmp-x-905) syntmp-x-905))) (if (annotation? syntmp-e-906) (annotation-expression syntmp-e-906) syntmp-e-906))) (let ((syntmp-x-907 syntmp-j-904)) (let ((syntmp-e-908 (if (syntmp-syntax-object?-88 syntmp-x-907) (syntmp-syntax-object-expression-89 syntmp-x-907) syntmp-x-907))) (if (annotation? syntmp-e-908) (annotation-expression syntmp-e-908) syntmp-e-908)))) (eq? (syntmp-id-var-name-126 syntmp-i-903 (quote (()))) (syntmp-id-var-name-126 syntmp-j-904 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-909 syntmp-w-910) (letrec ((syntmp-search-vector-rib-913 (lambda (syntmp-sym-924 syntmp-subst-925 syntmp-marks-926 syntmp-symnames-927 syntmp-ribcage-928) (let ((syntmp-n-929 (vector-length syntmp-symnames-927))) (let syntmp-f-930 ((syntmp-i-931 0)) (cond ((syntmp-fx=-74 syntmp-i-931 syntmp-n-929) (syntmp-search-911 syntmp-sym-924 (cdr syntmp-subst-925) syntmp-marks-926)) ((and (eq? (vector-ref syntmp-symnames-927 syntmp-i-931) syntmp-sym-924) (syntmp-same-marks?-125 syntmp-marks-926 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-928) syntmp-i-931))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-928) syntmp-i-931) syntmp-marks-926)) (else (syntmp-f-930 (syntmp-fx+-72 syntmp-i-931 1)))))))) (syntmp-search-list-rib-912 (lambda (syntmp-sym-932 syntmp-subst-933 syntmp-marks-934 syntmp-symnames-935 syntmp-ribcage-936) (let syntmp-f-937 ((syntmp-symnames-938 syntmp-symnames-935) (syntmp-i-939 0)) (cond ((null? syntmp-symnames-938) (syntmp-search-911 syntmp-sym-932 (cdr syntmp-subst-933) syntmp-marks-934)) ((and (eq? (car syntmp-symnames-938) syntmp-sym-932) (syntmp-same-marks?-125 syntmp-marks-934 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-936) syntmp-i-939))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-936) syntmp-i-939) syntmp-marks-934)) (else (syntmp-f-937 (cdr syntmp-symnames-938) (syntmp-fx+-72 syntmp-i-939 1))))))) (syntmp-search-911 (lambda (syntmp-sym-940 syntmp-subst-941 syntmp-marks-942) (if (null? syntmp-subst-941) (values #f syntmp-marks-942) (let ((syntmp-fst-943 (car syntmp-subst-941))) (if (eq? syntmp-fst-943 (quote shift)) (syntmp-search-911 syntmp-sym-940 (cdr syntmp-subst-941) (cdr syntmp-marks-942)) (let ((syntmp-symnames-944 (syntmp-ribcage-symnames-113 syntmp-fst-943))) (if (vector? syntmp-symnames-944) (syntmp-search-vector-rib-913 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943) (syntmp-search-list-rib-912 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943))))))))) (cond ((symbol? syntmp-id-909) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-909 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-946 . syntmp-ignore-945) syntmp-x-946)) syntmp-id-909)) ((syntmp-syntax-object?-88 syntmp-id-909) (let ((syntmp-id-947 (let ((syntmp-e-949 (syntmp-syntax-object-expression-89 syntmp-id-909))) (if (annotation? syntmp-e-949) (annotation-expression syntmp-e-949) syntmp-e-949))) (syntmp-w1-948 (syntmp-syntax-object-wrap-90 syntmp-id-909))) (let ((syntmp-marks-950 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w1-948)))) (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w-910) syntmp-marks-950)) (lambda (syntmp-new-id-951 syntmp-marks-952) (or syntmp-new-id-951 (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w1-948) syntmp-marks-952)) (lambda (syntmp-x-954 . syntmp-ignore-953) syntmp-x-954)) syntmp-id-947)))))) ((annotation? syntmp-id-909) (let ((syntmp-id-955 (let ((syntmp-e-956 syntmp-id-909)) (if (annotation? syntmp-e-956) (annotation-expression syntmp-e-956) syntmp-e-956)))) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-955 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-958 . syntmp-ignore-957) syntmp-x-958)) syntmp-id-955))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-909)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-959 syntmp-y-960) (or (eq? syntmp-x-959 syntmp-y-960) (and (not (null? syntmp-x-959)) (not (null? syntmp-y-960)) (eq? (car syntmp-x-959) (car syntmp-y-960)) (syntmp-same-marks?-125 (cdr syntmp-x-959) (cdr syntmp-y-960)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-961 syntmp-m2-962) (syntmp-smart-append-122 syntmp-m1-961 syntmp-m2-962))) (syntmp-join-wraps-123 (lambda (syntmp-w1-963 syntmp-w2-964) (let ((syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w1-963)) (syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w1-963))) (if (null? syntmp-m1-965) (if (null? syntmp-s1-966) syntmp-w2-964 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-964) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w2-964)) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-967 syntmp-m2-968) (if (null? syntmp-m2-968) syntmp-m1-967 (append syntmp-m1-967 syntmp-m2-968)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-969 syntmp-labels-970 syntmp-w-971) (if (null? syntmp-ids-969) syntmp-w-971 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-971) (cons (let ((syntmp-labelvec-972 (list->vector syntmp-labels-970))) (let ((syntmp-n-973 (vector-length syntmp-labelvec-972))) (let ((syntmp-symnamevec-974 (make-vector syntmp-n-973)) (syntmp-marksvec-975 (make-vector syntmp-n-973))) (begin (let syntmp-f-976 ((syntmp-ids-977 syntmp-ids-969) (syntmp-i-978 0)) (if (not (null? syntmp-ids-977)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-977) syntmp-w-971)) (lambda (syntmp-symname-979 syntmp-marks-980) (begin (vector-set! syntmp-symnamevec-974 syntmp-i-978 syntmp-symname-979) (vector-set! syntmp-marksvec-975 syntmp-i-978 syntmp-marks-980) (syntmp-f-976 (cdr syntmp-ids-977) (syntmp-fx+-72 syntmp-i-978 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-974 syntmp-marksvec-975 syntmp-labelvec-972))))) (syntmp-wrap-subst-108 syntmp-w-971)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-981 syntmp-id-982 syntmp-label-983) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-981 (cons (let ((syntmp-e-984 (syntmp-syntax-object-expression-89 syntmp-id-982))) (if (annotation? syntmp-e-984) (annotation-expression syntmp-e-984) syntmp-e-984)) (syntmp-ribcage-symnames-113 syntmp-ribcage-981))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-981 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-982)) (syntmp-ribcage-marks-114 syntmp-ribcage-981))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-981 (cons syntmp-label-983 (syntmp-ribcage-labels-115 syntmp-ribcage-981)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-985) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-985)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-985))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-986 syntmp-update-987) (vector-set! syntmp-x-986 3 syntmp-update-987))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-988 syntmp-update-989) (vector-set! syntmp-x-988 2 syntmp-update-989))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-990 syntmp-update-991) (vector-set! syntmp-x-990 1 syntmp-update-991))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-992) (vector-ref syntmp-x-992 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 4) (eq? (vector-ref syntmp-x-995 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998) (vector (quote ribcage) syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998))) (syntmp-gen-labels-110 (lambda (syntmp-ls-999) (if (null? syntmp-ls-999) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-999)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-1000 syntmp-w-1001) (if (syntmp-syntax-object?-88 syntmp-x-1000) (values (let ((syntmp-e-1002 (syntmp-syntax-object-expression-89 syntmp-x-1000))) (if (annotation? syntmp-e-1002) (annotation-expression syntmp-e-1002) syntmp-e-1002)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-1001) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-1000)))) (values (let ((syntmp-e-1003 syntmp-x-1000)) (if (annotation? syntmp-e-1003) (annotation-expression syntmp-e-1003) syntmp-e-1003)) (syntmp-wrap-marks-107 syntmp-w-1001))))) (syntmp-id?-104 (lambda (syntmp-x-1004) (cond ((symbol? syntmp-x-1004) #t) ((syntmp-syntax-object?-88 syntmp-x-1004) (symbol? (let ((syntmp-e-1005 (syntmp-syntax-object-expression-89 syntmp-x-1004))) (if (annotation? syntmp-e-1005) (annotation-expression syntmp-e-1005) syntmp-e-1005)))) ((annotation? syntmp-x-1004) (symbol? (annotation-expression syntmp-x-1004))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-1006) (and (syntmp-syntax-object?-88 syntmp-x-1006) (symbol? (let ((syntmp-e-1007 (syntmp-syntax-object-expression-89 syntmp-x-1006))) (if (annotation? syntmp-e-1007) (annotation-expression syntmp-e-1007) syntmp-e-1007)))))) (syntmp-global-extend-102 (lambda (syntmp-type-1008 syntmp-sym-1009 syntmp-val-1010) (syntmp-put-global-definition-hook-79 syntmp-sym-1009 (cons syntmp-type-1008 syntmp-val-1010) (module-name (current-module))))) (syntmp-lookup-101 (lambda (syntmp-x-1011 syntmp-r-1012 syntmp-mod-1013) (cond ((assq syntmp-x-1011 syntmp-r-1012) => cdr) ((symbol? syntmp-x-1011) (or (syntmp-get-global-definition-hook-80 syntmp-x-1011 syntmp-mod-1013) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-1014) (if (null? syntmp-r-1014) (quote ()) (let ((syntmp-a-1015 (car syntmp-r-1014))) (if (eq? (cadr syntmp-a-1015) (quote macro)) (cons syntmp-a-1015 (syntmp-macros-only-env-100 (cdr syntmp-r-1014))) (syntmp-macros-only-env-100 (cdr syntmp-r-1014))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-1016 syntmp-vars-1017 syntmp-r-1018) (if (null? syntmp-labels-1016) syntmp-r-1018 (syntmp-extend-var-env-99 (cdr syntmp-labels-1016) (cdr syntmp-vars-1017) (cons (cons (car syntmp-labels-1016) (cons (quote lexical) (car syntmp-vars-1017))) syntmp-r-1018))))) (syntmp-extend-env-98 (lambda (syntmp-labels-1019 syntmp-bindings-1020 syntmp-r-1021) (if (null? syntmp-labels-1019) syntmp-r-1021 (syntmp-extend-env-98 (cdr syntmp-labels-1019) (cdr syntmp-bindings-1020) (cons (cons (car syntmp-labels-1019) (car syntmp-bindings-1020)) syntmp-r-1021))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-1022) (cond ((annotation? syntmp-x-1022) (annotation-source syntmp-x-1022)) ((syntmp-syntax-object?-88 syntmp-x-1022) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-1022))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-1023 syntmp-update-1024) (vector-set! syntmp-x-1023 3 syntmp-update-1024))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-1025 syntmp-update-1026) (vector-set! syntmp-x-1025 2 syntmp-update-1026))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-1027 syntmp-update-1028) (vector-set! syntmp-x-1027 1 syntmp-update-1028))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-1029) (vector-ref syntmp-x-1029 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-1030) (vector-ref syntmp-x-1030 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-1031) (vector-ref syntmp-x-1031 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1032) (and (vector? syntmp-x-1032) (= (vector-length syntmp-x-1032) 4) (eq? (vector-ref syntmp-x-1032 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035) (vector (quote syntax-object) syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035))) (syntmp-build-letrec-86 (lambda (syntmp-src-1036 syntmp-vars-1037 syntmp-val-exps-1038 syntmp-body-exp-1039) (if (null? syntmp-vars-1037) (syntmp-build-annotated-81 syntmp-src-1036 syntmp-body-exp-1039) (syntmp-build-annotated-81 syntmp-src-1036 (list (quote letrec) (map list syntmp-vars-1037 syntmp-val-exps-1038) syntmp-body-exp-1039))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1040 syntmp-vars-1041 syntmp-val-exps-1042 syntmp-body-exp-1043) (if (null? syntmp-vars-1041) (syntmp-build-annotated-81 syntmp-src-1040 syntmp-body-exp-1043) (syntmp-build-annotated-81 syntmp-src-1040 (list (quote let) (car syntmp-vars-1041) (map list (cdr syntmp-vars-1041) syntmp-val-exps-1042) syntmp-body-exp-1043))))) (syntmp-build-let-84 (lambda (syntmp-src-1044 syntmp-vars-1045 syntmp-val-exps-1046 syntmp-body-exp-1047) (if (null? syntmp-vars-1045) (syntmp-build-annotated-81 syntmp-src-1044 syntmp-body-exp-1047) (syntmp-build-annotated-81 syntmp-src-1044 (list (quote let) (map list syntmp-vars-1045 syntmp-val-exps-1046) syntmp-body-exp-1047))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1048 syntmp-exps-1049) (if (null? (cdr syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (car syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (cons (quote begin) syntmp-exps-1049))))) (syntmp-build-data-82 (lambda (syntmp-src-1050 syntmp-exp-1051) (if (and (self-evaluating? syntmp-exp-1051) (not (vector? syntmp-exp-1051))) (syntmp-build-annotated-81 syntmp-src-1050 syntmp-exp-1051) (syntmp-build-annotated-81 syntmp-src-1050 (list (quote quote) syntmp-exp-1051))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1052 syntmp-exp-1053) (if (and syntmp-src-1052 (not (annotation? syntmp-exp-1053))) (make-annotation syntmp-exp-1053 syntmp-src-1052 #t) syntmp-exp-1053))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1054 syntmp-module-1055) (let ((syntmp-module-1056 (if syntmp-module-1055 (resolve-module syntmp-module-1055) (warn "wha" syntmp-symbol-1054 (current-module))))) (let ((syntmp-v-1057 (module-variable syntmp-module-1056 syntmp-symbol-1054))) (and syntmp-v-1057 (or (object-property syntmp-v-1057 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1057) (macro? (variable-ref syntmp-v-1057)) (macro-transformer (variable-ref syntmp-v-1057)) guile-macro))))))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1058 syntmp-binding-1059 syntmp-module-1060) (let ((syntmp-module-1061 (if syntmp-module-1060 (resolve-module syntmp-module-1060) (warn "wha" syntmp-symbol-1058 (current-module))))) (let ((syntmp-v-1062 (or (module-variable syntmp-module-1061 syntmp-symbol-1058) (let ((syntmp-v-1063 (make-variable sc-macro))) (begin (module-add! syntmp-module-1061 syntmp-symbol-1058 syntmp-v-1063) syntmp-v-1063))))) (begin (if (not (and (symbol-property syntmp-symbol-1058 (quote primitive-syntax)) (eq? syntmp-module-1061 the-syncase-module))) (variable-set! syntmp-v-1062 sc-macro)) (set-object-property! syntmp-v-1062 (quote *sc-expander*) syntmp-binding-1059)))))) (syntmp-error-hook-78 (lambda (syntmp-who-1064 syntmp-why-1065 syntmp-what-1066) (error syntmp-who-1064 "~a ~s" syntmp-why-1065 syntmp-what-1066))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1067 syntmp-mod-1068) (eval (list syntmp-noexpand-71 syntmp-x-1067) (if syntmp-mod-1068 (resolve-module syntmp-mod-1068) (interaction-environment))))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1069 syntmp-mod-1070) (eval (list syntmp-noexpand-71 syntmp-x-1069) (if syntmp-mod-1070 (resolve-module syntmp-mod-1070) (interaction-environment))))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1071 syntmp-r-1072 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) ((lambda (syntmp-tmp-1076) ((lambda (syntmp-tmp-1077) (if (if syntmp-tmp-1077 (apply (lambda (syntmp-_-1078 syntmp-var-1079 syntmp-val-1080 syntmp-e1-1081 syntmp-e2-1082) (syntmp-valid-bound-ids?-129 syntmp-var-1079)) syntmp-tmp-1077) #f) (apply (lambda (syntmp-_-1084 syntmp-var-1085 syntmp-val-1086 syntmp-e1-1087 syntmp-e2-1088) (let ((syntmp-names-1089 (map (lambda (syntmp-x-1090) (syntmp-id-var-name-126 syntmp-x-1090 syntmp-w-1073)) syntmp-var-1085))) (begin (for-each (lambda (syntmp-id-1092 syntmp-n-1093) (let ((syntmp-t-1094 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1093 syntmp-r-1072 syntmp-mod-1075)))) (if (memv syntmp-t-1094 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1092 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) "identifier out of context")))) syntmp-var-1085 syntmp-names-1089) (syntmp-chi-body-144 (cons syntmp-e1-1087 syntmp-e2-1088) (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) (syntmp-extend-env-98 syntmp-names-1089 (let ((syntmp-trans-r-1097 (syntmp-macros-only-env-100 syntmp-r-1072))) (map (lambda (syntmp-x-1098) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1098 syntmp-trans-r-1097 syntmp-w-1073 syntmp-mod-1075) syntmp-mod-1075))) syntmp-val-1086)) syntmp-r-1072) syntmp-w-1073 syntmp-mod-1075)))) syntmp-tmp-1077) ((lambda (syntmp-_-1100) (syntax-error (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075))) syntmp-tmp-1076))) (syntax-dispatch syntmp-tmp-1076 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1071))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1101 syntmp-r-1102 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105) ((lambda (syntmp-tmp-1106) ((lambda (syntmp-tmp-1107) (if syntmp-tmp-1107 (apply (lambda (syntmp-_-1108 syntmp-e-1109) (syntmp-build-data-82 syntmp-s-1104 (syntmp-strip-151 syntmp-e-1109 syntmp-w-1103))) syntmp-tmp-1107) ((lambda (syntmp-_-1110) (syntax-error (syntmp-source-wrap-133 syntmp-e-1101 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105))) syntmp-tmp-1106))) (syntax-dispatch syntmp-tmp-1106 (quote (any any))))) syntmp-e-1101))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1118 (lambda (syntmp-x-1119) (let ((syntmp-t-1120 (car syntmp-x-1119))) (if (memv syntmp-t-1120 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1119) (syntmp-regen-1118 (caddr syntmp-x-1119)))) (if (memv syntmp-t-1120 (quote (map))) (let ((syntmp-ls-1121 (map syntmp-regen-1118 (cdr syntmp-x-1119)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1121) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1121))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1119)) (map syntmp-regen-1118 (cdr syntmp-x-1119)))))))))))) (syntmp-gen-vector-1117 (lambda (syntmp-x-1122) (cond ((eq? (car syntmp-x-1122) (quote list)) (cons (quote vector) (cdr syntmp-x-1122))) ((eq? (car syntmp-x-1122) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1122)))) (else (list (quote list->vector) syntmp-x-1122))))) (syntmp-gen-append-1116 (lambda (syntmp-x-1123 syntmp-y-1124) (if (equal? syntmp-y-1124 (quote (quote ()))) syntmp-x-1123 (list (quote append) syntmp-x-1123 syntmp-y-1124)))) (syntmp-gen-cons-1115 (lambda (syntmp-x-1125 syntmp-y-1126) (let ((syntmp-t-1127 (car syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (quote))) (if (eq? (car syntmp-x-1125) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1125) (cadr syntmp-y-1126))) (if (eq? (cadr syntmp-y-1126) (quote ())) (list (quote list) syntmp-x-1125) (list (quote cons) syntmp-x-1125 syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (list))) (cons (quote list) (cons syntmp-x-1125 (cdr syntmp-y-1126))) (list (quote cons) syntmp-x-1125 syntmp-y-1126)))))) (syntmp-gen-map-1114 (lambda (syntmp-e-1128 syntmp-map-env-1129) (let ((syntmp-formals-1130 (map cdr syntmp-map-env-1129)) (syntmp-actuals-1131 (map (lambda (syntmp-x-1132) (list (quote ref) (car syntmp-x-1132))) syntmp-map-env-1129))) (cond ((eq? (car syntmp-e-1128) (quote ref)) (car syntmp-actuals-1131)) ((andmap (lambda (syntmp-x-1133) (and (eq? (car syntmp-x-1133) (quote ref)) (memq (cadr syntmp-x-1133) syntmp-formals-1130))) (cdr syntmp-e-1128)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1128)) (map (let ((syntmp-r-1134 (map cons syntmp-formals-1130 syntmp-actuals-1131))) (lambda (syntmp-x-1135) (cdr (assq (cadr syntmp-x-1135) syntmp-r-1134)))) (cdr syntmp-e-1128))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1130 syntmp-e-1128) syntmp-actuals-1131))))))) (syntmp-gen-mappend-1113 (lambda (syntmp-e-1136 syntmp-map-env-1137) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1114 syntmp-e-1136 syntmp-map-env-1137)))) (syntmp-gen-ref-1112 (lambda (syntmp-src-1138 syntmp-var-1139 syntmp-level-1140 syntmp-maps-1141) (if (syntmp-fx=-74 syntmp-level-1140 0) (values syntmp-var-1139 syntmp-maps-1141) (if (null? syntmp-maps-1141) (syntax-error syntmp-src-1138 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1112 syntmp-src-1138 syntmp-var-1139 (syntmp-fx--73 syntmp-level-1140 1) (cdr syntmp-maps-1141))) (lambda (syntmp-outer-var-1142 syntmp-outer-maps-1143) (let ((syntmp-b-1144 (assq syntmp-outer-var-1142 (car syntmp-maps-1141)))) (if syntmp-b-1144 (values (cdr syntmp-b-1144) syntmp-maps-1141) (let ((syntmp-inner-var-1145 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1145 (cons (cons (cons syntmp-outer-var-1142 syntmp-inner-var-1145) (car syntmp-maps-1141)) syntmp-outer-maps-1143))))))))))) (syntmp-gen-syntax-1111 (lambda (syntmp-src-1146 syntmp-e-1147 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151) (if (syntmp-id?-104 syntmp-e-1147) (let ((syntmp-label-1152 (syntmp-id-var-name-126 syntmp-e-1147 (quote (()))))) (let ((syntmp-b-1153 (syntmp-lookup-101 syntmp-label-1152 syntmp-r-1148 syntmp-mod-1151))) (if (eq? (syntmp-binding-type-96 syntmp-b-1153) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1154 (syntmp-binding-value-97 syntmp-b-1153))) (syntmp-gen-ref-1112 syntmp-src-1146 (car syntmp-var.lev-1154) (cdr syntmp-var.lev-1154) syntmp-maps-1149))) (lambda (syntmp-var-1155 syntmp-maps-1156) (values (list (quote ref) syntmp-var-1155) syntmp-maps-1156))) (if (syntmp-ellipsis?-1150 syntmp-e-1147) (syntax-error syntmp-src-1146 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149))))) ((lambda (syntmp-tmp-1157) ((lambda (syntmp-tmp-1158) (if (if syntmp-tmp-1158 (apply (lambda (syntmp-dots-1159 syntmp-e-1160) (syntmp-ellipsis?-1150 syntmp-dots-1159)) syntmp-tmp-1158) #f) (apply (lambda (syntmp-dots-1161 syntmp-e-1162) (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-e-1162 syntmp-r-1148 syntmp-maps-1149 (lambda (syntmp-x-1163) #f) syntmp-mod-1151)) syntmp-tmp-1158) ((lambda (syntmp-tmp-1164) (if (if syntmp-tmp-1164 (apply (lambda (syntmp-x-1165 syntmp-dots-1166 syntmp-y-1167) (syntmp-ellipsis?-1150 syntmp-dots-1166)) syntmp-tmp-1164) #f) (apply (lambda (syntmp-x-1168 syntmp-dots-1169 syntmp-y-1170) (let syntmp-f-1171 ((syntmp-y-1172 syntmp-y-1170) (syntmp-k-1173 (lambda (syntmp-maps-1174) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1168 syntmp-r-1148 (cons (quote ()) syntmp-maps-1174) syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1175 syntmp-maps-1176) (if (null? (car syntmp-maps-1176)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-map-1114 syntmp-x-1175 (car syntmp-maps-1176)) (cdr syntmp-maps-1176)))))))) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if (if syntmp-tmp-1178 (apply (lambda (syntmp-dots-1179 syntmp-y-1180) (syntmp-ellipsis?-1150 syntmp-dots-1179)) syntmp-tmp-1178) #f) (apply (lambda (syntmp-dots-1181 syntmp-y-1182) (syntmp-f-1171 syntmp-y-1182 (lambda (syntmp-maps-1183) (call-with-values (lambda () (syntmp-k-1173 (cons (quote ()) syntmp-maps-1183))) (lambda (syntmp-x-1184 syntmp-maps-1185) (if (null? (car syntmp-maps-1185)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1113 syntmp-x-1184 (car syntmp-maps-1185)) (cdr syntmp-maps-1185)))))))) syntmp-tmp-1178) ((lambda (syntmp-_-1186) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1172 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1187 syntmp-maps-1188) (call-with-values (lambda () (syntmp-k-1173 syntmp-maps-1188)) (lambda (syntmp-x-1189 syntmp-maps-1190) (values (syntmp-gen-append-1116 syntmp-x-1189 syntmp-y-1187) syntmp-maps-1190)))))) syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-y-1172))) syntmp-tmp-1164) ((lambda (syntmp-tmp-1191) (if syntmp-tmp-1191 (apply (lambda (syntmp-x-1192 syntmp-y-1193) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1192 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1194 syntmp-maps-1195) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1193 syntmp-r-1148 syntmp-maps-1195 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1196 syntmp-maps-1197) (values (syntmp-gen-cons-1115 syntmp-x-1194 syntmp-y-1196) syntmp-maps-1197)))))) syntmp-tmp-1191) ((lambda (syntmp-tmp-1198) (if syntmp-tmp-1198 (apply (lambda (syntmp-e1-1199 syntmp-e2-1200) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 (cons syntmp-e1-1199 syntmp-e2-1200) syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-e-1202 syntmp-maps-1203) (values (syntmp-gen-vector-1117 syntmp-e-1202) syntmp-maps-1203)))) syntmp-tmp-1198) ((lambda (syntmp-_-1204) (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149)) syntmp-tmp-1157))) (syntax-dispatch syntmp-tmp-1157 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1157 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any))))) syntmp-e-1147))))) (lambda (syntmp-e-1205 syntmp-r-1206 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209) (let ((syntmp-e-1210 (syntmp-source-wrap-133 syntmp-e-1205 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209))) ((lambda (syntmp-tmp-1211) ((lambda (syntmp-tmp-1212) (if syntmp-tmp-1212 (apply (lambda (syntmp-_-1213 syntmp-x-1214) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-e-1210 syntmp-x-1214 syntmp-r-1206 (quote ()) syntmp-ellipsis?-149 syntmp-mod-1209)) (lambda (syntmp-e-1215 syntmp-maps-1216) (syntmp-regen-1118 syntmp-e-1215)))) syntmp-tmp-1212) ((lambda (syntmp-_-1217) (syntax-error syntmp-e-1210)) syntmp-tmp-1211))) (syntax-dispatch syntmp-tmp-1211 (quote (any any))))) syntmp-e-1210))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1218 syntmp-r-1219 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) ((lambda (syntmp-tmp-1223) ((lambda (syntmp-tmp-1224) (if syntmp-tmp-1224 (apply (lambda (syntmp-_-1225 syntmp-c-1226) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1218 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) syntmp-c-1226 syntmp-r-1219 syntmp-w-1220 syntmp-mod-1222 (lambda (syntmp-vars-1227 syntmp-body-1228) (syntmp-build-annotated-81 syntmp-s-1221 (list (quote lambda) syntmp-vars-1227 syntmp-body-1228))))) syntmp-tmp-1224) (syntax-error syntmp-tmp-1223))) (syntax-dispatch syntmp-tmp-1223 (quote (any . any))))) syntmp-e-1218))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1229 (lambda (syntmp-e-1230 syntmp-r-1231 syntmp-w-1232 syntmp-s-1233 syntmp-mod-1234 syntmp-constructor-1235 syntmp-ids-1236 syntmp-vals-1237 syntmp-exps-1238) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1236)) (syntax-error syntmp-e-1230 "duplicate bound variable in") (let ((syntmp-labels-1239 (syntmp-gen-labels-110 syntmp-ids-1236)) (syntmp-new-vars-1240 (map syntmp-gen-var-152 syntmp-ids-1236))) (let ((syntmp-nw-1241 (syntmp-make-binding-wrap-121 syntmp-ids-1236 syntmp-labels-1239 syntmp-w-1232)) (syntmp-nr-1242 (syntmp-extend-var-env-99 syntmp-labels-1239 syntmp-new-vars-1240 syntmp-r-1231))) (syntmp-constructor-1235 syntmp-s-1233 syntmp-new-vars-1240 (map (lambda (syntmp-x-1243) (syntmp-chi-140 syntmp-x-1243 syntmp-r-1231 syntmp-w-1232 syntmp-mod-1234)) syntmp-vals-1237) (syntmp-chi-body-144 syntmp-exps-1238 (syntmp-source-wrap-133 syntmp-e-1230 syntmp-nw-1241 syntmp-s-1233 syntmp-mod-1234) syntmp-nr-1242 syntmp-nw-1241 syntmp-mod-1234)))))))) (lambda (syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248) ((lambda (syntmp-tmp-1249) ((lambda (syntmp-tmp-1250) (if syntmp-tmp-1250 (apply (lambda (syntmp-_-1251 syntmp-id-1252 syntmp-val-1253 syntmp-e1-1254 syntmp-e2-1255) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-let-84 syntmp-id-1252 syntmp-val-1253 (cons syntmp-e1-1254 syntmp-e2-1255))) syntmp-tmp-1250) ((lambda (syntmp-tmp-1259) (if (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-f-1261 syntmp-id-1262 syntmp-val-1263 syntmp-e1-1264 syntmp-e2-1265) (syntmp-id?-104 syntmp-f-1261)) syntmp-tmp-1259) #f) (apply (lambda (syntmp-_-1266 syntmp-f-1267 syntmp-id-1268 syntmp-val-1269 syntmp-e1-1270 syntmp-e2-1271) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-named-let-85 (cons syntmp-f-1267 syntmp-id-1268) syntmp-val-1269 (cons syntmp-e1-1270 syntmp-e2-1271))) syntmp-tmp-1259) ((lambda (syntmp-_-1275) (syntax-error (syntmp-source-wrap-133 syntmp-e-1244 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248))) syntmp-tmp-1249))) (syntax-dispatch syntmp-tmp-1249 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1249 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1244)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1276 syntmp-r-1277 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-_-1283 syntmp-id-1284 syntmp-val-1285 syntmp-e1-1286 syntmp-e2-1287) (let ((syntmp-ids-1288 syntmp-id-1284)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1288)) (syntax-error syntmp-e-1276 "duplicate bound variable in") (let ((syntmp-labels-1290 (syntmp-gen-labels-110 syntmp-ids-1288)) (syntmp-new-vars-1291 (map syntmp-gen-var-152 syntmp-ids-1288))) (let ((syntmp-w-1292 (syntmp-make-binding-wrap-121 syntmp-ids-1288 syntmp-labels-1290 syntmp-w-1278)) (syntmp-r-1293 (syntmp-extend-var-env-99 syntmp-labels-1290 syntmp-new-vars-1291 syntmp-r-1277))) (syntmp-build-letrec-86 syntmp-s-1279 syntmp-new-vars-1291 (map (lambda (syntmp-x-1294) (syntmp-chi-140 syntmp-x-1294 syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280)) syntmp-val-1285) (syntmp-chi-body-144 (cons syntmp-e1-1286 syntmp-e2-1287) (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1292 syntmp-s-1279 syntmp-mod-1280) syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280))))))) syntmp-tmp-1282) ((lambda (syntmp-_-1297) (syntax-error (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280))) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1276))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1298 syntmp-r-1299 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302) ((lambda (syntmp-tmp-1303) ((lambda (syntmp-tmp-1304) (if (if syntmp-tmp-1304 (apply (lambda (syntmp-_-1305 syntmp-id-1306 syntmp-val-1307) (syntmp-id?-104 syntmp-id-1306)) syntmp-tmp-1304) #f) (apply (lambda (syntmp-_-1308 syntmp-id-1309 syntmp-val-1310) (let ((syntmp-val-1311 (syntmp-chi-140 syntmp-val-1310 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (syntmp-n-1312 (syntmp-id-var-name-126 syntmp-id-1309 syntmp-w-1300))) (let ((syntmp-b-1313 (syntmp-lookup-101 syntmp-n-1312 syntmp-r-1299 syntmp-mod-1302))) (let ((syntmp-t-1314 (syntmp-binding-type-96 syntmp-b-1313))) (if (memv syntmp-t-1314 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1313) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1302 syntmp-n-1312 #f) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1309 syntmp-w-1300 syntmp-mod-1302) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))))))))) syntmp-tmp-1304) ((lambda (syntmp-tmp-1315) (if syntmp-tmp-1315 (apply (lambda (syntmp-_-1316 syntmp-head-1317 syntmp-tail-1318 syntmp-val-1319) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-head-1317 syntmp-r-1299 (quote (())) #f #f syntmp-mod-1302)) (lambda (syntmp-type-1320 syntmp-value-1321 syntmp-ee-1322 syntmp-ww-1323 syntmp-ss-1324 syntmp-modmod-1325) (let ((syntmp-t-1326 syntmp-type-1320)) (if (memv syntmp-t-1326 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1321 (cons syntmp-head-1317 syntmp-tail-1318))) (lambda (syntmp-id-1328 syntmp-mod-1329) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1329 syntmp-id-1328 #f) syntmp-val-1319)))) (syntmp-build-annotated-81 syntmp-s-1301 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1317) syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302) (map (lambda (syntmp-e-1330) (syntmp-chi-140 syntmp-e-1330 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (append syntmp-tail-1318 (list syntmp-val-1319)))))))))) syntmp-tmp-1315) ((lambda (syntmp-_-1332) (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))) syntmp-tmp-1303))) (syntax-dispatch syntmp-tmp-1303 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1303 (quote (any any any))))) syntmp-e-1298))) (syntmp-global-extend-102 (quote module-ref) (quote @) (lambda (syntmp-e-1333) ((lambda (syntmp-tmp-1334) ((lambda (syntmp-tmp-1335) (if (if syntmp-tmp-1335 (apply (lambda (syntmp-_-1336 syntmp-mod-1337 syntmp-id-1338) (and (andmap syntmp-id?-104 syntmp-mod-1337) (syntmp-id?-104 syntmp-id-1338))) syntmp-tmp-1335) #f) (apply (lambda (syntmp-_-1340 syntmp-mod-1341 syntmp-id-1342) (values (syntax-object->datum syntmp-id-1342) (syntax-object->datum (append syntmp-mod-1341 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1335) (syntax-error syntmp-tmp-1334))) (syntax-dispatch syntmp-tmp-1334 (quote (any each-any any))))) syntmp-e-1333))) (syntmp-global-extend-102 (quote module-ref) (quote @@) (lambda (syntmp-e-1344) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-mod-1348 syntmp-id-1349) (and (andmap syntmp-id?-104 syntmp-mod-1348) (syntmp-id?-104 syntmp-id-1349))) syntmp-tmp-1346) #f) (apply (lambda (syntmp-_-1351 syntmp-mod-1352 syntmp-id-1353) (values (syntax-object->datum syntmp-id-1353) (syntax-object->datum syntmp-mod-1352))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any each-any any))))) syntmp-e-1344))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1358 (lambda (syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1363) (if (null? syntmp-clauses-1361) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1359)) ((lambda (syntmp-tmp-1364) ((lambda (syntmp-tmp-1365) (if syntmp-tmp-1365 (apply (lambda (syntmp-pat-1366 syntmp-exp-1367) (if (and (syntmp-id?-104 syntmp-pat-1366) (andmap (lambda (syntmp-x-1368) (not (syntmp-free-id=?-127 syntmp-pat-1366 syntmp-x-1368))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1360))) (let ((syntmp-labels-1369 (list (syntmp-gen-label-109))) (syntmp-var-1370 (syntmp-gen-var-152 syntmp-pat-1366))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1370) (syntmp-chi-140 syntmp-exp-1367 (syntmp-extend-env-98 syntmp-labels-1369 (list (cons (quote syntax) (cons syntmp-var-1370 0))) syntmp-r-1362) (syntmp-make-binding-wrap-121 (list syntmp-pat-1366) syntmp-labels-1369 (quote (()))) syntmp-mod-1363))) syntmp-x-1359))) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1366 #t syntmp-exp-1367 syntmp-mod-1363))) syntmp-tmp-1365) ((lambda (syntmp-tmp-1371) (if syntmp-tmp-1371 (apply (lambda (syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374 syntmp-mod-1363)) syntmp-tmp-1371) ((lambda (syntmp-_-1375) (syntax-error (car syntmp-clauses-1361) "invalid syntax-case clause")) syntmp-tmp-1364))) (syntax-dispatch syntmp-tmp-1364 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1364 (quote (any any))))) (car syntmp-clauses-1361))))) (syntmp-gen-clause-1357 (lambda (syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-pat-1380 syntmp-fender-1381 syntmp-exp-1382 syntmp-mod-1383) (call-with-values (lambda () (syntmp-convert-pattern-1355 syntmp-pat-1380 syntmp-keys-1377)) (lambda (syntmp-p-1384 syntmp-pvars-1385) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1385))) (syntax-error syntmp-pat-1380 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1386) (not (syntmp-ellipsis?-149 (car syntmp-x-1386)))) syntmp-pvars-1385)) (syntax-error syntmp-pat-1380 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1387 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1387) (let ((syntmp-y-1388 (syntmp-build-annotated-81 #f syntmp-y-1387))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1389) ((lambda (syntmp-tmp-1390) (if syntmp-tmp-1390 (apply (lambda () syntmp-y-1388) syntmp-tmp-1390) ((lambda (syntmp-_-1391) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1388 (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-fender-1381 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1389))) (syntax-dispatch syntmp-tmp-1389 (quote #(atom #t))))) syntmp-fender-1381) (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-exp-1382 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-gen-syntax-case-1358 syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-mod-1383)))))) (if (eq? syntmp-p-1384 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1376)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1376 (syntmp-build-data-82 #f syntmp-p-1384))))))))))))) (syntmp-build-dispatch-call-1356 (lambda (syntmp-pvars-1392 syntmp-exp-1393 syntmp-y-1394 syntmp-r-1395 syntmp-mod-1396) (let ((syntmp-ids-1397 (map car syntmp-pvars-1392)) (syntmp-levels-1398 (map cdr syntmp-pvars-1392))) (let ((syntmp-labels-1399 (syntmp-gen-labels-110 syntmp-ids-1397)) (syntmp-new-vars-1400 (map syntmp-gen-var-152 syntmp-ids-1397))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1400 (syntmp-chi-140 syntmp-exp-1393 (syntmp-extend-env-98 syntmp-labels-1399 (map (lambda (syntmp-var-1401 syntmp-level-1402) (cons (quote syntax) (cons syntmp-var-1401 syntmp-level-1402))) syntmp-new-vars-1400 (map cdr syntmp-pvars-1392)) syntmp-r-1395) (syntmp-make-binding-wrap-121 syntmp-ids-1397 syntmp-labels-1399 (quote (()))) syntmp-mod-1396))) syntmp-y-1394)))))) (syntmp-convert-pattern-1355 (lambda (syntmp-pattern-1403 syntmp-keys-1404) (let syntmp-cvt-1405 ((syntmp-p-1406 syntmp-pattern-1403) (syntmp-n-1407 0) (syntmp-ids-1408 (quote ()))) (if (syntmp-id?-104 syntmp-p-1406) (if (syntmp-bound-id-member?-131 syntmp-p-1406 syntmp-keys-1404) (values (vector (quote free-id) syntmp-p-1406) syntmp-ids-1408) (values (quote any) (cons (cons syntmp-p-1406 syntmp-n-1407) syntmp-ids-1408))) ((lambda (syntmp-tmp-1409) ((lambda (syntmp-tmp-1410) (if (if syntmp-tmp-1410 (apply (lambda (syntmp-x-1411 syntmp-dots-1412) (syntmp-ellipsis?-149 syntmp-dots-1412)) syntmp-tmp-1410) #f) (apply (lambda (syntmp-x-1413 syntmp-dots-1414) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1413 (syntmp-fx+-72 syntmp-n-1407 1) syntmp-ids-1408)) (lambda (syntmp-p-1415 syntmp-ids-1416) (values (if (eq? syntmp-p-1415 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1415)) syntmp-ids-1416)))) syntmp-tmp-1410) ((lambda (syntmp-tmp-1417) (if syntmp-tmp-1417 (apply (lambda (syntmp-x-1418 syntmp-y-1419) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-y-1419 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-y-1420 syntmp-ids-1421) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1418 syntmp-n-1407 syntmp-ids-1421)) (lambda (syntmp-x-1422 syntmp-ids-1423) (values (cons syntmp-x-1422 syntmp-y-1420) syntmp-ids-1423)))))) syntmp-tmp-1417) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda () (values (quote ()) syntmp-ids-1408)) syntmp-tmp-1424) ((lambda (syntmp-tmp-1425) (if syntmp-tmp-1425 (apply (lambda (syntmp-x-1426) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1426 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-p-1428 syntmp-ids-1429) (values (vector (quote vector) syntmp-p-1428) syntmp-ids-1429)))) syntmp-tmp-1425) ((lambda (syntmp-x-1430) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1406 (quote (())))) syntmp-ids-1408)) syntmp-tmp-1409))) (syntax-dispatch syntmp-tmp-1409 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1409 (quote ()))))) (syntax-dispatch syntmp-tmp-1409 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1409 (quote (any any))))) syntmp-p-1406)))))) (lambda (syntmp-e-1431 syntmp-r-1432 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435) (let ((syntmp-e-1436 (syntmp-source-wrap-133 syntmp-e-1431 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435))) ((lambda (syntmp-tmp-1437) ((lambda (syntmp-tmp-1438) (if syntmp-tmp-1438 (apply (lambda (syntmp-_-1439 syntmp-val-1440 syntmp-key-1441 syntmp-m-1442) (if (andmap (lambda (syntmp-x-1443) (and (syntmp-id?-104 syntmp-x-1443) (not (syntmp-ellipsis?-149 syntmp-x-1443)))) syntmp-key-1441) (let ((syntmp-x-1445 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1434 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1445) (syntmp-gen-syntax-case-1358 (syntmp-build-annotated-81 #f syntmp-x-1445) syntmp-key-1441 syntmp-m-1442 syntmp-r-1432 syntmp-mod-1435))) (syntmp-chi-140 syntmp-val-1440 syntmp-r-1432 (quote (())) syntmp-mod-1435)))) (syntax-error syntmp-e-1436 "invalid literals list in"))) syntmp-tmp-1438) (syntax-error syntmp-tmp-1437))) (syntax-dispatch syntmp-tmp-1437 (quote (any any each-any . each-any))))) syntmp-e-1436))))) (set! sc-expand (let ((syntmp-m-1448 (quote e)) (syntmp-esew-1449 (quote (eval)))) (lambda (syntmp-x-1450) (if (and (pair? syntmp-x-1450) (equal? (car syntmp-x-1450) syntmp-noexpand-71)) (cadr syntmp-x-1450) (syntmp-chi-top-139 syntmp-x-1450 (quote ()) (quote ((top))) syntmp-m-1448 syntmp-esew-1449 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1451 (quote e)) (syntmp-esew-1452 (quote (eval)))) (lambda (syntmp-x-1454 . syntmp-rest-1453) (if (and (pair? syntmp-x-1454) (equal? (car syntmp-x-1454) syntmp-noexpand-71)) (cadr syntmp-x-1454) (syntmp-chi-top-139 syntmp-x-1454 (quote ()) (quote ((top))) (if (null? syntmp-rest-1453) syntmp-m-1451 (car syntmp-rest-1453)) (if (or (null? syntmp-rest-1453) (null? (cdr syntmp-rest-1453))) syntmp-esew-1452 (cadr syntmp-rest-1453)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1455) (syntmp-nonsymbol-id?-103 syntmp-x-1455))) (set! datum->syntax-object (lambda (syntmp-id-1456 syntmp-datum-1457) (syntmp-make-syntax-object-87 syntmp-datum-1457 (syntmp-syntax-object-wrap-90 syntmp-id-1456) #f))) (set! syntax-object->datum (lambda (syntmp-x-1458) (syntmp-strip-151 syntmp-x-1458 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1459) (begin (let ((syntmp-x-1460 syntmp-ls-1459)) (if (not (list? syntmp-x-1460)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1460))) (map (lambda (syntmp-x-1461) (syntmp-wrap-132 (gensym) (quote ((top))) #f)) syntmp-ls-1459)))) (set! free-identifier=? (lambda (syntmp-x-1462 syntmp-y-1463) (begin (let ((syntmp-x-1464 syntmp-x-1462)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1464)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1464))) (let ((syntmp-x-1465 syntmp-y-1463)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1465)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1465))) (syntmp-free-id=?-127 syntmp-x-1462 syntmp-y-1463)))) (set! bound-identifier=? (lambda (syntmp-x-1466 syntmp-y-1467) (begin (let ((syntmp-x-1468 syntmp-x-1466)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1468)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1468))) (let ((syntmp-x-1469 syntmp-y-1467)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1469)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1469))) (syntmp-bound-id=?-128 syntmp-x-1466 syntmp-y-1467)))) (set! syntax-error (lambda (syntmp-object-1471 . syntmp-messages-1470) (begin (for-each (lambda (syntmp-x-1472) (let ((syntmp-x-1473 syntmp-x-1472)) (if (not (string? syntmp-x-1473)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1473)))) syntmp-messages-1470) (let ((syntmp-message-1474 (if (null? syntmp-messages-1470) "invalid syntax" (apply string-append syntmp-messages-1470)))) (syntmp-error-hook-78 #f syntmp-message-1474 (syntmp-strip-151 syntmp-object-1471 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1475 syntmp-v-1476) (begin (let ((syntmp-x-1477 syntmp-sym-1475)) (if (not (symbol? syntmp-x-1477)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1477))) (let ((syntmp-x-1478 syntmp-v-1476)) (if (not (procedure? syntmp-x-1478)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1478))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1475 syntmp-v-1476)))) (letrec ((syntmp-match-1483 (lambda (syntmp-e-1484 syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488) (cond ((not syntmp-r-1487) #f) ((eq? syntmp-p-1485 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1484 syntmp-w-1486 syntmp-mod-1488) syntmp-r-1487)) ((syntmp-syntax-object?-88 syntmp-e-1484) (syntmp-match*-1482 (let ((syntmp-e-1489 (syntmp-syntax-object-expression-89 syntmp-e-1484))) (if (annotation? syntmp-e-1489) (annotation-expression syntmp-e-1489) syntmp-e-1489)) syntmp-p-1485 (syntmp-join-wraps-123 syntmp-w-1486 (syntmp-syntax-object-wrap-90 syntmp-e-1484)) syntmp-r-1487 (syntmp-syntax-object-module-91 syntmp-e-1484))) (else (syntmp-match*-1482 (let ((syntmp-e-1490 syntmp-e-1484)) (if (annotation? syntmp-e-1490) (annotation-expression syntmp-e-1490) syntmp-e-1490)) syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488))))) (syntmp-match*-1482 (lambda (syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) (cond ((null? syntmp-p-1492) (and (null? syntmp-e-1491) syntmp-r-1494)) ((pair? syntmp-p-1492) (and (pair? syntmp-e-1491) (syntmp-match-1483 (car syntmp-e-1491) (car syntmp-p-1492) syntmp-w-1493 (syntmp-match-1483 (cdr syntmp-e-1491) (cdr syntmp-p-1492) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) syntmp-mod-1495))) ((eq? syntmp-p-1492 (quote each-any)) (let ((syntmp-l-1496 (syntmp-match-each-any-1480 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1496 (cons syntmp-l-1496 syntmp-r-1494)))) (else (let ((syntmp-t-1497 (vector-ref syntmp-p-1492 0))) (if (memv syntmp-t-1497 (quote (each))) (if (null? syntmp-e-1491) (syntmp-match-empty-1481 (vector-ref syntmp-p-1492 1) syntmp-r-1494) (let ((syntmp-l-1498 (syntmp-match-each-1479 syntmp-e-1491 (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1498 (let syntmp-collect-1499 ((syntmp-l-1500 syntmp-l-1498)) (if (null? (car syntmp-l-1500)) syntmp-r-1494 (cons (map car syntmp-l-1500) (syntmp-collect-1499 (map cdr syntmp-l-1500)))))))) (if (memv syntmp-t-1497 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1491) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495) (vector-ref syntmp-p-1492 1)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (atom))) (and (equal? (vector-ref syntmp-p-1492 1) (syntmp-strip-151 syntmp-e-1491 syntmp-w-1493)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (vector))) (and (vector? syntmp-e-1491) (syntmp-match-1483 (vector->list syntmp-e-1491) (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495))))))))))) (syntmp-match-empty-1481 (lambda (syntmp-p-1501 syntmp-r-1502) (cond ((null? syntmp-p-1501) syntmp-r-1502) ((eq? syntmp-p-1501 (quote any)) (cons (quote ()) syntmp-r-1502)) ((pair? syntmp-p-1501) (syntmp-match-empty-1481 (car syntmp-p-1501) (syntmp-match-empty-1481 (cdr syntmp-p-1501) syntmp-r-1502))) ((eq? syntmp-p-1501 (quote each-any)) (cons (quote ()) syntmp-r-1502)) (else (let ((syntmp-t-1503 (vector-ref syntmp-p-1501 0))) (if (memv syntmp-t-1503 (quote (each))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502) (if (memv syntmp-t-1503 (quote (free-id atom))) syntmp-r-1502 (if (memv syntmp-t-1503 (quote (vector))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502))))))))) (syntmp-match-each-any-1480 (lambda (syntmp-e-1504 syntmp-w-1505 syntmp-mod-1506) (cond ((annotation? syntmp-e-1504) (syntmp-match-each-any-1480 (annotation-expression syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506)) ((pair? syntmp-e-1504) (let ((syntmp-l-1507 (syntmp-match-each-any-1480 (cdr syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506))) (and syntmp-l-1507 (cons (syntmp-wrap-132 (car syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506) syntmp-l-1507)))) ((null? syntmp-e-1504) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1504) (syntmp-match-each-any-1480 (syntmp-syntax-object-expression-89 syntmp-e-1504) (syntmp-join-wraps-123 syntmp-w-1505 (syntmp-syntax-object-wrap-90 syntmp-e-1504)) syntmp-mod-1506)) (else #f)))) (syntmp-match-each-1479 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511) (cond ((annotation? syntmp-e-1508) (syntmp-match-each-1479 (annotation-expression syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511)) ((pair? syntmp-e-1508) (let ((syntmp-first-1512 (syntmp-match-1483 (car syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 (quote ()) syntmp-mod-1511))) (and syntmp-first-1512 (let ((syntmp-rest-1513 (syntmp-match-each-1479 (cdr syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511))) (and syntmp-rest-1513 (cons syntmp-first-1512 syntmp-rest-1513)))))) ((null? syntmp-e-1508) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1508) (syntmp-match-each-1479 (syntmp-syntax-object-expression-89 syntmp-e-1508) syntmp-p-1509 (syntmp-join-wraps-123 syntmp-w-1510 (syntmp-syntax-object-wrap-90 syntmp-e-1508)) (syntmp-syntax-object-module-91 syntmp-e-1508))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1514 syntmp-p-1515) (cond ((eq? syntmp-p-1515 (quote any)) (list syntmp-e-1514)) ((syntmp-syntax-object?-88 syntmp-e-1514) (syntmp-match*-1482 (let ((syntmp-e-1516 (syntmp-syntax-object-expression-89 syntmp-e-1514))) (if (annotation? syntmp-e-1516) (annotation-expression syntmp-e-1516) syntmp-e-1516)) syntmp-p-1515 (syntmp-syntax-object-wrap-90 syntmp-e-1514) (quote ()) (syntmp-syntax-object-module-91 syntmp-e-1514))) (else (syntmp-match*-1482 (let ((syntmp-e-1517 syntmp-e-1514)) (if (annotation? syntmp-e-1517) (annotation-expression syntmp-e-1517) syntmp-e-1517)) syntmp-p-1515 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-140))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1518) ((lambda (syntmp-tmp-1519) ((lambda (syntmp-tmp-1520) (if syntmp-tmp-1520 (apply (lambda (syntmp-_-1521 syntmp-e1-1522 syntmp-e2-1523) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1522 syntmp-e2-1523))) syntmp-tmp-1520) ((lambda (syntmp-tmp-1525) (if syntmp-tmp-1525 (apply (lambda (syntmp-_-1526 syntmp-out-1527 syntmp-in-1528 syntmp-e1-1529 syntmp-e2-1530) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1528 (quote ()) (list syntmp-out-1527 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1529 syntmp-e2-1530))))) syntmp-tmp-1525) ((lambda (syntmp-tmp-1532) (if syntmp-tmp-1532 (apply (lambda (syntmp-_-1533 syntmp-out-1534 syntmp-in-1535 syntmp-e1-1536 syntmp-e2-1537) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1535) (quote ()) (list syntmp-out-1534 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1536 syntmp-e2-1537))))) syntmp-tmp-1532) (syntax-error syntmp-tmp-1519))) (syntax-dispatch syntmp-tmp-1519 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any () any . each-any))))) syntmp-x-1518))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1559) ((lambda (syntmp-tmp-1560) ((lambda (syntmp-tmp-1561) (if syntmp-tmp-1561 (apply (lambda (syntmp-_-1562 syntmp-k-1563 syntmp-keyword-1564 syntmp-pattern-1565 syntmp-template-1566) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1563 (map (lambda (syntmp-tmp-1569 syntmp-tmp-1568) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1568) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1569))) syntmp-template-1566 syntmp-pattern-1565)))))) syntmp-tmp-1561) (syntax-error syntmp-tmp-1560))) (syntax-dispatch syntmp-tmp-1560 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1559))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1580) ((lambda (syntmp-tmp-1581) ((lambda (syntmp-tmp-1582) (if (if syntmp-tmp-1582 (apply (lambda (syntmp-let*-1583 syntmp-x-1584 syntmp-v-1585 syntmp-e1-1586 syntmp-e2-1587) (andmap identifier? syntmp-x-1584)) syntmp-tmp-1582) #f) (apply (lambda (syntmp-let*-1589 syntmp-x-1590 syntmp-v-1591 syntmp-e1-1592 syntmp-e2-1593) (let syntmp-f-1594 ((syntmp-bindings-1595 (map list syntmp-x-1590 syntmp-v-1591))) (if (null? syntmp-bindings-1595) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1592 syntmp-e2-1593))) ((lambda (syntmp-tmp-1599) ((lambda (syntmp-tmp-1600) (if syntmp-tmp-1600 (apply (lambda (syntmp-body-1601 syntmp-binding-1602) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1602) syntmp-body-1601)) syntmp-tmp-1600) (syntax-error syntmp-tmp-1599))) (syntax-dispatch syntmp-tmp-1599 (quote (any any))))) (list (syntmp-f-1594 (cdr syntmp-bindings-1595)) (car syntmp-bindings-1595)))))) syntmp-tmp-1582) (syntax-error syntmp-tmp-1581))) (syntax-dispatch syntmp-tmp-1581 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1580))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1622) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-_-1625 syntmp-var-1626 syntmp-init-1627 syntmp-step-1628 syntmp-e0-1629 syntmp-e1-1630 syntmp-c-1631) ((lambda (syntmp-tmp-1632) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-step-1634) ((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-e1-1642 syntmp-e2-1643) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1642 syntmp-e2-1643)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1641) (syntax-error syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-e1-1630)) syntmp-tmp-1633) (syntax-error syntmp-tmp-1632))) (syntax-dispatch syntmp-tmp-1632 (quote each-any)))) (map (lambda (syntmp-v-1650 syntmp-s-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda () syntmp-v-1650) syntmp-tmp-1653) ((lambda (syntmp-tmp-1654) (if syntmp-tmp-1654 (apply (lambda (syntmp-e-1655) syntmp-e-1655) syntmp-tmp-1654) ((lambda (syntmp-_-1656) (syntax-error syntmp-orig-x-1622)) syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any)))))) (syntax-dispatch syntmp-tmp-1652 (quote ())))) syntmp-s-1651)) syntmp-var-1626 syntmp-step-1628))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1622))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1684 (lambda (syntmp-x-1688 syntmp-y-1689) ((lambda (syntmp-tmp-1690) ((lambda (syntmp-tmp-1691) (if syntmp-tmp-1691 (apply (lambda (syntmp-x-1692 syntmp-y-1693) ((lambda (syntmp-tmp-1694) ((lambda (syntmp-tmp-1695) (if syntmp-tmp-1695 (apply (lambda (syntmp-dy-1696) ((lambda (syntmp-tmp-1697) ((lambda (syntmp-tmp-1698) (if syntmp-tmp-1698 (apply (lambda (syntmp-dx-1699) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1699 syntmp-dy-1696))) syntmp-tmp-1698) ((lambda (syntmp-_-1700) (if (null? syntmp-dy-1696) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693))) syntmp-tmp-1697))) (syntax-dispatch syntmp-tmp-1697 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1692)) syntmp-tmp-1695) ((lambda (syntmp-tmp-1701) (if syntmp-tmp-1701 (apply (lambda (syntmp-stuff-1702) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1692 syntmp-stuff-1702))) syntmp-tmp-1701) ((lambda (syntmp-else-1703) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693)) syntmp-tmp-1694))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1693)) syntmp-tmp-1691) (syntax-error syntmp-tmp-1690))) (syntax-dispatch syntmp-tmp-1690 (quote (any any))))) (list syntmp-x-1688 syntmp-y-1689)))) (syntmp-quasiappend-1685 (lambda (syntmp-x-1704 syntmp-y-1705) ((lambda (syntmp-tmp-1706) ((lambda (syntmp-tmp-1707) (if syntmp-tmp-1707 (apply (lambda (syntmp-x-1708 syntmp-y-1709) ((lambda (syntmp-tmp-1710) ((lambda (syntmp-tmp-1711) (if syntmp-tmp-1711 (apply (lambda () syntmp-x-1708) syntmp-tmp-1711) ((lambda (syntmp-_-1712) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1708 syntmp-y-1709)) syntmp-tmp-1710))) (syntax-dispatch syntmp-tmp-1710 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1709)) syntmp-tmp-1707) (syntax-error syntmp-tmp-1706))) (syntax-dispatch syntmp-tmp-1706 (quote (any any))))) (list syntmp-x-1704 syntmp-y-1705)))) (syntmp-quasivector-1686 (lambda (syntmp-x-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-x-1715) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-x-1718) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1718))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1721)) syntmp-tmp-1720) ((lambda (syntmp-_-1723) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1715)) syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1715)) syntmp-tmp-1714)) syntmp-x-1713))) (syntmp-quasi-1687 (lambda (syntmp-p-1724 syntmp-lev-1725) ((lambda (syntmp-tmp-1726) ((lambda (syntmp-tmp-1727) (if syntmp-tmp-1727 (apply (lambda (syntmp-p-1728) (if (= syntmp-lev-1725 0) syntmp-p-1728 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1728) (- syntmp-lev-1725 1))))) syntmp-tmp-1727) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-p-1730 syntmp-q-1731) (if (= syntmp-lev-1725 0) (syntmp-quasiappend-1685 syntmp-p-1730 (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)) (syntmp-quasicons-1684 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1730) (- syntmp-lev-1725 1))) (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)))) syntmp-tmp-1729) ((lambda (syntmp-tmp-1732) (if syntmp-tmp-1732 (apply (lambda (syntmp-p-1733) (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1733) (+ syntmp-lev-1725 1)))) syntmp-tmp-1732) ((lambda (syntmp-tmp-1734) (if syntmp-tmp-1734 (apply (lambda (syntmp-p-1735 syntmp-q-1736) (syntmp-quasicons-1684 (syntmp-quasi-1687 syntmp-p-1735 syntmp-lev-1725) (syntmp-quasi-1687 syntmp-q-1736 syntmp-lev-1725))) syntmp-tmp-1734) ((lambda (syntmp-tmp-1737) (if syntmp-tmp-1737 (apply (lambda (syntmp-x-1738) (syntmp-quasivector-1686 (syntmp-quasi-1687 syntmp-x-1738 syntmp-lev-1725))) syntmp-tmp-1737) ((lambda (syntmp-p-1740) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1740)) syntmp-tmp-1726))) (syntax-dispatch syntmp-tmp-1726 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1726 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1724)))) (lambda (syntmp-x-1741) ((lambda (syntmp-tmp-1742) ((lambda (syntmp-tmp-1743) (if syntmp-tmp-1743 (apply (lambda (syntmp-_-1744 syntmp-e-1745) (syntmp-quasi-1687 syntmp-e-1745 0)) syntmp-tmp-1743) (syntax-error syntmp-tmp-1742))) (syntax-dispatch syntmp-tmp-1742 (quote (any any))))) syntmp-x-1741)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1805) (letrec ((syntmp-read-file-1806 (lambda (syntmp-fn-1807 syntmp-k-1808) (let ((syntmp-p-1809 (open-input-file syntmp-fn-1807))) (let syntmp-f-1810 ((syntmp-x-1811 (read syntmp-p-1809))) (if (eof-object? syntmp-x-1811) (begin (close-input-port syntmp-p-1809) (quote ())) (cons (datum->syntax-object syntmp-k-1808 syntmp-x-1811) (syntmp-f-1810 (read syntmp-p-1809))))))))) ((lambda (syntmp-tmp-1812) ((lambda (syntmp-tmp-1813) (if syntmp-tmp-1813 (apply (lambda (syntmp-k-1814 syntmp-filename-1815) (let ((syntmp-fn-1816 (syntax-object->datum syntmp-filename-1815))) ((lambda (syntmp-tmp-1817) ((lambda (syntmp-tmp-1818) (if syntmp-tmp-1818 (apply (lambda (syntmp-exp-1819) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1819)) syntmp-tmp-1818) (syntax-error syntmp-tmp-1817))) (syntax-dispatch syntmp-tmp-1817 (quote each-any)))) (syntmp-read-file-1806 syntmp-fn-1816 syntmp-k-1814)))) syntmp-tmp-1813) (syntax-error syntmp-tmp-1812))) (syntax-dispatch syntmp-tmp-1812 (quote (any any))))) syntmp-x-1805)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1836) ((lambda (syntmp-tmp-1837) ((lambda (syntmp-tmp-1838) (if syntmp-tmp-1838 (apply (lambda (syntmp-_-1839 syntmp-e-1840) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1840))) syntmp-tmp-1838) (syntax-error syntmp-tmp-1837))) (syntax-dispatch syntmp-tmp-1837 (quote (any any))))) syntmp-x-1836))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1846) ((lambda (syntmp-tmp-1847) ((lambda (syntmp-tmp-1848) (if syntmp-tmp-1848 (apply (lambda (syntmp-_-1849 syntmp-e-1850) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1850))) syntmp-tmp-1848) (syntax-error syntmp-tmp-1847))) (syntax-dispatch syntmp-tmp-1847 (quote (any any))))) syntmp-x-1846))) +(install-global-transformer (quote case) (lambda (syntmp-x-1856) ((lambda (syntmp-tmp-1857) ((lambda (syntmp-tmp-1858) (if syntmp-tmp-1858 (apply (lambda (syntmp-_-1859 syntmp-e-1860 syntmp-m1-1861 syntmp-m2-1862) ((lambda (syntmp-tmp-1863) ((lambda (syntmp-body-1864) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1860)) syntmp-body-1864)) syntmp-tmp-1863)) (let syntmp-f-1865 ((syntmp-clause-1866 syntmp-m1-1861) (syntmp-clauses-1867 syntmp-m2-1862)) (if (null? syntmp-clauses-1867) ((lambda (syntmp-tmp-1869) ((lambda (syntmp-tmp-1870) (if syntmp-tmp-1870 (apply (lambda (syntmp-e1-1871 syntmp-e2-1872) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1871 syntmp-e2-1872))) syntmp-tmp-1870) ((lambda (syntmp-tmp-1874) (if syntmp-tmp-1874 (apply (lambda (syntmp-k-1875 syntmp-e1-1876 syntmp-e2-1877) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1875)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1876 syntmp-e2-1877)))) syntmp-tmp-1874) ((lambda (syntmp-_-1880) (syntax-error syntmp-x-1856)) syntmp-tmp-1869))) (syntax-dispatch syntmp-tmp-1869 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1869 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1866) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-rest-1882) ((lambda (syntmp-tmp-1883) ((lambda (syntmp-tmp-1884) (if syntmp-tmp-1884 (apply (lambda (syntmp-k-1885 syntmp-e1-1886 syntmp-e2-1887) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1885)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1886 syntmp-e2-1887)) syntmp-rest-1882)) syntmp-tmp-1884) ((lambda (syntmp-_-1890) (syntax-error syntmp-x-1856)) syntmp-tmp-1883))) (syntax-dispatch syntmp-tmp-1883 (quote (each-any any . each-any))))) syntmp-clause-1866)) syntmp-tmp-1881)) (syntmp-f-1865 (car syntmp-clauses-1867) (cdr syntmp-clauses-1867))))))) syntmp-tmp-1858) (syntax-error syntmp-tmp-1857))) (syntax-dispatch syntmp-tmp-1857 (quote (any any any . each-any))))) syntmp-x-1856))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1920) ((lambda (syntmp-tmp-1921) ((lambda (syntmp-tmp-1922) (if syntmp-tmp-1922 (apply (lambda (syntmp-_-1923 syntmp-e-1924) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1924)) (list (cons syntmp-_-1923 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1924 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1922) (syntax-error syntmp-tmp-1921))) (syntax-dispatch syntmp-tmp-1921 (quote (any any))))) syntmp-x-1920))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index d016b2f6d..cd2c53224 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1132,7 +1132,7 @@ ;; apply transformer (value e r w s mod)) ((module-ref) - (call-with-values (lambda () (value e r w s mod)) + (call-with-values (lambda () (value e)) ;; we could add a public? arg here (lambda (id mod) (build-global-reference s id mod)))) ((lexical-call) @@ -1772,15 +1772,24 @@ (syntax-error (wrap (syntax id) w mod) "identifier out of context")) (else (syntax-error (source-wrap e w s mod))))))) - ((_ (getter arg ...) val) - (build-application s - (chi (syntax (setter getter)) r w mod) - (map (lambda (e) (chi e r w mod)) - (syntax (arg ... val))))) + ((_ (head tail ...) val) + (call-with-values + (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod)) + (lambda (type value ee ww ss modmod) + (case type + ((module-ref) + (call-with-values (lambda () (value (syntax (head tail ...)))) + (lambda (id mod) + (build-global-assignment s id (syntax val) mod)))) + (else + (build-application s + (chi (syntax (setter head)) r w mod) + (map (lambda (e) (chi e r w mod)) + (syntax (tail ... val))))))))) (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'module-ref '@ - (lambda (e r w s mod) + (lambda (e) (syntax-case e (%module-public-interface) ((_ (mod ...) id) (and (andmap id? (syntax (mod ...))) (id? (syntax id))) @@ -1789,7 +1798,7 @@ (syntax (mod ... %module-public-interface)))))))) (global-extend 'module-ref '@@ - (lambda (e r w s mod) + (lambda (e) (syntax-case e () ((_ (mod ...) id) (and (andmap id? (syntax (mod ...))) (id? (syntax id))) From b7e6589fff9fe85c46519ba20d45bf599ea56ffd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 9 Mar 2009 20:49:54 +0100 Subject: [PATCH 050/375] scm_[current_]module_transformer returns the %pre-modules-transformer, if set * libguile/modules.c (scm_module_transformer) (scm_current_module_transformer): So, if the module system hasn't yet booted, take the current transformer from a variable named %pre-modules-transformer from the %pre-modules-obarray. This is a prequel to booting syncase early in boot-9. --- libguile/modules.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index 428cb607d..2cb8a7620 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -577,11 +577,20 @@ scm_current_module_lookup_closure () return SCM_BOOL_F; } +SCM_SYMBOL (sym_sys_pre_modules_transformer, "%pre-modules-transformer"); + SCM scm_module_transformer (SCM module) { - if (scm_is_false (module)) - return SCM_BOOL_F; + if (SCM_UNLIKELY (scm_is_false (module))) + { SCM v = scm_hashq_ref (scm_pre_modules_obarray, + sym_sys_pre_modules_transformer, + SCM_BOOL_F); + if (scm_is_false (v)) + return SCM_BOOL_F; + else + return SCM_VARIABLE_REF (v); + } else return SCM_MODULE_TRANSFORMER (module); } @@ -589,10 +598,7 @@ scm_module_transformer (SCM module) SCM scm_current_module_transformer () { - if (scm_module_system_booted_p) - return scm_module_transformer (scm_current_module ()); - else - return SCM_BOOL_F; + return scm_module_transformer (scm_current_module ()); } SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, From ae6bba7f9c5fd712b3177b067a03e8e8277a94c3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 9 Mar 2009 20:52:45 +0100 Subject: [PATCH 051/375] commit some tweaks to expand.scm, likely obviated by syncase though * module/language/scheme/expand.scm (re-annotate, expand): A couple of speculative cases for dealing with syncase better -- but all of this code is likely to go. --- module/language/scheme/expand.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm index 18dc032c9..2ffefb318 100644 --- a/module/language/scheme/expand.scm +++ b/module/language/scheme/expand.scm @@ -37,7 +37,7 @@ (define (acddr x) (acdr (acdr x))) (define (aloc x) (and (annotation? x) (annotation-source x))) (define (re-annotate x y) - (if (annotation? x) + (if (and (annotation? x) (not (annotation? y))) (make-annotation y (annotation-source x)) y)) (define-macro (-> exp) `(re-annotate x ,exp)) @@ -77,8 +77,8 @@ (sc-expand3 (@@ (ice-9 syncase) sc-expand3))) (re-expand (with-fluids ((eec (module-eval-closure mod))) - ;; fixme - (sc-expand3 (deannotate exp) 'c '(compile load eval)))))) + ;; fixme -- use ewes fluid? + (sc-expand3 exp 'c '(compile load eval)))))) ((primitive-macro? val) (syntax-error (aloc x) "unhandled primitive macro" head)) From 181f1cd7d0b9f6ab3035f615142dabf6f63d0583 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 9 Mar 2009 21:09:22 +0100 Subject: [PATCH 052/375] allow eval to be called before modules are booted * libguile/eval.c (scm_eval): If the module system isn't booted, assert not on the module argument. --- libguile/eval.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 4c79b166c..19ac0b155 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -4109,11 +4109,12 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); if (scm_is_dynamic_state (module_or_state)) scm_dynwind_current_dynamic_state (module_or_state); - else + else if (scm_module_system_booted_p) { SCM_VALIDATE_MODULE (2, module_or_state); scm_dynwind_current_module (module_or_state); } + /* otherwise if the module system isn't booted, ignore the module arg */ res = scm_primitive_eval (exp); From 928258fbf2bfd453930cd5d6c0f7ba59a221fe64 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 9 Mar 2009 21:40:30 +0100 Subject: [PATCH 053/375] tweaks to boot-9 * module/ice-9/boot-9.scm: Move the r4rs init up to the top. (try-module-autoload): Don't use with-fluids before it's defined. --- module/ice-9/boot-9.scm | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 03d876907..0f57e7f84 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -33,6 +33,13 @@ +;;; {R4RS compliance} +;;; + +(primitive-load-path "ice-9/r4rs") + + + ;;; {Features} ;;; @@ -189,13 +196,6 @@ -;;; {R4RS compliance} -;;; - -(primitive-load-path "ice-9/r4rs") - - - ;;; {Simple Debugging Tools} ;;; @@ -2159,8 +2159,8 @@ module '(ice-9 q) '(make-q q-length))}." (stat:mtime (stat source))))) (if compiled (warn "source file" source "newer than" compiled)) - (with-fluids ((current-reader #f)) - (load-file primitive-load source))) + (with-fluid* current-reader #f + (lambda () (load-file primitive-load source)))) (compiled (load-file load-compiled compiled)))))) (lambda () (set-autoloaded! dir-hint name didit))) From b1e93821a3065f1ebccc55dadf678bda75c0f34d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 9 Mar 2009 22:01:27 +0100 Subject: [PATCH 054/375] fix begin-deprecated * module/ice-9/boot-9.scm (begin-deprecated): Fix to output source code, doh. --- module/ice-9/boot-9.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 0f57e7f84..d36d33bf9 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -192,7 +192,7 @@ (defmacro begin-deprecated forms (if (include-deprecated-features) `(begin ,@forms) - (begin))) + `(begin))) From efa6f9d944174427a3125aa4773e5f6a7e04acdd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Apr 2009 00:17:22 +0200 Subject: [PATCH 055/375] module-name before syncase is booted * module/ice-9/boot-9.scm (module-name): Give psyntax a module-name definition, even before psyntax is booted (in a future commit). --- module/ice-9/boot-9.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index d36d33bf9..f3cf9b0a5 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -93,6 +93,11 @@ +;; Before the module system boots, there are no module names. But +;; psyntax does want a module-name definition, so give it one. +(define (module-name x) + #f) + ;; (eval-when (situation...) form...) ;; ;; Evaluate certain code based on the situation that eval-when is used From eb5d1f882672345231bca226e140b2a91718d348 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Apr 2009 22:23:43 +0200 Subject: [PATCH 056/375] move pk, peek, and warn to the beginning of boot-9 * module/ice-9/boot-9.scm (peek, pk, warn): Move these helpers up to the top. I like them! (load-compiled): Don't define within an if, syncase doesn't like that. --- module/ice-9/boot-9.scm | 69 +++++++++++++++++++---------------------- 1 file changed, 32 insertions(+), 37 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f3cf9b0a5..48d822bfc 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -40,6 +40,38 @@ +;;; {Simple Debugging Tools} +;;; + +;; peek takes any number of arguments, writes them to the +;; current ouput port, and returns the last argument. +;; It is handy to wrap around an expression to look at +;; a value each time is evaluated, e.g.: +;; +;; (+ 10 (troublesome-fn)) +;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn))) +;; + +(define (peek . stuff) + (newline) + (display ";;; ") + (write stuff) + (newline) + (car (last-pair stuff))) + +(define pk peek) + +(define (warn . stuff) + (with-output-to-port (current-error-port) + (lambda () + (newline) + (display ";;; WARNING ") + (display stuff) + (newline) + (car (last-pair stuff))))) + + + ;;; {Features} ;;; @@ -201,38 +233,6 @@ -;;; {Simple Debugging Tools} -;;; - -;; peek takes any number of arguments, writes them to the -;; current ouput port, and returns the last argument. -;; It is handy to wrap around an expression to look at -;; a value each time is evaluated, e.g.: -;; -;; (+ 10 (troublesome-fn)) -;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn))) -;; - -(define (peek . stuff) - (newline) - (display ";;; ") - (write stuff) - (newline) - (car (last-pair stuff))) - -(define pk peek) - -(define (warn . stuff) - (with-output-to-port (current-error-port) - (lambda () - (newline) - (display ";;; WARNING ") - (display stuff) - (newline) - (car (last-pair stuff))))) - - - ;;; {Trivial Functions} ;;; @@ -2121,11 +2121,6 @@ module '(ice-9 q) '(make-q q-length))}." (loop (cddr args))))))) -;;; {Compiled module} - -(if (not (defined? 'load-compiled)) - (define load-compiled #f)) - ;;; {Autoloading modules} From 8239263f86e9d3782482e4da4b91d8fe490ac4ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Apr 2009 22:27:50 +0200 Subject: [PATCH 057/375] fix erroneous #:use-syntax clausen * module/system/repl/command.scm: * module/system/repl/common.scm: * module/system/repl/repl.scm: * module/system/vm/debug.scm: * module/system/vm/trace.scm: Change #:use-syntax to #:use-module, as that's really what we want to do. --- module/language/ghil/compile-glil.scm | 2 +- module/system/repl/command.scm | 2 +- module/system/repl/common.scm | 2 +- module/system/repl/repl.scm | 2 +- module/system/vm/debug.scm | 2 +- module/system/vm/trace.scm | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm index 863d2603b..c813319d6 100644 --- a/module/language/ghil/compile-glil.scm +++ b/module/language/ghil/compile-glil.scm @@ -20,7 +20,7 @@ ;;; Code: (define-module (language ghil compile-glil) - #:use-syntax (system base syntax) + #:use-module (system base syntax) #:use-module (language glil) #:use-module (language ghil) #:use-module (ice-9 common-list) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index cf09e01af..47f1a9aa2 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -20,7 +20,7 @@ ;;; Code: (define-module (system repl command) - #:use-syntax (system base syntax) + #:use-module (system base syntax) #:use-module (system base pmatch) #:use-module (system base compile) #:use-module (system repl common) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index bc3242375..1978255f7 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -20,7 +20,7 @@ ;;; Code: (define-module (system repl common) - #:use-syntax (system base syntax) + #:use-module (system base syntax) #:use-module (system base compile) #:use-module (system base language) #:use-module (system vm vm) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 76e7bfe3f..ebf2b93d4 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -20,7 +20,7 @@ ;;; Code: (define-module (system repl repl) - #:use-syntax (system base syntax) + #:use-module (system base syntax) #:use-module (system base pmatch) #:use-module (system base compile) #:use-module (system base language) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 3c5cfa201..740111257 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -20,7 +20,7 @@ ;;; Code: (define-module (system vm debug) - #:use-syntax (system base syntax) + #:use-module (system base syntax) #:use-module (system vm vm) #:use-module (system vm frame) #:use-module (ice-9 format) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 00f013c9d..2ba528052 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -20,7 +20,7 @@ ;;; Code: (define-module (system vm trace) - #:use-syntax (system base syntax) + #:use-module (system base syntax) #:use-module (system vm vm) #:use-module (system vm frame) #:use-module (ice-9 format) From 819cf0e8b8f09e769e194781ec57a52f9415763b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Apr 2009 11:25:22 +0200 Subject: [PATCH 058/375] I ain't broke, but brother I'm badly bent * module/ice-9/expand-support.scm (strip-expansion-structures): If, when producing @/@@ forms, we find that an @@ variable is not bound in its module, just serialize the symbol. This bends hygiene, in that it can introduce a global (but not lexical) reference in the expanded module, but it seems necessary to not produce (@@ (foo) else) in forms like ((@@ (foo) cond) ((test then) ((@@ (foo) else) bar))). --- module/ice-9/expand-support.scm | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm index 63ea2d2b1..372d959a5 100644 --- a/module/ice-9/expand-support.scm +++ b/module/ice-9/expand-support.scm @@ -149,13 +149,19 @@ (set-source-properties! e source)) e)) ((module-ref? e) - (if (and (module-ref-modname e) - (not (eq? (module-ref-modname e) - (module-name (current-module))))) - `(,(if (module-ref-public? e) '@ '@@) - ,(module-ref-modname e) - ,(module-ref-symbol e)) - (module-ref-symbol e))) + (cond + ((or (not (module-ref-modname e)) + (eq? (module-ref-modname e) + (module-name (current-module))) + (and (not (module-ref-public? e)) + (not (module-variable + (resolve-module (module-ref-modname e)) + (module-ref-symbol e))))) + (module-ref-symbol e)) + (else + `(,(if (module-ref-public? e) '@ '@@) + ,(module-ref-modname e) + ,(module-ref-symbol e))))) ((lexical? e) (lexical-gensym e)) ((record? e) From 757937c290ae64a7a75232793c659d0cca3dea10 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Apr 2009 23:10:35 +0200 Subject: [PATCH 059/375] more steps on the way to boot-time syncase * module/ice-9/boot-9.scm: Define a version of module-add! for psyntax, before modules are booted. * module/ice-9/psyntax.scm: Remove a warning, and rename a variable. Initialize a new variable to 'sc-macro, though it will have no effect. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/boot-9.scm | 2 ++ module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 10 +++++----- 3 files changed, 18 insertions(+), 16 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 48d822bfc..1a8157ac6 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -129,6 +129,8 @@ ;; psyntax does want a module-name definition, so give it one. (define (module-name x) #f) +(define (module-add! module sym var) + (hashq-set! (%get-pre-modules-obarray) sym var)) ;; (eval-when (situation...) form...) ;; diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 02d9e9975..1ab522163 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-544) (let syntmp-lvl-545 ((syntmp-vars-546 syntmp-vars-544) (syntmp-ls-547 (quote ())) (syntmp-w-548 (quote (())))) (cond ((pair? syntmp-vars-546) (syntmp-lvl-545 (cdr syntmp-vars-546) (cons (syntmp-wrap-132 (car syntmp-vars-546) syntmp-w-548 #f) syntmp-ls-547) syntmp-w-548)) ((syntmp-id?-104 syntmp-vars-546) (cons (syntmp-wrap-132 syntmp-vars-546 syntmp-w-548 #f) syntmp-ls-547)) ((null? syntmp-vars-546) syntmp-ls-547) ((syntmp-syntax-object?-88 syntmp-vars-546) (syntmp-lvl-545 (syntmp-syntax-object-expression-89 syntmp-vars-546) syntmp-ls-547 (syntmp-join-wraps-123 syntmp-w-548 (syntmp-syntax-object-wrap-90 syntmp-vars-546)))) ((annotation? syntmp-vars-546) (syntmp-lvl-545 (annotation-expression syntmp-vars-546) syntmp-ls-547 syntmp-w-548)) (else (cons syntmp-vars-546 syntmp-ls-547)))))) (syntmp-gen-var-152 (lambda (syntmp-id-549) (let ((syntmp-id-550 (if (syntmp-syntax-object?-88 syntmp-id-549) (syntmp-syntax-object-expression-89 syntmp-id-549) syntmp-id-549))) (if (annotation? syntmp-id-550) (syntmp-build-annotated-81 (annotation-source syntmp-id-550) (gensym (symbol->string (annotation-expression syntmp-id-550)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-550))))))) (syntmp-strip-151 (lambda (syntmp-x-551 syntmp-w-552) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-552)) (if (or (annotation? syntmp-x-551) (and (pair? syntmp-x-551) (annotation? (car syntmp-x-551)))) (syntmp-strip-annotation-150 syntmp-x-551 #f) syntmp-x-551) (let syntmp-f-553 ((syntmp-x-554 syntmp-x-551)) (cond ((syntmp-syntax-object?-88 syntmp-x-554) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-554) (syntmp-syntax-object-wrap-90 syntmp-x-554))) ((pair? syntmp-x-554) (let ((syntmp-a-555 (syntmp-f-553 (car syntmp-x-554))) (syntmp-d-556 (syntmp-f-553 (cdr syntmp-x-554)))) (if (and (eq? syntmp-a-555 (car syntmp-x-554)) (eq? syntmp-d-556 (cdr syntmp-x-554))) syntmp-x-554 (cons syntmp-a-555 syntmp-d-556)))) ((vector? syntmp-x-554) (let ((syntmp-old-557 (vector->list syntmp-x-554))) (let ((syntmp-new-558 (map syntmp-f-553 syntmp-old-557))) (if (andmap eq? syntmp-old-557 syntmp-new-558) syntmp-x-554 (list->vector syntmp-new-558))))) (else syntmp-x-554)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-559 syntmp-parent-560) (cond ((pair? syntmp-x-559) (let ((syntmp-new-561 (cons #f #f))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-561)) (set-car! syntmp-new-561 (syntmp-strip-annotation-150 (car syntmp-x-559) #f)) (set-cdr! syntmp-new-561 (syntmp-strip-annotation-150 (cdr syntmp-x-559) #f)) syntmp-new-561))) ((annotation? syntmp-x-559) (or (annotation-stripped syntmp-x-559) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-559) syntmp-x-559))) ((vector? syntmp-x-559) (let ((syntmp-new-562 (make-vector (vector-length syntmp-x-559)))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-562)) (let syntmp-loop-563 ((syntmp-i-564 (- (vector-length syntmp-x-559) 1))) (unless (syntmp-fx<-75 syntmp-i-564 0) (vector-set! syntmp-new-562 syntmp-i-564 (syntmp-strip-annotation-150 (vector-ref syntmp-x-559 syntmp-i-564) #f)) (syntmp-loop-563 (syntmp-fx--73 syntmp-i-564 1)))) syntmp-new-562))) (else syntmp-x-559)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-565) (and (syntmp-nonsymbol-id?-103 syntmp-x-565) (syntmp-free-id=?-127 syntmp-x-565 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-566 syntmp-mod-567) (let ((syntmp-p-568 (syntmp-local-eval-hook-77 syntmp-expanded-566 syntmp-mod-567))) (if (procedure? syntmp-p-568) syntmp-p-568 (syntax-error syntmp-p-568 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-569 syntmp-e-570 syntmp-r-571 syntmp-w-572 syntmp-s-573 syntmp-mod-574 syntmp-k-575) ((lambda (syntmp-tmp-576) ((lambda (syntmp-tmp-577) (if syntmp-tmp-577 (apply (lambda (syntmp-_-578 syntmp-id-579 syntmp-val-580 syntmp-e1-581 syntmp-e2-582) (let ((syntmp-ids-583 syntmp-id-579)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-583)) (syntax-error syntmp-e-570 "duplicate bound keyword in") (let ((syntmp-labels-585 (syntmp-gen-labels-110 syntmp-ids-583))) (let ((syntmp-new-w-586 (syntmp-make-binding-wrap-121 syntmp-ids-583 syntmp-labels-585 syntmp-w-572))) (syntmp-k-575 (cons syntmp-e1-581 syntmp-e2-582) (syntmp-extend-env-98 syntmp-labels-585 (let ((syntmp-w-588 (if syntmp-rec?-569 syntmp-new-w-586 syntmp-w-572)) (syntmp-trans-r-589 (syntmp-macros-only-env-100 syntmp-r-571))) (map (lambda (syntmp-x-590) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-590 syntmp-trans-r-589 syntmp-w-588 syntmp-mod-574) syntmp-mod-574))) syntmp-val-580)) syntmp-r-571) syntmp-new-w-586 syntmp-s-573 syntmp-mod-574)))))) syntmp-tmp-577) ((lambda (syntmp-_-592) (syntax-error (syntmp-source-wrap-133 syntmp-e-570 syntmp-w-572 syntmp-s-573 syntmp-mod-574))) syntmp-tmp-576))) (syntax-dispatch syntmp-tmp-576 (quote (any #(each (any any)) any . each-any))))) syntmp-e-570))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-593 syntmp-c-594 syntmp-r-595 syntmp-w-596 syntmp-mod-597 syntmp-k-598) ((lambda (syntmp-tmp-599) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-id-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-ids-604 syntmp-id-601)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-604)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-606 (syntmp-gen-labels-110 syntmp-ids-604)) (syntmp-new-vars-607 (map syntmp-gen-var-152 syntmp-ids-604))) (syntmp-k-598 syntmp-new-vars-607 (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-606 syntmp-new-vars-607 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-ids-604 syntmp-labels-606 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-600) ((lambda (syntmp-tmp-609) (if syntmp-tmp-609 (apply (lambda (syntmp-ids-610 syntmp-e1-611 syntmp-e2-612) (let ((syntmp-old-ids-613 (syntmp-lambda-var-list-153 syntmp-ids-610))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-613)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-614 (syntmp-gen-labels-110 syntmp-old-ids-613)) (syntmp-new-vars-615 (map syntmp-gen-var-152 syntmp-old-ids-613))) (syntmp-k-598 (let syntmp-f-616 ((syntmp-ls1-617 (cdr syntmp-new-vars-615)) (syntmp-ls2-618 (car syntmp-new-vars-615))) (if (null? syntmp-ls1-617) syntmp-ls2-618 (syntmp-f-616 (cdr syntmp-ls1-617) (cons (car syntmp-ls1-617) syntmp-ls2-618)))) (syntmp-chi-body-144 (cons syntmp-e1-611 syntmp-e2-612) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-614 syntmp-new-vars-615 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-old-ids-613 syntmp-labels-614 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-609) ((lambda (syntmp-_-620) (syntax-error syntmp-e-593)) syntmp-tmp-599))) (syntax-dispatch syntmp-tmp-599 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-599 (quote (each-any any . each-any))))) syntmp-c-594))) (syntmp-chi-body-144 (lambda (syntmp-body-621 syntmp-outer-form-622 syntmp-r-623 syntmp-w-624 syntmp-mod-625) (let ((syntmp-r-626 (cons (quote ("placeholder" placeholder)) syntmp-r-623))) (let ((syntmp-ribcage-627 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-628 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-624) (cons syntmp-ribcage-627 (syntmp-wrap-subst-108 syntmp-w-624))))) (let syntmp-parse-629 ((syntmp-body-630 (map (lambda (syntmp-x-636) (cons syntmp-r-626 (syntmp-wrap-132 syntmp-x-636 syntmp-w-628 syntmp-mod-625))) syntmp-body-621)) (syntmp-ids-631 (quote ())) (syntmp-labels-632 (quote ())) (syntmp-vars-633 (quote ())) (syntmp-vals-634 (quote ())) (syntmp-bindings-635 (quote ()))) (if (null? syntmp-body-630) (syntax-error syntmp-outer-form-622 "no expressions in body") (let ((syntmp-e-637 (cdar syntmp-body-630)) (syntmp-er-638 (caar syntmp-body-630))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-637 syntmp-er-638 (quote (())) #f syntmp-ribcage-627 syntmp-mod-625)) (lambda (syntmp-type-639 syntmp-value-640 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644) (let ((syntmp-t-645 syntmp-type-639)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-647 (syntmp-gen-label-109))) (let ((syntmp-var-648 (syntmp-gen-var-152 syntmp-id-646))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-646 syntmp-label-647) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-646 syntmp-ids-631) (cons syntmp-label-647 syntmp-labels-632) (cons syntmp-var-648 syntmp-vars-633) (cons (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644)) syntmp-vals-634) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-635))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-650 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-649 syntmp-label-650) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-649 syntmp-ids-631) (cons syntmp-label-650 syntmp-labels-632) syntmp-vars-633 syntmp-vals-634 (cons (cons (quote macro) (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644))) syntmp-bindings-635)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-629 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-630) (cons (cons syntmp-er-638 (syntmp-wrap-132 (car syntmp-forms-656) syntmp-w-642 syntmp-mod-644)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-641) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-640 syntmp-e-641 syntmp-er-638 syntmp-w-642 syntmp-s-643 syntmp-mod-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661 syntmp-mod-662) (syntmp-parse-629 (let syntmp-f-663 ((syntmp-forms-664 syntmp-forms-658)) (if (null? syntmp-forms-664) (cdr syntmp-body-630) (cons (cons syntmp-er-659 (syntmp-wrap-132 (car syntmp-forms-664) syntmp-w-660 syntmp-mod-662)) (syntmp-f-663 (cdr syntmp-forms-664))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635))) (if (null? syntmp-ids-631) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-665) (syntmp-chi-140 (cdr syntmp-x-665) (car syntmp-x-665) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-631)) (syntax-error syntmp-outer-form-622 "invalid or duplicate identifier in definition")) (let syntmp-loop-666 ((syntmp-bs-667 syntmp-bindings-635) (syntmp-er-cache-668 #f) (syntmp-r-cache-669 #f)) (if (not (null? syntmp-bs-667)) (let ((syntmp-b-670 (car syntmp-bs-667))) (if (eq? (car syntmp-b-670) (quote macro)) (let ((syntmp-er-671 (cadr syntmp-b-670))) (let ((syntmp-r-cache-672 (if (eq? syntmp-er-671 syntmp-er-cache-668) syntmp-r-cache-669 (syntmp-macros-only-env-100 syntmp-er-671)))) (begin (set-cdr! syntmp-b-670 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-670) syntmp-r-cache-672 (quote (())) syntmp-mod-644) syntmp-mod-644)) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-671 syntmp-r-cache-672)))) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-cache-668 syntmp-r-cache-669))))) (set-cdr! syntmp-r-626 (syntmp-extend-env-98 syntmp-labels-632 syntmp-bindings-635 (cdr syntmp-r-626))) (syntmp-build-letrec-86 #f syntmp-vars-633 (map (lambda (syntmp-x-673) (syntmp-chi-140 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())) syntmp-mod-644)) syntmp-vals-634) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-674) (syntmp-chi-140 (cdr syntmp-x-674) (car syntmp-x-674) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-675 syntmp-e-676 syntmp-r-677 syntmp-w-678 syntmp-rib-679 syntmp-mod-680) (letrec ((syntmp-rebuild-macro-output-681 (lambda (syntmp-x-682 syntmp-m-683) (cond ((pair? syntmp-x-682) (cons (syntmp-rebuild-macro-output-681 (car syntmp-x-682) syntmp-m-683) (syntmp-rebuild-macro-output-681 (cdr syntmp-x-682) syntmp-m-683))) ((syntmp-syntax-object?-88 syntmp-x-682) (let ((syntmp-w-684 (syntmp-syntax-object-wrap-90 syntmp-x-682))) (let ((syntmp-ms-685 (syntmp-wrap-marks-107 syntmp-w-684)) (syntmp-s-686 (syntmp-wrap-subst-108 syntmp-w-684))) (if (and (pair? syntmp-ms-685) (eq? (car syntmp-ms-685) #f)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cdr syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cdr syntmp-s-686)) (cdr syntmp-s-686))) (syntmp-syntax-object-module-91 syntmp-x-682)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cons syntmp-m-683 syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cons (quote shift) syntmp-s-686)) (cons (quote shift) syntmp-s-686))) (module-name (procedure-module syntmp-p-675))))))) ((vector? syntmp-x-682) (let ((syntmp-n-687 (vector-length syntmp-x-682))) (let ((syntmp-v-688 (make-vector syntmp-n-687))) (let syntmp-doloop-689 ((syntmp-i-690 0)) (if (syntmp-fx=-74 syntmp-i-690 syntmp-n-687) syntmp-v-688 (begin (vector-set! syntmp-v-688 syntmp-i-690 (syntmp-rebuild-macro-output-681 (vector-ref syntmp-x-682 syntmp-i-690) syntmp-m-683)) (syntmp-doloop-689 (syntmp-fx+-72 syntmp-i-690 1)))))))) ((symbol? syntmp-x-682) (syntax-error syntmp-x-682 "encountered raw symbol in macro output")) (else syntmp-x-682))))) (syntmp-rebuild-macro-output-681 (syntmp-p-675 (syntmp-wrap-132 syntmp-e-676 (syntmp-anti-mark-119 syntmp-w-678) syntmp-mod-680)) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-691 syntmp-e-692 syntmp-r-693 syntmp-w-694 syntmp-s-695 syntmp-mod-696) ((lambda (syntmp-tmp-697) ((lambda (syntmp-tmp-698) (if syntmp-tmp-698 (apply (lambda (syntmp-e0-699 syntmp-e1-700) (syntmp-build-annotated-81 syntmp-s-695 (cons syntmp-x-691 (map (lambda (syntmp-e-701) (syntmp-chi-140 syntmp-e-701 syntmp-r-693 syntmp-w-694 syntmp-mod-696)) syntmp-e1-700)))) syntmp-tmp-698) (syntax-error syntmp-tmp-697))) (syntax-dispatch syntmp-tmp-697 (quote (any . each-any))))) syntmp-e-692))) (syntmp-chi-expr-141 (lambda (syntmp-type-703 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (let ((syntmp-t-710 syntmp-type-703)) (if (memv syntmp-t-710 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-708 syntmp-value-704) (if (memv syntmp-t-710 (quote (core external-macro))) (syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-704 syntmp-e-705)) (lambda (syntmp-id-711 syntmp-mod-712) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-712 syntmp-id-711 #f)))) (if (memv syntmp-t-710 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) syntmp-value-704) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) (make-module-ref (if (syntmp-syntax-object?-88 (car syntmp-e-705)) (syntmp-syntax-object-module-91 (car syntmp-e-705)) syntmp-mod-709) syntmp-value-704 #f)) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (constant))) (syntmp-build-data-82 syntmp-s-708 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (quote (())))) (if (memv syntmp-t-710 (quote (global))) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-709 syntmp-value-704 #f)) (if (memv syntmp-t-710 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-705) syntmp-r-706 syntmp-w-707 syntmp-mod-709) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (begin-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-e1-716 syntmp-e2-717) (syntmp-chi-sequence-134 (cons syntmp-e1-716 syntmp-e2-717) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709)) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709 syntmp-chi-sequence-134) (if (memv syntmp-t-710 (quote (eval-when-form))) ((lambda (syntmp-tmp-719) ((lambda (syntmp-tmp-720) (if syntmp-tmp-720 (apply (lambda (syntmp-_-721 syntmp-x-722 syntmp-e1-723 syntmp-e2-724) (let ((syntmp-when-list-725 (syntmp-chi-when-list-137 syntmp-e-705 syntmp-x-722 syntmp-w-707))) (if (memq (quote eval) syntmp-when-list-725) (syntmp-chi-sequence-134 (cons syntmp-e1-723 syntmp-e2-724) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (syntmp-chi-void-148)))) syntmp-tmp-720) (syntax-error syntmp-tmp-719))) (syntax-dispatch syntmp-tmp-719 (quote (any each-any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-704 syntmp-w-707 syntmp-mod-709) "invalid context for definition of") (if (memv syntmp-t-710 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to pattern variable outside syntax form") (if (memv syntmp-t-710 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709))))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-728 syntmp-r-729 syntmp-w-730 syntmp-mod-731) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-728 syntmp-r-729 syntmp-w-730 #f #f syntmp-mod-731)) (lambda (syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-w-735 syntmp-s-736 syntmp-mod-737) (syntmp-chi-expr-141 syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-r-729 syntmp-w-735 syntmp-s-736 syntmp-mod-737))))) (syntmp-chi-top-139 (lambda (syntmp-e-738 syntmp-r-739 syntmp-w-740 syntmp-m-741 syntmp-esew-742 syntmp-mod-743) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-738 syntmp-r-739 syntmp-w-740 #f #f syntmp-mod-743)) (lambda (syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-w-761 syntmp-s-762 syntmp-mod-763) (let ((syntmp-t-764 syntmp-type-758)) (if (memv syntmp-t-764 (quote (begin-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767) (syntmp-chi-void-148)) syntmp-tmp-766) ((lambda (syntmp-tmp-768) (if syntmp-tmp-768 (apply (lambda (syntmp-_-769 syntmp-e1-770 syntmp-e2-771) (syntmp-chi-top-sequence-135 (cons syntmp-e1-770 syntmp-e2-771) syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-m-741 syntmp-esew-742 syntmp-mod-763)) syntmp-tmp-768) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-765 (quote (any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763 (lambda (syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-mod-777) (syntmp-chi-top-sequence-135 syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-m-741 syntmp-esew-742 syntmp-mod-777))) (if (memv syntmp-t-764 (quote (eval-when-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-x-781 syntmp-e1-782 syntmp-e2-783) (let ((syntmp-when-list-784 (syntmp-chi-when-list-137 syntmp-e-760 syntmp-x-781 syntmp-w-761)) (syntmp-body-785 (cons syntmp-e1-782 syntmp-e2-783))) (cond ((eq? syntmp-m-741 (quote e)) (if (memq (quote eval) syntmp-when-list-784) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-784) (if (or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c&e) (quote (compile load)) syntmp-mod-763) (if (memq syntmp-m-741 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c) (quote (load)) syntmp-mod-763) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) syntmp-mod-763) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-779) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any each-any any . each-any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (define-syntax-form))) (let ((syntmp-n-788 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761)) (syntmp-r-789 (syntmp-macros-only-env-100 syntmp-r-739))) (let ((syntmp-t-790 syntmp-m-741)) (if (memv syntmp-t-790 (quote (c))) (if (memq (quote compile) syntmp-esew-742) (let ((syntmp-e-791 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-791 syntmp-mod-763) (if (memq (quote load) syntmp-esew-742) syntmp-e-791 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-742) (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) (syntmp-chi-void-148))) (if (memv syntmp-t-790 (quote (c&e))) (let ((syntmp-e-792 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-792 syntmp-mod-763) syntmp-e-792)) (begin (if (memq (quote eval) syntmp-esew-742) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) syntmp-mod-763)) (syntmp-chi-void-148)))))) (if (memv syntmp-t-764 (quote (define-form))) (let ((syntmp-n-793 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761))) (let ((syntmp-type-794 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-793 syntmp-r-739 syntmp-mod-763)))) (let ((syntmp-t-795 syntmp-type-794)) (if (memv syntmp-t-795 (quote (global))) (let ((syntmp-x-796 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-796 syntmp-mod-763)) syntmp-x-796)) (if (memv syntmp-t-795 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "identifier out of context") (if (eq? syntmp-type-794 (quote external-macro)) (let ((syntmp-x-797 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-797 syntmp-mod-763)) syntmp-x-797)) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "cannot define keyword at top level"))))))) (let ((syntmp-x-798 (syntmp-chi-expr-141 syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-798 syntmp-mod-763)) syntmp-x-798)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (cond ((symbol? syntmp-e-799) (let ((syntmp-n-805 (syntmp-id-var-name-126 syntmp-e-799 syntmp-w-801))) (let ((syntmp-b-806 (syntmp-lookup-101 syntmp-n-805 syntmp-r-800 syntmp-mod-804))) (let ((syntmp-type-807 (syntmp-binding-type-96 syntmp-b-806))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (lexical))) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (global))) (values syntmp-type-807 syntmp-n-805 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))))))) ((pair? syntmp-e-799) (let ((syntmp-first-809 (car syntmp-e-799))) (if (syntmp-id?-104 syntmp-first-809) (let ((syntmp-n-810 (syntmp-id-var-name-126 syntmp-first-809 syntmp-w-801))) (let ((syntmp-b-811 (syntmp-lookup-101 syntmp-n-810 syntmp-r-800 (or (and (syntmp-syntax-object?-88 syntmp-first-809) (syntmp-syntax-object-module-91 syntmp-first-809)) syntmp-mod-804)))) (let ((syntmp-type-812 (syntmp-binding-type-96 syntmp-b-811))) (let ((syntmp-t-813 syntmp-type-812)) (if (memv syntmp-t-813 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (global))) (values (quote global-call) syntmp-n-810 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (if (memv syntmp-t-813 (quote (core external-macro module-ref))) (values syntmp-type-812 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (begin))) (values (quote begin-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (define))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-form) syntmp-name-820 syntmp-val-821 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-815) ((lambda (syntmp-tmp-822) (if (if syntmp-tmp-822 (apply (lambda (syntmp-_-823 syntmp-name-824 syntmp-args-825 syntmp-e1-826 syntmp-e2-827) (and (syntmp-id?-104 syntmp-name-824) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-825)))) syntmp-tmp-822) #f) (apply (lambda (syntmp-_-828 syntmp-name-829 syntmp-args-830 syntmp-e1-831 syntmp-e2-832) (values (quote define-form) (syntmp-wrap-132 syntmp-name-829 syntmp-w-801 syntmp-mod-804) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-132 (cons syntmp-args-830 (cons syntmp-e1-831 syntmp-e2-832)) syntmp-w-801 syntmp-mod-804)) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-822) ((lambda (syntmp-tmp-834) (if (if syntmp-tmp-834 (apply (lambda (syntmp-_-835 syntmp-name-836) (syntmp-id?-104 syntmp-name-836)) syntmp-tmp-834) #f) (apply (lambda (syntmp-_-837 syntmp-name-838) (values (quote define-form) (syntmp-wrap-132 syntmp-name-838 syntmp-w-801 syntmp-mod-804) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-834) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-799) (if (memv syntmp-t-813 (quote (define-syntax))) ((lambda (syntmp-tmp-839) ((lambda (syntmp-tmp-840) (if (if syntmp-tmp-840 (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-val-843) (syntmp-id?-104 syntmp-name-842)) syntmp-tmp-840) #f) (apply (lambda (syntmp-_-844 syntmp-name-845 syntmp-val-846) (values (quote define-syntax-form) syntmp-name-845 syntmp-val-846 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-840) (syntax-error syntmp-tmp-839))) (syntax-dispatch syntmp-tmp-839 (quote (any any any))))) syntmp-e-799) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))))))))))))) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))) ((syntmp-syntax-object?-88 syntmp-e-799) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-799) syntmp-r-800 (syntmp-join-wraps-123 syntmp-w-801 (syntmp-syntax-object-wrap-90 syntmp-e-799)) #f syntmp-rib-803 (or (syntmp-syntax-object-module-91 syntmp-e-799) syntmp-mod-804))) ((annotation? syntmp-e-799) (syntmp-syntax-type-138 (annotation-expression syntmp-e-799) syntmp-r-800 syntmp-w-801 (annotation-source syntmp-e-799) syntmp-rib-803 syntmp-mod-804)) ((self-evaluating? syntmp-e-799) (values (quote constant) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) (else (values (quote other) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-847 syntmp-when-list-848 syntmp-w-849) (let syntmp-f-850 ((syntmp-when-list-851 syntmp-when-list-848) (syntmp-situations-852 (quote ()))) (if (null? syntmp-when-list-851) syntmp-situations-852 (syntmp-f-850 (cdr syntmp-when-list-851) (cons (let ((syntmp-x-853 (car syntmp-when-list-851))) (cond ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-853 syntmp-w-849 #f) "invalid eval-when situation")))) syntmp-situations-852)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-854 syntmp-e-855) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-854) syntmp-e-855)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-856 syntmp-r-857 syntmp-w-858 syntmp-s-859 syntmp-m-860 syntmp-esew-861 syntmp-mod-862) (syntmp-build-sequence-83 syntmp-s-859 (let syntmp-dobody-863 ((syntmp-body-864 syntmp-body-856) (syntmp-r-865 syntmp-r-857) (syntmp-w-866 syntmp-w-858) (syntmp-m-867 syntmp-m-860) (syntmp-esew-868 syntmp-esew-861) (syntmp-mod-869 syntmp-mod-862)) (if (null? syntmp-body-864) (quote ()) (let ((syntmp-first-870 (syntmp-chi-top-139 (car syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869))) (cons syntmp-first-870 (syntmp-dobody-863 (cdr syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873 syntmp-s-874 syntmp-mod-875) (syntmp-build-sequence-83 syntmp-s-874 (let syntmp-dobody-876 ((syntmp-body-877 syntmp-body-871) (syntmp-r-878 syntmp-r-872) (syntmp-w-879 syntmp-w-873) (syntmp-mod-880 syntmp-mod-875)) (if (null? syntmp-body-877) (quote ()) (let ((syntmp-first-881 (syntmp-chi-140 (car syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880))) (cons syntmp-first-881 (syntmp-dobody-876 (cdr syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-882 syntmp-w-883 syntmp-s-884 syntmp-defmod-885) (syntmp-wrap-132 (if syntmp-s-884 (make-annotation syntmp-x-882 syntmp-s-884 #f) syntmp-x-882) syntmp-w-883 syntmp-defmod-885))) (syntmp-wrap-132 (lambda (syntmp-x-886 syntmp-w-887 syntmp-defmod-888) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-887)) (null? (syntmp-wrap-subst-108 syntmp-w-887))) syntmp-x-886) ((syntmp-syntax-object?-88 syntmp-x-886) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-886) (syntmp-join-wraps-123 syntmp-w-887 (syntmp-syntax-object-wrap-90 syntmp-x-886)) (syntmp-syntax-object-module-91 syntmp-x-886))) ((null? syntmp-x-886) syntmp-x-886) (else (syntmp-make-syntax-object-87 syntmp-x-886 syntmp-w-887 syntmp-defmod-888))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-889 syntmp-list-890) (and (not (null? syntmp-list-890)) (or (syntmp-bound-id=?-128 syntmp-x-889 (car syntmp-list-890)) (syntmp-bound-id-member?-131 syntmp-x-889 (cdr syntmp-list-890)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-891) (let syntmp-distinct?-892 ((syntmp-ids-893 syntmp-ids-891)) (or (null? syntmp-ids-893) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-893) (cdr syntmp-ids-893))) (syntmp-distinct?-892 (cdr syntmp-ids-893))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-894) (and (let syntmp-all-ids?-895 ((syntmp-ids-896 syntmp-ids-894)) (or (null? syntmp-ids-896) (and (syntmp-id?-104 (car syntmp-ids-896)) (syntmp-all-ids?-895 (cdr syntmp-ids-896))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-894)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-897 syntmp-j-898) (if (and (syntmp-syntax-object?-88 syntmp-i-897) (syntmp-syntax-object?-88 syntmp-j-898)) (and (eq? (let ((syntmp-e-899 (syntmp-syntax-object-expression-89 syntmp-i-897))) (if (annotation? syntmp-e-899) (annotation-expression syntmp-e-899) syntmp-e-899)) (let ((syntmp-e-900 (syntmp-syntax-object-expression-89 syntmp-j-898))) (if (annotation? syntmp-e-900) (annotation-expression syntmp-e-900) syntmp-e-900))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-897)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-898)))) (eq? (let ((syntmp-e-901 syntmp-i-897)) (if (annotation? syntmp-e-901) (annotation-expression syntmp-e-901) syntmp-e-901)) (let ((syntmp-e-902 syntmp-j-898)) (if (annotation? syntmp-e-902) (annotation-expression syntmp-e-902) syntmp-e-902)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-903 syntmp-j-904) (and (eq? (let ((syntmp-x-905 syntmp-i-903)) (let ((syntmp-e-906 (if (syntmp-syntax-object?-88 syntmp-x-905) (syntmp-syntax-object-expression-89 syntmp-x-905) syntmp-x-905))) (if (annotation? syntmp-e-906) (annotation-expression syntmp-e-906) syntmp-e-906))) (let ((syntmp-x-907 syntmp-j-904)) (let ((syntmp-e-908 (if (syntmp-syntax-object?-88 syntmp-x-907) (syntmp-syntax-object-expression-89 syntmp-x-907) syntmp-x-907))) (if (annotation? syntmp-e-908) (annotation-expression syntmp-e-908) syntmp-e-908)))) (eq? (syntmp-id-var-name-126 syntmp-i-903 (quote (()))) (syntmp-id-var-name-126 syntmp-j-904 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-909 syntmp-w-910) (letrec ((syntmp-search-vector-rib-913 (lambda (syntmp-sym-924 syntmp-subst-925 syntmp-marks-926 syntmp-symnames-927 syntmp-ribcage-928) (let ((syntmp-n-929 (vector-length syntmp-symnames-927))) (let syntmp-f-930 ((syntmp-i-931 0)) (cond ((syntmp-fx=-74 syntmp-i-931 syntmp-n-929) (syntmp-search-911 syntmp-sym-924 (cdr syntmp-subst-925) syntmp-marks-926)) ((and (eq? (vector-ref syntmp-symnames-927 syntmp-i-931) syntmp-sym-924) (syntmp-same-marks?-125 syntmp-marks-926 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-928) syntmp-i-931))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-928) syntmp-i-931) syntmp-marks-926)) (else (syntmp-f-930 (syntmp-fx+-72 syntmp-i-931 1)))))))) (syntmp-search-list-rib-912 (lambda (syntmp-sym-932 syntmp-subst-933 syntmp-marks-934 syntmp-symnames-935 syntmp-ribcage-936) (let syntmp-f-937 ((syntmp-symnames-938 syntmp-symnames-935) (syntmp-i-939 0)) (cond ((null? syntmp-symnames-938) (syntmp-search-911 syntmp-sym-932 (cdr syntmp-subst-933) syntmp-marks-934)) ((and (eq? (car syntmp-symnames-938) syntmp-sym-932) (syntmp-same-marks?-125 syntmp-marks-934 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-936) syntmp-i-939))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-936) syntmp-i-939) syntmp-marks-934)) (else (syntmp-f-937 (cdr syntmp-symnames-938) (syntmp-fx+-72 syntmp-i-939 1))))))) (syntmp-search-911 (lambda (syntmp-sym-940 syntmp-subst-941 syntmp-marks-942) (if (null? syntmp-subst-941) (values #f syntmp-marks-942) (let ((syntmp-fst-943 (car syntmp-subst-941))) (if (eq? syntmp-fst-943 (quote shift)) (syntmp-search-911 syntmp-sym-940 (cdr syntmp-subst-941) (cdr syntmp-marks-942)) (let ((syntmp-symnames-944 (syntmp-ribcage-symnames-113 syntmp-fst-943))) (if (vector? syntmp-symnames-944) (syntmp-search-vector-rib-913 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943) (syntmp-search-list-rib-912 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943))))))))) (cond ((symbol? syntmp-id-909) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-909 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-946 . syntmp-ignore-945) syntmp-x-946)) syntmp-id-909)) ((syntmp-syntax-object?-88 syntmp-id-909) (let ((syntmp-id-947 (let ((syntmp-e-949 (syntmp-syntax-object-expression-89 syntmp-id-909))) (if (annotation? syntmp-e-949) (annotation-expression syntmp-e-949) syntmp-e-949))) (syntmp-w1-948 (syntmp-syntax-object-wrap-90 syntmp-id-909))) (let ((syntmp-marks-950 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w1-948)))) (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w-910) syntmp-marks-950)) (lambda (syntmp-new-id-951 syntmp-marks-952) (or syntmp-new-id-951 (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w1-948) syntmp-marks-952)) (lambda (syntmp-x-954 . syntmp-ignore-953) syntmp-x-954)) syntmp-id-947)))))) ((annotation? syntmp-id-909) (let ((syntmp-id-955 (let ((syntmp-e-956 syntmp-id-909)) (if (annotation? syntmp-e-956) (annotation-expression syntmp-e-956) syntmp-e-956)))) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-955 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-958 . syntmp-ignore-957) syntmp-x-958)) syntmp-id-955))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-909)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-959 syntmp-y-960) (or (eq? syntmp-x-959 syntmp-y-960) (and (not (null? syntmp-x-959)) (not (null? syntmp-y-960)) (eq? (car syntmp-x-959) (car syntmp-y-960)) (syntmp-same-marks?-125 (cdr syntmp-x-959) (cdr syntmp-y-960)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-961 syntmp-m2-962) (syntmp-smart-append-122 syntmp-m1-961 syntmp-m2-962))) (syntmp-join-wraps-123 (lambda (syntmp-w1-963 syntmp-w2-964) (let ((syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w1-963)) (syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w1-963))) (if (null? syntmp-m1-965) (if (null? syntmp-s1-966) syntmp-w2-964 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-964) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w2-964)) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-967 syntmp-m2-968) (if (null? syntmp-m2-968) syntmp-m1-967 (append syntmp-m1-967 syntmp-m2-968)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-969 syntmp-labels-970 syntmp-w-971) (if (null? syntmp-ids-969) syntmp-w-971 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-971) (cons (let ((syntmp-labelvec-972 (list->vector syntmp-labels-970))) (let ((syntmp-n-973 (vector-length syntmp-labelvec-972))) (let ((syntmp-symnamevec-974 (make-vector syntmp-n-973)) (syntmp-marksvec-975 (make-vector syntmp-n-973))) (begin (let syntmp-f-976 ((syntmp-ids-977 syntmp-ids-969) (syntmp-i-978 0)) (if (not (null? syntmp-ids-977)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-977) syntmp-w-971)) (lambda (syntmp-symname-979 syntmp-marks-980) (begin (vector-set! syntmp-symnamevec-974 syntmp-i-978 syntmp-symname-979) (vector-set! syntmp-marksvec-975 syntmp-i-978 syntmp-marks-980) (syntmp-f-976 (cdr syntmp-ids-977) (syntmp-fx+-72 syntmp-i-978 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-974 syntmp-marksvec-975 syntmp-labelvec-972))))) (syntmp-wrap-subst-108 syntmp-w-971)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-981 syntmp-id-982 syntmp-label-983) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-981 (cons (let ((syntmp-e-984 (syntmp-syntax-object-expression-89 syntmp-id-982))) (if (annotation? syntmp-e-984) (annotation-expression syntmp-e-984) syntmp-e-984)) (syntmp-ribcage-symnames-113 syntmp-ribcage-981))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-981 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-982)) (syntmp-ribcage-marks-114 syntmp-ribcage-981))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-981 (cons syntmp-label-983 (syntmp-ribcage-labels-115 syntmp-ribcage-981)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-985) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-985)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-985))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-986 syntmp-update-987) (vector-set! syntmp-x-986 3 syntmp-update-987))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-988 syntmp-update-989) (vector-set! syntmp-x-988 2 syntmp-update-989))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-990 syntmp-update-991) (vector-set! syntmp-x-990 1 syntmp-update-991))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-992) (vector-ref syntmp-x-992 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 4) (eq? (vector-ref syntmp-x-995 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998) (vector (quote ribcage) syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998))) (syntmp-gen-labels-110 (lambda (syntmp-ls-999) (if (null? syntmp-ls-999) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-999)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-1000 syntmp-w-1001) (if (syntmp-syntax-object?-88 syntmp-x-1000) (values (let ((syntmp-e-1002 (syntmp-syntax-object-expression-89 syntmp-x-1000))) (if (annotation? syntmp-e-1002) (annotation-expression syntmp-e-1002) syntmp-e-1002)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-1001) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-1000)))) (values (let ((syntmp-e-1003 syntmp-x-1000)) (if (annotation? syntmp-e-1003) (annotation-expression syntmp-e-1003) syntmp-e-1003)) (syntmp-wrap-marks-107 syntmp-w-1001))))) (syntmp-id?-104 (lambda (syntmp-x-1004) (cond ((symbol? syntmp-x-1004) #t) ((syntmp-syntax-object?-88 syntmp-x-1004) (symbol? (let ((syntmp-e-1005 (syntmp-syntax-object-expression-89 syntmp-x-1004))) (if (annotation? syntmp-e-1005) (annotation-expression syntmp-e-1005) syntmp-e-1005)))) ((annotation? syntmp-x-1004) (symbol? (annotation-expression syntmp-x-1004))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-1006) (and (syntmp-syntax-object?-88 syntmp-x-1006) (symbol? (let ((syntmp-e-1007 (syntmp-syntax-object-expression-89 syntmp-x-1006))) (if (annotation? syntmp-e-1007) (annotation-expression syntmp-e-1007) syntmp-e-1007)))))) (syntmp-global-extend-102 (lambda (syntmp-type-1008 syntmp-sym-1009 syntmp-val-1010) (syntmp-put-global-definition-hook-79 syntmp-sym-1009 (cons syntmp-type-1008 syntmp-val-1010) (module-name (current-module))))) (syntmp-lookup-101 (lambda (syntmp-x-1011 syntmp-r-1012 syntmp-mod-1013) (cond ((assq syntmp-x-1011 syntmp-r-1012) => cdr) ((symbol? syntmp-x-1011) (or (syntmp-get-global-definition-hook-80 syntmp-x-1011 syntmp-mod-1013) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-1014) (if (null? syntmp-r-1014) (quote ()) (let ((syntmp-a-1015 (car syntmp-r-1014))) (if (eq? (cadr syntmp-a-1015) (quote macro)) (cons syntmp-a-1015 (syntmp-macros-only-env-100 (cdr syntmp-r-1014))) (syntmp-macros-only-env-100 (cdr syntmp-r-1014))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-1016 syntmp-vars-1017 syntmp-r-1018) (if (null? syntmp-labels-1016) syntmp-r-1018 (syntmp-extend-var-env-99 (cdr syntmp-labels-1016) (cdr syntmp-vars-1017) (cons (cons (car syntmp-labels-1016) (cons (quote lexical) (car syntmp-vars-1017))) syntmp-r-1018))))) (syntmp-extend-env-98 (lambda (syntmp-labels-1019 syntmp-bindings-1020 syntmp-r-1021) (if (null? syntmp-labels-1019) syntmp-r-1021 (syntmp-extend-env-98 (cdr syntmp-labels-1019) (cdr syntmp-bindings-1020) (cons (cons (car syntmp-labels-1019) (car syntmp-bindings-1020)) syntmp-r-1021))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-1022) (cond ((annotation? syntmp-x-1022) (annotation-source syntmp-x-1022)) ((syntmp-syntax-object?-88 syntmp-x-1022) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-1022))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-1023 syntmp-update-1024) (vector-set! syntmp-x-1023 3 syntmp-update-1024))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-1025 syntmp-update-1026) (vector-set! syntmp-x-1025 2 syntmp-update-1026))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-1027 syntmp-update-1028) (vector-set! syntmp-x-1027 1 syntmp-update-1028))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-1029) (vector-ref syntmp-x-1029 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-1030) (vector-ref syntmp-x-1030 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-1031) (vector-ref syntmp-x-1031 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1032) (and (vector? syntmp-x-1032) (= (vector-length syntmp-x-1032) 4) (eq? (vector-ref syntmp-x-1032 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035) (vector (quote syntax-object) syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035))) (syntmp-build-letrec-86 (lambda (syntmp-src-1036 syntmp-vars-1037 syntmp-val-exps-1038 syntmp-body-exp-1039) (if (null? syntmp-vars-1037) (syntmp-build-annotated-81 syntmp-src-1036 syntmp-body-exp-1039) (syntmp-build-annotated-81 syntmp-src-1036 (list (quote letrec) (map list syntmp-vars-1037 syntmp-val-exps-1038) syntmp-body-exp-1039))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1040 syntmp-vars-1041 syntmp-val-exps-1042 syntmp-body-exp-1043) (if (null? syntmp-vars-1041) (syntmp-build-annotated-81 syntmp-src-1040 syntmp-body-exp-1043) (syntmp-build-annotated-81 syntmp-src-1040 (list (quote let) (car syntmp-vars-1041) (map list (cdr syntmp-vars-1041) syntmp-val-exps-1042) syntmp-body-exp-1043))))) (syntmp-build-let-84 (lambda (syntmp-src-1044 syntmp-vars-1045 syntmp-val-exps-1046 syntmp-body-exp-1047) (if (null? syntmp-vars-1045) (syntmp-build-annotated-81 syntmp-src-1044 syntmp-body-exp-1047) (syntmp-build-annotated-81 syntmp-src-1044 (list (quote let) (map list syntmp-vars-1045 syntmp-val-exps-1046) syntmp-body-exp-1047))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1048 syntmp-exps-1049) (if (null? (cdr syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (car syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (cons (quote begin) syntmp-exps-1049))))) (syntmp-build-data-82 (lambda (syntmp-src-1050 syntmp-exp-1051) (if (and (self-evaluating? syntmp-exp-1051) (not (vector? syntmp-exp-1051))) (syntmp-build-annotated-81 syntmp-src-1050 syntmp-exp-1051) (syntmp-build-annotated-81 syntmp-src-1050 (list (quote quote) syntmp-exp-1051))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1052 syntmp-exp-1053) (if (and syntmp-src-1052 (not (annotation? syntmp-exp-1053))) (make-annotation syntmp-exp-1053 syntmp-src-1052 #t) syntmp-exp-1053))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1054 syntmp-module-1055) (let ((syntmp-module-1056 (if syntmp-module-1055 (resolve-module syntmp-module-1055) (warn "wha" syntmp-symbol-1054 (current-module))))) (let ((syntmp-v-1057 (module-variable syntmp-module-1056 syntmp-symbol-1054))) (and syntmp-v-1057 (or (object-property syntmp-v-1057 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1057) (macro? (variable-ref syntmp-v-1057)) (macro-transformer (variable-ref syntmp-v-1057)) guile-macro))))))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1058 syntmp-binding-1059 syntmp-module-1060) (let ((syntmp-module-1061 (if syntmp-module-1060 (resolve-module syntmp-module-1060) (warn "wha" syntmp-symbol-1058 (current-module))))) (let ((syntmp-v-1062 (or (module-variable syntmp-module-1061 syntmp-symbol-1058) (let ((syntmp-v-1063 (make-variable sc-macro))) (begin (module-add! syntmp-module-1061 syntmp-symbol-1058 syntmp-v-1063) syntmp-v-1063))))) (begin (if (not (and (symbol-property syntmp-symbol-1058 (quote primitive-syntax)) (eq? syntmp-module-1061 the-syncase-module))) (variable-set! syntmp-v-1062 sc-macro)) (set-object-property! syntmp-v-1062 (quote *sc-expander*) syntmp-binding-1059)))))) (syntmp-error-hook-78 (lambda (syntmp-who-1064 syntmp-why-1065 syntmp-what-1066) (error syntmp-who-1064 "~a ~s" syntmp-why-1065 syntmp-what-1066))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1067 syntmp-mod-1068) (eval (list syntmp-noexpand-71 syntmp-x-1067) (if syntmp-mod-1068 (resolve-module syntmp-mod-1068) (interaction-environment))))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1069 syntmp-mod-1070) (eval (list syntmp-noexpand-71 syntmp-x-1069) (if syntmp-mod-1070 (resolve-module syntmp-mod-1070) (interaction-environment))))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1071 syntmp-r-1072 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) ((lambda (syntmp-tmp-1076) ((lambda (syntmp-tmp-1077) (if (if syntmp-tmp-1077 (apply (lambda (syntmp-_-1078 syntmp-var-1079 syntmp-val-1080 syntmp-e1-1081 syntmp-e2-1082) (syntmp-valid-bound-ids?-129 syntmp-var-1079)) syntmp-tmp-1077) #f) (apply (lambda (syntmp-_-1084 syntmp-var-1085 syntmp-val-1086 syntmp-e1-1087 syntmp-e2-1088) (let ((syntmp-names-1089 (map (lambda (syntmp-x-1090) (syntmp-id-var-name-126 syntmp-x-1090 syntmp-w-1073)) syntmp-var-1085))) (begin (for-each (lambda (syntmp-id-1092 syntmp-n-1093) (let ((syntmp-t-1094 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1093 syntmp-r-1072 syntmp-mod-1075)))) (if (memv syntmp-t-1094 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1092 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) "identifier out of context")))) syntmp-var-1085 syntmp-names-1089) (syntmp-chi-body-144 (cons syntmp-e1-1087 syntmp-e2-1088) (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) (syntmp-extend-env-98 syntmp-names-1089 (let ((syntmp-trans-r-1097 (syntmp-macros-only-env-100 syntmp-r-1072))) (map (lambda (syntmp-x-1098) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1098 syntmp-trans-r-1097 syntmp-w-1073 syntmp-mod-1075) syntmp-mod-1075))) syntmp-val-1086)) syntmp-r-1072) syntmp-w-1073 syntmp-mod-1075)))) syntmp-tmp-1077) ((lambda (syntmp-_-1100) (syntax-error (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075))) syntmp-tmp-1076))) (syntax-dispatch syntmp-tmp-1076 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1071))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1101 syntmp-r-1102 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105) ((lambda (syntmp-tmp-1106) ((lambda (syntmp-tmp-1107) (if syntmp-tmp-1107 (apply (lambda (syntmp-_-1108 syntmp-e-1109) (syntmp-build-data-82 syntmp-s-1104 (syntmp-strip-151 syntmp-e-1109 syntmp-w-1103))) syntmp-tmp-1107) ((lambda (syntmp-_-1110) (syntax-error (syntmp-source-wrap-133 syntmp-e-1101 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105))) syntmp-tmp-1106))) (syntax-dispatch syntmp-tmp-1106 (quote (any any))))) syntmp-e-1101))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1118 (lambda (syntmp-x-1119) (let ((syntmp-t-1120 (car syntmp-x-1119))) (if (memv syntmp-t-1120 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1119) (syntmp-regen-1118 (caddr syntmp-x-1119)))) (if (memv syntmp-t-1120 (quote (map))) (let ((syntmp-ls-1121 (map syntmp-regen-1118 (cdr syntmp-x-1119)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1121) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1121))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1119)) (map syntmp-regen-1118 (cdr syntmp-x-1119)))))))))))) (syntmp-gen-vector-1117 (lambda (syntmp-x-1122) (cond ((eq? (car syntmp-x-1122) (quote list)) (cons (quote vector) (cdr syntmp-x-1122))) ((eq? (car syntmp-x-1122) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1122)))) (else (list (quote list->vector) syntmp-x-1122))))) (syntmp-gen-append-1116 (lambda (syntmp-x-1123 syntmp-y-1124) (if (equal? syntmp-y-1124 (quote (quote ()))) syntmp-x-1123 (list (quote append) syntmp-x-1123 syntmp-y-1124)))) (syntmp-gen-cons-1115 (lambda (syntmp-x-1125 syntmp-y-1126) (let ((syntmp-t-1127 (car syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (quote))) (if (eq? (car syntmp-x-1125) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1125) (cadr syntmp-y-1126))) (if (eq? (cadr syntmp-y-1126) (quote ())) (list (quote list) syntmp-x-1125) (list (quote cons) syntmp-x-1125 syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (list))) (cons (quote list) (cons syntmp-x-1125 (cdr syntmp-y-1126))) (list (quote cons) syntmp-x-1125 syntmp-y-1126)))))) (syntmp-gen-map-1114 (lambda (syntmp-e-1128 syntmp-map-env-1129) (let ((syntmp-formals-1130 (map cdr syntmp-map-env-1129)) (syntmp-actuals-1131 (map (lambda (syntmp-x-1132) (list (quote ref) (car syntmp-x-1132))) syntmp-map-env-1129))) (cond ((eq? (car syntmp-e-1128) (quote ref)) (car syntmp-actuals-1131)) ((andmap (lambda (syntmp-x-1133) (and (eq? (car syntmp-x-1133) (quote ref)) (memq (cadr syntmp-x-1133) syntmp-formals-1130))) (cdr syntmp-e-1128)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1128)) (map (let ((syntmp-r-1134 (map cons syntmp-formals-1130 syntmp-actuals-1131))) (lambda (syntmp-x-1135) (cdr (assq (cadr syntmp-x-1135) syntmp-r-1134)))) (cdr syntmp-e-1128))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1130 syntmp-e-1128) syntmp-actuals-1131))))))) (syntmp-gen-mappend-1113 (lambda (syntmp-e-1136 syntmp-map-env-1137) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1114 syntmp-e-1136 syntmp-map-env-1137)))) (syntmp-gen-ref-1112 (lambda (syntmp-src-1138 syntmp-var-1139 syntmp-level-1140 syntmp-maps-1141) (if (syntmp-fx=-74 syntmp-level-1140 0) (values syntmp-var-1139 syntmp-maps-1141) (if (null? syntmp-maps-1141) (syntax-error syntmp-src-1138 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1112 syntmp-src-1138 syntmp-var-1139 (syntmp-fx--73 syntmp-level-1140 1) (cdr syntmp-maps-1141))) (lambda (syntmp-outer-var-1142 syntmp-outer-maps-1143) (let ((syntmp-b-1144 (assq syntmp-outer-var-1142 (car syntmp-maps-1141)))) (if syntmp-b-1144 (values (cdr syntmp-b-1144) syntmp-maps-1141) (let ((syntmp-inner-var-1145 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1145 (cons (cons (cons syntmp-outer-var-1142 syntmp-inner-var-1145) (car syntmp-maps-1141)) syntmp-outer-maps-1143))))))))))) (syntmp-gen-syntax-1111 (lambda (syntmp-src-1146 syntmp-e-1147 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151) (if (syntmp-id?-104 syntmp-e-1147) (let ((syntmp-label-1152 (syntmp-id-var-name-126 syntmp-e-1147 (quote (()))))) (let ((syntmp-b-1153 (syntmp-lookup-101 syntmp-label-1152 syntmp-r-1148 syntmp-mod-1151))) (if (eq? (syntmp-binding-type-96 syntmp-b-1153) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1154 (syntmp-binding-value-97 syntmp-b-1153))) (syntmp-gen-ref-1112 syntmp-src-1146 (car syntmp-var.lev-1154) (cdr syntmp-var.lev-1154) syntmp-maps-1149))) (lambda (syntmp-var-1155 syntmp-maps-1156) (values (list (quote ref) syntmp-var-1155) syntmp-maps-1156))) (if (syntmp-ellipsis?-1150 syntmp-e-1147) (syntax-error syntmp-src-1146 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149))))) ((lambda (syntmp-tmp-1157) ((lambda (syntmp-tmp-1158) (if (if syntmp-tmp-1158 (apply (lambda (syntmp-dots-1159 syntmp-e-1160) (syntmp-ellipsis?-1150 syntmp-dots-1159)) syntmp-tmp-1158) #f) (apply (lambda (syntmp-dots-1161 syntmp-e-1162) (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-e-1162 syntmp-r-1148 syntmp-maps-1149 (lambda (syntmp-x-1163) #f) syntmp-mod-1151)) syntmp-tmp-1158) ((lambda (syntmp-tmp-1164) (if (if syntmp-tmp-1164 (apply (lambda (syntmp-x-1165 syntmp-dots-1166 syntmp-y-1167) (syntmp-ellipsis?-1150 syntmp-dots-1166)) syntmp-tmp-1164) #f) (apply (lambda (syntmp-x-1168 syntmp-dots-1169 syntmp-y-1170) (let syntmp-f-1171 ((syntmp-y-1172 syntmp-y-1170) (syntmp-k-1173 (lambda (syntmp-maps-1174) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1168 syntmp-r-1148 (cons (quote ()) syntmp-maps-1174) syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1175 syntmp-maps-1176) (if (null? (car syntmp-maps-1176)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-map-1114 syntmp-x-1175 (car syntmp-maps-1176)) (cdr syntmp-maps-1176)))))))) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if (if syntmp-tmp-1178 (apply (lambda (syntmp-dots-1179 syntmp-y-1180) (syntmp-ellipsis?-1150 syntmp-dots-1179)) syntmp-tmp-1178) #f) (apply (lambda (syntmp-dots-1181 syntmp-y-1182) (syntmp-f-1171 syntmp-y-1182 (lambda (syntmp-maps-1183) (call-with-values (lambda () (syntmp-k-1173 (cons (quote ()) syntmp-maps-1183))) (lambda (syntmp-x-1184 syntmp-maps-1185) (if (null? (car syntmp-maps-1185)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1113 syntmp-x-1184 (car syntmp-maps-1185)) (cdr syntmp-maps-1185)))))))) syntmp-tmp-1178) ((lambda (syntmp-_-1186) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1172 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1187 syntmp-maps-1188) (call-with-values (lambda () (syntmp-k-1173 syntmp-maps-1188)) (lambda (syntmp-x-1189 syntmp-maps-1190) (values (syntmp-gen-append-1116 syntmp-x-1189 syntmp-y-1187) syntmp-maps-1190)))))) syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-y-1172))) syntmp-tmp-1164) ((lambda (syntmp-tmp-1191) (if syntmp-tmp-1191 (apply (lambda (syntmp-x-1192 syntmp-y-1193) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1192 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1194 syntmp-maps-1195) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1193 syntmp-r-1148 syntmp-maps-1195 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1196 syntmp-maps-1197) (values (syntmp-gen-cons-1115 syntmp-x-1194 syntmp-y-1196) syntmp-maps-1197)))))) syntmp-tmp-1191) ((lambda (syntmp-tmp-1198) (if syntmp-tmp-1198 (apply (lambda (syntmp-e1-1199 syntmp-e2-1200) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 (cons syntmp-e1-1199 syntmp-e2-1200) syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-e-1202 syntmp-maps-1203) (values (syntmp-gen-vector-1117 syntmp-e-1202) syntmp-maps-1203)))) syntmp-tmp-1198) ((lambda (syntmp-_-1204) (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149)) syntmp-tmp-1157))) (syntax-dispatch syntmp-tmp-1157 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1157 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any))))) syntmp-e-1147))))) (lambda (syntmp-e-1205 syntmp-r-1206 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209) (let ((syntmp-e-1210 (syntmp-source-wrap-133 syntmp-e-1205 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209))) ((lambda (syntmp-tmp-1211) ((lambda (syntmp-tmp-1212) (if syntmp-tmp-1212 (apply (lambda (syntmp-_-1213 syntmp-x-1214) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-e-1210 syntmp-x-1214 syntmp-r-1206 (quote ()) syntmp-ellipsis?-149 syntmp-mod-1209)) (lambda (syntmp-e-1215 syntmp-maps-1216) (syntmp-regen-1118 syntmp-e-1215)))) syntmp-tmp-1212) ((lambda (syntmp-_-1217) (syntax-error syntmp-e-1210)) syntmp-tmp-1211))) (syntax-dispatch syntmp-tmp-1211 (quote (any any))))) syntmp-e-1210))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1218 syntmp-r-1219 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) ((lambda (syntmp-tmp-1223) ((lambda (syntmp-tmp-1224) (if syntmp-tmp-1224 (apply (lambda (syntmp-_-1225 syntmp-c-1226) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1218 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) syntmp-c-1226 syntmp-r-1219 syntmp-w-1220 syntmp-mod-1222 (lambda (syntmp-vars-1227 syntmp-body-1228) (syntmp-build-annotated-81 syntmp-s-1221 (list (quote lambda) syntmp-vars-1227 syntmp-body-1228))))) syntmp-tmp-1224) (syntax-error syntmp-tmp-1223))) (syntax-dispatch syntmp-tmp-1223 (quote (any . any))))) syntmp-e-1218))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1229 (lambda (syntmp-e-1230 syntmp-r-1231 syntmp-w-1232 syntmp-s-1233 syntmp-mod-1234 syntmp-constructor-1235 syntmp-ids-1236 syntmp-vals-1237 syntmp-exps-1238) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1236)) (syntax-error syntmp-e-1230 "duplicate bound variable in") (let ((syntmp-labels-1239 (syntmp-gen-labels-110 syntmp-ids-1236)) (syntmp-new-vars-1240 (map syntmp-gen-var-152 syntmp-ids-1236))) (let ((syntmp-nw-1241 (syntmp-make-binding-wrap-121 syntmp-ids-1236 syntmp-labels-1239 syntmp-w-1232)) (syntmp-nr-1242 (syntmp-extend-var-env-99 syntmp-labels-1239 syntmp-new-vars-1240 syntmp-r-1231))) (syntmp-constructor-1235 syntmp-s-1233 syntmp-new-vars-1240 (map (lambda (syntmp-x-1243) (syntmp-chi-140 syntmp-x-1243 syntmp-r-1231 syntmp-w-1232 syntmp-mod-1234)) syntmp-vals-1237) (syntmp-chi-body-144 syntmp-exps-1238 (syntmp-source-wrap-133 syntmp-e-1230 syntmp-nw-1241 syntmp-s-1233 syntmp-mod-1234) syntmp-nr-1242 syntmp-nw-1241 syntmp-mod-1234)))))))) (lambda (syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248) ((lambda (syntmp-tmp-1249) ((lambda (syntmp-tmp-1250) (if syntmp-tmp-1250 (apply (lambda (syntmp-_-1251 syntmp-id-1252 syntmp-val-1253 syntmp-e1-1254 syntmp-e2-1255) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-let-84 syntmp-id-1252 syntmp-val-1253 (cons syntmp-e1-1254 syntmp-e2-1255))) syntmp-tmp-1250) ((lambda (syntmp-tmp-1259) (if (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-f-1261 syntmp-id-1262 syntmp-val-1263 syntmp-e1-1264 syntmp-e2-1265) (syntmp-id?-104 syntmp-f-1261)) syntmp-tmp-1259) #f) (apply (lambda (syntmp-_-1266 syntmp-f-1267 syntmp-id-1268 syntmp-val-1269 syntmp-e1-1270 syntmp-e2-1271) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-named-let-85 (cons syntmp-f-1267 syntmp-id-1268) syntmp-val-1269 (cons syntmp-e1-1270 syntmp-e2-1271))) syntmp-tmp-1259) ((lambda (syntmp-_-1275) (syntax-error (syntmp-source-wrap-133 syntmp-e-1244 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248))) syntmp-tmp-1249))) (syntax-dispatch syntmp-tmp-1249 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1249 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1244)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1276 syntmp-r-1277 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-_-1283 syntmp-id-1284 syntmp-val-1285 syntmp-e1-1286 syntmp-e2-1287) (let ((syntmp-ids-1288 syntmp-id-1284)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1288)) (syntax-error syntmp-e-1276 "duplicate bound variable in") (let ((syntmp-labels-1290 (syntmp-gen-labels-110 syntmp-ids-1288)) (syntmp-new-vars-1291 (map syntmp-gen-var-152 syntmp-ids-1288))) (let ((syntmp-w-1292 (syntmp-make-binding-wrap-121 syntmp-ids-1288 syntmp-labels-1290 syntmp-w-1278)) (syntmp-r-1293 (syntmp-extend-var-env-99 syntmp-labels-1290 syntmp-new-vars-1291 syntmp-r-1277))) (syntmp-build-letrec-86 syntmp-s-1279 syntmp-new-vars-1291 (map (lambda (syntmp-x-1294) (syntmp-chi-140 syntmp-x-1294 syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280)) syntmp-val-1285) (syntmp-chi-body-144 (cons syntmp-e1-1286 syntmp-e2-1287) (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1292 syntmp-s-1279 syntmp-mod-1280) syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280))))))) syntmp-tmp-1282) ((lambda (syntmp-_-1297) (syntax-error (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280))) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1276))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1298 syntmp-r-1299 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302) ((lambda (syntmp-tmp-1303) ((lambda (syntmp-tmp-1304) (if (if syntmp-tmp-1304 (apply (lambda (syntmp-_-1305 syntmp-id-1306 syntmp-val-1307) (syntmp-id?-104 syntmp-id-1306)) syntmp-tmp-1304) #f) (apply (lambda (syntmp-_-1308 syntmp-id-1309 syntmp-val-1310) (let ((syntmp-val-1311 (syntmp-chi-140 syntmp-val-1310 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (syntmp-n-1312 (syntmp-id-var-name-126 syntmp-id-1309 syntmp-w-1300))) (let ((syntmp-b-1313 (syntmp-lookup-101 syntmp-n-1312 syntmp-r-1299 syntmp-mod-1302))) (let ((syntmp-t-1314 (syntmp-binding-type-96 syntmp-b-1313))) (if (memv syntmp-t-1314 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1313) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1302 syntmp-n-1312 #f) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1309 syntmp-w-1300 syntmp-mod-1302) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))))))))) syntmp-tmp-1304) ((lambda (syntmp-tmp-1315) (if syntmp-tmp-1315 (apply (lambda (syntmp-_-1316 syntmp-head-1317 syntmp-tail-1318 syntmp-val-1319) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-head-1317 syntmp-r-1299 (quote (())) #f #f syntmp-mod-1302)) (lambda (syntmp-type-1320 syntmp-value-1321 syntmp-ee-1322 syntmp-ww-1323 syntmp-ss-1324 syntmp-modmod-1325) (let ((syntmp-t-1326 syntmp-type-1320)) (if (memv syntmp-t-1326 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1321 (cons syntmp-head-1317 syntmp-tail-1318))) (lambda (syntmp-id-1328 syntmp-mod-1329) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1329 syntmp-id-1328 #f) syntmp-val-1319)))) (syntmp-build-annotated-81 syntmp-s-1301 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1317) syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302) (map (lambda (syntmp-e-1330) (syntmp-chi-140 syntmp-e-1330 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (append syntmp-tail-1318 (list syntmp-val-1319)))))))))) syntmp-tmp-1315) ((lambda (syntmp-_-1332) (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))) syntmp-tmp-1303))) (syntax-dispatch syntmp-tmp-1303 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1303 (quote (any any any))))) syntmp-e-1298))) (syntmp-global-extend-102 (quote module-ref) (quote @) (lambda (syntmp-e-1333) ((lambda (syntmp-tmp-1334) ((lambda (syntmp-tmp-1335) (if (if syntmp-tmp-1335 (apply (lambda (syntmp-_-1336 syntmp-mod-1337 syntmp-id-1338) (and (andmap syntmp-id?-104 syntmp-mod-1337) (syntmp-id?-104 syntmp-id-1338))) syntmp-tmp-1335) #f) (apply (lambda (syntmp-_-1340 syntmp-mod-1341 syntmp-id-1342) (values (syntax-object->datum syntmp-id-1342) (syntax-object->datum (append syntmp-mod-1341 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1335) (syntax-error syntmp-tmp-1334))) (syntax-dispatch syntmp-tmp-1334 (quote (any each-any any))))) syntmp-e-1333))) (syntmp-global-extend-102 (quote module-ref) (quote @@) (lambda (syntmp-e-1344) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-mod-1348 syntmp-id-1349) (and (andmap syntmp-id?-104 syntmp-mod-1348) (syntmp-id?-104 syntmp-id-1349))) syntmp-tmp-1346) #f) (apply (lambda (syntmp-_-1351 syntmp-mod-1352 syntmp-id-1353) (values (syntax-object->datum syntmp-id-1353) (syntax-object->datum syntmp-mod-1352))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any each-any any))))) syntmp-e-1344))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1358 (lambda (syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1363) (if (null? syntmp-clauses-1361) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1359)) ((lambda (syntmp-tmp-1364) ((lambda (syntmp-tmp-1365) (if syntmp-tmp-1365 (apply (lambda (syntmp-pat-1366 syntmp-exp-1367) (if (and (syntmp-id?-104 syntmp-pat-1366) (andmap (lambda (syntmp-x-1368) (not (syntmp-free-id=?-127 syntmp-pat-1366 syntmp-x-1368))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1360))) (let ((syntmp-labels-1369 (list (syntmp-gen-label-109))) (syntmp-var-1370 (syntmp-gen-var-152 syntmp-pat-1366))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1370) (syntmp-chi-140 syntmp-exp-1367 (syntmp-extend-env-98 syntmp-labels-1369 (list (cons (quote syntax) (cons syntmp-var-1370 0))) syntmp-r-1362) (syntmp-make-binding-wrap-121 (list syntmp-pat-1366) syntmp-labels-1369 (quote (()))) syntmp-mod-1363))) syntmp-x-1359))) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1366 #t syntmp-exp-1367 syntmp-mod-1363))) syntmp-tmp-1365) ((lambda (syntmp-tmp-1371) (if syntmp-tmp-1371 (apply (lambda (syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374 syntmp-mod-1363)) syntmp-tmp-1371) ((lambda (syntmp-_-1375) (syntax-error (car syntmp-clauses-1361) "invalid syntax-case clause")) syntmp-tmp-1364))) (syntax-dispatch syntmp-tmp-1364 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1364 (quote (any any))))) (car syntmp-clauses-1361))))) (syntmp-gen-clause-1357 (lambda (syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-pat-1380 syntmp-fender-1381 syntmp-exp-1382 syntmp-mod-1383) (call-with-values (lambda () (syntmp-convert-pattern-1355 syntmp-pat-1380 syntmp-keys-1377)) (lambda (syntmp-p-1384 syntmp-pvars-1385) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1385))) (syntax-error syntmp-pat-1380 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1386) (not (syntmp-ellipsis?-149 (car syntmp-x-1386)))) syntmp-pvars-1385)) (syntax-error syntmp-pat-1380 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1387 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1387) (let ((syntmp-y-1388 (syntmp-build-annotated-81 #f syntmp-y-1387))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1389) ((lambda (syntmp-tmp-1390) (if syntmp-tmp-1390 (apply (lambda () syntmp-y-1388) syntmp-tmp-1390) ((lambda (syntmp-_-1391) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1388 (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-fender-1381 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1389))) (syntax-dispatch syntmp-tmp-1389 (quote #(atom #t))))) syntmp-fender-1381) (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-exp-1382 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-gen-syntax-case-1358 syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-mod-1383)))))) (if (eq? syntmp-p-1384 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1376)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1376 (syntmp-build-data-82 #f syntmp-p-1384))))))))))))) (syntmp-build-dispatch-call-1356 (lambda (syntmp-pvars-1392 syntmp-exp-1393 syntmp-y-1394 syntmp-r-1395 syntmp-mod-1396) (let ((syntmp-ids-1397 (map car syntmp-pvars-1392)) (syntmp-levels-1398 (map cdr syntmp-pvars-1392))) (let ((syntmp-labels-1399 (syntmp-gen-labels-110 syntmp-ids-1397)) (syntmp-new-vars-1400 (map syntmp-gen-var-152 syntmp-ids-1397))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1400 (syntmp-chi-140 syntmp-exp-1393 (syntmp-extend-env-98 syntmp-labels-1399 (map (lambda (syntmp-var-1401 syntmp-level-1402) (cons (quote syntax) (cons syntmp-var-1401 syntmp-level-1402))) syntmp-new-vars-1400 (map cdr syntmp-pvars-1392)) syntmp-r-1395) (syntmp-make-binding-wrap-121 syntmp-ids-1397 syntmp-labels-1399 (quote (()))) syntmp-mod-1396))) syntmp-y-1394)))))) (syntmp-convert-pattern-1355 (lambda (syntmp-pattern-1403 syntmp-keys-1404) (let syntmp-cvt-1405 ((syntmp-p-1406 syntmp-pattern-1403) (syntmp-n-1407 0) (syntmp-ids-1408 (quote ()))) (if (syntmp-id?-104 syntmp-p-1406) (if (syntmp-bound-id-member?-131 syntmp-p-1406 syntmp-keys-1404) (values (vector (quote free-id) syntmp-p-1406) syntmp-ids-1408) (values (quote any) (cons (cons syntmp-p-1406 syntmp-n-1407) syntmp-ids-1408))) ((lambda (syntmp-tmp-1409) ((lambda (syntmp-tmp-1410) (if (if syntmp-tmp-1410 (apply (lambda (syntmp-x-1411 syntmp-dots-1412) (syntmp-ellipsis?-149 syntmp-dots-1412)) syntmp-tmp-1410) #f) (apply (lambda (syntmp-x-1413 syntmp-dots-1414) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1413 (syntmp-fx+-72 syntmp-n-1407 1) syntmp-ids-1408)) (lambda (syntmp-p-1415 syntmp-ids-1416) (values (if (eq? syntmp-p-1415 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1415)) syntmp-ids-1416)))) syntmp-tmp-1410) ((lambda (syntmp-tmp-1417) (if syntmp-tmp-1417 (apply (lambda (syntmp-x-1418 syntmp-y-1419) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-y-1419 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-y-1420 syntmp-ids-1421) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1418 syntmp-n-1407 syntmp-ids-1421)) (lambda (syntmp-x-1422 syntmp-ids-1423) (values (cons syntmp-x-1422 syntmp-y-1420) syntmp-ids-1423)))))) syntmp-tmp-1417) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda () (values (quote ()) syntmp-ids-1408)) syntmp-tmp-1424) ((lambda (syntmp-tmp-1425) (if syntmp-tmp-1425 (apply (lambda (syntmp-x-1426) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1426 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-p-1428 syntmp-ids-1429) (values (vector (quote vector) syntmp-p-1428) syntmp-ids-1429)))) syntmp-tmp-1425) ((lambda (syntmp-x-1430) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1406 (quote (())))) syntmp-ids-1408)) syntmp-tmp-1409))) (syntax-dispatch syntmp-tmp-1409 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1409 (quote ()))))) (syntax-dispatch syntmp-tmp-1409 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1409 (quote (any any))))) syntmp-p-1406)))))) (lambda (syntmp-e-1431 syntmp-r-1432 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435) (let ((syntmp-e-1436 (syntmp-source-wrap-133 syntmp-e-1431 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435))) ((lambda (syntmp-tmp-1437) ((lambda (syntmp-tmp-1438) (if syntmp-tmp-1438 (apply (lambda (syntmp-_-1439 syntmp-val-1440 syntmp-key-1441 syntmp-m-1442) (if (andmap (lambda (syntmp-x-1443) (and (syntmp-id?-104 syntmp-x-1443) (not (syntmp-ellipsis?-149 syntmp-x-1443)))) syntmp-key-1441) (let ((syntmp-x-1445 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1434 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1445) (syntmp-gen-syntax-case-1358 (syntmp-build-annotated-81 #f syntmp-x-1445) syntmp-key-1441 syntmp-m-1442 syntmp-r-1432 syntmp-mod-1435))) (syntmp-chi-140 syntmp-val-1440 syntmp-r-1432 (quote (())) syntmp-mod-1435)))) (syntax-error syntmp-e-1436 "invalid literals list in"))) syntmp-tmp-1438) (syntax-error syntmp-tmp-1437))) (syntax-dispatch syntmp-tmp-1437 (quote (any any each-any . each-any))))) syntmp-e-1436))))) (set! sc-expand (let ((syntmp-m-1448 (quote e)) (syntmp-esew-1449 (quote (eval)))) (lambda (syntmp-x-1450) (if (and (pair? syntmp-x-1450) (equal? (car syntmp-x-1450) syntmp-noexpand-71)) (cadr syntmp-x-1450) (syntmp-chi-top-139 syntmp-x-1450 (quote ()) (quote ((top))) syntmp-m-1448 syntmp-esew-1449 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1451 (quote e)) (syntmp-esew-1452 (quote (eval)))) (lambda (syntmp-x-1454 . syntmp-rest-1453) (if (and (pair? syntmp-x-1454) (equal? (car syntmp-x-1454) syntmp-noexpand-71)) (cadr syntmp-x-1454) (syntmp-chi-top-139 syntmp-x-1454 (quote ()) (quote ((top))) (if (null? syntmp-rest-1453) syntmp-m-1451 (car syntmp-rest-1453)) (if (or (null? syntmp-rest-1453) (null? (cdr syntmp-rest-1453))) syntmp-esew-1452 (cadr syntmp-rest-1453)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1455) (syntmp-nonsymbol-id?-103 syntmp-x-1455))) (set! datum->syntax-object (lambda (syntmp-id-1456 syntmp-datum-1457) (syntmp-make-syntax-object-87 syntmp-datum-1457 (syntmp-syntax-object-wrap-90 syntmp-id-1456) #f))) (set! syntax-object->datum (lambda (syntmp-x-1458) (syntmp-strip-151 syntmp-x-1458 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1459) (begin (let ((syntmp-x-1460 syntmp-ls-1459)) (if (not (list? syntmp-x-1460)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1460))) (map (lambda (syntmp-x-1461) (syntmp-wrap-132 (gensym) (quote ((top))) #f)) syntmp-ls-1459)))) (set! free-identifier=? (lambda (syntmp-x-1462 syntmp-y-1463) (begin (let ((syntmp-x-1464 syntmp-x-1462)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1464)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1464))) (let ((syntmp-x-1465 syntmp-y-1463)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1465)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1465))) (syntmp-free-id=?-127 syntmp-x-1462 syntmp-y-1463)))) (set! bound-identifier=? (lambda (syntmp-x-1466 syntmp-y-1467) (begin (let ((syntmp-x-1468 syntmp-x-1466)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1468)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1468))) (let ((syntmp-x-1469 syntmp-y-1467)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1469)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1469))) (syntmp-bound-id=?-128 syntmp-x-1466 syntmp-y-1467)))) (set! syntax-error (lambda (syntmp-object-1471 . syntmp-messages-1470) (begin (for-each (lambda (syntmp-x-1472) (let ((syntmp-x-1473 syntmp-x-1472)) (if (not (string? syntmp-x-1473)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1473)))) syntmp-messages-1470) (let ((syntmp-message-1474 (if (null? syntmp-messages-1470) "invalid syntax" (apply string-append syntmp-messages-1470)))) (syntmp-error-hook-78 #f syntmp-message-1474 (syntmp-strip-151 syntmp-object-1471 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1475 syntmp-v-1476) (begin (let ((syntmp-x-1477 syntmp-sym-1475)) (if (not (symbol? syntmp-x-1477)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1477))) (let ((syntmp-x-1478 syntmp-v-1476)) (if (not (procedure? syntmp-x-1478)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1478))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1475 syntmp-v-1476)))) (letrec ((syntmp-match-1483 (lambda (syntmp-e-1484 syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488) (cond ((not syntmp-r-1487) #f) ((eq? syntmp-p-1485 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1484 syntmp-w-1486 syntmp-mod-1488) syntmp-r-1487)) ((syntmp-syntax-object?-88 syntmp-e-1484) (syntmp-match*-1482 (let ((syntmp-e-1489 (syntmp-syntax-object-expression-89 syntmp-e-1484))) (if (annotation? syntmp-e-1489) (annotation-expression syntmp-e-1489) syntmp-e-1489)) syntmp-p-1485 (syntmp-join-wraps-123 syntmp-w-1486 (syntmp-syntax-object-wrap-90 syntmp-e-1484)) syntmp-r-1487 (syntmp-syntax-object-module-91 syntmp-e-1484))) (else (syntmp-match*-1482 (let ((syntmp-e-1490 syntmp-e-1484)) (if (annotation? syntmp-e-1490) (annotation-expression syntmp-e-1490) syntmp-e-1490)) syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488))))) (syntmp-match*-1482 (lambda (syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) (cond ((null? syntmp-p-1492) (and (null? syntmp-e-1491) syntmp-r-1494)) ((pair? syntmp-p-1492) (and (pair? syntmp-e-1491) (syntmp-match-1483 (car syntmp-e-1491) (car syntmp-p-1492) syntmp-w-1493 (syntmp-match-1483 (cdr syntmp-e-1491) (cdr syntmp-p-1492) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) syntmp-mod-1495))) ((eq? syntmp-p-1492 (quote each-any)) (let ((syntmp-l-1496 (syntmp-match-each-any-1480 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1496 (cons syntmp-l-1496 syntmp-r-1494)))) (else (let ((syntmp-t-1497 (vector-ref syntmp-p-1492 0))) (if (memv syntmp-t-1497 (quote (each))) (if (null? syntmp-e-1491) (syntmp-match-empty-1481 (vector-ref syntmp-p-1492 1) syntmp-r-1494) (let ((syntmp-l-1498 (syntmp-match-each-1479 syntmp-e-1491 (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1498 (let syntmp-collect-1499 ((syntmp-l-1500 syntmp-l-1498)) (if (null? (car syntmp-l-1500)) syntmp-r-1494 (cons (map car syntmp-l-1500) (syntmp-collect-1499 (map cdr syntmp-l-1500)))))))) (if (memv syntmp-t-1497 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1491) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495) (vector-ref syntmp-p-1492 1)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (atom))) (and (equal? (vector-ref syntmp-p-1492 1) (syntmp-strip-151 syntmp-e-1491 syntmp-w-1493)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (vector))) (and (vector? syntmp-e-1491) (syntmp-match-1483 (vector->list syntmp-e-1491) (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495))))))))))) (syntmp-match-empty-1481 (lambda (syntmp-p-1501 syntmp-r-1502) (cond ((null? syntmp-p-1501) syntmp-r-1502) ((eq? syntmp-p-1501 (quote any)) (cons (quote ()) syntmp-r-1502)) ((pair? syntmp-p-1501) (syntmp-match-empty-1481 (car syntmp-p-1501) (syntmp-match-empty-1481 (cdr syntmp-p-1501) syntmp-r-1502))) ((eq? syntmp-p-1501 (quote each-any)) (cons (quote ()) syntmp-r-1502)) (else (let ((syntmp-t-1503 (vector-ref syntmp-p-1501 0))) (if (memv syntmp-t-1503 (quote (each))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502) (if (memv syntmp-t-1503 (quote (free-id atom))) syntmp-r-1502 (if (memv syntmp-t-1503 (quote (vector))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502))))))))) (syntmp-match-each-any-1480 (lambda (syntmp-e-1504 syntmp-w-1505 syntmp-mod-1506) (cond ((annotation? syntmp-e-1504) (syntmp-match-each-any-1480 (annotation-expression syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506)) ((pair? syntmp-e-1504) (let ((syntmp-l-1507 (syntmp-match-each-any-1480 (cdr syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506))) (and syntmp-l-1507 (cons (syntmp-wrap-132 (car syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506) syntmp-l-1507)))) ((null? syntmp-e-1504) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1504) (syntmp-match-each-any-1480 (syntmp-syntax-object-expression-89 syntmp-e-1504) (syntmp-join-wraps-123 syntmp-w-1505 (syntmp-syntax-object-wrap-90 syntmp-e-1504)) syntmp-mod-1506)) (else #f)))) (syntmp-match-each-1479 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511) (cond ((annotation? syntmp-e-1508) (syntmp-match-each-1479 (annotation-expression syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511)) ((pair? syntmp-e-1508) (let ((syntmp-first-1512 (syntmp-match-1483 (car syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 (quote ()) syntmp-mod-1511))) (and syntmp-first-1512 (let ((syntmp-rest-1513 (syntmp-match-each-1479 (cdr syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511))) (and syntmp-rest-1513 (cons syntmp-first-1512 syntmp-rest-1513)))))) ((null? syntmp-e-1508) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1508) (syntmp-match-each-1479 (syntmp-syntax-object-expression-89 syntmp-e-1508) syntmp-p-1509 (syntmp-join-wraps-123 syntmp-w-1510 (syntmp-syntax-object-wrap-90 syntmp-e-1508)) (syntmp-syntax-object-module-91 syntmp-e-1508))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1514 syntmp-p-1515) (cond ((eq? syntmp-p-1515 (quote any)) (list syntmp-e-1514)) ((syntmp-syntax-object?-88 syntmp-e-1514) (syntmp-match*-1482 (let ((syntmp-e-1516 (syntmp-syntax-object-expression-89 syntmp-e-1514))) (if (annotation? syntmp-e-1516) (annotation-expression syntmp-e-1516) syntmp-e-1516)) syntmp-p-1515 (syntmp-syntax-object-wrap-90 syntmp-e-1514) (quote ()) (syntmp-syntax-object-module-91 syntmp-e-1514))) (else (syntmp-match*-1482 (let ((syntmp-e-1517 syntmp-e-1514)) (if (annotation? syntmp-e-1517) (annotation-expression syntmp-e-1517) syntmp-e-1517)) syntmp-p-1515 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-140))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1518) ((lambda (syntmp-tmp-1519) ((lambda (syntmp-tmp-1520) (if syntmp-tmp-1520 (apply (lambda (syntmp-_-1521 syntmp-e1-1522 syntmp-e2-1523) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1522 syntmp-e2-1523))) syntmp-tmp-1520) ((lambda (syntmp-tmp-1525) (if syntmp-tmp-1525 (apply (lambda (syntmp-_-1526 syntmp-out-1527 syntmp-in-1528 syntmp-e1-1529 syntmp-e2-1530) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1528 (quote ()) (list syntmp-out-1527 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1529 syntmp-e2-1530))))) syntmp-tmp-1525) ((lambda (syntmp-tmp-1532) (if syntmp-tmp-1532 (apply (lambda (syntmp-_-1533 syntmp-out-1534 syntmp-in-1535 syntmp-e1-1536 syntmp-e2-1537) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1535) (quote ()) (list syntmp-out-1534 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1536 syntmp-e2-1537))))) syntmp-tmp-1532) (syntax-error syntmp-tmp-1519))) (syntax-dispatch syntmp-tmp-1519 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any () any . each-any))))) syntmp-x-1518))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1559) ((lambda (syntmp-tmp-1560) ((lambda (syntmp-tmp-1561) (if syntmp-tmp-1561 (apply (lambda (syntmp-_-1562 syntmp-k-1563 syntmp-keyword-1564 syntmp-pattern-1565 syntmp-template-1566) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1563 (map (lambda (syntmp-tmp-1569 syntmp-tmp-1568) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1568) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1569))) syntmp-template-1566 syntmp-pattern-1565)))))) syntmp-tmp-1561) (syntax-error syntmp-tmp-1560))) (syntax-dispatch syntmp-tmp-1560 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1559))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1580) ((lambda (syntmp-tmp-1581) ((lambda (syntmp-tmp-1582) (if (if syntmp-tmp-1582 (apply (lambda (syntmp-let*-1583 syntmp-x-1584 syntmp-v-1585 syntmp-e1-1586 syntmp-e2-1587) (andmap identifier? syntmp-x-1584)) syntmp-tmp-1582) #f) (apply (lambda (syntmp-let*-1589 syntmp-x-1590 syntmp-v-1591 syntmp-e1-1592 syntmp-e2-1593) (let syntmp-f-1594 ((syntmp-bindings-1595 (map list syntmp-x-1590 syntmp-v-1591))) (if (null? syntmp-bindings-1595) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1592 syntmp-e2-1593))) ((lambda (syntmp-tmp-1599) ((lambda (syntmp-tmp-1600) (if syntmp-tmp-1600 (apply (lambda (syntmp-body-1601 syntmp-binding-1602) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1602) syntmp-body-1601)) syntmp-tmp-1600) (syntax-error syntmp-tmp-1599))) (syntax-dispatch syntmp-tmp-1599 (quote (any any))))) (list (syntmp-f-1594 (cdr syntmp-bindings-1595)) (car syntmp-bindings-1595)))))) syntmp-tmp-1582) (syntax-error syntmp-tmp-1581))) (syntax-dispatch syntmp-tmp-1581 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1580))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1622) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-_-1625 syntmp-var-1626 syntmp-init-1627 syntmp-step-1628 syntmp-e0-1629 syntmp-e1-1630 syntmp-c-1631) ((lambda (syntmp-tmp-1632) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-step-1634) ((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-e1-1642 syntmp-e2-1643) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1642 syntmp-e2-1643)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1641) (syntax-error syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-e1-1630)) syntmp-tmp-1633) (syntax-error syntmp-tmp-1632))) (syntax-dispatch syntmp-tmp-1632 (quote each-any)))) (map (lambda (syntmp-v-1650 syntmp-s-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda () syntmp-v-1650) syntmp-tmp-1653) ((lambda (syntmp-tmp-1654) (if syntmp-tmp-1654 (apply (lambda (syntmp-e-1655) syntmp-e-1655) syntmp-tmp-1654) ((lambda (syntmp-_-1656) (syntax-error syntmp-orig-x-1622)) syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any)))))) (syntax-dispatch syntmp-tmp-1652 (quote ())))) syntmp-s-1651)) syntmp-var-1626 syntmp-step-1628))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1622))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1684 (lambda (syntmp-x-1688 syntmp-y-1689) ((lambda (syntmp-tmp-1690) ((lambda (syntmp-tmp-1691) (if syntmp-tmp-1691 (apply (lambda (syntmp-x-1692 syntmp-y-1693) ((lambda (syntmp-tmp-1694) ((lambda (syntmp-tmp-1695) (if syntmp-tmp-1695 (apply (lambda (syntmp-dy-1696) ((lambda (syntmp-tmp-1697) ((lambda (syntmp-tmp-1698) (if syntmp-tmp-1698 (apply (lambda (syntmp-dx-1699) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1699 syntmp-dy-1696))) syntmp-tmp-1698) ((lambda (syntmp-_-1700) (if (null? syntmp-dy-1696) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693))) syntmp-tmp-1697))) (syntax-dispatch syntmp-tmp-1697 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1692)) syntmp-tmp-1695) ((lambda (syntmp-tmp-1701) (if syntmp-tmp-1701 (apply (lambda (syntmp-stuff-1702) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1692 syntmp-stuff-1702))) syntmp-tmp-1701) ((lambda (syntmp-else-1703) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693)) syntmp-tmp-1694))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1693)) syntmp-tmp-1691) (syntax-error syntmp-tmp-1690))) (syntax-dispatch syntmp-tmp-1690 (quote (any any))))) (list syntmp-x-1688 syntmp-y-1689)))) (syntmp-quasiappend-1685 (lambda (syntmp-x-1704 syntmp-y-1705) ((lambda (syntmp-tmp-1706) ((lambda (syntmp-tmp-1707) (if syntmp-tmp-1707 (apply (lambda (syntmp-x-1708 syntmp-y-1709) ((lambda (syntmp-tmp-1710) ((lambda (syntmp-tmp-1711) (if syntmp-tmp-1711 (apply (lambda () syntmp-x-1708) syntmp-tmp-1711) ((lambda (syntmp-_-1712) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1708 syntmp-y-1709)) syntmp-tmp-1710))) (syntax-dispatch syntmp-tmp-1710 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1709)) syntmp-tmp-1707) (syntax-error syntmp-tmp-1706))) (syntax-dispatch syntmp-tmp-1706 (quote (any any))))) (list syntmp-x-1704 syntmp-y-1705)))) (syntmp-quasivector-1686 (lambda (syntmp-x-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-x-1715) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-x-1718) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1718))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1721)) syntmp-tmp-1720) ((lambda (syntmp-_-1723) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1715)) syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1715)) syntmp-tmp-1714)) syntmp-x-1713))) (syntmp-quasi-1687 (lambda (syntmp-p-1724 syntmp-lev-1725) ((lambda (syntmp-tmp-1726) ((lambda (syntmp-tmp-1727) (if syntmp-tmp-1727 (apply (lambda (syntmp-p-1728) (if (= syntmp-lev-1725 0) syntmp-p-1728 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1728) (- syntmp-lev-1725 1))))) syntmp-tmp-1727) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-p-1730 syntmp-q-1731) (if (= syntmp-lev-1725 0) (syntmp-quasiappend-1685 syntmp-p-1730 (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)) (syntmp-quasicons-1684 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1730) (- syntmp-lev-1725 1))) (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)))) syntmp-tmp-1729) ((lambda (syntmp-tmp-1732) (if syntmp-tmp-1732 (apply (lambda (syntmp-p-1733) (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1733) (+ syntmp-lev-1725 1)))) syntmp-tmp-1732) ((lambda (syntmp-tmp-1734) (if syntmp-tmp-1734 (apply (lambda (syntmp-p-1735 syntmp-q-1736) (syntmp-quasicons-1684 (syntmp-quasi-1687 syntmp-p-1735 syntmp-lev-1725) (syntmp-quasi-1687 syntmp-q-1736 syntmp-lev-1725))) syntmp-tmp-1734) ((lambda (syntmp-tmp-1737) (if syntmp-tmp-1737 (apply (lambda (syntmp-x-1738) (syntmp-quasivector-1686 (syntmp-quasi-1687 syntmp-x-1738 syntmp-lev-1725))) syntmp-tmp-1737) ((lambda (syntmp-p-1740) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1740)) syntmp-tmp-1726))) (syntax-dispatch syntmp-tmp-1726 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1726 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1724)))) (lambda (syntmp-x-1741) ((lambda (syntmp-tmp-1742) ((lambda (syntmp-tmp-1743) (if syntmp-tmp-1743 (apply (lambda (syntmp-_-1744 syntmp-e-1745) (syntmp-quasi-1687 syntmp-e-1745 0)) syntmp-tmp-1743) (syntax-error syntmp-tmp-1742))) (syntax-dispatch syntmp-tmp-1742 (quote (any any))))) syntmp-x-1741)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1805) (letrec ((syntmp-read-file-1806 (lambda (syntmp-fn-1807 syntmp-k-1808) (let ((syntmp-p-1809 (open-input-file syntmp-fn-1807))) (let syntmp-f-1810 ((syntmp-x-1811 (read syntmp-p-1809))) (if (eof-object? syntmp-x-1811) (begin (close-input-port syntmp-p-1809) (quote ())) (cons (datum->syntax-object syntmp-k-1808 syntmp-x-1811) (syntmp-f-1810 (read syntmp-p-1809))))))))) ((lambda (syntmp-tmp-1812) ((lambda (syntmp-tmp-1813) (if syntmp-tmp-1813 (apply (lambda (syntmp-k-1814 syntmp-filename-1815) (let ((syntmp-fn-1816 (syntax-object->datum syntmp-filename-1815))) ((lambda (syntmp-tmp-1817) ((lambda (syntmp-tmp-1818) (if syntmp-tmp-1818 (apply (lambda (syntmp-exp-1819) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1819)) syntmp-tmp-1818) (syntax-error syntmp-tmp-1817))) (syntax-dispatch syntmp-tmp-1817 (quote each-any)))) (syntmp-read-file-1806 syntmp-fn-1816 syntmp-k-1814)))) syntmp-tmp-1813) (syntax-error syntmp-tmp-1812))) (syntax-dispatch syntmp-tmp-1812 (quote (any any))))) syntmp-x-1805)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1836) ((lambda (syntmp-tmp-1837) ((lambda (syntmp-tmp-1838) (if syntmp-tmp-1838 (apply (lambda (syntmp-_-1839 syntmp-e-1840) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1840))) syntmp-tmp-1838) (syntax-error syntmp-tmp-1837))) (syntax-dispatch syntmp-tmp-1837 (quote (any any))))) syntmp-x-1836))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1846) ((lambda (syntmp-tmp-1847) ((lambda (syntmp-tmp-1848) (if syntmp-tmp-1848 (apply (lambda (syntmp-_-1849 syntmp-e-1850) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1850))) syntmp-tmp-1848) (syntax-error syntmp-tmp-1847))) (syntax-dispatch syntmp-tmp-1847 (quote (any any))))) syntmp-x-1846))) -(install-global-transformer (quote case) (lambda (syntmp-x-1856) ((lambda (syntmp-tmp-1857) ((lambda (syntmp-tmp-1858) (if syntmp-tmp-1858 (apply (lambda (syntmp-_-1859 syntmp-e-1860 syntmp-m1-1861 syntmp-m2-1862) ((lambda (syntmp-tmp-1863) ((lambda (syntmp-body-1864) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1860)) syntmp-body-1864)) syntmp-tmp-1863)) (let syntmp-f-1865 ((syntmp-clause-1866 syntmp-m1-1861) (syntmp-clauses-1867 syntmp-m2-1862)) (if (null? syntmp-clauses-1867) ((lambda (syntmp-tmp-1869) ((lambda (syntmp-tmp-1870) (if syntmp-tmp-1870 (apply (lambda (syntmp-e1-1871 syntmp-e2-1872) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1871 syntmp-e2-1872))) syntmp-tmp-1870) ((lambda (syntmp-tmp-1874) (if syntmp-tmp-1874 (apply (lambda (syntmp-k-1875 syntmp-e1-1876 syntmp-e2-1877) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1875)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1876 syntmp-e2-1877)))) syntmp-tmp-1874) ((lambda (syntmp-_-1880) (syntax-error syntmp-x-1856)) syntmp-tmp-1869))) (syntax-dispatch syntmp-tmp-1869 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1869 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1866) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-rest-1882) ((lambda (syntmp-tmp-1883) ((lambda (syntmp-tmp-1884) (if syntmp-tmp-1884 (apply (lambda (syntmp-k-1885 syntmp-e1-1886 syntmp-e2-1887) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1885)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1886 syntmp-e2-1887)) syntmp-rest-1882)) syntmp-tmp-1884) ((lambda (syntmp-_-1890) (syntax-error syntmp-x-1856)) syntmp-tmp-1883))) (syntax-dispatch syntmp-tmp-1883 (quote (each-any any . each-any))))) syntmp-clause-1866)) syntmp-tmp-1881)) (syntmp-f-1865 (car syntmp-clauses-1867) (cdr syntmp-clauses-1867))))))) syntmp-tmp-1858) (syntax-error syntmp-tmp-1857))) (syntax-dispatch syntmp-tmp-1857 (quote (any any any . each-any))))) syntmp-x-1856))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1920) ((lambda (syntmp-tmp-1921) ((lambda (syntmp-tmp-1922) (if syntmp-tmp-1922 (apply (lambda (syntmp-_-1923 syntmp-e-1924) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1924)) (list (cons syntmp-_-1923 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1924 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1922) (syntax-error syntmp-tmp-1921))) (syntax-dispatch syntmp-tmp-1921 (quote (any any))))) syntmp-x-1920))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-modname-1084) (let ((syntmp-module-1085 (if syntmp-modname-1084 (resolve-module syntmp-modname-1084) (current-module)))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable (quote sc-macro)))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (and (symbol-property syntmp-symbol-1082 (quote primitive-syntax)) (eq? syntmp-module-1085 the-syncase-module))) (variable-set! syntmp-v-1086 sc-macro)) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-head-1341 syntmp-tail-1342 syntmp-val-1343) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-head-1341 syntmp-r-1323 (quote (())) #f #f syntmp-mod-1326)) (lambda (syntmp-type-1344 syntmp-value-1345 syntmp-ee-1346 syntmp-ww-1347 syntmp-ss-1348 syntmp-modmod-1349) (let ((syntmp-t-1350 syntmp-type-1344)) (if (memv syntmp-t-1350 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1345 (cons syntmp-head-1341 syntmp-tail-1342))) (lambda (syntmp-id-1352 syntmp-mod-1353) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1353 syntmp-id-1352 #f) syntmp-val-1343)))) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1354) (syntmp-chi-153 syntmp-e-1354 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-tail-1342 (list syntmp-val-1343)))))))))) syntmp-tmp-1339) ((lambda (syntmp-_-1356) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1357) ((lambda (syntmp-tmp-1358) ((lambda (syntmp-tmp-1359) (if (if syntmp-tmp-1359 (apply (lambda (syntmp-_-1360 syntmp-mod-1361 syntmp-id-1362) (and (andmap syntmp-id?-117 syntmp-mod-1361) (syntmp-id?-117 syntmp-id-1362))) syntmp-tmp-1359) #f) (apply (lambda (syntmp-_-1364 syntmp-mod-1365 syntmp-id-1366) (values (syntax-object->datum syntmp-id-1366) (syntax-object->datum (append syntmp-mod-1365 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1359) (syntax-error syntmp-tmp-1358))) (syntax-dispatch syntmp-tmp-1358 (quote (any each-any any))))) syntmp-e-1357))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1368) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-mod-1372 syntmp-id-1373) (and (andmap syntmp-id?-117 syntmp-mod-1372) (syntmp-id?-117 syntmp-id-1373))) syntmp-tmp-1370) #f) (apply (lambda (syntmp-_-1375 syntmp-mod-1376 syntmp-id-1377) (values (syntax-object->datum syntmp-id-1377) (syntax-object->datum syntmp-mod-1376))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any each-any any))))) syntmp-e-1368))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1382 (lambda (syntmp-x-1383 syntmp-keys-1384 syntmp-clauses-1385 syntmp-r-1386 syntmp-mod-1387) (if (null? syntmp-clauses-1385) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1383)) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if syntmp-tmp-1389 (apply (lambda (syntmp-pat-1390 syntmp-exp-1391) (if (and (syntmp-id?-117 syntmp-pat-1390) (andmap (lambda (syntmp-x-1392) (not (syntmp-free-id=?-140 syntmp-pat-1390 syntmp-x-1392))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1384))) (let ((syntmp-labels-1393 (list (syntmp-gen-label-122))) (syntmp-var-1394 (syntmp-gen-var-165 syntmp-pat-1390))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1394) (syntmp-chi-153 syntmp-exp-1391 (syntmp-extend-env-111 syntmp-labels-1393 (list (cons (quote syntax) (cons syntmp-var-1394 0))) syntmp-r-1386) (syntmp-make-binding-wrap-134 (list syntmp-pat-1390) syntmp-labels-1393 (quote (()))) syntmp-mod-1387))) syntmp-x-1383))) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1390 #t syntmp-exp-1391 syntmp-mod-1387))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1395) (if syntmp-tmp-1395 (apply (lambda (syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398 syntmp-mod-1387)) syntmp-tmp-1395) ((lambda (syntmp-_-1399) (syntax-error (car syntmp-clauses-1385) "invalid syntax-case clause")) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) (car syntmp-clauses-1385))))) (syntmp-gen-clause-1381 (lambda (syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-pat-1404 syntmp-fender-1405 syntmp-exp-1406 syntmp-mod-1407) (call-with-values (lambda () (syntmp-convert-pattern-1379 syntmp-pat-1404 syntmp-keys-1401)) (lambda (syntmp-p-1408 syntmp-pvars-1409) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1409))) (syntax-error syntmp-pat-1404 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1410) (not (syntmp-ellipsis?-162 (car syntmp-x-1410)))) syntmp-pvars-1409)) (syntax-error syntmp-pat-1404 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1411 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1411) (let ((syntmp-y-1412 (syntmp-build-annotated-94 #f syntmp-y-1411))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1413) ((lambda (syntmp-tmp-1414) (if syntmp-tmp-1414 (apply (lambda () syntmp-y-1412) syntmp-tmp-1414) ((lambda (syntmp-_-1415) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1412 (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-fender-1405 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1413))) (syntax-dispatch syntmp-tmp-1413 (quote #(atom #t))))) syntmp-fender-1405) (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-exp-1406 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-gen-syntax-case-1382 syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-mod-1407)))))) (if (eq? syntmp-p-1408 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1400)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1400 (syntmp-build-data-95 #f syntmp-p-1408))))))))))))) (syntmp-build-dispatch-call-1380 (lambda (syntmp-pvars-1416 syntmp-exp-1417 syntmp-y-1418 syntmp-r-1419 syntmp-mod-1420) (let ((syntmp-ids-1421 (map car syntmp-pvars-1416)) (syntmp-levels-1422 (map cdr syntmp-pvars-1416))) (let ((syntmp-labels-1423 (syntmp-gen-labels-123 syntmp-ids-1421)) (syntmp-new-vars-1424 (map syntmp-gen-var-165 syntmp-ids-1421))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1424 (syntmp-chi-153 syntmp-exp-1417 (syntmp-extend-env-111 syntmp-labels-1423 (map (lambda (syntmp-var-1425 syntmp-level-1426) (cons (quote syntax) (cons syntmp-var-1425 syntmp-level-1426))) syntmp-new-vars-1424 (map cdr syntmp-pvars-1416)) syntmp-r-1419) (syntmp-make-binding-wrap-134 syntmp-ids-1421 syntmp-labels-1423 (quote (()))) syntmp-mod-1420))) syntmp-y-1418)))))) (syntmp-convert-pattern-1379 (lambda (syntmp-pattern-1427 syntmp-keys-1428) (let syntmp-cvt-1429 ((syntmp-p-1430 syntmp-pattern-1427) (syntmp-n-1431 0) (syntmp-ids-1432 (quote ()))) (if (syntmp-id?-117 syntmp-p-1430) (if (syntmp-bound-id-member?-144 syntmp-p-1430 syntmp-keys-1428) (values (vector (quote free-id) syntmp-p-1430) syntmp-ids-1432) (values (quote any) (cons (cons syntmp-p-1430 syntmp-n-1431) syntmp-ids-1432))) ((lambda (syntmp-tmp-1433) ((lambda (syntmp-tmp-1434) (if (if syntmp-tmp-1434 (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (syntmp-ellipsis?-162 syntmp-dots-1436)) syntmp-tmp-1434) #f) (apply (lambda (syntmp-x-1437 syntmp-dots-1438) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1437 (syntmp-fx+-85 syntmp-n-1431 1) syntmp-ids-1432)) (lambda (syntmp-p-1439 syntmp-ids-1440) (values (if (eq? syntmp-p-1439 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1439)) syntmp-ids-1440)))) syntmp-tmp-1434) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-x-1442 syntmp-y-1443) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-y-1443 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-y-1444 syntmp-ids-1445) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1442 syntmp-n-1431 syntmp-ids-1445)) (lambda (syntmp-x-1446 syntmp-ids-1447) (values (cons syntmp-x-1446 syntmp-y-1444) syntmp-ids-1447)))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda () (values (quote ()) syntmp-ids-1432)) syntmp-tmp-1448) ((lambda (syntmp-tmp-1449) (if syntmp-tmp-1449 (apply (lambda (syntmp-x-1450) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1450 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-p-1452 syntmp-ids-1453) (values (vector (quote vector) syntmp-p-1452) syntmp-ids-1453)))) syntmp-tmp-1449) ((lambda (syntmp-x-1454) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1430 (quote (())))) syntmp-ids-1432)) syntmp-tmp-1433))) (syntax-dispatch syntmp-tmp-1433 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1433 (quote ()))))) (syntax-dispatch syntmp-tmp-1433 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1433 (quote (any any))))) syntmp-p-1430)))))) (lambda (syntmp-e-1455 syntmp-r-1456 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459) (let ((syntmp-e-1460 (syntmp-source-wrap-146 syntmp-e-1455 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459))) ((lambda (syntmp-tmp-1461) ((lambda (syntmp-tmp-1462) (if syntmp-tmp-1462 (apply (lambda (syntmp-_-1463 syntmp-val-1464 syntmp-key-1465 syntmp-m-1466) (if (andmap (lambda (syntmp-x-1467) (and (syntmp-id?-117 syntmp-x-1467) (not (syntmp-ellipsis?-162 syntmp-x-1467)))) syntmp-key-1465) (let ((syntmp-x-1469 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1458 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1469) (syntmp-gen-syntax-case-1382 (syntmp-build-annotated-94 #f syntmp-x-1469) syntmp-key-1465 syntmp-m-1466 syntmp-r-1456 syntmp-mod-1459))) (syntmp-chi-153 syntmp-val-1464 syntmp-r-1456 (quote (())) syntmp-mod-1459)))) (syntax-error syntmp-e-1460 "invalid literals list in"))) syntmp-tmp-1462) (syntax-error syntmp-tmp-1461))) (syntax-dispatch syntmp-tmp-1461 (quote (any any each-any . each-any))))) syntmp-e-1460))))) (set! sc-expand (let ((syntmp-m-1472 (quote e)) (syntmp-esew-1473 (quote (eval)))) (lambda (syntmp-x-1474) (if (and (pair? syntmp-x-1474) (equal? (car syntmp-x-1474) syntmp-noexpand-84)) (cadr syntmp-x-1474) (syntmp-chi-top-152 syntmp-x-1474 (quote ()) (quote ((top))) syntmp-m-1472 syntmp-esew-1473 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1475 (quote e)) (syntmp-esew-1476 (quote (eval)))) (lambda (syntmp-x-1478 . syntmp-rest-1477) (if (and (pair? syntmp-x-1478) (equal? (car syntmp-x-1478) syntmp-noexpand-84)) (cadr syntmp-x-1478) (syntmp-chi-top-152 syntmp-x-1478 (quote ()) (quote ((top))) (if (null? syntmp-rest-1477) syntmp-m-1475 (car syntmp-rest-1477)) (if (or (null? syntmp-rest-1477) (null? (cdr syntmp-rest-1477))) syntmp-esew-1476 (cadr syntmp-rest-1477)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1479) (syntmp-nonsymbol-id?-116 syntmp-x-1479))) (set! datum->syntax-object (lambda (syntmp-id-1480 syntmp-datum-1481) (syntmp-make-syntax-object-100 syntmp-datum-1481 (syntmp-syntax-object-wrap-103 syntmp-id-1480) #f))) (set! syntax-object->datum (lambda (syntmp-x-1482) (syntmp-strip-164 syntmp-x-1482 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1483) (begin (let ((syntmp-x-1484 syntmp-ls-1483)) (if (not (list? syntmp-x-1484)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1484))) (map (lambda (syntmp-x-1485) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1483)))) (set! free-identifier=? (lambda (syntmp-x-1486 syntmp-y-1487) (begin (let ((syntmp-x-1488 syntmp-x-1486)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1488)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1488))) (let ((syntmp-x-1489 syntmp-y-1487)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1489)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1489))) (syntmp-free-id=?-140 syntmp-x-1486 syntmp-y-1487)))) (set! bound-identifier=? (lambda (syntmp-x-1490 syntmp-y-1491) (begin (let ((syntmp-x-1492 syntmp-x-1490)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1492)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1492))) (let ((syntmp-x-1493 syntmp-y-1491)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1493)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1493))) (syntmp-bound-id=?-141 syntmp-x-1490 syntmp-y-1491)))) (set! syntax-error (lambda (syntmp-object-1495 . syntmp-messages-1494) (begin (for-each (lambda (syntmp-x-1496) (let ((syntmp-x-1497 syntmp-x-1496)) (if (not (string? syntmp-x-1497)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1497)))) syntmp-messages-1494) (let ((syntmp-message-1498 (if (null? syntmp-messages-1494) "invalid syntax" (apply string-append syntmp-messages-1494)))) (syntmp-error-hook-91 #f syntmp-message-1498 (syntmp-strip-164 syntmp-object-1495 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1499 syntmp-v-1500) (begin (let ((syntmp-x-1501 syntmp-sym-1499)) (if (not (symbol? syntmp-x-1501)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1501))) (let ((syntmp-x-1502 syntmp-v-1500)) (if (not (procedure? syntmp-x-1502)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1502))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1499 syntmp-v-1500)))) (letrec ((syntmp-match-1507 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512) (cond ((not syntmp-r-1511) #f) ((eq? syntmp-p-1509 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1508 syntmp-w-1510 syntmp-mod-1512) syntmp-r-1511)) ((syntmp-syntax-object?-101 syntmp-e-1508) (syntmp-match*-1506 (let ((syntmp-e-1513 (syntmp-syntax-object-expression-102 syntmp-e-1508))) (if (annotation? syntmp-e-1513) (annotation-expression syntmp-e-1513) syntmp-e-1513)) syntmp-p-1509 (syntmp-join-wraps-136 syntmp-w-1510 (syntmp-syntax-object-wrap-103 syntmp-e-1508)) syntmp-r-1511 (syntmp-syntax-object-module-104 syntmp-e-1508))) (else (syntmp-match*-1506 (let ((syntmp-e-1514 syntmp-e-1508)) (if (annotation? syntmp-e-1514) (annotation-expression syntmp-e-1514) syntmp-e-1514)) syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512))))) (syntmp-match*-1506 (lambda (syntmp-e-1515 syntmp-p-1516 syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) (cond ((null? syntmp-p-1516) (and (null? syntmp-e-1515) syntmp-r-1518)) ((pair? syntmp-p-1516) (and (pair? syntmp-e-1515) (syntmp-match-1507 (car syntmp-e-1515) (car syntmp-p-1516) syntmp-w-1517 (syntmp-match-1507 (cdr syntmp-e-1515) (cdr syntmp-p-1516) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) syntmp-mod-1519))) ((eq? syntmp-p-1516 (quote each-any)) (let ((syntmp-l-1520 (syntmp-match-each-any-1504 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1520 (cons syntmp-l-1520 syntmp-r-1518)))) (else (let ((syntmp-t-1521 (vector-ref syntmp-p-1516 0))) (if (memv syntmp-t-1521 (quote (each))) (if (null? syntmp-e-1515) (syntmp-match-empty-1505 (vector-ref syntmp-p-1516 1) syntmp-r-1518) (let ((syntmp-l-1522 (syntmp-match-each-1503 syntmp-e-1515 (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1522 (let syntmp-collect-1523 ((syntmp-l-1524 syntmp-l-1522)) (if (null? (car syntmp-l-1524)) syntmp-r-1518 (cons (map car syntmp-l-1524) (syntmp-collect-1523 (map cdr syntmp-l-1524)))))))) (if (memv syntmp-t-1521 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1515) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519) (vector-ref syntmp-p-1516 1)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (atom))) (and (equal? (vector-ref syntmp-p-1516 1) (syntmp-strip-164 syntmp-e-1515 syntmp-w-1517)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (vector))) (and (vector? syntmp-e-1515) (syntmp-match-1507 (vector->list syntmp-e-1515) (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519))))))))))) (syntmp-match-empty-1505 (lambda (syntmp-p-1525 syntmp-r-1526) (cond ((null? syntmp-p-1525) syntmp-r-1526) ((eq? syntmp-p-1525 (quote any)) (cons (quote ()) syntmp-r-1526)) ((pair? syntmp-p-1525) (syntmp-match-empty-1505 (car syntmp-p-1525) (syntmp-match-empty-1505 (cdr syntmp-p-1525) syntmp-r-1526))) ((eq? syntmp-p-1525 (quote each-any)) (cons (quote ()) syntmp-r-1526)) (else (let ((syntmp-t-1527 (vector-ref syntmp-p-1525 0))) (if (memv syntmp-t-1527 (quote (each))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526) (if (memv syntmp-t-1527 (quote (free-id atom))) syntmp-r-1526 (if (memv syntmp-t-1527 (quote (vector))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526))))))))) (syntmp-match-each-any-1504 (lambda (syntmp-e-1528 syntmp-w-1529 syntmp-mod-1530) (cond ((annotation? syntmp-e-1528) (syntmp-match-each-any-1504 (annotation-expression syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530)) ((pair? syntmp-e-1528) (let ((syntmp-l-1531 (syntmp-match-each-any-1504 (cdr syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530))) (and syntmp-l-1531 (cons (syntmp-wrap-145 (car syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530) syntmp-l-1531)))) ((null? syntmp-e-1528) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1528) (syntmp-match-each-any-1504 (syntmp-syntax-object-expression-102 syntmp-e-1528) (syntmp-join-wraps-136 syntmp-w-1529 (syntmp-syntax-object-wrap-103 syntmp-e-1528)) syntmp-mod-1530)) (else #f)))) (syntmp-match-each-1503 (lambda (syntmp-e-1532 syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535) (cond ((annotation? syntmp-e-1532) (syntmp-match-each-1503 (annotation-expression syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535)) ((pair? syntmp-e-1532) (let ((syntmp-first-1536 (syntmp-match-1507 (car syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 (quote ()) syntmp-mod-1535))) (and syntmp-first-1536 (let ((syntmp-rest-1537 (syntmp-match-each-1503 (cdr syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535))) (and syntmp-rest-1537 (cons syntmp-first-1536 syntmp-rest-1537)))))) ((null? syntmp-e-1532) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1532) (syntmp-match-each-1503 (syntmp-syntax-object-expression-102 syntmp-e-1532) syntmp-p-1533 (syntmp-join-wraps-136 syntmp-w-1534 (syntmp-syntax-object-wrap-103 syntmp-e-1532)) (syntmp-syntax-object-module-104 syntmp-e-1532))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1538 syntmp-p-1539) (cond ((eq? syntmp-p-1539 (quote any)) (list syntmp-e-1538)) ((syntmp-syntax-object?-101 syntmp-e-1538) (syntmp-match*-1506 (let ((syntmp-e-1540 (syntmp-syntax-object-expression-102 syntmp-e-1538))) (if (annotation? syntmp-e-1540) (annotation-expression syntmp-e-1540) syntmp-e-1540)) syntmp-p-1539 (syntmp-syntax-object-wrap-103 syntmp-e-1538) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1538))) (else (syntmp-match*-1506 (let ((syntmp-e-1541 syntmp-e-1538)) (if (annotation? syntmp-e-1541) (annotation-expression syntmp-e-1541) syntmp-e-1541)) syntmp-p-1539 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-e1-1546 syntmp-e2-1547) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1546 syntmp-e2-1547))) syntmp-tmp-1544) ((lambda (syntmp-tmp-1549) (if syntmp-tmp-1549 (apply (lambda (syntmp-_-1550 syntmp-out-1551 syntmp-in-1552 syntmp-e1-1553 syntmp-e2-1554) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1552 (quote ()) (list syntmp-out-1551 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1553 syntmp-e2-1554))))) syntmp-tmp-1549) ((lambda (syntmp-tmp-1556) (if syntmp-tmp-1556 (apply (lambda (syntmp-_-1557 syntmp-out-1558 syntmp-in-1559 syntmp-e1-1560 syntmp-e2-1561) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1559) (quote ()) (list syntmp-out-1558 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1560 syntmp-e2-1561))))) syntmp-tmp-1556) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any () any . each-any))))) syntmp-x-1542))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1583) ((lambda (syntmp-tmp-1584) ((lambda (syntmp-tmp-1585) (if syntmp-tmp-1585 (apply (lambda (syntmp-_-1586 syntmp-k-1587 syntmp-keyword-1588 syntmp-pattern-1589 syntmp-template-1590) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1587 (map (lambda (syntmp-tmp-1593 syntmp-tmp-1592) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1592) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1593))) syntmp-template-1590 syntmp-pattern-1589)))))) syntmp-tmp-1585) (syntax-error syntmp-tmp-1584))) (syntax-dispatch syntmp-tmp-1584 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1583))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1604) ((lambda (syntmp-tmp-1605) ((lambda (syntmp-tmp-1606) (if (if syntmp-tmp-1606 (apply (lambda (syntmp-let*-1607 syntmp-x-1608 syntmp-v-1609 syntmp-e1-1610 syntmp-e2-1611) (andmap identifier? syntmp-x-1608)) syntmp-tmp-1606) #f) (apply (lambda (syntmp-let*-1613 syntmp-x-1614 syntmp-v-1615 syntmp-e1-1616 syntmp-e2-1617) (let syntmp-f-1618 ((syntmp-bindings-1619 (map list syntmp-x-1614 syntmp-v-1615))) (if (null? syntmp-bindings-1619) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1616 syntmp-e2-1617))) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-body-1625 syntmp-binding-1626) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1626) syntmp-body-1625)) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any any))))) (list (syntmp-f-1618 (cdr syntmp-bindings-1619)) (car syntmp-bindings-1619)))))) syntmp-tmp-1606) (syntax-error syntmp-tmp-1605))) (syntax-dispatch syntmp-tmp-1605 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1604))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1646) ((lambda (syntmp-tmp-1647) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-_-1649 syntmp-var-1650 syntmp-init-1651 syntmp-step-1652 syntmp-e0-1653 syntmp-e1-1654 syntmp-c-1655) ((lambda (syntmp-tmp-1656) ((lambda (syntmp-tmp-1657) (if syntmp-tmp-1657 (apply (lambda (syntmp-step-1658) ((lambda (syntmp-tmp-1659) ((lambda (syntmp-tmp-1660) (if syntmp-tmp-1660 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1653) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1658))))))) syntmp-tmp-1660) ((lambda (syntmp-tmp-1665) (if syntmp-tmp-1665 (apply (lambda (syntmp-e1-1666 syntmp-e2-1667) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1653 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1666 syntmp-e2-1667)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1658))))))) syntmp-tmp-1665) (syntax-error syntmp-tmp-1659))) (syntax-dispatch syntmp-tmp-1659 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1659 (quote ())))) syntmp-e1-1654)) syntmp-tmp-1657) (syntax-error syntmp-tmp-1656))) (syntax-dispatch syntmp-tmp-1656 (quote each-any)))) (map (lambda (syntmp-v-1674 syntmp-s-1675) ((lambda (syntmp-tmp-1676) ((lambda (syntmp-tmp-1677) (if syntmp-tmp-1677 (apply (lambda () syntmp-v-1674) syntmp-tmp-1677) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-e-1679) syntmp-e-1679) syntmp-tmp-1678) ((lambda (syntmp-_-1680) (syntax-error syntmp-orig-x-1646)) syntmp-tmp-1676))) (syntax-dispatch syntmp-tmp-1676 (quote (any)))))) (syntax-dispatch syntmp-tmp-1676 (quote ())))) syntmp-s-1675)) syntmp-var-1650 syntmp-step-1652))) syntmp-tmp-1648) (syntax-error syntmp-tmp-1647))) (syntax-dispatch syntmp-tmp-1647 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1646))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1708 (lambda (syntmp-x-1712 syntmp-y-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-tmp-1715) (if syntmp-tmp-1715 (apply (lambda (syntmp-x-1716 syntmp-y-1717) ((lambda (syntmp-tmp-1718) ((lambda (syntmp-tmp-1719) (if syntmp-tmp-1719 (apply (lambda (syntmp-dy-1720) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-dx-1723) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1723 syntmp-dy-1720))) syntmp-tmp-1722) ((lambda (syntmp-_-1724) (if (null? syntmp-dy-1720) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1716) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1716 syntmp-y-1717))) syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1716)) syntmp-tmp-1719) ((lambda (syntmp-tmp-1725) (if syntmp-tmp-1725 (apply (lambda (syntmp-stuff-1726) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1716 syntmp-stuff-1726))) syntmp-tmp-1725) ((lambda (syntmp-else-1727) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1716 syntmp-y-1717)) syntmp-tmp-1718))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1717)) syntmp-tmp-1715) (syntax-error syntmp-tmp-1714))) (syntax-dispatch syntmp-tmp-1714 (quote (any any))))) (list syntmp-x-1712 syntmp-y-1713)))) (syntmp-quasiappend-1709 (lambda (syntmp-x-1728 syntmp-y-1729) ((lambda (syntmp-tmp-1730) ((lambda (syntmp-tmp-1731) (if syntmp-tmp-1731 (apply (lambda (syntmp-x-1732 syntmp-y-1733) ((lambda (syntmp-tmp-1734) ((lambda (syntmp-tmp-1735) (if syntmp-tmp-1735 (apply (lambda () syntmp-x-1732) syntmp-tmp-1735) ((lambda (syntmp-_-1736) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1732 syntmp-y-1733)) syntmp-tmp-1734))) (syntax-dispatch syntmp-tmp-1734 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1733)) syntmp-tmp-1731) (syntax-error syntmp-tmp-1730))) (syntax-dispatch syntmp-tmp-1730 (quote (any any))))) (list syntmp-x-1728 syntmp-y-1729)))) (syntmp-quasivector-1710 (lambda (syntmp-x-1737) ((lambda (syntmp-tmp-1738) ((lambda (syntmp-x-1739) ((lambda (syntmp-tmp-1740) ((lambda (syntmp-tmp-1741) (if syntmp-tmp-1741 (apply (lambda (syntmp-x-1742) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1742))) syntmp-tmp-1741) ((lambda (syntmp-tmp-1744) (if syntmp-tmp-1744 (apply (lambda (syntmp-x-1745) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1745)) syntmp-tmp-1744) ((lambda (syntmp-_-1747) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1739)) syntmp-tmp-1740))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1739)) syntmp-tmp-1738)) syntmp-x-1737))) (syntmp-quasi-1711 (lambda (syntmp-p-1748 syntmp-lev-1749) ((lambda (syntmp-tmp-1750) ((lambda (syntmp-tmp-1751) (if syntmp-tmp-1751 (apply (lambda (syntmp-p-1752) (if (= syntmp-lev-1749 0) syntmp-p-1752 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1711 (list syntmp-p-1752) (- syntmp-lev-1749 1))))) syntmp-tmp-1751) ((lambda (syntmp-tmp-1753) (if syntmp-tmp-1753 (apply (lambda (syntmp-p-1754 syntmp-q-1755) (if (= syntmp-lev-1749 0) (syntmp-quasiappend-1709 syntmp-p-1754 (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)) (syntmp-quasicons-1708 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1711 (list syntmp-p-1754) (- syntmp-lev-1749 1))) (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)))) syntmp-tmp-1753) ((lambda (syntmp-tmp-1756) (if syntmp-tmp-1756 (apply (lambda (syntmp-p-1757) (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1711 (list syntmp-p-1757) (+ syntmp-lev-1749 1)))) syntmp-tmp-1756) ((lambda (syntmp-tmp-1758) (if syntmp-tmp-1758 (apply (lambda (syntmp-p-1759 syntmp-q-1760) (syntmp-quasicons-1708 (syntmp-quasi-1711 syntmp-p-1759 syntmp-lev-1749) (syntmp-quasi-1711 syntmp-q-1760 syntmp-lev-1749))) syntmp-tmp-1758) ((lambda (syntmp-tmp-1761) (if syntmp-tmp-1761 (apply (lambda (syntmp-x-1762) (syntmp-quasivector-1710 (syntmp-quasi-1711 syntmp-x-1762 syntmp-lev-1749))) syntmp-tmp-1761) ((lambda (syntmp-p-1764) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1764)) syntmp-tmp-1750))) (syntax-dispatch syntmp-tmp-1750 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1750 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1748)))) (lambda (syntmp-x-1765) ((lambda (syntmp-tmp-1766) ((lambda (syntmp-tmp-1767) (if syntmp-tmp-1767 (apply (lambda (syntmp-_-1768 syntmp-e-1769) (syntmp-quasi-1711 syntmp-e-1769 0)) syntmp-tmp-1767) (syntax-error syntmp-tmp-1766))) (syntax-dispatch syntmp-tmp-1766 (quote (any any))))) syntmp-x-1765)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1829) (letrec ((syntmp-read-file-1830 (lambda (syntmp-fn-1831 syntmp-k-1832) (let ((syntmp-p-1833 (open-input-file syntmp-fn-1831))) (let syntmp-f-1834 ((syntmp-x-1835 (read syntmp-p-1833))) (if (eof-object? syntmp-x-1835) (begin (close-input-port syntmp-p-1833) (quote ())) (cons (datum->syntax-object syntmp-k-1832 syntmp-x-1835) (syntmp-f-1834 (read syntmp-p-1833))))))))) ((lambda (syntmp-tmp-1836) ((lambda (syntmp-tmp-1837) (if syntmp-tmp-1837 (apply (lambda (syntmp-k-1838 syntmp-filename-1839) (let ((syntmp-fn-1840 (syntax-object->datum syntmp-filename-1839))) ((lambda (syntmp-tmp-1841) ((lambda (syntmp-tmp-1842) (if syntmp-tmp-1842 (apply (lambda (syntmp-exp-1843) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1843)) syntmp-tmp-1842) (syntax-error syntmp-tmp-1841))) (syntax-dispatch syntmp-tmp-1841 (quote each-any)))) (syntmp-read-file-1830 syntmp-fn-1840 syntmp-k-1838)))) syntmp-tmp-1837) (syntax-error syntmp-tmp-1836))) (syntax-dispatch syntmp-tmp-1836 (quote (any any))))) syntmp-x-1829)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1860) ((lambda (syntmp-tmp-1861) ((lambda (syntmp-tmp-1862) (if syntmp-tmp-1862 (apply (lambda (syntmp-_-1863 syntmp-e-1864) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1864))) syntmp-tmp-1862) (syntax-error syntmp-tmp-1861))) (syntax-dispatch syntmp-tmp-1861 (quote (any any))))) syntmp-x-1860))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1870) ((lambda (syntmp-tmp-1871) ((lambda (syntmp-tmp-1872) (if syntmp-tmp-1872 (apply (lambda (syntmp-_-1873 syntmp-e-1874) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1874))) syntmp-tmp-1872) (syntax-error syntmp-tmp-1871))) (syntax-dispatch syntmp-tmp-1871 (quote (any any))))) syntmp-x-1870))) +(install-global-transformer (quote case) (lambda (syntmp-x-1880) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-tmp-1882) (if syntmp-tmp-1882 (apply (lambda (syntmp-_-1883 syntmp-e-1884 syntmp-m1-1885 syntmp-m2-1886) ((lambda (syntmp-tmp-1887) ((lambda (syntmp-body-1888) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1884)) syntmp-body-1888)) syntmp-tmp-1887)) (let syntmp-f-1889 ((syntmp-clause-1890 syntmp-m1-1885) (syntmp-clauses-1891 syntmp-m2-1886)) (if (null? syntmp-clauses-1891) ((lambda (syntmp-tmp-1893) ((lambda (syntmp-tmp-1894) (if syntmp-tmp-1894 (apply (lambda (syntmp-e1-1895 syntmp-e2-1896) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1895 syntmp-e2-1896))) syntmp-tmp-1894) ((lambda (syntmp-tmp-1898) (if syntmp-tmp-1898 (apply (lambda (syntmp-k-1899 syntmp-e1-1900 syntmp-e2-1901) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1899)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1900 syntmp-e2-1901)))) syntmp-tmp-1898) ((lambda (syntmp-_-1904) (syntax-error syntmp-x-1880)) syntmp-tmp-1893))) (syntax-dispatch syntmp-tmp-1893 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1893 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1890) ((lambda (syntmp-tmp-1905) ((lambda (syntmp-rest-1906) ((lambda (syntmp-tmp-1907) ((lambda (syntmp-tmp-1908) (if syntmp-tmp-1908 (apply (lambda (syntmp-k-1909 syntmp-e1-1910 syntmp-e2-1911) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1909)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1910 syntmp-e2-1911)) syntmp-rest-1906)) syntmp-tmp-1908) ((lambda (syntmp-_-1914) (syntax-error syntmp-x-1880)) syntmp-tmp-1907))) (syntax-dispatch syntmp-tmp-1907 (quote (each-any any . each-any))))) syntmp-clause-1890)) syntmp-tmp-1905)) (syntmp-f-1889 (car syntmp-clauses-1891) (cdr syntmp-clauses-1891))))))) syntmp-tmp-1882) (syntax-error syntmp-tmp-1881))) (syntax-dispatch syntmp-tmp-1881 (quote (any any any . each-any))))) syntmp-x-1880))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1944) ((lambda (syntmp-tmp-1945) ((lambda (syntmp-tmp-1946) (if syntmp-tmp-1946 (apply (lambda (syntmp-_-1947 syntmp-e-1948) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1948)) (list (cons syntmp-_-1947 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1948 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1946) (syntax-error syntmp-tmp-1945))) (syntax-dispatch syntmp-tmp-1945 (quote (any any))))) syntmp-x-1944))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index cd2c53224..a9159266b 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -337,12 +337,12 @@ ((_) (gensym)))) (define put-global-definition-hook - (lambda (symbol binding module) - (let* ((module (if module - (resolve-module module) - (warn "wha" symbol (current-module)))) + (lambda (symbol binding modname) + (let* ((module (if modname + (resolve-module modname) + (current-module))) (v (or (module-variable module symbol) - (let ((v (make-variable sc-macro))) + (let ((v (make-variable 'sc-macro))) (module-add! module symbol v) v)))) ;; Don't destroy Guile macros corresponding to primitive syntax From a26934a850fba4ee1caf5d44cdbbe95115c91be0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 13:50:14 +0200 Subject: [PATCH 060/375] module-name returns '(guile) during boot; psyntax tweak * module/ice-9/boot-9.scm (module-name): Return '(guile) before the module system is booted, for syncase's benefit. Defer redefinition until the module system is booted. * module/ice-9/psyntax.scm (put-global-definition-hook): Only set a variable if it's unbound. * module/ice-9/psyntax.scm: Regenerated. --- module/ice-9/boot-9.scm | 6 ++++-- module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 7 ++----- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 1a8157ac6..5e658663e 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -128,7 +128,7 @@ ;; Before the module system boots, there are no module names. But ;; psyntax does want a module-name definition, so give it one. (define (module-name x) - #f) + '(guile)) (define (module-add! module sym var) (hashq-set! (%get-pre-modules-obarray) sym var)) @@ -1221,7 +1221,7 @@ (define module-transformer (record-accessor module-type 'transformer)) (define set-module-transformer! (record-modifier module-type 'transformer)) -(define module-name (record-accessor module-type 'name)) +;; (define module-name (record-accessor module-type 'name)) wait until mods are booted (define set-module-name! (record-modifier module-type 'name)) (define module-kind (record-accessor module-type 'kind)) (define set-module-kind! (record-modifier module-type 'kind)) @@ -1864,6 +1864,8 @@ ;; must have been defined by now. ;; (set-current-module the-root-module) +;; definition deferred for syncase's benefit +(define module-name (record-accessor module-type 'name)) ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 1ab522163..a870f8700 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,4 +1,4 @@ -(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-modname-1084) (let ((syntmp-module-1085 (if syntmp-modname-1084 (resolve-module syntmp-modname-1084) (current-module)))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable (quote sc-macro)))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (and (symbol-property syntmp-symbol-1082 (quote primitive-syntax)) (eq? syntmp-module-1085 the-syncase-module))) (variable-set! syntmp-v-1086 sc-macro)) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-head-1341 syntmp-tail-1342 syntmp-val-1343) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-head-1341 syntmp-r-1323 (quote (())) #f #f syntmp-mod-1326)) (lambda (syntmp-type-1344 syntmp-value-1345 syntmp-ee-1346 syntmp-ww-1347 syntmp-ss-1348 syntmp-modmod-1349) (let ((syntmp-t-1350 syntmp-type-1344)) (if (memv syntmp-t-1350 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1345 (cons syntmp-head-1341 syntmp-tail-1342))) (lambda (syntmp-id-1352 syntmp-mod-1353) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1353 syntmp-id-1352 #f) syntmp-val-1343)))) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1354) (syntmp-chi-153 syntmp-e-1354 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-tail-1342 (list syntmp-val-1343)))))))))) syntmp-tmp-1339) ((lambda (syntmp-_-1356) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1357) ((lambda (syntmp-tmp-1358) ((lambda (syntmp-tmp-1359) (if (if syntmp-tmp-1359 (apply (lambda (syntmp-_-1360 syntmp-mod-1361 syntmp-id-1362) (and (andmap syntmp-id?-117 syntmp-mod-1361) (syntmp-id?-117 syntmp-id-1362))) syntmp-tmp-1359) #f) (apply (lambda (syntmp-_-1364 syntmp-mod-1365 syntmp-id-1366) (values (syntax-object->datum syntmp-id-1366) (syntax-object->datum (append syntmp-mod-1365 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1359) (syntax-error syntmp-tmp-1358))) (syntax-dispatch syntmp-tmp-1358 (quote (any each-any any))))) syntmp-e-1357))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1368) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-mod-1372 syntmp-id-1373) (and (andmap syntmp-id?-117 syntmp-mod-1372) (syntmp-id?-117 syntmp-id-1373))) syntmp-tmp-1370) #f) (apply (lambda (syntmp-_-1375 syntmp-mod-1376 syntmp-id-1377) (values (syntax-object->datum syntmp-id-1377) (syntax-object->datum syntmp-mod-1376))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any each-any any))))) syntmp-e-1368))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1382 (lambda (syntmp-x-1383 syntmp-keys-1384 syntmp-clauses-1385 syntmp-r-1386 syntmp-mod-1387) (if (null? syntmp-clauses-1385) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1383)) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if syntmp-tmp-1389 (apply (lambda (syntmp-pat-1390 syntmp-exp-1391) (if (and (syntmp-id?-117 syntmp-pat-1390) (andmap (lambda (syntmp-x-1392) (not (syntmp-free-id=?-140 syntmp-pat-1390 syntmp-x-1392))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1384))) (let ((syntmp-labels-1393 (list (syntmp-gen-label-122))) (syntmp-var-1394 (syntmp-gen-var-165 syntmp-pat-1390))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1394) (syntmp-chi-153 syntmp-exp-1391 (syntmp-extend-env-111 syntmp-labels-1393 (list (cons (quote syntax) (cons syntmp-var-1394 0))) syntmp-r-1386) (syntmp-make-binding-wrap-134 (list syntmp-pat-1390) syntmp-labels-1393 (quote (()))) syntmp-mod-1387))) syntmp-x-1383))) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1390 #t syntmp-exp-1391 syntmp-mod-1387))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1395) (if syntmp-tmp-1395 (apply (lambda (syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398 syntmp-mod-1387)) syntmp-tmp-1395) ((lambda (syntmp-_-1399) (syntax-error (car syntmp-clauses-1385) "invalid syntax-case clause")) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) (car syntmp-clauses-1385))))) (syntmp-gen-clause-1381 (lambda (syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-pat-1404 syntmp-fender-1405 syntmp-exp-1406 syntmp-mod-1407) (call-with-values (lambda () (syntmp-convert-pattern-1379 syntmp-pat-1404 syntmp-keys-1401)) (lambda (syntmp-p-1408 syntmp-pvars-1409) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1409))) (syntax-error syntmp-pat-1404 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1410) (not (syntmp-ellipsis?-162 (car syntmp-x-1410)))) syntmp-pvars-1409)) (syntax-error syntmp-pat-1404 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1411 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1411) (let ((syntmp-y-1412 (syntmp-build-annotated-94 #f syntmp-y-1411))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1413) ((lambda (syntmp-tmp-1414) (if syntmp-tmp-1414 (apply (lambda () syntmp-y-1412) syntmp-tmp-1414) ((lambda (syntmp-_-1415) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1412 (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-fender-1405 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1413))) (syntax-dispatch syntmp-tmp-1413 (quote #(atom #t))))) syntmp-fender-1405) (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-exp-1406 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-gen-syntax-case-1382 syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-mod-1407)))))) (if (eq? syntmp-p-1408 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1400)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1400 (syntmp-build-data-95 #f syntmp-p-1408))))))))))))) (syntmp-build-dispatch-call-1380 (lambda (syntmp-pvars-1416 syntmp-exp-1417 syntmp-y-1418 syntmp-r-1419 syntmp-mod-1420) (let ((syntmp-ids-1421 (map car syntmp-pvars-1416)) (syntmp-levels-1422 (map cdr syntmp-pvars-1416))) (let ((syntmp-labels-1423 (syntmp-gen-labels-123 syntmp-ids-1421)) (syntmp-new-vars-1424 (map syntmp-gen-var-165 syntmp-ids-1421))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1424 (syntmp-chi-153 syntmp-exp-1417 (syntmp-extend-env-111 syntmp-labels-1423 (map (lambda (syntmp-var-1425 syntmp-level-1426) (cons (quote syntax) (cons syntmp-var-1425 syntmp-level-1426))) syntmp-new-vars-1424 (map cdr syntmp-pvars-1416)) syntmp-r-1419) (syntmp-make-binding-wrap-134 syntmp-ids-1421 syntmp-labels-1423 (quote (()))) syntmp-mod-1420))) syntmp-y-1418)))))) (syntmp-convert-pattern-1379 (lambda (syntmp-pattern-1427 syntmp-keys-1428) (let syntmp-cvt-1429 ((syntmp-p-1430 syntmp-pattern-1427) (syntmp-n-1431 0) (syntmp-ids-1432 (quote ()))) (if (syntmp-id?-117 syntmp-p-1430) (if (syntmp-bound-id-member?-144 syntmp-p-1430 syntmp-keys-1428) (values (vector (quote free-id) syntmp-p-1430) syntmp-ids-1432) (values (quote any) (cons (cons syntmp-p-1430 syntmp-n-1431) syntmp-ids-1432))) ((lambda (syntmp-tmp-1433) ((lambda (syntmp-tmp-1434) (if (if syntmp-tmp-1434 (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (syntmp-ellipsis?-162 syntmp-dots-1436)) syntmp-tmp-1434) #f) (apply (lambda (syntmp-x-1437 syntmp-dots-1438) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1437 (syntmp-fx+-85 syntmp-n-1431 1) syntmp-ids-1432)) (lambda (syntmp-p-1439 syntmp-ids-1440) (values (if (eq? syntmp-p-1439 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1439)) syntmp-ids-1440)))) syntmp-tmp-1434) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-x-1442 syntmp-y-1443) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-y-1443 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-y-1444 syntmp-ids-1445) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1442 syntmp-n-1431 syntmp-ids-1445)) (lambda (syntmp-x-1446 syntmp-ids-1447) (values (cons syntmp-x-1446 syntmp-y-1444) syntmp-ids-1447)))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda () (values (quote ()) syntmp-ids-1432)) syntmp-tmp-1448) ((lambda (syntmp-tmp-1449) (if syntmp-tmp-1449 (apply (lambda (syntmp-x-1450) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1450 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-p-1452 syntmp-ids-1453) (values (vector (quote vector) syntmp-p-1452) syntmp-ids-1453)))) syntmp-tmp-1449) ((lambda (syntmp-x-1454) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1430 (quote (())))) syntmp-ids-1432)) syntmp-tmp-1433))) (syntax-dispatch syntmp-tmp-1433 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1433 (quote ()))))) (syntax-dispatch syntmp-tmp-1433 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1433 (quote (any any))))) syntmp-p-1430)))))) (lambda (syntmp-e-1455 syntmp-r-1456 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459) (let ((syntmp-e-1460 (syntmp-source-wrap-146 syntmp-e-1455 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459))) ((lambda (syntmp-tmp-1461) ((lambda (syntmp-tmp-1462) (if syntmp-tmp-1462 (apply (lambda (syntmp-_-1463 syntmp-val-1464 syntmp-key-1465 syntmp-m-1466) (if (andmap (lambda (syntmp-x-1467) (and (syntmp-id?-117 syntmp-x-1467) (not (syntmp-ellipsis?-162 syntmp-x-1467)))) syntmp-key-1465) (let ((syntmp-x-1469 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1458 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1469) (syntmp-gen-syntax-case-1382 (syntmp-build-annotated-94 #f syntmp-x-1469) syntmp-key-1465 syntmp-m-1466 syntmp-r-1456 syntmp-mod-1459))) (syntmp-chi-153 syntmp-val-1464 syntmp-r-1456 (quote (())) syntmp-mod-1459)))) (syntax-error syntmp-e-1460 "invalid literals list in"))) syntmp-tmp-1462) (syntax-error syntmp-tmp-1461))) (syntax-dispatch syntmp-tmp-1461 (quote (any any each-any . each-any))))) syntmp-e-1460))))) (set! sc-expand (let ((syntmp-m-1472 (quote e)) (syntmp-esew-1473 (quote (eval)))) (lambda (syntmp-x-1474) (if (and (pair? syntmp-x-1474) (equal? (car syntmp-x-1474) syntmp-noexpand-84)) (cadr syntmp-x-1474) (syntmp-chi-top-152 syntmp-x-1474 (quote ()) (quote ((top))) syntmp-m-1472 syntmp-esew-1473 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1475 (quote e)) (syntmp-esew-1476 (quote (eval)))) (lambda (syntmp-x-1478 . syntmp-rest-1477) (if (and (pair? syntmp-x-1478) (equal? (car syntmp-x-1478) syntmp-noexpand-84)) (cadr syntmp-x-1478) (syntmp-chi-top-152 syntmp-x-1478 (quote ()) (quote ((top))) (if (null? syntmp-rest-1477) syntmp-m-1475 (car syntmp-rest-1477)) (if (or (null? syntmp-rest-1477) (null? (cdr syntmp-rest-1477))) syntmp-esew-1476 (cadr syntmp-rest-1477)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1479) (syntmp-nonsymbol-id?-116 syntmp-x-1479))) (set! datum->syntax-object (lambda (syntmp-id-1480 syntmp-datum-1481) (syntmp-make-syntax-object-100 syntmp-datum-1481 (syntmp-syntax-object-wrap-103 syntmp-id-1480) #f))) (set! syntax-object->datum (lambda (syntmp-x-1482) (syntmp-strip-164 syntmp-x-1482 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1483) (begin (let ((syntmp-x-1484 syntmp-ls-1483)) (if (not (list? syntmp-x-1484)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1484))) (map (lambda (syntmp-x-1485) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1483)))) (set! free-identifier=? (lambda (syntmp-x-1486 syntmp-y-1487) (begin (let ((syntmp-x-1488 syntmp-x-1486)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1488)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1488))) (let ((syntmp-x-1489 syntmp-y-1487)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1489)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1489))) (syntmp-free-id=?-140 syntmp-x-1486 syntmp-y-1487)))) (set! bound-identifier=? (lambda (syntmp-x-1490 syntmp-y-1491) (begin (let ((syntmp-x-1492 syntmp-x-1490)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1492)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1492))) (let ((syntmp-x-1493 syntmp-y-1491)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1493)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1493))) (syntmp-bound-id=?-141 syntmp-x-1490 syntmp-y-1491)))) (set! syntax-error (lambda (syntmp-object-1495 . syntmp-messages-1494) (begin (for-each (lambda (syntmp-x-1496) (let ((syntmp-x-1497 syntmp-x-1496)) (if (not (string? syntmp-x-1497)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1497)))) syntmp-messages-1494) (let ((syntmp-message-1498 (if (null? syntmp-messages-1494) "invalid syntax" (apply string-append syntmp-messages-1494)))) (syntmp-error-hook-91 #f syntmp-message-1498 (syntmp-strip-164 syntmp-object-1495 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1499 syntmp-v-1500) (begin (let ((syntmp-x-1501 syntmp-sym-1499)) (if (not (symbol? syntmp-x-1501)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1501))) (let ((syntmp-x-1502 syntmp-v-1500)) (if (not (procedure? syntmp-x-1502)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1502))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1499 syntmp-v-1500)))) (letrec ((syntmp-match-1507 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512) (cond ((not syntmp-r-1511) #f) ((eq? syntmp-p-1509 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1508 syntmp-w-1510 syntmp-mod-1512) syntmp-r-1511)) ((syntmp-syntax-object?-101 syntmp-e-1508) (syntmp-match*-1506 (let ((syntmp-e-1513 (syntmp-syntax-object-expression-102 syntmp-e-1508))) (if (annotation? syntmp-e-1513) (annotation-expression syntmp-e-1513) syntmp-e-1513)) syntmp-p-1509 (syntmp-join-wraps-136 syntmp-w-1510 (syntmp-syntax-object-wrap-103 syntmp-e-1508)) syntmp-r-1511 (syntmp-syntax-object-module-104 syntmp-e-1508))) (else (syntmp-match*-1506 (let ((syntmp-e-1514 syntmp-e-1508)) (if (annotation? syntmp-e-1514) (annotation-expression syntmp-e-1514) syntmp-e-1514)) syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512))))) (syntmp-match*-1506 (lambda (syntmp-e-1515 syntmp-p-1516 syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) (cond ((null? syntmp-p-1516) (and (null? syntmp-e-1515) syntmp-r-1518)) ((pair? syntmp-p-1516) (and (pair? syntmp-e-1515) (syntmp-match-1507 (car syntmp-e-1515) (car syntmp-p-1516) syntmp-w-1517 (syntmp-match-1507 (cdr syntmp-e-1515) (cdr syntmp-p-1516) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) syntmp-mod-1519))) ((eq? syntmp-p-1516 (quote each-any)) (let ((syntmp-l-1520 (syntmp-match-each-any-1504 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1520 (cons syntmp-l-1520 syntmp-r-1518)))) (else (let ((syntmp-t-1521 (vector-ref syntmp-p-1516 0))) (if (memv syntmp-t-1521 (quote (each))) (if (null? syntmp-e-1515) (syntmp-match-empty-1505 (vector-ref syntmp-p-1516 1) syntmp-r-1518) (let ((syntmp-l-1522 (syntmp-match-each-1503 syntmp-e-1515 (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1522 (let syntmp-collect-1523 ((syntmp-l-1524 syntmp-l-1522)) (if (null? (car syntmp-l-1524)) syntmp-r-1518 (cons (map car syntmp-l-1524) (syntmp-collect-1523 (map cdr syntmp-l-1524)))))))) (if (memv syntmp-t-1521 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1515) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519) (vector-ref syntmp-p-1516 1)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (atom))) (and (equal? (vector-ref syntmp-p-1516 1) (syntmp-strip-164 syntmp-e-1515 syntmp-w-1517)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (vector))) (and (vector? syntmp-e-1515) (syntmp-match-1507 (vector->list syntmp-e-1515) (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519))))))))))) (syntmp-match-empty-1505 (lambda (syntmp-p-1525 syntmp-r-1526) (cond ((null? syntmp-p-1525) syntmp-r-1526) ((eq? syntmp-p-1525 (quote any)) (cons (quote ()) syntmp-r-1526)) ((pair? syntmp-p-1525) (syntmp-match-empty-1505 (car syntmp-p-1525) (syntmp-match-empty-1505 (cdr syntmp-p-1525) syntmp-r-1526))) ((eq? syntmp-p-1525 (quote each-any)) (cons (quote ()) syntmp-r-1526)) (else (let ((syntmp-t-1527 (vector-ref syntmp-p-1525 0))) (if (memv syntmp-t-1527 (quote (each))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526) (if (memv syntmp-t-1527 (quote (free-id atom))) syntmp-r-1526 (if (memv syntmp-t-1527 (quote (vector))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526))))))))) (syntmp-match-each-any-1504 (lambda (syntmp-e-1528 syntmp-w-1529 syntmp-mod-1530) (cond ((annotation? syntmp-e-1528) (syntmp-match-each-any-1504 (annotation-expression syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530)) ((pair? syntmp-e-1528) (let ((syntmp-l-1531 (syntmp-match-each-any-1504 (cdr syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530))) (and syntmp-l-1531 (cons (syntmp-wrap-145 (car syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530) syntmp-l-1531)))) ((null? syntmp-e-1528) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1528) (syntmp-match-each-any-1504 (syntmp-syntax-object-expression-102 syntmp-e-1528) (syntmp-join-wraps-136 syntmp-w-1529 (syntmp-syntax-object-wrap-103 syntmp-e-1528)) syntmp-mod-1530)) (else #f)))) (syntmp-match-each-1503 (lambda (syntmp-e-1532 syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535) (cond ((annotation? syntmp-e-1532) (syntmp-match-each-1503 (annotation-expression syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535)) ((pair? syntmp-e-1532) (let ((syntmp-first-1536 (syntmp-match-1507 (car syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 (quote ()) syntmp-mod-1535))) (and syntmp-first-1536 (let ((syntmp-rest-1537 (syntmp-match-each-1503 (cdr syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535))) (and syntmp-rest-1537 (cons syntmp-first-1536 syntmp-rest-1537)))))) ((null? syntmp-e-1532) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1532) (syntmp-match-each-1503 (syntmp-syntax-object-expression-102 syntmp-e-1532) syntmp-p-1533 (syntmp-join-wraps-136 syntmp-w-1534 (syntmp-syntax-object-wrap-103 syntmp-e-1532)) (syntmp-syntax-object-module-104 syntmp-e-1532))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1538 syntmp-p-1539) (cond ((eq? syntmp-p-1539 (quote any)) (list syntmp-e-1538)) ((syntmp-syntax-object?-101 syntmp-e-1538) (syntmp-match*-1506 (let ((syntmp-e-1540 (syntmp-syntax-object-expression-102 syntmp-e-1538))) (if (annotation? syntmp-e-1540) (annotation-expression syntmp-e-1540) syntmp-e-1540)) syntmp-p-1539 (syntmp-syntax-object-wrap-103 syntmp-e-1538) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1538))) (else (syntmp-match*-1506 (let ((syntmp-e-1541 syntmp-e-1538)) (if (annotation? syntmp-e-1541) (annotation-expression syntmp-e-1541) syntmp-e-1541)) syntmp-p-1539 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-modname-1084) (let ((syntmp-module-1085 (if syntmp-modname-1084 (resolve-module syntmp-modname-1084) (current-module)))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable (quote sc-macro)))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (variable-bound? syntmp-v-1086)) (variable-set! syntmp-v-1086 (gensym))) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-head-1341 syntmp-tail-1342 syntmp-val-1343) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-head-1341 syntmp-r-1323 (quote (())) #f #f syntmp-mod-1326)) (lambda (syntmp-type-1344 syntmp-value-1345 syntmp-ee-1346 syntmp-ww-1347 syntmp-ss-1348 syntmp-modmod-1349) (let ((syntmp-t-1350 syntmp-type-1344)) (if (memv syntmp-t-1350 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1345 (cons syntmp-head-1341 syntmp-tail-1342))) (lambda (syntmp-id-1352 syntmp-mod-1353) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1353 syntmp-id-1352 #f) syntmp-val-1343)))) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1354) (syntmp-chi-153 syntmp-e-1354 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-tail-1342 (list syntmp-val-1343)))))))))) syntmp-tmp-1339) ((lambda (syntmp-_-1356) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1357) ((lambda (syntmp-tmp-1358) ((lambda (syntmp-tmp-1359) (if (if syntmp-tmp-1359 (apply (lambda (syntmp-_-1360 syntmp-mod-1361 syntmp-id-1362) (and (andmap syntmp-id?-117 syntmp-mod-1361) (syntmp-id?-117 syntmp-id-1362))) syntmp-tmp-1359) #f) (apply (lambda (syntmp-_-1364 syntmp-mod-1365 syntmp-id-1366) (values (syntax-object->datum syntmp-id-1366) (syntax-object->datum (append syntmp-mod-1365 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1359) (syntax-error syntmp-tmp-1358))) (syntax-dispatch syntmp-tmp-1358 (quote (any each-any any))))) syntmp-e-1357))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1368) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-mod-1372 syntmp-id-1373) (and (andmap syntmp-id?-117 syntmp-mod-1372) (syntmp-id?-117 syntmp-id-1373))) syntmp-tmp-1370) #f) (apply (lambda (syntmp-_-1375 syntmp-mod-1376 syntmp-id-1377) (values (syntax-object->datum syntmp-id-1377) (syntax-object->datum syntmp-mod-1376))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any each-any any))))) syntmp-e-1368))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1382 (lambda (syntmp-x-1383 syntmp-keys-1384 syntmp-clauses-1385 syntmp-r-1386 syntmp-mod-1387) (if (null? syntmp-clauses-1385) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1383)) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if syntmp-tmp-1389 (apply (lambda (syntmp-pat-1390 syntmp-exp-1391) (if (and (syntmp-id?-117 syntmp-pat-1390) (andmap (lambda (syntmp-x-1392) (not (syntmp-free-id=?-140 syntmp-pat-1390 syntmp-x-1392))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1384))) (let ((syntmp-labels-1393 (list (syntmp-gen-label-122))) (syntmp-var-1394 (syntmp-gen-var-165 syntmp-pat-1390))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1394) (syntmp-chi-153 syntmp-exp-1391 (syntmp-extend-env-111 syntmp-labels-1393 (list (cons (quote syntax) (cons syntmp-var-1394 0))) syntmp-r-1386) (syntmp-make-binding-wrap-134 (list syntmp-pat-1390) syntmp-labels-1393 (quote (()))) syntmp-mod-1387))) syntmp-x-1383))) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1390 #t syntmp-exp-1391 syntmp-mod-1387))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1395) (if syntmp-tmp-1395 (apply (lambda (syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398 syntmp-mod-1387)) syntmp-tmp-1395) ((lambda (syntmp-_-1399) (syntax-error (car syntmp-clauses-1385) "invalid syntax-case clause")) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) (car syntmp-clauses-1385))))) (syntmp-gen-clause-1381 (lambda (syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-pat-1404 syntmp-fender-1405 syntmp-exp-1406 syntmp-mod-1407) (call-with-values (lambda () (syntmp-convert-pattern-1379 syntmp-pat-1404 syntmp-keys-1401)) (lambda (syntmp-p-1408 syntmp-pvars-1409) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1409))) (syntax-error syntmp-pat-1404 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1410) (not (syntmp-ellipsis?-162 (car syntmp-x-1410)))) syntmp-pvars-1409)) (syntax-error syntmp-pat-1404 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1411 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1411) (let ((syntmp-y-1412 (syntmp-build-annotated-94 #f syntmp-y-1411))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1413) ((lambda (syntmp-tmp-1414) (if syntmp-tmp-1414 (apply (lambda () syntmp-y-1412) syntmp-tmp-1414) ((lambda (syntmp-_-1415) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1412 (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-fender-1405 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1413))) (syntax-dispatch syntmp-tmp-1413 (quote #(atom #t))))) syntmp-fender-1405) (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-exp-1406 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-gen-syntax-case-1382 syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-mod-1407)))))) (if (eq? syntmp-p-1408 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1400)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1400 (syntmp-build-data-95 #f syntmp-p-1408))))))))))))) (syntmp-build-dispatch-call-1380 (lambda (syntmp-pvars-1416 syntmp-exp-1417 syntmp-y-1418 syntmp-r-1419 syntmp-mod-1420) (let ((syntmp-ids-1421 (map car syntmp-pvars-1416)) (syntmp-levels-1422 (map cdr syntmp-pvars-1416))) (let ((syntmp-labels-1423 (syntmp-gen-labels-123 syntmp-ids-1421)) (syntmp-new-vars-1424 (map syntmp-gen-var-165 syntmp-ids-1421))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1424 (syntmp-chi-153 syntmp-exp-1417 (syntmp-extend-env-111 syntmp-labels-1423 (map (lambda (syntmp-var-1425 syntmp-level-1426) (cons (quote syntax) (cons syntmp-var-1425 syntmp-level-1426))) syntmp-new-vars-1424 (map cdr syntmp-pvars-1416)) syntmp-r-1419) (syntmp-make-binding-wrap-134 syntmp-ids-1421 syntmp-labels-1423 (quote (()))) syntmp-mod-1420))) syntmp-y-1418)))))) (syntmp-convert-pattern-1379 (lambda (syntmp-pattern-1427 syntmp-keys-1428) (let syntmp-cvt-1429 ((syntmp-p-1430 syntmp-pattern-1427) (syntmp-n-1431 0) (syntmp-ids-1432 (quote ()))) (if (syntmp-id?-117 syntmp-p-1430) (if (syntmp-bound-id-member?-144 syntmp-p-1430 syntmp-keys-1428) (values (vector (quote free-id) syntmp-p-1430) syntmp-ids-1432) (values (quote any) (cons (cons syntmp-p-1430 syntmp-n-1431) syntmp-ids-1432))) ((lambda (syntmp-tmp-1433) ((lambda (syntmp-tmp-1434) (if (if syntmp-tmp-1434 (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (syntmp-ellipsis?-162 syntmp-dots-1436)) syntmp-tmp-1434) #f) (apply (lambda (syntmp-x-1437 syntmp-dots-1438) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1437 (syntmp-fx+-85 syntmp-n-1431 1) syntmp-ids-1432)) (lambda (syntmp-p-1439 syntmp-ids-1440) (values (if (eq? syntmp-p-1439 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1439)) syntmp-ids-1440)))) syntmp-tmp-1434) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-x-1442 syntmp-y-1443) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-y-1443 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-y-1444 syntmp-ids-1445) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1442 syntmp-n-1431 syntmp-ids-1445)) (lambda (syntmp-x-1446 syntmp-ids-1447) (values (cons syntmp-x-1446 syntmp-y-1444) syntmp-ids-1447)))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda () (values (quote ()) syntmp-ids-1432)) syntmp-tmp-1448) ((lambda (syntmp-tmp-1449) (if syntmp-tmp-1449 (apply (lambda (syntmp-x-1450) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1450 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-p-1452 syntmp-ids-1453) (values (vector (quote vector) syntmp-p-1452) syntmp-ids-1453)))) syntmp-tmp-1449) ((lambda (syntmp-x-1454) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1430 (quote (())))) syntmp-ids-1432)) syntmp-tmp-1433))) (syntax-dispatch syntmp-tmp-1433 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1433 (quote ()))))) (syntax-dispatch syntmp-tmp-1433 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1433 (quote (any any))))) syntmp-p-1430)))))) (lambda (syntmp-e-1455 syntmp-r-1456 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459) (let ((syntmp-e-1460 (syntmp-source-wrap-146 syntmp-e-1455 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459))) ((lambda (syntmp-tmp-1461) ((lambda (syntmp-tmp-1462) (if syntmp-tmp-1462 (apply (lambda (syntmp-_-1463 syntmp-val-1464 syntmp-key-1465 syntmp-m-1466) (if (andmap (lambda (syntmp-x-1467) (and (syntmp-id?-117 syntmp-x-1467) (not (syntmp-ellipsis?-162 syntmp-x-1467)))) syntmp-key-1465) (let ((syntmp-x-1469 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1458 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1469) (syntmp-gen-syntax-case-1382 (syntmp-build-annotated-94 #f syntmp-x-1469) syntmp-key-1465 syntmp-m-1466 syntmp-r-1456 syntmp-mod-1459))) (syntmp-chi-153 syntmp-val-1464 syntmp-r-1456 (quote (())) syntmp-mod-1459)))) (syntax-error syntmp-e-1460 "invalid literals list in"))) syntmp-tmp-1462) (syntax-error syntmp-tmp-1461))) (syntax-dispatch syntmp-tmp-1461 (quote (any any each-any . each-any))))) syntmp-e-1460))))) (set! sc-expand (let ((syntmp-m-1472 (quote e)) (syntmp-esew-1473 (quote (eval)))) (lambda (syntmp-x-1474) (if (and (pair? syntmp-x-1474) (equal? (car syntmp-x-1474) syntmp-noexpand-84)) (cadr syntmp-x-1474) (syntmp-chi-top-152 syntmp-x-1474 (quote ()) (quote ((top))) syntmp-m-1472 syntmp-esew-1473 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1475 (quote e)) (syntmp-esew-1476 (quote (eval)))) (lambda (syntmp-x-1478 . syntmp-rest-1477) (if (and (pair? syntmp-x-1478) (equal? (car syntmp-x-1478) syntmp-noexpand-84)) (cadr syntmp-x-1478) (syntmp-chi-top-152 syntmp-x-1478 (quote ()) (quote ((top))) (if (null? syntmp-rest-1477) syntmp-m-1475 (car syntmp-rest-1477)) (if (or (null? syntmp-rest-1477) (null? (cdr syntmp-rest-1477))) syntmp-esew-1476 (cadr syntmp-rest-1477)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1479) (syntmp-nonsymbol-id?-116 syntmp-x-1479))) (set! datum->syntax-object (lambda (syntmp-id-1480 syntmp-datum-1481) (syntmp-make-syntax-object-100 syntmp-datum-1481 (syntmp-syntax-object-wrap-103 syntmp-id-1480) #f))) (set! syntax-object->datum (lambda (syntmp-x-1482) (syntmp-strip-164 syntmp-x-1482 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1483) (begin (let ((syntmp-x-1484 syntmp-ls-1483)) (if (not (list? syntmp-x-1484)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1484))) (map (lambda (syntmp-x-1485) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1483)))) (set! free-identifier=? (lambda (syntmp-x-1486 syntmp-y-1487) (begin (let ((syntmp-x-1488 syntmp-x-1486)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1488)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1488))) (let ((syntmp-x-1489 syntmp-y-1487)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1489)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1489))) (syntmp-free-id=?-140 syntmp-x-1486 syntmp-y-1487)))) (set! bound-identifier=? (lambda (syntmp-x-1490 syntmp-y-1491) (begin (let ((syntmp-x-1492 syntmp-x-1490)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1492)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1492))) (let ((syntmp-x-1493 syntmp-y-1491)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1493)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1493))) (syntmp-bound-id=?-141 syntmp-x-1490 syntmp-y-1491)))) (set! syntax-error (lambda (syntmp-object-1495 . syntmp-messages-1494) (begin (for-each (lambda (syntmp-x-1496) (let ((syntmp-x-1497 syntmp-x-1496)) (if (not (string? syntmp-x-1497)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1497)))) syntmp-messages-1494) (let ((syntmp-message-1498 (if (null? syntmp-messages-1494) "invalid syntax" (apply string-append syntmp-messages-1494)))) (syntmp-error-hook-91 #f syntmp-message-1498 (syntmp-strip-164 syntmp-object-1495 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1499 syntmp-v-1500) (begin (let ((syntmp-x-1501 syntmp-sym-1499)) (if (not (symbol? syntmp-x-1501)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1501))) (let ((syntmp-x-1502 syntmp-v-1500)) (if (not (procedure? syntmp-x-1502)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1502))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1499 syntmp-v-1500)))) (letrec ((syntmp-match-1507 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512) (cond ((not syntmp-r-1511) #f) ((eq? syntmp-p-1509 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1508 syntmp-w-1510 syntmp-mod-1512) syntmp-r-1511)) ((syntmp-syntax-object?-101 syntmp-e-1508) (syntmp-match*-1506 (let ((syntmp-e-1513 (syntmp-syntax-object-expression-102 syntmp-e-1508))) (if (annotation? syntmp-e-1513) (annotation-expression syntmp-e-1513) syntmp-e-1513)) syntmp-p-1509 (syntmp-join-wraps-136 syntmp-w-1510 (syntmp-syntax-object-wrap-103 syntmp-e-1508)) syntmp-r-1511 (syntmp-syntax-object-module-104 syntmp-e-1508))) (else (syntmp-match*-1506 (let ((syntmp-e-1514 syntmp-e-1508)) (if (annotation? syntmp-e-1514) (annotation-expression syntmp-e-1514) syntmp-e-1514)) syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512))))) (syntmp-match*-1506 (lambda (syntmp-e-1515 syntmp-p-1516 syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) (cond ((null? syntmp-p-1516) (and (null? syntmp-e-1515) syntmp-r-1518)) ((pair? syntmp-p-1516) (and (pair? syntmp-e-1515) (syntmp-match-1507 (car syntmp-e-1515) (car syntmp-p-1516) syntmp-w-1517 (syntmp-match-1507 (cdr syntmp-e-1515) (cdr syntmp-p-1516) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) syntmp-mod-1519))) ((eq? syntmp-p-1516 (quote each-any)) (let ((syntmp-l-1520 (syntmp-match-each-any-1504 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1520 (cons syntmp-l-1520 syntmp-r-1518)))) (else (let ((syntmp-t-1521 (vector-ref syntmp-p-1516 0))) (if (memv syntmp-t-1521 (quote (each))) (if (null? syntmp-e-1515) (syntmp-match-empty-1505 (vector-ref syntmp-p-1516 1) syntmp-r-1518) (let ((syntmp-l-1522 (syntmp-match-each-1503 syntmp-e-1515 (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1522 (let syntmp-collect-1523 ((syntmp-l-1524 syntmp-l-1522)) (if (null? (car syntmp-l-1524)) syntmp-r-1518 (cons (map car syntmp-l-1524) (syntmp-collect-1523 (map cdr syntmp-l-1524)))))))) (if (memv syntmp-t-1521 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1515) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519) (vector-ref syntmp-p-1516 1)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (atom))) (and (equal? (vector-ref syntmp-p-1516 1) (syntmp-strip-164 syntmp-e-1515 syntmp-w-1517)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (vector))) (and (vector? syntmp-e-1515) (syntmp-match-1507 (vector->list syntmp-e-1515) (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519))))))))))) (syntmp-match-empty-1505 (lambda (syntmp-p-1525 syntmp-r-1526) (cond ((null? syntmp-p-1525) syntmp-r-1526) ((eq? syntmp-p-1525 (quote any)) (cons (quote ()) syntmp-r-1526)) ((pair? syntmp-p-1525) (syntmp-match-empty-1505 (car syntmp-p-1525) (syntmp-match-empty-1505 (cdr syntmp-p-1525) syntmp-r-1526))) ((eq? syntmp-p-1525 (quote each-any)) (cons (quote ()) syntmp-r-1526)) (else (let ((syntmp-t-1527 (vector-ref syntmp-p-1525 0))) (if (memv syntmp-t-1527 (quote (each))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526) (if (memv syntmp-t-1527 (quote (free-id atom))) syntmp-r-1526 (if (memv syntmp-t-1527 (quote (vector))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526))))))))) (syntmp-match-each-any-1504 (lambda (syntmp-e-1528 syntmp-w-1529 syntmp-mod-1530) (cond ((annotation? syntmp-e-1528) (syntmp-match-each-any-1504 (annotation-expression syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530)) ((pair? syntmp-e-1528) (let ((syntmp-l-1531 (syntmp-match-each-any-1504 (cdr syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530))) (and syntmp-l-1531 (cons (syntmp-wrap-145 (car syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530) syntmp-l-1531)))) ((null? syntmp-e-1528) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1528) (syntmp-match-each-any-1504 (syntmp-syntax-object-expression-102 syntmp-e-1528) (syntmp-join-wraps-136 syntmp-w-1529 (syntmp-syntax-object-wrap-103 syntmp-e-1528)) syntmp-mod-1530)) (else #f)))) (syntmp-match-each-1503 (lambda (syntmp-e-1532 syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535) (cond ((annotation? syntmp-e-1532) (syntmp-match-each-1503 (annotation-expression syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535)) ((pair? syntmp-e-1532) (let ((syntmp-first-1536 (syntmp-match-1507 (car syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 (quote ()) syntmp-mod-1535))) (and syntmp-first-1536 (let ((syntmp-rest-1537 (syntmp-match-each-1503 (cdr syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535))) (and syntmp-rest-1537 (cons syntmp-first-1536 syntmp-rest-1537)))))) ((null? syntmp-e-1532) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1532) (syntmp-match-each-1503 (syntmp-syntax-object-expression-102 syntmp-e-1532) syntmp-p-1533 (syntmp-join-wraps-136 syntmp-w-1534 (syntmp-syntax-object-wrap-103 syntmp-e-1532)) (syntmp-syntax-object-module-104 syntmp-e-1532))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1538 syntmp-p-1539) (cond ((eq? syntmp-p-1539 (quote any)) (list syntmp-e-1538)) ((syntmp-syntax-object?-101 syntmp-e-1538) (syntmp-match*-1506 (let ((syntmp-e-1540 (syntmp-syntax-object-expression-102 syntmp-e-1538))) (if (annotation? syntmp-e-1540) (annotation-expression syntmp-e-1540) syntmp-e-1540)) syntmp-p-1539 (syntmp-syntax-object-wrap-103 syntmp-e-1538) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1538))) (else (syntmp-match*-1506 (let ((syntmp-e-1541 syntmp-e-1538)) (if (annotation? syntmp-e-1541) (annotation-expression syntmp-e-1541) syntmp-e-1541)) syntmp-p-1539 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) (install-global-transformer (quote with-syntax) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-e1-1546 syntmp-e2-1547) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1546 syntmp-e2-1547))) syntmp-tmp-1544) ((lambda (syntmp-tmp-1549) (if syntmp-tmp-1549 (apply (lambda (syntmp-_-1550 syntmp-out-1551 syntmp-in-1552 syntmp-e1-1553 syntmp-e2-1554) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1552 (quote ()) (list syntmp-out-1551 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1553 syntmp-e2-1554))))) syntmp-tmp-1549) ((lambda (syntmp-tmp-1556) (if syntmp-tmp-1556 (apply (lambda (syntmp-_-1557 syntmp-out-1558 syntmp-in-1559 syntmp-e1-1560 syntmp-e2-1561) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1559) (quote ()) (list syntmp-out-1558 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1560 syntmp-e2-1561))))) syntmp-tmp-1556) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any () any . each-any))))) syntmp-x-1542))) (install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1583) ((lambda (syntmp-tmp-1584) ((lambda (syntmp-tmp-1585) (if syntmp-tmp-1585 (apply (lambda (syntmp-_-1586 syntmp-k-1587 syntmp-keyword-1588 syntmp-pattern-1589 syntmp-template-1590) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1587 (map (lambda (syntmp-tmp-1593 syntmp-tmp-1592) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1592) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1593))) syntmp-template-1590 syntmp-pattern-1589)))))) syntmp-tmp-1585) (syntax-error syntmp-tmp-1584))) (syntax-dispatch syntmp-tmp-1584 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1583))) (install-global-transformer (quote let*) (lambda (syntmp-x-1604) ((lambda (syntmp-tmp-1605) ((lambda (syntmp-tmp-1606) (if (if syntmp-tmp-1606 (apply (lambda (syntmp-let*-1607 syntmp-x-1608 syntmp-v-1609 syntmp-e1-1610 syntmp-e2-1611) (andmap identifier? syntmp-x-1608)) syntmp-tmp-1606) #f) (apply (lambda (syntmp-let*-1613 syntmp-x-1614 syntmp-v-1615 syntmp-e1-1616 syntmp-e2-1617) (let syntmp-f-1618 ((syntmp-bindings-1619 (map list syntmp-x-1614 syntmp-v-1615))) (if (null? syntmp-bindings-1619) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1616 syntmp-e2-1617))) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-body-1625 syntmp-binding-1626) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1626) syntmp-body-1625)) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any any))))) (list (syntmp-f-1618 (cdr syntmp-bindings-1619)) (car syntmp-bindings-1619)))))) syntmp-tmp-1606) (syntax-error syntmp-tmp-1605))) (syntax-dispatch syntmp-tmp-1605 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1604))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index a9159266b..9b65339c8 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -345,11 +345,8 @@ (let ((v (make-variable 'sc-macro))) (module-add! module symbol v) v)))) - ;; Don't destroy Guile macros corresponding to primitive syntax - ;; when syncase boots. - (if (not (and (symbol-property symbol 'primitive-syntax) - (eq? module the-syncase-module))) - (variable-set! v sc-macro)) + (if (not (variable-bound? v)) + (variable-set! v (gensym))) ;; Properties are tied to variable objects (set-object-property! v '*sc-expander* binding)))) From 131826039c62bdfd5932272b5d19d4b08cbe4e63 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 13:54:38 +0200 Subject: [PATCH 061/375] syncase early in boot-9, defmacros in terms of syntax-case -- halfway working * module/ice-9/boot-9.scm (eval-when): Remove, as syncase is going to handle this one for us. (sc-expand, sc-expand3, sc-chi, install-global-transformer) (syntax-dispatch, syntax-error, annotation?, bound-identifier=?) (datum->syntax-object, free-identifier=?, generate-temporaries) (identifier?, syntax-object->datum, void, andmap): Oh, ugly of uglies: add these exciting definitions to the main environment. Hopefully we can pull them back out soon. (make-module-ref, resolve-module): Stub these out, as a replacement for expand-support. (%pre-modules-transformer): Define to sc-expand, so that we are using syncase from the very start. (defmacro, define-macro): Define in terms of syntax-case. (macroexpand, macroexpand-1): Remove, there should be a different way to get at this -- though perhaps with the same name. (make-module): Make sc-expand the default module-transformer. (process-define-module): Issue a deprecation warning when using ice-9 syncase. (primitive-macro?): Remove, no meaning... (use-syntax): Deprecate. (define-private, define-public, defmacro-public): Rework in terms of syntax-rules. * module/ice-9/syncase.scm: Gut, as syncase is provided by core now. --- module/ice-9/boot-9.scm | 274 ++++++++++++++++++--------------------- module/ice-9/syncase.scm | 200 ++-------------------------- 2 files changed, 135 insertions(+), 339 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5e658663e..923c042ff 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -131,30 +131,63 @@ '(guile)) (define (module-add! module sym var) (hashq-set! (%get-pre-modules-obarray) sym var)) +(define sc-macro 'sc-macro) +(define (make-module-ref mod var public?) + (cond + ((or (not mod) + (eq? mod (module-name (current-module))) + (and (not public?) + (not (module-variable (resolve-module mod) var)))) + var) + (else + (list (if public? '@ '@@) mod var)))) +(define (resolve-module . args) + #f) -;; (eval-when (situation...) form...) -;; -;; Evaluate certain code based on the situation that eval-when is used -;; in. There are three situations defined. -;; -;; `load' triggers when a file is loaded via `load', or when a compiled -;; file is loaded. -;; -;; `compile' triggers when an expression is compiled. -;; -;; `eval' triggers when code is evaluated interactively, as at the REPL -;; or via the `compile' or `eval' procedures. +(define sc-expand #f) +(define sc-expand3 #f) +(define sc-chi #f) +(define install-global-transformer #f) +(define syntax-dispatch #f) +(define syntax-error #f) +(define (annotation? x) #f) -;; NB: this macro is only ever expanded by the interpreter. The compiler -;; notices it and interprets the situations differently. -(define eval-when - (procedure->memoizing-macro - (lambda (exp env) - (let ((situations (cadr exp)) - (body (cddr exp))) - (if (or (memq 'load situations) - (memq 'eval situations)) - `(begin . ,body)))))) +(define bound-identifier=? #f) +(define datum->syntax-object #f) +(define free-identifier=? #f) +(define generate-temporaries #f) +(define identifier? #f) +(define syntax-object->datum #f) + +(define (void) (if #f #f)) + +(define andmap + (lambda (f first . rest) + (or (null? first) + (if (null? rest) + (let andmap ((first first)) + (let ((x (car first)) (first (cdr first))) + (if (null? first) + (f x) + (and (f x) (andmap first))))) + (let andmap ((first first) (rest rest)) + (let ((x (car first)) + (xr (map car rest)) + (first (cdr first)) + (rest (map cdr rest))) + (if (null? first) + (apply f (cons x xr)) + (and (apply f (cons x xr)) (andmap first rest))))))))) + +(define (syncase-error who format-string why what) + (%start-stack 'syncase-stack + (lambda () + (scm-error 'misc-error who "~A ~S" (list why what) '())))) + +;; Until the module system is booted, this will be the current expander. +(primitive-load-path "ice-9/psyntax-pp") + +(define %pre-modules-transformer (lambda args (pk 'in args 'out (apply sc-expand args)))) @@ -170,54 +203,23 @@ ;;; Depends on: features, eval-case ;;; -(define macro-table (make-weak-key-hash-table 61)) -(define xformer-table (make-weak-key-hash-table 61)) +(define-syntax define-macro + (lambda (x) + (syntax-case x () + ((_ (macro . args) . body) + (syntax (define-macro macro (lambda args . body)))) + ((_ macro transformer) + (syntax + (define-syntax macro + (lambda (y) + (let ((v (syntax-object->datum y))) + (datum->syntax-object y (apply transformer (cdr v))))))))))) -(define (defmacro? m) (hashq-ref macro-table m)) -(define (assert-defmacro?! m) (hashq-set! macro-table m #t)) -(define (defmacro-transformer m) (hashq-ref xformer-table m)) -(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t)) - -(define defmacro:transformer - (lambda (f) - (let* ((xform (lambda (exp env) - (copy-tree (apply f (cdr exp))))) - (a (procedure->memoizing-macro xform))) - (assert-defmacro?! a) - (set-defmacro-transformer! a f) - a))) - - -(define defmacro - (let ((defmacro-transformer - (lambda (name parms . body) - (let ((transformer `(lambda ,parms ,@body))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))))) - (defmacro:transformer defmacro-transformer))) - - -;; XXX - should the definition of the car really be looked up in the -;; current module? - -(define (macroexpand-1 e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (apply (defmacro-transformer val) (cdr e)) - e))) - (#t e))) - -(define (macroexpand e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (macroexpand (apply (defmacro-transformer val) (cdr e))) - e))) - (#t e))) +(define-syntax defmacro + (lambda (x) + (syntax-case x () + ((_ macro args . body) + (syntax (define-macro macro (lambda args . body))))))) (provide 'defmacro) @@ -1196,7 +1198,8 @@ "Lazy-binder expected to be a procedure or #f." binder)) (let ((module (module-constructor (make-hash-table size) - uses binder #f #f #f #f #f + uses binder #f %pre-modules-transformer + #f #f #f (make-hash-table %default-import-size) '() (make-weak-key-hash-table 31)))) @@ -1837,6 +1840,7 @@ already) (autoload ;; Try to autoload the module, and recurse. + (pk name) (try-load-module name) (resolve-module name #f)) (else @@ -2006,23 +2010,34 @@ ((#:use-module #:use-syntax) (or (pair? (cdr kws)) (unrecognized kws)) - (let* ((interface-args (cadr kws)) - (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) #:use-syntax) - (or (symbol? (caar interface-args)) - (error "invalid module name for use-syntax" - (car interface-args))) - (set-module-transformer! - module - (module-ref interface - (car (last-pair (car interface-args))) - #f))) + (cond + ((equal? (caadr kws) '(ice-9 syncase)) + (issue-deprecation-warning + "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.") (loop (cddr kws) - (cons interface reversed-interfaces) + reversed-interfaces exports re-exports replacements - autoloads))) + autoloads)) + (else + (let* ((interface-args (cadr kws)) + (interface (apply resolve-interface interface-args))) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) + (error "invalid module name for use-syntax" + (car interface-args))) + (set-module-transformer! + module + (module-ref interface + (car (last-pair (car interface-args))) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces) + exports + re-exports + replacements + autoloads))))) ((#:autoload) (or (and (pair? (cdr kws)) (pair? (cddr kws))) (unrecognized kws)) @@ -2678,32 +2693,6 @@ module '(ice-9 q) '(make-q q-length))}." `(with-fluids* (list ,@fluids) (list ,@values) (lambda () ,@body))))) - - -;;; {Macros} -;;; - -;; actually....hobbit might be able to hack these with a little -;; coaxing -;; - -(define (primitive-macro? m) - (and (macro? m) - (not (macro-transformer m)))) - -(defmacro define-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))) - - - - ;;; {While} ;;; ;;; with `continue' and `break'. @@ -2843,50 +2832,33 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro use-syntax (spec) `(eval-when (eval load compile) - ,@(if (pair? spec) - `((process-use-modules (list - (list ,@(compile-interface-spec spec)))) - (set-module-transformer! (current-module) - ,(car (last-pair spec)))) - `((set-module-transformer! (current-module) ,spec))) - *unspecified*)) + (issue-deprecation-warning + "`use-syntax' is deprecated. Please contact guile-devel for more info.") + (process-use-modules (list (list ,@(compile-interface-spec spec)))) + *unspecified*)) ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed ;; as soon as guile supports hygienic macros. -(define define-private define) +(define-syntax define-private + (syntax-rules () + ((_ foo bar) + (define foo bar)))) -(defmacro define-public args - (define (syntax) - (error "bad syntax" (list 'define-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - ((pair? n) (defined-name (car n))) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (define-private ,@args) - (export ,name)))))) +(define-syntax define-public + (syntax-rules () + ((_ (name . args) . body) + (define-public name (lambda args . body))) + ((_ name val) + (begin + (define name val) + (export name))))) -(defmacro defmacro-public args - (define (syntax) - (error "bad syntax" (list 'defmacro-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (export-syntax ,name) - (defmacro ,@args)))))) +(define-syntax defmacro-public + (syntax-rules () + ((_ name args . body) + (begin + (defmacro name args . body) + (export-syntax name))))) ;; Export a local variable @@ -3375,6 +3347,12 @@ module '(ice-9 q) '(make-q q-length))}." ;;; Place the user in the guile-user module. ;;; +;;; FIXME: annotate ? +;; (define (syncase exp) +;; (with-fluids ((expansion-eval-closure +;; (module-eval-closure (current-module)))) +;; (deannotate/source-properties (sc-expand (annotate exp))))) + (define-module (guile-user)) ;;; boot-9.scm ends here diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index d8fdeb4c9..22391a8c8 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -17,197 +17,15 @@ (define-module (ice-9 syncase) - :use-module (ice-9 expand-support) - :use-module (ice-9 debug) - :use-module (ice-9 threads) - :export-syntax (sc-macro define-syntax define-syntax-public - fluid-let-syntax - identifier-syntax let-syntax - letrec-syntax syntax syntax-case syntax-rules - with-syntax - include) - :export (sc-expand sc-expand3 install-global-transformer - syntax-dispatch syntax-error bound-identifier=? - datum->syntax-object free-identifier=? - generate-temporaries identifier? syntax-object->datum - void syncase) - :replace (eval eval-when)) + ) - - -(define (annotation? x) #f) - -(define sc-macro - (procedure->memoizing-macro - (lambda (exp env) - (save-module-excursion - (lambda () - ;; Because memoization happens lazily, env's module isn't - ;; necessarily the current module. - (set-current-module (eval-closure-module (car (last-pair env)))) - (strip-expansion-structures (sc-expand exp))))))) - -;;; Exported variables - -(define sc-expand #f) -(define sc-expand3 #f) -(define sc-chi #f) -(define install-global-transformer #f) -(define syntax-dispatch #f) -(define syntax-error #f) - -(define bound-identifier=? #f) -(define datum->syntax-object #f) -(define free-identifier=? #f) -(define generate-temporaries #f) -(define identifier? #f) -(define syntax-object->datum #f) - -(define primitive-syntax '(quote lambda letrec if set! begin define or - and let let* cond do quasiquote unquote - unquote-splicing case @ @@)) - -(for-each (lambda (symbol) - (set-symbol-property! symbol 'primitive-syntax #t)) - primitive-syntax) - -;;; Hooks needed by the syntax-case macro package - -(define (void) *unspecified*) - -(define andmap - (lambda (f first . rest) - (or (null? first) - (if (null? rest) - (let andmap ((first first)) - (let ((x (car first)) (first (cdr first))) - (if (null? first) - (f x) - (and (f x) (andmap first))))) - (let andmap ((first first) (rest rest)) - (let ((x (car first)) - (xr (map car rest)) - (first (cdr first)) - (rest (map cdr rest))) - (if (null? first) - (apply f (cons x xr)) - (and (apply f (cons x xr)) (andmap first rest))))))))) - -(define (error who format-string why what) - (start-stack 'syncase-stack - (scm-error 'misc-error - who - "~A ~S" - (list why what) - '()))) - -(define the-syncase-module (current-module)) - -(define guile-macro - (cons 'external-macro - (lambda (e r w s mod) - (let ((e (syntax-object->datum e))) - (if (symbol? e) - ;; pass the expression through - e - (let* ((mod (resolve-module mod)) - (m (module-ref mod (car e)))) - (if (eq? (macro-type m) 'syntax) - ;; pass the expression through - e - ;; perform Guile macro transform - (let ((e ((macro-transformer m) - (strip-expansion-structures e) - (append r (list (module-eval-closure mod)))))) - (if (variable? e) - e - (if (null? r) - (sc-expand e) - (sc-chi e r w (module-name mod)))))))))))) - -(define generated-symbols (make-weak-key-hash-table 1019)) - -;; We define our own gensym here because the Guile built-in one will -;; eventually produce uninterned and unreadable symbols (as needed for -;; safe macro expansions) and will the be inappropriate for dumping to -;; pssyntax.pp. -;; -;; syncase is supposed to only require that gensym produce unique -;; readable symbols, and they only need be unique with respect to -;; multiple calls to gensym, not globally unique. -;; -(define gensym - (let ((counter 0)) - - (define next-id - (if (provided? 'threads) - (let ((symlock (make-mutex))) - (lambda () - (let ((result #f)) - (with-mutex symlock - (set! result counter) - (set! counter (+ counter 1))) - result))) - ;; faster, non-threaded case. - (lambda () - (let ((result counter)) - (set! counter (+ counter 1)) - result)))) - - ;; actual gensym body code. - (lambda (. rest) - (let* ((next-val (next-id)) - (valstr (number->string next-val))) - (cond - ((null? rest) - (string->symbol (string-append "syntmp-" valstr))) - ((null? (cdr rest)) - (string->symbol (string-append "syntmp-" (car rest) "-" valstr))) - (else - (error - (string-append - "syncase's gensym expected 0 or 1 arguments, got " - (length rest))))))))) - -;;; Load the preprocessed code - -(let ((old-debug #f) - (old-read #f)) - (dynamic-wind (lambda () - (set! old-debug (debug-options)) - (set! old-read (read-options))) - (lambda () - (debug-disable 'debug 'procnames) - (read-disable 'positions) - (load-from-path "ice-9/psyntax-pp")) - (lambda () - (debug-options old-debug) - (read-options old-read)))) - -(define internal-eval (nested-ref the-scm-module '(%app modules guile eval))) - -(define (eval x environment) - (internal-eval (if (and (pair? x) - (equal? (car x) "noexpand")) - (strip-expansion-structures (cadr x)) - (strip-expansion-structures (sc-expand x))) - environment)) +(issue-deprecation-warning + "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.") ;;; Hack to make syncase macros work in the slib module -(let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) - (if m - (set-object-property! (module-local-variable m 'define) - '*sc-expander* - '(define)))) - -(define (syncase exp) - (strip-expansion-structures (sc-expand exp))) - -(set-module-transformer! the-syncase-module syncase) - -(define-syntax define-syntax-public - (syntax-rules () - ((_ name rules ...) - (begin - ;(eval-case ((load-toplevel) (export-syntax name))) - (define-syntax name rules ...))))) +;; FIXME wingo is this still necessary? +;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) +;; (if m +;; (set-object-property! (module-local-variable m 'define) +;; '*sc-expander* +;; '(define)))) From 64e5d08d3e7076b554f724efede860883f846b5f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 14:01:26 +0200 Subject: [PATCH 062/375] leap of faith: (ice-9 syncase) in psyntax-pp.scm -> (guile) * module/ice-9/psyntax-pp.scm: Manually switch psyntax-pp over to (guile) from (ice-9 syncase). Heh heh. --- guile-readline/ice-9/readline.scm | 32 +++++++++++++++---------------- module/ice-9/boot-9.scm | 1 + module/ice-9/psyntax-pp.scm | 18 ++++++++--------- 3 files changed, 25 insertions(+), 26 deletions(-) diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index c35602f0c..19dda94db 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -169,24 +169,22 @@ (define-public (set-readline-read-hook! h) (set! read-hook h)) -(if (provided? 'regex) - (begin - (define-public apropos-completion-function - (let ((completions '())) - (lambda (text cont?) - (if (not cont?) - (set! completions - (map symbol->string - (apropos-internal - (string-append "^" (regexp-quote text)))))) - (if (null? completions) - #f - (let ((retval (car completions))) - (begin (set! completions (cdr completions)) - retval)))))) +(define-public apropos-completion-function + (let ((completions '())) + (lambda (text cont?) + (if (not cont?) + (set! completions + (map symbol->string + (apropos-internal + (string-append "^" (regexp-quote text)))))) + (if (null? completions) + #f + (let ((retval (car completions))) + (begin (set! completions (cdr completions)) + retval)))))) - (set! *readline-completion-function* apropos-completion-function) - )) +(if (provided? 'regex) + (set! *readline-completion-function* apropos-completion-function)) (define-public (with-readline-completion-function completer thunk) "With @var{completer} as readline completion function, call @var{thunk}." diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 923c042ff..f06cc92b8 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2162,6 +2162,7 @@ module '(ice-9 q) '(make-q q-length))}." (and (not (autoload-done-or-in-progress? dir-hint name)) (let ((didit #f)) (define (load-file proc file) + (pk 'loading proc file) (save-module-excursion (lambda () (proc file))) (set! didit #t)) (dynamic-wind diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index a870f8700..9df53fff9 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-modname-1084) (let ((syntmp-module-1085 (if syntmp-modname-1084 (resolve-module syntmp-modname-1084) (current-module)))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable (quote sc-macro)))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (variable-bound? syntmp-v-1086)) (variable-set! syntmp-v-1086 (gensym))) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-head-1341 syntmp-tail-1342 syntmp-val-1343) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-head-1341 syntmp-r-1323 (quote (())) #f #f syntmp-mod-1326)) (lambda (syntmp-type-1344 syntmp-value-1345 syntmp-ee-1346 syntmp-ww-1347 syntmp-ss-1348 syntmp-modmod-1349) (let ((syntmp-t-1350 syntmp-type-1344)) (if (memv syntmp-t-1350 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1345 (cons syntmp-head-1341 syntmp-tail-1342))) (lambda (syntmp-id-1352 syntmp-mod-1353) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1353 syntmp-id-1352 #f) syntmp-val-1343)))) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1354) (syntmp-chi-153 syntmp-e-1354 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-tail-1342 (list syntmp-val-1343)))))))))) syntmp-tmp-1339) ((lambda (syntmp-_-1356) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1357) ((lambda (syntmp-tmp-1358) ((lambda (syntmp-tmp-1359) (if (if syntmp-tmp-1359 (apply (lambda (syntmp-_-1360 syntmp-mod-1361 syntmp-id-1362) (and (andmap syntmp-id?-117 syntmp-mod-1361) (syntmp-id?-117 syntmp-id-1362))) syntmp-tmp-1359) #f) (apply (lambda (syntmp-_-1364 syntmp-mod-1365 syntmp-id-1366) (values (syntax-object->datum syntmp-id-1366) (syntax-object->datum (append syntmp-mod-1365 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1359) (syntax-error syntmp-tmp-1358))) (syntax-dispatch syntmp-tmp-1358 (quote (any each-any any))))) syntmp-e-1357))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1368) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-mod-1372 syntmp-id-1373) (and (andmap syntmp-id?-117 syntmp-mod-1372) (syntmp-id?-117 syntmp-id-1373))) syntmp-tmp-1370) #f) (apply (lambda (syntmp-_-1375 syntmp-mod-1376 syntmp-id-1377) (values (syntax-object->datum syntmp-id-1377) (syntax-object->datum syntmp-mod-1376))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any each-any any))))) syntmp-e-1368))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1382 (lambda (syntmp-x-1383 syntmp-keys-1384 syntmp-clauses-1385 syntmp-r-1386 syntmp-mod-1387) (if (null? syntmp-clauses-1385) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1383)) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if syntmp-tmp-1389 (apply (lambda (syntmp-pat-1390 syntmp-exp-1391) (if (and (syntmp-id?-117 syntmp-pat-1390) (andmap (lambda (syntmp-x-1392) (not (syntmp-free-id=?-140 syntmp-pat-1390 syntmp-x-1392))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1384))) (let ((syntmp-labels-1393 (list (syntmp-gen-label-122))) (syntmp-var-1394 (syntmp-gen-var-165 syntmp-pat-1390))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1394) (syntmp-chi-153 syntmp-exp-1391 (syntmp-extend-env-111 syntmp-labels-1393 (list (cons (quote syntax) (cons syntmp-var-1394 0))) syntmp-r-1386) (syntmp-make-binding-wrap-134 (list syntmp-pat-1390) syntmp-labels-1393 (quote (()))) syntmp-mod-1387))) syntmp-x-1383))) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1390 #t syntmp-exp-1391 syntmp-mod-1387))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1395) (if syntmp-tmp-1395 (apply (lambda (syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398 syntmp-mod-1387)) syntmp-tmp-1395) ((lambda (syntmp-_-1399) (syntax-error (car syntmp-clauses-1385) "invalid syntax-case clause")) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) (car syntmp-clauses-1385))))) (syntmp-gen-clause-1381 (lambda (syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-pat-1404 syntmp-fender-1405 syntmp-exp-1406 syntmp-mod-1407) (call-with-values (lambda () (syntmp-convert-pattern-1379 syntmp-pat-1404 syntmp-keys-1401)) (lambda (syntmp-p-1408 syntmp-pvars-1409) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1409))) (syntax-error syntmp-pat-1404 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1410) (not (syntmp-ellipsis?-162 (car syntmp-x-1410)))) syntmp-pvars-1409)) (syntax-error syntmp-pat-1404 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1411 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1411) (let ((syntmp-y-1412 (syntmp-build-annotated-94 #f syntmp-y-1411))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1413) ((lambda (syntmp-tmp-1414) (if syntmp-tmp-1414 (apply (lambda () syntmp-y-1412) syntmp-tmp-1414) ((lambda (syntmp-_-1415) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1412 (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-fender-1405 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1413))) (syntax-dispatch syntmp-tmp-1413 (quote #(atom #t))))) syntmp-fender-1405) (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-exp-1406 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-gen-syntax-case-1382 syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-mod-1407)))))) (if (eq? syntmp-p-1408 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1400)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1400 (syntmp-build-data-95 #f syntmp-p-1408))))))))))))) (syntmp-build-dispatch-call-1380 (lambda (syntmp-pvars-1416 syntmp-exp-1417 syntmp-y-1418 syntmp-r-1419 syntmp-mod-1420) (let ((syntmp-ids-1421 (map car syntmp-pvars-1416)) (syntmp-levels-1422 (map cdr syntmp-pvars-1416))) (let ((syntmp-labels-1423 (syntmp-gen-labels-123 syntmp-ids-1421)) (syntmp-new-vars-1424 (map syntmp-gen-var-165 syntmp-ids-1421))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1424 (syntmp-chi-153 syntmp-exp-1417 (syntmp-extend-env-111 syntmp-labels-1423 (map (lambda (syntmp-var-1425 syntmp-level-1426) (cons (quote syntax) (cons syntmp-var-1425 syntmp-level-1426))) syntmp-new-vars-1424 (map cdr syntmp-pvars-1416)) syntmp-r-1419) (syntmp-make-binding-wrap-134 syntmp-ids-1421 syntmp-labels-1423 (quote (()))) syntmp-mod-1420))) syntmp-y-1418)))))) (syntmp-convert-pattern-1379 (lambda (syntmp-pattern-1427 syntmp-keys-1428) (let syntmp-cvt-1429 ((syntmp-p-1430 syntmp-pattern-1427) (syntmp-n-1431 0) (syntmp-ids-1432 (quote ()))) (if (syntmp-id?-117 syntmp-p-1430) (if (syntmp-bound-id-member?-144 syntmp-p-1430 syntmp-keys-1428) (values (vector (quote free-id) syntmp-p-1430) syntmp-ids-1432) (values (quote any) (cons (cons syntmp-p-1430 syntmp-n-1431) syntmp-ids-1432))) ((lambda (syntmp-tmp-1433) ((lambda (syntmp-tmp-1434) (if (if syntmp-tmp-1434 (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (syntmp-ellipsis?-162 syntmp-dots-1436)) syntmp-tmp-1434) #f) (apply (lambda (syntmp-x-1437 syntmp-dots-1438) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1437 (syntmp-fx+-85 syntmp-n-1431 1) syntmp-ids-1432)) (lambda (syntmp-p-1439 syntmp-ids-1440) (values (if (eq? syntmp-p-1439 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1439)) syntmp-ids-1440)))) syntmp-tmp-1434) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-x-1442 syntmp-y-1443) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-y-1443 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-y-1444 syntmp-ids-1445) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1442 syntmp-n-1431 syntmp-ids-1445)) (lambda (syntmp-x-1446 syntmp-ids-1447) (values (cons syntmp-x-1446 syntmp-y-1444) syntmp-ids-1447)))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda () (values (quote ()) syntmp-ids-1432)) syntmp-tmp-1448) ((lambda (syntmp-tmp-1449) (if syntmp-tmp-1449 (apply (lambda (syntmp-x-1450) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1450 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-p-1452 syntmp-ids-1453) (values (vector (quote vector) syntmp-p-1452) syntmp-ids-1453)))) syntmp-tmp-1449) ((lambda (syntmp-x-1454) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1430 (quote (())))) syntmp-ids-1432)) syntmp-tmp-1433))) (syntax-dispatch syntmp-tmp-1433 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1433 (quote ()))))) (syntax-dispatch syntmp-tmp-1433 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1433 (quote (any any))))) syntmp-p-1430)))))) (lambda (syntmp-e-1455 syntmp-r-1456 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459) (let ((syntmp-e-1460 (syntmp-source-wrap-146 syntmp-e-1455 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459))) ((lambda (syntmp-tmp-1461) ((lambda (syntmp-tmp-1462) (if syntmp-tmp-1462 (apply (lambda (syntmp-_-1463 syntmp-val-1464 syntmp-key-1465 syntmp-m-1466) (if (andmap (lambda (syntmp-x-1467) (and (syntmp-id?-117 syntmp-x-1467) (not (syntmp-ellipsis?-162 syntmp-x-1467)))) syntmp-key-1465) (let ((syntmp-x-1469 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1458 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1469) (syntmp-gen-syntax-case-1382 (syntmp-build-annotated-94 #f syntmp-x-1469) syntmp-key-1465 syntmp-m-1466 syntmp-r-1456 syntmp-mod-1459))) (syntmp-chi-153 syntmp-val-1464 syntmp-r-1456 (quote (())) syntmp-mod-1459)))) (syntax-error syntmp-e-1460 "invalid literals list in"))) syntmp-tmp-1462) (syntax-error syntmp-tmp-1461))) (syntax-dispatch syntmp-tmp-1461 (quote (any any each-any . each-any))))) syntmp-e-1460))))) (set! sc-expand (let ((syntmp-m-1472 (quote e)) (syntmp-esew-1473 (quote (eval)))) (lambda (syntmp-x-1474) (if (and (pair? syntmp-x-1474) (equal? (car syntmp-x-1474) syntmp-noexpand-84)) (cadr syntmp-x-1474) (syntmp-chi-top-152 syntmp-x-1474 (quote ()) (quote ((top))) syntmp-m-1472 syntmp-esew-1473 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1475 (quote e)) (syntmp-esew-1476 (quote (eval)))) (lambda (syntmp-x-1478 . syntmp-rest-1477) (if (and (pair? syntmp-x-1478) (equal? (car syntmp-x-1478) syntmp-noexpand-84)) (cadr syntmp-x-1478) (syntmp-chi-top-152 syntmp-x-1478 (quote ()) (quote ((top))) (if (null? syntmp-rest-1477) syntmp-m-1475 (car syntmp-rest-1477)) (if (or (null? syntmp-rest-1477) (null? (cdr syntmp-rest-1477))) syntmp-esew-1476 (cadr syntmp-rest-1477)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1479) (syntmp-nonsymbol-id?-116 syntmp-x-1479))) (set! datum->syntax-object (lambda (syntmp-id-1480 syntmp-datum-1481) (syntmp-make-syntax-object-100 syntmp-datum-1481 (syntmp-syntax-object-wrap-103 syntmp-id-1480) #f))) (set! syntax-object->datum (lambda (syntmp-x-1482) (syntmp-strip-164 syntmp-x-1482 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1483) (begin (let ((syntmp-x-1484 syntmp-ls-1483)) (if (not (list? syntmp-x-1484)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1484))) (map (lambda (syntmp-x-1485) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1483)))) (set! free-identifier=? (lambda (syntmp-x-1486 syntmp-y-1487) (begin (let ((syntmp-x-1488 syntmp-x-1486)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1488)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1488))) (let ((syntmp-x-1489 syntmp-y-1487)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1489)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1489))) (syntmp-free-id=?-140 syntmp-x-1486 syntmp-y-1487)))) (set! bound-identifier=? (lambda (syntmp-x-1490 syntmp-y-1491) (begin (let ((syntmp-x-1492 syntmp-x-1490)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1492)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1492))) (let ((syntmp-x-1493 syntmp-y-1491)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1493)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1493))) (syntmp-bound-id=?-141 syntmp-x-1490 syntmp-y-1491)))) (set! syntax-error (lambda (syntmp-object-1495 . syntmp-messages-1494) (begin (for-each (lambda (syntmp-x-1496) (let ((syntmp-x-1497 syntmp-x-1496)) (if (not (string? syntmp-x-1497)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1497)))) syntmp-messages-1494) (let ((syntmp-message-1498 (if (null? syntmp-messages-1494) "invalid syntax" (apply string-append syntmp-messages-1494)))) (syntmp-error-hook-91 #f syntmp-message-1498 (syntmp-strip-164 syntmp-object-1495 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1499 syntmp-v-1500) (begin (let ((syntmp-x-1501 syntmp-sym-1499)) (if (not (symbol? syntmp-x-1501)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1501))) (let ((syntmp-x-1502 syntmp-v-1500)) (if (not (procedure? syntmp-x-1502)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1502))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1499 syntmp-v-1500)))) (letrec ((syntmp-match-1507 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512) (cond ((not syntmp-r-1511) #f) ((eq? syntmp-p-1509 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1508 syntmp-w-1510 syntmp-mod-1512) syntmp-r-1511)) ((syntmp-syntax-object?-101 syntmp-e-1508) (syntmp-match*-1506 (let ((syntmp-e-1513 (syntmp-syntax-object-expression-102 syntmp-e-1508))) (if (annotation? syntmp-e-1513) (annotation-expression syntmp-e-1513) syntmp-e-1513)) syntmp-p-1509 (syntmp-join-wraps-136 syntmp-w-1510 (syntmp-syntax-object-wrap-103 syntmp-e-1508)) syntmp-r-1511 (syntmp-syntax-object-module-104 syntmp-e-1508))) (else (syntmp-match*-1506 (let ((syntmp-e-1514 syntmp-e-1508)) (if (annotation? syntmp-e-1514) (annotation-expression syntmp-e-1514) syntmp-e-1514)) syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512))))) (syntmp-match*-1506 (lambda (syntmp-e-1515 syntmp-p-1516 syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) (cond ((null? syntmp-p-1516) (and (null? syntmp-e-1515) syntmp-r-1518)) ((pair? syntmp-p-1516) (and (pair? syntmp-e-1515) (syntmp-match-1507 (car syntmp-e-1515) (car syntmp-p-1516) syntmp-w-1517 (syntmp-match-1507 (cdr syntmp-e-1515) (cdr syntmp-p-1516) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) syntmp-mod-1519))) ((eq? syntmp-p-1516 (quote each-any)) (let ((syntmp-l-1520 (syntmp-match-each-any-1504 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1520 (cons syntmp-l-1520 syntmp-r-1518)))) (else (let ((syntmp-t-1521 (vector-ref syntmp-p-1516 0))) (if (memv syntmp-t-1521 (quote (each))) (if (null? syntmp-e-1515) (syntmp-match-empty-1505 (vector-ref syntmp-p-1516 1) syntmp-r-1518) (let ((syntmp-l-1522 (syntmp-match-each-1503 syntmp-e-1515 (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1522 (let syntmp-collect-1523 ((syntmp-l-1524 syntmp-l-1522)) (if (null? (car syntmp-l-1524)) syntmp-r-1518 (cons (map car syntmp-l-1524) (syntmp-collect-1523 (map cdr syntmp-l-1524)))))))) (if (memv syntmp-t-1521 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1515) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519) (vector-ref syntmp-p-1516 1)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (atom))) (and (equal? (vector-ref syntmp-p-1516 1) (syntmp-strip-164 syntmp-e-1515 syntmp-w-1517)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (vector))) (and (vector? syntmp-e-1515) (syntmp-match-1507 (vector->list syntmp-e-1515) (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519))))))))))) (syntmp-match-empty-1505 (lambda (syntmp-p-1525 syntmp-r-1526) (cond ((null? syntmp-p-1525) syntmp-r-1526) ((eq? syntmp-p-1525 (quote any)) (cons (quote ()) syntmp-r-1526)) ((pair? syntmp-p-1525) (syntmp-match-empty-1505 (car syntmp-p-1525) (syntmp-match-empty-1505 (cdr syntmp-p-1525) syntmp-r-1526))) ((eq? syntmp-p-1525 (quote each-any)) (cons (quote ()) syntmp-r-1526)) (else (let ((syntmp-t-1527 (vector-ref syntmp-p-1525 0))) (if (memv syntmp-t-1527 (quote (each))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526) (if (memv syntmp-t-1527 (quote (free-id atom))) syntmp-r-1526 (if (memv syntmp-t-1527 (quote (vector))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526))))))))) (syntmp-match-each-any-1504 (lambda (syntmp-e-1528 syntmp-w-1529 syntmp-mod-1530) (cond ((annotation? syntmp-e-1528) (syntmp-match-each-any-1504 (annotation-expression syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530)) ((pair? syntmp-e-1528) (let ((syntmp-l-1531 (syntmp-match-each-any-1504 (cdr syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530))) (and syntmp-l-1531 (cons (syntmp-wrap-145 (car syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530) syntmp-l-1531)))) ((null? syntmp-e-1528) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1528) (syntmp-match-each-any-1504 (syntmp-syntax-object-expression-102 syntmp-e-1528) (syntmp-join-wraps-136 syntmp-w-1529 (syntmp-syntax-object-wrap-103 syntmp-e-1528)) syntmp-mod-1530)) (else #f)))) (syntmp-match-each-1503 (lambda (syntmp-e-1532 syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535) (cond ((annotation? syntmp-e-1532) (syntmp-match-each-1503 (annotation-expression syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535)) ((pair? syntmp-e-1532) (let ((syntmp-first-1536 (syntmp-match-1507 (car syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 (quote ()) syntmp-mod-1535))) (and syntmp-first-1536 (let ((syntmp-rest-1537 (syntmp-match-each-1503 (cdr syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535))) (and syntmp-rest-1537 (cons syntmp-first-1536 syntmp-rest-1537)))))) ((null? syntmp-e-1532) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1532) (syntmp-match-each-1503 (syntmp-syntax-object-expression-102 syntmp-e-1532) syntmp-p-1533 (syntmp-join-wraps-136 syntmp-w-1534 (syntmp-syntax-object-wrap-103 syntmp-e-1532)) (syntmp-syntax-object-module-104 syntmp-e-1532))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1538 syntmp-p-1539) (cond ((eq? syntmp-p-1539 (quote any)) (list syntmp-e-1538)) ((syntmp-syntax-object?-101 syntmp-e-1538) (syntmp-match*-1506 (let ((syntmp-e-1540 (syntmp-syntax-object-expression-102 syntmp-e-1538))) (if (annotation? syntmp-e-1540) (annotation-expression syntmp-e-1540) syntmp-e-1540)) syntmp-p-1539 (syntmp-syntax-object-wrap-103 syntmp-e-1538) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1538))) (else (syntmp-match*-1506 (let ((syntmp-e-1541 syntmp-e-1538)) (if (annotation? syntmp-e-1541) (annotation-expression syntmp-e-1541) syntmp-e-1541)) syntmp-p-1539 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-e1-1546 syntmp-e2-1547) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1546 syntmp-e2-1547))) syntmp-tmp-1544) ((lambda (syntmp-tmp-1549) (if syntmp-tmp-1549 (apply (lambda (syntmp-_-1550 syntmp-out-1551 syntmp-in-1552 syntmp-e1-1553 syntmp-e2-1554) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1552 (quote ()) (list syntmp-out-1551 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1553 syntmp-e2-1554))))) syntmp-tmp-1549) ((lambda (syntmp-tmp-1556) (if syntmp-tmp-1556 (apply (lambda (syntmp-_-1557 syntmp-out-1558 syntmp-in-1559 syntmp-e1-1560 syntmp-e2-1561) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1559) (quote ()) (list syntmp-out-1558 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1560 syntmp-e2-1561))))) syntmp-tmp-1556) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any () any . each-any))))) syntmp-x-1542))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1583) ((lambda (syntmp-tmp-1584) ((lambda (syntmp-tmp-1585) (if syntmp-tmp-1585 (apply (lambda (syntmp-_-1586 syntmp-k-1587 syntmp-keyword-1588 syntmp-pattern-1589 syntmp-template-1590) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1587 (map (lambda (syntmp-tmp-1593 syntmp-tmp-1592) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1592) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1593))) syntmp-template-1590 syntmp-pattern-1589)))))) syntmp-tmp-1585) (syntax-error syntmp-tmp-1584))) (syntax-dispatch syntmp-tmp-1584 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1583))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1604) ((lambda (syntmp-tmp-1605) ((lambda (syntmp-tmp-1606) (if (if syntmp-tmp-1606 (apply (lambda (syntmp-let*-1607 syntmp-x-1608 syntmp-v-1609 syntmp-e1-1610 syntmp-e2-1611) (andmap identifier? syntmp-x-1608)) syntmp-tmp-1606) #f) (apply (lambda (syntmp-let*-1613 syntmp-x-1614 syntmp-v-1615 syntmp-e1-1616 syntmp-e2-1617) (let syntmp-f-1618 ((syntmp-bindings-1619 (map list syntmp-x-1614 syntmp-v-1615))) (if (null? syntmp-bindings-1619) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1616 syntmp-e2-1617))) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-body-1625 syntmp-binding-1626) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1626) syntmp-body-1625)) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any any))))) (list (syntmp-f-1618 (cdr syntmp-bindings-1619)) (car syntmp-bindings-1619)))))) syntmp-tmp-1606) (syntax-error syntmp-tmp-1605))) (syntax-dispatch syntmp-tmp-1605 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1604))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1646) ((lambda (syntmp-tmp-1647) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-_-1649 syntmp-var-1650 syntmp-init-1651 syntmp-step-1652 syntmp-e0-1653 syntmp-e1-1654 syntmp-c-1655) ((lambda (syntmp-tmp-1656) ((lambda (syntmp-tmp-1657) (if syntmp-tmp-1657 (apply (lambda (syntmp-step-1658) ((lambda (syntmp-tmp-1659) ((lambda (syntmp-tmp-1660) (if syntmp-tmp-1660 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1653) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1658))))))) syntmp-tmp-1660) ((lambda (syntmp-tmp-1665) (if syntmp-tmp-1665 (apply (lambda (syntmp-e1-1666 syntmp-e2-1667) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1653 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1666 syntmp-e2-1667)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1658))))))) syntmp-tmp-1665) (syntax-error syntmp-tmp-1659))) (syntax-dispatch syntmp-tmp-1659 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1659 (quote ())))) syntmp-e1-1654)) syntmp-tmp-1657) (syntax-error syntmp-tmp-1656))) (syntax-dispatch syntmp-tmp-1656 (quote each-any)))) (map (lambda (syntmp-v-1674 syntmp-s-1675) ((lambda (syntmp-tmp-1676) ((lambda (syntmp-tmp-1677) (if syntmp-tmp-1677 (apply (lambda () syntmp-v-1674) syntmp-tmp-1677) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-e-1679) syntmp-e-1679) syntmp-tmp-1678) ((lambda (syntmp-_-1680) (syntax-error syntmp-orig-x-1646)) syntmp-tmp-1676))) (syntax-dispatch syntmp-tmp-1676 (quote (any)))))) (syntax-dispatch syntmp-tmp-1676 (quote ())))) syntmp-s-1675)) syntmp-var-1650 syntmp-step-1652))) syntmp-tmp-1648) (syntax-error syntmp-tmp-1647))) (syntax-dispatch syntmp-tmp-1647 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1646))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1708 (lambda (syntmp-x-1712 syntmp-y-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-tmp-1715) (if syntmp-tmp-1715 (apply (lambda (syntmp-x-1716 syntmp-y-1717) ((lambda (syntmp-tmp-1718) ((lambda (syntmp-tmp-1719) (if syntmp-tmp-1719 (apply (lambda (syntmp-dy-1720) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-dx-1723) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1723 syntmp-dy-1720))) syntmp-tmp-1722) ((lambda (syntmp-_-1724) (if (null? syntmp-dy-1720) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1716) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1716 syntmp-y-1717))) syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1716)) syntmp-tmp-1719) ((lambda (syntmp-tmp-1725) (if syntmp-tmp-1725 (apply (lambda (syntmp-stuff-1726) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1716 syntmp-stuff-1726))) syntmp-tmp-1725) ((lambda (syntmp-else-1727) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1716 syntmp-y-1717)) syntmp-tmp-1718))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1717)) syntmp-tmp-1715) (syntax-error syntmp-tmp-1714))) (syntax-dispatch syntmp-tmp-1714 (quote (any any))))) (list syntmp-x-1712 syntmp-y-1713)))) (syntmp-quasiappend-1709 (lambda (syntmp-x-1728 syntmp-y-1729) ((lambda (syntmp-tmp-1730) ((lambda (syntmp-tmp-1731) (if syntmp-tmp-1731 (apply (lambda (syntmp-x-1732 syntmp-y-1733) ((lambda (syntmp-tmp-1734) ((lambda (syntmp-tmp-1735) (if syntmp-tmp-1735 (apply (lambda () syntmp-x-1732) syntmp-tmp-1735) ((lambda (syntmp-_-1736) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1732 syntmp-y-1733)) syntmp-tmp-1734))) (syntax-dispatch syntmp-tmp-1734 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1733)) syntmp-tmp-1731) (syntax-error syntmp-tmp-1730))) (syntax-dispatch syntmp-tmp-1730 (quote (any any))))) (list syntmp-x-1728 syntmp-y-1729)))) (syntmp-quasivector-1710 (lambda (syntmp-x-1737) ((lambda (syntmp-tmp-1738) ((lambda (syntmp-x-1739) ((lambda (syntmp-tmp-1740) ((lambda (syntmp-tmp-1741) (if syntmp-tmp-1741 (apply (lambda (syntmp-x-1742) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1742))) syntmp-tmp-1741) ((lambda (syntmp-tmp-1744) (if syntmp-tmp-1744 (apply (lambda (syntmp-x-1745) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1745)) syntmp-tmp-1744) ((lambda (syntmp-_-1747) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1739)) syntmp-tmp-1740))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1739)) syntmp-tmp-1738)) syntmp-x-1737))) (syntmp-quasi-1711 (lambda (syntmp-p-1748 syntmp-lev-1749) ((lambda (syntmp-tmp-1750) ((lambda (syntmp-tmp-1751) (if syntmp-tmp-1751 (apply (lambda (syntmp-p-1752) (if (= syntmp-lev-1749 0) syntmp-p-1752 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1711 (list syntmp-p-1752) (- syntmp-lev-1749 1))))) syntmp-tmp-1751) ((lambda (syntmp-tmp-1753) (if syntmp-tmp-1753 (apply (lambda (syntmp-p-1754 syntmp-q-1755) (if (= syntmp-lev-1749 0) (syntmp-quasiappend-1709 syntmp-p-1754 (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)) (syntmp-quasicons-1708 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1711 (list syntmp-p-1754) (- syntmp-lev-1749 1))) (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)))) syntmp-tmp-1753) ((lambda (syntmp-tmp-1756) (if syntmp-tmp-1756 (apply (lambda (syntmp-p-1757) (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1711 (list syntmp-p-1757) (+ syntmp-lev-1749 1)))) syntmp-tmp-1756) ((lambda (syntmp-tmp-1758) (if syntmp-tmp-1758 (apply (lambda (syntmp-p-1759 syntmp-q-1760) (syntmp-quasicons-1708 (syntmp-quasi-1711 syntmp-p-1759 syntmp-lev-1749) (syntmp-quasi-1711 syntmp-q-1760 syntmp-lev-1749))) syntmp-tmp-1758) ((lambda (syntmp-tmp-1761) (if syntmp-tmp-1761 (apply (lambda (syntmp-x-1762) (syntmp-quasivector-1710 (syntmp-quasi-1711 syntmp-x-1762 syntmp-lev-1749))) syntmp-tmp-1761) ((lambda (syntmp-p-1764) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1764)) syntmp-tmp-1750))) (syntax-dispatch syntmp-tmp-1750 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1750 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1748)))) (lambda (syntmp-x-1765) ((lambda (syntmp-tmp-1766) ((lambda (syntmp-tmp-1767) (if syntmp-tmp-1767 (apply (lambda (syntmp-_-1768 syntmp-e-1769) (syntmp-quasi-1711 syntmp-e-1769 0)) syntmp-tmp-1767) (syntax-error syntmp-tmp-1766))) (syntax-dispatch syntmp-tmp-1766 (quote (any any))))) syntmp-x-1765)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1829) (letrec ((syntmp-read-file-1830 (lambda (syntmp-fn-1831 syntmp-k-1832) (let ((syntmp-p-1833 (open-input-file syntmp-fn-1831))) (let syntmp-f-1834 ((syntmp-x-1835 (read syntmp-p-1833))) (if (eof-object? syntmp-x-1835) (begin (close-input-port syntmp-p-1833) (quote ())) (cons (datum->syntax-object syntmp-k-1832 syntmp-x-1835) (syntmp-f-1834 (read syntmp-p-1833))))))))) ((lambda (syntmp-tmp-1836) ((lambda (syntmp-tmp-1837) (if syntmp-tmp-1837 (apply (lambda (syntmp-k-1838 syntmp-filename-1839) (let ((syntmp-fn-1840 (syntax-object->datum syntmp-filename-1839))) ((lambda (syntmp-tmp-1841) ((lambda (syntmp-tmp-1842) (if syntmp-tmp-1842 (apply (lambda (syntmp-exp-1843) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1843)) syntmp-tmp-1842) (syntax-error syntmp-tmp-1841))) (syntax-dispatch syntmp-tmp-1841 (quote each-any)))) (syntmp-read-file-1830 syntmp-fn-1840 syntmp-k-1838)))) syntmp-tmp-1837) (syntax-error syntmp-tmp-1836))) (syntax-dispatch syntmp-tmp-1836 (quote (any any))))) syntmp-x-1829)))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-modname-1084) (let ((syntmp-module-1085 (if syntmp-modname-1084 (resolve-module syntmp-modname-1084) (current-module)))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable (quote sc-macro)))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (variable-bound? syntmp-v-1086)) (variable-set! syntmp-v-1086 (gensym))) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-head-1341 syntmp-tail-1342 syntmp-val-1343) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-head-1341 syntmp-r-1323 (quote (())) #f #f syntmp-mod-1326)) (lambda (syntmp-type-1344 syntmp-value-1345 syntmp-ee-1346 syntmp-ww-1347 syntmp-ss-1348 syntmp-modmod-1349) (let ((syntmp-t-1350 syntmp-type-1344)) (if (memv syntmp-t-1350 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1345 (cons syntmp-head-1341 syntmp-tail-1342))) (lambda (syntmp-id-1352 syntmp-mod-1353) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1353 syntmp-id-1352 #f) syntmp-val-1343)))) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) syntmp-head-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1354) (syntmp-chi-153 syntmp-e-1354 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-tail-1342 (list syntmp-val-1343)))))))))) syntmp-tmp-1339) ((lambda (syntmp-_-1356) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1357) ((lambda (syntmp-tmp-1358) ((lambda (syntmp-tmp-1359) (if (if syntmp-tmp-1359 (apply (lambda (syntmp-_-1360 syntmp-mod-1361 syntmp-id-1362) (and (andmap syntmp-id?-117 syntmp-mod-1361) (syntmp-id?-117 syntmp-id-1362))) syntmp-tmp-1359) #f) (apply (lambda (syntmp-_-1364 syntmp-mod-1365 syntmp-id-1366) (values (syntax-object->datum syntmp-id-1366) (syntax-object->datum (append syntmp-mod-1365 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) syntmp-tmp-1359) (syntax-error syntmp-tmp-1358))) (syntax-dispatch syntmp-tmp-1358 (quote (any each-any any))))) syntmp-e-1357))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1368) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-mod-1372 syntmp-id-1373) (and (andmap syntmp-id?-117 syntmp-mod-1372) (syntmp-id?-117 syntmp-id-1373))) syntmp-tmp-1370) #f) (apply (lambda (syntmp-_-1375 syntmp-mod-1376 syntmp-id-1377) (values (syntax-object->datum syntmp-id-1377) (syntax-object->datum syntmp-mod-1376))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any each-any any))))) syntmp-e-1368))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1382 (lambda (syntmp-x-1383 syntmp-keys-1384 syntmp-clauses-1385 syntmp-r-1386 syntmp-mod-1387) (if (null? syntmp-clauses-1385) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1383)) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if syntmp-tmp-1389 (apply (lambda (syntmp-pat-1390 syntmp-exp-1391) (if (and (syntmp-id?-117 syntmp-pat-1390) (andmap (lambda (syntmp-x-1392) (not (syntmp-free-id=?-140 syntmp-pat-1390 syntmp-x-1392))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) syntmp-keys-1384))) (let ((syntmp-labels-1393 (list (syntmp-gen-label-122))) (syntmp-var-1394 (syntmp-gen-var-165 syntmp-pat-1390))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1394) (syntmp-chi-153 syntmp-exp-1391 (syntmp-extend-env-111 syntmp-labels-1393 (list (cons (quote syntax) (cons syntmp-var-1394 0))) syntmp-r-1386) (syntmp-make-binding-wrap-134 (list syntmp-pat-1390) syntmp-labels-1393 (quote (()))) syntmp-mod-1387))) syntmp-x-1383))) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1390 #t syntmp-exp-1391 syntmp-mod-1387))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1395) (if syntmp-tmp-1395 (apply (lambda (syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398 syntmp-mod-1387)) syntmp-tmp-1395) ((lambda (syntmp-_-1399) (syntax-error (car syntmp-clauses-1385) "invalid syntax-case clause")) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) (car syntmp-clauses-1385))))) (syntmp-gen-clause-1381 (lambda (syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-pat-1404 syntmp-fender-1405 syntmp-exp-1406 syntmp-mod-1407) (call-with-values (lambda () (syntmp-convert-pattern-1379 syntmp-pat-1404 syntmp-keys-1401)) (lambda (syntmp-p-1408 syntmp-pvars-1409) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1409))) (syntax-error syntmp-pat-1404 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1410) (not (syntmp-ellipsis?-162 (car syntmp-x-1410)))) syntmp-pvars-1409)) (syntax-error syntmp-pat-1404 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1411 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1411) (let ((syntmp-y-1412 (syntmp-build-annotated-94 #f syntmp-y-1411))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1413) ((lambda (syntmp-tmp-1414) (if syntmp-tmp-1414 (apply (lambda () syntmp-y-1412) syntmp-tmp-1414) ((lambda (syntmp-_-1415) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1412 (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-fender-1405 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1413))) (syntax-dispatch syntmp-tmp-1413 (quote #(atom #t))))) syntmp-fender-1405) (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-exp-1406 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-gen-syntax-case-1382 syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-mod-1407)))))) (if (eq? syntmp-p-1408 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1400)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1400 (syntmp-build-data-95 #f syntmp-p-1408))))))))))))) (syntmp-build-dispatch-call-1380 (lambda (syntmp-pvars-1416 syntmp-exp-1417 syntmp-y-1418 syntmp-r-1419 syntmp-mod-1420) (let ((syntmp-ids-1421 (map car syntmp-pvars-1416)) (syntmp-levels-1422 (map cdr syntmp-pvars-1416))) (let ((syntmp-labels-1423 (syntmp-gen-labels-123 syntmp-ids-1421)) (syntmp-new-vars-1424 (map syntmp-gen-var-165 syntmp-ids-1421))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1424 (syntmp-chi-153 syntmp-exp-1417 (syntmp-extend-env-111 syntmp-labels-1423 (map (lambda (syntmp-var-1425 syntmp-level-1426) (cons (quote syntax) (cons syntmp-var-1425 syntmp-level-1426))) syntmp-new-vars-1424 (map cdr syntmp-pvars-1416)) syntmp-r-1419) (syntmp-make-binding-wrap-134 syntmp-ids-1421 syntmp-labels-1423 (quote (()))) syntmp-mod-1420))) syntmp-y-1418)))))) (syntmp-convert-pattern-1379 (lambda (syntmp-pattern-1427 syntmp-keys-1428) (let syntmp-cvt-1429 ((syntmp-p-1430 syntmp-pattern-1427) (syntmp-n-1431 0) (syntmp-ids-1432 (quote ()))) (if (syntmp-id?-117 syntmp-p-1430) (if (syntmp-bound-id-member?-144 syntmp-p-1430 syntmp-keys-1428) (values (vector (quote free-id) syntmp-p-1430) syntmp-ids-1432) (values (quote any) (cons (cons syntmp-p-1430 syntmp-n-1431) syntmp-ids-1432))) ((lambda (syntmp-tmp-1433) ((lambda (syntmp-tmp-1434) (if (if syntmp-tmp-1434 (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (syntmp-ellipsis?-162 syntmp-dots-1436)) syntmp-tmp-1434) #f) (apply (lambda (syntmp-x-1437 syntmp-dots-1438) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1437 (syntmp-fx+-85 syntmp-n-1431 1) syntmp-ids-1432)) (lambda (syntmp-p-1439 syntmp-ids-1440) (values (if (eq? syntmp-p-1439 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1439)) syntmp-ids-1440)))) syntmp-tmp-1434) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-x-1442 syntmp-y-1443) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-y-1443 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-y-1444 syntmp-ids-1445) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1442 syntmp-n-1431 syntmp-ids-1445)) (lambda (syntmp-x-1446 syntmp-ids-1447) (values (cons syntmp-x-1446 syntmp-y-1444) syntmp-ids-1447)))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda () (values (quote ()) syntmp-ids-1432)) syntmp-tmp-1448) ((lambda (syntmp-tmp-1449) (if syntmp-tmp-1449 (apply (lambda (syntmp-x-1450) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1450 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-p-1452 syntmp-ids-1453) (values (vector (quote vector) syntmp-p-1452) syntmp-ids-1453)))) syntmp-tmp-1449) ((lambda (syntmp-x-1454) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1430 (quote (())))) syntmp-ids-1432)) syntmp-tmp-1433))) (syntax-dispatch syntmp-tmp-1433 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1433 (quote ()))))) (syntax-dispatch syntmp-tmp-1433 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1433 (quote (any any))))) syntmp-p-1430)))))) (lambda (syntmp-e-1455 syntmp-r-1456 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459) (let ((syntmp-e-1460 (syntmp-source-wrap-146 syntmp-e-1455 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459))) ((lambda (syntmp-tmp-1461) ((lambda (syntmp-tmp-1462) (if syntmp-tmp-1462 (apply (lambda (syntmp-_-1463 syntmp-val-1464 syntmp-key-1465 syntmp-m-1466) (if (andmap (lambda (syntmp-x-1467) (and (syntmp-id?-117 syntmp-x-1467) (not (syntmp-ellipsis?-162 syntmp-x-1467)))) syntmp-key-1465) (let ((syntmp-x-1469 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1458 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1469) (syntmp-gen-syntax-case-1382 (syntmp-build-annotated-94 #f syntmp-x-1469) syntmp-key-1465 syntmp-m-1466 syntmp-r-1456 syntmp-mod-1459))) (syntmp-chi-153 syntmp-val-1464 syntmp-r-1456 (quote (())) syntmp-mod-1459)))) (syntax-error syntmp-e-1460 "invalid literals list in"))) syntmp-tmp-1462) (syntax-error syntmp-tmp-1461))) (syntax-dispatch syntmp-tmp-1461 (quote (any any each-any . each-any))))) syntmp-e-1460))))) (set! sc-expand (let ((syntmp-m-1472 (quote e)) (syntmp-esew-1473 (quote (eval)))) (lambda (syntmp-x-1474) (if (and (pair? syntmp-x-1474) (equal? (car syntmp-x-1474) syntmp-noexpand-84)) (cadr syntmp-x-1474) (syntmp-chi-top-152 syntmp-x-1474 (quote ()) (quote ((top))) syntmp-m-1472 syntmp-esew-1473 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1475 (quote e)) (syntmp-esew-1476 (quote (eval)))) (lambda (syntmp-x-1478 . syntmp-rest-1477) (if (and (pair? syntmp-x-1478) (equal? (car syntmp-x-1478) syntmp-noexpand-84)) (cadr syntmp-x-1478) (syntmp-chi-top-152 syntmp-x-1478 (quote ()) (quote ((top))) (if (null? syntmp-rest-1477) syntmp-m-1475 (car syntmp-rest-1477)) (if (or (null? syntmp-rest-1477) (null? (cdr syntmp-rest-1477))) syntmp-esew-1476 (cadr syntmp-rest-1477)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1479) (syntmp-nonsymbol-id?-116 syntmp-x-1479))) (set! datum->syntax-object (lambda (syntmp-id-1480 syntmp-datum-1481) (syntmp-make-syntax-object-100 syntmp-datum-1481 (syntmp-syntax-object-wrap-103 syntmp-id-1480) #f))) (set! syntax-object->datum (lambda (syntmp-x-1482) (syntmp-strip-164 syntmp-x-1482 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1483) (begin (let ((syntmp-x-1484 syntmp-ls-1483)) (if (not (list? syntmp-x-1484)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1484))) (map (lambda (syntmp-x-1485) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1483)))) (set! free-identifier=? (lambda (syntmp-x-1486 syntmp-y-1487) (begin (let ((syntmp-x-1488 syntmp-x-1486)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1488)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1488))) (let ((syntmp-x-1489 syntmp-y-1487)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1489)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1489))) (syntmp-free-id=?-140 syntmp-x-1486 syntmp-y-1487)))) (set! bound-identifier=? (lambda (syntmp-x-1490 syntmp-y-1491) (begin (let ((syntmp-x-1492 syntmp-x-1490)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1492)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1492))) (let ((syntmp-x-1493 syntmp-y-1491)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1493)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1493))) (syntmp-bound-id=?-141 syntmp-x-1490 syntmp-y-1491)))) (set! syntax-error (lambda (syntmp-object-1495 . syntmp-messages-1494) (begin (for-each (lambda (syntmp-x-1496) (let ((syntmp-x-1497 syntmp-x-1496)) (if (not (string? syntmp-x-1497)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1497)))) syntmp-messages-1494) (let ((syntmp-message-1498 (if (null? syntmp-messages-1494) "invalid syntax" (apply string-append syntmp-messages-1494)))) (syntmp-error-hook-91 #f syntmp-message-1498 (syntmp-strip-164 syntmp-object-1495 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1499 syntmp-v-1500) (begin (let ((syntmp-x-1501 syntmp-sym-1499)) (if (not (symbol? syntmp-x-1501)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1501))) (let ((syntmp-x-1502 syntmp-v-1500)) (if (not (procedure? syntmp-x-1502)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1502))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1499 syntmp-v-1500)))) (letrec ((syntmp-match-1507 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512) (cond ((not syntmp-r-1511) #f) ((eq? syntmp-p-1509 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1508 syntmp-w-1510 syntmp-mod-1512) syntmp-r-1511)) ((syntmp-syntax-object?-101 syntmp-e-1508) (syntmp-match*-1506 (let ((syntmp-e-1513 (syntmp-syntax-object-expression-102 syntmp-e-1508))) (if (annotation? syntmp-e-1513) (annotation-expression syntmp-e-1513) syntmp-e-1513)) syntmp-p-1509 (syntmp-join-wraps-136 syntmp-w-1510 (syntmp-syntax-object-wrap-103 syntmp-e-1508)) syntmp-r-1511 (syntmp-syntax-object-module-104 syntmp-e-1508))) (else (syntmp-match*-1506 (let ((syntmp-e-1514 syntmp-e-1508)) (if (annotation? syntmp-e-1514) (annotation-expression syntmp-e-1514) syntmp-e-1514)) syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512))))) (syntmp-match*-1506 (lambda (syntmp-e-1515 syntmp-p-1516 syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) (cond ((null? syntmp-p-1516) (and (null? syntmp-e-1515) syntmp-r-1518)) ((pair? syntmp-p-1516) (and (pair? syntmp-e-1515) (syntmp-match-1507 (car syntmp-e-1515) (car syntmp-p-1516) syntmp-w-1517 (syntmp-match-1507 (cdr syntmp-e-1515) (cdr syntmp-p-1516) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) syntmp-mod-1519))) ((eq? syntmp-p-1516 (quote each-any)) (let ((syntmp-l-1520 (syntmp-match-each-any-1504 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1520 (cons syntmp-l-1520 syntmp-r-1518)))) (else (let ((syntmp-t-1521 (vector-ref syntmp-p-1516 0))) (if (memv syntmp-t-1521 (quote (each))) (if (null? syntmp-e-1515) (syntmp-match-empty-1505 (vector-ref syntmp-p-1516 1) syntmp-r-1518) (let ((syntmp-l-1522 (syntmp-match-each-1503 syntmp-e-1515 (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1522 (let syntmp-collect-1523 ((syntmp-l-1524 syntmp-l-1522)) (if (null? (car syntmp-l-1524)) syntmp-r-1518 (cons (map car syntmp-l-1524) (syntmp-collect-1523 (map cdr syntmp-l-1524)))))))) (if (memv syntmp-t-1521 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1515) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519) (vector-ref syntmp-p-1516 1)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (atom))) (and (equal? (vector-ref syntmp-p-1516 1) (syntmp-strip-164 syntmp-e-1515 syntmp-w-1517)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (vector))) (and (vector? syntmp-e-1515) (syntmp-match-1507 (vector->list syntmp-e-1515) (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519))))))))))) (syntmp-match-empty-1505 (lambda (syntmp-p-1525 syntmp-r-1526) (cond ((null? syntmp-p-1525) syntmp-r-1526) ((eq? syntmp-p-1525 (quote any)) (cons (quote ()) syntmp-r-1526)) ((pair? syntmp-p-1525) (syntmp-match-empty-1505 (car syntmp-p-1525) (syntmp-match-empty-1505 (cdr syntmp-p-1525) syntmp-r-1526))) ((eq? syntmp-p-1525 (quote each-any)) (cons (quote ()) syntmp-r-1526)) (else (let ((syntmp-t-1527 (vector-ref syntmp-p-1525 0))) (if (memv syntmp-t-1527 (quote (each))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526) (if (memv syntmp-t-1527 (quote (free-id atom))) syntmp-r-1526 (if (memv syntmp-t-1527 (quote (vector))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526))))))))) (syntmp-match-each-any-1504 (lambda (syntmp-e-1528 syntmp-w-1529 syntmp-mod-1530) (cond ((annotation? syntmp-e-1528) (syntmp-match-each-any-1504 (annotation-expression syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530)) ((pair? syntmp-e-1528) (let ((syntmp-l-1531 (syntmp-match-each-any-1504 (cdr syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530))) (and syntmp-l-1531 (cons (syntmp-wrap-145 (car syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530) syntmp-l-1531)))) ((null? syntmp-e-1528) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1528) (syntmp-match-each-any-1504 (syntmp-syntax-object-expression-102 syntmp-e-1528) (syntmp-join-wraps-136 syntmp-w-1529 (syntmp-syntax-object-wrap-103 syntmp-e-1528)) syntmp-mod-1530)) (else #f)))) (syntmp-match-each-1503 (lambda (syntmp-e-1532 syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535) (cond ((annotation? syntmp-e-1532) (syntmp-match-each-1503 (annotation-expression syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535)) ((pair? syntmp-e-1532) (let ((syntmp-first-1536 (syntmp-match-1507 (car syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 (quote ()) syntmp-mod-1535))) (and syntmp-first-1536 (let ((syntmp-rest-1537 (syntmp-match-each-1503 (cdr syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535))) (and syntmp-rest-1537 (cons syntmp-first-1536 syntmp-rest-1537)))))) ((null? syntmp-e-1532) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1532) (syntmp-match-each-1503 (syntmp-syntax-object-expression-102 syntmp-e-1532) syntmp-p-1533 (syntmp-join-wraps-136 syntmp-w-1534 (syntmp-syntax-object-wrap-103 syntmp-e-1532)) (syntmp-syntax-object-module-104 syntmp-e-1532))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1538 syntmp-p-1539) (cond ((eq? syntmp-p-1539 (quote any)) (list syntmp-e-1538)) ((syntmp-syntax-object?-101 syntmp-e-1538) (syntmp-match*-1506 (let ((syntmp-e-1540 (syntmp-syntax-object-expression-102 syntmp-e-1538))) (if (annotation? syntmp-e-1540) (annotation-expression syntmp-e-1540) syntmp-e-1540)) syntmp-p-1539 (syntmp-syntax-object-wrap-103 syntmp-e-1538) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1538))) (else (syntmp-match*-1506 (let ((syntmp-e-1541 syntmp-e-1538)) (if (annotation? syntmp-e-1541) (annotation-expression syntmp-e-1541) syntmp-e-1541)) syntmp-p-1539 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-e1-1546 syntmp-e2-1547) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1546 syntmp-e2-1547))) syntmp-tmp-1544) ((lambda (syntmp-tmp-1549) (if syntmp-tmp-1549 (apply (lambda (syntmp-_-1550 syntmp-out-1551 syntmp-in-1552 syntmp-e1-1553 syntmp-e2-1554) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-in-1552 (quote ()) (list syntmp-out-1551 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1553 syntmp-e2-1554))))) syntmp-tmp-1549) ((lambda (syntmp-tmp-1556) (if syntmp-tmp-1556 (apply (lambda (syntmp-_-1557 syntmp-out-1558 syntmp-in-1559 syntmp-e1-1560 syntmp-e2-1561) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-in-1559) (quote ()) (list syntmp-out-1558 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1560 syntmp-e2-1561))))) syntmp-tmp-1556) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any () any . each-any))))) syntmp-x-1542))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1583) ((lambda (syntmp-tmp-1584) ((lambda (syntmp-tmp-1585) (if syntmp-tmp-1585 (apply (lambda (syntmp-_-1586 syntmp-k-1587 syntmp-keyword-1588 syntmp-pattern-1589 syntmp-template-1590) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-k-1587 (map (lambda (syntmp-tmp-1593 syntmp-tmp-1592) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-tmp-1592) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-tmp-1593))) syntmp-template-1590 syntmp-pattern-1589)))))) syntmp-tmp-1585) (syntax-error syntmp-tmp-1584))) (syntax-dispatch syntmp-tmp-1584 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1583))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1604) ((lambda (syntmp-tmp-1605) ((lambda (syntmp-tmp-1606) (if (if syntmp-tmp-1606 (apply (lambda (syntmp-let*-1607 syntmp-x-1608 syntmp-v-1609 syntmp-e1-1610 syntmp-e2-1611) (andmap identifier? syntmp-x-1608)) syntmp-tmp-1606) #f) (apply (lambda (syntmp-let*-1613 syntmp-x-1614 syntmp-v-1615 syntmp-e1-1616 syntmp-e2-1617) (let syntmp-f-1618 ((syntmp-bindings-1619 (map list syntmp-x-1614 syntmp-v-1615))) (if (null? syntmp-bindings-1619) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons syntmp-e1-1616 syntmp-e2-1617))) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-body-1625 syntmp-binding-1626) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list syntmp-binding-1626) syntmp-body-1625)) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any any))))) (list (syntmp-f-1618 (cdr syntmp-bindings-1619)) (car syntmp-bindings-1619)))))) syntmp-tmp-1606) (syntax-error syntmp-tmp-1605))) (syntax-dispatch syntmp-tmp-1605 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1604))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1646) ((lambda (syntmp-tmp-1647) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-_-1649 syntmp-var-1650 syntmp-init-1651 syntmp-step-1652 syntmp-e0-1653 syntmp-e1-1654 syntmp-c-1655) ((lambda (syntmp-tmp-1656) ((lambda (syntmp-tmp-1657) (if syntmp-tmp-1657 (apply (lambda (syntmp-step-1658) ((lambda (syntmp-tmp-1659) ((lambda (syntmp-tmp-1660) (if syntmp-tmp-1660 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-e0-1653) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-step-1658))))))) syntmp-tmp-1660) ((lambda (syntmp-tmp-1665) (if syntmp-tmp-1665 (apply (lambda (syntmp-e1-1666 syntmp-e2-1667) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-e0-1653 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1666 syntmp-e2-1667)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-step-1658))))))) syntmp-tmp-1665) (syntax-error syntmp-tmp-1659))) (syntax-dispatch syntmp-tmp-1659 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1659 (quote ())))) syntmp-e1-1654)) syntmp-tmp-1657) (syntax-error syntmp-tmp-1656))) (syntax-dispatch syntmp-tmp-1656 (quote each-any)))) (map (lambda (syntmp-v-1674 syntmp-s-1675) ((lambda (syntmp-tmp-1676) ((lambda (syntmp-tmp-1677) (if syntmp-tmp-1677 (apply (lambda () syntmp-v-1674) syntmp-tmp-1677) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-e-1679) syntmp-e-1679) syntmp-tmp-1678) ((lambda (syntmp-_-1680) (syntax-error syntmp-orig-x-1646)) syntmp-tmp-1676))) (syntax-dispatch syntmp-tmp-1676 (quote (any)))))) (syntax-dispatch syntmp-tmp-1676 (quote ())))) syntmp-s-1675)) syntmp-var-1650 syntmp-step-1652))) syntmp-tmp-1648) (syntax-error syntmp-tmp-1647))) (syntax-dispatch syntmp-tmp-1647 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1646))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1708 (lambda (syntmp-x-1712 syntmp-y-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-tmp-1715) (if syntmp-tmp-1715 (apply (lambda (syntmp-x-1716 syntmp-y-1717) ((lambda (syntmp-tmp-1718) ((lambda (syntmp-tmp-1719) (if syntmp-tmp-1719 (apply (lambda (syntmp-dy-1720) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-dx-1723) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons syntmp-dx-1723 syntmp-dy-1720))) syntmp-tmp-1722) ((lambda (syntmp-_-1724) (if (null? syntmp-dy-1720) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1716) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1716 syntmp-y-1717))) syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) syntmp-x-1716)) syntmp-tmp-1719) ((lambda (syntmp-tmp-1725) (if syntmp-tmp-1725 (apply (lambda (syntmp-stuff-1726) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons syntmp-x-1716 syntmp-stuff-1726))) syntmp-tmp-1725) ((lambda (syntmp-else-1727) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1716 syntmp-y-1717)) syntmp-tmp-1718))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) syntmp-y-1717)) syntmp-tmp-1715) (syntax-error syntmp-tmp-1714))) (syntax-dispatch syntmp-tmp-1714 (quote (any any))))) (list syntmp-x-1712 syntmp-y-1713)))) (syntmp-quasiappend-1709 (lambda (syntmp-x-1728 syntmp-y-1729) ((lambda (syntmp-tmp-1730) ((lambda (syntmp-tmp-1731) (if syntmp-tmp-1731 (apply (lambda (syntmp-x-1732 syntmp-y-1733) ((lambda (syntmp-tmp-1734) ((lambda (syntmp-tmp-1735) (if syntmp-tmp-1735 (apply (lambda () syntmp-x-1732) syntmp-tmp-1735) ((lambda (syntmp-_-1736) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1732 syntmp-y-1733)) syntmp-tmp-1734))) (syntax-dispatch syntmp-tmp-1734 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) syntmp-y-1733)) syntmp-tmp-1731) (syntax-error syntmp-tmp-1730))) (syntax-dispatch syntmp-tmp-1730 (quote (any any))))) (list syntmp-x-1728 syntmp-y-1729)))) (syntmp-quasivector-1710 (lambda (syntmp-x-1737) ((lambda (syntmp-tmp-1738) ((lambda (syntmp-x-1739) ((lambda (syntmp-tmp-1740) ((lambda (syntmp-tmp-1741) (if syntmp-tmp-1741 (apply (lambda (syntmp-x-1742) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector syntmp-x-1742))) syntmp-tmp-1741) ((lambda (syntmp-tmp-1744) (if syntmp-tmp-1744 (apply (lambda (syntmp-x-1745) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1745)) syntmp-tmp-1744) ((lambda (syntmp-_-1747) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1739)) syntmp-tmp-1740))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) syntmp-x-1739)) syntmp-tmp-1738)) syntmp-x-1737))) (syntmp-quasi-1711 (lambda (syntmp-p-1748 syntmp-lev-1749) ((lambda (syntmp-tmp-1750) ((lambda (syntmp-tmp-1751) (if syntmp-tmp-1751 (apply (lambda (syntmp-p-1752) (if (= syntmp-lev-1749 0) syntmp-p-1752 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (syntmp-quasi-1711 (list syntmp-p-1752) (- syntmp-lev-1749 1))))) syntmp-tmp-1751) ((lambda (syntmp-tmp-1753) (if syntmp-tmp-1753 (apply (lambda (syntmp-p-1754 syntmp-q-1755) (if (= syntmp-lev-1749 0) (syntmp-quasiappend-1709 syntmp-p-1754 (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)) (syntmp-quasicons-1708 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (syntmp-quasi-1711 (list syntmp-p-1754) (- syntmp-lev-1749 1))) (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)))) syntmp-tmp-1753) ((lambda (syntmp-tmp-1756) (if syntmp-tmp-1756 (apply (lambda (syntmp-p-1757) (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (syntmp-quasi-1711 (list syntmp-p-1757) (+ syntmp-lev-1749 1)))) syntmp-tmp-1756) ((lambda (syntmp-tmp-1758) (if syntmp-tmp-1758 (apply (lambda (syntmp-p-1759 syntmp-q-1760) (syntmp-quasicons-1708 (syntmp-quasi-1711 syntmp-p-1759 syntmp-lev-1749) (syntmp-quasi-1711 syntmp-q-1760 syntmp-lev-1749))) syntmp-tmp-1758) ((lambda (syntmp-tmp-1761) (if syntmp-tmp-1761 (apply (lambda (syntmp-x-1762) (syntmp-quasivector-1710 (syntmp-quasi-1711 syntmp-x-1762 syntmp-lev-1749))) syntmp-tmp-1761) ((lambda (syntmp-p-1764) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-p-1764)) syntmp-tmp-1750))) (syntax-dispatch syntmp-tmp-1750 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch syntmp-tmp-1750 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) syntmp-p-1748)))) (lambda (syntmp-x-1765) ((lambda (syntmp-tmp-1766) ((lambda (syntmp-tmp-1767) (if syntmp-tmp-1767 (apply (lambda (syntmp-_-1768 syntmp-e-1769) (syntmp-quasi-1711 syntmp-e-1769 0)) syntmp-tmp-1767) (syntax-error syntmp-tmp-1766))) (syntax-dispatch syntmp-tmp-1766 (quote (any any))))) syntmp-x-1765)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1829) (letrec ((syntmp-read-file-1830 (lambda (syntmp-fn-1831 syntmp-k-1832) (let ((syntmp-p-1833 (open-input-file syntmp-fn-1831))) (let syntmp-f-1834 ((syntmp-x-1835 (read syntmp-p-1833))) (if (eof-object? syntmp-x-1835) (begin (close-input-port syntmp-p-1833) (quote ())) (cons (datum->syntax-object syntmp-k-1832 syntmp-x-1835) (syntmp-f-1834 (read syntmp-p-1833))))))))) ((lambda (syntmp-tmp-1836) ((lambda (syntmp-tmp-1837) (if syntmp-tmp-1837 (apply (lambda (syntmp-k-1838 syntmp-filename-1839) (let ((syntmp-fn-1840 (syntax-object->datum syntmp-filename-1839))) ((lambda (syntmp-tmp-1841) ((lambda (syntmp-tmp-1842) (if syntmp-tmp-1842 (apply (lambda (syntmp-exp-1843) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-exp-1843)) syntmp-tmp-1842) (syntax-error syntmp-tmp-1841))) (syntax-dispatch syntmp-tmp-1841 (quote each-any)))) (syntmp-read-file-1830 syntmp-fn-1840 syntmp-k-1838)))) syntmp-tmp-1837) (syntax-error syntmp-tmp-1836))) (syntax-dispatch syntmp-tmp-1836 (quote (any any))))) syntmp-x-1829)))) (install-global-transformer (quote unquote) (lambda (syntmp-x-1860) ((lambda (syntmp-tmp-1861) ((lambda (syntmp-tmp-1862) (if syntmp-tmp-1862 (apply (lambda (syntmp-_-1863 syntmp-e-1864) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1864))) syntmp-tmp-1862) (syntax-error syntmp-tmp-1861))) (syntax-dispatch syntmp-tmp-1861 (quote (any any))))) syntmp-x-1860))) (install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1870) ((lambda (syntmp-tmp-1871) ((lambda (syntmp-tmp-1872) (if syntmp-tmp-1872 (apply (lambda (syntmp-_-1873 syntmp-e-1874) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1874))) syntmp-tmp-1872) (syntax-error syntmp-tmp-1871))) (syntax-dispatch syntmp-tmp-1871 (quote (any any))))) syntmp-x-1870))) -(install-global-transformer (quote case) (lambda (syntmp-x-1880) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-tmp-1882) (if syntmp-tmp-1882 (apply (lambda (syntmp-_-1883 syntmp-e-1884 syntmp-m1-1885 syntmp-m2-1886) ((lambda (syntmp-tmp-1887) ((lambda (syntmp-body-1888) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1884)) syntmp-body-1888)) syntmp-tmp-1887)) (let syntmp-f-1889 ((syntmp-clause-1890 syntmp-m1-1885) (syntmp-clauses-1891 syntmp-m2-1886)) (if (null? syntmp-clauses-1891) ((lambda (syntmp-tmp-1893) ((lambda (syntmp-tmp-1894) (if syntmp-tmp-1894 (apply (lambda (syntmp-e1-1895 syntmp-e2-1896) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1895 syntmp-e2-1896))) syntmp-tmp-1894) ((lambda (syntmp-tmp-1898) (if syntmp-tmp-1898 (apply (lambda (syntmp-k-1899 syntmp-e1-1900 syntmp-e2-1901) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1899)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1900 syntmp-e2-1901)))) syntmp-tmp-1898) ((lambda (syntmp-_-1904) (syntax-error syntmp-x-1880)) syntmp-tmp-1893))) (syntax-dispatch syntmp-tmp-1893 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1893 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1890) ((lambda (syntmp-tmp-1905) ((lambda (syntmp-rest-1906) ((lambda (syntmp-tmp-1907) ((lambda (syntmp-tmp-1908) (if syntmp-tmp-1908 (apply (lambda (syntmp-k-1909 syntmp-e1-1910 syntmp-e2-1911) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1909)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1910 syntmp-e2-1911)) syntmp-rest-1906)) syntmp-tmp-1908) ((lambda (syntmp-_-1914) (syntax-error syntmp-x-1880)) syntmp-tmp-1907))) (syntax-dispatch syntmp-tmp-1907 (quote (each-any any . each-any))))) syntmp-clause-1890)) syntmp-tmp-1905)) (syntmp-f-1889 (car syntmp-clauses-1891) (cdr syntmp-clauses-1891))))))) syntmp-tmp-1882) (syntax-error syntmp-tmp-1881))) (syntax-dispatch syntmp-tmp-1881 (quote (any any any . each-any))))) syntmp-x-1880))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1944) ((lambda (syntmp-tmp-1945) ((lambda (syntmp-tmp-1946) (if syntmp-tmp-1946 (apply (lambda (syntmp-_-1947 syntmp-e-1948) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1948)) (list (cons syntmp-_-1947 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1948 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1946) (syntax-error syntmp-tmp-1945))) (syntax-dispatch syntmp-tmp-1945 (quote (any any))))) syntmp-x-1944))) +(install-global-transformer (quote case) (lambda (syntmp-x-1880) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-tmp-1882) (if syntmp-tmp-1882 (apply (lambda (syntmp-_-1883 syntmp-e-1884 syntmp-m1-1885 syntmp-m2-1886) ((lambda (syntmp-tmp-1887) ((lambda (syntmp-body-1888) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-e-1884)) syntmp-body-1888)) syntmp-tmp-1887)) (let syntmp-f-1889 ((syntmp-clause-1890 syntmp-m1-1885) (syntmp-clauses-1891 syntmp-m2-1886)) (if (null? syntmp-clauses-1891) ((lambda (syntmp-tmp-1893) ((lambda (syntmp-tmp-1894) (if syntmp-tmp-1894 (apply (lambda (syntmp-e1-1895 syntmp-e2-1896) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1895 syntmp-e2-1896))) syntmp-tmp-1894) ((lambda (syntmp-tmp-1898) (if syntmp-tmp-1898 (apply (lambda (syntmp-k-1899 syntmp-e1-1900 syntmp-e2-1901) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-k-1899)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1900 syntmp-e2-1901)))) syntmp-tmp-1898) ((lambda (syntmp-_-1904) (syntax-error syntmp-x-1880)) syntmp-tmp-1893))) (syntax-dispatch syntmp-tmp-1893 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1893 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) syntmp-clause-1890) ((lambda (syntmp-tmp-1905) ((lambda (syntmp-rest-1906) ((lambda (syntmp-tmp-1907) ((lambda (syntmp-tmp-1908) (if syntmp-tmp-1908 (apply (lambda (syntmp-k-1909 syntmp-e1-1910 syntmp-e2-1911) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-k-1909)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1910 syntmp-e2-1911)) syntmp-rest-1906)) syntmp-tmp-1908) ((lambda (syntmp-_-1914) (syntax-error syntmp-x-1880)) syntmp-tmp-1907))) (syntax-dispatch syntmp-tmp-1907 (quote (each-any any . each-any))))) syntmp-clause-1890)) syntmp-tmp-1905)) (syntmp-f-1889 (car syntmp-clauses-1891) (cdr syntmp-clauses-1891))))))) syntmp-tmp-1882) (syntax-error syntmp-tmp-1881))) (syntax-dispatch syntmp-tmp-1881 (quote (any any any . each-any))))) syntmp-x-1880))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1944) ((lambda (syntmp-tmp-1945) ((lambda (syntmp-tmp-1946) (if syntmp-tmp-1946 (apply (lambda (syntmp-_-1947 syntmp-e-1948) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-e-1948)) (list (cons syntmp-_-1947 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e-1948 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) syntmp-tmp-1946) (syntax-error syntmp-tmp-1945))) (syntax-dispatch syntmp-tmp-1945 (quote (any any))))) syntmp-x-1944))) From 85e95b47108a84f0829cf17c5dde40f53814186e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 14:08:32 +0200 Subject: [PATCH 063/375] fix load for syncase-in-boot-9; compile-psyntax works again * module/ice-9/r4rs.scm: * module/ice-9/boot-9.scm (%load-verbosely, assert-load-verbosity) (%load-announce, %load-hook, load): Move these from r4rs.scm to boot-9.scm. * module/ice-9/compile-psyntax.scm: Update to work with syncase-in-boot-9. * module/ice-9/psyntax-pp.scm: Recompiled with syncase-in-boot-9. --- module/ice-9/boot-9.scm | 20 ++++++++++++++++++++ module/ice-9/compile-psyntax.scm | 9 +++------ module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/r4rs.scm | 25 ------------------------- 4 files changed, 34 insertions(+), 42 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f06cc92b8..e4c3cb2f8 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -761,6 +761,26 @@ (start-stack 'load-stack (primitive-load-path name))) +(define %load-verbosely #f) +(define (assert-load-verbosity v) (set! %load-verbosely v)) + +(define (%load-announce file) + (if %load-verbosely + (with-output-to-port (current-error-port) + (lambda () + (display ";;; ") + (display "loading ") + (display file) + (newline) + (force-output))))) + +(set! %load-hook %load-announce) + +(define (load name . reader) + (with-fluid* current-reader (and (pair? reader) (car reader)) + (lambda () + (start-stack 'load-stack + (primitive-load name))))) diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 10a307be1..ac6683eb0 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,11 +1,9 @@ -(use-modules (ice-9 syncase)) - -;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls +;; XXX - We need to be inside (guile) since psyntax.ss calls ;; `eval' int he `interaction-environment' aka the current module and ;; it expects to have `andmap' there. The reason for this escapes me ;; at the moment. ;; -(define-module (ice-9 syncase)) +(define-module (guile)) (define source (list-ref (command-line) 1)) (define target (list-ref (command-line) 2)) @@ -18,8 +16,7 @@ (close-port out) (close-port in)) (begin - (write (strip-expansion-structures - (sc-expand3 x 'c '(compile load eval))) + (write (sc-expand3 x 'c '(compile load eval)) out) (newline out) (loop (read in)))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 9df53fff9..4a2bc8796 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-717 syntmp-e-718)) (lambda (syntmp-id-724 syntmp-mod-725) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-725 syntmp-id-724 #f)))) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-726) ((lambda (syntmp-tmp-727) (if syntmp-tmp-727 (apply (lambda (syntmp-_-728 syntmp-e1-729 syntmp-e2-730) (syntmp-chi-sequence-147 (cons syntmp-e1-729 syntmp-e2-730) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-727) (syntax-error syntmp-tmp-726))) (syntax-dispatch syntmp-tmp-726 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-732) ((lambda (syntmp-tmp-733) (if syntmp-tmp-733 (apply (lambda (syntmp-_-734 syntmp-x-735 syntmp-e1-736 syntmp-e2-737) (let ((syntmp-when-list-738 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-735 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-738) (syntmp-chi-sequence-147 (cons syntmp-e1-736 syntmp-e2-737) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-733) (syntax-error syntmp-tmp-732))) (syntax-dispatch syntmp-tmp-732 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722))))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-741 syntmp-r-742 syntmp-w-743 syntmp-mod-744) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-741 syntmp-r-742 syntmp-w-743 #f #f syntmp-mod-744)) (lambda (syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-w-748 syntmp-s-749 syntmp-mod-750) (syntmp-chi-expr-154 syntmp-type-745 syntmp-value-746 syntmp-e-747 syntmp-r-742 syntmp-w-748 syntmp-s-749 syntmp-mod-750))))) (syntmp-chi-top-152 (lambda (syntmp-e-751 syntmp-r-752 syntmp-w-753 syntmp-m-754 syntmp-esew-755 syntmp-mod-756) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-751 syntmp-r-752 syntmp-w-753 #f #f syntmp-mod-756)) (lambda (syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-w-774 syntmp-s-775 syntmp-mod-776) (let ((syntmp-t-777 syntmp-type-771)) (if (memv syntmp-t-777 (quote (begin-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780) (syntmp-chi-void-161)) syntmp-tmp-779) ((lambda (syntmp-tmp-781) (if syntmp-tmp-781 (apply (lambda (syntmp-_-782 syntmp-e1-783 syntmp-e2-784) (syntmp-chi-top-sequence-148 (cons syntmp-e1-783 syntmp-e2-784) syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-m-754 syntmp-esew-755 syntmp-mod-776)) syntmp-tmp-781) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-778 (quote (any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776 (lambda (syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-mod-790) (syntmp-chi-top-sequence-148 syntmp-body-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-m-754 syntmp-esew-755 syntmp-mod-790))) (if (memv syntmp-t-777 (quote (eval-when-form))) ((lambda (syntmp-tmp-791) ((lambda (syntmp-tmp-792) (if syntmp-tmp-792 (apply (lambda (syntmp-_-793 syntmp-x-794 syntmp-e1-795 syntmp-e2-796) (let ((syntmp-when-list-797 (syntmp-chi-when-list-150 syntmp-e-773 syntmp-x-794 syntmp-w-774)) (syntmp-body-798 (cons syntmp-e1-795 syntmp-e2-796))) (cond ((eq? syntmp-m-754 (quote e)) (if (memq (quote eval) syntmp-when-list-797) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-797) (if (or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c&e) (quote (compile load)) syntmp-mod-776) (if (memq syntmp-m-754 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote c) (quote (load)) syntmp-mod-776) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-797) (and (eq? syntmp-m-754 (quote c&e)) (memq (quote eval) syntmp-when-list-797))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-798 syntmp-r-752 syntmp-w-774 syntmp-s-775 (quote e) (quote (eval)) syntmp-mod-776) syntmp-mod-776) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-792) (syntax-error syntmp-tmp-791))) (syntax-dispatch syntmp-tmp-791 (quote (any each-any any . each-any))))) syntmp-e-773) (if (memv syntmp-t-777 (quote (define-syntax-form))) (let ((syntmp-n-801 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774)) (syntmp-r-802 (syntmp-macros-only-env-113 syntmp-r-752))) (let ((syntmp-t-803 syntmp-m-754)) (if (memv syntmp-t-803 (quote (c))) (if (memq (quote compile) syntmp-esew-755) (let ((syntmp-e-804 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-804 syntmp-mod-776) (if (memq (quote load) syntmp-esew-755) syntmp-e-804 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-755) (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) (syntmp-chi-void-161))) (if (memv syntmp-t-803 (quote (c&e))) (let ((syntmp-e-805 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-805 syntmp-mod-776) syntmp-e-805)) (begin (if (memq (quote eval) syntmp-esew-755) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-801 (syntmp-chi-153 syntmp-e-773 syntmp-r-802 syntmp-w-774 syntmp-mod-776)) syntmp-mod-776)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-777 (quote (define-form))) (let ((syntmp-n-806 (syntmp-id-var-name-139 syntmp-value-772 syntmp-w-774))) (let ((syntmp-type-807 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-806 syntmp-r-752 syntmp-mod-776)))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (global))) (let ((syntmp-x-809 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-776)) syntmp-x-809)) (if (memv syntmp-t-808 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "identifier out of context") (if (eq? syntmp-type-807 (quote external-macro)) (let ((syntmp-x-810 (syntmp-build-annotated-94 syntmp-s-775 (list (quote define) syntmp-n-806 (syntmp-chi-153 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-mod-776))))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-810 syntmp-mod-776)) syntmp-x-810)) (syntax-error (syntmp-wrap-145 syntmp-value-772 syntmp-w-774 syntmp-mod-776) "cannot define keyword at top level"))))))) (let ((syntmp-x-811 (syntmp-chi-expr-154 syntmp-type-771 syntmp-value-772 syntmp-e-773 syntmp-r-752 syntmp-w-774 syntmp-s-775 syntmp-mod-776))) (begin (if (eq? syntmp-m-754 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-811 syntmp-mod-776)) syntmp-x-811)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (cond ((symbol? syntmp-e-812) (let ((syntmp-n-818 (syntmp-id-var-name-139 syntmp-e-812 syntmp-w-814))) (let ((syntmp-b-819 (syntmp-lookup-114 syntmp-n-818 syntmp-r-813 syntmp-mod-817))) (let ((syntmp-type-820 (syntmp-binding-type-109 syntmp-b-819))) (let ((syntmp-t-821 syntmp-type-820)) (if (memv syntmp-t-821 (quote (lexical))) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (global))) (values syntmp-type-820 syntmp-n-818 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-821 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (values syntmp-type-820 (syntmp-binding-value-110 syntmp-b-819) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))))))) ((pair? syntmp-e-812) (let ((syntmp-first-822 (car syntmp-e-812))) (if (syntmp-id?-117 syntmp-first-822) (let ((syntmp-n-823 (syntmp-id-var-name-139 syntmp-first-822 syntmp-w-814))) (let ((syntmp-b-824 (syntmp-lookup-114 syntmp-n-823 syntmp-r-813 (or (and (syntmp-syntax-object?-101 syntmp-first-822) (syntmp-syntax-object-module-104 syntmp-first-822)) syntmp-mod-817)))) (let ((syntmp-type-825 (syntmp-binding-type-109 syntmp-b-824))) (let ((syntmp-t-826 syntmp-type-825)) (if (memv syntmp-t-826 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (global))) (values (quote global-call) syntmp-n-823 syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-r-813 syntmp-w-814 syntmp-rib-816 syntmp-mod-817) syntmp-r-813 (quote (())) syntmp-s-815 syntmp-rib-816 syntmp-mod-817) (if (memv syntmp-t-826 (quote (core external-macro module-ref))) (values syntmp-type-825 (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-824) syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (begin))) (values (quote begin-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817) (if (memv syntmp-t-826 (quote (define))) ((lambda (syntmp-tmp-827) ((lambda (syntmp-tmp-828) (if (if syntmp-tmp-828 (apply (lambda (syntmp-_-829 syntmp-name-830 syntmp-val-831) (syntmp-id?-117 syntmp-name-830)) syntmp-tmp-828) #f) (apply (lambda (syntmp-_-832 syntmp-name-833 syntmp-val-834) (values (quote define-form) syntmp-name-833 syntmp-val-834 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-828) ((lambda (syntmp-tmp-835) (if (if syntmp-tmp-835 (apply (lambda (syntmp-_-836 syntmp-name-837 syntmp-args-838 syntmp-e1-839 syntmp-e2-840) (and (syntmp-id?-117 syntmp-name-837) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-838)))) syntmp-tmp-835) #f) (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-args-843 syntmp-e1-844 syntmp-e2-845) (values (quote define-form) (syntmp-wrap-145 syntmp-name-842 syntmp-w-814 syntmp-mod-817) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (syntmp-wrap-145 (cons syntmp-args-843 (cons syntmp-e1-844 syntmp-e2-845)) syntmp-w-814 syntmp-mod-817)) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-835) ((lambda (syntmp-tmp-847) (if (if syntmp-tmp-847 (apply (lambda (syntmp-_-848 syntmp-name-849) (syntmp-id?-117 syntmp-name-849)) syntmp-tmp-847) #f) (apply (lambda (syntmp-_-850 syntmp-name-851) (values (quote define-form) (syntmp-wrap-145 syntmp-name-851 syntmp-w-814 syntmp-mod-817) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) syntmp-s-815 syntmp-mod-817)) syntmp-tmp-847) (syntax-error syntmp-tmp-827))) (syntax-dispatch syntmp-tmp-827 (quote (any any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-827 (quote (any any any))))) syntmp-e-812) (if (memv syntmp-t-826 (quote (define-syntax))) ((lambda (syntmp-tmp-852) ((lambda (syntmp-tmp-853) (if (if syntmp-tmp-853 (apply (lambda (syntmp-_-854 syntmp-name-855 syntmp-val-856) (syntmp-id?-117 syntmp-name-855)) syntmp-tmp-853) #f) (apply (lambda (syntmp-_-857 syntmp-name-858 syntmp-val-859) (values (quote define-syntax-form) syntmp-name-858 syntmp-val-859 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) syntmp-tmp-853) (syntax-error syntmp-tmp-852))) (syntax-dispatch syntmp-tmp-852 (quote (any any any))))) syntmp-e-812) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))))))))))))) (values (quote call) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)))) ((syntmp-syntax-object?-101 syntmp-e-812) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-812) syntmp-r-813 (syntmp-join-wraps-136 syntmp-w-814 (syntmp-syntax-object-wrap-103 syntmp-e-812)) #f syntmp-rib-816 (or (syntmp-syntax-object-module-104 syntmp-e-812) syntmp-mod-817))) ((annotation? syntmp-e-812) (syntmp-syntax-type-151 (annotation-expression syntmp-e-812) syntmp-r-813 syntmp-w-814 (annotation-source syntmp-e-812) syntmp-rib-816 syntmp-mod-817)) ((self-evaluating? syntmp-e-812) (values (quote constant) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817)) (else (values (quote other) #f syntmp-e-812 syntmp-w-814 syntmp-s-815 syntmp-mod-817))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-860 syntmp-when-list-861 syntmp-w-862) (let syntmp-f-863 ((syntmp-when-list-864 syntmp-when-list-861) (syntmp-situations-865 (quote ()))) (if (null? syntmp-when-list-864) syntmp-situations-865 (syntmp-f-863 (cdr syntmp-when-list-864) (cons (let ((syntmp-x-866 (car syntmp-when-list-864))) (cond ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-866 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-866 syntmp-w-862 #f) "invalid eval-when situation")))) syntmp-situations-865)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-878 syntmp-e-879) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-878) syntmp-e-879)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-880 syntmp-r-881 syntmp-w-882 syntmp-s-883 syntmp-m-884 syntmp-esew-885 syntmp-mod-886) (syntmp-build-sequence-96 syntmp-s-883 (let syntmp-dobody-887 ((syntmp-body-888 syntmp-body-880) (syntmp-r-889 syntmp-r-881) (syntmp-w-890 syntmp-w-882) (syntmp-m-891 syntmp-m-884) (syntmp-esew-892 syntmp-esew-885) (syntmp-mod-893 syntmp-mod-886)) (if (null? syntmp-body-888) (quote ()) (let ((syntmp-first-894 (syntmp-chi-top-152 (car syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893))) (cons syntmp-first-894 (syntmp-dobody-887 (cdr syntmp-body-888) syntmp-r-889 syntmp-w-890 syntmp-m-891 syntmp-esew-892 syntmp-mod-893)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-895 syntmp-r-896 syntmp-w-897 syntmp-s-898 syntmp-mod-899) (syntmp-build-sequence-96 syntmp-s-898 (let syntmp-dobody-900 ((syntmp-body-901 syntmp-body-895) (syntmp-r-902 syntmp-r-896) (syntmp-w-903 syntmp-w-897) (syntmp-mod-904 syntmp-mod-899)) (if (null? syntmp-body-901) (quote ()) (let ((syntmp-first-905 (syntmp-chi-153 (car syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904))) (cons syntmp-first-905 (syntmp-dobody-900 (cdr syntmp-body-901) syntmp-r-902 syntmp-w-903 syntmp-mod-904)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-906 syntmp-w-907 syntmp-s-908 syntmp-defmod-909) (syntmp-wrap-145 (if syntmp-s-908 (make-annotation syntmp-x-906 syntmp-s-908 #f) syntmp-x-906) syntmp-w-907 syntmp-defmod-909))) (syntmp-wrap-145 (lambda (syntmp-x-910 syntmp-w-911 syntmp-defmod-912) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-911)) (null? (syntmp-wrap-subst-121 syntmp-w-911))) syntmp-x-910) ((syntmp-syntax-object?-101 syntmp-x-910) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-910) (syntmp-join-wraps-136 syntmp-w-911 (syntmp-syntax-object-wrap-103 syntmp-x-910)) (syntmp-syntax-object-module-104 syntmp-x-910))) ((null? syntmp-x-910) syntmp-x-910) (else (syntmp-make-syntax-object-100 syntmp-x-910 syntmp-w-911 syntmp-defmod-912))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-913 syntmp-list-914) (and (not (null? syntmp-list-914)) (or (syntmp-bound-id=?-141 syntmp-x-913 (car syntmp-list-914)) (syntmp-bound-id-member?-144 syntmp-x-913 (cdr syntmp-list-914)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-915) (let syntmp-distinct?-916 ((syntmp-ids-917 syntmp-ids-915)) (or (null? syntmp-ids-917) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-917) (cdr syntmp-ids-917))) (syntmp-distinct?-916 (cdr syntmp-ids-917))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-918) (and (let syntmp-all-ids?-919 ((syntmp-ids-920 syntmp-ids-918)) (or (null? syntmp-ids-920) (and (syntmp-id?-117 (car syntmp-ids-920)) (syntmp-all-ids?-919 (cdr syntmp-ids-920))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-918)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-921 syntmp-j-922) (if (and (syntmp-syntax-object?-101 syntmp-i-921) (syntmp-syntax-object?-101 syntmp-j-922)) (and (eq? (let ((syntmp-e-923 (syntmp-syntax-object-expression-102 syntmp-i-921))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)) (let ((syntmp-e-924 (syntmp-syntax-object-expression-102 syntmp-j-922))) (if (annotation? syntmp-e-924) (annotation-expression syntmp-e-924) syntmp-e-924))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-921)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-922)))) (eq? (let ((syntmp-e-925 syntmp-i-921)) (if (annotation? syntmp-e-925) (annotation-expression syntmp-e-925) syntmp-e-925)) (let ((syntmp-e-926 syntmp-j-922)) (if (annotation? syntmp-e-926) (annotation-expression syntmp-e-926) syntmp-e-926)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-927 syntmp-j-928) (and (eq? (let ((syntmp-x-929 syntmp-i-927)) (let ((syntmp-e-930 (if (syntmp-syntax-object?-101 syntmp-x-929) (syntmp-syntax-object-expression-102 syntmp-x-929) syntmp-x-929))) (if (annotation? syntmp-e-930) (annotation-expression syntmp-e-930) syntmp-e-930))) (let ((syntmp-x-931 syntmp-j-928)) (let ((syntmp-e-932 (if (syntmp-syntax-object?-101 syntmp-x-931) (syntmp-syntax-object-expression-102 syntmp-x-931) syntmp-x-931))) (if (annotation? syntmp-e-932) (annotation-expression syntmp-e-932) syntmp-e-932)))) (eq? (syntmp-id-var-name-139 syntmp-i-927 (quote (()))) (syntmp-id-var-name-139 syntmp-j-928 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-933 syntmp-w-934) (letrec ((syntmp-search-vector-rib-937 (lambda (syntmp-sym-948 syntmp-subst-949 syntmp-marks-950 syntmp-symnames-951 syntmp-ribcage-952) (let ((syntmp-n-953 (vector-length syntmp-symnames-951))) (let syntmp-f-954 ((syntmp-i-955 0)) (cond ((syntmp-fx=-87 syntmp-i-955 syntmp-n-953) (syntmp-search-935 syntmp-sym-948 (cdr syntmp-subst-949) syntmp-marks-950)) ((and (eq? (vector-ref syntmp-symnames-951 syntmp-i-955) syntmp-sym-948) (syntmp-same-marks?-138 syntmp-marks-950 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-952) syntmp-i-955))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-952) syntmp-i-955) syntmp-marks-950)) (else (syntmp-f-954 (syntmp-fx+-85 syntmp-i-955 1)))))))) (syntmp-search-list-rib-936 (lambda (syntmp-sym-956 syntmp-subst-957 syntmp-marks-958 syntmp-symnames-959 syntmp-ribcage-960) (let syntmp-f-961 ((syntmp-symnames-962 syntmp-symnames-959) (syntmp-i-963 0)) (cond ((null? syntmp-symnames-962) (syntmp-search-935 syntmp-sym-956 (cdr syntmp-subst-957) syntmp-marks-958)) ((and (eq? (car syntmp-symnames-962) syntmp-sym-956) (syntmp-same-marks?-138 syntmp-marks-958 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-960) syntmp-i-963))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-960) syntmp-i-963) syntmp-marks-958)) (else (syntmp-f-961 (cdr syntmp-symnames-962) (syntmp-fx+-85 syntmp-i-963 1))))))) (syntmp-search-935 (lambda (syntmp-sym-964 syntmp-subst-965 syntmp-marks-966) (if (null? syntmp-subst-965) (values #f syntmp-marks-966) (let ((syntmp-fst-967 (car syntmp-subst-965))) (if (eq? syntmp-fst-967 (quote shift)) (syntmp-search-935 syntmp-sym-964 (cdr syntmp-subst-965) (cdr syntmp-marks-966)) (let ((syntmp-symnames-968 (syntmp-ribcage-symnames-126 syntmp-fst-967))) (if (vector? syntmp-symnames-968) (syntmp-search-vector-rib-937 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967) (syntmp-search-list-rib-936 syntmp-sym-964 syntmp-subst-965 syntmp-marks-966 syntmp-symnames-968 syntmp-fst-967))))))))) (cond ((symbol? syntmp-id-933) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-933 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-970 . syntmp-ignore-969) syntmp-x-970)) syntmp-id-933)) ((syntmp-syntax-object?-101 syntmp-id-933) (let ((syntmp-id-971 (let ((syntmp-e-973 (syntmp-syntax-object-expression-102 syntmp-id-933))) (if (annotation? syntmp-e-973) (annotation-expression syntmp-e-973) syntmp-e-973))) (syntmp-w1-972 (syntmp-syntax-object-wrap-103 syntmp-id-933))) (let ((syntmp-marks-974 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w1-972)))) (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w-934) syntmp-marks-974)) (lambda (syntmp-new-id-975 syntmp-marks-976) (or syntmp-new-id-975 (call-with-values (lambda () (syntmp-search-935 syntmp-id-971 (syntmp-wrap-subst-121 syntmp-w1-972) syntmp-marks-976)) (lambda (syntmp-x-978 . syntmp-ignore-977) syntmp-x-978)) syntmp-id-971)))))) ((annotation? syntmp-id-933) (let ((syntmp-id-979 (let ((syntmp-e-980 syntmp-id-933)) (if (annotation? syntmp-e-980) (annotation-expression syntmp-e-980) syntmp-e-980)))) (or (call-with-values (lambda () (syntmp-search-935 syntmp-id-979 (syntmp-wrap-subst-121 syntmp-w-934) (syntmp-wrap-marks-120 syntmp-w-934))) (lambda (syntmp-x-982 . syntmp-ignore-981) syntmp-x-982)) syntmp-id-979))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-933)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-983 syntmp-y-984) (or (eq? syntmp-x-983 syntmp-y-984) (and (not (null? syntmp-x-983)) (not (null? syntmp-y-984)) (eq? (car syntmp-x-983) (car syntmp-y-984)) (syntmp-same-marks?-138 (cdr syntmp-x-983) (cdr syntmp-y-984)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-985 syntmp-m2-986) (syntmp-smart-append-135 syntmp-m1-985 syntmp-m2-986))) (syntmp-join-wraps-136 (lambda (syntmp-w1-987 syntmp-w2-988) (let ((syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w1-987)) (syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w1-987))) (if (null? syntmp-m1-989) (if (null? syntmp-s1-990) syntmp-w2-988 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-988) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-989 (syntmp-wrap-marks-120 syntmp-w2-988)) (syntmp-smart-append-135 syntmp-s1-990 (syntmp-wrap-subst-121 syntmp-w2-988))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-991 syntmp-m2-992) (if (null? syntmp-m2-992) syntmp-m1-991 (append syntmp-m1-991 syntmp-m2-992)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-993 syntmp-labels-994 syntmp-w-995) (if (null? syntmp-ids-993) syntmp-w-995 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-995) (cons (let ((syntmp-labelvec-996 (list->vector syntmp-labels-994))) (let ((syntmp-n-997 (vector-length syntmp-labelvec-996))) (let ((syntmp-symnamevec-998 (make-vector syntmp-n-997)) (syntmp-marksvec-999 (make-vector syntmp-n-997))) (begin (let syntmp-f-1000 ((syntmp-ids-1001 syntmp-ids-993) (syntmp-i-1002 0)) (if (not (null? syntmp-ids-1001)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-1001) syntmp-w-995)) (lambda (syntmp-symname-1003 syntmp-marks-1004) (begin (vector-set! syntmp-symnamevec-998 syntmp-i-1002 syntmp-symname-1003) (vector-set! syntmp-marksvec-999 syntmp-i-1002 syntmp-marks-1004) (syntmp-f-1000 (cdr syntmp-ids-1001) (syntmp-fx+-85 syntmp-i-1002 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-998 syntmp-marksvec-999 syntmp-labelvec-996))))) (syntmp-wrap-subst-121 syntmp-w-995)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-1005 syntmp-id-1006 syntmp-label-1007) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-1005 (cons (let ((syntmp-e-1008 (syntmp-syntax-object-expression-102 syntmp-id-1006))) (if (annotation? syntmp-e-1008) (annotation-expression syntmp-e-1008) syntmp-e-1008)) (syntmp-ribcage-symnames-126 syntmp-ribcage-1005))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-1005 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-1006)) (syntmp-ribcage-marks-127 syntmp-ribcage-1005))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-1005 (cons syntmp-label-1007 (syntmp-ribcage-labels-128 syntmp-ribcage-1005)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1009) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1009)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1009))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1010 syntmp-update-1011) (vector-set! syntmp-x-1010 3 syntmp-update-1011))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1012 syntmp-update-1013) (vector-set! syntmp-x-1012 2 syntmp-update-1013))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1014 syntmp-update-1015) (vector-set! syntmp-x-1014 1 syntmp-update-1015))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1016) (vector-ref syntmp-x-1016 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1017) (vector-ref syntmp-x-1017 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1018) (vector-ref syntmp-x-1018 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1019) (and (vector? syntmp-x-1019) (= (vector-length syntmp-x-1019) 4) (eq? (vector-ref syntmp-x-1019 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022) (vector (quote ribcage) syntmp-symnames-1020 syntmp-marks-1021 syntmp-labels-1022))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1023) (if (null? syntmp-ls-1023) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1023)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1024 syntmp-w-1025) (if (syntmp-syntax-object?-101 syntmp-x-1024) (values (let ((syntmp-e-1026 (syntmp-syntax-object-expression-102 syntmp-x-1024))) (if (annotation? syntmp-e-1026) (annotation-expression syntmp-e-1026) syntmp-e-1026)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1025) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1024)))) (values (let ((syntmp-e-1027 syntmp-x-1024)) (if (annotation? syntmp-e-1027) (annotation-expression syntmp-e-1027) syntmp-e-1027)) (syntmp-wrap-marks-120 syntmp-w-1025))))) (syntmp-id?-117 (lambda (syntmp-x-1028) (cond ((symbol? syntmp-x-1028) #t) ((syntmp-syntax-object?-101 syntmp-x-1028) (symbol? (let ((syntmp-e-1029 (syntmp-syntax-object-expression-102 syntmp-x-1028))) (if (annotation? syntmp-e-1029) (annotation-expression syntmp-e-1029) syntmp-e-1029)))) ((annotation? syntmp-x-1028) (symbol? (annotation-expression syntmp-x-1028))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1030) (and (syntmp-syntax-object?-101 syntmp-x-1030) (symbol? (let ((syntmp-e-1031 (syntmp-syntax-object-expression-102 syntmp-x-1030))) (if (annotation? syntmp-e-1031) (annotation-expression syntmp-e-1031) syntmp-e-1031)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1032 syntmp-sym-1033 syntmp-val-1034) (syntmp-put-global-definition-hook-92 syntmp-sym-1033 (cons syntmp-type-1032 syntmp-val-1034) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1035 syntmp-r-1036 syntmp-mod-1037) (cond ((assq syntmp-x-1035 syntmp-r-1036) => cdr) ((symbol? syntmp-x-1035) (or (syntmp-get-global-definition-hook-93 syntmp-x-1035 syntmp-mod-1037) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1038) (if (null? syntmp-r-1038) (quote ()) (let ((syntmp-a-1039 (car syntmp-r-1038))) (if (eq? (cadr syntmp-a-1039) (quote macro)) (cons syntmp-a-1039 (syntmp-macros-only-env-113 (cdr syntmp-r-1038))) (syntmp-macros-only-env-113 (cdr syntmp-r-1038))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1040 syntmp-vars-1041 syntmp-r-1042) (if (null? syntmp-labels-1040) syntmp-r-1042 (syntmp-extend-var-env-112 (cdr syntmp-labels-1040) (cdr syntmp-vars-1041) (cons (cons (car syntmp-labels-1040) (cons (quote lexical) (car syntmp-vars-1041))) syntmp-r-1042))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1043 syntmp-bindings-1044 syntmp-r-1045) (if (null? syntmp-labels-1043) syntmp-r-1045 (syntmp-extend-env-111 (cdr syntmp-labels-1043) (cdr syntmp-bindings-1044) (cons (cons (car syntmp-labels-1043) (car syntmp-bindings-1044)) syntmp-r-1045))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1046) (cond ((annotation? syntmp-x-1046) (annotation-source syntmp-x-1046)) ((syntmp-syntax-object?-101 syntmp-x-1046) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1046))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1047 syntmp-update-1048) (vector-set! syntmp-x-1047 3 syntmp-update-1048))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1049 syntmp-update-1050) (vector-set! syntmp-x-1049 2 syntmp-update-1050))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1051 syntmp-update-1052) (vector-set! syntmp-x-1051 1 syntmp-update-1052))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1053) (vector-ref syntmp-x-1053 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1054) (vector-ref syntmp-x-1054 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1055) (vector-ref syntmp-x-1055 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1056) (and (vector? syntmp-x-1056) (= (vector-length syntmp-x-1056) 4) (eq? (vector-ref syntmp-x-1056 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059) (vector (quote syntax-object) syntmp-expression-1057 syntmp-wrap-1058 syntmp-module-1059))) (syntmp-build-letrec-99 (lambda (syntmp-src-1060 syntmp-vars-1061 syntmp-val-exps-1062 syntmp-body-exp-1063) (if (null? syntmp-vars-1061) (syntmp-build-annotated-94 syntmp-src-1060 syntmp-body-exp-1063) (syntmp-build-annotated-94 syntmp-src-1060 (list (quote letrec) (map list syntmp-vars-1061 syntmp-val-exps-1062) syntmp-body-exp-1063))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1064 syntmp-vars-1065 syntmp-val-exps-1066 syntmp-body-exp-1067) (if (null? syntmp-vars-1065) (syntmp-build-annotated-94 syntmp-src-1064 syntmp-body-exp-1067) (syntmp-build-annotated-94 syntmp-src-1064 (list (quote let) (car syntmp-vars-1065) (map list (cdr syntmp-vars-1065) syntmp-val-exps-1066) syntmp-body-exp-1067))))) (syntmp-build-let-97 (lambda (syntmp-src-1068 syntmp-vars-1069 syntmp-val-exps-1070 syntmp-body-exp-1071) (if (null? syntmp-vars-1069) (syntmp-build-annotated-94 syntmp-src-1068 syntmp-body-exp-1071) (syntmp-build-annotated-94 syntmp-src-1068 (list (quote let) (map list syntmp-vars-1069 syntmp-val-exps-1070) syntmp-body-exp-1071))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1072 syntmp-exps-1073) (if (null? (cdr syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (car syntmp-exps-1073)) (syntmp-build-annotated-94 syntmp-src-1072 (cons (quote begin) syntmp-exps-1073))))) (syntmp-build-data-95 (lambda (syntmp-src-1074 syntmp-exp-1075) (if (and (self-evaluating? syntmp-exp-1075) (not (vector? syntmp-exp-1075))) (syntmp-build-annotated-94 syntmp-src-1074 syntmp-exp-1075) (syntmp-build-annotated-94 syntmp-src-1074 (list (quote quote) syntmp-exp-1075))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1076 syntmp-exp-1077) (if (and syntmp-src-1076 (not (annotation? syntmp-exp-1077))) (make-annotation syntmp-exp-1077 syntmp-src-1076 #t) syntmp-exp-1077))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1078 syntmp-module-1079) (let ((syntmp-module-1080 (if syntmp-module-1079 (resolve-module syntmp-module-1079) (warn "wha" syntmp-symbol-1078 (current-module))))) (let ((syntmp-v-1081 (module-variable syntmp-module-1080 syntmp-symbol-1078))) (and syntmp-v-1081 (or (object-property syntmp-v-1081 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1081) (macro? (variable-ref syntmp-v-1081)) (macro-transformer (variable-ref syntmp-v-1081)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1082 syntmp-binding-1083 syntmp-modname-1084) (let ((syntmp-module-1085 (if syntmp-modname-1084 (resolve-module syntmp-modname-1084) (current-module)))) (let ((syntmp-v-1086 (or (module-variable syntmp-module-1085 syntmp-symbol-1082) (let ((syntmp-v-1087 (make-variable (quote sc-macro)))) (begin (module-add! syntmp-module-1085 syntmp-symbol-1082 syntmp-v-1087) syntmp-v-1087))))) (begin (if (not (variable-bound? syntmp-v-1086)) (variable-set! syntmp-v-1086 (gensym))) (set-object-property! syntmp-v-1086 (quote *sc-expander*) syntmp-binding-1083)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1088 syntmp-why-1089 syntmp-what-1090) (error syntmp-who-1088 "~a ~s" syntmp-why-1089 syntmp-what-1090))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1091 syntmp-mod-1092) (eval (list syntmp-noexpand-84 syntmp-x-1091) (if syntmp-mod-1092 (resolve-module syntmp-mod-1092) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1093 syntmp-mod-1094) (eval (list syntmp-noexpand-84 syntmp-x-1093) (if syntmp-mod-1094 (resolve-module syntmp-mod-1094) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1095 syntmp-r-1096 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) ((lambda (syntmp-tmp-1100) ((lambda (syntmp-tmp-1101) (if (if syntmp-tmp-1101 (apply (lambda (syntmp-_-1102 syntmp-var-1103 syntmp-val-1104 syntmp-e1-1105 syntmp-e2-1106) (syntmp-valid-bound-ids?-142 syntmp-var-1103)) syntmp-tmp-1101) #f) (apply (lambda (syntmp-_-1108 syntmp-var-1109 syntmp-val-1110 syntmp-e1-1111 syntmp-e2-1112) (let ((syntmp-names-1113 (map (lambda (syntmp-x-1114) (syntmp-id-var-name-139 syntmp-x-1114 syntmp-w-1097)) syntmp-var-1109))) (begin (for-each (lambda (syntmp-id-1116 syntmp-n-1117) (let ((syntmp-t-1118 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1117 syntmp-r-1096 syntmp-mod-1099)))) (if (memv syntmp-t-1118 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1116 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) "identifier out of context")))) syntmp-var-1109 syntmp-names-1113) (syntmp-chi-body-157 (cons syntmp-e1-1111 syntmp-e2-1112) (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099) (syntmp-extend-env-111 syntmp-names-1113 (let ((syntmp-trans-r-1121 (syntmp-macros-only-env-113 syntmp-r-1096))) (map (lambda (syntmp-x-1122) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1122 syntmp-trans-r-1121 syntmp-w-1097 syntmp-mod-1099) syntmp-mod-1099))) syntmp-val-1110)) syntmp-r-1096) syntmp-w-1097 syntmp-mod-1099)))) syntmp-tmp-1101) ((lambda (syntmp-_-1124) (syntax-error (syntmp-source-wrap-146 syntmp-e-1095 syntmp-w-1097 syntmp-s-1098 syntmp-mod-1099))) syntmp-tmp-1100))) (syntax-dispatch syntmp-tmp-1100 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1095))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1125 syntmp-r-1126 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129) ((lambda (syntmp-tmp-1130) ((lambda (syntmp-tmp-1131) (if syntmp-tmp-1131 (apply (lambda (syntmp-_-1132 syntmp-e-1133) (syntmp-build-data-95 syntmp-s-1128 (syntmp-strip-164 syntmp-e-1133 syntmp-w-1127))) syntmp-tmp-1131) ((lambda (syntmp-_-1134) (syntax-error (syntmp-source-wrap-146 syntmp-e-1125 syntmp-w-1127 syntmp-s-1128 syntmp-mod-1129))) syntmp-tmp-1130))) (syntax-dispatch syntmp-tmp-1130 (quote (any any))))) syntmp-e-1125))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1142 (lambda (syntmp-x-1143) (let ((syntmp-t-1144 (car syntmp-x-1143))) (if (memv syntmp-t-1144 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1143)) (if (memv syntmp-t-1144 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1143) (syntmp-regen-1142 (caddr syntmp-x-1143)))) (if (memv syntmp-t-1144 (quote (map))) (let ((syntmp-ls-1145 (map syntmp-regen-1142 (cdr syntmp-x-1143)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1145) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1145))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1143)) (map syntmp-regen-1142 (cdr syntmp-x-1143)))))))))))) (syntmp-gen-vector-1141 (lambda (syntmp-x-1146) (cond ((eq? (car syntmp-x-1146) (quote list)) (cons (quote vector) (cdr syntmp-x-1146))) ((eq? (car syntmp-x-1146) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1146)))) (else (list (quote list->vector) syntmp-x-1146))))) (syntmp-gen-append-1140 (lambda (syntmp-x-1147 syntmp-y-1148) (if (equal? syntmp-y-1148 (quote (quote ()))) syntmp-x-1147 (list (quote append) syntmp-x-1147 syntmp-y-1148)))) (syntmp-gen-cons-1139 (lambda (syntmp-x-1149 syntmp-y-1150) (let ((syntmp-t-1151 (car syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (quote))) (if (eq? (car syntmp-x-1149) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1149) (cadr syntmp-y-1150))) (if (eq? (cadr syntmp-y-1150) (quote ())) (list (quote list) syntmp-x-1149) (list (quote cons) syntmp-x-1149 syntmp-y-1150))) (if (memv syntmp-t-1151 (quote (list))) (cons (quote list) (cons syntmp-x-1149 (cdr syntmp-y-1150))) (list (quote cons) syntmp-x-1149 syntmp-y-1150)))))) (syntmp-gen-map-1138 (lambda (syntmp-e-1152 syntmp-map-env-1153) (let ((syntmp-formals-1154 (map cdr syntmp-map-env-1153)) (syntmp-actuals-1155 (map (lambda (syntmp-x-1156) (list (quote ref) (car syntmp-x-1156))) syntmp-map-env-1153))) (cond ((eq? (car syntmp-e-1152) (quote ref)) (car syntmp-actuals-1155)) ((andmap (lambda (syntmp-x-1157) (and (eq? (car syntmp-x-1157) (quote ref)) (memq (cadr syntmp-x-1157) syntmp-formals-1154))) (cdr syntmp-e-1152)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1152)) (map (let ((syntmp-r-1158 (map cons syntmp-formals-1154 syntmp-actuals-1155))) (lambda (syntmp-x-1159) (cdr (assq (cadr syntmp-x-1159) syntmp-r-1158)))) (cdr syntmp-e-1152))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1154 syntmp-e-1152) syntmp-actuals-1155))))))) (syntmp-gen-mappend-1137 (lambda (syntmp-e-1160 syntmp-map-env-1161) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1138 syntmp-e-1160 syntmp-map-env-1161)))) (syntmp-gen-ref-1136 (lambda (syntmp-src-1162 syntmp-var-1163 syntmp-level-1164 syntmp-maps-1165) (if (syntmp-fx=-87 syntmp-level-1164 0) (values syntmp-var-1163 syntmp-maps-1165) (if (null? syntmp-maps-1165) (syntax-error syntmp-src-1162 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1136 syntmp-src-1162 syntmp-var-1163 (syntmp-fx--86 syntmp-level-1164 1) (cdr syntmp-maps-1165))) (lambda (syntmp-outer-var-1166 syntmp-outer-maps-1167) (let ((syntmp-b-1168 (assq syntmp-outer-var-1166 (car syntmp-maps-1165)))) (if syntmp-b-1168 (values (cdr syntmp-b-1168) syntmp-maps-1165) (let ((syntmp-inner-var-1169 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1169 (cons (cons (cons syntmp-outer-var-1166 syntmp-inner-var-1169) (car syntmp-maps-1165)) syntmp-outer-maps-1167))))))))))) (syntmp-gen-syntax-1135 (lambda (syntmp-src-1170 syntmp-e-1171 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175) (if (syntmp-id?-117 syntmp-e-1171) (let ((syntmp-label-1176 (syntmp-id-var-name-139 syntmp-e-1171 (quote (()))))) (let ((syntmp-b-1177 (syntmp-lookup-114 syntmp-label-1176 syntmp-r-1172 syntmp-mod-1175))) (if (eq? (syntmp-binding-type-109 syntmp-b-1177) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1178 (syntmp-binding-value-110 syntmp-b-1177))) (syntmp-gen-ref-1136 syntmp-src-1170 (car syntmp-var.lev-1178) (cdr syntmp-var.lev-1178) syntmp-maps-1173))) (lambda (syntmp-var-1179 syntmp-maps-1180) (values (list (quote ref) syntmp-var-1179) syntmp-maps-1180))) (if (syntmp-ellipsis?-1174 syntmp-e-1171) (syntax-error syntmp-src-1170 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173))))) ((lambda (syntmp-tmp-1181) ((lambda (syntmp-tmp-1182) (if (if syntmp-tmp-1182 (apply (lambda (syntmp-dots-1183 syntmp-e-1184) (syntmp-ellipsis?-1174 syntmp-dots-1183)) syntmp-tmp-1182) #f) (apply (lambda (syntmp-dots-1185 syntmp-e-1186) (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-e-1186 syntmp-r-1172 syntmp-maps-1173 (lambda (syntmp-x-1187) #f) syntmp-mod-1175)) syntmp-tmp-1182) ((lambda (syntmp-tmp-1188) (if (if syntmp-tmp-1188 (apply (lambda (syntmp-x-1189 syntmp-dots-1190 syntmp-y-1191) (syntmp-ellipsis?-1174 syntmp-dots-1190)) syntmp-tmp-1188) #f) (apply (lambda (syntmp-x-1192 syntmp-dots-1193 syntmp-y-1194) (let syntmp-f-1195 ((syntmp-y-1196 syntmp-y-1194) (syntmp-k-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1192 syntmp-r-1172 (cons (quote ()) syntmp-maps-1198) syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-map-1138 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) ((lambda (syntmp-tmp-1201) ((lambda (syntmp-tmp-1202) (if (if syntmp-tmp-1202 (apply (lambda (syntmp-dots-1203 syntmp-y-1204) (syntmp-ellipsis?-1174 syntmp-dots-1203)) syntmp-tmp-1202) #f) (apply (lambda (syntmp-dots-1205 syntmp-y-1206) (syntmp-f-1195 syntmp-y-1206 (lambda (syntmp-maps-1207) (call-with-values (lambda () (syntmp-k-1197 (cons (quote ()) syntmp-maps-1207))) (lambda (syntmp-x-1208 syntmp-maps-1209) (if (null? (car syntmp-maps-1209)) (syntax-error syntmp-src-1170 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1137 syntmp-x-1208 (car syntmp-maps-1209)) (cdr syntmp-maps-1209)))))))) syntmp-tmp-1202) ((lambda (syntmp-_-1210) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1196 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1211 syntmp-maps-1212) (call-with-values (lambda () (syntmp-k-1197 syntmp-maps-1212)) (lambda (syntmp-x-1213 syntmp-maps-1214) (values (syntmp-gen-append-1140 syntmp-x-1213 syntmp-y-1211) syntmp-maps-1214)))))) syntmp-tmp-1201))) (syntax-dispatch syntmp-tmp-1201 (quote (any . any))))) syntmp-y-1196))) syntmp-tmp-1188) ((lambda (syntmp-tmp-1215) (if syntmp-tmp-1215 (apply (lambda (syntmp-x-1216 syntmp-y-1217) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-x-1216 syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-x-1218 syntmp-maps-1219) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 syntmp-y-1217 syntmp-r-1172 syntmp-maps-1219 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-y-1220 syntmp-maps-1221) (values (syntmp-gen-cons-1139 syntmp-x-1218 syntmp-y-1220) syntmp-maps-1221)))))) syntmp-tmp-1215) ((lambda (syntmp-tmp-1222) (if syntmp-tmp-1222 (apply (lambda (syntmp-e1-1223 syntmp-e2-1224) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-src-1170 (cons syntmp-e1-1223 syntmp-e2-1224) syntmp-r-1172 syntmp-maps-1173 syntmp-ellipsis?-1174 syntmp-mod-1175)) (lambda (syntmp-e-1226 syntmp-maps-1227) (values (syntmp-gen-vector-1141 syntmp-e-1226) syntmp-maps-1227)))) syntmp-tmp-1222) ((lambda (syntmp-_-1228) (values (list (quote quote) syntmp-e-1171) syntmp-maps-1173)) syntmp-tmp-1181))) (syntax-dispatch syntmp-tmp-1181 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1181 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1181 (quote (any any))))) syntmp-e-1171))))) (lambda (syntmp-e-1229 syntmp-r-1230 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233) (let ((syntmp-e-1234 (syntmp-source-wrap-146 syntmp-e-1229 syntmp-w-1231 syntmp-s-1232 syntmp-mod-1233))) ((lambda (syntmp-tmp-1235) ((lambda (syntmp-tmp-1236) (if syntmp-tmp-1236 (apply (lambda (syntmp-_-1237 syntmp-x-1238) (call-with-values (lambda () (syntmp-gen-syntax-1135 syntmp-e-1234 syntmp-x-1238 syntmp-r-1230 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1233)) (lambda (syntmp-e-1239 syntmp-maps-1240) (syntmp-regen-1142 syntmp-e-1239)))) syntmp-tmp-1236) ((lambda (syntmp-_-1241) (syntax-error syntmp-e-1234)) syntmp-tmp-1235))) (syntax-dispatch syntmp-tmp-1235 (quote (any any))))) syntmp-e-1234))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1242 syntmp-r-1243 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-c-1250) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1242 syntmp-w-1244 syntmp-s-1245 syntmp-mod-1246) syntmp-c-1250 syntmp-r-1243 syntmp-w-1244 syntmp-mod-1246 (lambda (syntmp-vars-1251 syntmp-body-1252) (syntmp-build-annotated-94 syntmp-s-1245 (list (quote lambda) syntmp-vars-1251 syntmp-body-1252))))) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any . any))))) syntmp-e-1242))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1253 (lambda (syntmp-e-1254 syntmp-r-1255 syntmp-w-1256 syntmp-s-1257 syntmp-mod-1258 syntmp-constructor-1259 syntmp-ids-1260 syntmp-vals-1261 syntmp-exps-1262) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1260)) (syntax-error syntmp-e-1254 "duplicate bound variable in") (let ((syntmp-labels-1263 (syntmp-gen-labels-123 syntmp-ids-1260)) (syntmp-new-vars-1264 (map syntmp-gen-var-165 syntmp-ids-1260))) (let ((syntmp-nw-1265 (syntmp-make-binding-wrap-134 syntmp-ids-1260 syntmp-labels-1263 syntmp-w-1256)) (syntmp-nr-1266 (syntmp-extend-var-env-112 syntmp-labels-1263 syntmp-new-vars-1264 syntmp-r-1255))) (syntmp-constructor-1259 syntmp-s-1257 syntmp-new-vars-1264 (map (lambda (syntmp-x-1267) (syntmp-chi-153 syntmp-x-1267 syntmp-r-1255 syntmp-w-1256 syntmp-mod-1258)) syntmp-vals-1261) (syntmp-chi-body-157 syntmp-exps-1262 (syntmp-source-wrap-146 syntmp-e-1254 syntmp-nw-1265 syntmp-s-1257 syntmp-mod-1258) syntmp-nr-1266 syntmp-nw-1265 syntmp-mod-1258)))))))) (lambda (syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272) ((lambda (syntmp-tmp-1273) ((lambda (syntmp-tmp-1274) (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-id-1276 syntmp-val-1277 syntmp-e1-1278 syntmp-e2-1279) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-let-97 syntmp-id-1276 syntmp-val-1277 (cons syntmp-e1-1278 syntmp-e2-1279))) syntmp-tmp-1274) ((lambda (syntmp-tmp-1283) (if (if syntmp-tmp-1283 (apply (lambda (syntmp-_-1284 syntmp-f-1285 syntmp-id-1286 syntmp-val-1287 syntmp-e1-1288 syntmp-e2-1289) (syntmp-id?-117 syntmp-f-1285)) syntmp-tmp-1283) #f) (apply (lambda (syntmp-_-1290 syntmp-f-1291 syntmp-id-1292 syntmp-val-1293 syntmp-e1-1294 syntmp-e2-1295) (syntmp-chi-let-1253 syntmp-e-1268 syntmp-r-1269 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272 syntmp-build-named-let-98 (cons syntmp-f-1291 syntmp-id-1292) syntmp-val-1293 (cons syntmp-e1-1294 syntmp-e2-1295))) syntmp-tmp-1283) ((lambda (syntmp-_-1299) (syntax-error (syntmp-source-wrap-146 syntmp-e-1268 syntmp-w-1270 syntmp-s-1271 syntmp-mod-1272))) syntmp-tmp-1273))) (syntax-dispatch syntmp-tmp-1273 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1273 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1268)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1300 syntmp-r-1301 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304) ((lambda (syntmp-tmp-1305) ((lambda (syntmp-tmp-1306) (if syntmp-tmp-1306 (apply (lambda (syntmp-_-1307 syntmp-id-1308 syntmp-val-1309 syntmp-e1-1310 syntmp-e2-1311) (let ((syntmp-ids-1312 syntmp-id-1308)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1312)) (syntax-error syntmp-e-1300 "duplicate bound variable in") (let ((syntmp-labels-1314 (syntmp-gen-labels-123 syntmp-ids-1312)) (syntmp-new-vars-1315 (map syntmp-gen-var-165 syntmp-ids-1312))) (let ((syntmp-w-1316 (syntmp-make-binding-wrap-134 syntmp-ids-1312 syntmp-labels-1314 syntmp-w-1302)) (syntmp-r-1317 (syntmp-extend-var-env-112 syntmp-labels-1314 syntmp-new-vars-1315 syntmp-r-1301))) (syntmp-build-letrec-99 syntmp-s-1303 syntmp-new-vars-1315 (map (lambda (syntmp-x-1318) (syntmp-chi-153 syntmp-x-1318 syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304)) syntmp-val-1309) (syntmp-chi-body-157 (cons syntmp-e1-1310 syntmp-e2-1311) (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1316 syntmp-s-1303 syntmp-mod-1304) syntmp-r-1317 syntmp-w-1316 syntmp-mod-1304))))))) syntmp-tmp-1306) ((lambda (syntmp-_-1321) (syntax-error (syntmp-source-wrap-146 syntmp-e-1300 syntmp-w-1302 syntmp-s-1303 syntmp-mod-1304))) syntmp-tmp-1305))) (syntax-dispatch syntmp-tmp-1305 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1300))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1322 syntmp-r-1323 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326) ((lambda (syntmp-tmp-1327) ((lambda (syntmp-tmp-1328) (if (if syntmp-tmp-1328 (apply (lambda (syntmp-_-1329 syntmp-id-1330 syntmp-val-1331) (syntmp-id?-117 syntmp-id-1330)) syntmp-tmp-1328) #f) (apply (lambda (syntmp-_-1332 syntmp-id-1333 syntmp-val-1334) (let ((syntmp-val-1335 (syntmp-chi-153 syntmp-val-1334 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (syntmp-n-1336 (syntmp-id-var-name-139 syntmp-id-1333 syntmp-w-1324))) (let ((syntmp-b-1337 (syntmp-lookup-114 syntmp-n-1336 syntmp-r-1323 syntmp-mod-1326))) (let ((syntmp-t-1338 (syntmp-binding-type-109 syntmp-b-1337))) (if (memv syntmp-t-1338 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1337) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1326 syntmp-n-1336 #f) syntmp-val-1335)) (if (memv syntmp-t-1338 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1333 syntmp-w-1324 syntmp-mod-1326) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))))))))) syntmp-tmp-1328) ((lambda (syntmp-tmp-1339) (if syntmp-tmp-1339 (apply (lambda (syntmp-_-1340 syntmp-head-1341 syntmp-tail-1342 syntmp-val-1343) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-head-1341 syntmp-r-1323 (quote (())) #f #f syntmp-mod-1326)) (lambda (syntmp-type-1344 syntmp-value-1345 syntmp-ee-1346 syntmp-ww-1347 syntmp-ss-1348 syntmp-modmod-1349) (let ((syntmp-t-1350 syntmp-type-1344)) (if (memv syntmp-t-1350 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1345 (cons syntmp-head-1341 syntmp-tail-1342))) (lambda (syntmp-id-1352 syntmp-mod-1353) (syntmp-build-annotated-94 syntmp-s-1325 (list (quote set!) (make-module-ref syntmp-mod-1353 syntmp-id-1352 #f) syntmp-val-1343)))) (syntmp-build-annotated-94 syntmp-s-1325 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) syntmp-head-1341) syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326) (map (lambda (syntmp-e-1354) (syntmp-chi-153 syntmp-e-1354 syntmp-r-1323 syntmp-w-1324 syntmp-mod-1326)) (append syntmp-tail-1342 (list syntmp-val-1343)))))))))) syntmp-tmp-1339) ((lambda (syntmp-_-1356) (syntax-error (syntmp-source-wrap-146 syntmp-e-1322 syntmp-w-1324 syntmp-s-1325 syntmp-mod-1326))) syntmp-tmp-1327))) (syntax-dispatch syntmp-tmp-1327 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1327 (quote (any any any))))) syntmp-e-1322))) (syntmp-global-extend-115 (quote module-ref) (quote @) (lambda (syntmp-e-1357) ((lambda (syntmp-tmp-1358) ((lambda (syntmp-tmp-1359) (if (if syntmp-tmp-1359 (apply (lambda (syntmp-_-1360 syntmp-mod-1361 syntmp-id-1362) (and (andmap syntmp-id?-117 syntmp-mod-1361) (syntmp-id?-117 syntmp-id-1362))) syntmp-tmp-1359) #f) (apply (lambda (syntmp-_-1364 syntmp-mod-1365 syntmp-id-1366) (values (syntax-object->datum syntmp-id-1366) (syntax-object->datum (append syntmp-mod-1365 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) syntmp-tmp-1359) (syntax-error syntmp-tmp-1358))) (syntax-dispatch syntmp-tmp-1358 (quote (any each-any any))))) syntmp-e-1357))) (syntmp-global-extend-115 (quote module-ref) (quote @@) (lambda (syntmp-e-1368) ((lambda (syntmp-tmp-1369) ((lambda (syntmp-tmp-1370) (if (if syntmp-tmp-1370 (apply (lambda (syntmp-_-1371 syntmp-mod-1372 syntmp-id-1373) (and (andmap syntmp-id?-117 syntmp-mod-1372) (syntmp-id?-117 syntmp-id-1373))) syntmp-tmp-1370) #f) (apply (lambda (syntmp-_-1375 syntmp-mod-1376 syntmp-id-1377) (values (syntax-object->datum syntmp-id-1377) (syntax-object->datum syntmp-mod-1376))) syntmp-tmp-1370) (syntax-error syntmp-tmp-1369))) (syntax-dispatch syntmp-tmp-1369 (quote (any each-any any))))) syntmp-e-1368))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1382 (lambda (syntmp-x-1383 syntmp-keys-1384 syntmp-clauses-1385 syntmp-r-1386 syntmp-mod-1387) (if (null? syntmp-clauses-1385) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1383)) ((lambda (syntmp-tmp-1388) ((lambda (syntmp-tmp-1389) (if syntmp-tmp-1389 (apply (lambda (syntmp-pat-1390 syntmp-exp-1391) (if (and (syntmp-id?-117 syntmp-pat-1390) (andmap (lambda (syntmp-x-1392) (not (syntmp-free-id=?-140 syntmp-pat-1390 syntmp-x-1392))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) syntmp-keys-1384))) (let ((syntmp-labels-1393 (list (syntmp-gen-label-122))) (syntmp-var-1394 (syntmp-gen-var-165 syntmp-pat-1390))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1394) (syntmp-chi-153 syntmp-exp-1391 (syntmp-extend-env-111 syntmp-labels-1393 (list (cons (quote syntax) (cons syntmp-var-1394 0))) syntmp-r-1386) (syntmp-make-binding-wrap-134 (list syntmp-pat-1390) syntmp-labels-1393 (quote (()))) syntmp-mod-1387))) syntmp-x-1383))) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1390 #t syntmp-exp-1391 syntmp-mod-1387))) syntmp-tmp-1389) ((lambda (syntmp-tmp-1395) (if syntmp-tmp-1395 (apply (lambda (syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398) (syntmp-gen-clause-1381 syntmp-x-1383 syntmp-keys-1384 (cdr syntmp-clauses-1385) syntmp-r-1386 syntmp-pat-1396 syntmp-fender-1397 syntmp-exp-1398 syntmp-mod-1387)) syntmp-tmp-1395) ((lambda (syntmp-_-1399) (syntax-error (car syntmp-clauses-1385) "invalid syntax-case clause")) syntmp-tmp-1388))) (syntax-dispatch syntmp-tmp-1388 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1388 (quote (any any))))) (car syntmp-clauses-1385))))) (syntmp-gen-clause-1381 (lambda (syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-pat-1404 syntmp-fender-1405 syntmp-exp-1406 syntmp-mod-1407) (call-with-values (lambda () (syntmp-convert-pattern-1379 syntmp-pat-1404 syntmp-keys-1401)) (lambda (syntmp-p-1408 syntmp-pvars-1409) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1409))) (syntax-error syntmp-pat-1404 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1410) (not (syntmp-ellipsis?-162 (car syntmp-x-1410)))) syntmp-pvars-1409)) (syntax-error syntmp-pat-1404 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1411 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1411) (let ((syntmp-y-1412 (syntmp-build-annotated-94 #f syntmp-y-1411))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1413) ((lambda (syntmp-tmp-1414) (if syntmp-tmp-1414 (apply (lambda () syntmp-y-1412) syntmp-tmp-1414) ((lambda (syntmp-_-1415) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1412 (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-fender-1405 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1413))) (syntax-dispatch syntmp-tmp-1413 (quote #(atom #t))))) syntmp-fender-1405) (syntmp-build-dispatch-call-1380 syntmp-pvars-1409 syntmp-exp-1406 syntmp-y-1412 syntmp-r-1403 syntmp-mod-1407) (syntmp-gen-syntax-case-1382 syntmp-x-1400 syntmp-keys-1401 syntmp-clauses-1402 syntmp-r-1403 syntmp-mod-1407)))))) (if (eq? syntmp-p-1408 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1400)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1400 (syntmp-build-data-95 #f syntmp-p-1408))))))))))))) (syntmp-build-dispatch-call-1380 (lambda (syntmp-pvars-1416 syntmp-exp-1417 syntmp-y-1418 syntmp-r-1419 syntmp-mod-1420) (let ((syntmp-ids-1421 (map car syntmp-pvars-1416)) (syntmp-levels-1422 (map cdr syntmp-pvars-1416))) (let ((syntmp-labels-1423 (syntmp-gen-labels-123 syntmp-ids-1421)) (syntmp-new-vars-1424 (map syntmp-gen-var-165 syntmp-ids-1421))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1424 (syntmp-chi-153 syntmp-exp-1417 (syntmp-extend-env-111 syntmp-labels-1423 (map (lambda (syntmp-var-1425 syntmp-level-1426) (cons (quote syntax) (cons syntmp-var-1425 syntmp-level-1426))) syntmp-new-vars-1424 (map cdr syntmp-pvars-1416)) syntmp-r-1419) (syntmp-make-binding-wrap-134 syntmp-ids-1421 syntmp-labels-1423 (quote (()))) syntmp-mod-1420))) syntmp-y-1418)))))) (syntmp-convert-pattern-1379 (lambda (syntmp-pattern-1427 syntmp-keys-1428) (let syntmp-cvt-1429 ((syntmp-p-1430 syntmp-pattern-1427) (syntmp-n-1431 0) (syntmp-ids-1432 (quote ()))) (if (syntmp-id?-117 syntmp-p-1430) (if (syntmp-bound-id-member?-144 syntmp-p-1430 syntmp-keys-1428) (values (vector (quote free-id) syntmp-p-1430) syntmp-ids-1432) (values (quote any) (cons (cons syntmp-p-1430 syntmp-n-1431) syntmp-ids-1432))) ((lambda (syntmp-tmp-1433) ((lambda (syntmp-tmp-1434) (if (if syntmp-tmp-1434 (apply (lambda (syntmp-x-1435 syntmp-dots-1436) (syntmp-ellipsis?-162 syntmp-dots-1436)) syntmp-tmp-1434) #f) (apply (lambda (syntmp-x-1437 syntmp-dots-1438) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1437 (syntmp-fx+-85 syntmp-n-1431 1) syntmp-ids-1432)) (lambda (syntmp-p-1439 syntmp-ids-1440) (values (if (eq? syntmp-p-1439 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1439)) syntmp-ids-1440)))) syntmp-tmp-1434) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-x-1442 syntmp-y-1443) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-y-1443 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-y-1444 syntmp-ids-1445) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1442 syntmp-n-1431 syntmp-ids-1445)) (lambda (syntmp-x-1446 syntmp-ids-1447) (values (cons syntmp-x-1446 syntmp-y-1444) syntmp-ids-1447)))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda () (values (quote ()) syntmp-ids-1432)) syntmp-tmp-1448) ((lambda (syntmp-tmp-1449) (if syntmp-tmp-1449 (apply (lambda (syntmp-x-1450) (call-with-values (lambda () (syntmp-cvt-1429 syntmp-x-1450 syntmp-n-1431 syntmp-ids-1432)) (lambda (syntmp-p-1452 syntmp-ids-1453) (values (vector (quote vector) syntmp-p-1452) syntmp-ids-1453)))) syntmp-tmp-1449) ((lambda (syntmp-x-1454) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1430 (quote (())))) syntmp-ids-1432)) syntmp-tmp-1433))) (syntax-dispatch syntmp-tmp-1433 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1433 (quote ()))))) (syntax-dispatch syntmp-tmp-1433 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1433 (quote (any any))))) syntmp-p-1430)))))) (lambda (syntmp-e-1455 syntmp-r-1456 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459) (let ((syntmp-e-1460 (syntmp-source-wrap-146 syntmp-e-1455 syntmp-w-1457 syntmp-s-1458 syntmp-mod-1459))) ((lambda (syntmp-tmp-1461) ((lambda (syntmp-tmp-1462) (if syntmp-tmp-1462 (apply (lambda (syntmp-_-1463 syntmp-val-1464 syntmp-key-1465 syntmp-m-1466) (if (andmap (lambda (syntmp-x-1467) (and (syntmp-id?-117 syntmp-x-1467) (not (syntmp-ellipsis?-162 syntmp-x-1467)))) syntmp-key-1465) (let ((syntmp-x-1469 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1458 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1469) (syntmp-gen-syntax-case-1382 (syntmp-build-annotated-94 #f syntmp-x-1469) syntmp-key-1465 syntmp-m-1466 syntmp-r-1456 syntmp-mod-1459))) (syntmp-chi-153 syntmp-val-1464 syntmp-r-1456 (quote (())) syntmp-mod-1459)))) (syntax-error syntmp-e-1460 "invalid literals list in"))) syntmp-tmp-1462) (syntax-error syntmp-tmp-1461))) (syntax-dispatch syntmp-tmp-1461 (quote (any any each-any . each-any))))) syntmp-e-1460))))) (set! sc-expand (let ((syntmp-m-1472 (quote e)) (syntmp-esew-1473 (quote (eval)))) (lambda (syntmp-x-1474) (if (and (pair? syntmp-x-1474) (equal? (car syntmp-x-1474) syntmp-noexpand-84)) (cadr syntmp-x-1474) (syntmp-chi-top-152 syntmp-x-1474 (quote ()) (quote ((top))) syntmp-m-1472 syntmp-esew-1473 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1475 (quote e)) (syntmp-esew-1476 (quote (eval)))) (lambda (syntmp-x-1478 . syntmp-rest-1477) (if (and (pair? syntmp-x-1478) (equal? (car syntmp-x-1478) syntmp-noexpand-84)) (cadr syntmp-x-1478) (syntmp-chi-top-152 syntmp-x-1478 (quote ()) (quote ((top))) (if (null? syntmp-rest-1477) syntmp-m-1475 (car syntmp-rest-1477)) (if (or (null? syntmp-rest-1477) (null? (cdr syntmp-rest-1477))) syntmp-esew-1476 (cadr syntmp-rest-1477)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1479) (syntmp-nonsymbol-id?-116 syntmp-x-1479))) (set! datum->syntax-object (lambda (syntmp-id-1480 syntmp-datum-1481) (syntmp-make-syntax-object-100 syntmp-datum-1481 (syntmp-syntax-object-wrap-103 syntmp-id-1480) #f))) (set! syntax-object->datum (lambda (syntmp-x-1482) (syntmp-strip-164 syntmp-x-1482 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1483) (begin (let ((syntmp-x-1484 syntmp-ls-1483)) (if (not (list? syntmp-x-1484)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1484))) (map (lambda (syntmp-x-1485) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1483)))) (set! free-identifier=? (lambda (syntmp-x-1486 syntmp-y-1487) (begin (let ((syntmp-x-1488 syntmp-x-1486)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1488)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1488))) (let ((syntmp-x-1489 syntmp-y-1487)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1489)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1489))) (syntmp-free-id=?-140 syntmp-x-1486 syntmp-y-1487)))) (set! bound-identifier=? (lambda (syntmp-x-1490 syntmp-y-1491) (begin (let ((syntmp-x-1492 syntmp-x-1490)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1492)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1492))) (let ((syntmp-x-1493 syntmp-y-1491)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1493)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1493))) (syntmp-bound-id=?-141 syntmp-x-1490 syntmp-y-1491)))) (set! syntax-error (lambda (syntmp-object-1495 . syntmp-messages-1494) (begin (for-each (lambda (syntmp-x-1496) (let ((syntmp-x-1497 syntmp-x-1496)) (if (not (string? syntmp-x-1497)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1497)))) syntmp-messages-1494) (let ((syntmp-message-1498 (if (null? syntmp-messages-1494) "invalid syntax" (apply string-append syntmp-messages-1494)))) (syntmp-error-hook-91 #f syntmp-message-1498 (syntmp-strip-164 syntmp-object-1495 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1499 syntmp-v-1500) (begin (let ((syntmp-x-1501 syntmp-sym-1499)) (if (not (symbol? syntmp-x-1501)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1501))) (let ((syntmp-x-1502 syntmp-v-1500)) (if (not (procedure? syntmp-x-1502)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1502))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1499 syntmp-v-1500)))) (letrec ((syntmp-match-1507 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512) (cond ((not syntmp-r-1511) #f) ((eq? syntmp-p-1509 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1508 syntmp-w-1510 syntmp-mod-1512) syntmp-r-1511)) ((syntmp-syntax-object?-101 syntmp-e-1508) (syntmp-match*-1506 (let ((syntmp-e-1513 (syntmp-syntax-object-expression-102 syntmp-e-1508))) (if (annotation? syntmp-e-1513) (annotation-expression syntmp-e-1513) syntmp-e-1513)) syntmp-p-1509 (syntmp-join-wraps-136 syntmp-w-1510 (syntmp-syntax-object-wrap-103 syntmp-e-1508)) syntmp-r-1511 (syntmp-syntax-object-module-104 syntmp-e-1508))) (else (syntmp-match*-1506 (let ((syntmp-e-1514 syntmp-e-1508)) (if (annotation? syntmp-e-1514) (annotation-expression syntmp-e-1514) syntmp-e-1514)) syntmp-p-1509 syntmp-w-1510 syntmp-r-1511 syntmp-mod-1512))))) (syntmp-match*-1506 (lambda (syntmp-e-1515 syntmp-p-1516 syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) (cond ((null? syntmp-p-1516) (and (null? syntmp-e-1515) syntmp-r-1518)) ((pair? syntmp-p-1516) (and (pair? syntmp-e-1515) (syntmp-match-1507 (car syntmp-e-1515) (car syntmp-p-1516) syntmp-w-1517 (syntmp-match-1507 (cdr syntmp-e-1515) (cdr syntmp-p-1516) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519) syntmp-mod-1519))) ((eq? syntmp-p-1516 (quote each-any)) (let ((syntmp-l-1520 (syntmp-match-each-any-1504 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1520 (cons syntmp-l-1520 syntmp-r-1518)))) (else (let ((syntmp-t-1521 (vector-ref syntmp-p-1516 0))) (if (memv syntmp-t-1521 (quote (each))) (if (null? syntmp-e-1515) (syntmp-match-empty-1505 (vector-ref syntmp-p-1516 1) syntmp-r-1518) (let ((syntmp-l-1522 (syntmp-match-each-1503 syntmp-e-1515 (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-mod-1519))) (and syntmp-l-1522 (let syntmp-collect-1523 ((syntmp-l-1524 syntmp-l-1522)) (if (null? (car syntmp-l-1524)) syntmp-r-1518 (cons (map car syntmp-l-1524) (syntmp-collect-1523 (map cdr syntmp-l-1524)))))))) (if (memv syntmp-t-1521 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1515) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1515 syntmp-w-1517 syntmp-mod-1519) (vector-ref syntmp-p-1516 1)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (atom))) (and (equal? (vector-ref syntmp-p-1516 1) (syntmp-strip-164 syntmp-e-1515 syntmp-w-1517)) syntmp-r-1518) (if (memv syntmp-t-1521 (quote (vector))) (and (vector? syntmp-e-1515) (syntmp-match-1507 (vector->list syntmp-e-1515) (vector-ref syntmp-p-1516 1) syntmp-w-1517 syntmp-r-1518 syntmp-mod-1519))))))))))) (syntmp-match-empty-1505 (lambda (syntmp-p-1525 syntmp-r-1526) (cond ((null? syntmp-p-1525) syntmp-r-1526) ((eq? syntmp-p-1525 (quote any)) (cons (quote ()) syntmp-r-1526)) ((pair? syntmp-p-1525) (syntmp-match-empty-1505 (car syntmp-p-1525) (syntmp-match-empty-1505 (cdr syntmp-p-1525) syntmp-r-1526))) ((eq? syntmp-p-1525 (quote each-any)) (cons (quote ()) syntmp-r-1526)) (else (let ((syntmp-t-1527 (vector-ref syntmp-p-1525 0))) (if (memv syntmp-t-1527 (quote (each))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526) (if (memv syntmp-t-1527 (quote (free-id atom))) syntmp-r-1526 (if (memv syntmp-t-1527 (quote (vector))) (syntmp-match-empty-1505 (vector-ref syntmp-p-1525 1) syntmp-r-1526))))))))) (syntmp-match-each-any-1504 (lambda (syntmp-e-1528 syntmp-w-1529 syntmp-mod-1530) (cond ((annotation? syntmp-e-1528) (syntmp-match-each-any-1504 (annotation-expression syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530)) ((pair? syntmp-e-1528) (let ((syntmp-l-1531 (syntmp-match-each-any-1504 (cdr syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530))) (and syntmp-l-1531 (cons (syntmp-wrap-145 (car syntmp-e-1528) syntmp-w-1529 syntmp-mod-1530) syntmp-l-1531)))) ((null? syntmp-e-1528) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1528) (syntmp-match-each-any-1504 (syntmp-syntax-object-expression-102 syntmp-e-1528) (syntmp-join-wraps-136 syntmp-w-1529 (syntmp-syntax-object-wrap-103 syntmp-e-1528)) syntmp-mod-1530)) (else #f)))) (syntmp-match-each-1503 (lambda (syntmp-e-1532 syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535) (cond ((annotation? syntmp-e-1532) (syntmp-match-each-1503 (annotation-expression syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535)) ((pair? syntmp-e-1532) (let ((syntmp-first-1536 (syntmp-match-1507 (car syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 (quote ()) syntmp-mod-1535))) (and syntmp-first-1536 (let ((syntmp-rest-1537 (syntmp-match-each-1503 (cdr syntmp-e-1532) syntmp-p-1533 syntmp-w-1534 syntmp-mod-1535))) (and syntmp-rest-1537 (cons syntmp-first-1536 syntmp-rest-1537)))))) ((null? syntmp-e-1532) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1532) (syntmp-match-each-1503 (syntmp-syntax-object-expression-102 syntmp-e-1532) syntmp-p-1533 (syntmp-join-wraps-136 syntmp-w-1534 (syntmp-syntax-object-wrap-103 syntmp-e-1532)) (syntmp-syntax-object-module-104 syntmp-e-1532))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1538 syntmp-p-1539) (cond ((eq? syntmp-p-1539 (quote any)) (list syntmp-e-1538)) ((syntmp-syntax-object?-101 syntmp-e-1538) (syntmp-match*-1506 (let ((syntmp-e-1540 (syntmp-syntax-object-expression-102 syntmp-e-1538))) (if (annotation? syntmp-e-1540) (annotation-expression syntmp-e-1540) syntmp-e-1540)) syntmp-p-1539 (syntmp-syntax-object-wrap-103 syntmp-e-1538) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1538))) (else (syntmp-match*-1506 (let ((syntmp-e-1541 syntmp-e-1538)) (if (annotation? syntmp-e-1541) (annotation-expression syntmp-e-1541) syntmp-e-1541)) syntmp-p-1539 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-e1-1546 syntmp-e2-1547) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1546 syntmp-e2-1547))) syntmp-tmp-1544) ((lambda (syntmp-tmp-1549) (if syntmp-tmp-1549 (apply (lambda (syntmp-_-1550 syntmp-out-1551 syntmp-in-1552 syntmp-e1-1553 syntmp-e2-1554) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-in-1552 (quote ()) (list syntmp-out-1551 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1553 syntmp-e2-1554))))) syntmp-tmp-1549) ((lambda (syntmp-tmp-1556) (if syntmp-tmp-1556 (apply (lambda (syntmp-_-1557 syntmp-out-1558 syntmp-in-1559 syntmp-e1-1560 syntmp-e2-1561) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-in-1559) (quote ()) (list syntmp-out-1558 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1560 syntmp-e2-1561))))) syntmp-tmp-1556) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1543 (quote (any () any . each-any))))) syntmp-x-1542))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1583) ((lambda (syntmp-tmp-1584) ((lambda (syntmp-tmp-1585) (if syntmp-tmp-1585 (apply (lambda (syntmp-_-1586 syntmp-k-1587 syntmp-keyword-1588 syntmp-pattern-1589 syntmp-template-1590) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-k-1587 (map (lambda (syntmp-tmp-1593 syntmp-tmp-1592) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-tmp-1592) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-tmp-1593))) syntmp-template-1590 syntmp-pattern-1589)))))) syntmp-tmp-1585) (syntax-error syntmp-tmp-1584))) (syntax-dispatch syntmp-tmp-1584 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1583))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1604) ((lambda (syntmp-tmp-1605) ((lambda (syntmp-tmp-1606) (if (if syntmp-tmp-1606 (apply (lambda (syntmp-let*-1607 syntmp-x-1608 syntmp-v-1609 syntmp-e1-1610 syntmp-e2-1611) (andmap identifier? syntmp-x-1608)) syntmp-tmp-1606) #f) (apply (lambda (syntmp-let*-1613 syntmp-x-1614 syntmp-v-1615 syntmp-e1-1616 syntmp-e2-1617) (let syntmp-f-1618 ((syntmp-bindings-1619 (map list syntmp-x-1614 syntmp-v-1615))) (if (null? syntmp-bindings-1619) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons syntmp-e1-1616 syntmp-e2-1617))) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-body-1625 syntmp-binding-1626) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list syntmp-binding-1626) syntmp-body-1625)) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any any))))) (list (syntmp-f-1618 (cdr syntmp-bindings-1619)) (car syntmp-bindings-1619)))))) syntmp-tmp-1606) (syntax-error syntmp-tmp-1605))) (syntax-dispatch syntmp-tmp-1605 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1604))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1646) ((lambda (syntmp-tmp-1647) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-_-1649 syntmp-var-1650 syntmp-init-1651 syntmp-step-1652 syntmp-e0-1653 syntmp-e1-1654 syntmp-c-1655) ((lambda (syntmp-tmp-1656) ((lambda (syntmp-tmp-1657) (if syntmp-tmp-1657 (apply (lambda (syntmp-step-1658) ((lambda (syntmp-tmp-1659) ((lambda (syntmp-tmp-1660) (if syntmp-tmp-1660 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-e0-1653) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-step-1658))))))) syntmp-tmp-1660) ((lambda (syntmp-tmp-1665) (if syntmp-tmp-1665 (apply (lambda (syntmp-e1-1666 syntmp-e2-1667) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list syntmp-var-1650 syntmp-init-1651) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-e0-1653 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1666 syntmp-e2-1667)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append syntmp-c-1655 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) syntmp-step-1658))))))) syntmp-tmp-1665) (syntax-error syntmp-tmp-1659))) (syntax-dispatch syntmp-tmp-1659 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1659 (quote ())))) syntmp-e1-1654)) syntmp-tmp-1657) (syntax-error syntmp-tmp-1656))) (syntax-dispatch syntmp-tmp-1656 (quote each-any)))) (map (lambda (syntmp-v-1674 syntmp-s-1675) ((lambda (syntmp-tmp-1676) ((lambda (syntmp-tmp-1677) (if syntmp-tmp-1677 (apply (lambda () syntmp-v-1674) syntmp-tmp-1677) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-e-1679) syntmp-e-1679) syntmp-tmp-1678) ((lambda (syntmp-_-1680) (syntax-error syntmp-orig-x-1646)) syntmp-tmp-1676))) (syntax-dispatch syntmp-tmp-1676 (quote (any)))))) (syntax-dispatch syntmp-tmp-1676 (quote ())))) syntmp-s-1675)) syntmp-var-1650 syntmp-step-1652))) syntmp-tmp-1648) (syntax-error syntmp-tmp-1647))) (syntax-dispatch syntmp-tmp-1647 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1646))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1708 (lambda (syntmp-x-1712 syntmp-y-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-tmp-1715) (if syntmp-tmp-1715 (apply (lambda (syntmp-x-1716 syntmp-y-1717) ((lambda (syntmp-tmp-1718) ((lambda (syntmp-tmp-1719) (if syntmp-tmp-1719 (apply (lambda (syntmp-dy-1720) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-dx-1723) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons syntmp-dx-1723 syntmp-dy-1720))) syntmp-tmp-1722) ((lambda (syntmp-_-1724) (if (null? syntmp-dy-1720) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1716) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1716 syntmp-y-1717))) syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) syntmp-x-1716)) syntmp-tmp-1719) ((lambda (syntmp-tmp-1725) (if syntmp-tmp-1725 (apply (lambda (syntmp-stuff-1726) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons syntmp-x-1716 syntmp-stuff-1726))) syntmp-tmp-1725) ((lambda (syntmp-else-1727) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1716 syntmp-y-1717)) syntmp-tmp-1718))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch syntmp-tmp-1718 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) syntmp-y-1717)) syntmp-tmp-1715) (syntax-error syntmp-tmp-1714))) (syntax-dispatch syntmp-tmp-1714 (quote (any any))))) (list syntmp-x-1712 syntmp-y-1713)))) (syntmp-quasiappend-1709 (lambda (syntmp-x-1728 syntmp-y-1729) ((lambda (syntmp-tmp-1730) ((lambda (syntmp-tmp-1731) (if syntmp-tmp-1731 (apply (lambda (syntmp-x-1732 syntmp-y-1733) ((lambda (syntmp-tmp-1734) ((lambda (syntmp-tmp-1735) (if syntmp-tmp-1735 (apply (lambda () syntmp-x-1732) syntmp-tmp-1735) ((lambda (syntmp-_-1736) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1732 syntmp-y-1733)) syntmp-tmp-1734))) (syntax-dispatch syntmp-tmp-1734 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) syntmp-y-1733)) syntmp-tmp-1731) (syntax-error syntmp-tmp-1730))) (syntax-dispatch syntmp-tmp-1730 (quote (any any))))) (list syntmp-x-1728 syntmp-y-1729)))) (syntmp-quasivector-1710 (lambda (syntmp-x-1737) ((lambda (syntmp-tmp-1738) ((lambda (syntmp-x-1739) ((lambda (syntmp-tmp-1740) ((lambda (syntmp-tmp-1741) (if syntmp-tmp-1741 (apply (lambda (syntmp-x-1742) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector syntmp-x-1742))) syntmp-tmp-1741) ((lambda (syntmp-tmp-1744) (if syntmp-tmp-1744 (apply (lambda (syntmp-x-1745) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1745)) syntmp-tmp-1744) ((lambda (syntmp-_-1747) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-x-1739)) syntmp-tmp-1740))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch syntmp-tmp-1740 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) syntmp-x-1739)) syntmp-tmp-1738)) syntmp-x-1737))) (syntmp-quasi-1711 (lambda (syntmp-p-1748 syntmp-lev-1749) ((lambda (syntmp-tmp-1750) ((lambda (syntmp-tmp-1751) (if syntmp-tmp-1751 (apply (lambda (syntmp-p-1752) (if (= syntmp-lev-1749 0) syntmp-p-1752 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (syntmp-quasi-1711 (list syntmp-p-1752) (- syntmp-lev-1749 1))))) syntmp-tmp-1751) ((lambda (syntmp-tmp-1753) (if syntmp-tmp-1753 (apply (lambda (syntmp-p-1754 syntmp-q-1755) (if (= syntmp-lev-1749 0) (syntmp-quasiappend-1709 syntmp-p-1754 (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)) (syntmp-quasicons-1708 (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (syntmp-quasi-1711 (list syntmp-p-1754) (- syntmp-lev-1749 1))) (syntmp-quasi-1711 syntmp-q-1755 syntmp-lev-1749)))) syntmp-tmp-1753) ((lambda (syntmp-tmp-1756) (if syntmp-tmp-1756 (apply (lambda (syntmp-p-1757) (syntmp-quasicons-1708 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (syntmp-quasi-1711 (list syntmp-p-1757) (+ syntmp-lev-1749 1)))) syntmp-tmp-1756) ((lambda (syntmp-tmp-1758) (if syntmp-tmp-1758 (apply (lambda (syntmp-p-1759 syntmp-q-1760) (syntmp-quasicons-1708 (syntmp-quasi-1711 syntmp-p-1759 syntmp-lev-1749) (syntmp-quasi-1711 syntmp-q-1760 syntmp-lev-1749))) syntmp-tmp-1758) ((lambda (syntmp-tmp-1761) (if syntmp-tmp-1761 (apply (lambda (syntmp-x-1762) (syntmp-quasivector-1710 (syntmp-quasi-1711 syntmp-x-1762 syntmp-lev-1749))) syntmp-tmp-1761) ((lambda (syntmp-p-1764) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) syntmp-p-1764)) syntmp-tmp-1750))) (syntax-dispatch syntmp-tmp-1750 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch syntmp-tmp-1750 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch syntmp-tmp-1750 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) syntmp-p-1748)))) (lambda (syntmp-x-1765) ((lambda (syntmp-tmp-1766) ((lambda (syntmp-tmp-1767) (if syntmp-tmp-1767 (apply (lambda (syntmp-_-1768 syntmp-e-1769) (syntmp-quasi-1711 syntmp-e-1769 0)) syntmp-tmp-1767) (syntax-error syntmp-tmp-1766))) (syntax-dispatch syntmp-tmp-1766 (quote (any any))))) syntmp-x-1765)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1829) (letrec ((syntmp-read-file-1830 (lambda (syntmp-fn-1831 syntmp-k-1832) (let ((syntmp-p-1833 (open-input-file syntmp-fn-1831))) (let syntmp-f-1834 ((syntmp-x-1835 (read syntmp-p-1833))) (if (eof-object? syntmp-x-1835) (begin (close-input-port syntmp-p-1833) (quote ())) (cons (datum->syntax-object syntmp-k-1832 syntmp-x-1835) (syntmp-f-1834 (read syntmp-p-1833))))))))) ((lambda (syntmp-tmp-1836) ((lambda (syntmp-tmp-1837) (if syntmp-tmp-1837 (apply (lambda (syntmp-k-1838 syntmp-filename-1839) (let ((syntmp-fn-1840 (syntax-object->datum syntmp-filename-1839))) ((lambda (syntmp-tmp-1841) ((lambda (syntmp-tmp-1842) (if syntmp-tmp-1842 (apply (lambda (syntmp-exp-1843) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-exp-1843)) syntmp-tmp-1842) (syntax-error syntmp-tmp-1841))) (syntax-dispatch syntmp-tmp-1841 (quote each-any)))) (syntmp-read-file-1830 syntmp-fn-1840 syntmp-k-1838)))) syntmp-tmp-1837) (syntax-error syntmp-tmp-1836))) (syntax-dispatch syntmp-tmp-1836 (quote (any any))))) syntmp-x-1829)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1860) ((lambda (syntmp-tmp-1861) ((lambda (syntmp-tmp-1862) (if syntmp-tmp-1862 (apply (lambda (syntmp-_-1863 syntmp-e-1864) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1864))) syntmp-tmp-1862) (syntax-error syntmp-tmp-1861))) (syntax-dispatch syntmp-tmp-1861 (quote (any any))))) syntmp-x-1860))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1870) ((lambda (syntmp-tmp-1871) ((lambda (syntmp-tmp-1872) (if syntmp-tmp-1872 (apply (lambda (syntmp-_-1873 syntmp-e-1874) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1874))) syntmp-tmp-1872) (syntax-error syntmp-tmp-1871))) (syntax-dispatch syntmp-tmp-1871 (quote (any any))))) syntmp-x-1870))) -(install-global-transformer (quote case) (lambda (syntmp-x-1880) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-tmp-1882) (if syntmp-tmp-1882 (apply (lambda (syntmp-_-1883 syntmp-e-1884 syntmp-m1-1885 syntmp-m2-1886) ((lambda (syntmp-tmp-1887) ((lambda (syntmp-body-1888) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-e-1884)) syntmp-body-1888)) syntmp-tmp-1887)) (let syntmp-f-1889 ((syntmp-clause-1890 syntmp-m1-1885) (syntmp-clauses-1891 syntmp-m2-1886)) (if (null? syntmp-clauses-1891) ((lambda (syntmp-tmp-1893) ((lambda (syntmp-tmp-1894) (if syntmp-tmp-1894 (apply (lambda (syntmp-e1-1895 syntmp-e2-1896) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1895 syntmp-e2-1896))) syntmp-tmp-1894) ((lambda (syntmp-tmp-1898) (if syntmp-tmp-1898 (apply (lambda (syntmp-k-1899 syntmp-e1-1900 syntmp-e2-1901) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-k-1899)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1900 syntmp-e2-1901)))) syntmp-tmp-1898) ((lambda (syntmp-_-1904) (syntax-error syntmp-x-1880)) syntmp-tmp-1893))) (syntax-dispatch syntmp-tmp-1893 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1893 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) syntmp-clause-1890) ((lambda (syntmp-tmp-1905) ((lambda (syntmp-rest-1906) ((lambda (syntmp-tmp-1907) ((lambda (syntmp-tmp-1908) (if syntmp-tmp-1908 (apply (lambda (syntmp-k-1909 syntmp-e1-1910 syntmp-e2-1911) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-k-1909)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e1-1910 syntmp-e2-1911)) syntmp-rest-1906)) syntmp-tmp-1908) ((lambda (syntmp-_-1914) (syntax-error syntmp-x-1880)) syntmp-tmp-1907))) (syntax-dispatch syntmp-tmp-1907 (quote (each-any any . each-any))))) syntmp-clause-1890)) syntmp-tmp-1905)) (syntmp-f-1889 (car syntmp-clauses-1891) (cdr syntmp-clauses-1891))))))) syntmp-tmp-1882) (syntax-error syntmp-tmp-1881))) (syntax-dispatch syntmp-tmp-1881 (quote (any any any . each-any))))) syntmp-x-1880))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1944) ((lambda (syntmp-tmp-1945) ((lambda (syntmp-tmp-1946) (if syntmp-tmp-1946 (apply (lambda (syntmp-_-1947 syntmp-e-1948) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) syntmp-e-1948)) (list (cons syntmp-_-1947 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons syntmp-e-1948 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) syntmp-tmp-1946) (syntax-error syntmp-tmp-1945))) (syntax-dispatch syntmp-tmp-1945 (quote (any any))))) syntmp-x-1944))) +(letrec ((lambda-var-list1140 (lambda (vars1339) (let lvl1340 ((vars1341 vars1339) (ls1342 (quote ())) (w1343 (quote (())))) (cond ((pair? vars1341) (lvl1340 (cdr vars1341) (cons (wrap1119 (car vars1341) w1343 #f) ls1342) w1343)) ((id?1091 vars1341) (cons (wrap1119 vars1341 w1343 #f) ls1342)) ((null? vars1341) ls1342) ((syntax-object?1075 vars1341) (lvl1340 (syntax-object-expression1076 vars1341) ls1342 (join-wraps1110 w1343 (syntax-object-wrap1077 vars1341)))) ((annotation? vars1341) (lvl1340 (annotation-expression vars1341) ls1342 w1343)) (else (cons vars1341 ls1342)))))) (gen-var1139 (lambda (id1344) (let ((id1345 (if (syntax-object?1075 id1344) (syntax-object-expression1076 id1344) id1344))) (if (annotation? id1345) (build-annotated1068 (annotation-source id1345) (gensym (symbol->string (annotation-expression id1345)))) (build-annotated1068 #f (gensym (symbol->string id1345))))))) (strip1138 (lambda (x1346 w1347) (if (memq (quote top) (wrap-marks1094 w1347)) (if (or (annotation? x1346) (and (pair? x1346) (annotation? (car x1346)))) (strip-annotation1137 x1346 #f) x1346) (let f1348 ((x1349 x1346)) (cond ((syntax-object?1075 x1349) (strip1138 (syntax-object-expression1076 x1349) (syntax-object-wrap1077 x1349))) ((pair? x1349) (let ((a1350 (f1348 (car x1349))) (d1351 (f1348 (cdr x1349)))) (if (and (eq? a1350 (car x1349)) (eq? d1351 (cdr x1349))) x1349 (cons a1350 d1351)))) ((vector? x1349) (let ((old1352 (vector->list x1349))) (let ((new1353 (map f1348 old1352))) (if (andmap eq? old1352 new1353) x1349 (list->vector new1353))))) (else x1349)))))) (strip-annotation1137 (lambda (x1354 parent1355) (cond ((pair? x1354) (let ((new1356 (cons #f #f))) (begin (if parent1355 (set-annotation-stripped! parent1355 new1356)) (set-car! new1356 (strip-annotation1137 (car x1354) #f)) (set-cdr! new1356 (strip-annotation1137 (cdr x1354) #f)) new1356))) ((annotation? x1354) (or (annotation-stripped x1354) (strip-annotation1137 (annotation-expression x1354) x1354))) ((vector? x1354) (let ((new1357 (make-vector (vector-length x1354)))) (begin (if parent1355 (set-annotation-stripped! parent1355 new1357)) (let loop1358 ((i1359 (- (vector-length x1354) 1))) (unless (fx<1062 i1359 0) (vector-set! new1357 i1359 (strip-annotation1137 (vector-ref x1354 i1359) #f)) (loop1358 (fx-1060 i1359 1)))) new1357))) (else x1354)))) (ellipsis?1136 (lambda (x1360) (and (nonsymbol-id?1090 x1360) (free-id=?1114 x1360 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1135 (lambda () (build-annotated1068 #f (list (build-annotated1068 #f (quote void)))))) (eval-local-transformer1134 (lambda (expanded1361 mod1362) (let ((p1363 (local-eval-hook1064 expanded1361 mod1362))) (if (procedure? p1363) p1363 (syntax-error p1363 "nonprocedure transformer"))))) (chi-local-syntax1133 (lambda (rec?1364 e1365 r1366 w1367 s1368 mod1369 k1370) ((lambda (tmp1371) ((lambda (tmp1372) (if tmp1372 (apply (lambda (_1373 id1374 val1375 e11376 e21377) (let ((ids1378 id1374)) (if (not (valid-bound-ids?1116 ids1378)) (syntax-error e1365 "duplicate bound keyword in") (let ((labels1380 (gen-labels1097 ids1378))) (let ((new-w1381 (make-binding-wrap1108 ids1378 labels1380 w1367))) (k1370 (cons e11376 e21377) (extend-env1085 labels1380 (let ((w1383 (if rec?1364 new-w1381 w1367)) (trans-r1384 (macros-only-env1087 r1366))) (map (lambda (x1385) (cons (quote macro) (eval-local-transformer1134 (chi1127 x1385 trans-r1384 w1383 mod1369) mod1369))) val1375)) r1366) new-w1381 s1368 mod1369)))))) tmp1372) ((lambda (_1387) (syntax-error (source-wrap1120 e1365 w1367 s1368 mod1369))) tmp1371))) (syntax-dispatch tmp1371 (quote (any #(each (any any)) any . each-any))))) e1365))) (chi-lambda-clause1132 (lambda (e1388 c1389 r1390 w1391 mod1392 k1393) ((lambda (tmp1394) ((lambda (tmp1395) (if tmp1395 (apply (lambda (id1396 e11397 e21398) (let ((ids1399 id1396)) (if (not (valid-bound-ids?1116 ids1399)) (syntax-error e1388 "invalid parameter list in") (let ((labels1401 (gen-labels1097 ids1399)) (new-vars1402 (map gen-var1139 ids1399))) (k1393 new-vars1402 (chi-body1131 (cons e11397 e21398) e1388 (extend-var-env1086 labels1401 new-vars1402 r1390) (make-binding-wrap1108 ids1399 labels1401 w1391) mod1392)))))) tmp1395) ((lambda (tmp1404) (if tmp1404 (apply (lambda (ids1405 e11406 e21407) (let ((old-ids1408 (lambda-var-list1140 ids1405))) (if (not (valid-bound-ids?1116 old-ids1408)) (syntax-error e1388 "invalid parameter list in") (let ((labels1409 (gen-labels1097 old-ids1408)) (new-vars1410 (map gen-var1139 old-ids1408))) (k1393 (let f1411 ((ls11412 (cdr new-vars1410)) (ls21413 (car new-vars1410))) (if (null? ls11412) ls21413 (f1411 (cdr ls11412) (cons (car ls11412) ls21413)))) (chi-body1131 (cons e11406 e21407) e1388 (extend-var-env1086 labels1409 new-vars1410 r1390) (make-binding-wrap1108 old-ids1408 labels1409 w1391) mod1392)))))) tmp1404) ((lambda (_1415) (syntax-error e1388)) tmp1394))) (syntax-dispatch tmp1394 (quote (any any . each-any)))))) (syntax-dispatch tmp1394 (quote (each-any any . each-any))))) c1389))) (chi-body1131 (lambda (body1416 outer-form1417 r1418 w1419 mod1420) (let ((r1421 (cons (quote ("placeholder" placeholder)) r1418))) (let ((ribcage1422 (make-ribcage1098 (quote ()) (quote ()) (quote ())))) (let ((w1423 (make-wrap1093 (wrap-marks1094 w1419) (cons ribcage1422 (wrap-subst1095 w1419))))) (let parse1424 ((body1425 (map (lambda (x1431) (cons r1421 (wrap1119 x1431 w1423 mod1420))) body1416)) (ids1426 (quote ())) (labels1427 (quote ())) (vars1428 (quote ())) (vals1429 (quote ())) (bindings1430 (quote ()))) (if (null? body1425) (syntax-error outer-form1417 "no expressions in body") (let ((e1432 (cdar body1425)) (er1433 (caar body1425))) (call-with-values (lambda () (syntax-type1125 e1432 er1433 (quote (())) #f ribcage1422 mod1420)) (lambda (type1434 value1435 e1436 w1437 s1438 mod1439) (let ((t1440 type1434)) (if (memv t1440 (quote (define-form))) (let ((id1441 (wrap1119 value1435 w1437 mod1439)) (label1442 (gen-label1096))) (let ((var1443 (gen-var1139 id1441))) (begin (extend-ribcage!1107 ribcage1422 id1441 label1442) (parse1424 (cdr body1425) (cons id1441 ids1426) (cons label1442 labels1427) (cons var1443 vars1428) (cons (cons er1433 (wrap1119 e1436 w1437 mod1439)) vals1429) (cons (cons (quote lexical) var1443) bindings1430))))) (if (memv t1440 (quote (define-syntax-form))) (let ((id1444 (wrap1119 value1435 w1437 mod1439)) (label1445 (gen-label1096))) (begin (extend-ribcage!1107 ribcage1422 id1444 label1445) (parse1424 (cdr body1425) (cons id1444 ids1426) (cons label1445 labels1427) vars1428 vals1429 (cons (cons (quote macro) (cons er1433 (wrap1119 e1436 w1437 mod1439))) bindings1430)))) (if (memv t1440 (quote (begin-form))) ((lambda (tmp1446) ((lambda (tmp1447) (if tmp1447 (apply (lambda (_1448 e11449) (parse1424 (let f1450 ((forms1451 e11449)) (if (null? forms1451) (cdr body1425) (cons (cons er1433 (wrap1119 (car forms1451) w1437 mod1439)) (f1450 (cdr forms1451))))) ids1426 labels1427 vars1428 vals1429 bindings1430)) tmp1447) (syntax-error tmp1446))) (syntax-dispatch tmp1446 (quote (any . each-any))))) e1436) (if (memv t1440 (quote (local-syntax-form))) (chi-local-syntax1133 value1435 e1436 er1433 w1437 s1438 mod1439 (lambda (forms1453 er1454 w1455 s1456 mod1457) (parse1424 (let f1458 ((forms1459 forms1453)) (if (null? forms1459) (cdr body1425) (cons (cons er1454 (wrap1119 (car forms1459) w1455 mod1457)) (f1458 (cdr forms1459))))) ids1426 labels1427 vars1428 vals1429 bindings1430))) (if (null? ids1426) (build-sequence1070 #f (map (lambda (x1460) (chi1127 (cdr x1460) (car x1460) (quote (())) mod1439)) (cons (cons er1433 (source-wrap1120 e1436 w1437 s1438 mod1439)) (cdr body1425)))) (begin (if (not (valid-bound-ids?1116 ids1426)) (syntax-error outer-form1417 "invalid or duplicate identifier in definition")) (let loop1461 ((bs1462 bindings1430) (er-cache1463 #f) (r-cache1464 #f)) (if (not (null? bs1462)) (let ((b1465 (car bs1462))) (if (eq? (car b1465) (quote macro)) (let ((er1466 (cadr b1465))) (let ((r-cache1467 (if (eq? er1466 er-cache1463) r-cache1464 (macros-only-env1087 er1466)))) (begin (set-cdr! b1465 (eval-local-transformer1134 (chi1127 (cddr b1465) r-cache1467 (quote (())) mod1439) mod1439)) (loop1461 (cdr bs1462) er1466 r-cache1467)))) (loop1461 (cdr bs1462) er-cache1463 r-cache1464))))) (set-cdr! r1421 (extend-env1085 labels1427 bindings1430 (cdr r1421))) (build-letrec1073 #f vars1428 (map (lambda (x1468) (chi1127 (cdr x1468) (car x1468) (quote (())) mod1439)) vals1429) (build-sequence1070 #f (map (lambda (x1469) (chi1127 (cdr x1469) (car x1469) (quote (())) mod1439)) (cons (cons er1433 (source-wrap1120 e1436 w1437 s1438 mod1439)) (cdr body1425)))))))))))))))))))))) (chi-macro1130 (lambda (p1470 e1471 r1472 w1473 rib1474 mod1475) (letrec ((rebuild-macro-output1476 (lambda (x1477 m1478) (cond ((pair? x1477) (cons (rebuild-macro-output1476 (car x1477) m1478) (rebuild-macro-output1476 (cdr x1477) m1478))) ((syntax-object?1075 x1477) (let ((w1479 (syntax-object-wrap1077 x1477))) (let ((ms1480 (wrap-marks1094 w1479)) (s1481 (wrap-subst1095 w1479))) (if (and (pair? ms1480) (eq? (car ms1480) #f)) (make-syntax-object1074 (syntax-object-expression1076 x1477) (make-wrap1093 (cdr ms1480) (if rib1474 (cons rib1474 (cdr s1481)) (cdr s1481))) (syntax-object-module1078 x1477)) (make-syntax-object1074 (syntax-object-expression1076 x1477) (make-wrap1093 (cons m1478 ms1480) (if rib1474 (cons rib1474 (cons (quote shift) s1481)) (cons (quote shift) s1481))) (module-name (procedure-module p1470))))))) ((vector? x1477) (let ((n1482 (vector-length x1477))) (let ((v1483 (make-vector n1482))) (let doloop1484 ((i1485 0)) (if (fx=1061 i1485 n1482) v1483 (begin (vector-set! v1483 i1485 (rebuild-macro-output1476 (vector-ref x1477 i1485) m1478)) (doloop1484 (fx+1059 i1485 1)))))))) ((symbol? x1477) (syntax-error x1477 "encountered raw symbol in macro output")) (else x1477))))) (rebuild-macro-output1476 (p1470 (wrap1119 e1471 (anti-mark1106 w1473) mod1475)) (string #\m))))) (chi-application1129 (lambda (x1486 e1487 r1488 w1489 s1490 mod1491) ((lambda (tmp1492) ((lambda (tmp1493) (if tmp1493 (apply (lambda (e01494 e11495) (build-annotated1068 s1490 (cons x1486 (map (lambda (e1496) (chi1127 e1496 r1488 w1489 mod1491)) e11495)))) tmp1493) (syntax-error tmp1492))) (syntax-dispatch tmp1492 (quote (any . each-any))))) e1487))) (chi-expr1128 (lambda (type1498 value1499 e1500 r1501 w1502 s1503 mod1504) (let ((t1505 type1498)) (if (memv t1505 (quote (lexical))) (build-annotated1068 s1503 value1499) (if (memv t1505 (quote (core external-macro))) (value1499 e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (module-ref))) (call-with-values (lambda () (value1499 e1500)) (lambda (id1506 mod1507) (build-annotated1068 s1503 (make-module-ref mod1507 id1506 #f)))) (if (memv t1505 (quote (lexical-call))) (chi-application1129 (build-annotated1068 (source-annotation1082 (car e1500)) value1499) e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (global-call))) (chi-application1129 (build-annotated1068 (source-annotation1082 (car e1500)) (make-module-ref (if (syntax-object?1075 (car e1500)) (syntax-object-module1078 (car e1500)) mod1504) value1499 #f)) e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (constant))) (build-data1069 s1503 (strip1138 (source-wrap1120 e1500 w1502 s1503 mod1504) (quote (())))) (if (memv t1505 (quote (global))) (build-annotated1068 s1503 (make-module-ref mod1504 value1499 #f)) (if (memv t1505 (quote (call))) (chi-application1129 (chi1127 (car e1500) r1501 w1502 mod1504) e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (begin-form))) ((lambda (tmp1508) ((lambda (tmp1509) (if tmp1509 (apply (lambda (_1510 e11511 e21512) (chi-sequence1121 (cons e11511 e21512) r1501 w1502 s1503 mod1504)) tmp1509) (syntax-error tmp1508))) (syntax-dispatch tmp1508 (quote (any any . each-any))))) e1500) (if (memv t1505 (quote (local-syntax-form))) (chi-local-syntax1133 value1499 e1500 r1501 w1502 s1503 mod1504 chi-sequence1121) (if (memv t1505 (quote (eval-when-form))) ((lambda (tmp1514) ((lambda (tmp1515) (if tmp1515 (apply (lambda (_1516 x1517 e11518 e21519) (let ((when-list1520 (chi-when-list1124 e1500 x1517 w1502))) (if (memq (quote eval) when-list1520) (chi-sequence1121 (cons e11518 e21519) r1501 w1502 s1503 mod1504) (chi-void1135)))) tmp1515) (syntax-error tmp1514))) (syntax-dispatch tmp1514 (quote (any each-any any . each-any))))) e1500) (if (memv t1505 (quote (define-form define-syntax-form))) (syntax-error (wrap1119 value1499 w1502 mod1504) "invalid context for definition of") (if (memv t1505 (quote (syntax))) (syntax-error (source-wrap1120 e1500 w1502 s1503 mod1504) "reference to pattern variable outside syntax form") (if (memv t1505 (quote (displaced-lexical))) (syntax-error (source-wrap1120 e1500 w1502 s1503 mod1504) "reference to identifier outside its scope") (syntax-error (source-wrap1120 e1500 w1502 s1503 mod1504))))))))))))))))))) (chi1127 (lambda (e1523 r1524 w1525 mod1526) (call-with-values (lambda () (syntax-type1125 e1523 r1524 w1525 #f #f mod1526)) (lambda (type1527 value1528 e1529 w1530 s1531 mod1532) (chi-expr1128 type1527 value1528 e1529 r1524 w1530 s1531 mod1532))))) (chi-top1126 (lambda (e1533 r1534 w1535 m1536 esew1537 mod1538) (call-with-values (lambda () (syntax-type1125 e1533 r1534 w1535 #f #f mod1538)) (lambda (type1546 value1547 e1548 w1549 s1550 mod1551) (let ((t1552 type1546)) (if (memv t1552 (quote (begin-form))) ((lambda (tmp1553) ((lambda (tmp1554) (if tmp1554 (apply (lambda (_1555) (chi-void1135)) tmp1554) ((lambda (tmp1556) (if tmp1556 (apply (lambda (_1557 e11558 e21559) (chi-top-sequence1122 (cons e11558 e21559) r1534 w1549 s1550 m1536 esew1537 mod1551)) tmp1556) (syntax-error tmp1553))) (syntax-dispatch tmp1553 (quote (any any . each-any)))))) (syntax-dispatch tmp1553 (quote (any))))) e1548) (if (memv t1552 (quote (local-syntax-form))) (chi-local-syntax1133 value1547 e1548 r1534 w1549 s1550 mod1551 (lambda (body1561 r1562 w1563 s1564 mod1565) (chi-top-sequence1122 body1561 r1562 w1563 s1564 m1536 esew1537 mod1565))) (if (memv t1552 (quote (eval-when-form))) ((lambda (tmp1566) ((lambda (tmp1567) (if tmp1567 (apply (lambda (_1568 x1569 e11570 e21571) (let ((when-list1572 (chi-when-list1124 e1548 x1569 w1549)) (body1573 (cons e11570 e21571))) (cond ((eq? m1536 (quote e)) (if (memq (quote eval) when-list1572) (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote e) (quote (eval)) mod1551) (chi-void1135))) ((memq (quote load) when-list1572) (if (or (memq (quote compile) when-list1572) (and (eq? m1536 (quote c&e)) (memq (quote eval) when-list1572))) (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote c&e) (quote (compile load)) mod1551) (if (memq m1536 (quote (c c&e))) (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote c) (quote (load)) mod1551) (chi-void1135)))) ((or (memq (quote compile) when-list1572) (and (eq? m1536 (quote c&e)) (memq (quote eval) when-list1572))) (top-level-eval-hook1063 (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote e) (quote (eval)) mod1551) mod1551) (chi-void1135)) (else (chi-void1135))))) tmp1567) (syntax-error tmp1566))) (syntax-dispatch tmp1566 (quote (any each-any any . each-any))))) e1548) (if (memv t1552 (quote (define-syntax-form))) (let ((n1576 (id-var-name1113 value1547 w1549)) (r1577 (macros-only-env1087 r1534))) (let ((t1578 m1536)) (if (memv t1578 (quote (c))) (if (memq (quote compile) esew1537) (let ((e1579 (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)))) (begin (top-level-eval-hook1063 e1579 mod1551) (if (memq (quote load) esew1537) e1579 (chi-void1135)))) (if (memq (quote load) esew1537) (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)) (chi-void1135))) (if (memv t1578 (quote (c&e))) (let ((e1580 (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)))) (begin (top-level-eval-hook1063 e1580 mod1551) e1580)) (begin (if (memq (quote eval) esew1537) (top-level-eval-hook1063 (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)) mod1551)) (chi-void1135)))))) (if (memv t1552 (quote (define-form))) (let ((n1581 (id-var-name1113 value1547 w1549))) (let ((type1582 (binding-type1083 (lookup1088 n1581 r1534 mod1551)))) (let ((t1583 type1582)) (if (memv t1583 (quote (global))) (let ((x1584 (build-annotated1068 s1550 (list (quote define) n1581 (chi1127 e1548 r1534 w1549 mod1551))))) (begin (if (eq? m1536 (quote c&e)) (top-level-eval-hook1063 x1584 mod1551)) x1584)) (if (memv t1583 (quote (displaced-lexical))) (syntax-error (wrap1119 value1547 w1549 mod1551) "identifier out of context") (if (eq? type1582 (quote external-macro)) (let ((x1585 (build-annotated1068 s1550 (list (quote define) n1581 (chi1127 e1548 r1534 w1549 mod1551))))) (begin (if (eq? m1536 (quote c&e)) (top-level-eval-hook1063 x1585 mod1551)) x1585)) (syntax-error (wrap1119 value1547 w1549 mod1551) "cannot define keyword at top level"))))))) (let ((x1586 (chi-expr1128 type1546 value1547 e1548 r1534 w1549 s1550 mod1551))) (begin (if (eq? m1536 (quote c&e)) (top-level-eval-hook1063 x1586 mod1551)) x1586)))))))))))) (syntax-type1125 (lambda (e1587 r1588 w1589 s1590 rib1591 mod1592) (cond ((symbol? e1587) (let ((n1593 (id-var-name1113 e1587 w1589))) (let ((b1594 (lookup1088 n1593 r1588 mod1592))) (let ((type1595 (binding-type1083 b1594))) (let ((t1596 type1595)) (if (memv t1596 (quote (lexical))) (values type1595 (binding-value1084 b1594) e1587 w1589 s1590 mod1592) (if (memv t1596 (quote (global))) (values type1595 n1593 e1587 w1589 s1590 mod1592) (if (memv t1596 (quote (macro))) (syntax-type1125 (chi-macro1130 (binding-value1084 b1594) e1587 r1588 w1589 rib1591 mod1592) r1588 (quote (())) s1590 rib1591 mod1592) (values type1595 (binding-value1084 b1594) e1587 w1589 s1590 mod1592))))))))) ((pair? e1587) (let ((first1597 (car e1587))) (if (id?1091 first1597) (let ((n1598 (id-var-name1113 first1597 w1589))) (let ((b1599 (lookup1088 n1598 r1588 (or (and (syntax-object?1075 first1597) (syntax-object-module1078 first1597)) mod1592)))) (let ((type1600 (binding-type1083 b1599))) (let ((t1601 type1600)) (if (memv t1601 (quote (lexical))) (values (quote lexical-call) (binding-value1084 b1599) e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (global))) (values (quote global-call) n1598 e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (macro))) (syntax-type1125 (chi-macro1130 (binding-value1084 b1599) e1587 r1588 w1589 rib1591 mod1592) r1588 (quote (())) s1590 rib1591 mod1592) (if (memv t1601 (quote (core external-macro module-ref))) (values type1600 (binding-value1084 b1599) e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1084 b1599) e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (begin))) (values (quote begin-form) #f e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (eval-when))) (values (quote eval-when-form) #f e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (define))) ((lambda (tmp1602) ((lambda (tmp1603) (if (if tmp1603 (apply (lambda (_1604 name1605 val1606) (id?1091 name1605)) tmp1603) #f) (apply (lambda (_1607 name1608 val1609) (values (quote define-form) name1608 val1609 w1589 s1590 mod1592)) tmp1603) ((lambda (tmp1610) (if (if tmp1610 (apply (lambda (_1611 name1612 args1613 e11614 e21615) (and (id?1091 name1612) (valid-bound-ids?1116 (lambda-var-list1140 args1613)))) tmp1610) #f) (apply (lambda (_1616 name1617 args1618 e11619 e21620) (values (quote define-form) (wrap1119 name1617 w1589 mod1592) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1119 (cons args1618 (cons e11619 e21620)) w1589 mod1592)) (quote (())) s1590 mod1592)) tmp1610) ((lambda (tmp1622) (if (if tmp1622 (apply (lambda (_1623 name1624) (id?1091 name1624)) tmp1622) #f) (apply (lambda (_1625 name1626) (values (quote define-form) (wrap1119 name1626 w1589 mod1592) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1590 mod1592)) tmp1622) (syntax-error tmp1602))) (syntax-dispatch tmp1602 (quote (any any)))))) (syntax-dispatch tmp1602 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1602 (quote (any any any))))) e1587) (if (memv t1601 (quote (define-syntax))) ((lambda (tmp1627) ((lambda (tmp1628) (if (if tmp1628 (apply (lambda (_1629 name1630 val1631) (id?1091 name1630)) tmp1628) #f) (apply (lambda (_1632 name1633 val1634) (values (quote define-syntax-form) name1633 val1634 w1589 s1590 mod1592)) tmp1628) (syntax-error tmp1627))) (syntax-dispatch tmp1627 (quote (any any any))))) e1587) (values (quote call) #f e1587 w1589 s1590 mod1592)))))))))))))) (values (quote call) #f e1587 w1589 s1590 mod1592)))) ((syntax-object?1075 e1587) (syntax-type1125 (syntax-object-expression1076 e1587) r1588 (join-wraps1110 w1589 (syntax-object-wrap1077 e1587)) #f rib1591 (or (syntax-object-module1078 e1587) mod1592))) ((annotation? e1587) (syntax-type1125 (annotation-expression e1587) r1588 w1589 (annotation-source e1587) rib1591 mod1592)) ((self-evaluating? e1587) (values (quote constant) #f e1587 w1589 s1590 mod1592)) (else (values (quote other) #f e1587 w1589 s1590 mod1592))))) (chi-when-list1124 (lambda (e1635 when-list1636 w1637) (let f1638 ((when-list1639 when-list1636) (situations1640 (quote ()))) (if (null? when-list1639) situations1640 (f1638 (cdr when-list1639) (cons (let ((x1641 (car when-list1639))) (cond ((free-id=?1114 x1641 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1114 x1641 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1114 x1641 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1119 x1641 w1637 #f) "invalid eval-when situation")))) situations1640)))))) (chi-install-global1123 (lambda (name1642 e1643) (build-annotated1068 #f (list (build-annotated1068 #f (quote install-global-transformer)) (build-data1069 #f name1642) e1643)))) (chi-top-sequence1122 (lambda (body1644 r1645 w1646 s1647 m1648 esew1649 mod1650) (build-sequence1070 s1647 (let dobody1651 ((body1652 body1644) (r1653 r1645) (w1654 w1646) (m1655 m1648) (esew1656 esew1649) (mod1657 mod1650)) (if (null? body1652) (quote ()) (let ((first1658 (chi-top1126 (car body1652) r1653 w1654 m1655 esew1656 mod1657))) (cons first1658 (dobody1651 (cdr body1652) r1653 w1654 m1655 esew1656 mod1657)))))))) (chi-sequence1121 (lambda (body1659 r1660 w1661 s1662 mod1663) (build-sequence1070 s1662 (let dobody1664 ((body1665 body1659) (r1666 r1660) (w1667 w1661) (mod1668 mod1663)) (if (null? body1665) (quote ()) (let ((first1669 (chi1127 (car body1665) r1666 w1667 mod1668))) (cons first1669 (dobody1664 (cdr body1665) r1666 w1667 mod1668)))))))) (source-wrap1120 (lambda (x1670 w1671 s1672 defmod1673) (wrap1119 (if s1672 (make-annotation x1670 s1672 #f) x1670) w1671 defmod1673))) (wrap1119 (lambda (x1674 w1675 defmod1676) (cond ((and (null? (wrap-marks1094 w1675)) (null? (wrap-subst1095 w1675))) x1674) ((syntax-object?1075 x1674) (make-syntax-object1074 (syntax-object-expression1076 x1674) (join-wraps1110 w1675 (syntax-object-wrap1077 x1674)) (syntax-object-module1078 x1674))) ((null? x1674) x1674) (else (make-syntax-object1074 x1674 w1675 defmod1676))))) (bound-id-member?1118 (lambda (x1677 list1678) (and (not (null? list1678)) (or (bound-id=?1115 x1677 (car list1678)) (bound-id-member?1118 x1677 (cdr list1678)))))) (distinct-bound-ids?1117 (lambda (ids1679) (let distinct?1680 ((ids1681 ids1679)) (or (null? ids1681) (and (not (bound-id-member?1118 (car ids1681) (cdr ids1681))) (distinct?1680 (cdr ids1681))))))) (valid-bound-ids?1116 (lambda (ids1682) (and (let all-ids?1683 ((ids1684 ids1682)) (or (null? ids1684) (and (id?1091 (car ids1684)) (all-ids?1683 (cdr ids1684))))) (distinct-bound-ids?1117 ids1682)))) (bound-id=?1115 (lambda (i1685 j1686) (if (and (syntax-object?1075 i1685) (syntax-object?1075 j1686)) (and (eq? (let ((e1687 (syntax-object-expression1076 i1685))) (if (annotation? e1687) (annotation-expression e1687) e1687)) (let ((e1688 (syntax-object-expression1076 j1686))) (if (annotation? e1688) (annotation-expression e1688) e1688))) (same-marks?1112 (wrap-marks1094 (syntax-object-wrap1077 i1685)) (wrap-marks1094 (syntax-object-wrap1077 j1686)))) (eq? (let ((e1689 i1685)) (if (annotation? e1689) (annotation-expression e1689) e1689)) (let ((e1690 j1686)) (if (annotation? e1690) (annotation-expression e1690) e1690)))))) (free-id=?1114 (lambda (i1691 j1692) (and (eq? (let ((x1693 i1691)) (let ((e1694 (if (syntax-object?1075 x1693) (syntax-object-expression1076 x1693) x1693))) (if (annotation? e1694) (annotation-expression e1694) e1694))) (let ((x1695 j1692)) (let ((e1696 (if (syntax-object?1075 x1695) (syntax-object-expression1076 x1695) x1695))) (if (annotation? e1696) (annotation-expression e1696) e1696)))) (eq? (id-var-name1113 i1691 (quote (()))) (id-var-name1113 j1692 (quote (()))))))) (id-var-name1113 (lambda (id1697 w1698) (letrec ((search-vector-rib1701 (lambda (sym1707 subst1708 marks1709 symnames1710 ribcage1711) (let ((n1712 (vector-length symnames1710))) (let f1713 ((i1714 0)) (cond ((fx=1061 i1714 n1712) (search1699 sym1707 (cdr subst1708) marks1709)) ((and (eq? (vector-ref symnames1710 i1714) sym1707) (same-marks?1112 marks1709 (vector-ref (ribcage-marks1101 ribcage1711) i1714))) (values (vector-ref (ribcage-labels1102 ribcage1711) i1714) marks1709)) (else (f1713 (fx+1059 i1714 1)))))))) (search-list-rib1700 (lambda (sym1715 subst1716 marks1717 symnames1718 ribcage1719) (let f1720 ((symnames1721 symnames1718) (i1722 0)) (cond ((null? symnames1721) (search1699 sym1715 (cdr subst1716) marks1717)) ((and (eq? (car symnames1721) sym1715) (same-marks?1112 marks1717 (list-ref (ribcage-marks1101 ribcage1719) i1722))) (values (list-ref (ribcage-labels1102 ribcage1719) i1722) marks1717)) (else (f1720 (cdr symnames1721) (fx+1059 i1722 1))))))) (search1699 (lambda (sym1723 subst1724 marks1725) (if (null? subst1724) (values #f marks1725) (let ((fst1726 (car subst1724))) (if (eq? fst1726 (quote shift)) (search1699 sym1723 (cdr subst1724) (cdr marks1725)) (let ((symnames1727 (ribcage-symnames1100 fst1726))) (if (vector? symnames1727) (search-vector-rib1701 sym1723 subst1724 marks1725 symnames1727 fst1726) (search-list-rib1700 sym1723 subst1724 marks1725 symnames1727 fst1726))))))))) (cond ((symbol? id1697) (or (call-with-values (lambda () (search1699 id1697 (wrap-subst1095 w1698) (wrap-marks1094 w1698))) (lambda (x1729 . ignore1728) x1729)) id1697)) ((syntax-object?1075 id1697) (let ((id1730 (let ((e1732 (syntax-object-expression1076 id1697))) (if (annotation? e1732) (annotation-expression e1732) e1732))) (w11731 (syntax-object-wrap1077 id1697))) (let ((marks1733 (join-marks1111 (wrap-marks1094 w1698) (wrap-marks1094 w11731)))) (call-with-values (lambda () (search1699 id1730 (wrap-subst1095 w1698) marks1733)) (lambda (new-id1734 marks1735) (or new-id1734 (call-with-values (lambda () (search1699 id1730 (wrap-subst1095 w11731) marks1735)) (lambda (x1737 . ignore1736) x1737)) id1730)))))) ((annotation? id1697) (let ((id1738 (let ((e1739 id1697)) (if (annotation? e1739) (annotation-expression e1739) e1739)))) (or (call-with-values (lambda () (search1699 id1738 (wrap-subst1095 w1698) (wrap-marks1094 w1698))) (lambda (x1741 . ignore1740) x1741)) id1738))) (else (error-hook1065 (quote id-var-name) "invalid id" id1697)))))) (same-marks?1112 (lambda (x1742 y1743) (or (eq? x1742 y1743) (and (not (null? x1742)) (not (null? y1743)) (eq? (car x1742) (car y1743)) (same-marks?1112 (cdr x1742) (cdr y1743)))))) (join-marks1111 (lambda (m11744 m21745) (smart-append1109 m11744 m21745))) (join-wraps1110 (lambda (w11746 w21747) (let ((m11748 (wrap-marks1094 w11746)) (s11749 (wrap-subst1095 w11746))) (if (null? m11748) (if (null? s11749) w21747 (make-wrap1093 (wrap-marks1094 w21747) (smart-append1109 s11749 (wrap-subst1095 w21747)))) (make-wrap1093 (smart-append1109 m11748 (wrap-marks1094 w21747)) (smart-append1109 s11749 (wrap-subst1095 w21747))))))) (smart-append1109 (lambda (m11750 m21751) (if (null? m21751) m11750 (append m11750 m21751)))) (make-binding-wrap1108 (lambda (ids1752 labels1753 w1754) (if (null? ids1752) w1754 (make-wrap1093 (wrap-marks1094 w1754) (cons (let ((labelvec1755 (list->vector labels1753))) (let ((n1756 (vector-length labelvec1755))) (let ((symnamevec1757 (make-vector n1756)) (marksvec1758 (make-vector n1756))) (begin (let f1759 ((ids1760 ids1752) (i1761 0)) (if (not (null? ids1760)) (call-with-values (lambda () (id-sym-name&marks1092 (car ids1760) w1754)) (lambda (symname1762 marks1763) (begin (vector-set! symnamevec1757 i1761 symname1762) (vector-set! marksvec1758 i1761 marks1763) (f1759 (cdr ids1760) (fx+1059 i1761 1))))))) (make-ribcage1098 symnamevec1757 marksvec1758 labelvec1755))))) (wrap-subst1095 w1754)))))) (extend-ribcage!1107 (lambda (ribcage1764 id1765 label1766) (begin (set-ribcage-symnames!1103 ribcage1764 (cons (let ((e1767 (syntax-object-expression1076 id1765))) (if (annotation? e1767) (annotation-expression e1767) e1767)) (ribcage-symnames1100 ribcage1764))) (set-ribcage-marks!1104 ribcage1764 (cons (wrap-marks1094 (syntax-object-wrap1077 id1765)) (ribcage-marks1101 ribcage1764))) (set-ribcage-labels!1105 ribcage1764 (cons label1766 (ribcage-labels1102 ribcage1764)))))) (anti-mark1106 (lambda (w1768) (make-wrap1093 (cons #f (wrap-marks1094 w1768)) (cons (quote shift) (wrap-subst1095 w1768))))) (set-ribcage-labels!1105 (lambda (x1769 update1770) (vector-set! x1769 3 update1770))) (set-ribcage-marks!1104 (lambda (x1771 update1772) (vector-set! x1771 2 update1772))) (set-ribcage-symnames!1103 (lambda (x1773 update1774) (vector-set! x1773 1 update1774))) (ribcage-labels1102 (lambda (x1775) (vector-ref x1775 3))) (ribcage-marks1101 (lambda (x1776) (vector-ref x1776 2))) (ribcage-symnames1100 (lambda (x1777) (vector-ref x1777 1))) (ribcage?1099 (lambda (x1778) (and (vector? x1778) (= (vector-length x1778) 4) (eq? (vector-ref x1778 0) (quote ribcage))))) (make-ribcage1098 (lambda (symnames1779 marks1780 labels1781) (vector (quote ribcage) symnames1779 marks1780 labels1781))) (gen-labels1097 (lambda (ls1782) (if (null? ls1782) (quote ()) (cons (gen-label1096) (gen-labels1097 (cdr ls1782)))))) (gen-label1096 (lambda () (string #\i))) (wrap-subst1095 cdr) (wrap-marks1094 car) (make-wrap1093 cons) (id-sym-name&marks1092 (lambda (x1783 w1784) (if (syntax-object?1075 x1783) (values (let ((e1785 (syntax-object-expression1076 x1783))) (if (annotation? e1785) (annotation-expression e1785) e1785)) (join-marks1111 (wrap-marks1094 w1784) (wrap-marks1094 (syntax-object-wrap1077 x1783)))) (values (let ((e1786 x1783)) (if (annotation? e1786) (annotation-expression e1786) e1786)) (wrap-marks1094 w1784))))) (id?1091 (lambda (x1787) (cond ((symbol? x1787) #t) ((syntax-object?1075 x1787) (symbol? (let ((e1788 (syntax-object-expression1076 x1787))) (if (annotation? e1788) (annotation-expression e1788) e1788)))) ((annotation? x1787) (symbol? (annotation-expression x1787))) (else #f)))) (nonsymbol-id?1090 (lambda (x1789) (and (syntax-object?1075 x1789) (symbol? (let ((e1790 (syntax-object-expression1076 x1789))) (if (annotation? e1790) (annotation-expression e1790) e1790)))))) (global-extend1089 (lambda (type1791 sym1792 val1793) (put-global-definition-hook1066 sym1792 (cons type1791 val1793) (module-name (current-module))))) (lookup1088 (lambda (x1794 r1795 mod1796) (cond ((assq x1794 r1795) => cdr) ((symbol? x1794) (or (get-global-definition-hook1067 x1794 mod1796) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1087 (lambda (r1797) (if (null? r1797) (quote ()) (let ((a1798 (car r1797))) (if (eq? (cadr a1798) (quote macro)) (cons a1798 (macros-only-env1087 (cdr r1797))) (macros-only-env1087 (cdr r1797))))))) (extend-var-env1086 (lambda (labels1799 vars1800 r1801) (if (null? labels1799) r1801 (extend-var-env1086 (cdr labels1799) (cdr vars1800) (cons (cons (car labels1799) (cons (quote lexical) (car vars1800))) r1801))))) (extend-env1085 (lambda (labels1802 bindings1803 r1804) (if (null? labels1802) r1804 (extend-env1085 (cdr labels1802) (cdr bindings1803) (cons (cons (car labels1802) (car bindings1803)) r1804))))) (binding-value1084 cdr) (binding-type1083 car) (source-annotation1082 (lambda (x1805) (cond ((annotation? x1805) (annotation-source x1805)) ((syntax-object?1075 x1805) (source-annotation1082 (syntax-object-expression1076 x1805))) (else #f)))) (set-syntax-object-module!1081 (lambda (x1806 update1807) (vector-set! x1806 3 update1807))) (set-syntax-object-wrap!1080 (lambda (x1808 update1809) (vector-set! x1808 2 update1809))) (set-syntax-object-expression!1079 (lambda (x1810 update1811) (vector-set! x1810 1 update1811))) (syntax-object-module1078 (lambda (x1812) (vector-ref x1812 3))) (syntax-object-wrap1077 (lambda (x1813) (vector-ref x1813 2))) (syntax-object-expression1076 (lambda (x1814) (vector-ref x1814 1))) (syntax-object?1075 (lambda (x1815) (and (vector? x1815) (= (vector-length x1815) 4) (eq? (vector-ref x1815 0) (quote syntax-object))))) (make-syntax-object1074 (lambda (expression1816 wrap1817 module1818) (vector (quote syntax-object) expression1816 wrap1817 module1818))) (build-letrec1073 (lambda (src1819 vars1820 val-exps1821 body-exp1822) (if (null? vars1820) (build-annotated1068 src1819 body-exp1822) (build-annotated1068 src1819 (list (quote letrec) (map list vars1820 val-exps1821) body-exp1822))))) (build-named-let1072 (lambda (src1823 vars1824 val-exps1825 body-exp1826) (if (null? vars1824) (build-annotated1068 src1823 body-exp1826) (build-annotated1068 src1823 (list (quote let) (car vars1824) (map list (cdr vars1824) val-exps1825) body-exp1826))))) (build-let1071 (lambda (src1827 vars1828 val-exps1829 body-exp1830) (if (null? vars1828) (build-annotated1068 src1827 body-exp1830) (build-annotated1068 src1827 (list (quote let) (map list vars1828 val-exps1829) body-exp1830))))) (build-sequence1070 (lambda (src1831 exps1832) (if (null? (cdr exps1832)) (build-annotated1068 src1831 (car exps1832)) (build-annotated1068 src1831 (cons (quote begin) exps1832))))) (build-data1069 (lambda (src1833 exp1834) (if (and (self-evaluating? exp1834) (not (vector? exp1834))) (build-annotated1068 src1833 exp1834) (build-annotated1068 src1833 (list (quote quote) exp1834))))) (build-annotated1068 (lambda (src1835 exp1836) (if (and src1835 (not (annotation? exp1836))) (make-annotation exp1836 src1835 #t) exp1836))) (get-global-definition-hook1067 (lambda (symbol1837 module1838) (let ((module1839 (if module1838 (resolve-module module1838) (warn "wha" symbol1837 (current-module))))) (let ((v1840 (module-variable module1839 symbol1837))) (and v1840 (or (object-property v1840 (quote *sc-expander*)) (and (variable-bound? v1840) (macro? (variable-ref v1840)) (macro-transformer (variable-ref v1840)) guile-macro))))))) (put-global-definition-hook1066 (lambda (symbol1841 binding1842 modname1843) (let ((module1844 (if modname1843 (resolve-module modname1843) (current-module)))) (let ((v1845 (or (module-variable module1844 symbol1841) (let ((v1846 (make-variable (quote sc-macro)))) (begin (module-add! module1844 symbol1841 v1846) v1846))))) (begin (if (not (variable-bound? v1845)) (variable-set! v1845 (gensym))) (set-object-property! v1845 (quote *sc-expander*) binding1842)))))) (error-hook1065 (lambda (who1847 why1848 what1849) (error who1847 "~a ~s" why1848 what1849))) (local-eval-hook1064 (lambda (x1850 mod1851) (eval (list noexpand1058 x1850) (if mod1851 (resolve-module mod1851) (interaction-environment))))) (top-level-eval-hook1063 (lambda (x1852 mod1853) (eval (list noexpand1058 x1852) (if mod1853 (resolve-module mod1853) (interaction-environment))))) (fx<1062 <) (fx=1061 =) (fx-1060 -) (fx+1059 +) (noexpand1058 "noexpand")) (begin (global-extend1089 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1089 (quote local-syntax) (quote let-syntax) #f) (global-extend1089 (quote core) (quote fluid-let-syntax) (lambda (e1854 r1855 w1856 s1857 mod1858) ((lambda (tmp1859) ((lambda (tmp1860) (if (if tmp1860 (apply (lambda (_1861 var1862 val1863 e11864 e21865) (valid-bound-ids?1116 var1862)) tmp1860) #f) (apply (lambda (_1867 var1868 val1869 e11870 e21871) (let ((names1872 (map (lambda (x1873) (id-var-name1113 x1873 w1856)) var1868))) (begin (for-each (lambda (id1875 n1876) (let ((t1877 (binding-type1083 (lookup1088 n1876 r1855 mod1858)))) (if (memv t1877 (quote (displaced-lexical))) (syntax-error (source-wrap1120 id1875 w1856 s1857 mod1858) "identifier out of context")))) var1868 names1872) (chi-body1131 (cons e11870 e21871) (source-wrap1120 e1854 w1856 s1857 mod1858) (extend-env1085 names1872 (let ((trans-r1880 (macros-only-env1087 r1855))) (map (lambda (x1881) (cons (quote macro) (eval-local-transformer1134 (chi1127 x1881 trans-r1880 w1856 mod1858) mod1858))) val1869)) r1855) w1856 mod1858)))) tmp1860) ((lambda (_1883) (syntax-error (source-wrap1120 e1854 w1856 s1857 mod1858))) tmp1859))) (syntax-dispatch tmp1859 (quote (any #(each (any any)) any . each-any))))) e1854))) (global-extend1089 (quote core) (quote quote) (lambda (e1884 r1885 w1886 s1887 mod1888) ((lambda (tmp1889) ((lambda (tmp1890) (if tmp1890 (apply (lambda (_1891 e1892) (build-data1069 s1887 (strip1138 e1892 w1886))) tmp1890) ((lambda (_1893) (syntax-error (source-wrap1120 e1884 w1886 s1887 mod1888))) tmp1889))) (syntax-dispatch tmp1889 (quote (any any))))) e1884))) (global-extend1089 (quote core) (quote syntax) (letrec ((regen1901 (lambda (x1902) (let ((t1903 (car x1902))) (if (memv t1903 (quote (ref))) (build-annotated1068 #f (cadr x1902)) (if (memv t1903 (quote (primitive))) (build-annotated1068 #f (cadr x1902)) (if (memv t1903 (quote (quote))) (build-data1069 #f (cadr x1902)) (if (memv t1903 (quote (lambda))) (build-annotated1068 #f (list (quote lambda) (cadr x1902) (regen1901 (caddr x1902)))) (if (memv t1903 (quote (map))) (let ((ls1904 (map regen1901 (cdr x1902)))) (build-annotated1068 #f (cons (if (fx=1061 (length ls1904) 2) (build-annotated1068 #f (quote map)) (build-annotated1068 #f (quote map))) ls1904))) (build-annotated1068 #f (cons (build-annotated1068 #f (car x1902)) (map regen1901 (cdr x1902)))))))))))) (gen-vector1900 (lambda (x1905) (cond ((eq? (car x1905) (quote list)) (cons (quote vector) (cdr x1905))) ((eq? (car x1905) (quote quote)) (list (quote quote) (list->vector (cadr x1905)))) (else (list (quote list->vector) x1905))))) (gen-append1899 (lambda (x1906 y1907) (if (equal? y1907 (quote (quote ()))) x1906 (list (quote append) x1906 y1907)))) (gen-cons1898 (lambda (x1908 y1909) (let ((t1910 (car y1909))) (if (memv t1910 (quote (quote))) (if (eq? (car x1908) (quote quote)) (list (quote quote) (cons (cadr x1908) (cadr y1909))) (if (eq? (cadr y1909) (quote ())) (list (quote list) x1908) (list (quote cons) x1908 y1909))) (if (memv t1910 (quote (list))) (cons (quote list) (cons x1908 (cdr y1909))) (list (quote cons) x1908 y1909)))))) (gen-map1897 (lambda (e1911 map-env1912) (let ((formals1913 (map cdr map-env1912)) (actuals1914 (map (lambda (x1915) (list (quote ref) (car x1915))) map-env1912))) (cond ((eq? (car e1911) (quote ref)) (car actuals1914)) ((andmap (lambda (x1916) (and (eq? (car x1916) (quote ref)) (memq (cadr x1916) formals1913))) (cdr e1911)) (cons (quote map) (cons (list (quote primitive) (car e1911)) (map (let ((r1917 (map cons formals1913 actuals1914))) (lambda (x1918) (cdr (assq (cadr x1918) r1917)))) (cdr e1911))))) (else (cons (quote map) (cons (list (quote lambda) formals1913 e1911) actuals1914))))))) (gen-mappend1896 (lambda (e1919 map-env1920) (list (quote apply) (quote (primitive append)) (gen-map1897 e1919 map-env1920)))) (gen-ref1895 (lambda (src1921 var1922 level1923 maps1924) (if (fx=1061 level1923 0) (values var1922 maps1924) (if (null? maps1924) (syntax-error src1921 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1895 src1921 var1922 (fx-1060 level1923 1) (cdr maps1924))) (lambda (outer-var1925 outer-maps1926) (let ((b1927 (assq outer-var1925 (car maps1924)))) (if b1927 (values (cdr b1927) maps1924) (let ((inner-var1928 (gen-var1139 (quote tmp)))) (values inner-var1928 (cons (cons (cons outer-var1925 inner-var1928) (car maps1924)) outer-maps1926))))))))))) (gen-syntax1894 (lambda (src1929 e1930 r1931 maps1932 ellipsis?1933 mod1934) (if (id?1091 e1930) (let ((label1935 (id-var-name1113 e1930 (quote (()))))) (let ((b1936 (lookup1088 label1935 r1931 mod1934))) (if (eq? (binding-type1083 b1936) (quote syntax)) (call-with-values (lambda () (let ((var.lev1937 (binding-value1084 b1936))) (gen-ref1895 src1929 (car var.lev1937) (cdr var.lev1937) maps1932))) (lambda (var1938 maps1939) (values (list (quote ref) var1938) maps1939))) (if (ellipsis?1933 e1930) (syntax-error src1929 "misplaced ellipsis in syntax form") (values (list (quote quote) e1930) maps1932))))) ((lambda (tmp1940) ((lambda (tmp1941) (if (if tmp1941 (apply (lambda (dots1942 e1943) (ellipsis?1933 dots1942)) tmp1941) #f) (apply (lambda (dots1944 e1945) (gen-syntax1894 src1929 e1945 r1931 maps1932 (lambda (x1946) #f) mod1934)) tmp1941) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (x1948 dots1949 y1950) (ellipsis?1933 dots1949)) tmp1947) #f) (apply (lambda (x1951 dots1952 y1953) (let f1954 ((y1955 y1953) (k1956 (lambda (maps1957) (call-with-values (lambda () (gen-syntax1894 src1929 x1951 r1931 (cons (quote ()) maps1957) ellipsis?1933 mod1934)) (lambda (x1958 maps1959) (if (null? (car maps1959)) (syntax-error src1929 "extra ellipsis in syntax form") (values (gen-map1897 x1958 (car maps1959)) (cdr maps1959)))))))) ((lambda (tmp1960) ((lambda (tmp1961) (if (if tmp1961 (apply (lambda (dots1962 y1963) (ellipsis?1933 dots1962)) tmp1961) #f) (apply (lambda (dots1964 y1965) (f1954 y1965 (lambda (maps1966) (call-with-values (lambda () (k1956 (cons (quote ()) maps1966))) (lambda (x1967 maps1968) (if (null? (car maps1968)) (syntax-error src1929 "extra ellipsis in syntax form") (values (gen-mappend1896 x1967 (car maps1968)) (cdr maps1968)))))))) tmp1961) ((lambda (_1969) (call-with-values (lambda () (gen-syntax1894 src1929 y1955 r1931 maps1932 ellipsis?1933 mod1934)) (lambda (y1970 maps1971) (call-with-values (lambda () (k1956 maps1971)) (lambda (x1972 maps1973) (values (gen-append1899 x1972 y1970) maps1973)))))) tmp1960))) (syntax-dispatch tmp1960 (quote (any . any))))) y1955))) tmp1947) ((lambda (tmp1974) (if tmp1974 (apply (lambda (x1975 y1976) (call-with-values (lambda () (gen-syntax1894 src1929 x1975 r1931 maps1932 ellipsis?1933 mod1934)) (lambda (x1977 maps1978) (call-with-values (lambda () (gen-syntax1894 src1929 y1976 r1931 maps1978 ellipsis?1933 mod1934)) (lambda (y1979 maps1980) (values (gen-cons1898 x1977 y1979) maps1980)))))) tmp1974) ((lambda (tmp1981) (if tmp1981 (apply (lambda (e11982 e21983) (call-with-values (lambda () (gen-syntax1894 src1929 (cons e11982 e21983) r1931 maps1932 ellipsis?1933 mod1934)) (lambda (e1985 maps1986) (values (gen-vector1900 e1985) maps1986)))) tmp1981) ((lambda (_1987) (values (list (quote quote) e1930) maps1932)) tmp1940))) (syntax-dispatch tmp1940 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1940 (quote (any . any)))))) (syntax-dispatch tmp1940 (quote (any any . any)))))) (syntax-dispatch tmp1940 (quote (any any))))) e1930))))) (lambda (e1988 r1989 w1990 s1991 mod1992) (let ((e1993 (source-wrap1120 e1988 w1990 s1991 mod1992))) ((lambda (tmp1994) ((lambda (tmp1995) (if tmp1995 (apply (lambda (_1996 x1997) (call-with-values (lambda () (gen-syntax1894 e1993 x1997 r1989 (quote ()) ellipsis?1136 mod1992)) (lambda (e1998 maps1999) (regen1901 e1998)))) tmp1995) ((lambda (_2000) (syntax-error e1993)) tmp1994))) (syntax-dispatch tmp1994 (quote (any any))))) e1993))))) (global-extend1089 (quote core) (quote lambda) (lambda (e2001 r2002 w2003 s2004 mod2005) ((lambda (tmp2006) ((lambda (tmp2007) (if tmp2007 (apply (lambda (_2008 c2009) (chi-lambda-clause1132 (source-wrap1120 e2001 w2003 s2004 mod2005) c2009 r2002 w2003 mod2005 (lambda (vars2010 body2011) (build-annotated1068 s2004 (list (quote lambda) vars2010 body2011))))) tmp2007) (syntax-error tmp2006))) (syntax-dispatch tmp2006 (quote (any . any))))) e2001))) (global-extend1089 (quote core) (quote let) (letrec ((chi-let2012 (lambda (e2013 r2014 w2015 s2016 mod2017 constructor2018 ids2019 vals2020 exps2021) (if (not (valid-bound-ids?1116 ids2019)) (syntax-error e2013 "duplicate bound variable in") (let ((labels2022 (gen-labels1097 ids2019)) (new-vars2023 (map gen-var1139 ids2019))) (let ((nw2024 (make-binding-wrap1108 ids2019 labels2022 w2015)) (nr2025 (extend-var-env1086 labels2022 new-vars2023 r2014))) (constructor2018 s2016 new-vars2023 (map (lambda (x2026) (chi1127 x2026 r2014 w2015 mod2017)) vals2020) (chi-body1131 exps2021 (source-wrap1120 e2013 nw2024 s2016 mod2017) nr2025 nw2024 mod2017)))))))) (lambda (e2027 r2028 w2029 s2030 mod2031) ((lambda (tmp2032) ((lambda (tmp2033) (if tmp2033 (apply (lambda (_2034 id2035 val2036 e12037 e22038) (chi-let2012 e2027 r2028 w2029 s2030 mod2031 build-let1071 id2035 val2036 (cons e12037 e22038))) tmp2033) ((lambda (tmp2042) (if (if tmp2042 (apply (lambda (_2043 f2044 id2045 val2046 e12047 e22048) (id?1091 f2044)) tmp2042) #f) (apply (lambda (_2049 f2050 id2051 val2052 e12053 e22054) (chi-let2012 e2027 r2028 w2029 s2030 mod2031 build-named-let1072 (cons f2050 id2051) val2052 (cons e12053 e22054))) tmp2042) ((lambda (_2058) (syntax-error (source-wrap1120 e2027 w2029 s2030 mod2031))) tmp2032))) (syntax-dispatch tmp2032 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2032 (quote (any #(each (any any)) any . each-any))))) e2027)))) (global-extend1089 (quote core) (quote letrec) (lambda (e2059 r2060 w2061 s2062 mod2063) ((lambda (tmp2064) ((lambda (tmp2065) (if tmp2065 (apply (lambda (_2066 id2067 val2068 e12069 e22070) (let ((ids2071 id2067)) (if (not (valid-bound-ids?1116 ids2071)) (syntax-error e2059 "duplicate bound variable in") (let ((labels2073 (gen-labels1097 ids2071)) (new-vars2074 (map gen-var1139 ids2071))) (let ((w2075 (make-binding-wrap1108 ids2071 labels2073 w2061)) (r2076 (extend-var-env1086 labels2073 new-vars2074 r2060))) (build-letrec1073 s2062 new-vars2074 (map (lambda (x2077) (chi1127 x2077 r2076 w2075 mod2063)) val2068) (chi-body1131 (cons e12069 e22070) (source-wrap1120 e2059 w2075 s2062 mod2063) r2076 w2075 mod2063))))))) tmp2065) ((lambda (_2080) (syntax-error (source-wrap1120 e2059 w2061 s2062 mod2063))) tmp2064))) (syntax-dispatch tmp2064 (quote (any #(each (any any)) any . each-any))))) e2059))) (global-extend1089 (quote core) (quote set!) (lambda (e2081 r2082 w2083 s2084 mod2085) ((lambda (tmp2086) ((lambda (tmp2087) (if (if tmp2087 (apply (lambda (_2088 id2089 val2090) (id?1091 id2089)) tmp2087) #f) (apply (lambda (_2091 id2092 val2093) (let ((val2094 (chi1127 val2093 r2082 w2083 mod2085)) (n2095 (id-var-name1113 id2092 w2083))) (let ((b2096 (lookup1088 n2095 r2082 mod2085))) (let ((t2097 (binding-type1083 b2096))) (if (memv t2097 (quote (lexical))) (build-annotated1068 s2084 (list (quote set!) (binding-value1084 b2096) val2094)) (if (memv t2097 (quote (global))) (build-annotated1068 s2084 (list (quote set!) (make-module-ref mod2085 n2095 #f) val2094)) (if (memv t2097 (quote (displaced-lexical))) (syntax-error (wrap1119 id2092 w2083 mod2085) "identifier out of context") (syntax-error (source-wrap1120 e2081 w2083 s2084 mod2085))))))))) tmp2087) ((lambda (tmp2098) (if tmp2098 (apply (lambda (_2099 head2100 tail2101 val2102) (call-with-values (lambda () (syntax-type1125 head2100 r2082 (quote (())) #f #f mod2085)) (lambda (type2103 value2104 ee2105 ww2106 ss2107 modmod2108) (let ((t2109 type2103)) (if (memv t2109 (quote (module-ref))) (call-with-values (lambda () (value2104 (cons head2100 tail2101))) (lambda (id2111 mod2112) (build-annotated1068 s2084 (list (quote set!) (make-module-ref mod2112 id2111 #f) val2102)))) (build-annotated1068 s2084 (cons (chi1127 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2100) r2082 w2083 mod2085) (map (lambda (e2113) (chi1127 e2113 r2082 w2083 mod2085)) (append tail2101 (list val2102)))))))))) tmp2098) ((lambda (_2115) (syntax-error (source-wrap1120 e2081 w2083 s2084 mod2085))) tmp2086))) (syntax-dispatch tmp2086 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2086 (quote (any any any))))) e2081))) (global-extend1089 (quote module-ref) (quote @) (lambda (e2116) ((lambda (tmp2117) ((lambda (tmp2118) (if (if tmp2118 (apply (lambda (_2119 mod2120 id2121) (and (andmap id?1091 mod2120) (id?1091 id2121))) tmp2118) #f) (apply (lambda (_2123 mod2124 id2125) (values (syntax-object->datum id2125) (syntax-object->datum (append mod2124 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) tmp2118) (syntax-error tmp2117))) (syntax-dispatch tmp2117 (quote (any each-any any))))) e2116))) (global-extend1089 (quote module-ref) (quote @@) (lambda (e2127) ((lambda (tmp2128) ((lambda (tmp2129) (if (if tmp2129 (apply (lambda (_2130 mod2131 id2132) (and (andmap id?1091 mod2131) (id?1091 id2132))) tmp2129) #f) (apply (lambda (_2134 mod2135 id2136) (values (syntax-object->datum id2136) (syntax-object->datum mod2135))) tmp2129) (syntax-error tmp2128))) (syntax-dispatch tmp2128 (quote (any each-any any))))) e2127))) (global-extend1089 (quote begin) (quote begin) (quote ())) (global-extend1089 (quote define) (quote define) (quote ())) (global-extend1089 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1089 (quote eval-when) (quote eval-when) (quote ())) (global-extend1089 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2141 (lambda (x2142 keys2143 clauses2144 r2145 mod2146) (if (null? clauses2144) (build-annotated1068 #f (list (build-annotated1068 #f (quote syntax-error)) x2142)) ((lambda (tmp2147) ((lambda (tmp2148) (if tmp2148 (apply (lambda (pat2149 exp2150) (if (and (id?1091 pat2149) (andmap (lambda (x2151) (not (free-id=?1114 pat2149 x2151))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2143))) (let ((labels2152 (list (gen-label1096))) (var2153 (gen-var1139 pat2149))) (build-annotated1068 #f (list (build-annotated1068 #f (list (quote lambda) (list var2153) (chi1127 exp2150 (extend-env1085 labels2152 (list (cons (quote syntax) (cons var2153 0))) r2145) (make-binding-wrap1108 (list pat2149) labels2152 (quote (()))) mod2146))) x2142))) (gen-clause2140 x2142 keys2143 (cdr clauses2144) r2145 pat2149 #t exp2150 mod2146))) tmp2148) ((lambda (tmp2154) (if tmp2154 (apply (lambda (pat2155 fender2156 exp2157) (gen-clause2140 x2142 keys2143 (cdr clauses2144) r2145 pat2155 fender2156 exp2157 mod2146)) tmp2154) ((lambda (_2158) (syntax-error (car clauses2144) "invalid syntax-case clause")) tmp2147))) (syntax-dispatch tmp2147 (quote (any any any)))))) (syntax-dispatch tmp2147 (quote (any any))))) (car clauses2144))))) (gen-clause2140 (lambda (x2159 keys2160 clauses2161 r2162 pat2163 fender2164 exp2165 mod2166) (call-with-values (lambda () (convert-pattern2138 pat2163 keys2160)) (lambda (p2167 pvars2168) (cond ((not (distinct-bound-ids?1117 (map car pvars2168))) (syntax-error pat2163 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2169) (not (ellipsis?1136 (car x2169)))) pvars2168)) (syntax-error pat2163 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2170 (gen-var1139 (quote tmp)))) (build-annotated1068 #f (list (build-annotated1068 #f (list (quote lambda) (list y2170) (let ((y2171 (build-annotated1068 #f y2170))) (build-annotated1068 #f (list (quote if) ((lambda (tmp2172) ((lambda (tmp2173) (if tmp2173 (apply (lambda () y2171) tmp2173) ((lambda (_2174) (build-annotated1068 #f (list (quote if) y2171 (build-dispatch-call2139 pvars2168 fender2164 y2171 r2162 mod2166) (build-data1069 #f #f)))) tmp2172))) (syntax-dispatch tmp2172 (quote #(atom #t))))) fender2164) (build-dispatch-call2139 pvars2168 exp2165 y2171 r2162 mod2166) (gen-syntax-case2141 x2159 keys2160 clauses2161 r2162 mod2166)))))) (if (eq? p2167 (quote any)) (build-annotated1068 #f (list (build-annotated1068 #f (quote list)) x2159)) (build-annotated1068 #f (list (build-annotated1068 #f (quote syntax-dispatch)) x2159 (build-data1069 #f p2167))))))))))))) (build-dispatch-call2139 (lambda (pvars2175 exp2176 y2177 r2178 mod2179) (let ((ids2180 (map car pvars2175)) (levels2181 (map cdr pvars2175))) (let ((labels2182 (gen-labels1097 ids2180)) (new-vars2183 (map gen-var1139 ids2180))) (build-annotated1068 #f (list (build-annotated1068 #f (quote apply)) (build-annotated1068 #f (list (quote lambda) new-vars2183 (chi1127 exp2176 (extend-env1085 labels2182 (map (lambda (var2184 level2185) (cons (quote syntax) (cons var2184 level2185))) new-vars2183 (map cdr pvars2175)) r2178) (make-binding-wrap1108 ids2180 labels2182 (quote (()))) mod2179))) y2177)))))) (convert-pattern2138 (lambda (pattern2186 keys2187) (let cvt2188 ((p2189 pattern2186) (n2190 0) (ids2191 (quote ()))) (if (id?1091 p2189) (if (bound-id-member?1118 p2189 keys2187) (values (vector (quote free-id) p2189) ids2191) (values (quote any) (cons (cons p2189 n2190) ids2191))) ((lambda (tmp2192) ((lambda (tmp2193) (if (if tmp2193 (apply (lambda (x2194 dots2195) (ellipsis?1136 dots2195)) tmp2193) #f) (apply (lambda (x2196 dots2197) (call-with-values (lambda () (cvt2188 x2196 (fx+1059 n2190 1) ids2191)) (lambda (p2198 ids2199) (values (if (eq? p2198 (quote any)) (quote each-any) (vector (quote each) p2198)) ids2199)))) tmp2193) ((lambda (tmp2200) (if tmp2200 (apply (lambda (x2201 y2202) (call-with-values (lambda () (cvt2188 y2202 n2190 ids2191)) (lambda (y2203 ids2204) (call-with-values (lambda () (cvt2188 x2201 n2190 ids2204)) (lambda (x2205 ids2206) (values (cons x2205 y2203) ids2206)))))) tmp2200) ((lambda (tmp2207) (if tmp2207 (apply (lambda () (values (quote ()) ids2191)) tmp2207) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209) (call-with-values (lambda () (cvt2188 x2209 n2190 ids2191)) (lambda (p2211 ids2212) (values (vector (quote vector) p2211) ids2212)))) tmp2208) ((lambda (x2213) (values (vector (quote atom) (strip1138 p2189 (quote (())))) ids2191)) tmp2192))) (syntax-dispatch tmp2192 (quote #(vector each-any)))))) (syntax-dispatch tmp2192 (quote ()))))) (syntax-dispatch tmp2192 (quote (any . any)))))) (syntax-dispatch tmp2192 (quote (any any))))) p2189)))))) (lambda (e2214 r2215 w2216 s2217 mod2218) (let ((e2219 (source-wrap1120 e2214 w2216 s2217 mod2218))) ((lambda (tmp2220) ((lambda (tmp2221) (if tmp2221 (apply (lambda (_2222 val2223 key2224 m2225) (if (andmap (lambda (x2226) (and (id?1091 x2226) (not (ellipsis?1136 x2226)))) key2224) (let ((x2228 (gen-var1139 (quote tmp)))) (build-annotated1068 s2217 (list (build-annotated1068 #f (list (quote lambda) (list x2228) (gen-syntax-case2141 (build-annotated1068 #f x2228) key2224 m2225 r2215 mod2218))) (chi1127 val2223 r2215 (quote (())) mod2218)))) (syntax-error e2219 "invalid literals list in"))) tmp2221) (syntax-error tmp2220))) (syntax-dispatch tmp2220 (quote (any any each-any . each-any))))) e2219))))) (set! sc-expand (let ((m2231 (quote e)) (esew2232 (quote (eval)))) (lambda (x2233) (if (and (pair? x2233) (equal? (car x2233) noexpand1058)) (cadr x2233) (chi-top1126 x2233 (quote ()) (quote ((top))) m2231 esew2232 (module-name (current-module))))))) (set! sc-expand3 (let ((m2234 (quote e)) (esew2235 (quote (eval)))) (lambda (x2237 . rest2236) (if (and (pair? x2237) (equal? (car x2237) noexpand1058)) (cadr x2237) (chi-top1126 x2237 (quote ()) (quote ((top))) (if (null? rest2236) m2234 (car rest2236)) (if (or (null? rest2236) (null? (cdr rest2236))) esew2235 (cadr rest2236)) (module-name (current-module))))))) (set! identifier? (lambda (x2238) (nonsymbol-id?1090 x2238))) (set! datum->syntax-object (lambda (id2239 datum2240) (make-syntax-object1074 datum2240 (syntax-object-wrap1077 id2239) #f))) (set! syntax-object->datum (lambda (x2241) (strip1138 x2241 (quote (()))))) (set! generate-temporaries (lambda (ls2242) (begin (let ((x2243 ls2242)) (if (not (list? x2243)) (error-hook1065 (quote generate-temporaries) "invalid argument" x2243))) (map (lambda (x2244) (wrap1119 (gensym) (quote ((top))) #f)) ls2242)))) (set! free-identifier=? (lambda (x2245 y2246) (begin (let ((x2247 x2245)) (if (not (nonsymbol-id?1090 x2247)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2247))) (let ((x2248 y2246)) (if (not (nonsymbol-id?1090 x2248)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2248))) (free-id=?1114 x2245 y2246)))) (set! bound-identifier=? (lambda (x2249 y2250) (begin (let ((x2251 x2249)) (if (not (nonsymbol-id?1090 x2251)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2251))) (let ((x2252 y2250)) (if (not (nonsymbol-id?1090 x2252)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2252))) (bound-id=?1115 x2249 y2250)))) (set! syntax-error (lambda (object2254 . messages2253) (begin (for-each (lambda (x2255) (let ((x2256 x2255)) (if (not (string? x2256)) (error-hook1065 (quote syntax-error) "invalid argument" x2256)))) messages2253) (let ((message2257 (if (null? messages2253) "invalid syntax" (apply string-append messages2253)))) (error-hook1065 #f message2257 (strip1138 object2254 (quote (())))))))) (set! install-global-transformer (lambda (sym2258 v2259) (begin (let ((x2260 sym2258)) (if (not (symbol? x2260)) (error-hook1065 (quote define-syntax) "invalid argument" x2260))) (let ((x2261 v2259)) (if (not (procedure? x2261)) (error-hook1065 (quote define-syntax) "invalid argument" x2261))) (global-extend1089 (quote macro) sym2258 v2259)))) (letrec ((match2266 (lambda (e2267 p2268 w2269 r2270 mod2271) (cond ((not r2270) #f) ((eq? p2268 (quote any)) (cons (wrap1119 e2267 w2269 mod2271) r2270)) ((syntax-object?1075 e2267) (match*2265 (let ((e2272 (syntax-object-expression1076 e2267))) (if (annotation? e2272) (annotation-expression e2272) e2272)) p2268 (join-wraps1110 w2269 (syntax-object-wrap1077 e2267)) r2270 (syntax-object-module1078 e2267))) (else (match*2265 (let ((e2273 e2267)) (if (annotation? e2273) (annotation-expression e2273) e2273)) p2268 w2269 r2270 mod2271))))) (match*2265 (lambda (e2274 p2275 w2276 r2277 mod2278) (cond ((null? p2275) (and (null? e2274) r2277)) ((pair? p2275) (and (pair? e2274) (match2266 (car e2274) (car p2275) w2276 (match2266 (cdr e2274) (cdr p2275) w2276 r2277 mod2278) mod2278))) ((eq? p2275 (quote each-any)) (let ((l2279 (match-each-any2263 e2274 w2276 mod2278))) (and l2279 (cons l2279 r2277)))) (else (let ((t2280 (vector-ref p2275 0))) (if (memv t2280 (quote (each))) (if (null? e2274) (match-empty2264 (vector-ref p2275 1) r2277) (let ((l2281 (match-each2262 e2274 (vector-ref p2275 1) w2276 mod2278))) (and l2281 (let collect2282 ((l2283 l2281)) (if (null? (car l2283)) r2277 (cons (map car l2283) (collect2282 (map cdr l2283)))))))) (if (memv t2280 (quote (free-id))) (and (id?1091 e2274) (free-id=?1114 (wrap1119 e2274 w2276 mod2278) (vector-ref p2275 1)) r2277) (if (memv t2280 (quote (atom))) (and (equal? (vector-ref p2275 1) (strip1138 e2274 w2276)) r2277) (if (memv t2280 (quote (vector))) (and (vector? e2274) (match2266 (vector->list e2274) (vector-ref p2275 1) w2276 r2277 mod2278))))))))))) (match-empty2264 (lambda (p2284 r2285) (cond ((null? p2284) r2285) ((eq? p2284 (quote any)) (cons (quote ()) r2285)) ((pair? p2284) (match-empty2264 (car p2284) (match-empty2264 (cdr p2284) r2285))) ((eq? p2284 (quote each-any)) (cons (quote ()) r2285)) (else (let ((t2286 (vector-ref p2284 0))) (if (memv t2286 (quote (each))) (match-empty2264 (vector-ref p2284 1) r2285) (if (memv t2286 (quote (free-id atom))) r2285 (if (memv t2286 (quote (vector))) (match-empty2264 (vector-ref p2284 1) r2285))))))))) (match-each-any2263 (lambda (e2287 w2288 mod2289) (cond ((annotation? e2287) (match-each-any2263 (annotation-expression e2287) w2288 mod2289)) ((pair? e2287) (let ((l2290 (match-each-any2263 (cdr e2287) w2288 mod2289))) (and l2290 (cons (wrap1119 (car e2287) w2288 mod2289) l2290)))) ((null? e2287) (quote ())) ((syntax-object?1075 e2287) (match-each-any2263 (syntax-object-expression1076 e2287) (join-wraps1110 w2288 (syntax-object-wrap1077 e2287)) mod2289)) (else #f)))) (match-each2262 (lambda (e2291 p2292 w2293 mod2294) (cond ((annotation? e2291) (match-each2262 (annotation-expression e2291) p2292 w2293 mod2294)) ((pair? e2291) (let ((first2295 (match2266 (car e2291) p2292 w2293 (quote ()) mod2294))) (and first2295 (let ((rest2296 (match-each2262 (cdr e2291) p2292 w2293 mod2294))) (and rest2296 (cons first2295 rest2296)))))) ((null? e2291) (quote ())) ((syntax-object?1075 e2291) (match-each2262 (syntax-object-expression1076 e2291) p2292 (join-wraps1110 w2293 (syntax-object-wrap1077 e2291)) (syntax-object-module1078 e2291))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2297 p2298) (cond ((eq? p2298 (quote any)) (list e2297)) ((syntax-object?1075 e2297) (match*2265 (let ((e2299 (syntax-object-expression1076 e2297))) (if (annotation? e2299) (annotation-expression e2299) e2299)) p2298 (syntax-object-wrap1077 e2297) (quote ()) (syntax-object-module1078 e2297))) (else (match*2265 (let ((e2300 e2297)) (if (annotation? e2300) (annotation-expression e2300) e2300)) p2298 (quote (())) (quote ()) #f))))) (set! sc-chi chi1127))))) +(install-global-transformer (quote with-syntax) (lambda (x2301) ((lambda (tmp2302) ((lambda (tmp2303) (if tmp2303 (apply (lambda (_2304 e12305 e22306) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12305 e22306))) tmp2303) ((lambda (tmp2308) (if tmp2308 (apply (lambda (_2309 out2310 in2311 e12312 e22313) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2311 (quote ()) (list out2310 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12312 e22313))))) tmp2308) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 out2317 in2318 e12319 e22320) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2318) (quote ()) (list out2317 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12319 e22320))))) tmp2315) (syntax-error tmp2302))) (syntax-dispatch tmp2302 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2302 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2302 (quote (any () any . each-any))))) x2301))) +(install-global-transformer (quote syntax-rules) (lambda (x2324) ((lambda (tmp2325) ((lambda (tmp2326) (if tmp2326 (apply (lambda (_2327 k2328 keyword2329 pattern2330 template2331) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2328 (map (lambda (tmp2334 tmp2333) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2333) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2334))) template2331 pattern2330)))))) tmp2326) (syntax-error tmp2325))) (syntax-dispatch tmp2325 (quote (any each-any . #(each ((any . any) any))))))) x2324))) +(install-global-transformer (quote let*) (lambda (x2335) ((lambda (tmp2336) ((lambda (tmp2337) (if (if tmp2337 (apply (lambda (let*2338 x2339 v2340 e12341 e22342) (andmap identifier? x2339)) tmp2337) #f) (apply (lambda (let*2344 x2345 v2346 e12347 e22348) (let f2349 ((bindings2350 (map list x2345 v2346))) (if (null? bindings2350) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12347 e22348))) ((lambda (tmp2354) ((lambda (tmp2355) (if tmp2355 (apply (lambda (body2356 binding2357) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2357) body2356)) tmp2355) (syntax-error tmp2354))) (syntax-dispatch tmp2354 (quote (any any))))) (list (f2349 (cdr bindings2350)) (car bindings2350)))))) tmp2337) (syntax-error tmp2336))) (syntax-dispatch tmp2336 (quote (any #(each (any any)) any . each-any))))) x2335))) +(install-global-transformer (quote do) (lambda (orig-x2358) ((lambda (tmp2359) ((lambda (tmp2360) (if tmp2360 (apply (lambda (_2361 var2362 init2363 step2364 e02365 e12366 c2367) ((lambda (tmp2368) ((lambda (tmp2369) (if tmp2369 (apply (lambda (step2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2362 init2363) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02365) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2367 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2370))))))) tmp2372) ((lambda (tmp2377) (if tmp2377 (apply (lambda (e12378 e22379) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2362 init2363) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02365 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12378 e22379)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2367 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2370))))))) tmp2377) (syntax-error tmp2371))) (syntax-dispatch tmp2371 (quote (any . each-any)))))) (syntax-dispatch tmp2371 (quote ())))) e12366)) tmp2369) (syntax-error tmp2368))) (syntax-dispatch tmp2368 (quote each-any)))) (map (lambda (v2386 s2387) ((lambda (tmp2388) ((lambda (tmp2389) (if tmp2389 (apply (lambda () v2386) tmp2389) ((lambda (tmp2390) (if tmp2390 (apply (lambda (e2391) e2391) tmp2390) ((lambda (_2392) (syntax-error orig-x2358)) tmp2388))) (syntax-dispatch tmp2388 (quote (any)))))) (syntax-dispatch tmp2388 (quote ())))) s2387)) var2362 step2364))) tmp2360) (syntax-error tmp2359))) (syntax-dispatch tmp2359 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2358))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2395 (lambda (x2399 y2400) ((lambda (tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (x2403 y2404) ((lambda (tmp2405) ((lambda (tmp2406) (if tmp2406 (apply (lambda (dy2407) ((lambda (tmp2408) ((lambda (tmp2409) (if tmp2409 (apply (lambda (dx2410) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2410 dy2407))) tmp2409) ((lambda (_2411) (if (null? dy2407) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2403) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2403 y2404))) tmp2408))) (syntax-dispatch tmp2408 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2403)) tmp2406) ((lambda (tmp2412) (if tmp2412 (apply (lambda (stuff2413) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2403 stuff2413))) tmp2412) ((lambda (else2414) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2403 y2404)) tmp2405))) (syntax-dispatch tmp2405 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2405 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2404)) tmp2402) (syntax-error tmp2401))) (syntax-dispatch tmp2401 (quote (any any))))) (list x2399 y2400)))) (quasiappend2396 (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (x2419 y2420) ((lambda (tmp2421) ((lambda (tmp2422) (if tmp2422 (apply (lambda () x2419) tmp2422) ((lambda (_2423) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2419 y2420)) tmp2421))) (syntax-dispatch tmp2421 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2420)) tmp2418) (syntax-error tmp2417))) (syntax-dispatch tmp2417 (quote (any any))))) (list x2415 y2416)))) (quasivector2397 (lambda (x2424) ((lambda (tmp2425) ((lambda (x2426) ((lambda (tmp2427) ((lambda (tmp2428) (if tmp2428 (apply (lambda (x2429) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2429))) tmp2428) ((lambda (tmp2431) (if tmp2431 (apply (lambda (x2432) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2432)) tmp2431) ((lambda (_2434) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2426)) tmp2427))) (syntax-dispatch tmp2427 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2427 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2426)) tmp2425)) x2424))) (quasi2398 (lambda (p2435 lev2436) ((lambda (tmp2437) ((lambda (tmp2438) (if tmp2438 (apply (lambda (p2439) (if (= lev2436 0) p2439 (quasicons2395 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2398 (list p2439) (- lev2436 1))))) tmp2438) ((lambda (tmp2440) (if tmp2440 (apply (lambda (p2441 q2442) (if (= lev2436 0) (quasiappend2396 p2441 (quasi2398 q2442 lev2436)) (quasicons2395 (quasicons2395 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2398 (list p2441) (- lev2436 1))) (quasi2398 q2442 lev2436)))) tmp2440) ((lambda (tmp2443) (if tmp2443 (apply (lambda (p2444) (quasicons2395 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2398 (list p2444) (+ lev2436 1)))) tmp2443) ((lambda (tmp2445) (if tmp2445 (apply (lambda (p2446 q2447) (quasicons2395 (quasi2398 p2446 lev2436) (quasi2398 q2447 lev2436))) tmp2445) ((lambda (tmp2448) (if tmp2448 (apply (lambda (x2449) (quasivector2397 (quasi2398 x2449 lev2436))) tmp2448) ((lambda (p2451) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2451)) tmp2437))) (syntax-dispatch tmp2437 (quote #(vector each-any)))))) (syntax-dispatch tmp2437 (quote (any . any)))))) (syntax-dispatch tmp2437 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2437 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2437 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2435)))) (lambda (x2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (_2455 e2456) (quasi2398 e2456 0)) tmp2454) (syntax-error tmp2453))) (syntax-dispatch tmp2453 (quote (any any))))) x2452)))) +(install-global-transformer (quote include) (lambda (x2457) (letrec ((read-file2458 (lambda (fn2459 k2460) (let ((p2461 (open-input-file fn2459))) (let f2462 ((x2463 (read p2461))) (if (eof-object? x2463) (begin (close-input-port p2461) (quote ())) (cons (datum->syntax-object k2460 x2463) (f2462 (read p2461))))))))) ((lambda (tmp2464) ((lambda (tmp2465) (if tmp2465 (apply (lambda (k2466 filename2467) (let ((fn2468 (syntax-object->datum filename2467))) ((lambda (tmp2469) ((lambda (tmp2470) (if tmp2470 (apply (lambda (exp2471) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2471)) tmp2470) (syntax-error tmp2469))) (syntax-dispatch tmp2469 (quote each-any)))) (read-file2458 fn2468 k2466)))) tmp2465) (syntax-error tmp2464))) (syntax-dispatch tmp2464 (quote (any any))))) x2457)))) +(install-global-transformer (quote unquote) (lambda (x2473) ((lambda (tmp2474) ((lambda (tmp2475) (if tmp2475 (apply (lambda (_2476 e2477) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2477))) tmp2475) (syntax-error tmp2474))) (syntax-dispatch tmp2474 (quote (any any))))) x2473))) +(install-global-transformer (quote unquote-splicing) (lambda (x2478) ((lambda (tmp2479) ((lambda (tmp2480) (if tmp2480 (apply (lambda (_2481 e2482) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2482))) tmp2480) (syntax-error tmp2479))) (syntax-dispatch tmp2479 (quote (any any))))) x2478))) +(install-global-transformer (quote case) (lambda (x2483) ((lambda (tmp2484) ((lambda (tmp2485) (if tmp2485 (apply (lambda (_2486 e2487 m12488 m22489) ((lambda (tmp2490) ((lambda (body2491) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2487)) body2491)) tmp2490)) (let f2492 ((clause2493 m12488) (clauses2494 m22489)) (if (null? clauses2494) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (e12498 e22499) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12498 e22499))) tmp2497) ((lambda (tmp2501) (if tmp2501 (apply (lambda (k2502 e12503 e22504) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2502)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12503 e22504)))) tmp2501) ((lambda (_2507) (syntax-error x2483)) tmp2496))) (syntax-dispatch tmp2496 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2496 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2493) ((lambda (tmp2508) ((lambda (rest2509) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (k2512 e12513 e22514) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2512)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12513 e22514)) rest2509)) tmp2511) ((lambda (_2517) (syntax-error x2483)) tmp2510))) (syntax-dispatch tmp2510 (quote (each-any any . each-any))))) clause2493)) tmp2508)) (f2492 (car clauses2494) (cdr clauses2494))))))) tmp2485) (syntax-error tmp2484))) (syntax-dispatch tmp2484 (quote (any any any . each-any))))) x2483))) +(install-global-transformer (quote identifier-syntax) (lambda (x2518) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (_2521 e2522) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2522)) (list (cons _2521 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2522 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote (any any))))) x2518))) diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm index de2aeb2de..875229f6a 100644 --- a/module/ice-9/r4rs.scm +++ b/module/ice-9/r4rs.scm @@ -186,28 +186,3 @@ procedures, their behavior is implementation dependent." (lambda (p) (with-error-to-port p thunk)))) (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - - -;;;; Loading - -(if (not (defined? '%load-verbosely)) - (define %load-verbosely #f)) -(define (assert-load-verbosity v) (set! %load-verbosely v)) - -(define (%load-announce file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display "loading ") - (display file) - (newline) - (force-output))))) - -(set! %load-hook %load-announce) - -(define (load name . reader) - (with-fluid* current-reader (and (pair? reader) (car reader)) - (lambda () - (start-stack 'load-stack - (primitive-load name))))) From c5ad45c7b34346f0f7084477479e7367c30a67f6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Apr 2009 12:41:03 +0200 Subject: [PATCH 064/375] allow redefinition of global macros to variables * module/ice-9/psyntax.scm: Allow the redefinition of keywords to variables. Otherwise we can't do (define let #f), which is totally useful and stuff. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 23 +++++++++++++++++------ 2 files changed, 28 insertions(+), 17 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 4a2bc8796..9496275cb 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list1140 (lambda (vars1339) (let lvl1340 ((vars1341 vars1339) (ls1342 (quote ())) (w1343 (quote (())))) (cond ((pair? vars1341) (lvl1340 (cdr vars1341) (cons (wrap1119 (car vars1341) w1343 #f) ls1342) w1343)) ((id?1091 vars1341) (cons (wrap1119 vars1341 w1343 #f) ls1342)) ((null? vars1341) ls1342) ((syntax-object?1075 vars1341) (lvl1340 (syntax-object-expression1076 vars1341) ls1342 (join-wraps1110 w1343 (syntax-object-wrap1077 vars1341)))) ((annotation? vars1341) (lvl1340 (annotation-expression vars1341) ls1342 w1343)) (else (cons vars1341 ls1342)))))) (gen-var1139 (lambda (id1344) (let ((id1345 (if (syntax-object?1075 id1344) (syntax-object-expression1076 id1344) id1344))) (if (annotation? id1345) (build-annotated1068 (annotation-source id1345) (gensym (symbol->string (annotation-expression id1345)))) (build-annotated1068 #f (gensym (symbol->string id1345))))))) (strip1138 (lambda (x1346 w1347) (if (memq (quote top) (wrap-marks1094 w1347)) (if (or (annotation? x1346) (and (pair? x1346) (annotation? (car x1346)))) (strip-annotation1137 x1346 #f) x1346) (let f1348 ((x1349 x1346)) (cond ((syntax-object?1075 x1349) (strip1138 (syntax-object-expression1076 x1349) (syntax-object-wrap1077 x1349))) ((pair? x1349) (let ((a1350 (f1348 (car x1349))) (d1351 (f1348 (cdr x1349)))) (if (and (eq? a1350 (car x1349)) (eq? d1351 (cdr x1349))) x1349 (cons a1350 d1351)))) ((vector? x1349) (let ((old1352 (vector->list x1349))) (let ((new1353 (map f1348 old1352))) (if (andmap eq? old1352 new1353) x1349 (list->vector new1353))))) (else x1349)))))) (strip-annotation1137 (lambda (x1354 parent1355) (cond ((pair? x1354) (let ((new1356 (cons #f #f))) (begin (if parent1355 (set-annotation-stripped! parent1355 new1356)) (set-car! new1356 (strip-annotation1137 (car x1354) #f)) (set-cdr! new1356 (strip-annotation1137 (cdr x1354) #f)) new1356))) ((annotation? x1354) (or (annotation-stripped x1354) (strip-annotation1137 (annotation-expression x1354) x1354))) ((vector? x1354) (let ((new1357 (make-vector (vector-length x1354)))) (begin (if parent1355 (set-annotation-stripped! parent1355 new1357)) (let loop1358 ((i1359 (- (vector-length x1354) 1))) (unless (fx<1062 i1359 0) (vector-set! new1357 i1359 (strip-annotation1137 (vector-ref x1354 i1359) #f)) (loop1358 (fx-1060 i1359 1)))) new1357))) (else x1354)))) (ellipsis?1136 (lambda (x1360) (and (nonsymbol-id?1090 x1360) (free-id=?1114 x1360 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1135 (lambda () (build-annotated1068 #f (list (build-annotated1068 #f (quote void)))))) (eval-local-transformer1134 (lambda (expanded1361 mod1362) (let ((p1363 (local-eval-hook1064 expanded1361 mod1362))) (if (procedure? p1363) p1363 (syntax-error p1363 "nonprocedure transformer"))))) (chi-local-syntax1133 (lambda (rec?1364 e1365 r1366 w1367 s1368 mod1369 k1370) ((lambda (tmp1371) ((lambda (tmp1372) (if tmp1372 (apply (lambda (_1373 id1374 val1375 e11376 e21377) (let ((ids1378 id1374)) (if (not (valid-bound-ids?1116 ids1378)) (syntax-error e1365 "duplicate bound keyword in") (let ((labels1380 (gen-labels1097 ids1378))) (let ((new-w1381 (make-binding-wrap1108 ids1378 labels1380 w1367))) (k1370 (cons e11376 e21377) (extend-env1085 labels1380 (let ((w1383 (if rec?1364 new-w1381 w1367)) (trans-r1384 (macros-only-env1087 r1366))) (map (lambda (x1385) (cons (quote macro) (eval-local-transformer1134 (chi1127 x1385 trans-r1384 w1383 mod1369) mod1369))) val1375)) r1366) new-w1381 s1368 mod1369)))))) tmp1372) ((lambda (_1387) (syntax-error (source-wrap1120 e1365 w1367 s1368 mod1369))) tmp1371))) (syntax-dispatch tmp1371 (quote (any #(each (any any)) any . each-any))))) e1365))) (chi-lambda-clause1132 (lambda (e1388 c1389 r1390 w1391 mod1392 k1393) ((lambda (tmp1394) ((lambda (tmp1395) (if tmp1395 (apply (lambda (id1396 e11397 e21398) (let ((ids1399 id1396)) (if (not (valid-bound-ids?1116 ids1399)) (syntax-error e1388 "invalid parameter list in") (let ((labels1401 (gen-labels1097 ids1399)) (new-vars1402 (map gen-var1139 ids1399))) (k1393 new-vars1402 (chi-body1131 (cons e11397 e21398) e1388 (extend-var-env1086 labels1401 new-vars1402 r1390) (make-binding-wrap1108 ids1399 labels1401 w1391) mod1392)))))) tmp1395) ((lambda (tmp1404) (if tmp1404 (apply (lambda (ids1405 e11406 e21407) (let ((old-ids1408 (lambda-var-list1140 ids1405))) (if (not (valid-bound-ids?1116 old-ids1408)) (syntax-error e1388 "invalid parameter list in") (let ((labels1409 (gen-labels1097 old-ids1408)) (new-vars1410 (map gen-var1139 old-ids1408))) (k1393 (let f1411 ((ls11412 (cdr new-vars1410)) (ls21413 (car new-vars1410))) (if (null? ls11412) ls21413 (f1411 (cdr ls11412) (cons (car ls11412) ls21413)))) (chi-body1131 (cons e11406 e21407) e1388 (extend-var-env1086 labels1409 new-vars1410 r1390) (make-binding-wrap1108 old-ids1408 labels1409 w1391) mod1392)))))) tmp1404) ((lambda (_1415) (syntax-error e1388)) tmp1394))) (syntax-dispatch tmp1394 (quote (any any . each-any)))))) (syntax-dispatch tmp1394 (quote (each-any any . each-any))))) c1389))) (chi-body1131 (lambda (body1416 outer-form1417 r1418 w1419 mod1420) (let ((r1421 (cons (quote ("placeholder" placeholder)) r1418))) (let ((ribcage1422 (make-ribcage1098 (quote ()) (quote ()) (quote ())))) (let ((w1423 (make-wrap1093 (wrap-marks1094 w1419) (cons ribcage1422 (wrap-subst1095 w1419))))) (let parse1424 ((body1425 (map (lambda (x1431) (cons r1421 (wrap1119 x1431 w1423 mod1420))) body1416)) (ids1426 (quote ())) (labels1427 (quote ())) (vars1428 (quote ())) (vals1429 (quote ())) (bindings1430 (quote ()))) (if (null? body1425) (syntax-error outer-form1417 "no expressions in body") (let ((e1432 (cdar body1425)) (er1433 (caar body1425))) (call-with-values (lambda () (syntax-type1125 e1432 er1433 (quote (())) #f ribcage1422 mod1420)) (lambda (type1434 value1435 e1436 w1437 s1438 mod1439) (let ((t1440 type1434)) (if (memv t1440 (quote (define-form))) (let ((id1441 (wrap1119 value1435 w1437 mod1439)) (label1442 (gen-label1096))) (let ((var1443 (gen-var1139 id1441))) (begin (extend-ribcage!1107 ribcage1422 id1441 label1442) (parse1424 (cdr body1425) (cons id1441 ids1426) (cons label1442 labels1427) (cons var1443 vars1428) (cons (cons er1433 (wrap1119 e1436 w1437 mod1439)) vals1429) (cons (cons (quote lexical) var1443) bindings1430))))) (if (memv t1440 (quote (define-syntax-form))) (let ((id1444 (wrap1119 value1435 w1437 mod1439)) (label1445 (gen-label1096))) (begin (extend-ribcage!1107 ribcage1422 id1444 label1445) (parse1424 (cdr body1425) (cons id1444 ids1426) (cons label1445 labels1427) vars1428 vals1429 (cons (cons (quote macro) (cons er1433 (wrap1119 e1436 w1437 mod1439))) bindings1430)))) (if (memv t1440 (quote (begin-form))) ((lambda (tmp1446) ((lambda (tmp1447) (if tmp1447 (apply (lambda (_1448 e11449) (parse1424 (let f1450 ((forms1451 e11449)) (if (null? forms1451) (cdr body1425) (cons (cons er1433 (wrap1119 (car forms1451) w1437 mod1439)) (f1450 (cdr forms1451))))) ids1426 labels1427 vars1428 vals1429 bindings1430)) tmp1447) (syntax-error tmp1446))) (syntax-dispatch tmp1446 (quote (any . each-any))))) e1436) (if (memv t1440 (quote (local-syntax-form))) (chi-local-syntax1133 value1435 e1436 er1433 w1437 s1438 mod1439 (lambda (forms1453 er1454 w1455 s1456 mod1457) (parse1424 (let f1458 ((forms1459 forms1453)) (if (null? forms1459) (cdr body1425) (cons (cons er1454 (wrap1119 (car forms1459) w1455 mod1457)) (f1458 (cdr forms1459))))) ids1426 labels1427 vars1428 vals1429 bindings1430))) (if (null? ids1426) (build-sequence1070 #f (map (lambda (x1460) (chi1127 (cdr x1460) (car x1460) (quote (())) mod1439)) (cons (cons er1433 (source-wrap1120 e1436 w1437 s1438 mod1439)) (cdr body1425)))) (begin (if (not (valid-bound-ids?1116 ids1426)) (syntax-error outer-form1417 "invalid or duplicate identifier in definition")) (let loop1461 ((bs1462 bindings1430) (er-cache1463 #f) (r-cache1464 #f)) (if (not (null? bs1462)) (let ((b1465 (car bs1462))) (if (eq? (car b1465) (quote macro)) (let ((er1466 (cadr b1465))) (let ((r-cache1467 (if (eq? er1466 er-cache1463) r-cache1464 (macros-only-env1087 er1466)))) (begin (set-cdr! b1465 (eval-local-transformer1134 (chi1127 (cddr b1465) r-cache1467 (quote (())) mod1439) mod1439)) (loop1461 (cdr bs1462) er1466 r-cache1467)))) (loop1461 (cdr bs1462) er-cache1463 r-cache1464))))) (set-cdr! r1421 (extend-env1085 labels1427 bindings1430 (cdr r1421))) (build-letrec1073 #f vars1428 (map (lambda (x1468) (chi1127 (cdr x1468) (car x1468) (quote (())) mod1439)) vals1429) (build-sequence1070 #f (map (lambda (x1469) (chi1127 (cdr x1469) (car x1469) (quote (())) mod1439)) (cons (cons er1433 (source-wrap1120 e1436 w1437 s1438 mod1439)) (cdr body1425)))))))))))))))))))))) (chi-macro1130 (lambda (p1470 e1471 r1472 w1473 rib1474 mod1475) (letrec ((rebuild-macro-output1476 (lambda (x1477 m1478) (cond ((pair? x1477) (cons (rebuild-macro-output1476 (car x1477) m1478) (rebuild-macro-output1476 (cdr x1477) m1478))) ((syntax-object?1075 x1477) (let ((w1479 (syntax-object-wrap1077 x1477))) (let ((ms1480 (wrap-marks1094 w1479)) (s1481 (wrap-subst1095 w1479))) (if (and (pair? ms1480) (eq? (car ms1480) #f)) (make-syntax-object1074 (syntax-object-expression1076 x1477) (make-wrap1093 (cdr ms1480) (if rib1474 (cons rib1474 (cdr s1481)) (cdr s1481))) (syntax-object-module1078 x1477)) (make-syntax-object1074 (syntax-object-expression1076 x1477) (make-wrap1093 (cons m1478 ms1480) (if rib1474 (cons rib1474 (cons (quote shift) s1481)) (cons (quote shift) s1481))) (module-name (procedure-module p1470))))))) ((vector? x1477) (let ((n1482 (vector-length x1477))) (let ((v1483 (make-vector n1482))) (let doloop1484 ((i1485 0)) (if (fx=1061 i1485 n1482) v1483 (begin (vector-set! v1483 i1485 (rebuild-macro-output1476 (vector-ref x1477 i1485) m1478)) (doloop1484 (fx+1059 i1485 1)))))))) ((symbol? x1477) (syntax-error x1477 "encountered raw symbol in macro output")) (else x1477))))) (rebuild-macro-output1476 (p1470 (wrap1119 e1471 (anti-mark1106 w1473) mod1475)) (string #\m))))) (chi-application1129 (lambda (x1486 e1487 r1488 w1489 s1490 mod1491) ((lambda (tmp1492) ((lambda (tmp1493) (if tmp1493 (apply (lambda (e01494 e11495) (build-annotated1068 s1490 (cons x1486 (map (lambda (e1496) (chi1127 e1496 r1488 w1489 mod1491)) e11495)))) tmp1493) (syntax-error tmp1492))) (syntax-dispatch tmp1492 (quote (any . each-any))))) e1487))) (chi-expr1128 (lambda (type1498 value1499 e1500 r1501 w1502 s1503 mod1504) (let ((t1505 type1498)) (if (memv t1505 (quote (lexical))) (build-annotated1068 s1503 value1499) (if (memv t1505 (quote (core external-macro))) (value1499 e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (module-ref))) (call-with-values (lambda () (value1499 e1500)) (lambda (id1506 mod1507) (build-annotated1068 s1503 (make-module-ref mod1507 id1506 #f)))) (if (memv t1505 (quote (lexical-call))) (chi-application1129 (build-annotated1068 (source-annotation1082 (car e1500)) value1499) e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (global-call))) (chi-application1129 (build-annotated1068 (source-annotation1082 (car e1500)) (make-module-ref (if (syntax-object?1075 (car e1500)) (syntax-object-module1078 (car e1500)) mod1504) value1499 #f)) e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (constant))) (build-data1069 s1503 (strip1138 (source-wrap1120 e1500 w1502 s1503 mod1504) (quote (())))) (if (memv t1505 (quote (global))) (build-annotated1068 s1503 (make-module-ref mod1504 value1499 #f)) (if (memv t1505 (quote (call))) (chi-application1129 (chi1127 (car e1500) r1501 w1502 mod1504) e1500 r1501 w1502 s1503 mod1504) (if (memv t1505 (quote (begin-form))) ((lambda (tmp1508) ((lambda (tmp1509) (if tmp1509 (apply (lambda (_1510 e11511 e21512) (chi-sequence1121 (cons e11511 e21512) r1501 w1502 s1503 mod1504)) tmp1509) (syntax-error tmp1508))) (syntax-dispatch tmp1508 (quote (any any . each-any))))) e1500) (if (memv t1505 (quote (local-syntax-form))) (chi-local-syntax1133 value1499 e1500 r1501 w1502 s1503 mod1504 chi-sequence1121) (if (memv t1505 (quote (eval-when-form))) ((lambda (tmp1514) ((lambda (tmp1515) (if tmp1515 (apply (lambda (_1516 x1517 e11518 e21519) (let ((when-list1520 (chi-when-list1124 e1500 x1517 w1502))) (if (memq (quote eval) when-list1520) (chi-sequence1121 (cons e11518 e21519) r1501 w1502 s1503 mod1504) (chi-void1135)))) tmp1515) (syntax-error tmp1514))) (syntax-dispatch tmp1514 (quote (any each-any any . each-any))))) e1500) (if (memv t1505 (quote (define-form define-syntax-form))) (syntax-error (wrap1119 value1499 w1502 mod1504) "invalid context for definition of") (if (memv t1505 (quote (syntax))) (syntax-error (source-wrap1120 e1500 w1502 s1503 mod1504) "reference to pattern variable outside syntax form") (if (memv t1505 (quote (displaced-lexical))) (syntax-error (source-wrap1120 e1500 w1502 s1503 mod1504) "reference to identifier outside its scope") (syntax-error (source-wrap1120 e1500 w1502 s1503 mod1504))))))))))))))))))) (chi1127 (lambda (e1523 r1524 w1525 mod1526) (call-with-values (lambda () (syntax-type1125 e1523 r1524 w1525 #f #f mod1526)) (lambda (type1527 value1528 e1529 w1530 s1531 mod1532) (chi-expr1128 type1527 value1528 e1529 r1524 w1530 s1531 mod1532))))) (chi-top1126 (lambda (e1533 r1534 w1535 m1536 esew1537 mod1538) (call-with-values (lambda () (syntax-type1125 e1533 r1534 w1535 #f #f mod1538)) (lambda (type1546 value1547 e1548 w1549 s1550 mod1551) (let ((t1552 type1546)) (if (memv t1552 (quote (begin-form))) ((lambda (tmp1553) ((lambda (tmp1554) (if tmp1554 (apply (lambda (_1555) (chi-void1135)) tmp1554) ((lambda (tmp1556) (if tmp1556 (apply (lambda (_1557 e11558 e21559) (chi-top-sequence1122 (cons e11558 e21559) r1534 w1549 s1550 m1536 esew1537 mod1551)) tmp1556) (syntax-error tmp1553))) (syntax-dispatch tmp1553 (quote (any any . each-any)))))) (syntax-dispatch tmp1553 (quote (any))))) e1548) (if (memv t1552 (quote (local-syntax-form))) (chi-local-syntax1133 value1547 e1548 r1534 w1549 s1550 mod1551 (lambda (body1561 r1562 w1563 s1564 mod1565) (chi-top-sequence1122 body1561 r1562 w1563 s1564 m1536 esew1537 mod1565))) (if (memv t1552 (quote (eval-when-form))) ((lambda (tmp1566) ((lambda (tmp1567) (if tmp1567 (apply (lambda (_1568 x1569 e11570 e21571) (let ((when-list1572 (chi-when-list1124 e1548 x1569 w1549)) (body1573 (cons e11570 e21571))) (cond ((eq? m1536 (quote e)) (if (memq (quote eval) when-list1572) (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote e) (quote (eval)) mod1551) (chi-void1135))) ((memq (quote load) when-list1572) (if (or (memq (quote compile) when-list1572) (and (eq? m1536 (quote c&e)) (memq (quote eval) when-list1572))) (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote c&e) (quote (compile load)) mod1551) (if (memq m1536 (quote (c c&e))) (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote c) (quote (load)) mod1551) (chi-void1135)))) ((or (memq (quote compile) when-list1572) (and (eq? m1536 (quote c&e)) (memq (quote eval) when-list1572))) (top-level-eval-hook1063 (chi-top-sequence1122 body1573 r1534 w1549 s1550 (quote e) (quote (eval)) mod1551) mod1551) (chi-void1135)) (else (chi-void1135))))) tmp1567) (syntax-error tmp1566))) (syntax-dispatch tmp1566 (quote (any each-any any . each-any))))) e1548) (if (memv t1552 (quote (define-syntax-form))) (let ((n1576 (id-var-name1113 value1547 w1549)) (r1577 (macros-only-env1087 r1534))) (let ((t1578 m1536)) (if (memv t1578 (quote (c))) (if (memq (quote compile) esew1537) (let ((e1579 (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)))) (begin (top-level-eval-hook1063 e1579 mod1551) (if (memq (quote load) esew1537) e1579 (chi-void1135)))) (if (memq (quote load) esew1537) (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)) (chi-void1135))) (if (memv t1578 (quote (c&e))) (let ((e1580 (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)))) (begin (top-level-eval-hook1063 e1580 mod1551) e1580)) (begin (if (memq (quote eval) esew1537) (top-level-eval-hook1063 (chi-install-global1123 n1576 (chi1127 e1548 r1577 w1549 mod1551)) mod1551)) (chi-void1135)))))) (if (memv t1552 (quote (define-form))) (let ((n1581 (id-var-name1113 value1547 w1549))) (let ((type1582 (binding-type1083 (lookup1088 n1581 r1534 mod1551)))) (let ((t1583 type1582)) (if (memv t1583 (quote (global))) (let ((x1584 (build-annotated1068 s1550 (list (quote define) n1581 (chi1127 e1548 r1534 w1549 mod1551))))) (begin (if (eq? m1536 (quote c&e)) (top-level-eval-hook1063 x1584 mod1551)) x1584)) (if (memv t1583 (quote (displaced-lexical))) (syntax-error (wrap1119 value1547 w1549 mod1551) "identifier out of context") (if (eq? type1582 (quote external-macro)) (let ((x1585 (build-annotated1068 s1550 (list (quote define) n1581 (chi1127 e1548 r1534 w1549 mod1551))))) (begin (if (eq? m1536 (quote c&e)) (top-level-eval-hook1063 x1585 mod1551)) x1585)) (syntax-error (wrap1119 value1547 w1549 mod1551) "cannot define keyword at top level"))))))) (let ((x1586 (chi-expr1128 type1546 value1547 e1548 r1534 w1549 s1550 mod1551))) (begin (if (eq? m1536 (quote c&e)) (top-level-eval-hook1063 x1586 mod1551)) x1586)))))))))))) (syntax-type1125 (lambda (e1587 r1588 w1589 s1590 rib1591 mod1592) (cond ((symbol? e1587) (let ((n1593 (id-var-name1113 e1587 w1589))) (let ((b1594 (lookup1088 n1593 r1588 mod1592))) (let ((type1595 (binding-type1083 b1594))) (let ((t1596 type1595)) (if (memv t1596 (quote (lexical))) (values type1595 (binding-value1084 b1594) e1587 w1589 s1590 mod1592) (if (memv t1596 (quote (global))) (values type1595 n1593 e1587 w1589 s1590 mod1592) (if (memv t1596 (quote (macro))) (syntax-type1125 (chi-macro1130 (binding-value1084 b1594) e1587 r1588 w1589 rib1591 mod1592) r1588 (quote (())) s1590 rib1591 mod1592) (values type1595 (binding-value1084 b1594) e1587 w1589 s1590 mod1592))))))))) ((pair? e1587) (let ((first1597 (car e1587))) (if (id?1091 first1597) (let ((n1598 (id-var-name1113 first1597 w1589))) (let ((b1599 (lookup1088 n1598 r1588 (or (and (syntax-object?1075 first1597) (syntax-object-module1078 first1597)) mod1592)))) (let ((type1600 (binding-type1083 b1599))) (let ((t1601 type1600)) (if (memv t1601 (quote (lexical))) (values (quote lexical-call) (binding-value1084 b1599) e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (global))) (values (quote global-call) n1598 e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (macro))) (syntax-type1125 (chi-macro1130 (binding-value1084 b1599) e1587 r1588 w1589 rib1591 mod1592) r1588 (quote (())) s1590 rib1591 mod1592) (if (memv t1601 (quote (core external-macro module-ref))) (values type1600 (binding-value1084 b1599) e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1084 b1599) e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (begin))) (values (quote begin-form) #f e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (eval-when))) (values (quote eval-when-form) #f e1587 w1589 s1590 mod1592) (if (memv t1601 (quote (define))) ((lambda (tmp1602) ((lambda (tmp1603) (if (if tmp1603 (apply (lambda (_1604 name1605 val1606) (id?1091 name1605)) tmp1603) #f) (apply (lambda (_1607 name1608 val1609) (values (quote define-form) name1608 val1609 w1589 s1590 mod1592)) tmp1603) ((lambda (tmp1610) (if (if tmp1610 (apply (lambda (_1611 name1612 args1613 e11614 e21615) (and (id?1091 name1612) (valid-bound-ids?1116 (lambda-var-list1140 args1613)))) tmp1610) #f) (apply (lambda (_1616 name1617 args1618 e11619 e21620) (values (quote define-form) (wrap1119 name1617 w1589 mod1592) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1119 (cons args1618 (cons e11619 e21620)) w1589 mod1592)) (quote (())) s1590 mod1592)) tmp1610) ((lambda (tmp1622) (if (if tmp1622 (apply (lambda (_1623 name1624) (id?1091 name1624)) tmp1622) #f) (apply (lambda (_1625 name1626) (values (quote define-form) (wrap1119 name1626 w1589 mod1592) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1590 mod1592)) tmp1622) (syntax-error tmp1602))) (syntax-dispatch tmp1602 (quote (any any)))))) (syntax-dispatch tmp1602 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1602 (quote (any any any))))) e1587) (if (memv t1601 (quote (define-syntax))) ((lambda (tmp1627) ((lambda (tmp1628) (if (if tmp1628 (apply (lambda (_1629 name1630 val1631) (id?1091 name1630)) tmp1628) #f) (apply (lambda (_1632 name1633 val1634) (values (quote define-syntax-form) name1633 val1634 w1589 s1590 mod1592)) tmp1628) (syntax-error tmp1627))) (syntax-dispatch tmp1627 (quote (any any any))))) e1587) (values (quote call) #f e1587 w1589 s1590 mod1592)))))))))))))) (values (quote call) #f e1587 w1589 s1590 mod1592)))) ((syntax-object?1075 e1587) (syntax-type1125 (syntax-object-expression1076 e1587) r1588 (join-wraps1110 w1589 (syntax-object-wrap1077 e1587)) #f rib1591 (or (syntax-object-module1078 e1587) mod1592))) ((annotation? e1587) (syntax-type1125 (annotation-expression e1587) r1588 w1589 (annotation-source e1587) rib1591 mod1592)) ((self-evaluating? e1587) (values (quote constant) #f e1587 w1589 s1590 mod1592)) (else (values (quote other) #f e1587 w1589 s1590 mod1592))))) (chi-when-list1124 (lambda (e1635 when-list1636 w1637) (let f1638 ((when-list1639 when-list1636) (situations1640 (quote ()))) (if (null? when-list1639) situations1640 (f1638 (cdr when-list1639) (cons (let ((x1641 (car when-list1639))) (cond ((free-id=?1114 x1641 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1114 x1641 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1114 x1641 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1119 x1641 w1637 #f) "invalid eval-when situation")))) situations1640)))))) (chi-install-global1123 (lambda (name1642 e1643) (build-annotated1068 #f (list (build-annotated1068 #f (quote install-global-transformer)) (build-data1069 #f name1642) e1643)))) (chi-top-sequence1122 (lambda (body1644 r1645 w1646 s1647 m1648 esew1649 mod1650) (build-sequence1070 s1647 (let dobody1651 ((body1652 body1644) (r1653 r1645) (w1654 w1646) (m1655 m1648) (esew1656 esew1649) (mod1657 mod1650)) (if (null? body1652) (quote ()) (let ((first1658 (chi-top1126 (car body1652) r1653 w1654 m1655 esew1656 mod1657))) (cons first1658 (dobody1651 (cdr body1652) r1653 w1654 m1655 esew1656 mod1657)))))))) (chi-sequence1121 (lambda (body1659 r1660 w1661 s1662 mod1663) (build-sequence1070 s1662 (let dobody1664 ((body1665 body1659) (r1666 r1660) (w1667 w1661) (mod1668 mod1663)) (if (null? body1665) (quote ()) (let ((first1669 (chi1127 (car body1665) r1666 w1667 mod1668))) (cons first1669 (dobody1664 (cdr body1665) r1666 w1667 mod1668)))))))) (source-wrap1120 (lambda (x1670 w1671 s1672 defmod1673) (wrap1119 (if s1672 (make-annotation x1670 s1672 #f) x1670) w1671 defmod1673))) (wrap1119 (lambda (x1674 w1675 defmod1676) (cond ((and (null? (wrap-marks1094 w1675)) (null? (wrap-subst1095 w1675))) x1674) ((syntax-object?1075 x1674) (make-syntax-object1074 (syntax-object-expression1076 x1674) (join-wraps1110 w1675 (syntax-object-wrap1077 x1674)) (syntax-object-module1078 x1674))) ((null? x1674) x1674) (else (make-syntax-object1074 x1674 w1675 defmod1676))))) (bound-id-member?1118 (lambda (x1677 list1678) (and (not (null? list1678)) (or (bound-id=?1115 x1677 (car list1678)) (bound-id-member?1118 x1677 (cdr list1678)))))) (distinct-bound-ids?1117 (lambda (ids1679) (let distinct?1680 ((ids1681 ids1679)) (or (null? ids1681) (and (not (bound-id-member?1118 (car ids1681) (cdr ids1681))) (distinct?1680 (cdr ids1681))))))) (valid-bound-ids?1116 (lambda (ids1682) (and (let all-ids?1683 ((ids1684 ids1682)) (or (null? ids1684) (and (id?1091 (car ids1684)) (all-ids?1683 (cdr ids1684))))) (distinct-bound-ids?1117 ids1682)))) (bound-id=?1115 (lambda (i1685 j1686) (if (and (syntax-object?1075 i1685) (syntax-object?1075 j1686)) (and (eq? (let ((e1687 (syntax-object-expression1076 i1685))) (if (annotation? e1687) (annotation-expression e1687) e1687)) (let ((e1688 (syntax-object-expression1076 j1686))) (if (annotation? e1688) (annotation-expression e1688) e1688))) (same-marks?1112 (wrap-marks1094 (syntax-object-wrap1077 i1685)) (wrap-marks1094 (syntax-object-wrap1077 j1686)))) (eq? (let ((e1689 i1685)) (if (annotation? e1689) (annotation-expression e1689) e1689)) (let ((e1690 j1686)) (if (annotation? e1690) (annotation-expression e1690) e1690)))))) (free-id=?1114 (lambda (i1691 j1692) (and (eq? (let ((x1693 i1691)) (let ((e1694 (if (syntax-object?1075 x1693) (syntax-object-expression1076 x1693) x1693))) (if (annotation? e1694) (annotation-expression e1694) e1694))) (let ((x1695 j1692)) (let ((e1696 (if (syntax-object?1075 x1695) (syntax-object-expression1076 x1695) x1695))) (if (annotation? e1696) (annotation-expression e1696) e1696)))) (eq? (id-var-name1113 i1691 (quote (()))) (id-var-name1113 j1692 (quote (()))))))) (id-var-name1113 (lambda (id1697 w1698) (letrec ((search-vector-rib1701 (lambda (sym1707 subst1708 marks1709 symnames1710 ribcage1711) (let ((n1712 (vector-length symnames1710))) (let f1713 ((i1714 0)) (cond ((fx=1061 i1714 n1712) (search1699 sym1707 (cdr subst1708) marks1709)) ((and (eq? (vector-ref symnames1710 i1714) sym1707) (same-marks?1112 marks1709 (vector-ref (ribcage-marks1101 ribcage1711) i1714))) (values (vector-ref (ribcage-labels1102 ribcage1711) i1714) marks1709)) (else (f1713 (fx+1059 i1714 1)))))))) (search-list-rib1700 (lambda (sym1715 subst1716 marks1717 symnames1718 ribcage1719) (let f1720 ((symnames1721 symnames1718) (i1722 0)) (cond ((null? symnames1721) (search1699 sym1715 (cdr subst1716) marks1717)) ((and (eq? (car symnames1721) sym1715) (same-marks?1112 marks1717 (list-ref (ribcage-marks1101 ribcage1719) i1722))) (values (list-ref (ribcage-labels1102 ribcage1719) i1722) marks1717)) (else (f1720 (cdr symnames1721) (fx+1059 i1722 1))))))) (search1699 (lambda (sym1723 subst1724 marks1725) (if (null? subst1724) (values #f marks1725) (let ((fst1726 (car subst1724))) (if (eq? fst1726 (quote shift)) (search1699 sym1723 (cdr subst1724) (cdr marks1725)) (let ((symnames1727 (ribcage-symnames1100 fst1726))) (if (vector? symnames1727) (search-vector-rib1701 sym1723 subst1724 marks1725 symnames1727 fst1726) (search-list-rib1700 sym1723 subst1724 marks1725 symnames1727 fst1726))))))))) (cond ((symbol? id1697) (or (call-with-values (lambda () (search1699 id1697 (wrap-subst1095 w1698) (wrap-marks1094 w1698))) (lambda (x1729 . ignore1728) x1729)) id1697)) ((syntax-object?1075 id1697) (let ((id1730 (let ((e1732 (syntax-object-expression1076 id1697))) (if (annotation? e1732) (annotation-expression e1732) e1732))) (w11731 (syntax-object-wrap1077 id1697))) (let ((marks1733 (join-marks1111 (wrap-marks1094 w1698) (wrap-marks1094 w11731)))) (call-with-values (lambda () (search1699 id1730 (wrap-subst1095 w1698) marks1733)) (lambda (new-id1734 marks1735) (or new-id1734 (call-with-values (lambda () (search1699 id1730 (wrap-subst1095 w11731) marks1735)) (lambda (x1737 . ignore1736) x1737)) id1730)))))) ((annotation? id1697) (let ((id1738 (let ((e1739 id1697)) (if (annotation? e1739) (annotation-expression e1739) e1739)))) (or (call-with-values (lambda () (search1699 id1738 (wrap-subst1095 w1698) (wrap-marks1094 w1698))) (lambda (x1741 . ignore1740) x1741)) id1738))) (else (error-hook1065 (quote id-var-name) "invalid id" id1697)))))) (same-marks?1112 (lambda (x1742 y1743) (or (eq? x1742 y1743) (and (not (null? x1742)) (not (null? y1743)) (eq? (car x1742) (car y1743)) (same-marks?1112 (cdr x1742) (cdr y1743)))))) (join-marks1111 (lambda (m11744 m21745) (smart-append1109 m11744 m21745))) (join-wraps1110 (lambda (w11746 w21747) (let ((m11748 (wrap-marks1094 w11746)) (s11749 (wrap-subst1095 w11746))) (if (null? m11748) (if (null? s11749) w21747 (make-wrap1093 (wrap-marks1094 w21747) (smart-append1109 s11749 (wrap-subst1095 w21747)))) (make-wrap1093 (smart-append1109 m11748 (wrap-marks1094 w21747)) (smart-append1109 s11749 (wrap-subst1095 w21747))))))) (smart-append1109 (lambda (m11750 m21751) (if (null? m21751) m11750 (append m11750 m21751)))) (make-binding-wrap1108 (lambda (ids1752 labels1753 w1754) (if (null? ids1752) w1754 (make-wrap1093 (wrap-marks1094 w1754) (cons (let ((labelvec1755 (list->vector labels1753))) (let ((n1756 (vector-length labelvec1755))) (let ((symnamevec1757 (make-vector n1756)) (marksvec1758 (make-vector n1756))) (begin (let f1759 ((ids1760 ids1752) (i1761 0)) (if (not (null? ids1760)) (call-with-values (lambda () (id-sym-name&marks1092 (car ids1760) w1754)) (lambda (symname1762 marks1763) (begin (vector-set! symnamevec1757 i1761 symname1762) (vector-set! marksvec1758 i1761 marks1763) (f1759 (cdr ids1760) (fx+1059 i1761 1))))))) (make-ribcage1098 symnamevec1757 marksvec1758 labelvec1755))))) (wrap-subst1095 w1754)))))) (extend-ribcage!1107 (lambda (ribcage1764 id1765 label1766) (begin (set-ribcage-symnames!1103 ribcage1764 (cons (let ((e1767 (syntax-object-expression1076 id1765))) (if (annotation? e1767) (annotation-expression e1767) e1767)) (ribcage-symnames1100 ribcage1764))) (set-ribcage-marks!1104 ribcage1764 (cons (wrap-marks1094 (syntax-object-wrap1077 id1765)) (ribcage-marks1101 ribcage1764))) (set-ribcage-labels!1105 ribcage1764 (cons label1766 (ribcage-labels1102 ribcage1764)))))) (anti-mark1106 (lambda (w1768) (make-wrap1093 (cons #f (wrap-marks1094 w1768)) (cons (quote shift) (wrap-subst1095 w1768))))) (set-ribcage-labels!1105 (lambda (x1769 update1770) (vector-set! x1769 3 update1770))) (set-ribcage-marks!1104 (lambda (x1771 update1772) (vector-set! x1771 2 update1772))) (set-ribcage-symnames!1103 (lambda (x1773 update1774) (vector-set! x1773 1 update1774))) (ribcage-labels1102 (lambda (x1775) (vector-ref x1775 3))) (ribcage-marks1101 (lambda (x1776) (vector-ref x1776 2))) (ribcage-symnames1100 (lambda (x1777) (vector-ref x1777 1))) (ribcage?1099 (lambda (x1778) (and (vector? x1778) (= (vector-length x1778) 4) (eq? (vector-ref x1778 0) (quote ribcage))))) (make-ribcage1098 (lambda (symnames1779 marks1780 labels1781) (vector (quote ribcage) symnames1779 marks1780 labels1781))) (gen-labels1097 (lambda (ls1782) (if (null? ls1782) (quote ()) (cons (gen-label1096) (gen-labels1097 (cdr ls1782)))))) (gen-label1096 (lambda () (string #\i))) (wrap-subst1095 cdr) (wrap-marks1094 car) (make-wrap1093 cons) (id-sym-name&marks1092 (lambda (x1783 w1784) (if (syntax-object?1075 x1783) (values (let ((e1785 (syntax-object-expression1076 x1783))) (if (annotation? e1785) (annotation-expression e1785) e1785)) (join-marks1111 (wrap-marks1094 w1784) (wrap-marks1094 (syntax-object-wrap1077 x1783)))) (values (let ((e1786 x1783)) (if (annotation? e1786) (annotation-expression e1786) e1786)) (wrap-marks1094 w1784))))) (id?1091 (lambda (x1787) (cond ((symbol? x1787) #t) ((syntax-object?1075 x1787) (symbol? (let ((e1788 (syntax-object-expression1076 x1787))) (if (annotation? e1788) (annotation-expression e1788) e1788)))) ((annotation? x1787) (symbol? (annotation-expression x1787))) (else #f)))) (nonsymbol-id?1090 (lambda (x1789) (and (syntax-object?1075 x1789) (symbol? (let ((e1790 (syntax-object-expression1076 x1789))) (if (annotation? e1790) (annotation-expression e1790) e1790)))))) (global-extend1089 (lambda (type1791 sym1792 val1793) (put-global-definition-hook1066 sym1792 (cons type1791 val1793) (module-name (current-module))))) (lookup1088 (lambda (x1794 r1795 mod1796) (cond ((assq x1794 r1795) => cdr) ((symbol? x1794) (or (get-global-definition-hook1067 x1794 mod1796) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1087 (lambda (r1797) (if (null? r1797) (quote ()) (let ((a1798 (car r1797))) (if (eq? (cadr a1798) (quote macro)) (cons a1798 (macros-only-env1087 (cdr r1797))) (macros-only-env1087 (cdr r1797))))))) (extend-var-env1086 (lambda (labels1799 vars1800 r1801) (if (null? labels1799) r1801 (extend-var-env1086 (cdr labels1799) (cdr vars1800) (cons (cons (car labels1799) (cons (quote lexical) (car vars1800))) r1801))))) (extend-env1085 (lambda (labels1802 bindings1803 r1804) (if (null? labels1802) r1804 (extend-env1085 (cdr labels1802) (cdr bindings1803) (cons (cons (car labels1802) (car bindings1803)) r1804))))) (binding-value1084 cdr) (binding-type1083 car) (source-annotation1082 (lambda (x1805) (cond ((annotation? x1805) (annotation-source x1805)) ((syntax-object?1075 x1805) (source-annotation1082 (syntax-object-expression1076 x1805))) (else #f)))) (set-syntax-object-module!1081 (lambda (x1806 update1807) (vector-set! x1806 3 update1807))) (set-syntax-object-wrap!1080 (lambda (x1808 update1809) (vector-set! x1808 2 update1809))) (set-syntax-object-expression!1079 (lambda (x1810 update1811) (vector-set! x1810 1 update1811))) (syntax-object-module1078 (lambda (x1812) (vector-ref x1812 3))) (syntax-object-wrap1077 (lambda (x1813) (vector-ref x1813 2))) (syntax-object-expression1076 (lambda (x1814) (vector-ref x1814 1))) (syntax-object?1075 (lambda (x1815) (and (vector? x1815) (= (vector-length x1815) 4) (eq? (vector-ref x1815 0) (quote syntax-object))))) (make-syntax-object1074 (lambda (expression1816 wrap1817 module1818) (vector (quote syntax-object) expression1816 wrap1817 module1818))) (build-letrec1073 (lambda (src1819 vars1820 val-exps1821 body-exp1822) (if (null? vars1820) (build-annotated1068 src1819 body-exp1822) (build-annotated1068 src1819 (list (quote letrec) (map list vars1820 val-exps1821) body-exp1822))))) (build-named-let1072 (lambda (src1823 vars1824 val-exps1825 body-exp1826) (if (null? vars1824) (build-annotated1068 src1823 body-exp1826) (build-annotated1068 src1823 (list (quote let) (car vars1824) (map list (cdr vars1824) val-exps1825) body-exp1826))))) (build-let1071 (lambda (src1827 vars1828 val-exps1829 body-exp1830) (if (null? vars1828) (build-annotated1068 src1827 body-exp1830) (build-annotated1068 src1827 (list (quote let) (map list vars1828 val-exps1829) body-exp1830))))) (build-sequence1070 (lambda (src1831 exps1832) (if (null? (cdr exps1832)) (build-annotated1068 src1831 (car exps1832)) (build-annotated1068 src1831 (cons (quote begin) exps1832))))) (build-data1069 (lambda (src1833 exp1834) (if (and (self-evaluating? exp1834) (not (vector? exp1834))) (build-annotated1068 src1833 exp1834) (build-annotated1068 src1833 (list (quote quote) exp1834))))) (build-annotated1068 (lambda (src1835 exp1836) (if (and src1835 (not (annotation? exp1836))) (make-annotation exp1836 src1835 #t) exp1836))) (get-global-definition-hook1067 (lambda (symbol1837 module1838) (let ((module1839 (if module1838 (resolve-module module1838) (warn "wha" symbol1837 (current-module))))) (let ((v1840 (module-variable module1839 symbol1837))) (and v1840 (or (object-property v1840 (quote *sc-expander*)) (and (variable-bound? v1840) (macro? (variable-ref v1840)) (macro-transformer (variable-ref v1840)) guile-macro))))))) (put-global-definition-hook1066 (lambda (symbol1841 binding1842 modname1843) (let ((module1844 (if modname1843 (resolve-module modname1843) (current-module)))) (let ((v1845 (or (module-variable module1844 symbol1841) (let ((v1846 (make-variable (quote sc-macro)))) (begin (module-add! module1844 symbol1841 v1846) v1846))))) (begin (if (not (variable-bound? v1845)) (variable-set! v1845 (gensym))) (set-object-property! v1845 (quote *sc-expander*) binding1842)))))) (error-hook1065 (lambda (who1847 why1848 what1849) (error who1847 "~a ~s" why1848 what1849))) (local-eval-hook1064 (lambda (x1850 mod1851) (eval (list noexpand1058 x1850) (if mod1851 (resolve-module mod1851) (interaction-environment))))) (top-level-eval-hook1063 (lambda (x1852 mod1853) (eval (list noexpand1058 x1852) (if mod1853 (resolve-module mod1853) (interaction-environment))))) (fx<1062 <) (fx=1061 =) (fx-1060 -) (fx+1059 +) (noexpand1058 "noexpand")) (begin (global-extend1089 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1089 (quote local-syntax) (quote let-syntax) #f) (global-extend1089 (quote core) (quote fluid-let-syntax) (lambda (e1854 r1855 w1856 s1857 mod1858) ((lambda (tmp1859) ((lambda (tmp1860) (if (if tmp1860 (apply (lambda (_1861 var1862 val1863 e11864 e21865) (valid-bound-ids?1116 var1862)) tmp1860) #f) (apply (lambda (_1867 var1868 val1869 e11870 e21871) (let ((names1872 (map (lambda (x1873) (id-var-name1113 x1873 w1856)) var1868))) (begin (for-each (lambda (id1875 n1876) (let ((t1877 (binding-type1083 (lookup1088 n1876 r1855 mod1858)))) (if (memv t1877 (quote (displaced-lexical))) (syntax-error (source-wrap1120 id1875 w1856 s1857 mod1858) "identifier out of context")))) var1868 names1872) (chi-body1131 (cons e11870 e21871) (source-wrap1120 e1854 w1856 s1857 mod1858) (extend-env1085 names1872 (let ((trans-r1880 (macros-only-env1087 r1855))) (map (lambda (x1881) (cons (quote macro) (eval-local-transformer1134 (chi1127 x1881 trans-r1880 w1856 mod1858) mod1858))) val1869)) r1855) w1856 mod1858)))) tmp1860) ((lambda (_1883) (syntax-error (source-wrap1120 e1854 w1856 s1857 mod1858))) tmp1859))) (syntax-dispatch tmp1859 (quote (any #(each (any any)) any . each-any))))) e1854))) (global-extend1089 (quote core) (quote quote) (lambda (e1884 r1885 w1886 s1887 mod1888) ((lambda (tmp1889) ((lambda (tmp1890) (if tmp1890 (apply (lambda (_1891 e1892) (build-data1069 s1887 (strip1138 e1892 w1886))) tmp1890) ((lambda (_1893) (syntax-error (source-wrap1120 e1884 w1886 s1887 mod1888))) tmp1889))) (syntax-dispatch tmp1889 (quote (any any))))) e1884))) (global-extend1089 (quote core) (quote syntax) (letrec ((regen1901 (lambda (x1902) (let ((t1903 (car x1902))) (if (memv t1903 (quote (ref))) (build-annotated1068 #f (cadr x1902)) (if (memv t1903 (quote (primitive))) (build-annotated1068 #f (cadr x1902)) (if (memv t1903 (quote (quote))) (build-data1069 #f (cadr x1902)) (if (memv t1903 (quote (lambda))) (build-annotated1068 #f (list (quote lambda) (cadr x1902) (regen1901 (caddr x1902)))) (if (memv t1903 (quote (map))) (let ((ls1904 (map regen1901 (cdr x1902)))) (build-annotated1068 #f (cons (if (fx=1061 (length ls1904) 2) (build-annotated1068 #f (quote map)) (build-annotated1068 #f (quote map))) ls1904))) (build-annotated1068 #f (cons (build-annotated1068 #f (car x1902)) (map regen1901 (cdr x1902)))))))))))) (gen-vector1900 (lambda (x1905) (cond ((eq? (car x1905) (quote list)) (cons (quote vector) (cdr x1905))) ((eq? (car x1905) (quote quote)) (list (quote quote) (list->vector (cadr x1905)))) (else (list (quote list->vector) x1905))))) (gen-append1899 (lambda (x1906 y1907) (if (equal? y1907 (quote (quote ()))) x1906 (list (quote append) x1906 y1907)))) (gen-cons1898 (lambda (x1908 y1909) (let ((t1910 (car y1909))) (if (memv t1910 (quote (quote))) (if (eq? (car x1908) (quote quote)) (list (quote quote) (cons (cadr x1908) (cadr y1909))) (if (eq? (cadr y1909) (quote ())) (list (quote list) x1908) (list (quote cons) x1908 y1909))) (if (memv t1910 (quote (list))) (cons (quote list) (cons x1908 (cdr y1909))) (list (quote cons) x1908 y1909)))))) (gen-map1897 (lambda (e1911 map-env1912) (let ((formals1913 (map cdr map-env1912)) (actuals1914 (map (lambda (x1915) (list (quote ref) (car x1915))) map-env1912))) (cond ((eq? (car e1911) (quote ref)) (car actuals1914)) ((andmap (lambda (x1916) (and (eq? (car x1916) (quote ref)) (memq (cadr x1916) formals1913))) (cdr e1911)) (cons (quote map) (cons (list (quote primitive) (car e1911)) (map (let ((r1917 (map cons formals1913 actuals1914))) (lambda (x1918) (cdr (assq (cadr x1918) r1917)))) (cdr e1911))))) (else (cons (quote map) (cons (list (quote lambda) formals1913 e1911) actuals1914))))))) (gen-mappend1896 (lambda (e1919 map-env1920) (list (quote apply) (quote (primitive append)) (gen-map1897 e1919 map-env1920)))) (gen-ref1895 (lambda (src1921 var1922 level1923 maps1924) (if (fx=1061 level1923 0) (values var1922 maps1924) (if (null? maps1924) (syntax-error src1921 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1895 src1921 var1922 (fx-1060 level1923 1) (cdr maps1924))) (lambda (outer-var1925 outer-maps1926) (let ((b1927 (assq outer-var1925 (car maps1924)))) (if b1927 (values (cdr b1927) maps1924) (let ((inner-var1928 (gen-var1139 (quote tmp)))) (values inner-var1928 (cons (cons (cons outer-var1925 inner-var1928) (car maps1924)) outer-maps1926))))))))))) (gen-syntax1894 (lambda (src1929 e1930 r1931 maps1932 ellipsis?1933 mod1934) (if (id?1091 e1930) (let ((label1935 (id-var-name1113 e1930 (quote (()))))) (let ((b1936 (lookup1088 label1935 r1931 mod1934))) (if (eq? (binding-type1083 b1936) (quote syntax)) (call-with-values (lambda () (let ((var.lev1937 (binding-value1084 b1936))) (gen-ref1895 src1929 (car var.lev1937) (cdr var.lev1937) maps1932))) (lambda (var1938 maps1939) (values (list (quote ref) var1938) maps1939))) (if (ellipsis?1933 e1930) (syntax-error src1929 "misplaced ellipsis in syntax form") (values (list (quote quote) e1930) maps1932))))) ((lambda (tmp1940) ((lambda (tmp1941) (if (if tmp1941 (apply (lambda (dots1942 e1943) (ellipsis?1933 dots1942)) tmp1941) #f) (apply (lambda (dots1944 e1945) (gen-syntax1894 src1929 e1945 r1931 maps1932 (lambda (x1946) #f) mod1934)) tmp1941) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (x1948 dots1949 y1950) (ellipsis?1933 dots1949)) tmp1947) #f) (apply (lambda (x1951 dots1952 y1953) (let f1954 ((y1955 y1953) (k1956 (lambda (maps1957) (call-with-values (lambda () (gen-syntax1894 src1929 x1951 r1931 (cons (quote ()) maps1957) ellipsis?1933 mod1934)) (lambda (x1958 maps1959) (if (null? (car maps1959)) (syntax-error src1929 "extra ellipsis in syntax form") (values (gen-map1897 x1958 (car maps1959)) (cdr maps1959)))))))) ((lambda (tmp1960) ((lambda (tmp1961) (if (if tmp1961 (apply (lambda (dots1962 y1963) (ellipsis?1933 dots1962)) tmp1961) #f) (apply (lambda (dots1964 y1965) (f1954 y1965 (lambda (maps1966) (call-with-values (lambda () (k1956 (cons (quote ()) maps1966))) (lambda (x1967 maps1968) (if (null? (car maps1968)) (syntax-error src1929 "extra ellipsis in syntax form") (values (gen-mappend1896 x1967 (car maps1968)) (cdr maps1968)))))))) tmp1961) ((lambda (_1969) (call-with-values (lambda () (gen-syntax1894 src1929 y1955 r1931 maps1932 ellipsis?1933 mod1934)) (lambda (y1970 maps1971) (call-with-values (lambda () (k1956 maps1971)) (lambda (x1972 maps1973) (values (gen-append1899 x1972 y1970) maps1973)))))) tmp1960))) (syntax-dispatch tmp1960 (quote (any . any))))) y1955))) tmp1947) ((lambda (tmp1974) (if tmp1974 (apply (lambda (x1975 y1976) (call-with-values (lambda () (gen-syntax1894 src1929 x1975 r1931 maps1932 ellipsis?1933 mod1934)) (lambda (x1977 maps1978) (call-with-values (lambda () (gen-syntax1894 src1929 y1976 r1931 maps1978 ellipsis?1933 mod1934)) (lambda (y1979 maps1980) (values (gen-cons1898 x1977 y1979) maps1980)))))) tmp1974) ((lambda (tmp1981) (if tmp1981 (apply (lambda (e11982 e21983) (call-with-values (lambda () (gen-syntax1894 src1929 (cons e11982 e21983) r1931 maps1932 ellipsis?1933 mod1934)) (lambda (e1985 maps1986) (values (gen-vector1900 e1985) maps1986)))) tmp1981) ((lambda (_1987) (values (list (quote quote) e1930) maps1932)) tmp1940))) (syntax-dispatch tmp1940 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1940 (quote (any . any)))))) (syntax-dispatch tmp1940 (quote (any any . any)))))) (syntax-dispatch tmp1940 (quote (any any))))) e1930))))) (lambda (e1988 r1989 w1990 s1991 mod1992) (let ((e1993 (source-wrap1120 e1988 w1990 s1991 mod1992))) ((lambda (tmp1994) ((lambda (tmp1995) (if tmp1995 (apply (lambda (_1996 x1997) (call-with-values (lambda () (gen-syntax1894 e1993 x1997 r1989 (quote ()) ellipsis?1136 mod1992)) (lambda (e1998 maps1999) (regen1901 e1998)))) tmp1995) ((lambda (_2000) (syntax-error e1993)) tmp1994))) (syntax-dispatch tmp1994 (quote (any any))))) e1993))))) (global-extend1089 (quote core) (quote lambda) (lambda (e2001 r2002 w2003 s2004 mod2005) ((lambda (tmp2006) ((lambda (tmp2007) (if tmp2007 (apply (lambda (_2008 c2009) (chi-lambda-clause1132 (source-wrap1120 e2001 w2003 s2004 mod2005) c2009 r2002 w2003 mod2005 (lambda (vars2010 body2011) (build-annotated1068 s2004 (list (quote lambda) vars2010 body2011))))) tmp2007) (syntax-error tmp2006))) (syntax-dispatch tmp2006 (quote (any . any))))) e2001))) (global-extend1089 (quote core) (quote let) (letrec ((chi-let2012 (lambda (e2013 r2014 w2015 s2016 mod2017 constructor2018 ids2019 vals2020 exps2021) (if (not (valid-bound-ids?1116 ids2019)) (syntax-error e2013 "duplicate bound variable in") (let ((labels2022 (gen-labels1097 ids2019)) (new-vars2023 (map gen-var1139 ids2019))) (let ((nw2024 (make-binding-wrap1108 ids2019 labels2022 w2015)) (nr2025 (extend-var-env1086 labels2022 new-vars2023 r2014))) (constructor2018 s2016 new-vars2023 (map (lambda (x2026) (chi1127 x2026 r2014 w2015 mod2017)) vals2020) (chi-body1131 exps2021 (source-wrap1120 e2013 nw2024 s2016 mod2017) nr2025 nw2024 mod2017)))))))) (lambda (e2027 r2028 w2029 s2030 mod2031) ((lambda (tmp2032) ((lambda (tmp2033) (if tmp2033 (apply (lambda (_2034 id2035 val2036 e12037 e22038) (chi-let2012 e2027 r2028 w2029 s2030 mod2031 build-let1071 id2035 val2036 (cons e12037 e22038))) tmp2033) ((lambda (tmp2042) (if (if tmp2042 (apply (lambda (_2043 f2044 id2045 val2046 e12047 e22048) (id?1091 f2044)) tmp2042) #f) (apply (lambda (_2049 f2050 id2051 val2052 e12053 e22054) (chi-let2012 e2027 r2028 w2029 s2030 mod2031 build-named-let1072 (cons f2050 id2051) val2052 (cons e12053 e22054))) tmp2042) ((lambda (_2058) (syntax-error (source-wrap1120 e2027 w2029 s2030 mod2031))) tmp2032))) (syntax-dispatch tmp2032 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2032 (quote (any #(each (any any)) any . each-any))))) e2027)))) (global-extend1089 (quote core) (quote letrec) (lambda (e2059 r2060 w2061 s2062 mod2063) ((lambda (tmp2064) ((lambda (tmp2065) (if tmp2065 (apply (lambda (_2066 id2067 val2068 e12069 e22070) (let ((ids2071 id2067)) (if (not (valid-bound-ids?1116 ids2071)) (syntax-error e2059 "duplicate bound variable in") (let ((labels2073 (gen-labels1097 ids2071)) (new-vars2074 (map gen-var1139 ids2071))) (let ((w2075 (make-binding-wrap1108 ids2071 labels2073 w2061)) (r2076 (extend-var-env1086 labels2073 new-vars2074 r2060))) (build-letrec1073 s2062 new-vars2074 (map (lambda (x2077) (chi1127 x2077 r2076 w2075 mod2063)) val2068) (chi-body1131 (cons e12069 e22070) (source-wrap1120 e2059 w2075 s2062 mod2063) r2076 w2075 mod2063))))))) tmp2065) ((lambda (_2080) (syntax-error (source-wrap1120 e2059 w2061 s2062 mod2063))) tmp2064))) (syntax-dispatch tmp2064 (quote (any #(each (any any)) any . each-any))))) e2059))) (global-extend1089 (quote core) (quote set!) (lambda (e2081 r2082 w2083 s2084 mod2085) ((lambda (tmp2086) ((lambda (tmp2087) (if (if tmp2087 (apply (lambda (_2088 id2089 val2090) (id?1091 id2089)) tmp2087) #f) (apply (lambda (_2091 id2092 val2093) (let ((val2094 (chi1127 val2093 r2082 w2083 mod2085)) (n2095 (id-var-name1113 id2092 w2083))) (let ((b2096 (lookup1088 n2095 r2082 mod2085))) (let ((t2097 (binding-type1083 b2096))) (if (memv t2097 (quote (lexical))) (build-annotated1068 s2084 (list (quote set!) (binding-value1084 b2096) val2094)) (if (memv t2097 (quote (global))) (build-annotated1068 s2084 (list (quote set!) (make-module-ref mod2085 n2095 #f) val2094)) (if (memv t2097 (quote (displaced-lexical))) (syntax-error (wrap1119 id2092 w2083 mod2085) "identifier out of context") (syntax-error (source-wrap1120 e2081 w2083 s2084 mod2085))))))))) tmp2087) ((lambda (tmp2098) (if tmp2098 (apply (lambda (_2099 head2100 tail2101 val2102) (call-with-values (lambda () (syntax-type1125 head2100 r2082 (quote (())) #f #f mod2085)) (lambda (type2103 value2104 ee2105 ww2106 ss2107 modmod2108) (let ((t2109 type2103)) (if (memv t2109 (quote (module-ref))) (call-with-values (lambda () (value2104 (cons head2100 tail2101))) (lambda (id2111 mod2112) (build-annotated1068 s2084 (list (quote set!) (make-module-ref mod2112 id2111 #f) val2102)))) (build-annotated1068 s2084 (cons (chi1127 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2100) r2082 w2083 mod2085) (map (lambda (e2113) (chi1127 e2113 r2082 w2083 mod2085)) (append tail2101 (list val2102)))))))))) tmp2098) ((lambda (_2115) (syntax-error (source-wrap1120 e2081 w2083 s2084 mod2085))) tmp2086))) (syntax-dispatch tmp2086 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2086 (quote (any any any))))) e2081))) (global-extend1089 (quote module-ref) (quote @) (lambda (e2116) ((lambda (tmp2117) ((lambda (tmp2118) (if (if tmp2118 (apply (lambda (_2119 mod2120 id2121) (and (andmap id?1091 mod2120) (id?1091 id2121))) tmp2118) #f) (apply (lambda (_2123 mod2124 id2125) (values (syntax-object->datum id2125) (syntax-object->datum (append mod2124 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) tmp2118) (syntax-error tmp2117))) (syntax-dispatch tmp2117 (quote (any each-any any))))) e2116))) (global-extend1089 (quote module-ref) (quote @@) (lambda (e2127) ((lambda (tmp2128) ((lambda (tmp2129) (if (if tmp2129 (apply (lambda (_2130 mod2131 id2132) (and (andmap id?1091 mod2131) (id?1091 id2132))) tmp2129) #f) (apply (lambda (_2134 mod2135 id2136) (values (syntax-object->datum id2136) (syntax-object->datum mod2135))) tmp2129) (syntax-error tmp2128))) (syntax-dispatch tmp2128 (quote (any each-any any))))) e2127))) (global-extend1089 (quote begin) (quote begin) (quote ())) (global-extend1089 (quote define) (quote define) (quote ())) (global-extend1089 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1089 (quote eval-when) (quote eval-when) (quote ())) (global-extend1089 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2141 (lambda (x2142 keys2143 clauses2144 r2145 mod2146) (if (null? clauses2144) (build-annotated1068 #f (list (build-annotated1068 #f (quote syntax-error)) x2142)) ((lambda (tmp2147) ((lambda (tmp2148) (if tmp2148 (apply (lambda (pat2149 exp2150) (if (and (id?1091 pat2149) (andmap (lambda (x2151) (not (free-id=?1114 pat2149 x2151))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2143))) (let ((labels2152 (list (gen-label1096))) (var2153 (gen-var1139 pat2149))) (build-annotated1068 #f (list (build-annotated1068 #f (list (quote lambda) (list var2153) (chi1127 exp2150 (extend-env1085 labels2152 (list (cons (quote syntax) (cons var2153 0))) r2145) (make-binding-wrap1108 (list pat2149) labels2152 (quote (()))) mod2146))) x2142))) (gen-clause2140 x2142 keys2143 (cdr clauses2144) r2145 pat2149 #t exp2150 mod2146))) tmp2148) ((lambda (tmp2154) (if tmp2154 (apply (lambda (pat2155 fender2156 exp2157) (gen-clause2140 x2142 keys2143 (cdr clauses2144) r2145 pat2155 fender2156 exp2157 mod2146)) tmp2154) ((lambda (_2158) (syntax-error (car clauses2144) "invalid syntax-case clause")) tmp2147))) (syntax-dispatch tmp2147 (quote (any any any)))))) (syntax-dispatch tmp2147 (quote (any any))))) (car clauses2144))))) (gen-clause2140 (lambda (x2159 keys2160 clauses2161 r2162 pat2163 fender2164 exp2165 mod2166) (call-with-values (lambda () (convert-pattern2138 pat2163 keys2160)) (lambda (p2167 pvars2168) (cond ((not (distinct-bound-ids?1117 (map car pvars2168))) (syntax-error pat2163 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2169) (not (ellipsis?1136 (car x2169)))) pvars2168)) (syntax-error pat2163 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2170 (gen-var1139 (quote tmp)))) (build-annotated1068 #f (list (build-annotated1068 #f (list (quote lambda) (list y2170) (let ((y2171 (build-annotated1068 #f y2170))) (build-annotated1068 #f (list (quote if) ((lambda (tmp2172) ((lambda (tmp2173) (if tmp2173 (apply (lambda () y2171) tmp2173) ((lambda (_2174) (build-annotated1068 #f (list (quote if) y2171 (build-dispatch-call2139 pvars2168 fender2164 y2171 r2162 mod2166) (build-data1069 #f #f)))) tmp2172))) (syntax-dispatch tmp2172 (quote #(atom #t))))) fender2164) (build-dispatch-call2139 pvars2168 exp2165 y2171 r2162 mod2166) (gen-syntax-case2141 x2159 keys2160 clauses2161 r2162 mod2166)))))) (if (eq? p2167 (quote any)) (build-annotated1068 #f (list (build-annotated1068 #f (quote list)) x2159)) (build-annotated1068 #f (list (build-annotated1068 #f (quote syntax-dispatch)) x2159 (build-data1069 #f p2167))))))))))))) (build-dispatch-call2139 (lambda (pvars2175 exp2176 y2177 r2178 mod2179) (let ((ids2180 (map car pvars2175)) (levels2181 (map cdr pvars2175))) (let ((labels2182 (gen-labels1097 ids2180)) (new-vars2183 (map gen-var1139 ids2180))) (build-annotated1068 #f (list (build-annotated1068 #f (quote apply)) (build-annotated1068 #f (list (quote lambda) new-vars2183 (chi1127 exp2176 (extend-env1085 labels2182 (map (lambda (var2184 level2185) (cons (quote syntax) (cons var2184 level2185))) new-vars2183 (map cdr pvars2175)) r2178) (make-binding-wrap1108 ids2180 labels2182 (quote (()))) mod2179))) y2177)))))) (convert-pattern2138 (lambda (pattern2186 keys2187) (let cvt2188 ((p2189 pattern2186) (n2190 0) (ids2191 (quote ()))) (if (id?1091 p2189) (if (bound-id-member?1118 p2189 keys2187) (values (vector (quote free-id) p2189) ids2191) (values (quote any) (cons (cons p2189 n2190) ids2191))) ((lambda (tmp2192) ((lambda (tmp2193) (if (if tmp2193 (apply (lambda (x2194 dots2195) (ellipsis?1136 dots2195)) tmp2193) #f) (apply (lambda (x2196 dots2197) (call-with-values (lambda () (cvt2188 x2196 (fx+1059 n2190 1) ids2191)) (lambda (p2198 ids2199) (values (if (eq? p2198 (quote any)) (quote each-any) (vector (quote each) p2198)) ids2199)))) tmp2193) ((lambda (tmp2200) (if tmp2200 (apply (lambda (x2201 y2202) (call-with-values (lambda () (cvt2188 y2202 n2190 ids2191)) (lambda (y2203 ids2204) (call-with-values (lambda () (cvt2188 x2201 n2190 ids2204)) (lambda (x2205 ids2206) (values (cons x2205 y2203) ids2206)))))) tmp2200) ((lambda (tmp2207) (if tmp2207 (apply (lambda () (values (quote ()) ids2191)) tmp2207) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209) (call-with-values (lambda () (cvt2188 x2209 n2190 ids2191)) (lambda (p2211 ids2212) (values (vector (quote vector) p2211) ids2212)))) tmp2208) ((lambda (x2213) (values (vector (quote atom) (strip1138 p2189 (quote (())))) ids2191)) tmp2192))) (syntax-dispatch tmp2192 (quote #(vector each-any)))))) (syntax-dispatch tmp2192 (quote ()))))) (syntax-dispatch tmp2192 (quote (any . any)))))) (syntax-dispatch tmp2192 (quote (any any))))) p2189)))))) (lambda (e2214 r2215 w2216 s2217 mod2218) (let ((e2219 (source-wrap1120 e2214 w2216 s2217 mod2218))) ((lambda (tmp2220) ((lambda (tmp2221) (if tmp2221 (apply (lambda (_2222 val2223 key2224 m2225) (if (andmap (lambda (x2226) (and (id?1091 x2226) (not (ellipsis?1136 x2226)))) key2224) (let ((x2228 (gen-var1139 (quote tmp)))) (build-annotated1068 s2217 (list (build-annotated1068 #f (list (quote lambda) (list x2228) (gen-syntax-case2141 (build-annotated1068 #f x2228) key2224 m2225 r2215 mod2218))) (chi1127 val2223 r2215 (quote (())) mod2218)))) (syntax-error e2219 "invalid literals list in"))) tmp2221) (syntax-error tmp2220))) (syntax-dispatch tmp2220 (quote (any any each-any . each-any))))) e2219))))) (set! sc-expand (let ((m2231 (quote e)) (esew2232 (quote (eval)))) (lambda (x2233) (if (and (pair? x2233) (equal? (car x2233) noexpand1058)) (cadr x2233) (chi-top1126 x2233 (quote ()) (quote ((top))) m2231 esew2232 (module-name (current-module))))))) (set! sc-expand3 (let ((m2234 (quote e)) (esew2235 (quote (eval)))) (lambda (x2237 . rest2236) (if (and (pair? x2237) (equal? (car x2237) noexpand1058)) (cadr x2237) (chi-top1126 x2237 (quote ()) (quote ((top))) (if (null? rest2236) m2234 (car rest2236)) (if (or (null? rest2236) (null? (cdr rest2236))) esew2235 (cadr rest2236)) (module-name (current-module))))))) (set! identifier? (lambda (x2238) (nonsymbol-id?1090 x2238))) (set! datum->syntax-object (lambda (id2239 datum2240) (make-syntax-object1074 datum2240 (syntax-object-wrap1077 id2239) #f))) (set! syntax-object->datum (lambda (x2241) (strip1138 x2241 (quote (()))))) (set! generate-temporaries (lambda (ls2242) (begin (let ((x2243 ls2242)) (if (not (list? x2243)) (error-hook1065 (quote generate-temporaries) "invalid argument" x2243))) (map (lambda (x2244) (wrap1119 (gensym) (quote ((top))) #f)) ls2242)))) (set! free-identifier=? (lambda (x2245 y2246) (begin (let ((x2247 x2245)) (if (not (nonsymbol-id?1090 x2247)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2247))) (let ((x2248 y2246)) (if (not (nonsymbol-id?1090 x2248)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2248))) (free-id=?1114 x2245 y2246)))) (set! bound-identifier=? (lambda (x2249 y2250) (begin (let ((x2251 x2249)) (if (not (nonsymbol-id?1090 x2251)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2251))) (let ((x2252 y2250)) (if (not (nonsymbol-id?1090 x2252)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2252))) (bound-id=?1115 x2249 y2250)))) (set! syntax-error (lambda (object2254 . messages2253) (begin (for-each (lambda (x2255) (let ((x2256 x2255)) (if (not (string? x2256)) (error-hook1065 (quote syntax-error) "invalid argument" x2256)))) messages2253) (let ((message2257 (if (null? messages2253) "invalid syntax" (apply string-append messages2253)))) (error-hook1065 #f message2257 (strip1138 object2254 (quote (())))))))) (set! install-global-transformer (lambda (sym2258 v2259) (begin (let ((x2260 sym2258)) (if (not (symbol? x2260)) (error-hook1065 (quote define-syntax) "invalid argument" x2260))) (let ((x2261 v2259)) (if (not (procedure? x2261)) (error-hook1065 (quote define-syntax) "invalid argument" x2261))) (global-extend1089 (quote macro) sym2258 v2259)))) (letrec ((match2266 (lambda (e2267 p2268 w2269 r2270 mod2271) (cond ((not r2270) #f) ((eq? p2268 (quote any)) (cons (wrap1119 e2267 w2269 mod2271) r2270)) ((syntax-object?1075 e2267) (match*2265 (let ((e2272 (syntax-object-expression1076 e2267))) (if (annotation? e2272) (annotation-expression e2272) e2272)) p2268 (join-wraps1110 w2269 (syntax-object-wrap1077 e2267)) r2270 (syntax-object-module1078 e2267))) (else (match*2265 (let ((e2273 e2267)) (if (annotation? e2273) (annotation-expression e2273) e2273)) p2268 w2269 r2270 mod2271))))) (match*2265 (lambda (e2274 p2275 w2276 r2277 mod2278) (cond ((null? p2275) (and (null? e2274) r2277)) ((pair? p2275) (and (pair? e2274) (match2266 (car e2274) (car p2275) w2276 (match2266 (cdr e2274) (cdr p2275) w2276 r2277 mod2278) mod2278))) ((eq? p2275 (quote each-any)) (let ((l2279 (match-each-any2263 e2274 w2276 mod2278))) (and l2279 (cons l2279 r2277)))) (else (let ((t2280 (vector-ref p2275 0))) (if (memv t2280 (quote (each))) (if (null? e2274) (match-empty2264 (vector-ref p2275 1) r2277) (let ((l2281 (match-each2262 e2274 (vector-ref p2275 1) w2276 mod2278))) (and l2281 (let collect2282 ((l2283 l2281)) (if (null? (car l2283)) r2277 (cons (map car l2283) (collect2282 (map cdr l2283)))))))) (if (memv t2280 (quote (free-id))) (and (id?1091 e2274) (free-id=?1114 (wrap1119 e2274 w2276 mod2278) (vector-ref p2275 1)) r2277) (if (memv t2280 (quote (atom))) (and (equal? (vector-ref p2275 1) (strip1138 e2274 w2276)) r2277) (if (memv t2280 (quote (vector))) (and (vector? e2274) (match2266 (vector->list e2274) (vector-ref p2275 1) w2276 r2277 mod2278))))))))))) (match-empty2264 (lambda (p2284 r2285) (cond ((null? p2284) r2285) ((eq? p2284 (quote any)) (cons (quote ()) r2285)) ((pair? p2284) (match-empty2264 (car p2284) (match-empty2264 (cdr p2284) r2285))) ((eq? p2284 (quote each-any)) (cons (quote ()) r2285)) (else (let ((t2286 (vector-ref p2284 0))) (if (memv t2286 (quote (each))) (match-empty2264 (vector-ref p2284 1) r2285) (if (memv t2286 (quote (free-id atom))) r2285 (if (memv t2286 (quote (vector))) (match-empty2264 (vector-ref p2284 1) r2285))))))))) (match-each-any2263 (lambda (e2287 w2288 mod2289) (cond ((annotation? e2287) (match-each-any2263 (annotation-expression e2287) w2288 mod2289)) ((pair? e2287) (let ((l2290 (match-each-any2263 (cdr e2287) w2288 mod2289))) (and l2290 (cons (wrap1119 (car e2287) w2288 mod2289) l2290)))) ((null? e2287) (quote ())) ((syntax-object?1075 e2287) (match-each-any2263 (syntax-object-expression1076 e2287) (join-wraps1110 w2288 (syntax-object-wrap1077 e2287)) mod2289)) (else #f)))) (match-each2262 (lambda (e2291 p2292 w2293 mod2294) (cond ((annotation? e2291) (match-each2262 (annotation-expression e2291) p2292 w2293 mod2294)) ((pair? e2291) (let ((first2295 (match2266 (car e2291) p2292 w2293 (quote ()) mod2294))) (and first2295 (let ((rest2296 (match-each2262 (cdr e2291) p2292 w2293 mod2294))) (and rest2296 (cons first2295 rest2296)))))) ((null? e2291) (quote ())) ((syntax-object?1075 e2291) (match-each2262 (syntax-object-expression1076 e2291) p2292 (join-wraps1110 w2293 (syntax-object-wrap1077 e2291)) (syntax-object-module1078 e2291))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2297 p2298) (cond ((eq? p2298 (quote any)) (list e2297)) ((syntax-object?1075 e2297) (match*2265 (let ((e2299 (syntax-object-expression1076 e2297))) (if (annotation? e2299) (annotation-expression e2299) e2299)) p2298 (syntax-object-wrap1077 e2297) (quote ()) (syntax-object-module1078 e2297))) (else (match*2265 (let ((e2300 e2297)) (if (annotation? e2300) (annotation-expression e2300) e2300)) p2298 (quote (())) (quote ()) #f))))) (set! sc-chi chi1127))))) -(install-global-transformer (quote with-syntax) (lambda (x2301) ((lambda (tmp2302) ((lambda (tmp2303) (if tmp2303 (apply (lambda (_2304 e12305 e22306) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12305 e22306))) tmp2303) ((lambda (tmp2308) (if tmp2308 (apply (lambda (_2309 out2310 in2311 e12312 e22313) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2311 (quote ()) (list out2310 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12312 e22313))))) tmp2308) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 out2317 in2318 e12319 e22320) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2318) (quote ()) (list out2317 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12319 e22320))))) tmp2315) (syntax-error tmp2302))) (syntax-dispatch tmp2302 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2302 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2302 (quote (any () any . each-any))))) x2301))) -(install-global-transformer (quote syntax-rules) (lambda (x2324) ((lambda (tmp2325) ((lambda (tmp2326) (if tmp2326 (apply (lambda (_2327 k2328 keyword2329 pattern2330 template2331) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2328 (map (lambda (tmp2334 tmp2333) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2333) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2334))) template2331 pattern2330)))))) tmp2326) (syntax-error tmp2325))) (syntax-dispatch tmp2325 (quote (any each-any . #(each ((any . any) any))))))) x2324))) -(install-global-transformer (quote let*) (lambda (x2335) ((lambda (tmp2336) ((lambda (tmp2337) (if (if tmp2337 (apply (lambda (let*2338 x2339 v2340 e12341 e22342) (andmap identifier? x2339)) tmp2337) #f) (apply (lambda (let*2344 x2345 v2346 e12347 e22348) (let f2349 ((bindings2350 (map list x2345 v2346))) (if (null? bindings2350) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12347 e22348))) ((lambda (tmp2354) ((lambda (tmp2355) (if tmp2355 (apply (lambda (body2356 binding2357) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2357) body2356)) tmp2355) (syntax-error tmp2354))) (syntax-dispatch tmp2354 (quote (any any))))) (list (f2349 (cdr bindings2350)) (car bindings2350)))))) tmp2337) (syntax-error tmp2336))) (syntax-dispatch tmp2336 (quote (any #(each (any any)) any . each-any))))) x2335))) -(install-global-transformer (quote do) (lambda (orig-x2358) ((lambda (tmp2359) ((lambda (tmp2360) (if tmp2360 (apply (lambda (_2361 var2362 init2363 step2364 e02365 e12366 c2367) ((lambda (tmp2368) ((lambda (tmp2369) (if tmp2369 (apply (lambda (step2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2362 init2363) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02365) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2367 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2370))))))) tmp2372) ((lambda (tmp2377) (if tmp2377 (apply (lambda (e12378 e22379) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2362 init2363) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02365 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12378 e22379)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2367 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2370))))))) tmp2377) (syntax-error tmp2371))) (syntax-dispatch tmp2371 (quote (any . each-any)))))) (syntax-dispatch tmp2371 (quote ())))) e12366)) tmp2369) (syntax-error tmp2368))) (syntax-dispatch tmp2368 (quote each-any)))) (map (lambda (v2386 s2387) ((lambda (tmp2388) ((lambda (tmp2389) (if tmp2389 (apply (lambda () v2386) tmp2389) ((lambda (tmp2390) (if tmp2390 (apply (lambda (e2391) e2391) tmp2390) ((lambda (_2392) (syntax-error orig-x2358)) tmp2388))) (syntax-dispatch tmp2388 (quote (any)))))) (syntax-dispatch tmp2388 (quote ())))) s2387)) var2362 step2364))) tmp2360) (syntax-error tmp2359))) (syntax-dispatch tmp2359 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2358))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2395 (lambda (x2399 y2400) ((lambda (tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (x2403 y2404) ((lambda (tmp2405) ((lambda (tmp2406) (if tmp2406 (apply (lambda (dy2407) ((lambda (tmp2408) ((lambda (tmp2409) (if tmp2409 (apply (lambda (dx2410) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2410 dy2407))) tmp2409) ((lambda (_2411) (if (null? dy2407) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2403) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2403 y2404))) tmp2408))) (syntax-dispatch tmp2408 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2403)) tmp2406) ((lambda (tmp2412) (if tmp2412 (apply (lambda (stuff2413) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2403 stuff2413))) tmp2412) ((lambda (else2414) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2403 y2404)) tmp2405))) (syntax-dispatch tmp2405 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2405 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2404)) tmp2402) (syntax-error tmp2401))) (syntax-dispatch tmp2401 (quote (any any))))) (list x2399 y2400)))) (quasiappend2396 (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (x2419 y2420) ((lambda (tmp2421) ((lambda (tmp2422) (if tmp2422 (apply (lambda () x2419) tmp2422) ((lambda (_2423) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2419 y2420)) tmp2421))) (syntax-dispatch tmp2421 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2420)) tmp2418) (syntax-error tmp2417))) (syntax-dispatch tmp2417 (quote (any any))))) (list x2415 y2416)))) (quasivector2397 (lambda (x2424) ((lambda (tmp2425) ((lambda (x2426) ((lambda (tmp2427) ((lambda (tmp2428) (if tmp2428 (apply (lambda (x2429) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2429))) tmp2428) ((lambda (tmp2431) (if tmp2431 (apply (lambda (x2432) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2432)) tmp2431) ((lambda (_2434) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2426)) tmp2427))) (syntax-dispatch tmp2427 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2427 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2426)) tmp2425)) x2424))) (quasi2398 (lambda (p2435 lev2436) ((lambda (tmp2437) ((lambda (tmp2438) (if tmp2438 (apply (lambda (p2439) (if (= lev2436 0) p2439 (quasicons2395 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2398 (list p2439) (- lev2436 1))))) tmp2438) ((lambda (tmp2440) (if tmp2440 (apply (lambda (p2441 q2442) (if (= lev2436 0) (quasiappend2396 p2441 (quasi2398 q2442 lev2436)) (quasicons2395 (quasicons2395 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2398 (list p2441) (- lev2436 1))) (quasi2398 q2442 lev2436)))) tmp2440) ((lambda (tmp2443) (if tmp2443 (apply (lambda (p2444) (quasicons2395 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2398 (list p2444) (+ lev2436 1)))) tmp2443) ((lambda (tmp2445) (if tmp2445 (apply (lambda (p2446 q2447) (quasicons2395 (quasi2398 p2446 lev2436) (quasi2398 q2447 lev2436))) tmp2445) ((lambda (tmp2448) (if tmp2448 (apply (lambda (x2449) (quasivector2397 (quasi2398 x2449 lev2436))) tmp2448) ((lambda (p2451) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2451)) tmp2437))) (syntax-dispatch tmp2437 (quote #(vector each-any)))))) (syntax-dispatch tmp2437 (quote (any . any)))))) (syntax-dispatch tmp2437 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2437 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2437 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2435)))) (lambda (x2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (_2455 e2456) (quasi2398 e2456 0)) tmp2454) (syntax-error tmp2453))) (syntax-dispatch tmp2453 (quote (any any))))) x2452)))) -(install-global-transformer (quote include) (lambda (x2457) (letrec ((read-file2458 (lambda (fn2459 k2460) (let ((p2461 (open-input-file fn2459))) (let f2462 ((x2463 (read p2461))) (if (eof-object? x2463) (begin (close-input-port p2461) (quote ())) (cons (datum->syntax-object k2460 x2463) (f2462 (read p2461))))))))) ((lambda (tmp2464) ((lambda (tmp2465) (if tmp2465 (apply (lambda (k2466 filename2467) (let ((fn2468 (syntax-object->datum filename2467))) ((lambda (tmp2469) ((lambda (tmp2470) (if tmp2470 (apply (lambda (exp2471) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2471)) tmp2470) (syntax-error tmp2469))) (syntax-dispatch tmp2469 (quote each-any)))) (read-file2458 fn2468 k2466)))) tmp2465) (syntax-error tmp2464))) (syntax-dispatch tmp2464 (quote (any any))))) x2457)))) -(install-global-transformer (quote unquote) (lambda (x2473) ((lambda (tmp2474) ((lambda (tmp2475) (if tmp2475 (apply (lambda (_2476 e2477) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2477))) tmp2475) (syntax-error tmp2474))) (syntax-dispatch tmp2474 (quote (any any))))) x2473))) -(install-global-transformer (quote unquote-splicing) (lambda (x2478) ((lambda (tmp2479) ((lambda (tmp2480) (if tmp2480 (apply (lambda (_2481 e2482) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2482))) tmp2480) (syntax-error tmp2479))) (syntax-dispatch tmp2479 (quote (any any))))) x2478))) -(install-global-transformer (quote case) (lambda (x2483) ((lambda (tmp2484) ((lambda (tmp2485) (if tmp2485 (apply (lambda (_2486 e2487 m12488 m22489) ((lambda (tmp2490) ((lambda (body2491) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2487)) body2491)) tmp2490)) (let f2492 ((clause2493 m12488) (clauses2494 m22489)) (if (null? clauses2494) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (e12498 e22499) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12498 e22499))) tmp2497) ((lambda (tmp2501) (if tmp2501 (apply (lambda (k2502 e12503 e22504) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2502)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12503 e22504)))) tmp2501) ((lambda (_2507) (syntax-error x2483)) tmp2496))) (syntax-dispatch tmp2496 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2496 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2493) ((lambda (tmp2508) ((lambda (rest2509) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (k2512 e12513 e22514) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2512)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12513 e22514)) rest2509)) tmp2511) ((lambda (_2517) (syntax-error x2483)) tmp2510))) (syntax-dispatch tmp2510 (quote (each-any any . each-any))))) clause2493)) tmp2508)) (f2492 (car clauses2494) (cdr clauses2494))))))) tmp2485) (syntax-error tmp2484))) (syntax-dispatch tmp2484 (quote (any any any . each-any))))) x2483))) -(install-global-transformer (quote identifier-syntax) (lambda (x2518) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (_2521 e2522) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2522)) (list (cons _2521 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2522 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote (any any))))) x2518))) +(letrec ((lambda-var-list1141 (lambda (vars1340) (let lvl1341 ((vars1342 vars1340) (ls1343 (quote ())) (w1344 (quote (())))) (cond ((pair? vars1342) (lvl1341 (cdr vars1342) (cons (wrap1120 (car vars1342) w1344 #f) ls1343) w1344)) ((id?1092 vars1342) (cons (wrap1120 vars1342 w1344 #f) ls1343)) ((null? vars1342) ls1343) ((syntax-object?1076 vars1342) (lvl1341 (syntax-object-expression1077 vars1342) ls1343 (join-wraps1111 w1344 (syntax-object-wrap1078 vars1342)))) ((annotation? vars1342) (lvl1341 (annotation-expression vars1342) ls1343 w1344)) (else (cons vars1342 ls1343)))))) (gen-var1140 (lambda (id1345) (let ((id1346 (if (syntax-object?1076 id1345) (syntax-object-expression1077 id1345) id1345))) (if (annotation? id1346) (build-annotated1069 (annotation-source id1346) (gensym (symbol->string (annotation-expression id1346)))) (build-annotated1069 #f (gensym (symbol->string id1346))))))) (strip1139 (lambda (x1347 w1348) (if (memq (quote top) (wrap-marks1095 w1348)) (if (or (annotation? x1347) (and (pair? x1347) (annotation? (car x1347)))) (strip-annotation1138 x1347 #f) x1347) (let f1349 ((x1350 x1347)) (cond ((syntax-object?1076 x1350) (strip1139 (syntax-object-expression1077 x1350) (syntax-object-wrap1078 x1350))) ((pair? x1350) (let ((a1351 (f1349 (car x1350))) (d1352 (f1349 (cdr x1350)))) (if (and (eq? a1351 (car x1350)) (eq? d1352 (cdr x1350))) x1350 (cons a1351 d1352)))) ((vector? x1350) (let ((old1353 (vector->list x1350))) (let ((new1354 (map f1349 old1353))) (if (andmap eq? old1353 new1354) x1350 (list->vector new1354))))) (else x1350)))))) (strip-annotation1138 (lambda (x1355 parent1356) (cond ((pair? x1355) (let ((new1357 (cons #f #f))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1357)) (set-car! new1357 (strip-annotation1138 (car x1355) #f)) (set-cdr! new1357 (strip-annotation1138 (cdr x1355) #f)) new1357))) ((annotation? x1355) (or (annotation-stripped x1355) (strip-annotation1138 (annotation-expression x1355) x1355))) ((vector? x1355) (let ((new1358 (make-vector (vector-length x1355)))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1358)) (let loop1359 ((i1360 (- (vector-length x1355) 1))) (unless (fx<1062 i1360 0) (vector-set! new1358 i1360 (strip-annotation1138 (vector-ref x1355 i1360) #f)) (loop1359 (fx-1060 i1360 1)))) new1358))) (else x1355)))) (ellipsis?1137 (lambda (x1361) (and (nonsymbol-id?1091 x1361) (free-id=?1115 x1361 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1136 (lambda () (build-annotated1069 #f (list (build-annotated1069 #f (quote void)))))) (eval-local-transformer1135 (lambda (expanded1362 mod1363) (let ((p1364 (local-eval-hook1064 expanded1362 mod1363))) (if (procedure? p1364) p1364 (syntax-error p1364 "nonprocedure transformer"))))) (chi-local-syntax1134 (lambda (rec?1365 e1366 r1367 w1368 s1369 mod1370 k1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 id1375 val1376 e11377 e21378) (let ((ids1379 id1375)) (if (not (valid-bound-ids?1117 ids1379)) (syntax-error e1366 "duplicate bound keyword in") (let ((labels1381 (gen-labels1098 ids1379))) (let ((new-w1382 (make-binding-wrap1109 ids1379 labels1381 w1368))) (k1371 (cons e11377 e21378) (extend-env1086 labels1381 (let ((w1384 (if rec?1365 new-w1382 w1368)) (trans-r1385 (macros-only-env1088 r1367))) (map (lambda (x1386) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1386 trans-r1385 w1384 mod1370) mod1370))) val1376)) r1367) new-w1382 s1369 mod1370)))))) tmp1373) ((lambda (_1388) (syntax-error (source-wrap1121 e1366 w1368 s1369 mod1370))) tmp1372))) (syntax-dispatch tmp1372 (quote (any #(each (any any)) any . each-any))))) e1366))) (chi-lambda-clause1133 (lambda (e1389 c1390 r1391 w1392 mod1393 k1394) ((lambda (tmp1395) ((lambda (tmp1396) (if tmp1396 (apply (lambda (id1397 e11398 e21399) (let ((ids1400 id1397)) (if (not (valid-bound-ids?1117 ids1400)) (syntax-error e1389 "invalid parameter list in") (let ((labels1402 (gen-labels1098 ids1400)) (new-vars1403 (map gen-var1140 ids1400))) (k1394 new-vars1403 (chi-body1132 (cons e11398 e21399) e1389 (extend-var-env1087 labels1402 new-vars1403 r1391) (make-binding-wrap1109 ids1400 labels1402 w1392) mod1393)))))) tmp1396) ((lambda (tmp1405) (if tmp1405 (apply (lambda (ids1406 e11407 e21408) (let ((old-ids1409 (lambda-var-list1141 ids1406))) (if (not (valid-bound-ids?1117 old-ids1409)) (syntax-error e1389 "invalid parameter list in") (let ((labels1410 (gen-labels1098 old-ids1409)) (new-vars1411 (map gen-var1140 old-ids1409))) (k1394 (let f1412 ((ls11413 (cdr new-vars1411)) (ls21414 (car new-vars1411))) (if (null? ls11413) ls21414 (f1412 (cdr ls11413) (cons (car ls11413) ls21414)))) (chi-body1132 (cons e11407 e21408) e1389 (extend-var-env1087 labels1410 new-vars1411 r1391) (make-binding-wrap1109 old-ids1409 labels1410 w1392) mod1393)))))) tmp1405) ((lambda (_1416) (syntax-error e1389)) tmp1395))) (syntax-dispatch tmp1395 (quote (any any . each-any)))))) (syntax-dispatch tmp1395 (quote (each-any any . each-any))))) c1390))) (chi-body1132 (lambda (body1417 outer-form1418 r1419 w1420 mod1421) (let ((r1422 (cons (quote ("placeholder" placeholder)) r1419))) (let ((ribcage1423 (make-ribcage1099 (quote ()) (quote ()) (quote ())))) (let ((w1424 (make-wrap1094 (wrap-marks1095 w1420) (cons ribcage1423 (wrap-subst1096 w1420))))) (let parse1425 ((body1426 (map (lambda (x1432) (cons r1422 (wrap1120 x1432 w1424 mod1421))) body1417)) (ids1427 (quote ())) (labels1428 (quote ())) (vars1429 (quote ())) (vals1430 (quote ())) (bindings1431 (quote ()))) (if (null? body1426) (syntax-error outer-form1418 "no expressions in body") (let ((e1433 (cdar body1426)) (er1434 (caar body1426))) (call-with-values (lambda () (syntax-type1126 e1433 er1434 (quote (())) #f ribcage1423 mod1421)) (lambda (type1435 value1436 e1437 w1438 s1439 mod1440) (let ((t1441 type1435)) (if (memv t1441 (quote (define-form))) (let ((id1442 (wrap1120 value1436 w1438 mod1440)) (label1443 (gen-label1097))) (let ((var1444 (gen-var1140 id1442))) (begin (extend-ribcage!1108 ribcage1423 id1442 label1443) (parse1425 (cdr body1426) (cons id1442 ids1427) (cons label1443 labels1428) (cons var1444 vars1429) (cons (cons er1434 (wrap1120 e1437 w1438 mod1440)) vals1430) (cons (cons (quote lexical) var1444) bindings1431))))) (if (memv t1441 (quote (define-syntax-form))) (let ((id1445 (wrap1120 value1436 w1438 mod1440)) (label1446 (gen-label1097))) (begin (extend-ribcage!1108 ribcage1423 id1445 label1446) (parse1425 (cdr body1426) (cons id1445 ids1427) (cons label1446 labels1428) vars1429 vals1430 (cons (cons (quote macro) (cons er1434 (wrap1120 e1437 w1438 mod1440))) bindings1431)))) (if (memv t1441 (quote (begin-form))) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (_1449 e11450) (parse1425 (let f1451 ((forms1452 e11450)) (if (null? forms1452) (cdr body1426) (cons (cons er1434 (wrap1120 (car forms1452) w1438 mod1440)) (f1451 (cdr forms1452))))) ids1427 labels1428 vars1429 vals1430 bindings1431)) tmp1448) (syntax-error tmp1447))) (syntax-dispatch tmp1447 (quote (any . each-any))))) e1437) (if (memv t1441 (quote (local-syntax-form))) (chi-local-syntax1134 value1436 e1437 er1434 w1438 s1439 mod1440 (lambda (forms1454 er1455 w1456 s1457 mod1458) (parse1425 (let f1459 ((forms1460 forms1454)) (if (null? forms1460) (cdr body1426) (cons (cons er1455 (wrap1120 (car forms1460) w1456 mod1458)) (f1459 (cdr forms1460))))) ids1427 labels1428 vars1429 vals1430 bindings1431))) (if (null? ids1427) (build-sequence1071 #f (map (lambda (x1461) (chi1128 (cdr x1461) (car x1461) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))) (begin (if (not (valid-bound-ids?1117 ids1427)) (syntax-error outer-form1418 "invalid or duplicate identifier in definition")) (let loop1462 ((bs1463 bindings1431) (er-cache1464 #f) (r-cache1465 #f)) (if (not (null? bs1463)) (let ((b1466 (car bs1463))) (if (eq? (car b1466) (quote macro)) (let ((er1467 (cadr b1466))) (let ((r-cache1468 (if (eq? er1467 er-cache1464) r-cache1465 (macros-only-env1088 er1467)))) (begin (set-cdr! b1466 (eval-local-transformer1135 (chi1128 (cddr b1466) r-cache1468 (quote (())) mod1440) mod1440)) (loop1462 (cdr bs1463) er1467 r-cache1468)))) (loop1462 (cdr bs1463) er-cache1464 r-cache1465))))) (set-cdr! r1422 (extend-env1086 labels1428 bindings1431 (cdr r1422))) (build-letrec1074 #f vars1429 (map (lambda (x1469) (chi1128 (cdr x1469) (car x1469) (quote (())) mod1440)) vals1430) (build-sequence1071 #f (map (lambda (x1470) (chi1128 (cdr x1470) (car x1470) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))))))))))))))))))))) (chi-macro1131 (lambda (p1471 e1472 r1473 w1474 rib1475 mod1476) (letrec ((rebuild-macro-output1477 (lambda (x1478 m1479) (cond ((pair? x1478) (cons (rebuild-macro-output1477 (car x1478) m1479) (rebuild-macro-output1477 (cdr x1478) m1479))) ((syntax-object?1076 x1478) (let ((w1480 (syntax-object-wrap1078 x1478))) (let ((ms1481 (wrap-marks1095 w1480)) (s1482 (wrap-subst1096 w1480))) (if (and (pair? ms1481) (eq? (car ms1481) #f)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cdr ms1481) (if rib1475 (cons rib1475 (cdr s1482)) (cdr s1482))) (syntax-object-module1079 x1478)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cons m1479 ms1481) (if rib1475 (cons rib1475 (cons (quote shift) s1482)) (cons (quote shift) s1482))) (module-name (procedure-module p1471))))))) ((vector? x1478) (let ((n1483 (vector-length x1478))) (let ((v1484 (make-vector n1483))) (let doloop1485 ((i1486 0)) (if (fx=1061 i1486 n1483) v1484 (begin (vector-set! v1484 i1486 (rebuild-macro-output1477 (vector-ref x1478 i1486) m1479)) (doloop1485 (fx+1059 i1486 1)))))))) ((symbol? x1478) (syntax-error x1478 "encountered raw symbol in macro output")) (else x1478))))) (rebuild-macro-output1477 (p1471 (wrap1120 e1472 (anti-mark1107 w1474) mod1476)) (string #\m))))) (chi-application1130 (lambda (x1487 e1488 r1489 w1490 s1491 mod1492) ((lambda (tmp1493) ((lambda (tmp1494) (if tmp1494 (apply (lambda (e01495 e11496) (build-annotated1069 s1491 (cons x1487 (map (lambda (e1497) (chi1128 e1497 r1489 w1490 mod1492)) e11496)))) tmp1494) (syntax-error tmp1493))) (syntax-dispatch tmp1493 (quote (any . each-any))))) e1488))) (chi-expr1129 (lambda (type1499 value1500 e1501 r1502 w1503 s1504 mod1505) (let ((t1506 type1499)) (if (memv t1506 (quote (lexical))) (build-annotated1069 s1504 value1500) (if (memv t1506 (quote (core external-macro))) (value1500 e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (module-ref))) (call-with-values (lambda () (value1500 e1501)) (lambda (id1507 mod1508) (build-annotated1069 s1504 (make-module-ref mod1508 id1507 #f)))) (if (memv t1506 (quote (lexical-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) value1500) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (global-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) (make-module-ref (if (syntax-object?1076 (car e1501)) (syntax-object-module1079 (car e1501)) mod1505) value1500 #f)) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (constant))) (build-data1070 s1504 (strip1139 (source-wrap1121 e1501 w1503 s1504 mod1505) (quote (())))) (if (memv t1506 (quote (global))) (build-annotated1069 s1504 (make-module-ref mod1505 value1500 #f)) (if (memv t1506 (quote (call))) (chi-application1130 (chi1128 (car e1501) r1502 w1503 mod1505) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (begin-form))) ((lambda (tmp1509) ((lambda (tmp1510) (if tmp1510 (apply (lambda (_1511 e11512 e21513) (chi-sequence1122 (cons e11512 e21513) r1502 w1503 s1504 mod1505)) tmp1510) (syntax-error tmp1509))) (syntax-dispatch tmp1509 (quote (any any . each-any))))) e1501) (if (memv t1506 (quote (local-syntax-form))) (chi-local-syntax1134 value1500 e1501 r1502 w1503 s1504 mod1505 chi-sequence1122) (if (memv t1506 (quote (eval-when-form))) ((lambda (tmp1515) ((lambda (tmp1516) (if tmp1516 (apply (lambda (_1517 x1518 e11519 e21520) (let ((when-list1521 (chi-when-list1125 e1501 x1518 w1503))) (if (memq (quote eval) when-list1521) (chi-sequence1122 (cons e11519 e21520) r1502 w1503 s1504 mod1505) (chi-void1136)))) tmp1516) (syntax-error tmp1515))) (syntax-dispatch tmp1515 (quote (any each-any any . each-any))))) e1501) (if (memv t1506 (quote (define-form define-syntax-form))) (syntax-error (wrap1120 value1500 w1503 mod1505) "invalid context for definition of") (if (memv t1506 (quote (syntax))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to pattern variable outside syntax form") (if (memv t1506 (quote (displaced-lexical))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to identifier outside its scope") (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505))))))))))))))))))) (chi1128 (lambda (e1524 r1525 w1526 mod1527) (call-with-values (lambda () (syntax-type1126 e1524 r1525 w1526 #f #f mod1527)) (lambda (type1528 value1529 e1530 w1531 s1532 mod1533) (chi-expr1129 type1528 value1529 e1530 r1525 w1531 s1532 mod1533))))) (chi-top1127 (lambda (e1534 r1535 w1536 m1537 esew1538 mod1539) (call-with-values (lambda () (syntax-type1126 e1534 r1535 w1536 #f #f mod1539)) (lambda (type1547 value1548 e1549 w1550 s1551 mod1552) (let ((t1553 type1547)) (if (memv t1553 (quote (begin-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556) (chi-void1136)) tmp1555) ((lambda (tmp1557) (if tmp1557 (apply (lambda (_1558 e11559 e21560) (chi-top-sequence1123 (cons e11559 e21560) r1535 w1550 s1551 m1537 esew1538 mod1552)) tmp1557) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any any . each-any)))))) (syntax-dispatch tmp1554 (quote (any))))) e1549) (if (memv t1553 (quote (local-syntax-form))) (chi-local-syntax1134 value1548 e1549 r1535 w1550 s1551 mod1552 (lambda (body1562 r1563 w1564 s1565 mod1566) (chi-top-sequence1123 body1562 r1563 w1564 s1565 m1537 esew1538 mod1566))) (if (memv t1553 (quote (eval-when-form))) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569 x1570 e11571 e21572) (let ((when-list1573 (chi-when-list1125 e1549 x1570 w1550)) (body1574 (cons e11571 e21572))) (cond ((eq? m1537 (quote e)) (if (memq (quote eval) when-list1573) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) (chi-void1136))) ((memq (quote load) when-list1573) (if (or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c&e) (quote (compile load)) mod1552) (if (memq m1537 (quote (c c&e))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c) (quote (load)) mod1552) (chi-void1136)))) ((or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (top-level-eval-hook1063 (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) mod1552) (chi-void1136)) (else (chi-void1136))))) tmp1568) (syntax-error tmp1567))) (syntax-dispatch tmp1567 (quote (any each-any any . each-any))))) e1549) (if (memv t1553 (quote (define-syntax-form))) (let ((n1577 (id-var-name1114 value1548 w1550)) (r1578 (macros-only-env1088 r1535))) (let ((t1579 m1537)) (if (memv t1579 (quote (c))) (if (memq (quote compile) esew1538) (let ((e1580 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1580 mod1552) (if (memq (quote load) esew1538) e1580 (chi-void1136)))) (if (memq (quote load) esew1538) (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) (chi-void1136))) (if (memv t1579 (quote (c&e))) (let ((e1581 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1581 mod1552) e1581)) (begin (if (memq (quote eval) esew1538) (top-level-eval-hook1063 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) mod1552)) (chi-void1136)))))) (if (memv t1553 (quote (define-form))) (let ((n1582 (id-var-name1114 value1548 w1550))) (let ((type1583 (binding-type1084 (lookup1089 n1582 r1535 mod1552)))) (let ((t1584 type1583)) (if (memv t1584 (quote (global))) (let ((x1585 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1585 mod1552)) x1585)) (if (memv t1584 (quote (displaced-lexical))) (syntax-error (wrap1120 value1548 w1550 mod1552) "identifier out of context") (if (memv t1584 (quote (core macro module-ref))) (begin (remove-global-definition-hook1067 n1582 mod1552) (let ((x1586 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1586 mod1552)) x1586))) (syntax-error (wrap1120 value1548 w1550 mod1552) "cannot define keyword at top level"))))))) (let ((x1587 (chi-expr1129 type1547 value1548 e1549 r1535 w1550 s1551 mod1552))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1587 mod1552)) x1587)))))))))))) (syntax-type1126 (lambda (e1588 r1589 w1590 s1591 rib1592 mod1593) (cond ((symbol? e1588) (let ((n1594 (id-var-name1114 e1588 w1590))) (let ((b1595 (lookup1089 n1594 r1589 mod1593))) (let ((type1596 (binding-type1084 b1595))) (let ((t1597 type1596)) (if (memv t1597 (quote (lexical))) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (global))) (values type1596 n1594 e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1595) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593))))))))) ((pair? e1588) (let ((first1598 (car e1588))) (if (id?1092 first1598) (let ((n1599 (id-var-name1114 first1598 w1590))) (let ((b1600 (lookup1089 n1599 r1589 (or (and (syntax-object?1076 first1598) (syntax-object-module1079 first1598)) mod1593)))) (let ((type1601 (binding-type1084 b1600))) (let ((t1602 type1601)) (if (memv t1602 (quote (lexical))) (values (quote lexical-call) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (global))) (values (quote global-call) n1599 e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1600) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (if (memv t1602 (quote (core external-macro module-ref))) (values type1601 (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (begin))) (values (quote begin-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (eval-when))) (values (quote eval-when-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (define))) ((lambda (tmp1603) ((lambda (tmp1604) (if (if tmp1604 (apply (lambda (_1605 name1606 val1607) (id?1092 name1606)) tmp1604) #f) (apply (lambda (_1608 name1609 val1610) (values (quote define-form) name1609 val1610 w1590 s1591 mod1593)) tmp1604) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 name1613 args1614 e11615 e21616) (and (id?1092 name1613) (valid-bound-ids?1117 (lambda-var-list1141 args1614)))) tmp1611) #f) (apply (lambda (_1617 name1618 args1619 e11620 e21621) (values (quote define-form) (wrap1120 name1618 w1590 mod1593) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1120 (cons args1619 (cons e11620 e21621)) w1590 mod1593)) (quote (())) s1591 mod1593)) tmp1611) ((lambda (tmp1623) (if (if tmp1623 (apply (lambda (_1624 name1625) (id?1092 name1625)) tmp1623) #f) (apply (lambda (_1626 name1627) (values (quote define-form) (wrap1120 name1627 w1590 mod1593) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1591 mod1593)) tmp1623) (syntax-error tmp1603))) (syntax-dispatch tmp1603 (quote (any any)))))) (syntax-dispatch tmp1603 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1603 (quote (any any any))))) e1588) (if (memv t1602 (quote (define-syntax))) ((lambda (tmp1628) ((lambda (tmp1629) (if (if tmp1629 (apply (lambda (_1630 name1631 val1632) (id?1092 name1631)) tmp1629) #f) (apply (lambda (_1633 name1634 val1635) (values (quote define-syntax-form) name1634 val1635 w1590 s1591 mod1593)) tmp1629) (syntax-error tmp1628))) (syntax-dispatch tmp1628 (quote (any any any))))) e1588) (values (quote call) #f e1588 w1590 s1591 mod1593)))))))))))))) (values (quote call) #f e1588 w1590 s1591 mod1593)))) ((syntax-object?1076 e1588) (syntax-type1126 (syntax-object-expression1077 e1588) r1589 (join-wraps1111 w1590 (syntax-object-wrap1078 e1588)) #f rib1592 (or (syntax-object-module1079 e1588) mod1593))) ((annotation? e1588) (syntax-type1126 (annotation-expression e1588) r1589 w1590 (annotation-source e1588) rib1592 mod1593)) ((self-evaluating? e1588) (values (quote constant) #f e1588 w1590 s1591 mod1593)) (else (values (quote other) #f e1588 w1590 s1591 mod1593))))) (chi-when-list1125 (lambda (e1636 when-list1637 w1638) (let f1639 ((when-list1640 when-list1637) (situations1641 (quote ()))) (if (null? when-list1640) situations1641 (f1639 (cdr when-list1640) (cons (let ((x1642 (car when-list1640))) (cond ((free-id=?1115 x1642 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1115 x1642 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1115 x1642 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1120 x1642 w1638 #f) "invalid eval-when situation")))) situations1641)))))) (chi-install-global1124 (lambda (name1643 e1644) (build-annotated1069 #f (list (build-annotated1069 #f (quote install-global-transformer)) (build-data1070 #f name1643) e1644)))) (chi-top-sequence1123 (lambda (body1645 r1646 w1647 s1648 m1649 esew1650 mod1651) (build-sequence1071 s1648 (let dobody1652 ((body1653 body1645) (r1654 r1646) (w1655 w1647) (m1656 m1649) (esew1657 esew1650) (mod1658 mod1651)) (if (null? body1653) (quote ()) (let ((first1659 (chi-top1127 (car body1653) r1654 w1655 m1656 esew1657 mod1658))) (cons first1659 (dobody1652 (cdr body1653) r1654 w1655 m1656 esew1657 mod1658)))))))) (chi-sequence1122 (lambda (body1660 r1661 w1662 s1663 mod1664) (build-sequence1071 s1663 (let dobody1665 ((body1666 body1660) (r1667 r1661) (w1668 w1662) (mod1669 mod1664)) (if (null? body1666) (quote ()) (let ((first1670 (chi1128 (car body1666) r1667 w1668 mod1669))) (cons first1670 (dobody1665 (cdr body1666) r1667 w1668 mod1669)))))))) (source-wrap1121 (lambda (x1671 w1672 s1673 defmod1674) (wrap1120 (if s1673 (make-annotation x1671 s1673 #f) x1671) w1672 defmod1674))) (wrap1120 (lambda (x1675 w1676 defmod1677) (cond ((and (null? (wrap-marks1095 w1676)) (null? (wrap-subst1096 w1676))) x1675) ((syntax-object?1076 x1675) (make-syntax-object1075 (syntax-object-expression1077 x1675) (join-wraps1111 w1676 (syntax-object-wrap1078 x1675)) (syntax-object-module1079 x1675))) ((null? x1675) x1675) (else (make-syntax-object1075 x1675 w1676 defmod1677))))) (bound-id-member?1119 (lambda (x1678 list1679) (and (not (null? list1679)) (or (bound-id=?1116 x1678 (car list1679)) (bound-id-member?1119 x1678 (cdr list1679)))))) (distinct-bound-ids?1118 (lambda (ids1680) (let distinct?1681 ((ids1682 ids1680)) (or (null? ids1682) (and (not (bound-id-member?1119 (car ids1682) (cdr ids1682))) (distinct?1681 (cdr ids1682))))))) (valid-bound-ids?1117 (lambda (ids1683) (and (let all-ids?1684 ((ids1685 ids1683)) (or (null? ids1685) (and (id?1092 (car ids1685)) (all-ids?1684 (cdr ids1685))))) (distinct-bound-ids?1118 ids1683)))) (bound-id=?1116 (lambda (i1686 j1687) (if (and (syntax-object?1076 i1686) (syntax-object?1076 j1687)) (and (eq? (let ((e1688 (syntax-object-expression1077 i1686))) (if (annotation? e1688) (annotation-expression e1688) e1688)) (let ((e1689 (syntax-object-expression1077 j1687))) (if (annotation? e1689) (annotation-expression e1689) e1689))) (same-marks?1113 (wrap-marks1095 (syntax-object-wrap1078 i1686)) (wrap-marks1095 (syntax-object-wrap1078 j1687)))) (eq? (let ((e1690 i1686)) (if (annotation? e1690) (annotation-expression e1690) e1690)) (let ((e1691 j1687)) (if (annotation? e1691) (annotation-expression e1691) e1691)))))) (free-id=?1115 (lambda (i1692 j1693) (and (eq? (let ((x1694 i1692)) (let ((e1695 (if (syntax-object?1076 x1694) (syntax-object-expression1077 x1694) x1694))) (if (annotation? e1695) (annotation-expression e1695) e1695))) (let ((x1696 j1693)) (let ((e1697 (if (syntax-object?1076 x1696) (syntax-object-expression1077 x1696) x1696))) (if (annotation? e1697) (annotation-expression e1697) e1697)))) (eq? (id-var-name1114 i1692 (quote (()))) (id-var-name1114 j1693 (quote (()))))))) (id-var-name1114 (lambda (id1698 w1699) (letrec ((search-vector-rib1702 (lambda (sym1708 subst1709 marks1710 symnames1711 ribcage1712) (let ((n1713 (vector-length symnames1711))) (let f1714 ((i1715 0)) (cond ((fx=1061 i1715 n1713) (search1700 sym1708 (cdr subst1709) marks1710)) ((and (eq? (vector-ref symnames1711 i1715) sym1708) (same-marks?1113 marks1710 (vector-ref (ribcage-marks1102 ribcage1712) i1715))) (values (vector-ref (ribcage-labels1103 ribcage1712) i1715) marks1710)) (else (f1714 (fx+1059 i1715 1)))))))) (search-list-rib1701 (lambda (sym1716 subst1717 marks1718 symnames1719 ribcage1720) (let f1721 ((symnames1722 symnames1719) (i1723 0)) (cond ((null? symnames1722) (search1700 sym1716 (cdr subst1717) marks1718)) ((and (eq? (car symnames1722) sym1716) (same-marks?1113 marks1718 (list-ref (ribcage-marks1102 ribcage1720) i1723))) (values (list-ref (ribcage-labels1103 ribcage1720) i1723) marks1718)) (else (f1721 (cdr symnames1722) (fx+1059 i1723 1))))))) (search1700 (lambda (sym1724 subst1725 marks1726) (if (null? subst1725) (values #f marks1726) (let ((fst1727 (car subst1725))) (if (eq? fst1727 (quote shift)) (search1700 sym1724 (cdr subst1725) (cdr marks1726)) (let ((symnames1728 (ribcage-symnames1101 fst1727))) (if (vector? symnames1728) (search-vector-rib1702 sym1724 subst1725 marks1726 symnames1728 fst1727) (search-list-rib1701 sym1724 subst1725 marks1726 symnames1728 fst1727))))))))) (cond ((symbol? id1698) (or (call-with-values (lambda () (search1700 id1698 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1730 . ignore1729) x1730)) id1698)) ((syntax-object?1076 id1698) (let ((id1731 (let ((e1733 (syntax-object-expression1077 id1698))) (if (annotation? e1733) (annotation-expression e1733) e1733))) (w11732 (syntax-object-wrap1078 id1698))) (let ((marks1734 (join-marks1112 (wrap-marks1095 w1699) (wrap-marks1095 w11732)))) (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w1699) marks1734)) (lambda (new-id1735 marks1736) (or new-id1735 (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w11732) marks1736)) (lambda (x1738 . ignore1737) x1738)) id1731)))))) ((annotation? id1698) (let ((id1739 (let ((e1740 id1698)) (if (annotation? e1740) (annotation-expression e1740) e1740)))) (or (call-with-values (lambda () (search1700 id1739 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1742 . ignore1741) x1742)) id1739))) (else (error-hook1065 (quote id-var-name) "invalid id" id1698)))))) (same-marks?1113 (lambda (x1743 y1744) (or (eq? x1743 y1744) (and (not (null? x1743)) (not (null? y1744)) (eq? (car x1743) (car y1744)) (same-marks?1113 (cdr x1743) (cdr y1744)))))) (join-marks1112 (lambda (m11745 m21746) (smart-append1110 m11745 m21746))) (join-wraps1111 (lambda (w11747 w21748) (let ((m11749 (wrap-marks1095 w11747)) (s11750 (wrap-subst1096 w11747))) (if (null? m11749) (if (null? s11750) w21748 (make-wrap1094 (wrap-marks1095 w21748) (smart-append1110 s11750 (wrap-subst1096 w21748)))) (make-wrap1094 (smart-append1110 m11749 (wrap-marks1095 w21748)) (smart-append1110 s11750 (wrap-subst1096 w21748))))))) (smart-append1110 (lambda (m11751 m21752) (if (null? m21752) m11751 (append m11751 m21752)))) (make-binding-wrap1109 (lambda (ids1753 labels1754 w1755) (if (null? ids1753) w1755 (make-wrap1094 (wrap-marks1095 w1755) (cons (let ((labelvec1756 (list->vector labels1754))) (let ((n1757 (vector-length labelvec1756))) (let ((symnamevec1758 (make-vector n1757)) (marksvec1759 (make-vector n1757))) (begin (let f1760 ((ids1761 ids1753) (i1762 0)) (if (not (null? ids1761)) (call-with-values (lambda () (id-sym-name&marks1093 (car ids1761) w1755)) (lambda (symname1763 marks1764) (begin (vector-set! symnamevec1758 i1762 symname1763) (vector-set! marksvec1759 i1762 marks1764) (f1760 (cdr ids1761) (fx+1059 i1762 1))))))) (make-ribcage1099 symnamevec1758 marksvec1759 labelvec1756))))) (wrap-subst1096 w1755)))))) (extend-ribcage!1108 (lambda (ribcage1765 id1766 label1767) (begin (set-ribcage-symnames!1104 ribcage1765 (cons (let ((e1768 (syntax-object-expression1077 id1766))) (if (annotation? e1768) (annotation-expression e1768) e1768)) (ribcage-symnames1101 ribcage1765))) (set-ribcage-marks!1105 ribcage1765 (cons (wrap-marks1095 (syntax-object-wrap1078 id1766)) (ribcage-marks1102 ribcage1765))) (set-ribcage-labels!1106 ribcage1765 (cons label1767 (ribcage-labels1103 ribcage1765)))))) (anti-mark1107 (lambda (w1769) (make-wrap1094 (cons #f (wrap-marks1095 w1769)) (cons (quote shift) (wrap-subst1096 w1769))))) (set-ribcage-labels!1106 (lambda (x1770 update1771) (vector-set! x1770 3 update1771))) (set-ribcage-marks!1105 (lambda (x1772 update1773) (vector-set! x1772 2 update1773))) (set-ribcage-symnames!1104 (lambda (x1774 update1775) (vector-set! x1774 1 update1775))) (ribcage-labels1103 (lambda (x1776) (vector-ref x1776 3))) (ribcage-marks1102 (lambda (x1777) (vector-ref x1777 2))) (ribcage-symnames1101 (lambda (x1778) (vector-ref x1778 1))) (ribcage?1100 (lambda (x1779) (and (vector? x1779) (= (vector-length x1779) 4) (eq? (vector-ref x1779 0) (quote ribcage))))) (make-ribcage1099 (lambda (symnames1780 marks1781 labels1782) (vector (quote ribcage) symnames1780 marks1781 labels1782))) (gen-labels1098 (lambda (ls1783) (if (null? ls1783) (quote ()) (cons (gen-label1097) (gen-labels1098 (cdr ls1783)))))) (gen-label1097 (lambda () (string #\i))) (wrap-subst1096 cdr) (wrap-marks1095 car) (make-wrap1094 cons) (id-sym-name&marks1093 (lambda (x1784 w1785) (if (syntax-object?1076 x1784) (values (let ((e1786 (syntax-object-expression1077 x1784))) (if (annotation? e1786) (annotation-expression e1786) e1786)) (join-marks1112 (wrap-marks1095 w1785) (wrap-marks1095 (syntax-object-wrap1078 x1784)))) (values (let ((e1787 x1784)) (if (annotation? e1787) (annotation-expression e1787) e1787)) (wrap-marks1095 w1785))))) (id?1092 (lambda (x1788) (cond ((symbol? x1788) #t) ((syntax-object?1076 x1788) (symbol? (let ((e1789 (syntax-object-expression1077 x1788))) (if (annotation? e1789) (annotation-expression e1789) e1789)))) ((annotation? x1788) (symbol? (annotation-expression x1788))) (else #f)))) (nonsymbol-id?1091 (lambda (x1790) (and (syntax-object?1076 x1790) (symbol? (let ((e1791 (syntax-object-expression1077 x1790))) (if (annotation? e1791) (annotation-expression e1791) e1791)))))) (global-extend1090 (lambda (type1792 sym1793 val1794) (put-global-definition-hook1066 sym1793 (cons type1792 val1794) (module-name (current-module))))) (lookup1089 (lambda (x1795 r1796 mod1797) (cond ((assq x1795 r1796) => cdr) ((symbol? x1795) (or (get-global-definition-hook1068 x1795 mod1797) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1088 (lambda (r1798) (if (null? r1798) (quote ()) (let ((a1799 (car r1798))) (if (eq? (cadr a1799) (quote macro)) (cons a1799 (macros-only-env1088 (cdr r1798))) (macros-only-env1088 (cdr r1798))))))) (extend-var-env1087 (lambda (labels1800 vars1801 r1802) (if (null? labels1800) r1802 (extend-var-env1087 (cdr labels1800) (cdr vars1801) (cons (cons (car labels1800) (cons (quote lexical) (car vars1801))) r1802))))) (extend-env1086 (lambda (labels1803 bindings1804 r1805) (if (null? labels1803) r1805 (extend-env1086 (cdr labels1803) (cdr bindings1804) (cons (cons (car labels1803) (car bindings1804)) r1805))))) (binding-value1085 cdr) (binding-type1084 car) (source-annotation1083 (lambda (x1806) (cond ((annotation? x1806) (annotation-source x1806)) ((syntax-object?1076 x1806) (source-annotation1083 (syntax-object-expression1077 x1806))) (else #f)))) (set-syntax-object-module!1082 (lambda (x1807 update1808) (vector-set! x1807 3 update1808))) (set-syntax-object-wrap!1081 (lambda (x1809 update1810) (vector-set! x1809 2 update1810))) (set-syntax-object-expression!1080 (lambda (x1811 update1812) (vector-set! x1811 1 update1812))) (syntax-object-module1079 (lambda (x1813) (vector-ref x1813 3))) (syntax-object-wrap1078 (lambda (x1814) (vector-ref x1814 2))) (syntax-object-expression1077 (lambda (x1815) (vector-ref x1815 1))) (syntax-object?1076 (lambda (x1816) (and (vector? x1816) (= (vector-length x1816) 4) (eq? (vector-ref x1816 0) (quote syntax-object))))) (make-syntax-object1075 (lambda (expression1817 wrap1818 module1819) (vector (quote syntax-object) expression1817 wrap1818 module1819))) (build-letrec1074 (lambda (src1820 vars1821 val-exps1822 body-exp1823) (if (null? vars1821) (build-annotated1069 src1820 body-exp1823) (build-annotated1069 src1820 (list (quote letrec) (map list vars1821 val-exps1822) body-exp1823))))) (build-named-let1073 (lambda (src1824 vars1825 val-exps1826 body-exp1827) (if (null? vars1825) (build-annotated1069 src1824 body-exp1827) (build-annotated1069 src1824 (list (quote let) (car vars1825) (map list (cdr vars1825) val-exps1826) body-exp1827))))) (build-let1072 (lambda (src1828 vars1829 val-exps1830 body-exp1831) (if (null? vars1829) (build-annotated1069 src1828 body-exp1831) (build-annotated1069 src1828 (list (quote let) (map list vars1829 val-exps1830) body-exp1831))))) (build-sequence1071 (lambda (src1832 exps1833) (if (null? (cdr exps1833)) (build-annotated1069 src1832 (car exps1833)) (build-annotated1069 src1832 (cons (quote begin) exps1833))))) (build-data1070 (lambda (src1834 exp1835) (if (and (self-evaluating? exp1835) (not (vector? exp1835))) (build-annotated1069 src1834 exp1835) (build-annotated1069 src1834 (list (quote quote) exp1835))))) (build-annotated1069 (lambda (src1836 exp1837) (if (and src1836 (not (annotation? exp1837))) (make-annotation exp1837 src1836 #t) exp1837))) (get-global-definition-hook1068 (lambda (symbol1838 module1839) (let ((module1840 (if module1839 (resolve-module module1839) (warn "wha" symbol1838 (current-module))))) (let ((v1841 (module-variable module1840 symbol1838))) (and v1841 (or (object-property v1841 (quote *sc-expander*)) (and (variable-bound? v1841) (macro? (variable-ref v1841)) (macro-transformer (variable-ref v1841)) guile-macro))))))) (remove-global-definition-hook1067 (lambda (symbol1842 modname1843) (let ((module1844 (if modname1843 (resolve-module modname1843) (current-module)))) (let ((v1845 (module-local-variable module1844 symbol1842))) (if v1845 (let ((p1846 (assq (quote *sc-expander*) (object-properties v1845)))) (set-object-properties! v1845 (delq p1846 (object-properties v1845))))))))) (put-global-definition-hook1066 (lambda (symbol1847 binding1848 modname1849) (let ((module1850 (if modname1849 (resolve-module modname1849) (current-module)))) (let ((v1851 (or (module-variable module1850 symbol1847) (let ((v1852 (make-variable (quote sc-macro)))) (begin (module-add! module1850 symbol1847 v1852) v1852))))) (begin (if (not (variable-bound? v1851)) (variable-set! v1851 (gensym))) (set-object-property! v1851 (quote *sc-expander*) binding1848)))))) (error-hook1065 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1064 (lambda (x1856 mod1857) (eval (list noexpand1058 x1856) (if mod1857 (resolve-module mod1857) (interaction-environment))))) (top-level-eval-hook1063 (lambda (x1858 mod1859) (eval (list noexpand1058 x1858) (if mod1859 (resolve-module mod1859) (interaction-environment))))) (fx<1062 <) (fx=1061 =) (fx-1060 -) (fx+1059 +) (noexpand1058 "noexpand")) (begin (global-extend1090 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1090 (quote local-syntax) (quote let-syntax) #f) (global-extend1090 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1117 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1114 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1084 (lookup1089 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-error (source-wrap1121 id1881 w1862 s1863 mod1864) "identifier out of context")))) var1874 names1878) (chi-body1132 (cons e11876 e21877) (source-wrap1121 e1860 w1862 s1863 mod1864) (extend-env1086 names1878 (let ((trans-r1886 (macros-only-env1088 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-error (source-wrap1121 e1860 w1862 s1863 mod1864))) tmp1865))) (syntax-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1090 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1070 s1893 (strip1139 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-error (source-wrap1121 e1890 w1892 s1893 mod1894))) tmp1895))) (syntax-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1090 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1069 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1069 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1070 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1069 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1069 #f (cons (if (fx=1061 (length ls1910) 2) (build-annotated1069 #f (quote map)) (build-annotated1069 #f (quote map))) ls1910))) (build-annotated1069 #f (cons (build-annotated1069 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1061 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-error src1927 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1060 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1140 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1092 e1936) (let ((label1941 (id-var-name1114 e1936 (quote (()))))) (let ((b1942 (lookup1089 label1941 r1937 mod1940))) (if (eq? (binding-type1084 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1085 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-error src1935 "misplaced ellipsis in syntax form") (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) (syntax-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) (syntax-dispatch tmp1946 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1946 (quote (any . any)))))) (syntax-dispatch tmp1946 (quote (any any . any)))))) (syntax-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1121 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1137 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-error e1999)) tmp2000))) (syntax-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1090 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1133 (source-wrap1121 e2007 w2009 s2010 mod2011) c2015 r2008 w2009 mod2011 (lambda (vars2016 body2017) (build-annotated1069 s2010 (list (quote lambda) vars2016 body2017))))) tmp2013) (syntax-error tmp2012))) (syntax-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1090 (quote core) (quote let) (letrec ((chi-let2018 (lambda (e2019 r2020 w2021 s2022 mod2023 constructor2024 ids2025 vals2026 exps2027) (if (not (valid-bound-ids?1117 ids2025)) (syntax-error e2019 "duplicate bound variable in") (let ((labels2028 (gen-labels1098 ids2025)) (new-vars2029 (map gen-var1140 ids2025))) (let ((nw2030 (make-binding-wrap1109 ids2025 labels2028 w2021)) (nr2031 (extend-var-env1087 labels2028 new-vars2029 r2020))) (constructor2024 s2022 new-vars2029 (map (lambda (x2032) (chi1128 x2032 r2020 w2021 mod2023)) vals2026) (chi-body1132 exps2027 (source-wrap1121 e2019 nw2030 s2022 mod2023) nr2031 nw2030 mod2023)))))))) (lambda (e2033 r2034 w2035 s2036 mod2037) ((lambda (tmp2038) ((lambda (tmp2039) (if tmp2039 (apply (lambda (_2040 id2041 val2042 e12043 e22044) (chi-let2018 e2033 r2034 w2035 s2036 mod2037 build-let1072 id2041 val2042 (cons e12043 e22044))) tmp2039) ((lambda (tmp2048) (if (if tmp2048 (apply (lambda (_2049 f2050 id2051 val2052 e12053 e22054) (id?1092 f2050)) tmp2048) #f) (apply (lambda (_2055 f2056 id2057 val2058 e12059 e22060) (chi-let2018 e2033 r2034 w2035 s2036 mod2037 build-named-let1073 (cons f2056 id2057) val2058 (cons e12059 e22060))) tmp2048) ((lambda (_2064) (syntax-error (source-wrap1121 e2033 w2035 s2036 mod2037))) tmp2038))) (syntax-dispatch tmp2038 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2038 (quote (any #(each (any any)) any . each-any))))) e2033)))) (global-extend1090 (quote core) (quote letrec) (lambda (e2065 r2066 w2067 s2068 mod2069) ((lambda (tmp2070) ((lambda (tmp2071) (if tmp2071 (apply (lambda (_2072 id2073 val2074 e12075 e22076) (let ((ids2077 id2073)) (if (not (valid-bound-ids?1117 ids2077)) (syntax-error e2065 "duplicate bound variable in") (let ((labels2079 (gen-labels1098 ids2077)) (new-vars2080 (map gen-var1140 ids2077))) (let ((w2081 (make-binding-wrap1109 ids2077 labels2079 w2067)) (r2082 (extend-var-env1087 labels2079 new-vars2080 r2066))) (build-letrec1074 s2068 new-vars2080 (map (lambda (x2083) (chi1128 x2083 r2082 w2081 mod2069)) val2074) (chi-body1132 (cons e12075 e22076) (source-wrap1121 e2065 w2081 s2068 mod2069) r2082 w2081 mod2069))))))) tmp2071) ((lambda (_2086) (syntax-error (source-wrap1121 e2065 w2067 s2068 mod2069))) tmp2070))) (syntax-dispatch tmp2070 (quote (any #(each (any any)) any . each-any))))) e2065))) (global-extend1090 (quote core) (quote set!) (lambda (e2087 r2088 w2089 s2090 mod2091) ((lambda (tmp2092) ((lambda (tmp2093) (if (if tmp2093 (apply (lambda (_2094 id2095 val2096) (id?1092 id2095)) tmp2093) #f) (apply (lambda (_2097 id2098 val2099) (let ((val2100 (chi1128 val2099 r2088 w2089 mod2091)) (n2101 (id-var-name1114 id2098 w2089))) (let ((b2102 (lookup1089 n2101 r2088 mod2091))) (let ((t2103 (binding-type1084 b2102))) (if (memv t2103 (quote (lexical))) (build-annotated1069 s2090 (list (quote set!) (binding-value1085 b2102) val2100)) (if (memv t2103 (quote (global))) (build-annotated1069 s2090 (list (quote set!) (make-module-ref mod2091 n2101 #f) val2100)) (if (memv t2103 (quote (displaced-lexical))) (syntax-error (wrap1120 id2098 w2089 mod2091) "identifier out of context") (syntax-error (source-wrap1121 e2087 w2089 s2090 mod2091))))))))) tmp2093) ((lambda (tmp2104) (if tmp2104 (apply (lambda (_2105 head2106 tail2107 val2108) (call-with-values (lambda () (syntax-type1126 head2106 r2088 (quote (())) #f #f mod2091)) (lambda (type2109 value2110 ee2111 ww2112 ss2113 modmod2114) (let ((t2115 type2109)) (if (memv t2115 (quote (module-ref))) (call-with-values (lambda () (value2110 (cons head2106 tail2107))) (lambda (id2117 mod2118) (build-annotated1069 s2090 (list (quote set!) (make-module-ref mod2118 id2117 #f) val2108)))) (build-annotated1069 s2090 (cons (chi1128 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2106) r2088 w2089 mod2091) (map (lambda (e2119) (chi1128 e2119 r2088 w2089 mod2091)) (append tail2107 (list val2108)))))))))) tmp2104) ((lambda (_2121) (syntax-error (source-wrap1121 e2087 w2089 s2090 mod2091))) tmp2092))) (syntax-dispatch tmp2092 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2092 (quote (any any any))))) e2087))) (global-extend1090 (quote module-ref) (quote @) (lambda (e2122) ((lambda (tmp2123) ((lambda (tmp2124) (if (if tmp2124 (apply (lambda (_2125 mod2126 id2127) (and (andmap id?1092 mod2126) (id?1092 id2127))) tmp2124) #f) (apply (lambda (_2129 mod2130 id2131) (values (syntax-object->datum id2131) (syntax-object->datum (append mod2130 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) tmp2124) (syntax-error tmp2123))) (syntax-dispatch tmp2123 (quote (any each-any any))))) e2122))) (global-extend1090 (quote module-ref) (quote @@) (lambda (e2133) ((lambda (tmp2134) ((lambda (tmp2135) (if (if tmp2135 (apply (lambda (_2136 mod2137 id2138) (and (andmap id?1092 mod2137) (id?1092 id2138))) tmp2135) #f) (apply (lambda (_2140 mod2141 id2142) (values (syntax-object->datum id2142) (syntax-object->datum mod2141))) tmp2135) (syntax-error tmp2134))) (syntax-dispatch tmp2134 (quote (any each-any any))))) e2133))) (global-extend1090 (quote begin) (quote begin) (quote ())) (global-extend1090 (quote define) (quote define) (quote ())) (global-extend1090 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1090 (quote eval-when) (quote eval-when) (quote ())) (global-extend1090 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2147 (lambda (x2148 keys2149 clauses2150 r2151 mod2152) (if (null? clauses2150) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-error)) x2148)) ((lambda (tmp2153) ((lambda (tmp2154) (if tmp2154 (apply (lambda (pat2155 exp2156) (if (and (id?1092 pat2155) (andmap (lambda (x2157) (not (free-id=?1115 pat2155 x2157))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2149))) (let ((labels2158 (list (gen-label1097))) (var2159 (gen-var1140 pat2155))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list var2159) (chi1128 exp2156 (extend-env1086 labels2158 (list (cons (quote syntax) (cons var2159 0))) r2151) (make-binding-wrap1109 (list pat2155) labels2158 (quote (()))) mod2152))) x2148))) (gen-clause2146 x2148 keys2149 (cdr clauses2150) r2151 pat2155 #t exp2156 mod2152))) tmp2154) ((lambda (tmp2160) (if tmp2160 (apply (lambda (pat2161 fender2162 exp2163) (gen-clause2146 x2148 keys2149 (cdr clauses2150) r2151 pat2161 fender2162 exp2163 mod2152)) tmp2160) ((lambda (_2164) (syntax-error (car clauses2150) "invalid syntax-case clause")) tmp2153))) (syntax-dispatch tmp2153 (quote (any any any)))))) (syntax-dispatch tmp2153 (quote (any any))))) (car clauses2150))))) (gen-clause2146 (lambda (x2165 keys2166 clauses2167 r2168 pat2169 fender2170 exp2171 mod2172) (call-with-values (lambda () (convert-pattern2144 pat2169 keys2166)) (lambda (p2173 pvars2174) (cond ((not (distinct-bound-ids?1118 (map car pvars2174))) (syntax-error pat2169 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2175) (not (ellipsis?1137 (car x2175)))) pvars2174)) (syntax-error pat2169 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2176 (gen-var1140 (quote tmp)))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list y2176) (let ((y2177 (build-annotated1069 #f y2176))) (build-annotated1069 #f (list (quote if) ((lambda (tmp2178) ((lambda (tmp2179) (if tmp2179 (apply (lambda () y2177) tmp2179) ((lambda (_2180) (build-annotated1069 #f (list (quote if) y2177 (build-dispatch-call2145 pvars2174 fender2170 y2177 r2168 mod2172) (build-data1070 #f #f)))) tmp2178))) (syntax-dispatch tmp2178 (quote #(atom #t))))) fender2170) (build-dispatch-call2145 pvars2174 exp2171 y2177 r2168 mod2172) (gen-syntax-case2147 x2165 keys2166 clauses2167 r2168 mod2172)))))) (if (eq? p2173 (quote any)) (build-annotated1069 #f (list (build-annotated1069 #f (quote list)) x2165)) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-dispatch)) x2165 (build-data1070 #f p2173))))))))))))) (build-dispatch-call2145 (lambda (pvars2181 exp2182 y2183 r2184 mod2185) (let ((ids2186 (map car pvars2181)) (levels2187 (map cdr pvars2181))) (let ((labels2188 (gen-labels1098 ids2186)) (new-vars2189 (map gen-var1140 ids2186))) (build-annotated1069 #f (list (build-annotated1069 #f (quote apply)) (build-annotated1069 #f (list (quote lambda) new-vars2189 (chi1128 exp2182 (extend-env1086 labels2188 (map (lambda (var2190 level2191) (cons (quote syntax) (cons var2190 level2191))) new-vars2189 (map cdr pvars2181)) r2184) (make-binding-wrap1109 ids2186 labels2188 (quote (()))) mod2185))) y2183)))))) (convert-pattern2144 (lambda (pattern2192 keys2193) (let cvt2194 ((p2195 pattern2192) (n2196 0) (ids2197 (quote ()))) (if (id?1092 p2195) (if (bound-id-member?1119 p2195 keys2193) (values (vector (quote free-id) p2195) ids2197) (values (quote any) (cons (cons p2195 n2196) ids2197))) ((lambda (tmp2198) ((lambda (tmp2199) (if (if tmp2199 (apply (lambda (x2200 dots2201) (ellipsis?1137 dots2201)) tmp2199) #f) (apply (lambda (x2202 dots2203) (call-with-values (lambda () (cvt2194 x2202 (fx+1059 n2196 1) ids2197)) (lambda (p2204 ids2205) (values (if (eq? p2204 (quote any)) (quote each-any) (vector (quote each) p2204)) ids2205)))) tmp2199) ((lambda (tmp2206) (if tmp2206 (apply (lambda (x2207 y2208) (call-with-values (lambda () (cvt2194 y2208 n2196 ids2197)) (lambda (y2209 ids2210) (call-with-values (lambda () (cvt2194 x2207 n2196 ids2210)) (lambda (x2211 ids2212) (values (cons x2211 y2209) ids2212)))))) tmp2206) ((lambda (tmp2213) (if tmp2213 (apply (lambda () (values (quote ()) ids2197)) tmp2213) ((lambda (tmp2214) (if tmp2214 (apply (lambda (x2215) (call-with-values (lambda () (cvt2194 x2215 n2196 ids2197)) (lambda (p2217 ids2218) (values (vector (quote vector) p2217) ids2218)))) tmp2214) ((lambda (x2219) (values (vector (quote atom) (strip1139 p2195 (quote (())))) ids2197)) tmp2198))) (syntax-dispatch tmp2198 (quote #(vector each-any)))))) (syntax-dispatch tmp2198 (quote ()))))) (syntax-dispatch tmp2198 (quote (any . any)))))) (syntax-dispatch tmp2198 (quote (any any))))) p2195)))))) (lambda (e2220 r2221 w2222 s2223 mod2224) (let ((e2225 (source-wrap1121 e2220 w2222 s2223 mod2224))) ((lambda (tmp2226) ((lambda (tmp2227) (if tmp2227 (apply (lambda (_2228 val2229 key2230 m2231) (if (andmap (lambda (x2232) (and (id?1092 x2232) (not (ellipsis?1137 x2232)))) key2230) (let ((x2234 (gen-var1140 (quote tmp)))) (build-annotated1069 s2223 (list (build-annotated1069 #f (list (quote lambda) (list x2234) (gen-syntax-case2147 (build-annotated1069 #f x2234) key2230 m2231 r2221 mod2224))) (chi1128 val2229 r2221 (quote (())) mod2224)))) (syntax-error e2225 "invalid literals list in"))) tmp2227) (syntax-error tmp2226))) (syntax-dispatch tmp2226 (quote (any any each-any . each-any))))) e2225))))) (set! sc-expand (let ((m2237 (quote e)) (esew2238 (quote (eval)))) (lambda (x2239) (if (and (pair? x2239) (equal? (car x2239) noexpand1058)) (cadr x2239) (chi-top1127 x2239 (quote ()) (quote ((top))) m2237 esew2238 (module-name (current-module))))))) (set! sc-expand3 (let ((m2240 (quote e)) (esew2241 (quote (eval)))) (lambda (x2243 . rest2242) (if (and (pair? x2243) (equal? (car x2243) noexpand1058)) (cadr x2243) (chi-top1127 x2243 (quote ()) (quote ((top))) (if (null? rest2242) m2240 (car rest2242)) (if (or (null? rest2242) (null? (cdr rest2242))) esew2241 (cadr rest2242)) (module-name (current-module))))))) (set! identifier? (lambda (x2244) (nonsymbol-id?1091 x2244))) (set! datum->syntax-object (lambda (id2245 datum2246) (make-syntax-object1075 datum2246 (syntax-object-wrap1078 id2245) #f))) (set! syntax-object->datum (lambda (x2247) (strip1139 x2247 (quote (()))))) (set! generate-temporaries (lambda (ls2248) (begin (let ((x2249 ls2248)) (if (not (list? x2249)) (error-hook1065 (quote generate-temporaries) "invalid argument" x2249))) (map (lambda (x2250) (wrap1120 (gensym) (quote ((top))) #f)) ls2248)))) (set! free-identifier=? (lambda (x2251 y2252) (begin (let ((x2253 x2251)) (if (not (nonsymbol-id?1091 x2253)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2253))) (let ((x2254 y2252)) (if (not (nonsymbol-id?1091 x2254)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2254))) (free-id=?1115 x2251 y2252)))) (set! bound-identifier=? (lambda (x2255 y2256) (begin (let ((x2257 x2255)) (if (not (nonsymbol-id?1091 x2257)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2257))) (let ((x2258 y2256)) (if (not (nonsymbol-id?1091 x2258)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2258))) (bound-id=?1116 x2255 y2256)))) (set! syntax-error (lambda (object2260 . messages2259) (begin (for-each (lambda (x2261) (let ((x2262 x2261)) (if (not (string? x2262)) (error-hook1065 (quote syntax-error) "invalid argument" x2262)))) messages2259) (let ((message2263 (if (null? messages2259) "invalid syntax" (apply string-append messages2259)))) (error-hook1065 #f message2263 (strip1139 object2260 (quote (())))))))) (set! install-global-transformer (lambda (sym2264 v2265) (begin (let ((x2266 sym2264)) (if (not (symbol? x2266)) (error-hook1065 (quote define-syntax) "invalid argument" x2266))) (let ((x2267 v2265)) (if (not (procedure? x2267)) (error-hook1065 (quote define-syntax) "invalid argument" x2267))) (global-extend1090 (quote macro) sym2264 v2265)))) (letrec ((match2272 (lambda (e2273 p2274 w2275 r2276 mod2277) (cond ((not r2276) #f) ((eq? p2274 (quote any)) (cons (wrap1120 e2273 w2275 mod2277) r2276)) ((syntax-object?1076 e2273) (match*2271 (let ((e2278 (syntax-object-expression1077 e2273))) (if (annotation? e2278) (annotation-expression e2278) e2278)) p2274 (join-wraps1111 w2275 (syntax-object-wrap1078 e2273)) r2276 (syntax-object-module1079 e2273))) (else (match*2271 (let ((e2279 e2273)) (if (annotation? e2279) (annotation-expression e2279) e2279)) p2274 w2275 r2276 mod2277))))) (match*2271 (lambda (e2280 p2281 w2282 r2283 mod2284) (cond ((null? p2281) (and (null? e2280) r2283)) ((pair? p2281) (and (pair? e2280) (match2272 (car e2280) (car p2281) w2282 (match2272 (cdr e2280) (cdr p2281) w2282 r2283 mod2284) mod2284))) ((eq? p2281 (quote each-any)) (let ((l2285 (match-each-any2269 e2280 w2282 mod2284))) (and l2285 (cons l2285 r2283)))) (else (let ((t2286 (vector-ref p2281 0))) (if (memv t2286 (quote (each))) (if (null? e2280) (match-empty2270 (vector-ref p2281 1) r2283) (let ((l2287 (match-each2268 e2280 (vector-ref p2281 1) w2282 mod2284))) (and l2287 (let collect2288 ((l2289 l2287)) (if (null? (car l2289)) r2283 (cons (map car l2289) (collect2288 (map cdr l2289)))))))) (if (memv t2286 (quote (free-id))) (and (id?1092 e2280) (free-id=?1115 (wrap1120 e2280 w2282 mod2284) (vector-ref p2281 1)) r2283) (if (memv t2286 (quote (atom))) (and (equal? (vector-ref p2281 1) (strip1139 e2280 w2282)) r2283) (if (memv t2286 (quote (vector))) (and (vector? e2280) (match2272 (vector->list e2280) (vector-ref p2281 1) w2282 r2283 mod2284))))))))))) (match-empty2270 (lambda (p2290 r2291) (cond ((null? p2290) r2291) ((eq? p2290 (quote any)) (cons (quote ()) r2291)) ((pair? p2290) (match-empty2270 (car p2290) (match-empty2270 (cdr p2290) r2291))) ((eq? p2290 (quote each-any)) (cons (quote ()) r2291)) (else (let ((t2292 (vector-ref p2290 0))) (if (memv t2292 (quote (each))) (match-empty2270 (vector-ref p2290 1) r2291) (if (memv t2292 (quote (free-id atom))) r2291 (if (memv t2292 (quote (vector))) (match-empty2270 (vector-ref p2290 1) r2291))))))))) (match-each-any2269 (lambda (e2293 w2294 mod2295) (cond ((annotation? e2293) (match-each-any2269 (annotation-expression e2293) w2294 mod2295)) ((pair? e2293) (let ((l2296 (match-each-any2269 (cdr e2293) w2294 mod2295))) (and l2296 (cons (wrap1120 (car e2293) w2294 mod2295) l2296)))) ((null? e2293) (quote ())) ((syntax-object?1076 e2293) (match-each-any2269 (syntax-object-expression1077 e2293) (join-wraps1111 w2294 (syntax-object-wrap1078 e2293)) mod2295)) (else #f)))) (match-each2268 (lambda (e2297 p2298 w2299 mod2300) (cond ((annotation? e2297) (match-each2268 (annotation-expression e2297) p2298 w2299 mod2300)) ((pair? e2297) (let ((first2301 (match2272 (car e2297) p2298 w2299 (quote ()) mod2300))) (and first2301 (let ((rest2302 (match-each2268 (cdr e2297) p2298 w2299 mod2300))) (and rest2302 (cons first2301 rest2302)))))) ((null? e2297) (quote ())) ((syntax-object?1076 e2297) (match-each2268 (syntax-object-expression1077 e2297) p2298 (join-wraps1111 w2299 (syntax-object-wrap1078 e2297)) (syntax-object-module1079 e2297))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2303 p2304) (cond ((eq? p2304 (quote any)) (list e2303)) ((syntax-object?1076 e2303) (match*2271 (let ((e2305 (syntax-object-expression1077 e2303))) (if (annotation? e2305) (annotation-expression e2305) e2305)) p2304 (syntax-object-wrap1078 e2303) (quote ()) (syntax-object-module1079 e2303))) (else (match*2271 (let ((e2306 e2303)) (if (annotation? e2306) (annotation-expression e2306) e2306)) p2304 (quote (())) (quote ()) #f))))) (set! sc-chi chi1128))))) +(install-global-transformer (quote with-syntax) (lambda (x2307) ((lambda (tmp2308) ((lambda (tmp2309) (if tmp2309 (apply (lambda (_2310 e12311 e22312) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12311 e22312))) tmp2309) ((lambda (tmp2314) (if tmp2314 (apply (lambda (_2315 out2316 in2317 e12318 e22319) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2317 (quote ()) (list out2316 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12318 e22319))))) tmp2314) ((lambda (tmp2321) (if tmp2321 (apply (lambda (_2322 out2323 in2324 e12325 e22326) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2324) (quote ()) (list out2323 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12325 e22326))))) tmp2321) (syntax-error tmp2308))) (syntax-dispatch tmp2308 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2308 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2308 (quote (any () any . each-any))))) x2307))) +(install-global-transformer (quote syntax-rules) (lambda (x2330) ((lambda (tmp2331) ((lambda (tmp2332) (if tmp2332 (apply (lambda (_2333 k2334 keyword2335 pattern2336 template2337) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2334 (map (lambda (tmp2340 tmp2339) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2339) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2340))) template2337 pattern2336)))))) tmp2332) (syntax-error tmp2331))) (syntax-dispatch tmp2331 (quote (any each-any . #(each ((any . any) any))))))) x2330))) +(install-global-transformer (quote let*) (lambda (x2341) ((lambda (tmp2342) ((lambda (tmp2343) (if (if tmp2343 (apply (lambda (let*2344 x2345 v2346 e12347 e22348) (andmap identifier? x2345)) tmp2343) #f) (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (let f2355 ((bindings2356 (map list x2351 v2352))) (if (null? bindings2356) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12353 e22354))) ((lambda (tmp2360) ((lambda (tmp2361) (if tmp2361 (apply (lambda (body2362 binding2363) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2363) body2362)) tmp2361) (syntax-error tmp2360))) (syntax-dispatch tmp2360 (quote (any any))))) (list (f2355 (cdr bindings2356)) (car bindings2356)))))) tmp2343) (syntax-error tmp2342))) (syntax-dispatch tmp2342 (quote (any #(each (any any)) any . each-any))))) x2341))) +(install-global-transformer (quote do) (lambda (orig-x2364) ((lambda (tmp2365) ((lambda (tmp2366) (if tmp2366 (apply (lambda (_2367 var2368 init2369 step2370 e02371 e12372 c2373) ((lambda (tmp2374) ((lambda (tmp2375) (if tmp2375 (apply (lambda (step2376) ((lambda (tmp2377) ((lambda (tmp2378) (if tmp2378 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2368 init2369) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02371) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2373 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2376))))))) tmp2378) ((lambda (tmp2383) (if tmp2383 (apply (lambda (e12384 e22385) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2368 init2369) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02371 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12384 e22385)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2373 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2376))))))) tmp2383) (syntax-error tmp2377))) (syntax-dispatch tmp2377 (quote (any . each-any)))))) (syntax-dispatch tmp2377 (quote ())))) e12372)) tmp2375) (syntax-error tmp2374))) (syntax-dispatch tmp2374 (quote each-any)))) (map (lambda (v2392 s2393) ((lambda (tmp2394) ((lambda (tmp2395) (if tmp2395 (apply (lambda () v2392) tmp2395) ((lambda (tmp2396) (if tmp2396 (apply (lambda (e2397) e2397) tmp2396) ((lambda (_2398) (syntax-error orig-x2364)) tmp2394))) (syntax-dispatch tmp2394 (quote (any)))))) (syntax-dispatch tmp2394 (quote ())))) s2393)) var2368 step2370))) tmp2366) (syntax-error tmp2365))) (syntax-dispatch tmp2365 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2364))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2401 (lambda (x2405 y2406) ((lambda (tmp2407) ((lambda (tmp2408) (if tmp2408 (apply (lambda (x2409 y2410) ((lambda (tmp2411) ((lambda (tmp2412) (if tmp2412 (apply (lambda (dy2413) ((lambda (tmp2414) ((lambda (tmp2415) (if tmp2415 (apply (lambda (dx2416) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2416 dy2413))) tmp2415) ((lambda (_2417) (if (null? dy2413) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2409) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2409 y2410))) tmp2414))) (syntax-dispatch tmp2414 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2409)) tmp2412) ((lambda (tmp2418) (if tmp2418 (apply (lambda (stuff2419) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2409 stuff2419))) tmp2418) ((lambda (else2420) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2409 y2410)) tmp2411))) (syntax-dispatch tmp2411 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2411 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2410)) tmp2408) (syntax-error tmp2407))) (syntax-dispatch tmp2407 (quote (any any))))) (list x2405 y2406)))) (quasiappend2402 (lambda (x2421 y2422) ((lambda (tmp2423) ((lambda (tmp2424) (if tmp2424 (apply (lambda (x2425 y2426) ((lambda (tmp2427) ((lambda (tmp2428) (if tmp2428 (apply (lambda () x2425) tmp2428) ((lambda (_2429) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2425 y2426)) tmp2427))) (syntax-dispatch tmp2427 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2426)) tmp2424) (syntax-error tmp2423))) (syntax-dispatch tmp2423 (quote (any any))))) (list x2421 y2422)))) (quasivector2403 (lambda (x2430) ((lambda (tmp2431) ((lambda (x2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda (x2435) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2435))) tmp2434) ((lambda (tmp2437) (if tmp2437 (apply (lambda (x2438) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2438)) tmp2437) ((lambda (_2440) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2432)) tmp2433))) (syntax-dispatch tmp2433 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2433 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2432)) tmp2431)) x2430))) (quasi2404 (lambda (p2441 lev2442) ((lambda (tmp2443) ((lambda (tmp2444) (if tmp2444 (apply (lambda (p2445) (if (= lev2442 0) p2445 (quasicons2401 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2404 (list p2445) (- lev2442 1))))) tmp2444) ((lambda (tmp2446) (if tmp2446 (apply (lambda (p2447 q2448) (if (= lev2442 0) (quasiappend2402 p2447 (quasi2404 q2448 lev2442)) (quasicons2401 (quasicons2401 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2404 (list p2447) (- lev2442 1))) (quasi2404 q2448 lev2442)))) tmp2446) ((lambda (tmp2449) (if tmp2449 (apply (lambda (p2450) (quasicons2401 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2404 (list p2450) (+ lev2442 1)))) tmp2449) ((lambda (tmp2451) (if tmp2451 (apply (lambda (p2452 q2453) (quasicons2401 (quasi2404 p2452 lev2442) (quasi2404 q2453 lev2442))) tmp2451) ((lambda (tmp2454) (if tmp2454 (apply (lambda (x2455) (quasivector2403 (quasi2404 x2455 lev2442))) tmp2454) ((lambda (p2457) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2457)) tmp2443))) (syntax-dispatch tmp2443 (quote #(vector each-any)))))) (syntax-dispatch tmp2443 (quote (any . any)))))) (syntax-dispatch tmp2443 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2443 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2443 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2441)))) (lambda (x2458) ((lambda (tmp2459) ((lambda (tmp2460) (if tmp2460 (apply (lambda (_2461 e2462) (quasi2404 e2462 0)) tmp2460) (syntax-error tmp2459))) (syntax-dispatch tmp2459 (quote (any any))))) x2458)))) +(install-global-transformer (quote include) (lambda (x2463) (letrec ((read-file2464 (lambda (fn2465 k2466) (let ((p2467 (open-input-file fn2465))) (let f2468 ((x2469 (read p2467))) (if (eof-object? x2469) (begin (close-input-port p2467) (quote ())) (cons (datum->syntax-object k2466 x2469) (f2468 (read p2467))))))))) ((lambda (tmp2470) ((lambda (tmp2471) (if tmp2471 (apply (lambda (k2472 filename2473) (let ((fn2474 (syntax-object->datum filename2473))) ((lambda (tmp2475) ((lambda (tmp2476) (if tmp2476 (apply (lambda (exp2477) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2477)) tmp2476) (syntax-error tmp2475))) (syntax-dispatch tmp2475 (quote each-any)))) (read-file2464 fn2474 k2472)))) tmp2471) (syntax-error tmp2470))) (syntax-dispatch tmp2470 (quote (any any))))) x2463)))) +(install-global-transformer (quote unquote) (lambda (x2479) ((lambda (tmp2480) ((lambda (tmp2481) (if tmp2481 (apply (lambda (_2482 e2483) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2483))) tmp2481) (syntax-error tmp2480))) (syntax-dispatch tmp2480 (quote (any any))))) x2479))) +(install-global-transformer (quote unquote-splicing) (lambda (x2484) ((lambda (tmp2485) ((lambda (tmp2486) (if tmp2486 (apply (lambda (_2487 e2488) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2488))) tmp2486) (syntax-error tmp2485))) (syntax-dispatch tmp2485 (quote (any any))))) x2484))) +(install-global-transformer (quote case) (lambda (x2489) ((lambda (tmp2490) ((lambda (tmp2491) (if tmp2491 (apply (lambda (_2492 e2493 m12494 m22495) ((lambda (tmp2496) ((lambda (body2497) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2493)) body2497)) tmp2496)) (let f2498 ((clause2499 m12494) (clauses2500 m22495)) (if (null? clauses2500) ((lambda (tmp2502) ((lambda (tmp2503) (if tmp2503 (apply (lambda (e12504 e22505) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12504 e22505))) tmp2503) ((lambda (tmp2507) (if tmp2507 (apply (lambda (k2508 e12509 e22510) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2508)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12509 e22510)))) tmp2507) ((lambda (_2513) (syntax-error x2489)) tmp2502))) (syntax-dispatch tmp2502 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2502 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2499) ((lambda (tmp2514) ((lambda (rest2515) ((lambda (tmp2516) ((lambda (tmp2517) (if tmp2517 (apply (lambda (k2518 e12519 e22520) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2518)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12519 e22520)) rest2515)) tmp2517) ((lambda (_2523) (syntax-error x2489)) tmp2516))) (syntax-dispatch tmp2516 (quote (each-any any . each-any))))) clause2499)) tmp2514)) (f2498 (car clauses2500) (cdr clauses2500))))))) tmp2491) (syntax-error tmp2490))) (syntax-dispatch tmp2490 (quote (any any any . each-any))))) x2489))) +(install-global-transformer (quote identifier-syntax) (lambda (x2524) ((lambda (tmp2525) ((lambda (tmp2526) (if tmp2526 (apply (lambda (_2527 e2528) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2528)) (list (cons _2527 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2528 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2526) (syntax-error tmp2525))) (syntax-dispatch tmp2525 (quote (any any))))) x2524))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 9b65339c8..5707d5f0d 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -350,6 +350,16 @@ ;; Properties are tied to variable objects (set-object-property! v '*sc-expander* binding)))) +(define remove-global-definition-hook + (lambda (symbol modname) + (let* ((module (if modname + (resolve-module modname) + (current-module))) + (v (module-local-variable module symbol))) + (if v + (let ((p (assq '*sc-expander* (object-properties v)))) + (set-object-properties! v (delq p (object-properties v)))))))) + (define get-global-definition-hook (lambda (symbol module) (let* ((module (if module @@ -1104,13 +1114,14 @@ mod)) ((displaced-lexical) (syntax-error (wrap value w mod) "identifier out of context")) + ((core macro module-ref) + (remove-global-definition-hook n mod) + (eval-if-c&e m + (build-global-definition s n (chi e r w mod) mod) + mod)) (else - (if (eq? type 'external-macro) - (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) - mod) - (syntax-error (wrap value w mod) - "cannot define keyword at top level")))))) + (syntax-error (wrap value w mod) + "cannot define keyword at top level"))))) (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) (define chi From 01c161ca11b19d56ce994cba477a8fc4aeb8ac43 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Apr 2009 13:30:23 +0200 Subject: [PATCH 065/375] it is alive!!!!! + concision + fix to compile-ghil * module/ice-9/boot-9.scm: Remove lots of debugging prints. Remove some already-deprecated attempts to load modules from shared libraries. * module/ice-9/psyntax.scm: If we have to create a variable for a syntactic binding, initialize its contents to a gensym. I'd like something more meaningful, but at least this way we can tell different macros apart. Only warn about missing modules if modules are booted. Chi the value part of a (set! (@ ...) ) expression -- whoops! * module/ice-9/psyntax-pp.scm: Regenerated. * module/language/glil.scm (parse-glil): Fix an unquoting error. * module/language/scheme/compile-ghil.scm: No need to import syncase, we gots it. Rework compiler to expand only once, with syncase, instead of incrementally. Fix define-scheme-transformer to work with syncase, by not referencing bare keywords. It works! --- module/ice-9/boot-9.scm | 8 ++---- module/ice-9/psyntax-pp.scm | 22 ++++++++--------- module/ice-9/psyntax.scm | 13 ++++++---- module/language/glil.scm | 2 +- module/language/scheme/compile-ghil.scm | 33 +++++++------------------ 5 files changed, 31 insertions(+), 47 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index e4c3cb2f8..ac1ffd66a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -187,7 +187,7 @@ ;; Until the module system is booted, this will be the current expander. (primitive-load-path "ice-9/psyntax-pp") -(define %pre-modules-transformer (lambda args (pk 'in args 'out (apply sc-expand args)))) +(define %pre-modules-transformer sc-expand) @@ -1860,7 +1860,6 @@ already) (autoload ;; Try to autoload the module, and recurse. - (pk name) (try-load-module name) (resolve-module name #f)) (else @@ -1894,9 +1893,7 @@ ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) (define (try-load-module name) - (or (begin-deprecated (try-module-linked name)) - (try-module-autoload name) - (begin-deprecated (try-module-dynamic-link name)))) + (try-module-autoload name)) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -2182,7 +2179,6 @@ module '(ice-9 q) '(make-q q-length))}." (and (not (autoload-done-or-in-progress? dir-hint name)) (let ((didit #f)) (define (load-file proc file) - (pk 'loading proc file) (save-module-excursion (lambda () (proc file))) (set! didit #t)) (dynamic-wind diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 9496275cb..befef849c 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list1141 (lambda (vars1340) (let lvl1341 ((vars1342 vars1340) (ls1343 (quote ())) (w1344 (quote (())))) (cond ((pair? vars1342) (lvl1341 (cdr vars1342) (cons (wrap1120 (car vars1342) w1344 #f) ls1343) w1344)) ((id?1092 vars1342) (cons (wrap1120 vars1342 w1344 #f) ls1343)) ((null? vars1342) ls1343) ((syntax-object?1076 vars1342) (lvl1341 (syntax-object-expression1077 vars1342) ls1343 (join-wraps1111 w1344 (syntax-object-wrap1078 vars1342)))) ((annotation? vars1342) (lvl1341 (annotation-expression vars1342) ls1343 w1344)) (else (cons vars1342 ls1343)))))) (gen-var1140 (lambda (id1345) (let ((id1346 (if (syntax-object?1076 id1345) (syntax-object-expression1077 id1345) id1345))) (if (annotation? id1346) (build-annotated1069 (annotation-source id1346) (gensym (symbol->string (annotation-expression id1346)))) (build-annotated1069 #f (gensym (symbol->string id1346))))))) (strip1139 (lambda (x1347 w1348) (if (memq (quote top) (wrap-marks1095 w1348)) (if (or (annotation? x1347) (and (pair? x1347) (annotation? (car x1347)))) (strip-annotation1138 x1347 #f) x1347) (let f1349 ((x1350 x1347)) (cond ((syntax-object?1076 x1350) (strip1139 (syntax-object-expression1077 x1350) (syntax-object-wrap1078 x1350))) ((pair? x1350) (let ((a1351 (f1349 (car x1350))) (d1352 (f1349 (cdr x1350)))) (if (and (eq? a1351 (car x1350)) (eq? d1352 (cdr x1350))) x1350 (cons a1351 d1352)))) ((vector? x1350) (let ((old1353 (vector->list x1350))) (let ((new1354 (map f1349 old1353))) (if (andmap eq? old1353 new1354) x1350 (list->vector new1354))))) (else x1350)))))) (strip-annotation1138 (lambda (x1355 parent1356) (cond ((pair? x1355) (let ((new1357 (cons #f #f))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1357)) (set-car! new1357 (strip-annotation1138 (car x1355) #f)) (set-cdr! new1357 (strip-annotation1138 (cdr x1355) #f)) new1357))) ((annotation? x1355) (or (annotation-stripped x1355) (strip-annotation1138 (annotation-expression x1355) x1355))) ((vector? x1355) (let ((new1358 (make-vector (vector-length x1355)))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1358)) (let loop1359 ((i1360 (- (vector-length x1355) 1))) (unless (fx<1062 i1360 0) (vector-set! new1358 i1360 (strip-annotation1138 (vector-ref x1355 i1360) #f)) (loop1359 (fx-1060 i1360 1)))) new1358))) (else x1355)))) (ellipsis?1137 (lambda (x1361) (and (nonsymbol-id?1091 x1361) (free-id=?1115 x1361 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1136 (lambda () (build-annotated1069 #f (list (build-annotated1069 #f (quote void)))))) (eval-local-transformer1135 (lambda (expanded1362 mod1363) (let ((p1364 (local-eval-hook1064 expanded1362 mod1363))) (if (procedure? p1364) p1364 (syntax-error p1364 "nonprocedure transformer"))))) (chi-local-syntax1134 (lambda (rec?1365 e1366 r1367 w1368 s1369 mod1370 k1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 id1375 val1376 e11377 e21378) (let ((ids1379 id1375)) (if (not (valid-bound-ids?1117 ids1379)) (syntax-error e1366 "duplicate bound keyword in") (let ((labels1381 (gen-labels1098 ids1379))) (let ((new-w1382 (make-binding-wrap1109 ids1379 labels1381 w1368))) (k1371 (cons e11377 e21378) (extend-env1086 labels1381 (let ((w1384 (if rec?1365 new-w1382 w1368)) (trans-r1385 (macros-only-env1088 r1367))) (map (lambda (x1386) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1386 trans-r1385 w1384 mod1370) mod1370))) val1376)) r1367) new-w1382 s1369 mod1370)))))) tmp1373) ((lambda (_1388) (syntax-error (source-wrap1121 e1366 w1368 s1369 mod1370))) tmp1372))) (syntax-dispatch tmp1372 (quote (any #(each (any any)) any . each-any))))) e1366))) (chi-lambda-clause1133 (lambda (e1389 c1390 r1391 w1392 mod1393 k1394) ((lambda (tmp1395) ((lambda (tmp1396) (if tmp1396 (apply (lambda (id1397 e11398 e21399) (let ((ids1400 id1397)) (if (not (valid-bound-ids?1117 ids1400)) (syntax-error e1389 "invalid parameter list in") (let ((labels1402 (gen-labels1098 ids1400)) (new-vars1403 (map gen-var1140 ids1400))) (k1394 new-vars1403 (chi-body1132 (cons e11398 e21399) e1389 (extend-var-env1087 labels1402 new-vars1403 r1391) (make-binding-wrap1109 ids1400 labels1402 w1392) mod1393)))))) tmp1396) ((lambda (tmp1405) (if tmp1405 (apply (lambda (ids1406 e11407 e21408) (let ((old-ids1409 (lambda-var-list1141 ids1406))) (if (not (valid-bound-ids?1117 old-ids1409)) (syntax-error e1389 "invalid parameter list in") (let ((labels1410 (gen-labels1098 old-ids1409)) (new-vars1411 (map gen-var1140 old-ids1409))) (k1394 (let f1412 ((ls11413 (cdr new-vars1411)) (ls21414 (car new-vars1411))) (if (null? ls11413) ls21414 (f1412 (cdr ls11413) (cons (car ls11413) ls21414)))) (chi-body1132 (cons e11407 e21408) e1389 (extend-var-env1087 labels1410 new-vars1411 r1391) (make-binding-wrap1109 old-ids1409 labels1410 w1392) mod1393)))))) tmp1405) ((lambda (_1416) (syntax-error e1389)) tmp1395))) (syntax-dispatch tmp1395 (quote (any any . each-any)))))) (syntax-dispatch tmp1395 (quote (each-any any . each-any))))) c1390))) (chi-body1132 (lambda (body1417 outer-form1418 r1419 w1420 mod1421) (let ((r1422 (cons (quote ("placeholder" placeholder)) r1419))) (let ((ribcage1423 (make-ribcage1099 (quote ()) (quote ()) (quote ())))) (let ((w1424 (make-wrap1094 (wrap-marks1095 w1420) (cons ribcage1423 (wrap-subst1096 w1420))))) (let parse1425 ((body1426 (map (lambda (x1432) (cons r1422 (wrap1120 x1432 w1424 mod1421))) body1417)) (ids1427 (quote ())) (labels1428 (quote ())) (vars1429 (quote ())) (vals1430 (quote ())) (bindings1431 (quote ()))) (if (null? body1426) (syntax-error outer-form1418 "no expressions in body") (let ((e1433 (cdar body1426)) (er1434 (caar body1426))) (call-with-values (lambda () (syntax-type1126 e1433 er1434 (quote (())) #f ribcage1423 mod1421)) (lambda (type1435 value1436 e1437 w1438 s1439 mod1440) (let ((t1441 type1435)) (if (memv t1441 (quote (define-form))) (let ((id1442 (wrap1120 value1436 w1438 mod1440)) (label1443 (gen-label1097))) (let ((var1444 (gen-var1140 id1442))) (begin (extend-ribcage!1108 ribcage1423 id1442 label1443) (parse1425 (cdr body1426) (cons id1442 ids1427) (cons label1443 labels1428) (cons var1444 vars1429) (cons (cons er1434 (wrap1120 e1437 w1438 mod1440)) vals1430) (cons (cons (quote lexical) var1444) bindings1431))))) (if (memv t1441 (quote (define-syntax-form))) (let ((id1445 (wrap1120 value1436 w1438 mod1440)) (label1446 (gen-label1097))) (begin (extend-ribcage!1108 ribcage1423 id1445 label1446) (parse1425 (cdr body1426) (cons id1445 ids1427) (cons label1446 labels1428) vars1429 vals1430 (cons (cons (quote macro) (cons er1434 (wrap1120 e1437 w1438 mod1440))) bindings1431)))) (if (memv t1441 (quote (begin-form))) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (_1449 e11450) (parse1425 (let f1451 ((forms1452 e11450)) (if (null? forms1452) (cdr body1426) (cons (cons er1434 (wrap1120 (car forms1452) w1438 mod1440)) (f1451 (cdr forms1452))))) ids1427 labels1428 vars1429 vals1430 bindings1431)) tmp1448) (syntax-error tmp1447))) (syntax-dispatch tmp1447 (quote (any . each-any))))) e1437) (if (memv t1441 (quote (local-syntax-form))) (chi-local-syntax1134 value1436 e1437 er1434 w1438 s1439 mod1440 (lambda (forms1454 er1455 w1456 s1457 mod1458) (parse1425 (let f1459 ((forms1460 forms1454)) (if (null? forms1460) (cdr body1426) (cons (cons er1455 (wrap1120 (car forms1460) w1456 mod1458)) (f1459 (cdr forms1460))))) ids1427 labels1428 vars1429 vals1430 bindings1431))) (if (null? ids1427) (build-sequence1071 #f (map (lambda (x1461) (chi1128 (cdr x1461) (car x1461) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))) (begin (if (not (valid-bound-ids?1117 ids1427)) (syntax-error outer-form1418 "invalid or duplicate identifier in definition")) (let loop1462 ((bs1463 bindings1431) (er-cache1464 #f) (r-cache1465 #f)) (if (not (null? bs1463)) (let ((b1466 (car bs1463))) (if (eq? (car b1466) (quote macro)) (let ((er1467 (cadr b1466))) (let ((r-cache1468 (if (eq? er1467 er-cache1464) r-cache1465 (macros-only-env1088 er1467)))) (begin (set-cdr! b1466 (eval-local-transformer1135 (chi1128 (cddr b1466) r-cache1468 (quote (())) mod1440) mod1440)) (loop1462 (cdr bs1463) er1467 r-cache1468)))) (loop1462 (cdr bs1463) er-cache1464 r-cache1465))))) (set-cdr! r1422 (extend-env1086 labels1428 bindings1431 (cdr r1422))) (build-letrec1074 #f vars1429 (map (lambda (x1469) (chi1128 (cdr x1469) (car x1469) (quote (())) mod1440)) vals1430) (build-sequence1071 #f (map (lambda (x1470) (chi1128 (cdr x1470) (car x1470) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))))))))))))))))))))) (chi-macro1131 (lambda (p1471 e1472 r1473 w1474 rib1475 mod1476) (letrec ((rebuild-macro-output1477 (lambda (x1478 m1479) (cond ((pair? x1478) (cons (rebuild-macro-output1477 (car x1478) m1479) (rebuild-macro-output1477 (cdr x1478) m1479))) ((syntax-object?1076 x1478) (let ((w1480 (syntax-object-wrap1078 x1478))) (let ((ms1481 (wrap-marks1095 w1480)) (s1482 (wrap-subst1096 w1480))) (if (and (pair? ms1481) (eq? (car ms1481) #f)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cdr ms1481) (if rib1475 (cons rib1475 (cdr s1482)) (cdr s1482))) (syntax-object-module1079 x1478)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cons m1479 ms1481) (if rib1475 (cons rib1475 (cons (quote shift) s1482)) (cons (quote shift) s1482))) (module-name (procedure-module p1471))))))) ((vector? x1478) (let ((n1483 (vector-length x1478))) (let ((v1484 (make-vector n1483))) (let doloop1485 ((i1486 0)) (if (fx=1061 i1486 n1483) v1484 (begin (vector-set! v1484 i1486 (rebuild-macro-output1477 (vector-ref x1478 i1486) m1479)) (doloop1485 (fx+1059 i1486 1)))))))) ((symbol? x1478) (syntax-error x1478 "encountered raw symbol in macro output")) (else x1478))))) (rebuild-macro-output1477 (p1471 (wrap1120 e1472 (anti-mark1107 w1474) mod1476)) (string #\m))))) (chi-application1130 (lambda (x1487 e1488 r1489 w1490 s1491 mod1492) ((lambda (tmp1493) ((lambda (tmp1494) (if tmp1494 (apply (lambda (e01495 e11496) (build-annotated1069 s1491 (cons x1487 (map (lambda (e1497) (chi1128 e1497 r1489 w1490 mod1492)) e11496)))) tmp1494) (syntax-error tmp1493))) (syntax-dispatch tmp1493 (quote (any . each-any))))) e1488))) (chi-expr1129 (lambda (type1499 value1500 e1501 r1502 w1503 s1504 mod1505) (let ((t1506 type1499)) (if (memv t1506 (quote (lexical))) (build-annotated1069 s1504 value1500) (if (memv t1506 (quote (core external-macro))) (value1500 e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (module-ref))) (call-with-values (lambda () (value1500 e1501)) (lambda (id1507 mod1508) (build-annotated1069 s1504 (make-module-ref mod1508 id1507 #f)))) (if (memv t1506 (quote (lexical-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) value1500) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (global-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) (make-module-ref (if (syntax-object?1076 (car e1501)) (syntax-object-module1079 (car e1501)) mod1505) value1500 #f)) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (constant))) (build-data1070 s1504 (strip1139 (source-wrap1121 e1501 w1503 s1504 mod1505) (quote (())))) (if (memv t1506 (quote (global))) (build-annotated1069 s1504 (make-module-ref mod1505 value1500 #f)) (if (memv t1506 (quote (call))) (chi-application1130 (chi1128 (car e1501) r1502 w1503 mod1505) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (begin-form))) ((lambda (tmp1509) ((lambda (tmp1510) (if tmp1510 (apply (lambda (_1511 e11512 e21513) (chi-sequence1122 (cons e11512 e21513) r1502 w1503 s1504 mod1505)) tmp1510) (syntax-error tmp1509))) (syntax-dispatch tmp1509 (quote (any any . each-any))))) e1501) (if (memv t1506 (quote (local-syntax-form))) (chi-local-syntax1134 value1500 e1501 r1502 w1503 s1504 mod1505 chi-sequence1122) (if (memv t1506 (quote (eval-when-form))) ((lambda (tmp1515) ((lambda (tmp1516) (if tmp1516 (apply (lambda (_1517 x1518 e11519 e21520) (let ((when-list1521 (chi-when-list1125 e1501 x1518 w1503))) (if (memq (quote eval) when-list1521) (chi-sequence1122 (cons e11519 e21520) r1502 w1503 s1504 mod1505) (chi-void1136)))) tmp1516) (syntax-error tmp1515))) (syntax-dispatch tmp1515 (quote (any each-any any . each-any))))) e1501) (if (memv t1506 (quote (define-form define-syntax-form))) (syntax-error (wrap1120 value1500 w1503 mod1505) "invalid context for definition of") (if (memv t1506 (quote (syntax))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to pattern variable outside syntax form") (if (memv t1506 (quote (displaced-lexical))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to identifier outside its scope") (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505))))))))))))))))))) (chi1128 (lambda (e1524 r1525 w1526 mod1527) (call-with-values (lambda () (syntax-type1126 e1524 r1525 w1526 #f #f mod1527)) (lambda (type1528 value1529 e1530 w1531 s1532 mod1533) (chi-expr1129 type1528 value1529 e1530 r1525 w1531 s1532 mod1533))))) (chi-top1127 (lambda (e1534 r1535 w1536 m1537 esew1538 mod1539) (call-with-values (lambda () (syntax-type1126 e1534 r1535 w1536 #f #f mod1539)) (lambda (type1547 value1548 e1549 w1550 s1551 mod1552) (let ((t1553 type1547)) (if (memv t1553 (quote (begin-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556) (chi-void1136)) tmp1555) ((lambda (tmp1557) (if tmp1557 (apply (lambda (_1558 e11559 e21560) (chi-top-sequence1123 (cons e11559 e21560) r1535 w1550 s1551 m1537 esew1538 mod1552)) tmp1557) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any any . each-any)))))) (syntax-dispatch tmp1554 (quote (any))))) e1549) (if (memv t1553 (quote (local-syntax-form))) (chi-local-syntax1134 value1548 e1549 r1535 w1550 s1551 mod1552 (lambda (body1562 r1563 w1564 s1565 mod1566) (chi-top-sequence1123 body1562 r1563 w1564 s1565 m1537 esew1538 mod1566))) (if (memv t1553 (quote (eval-when-form))) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569 x1570 e11571 e21572) (let ((when-list1573 (chi-when-list1125 e1549 x1570 w1550)) (body1574 (cons e11571 e21572))) (cond ((eq? m1537 (quote e)) (if (memq (quote eval) when-list1573) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) (chi-void1136))) ((memq (quote load) when-list1573) (if (or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c&e) (quote (compile load)) mod1552) (if (memq m1537 (quote (c c&e))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c) (quote (load)) mod1552) (chi-void1136)))) ((or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (top-level-eval-hook1063 (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) mod1552) (chi-void1136)) (else (chi-void1136))))) tmp1568) (syntax-error tmp1567))) (syntax-dispatch tmp1567 (quote (any each-any any . each-any))))) e1549) (if (memv t1553 (quote (define-syntax-form))) (let ((n1577 (id-var-name1114 value1548 w1550)) (r1578 (macros-only-env1088 r1535))) (let ((t1579 m1537)) (if (memv t1579 (quote (c))) (if (memq (quote compile) esew1538) (let ((e1580 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1580 mod1552) (if (memq (quote load) esew1538) e1580 (chi-void1136)))) (if (memq (quote load) esew1538) (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) (chi-void1136))) (if (memv t1579 (quote (c&e))) (let ((e1581 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1581 mod1552) e1581)) (begin (if (memq (quote eval) esew1538) (top-level-eval-hook1063 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) mod1552)) (chi-void1136)))))) (if (memv t1553 (quote (define-form))) (let ((n1582 (id-var-name1114 value1548 w1550))) (let ((type1583 (binding-type1084 (lookup1089 n1582 r1535 mod1552)))) (let ((t1584 type1583)) (if (memv t1584 (quote (global))) (let ((x1585 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1585 mod1552)) x1585)) (if (memv t1584 (quote (displaced-lexical))) (syntax-error (wrap1120 value1548 w1550 mod1552) "identifier out of context") (if (memv t1584 (quote (core macro module-ref))) (begin (remove-global-definition-hook1067 n1582 mod1552) (let ((x1586 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1586 mod1552)) x1586))) (syntax-error (wrap1120 value1548 w1550 mod1552) "cannot define keyword at top level"))))))) (let ((x1587 (chi-expr1129 type1547 value1548 e1549 r1535 w1550 s1551 mod1552))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1587 mod1552)) x1587)))))))))))) (syntax-type1126 (lambda (e1588 r1589 w1590 s1591 rib1592 mod1593) (cond ((symbol? e1588) (let ((n1594 (id-var-name1114 e1588 w1590))) (let ((b1595 (lookup1089 n1594 r1589 mod1593))) (let ((type1596 (binding-type1084 b1595))) (let ((t1597 type1596)) (if (memv t1597 (quote (lexical))) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (global))) (values type1596 n1594 e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1595) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593))))))))) ((pair? e1588) (let ((first1598 (car e1588))) (if (id?1092 first1598) (let ((n1599 (id-var-name1114 first1598 w1590))) (let ((b1600 (lookup1089 n1599 r1589 (or (and (syntax-object?1076 first1598) (syntax-object-module1079 first1598)) mod1593)))) (let ((type1601 (binding-type1084 b1600))) (let ((t1602 type1601)) (if (memv t1602 (quote (lexical))) (values (quote lexical-call) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (global))) (values (quote global-call) n1599 e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1600) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (if (memv t1602 (quote (core external-macro module-ref))) (values type1601 (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (begin))) (values (quote begin-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (eval-when))) (values (quote eval-when-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (define))) ((lambda (tmp1603) ((lambda (tmp1604) (if (if tmp1604 (apply (lambda (_1605 name1606 val1607) (id?1092 name1606)) tmp1604) #f) (apply (lambda (_1608 name1609 val1610) (values (quote define-form) name1609 val1610 w1590 s1591 mod1593)) tmp1604) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 name1613 args1614 e11615 e21616) (and (id?1092 name1613) (valid-bound-ids?1117 (lambda-var-list1141 args1614)))) tmp1611) #f) (apply (lambda (_1617 name1618 args1619 e11620 e21621) (values (quote define-form) (wrap1120 name1618 w1590 mod1593) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1120 (cons args1619 (cons e11620 e21621)) w1590 mod1593)) (quote (())) s1591 mod1593)) tmp1611) ((lambda (tmp1623) (if (if tmp1623 (apply (lambda (_1624 name1625) (id?1092 name1625)) tmp1623) #f) (apply (lambda (_1626 name1627) (values (quote define-form) (wrap1120 name1627 w1590 mod1593) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1591 mod1593)) tmp1623) (syntax-error tmp1603))) (syntax-dispatch tmp1603 (quote (any any)))))) (syntax-dispatch tmp1603 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1603 (quote (any any any))))) e1588) (if (memv t1602 (quote (define-syntax))) ((lambda (tmp1628) ((lambda (tmp1629) (if (if tmp1629 (apply (lambda (_1630 name1631 val1632) (id?1092 name1631)) tmp1629) #f) (apply (lambda (_1633 name1634 val1635) (values (quote define-syntax-form) name1634 val1635 w1590 s1591 mod1593)) tmp1629) (syntax-error tmp1628))) (syntax-dispatch tmp1628 (quote (any any any))))) e1588) (values (quote call) #f e1588 w1590 s1591 mod1593)))))))))))))) (values (quote call) #f e1588 w1590 s1591 mod1593)))) ((syntax-object?1076 e1588) (syntax-type1126 (syntax-object-expression1077 e1588) r1589 (join-wraps1111 w1590 (syntax-object-wrap1078 e1588)) #f rib1592 (or (syntax-object-module1079 e1588) mod1593))) ((annotation? e1588) (syntax-type1126 (annotation-expression e1588) r1589 w1590 (annotation-source e1588) rib1592 mod1593)) ((self-evaluating? e1588) (values (quote constant) #f e1588 w1590 s1591 mod1593)) (else (values (quote other) #f e1588 w1590 s1591 mod1593))))) (chi-when-list1125 (lambda (e1636 when-list1637 w1638) (let f1639 ((when-list1640 when-list1637) (situations1641 (quote ()))) (if (null? when-list1640) situations1641 (f1639 (cdr when-list1640) (cons (let ((x1642 (car when-list1640))) (cond ((free-id=?1115 x1642 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1115 x1642 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1115 x1642 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1120 x1642 w1638 #f) "invalid eval-when situation")))) situations1641)))))) (chi-install-global1124 (lambda (name1643 e1644) (build-annotated1069 #f (list (build-annotated1069 #f (quote install-global-transformer)) (build-data1070 #f name1643) e1644)))) (chi-top-sequence1123 (lambda (body1645 r1646 w1647 s1648 m1649 esew1650 mod1651) (build-sequence1071 s1648 (let dobody1652 ((body1653 body1645) (r1654 r1646) (w1655 w1647) (m1656 m1649) (esew1657 esew1650) (mod1658 mod1651)) (if (null? body1653) (quote ()) (let ((first1659 (chi-top1127 (car body1653) r1654 w1655 m1656 esew1657 mod1658))) (cons first1659 (dobody1652 (cdr body1653) r1654 w1655 m1656 esew1657 mod1658)))))))) (chi-sequence1122 (lambda (body1660 r1661 w1662 s1663 mod1664) (build-sequence1071 s1663 (let dobody1665 ((body1666 body1660) (r1667 r1661) (w1668 w1662) (mod1669 mod1664)) (if (null? body1666) (quote ()) (let ((first1670 (chi1128 (car body1666) r1667 w1668 mod1669))) (cons first1670 (dobody1665 (cdr body1666) r1667 w1668 mod1669)))))))) (source-wrap1121 (lambda (x1671 w1672 s1673 defmod1674) (wrap1120 (if s1673 (make-annotation x1671 s1673 #f) x1671) w1672 defmod1674))) (wrap1120 (lambda (x1675 w1676 defmod1677) (cond ((and (null? (wrap-marks1095 w1676)) (null? (wrap-subst1096 w1676))) x1675) ((syntax-object?1076 x1675) (make-syntax-object1075 (syntax-object-expression1077 x1675) (join-wraps1111 w1676 (syntax-object-wrap1078 x1675)) (syntax-object-module1079 x1675))) ((null? x1675) x1675) (else (make-syntax-object1075 x1675 w1676 defmod1677))))) (bound-id-member?1119 (lambda (x1678 list1679) (and (not (null? list1679)) (or (bound-id=?1116 x1678 (car list1679)) (bound-id-member?1119 x1678 (cdr list1679)))))) (distinct-bound-ids?1118 (lambda (ids1680) (let distinct?1681 ((ids1682 ids1680)) (or (null? ids1682) (and (not (bound-id-member?1119 (car ids1682) (cdr ids1682))) (distinct?1681 (cdr ids1682))))))) (valid-bound-ids?1117 (lambda (ids1683) (and (let all-ids?1684 ((ids1685 ids1683)) (or (null? ids1685) (and (id?1092 (car ids1685)) (all-ids?1684 (cdr ids1685))))) (distinct-bound-ids?1118 ids1683)))) (bound-id=?1116 (lambda (i1686 j1687) (if (and (syntax-object?1076 i1686) (syntax-object?1076 j1687)) (and (eq? (let ((e1688 (syntax-object-expression1077 i1686))) (if (annotation? e1688) (annotation-expression e1688) e1688)) (let ((e1689 (syntax-object-expression1077 j1687))) (if (annotation? e1689) (annotation-expression e1689) e1689))) (same-marks?1113 (wrap-marks1095 (syntax-object-wrap1078 i1686)) (wrap-marks1095 (syntax-object-wrap1078 j1687)))) (eq? (let ((e1690 i1686)) (if (annotation? e1690) (annotation-expression e1690) e1690)) (let ((e1691 j1687)) (if (annotation? e1691) (annotation-expression e1691) e1691)))))) (free-id=?1115 (lambda (i1692 j1693) (and (eq? (let ((x1694 i1692)) (let ((e1695 (if (syntax-object?1076 x1694) (syntax-object-expression1077 x1694) x1694))) (if (annotation? e1695) (annotation-expression e1695) e1695))) (let ((x1696 j1693)) (let ((e1697 (if (syntax-object?1076 x1696) (syntax-object-expression1077 x1696) x1696))) (if (annotation? e1697) (annotation-expression e1697) e1697)))) (eq? (id-var-name1114 i1692 (quote (()))) (id-var-name1114 j1693 (quote (()))))))) (id-var-name1114 (lambda (id1698 w1699) (letrec ((search-vector-rib1702 (lambda (sym1708 subst1709 marks1710 symnames1711 ribcage1712) (let ((n1713 (vector-length symnames1711))) (let f1714 ((i1715 0)) (cond ((fx=1061 i1715 n1713) (search1700 sym1708 (cdr subst1709) marks1710)) ((and (eq? (vector-ref symnames1711 i1715) sym1708) (same-marks?1113 marks1710 (vector-ref (ribcage-marks1102 ribcage1712) i1715))) (values (vector-ref (ribcage-labels1103 ribcage1712) i1715) marks1710)) (else (f1714 (fx+1059 i1715 1)))))))) (search-list-rib1701 (lambda (sym1716 subst1717 marks1718 symnames1719 ribcage1720) (let f1721 ((symnames1722 symnames1719) (i1723 0)) (cond ((null? symnames1722) (search1700 sym1716 (cdr subst1717) marks1718)) ((and (eq? (car symnames1722) sym1716) (same-marks?1113 marks1718 (list-ref (ribcage-marks1102 ribcage1720) i1723))) (values (list-ref (ribcage-labels1103 ribcage1720) i1723) marks1718)) (else (f1721 (cdr symnames1722) (fx+1059 i1723 1))))))) (search1700 (lambda (sym1724 subst1725 marks1726) (if (null? subst1725) (values #f marks1726) (let ((fst1727 (car subst1725))) (if (eq? fst1727 (quote shift)) (search1700 sym1724 (cdr subst1725) (cdr marks1726)) (let ((symnames1728 (ribcage-symnames1101 fst1727))) (if (vector? symnames1728) (search-vector-rib1702 sym1724 subst1725 marks1726 symnames1728 fst1727) (search-list-rib1701 sym1724 subst1725 marks1726 symnames1728 fst1727))))))))) (cond ((symbol? id1698) (or (call-with-values (lambda () (search1700 id1698 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1730 . ignore1729) x1730)) id1698)) ((syntax-object?1076 id1698) (let ((id1731 (let ((e1733 (syntax-object-expression1077 id1698))) (if (annotation? e1733) (annotation-expression e1733) e1733))) (w11732 (syntax-object-wrap1078 id1698))) (let ((marks1734 (join-marks1112 (wrap-marks1095 w1699) (wrap-marks1095 w11732)))) (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w1699) marks1734)) (lambda (new-id1735 marks1736) (or new-id1735 (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w11732) marks1736)) (lambda (x1738 . ignore1737) x1738)) id1731)))))) ((annotation? id1698) (let ((id1739 (let ((e1740 id1698)) (if (annotation? e1740) (annotation-expression e1740) e1740)))) (or (call-with-values (lambda () (search1700 id1739 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1742 . ignore1741) x1742)) id1739))) (else (error-hook1065 (quote id-var-name) "invalid id" id1698)))))) (same-marks?1113 (lambda (x1743 y1744) (or (eq? x1743 y1744) (and (not (null? x1743)) (not (null? y1744)) (eq? (car x1743) (car y1744)) (same-marks?1113 (cdr x1743) (cdr y1744)))))) (join-marks1112 (lambda (m11745 m21746) (smart-append1110 m11745 m21746))) (join-wraps1111 (lambda (w11747 w21748) (let ((m11749 (wrap-marks1095 w11747)) (s11750 (wrap-subst1096 w11747))) (if (null? m11749) (if (null? s11750) w21748 (make-wrap1094 (wrap-marks1095 w21748) (smart-append1110 s11750 (wrap-subst1096 w21748)))) (make-wrap1094 (smart-append1110 m11749 (wrap-marks1095 w21748)) (smart-append1110 s11750 (wrap-subst1096 w21748))))))) (smart-append1110 (lambda (m11751 m21752) (if (null? m21752) m11751 (append m11751 m21752)))) (make-binding-wrap1109 (lambda (ids1753 labels1754 w1755) (if (null? ids1753) w1755 (make-wrap1094 (wrap-marks1095 w1755) (cons (let ((labelvec1756 (list->vector labels1754))) (let ((n1757 (vector-length labelvec1756))) (let ((symnamevec1758 (make-vector n1757)) (marksvec1759 (make-vector n1757))) (begin (let f1760 ((ids1761 ids1753) (i1762 0)) (if (not (null? ids1761)) (call-with-values (lambda () (id-sym-name&marks1093 (car ids1761) w1755)) (lambda (symname1763 marks1764) (begin (vector-set! symnamevec1758 i1762 symname1763) (vector-set! marksvec1759 i1762 marks1764) (f1760 (cdr ids1761) (fx+1059 i1762 1))))))) (make-ribcage1099 symnamevec1758 marksvec1759 labelvec1756))))) (wrap-subst1096 w1755)))))) (extend-ribcage!1108 (lambda (ribcage1765 id1766 label1767) (begin (set-ribcage-symnames!1104 ribcage1765 (cons (let ((e1768 (syntax-object-expression1077 id1766))) (if (annotation? e1768) (annotation-expression e1768) e1768)) (ribcage-symnames1101 ribcage1765))) (set-ribcage-marks!1105 ribcage1765 (cons (wrap-marks1095 (syntax-object-wrap1078 id1766)) (ribcage-marks1102 ribcage1765))) (set-ribcage-labels!1106 ribcage1765 (cons label1767 (ribcage-labels1103 ribcage1765)))))) (anti-mark1107 (lambda (w1769) (make-wrap1094 (cons #f (wrap-marks1095 w1769)) (cons (quote shift) (wrap-subst1096 w1769))))) (set-ribcage-labels!1106 (lambda (x1770 update1771) (vector-set! x1770 3 update1771))) (set-ribcage-marks!1105 (lambda (x1772 update1773) (vector-set! x1772 2 update1773))) (set-ribcage-symnames!1104 (lambda (x1774 update1775) (vector-set! x1774 1 update1775))) (ribcage-labels1103 (lambda (x1776) (vector-ref x1776 3))) (ribcage-marks1102 (lambda (x1777) (vector-ref x1777 2))) (ribcage-symnames1101 (lambda (x1778) (vector-ref x1778 1))) (ribcage?1100 (lambda (x1779) (and (vector? x1779) (= (vector-length x1779) 4) (eq? (vector-ref x1779 0) (quote ribcage))))) (make-ribcage1099 (lambda (symnames1780 marks1781 labels1782) (vector (quote ribcage) symnames1780 marks1781 labels1782))) (gen-labels1098 (lambda (ls1783) (if (null? ls1783) (quote ()) (cons (gen-label1097) (gen-labels1098 (cdr ls1783)))))) (gen-label1097 (lambda () (string #\i))) (wrap-subst1096 cdr) (wrap-marks1095 car) (make-wrap1094 cons) (id-sym-name&marks1093 (lambda (x1784 w1785) (if (syntax-object?1076 x1784) (values (let ((e1786 (syntax-object-expression1077 x1784))) (if (annotation? e1786) (annotation-expression e1786) e1786)) (join-marks1112 (wrap-marks1095 w1785) (wrap-marks1095 (syntax-object-wrap1078 x1784)))) (values (let ((e1787 x1784)) (if (annotation? e1787) (annotation-expression e1787) e1787)) (wrap-marks1095 w1785))))) (id?1092 (lambda (x1788) (cond ((symbol? x1788) #t) ((syntax-object?1076 x1788) (symbol? (let ((e1789 (syntax-object-expression1077 x1788))) (if (annotation? e1789) (annotation-expression e1789) e1789)))) ((annotation? x1788) (symbol? (annotation-expression x1788))) (else #f)))) (nonsymbol-id?1091 (lambda (x1790) (and (syntax-object?1076 x1790) (symbol? (let ((e1791 (syntax-object-expression1077 x1790))) (if (annotation? e1791) (annotation-expression e1791) e1791)))))) (global-extend1090 (lambda (type1792 sym1793 val1794) (put-global-definition-hook1066 sym1793 (cons type1792 val1794) (module-name (current-module))))) (lookup1089 (lambda (x1795 r1796 mod1797) (cond ((assq x1795 r1796) => cdr) ((symbol? x1795) (or (get-global-definition-hook1068 x1795 mod1797) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1088 (lambda (r1798) (if (null? r1798) (quote ()) (let ((a1799 (car r1798))) (if (eq? (cadr a1799) (quote macro)) (cons a1799 (macros-only-env1088 (cdr r1798))) (macros-only-env1088 (cdr r1798))))))) (extend-var-env1087 (lambda (labels1800 vars1801 r1802) (if (null? labels1800) r1802 (extend-var-env1087 (cdr labels1800) (cdr vars1801) (cons (cons (car labels1800) (cons (quote lexical) (car vars1801))) r1802))))) (extend-env1086 (lambda (labels1803 bindings1804 r1805) (if (null? labels1803) r1805 (extend-env1086 (cdr labels1803) (cdr bindings1804) (cons (cons (car labels1803) (car bindings1804)) r1805))))) (binding-value1085 cdr) (binding-type1084 car) (source-annotation1083 (lambda (x1806) (cond ((annotation? x1806) (annotation-source x1806)) ((syntax-object?1076 x1806) (source-annotation1083 (syntax-object-expression1077 x1806))) (else #f)))) (set-syntax-object-module!1082 (lambda (x1807 update1808) (vector-set! x1807 3 update1808))) (set-syntax-object-wrap!1081 (lambda (x1809 update1810) (vector-set! x1809 2 update1810))) (set-syntax-object-expression!1080 (lambda (x1811 update1812) (vector-set! x1811 1 update1812))) (syntax-object-module1079 (lambda (x1813) (vector-ref x1813 3))) (syntax-object-wrap1078 (lambda (x1814) (vector-ref x1814 2))) (syntax-object-expression1077 (lambda (x1815) (vector-ref x1815 1))) (syntax-object?1076 (lambda (x1816) (and (vector? x1816) (= (vector-length x1816) 4) (eq? (vector-ref x1816 0) (quote syntax-object))))) (make-syntax-object1075 (lambda (expression1817 wrap1818 module1819) (vector (quote syntax-object) expression1817 wrap1818 module1819))) (build-letrec1074 (lambda (src1820 vars1821 val-exps1822 body-exp1823) (if (null? vars1821) (build-annotated1069 src1820 body-exp1823) (build-annotated1069 src1820 (list (quote letrec) (map list vars1821 val-exps1822) body-exp1823))))) (build-named-let1073 (lambda (src1824 vars1825 val-exps1826 body-exp1827) (if (null? vars1825) (build-annotated1069 src1824 body-exp1827) (build-annotated1069 src1824 (list (quote let) (car vars1825) (map list (cdr vars1825) val-exps1826) body-exp1827))))) (build-let1072 (lambda (src1828 vars1829 val-exps1830 body-exp1831) (if (null? vars1829) (build-annotated1069 src1828 body-exp1831) (build-annotated1069 src1828 (list (quote let) (map list vars1829 val-exps1830) body-exp1831))))) (build-sequence1071 (lambda (src1832 exps1833) (if (null? (cdr exps1833)) (build-annotated1069 src1832 (car exps1833)) (build-annotated1069 src1832 (cons (quote begin) exps1833))))) (build-data1070 (lambda (src1834 exp1835) (if (and (self-evaluating? exp1835) (not (vector? exp1835))) (build-annotated1069 src1834 exp1835) (build-annotated1069 src1834 (list (quote quote) exp1835))))) (build-annotated1069 (lambda (src1836 exp1837) (if (and src1836 (not (annotation? exp1837))) (make-annotation exp1837 src1836 #t) exp1837))) (get-global-definition-hook1068 (lambda (symbol1838 module1839) (let ((module1840 (if module1839 (resolve-module module1839) (warn "wha" symbol1838 (current-module))))) (let ((v1841 (module-variable module1840 symbol1838))) (and v1841 (or (object-property v1841 (quote *sc-expander*)) (and (variable-bound? v1841) (macro? (variable-ref v1841)) (macro-transformer (variable-ref v1841)) guile-macro))))))) (remove-global-definition-hook1067 (lambda (symbol1842 modname1843) (let ((module1844 (if modname1843 (resolve-module modname1843) (current-module)))) (let ((v1845 (module-local-variable module1844 symbol1842))) (if v1845 (let ((p1846 (assq (quote *sc-expander*) (object-properties v1845)))) (set-object-properties! v1845 (delq p1846 (object-properties v1845))))))))) (put-global-definition-hook1066 (lambda (symbol1847 binding1848 modname1849) (let ((module1850 (if modname1849 (resolve-module modname1849) (current-module)))) (let ((v1851 (or (module-variable module1850 symbol1847) (let ((v1852 (make-variable (quote sc-macro)))) (begin (module-add! module1850 symbol1847 v1852) v1852))))) (begin (if (not (variable-bound? v1851)) (variable-set! v1851 (gensym))) (set-object-property! v1851 (quote *sc-expander*) binding1848)))))) (error-hook1065 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1064 (lambda (x1856 mod1857) (eval (list noexpand1058 x1856) (if mod1857 (resolve-module mod1857) (interaction-environment))))) (top-level-eval-hook1063 (lambda (x1858 mod1859) (eval (list noexpand1058 x1858) (if mod1859 (resolve-module mod1859) (interaction-environment))))) (fx<1062 <) (fx=1061 =) (fx-1060 -) (fx+1059 +) (noexpand1058 "noexpand")) (begin (global-extend1090 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1090 (quote local-syntax) (quote let-syntax) #f) (global-extend1090 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1117 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1114 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1084 (lookup1089 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-error (source-wrap1121 id1881 w1862 s1863 mod1864) "identifier out of context")))) var1874 names1878) (chi-body1132 (cons e11876 e21877) (source-wrap1121 e1860 w1862 s1863 mod1864) (extend-env1086 names1878 (let ((trans-r1886 (macros-only-env1088 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-error (source-wrap1121 e1860 w1862 s1863 mod1864))) tmp1865))) (syntax-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1090 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1070 s1893 (strip1139 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-error (source-wrap1121 e1890 w1892 s1893 mod1894))) tmp1895))) (syntax-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1090 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1069 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1069 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1070 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1069 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1069 #f (cons (if (fx=1061 (length ls1910) 2) (build-annotated1069 #f (quote map)) (build-annotated1069 #f (quote map))) ls1910))) (build-annotated1069 #f (cons (build-annotated1069 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1061 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-error src1927 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1060 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1140 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1092 e1936) (let ((label1941 (id-var-name1114 e1936 (quote (()))))) (let ((b1942 (lookup1089 label1941 r1937 mod1940))) (if (eq? (binding-type1084 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1085 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-error src1935 "misplaced ellipsis in syntax form") (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) (syntax-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) (syntax-dispatch tmp1946 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1946 (quote (any . any)))))) (syntax-dispatch tmp1946 (quote (any any . any)))))) (syntax-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1121 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1137 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-error e1999)) tmp2000))) (syntax-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1090 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1133 (source-wrap1121 e2007 w2009 s2010 mod2011) c2015 r2008 w2009 mod2011 (lambda (vars2016 body2017) (build-annotated1069 s2010 (list (quote lambda) vars2016 body2017))))) tmp2013) (syntax-error tmp2012))) (syntax-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1090 (quote core) (quote let) (letrec ((chi-let2018 (lambda (e2019 r2020 w2021 s2022 mod2023 constructor2024 ids2025 vals2026 exps2027) (if (not (valid-bound-ids?1117 ids2025)) (syntax-error e2019 "duplicate bound variable in") (let ((labels2028 (gen-labels1098 ids2025)) (new-vars2029 (map gen-var1140 ids2025))) (let ((nw2030 (make-binding-wrap1109 ids2025 labels2028 w2021)) (nr2031 (extend-var-env1087 labels2028 new-vars2029 r2020))) (constructor2024 s2022 new-vars2029 (map (lambda (x2032) (chi1128 x2032 r2020 w2021 mod2023)) vals2026) (chi-body1132 exps2027 (source-wrap1121 e2019 nw2030 s2022 mod2023) nr2031 nw2030 mod2023)))))))) (lambda (e2033 r2034 w2035 s2036 mod2037) ((lambda (tmp2038) ((lambda (tmp2039) (if tmp2039 (apply (lambda (_2040 id2041 val2042 e12043 e22044) (chi-let2018 e2033 r2034 w2035 s2036 mod2037 build-let1072 id2041 val2042 (cons e12043 e22044))) tmp2039) ((lambda (tmp2048) (if (if tmp2048 (apply (lambda (_2049 f2050 id2051 val2052 e12053 e22054) (id?1092 f2050)) tmp2048) #f) (apply (lambda (_2055 f2056 id2057 val2058 e12059 e22060) (chi-let2018 e2033 r2034 w2035 s2036 mod2037 build-named-let1073 (cons f2056 id2057) val2058 (cons e12059 e22060))) tmp2048) ((lambda (_2064) (syntax-error (source-wrap1121 e2033 w2035 s2036 mod2037))) tmp2038))) (syntax-dispatch tmp2038 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2038 (quote (any #(each (any any)) any . each-any))))) e2033)))) (global-extend1090 (quote core) (quote letrec) (lambda (e2065 r2066 w2067 s2068 mod2069) ((lambda (tmp2070) ((lambda (tmp2071) (if tmp2071 (apply (lambda (_2072 id2073 val2074 e12075 e22076) (let ((ids2077 id2073)) (if (not (valid-bound-ids?1117 ids2077)) (syntax-error e2065 "duplicate bound variable in") (let ((labels2079 (gen-labels1098 ids2077)) (new-vars2080 (map gen-var1140 ids2077))) (let ((w2081 (make-binding-wrap1109 ids2077 labels2079 w2067)) (r2082 (extend-var-env1087 labels2079 new-vars2080 r2066))) (build-letrec1074 s2068 new-vars2080 (map (lambda (x2083) (chi1128 x2083 r2082 w2081 mod2069)) val2074) (chi-body1132 (cons e12075 e22076) (source-wrap1121 e2065 w2081 s2068 mod2069) r2082 w2081 mod2069))))))) tmp2071) ((lambda (_2086) (syntax-error (source-wrap1121 e2065 w2067 s2068 mod2069))) tmp2070))) (syntax-dispatch tmp2070 (quote (any #(each (any any)) any . each-any))))) e2065))) (global-extend1090 (quote core) (quote set!) (lambda (e2087 r2088 w2089 s2090 mod2091) ((lambda (tmp2092) ((lambda (tmp2093) (if (if tmp2093 (apply (lambda (_2094 id2095 val2096) (id?1092 id2095)) tmp2093) #f) (apply (lambda (_2097 id2098 val2099) (let ((val2100 (chi1128 val2099 r2088 w2089 mod2091)) (n2101 (id-var-name1114 id2098 w2089))) (let ((b2102 (lookup1089 n2101 r2088 mod2091))) (let ((t2103 (binding-type1084 b2102))) (if (memv t2103 (quote (lexical))) (build-annotated1069 s2090 (list (quote set!) (binding-value1085 b2102) val2100)) (if (memv t2103 (quote (global))) (build-annotated1069 s2090 (list (quote set!) (make-module-ref mod2091 n2101 #f) val2100)) (if (memv t2103 (quote (displaced-lexical))) (syntax-error (wrap1120 id2098 w2089 mod2091) "identifier out of context") (syntax-error (source-wrap1121 e2087 w2089 s2090 mod2091))))))))) tmp2093) ((lambda (tmp2104) (if tmp2104 (apply (lambda (_2105 head2106 tail2107 val2108) (call-with-values (lambda () (syntax-type1126 head2106 r2088 (quote (())) #f #f mod2091)) (lambda (type2109 value2110 ee2111 ww2112 ss2113 modmod2114) (let ((t2115 type2109)) (if (memv t2115 (quote (module-ref))) (call-with-values (lambda () (value2110 (cons head2106 tail2107))) (lambda (id2117 mod2118) (build-annotated1069 s2090 (list (quote set!) (make-module-ref mod2118 id2117 #f) val2108)))) (build-annotated1069 s2090 (cons (chi1128 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2106) r2088 w2089 mod2091) (map (lambda (e2119) (chi1128 e2119 r2088 w2089 mod2091)) (append tail2107 (list val2108)))))))))) tmp2104) ((lambda (_2121) (syntax-error (source-wrap1121 e2087 w2089 s2090 mod2091))) tmp2092))) (syntax-dispatch tmp2092 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2092 (quote (any any any))))) e2087))) (global-extend1090 (quote module-ref) (quote @) (lambda (e2122) ((lambda (tmp2123) ((lambda (tmp2124) (if (if tmp2124 (apply (lambda (_2125 mod2126 id2127) (and (andmap id?1092 mod2126) (id?1092 id2127))) tmp2124) #f) (apply (lambda (_2129 mod2130 id2131) (values (syntax-object->datum id2131) (syntax-object->datum (append mod2130 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) tmp2124) (syntax-error tmp2123))) (syntax-dispatch tmp2123 (quote (any each-any any))))) e2122))) (global-extend1090 (quote module-ref) (quote @@) (lambda (e2133) ((lambda (tmp2134) ((lambda (tmp2135) (if (if tmp2135 (apply (lambda (_2136 mod2137 id2138) (and (andmap id?1092 mod2137) (id?1092 id2138))) tmp2135) #f) (apply (lambda (_2140 mod2141 id2142) (values (syntax-object->datum id2142) (syntax-object->datum mod2141))) tmp2135) (syntax-error tmp2134))) (syntax-dispatch tmp2134 (quote (any each-any any))))) e2133))) (global-extend1090 (quote begin) (quote begin) (quote ())) (global-extend1090 (quote define) (quote define) (quote ())) (global-extend1090 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1090 (quote eval-when) (quote eval-when) (quote ())) (global-extend1090 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2147 (lambda (x2148 keys2149 clauses2150 r2151 mod2152) (if (null? clauses2150) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-error)) x2148)) ((lambda (tmp2153) ((lambda (tmp2154) (if tmp2154 (apply (lambda (pat2155 exp2156) (if (and (id?1092 pat2155) (andmap (lambda (x2157) (not (free-id=?1115 pat2155 x2157))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2149))) (let ((labels2158 (list (gen-label1097))) (var2159 (gen-var1140 pat2155))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list var2159) (chi1128 exp2156 (extend-env1086 labels2158 (list (cons (quote syntax) (cons var2159 0))) r2151) (make-binding-wrap1109 (list pat2155) labels2158 (quote (()))) mod2152))) x2148))) (gen-clause2146 x2148 keys2149 (cdr clauses2150) r2151 pat2155 #t exp2156 mod2152))) tmp2154) ((lambda (tmp2160) (if tmp2160 (apply (lambda (pat2161 fender2162 exp2163) (gen-clause2146 x2148 keys2149 (cdr clauses2150) r2151 pat2161 fender2162 exp2163 mod2152)) tmp2160) ((lambda (_2164) (syntax-error (car clauses2150) "invalid syntax-case clause")) tmp2153))) (syntax-dispatch tmp2153 (quote (any any any)))))) (syntax-dispatch tmp2153 (quote (any any))))) (car clauses2150))))) (gen-clause2146 (lambda (x2165 keys2166 clauses2167 r2168 pat2169 fender2170 exp2171 mod2172) (call-with-values (lambda () (convert-pattern2144 pat2169 keys2166)) (lambda (p2173 pvars2174) (cond ((not (distinct-bound-ids?1118 (map car pvars2174))) (syntax-error pat2169 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2175) (not (ellipsis?1137 (car x2175)))) pvars2174)) (syntax-error pat2169 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2176 (gen-var1140 (quote tmp)))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list y2176) (let ((y2177 (build-annotated1069 #f y2176))) (build-annotated1069 #f (list (quote if) ((lambda (tmp2178) ((lambda (tmp2179) (if tmp2179 (apply (lambda () y2177) tmp2179) ((lambda (_2180) (build-annotated1069 #f (list (quote if) y2177 (build-dispatch-call2145 pvars2174 fender2170 y2177 r2168 mod2172) (build-data1070 #f #f)))) tmp2178))) (syntax-dispatch tmp2178 (quote #(atom #t))))) fender2170) (build-dispatch-call2145 pvars2174 exp2171 y2177 r2168 mod2172) (gen-syntax-case2147 x2165 keys2166 clauses2167 r2168 mod2172)))))) (if (eq? p2173 (quote any)) (build-annotated1069 #f (list (build-annotated1069 #f (quote list)) x2165)) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-dispatch)) x2165 (build-data1070 #f p2173))))))))))))) (build-dispatch-call2145 (lambda (pvars2181 exp2182 y2183 r2184 mod2185) (let ((ids2186 (map car pvars2181)) (levels2187 (map cdr pvars2181))) (let ((labels2188 (gen-labels1098 ids2186)) (new-vars2189 (map gen-var1140 ids2186))) (build-annotated1069 #f (list (build-annotated1069 #f (quote apply)) (build-annotated1069 #f (list (quote lambda) new-vars2189 (chi1128 exp2182 (extend-env1086 labels2188 (map (lambda (var2190 level2191) (cons (quote syntax) (cons var2190 level2191))) new-vars2189 (map cdr pvars2181)) r2184) (make-binding-wrap1109 ids2186 labels2188 (quote (()))) mod2185))) y2183)))))) (convert-pattern2144 (lambda (pattern2192 keys2193) (let cvt2194 ((p2195 pattern2192) (n2196 0) (ids2197 (quote ()))) (if (id?1092 p2195) (if (bound-id-member?1119 p2195 keys2193) (values (vector (quote free-id) p2195) ids2197) (values (quote any) (cons (cons p2195 n2196) ids2197))) ((lambda (tmp2198) ((lambda (tmp2199) (if (if tmp2199 (apply (lambda (x2200 dots2201) (ellipsis?1137 dots2201)) tmp2199) #f) (apply (lambda (x2202 dots2203) (call-with-values (lambda () (cvt2194 x2202 (fx+1059 n2196 1) ids2197)) (lambda (p2204 ids2205) (values (if (eq? p2204 (quote any)) (quote each-any) (vector (quote each) p2204)) ids2205)))) tmp2199) ((lambda (tmp2206) (if tmp2206 (apply (lambda (x2207 y2208) (call-with-values (lambda () (cvt2194 y2208 n2196 ids2197)) (lambda (y2209 ids2210) (call-with-values (lambda () (cvt2194 x2207 n2196 ids2210)) (lambda (x2211 ids2212) (values (cons x2211 y2209) ids2212)))))) tmp2206) ((lambda (tmp2213) (if tmp2213 (apply (lambda () (values (quote ()) ids2197)) tmp2213) ((lambda (tmp2214) (if tmp2214 (apply (lambda (x2215) (call-with-values (lambda () (cvt2194 x2215 n2196 ids2197)) (lambda (p2217 ids2218) (values (vector (quote vector) p2217) ids2218)))) tmp2214) ((lambda (x2219) (values (vector (quote atom) (strip1139 p2195 (quote (())))) ids2197)) tmp2198))) (syntax-dispatch tmp2198 (quote #(vector each-any)))))) (syntax-dispatch tmp2198 (quote ()))))) (syntax-dispatch tmp2198 (quote (any . any)))))) (syntax-dispatch tmp2198 (quote (any any))))) p2195)))))) (lambda (e2220 r2221 w2222 s2223 mod2224) (let ((e2225 (source-wrap1121 e2220 w2222 s2223 mod2224))) ((lambda (tmp2226) ((lambda (tmp2227) (if tmp2227 (apply (lambda (_2228 val2229 key2230 m2231) (if (andmap (lambda (x2232) (and (id?1092 x2232) (not (ellipsis?1137 x2232)))) key2230) (let ((x2234 (gen-var1140 (quote tmp)))) (build-annotated1069 s2223 (list (build-annotated1069 #f (list (quote lambda) (list x2234) (gen-syntax-case2147 (build-annotated1069 #f x2234) key2230 m2231 r2221 mod2224))) (chi1128 val2229 r2221 (quote (())) mod2224)))) (syntax-error e2225 "invalid literals list in"))) tmp2227) (syntax-error tmp2226))) (syntax-dispatch tmp2226 (quote (any any each-any . each-any))))) e2225))))) (set! sc-expand (let ((m2237 (quote e)) (esew2238 (quote (eval)))) (lambda (x2239) (if (and (pair? x2239) (equal? (car x2239) noexpand1058)) (cadr x2239) (chi-top1127 x2239 (quote ()) (quote ((top))) m2237 esew2238 (module-name (current-module))))))) (set! sc-expand3 (let ((m2240 (quote e)) (esew2241 (quote (eval)))) (lambda (x2243 . rest2242) (if (and (pair? x2243) (equal? (car x2243) noexpand1058)) (cadr x2243) (chi-top1127 x2243 (quote ()) (quote ((top))) (if (null? rest2242) m2240 (car rest2242)) (if (or (null? rest2242) (null? (cdr rest2242))) esew2241 (cadr rest2242)) (module-name (current-module))))))) (set! identifier? (lambda (x2244) (nonsymbol-id?1091 x2244))) (set! datum->syntax-object (lambda (id2245 datum2246) (make-syntax-object1075 datum2246 (syntax-object-wrap1078 id2245) #f))) (set! syntax-object->datum (lambda (x2247) (strip1139 x2247 (quote (()))))) (set! generate-temporaries (lambda (ls2248) (begin (let ((x2249 ls2248)) (if (not (list? x2249)) (error-hook1065 (quote generate-temporaries) "invalid argument" x2249))) (map (lambda (x2250) (wrap1120 (gensym) (quote ((top))) #f)) ls2248)))) (set! free-identifier=? (lambda (x2251 y2252) (begin (let ((x2253 x2251)) (if (not (nonsymbol-id?1091 x2253)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2253))) (let ((x2254 y2252)) (if (not (nonsymbol-id?1091 x2254)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2254))) (free-id=?1115 x2251 y2252)))) (set! bound-identifier=? (lambda (x2255 y2256) (begin (let ((x2257 x2255)) (if (not (nonsymbol-id?1091 x2257)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2257))) (let ((x2258 y2256)) (if (not (nonsymbol-id?1091 x2258)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2258))) (bound-id=?1116 x2255 y2256)))) (set! syntax-error (lambda (object2260 . messages2259) (begin (for-each (lambda (x2261) (let ((x2262 x2261)) (if (not (string? x2262)) (error-hook1065 (quote syntax-error) "invalid argument" x2262)))) messages2259) (let ((message2263 (if (null? messages2259) "invalid syntax" (apply string-append messages2259)))) (error-hook1065 #f message2263 (strip1139 object2260 (quote (())))))))) (set! install-global-transformer (lambda (sym2264 v2265) (begin (let ((x2266 sym2264)) (if (not (symbol? x2266)) (error-hook1065 (quote define-syntax) "invalid argument" x2266))) (let ((x2267 v2265)) (if (not (procedure? x2267)) (error-hook1065 (quote define-syntax) "invalid argument" x2267))) (global-extend1090 (quote macro) sym2264 v2265)))) (letrec ((match2272 (lambda (e2273 p2274 w2275 r2276 mod2277) (cond ((not r2276) #f) ((eq? p2274 (quote any)) (cons (wrap1120 e2273 w2275 mod2277) r2276)) ((syntax-object?1076 e2273) (match*2271 (let ((e2278 (syntax-object-expression1077 e2273))) (if (annotation? e2278) (annotation-expression e2278) e2278)) p2274 (join-wraps1111 w2275 (syntax-object-wrap1078 e2273)) r2276 (syntax-object-module1079 e2273))) (else (match*2271 (let ((e2279 e2273)) (if (annotation? e2279) (annotation-expression e2279) e2279)) p2274 w2275 r2276 mod2277))))) (match*2271 (lambda (e2280 p2281 w2282 r2283 mod2284) (cond ((null? p2281) (and (null? e2280) r2283)) ((pair? p2281) (and (pair? e2280) (match2272 (car e2280) (car p2281) w2282 (match2272 (cdr e2280) (cdr p2281) w2282 r2283 mod2284) mod2284))) ((eq? p2281 (quote each-any)) (let ((l2285 (match-each-any2269 e2280 w2282 mod2284))) (and l2285 (cons l2285 r2283)))) (else (let ((t2286 (vector-ref p2281 0))) (if (memv t2286 (quote (each))) (if (null? e2280) (match-empty2270 (vector-ref p2281 1) r2283) (let ((l2287 (match-each2268 e2280 (vector-ref p2281 1) w2282 mod2284))) (and l2287 (let collect2288 ((l2289 l2287)) (if (null? (car l2289)) r2283 (cons (map car l2289) (collect2288 (map cdr l2289)))))))) (if (memv t2286 (quote (free-id))) (and (id?1092 e2280) (free-id=?1115 (wrap1120 e2280 w2282 mod2284) (vector-ref p2281 1)) r2283) (if (memv t2286 (quote (atom))) (and (equal? (vector-ref p2281 1) (strip1139 e2280 w2282)) r2283) (if (memv t2286 (quote (vector))) (and (vector? e2280) (match2272 (vector->list e2280) (vector-ref p2281 1) w2282 r2283 mod2284))))))))))) (match-empty2270 (lambda (p2290 r2291) (cond ((null? p2290) r2291) ((eq? p2290 (quote any)) (cons (quote ()) r2291)) ((pair? p2290) (match-empty2270 (car p2290) (match-empty2270 (cdr p2290) r2291))) ((eq? p2290 (quote each-any)) (cons (quote ()) r2291)) (else (let ((t2292 (vector-ref p2290 0))) (if (memv t2292 (quote (each))) (match-empty2270 (vector-ref p2290 1) r2291) (if (memv t2292 (quote (free-id atom))) r2291 (if (memv t2292 (quote (vector))) (match-empty2270 (vector-ref p2290 1) r2291))))))))) (match-each-any2269 (lambda (e2293 w2294 mod2295) (cond ((annotation? e2293) (match-each-any2269 (annotation-expression e2293) w2294 mod2295)) ((pair? e2293) (let ((l2296 (match-each-any2269 (cdr e2293) w2294 mod2295))) (and l2296 (cons (wrap1120 (car e2293) w2294 mod2295) l2296)))) ((null? e2293) (quote ())) ((syntax-object?1076 e2293) (match-each-any2269 (syntax-object-expression1077 e2293) (join-wraps1111 w2294 (syntax-object-wrap1078 e2293)) mod2295)) (else #f)))) (match-each2268 (lambda (e2297 p2298 w2299 mod2300) (cond ((annotation? e2297) (match-each2268 (annotation-expression e2297) p2298 w2299 mod2300)) ((pair? e2297) (let ((first2301 (match2272 (car e2297) p2298 w2299 (quote ()) mod2300))) (and first2301 (let ((rest2302 (match-each2268 (cdr e2297) p2298 w2299 mod2300))) (and rest2302 (cons first2301 rest2302)))))) ((null? e2297) (quote ())) ((syntax-object?1076 e2297) (match-each2268 (syntax-object-expression1077 e2297) p2298 (join-wraps1111 w2299 (syntax-object-wrap1078 e2297)) (syntax-object-module1079 e2297))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2303 p2304) (cond ((eq? p2304 (quote any)) (list e2303)) ((syntax-object?1076 e2303) (match*2271 (let ((e2305 (syntax-object-expression1077 e2303))) (if (annotation? e2305) (annotation-expression e2305) e2305)) p2304 (syntax-object-wrap1078 e2303) (quote ()) (syntax-object-module1079 e2303))) (else (match*2271 (let ((e2306 e2303)) (if (annotation? e2306) (annotation-expression e2306) e2306)) p2304 (quote (())) (quote ()) #f))))) (set! sc-chi chi1128))))) -(install-global-transformer (quote with-syntax) (lambda (x2307) ((lambda (tmp2308) ((lambda (tmp2309) (if tmp2309 (apply (lambda (_2310 e12311 e22312) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12311 e22312))) tmp2309) ((lambda (tmp2314) (if tmp2314 (apply (lambda (_2315 out2316 in2317 e12318 e22319) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2317 (quote ()) (list out2316 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12318 e22319))))) tmp2314) ((lambda (tmp2321) (if tmp2321 (apply (lambda (_2322 out2323 in2324 e12325 e22326) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2324) (quote ()) (list out2323 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12325 e22326))))) tmp2321) (syntax-error tmp2308))) (syntax-dispatch tmp2308 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2308 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2308 (quote (any () any . each-any))))) x2307))) -(install-global-transformer (quote syntax-rules) (lambda (x2330) ((lambda (tmp2331) ((lambda (tmp2332) (if tmp2332 (apply (lambda (_2333 k2334 keyword2335 pattern2336 template2337) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2334 (map (lambda (tmp2340 tmp2339) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2339) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2340))) template2337 pattern2336)))))) tmp2332) (syntax-error tmp2331))) (syntax-dispatch tmp2331 (quote (any each-any . #(each ((any . any) any))))))) x2330))) -(install-global-transformer (quote let*) (lambda (x2341) ((lambda (tmp2342) ((lambda (tmp2343) (if (if tmp2343 (apply (lambda (let*2344 x2345 v2346 e12347 e22348) (andmap identifier? x2345)) tmp2343) #f) (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (let f2355 ((bindings2356 (map list x2351 v2352))) (if (null? bindings2356) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12353 e22354))) ((lambda (tmp2360) ((lambda (tmp2361) (if tmp2361 (apply (lambda (body2362 binding2363) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2363) body2362)) tmp2361) (syntax-error tmp2360))) (syntax-dispatch tmp2360 (quote (any any))))) (list (f2355 (cdr bindings2356)) (car bindings2356)))))) tmp2343) (syntax-error tmp2342))) (syntax-dispatch tmp2342 (quote (any #(each (any any)) any . each-any))))) x2341))) -(install-global-transformer (quote do) (lambda (orig-x2364) ((lambda (tmp2365) ((lambda (tmp2366) (if tmp2366 (apply (lambda (_2367 var2368 init2369 step2370 e02371 e12372 c2373) ((lambda (tmp2374) ((lambda (tmp2375) (if tmp2375 (apply (lambda (step2376) ((lambda (tmp2377) ((lambda (tmp2378) (if tmp2378 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2368 init2369) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02371) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2373 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2376))))))) tmp2378) ((lambda (tmp2383) (if tmp2383 (apply (lambda (e12384 e22385) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2368 init2369) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02371 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12384 e22385)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2373 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2376))))))) tmp2383) (syntax-error tmp2377))) (syntax-dispatch tmp2377 (quote (any . each-any)))))) (syntax-dispatch tmp2377 (quote ())))) e12372)) tmp2375) (syntax-error tmp2374))) (syntax-dispatch tmp2374 (quote each-any)))) (map (lambda (v2392 s2393) ((lambda (tmp2394) ((lambda (tmp2395) (if tmp2395 (apply (lambda () v2392) tmp2395) ((lambda (tmp2396) (if tmp2396 (apply (lambda (e2397) e2397) tmp2396) ((lambda (_2398) (syntax-error orig-x2364)) tmp2394))) (syntax-dispatch tmp2394 (quote (any)))))) (syntax-dispatch tmp2394 (quote ())))) s2393)) var2368 step2370))) tmp2366) (syntax-error tmp2365))) (syntax-dispatch tmp2365 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2364))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2401 (lambda (x2405 y2406) ((lambda (tmp2407) ((lambda (tmp2408) (if tmp2408 (apply (lambda (x2409 y2410) ((lambda (tmp2411) ((lambda (tmp2412) (if tmp2412 (apply (lambda (dy2413) ((lambda (tmp2414) ((lambda (tmp2415) (if tmp2415 (apply (lambda (dx2416) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2416 dy2413))) tmp2415) ((lambda (_2417) (if (null? dy2413) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2409) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2409 y2410))) tmp2414))) (syntax-dispatch tmp2414 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2409)) tmp2412) ((lambda (tmp2418) (if tmp2418 (apply (lambda (stuff2419) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2409 stuff2419))) tmp2418) ((lambda (else2420) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2409 y2410)) tmp2411))) (syntax-dispatch tmp2411 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2411 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2410)) tmp2408) (syntax-error tmp2407))) (syntax-dispatch tmp2407 (quote (any any))))) (list x2405 y2406)))) (quasiappend2402 (lambda (x2421 y2422) ((lambda (tmp2423) ((lambda (tmp2424) (if tmp2424 (apply (lambda (x2425 y2426) ((lambda (tmp2427) ((lambda (tmp2428) (if tmp2428 (apply (lambda () x2425) tmp2428) ((lambda (_2429) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2425 y2426)) tmp2427))) (syntax-dispatch tmp2427 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2426)) tmp2424) (syntax-error tmp2423))) (syntax-dispatch tmp2423 (quote (any any))))) (list x2421 y2422)))) (quasivector2403 (lambda (x2430) ((lambda (tmp2431) ((lambda (x2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda (x2435) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2435))) tmp2434) ((lambda (tmp2437) (if tmp2437 (apply (lambda (x2438) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2438)) tmp2437) ((lambda (_2440) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2432)) tmp2433))) (syntax-dispatch tmp2433 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2433 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2432)) tmp2431)) x2430))) (quasi2404 (lambda (p2441 lev2442) ((lambda (tmp2443) ((lambda (tmp2444) (if tmp2444 (apply (lambda (p2445) (if (= lev2442 0) p2445 (quasicons2401 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2404 (list p2445) (- lev2442 1))))) tmp2444) ((lambda (tmp2446) (if tmp2446 (apply (lambda (p2447 q2448) (if (= lev2442 0) (quasiappend2402 p2447 (quasi2404 q2448 lev2442)) (quasicons2401 (quasicons2401 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2404 (list p2447) (- lev2442 1))) (quasi2404 q2448 lev2442)))) tmp2446) ((lambda (tmp2449) (if tmp2449 (apply (lambda (p2450) (quasicons2401 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2404 (list p2450) (+ lev2442 1)))) tmp2449) ((lambda (tmp2451) (if tmp2451 (apply (lambda (p2452 q2453) (quasicons2401 (quasi2404 p2452 lev2442) (quasi2404 q2453 lev2442))) tmp2451) ((lambda (tmp2454) (if tmp2454 (apply (lambda (x2455) (quasivector2403 (quasi2404 x2455 lev2442))) tmp2454) ((lambda (p2457) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2457)) tmp2443))) (syntax-dispatch tmp2443 (quote #(vector each-any)))))) (syntax-dispatch tmp2443 (quote (any . any)))))) (syntax-dispatch tmp2443 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2443 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2443 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2441)))) (lambda (x2458) ((lambda (tmp2459) ((lambda (tmp2460) (if tmp2460 (apply (lambda (_2461 e2462) (quasi2404 e2462 0)) tmp2460) (syntax-error tmp2459))) (syntax-dispatch tmp2459 (quote (any any))))) x2458)))) -(install-global-transformer (quote include) (lambda (x2463) (letrec ((read-file2464 (lambda (fn2465 k2466) (let ((p2467 (open-input-file fn2465))) (let f2468 ((x2469 (read p2467))) (if (eof-object? x2469) (begin (close-input-port p2467) (quote ())) (cons (datum->syntax-object k2466 x2469) (f2468 (read p2467))))))))) ((lambda (tmp2470) ((lambda (tmp2471) (if tmp2471 (apply (lambda (k2472 filename2473) (let ((fn2474 (syntax-object->datum filename2473))) ((lambda (tmp2475) ((lambda (tmp2476) (if tmp2476 (apply (lambda (exp2477) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2477)) tmp2476) (syntax-error tmp2475))) (syntax-dispatch tmp2475 (quote each-any)))) (read-file2464 fn2474 k2472)))) tmp2471) (syntax-error tmp2470))) (syntax-dispatch tmp2470 (quote (any any))))) x2463)))) -(install-global-transformer (quote unquote) (lambda (x2479) ((lambda (tmp2480) ((lambda (tmp2481) (if tmp2481 (apply (lambda (_2482 e2483) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2483))) tmp2481) (syntax-error tmp2480))) (syntax-dispatch tmp2480 (quote (any any))))) x2479))) -(install-global-transformer (quote unquote-splicing) (lambda (x2484) ((lambda (tmp2485) ((lambda (tmp2486) (if tmp2486 (apply (lambda (_2487 e2488) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2488))) tmp2486) (syntax-error tmp2485))) (syntax-dispatch tmp2485 (quote (any any))))) x2484))) -(install-global-transformer (quote case) (lambda (x2489) ((lambda (tmp2490) ((lambda (tmp2491) (if tmp2491 (apply (lambda (_2492 e2493 m12494 m22495) ((lambda (tmp2496) ((lambda (body2497) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2493)) body2497)) tmp2496)) (let f2498 ((clause2499 m12494) (clauses2500 m22495)) (if (null? clauses2500) ((lambda (tmp2502) ((lambda (tmp2503) (if tmp2503 (apply (lambda (e12504 e22505) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12504 e22505))) tmp2503) ((lambda (tmp2507) (if tmp2507 (apply (lambda (k2508 e12509 e22510) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2508)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12509 e22510)))) tmp2507) ((lambda (_2513) (syntax-error x2489)) tmp2502))) (syntax-dispatch tmp2502 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2502 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2499) ((lambda (tmp2514) ((lambda (rest2515) ((lambda (tmp2516) ((lambda (tmp2517) (if tmp2517 (apply (lambda (k2518 e12519 e22520) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2518)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12519 e22520)) rest2515)) tmp2517) ((lambda (_2523) (syntax-error x2489)) tmp2516))) (syntax-dispatch tmp2516 (quote (each-any any . each-any))))) clause2499)) tmp2514)) (f2498 (car clauses2500) (cdr clauses2500))))))) tmp2491) (syntax-error tmp2490))) (syntax-dispatch tmp2490 (quote (any any any . each-any))))) x2489))) -(install-global-transformer (quote identifier-syntax) (lambda (x2524) ((lambda (tmp2525) ((lambda (tmp2526) (if tmp2526 (apply (lambda (_2527 e2528) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2528)) (list (cons _2527 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2528 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2526) (syntax-error tmp2525))) (syntax-dispatch tmp2525 (quote (any any))))) x2524))) +(letrec ((lambda-var-list1141 (lambda (vars1340) (let lvl1341 ((vars1342 vars1340) (ls1343 (quote ())) (w1344 (quote (())))) (cond ((pair? vars1342) (lvl1341 (cdr vars1342) (cons (wrap1120 (car vars1342) w1344 #f) ls1343) w1344)) ((id?1092 vars1342) (cons (wrap1120 vars1342 w1344 #f) ls1343)) ((null? vars1342) ls1343) ((syntax-object?1076 vars1342) (lvl1341 (syntax-object-expression1077 vars1342) ls1343 (join-wraps1111 w1344 (syntax-object-wrap1078 vars1342)))) ((annotation? vars1342) (lvl1341 (annotation-expression vars1342) ls1343 w1344)) (else (cons vars1342 ls1343)))))) (gen-var1140 (lambda (id1345) (let ((id1346 (if (syntax-object?1076 id1345) (syntax-object-expression1077 id1345) id1345))) (if (annotation? id1346) (build-annotated1069 (annotation-source id1346) (gensym (symbol->string (annotation-expression id1346)))) (build-annotated1069 #f (gensym (symbol->string id1346))))))) (strip1139 (lambda (x1347 w1348) (if (memq (quote top) (wrap-marks1095 w1348)) (if (or (annotation? x1347) (and (pair? x1347) (annotation? (car x1347)))) (strip-annotation1138 x1347 #f) x1347) (let f1349 ((x1350 x1347)) (cond ((syntax-object?1076 x1350) (strip1139 (syntax-object-expression1077 x1350) (syntax-object-wrap1078 x1350))) ((pair? x1350) (let ((a1351 (f1349 (car x1350))) (d1352 (f1349 (cdr x1350)))) (if (and (eq? a1351 (car x1350)) (eq? d1352 (cdr x1350))) x1350 (cons a1351 d1352)))) ((vector? x1350) (let ((old1353 (vector->list x1350))) (let ((new1354 (map f1349 old1353))) (if (andmap eq? old1353 new1354) x1350 (list->vector new1354))))) (else x1350)))))) (strip-annotation1138 (lambda (x1355 parent1356) (cond ((pair? x1355) (let ((new1357 (cons #f #f))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1357)) (set-car! new1357 (strip-annotation1138 (car x1355) #f)) (set-cdr! new1357 (strip-annotation1138 (cdr x1355) #f)) new1357))) ((annotation? x1355) (or (annotation-stripped x1355) (strip-annotation1138 (annotation-expression x1355) x1355))) ((vector? x1355) (let ((new1358 (make-vector (vector-length x1355)))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1358)) (let loop1359 ((i1360 (- (vector-length x1355) 1))) (unless (fx<1062 i1360 0) (vector-set! new1358 i1360 (strip-annotation1138 (vector-ref x1355 i1360) #f)) (loop1359 (fx-1060 i1360 1)))) new1358))) (else x1355)))) (ellipsis?1137 (lambda (x1361) (and (nonsymbol-id?1091 x1361) (free-id=?1115 x1361 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1136 (lambda () (build-annotated1069 #f (list (build-annotated1069 #f (quote void)))))) (eval-local-transformer1135 (lambda (expanded1362 mod1363) (let ((p1364 (local-eval-hook1064 expanded1362 mod1363))) (if (procedure? p1364) p1364 (syntax-error p1364 "nonprocedure transformer"))))) (chi-local-syntax1134 (lambda (rec?1365 e1366 r1367 w1368 s1369 mod1370 k1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 id1375 val1376 e11377 e21378) (let ((ids1379 id1375)) (if (not (valid-bound-ids?1117 ids1379)) (syntax-error e1366 "duplicate bound keyword in") (let ((labels1381 (gen-labels1098 ids1379))) (let ((new-w1382 (make-binding-wrap1109 ids1379 labels1381 w1368))) (k1371 (cons e11377 e21378) (extend-env1086 labels1381 (let ((w1384 (if rec?1365 new-w1382 w1368)) (trans-r1385 (macros-only-env1088 r1367))) (map (lambda (x1386) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1386 trans-r1385 w1384 mod1370) mod1370))) val1376)) r1367) new-w1382 s1369 mod1370)))))) tmp1373) ((lambda (_1388) (syntax-error (source-wrap1121 e1366 w1368 s1369 mod1370))) tmp1372))) (syntax-dispatch tmp1372 (quote (any #(each (any any)) any . each-any))))) e1366))) (chi-lambda-clause1133 (lambda (e1389 c1390 r1391 w1392 mod1393 k1394) ((lambda (tmp1395) ((lambda (tmp1396) (if tmp1396 (apply (lambda (id1397 e11398 e21399) (let ((ids1400 id1397)) (if (not (valid-bound-ids?1117 ids1400)) (syntax-error e1389 "invalid parameter list in") (let ((labels1402 (gen-labels1098 ids1400)) (new-vars1403 (map gen-var1140 ids1400))) (k1394 new-vars1403 (chi-body1132 (cons e11398 e21399) e1389 (extend-var-env1087 labels1402 new-vars1403 r1391) (make-binding-wrap1109 ids1400 labels1402 w1392) mod1393)))))) tmp1396) ((lambda (tmp1405) (if tmp1405 (apply (lambda (ids1406 e11407 e21408) (let ((old-ids1409 (lambda-var-list1141 ids1406))) (if (not (valid-bound-ids?1117 old-ids1409)) (syntax-error e1389 "invalid parameter list in") (let ((labels1410 (gen-labels1098 old-ids1409)) (new-vars1411 (map gen-var1140 old-ids1409))) (k1394 (let f1412 ((ls11413 (cdr new-vars1411)) (ls21414 (car new-vars1411))) (if (null? ls11413) ls21414 (f1412 (cdr ls11413) (cons (car ls11413) ls21414)))) (chi-body1132 (cons e11407 e21408) e1389 (extend-var-env1087 labels1410 new-vars1411 r1391) (make-binding-wrap1109 old-ids1409 labels1410 w1392) mod1393)))))) tmp1405) ((lambda (_1416) (syntax-error e1389)) tmp1395))) (syntax-dispatch tmp1395 (quote (any any . each-any)))))) (syntax-dispatch tmp1395 (quote (each-any any . each-any))))) c1390))) (chi-body1132 (lambda (body1417 outer-form1418 r1419 w1420 mod1421) (let ((r1422 (cons (quote ("placeholder" placeholder)) r1419))) (let ((ribcage1423 (make-ribcage1099 (quote ()) (quote ()) (quote ())))) (let ((w1424 (make-wrap1094 (wrap-marks1095 w1420) (cons ribcage1423 (wrap-subst1096 w1420))))) (let parse1425 ((body1426 (map (lambda (x1432) (cons r1422 (wrap1120 x1432 w1424 mod1421))) body1417)) (ids1427 (quote ())) (labels1428 (quote ())) (vars1429 (quote ())) (vals1430 (quote ())) (bindings1431 (quote ()))) (if (null? body1426) (syntax-error outer-form1418 "no expressions in body") (let ((e1433 (cdar body1426)) (er1434 (caar body1426))) (call-with-values (lambda () (syntax-type1126 e1433 er1434 (quote (())) #f ribcage1423 mod1421)) (lambda (type1435 value1436 e1437 w1438 s1439 mod1440) (let ((t1441 type1435)) (if (memv t1441 (quote (define-form))) (let ((id1442 (wrap1120 value1436 w1438 mod1440)) (label1443 (gen-label1097))) (let ((var1444 (gen-var1140 id1442))) (begin (extend-ribcage!1108 ribcage1423 id1442 label1443) (parse1425 (cdr body1426) (cons id1442 ids1427) (cons label1443 labels1428) (cons var1444 vars1429) (cons (cons er1434 (wrap1120 e1437 w1438 mod1440)) vals1430) (cons (cons (quote lexical) var1444) bindings1431))))) (if (memv t1441 (quote (define-syntax-form))) (let ((id1445 (wrap1120 value1436 w1438 mod1440)) (label1446 (gen-label1097))) (begin (extend-ribcage!1108 ribcage1423 id1445 label1446) (parse1425 (cdr body1426) (cons id1445 ids1427) (cons label1446 labels1428) vars1429 vals1430 (cons (cons (quote macro) (cons er1434 (wrap1120 e1437 w1438 mod1440))) bindings1431)))) (if (memv t1441 (quote (begin-form))) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (_1449 e11450) (parse1425 (let f1451 ((forms1452 e11450)) (if (null? forms1452) (cdr body1426) (cons (cons er1434 (wrap1120 (car forms1452) w1438 mod1440)) (f1451 (cdr forms1452))))) ids1427 labels1428 vars1429 vals1430 bindings1431)) tmp1448) (syntax-error tmp1447))) (syntax-dispatch tmp1447 (quote (any . each-any))))) e1437) (if (memv t1441 (quote (local-syntax-form))) (chi-local-syntax1134 value1436 e1437 er1434 w1438 s1439 mod1440 (lambda (forms1454 er1455 w1456 s1457 mod1458) (parse1425 (let f1459 ((forms1460 forms1454)) (if (null? forms1460) (cdr body1426) (cons (cons er1455 (wrap1120 (car forms1460) w1456 mod1458)) (f1459 (cdr forms1460))))) ids1427 labels1428 vars1429 vals1430 bindings1431))) (if (null? ids1427) (build-sequence1071 #f (map (lambda (x1461) (chi1128 (cdr x1461) (car x1461) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))) (begin (if (not (valid-bound-ids?1117 ids1427)) (syntax-error outer-form1418 "invalid or duplicate identifier in definition")) (let loop1462 ((bs1463 bindings1431) (er-cache1464 #f) (r-cache1465 #f)) (if (not (null? bs1463)) (let ((b1466 (car bs1463))) (if (eq? (car b1466) (quote macro)) (let ((er1467 (cadr b1466))) (let ((r-cache1468 (if (eq? er1467 er-cache1464) r-cache1465 (macros-only-env1088 er1467)))) (begin (set-cdr! b1466 (eval-local-transformer1135 (chi1128 (cddr b1466) r-cache1468 (quote (())) mod1440) mod1440)) (loop1462 (cdr bs1463) er1467 r-cache1468)))) (loop1462 (cdr bs1463) er-cache1464 r-cache1465))))) (set-cdr! r1422 (extend-env1086 labels1428 bindings1431 (cdr r1422))) (build-letrec1074 #f vars1429 (map (lambda (x1469) (chi1128 (cdr x1469) (car x1469) (quote (())) mod1440)) vals1430) (build-sequence1071 #f (map (lambda (x1470) (chi1128 (cdr x1470) (car x1470) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))))))))))))))))))))) (chi-macro1131 (lambda (p1471 e1472 r1473 w1474 rib1475 mod1476) (letrec ((rebuild-macro-output1477 (lambda (x1478 m1479) (cond ((pair? x1478) (cons (rebuild-macro-output1477 (car x1478) m1479) (rebuild-macro-output1477 (cdr x1478) m1479))) ((syntax-object?1076 x1478) (let ((w1480 (syntax-object-wrap1078 x1478))) (let ((ms1481 (wrap-marks1095 w1480)) (s1482 (wrap-subst1096 w1480))) (if (and (pair? ms1481) (eq? (car ms1481) #f)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cdr ms1481) (if rib1475 (cons rib1475 (cdr s1482)) (cdr s1482))) (syntax-object-module1079 x1478)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cons m1479 ms1481) (if rib1475 (cons rib1475 (cons (quote shift) s1482)) (cons (quote shift) s1482))) (module-name (procedure-module p1471))))))) ((vector? x1478) (let ((n1483 (vector-length x1478))) (let ((v1484 (make-vector n1483))) (let doloop1485 ((i1486 0)) (if (fx=1061 i1486 n1483) v1484 (begin (vector-set! v1484 i1486 (rebuild-macro-output1477 (vector-ref x1478 i1486) m1479)) (doloop1485 (fx+1059 i1486 1)))))))) ((symbol? x1478) (syntax-error x1478 "encountered raw symbol in macro output")) (else x1478))))) (rebuild-macro-output1477 (p1471 (wrap1120 e1472 (anti-mark1107 w1474) mod1476)) (string #\m))))) (chi-application1130 (lambda (x1487 e1488 r1489 w1490 s1491 mod1492) ((lambda (tmp1493) ((lambda (tmp1494) (if tmp1494 (apply (lambda (e01495 e11496) (build-annotated1069 s1491 (cons x1487 (map (lambda (e1497) (chi1128 e1497 r1489 w1490 mod1492)) e11496)))) tmp1494) (syntax-error tmp1493))) (syntax-dispatch tmp1493 (quote (any . each-any))))) e1488))) (chi-expr1129 (lambda (type1499 value1500 e1501 r1502 w1503 s1504 mod1505) (let ((t1506 type1499)) (if (memv t1506 (quote (lexical))) (build-annotated1069 s1504 value1500) (if (memv t1506 (quote (core external-macro))) (value1500 e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (module-ref))) (call-with-values (lambda () (value1500 e1501)) (lambda (id1507 mod1508) (build-annotated1069 s1504 (make-module-ref mod1508 id1507 #f)))) (if (memv t1506 (quote (lexical-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) value1500) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (global-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) (make-module-ref (if (syntax-object?1076 (car e1501)) (syntax-object-module1079 (car e1501)) mod1505) value1500 #f)) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (constant))) (build-data1070 s1504 (strip1139 (source-wrap1121 e1501 w1503 s1504 mod1505) (quote (())))) (if (memv t1506 (quote (global))) (build-annotated1069 s1504 (make-module-ref mod1505 value1500 #f)) (if (memv t1506 (quote (call))) (chi-application1130 (chi1128 (car e1501) r1502 w1503 mod1505) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (begin-form))) ((lambda (tmp1509) ((lambda (tmp1510) (if tmp1510 (apply (lambda (_1511 e11512 e21513) (chi-sequence1122 (cons e11512 e21513) r1502 w1503 s1504 mod1505)) tmp1510) (syntax-error tmp1509))) (syntax-dispatch tmp1509 (quote (any any . each-any))))) e1501) (if (memv t1506 (quote (local-syntax-form))) (chi-local-syntax1134 value1500 e1501 r1502 w1503 s1504 mod1505 chi-sequence1122) (if (memv t1506 (quote (eval-when-form))) ((lambda (tmp1515) ((lambda (tmp1516) (if tmp1516 (apply (lambda (_1517 x1518 e11519 e21520) (let ((when-list1521 (chi-when-list1125 e1501 x1518 w1503))) (if (memq (quote eval) when-list1521) (chi-sequence1122 (cons e11519 e21520) r1502 w1503 s1504 mod1505) (chi-void1136)))) tmp1516) (syntax-error tmp1515))) (syntax-dispatch tmp1515 (quote (any each-any any . each-any))))) e1501) (if (memv t1506 (quote (define-form define-syntax-form))) (syntax-error (wrap1120 value1500 w1503 mod1505) "invalid context for definition of") (if (memv t1506 (quote (syntax))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to pattern variable outside syntax form") (if (memv t1506 (quote (displaced-lexical))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to identifier outside its scope") (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505))))))))))))))))))) (chi1128 (lambda (e1524 r1525 w1526 mod1527) (call-with-values (lambda () (syntax-type1126 e1524 r1525 w1526 #f #f mod1527)) (lambda (type1528 value1529 e1530 w1531 s1532 mod1533) (chi-expr1129 type1528 value1529 e1530 r1525 w1531 s1532 mod1533))))) (chi-top1127 (lambda (e1534 r1535 w1536 m1537 esew1538 mod1539) (call-with-values (lambda () (syntax-type1126 e1534 r1535 w1536 #f #f mod1539)) (lambda (type1547 value1548 e1549 w1550 s1551 mod1552) (let ((t1553 type1547)) (if (memv t1553 (quote (begin-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556) (chi-void1136)) tmp1555) ((lambda (tmp1557) (if tmp1557 (apply (lambda (_1558 e11559 e21560) (chi-top-sequence1123 (cons e11559 e21560) r1535 w1550 s1551 m1537 esew1538 mod1552)) tmp1557) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any any . each-any)))))) (syntax-dispatch tmp1554 (quote (any))))) e1549) (if (memv t1553 (quote (local-syntax-form))) (chi-local-syntax1134 value1548 e1549 r1535 w1550 s1551 mod1552 (lambda (body1562 r1563 w1564 s1565 mod1566) (chi-top-sequence1123 body1562 r1563 w1564 s1565 m1537 esew1538 mod1566))) (if (memv t1553 (quote (eval-when-form))) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569 x1570 e11571 e21572) (let ((when-list1573 (chi-when-list1125 e1549 x1570 w1550)) (body1574 (cons e11571 e21572))) (cond ((eq? m1537 (quote e)) (if (memq (quote eval) when-list1573) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) (chi-void1136))) ((memq (quote load) when-list1573) (if (or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c&e) (quote (compile load)) mod1552) (if (memq m1537 (quote (c c&e))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c) (quote (load)) mod1552) (chi-void1136)))) ((or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (top-level-eval-hook1063 (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) mod1552) (chi-void1136)) (else (chi-void1136))))) tmp1568) (syntax-error tmp1567))) (syntax-dispatch tmp1567 (quote (any each-any any . each-any))))) e1549) (if (memv t1553 (quote (define-syntax-form))) (let ((n1577 (id-var-name1114 value1548 w1550)) (r1578 (macros-only-env1088 r1535))) (let ((t1579 m1537)) (if (memv t1579 (quote (c))) (if (memq (quote compile) esew1538) (let ((e1580 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1580 mod1552) (if (memq (quote load) esew1538) e1580 (chi-void1136)))) (if (memq (quote load) esew1538) (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) (chi-void1136))) (if (memv t1579 (quote (c&e))) (let ((e1581 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1581 mod1552) e1581)) (begin (if (memq (quote eval) esew1538) (top-level-eval-hook1063 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) mod1552)) (chi-void1136)))))) (if (memv t1553 (quote (define-form))) (let ((n1582 (id-var-name1114 value1548 w1550))) (let ((type1583 (binding-type1084 (lookup1089 n1582 r1535 mod1552)))) (let ((t1584 type1583)) (if (memv t1584 (quote (global))) (let ((x1585 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1585 mod1552)) x1585)) (if (memv t1584 (quote (displaced-lexical))) (syntax-error (wrap1120 value1548 w1550 mod1552) "identifier out of context") (if (memv t1584 (quote (core macro module-ref))) (begin (remove-global-definition-hook1067 n1582 mod1552) (let ((x1586 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1586 mod1552)) x1586))) (syntax-error (wrap1120 value1548 w1550 mod1552) "cannot define keyword at top level"))))))) (let ((x1587 (chi-expr1129 type1547 value1548 e1549 r1535 w1550 s1551 mod1552))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1587 mod1552)) x1587)))))))))))) (syntax-type1126 (lambda (e1588 r1589 w1590 s1591 rib1592 mod1593) (cond ((symbol? e1588) (let ((n1594 (id-var-name1114 e1588 w1590))) (let ((b1595 (lookup1089 n1594 r1589 mod1593))) (let ((type1596 (binding-type1084 b1595))) (let ((t1597 type1596)) (if (memv t1597 (quote (lexical))) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (global))) (values type1596 n1594 e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1595) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593))))))))) ((pair? e1588) (let ((first1598 (car e1588))) (if (id?1092 first1598) (let ((n1599 (id-var-name1114 first1598 w1590))) (let ((b1600 (lookup1089 n1599 r1589 (or (and (syntax-object?1076 first1598) (syntax-object-module1079 first1598)) mod1593)))) (let ((type1601 (binding-type1084 b1600))) (let ((t1602 type1601)) (if (memv t1602 (quote (lexical))) (values (quote lexical-call) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (global))) (values (quote global-call) n1599 e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1600) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (if (memv t1602 (quote (core external-macro module-ref))) (values type1601 (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (begin))) (values (quote begin-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (eval-when))) (values (quote eval-when-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (define))) ((lambda (tmp1603) ((lambda (tmp1604) (if (if tmp1604 (apply (lambda (_1605 name1606 val1607) (id?1092 name1606)) tmp1604) #f) (apply (lambda (_1608 name1609 val1610) (values (quote define-form) name1609 val1610 w1590 s1591 mod1593)) tmp1604) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 name1613 args1614 e11615 e21616) (and (id?1092 name1613) (valid-bound-ids?1117 (lambda-var-list1141 args1614)))) tmp1611) #f) (apply (lambda (_1617 name1618 args1619 e11620 e21621) (values (quote define-form) (wrap1120 name1618 w1590 mod1593) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1120 (cons args1619 (cons e11620 e21621)) w1590 mod1593)) (quote (())) s1591 mod1593)) tmp1611) ((lambda (tmp1623) (if (if tmp1623 (apply (lambda (_1624 name1625) (id?1092 name1625)) tmp1623) #f) (apply (lambda (_1626 name1627) (values (quote define-form) (wrap1120 name1627 w1590 mod1593) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1591 mod1593)) tmp1623) (syntax-error tmp1603))) (syntax-dispatch tmp1603 (quote (any any)))))) (syntax-dispatch tmp1603 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1603 (quote (any any any))))) e1588) (if (memv t1602 (quote (define-syntax))) ((lambda (tmp1628) ((lambda (tmp1629) (if (if tmp1629 (apply (lambda (_1630 name1631 val1632) (id?1092 name1631)) tmp1629) #f) (apply (lambda (_1633 name1634 val1635) (values (quote define-syntax-form) name1634 val1635 w1590 s1591 mod1593)) tmp1629) (syntax-error tmp1628))) (syntax-dispatch tmp1628 (quote (any any any))))) e1588) (values (quote call) #f e1588 w1590 s1591 mod1593)))))))))))))) (values (quote call) #f e1588 w1590 s1591 mod1593)))) ((syntax-object?1076 e1588) (syntax-type1126 (syntax-object-expression1077 e1588) r1589 (join-wraps1111 w1590 (syntax-object-wrap1078 e1588)) #f rib1592 (or (syntax-object-module1079 e1588) mod1593))) ((annotation? e1588) (syntax-type1126 (annotation-expression e1588) r1589 w1590 (annotation-source e1588) rib1592 mod1593)) ((self-evaluating? e1588) (values (quote constant) #f e1588 w1590 s1591 mod1593)) (else (values (quote other) #f e1588 w1590 s1591 mod1593))))) (chi-when-list1125 (lambda (e1636 when-list1637 w1638) (let f1639 ((when-list1640 when-list1637) (situations1641 (quote ()))) (if (null? when-list1640) situations1641 (f1639 (cdr when-list1640) (cons (let ((x1642 (car when-list1640))) (cond ((free-id=?1115 x1642 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1115 x1642 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1115 x1642 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1120 x1642 w1638 #f) "invalid eval-when situation")))) situations1641)))))) (chi-install-global1124 (lambda (name1643 e1644) (build-annotated1069 #f (list (build-annotated1069 #f (quote install-global-transformer)) (build-data1070 #f name1643) e1644)))) (chi-top-sequence1123 (lambda (body1645 r1646 w1647 s1648 m1649 esew1650 mod1651) (build-sequence1071 s1648 (let dobody1652 ((body1653 body1645) (r1654 r1646) (w1655 w1647) (m1656 m1649) (esew1657 esew1650) (mod1658 mod1651)) (if (null? body1653) (quote ()) (let ((first1659 (chi-top1127 (car body1653) r1654 w1655 m1656 esew1657 mod1658))) (cons first1659 (dobody1652 (cdr body1653) r1654 w1655 m1656 esew1657 mod1658)))))))) (chi-sequence1122 (lambda (body1660 r1661 w1662 s1663 mod1664) (build-sequence1071 s1663 (let dobody1665 ((body1666 body1660) (r1667 r1661) (w1668 w1662) (mod1669 mod1664)) (if (null? body1666) (quote ()) (let ((first1670 (chi1128 (car body1666) r1667 w1668 mod1669))) (cons first1670 (dobody1665 (cdr body1666) r1667 w1668 mod1669)))))))) (source-wrap1121 (lambda (x1671 w1672 s1673 defmod1674) (wrap1120 (if s1673 (make-annotation x1671 s1673 #f) x1671) w1672 defmod1674))) (wrap1120 (lambda (x1675 w1676 defmod1677) (cond ((and (null? (wrap-marks1095 w1676)) (null? (wrap-subst1096 w1676))) x1675) ((syntax-object?1076 x1675) (make-syntax-object1075 (syntax-object-expression1077 x1675) (join-wraps1111 w1676 (syntax-object-wrap1078 x1675)) (syntax-object-module1079 x1675))) ((null? x1675) x1675) (else (make-syntax-object1075 x1675 w1676 defmod1677))))) (bound-id-member?1119 (lambda (x1678 list1679) (and (not (null? list1679)) (or (bound-id=?1116 x1678 (car list1679)) (bound-id-member?1119 x1678 (cdr list1679)))))) (distinct-bound-ids?1118 (lambda (ids1680) (let distinct?1681 ((ids1682 ids1680)) (or (null? ids1682) (and (not (bound-id-member?1119 (car ids1682) (cdr ids1682))) (distinct?1681 (cdr ids1682))))))) (valid-bound-ids?1117 (lambda (ids1683) (and (let all-ids?1684 ((ids1685 ids1683)) (or (null? ids1685) (and (id?1092 (car ids1685)) (all-ids?1684 (cdr ids1685))))) (distinct-bound-ids?1118 ids1683)))) (bound-id=?1116 (lambda (i1686 j1687) (if (and (syntax-object?1076 i1686) (syntax-object?1076 j1687)) (and (eq? (let ((e1688 (syntax-object-expression1077 i1686))) (if (annotation? e1688) (annotation-expression e1688) e1688)) (let ((e1689 (syntax-object-expression1077 j1687))) (if (annotation? e1689) (annotation-expression e1689) e1689))) (same-marks?1113 (wrap-marks1095 (syntax-object-wrap1078 i1686)) (wrap-marks1095 (syntax-object-wrap1078 j1687)))) (eq? (let ((e1690 i1686)) (if (annotation? e1690) (annotation-expression e1690) e1690)) (let ((e1691 j1687)) (if (annotation? e1691) (annotation-expression e1691) e1691)))))) (free-id=?1115 (lambda (i1692 j1693) (and (eq? (let ((x1694 i1692)) (let ((e1695 (if (syntax-object?1076 x1694) (syntax-object-expression1077 x1694) x1694))) (if (annotation? e1695) (annotation-expression e1695) e1695))) (let ((x1696 j1693)) (let ((e1697 (if (syntax-object?1076 x1696) (syntax-object-expression1077 x1696) x1696))) (if (annotation? e1697) (annotation-expression e1697) e1697)))) (eq? (id-var-name1114 i1692 (quote (()))) (id-var-name1114 j1693 (quote (()))))))) (id-var-name1114 (lambda (id1698 w1699) (letrec ((search-vector-rib1702 (lambda (sym1708 subst1709 marks1710 symnames1711 ribcage1712) (let ((n1713 (vector-length symnames1711))) (let f1714 ((i1715 0)) (cond ((fx=1061 i1715 n1713) (search1700 sym1708 (cdr subst1709) marks1710)) ((and (eq? (vector-ref symnames1711 i1715) sym1708) (same-marks?1113 marks1710 (vector-ref (ribcage-marks1102 ribcage1712) i1715))) (values (vector-ref (ribcage-labels1103 ribcage1712) i1715) marks1710)) (else (f1714 (fx+1059 i1715 1)))))))) (search-list-rib1701 (lambda (sym1716 subst1717 marks1718 symnames1719 ribcage1720) (let f1721 ((symnames1722 symnames1719) (i1723 0)) (cond ((null? symnames1722) (search1700 sym1716 (cdr subst1717) marks1718)) ((and (eq? (car symnames1722) sym1716) (same-marks?1113 marks1718 (list-ref (ribcage-marks1102 ribcage1720) i1723))) (values (list-ref (ribcage-labels1103 ribcage1720) i1723) marks1718)) (else (f1721 (cdr symnames1722) (fx+1059 i1723 1))))))) (search1700 (lambda (sym1724 subst1725 marks1726) (if (null? subst1725) (values #f marks1726) (let ((fst1727 (car subst1725))) (if (eq? fst1727 (quote shift)) (search1700 sym1724 (cdr subst1725) (cdr marks1726)) (let ((symnames1728 (ribcage-symnames1101 fst1727))) (if (vector? symnames1728) (search-vector-rib1702 sym1724 subst1725 marks1726 symnames1728 fst1727) (search-list-rib1701 sym1724 subst1725 marks1726 symnames1728 fst1727))))))))) (cond ((symbol? id1698) (or (call-with-values (lambda () (search1700 id1698 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1730 . ignore1729) x1730)) id1698)) ((syntax-object?1076 id1698) (let ((id1731 (let ((e1733 (syntax-object-expression1077 id1698))) (if (annotation? e1733) (annotation-expression e1733) e1733))) (w11732 (syntax-object-wrap1078 id1698))) (let ((marks1734 (join-marks1112 (wrap-marks1095 w1699) (wrap-marks1095 w11732)))) (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w1699) marks1734)) (lambda (new-id1735 marks1736) (or new-id1735 (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w11732) marks1736)) (lambda (x1738 . ignore1737) x1738)) id1731)))))) ((annotation? id1698) (let ((id1739 (let ((e1740 id1698)) (if (annotation? e1740) (annotation-expression e1740) e1740)))) (or (call-with-values (lambda () (search1700 id1739 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1742 . ignore1741) x1742)) id1739))) (else (error-hook1065 (quote id-var-name) "invalid id" id1698)))))) (same-marks?1113 (lambda (x1743 y1744) (or (eq? x1743 y1744) (and (not (null? x1743)) (not (null? y1744)) (eq? (car x1743) (car y1744)) (same-marks?1113 (cdr x1743) (cdr y1744)))))) (join-marks1112 (lambda (m11745 m21746) (smart-append1110 m11745 m21746))) (join-wraps1111 (lambda (w11747 w21748) (let ((m11749 (wrap-marks1095 w11747)) (s11750 (wrap-subst1096 w11747))) (if (null? m11749) (if (null? s11750) w21748 (make-wrap1094 (wrap-marks1095 w21748) (smart-append1110 s11750 (wrap-subst1096 w21748)))) (make-wrap1094 (smart-append1110 m11749 (wrap-marks1095 w21748)) (smart-append1110 s11750 (wrap-subst1096 w21748))))))) (smart-append1110 (lambda (m11751 m21752) (if (null? m21752) m11751 (append m11751 m21752)))) (make-binding-wrap1109 (lambda (ids1753 labels1754 w1755) (if (null? ids1753) w1755 (make-wrap1094 (wrap-marks1095 w1755) (cons (let ((labelvec1756 (list->vector labels1754))) (let ((n1757 (vector-length labelvec1756))) (let ((symnamevec1758 (make-vector n1757)) (marksvec1759 (make-vector n1757))) (begin (let f1760 ((ids1761 ids1753) (i1762 0)) (if (not (null? ids1761)) (call-with-values (lambda () (id-sym-name&marks1093 (car ids1761) w1755)) (lambda (symname1763 marks1764) (begin (vector-set! symnamevec1758 i1762 symname1763) (vector-set! marksvec1759 i1762 marks1764) (f1760 (cdr ids1761) (fx+1059 i1762 1))))))) (make-ribcage1099 symnamevec1758 marksvec1759 labelvec1756))))) (wrap-subst1096 w1755)))))) (extend-ribcage!1108 (lambda (ribcage1765 id1766 label1767) (begin (set-ribcage-symnames!1104 ribcage1765 (cons (let ((e1768 (syntax-object-expression1077 id1766))) (if (annotation? e1768) (annotation-expression e1768) e1768)) (ribcage-symnames1101 ribcage1765))) (set-ribcage-marks!1105 ribcage1765 (cons (wrap-marks1095 (syntax-object-wrap1078 id1766)) (ribcage-marks1102 ribcage1765))) (set-ribcage-labels!1106 ribcage1765 (cons label1767 (ribcage-labels1103 ribcage1765)))))) (anti-mark1107 (lambda (w1769) (make-wrap1094 (cons #f (wrap-marks1095 w1769)) (cons (quote shift) (wrap-subst1096 w1769))))) (set-ribcage-labels!1106 (lambda (x1770 update1771) (vector-set! x1770 3 update1771))) (set-ribcage-marks!1105 (lambda (x1772 update1773) (vector-set! x1772 2 update1773))) (set-ribcage-symnames!1104 (lambda (x1774 update1775) (vector-set! x1774 1 update1775))) (ribcage-labels1103 (lambda (x1776) (vector-ref x1776 3))) (ribcage-marks1102 (lambda (x1777) (vector-ref x1777 2))) (ribcage-symnames1101 (lambda (x1778) (vector-ref x1778 1))) (ribcage?1100 (lambda (x1779) (and (vector? x1779) (= (vector-length x1779) 4) (eq? (vector-ref x1779 0) (quote ribcage))))) (make-ribcage1099 (lambda (symnames1780 marks1781 labels1782) (vector (quote ribcage) symnames1780 marks1781 labels1782))) (gen-labels1098 (lambda (ls1783) (if (null? ls1783) (quote ()) (cons (gen-label1097) (gen-labels1098 (cdr ls1783)))))) (gen-label1097 (lambda () (string #\i))) (wrap-subst1096 cdr) (wrap-marks1095 car) (make-wrap1094 cons) (id-sym-name&marks1093 (lambda (x1784 w1785) (if (syntax-object?1076 x1784) (values (let ((e1786 (syntax-object-expression1077 x1784))) (if (annotation? e1786) (annotation-expression e1786) e1786)) (join-marks1112 (wrap-marks1095 w1785) (wrap-marks1095 (syntax-object-wrap1078 x1784)))) (values (let ((e1787 x1784)) (if (annotation? e1787) (annotation-expression e1787) e1787)) (wrap-marks1095 w1785))))) (id?1092 (lambda (x1788) (cond ((symbol? x1788) #t) ((syntax-object?1076 x1788) (symbol? (let ((e1789 (syntax-object-expression1077 x1788))) (if (annotation? e1789) (annotation-expression e1789) e1789)))) ((annotation? x1788) (symbol? (annotation-expression x1788))) (else #f)))) (nonsymbol-id?1091 (lambda (x1790) (and (syntax-object?1076 x1790) (symbol? (let ((e1791 (syntax-object-expression1077 x1790))) (if (annotation? e1791) (annotation-expression e1791) e1791)))))) (global-extend1090 (lambda (type1792 sym1793 val1794) (put-global-definition-hook1066 sym1793 (cons type1792 val1794) (module-name (current-module))))) (lookup1089 (lambda (x1795 r1796 mod1797) (cond ((assq x1795 r1796) => cdr) ((symbol? x1795) (or (get-global-definition-hook1068 x1795 mod1797) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1088 (lambda (r1798) (if (null? r1798) (quote ()) (let ((a1799 (car r1798))) (if (eq? (cadr a1799) (quote macro)) (cons a1799 (macros-only-env1088 (cdr r1798))) (macros-only-env1088 (cdr r1798))))))) (extend-var-env1087 (lambda (labels1800 vars1801 r1802) (if (null? labels1800) r1802 (extend-var-env1087 (cdr labels1800) (cdr vars1801) (cons (cons (car labels1800) (cons (quote lexical) (car vars1801))) r1802))))) (extend-env1086 (lambda (labels1803 bindings1804 r1805) (if (null? labels1803) r1805 (extend-env1086 (cdr labels1803) (cdr bindings1804) (cons (cons (car labels1803) (car bindings1804)) r1805))))) (binding-value1085 cdr) (binding-type1084 car) (source-annotation1083 (lambda (x1806) (cond ((annotation? x1806) (annotation-source x1806)) ((syntax-object?1076 x1806) (source-annotation1083 (syntax-object-expression1077 x1806))) (else #f)))) (set-syntax-object-module!1082 (lambda (x1807 update1808) (vector-set! x1807 3 update1808))) (set-syntax-object-wrap!1081 (lambda (x1809 update1810) (vector-set! x1809 2 update1810))) (set-syntax-object-expression!1080 (lambda (x1811 update1812) (vector-set! x1811 1 update1812))) (syntax-object-module1079 (lambda (x1813) (vector-ref x1813 3))) (syntax-object-wrap1078 (lambda (x1814) (vector-ref x1814 2))) (syntax-object-expression1077 (lambda (x1815) (vector-ref x1815 1))) (syntax-object?1076 (lambda (x1816) (and (vector? x1816) (= (vector-length x1816) 4) (eq? (vector-ref x1816 0) (quote syntax-object))))) (make-syntax-object1075 (lambda (expression1817 wrap1818 module1819) (vector (quote syntax-object) expression1817 wrap1818 module1819))) (build-letrec1074 (lambda (src1820 vars1821 val-exps1822 body-exp1823) (if (null? vars1821) (build-annotated1069 src1820 body-exp1823) (build-annotated1069 src1820 (list (quote letrec) (map list vars1821 val-exps1822) body-exp1823))))) (build-named-let1073 (lambda (src1824 vars1825 val-exps1826 body-exp1827) (if (null? vars1825) (build-annotated1069 src1824 body-exp1827) (build-annotated1069 src1824 (list (quote let) (car vars1825) (map list (cdr vars1825) val-exps1826) body-exp1827))))) (build-let1072 (lambda (src1828 vars1829 val-exps1830 body-exp1831) (if (null? vars1829) (build-annotated1069 src1828 body-exp1831) (build-annotated1069 src1828 (list (quote let) (map list vars1829 val-exps1830) body-exp1831))))) (build-sequence1071 (lambda (src1832 exps1833) (if (null? (cdr exps1833)) (build-annotated1069 src1832 (car exps1833)) (build-annotated1069 src1832 (cons (quote begin) exps1833))))) (build-data1070 (lambda (src1834 exp1835) (if (and (self-evaluating? exp1835) (not (vector? exp1835))) (build-annotated1069 src1834 exp1835) (build-annotated1069 src1834 (list (quote quote) exp1835))))) (build-annotated1069 (lambda (src1836 exp1837) (if (and src1836 (not (annotation? exp1837))) (make-annotation exp1837 src1836 #t) exp1837))) (get-global-definition-hook1068 (lambda (symbol1838 module1839) (let ((module1840 (if module1839 (resolve-module module1839) (let ((mod1841 (current-module))) (begin (if mod1841 (warn "wha" symbol1838)) mod1841))))) (let ((v1842 (module-variable module1840 symbol1838))) (and v1842 (or (object-property v1842 (quote *sc-expander*)) (and (variable-bound? v1842) (macro? (variable-ref v1842)) (macro-transformer (variable-ref v1842)) guile-macro))))))) (remove-global-definition-hook1067 (lambda (symbol1843 modname1844) (let ((module1845 (if modname1844 (resolve-module modname1844) (current-module)))) (let ((v1846 (module-local-variable module1845 symbol1843))) (if v1846 (let ((p1847 (assq (quote *sc-expander*) (object-properties v1846)))) (set-object-properties! v1846 (delq p1847 (object-properties v1846))))))))) (put-global-definition-hook1066 (lambda (symbol1848 binding1849 modname1850) (let ((module1851 (if modname1850 (resolve-module modname1850) (current-module)))) (let ((v1852 (or (module-variable module1851 symbol1848) (let ((v1853 (make-variable (gensym)))) (begin (module-add! module1851 symbol1848 v1853) v1853))))) (begin (if (not (variable-bound? v1852)) (variable-set! v1852 (gensym))) (set-object-property! v1852 (quote *sc-expander*) binding1849)))))) (error-hook1065 (lambda (who1854 why1855 what1856) (error who1854 "~a ~s" why1855 what1856))) (local-eval-hook1064 (lambda (x1857 mod1858) (eval (list noexpand1058 x1857) (if mod1858 (resolve-module mod1858) (interaction-environment))))) (top-level-eval-hook1063 (lambda (x1859 mod1860) (eval (list noexpand1058 x1859) (if mod1860 (resolve-module mod1860) (interaction-environment))))) (fx<1062 <) (fx=1061 =) (fx-1060 -) (fx+1059 +) (noexpand1058 "noexpand")) (begin (global-extend1090 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1090 (quote local-syntax) (quote let-syntax) #f) (global-extend1090 (quote core) (quote fluid-let-syntax) (lambda (e1861 r1862 w1863 s1864 mod1865) ((lambda (tmp1866) ((lambda (tmp1867) (if (if tmp1867 (apply (lambda (_1868 var1869 val1870 e11871 e21872) (valid-bound-ids?1117 var1869)) tmp1867) #f) (apply (lambda (_1874 var1875 val1876 e11877 e21878) (let ((names1879 (map (lambda (x1880) (id-var-name1114 x1880 w1863)) var1875))) (begin (for-each (lambda (id1882 n1883) (let ((t1884 (binding-type1084 (lookup1089 n1883 r1862 mod1865)))) (if (memv t1884 (quote (displaced-lexical))) (syntax-error (source-wrap1121 id1882 w1863 s1864 mod1865) "identifier out of context")))) var1875 names1879) (chi-body1132 (cons e11877 e21878) (source-wrap1121 e1861 w1863 s1864 mod1865) (extend-env1086 names1879 (let ((trans-r1887 (macros-only-env1088 r1862))) (map (lambda (x1888) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1888 trans-r1887 w1863 mod1865) mod1865))) val1876)) r1862) w1863 mod1865)))) tmp1867) ((lambda (_1890) (syntax-error (source-wrap1121 e1861 w1863 s1864 mod1865))) tmp1866))) (syntax-dispatch tmp1866 (quote (any #(each (any any)) any . each-any))))) e1861))) (global-extend1090 (quote core) (quote quote) (lambda (e1891 r1892 w1893 s1894 mod1895) ((lambda (tmp1896) ((lambda (tmp1897) (if tmp1897 (apply (lambda (_1898 e1899) (build-data1070 s1894 (strip1139 e1899 w1893))) tmp1897) ((lambda (_1900) (syntax-error (source-wrap1121 e1891 w1893 s1894 mod1895))) tmp1896))) (syntax-dispatch tmp1896 (quote (any any))))) e1891))) (global-extend1090 (quote core) (quote syntax) (letrec ((regen1908 (lambda (x1909) (let ((t1910 (car x1909))) (if (memv t1910 (quote (ref))) (build-annotated1069 #f (cadr x1909)) (if (memv t1910 (quote (primitive))) (build-annotated1069 #f (cadr x1909)) (if (memv t1910 (quote (quote))) (build-data1070 #f (cadr x1909)) (if (memv t1910 (quote (lambda))) (build-annotated1069 #f (list (quote lambda) (cadr x1909) (regen1908 (caddr x1909)))) (if (memv t1910 (quote (map))) (let ((ls1911 (map regen1908 (cdr x1909)))) (build-annotated1069 #f (cons (if (fx=1061 (length ls1911) 2) (build-annotated1069 #f (quote map)) (build-annotated1069 #f (quote map))) ls1911))) (build-annotated1069 #f (cons (build-annotated1069 #f (car x1909)) (map regen1908 (cdr x1909)))))))))))) (gen-vector1907 (lambda (x1912) (cond ((eq? (car x1912) (quote list)) (cons (quote vector) (cdr x1912))) ((eq? (car x1912) (quote quote)) (list (quote quote) (list->vector (cadr x1912)))) (else (list (quote list->vector) x1912))))) (gen-append1906 (lambda (x1913 y1914) (if (equal? y1914 (quote (quote ()))) x1913 (list (quote append) x1913 y1914)))) (gen-cons1905 (lambda (x1915 y1916) (let ((t1917 (car y1916))) (if (memv t1917 (quote (quote))) (if (eq? (car x1915) (quote quote)) (list (quote quote) (cons (cadr x1915) (cadr y1916))) (if (eq? (cadr y1916) (quote ())) (list (quote list) x1915) (list (quote cons) x1915 y1916))) (if (memv t1917 (quote (list))) (cons (quote list) (cons x1915 (cdr y1916))) (list (quote cons) x1915 y1916)))))) (gen-map1904 (lambda (e1918 map-env1919) (let ((formals1920 (map cdr map-env1919)) (actuals1921 (map (lambda (x1922) (list (quote ref) (car x1922))) map-env1919))) (cond ((eq? (car e1918) (quote ref)) (car actuals1921)) ((andmap (lambda (x1923) (and (eq? (car x1923) (quote ref)) (memq (cadr x1923) formals1920))) (cdr e1918)) (cons (quote map) (cons (list (quote primitive) (car e1918)) (map (let ((r1924 (map cons formals1920 actuals1921))) (lambda (x1925) (cdr (assq (cadr x1925) r1924)))) (cdr e1918))))) (else (cons (quote map) (cons (list (quote lambda) formals1920 e1918) actuals1921))))))) (gen-mappend1903 (lambda (e1926 map-env1927) (list (quote apply) (quote (primitive append)) (gen-map1904 e1926 map-env1927)))) (gen-ref1902 (lambda (src1928 var1929 level1930 maps1931) (if (fx=1061 level1930 0) (values var1929 maps1931) (if (null? maps1931) (syntax-error src1928 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1902 src1928 var1929 (fx-1060 level1930 1) (cdr maps1931))) (lambda (outer-var1932 outer-maps1933) (let ((b1934 (assq outer-var1932 (car maps1931)))) (if b1934 (values (cdr b1934) maps1931) (let ((inner-var1935 (gen-var1140 (quote tmp)))) (values inner-var1935 (cons (cons (cons outer-var1932 inner-var1935) (car maps1931)) outer-maps1933))))))))))) (gen-syntax1901 (lambda (src1936 e1937 r1938 maps1939 ellipsis?1940 mod1941) (if (id?1092 e1937) (let ((label1942 (id-var-name1114 e1937 (quote (()))))) (let ((b1943 (lookup1089 label1942 r1938 mod1941))) (if (eq? (binding-type1084 b1943) (quote syntax)) (call-with-values (lambda () (let ((var.lev1944 (binding-value1085 b1943))) (gen-ref1902 src1936 (car var.lev1944) (cdr var.lev1944) maps1939))) (lambda (var1945 maps1946) (values (list (quote ref) var1945) maps1946))) (if (ellipsis?1940 e1937) (syntax-error src1936 "misplaced ellipsis in syntax form") (values (list (quote quote) e1937) maps1939))))) ((lambda (tmp1947) ((lambda (tmp1948) (if (if tmp1948 (apply (lambda (dots1949 e1950) (ellipsis?1940 dots1949)) tmp1948) #f) (apply (lambda (dots1951 e1952) (gen-syntax1901 src1936 e1952 r1938 maps1939 (lambda (x1953) #f) mod1941)) tmp1948) ((lambda (tmp1954) (if (if tmp1954 (apply (lambda (x1955 dots1956 y1957) (ellipsis?1940 dots1956)) tmp1954) #f) (apply (lambda (x1958 dots1959 y1960) (let f1961 ((y1962 y1960) (k1963 (lambda (maps1964) (call-with-values (lambda () (gen-syntax1901 src1936 x1958 r1938 (cons (quote ()) maps1964) ellipsis?1940 mod1941)) (lambda (x1965 maps1966) (if (null? (car maps1966)) (syntax-error src1936 "extra ellipsis in syntax form") (values (gen-map1904 x1965 (car maps1966)) (cdr maps1966)))))))) ((lambda (tmp1967) ((lambda (tmp1968) (if (if tmp1968 (apply (lambda (dots1969 y1970) (ellipsis?1940 dots1969)) tmp1968) #f) (apply (lambda (dots1971 y1972) (f1961 y1972 (lambda (maps1973) (call-with-values (lambda () (k1963 (cons (quote ()) maps1973))) (lambda (x1974 maps1975) (if (null? (car maps1975)) (syntax-error src1936 "extra ellipsis in syntax form") (values (gen-mappend1903 x1974 (car maps1975)) (cdr maps1975)))))))) tmp1968) ((lambda (_1976) (call-with-values (lambda () (gen-syntax1901 src1936 y1962 r1938 maps1939 ellipsis?1940 mod1941)) (lambda (y1977 maps1978) (call-with-values (lambda () (k1963 maps1978)) (lambda (x1979 maps1980) (values (gen-append1906 x1979 y1977) maps1980)))))) tmp1967))) (syntax-dispatch tmp1967 (quote (any . any))))) y1962))) tmp1954) ((lambda (tmp1981) (if tmp1981 (apply (lambda (x1982 y1983) (call-with-values (lambda () (gen-syntax1901 src1936 x1982 r1938 maps1939 ellipsis?1940 mod1941)) (lambda (x1984 maps1985) (call-with-values (lambda () (gen-syntax1901 src1936 y1983 r1938 maps1985 ellipsis?1940 mod1941)) (lambda (y1986 maps1987) (values (gen-cons1905 x1984 y1986) maps1987)))))) tmp1981) ((lambda (tmp1988) (if tmp1988 (apply (lambda (e11989 e21990) (call-with-values (lambda () (gen-syntax1901 src1936 (cons e11989 e21990) r1938 maps1939 ellipsis?1940 mod1941)) (lambda (e1992 maps1993) (values (gen-vector1907 e1992) maps1993)))) tmp1988) ((lambda (_1994) (values (list (quote quote) e1937) maps1939)) tmp1947))) (syntax-dispatch tmp1947 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1947 (quote (any . any)))))) (syntax-dispatch tmp1947 (quote (any any . any)))))) (syntax-dispatch tmp1947 (quote (any any))))) e1937))))) (lambda (e1995 r1996 w1997 s1998 mod1999) (let ((e2000 (source-wrap1121 e1995 w1997 s1998 mod1999))) ((lambda (tmp2001) ((lambda (tmp2002) (if tmp2002 (apply (lambda (_2003 x2004) (call-with-values (lambda () (gen-syntax1901 e2000 x2004 r1996 (quote ()) ellipsis?1137 mod1999)) (lambda (e2005 maps2006) (regen1908 e2005)))) tmp2002) ((lambda (_2007) (syntax-error e2000)) tmp2001))) (syntax-dispatch tmp2001 (quote (any any))))) e2000))))) (global-extend1090 (quote core) (quote lambda) (lambda (e2008 r2009 w2010 s2011 mod2012) ((lambda (tmp2013) ((lambda (tmp2014) (if tmp2014 (apply (lambda (_2015 c2016) (chi-lambda-clause1133 (source-wrap1121 e2008 w2010 s2011 mod2012) c2016 r2009 w2010 mod2012 (lambda (vars2017 body2018) (build-annotated1069 s2011 (list (quote lambda) vars2017 body2018))))) tmp2014) (syntax-error tmp2013))) (syntax-dispatch tmp2013 (quote (any . any))))) e2008))) (global-extend1090 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1117 ids2026)) (syntax-error e2020 "duplicate bound variable in") (let ((labels2029 (gen-labels1098 ids2026)) (new-vars2030 (map gen-var1140 ids2026))) (let ((nw2031 (make-binding-wrap1109 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1087 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1128 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1132 exps2028 (source-wrap1121 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1072 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1092 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1073 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-error (source-wrap1121 e2034 w2036 s2037 mod2038))) tmp2039))) (syntax-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1090 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1117 ids2078)) (syntax-error e2066 "duplicate bound variable in") (let ((labels2080 (gen-labels1098 ids2078)) (new-vars2081 (map gen-var1140 ids2078))) (let ((w2082 (make-binding-wrap1109 ids2078 labels2080 w2068)) (r2083 (extend-var-env1087 labels2080 new-vars2081 r2067))) (build-letrec1074 s2069 new-vars2081 (map (lambda (x2084) (chi1128 x2084 r2083 w2082 mod2070)) val2075) (chi-body1132 (cons e12076 e22077) (source-wrap1121 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-error (source-wrap1121 e2066 w2068 s2069 mod2070))) tmp2071))) (syntax-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1090 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1092 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1128 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1114 id2099 w2090))) (let ((b2103 (lookup1089 n2102 r2089 mod2092))) (let ((t2104 (binding-type1084 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1069 s2091 (list (quote set!) (binding-value1085 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1069 s2091 (list (quote set!) (make-module-ref mod2092 n2102 #f) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-error (wrap1120 id2099 w2090 mod2092) "identifier out of context") (syntax-error (source-wrap1121 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1126 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1128 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1069 s2091 (list (quote set!) (make-module-ref mod2120 id2119 #f) val2117))))) (build-annotated1069 s2091 (cons (chi1128 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1128 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-error (source-wrap1121 e2088 w2090 s2091 mod2092))) tmp2093))) (syntax-dispatch tmp2093 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1090 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1092 mod2128) (id?1092 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax-object->datum id2133) (syntax-object->datum (append mod2132 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) tmp2126) (syntax-error tmp2125))) (syntax-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1090 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1092 mod2139) (id?1092 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax-object->datum id2144) (syntax-object->datum mod2143))) tmp2137) (syntax-error tmp2136))) (syntax-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1090 (quote begin) (quote begin) (quote ())) (global-extend1090 (quote define) (quote define) (quote ())) (global-extend1090 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1090 (quote eval-when) (quote eval-when) (quote ())) (global-extend1090 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-error)) x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1092 pat2157) (andmap (lambda (x2159) (not (free-id=?1115 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2151))) (let ((labels2160 (list (gen-label1097))) (var2161 (gen-var1140 pat2157))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list var2161) (chi1128 exp2158 (extend-env1086 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1109 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-error (car clauses2152) "invalid syntax-case clause")) tmp2155))) (syntax-dispatch tmp2155 (quote (any any any)))))) (syntax-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1118 (map car pvars2176))) (syntax-error pat2171 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2177) (not (ellipsis?1137 (car x2177)))) pvars2176)) (syntax-error pat2171 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2178 (gen-var1140 (quote tmp)))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1069 #f y2178))) (build-annotated1069 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1069 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1070 #f #f)))) tmp2180))) (syntax-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1069 #f (list (build-annotated1069 #f (quote list)) x2167)) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-dispatch)) x2167 (build-data1070 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1098 ids2188)) (new-vars2191 (map gen-var1140 ids2188))) (build-annotated1069 #f (list (build-annotated1069 #f (quote apply)) (build-annotated1069 #f (list (quote lambda) new-vars2191 (chi1128 exp2184 (extend-env1086 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1109 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1092 p2197) (if (bound-id-member?1119 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1137 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1059 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1139 p2197 (quote (())))) ids2199)) tmp2200))) (syntax-dispatch tmp2200 (quote #(vector each-any)))))) (syntax-dispatch tmp2200 (quote ()))))) (syntax-dispatch tmp2200 (quote (any . any)))))) (syntax-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1121 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1092 x2234) (not (ellipsis?1137 x2234)))) key2232) (let ((x2236 (gen-var1140 (quote tmp)))) (build-annotated1069 s2225 (list (build-annotated1069 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1069 #f x2236) key2232 m2233 r2223 mod2226))) (chi1128 val2231 r2223 (quote (())) mod2226)))) (syntax-error e2227 "invalid literals list in"))) tmp2229) (syntax-error tmp2228))) (syntax-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1058)) (cadr x2241) (chi-top1127 x2241 (quote ()) (quote ((top))) m2239 esew2240 (module-name (current-module))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1058)) (cadr x2245) (chi-top1127 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (module-name (current-module))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1091 x2246))) (set! datum->syntax-object (lambda (id2247 datum2248) (make-syntax-object1075 datum2248 (syntax-object-wrap1078 id2247) #f))) (set! syntax-object->datum (lambda (x2249) (strip1139 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1065 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1120 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1091 x2255)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1091 x2256)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1115 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1091 x2259)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1091 x2260)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1116 x2257 y2258)))) (set! syntax-error (lambda (object2262 . messages2261) (begin (for-each (lambda (x2263) (let ((x2264 x2263)) (if (not (string? x2264)) (error-hook1065 (quote syntax-error) "invalid argument" x2264)))) messages2261) (let ((message2265 (if (null? messages2261) "invalid syntax" (apply string-append messages2261)))) (error-hook1065 #f message2265 (strip1139 object2262 (quote (())))))))) (set! install-global-transformer (lambda (sym2266 v2267) (begin (let ((x2268 sym2266)) (if (not (symbol? x2268)) (error-hook1065 (quote define-syntax) "invalid argument" x2268))) (let ((x2269 v2267)) (if (not (procedure? x2269)) (error-hook1065 (quote define-syntax) "invalid argument" x2269))) (global-extend1090 (quote macro) sym2266 v2267)))) (letrec ((match2274 (lambda (e2275 p2276 w2277 r2278 mod2279) (cond ((not r2278) #f) ((eq? p2276 (quote any)) (cons (wrap1120 e2275 w2277 mod2279) r2278)) ((syntax-object?1076 e2275) (match*2273 (let ((e2280 (syntax-object-expression1077 e2275))) (if (annotation? e2280) (annotation-expression e2280) e2280)) p2276 (join-wraps1111 w2277 (syntax-object-wrap1078 e2275)) r2278 (syntax-object-module1079 e2275))) (else (match*2273 (let ((e2281 e2275)) (if (annotation? e2281) (annotation-expression e2281) e2281)) p2276 w2277 r2278 mod2279))))) (match*2273 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((null? p2283) (and (null? e2282) r2285)) ((pair? p2283) (and (pair? e2282) (match2274 (car e2282) (car p2283) w2284 (match2274 (cdr e2282) (cdr p2283) w2284 r2285 mod2286) mod2286))) ((eq? p2283 (quote each-any)) (let ((l2287 (match-each-any2271 e2282 w2284 mod2286))) (and l2287 (cons l2287 r2285)))) (else (let ((t2288 (vector-ref p2283 0))) (if (memv t2288 (quote (each))) (if (null? e2282) (match-empty2272 (vector-ref p2283 1) r2285) (let ((l2289 (match-each2270 e2282 (vector-ref p2283 1) w2284 mod2286))) (and l2289 (let collect2290 ((l2291 l2289)) (if (null? (car l2291)) r2285 (cons (map car l2291) (collect2290 (map cdr l2291)))))))) (if (memv t2288 (quote (free-id))) (and (id?1092 e2282) (free-id=?1115 (wrap1120 e2282 w2284 mod2286) (vector-ref p2283 1)) r2285) (if (memv t2288 (quote (atom))) (and (equal? (vector-ref p2283 1) (strip1139 e2282 w2284)) r2285) (if (memv t2288 (quote (vector))) (and (vector? e2282) (match2274 (vector->list e2282) (vector-ref p2283 1) w2284 r2285 mod2286))))))))))) (match-empty2272 (lambda (p2292 r2293) (cond ((null? p2292) r2293) ((eq? p2292 (quote any)) (cons (quote ()) r2293)) ((pair? p2292) (match-empty2272 (car p2292) (match-empty2272 (cdr p2292) r2293))) ((eq? p2292 (quote each-any)) (cons (quote ()) r2293)) (else (let ((t2294 (vector-ref p2292 0))) (if (memv t2294 (quote (each))) (match-empty2272 (vector-ref p2292 1) r2293) (if (memv t2294 (quote (free-id atom))) r2293 (if (memv t2294 (quote (vector))) (match-empty2272 (vector-ref p2292 1) r2293))))))))) (match-each-any2271 (lambda (e2295 w2296 mod2297) (cond ((annotation? e2295) (match-each-any2271 (annotation-expression e2295) w2296 mod2297)) ((pair? e2295) (let ((l2298 (match-each-any2271 (cdr e2295) w2296 mod2297))) (and l2298 (cons (wrap1120 (car e2295) w2296 mod2297) l2298)))) ((null? e2295) (quote ())) ((syntax-object?1076 e2295) (match-each-any2271 (syntax-object-expression1077 e2295) (join-wraps1111 w2296 (syntax-object-wrap1078 e2295)) mod2297)) (else #f)))) (match-each2270 (lambda (e2299 p2300 w2301 mod2302) (cond ((annotation? e2299) (match-each2270 (annotation-expression e2299) p2300 w2301 mod2302)) ((pair? e2299) (let ((first2303 (match2274 (car e2299) p2300 w2301 (quote ()) mod2302))) (and first2303 (let ((rest2304 (match-each2270 (cdr e2299) p2300 w2301 mod2302))) (and rest2304 (cons first2303 rest2304)))))) ((null? e2299) (quote ())) ((syntax-object?1076 e2299) (match-each2270 (syntax-object-expression1077 e2299) p2300 (join-wraps1111 w2301 (syntax-object-wrap1078 e2299)) (syntax-object-module1079 e2299))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2305 p2306) (cond ((eq? p2306 (quote any)) (list e2305)) ((syntax-object?1076 e2305) (match*2273 (let ((e2307 (syntax-object-expression1077 e2305))) (if (annotation? e2307) (annotation-expression e2307) e2307)) p2306 (syntax-object-wrap1078 e2305) (quote ()) (syntax-object-module1079 e2305))) (else (match*2273 (let ((e2308 e2305)) (if (annotation? e2308) (annotation-expression e2308) e2308)) p2306 (quote (())) (quote ()) #f))))) (set! sc-chi chi1128))))) +(install-global-transformer (quote with-syntax) (lambda (x2309) ((lambda (tmp2310) ((lambda (tmp2311) (if tmp2311 (apply (lambda (_2312 e12313 e22314) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12313 e22314))) tmp2311) ((lambda (tmp2316) (if tmp2316 (apply (lambda (_2317 out2318 in2319 e12320 e22321) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2319 (quote ()) (list out2318 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12320 e22321))))) tmp2316) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2326) (quote ()) (list out2325 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12327 e22328))))) tmp2323) (syntax-error tmp2310))) (syntax-dispatch tmp2310 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any () any . each-any))))) x2309))) +(install-global-transformer (quote syntax-rules) (lambda (x2332) ((lambda (tmp2333) ((lambda (tmp2334) (if tmp2334 (apply (lambda (_2335 k2336 keyword2337 pattern2338 template2339) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2336 (map (lambda (tmp2342 tmp2341) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2341) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2342))) template2339 pattern2338)))))) tmp2334) (syntax-error tmp2333))) (syntax-dispatch tmp2333 (quote (any each-any . #(each ((any . any) any))))))) x2332))) +(install-global-transformer (quote let*) (lambda (x2343) ((lambda (tmp2344) ((lambda (tmp2345) (if (if tmp2345 (apply (lambda (let*2346 x2347 v2348 e12349 e22350) (andmap identifier? x2347)) tmp2345) #f) (apply (lambda (let*2352 x2353 v2354 e12355 e22356) (let f2357 ((bindings2358 (map list x2353 v2354))) (if (null? bindings2358) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12355 e22356))) ((lambda (tmp2362) ((lambda (tmp2363) (if tmp2363 (apply (lambda (body2364 binding2365) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2365) body2364)) tmp2363) (syntax-error tmp2362))) (syntax-dispatch tmp2362 (quote (any any))))) (list (f2357 (cdr bindings2358)) (car bindings2358)))))) tmp2345) (syntax-error tmp2344))) (syntax-dispatch tmp2344 (quote (any #(each (any any)) any . each-any))))) x2343))) +(install-global-transformer (quote do) (lambda (orig-x2366) ((lambda (tmp2367) ((lambda (tmp2368) (if tmp2368 (apply (lambda (_2369 var2370 init2371 step2372 e02373 e12374 c2375) ((lambda (tmp2376) ((lambda (tmp2377) (if tmp2377 (apply (lambda (step2378) ((lambda (tmp2379) ((lambda (tmp2380) (if tmp2380 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02373) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2378))))))) tmp2380) ((lambda (tmp2385) (if tmp2385 (apply (lambda (e12386 e22387) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02373 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12386 e22387)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2378))))))) tmp2385) (syntax-error tmp2379))) (syntax-dispatch tmp2379 (quote (any . each-any)))))) (syntax-dispatch tmp2379 (quote ())))) e12374)) tmp2377) (syntax-error tmp2376))) (syntax-dispatch tmp2376 (quote each-any)))) (map (lambda (v2394 s2395) ((lambda (tmp2396) ((lambda (tmp2397) (if tmp2397 (apply (lambda () v2394) tmp2397) ((lambda (tmp2398) (if tmp2398 (apply (lambda (e2399) e2399) tmp2398) ((lambda (_2400) (syntax-error orig-x2366)) tmp2396))) (syntax-dispatch tmp2396 (quote (any)))))) (syntax-dispatch tmp2396 (quote ())))) s2395)) var2370 step2372))) tmp2368) (syntax-error tmp2367))) (syntax-dispatch tmp2367 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2366))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2403 (lambda (x2407 y2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (dy2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (dx2418) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2418 dy2415))) tmp2417) ((lambda (_2419) (if (null? dy2415) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2411) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2411 y2412))) tmp2416))) (syntax-dispatch tmp2416 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2411)) tmp2414) ((lambda (tmp2420) (if tmp2420 (apply (lambda (stuff2421) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2411 stuff2421))) tmp2420) ((lambda (else2422) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2411 y2412)) tmp2413))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2412)) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any any))))) (list x2407 y2408)))) (quasiappend2404 (lambda (x2423 y2424) ((lambda (tmp2425) ((lambda (tmp2426) (if tmp2426 (apply (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda () x2427) tmp2430) ((lambda (_2431) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2427 y2428)) tmp2429))) (syntax-dispatch tmp2429 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2428)) tmp2426) (syntax-error tmp2425))) (syntax-dispatch tmp2425 (quote (any any))))) (list x2423 y2424)))) (quasivector2405 (lambda (x2432) ((lambda (tmp2433) ((lambda (x2434) ((lambda (tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda (x2437) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2437))) tmp2436) ((lambda (tmp2439) (if tmp2439 (apply (lambda (x2440) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2440)) tmp2439) ((lambda (_2442) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2434)) tmp2435))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2434)) tmp2433)) x2432))) (quasi2406 (lambda (p2443 lev2444) ((lambda (tmp2445) ((lambda (tmp2446) (if tmp2446 (apply (lambda (p2447) (if (= lev2444 0) p2447 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2406 (list p2447) (- lev2444 1))))) tmp2446) ((lambda (tmp2448) (if tmp2448 (apply (lambda (p2449 q2450) (if (= lev2444 0) (quasiappend2404 p2449 (quasi2406 q2450 lev2444)) (quasicons2403 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2406 (list p2449) (- lev2444 1))) (quasi2406 q2450 lev2444)))) tmp2448) ((lambda (tmp2451) (if tmp2451 (apply (lambda (p2452) (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2406 (list p2452) (+ lev2444 1)))) tmp2451) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454 q2455) (quasicons2403 (quasi2406 p2454 lev2444) (quasi2406 q2455 lev2444))) tmp2453) ((lambda (tmp2456) (if tmp2456 (apply (lambda (x2457) (quasivector2405 (quasi2406 x2457 lev2444))) tmp2456) ((lambda (p2459) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2459)) tmp2445))) (syntax-dispatch tmp2445 (quote #(vector each-any)))))) (syntax-dispatch tmp2445 (quote (any . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2445 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2443)))) (lambda (x2460) ((lambda (tmp2461) ((lambda (tmp2462) (if tmp2462 (apply (lambda (_2463 e2464) (quasi2406 e2464 0)) tmp2462) (syntax-error tmp2461))) (syntax-dispatch tmp2461 (quote (any any))))) x2460)))) +(install-global-transformer (quote include) (lambda (x2465) (letrec ((read-file2466 (lambda (fn2467 k2468) (let ((p2469 (open-input-file fn2467))) (let f2470 ((x2471 (read p2469))) (if (eof-object? x2471) (begin (close-input-port p2469) (quote ())) (cons (datum->syntax-object k2468 x2471) (f2470 (read p2469))))))))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (k2474 filename2475) (let ((fn2476 (syntax-object->datum filename2475))) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (exp2479) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2479)) tmp2478) (syntax-error tmp2477))) (syntax-dispatch tmp2477 (quote each-any)))) (read-file2466 fn2476 k2474)))) tmp2473) (syntax-error tmp2472))) (syntax-dispatch tmp2472 (quote (any any))))) x2465)))) +(install-global-transformer (quote unquote) (lambda (x2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (_2484 e2485) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2485))) tmp2483) (syntax-error tmp2482))) (syntax-dispatch tmp2482 (quote (any any))))) x2481))) +(install-global-transformer (quote unquote-splicing) (lambda (x2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (_2489 e2490) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2490))) tmp2488) (syntax-error tmp2487))) (syntax-dispatch tmp2487 (quote (any any))))) x2486))) +(install-global-transformer (quote case) (lambda (x2491) ((lambda (tmp2492) ((lambda (tmp2493) (if tmp2493 (apply (lambda (_2494 e2495 m12496 m22497) ((lambda (tmp2498) ((lambda (body2499) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2495)) body2499)) tmp2498)) (let f2500 ((clause2501 m12496) (clauses2502 m22497)) (if (null? clauses2502) ((lambda (tmp2504) ((lambda (tmp2505) (if tmp2505 (apply (lambda (e12506 e22507) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12506 e22507))) tmp2505) ((lambda (tmp2509) (if tmp2509 (apply (lambda (k2510 e12511 e22512) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2510)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12511 e22512)))) tmp2509) ((lambda (_2515) (syntax-error x2491)) tmp2504))) (syntax-dispatch tmp2504 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2504 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2501) ((lambda (tmp2516) ((lambda (rest2517) ((lambda (tmp2518) ((lambda (tmp2519) (if tmp2519 (apply (lambda (k2520 e12521 e22522) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2520)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12521 e22522)) rest2517)) tmp2519) ((lambda (_2525) (syntax-error x2491)) tmp2518))) (syntax-dispatch tmp2518 (quote (each-any any . each-any))))) clause2501)) tmp2516)) (f2500 (car clauses2502) (cdr clauses2502))))))) tmp2493) (syntax-error tmp2492))) (syntax-dispatch tmp2492 (quote (any any any . each-any))))) x2491))) +(install-global-transformer (quote identifier-syntax) (lambda (x2526) ((lambda (tmp2527) ((lambda (tmp2528) (if tmp2528 (apply (lambda (_2529 e2530) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2530)) (list (cons _2529 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2530 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2528) (syntax-error tmp2527))) (syntax-dispatch tmp2527 (quote (any any))))) x2526))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 5707d5f0d..2deca5762 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -342,7 +342,7 @@ (resolve-module modname) (current-module))) (v (or (module-variable module symbol) - (let ((v (make-variable 'sc-macro))) + (let ((v (make-variable (gensym)))) (module-add! module symbol v) v)))) (if (not (variable-bound? v)) @@ -364,7 +364,9 @@ (lambda (symbol module) (let* ((module (if module (resolve-module module) - (warn "wha" symbol (current-module)))) + (let ((mod (current-module))) + (if mod (warn "wha" symbol)) + mod))) (v (module-variable module symbol))) (and v (or (object-property v '*sc-expander*) @@ -1786,9 +1788,10 @@ (lambda (type value ee ww ss modmod) (case type ((module-ref) - (call-with-values (lambda () (value (syntax (head tail ...)))) - (lambda (id mod) - (build-global-assignment s id (syntax val) mod)))) + (let ((val (chi (syntax val) r w mod))) + (call-with-values (lambda () (value (syntax (head tail ...)))) + (lambda (id mod) + (build-global-assignment s id val mod))))) (else (build-application s (chi (syntax (setter head)) r w mod) diff --git a/module/language/glil.scm b/module/language/glil.scm index 01b680194..51e7efac4 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -131,7 +131,7 @@ ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) - ((label ,label) (make-label ,label)) + ((label ,label) (make-label label)) ((branch ,inst ,label) (make-glil-branch inst label)) ((call ,inst ,nargs) (make-glil-call inst nargs)) ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra)) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 86234059e..45d6c204f 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,12 +27,11 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) - #:use-module (ice-9 expand-support) - #:use-module ((ice-9 syncase) #:select (sc-macro)) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 *translate-table* define-scheme-translator)) +(module-ref (current-module) 'receive) ;;; environment := #f ;;; | MODULE @@ -70,12 +69,13 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (let ((x (make-ghil-lambda env #f vars #f '() - (translate-1 env #f x))) - (cenv (make-cenv (current-module) - (ghil-env-parent env) - (if e (cenv-externals e) '())))) - (values x cenv cenv))))))) + (let ((x (sc-expand3 x 'c '(compile load eval)))) + (let ((x (make-ghil-lambda env #f vars #f '() + (translate-1 env #f x))) + (cenv (make-cenv (current-module) + (ghil-env-parent env) + (if e (cenv-externals e) '())))) + (values x cenv cenv)))))))) ;;; @@ -104,9 +104,6 @@ (let* ((mod (current-module)) (val (cond ((symbol? head) (module-ref/safe mod head)) - ;; allow macros to be unquoted into the output of a macro - ;; expansion - ((macro? head) head) ((pmatch head ((@ ,modname ,sym) (module-ref/safe (resolve-interface modname) sym)) @@ -117,18 +114,6 @@ (cond ((hashq-ref *translate-table* val)) - ((defmacro? val) - (lambda (env loc exp) - (retrans (apply (defmacro-transformer val) (cdr exp))))) - - ((eq? val sc-macro) - ;; syncase! - (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3))) - (lambda (env loc exp) - (retrans - (strip-expansion-structures - (sc-expand3 exp 'c '(compile load eval))))))) - ((primitive-macro? val) (syntax-error #f "unhandled primitive macro" head)) @@ -180,7 +165,7 @@ (define-macro (define-scheme-translator sym . clauses) `(hashq-set! (@ (language scheme compile-ghil) *translate-table*) - ,sym + (module-ref (current-module) ',sym) (lambda (e l exp) (define (retrans x) ((@ (language scheme compile-ghil) translate-1) From 7c72fe0bb5a6ef00c90f6988ce3178a45ed95f26 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Apr 2009 13:34:23 +0200 Subject: [PATCH 066/375] ice-9 syncase now deprecated, woo Remove #:use-module (ice-9 syncase) from lots of places, as it's no longer needed. --- module/ice-9/null.scm | 1 - module/ice-9/occam-channel.scm | 1 - module/language/scheme/amatch.scm | 4 +--- module/language/scheme/expand.scm | 1 - module/srfi/srfi-11.scm | 1 - module/srfi/srfi-39.scm | 1 - module/system/base/pmatch.scm | 1 - 7 files changed, 1 insertion(+), 9 deletions(-) diff --git a/module/ice-9/null.scm b/module/ice-9/null.scm index b9212e605..3f9f5b0a5 100644 --- a/module/ice-9/null.scm +++ b/module/ice-9/null.scm @@ -18,7 +18,6 @@ ;;;; The null environment - only syntactic bindings (define-module (ice-9 null) - :use-module (ice-9 syncase) :re-export-syntax (define quote lambda if set! cond case and or diff --git a/module/ice-9/occam-channel.scm b/module/ice-9/occam-channel.scm index e28f73d3b..e04ecac5b 100644 --- a/module/ice-9/occam-channel.scm +++ b/module/ice-9/occam-channel.scm @@ -17,7 +17,6 @@ ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 occam-channel) - #:use-syntax (ice-9 syncase) #:use-module (oop goops) #:use-module (ice-9 threads) #:export-syntax (alt diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm index 4ac973620..190b37f6a 100644 --- a/module/language/scheme/amatch.scm +++ b/module/language/scheme/amatch.scm @@ -1,7 +1,5 @@ (define-module (language scheme amatch) - #:use-module (ice-9 syncase) - #:export (amatch apat)) -;; FIXME: shouldn't have to export apat... + #:export (amatch)) ;; This is exactly the same as pmatch except that it unpacks annotations ;; as needed. diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm index 2ffefb318..cbf3f1862 100644 --- a/module/language/scheme/expand.scm +++ b/module/language/scheme/expand.scm @@ -23,7 +23,6 @@ #:use-module (language scheme amatch) #:use-module (ice-9 expand-support) #:use-module (ice-9 optargs) - #:use-module ((ice-9 syncase) #:select (sc-macro)) #:use-module ((system base compile) #:select (syntax-error)) #:export (expand *expand-table* define-scheme-expander)) diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index 9e17d6632..afa1730f1 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -37,7 +37,6 @@ ;;; Code: (define-module (srfi srfi-11) - :use-module (ice-9 syncase) :export-syntax (let-values let*-values)) (cond-expand-provide (current-module) '(srfi-11)) diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm index 086751170..87154d6df 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -35,7 +35,6 @@ ;;; Code: (define-module (srfi srfi-39) - #:use-module (ice-9 syncase) #:use-module (srfi srfi-16) #:export (make-parameter) diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm index 902fc49a5..5dae355e6 100644 --- a/module/system/base/pmatch.scm +++ b/module/system/base/pmatch.scm @@ -1,5 +1,4 @@ (define-module (system base pmatch) - #:use-module (ice-9 syncase) #:export (pmatch)) ;; FIXME: shouldn't have to export ppat... From 384e92b3ae491e2f8495b0d188b384f138a8cc61 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 12:12:24 +0200 Subject: [PATCH 067/375] fix @ and syncase * module/ice-9/boot-9.scm (make-module-ref): equal?, not eq?, when matching on module name. (Module names don't have to come from an invocation of module-name in this process.) * module/ice-9/psyntax.scm (build-global-reference) (build-global-assignment, @): Rework the format of the module in syntax objects so that a car of #f indicates a public reference. Loading (foo %module-public-interface) didn't guarantee that (foo) was loaded and useful. * module/ice-9/psyntax-pp.scm: Regenerated. * module/language/scheme/compile-ghil.scm (lookup-transformer): primitive-macro? does not exist any more. --- module/ice-9/boot-9.scm | 2 +- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 16 +++++++++++----- module/language/scheme/compile-ghil.scm | 3 --- 4 files changed, 23 insertions(+), 20 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ac1ffd66a..feb5c3e48 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -135,7 +135,7 @@ (define (make-module-ref mod var public?) (cond ((or (not mod) - (eq? mod (module-name (current-module))) + (equal? mod (module-name (current-module))) (and (not public?) (not (module-variable (resolve-module mod) var)))) var) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index befef849c..54261e1fa 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list1141 (lambda (vars1340) (let lvl1341 ((vars1342 vars1340) (ls1343 (quote ())) (w1344 (quote (())))) (cond ((pair? vars1342) (lvl1341 (cdr vars1342) (cons (wrap1120 (car vars1342) w1344 #f) ls1343) w1344)) ((id?1092 vars1342) (cons (wrap1120 vars1342 w1344 #f) ls1343)) ((null? vars1342) ls1343) ((syntax-object?1076 vars1342) (lvl1341 (syntax-object-expression1077 vars1342) ls1343 (join-wraps1111 w1344 (syntax-object-wrap1078 vars1342)))) ((annotation? vars1342) (lvl1341 (annotation-expression vars1342) ls1343 w1344)) (else (cons vars1342 ls1343)))))) (gen-var1140 (lambda (id1345) (let ((id1346 (if (syntax-object?1076 id1345) (syntax-object-expression1077 id1345) id1345))) (if (annotation? id1346) (build-annotated1069 (annotation-source id1346) (gensym (symbol->string (annotation-expression id1346)))) (build-annotated1069 #f (gensym (symbol->string id1346))))))) (strip1139 (lambda (x1347 w1348) (if (memq (quote top) (wrap-marks1095 w1348)) (if (or (annotation? x1347) (and (pair? x1347) (annotation? (car x1347)))) (strip-annotation1138 x1347 #f) x1347) (let f1349 ((x1350 x1347)) (cond ((syntax-object?1076 x1350) (strip1139 (syntax-object-expression1077 x1350) (syntax-object-wrap1078 x1350))) ((pair? x1350) (let ((a1351 (f1349 (car x1350))) (d1352 (f1349 (cdr x1350)))) (if (and (eq? a1351 (car x1350)) (eq? d1352 (cdr x1350))) x1350 (cons a1351 d1352)))) ((vector? x1350) (let ((old1353 (vector->list x1350))) (let ((new1354 (map f1349 old1353))) (if (andmap eq? old1353 new1354) x1350 (list->vector new1354))))) (else x1350)))))) (strip-annotation1138 (lambda (x1355 parent1356) (cond ((pair? x1355) (let ((new1357 (cons #f #f))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1357)) (set-car! new1357 (strip-annotation1138 (car x1355) #f)) (set-cdr! new1357 (strip-annotation1138 (cdr x1355) #f)) new1357))) ((annotation? x1355) (or (annotation-stripped x1355) (strip-annotation1138 (annotation-expression x1355) x1355))) ((vector? x1355) (let ((new1358 (make-vector (vector-length x1355)))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1358)) (let loop1359 ((i1360 (- (vector-length x1355) 1))) (unless (fx<1062 i1360 0) (vector-set! new1358 i1360 (strip-annotation1138 (vector-ref x1355 i1360) #f)) (loop1359 (fx-1060 i1360 1)))) new1358))) (else x1355)))) (ellipsis?1137 (lambda (x1361) (and (nonsymbol-id?1091 x1361) (free-id=?1115 x1361 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1136 (lambda () (build-annotated1069 #f (list (build-annotated1069 #f (quote void)))))) (eval-local-transformer1135 (lambda (expanded1362 mod1363) (let ((p1364 (local-eval-hook1064 expanded1362 mod1363))) (if (procedure? p1364) p1364 (syntax-error p1364 "nonprocedure transformer"))))) (chi-local-syntax1134 (lambda (rec?1365 e1366 r1367 w1368 s1369 mod1370 k1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 id1375 val1376 e11377 e21378) (let ((ids1379 id1375)) (if (not (valid-bound-ids?1117 ids1379)) (syntax-error e1366 "duplicate bound keyword in") (let ((labels1381 (gen-labels1098 ids1379))) (let ((new-w1382 (make-binding-wrap1109 ids1379 labels1381 w1368))) (k1371 (cons e11377 e21378) (extend-env1086 labels1381 (let ((w1384 (if rec?1365 new-w1382 w1368)) (trans-r1385 (macros-only-env1088 r1367))) (map (lambda (x1386) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1386 trans-r1385 w1384 mod1370) mod1370))) val1376)) r1367) new-w1382 s1369 mod1370)))))) tmp1373) ((lambda (_1388) (syntax-error (source-wrap1121 e1366 w1368 s1369 mod1370))) tmp1372))) (syntax-dispatch tmp1372 (quote (any #(each (any any)) any . each-any))))) e1366))) (chi-lambda-clause1133 (lambda (e1389 c1390 r1391 w1392 mod1393 k1394) ((lambda (tmp1395) ((lambda (tmp1396) (if tmp1396 (apply (lambda (id1397 e11398 e21399) (let ((ids1400 id1397)) (if (not (valid-bound-ids?1117 ids1400)) (syntax-error e1389 "invalid parameter list in") (let ((labels1402 (gen-labels1098 ids1400)) (new-vars1403 (map gen-var1140 ids1400))) (k1394 new-vars1403 (chi-body1132 (cons e11398 e21399) e1389 (extend-var-env1087 labels1402 new-vars1403 r1391) (make-binding-wrap1109 ids1400 labels1402 w1392) mod1393)))))) tmp1396) ((lambda (tmp1405) (if tmp1405 (apply (lambda (ids1406 e11407 e21408) (let ((old-ids1409 (lambda-var-list1141 ids1406))) (if (not (valid-bound-ids?1117 old-ids1409)) (syntax-error e1389 "invalid parameter list in") (let ((labels1410 (gen-labels1098 old-ids1409)) (new-vars1411 (map gen-var1140 old-ids1409))) (k1394 (let f1412 ((ls11413 (cdr new-vars1411)) (ls21414 (car new-vars1411))) (if (null? ls11413) ls21414 (f1412 (cdr ls11413) (cons (car ls11413) ls21414)))) (chi-body1132 (cons e11407 e21408) e1389 (extend-var-env1087 labels1410 new-vars1411 r1391) (make-binding-wrap1109 old-ids1409 labels1410 w1392) mod1393)))))) tmp1405) ((lambda (_1416) (syntax-error e1389)) tmp1395))) (syntax-dispatch tmp1395 (quote (any any . each-any)))))) (syntax-dispatch tmp1395 (quote (each-any any . each-any))))) c1390))) (chi-body1132 (lambda (body1417 outer-form1418 r1419 w1420 mod1421) (let ((r1422 (cons (quote ("placeholder" placeholder)) r1419))) (let ((ribcage1423 (make-ribcage1099 (quote ()) (quote ()) (quote ())))) (let ((w1424 (make-wrap1094 (wrap-marks1095 w1420) (cons ribcage1423 (wrap-subst1096 w1420))))) (let parse1425 ((body1426 (map (lambda (x1432) (cons r1422 (wrap1120 x1432 w1424 mod1421))) body1417)) (ids1427 (quote ())) (labels1428 (quote ())) (vars1429 (quote ())) (vals1430 (quote ())) (bindings1431 (quote ()))) (if (null? body1426) (syntax-error outer-form1418 "no expressions in body") (let ((e1433 (cdar body1426)) (er1434 (caar body1426))) (call-with-values (lambda () (syntax-type1126 e1433 er1434 (quote (())) #f ribcage1423 mod1421)) (lambda (type1435 value1436 e1437 w1438 s1439 mod1440) (let ((t1441 type1435)) (if (memv t1441 (quote (define-form))) (let ((id1442 (wrap1120 value1436 w1438 mod1440)) (label1443 (gen-label1097))) (let ((var1444 (gen-var1140 id1442))) (begin (extend-ribcage!1108 ribcage1423 id1442 label1443) (parse1425 (cdr body1426) (cons id1442 ids1427) (cons label1443 labels1428) (cons var1444 vars1429) (cons (cons er1434 (wrap1120 e1437 w1438 mod1440)) vals1430) (cons (cons (quote lexical) var1444) bindings1431))))) (if (memv t1441 (quote (define-syntax-form))) (let ((id1445 (wrap1120 value1436 w1438 mod1440)) (label1446 (gen-label1097))) (begin (extend-ribcage!1108 ribcage1423 id1445 label1446) (parse1425 (cdr body1426) (cons id1445 ids1427) (cons label1446 labels1428) vars1429 vals1430 (cons (cons (quote macro) (cons er1434 (wrap1120 e1437 w1438 mod1440))) bindings1431)))) (if (memv t1441 (quote (begin-form))) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (_1449 e11450) (parse1425 (let f1451 ((forms1452 e11450)) (if (null? forms1452) (cdr body1426) (cons (cons er1434 (wrap1120 (car forms1452) w1438 mod1440)) (f1451 (cdr forms1452))))) ids1427 labels1428 vars1429 vals1430 bindings1431)) tmp1448) (syntax-error tmp1447))) (syntax-dispatch tmp1447 (quote (any . each-any))))) e1437) (if (memv t1441 (quote (local-syntax-form))) (chi-local-syntax1134 value1436 e1437 er1434 w1438 s1439 mod1440 (lambda (forms1454 er1455 w1456 s1457 mod1458) (parse1425 (let f1459 ((forms1460 forms1454)) (if (null? forms1460) (cdr body1426) (cons (cons er1455 (wrap1120 (car forms1460) w1456 mod1458)) (f1459 (cdr forms1460))))) ids1427 labels1428 vars1429 vals1430 bindings1431))) (if (null? ids1427) (build-sequence1071 #f (map (lambda (x1461) (chi1128 (cdr x1461) (car x1461) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))) (begin (if (not (valid-bound-ids?1117 ids1427)) (syntax-error outer-form1418 "invalid or duplicate identifier in definition")) (let loop1462 ((bs1463 bindings1431) (er-cache1464 #f) (r-cache1465 #f)) (if (not (null? bs1463)) (let ((b1466 (car bs1463))) (if (eq? (car b1466) (quote macro)) (let ((er1467 (cadr b1466))) (let ((r-cache1468 (if (eq? er1467 er-cache1464) r-cache1465 (macros-only-env1088 er1467)))) (begin (set-cdr! b1466 (eval-local-transformer1135 (chi1128 (cddr b1466) r-cache1468 (quote (())) mod1440) mod1440)) (loop1462 (cdr bs1463) er1467 r-cache1468)))) (loop1462 (cdr bs1463) er-cache1464 r-cache1465))))) (set-cdr! r1422 (extend-env1086 labels1428 bindings1431 (cdr r1422))) (build-letrec1074 #f vars1429 (map (lambda (x1469) (chi1128 (cdr x1469) (car x1469) (quote (())) mod1440)) vals1430) (build-sequence1071 #f (map (lambda (x1470) (chi1128 (cdr x1470) (car x1470) (quote (())) mod1440)) (cons (cons er1434 (source-wrap1121 e1437 w1438 s1439 mod1440)) (cdr body1426)))))))))))))))))))))) (chi-macro1131 (lambda (p1471 e1472 r1473 w1474 rib1475 mod1476) (letrec ((rebuild-macro-output1477 (lambda (x1478 m1479) (cond ((pair? x1478) (cons (rebuild-macro-output1477 (car x1478) m1479) (rebuild-macro-output1477 (cdr x1478) m1479))) ((syntax-object?1076 x1478) (let ((w1480 (syntax-object-wrap1078 x1478))) (let ((ms1481 (wrap-marks1095 w1480)) (s1482 (wrap-subst1096 w1480))) (if (and (pair? ms1481) (eq? (car ms1481) #f)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cdr ms1481) (if rib1475 (cons rib1475 (cdr s1482)) (cdr s1482))) (syntax-object-module1079 x1478)) (make-syntax-object1075 (syntax-object-expression1077 x1478) (make-wrap1094 (cons m1479 ms1481) (if rib1475 (cons rib1475 (cons (quote shift) s1482)) (cons (quote shift) s1482))) (module-name (procedure-module p1471))))))) ((vector? x1478) (let ((n1483 (vector-length x1478))) (let ((v1484 (make-vector n1483))) (let doloop1485 ((i1486 0)) (if (fx=1061 i1486 n1483) v1484 (begin (vector-set! v1484 i1486 (rebuild-macro-output1477 (vector-ref x1478 i1486) m1479)) (doloop1485 (fx+1059 i1486 1)))))))) ((symbol? x1478) (syntax-error x1478 "encountered raw symbol in macro output")) (else x1478))))) (rebuild-macro-output1477 (p1471 (wrap1120 e1472 (anti-mark1107 w1474) mod1476)) (string #\m))))) (chi-application1130 (lambda (x1487 e1488 r1489 w1490 s1491 mod1492) ((lambda (tmp1493) ((lambda (tmp1494) (if tmp1494 (apply (lambda (e01495 e11496) (build-annotated1069 s1491 (cons x1487 (map (lambda (e1497) (chi1128 e1497 r1489 w1490 mod1492)) e11496)))) tmp1494) (syntax-error tmp1493))) (syntax-dispatch tmp1493 (quote (any . each-any))))) e1488))) (chi-expr1129 (lambda (type1499 value1500 e1501 r1502 w1503 s1504 mod1505) (let ((t1506 type1499)) (if (memv t1506 (quote (lexical))) (build-annotated1069 s1504 value1500) (if (memv t1506 (quote (core external-macro))) (value1500 e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (module-ref))) (call-with-values (lambda () (value1500 e1501)) (lambda (id1507 mod1508) (build-annotated1069 s1504 (make-module-ref mod1508 id1507 #f)))) (if (memv t1506 (quote (lexical-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) value1500) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (global-call))) (chi-application1130 (build-annotated1069 (source-annotation1083 (car e1501)) (make-module-ref (if (syntax-object?1076 (car e1501)) (syntax-object-module1079 (car e1501)) mod1505) value1500 #f)) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (constant))) (build-data1070 s1504 (strip1139 (source-wrap1121 e1501 w1503 s1504 mod1505) (quote (())))) (if (memv t1506 (quote (global))) (build-annotated1069 s1504 (make-module-ref mod1505 value1500 #f)) (if (memv t1506 (quote (call))) (chi-application1130 (chi1128 (car e1501) r1502 w1503 mod1505) e1501 r1502 w1503 s1504 mod1505) (if (memv t1506 (quote (begin-form))) ((lambda (tmp1509) ((lambda (tmp1510) (if tmp1510 (apply (lambda (_1511 e11512 e21513) (chi-sequence1122 (cons e11512 e21513) r1502 w1503 s1504 mod1505)) tmp1510) (syntax-error tmp1509))) (syntax-dispatch tmp1509 (quote (any any . each-any))))) e1501) (if (memv t1506 (quote (local-syntax-form))) (chi-local-syntax1134 value1500 e1501 r1502 w1503 s1504 mod1505 chi-sequence1122) (if (memv t1506 (quote (eval-when-form))) ((lambda (tmp1515) ((lambda (tmp1516) (if tmp1516 (apply (lambda (_1517 x1518 e11519 e21520) (let ((when-list1521 (chi-when-list1125 e1501 x1518 w1503))) (if (memq (quote eval) when-list1521) (chi-sequence1122 (cons e11519 e21520) r1502 w1503 s1504 mod1505) (chi-void1136)))) tmp1516) (syntax-error tmp1515))) (syntax-dispatch tmp1515 (quote (any each-any any . each-any))))) e1501) (if (memv t1506 (quote (define-form define-syntax-form))) (syntax-error (wrap1120 value1500 w1503 mod1505) "invalid context for definition of") (if (memv t1506 (quote (syntax))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to pattern variable outside syntax form") (if (memv t1506 (quote (displaced-lexical))) (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505) "reference to identifier outside its scope") (syntax-error (source-wrap1121 e1501 w1503 s1504 mod1505))))))))))))))))))) (chi1128 (lambda (e1524 r1525 w1526 mod1527) (call-with-values (lambda () (syntax-type1126 e1524 r1525 w1526 #f #f mod1527)) (lambda (type1528 value1529 e1530 w1531 s1532 mod1533) (chi-expr1129 type1528 value1529 e1530 r1525 w1531 s1532 mod1533))))) (chi-top1127 (lambda (e1534 r1535 w1536 m1537 esew1538 mod1539) (call-with-values (lambda () (syntax-type1126 e1534 r1535 w1536 #f #f mod1539)) (lambda (type1547 value1548 e1549 w1550 s1551 mod1552) (let ((t1553 type1547)) (if (memv t1553 (quote (begin-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556) (chi-void1136)) tmp1555) ((lambda (tmp1557) (if tmp1557 (apply (lambda (_1558 e11559 e21560) (chi-top-sequence1123 (cons e11559 e21560) r1535 w1550 s1551 m1537 esew1538 mod1552)) tmp1557) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any any . each-any)))))) (syntax-dispatch tmp1554 (quote (any))))) e1549) (if (memv t1553 (quote (local-syntax-form))) (chi-local-syntax1134 value1548 e1549 r1535 w1550 s1551 mod1552 (lambda (body1562 r1563 w1564 s1565 mod1566) (chi-top-sequence1123 body1562 r1563 w1564 s1565 m1537 esew1538 mod1566))) (if (memv t1553 (quote (eval-when-form))) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569 x1570 e11571 e21572) (let ((when-list1573 (chi-when-list1125 e1549 x1570 w1550)) (body1574 (cons e11571 e21572))) (cond ((eq? m1537 (quote e)) (if (memq (quote eval) when-list1573) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) (chi-void1136))) ((memq (quote load) when-list1573) (if (or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c&e) (quote (compile load)) mod1552) (if (memq m1537 (quote (c c&e))) (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote c) (quote (load)) mod1552) (chi-void1136)))) ((or (memq (quote compile) when-list1573) (and (eq? m1537 (quote c&e)) (memq (quote eval) when-list1573))) (top-level-eval-hook1063 (chi-top-sequence1123 body1574 r1535 w1550 s1551 (quote e) (quote (eval)) mod1552) mod1552) (chi-void1136)) (else (chi-void1136))))) tmp1568) (syntax-error tmp1567))) (syntax-dispatch tmp1567 (quote (any each-any any . each-any))))) e1549) (if (memv t1553 (quote (define-syntax-form))) (let ((n1577 (id-var-name1114 value1548 w1550)) (r1578 (macros-only-env1088 r1535))) (let ((t1579 m1537)) (if (memv t1579 (quote (c))) (if (memq (quote compile) esew1538) (let ((e1580 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1580 mod1552) (if (memq (quote load) esew1538) e1580 (chi-void1136)))) (if (memq (quote load) esew1538) (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) (chi-void1136))) (if (memv t1579 (quote (c&e))) (let ((e1581 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)))) (begin (top-level-eval-hook1063 e1581 mod1552) e1581)) (begin (if (memq (quote eval) esew1538) (top-level-eval-hook1063 (chi-install-global1124 n1577 (chi1128 e1549 r1578 w1550 mod1552)) mod1552)) (chi-void1136)))))) (if (memv t1553 (quote (define-form))) (let ((n1582 (id-var-name1114 value1548 w1550))) (let ((type1583 (binding-type1084 (lookup1089 n1582 r1535 mod1552)))) (let ((t1584 type1583)) (if (memv t1584 (quote (global))) (let ((x1585 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1585 mod1552)) x1585)) (if (memv t1584 (quote (displaced-lexical))) (syntax-error (wrap1120 value1548 w1550 mod1552) "identifier out of context") (if (memv t1584 (quote (core macro module-ref))) (begin (remove-global-definition-hook1067 n1582 mod1552) (let ((x1586 (build-annotated1069 s1551 (list (quote define) n1582 (chi1128 e1549 r1535 w1550 mod1552))))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1586 mod1552)) x1586))) (syntax-error (wrap1120 value1548 w1550 mod1552) "cannot define keyword at top level"))))))) (let ((x1587 (chi-expr1129 type1547 value1548 e1549 r1535 w1550 s1551 mod1552))) (begin (if (eq? m1537 (quote c&e)) (top-level-eval-hook1063 x1587 mod1552)) x1587)))))))))))) (syntax-type1126 (lambda (e1588 r1589 w1590 s1591 rib1592 mod1593) (cond ((symbol? e1588) (let ((n1594 (id-var-name1114 e1588 w1590))) (let ((b1595 (lookup1089 n1594 r1589 mod1593))) (let ((type1596 (binding-type1084 b1595))) (let ((t1597 type1596)) (if (memv t1597 (quote (lexical))) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (global))) (values type1596 n1594 e1588 w1590 s1591 mod1593) (if (memv t1597 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1595) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (values type1596 (binding-value1085 b1595) e1588 w1590 s1591 mod1593))))))))) ((pair? e1588) (let ((first1598 (car e1588))) (if (id?1092 first1598) (let ((n1599 (id-var-name1114 first1598 w1590))) (let ((b1600 (lookup1089 n1599 r1589 (or (and (syntax-object?1076 first1598) (syntax-object-module1079 first1598)) mod1593)))) (let ((type1601 (binding-type1084 b1600))) (let ((t1602 type1601)) (if (memv t1602 (quote (lexical))) (values (quote lexical-call) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (global))) (values (quote global-call) n1599 e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (macro))) (syntax-type1126 (chi-macro1131 (binding-value1085 b1600) e1588 r1589 w1590 rib1592 mod1593) r1589 (quote (())) s1591 rib1592 mod1593) (if (memv t1602 (quote (core external-macro module-ref))) (values type1601 (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1085 b1600) e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (begin))) (values (quote begin-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (eval-when))) (values (quote eval-when-form) #f e1588 w1590 s1591 mod1593) (if (memv t1602 (quote (define))) ((lambda (tmp1603) ((lambda (tmp1604) (if (if tmp1604 (apply (lambda (_1605 name1606 val1607) (id?1092 name1606)) tmp1604) #f) (apply (lambda (_1608 name1609 val1610) (values (quote define-form) name1609 val1610 w1590 s1591 mod1593)) tmp1604) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 name1613 args1614 e11615 e21616) (and (id?1092 name1613) (valid-bound-ids?1117 (lambda-var-list1141 args1614)))) tmp1611) #f) (apply (lambda (_1617 name1618 args1619 e11620 e21621) (values (quote define-form) (wrap1120 name1618 w1590 mod1593) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1120 (cons args1619 (cons e11620 e21621)) w1590 mod1593)) (quote (())) s1591 mod1593)) tmp1611) ((lambda (tmp1623) (if (if tmp1623 (apply (lambda (_1624 name1625) (id?1092 name1625)) tmp1623) #f) (apply (lambda (_1626 name1627) (values (quote define-form) (wrap1120 name1627 w1590 mod1593) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1591 mod1593)) tmp1623) (syntax-error tmp1603))) (syntax-dispatch tmp1603 (quote (any any)))))) (syntax-dispatch tmp1603 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1603 (quote (any any any))))) e1588) (if (memv t1602 (quote (define-syntax))) ((lambda (tmp1628) ((lambda (tmp1629) (if (if tmp1629 (apply (lambda (_1630 name1631 val1632) (id?1092 name1631)) tmp1629) #f) (apply (lambda (_1633 name1634 val1635) (values (quote define-syntax-form) name1634 val1635 w1590 s1591 mod1593)) tmp1629) (syntax-error tmp1628))) (syntax-dispatch tmp1628 (quote (any any any))))) e1588) (values (quote call) #f e1588 w1590 s1591 mod1593)))))))))))))) (values (quote call) #f e1588 w1590 s1591 mod1593)))) ((syntax-object?1076 e1588) (syntax-type1126 (syntax-object-expression1077 e1588) r1589 (join-wraps1111 w1590 (syntax-object-wrap1078 e1588)) #f rib1592 (or (syntax-object-module1079 e1588) mod1593))) ((annotation? e1588) (syntax-type1126 (annotation-expression e1588) r1589 w1590 (annotation-source e1588) rib1592 mod1593)) ((self-evaluating? e1588) (values (quote constant) #f e1588 w1590 s1591 mod1593)) (else (values (quote other) #f e1588 w1590 s1591 mod1593))))) (chi-when-list1125 (lambda (e1636 when-list1637 w1638) (let f1639 ((when-list1640 when-list1637) (situations1641 (quote ()))) (if (null? when-list1640) situations1641 (f1639 (cdr when-list1640) (cons (let ((x1642 (car when-list1640))) (cond ((free-id=?1115 x1642 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1115 x1642 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1115 x1642 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1120 x1642 w1638 #f) "invalid eval-when situation")))) situations1641)))))) (chi-install-global1124 (lambda (name1643 e1644) (build-annotated1069 #f (list (build-annotated1069 #f (quote install-global-transformer)) (build-data1070 #f name1643) e1644)))) (chi-top-sequence1123 (lambda (body1645 r1646 w1647 s1648 m1649 esew1650 mod1651) (build-sequence1071 s1648 (let dobody1652 ((body1653 body1645) (r1654 r1646) (w1655 w1647) (m1656 m1649) (esew1657 esew1650) (mod1658 mod1651)) (if (null? body1653) (quote ()) (let ((first1659 (chi-top1127 (car body1653) r1654 w1655 m1656 esew1657 mod1658))) (cons first1659 (dobody1652 (cdr body1653) r1654 w1655 m1656 esew1657 mod1658)))))))) (chi-sequence1122 (lambda (body1660 r1661 w1662 s1663 mod1664) (build-sequence1071 s1663 (let dobody1665 ((body1666 body1660) (r1667 r1661) (w1668 w1662) (mod1669 mod1664)) (if (null? body1666) (quote ()) (let ((first1670 (chi1128 (car body1666) r1667 w1668 mod1669))) (cons first1670 (dobody1665 (cdr body1666) r1667 w1668 mod1669)))))))) (source-wrap1121 (lambda (x1671 w1672 s1673 defmod1674) (wrap1120 (if s1673 (make-annotation x1671 s1673 #f) x1671) w1672 defmod1674))) (wrap1120 (lambda (x1675 w1676 defmod1677) (cond ((and (null? (wrap-marks1095 w1676)) (null? (wrap-subst1096 w1676))) x1675) ((syntax-object?1076 x1675) (make-syntax-object1075 (syntax-object-expression1077 x1675) (join-wraps1111 w1676 (syntax-object-wrap1078 x1675)) (syntax-object-module1079 x1675))) ((null? x1675) x1675) (else (make-syntax-object1075 x1675 w1676 defmod1677))))) (bound-id-member?1119 (lambda (x1678 list1679) (and (not (null? list1679)) (or (bound-id=?1116 x1678 (car list1679)) (bound-id-member?1119 x1678 (cdr list1679)))))) (distinct-bound-ids?1118 (lambda (ids1680) (let distinct?1681 ((ids1682 ids1680)) (or (null? ids1682) (and (not (bound-id-member?1119 (car ids1682) (cdr ids1682))) (distinct?1681 (cdr ids1682))))))) (valid-bound-ids?1117 (lambda (ids1683) (and (let all-ids?1684 ((ids1685 ids1683)) (or (null? ids1685) (and (id?1092 (car ids1685)) (all-ids?1684 (cdr ids1685))))) (distinct-bound-ids?1118 ids1683)))) (bound-id=?1116 (lambda (i1686 j1687) (if (and (syntax-object?1076 i1686) (syntax-object?1076 j1687)) (and (eq? (let ((e1688 (syntax-object-expression1077 i1686))) (if (annotation? e1688) (annotation-expression e1688) e1688)) (let ((e1689 (syntax-object-expression1077 j1687))) (if (annotation? e1689) (annotation-expression e1689) e1689))) (same-marks?1113 (wrap-marks1095 (syntax-object-wrap1078 i1686)) (wrap-marks1095 (syntax-object-wrap1078 j1687)))) (eq? (let ((e1690 i1686)) (if (annotation? e1690) (annotation-expression e1690) e1690)) (let ((e1691 j1687)) (if (annotation? e1691) (annotation-expression e1691) e1691)))))) (free-id=?1115 (lambda (i1692 j1693) (and (eq? (let ((x1694 i1692)) (let ((e1695 (if (syntax-object?1076 x1694) (syntax-object-expression1077 x1694) x1694))) (if (annotation? e1695) (annotation-expression e1695) e1695))) (let ((x1696 j1693)) (let ((e1697 (if (syntax-object?1076 x1696) (syntax-object-expression1077 x1696) x1696))) (if (annotation? e1697) (annotation-expression e1697) e1697)))) (eq? (id-var-name1114 i1692 (quote (()))) (id-var-name1114 j1693 (quote (()))))))) (id-var-name1114 (lambda (id1698 w1699) (letrec ((search-vector-rib1702 (lambda (sym1708 subst1709 marks1710 symnames1711 ribcage1712) (let ((n1713 (vector-length symnames1711))) (let f1714 ((i1715 0)) (cond ((fx=1061 i1715 n1713) (search1700 sym1708 (cdr subst1709) marks1710)) ((and (eq? (vector-ref symnames1711 i1715) sym1708) (same-marks?1113 marks1710 (vector-ref (ribcage-marks1102 ribcage1712) i1715))) (values (vector-ref (ribcage-labels1103 ribcage1712) i1715) marks1710)) (else (f1714 (fx+1059 i1715 1)))))))) (search-list-rib1701 (lambda (sym1716 subst1717 marks1718 symnames1719 ribcage1720) (let f1721 ((symnames1722 symnames1719) (i1723 0)) (cond ((null? symnames1722) (search1700 sym1716 (cdr subst1717) marks1718)) ((and (eq? (car symnames1722) sym1716) (same-marks?1113 marks1718 (list-ref (ribcage-marks1102 ribcage1720) i1723))) (values (list-ref (ribcage-labels1103 ribcage1720) i1723) marks1718)) (else (f1721 (cdr symnames1722) (fx+1059 i1723 1))))))) (search1700 (lambda (sym1724 subst1725 marks1726) (if (null? subst1725) (values #f marks1726) (let ((fst1727 (car subst1725))) (if (eq? fst1727 (quote shift)) (search1700 sym1724 (cdr subst1725) (cdr marks1726)) (let ((symnames1728 (ribcage-symnames1101 fst1727))) (if (vector? symnames1728) (search-vector-rib1702 sym1724 subst1725 marks1726 symnames1728 fst1727) (search-list-rib1701 sym1724 subst1725 marks1726 symnames1728 fst1727))))))))) (cond ((symbol? id1698) (or (call-with-values (lambda () (search1700 id1698 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1730 . ignore1729) x1730)) id1698)) ((syntax-object?1076 id1698) (let ((id1731 (let ((e1733 (syntax-object-expression1077 id1698))) (if (annotation? e1733) (annotation-expression e1733) e1733))) (w11732 (syntax-object-wrap1078 id1698))) (let ((marks1734 (join-marks1112 (wrap-marks1095 w1699) (wrap-marks1095 w11732)))) (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w1699) marks1734)) (lambda (new-id1735 marks1736) (or new-id1735 (call-with-values (lambda () (search1700 id1731 (wrap-subst1096 w11732) marks1736)) (lambda (x1738 . ignore1737) x1738)) id1731)))))) ((annotation? id1698) (let ((id1739 (let ((e1740 id1698)) (if (annotation? e1740) (annotation-expression e1740) e1740)))) (or (call-with-values (lambda () (search1700 id1739 (wrap-subst1096 w1699) (wrap-marks1095 w1699))) (lambda (x1742 . ignore1741) x1742)) id1739))) (else (error-hook1065 (quote id-var-name) "invalid id" id1698)))))) (same-marks?1113 (lambda (x1743 y1744) (or (eq? x1743 y1744) (and (not (null? x1743)) (not (null? y1744)) (eq? (car x1743) (car y1744)) (same-marks?1113 (cdr x1743) (cdr y1744)))))) (join-marks1112 (lambda (m11745 m21746) (smart-append1110 m11745 m21746))) (join-wraps1111 (lambda (w11747 w21748) (let ((m11749 (wrap-marks1095 w11747)) (s11750 (wrap-subst1096 w11747))) (if (null? m11749) (if (null? s11750) w21748 (make-wrap1094 (wrap-marks1095 w21748) (smart-append1110 s11750 (wrap-subst1096 w21748)))) (make-wrap1094 (smart-append1110 m11749 (wrap-marks1095 w21748)) (smart-append1110 s11750 (wrap-subst1096 w21748))))))) (smart-append1110 (lambda (m11751 m21752) (if (null? m21752) m11751 (append m11751 m21752)))) (make-binding-wrap1109 (lambda (ids1753 labels1754 w1755) (if (null? ids1753) w1755 (make-wrap1094 (wrap-marks1095 w1755) (cons (let ((labelvec1756 (list->vector labels1754))) (let ((n1757 (vector-length labelvec1756))) (let ((symnamevec1758 (make-vector n1757)) (marksvec1759 (make-vector n1757))) (begin (let f1760 ((ids1761 ids1753) (i1762 0)) (if (not (null? ids1761)) (call-with-values (lambda () (id-sym-name&marks1093 (car ids1761) w1755)) (lambda (symname1763 marks1764) (begin (vector-set! symnamevec1758 i1762 symname1763) (vector-set! marksvec1759 i1762 marks1764) (f1760 (cdr ids1761) (fx+1059 i1762 1))))))) (make-ribcage1099 symnamevec1758 marksvec1759 labelvec1756))))) (wrap-subst1096 w1755)))))) (extend-ribcage!1108 (lambda (ribcage1765 id1766 label1767) (begin (set-ribcage-symnames!1104 ribcage1765 (cons (let ((e1768 (syntax-object-expression1077 id1766))) (if (annotation? e1768) (annotation-expression e1768) e1768)) (ribcage-symnames1101 ribcage1765))) (set-ribcage-marks!1105 ribcage1765 (cons (wrap-marks1095 (syntax-object-wrap1078 id1766)) (ribcage-marks1102 ribcage1765))) (set-ribcage-labels!1106 ribcage1765 (cons label1767 (ribcage-labels1103 ribcage1765)))))) (anti-mark1107 (lambda (w1769) (make-wrap1094 (cons #f (wrap-marks1095 w1769)) (cons (quote shift) (wrap-subst1096 w1769))))) (set-ribcage-labels!1106 (lambda (x1770 update1771) (vector-set! x1770 3 update1771))) (set-ribcage-marks!1105 (lambda (x1772 update1773) (vector-set! x1772 2 update1773))) (set-ribcage-symnames!1104 (lambda (x1774 update1775) (vector-set! x1774 1 update1775))) (ribcage-labels1103 (lambda (x1776) (vector-ref x1776 3))) (ribcage-marks1102 (lambda (x1777) (vector-ref x1777 2))) (ribcage-symnames1101 (lambda (x1778) (vector-ref x1778 1))) (ribcage?1100 (lambda (x1779) (and (vector? x1779) (= (vector-length x1779) 4) (eq? (vector-ref x1779 0) (quote ribcage))))) (make-ribcage1099 (lambda (symnames1780 marks1781 labels1782) (vector (quote ribcage) symnames1780 marks1781 labels1782))) (gen-labels1098 (lambda (ls1783) (if (null? ls1783) (quote ()) (cons (gen-label1097) (gen-labels1098 (cdr ls1783)))))) (gen-label1097 (lambda () (string #\i))) (wrap-subst1096 cdr) (wrap-marks1095 car) (make-wrap1094 cons) (id-sym-name&marks1093 (lambda (x1784 w1785) (if (syntax-object?1076 x1784) (values (let ((e1786 (syntax-object-expression1077 x1784))) (if (annotation? e1786) (annotation-expression e1786) e1786)) (join-marks1112 (wrap-marks1095 w1785) (wrap-marks1095 (syntax-object-wrap1078 x1784)))) (values (let ((e1787 x1784)) (if (annotation? e1787) (annotation-expression e1787) e1787)) (wrap-marks1095 w1785))))) (id?1092 (lambda (x1788) (cond ((symbol? x1788) #t) ((syntax-object?1076 x1788) (symbol? (let ((e1789 (syntax-object-expression1077 x1788))) (if (annotation? e1789) (annotation-expression e1789) e1789)))) ((annotation? x1788) (symbol? (annotation-expression x1788))) (else #f)))) (nonsymbol-id?1091 (lambda (x1790) (and (syntax-object?1076 x1790) (symbol? (let ((e1791 (syntax-object-expression1077 x1790))) (if (annotation? e1791) (annotation-expression e1791) e1791)))))) (global-extend1090 (lambda (type1792 sym1793 val1794) (put-global-definition-hook1066 sym1793 (cons type1792 val1794) (module-name (current-module))))) (lookup1089 (lambda (x1795 r1796 mod1797) (cond ((assq x1795 r1796) => cdr) ((symbol? x1795) (or (get-global-definition-hook1068 x1795 mod1797) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1088 (lambda (r1798) (if (null? r1798) (quote ()) (let ((a1799 (car r1798))) (if (eq? (cadr a1799) (quote macro)) (cons a1799 (macros-only-env1088 (cdr r1798))) (macros-only-env1088 (cdr r1798))))))) (extend-var-env1087 (lambda (labels1800 vars1801 r1802) (if (null? labels1800) r1802 (extend-var-env1087 (cdr labels1800) (cdr vars1801) (cons (cons (car labels1800) (cons (quote lexical) (car vars1801))) r1802))))) (extend-env1086 (lambda (labels1803 bindings1804 r1805) (if (null? labels1803) r1805 (extend-env1086 (cdr labels1803) (cdr bindings1804) (cons (cons (car labels1803) (car bindings1804)) r1805))))) (binding-value1085 cdr) (binding-type1084 car) (source-annotation1083 (lambda (x1806) (cond ((annotation? x1806) (annotation-source x1806)) ((syntax-object?1076 x1806) (source-annotation1083 (syntax-object-expression1077 x1806))) (else #f)))) (set-syntax-object-module!1082 (lambda (x1807 update1808) (vector-set! x1807 3 update1808))) (set-syntax-object-wrap!1081 (lambda (x1809 update1810) (vector-set! x1809 2 update1810))) (set-syntax-object-expression!1080 (lambda (x1811 update1812) (vector-set! x1811 1 update1812))) (syntax-object-module1079 (lambda (x1813) (vector-ref x1813 3))) (syntax-object-wrap1078 (lambda (x1814) (vector-ref x1814 2))) (syntax-object-expression1077 (lambda (x1815) (vector-ref x1815 1))) (syntax-object?1076 (lambda (x1816) (and (vector? x1816) (= (vector-length x1816) 4) (eq? (vector-ref x1816 0) (quote syntax-object))))) (make-syntax-object1075 (lambda (expression1817 wrap1818 module1819) (vector (quote syntax-object) expression1817 wrap1818 module1819))) (build-letrec1074 (lambda (src1820 vars1821 val-exps1822 body-exp1823) (if (null? vars1821) (build-annotated1069 src1820 body-exp1823) (build-annotated1069 src1820 (list (quote letrec) (map list vars1821 val-exps1822) body-exp1823))))) (build-named-let1073 (lambda (src1824 vars1825 val-exps1826 body-exp1827) (if (null? vars1825) (build-annotated1069 src1824 body-exp1827) (build-annotated1069 src1824 (list (quote let) (car vars1825) (map list (cdr vars1825) val-exps1826) body-exp1827))))) (build-let1072 (lambda (src1828 vars1829 val-exps1830 body-exp1831) (if (null? vars1829) (build-annotated1069 src1828 body-exp1831) (build-annotated1069 src1828 (list (quote let) (map list vars1829 val-exps1830) body-exp1831))))) (build-sequence1071 (lambda (src1832 exps1833) (if (null? (cdr exps1833)) (build-annotated1069 src1832 (car exps1833)) (build-annotated1069 src1832 (cons (quote begin) exps1833))))) (build-data1070 (lambda (src1834 exp1835) (if (and (self-evaluating? exp1835) (not (vector? exp1835))) (build-annotated1069 src1834 exp1835) (build-annotated1069 src1834 (list (quote quote) exp1835))))) (build-annotated1069 (lambda (src1836 exp1837) (if (and src1836 (not (annotation? exp1837))) (make-annotation exp1837 src1836 #t) exp1837))) (get-global-definition-hook1068 (lambda (symbol1838 module1839) (let ((module1840 (if module1839 (resolve-module module1839) (let ((mod1841 (current-module))) (begin (if mod1841 (warn "wha" symbol1838)) mod1841))))) (let ((v1842 (module-variable module1840 symbol1838))) (and v1842 (or (object-property v1842 (quote *sc-expander*)) (and (variable-bound? v1842) (macro? (variable-ref v1842)) (macro-transformer (variable-ref v1842)) guile-macro))))))) (remove-global-definition-hook1067 (lambda (symbol1843 modname1844) (let ((module1845 (if modname1844 (resolve-module modname1844) (current-module)))) (let ((v1846 (module-local-variable module1845 symbol1843))) (if v1846 (let ((p1847 (assq (quote *sc-expander*) (object-properties v1846)))) (set-object-properties! v1846 (delq p1847 (object-properties v1846))))))))) (put-global-definition-hook1066 (lambda (symbol1848 binding1849 modname1850) (let ((module1851 (if modname1850 (resolve-module modname1850) (current-module)))) (let ((v1852 (or (module-variable module1851 symbol1848) (let ((v1853 (make-variable (gensym)))) (begin (module-add! module1851 symbol1848 v1853) v1853))))) (begin (if (not (variable-bound? v1852)) (variable-set! v1852 (gensym))) (set-object-property! v1852 (quote *sc-expander*) binding1849)))))) (error-hook1065 (lambda (who1854 why1855 what1856) (error who1854 "~a ~s" why1855 what1856))) (local-eval-hook1064 (lambda (x1857 mod1858) (eval (list noexpand1058 x1857) (if mod1858 (resolve-module mod1858) (interaction-environment))))) (top-level-eval-hook1063 (lambda (x1859 mod1860) (eval (list noexpand1058 x1859) (if mod1860 (resolve-module mod1860) (interaction-environment))))) (fx<1062 <) (fx=1061 =) (fx-1060 -) (fx+1059 +) (noexpand1058 "noexpand")) (begin (global-extend1090 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1090 (quote local-syntax) (quote let-syntax) #f) (global-extend1090 (quote core) (quote fluid-let-syntax) (lambda (e1861 r1862 w1863 s1864 mod1865) ((lambda (tmp1866) ((lambda (tmp1867) (if (if tmp1867 (apply (lambda (_1868 var1869 val1870 e11871 e21872) (valid-bound-ids?1117 var1869)) tmp1867) #f) (apply (lambda (_1874 var1875 val1876 e11877 e21878) (let ((names1879 (map (lambda (x1880) (id-var-name1114 x1880 w1863)) var1875))) (begin (for-each (lambda (id1882 n1883) (let ((t1884 (binding-type1084 (lookup1089 n1883 r1862 mod1865)))) (if (memv t1884 (quote (displaced-lexical))) (syntax-error (source-wrap1121 id1882 w1863 s1864 mod1865) "identifier out of context")))) var1875 names1879) (chi-body1132 (cons e11877 e21878) (source-wrap1121 e1861 w1863 s1864 mod1865) (extend-env1086 names1879 (let ((trans-r1887 (macros-only-env1088 r1862))) (map (lambda (x1888) (cons (quote macro) (eval-local-transformer1135 (chi1128 x1888 trans-r1887 w1863 mod1865) mod1865))) val1876)) r1862) w1863 mod1865)))) tmp1867) ((lambda (_1890) (syntax-error (source-wrap1121 e1861 w1863 s1864 mod1865))) tmp1866))) (syntax-dispatch tmp1866 (quote (any #(each (any any)) any . each-any))))) e1861))) (global-extend1090 (quote core) (quote quote) (lambda (e1891 r1892 w1893 s1894 mod1895) ((lambda (tmp1896) ((lambda (tmp1897) (if tmp1897 (apply (lambda (_1898 e1899) (build-data1070 s1894 (strip1139 e1899 w1893))) tmp1897) ((lambda (_1900) (syntax-error (source-wrap1121 e1891 w1893 s1894 mod1895))) tmp1896))) (syntax-dispatch tmp1896 (quote (any any))))) e1891))) (global-extend1090 (quote core) (quote syntax) (letrec ((regen1908 (lambda (x1909) (let ((t1910 (car x1909))) (if (memv t1910 (quote (ref))) (build-annotated1069 #f (cadr x1909)) (if (memv t1910 (quote (primitive))) (build-annotated1069 #f (cadr x1909)) (if (memv t1910 (quote (quote))) (build-data1070 #f (cadr x1909)) (if (memv t1910 (quote (lambda))) (build-annotated1069 #f (list (quote lambda) (cadr x1909) (regen1908 (caddr x1909)))) (if (memv t1910 (quote (map))) (let ((ls1911 (map regen1908 (cdr x1909)))) (build-annotated1069 #f (cons (if (fx=1061 (length ls1911) 2) (build-annotated1069 #f (quote map)) (build-annotated1069 #f (quote map))) ls1911))) (build-annotated1069 #f (cons (build-annotated1069 #f (car x1909)) (map regen1908 (cdr x1909)))))))))))) (gen-vector1907 (lambda (x1912) (cond ((eq? (car x1912) (quote list)) (cons (quote vector) (cdr x1912))) ((eq? (car x1912) (quote quote)) (list (quote quote) (list->vector (cadr x1912)))) (else (list (quote list->vector) x1912))))) (gen-append1906 (lambda (x1913 y1914) (if (equal? y1914 (quote (quote ()))) x1913 (list (quote append) x1913 y1914)))) (gen-cons1905 (lambda (x1915 y1916) (let ((t1917 (car y1916))) (if (memv t1917 (quote (quote))) (if (eq? (car x1915) (quote quote)) (list (quote quote) (cons (cadr x1915) (cadr y1916))) (if (eq? (cadr y1916) (quote ())) (list (quote list) x1915) (list (quote cons) x1915 y1916))) (if (memv t1917 (quote (list))) (cons (quote list) (cons x1915 (cdr y1916))) (list (quote cons) x1915 y1916)))))) (gen-map1904 (lambda (e1918 map-env1919) (let ((formals1920 (map cdr map-env1919)) (actuals1921 (map (lambda (x1922) (list (quote ref) (car x1922))) map-env1919))) (cond ((eq? (car e1918) (quote ref)) (car actuals1921)) ((andmap (lambda (x1923) (and (eq? (car x1923) (quote ref)) (memq (cadr x1923) formals1920))) (cdr e1918)) (cons (quote map) (cons (list (quote primitive) (car e1918)) (map (let ((r1924 (map cons formals1920 actuals1921))) (lambda (x1925) (cdr (assq (cadr x1925) r1924)))) (cdr e1918))))) (else (cons (quote map) (cons (list (quote lambda) formals1920 e1918) actuals1921))))))) (gen-mappend1903 (lambda (e1926 map-env1927) (list (quote apply) (quote (primitive append)) (gen-map1904 e1926 map-env1927)))) (gen-ref1902 (lambda (src1928 var1929 level1930 maps1931) (if (fx=1061 level1930 0) (values var1929 maps1931) (if (null? maps1931) (syntax-error src1928 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1902 src1928 var1929 (fx-1060 level1930 1) (cdr maps1931))) (lambda (outer-var1932 outer-maps1933) (let ((b1934 (assq outer-var1932 (car maps1931)))) (if b1934 (values (cdr b1934) maps1931) (let ((inner-var1935 (gen-var1140 (quote tmp)))) (values inner-var1935 (cons (cons (cons outer-var1932 inner-var1935) (car maps1931)) outer-maps1933))))))))))) (gen-syntax1901 (lambda (src1936 e1937 r1938 maps1939 ellipsis?1940 mod1941) (if (id?1092 e1937) (let ((label1942 (id-var-name1114 e1937 (quote (()))))) (let ((b1943 (lookup1089 label1942 r1938 mod1941))) (if (eq? (binding-type1084 b1943) (quote syntax)) (call-with-values (lambda () (let ((var.lev1944 (binding-value1085 b1943))) (gen-ref1902 src1936 (car var.lev1944) (cdr var.lev1944) maps1939))) (lambda (var1945 maps1946) (values (list (quote ref) var1945) maps1946))) (if (ellipsis?1940 e1937) (syntax-error src1936 "misplaced ellipsis in syntax form") (values (list (quote quote) e1937) maps1939))))) ((lambda (tmp1947) ((lambda (tmp1948) (if (if tmp1948 (apply (lambda (dots1949 e1950) (ellipsis?1940 dots1949)) tmp1948) #f) (apply (lambda (dots1951 e1952) (gen-syntax1901 src1936 e1952 r1938 maps1939 (lambda (x1953) #f) mod1941)) tmp1948) ((lambda (tmp1954) (if (if tmp1954 (apply (lambda (x1955 dots1956 y1957) (ellipsis?1940 dots1956)) tmp1954) #f) (apply (lambda (x1958 dots1959 y1960) (let f1961 ((y1962 y1960) (k1963 (lambda (maps1964) (call-with-values (lambda () (gen-syntax1901 src1936 x1958 r1938 (cons (quote ()) maps1964) ellipsis?1940 mod1941)) (lambda (x1965 maps1966) (if (null? (car maps1966)) (syntax-error src1936 "extra ellipsis in syntax form") (values (gen-map1904 x1965 (car maps1966)) (cdr maps1966)))))))) ((lambda (tmp1967) ((lambda (tmp1968) (if (if tmp1968 (apply (lambda (dots1969 y1970) (ellipsis?1940 dots1969)) tmp1968) #f) (apply (lambda (dots1971 y1972) (f1961 y1972 (lambda (maps1973) (call-with-values (lambda () (k1963 (cons (quote ()) maps1973))) (lambda (x1974 maps1975) (if (null? (car maps1975)) (syntax-error src1936 "extra ellipsis in syntax form") (values (gen-mappend1903 x1974 (car maps1975)) (cdr maps1975)))))))) tmp1968) ((lambda (_1976) (call-with-values (lambda () (gen-syntax1901 src1936 y1962 r1938 maps1939 ellipsis?1940 mod1941)) (lambda (y1977 maps1978) (call-with-values (lambda () (k1963 maps1978)) (lambda (x1979 maps1980) (values (gen-append1906 x1979 y1977) maps1980)))))) tmp1967))) (syntax-dispatch tmp1967 (quote (any . any))))) y1962))) tmp1954) ((lambda (tmp1981) (if tmp1981 (apply (lambda (x1982 y1983) (call-with-values (lambda () (gen-syntax1901 src1936 x1982 r1938 maps1939 ellipsis?1940 mod1941)) (lambda (x1984 maps1985) (call-with-values (lambda () (gen-syntax1901 src1936 y1983 r1938 maps1985 ellipsis?1940 mod1941)) (lambda (y1986 maps1987) (values (gen-cons1905 x1984 y1986) maps1987)))))) tmp1981) ((lambda (tmp1988) (if tmp1988 (apply (lambda (e11989 e21990) (call-with-values (lambda () (gen-syntax1901 src1936 (cons e11989 e21990) r1938 maps1939 ellipsis?1940 mod1941)) (lambda (e1992 maps1993) (values (gen-vector1907 e1992) maps1993)))) tmp1988) ((lambda (_1994) (values (list (quote quote) e1937) maps1939)) tmp1947))) (syntax-dispatch tmp1947 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1947 (quote (any . any)))))) (syntax-dispatch tmp1947 (quote (any any . any)))))) (syntax-dispatch tmp1947 (quote (any any))))) e1937))))) (lambda (e1995 r1996 w1997 s1998 mod1999) (let ((e2000 (source-wrap1121 e1995 w1997 s1998 mod1999))) ((lambda (tmp2001) ((lambda (tmp2002) (if tmp2002 (apply (lambda (_2003 x2004) (call-with-values (lambda () (gen-syntax1901 e2000 x2004 r1996 (quote ()) ellipsis?1137 mod1999)) (lambda (e2005 maps2006) (regen1908 e2005)))) tmp2002) ((lambda (_2007) (syntax-error e2000)) tmp2001))) (syntax-dispatch tmp2001 (quote (any any))))) e2000))))) (global-extend1090 (quote core) (quote lambda) (lambda (e2008 r2009 w2010 s2011 mod2012) ((lambda (tmp2013) ((lambda (tmp2014) (if tmp2014 (apply (lambda (_2015 c2016) (chi-lambda-clause1133 (source-wrap1121 e2008 w2010 s2011 mod2012) c2016 r2009 w2010 mod2012 (lambda (vars2017 body2018) (build-annotated1069 s2011 (list (quote lambda) vars2017 body2018))))) tmp2014) (syntax-error tmp2013))) (syntax-dispatch tmp2013 (quote (any . any))))) e2008))) (global-extend1090 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1117 ids2026)) (syntax-error e2020 "duplicate bound variable in") (let ((labels2029 (gen-labels1098 ids2026)) (new-vars2030 (map gen-var1140 ids2026))) (let ((nw2031 (make-binding-wrap1109 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1087 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1128 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1132 exps2028 (source-wrap1121 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1072 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1092 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1073 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-error (source-wrap1121 e2034 w2036 s2037 mod2038))) tmp2039))) (syntax-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1090 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1117 ids2078)) (syntax-error e2066 "duplicate bound variable in") (let ((labels2080 (gen-labels1098 ids2078)) (new-vars2081 (map gen-var1140 ids2078))) (let ((w2082 (make-binding-wrap1109 ids2078 labels2080 w2068)) (r2083 (extend-var-env1087 labels2080 new-vars2081 r2067))) (build-letrec1074 s2069 new-vars2081 (map (lambda (x2084) (chi1128 x2084 r2083 w2082 mod2070)) val2075) (chi-body1132 (cons e12076 e22077) (source-wrap1121 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-error (source-wrap1121 e2066 w2068 s2069 mod2070))) tmp2071))) (syntax-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1090 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1092 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1128 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1114 id2099 w2090))) (let ((b2103 (lookup1089 n2102 r2089 mod2092))) (let ((t2104 (binding-type1084 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1069 s2091 (list (quote set!) (binding-value1085 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1069 s2091 (list (quote set!) (make-module-ref mod2092 n2102 #f) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-error (wrap1120 id2099 w2090 mod2092) "identifier out of context") (syntax-error (source-wrap1121 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1126 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1128 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1069 s2091 (list (quote set!) (make-module-ref mod2120 id2119 #f) val2117))))) (build-annotated1069 s2091 (cons (chi1128 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1128 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-error (source-wrap1121 e2088 w2090 s2091 mod2092))) tmp2093))) (syntax-dispatch tmp2093 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1090 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1092 mod2128) (id?1092 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax-object->datum id2133) (syntax-object->datum (append mod2132 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))))))) tmp2126) (syntax-error tmp2125))) (syntax-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1090 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1092 mod2139) (id?1092 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax-object->datum id2144) (syntax-object->datum mod2143))) tmp2137) (syntax-error tmp2136))) (syntax-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1090 (quote begin) (quote begin) (quote ())) (global-extend1090 (quote define) (quote define) (quote ())) (global-extend1090 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1090 (quote eval-when) (quote eval-when) (quote ())) (global-extend1090 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-error)) x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1092 pat2157) (andmap (lambda (x2159) (not (free-id=?1115 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2151))) (let ((labels2160 (list (gen-label1097))) (var2161 (gen-var1140 pat2157))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list var2161) (chi1128 exp2158 (extend-env1086 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1109 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-error (car clauses2152) "invalid syntax-case clause")) tmp2155))) (syntax-dispatch tmp2155 (quote (any any any)))))) (syntax-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1118 (map car pvars2176))) (syntax-error pat2171 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2177) (not (ellipsis?1137 (car x2177)))) pvars2176)) (syntax-error pat2171 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2178 (gen-var1140 (quote tmp)))) (build-annotated1069 #f (list (build-annotated1069 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1069 #f y2178))) (build-annotated1069 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1069 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1070 #f #f)))) tmp2180))) (syntax-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1069 #f (list (build-annotated1069 #f (quote list)) x2167)) (build-annotated1069 #f (list (build-annotated1069 #f (quote syntax-dispatch)) x2167 (build-data1070 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1098 ids2188)) (new-vars2191 (map gen-var1140 ids2188))) (build-annotated1069 #f (list (build-annotated1069 #f (quote apply)) (build-annotated1069 #f (list (quote lambda) new-vars2191 (chi1128 exp2184 (extend-env1086 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1109 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1092 p2197) (if (bound-id-member?1119 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1137 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1059 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1139 p2197 (quote (())))) ids2199)) tmp2200))) (syntax-dispatch tmp2200 (quote #(vector each-any)))))) (syntax-dispatch tmp2200 (quote ()))))) (syntax-dispatch tmp2200 (quote (any . any)))))) (syntax-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1121 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1092 x2234) (not (ellipsis?1137 x2234)))) key2232) (let ((x2236 (gen-var1140 (quote tmp)))) (build-annotated1069 s2225 (list (build-annotated1069 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1069 #f x2236) key2232 m2233 r2223 mod2226))) (chi1128 val2231 r2223 (quote (())) mod2226)))) (syntax-error e2227 "invalid literals list in"))) tmp2229) (syntax-error tmp2228))) (syntax-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1058)) (cadr x2241) (chi-top1127 x2241 (quote ()) (quote ((top))) m2239 esew2240 (module-name (current-module))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1058)) (cadr x2245) (chi-top1127 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (module-name (current-module))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1091 x2246))) (set! datum->syntax-object (lambda (id2247 datum2248) (make-syntax-object1075 datum2248 (syntax-object-wrap1078 id2247) #f))) (set! syntax-object->datum (lambda (x2249) (strip1139 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1065 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1120 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1091 x2255)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1091 x2256)) (error-hook1065 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1115 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1091 x2259)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1091 x2260)) (error-hook1065 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1116 x2257 y2258)))) (set! syntax-error (lambda (object2262 . messages2261) (begin (for-each (lambda (x2263) (let ((x2264 x2263)) (if (not (string? x2264)) (error-hook1065 (quote syntax-error) "invalid argument" x2264)))) messages2261) (let ((message2265 (if (null? messages2261) "invalid syntax" (apply string-append messages2261)))) (error-hook1065 #f message2265 (strip1139 object2262 (quote (())))))))) (set! install-global-transformer (lambda (sym2266 v2267) (begin (let ((x2268 sym2266)) (if (not (symbol? x2268)) (error-hook1065 (quote define-syntax) "invalid argument" x2268))) (let ((x2269 v2267)) (if (not (procedure? x2269)) (error-hook1065 (quote define-syntax) "invalid argument" x2269))) (global-extend1090 (quote macro) sym2266 v2267)))) (letrec ((match2274 (lambda (e2275 p2276 w2277 r2278 mod2279) (cond ((not r2278) #f) ((eq? p2276 (quote any)) (cons (wrap1120 e2275 w2277 mod2279) r2278)) ((syntax-object?1076 e2275) (match*2273 (let ((e2280 (syntax-object-expression1077 e2275))) (if (annotation? e2280) (annotation-expression e2280) e2280)) p2276 (join-wraps1111 w2277 (syntax-object-wrap1078 e2275)) r2278 (syntax-object-module1079 e2275))) (else (match*2273 (let ((e2281 e2275)) (if (annotation? e2281) (annotation-expression e2281) e2281)) p2276 w2277 r2278 mod2279))))) (match*2273 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((null? p2283) (and (null? e2282) r2285)) ((pair? p2283) (and (pair? e2282) (match2274 (car e2282) (car p2283) w2284 (match2274 (cdr e2282) (cdr p2283) w2284 r2285 mod2286) mod2286))) ((eq? p2283 (quote each-any)) (let ((l2287 (match-each-any2271 e2282 w2284 mod2286))) (and l2287 (cons l2287 r2285)))) (else (let ((t2288 (vector-ref p2283 0))) (if (memv t2288 (quote (each))) (if (null? e2282) (match-empty2272 (vector-ref p2283 1) r2285) (let ((l2289 (match-each2270 e2282 (vector-ref p2283 1) w2284 mod2286))) (and l2289 (let collect2290 ((l2291 l2289)) (if (null? (car l2291)) r2285 (cons (map car l2291) (collect2290 (map cdr l2291)))))))) (if (memv t2288 (quote (free-id))) (and (id?1092 e2282) (free-id=?1115 (wrap1120 e2282 w2284 mod2286) (vector-ref p2283 1)) r2285) (if (memv t2288 (quote (atom))) (and (equal? (vector-ref p2283 1) (strip1139 e2282 w2284)) r2285) (if (memv t2288 (quote (vector))) (and (vector? e2282) (match2274 (vector->list e2282) (vector-ref p2283 1) w2284 r2285 mod2286))))))))))) (match-empty2272 (lambda (p2292 r2293) (cond ((null? p2292) r2293) ((eq? p2292 (quote any)) (cons (quote ()) r2293)) ((pair? p2292) (match-empty2272 (car p2292) (match-empty2272 (cdr p2292) r2293))) ((eq? p2292 (quote each-any)) (cons (quote ()) r2293)) (else (let ((t2294 (vector-ref p2292 0))) (if (memv t2294 (quote (each))) (match-empty2272 (vector-ref p2292 1) r2293) (if (memv t2294 (quote (free-id atom))) r2293 (if (memv t2294 (quote (vector))) (match-empty2272 (vector-ref p2292 1) r2293))))))))) (match-each-any2271 (lambda (e2295 w2296 mod2297) (cond ((annotation? e2295) (match-each-any2271 (annotation-expression e2295) w2296 mod2297)) ((pair? e2295) (let ((l2298 (match-each-any2271 (cdr e2295) w2296 mod2297))) (and l2298 (cons (wrap1120 (car e2295) w2296 mod2297) l2298)))) ((null? e2295) (quote ())) ((syntax-object?1076 e2295) (match-each-any2271 (syntax-object-expression1077 e2295) (join-wraps1111 w2296 (syntax-object-wrap1078 e2295)) mod2297)) (else #f)))) (match-each2270 (lambda (e2299 p2300 w2301 mod2302) (cond ((annotation? e2299) (match-each2270 (annotation-expression e2299) p2300 w2301 mod2302)) ((pair? e2299) (let ((first2303 (match2274 (car e2299) p2300 w2301 (quote ()) mod2302))) (and first2303 (let ((rest2304 (match-each2270 (cdr e2299) p2300 w2301 mod2302))) (and rest2304 (cons first2303 rest2304)))))) ((null? e2299) (quote ())) ((syntax-object?1076 e2299) (match-each2270 (syntax-object-expression1077 e2299) p2300 (join-wraps1111 w2301 (syntax-object-wrap1078 e2299)) (syntax-object-module1079 e2299))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2305 p2306) (cond ((eq? p2306 (quote any)) (list e2305)) ((syntax-object?1076 e2305) (match*2273 (let ((e2307 (syntax-object-expression1077 e2305))) (if (annotation? e2307) (annotation-expression e2307) e2307)) p2306 (syntax-object-wrap1078 e2305) (quote ()) (syntax-object-module1079 e2305))) (else (match*2273 (let ((e2308 e2305)) (if (annotation? e2308) (annotation-expression e2308) e2308)) p2306 (quote (())) (quote ()) #f))))) (set! sc-chi chi1128))))) -(install-global-transformer (quote with-syntax) (lambda (x2309) ((lambda (tmp2310) ((lambda (tmp2311) (if tmp2311 (apply (lambda (_2312 e12313 e22314) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12313 e22314))) tmp2311) ((lambda (tmp2316) (if tmp2316 (apply (lambda (_2317 out2318 in2319 e12320 e22321) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2319 (quote ()) (list out2318 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12320 e22321))))) tmp2316) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2326) (quote ()) (list out2325 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12327 e22328))))) tmp2323) (syntax-error tmp2310))) (syntax-dispatch tmp2310 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any () any . each-any))))) x2309))) -(install-global-transformer (quote syntax-rules) (lambda (x2332) ((lambda (tmp2333) ((lambda (tmp2334) (if tmp2334 (apply (lambda (_2335 k2336 keyword2337 pattern2338 template2339) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2336 (map (lambda (tmp2342 tmp2341) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2341) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2342))) template2339 pattern2338)))))) tmp2334) (syntax-error tmp2333))) (syntax-dispatch tmp2333 (quote (any each-any . #(each ((any . any) any))))))) x2332))) -(install-global-transformer (quote let*) (lambda (x2343) ((lambda (tmp2344) ((lambda (tmp2345) (if (if tmp2345 (apply (lambda (let*2346 x2347 v2348 e12349 e22350) (andmap identifier? x2347)) tmp2345) #f) (apply (lambda (let*2352 x2353 v2354 e12355 e22356) (let f2357 ((bindings2358 (map list x2353 v2354))) (if (null? bindings2358) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12355 e22356))) ((lambda (tmp2362) ((lambda (tmp2363) (if tmp2363 (apply (lambda (body2364 binding2365) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2365) body2364)) tmp2363) (syntax-error tmp2362))) (syntax-dispatch tmp2362 (quote (any any))))) (list (f2357 (cdr bindings2358)) (car bindings2358)))))) tmp2345) (syntax-error tmp2344))) (syntax-dispatch tmp2344 (quote (any #(each (any any)) any . each-any))))) x2343))) -(install-global-transformer (quote do) (lambda (orig-x2366) ((lambda (tmp2367) ((lambda (tmp2368) (if tmp2368 (apply (lambda (_2369 var2370 init2371 step2372 e02373 e12374 c2375) ((lambda (tmp2376) ((lambda (tmp2377) (if tmp2377 (apply (lambda (step2378) ((lambda (tmp2379) ((lambda (tmp2380) (if tmp2380 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02373) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2378))))))) tmp2380) ((lambda (tmp2385) (if tmp2385 (apply (lambda (e12386 e22387) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02373 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12386 e22387)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2378))))))) tmp2385) (syntax-error tmp2379))) (syntax-dispatch tmp2379 (quote (any . each-any)))))) (syntax-dispatch tmp2379 (quote ())))) e12374)) tmp2377) (syntax-error tmp2376))) (syntax-dispatch tmp2376 (quote each-any)))) (map (lambda (v2394 s2395) ((lambda (tmp2396) ((lambda (tmp2397) (if tmp2397 (apply (lambda () v2394) tmp2397) ((lambda (tmp2398) (if tmp2398 (apply (lambda (e2399) e2399) tmp2398) ((lambda (_2400) (syntax-error orig-x2366)) tmp2396))) (syntax-dispatch tmp2396 (quote (any)))))) (syntax-dispatch tmp2396 (quote ())))) s2395)) var2370 step2372))) tmp2368) (syntax-error tmp2367))) (syntax-dispatch tmp2367 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2366))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2403 (lambda (x2407 y2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (dy2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (dx2418) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2418 dy2415))) tmp2417) ((lambda (_2419) (if (null? dy2415) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2411) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2411 y2412))) tmp2416))) (syntax-dispatch tmp2416 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2411)) tmp2414) ((lambda (tmp2420) (if tmp2420 (apply (lambda (stuff2421) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2411 stuff2421))) tmp2420) ((lambda (else2422) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2411 y2412)) tmp2413))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2412)) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any any))))) (list x2407 y2408)))) (quasiappend2404 (lambda (x2423 y2424) ((lambda (tmp2425) ((lambda (tmp2426) (if tmp2426 (apply (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda () x2427) tmp2430) ((lambda (_2431) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2427 y2428)) tmp2429))) (syntax-dispatch tmp2429 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2428)) tmp2426) (syntax-error tmp2425))) (syntax-dispatch tmp2425 (quote (any any))))) (list x2423 y2424)))) (quasivector2405 (lambda (x2432) ((lambda (tmp2433) ((lambda (x2434) ((lambda (tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda (x2437) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2437))) tmp2436) ((lambda (tmp2439) (if tmp2439 (apply (lambda (x2440) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2440)) tmp2439) ((lambda (_2442) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2434)) tmp2435))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2434)) tmp2433)) x2432))) (quasi2406 (lambda (p2443 lev2444) ((lambda (tmp2445) ((lambda (tmp2446) (if tmp2446 (apply (lambda (p2447) (if (= lev2444 0) p2447 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2406 (list p2447) (- lev2444 1))))) tmp2446) ((lambda (tmp2448) (if tmp2448 (apply (lambda (p2449 q2450) (if (= lev2444 0) (quasiappend2404 p2449 (quasi2406 q2450 lev2444)) (quasicons2403 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2406 (list p2449) (- lev2444 1))) (quasi2406 q2450 lev2444)))) tmp2448) ((lambda (tmp2451) (if tmp2451 (apply (lambda (p2452) (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2406 (list p2452) (+ lev2444 1)))) tmp2451) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454 q2455) (quasicons2403 (quasi2406 p2454 lev2444) (quasi2406 q2455 lev2444))) tmp2453) ((lambda (tmp2456) (if tmp2456 (apply (lambda (x2457) (quasivector2405 (quasi2406 x2457 lev2444))) tmp2456) ((lambda (p2459) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2459)) tmp2445))) (syntax-dispatch tmp2445 (quote #(vector each-any)))))) (syntax-dispatch tmp2445 (quote (any . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2445 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2443)))) (lambda (x2460) ((lambda (tmp2461) ((lambda (tmp2462) (if tmp2462 (apply (lambda (_2463 e2464) (quasi2406 e2464 0)) tmp2462) (syntax-error tmp2461))) (syntax-dispatch tmp2461 (quote (any any))))) x2460)))) -(install-global-transformer (quote include) (lambda (x2465) (letrec ((read-file2466 (lambda (fn2467 k2468) (let ((p2469 (open-input-file fn2467))) (let f2470 ((x2471 (read p2469))) (if (eof-object? x2471) (begin (close-input-port p2469) (quote ())) (cons (datum->syntax-object k2468 x2471) (f2470 (read p2469))))))))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (k2474 filename2475) (let ((fn2476 (syntax-object->datum filename2475))) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (exp2479) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2479)) tmp2478) (syntax-error tmp2477))) (syntax-dispatch tmp2477 (quote each-any)))) (read-file2466 fn2476 k2474)))) tmp2473) (syntax-error tmp2472))) (syntax-dispatch tmp2472 (quote (any any))))) x2465)))) -(install-global-transformer (quote unquote) (lambda (x2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (_2484 e2485) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2485))) tmp2483) (syntax-error tmp2482))) (syntax-dispatch tmp2482 (quote (any any))))) x2481))) -(install-global-transformer (quote unquote-splicing) (lambda (x2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (_2489 e2490) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2490))) tmp2488) (syntax-error tmp2487))) (syntax-dispatch tmp2487 (quote (any any))))) x2486))) -(install-global-transformer (quote case) (lambda (x2491) ((lambda (tmp2492) ((lambda (tmp2493) (if tmp2493 (apply (lambda (_2494 e2495 m12496 m22497) ((lambda (tmp2498) ((lambda (body2499) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2495)) body2499)) tmp2498)) (let f2500 ((clause2501 m12496) (clauses2502 m22497)) (if (null? clauses2502) ((lambda (tmp2504) ((lambda (tmp2505) (if tmp2505 (apply (lambda (e12506 e22507) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12506 e22507))) tmp2505) ((lambda (tmp2509) (if tmp2509 (apply (lambda (k2510 e12511 e22512) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2510)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12511 e22512)))) tmp2509) ((lambda (_2515) (syntax-error x2491)) tmp2504))) (syntax-dispatch tmp2504 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2504 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2501) ((lambda (tmp2516) ((lambda (rest2517) ((lambda (tmp2518) ((lambda (tmp2519) (if tmp2519 (apply (lambda (k2520 e12521 e22522) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2520)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12521 e22522)) rest2517)) tmp2519) ((lambda (_2525) (syntax-error x2491)) tmp2518))) (syntax-dispatch tmp2518 (quote (each-any any . each-any))))) clause2501)) tmp2516)) (f2500 (car clauses2502) (cdr clauses2502))))))) tmp2493) (syntax-error tmp2492))) (syntax-dispatch tmp2492 (quote (any any any . each-any))))) x2491))) -(install-global-transformer (quote identifier-syntax) (lambda (x2526) ((lambda (tmp2527) ((lambda (tmp2528) (if tmp2528 (apply (lambda (_2529 e2530) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2530)) (list (cons _2529 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2530 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2528) (syntax-error tmp2527))) (syntax-dispatch tmp2527 (quote (any any))))) x2526))) +(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (module-name (procedure-module p1510))))))) ((vector? x1517) (let ((n1522 (vector-length x1517))) (let ((v1523 (make-vector n1522))) (let doloop1524 ((i1525 0)) (if (fx=1100 i1525 n1522) v1523 (begin (vector-set! v1523 i1525 (rebuild-macro-output1516 (vector-ref x1517 i1525) m1518)) (doloop1524 (fx+1098 i1525 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1526 e1527 r1528 w1529 s1530 mod1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (e01534 e11535) (build-annotated1108 s1530 (cons x1526 (map (lambda (e1536) (chi1167 e1536 r1528 w1529 mod1531)) e11535)))) tmp1533) (syntax-error tmp1532))) (syntax-dispatch tmp1532 (quote (any . each-any))))) e1527))) (chi-expr1168 (lambda (type1538 value1539 e1540 r1541 w1542 s1543 mod1544) (let ((t1545 type1538)) (if (memv t1545 (quote (lexical))) (build-annotated1108 s1543 value1539) (if (memv t1545 (quote (core external-macro))) (value1539 e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (module-ref))) (call-with-values (lambda () (value1539 e1540)) (lambda (id1546 mod1547) (cond ((and mod1547 (not (car mod1547))) (build-annotated1108 s1543 (make-module-ref (cdr mod1547) id1546 #t))) (else (build-annotated1108 s1543 (make-module-ref mod1547 id1546 #f)))))) (if (memv t1545 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) value1539) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (global-call))) (chi-application1169 (cond ((and (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) (not (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)))) (build-annotated1108 (source-annotation1122 (car e1540)) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 #t))) (else (build-annotated1108 (source-annotation1122 (car e1540)) (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 #f)))) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (constant))) (build-data1109 s1543 (strip1178 (source-wrap1160 e1540 w1542 s1543 mod1544) (quote (())))) (if (memv t1545 (quote (global))) (cond ((and mod1544 (not (car mod1544))) (build-annotated1108 s1543 (make-module-ref (cdr mod1544) value1539 #t))) (else (build-annotated1108 s1543 (make-module-ref mod1544 value1539 #f)))) (if (memv t1545 (quote (call))) (chi-application1169 (chi1167 (car e1540) r1541 w1542 mod1544) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (begin-form))) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (_1550 e11551 e21552) (chi-sequence1161 (cons e11551 e21552) r1541 w1542 s1543 mod1544)) tmp1549) (syntax-error tmp1548))) (syntax-dispatch tmp1548 (quote (any any . each-any))))) e1540) (if (memv t1545 (quote (local-syntax-form))) (chi-local-syntax1173 value1539 e1540 r1541 w1542 s1543 mod1544 chi-sequence1161) (if (memv t1545 (quote (eval-when-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 x1557 e11558 e21559) (let ((when-list1560 (chi-when-list1164 e1540 x1557 w1542))) (if (memq (quote eval) when-list1560) (chi-sequence1161 (cons e11558 e21559) r1541 w1542 s1543 mod1544) (chi-void1175)))) tmp1555) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any each-any any . each-any))))) e1540) (if (memv t1545 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1539 w1542 mod1544) "invalid context for definition of") (if (memv t1545 (quote (syntax))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to pattern variable outside syntax form") (if (memv t1545 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544))))))))))))))))))) (chi1167 (lambda (e1563 r1564 w1565 mod1566) (call-with-values (lambda () (syntax-type1165 e1563 r1564 w1565 #f #f mod1566)) (lambda (type1567 value1568 e1569 w1570 s1571 mod1572) (chi-expr1168 type1567 value1568 e1569 r1564 w1570 s1571 mod1572))))) (chi-top1166 (lambda (e1573 r1574 w1575 m1576 esew1577 mod1578) (call-with-values (lambda () (syntax-type1165 e1573 r1574 w1575 #f #f mod1578)) (lambda (type1586 value1587 e1588 w1589 s1590 mod1591) (let ((t1592 type1586)) (if (memv t1592 (quote (begin-form))) ((lambda (tmp1593) ((lambda (tmp1594) (if tmp1594 (apply (lambda (_1595) (chi-void1175)) tmp1594) ((lambda (tmp1596) (if tmp1596 (apply (lambda (_1597 e11598 e21599) (chi-top-sequence1162 (cons e11598 e21599) r1574 w1589 s1590 m1576 esew1577 mod1591)) tmp1596) (syntax-error tmp1593))) (syntax-dispatch tmp1593 (quote (any any . each-any)))))) (syntax-dispatch tmp1593 (quote (any))))) e1588) (if (memv t1592 (quote (local-syntax-form))) (chi-local-syntax1173 value1587 e1588 r1574 w1589 s1590 mod1591 (lambda (body1601 r1602 w1603 s1604 mod1605) (chi-top-sequence1162 body1601 r1602 w1603 s1604 m1576 esew1577 mod1605))) (if (memv t1592 (quote (eval-when-form))) ((lambda (tmp1606) ((lambda (tmp1607) (if tmp1607 (apply (lambda (_1608 x1609 e11610 e21611) (let ((when-list1612 (chi-when-list1164 e1588 x1609 w1589)) (body1613 (cons e11610 e21611))) (cond ((eq? m1576 (quote e)) (if (memq (quote eval) when-list1612) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) (chi-void1175))) ((memq (quote load) when-list1612) (if (or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c&e) (quote (compile load)) mod1591) (if (memq m1576 (quote (c c&e))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c) (quote (load)) mod1591) (chi-void1175)))) ((or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (top-level-eval-hook1102 (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) mod1591) (chi-void1175)) (else (chi-void1175))))) tmp1607) (syntax-error tmp1606))) (syntax-dispatch tmp1606 (quote (any each-any any . each-any))))) e1588) (if (memv t1592 (quote (define-syntax-form))) (let ((n1616 (id-var-name1153 value1587 w1589)) (r1617 (macros-only-env1127 r1574))) (let ((t1618 m1576)) (if (memv t1618 (quote (c))) (if (memq (quote compile) esew1577) (let ((e1619 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1619 mod1591) (if (memq (quote load) esew1577) e1619 (chi-void1175)))) (if (memq (quote load) esew1577) (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) (chi-void1175))) (if (memv t1618 (quote (c&e))) (let ((e1620 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1620 mod1591) e1620)) (begin (if (memq (quote eval) esew1577) (top-level-eval-hook1102 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) mod1591)) (chi-void1175)))))) (if (memv t1592 (quote (define-form))) (let ((n1621 (id-var-name1153 value1587 w1589))) (let ((type1622 (binding-type1123 (lookup1128 n1621 r1574 mod1591)))) (let ((t1623 type1622)) (if (memv t1623 (quote (global))) (let ((x1624 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1624 mod1591)) x1624)) (if (memv t1623 (quote (displaced-lexical))) (syntax-error (wrap1159 value1587 w1589 mod1591) "identifier out of context") (if (memv t1623 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1621 mod1591) (let ((x1625 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1625 mod1591)) x1625))) (syntax-error (wrap1159 value1587 w1589 mod1591) "cannot define keyword at top level"))))))) (let ((x1626 (chi-expr1168 type1586 value1587 e1588 r1574 w1589 s1590 mod1591))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1626 mod1591)) x1626)))))))))))) (syntax-type1165 (lambda (e1627 r1628 w1629 s1630 rib1631 mod1632) (cond ((symbol? e1627) (let ((n1633 (id-var-name1153 e1627 w1629))) (let ((b1634 (lookup1128 n1633 r1628 mod1632))) (let ((type1635 (binding-type1123 b1634))) (let ((t1636 type1635)) (if (memv t1636 (quote (lexical))) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (global))) (values type1635 n1633 e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1634) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632))))))))) ((pair? e1627) (let ((first1637 (car e1627))) (if (id?1131 first1637) (let ((n1638 (id-var-name1153 first1637 w1629))) (let ((b1639 (lookup1128 n1638 r1628 (or (and (syntax-object?1115 first1637) (syntax-object-module1118 first1637)) mod1632)))) (let ((type1640 (binding-type1123 b1639))) (let ((t1641 type1640)) (if (memv t1641 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (global))) (values (quote global-call) n1638 e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1639) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (if (memv t1641 (quote (core external-macro module-ref))) (values type1640 (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (begin))) (values (quote begin-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (eval-when))) (values (quote eval-when-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (define))) ((lambda (tmp1642) ((lambda (tmp1643) (if (if tmp1643 (apply (lambda (_1644 name1645 val1646) (id?1131 name1645)) tmp1643) #f) (apply (lambda (_1647 name1648 val1649) (values (quote define-form) name1648 val1649 w1629 s1630 mod1632)) tmp1643) ((lambda (tmp1650) (if (if tmp1650 (apply (lambda (_1651 name1652 args1653 e11654 e21655) (and (id?1131 name1652) (valid-bound-ids?1156 (lambda-var-list1180 args1653)))) tmp1650) #f) (apply (lambda (_1656 name1657 args1658 e11659 e21660) (values (quote define-form) (wrap1159 name1657 w1629 mod1632) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1159 (cons args1658 (cons e11659 e21660)) w1629 mod1632)) (quote (())) s1630 mod1632)) tmp1650) ((lambda (tmp1662) (if (if tmp1662 (apply (lambda (_1663 name1664) (id?1131 name1664)) tmp1662) #f) (apply (lambda (_1665 name1666) (values (quote define-form) (wrap1159 name1666 w1629 mod1632) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1630 mod1632)) tmp1662) (syntax-error tmp1642))) (syntax-dispatch tmp1642 (quote (any any)))))) (syntax-dispatch tmp1642 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1642 (quote (any any any))))) e1627) (if (memv t1641 (quote (define-syntax))) ((lambda (tmp1667) ((lambda (tmp1668) (if (if tmp1668 (apply (lambda (_1669 name1670 val1671) (id?1131 name1670)) tmp1668) #f) (apply (lambda (_1672 name1673 val1674) (values (quote define-syntax-form) name1673 val1674 w1629 s1630 mod1632)) tmp1668) (syntax-error tmp1667))) (syntax-dispatch tmp1667 (quote (any any any))))) e1627) (values (quote call) #f e1627 w1629 s1630 mod1632)))))))))))))) (values (quote call) #f e1627 w1629 s1630 mod1632)))) ((syntax-object?1115 e1627) (syntax-type1165 (syntax-object-expression1116 e1627) r1628 (join-wraps1150 w1629 (syntax-object-wrap1117 e1627)) #f rib1631 (or (syntax-object-module1118 e1627) mod1632))) ((annotation? e1627) (syntax-type1165 (annotation-expression e1627) r1628 w1629 (annotation-source e1627) rib1631 mod1632)) ((self-evaluating? e1627) (values (quote constant) #f e1627 w1629 s1630 mod1632)) (else (values (quote other) #f e1627 w1629 s1630 mod1632))))) (chi-when-list1164 (lambda (e1675 when-list1676 w1677) (let f1678 ((when-list1679 when-list1676) (situations1680 (quote ()))) (if (null? when-list1679) situations1680 (f1678 (cdr when-list1679) (cons (let ((x1681 (car when-list1679))) (cond ((free-id=?1154 x1681 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1154 x1681 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1154 x1681 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1159 x1681 w1677 #f) "invalid eval-when situation")))) situations1680)))))) (chi-install-global1163 (lambda (name1682 e1683) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1682) e1683)))) (chi-top-sequence1162 (lambda (body1684 r1685 w1686 s1687 m1688 esew1689 mod1690) (build-sequence1110 s1687 (let dobody1691 ((body1692 body1684) (r1693 r1685) (w1694 w1686) (m1695 m1688) (esew1696 esew1689) (mod1697 mod1690)) (if (null? body1692) (quote ()) (let ((first1698 (chi-top1166 (car body1692) r1693 w1694 m1695 esew1696 mod1697))) (cons first1698 (dobody1691 (cdr body1692) r1693 w1694 m1695 esew1696 mod1697)))))))) (chi-sequence1161 (lambda (body1699 r1700 w1701 s1702 mod1703) (build-sequence1110 s1702 (let dobody1704 ((body1705 body1699) (r1706 r1700) (w1707 w1701) (mod1708 mod1703)) (if (null? body1705) (quote ()) (let ((first1709 (chi1167 (car body1705) r1706 w1707 mod1708))) (cons first1709 (dobody1704 (cdr body1705) r1706 w1707 mod1708)))))))) (source-wrap1160 (lambda (x1710 w1711 s1712 defmod1713) (wrap1159 (if s1712 (make-annotation x1710 s1712 #f) x1710) w1711 defmod1713))) (wrap1159 (lambda (x1714 w1715 defmod1716) (cond ((and (null? (wrap-marks1134 w1715)) (null? (wrap-subst1135 w1715))) x1714) ((syntax-object?1115 x1714) (make-syntax-object1114 (syntax-object-expression1116 x1714) (join-wraps1150 w1715 (syntax-object-wrap1117 x1714)) (syntax-object-module1118 x1714))) ((null? x1714) x1714) (else (make-syntax-object1114 x1714 w1715 defmod1716))))) (bound-id-member?1158 (lambda (x1717 list1718) (and (not (null? list1718)) (or (bound-id=?1155 x1717 (car list1718)) (bound-id-member?1158 x1717 (cdr list1718)))))) (distinct-bound-ids?1157 (lambda (ids1719) (let distinct?1720 ((ids1721 ids1719)) (or (null? ids1721) (and (not (bound-id-member?1158 (car ids1721) (cdr ids1721))) (distinct?1720 (cdr ids1721))))))) (valid-bound-ids?1156 (lambda (ids1722) (and (let all-ids?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (id?1131 (car ids1724)) (all-ids?1723 (cdr ids1724))))) (distinct-bound-ids?1157 ids1722)))) (bound-id=?1155 (lambda (i1725 j1726) (if (and (syntax-object?1115 i1725) (syntax-object?1115 j1726)) (and (eq? (let ((e1727 (syntax-object-expression1116 i1725))) (if (annotation? e1727) (annotation-expression e1727) e1727)) (let ((e1728 (syntax-object-expression1116 j1726))) (if (annotation? e1728) (annotation-expression e1728) e1728))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1725)) (wrap-marks1134 (syntax-object-wrap1117 j1726)))) (eq? (let ((e1729 i1725)) (if (annotation? e1729) (annotation-expression e1729) e1729)) (let ((e1730 j1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)))))) (free-id=?1154 (lambda (i1731 j1732) (and (eq? (let ((x1733 i1731)) (let ((e1734 (if (syntax-object?1115 x1733) (syntax-object-expression1116 x1733) x1733))) (if (annotation? e1734) (annotation-expression e1734) e1734))) (let ((x1735 j1732)) (let ((e1736 (if (syntax-object?1115 x1735) (syntax-object-expression1116 x1735) x1735))) (if (annotation? e1736) (annotation-expression e1736) e1736)))) (eq? (id-var-name1153 i1731 (quote (()))) (id-var-name1153 j1732 (quote (()))))))) (id-var-name1153 (lambda (id1737 w1738) (letrec ((search-vector-rib1741 (lambda (sym1747 subst1748 marks1749 symnames1750 ribcage1751) (let ((n1752 (vector-length symnames1750))) (let f1753 ((i1754 0)) (cond ((fx=1100 i1754 n1752) (search1739 sym1747 (cdr subst1748) marks1749)) ((and (eq? (vector-ref symnames1750 i1754) sym1747) (same-marks?1152 marks1749 (vector-ref (ribcage-marks1141 ribcage1751) i1754))) (values (vector-ref (ribcage-labels1142 ribcage1751) i1754) marks1749)) (else (f1753 (fx+1098 i1754 1)))))))) (search-list-rib1740 (lambda (sym1755 subst1756 marks1757 symnames1758 ribcage1759) (let f1760 ((symnames1761 symnames1758) (i1762 0)) (cond ((null? symnames1761) (search1739 sym1755 (cdr subst1756) marks1757)) ((and (eq? (car symnames1761) sym1755) (same-marks?1152 marks1757 (list-ref (ribcage-marks1141 ribcage1759) i1762))) (values (list-ref (ribcage-labels1142 ribcage1759) i1762) marks1757)) (else (f1760 (cdr symnames1761) (fx+1098 i1762 1))))))) (search1739 (lambda (sym1763 subst1764 marks1765) (if (null? subst1764) (values #f marks1765) (let ((fst1766 (car subst1764))) (if (eq? fst1766 (quote shift)) (search1739 sym1763 (cdr subst1764) (cdr marks1765)) (let ((symnames1767 (ribcage-symnames1140 fst1766))) (if (vector? symnames1767) (search-vector-rib1741 sym1763 subst1764 marks1765 symnames1767 fst1766) (search-list-rib1740 sym1763 subst1764 marks1765 symnames1767 fst1766))))))))) (cond ((symbol? id1737) (or (call-with-values (lambda () (search1739 id1737 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1769 . ignore1768) x1769)) id1737)) ((syntax-object?1115 id1737) (let ((id1770 (let ((e1772 (syntax-object-expression1116 id1737))) (if (annotation? e1772) (annotation-expression e1772) e1772))) (w11771 (syntax-object-wrap1117 id1737))) (let ((marks1773 (join-marks1151 (wrap-marks1134 w1738) (wrap-marks1134 w11771)))) (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w1738) marks1773)) (lambda (new-id1774 marks1775) (or new-id1774 (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w11771) marks1775)) (lambda (x1777 . ignore1776) x1777)) id1770)))))) ((annotation? id1737) (let ((id1778 (let ((e1779 id1737)) (if (annotation? e1779) (annotation-expression e1779) e1779)))) (or (call-with-values (lambda () (search1739 id1778 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1781 . ignore1780) x1781)) id1778))) (else (error-hook1104 (quote id-var-name) "invalid id" id1737)))))) (same-marks?1152 (lambda (x1782 y1783) (or (eq? x1782 y1783) (and (not (null? x1782)) (not (null? y1783)) (eq? (car x1782) (car y1783)) (same-marks?1152 (cdr x1782) (cdr y1783)))))) (join-marks1151 (lambda (m11784 m21785) (smart-append1149 m11784 m21785))) (join-wraps1150 (lambda (w11786 w21787) (let ((m11788 (wrap-marks1134 w11786)) (s11789 (wrap-subst1135 w11786))) (if (null? m11788) (if (null? s11789) w21787 (make-wrap1133 (wrap-marks1134 w21787) (smart-append1149 s11789 (wrap-subst1135 w21787)))) (make-wrap1133 (smart-append1149 m11788 (wrap-marks1134 w21787)) (smart-append1149 s11789 (wrap-subst1135 w21787))))))) (smart-append1149 (lambda (m11790 m21791) (if (null? m21791) m11790 (append m11790 m21791)))) (make-binding-wrap1148 (lambda (ids1792 labels1793 w1794) (if (null? ids1792) w1794 (make-wrap1133 (wrap-marks1134 w1794) (cons (let ((labelvec1795 (list->vector labels1793))) (let ((n1796 (vector-length labelvec1795))) (let ((symnamevec1797 (make-vector n1796)) (marksvec1798 (make-vector n1796))) (begin (let f1799 ((ids1800 ids1792) (i1801 0)) (if (not (null? ids1800)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1800) w1794)) (lambda (symname1802 marks1803) (begin (vector-set! symnamevec1797 i1801 symname1802) (vector-set! marksvec1798 i1801 marks1803) (f1799 (cdr ids1800) (fx+1098 i1801 1))))))) (make-ribcage1138 symnamevec1797 marksvec1798 labelvec1795))))) (wrap-subst1135 w1794)))))) (extend-ribcage!1147 (lambda (ribcage1804 id1805 label1806) (begin (set-ribcage-symnames!1143 ribcage1804 (cons (let ((e1807 (syntax-object-expression1116 id1805))) (if (annotation? e1807) (annotation-expression e1807) e1807)) (ribcage-symnames1140 ribcage1804))) (set-ribcage-marks!1144 ribcage1804 (cons (wrap-marks1134 (syntax-object-wrap1117 id1805)) (ribcage-marks1141 ribcage1804))) (set-ribcage-labels!1145 ribcage1804 (cons label1806 (ribcage-labels1142 ribcage1804)))))) (anti-mark1146 (lambda (w1808) (make-wrap1133 (cons #f (wrap-marks1134 w1808)) (cons (quote shift) (wrap-subst1135 w1808))))) (set-ribcage-labels!1145 (lambda (x1809 update1810) (vector-set! x1809 3 update1810))) (set-ribcage-marks!1144 (lambda (x1811 update1812) (vector-set! x1811 2 update1812))) (set-ribcage-symnames!1143 (lambda (x1813 update1814) (vector-set! x1813 1 update1814))) (ribcage-labels1142 (lambda (x1815) (vector-ref x1815 3))) (ribcage-marks1141 (lambda (x1816) (vector-ref x1816 2))) (ribcage-symnames1140 (lambda (x1817) (vector-ref x1817 1))) (ribcage?1139 (lambda (x1818) (and (vector? x1818) (= (vector-length x1818) 4) (eq? (vector-ref x1818 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1819 marks1820 labels1821) (vector (quote ribcage) symnames1819 marks1820 labels1821))) (gen-labels1137 (lambda (ls1822) (if (null? ls1822) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1822)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1823 w1824) (if (syntax-object?1115 x1823) (values (let ((e1825 (syntax-object-expression1116 x1823))) (if (annotation? e1825) (annotation-expression e1825) e1825)) (join-marks1151 (wrap-marks1134 w1824) (wrap-marks1134 (syntax-object-wrap1117 x1823)))) (values (let ((e1826 x1823)) (if (annotation? e1826) (annotation-expression e1826) e1826)) (wrap-marks1134 w1824))))) (id?1131 (lambda (x1827) (cond ((symbol? x1827) #t) ((syntax-object?1115 x1827) (symbol? (let ((e1828 (syntax-object-expression1116 x1827))) (if (annotation? e1828) (annotation-expression e1828) e1828)))) ((annotation? x1827) (symbol? (annotation-expression x1827))) (else #f)))) (nonsymbol-id?1130 (lambda (x1829) (and (syntax-object?1115 x1829) (symbol? (let ((e1830 (syntax-object-expression1116 x1829))) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (global-extend1129 (lambda (type1831 sym1832 val1833) (put-global-definition-hook1105 sym1832 (cons type1831 val1833) (module-name (current-module))))) (lookup1128 (lambda (x1834 r1835 mod1836) (cond ((assq x1834 r1835) => cdr) ((symbol? x1834) (or (get-global-definition-hook1107 x1834 mod1836) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1837) (if (null? r1837) (quote ()) (let ((a1838 (car r1837))) (if (eq? (cadr a1838) (quote macro)) (cons a1838 (macros-only-env1127 (cdr r1837))) (macros-only-env1127 (cdr r1837))))))) (extend-var-env1126 (lambda (labels1839 vars1840 r1841) (if (null? labels1839) r1841 (extend-var-env1126 (cdr labels1839) (cdr vars1840) (cons (cons (car labels1839) (cons (quote lexical) (car vars1840))) r1841))))) (extend-env1125 (lambda (labels1842 bindings1843 r1844) (if (null? labels1842) r1844 (extend-env1125 (cdr labels1842) (cdr bindings1843) (cons (cons (car labels1842) (car bindings1843)) r1844))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1845) (cond ((annotation? x1845) (annotation-source x1845)) ((syntax-object?1115 x1845) (source-annotation1122 (syntax-object-expression1116 x1845))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1846 update1847) (vector-set! x1846 3 update1847))) (set-syntax-object-wrap!1120 (lambda (x1848 update1849) (vector-set! x1848 2 update1849))) (set-syntax-object-expression!1119 (lambda (x1850 update1851) (vector-set! x1850 1 update1851))) (syntax-object-module1118 (lambda (x1852) (vector-ref x1852 3))) (syntax-object-wrap1117 (lambda (x1853) (vector-ref x1853 2))) (syntax-object-expression1116 (lambda (x1854) (vector-ref x1854 1))) (syntax-object?1115 (lambda (x1855) (and (vector? x1855) (= (vector-length x1855) 4) (eq? (vector-ref x1855 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1856 wrap1857 module1858) (vector (quote syntax-object) expression1856 wrap1857 module1858))) (build-letrec1113 (lambda (src1859 vars1860 val-exps1861 body-exp1862) (if (null? vars1860) (build-annotated1108 src1859 body-exp1862) (build-annotated1108 src1859 (list (quote letrec) (map list vars1860 val-exps1861) body-exp1862))))) (build-named-let1112 (lambda (src1863 vars1864 val-exps1865 body-exp1866) (if (null? vars1864) (build-annotated1108 src1863 body-exp1866) (build-annotated1108 src1863 (list (quote let) (car vars1864) (map list (cdr vars1864) val-exps1865) body-exp1866))))) (build-let1111 (lambda (src1867 vars1868 val-exps1869 body-exp1870) (if (null? vars1868) (build-annotated1108 src1867 body-exp1870) (build-annotated1108 src1867 (list (quote let) (map list vars1868 val-exps1869) body-exp1870))))) (build-sequence1110 (lambda (src1871 exps1872) (if (null? (cdr exps1872)) (build-annotated1108 src1871 (car exps1872)) (build-annotated1108 src1871 (cons (quote begin) exps1872))))) (build-data1109 (lambda (src1873 exp1874) (if (and (self-evaluating? exp1874) (not (vector? exp1874))) (build-annotated1108 src1873 exp1874) (build-annotated1108 src1873 (list (quote quote) exp1874))))) (build-annotated1108 (lambda (src1875 exp1876) (if (and src1875 (not (annotation? exp1876))) (make-annotation exp1876 src1875 #t) exp1876))) (get-global-definition-hook1107 (lambda (symbol1877 module1878) (let ((module1879 (if module1878 (resolve-module module1878) (let ((mod1880 (current-module))) (begin (if mod1880 (warn "wha" symbol1877)) mod1880))))) (let ((v1881 (module-variable module1879 symbol1877))) (and v1881 (or (object-property v1881 (quote *sc-expander*)) (and (variable-bound? v1881) (macro? (variable-ref v1881)) (macro-transformer (variable-ref v1881)) guile-macro))))))) (remove-global-definition-hook1106 (lambda (symbol1882 modname1883) (let ((module1884 (if modname1883 (resolve-module modname1883) (current-module)))) (let ((v1885 (module-local-variable module1884 symbol1882))) (if v1885 (let ((p1886 (assq (quote *sc-expander*) (object-properties v1885)))) (set-object-properties! v1885 (delq p1886 (object-properties v1885))))))))) (put-global-definition-hook1105 (lambda (symbol1887 binding1888 modname1889) (let ((module1890 (if modname1889 (resolve-module modname1889) (current-module)))) (let ((v1891 (or (module-variable module1890 symbol1887) (let ((v1892 (make-variable (gensym)))) (begin (module-add! module1890 symbol1887 v1892) v1892))))) (begin (if (not (variable-bound? v1891)) (variable-set! v1891 (gensym))) (set-object-property! v1891 (quote *sc-expander*) binding1888)))))) (error-hook1104 (lambda (who1893 why1894 what1895) (error who1893 "~a ~s" why1894 what1895))) (local-eval-hook1103 (lambda (x1896 mod1897) (eval (list noexpand1097 x1896) (if mod1897 (resolve-module mod1897) (interaction-environment))))) (top-level-eval-hook1102 (lambda (x1898 mod1899) (eval (list noexpand1097 x1898) (if mod1899 (resolve-module mod1899) (interaction-environment))))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1900 r1901 w1902 s1903 mod1904) ((lambda (tmp1905) ((lambda (tmp1906) (if (if tmp1906 (apply (lambda (_1907 var1908 val1909 e11910 e21911) (valid-bound-ids?1156 var1908)) tmp1906) #f) (apply (lambda (_1913 var1914 val1915 e11916 e21917) (let ((names1918 (map (lambda (x1919) (id-var-name1153 x1919 w1902)) var1914))) (begin (for-each (lambda (id1921 n1922) (let ((t1923 (binding-type1123 (lookup1128 n1922 r1901 mod1904)))) (if (memv t1923 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1921 w1902 s1903 mod1904) "identifier out of context")))) var1914 names1918) (chi-body1171 (cons e11916 e21917) (source-wrap1160 e1900 w1902 s1903 mod1904) (extend-env1125 names1918 (let ((trans-r1926 (macros-only-env1127 r1901))) (map (lambda (x1927) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1927 trans-r1926 w1902 mod1904) mod1904))) val1915)) r1901) w1902 mod1904)))) tmp1906) ((lambda (_1929) (syntax-error (source-wrap1160 e1900 w1902 s1903 mod1904))) tmp1905))) (syntax-dispatch tmp1905 (quote (any #(each (any any)) any . each-any))))) e1900))) (global-extend1129 (quote core) (quote quote) (lambda (e1930 r1931 w1932 s1933 mod1934) ((lambda (tmp1935) ((lambda (tmp1936) (if tmp1936 (apply (lambda (_1937 e1938) (build-data1109 s1933 (strip1178 e1938 w1932))) tmp1936) ((lambda (_1939) (syntax-error (source-wrap1160 e1930 w1932 s1933 mod1934))) tmp1935))) (syntax-dispatch tmp1935 (quote (any any))))) e1930))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1947 (lambda (x1948) (let ((t1949 (car x1948))) (if (memv t1949 (quote (ref))) (build-annotated1108 #f (cadr x1948)) (if (memv t1949 (quote (primitive))) (build-annotated1108 #f (cadr x1948)) (if (memv t1949 (quote (quote))) (build-data1109 #f (cadr x1948)) (if (memv t1949 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1948) (regen1947 (caddr x1948)))) (if (memv t1949 (quote (map))) (let ((ls1950 (map regen1947 (cdr x1948)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1950) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1950))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1948)) (map regen1947 (cdr x1948)))))))))))) (gen-vector1946 (lambda (x1951) (cond ((eq? (car x1951) (quote list)) (cons (quote vector) (cdr x1951))) ((eq? (car x1951) (quote quote)) (list (quote quote) (list->vector (cadr x1951)))) (else (list (quote list->vector) x1951))))) (gen-append1945 (lambda (x1952 y1953) (if (equal? y1953 (quote (quote ()))) x1952 (list (quote append) x1952 y1953)))) (gen-cons1944 (lambda (x1954 y1955) (let ((t1956 (car y1955))) (if (memv t1956 (quote (quote))) (if (eq? (car x1954) (quote quote)) (list (quote quote) (cons (cadr x1954) (cadr y1955))) (if (eq? (cadr y1955) (quote ())) (list (quote list) x1954) (list (quote cons) x1954 y1955))) (if (memv t1956 (quote (list))) (cons (quote list) (cons x1954 (cdr y1955))) (list (quote cons) x1954 y1955)))))) (gen-map1943 (lambda (e1957 map-env1958) (let ((formals1959 (map cdr map-env1958)) (actuals1960 (map (lambda (x1961) (list (quote ref) (car x1961))) map-env1958))) (cond ((eq? (car e1957) (quote ref)) (car actuals1960)) ((andmap (lambda (x1962) (and (eq? (car x1962) (quote ref)) (memq (cadr x1962) formals1959))) (cdr e1957)) (cons (quote map) (cons (list (quote primitive) (car e1957)) (map (let ((r1963 (map cons formals1959 actuals1960))) (lambda (x1964) (cdr (assq (cadr x1964) r1963)))) (cdr e1957))))) (else (cons (quote map) (cons (list (quote lambda) formals1959 e1957) actuals1960))))))) (gen-mappend1942 (lambda (e1965 map-env1966) (list (quote apply) (quote (primitive append)) (gen-map1943 e1965 map-env1966)))) (gen-ref1941 (lambda (src1967 var1968 level1969 maps1970) (if (fx=1100 level1969 0) (values var1968 maps1970) (if (null? maps1970) (syntax-error src1967 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1941 src1967 var1968 (fx-1099 level1969 1) (cdr maps1970))) (lambda (outer-var1971 outer-maps1972) (let ((b1973 (assq outer-var1971 (car maps1970)))) (if b1973 (values (cdr b1973) maps1970) (let ((inner-var1974 (gen-var1179 (quote tmp)))) (values inner-var1974 (cons (cons (cons outer-var1971 inner-var1974) (car maps1970)) outer-maps1972))))))))))) (gen-syntax1940 (lambda (src1975 e1976 r1977 maps1978 ellipsis?1979 mod1980) (if (id?1131 e1976) (let ((label1981 (id-var-name1153 e1976 (quote (()))))) (let ((b1982 (lookup1128 label1981 r1977 mod1980))) (if (eq? (binding-type1123 b1982) (quote syntax)) (call-with-values (lambda () (let ((var.lev1983 (binding-value1124 b1982))) (gen-ref1941 src1975 (car var.lev1983) (cdr var.lev1983) maps1978))) (lambda (var1984 maps1985) (values (list (quote ref) var1984) maps1985))) (if (ellipsis?1979 e1976) (syntax-error src1975 "misplaced ellipsis in syntax form") (values (list (quote quote) e1976) maps1978))))) ((lambda (tmp1986) ((lambda (tmp1987) (if (if tmp1987 (apply (lambda (dots1988 e1989) (ellipsis?1979 dots1988)) tmp1987) #f) (apply (lambda (dots1990 e1991) (gen-syntax1940 src1975 e1991 r1977 maps1978 (lambda (x1992) #f) mod1980)) tmp1987) ((lambda (tmp1993) (if (if tmp1993 (apply (lambda (x1994 dots1995 y1996) (ellipsis?1979 dots1995)) tmp1993) #f) (apply (lambda (x1997 dots1998 y1999) (let f2000 ((y2001 y1999) (k2002 (lambda (maps2003) (call-with-values (lambda () (gen-syntax1940 src1975 x1997 r1977 (cons (quote ()) maps2003) ellipsis?1979 mod1980)) (lambda (x2004 maps2005) (if (null? (car maps2005)) (syntax-error src1975 "extra ellipsis in syntax form") (values (gen-map1943 x2004 (car maps2005)) (cdr maps2005)))))))) ((lambda (tmp2006) ((lambda (tmp2007) (if (if tmp2007 (apply (lambda (dots2008 y2009) (ellipsis?1979 dots2008)) tmp2007) #f) (apply (lambda (dots2010 y2011) (f2000 y2011 (lambda (maps2012) (call-with-values (lambda () (k2002 (cons (quote ()) maps2012))) (lambda (x2013 maps2014) (if (null? (car maps2014)) (syntax-error src1975 "extra ellipsis in syntax form") (values (gen-mappend1942 x2013 (car maps2014)) (cdr maps2014)))))))) tmp2007) ((lambda (_2015) (call-with-values (lambda () (gen-syntax1940 src1975 y2001 r1977 maps1978 ellipsis?1979 mod1980)) (lambda (y2016 maps2017) (call-with-values (lambda () (k2002 maps2017)) (lambda (x2018 maps2019) (values (gen-append1945 x2018 y2016) maps2019)))))) tmp2006))) (syntax-dispatch tmp2006 (quote (any . any))))) y2001))) tmp1993) ((lambda (tmp2020) (if tmp2020 (apply (lambda (x2021 y2022) (call-with-values (lambda () (gen-syntax1940 src1975 x2021 r1977 maps1978 ellipsis?1979 mod1980)) (lambda (x2023 maps2024) (call-with-values (lambda () (gen-syntax1940 src1975 y2022 r1977 maps2024 ellipsis?1979 mod1980)) (lambda (y2025 maps2026) (values (gen-cons1944 x2023 y2025) maps2026)))))) tmp2020) ((lambda (tmp2027) (if tmp2027 (apply (lambda (e12028 e22029) (call-with-values (lambda () (gen-syntax1940 src1975 (cons e12028 e22029) r1977 maps1978 ellipsis?1979 mod1980)) (lambda (e2031 maps2032) (values (gen-vector1946 e2031) maps2032)))) tmp2027) ((lambda (_2033) (values (list (quote quote) e1976) maps1978)) tmp1986))) (syntax-dispatch tmp1986 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1986 (quote (any . any)))))) (syntax-dispatch tmp1986 (quote (any any . any)))))) (syntax-dispatch tmp1986 (quote (any any))))) e1976))))) (lambda (e2034 r2035 w2036 s2037 mod2038) (let ((e2039 (source-wrap1160 e2034 w2036 s2037 mod2038))) ((lambda (tmp2040) ((lambda (tmp2041) (if tmp2041 (apply (lambda (_2042 x2043) (call-with-values (lambda () (gen-syntax1940 e2039 x2043 r2035 (quote ()) ellipsis?1176 mod2038)) (lambda (e2044 maps2045) (regen1947 e2044)))) tmp2041) ((lambda (_2046) (syntax-error e2039)) tmp2040))) (syntax-dispatch tmp2040 (quote (any any))))) e2039))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2047 r2048 w2049 s2050 mod2051) ((lambda (tmp2052) ((lambda (tmp2053) (if tmp2053 (apply (lambda (_2054 c2055) (chi-lambda-clause1172 (source-wrap1160 e2047 w2049 s2050 mod2051) c2055 r2048 w2049 mod2051 (lambda (vars2056 body2057) (build-annotated1108 s2050 (list (quote lambda) vars2056 body2057))))) tmp2053) (syntax-error tmp2052))) (syntax-dispatch tmp2052 (quote (any . any))))) e2047))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2058 (lambda (e2059 r2060 w2061 s2062 mod2063 constructor2064 ids2065 vals2066 exps2067) (if (not (valid-bound-ids?1156 ids2065)) (syntax-error e2059 "duplicate bound variable in") (let ((labels2068 (gen-labels1137 ids2065)) (new-vars2069 (map gen-var1179 ids2065))) (let ((nw2070 (make-binding-wrap1148 ids2065 labels2068 w2061)) (nr2071 (extend-var-env1126 labels2068 new-vars2069 r2060))) (constructor2064 s2062 new-vars2069 (map (lambda (x2072) (chi1167 x2072 r2060 w2061 mod2063)) vals2066) (chi-body1171 exps2067 (source-wrap1160 e2059 nw2070 s2062 mod2063) nr2071 nw2070 mod2063)))))))) (lambda (e2073 r2074 w2075 s2076 mod2077) ((lambda (tmp2078) ((lambda (tmp2079) (if tmp2079 (apply (lambda (_2080 id2081 val2082 e12083 e22084) (chi-let2058 e2073 r2074 w2075 s2076 mod2077 build-let1111 id2081 val2082 (cons e12083 e22084))) tmp2079) ((lambda (tmp2088) (if (if tmp2088 (apply (lambda (_2089 f2090 id2091 val2092 e12093 e22094) (id?1131 f2090)) tmp2088) #f) (apply (lambda (_2095 f2096 id2097 val2098 e12099 e22100) (chi-let2058 e2073 r2074 w2075 s2076 mod2077 build-named-let1112 (cons f2096 id2097) val2098 (cons e12099 e22100))) tmp2088) ((lambda (_2104) (syntax-error (source-wrap1160 e2073 w2075 s2076 mod2077))) tmp2078))) (syntax-dispatch tmp2078 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2078 (quote (any #(each (any any)) any . each-any))))) e2073)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2105 r2106 w2107 s2108 mod2109) ((lambda (tmp2110) ((lambda (tmp2111) (if tmp2111 (apply (lambda (_2112 id2113 val2114 e12115 e22116) (let ((ids2117 id2113)) (if (not (valid-bound-ids?1156 ids2117)) (syntax-error e2105 "duplicate bound variable in") (let ((labels2119 (gen-labels1137 ids2117)) (new-vars2120 (map gen-var1179 ids2117))) (let ((w2121 (make-binding-wrap1148 ids2117 labels2119 w2107)) (r2122 (extend-var-env1126 labels2119 new-vars2120 r2106))) (build-letrec1113 s2108 new-vars2120 (map (lambda (x2123) (chi1167 x2123 r2122 w2121 mod2109)) val2114) (chi-body1171 (cons e12115 e22116) (source-wrap1160 e2105 w2121 s2108 mod2109) r2122 w2121 mod2109))))))) tmp2111) ((lambda (_2126) (syntax-error (source-wrap1160 e2105 w2107 s2108 mod2109))) tmp2110))) (syntax-dispatch tmp2110 (quote (any #(each (any any)) any . each-any))))) e2105))) (global-extend1129 (quote core) (quote set!) (lambda (e2127 r2128 w2129 s2130 mod2131) ((lambda (tmp2132) ((lambda (tmp2133) (if (if tmp2133 (apply (lambda (_2134 id2135 val2136) (id?1131 id2135)) tmp2133) #f) (apply (lambda (_2137 id2138 val2139) (let ((val2140 (chi1167 val2139 r2128 w2129 mod2131)) (n2141 (id-var-name1153 id2138 w2129))) (let ((b2142 (lookup1128 n2141 r2128 mod2131))) (let ((t2143 (binding-type1123 b2142))) (if (memv t2143 (quote (lexical))) (build-annotated1108 s2130 (list (quote set!) (binding-value1124 b2142) val2140)) (if (memv t2143 (quote (global))) (build-annotated1108 s2130 (list (quote set!) (cond ((and mod2131 (not (car mod2131))) (make-module-ref (cdr mod2131) n2141 #t)) (else (make-module-ref mod2131 n2141 #f))) val2140)) (if (memv t2143 (quote (displaced-lexical))) (syntax-error (wrap1159 id2138 w2129 mod2131) "identifier out of context") (syntax-error (source-wrap1160 e2127 w2129 s2130 mod2131))))))))) tmp2133) ((lambda (tmp2144) (if tmp2144 (apply (lambda (_2145 head2146 tail2147 val2148) (call-with-values (lambda () (syntax-type1165 head2146 r2128 (quote (())) #f #f mod2131)) (lambda (type2149 value2150 ee2151 ww2152 ss2153 modmod2154) (let ((t2155 type2149)) (if (memv t2155 (quote (module-ref))) (let ((val2156 (chi1167 val2148 r2128 w2129 mod2131))) (call-with-values (lambda () (value2150 (cons head2146 tail2147))) (lambda (id2158 mod2159) (build-annotated1108 s2130 (list (quote set!) (cond ((and mod2159 (not (car mod2159))) (make-module-ref (cdr mod2159) id2158 #t)) (else (make-module-ref mod2159 id2158 #f))) val2156))))) (build-annotated1108 s2130 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2146) r2128 w2129 mod2131) (map (lambda (e2160) (chi1167 e2160 r2128 w2129 mod2131)) (append tail2147 (list val2148)))))))))) tmp2144) ((lambda (_2162) (syntax-error (source-wrap1160 e2127 w2129 s2130 mod2131))) tmp2132))) (syntax-dispatch tmp2132 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2132 (quote (any any any))))) e2127))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2163) ((lambda (tmp2164) ((lambda (tmp2165) (if (if tmp2165 (apply (lambda (_2166 mod2167 id2168) (and (andmap id?1131 mod2167) (id?1131 id2168))) tmp2165) #f) (apply (lambda (_2170 mod2171 id2172) (values (syntax-object->datum id2172) (syntax-object->datum (cons (quote #(syntax-object #f ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) mod2171)))) tmp2165) (syntax-error tmp2164))) (syntax-dispatch tmp2164 (quote (any each-any any))))) e2163))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2174) ((lambda (tmp2175) ((lambda (tmp2176) (if (if tmp2176 (apply (lambda (_2177 mod2178 id2179) (and (andmap id?1131 mod2178) (id?1131 id2179))) tmp2176) #f) (apply (lambda (_2181 mod2182 id2183) (values (syntax-object->datum id2183) (syntax-object->datum mod2182))) tmp2176) (syntax-error tmp2175))) (syntax-dispatch tmp2175 (quote (any each-any any))))) e2174))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2188 (lambda (x2189 keys2190 clauses2191 r2192 mod2193) (if (null? clauses2191) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2189)) ((lambda (tmp2194) ((lambda (tmp2195) (if tmp2195 (apply (lambda (pat2196 exp2197) (if (and (id?1131 pat2196) (andmap (lambda (x2198) (not (free-id=?1154 pat2196 x2198))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2190))) (let ((labels2199 (list (gen-label1136))) (var2200 (gen-var1179 pat2196))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2200) (chi1167 exp2197 (extend-env1125 labels2199 (list (cons (quote syntax) (cons var2200 0))) r2192) (make-binding-wrap1148 (list pat2196) labels2199 (quote (()))) mod2193))) x2189))) (gen-clause2187 x2189 keys2190 (cdr clauses2191) r2192 pat2196 #t exp2197 mod2193))) tmp2195) ((lambda (tmp2201) (if tmp2201 (apply (lambda (pat2202 fender2203 exp2204) (gen-clause2187 x2189 keys2190 (cdr clauses2191) r2192 pat2202 fender2203 exp2204 mod2193)) tmp2201) ((lambda (_2205) (syntax-error (car clauses2191) "invalid syntax-case clause")) tmp2194))) (syntax-dispatch tmp2194 (quote (any any any)))))) (syntax-dispatch tmp2194 (quote (any any))))) (car clauses2191))))) (gen-clause2187 (lambda (x2206 keys2207 clauses2208 r2209 pat2210 fender2211 exp2212 mod2213) (call-with-values (lambda () (convert-pattern2185 pat2210 keys2207)) (lambda (p2214 pvars2215) (cond ((not (distinct-bound-ids?1157 (map car pvars2215))) (syntax-error pat2210 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2216) (not (ellipsis?1176 (car x2216)))) pvars2215)) (syntax-error pat2210 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2217 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2217) (let ((y2218 (build-annotated1108 #f y2217))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2219) ((lambda (tmp2220) (if tmp2220 (apply (lambda () y2218) tmp2220) ((lambda (_2221) (build-annotated1108 #f (list (quote if) y2218 (build-dispatch-call2186 pvars2215 fender2211 y2218 r2209 mod2213) (build-data1109 #f #f)))) tmp2219))) (syntax-dispatch tmp2219 (quote #(atom #t))))) fender2211) (build-dispatch-call2186 pvars2215 exp2212 y2218 r2209 mod2213) (gen-syntax-case2188 x2206 keys2207 clauses2208 r2209 mod2213)))))) (if (eq? p2214 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2206)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2206 (build-data1109 #f p2214))))))))))))) (build-dispatch-call2186 (lambda (pvars2222 exp2223 y2224 r2225 mod2226) (let ((ids2227 (map car pvars2222)) (levels2228 (map cdr pvars2222))) (let ((labels2229 (gen-labels1137 ids2227)) (new-vars2230 (map gen-var1179 ids2227))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2230 (chi1167 exp2223 (extend-env1125 labels2229 (map (lambda (var2231 level2232) (cons (quote syntax) (cons var2231 level2232))) new-vars2230 (map cdr pvars2222)) r2225) (make-binding-wrap1148 ids2227 labels2229 (quote (()))) mod2226))) y2224)))))) (convert-pattern2185 (lambda (pattern2233 keys2234) (let cvt2235 ((p2236 pattern2233) (n2237 0) (ids2238 (quote ()))) (if (id?1131 p2236) (if (bound-id-member?1158 p2236 keys2234) (values (vector (quote free-id) p2236) ids2238) (values (quote any) (cons (cons p2236 n2237) ids2238))) ((lambda (tmp2239) ((lambda (tmp2240) (if (if tmp2240 (apply (lambda (x2241 dots2242) (ellipsis?1176 dots2242)) tmp2240) #f) (apply (lambda (x2243 dots2244) (call-with-values (lambda () (cvt2235 x2243 (fx+1098 n2237 1) ids2238)) (lambda (p2245 ids2246) (values (if (eq? p2245 (quote any)) (quote each-any) (vector (quote each) p2245)) ids2246)))) tmp2240) ((lambda (tmp2247) (if tmp2247 (apply (lambda (x2248 y2249) (call-with-values (lambda () (cvt2235 y2249 n2237 ids2238)) (lambda (y2250 ids2251) (call-with-values (lambda () (cvt2235 x2248 n2237 ids2251)) (lambda (x2252 ids2253) (values (cons x2252 y2250) ids2253)))))) tmp2247) ((lambda (tmp2254) (if tmp2254 (apply (lambda () (values (quote ()) ids2238)) tmp2254) ((lambda (tmp2255) (if tmp2255 (apply (lambda (x2256) (call-with-values (lambda () (cvt2235 x2256 n2237 ids2238)) (lambda (p2258 ids2259) (values (vector (quote vector) p2258) ids2259)))) tmp2255) ((lambda (x2260) (values (vector (quote atom) (strip1178 p2236 (quote (())))) ids2238)) tmp2239))) (syntax-dispatch tmp2239 (quote #(vector each-any)))))) (syntax-dispatch tmp2239 (quote ()))))) (syntax-dispatch tmp2239 (quote (any . any)))))) (syntax-dispatch tmp2239 (quote (any any))))) p2236)))))) (lambda (e2261 r2262 w2263 s2264 mod2265) (let ((e2266 (source-wrap1160 e2261 w2263 s2264 mod2265))) ((lambda (tmp2267) ((lambda (tmp2268) (if tmp2268 (apply (lambda (_2269 val2270 key2271 m2272) (if (andmap (lambda (x2273) (and (id?1131 x2273) (not (ellipsis?1176 x2273)))) key2271) (let ((x2275 (gen-var1179 (quote tmp)))) (build-annotated1108 s2264 (list (build-annotated1108 #f (list (quote lambda) (list x2275) (gen-syntax-case2188 (build-annotated1108 #f x2275) key2271 m2272 r2262 mod2265))) (chi1167 val2270 r2262 (quote (())) mod2265)))) (syntax-error e2266 "invalid literals list in"))) tmp2268) (syntax-error tmp2267))) (syntax-dispatch tmp2267 (quote (any any each-any . each-any))))) e2266))))) (set! sc-expand (let ((m2278 (quote e)) (esew2279 (quote (eval)))) (lambda (x2280) (if (and (pair? x2280) (equal? (car x2280) noexpand1097)) (cadr x2280) (chi-top1166 x2280 (quote ()) (quote ((top))) m2278 esew2279 (module-name (current-module))))))) (set! sc-expand3 (let ((m2281 (quote e)) (esew2282 (quote (eval)))) (lambda (x2284 . rest2283) (if (and (pair? x2284) (equal? (car x2284) noexpand1097)) (cadr x2284) (chi-top1166 x2284 (quote ()) (quote ((top))) (if (null? rest2283) m2281 (car rest2283)) (if (or (null? rest2283) (null? (cdr rest2283))) esew2282 (cadr rest2283)) (module-name (current-module))))))) (set! identifier? (lambda (x2285) (nonsymbol-id?1130 x2285))) (set! datum->syntax-object (lambda (id2286 datum2287) (make-syntax-object1114 datum2287 (syntax-object-wrap1117 id2286) #f))) (set! syntax-object->datum (lambda (x2288) (strip1178 x2288 (quote (()))))) (set! generate-temporaries (lambda (ls2289) (begin (let ((x2290 ls2289)) (if (not (list? x2290)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2290))) (map (lambda (x2291) (wrap1159 (gensym) (quote ((top))) #f)) ls2289)))) (set! free-identifier=? (lambda (x2292 y2293) (begin (let ((x2294 x2292)) (if (not (nonsymbol-id?1130 x2294)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2294))) (let ((x2295 y2293)) (if (not (nonsymbol-id?1130 x2295)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2295))) (free-id=?1154 x2292 y2293)))) (set! bound-identifier=? (lambda (x2296 y2297) (begin (let ((x2298 x2296)) (if (not (nonsymbol-id?1130 x2298)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2298))) (let ((x2299 y2297)) (if (not (nonsymbol-id?1130 x2299)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2299))) (bound-id=?1155 x2296 y2297)))) (set! syntax-error (lambda (object2301 . messages2300) (begin (for-each (lambda (x2302) (let ((x2303 x2302)) (if (not (string? x2303)) (error-hook1104 (quote syntax-error) "invalid argument" x2303)))) messages2300) (let ((message2304 (if (null? messages2300) "invalid syntax" (apply string-append messages2300)))) (error-hook1104 #f message2304 (strip1178 object2301 (quote (())))))))) (set! install-global-transformer (lambda (sym2305 v2306) (begin (let ((x2307 sym2305)) (if (not (symbol? x2307)) (error-hook1104 (quote define-syntax) "invalid argument" x2307))) (let ((x2308 v2306)) (if (not (procedure? x2308)) (error-hook1104 (quote define-syntax) "invalid argument" x2308))) (global-extend1129 (quote macro) sym2305 v2306)))) (letrec ((match2313 (lambda (e2314 p2315 w2316 r2317 mod2318) (cond ((not r2317) #f) ((eq? p2315 (quote any)) (cons (wrap1159 e2314 w2316 mod2318) r2317)) ((syntax-object?1115 e2314) (match*2312 (let ((e2319 (syntax-object-expression1116 e2314))) (if (annotation? e2319) (annotation-expression e2319) e2319)) p2315 (join-wraps1150 w2316 (syntax-object-wrap1117 e2314)) r2317 (syntax-object-module1118 e2314))) (else (match*2312 (let ((e2320 e2314)) (if (annotation? e2320) (annotation-expression e2320) e2320)) p2315 w2316 r2317 mod2318))))) (match*2312 (lambda (e2321 p2322 w2323 r2324 mod2325) (cond ((null? p2322) (and (null? e2321) r2324)) ((pair? p2322) (and (pair? e2321) (match2313 (car e2321) (car p2322) w2323 (match2313 (cdr e2321) (cdr p2322) w2323 r2324 mod2325) mod2325))) ((eq? p2322 (quote each-any)) (let ((l2326 (match-each-any2310 e2321 w2323 mod2325))) (and l2326 (cons l2326 r2324)))) (else (let ((t2327 (vector-ref p2322 0))) (if (memv t2327 (quote (each))) (if (null? e2321) (match-empty2311 (vector-ref p2322 1) r2324) (let ((l2328 (match-each2309 e2321 (vector-ref p2322 1) w2323 mod2325))) (and l2328 (let collect2329 ((l2330 l2328)) (if (null? (car l2330)) r2324 (cons (map car l2330) (collect2329 (map cdr l2330)))))))) (if (memv t2327 (quote (free-id))) (and (id?1131 e2321) (free-id=?1154 (wrap1159 e2321 w2323 mod2325) (vector-ref p2322 1)) r2324) (if (memv t2327 (quote (atom))) (and (equal? (vector-ref p2322 1) (strip1178 e2321 w2323)) r2324) (if (memv t2327 (quote (vector))) (and (vector? e2321) (match2313 (vector->list e2321) (vector-ref p2322 1) w2323 r2324 mod2325))))))))))) (match-empty2311 (lambda (p2331 r2332) (cond ((null? p2331) r2332) ((eq? p2331 (quote any)) (cons (quote ()) r2332)) ((pair? p2331) (match-empty2311 (car p2331) (match-empty2311 (cdr p2331) r2332))) ((eq? p2331 (quote each-any)) (cons (quote ()) r2332)) (else (let ((t2333 (vector-ref p2331 0))) (if (memv t2333 (quote (each))) (match-empty2311 (vector-ref p2331 1) r2332) (if (memv t2333 (quote (free-id atom))) r2332 (if (memv t2333 (quote (vector))) (match-empty2311 (vector-ref p2331 1) r2332))))))))) (match-each-any2310 (lambda (e2334 w2335 mod2336) (cond ((annotation? e2334) (match-each-any2310 (annotation-expression e2334) w2335 mod2336)) ((pair? e2334) (let ((l2337 (match-each-any2310 (cdr e2334) w2335 mod2336))) (and l2337 (cons (wrap1159 (car e2334) w2335 mod2336) l2337)))) ((null? e2334) (quote ())) ((syntax-object?1115 e2334) (match-each-any2310 (syntax-object-expression1116 e2334) (join-wraps1150 w2335 (syntax-object-wrap1117 e2334)) mod2336)) (else #f)))) (match-each2309 (lambda (e2338 p2339 w2340 mod2341) (cond ((annotation? e2338) (match-each2309 (annotation-expression e2338) p2339 w2340 mod2341)) ((pair? e2338) (let ((first2342 (match2313 (car e2338) p2339 w2340 (quote ()) mod2341))) (and first2342 (let ((rest2343 (match-each2309 (cdr e2338) p2339 w2340 mod2341))) (and rest2343 (cons first2342 rest2343)))))) ((null? e2338) (quote ())) ((syntax-object?1115 e2338) (match-each2309 (syntax-object-expression1116 e2338) p2339 (join-wraps1150 w2340 (syntax-object-wrap1117 e2338)) (syntax-object-module1118 e2338))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2344 p2345) (cond ((eq? p2345 (quote any)) (list e2344)) ((syntax-object?1115 e2344) (match*2312 (let ((e2346 (syntax-object-expression1116 e2344))) (if (annotation? e2346) (annotation-expression e2346) e2346)) p2345 (syntax-object-wrap1117 e2344) (quote ()) (syntax-object-module1118 e2344))) (else (match*2312 (let ((e2347 e2344)) (if (annotation? e2347) (annotation-expression e2347) e2347)) p2345 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) +(install-global-transformer (quote with-syntax) (lambda (x2348) ((lambda (tmp2349) ((lambda (tmp2350) (if tmp2350 (apply (lambda (_2351 e12352 e22353) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12352 e22353))) tmp2350) ((lambda (tmp2355) (if tmp2355 (apply (lambda (_2356 out2357 in2358 e12359 e22360) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2358 (quote ()) (list out2357 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12359 e22360))))) tmp2355) ((lambda (tmp2362) (if tmp2362 (apply (lambda (_2363 out2364 in2365 e12366 e22367) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2365) (quote ()) (list out2364 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12366 e22367))))) tmp2362) (syntax-error tmp2349))) (syntax-dispatch tmp2349 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2349 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2349 (quote (any () any . each-any))))) x2348))) +(install-global-transformer (quote syntax-rules) (lambda (x2371) ((lambda (tmp2372) ((lambda (tmp2373) (if tmp2373 (apply (lambda (_2374 k2375 keyword2376 pattern2377 template2378) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2375 (map (lambda (tmp2381 tmp2380) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2380) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2381))) template2378 pattern2377)))))) tmp2373) (syntax-error tmp2372))) (syntax-dispatch tmp2372 (quote (any each-any . #(each ((any . any) any))))))) x2371))) +(install-global-transformer (quote let*) (lambda (x2382) ((lambda (tmp2383) ((lambda (tmp2384) (if (if tmp2384 (apply (lambda (let*2385 x2386 v2387 e12388 e22389) (andmap identifier? x2386)) tmp2384) #f) (apply (lambda (let*2391 x2392 v2393 e12394 e22395) (let f2396 ((bindings2397 (map list x2392 v2393))) (if (null? bindings2397) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12394 e22395))) ((lambda (tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (body2403 binding2404) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2404) body2403)) tmp2402) (syntax-error tmp2401))) (syntax-dispatch tmp2401 (quote (any any))))) (list (f2396 (cdr bindings2397)) (car bindings2397)))))) tmp2384) (syntax-error tmp2383))) (syntax-dispatch tmp2383 (quote (any #(each (any any)) any . each-any))))) x2382))) +(install-global-transformer (quote do) (lambda (orig-x2405) ((lambda (tmp2406) ((lambda (tmp2407) (if tmp2407 (apply (lambda (_2408 var2409 init2410 step2411 e02412 e12413 c2414) ((lambda (tmp2415) ((lambda (tmp2416) (if tmp2416 (apply (lambda (step2417) ((lambda (tmp2418) ((lambda (tmp2419) (if tmp2419 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2409 init2410) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02412) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2414 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2417))))))) tmp2419) ((lambda (tmp2424) (if tmp2424 (apply (lambda (e12425 e22426) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2409 init2410) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02412 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12425 e22426)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2414 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2417))))))) tmp2424) (syntax-error tmp2418))) (syntax-dispatch tmp2418 (quote (any . each-any)))))) (syntax-dispatch tmp2418 (quote ())))) e12413)) tmp2416) (syntax-error tmp2415))) (syntax-dispatch tmp2415 (quote each-any)))) (map (lambda (v2433 s2434) ((lambda (tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda () v2433) tmp2436) ((lambda (tmp2437) (if tmp2437 (apply (lambda (e2438) e2438) tmp2437) ((lambda (_2439) (syntax-error orig-x2405)) tmp2435))) (syntax-dispatch tmp2435 (quote (any)))))) (syntax-dispatch tmp2435 (quote ())))) s2434)) var2409 step2411))) tmp2407) (syntax-error tmp2406))) (syntax-dispatch tmp2406 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2405))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2442 (lambda (x2446 y2447) ((lambda (tmp2448) ((lambda (tmp2449) (if tmp2449 (apply (lambda (x2450 y2451) ((lambda (tmp2452) ((lambda (tmp2453) (if tmp2453 (apply (lambda (dy2454) ((lambda (tmp2455) ((lambda (tmp2456) (if tmp2456 (apply (lambda (dx2457) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2457 dy2454))) tmp2456) ((lambda (_2458) (if (null? dy2454) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2450) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2450 y2451))) tmp2455))) (syntax-dispatch tmp2455 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2450)) tmp2453) ((lambda (tmp2459) (if tmp2459 (apply (lambda (stuff2460) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2450 stuff2460))) tmp2459) ((lambda (else2461) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2450 y2451)) tmp2452))) (syntax-dispatch tmp2452 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2452 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2451)) tmp2449) (syntax-error tmp2448))) (syntax-dispatch tmp2448 (quote (any any))))) (list x2446 y2447)))) (quasiappend2443 (lambda (x2462 y2463) ((lambda (tmp2464) ((lambda (tmp2465) (if tmp2465 (apply (lambda (x2466 y2467) ((lambda (tmp2468) ((lambda (tmp2469) (if tmp2469 (apply (lambda () x2466) tmp2469) ((lambda (_2470) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2466 y2467)) tmp2468))) (syntax-dispatch tmp2468 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2467)) tmp2465) (syntax-error tmp2464))) (syntax-dispatch tmp2464 (quote (any any))))) (list x2462 y2463)))) (quasivector2444 (lambda (x2471) ((lambda (tmp2472) ((lambda (x2473) ((lambda (tmp2474) ((lambda (tmp2475) (if tmp2475 (apply (lambda (x2476) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2476))) tmp2475) ((lambda (tmp2478) (if tmp2478 (apply (lambda (x2479) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2479)) tmp2478) ((lambda (_2481) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2473)) tmp2474))) (syntax-dispatch tmp2474 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2474 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2473)) tmp2472)) x2471))) (quasi2445 (lambda (p2482 lev2483) ((lambda (tmp2484) ((lambda (tmp2485) (if tmp2485 (apply (lambda (p2486) (if (= lev2483 0) p2486 (quasicons2442 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2445 (list p2486) (- lev2483 1))))) tmp2485) ((lambda (tmp2487) (if tmp2487 (apply (lambda (p2488 q2489) (if (= lev2483 0) (quasiappend2443 p2488 (quasi2445 q2489 lev2483)) (quasicons2442 (quasicons2442 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2445 (list p2488) (- lev2483 1))) (quasi2445 q2489 lev2483)))) tmp2487) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491) (quasicons2442 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2445 (list p2491) (+ lev2483 1)))) tmp2490) ((lambda (tmp2492) (if tmp2492 (apply (lambda (p2493 q2494) (quasicons2442 (quasi2445 p2493 lev2483) (quasi2445 q2494 lev2483))) tmp2492) ((lambda (tmp2495) (if tmp2495 (apply (lambda (x2496) (quasivector2444 (quasi2445 x2496 lev2483))) tmp2495) ((lambda (p2498) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2498)) tmp2484))) (syntax-dispatch tmp2484 (quote #(vector each-any)))))) (syntax-dispatch tmp2484 (quote (any . any)))))) (syntax-dispatch tmp2484 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2484 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2484 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2482)))) (lambda (x2499) ((lambda (tmp2500) ((lambda (tmp2501) (if tmp2501 (apply (lambda (_2502 e2503) (quasi2445 e2503 0)) tmp2501) (syntax-error tmp2500))) (syntax-dispatch tmp2500 (quote (any any))))) x2499)))) +(install-global-transformer (quote include) (lambda (x2504) (letrec ((read-file2505 (lambda (fn2506 k2507) (let ((p2508 (open-input-file fn2506))) (let f2509 ((x2510 (read p2508))) (if (eof-object? x2510) (begin (close-input-port p2508) (quote ())) (cons (datum->syntax-object k2507 x2510) (f2509 (read p2508))))))))) ((lambda (tmp2511) ((lambda (tmp2512) (if tmp2512 (apply (lambda (k2513 filename2514) (let ((fn2515 (syntax-object->datum filename2514))) ((lambda (tmp2516) ((lambda (tmp2517) (if tmp2517 (apply (lambda (exp2518) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2518)) tmp2517) (syntax-error tmp2516))) (syntax-dispatch tmp2516 (quote each-any)))) (read-file2505 fn2515 k2513)))) tmp2512) (syntax-error tmp2511))) (syntax-dispatch tmp2511 (quote (any any))))) x2504)))) +(install-global-transformer (quote unquote) (lambda (x2520) ((lambda (tmp2521) ((lambda (tmp2522) (if tmp2522 (apply (lambda (_2523 e2524) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2524))) tmp2522) (syntax-error tmp2521))) (syntax-dispatch tmp2521 (quote (any any))))) x2520))) +(install-global-transformer (quote unquote-splicing) (lambda (x2525) ((lambda (tmp2526) ((lambda (tmp2527) (if tmp2527 (apply (lambda (_2528 e2529) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2529))) tmp2527) (syntax-error tmp2526))) (syntax-dispatch tmp2526 (quote (any any))))) x2525))) +(install-global-transformer (quote case) (lambda (x2530) ((lambda (tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534 m12535 m22536) ((lambda (tmp2537) ((lambda (body2538) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2534)) body2538)) tmp2537)) (let f2539 ((clause2540 m12535) (clauses2541 m22536)) (if (null? clauses2541) ((lambda (tmp2543) ((lambda (tmp2544) (if tmp2544 (apply (lambda (e12545 e22546) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12545 e22546))) tmp2544) ((lambda (tmp2548) (if tmp2548 (apply (lambda (k2549 e12550 e22551) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2549)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12550 e22551)))) tmp2548) ((lambda (_2554) (syntax-error x2530)) tmp2543))) (syntax-dispatch tmp2543 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2543 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2540) ((lambda (tmp2555) ((lambda (rest2556) ((lambda (tmp2557) ((lambda (tmp2558) (if tmp2558 (apply (lambda (k2559 e12560 e22561) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12560 e22561)) rest2556)) tmp2558) ((lambda (_2564) (syntax-error x2530)) tmp2557))) (syntax-dispatch tmp2557 (quote (each-any any . each-any))))) clause2540)) tmp2555)) (f2539 (car clauses2541) (cdr clauses2541))))))) tmp2532) (syntax-error tmp2531))) (syntax-dispatch tmp2531 (quote (any any any . each-any))))) x2530))) +(install-global-transformer (quote identifier-syntax) (lambda (x2565) ((lambda (tmp2566) ((lambda (tmp2567) (if tmp2567 (apply (lambda (_2568 e2569) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2569)) (list (cons _2568 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2569 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2567) (syntax-error tmp2566))) (syntax-dispatch tmp2566 (quote (any any))))) x2565))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 2deca5762..6d7ab1780 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -406,14 +406,20 @@ (define-syntax build-global-reference (syntax-rules () ((_ source var mod) - (build-annotated source - (make-module-ref mod var #f))))) + (cond + ((and mod (not (car mod))) + (build-annotated source (make-module-ref (cdr mod) var #t))) + (else + (build-annotated source (make-module-ref mod var #f))))))) (define-syntax build-global-assignment (syntax-rules () ((_ source var exp mod) (build-annotated source - `(set! ,(make-module-ref mod var #f) ,exp))))) + `(set! ,(cond + ((and mod (not (car mod))) (make-module-ref (cdr mod) var #t)) + (else (make-module-ref mod var #f))) + ,exp))))) (define-syntax build-global-definition (syntax-rules () @@ -1801,12 +1807,12 @@ (global-extend 'module-ref '@ (lambda (e) - (syntax-case e (%module-public-interface) + (syntax-case e () ((_ (mod ...) id) (and (andmap id? (syntax (mod ...))) (id? (syntax id))) (values (syntax-object->datum (syntax id)) (syntax-object->datum - (syntax (mod ... %module-public-interface)))))))) + (syntax (#f mod ...)))))))) (global-extend 'module-ref '@@ (lambda (e) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 45d6c204f..689770e8f 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -114,9 +114,6 @@ (cond ((hashq-ref *translate-table* val)) - ((primitive-macro? val) - (syntax-error #f "unhandled primitive macro" head)) - ((macro? val) (syntax-error #f "unknown kind of macro" head)) From a2716cbe1e9d2b43d1fb1a017cb8b1e97617da3c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 13:13:29 +0200 Subject: [PATCH 068/375] only bend hygiene in macro-introduced output, not for explicit @/@@ * module/ice-9/psyntax.scm * module/ice-9/psyntax-pp.scm * module/ice-9/boot-9.scm (make-module-ref): We were so almost there with what we had, sniff. The deal is that (begin (load "foo.scm") ((@@ (foo) bar))) would expand to (begin (load "foo.scm") (bar)) because bar was unbound at expansion time, and make-module-ref assumed it was like the else in a cond. But it shouldn't have, because we /explicitly/ asked for the @@ var -- so now if we see a @ or @@, we never drop it. @@ introduced by hygiene can be dropped if it doesn't reference a var, though. Practically speaking, this means tagging all modules in psyntax with their intent: public or private (corresponding to @ or @@), hygiene (introduced by a macro), or bare (when we don't have a module). I'm not sure when we'd see a bare. The implementation is complicated by the need to support the old format and the new format at the same time, so that psyntax-pp can be regenerated. --- module/ice-9/boot-9.scm | 22 +++++++++------ module/ice-9/psyntax-pp.scm | 22 +++++++-------- module/ice-9/psyntax.scm | 55 ++++++++++++++++++------------------- 3 files changed, 50 insertions(+), 49 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index feb5c3e48..d9e7e5d0c 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -132,15 +132,19 @@ (define (module-add! module sym var) (hashq-set! (%get-pre-modules-obarray) sym var)) (define sc-macro 'sc-macro) -(define (make-module-ref mod var public?) - (cond - ((or (not mod) - (equal? mod (module-name (current-module))) - (and (not public?) - (not (module-variable (resolve-module mod) var)))) - var) - (else - (list (if public? '@ '@@) mod var)))) +(define (make-module-ref mod var kind) + (case kind + ((public #t) (if mod `(@ ,mod ,var) var)) + ((private #f) (if (and mod (not (equal? mod (module-name (current-module))))) + `(@@ ,mod ,var) + var)) + ((bare) var) + ((hygiene) (if (and mod + (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + `(@@ ,mod ,var) + var)) + (else (error "foo" mod var kind)))) (define (resolve-module . args) #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 54261e1fa..dd838c202 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (module-name (procedure-module p1510))))))) ((vector? x1517) (let ((n1522 (vector-length x1517))) (let ((v1523 (make-vector n1522))) (let doloop1524 ((i1525 0)) (if (fx=1100 i1525 n1522) v1523 (begin (vector-set! v1523 i1525 (rebuild-macro-output1516 (vector-ref x1517 i1525) m1518)) (doloop1524 (fx+1098 i1525 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1526 e1527 r1528 w1529 s1530 mod1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (e01534 e11535) (build-annotated1108 s1530 (cons x1526 (map (lambda (e1536) (chi1167 e1536 r1528 w1529 mod1531)) e11535)))) tmp1533) (syntax-error tmp1532))) (syntax-dispatch tmp1532 (quote (any . each-any))))) e1527))) (chi-expr1168 (lambda (type1538 value1539 e1540 r1541 w1542 s1543 mod1544) (let ((t1545 type1538)) (if (memv t1545 (quote (lexical))) (build-annotated1108 s1543 value1539) (if (memv t1545 (quote (core external-macro))) (value1539 e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (module-ref))) (call-with-values (lambda () (value1539 e1540)) (lambda (id1546 mod1547) (cond ((and mod1547 (not (car mod1547))) (build-annotated1108 s1543 (make-module-ref (cdr mod1547) id1546 #t))) (else (build-annotated1108 s1543 (make-module-ref mod1547 id1546 #f)))))) (if (memv t1545 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) value1539) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (global-call))) (chi-application1169 (cond ((and (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) (not (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)))) (build-annotated1108 (source-annotation1122 (car e1540)) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 #t))) (else (build-annotated1108 (source-annotation1122 (car e1540)) (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 #f)))) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (constant))) (build-data1109 s1543 (strip1178 (source-wrap1160 e1540 w1542 s1543 mod1544) (quote (())))) (if (memv t1545 (quote (global))) (cond ((and mod1544 (not (car mod1544))) (build-annotated1108 s1543 (make-module-ref (cdr mod1544) value1539 #t))) (else (build-annotated1108 s1543 (make-module-ref mod1544 value1539 #f)))) (if (memv t1545 (quote (call))) (chi-application1169 (chi1167 (car e1540) r1541 w1542 mod1544) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (begin-form))) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (_1550 e11551 e21552) (chi-sequence1161 (cons e11551 e21552) r1541 w1542 s1543 mod1544)) tmp1549) (syntax-error tmp1548))) (syntax-dispatch tmp1548 (quote (any any . each-any))))) e1540) (if (memv t1545 (quote (local-syntax-form))) (chi-local-syntax1173 value1539 e1540 r1541 w1542 s1543 mod1544 chi-sequence1161) (if (memv t1545 (quote (eval-when-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 x1557 e11558 e21559) (let ((when-list1560 (chi-when-list1164 e1540 x1557 w1542))) (if (memq (quote eval) when-list1560) (chi-sequence1161 (cons e11558 e21559) r1541 w1542 s1543 mod1544) (chi-void1175)))) tmp1555) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any each-any any . each-any))))) e1540) (if (memv t1545 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1539 w1542 mod1544) "invalid context for definition of") (if (memv t1545 (quote (syntax))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to pattern variable outside syntax form") (if (memv t1545 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544))))))))))))))))))) (chi1167 (lambda (e1563 r1564 w1565 mod1566) (call-with-values (lambda () (syntax-type1165 e1563 r1564 w1565 #f #f mod1566)) (lambda (type1567 value1568 e1569 w1570 s1571 mod1572) (chi-expr1168 type1567 value1568 e1569 r1564 w1570 s1571 mod1572))))) (chi-top1166 (lambda (e1573 r1574 w1575 m1576 esew1577 mod1578) (call-with-values (lambda () (syntax-type1165 e1573 r1574 w1575 #f #f mod1578)) (lambda (type1586 value1587 e1588 w1589 s1590 mod1591) (let ((t1592 type1586)) (if (memv t1592 (quote (begin-form))) ((lambda (tmp1593) ((lambda (tmp1594) (if tmp1594 (apply (lambda (_1595) (chi-void1175)) tmp1594) ((lambda (tmp1596) (if tmp1596 (apply (lambda (_1597 e11598 e21599) (chi-top-sequence1162 (cons e11598 e21599) r1574 w1589 s1590 m1576 esew1577 mod1591)) tmp1596) (syntax-error tmp1593))) (syntax-dispatch tmp1593 (quote (any any . each-any)))))) (syntax-dispatch tmp1593 (quote (any))))) e1588) (if (memv t1592 (quote (local-syntax-form))) (chi-local-syntax1173 value1587 e1588 r1574 w1589 s1590 mod1591 (lambda (body1601 r1602 w1603 s1604 mod1605) (chi-top-sequence1162 body1601 r1602 w1603 s1604 m1576 esew1577 mod1605))) (if (memv t1592 (quote (eval-when-form))) ((lambda (tmp1606) ((lambda (tmp1607) (if tmp1607 (apply (lambda (_1608 x1609 e11610 e21611) (let ((when-list1612 (chi-when-list1164 e1588 x1609 w1589)) (body1613 (cons e11610 e21611))) (cond ((eq? m1576 (quote e)) (if (memq (quote eval) when-list1612) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) (chi-void1175))) ((memq (quote load) when-list1612) (if (or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c&e) (quote (compile load)) mod1591) (if (memq m1576 (quote (c c&e))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c) (quote (load)) mod1591) (chi-void1175)))) ((or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (top-level-eval-hook1102 (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) mod1591) (chi-void1175)) (else (chi-void1175))))) tmp1607) (syntax-error tmp1606))) (syntax-dispatch tmp1606 (quote (any each-any any . each-any))))) e1588) (if (memv t1592 (quote (define-syntax-form))) (let ((n1616 (id-var-name1153 value1587 w1589)) (r1617 (macros-only-env1127 r1574))) (let ((t1618 m1576)) (if (memv t1618 (quote (c))) (if (memq (quote compile) esew1577) (let ((e1619 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1619 mod1591) (if (memq (quote load) esew1577) e1619 (chi-void1175)))) (if (memq (quote load) esew1577) (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) (chi-void1175))) (if (memv t1618 (quote (c&e))) (let ((e1620 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1620 mod1591) e1620)) (begin (if (memq (quote eval) esew1577) (top-level-eval-hook1102 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) mod1591)) (chi-void1175)))))) (if (memv t1592 (quote (define-form))) (let ((n1621 (id-var-name1153 value1587 w1589))) (let ((type1622 (binding-type1123 (lookup1128 n1621 r1574 mod1591)))) (let ((t1623 type1622)) (if (memv t1623 (quote (global))) (let ((x1624 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1624 mod1591)) x1624)) (if (memv t1623 (quote (displaced-lexical))) (syntax-error (wrap1159 value1587 w1589 mod1591) "identifier out of context") (if (memv t1623 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1621 mod1591) (let ((x1625 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1625 mod1591)) x1625))) (syntax-error (wrap1159 value1587 w1589 mod1591) "cannot define keyword at top level"))))))) (let ((x1626 (chi-expr1168 type1586 value1587 e1588 r1574 w1589 s1590 mod1591))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1626 mod1591)) x1626)))))))))))) (syntax-type1165 (lambda (e1627 r1628 w1629 s1630 rib1631 mod1632) (cond ((symbol? e1627) (let ((n1633 (id-var-name1153 e1627 w1629))) (let ((b1634 (lookup1128 n1633 r1628 mod1632))) (let ((type1635 (binding-type1123 b1634))) (let ((t1636 type1635)) (if (memv t1636 (quote (lexical))) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (global))) (values type1635 n1633 e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1634) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632))))))))) ((pair? e1627) (let ((first1637 (car e1627))) (if (id?1131 first1637) (let ((n1638 (id-var-name1153 first1637 w1629))) (let ((b1639 (lookup1128 n1638 r1628 (or (and (syntax-object?1115 first1637) (syntax-object-module1118 first1637)) mod1632)))) (let ((type1640 (binding-type1123 b1639))) (let ((t1641 type1640)) (if (memv t1641 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (global))) (values (quote global-call) n1638 e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1639) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (if (memv t1641 (quote (core external-macro module-ref))) (values type1640 (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (begin))) (values (quote begin-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (eval-when))) (values (quote eval-when-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (define))) ((lambda (tmp1642) ((lambda (tmp1643) (if (if tmp1643 (apply (lambda (_1644 name1645 val1646) (id?1131 name1645)) tmp1643) #f) (apply (lambda (_1647 name1648 val1649) (values (quote define-form) name1648 val1649 w1629 s1630 mod1632)) tmp1643) ((lambda (tmp1650) (if (if tmp1650 (apply (lambda (_1651 name1652 args1653 e11654 e21655) (and (id?1131 name1652) (valid-bound-ids?1156 (lambda-var-list1180 args1653)))) tmp1650) #f) (apply (lambda (_1656 name1657 args1658 e11659 e21660) (values (quote define-form) (wrap1159 name1657 w1629 mod1632) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1159 (cons args1658 (cons e11659 e21660)) w1629 mod1632)) (quote (())) s1630 mod1632)) tmp1650) ((lambda (tmp1662) (if (if tmp1662 (apply (lambda (_1663 name1664) (id?1131 name1664)) tmp1662) #f) (apply (lambda (_1665 name1666) (values (quote define-form) (wrap1159 name1666 w1629 mod1632) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1630 mod1632)) tmp1662) (syntax-error tmp1642))) (syntax-dispatch tmp1642 (quote (any any)))))) (syntax-dispatch tmp1642 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1642 (quote (any any any))))) e1627) (if (memv t1641 (quote (define-syntax))) ((lambda (tmp1667) ((lambda (tmp1668) (if (if tmp1668 (apply (lambda (_1669 name1670 val1671) (id?1131 name1670)) tmp1668) #f) (apply (lambda (_1672 name1673 val1674) (values (quote define-syntax-form) name1673 val1674 w1629 s1630 mod1632)) tmp1668) (syntax-error tmp1667))) (syntax-dispatch tmp1667 (quote (any any any))))) e1627) (values (quote call) #f e1627 w1629 s1630 mod1632)))))))))))))) (values (quote call) #f e1627 w1629 s1630 mod1632)))) ((syntax-object?1115 e1627) (syntax-type1165 (syntax-object-expression1116 e1627) r1628 (join-wraps1150 w1629 (syntax-object-wrap1117 e1627)) #f rib1631 (or (syntax-object-module1118 e1627) mod1632))) ((annotation? e1627) (syntax-type1165 (annotation-expression e1627) r1628 w1629 (annotation-source e1627) rib1631 mod1632)) ((self-evaluating? e1627) (values (quote constant) #f e1627 w1629 s1630 mod1632)) (else (values (quote other) #f e1627 w1629 s1630 mod1632))))) (chi-when-list1164 (lambda (e1675 when-list1676 w1677) (let f1678 ((when-list1679 when-list1676) (situations1680 (quote ()))) (if (null? when-list1679) situations1680 (f1678 (cdr when-list1679) (cons (let ((x1681 (car when-list1679))) (cond ((free-id=?1154 x1681 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1154 x1681 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1154 x1681 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1159 x1681 w1677 #f) "invalid eval-when situation")))) situations1680)))))) (chi-install-global1163 (lambda (name1682 e1683) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1682) e1683)))) (chi-top-sequence1162 (lambda (body1684 r1685 w1686 s1687 m1688 esew1689 mod1690) (build-sequence1110 s1687 (let dobody1691 ((body1692 body1684) (r1693 r1685) (w1694 w1686) (m1695 m1688) (esew1696 esew1689) (mod1697 mod1690)) (if (null? body1692) (quote ()) (let ((first1698 (chi-top1166 (car body1692) r1693 w1694 m1695 esew1696 mod1697))) (cons first1698 (dobody1691 (cdr body1692) r1693 w1694 m1695 esew1696 mod1697)))))))) (chi-sequence1161 (lambda (body1699 r1700 w1701 s1702 mod1703) (build-sequence1110 s1702 (let dobody1704 ((body1705 body1699) (r1706 r1700) (w1707 w1701) (mod1708 mod1703)) (if (null? body1705) (quote ()) (let ((first1709 (chi1167 (car body1705) r1706 w1707 mod1708))) (cons first1709 (dobody1704 (cdr body1705) r1706 w1707 mod1708)))))))) (source-wrap1160 (lambda (x1710 w1711 s1712 defmod1713) (wrap1159 (if s1712 (make-annotation x1710 s1712 #f) x1710) w1711 defmod1713))) (wrap1159 (lambda (x1714 w1715 defmod1716) (cond ((and (null? (wrap-marks1134 w1715)) (null? (wrap-subst1135 w1715))) x1714) ((syntax-object?1115 x1714) (make-syntax-object1114 (syntax-object-expression1116 x1714) (join-wraps1150 w1715 (syntax-object-wrap1117 x1714)) (syntax-object-module1118 x1714))) ((null? x1714) x1714) (else (make-syntax-object1114 x1714 w1715 defmod1716))))) (bound-id-member?1158 (lambda (x1717 list1718) (and (not (null? list1718)) (or (bound-id=?1155 x1717 (car list1718)) (bound-id-member?1158 x1717 (cdr list1718)))))) (distinct-bound-ids?1157 (lambda (ids1719) (let distinct?1720 ((ids1721 ids1719)) (or (null? ids1721) (and (not (bound-id-member?1158 (car ids1721) (cdr ids1721))) (distinct?1720 (cdr ids1721))))))) (valid-bound-ids?1156 (lambda (ids1722) (and (let all-ids?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (id?1131 (car ids1724)) (all-ids?1723 (cdr ids1724))))) (distinct-bound-ids?1157 ids1722)))) (bound-id=?1155 (lambda (i1725 j1726) (if (and (syntax-object?1115 i1725) (syntax-object?1115 j1726)) (and (eq? (let ((e1727 (syntax-object-expression1116 i1725))) (if (annotation? e1727) (annotation-expression e1727) e1727)) (let ((e1728 (syntax-object-expression1116 j1726))) (if (annotation? e1728) (annotation-expression e1728) e1728))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1725)) (wrap-marks1134 (syntax-object-wrap1117 j1726)))) (eq? (let ((e1729 i1725)) (if (annotation? e1729) (annotation-expression e1729) e1729)) (let ((e1730 j1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)))))) (free-id=?1154 (lambda (i1731 j1732) (and (eq? (let ((x1733 i1731)) (let ((e1734 (if (syntax-object?1115 x1733) (syntax-object-expression1116 x1733) x1733))) (if (annotation? e1734) (annotation-expression e1734) e1734))) (let ((x1735 j1732)) (let ((e1736 (if (syntax-object?1115 x1735) (syntax-object-expression1116 x1735) x1735))) (if (annotation? e1736) (annotation-expression e1736) e1736)))) (eq? (id-var-name1153 i1731 (quote (()))) (id-var-name1153 j1732 (quote (()))))))) (id-var-name1153 (lambda (id1737 w1738) (letrec ((search-vector-rib1741 (lambda (sym1747 subst1748 marks1749 symnames1750 ribcage1751) (let ((n1752 (vector-length symnames1750))) (let f1753 ((i1754 0)) (cond ((fx=1100 i1754 n1752) (search1739 sym1747 (cdr subst1748) marks1749)) ((and (eq? (vector-ref symnames1750 i1754) sym1747) (same-marks?1152 marks1749 (vector-ref (ribcage-marks1141 ribcage1751) i1754))) (values (vector-ref (ribcage-labels1142 ribcage1751) i1754) marks1749)) (else (f1753 (fx+1098 i1754 1)))))))) (search-list-rib1740 (lambda (sym1755 subst1756 marks1757 symnames1758 ribcage1759) (let f1760 ((symnames1761 symnames1758) (i1762 0)) (cond ((null? symnames1761) (search1739 sym1755 (cdr subst1756) marks1757)) ((and (eq? (car symnames1761) sym1755) (same-marks?1152 marks1757 (list-ref (ribcage-marks1141 ribcage1759) i1762))) (values (list-ref (ribcage-labels1142 ribcage1759) i1762) marks1757)) (else (f1760 (cdr symnames1761) (fx+1098 i1762 1))))))) (search1739 (lambda (sym1763 subst1764 marks1765) (if (null? subst1764) (values #f marks1765) (let ((fst1766 (car subst1764))) (if (eq? fst1766 (quote shift)) (search1739 sym1763 (cdr subst1764) (cdr marks1765)) (let ((symnames1767 (ribcage-symnames1140 fst1766))) (if (vector? symnames1767) (search-vector-rib1741 sym1763 subst1764 marks1765 symnames1767 fst1766) (search-list-rib1740 sym1763 subst1764 marks1765 symnames1767 fst1766))))))))) (cond ((symbol? id1737) (or (call-with-values (lambda () (search1739 id1737 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1769 . ignore1768) x1769)) id1737)) ((syntax-object?1115 id1737) (let ((id1770 (let ((e1772 (syntax-object-expression1116 id1737))) (if (annotation? e1772) (annotation-expression e1772) e1772))) (w11771 (syntax-object-wrap1117 id1737))) (let ((marks1773 (join-marks1151 (wrap-marks1134 w1738) (wrap-marks1134 w11771)))) (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w1738) marks1773)) (lambda (new-id1774 marks1775) (or new-id1774 (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w11771) marks1775)) (lambda (x1777 . ignore1776) x1777)) id1770)))))) ((annotation? id1737) (let ((id1778 (let ((e1779 id1737)) (if (annotation? e1779) (annotation-expression e1779) e1779)))) (or (call-with-values (lambda () (search1739 id1778 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1781 . ignore1780) x1781)) id1778))) (else (error-hook1104 (quote id-var-name) "invalid id" id1737)))))) (same-marks?1152 (lambda (x1782 y1783) (or (eq? x1782 y1783) (and (not (null? x1782)) (not (null? y1783)) (eq? (car x1782) (car y1783)) (same-marks?1152 (cdr x1782) (cdr y1783)))))) (join-marks1151 (lambda (m11784 m21785) (smart-append1149 m11784 m21785))) (join-wraps1150 (lambda (w11786 w21787) (let ((m11788 (wrap-marks1134 w11786)) (s11789 (wrap-subst1135 w11786))) (if (null? m11788) (if (null? s11789) w21787 (make-wrap1133 (wrap-marks1134 w21787) (smart-append1149 s11789 (wrap-subst1135 w21787)))) (make-wrap1133 (smart-append1149 m11788 (wrap-marks1134 w21787)) (smart-append1149 s11789 (wrap-subst1135 w21787))))))) (smart-append1149 (lambda (m11790 m21791) (if (null? m21791) m11790 (append m11790 m21791)))) (make-binding-wrap1148 (lambda (ids1792 labels1793 w1794) (if (null? ids1792) w1794 (make-wrap1133 (wrap-marks1134 w1794) (cons (let ((labelvec1795 (list->vector labels1793))) (let ((n1796 (vector-length labelvec1795))) (let ((symnamevec1797 (make-vector n1796)) (marksvec1798 (make-vector n1796))) (begin (let f1799 ((ids1800 ids1792) (i1801 0)) (if (not (null? ids1800)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1800) w1794)) (lambda (symname1802 marks1803) (begin (vector-set! symnamevec1797 i1801 symname1802) (vector-set! marksvec1798 i1801 marks1803) (f1799 (cdr ids1800) (fx+1098 i1801 1))))))) (make-ribcage1138 symnamevec1797 marksvec1798 labelvec1795))))) (wrap-subst1135 w1794)))))) (extend-ribcage!1147 (lambda (ribcage1804 id1805 label1806) (begin (set-ribcage-symnames!1143 ribcage1804 (cons (let ((e1807 (syntax-object-expression1116 id1805))) (if (annotation? e1807) (annotation-expression e1807) e1807)) (ribcage-symnames1140 ribcage1804))) (set-ribcage-marks!1144 ribcage1804 (cons (wrap-marks1134 (syntax-object-wrap1117 id1805)) (ribcage-marks1141 ribcage1804))) (set-ribcage-labels!1145 ribcage1804 (cons label1806 (ribcage-labels1142 ribcage1804)))))) (anti-mark1146 (lambda (w1808) (make-wrap1133 (cons #f (wrap-marks1134 w1808)) (cons (quote shift) (wrap-subst1135 w1808))))) (set-ribcage-labels!1145 (lambda (x1809 update1810) (vector-set! x1809 3 update1810))) (set-ribcage-marks!1144 (lambda (x1811 update1812) (vector-set! x1811 2 update1812))) (set-ribcage-symnames!1143 (lambda (x1813 update1814) (vector-set! x1813 1 update1814))) (ribcage-labels1142 (lambda (x1815) (vector-ref x1815 3))) (ribcage-marks1141 (lambda (x1816) (vector-ref x1816 2))) (ribcage-symnames1140 (lambda (x1817) (vector-ref x1817 1))) (ribcage?1139 (lambda (x1818) (and (vector? x1818) (= (vector-length x1818) 4) (eq? (vector-ref x1818 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1819 marks1820 labels1821) (vector (quote ribcage) symnames1819 marks1820 labels1821))) (gen-labels1137 (lambda (ls1822) (if (null? ls1822) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1822)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1823 w1824) (if (syntax-object?1115 x1823) (values (let ((e1825 (syntax-object-expression1116 x1823))) (if (annotation? e1825) (annotation-expression e1825) e1825)) (join-marks1151 (wrap-marks1134 w1824) (wrap-marks1134 (syntax-object-wrap1117 x1823)))) (values (let ((e1826 x1823)) (if (annotation? e1826) (annotation-expression e1826) e1826)) (wrap-marks1134 w1824))))) (id?1131 (lambda (x1827) (cond ((symbol? x1827) #t) ((syntax-object?1115 x1827) (symbol? (let ((e1828 (syntax-object-expression1116 x1827))) (if (annotation? e1828) (annotation-expression e1828) e1828)))) ((annotation? x1827) (symbol? (annotation-expression x1827))) (else #f)))) (nonsymbol-id?1130 (lambda (x1829) (and (syntax-object?1115 x1829) (symbol? (let ((e1830 (syntax-object-expression1116 x1829))) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (global-extend1129 (lambda (type1831 sym1832 val1833) (put-global-definition-hook1105 sym1832 (cons type1831 val1833) (module-name (current-module))))) (lookup1128 (lambda (x1834 r1835 mod1836) (cond ((assq x1834 r1835) => cdr) ((symbol? x1834) (or (get-global-definition-hook1107 x1834 mod1836) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1837) (if (null? r1837) (quote ()) (let ((a1838 (car r1837))) (if (eq? (cadr a1838) (quote macro)) (cons a1838 (macros-only-env1127 (cdr r1837))) (macros-only-env1127 (cdr r1837))))))) (extend-var-env1126 (lambda (labels1839 vars1840 r1841) (if (null? labels1839) r1841 (extend-var-env1126 (cdr labels1839) (cdr vars1840) (cons (cons (car labels1839) (cons (quote lexical) (car vars1840))) r1841))))) (extend-env1125 (lambda (labels1842 bindings1843 r1844) (if (null? labels1842) r1844 (extend-env1125 (cdr labels1842) (cdr bindings1843) (cons (cons (car labels1842) (car bindings1843)) r1844))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1845) (cond ((annotation? x1845) (annotation-source x1845)) ((syntax-object?1115 x1845) (source-annotation1122 (syntax-object-expression1116 x1845))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1846 update1847) (vector-set! x1846 3 update1847))) (set-syntax-object-wrap!1120 (lambda (x1848 update1849) (vector-set! x1848 2 update1849))) (set-syntax-object-expression!1119 (lambda (x1850 update1851) (vector-set! x1850 1 update1851))) (syntax-object-module1118 (lambda (x1852) (vector-ref x1852 3))) (syntax-object-wrap1117 (lambda (x1853) (vector-ref x1853 2))) (syntax-object-expression1116 (lambda (x1854) (vector-ref x1854 1))) (syntax-object?1115 (lambda (x1855) (and (vector? x1855) (= (vector-length x1855) 4) (eq? (vector-ref x1855 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1856 wrap1857 module1858) (vector (quote syntax-object) expression1856 wrap1857 module1858))) (build-letrec1113 (lambda (src1859 vars1860 val-exps1861 body-exp1862) (if (null? vars1860) (build-annotated1108 src1859 body-exp1862) (build-annotated1108 src1859 (list (quote letrec) (map list vars1860 val-exps1861) body-exp1862))))) (build-named-let1112 (lambda (src1863 vars1864 val-exps1865 body-exp1866) (if (null? vars1864) (build-annotated1108 src1863 body-exp1866) (build-annotated1108 src1863 (list (quote let) (car vars1864) (map list (cdr vars1864) val-exps1865) body-exp1866))))) (build-let1111 (lambda (src1867 vars1868 val-exps1869 body-exp1870) (if (null? vars1868) (build-annotated1108 src1867 body-exp1870) (build-annotated1108 src1867 (list (quote let) (map list vars1868 val-exps1869) body-exp1870))))) (build-sequence1110 (lambda (src1871 exps1872) (if (null? (cdr exps1872)) (build-annotated1108 src1871 (car exps1872)) (build-annotated1108 src1871 (cons (quote begin) exps1872))))) (build-data1109 (lambda (src1873 exp1874) (if (and (self-evaluating? exp1874) (not (vector? exp1874))) (build-annotated1108 src1873 exp1874) (build-annotated1108 src1873 (list (quote quote) exp1874))))) (build-annotated1108 (lambda (src1875 exp1876) (if (and src1875 (not (annotation? exp1876))) (make-annotation exp1876 src1875 #t) exp1876))) (get-global-definition-hook1107 (lambda (symbol1877 module1878) (let ((module1879 (if module1878 (resolve-module module1878) (let ((mod1880 (current-module))) (begin (if mod1880 (warn "wha" symbol1877)) mod1880))))) (let ((v1881 (module-variable module1879 symbol1877))) (and v1881 (or (object-property v1881 (quote *sc-expander*)) (and (variable-bound? v1881) (macro? (variable-ref v1881)) (macro-transformer (variable-ref v1881)) guile-macro))))))) (remove-global-definition-hook1106 (lambda (symbol1882 modname1883) (let ((module1884 (if modname1883 (resolve-module modname1883) (current-module)))) (let ((v1885 (module-local-variable module1884 symbol1882))) (if v1885 (let ((p1886 (assq (quote *sc-expander*) (object-properties v1885)))) (set-object-properties! v1885 (delq p1886 (object-properties v1885))))))))) (put-global-definition-hook1105 (lambda (symbol1887 binding1888 modname1889) (let ((module1890 (if modname1889 (resolve-module modname1889) (current-module)))) (let ((v1891 (or (module-variable module1890 symbol1887) (let ((v1892 (make-variable (gensym)))) (begin (module-add! module1890 symbol1887 v1892) v1892))))) (begin (if (not (variable-bound? v1891)) (variable-set! v1891 (gensym))) (set-object-property! v1891 (quote *sc-expander*) binding1888)))))) (error-hook1104 (lambda (who1893 why1894 what1895) (error who1893 "~a ~s" why1894 what1895))) (local-eval-hook1103 (lambda (x1896 mod1897) (eval (list noexpand1097 x1896) (if mod1897 (resolve-module mod1897) (interaction-environment))))) (top-level-eval-hook1102 (lambda (x1898 mod1899) (eval (list noexpand1097 x1898) (if mod1899 (resolve-module mod1899) (interaction-environment))))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1900 r1901 w1902 s1903 mod1904) ((lambda (tmp1905) ((lambda (tmp1906) (if (if tmp1906 (apply (lambda (_1907 var1908 val1909 e11910 e21911) (valid-bound-ids?1156 var1908)) tmp1906) #f) (apply (lambda (_1913 var1914 val1915 e11916 e21917) (let ((names1918 (map (lambda (x1919) (id-var-name1153 x1919 w1902)) var1914))) (begin (for-each (lambda (id1921 n1922) (let ((t1923 (binding-type1123 (lookup1128 n1922 r1901 mod1904)))) (if (memv t1923 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1921 w1902 s1903 mod1904) "identifier out of context")))) var1914 names1918) (chi-body1171 (cons e11916 e21917) (source-wrap1160 e1900 w1902 s1903 mod1904) (extend-env1125 names1918 (let ((trans-r1926 (macros-only-env1127 r1901))) (map (lambda (x1927) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1927 trans-r1926 w1902 mod1904) mod1904))) val1915)) r1901) w1902 mod1904)))) tmp1906) ((lambda (_1929) (syntax-error (source-wrap1160 e1900 w1902 s1903 mod1904))) tmp1905))) (syntax-dispatch tmp1905 (quote (any #(each (any any)) any . each-any))))) e1900))) (global-extend1129 (quote core) (quote quote) (lambda (e1930 r1931 w1932 s1933 mod1934) ((lambda (tmp1935) ((lambda (tmp1936) (if tmp1936 (apply (lambda (_1937 e1938) (build-data1109 s1933 (strip1178 e1938 w1932))) tmp1936) ((lambda (_1939) (syntax-error (source-wrap1160 e1930 w1932 s1933 mod1934))) tmp1935))) (syntax-dispatch tmp1935 (quote (any any))))) e1930))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1947 (lambda (x1948) (let ((t1949 (car x1948))) (if (memv t1949 (quote (ref))) (build-annotated1108 #f (cadr x1948)) (if (memv t1949 (quote (primitive))) (build-annotated1108 #f (cadr x1948)) (if (memv t1949 (quote (quote))) (build-data1109 #f (cadr x1948)) (if (memv t1949 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1948) (regen1947 (caddr x1948)))) (if (memv t1949 (quote (map))) (let ((ls1950 (map regen1947 (cdr x1948)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1950) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1950))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1948)) (map regen1947 (cdr x1948)))))))))))) (gen-vector1946 (lambda (x1951) (cond ((eq? (car x1951) (quote list)) (cons (quote vector) (cdr x1951))) ((eq? (car x1951) (quote quote)) (list (quote quote) (list->vector (cadr x1951)))) (else (list (quote list->vector) x1951))))) (gen-append1945 (lambda (x1952 y1953) (if (equal? y1953 (quote (quote ()))) x1952 (list (quote append) x1952 y1953)))) (gen-cons1944 (lambda (x1954 y1955) (let ((t1956 (car y1955))) (if (memv t1956 (quote (quote))) (if (eq? (car x1954) (quote quote)) (list (quote quote) (cons (cadr x1954) (cadr y1955))) (if (eq? (cadr y1955) (quote ())) (list (quote list) x1954) (list (quote cons) x1954 y1955))) (if (memv t1956 (quote (list))) (cons (quote list) (cons x1954 (cdr y1955))) (list (quote cons) x1954 y1955)))))) (gen-map1943 (lambda (e1957 map-env1958) (let ((formals1959 (map cdr map-env1958)) (actuals1960 (map (lambda (x1961) (list (quote ref) (car x1961))) map-env1958))) (cond ((eq? (car e1957) (quote ref)) (car actuals1960)) ((andmap (lambda (x1962) (and (eq? (car x1962) (quote ref)) (memq (cadr x1962) formals1959))) (cdr e1957)) (cons (quote map) (cons (list (quote primitive) (car e1957)) (map (let ((r1963 (map cons formals1959 actuals1960))) (lambda (x1964) (cdr (assq (cadr x1964) r1963)))) (cdr e1957))))) (else (cons (quote map) (cons (list (quote lambda) formals1959 e1957) actuals1960))))))) (gen-mappend1942 (lambda (e1965 map-env1966) (list (quote apply) (quote (primitive append)) (gen-map1943 e1965 map-env1966)))) (gen-ref1941 (lambda (src1967 var1968 level1969 maps1970) (if (fx=1100 level1969 0) (values var1968 maps1970) (if (null? maps1970) (syntax-error src1967 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1941 src1967 var1968 (fx-1099 level1969 1) (cdr maps1970))) (lambda (outer-var1971 outer-maps1972) (let ((b1973 (assq outer-var1971 (car maps1970)))) (if b1973 (values (cdr b1973) maps1970) (let ((inner-var1974 (gen-var1179 (quote tmp)))) (values inner-var1974 (cons (cons (cons outer-var1971 inner-var1974) (car maps1970)) outer-maps1972))))))))))) (gen-syntax1940 (lambda (src1975 e1976 r1977 maps1978 ellipsis?1979 mod1980) (if (id?1131 e1976) (let ((label1981 (id-var-name1153 e1976 (quote (()))))) (let ((b1982 (lookup1128 label1981 r1977 mod1980))) (if (eq? (binding-type1123 b1982) (quote syntax)) (call-with-values (lambda () (let ((var.lev1983 (binding-value1124 b1982))) (gen-ref1941 src1975 (car var.lev1983) (cdr var.lev1983) maps1978))) (lambda (var1984 maps1985) (values (list (quote ref) var1984) maps1985))) (if (ellipsis?1979 e1976) (syntax-error src1975 "misplaced ellipsis in syntax form") (values (list (quote quote) e1976) maps1978))))) ((lambda (tmp1986) ((lambda (tmp1987) (if (if tmp1987 (apply (lambda (dots1988 e1989) (ellipsis?1979 dots1988)) tmp1987) #f) (apply (lambda (dots1990 e1991) (gen-syntax1940 src1975 e1991 r1977 maps1978 (lambda (x1992) #f) mod1980)) tmp1987) ((lambda (tmp1993) (if (if tmp1993 (apply (lambda (x1994 dots1995 y1996) (ellipsis?1979 dots1995)) tmp1993) #f) (apply (lambda (x1997 dots1998 y1999) (let f2000 ((y2001 y1999) (k2002 (lambda (maps2003) (call-with-values (lambda () (gen-syntax1940 src1975 x1997 r1977 (cons (quote ()) maps2003) ellipsis?1979 mod1980)) (lambda (x2004 maps2005) (if (null? (car maps2005)) (syntax-error src1975 "extra ellipsis in syntax form") (values (gen-map1943 x2004 (car maps2005)) (cdr maps2005)))))))) ((lambda (tmp2006) ((lambda (tmp2007) (if (if tmp2007 (apply (lambda (dots2008 y2009) (ellipsis?1979 dots2008)) tmp2007) #f) (apply (lambda (dots2010 y2011) (f2000 y2011 (lambda (maps2012) (call-with-values (lambda () (k2002 (cons (quote ()) maps2012))) (lambda (x2013 maps2014) (if (null? (car maps2014)) (syntax-error src1975 "extra ellipsis in syntax form") (values (gen-mappend1942 x2013 (car maps2014)) (cdr maps2014)))))))) tmp2007) ((lambda (_2015) (call-with-values (lambda () (gen-syntax1940 src1975 y2001 r1977 maps1978 ellipsis?1979 mod1980)) (lambda (y2016 maps2017) (call-with-values (lambda () (k2002 maps2017)) (lambda (x2018 maps2019) (values (gen-append1945 x2018 y2016) maps2019)))))) tmp2006))) (syntax-dispatch tmp2006 (quote (any . any))))) y2001))) tmp1993) ((lambda (tmp2020) (if tmp2020 (apply (lambda (x2021 y2022) (call-with-values (lambda () (gen-syntax1940 src1975 x2021 r1977 maps1978 ellipsis?1979 mod1980)) (lambda (x2023 maps2024) (call-with-values (lambda () (gen-syntax1940 src1975 y2022 r1977 maps2024 ellipsis?1979 mod1980)) (lambda (y2025 maps2026) (values (gen-cons1944 x2023 y2025) maps2026)))))) tmp2020) ((lambda (tmp2027) (if tmp2027 (apply (lambda (e12028 e22029) (call-with-values (lambda () (gen-syntax1940 src1975 (cons e12028 e22029) r1977 maps1978 ellipsis?1979 mod1980)) (lambda (e2031 maps2032) (values (gen-vector1946 e2031) maps2032)))) tmp2027) ((lambda (_2033) (values (list (quote quote) e1976) maps1978)) tmp1986))) (syntax-dispatch tmp1986 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1986 (quote (any . any)))))) (syntax-dispatch tmp1986 (quote (any any . any)))))) (syntax-dispatch tmp1986 (quote (any any))))) e1976))))) (lambda (e2034 r2035 w2036 s2037 mod2038) (let ((e2039 (source-wrap1160 e2034 w2036 s2037 mod2038))) ((lambda (tmp2040) ((lambda (tmp2041) (if tmp2041 (apply (lambda (_2042 x2043) (call-with-values (lambda () (gen-syntax1940 e2039 x2043 r2035 (quote ()) ellipsis?1176 mod2038)) (lambda (e2044 maps2045) (regen1947 e2044)))) tmp2041) ((lambda (_2046) (syntax-error e2039)) tmp2040))) (syntax-dispatch tmp2040 (quote (any any))))) e2039))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2047 r2048 w2049 s2050 mod2051) ((lambda (tmp2052) ((lambda (tmp2053) (if tmp2053 (apply (lambda (_2054 c2055) (chi-lambda-clause1172 (source-wrap1160 e2047 w2049 s2050 mod2051) c2055 r2048 w2049 mod2051 (lambda (vars2056 body2057) (build-annotated1108 s2050 (list (quote lambda) vars2056 body2057))))) tmp2053) (syntax-error tmp2052))) (syntax-dispatch tmp2052 (quote (any . any))))) e2047))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2058 (lambda (e2059 r2060 w2061 s2062 mod2063 constructor2064 ids2065 vals2066 exps2067) (if (not (valid-bound-ids?1156 ids2065)) (syntax-error e2059 "duplicate bound variable in") (let ((labels2068 (gen-labels1137 ids2065)) (new-vars2069 (map gen-var1179 ids2065))) (let ((nw2070 (make-binding-wrap1148 ids2065 labels2068 w2061)) (nr2071 (extend-var-env1126 labels2068 new-vars2069 r2060))) (constructor2064 s2062 new-vars2069 (map (lambda (x2072) (chi1167 x2072 r2060 w2061 mod2063)) vals2066) (chi-body1171 exps2067 (source-wrap1160 e2059 nw2070 s2062 mod2063) nr2071 nw2070 mod2063)))))))) (lambda (e2073 r2074 w2075 s2076 mod2077) ((lambda (tmp2078) ((lambda (tmp2079) (if tmp2079 (apply (lambda (_2080 id2081 val2082 e12083 e22084) (chi-let2058 e2073 r2074 w2075 s2076 mod2077 build-let1111 id2081 val2082 (cons e12083 e22084))) tmp2079) ((lambda (tmp2088) (if (if tmp2088 (apply (lambda (_2089 f2090 id2091 val2092 e12093 e22094) (id?1131 f2090)) tmp2088) #f) (apply (lambda (_2095 f2096 id2097 val2098 e12099 e22100) (chi-let2058 e2073 r2074 w2075 s2076 mod2077 build-named-let1112 (cons f2096 id2097) val2098 (cons e12099 e22100))) tmp2088) ((lambda (_2104) (syntax-error (source-wrap1160 e2073 w2075 s2076 mod2077))) tmp2078))) (syntax-dispatch tmp2078 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2078 (quote (any #(each (any any)) any . each-any))))) e2073)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2105 r2106 w2107 s2108 mod2109) ((lambda (tmp2110) ((lambda (tmp2111) (if tmp2111 (apply (lambda (_2112 id2113 val2114 e12115 e22116) (let ((ids2117 id2113)) (if (not (valid-bound-ids?1156 ids2117)) (syntax-error e2105 "duplicate bound variable in") (let ((labels2119 (gen-labels1137 ids2117)) (new-vars2120 (map gen-var1179 ids2117))) (let ((w2121 (make-binding-wrap1148 ids2117 labels2119 w2107)) (r2122 (extend-var-env1126 labels2119 new-vars2120 r2106))) (build-letrec1113 s2108 new-vars2120 (map (lambda (x2123) (chi1167 x2123 r2122 w2121 mod2109)) val2114) (chi-body1171 (cons e12115 e22116) (source-wrap1160 e2105 w2121 s2108 mod2109) r2122 w2121 mod2109))))))) tmp2111) ((lambda (_2126) (syntax-error (source-wrap1160 e2105 w2107 s2108 mod2109))) tmp2110))) (syntax-dispatch tmp2110 (quote (any #(each (any any)) any . each-any))))) e2105))) (global-extend1129 (quote core) (quote set!) (lambda (e2127 r2128 w2129 s2130 mod2131) ((lambda (tmp2132) ((lambda (tmp2133) (if (if tmp2133 (apply (lambda (_2134 id2135 val2136) (id?1131 id2135)) tmp2133) #f) (apply (lambda (_2137 id2138 val2139) (let ((val2140 (chi1167 val2139 r2128 w2129 mod2131)) (n2141 (id-var-name1153 id2138 w2129))) (let ((b2142 (lookup1128 n2141 r2128 mod2131))) (let ((t2143 (binding-type1123 b2142))) (if (memv t2143 (quote (lexical))) (build-annotated1108 s2130 (list (quote set!) (binding-value1124 b2142) val2140)) (if (memv t2143 (quote (global))) (build-annotated1108 s2130 (list (quote set!) (cond ((and mod2131 (not (car mod2131))) (make-module-ref (cdr mod2131) n2141 #t)) (else (make-module-ref mod2131 n2141 #f))) val2140)) (if (memv t2143 (quote (displaced-lexical))) (syntax-error (wrap1159 id2138 w2129 mod2131) "identifier out of context") (syntax-error (source-wrap1160 e2127 w2129 s2130 mod2131))))))))) tmp2133) ((lambda (tmp2144) (if tmp2144 (apply (lambda (_2145 head2146 tail2147 val2148) (call-with-values (lambda () (syntax-type1165 head2146 r2128 (quote (())) #f #f mod2131)) (lambda (type2149 value2150 ee2151 ww2152 ss2153 modmod2154) (let ((t2155 type2149)) (if (memv t2155 (quote (module-ref))) (let ((val2156 (chi1167 val2148 r2128 w2129 mod2131))) (call-with-values (lambda () (value2150 (cons head2146 tail2147))) (lambda (id2158 mod2159) (build-annotated1108 s2130 (list (quote set!) (cond ((and mod2159 (not (car mod2159))) (make-module-ref (cdr mod2159) id2158 #t)) (else (make-module-ref mod2159 id2158 #f))) val2156))))) (build-annotated1108 s2130 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2146) r2128 w2129 mod2131) (map (lambda (e2160) (chi1167 e2160 r2128 w2129 mod2131)) (append tail2147 (list val2148)))))))))) tmp2144) ((lambda (_2162) (syntax-error (source-wrap1160 e2127 w2129 s2130 mod2131))) tmp2132))) (syntax-dispatch tmp2132 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2132 (quote (any any any))))) e2127))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2163) ((lambda (tmp2164) ((lambda (tmp2165) (if (if tmp2165 (apply (lambda (_2166 mod2167 id2168) (and (andmap id?1131 mod2167) (id?1131 id2168))) tmp2165) #f) (apply (lambda (_2170 mod2171 id2172) (values (syntax-object->datum id2172) (syntax-object->datum (cons (quote #(syntax-object #f ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) mod2171)))) tmp2165) (syntax-error tmp2164))) (syntax-dispatch tmp2164 (quote (any each-any any))))) e2163))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2174) ((lambda (tmp2175) ((lambda (tmp2176) (if (if tmp2176 (apply (lambda (_2177 mod2178 id2179) (and (andmap id?1131 mod2178) (id?1131 id2179))) tmp2176) #f) (apply (lambda (_2181 mod2182 id2183) (values (syntax-object->datum id2183) (syntax-object->datum mod2182))) tmp2176) (syntax-error tmp2175))) (syntax-dispatch tmp2175 (quote (any each-any any))))) e2174))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2188 (lambda (x2189 keys2190 clauses2191 r2192 mod2193) (if (null? clauses2191) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2189)) ((lambda (tmp2194) ((lambda (tmp2195) (if tmp2195 (apply (lambda (pat2196 exp2197) (if (and (id?1131 pat2196) (andmap (lambda (x2198) (not (free-id=?1154 pat2196 x2198))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2190))) (let ((labels2199 (list (gen-label1136))) (var2200 (gen-var1179 pat2196))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2200) (chi1167 exp2197 (extend-env1125 labels2199 (list (cons (quote syntax) (cons var2200 0))) r2192) (make-binding-wrap1148 (list pat2196) labels2199 (quote (()))) mod2193))) x2189))) (gen-clause2187 x2189 keys2190 (cdr clauses2191) r2192 pat2196 #t exp2197 mod2193))) tmp2195) ((lambda (tmp2201) (if tmp2201 (apply (lambda (pat2202 fender2203 exp2204) (gen-clause2187 x2189 keys2190 (cdr clauses2191) r2192 pat2202 fender2203 exp2204 mod2193)) tmp2201) ((lambda (_2205) (syntax-error (car clauses2191) "invalid syntax-case clause")) tmp2194))) (syntax-dispatch tmp2194 (quote (any any any)))))) (syntax-dispatch tmp2194 (quote (any any))))) (car clauses2191))))) (gen-clause2187 (lambda (x2206 keys2207 clauses2208 r2209 pat2210 fender2211 exp2212 mod2213) (call-with-values (lambda () (convert-pattern2185 pat2210 keys2207)) (lambda (p2214 pvars2215) (cond ((not (distinct-bound-ids?1157 (map car pvars2215))) (syntax-error pat2210 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2216) (not (ellipsis?1176 (car x2216)))) pvars2215)) (syntax-error pat2210 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2217 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2217) (let ((y2218 (build-annotated1108 #f y2217))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2219) ((lambda (tmp2220) (if tmp2220 (apply (lambda () y2218) tmp2220) ((lambda (_2221) (build-annotated1108 #f (list (quote if) y2218 (build-dispatch-call2186 pvars2215 fender2211 y2218 r2209 mod2213) (build-data1109 #f #f)))) tmp2219))) (syntax-dispatch tmp2219 (quote #(atom #t))))) fender2211) (build-dispatch-call2186 pvars2215 exp2212 y2218 r2209 mod2213) (gen-syntax-case2188 x2206 keys2207 clauses2208 r2209 mod2213)))))) (if (eq? p2214 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2206)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2206 (build-data1109 #f p2214))))))))))))) (build-dispatch-call2186 (lambda (pvars2222 exp2223 y2224 r2225 mod2226) (let ((ids2227 (map car pvars2222)) (levels2228 (map cdr pvars2222))) (let ((labels2229 (gen-labels1137 ids2227)) (new-vars2230 (map gen-var1179 ids2227))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2230 (chi1167 exp2223 (extend-env1125 labels2229 (map (lambda (var2231 level2232) (cons (quote syntax) (cons var2231 level2232))) new-vars2230 (map cdr pvars2222)) r2225) (make-binding-wrap1148 ids2227 labels2229 (quote (()))) mod2226))) y2224)))))) (convert-pattern2185 (lambda (pattern2233 keys2234) (let cvt2235 ((p2236 pattern2233) (n2237 0) (ids2238 (quote ()))) (if (id?1131 p2236) (if (bound-id-member?1158 p2236 keys2234) (values (vector (quote free-id) p2236) ids2238) (values (quote any) (cons (cons p2236 n2237) ids2238))) ((lambda (tmp2239) ((lambda (tmp2240) (if (if tmp2240 (apply (lambda (x2241 dots2242) (ellipsis?1176 dots2242)) tmp2240) #f) (apply (lambda (x2243 dots2244) (call-with-values (lambda () (cvt2235 x2243 (fx+1098 n2237 1) ids2238)) (lambda (p2245 ids2246) (values (if (eq? p2245 (quote any)) (quote each-any) (vector (quote each) p2245)) ids2246)))) tmp2240) ((lambda (tmp2247) (if tmp2247 (apply (lambda (x2248 y2249) (call-with-values (lambda () (cvt2235 y2249 n2237 ids2238)) (lambda (y2250 ids2251) (call-with-values (lambda () (cvt2235 x2248 n2237 ids2251)) (lambda (x2252 ids2253) (values (cons x2252 y2250) ids2253)))))) tmp2247) ((lambda (tmp2254) (if tmp2254 (apply (lambda () (values (quote ()) ids2238)) tmp2254) ((lambda (tmp2255) (if tmp2255 (apply (lambda (x2256) (call-with-values (lambda () (cvt2235 x2256 n2237 ids2238)) (lambda (p2258 ids2259) (values (vector (quote vector) p2258) ids2259)))) tmp2255) ((lambda (x2260) (values (vector (quote atom) (strip1178 p2236 (quote (())))) ids2238)) tmp2239))) (syntax-dispatch tmp2239 (quote #(vector each-any)))))) (syntax-dispatch tmp2239 (quote ()))))) (syntax-dispatch tmp2239 (quote (any . any)))))) (syntax-dispatch tmp2239 (quote (any any))))) p2236)))))) (lambda (e2261 r2262 w2263 s2264 mod2265) (let ((e2266 (source-wrap1160 e2261 w2263 s2264 mod2265))) ((lambda (tmp2267) ((lambda (tmp2268) (if tmp2268 (apply (lambda (_2269 val2270 key2271 m2272) (if (andmap (lambda (x2273) (and (id?1131 x2273) (not (ellipsis?1176 x2273)))) key2271) (let ((x2275 (gen-var1179 (quote tmp)))) (build-annotated1108 s2264 (list (build-annotated1108 #f (list (quote lambda) (list x2275) (gen-syntax-case2188 (build-annotated1108 #f x2275) key2271 m2272 r2262 mod2265))) (chi1167 val2270 r2262 (quote (())) mod2265)))) (syntax-error e2266 "invalid literals list in"))) tmp2268) (syntax-error tmp2267))) (syntax-dispatch tmp2267 (quote (any any each-any . each-any))))) e2266))))) (set! sc-expand (let ((m2278 (quote e)) (esew2279 (quote (eval)))) (lambda (x2280) (if (and (pair? x2280) (equal? (car x2280) noexpand1097)) (cadr x2280) (chi-top1166 x2280 (quote ()) (quote ((top))) m2278 esew2279 (module-name (current-module))))))) (set! sc-expand3 (let ((m2281 (quote e)) (esew2282 (quote (eval)))) (lambda (x2284 . rest2283) (if (and (pair? x2284) (equal? (car x2284) noexpand1097)) (cadr x2284) (chi-top1166 x2284 (quote ()) (quote ((top))) (if (null? rest2283) m2281 (car rest2283)) (if (or (null? rest2283) (null? (cdr rest2283))) esew2282 (cadr rest2283)) (module-name (current-module))))))) (set! identifier? (lambda (x2285) (nonsymbol-id?1130 x2285))) (set! datum->syntax-object (lambda (id2286 datum2287) (make-syntax-object1114 datum2287 (syntax-object-wrap1117 id2286) #f))) (set! syntax-object->datum (lambda (x2288) (strip1178 x2288 (quote (()))))) (set! generate-temporaries (lambda (ls2289) (begin (let ((x2290 ls2289)) (if (not (list? x2290)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2290))) (map (lambda (x2291) (wrap1159 (gensym) (quote ((top))) #f)) ls2289)))) (set! free-identifier=? (lambda (x2292 y2293) (begin (let ((x2294 x2292)) (if (not (nonsymbol-id?1130 x2294)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2294))) (let ((x2295 y2293)) (if (not (nonsymbol-id?1130 x2295)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2295))) (free-id=?1154 x2292 y2293)))) (set! bound-identifier=? (lambda (x2296 y2297) (begin (let ((x2298 x2296)) (if (not (nonsymbol-id?1130 x2298)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2298))) (let ((x2299 y2297)) (if (not (nonsymbol-id?1130 x2299)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2299))) (bound-id=?1155 x2296 y2297)))) (set! syntax-error (lambda (object2301 . messages2300) (begin (for-each (lambda (x2302) (let ((x2303 x2302)) (if (not (string? x2303)) (error-hook1104 (quote syntax-error) "invalid argument" x2303)))) messages2300) (let ((message2304 (if (null? messages2300) "invalid syntax" (apply string-append messages2300)))) (error-hook1104 #f message2304 (strip1178 object2301 (quote (())))))))) (set! install-global-transformer (lambda (sym2305 v2306) (begin (let ((x2307 sym2305)) (if (not (symbol? x2307)) (error-hook1104 (quote define-syntax) "invalid argument" x2307))) (let ((x2308 v2306)) (if (not (procedure? x2308)) (error-hook1104 (quote define-syntax) "invalid argument" x2308))) (global-extend1129 (quote macro) sym2305 v2306)))) (letrec ((match2313 (lambda (e2314 p2315 w2316 r2317 mod2318) (cond ((not r2317) #f) ((eq? p2315 (quote any)) (cons (wrap1159 e2314 w2316 mod2318) r2317)) ((syntax-object?1115 e2314) (match*2312 (let ((e2319 (syntax-object-expression1116 e2314))) (if (annotation? e2319) (annotation-expression e2319) e2319)) p2315 (join-wraps1150 w2316 (syntax-object-wrap1117 e2314)) r2317 (syntax-object-module1118 e2314))) (else (match*2312 (let ((e2320 e2314)) (if (annotation? e2320) (annotation-expression e2320) e2320)) p2315 w2316 r2317 mod2318))))) (match*2312 (lambda (e2321 p2322 w2323 r2324 mod2325) (cond ((null? p2322) (and (null? e2321) r2324)) ((pair? p2322) (and (pair? e2321) (match2313 (car e2321) (car p2322) w2323 (match2313 (cdr e2321) (cdr p2322) w2323 r2324 mod2325) mod2325))) ((eq? p2322 (quote each-any)) (let ((l2326 (match-each-any2310 e2321 w2323 mod2325))) (and l2326 (cons l2326 r2324)))) (else (let ((t2327 (vector-ref p2322 0))) (if (memv t2327 (quote (each))) (if (null? e2321) (match-empty2311 (vector-ref p2322 1) r2324) (let ((l2328 (match-each2309 e2321 (vector-ref p2322 1) w2323 mod2325))) (and l2328 (let collect2329 ((l2330 l2328)) (if (null? (car l2330)) r2324 (cons (map car l2330) (collect2329 (map cdr l2330)))))))) (if (memv t2327 (quote (free-id))) (and (id?1131 e2321) (free-id=?1154 (wrap1159 e2321 w2323 mod2325) (vector-ref p2322 1)) r2324) (if (memv t2327 (quote (atom))) (and (equal? (vector-ref p2322 1) (strip1178 e2321 w2323)) r2324) (if (memv t2327 (quote (vector))) (and (vector? e2321) (match2313 (vector->list e2321) (vector-ref p2322 1) w2323 r2324 mod2325))))))))))) (match-empty2311 (lambda (p2331 r2332) (cond ((null? p2331) r2332) ((eq? p2331 (quote any)) (cons (quote ()) r2332)) ((pair? p2331) (match-empty2311 (car p2331) (match-empty2311 (cdr p2331) r2332))) ((eq? p2331 (quote each-any)) (cons (quote ()) r2332)) (else (let ((t2333 (vector-ref p2331 0))) (if (memv t2333 (quote (each))) (match-empty2311 (vector-ref p2331 1) r2332) (if (memv t2333 (quote (free-id atom))) r2332 (if (memv t2333 (quote (vector))) (match-empty2311 (vector-ref p2331 1) r2332))))))))) (match-each-any2310 (lambda (e2334 w2335 mod2336) (cond ((annotation? e2334) (match-each-any2310 (annotation-expression e2334) w2335 mod2336)) ((pair? e2334) (let ((l2337 (match-each-any2310 (cdr e2334) w2335 mod2336))) (and l2337 (cons (wrap1159 (car e2334) w2335 mod2336) l2337)))) ((null? e2334) (quote ())) ((syntax-object?1115 e2334) (match-each-any2310 (syntax-object-expression1116 e2334) (join-wraps1150 w2335 (syntax-object-wrap1117 e2334)) mod2336)) (else #f)))) (match-each2309 (lambda (e2338 p2339 w2340 mod2341) (cond ((annotation? e2338) (match-each2309 (annotation-expression e2338) p2339 w2340 mod2341)) ((pair? e2338) (let ((first2342 (match2313 (car e2338) p2339 w2340 (quote ()) mod2341))) (and first2342 (let ((rest2343 (match-each2309 (cdr e2338) p2339 w2340 mod2341))) (and rest2343 (cons first2342 rest2343)))))) ((null? e2338) (quote ())) ((syntax-object?1115 e2338) (match-each2309 (syntax-object-expression1116 e2338) p2339 (join-wraps1150 w2340 (syntax-object-wrap1117 e2338)) (syntax-object-module1118 e2338))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2344 p2345) (cond ((eq? p2345 (quote any)) (list e2344)) ((syntax-object?1115 e2344) (match*2312 (let ((e2346 (syntax-object-expression1116 e2344))) (if (annotation? e2346) (annotation-expression e2346) e2346)) p2345 (syntax-object-wrap1117 e2344) (quote ()) (syntax-object-module1118 e2344))) (else (match*2312 (let ((e2347 e2344)) (if (annotation? e2347) (annotation-expression e2347) e2347)) p2345 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) -(install-global-transformer (quote with-syntax) (lambda (x2348) ((lambda (tmp2349) ((lambda (tmp2350) (if tmp2350 (apply (lambda (_2351 e12352 e22353) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12352 e22353))) tmp2350) ((lambda (tmp2355) (if tmp2355 (apply (lambda (_2356 out2357 in2358 e12359 e22360) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2358 (quote ()) (list out2357 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12359 e22360))))) tmp2355) ((lambda (tmp2362) (if tmp2362 (apply (lambda (_2363 out2364 in2365 e12366 e22367) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2365) (quote ()) (list out2364 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12366 e22367))))) tmp2362) (syntax-error tmp2349))) (syntax-dispatch tmp2349 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2349 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2349 (quote (any () any . each-any))))) x2348))) -(install-global-transformer (quote syntax-rules) (lambda (x2371) ((lambda (tmp2372) ((lambda (tmp2373) (if tmp2373 (apply (lambda (_2374 k2375 keyword2376 pattern2377 template2378) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2375 (map (lambda (tmp2381 tmp2380) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2380) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2381))) template2378 pattern2377)))))) tmp2373) (syntax-error tmp2372))) (syntax-dispatch tmp2372 (quote (any each-any . #(each ((any . any) any))))))) x2371))) -(install-global-transformer (quote let*) (lambda (x2382) ((lambda (tmp2383) ((lambda (tmp2384) (if (if tmp2384 (apply (lambda (let*2385 x2386 v2387 e12388 e22389) (andmap identifier? x2386)) tmp2384) #f) (apply (lambda (let*2391 x2392 v2393 e12394 e22395) (let f2396 ((bindings2397 (map list x2392 v2393))) (if (null? bindings2397) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12394 e22395))) ((lambda (tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (body2403 binding2404) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2404) body2403)) tmp2402) (syntax-error tmp2401))) (syntax-dispatch tmp2401 (quote (any any))))) (list (f2396 (cdr bindings2397)) (car bindings2397)))))) tmp2384) (syntax-error tmp2383))) (syntax-dispatch tmp2383 (quote (any #(each (any any)) any . each-any))))) x2382))) -(install-global-transformer (quote do) (lambda (orig-x2405) ((lambda (tmp2406) ((lambda (tmp2407) (if tmp2407 (apply (lambda (_2408 var2409 init2410 step2411 e02412 e12413 c2414) ((lambda (tmp2415) ((lambda (tmp2416) (if tmp2416 (apply (lambda (step2417) ((lambda (tmp2418) ((lambda (tmp2419) (if tmp2419 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2409 init2410) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02412) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2414 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2417))))))) tmp2419) ((lambda (tmp2424) (if tmp2424 (apply (lambda (e12425 e22426) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2409 init2410) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02412 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12425 e22426)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2414 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2417))))))) tmp2424) (syntax-error tmp2418))) (syntax-dispatch tmp2418 (quote (any . each-any)))))) (syntax-dispatch tmp2418 (quote ())))) e12413)) tmp2416) (syntax-error tmp2415))) (syntax-dispatch tmp2415 (quote each-any)))) (map (lambda (v2433 s2434) ((lambda (tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda () v2433) tmp2436) ((lambda (tmp2437) (if tmp2437 (apply (lambda (e2438) e2438) tmp2437) ((lambda (_2439) (syntax-error orig-x2405)) tmp2435))) (syntax-dispatch tmp2435 (quote (any)))))) (syntax-dispatch tmp2435 (quote ())))) s2434)) var2409 step2411))) tmp2407) (syntax-error tmp2406))) (syntax-dispatch tmp2406 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2405))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2442 (lambda (x2446 y2447) ((lambda (tmp2448) ((lambda (tmp2449) (if tmp2449 (apply (lambda (x2450 y2451) ((lambda (tmp2452) ((lambda (tmp2453) (if tmp2453 (apply (lambda (dy2454) ((lambda (tmp2455) ((lambda (tmp2456) (if tmp2456 (apply (lambda (dx2457) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2457 dy2454))) tmp2456) ((lambda (_2458) (if (null? dy2454) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2450) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2450 y2451))) tmp2455))) (syntax-dispatch tmp2455 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2450)) tmp2453) ((lambda (tmp2459) (if tmp2459 (apply (lambda (stuff2460) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2450 stuff2460))) tmp2459) ((lambda (else2461) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2450 y2451)) tmp2452))) (syntax-dispatch tmp2452 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2452 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2451)) tmp2449) (syntax-error tmp2448))) (syntax-dispatch tmp2448 (quote (any any))))) (list x2446 y2447)))) (quasiappend2443 (lambda (x2462 y2463) ((lambda (tmp2464) ((lambda (tmp2465) (if tmp2465 (apply (lambda (x2466 y2467) ((lambda (tmp2468) ((lambda (tmp2469) (if tmp2469 (apply (lambda () x2466) tmp2469) ((lambda (_2470) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2466 y2467)) tmp2468))) (syntax-dispatch tmp2468 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2467)) tmp2465) (syntax-error tmp2464))) (syntax-dispatch tmp2464 (quote (any any))))) (list x2462 y2463)))) (quasivector2444 (lambda (x2471) ((lambda (tmp2472) ((lambda (x2473) ((lambda (tmp2474) ((lambda (tmp2475) (if tmp2475 (apply (lambda (x2476) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2476))) tmp2475) ((lambda (tmp2478) (if tmp2478 (apply (lambda (x2479) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2479)) tmp2478) ((lambda (_2481) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2473)) tmp2474))) (syntax-dispatch tmp2474 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2474 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2473)) tmp2472)) x2471))) (quasi2445 (lambda (p2482 lev2483) ((lambda (tmp2484) ((lambda (tmp2485) (if tmp2485 (apply (lambda (p2486) (if (= lev2483 0) p2486 (quasicons2442 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2445 (list p2486) (- lev2483 1))))) tmp2485) ((lambda (tmp2487) (if tmp2487 (apply (lambda (p2488 q2489) (if (= lev2483 0) (quasiappend2443 p2488 (quasi2445 q2489 lev2483)) (quasicons2442 (quasicons2442 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2445 (list p2488) (- lev2483 1))) (quasi2445 q2489 lev2483)))) tmp2487) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491) (quasicons2442 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2445 (list p2491) (+ lev2483 1)))) tmp2490) ((lambda (tmp2492) (if tmp2492 (apply (lambda (p2493 q2494) (quasicons2442 (quasi2445 p2493 lev2483) (quasi2445 q2494 lev2483))) tmp2492) ((lambda (tmp2495) (if tmp2495 (apply (lambda (x2496) (quasivector2444 (quasi2445 x2496 lev2483))) tmp2495) ((lambda (p2498) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2498)) tmp2484))) (syntax-dispatch tmp2484 (quote #(vector each-any)))))) (syntax-dispatch tmp2484 (quote (any . any)))))) (syntax-dispatch tmp2484 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2484 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2484 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2482)))) (lambda (x2499) ((lambda (tmp2500) ((lambda (tmp2501) (if tmp2501 (apply (lambda (_2502 e2503) (quasi2445 e2503 0)) tmp2501) (syntax-error tmp2500))) (syntax-dispatch tmp2500 (quote (any any))))) x2499)))) -(install-global-transformer (quote include) (lambda (x2504) (letrec ((read-file2505 (lambda (fn2506 k2507) (let ((p2508 (open-input-file fn2506))) (let f2509 ((x2510 (read p2508))) (if (eof-object? x2510) (begin (close-input-port p2508) (quote ())) (cons (datum->syntax-object k2507 x2510) (f2509 (read p2508))))))))) ((lambda (tmp2511) ((lambda (tmp2512) (if tmp2512 (apply (lambda (k2513 filename2514) (let ((fn2515 (syntax-object->datum filename2514))) ((lambda (tmp2516) ((lambda (tmp2517) (if tmp2517 (apply (lambda (exp2518) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2518)) tmp2517) (syntax-error tmp2516))) (syntax-dispatch tmp2516 (quote each-any)))) (read-file2505 fn2515 k2513)))) tmp2512) (syntax-error tmp2511))) (syntax-dispatch tmp2511 (quote (any any))))) x2504)))) -(install-global-transformer (quote unquote) (lambda (x2520) ((lambda (tmp2521) ((lambda (tmp2522) (if tmp2522 (apply (lambda (_2523 e2524) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2524))) tmp2522) (syntax-error tmp2521))) (syntax-dispatch tmp2521 (quote (any any))))) x2520))) -(install-global-transformer (quote unquote-splicing) (lambda (x2525) ((lambda (tmp2526) ((lambda (tmp2527) (if tmp2527 (apply (lambda (_2528 e2529) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2529))) tmp2527) (syntax-error tmp2526))) (syntax-dispatch tmp2526 (quote (any any))))) x2525))) -(install-global-transformer (quote case) (lambda (x2530) ((lambda (tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534 m12535 m22536) ((lambda (tmp2537) ((lambda (body2538) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2534)) body2538)) tmp2537)) (let f2539 ((clause2540 m12535) (clauses2541 m22536)) (if (null? clauses2541) ((lambda (tmp2543) ((lambda (tmp2544) (if tmp2544 (apply (lambda (e12545 e22546) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12545 e22546))) tmp2544) ((lambda (tmp2548) (if tmp2548 (apply (lambda (k2549 e12550 e22551) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2549)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12550 e22551)))) tmp2548) ((lambda (_2554) (syntax-error x2530)) tmp2543))) (syntax-dispatch tmp2543 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2543 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2540) ((lambda (tmp2555) ((lambda (rest2556) ((lambda (tmp2557) ((lambda (tmp2558) (if tmp2558 (apply (lambda (k2559 e12560 e22561) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12560 e22561)) rest2556)) tmp2558) ((lambda (_2564) (syntax-error x2530)) tmp2557))) (syntax-dispatch tmp2557 (quote (each-any any . each-any))))) clause2540)) tmp2555)) (f2539 (car clauses2541) (cdr clauses2541))))))) tmp2532) (syntax-error tmp2531))) (syntax-dispatch tmp2531 (quote (any any any . each-any))))) x2530))) -(install-global-transformer (quote identifier-syntax) (lambda (x2565) ((lambda (tmp2566) ((lambda (tmp2567) (if tmp2567 (apply (lambda (_2568 e2569) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2569)) (list (cons _2568 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2569 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2567) (syntax-error tmp2566))) (syntax-dispatch tmp2566 (quote (any any))))) x2565))) +(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (cons (quote hygiene) (module-name (procedure-module p1510)))))))) ((vector? x1517) (let ((n1522 (vector-length x1517))) (let ((v1523 (make-vector n1522))) (let doloop1524 ((i1525 0)) (if (fx=1100 i1525 n1522) v1523 (begin (vector-set! v1523 i1525 (rebuild-macro-output1516 (vector-ref x1517 i1525) m1518)) (doloop1524 (fx+1098 i1525 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1526 e1527 r1528 w1529 s1530 mod1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (e01534 e11535) (build-annotated1108 s1530 (cons x1526 (map (lambda (e1536) (chi1167 e1536 r1528 w1529 mod1531)) e11535)))) tmp1533) (syntax-error tmp1532))) (syntax-dispatch tmp1532 (quote (any . each-any))))) e1527))) (chi-expr1168 (lambda (type1538 value1539 e1540 r1541 w1542 s1543 mod1544) (let ((t1545 type1538)) (if (memv t1545 (quote (lexical))) (build-annotated1108 s1543 value1539) (if (memv t1545 (quote (core external-macro))) (value1539 e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (module-ref))) (call-with-values (lambda () (value1539 e1540)) (lambda (id1546 mod1547) (build-annotated1108 s1543 (cond ((not mod1547) (make-module-ref mod1547 id1546 (quote bare))) ((not (car mod1547)) (make-module-ref (cdr mod1547) id1546 (quote public))) ((memq (car mod1547) (quote (bare public private hygiene))) (make-module-ref (cdr mod1547) id1546 (car mod1547))) (else (make-module-ref mod1547 id1546 (quote private))))))) (if (memv t1545 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) value1539) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (global-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) (cond ((not (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 (quote bare))) ((not (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544))) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 (quote public))) ((memq (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) (quote (bare public private hygiene))) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)))) (else (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 (quote private))))) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (constant))) (build-data1109 s1543 (strip1178 (source-wrap1160 e1540 w1542 s1543 mod1544) (quote (())))) (if (memv t1545 (quote (global))) (build-annotated1108 s1543 (cond ((not mod1544) (make-module-ref mod1544 value1539 (quote bare))) ((not (car mod1544)) (make-module-ref (cdr mod1544) value1539 (quote public))) ((memq (car mod1544) (quote (bare public private hygiene))) (make-module-ref (cdr mod1544) value1539 (car mod1544))) (else (make-module-ref mod1544 value1539 (quote private))))) (if (memv t1545 (quote (call))) (chi-application1169 (chi1167 (car e1540) r1541 w1542 mod1544) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (begin-form))) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (_1550 e11551 e21552) (chi-sequence1161 (cons e11551 e21552) r1541 w1542 s1543 mod1544)) tmp1549) (syntax-error tmp1548))) (syntax-dispatch tmp1548 (quote (any any . each-any))))) e1540) (if (memv t1545 (quote (local-syntax-form))) (chi-local-syntax1173 value1539 e1540 r1541 w1542 s1543 mod1544 chi-sequence1161) (if (memv t1545 (quote (eval-when-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 x1557 e11558 e21559) (let ((when-list1560 (chi-when-list1164 e1540 x1557 w1542))) (if (memq (quote eval) when-list1560) (chi-sequence1161 (cons e11558 e21559) r1541 w1542 s1543 mod1544) (chi-void1175)))) tmp1555) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any each-any any . each-any))))) e1540) (if (memv t1545 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1539 w1542 mod1544) "invalid context for definition of") (if (memv t1545 (quote (syntax))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to pattern variable outside syntax form") (if (memv t1545 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544))))))))))))))))))) (chi1167 (lambda (e1563 r1564 w1565 mod1566) (call-with-values (lambda () (syntax-type1165 e1563 r1564 w1565 #f #f mod1566)) (lambda (type1567 value1568 e1569 w1570 s1571 mod1572) (chi-expr1168 type1567 value1568 e1569 r1564 w1570 s1571 mod1572))))) (chi-top1166 (lambda (e1573 r1574 w1575 m1576 esew1577 mod1578) (call-with-values (lambda () (syntax-type1165 e1573 r1574 w1575 #f #f mod1578)) (lambda (type1586 value1587 e1588 w1589 s1590 mod1591) (let ((t1592 type1586)) (if (memv t1592 (quote (begin-form))) ((lambda (tmp1593) ((lambda (tmp1594) (if tmp1594 (apply (lambda (_1595) (chi-void1175)) tmp1594) ((lambda (tmp1596) (if tmp1596 (apply (lambda (_1597 e11598 e21599) (chi-top-sequence1162 (cons e11598 e21599) r1574 w1589 s1590 m1576 esew1577 mod1591)) tmp1596) (syntax-error tmp1593))) (syntax-dispatch tmp1593 (quote (any any . each-any)))))) (syntax-dispatch tmp1593 (quote (any))))) e1588) (if (memv t1592 (quote (local-syntax-form))) (chi-local-syntax1173 value1587 e1588 r1574 w1589 s1590 mod1591 (lambda (body1601 r1602 w1603 s1604 mod1605) (chi-top-sequence1162 body1601 r1602 w1603 s1604 m1576 esew1577 mod1605))) (if (memv t1592 (quote (eval-when-form))) ((lambda (tmp1606) ((lambda (tmp1607) (if tmp1607 (apply (lambda (_1608 x1609 e11610 e21611) (let ((when-list1612 (chi-when-list1164 e1588 x1609 w1589)) (body1613 (cons e11610 e21611))) (cond ((eq? m1576 (quote e)) (if (memq (quote eval) when-list1612) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) (chi-void1175))) ((memq (quote load) when-list1612) (if (or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c&e) (quote (compile load)) mod1591) (if (memq m1576 (quote (c c&e))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c) (quote (load)) mod1591) (chi-void1175)))) ((or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (top-level-eval-hook1102 (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) mod1591) (chi-void1175)) (else (chi-void1175))))) tmp1607) (syntax-error tmp1606))) (syntax-dispatch tmp1606 (quote (any each-any any . each-any))))) e1588) (if (memv t1592 (quote (define-syntax-form))) (let ((n1616 (id-var-name1153 value1587 w1589)) (r1617 (macros-only-env1127 r1574))) (let ((t1618 m1576)) (if (memv t1618 (quote (c))) (if (memq (quote compile) esew1577) (let ((e1619 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1619 mod1591) (if (memq (quote load) esew1577) e1619 (chi-void1175)))) (if (memq (quote load) esew1577) (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) (chi-void1175))) (if (memv t1618 (quote (c&e))) (let ((e1620 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1620 mod1591) e1620)) (begin (if (memq (quote eval) esew1577) (top-level-eval-hook1102 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) mod1591)) (chi-void1175)))))) (if (memv t1592 (quote (define-form))) (let ((n1621 (id-var-name1153 value1587 w1589))) (let ((type1622 (binding-type1123 (lookup1128 n1621 r1574 mod1591)))) (let ((t1623 type1622)) (if (memv t1623 (quote (global))) (let ((x1624 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1624 mod1591)) x1624)) (if (memv t1623 (quote (displaced-lexical))) (syntax-error (wrap1159 value1587 w1589 mod1591) "identifier out of context") (if (memv t1623 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1621) (let ((x1625 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1625 mod1591)) x1625))) (syntax-error (wrap1159 value1587 w1589 mod1591) "cannot define keyword at top level"))))))) (let ((x1626 (chi-expr1168 type1586 value1587 e1588 r1574 w1589 s1590 mod1591))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1626 mod1591)) x1626)))))))))))) (syntax-type1165 (lambda (e1627 r1628 w1629 s1630 rib1631 mod1632) (cond ((symbol? e1627) (let ((n1633 (id-var-name1153 e1627 w1629))) (let ((b1634 (lookup1128 n1633 r1628 mod1632))) (let ((type1635 (binding-type1123 b1634))) (let ((t1636 type1635)) (if (memv t1636 (quote (lexical))) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (global))) (values type1635 n1633 e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1634) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632))))))))) ((pair? e1627) (let ((first1637 (car e1627))) (if (id?1131 first1637) (let ((n1638 (id-var-name1153 first1637 w1629))) (let ((b1639 (lookup1128 n1638 r1628 (or (and (syntax-object?1115 first1637) (syntax-object-module1118 first1637)) mod1632)))) (let ((type1640 (binding-type1123 b1639))) (let ((t1641 type1640)) (if (memv t1641 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (global))) (values (quote global-call) n1638 e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1639) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (if (memv t1641 (quote (core external-macro module-ref))) (values type1640 (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (begin))) (values (quote begin-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (eval-when))) (values (quote eval-when-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (define))) ((lambda (tmp1642) ((lambda (tmp1643) (if (if tmp1643 (apply (lambda (_1644 name1645 val1646) (id?1131 name1645)) tmp1643) #f) (apply (lambda (_1647 name1648 val1649) (values (quote define-form) name1648 val1649 w1629 s1630 mod1632)) tmp1643) ((lambda (tmp1650) (if (if tmp1650 (apply (lambda (_1651 name1652 args1653 e11654 e21655) (and (id?1131 name1652) (valid-bound-ids?1156 (lambda-var-list1180 args1653)))) tmp1650) #f) (apply (lambda (_1656 name1657 args1658 e11659 e21660) (values (quote define-form) (wrap1159 name1657 w1629 mod1632) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1159 (cons args1658 (cons e11659 e21660)) w1629 mod1632)) (quote (())) s1630 mod1632)) tmp1650) ((lambda (tmp1662) (if (if tmp1662 (apply (lambda (_1663 name1664) (id?1131 name1664)) tmp1662) #f) (apply (lambda (_1665 name1666) (values (quote define-form) (wrap1159 name1666 w1629 mod1632) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1630 mod1632)) tmp1662) (syntax-error tmp1642))) (syntax-dispatch tmp1642 (quote (any any)))))) (syntax-dispatch tmp1642 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1642 (quote (any any any))))) e1627) (if (memv t1641 (quote (define-syntax))) ((lambda (tmp1667) ((lambda (tmp1668) (if (if tmp1668 (apply (lambda (_1669 name1670 val1671) (id?1131 name1670)) tmp1668) #f) (apply (lambda (_1672 name1673 val1674) (values (quote define-syntax-form) name1673 val1674 w1629 s1630 mod1632)) tmp1668) (syntax-error tmp1667))) (syntax-dispatch tmp1667 (quote (any any any))))) e1627) (values (quote call) #f e1627 w1629 s1630 mod1632)))))))))))))) (values (quote call) #f e1627 w1629 s1630 mod1632)))) ((syntax-object?1115 e1627) (syntax-type1165 (syntax-object-expression1116 e1627) r1628 (join-wraps1150 w1629 (syntax-object-wrap1117 e1627)) #f rib1631 (or (syntax-object-module1118 e1627) mod1632))) ((annotation? e1627) (syntax-type1165 (annotation-expression e1627) r1628 w1629 (annotation-source e1627) rib1631 mod1632)) ((self-evaluating? e1627) (values (quote constant) #f e1627 w1629 s1630 mod1632)) (else (values (quote other) #f e1627 w1629 s1630 mod1632))))) (chi-when-list1164 (lambda (e1675 when-list1676 w1677) (let f1678 ((when-list1679 when-list1676) (situations1680 (quote ()))) (if (null? when-list1679) situations1680 (f1678 (cdr when-list1679) (cons (let ((x1681 (car when-list1679))) (cond ((free-id=?1154 x1681 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1154 x1681 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1154 x1681 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1159 x1681 w1677 #f) "invalid eval-when situation")))) situations1680)))))) (chi-install-global1163 (lambda (name1682 e1683) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1682) e1683)))) (chi-top-sequence1162 (lambda (body1684 r1685 w1686 s1687 m1688 esew1689 mod1690) (build-sequence1110 s1687 (let dobody1691 ((body1692 body1684) (r1693 r1685) (w1694 w1686) (m1695 m1688) (esew1696 esew1689) (mod1697 mod1690)) (if (null? body1692) (quote ()) (let ((first1698 (chi-top1166 (car body1692) r1693 w1694 m1695 esew1696 mod1697))) (cons first1698 (dobody1691 (cdr body1692) r1693 w1694 m1695 esew1696 mod1697)))))))) (chi-sequence1161 (lambda (body1699 r1700 w1701 s1702 mod1703) (build-sequence1110 s1702 (let dobody1704 ((body1705 body1699) (r1706 r1700) (w1707 w1701) (mod1708 mod1703)) (if (null? body1705) (quote ()) (let ((first1709 (chi1167 (car body1705) r1706 w1707 mod1708))) (cons first1709 (dobody1704 (cdr body1705) r1706 w1707 mod1708)))))))) (source-wrap1160 (lambda (x1710 w1711 s1712 defmod1713) (wrap1159 (if s1712 (make-annotation x1710 s1712 #f) x1710) w1711 defmod1713))) (wrap1159 (lambda (x1714 w1715 defmod1716) (cond ((and (null? (wrap-marks1134 w1715)) (null? (wrap-subst1135 w1715))) x1714) ((syntax-object?1115 x1714) (make-syntax-object1114 (syntax-object-expression1116 x1714) (join-wraps1150 w1715 (syntax-object-wrap1117 x1714)) (syntax-object-module1118 x1714))) ((null? x1714) x1714) (else (make-syntax-object1114 x1714 w1715 defmod1716))))) (bound-id-member?1158 (lambda (x1717 list1718) (and (not (null? list1718)) (or (bound-id=?1155 x1717 (car list1718)) (bound-id-member?1158 x1717 (cdr list1718)))))) (distinct-bound-ids?1157 (lambda (ids1719) (let distinct?1720 ((ids1721 ids1719)) (or (null? ids1721) (and (not (bound-id-member?1158 (car ids1721) (cdr ids1721))) (distinct?1720 (cdr ids1721))))))) (valid-bound-ids?1156 (lambda (ids1722) (and (let all-ids?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (id?1131 (car ids1724)) (all-ids?1723 (cdr ids1724))))) (distinct-bound-ids?1157 ids1722)))) (bound-id=?1155 (lambda (i1725 j1726) (if (and (syntax-object?1115 i1725) (syntax-object?1115 j1726)) (and (eq? (let ((e1727 (syntax-object-expression1116 i1725))) (if (annotation? e1727) (annotation-expression e1727) e1727)) (let ((e1728 (syntax-object-expression1116 j1726))) (if (annotation? e1728) (annotation-expression e1728) e1728))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1725)) (wrap-marks1134 (syntax-object-wrap1117 j1726)))) (eq? (let ((e1729 i1725)) (if (annotation? e1729) (annotation-expression e1729) e1729)) (let ((e1730 j1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)))))) (free-id=?1154 (lambda (i1731 j1732) (and (eq? (let ((x1733 i1731)) (let ((e1734 (if (syntax-object?1115 x1733) (syntax-object-expression1116 x1733) x1733))) (if (annotation? e1734) (annotation-expression e1734) e1734))) (let ((x1735 j1732)) (let ((e1736 (if (syntax-object?1115 x1735) (syntax-object-expression1116 x1735) x1735))) (if (annotation? e1736) (annotation-expression e1736) e1736)))) (eq? (id-var-name1153 i1731 (quote (()))) (id-var-name1153 j1732 (quote (()))))))) (id-var-name1153 (lambda (id1737 w1738) (letrec ((search-vector-rib1741 (lambda (sym1747 subst1748 marks1749 symnames1750 ribcage1751) (let ((n1752 (vector-length symnames1750))) (let f1753 ((i1754 0)) (cond ((fx=1100 i1754 n1752) (search1739 sym1747 (cdr subst1748) marks1749)) ((and (eq? (vector-ref symnames1750 i1754) sym1747) (same-marks?1152 marks1749 (vector-ref (ribcage-marks1141 ribcage1751) i1754))) (values (vector-ref (ribcage-labels1142 ribcage1751) i1754) marks1749)) (else (f1753 (fx+1098 i1754 1)))))))) (search-list-rib1740 (lambda (sym1755 subst1756 marks1757 symnames1758 ribcage1759) (let f1760 ((symnames1761 symnames1758) (i1762 0)) (cond ((null? symnames1761) (search1739 sym1755 (cdr subst1756) marks1757)) ((and (eq? (car symnames1761) sym1755) (same-marks?1152 marks1757 (list-ref (ribcage-marks1141 ribcage1759) i1762))) (values (list-ref (ribcage-labels1142 ribcage1759) i1762) marks1757)) (else (f1760 (cdr symnames1761) (fx+1098 i1762 1))))))) (search1739 (lambda (sym1763 subst1764 marks1765) (if (null? subst1764) (values #f marks1765) (let ((fst1766 (car subst1764))) (if (eq? fst1766 (quote shift)) (search1739 sym1763 (cdr subst1764) (cdr marks1765)) (let ((symnames1767 (ribcage-symnames1140 fst1766))) (if (vector? symnames1767) (search-vector-rib1741 sym1763 subst1764 marks1765 symnames1767 fst1766) (search-list-rib1740 sym1763 subst1764 marks1765 symnames1767 fst1766))))))))) (cond ((symbol? id1737) (or (call-with-values (lambda () (search1739 id1737 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1769 . ignore1768) x1769)) id1737)) ((syntax-object?1115 id1737) (let ((id1770 (let ((e1772 (syntax-object-expression1116 id1737))) (if (annotation? e1772) (annotation-expression e1772) e1772))) (w11771 (syntax-object-wrap1117 id1737))) (let ((marks1773 (join-marks1151 (wrap-marks1134 w1738) (wrap-marks1134 w11771)))) (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w1738) marks1773)) (lambda (new-id1774 marks1775) (or new-id1774 (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w11771) marks1775)) (lambda (x1777 . ignore1776) x1777)) id1770)))))) ((annotation? id1737) (let ((id1778 (let ((e1779 id1737)) (if (annotation? e1779) (annotation-expression e1779) e1779)))) (or (call-with-values (lambda () (search1739 id1778 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1781 . ignore1780) x1781)) id1778))) (else (error-hook1104 (quote id-var-name) "invalid id" id1737)))))) (same-marks?1152 (lambda (x1782 y1783) (or (eq? x1782 y1783) (and (not (null? x1782)) (not (null? y1783)) (eq? (car x1782) (car y1783)) (same-marks?1152 (cdr x1782) (cdr y1783)))))) (join-marks1151 (lambda (m11784 m21785) (smart-append1149 m11784 m21785))) (join-wraps1150 (lambda (w11786 w21787) (let ((m11788 (wrap-marks1134 w11786)) (s11789 (wrap-subst1135 w11786))) (if (null? m11788) (if (null? s11789) w21787 (make-wrap1133 (wrap-marks1134 w21787) (smart-append1149 s11789 (wrap-subst1135 w21787)))) (make-wrap1133 (smart-append1149 m11788 (wrap-marks1134 w21787)) (smart-append1149 s11789 (wrap-subst1135 w21787))))))) (smart-append1149 (lambda (m11790 m21791) (if (null? m21791) m11790 (append m11790 m21791)))) (make-binding-wrap1148 (lambda (ids1792 labels1793 w1794) (if (null? ids1792) w1794 (make-wrap1133 (wrap-marks1134 w1794) (cons (let ((labelvec1795 (list->vector labels1793))) (let ((n1796 (vector-length labelvec1795))) (let ((symnamevec1797 (make-vector n1796)) (marksvec1798 (make-vector n1796))) (begin (let f1799 ((ids1800 ids1792) (i1801 0)) (if (not (null? ids1800)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1800) w1794)) (lambda (symname1802 marks1803) (begin (vector-set! symnamevec1797 i1801 symname1802) (vector-set! marksvec1798 i1801 marks1803) (f1799 (cdr ids1800) (fx+1098 i1801 1))))))) (make-ribcage1138 symnamevec1797 marksvec1798 labelvec1795))))) (wrap-subst1135 w1794)))))) (extend-ribcage!1147 (lambda (ribcage1804 id1805 label1806) (begin (set-ribcage-symnames!1143 ribcage1804 (cons (let ((e1807 (syntax-object-expression1116 id1805))) (if (annotation? e1807) (annotation-expression e1807) e1807)) (ribcage-symnames1140 ribcage1804))) (set-ribcage-marks!1144 ribcage1804 (cons (wrap-marks1134 (syntax-object-wrap1117 id1805)) (ribcage-marks1141 ribcage1804))) (set-ribcage-labels!1145 ribcage1804 (cons label1806 (ribcage-labels1142 ribcage1804)))))) (anti-mark1146 (lambda (w1808) (make-wrap1133 (cons #f (wrap-marks1134 w1808)) (cons (quote shift) (wrap-subst1135 w1808))))) (set-ribcage-labels!1145 (lambda (x1809 update1810) (vector-set! x1809 3 update1810))) (set-ribcage-marks!1144 (lambda (x1811 update1812) (vector-set! x1811 2 update1812))) (set-ribcage-symnames!1143 (lambda (x1813 update1814) (vector-set! x1813 1 update1814))) (ribcage-labels1142 (lambda (x1815) (vector-ref x1815 3))) (ribcage-marks1141 (lambda (x1816) (vector-ref x1816 2))) (ribcage-symnames1140 (lambda (x1817) (vector-ref x1817 1))) (ribcage?1139 (lambda (x1818) (and (vector? x1818) (= (vector-length x1818) 4) (eq? (vector-ref x1818 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1819 marks1820 labels1821) (vector (quote ribcage) symnames1819 marks1820 labels1821))) (gen-labels1137 (lambda (ls1822) (if (null? ls1822) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1822)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1823 w1824) (if (syntax-object?1115 x1823) (values (let ((e1825 (syntax-object-expression1116 x1823))) (if (annotation? e1825) (annotation-expression e1825) e1825)) (join-marks1151 (wrap-marks1134 w1824) (wrap-marks1134 (syntax-object-wrap1117 x1823)))) (values (let ((e1826 x1823)) (if (annotation? e1826) (annotation-expression e1826) e1826)) (wrap-marks1134 w1824))))) (id?1131 (lambda (x1827) (cond ((symbol? x1827) #t) ((syntax-object?1115 x1827) (symbol? (let ((e1828 (syntax-object-expression1116 x1827))) (if (annotation? e1828) (annotation-expression e1828) e1828)))) ((annotation? x1827) (symbol? (annotation-expression x1827))) (else #f)))) (nonsymbol-id?1130 (lambda (x1829) (and (syntax-object?1115 x1829) (symbol? (let ((e1830 (syntax-object-expression1116 x1829))) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (global-extend1129 (lambda (type1831 sym1832 val1833) (put-global-definition-hook1105 sym1832 (cons type1831 val1833)))) (lookup1128 (lambda (x1834 r1835 mod1836) (cond ((assq x1834 r1835) => cdr) ((symbol? x1834) (or (get-global-definition-hook1107 x1834 mod1836) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1837) (if (null? r1837) (quote ()) (let ((a1838 (car r1837))) (if (eq? (cadr a1838) (quote macro)) (cons a1838 (macros-only-env1127 (cdr r1837))) (macros-only-env1127 (cdr r1837))))))) (extend-var-env1126 (lambda (labels1839 vars1840 r1841) (if (null? labels1839) r1841 (extend-var-env1126 (cdr labels1839) (cdr vars1840) (cons (cons (car labels1839) (cons (quote lexical) (car vars1840))) r1841))))) (extend-env1125 (lambda (labels1842 bindings1843 r1844) (if (null? labels1842) r1844 (extend-env1125 (cdr labels1842) (cdr bindings1843) (cons (cons (car labels1842) (car bindings1843)) r1844))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1845) (cond ((annotation? x1845) (annotation-source x1845)) ((syntax-object?1115 x1845) (source-annotation1122 (syntax-object-expression1116 x1845))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1846 update1847) (vector-set! x1846 3 update1847))) (set-syntax-object-wrap!1120 (lambda (x1848 update1849) (vector-set! x1848 2 update1849))) (set-syntax-object-expression!1119 (lambda (x1850 update1851) (vector-set! x1850 1 update1851))) (syntax-object-module1118 (lambda (x1852) (vector-ref x1852 3))) (syntax-object-wrap1117 (lambda (x1853) (vector-ref x1853 2))) (syntax-object-expression1116 (lambda (x1854) (vector-ref x1854 1))) (syntax-object?1115 (lambda (x1855) (and (vector? x1855) (= (vector-length x1855) 4) (eq? (vector-ref x1855 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1856 wrap1857 module1858) (vector (quote syntax-object) expression1856 wrap1857 module1858))) (build-letrec1113 (lambda (src1859 vars1860 val-exps1861 body-exp1862) (if (null? vars1860) (build-annotated1108 src1859 body-exp1862) (build-annotated1108 src1859 (list (quote letrec) (map list vars1860 val-exps1861) body-exp1862))))) (build-named-let1112 (lambda (src1863 vars1864 val-exps1865 body-exp1866) (if (null? vars1864) (build-annotated1108 src1863 body-exp1866) (build-annotated1108 src1863 (list (quote let) (car vars1864) (map list (cdr vars1864) val-exps1865) body-exp1866))))) (build-let1111 (lambda (src1867 vars1868 val-exps1869 body-exp1870) (if (null? vars1868) (build-annotated1108 src1867 body-exp1870) (build-annotated1108 src1867 (list (quote let) (map list vars1868 val-exps1869) body-exp1870))))) (build-sequence1110 (lambda (src1871 exps1872) (if (null? (cdr exps1872)) (build-annotated1108 src1871 (car exps1872)) (build-annotated1108 src1871 (cons (quote begin) exps1872))))) (build-data1109 (lambda (src1873 exp1874) (if (and (self-evaluating? exp1874) (not (vector? exp1874))) (build-annotated1108 src1873 exp1874) (build-annotated1108 src1873 (list (quote quote) exp1874))))) (build-annotated1108 (lambda (src1875 exp1876) (if (and src1875 (not (annotation? exp1876))) (make-annotation exp1876 src1875 #t) exp1876))) (get-global-definition-hook1107 (lambda (symbol1877 module1878) (let ((module1879 (if module1878 (resolve-module (if (memq (car module1878) (quote (#f hygiene public private bare))) (cdr module1878) module1878)) (let ((mod1880 (current-module))) (begin (if mod1880 (warn "wha" symbol1877)) mod1880))))) (let ((v1881 (module-variable module1879 symbol1877))) (and v1881 (or (object-property v1881 (quote *sc-expander*)) (and (variable-bound? v1881) (macro? (variable-ref v1881)) (macro-transformer (variable-ref v1881)) guile-macro))))))) (remove-global-definition-hook1106 (lambda (symbol1882) (let ((module1883 (current-module))) (let ((v1884 (module-local-variable module1883 symbol1882))) (if v1884 (let ((p1885 (assq (quote *sc-expander*) (object-properties v1884)))) (set-object-properties! v1884 (delq p1885 (object-properties v1884))))))))) (put-global-definition-hook1105 (lambda (symbol1886 binding1887) (let ((module1888 (current-module))) (let ((v1889 (or (module-variable module1888 symbol1886) (let ((v1890 (make-variable (gensym)))) (begin (module-add! module1888 symbol1886 v1890) v1890))))) (begin (if (not (variable-bound? v1889)) (variable-set! v1889 (gensym))) (set-object-property! v1889 (quote *sc-expander*) binding1887)))))) (error-hook1104 (lambda (who1891 why1892 what1893) (error who1891 "~a ~s" why1892 what1893))) (local-eval-hook1103 (lambda (x1894 mod1895) (primitive-eval (list noexpand1097 x1894)))) (top-level-eval-hook1102 (lambda (x1896 mod1897) (primitive-eval (list noexpand1097 x1896)))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1898 r1899 w1900 s1901 mod1902) ((lambda (tmp1903) ((lambda (tmp1904) (if (if tmp1904 (apply (lambda (_1905 var1906 val1907 e11908 e21909) (valid-bound-ids?1156 var1906)) tmp1904) #f) (apply (lambda (_1911 var1912 val1913 e11914 e21915) (let ((names1916 (map (lambda (x1917) (id-var-name1153 x1917 w1900)) var1912))) (begin (for-each (lambda (id1919 n1920) (let ((t1921 (binding-type1123 (lookup1128 n1920 r1899 mod1902)))) (if (memv t1921 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1919 w1900 s1901 mod1902) "identifier out of context")))) var1912 names1916) (chi-body1171 (cons e11914 e21915) (source-wrap1160 e1898 w1900 s1901 mod1902) (extend-env1125 names1916 (let ((trans-r1924 (macros-only-env1127 r1899))) (map (lambda (x1925) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1925 trans-r1924 w1900 mod1902) mod1902))) val1913)) r1899) w1900 mod1902)))) tmp1904) ((lambda (_1927) (syntax-error (source-wrap1160 e1898 w1900 s1901 mod1902))) tmp1903))) (syntax-dispatch tmp1903 (quote (any #(each (any any)) any . each-any))))) e1898))) (global-extend1129 (quote core) (quote quote) (lambda (e1928 r1929 w1930 s1931 mod1932) ((lambda (tmp1933) ((lambda (tmp1934) (if tmp1934 (apply (lambda (_1935 e1936) (build-data1109 s1931 (strip1178 e1936 w1930))) tmp1934) ((lambda (_1937) (syntax-error (source-wrap1160 e1928 w1930 s1931 mod1932))) tmp1933))) (syntax-dispatch tmp1933 (quote (any any))))) e1928))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1945 (lambda (x1946) (let ((t1947 (car x1946))) (if (memv t1947 (quote (ref))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (primitive))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (quote))) (build-data1109 #f (cadr x1946)) (if (memv t1947 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1946) (regen1945 (caddr x1946)))) (if (memv t1947 (quote (map))) (let ((ls1948 (map regen1945 (cdr x1946)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1948) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1948))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1946)) (map regen1945 (cdr x1946)))))))))))) (gen-vector1944 (lambda (x1949) (cond ((eq? (car x1949) (quote list)) (cons (quote vector) (cdr x1949))) ((eq? (car x1949) (quote quote)) (list (quote quote) (list->vector (cadr x1949)))) (else (list (quote list->vector) x1949))))) (gen-append1943 (lambda (x1950 y1951) (if (equal? y1951 (quote (quote ()))) x1950 (list (quote append) x1950 y1951)))) (gen-cons1942 (lambda (x1952 y1953) (let ((t1954 (car y1953))) (if (memv t1954 (quote (quote))) (if (eq? (car x1952) (quote quote)) (list (quote quote) (cons (cadr x1952) (cadr y1953))) (if (eq? (cadr y1953) (quote ())) (list (quote list) x1952) (list (quote cons) x1952 y1953))) (if (memv t1954 (quote (list))) (cons (quote list) (cons x1952 (cdr y1953))) (list (quote cons) x1952 y1953)))))) (gen-map1941 (lambda (e1955 map-env1956) (let ((formals1957 (map cdr map-env1956)) (actuals1958 (map (lambda (x1959) (list (quote ref) (car x1959))) map-env1956))) (cond ((eq? (car e1955) (quote ref)) (car actuals1958)) ((andmap (lambda (x1960) (and (eq? (car x1960) (quote ref)) (memq (cadr x1960) formals1957))) (cdr e1955)) (cons (quote map) (cons (list (quote primitive) (car e1955)) (map (let ((r1961 (map cons formals1957 actuals1958))) (lambda (x1962) (cdr (assq (cadr x1962) r1961)))) (cdr e1955))))) (else (cons (quote map) (cons (list (quote lambda) formals1957 e1955) actuals1958))))))) (gen-mappend1940 (lambda (e1963 map-env1964) (list (quote apply) (quote (primitive append)) (gen-map1941 e1963 map-env1964)))) (gen-ref1939 (lambda (src1965 var1966 level1967 maps1968) (if (fx=1100 level1967 0) (values var1966 maps1968) (if (null? maps1968) (syntax-error src1965 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1939 src1965 var1966 (fx-1099 level1967 1) (cdr maps1968))) (lambda (outer-var1969 outer-maps1970) (let ((b1971 (assq outer-var1969 (car maps1968)))) (if b1971 (values (cdr b1971) maps1968) (let ((inner-var1972 (gen-var1179 (quote tmp)))) (values inner-var1972 (cons (cons (cons outer-var1969 inner-var1972) (car maps1968)) outer-maps1970))))))))))) (gen-syntax1938 (lambda (src1973 e1974 r1975 maps1976 ellipsis?1977 mod1978) (if (id?1131 e1974) (let ((label1979 (id-var-name1153 e1974 (quote (()))))) (let ((b1980 (lookup1128 label1979 r1975 mod1978))) (if (eq? (binding-type1123 b1980) (quote syntax)) (call-with-values (lambda () (let ((var.lev1981 (binding-value1124 b1980))) (gen-ref1939 src1973 (car var.lev1981) (cdr var.lev1981) maps1976))) (lambda (var1982 maps1983) (values (list (quote ref) var1982) maps1983))) (if (ellipsis?1977 e1974) (syntax-error src1973 "misplaced ellipsis in syntax form") (values (list (quote quote) e1974) maps1976))))) ((lambda (tmp1984) ((lambda (tmp1985) (if (if tmp1985 (apply (lambda (dots1986 e1987) (ellipsis?1977 dots1986)) tmp1985) #f) (apply (lambda (dots1988 e1989) (gen-syntax1938 src1973 e1989 r1975 maps1976 (lambda (x1990) #f) mod1978)) tmp1985) ((lambda (tmp1991) (if (if tmp1991 (apply (lambda (x1992 dots1993 y1994) (ellipsis?1977 dots1993)) tmp1991) #f) (apply (lambda (x1995 dots1996 y1997) (let f1998 ((y1999 y1997) (k2000 (lambda (maps2001) (call-with-values (lambda () (gen-syntax1938 src1973 x1995 r1975 (cons (quote ()) maps2001) ellipsis?1977 mod1978)) (lambda (x2002 maps2003) (if (null? (car maps2003)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-map1941 x2002 (car maps2003)) (cdr maps2003)))))))) ((lambda (tmp2004) ((lambda (tmp2005) (if (if tmp2005 (apply (lambda (dots2006 y2007) (ellipsis?1977 dots2006)) tmp2005) #f) (apply (lambda (dots2008 y2009) (f1998 y2009 (lambda (maps2010) (call-with-values (lambda () (k2000 (cons (quote ()) maps2010))) (lambda (x2011 maps2012) (if (null? (car maps2012)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-mappend1940 x2011 (car maps2012)) (cdr maps2012)))))))) tmp2005) ((lambda (_2013) (call-with-values (lambda () (gen-syntax1938 src1973 y1999 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (y2014 maps2015) (call-with-values (lambda () (k2000 maps2015)) (lambda (x2016 maps2017) (values (gen-append1943 x2016 y2014) maps2017)))))) tmp2004))) (syntax-dispatch tmp2004 (quote (any . any))))) y1999))) tmp1991) ((lambda (tmp2018) (if tmp2018 (apply (lambda (x2019 y2020) (call-with-values (lambda () (gen-syntax1938 src1973 x2019 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (x2021 maps2022) (call-with-values (lambda () (gen-syntax1938 src1973 y2020 r1975 maps2022 ellipsis?1977 mod1978)) (lambda (y2023 maps2024) (values (gen-cons1942 x2021 y2023) maps2024)))))) tmp2018) ((lambda (tmp2025) (if tmp2025 (apply (lambda (e12026 e22027) (call-with-values (lambda () (gen-syntax1938 src1973 (cons e12026 e22027) r1975 maps1976 ellipsis?1977 mod1978)) (lambda (e2029 maps2030) (values (gen-vector1944 e2029) maps2030)))) tmp2025) ((lambda (_2031) (values (list (quote quote) e1974) maps1976)) tmp1984))) (syntax-dispatch tmp1984 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1984 (quote (any . any)))))) (syntax-dispatch tmp1984 (quote (any any . any)))))) (syntax-dispatch tmp1984 (quote (any any))))) e1974))))) (lambda (e2032 r2033 w2034 s2035 mod2036) (let ((e2037 (source-wrap1160 e2032 w2034 s2035 mod2036))) ((lambda (tmp2038) ((lambda (tmp2039) (if tmp2039 (apply (lambda (_2040 x2041) (call-with-values (lambda () (gen-syntax1938 e2037 x2041 r2033 (quote ()) ellipsis?1176 mod2036)) (lambda (e2042 maps2043) (regen1945 e2042)))) tmp2039) ((lambda (_2044) (syntax-error e2037)) tmp2038))) (syntax-dispatch tmp2038 (quote (any any))))) e2037))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2045 r2046 w2047 s2048 mod2049) ((lambda (tmp2050) ((lambda (tmp2051) (if tmp2051 (apply (lambda (_2052 c2053) (chi-lambda-clause1172 (source-wrap1160 e2045 w2047 s2048 mod2049) c2053 r2046 w2047 mod2049 (lambda (vars2054 body2055) (build-annotated1108 s2048 (list (quote lambda) vars2054 body2055))))) tmp2051) (syntax-error tmp2050))) (syntax-dispatch tmp2050 (quote (any . any))))) e2045))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2056 (lambda (e2057 r2058 w2059 s2060 mod2061 constructor2062 ids2063 vals2064 exps2065) (if (not (valid-bound-ids?1156 ids2063)) (syntax-error e2057 "duplicate bound variable in") (let ((labels2066 (gen-labels1137 ids2063)) (new-vars2067 (map gen-var1179 ids2063))) (let ((nw2068 (make-binding-wrap1148 ids2063 labels2066 w2059)) (nr2069 (extend-var-env1126 labels2066 new-vars2067 r2058))) (constructor2062 s2060 new-vars2067 (map (lambda (x2070) (chi1167 x2070 r2058 w2059 mod2061)) vals2064) (chi-body1171 exps2065 (source-wrap1160 e2057 nw2068 s2060 mod2061) nr2069 nw2068 mod2061)))))))) (lambda (e2071 r2072 w2073 s2074 mod2075) ((lambda (tmp2076) ((lambda (tmp2077) (if tmp2077 (apply (lambda (_2078 id2079 val2080 e12081 e22082) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-let1111 id2079 val2080 (cons e12081 e22082))) tmp2077) ((lambda (tmp2086) (if (if tmp2086 (apply (lambda (_2087 f2088 id2089 val2090 e12091 e22092) (id?1131 f2088)) tmp2086) #f) (apply (lambda (_2093 f2094 id2095 val2096 e12097 e22098) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-named-let1112 (cons f2094 id2095) val2096 (cons e12097 e22098))) tmp2086) ((lambda (_2102) (syntax-error (source-wrap1160 e2071 w2073 s2074 mod2075))) tmp2076))) (syntax-dispatch tmp2076 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2076 (quote (any #(each (any any)) any . each-any))))) e2071)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2103 r2104 w2105 s2106 mod2107) ((lambda (tmp2108) ((lambda (tmp2109) (if tmp2109 (apply (lambda (_2110 id2111 val2112 e12113 e22114) (let ((ids2115 id2111)) (if (not (valid-bound-ids?1156 ids2115)) (syntax-error e2103 "duplicate bound variable in") (let ((labels2117 (gen-labels1137 ids2115)) (new-vars2118 (map gen-var1179 ids2115))) (let ((w2119 (make-binding-wrap1148 ids2115 labels2117 w2105)) (r2120 (extend-var-env1126 labels2117 new-vars2118 r2104))) (build-letrec1113 s2106 new-vars2118 (map (lambda (x2121) (chi1167 x2121 r2120 w2119 mod2107)) val2112) (chi-body1171 (cons e12113 e22114) (source-wrap1160 e2103 w2119 s2106 mod2107) r2120 w2119 mod2107))))))) tmp2109) ((lambda (_2124) (syntax-error (source-wrap1160 e2103 w2105 s2106 mod2107))) tmp2108))) (syntax-dispatch tmp2108 (quote (any #(each (any any)) any . each-any))))) e2103))) (global-extend1129 (quote core) (quote set!) (lambda (e2125 r2126 w2127 s2128 mod2129) ((lambda (tmp2130) ((lambda (tmp2131) (if (if tmp2131 (apply (lambda (_2132 id2133 val2134) (id?1131 id2133)) tmp2131) #f) (apply (lambda (_2135 id2136 val2137) (let ((val2138 (chi1167 val2137 r2126 w2127 mod2129)) (n2139 (id-var-name1153 id2136 w2127))) (let ((b2140 (lookup1128 n2139 r2126 mod2129))) (let ((t2141 (binding-type1123 b2140))) (if (memv t2141 (quote (lexical))) (build-annotated1108 s2128 (list (quote set!) (binding-value1124 b2140) val2138)) (if (memv t2141 (quote (global))) (build-annotated1108 s2128 (list (quote set!) (cond ((not mod2129) (make-module-ref mod2129 n2139 (quote bare))) ((not (car mod2129)) (make-module-ref (cdr mod2129) n2139 (quote public))) ((memq (car mod2129) (quote (bare public private hygiene))) (make-module-ref (cdr mod2129) n2139 (car mod2129))) (else (make-module-ref mod2129 n2139 (quote private)))) val2138)) (if (memv t2141 (quote (displaced-lexical))) (syntax-error (wrap1159 id2136 w2127 mod2129) "identifier out of context") (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))))))))) tmp2131) ((lambda (tmp2142) (if tmp2142 (apply (lambda (_2143 head2144 tail2145 val2146) (call-with-values (lambda () (syntax-type1165 head2144 r2126 (quote (())) #f #f mod2129)) (lambda (type2147 value2148 ee2149 ww2150 ss2151 modmod2152) (let ((t2153 type2147)) (if (memv t2153 (quote (module-ref))) (let ((val2154 (chi1167 val2146 r2126 w2127 mod2129))) (call-with-values (lambda () (value2148 (cons head2144 tail2145))) (lambda (id2156 mod2157) (build-annotated1108 s2128 (list (quote set!) (cond ((not mod2157) (make-module-ref mod2157 id2156 (quote bare))) ((not (car mod2157)) (make-module-ref (cdr mod2157) id2156 (quote public))) ((memq (car mod2157) (quote (bare public private hygiene))) (make-module-ref (cdr mod2157) id2156 (car mod2157))) (else (make-module-ref mod2157 id2156 (quote private)))) val2154))))) (build-annotated1108 s2128 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2144) r2126 w2127 mod2129) (map (lambda (e2158) (chi1167 e2158 r2126 w2127 mod2129)) (append tail2145 (list val2146)))))))))) tmp2142) ((lambda (_2160) (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))) tmp2130))) (syntax-dispatch tmp2130 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2130 (quote (any any any))))) e2125))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2161) ((lambda (tmp2162) ((lambda (tmp2163) (if (if tmp2163 (apply (lambda (_2164 mod2165 id2166) (and (andmap id?1131 mod2165) (id?1131 id2166))) tmp2163) #f) (apply (lambda (_2168 mod2169 id2170) (values (syntax-object->datum id2170) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) mod2169)))) tmp2163) (syntax-error tmp2162))) (syntax-dispatch tmp2162 (quote (any each-any any))))) e2161))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2172) ((lambda (tmp2173) ((lambda (tmp2174) (if (if tmp2174 (apply (lambda (_2175 mod2176 id2177) (and (andmap id?1131 mod2176) (id?1131 id2177))) tmp2174) #f) (apply (lambda (_2179 mod2180 id2181) (values (syntax-object->datum id2181) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) mod2180)))) tmp2174) (syntax-error tmp2173))) (syntax-dispatch tmp2173 (quote (any each-any any))))) e2172))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2186 (lambda (x2187 keys2188 clauses2189 r2190 mod2191) (if (null? clauses2189) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2187)) ((lambda (tmp2192) ((lambda (tmp2193) (if tmp2193 (apply (lambda (pat2194 exp2195) (if (and (id?1131 pat2194) (andmap (lambda (x2196) (not (free-id=?1154 pat2194 x2196))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2188))) (let ((labels2197 (list (gen-label1136))) (var2198 (gen-var1179 pat2194))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2198) (chi1167 exp2195 (extend-env1125 labels2197 (list (cons (quote syntax) (cons var2198 0))) r2190) (make-binding-wrap1148 (list pat2194) labels2197 (quote (()))) mod2191))) x2187))) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2194 #t exp2195 mod2191))) tmp2193) ((lambda (tmp2199) (if tmp2199 (apply (lambda (pat2200 fender2201 exp2202) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2200 fender2201 exp2202 mod2191)) tmp2199) ((lambda (_2203) (syntax-error (car clauses2189) "invalid syntax-case clause")) tmp2192))) (syntax-dispatch tmp2192 (quote (any any any)))))) (syntax-dispatch tmp2192 (quote (any any))))) (car clauses2189))))) (gen-clause2185 (lambda (x2204 keys2205 clauses2206 r2207 pat2208 fender2209 exp2210 mod2211) (call-with-values (lambda () (convert-pattern2183 pat2208 keys2205)) (lambda (p2212 pvars2213) (cond ((not (distinct-bound-ids?1157 (map car pvars2213))) (syntax-error pat2208 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2214) (not (ellipsis?1176 (car x2214)))) pvars2213)) (syntax-error pat2208 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2215 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2215) (let ((y2216 (build-annotated1108 #f y2215))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2217) ((lambda (tmp2218) (if tmp2218 (apply (lambda () y2216) tmp2218) ((lambda (_2219) (build-annotated1108 #f (list (quote if) y2216 (build-dispatch-call2184 pvars2213 fender2209 y2216 r2207 mod2211) (build-data1109 #f #f)))) tmp2217))) (syntax-dispatch tmp2217 (quote #(atom #t))))) fender2209) (build-dispatch-call2184 pvars2213 exp2210 y2216 r2207 mod2211) (gen-syntax-case2186 x2204 keys2205 clauses2206 r2207 mod2211)))))) (if (eq? p2212 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2204)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2204 (build-data1109 #f p2212))))))))))))) (build-dispatch-call2184 (lambda (pvars2220 exp2221 y2222 r2223 mod2224) (let ((ids2225 (map car pvars2220)) (levels2226 (map cdr pvars2220))) (let ((labels2227 (gen-labels1137 ids2225)) (new-vars2228 (map gen-var1179 ids2225))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2228 (chi1167 exp2221 (extend-env1125 labels2227 (map (lambda (var2229 level2230) (cons (quote syntax) (cons var2229 level2230))) new-vars2228 (map cdr pvars2220)) r2223) (make-binding-wrap1148 ids2225 labels2227 (quote (()))) mod2224))) y2222)))))) (convert-pattern2183 (lambda (pattern2231 keys2232) (let cvt2233 ((p2234 pattern2231) (n2235 0) (ids2236 (quote ()))) (if (id?1131 p2234) (if (bound-id-member?1158 p2234 keys2232) (values (vector (quote free-id) p2234) ids2236) (values (quote any) (cons (cons p2234 n2235) ids2236))) ((lambda (tmp2237) ((lambda (tmp2238) (if (if tmp2238 (apply (lambda (x2239 dots2240) (ellipsis?1176 dots2240)) tmp2238) #f) (apply (lambda (x2241 dots2242) (call-with-values (lambda () (cvt2233 x2241 (fx+1098 n2235 1) ids2236)) (lambda (p2243 ids2244) (values (if (eq? p2243 (quote any)) (quote each-any) (vector (quote each) p2243)) ids2244)))) tmp2238) ((lambda (tmp2245) (if tmp2245 (apply (lambda (x2246 y2247) (call-with-values (lambda () (cvt2233 y2247 n2235 ids2236)) (lambda (y2248 ids2249) (call-with-values (lambda () (cvt2233 x2246 n2235 ids2249)) (lambda (x2250 ids2251) (values (cons x2250 y2248) ids2251)))))) tmp2245) ((lambda (tmp2252) (if tmp2252 (apply (lambda () (values (quote ()) ids2236)) tmp2252) ((lambda (tmp2253) (if tmp2253 (apply (lambda (x2254) (call-with-values (lambda () (cvt2233 x2254 n2235 ids2236)) (lambda (p2256 ids2257) (values (vector (quote vector) p2256) ids2257)))) tmp2253) ((lambda (x2258) (values (vector (quote atom) (strip1178 p2234 (quote (())))) ids2236)) tmp2237))) (syntax-dispatch tmp2237 (quote #(vector each-any)))))) (syntax-dispatch tmp2237 (quote ()))))) (syntax-dispatch tmp2237 (quote (any . any)))))) (syntax-dispatch tmp2237 (quote (any any))))) p2234)))))) (lambda (e2259 r2260 w2261 s2262 mod2263) (let ((e2264 (source-wrap1160 e2259 w2261 s2262 mod2263))) ((lambda (tmp2265) ((lambda (tmp2266) (if tmp2266 (apply (lambda (_2267 val2268 key2269 m2270) (if (andmap (lambda (x2271) (and (id?1131 x2271) (not (ellipsis?1176 x2271)))) key2269) (let ((x2273 (gen-var1179 (quote tmp)))) (build-annotated1108 s2262 (list (build-annotated1108 #f (list (quote lambda) (list x2273) (gen-syntax-case2186 (build-annotated1108 #f x2273) key2269 m2270 r2260 mod2263))) (chi1167 val2268 r2260 (quote (())) mod2263)))) (syntax-error e2264 "invalid literals list in"))) tmp2266) (syntax-error tmp2265))) (syntax-dispatch tmp2265 (quote (any any each-any . each-any))))) e2264))))) (set! sc-expand (let ((m2276 (quote e)) (esew2277 (quote (eval)))) (lambda (x2278) (if (and (pair? x2278) (equal? (car x2278) noexpand1097)) (cadr x2278) (chi-top1166 x2278 (quote ()) (quote ((top))) m2276 esew2277 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2279 (quote e)) (esew2280 (quote (eval)))) (lambda (x2282 . rest2281) (if (and (pair? x2282) (equal? (car x2282) noexpand1097)) (cadr x2282) (chi-top1166 x2282 (quote ()) (quote ((top))) (if (null? rest2281) m2279 (car rest2281)) (if (or (null? rest2281) (null? (cdr rest2281))) esew2280 (cadr rest2281)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2283) (nonsymbol-id?1130 x2283))) (set! datum->syntax-object (lambda (id2284 datum2285) (make-syntax-object1114 datum2285 (syntax-object-wrap1117 id2284) #f))) (set! syntax-object->datum (lambda (x2286) (strip1178 x2286 (quote (()))))) (set! generate-temporaries (lambda (ls2287) (begin (let ((x2288 ls2287)) (if (not (list? x2288)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2288))) (map (lambda (x2289) (wrap1159 (gensym) (quote ((top))) #f)) ls2287)))) (set! free-identifier=? (lambda (x2290 y2291) (begin (let ((x2292 x2290)) (if (not (nonsymbol-id?1130 x2292)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2292))) (let ((x2293 y2291)) (if (not (nonsymbol-id?1130 x2293)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2293))) (free-id=?1154 x2290 y2291)))) (set! bound-identifier=? (lambda (x2294 y2295) (begin (let ((x2296 x2294)) (if (not (nonsymbol-id?1130 x2296)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2296))) (let ((x2297 y2295)) (if (not (nonsymbol-id?1130 x2297)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2297))) (bound-id=?1155 x2294 y2295)))) (set! syntax-error (lambda (object2299 . messages2298) (begin (for-each (lambda (x2300) (let ((x2301 x2300)) (if (not (string? x2301)) (error-hook1104 (quote syntax-error) "invalid argument" x2301)))) messages2298) (let ((message2302 (if (null? messages2298) "invalid syntax" (apply string-append messages2298)))) (error-hook1104 #f message2302 (strip1178 object2299 (quote (())))))))) (set! install-global-transformer (lambda (sym2303 v2304) (begin (let ((x2305 sym2303)) (if (not (symbol? x2305)) (error-hook1104 (quote define-syntax) "invalid argument" x2305))) (let ((x2306 v2304)) (if (not (procedure? x2306)) (error-hook1104 (quote define-syntax) "invalid argument" x2306))) (global-extend1129 (quote macro) sym2303 v2304)))) (letrec ((match2311 (lambda (e2312 p2313 w2314 r2315 mod2316) (cond ((not r2315) #f) ((eq? p2313 (quote any)) (cons (wrap1159 e2312 w2314 mod2316) r2315)) ((syntax-object?1115 e2312) (match*2310 (let ((e2317 (syntax-object-expression1116 e2312))) (if (annotation? e2317) (annotation-expression e2317) e2317)) p2313 (join-wraps1150 w2314 (syntax-object-wrap1117 e2312)) r2315 (syntax-object-module1118 e2312))) (else (match*2310 (let ((e2318 e2312)) (if (annotation? e2318) (annotation-expression e2318) e2318)) p2313 w2314 r2315 mod2316))))) (match*2310 (lambda (e2319 p2320 w2321 r2322 mod2323) (cond ((null? p2320) (and (null? e2319) r2322)) ((pair? p2320) (and (pair? e2319) (match2311 (car e2319) (car p2320) w2321 (match2311 (cdr e2319) (cdr p2320) w2321 r2322 mod2323) mod2323))) ((eq? p2320 (quote each-any)) (let ((l2324 (match-each-any2308 e2319 w2321 mod2323))) (and l2324 (cons l2324 r2322)))) (else (let ((t2325 (vector-ref p2320 0))) (if (memv t2325 (quote (each))) (if (null? e2319) (match-empty2309 (vector-ref p2320 1) r2322) (let ((l2326 (match-each2307 e2319 (vector-ref p2320 1) w2321 mod2323))) (and l2326 (let collect2327 ((l2328 l2326)) (if (null? (car l2328)) r2322 (cons (map car l2328) (collect2327 (map cdr l2328)))))))) (if (memv t2325 (quote (free-id))) (and (id?1131 e2319) (free-id=?1154 (wrap1159 e2319 w2321 mod2323) (vector-ref p2320 1)) r2322) (if (memv t2325 (quote (atom))) (and (equal? (vector-ref p2320 1) (strip1178 e2319 w2321)) r2322) (if (memv t2325 (quote (vector))) (and (vector? e2319) (match2311 (vector->list e2319) (vector-ref p2320 1) w2321 r2322 mod2323))))))))))) (match-empty2309 (lambda (p2329 r2330) (cond ((null? p2329) r2330) ((eq? p2329 (quote any)) (cons (quote ()) r2330)) ((pair? p2329) (match-empty2309 (car p2329) (match-empty2309 (cdr p2329) r2330))) ((eq? p2329 (quote each-any)) (cons (quote ()) r2330)) (else (let ((t2331 (vector-ref p2329 0))) (if (memv t2331 (quote (each))) (match-empty2309 (vector-ref p2329 1) r2330) (if (memv t2331 (quote (free-id atom))) r2330 (if (memv t2331 (quote (vector))) (match-empty2309 (vector-ref p2329 1) r2330))))))))) (match-each-any2308 (lambda (e2332 w2333 mod2334) (cond ((annotation? e2332) (match-each-any2308 (annotation-expression e2332) w2333 mod2334)) ((pair? e2332) (let ((l2335 (match-each-any2308 (cdr e2332) w2333 mod2334))) (and l2335 (cons (wrap1159 (car e2332) w2333 mod2334) l2335)))) ((null? e2332) (quote ())) ((syntax-object?1115 e2332) (match-each-any2308 (syntax-object-expression1116 e2332) (join-wraps1150 w2333 (syntax-object-wrap1117 e2332)) mod2334)) (else #f)))) (match-each2307 (lambda (e2336 p2337 w2338 mod2339) (cond ((annotation? e2336) (match-each2307 (annotation-expression e2336) p2337 w2338 mod2339)) ((pair? e2336) (let ((first2340 (match2311 (car e2336) p2337 w2338 (quote ()) mod2339))) (and first2340 (let ((rest2341 (match-each2307 (cdr e2336) p2337 w2338 mod2339))) (and rest2341 (cons first2340 rest2341)))))) ((null? e2336) (quote ())) ((syntax-object?1115 e2336) (match-each2307 (syntax-object-expression1116 e2336) p2337 (join-wraps1150 w2338 (syntax-object-wrap1117 e2336)) (syntax-object-module1118 e2336))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2342 p2343) (cond ((eq? p2343 (quote any)) (list e2342)) ((syntax-object?1115 e2342) (match*2310 (let ((e2344 (syntax-object-expression1116 e2342))) (if (annotation? e2344) (annotation-expression e2344) e2344)) p2343 (syntax-object-wrap1117 e2342) (quote ()) (syntax-object-module1118 e2342))) (else (match*2310 (let ((e2345 e2342)) (if (annotation? e2345) (annotation-expression e2345) e2345)) p2343 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) +(install-global-transformer (quote with-syntax) (lambda (x2346) ((lambda (tmp2347) ((lambda (tmp2348) (if tmp2348 (apply (lambda (_2349 e12350 e22351) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12350 e22351))) tmp2348) ((lambda (tmp2353) (if tmp2353 (apply (lambda (_2354 out2355 in2356 e12357 e22358) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2356 (quote ()) (list out2355 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12357 e22358))))) tmp2353) ((lambda (tmp2360) (if tmp2360 (apply (lambda (_2361 out2362 in2363 e12364 e22365) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2363) (quote ()) (list out2362 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12364 e22365))))) tmp2360) (syntax-error tmp2347))) (syntax-dispatch tmp2347 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any () any . each-any))))) x2346))) +(install-global-transformer (quote syntax-rules) (lambda (x2369) ((lambda (tmp2370) ((lambda (tmp2371) (if tmp2371 (apply (lambda (_2372 k2373 keyword2374 pattern2375 template2376) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2373 (map (lambda (tmp2379 tmp2378) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2378) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2379))) template2376 pattern2375)))))) tmp2371) (syntax-error tmp2370))) (syntax-dispatch tmp2370 (quote (any each-any . #(each ((any . any) any))))))) x2369))) +(install-global-transformer (quote let*) (lambda (x2380) ((lambda (tmp2381) ((lambda (tmp2382) (if (if tmp2382 (apply (lambda (let*2383 x2384 v2385 e12386 e22387) (andmap identifier? x2384)) tmp2382) #f) (apply (lambda (let*2389 x2390 v2391 e12392 e22393) (let f2394 ((bindings2395 (map list x2390 v2391))) (if (null? bindings2395) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12392 e22393))) ((lambda (tmp2399) ((lambda (tmp2400) (if tmp2400 (apply (lambda (body2401 binding2402) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2402) body2401)) tmp2400) (syntax-error tmp2399))) (syntax-dispatch tmp2399 (quote (any any))))) (list (f2394 (cdr bindings2395)) (car bindings2395)))))) tmp2382) (syntax-error tmp2381))) (syntax-dispatch tmp2381 (quote (any #(each (any any)) any . each-any))))) x2380))) +(install-global-transformer (quote do) (lambda (orig-x2403) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 var2407 init2408 step2409 e02410 e12411 c2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (step2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02410) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2415))))))) tmp2417) ((lambda (tmp2422) (if tmp2422 (apply (lambda (e12423 e22424) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02410 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12423 e22424)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2415))))))) tmp2422) (syntax-error tmp2416))) (syntax-dispatch tmp2416 (quote (any . each-any)))))) (syntax-dispatch tmp2416 (quote ())))) e12411)) tmp2414) (syntax-error tmp2413))) (syntax-dispatch tmp2413 (quote each-any)))) (map (lambda (v2431 s2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () v2431) tmp2434) ((lambda (tmp2435) (if tmp2435 (apply (lambda (e2436) e2436) tmp2435) ((lambda (_2437) (syntax-error orig-x2403)) tmp2433))) (syntax-dispatch tmp2433 (quote (any)))))) (syntax-dispatch tmp2433 (quote ())))) s2432)) var2407 step2409))) tmp2405) (syntax-error tmp2404))) (syntax-dispatch tmp2404 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2403))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2440 (lambda (x2444 y2445) ((lambda (tmp2446) ((lambda (tmp2447) (if tmp2447 (apply (lambda (x2448 y2449) ((lambda (tmp2450) ((lambda (tmp2451) (if tmp2451 (apply (lambda (dy2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (dx2455) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2455 dy2452))) tmp2454) ((lambda (_2456) (if (null? dy2452) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2448) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2448 y2449))) tmp2453))) (syntax-dispatch tmp2453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2448)) tmp2451) ((lambda (tmp2457) (if tmp2457 (apply (lambda (stuff2458) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2448 stuff2458))) tmp2457) ((lambda (else2459) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2448 y2449)) tmp2450))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2449)) tmp2447) (syntax-error tmp2446))) (syntax-dispatch tmp2446 (quote (any any))))) (list x2444 y2445)))) (quasiappend2441 (lambda (x2460 y2461) ((lambda (tmp2462) ((lambda (tmp2463) (if tmp2463 (apply (lambda (x2464 y2465) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda () x2464) tmp2467) ((lambda (_2468) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2464 y2465)) tmp2466))) (syntax-dispatch tmp2466 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2465)) tmp2463) (syntax-error tmp2462))) (syntax-dispatch tmp2462 (quote (any any))))) (list x2460 y2461)))) (quasivector2442 (lambda (x2469) ((lambda (tmp2470) ((lambda (x2471) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (x2474) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2474))) tmp2473) ((lambda (tmp2476) (if tmp2476 (apply (lambda (x2477) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2477)) tmp2476) ((lambda (_2479) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2471)) tmp2472))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2471)) tmp2470)) x2469))) (quasi2443 (lambda (p2480 lev2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (p2484) (if (= lev2481 0) p2484 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2443 (list p2484) (- lev2481 1))))) tmp2483) ((lambda (tmp2485) (if tmp2485 (apply (lambda (p2486 q2487) (if (= lev2481 0) (quasiappend2441 p2486 (quasi2443 q2487 lev2481)) (quasicons2440 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2443 (list p2486) (- lev2481 1))) (quasi2443 q2487 lev2481)))) tmp2485) ((lambda (tmp2488) (if tmp2488 (apply (lambda (p2489) (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2443 (list p2489) (+ lev2481 1)))) tmp2488) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491 q2492) (quasicons2440 (quasi2443 p2491 lev2481) (quasi2443 q2492 lev2481))) tmp2490) ((lambda (tmp2493) (if tmp2493 (apply (lambda (x2494) (quasivector2442 (quasi2443 x2494 lev2481))) tmp2493) ((lambda (p2496) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2496)) tmp2482))) (syntax-dispatch tmp2482 (quote #(vector each-any)))))) (syntax-dispatch tmp2482 (quote (any . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2482 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2480)))) (lambda (x2497) ((lambda (tmp2498) ((lambda (tmp2499) (if tmp2499 (apply (lambda (_2500 e2501) (quasi2443 e2501 0)) tmp2499) (syntax-error tmp2498))) (syntax-dispatch tmp2498 (quote (any any))))) x2497)))) +(install-global-transformer (quote include) (lambda (x2502) (letrec ((read-file2503 (lambda (fn2504 k2505) (let ((p2506 (open-input-file fn2504))) (let f2507 ((x2508 (read p2506))) (if (eof-object? x2508) (begin (close-input-port p2506) (quote ())) (cons (datum->syntax-object k2505 x2508) (f2507 (read p2506))))))))) ((lambda (tmp2509) ((lambda (tmp2510) (if tmp2510 (apply (lambda (k2511 filename2512) (let ((fn2513 (syntax-object->datum filename2512))) ((lambda (tmp2514) ((lambda (tmp2515) (if tmp2515 (apply (lambda (exp2516) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2516)) tmp2515) (syntax-error tmp2514))) (syntax-dispatch tmp2514 (quote each-any)))) (read-file2503 fn2513 k2511)))) tmp2510) (syntax-error tmp2509))) (syntax-dispatch tmp2509 (quote (any any))))) x2502)))) +(install-global-transformer (quote unquote) (lambda (x2518) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (_2521 e2522) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2522))) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote (any any))))) x2518))) +(install-global-transformer (quote unquote-splicing) (lambda (x2523) ((lambda (tmp2524) ((lambda (tmp2525) (if tmp2525 (apply (lambda (_2526 e2527) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2527))) tmp2525) (syntax-error tmp2524))) (syntax-dispatch tmp2524 (quote (any any))))) x2523))) +(install-global-transformer (quote case) (lambda (x2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda (_2531 e2532 m12533 m22534) ((lambda (tmp2535) ((lambda (body2536) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2532)) body2536)) tmp2535)) (let f2537 ((clause2538 m12533) (clauses2539 m22534)) (if (null? clauses2539) ((lambda (tmp2541) ((lambda (tmp2542) (if tmp2542 (apply (lambda (e12543 e22544) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12543 e22544))) tmp2542) ((lambda (tmp2546) (if tmp2546 (apply (lambda (k2547 e12548 e22549) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2547)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12548 e22549)))) tmp2546) ((lambda (_2552) (syntax-error x2528)) tmp2541))) (syntax-dispatch tmp2541 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2541 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2538) ((lambda (tmp2553) ((lambda (rest2554) ((lambda (tmp2555) ((lambda (tmp2556) (if tmp2556 (apply (lambda (k2557 e12558 e22559) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2557)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12558 e22559)) rest2554)) tmp2556) ((lambda (_2562) (syntax-error x2528)) tmp2555))) (syntax-dispatch tmp2555 (quote (each-any any . each-any))))) clause2538)) tmp2553)) (f2537 (car clauses2539) (cdr clauses2539))))))) tmp2530) (syntax-error tmp2529))) (syntax-dispatch tmp2529 (quote (any any any . each-any))))) x2528))) +(install-global-transformer (quote identifier-syntax) (lambda (x2563) ((lambda (tmp2564) ((lambda (tmp2565) (if tmp2565 (apply (lambda (_2566 e2567) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2567)) (list (cons _2566 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2567 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2565) (syntax-error tmp2564))) (syntax-dispatch tmp2564 (quote (any any))))) x2563))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 6d7ab1780..94c408343 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -320,13 +320,11 @@ (define top-level-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (if mod (resolve-module mod) - (interaction-environment))))) + (primitive-eval `(,noexpand ,x)))) (define local-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (if mod (resolve-module mod) - (interaction-environment))))) + (primitive-eval `(,noexpand ,x)))) (define error-hook (lambda (who why what) @@ -337,10 +335,8 @@ ((_) (gensym)))) (define put-global-definition-hook - (lambda (symbol binding modname) - (let* ((module (if modname - (resolve-module modname) - (current-module))) + (lambda (symbol binding) + (let* ((module (current-module)) (v (or (module-variable module symbol) (let ((v (make-variable (gensym)))) (module-add! module symbol v) @@ -351,10 +347,8 @@ (set-object-property! v '*sc-expander* binding)))) (define remove-global-definition-hook - (lambda (symbol modname) - (let* ((module (if modname - (resolve-module modname) - (current-module))) + (lambda (symbol) + (let* ((module (current-module)) (v (module-local-variable module symbol))) (if v (let ((p (assq '*sc-expander* (object-properties v)))) @@ -363,7 +357,9 @@ (define get-global-definition-hook (lambda (symbol module) (let* ((module (if module - (resolve-module module) + (resolve-module (if (memq (car module) '(#f hygiene public private bare)) + (cdr module) + module)) (let ((mod (current-module))) (if mod (warn "wha" symbol)) mod))) @@ -406,19 +402,21 @@ (define-syntax build-global-reference (syntax-rules () ((_ source var mod) - (cond - ((and mod (not (car mod))) - (build-annotated source (make-module-ref (cdr mod) var #t))) - (else - (build-annotated source (make-module-ref mod var #f))))))) + (build-annotated + source + (cond ((not mod) (make-module-ref mod var 'bare)) + ((not (car mod)) (make-module-ref (cdr mod) var 'public)) + ((memq (car mod) '(bare public private hygiene)) (make-module-ref (cdr mod) var (car mod))) + (else (make-module-ref mod var 'private))))))) (define-syntax build-global-assignment (syntax-rules () ((_ source var exp mod) (build-annotated source - `(set! ,(cond - ((and mod (not (car mod))) (make-module-ref (cdr mod) var #t)) - (else (make-module-ref mod var #f))) + `(set! ,(cond ((not mod) (make-module-ref mod var 'bare)) + ((not (car mod)) (make-module-ref (cdr mod) var 'public)) + ((memq (car mod) '(bare public private hygiene)) (make-module-ref (cdr mod) var (car mod))) + (else (make-module-ref mod var 'private))) ,exp))))) (define-syntax build-global-definition @@ -608,8 +606,7 @@ (define global-extend (lambda (type sym val) - (put-global-definition-hook sym (make-binding type val) - (module-name (current-module))))) + (put-global-definition-hook sym (make-binding type val)))) ;;; Conceptually, identifiers are always syntax objects. Internally, @@ -1123,7 +1120,7 @@ ((displaced-lexical) (syntax-error (wrap value w mod) "identifier out of context")) ((core macro module-ref) - (remove-global-definition-hook n mod) + (remove-global-definition-hook n) (eval-if-c&e m (build-global-definition s n (chi e r w mod) mod) mod)) @@ -1217,7 +1214,7 @@ (if rib (cons rib (cons 'shift s)) (cons 'shift s))) - (module-name (procedure-module p))))))) ;; hither the hygiene + (cons 'hygiene (module-name (procedure-module p)))))))) ;; hither the hygiene ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -1812,7 +1809,7 @@ (and (andmap id? (syntax (mod ...))) (id? (syntax id))) (values (syntax-object->datum (syntax id)) (syntax-object->datum - (syntax (#f mod ...)))))))) + (syntax (public mod ...)))))))) (global-extend 'module-ref '@@ (lambda (e) @@ -1821,7 +1818,7 @@ (and (andmap id? (syntax (mod ...))) (id? (syntax id))) (values (syntax-object->datum (syntax id)) (syntax-object->datum - (syntax (mod ...)))))))) + (syntax (private mod ...)))))))) (global-extend 'begin 'begin '()) @@ -1981,7 +1978,7 @@ (if (and (pair? x) (equal? (car x) noexpand)) (cadr x) (chi-top x null-env top-wrap m esew - (module-name (current-module))))))) + (cons 'hygiene (module-name (current-module)))))))) (set! sc-expand3 (let ((m 'e) (esew '(eval))) @@ -1995,7 +1992,7 @@ (if (or (null? rest) (null? (cdr rest))) esew (cadr rest)) - (module-name (current-module))))))) + (cons 'hygiene (module-name (current-module)))))))) (set! identifier? (lambda (x) From d6ebfd72268878d64c583998ea9d57c0eb22996e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 13:30:57 +0200 Subject: [PATCH 069/375] finish transition to bare/hygiene/public/private * module/ice-9/boot-9.scm (make-module-ref): Remove the transition support. * module/ice-9/psyntax.scm (get-global-definition-hook): Remove transition support. Also remove support for guile-macro. (build-global-reference, build-global-assignment): Remove transition support. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/boot-9.scm | 4 ++-- module/ice-9/psyntax-pp.scm | 18 +++++++++--------- module/ice-9/psyntax.scm | 26 +++++++++----------------- 3 files changed, 20 insertions(+), 28 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index d9e7e5d0c..a10c125f7 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -134,8 +134,8 @@ (define sc-macro 'sc-macro) (define (make-module-ref mod var kind) (case kind - ((public #t) (if mod `(@ ,mod ,var) var)) - ((private #f) (if (and mod (not (equal? mod (module-name (current-module))))) + ((public) (if mod `(@ ,mod ,var) var)) + ((private) (if (and mod (not (equal? mod (module-name (current-module))))) `(@@ ,mod ,var) var)) ((bare) var) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index dd838c202..901574ca2 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (cons (quote hygiene) (module-name (procedure-module p1510)))))))) ((vector? x1517) (let ((n1522 (vector-length x1517))) (let ((v1523 (make-vector n1522))) (let doloop1524 ((i1525 0)) (if (fx=1100 i1525 n1522) v1523 (begin (vector-set! v1523 i1525 (rebuild-macro-output1516 (vector-ref x1517 i1525) m1518)) (doloop1524 (fx+1098 i1525 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1526 e1527 r1528 w1529 s1530 mod1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (e01534 e11535) (build-annotated1108 s1530 (cons x1526 (map (lambda (e1536) (chi1167 e1536 r1528 w1529 mod1531)) e11535)))) tmp1533) (syntax-error tmp1532))) (syntax-dispatch tmp1532 (quote (any . each-any))))) e1527))) (chi-expr1168 (lambda (type1538 value1539 e1540 r1541 w1542 s1543 mod1544) (let ((t1545 type1538)) (if (memv t1545 (quote (lexical))) (build-annotated1108 s1543 value1539) (if (memv t1545 (quote (core external-macro))) (value1539 e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (module-ref))) (call-with-values (lambda () (value1539 e1540)) (lambda (id1546 mod1547) (build-annotated1108 s1543 (cond ((not mod1547) (make-module-ref mod1547 id1546 (quote bare))) ((not (car mod1547)) (make-module-ref (cdr mod1547) id1546 (quote public))) ((memq (car mod1547) (quote (bare public private hygiene))) (make-module-ref (cdr mod1547) id1546 (car mod1547))) (else (make-module-ref mod1547 id1546 (quote private))))))) (if (memv t1545 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) value1539) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (global-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) (cond ((not (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 (quote bare))) ((not (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544))) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 (quote public))) ((memq (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) (quote (bare public private hygiene))) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)))) (else (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 (quote private))))) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (constant))) (build-data1109 s1543 (strip1178 (source-wrap1160 e1540 w1542 s1543 mod1544) (quote (())))) (if (memv t1545 (quote (global))) (build-annotated1108 s1543 (cond ((not mod1544) (make-module-ref mod1544 value1539 (quote bare))) ((not (car mod1544)) (make-module-ref (cdr mod1544) value1539 (quote public))) ((memq (car mod1544) (quote (bare public private hygiene))) (make-module-ref (cdr mod1544) value1539 (car mod1544))) (else (make-module-ref mod1544 value1539 (quote private))))) (if (memv t1545 (quote (call))) (chi-application1169 (chi1167 (car e1540) r1541 w1542 mod1544) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (begin-form))) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (_1550 e11551 e21552) (chi-sequence1161 (cons e11551 e21552) r1541 w1542 s1543 mod1544)) tmp1549) (syntax-error tmp1548))) (syntax-dispatch tmp1548 (quote (any any . each-any))))) e1540) (if (memv t1545 (quote (local-syntax-form))) (chi-local-syntax1173 value1539 e1540 r1541 w1542 s1543 mod1544 chi-sequence1161) (if (memv t1545 (quote (eval-when-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 x1557 e11558 e21559) (let ((when-list1560 (chi-when-list1164 e1540 x1557 w1542))) (if (memq (quote eval) when-list1560) (chi-sequence1161 (cons e11558 e21559) r1541 w1542 s1543 mod1544) (chi-void1175)))) tmp1555) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any each-any any . each-any))))) e1540) (if (memv t1545 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1539 w1542 mod1544) "invalid context for definition of") (if (memv t1545 (quote (syntax))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to pattern variable outside syntax form") (if (memv t1545 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544))))))))))))))))))) (chi1167 (lambda (e1563 r1564 w1565 mod1566) (call-with-values (lambda () (syntax-type1165 e1563 r1564 w1565 #f #f mod1566)) (lambda (type1567 value1568 e1569 w1570 s1571 mod1572) (chi-expr1168 type1567 value1568 e1569 r1564 w1570 s1571 mod1572))))) (chi-top1166 (lambda (e1573 r1574 w1575 m1576 esew1577 mod1578) (call-with-values (lambda () (syntax-type1165 e1573 r1574 w1575 #f #f mod1578)) (lambda (type1586 value1587 e1588 w1589 s1590 mod1591) (let ((t1592 type1586)) (if (memv t1592 (quote (begin-form))) ((lambda (tmp1593) ((lambda (tmp1594) (if tmp1594 (apply (lambda (_1595) (chi-void1175)) tmp1594) ((lambda (tmp1596) (if tmp1596 (apply (lambda (_1597 e11598 e21599) (chi-top-sequence1162 (cons e11598 e21599) r1574 w1589 s1590 m1576 esew1577 mod1591)) tmp1596) (syntax-error tmp1593))) (syntax-dispatch tmp1593 (quote (any any . each-any)))))) (syntax-dispatch tmp1593 (quote (any))))) e1588) (if (memv t1592 (quote (local-syntax-form))) (chi-local-syntax1173 value1587 e1588 r1574 w1589 s1590 mod1591 (lambda (body1601 r1602 w1603 s1604 mod1605) (chi-top-sequence1162 body1601 r1602 w1603 s1604 m1576 esew1577 mod1605))) (if (memv t1592 (quote (eval-when-form))) ((lambda (tmp1606) ((lambda (tmp1607) (if tmp1607 (apply (lambda (_1608 x1609 e11610 e21611) (let ((when-list1612 (chi-when-list1164 e1588 x1609 w1589)) (body1613 (cons e11610 e21611))) (cond ((eq? m1576 (quote e)) (if (memq (quote eval) when-list1612) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) (chi-void1175))) ((memq (quote load) when-list1612) (if (or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c&e) (quote (compile load)) mod1591) (if (memq m1576 (quote (c c&e))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c) (quote (load)) mod1591) (chi-void1175)))) ((or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (top-level-eval-hook1102 (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) mod1591) (chi-void1175)) (else (chi-void1175))))) tmp1607) (syntax-error tmp1606))) (syntax-dispatch tmp1606 (quote (any each-any any . each-any))))) e1588) (if (memv t1592 (quote (define-syntax-form))) (let ((n1616 (id-var-name1153 value1587 w1589)) (r1617 (macros-only-env1127 r1574))) (let ((t1618 m1576)) (if (memv t1618 (quote (c))) (if (memq (quote compile) esew1577) (let ((e1619 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1619 mod1591) (if (memq (quote load) esew1577) e1619 (chi-void1175)))) (if (memq (quote load) esew1577) (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) (chi-void1175))) (if (memv t1618 (quote (c&e))) (let ((e1620 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1620 mod1591) e1620)) (begin (if (memq (quote eval) esew1577) (top-level-eval-hook1102 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) mod1591)) (chi-void1175)))))) (if (memv t1592 (quote (define-form))) (let ((n1621 (id-var-name1153 value1587 w1589))) (let ((type1622 (binding-type1123 (lookup1128 n1621 r1574 mod1591)))) (let ((t1623 type1622)) (if (memv t1623 (quote (global))) (let ((x1624 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1624 mod1591)) x1624)) (if (memv t1623 (quote (displaced-lexical))) (syntax-error (wrap1159 value1587 w1589 mod1591) "identifier out of context") (if (memv t1623 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1621) (let ((x1625 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1625 mod1591)) x1625))) (syntax-error (wrap1159 value1587 w1589 mod1591) "cannot define keyword at top level"))))))) (let ((x1626 (chi-expr1168 type1586 value1587 e1588 r1574 w1589 s1590 mod1591))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1626 mod1591)) x1626)))))))))))) (syntax-type1165 (lambda (e1627 r1628 w1629 s1630 rib1631 mod1632) (cond ((symbol? e1627) (let ((n1633 (id-var-name1153 e1627 w1629))) (let ((b1634 (lookup1128 n1633 r1628 mod1632))) (let ((type1635 (binding-type1123 b1634))) (let ((t1636 type1635)) (if (memv t1636 (quote (lexical))) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (global))) (values type1635 n1633 e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1634) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632))))))))) ((pair? e1627) (let ((first1637 (car e1627))) (if (id?1131 first1637) (let ((n1638 (id-var-name1153 first1637 w1629))) (let ((b1639 (lookup1128 n1638 r1628 (or (and (syntax-object?1115 first1637) (syntax-object-module1118 first1637)) mod1632)))) (let ((type1640 (binding-type1123 b1639))) (let ((t1641 type1640)) (if (memv t1641 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (global))) (values (quote global-call) n1638 e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1639) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (if (memv t1641 (quote (core external-macro module-ref))) (values type1640 (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (begin))) (values (quote begin-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (eval-when))) (values (quote eval-when-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (define))) ((lambda (tmp1642) ((lambda (tmp1643) (if (if tmp1643 (apply (lambda (_1644 name1645 val1646) (id?1131 name1645)) tmp1643) #f) (apply (lambda (_1647 name1648 val1649) (values (quote define-form) name1648 val1649 w1629 s1630 mod1632)) tmp1643) ((lambda (tmp1650) (if (if tmp1650 (apply (lambda (_1651 name1652 args1653 e11654 e21655) (and (id?1131 name1652) (valid-bound-ids?1156 (lambda-var-list1180 args1653)))) tmp1650) #f) (apply (lambda (_1656 name1657 args1658 e11659 e21660) (values (quote define-form) (wrap1159 name1657 w1629 mod1632) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) (wrap1159 (cons args1658 (cons e11659 e21660)) w1629 mod1632)) (quote (())) s1630 mod1632)) tmp1650) ((lambda (tmp1662) (if (if tmp1662 (apply (lambda (_1663 name1664) (id?1131 name1664)) tmp1662) #f) (apply (lambda (_1665 name1666) (values (quote define-form) (wrap1159 name1666 w1629 mod1632) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote (())) s1630 mod1632)) tmp1662) (syntax-error tmp1642))) (syntax-dispatch tmp1642 (quote (any any)))))) (syntax-dispatch tmp1642 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1642 (quote (any any any))))) e1627) (if (memv t1641 (quote (define-syntax))) ((lambda (tmp1667) ((lambda (tmp1668) (if (if tmp1668 (apply (lambda (_1669 name1670 val1671) (id?1131 name1670)) tmp1668) #f) (apply (lambda (_1672 name1673 val1674) (values (quote define-syntax-form) name1673 val1674 w1629 s1630 mod1632)) tmp1668) (syntax-error tmp1667))) (syntax-dispatch tmp1667 (quote (any any any))))) e1627) (values (quote call) #f e1627 w1629 s1630 mod1632)))))))))))))) (values (quote call) #f e1627 w1629 s1630 mod1632)))) ((syntax-object?1115 e1627) (syntax-type1165 (syntax-object-expression1116 e1627) r1628 (join-wraps1150 w1629 (syntax-object-wrap1117 e1627)) #f rib1631 (or (syntax-object-module1118 e1627) mod1632))) ((annotation? e1627) (syntax-type1165 (annotation-expression e1627) r1628 w1629 (annotation-source e1627) rib1631 mod1632)) ((self-evaluating? e1627) (values (quote constant) #f e1627 w1629 s1630 mod1632)) (else (values (quote other) #f e1627 w1629 s1630 mod1632))))) (chi-when-list1164 (lambda (e1675 when-list1676 w1677) (let f1678 ((when-list1679 when-list1676) (situations1680 (quote ()))) (if (null? when-list1679) situations1680 (f1678 (cdr when-list1679) (cons (let ((x1681 (car when-list1679))) (cond ((free-id=?1154 x1681 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote compile)) ((free-id=?1154 x1681 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote load)) ((free-id=?1154 x1681 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile)))) (quote eval)) (else (syntax-error (wrap1159 x1681 w1677 #f) "invalid eval-when situation")))) situations1680)))))) (chi-install-global1163 (lambda (name1682 e1683) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1682) e1683)))) (chi-top-sequence1162 (lambda (body1684 r1685 w1686 s1687 m1688 esew1689 mod1690) (build-sequence1110 s1687 (let dobody1691 ((body1692 body1684) (r1693 r1685) (w1694 w1686) (m1695 m1688) (esew1696 esew1689) (mod1697 mod1690)) (if (null? body1692) (quote ()) (let ((first1698 (chi-top1166 (car body1692) r1693 w1694 m1695 esew1696 mod1697))) (cons first1698 (dobody1691 (cdr body1692) r1693 w1694 m1695 esew1696 mod1697)))))))) (chi-sequence1161 (lambda (body1699 r1700 w1701 s1702 mod1703) (build-sequence1110 s1702 (let dobody1704 ((body1705 body1699) (r1706 r1700) (w1707 w1701) (mod1708 mod1703)) (if (null? body1705) (quote ()) (let ((first1709 (chi1167 (car body1705) r1706 w1707 mod1708))) (cons first1709 (dobody1704 (cdr body1705) r1706 w1707 mod1708)))))))) (source-wrap1160 (lambda (x1710 w1711 s1712 defmod1713) (wrap1159 (if s1712 (make-annotation x1710 s1712 #f) x1710) w1711 defmod1713))) (wrap1159 (lambda (x1714 w1715 defmod1716) (cond ((and (null? (wrap-marks1134 w1715)) (null? (wrap-subst1135 w1715))) x1714) ((syntax-object?1115 x1714) (make-syntax-object1114 (syntax-object-expression1116 x1714) (join-wraps1150 w1715 (syntax-object-wrap1117 x1714)) (syntax-object-module1118 x1714))) ((null? x1714) x1714) (else (make-syntax-object1114 x1714 w1715 defmod1716))))) (bound-id-member?1158 (lambda (x1717 list1718) (and (not (null? list1718)) (or (bound-id=?1155 x1717 (car list1718)) (bound-id-member?1158 x1717 (cdr list1718)))))) (distinct-bound-ids?1157 (lambda (ids1719) (let distinct?1720 ((ids1721 ids1719)) (or (null? ids1721) (and (not (bound-id-member?1158 (car ids1721) (cdr ids1721))) (distinct?1720 (cdr ids1721))))))) (valid-bound-ids?1156 (lambda (ids1722) (and (let all-ids?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (id?1131 (car ids1724)) (all-ids?1723 (cdr ids1724))))) (distinct-bound-ids?1157 ids1722)))) (bound-id=?1155 (lambda (i1725 j1726) (if (and (syntax-object?1115 i1725) (syntax-object?1115 j1726)) (and (eq? (let ((e1727 (syntax-object-expression1116 i1725))) (if (annotation? e1727) (annotation-expression e1727) e1727)) (let ((e1728 (syntax-object-expression1116 j1726))) (if (annotation? e1728) (annotation-expression e1728) e1728))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1725)) (wrap-marks1134 (syntax-object-wrap1117 j1726)))) (eq? (let ((e1729 i1725)) (if (annotation? e1729) (annotation-expression e1729) e1729)) (let ((e1730 j1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)))))) (free-id=?1154 (lambda (i1731 j1732) (and (eq? (let ((x1733 i1731)) (let ((e1734 (if (syntax-object?1115 x1733) (syntax-object-expression1116 x1733) x1733))) (if (annotation? e1734) (annotation-expression e1734) e1734))) (let ((x1735 j1732)) (let ((e1736 (if (syntax-object?1115 x1735) (syntax-object-expression1116 x1735) x1735))) (if (annotation? e1736) (annotation-expression e1736) e1736)))) (eq? (id-var-name1153 i1731 (quote (()))) (id-var-name1153 j1732 (quote (()))))))) (id-var-name1153 (lambda (id1737 w1738) (letrec ((search-vector-rib1741 (lambda (sym1747 subst1748 marks1749 symnames1750 ribcage1751) (let ((n1752 (vector-length symnames1750))) (let f1753 ((i1754 0)) (cond ((fx=1100 i1754 n1752) (search1739 sym1747 (cdr subst1748) marks1749)) ((and (eq? (vector-ref symnames1750 i1754) sym1747) (same-marks?1152 marks1749 (vector-ref (ribcage-marks1141 ribcage1751) i1754))) (values (vector-ref (ribcage-labels1142 ribcage1751) i1754) marks1749)) (else (f1753 (fx+1098 i1754 1)))))))) (search-list-rib1740 (lambda (sym1755 subst1756 marks1757 symnames1758 ribcage1759) (let f1760 ((symnames1761 symnames1758) (i1762 0)) (cond ((null? symnames1761) (search1739 sym1755 (cdr subst1756) marks1757)) ((and (eq? (car symnames1761) sym1755) (same-marks?1152 marks1757 (list-ref (ribcage-marks1141 ribcage1759) i1762))) (values (list-ref (ribcage-labels1142 ribcage1759) i1762) marks1757)) (else (f1760 (cdr symnames1761) (fx+1098 i1762 1))))))) (search1739 (lambda (sym1763 subst1764 marks1765) (if (null? subst1764) (values #f marks1765) (let ((fst1766 (car subst1764))) (if (eq? fst1766 (quote shift)) (search1739 sym1763 (cdr subst1764) (cdr marks1765)) (let ((symnames1767 (ribcage-symnames1140 fst1766))) (if (vector? symnames1767) (search-vector-rib1741 sym1763 subst1764 marks1765 symnames1767 fst1766) (search-list-rib1740 sym1763 subst1764 marks1765 symnames1767 fst1766))))))))) (cond ((symbol? id1737) (or (call-with-values (lambda () (search1739 id1737 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1769 . ignore1768) x1769)) id1737)) ((syntax-object?1115 id1737) (let ((id1770 (let ((e1772 (syntax-object-expression1116 id1737))) (if (annotation? e1772) (annotation-expression e1772) e1772))) (w11771 (syntax-object-wrap1117 id1737))) (let ((marks1773 (join-marks1151 (wrap-marks1134 w1738) (wrap-marks1134 w11771)))) (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w1738) marks1773)) (lambda (new-id1774 marks1775) (or new-id1774 (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w11771) marks1775)) (lambda (x1777 . ignore1776) x1777)) id1770)))))) ((annotation? id1737) (let ((id1778 (let ((e1779 id1737)) (if (annotation? e1779) (annotation-expression e1779) e1779)))) (or (call-with-values (lambda () (search1739 id1778 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1781 . ignore1780) x1781)) id1778))) (else (error-hook1104 (quote id-var-name) "invalid id" id1737)))))) (same-marks?1152 (lambda (x1782 y1783) (or (eq? x1782 y1783) (and (not (null? x1782)) (not (null? y1783)) (eq? (car x1782) (car y1783)) (same-marks?1152 (cdr x1782) (cdr y1783)))))) (join-marks1151 (lambda (m11784 m21785) (smart-append1149 m11784 m21785))) (join-wraps1150 (lambda (w11786 w21787) (let ((m11788 (wrap-marks1134 w11786)) (s11789 (wrap-subst1135 w11786))) (if (null? m11788) (if (null? s11789) w21787 (make-wrap1133 (wrap-marks1134 w21787) (smart-append1149 s11789 (wrap-subst1135 w21787)))) (make-wrap1133 (smart-append1149 m11788 (wrap-marks1134 w21787)) (smart-append1149 s11789 (wrap-subst1135 w21787))))))) (smart-append1149 (lambda (m11790 m21791) (if (null? m21791) m11790 (append m11790 m21791)))) (make-binding-wrap1148 (lambda (ids1792 labels1793 w1794) (if (null? ids1792) w1794 (make-wrap1133 (wrap-marks1134 w1794) (cons (let ((labelvec1795 (list->vector labels1793))) (let ((n1796 (vector-length labelvec1795))) (let ((symnamevec1797 (make-vector n1796)) (marksvec1798 (make-vector n1796))) (begin (let f1799 ((ids1800 ids1792) (i1801 0)) (if (not (null? ids1800)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1800) w1794)) (lambda (symname1802 marks1803) (begin (vector-set! symnamevec1797 i1801 symname1802) (vector-set! marksvec1798 i1801 marks1803) (f1799 (cdr ids1800) (fx+1098 i1801 1))))))) (make-ribcage1138 symnamevec1797 marksvec1798 labelvec1795))))) (wrap-subst1135 w1794)))))) (extend-ribcage!1147 (lambda (ribcage1804 id1805 label1806) (begin (set-ribcage-symnames!1143 ribcage1804 (cons (let ((e1807 (syntax-object-expression1116 id1805))) (if (annotation? e1807) (annotation-expression e1807) e1807)) (ribcage-symnames1140 ribcage1804))) (set-ribcage-marks!1144 ribcage1804 (cons (wrap-marks1134 (syntax-object-wrap1117 id1805)) (ribcage-marks1141 ribcage1804))) (set-ribcage-labels!1145 ribcage1804 (cons label1806 (ribcage-labels1142 ribcage1804)))))) (anti-mark1146 (lambda (w1808) (make-wrap1133 (cons #f (wrap-marks1134 w1808)) (cons (quote shift) (wrap-subst1135 w1808))))) (set-ribcage-labels!1145 (lambda (x1809 update1810) (vector-set! x1809 3 update1810))) (set-ribcage-marks!1144 (lambda (x1811 update1812) (vector-set! x1811 2 update1812))) (set-ribcage-symnames!1143 (lambda (x1813 update1814) (vector-set! x1813 1 update1814))) (ribcage-labels1142 (lambda (x1815) (vector-ref x1815 3))) (ribcage-marks1141 (lambda (x1816) (vector-ref x1816 2))) (ribcage-symnames1140 (lambda (x1817) (vector-ref x1817 1))) (ribcage?1139 (lambda (x1818) (and (vector? x1818) (= (vector-length x1818) 4) (eq? (vector-ref x1818 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1819 marks1820 labels1821) (vector (quote ribcage) symnames1819 marks1820 labels1821))) (gen-labels1137 (lambda (ls1822) (if (null? ls1822) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1822)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1823 w1824) (if (syntax-object?1115 x1823) (values (let ((e1825 (syntax-object-expression1116 x1823))) (if (annotation? e1825) (annotation-expression e1825) e1825)) (join-marks1151 (wrap-marks1134 w1824) (wrap-marks1134 (syntax-object-wrap1117 x1823)))) (values (let ((e1826 x1823)) (if (annotation? e1826) (annotation-expression e1826) e1826)) (wrap-marks1134 w1824))))) (id?1131 (lambda (x1827) (cond ((symbol? x1827) #t) ((syntax-object?1115 x1827) (symbol? (let ((e1828 (syntax-object-expression1116 x1827))) (if (annotation? e1828) (annotation-expression e1828) e1828)))) ((annotation? x1827) (symbol? (annotation-expression x1827))) (else #f)))) (nonsymbol-id?1130 (lambda (x1829) (and (syntax-object?1115 x1829) (symbol? (let ((e1830 (syntax-object-expression1116 x1829))) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (global-extend1129 (lambda (type1831 sym1832 val1833) (put-global-definition-hook1105 sym1832 (cons type1831 val1833)))) (lookup1128 (lambda (x1834 r1835 mod1836) (cond ((assq x1834 r1835) => cdr) ((symbol? x1834) (or (get-global-definition-hook1107 x1834 mod1836) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1837) (if (null? r1837) (quote ()) (let ((a1838 (car r1837))) (if (eq? (cadr a1838) (quote macro)) (cons a1838 (macros-only-env1127 (cdr r1837))) (macros-only-env1127 (cdr r1837))))))) (extend-var-env1126 (lambda (labels1839 vars1840 r1841) (if (null? labels1839) r1841 (extend-var-env1126 (cdr labels1839) (cdr vars1840) (cons (cons (car labels1839) (cons (quote lexical) (car vars1840))) r1841))))) (extend-env1125 (lambda (labels1842 bindings1843 r1844) (if (null? labels1842) r1844 (extend-env1125 (cdr labels1842) (cdr bindings1843) (cons (cons (car labels1842) (car bindings1843)) r1844))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1845) (cond ((annotation? x1845) (annotation-source x1845)) ((syntax-object?1115 x1845) (source-annotation1122 (syntax-object-expression1116 x1845))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1846 update1847) (vector-set! x1846 3 update1847))) (set-syntax-object-wrap!1120 (lambda (x1848 update1849) (vector-set! x1848 2 update1849))) (set-syntax-object-expression!1119 (lambda (x1850 update1851) (vector-set! x1850 1 update1851))) (syntax-object-module1118 (lambda (x1852) (vector-ref x1852 3))) (syntax-object-wrap1117 (lambda (x1853) (vector-ref x1853 2))) (syntax-object-expression1116 (lambda (x1854) (vector-ref x1854 1))) (syntax-object?1115 (lambda (x1855) (and (vector? x1855) (= (vector-length x1855) 4) (eq? (vector-ref x1855 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1856 wrap1857 module1858) (vector (quote syntax-object) expression1856 wrap1857 module1858))) (build-letrec1113 (lambda (src1859 vars1860 val-exps1861 body-exp1862) (if (null? vars1860) (build-annotated1108 src1859 body-exp1862) (build-annotated1108 src1859 (list (quote letrec) (map list vars1860 val-exps1861) body-exp1862))))) (build-named-let1112 (lambda (src1863 vars1864 val-exps1865 body-exp1866) (if (null? vars1864) (build-annotated1108 src1863 body-exp1866) (build-annotated1108 src1863 (list (quote let) (car vars1864) (map list (cdr vars1864) val-exps1865) body-exp1866))))) (build-let1111 (lambda (src1867 vars1868 val-exps1869 body-exp1870) (if (null? vars1868) (build-annotated1108 src1867 body-exp1870) (build-annotated1108 src1867 (list (quote let) (map list vars1868 val-exps1869) body-exp1870))))) (build-sequence1110 (lambda (src1871 exps1872) (if (null? (cdr exps1872)) (build-annotated1108 src1871 (car exps1872)) (build-annotated1108 src1871 (cons (quote begin) exps1872))))) (build-data1109 (lambda (src1873 exp1874) (if (and (self-evaluating? exp1874) (not (vector? exp1874))) (build-annotated1108 src1873 exp1874) (build-annotated1108 src1873 (list (quote quote) exp1874))))) (build-annotated1108 (lambda (src1875 exp1876) (if (and src1875 (not (annotation? exp1876))) (make-annotation exp1876 src1875 #t) exp1876))) (get-global-definition-hook1107 (lambda (symbol1877 module1878) (let ((module1879 (if module1878 (resolve-module (if (memq (car module1878) (quote (#f hygiene public private bare))) (cdr module1878) module1878)) (let ((mod1880 (current-module))) (begin (if mod1880 (warn "wha" symbol1877)) mod1880))))) (let ((v1881 (module-variable module1879 symbol1877))) (and v1881 (or (object-property v1881 (quote *sc-expander*)) (and (variable-bound? v1881) (macro? (variable-ref v1881)) (macro-transformer (variable-ref v1881)) guile-macro))))))) (remove-global-definition-hook1106 (lambda (symbol1882) (let ((module1883 (current-module))) (let ((v1884 (module-local-variable module1883 symbol1882))) (if v1884 (let ((p1885 (assq (quote *sc-expander*) (object-properties v1884)))) (set-object-properties! v1884 (delq p1885 (object-properties v1884))))))))) (put-global-definition-hook1105 (lambda (symbol1886 binding1887) (let ((module1888 (current-module))) (let ((v1889 (or (module-variable module1888 symbol1886) (let ((v1890 (make-variable (gensym)))) (begin (module-add! module1888 symbol1886 v1890) v1890))))) (begin (if (not (variable-bound? v1889)) (variable-set! v1889 (gensym))) (set-object-property! v1889 (quote *sc-expander*) binding1887)))))) (error-hook1104 (lambda (who1891 why1892 what1893) (error who1891 "~a ~s" why1892 what1893))) (local-eval-hook1103 (lambda (x1894 mod1895) (primitive-eval (list noexpand1097 x1894)))) (top-level-eval-hook1102 (lambda (x1896 mod1897) (primitive-eval (list noexpand1097 x1896)))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1898 r1899 w1900 s1901 mod1902) ((lambda (tmp1903) ((lambda (tmp1904) (if (if tmp1904 (apply (lambda (_1905 var1906 val1907 e11908 e21909) (valid-bound-ids?1156 var1906)) tmp1904) #f) (apply (lambda (_1911 var1912 val1913 e11914 e21915) (let ((names1916 (map (lambda (x1917) (id-var-name1153 x1917 w1900)) var1912))) (begin (for-each (lambda (id1919 n1920) (let ((t1921 (binding-type1123 (lookup1128 n1920 r1899 mod1902)))) (if (memv t1921 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1919 w1900 s1901 mod1902) "identifier out of context")))) var1912 names1916) (chi-body1171 (cons e11914 e21915) (source-wrap1160 e1898 w1900 s1901 mod1902) (extend-env1125 names1916 (let ((trans-r1924 (macros-only-env1127 r1899))) (map (lambda (x1925) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1925 trans-r1924 w1900 mod1902) mod1902))) val1913)) r1899) w1900 mod1902)))) tmp1904) ((lambda (_1927) (syntax-error (source-wrap1160 e1898 w1900 s1901 mod1902))) tmp1903))) (syntax-dispatch tmp1903 (quote (any #(each (any any)) any . each-any))))) e1898))) (global-extend1129 (quote core) (quote quote) (lambda (e1928 r1929 w1930 s1931 mod1932) ((lambda (tmp1933) ((lambda (tmp1934) (if tmp1934 (apply (lambda (_1935 e1936) (build-data1109 s1931 (strip1178 e1936 w1930))) tmp1934) ((lambda (_1937) (syntax-error (source-wrap1160 e1928 w1930 s1931 mod1932))) tmp1933))) (syntax-dispatch tmp1933 (quote (any any))))) e1928))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1945 (lambda (x1946) (let ((t1947 (car x1946))) (if (memv t1947 (quote (ref))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (primitive))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (quote))) (build-data1109 #f (cadr x1946)) (if (memv t1947 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1946) (regen1945 (caddr x1946)))) (if (memv t1947 (quote (map))) (let ((ls1948 (map regen1945 (cdr x1946)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1948) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1948))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1946)) (map regen1945 (cdr x1946)))))))))))) (gen-vector1944 (lambda (x1949) (cond ((eq? (car x1949) (quote list)) (cons (quote vector) (cdr x1949))) ((eq? (car x1949) (quote quote)) (list (quote quote) (list->vector (cadr x1949)))) (else (list (quote list->vector) x1949))))) (gen-append1943 (lambda (x1950 y1951) (if (equal? y1951 (quote (quote ()))) x1950 (list (quote append) x1950 y1951)))) (gen-cons1942 (lambda (x1952 y1953) (let ((t1954 (car y1953))) (if (memv t1954 (quote (quote))) (if (eq? (car x1952) (quote quote)) (list (quote quote) (cons (cadr x1952) (cadr y1953))) (if (eq? (cadr y1953) (quote ())) (list (quote list) x1952) (list (quote cons) x1952 y1953))) (if (memv t1954 (quote (list))) (cons (quote list) (cons x1952 (cdr y1953))) (list (quote cons) x1952 y1953)))))) (gen-map1941 (lambda (e1955 map-env1956) (let ((formals1957 (map cdr map-env1956)) (actuals1958 (map (lambda (x1959) (list (quote ref) (car x1959))) map-env1956))) (cond ((eq? (car e1955) (quote ref)) (car actuals1958)) ((andmap (lambda (x1960) (and (eq? (car x1960) (quote ref)) (memq (cadr x1960) formals1957))) (cdr e1955)) (cons (quote map) (cons (list (quote primitive) (car e1955)) (map (let ((r1961 (map cons formals1957 actuals1958))) (lambda (x1962) (cdr (assq (cadr x1962) r1961)))) (cdr e1955))))) (else (cons (quote map) (cons (list (quote lambda) formals1957 e1955) actuals1958))))))) (gen-mappend1940 (lambda (e1963 map-env1964) (list (quote apply) (quote (primitive append)) (gen-map1941 e1963 map-env1964)))) (gen-ref1939 (lambda (src1965 var1966 level1967 maps1968) (if (fx=1100 level1967 0) (values var1966 maps1968) (if (null? maps1968) (syntax-error src1965 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1939 src1965 var1966 (fx-1099 level1967 1) (cdr maps1968))) (lambda (outer-var1969 outer-maps1970) (let ((b1971 (assq outer-var1969 (car maps1968)))) (if b1971 (values (cdr b1971) maps1968) (let ((inner-var1972 (gen-var1179 (quote tmp)))) (values inner-var1972 (cons (cons (cons outer-var1969 inner-var1972) (car maps1968)) outer-maps1970))))))))))) (gen-syntax1938 (lambda (src1973 e1974 r1975 maps1976 ellipsis?1977 mod1978) (if (id?1131 e1974) (let ((label1979 (id-var-name1153 e1974 (quote (()))))) (let ((b1980 (lookup1128 label1979 r1975 mod1978))) (if (eq? (binding-type1123 b1980) (quote syntax)) (call-with-values (lambda () (let ((var.lev1981 (binding-value1124 b1980))) (gen-ref1939 src1973 (car var.lev1981) (cdr var.lev1981) maps1976))) (lambda (var1982 maps1983) (values (list (quote ref) var1982) maps1983))) (if (ellipsis?1977 e1974) (syntax-error src1973 "misplaced ellipsis in syntax form") (values (list (quote quote) e1974) maps1976))))) ((lambda (tmp1984) ((lambda (tmp1985) (if (if tmp1985 (apply (lambda (dots1986 e1987) (ellipsis?1977 dots1986)) tmp1985) #f) (apply (lambda (dots1988 e1989) (gen-syntax1938 src1973 e1989 r1975 maps1976 (lambda (x1990) #f) mod1978)) tmp1985) ((lambda (tmp1991) (if (if tmp1991 (apply (lambda (x1992 dots1993 y1994) (ellipsis?1977 dots1993)) tmp1991) #f) (apply (lambda (x1995 dots1996 y1997) (let f1998 ((y1999 y1997) (k2000 (lambda (maps2001) (call-with-values (lambda () (gen-syntax1938 src1973 x1995 r1975 (cons (quote ()) maps2001) ellipsis?1977 mod1978)) (lambda (x2002 maps2003) (if (null? (car maps2003)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-map1941 x2002 (car maps2003)) (cdr maps2003)))))))) ((lambda (tmp2004) ((lambda (tmp2005) (if (if tmp2005 (apply (lambda (dots2006 y2007) (ellipsis?1977 dots2006)) tmp2005) #f) (apply (lambda (dots2008 y2009) (f1998 y2009 (lambda (maps2010) (call-with-values (lambda () (k2000 (cons (quote ()) maps2010))) (lambda (x2011 maps2012) (if (null? (car maps2012)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-mappend1940 x2011 (car maps2012)) (cdr maps2012)))))))) tmp2005) ((lambda (_2013) (call-with-values (lambda () (gen-syntax1938 src1973 y1999 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (y2014 maps2015) (call-with-values (lambda () (k2000 maps2015)) (lambda (x2016 maps2017) (values (gen-append1943 x2016 y2014) maps2017)))))) tmp2004))) (syntax-dispatch tmp2004 (quote (any . any))))) y1999))) tmp1991) ((lambda (tmp2018) (if tmp2018 (apply (lambda (x2019 y2020) (call-with-values (lambda () (gen-syntax1938 src1973 x2019 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (x2021 maps2022) (call-with-values (lambda () (gen-syntax1938 src1973 y2020 r1975 maps2022 ellipsis?1977 mod1978)) (lambda (y2023 maps2024) (values (gen-cons1942 x2021 y2023) maps2024)))))) tmp2018) ((lambda (tmp2025) (if tmp2025 (apply (lambda (e12026 e22027) (call-with-values (lambda () (gen-syntax1938 src1973 (cons e12026 e22027) r1975 maps1976 ellipsis?1977 mod1978)) (lambda (e2029 maps2030) (values (gen-vector1944 e2029) maps2030)))) tmp2025) ((lambda (_2031) (values (list (quote quote) e1974) maps1976)) tmp1984))) (syntax-dispatch tmp1984 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1984 (quote (any . any)))))) (syntax-dispatch tmp1984 (quote (any any . any)))))) (syntax-dispatch tmp1984 (quote (any any))))) e1974))))) (lambda (e2032 r2033 w2034 s2035 mod2036) (let ((e2037 (source-wrap1160 e2032 w2034 s2035 mod2036))) ((lambda (tmp2038) ((lambda (tmp2039) (if tmp2039 (apply (lambda (_2040 x2041) (call-with-values (lambda () (gen-syntax1938 e2037 x2041 r2033 (quote ()) ellipsis?1176 mod2036)) (lambda (e2042 maps2043) (regen1945 e2042)))) tmp2039) ((lambda (_2044) (syntax-error e2037)) tmp2038))) (syntax-dispatch tmp2038 (quote (any any))))) e2037))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2045 r2046 w2047 s2048 mod2049) ((lambda (tmp2050) ((lambda (tmp2051) (if tmp2051 (apply (lambda (_2052 c2053) (chi-lambda-clause1172 (source-wrap1160 e2045 w2047 s2048 mod2049) c2053 r2046 w2047 mod2049 (lambda (vars2054 body2055) (build-annotated1108 s2048 (list (quote lambda) vars2054 body2055))))) tmp2051) (syntax-error tmp2050))) (syntax-dispatch tmp2050 (quote (any . any))))) e2045))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2056 (lambda (e2057 r2058 w2059 s2060 mod2061 constructor2062 ids2063 vals2064 exps2065) (if (not (valid-bound-ids?1156 ids2063)) (syntax-error e2057 "duplicate bound variable in") (let ((labels2066 (gen-labels1137 ids2063)) (new-vars2067 (map gen-var1179 ids2063))) (let ((nw2068 (make-binding-wrap1148 ids2063 labels2066 w2059)) (nr2069 (extend-var-env1126 labels2066 new-vars2067 r2058))) (constructor2062 s2060 new-vars2067 (map (lambda (x2070) (chi1167 x2070 r2058 w2059 mod2061)) vals2064) (chi-body1171 exps2065 (source-wrap1160 e2057 nw2068 s2060 mod2061) nr2069 nw2068 mod2061)))))))) (lambda (e2071 r2072 w2073 s2074 mod2075) ((lambda (tmp2076) ((lambda (tmp2077) (if tmp2077 (apply (lambda (_2078 id2079 val2080 e12081 e22082) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-let1111 id2079 val2080 (cons e12081 e22082))) tmp2077) ((lambda (tmp2086) (if (if tmp2086 (apply (lambda (_2087 f2088 id2089 val2090 e12091 e22092) (id?1131 f2088)) tmp2086) #f) (apply (lambda (_2093 f2094 id2095 val2096 e12097 e22098) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-named-let1112 (cons f2094 id2095) val2096 (cons e12097 e22098))) tmp2086) ((lambda (_2102) (syntax-error (source-wrap1160 e2071 w2073 s2074 mod2075))) tmp2076))) (syntax-dispatch tmp2076 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2076 (quote (any #(each (any any)) any . each-any))))) e2071)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2103 r2104 w2105 s2106 mod2107) ((lambda (tmp2108) ((lambda (tmp2109) (if tmp2109 (apply (lambda (_2110 id2111 val2112 e12113 e22114) (let ((ids2115 id2111)) (if (not (valid-bound-ids?1156 ids2115)) (syntax-error e2103 "duplicate bound variable in") (let ((labels2117 (gen-labels1137 ids2115)) (new-vars2118 (map gen-var1179 ids2115))) (let ((w2119 (make-binding-wrap1148 ids2115 labels2117 w2105)) (r2120 (extend-var-env1126 labels2117 new-vars2118 r2104))) (build-letrec1113 s2106 new-vars2118 (map (lambda (x2121) (chi1167 x2121 r2120 w2119 mod2107)) val2112) (chi-body1171 (cons e12113 e22114) (source-wrap1160 e2103 w2119 s2106 mod2107) r2120 w2119 mod2107))))))) tmp2109) ((lambda (_2124) (syntax-error (source-wrap1160 e2103 w2105 s2106 mod2107))) tmp2108))) (syntax-dispatch tmp2108 (quote (any #(each (any any)) any . each-any))))) e2103))) (global-extend1129 (quote core) (quote set!) (lambda (e2125 r2126 w2127 s2128 mod2129) ((lambda (tmp2130) ((lambda (tmp2131) (if (if tmp2131 (apply (lambda (_2132 id2133 val2134) (id?1131 id2133)) tmp2131) #f) (apply (lambda (_2135 id2136 val2137) (let ((val2138 (chi1167 val2137 r2126 w2127 mod2129)) (n2139 (id-var-name1153 id2136 w2127))) (let ((b2140 (lookup1128 n2139 r2126 mod2129))) (let ((t2141 (binding-type1123 b2140))) (if (memv t2141 (quote (lexical))) (build-annotated1108 s2128 (list (quote set!) (binding-value1124 b2140) val2138)) (if (memv t2141 (quote (global))) (build-annotated1108 s2128 (list (quote set!) (cond ((not mod2129) (make-module-ref mod2129 n2139 (quote bare))) ((not (car mod2129)) (make-module-ref (cdr mod2129) n2139 (quote public))) ((memq (car mod2129) (quote (bare public private hygiene))) (make-module-ref (cdr mod2129) n2139 (car mod2129))) (else (make-module-ref mod2129 n2139 (quote private)))) val2138)) (if (memv t2141 (quote (displaced-lexical))) (syntax-error (wrap1159 id2136 w2127 mod2129) "identifier out of context") (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))))))))) tmp2131) ((lambda (tmp2142) (if tmp2142 (apply (lambda (_2143 head2144 tail2145 val2146) (call-with-values (lambda () (syntax-type1165 head2144 r2126 (quote (())) #f #f mod2129)) (lambda (type2147 value2148 ee2149 ww2150 ss2151 modmod2152) (let ((t2153 type2147)) (if (memv t2153 (quote (module-ref))) (let ((val2154 (chi1167 val2146 r2126 w2127 mod2129))) (call-with-values (lambda () (value2148 (cons head2144 tail2145))) (lambda (id2156 mod2157) (build-annotated1108 s2128 (list (quote set!) (cond ((not mod2157) (make-module-ref mod2157 id2156 (quote bare))) ((not (car mod2157)) (make-module-ref (cdr mod2157) id2156 (quote public))) ((memq (car mod2157) (quote (bare public private hygiene))) (make-module-ref (cdr mod2157) id2156 (car mod2157))) (else (make-module-ref mod2157 id2156 (quote private)))) val2154))))) (build-annotated1108 s2128 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) head2144) r2126 w2127 mod2129) (map (lambda (e2158) (chi1167 e2158 r2126 w2127 mod2129)) (append tail2145 (list val2146)))))))))) tmp2142) ((lambda (_2160) (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))) tmp2130))) (syntax-dispatch tmp2130 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2130 (quote (any any any))))) e2125))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2161) ((lambda (tmp2162) ((lambda (tmp2163) (if (if tmp2163 (apply (lambda (_2164 mod2165 id2166) (and (andmap id?1131 mod2165) (id?1131 id2166))) tmp2163) #f) (apply (lambda (_2168 mod2169 id2170) (values (syntax-object->datum id2170) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) mod2169)))) tmp2163) (syntax-error tmp2162))) (syntax-dispatch tmp2162 (quote (any each-any any))))) e2161))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2172) ((lambda (tmp2173) ((lambda (tmp2174) (if (if tmp2174 (apply (lambda (_2175 mod2176 id2177) (and (andmap id?1131 mod2176) (id?1131 id2177))) tmp2174) #f) (apply (lambda (_2179 mod2180 id2181) (values (syntax-object->datum id2181) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) mod2180)))) tmp2174) (syntax-error tmp2173))) (syntax-dispatch tmp2173 (quote (any each-any any))))) e2172))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2186 (lambda (x2187 keys2188 clauses2189 r2190 mod2191) (if (null? clauses2189) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2187)) ((lambda (tmp2192) ((lambda (tmp2193) (if tmp2193 (apply (lambda (pat2194 exp2195) (if (and (id?1131 pat2194) (andmap (lambda (x2196) (not (free-id=?1154 pat2194 x2196))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (guile))) keys2188))) (let ((labels2197 (list (gen-label1136))) (var2198 (gen-var1179 pat2194))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2198) (chi1167 exp2195 (extend-env1125 labels2197 (list (cons (quote syntax) (cons var2198 0))) r2190) (make-binding-wrap1148 (list pat2194) labels2197 (quote (()))) mod2191))) x2187))) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2194 #t exp2195 mod2191))) tmp2193) ((lambda (tmp2199) (if tmp2199 (apply (lambda (pat2200 fender2201 exp2202) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2200 fender2201 exp2202 mod2191)) tmp2199) ((lambda (_2203) (syntax-error (car clauses2189) "invalid syntax-case clause")) tmp2192))) (syntax-dispatch tmp2192 (quote (any any any)))))) (syntax-dispatch tmp2192 (quote (any any))))) (car clauses2189))))) (gen-clause2185 (lambda (x2204 keys2205 clauses2206 r2207 pat2208 fender2209 exp2210 mod2211) (call-with-values (lambda () (convert-pattern2183 pat2208 keys2205)) (lambda (p2212 pvars2213) (cond ((not (distinct-bound-ids?1157 (map car pvars2213))) (syntax-error pat2208 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2214) (not (ellipsis?1176 (car x2214)))) pvars2213)) (syntax-error pat2208 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2215 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2215) (let ((y2216 (build-annotated1108 #f y2215))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2217) ((lambda (tmp2218) (if tmp2218 (apply (lambda () y2216) tmp2218) ((lambda (_2219) (build-annotated1108 #f (list (quote if) y2216 (build-dispatch-call2184 pvars2213 fender2209 y2216 r2207 mod2211) (build-data1109 #f #f)))) tmp2217))) (syntax-dispatch tmp2217 (quote #(atom #t))))) fender2209) (build-dispatch-call2184 pvars2213 exp2210 y2216 r2207 mod2211) (gen-syntax-case2186 x2204 keys2205 clauses2206 r2207 mod2211)))))) (if (eq? p2212 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2204)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2204 (build-data1109 #f p2212))))))))))))) (build-dispatch-call2184 (lambda (pvars2220 exp2221 y2222 r2223 mod2224) (let ((ids2225 (map car pvars2220)) (levels2226 (map cdr pvars2220))) (let ((labels2227 (gen-labels1137 ids2225)) (new-vars2228 (map gen-var1179 ids2225))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2228 (chi1167 exp2221 (extend-env1125 labels2227 (map (lambda (var2229 level2230) (cons (quote syntax) (cons var2229 level2230))) new-vars2228 (map cdr pvars2220)) r2223) (make-binding-wrap1148 ids2225 labels2227 (quote (()))) mod2224))) y2222)))))) (convert-pattern2183 (lambda (pattern2231 keys2232) (let cvt2233 ((p2234 pattern2231) (n2235 0) (ids2236 (quote ()))) (if (id?1131 p2234) (if (bound-id-member?1158 p2234 keys2232) (values (vector (quote free-id) p2234) ids2236) (values (quote any) (cons (cons p2234 n2235) ids2236))) ((lambda (tmp2237) ((lambda (tmp2238) (if (if tmp2238 (apply (lambda (x2239 dots2240) (ellipsis?1176 dots2240)) tmp2238) #f) (apply (lambda (x2241 dots2242) (call-with-values (lambda () (cvt2233 x2241 (fx+1098 n2235 1) ids2236)) (lambda (p2243 ids2244) (values (if (eq? p2243 (quote any)) (quote each-any) (vector (quote each) p2243)) ids2244)))) tmp2238) ((lambda (tmp2245) (if tmp2245 (apply (lambda (x2246 y2247) (call-with-values (lambda () (cvt2233 y2247 n2235 ids2236)) (lambda (y2248 ids2249) (call-with-values (lambda () (cvt2233 x2246 n2235 ids2249)) (lambda (x2250 ids2251) (values (cons x2250 y2248) ids2251)))))) tmp2245) ((lambda (tmp2252) (if tmp2252 (apply (lambda () (values (quote ()) ids2236)) tmp2252) ((lambda (tmp2253) (if tmp2253 (apply (lambda (x2254) (call-with-values (lambda () (cvt2233 x2254 n2235 ids2236)) (lambda (p2256 ids2257) (values (vector (quote vector) p2256) ids2257)))) tmp2253) ((lambda (x2258) (values (vector (quote atom) (strip1178 p2234 (quote (())))) ids2236)) tmp2237))) (syntax-dispatch tmp2237 (quote #(vector each-any)))))) (syntax-dispatch tmp2237 (quote ()))))) (syntax-dispatch tmp2237 (quote (any . any)))))) (syntax-dispatch tmp2237 (quote (any any))))) p2234)))))) (lambda (e2259 r2260 w2261 s2262 mod2263) (let ((e2264 (source-wrap1160 e2259 w2261 s2262 mod2263))) ((lambda (tmp2265) ((lambda (tmp2266) (if tmp2266 (apply (lambda (_2267 val2268 key2269 m2270) (if (andmap (lambda (x2271) (and (id?1131 x2271) (not (ellipsis?1176 x2271)))) key2269) (let ((x2273 (gen-var1179 (quote tmp)))) (build-annotated1108 s2262 (list (build-annotated1108 #f (list (quote lambda) (list x2273) (gen-syntax-case2186 (build-annotated1108 #f x2273) key2269 m2270 r2260 mod2263))) (chi1167 val2268 r2260 (quote (())) mod2263)))) (syntax-error e2264 "invalid literals list in"))) tmp2266) (syntax-error tmp2265))) (syntax-dispatch tmp2265 (quote (any any each-any . each-any))))) e2264))))) (set! sc-expand (let ((m2276 (quote e)) (esew2277 (quote (eval)))) (lambda (x2278) (if (and (pair? x2278) (equal? (car x2278) noexpand1097)) (cadr x2278) (chi-top1166 x2278 (quote ()) (quote ((top))) m2276 esew2277 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2279 (quote e)) (esew2280 (quote (eval)))) (lambda (x2282 . rest2281) (if (and (pair? x2282) (equal? (car x2282) noexpand1097)) (cadr x2282) (chi-top1166 x2282 (quote ()) (quote ((top))) (if (null? rest2281) m2279 (car rest2281)) (if (or (null? rest2281) (null? (cdr rest2281))) esew2280 (cadr rest2281)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2283) (nonsymbol-id?1130 x2283))) (set! datum->syntax-object (lambda (id2284 datum2285) (make-syntax-object1114 datum2285 (syntax-object-wrap1117 id2284) #f))) (set! syntax-object->datum (lambda (x2286) (strip1178 x2286 (quote (()))))) (set! generate-temporaries (lambda (ls2287) (begin (let ((x2288 ls2287)) (if (not (list? x2288)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2288))) (map (lambda (x2289) (wrap1159 (gensym) (quote ((top))) #f)) ls2287)))) (set! free-identifier=? (lambda (x2290 y2291) (begin (let ((x2292 x2290)) (if (not (nonsymbol-id?1130 x2292)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2292))) (let ((x2293 y2291)) (if (not (nonsymbol-id?1130 x2293)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2293))) (free-id=?1154 x2290 y2291)))) (set! bound-identifier=? (lambda (x2294 y2295) (begin (let ((x2296 x2294)) (if (not (nonsymbol-id?1130 x2296)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2296))) (let ((x2297 y2295)) (if (not (nonsymbol-id?1130 x2297)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2297))) (bound-id=?1155 x2294 y2295)))) (set! syntax-error (lambda (object2299 . messages2298) (begin (for-each (lambda (x2300) (let ((x2301 x2300)) (if (not (string? x2301)) (error-hook1104 (quote syntax-error) "invalid argument" x2301)))) messages2298) (let ((message2302 (if (null? messages2298) "invalid syntax" (apply string-append messages2298)))) (error-hook1104 #f message2302 (strip1178 object2299 (quote (())))))))) (set! install-global-transformer (lambda (sym2303 v2304) (begin (let ((x2305 sym2303)) (if (not (symbol? x2305)) (error-hook1104 (quote define-syntax) "invalid argument" x2305))) (let ((x2306 v2304)) (if (not (procedure? x2306)) (error-hook1104 (quote define-syntax) "invalid argument" x2306))) (global-extend1129 (quote macro) sym2303 v2304)))) (letrec ((match2311 (lambda (e2312 p2313 w2314 r2315 mod2316) (cond ((not r2315) #f) ((eq? p2313 (quote any)) (cons (wrap1159 e2312 w2314 mod2316) r2315)) ((syntax-object?1115 e2312) (match*2310 (let ((e2317 (syntax-object-expression1116 e2312))) (if (annotation? e2317) (annotation-expression e2317) e2317)) p2313 (join-wraps1150 w2314 (syntax-object-wrap1117 e2312)) r2315 (syntax-object-module1118 e2312))) (else (match*2310 (let ((e2318 e2312)) (if (annotation? e2318) (annotation-expression e2318) e2318)) p2313 w2314 r2315 mod2316))))) (match*2310 (lambda (e2319 p2320 w2321 r2322 mod2323) (cond ((null? p2320) (and (null? e2319) r2322)) ((pair? p2320) (and (pair? e2319) (match2311 (car e2319) (car p2320) w2321 (match2311 (cdr e2319) (cdr p2320) w2321 r2322 mod2323) mod2323))) ((eq? p2320 (quote each-any)) (let ((l2324 (match-each-any2308 e2319 w2321 mod2323))) (and l2324 (cons l2324 r2322)))) (else (let ((t2325 (vector-ref p2320 0))) (if (memv t2325 (quote (each))) (if (null? e2319) (match-empty2309 (vector-ref p2320 1) r2322) (let ((l2326 (match-each2307 e2319 (vector-ref p2320 1) w2321 mod2323))) (and l2326 (let collect2327 ((l2328 l2326)) (if (null? (car l2328)) r2322 (cons (map car l2328) (collect2327 (map cdr l2328)))))))) (if (memv t2325 (quote (free-id))) (and (id?1131 e2319) (free-id=?1154 (wrap1159 e2319 w2321 mod2323) (vector-ref p2320 1)) r2322) (if (memv t2325 (quote (atom))) (and (equal? (vector-ref p2320 1) (strip1178 e2319 w2321)) r2322) (if (memv t2325 (quote (vector))) (and (vector? e2319) (match2311 (vector->list e2319) (vector-ref p2320 1) w2321 r2322 mod2323))))))))))) (match-empty2309 (lambda (p2329 r2330) (cond ((null? p2329) r2330) ((eq? p2329 (quote any)) (cons (quote ()) r2330)) ((pair? p2329) (match-empty2309 (car p2329) (match-empty2309 (cdr p2329) r2330))) ((eq? p2329 (quote each-any)) (cons (quote ()) r2330)) (else (let ((t2331 (vector-ref p2329 0))) (if (memv t2331 (quote (each))) (match-empty2309 (vector-ref p2329 1) r2330) (if (memv t2331 (quote (free-id atom))) r2330 (if (memv t2331 (quote (vector))) (match-empty2309 (vector-ref p2329 1) r2330))))))))) (match-each-any2308 (lambda (e2332 w2333 mod2334) (cond ((annotation? e2332) (match-each-any2308 (annotation-expression e2332) w2333 mod2334)) ((pair? e2332) (let ((l2335 (match-each-any2308 (cdr e2332) w2333 mod2334))) (and l2335 (cons (wrap1159 (car e2332) w2333 mod2334) l2335)))) ((null? e2332) (quote ())) ((syntax-object?1115 e2332) (match-each-any2308 (syntax-object-expression1116 e2332) (join-wraps1150 w2333 (syntax-object-wrap1117 e2332)) mod2334)) (else #f)))) (match-each2307 (lambda (e2336 p2337 w2338 mod2339) (cond ((annotation? e2336) (match-each2307 (annotation-expression e2336) p2337 w2338 mod2339)) ((pair? e2336) (let ((first2340 (match2311 (car e2336) p2337 w2338 (quote ()) mod2339))) (and first2340 (let ((rest2341 (match-each2307 (cdr e2336) p2337 w2338 mod2339))) (and rest2341 (cons first2340 rest2341)))))) ((null? e2336) (quote ())) ((syntax-object?1115 e2336) (match-each2307 (syntax-object-expression1116 e2336) p2337 (join-wraps1150 w2338 (syntax-object-wrap1117 e2336)) (syntax-object-module1118 e2336))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2342 p2343) (cond ((eq? p2343 (quote any)) (list e2342)) ((syntax-object?1115 e2342) (match*2310 (let ((e2344 (syntax-object-expression1116 e2342))) (if (annotation? e2344) (annotation-expression e2344) e2344)) p2343 (syntax-object-wrap1117 e2342) (quote ()) (syntax-object-module1118 e2342))) (else (match*2310 (let ((e2345 e2342)) (if (annotation? e2345) (annotation-expression e2345) e2345)) p2343 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) -(install-global-transformer (quote with-syntax) (lambda (x2346) ((lambda (tmp2347) ((lambda (tmp2348) (if tmp2348 (apply (lambda (_2349 e12350 e22351) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12350 e22351))) tmp2348) ((lambda (tmp2353) (if tmp2353 (apply (lambda (_2354 out2355 in2356 e12357 e22358) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2356 (quote ()) (list out2355 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12357 e22358))))) tmp2353) ((lambda (tmp2360) (if tmp2360 (apply (lambda (_2361 out2362 in2363 e12364 e22365) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) in2363) (quote ()) (list out2362 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12364 e22365))))) tmp2360) (syntax-error tmp2347))) (syntax-dispatch tmp2347 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any () any . each-any))))) x2346))) -(install-global-transformer (quote syntax-rules) (lambda (x2369) ((lambda (tmp2370) ((lambda (tmp2371) (if tmp2371 (apply (lambda (_2372 k2373 keyword2374 pattern2375 template2376) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons k2373 (map (lambda (tmp2379 tmp2378) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2378) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) tmp2379))) template2376 pattern2375)))))) tmp2371) (syntax-error tmp2370))) (syntax-dispatch tmp2370 (quote (any each-any . #(each ((any . any) any))))))) x2369))) -(install-global-transformer (quote let*) (lambda (x2380) ((lambda (tmp2381) ((lambda (tmp2382) (if (if tmp2382 (apply (lambda (let*2383 x2384 v2385 e12386 e22387) (andmap identifier? x2384)) tmp2382) #f) (apply (lambda (let*2389 x2390 v2391 e12392 e22393) (let f2394 ((bindings2395 (map list x2390 v2391))) (if (null? bindings2395) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons (quote ()) (cons e12392 e22393))) ((lambda (tmp2399) ((lambda (tmp2400) (if tmp2400 (apply (lambda (body2401 binding2402) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list binding2402) body2401)) tmp2400) (syntax-error tmp2399))) (syntax-dispatch tmp2399 (quote (any any))))) (list (f2394 (cdr bindings2395)) (car bindings2395)))))) tmp2382) (syntax-error tmp2381))) (syntax-dispatch tmp2381 (quote (any #(each (any any)) any . each-any))))) x2380))) -(install-global-transformer (quote do) (lambda (orig-x2403) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 var2407 init2408 step2409 e02410 e12411 c2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (step2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02410) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2415))))))) tmp2417) ((lambda (tmp2422) (if tmp2422 (apply (lambda (e12423 e22424) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) e02410 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (cons e12423 e22424)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (guile))) step2415))))))) tmp2422) (syntax-error tmp2416))) (syntax-dispatch tmp2416 (quote (any . each-any)))))) (syntax-dispatch tmp2416 (quote ())))) e12411)) tmp2414) (syntax-error tmp2413))) (syntax-dispatch tmp2413 (quote each-any)))) (map (lambda (v2431 s2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () v2431) tmp2434) ((lambda (tmp2435) (if tmp2435 (apply (lambda (e2436) e2436) tmp2435) ((lambda (_2437) (syntax-error orig-x2403)) tmp2433))) (syntax-dispatch tmp2433 (quote (any)))))) (syntax-dispatch tmp2433 (quote ())))) s2432)) var2407 step2409))) tmp2405) (syntax-error tmp2404))) (syntax-dispatch tmp2404 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2403))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2440 (lambda (x2444 y2445) ((lambda (tmp2446) ((lambda (tmp2447) (if tmp2447 (apply (lambda (x2448 y2449) ((lambda (tmp2450) ((lambda (tmp2451) (if tmp2451 (apply (lambda (dy2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (dx2455) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons dx2455 dy2452))) tmp2454) ((lambda (_2456) (if (null? dy2452) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2448) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2448 y2449))) tmp2453))) (syntax-dispatch tmp2453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) x2448)) tmp2451) ((lambda (tmp2457) (if tmp2457 (apply (lambda (stuff2458) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (cons x2448 stuff2458))) tmp2457) ((lambda (else2459) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2448 y2449)) tmp2450))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . any)))))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) y2449)) tmp2447) (syntax-error tmp2446))) (syntax-dispatch tmp2446 (quote (any any))))) (list x2444 y2445)))) (quasiappend2441 (lambda (x2460 y2461) ((lambda (tmp2462) ((lambda (tmp2463) (if tmp2463 (apply (lambda (x2464 y2465) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda () x2464) tmp2467) ((lambda (_2468) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2464 y2465)) tmp2466))) (syntax-dispatch tmp2466 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) ()))))) y2465)) tmp2463) (syntax-error tmp2462))) (syntax-dispatch tmp2462 (quote (any any))))) (list x2460 y2461)))) (quasivector2442 (lambda (x2469) ((lambda (tmp2470) ((lambda (x2471) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (x2474) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) (list->vector x2474))) tmp2473) ((lambda (tmp2476) (if tmp2476 (apply (lambda (x2477) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2477)) tmp2476) ((lambda (_2479) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) x2471)) tmp2472))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) . each-any)))))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) each-any))))) x2471)) tmp2470)) x2469))) (quasi2443 (lambda (p2480 lev2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (p2484) (if (= lev2481 0) p2484 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2443 (list p2484) (- lev2481 1))))) tmp2483) ((lambda (tmp2485) (if tmp2485 (apply (lambda (p2486 q2487) (if (= lev2481 0) (quasiappend2441 p2486 (quasi2443 q2487 lev2481)) (quasicons2440 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2443 (list p2486) (- lev2481 1))) (quasi2443 q2487 lev2481)))) tmp2485) ((lambda (tmp2488) (if tmp2488 (apply (lambda (p2489) (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile)))) (quasi2443 (list p2489) (+ lev2481 1)))) tmp2488) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491 q2492) (quasicons2440 (quasi2443 p2491 lev2481) (quasi2443 q2492 lev2481))) tmp2490) ((lambda (tmp2493) (if tmp2493 (apply (lambda (x2494) (quasivector2442 (quasi2443 x2494 lev2481))) tmp2493) ((lambda (p2496) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) p2496)) tmp2482))) (syntax-dispatch tmp2482 (quote #(vector each-any)))))) (syntax-dispatch tmp2482 (quote (any . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any)))))) (syntax-dispatch tmp2482 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any) . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (guile))) any))))) p2480)))) (lambda (x2497) ((lambda (tmp2498) ((lambda (tmp2499) (if tmp2499 (apply (lambda (_2500 e2501) (quasi2443 e2501 0)) tmp2499) (syntax-error tmp2498))) (syntax-dispatch tmp2498 (quote (any any))))) x2497)))) -(install-global-transformer (quote include) (lambda (x2502) (letrec ((read-file2503 (lambda (fn2504 k2505) (let ((p2506 (open-input-file fn2504))) (let f2507 ((x2508 (read p2506))) (if (eof-object? x2508) (begin (close-input-port p2506) (quote ())) (cons (datum->syntax-object k2505 x2508) (f2507 (read p2506))))))))) ((lambda (tmp2509) ((lambda (tmp2510) (if tmp2510 (apply (lambda (k2511 filename2512) (let ((fn2513 (syntax-object->datum filename2512))) ((lambda (tmp2514) ((lambda (tmp2515) (if tmp2515 (apply (lambda (exp2516) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (guile))) exp2516)) tmp2515) (syntax-error tmp2514))) (syntax-dispatch tmp2514 (quote each-any)))) (read-file2503 fn2513 k2511)))) tmp2510) (syntax-error tmp2509))) (syntax-dispatch tmp2509 (quote (any any))))) x2502)))) +(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (cons (quote hygiene) (module-name (procedure-module p1510)))))))) ((vector? x1517) (let ((n1522 (vector-length x1517))) (let ((v1523 (make-vector n1522))) (let doloop1524 ((i1525 0)) (if (fx=1100 i1525 n1522) v1523 (begin (vector-set! v1523 i1525 (rebuild-macro-output1516 (vector-ref x1517 i1525) m1518)) (doloop1524 (fx+1098 i1525 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1526 e1527 r1528 w1529 s1530 mod1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (e01534 e11535) (build-annotated1108 s1530 (cons x1526 (map (lambda (e1536) (chi1167 e1536 r1528 w1529 mod1531)) e11535)))) tmp1533) (syntax-error tmp1532))) (syntax-dispatch tmp1532 (quote (any . each-any))))) e1527))) (chi-expr1168 (lambda (type1538 value1539 e1540 r1541 w1542 s1543 mod1544) (let ((t1545 type1538)) (if (memv t1545 (quote (lexical))) (build-annotated1108 s1543 value1539) (if (memv t1545 (quote (core external-macro))) (value1539 e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (module-ref))) (call-with-values (lambda () (value1539 e1540)) (lambda (id1546 mod1547) (build-annotated1108 s1543 (if mod1547 (make-module-ref (cdr mod1547) id1546 (car mod1547)) (make-module-ref mod1547 id1546 (quote bare)))))) (if (memv t1545 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) value1539) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (global-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) (if (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544))) (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 (quote bare)))) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (constant))) (build-data1109 s1543 (strip1178 (source-wrap1160 e1540 w1542 s1543 mod1544) (quote (())))) (if (memv t1545 (quote (global))) (build-annotated1108 s1543 (if mod1544 (make-module-ref (cdr mod1544) value1539 (car mod1544)) (make-module-ref mod1544 value1539 (quote bare)))) (if (memv t1545 (quote (call))) (chi-application1169 (chi1167 (car e1540) r1541 w1542 mod1544) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (begin-form))) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (_1550 e11551 e21552) (chi-sequence1161 (cons e11551 e21552) r1541 w1542 s1543 mod1544)) tmp1549) (syntax-error tmp1548))) (syntax-dispatch tmp1548 (quote (any any . each-any))))) e1540) (if (memv t1545 (quote (local-syntax-form))) (chi-local-syntax1173 value1539 e1540 r1541 w1542 s1543 mod1544 chi-sequence1161) (if (memv t1545 (quote (eval-when-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 x1557 e11558 e21559) (let ((when-list1560 (chi-when-list1164 e1540 x1557 w1542))) (if (memq (quote eval) when-list1560) (chi-sequence1161 (cons e11558 e21559) r1541 w1542 s1543 mod1544) (chi-void1175)))) tmp1555) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any each-any any . each-any))))) e1540) (if (memv t1545 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1539 w1542 mod1544) "invalid context for definition of") (if (memv t1545 (quote (syntax))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to pattern variable outside syntax form") (if (memv t1545 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544))))))))))))))))))) (chi1167 (lambda (e1563 r1564 w1565 mod1566) (call-with-values (lambda () (syntax-type1165 e1563 r1564 w1565 #f #f mod1566)) (lambda (type1567 value1568 e1569 w1570 s1571 mod1572) (chi-expr1168 type1567 value1568 e1569 r1564 w1570 s1571 mod1572))))) (chi-top1166 (lambda (e1573 r1574 w1575 m1576 esew1577 mod1578) (call-with-values (lambda () (syntax-type1165 e1573 r1574 w1575 #f #f mod1578)) (lambda (type1586 value1587 e1588 w1589 s1590 mod1591) (let ((t1592 type1586)) (if (memv t1592 (quote (begin-form))) ((lambda (tmp1593) ((lambda (tmp1594) (if tmp1594 (apply (lambda (_1595) (chi-void1175)) tmp1594) ((lambda (tmp1596) (if tmp1596 (apply (lambda (_1597 e11598 e21599) (chi-top-sequence1162 (cons e11598 e21599) r1574 w1589 s1590 m1576 esew1577 mod1591)) tmp1596) (syntax-error tmp1593))) (syntax-dispatch tmp1593 (quote (any any . each-any)))))) (syntax-dispatch tmp1593 (quote (any))))) e1588) (if (memv t1592 (quote (local-syntax-form))) (chi-local-syntax1173 value1587 e1588 r1574 w1589 s1590 mod1591 (lambda (body1601 r1602 w1603 s1604 mod1605) (chi-top-sequence1162 body1601 r1602 w1603 s1604 m1576 esew1577 mod1605))) (if (memv t1592 (quote (eval-when-form))) ((lambda (tmp1606) ((lambda (tmp1607) (if tmp1607 (apply (lambda (_1608 x1609 e11610 e21611) (let ((when-list1612 (chi-when-list1164 e1588 x1609 w1589)) (body1613 (cons e11610 e21611))) (cond ((eq? m1576 (quote e)) (if (memq (quote eval) when-list1612) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) (chi-void1175))) ((memq (quote load) when-list1612) (if (or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c&e) (quote (compile load)) mod1591) (if (memq m1576 (quote (c c&e))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c) (quote (load)) mod1591) (chi-void1175)))) ((or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (top-level-eval-hook1102 (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) mod1591) (chi-void1175)) (else (chi-void1175))))) tmp1607) (syntax-error tmp1606))) (syntax-dispatch tmp1606 (quote (any each-any any . each-any))))) e1588) (if (memv t1592 (quote (define-syntax-form))) (let ((n1616 (id-var-name1153 value1587 w1589)) (r1617 (macros-only-env1127 r1574))) (let ((t1618 m1576)) (if (memv t1618 (quote (c))) (if (memq (quote compile) esew1577) (let ((e1619 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1619 mod1591) (if (memq (quote load) esew1577) e1619 (chi-void1175)))) (if (memq (quote load) esew1577) (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) (chi-void1175))) (if (memv t1618 (quote (c&e))) (let ((e1620 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1620 mod1591) e1620)) (begin (if (memq (quote eval) esew1577) (top-level-eval-hook1102 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) mod1591)) (chi-void1175)))))) (if (memv t1592 (quote (define-form))) (let ((n1621 (id-var-name1153 value1587 w1589))) (let ((type1622 (binding-type1123 (lookup1128 n1621 r1574 mod1591)))) (let ((t1623 type1622)) (if (memv t1623 (quote (global))) (let ((x1624 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1624 mod1591)) x1624)) (if (memv t1623 (quote (displaced-lexical))) (syntax-error (wrap1159 value1587 w1589 mod1591) "identifier out of context") (if (memv t1623 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1621) (let ((x1625 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1625 mod1591)) x1625))) (syntax-error (wrap1159 value1587 w1589 mod1591) "cannot define keyword at top level"))))))) (let ((x1626 (chi-expr1168 type1586 value1587 e1588 r1574 w1589 s1590 mod1591))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1626 mod1591)) x1626)))))))))))) (syntax-type1165 (lambda (e1627 r1628 w1629 s1630 rib1631 mod1632) (cond ((symbol? e1627) (let ((n1633 (id-var-name1153 e1627 w1629))) (let ((b1634 (lookup1128 n1633 r1628 mod1632))) (let ((type1635 (binding-type1123 b1634))) (let ((t1636 type1635)) (if (memv t1636 (quote (lexical))) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (global))) (values type1635 n1633 e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1634) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632))))))))) ((pair? e1627) (let ((first1637 (car e1627))) (if (id?1131 first1637) (let ((n1638 (id-var-name1153 first1637 w1629))) (let ((b1639 (lookup1128 n1638 r1628 (or (and (syntax-object?1115 first1637) (syntax-object-module1118 first1637)) mod1632)))) (let ((type1640 (binding-type1123 b1639))) (let ((t1641 type1640)) (if (memv t1641 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (global))) (values (quote global-call) n1638 e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1639) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (if (memv t1641 (quote (core external-macro module-ref))) (values type1640 (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (begin))) (values (quote begin-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (eval-when))) (values (quote eval-when-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (define))) ((lambda (tmp1642) ((lambda (tmp1643) (if (if tmp1643 (apply (lambda (_1644 name1645 val1646) (id?1131 name1645)) tmp1643) #f) (apply (lambda (_1647 name1648 val1649) (values (quote define-form) name1648 val1649 w1629 s1630 mod1632)) tmp1643) ((lambda (tmp1650) (if (if tmp1650 (apply (lambda (_1651 name1652 args1653 e11654 e21655) (and (id?1131 name1652) (valid-bound-ids?1156 (lambda-var-list1180 args1653)))) tmp1650) #f) (apply (lambda (_1656 name1657 args1658 e11659 e21660) (values (quote define-form) (wrap1159 name1657 w1629 mod1632) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1159 (cons args1658 (cons e11659 e21660)) w1629 mod1632)) (quote (())) s1630 mod1632)) tmp1650) ((lambda (tmp1662) (if (if tmp1662 (apply (lambda (_1663 name1664) (id?1131 name1664)) tmp1662) #f) (apply (lambda (_1665 name1666) (values (quote define-form) (wrap1159 name1666 w1629 mod1632) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1630 mod1632)) tmp1662) (syntax-error tmp1642))) (syntax-dispatch tmp1642 (quote (any any)))))) (syntax-dispatch tmp1642 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1642 (quote (any any any))))) e1627) (if (memv t1641 (quote (define-syntax))) ((lambda (tmp1667) ((lambda (tmp1668) (if (if tmp1668 (apply (lambda (_1669 name1670 val1671) (id?1131 name1670)) tmp1668) #f) (apply (lambda (_1672 name1673 val1674) (values (quote define-syntax-form) name1673 val1674 w1629 s1630 mod1632)) tmp1668) (syntax-error tmp1667))) (syntax-dispatch tmp1667 (quote (any any any))))) e1627) (values (quote call) #f e1627 w1629 s1630 mod1632)))))))))))))) (values (quote call) #f e1627 w1629 s1630 mod1632)))) ((syntax-object?1115 e1627) (syntax-type1165 (syntax-object-expression1116 e1627) r1628 (join-wraps1150 w1629 (syntax-object-wrap1117 e1627)) #f rib1631 (or (syntax-object-module1118 e1627) mod1632))) ((annotation? e1627) (syntax-type1165 (annotation-expression e1627) r1628 w1629 (annotation-source e1627) rib1631 mod1632)) ((self-evaluating? e1627) (values (quote constant) #f e1627 w1629 s1630 mod1632)) (else (values (quote other) #f e1627 w1629 s1630 mod1632))))) (chi-when-list1164 (lambda (e1675 when-list1676 w1677) (let f1678 ((when-list1679 when-list1676) (situations1680 (quote ()))) (if (null? when-list1679) situations1680 (f1678 (cdr when-list1679) (cons (let ((x1681 (car when-list1679))) (cond ((free-id=?1154 x1681 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1154 x1681 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1154 x1681 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1159 x1681 w1677 #f) "invalid eval-when situation")))) situations1680)))))) (chi-install-global1163 (lambda (name1682 e1683) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1682) e1683)))) (chi-top-sequence1162 (lambda (body1684 r1685 w1686 s1687 m1688 esew1689 mod1690) (build-sequence1110 s1687 (let dobody1691 ((body1692 body1684) (r1693 r1685) (w1694 w1686) (m1695 m1688) (esew1696 esew1689) (mod1697 mod1690)) (if (null? body1692) (quote ()) (let ((first1698 (chi-top1166 (car body1692) r1693 w1694 m1695 esew1696 mod1697))) (cons first1698 (dobody1691 (cdr body1692) r1693 w1694 m1695 esew1696 mod1697)))))))) (chi-sequence1161 (lambda (body1699 r1700 w1701 s1702 mod1703) (build-sequence1110 s1702 (let dobody1704 ((body1705 body1699) (r1706 r1700) (w1707 w1701) (mod1708 mod1703)) (if (null? body1705) (quote ()) (let ((first1709 (chi1167 (car body1705) r1706 w1707 mod1708))) (cons first1709 (dobody1704 (cdr body1705) r1706 w1707 mod1708)))))))) (source-wrap1160 (lambda (x1710 w1711 s1712 defmod1713) (wrap1159 (if s1712 (make-annotation x1710 s1712 #f) x1710) w1711 defmod1713))) (wrap1159 (lambda (x1714 w1715 defmod1716) (cond ((and (null? (wrap-marks1134 w1715)) (null? (wrap-subst1135 w1715))) x1714) ((syntax-object?1115 x1714) (make-syntax-object1114 (syntax-object-expression1116 x1714) (join-wraps1150 w1715 (syntax-object-wrap1117 x1714)) (syntax-object-module1118 x1714))) ((null? x1714) x1714) (else (make-syntax-object1114 x1714 w1715 defmod1716))))) (bound-id-member?1158 (lambda (x1717 list1718) (and (not (null? list1718)) (or (bound-id=?1155 x1717 (car list1718)) (bound-id-member?1158 x1717 (cdr list1718)))))) (distinct-bound-ids?1157 (lambda (ids1719) (let distinct?1720 ((ids1721 ids1719)) (or (null? ids1721) (and (not (bound-id-member?1158 (car ids1721) (cdr ids1721))) (distinct?1720 (cdr ids1721))))))) (valid-bound-ids?1156 (lambda (ids1722) (and (let all-ids?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (id?1131 (car ids1724)) (all-ids?1723 (cdr ids1724))))) (distinct-bound-ids?1157 ids1722)))) (bound-id=?1155 (lambda (i1725 j1726) (if (and (syntax-object?1115 i1725) (syntax-object?1115 j1726)) (and (eq? (let ((e1727 (syntax-object-expression1116 i1725))) (if (annotation? e1727) (annotation-expression e1727) e1727)) (let ((e1728 (syntax-object-expression1116 j1726))) (if (annotation? e1728) (annotation-expression e1728) e1728))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1725)) (wrap-marks1134 (syntax-object-wrap1117 j1726)))) (eq? (let ((e1729 i1725)) (if (annotation? e1729) (annotation-expression e1729) e1729)) (let ((e1730 j1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)))))) (free-id=?1154 (lambda (i1731 j1732) (and (eq? (let ((x1733 i1731)) (let ((e1734 (if (syntax-object?1115 x1733) (syntax-object-expression1116 x1733) x1733))) (if (annotation? e1734) (annotation-expression e1734) e1734))) (let ((x1735 j1732)) (let ((e1736 (if (syntax-object?1115 x1735) (syntax-object-expression1116 x1735) x1735))) (if (annotation? e1736) (annotation-expression e1736) e1736)))) (eq? (id-var-name1153 i1731 (quote (()))) (id-var-name1153 j1732 (quote (()))))))) (id-var-name1153 (lambda (id1737 w1738) (letrec ((search-vector-rib1741 (lambda (sym1747 subst1748 marks1749 symnames1750 ribcage1751) (let ((n1752 (vector-length symnames1750))) (let f1753 ((i1754 0)) (cond ((fx=1100 i1754 n1752) (search1739 sym1747 (cdr subst1748) marks1749)) ((and (eq? (vector-ref symnames1750 i1754) sym1747) (same-marks?1152 marks1749 (vector-ref (ribcage-marks1141 ribcage1751) i1754))) (values (vector-ref (ribcage-labels1142 ribcage1751) i1754) marks1749)) (else (f1753 (fx+1098 i1754 1)))))))) (search-list-rib1740 (lambda (sym1755 subst1756 marks1757 symnames1758 ribcage1759) (let f1760 ((symnames1761 symnames1758) (i1762 0)) (cond ((null? symnames1761) (search1739 sym1755 (cdr subst1756) marks1757)) ((and (eq? (car symnames1761) sym1755) (same-marks?1152 marks1757 (list-ref (ribcage-marks1141 ribcage1759) i1762))) (values (list-ref (ribcage-labels1142 ribcage1759) i1762) marks1757)) (else (f1760 (cdr symnames1761) (fx+1098 i1762 1))))))) (search1739 (lambda (sym1763 subst1764 marks1765) (if (null? subst1764) (values #f marks1765) (let ((fst1766 (car subst1764))) (if (eq? fst1766 (quote shift)) (search1739 sym1763 (cdr subst1764) (cdr marks1765)) (let ((symnames1767 (ribcage-symnames1140 fst1766))) (if (vector? symnames1767) (search-vector-rib1741 sym1763 subst1764 marks1765 symnames1767 fst1766) (search-list-rib1740 sym1763 subst1764 marks1765 symnames1767 fst1766))))))))) (cond ((symbol? id1737) (or (call-with-values (lambda () (search1739 id1737 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1769 . ignore1768) x1769)) id1737)) ((syntax-object?1115 id1737) (let ((id1770 (let ((e1772 (syntax-object-expression1116 id1737))) (if (annotation? e1772) (annotation-expression e1772) e1772))) (w11771 (syntax-object-wrap1117 id1737))) (let ((marks1773 (join-marks1151 (wrap-marks1134 w1738) (wrap-marks1134 w11771)))) (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w1738) marks1773)) (lambda (new-id1774 marks1775) (or new-id1774 (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w11771) marks1775)) (lambda (x1777 . ignore1776) x1777)) id1770)))))) ((annotation? id1737) (let ((id1778 (let ((e1779 id1737)) (if (annotation? e1779) (annotation-expression e1779) e1779)))) (or (call-with-values (lambda () (search1739 id1778 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1781 . ignore1780) x1781)) id1778))) (else (error-hook1104 (quote id-var-name) "invalid id" id1737)))))) (same-marks?1152 (lambda (x1782 y1783) (or (eq? x1782 y1783) (and (not (null? x1782)) (not (null? y1783)) (eq? (car x1782) (car y1783)) (same-marks?1152 (cdr x1782) (cdr y1783)))))) (join-marks1151 (lambda (m11784 m21785) (smart-append1149 m11784 m21785))) (join-wraps1150 (lambda (w11786 w21787) (let ((m11788 (wrap-marks1134 w11786)) (s11789 (wrap-subst1135 w11786))) (if (null? m11788) (if (null? s11789) w21787 (make-wrap1133 (wrap-marks1134 w21787) (smart-append1149 s11789 (wrap-subst1135 w21787)))) (make-wrap1133 (smart-append1149 m11788 (wrap-marks1134 w21787)) (smart-append1149 s11789 (wrap-subst1135 w21787))))))) (smart-append1149 (lambda (m11790 m21791) (if (null? m21791) m11790 (append m11790 m21791)))) (make-binding-wrap1148 (lambda (ids1792 labels1793 w1794) (if (null? ids1792) w1794 (make-wrap1133 (wrap-marks1134 w1794) (cons (let ((labelvec1795 (list->vector labels1793))) (let ((n1796 (vector-length labelvec1795))) (let ((symnamevec1797 (make-vector n1796)) (marksvec1798 (make-vector n1796))) (begin (let f1799 ((ids1800 ids1792) (i1801 0)) (if (not (null? ids1800)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1800) w1794)) (lambda (symname1802 marks1803) (begin (vector-set! symnamevec1797 i1801 symname1802) (vector-set! marksvec1798 i1801 marks1803) (f1799 (cdr ids1800) (fx+1098 i1801 1))))))) (make-ribcage1138 symnamevec1797 marksvec1798 labelvec1795))))) (wrap-subst1135 w1794)))))) (extend-ribcage!1147 (lambda (ribcage1804 id1805 label1806) (begin (set-ribcage-symnames!1143 ribcage1804 (cons (let ((e1807 (syntax-object-expression1116 id1805))) (if (annotation? e1807) (annotation-expression e1807) e1807)) (ribcage-symnames1140 ribcage1804))) (set-ribcage-marks!1144 ribcage1804 (cons (wrap-marks1134 (syntax-object-wrap1117 id1805)) (ribcage-marks1141 ribcage1804))) (set-ribcage-labels!1145 ribcage1804 (cons label1806 (ribcage-labels1142 ribcage1804)))))) (anti-mark1146 (lambda (w1808) (make-wrap1133 (cons #f (wrap-marks1134 w1808)) (cons (quote shift) (wrap-subst1135 w1808))))) (set-ribcage-labels!1145 (lambda (x1809 update1810) (vector-set! x1809 3 update1810))) (set-ribcage-marks!1144 (lambda (x1811 update1812) (vector-set! x1811 2 update1812))) (set-ribcage-symnames!1143 (lambda (x1813 update1814) (vector-set! x1813 1 update1814))) (ribcage-labels1142 (lambda (x1815) (vector-ref x1815 3))) (ribcage-marks1141 (lambda (x1816) (vector-ref x1816 2))) (ribcage-symnames1140 (lambda (x1817) (vector-ref x1817 1))) (ribcage?1139 (lambda (x1818) (and (vector? x1818) (= (vector-length x1818) 4) (eq? (vector-ref x1818 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1819 marks1820 labels1821) (vector (quote ribcage) symnames1819 marks1820 labels1821))) (gen-labels1137 (lambda (ls1822) (if (null? ls1822) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1822)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1823 w1824) (if (syntax-object?1115 x1823) (values (let ((e1825 (syntax-object-expression1116 x1823))) (if (annotation? e1825) (annotation-expression e1825) e1825)) (join-marks1151 (wrap-marks1134 w1824) (wrap-marks1134 (syntax-object-wrap1117 x1823)))) (values (let ((e1826 x1823)) (if (annotation? e1826) (annotation-expression e1826) e1826)) (wrap-marks1134 w1824))))) (id?1131 (lambda (x1827) (cond ((symbol? x1827) #t) ((syntax-object?1115 x1827) (symbol? (let ((e1828 (syntax-object-expression1116 x1827))) (if (annotation? e1828) (annotation-expression e1828) e1828)))) ((annotation? x1827) (symbol? (annotation-expression x1827))) (else #f)))) (nonsymbol-id?1130 (lambda (x1829) (and (syntax-object?1115 x1829) (symbol? (let ((e1830 (syntax-object-expression1116 x1829))) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (global-extend1129 (lambda (type1831 sym1832 val1833) (put-global-definition-hook1105 sym1832 (cons type1831 val1833)))) (lookup1128 (lambda (x1834 r1835 mod1836) (cond ((assq x1834 r1835) => cdr) ((symbol? x1834) (or (get-global-definition-hook1107 x1834 mod1836) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1837) (if (null? r1837) (quote ()) (let ((a1838 (car r1837))) (if (eq? (cadr a1838) (quote macro)) (cons a1838 (macros-only-env1127 (cdr r1837))) (macros-only-env1127 (cdr r1837))))))) (extend-var-env1126 (lambda (labels1839 vars1840 r1841) (if (null? labels1839) r1841 (extend-var-env1126 (cdr labels1839) (cdr vars1840) (cons (cons (car labels1839) (cons (quote lexical) (car vars1840))) r1841))))) (extend-env1125 (lambda (labels1842 bindings1843 r1844) (if (null? labels1842) r1844 (extend-env1125 (cdr labels1842) (cdr bindings1843) (cons (cons (car labels1842) (car bindings1843)) r1844))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1845) (cond ((annotation? x1845) (annotation-source x1845)) ((syntax-object?1115 x1845) (source-annotation1122 (syntax-object-expression1116 x1845))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1846 update1847) (vector-set! x1846 3 update1847))) (set-syntax-object-wrap!1120 (lambda (x1848 update1849) (vector-set! x1848 2 update1849))) (set-syntax-object-expression!1119 (lambda (x1850 update1851) (vector-set! x1850 1 update1851))) (syntax-object-module1118 (lambda (x1852) (vector-ref x1852 3))) (syntax-object-wrap1117 (lambda (x1853) (vector-ref x1853 2))) (syntax-object-expression1116 (lambda (x1854) (vector-ref x1854 1))) (syntax-object?1115 (lambda (x1855) (and (vector? x1855) (= (vector-length x1855) 4) (eq? (vector-ref x1855 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1856 wrap1857 module1858) (vector (quote syntax-object) expression1856 wrap1857 module1858))) (build-letrec1113 (lambda (src1859 vars1860 val-exps1861 body-exp1862) (if (null? vars1860) (build-annotated1108 src1859 body-exp1862) (build-annotated1108 src1859 (list (quote letrec) (map list vars1860 val-exps1861) body-exp1862))))) (build-named-let1112 (lambda (src1863 vars1864 val-exps1865 body-exp1866) (if (null? vars1864) (build-annotated1108 src1863 body-exp1866) (build-annotated1108 src1863 (list (quote let) (car vars1864) (map list (cdr vars1864) val-exps1865) body-exp1866))))) (build-let1111 (lambda (src1867 vars1868 val-exps1869 body-exp1870) (if (null? vars1868) (build-annotated1108 src1867 body-exp1870) (build-annotated1108 src1867 (list (quote let) (map list vars1868 val-exps1869) body-exp1870))))) (build-sequence1110 (lambda (src1871 exps1872) (if (null? (cdr exps1872)) (build-annotated1108 src1871 (car exps1872)) (build-annotated1108 src1871 (cons (quote begin) exps1872))))) (build-data1109 (lambda (src1873 exp1874) (if (and (self-evaluating? exp1874) (not (vector? exp1874))) (build-annotated1108 src1873 exp1874) (build-annotated1108 src1873 (list (quote quote) exp1874))))) (build-annotated1108 (lambda (src1875 exp1876) (if (and src1875 (not (annotation? exp1876))) (make-annotation exp1876 src1875 #t) exp1876))) (get-global-definition-hook1107 (lambda (symbol1877 module1878) (let ((module1879 (if module1878 (resolve-module (cdr module1878)) (let ((mod1880 (current-module))) (begin (if mod1880 (warn "wha" symbol1877)) mod1880))))) (let ((v1881 (module-variable module1879 symbol1877))) (and v1881 (object-property v1881 (quote *sc-expander*))))))) (remove-global-definition-hook1106 (lambda (symbol1882) (let ((module1883 (current-module))) (let ((v1884 (module-local-variable module1883 symbol1882))) (if v1884 (let ((p1885 (assq (quote *sc-expander*) (object-properties v1884)))) (set-object-properties! v1884 (delq p1885 (object-properties v1884))))))))) (put-global-definition-hook1105 (lambda (symbol1886 binding1887) (let ((module1888 (current-module))) (let ((v1889 (or (module-variable module1888 symbol1886) (let ((v1890 (make-variable (gensym)))) (begin (module-add! module1888 symbol1886 v1890) v1890))))) (begin (if (not (variable-bound? v1889)) (variable-set! v1889 (gensym))) (set-object-property! v1889 (quote *sc-expander*) binding1887)))))) (error-hook1104 (lambda (who1891 why1892 what1893) (error who1891 "~a ~s" why1892 what1893))) (local-eval-hook1103 (lambda (x1894 mod1895) (primitive-eval (list noexpand1097 x1894)))) (top-level-eval-hook1102 (lambda (x1896 mod1897) (primitive-eval (list noexpand1097 x1896)))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1898 r1899 w1900 s1901 mod1902) ((lambda (tmp1903) ((lambda (tmp1904) (if (if tmp1904 (apply (lambda (_1905 var1906 val1907 e11908 e21909) (valid-bound-ids?1156 var1906)) tmp1904) #f) (apply (lambda (_1911 var1912 val1913 e11914 e21915) (let ((names1916 (map (lambda (x1917) (id-var-name1153 x1917 w1900)) var1912))) (begin (for-each (lambda (id1919 n1920) (let ((t1921 (binding-type1123 (lookup1128 n1920 r1899 mod1902)))) (if (memv t1921 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1919 w1900 s1901 mod1902) "identifier out of context")))) var1912 names1916) (chi-body1171 (cons e11914 e21915) (source-wrap1160 e1898 w1900 s1901 mod1902) (extend-env1125 names1916 (let ((trans-r1924 (macros-only-env1127 r1899))) (map (lambda (x1925) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1925 trans-r1924 w1900 mod1902) mod1902))) val1913)) r1899) w1900 mod1902)))) tmp1904) ((lambda (_1927) (syntax-error (source-wrap1160 e1898 w1900 s1901 mod1902))) tmp1903))) (syntax-dispatch tmp1903 (quote (any #(each (any any)) any . each-any))))) e1898))) (global-extend1129 (quote core) (quote quote) (lambda (e1928 r1929 w1930 s1931 mod1932) ((lambda (tmp1933) ((lambda (tmp1934) (if tmp1934 (apply (lambda (_1935 e1936) (build-data1109 s1931 (strip1178 e1936 w1930))) tmp1934) ((lambda (_1937) (syntax-error (source-wrap1160 e1928 w1930 s1931 mod1932))) tmp1933))) (syntax-dispatch tmp1933 (quote (any any))))) e1928))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1945 (lambda (x1946) (let ((t1947 (car x1946))) (if (memv t1947 (quote (ref))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (primitive))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (quote))) (build-data1109 #f (cadr x1946)) (if (memv t1947 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1946) (regen1945 (caddr x1946)))) (if (memv t1947 (quote (map))) (let ((ls1948 (map regen1945 (cdr x1946)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1948) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1948))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1946)) (map regen1945 (cdr x1946)))))))))))) (gen-vector1944 (lambda (x1949) (cond ((eq? (car x1949) (quote list)) (cons (quote vector) (cdr x1949))) ((eq? (car x1949) (quote quote)) (list (quote quote) (list->vector (cadr x1949)))) (else (list (quote list->vector) x1949))))) (gen-append1943 (lambda (x1950 y1951) (if (equal? y1951 (quote (quote ()))) x1950 (list (quote append) x1950 y1951)))) (gen-cons1942 (lambda (x1952 y1953) (let ((t1954 (car y1953))) (if (memv t1954 (quote (quote))) (if (eq? (car x1952) (quote quote)) (list (quote quote) (cons (cadr x1952) (cadr y1953))) (if (eq? (cadr y1953) (quote ())) (list (quote list) x1952) (list (quote cons) x1952 y1953))) (if (memv t1954 (quote (list))) (cons (quote list) (cons x1952 (cdr y1953))) (list (quote cons) x1952 y1953)))))) (gen-map1941 (lambda (e1955 map-env1956) (let ((formals1957 (map cdr map-env1956)) (actuals1958 (map (lambda (x1959) (list (quote ref) (car x1959))) map-env1956))) (cond ((eq? (car e1955) (quote ref)) (car actuals1958)) ((andmap (lambda (x1960) (and (eq? (car x1960) (quote ref)) (memq (cadr x1960) formals1957))) (cdr e1955)) (cons (quote map) (cons (list (quote primitive) (car e1955)) (map (let ((r1961 (map cons formals1957 actuals1958))) (lambda (x1962) (cdr (assq (cadr x1962) r1961)))) (cdr e1955))))) (else (cons (quote map) (cons (list (quote lambda) formals1957 e1955) actuals1958))))))) (gen-mappend1940 (lambda (e1963 map-env1964) (list (quote apply) (quote (primitive append)) (gen-map1941 e1963 map-env1964)))) (gen-ref1939 (lambda (src1965 var1966 level1967 maps1968) (if (fx=1100 level1967 0) (values var1966 maps1968) (if (null? maps1968) (syntax-error src1965 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1939 src1965 var1966 (fx-1099 level1967 1) (cdr maps1968))) (lambda (outer-var1969 outer-maps1970) (let ((b1971 (assq outer-var1969 (car maps1968)))) (if b1971 (values (cdr b1971) maps1968) (let ((inner-var1972 (gen-var1179 (quote tmp)))) (values inner-var1972 (cons (cons (cons outer-var1969 inner-var1972) (car maps1968)) outer-maps1970))))))))))) (gen-syntax1938 (lambda (src1973 e1974 r1975 maps1976 ellipsis?1977 mod1978) (if (id?1131 e1974) (let ((label1979 (id-var-name1153 e1974 (quote (()))))) (let ((b1980 (lookup1128 label1979 r1975 mod1978))) (if (eq? (binding-type1123 b1980) (quote syntax)) (call-with-values (lambda () (let ((var.lev1981 (binding-value1124 b1980))) (gen-ref1939 src1973 (car var.lev1981) (cdr var.lev1981) maps1976))) (lambda (var1982 maps1983) (values (list (quote ref) var1982) maps1983))) (if (ellipsis?1977 e1974) (syntax-error src1973 "misplaced ellipsis in syntax form") (values (list (quote quote) e1974) maps1976))))) ((lambda (tmp1984) ((lambda (tmp1985) (if (if tmp1985 (apply (lambda (dots1986 e1987) (ellipsis?1977 dots1986)) tmp1985) #f) (apply (lambda (dots1988 e1989) (gen-syntax1938 src1973 e1989 r1975 maps1976 (lambda (x1990) #f) mod1978)) tmp1985) ((lambda (tmp1991) (if (if tmp1991 (apply (lambda (x1992 dots1993 y1994) (ellipsis?1977 dots1993)) tmp1991) #f) (apply (lambda (x1995 dots1996 y1997) (let f1998 ((y1999 y1997) (k2000 (lambda (maps2001) (call-with-values (lambda () (gen-syntax1938 src1973 x1995 r1975 (cons (quote ()) maps2001) ellipsis?1977 mod1978)) (lambda (x2002 maps2003) (if (null? (car maps2003)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-map1941 x2002 (car maps2003)) (cdr maps2003)))))))) ((lambda (tmp2004) ((lambda (tmp2005) (if (if tmp2005 (apply (lambda (dots2006 y2007) (ellipsis?1977 dots2006)) tmp2005) #f) (apply (lambda (dots2008 y2009) (f1998 y2009 (lambda (maps2010) (call-with-values (lambda () (k2000 (cons (quote ()) maps2010))) (lambda (x2011 maps2012) (if (null? (car maps2012)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-mappend1940 x2011 (car maps2012)) (cdr maps2012)))))))) tmp2005) ((lambda (_2013) (call-with-values (lambda () (gen-syntax1938 src1973 y1999 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (y2014 maps2015) (call-with-values (lambda () (k2000 maps2015)) (lambda (x2016 maps2017) (values (gen-append1943 x2016 y2014) maps2017)))))) tmp2004))) (syntax-dispatch tmp2004 (quote (any . any))))) y1999))) tmp1991) ((lambda (tmp2018) (if tmp2018 (apply (lambda (x2019 y2020) (call-with-values (lambda () (gen-syntax1938 src1973 x2019 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (x2021 maps2022) (call-with-values (lambda () (gen-syntax1938 src1973 y2020 r1975 maps2022 ellipsis?1977 mod1978)) (lambda (y2023 maps2024) (values (gen-cons1942 x2021 y2023) maps2024)))))) tmp2018) ((lambda (tmp2025) (if tmp2025 (apply (lambda (e12026 e22027) (call-with-values (lambda () (gen-syntax1938 src1973 (cons e12026 e22027) r1975 maps1976 ellipsis?1977 mod1978)) (lambda (e2029 maps2030) (values (gen-vector1944 e2029) maps2030)))) tmp2025) ((lambda (_2031) (values (list (quote quote) e1974) maps1976)) tmp1984))) (syntax-dispatch tmp1984 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1984 (quote (any . any)))))) (syntax-dispatch tmp1984 (quote (any any . any)))))) (syntax-dispatch tmp1984 (quote (any any))))) e1974))))) (lambda (e2032 r2033 w2034 s2035 mod2036) (let ((e2037 (source-wrap1160 e2032 w2034 s2035 mod2036))) ((lambda (tmp2038) ((lambda (tmp2039) (if tmp2039 (apply (lambda (_2040 x2041) (call-with-values (lambda () (gen-syntax1938 e2037 x2041 r2033 (quote ()) ellipsis?1176 mod2036)) (lambda (e2042 maps2043) (regen1945 e2042)))) tmp2039) ((lambda (_2044) (syntax-error e2037)) tmp2038))) (syntax-dispatch tmp2038 (quote (any any))))) e2037))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2045 r2046 w2047 s2048 mod2049) ((lambda (tmp2050) ((lambda (tmp2051) (if tmp2051 (apply (lambda (_2052 c2053) (chi-lambda-clause1172 (source-wrap1160 e2045 w2047 s2048 mod2049) c2053 r2046 w2047 mod2049 (lambda (vars2054 body2055) (build-annotated1108 s2048 (list (quote lambda) vars2054 body2055))))) tmp2051) (syntax-error tmp2050))) (syntax-dispatch tmp2050 (quote (any . any))))) e2045))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2056 (lambda (e2057 r2058 w2059 s2060 mod2061 constructor2062 ids2063 vals2064 exps2065) (if (not (valid-bound-ids?1156 ids2063)) (syntax-error e2057 "duplicate bound variable in") (let ((labels2066 (gen-labels1137 ids2063)) (new-vars2067 (map gen-var1179 ids2063))) (let ((nw2068 (make-binding-wrap1148 ids2063 labels2066 w2059)) (nr2069 (extend-var-env1126 labels2066 new-vars2067 r2058))) (constructor2062 s2060 new-vars2067 (map (lambda (x2070) (chi1167 x2070 r2058 w2059 mod2061)) vals2064) (chi-body1171 exps2065 (source-wrap1160 e2057 nw2068 s2060 mod2061) nr2069 nw2068 mod2061)))))))) (lambda (e2071 r2072 w2073 s2074 mod2075) ((lambda (tmp2076) ((lambda (tmp2077) (if tmp2077 (apply (lambda (_2078 id2079 val2080 e12081 e22082) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-let1111 id2079 val2080 (cons e12081 e22082))) tmp2077) ((lambda (tmp2086) (if (if tmp2086 (apply (lambda (_2087 f2088 id2089 val2090 e12091 e22092) (id?1131 f2088)) tmp2086) #f) (apply (lambda (_2093 f2094 id2095 val2096 e12097 e22098) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-named-let1112 (cons f2094 id2095) val2096 (cons e12097 e22098))) tmp2086) ((lambda (_2102) (syntax-error (source-wrap1160 e2071 w2073 s2074 mod2075))) tmp2076))) (syntax-dispatch tmp2076 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2076 (quote (any #(each (any any)) any . each-any))))) e2071)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2103 r2104 w2105 s2106 mod2107) ((lambda (tmp2108) ((lambda (tmp2109) (if tmp2109 (apply (lambda (_2110 id2111 val2112 e12113 e22114) (let ((ids2115 id2111)) (if (not (valid-bound-ids?1156 ids2115)) (syntax-error e2103 "duplicate bound variable in") (let ((labels2117 (gen-labels1137 ids2115)) (new-vars2118 (map gen-var1179 ids2115))) (let ((w2119 (make-binding-wrap1148 ids2115 labels2117 w2105)) (r2120 (extend-var-env1126 labels2117 new-vars2118 r2104))) (build-letrec1113 s2106 new-vars2118 (map (lambda (x2121) (chi1167 x2121 r2120 w2119 mod2107)) val2112) (chi-body1171 (cons e12113 e22114) (source-wrap1160 e2103 w2119 s2106 mod2107) r2120 w2119 mod2107))))))) tmp2109) ((lambda (_2124) (syntax-error (source-wrap1160 e2103 w2105 s2106 mod2107))) tmp2108))) (syntax-dispatch tmp2108 (quote (any #(each (any any)) any . each-any))))) e2103))) (global-extend1129 (quote core) (quote set!) (lambda (e2125 r2126 w2127 s2128 mod2129) ((lambda (tmp2130) ((lambda (tmp2131) (if (if tmp2131 (apply (lambda (_2132 id2133 val2134) (id?1131 id2133)) tmp2131) #f) (apply (lambda (_2135 id2136 val2137) (let ((val2138 (chi1167 val2137 r2126 w2127 mod2129)) (n2139 (id-var-name1153 id2136 w2127))) (let ((b2140 (lookup1128 n2139 r2126 mod2129))) (let ((t2141 (binding-type1123 b2140))) (if (memv t2141 (quote (lexical))) (build-annotated1108 s2128 (list (quote set!) (binding-value1124 b2140) val2138)) (if (memv t2141 (quote (global))) (build-annotated1108 s2128 (list (quote set!) (if mod2129 (make-module-ref (cdr mod2129) n2139 (car mod2129)) (make-module-ref mod2129 n2139 (quote bare))) val2138)) (if (memv t2141 (quote (displaced-lexical))) (syntax-error (wrap1159 id2136 w2127 mod2129) "identifier out of context") (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))))))))) tmp2131) ((lambda (tmp2142) (if tmp2142 (apply (lambda (_2143 head2144 tail2145 val2146) (call-with-values (lambda () (syntax-type1165 head2144 r2126 (quote (())) #f #f mod2129)) (lambda (type2147 value2148 ee2149 ww2150 ss2151 modmod2152) (let ((t2153 type2147)) (if (memv t2153 (quote (module-ref))) (let ((val2154 (chi1167 val2146 r2126 w2127 mod2129))) (call-with-values (lambda () (value2148 (cons head2144 tail2145))) (lambda (id2156 mod2157) (build-annotated1108 s2128 (list (quote set!) (if mod2157 (make-module-ref (cdr mod2157) id2156 (car mod2157)) (make-module-ref mod2157 id2156 (quote bare))) val2154))))) (build-annotated1108 s2128 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2144) r2126 w2127 mod2129) (map (lambda (e2158) (chi1167 e2158 r2126 w2127 mod2129)) (append tail2145 (list val2146)))))))))) tmp2142) ((lambda (_2160) (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))) tmp2130))) (syntax-dispatch tmp2130 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2130 (quote (any any any))))) e2125))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2161) ((lambda (tmp2162) ((lambda (tmp2163) (if (if tmp2163 (apply (lambda (_2164 mod2165 id2166) (and (andmap id?1131 mod2165) (id?1131 id2166))) tmp2163) #f) (apply (lambda (_2168 mod2169 id2170) (values (syntax-object->datum id2170) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2169)))) tmp2163) (syntax-error tmp2162))) (syntax-dispatch tmp2162 (quote (any each-any any))))) e2161))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2172) ((lambda (tmp2173) ((lambda (tmp2174) (if (if tmp2174 (apply (lambda (_2175 mod2176 id2177) (and (andmap id?1131 mod2176) (id?1131 id2177))) tmp2174) #f) (apply (lambda (_2179 mod2180 id2181) (values (syntax-object->datum id2181) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2180)))) tmp2174) (syntax-error tmp2173))) (syntax-dispatch tmp2173 (quote (any each-any any))))) e2172))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2186 (lambda (x2187 keys2188 clauses2189 r2190 mod2191) (if (null? clauses2189) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2187)) ((lambda (tmp2192) ((lambda (tmp2193) (if tmp2193 (apply (lambda (pat2194 exp2195) (if (and (id?1131 pat2194) (andmap (lambda (x2196) (not (free-id=?1154 pat2194 x2196))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2188))) (let ((labels2197 (list (gen-label1136))) (var2198 (gen-var1179 pat2194))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2198) (chi1167 exp2195 (extend-env1125 labels2197 (list (cons (quote syntax) (cons var2198 0))) r2190) (make-binding-wrap1148 (list pat2194) labels2197 (quote (()))) mod2191))) x2187))) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2194 #t exp2195 mod2191))) tmp2193) ((lambda (tmp2199) (if tmp2199 (apply (lambda (pat2200 fender2201 exp2202) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2200 fender2201 exp2202 mod2191)) tmp2199) ((lambda (_2203) (syntax-error (car clauses2189) "invalid syntax-case clause")) tmp2192))) (syntax-dispatch tmp2192 (quote (any any any)))))) (syntax-dispatch tmp2192 (quote (any any))))) (car clauses2189))))) (gen-clause2185 (lambda (x2204 keys2205 clauses2206 r2207 pat2208 fender2209 exp2210 mod2211) (call-with-values (lambda () (convert-pattern2183 pat2208 keys2205)) (lambda (p2212 pvars2213) (cond ((not (distinct-bound-ids?1157 (map car pvars2213))) (syntax-error pat2208 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2214) (not (ellipsis?1176 (car x2214)))) pvars2213)) (syntax-error pat2208 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2215 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2215) (let ((y2216 (build-annotated1108 #f y2215))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2217) ((lambda (tmp2218) (if tmp2218 (apply (lambda () y2216) tmp2218) ((lambda (_2219) (build-annotated1108 #f (list (quote if) y2216 (build-dispatch-call2184 pvars2213 fender2209 y2216 r2207 mod2211) (build-data1109 #f #f)))) tmp2217))) (syntax-dispatch tmp2217 (quote #(atom #t))))) fender2209) (build-dispatch-call2184 pvars2213 exp2210 y2216 r2207 mod2211) (gen-syntax-case2186 x2204 keys2205 clauses2206 r2207 mod2211)))))) (if (eq? p2212 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2204)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2204 (build-data1109 #f p2212))))))))))))) (build-dispatch-call2184 (lambda (pvars2220 exp2221 y2222 r2223 mod2224) (let ((ids2225 (map car pvars2220)) (levels2226 (map cdr pvars2220))) (let ((labels2227 (gen-labels1137 ids2225)) (new-vars2228 (map gen-var1179 ids2225))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2228 (chi1167 exp2221 (extend-env1125 labels2227 (map (lambda (var2229 level2230) (cons (quote syntax) (cons var2229 level2230))) new-vars2228 (map cdr pvars2220)) r2223) (make-binding-wrap1148 ids2225 labels2227 (quote (()))) mod2224))) y2222)))))) (convert-pattern2183 (lambda (pattern2231 keys2232) (let cvt2233 ((p2234 pattern2231) (n2235 0) (ids2236 (quote ()))) (if (id?1131 p2234) (if (bound-id-member?1158 p2234 keys2232) (values (vector (quote free-id) p2234) ids2236) (values (quote any) (cons (cons p2234 n2235) ids2236))) ((lambda (tmp2237) ((lambda (tmp2238) (if (if tmp2238 (apply (lambda (x2239 dots2240) (ellipsis?1176 dots2240)) tmp2238) #f) (apply (lambda (x2241 dots2242) (call-with-values (lambda () (cvt2233 x2241 (fx+1098 n2235 1) ids2236)) (lambda (p2243 ids2244) (values (if (eq? p2243 (quote any)) (quote each-any) (vector (quote each) p2243)) ids2244)))) tmp2238) ((lambda (tmp2245) (if tmp2245 (apply (lambda (x2246 y2247) (call-with-values (lambda () (cvt2233 y2247 n2235 ids2236)) (lambda (y2248 ids2249) (call-with-values (lambda () (cvt2233 x2246 n2235 ids2249)) (lambda (x2250 ids2251) (values (cons x2250 y2248) ids2251)))))) tmp2245) ((lambda (tmp2252) (if tmp2252 (apply (lambda () (values (quote ()) ids2236)) tmp2252) ((lambda (tmp2253) (if tmp2253 (apply (lambda (x2254) (call-with-values (lambda () (cvt2233 x2254 n2235 ids2236)) (lambda (p2256 ids2257) (values (vector (quote vector) p2256) ids2257)))) tmp2253) ((lambda (x2258) (values (vector (quote atom) (strip1178 p2234 (quote (())))) ids2236)) tmp2237))) (syntax-dispatch tmp2237 (quote #(vector each-any)))))) (syntax-dispatch tmp2237 (quote ()))))) (syntax-dispatch tmp2237 (quote (any . any)))))) (syntax-dispatch tmp2237 (quote (any any))))) p2234)))))) (lambda (e2259 r2260 w2261 s2262 mod2263) (let ((e2264 (source-wrap1160 e2259 w2261 s2262 mod2263))) ((lambda (tmp2265) ((lambda (tmp2266) (if tmp2266 (apply (lambda (_2267 val2268 key2269 m2270) (if (andmap (lambda (x2271) (and (id?1131 x2271) (not (ellipsis?1176 x2271)))) key2269) (let ((x2273 (gen-var1179 (quote tmp)))) (build-annotated1108 s2262 (list (build-annotated1108 #f (list (quote lambda) (list x2273) (gen-syntax-case2186 (build-annotated1108 #f x2273) key2269 m2270 r2260 mod2263))) (chi1167 val2268 r2260 (quote (())) mod2263)))) (syntax-error e2264 "invalid literals list in"))) tmp2266) (syntax-error tmp2265))) (syntax-dispatch tmp2265 (quote (any any each-any . each-any))))) e2264))))) (set! sc-expand (let ((m2276 (quote e)) (esew2277 (quote (eval)))) (lambda (x2278) (if (and (pair? x2278) (equal? (car x2278) noexpand1097)) (cadr x2278) (chi-top1166 x2278 (quote ()) (quote ((top))) m2276 esew2277 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2279 (quote e)) (esew2280 (quote (eval)))) (lambda (x2282 . rest2281) (if (and (pair? x2282) (equal? (car x2282) noexpand1097)) (cadr x2282) (chi-top1166 x2282 (quote ()) (quote ((top))) (if (null? rest2281) m2279 (car rest2281)) (if (or (null? rest2281) (null? (cdr rest2281))) esew2280 (cadr rest2281)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2283) (nonsymbol-id?1130 x2283))) (set! datum->syntax-object (lambda (id2284 datum2285) (make-syntax-object1114 datum2285 (syntax-object-wrap1117 id2284) #f))) (set! syntax-object->datum (lambda (x2286) (strip1178 x2286 (quote (()))))) (set! generate-temporaries (lambda (ls2287) (begin (let ((x2288 ls2287)) (if (not (list? x2288)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2288))) (map (lambda (x2289) (wrap1159 (gensym) (quote ((top))) #f)) ls2287)))) (set! free-identifier=? (lambda (x2290 y2291) (begin (let ((x2292 x2290)) (if (not (nonsymbol-id?1130 x2292)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2292))) (let ((x2293 y2291)) (if (not (nonsymbol-id?1130 x2293)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2293))) (free-id=?1154 x2290 y2291)))) (set! bound-identifier=? (lambda (x2294 y2295) (begin (let ((x2296 x2294)) (if (not (nonsymbol-id?1130 x2296)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2296))) (let ((x2297 y2295)) (if (not (nonsymbol-id?1130 x2297)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2297))) (bound-id=?1155 x2294 y2295)))) (set! syntax-error (lambda (object2299 . messages2298) (begin (for-each (lambda (x2300) (let ((x2301 x2300)) (if (not (string? x2301)) (error-hook1104 (quote syntax-error) "invalid argument" x2301)))) messages2298) (let ((message2302 (if (null? messages2298) "invalid syntax" (apply string-append messages2298)))) (error-hook1104 #f message2302 (strip1178 object2299 (quote (())))))))) (set! install-global-transformer (lambda (sym2303 v2304) (begin (let ((x2305 sym2303)) (if (not (symbol? x2305)) (error-hook1104 (quote define-syntax) "invalid argument" x2305))) (let ((x2306 v2304)) (if (not (procedure? x2306)) (error-hook1104 (quote define-syntax) "invalid argument" x2306))) (global-extend1129 (quote macro) sym2303 v2304)))) (letrec ((match2311 (lambda (e2312 p2313 w2314 r2315 mod2316) (cond ((not r2315) #f) ((eq? p2313 (quote any)) (cons (wrap1159 e2312 w2314 mod2316) r2315)) ((syntax-object?1115 e2312) (match*2310 (let ((e2317 (syntax-object-expression1116 e2312))) (if (annotation? e2317) (annotation-expression e2317) e2317)) p2313 (join-wraps1150 w2314 (syntax-object-wrap1117 e2312)) r2315 (syntax-object-module1118 e2312))) (else (match*2310 (let ((e2318 e2312)) (if (annotation? e2318) (annotation-expression e2318) e2318)) p2313 w2314 r2315 mod2316))))) (match*2310 (lambda (e2319 p2320 w2321 r2322 mod2323) (cond ((null? p2320) (and (null? e2319) r2322)) ((pair? p2320) (and (pair? e2319) (match2311 (car e2319) (car p2320) w2321 (match2311 (cdr e2319) (cdr p2320) w2321 r2322 mod2323) mod2323))) ((eq? p2320 (quote each-any)) (let ((l2324 (match-each-any2308 e2319 w2321 mod2323))) (and l2324 (cons l2324 r2322)))) (else (let ((t2325 (vector-ref p2320 0))) (if (memv t2325 (quote (each))) (if (null? e2319) (match-empty2309 (vector-ref p2320 1) r2322) (let ((l2326 (match-each2307 e2319 (vector-ref p2320 1) w2321 mod2323))) (and l2326 (let collect2327 ((l2328 l2326)) (if (null? (car l2328)) r2322 (cons (map car l2328) (collect2327 (map cdr l2328)))))))) (if (memv t2325 (quote (free-id))) (and (id?1131 e2319) (free-id=?1154 (wrap1159 e2319 w2321 mod2323) (vector-ref p2320 1)) r2322) (if (memv t2325 (quote (atom))) (and (equal? (vector-ref p2320 1) (strip1178 e2319 w2321)) r2322) (if (memv t2325 (quote (vector))) (and (vector? e2319) (match2311 (vector->list e2319) (vector-ref p2320 1) w2321 r2322 mod2323))))))))))) (match-empty2309 (lambda (p2329 r2330) (cond ((null? p2329) r2330) ((eq? p2329 (quote any)) (cons (quote ()) r2330)) ((pair? p2329) (match-empty2309 (car p2329) (match-empty2309 (cdr p2329) r2330))) ((eq? p2329 (quote each-any)) (cons (quote ()) r2330)) (else (let ((t2331 (vector-ref p2329 0))) (if (memv t2331 (quote (each))) (match-empty2309 (vector-ref p2329 1) r2330) (if (memv t2331 (quote (free-id atom))) r2330 (if (memv t2331 (quote (vector))) (match-empty2309 (vector-ref p2329 1) r2330))))))))) (match-each-any2308 (lambda (e2332 w2333 mod2334) (cond ((annotation? e2332) (match-each-any2308 (annotation-expression e2332) w2333 mod2334)) ((pair? e2332) (let ((l2335 (match-each-any2308 (cdr e2332) w2333 mod2334))) (and l2335 (cons (wrap1159 (car e2332) w2333 mod2334) l2335)))) ((null? e2332) (quote ())) ((syntax-object?1115 e2332) (match-each-any2308 (syntax-object-expression1116 e2332) (join-wraps1150 w2333 (syntax-object-wrap1117 e2332)) mod2334)) (else #f)))) (match-each2307 (lambda (e2336 p2337 w2338 mod2339) (cond ((annotation? e2336) (match-each2307 (annotation-expression e2336) p2337 w2338 mod2339)) ((pair? e2336) (let ((first2340 (match2311 (car e2336) p2337 w2338 (quote ()) mod2339))) (and first2340 (let ((rest2341 (match-each2307 (cdr e2336) p2337 w2338 mod2339))) (and rest2341 (cons first2340 rest2341)))))) ((null? e2336) (quote ())) ((syntax-object?1115 e2336) (match-each2307 (syntax-object-expression1116 e2336) p2337 (join-wraps1150 w2338 (syntax-object-wrap1117 e2336)) (syntax-object-module1118 e2336))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2342 p2343) (cond ((eq? p2343 (quote any)) (list e2342)) ((syntax-object?1115 e2342) (match*2310 (let ((e2344 (syntax-object-expression1116 e2342))) (if (annotation? e2344) (annotation-expression e2344) e2344)) p2343 (syntax-object-wrap1117 e2342) (quote ()) (syntax-object-module1118 e2342))) (else (match*2310 (let ((e2345 e2342)) (if (annotation? e2345) (annotation-expression e2345) e2345)) p2343 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) +(install-global-transformer (quote with-syntax) (lambda (x2346) ((lambda (tmp2347) ((lambda (tmp2348) (if tmp2348 (apply (lambda (_2349 e12350 e22351) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12350 e22351))) tmp2348) ((lambda (tmp2353) (if tmp2353 (apply (lambda (_2354 out2355 in2356 e12357 e22358) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2356 (quote ()) (list out2355 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12357 e22358))))) tmp2353) ((lambda (tmp2360) (if tmp2360 (apply (lambda (_2361 out2362 in2363 e12364 e22365) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2363) (quote ()) (list out2362 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12364 e22365))))) tmp2360) (syntax-error tmp2347))) (syntax-dispatch tmp2347 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any () any . each-any))))) x2346))) +(install-global-transformer (quote syntax-rules) (lambda (x2369) ((lambda (tmp2370) ((lambda (tmp2371) (if tmp2371 (apply (lambda (_2372 k2373 keyword2374 pattern2375 template2376) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2373 (map (lambda (tmp2379 tmp2378) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2378) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2379))) template2376 pattern2375)))))) tmp2371) (syntax-error tmp2370))) (syntax-dispatch tmp2370 (quote (any each-any . #(each ((any . any) any))))))) x2369))) +(install-global-transformer (quote let*) (lambda (x2380) ((lambda (tmp2381) ((lambda (tmp2382) (if (if tmp2382 (apply (lambda (let*2383 x2384 v2385 e12386 e22387) (andmap identifier? x2384)) tmp2382) #f) (apply (lambda (let*2389 x2390 v2391 e12392 e22393) (let f2394 ((bindings2395 (map list x2390 v2391))) (if (null? bindings2395) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12392 e22393))) ((lambda (tmp2399) ((lambda (tmp2400) (if tmp2400 (apply (lambda (body2401 binding2402) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2402) body2401)) tmp2400) (syntax-error tmp2399))) (syntax-dispatch tmp2399 (quote (any any))))) (list (f2394 (cdr bindings2395)) (car bindings2395)))))) tmp2382) (syntax-error tmp2381))) (syntax-dispatch tmp2381 (quote (any #(each (any any)) any . each-any))))) x2380))) +(install-global-transformer (quote do) (lambda (orig-x2403) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 var2407 init2408 step2409 e02410 e12411 c2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (step2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02410) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2415))))))) tmp2417) ((lambda (tmp2422) (if tmp2422 (apply (lambda (e12423 e22424) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02410 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12423 e22424)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2415))))))) tmp2422) (syntax-error tmp2416))) (syntax-dispatch tmp2416 (quote (any . each-any)))))) (syntax-dispatch tmp2416 (quote ())))) e12411)) tmp2414) (syntax-error tmp2413))) (syntax-dispatch tmp2413 (quote each-any)))) (map (lambda (v2431 s2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () v2431) tmp2434) ((lambda (tmp2435) (if tmp2435 (apply (lambda (e2436) e2436) tmp2435) ((lambda (_2437) (syntax-error orig-x2403)) tmp2433))) (syntax-dispatch tmp2433 (quote (any)))))) (syntax-dispatch tmp2433 (quote ())))) s2432)) var2407 step2409))) tmp2405) (syntax-error tmp2404))) (syntax-dispatch tmp2404 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2403))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2440 (lambda (x2444 y2445) ((lambda (tmp2446) ((lambda (tmp2447) (if tmp2447 (apply (lambda (x2448 y2449) ((lambda (tmp2450) ((lambda (tmp2451) (if tmp2451 (apply (lambda (dy2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (dx2455) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2455 dy2452))) tmp2454) ((lambda (_2456) (if (null? dy2452) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448 y2449))) tmp2453))) (syntax-dispatch tmp2453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2448)) tmp2451) ((lambda (tmp2457) (if tmp2457 (apply (lambda (stuff2458) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2448 stuff2458))) tmp2457) ((lambda (else2459) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448 y2449)) tmp2450))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2449)) tmp2447) (syntax-error tmp2446))) (syntax-dispatch tmp2446 (quote (any any))))) (list x2444 y2445)))) (quasiappend2441 (lambda (x2460 y2461) ((lambda (tmp2462) ((lambda (tmp2463) (if tmp2463 (apply (lambda (x2464 y2465) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda () x2464) tmp2467) ((lambda (_2468) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2464 y2465)) tmp2466))) (syntax-dispatch tmp2466 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2465)) tmp2463) (syntax-error tmp2462))) (syntax-dispatch tmp2462 (quote (any any))))) (list x2460 y2461)))) (quasivector2442 (lambda (x2469) ((lambda (tmp2470) ((lambda (x2471) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (x2474) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2474))) tmp2473) ((lambda (tmp2476) (if tmp2476 (apply (lambda (x2477) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2477)) tmp2476) ((lambda (_2479) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2471)) tmp2472))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2471)) tmp2470)) x2469))) (quasi2443 (lambda (p2480 lev2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (p2484) (if (= lev2481 0) p2484 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2443 (list p2484) (- lev2481 1))))) tmp2483) ((lambda (tmp2485) (if tmp2485 (apply (lambda (p2486 q2487) (if (= lev2481 0) (quasiappend2441 p2486 (quasi2443 q2487 lev2481)) (quasicons2440 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2443 (list p2486) (- lev2481 1))) (quasi2443 q2487 lev2481)))) tmp2485) ((lambda (tmp2488) (if tmp2488 (apply (lambda (p2489) (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2443 (list p2489) (+ lev2481 1)))) tmp2488) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491 q2492) (quasicons2440 (quasi2443 p2491 lev2481) (quasi2443 q2492 lev2481))) tmp2490) ((lambda (tmp2493) (if tmp2493 (apply (lambda (x2494) (quasivector2442 (quasi2443 x2494 lev2481))) tmp2493) ((lambda (p2496) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2496)) tmp2482))) (syntax-dispatch tmp2482 (quote #(vector each-any)))))) (syntax-dispatch tmp2482 (quote (any . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2482 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2480)))) (lambda (x2497) ((lambda (tmp2498) ((lambda (tmp2499) (if tmp2499 (apply (lambda (_2500 e2501) (quasi2443 e2501 0)) tmp2499) (syntax-error tmp2498))) (syntax-dispatch tmp2498 (quote (any any))))) x2497)))) +(install-global-transformer (quote include) (lambda (x2502) (letrec ((read-file2503 (lambda (fn2504 k2505) (let ((p2506 (open-input-file fn2504))) (let f2507 ((x2508 (read p2506))) (if (eof-object? x2508) (begin (close-input-port p2506) (quote ())) (cons (datum->syntax-object k2505 x2508) (f2507 (read p2506))))))))) ((lambda (tmp2509) ((lambda (tmp2510) (if tmp2510 (apply (lambda (k2511 filename2512) (let ((fn2513 (syntax-object->datum filename2512))) ((lambda (tmp2514) ((lambda (tmp2515) (if tmp2515 (apply (lambda (exp2516) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2516)) tmp2515) (syntax-error tmp2514))) (syntax-dispatch tmp2514 (quote each-any)))) (read-file2503 fn2513 k2511)))) tmp2510) (syntax-error tmp2509))) (syntax-dispatch tmp2509 (quote (any any))))) x2502)))) (install-global-transformer (quote unquote) (lambda (x2518) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (_2521 e2522) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2522))) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote (any any))))) x2518))) (install-global-transformer (quote unquote-splicing) (lambda (x2523) ((lambda (tmp2524) ((lambda (tmp2525) (if tmp2525 (apply (lambda (_2526 e2527) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2527))) tmp2525) (syntax-error tmp2524))) (syntax-dispatch tmp2524 (quote (any any))))) x2523))) -(install-global-transformer (quote case) (lambda (x2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda (_2531 e2532 m12533 m22534) ((lambda (tmp2535) ((lambda (body2536) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2532)) body2536)) tmp2535)) (let f2537 ((clause2538 m12533) (clauses2539 m22534)) (if (null? clauses2539) ((lambda (tmp2541) ((lambda (tmp2542) (if tmp2542 (apply (lambda (e12543 e22544) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12543 e22544))) tmp2542) ((lambda (tmp2546) (if tmp2546 (apply (lambda (k2547 e12548 e22549) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2547)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12548 e22549)))) tmp2546) ((lambda (_2552) (syntax-error x2528)) tmp2541))) (syntax-dispatch tmp2541 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2541 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) any . each-any))))) clause2538) ((lambda (tmp2553) ((lambda (rest2554) ((lambda (tmp2555) ((lambda (tmp2556) (if tmp2556 (apply (lambda (k2557 e12558 e22559) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) k2557)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e12558 e22559)) rest2554)) tmp2556) ((lambda (_2562) (syntax-error x2528)) tmp2555))) (syntax-dispatch tmp2555 (quote (each-any any . each-any))))) clause2538)) tmp2553)) (f2537 (car clauses2539) (cdr clauses2539))))))) tmp2530) (syntax-error tmp2529))) (syntax-dispatch tmp2529 (quote (any any any . each-any))))) x2528))) -(install-global-transformer (quote identifier-syntax) (lambda (x2563) ((lambda (tmp2564) ((lambda (tmp2565) (if tmp2565 (apply (lambda (_2566 e2567) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) e2567)) (list (cons _2566 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile))) (cons e2567 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (guile)))))))))) tmp2565) (syntax-error tmp2564))) (syntax-dispatch tmp2564 (quote (any any))))) x2563))) +(install-global-transformer (quote case) (lambda (x2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda (_2531 e2532 m12533 m22534) ((lambda (tmp2535) ((lambda (body2536) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2532)) body2536)) tmp2535)) (let f2537 ((clause2538 m12533) (clauses2539 m22534)) (if (null? clauses2539) ((lambda (tmp2541) ((lambda (tmp2542) (if tmp2542 (apply (lambda (e12543 e22544) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12543 e22544))) tmp2542) ((lambda (tmp2546) (if tmp2546 (apply (lambda (k2547 e12548 e22549) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2547)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12548 e22549)))) tmp2546) ((lambda (_2552) (syntax-error x2528)) tmp2541))) (syntax-dispatch tmp2541 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2541 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2538) ((lambda (tmp2553) ((lambda (rest2554) ((lambda (tmp2555) ((lambda (tmp2556) (if tmp2556 (apply (lambda (k2557 e12558 e22559) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2557)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12558 e22559)) rest2554)) tmp2556) ((lambda (_2562) (syntax-error x2528)) tmp2555))) (syntax-dispatch tmp2555 (quote (each-any any . each-any))))) clause2538)) tmp2553)) (f2537 (car clauses2539) (cdr clauses2539))))))) tmp2530) (syntax-error tmp2529))) (syntax-dispatch tmp2529 (quote (any any any . each-any))))) x2528))) +(install-global-transformer (quote identifier-syntax) (lambda (x2563) ((lambda (tmp2564) ((lambda (tmp2565) (if tmp2565 (apply (lambda (_2566 e2567) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2567)) (list (cons _2566 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2567 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2565) (syntax-error tmp2564))) (syntax-dispatch tmp2564 (quote (any any))))) x2563))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 94c408343..72a3c3f16 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -357,19 +357,13 @@ (define get-global-definition-hook (lambda (symbol module) (let* ((module (if module - (resolve-module (if (memq (car module) '(#f hygiene public private bare)) - (cdr module) - module)) + (resolve-module (cdr module)) (let ((mod (current-module))) (if mod (warn "wha" symbol)) mod))) (v (module-variable module symbol))) - (and v - (or (object-property v '*sc-expander*) - (and (variable-bound? v) - (macro? (variable-ref v)) - (macro-transformer (variable-ref v)) ;non-primitive - guile-macro)))))) + (and v (object-property v '*sc-expander*))))) + ) @@ -404,19 +398,17 @@ ((_ source var mod) (build-annotated source - (cond ((not mod) (make-module-ref mod var 'bare)) - ((not (car mod)) (make-module-ref (cdr mod) var 'public)) - ((memq (car mod) '(bare public private hygiene)) (make-module-ref (cdr mod) var (car mod))) - (else (make-module-ref mod var 'private))))))) + (if mod + (make-module-ref (cdr mod) var (car mod)) + (make-module-ref mod var 'bare)))))) (define-syntax build-global-assignment (syntax-rules () ((_ source var exp mod) (build-annotated source - `(set! ,(cond ((not mod) (make-module-ref mod var 'bare)) - ((not (car mod)) (make-module-ref (cdr mod) var 'public)) - ((memq (car mod) '(bare public private hygiene)) (make-module-ref (cdr mod) var (car mod))) - (else (make-module-ref mod var 'private))) + `(set! ,(if mod + (make-module-ref (cdr mod) var (car mod)) + (make-module-ref mod var 'bare)) ,exp))))) (define-syntax build-global-definition From 58df2e43937bb86fbf751f48db7bf13934d7c87e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 19:16:06 +0200 Subject: [PATCH 070/375] merge ice-9, srfi, oop makfiles into module makefile * configure.in: No longer output the Makefile.ins. * module/Makefile.am: Include the contents of ice-9/, srfi/, and oop/. * module/ice-9/Makefile.am: * module/ice-9/debugger/Makefile.am: * module/ice-9/debugging/Makefile.am: * module/oop/Makefile.am: * module/oop/goops/Makefile.am: * module/srfi/Makefile.am: Removed. --- configure.in | 6 -- module/Makefile.am | 140 +++++++++++++++++++++++++++-- module/ice-9/Makefile.am | 70 --------------- module/ice-9/debugger/Makefile.am | 31 ------- module/ice-9/debugging/Makefile.am | 33 ------- module/oop/Makefile.am | 30 ------- module/oop/goops/Makefile.am | 30 ------- 7 files changed, 135 insertions(+), 205 deletions(-) delete mode 100644 module/ice-9/Makefile.am delete mode 100644 module/ice-9/debugger/Makefile.am delete mode 100644 module/ice-9/debugging/Makefile.am delete mode 100644 module/oop/Makefile.am delete mode 100644 module/oop/goops/Makefile.am diff --git a/configure.in b/configure.in index 354e93c54..553d68814 100644 --- a/configure.in +++ b/configure.in @@ -1542,12 +1542,6 @@ AC_CONFIG_FILES([ test-suite/standalone/Makefile meta/Makefile module/Makefile - module/ice-9/Makefile - module/ice-9/debugger/Makefile - module/ice-9/debugging/Makefile - module/srfi/Makefile - module/oop/Makefile - module/oop/goops/Makefile testsuite/Makefile ]) diff --git a/module/Makefile.am b/module/Makefile.am index ee552762a..95dc75ac2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -19,16 +19,19 @@ ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA -# Build the compiler and VM support first to avoid stack overflows -# when building the rest. -SUBDIRS = . ice-9 srfi oop - include $(top_srcdir)/am/guilec # We're at the root of the module hierarchy. modpath = +# Compile psyntax and boot-9 first, so that we get the speed benefit in +# the rest of the compilation. Also, if there is too much switching back +# and forth between interpreted and compiled code, we end up using more +# of the C stack than the interpreter would have; so avoid that by +# putting these core modules first. + SOURCES = \ + ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ \ @@ -48,8 +51,25 @@ SOURCES = \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ \ + $(ICE_9_SOURCES) \ + $(SRFI_SOURCES) \ + $(OOP_SOURCES) \ + \ $(SCRIPTS_SOURCES) +## test.scm is not currently installed. +EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008 + +# We expect this to never be invoked when there is not already +# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends +# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'. +# In other words, to bootstrap this file, you need to do something like: +# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm +include $(top_srcdir)/am/pre-inst-guile +ice-9/psyntax-pp.scm: ice-9/psyntax.scm + $(preinstguile) -s $(srcdir)/ice-9/compile-psyntax.scm \ + $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm + SCHEME_LANG_SOURCES = \ language/scheme/amatch.scm language/scheme/expand.scm \ language/scheme/compile-ghil.scm language/scheme/spec.scm \ @@ -109,8 +129,118 @@ SCRIPTS_SOURCES = \ scripts/read-rfc822.scm \ scripts/snarf-guile-m4-docs.scm +ICE_9_SOURCES = \ + ice-9/boot-9.scm \ + ice-9/r4rs.scm \ + ice-9/r5rs.scm \ + ice-9/and-let-star.scm \ + ice-9/calling.scm \ + ice-9/common-list.scm \ + ice-9/debug.scm \ + ice-9/debugger.scm \ + ice-9/documentation.scm \ + ice-9/emacs.scm \ + ice-9/expand-support.scm \ + ice-9/expect.scm \ + ice-9/format.scm \ + ice-9/getopt-long.scm \ + ice-9/hcons.scm \ + ice-9/i18n.scm \ + ice-9/lineio.scm \ + ice-9/ls.scm \ + ice-9/mapping.scm \ + ice-9/match.scm \ + ice-9/networking.scm \ + ice-9/null.scm \ + ice-9/occam-channel.scm \ + ice-9/optargs.scm \ + ice-9/poe.scm \ + ice-9/popen.scm \ + ice-9/posix.scm \ + ice-9/q.scm \ + ice-9/rdelim.scm \ + ice-9/receive.scm \ + ice-9/regex.scm \ + ice-9/runq.scm \ + ice-9/rw.scm \ + ice-9/safe-r5rs.scm \ + ice-9/safe.scm \ + ice-9/session.scm \ + ice-9/slib.scm \ + ice-9/stack-catch.scm \ + ice-9/streams.scm \ + ice-9/string-fun.scm \ + ice-9/syncase.scm \ + ice-9/threads.scm \ + ice-9/buffered-input.scm \ + ice-9/time.scm \ + ice-9/history.scm \ + ice-9/channel.scm \ + ice-9/pretty-print.scm \ + ice-9/ftw.scm \ + ice-9/gap-buffer.scm \ + ice-9/weak-vector.scm \ + ice-9/deprecated.scm \ + ice-9/list.scm \ + ice-9/serialize.scm \ + ice-9/gds-server.scm + +SRFI_SOURCES = \ + srfi/srfi-1.scm \ + srfi/srfi-2.scm \ + srfi/srfi-4.scm \ + srfi/srfi-6.scm \ + srfi/srfi-8.scm \ + srfi/srfi-9.scm \ + srfi/srfi-10.scm \ + srfi/srfi-11.scm \ + srfi/srfi-13.scm \ + srfi/srfi-14.scm \ + srfi/srfi-16.scm \ + srfi/srfi-17.scm \ + srfi/srfi-19.scm \ + srfi/srfi-26.scm \ + srfi/srfi-31.scm \ + srfi/srfi-34.scm \ + srfi/srfi-35.scm \ + srfi/srfi-37.scm \ + srfi/srfi-39.scm \ + srfi/srfi-60.scm \ + srfi/srfi-69.scm \ + srfi/srfi-88.scm + EXTRA_DIST += scripts/ChangeLog-2008 EXTRA_DIST += scripts/README +OOP_SOURCES = \ + oop/goops.scm \ + oop/goops/active-slot.scm \ + oop/goops/compile.scm \ + oop/goops/composite-slot.scm \ + oop/goops/describe.scm \ + oop/goops/dispatch.scm \ + oop/goops/internal.scm \ + oop/goops/save.scm \ + oop/goops/stklos.scm \ + oop/goops/util.scm \ + oop/goops/accessors.scm \ + oop/goops/simple.scm + +EXTRA_DIST += oop/ChangeLog-2008 + NOCOMP_SOURCES = \ - system/repl/describe.scm + ice-9/gds-client.scm \ + ice-9/psyntax.scm \ + system/repl/describe.scm \ + ice-9/debugger/command-loop.scm \ + ice-9/debugger/commands.scm \ + ice-9/debugger/state.scm \ + ice-9/debugger/trc.scm \ + ice-9/debugger/utils.scm \ + ice-9/debugging/example-fns.scm \ + ice-9/debugging/ice-9-debugger-extensions.scm \ + ice-9/debugging/steps.scm \ + ice-9/debugging/trace.scm \ + ice-9/debugging/traps.scm \ + ice-9/debugging/trc.scm \ + srfi/srfi-18.scm diff --git a/module/ice-9/Makefile.am b/module/ice-9/Makefile.am deleted file mode 100644 index a93ec817b..000000000 --- a/module/ice-9/Makefile.am +++ /dev/null @@ -1,70 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 1998,1999,2000,2001,2003, 2004, 2006, 2008 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -SUBDIRS = debugger debugging - -# These should be installed and distributed. -modpath = ice-9 -# Compile psyntax and boot-9 first, so that we get the speed benefit in -# the rest of the compilation. Also, if there is too much switching back -# and forth between interpreted and compiled code, we end up using more -# of the C stack than the interpreter would have; so avoid that by -# putting these core modules first. -SOURCES = psyntax-pp.scm expand-support.scm boot-9.scm \ - and-let-star.scm calling.scm common-list.scm \ - debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ - format.scm getopt-long.scm hcons.scm i18n.scm \ - lineio.scm ls.scm mapping.scm match.scm \ - networking.scm null.scm occam-channel.scm optargs.scm poe.scm \ - popen.scm posix.scm q.scm r4rs.scm r5rs.scm \ - rdelim.scm receive.scm regex.scm runq.scm rw.scm \ - safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \ - streams.scm string-fun.scm syncase.scm threads.scm \ - buffered-input.scm time.scm history.scm channel.scm \ - pretty-print.scm ftw.scm gap-buffer.scm \ - weak-vector.scm deprecated.scm list.scm serialize.scm \ - gds-server.scm - -# gds-client is tight with the memoizer, so punt on it until it can be -# made portable. -# -# psyntax.scm needs help. fortunately it's only needed when recompiling -# psyntax-pp.scm. -NOCOMP_SOURCES = gds-client.scm psyntax.scm - -include $(top_srcdir)/am/guilec - -## test.scm is not currently installed. -EXTRA_DIST += test.scm compile-psyntax.scm ChangeLog-2008 - -TAGS_FILES = $(SOURCES) - -# We expect this to never be invoked when there is not already -# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends -# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'. -# In other words, to bootstrap this file, you need to do something like: -# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm -include $(top_srcdir)/am/pre-inst-guile -psyntax-pp.scm: psyntax.scm - $(preinstguile) -s $(srcdir)/compile-psyntax.scm \ - $(srcdir)/psyntax.scm $(srcdir)/psyntax-pp.scm diff --git a/module/ice-9/debugger/Makefile.am b/module/ice-9/debugger/Makefile.am deleted file mode 100644 index 7ef09a025..000000000 --- a/module/ice-9/debugger/Makefile.am +++ /dev/null @@ -1,31 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -# These should be installed and distributed. -ice9_debugger_sources = command-loop.scm commands.scm state.scm trc.scm utils.scm - -subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/ice-9/debugger -subpkgdata_DATA = $(ice9_debugger_sources) -TAGS_FILES = $(subpkgdata_DATA) - -EXTRA_DIST = $(ice9_debugger_sources) diff --git a/module/ice-9/debugging/Makefile.am b/module/ice-9/debugging/Makefile.am deleted file mode 100644 index 44d86d3cf..000000000 --- a/module/ice-9/debugging/Makefile.am +++ /dev/null @@ -1,33 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2006 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -# These should be installed and distributed. -ice9_debugging_sources = example-fns.scm \ - ice-9-debugger-extensions.scm \ - steps.scm trace.scm traps.scm trc.scm - -subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging -subpkgdata_DATA = $(ice9_debugging_sources) -TAGS_FILES = $(subpkgdata_DATA) - -EXTRA_DIST = $(ice9_debugging_sources) diff --git a/module/oop/Makefile.am b/module/oop/Makefile.am deleted file mode 100644 index 83c342abc..000000000 --- a/module/oop/Makefile.am +++ /dev/null @@ -1,30 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -SUBDIRS = goops - -modpath = oop -SOURCES = goops.scm -include $(top_srcdir)/am/guilec - -EXTRA_DIST += ChangeLog-2008 diff --git a/module/oop/goops/Makefile.am b/module/oop/goops/Makefile.am deleted file mode 100644 index 0c90ac49f..000000000 --- a/module/oop/goops/Makefile.am +++ /dev/null @@ -1,30 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -modpath = oop/goops -SOURCES = \ - active-slot.scm compile.scm composite-slot.scm describe.scm \ - dispatch.scm internal.scm save.scm stklos.scm util.scm \ - accessors.scm simple.scm - -include $(top_srcdir)/am/guilec From 34ad4f83ca4310e84226d6bd06feb03006c736cc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 19:59:42 +0200 Subject: [PATCH 071/375] handle pre-module macro procedures correctly * module/ice-9/psyntax.scm (chi-macro): It's possible for a macro procedure to have no module, if the procedure was made before modules were booted. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 9 ++++++++- 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 901574ca2..743197fbd 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (cons (quote hygiene) (module-name (procedure-module p1510)))))))) ((vector? x1517) (let ((n1522 (vector-length x1517))) (let ((v1523 (make-vector n1522))) (let doloop1524 ((i1525 0)) (if (fx=1100 i1525 n1522) v1523 (begin (vector-set! v1523 i1525 (rebuild-macro-output1516 (vector-ref x1517 i1525) m1518)) (doloop1524 (fx+1098 i1525 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1526 e1527 r1528 w1529 s1530 mod1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (e01534 e11535) (build-annotated1108 s1530 (cons x1526 (map (lambda (e1536) (chi1167 e1536 r1528 w1529 mod1531)) e11535)))) tmp1533) (syntax-error tmp1532))) (syntax-dispatch tmp1532 (quote (any . each-any))))) e1527))) (chi-expr1168 (lambda (type1538 value1539 e1540 r1541 w1542 s1543 mod1544) (let ((t1545 type1538)) (if (memv t1545 (quote (lexical))) (build-annotated1108 s1543 value1539) (if (memv t1545 (quote (core external-macro))) (value1539 e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (module-ref))) (call-with-values (lambda () (value1539 e1540)) (lambda (id1546 mod1547) (build-annotated1108 s1543 (if mod1547 (make-module-ref (cdr mod1547) id1546 (car mod1547)) (make-module-ref mod1547 id1546 (quote bare)))))) (if (memv t1545 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) value1539) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (global-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1540)) (if (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) (make-module-ref (cdr (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544)) value1539 (car (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544))) (make-module-ref (if (syntax-object?1115 (car e1540)) (syntax-object-module1118 (car e1540)) mod1544) value1539 (quote bare)))) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (constant))) (build-data1109 s1543 (strip1178 (source-wrap1160 e1540 w1542 s1543 mod1544) (quote (())))) (if (memv t1545 (quote (global))) (build-annotated1108 s1543 (if mod1544 (make-module-ref (cdr mod1544) value1539 (car mod1544)) (make-module-ref mod1544 value1539 (quote bare)))) (if (memv t1545 (quote (call))) (chi-application1169 (chi1167 (car e1540) r1541 w1542 mod1544) e1540 r1541 w1542 s1543 mod1544) (if (memv t1545 (quote (begin-form))) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (_1550 e11551 e21552) (chi-sequence1161 (cons e11551 e21552) r1541 w1542 s1543 mod1544)) tmp1549) (syntax-error tmp1548))) (syntax-dispatch tmp1548 (quote (any any . each-any))))) e1540) (if (memv t1545 (quote (local-syntax-form))) (chi-local-syntax1173 value1539 e1540 r1541 w1542 s1543 mod1544 chi-sequence1161) (if (memv t1545 (quote (eval-when-form))) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 x1557 e11558 e21559) (let ((when-list1560 (chi-when-list1164 e1540 x1557 w1542))) (if (memq (quote eval) when-list1560) (chi-sequence1161 (cons e11558 e21559) r1541 w1542 s1543 mod1544) (chi-void1175)))) tmp1555) (syntax-error tmp1554))) (syntax-dispatch tmp1554 (quote (any each-any any . each-any))))) e1540) (if (memv t1545 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1539 w1542 mod1544) "invalid context for definition of") (if (memv t1545 (quote (syntax))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to pattern variable outside syntax form") (if (memv t1545 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1540 w1542 s1543 mod1544))))))))))))))))))) (chi1167 (lambda (e1563 r1564 w1565 mod1566) (call-with-values (lambda () (syntax-type1165 e1563 r1564 w1565 #f #f mod1566)) (lambda (type1567 value1568 e1569 w1570 s1571 mod1572) (chi-expr1168 type1567 value1568 e1569 r1564 w1570 s1571 mod1572))))) (chi-top1166 (lambda (e1573 r1574 w1575 m1576 esew1577 mod1578) (call-with-values (lambda () (syntax-type1165 e1573 r1574 w1575 #f #f mod1578)) (lambda (type1586 value1587 e1588 w1589 s1590 mod1591) (let ((t1592 type1586)) (if (memv t1592 (quote (begin-form))) ((lambda (tmp1593) ((lambda (tmp1594) (if tmp1594 (apply (lambda (_1595) (chi-void1175)) tmp1594) ((lambda (tmp1596) (if tmp1596 (apply (lambda (_1597 e11598 e21599) (chi-top-sequence1162 (cons e11598 e21599) r1574 w1589 s1590 m1576 esew1577 mod1591)) tmp1596) (syntax-error tmp1593))) (syntax-dispatch tmp1593 (quote (any any . each-any)))))) (syntax-dispatch tmp1593 (quote (any))))) e1588) (if (memv t1592 (quote (local-syntax-form))) (chi-local-syntax1173 value1587 e1588 r1574 w1589 s1590 mod1591 (lambda (body1601 r1602 w1603 s1604 mod1605) (chi-top-sequence1162 body1601 r1602 w1603 s1604 m1576 esew1577 mod1605))) (if (memv t1592 (quote (eval-when-form))) ((lambda (tmp1606) ((lambda (tmp1607) (if tmp1607 (apply (lambda (_1608 x1609 e11610 e21611) (let ((when-list1612 (chi-when-list1164 e1588 x1609 w1589)) (body1613 (cons e11610 e21611))) (cond ((eq? m1576 (quote e)) (if (memq (quote eval) when-list1612) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) (chi-void1175))) ((memq (quote load) when-list1612) (if (or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c&e) (quote (compile load)) mod1591) (if (memq m1576 (quote (c c&e))) (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote c) (quote (load)) mod1591) (chi-void1175)))) ((or (memq (quote compile) when-list1612) (and (eq? m1576 (quote c&e)) (memq (quote eval) when-list1612))) (top-level-eval-hook1102 (chi-top-sequence1162 body1613 r1574 w1589 s1590 (quote e) (quote (eval)) mod1591) mod1591) (chi-void1175)) (else (chi-void1175))))) tmp1607) (syntax-error tmp1606))) (syntax-dispatch tmp1606 (quote (any each-any any . each-any))))) e1588) (if (memv t1592 (quote (define-syntax-form))) (let ((n1616 (id-var-name1153 value1587 w1589)) (r1617 (macros-only-env1127 r1574))) (let ((t1618 m1576)) (if (memv t1618 (quote (c))) (if (memq (quote compile) esew1577) (let ((e1619 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1619 mod1591) (if (memq (quote load) esew1577) e1619 (chi-void1175)))) (if (memq (quote load) esew1577) (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) (chi-void1175))) (if (memv t1618 (quote (c&e))) (let ((e1620 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)))) (begin (top-level-eval-hook1102 e1620 mod1591) e1620)) (begin (if (memq (quote eval) esew1577) (top-level-eval-hook1102 (chi-install-global1163 n1616 (chi1167 e1588 r1617 w1589 mod1591)) mod1591)) (chi-void1175)))))) (if (memv t1592 (quote (define-form))) (let ((n1621 (id-var-name1153 value1587 w1589))) (let ((type1622 (binding-type1123 (lookup1128 n1621 r1574 mod1591)))) (let ((t1623 type1622)) (if (memv t1623 (quote (global))) (let ((x1624 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1624 mod1591)) x1624)) (if (memv t1623 (quote (displaced-lexical))) (syntax-error (wrap1159 value1587 w1589 mod1591) "identifier out of context") (if (memv t1623 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1621) (let ((x1625 (build-annotated1108 s1590 (list (quote define) n1621 (chi1167 e1588 r1574 w1589 mod1591))))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1625 mod1591)) x1625))) (syntax-error (wrap1159 value1587 w1589 mod1591) "cannot define keyword at top level"))))))) (let ((x1626 (chi-expr1168 type1586 value1587 e1588 r1574 w1589 s1590 mod1591))) (begin (if (eq? m1576 (quote c&e)) (top-level-eval-hook1102 x1626 mod1591)) x1626)))))))))))) (syntax-type1165 (lambda (e1627 r1628 w1629 s1630 rib1631 mod1632) (cond ((symbol? e1627) (let ((n1633 (id-var-name1153 e1627 w1629))) (let ((b1634 (lookup1128 n1633 r1628 mod1632))) (let ((type1635 (binding-type1123 b1634))) (let ((t1636 type1635)) (if (memv t1636 (quote (lexical))) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (global))) (values type1635 n1633 e1627 w1629 s1630 mod1632) (if (memv t1636 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1634) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (values type1635 (binding-value1124 b1634) e1627 w1629 s1630 mod1632))))))))) ((pair? e1627) (let ((first1637 (car e1627))) (if (id?1131 first1637) (let ((n1638 (id-var-name1153 first1637 w1629))) (let ((b1639 (lookup1128 n1638 r1628 (or (and (syntax-object?1115 first1637) (syntax-object-module1118 first1637)) mod1632)))) (let ((type1640 (binding-type1123 b1639))) (let ((t1641 type1640)) (if (memv t1641 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (global))) (values (quote global-call) n1638 e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1639) e1627 r1628 w1629 rib1631 mod1632) r1628 (quote (())) s1630 rib1631 mod1632) (if (memv t1641 (quote (core external-macro module-ref))) (values type1640 (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1639) e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (begin))) (values (quote begin-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (eval-when))) (values (quote eval-when-form) #f e1627 w1629 s1630 mod1632) (if (memv t1641 (quote (define))) ((lambda (tmp1642) ((lambda (tmp1643) (if (if tmp1643 (apply (lambda (_1644 name1645 val1646) (id?1131 name1645)) tmp1643) #f) (apply (lambda (_1647 name1648 val1649) (values (quote define-form) name1648 val1649 w1629 s1630 mod1632)) tmp1643) ((lambda (tmp1650) (if (if tmp1650 (apply (lambda (_1651 name1652 args1653 e11654 e21655) (and (id?1131 name1652) (valid-bound-ids?1156 (lambda-var-list1180 args1653)))) tmp1650) #f) (apply (lambda (_1656 name1657 args1658 e11659 e21660) (values (quote define-form) (wrap1159 name1657 w1629 mod1632) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1159 (cons args1658 (cons e11659 e21660)) w1629 mod1632)) (quote (())) s1630 mod1632)) tmp1650) ((lambda (tmp1662) (if (if tmp1662 (apply (lambda (_1663 name1664) (id?1131 name1664)) tmp1662) #f) (apply (lambda (_1665 name1666) (values (quote define-form) (wrap1159 name1666 w1629 mod1632) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1630 mod1632)) tmp1662) (syntax-error tmp1642))) (syntax-dispatch tmp1642 (quote (any any)))))) (syntax-dispatch tmp1642 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1642 (quote (any any any))))) e1627) (if (memv t1641 (quote (define-syntax))) ((lambda (tmp1667) ((lambda (tmp1668) (if (if tmp1668 (apply (lambda (_1669 name1670 val1671) (id?1131 name1670)) tmp1668) #f) (apply (lambda (_1672 name1673 val1674) (values (quote define-syntax-form) name1673 val1674 w1629 s1630 mod1632)) tmp1668) (syntax-error tmp1667))) (syntax-dispatch tmp1667 (quote (any any any))))) e1627) (values (quote call) #f e1627 w1629 s1630 mod1632)))))))))))))) (values (quote call) #f e1627 w1629 s1630 mod1632)))) ((syntax-object?1115 e1627) (syntax-type1165 (syntax-object-expression1116 e1627) r1628 (join-wraps1150 w1629 (syntax-object-wrap1117 e1627)) #f rib1631 (or (syntax-object-module1118 e1627) mod1632))) ((annotation? e1627) (syntax-type1165 (annotation-expression e1627) r1628 w1629 (annotation-source e1627) rib1631 mod1632)) ((self-evaluating? e1627) (values (quote constant) #f e1627 w1629 s1630 mod1632)) (else (values (quote other) #f e1627 w1629 s1630 mod1632))))) (chi-when-list1164 (lambda (e1675 when-list1676 w1677) (let f1678 ((when-list1679 when-list1676) (situations1680 (quote ()))) (if (null? when-list1679) situations1680 (f1678 (cdr when-list1679) (cons (let ((x1681 (car when-list1679))) (cond ((free-id=?1154 x1681 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1154 x1681 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1154 x1681 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1159 x1681 w1677 #f) "invalid eval-when situation")))) situations1680)))))) (chi-install-global1163 (lambda (name1682 e1683) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1682) e1683)))) (chi-top-sequence1162 (lambda (body1684 r1685 w1686 s1687 m1688 esew1689 mod1690) (build-sequence1110 s1687 (let dobody1691 ((body1692 body1684) (r1693 r1685) (w1694 w1686) (m1695 m1688) (esew1696 esew1689) (mod1697 mod1690)) (if (null? body1692) (quote ()) (let ((first1698 (chi-top1166 (car body1692) r1693 w1694 m1695 esew1696 mod1697))) (cons first1698 (dobody1691 (cdr body1692) r1693 w1694 m1695 esew1696 mod1697)))))))) (chi-sequence1161 (lambda (body1699 r1700 w1701 s1702 mod1703) (build-sequence1110 s1702 (let dobody1704 ((body1705 body1699) (r1706 r1700) (w1707 w1701) (mod1708 mod1703)) (if (null? body1705) (quote ()) (let ((first1709 (chi1167 (car body1705) r1706 w1707 mod1708))) (cons first1709 (dobody1704 (cdr body1705) r1706 w1707 mod1708)))))))) (source-wrap1160 (lambda (x1710 w1711 s1712 defmod1713) (wrap1159 (if s1712 (make-annotation x1710 s1712 #f) x1710) w1711 defmod1713))) (wrap1159 (lambda (x1714 w1715 defmod1716) (cond ((and (null? (wrap-marks1134 w1715)) (null? (wrap-subst1135 w1715))) x1714) ((syntax-object?1115 x1714) (make-syntax-object1114 (syntax-object-expression1116 x1714) (join-wraps1150 w1715 (syntax-object-wrap1117 x1714)) (syntax-object-module1118 x1714))) ((null? x1714) x1714) (else (make-syntax-object1114 x1714 w1715 defmod1716))))) (bound-id-member?1158 (lambda (x1717 list1718) (and (not (null? list1718)) (or (bound-id=?1155 x1717 (car list1718)) (bound-id-member?1158 x1717 (cdr list1718)))))) (distinct-bound-ids?1157 (lambda (ids1719) (let distinct?1720 ((ids1721 ids1719)) (or (null? ids1721) (and (not (bound-id-member?1158 (car ids1721) (cdr ids1721))) (distinct?1720 (cdr ids1721))))))) (valid-bound-ids?1156 (lambda (ids1722) (and (let all-ids?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (id?1131 (car ids1724)) (all-ids?1723 (cdr ids1724))))) (distinct-bound-ids?1157 ids1722)))) (bound-id=?1155 (lambda (i1725 j1726) (if (and (syntax-object?1115 i1725) (syntax-object?1115 j1726)) (and (eq? (let ((e1727 (syntax-object-expression1116 i1725))) (if (annotation? e1727) (annotation-expression e1727) e1727)) (let ((e1728 (syntax-object-expression1116 j1726))) (if (annotation? e1728) (annotation-expression e1728) e1728))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1725)) (wrap-marks1134 (syntax-object-wrap1117 j1726)))) (eq? (let ((e1729 i1725)) (if (annotation? e1729) (annotation-expression e1729) e1729)) (let ((e1730 j1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)))))) (free-id=?1154 (lambda (i1731 j1732) (and (eq? (let ((x1733 i1731)) (let ((e1734 (if (syntax-object?1115 x1733) (syntax-object-expression1116 x1733) x1733))) (if (annotation? e1734) (annotation-expression e1734) e1734))) (let ((x1735 j1732)) (let ((e1736 (if (syntax-object?1115 x1735) (syntax-object-expression1116 x1735) x1735))) (if (annotation? e1736) (annotation-expression e1736) e1736)))) (eq? (id-var-name1153 i1731 (quote (()))) (id-var-name1153 j1732 (quote (()))))))) (id-var-name1153 (lambda (id1737 w1738) (letrec ((search-vector-rib1741 (lambda (sym1747 subst1748 marks1749 symnames1750 ribcage1751) (let ((n1752 (vector-length symnames1750))) (let f1753 ((i1754 0)) (cond ((fx=1100 i1754 n1752) (search1739 sym1747 (cdr subst1748) marks1749)) ((and (eq? (vector-ref symnames1750 i1754) sym1747) (same-marks?1152 marks1749 (vector-ref (ribcage-marks1141 ribcage1751) i1754))) (values (vector-ref (ribcage-labels1142 ribcage1751) i1754) marks1749)) (else (f1753 (fx+1098 i1754 1)))))))) (search-list-rib1740 (lambda (sym1755 subst1756 marks1757 symnames1758 ribcage1759) (let f1760 ((symnames1761 symnames1758) (i1762 0)) (cond ((null? symnames1761) (search1739 sym1755 (cdr subst1756) marks1757)) ((and (eq? (car symnames1761) sym1755) (same-marks?1152 marks1757 (list-ref (ribcage-marks1141 ribcage1759) i1762))) (values (list-ref (ribcage-labels1142 ribcage1759) i1762) marks1757)) (else (f1760 (cdr symnames1761) (fx+1098 i1762 1))))))) (search1739 (lambda (sym1763 subst1764 marks1765) (if (null? subst1764) (values #f marks1765) (let ((fst1766 (car subst1764))) (if (eq? fst1766 (quote shift)) (search1739 sym1763 (cdr subst1764) (cdr marks1765)) (let ((symnames1767 (ribcage-symnames1140 fst1766))) (if (vector? symnames1767) (search-vector-rib1741 sym1763 subst1764 marks1765 symnames1767 fst1766) (search-list-rib1740 sym1763 subst1764 marks1765 symnames1767 fst1766))))))))) (cond ((symbol? id1737) (or (call-with-values (lambda () (search1739 id1737 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1769 . ignore1768) x1769)) id1737)) ((syntax-object?1115 id1737) (let ((id1770 (let ((e1772 (syntax-object-expression1116 id1737))) (if (annotation? e1772) (annotation-expression e1772) e1772))) (w11771 (syntax-object-wrap1117 id1737))) (let ((marks1773 (join-marks1151 (wrap-marks1134 w1738) (wrap-marks1134 w11771)))) (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w1738) marks1773)) (lambda (new-id1774 marks1775) (or new-id1774 (call-with-values (lambda () (search1739 id1770 (wrap-subst1135 w11771) marks1775)) (lambda (x1777 . ignore1776) x1777)) id1770)))))) ((annotation? id1737) (let ((id1778 (let ((e1779 id1737)) (if (annotation? e1779) (annotation-expression e1779) e1779)))) (or (call-with-values (lambda () (search1739 id1778 (wrap-subst1135 w1738) (wrap-marks1134 w1738))) (lambda (x1781 . ignore1780) x1781)) id1778))) (else (error-hook1104 (quote id-var-name) "invalid id" id1737)))))) (same-marks?1152 (lambda (x1782 y1783) (or (eq? x1782 y1783) (and (not (null? x1782)) (not (null? y1783)) (eq? (car x1782) (car y1783)) (same-marks?1152 (cdr x1782) (cdr y1783)))))) (join-marks1151 (lambda (m11784 m21785) (smart-append1149 m11784 m21785))) (join-wraps1150 (lambda (w11786 w21787) (let ((m11788 (wrap-marks1134 w11786)) (s11789 (wrap-subst1135 w11786))) (if (null? m11788) (if (null? s11789) w21787 (make-wrap1133 (wrap-marks1134 w21787) (smart-append1149 s11789 (wrap-subst1135 w21787)))) (make-wrap1133 (smart-append1149 m11788 (wrap-marks1134 w21787)) (smart-append1149 s11789 (wrap-subst1135 w21787))))))) (smart-append1149 (lambda (m11790 m21791) (if (null? m21791) m11790 (append m11790 m21791)))) (make-binding-wrap1148 (lambda (ids1792 labels1793 w1794) (if (null? ids1792) w1794 (make-wrap1133 (wrap-marks1134 w1794) (cons (let ((labelvec1795 (list->vector labels1793))) (let ((n1796 (vector-length labelvec1795))) (let ((symnamevec1797 (make-vector n1796)) (marksvec1798 (make-vector n1796))) (begin (let f1799 ((ids1800 ids1792) (i1801 0)) (if (not (null? ids1800)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1800) w1794)) (lambda (symname1802 marks1803) (begin (vector-set! symnamevec1797 i1801 symname1802) (vector-set! marksvec1798 i1801 marks1803) (f1799 (cdr ids1800) (fx+1098 i1801 1))))))) (make-ribcage1138 symnamevec1797 marksvec1798 labelvec1795))))) (wrap-subst1135 w1794)))))) (extend-ribcage!1147 (lambda (ribcage1804 id1805 label1806) (begin (set-ribcage-symnames!1143 ribcage1804 (cons (let ((e1807 (syntax-object-expression1116 id1805))) (if (annotation? e1807) (annotation-expression e1807) e1807)) (ribcage-symnames1140 ribcage1804))) (set-ribcage-marks!1144 ribcage1804 (cons (wrap-marks1134 (syntax-object-wrap1117 id1805)) (ribcage-marks1141 ribcage1804))) (set-ribcage-labels!1145 ribcage1804 (cons label1806 (ribcage-labels1142 ribcage1804)))))) (anti-mark1146 (lambda (w1808) (make-wrap1133 (cons #f (wrap-marks1134 w1808)) (cons (quote shift) (wrap-subst1135 w1808))))) (set-ribcage-labels!1145 (lambda (x1809 update1810) (vector-set! x1809 3 update1810))) (set-ribcage-marks!1144 (lambda (x1811 update1812) (vector-set! x1811 2 update1812))) (set-ribcage-symnames!1143 (lambda (x1813 update1814) (vector-set! x1813 1 update1814))) (ribcage-labels1142 (lambda (x1815) (vector-ref x1815 3))) (ribcage-marks1141 (lambda (x1816) (vector-ref x1816 2))) (ribcage-symnames1140 (lambda (x1817) (vector-ref x1817 1))) (ribcage?1139 (lambda (x1818) (and (vector? x1818) (= (vector-length x1818) 4) (eq? (vector-ref x1818 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1819 marks1820 labels1821) (vector (quote ribcage) symnames1819 marks1820 labels1821))) (gen-labels1137 (lambda (ls1822) (if (null? ls1822) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1822)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1823 w1824) (if (syntax-object?1115 x1823) (values (let ((e1825 (syntax-object-expression1116 x1823))) (if (annotation? e1825) (annotation-expression e1825) e1825)) (join-marks1151 (wrap-marks1134 w1824) (wrap-marks1134 (syntax-object-wrap1117 x1823)))) (values (let ((e1826 x1823)) (if (annotation? e1826) (annotation-expression e1826) e1826)) (wrap-marks1134 w1824))))) (id?1131 (lambda (x1827) (cond ((symbol? x1827) #t) ((syntax-object?1115 x1827) (symbol? (let ((e1828 (syntax-object-expression1116 x1827))) (if (annotation? e1828) (annotation-expression e1828) e1828)))) ((annotation? x1827) (symbol? (annotation-expression x1827))) (else #f)))) (nonsymbol-id?1130 (lambda (x1829) (and (syntax-object?1115 x1829) (symbol? (let ((e1830 (syntax-object-expression1116 x1829))) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (global-extend1129 (lambda (type1831 sym1832 val1833) (put-global-definition-hook1105 sym1832 (cons type1831 val1833)))) (lookup1128 (lambda (x1834 r1835 mod1836) (cond ((assq x1834 r1835) => cdr) ((symbol? x1834) (or (get-global-definition-hook1107 x1834 mod1836) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1837) (if (null? r1837) (quote ()) (let ((a1838 (car r1837))) (if (eq? (cadr a1838) (quote macro)) (cons a1838 (macros-only-env1127 (cdr r1837))) (macros-only-env1127 (cdr r1837))))))) (extend-var-env1126 (lambda (labels1839 vars1840 r1841) (if (null? labels1839) r1841 (extend-var-env1126 (cdr labels1839) (cdr vars1840) (cons (cons (car labels1839) (cons (quote lexical) (car vars1840))) r1841))))) (extend-env1125 (lambda (labels1842 bindings1843 r1844) (if (null? labels1842) r1844 (extend-env1125 (cdr labels1842) (cdr bindings1843) (cons (cons (car labels1842) (car bindings1843)) r1844))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1845) (cond ((annotation? x1845) (annotation-source x1845)) ((syntax-object?1115 x1845) (source-annotation1122 (syntax-object-expression1116 x1845))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1846 update1847) (vector-set! x1846 3 update1847))) (set-syntax-object-wrap!1120 (lambda (x1848 update1849) (vector-set! x1848 2 update1849))) (set-syntax-object-expression!1119 (lambda (x1850 update1851) (vector-set! x1850 1 update1851))) (syntax-object-module1118 (lambda (x1852) (vector-ref x1852 3))) (syntax-object-wrap1117 (lambda (x1853) (vector-ref x1853 2))) (syntax-object-expression1116 (lambda (x1854) (vector-ref x1854 1))) (syntax-object?1115 (lambda (x1855) (and (vector? x1855) (= (vector-length x1855) 4) (eq? (vector-ref x1855 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1856 wrap1857 module1858) (vector (quote syntax-object) expression1856 wrap1857 module1858))) (build-letrec1113 (lambda (src1859 vars1860 val-exps1861 body-exp1862) (if (null? vars1860) (build-annotated1108 src1859 body-exp1862) (build-annotated1108 src1859 (list (quote letrec) (map list vars1860 val-exps1861) body-exp1862))))) (build-named-let1112 (lambda (src1863 vars1864 val-exps1865 body-exp1866) (if (null? vars1864) (build-annotated1108 src1863 body-exp1866) (build-annotated1108 src1863 (list (quote let) (car vars1864) (map list (cdr vars1864) val-exps1865) body-exp1866))))) (build-let1111 (lambda (src1867 vars1868 val-exps1869 body-exp1870) (if (null? vars1868) (build-annotated1108 src1867 body-exp1870) (build-annotated1108 src1867 (list (quote let) (map list vars1868 val-exps1869) body-exp1870))))) (build-sequence1110 (lambda (src1871 exps1872) (if (null? (cdr exps1872)) (build-annotated1108 src1871 (car exps1872)) (build-annotated1108 src1871 (cons (quote begin) exps1872))))) (build-data1109 (lambda (src1873 exp1874) (if (and (self-evaluating? exp1874) (not (vector? exp1874))) (build-annotated1108 src1873 exp1874) (build-annotated1108 src1873 (list (quote quote) exp1874))))) (build-annotated1108 (lambda (src1875 exp1876) (if (and src1875 (not (annotation? exp1876))) (make-annotation exp1876 src1875 #t) exp1876))) (get-global-definition-hook1107 (lambda (symbol1877 module1878) (let ((module1879 (if module1878 (resolve-module (cdr module1878)) (let ((mod1880 (current-module))) (begin (if mod1880 (warn "wha" symbol1877)) mod1880))))) (let ((v1881 (module-variable module1879 symbol1877))) (and v1881 (object-property v1881 (quote *sc-expander*))))))) (remove-global-definition-hook1106 (lambda (symbol1882) (let ((module1883 (current-module))) (let ((v1884 (module-local-variable module1883 symbol1882))) (if v1884 (let ((p1885 (assq (quote *sc-expander*) (object-properties v1884)))) (set-object-properties! v1884 (delq p1885 (object-properties v1884))))))))) (put-global-definition-hook1105 (lambda (symbol1886 binding1887) (let ((module1888 (current-module))) (let ((v1889 (or (module-variable module1888 symbol1886) (let ((v1890 (make-variable (gensym)))) (begin (module-add! module1888 symbol1886 v1890) v1890))))) (begin (if (not (variable-bound? v1889)) (variable-set! v1889 (gensym))) (set-object-property! v1889 (quote *sc-expander*) binding1887)))))) (error-hook1104 (lambda (who1891 why1892 what1893) (error who1891 "~a ~s" why1892 what1893))) (local-eval-hook1103 (lambda (x1894 mod1895) (primitive-eval (list noexpand1097 x1894)))) (top-level-eval-hook1102 (lambda (x1896 mod1897) (primitive-eval (list noexpand1097 x1896)))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1898 r1899 w1900 s1901 mod1902) ((lambda (tmp1903) ((lambda (tmp1904) (if (if tmp1904 (apply (lambda (_1905 var1906 val1907 e11908 e21909) (valid-bound-ids?1156 var1906)) tmp1904) #f) (apply (lambda (_1911 var1912 val1913 e11914 e21915) (let ((names1916 (map (lambda (x1917) (id-var-name1153 x1917 w1900)) var1912))) (begin (for-each (lambda (id1919 n1920) (let ((t1921 (binding-type1123 (lookup1128 n1920 r1899 mod1902)))) (if (memv t1921 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1919 w1900 s1901 mod1902) "identifier out of context")))) var1912 names1916) (chi-body1171 (cons e11914 e21915) (source-wrap1160 e1898 w1900 s1901 mod1902) (extend-env1125 names1916 (let ((trans-r1924 (macros-only-env1127 r1899))) (map (lambda (x1925) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1925 trans-r1924 w1900 mod1902) mod1902))) val1913)) r1899) w1900 mod1902)))) tmp1904) ((lambda (_1927) (syntax-error (source-wrap1160 e1898 w1900 s1901 mod1902))) tmp1903))) (syntax-dispatch tmp1903 (quote (any #(each (any any)) any . each-any))))) e1898))) (global-extend1129 (quote core) (quote quote) (lambda (e1928 r1929 w1930 s1931 mod1932) ((lambda (tmp1933) ((lambda (tmp1934) (if tmp1934 (apply (lambda (_1935 e1936) (build-data1109 s1931 (strip1178 e1936 w1930))) tmp1934) ((lambda (_1937) (syntax-error (source-wrap1160 e1928 w1930 s1931 mod1932))) tmp1933))) (syntax-dispatch tmp1933 (quote (any any))))) e1928))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1945 (lambda (x1946) (let ((t1947 (car x1946))) (if (memv t1947 (quote (ref))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (primitive))) (build-annotated1108 #f (cadr x1946)) (if (memv t1947 (quote (quote))) (build-data1109 #f (cadr x1946)) (if (memv t1947 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1946) (regen1945 (caddr x1946)))) (if (memv t1947 (quote (map))) (let ((ls1948 (map regen1945 (cdr x1946)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1948) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1948))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1946)) (map regen1945 (cdr x1946)))))))))))) (gen-vector1944 (lambda (x1949) (cond ((eq? (car x1949) (quote list)) (cons (quote vector) (cdr x1949))) ((eq? (car x1949) (quote quote)) (list (quote quote) (list->vector (cadr x1949)))) (else (list (quote list->vector) x1949))))) (gen-append1943 (lambda (x1950 y1951) (if (equal? y1951 (quote (quote ()))) x1950 (list (quote append) x1950 y1951)))) (gen-cons1942 (lambda (x1952 y1953) (let ((t1954 (car y1953))) (if (memv t1954 (quote (quote))) (if (eq? (car x1952) (quote quote)) (list (quote quote) (cons (cadr x1952) (cadr y1953))) (if (eq? (cadr y1953) (quote ())) (list (quote list) x1952) (list (quote cons) x1952 y1953))) (if (memv t1954 (quote (list))) (cons (quote list) (cons x1952 (cdr y1953))) (list (quote cons) x1952 y1953)))))) (gen-map1941 (lambda (e1955 map-env1956) (let ((formals1957 (map cdr map-env1956)) (actuals1958 (map (lambda (x1959) (list (quote ref) (car x1959))) map-env1956))) (cond ((eq? (car e1955) (quote ref)) (car actuals1958)) ((andmap (lambda (x1960) (and (eq? (car x1960) (quote ref)) (memq (cadr x1960) formals1957))) (cdr e1955)) (cons (quote map) (cons (list (quote primitive) (car e1955)) (map (let ((r1961 (map cons formals1957 actuals1958))) (lambda (x1962) (cdr (assq (cadr x1962) r1961)))) (cdr e1955))))) (else (cons (quote map) (cons (list (quote lambda) formals1957 e1955) actuals1958))))))) (gen-mappend1940 (lambda (e1963 map-env1964) (list (quote apply) (quote (primitive append)) (gen-map1941 e1963 map-env1964)))) (gen-ref1939 (lambda (src1965 var1966 level1967 maps1968) (if (fx=1100 level1967 0) (values var1966 maps1968) (if (null? maps1968) (syntax-error src1965 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1939 src1965 var1966 (fx-1099 level1967 1) (cdr maps1968))) (lambda (outer-var1969 outer-maps1970) (let ((b1971 (assq outer-var1969 (car maps1968)))) (if b1971 (values (cdr b1971) maps1968) (let ((inner-var1972 (gen-var1179 (quote tmp)))) (values inner-var1972 (cons (cons (cons outer-var1969 inner-var1972) (car maps1968)) outer-maps1970))))))))))) (gen-syntax1938 (lambda (src1973 e1974 r1975 maps1976 ellipsis?1977 mod1978) (if (id?1131 e1974) (let ((label1979 (id-var-name1153 e1974 (quote (()))))) (let ((b1980 (lookup1128 label1979 r1975 mod1978))) (if (eq? (binding-type1123 b1980) (quote syntax)) (call-with-values (lambda () (let ((var.lev1981 (binding-value1124 b1980))) (gen-ref1939 src1973 (car var.lev1981) (cdr var.lev1981) maps1976))) (lambda (var1982 maps1983) (values (list (quote ref) var1982) maps1983))) (if (ellipsis?1977 e1974) (syntax-error src1973 "misplaced ellipsis in syntax form") (values (list (quote quote) e1974) maps1976))))) ((lambda (tmp1984) ((lambda (tmp1985) (if (if tmp1985 (apply (lambda (dots1986 e1987) (ellipsis?1977 dots1986)) tmp1985) #f) (apply (lambda (dots1988 e1989) (gen-syntax1938 src1973 e1989 r1975 maps1976 (lambda (x1990) #f) mod1978)) tmp1985) ((lambda (tmp1991) (if (if tmp1991 (apply (lambda (x1992 dots1993 y1994) (ellipsis?1977 dots1993)) tmp1991) #f) (apply (lambda (x1995 dots1996 y1997) (let f1998 ((y1999 y1997) (k2000 (lambda (maps2001) (call-with-values (lambda () (gen-syntax1938 src1973 x1995 r1975 (cons (quote ()) maps2001) ellipsis?1977 mod1978)) (lambda (x2002 maps2003) (if (null? (car maps2003)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-map1941 x2002 (car maps2003)) (cdr maps2003)))))))) ((lambda (tmp2004) ((lambda (tmp2005) (if (if tmp2005 (apply (lambda (dots2006 y2007) (ellipsis?1977 dots2006)) tmp2005) #f) (apply (lambda (dots2008 y2009) (f1998 y2009 (lambda (maps2010) (call-with-values (lambda () (k2000 (cons (quote ()) maps2010))) (lambda (x2011 maps2012) (if (null? (car maps2012)) (syntax-error src1973 "extra ellipsis in syntax form") (values (gen-mappend1940 x2011 (car maps2012)) (cdr maps2012)))))))) tmp2005) ((lambda (_2013) (call-with-values (lambda () (gen-syntax1938 src1973 y1999 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (y2014 maps2015) (call-with-values (lambda () (k2000 maps2015)) (lambda (x2016 maps2017) (values (gen-append1943 x2016 y2014) maps2017)))))) tmp2004))) (syntax-dispatch tmp2004 (quote (any . any))))) y1999))) tmp1991) ((lambda (tmp2018) (if tmp2018 (apply (lambda (x2019 y2020) (call-with-values (lambda () (gen-syntax1938 src1973 x2019 r1975 maps1976 ellipsis?1977 mod1978)) (lambda (x2021 maps2022) (call-with-values (lambda () (gen-syntax1938 src1973 y2020 r1975 maps2022 ellipsis?1977 mod1978)) (lambda (y2023 maps2024) (values (gen-cons1942 x2021 y2023) maps2024)))))) tmp2018) ((lambda (tmp2025) (if tmp2025 (apply (lambda (e12026 e22027) (call-with-values (lambda () (gen-syntax1938 src1973 (cons e12026 e22027) r1975 maps1976 ellipsis?1977 mod1978)) (lambda (e2029 maps2030) (values (gen-vector1944 e2029) maps2030)))) tmp2025) ((lambda (_2031) (values (list (quote quote) e1974) maps1976)) tmp1984))) (syntax-dispatch tmp1984 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1984 (quote (any . any)))))) (syntax-dispatch tmp1984 (quote (any any . any)))))) (syntax-dispatch tmp1984 (quote (any any))))) e1974))))) (lambda (e2032 r2033 w2034 s2035 mod2036) (let ((e2037 (source-wrap1160 e2032 w2034 s2035 mod2036))) ((lambda (tmp2038) ((lambda (tmp2039) (if tmp2039 (apply (lambda (_2040 x2041) (call-with-values (lambda () (gen-syntax1938 e2037 x2041 r2033 (quote ()) ellipsis?1176 mod2036)) (lambda (e2042 maps2043) (regen1945 e2042)))) tmp2039) ((lambda (_2044) (syntax-error e2037)) tmp2038))) (syntax-dispatch tmp2038 (quote (any any))))) e2037))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2045 r2046 w2047 s2048 mod2049) ((lambda (tmp2050) ((lambda (tmp2051) (if tmp2051 (apply (lambda (_2052 c2053) (chi-lambda-clause1172 (source-wrap1160 e2045 w2047 s2048 mod2049) c2053 r2046 w2047 mod2049 (lambda (vars2054 body2055) (build-annotated1108 s2048 (list (quote lambda) vars2054 body2055))))) tmp2051) (syntax-error tmp2050))) (syntax-dispatch tmp2050 (quote (any . any))))) e2045))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2056 (lambda (e2057 r2058 w2059 s2060 mod2061 constructor2062 ids2063 vals2064 exps2065) (if (not (valid-bound-ids?1156 ids2063)) (syntax-error e2057 "duplicate bound variable in") (let ((labels2066 (gen-labels1137 ids2063)) (new-vars2067 (map gen-var1179 ids2063))) (let ((nw2068 (make-binding-wrap1148 ids2063 labels2066 w2059)) (nr2069 (extend-var-env1126 labels2066 new-vars2067 r2058))) (constructor2062 s2060 new-vars2067 (map (lambda (x2070) (chi1167 x2070 r2058 w2059 mod2061)) vals2064) (chi-body1171 exps2065 (source-wrap1160 e2057 nw2068 s2060 mod2061) nr2069 nw2068 mod2061)))))))) (lambda (e2071 r2072 w2073 s2074 mod2075) ((lambda (tmp2076) ((lambda (tmp2077) (if tmp2077 (apply (lambda (_2078 id2079 val2080 e12081 e22082) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-let1111 id2079 val2080 (cons e12081 e22082))) tmp2077) ((lambda (tmp2086) (if (if tmp2086 (apply (lambda (_2087 f2088 id2089 val2090 e12091 e22092) (id?1131 f2088)) tmp2086) #f) (apply (lambda (_2093 f2094 id2095 val2096 e12097 e22098) (chi-let2056 e2071 r2072 w2073 s2074 mod2075 build-named-let1112 (cons f2094 id2095) val2096 (cons e12097 e22098))) tmp2086) ((lambda (_2102) (syntax-error (source-wrap1160 e2071 w2073 s2074 mod2075))) tmp2076))) (syntax-dispatch tmp2076 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2076 (quote (any #(each (any any)) any . each-any))))) e2071)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2103 r2104 w2105 s2106 mod2107) ((lambda (tmp2108) ((lambda (tmp2109) (if tmp2109 (apply (lambda (_2110 id2111 val2112 e12113 e22114) (let ((ids2115 id2111)) (if (not (valid-bound-ids?1156 ids2115)) (syntax-error e2103 "duplicate bound variable in") (let ((labels2117 (gen-labels1137 ids2115)) (new-vars2118 (map gen-var1179 ids2115))) (let ((w2119 (make-binding-wrap1148 ids2115 labels2117 w2105)) (r2120 (extend-var-env1126 labels2117 new-vars2118 r2104))) (build-letrec1113 s2106 new-vars2118 (map (lambda (x2121) (chi1167 x2121 r2120 w2119 mod2107)) val2112) (chi-body1171 (cons e12113 e22114) (source-wrap1160 e2103 w2119 s2106 mod2107) r2120 w2119 mod2107))))))) tmp2109) ((lambda (_2124) (syntax-error (source-wrap1160 e2103 w2105 s2106 mod2107))) tmp2108))) (syntax-dispatch tmp2108 (quote (any #(each (any any)) any . each-any))))) e2103))) (global-extend1129 (quote core) (quote set!) (lambda (e2125 r2126 w2127 s2128 mod2129) ((lambda (tmp2130) ((lambda (tmp2131) (if (if tmp2131 (apply (lambda (_2132 id2133 val2134) (id?1131 id2133)) tmp2131) #f) (apply (lambda (_2135 id2136 val2137) (let ((val2138 (chi1167 val2137 r2126 w2127 mod2129)) (n2139 (id-var-name1153 id2136 w2127))) (let ((b2140 (lookup1128 n2139 r2126 mod2129))) (let ((t2141 (binding-type1123 b2140))) (if (memv t2141 (quote (lexical))) (build-annotated1108 s2128 (list (quote set!) (binding-value1124 b2140) val2138)) (if (memv t2141 (quote (global))) (build-annotated1108 s2128 (list (quote set!) (if mod2129 (make-module-ref (cdr mod2129) n2139 (car mod2129)) (make-module-ref mod2129 n2139 (quote bare))) val2138)) (if (memv t2141 (quote (displaced-lexical))) (syntax-error (wrap1159 id2136 w2127 mod2129) "identifier out of context") (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))))))))) tmp2131) ((lambda (tmp2142) (if tmp2142 (apply (lambda (_2143 head2144 tail2145 val2146) (call-with-values (lambda () (syntax-type1165 head2144 r2126 (quote (())) #f #f mod2129)) (lambda (type2147 value2148 ee2149 ww2150 ss2151 modmod2152) (let ((t2153 type2147)) (if (memv t2153 (quote (module-ref))) (let ((val2154 (chi1167 val2146 r2126 w2127 mod2129))) (call-with-values (lambda () (value2148 (cons head2144 tail2145))) (lambda (id2156 mod2157) (build-annotated1108 s2128 (list (quote set!) (if mod2157 (make-module-ref (cdr mod2157) id2156 (car mod2157)) (make-module-ref mod2157 id2156 (quote bare))) val2154))))) (build-annotated1108 s2128 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2144) r2126 w2127 mod2129) (map (lambda (e2158) (chi1167 e2158 r2126 w2127 mod2129)) (append tail2145 (list val2146)))))))))) tmp2142) ((lambda (_2160) (syntax-error (source-wrap1160 e2125 w2127 s2128 mod2129))) tmp2130))) (syntax-dispatch tmp2130 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2130 (quote (any any any))))) e2125))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2161) ((lambda (tmp2162) ((lambda (tmp2163) (if (if tmp2163 (apply (lambda (_2164 mod2165 id2166) (and (andmap id?1131 mod2165) (id?1131 id2166))) tmp2163) #f) (apply (lambda (_2168 mod2169 id2170) (values (syntax-object->datum id2170) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2169)))) tmp2163) (syntax-error tmp2162))) (syntax-dispatch tmp2162 (quote (any each-any any))))) e2161))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2172) ((lambda (tmp2173) ((lambda (tmp2174) (if (if tmp2174 (apply (lambda (_2175 mod2176 id2177) (and (andmap id?1131 mod2176) (id?1131 id2177))) tmp2174) #f) (apply (lambda (_2179 mod2180 id2181) (values (syntax-object->datum id2181) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2180)))) tmp2174) (syntax-error tmp2173))) (syntax-dispatch tmp2173 (quote (any each-any any))))) e2172))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2186 (lambda (x2187 keys2188 clauses2189 r2190 mod2191) (if (null? clauses2189) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2187)) ((lambda (tmp2192) ((lambda (tmp2193) (if tmp2193 (apply (lambda (pat2194 exp2195) (if (and (id?1131 pat2194) (andmap (lambda (x2196) (not (free-id=?1154 pat2194 x2196))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2188))) (let ((labels2197 (list (gen-label1136))) (var2198 (gen-var1179 pat2194))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2198) (chi1167 exp2195 (extend-env1125 labels2197 (list (cons (quote syntax) (cons var2198 0))) r2190) (make-binding-wrap1148 (list pat2194) labels2197 (quote (()))) mod2191))) x2187))) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2194 #t exp2195 mod2191))) tmp2193) ((lambda (tmp2199) (if tmp2199 (apply (lambda (pat2200 fender2201 exp2202) (gen-clause2185 x2187 keys2188 (cdr clauses2189) r2190 pat2200 fender2201 exp2202 mod2191)) tmp2199) ((lambda (_2203) (syntax-error (car clauses2189) "invalid syntax-case clause")) tmp2192))) (syntax-dispatch tmp2192 (quote (any any any)))))) (syntax-dispatch tmp2192 (quote (any any))))) (car clauses2189))))) (gen-clause2185 (lambda (x2204 keys2205 clauses2206 r2207 pat2208 fender2209 exp2210 mod2211) (call-with-values (lambda () (convert-pattern2183 pat2208 keys2205)) (lambda (p2212 pvars2213) (cond ((not (distinct-bound-ids?1157 (map car pvars2213))) (syntax-error pat2208 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2214) (not (ellipsis?1176 (car x2214)))) pvars2213)) (syntax-error pat2208 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2215 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2215) (let ((y2216 (build-annotated1108 #f y2215))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2217) ((lambda (tmp2218) (if tmp2218 (apply (lambda () y2216) tmp2218) ((lambda (_2219) (build-annotated1108 #f (list (quote if) y2216 (build-dispatch-call2184 pvars2213 fender2209 y2216 r2207 mod2211) (build-data1109 #f #f)))) tmp2217))) (syntax-dispatch tmp2217 (quote #(atom #t))))) fender2209) (build-dispatch-call2184 pvars2213 exp2210 y2216 r2207 mod2211) (gen-syntax-case2186 x2204 keys2205 clauses2206 r2207 mod2211)))))) (if (eq? p2212 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2204)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2204 (build-data1109 #f p2212))))))))))))) (build-dispatch-call2184 (lambda (pvars2220 exp2221 y2222 r2223 mod2224) (let ((ids2225 (map car pvars2220)) (levels2226 (map cdr pvars2220))) (let ((labels2227 (gen-labels1137 ids2225)) (new-vars2228 (map gen-var1179 ids2225))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2228 (chi1167 exp2221 (extend-env1125 labels2227 (map (lambda (var2229 level2230) (cons (quote syntax) (cons var2229 level2230))) new-vars2228 (map cdr pvars2220)) r2223) (make-binding-wrap1148 ids2225 labels2227 (quote (()))) mod2224))) y2222)))))) (convert-pattern2183 (lambda (pattern2231 keys2232) (let cvt2233 ((p2234 pattern2231) (n2235 0) (ids2236 (quote ()))) (if (id?1131 p2234) (if (bound-id-member?1158 p2234 keys2232) (values (vector (quote free-id) p2234) ids2236) (values (quote any) (cons (cons p2234 n2235) ids2236))) ((lambda (tmp2237) ((lambda (tmp2238) (if (if tmp2238 (apply (lambda (x2239 dots2240) (ellipsis?1176 dots2240)) tmp2238) #f) (apply (lambda (x2241 dots2242) (call-with-values (lambda () (cvt2233 x2241 (fx+1098 n2235 1) ids2236)) (lambda (p2243 ids2244) (values (if (eq? p2243 (quote any)) (quote each-any) (vector (quote each) p2243)) ids2244)))) tmp2238) ((lambda (tmp2245) (if tmp2245 (apply (lambda (x2246 y2247) (call-with-values (lambda () (cvt2233 y2247 n2235 ids2236)) (lambda (y2248 ids2249) (call-with-values (lambda () (cvt2233 x2246 n2235 ids2249)) (lambda (x2250 ids2251) (values (cons x2250 y2248) ids2251)))))) tmp2245) ((lambda (tmp2252) (if tmp2252 (apply (lambda () (values (quote ()) ids2236)) tmp2252) ((lambda (tmp2253) (if tmp2253 (apply (lambda (x2254) (call-with-values (lambda () (cvt2233 x2254 n2235 ids2236)) (lambda (p2256 ids2257) (values (vector (quote vector) p2256) ids2257)))) tmp2253) ((lambda (x2258) (values (vector (quote atom) (strip1178 p2234 (quote (())))) ids2236)) tmp2237))) (syntax-dispatch tmp2237 (quote #(vector each-any)))))) (syntax-dispatch tmp2237 (quote ()))))) (syntax-dispatch tmp2237 (quote (any . any)))))) (syntax-dispatch tmp2237 (quote (any any))))) p2234)))))) (lambda (e2259 r2260 w2261 s2262 mod2263) (let ((e2264 (source-wrap1160 e2259 w2261 s2262 mod2263))) ((lambda (tmp2265) ((lambda (tmp2266) (if tmp2266 (apply (lambda (_2267 val2268 key2269 m2270) (if (andmap (lambda (x2271) (and (id?1131 x2271) (not (ellipsis?1176 x2271)))) key2269) (let ((x2273 (gen-var1179 (quote tmp)))) (build-annotated1108 s2262 (list (build-annotated1108 #f (list (quote lambda) (list x2273) (gen-syntax-case2186 (build-annotated1108 #f x2273) key2269 m2270 r2260 mod2263))) (chi1167 val2268 r2260 (quote (())) mod2263)))) (syntax-error e2264 "invalid literals list in"))) tmp2266) (syntax-error tmp2265))) (syntax-dispatch tmp2265 (quote (any any each-any . each-any))))) e2264))))) (set! sc-expand (let ((m2276 (quote e)) (esew2277 (quote (eval)))) (lambda (x2278) (if (and (pair? x2278) (equal? (car x2278) noexpand1097)) (cadr x2278) (chi-top1166 x2278 (quote ()) (quote ((top))) m2276 esew2277 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2279 (quote e)) (esew2280 (quote (eval)))) (lambda (x2282 . rest2281) (if (and (pair? x2282) (equal? (car x2282) noexpand1097)) (cadr x2282) (chi-top1166 x2282 (quote ()) (quote ((top))) (if (null? rest2281) m2279 (car rest2281)) (if (or (null? rest2281) (null? (cdr rest2281))) esew2280 (cadr rest2281)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2283) (nonsymbol-id?1130 x2283))) (set! datum->syntax-object (lambda (id2284 datum2285) (make-syntax-object1114 datum2285 (syntax-object-wrap1117 id2284) #f))) (set! syntax-object->datum (lambda (x2286) (strip1178 x2286 (quote (()))))) (set! generate-temporaries (lambda (ls2287) (begin (let ((x2288 ls2287)) (if (not (list? x2288)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2288))) (map (lambda (x2289) (wrap1159 (gensym) (quote ((top))) #f)) ls2287)))) (set! free-identifier=? (lambda (x2290 y2291) (begin (let ((x2292 x2290)) (if (not (nonsymbol-id?1130 x2292)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2292))) (let ((x2293 y2291)) (if (not (nonsymbol-id?1130 x2293)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2293))) (free-id=?1154 x2290 y2291)))) (set! bound-identifier=? (lambda (x2294 y2295) (begin (let ((x2296 x2294)) (if (not (nonsymbol-id?1130 x2296)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2296))) (let ((x2297 y2295)) (if (not (nonsymbol-id?1130 x2297)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2297))) (bound-id=?1155 x2294 y2295)))) (set! syntax-error (lambda (object2299 . messages2298) (begin (for-each (lambda (x2300) (let ((x2301 x2300)) (if (not (string? x2301)) (error-hook1104 (quote syntax-error) "invalid argument" x2301)))) messages2298) (let ((message2302 (if (null? messages2298) "invalid syntax" (apply string-append messages2298)))) (error-hook1104 #f message2302 (strip1178 object2299 (quote (())))))))) (set! install-global-transformer (lambda (sym2303 v2304) (begin (let ((x2305 sym2303)) (if (not (symbol? x2305)) (error-hook1104 (quote define-syntax) "invalid argument" x2305))) (let ((x2306 v2304)) (if (not (procedure? x2306)) (error-hook1104 (quote define-syntax) "invalid argument" x2306))) (global-extend1129 (quote macro) sym2303 v2304)))) (letrec ((match2311 (lambda (e2312 p2313 w2314 r2315 mod2316) (cond ((not r2315) #f) ((eq? p2313 (quote any)) (cons (wrap1159 e2312 w2314 mod2316) r2315)) ((syntax-object?1115 e2312) (match*2310 (let ((e2317 (syntax-object-expression1116 e2312))) (if (annotation? e2317) (annotation-expression e2317) e2317)) p2313 (join-wraps1150 w2314 (syntax-object-wrap1117 e2312)) r2315 (syntax-object-module1118 e2312))) (else (match*2310 (let ((e2318 e2312)) (if (annotation? e2318) (annotation-expression e2318) e2318)) p2313 w2314 r2315 mod2316))))) (match*2310 (lambda (e2319 p2320 w2321 r2322 mod2323) (cond ((null? p2320) (and (null? e2319) r2322)) ((pair? p2320) (and (pair? e2319) (match2311 (car e2319) (car p2320) w2321 (match2311 (cdr e2319) (cdr p2320) w2321 r2322 mod2323) mod2323))) ((eq? p2320 (quote each-any)) (let ((l2324 (match-each-any2308 e2319 w2321 mod2323))) (and l2324 (cons l2324 r2322)))) (else (let ((t2325 (vector-ref p2320 0))) (if (memv t2325 (quote (each))) (if (null? e2319) (match-empty2309 (vector-ref p2320 1) r2322) (let ((l2326 (match-each2307 e2319 (vector-ref p2320 1) w2321 mod2323))) (and l2326 (let collect2327 ((l2328 l2326)) (if (null? (car l2328)) r2322 (cons (map car l2328) (collect2327 (map cdr l2328)))))))) (if (memv t2325 (quote (free-id))) (and (id?1131 e2319) (free-id=?1154 (wrap1159 e2319 w2321 mod2323) (vector-ref p2320 1)) r2322) (if (memv t2325 (quote (atom))) (and (equal? (vector-ref p2320 1) (strip1178 e2319 w2321)) r2322) (if (memv t2325 (quote (vector))) (and (vector? e2319) (match2311 (vector->list e2319) (vector-ref p2320 1) w2321 r2322 mod2323))))))))))) (match-empty2309 (lambda (p2329 r2330) (cond ((null? p2329) r2330) ((eq? p2329 (quote any)) (cons (quote ()) r2330)) ((pair? p2329) (match-empty2309 (car p2329) (match-empty2309 (cdr p2329) r2330))) ((eq? p2329 (quote each-any)) (cons (quote ()) r2330)) (else (let ((t2331 (vector-ref p2329 0))) (if (memv t2331 (quote (each))) (match-empty2309 (vector-ref p2329 1) r2330) (if (memv t2331 (quote (free-id atom))) r2330 (if (memv t2331 (quote (vector))) (match-empty2309 (vector-ref p2329 1) r2330))))))))) (match-each-any2308 (lambda (e2332 w2333 mod2334) (cond ((annotation? e2332) (match-each-any2308 (annotation-expression e2332) w2333 mod2334)) ((pair? e2332) (let ((l2335 (match-each-any2308 (cdr e2332) w2333 mod2334))) (and l2335 (cons (wrap1159 (car e2332) w2333 mod2334) l2335)))) ((null? e2332) (quote ())) ((syntax-object?1115 e2332) (match-each-any2308 (syntax-object-expression1116 e2332) (join-wraps1150 w2333 (syntax-object-wrap1117 e2332)) mod2334)) (else #f)))) (match-each2307 (lambda (e2336 p2337 w2338 mod2339) (cond ((annotation? e2336) (match-each2307 (annotation-expression e2336) p2337 w2338 mod2339)) ((pair? e2336) (let ((first2340 (match2311 (car e2336) p2337 w2338 (quote ()) mod2339))) (and first2340 (let ((rest2341 (match-each2307 (cdr e2336) p2337 w2338 mod2339))) (and rest2341 (cons first2340 rest2341)))))) ((null? e2336) (quote ())) ((syntax-object?1115 e2336) (match-each2307 (syntax-object-expression1116 e2336) p2337 (join-wraps1150 w2338 (syntax-object-wrap1117 e2336)) (syntax-object-module1118 e2336))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2342 p2343) (cond ((eq? p2343 (quote any)) (list e2342)) ((syntax-object?1115 e2342) (match*2310 (let ((e2344 (syntax-object-expression1116 e2342))) (if (annotation? e2344) (annotation-expression e2344) e2344)) p2343 (syntax-object-wrap1117 e2342) (quote ()) (syntax-object-module1118 e2342))) (else (match*2310 (let ((e2345 e2342)) (if (annotation? e2345) (annotation-expression e2345) e2345)) p2343 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) -(install-global-transformer (quote with-syntax) (lambda (x2346) ((lambda (tmp2347) ((lambda (tmp2348) (if tmp2348 (apply (lambda (_2349 e12350 e22351) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12350 e22351))) tmp2348) ((lambda (tmp2353) (if tmp2353 (apply (lambda (_2354 out2355 in2356 e12357 e22358) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2356 (quote ()) (list out2355 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12357 e22358))))) tmp2353) ((lambda (tmp2360) (if tmp2360 (apply (lambda (_2361 out2362 in2363 e12364 e22365) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2363) (quote ()) (list out2362 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12364 e22365))))) tmp2360) (syntax-error tmp2347))) (syntax-dispatch tmp2347 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2347 (quote (any () any . each-any))))) x2346))) -(install-global-transformer (quote syntax-rules) (lambda (x2369) ((lambda (tmp2370) ((lambda (tmp2371) (if tmp2371 (apply (lambda (_2372 k2373 keyword2374 pattern2375 template2376) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2373 (map (lambda (tmp2379 tmp2378) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2378) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2379))) template2376 pattern2375)))))) tmp2371) (syntax-error tmp2370))) (syntax-dispatch tmp2370 (quote (any each-any . #(each ((any . any) any))))))) x2369))) -(install-global-transformer (quote let*) (lambda (x2380) ((lambda (tmp2381) ((lambda (tmp2382) (if (if tmp2382 (apply (lambda (let*2383 x2384 v2385 e12386 e22387) (andmap identifier? x2384)) tmp2382) #f) (apply (lambda (let*2389 x2390 v2391 e12392 e22393) (let f2394 ((bindings2395 (map list x2390 v2391))) (if (null? bindings2395) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12392 e22393))) ((lambda (tmp2399) ((lambda (tmp2400) (if tmp2400 (apply (lambda (body2401 binding2402) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2402) body2401)) tmp2400) (syntax-error tmp2399))) (syntax-dispatch tmp2399 (quote (any any))))) (list (f2394 (cdr bindings2395)) (car bindings2395)))))) tmp2382) (syntax-error tmp2381))) (syntax-dispatch tmp2381 (quote (any #(each (any any)) any . each-any))))) x2380))) -(install-global-transformer (quote do) (lambda (orig-x2403) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 var2407 init2408 step2409 e02410 e12411 c2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (step2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02410) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2415))))))) tmp2417) ((lambda (tmp2422) (if tmp2422 (apply (lambda (e12423 e22424) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2407 init2408) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02410 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12423 e22424)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2412 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2415))))))) tmp2422) (syntax-error tmp2416))) (syntax-dispatch tmp2416 (quote (any . each-any)))))) (syntax-dispatch tmp2416 (quote ())))) e12411)) tmp2414) (syntax-error tmp2413))) (syntax-dispatch tmp2413 (quote each-any)))) (map (lambda (v2431 s2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () v2431) tmp2434) ((lambda (tmp2435) (if tmp2435 (apply (lambda (e2436) e2436) tmp2435) ((lambda (_2437) (syntax-error orig-x2403)) tmp2433))) (syntax-dispatch tmp2433 (quote (any)))))) (syntax-dispatch tmp2433 (quote ())))) s2432)) var2407 step2409))) tmp2405) (syntax-error tmp2404))) (syntax-dispatch tmp2404 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2403))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2440 (lambda (x2444 y2445) ((lambda (tmp2446) ((lambda (tmp2447) (if tmp2447 (apply (lambda (x2448 y2449) ((lambda (tmp2450) ((lambda (tmp2451) (if tmp2451 (apply (lambda (dy2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (dx2455) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2455 dy2452))) tmp2454) ((lambda (_2456) (if (null? dy2452) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448 y2449))) tmp2453))) (syntax-dispatch tmp2453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2448)) tmp2451) ((lambda (tmp2457) (if tmp2457 (apply (lambda (stuff2458) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2448 stuff2458))) tmp2457) ((lambda (else2459) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448 y2449)) tmp2450))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2450 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2449)) tmp2447) (syntax-error tmp2446))) (syntax-dispatch tmp2446 (quote (any any))))) (list x2444 y2445)))) (quasiappend2441 (lambda (x2460 y2461) ((lambda (tmp2462) ((lambda (tmp2463) (if tmp2463 (apply (lambda (x2464 y2465) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda () x2464) tmp2467) ((lambda (_2468) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2464 y2465)) tmp2466))) (syntax-dispatch tmp2466 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2465)) tmp2463) (syntax-error tmp2462))) (syntax-dispatch tmp2462 (quote (any any))))) (list x2460 y2461)))) (quasivector2442 (lambda (x2469) ((lambda (tmp2470) ((lambda (x2471) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (x2474) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2474))) tmp2473) ((lambda (tmp2476) (if tmp2476 (apply (lambda (x2477) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2477)) tmp2476) ((lambda (_2479) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2471)) tmp2472))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2472 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2471)) tmp2470)) x2469))) (quasi2443 (lambda (p2480 lev2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (p2484) (if (= lev2481 0) p2484 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2443 (list p2484) (- lev2481 1))))) tmp2483) ((lambda (tmp2485) (if tmp2485 (apply (lambda (p2486 q2487) (if (= lev2481 0) (quasiappend2441 p2486 (quasi2443 q2487 lev2481)) (quasicons2440 (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2443 (list p2486) (- lev2481 1))) (quasi2443 q2487 lev2481)))) tmp2485) ((lambda (tmp2488) (if tmp2488 (apply (lambda (p2489) (quasicons2440 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2443 (list p2489) (+ lev2481 1)))) tmp2488) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491 q2492) (quasicons2440 (quasi2443 p2491 lev2481) (quasi2443 q2492 lev2481))) tmp2490) ((lambda (tmp2493) (if tmp2493 (apply (lambda (x2494) (quasivector2442 (quasi2443 x2494 lev2481))) tmp2493) ((lambda (p2496) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2496)) tmp2482))) (syntax-dispatch tmp2482 (quote #(vector each-any)))))) (syntax-dispatch tmp2482 (quote (any . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2482 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2482 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2480)))) (lambda (x2497) ((lambda (tmp2498) ((lambda (tmp2499) (if tmp2499 (apply (lambda (_2500 e2501) (quasi2443 e2501 0)) tmp2499) (syntax-error tmp2498))) (syntax-dispatch tmp2498 (quote (any any))))) x2497)))) -(install-global-transformer (quote include) (lambda (x2502) (letrec ((read-file2503 (lambda (fn2504 k2505) (let ((p2506 (open-input-file fn2504))) (let f2507 ((x2508 (read p2506))) (if (eof-object? x2508) (begin (close-input-port p2506) (quote ())) (cons (datum->syntax-object k2505 x2508) (f2507 (read p2506))))))))) ((lambda (tmp2509) ((lambda (tmp2510) (if tmp2510 (apply (lambda (k2511 filename2512) (let ((fn2513 (syntax-object->datum filename2512))) ((lambda (tmp2514) ((lambda (tmp2515) (if tmp2515 (apply (lambda (exp2516) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2516)) tmp2515) (syntax-error tmp2514))) (syntax-dispatch tmp2514 (quote each-any)))) (read-file2503 fn2513 k2511)))) tmp2510) (syntax-error tmp2509))) (syntax-dispatch tmp2509 (quote (any any))))) x2502)))) -(install-global-transformer (quote unquote) (lambda (x2518) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (_2521 e2522) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2522))) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote (any any))))) x2518))) -(install-global-transformer (quote unquote-splicing) (lambda (x2523) ((lambda (tmp2524) ((lambda (tmp2525) (if tmp2525 (apply (lambda (_2526 e2527) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2527))) tmp2525) (syntax-error tmp2524))) (syntax-dispatch tmp2524 (quote (any any))))) x2523))) -(install-global-transformer (quote case) (lambda (x2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda (_2531 e2532 m12533 m22534) ((lambda (tmp2535) ((lambda (body2536) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2532)) body2536)) tmp2535)) (let f2537 ((clause2538 m12533) (clauses2539 m22534)) (if (null? clauses2539) ((lambda (tmp2541) ((lambda (tmp2542) (if tmp2542 (apply (lambda (e12543 e22544) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12543 e22544))) tmp2542) ((lambda (tmp2546) (if tmp2546 (apply (lambda (k2547 e12548 e22549) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2547)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12548 e22549)))) tmp2546) ((lambda (_2552) (syntax-error x2528)) tmp2541))) (syntax-dispatch tmp2541 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2541 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2538) ((lambda (tmp2553) ((lambda (rest2554) ((lambda (tmp2555) ((lambda (tmp2556) (if tmp2556 (apply (lambda (k2557 e12558 e22559) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2557)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12558 e22559)) rest2554)) tmp2556) ((lambda (_2562) (syntax-error x2528)) tmp2555))) (syntax-dispatch tmp2555 (quote (each-any any . each-any))))) clause2538)) tmp2553)) (f2537 (car clauses2539) (cdr clauses2539))))))) tmp2530) (syntax-error tmp2529))) (syntax-dispatch tmp2529 (quote (any any any . each-any))))) x2528))) -(install-global-transformer (quote identifier-syntax) (lambda (x2563) ((lambda (tmp2564) ((lambda (tmp2565) (if tmp2565 (apply (lambda (_2566 e2567) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2567)) (list (cons _2566 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2567 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2565) (syntax-error tmp2564))) (syntax-dispatch tmp2564 (quote (any any))))) x2563))) +(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (let ((pmod1522 (procedure-module p1510))) (if pmod1522 (cons (quote hygiene) (module-name pmod1522)) (quote (hygiene guile))))))))) ((vector? x1517) (let ((n1523 (vector-length x1517))) (let ((v1524 (make-vector n1523))) (let doloop1525 ((i1526 0)) (if (fx=1100 i1526 n1523) v1524 (begin (vector-set! v1524 i1526 (rebuild-macro-output1516 (vector-ref x1517 i1526) m1518)) (doloop1525 (fx+1098 i1526 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1527 e1528 r1529 w1530 s1531 mod1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (e01535 e11536) (build-annotated1108 s1531 (cons x1527 (map (lambda (e1537) (chi1167 e1537 r1529 w1530 mod1532)) e11536)))) tmp1534) (syntax-error tmp1533))) (syntax-dispatch tmp1533 (quote (any . each-any))))) e1528))) (chi-expr1168 (lambda (type1539 value1540 e1541 r1542 w1543 s1544 mod1545) (let ((t1546 type1539)) (if (memv t1546 (quote (lexical))) (build-annotated1108 s1544 value1540) (if (memv t1546 (quote (core external-macro))) (value1540 e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (module-ref))) (call-with-values (lambda () (value1540 e1541)) (lambda (id1547 mod1548) (build-annotated1108 s1544 (if mod1548 (make-module-ref (cdr mod1548) id1547 (car mod1548)) (make-module-ref mod1548 id1547 (quote bare)))))) (if (memv t1546 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1541)) value1540) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (global-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1541)) (if (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545) (make-module-ref (cdr (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545)) value1540 (car (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545))) (make-module-ref (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545) value1540 (quote bare)))) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (constant))) (build-data1109 s1544 (strip1178 (source-wrap1160 e1541 w1543 s1544 mod1545) (quote (())))) (if (memv t1546 (quote (global))) (build-annotated1108 s1544 (if mod1545 (make-module-ref (cdr mod1545) value1540 (car mod1545)) (make-module-ref mod1545 value1540 (quote bare)))) (if (memv t1546 (quote (call))) (chi-application1169 (chi1167 (car e1541) r1542 w1543 mod1545) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (begin-form))) ((lambda (tmp1549) ((lambda (tmp1550) (if tmp1550 (apply (lambda (_1551 e11552 e21553) (chi-sequence1161 (cons e11552 e21553) r1542 w1543 s1544 mod1545)) tmp1550) (syntax-error tmp1549))) (syntax-dispatch tmp1549 (quote (any any . each-any))))) e1541) (if (memv t1546 (quote (local-syntax-form))) (chi-local-syntax1173 value1540 e1541 r1542 w1543 s1544 mod1545 chi-sequence1161) (if (memv t1546 (quote (eval-when-form))) ((lambda (tmp1555) ((lambda (tmp1556) (if tmp1556 (apply (lambda (_1557 x1558 e11559 e21560) (let ((when-list1561 (chi-when-list1164 e1541 x1558 w1543))) (if (memq (quote eval) when-list1561) (chi-sequence1161 (cons e11559 e21560) r1542 w1543 s1544 mod1545) (chi-void1175)))) tmp1556) (syntax-error tmp1555))) (syntax-dispatch tmp1555 (quote (any each-any any . each-any))))) e1541) (if (memv t1546 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1540 w1543 mod1545) "invalid context for definition of") (if (memv t1546 (quote (syntax))) (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545) "reference to pattern variable outside syntax form") (if (memv t1546 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545))))))))))))))))))) (chi1167 (lambda (e1564 r1565 w1566 mod1567) (call-with-values (lambda () (syntax-type1165 e1564 r1565 w1566 #f #f mod1567)) (lambda (type1568 value1569 e1570 w1571 s1572 mod1573) (chi-expr1168 type1568 value1569 e1570 r1565 w1571 s1572 mod1573))))) (chi-top1166 (lambda (e1574 r1575 w1576 m1577 esew1578 mod1579) (call-with-values (lambda () (syntax-type1165 e1574 r1575 w1576 #f #f mod1579)) (lambda (type1587 value1588 e1589 w1590 s1591 mod1592) (let ((t1593 type1587)) (if (memv t1593 (quote (begin-form))) ((lambda (tmp1594) ((lambda (tmp1595) (if tmp1595 (apply (lambda (_1596) (chi-void1175)) tmp1595) ((lambda (tmp1597) (if tmp1597 (apply (lambda (_1598 e11599 e21600) (chi-top-sequence1162 (cons e11599 e21600) r1575 w1590 s1591 m1577 esew1578 mod1592)) tmp1597) (syntax-error tmp1594))) (syntax-dispatch tmp1594 (quote (any any . each-any)))))) (syntax-dispatch tmp1594 (quote (any))))) e1589) (if (memv t1593 (quote (local-syntax-form))) (chi-local-syntax1173 value1588 e1589 r1575 w1590 s1591 mod1592 (lambda (body1602 r1603 w1604 s1605 mod1606) (chi-top-sequence1162 body1602 r1603 w1604 s1605 m1577 esew1578 mod1606))) (if (memv t1593 (quote (eval-when-form))) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (_1609 x1610 e11611 e21612) (let ((when-list1613 (chi-when-list1164 e1589 x1610 w1590)) (body1614 (cons e11611 e21612))) (cond ((eq? m1577 (quote e)) (if (memq (quote eval) when-list1613) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote e) (quote (eval)) mod1592) (chi-void1175))) ((memq (quote load) when-list1613) (if (or (memq (quote compile) when-list1613) (and (eq? m1577 (quote c&e)) (memq (quote eval) when-list1613))) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote c&e) (quote (compile load)) mod1592) (if (memq m1577 (quote (c c&e))) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote c) (quote (load)) mod1592) (chi-void1175)))) ((or (memq (quote compile) when-list1613) (and (eq? m1577 (quote c&e)) (memq (quote eval) when-list1613))) (top-level-eval-hook1102 (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote e) (quote (eval)) mod1592) mod1592) (chi-void1175)) (else (chi-void1175))))) tmp1608) (syntax-error tmp1607))) (syntax-dispatch tmp1607 (quote (any each-any any . each-any))))) e1589) (if (memv t1593 (quote (define-syntax-form))) (let ((n1617 (id-var-name1153 value1588 w1590)) (r1618 (macros-only-env1127 r1575))) (let ((t1619 m1577)) (if (memv t1619 (quote (c))) (if (memq (quote compile) esew1578) (let ((e1620 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)))) (begin (top-level-eval-hook1102 e1620 mod1592) (if (memq (quote load) esew1578) e1620 (chi-void1175)))) (if (memq (quote load) esew1578) (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)) (chi-void1175))) (if (memv t1619 (quote (c&e))) (let ((e1621 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)))) (begin (top-level-eval-hook1102 e1621 mod1592) e1621)) (begin (if (memq (quote eval) esew1578) (top-level-eval-hook1102 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)) mod1592)) (chi-void1175)))))) (if (memv t1593 (quote (define-form))) (let ((n1622 (id-var-name1153 value1588 w1590))) (let ((type1623 (binding-type1123 (lookup1128 n1622 r1575 mod1592)))) (let ((t1624 type1623)) (if (memv t1624 (quote (global))) (let ((x1625 (build-annotated1108 s1591 (list (quote define) n1622 (chi1167 e1589 r1575 w1590 mod1592))))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1625 mod1592)) x1625)) (if (memv t1624 (quote (displaced-lexical))) (syntax-error (wrap1159 value1588 w1590 mod1592) "identifier out of context") (if (memv t1624 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1622) (let ((x1626 (build-annotated1108 s1591 (list (quote define) n1622 (chi1167 e1589 r1575 w1590 mod1592))))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1626 mod1592)) x1626))) (syntax-error (wrap1159 value1588 w1590 mod1592) "cannot define keyword at top level"))))))) (let ((x1627 (chi-expr1168 type1587 value1588 e1589 r1575 w1590 s1591 mod1592))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1627 mod1592)) x1627)))))))))))) (syntax-type1165 (lambda (e1628 r1629 w1630 s1631 rib1632 mod1633) (cond ((symbol? e1628) (let ((n1634 (id-var-name1153 e1628 w1630))) (let ((b1635 (lookup1128 n1634 r1629 mod1633))) (let ((type1636 (binding-type1123 b1635))) (let ((t1637 type1636)) (if (memv t1637 (quote (lexical))) (values type1636 (binding-value1124 b1635) e1628 w1630 s1631 mod1633) (if (memv t1637 (quote (global))) (values type1636 n1634 e1628 w1630 s1631 mod1633) (if (memv t1637 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1635) e1628 r1629 w1630 rib1632 mod1633) r1629 (quote (())) s1631 rib1632 mod1633) (values type1636 (binding-value1124 b1635) e1628 w1630 s1631 mod1633))))))))) ((pair? e1628) (let ((first1638 (car e1628))) (if (id?1131 first1638) (let ((n1639 (id-var-name1153 first1638 w1630))) (let ((b1640 (lookup1128 n1639 r1629 (or (and (syntax-object?1115 first1638) (syntax-object-module1118 first1638)) mod1633)))) (let ((type1641 (binding-type1123 b1640))) (let ((t1642 type1641)) (if (memv t1642 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (global))) (values (quote global-call) n1639 e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1640) e1628 r1629 w1630 rib1632 mod1633) r1629 (quote (())) s1631 rib1632 mod1633) (if (memv t1642 (quote (core external-macro module-ref))) (values type1641 (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (begin))) (values (quote begin-form) #f e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (eval-when))) (values (quote eval-when-form) #f e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (define))) ((lambda (tmp1643) ((lambda (tmp1644) (if (if tmp1644 (apply (lambda (_1645 name1646 val1647) (id?1131 name1646)) tmp1644) #f) (apply (lambda (_1648 name1649 val1650) (values (quote define-form) name1649 val1650 w1630 s1631 mod1633)) tmp1644) ((lambda (tmp1651) (if (if tmp1651 (apply (lambda (_1652 name1653 args1654 e11655 e21656) (and (id?1131 name1653) (valid-bound-ids?1156 (lambda-var-list1180 args1654)))) tmp1651) #f) (apply (lambda (_1657 name1658 args1659 e11660 e21661) (values (quote define-form) (wrap1159 name1658 w1630 mod1633) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1159 (cons args1659 (cons e11660 e21661)) w1630 mod1633)) (quote (())) s1631 mod1633)) tmp1651) ((lambda (tmp1663) (if (if tmp1663 (apply (lambda (_1664 name1665) (id?1131 name1665)) tmp1663) #f) (apply (lambda (_1666 name1667) (values (quote define-form) (wrap1159 name1667 w1630 mod1633) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1631 mod1633)) tmp1663) (syntax-error tmp1643))) (syntax-dispatch tmp1643 (quote (any any)))))) (syntax-dispatch tmp1643 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1643 (quote (any any any))))) e1628) (if (memv t1642 (quote (define-syntax))) ((lambda (tmp1668) ((lambda (tmp1669) (if (if tmp1669 (apply (lambda (_1670 name1671 val1672) (id?1131 name1671)) tmp1669) #f) (apply (lambda (_1673 name1674 val1675) (values (quote define-syntax-form) name1674 val1675 w1630 s1631 mod1633)) tmp1669) (syntax-error tmp1668))) (syntax-dispatch tmp1668 (quote (any any any))))) e1628) (values (quote call) #f e1628 w1630 s1631 mod1633)))))))))))))) (values (quote call) #f e1628 w1630 s1631 mod1633)))) ((syntax-object?1115 e1628) (syntax-type1165 (syntax-object-expression1116 e1628) r1629 (join-wraps1150 w1630 (syntax-object-wrap1117 e1628)) #f rib1632 (or (syntax-object-module1118 e1628) mod1633))) ((annotation? e1628) (syntax-type1165 (annotation-expression e1628) r1629 w1630 (annotation-source e1628) rib1632 mod1633)) ((self-evaluating? e1628) (values (quote constant) #f e1628 w1630 s1631 mod1633)) (else (values (quote other) #f e1628 w1630 s1631 mod1633))))) (chi-when-list1164 (lambda (e1676 when-list1677 w1678) (let f1679 ((when-list1680 when-list1677) (situations1681 (quote ()))) (if (null? when-list1680) situations1681 (f1679 (cdr when-list1680) (cons (let ((x1682 (car when-list1680))) (cond ((free-id=?1154 x1682 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1154 x1682 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1154 x1682 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1159 x1682 w1678 #f) "invalid eval-when situation")))) situations1681)))))) (chi-install-global1163 (lambda (name1683 e1684) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1683) e1684)))) (chi-top-sequence1162 (lambda (body1685 r1686 w1687 s1688 m1689 esew1690 mod1691) (build-sequence1110 s1688 (let dobody1692 ((body1693 body1685) (r1694 r1686) (w1695 w1687) (m1696 m1689) (esew1697 esew1690) (mod1698 mod1691)) (if (null? body1693) (quote ()) (let ((first1699 (chi-top1166 (car body1693) r1694 w1695 m1696 esew1697 mod1698))) (cons first1699 (dobody1692 (cdr body1693) r1694 w1695 m1696 esew1697 mod1698)))))))) (chi-sequence1161 (lambda (body1700 r1701 w1702 s1703 mod1704) (build-sequence1110 s1703 (let dobody1705 ((body1706 body1700) (r1707 r1701) (w1708 w1702) (mod1709 mod1704)) (if (null? body1706) (quote ()) (let ((first1710 (chi1167 (car body1706) r1707 w1708 mod1709))) (cons first1710 (dobody1705 (cdr body1706) r1707 w1708 mod1709)))))))) (source-wrap1160 (lambda (x1711 w1712 s1713 defmod1714) (wrap1159 (if s1713 (make-annotation x1711 s1713 #f) x1711) w1712 defmod1714))) (wrap1159 (lambda (x1715 w1716 defmod1717) (cond ((and (null? (wrap-marks1134 w1716)) (null? (wrap-subst1135 w1716))) x1715) ((syntax-object?1115 x1715) (make-syntax-object1114 (syntax-object-expression1116 x1715) (join-wraps1150 w1716 (syntax-object-wrap1117 x1715)) (syntax-object-module1118 x1715))) ((null? x1715) x1715) (else (make-syntax-object1114 x1715 w1716 defmod1717))))) (bound-id-member?1158 (lambda (x1718 list1719) (and (not (null? list1719)) (or (bound-id=?1155 x1718 (car list1719)) (bound-id-member?1158 x1718 (cdr list1719)))))) (distinct-bound-ids?1157 (lambda (ids1720) (let distinct?1721 ((ids1722 ids1720)) (or (null? ids1722) (and (not (bound-id-member?1158 (car ids1722) (cdr ids1722))) (distinct?1721 (cdr ids1722))))))) (valid-bound-ids?1156 (lambda (ids1723) (and (let all-ids?1724 ((ids1725 ids1723)) (or (null? ids1725) (and (id?1131 (car ids1725)) (all-ids?1724 (cdr ids1725))))) (distinct-bound-ids?1157 ids1723)))) (bound-id=?1155 (lambda (i1726 j1727) (if (and (syntax-object?1115 i1726) (syntax-object?1115 j1727)) (and (eq? (let ((e1728 (syntax-object-expression1116 i1726))) (if (annotation? e1728) (annotation-expression e1728) e1728)) (let ((e1729 (syntax-object-expression1116 j1727))) (if (annotation? e1729) (annotation-expression e1729) e1729))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1726)) (wrap-marks1134 (syntax-object-wrap1117 j1727)))) (eq? (let ((e1730 i1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)) (let ((e1731 j1727)) (if (annotation? e1731) (annotation-expression e1731) e1731)))))) (free-id=?1154 (lambda (i1732 j1733) (and (eq? (let ((x1734 i1732)) (let ((e1735 (if (syntax-object?1115 x1734) (syntax-object-expression1116 x1734) x1734))) (if (annotation? e1735) (annotation-expression e1735) e1735))) (let ((x1736 j1733)) (let ((e1737 (if (syntax-object?1115 x1736) (syntax-object-expression1116 x1736) x1736))) (if (annotation? e1737) (annotation-expression e1737) e1737)))) (eq? (id-var-name1153 i1732 (quote (()))) (id-var-name1153 j1733 (quote (()))))))) (id-var-name1153 (lambda (id1738 w1739) (letrec ((search-vector-rib1742 (lambda (sym1748 subst1749 marks1750 symnames1751 ribcage1752) (let ((n1753 (vector-length symnames1751))) (let f1754 ((i1755 0)) (cond ((fx=1100 i1755 n1753) (search1740 sym1748 (cdr subst1749) marks1750)) ((and (eq? (vector-ref symnames1751 i1755) sym1748) (same-marks?1152 marks1750 (vector-ref (ribcage-marks1141 ribcage1752) i1755))) (values (vector-ref (ribcage-labels1142 ribcage1752) i1755) marks1750)) (else (f1754 (fx+1098 i1755 1)))))))) (search-list-rib1741 (lambda (sym1756 subst1757 marks1758 symnames1759 ribcage1760) (let f1761 ((symnames1762 symnames1759) (i1763 0)) (cond ((null? symnames1762) (search1740 sym1756 (cdr subst1757) marks1758)) ((and (eq? (car symnames1762) sym1756) (same-marks?1152 marks1758 (list-ref (ribcage-marks1141 ribcage1760) i1763))) (values (list-ref (ribcage-labels1142 ribcage1760) i1763) marks1758)) (else (f1761 (cdr symnames1762) (fx+1098 i1763 1))))))) (search1740 (lambda (sym1764 subst1765 marks1766) (if (null? subst1765) (values #f marks1766) (let ((fst1767 (car subst1765))) (if (eq? fst1767 (quote shift)) (search1740 sym1764 (cdr subst1765) (cdr marks1766)) (let ((symnames1768 (ribcage-symnames1140 fst1767))) (if (vector? symnames1768) (search-vector-rib1742 sym1764 subst1765 marks1766 symnames1768 fst1767) (search-list-rib1741 sym1764 subst1765 marks1766 symnames1768 fst1767))))))))) (cond ((symbol? id1738) (or (call-with-values (lambda () (search1740 id1738 (wrap-subst1135 w1739) (wrap-marks1134 w1739))) (lambda (x1770 . ignore1769) x1770)) id1738)) ((syntax-object?1115 id1738) (let ((id1771 (let ((e1773 (syntax-object-expression1116 id1738))) (if (annotation? e1773) (annotation-expression e1773) e1773))) (w11772 (syntax-object-wrap1117 id1738))) (let ((marks1774 (join-marks1151 (wrap-marks1134 w1739) (wrap-marks1134 w11772)))) (call-with-values (lambda () (search1740 id1771 (wrap-subst1135 w1739) marks1774)) (lambda (new-id1775 marks1776) (or new-id1775 (call-with-values (lambda () (search1740 id1771 (wrap-subst1135 w11772) marks1776)) (lambda (x1778 . ignore1777) x1778)) id1771)))))) ((annotation? id1738) (let ((id1779 (let ((e1780 id1738)) (if (annotation? e1780) (annotation-expression e1780) e1780)))) (or (call-with-values (lambda () (search1740 id1779 (wrap-subst1135 w1739) (wrap-marks1134 w1739))) (lambda (x1782 . ignore1781) x1782)) id1779))) (else (error-hook1104 (quote id-var-name) "invalid id" id1738)))))) (same-marks?1152 (lambda (x1783 y1784) (or (eq? x1783 y1784) (and (not (null? x1783)) (not (null? y1784)) (eq? (car x1783) (car y1784)) (same-marks?1152 (cdr x1783) (cdr y1784)))))) (join-marks1151 (lambda (m11785 m21786) (smart-append1149 m11785 m21786))) (join-wraps1150 (lambda (w11787 w21788) (let ((m11789 (wrap-marks1134 w11787)) (s11790 (wrap-subst1135 w11787))) (if (null? m11789) (if (null? s11790) w21788 (make-wrap1133 (wrap-marks1134 w21788) (smart-append1149 s11790 (wrap-subst1135 w21788)))) (make-wrap1133 (smart-append1149 m11789 (wrap-marks1134 w21788)) (smart-append1149 s11790 (wrap-subst1135 w21788))))))) (smart-append1149 (lambda (m11791 m21792) (if (null? m21792) m11791 (append m11791 m21792)))) (make-binding-wrap1148 (lambda (ids1793 labels1794 w1795) (if (null? ids1793) w1795 (make-wrap1133 (wrap-marks1134 w1795) (cons (let ((labelvec1796 (list->vector labels1794))) (let ((n1797 (vector-length labelvec1796))) (let ((symnamevec1798 (make-vector n1797)) (marksvec1799 (make-vector n1797))) (begin (let f1800 ((ids1801 ids1793) (i1802 0)) (if (not (null? ids1801)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1801) w1795)) (lambda (symname1803 marks1804) (begin (vector-set! symnamevec1798 i1802 symname1803) (vector-set! marksvec1799 i1802 marks1804) (f1800 (cdr ids1801) (fx+1098 i1802 1))))))) (make-ribcage1138 symnamevec1798 marksvec1799 labelvec1796))))) (wrap-subst1135 w1795)))))) (extend-ribcage!1147 (lambda (ribcage1805 id1806 label1807) (begin (set-ribcage-symnames!1143 ribcage1805 (cons (let ((e1808 (syntax-object-expression1116 id1806))) (if (annotation? e1808) (annotation-expression e1808) e1808)) (ribcage-symnames1140 ribcage1805))) (set-ribcage-marks!1144 ribcage1805 (cons (wrap-marks1134 (syntax-object-wrap1117 id1806)) (ribcage-marks1141 ribcage1805))) (set-ribcage-labels!1145 ribcage1805 (cons label1807 (ribcage-labels1142 ribcage1805)))))) (anti-mark1146 (lambda (w1809) (make-wrap1133 (cons #f (wrap-marks1134 w1809)) (cons (quote shift) (wrap-subst1135 w1809))))) (set-ribcage-labels!1145 (lambda (x1810 update1811) (vector-set! x1810 3 update1811))) (set-ribcage-marks!1144 (lambda (x1812 update1813) (vector-set! x1812 2 update1813))) (set-ribcage-symnames!1143 (lambda (x1814 update1815) (vector-set! x1814 1 update1815))) (ribcage-labels1142 (lambda (x1816) (vector-ref x1816 3))) (ribcage-marks1141 (lambda (x1817) (vector-ref x1817 2))) (ribcage-symnames1140 (lambda (x1818) (vector-ref x1818 1))) (ribcage?1139 (lambda (x1819) (and (vector? x1819) (= (vector-length x1819) 4) (eq? (vector-ref x1819 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1820 marks1821 labels1822) (vector (quote ribcage) symnames1820 marks1821 labels1822))) (gen-labels1137 (lambda (ls1823) (if (null? ls1823) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1823)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1824 w1825) (if (syntax-object?1115 x1824) (values (let ((e1826 (syntax-object-expression1116 x1824))) (if (annotation? e1826) (annotation-expression e1826) e1826)) (join-marks1151 (wrap-marks1134 w1825) (wrap-marks1134 (syntax-object-wrap1117 x1824)))) (values (let ((e1827 x1824)) (if (annotation? e1827) (annotation-expression e1827) e1827)) (wrap-marks1134 w1825))))) (id?1131 (lambda (x1828) (cond ((symbol? x1828) #t) ((syntax-object?1115 x1828) (symbol? (let ((e1829 (syntax-object-expression1116 x1828))) (if (annotation? e1829) (annotation-expression e1829) e1829)))) ((annotation? x1828) (symbol? (annotation-expression x1828))) (else #f)))) (nonsymbol-id?1130 (lambda (x1830) (and (syntax-object?1115 x1830) (symbol? (let ((e1831 (syntax-object-expression1116 x1830))) (if (annotation? e1831) (annotation-expression e1831) e1831)))))) (global-extend1129 (lambda (type1832 sym1833 val1834) (put-global-definition-hook1105 sym1833 (cons type1832 val1834)))) (lookup1128 (lambda (x1835 r1836 mod1837) (cond ((assq x1835 r1836) => cdr) ((symbol? x1835) (or (get-global-definition-hook1107 x1835 mod1837) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1838) (if (null? r1838) (quote ()) (let ((a1839 (car r1838))) (if (eq? (cadr a1839) (quote macro)) (cons a1839 (macros-only-env1127 (cdr r1838))) (macros-only-env1127 (cdr r1838))))))) (extend-var-env1126 (lambda (labels1840 vars1841 r1842) (if (null? labels1840) r1842 (extend-var-env1126 (cdr labels1840) (cdr vars1841) (cons (cons (car labels1840) (cons (quote lexical) (car vars1841))) r1842))))) (extend-env1125 (lambda (labels1843 bindings1844 r1845) (if (null? labels1843) r1845 (extend-env1125 (cdr labels1843) (cdr bindings1844) (cons (cons (car labels1843) (car bindings1844)) r1845))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1846) (cond ((annotation? x1846) (annotation-source x1846)) ((syntax-object?1115 x1846) (source-annotation1122 (syntax-object-expression1116 x1846))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1847 update1848) (vector-set! x1847 3 update1848))) (set-syntax-object-wrap!1120 (lambda (x1849 update1850) (vector-set! x1849 2 update1850))) (set-syntax-object-expression!1119 (lambda (x1851 update1852) (vector-set! x1851 1 update1852))) (syntax-object-module1118 (lambda (x1853) (vector-ref x1853 3))) (syntax-object-wrap1117 (lambda (x1854) (vector-ref x1854 2))) (syntax-object-expression1116 (lambda (x1855) (vector-ref x1855 1))) (syntax-object?1115 (lambda (x1856) (and (vector? x1856) (= (vector-length x1856) 4) (eq? (vector-ref x1856 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1857 wrap1858 module1859) (vector (quote syntax-object) expression1857 wrap1858 module1859))) (build-letrec1113 (lambda (src1860 vars1861 val-exps1862 body-exp1863) (if (null? vars1861) (build-annotated1108 src1860 body-exp1863) (build-annotated1108 src1860 (list (quote letrec) (map list vars1861 val-exps1862) body-exp1863))))) (build-named-let1112 (lambda (src1864 vars1865 val-exps1866 body-exp1867) (if (null? vars1865) (build-annotated1108 src1864 body-exp1867) (build-annotated1108 src1864 (list (quote let) (car vars1865) (map list (cdr vars1865) val-exps1866) body-exp1867))))) (build-let1111 (lambda (src1868 vars1869 val-exps1870 body-exp1871) (if (null? vars1869) (build-annotated1108 src1868 body-exp1871) (build-annotated1108 src1868 (list (quote let) (map list vars1869 val-exps1870) body-exp1871))))) (build-sequence1110 (lambda (src1872 exps1873) (if (null? (cdr exps1873)) (build-annotated1108 src1872 (car exps1873)) (build-annotated1108 src1872 (cons (quote begin) exps1873))))) (build-data1109 (lambda (src1874 exp1875) (if (and (self-evaluating? exp1875) (not (vector? exp1875))) (build-annotated1108 src1874 exp1875) (build-annotated1108 src1874 (list (quote quote) exp1875))))) (build-annotated1108 (lambda (src1876 exp1877) (if (and src1876 (not (annotation? exp1877))) (make-annotation exp1877 src1876 #t) exp1877))) (get-global-definition-hook1107 (lambda (symbol1878 module1879) (let ((module1880 (if module1879 (resolve-module (cdr module1879)) (let ((mod1881 (current-module))) (begin (if mod1881 (warn "wha" symbol1878)) mod1881))))) (let ((v1882 (module-variable module1880 symbol1878))) (and v1882 (object-property v1882 (quote *sc-expander*))))))) (remove-global-definition-hook1106 (lambda (symbol1883) (let ((module1884 (current-module))) (let ((v1885 (module-local-variable module1884 symbol1883))) (if v1885 (let ((p1886 (assq (quote *sc-expander*) (object-properties v1885)))) (set-object-properties! v1885 (delq p1886 (object-properties v1885))))))))) (put-global-definition-hook1105 (lambda (symbol1887 binding1888) (let ((module1889 (current-module))) (let ((v1890 (or (module-variable module1889 symbol1887) (let ((v1891 (make-variable (gensym)))) (begin (module-add! module1889 symbol1887 v1891) v1891))))) (begin (if (not (variable-bound? v1890)) (variable-set! v1890 (gensym))) (set-object-property! v1890 (quote *sc-expander*) binding1888)))))) (error-hook1104 (lambda (who1892 why1893 what1894) (error who1892 "~a ~s" why1893 what1894))) (local-eval-hook1103 (lambda (x1895 mod1896) (primitive-eval (list noexpand1097 x1895)))) (top-level-eval-hook1102 (lambda (x1897 mod1898) (primitive-eval (list noexpand1097 x1897)))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1899 r1900 w1901 s1902 mod1903) ((lambda (tmp1904) ((lambda (tmp1905) (if (if tmp1905 (apply (lambda (_1906 var1907 val1908 e11909 e21910) (valid-bound-ids?1156 var1907)) tmp1905) #f) (apply (lambda (_1912 var1913 val1914 e11915 e21916) (let ((names1917 (map (lambda (x1918) (id-var-name1153 x1918 w1901)) var1913))) (begin (for-each (lambda (id1920 n1921) (let ((t1922 (binding-type1123 (lookup1128 n1921 r1900 mod1903)))) (if (memv t1922 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1920 w1901 s1902 mod1903) "identifier out of context")))) var1913 names1917) (chi-body1171 (cons e11915 e21916) (source-wrap1160 e1899 w1901 s1902 mod1903) (extend-env1125 names1917 (let ((trans-r1925 (macros-only-env1127 r1900))) (map (lambda (x1926) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1926 trans-r1925 w1901 mod1903) mod1903))) val1914)) r1900) w1901 mod1903)))) tmp1905) ((lambda (_1928) (syntax-error (source-wrap1160 e1899 w1901 s1902 mod1903))) tmp1904))) (syntax-dispatch tmp1904 (quote (any #(each (any any)) any . each-any))))) e1899))) (global-extend1129 (quote core) (quote quote) (lambda (e1929 r1930 w1931 s1932 mod1933) ((lambda (tmp1934) ((lambda (tmp1935) (if tmp1935 (apply (lambda (_1936 e1937) (build-data1109 s1932 (strip1178 e1937 w1931))) tmp1935) ((lambda (_1938) (syntax-error (source-wrap1160 e1929 w1931 s1932 mod1933))) tmp1934))) (syntax-dispatch tmp1934 (quote (any any))))) e1929))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1946 (lambda (x1947) (let ((t1948 (car x1947))) (if (memv t1948 (quote (ref))) (build-annotated1108 #f (cadr x1947)) (if (memv t1948 (quote (primitive))) (build-annotated1108 #f (cadr x1947)) (if (memv t1948 (quote (quote))) (build-data1109 #f (cadr x1947)) (if (memv t1948 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1947) (regen1946 (caddr x1947)))) (if (memv t1948 (quote (map))) (let ((ls1949 (map regen1946 (cdr x1947)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1949) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1949))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1947)) (map regen1946 (cdr x1947)))))))))))) (gen-vector1945 (lambda (x1950) (cond ((eq? (car x1950) (quote list)) (cons (quote vector) (cdr x1950))) ((eq? (car x1950) (quote quote)) (list (quote quote) (list->vector (cadr x1950)))) (else (list (quote list->vector) x1950))))) (gen-append1944 (lambda (x1951 y1952) (if (equal? y1952 (quote (quote ()))) x1951 (list (quote append) x1951 y1952)))) (gen-cons1943 (lambda (x1953 y1954) (let ((t1955 (car y1954))) (if (memv t1955 (quote (quote))) (if (eq? (car x1953) (quote quote)) (list (quote quote) (cons (cadr x1953) (cadr y1954))) (if (eq? (cadr y1954) (quote ())) (list (quote list) x1953) (list (quote cons) x1953 y1954))) (if (memv t1955 (quote (list))) (cons (quote list) (cons x1953 (cdr y1954))) (list (quote cons) x1953 y1954)))))) (gen-map1942 (lambda (e1956 map-env1957) (let ((formals1958 (map cdr map-env1957)) (actuals1959 (map (lambda (x1960) (list (quote ref) (car x1960))) map-env1957))) (cond ((eq? (car e1956) (quote ref)) (car actuals1959)) ((andmap (lambda (x1961) (and (eq? (car x1961) (quote ref)) (memq (cadr x1961) formals1958))) (cdr e1956)) (cons (quote map) (cons (list (quote primitive) (car e1956)) (map (let ((r1962 (map cons formals1958 actuals1959))) (lambda (x1963) (cdr (assq (cadr x1963) r1962)))) (cdr e1956))))) (else (cons (quote map) (cons (list (quote lambda) formals1958 e1956) actuals1959))))))) (gen-mappend1941 (lambda (e1964 map-env1965) (list (quote apply) (quote (primitive append)) (gen-map1942 e1964 map-env1965)))) (gen-ref1940 (lambda (src1966 var1967 level1968 maps1969) (if (fx=1100 level1968 0) (values var1967 maps1969) (if (null? maps1969) (syntax-error src1966 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1940 src1966 var1967 (fx-1099 level1968 1) (cdr maps1969))) (lambda (outer-var1970 outer-maps1971) (let ((b1972 (assq outer-var1970 (car maps1969)))) (if b1972 (values (cdr b1972) maps1969) (let ((inner-var1973 (gen-var1179 (quote tmp)))) (values inner-var1973 (cons (cons (cons outer-var1970 inner-var1973) (car maps1969)) outer-maps1971))))))))))) (gen-syntax1939 (lambda (src1974 e1975 r1976 maps1977 ellipsis?1978 mod1979) (if (id?1131 e1975) (let ((label1980 (id-var-name1153 e1975 (quote (()))))) (let ((b1981 (lookup1128 label1980 r1976 mod1979))) (if (eq? (binding-type1123 b1981) (quote syntax)) (call-with-values (lambda () (let ((var.lev1982 (binding-value1124 b1981))) (gen-ref1940 src1974 (car var.lev1982) (cdr var.lev1982) maps1977))) (lambda (var1983 maps1984) (values (list (quote ref) var1983) maps1984))) (if (ellipsis?1978 e1975) (syntax-error src1974 "misplaced ellipsis in syntax form") (values (list (quote quote) e1975) maps1977))))) ((lambda (tmp1985) ((lambda (tmp1986) (if (if tmp1986 (apply (lambda (dots1987 e1988) (ellipsis?1978 dots1987)) tmp1986) #f) (apply (lambda (dots1989 e1990) (gen-syntax1939 src1974 e1990 r1976 maps1977 (lambda (x1991) #f) mod1979)) tmp1986) ((lambda (tmp1992) (if (if tmp1992 (apply (lambda (x1993 dots1994 y1995) (ellipsis?1978 dots1994)) tmp1992) #f) (apply (lambda (x1996 dots1997 y1998) (let f1999 ((y2000 y1998) (k2001 (lambda (maps2002) (call-with-values (lambda () (gen-syntax1939 src1974 x1996 r1976 (cons (quote ()) maps2002) ellipsis?1978 mod1979)) (lambda (x2003 maps2004) (if (null? (car maps2004)) (syntax-error src1974 "extra ellipsis in syntax form") (values (gen-map1942 x2003 (car maps2004)) (cdr maps2004)))))))) ((lambda (tmp2005) ((lambda (tmp2006) (if (if tmp2006 (apply (lambda (dots2007 y2008) (ellipsis?1978 dots2007)) tmp2006) #f) (apply (lambda (dots2009 y2010) (f1999 y2010 (lambda (maps2011) (call-with-values (lambda () (k2001 (cons (quote ()) maps2011))) (lambda (x2012 maps2013) (if (null? (car maps2013)) (syntax-error src1974 "extra ellipsis in syntax form") (values (gen-mappend1941 x2012 (car maps2013)) (cdr maps2013)))))))) tmp2006) ((lambda (_2014) (call-with-values (lambda () (gen-syntax1939 src1974 y2000 r1976 maps1977 ellipsis?1978 mod1979)) (lambda (y2015 maps2016) (call-with-values (lambda () (k2001 maps2016)) (lambda (x2017 maps2018) (values (gen-append1944 x2017 y2015) maps2018)))))) tmp2005))) (syntax-dispatch tmp2005 (quote (any . any))))) y2000))) tmp1992) ((lambda (tmp2019) (if tmp2019 (apply (lambda (x2020 y2021) (call-with-values (lambda () (gen-syntax1939 src1974 x2020 r1976 maps1977 ellipsis?1978 mod1979)) (lambda (x2022 maps2023) (call-with-values (lambda () (gen-syntax1939 src1974 y2021 r1976 maps2023 ellipsis?1978 mod1979)) (lambda (y2024 maps2025) (values (gen-cons1943 x2022 y2024) maps2025)))))) tmp2019) ((lambda (tmp2026) (if tmp2026 (apply (lambda (e12027 e22028) (call-with-values (lambda () (gen-syntax1939 src1974 (cons e12027 e22028) r1976 maps1977 ellipsis?1978 mod1979)) (lambda (e2030 maps2031) (values (gen-vector1945 e2030) maps2031)))) tmp2026) ((lambda (_2032) (values (list (quote quote) e1975) maps1977)) tmp1985))) (syntax-dispatch tmp1985 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1985 (quote (any . any)))))) (syntax-dispatch tmp1985 (quote (any any . any)))))) (syntax-dispatch tmp1985 (quote (any any))))) e1975))))) (lambda (e2033 r2034 w2035 s2036 mod2037) (let ((e2038 (source-wrap1160 e2033 w2035 s2036 mod2037))) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 x2042) (call-with-values (lambda () (gen-syntax1939 e2038 x2042 r2034 (quote ()) ellipsis?1176 mod2037)) (lambda (e2043 maps2044) (regen1946 e2043)))) tmp2040) ((lambda (_2045) (syntax-error e2038)) tmp2039))) (syntax-dispatch tmp2039 (quote (any any))))) e2038))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2046 r2047 w2048 s2049 mod2050) ((lambda (tmp2051) ((lambda (tmp2052) (if tmp2052 (apply (lambda (_2053 c2054) (chi-lambda-clause1172 (source-wrap1160 e2046 w2048 s2049 mod2050) c2054 r2047 w2048 mod2050 (lambda (vars2055 body2056) (build-annotated1108 s2049 (list (quote lambda) vars2055 body2056))))) tmp2052) (syntax-error tmp2051))) (syntax-dispatch tmp2051 (quote (any . any))))) e2046))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2057 (lambda (e2058 r2059 w2060 s2061 mod2062 constructor2063 ids2064 vals2065 exps2066) (if (not (valid-bound-ids?1156 ids2064)) (syntax-error e2058 "duplicate bound variable in") (let ((labels2067 (gen-labels1137 ids2064)) (new-vars2068 (map gen-var1179 ids2064))) (let ((nw2069 (make-binding-wrap1148 ids2064 labels2067 w2060)) (nr2070 (extend-var-env1126 labels2067 new-vars2068 r2059))) (constructor2063 s2061 new-vars2068 (map (lambda (x2071) (chi1167 x2071 r2059 w2060 mod2062)) vals2065) (chi-body1171 exps2066 (source-wrap1160 e2058 nw2069 s2061 mod2062) nr2070 nw2069 mod2062)))))))) (lambda (e2072 r2073 w2074 s2075 mod2076) ((lambda (tmp2077) ((lambda (tmp2078) (if tmp2078 (apply (lambda (_2079 id2080 val2081 e12082 e22083) (chi-let2057 e2072 r2073 w2074 s2075 mod2076 build-let1111 id2080 val2081 (cons e12082 e22083))) tmp2078) ((lambda (tmp2087) (if (if tmp2087 (apply (lambda (_2088 f2089 id2090 val2091 e12092 e22093) (id?1131 f2089)) tmp2087) #f) (apply (lambda (_2094 f2095 id2096 val2097 e12098 e22099) (chi-let2057 e2072 r2073 w2074 s2075 mod2076 build-named-let1112 (cons f2095 id2096) val2097 (cons e12098 e22099))) tmp2087) ((lambda (_2103) (syntax-error (source-wrap1160 e2072 w2074 s2075 mod2076))) tmp2077))) (syntax-dispatch tmp2077 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2077 (quote (any #(each (any any)) any . each-any))))) e2072)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2104 r2105 w2106 s2107 mod2108) ((lambda (tmp2109) ((lambda (tmp2110) (if tmp2110 (apply (lambda (_2111 id2112 val2113 e12114 e22115) (let ((ids2116 id2112)) (if (not (valid-bound-ids?1156 ids2116)) (syntax-error e2104 "duplicate bound variable in") (let ((labels2118 (gen-labels1137 ids2116)) (new-vars2119 (map gen-var1179 ids2116))) (let ((w2120 (make-binding-wrap1148 ids2116 labels2118 w2106)) (r2121 (extend-var-env1126 labels2118 new-vars2119 r2105))) (build-letrec1113 s2107 new-vars2119 (map (lambda (x2122) (chi1167 x2122 r2121 w2120 mod2108)) val2113) (chi-body1171 (cons e12114 e22115) (source-wrap1160 e2104 w2120 s2107 mod2108) r2121 w2120 mod2108))))))) tmp2110) ((lambda (_2125) (syntax-error (source-wrap1160 e2104 w2106 s2107 mod2108))) tmp2109))) (syntax-dispatch tmp2109 (quote (any #(each (any any)) any . each-any))))) e2104))) (global-extend1129 (quote core) (quote set!) (lambda (e2126 r2127 w2128 s2129 mod2130) ((lambda (tmp2131) ((lambda (tmp2132) (if (if tmp2132 (apply (lambda (_2133 id2134 val2135) (id?1131 id2134)) tmp2132) #f) (apply (lambda (_2136 id2137 val2138) (let ((val2139 (chi1167 val2138 r2127 w2128 mod2130)) (n2140 (id-var-name1153 id2137 w2128))) (let ((b2141 (lookup1128 n2140 r2127 mod2130))) (let ((t2142 (binding-type1123 b2141))) (if (memv t2142 (quote (lexical))) (build-annotated1108 s2129 (list (quote set!) (binding-value1124 b2141) val2139)) (if (memv t2142 (quote (global))) (build-annotated1108 s2129 (list (quote set!) (if mod2130 (make-module-ref (cdr mod2130) n2140 (car mod2130)) (make-module-ref mod2130 n2140 (quote bare))) val2139)) (if (memv t2142 (quote (displaced-lexical))) (syntax-error (wrap1159 id2137 w2128 mod2130) "identifier out of context") (syntax-error (source-wrap1160 e2126 w2128 s2129 mod2130))))))))) tmp2132) ((lambda (tmp2143) (if tmp2143 (apply (lambda (_2144 head2145 tail2146 val2147) (call-with-values (lambda () (syntax-type1165 head2145 r2127 (quote (())) #f #f mod2130)) (lambda (type2148 value2149 ee2150 ww2151 ss2152 modmod2153) (let ((t2154 type2148)) (if (memv t2154 (quote (module-ref))) (let ((val2155 (chi1167 val2147 r2127 w2128 mod2130))) (call-with-values (lambda () (value2149 (cons head2145 tail2146))) (lambda (id2157 mod2158) (build-annotated1108 s2129 (list (quote set!) (if mod2158 (make-module-ref (cdr mod2158) id2157 (car mod2158)) (make-module-ref mod2158 id2157 (quote bare))) val2155))))) (build-annotated1108 s2129 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2145) r2127 w2128 mod2130) (map (lambda (e2159) (chi1167 e2159 r2127 w2128 mod2130)) (append tail2146 (list val2147)))))))))) tmp2143) ((lambda (_2161) (syntax-error (source-wrap1160 e2126 w2128 s2129 mod2130))) tmp2131))) (syntax-dispatch tmp2131 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2131 (quote (any any any))))) e2126))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2162) ((lambda (tmp2163) ((lambda (tmp2164) (if (if tmp2164 (apply (lambda (_2165 mod2166 id2167) (and (andmap id?1131 mod2166) (id?1131 id2167))) tmp2164) #f) (apply (lambda (_2169 mod2170 id2171) (values (syntax-object->datum id2171) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2170)))) tmp2164) (syntax-error tmp2163))) (syntax-dispatch tmp2163 (quote (any each-any any))))) e2162))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2173) ((lambda (tmp2174) ((lambda (tmp2175) (if (if tmp2175 (apply (lambda (_2176 mod2177 id2178) (and (andmap id?1131 mod2177) (id?1131 id2178))) tmp2175) #f) (apply (lambda (_2180 mod2181 id2182) (values (syntax-object->datum id2182) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2181)))) tmp2175) (syntax-error tmp2174))) (syntax-dispatch tmp2174 (quote (any each-any any))))) e2173))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2187 (lambda (x2188 keys2189 clauses2190 r2191 mod2192) (if (null? clauses2190) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2188)) ((lambda (tmp2193) ((lambda (tmp2194) (if tmp2194 (apply (lambda (pat2195 exp2196) (if (and (id?1131 pat2195) (andmap (lambda (x2197) (not (free-id=?1154 pat2195 x2197))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2189))) (let ((labels2198 (list (gen-label1136))) (var2199 (gen-var1179 pat2195))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2199) (chi1167 exp2196 (extend-env1125 labels2198 (list (cons (quote syntax) (cons var2199 0))) r2191) (make-binding-wrap1148 (list pat2195) labels2198 (quote (()))) mod2192))) x2188))) (gen-clause2186 x2188 keys2189 (cdr clauses2190) r2191 pat2195 #t exp2196 mod2192))) tmp2194) ((lambda (tmp2200) (if tmp2200 (apply (lambda (pat2201 fender2202 exp2203) (gen-clause2186 x2188 keys2189 (cdr clauses2190) r2191 pat2201 fender2202 exp2203 mod2192)) tmp2200) ((lambda (_2204) (syntax-error (car clauses2190) "invalid syntax-case clause")) tmp2193))) (syntax-dispatch tmp2193 (quote (any any any)))))) (syntax-dispatch tmp2193 (quote (any any))))) (car clauses2190))))) (gen-clause2186 (lambda (x2205 keys2206 clauses2207 r2208 pat2209 fender2210 exp2211 mod2212) (call-with-values (lambda () (convert-pattern2184 pat2209 keys2206)) (lambda (p2213 pvars2214) (cond ((not (distinct-bound-ids?1157 (map car pvars2214))) (syntax-error pat2209 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2215) (not (ellipsis?1176 (car x2215)))) pvars2214)) (syntax-error pat2209 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2216 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2216) (let ((y2217 (build-annotated1108 #f y2216))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2218) ((lambda (tmp2219) (if tmp2219 (apply (lambda () y2217) tmp2219) ((lambda (_2220) (build-annotated1108 #f (list (quote if) y2217 (build-dispatch-call2185 pvars2214 fender2210 y2217 r2208 mod2212) (build-data1109 #f #f)))) tmp2218))) (syntax-dispatch tmp2218 (quote #(atom #t))))) fender2210) (build-dispatch-call2185 pvars2214 exp2211 y2217 r2208 mod2212) (gen-syntax-case2187 x2205 keys2206 clauses2207 r2208 mod2212)))))) (if (eq? p2213 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2205)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2205 (build-data1109 #f p2213))))))))))))) (build-dispatch-call2185 (lambda (pvars2221 exp2222 y2223 r2224 mod2225) (let ((ids2226 (map car pvars2221)) (levels2227 (map cdr pvars2221))) (let ((labels2228 (gen-labels1137 ids2226)) (new-vars2229 (map gen-var1179 ids2226))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2229 (chi1167 exp2222 (extend-env1125 labels2228 (map (lambda (var2230 level2231) (cons (quote syntax) (cons var2230 level2231))) new-vars2229 (map cdr pvars2221)) r2224) (make-binding-wrap1148 ids2226 labels2228 (quote (()))) mod2225))) y2223)))))) (convert-pattern2184 (lambda (pattern2232 keys2233) (let cvt2234 ((p2235 pattern2232) (n2236 0) (ids2237 (quote ()))) (if (id?1131 p2235) (if (bound-id-member?1158 p2235 keys2233) (values (vector (quote free-id) p2235) ids2237) (values (quote any) (cons (cons p2235 n2236) ids2237))) ((lambda (tmp2238) ((lambda (tmp2239) (if (if tmp2239 (apply (lambda (x2240 dots2241) (ellipsis?1176 dots2241)) tmp2239) #f) (apply (lambda (x2242 dots2243) (call-with-values (lambda () (cvt2234 x2242 (fx+1098 n2236 1) ids2237)) (lambda (p2244 ids2245) (values (if (eq? p2244 (quote any)) (quote each-any) (vector (quote each) p2244)) ids2245)))) tmp2239) ((lambda (tmp2246) (if tmp2246 (apply (lambda (x2247 y2248) (call-with-values (lambda () (cvt2234 y2248 n2236 ids2237)) (lambda (y2249 ids2250) (call-with-values (lambda () (cvt2234 x2247 n2236 ids2250)) (lambda (x2251 ids2252) (values (cons x2251 y2249) ids2252)))))) tmp2246) ((lambda (tmp2253) (if tmp2253 (apply (lambda () (values (quote ()) ids2237)) tmp2253) ((lambda (tmp2254) (if tmp2254 (apply (lambda (x2255) (call-with-values (lambda () (cvt2234 x2255 n2236 ids2237)) (lambda (p2257 ids2258) (values (vector (quote vector) p2257) ids2258)))) tmp2254) ((lambda (x2259) (values (vector (quote atom) (strip1178 p2235 (quote (())))) ids2237)) tmp2238))) (syntax-dispatch tmp2238 (quote #(vector each-any)))))) (syntax-dispatch tmp2238 (quote ()))))) (syntax-dispatch tmp2238 (quote (any . any)))))) (syntax-dispatch tmp2238 (quote (any any))))) p2235)))))) (lambda (e2260 r2261 w2262 s2263 mod2264) (let ((e2265 (source-wrap1160 e2260 w2262 s2263 mod2264))) ((lambda (tmp2266) ((lambda (tmp2267) (if tmp2267 (apply (lambda (_2268 val2269 key2270 m2271) (if (andmap (lambda (x2272) (and (id?1131 x2272) (not (ellipsis?1176 x2272)))) key2270) (let ((x2274 (gen-var1179 (quote tmp)))) (build-annotated1108 s2263 (list (build-annotated1108 #f (list (quote lambda) (list x2274) (gen-syntax-case2187 (build-annotated1108 #f x2274) key2270 m2271 r2261 mod2264))) (chi1167 val2269 r2261 (quote (())) mod2264)))) (syntax-error e2265 "invalid literals list in"))) tmp2267) (syntax-error tmp2266))) (syntax-dispatch tmp2266 (quote (any any each-any . each-any))))) e2265))))) (set! sc-expand (let ((m2277 (quote e)) (esew2278 (quote (eval)))) (lambda (x2279) (if (and (pair? x2279) (equal? (car x2279) noexpand1097)) (cadr x2279) (chi-top1166 x2279 (quote ()) (quote ((top))) m2277 esew2278 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2280 (quote e)) (esew2281 (quote (eval)))) (lambda (x2283 . rest2282) (if (and (pair? x2283) (equal? (car x2283) noexpand1097)) (cadr x2283) (chi-top1166 x2283 (quote ()) (quote ((top))) (if (null? rest2282) m2280 (car rest2282)) (if (or (null? rest2282) (null? (cdr rest2282))) esew2281 (cadr rest2282)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2284) (nonsymbol-id?1130 x2284))) (set! datum->syntax-object (lambda (id2285 datum2286) (make-syntax-object1114 datum2286 (syntax-object-wrap1117 id2285) #f))) (set! syntax-object->datum (lambda (x2287) (strip1178 x2287 (quote (()))))) (set! generate-temporaries (lambda (ls2288) (begin (let ((x2289 ls2288)) (if (not (list? x2289)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2289))) (map (lambda (x2290) (wrap1159 (gensym) (quote ((top))) #f)) ls2288)))) (set! free-identifier=? (lambda (x2291 y2292) (begin (let ((x2293 x2291)) (if (not (nonsymbol-id?1130 x2293)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2293))) (let ((x2294 y2292)) (if (not (nonsymbol-id?1130 x2294)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2294))) (free-id=?1154 x2291 y2292)))) (set! bound-identifier=? (lambda (x2295 y2296) (begin (let ((x2297 x2295)) (if (not (nonsymbol-id?1130 x2297)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2297))) (let ((x2298 y2296)) (if (not (nonsymbol-id?1130 x2298)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2298))) (bound-id=?1155 x2295 y2296)))) (set! syntax-error (lambda (object2300 . messages2299) (begin (for-each (lambda (x2301) (let ((x2302 x2301)) (if (not (string? x2302)) (error-hook1104 (quote syntax-error) "invalid argument" x2302)))) messages2299) (let ((message2303 (if (null? messages2299) "invalid syntax" (apply string-append messages2299)))) (error-hook1104 #f message2303 (strip1178 object2300 (quote (())))))))) (set! install-global-transformer (lambda (sym2304 v2305) (begin (let ((x2306 sym2304)) (if (not (symbol? x2306)) (error-hook1104 (quote define-syntax) "invalid argument" x2306))) (let ((x2307 v2305)) (if (not (procedure? x2307)) (error-hook1104 (quote define-syntax) "invalid argument" x2307))) (global-extend1129 (quote macro) sym2304 v2305)))) (letrec ((match2312 (lambda (e2313 p2314 w2315 r2316 mod2317) (cond ((not r2316) #f) ((eq? p2314 (quote any)) (cons (wrap1159 e2313 w2315 mod2317) r2316)) ((syntax-object?1115 e2313) (match*2311 (let ((e2318 (syntax-object-expression1116 e2313))) (if (annotation? e2318) (annotation-expression e2318) e2318)) p2314 (join-wraps1150 w2315 (syntax-object-wrap1117 e2313)) r2316 (syntax-object-module1118 e2313))) (else (match*2311 (let ((e2319 e2313)) (if (annotation? e2319) (annotation-expression e2319) e2319)) p2314 w2315 r2316 mod2317))))) (match*2311 (lambda (e2320 p2321 w2322 r2323 mod2324) (cond ((null? p2321) (and (null? e2320) r2323)) ((pair? p2321) (and (pair? e2320) (match2312 (car e2320) (car p2321) w2322 (match2312 (cdr e2320) (cdr p2321) w2322 r2323 mod2324) mod2324))) ((eq? p2321 (quote each-any)) (let ((l2325 (match-each-any2309 e2320 w2322 mod2324))) (and l2325 (cons l2325 r2323)))) (else (let ((t2326 (vector-ref p2321 0))) (if (memv t2326 (quote (each))) (if (null? e2320) (match-empty2310 (vector-ref p2321 1) r2323) (let ((l2327 (match-each2308 e2320 (vector-ref p2321 1) w2322 mod2324))) (and l2327 (let collect2328 ((l2329 l2327)) (if (null? (car l2329)) r2323 (cons (map car l2329) (collect2328 (map cdr l2329)))))))) (if (memv t2326 (quote (free-id))) (and (id?1131 e2320) (free-id=?1154 (wrap1159 e2320 w2322 mod2324) (vector-ref p2321 1)) r2323) (if (memv t2326 (quote (atom))) (and (equal? (vector-ref p2321 1) (strip1178 e2320 w2322)) r2323) (if (memv t2326 (quote (vector))) (and (vector? e2320) (match2312 (vector->list e2320) (vector-ref p2321 1) w2322 r2323 mod2324))))))))))) (match-empty2310 (lambda (p2330 r2331) (cond ((null? p2330) r2331) ((eq? p2330 (quote any)) (cons (quote ()) r2331)) ((pair? p2330) (match-empty2310 (car p2330) (match-empty2310 (cdr p2330) r2331))) ((eq? p2330 (quote each-any)) (cons (quote ()) r2331)) (else (let ((t2332 (vector-ref p2330 0))) (if (memv t2332 (quote (each))) (match-empty2310 (vector-ref p2330 1) r2331) (if (memv t2332 (quote (free-id atom))) r2331 (if (memv t2332 (quote (vector))) (match-empty2310 (vector-ref p2330 1) r2331))))))))) (match-each-any2309 (lambda (e2333 w2334 mod2335) (cond ((annotation? e2333) (match-each-any2309 (annotation-expression e2333) w2334 mod2335)) ((pair? e2333) (let ((l2336 (match-each-any2309 (cdr e2333) w2334 mod2335))) (and l2336 (cons (wrap1159 (car e2333) w2334 mod2335) l2336)))) ((null? e2333) (quote ())) ((syntax-object?1115 e2333) (match-each-any2309 (syntax-object-expression1116 e2333) (join-wraps1150 w2334 (syntax-object-wrap1117 e2333)) mod2335)) (else #f)))) (match-each2308 (lambda (e2337 p2338 w2339 mod2340) (cond ((annotation? e2337) (match-each2308 (annotation-expression e2337) p2338 w2339 mod2340)) ((pair? e2337) (let ((first2341 (match2312 (car e2337) p2338 w2339 (quote ()) mod2340))) (and first2341 (let ((rest2342 (match-each2308 (cdr e2337) p2338 w2339 mod2340))) (and rest2342 (cons first2341 rest2342)))))) ((null? e2337) (quote ())) ((syntax-object?1115 e2337) (match-each2308 (syntax-object-expression1116 e2337) p2338 (join-wraps1150 w2339 (syntax-object-wrap1117 e2337)) (syntax-object-module1118 e2337))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2343 p2344) (cond ((eq? p2344 (quote any)) (list e2343)) ((syntax-object?1115 e2343) (match*2311 (let ((e2345 (syntax-object-expression1116 e2343))) (if (annotation? e2345) (annotation-expression e2345) e2345)) p2344 (syntax-object-wrap1117 e2343) (quote ()) (syntax-object-module1118 e2343))) (else (match*2311 (let ((e2346 e2343)) (if (annotation? e2346) (annotation-expression e2346) e2346)) p2344 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) +(install-global-transformer (quote with-syntax) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if tmp2349 (apply (lambda (_2350 e12351 e22352) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12351 e22352))) tmp2349) ((lambda (tmp2354) (if tmp2354 (apply (lambda (_2355 out2356 in2357 e12358 e22359) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2357 (quote ()) (list out2356 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12358 e22359))))) tmp2354) ((lambda (tmp2361) (if tmp2361 (apply (lambda (_2362 out2363 in2364 e12365 e22366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2364) (quote ()) (list out2363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12365 e22366))))) tmp2361) (syntax-error tmp2348))) (syntax-dispatch tmp2348 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2348 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2348 (quote (any () any . each-any))))) x2347))) +(install-global-transformer (quote syntax-rules) (lambda (x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 k2374 keyword2375 pattern2376 template2377) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2374 (map (lambda (tmp2380 tmp2379) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2379) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2380))) template2377 pattern2376)))))) tmp2372) (syntax-error tmp2371))) (syntax-dispatch tmp2371 (quote (any each-any . #(each ((any . any) any))))))) x2370))) +(install-global-transformer (quote let*) (lambda (x2381) ((lambda (tmp2382) ((lambda (tmp2383) (if (if tmp2383 (apply (lambda (let*2384 x2385 v2386 e12387 e22388) (andmap identifier? x2385)) tmp2383) #f) (apply (lambda (let*2390 x2391 v2392 e12393 e22394) (let f2395 ((bindings2396 (map list x2391 v2392))) (if (null? bindings2396) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12393 e22394))) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply (lambda (body2402 binding2403) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2403) body2402)) tmp2401) (syntax-error tmp2400))) (syntax-dispatch tmp2400 (quote (any any))))) (list (f2395 (cdr bindings2396)) (car bindings2396)))))) tmp2383) (syntax-error tmp2382))) (syntax-dispatch tmp2382 (quote (any #(each (any any)) any . each-any))))) x2381))) +(install-global-transformer (quote do) (lambda (orig-x2404) ((lambda (tmp2405) ((lambda (tmp2406) (if tmp2406 (apply (lambda (_2407 var2408 init2409 step2410 e02411 e12412 c2413) ((lambda (tmp2414) ((lambda (tmp2415) (if tmp2415 (apply (lambda (step2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2408 init2409) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02411) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2416))))))) tmp2418) ((lambda (tmp2423) (if tmp2423 (apply (lambda (e12424 e22425) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2408 init2409) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02411 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12424 e22425)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2416))))))) tmp2423) (syntax-error tmp2417))) (syntax-dispatch tmp2417 (quote (any . each-any)))))) (syntax-dispatch tmp2417 (quote ())))) e12412)) tmp2415) (syntax-error tmp2414))) (syntax-dispatch tmp2414 (quote each-any)))) (map (lambda (v2432 s2433) ((lambda (tmp2434) ((lambda (tmp2435) (if tmp2435 (apply (lambda () v2432) tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda (e2437) e2437) tmp2436) ((lambda (_2438) (syntax-error orig-x2404)) tmp2434))) (syntax-dispatch tmp2434 (quote (any)))))) (syntax-dispatch tmp2434 (quote ())))) s2433)) var2408 step2410))) tmp2406) (syntax-error tmp2405))) (syntax-dispatch tmp2405 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2404))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2441 (lambda (x2445 y2446) ((lambda (tmp2447) ((lambda (tmp2448) (if tmp2448 (apply (lambda (x2449 y2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (dy2453) ((lambda (tmp2454) ((lambda (tmp2455) (if tmp2455 (apply (lambda (dx2456) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2456 dy2453))) tmp2455) ((lambda (_2457) (if (null? dy2453) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2449) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2449 y2450))) tmp2454))) (syntax-dispatch tmp2454 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2449)) tmp2452) ((lambda (tmp2458) (if tmp2458 (apply (lambda (stuff2459) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2449 stuff2459))) tmp2458) ((lambda (else2460) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2449 y2450)) tmp2451))) (syntax-dispatch tmp2451 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2451 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2450)) tmp2448) (syntax-error tmp2447))) (syntax-dispatch tmp2447 (quote (any any))))) (list x2445 y2446)))) (quasiappend2442 (lambda (x2461 y2462) ((lambda (tmp2463) ((lambda (tmp2464) (if tmp2464 (apply (lambda (x2465 y2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda () x2465) tmp2468) ((lambda (_2469) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2465 y2466)) tmp2467))) (syntax-dispatch tmp2467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2466)) tmp2464) (syntax-error tmp2463))) (syntax-dispatch tmp2463 (quote (any any))))) (list x2461 y2462)))) (quasivector2443 (lambda (x2470) ((lambda (tmp2471) ((lambda (x2472) ((lambda (tmp2473) ((lambda (tmp2474) (if tmp2474 (apply (lambda (x2475) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2475))) tmp2474) ((lambda (tmp2477) (if tmp2477 (apply (lambda (x2478) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2478)) tmp2477) ((lambda (_2480) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2472)) tmp2473))) (syntax-dispatch tmp2473 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2473 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2472)) tmp2471)) x2470))) (quasi2444 (lambda (p2481 lev2482) ((lambda (tmp2483) ((lambda (tmp2484) (if tmp2484 (apply (lambda (p2485) (if (= lev2482 0) p2485 (quasicons2441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2444 (list p2485) (- lev2482 1))))) tmp2484) ((lambda (tmp2486) (if tmp2486 (apply (lambda (p2487 q2488) (if (= lev2482 0) (quasiappend2442 p2487 (quasi2444 q2488 lev2482)) (quasicons2441 (quasicons2441 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2444 (list p2487) (- lev2482 1))) (quasi2444 q2488 lev2482)))) tmp2486) ((lambda (tmp2489) (if tmp2489 (apply (lambda (p2490) (quasicons2441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2444 (list p2490) (+ lev2482 1)))) tmp2489) ((lambda (tmp2491) (if tmp2491 (apply (lambda (p2492 q2493) (quasicons2441 (quasi2444 p2492 lev2482) (quasi2444 q2493 lev2482))) tmp2491) ((lambda (tmp2494) (if tmp2494 (apply (lambda (x2495) (quasivector2443 (quasi2444 x2495 lev2482))) tmp2494) ((lambda (p2497) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2497)) tmp2483))) (syntax-dispatch tmp2483 (quote #(vector each-any)))))) (syntax-dispatch tmp2483 (quote (any . any)))))) (syntax-dispatch tmp2483 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2483 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2483 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2481)))) (lambda (x2498) ((lambda (tmp2499) ((lambda (tmp2500) (if tmp2500 (apply (lambda (_2501 e2502) (quasi2444 e2502 0)) tmp2500) (syntax-error tmp2499))) (syntax-dispatch tmp2499 (quote (any any))))) x2498)))) +(install-global-transformer (quote include) (lambda (x2503) (letrec ((read-file2504 (lambda (fn2505 k2506) (let ((p2507 (open-input-file fn2505))) (let f2508 ((x2509 (read p2507))) (if (eof-object? x2509) (begin (close-input-port p2507) (quote ())) (cons (datum->syntax-object k2506 x2509) (f2508 (read p2507))))))))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (k2512 filename2513) (let ((fn2514 (syntax-object->datum filename2513))) ((lambda (tmp2515) ((lambda (tmp2516) (if tmp2516 (apply (lambda (exp2517) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2517)) tmp2516) (syntax-error tmp2515))) (syntax-dispatch tmp2515 (quote each-any)))) (read-file2504 fn2514 k2512)))) tmp2511) (syntax-error tmp2510))) (syntax-dispatch tmp2510 (quote (any any))))) x2503)))) +(install-global-transformer (quote unquote) (lambda (x2519) ((lambda (tmp2520) ((lambda (tmp2521) (if tmp2521 (apply (lambda (_2522 e2523) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2523))) tmp2521) (syntax-error tmp2520))) (syntax-dispatch tmp2520 (quote (any any))))) x2519))) +(install-global-transformer (quote unquote-splicing) (lambda (x2524) ((lambda (tmp2525) ((lambda (tmp2526) (if tmp2526 (apply (lambda (_2527 e2528) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2528))) tmp2526) (syntax-error tmp2525))) (syntax-dispatch tmp2525 (quote (any any))))) x2524))) +(install-global-transformer (quote case) (lambda (x2529) ((lambda (tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda (_2532 e2533 m12534 m22535) ((lambda (tmp2536) ((lambda (body2537) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2533)) body2537)) tmp2536)) (let f2538 ((clause2539 m12534) (clauses2540 m22535)) (if (null? clauses2540) ((lambda (tmp2542) ((lambda (tmp2543) (if tmp2543 (apply (lambda (e12544 e22545) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12544 e22545))) tmp2543) ((lambda (tmp2547) (if tmp2547 (apply (lambda (k2548 e12549 e22550) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2548)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12549 e22550)))) tmp2547) ((lambda (_2553) (syntax-error x2529)) tmp2542))) (syntax-dispatch tmp2542 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2542 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2539) ((lambda (tmp2554) ((lambda (rest2555) ((lambda (tmp2556) ((lambda (tmp2557) (if tmp2557 (apply (lambda (k2558 e12559 e22560) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2558)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12559 e22560)) rest2555)) tmp2557) ((lambda (_2563) (syntax-error x2529)) tmp2556))) (syntax-dispatch tmp2556 (quote (each-any any . each-any))))) clause2539)) tmp2554)) (f2538 (car clauses2540) (cdr clauses2540))))))) tmp2531) (syntax-error tmp2530))) (syntax-dispatch tmp2530 (quote (any any any . each-any))))) x2529))) +(install-global-transformer (quote identifier-syntax) (lambda (x2564) ((lambda (tmp2565) ((lambda (tmp2566) (if tmp2566 (apply (lambda (_2567 e2568) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2568)) (list (cons _2567 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2568 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2566) (syntax-error tmp2565))) (syntax-dispatch tmp2565 (quote (any any))))) x2564))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 72a3c3f16..e6eaf9384 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1206,7 +1206,14 @@ (if rib (cons rib (cons 'shift s)) (cons 'shift s))) - (cons 'hygiene (module-name (procedure-module p)))))))) ;; hither the hygiene + (let ((pmod (procedure-module p))) + (if pmod + ;; hither the hygiene + (cons 'hygiene (module-name pmod)) + ;; but it's possible for the proc to have + ;; no mod, if it was made before modules + ;; were booted + '(hygiene guile)))))))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) From 9c35c5796cbffda57d76499048e8b8f82db943eb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 23:10:31 +0200 Subject: [PATCH 072/375] make sure we compile boot code in (guile), not (guile-user) * libguile/eval.h: * libguile/eval.c (scm_m_eval_when): Define a cheap eval-when, used before syncase has booted. * module/Makefile.am: Reorder to put (system vm) and (system repl) modules after the compiler, as they are not needed at runtime. * module/ice-9/boot-9.scm: Move the eval-when earlier, to be the first thing -- so when we recompile Guile we do so all in the '(guile) module, not '(guile-user). * module/ice-9/compile-psyntax.scm: Rewrite to assume that psyntax.scm will eval-when to set its module, etc. Have everything in a let -- otherwise the `format' call is in (guile), but `target' was defined in (guile-user). Also, write in an eval-when to the expanded file. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/networking.scm: * module/ice-9/psyntax.scm: * module/ice-9/r4rs.scm: Sprinkles of eval-when, for flavor. --- libguile/eval.c | 19 +++++++++++++++ libguile/eval.h | 2 ++ module/Makefile.am | 21 ++++++++-------- module/ice-9/boot-9.scm | 18 +++++++------- module/ice-9/compile-psyntax.scm | 42 ++++++++++++++------------------ module/ice-9/networking.scm | 3 +++ module/ice-9/posix.scm | 3 +++ module/ice-9/psyntax-pp.scm | 2 ++ module/ice-9/psyntax.scm | 3 +++ module/ice-9/r4rs.scm | 3 +++ 10 files changed, 73 insertions(+), 43 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 19ac0b155..5b1473e06 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2140,6 +2140,25 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env) unmemoize_exprs (SCM_CDR (expr), env)); } +SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when); +SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when); +SCM_SYMBOL (sym_eval, "eval"); +SCM_SYMBOL (sym_load, "load"); + + +SCM +scm_m_eval_when (SCM expr, SCM env SCM_UNUSED) +{ + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr))) + || scm_is_true (scm_memq (sym_load, scm_cadr (expr)))) + return scm_caddr (expr); + + return scm_list_1 (SCM_IM_BEGIN); +} + #if 0 /* See futures.h for a comment why futures are not enabled. diff --git a/libguile/eval.h b/libguile/eval.h index f3ec2e19c..b017f2e02 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -100,6 +100,7 @@ SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; SCM_API SCM scm_sym_delay; +SCM_API SCM scm_sym_eval_when; SCM_API SCM scm_sym_arrow; SCM_API SCM scm_sym_else; SCM_API SCM scm_sym_apply; @@ -146,6 +147,7 @@ SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env); SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env); SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env); SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env); +SCM_API SCM scm_m_eval_when (SCM xorig, SCM env); SCM_API int scm_badargsp (SCM formals, SCM args); SCM_API SCM scm_call_0 (SCM proc); SCM_API SCM scm_call_1 (SCM proc, SCM arg1); diff --git a/module/Makefile.am b/module/Makefile.am index 95dc75ac2..2322828d7 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -35,15 +35,6 @@ SOURCES = \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ \ - system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \ - system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \ - system/vm/trace.scm system/vm/vm.scm \ - \ - system/xref.scm \ - \ - system/repl/repl.scm system/repl/common.scm \ - system/repl/command.scm \ - \ language/ghil.scm language/glil.scm language/assembly.scm \ \ $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \ @@ -54,7 +45,7 @@ SOURCES = \ $(ICE_9_SOURCES) \ $(SRFI_SOURCES) \ $(OOP_SOURCES) \ - \ + $(SYSTEM_SOURCES) \ $(SCRIPTS_SOURCES) ## test.scm is not currently installed. @@ -226,6 +217,16 @@ OOP_SOURCES = \ oop/goops/accessors.scm \ oop/goops/simple.scm +SYSTEM_SOURCES = \ + system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \ + system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \ + system/vm/trace.scm system/vm/vm.scm \ + \ + system/xref.scm \ + \ + system/repl/repl.scm system/repl/common.scm \ + system/repl/command.scm + EXTRA_DIST += oop/ChangeLog-2008 NOCOMP_SOURCES = \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index a10c125f7..235d96c9a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -33,6 +33,15 @@ +(define (void) (if #f #f)) + +;; Before compiling, make sure any symbols are resolved in the (guile) +;; module, the primary location of those symbols, rather than in +;; (guile-user), the default module that we compile in. + +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + ;;; {R4RS compliance} ;;; @@ -163,8 +172,6 @@ (define identifier? #f) (define syntax-object->datum #f) -(define (void) (if #f #f)) - (define andmap (lambda (f first . rest) (or (null? first) @@ -195,13 +202,6 @@ -;; Before compiling, make sure any symbols are resolved in the (guile) -;; module, the primary location of those symbols, rather than in -;; (guile-user), the default module that we compile in. - -(eval-when (compile) - (set-current-module (resolve-module '(guile)))) - ;;; {Defmacros} ;;; ;;; Depends on: features, eval-case diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index ac6683eb0..7091ef9fb 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,24 +1,18 @@ -;; XXX - We need to be inside (guile) since psyntax.ss calls -;; `eval' int he `interaction-environment' aka the current module and -;; it expects to have `andmap' there. The reason for this escapes me -;; at the moment. -;; -(define-module (guile)) - -(define source (list-ref (command-line) 1)) -(define target (list-ref (command-line) 2)) - -(let ((in (open-input-file source)) - (out (open-output-file (string-append target ".tmp")))) - (let loop ((x (read in))) - (if (eof-object? x) - (begin - (close-port out) - (close-port in)) - (begin - (write (sc-expand3 x 'c '(compile load eval)) - out) - (newline out) - (loop (read in)))))) - -(system (format #f "mv -f ~s.tmp ~s" target target)) +(let ((source (list-ref (command-line) 1)) + (target (list-ref (command-line) 2))) + (let ((in (open-input-file source)) + (out (open-output-file (string-append target ".tmp")))) + (write '(eval-when (compile) (set-current-module (resolve-module '(guile)))) + out) + (newline out) + (let loop ((x (read in))) + (if (eof-object? x) + (begin + (close-port out) + (close-port in)) + (begin + (write (sc-expand3 x 'c '(compile load eval)) + out) + (newline out) + (loop (read in)))))) + (system (format #f "mv -f ~s.tmp ~s" target target))) diff --git a/module/ice-9/networking.scm b/module/ice-9/networking.scm index c0218821f..9a30fc5b6 100644 --- a/module/ice-9/networking.scm +++ b/module/ice-9/networking.scm @@ -17,6 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (define (gethostbyaddr addr) (gethost addr)) (define (gethostbyname name) (gethost name)) diff --git a/module/ice-9/posix.scm b/module/ice-9/posix.scm index 53d01a026..dd1a12690 100644 --- a/module/ice-9/posix.scm +++ b/module/ice-9/posix.scm @@ -17,6 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (define (stat:dev f) (vector-ref f 0)) (define (stat:ino f) (vector-ref f 1)) (define (stat:mode f) (vector-ref f 2)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 743197fbd..e402cddf0 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,3 +1,5 @@ +(eval-when (compile) (set-current-module (resolve-module (quote (guile))))) +(void) (letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (let ((pmod1522 (procedure-module p1510))) (if pmod1522 (cons (quote hygiene) (module-name pmod1522)) (quote (hygiene guile))))))))) ((vector? x1517) (let ((n1523 (vector-length x1517))) (let ((v1524 (make-vector n1523))) (let doloop1525 ((i1526 0)) (if (fx=1100 i1526 n1523) v1524 (begin (vector-set! v1524 i1526 (rebuild-macro-output1516 (vector-ref x1517 i1526) m1518)) (doloop1525 (fx+1098 i1526 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1527 e1528 r1529 w1530 s1531 mod1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (e01535 e11536) (build-annotated1108 s1531 (cons x1527 (map (lambda (e1537) (chi1167 e1537 r1529 w1530 mod1532)) e11536)))) tmp1534) (syntax-error tmp1533))) (syntax-dispatch tmp1533 (quote (any . each-any))))) e1528))) (chi-expr1168 (lambda (type1539 value1540 e1541 r1542 w1543 s1544 mod1545) (let ((t1546 type1539)) (if (memv t1546 (quote (lexical))) (build-annotated1108 s1544 value1540) (if (memv t1546 (quote (core external-macro))) (value1540 e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (module-ref))) (call-with-values (lambda () (value1540 e1541)) (lambda (id1547 mod1548) (build-annotated1108 s1544 (if mod1548 (make-module-ref (cdr mod1548) id1547 (car mod1548)) (make-module-ref mod1548 id1547 (quote bare)))))) (if (memv t1546 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1541)) value1540) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (global-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1541)) (if (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545) (make-module-ref (cdr (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545)) value1540 (car (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545))) (make-module-ref (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545) value1540 (quote bare)))) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (constant))) (build-data1109 s1544 (strip1178 (source-wrap1160 e1541 w1543 s1544 mod1545) (quote (())))) (if (memv t1546 (quote (global))) (build-annotated1108 s1544 (if mod1545 (make-module-ref (cdr mod1545) value1540 (car mod1545)) (make-module-ref mod1545 value1540 (quote bare)))) (if (memv t1546 (quote (call))) (chi-application1169 (chi1167 (car e1541) r1542 w1543 mod1545) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (begin-form))) ((lambda (tmp1549) ((lambda (tmp1550) (if tmp1550 (apply (lambda (_1551 e11552 e21553) (chi-sequence1161 (cons e11552 e21553) r1542 w1543 s1544 mod1545)) tmp1550) (syntax-error tmp1549))) (syntax-dispatch tmp1549 (quote (any any . each-any))))) e1541) (if (memv t1546 (quote (local-syntax-form))) (chi-local-syntax1173 value1540 e1541 r1542 w1543 s1544 mod1545 chi-sequence1161) (if (memv t1546 (quote (eval-when-form))) ((lambda (tmp1555) ((lambda (tmp1556) (if tmp1556 (apply (lambda (_1557 x1558 e11559 e21560) (let ((when-list1561 (chi-when-list1164 e1541 x1558 w1543))) (if (memq (quote eval) when-list1561) (chi-sequence1161 (cons e11559 e21560) r1542 w1543 s1544 mod1545) (chi-void1175)))) tmp1556) (syntax-error tmp1555))) (syntax-dispatch tmp1555 (quote (any each-any any . each-any))))) e1541) (if (memv t1546 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1540 w1543 mod1545) "invalid context for definition of") (if (memv t1546 (quote (syntax))) (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545) "reference to pattern variable outside syntax form") (if (memv t1546 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545))))))))))))))))))) (chi1167 (lambda (e1564 r1565 w1566 mod1567) (call-with-values (lambda () (syntax-type1165 e1564 r1565 w1566 #f #f mod1567)) (lambda (type1568 value1569 e1570 w1571 s1572 mod1573) (chi-expr1168 type1568 value1569 e1570 r1565 w1571 s1572 mod1573))))) (chi-top1166 (lambda (e1574 r1575 w1576 m1577 esew1578 mod1579) (call-with-values (lambda () (syntax-type1165 e1574 r1575 w1576 #f #f mod1579)) (lambda (type1587 value1588 e1589 w1590 s1591 mod1592) (let ((t1593 type1587)) (if (memv t1593 (quote (begin-form))) ((lambda (tmp1594) ((lambda (tmp1595) (if tmp1595 (apply (lambda (_1596) (chi-void1175)) tmp1595) ((lambda (tmp1597) (if tmp1597 (apply (lambda (_1598 e11599 e21600) (chi-top-sequence1162 (cons e11599 e21600) r1575 w1590 s1591 m1577 esew1578 mod1592)) tmp1597) (syntax-error tmp1594))) (syntax-dispatch tmp1594 (quote (any any . each-any)))))) (syntax-dispatch tmp1594 (quote (any))))) e1589) (if (memv t1593 (quote (local-syntax-form))) (chi-local-syntax1173 value1588 e1589 r1575 w1590 s1591 mod1592 (lambda (body1602 r1603 w1604 s1605 mod1606) (chi-top-sequence1162 body1602 r1603 w1604 s1605 m1577 esew1578 mod1606))) (if (memv t1593 (quote (eval-when-form))) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (_1609 x1610 e11611 e21612) (let ((when-list1613 (chi-when-list1164 e1589 x1610 w1590)) (body1614 (cons e11611 e21612))) (cond ((eq? m1577 (quote e)) (if (memq (quote eval) when-list1613) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote e) (quote (eval)) mod1592) (chi-void1175))) ((memq (quote load) when-list1613) (if (or (memq (quote compile) when-list1613) (and (eq? m1577 (quote c&e)) (memq (quote eval) when-list1613))) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote c&e) (quote (compile load)) mod1592) (if (memq m1577 (quote (c c&e))) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote c) (quote (load)) mod1592) (chi-void1175)))) ((or (memq (quote compile) when-list1613) (and (eq? m1577 (quote c&e)) (memq (quote eval) when-list1613))) (top-level-eval-hook1102 (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote e) (quote (eval)) mod1592) mod1592) (chi-void1175)) (else (chi-void1175))))) tmp1608) (syntax-error tmp1607))) (syntax-dispatch tmp1607 (quote (any each-any any . each-any))))) e1589) (if (memv t1593 (quote (define-syntax-form))) (let ((n1617 (id-var-name1153 value1588 w1590)) (r1618 (macros-only-env1127 r1575))) (let ((t1619 m1577)) (if (memv t1619 (quote (c))) (if (memq (quote compile) esew1578) (let ((e1620 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)))) (begin (top-level-eval-hook1102 e1620 mod1592) (if (memq (quote load) esew1578) e1620 (chi-void1175)))) (if (memq (quote load) esew1578) (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)) (chi-void1175))) (if (memv t1619 (quote (c&e))) (let ((e1621 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)))) (begin (top-level-eval-hook1102 e1621 mod1592) e1621)) (begin (if (memq (quote eval) esew1578) (top-level-eval-hook1102 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)) mod1592)) (chi-void1175)))))) (if (memv t1593 (quote (define-form))) (let ((n1622 (id-var-name1153 value1588 w1590))) (let ((type1623 (binding-type1123 (lookup1128 n1622 r1575 mod1592)))) (let ((t1624 type1623)) (if (memv t1624 (quote (global))) (let ((x1625 (build-annotated1108 s1591 (list (quote define) n1622 (chi1167 e1589 r1575 w1590 mod1592))))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1625 mod1592)) x1625)) (if (memv t1624 (quote (displaced-lexical))) (syntax-error (wrap1159 value1588 w1590 mod1592) "identifier out of context") (if (memv t1624 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1622) (let ((x1626 (build-annotated1108 s1591 (list (quote define) n1622 (chi1167 e1589 r1575 w1590 mod1592))))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1626 mod1592)) x1626))) (syntax-error (wrap1159 value1588 w1590 mod1592) "cannot define keyword at top level"))))))) (let ((x1627 (chi-expr1168 type1587 value1588 e1589 r1575 w1590 s1591 mod1592))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1627 mod1592)) x1627)))))))))))) (syntax-type1165 (lambda (e1628 r1629 w1630 s1631 rib1632 mod1633) (cond ((symbol? e1628) (let ((n1634 (id-var-name1153 e1628 w1630))) (let ((b1635 (lookup1128 n1634 r1629 mod1633))) (let ((type1636 (binding-type1123 b1635))) (let ((t1637 type1636)) (if (memv t1637 (quote (lexical))) (values type1636 (binding-value1124 b1635) e1628 w1630 s1631 mod1633) (if (memv t1637 (quote (global))) (values type1636 n1634 e1628 w1630 s1631 mod1633) (if (memv t1637 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1635) e1628 r1629 w1630 rib1632 mod1633) r1629 (quote (())) s1631 rib1632 mod1633) (values type1636 (binding-value1124 b1635) e1628 w1630 s1631 mod1633))))))))) ((pair? e1628) (let ((first1638 (car e1628))) (if (id?1131 first1638) (let ((n1639 (id-var-name1153 first1638 w1630))) (let ((b1640 (lookup1128 n1639 r1629 (or (and (syntax-object?1115 first1638) (syntax-object-module1118 first1638)) mod1633)))) (let ((type1641 (binding-type1123 b1640))) (let ((t1642 type1641)) (if (memv t1642 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (global))) (values (quote global-call) n1639 e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1640) e1628 r1629 w1630 rib1632 mod1633) r1629 (quote (())) s1631 rib1632 mod1633) (if (memv t1642 (quote (core external-macro module-ref))) (values type1641 (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (begin))) (values (quote begin-form) #f e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (eval-when))) (values (quote eval-when-form) #f e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (define))) ((lambda (tmp1643) ((lambda (tmp1644) (if (if tmp1644 (apply (lambda (_1645 name1646 val1647) (id?1131 name1646)) tmp1644) #f) (apply (lambda (_1648 name1649 val1650) (values (quote define-form) name1649 val1650 w1630 s1631 mod1633)) tmp1644) ((lambda (tmp1651) (if (if tmp1651 (apply (lambda (_1652 name1653 args1654 e11655 e21656) (and (id?1131 name1653) (valid-bound-ids?1156 (lambda-var-list1180 args1654)))) tmp1651) #f) (apply (lambda (_1657 name1658 args1659 e11660 e21661) (values (quote define-form) (wrap1159 name1658 w1630 mod1633) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1159 (cons args1659 (cons e11660 e21661)) w1630 mod1633)) (quote (())) s1631 mod1633)) tmp1651) ((lambda (tmp1663) (if (if tmp1663 (apply (lambda (_1664 name1665) (id?1131 name1665)) tmp1663) #f) (apply (lambda (_1666 name1667) (values (quote define-form) (wrap1159 name1667 w1630 mod1633) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1631 mod1633)) tmp1663) (syntax-error tmp1643))) (syntax-dispatch tmp1643 (quote (any any)))))) (syntax-dispatch tmp1643 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1643 (quote (any any any))))) e1628) (if (memv t1642 (quote (define-syntax))) ((lambda (tmp1668) ((lambda (tmp1669) (if (if tmp1669 (apply (lambda (_1670 name1671 val1672) (id?1131 name1671)) tmp1669) #f) (apply (lambda (_1673 name1674 val1675) (values (quote define-syntax-form) name1674 val1675 w1630 s1631 mod1633)) tmp1669) (syntax-error tmp1668))) (syntax-dispatch tmp1668 (quote (any any any))))) e1628) (values (quote call) #f e1628 w1630 s1631 mod1633)))))))))))))) (values (quote call) #f e1628 w1630 s1631 mod1633)))) ((syntax-object?1115 e1628) (syntax-type1165 (syntax-object-expression1116 e1628) r1629 (join-wraps1150 w1630 (syntax-object-wrap1117 e1628)) #f rib1632 (or (syntax-object-module1118 e1628) mod1633))) ((annotation? e1628) (syntax-type1165 (annotation-expression e1628) r1629 w1630 (annotation-source e1628) rib1632 mod1633)) ((self-evaluating? e1628) (values (quote constant) #f e1628 w1630 s1631 mod1633)) (else (values (quote other) #f e1628 w1630 s1631 mod1633))))) (chi-when-list1164 (lambda (e1676 when-list1677 w1678) (let f1679 ((when-list1680 when-list1677) (situations1681 (quote ()))) (if (null? when-list1680) situations1681 (f1679 (cdr when-list1680) (cons (let ((x1682 (car when-list1680))) (cond ((free-id=?1154 x1682 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1154 x1682 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1154 x1682 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1159 x1682 w1678 #f) "invalid eval-when situation")))) situations1681)))))) (chi-install-global1163 (lambda (name1683 e1684) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1683) e1684)))) (chi-top-sequence1162 (lambda (body1685 r1686 w1687 s1688 m1689 esew1690 mod1691) (build-sequence1110 s1688 (let dobody1692 ((body1693 body1685) (r1694 r1686) (w1695 w1687) (m1696 m1689) (esew1697 esew1690) (mod1698 mod1691)) (if (null? body1693) (quote ()) (let ((first1699 (chi-top1166 (car body1693) r1694 w1695 m1696 esew1697 mod1698))) (cons first1699 (dobody1692 (cdr body1693) r1694 w1695 m1696 esew1697 mod1698)))))))) (chi-sequence1161 (lambda (body1700 r1701 w1702 s1703 mod1704) (build-sequence1110 s1703 (let dobody1705 ((body1706 body1700) (r1707 r1701) (w1708 w1702) (mod1709 mod1704)) (if (null? body1706) (quote ()) (let ((first1710 (chi1167 (car body1706) r1707 w1708 mod1709))) (cons first1710 (dobody1705 (cdr body1706) r1707 w1708 mod1709)))))))) (source-wrap1160 (lambda (x1711 w1712 s1713 defmod1714) (wrap1159 (if s1713 (make-annotation x1711 s1713 #f) x1711) w1712 defmod1714))) (wrap1159 (lambda (x1715 w1716 defmod1717) (cond ((and (null? (wrap-marks1134 w1716)) (null? (wrap-subst1135 w1716))) x1715) ((syntax-object?1115 x1715) (make-syntax-object1114 (syntax-object-expression1116 x1715) (join-wraps1150 w1716 (syntax-object-wrap1117 x1715)) (syntax-object-module1118 x1715))) ((null? x1715) x1715) (else (make-syntax-object1114 x1715 w1716 defmod1717))))) (bound-id-member?1158 (lambda (x1718 list1719) (and (not (null? list1719)) (or (bound-id=?1155 x1718 (car list1719)) (bound-id-member?1158 x1718 (cdr list1719)))))) (distinct-bound-ids?1157 (lambda (ids1720) (let distinct?1721 ((ids1722 ids1720)) (or (null? ids1722) (and (not (bound-id-member?1158 (car ids1722) (cdr ids1722))) (distinct?1721 (cdr ids1722))))))) (valid-bound-ids?1156 (lambda (ids1723) (and (let all-ids?1724 ((ids1725 ids1723)) (or (null? ids1725) (and (id?1131 (car ids1725)) (all-ids?1724 (cdr ids1725))))) (distinct-bound-ids?1157 ids1723)))) (bound-id=?1155 (lambda (i1726 j1727) (if (and (syntax-object?1115 i1726) (syntax-object?1115 j1727)) (and (eq? (let ((e1728 (syntax-object-expression1116 i1726))) (if (annotation? e1728) (annotation-expression e1728) e1728)) (let ((e1729 (syntax-object-expression1116 j1727))) (if (annotation? e1729) (annotation-expression e1729) e1729))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1726)) (wrap-marks1134 (syntax-object-wrap1117 j1727)))) (eq? (let ((e1730 i1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)) (let ((e1731 j1727)) (if (annotation? e1731) (annotation-expression e1731) e1731)))))) (free-id=?1154 (lambda (i1732 j1733) (and (eq? (let ((x1734 i1732)) (let ((e1735 (if (syntax-object?1115 x1734) (syntax-object-expression1116 x1734) x1734))) (if (annotation? e1735) (annotation-expression e1735) e1735))) (let ((x1736 j1733)) (let ((e1737 (if (syntax-object?1115 x1736) (syntax-object-expression1116 x1736) x1736))) (if (annotation? e1737) (annotation-expression e1737) e1737)))) (eq? (id-var-name1153 i1732 (quote (()))) (id-var-name1153 j1733 (quote (()))))))) (id-var-name1153 (lambda (id1738 w1739) (letrec ((search-vector-rib1742 (lambda (sym1748 subst1749 marks1750 symnames1751 ribcage1752) (let ((n1753 (vector-length symnames1751))) (let f1754 ((i1755 0)) (cond ((fx=1100 i1755 n1753) (search1740 sym1748 (cdr subst1749) marks1750)) ((and (eq? (vector-ref symnames1751 i1755) sym1748) (same-marks?1152 marks1750 (vector-ref (ribcage-marks1141 ribcage1752) i1755))) (values (vector-ref (ribcage-labels1142 ribcage1752) i1755) marks1750)) (else (f1754 (fx+1098 i1755 1)))))))) (search-list-rib1741 (lambda (sym1756 subst1757 marks1758 symnames1759 ribcage1760) (let f1761 ((symnames1762 symnames1759) (i1763 0)) (cond ((null? symnames1762) (search1740 sym1756 (cdr subst1757) marks1758)) ((and (eq? (car symnames1762) sym1756) (same-marks?1152 marks1758 (list-ref (ribcage-marks1141 ribcage1760) i1763))) (values (list-ref (ribcage-labels1142 ribcage1760) i1763) marks1758)) (else (f1761 (cdr symnames1762) (fx+1098 i1763 1))))))) (search1740 (lambda (sym1764 subst1765 marks1766) (if (null? subst1765) (values #f marks1766) (let ((fst1767 (car subst1765))) (if (eq? fst1767 (quote shift)) (search1740 sym1764 (cdr subst1765) (cdr marks1766)) (let ((symnames1768 (ribcage-symnames1140 fst1767))) (if (vector? symnames1768) (search-vector-rib1742 sym1764 subst1765 marks1766 symnames1768 fst1767) (search-list-rib1741 sym1764 subst1765 marks1766 symnames1768 fst1767))))))))) (cond ((symbol? id1738) (or (call-with-values (lambda () (search1740 id1738 (wrap-subst1135 w1739) (wrap-marks1134 w1739))) (lambda (x1770 . ignore1769) x1770)) id1738)) ((syntax-object?1115 id1738) (let ((id1771 (let ((e1773 (syntax-object-expression1116 id1738))) (if (annotation? e1773) (annotation-expression e1773) e1773))) (w11772 (syntax-object-wrap1117 id1738))) (let ((marks1774 (join-marks1151 (wrap-marks1134 w1739) (wrap-marks1134 w11772)))) (call-with-values (lambda () (search1740 id1771 (wrap-subst1135 w1739) marks1774)) (lambda (new-id1775 marks1776) (or new-id1775 (call-with-values (lambda () (search1740 id1771 (wrap-subst1135 w11772) marks1776)) (lambda (x1778 . ignore1777) x1778)) id1771)))))) ((annotation? id1738) (let ((id1779 (let ((e1780 id1738)) (if (annotation? e1780) (annotation-expression e1780) e1780)))) (or (call-with-values (lambda () (search1740 id1779 (wrap-subst1135 w1739) (wrap-marks1134 w1739))) (lambda (x1782 . ignore1781) x1782)) id1779))) (else (error-hook1104 (quote id-var-name) "invalid id" id1738)))))) (same-marks?1152 (lambda (x1783 y1784) (or (eq? x1783 y1784) (and (not (null? x1783)) (not (null? y1784)) (eq? (car x1783) (car y1784)) (same-marks?1152 (cdr x1783) (cdr y1784)))))) (join-marks1151 (lambda (m11785 m21786) (smart-append1149 m11785 m21786))) (join-wraps1150 (lambda (w11787 w21788) (let ((m11789 (wrap-marks1134 w11787)) (s11790 (wrap-subst1135 w11787))) (if (null? m11789) (if (null? s11790) w21788 (make-wrap1133 (wrap-marks1134 w21788) (smart-append1149 s11790 (wrap-subst1135 w21788)))) (make-wrap1133 (smart-append1149 m11789 (wrap-marks1134 w21788)) (smart-append1149 s11790 (wrap-subst1135 w21788))))))) (smart-append1149 (lambda (m11791 m21792) (if (null? m21792) m11791 (append m11791 m21792)))) (make-binding-wrap1148 (lambda (ids1793 labels1794 w1795) (if (null? ids1793) w1795 (make-wrap1133 (wrap-marks1134 w1795) (cons (let ((labelvec1796 (list->vector labels1794))) (let ((n1797 (vector-length labelvec1796))) (let ((symnamevec1798 (make-vector n1797)) (marksvec1799 (make-vector n1797))) (begin (let f1800 ((ids1801 ids1793) (i1802 0)) (if (not (null? ids1801)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1801) w1795)) (lambda (symname1803 marks1804) (begin (vector-set! symnamevec1798 i1802 symname1803) (vector-set! marksvec1799 i1802 marks1804) (f1800 (cdr ids1801) (fx+1098 i1802 1))))))) (make-ribcage1138 symnamevec1798 marksvec1799 labelvec1796))))) (wrap-subst1135 w1795)))))) (extend-ribcage!1147 (lambda (ribcage1805 id1806 label1807) (begin (set-ribcage-symnames!1143 ribcage1805 (cons (let ((e1808 (syntax-object-expression1116 id1806))) (if (annotation? e1808) (annotation-expression e1808) e1808)) (ribcage-symnames1140 ribcage1805))) (set-ribcage-marks!1144 ribcage1805 (cons (wrap-marks1134 (syntax-object-wrap1117 id1806)) (ribcage-marks1141 ribcage1805))) (set-ribcage-labels!1145 ribcage1805 (cons label1807 (ribcage-labels1142 ribcage1805)))))) (anti-mark1146 (lambda (w1809) (make-wrap1133 (cons #f (wrap-marks1134 w1809)) (cons (quote shift) (wrap-subst1135 w1809))))) (set-ribcage-labels!1145 (lambda (x1810 update1811) (vector-set! x1810 3 update1811))) (set-ribcage-marks!1144 (lambda (x1812 update1813) (vector-set! x1812 2 update1813))) (set-ribcage-symnames!1143 (lambda (x1814 update1815) (vector-set! x1814 1 update1815))) (ribcage-labels1142 (lambda (x1816) (vector-ref x1816 3))) (ribcage-marks1141 (lambda (x1817) (vector-ref x1817 2))) (ribcage-symnames1140 (lambda (x1818) (vector-ref x1818 1))) (ribcage?1139 (lambda (x1819) (and (vector? x1819) (= (vector-length x1819) 4) (eq? (vector-ref x1819 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1820 marks1821 labels1822) (vector (quote ribcage) symnames1820 marks1821 labels1822))) (gen-labels1137 (lambda (ls1823) (if (null? ls1823) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1823)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1824 w1825) (if (syntax-object?1115 x1824) (values (let ((e1826 (syntax-object-expression1116 x1824))) (if (annotation? e1826) (annotation-expression e1826) e1826)) (join-marks1151 (wrap-marks1134 w1825) (wrap-marks1134 (syntax-object-wrap1117 x1824)))) (values (let ((e1827 x1824)) (if (annotation? e1827) (annotation-expression e1827) e1827)) (wrap-marks1134 w1825))))) (id?1131 (lambda (x1828) (cond ((symbol? x1828) #t) ((syntax-object?1115 x1828) (symbol? (let ((e1829 (syntax-object-expression1116 x1828))) (if (annotation? e1829) (annotation-expression e1829) e1829)))) ((annotation? x1828) (symbol? (annotation-expression x1828))) (else #f)))) (nonsymbol-id?1130 (lambda (x1830) (and (syntax-object?1115 x1830) (symbol? (let ((e1831 (syntax-object-expression1116 x1830))) (if (annotation? e1831) (annotation-expression e1831) e1831)))))) (global-extend1129 (lambda (type1832 sym1833 val1834) (put-global-definition-hook1105 sym1833 (cons type1832 val1834)))) (lookup1128 (lambda (x1835 r1836 mod1837) (cond ((assq x1835 r1836) => cdr) ((symbol? x1835) (or (get-global-definition-hook1107 x1835 mod1837) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1838) (if (null? r1838) (quote ()) (let ((a1839 (car r1838))) (if (eq? (cadr a1839) (quote macro)) (cons a1839 (macros-only-env1127 (cdr r1838))) (macros-only-env1127 (cdr r1838))))))) (extend-var-env1126 (lambda (labels1840 vars1841 r1842) (if (null? labels1840) r1842 (extend-var-env1126 (cdr labels1840) (cdr vars1841) (cons (cons (car labels1840) (cons (quote lexical) (car vars1841))) r1842))))) (extend-env1125 (lambda (labels1843 bindings1844 r1845) (if (null? labels1843) r1845 (extend-env1125 (cdr labels1843) (cdr bindings1844) (cons (cons (car labels1843) (car bindings1844)) r1845))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1846) (cond ((annotation? x1846) (annotation-source x1846)) ((syntax-object?1115 x1846) (source-annotation1122 (syntax-object-expression1116 x1846))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1847 update1848) (vector-set! x1847 3 update1848))) (set-syntax-object-wrap!1120 (lambda (x1849 update1850) (vector-set! x1849 2 update1850))) (set-syntax-object-expression!1119 (lambda (x1851 update1852) (vector-set! x1851 1 update1852))) (syntax-object-module1118 (lambda (x1853) (vector-ref x1853 3))) (syntax-object-wrap1117 (lambda (x1854) (vector-ref x1854 2))) (syntax-object-expression1116 (lambda (x1855) (vector-ref x1855 1))) (syntax-object?1115 (lambda (x1856) (and (vector? x1856) (= (vector-length x1856) 4) (eq? (vector-ref x1856 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1857 wrap1858 module1859) (vector (quote syntax-object) expression1857 wrap1858 module1859))) (build-letrec1113 (lambda (src1860 vars1861 val-exps1862 body-exp1863) (if (null? vars1861) (build-annotated1108 src1860 body-exp1863) (build-annotated1108 src1860 (list (quote letrec) (map list vars1861 val-exps1862) body-exp1863))))) (build-named-let1112 (lambda (src1864 vars1865 val-exps1866 body-exp1867) (if (null? vars1865) (build-annotated1108 src1864 body-exp1867) (build-annotated1108 src1864 (list (quote let) (car vars1865) (map list (cdr vars1865) val-exps1866) body-exp1867))))) (build-let1111 (lambda (src1868 vars1869 val-exps1870 body-exp1871) (if (null? vars1869) (build-annotated1108 src1868 body-exp1871) (build-annotated1108 src1868 (list (quote let) (map list vars1869 val-exps1870) body-exp1871))))) (build-sequence1110 (lambda (src1872 exps1873) (if (null? (cdr exps1873)) (build-annotated1108 src1872 (car exps1873)) (build-annotated1108 src1872 (cons (quote begin) exps1873))))) (build-data1109 (lambda (src1874 exp1875) (if (and (self-evaluating? exp1875) (not (vector? exp1875))) (build-annotated1108 src1874 exp1875) (build-annotated1108 src1874 (list (quote quote) exp1875))))) (build-annotated1108 (lambda (src1876 exp1877) (if (and src1876 (not (annotation? exp1877))) (make-annotation exp1877 src1876 #t) exp1877))) (get-global-definition-hook1107 (lambda (symbol1878 module1879) (let ((module1880 (if module1879 (resolve-module (cdr module1879)) (let ((mod1881 (current-module))) (begin (if mod1881 (warn "wha" symbol1878)) mod1881))))) (let ((v1882 (module-variable module1880 symbol1878))) (and v1882 (object-property v1882 (quote *sc-expander*))))))) (remove-global-definition-hook1106 (lambda (symbol1883) (let ((module1884 (current-module))) (let ((v1885 (module-local-variable module1884 symbol1883))) (if v1885 (let ((p1886 (assq (quote *sc-expander*) (object-properties v1885)))) (set-object-properties! v1885 (delq p1886 (object-properties v1885))))))))) (put-global-definition-hook1105 (lambda (symbol1887 binding1888) (let ((module1889 (current-module))) (let ((v1890 (or (module-variable module1889 symbol1887) (let ((v1891 (make-variable (gensym)))) (begin (module-add! module1889 symbol1887 v1891) v1891))))) (begin (if (not (variable-bound? v1890)) (variable-set! v1890 (gensym))) (set-object-property! v1890 (quote *sc-expander*) binding1888)))))) (error-hook1104 (lambda (who1892 why1893 what1894) (error who1892 "~a ~s" why1893 what1894))) (local-eval-hook1103 (lambda (x1895 mod1896) (primitive-eval (list noexpand1097 x1895)))) (top-level-eval-hook1102 (lambda (x1897 mod1898) (primitive-eval (list noexpand1097 x1897)))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1899 r1900 w1901 s1902 mod1903) ((lambda (tmp1904) ((lambda (tmp1905) (if (if tmp1905 (apply (lambda (_1906 var1907 val1908 e11909 e21910) (valid-bound-ids?1156 var1907)) tmp1905) #f) (apply (lambda (_1912 var1913 val1914 e11915 e21916) (let ((names1917 (map (lambda (x1918) (id-var-name1153 x1918 w1901)) var1913))) (begin (for-each (lambda (id1920 n1921) (let ((t1922 (binding-type1123 (lookup1128 n1921 r1900 mod1903)))) (if (memv t1922 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1920 w1901 s1902 mod1903) "identifier out of context")))) var1913 names1917) (chi-body1171 (cons e11915 e21916) (source-wrap1160 e1899 w1901 s1902 mod1903) (extend-env1125 names1917 (let ((trans-r1925 (macros-only-env1127 r1900))) (map (lambda (x1926) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1926 trans-r1925 w1901 mod1903) mod1903))) val1914)) r1900) w1901 mod1903)))) tmp1905) ((lambda (_1928) (syntax-error (source-wrap1160 e1899 w1901 s1902 mod1903))) tmp1904))) (syntax-dispatch tmp1904 (quote (any #(each (any any)) any . each-any))))) e1899))) (global-extend1129 (quote core) (quote quote) (lambda (e1929 r1930 w1931 s1932 mod1933) ((lambda (tmp1934) ((lambda (tmp1935) (if tmp1935 (apply (lambda (_1936 e1937) (build-data1109 s1932 (strip1178 e1937 w1931))) tmp1935) ((lambda (_1938) (syntax-error (source-wrap1160 e1929 w1931 s1932 mod1933))) tmp1934))) (syntax-dispatch tmp1934 (quote (any any))))) e1929))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1946 (lambda (x1947) (let ((t1948 (car x1947))) (if (memv t1948 (quote (ref))) (build-annotated1108 #f (cadr x1947)) (if (memv t1948 (quote (primitive))) (build-annotated1108 #f (cadr x1947)) (if (memv t1948 (quote (quote))) (build-data1109 #f (cadr x1947)) (if (memv t1948 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1947) (regen1946 (caddr x1947)))) (if (memv t1948 (quote (map))) (let ((ls1949 (map regen1946 (cdr x1947)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1949) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1949))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1947)) (map regen1946 (cdr x1947)))))))))))) (gen-vector1945 (lambda (x1950) (cond ((eq? (car x1950) (quote list)) (cons (quote vector) (cdr x1950))) ((eq? (car x1950) (quote quote)) (list (quote quote) (list->vector (cadr x1950)))) (else (list (quote list->vector) x1950))))) (gen-append1944 (lambda (x1951 y1952) (if (equal? y1952 (quote (quote ()))) x1951 (list (quote append) x1951 y1952)))) (gen-cons1943 (lambda (x1953 y1954) (let ((t1955 (car y1954))) (if (memv t1955 (quote (quote))) (if (eq? (car x1953) (quote quote)) (list (quote quote) (cons (cadr x1953) (cadr y1954))) (if (eq? (cadr y1954) (quote ())) (list (quote list) x1953) (list (quote cons) x1953 y1954))) (if (memv t1955 (quote (list))) (cons (quote list) (cons x1953 (cdr y1954))) (list (quote cons) x1953 y1954)))))) (gen-map1942 (lambda (e1956 map-env1957) (let ((formals1958 (map cdr map-env1957)) (actuals1959 (map (lambda (x1960) (list (quote ref) (car x1960))) map-env1957))) (cond ((eq? (car e1956) (quote ref)) (car actuals1959)) ((andmap (lambda (x1961) (and (eq? (car x1961) (quote ref)) (memq (cadr x1961) formals1958))) (cdr e1956)) (cons (quote map) (cons (list (quote primitive) (car e1956)) (map (let ((r1962 (map cons formals1958 actuals1959))) (lambda (x1963) (cdr (assq (cadr x1963) r1962)))) (cdr e1956))))) (else (cons (quote map) (cons (list (quote lambda) formals1958 e1956) actuals1959))))))) (gen-mappend1941 (lambda (e1964 map-env1965) (list (quote apply) (quote (primitive append)) (gen-map1942 e1964 map-env1965)))) (gen-ref1940 (lambda (src1966 var1967 level1968 maps1969) (if (fx=1100 level1968 0) (values var1967 maps1969) (if (null? maps1969) (syntax-error src1966 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1940 src1966 var1967 (fx-1099 level1968 1) (cdr maps1969))) (lambda (outer-var1970 outer-maps1971) (let ((b1972 (assq outer-var1970 (car maps1969)))) (if b1972 (values (cdr b1972) maps1969) (let ((inner-var1973 (gen-var1179 (quote tmp)))) (values inner-var1973 (cons (cons (cons outer-var1970 inner-var1973) (car maps1969)) outer-maps1971))))))))))) (gen-syntax1939 (lambda (src1974 e1975 r1976 maps1977 ellipsis?1978 mod1979) (if (id?1131 e1975) (let ((label1980 (id-var-name1153 e1975 (quote (()))))) (let ((b1981 (lookup1128 label1980 r1976 mod1979))) (if (eq? (binding-type1123 b1981) (quote syntax)) (call-with-values (lambda () (let ((var.lev1982 (binding-value1124 b1981))) (gen-ref1940 src1974 (car var.lev1982) (cdr var.lev1982) maps1977))) (lambda (var1983 maps1984) (values (list (quote ref) var1983) maps1984))) (if (ellipsis?1978 e1975) (syntax-error src1974 "misplaced ellipsis in syntax form") (values (list (quote quote) e1975) maps1977))))) ((lambda (tmp1985) ((lambda (tmp1986) (if (if tmp1986 (apply (lambda (dots1987 e1988) (ellipsis?1978 dots1987)) tmp1986) #f) (apply (lambda (dots1989 e1990) (gen-syntax1939 src1974 e1990 r1976 maps1977 (lambda (x1991) #f) mod1979)) tmp1986) ((lambda (tmp1992) (if (if tmp1992 (apply (lambda (x1993 dots1994 y1995) (ellipsis?1978 dots1994)) tmp1992) #f) (apply (lambda (x1996 dots1997 y1998) (let f1999 ((y2000 y1998) (k2001 (lambda (maps2002) (call-with-values (lambda () (gen-syntax1939 src1974 x1996 r1976 (cons (quote ()) maps2002) ellipsis?1978 mod1979)) (lambda (x2003 maps2004) (if (null? (car maps2004)) (syntax-error src1974 "extra ellipsis in syntax form") (values (gen-map1942 x2003 (car maps2004)) (cdr maps2004)))))))) ((lambda (tmp2005) ((lambda (tmp2006) (if (if tmp2006 (apply (lambda (dots2007 y2008) (ellipsis?1978 dots2007)) tmp2006) #f) (apply (lambda (dots2009 y2010) (f1999 y2010 (lambda (maps2011) (call-with-values (lambda () (k2001 (cons (quote ()) maps2011))) (lambda (x2012 maps2013) (if (null? (car maps2013)) (syntax-error src1974 "extra ellipsis in syntax form") (values (gen-mappend1941 x2012 (car maps2013)) (cdr maps2013)))))))) tmp2006) ((lambda (_2014) (call-with-values (lambda () (gen-syntax1939 src1974 y2000 r1976 maps1977 ellipsis?1978 mod1979)) (lambda (y2015 maps2016) (call-with-values (lambda () (k2001 maps2016)) (lambda (x2017 maps2018) (values (gen-append1944 x2017 y2015) maps2018)))))) tmp2005))) (syntax-dispatch tmp2005 (quote (any . any))))) y2000))) tmp1992) ((lambda (tmp2019) (if tmp2019 (apply (lambda (x2020 y2021) (call-with-values (lambda () (gen-syntax1939 src1974 x2020 r1976 maps1977 ellipsis?1978 mod1979)) (lambda (x2022 maps2023) (call-with-values (lambda () (gen-syntax1939 src1974 y2021 r1976 maps2023 ellipsis?1978 mod1979)) (lambda (y2024 maps2025) (values (gen-cons1943 x2022 y2024) maps2025)))))) tmp2019) ((lambda (tmp2026) (if tmp2026 (apply (lambda (e12027 e22028) (call-with-values (lambda () (gen-syntax1939 src1974 (cons e12027 e22028) r1976 maps1977 ellipsis?1978 mod1979)) (lambda (e2030 maps2031) (values (gen-vector1945 e2030) maps2031)))) tmp2026) ((lambda (_2032) (values (list (quote quote) e1975) maps1977)) tmp1985))) (syntax-dispatch tmp1985 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1985 (quote (any . any)))))) (syntax-dispatch tmp1985 (quote (any any . any)))))) (syntax-dispatch tmp1985 (quote (any any))))) e1975))))) (lambda (e2033 r2034 w2035 s2036 mod2037) (let ((e2038 (source-wrap1160 e2033 w2035 s2036 mod2037))) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 x2042) (call-with-values (lambda () (gen-syntax1939 e2038 x2042 r2034 (quote ()) ellipsis?1176 mod2037)) (lambda (e2043 maps2044) (regen1946 e2043)))) tmp2040) ((lambda (_2045) (syntax-error e2038)) tmp2039))) (syntax-dispatch tmp2039 (quote (any any))))) e2038))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2046 r2047 w2048 s2049 mod2050) ((lambda (tmp2051) ((lambda (tmp2052) (if tmp2052 (apply (lambda (_2053 c2054) (chi-lambda-clause1172 (source-wrap1160 e2046 w2048 s2049 mod2050) c2054 r2047 w2048 mod2050 (lambda (vars2055 body2056) (build-annotated1108 s2049 (list (quote lambda) vars2055 body2056))))) tmp2052) (syntax-error tmp2051))) (syntax-dispatch tmp2051 (quote (any . any))))) e2046))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2057 (lambda (e2058 r2059 w2060 s2061 mod2062 constructor2063 ids2064 vals2065 exps2066) (if (not (valid-bound-ids?1156 ids2064)) (syntax-error e2058 "duplicate bound variable in") (let ((labels2067 (gen-labels1137 ids2064)) (new-vars2068 (map gen-var1179 ids2064))) (let ((nw2069 (make-binding-wrap1148 ids2064 labels2067 w2060)) (nr2070 (extend-var-env1126 labels2067 new-vars2068 r2059))) (constructor2063 s2061 new-vars2068 (map (lambda (x2071) (chi1167 x2071 r2059 w2060 mod2062)) vals2065) (chi-body1171 exps2066 (source-wrap1160 e2058 nw2069 s2061 mod2062) nr2070 nw2069 mod2062)))))))) (lambda (e2072 r2073 w2074 s2075 mod2076) ((lambda (tmp2077) ((lambda (tmp2078) (if tmp2078 (apply (lambda (_2079 id2080 val2081 e12082 e22083) (chi-let2057 e2072 r2073 w2074 s2075 mod2076 build-let1111 id2080 val2081 (cons e12082 e22083))) tmp2078) ((lambda (tmp2087) (if (if tmp2087 (apply (lambda (_2088 f2089 id2090 val2091 e12092 e22093) (id?1131 f2089)) tmp2087) #f) (apply (lambda (_2094 f2095 id2096 val2097 e12098 e22099) (chi-let2057 e2072 r2073 w2074 s2075 mod2076 build-named-let1112 (cons f2095 id2096) val2097 (cons e12098 e22099))) tmp2087) ((lambda (_2103) (syntax-error (source-wrap1160 e2072 w2074 s2075 mod2076))) tmp2077))) (syntax-dispatch tmp2077 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2077 (quote (any #(each (any any)) any . each-any))))) e2072)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2104 r2105 w2106 s2107 mod2108) ((lambda (tmp2109) ((lambda (tmp2110) (if tmp2110 (apply (lambda (_2111 id2112 val2113 e12114 e22115) (let ((ids2116 id2112)) (if (not (valid-bound-ids?1156 ids2116)) (syntax-error e2104 "duplicate bound variable in") (let ((labels2118 (gen-labels1137 ids2116)) (new-vars2119 (map gen-var1179 ids2116))) (let ((w2120 (make-binding-wrap1148 ids2116 labels2118 w2106)) (r2121 (extend-var-env1126 labels2118 new-vars2119 r2105))) (build-letrec1113 s2107 new-vars2119 (map (lambda (x2122) (chi1167 x2122 r2121 w2120 mod2108)) val2113) (chi-body1171 (cons e12114 e22115) (source-wrap1160 e2104 w2120 s2107 mod2108) r2121 w2120 mod2108))))))) tmp2110) ((lambda (_2125) (syntax-error (source-wrap1160 e2104 w2106 s2107 mod2108))) tmp2109))) (syntax-dispatch tmp2109 (quote (any #(each (any any)) any . each-any))))) e2104))) (global-extend1129 (quote core) (quote set!) (lambda (e2126 r2127 w2128 s2129 mod2130) ((lambda (tmp2131) ((lambda (tmp2132) (if (if tmp2132 (apply (lambda (_2133 id2134 val2135) (id?1131 id2134)) tmp2132) #f) (apply (lambda (_2136 id2137 val2138) (let ((val2139 (chi1167 val2138 r2127 w2128 mod2130)) (n2140 (id-var-name1153 id2137 w2128))) (let ((b2141 (lookup1128 n2140 r2127 mod2130))) (let ((t2142 (binding-type1123 b2141))) (if (memv t2142 (quote (lexical))) (build-annotated1108 s2129 (list (quote set!) (binding-value1124 b2141) val2139)) (if (memv t2142 (quote (global))) (build-annotated1108 s2129 (list (quote set!) (if mod2130 (make-module-ref (cdr mod2130) n2140 (car mod2130)) (make-module-ref mod2130 n2140 (quote bare))) val2139)) (if (memv t2142 (quote (displaced-lexical))) (syntax-error (wrap1159 id2137 w2128 mod2130) "identifier out of context") (syntax-error (source-wrap1160 e2126 w2128 s2129 mod2130))))))))) tmp2132) ((lambda (tmp2143) (if tmp2143 (apply (lambda (_2144 head2145 tail2146 val2147) (call-with-values (lambda () (syntax-type1165 head2145 r2127 (quote (())) #f #f mod2130)) (lambda (type2148 value2149 ee2150 ww2151 ss2152 modmod2153) (let ((t2154 type2148)) (if (memv t2154 (quote (module-ref))) (let ((val2155 (chi1167 val2147 r2127 w2128 mod2130))) (call-with-values (lambda () (value2149 (cons head2145 tail2146))) (lambda (id2157 mod2158) (build-annotated1108 s2129 (list (quote set!) (if mod2158 (make-module-ref (cdr mod2158) id2157 (car mod2158)) (make-module-ref mod2158 id2157 (quote bare))) val2155))))) (build-annotated1108 s2129 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2145) r2127 w2128 mod2130) (map (lambda (e2159) (chi1167 e2159 r2127 w2128 mod2130)) (append tail2146 (list val2147)))))))))) tmp2143) ((lambda (_2161) (syntax-error (source-wrap1160 e2126 w2128 s2129 mod2130))) tmp2131))) (syntax-dispatch tmp2131 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2131 (quote (any any any))))) e2126))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2162) ((lambda (tmp2163) ((lambda (tmp2164) (if (if tmp2164 (apply (lambda (_2165 mod2166 id2167) (and (andmap id?1131 mod2166) (id?1131 id2167))) tmp2164) #f) (apply (lambda (_2169 mod2170 id2171) (values (syntax-object->datum id2171) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2170)))) tmp2164) (syntax-error tmp2163))) (syntax-dispatch tmp2163 (quote (any each-any any))))) e2162))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2173) ((lambda (tmp2174) ((lambda (tmp2175) (if (if tmp2175 (apply (lambda (_2176 mod2177 id2178) (and (andmap id?1131 mod2177) (id?1131 id2178))) tmp2175) #f) (apply (lambda (_2180 mod2181 id2182) (values (syntax-object->datum id2182) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2181)))) tmp2175) (syntax-error tmp2174))) (syntax-dispatch tmp2174 (quote (any each-any any))))) e2173))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2187 (lambda (x2188 keys2189 clauses2190 r2191 mod2192) (if (null? clauses2190) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2188)) ((lambda (tmp2193) ((lambda (tmp2194) (if tmp2194 (apply (lambda (pat2195 exp2196) (if (and (id?1131 pat2195) (andmap (lambda (x2197) (not (free-id=?1154 pat2195 x2197))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2189))) (let ((labels2198 (list (gen-label1136))) (var2199 (gen-var1179 pat2195))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2199) (chi1167 exp2196 (extend-env1125 labels2198 (list (cons (quote syntax) (cons var2199 0))) r2191) (make-binding-wrap1148 (list pat2195) labels2198 (quote (()))) mod2192))) x2188))) (gen-clause2186 x2188 keys2189 (cdr clauses2190) r2191 pat2195 #t exp2196 mod2192))) tmp2194) ((lambda (tmp2200) (if tmp2200 (apply (lambda (pat2201 fender2202 exp2203) (gen-clause2186 x2188 keys2189 (cdr clauses2190) r2191 pat2201 fender2202 exp2203 mod2192)) tmp2200) ((lambda (_2204) (syntax-error (car clauses2190) "invalid syntax-case clause")) tmp2193))) (syntax-dispatch tmp2193 (quote (any any any)))))) (syntax-dispatch tmp2193 (quote (any any))))) (car clauses2190))))) (gen-clause2186 (lambda (x2205 keys2206 clauses2207 r2208 pat2209 fender2210 exp2211 mod2212) (call-with-values (lambda () (convert-pattern2184 pat2209 keys2206)) (lambda (p2213 pvars2214) (cond ((not (distinct-bound-ids?1157 (map car pvars2214))) (syntax-error pat2209 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2215) (not (ellipsis?1176 (car x2215)))) pvars2214)) (syntax-error pat2209 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2216 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2216) (let ((y2217 (build-annotated1108 #f y2216))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2218) ((lambda (tmp2219) (if tmp2219 (apply (lambda () y2217) tmp2219) ((lambda (_2220) (build-annotated1108 #f (list (quote if) y2217 (build-dispatch-call2185 pvars2214 fender2210 y2217 r2208 mod2212) (build-data1109 #f #f)))) tmp2218))) (syntax-dispatch tmp2218 (quote #(atom #t))))) fender2210) (build-dispatch-call2185 pvars2214 exp2211 y2217 r2208 mod2212) (gen-syntax-case2187 x2205 keys2206 clauses2207 r2208 mod2212)))))) (if (eq? p2213 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2205)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2205 (build-data1109 #f p2213))))))))))))) (build-dispatch-call2185 (lambda (pvars2221 exp2222 y2223 r2224 mod2225) (let ((ids2226 (map car pvars2221)) (levels2227 (map cdr pvars2221))) (let ((labels2228 (gen-labels1137 ids2226)) (new-vars2229 (map gen-var1179 ids2226))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2229 (chi1167 exp2222 (extend-env1125 labels2228 (map (lambda (var2230 level2231) (cons (quote syntax) (cons var2230 level2231))) new-vars2229 (map cdr pvars2221)) r2224) (make-binding-wrap1148 ids2226 labels2228 (quote (()))) mod2225))) y2223)))))) (convert-pattern2184 (lambda (pattern2232 keys2233) (let cvt2234 ((p2235 pattern2232) (n2236 0) (ids2237 (quote ()))) (if (id?1131 p2235) (if (bound-id-member?1158 p2235 keys2233) (values (vector (quote free-id) p2235) ids2237) (values (quote any) (cons (cons p2235 n2236) ids2237))) ((lambda (tmp2238) ((lambda (tmp2239) (if (if tmp2239 (apply (lambda (x2240 dots2241) (ellipsis?1176 dots2241)) tmp2239) #f) (apply (lambda (x2242 dots2243) (call-with-values (lambda () (cvt2234 x2242 (fx+1098 n2236 1) ids2237)) (lambda (p2244 ids2245) (values (if (eq? p2244 (quote any)) (quote each-any) (vector (quote each) p2244)) ids2245)))) tmp2239) ((lambda (tmp2246) (if tmp2246 (apply (lambda (x2247 y2248) (call-with-values (lambda () (cvt2234 y2248 n2236 ids2237)) (lambda (y2249 ids2250) (call-with-values (lambda () (cvt2234 x2247 n2236 ids2250)) (lambda (x2251 ids2252) (values (cons x2251 y2249) ids2252)))))) tmp2246) ((lambda (tmp2253) (if tmp2253 (apply (lambda () (values (quote ()) ids2237)) tmp2253) ((lambda (tmp2254) (if tmp2254 (apply (lambda (x2255) (call-with-values (lambda () (cvt2234 x2255 n2236 ids2237)) (lambda (p2257 ids2258) (values (vector (quote vector) p2257) ids2258)))) tmp2254) ((lambda (x2259) (values (vector (quote atom) (strip1178 p2235 (quote (())))) ids2237)) tmp2238))) (syntax-dispatch tmp2238 (quote #(vector each-any)))))) (syntax-dispatch tmp2238 (quote ()))))) (syntax-dispatch tmp2238 (quote (any . any)))))) (syntax-dispatch tmp2238 (quote (any any))))) p2235)))))) (lambda (e2260 r2261 w2262 s2263 mod2264) (let ((e2265 (source-wrap1160 e2260 w2262 s2263 mod2264))) ((lambda (tmp2266) ((lambda (tmp2267) (if tmp2267 (apply (lambda (_2268 val2269 key2270 m2271) (if (andmap (lambda (x2272) (and (id?1131 x2272) (not (ellipsis?1176 x2272)))) key2270) (let ((x2274 (gen-var1179 (quote tmp)))) (build-annotated1108 s2263 (list (build-annotated1108 #f (list (quote lambda) (list x2274) (gen-syntax-case2187 (build-annotated1108 #f x2274) key2270 m2271 r2261 mod2264))) (chi1167 val2269 r2261 (quote (())) mod2264)))) (syntax-error e2265 "invalid literals list in"))) tmp2267) (syntax-error tmp2266))) (syntax-dispatch tmp2266 (quote (any any each-any . each-any))))) e2265))))) (set! sc-expand (let ((m2277 (quote e)) (esew2278 (quote (eval)))) (lambda (x2279) (if (and (pair? x2279) (equal? (car x2279) noexpand1097)) (cadr x2279) (chi-top1166 x2279 (quote ()) (quote ((top))) m2277 esew2278 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2280 (quote e)) (esew2281 (quote (eval)))) (lambda (x2283 . rest2282) (if (and (pair? x2283) (equal? (car x2283) noexpand1097)) (cadr x2283) (chi-top1166 x2283 (quote ()) (quote ((top))) (if (null? rest2282) m2280 (car rest2282)) (if (or (null? rest2282) (null? (cdr rest2282))) esew2281 (cadr rest2282)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2284) (nonsymbol-id?1130 x2284))) (set! datum->syntax-object (lambda (id2285 datum2286) (make-syntax-object1114 datum2286 (syntax-object-wrap1117 id2285) #f))) (set! syntax-object->datum (lambda (x2287) (strip1178 x2287 (quote (()))))) (set! generate-temporaries (lambda (ls2288) (begin (let ((x2289 ls2288)) (if (not (list? x2289)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2289))) (map (lambda (x2290) (wrap1159 (gensym) (quote ((top))) #f)) ls2288)))) (set! free-identifier=? (lambda (x2291 y2292) (begin (let ((x2293 x2291)) (if (not (nonsymbol-id?1130 x2293)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2293))) (let ((x2294 y2292)) (if (not (nonsymbol-id?1130 x2294)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2294))) (free-id=?1154 x2291 y2292)))) (set! bound-identifier=? (lambda (x2295 y2296) (begin (let ((x2297 x2295)) (if (not (nonsymbol-id?1130 x2297)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2297))) (let ((x2298 y2296)) (if (not (nonsymbol-id?1130 x2298)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2298))) (bound-id=?1155 x2295 y2296)))) (set! syntax-error (lambda (object2300 . messages2299) (begin (for-each (lambda (x2301) (let ((x2302 x2301)) (if (not (string? x2302)) (error-hook1104 (quote syntax-error) "invalid argument" x2302)))) messages2299) (let ((message2303 (if (null? messages2299) "invalid syntax" (apply string-append messages2299)))) (error-hook1104 #f message2303 (strip1178 object2300 (quote (())))))))) (set! install-global-transformer (lambda (sym2304 v2305) (begin (let ((x2306 sym2304)) (if (not (symbol? x2306)) (error-hook1104 (quote define-syntax) "invalid argument" x2306))) (let ((x2307 v2305)) (if (not (procedure? x2307)) (error-hook1104 (quote define-syntax) "invalid argument" x2307))) (global-extend1129 (quote macro) sym2304 v2305)))) (letrec ((match2312 (lambda (e2313 p2314 w2315 r2316 mod2317) (cond ((not r2316) #f) ((eq? p2314 (quote any)) (cons (wrap1159 e2313 w2315 mod2317) r2316)) ((syntax-object?1115 e2313) (match*2311 (let ((e2318 (syntax-object-expression1116 e2313))) (if (annotation? e2318) (annotation-expression e2318) e2318)) p2314 (join-wraps1150 w2315 (syntax-object-wrap1117 e2313)) r2316 (syntax-object-module1118 e2313))) (else (match*2311 (let ((e2319 e2313)) (if (annotation? e2319) (annotation-expression e2319) e2319)) p2314 w2315 r2316 mod2317))))) (match*2311 (lambda (e2320 p2321 w2322 r2323 mod2324) (cond ((null? p2321) (and (null? e2320) r2323)) ((pair? p2321) (and (pair? e2320) (match2312 (car e2320) (car p2321) w2322 (match2312 (cdr e2320) (cdr p2321) w2322 r2323 mod2324) mod2324))) ((eq? p2321 (quote each-any)) (let ((l2325 (match-each-any2309 e2320 w2322 mod2324))) (and l2325 (cons l2325 r2323)))) (else (let ((t2326 (vector-ref p2321 0))) (if (memv t2326 (quote (each))) (if (null? e2320) (match-empty2310 (vector-ref p2321 1) r2323) (let ((l2327 (match-each2308 e2320 (vector-ref p2321 1) w2322 mod2324))) (and l2327 (let collect2328 ((l2329 l2327)) (if (null? (car l2329)) r2323 (cons (map car l2329) (collect2328 (map cdr l2329)))))))) (if (memv t2326 (quote (free-id))) (and (id?1131 e2320) (free-id=?1154 (wrap1159 e2320 w2322 mod2324) (vector-ref p2321 1)) r2323) (if (memv t2326 (quote (atom))) (and (equal? (vector-ref p2321 1) (strip1178 e2320 w2322)) r2323) (if (memv t2326 (quote (vector))) (and (vector? e2320) (match2312 (vector->list e2320) (vector-ref p2321 1) w2322 r2323 mod2324))))))))))) (match-empty2310 (lambda (p2330 r2331) (cond ((null? p2330) r2331) ((eq? p2330 (quote any)) (cons (quote ()) r2331)) ((pair? p2330) (match-empty2310 (car p2330) (match-empty2310 (cdr p2330) r2331))) ((eq? p2330 (quote each-any)) (cons (quote ()) r2331)) (else (let ((t2332 (vector-ref p2330 0))) (if (memv t2332 (quote (each))) (match-empty2310 (vector-ref p2330 1) r2331) (if (memv t2332 (quote (free-id atom))) r2331 (if (memv t2332 (quote (vector))) (match-empty2310 (vector-ref p2330 1) r2331))))))))) (match-each-any2309 (lambda (e2333 w2334 mod2335) (cond ((annotation? e2333) (match-each-any2309 (annotation-expression e2333) w2334 mod2335)) ((pair? e2333) (let ((l2336 (match-each-any2309 (cdr e2333) w2334 mod2335))) (and l2336 (cons (wrap1159 (car e2333) w2334 mod2335) l2336)))) ((null? e2333) (quote ())) ((syntax-object?1115 e2333) (match-each-any2309 (syntax-object-expression1116 e2333) (join-wraps1150 w2334 (syntax-object-wrap1117 e2333)) mod2335)) (else #f)))) (match-each2308 (lambda (e2337 p2338 w2339 mod2340) (cond ((annotation? e2337) (match-each2308 (annotation-expression e2337) p2338 w2339 mod2340)) ((pair? e2337) (let ((first2341 (match2312 (car e2337) p2338 w2339 (quote ()) mod2340))) (and first2341 (let ((rest2342 (match-each2308 (cdr e2337) p2338 w2339 mod2340))) (and rest2342 (cons first2341 rest2342)))))) ((null? e2337) (quote ())) ((syntax-object?1115 e2337) (match-each2308 (syntax-object-expression1116 e2337) p2338 (join-wraps1150 w2339 (syntax-object-wrap1117 e2337)) (syntax-object-module1118 e2337))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2343 p2344) (cond ((eq? p2344 (quote any)) (list e2343)) ((syntax-object?1115 e2343) (match*2311 (let ((e2345 (syntax-object-expression1116 e2343))) (if (annotation? e2345) (annotation-expression e2345) e2345)) p2344 (syntax-object-wrap1117 e2343) (quote ()) (syntax-object-module1118 e2343))) (else (match*2311 (let ((e2346 e2343)) (if (annotation? e2346) (annotation-expression e2346) e2346)) p2344 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) (install-global-transformer (quote with-syntax) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if tmp2349 (apply (lambda (_2350 e12351 e22352) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12351 e22352))) tmp2349) ((lambda (tmp2354) (if tmp2354 (apply (lambda (_2355 out2356 in2357 e12358 e22359) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2357 (quote ()) (list out2356 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12358 e22359))))) tmp2354) ((lambda (tmp2361) (if tmp2361 (apply (lambda (_2362 out2363 in2364 e12365 e22366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2364) (quote ()) (list out2363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12365 e22366))))) tmp2361) (syntax-error tmp2348))) (syntax-dispatch tmp2348 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2348 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2348 (quote (any () any . each-any))))) x2347))) (install-global-transformer (quote syntax-rules) (lambda (x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 k2374 keyword2375 pattern2376 template2377) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2374 (map (lambda (tmp2380 tmp2379) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2379) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2380))) template2377 pattern2376)))))) tmp2372) (syntax-error tmp2371))) (syntax-dispatch tmp2371 (quote (any each-any . #(each ((any . any) any))))))) x2370))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index e6eaf9384..a5ea0ac60 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -256,6 +256,9 @@ +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (let () (define-syntax define-structure (lambda (x) diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm index 875229f6a..7b1c11cc1 100644 --- a/module/ice-9/r4rs.scm +++ b/module/ice-9/r4rs.scm @@ -17,6 +17,9 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + ;;;; apply and call-with-current-continuation From 0ee32d0131b49ee0661669b7a0b595d0a6565de4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 23:56:40 +0200 Subject: [PATCH 073/375] allow docstrings with internal definitions * module/Makefile.am (SCHEME_LANG_SOURCES): * module/language/scheme/expand.scm: Remove expand.scm, we don't need it any more. * module/ice-9/psyntax.scm (build-lambda, chi-lambda-clause): Support docstrings with internal definitions. What are Scheme people thinking these days? * module/ice-9/psyntax-pp.scm: Regenerated. --- module/Makefile.am | 2 +- module/ice-9/psyntax-pp.scm | 22 +-- module/ice-9/psyntax.scm | 14 +- module/language/scheme/expand.scm | 306 ------------------------------ 4 files changed, 23 insertions(+), 321 deletions(-) delete mode 100644 module/language/scheme/expand.scm diff --git a/module/Makefile.am b/module/Makefile.am index 2322828d7..28372c7e7 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -62,7 +62,7 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm SCHEME_LANG_SOURCES = \ - language/scheme/amatch.scm language/scheme/expand.scm \ + language/scheme/amatch.scm \ language/scheme/compile-ghil.scm language/scheme/spec.scm \ language/scheme/inline.scm diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index e402cddf0..aa637415e 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1180 (lambda (vars1379) (let lvl1380 ((vars1381 vars1379) (ls1382 (quote ())) (w1383 (quote (())))) (cond ((pair? vars1381) (lvl1380 (cdr vars1381) (cons (wrap1159 (car vars1381) w1383 #f) ls1382) w1383)) ((id?1131 vars1381) (cons (wrap1159 vars1381 w1383 #f) ls1382)) ((null? vars1381) ls1382) ((syntax-object?1115 vars1381) (lvl1380 (syntax-object-expression1116 vars1381) ls1382 (join-wraps1150 w1383 (syntax-object-wrap1117 vars1381)))) ((annotation? vars1381) (lvl1380 (annotation-expression vars1381) ls1382 w1383)) (else (cons vars1381 ls1382)))))) (gen-var1179 (lambda (id1384) (let ((id1385 (if (syntax-object?1115 id1384) (syntax-object-expression1116 id1384) id1384))) (if (annotation? id1385) (build-annotated1108 (annotation-source id1385) (gensym (symbol->string (annotation-expression id1385)))) (build-annotated1108 #f (gensym (symbol->string id1385))))))) (strip1178 (lambda (x1386 w1387) (if (memq (quote top) (wrap-marks1134 w1387)) (if (or (annotation? x1386) (and (pair? x1386) (annotation? (car x1386)))) (strip-annotation1177 x1386 #f) x1386) (let f1388 ((x1389 x1386)) (cond ((syntax-object?1115 x1389) (strip1178 (syntax-object-expression1116 x1389) (syntax-object-wrap1117 x1389))) ((pair? x1389) (let ((a1390 (f1388 (car x1389))) (d1391 (f1388 (cdr x1389)))) (if (and (eq? a1390 (car x1389)) (eq? d1391 (cdr x1389))) x1389 (cons a1390 d1391)))) ((vector? x1389) (let ((old1392 (vector->list x1389))) (let ((new1393 (map f1388 old1392))) (if (andmap eq? old1392 new1393) x1389 (list->vector new1393))))) (else x1389)))))) (strip-annotation1177 (lambda (x1394 parent1395) (cond ((pair? x1394) (let ((new1396 (cons #f #f))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1396)) (set-car! new1396 (strip-annotation1177 (car x1394) #f)) (set-cdr! new1396 (strip-annotation1177 (cdr x1394) #f)) new1396))) ((annotation? x1394) (or (annotation-stripped x1394) (strip-annotation1177 (annotation-expression x1394) x1394))) ((vector? x1394) (let ((new1397 (make-vector (vector-length x1394)))) (begin (if parent1395 (set-annotation-stripped! parent1395 new1397)) (let loop1398 ((i1399 (- (vector-length x1394) 1))) (unless (fx<1101 i1399 0) (vector-set! new1397 i1399 (strip-annotation1177 (vector-ref x1394 i1399) #f)) (loop1398 (fx-1099 i1399 1)))) new1397))) (else x1394)))) (ellipsis?1176 (lambda (x1400) (and (nonsymbol-id?1130 x1400) (free-id=?1154 x1400 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1175 (lambda () (build-annotated1108 #f (list (build-annotated1108 #f (quote void)))))) (eval-local-transformer1174 (lambda (expanded1401 mod1402) (let ((p1403 (local-eval-hook1103 expanded1401 mod1402))) (if (procedure? p1403) p1403 (syntax-error p1403 "nonprocedure transformer"))))) (chi-local-syntax1173 (lambda (rec?1404 e1405 r1406 w1407 s1408 mod1409 k1410) ((lambda (tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (_1413 id1414 val1415 e11416 e21417) (let ((ids1418 id1414)) (if (not (valid-bound-ids?1156 ids1418)) (syntax-error e1405 "duplicate bound keyword in") (let ((labels1420 (gen-labels1137 ids1418))) (let ((new-w1421 (make-binding-wrap1148 ids1418 labels1420 w1407))) (k1410 (cons e11416 e21417) (extend-env1125 labels1420 (let ((w1423 (if rec?1404 new-w1421 w1407)) (trans-r1424 (macros-only-env1127 r1406))) (map (lambda (x1425) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1425 trans-r1424 w1423 mod1409) mod1409))) val1415)) r1406) new-w1421 s1408 mod1409)))))) tmp1412) ((lambda (_1427) (syntax-error (source-wrap1160 e1405 w1407 s1408 mod1409))) tmp1411))) (syntax-dispatch tmp1411 (quote (any #(each (any any)) any . each-any))))) e1405))) (chi-lambda-clause1172 (lambda (e1428 c1429 r1430 w1431 mod1432 k1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (id1436 e11437 e21438) (let ((ids1439 id1436)) (if (not (valid-bound-ids?1156 ids1439)) (syntax-error e1428 "invalid parameter list in") (let ((labels1441 (gen-labels1137 ids1439)) (new-vars1442 (map gen-var1179 ids1439))) (k1433 new-vars1442 (chi-body1171 (cons e11437 e21438) e1428 (extend-var-env1126 labels1441 new-vars1442 r1430) (make-binding-wrap1148 ids1439 labels1441 w1431) mod1432)))))) tmp1435) ((lambda (tmp1444) (if tmp1444 (apply (lambda (ids1445 e11446 e21447) (let ((old-ids1448 (lambda-var-list1180 ids1445))) (if (not (valid-bound-ids?1156 old-ids1448)) (syntax-error e1428 "invalid parameter list in") (let ((labels1449 (gen-labels1137 old-ids1448)) (new-vars1450 (map gen-var1179 old-ids1448))) (k1433 (let f1451 ((ls11452 (cdr new-vars1450)) (ls21453 (car new-vars1450))) (if (null? ls11452) ls21453 (f1451 (cdr ls11452) (cons (car ls11452) ls21453)))) (chi-body1171 (cons e11446 e21447) e1428 (extend-var-env1126 labels1449 new-vars1450 r1430) (make-binding-wrap1148 old-ids1448 labels1449 w1431) mod1432)))))) tmp1444) ((lambda (_1455) (syntax-error e1428)) tmp1434))) (syntax-dispatch tmp1434 (quote (any any . each-any)))))) (syntax-dispatch tmp1434 (quote (each-any any . each-any))))) c1429))) (chi-body1171 (lambda (body1456 outer-form1457 r1458 w1459 mod1460) (let ((r1461 (cons (quote ("placeholder" placeholder)) r1458))) (let ((ribcage1462 (make-ribcage1138 (quote ()) (quote ()) (quote ())))) (let ((w1463 (make-wrap1133 (wrap-marks1134 w1459) (cons ribcage1462 (wrap-subst1135 w1459))))) (let parse1464 ((body1465 (map (lambda (x1471) (cons r1461 (wrap1159 x1471 w1463 mod1460))) body1456)) (ids1466 (quote ())) (labels1467 (quote ())) (vars1468 (quote ())) (vals1469 (quote ())) (bindings1470 (quote ()))) (if (null? body1465) (syntax-error outer-form1457 "no expressions in body") (let ((e1472 (cdar body1465)) (er1473 (caar body1465))) (call-with-values (lambda () (syntax-type1165 e1472 er1473 (quote (())) #f ribcage1462 mod1460)) (lambda (type1474 value1475 e1476 w1477 s1478 mod1479) (let ((t1480 type1474)) (if (memv t1480 (quote (define-form))) (let ((id1481 (wrap1159 value1475 w1477 mod1479)) (label1482 (gen-label1136))) (let ((var1483 (gen-var1179 id1481))) (begin (extend-ribcage!1147 ribcage1462 id1481 label1482) (parse1464 (cdr body1465) (cons id1481 ids1466) (cons label1482 labels1467) (cons var1483 vars1468) (cons (cons er1473 (wrap1159 e1476 w1477 mod1479)) vals1469) (cons (cons (quote lexical) var1483) bindings1470))))) (if (memv t1480 (quote (define-syntax-form))) (let ((id1484 (wrap1159 value1475 w1477 mod1479)) (label1485 (gen-label1136))) (begin (extend-ribcage!1147 ribcage1462 id1484 label1485) (parse1464 (cdr body1465) (cons id1484 ids1466) (cons label1485 labels1467) vars1468 vals1469 (cons (cons (quote macro) (cons er1473 (wrap1159 e1476 w1477 mod1479))) bindings1470)))) (if (memv t1480 (quote (begin-form))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (_1488 e11489) (parse1464 (let f1490 ((forms1491 e11489)) (if (null? forms1491) (cdr body1465) (cons (cons er1473 (wrap1159 (car forms1491) w1477 mod1479)) (f1490 (cdr forms1491))))) ids1466 labels1467 vars1468 vals1469 bindings1470)) tmp1487) (syntax-error tmp1486))) (syntax-dispatch tmp1486 (quote (any . each-any))))) e1476) (if (memv t1480 (quote (local-syntax-form))) (chi-local-syntax1173 value1475 e1476 er1473 w1477 s1478 mod1479 (lambda (forms1493 er1494 w1495 s1496 mod1497) (parse1464 (let f1498 ((forms1499 forms1493)) (if (null? forms1499) (cdr body1465) (cons (cons er1494 (wrap1159 (car forms1499) w1495 mod1497)) (f1498 (cdr forms1499))))) ids1466 labels1467 vars1468 vals1469 bindings1470))) (if (null? ids1466) (build-sequence1110 #f (map (lambda (x1500) (chi1167 (cdr x1500) (car x1500) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))) (begin (if (not (valid-bound-ids?1156 ids1466)) (syntax-error outer-form1457 "invalid or duplicate identifier in definition")) (let loop1501 ((bs1502 bindings1470) (er-cache1503 #f) (r-cache1504 #f)) (if (not (null? bs1502)) (let ((b1505 (car bs1502))) (if (eq? (car b1505) (quote macro)) (let ((er1506 (cadr b1505))) (let ((r-cache1507 (if (eq? er1506 er-cache1503) r-cache1504 (macros-only-env1127 er1506)))) (begin (set-cdr! b1505 (eval-local-transformer1174 (chi1167 (cddr b1505) r-cache1507 (quote (())) mod1479) mod1479)) (loop1501 (cdr bs1502) er1506 r-cache1507)))) (loop1501 (cdr bs1502) er-cache1503 r-cache1504))))) (set-cdr! r1461 (extend-env1125 labels1467 bindings1470 (cdr r1461))) (build-letrec1113 #f vars1468 (map (lambda (x1508) (chi1167 (cdr x1508) (car x1508) (quote (())) mod1479)) vals1469) (build-sequence1110 #f (map (lambda (x1509) (chi1167 (cdr x1509) (car x1509) (quote (())) mod1479)) (cons (cons er1473 (source-wrap1160 e1476 w1477 s1478 mod1479)) (cdr body1465)))))))))))))))))))))) (chi-macro1170 (lambda (p1510 e1511 r1512 w1513 rib1514 mod1515) (letrec ((rebuild-macro-output1516 (lambda (x1517 m1518) (cond ((pair? x1517) (cons (rebuild-macro-output1516 (car x1517) m1518) (rebuild-macro-output1516 (cdr x1517) m1518))) ((syntax-object?1115 x1517) (let ((w1519 (syntax-object-wrap1117 x1517))) (let ((ms1520 (wrap-marks1134 w1519)) (s1521 (wrap-subst1135 w1519))) (if (and (pair? ms1520) (eq? (car ms1520) #f)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cdr ms1520) (if rib1514 (cons rib1514 (cdr s1521)) (cdr s1521))) (syntax-object-module1118 x1517)) (make-syntax-object1114 (syntax-object-expression1116 x1517) (make-wrap1133 (cons m1518 ms1520) (if rib1514 (cons rib1514 (cons (quote shift) s1521)) (cons (quote shift) s1521))) (let ((pmod1522 (procedure-module p1510))) (if pmod1522 (cons (quote hygiene) (module-name pmod1522)) (quote (hygiene guile))))))))) ((vector? x1517) (let ((n1523 (vector-length x1517))) (let ((v1524 (make-vector n1523))) (let doloop1525 ((i1526 0)) (if (fx=1100 i1526 n1523) v1524 (begin (vector-set! v1524 i1526 (rebuild-macro-output1516 (vector-ref x1517 i1526) m1518)) (doloop1525 (fx+1098 i1526 1)))))))) ((symbol? x1517) (syntax-error x1517 "encountered raw symbol in macro output")) (else x1517))))) (rebuild-macro-output1516 (p1510 (wrap1159 e1511 (anti-mark1146 w1513) mod1515)) (string #\m))))) (chi-application1169 (lambda (x1527 e1528 r1529 w1530 s1531 mod1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (e01535 e11536) (build-annotated1108 s1531 (cons x1527 (map (lambda (e1537) (chi1167 e1537 r1529 w1530 mod1532)) e11536)))) tmp1534) (syntax-error tmp1533))) (syntax-dispatch tmp1533 (quote (any . each-any))))) e1528))) (chi-expr1168 (lambda (type1539 value1540 e1541 r1542 w1543 s1544 mod1545) (let ((t1546 type1539)) (if (memv t1546 (quote (lexical))) (build-annotated1108 s1544 value1540) (if (memv t1546 (quote (core external-macro))) (value1540 e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (module-ref))) (call-with-values (lambda () (value1540 e1541)) (lambda (id1547 mod1548) (build-annotated1108 s1544 (if mod1548 (make-module-ref (cdr mod1548) id1547 (car mod1548)) (make-module-ref mod1548 id1547 (quote bare)))))) (if (memv t1546 (quote (lexical-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1541)) value1540) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (global-call))) (chi-application1169 (build-annotated1108 (source-annotation1122 (car e1541)) (if (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545) (make-module-ref (cdr (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545)) value1540 (car (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545))) (make-module-ref (if (syntax-object?1115 (car e1541)) (syntax-object-module1118 (car e1541)) mod1545) value1540 (quote bare)))) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (constant))) (build-data1109 s1544 (strip1178 (source-wrap1160 e1541 w1543 s1544 mod1545) (quote (())))) (if (memv t1546 (quote (global))) (build-annotated1108 s1544 (if mod1545 (make-module-ref (cdr mod1545) value1540 (car mod1545)) (make-module-ref mod1545 value1540 (quote bare)))) (if (memv t1546 (quote (call))) (chi-application1169 (chi1167 (car e1541) r1542 w1543 mod1545) e1541 r1542 w1543 s1544 mod1545) (if (memv t1546 (quote (begin-form))) ((lambda (tmp1549) ((lambda (tmp1550) (if tmp1550 (apply (lambda (_1551 e11552 e21553) (chi-sequence1161 (cons e11552 e21553) r1542 w1543 s1544 mod1545)) tmp1550) (syntax-error tmp1549))) (syntax-dispatch tmp1549 (quote (any any . each-any))))) e1541) (if (memv t1546 (quote (local-syntax-form))) (chi-local-syntax1173 value1540 e1541 r1542 w1543 s1544 mod1545 chi-sequence1161) (if (memv t1546 (quote (eval-when-form))) ((lambda (tmp1555) ((lambda (tmp1556) (if tmp1556 (apply (lambda (_1557 x1558 e11559 e21560) (let ((when-list1561 (chi-when-list1164 e1541 x1558 w1543))) (if (memq (quote eval) when-list1561) (chi-sequence1161 (cons e11559 e21560) r1542 w1543 s1544 mod1545) (chi-void1175)))) tmp1556) (syntax-error tmp1555))) (syntax-dispatch tmp1555 (quote (any each-any any . each-any))))) e1541) (if (memv t1546 (quote (define-form define-syntax-form))) (syntax-error (wrap1159 value1540 w1543 mod1545) "invalid context for definition of") (if (memv t1546 (quote (syntax))) (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545) "reference to pattern variable outside syntax form") (if (memv t1546 (quote (displaced-lexical))) (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545) "reference to identifier outside its scope") (syntax-error (source-wrap1160 e1541 w1543 s1544 mod1545))))))))))))))))))) (chi1167 (lambda (e1564 r1565 w1566 mod1567) (call-with-values (lambda () (syntax-type1165 e1564 r1565 w1566 #f #f mod1567)) (lambda (type1568 value1569 e1570 w1571 s1572 mod1573) (chi-expr1168 type1568 value1569 e1570 r1565 w1571 s1572 mod1573))))) (chi-top1166 (lambda (e1574 r1575 w1576 m1577 esew1578 mod1579) (call-with-values (lambda () (syntax-type1165 e1574 r1575 w1576 #f #f mod1579)) (lambda (type1587 value1588 e1589 w1590 s1591 mod1592) (let ((t1593 type1587)) (if (memv t1593 (quote (begin-form))) ((lambda (tmp1594) ((lambda (tmp1595) (if tmp1595 (apply (lambda (_1596) (chi-void1175)) tmp1595) ((lambda (tmp1597) (if tmp1597 (apply (lambda (_1598 e11599 e21600) (chi-top-sequence1162 (cons e11599 e21600) r1575 w1590 s1591 m1577 esew1578 mod1592)) tmp1597) (syntax-error tmp1594))) (syntax-dispatch tmp1594 (quote (any any . each-any)))))) (syntax-dispatch tmp1594 (quote (any))))) e1589) (if (memv t1593 (quote (local-syntax-form))) (chi-local-syntax1173 value1588 e1589 r1575 w1590 s1591 mod1592 (lambda (body1602 r1603 w1604 s1605 mod1606) (chi-top-sequence1162 body1602 r1603 w1604 s1605 m1577 esew1578 mod1606))) (if (memv t1593 (quote (eval-when-form))) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (_1609 x1610 e11611 e21612) (let ((when-list1613 (chi-when-list1164 e1589 x1610 w1590)) (body1614 (cons e11611 e21612))) (cond ((eq? m1577 (quote e)) (if (memq (quote eval) when-list1613) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote e) (quote (eval)) mod1592) (chi-void1175))) ((memq (quote load) when-list1613) (if (or (memq (quote compile) when-list1613) (and (eq? m1577 (quote c&e)) (memq (quote eval) when-list1613))) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote c&e) (quote (compile load)) mod1592) (if (memq m1577 (quote (c c&e))) (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote c) (quote (load)) mod1592) (chi-void1175)))) ((or (memq (quote compile) when-list1613) (and (eq? m1577 (quote c&e)) (memq (quote eval) when-list1613))) (top-level-eval-hook1102 (chi-top-sequence1162 body1614 r1575 w1590 s1591 (quote e) (quote (eval)) mod1592) mod1592) (chi-void1175)) (else (chi-void1175))))) tmp1608) (syntax-error tmp1607))) (syntax-dispatch tmp1607 (quote (any each-any any . each-any))))) e1589) (if (memv t1593 (quote (define-syntax-form))) (let ((n1617 (id-var-name1153 value1588 w1590)) (r1618 (macros-only-env1127 r1575))) (let ((t1619 m1577)) (if (memv t1619 (quote (c))) (if (memq (quote compile) esew1578) (let ((e1620 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)))) (begin (top-level-eval-hook1102 e1620 mod1592) (if (memq (quote load) esew1578) e1620 (chi-void1175)))) (if (memq (quote load) esew1578) (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)) (chi-void1175))) (if (memv t1619 (quote (c&e))) (let ((e1621 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)))) (begin (top-level-eval-hook1102 e1621 mod1592) e1621)) (begin (if (memq (quote eval) esew1578) (top-level-eval-hook1102 (chi-install-global1163 n1617 (chi1167 e1589 r1618 w1590 mod1592)) mod1592)) (chi-void1175)))))) (if (memv t1593 (quote (define-form))) (let ((n1622 (id-var-name1153 value1588 w1590))) (let ((type1623 (binding-type1123 (lookup1128 n1622 r1575 mod1592)))) (let ((t1624 type1623)) (if (memv t1624 (quote (global))) (let ((x1625 (build-annotated1108 s1591 (list (quote define) n1622 (chi1167 e1589 r1575 w1590 mod1592))))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1625 mod1592)) x1625)) (if (memv t1624 (quote (displaced-lexical))) (syntax-error (wrap1159 value1588 w1590 mod1592) "identifier out of context") (if (memv t1624 (quote (core macro module-ref))) (begin (remove-global-definition-hook1106 n1622) (let ((x1626 (build-annotated1108 s1591 (list (quote define) n1622 (chi1167 e1589 r1575 w1590 mod1592))))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1626 mod1592)) x1626))) (syntax-error (wrap1159 value1588 w1590 mod1592) "cannot define keyword at top level"))))))) (let ((x1627 (chi-expr1168 type1587 value1588 e1589 r1575 w1590 s1591 mod1592))) (begin (if (eq? m1577 (quote c&e)) (top-level-eval-hook1102 x1627 mod1592)) x1627)))))))))))) (syntax-type1165 (lambda (e1628 r1629 w1630 s1631 rib1632 mod1633) (cond ((symbol? e1628) (let ((n1634 (id-var-name1153 e1628 w1630))) (let ((b1635 (lookup1128 n1634 r1629 mod1633))) (let ((type1636 (binding-type1123 b1635))) (let ((t1637 type1636)) (if (memv t1637 (quote (lexical))) (values type1636 (binding-value1124 b1635) e1628 w1630 s1631 mod1633) (if (memv t1637 (quote (global))) (values type1636 n1634 e1628 w1630 s1631 mod1633) (if (memv t1637 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1635) e1628 r1629 w1630 rib1632 mod1633) r1629 (quote (())) s1631 rib1632 mod1633) (values type1636 (binding-value1124 b1635) e1628 w1630 s1631 mod1633))))))))) ((pair? e1628) (let ((first1638 (car e1628))) (if (id?1131 first1638) (let ((n1639 (id-var-name1153 first1638 w1630))) (let ((b1640 (lookup1128 n1639 r1629 (or (and (syntax-object?1115 first1638) (syntax-object-module1118 first1638)) mod1633)))) (let ((type1641 (binding-type1123 b1640))) (let ((t1642 type1641)) (if (memv t1642 (quote (lexical))) (values (quote lexical-call) (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (global))) (values (quote global-call) n1639 e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (macro))) (syntax-type1165 (chi-macro1170 (binding-value1124 b1640) e1628 r1629 w1630 rib1632 mod1633) r1629 (quote (())) s1631 rib1632 mod1633) (if (memv t1642 (quote (core external-macro module-ref))) (values type1641 (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1124 b1640) e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (begin))) (values (quote begin-form) #f e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (eval-when))) (values (quote eval-when-form) #f e1628 w1630 s1631 mod1633) (if (memv t1642 (quote (define))) ((lambda (tmp1643) ((lambda (tmp1644) (if (if tmp1644 (apply (lambda (_1645 name1646 val1647) (id?1131 name1646)) tmp1644) #f) (apply (lambda (_1648 name1649 val1650) (values (quote define-form) name1649 val1650 w1630 s1631 mod1633)) tmp1644) ((lambda (tmp1651) (if (if tmp1651 (apply (lambda (_1652 name1653 args1654 e11655 e21656) (and (id?1131 name1653) (valid-bound-ids?1156 (lambda-var-list1180 args1654)))) tmp1651) #f) (apply (lambda (_1657 name1658 args1659 e11660 e21661) (values (quote define-form) (wrap1159 name1658 w1630 mod1633) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1159 (cons args1659 (cons e11660 e21661)) w1630 mod1633)) (quote (())) s1631 mod1633)) tmp1651) ((lambda (tmp1663) (if (if tmp1663 (apply (lambda (_1664 name1665) (id?1131 name1665)) tmp1663) #f) (apply (lambda (_1666 name1667) (values (quote define-form) (wrap1159 name1667 w1630 mod1633) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1631 mod1633)) tmp1663) (syntax-error tmp1643))) (syntax-dispatch tmp1643 (quote (any any)))))) (syntax-dispatch tmp1643 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1643 (quote (any any any))))) e1628) (if (memv t1642 (quote (define-syntax))) ((lambda (tmp1668) ((lambda (tmp1669) (if (if tmp1669 (apply (lambda (_1670 name1671 val1672) (id?1131 name1671)) tmp1669) #f) (apply (lambda (_1673 name1674 val1675) (values (quote define-syntax-form) name1674 val1675 w1630 s1631 mod1633)) tmp1669) (syntax-error tmp1668))) (syntax-dispatch tmp1668 (quote (any any any))))) e1628) (values (quote call) #f e1628 w1630 s1631 mod1633)))))))))))))) (values (quote call) #f e1628 w1630 s1631 mod1633)))) ((syntax-object?1115 e1628) (syntax-type1165 (syntax-object-expression1116 e1628) r1629 (join-wraps1150 w1630 (syntax-object-wrap1117 e1628)) #f rib1632 (or (syntax-object-module1118 e1628) mod1633))) ((annotation? e1628) (syntax-type1165 (annotation-expression e1628) r1629 w1630 (annotation-source e1628) rib1632 mod1633)) ((self-evaluating? e1628) (values (quote constant) #f e1628 w1630 s1631 mod1633)) (else (values (quote other) #f e1628 w1630 s1631 mod1633))))) (chi-when-list1164 (lambda (e1676 when-list1677 w1678) (let f1679 ((when-list1680 when-list1677) (situations1681 (quote ()))) (if (null? when-list1680) situations1681 (f1679 (cdr when-list1680) (cons (let ((x1682 (car when-list1680))) (cond ((free-id=?1154 x1682 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1154 x1682 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1154 x1682 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1159 x1682 w1678 #f) "invalid eval-when situation")))) situations1681)))))) (chi-install-global1163 (lambda (name1683 e1684) (build-annotated1108 #f (list (build-annotated1108 #f (quote install-global-transformer)) (build-data1109 #f name1683) e1684)))) (chi-top-sequence1162 (lambda (body1685 r1686 w1687 s1688 m1689 esew1690 mod1691) (build-sequence1110 s1688 (let dobody1692 ((body1693 body1685) (r1694 r1686) (w1695 w1687) (m1696 m1689) (esew1697 esew1690) (mod1698 mod1691)) (if (null? body1693) (quote ()) (let ((first1699 (chi-top1166 (car body1693) r1694 w1695 m1696 esew1697 mod1698))) (cons first1699 (dobody1692 (cdr body1693) r1694 w1695 m1696 esew1697 mod1698)))))))) (chi-sequence1161 (lambda (body1700 r1701 w1702 s1703 mod1704) (build-sequence1110 s1703 (let dobody1705 ((body1706 body1700) (r1707 r1701) (w1708 w1702) (mod1709 mod1704)) (if (null? body1706) (quote ()) (let ((first1710 (chi1167 (car body1706) r1707 w1708 mod1709))) (cons first1710 (dobody1705 (cdr body1706) r1707 w1708 mod1709)))))))) (source-wrap1160 (lambda (x1711 w1712 s1713 defmod1714) (wrap1159 (if s1713 (make-annotation x1711 s1713 #f) x1711) w1712 defmod1714))) (wrap1159 (lambda (x1715 w1716 defmod1717) (cond ((and (null? (wrap-marks1134 w1716)) (null? (wrap-subst1135 w1716))) x1715) ((syntax-object?1115 x1715) (make-syntax-object1114 (syntax-object-expression1116 x1715) (join-wraps1150 w1716 (syntax-object-wrap1117 x1715)) (syntax-object-module1118 x1715))) ((null? x1715) x1715) (else (make-syntax-object1114 x1715 w1716 defmod1717))))) (bound-id-member?1158 (lambda (x1718 list1719) (and (not (null? list1719)) (or (bound-id=?1155 x1718 (car list1719)) (bound-id-member?1158 x1718 (cdr list1719)))))) (distinct-bound-ids?1157 (lambda (ids1720) (let distinct?1721 ((ids1722 ids1720)) (or (null? ids1722) (and (not (bound-id-member?1158 (car ids1722) (cdr ids1722))) (distinct?1721 (cdr ids1722))))))) (valid-bound-ids?1156 (lambda (ids1723) (and (let all-ids?1724 ((ids1725 ids1723)) (or (null? ids1725) (and (id?1131 (car ids1725)) (all-ids?1724 (cdr ids1725))))) (distinct-bound-ids?1157 ids1723)))) (bound-id=?1155 (lambda (i1726 j1727) (if (and (syntax-object?1115 i1726) (syntax-object?1115 j1727)) (and (eq? (let ((e1728 (syntax-object-expression1116 i1726))) (if (annotation? e1728) (annotation-expression e1728) e1728)) (let ((e1729 (syntax-object-expression1116 j1727))) (if (annotation? e1729) (annotation-expression e1729) e1729))) (same-marks?1152 (wrap-marks1134 (syntax-object-wrap1117 i1726)) (wrap-marks1134 (syntax-object-wrap1117 j1727)))) (eq? (let ((e1730 i1726)) (if (annotation? e1730) (annotation-expression e1730) e1730)) (let ((e1731 j1727)) (if (annotation? e1731) (annotation-expression e1731) e1731)))))) (free-id=?1154 (lambda (i1732 j1733) (and (eq? (let ((x1734 i1732)) (let ((e1735 (if (syntax-object?1115 x1734) (syntax-object-expression1116 x1734) x1734))) (if (annotation? e1735) (annotation-expression e1735) e1735))) (let ((x1736 j1733)) (let ((e1737 (if (syntax-object?1115 x1736) (syntax-object-expression1116 x1736) x1736))) (if (annotation? e1737) (annotation-expression e1737) e1737)))) (eq? (id-var-name1153 i1732 (quote (()))) (id-var-name1153 j1733 (quote (()))))))) (id-var-name1153 (lambda (id1738 w1739) (letrec ((search-vector-rib1742 (lambda (sym1748 subst1749 marks1750 symnames1751 ribcage1752) (let ((n1753 (vector-length symnames1751))) (let f1754 ((i1755 0)) (cond ((fx=1100 i1755 n1753) (search1740 sym1748 (cdr subst1749) marks1750)) ((and (eq? (vector-ref symnames1751 i1755) sym1748) (same-marks?1152 marks1750 (vector-ref (ribcage-marks1141 ribcage1752) i1755))) (values (vector-ref (ribcage-labels1142 ribcage1752) i1755) marks1750)) (else (f1754 (fx+1098 i1755 1)))))))) (search-list-rib1741 (lambda (sym1756 subst1757 marks1758 symnames1759 ribcage1760) (let f1761 ((symnames1762 symnames1759) (i1763 0)) (cond ((null? symnames1762) (search1740 sym1756 (cdr subst1757) marks1758)) ((and (eq? (car symnames1762) sym1756) (same-marks?1152 marks1758 (list-ref (ribcage-marks1141 ribcage1760) i1763))) (values (list-ref (ribcage-labels1142 ribcage1760) i1763) marks1758)) (else (f1761 (cdr symnames1762) (fx+1098 i1763 1))))))) (search1740 (lambda (sym1764 subst1765 marks1766) (if (null? subst1765) (values #f marks1766) (let ((fst1767 (car subst1765))) (if (eq? fst1767 (quote shift)) (search1740 sym1764 (cdr subst1765) (cdr marks1766)) (let ((symnames1768 (ribcage-symnames1140 fst1767))) (if (vector? symnames1768) (search-vector-rib1742 sym1764 subst1765 marks1766 symnames1768 fst1767) (search-list-rib1741 sym1764 subst1765 marks1766 symnames1768 fst1767))))))))) (cond ((symbol? id1738) (or (call-with-values (lambda () (search1740 id1738 (wrap-subst1135 w1739) (wrap-marks1134 w1739))) (lambda (x1770 . ignore1769) x1770)) id1738)) ((syntax-object?1115 id1738) (let ((id1771 (let ((e1773 (syntax-object-expression1116 id1738))) (if (annotation? e1773) (annotation-expression e1773) e1773))) (w11772 (syntax-object-wrap1117 id1738))) (let ((marks1774 (join-marks1151 (wrap-marks1134 w1739) (wrap-marks1134 w11772)))) (call-with-values (lambda () (search1740 id1771 (wrap-subst1135 w1739) marks1774)) (lambda (new-id1775 marks1776) (or new-id1775 (call-with-values (lambda () (search1740 id1771 (wrap-subst1135 w11772) marks1776)) (lambda (x1778 . ignore1777) x1778)) id1771)))))) ((annotation? id1738) (let ((id1779 (let ((e1780 id1738)) (if (annotation? e1780) (annotation-expression e1780) e1780)))) (or (call-with-values (lambda () (search1740 id1779 (wrap-subst1135 w1739) (wrap-marks1134 w1739))) (lambda (x1782 . ignore1781) x1782)) id1779))) (else (error-hook1104 (quote id-var-name) "invalid id" id1738)))))) (same-marks?1152 (lambda (x1783 y1784) (or (eq? x1783 y1784) (and (not (null? x1783)) (not (null? y1784)) (eq? (car x1783) (car y1784)) (same-marks?1152 (cdr x1783) (cdr y1784)))))) (join-marks1151 (lambda (m11785 m21786) (smart-append1149 m11785 m21786))) (join-wraps1150 (lambda (w11787 w21788) (let ((m11789 (wrap-marks1134 w11787)) (s11790 (wrap-subst1135 w11787))) (if (null? m11789) (if (null? s11790) w21788 (make-wrap1133 (wrap-marks1134 w21788) (smart-append1149 s11790 (wrap-subst1135 w21788)))) (make-wrap1133 (smart-append1149 m11789 (wrap-marks1134 w21788)) (smart-append1149 s11790 (wrap-subst1135 w21788))))))) (smart-append1149 (lambda (m11791 m21792) (if (null? m21792) m11791 (append m11791 m21792)))) (make-binding-wrap1148 (lambda (ids1793 labels1794 w1795) (if (null? ids1793) w1795 (make-wrap1133 (wrap-marks1134 w1795) (cons (let ((labelvec1796 (list->vector labels1794))) (let ((n1797 (vector-length labelvec1796))) (let ((symnamevec1798 (make-vector n1797)) (marksvec1799 (make-vector n1797))) (begin (let f1800 ((ids1801 ids1793) (i1802 0)) (if (not (null? ids1801)) (call-with-values (lambda () (id-sym-name&marks1132 (car ids1801) w1795)) (lambda (symname1803 marks1804) (begin (vector-set! symnamevec1798 i1802 symname1803) (vector-set! marksvec1799 i1802 marks1804) (f1800 (cdr ids1801) (fx+1098 i1802 1))))))) (make-ribcage1138 symnamevec1798 marksvec1799 labelvec1796))))) (wrap-subst1135 w1795)))))) (extend-ribcage!1147 (lambda (ribcage1805 id1806 label1807) (begin (set-ribcage-symnames!1143 ribcage1805 (cons (let ((e1808 (syntax-object-expression1116 id1806))) (if (annotation? e1808) (annotation-expression e1808) e1808)) (ribcage-symnames1140 ribcage1805))) (set-ribcage-marks!1144 ribcage1805 (cons (wrap-marks1134 (syntax-object-wrap1117 id1806)) (ribcage-marks1141 ribcage1805))) (set-ribcage-labels!1145 ribcage1805 (cons label1807 (ribcage-labels1142 ribcage1805)))))) (anti-mark1146 (lambda (w1809) (make-wrap1133 (cons #f (wrap-marks1134 w1809)) (cons (quote shift) (wrap-subst1135 w1809))))) (set-ribcage-labels!1145 (lambda (x1810 update1811) (vector-set! x1810 3 update1811))) (set-ribcage-marks!1144 (lambda (x1812 update1813) (vector-set! x1812 2 update1813))) (set-ribcage-symnames!1143 (lambda (x1814 update1815) (vector-set! x1814 1 update1815))) (ribcage-labels1142 (lambda (x1816) (vector-ref x1816 3))) (ribcage-marks1141 (lambda (x1817) (vector-ref x1817 2))) (ribcage-symnames1140 (lambda (x1818) (vector-ref x1818 1))) (ribcage?1139 (lambda (x1819) (and (vector? x1819) (= (vector-length x1819) 4) (eq? (vector-ref x1819 0) (quote ribcage))))) (make-ribcage1138 (lambda (symnames1820 marks1821 labels1822) (vector (quote ribcage) symnames1820 marks1821 labels1822))) (gen-labels1137 (lambda (ls1823) (if (null? ls1823) (quote ()) (cons (gen-label1136) (gen-labels1137 (cdr ls1823)))))) (gen-label1136 (lambda () (string #\i))) (wrap-subst1135 cdr) (wrap-marks1134 car) (make-wrap1133 cons) (id-sym-name&marks1132 (lambda (x1824 w1825) (if (syntax-object?1115 x1824) (values (let ((e1826 (syntax-object-expression1116 x1824))) (if (annotation? e1826) (annotation-expression e1826) e1826)) (join-marks1151 (wrap-marks1134 w1825) (wrap-marks1134 (syntax-object-wrap1117 x1824)))) (values (let ((e1827 x1824)) (if (annotation? e1827) (annotation-expression e1827) e1827)) (wrap-marks1134 w1825))))) (id?1131 (lambda (x1828) (cond ((symbol? x1828) #t) ((syntax-object?1115 x1828) (symbol? (let ((e1829 (syntax-object-expression1116 x1828))) (if (annotation? e1829) (annotation-expression e1829) e1829)))) ((annotation? x1828) (symbol? (annotation-expression x1828))) (else #f)))) (nonsymbol-id?1130 (lambda (x1830) (and (syntax-object?1115 x1830) (symbol? (let ((e1831 (syntax-object-expression1116 x1830))) (if (annotation? e1831) (annotation-expression e1831) e1831)))))) (global-extend1129 (lambda (type1832 sym1833 val1834) (put-global-definition-hook1105 sym1833 (cons type1832 val1834)))) (lookup1128 (lambda (x1835 r1836 mod1837) (cond ((assq x1835 r1836) => cdr) ((symbol? x1835) (or (get-global-definition-hook1107 x1835 mod1837) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1127 (lambda (r1838) (if (null? r1838) (quote ()) (let ((a1839 (car r1838))) (if (eq? (cadr a1839) (quote macro)) (cons a1839 (macros-only-env1127 (cdr r1838))) (macros-only-env1127 (cdr r1838))))))) (extend-var-env1126 (lambda (labels1840 vars1841 r1842) (if (null? labels1840) r1842 (extend-var-env1126 (cdr labels1840) (cdr vars1841) (cons (cons (car labels1840) (cons (quote lexical) (car vars1841))) r1842))))) (extend-env1125 (lambda (labels1843 bindings1844 r1845) (if (null? labels1843) r1845 (extend-env1125 (cdr labels1843) (cdr bindings1844) (cons (cons (car labels1843) (car bindings1844)) r1845))))) (binding-value1124 cdr) (binding-type1123 car) (source-annotation1122 (lambda (x1846) (cond ((annotation? x1846) (annotation-source x1846)) ((syntax-object?1115 x1846) (source-annotation1122 (syntax-object-expression1116 x1846))) (else #f)))) (set-syntax-object-module!1121 (lambda (x1847 update1848) (vector-set! x1847 3 update1848))) (set-syntax-object-wrap!1120 (lambda (x1849 update1850) (vector-set! x1849 2 update1850))) (set-syntax-object-expression!1119 (lambda (x1851 update1852) (vector-set! x1851 1 update1852))) (syntax-object-module1118 (lambda (x1853) (vector-ref x1853 3))) (syntax-object-wrap1117 (lambda (x1854) (vector-ref x1854 2))) (syntax-object-expression1116 (lambda (x1855) (vector-ref x1855 1))) (syntax-object?1115 (lambda (x1856) (and (vector? x1856) (= (vector-length x1856) 4) (eq? (vector-ref x1856 0) (quote syntax-object))))) (make-syntax-object1114 (lambda (expression1857 wrap1858 module1859) (vector (quote syntax-object) expression1857 wrap1858 module1859))) (build-letrec1113 (lambda (src1860 vars1861 val-exps1862 body-exp1863) (if (null? vars1861) (build-annotated1108 src1860 body-exp1863) (build-annotated1108 src1860 (list (quote letrec) (map list vars1861 val-exps1862) body-exp1863))))) (build-named-let1112 (lambda (src1864 vars1865 val-exps1866 body-exp1867) (if (null? vars1865) (build-annotated1108 src1864 body-exp1867) (build-annotated1108 src1864 (list (quote let) (car vars1865) (map list (cdr vars1865) val-exps1866) body-exp1867))))) (build-let1111 (lambda (src1868 vars1869 val-exps1870 body-exp1871) (if (null? vars1869) (build-annotated1108 src1868 body-exp1871) (build-annotated1108 src1868 (list (quote let) (map list vars1869 val-exps1870) body-exp1871))))) (build-sequence1110 (lambda (src1872 exps1873) (if (null? (cdr exps1873)) (build-annotated1108 src1872 (car exps1873)) (build-annotated1108 src1872 (cons (quote begin) exps1873))))) (build-data1109 (lambda (src1874 exp1875) (if (and (self-evaluating? exp1875) (not (vector? exp1875))) (build-annotated1108 src1874 exp1875) (build-annotated1108 src1874 (list (quote quote) exp1875))))) (build-annotated1108 (lambda (src1876 exp1877) (if (and src1876 (not (annotation? exp1877))) (make-annotation exp1877 src1876 #t) exp1877))) (get-global-definition-hook1107 (lambda (symbol1878 module1879) (let ((module1880 (if module1879 (resolve-module (cdr module1879)) (let ((mod1881 (current-module))) (begin (if mod1881 (warn "wha" symbol1878)) mod1881))))) (let ((v1882 (module-variable module1880 symbol1878))) (and v1882 (object-property v1882 (quote *sc-expander*))))))) (remove-global-definition-hook1106 (lambda (symbol1883) (let ((module1884 (current-module))) (let ((v1885 (module-local-variable module1884 symbol1883))) (if v1885 (let ((p1886 (assq (quote *sc-expander*) (object-properties v1885)))) (set-object-properties! v1885 (delq p1886 (object-properties v1885))))))))) (put-global-definition-hook1105 (lambda (symbol1887 binding1888) (let ((module1889 (current-module))) (let ((v1890 (or (module-variable module1889 symbol1887) (let ((v1891 (make-variable (gensym)))) (begin (module-add! module1889 symbol1887 v1891) v1891))))) (begin (if (not (variable-bound? v1890)) (variable-set! v1890 (gensym))) (set-object-property! v1890 (quote *sc-expander*) binding1888)))))) (error-hook1104 (lambda (who1892 why1893 what1894) (error who1892 "~a ~s" why1893 what1894))) (local-eval-hook1103 (lambda (x1895 mod1896) (primitive-eval (list noexpand1097 x1895)))) (top-level-eval-hook1102 (lambda (x1897 mod1898) (primitive-eval (list noexpand1097 x1897)))) (fx<1101 <) (fx=1100 =) (fx-1099 -) (fx+1098 +) (noexpand1097 "noexpand")) (begin (global-extend1129 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1129 (quote local-syntax) (quote let-syntax) #f) (global-extend1129 (quote core) (quote fluid-let-syntax) (lambda (e1899 r1900 w1901 s1902 mod1903) ((lambda (tmp1904) ((lambda (tmp1905) (if (if tmp1905 (apply (lambda (_1906 var1907 val1908 e11909 e21910) (valid-bound-ids?1156 var1907)) tmp1905) #f) (apply (lambda (_1912 var1913 val1914 e11915 e21916) (let ((names1917 (map (lambda (x1918) (id-var-name1153 x1918 w1901)) var1913))) (begin (for-each (lambda (id1920 n1921) (let ((t1922 (binding-type1123 (lookup1128 n1921 r1900 mod1903)))) (if (memv t1922 (quote (displaced-lexical))) (syntax-error (source-wrap1160 id1920 w1901 s1902 mod1903) "identifier out of context")))) var1913 names1917) (chi-body1171 (cons e11915 e21916) (source-wrap1160 e1899 w1901 s1902 mod1903) (extend-env1125 names1917 (let ((trans-r1925 (macros-only-env1127 r1900))) (map (lambda (x1926) (cons (quote macro) (eval-local-transformer1174 (chi1167 x1926 trans-r1925 w1901 mod1903) mod1903))) val1914)) r1900) w1901 mod1903)))) tmp1905) ((lambda (_1928) (syntax-error (source-wrap1160 e1899 w1901 s1902 mod1903))) tmp1904))) (syntax-dispatch tmp1904 (quote (any #(each (any any)) any . each-any))))) e1899))) (global-extend1129 (quote core) (quote quote) (lambda (e1929 r1930 w1931 s1932 mod1933) ((lambda (tmp1934) ((lambda (tmp1935) (if tmp1935 (apply (lambda (_1936 e1937) (build-data1109 s1932 (strip1178 e1937 w1931))) tmp1935) ((lambda (_1938) (syntax-error (source-wrap1160 e1929 w1931 s1932 mod1933))) tmp1934))) (syntax-dispatch tmp1934 (quote (any any))))) e1929))) (global-extend1129 (quote core) (quote syntax) (letrec ((regen1946 (lambda (x1947) (let ((t1948 (car x1947))) (if (memv t1948 (quote (ref))) (build-annotated1108 #f (cadr x1947)) (if (memv t1948 (quote (primitive))) (build-annotated1108 #f (cadr x1947)) (if (memv t1948 (quote (quote))) (build-data1109 #f (cadr x1947)) (if (memv t1948 (quote (lambda))) (build-annotated1108 #f (list (quote lambda) (cadr x1947) (regen1946 (caddr x1947)))) (if (memv t1948 (quote (map))) (let ((ls1949 (map regen1946 (cdr x1947)))) (build-annotated1108 #f (cons (if (fx=1100 (length ls1949) 2) (build-annotated1108 #f (quote map)) (build-annotated1108 #f (quote map))) ls1949))) (build-annotated1108 #f (cons (build-annotated1108 #f (car x1947)) (map regen1946 (cdr x1947)))))))))))) (gen-vector1945 (lambda (x1950) (cond ((eq? (car x1950) (quote list)) (cons (quote vector) (cdr x1950))) ((eq? (car x1950) (quote quote)) (list (quote quote) (list->vector (cadr x1950)))) (else (list (quote list->vector) x1950))))) (gen-append1944 (lambda (x1951 y1952) (if (equal? y1952 (quote (quote ()))) x1951 (list (quote append) x1951 y1952)))) (gen-cons1943 (lambda (x1953 y1954) (let ((t1955 (car y1954))) (if (memv t1955 (quote (quote))) (if (eq? (car x1953) (quote quote)) (list (quote quote) (cons (cadr x1953) (cadr y1954))) (if (eq? (cadr y1954) (quote ())) (list (quote list) x1953) (list (quote cons) x1953 y1954))) (if (memv t1955 (quote (list))) (cons (quote list) (cons x1953 (cdr y1954))) (list (quote cons) x1953 y1954)))))) (gen-map1942 (lambda (e1956 map-env1957) (let ((formals1958 (map cdr map-env1957)) (actuals1959 (map (lambda (x1960) (list (quote ref) (car x1960))) map-env1957))) (cond ((eq? (car e1956) (quote ref)) (car actuals1959)) ((andmap (lambda (x1961) (and (eq? (car x1961) (quote ref)) (memq (cadr x1961) formals1958))) (cdr e1956)) (cons (quote map) (cons (list (quote primitive) (car e1956)) (map (let ((r1962 (map cons formals1958 actuals1959))) (lambda (x1963) (cdr (assq (cadr x1963) r1962)))) (cdr e1956))))) (else (cons (quote map) (cons (list (quote lambda) formals1958 e1956) actuals1959))))))) (gen-mappend1941 (lambda (e1964 map-env1965) (list (quote apply) (quote (primitive append)) (gen-map1942 e1964 map-env1965)))) (gen-ref1940 (lambda (src1966 var1967 level1968 maps1969) (if (fx=1100 level1968 0) (values var1967 maps1969) (if (null? maps1969) (syntax-error src1966 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1940 src1966 var1967 (fx-1099 level1968 1) (cdr maps1969))) (lambda (outer-var1970 outer-maps1971) (let ((b1972 (assq outer-var1970 (car maps1969)))) (if b1972 (values (cdr b1972) maps1969) (let ((inner-var1973 (gen-var1179 (quote tmp)))) (values inner-var1973 (cons (cons (cons outer-var1970 inner-var1973) (car maps1969)) outer-maps1971))))))))))) (gen-syntax1939 (lambda (src1974 e1975 r1976 maps1977 ellipsis?1978 mod1979) (if (id?1131 e1975) (let ((label1980 (id-var-name1153 e1975 (quote (()))))) (let ((b1981 (lookup1128 label1980 r1976 mod1979))) (if (eq? (binding-type1123 b1981) (quote syntax)) (call-with-values (lambda () (let ((var.lev1982 (binding-value1124 b1981))) (gen-ref1940 src1974 (car var.lev1982) (cdr var.lev1982) maps1977))) (lambda (var1983 maps1984) (values (list (quote ref) var1983) maps1984))) (if (ellipsis?1978 e1975) (syntax-error src1974 "misplaced ellipsis in syntax form") (values (list (quote quote) e1975) maps1977))))) ((lambda (tmp1985) ((lambda (tmp1986) (if (if tmp1986 (apply (lambda (dots1987 e1988) (ellipsis?1978 dots1987)) tmp1986) #f) (apply (lambda (dots1989 e1990) (gen-syntax1939 src1974 e1990 r1976 maps1977 (lambda (x1991) #f) mod1979)) tmp1986) ((lambda (tmp1992) (if (if tmp1992 (apply (lambda (x1993 dots1994 y1995) (ellipsis?1978 dots1994)) tmp1992) #f) (apply (lambda (x1996 dots1997 y1998) (let f1999 ((y2000 y1998) (k2001 (lambda (maps2002) (call-with-values (lambda () (gen-syntax1939 src1974 x1996 r1976 (cons (quote ()) maps2002) ellipsis?1978 mod1979)) (lambda (x2003 maps2004) (if (null? (car maps2004)) (syntax-error src1974 "extra ellipsis in syntax form") (values (gen-map1942 x2003 (car maps2004)) (cdr maps2004)))))))) ((lambda (tmp2005) ((lambda (tmp2006) (if (if tmp2006 (apply (lambda (dots2007 y2008) (ellipsis?1978 dots2007)) tmp2006) #f) (apply (lambda (dots2009 y2010) (f1999 y2010 (lambda (maps2011) (call-with-values (lambda () (k2001 (cons (quote ()) maps2011))) (lambda (x2012 maps2013) (if (null? (car maps2013)) (syntax-error src1974 "extra ellipsis in syntax form") (values (gen-mappend1941 x2012 (car maps2013)) (cdr maps2013)))))))) tmp2006) ((lambda (_2014) (call-with-values (lambda () (gen-syntax1939 src1974 y2000 r1976 maps1977 ellipsis?1978 mod1979)) (lambda (y2015 maps2016) (call-with-values (lambda () (k2001 maps2016)) (lambda (x2017 maps2018) (values (gen-append1944 x2017 y2015) maps2018)))))) tmp2005))) (syntax-dispatch tmp2005 (quote (any . any))))) y2000))) tmp1992) ((lambda (tmp2019) (if tmp2019 (apply (lambda (x2020 y2021) (call-with-values (lambda () (gen-syntax1939 src1974 x2020 r1976 maps1977 ellipsis?1978 mod1979)) (lambda (x2022 maps2023) (call-with-values (lambda () (gen-syntax1939 src1974 y2021 r1976 maps2023 ellipsis?1978 mod1979)) (lambda (y2024 maps2025) (values (gen-cons1943 x2022 y2024) maps2025)))))) tmp2019) ((lambda (tmp2026) (if tmp2026 (apply (lambda (e12027 e22028) (call-with-values (lambda () (gen-syntax1939 src1974 (cons e12027 e22028) r1976 maps1977 ellipsis?1978 mod1979)) (lambda (e2030 maps2031) (values (gen-vector1945 e2030) maps2031)))) tmp2026) ((lambda (_2032) (values (list (quote quote) e1975) maps1977)) tmp1985))) (syntax-dispatch tmp1985 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1985 (quote (any . any)))))) (syntax-dispatch tmp1985 (quote (any any . any)))))) (syntax-dispatch tmp1985 (quote (any any))))) e1975))))) (lambda (e2033 r2034 w2035 s2036 mod2037) (let ((e2038 (source-wrap1160 e2033 w2035 s2036 mod2037))) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 x2042) (call-with-values (lambda () (gen-syntax1939 e2038 x2042 r2034 (quote ()) ellipsis?1176 mod2037)) (lambda (e2043 maps2044) (regen1946 e2043)))) tmp2040) ((lambda (_2045) (syntax-error e2038)) tmp2039))) (syntax-dispatch tmp2039 (quote (any any))))) e2038))))) (global-extend1129 (quote core) (quote lambda) (lambda (e2046 r2047 w2048 s2049 mod2050) ((lambda (tmp2051) ((lambda (tmp2052) (if tmp2052 (apply (lambda (_2053 c2054) (chi-lambda-clause1172 (source-wrap1160 e2046 w2048 s2049 mod2050) c2054 r2047 w2048 mod2050 (lambda (vars2055 body2056) (build-annotated1108 s2049 (list (quote lambda) vars2055 body2056))))) tmp2052) (syntax-error tmp2051))) (syntax-dispatch tmp2051 (quote (any . any))))) e2046))) (global-extend1129 (quote core) (quote let) (letrec ((chi-let2057 (lambda (e2058 r2059 w2060 s2061 mod2062 constructor2063 ids2064 vals2065 exps2066) (if (not (valid-bound-ids?1156 ids2064)) (syntax-error e2058 "duplicate bound variable in") (let ((labels2067 (gen-labels1137 ids2064)) (new-vars2068 (map gen-var1179 ids2064))) (let ((nw2069 (make-binding-wrap1148 ids2064 labels2067 w2060)) (nr2070 (extend-var-env1126 labels2067 new-vars2068 r2059))) (constructor2063 s2061 new-vars2068 (map (lambda (x2071) (chi1167 x2071 r2059 w2060 mod2062)) vals2065) (chi-body1171 exps2066 (source-wrap1160 e2058 nw2069 s2061 mod2062) nr2070 nw2069 mod2062)))))))) (lambda (e2072 r2073 w2074 s2075 mod2076) ((lambda (tmp2077) ((lambda (tmp2078) (if tmp2078 (apply (lambda (_2079 id2080 val2081 e12082 e22083) (chi-let2057 e2072 r2073 w2074 s2075 mod2076 build-let1111 id2080 val2081 (cons e12082 e22083))) tmp2078) ((lambda (tmp2087) (if (if tmp2087 (apply (lambda (_2088 f2089 id2090 val2091 e12092 e22093) (id?1131 f2089)) tmp2087) #f) (apply (lambda (_2094 f2095 id2096 val2097 e12098 e22099) (chi-let2057 e2072 r2073 w2074 s2075 mod2076 build-named-let1112 (cons f2095 id2096) val2097 (cons e12098 e22099))) tmp2087) ((lambda (_2103) (syntax-error (source-wrap1160 e2072 w2074 s2075 mod2076))) tmp2077))) (syntax-dispatch tmp2077 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2077 (quote (any #(each (any any)) any . each-any))))) e2072)))) (global-extend1129 (quote core) (quote letrec) (lambda (e2104 r2105 w2106 s2107 mod2108) ((lambda (tmp2109) ((lambda (tmp2110) (if tmp2110 (apply (lambda (_2111 id2112 val2113 e12114 e22115) (let ((ids2116 id2112)) (if (not (valid-bound-ids?1156 ids2116)) (syntax-error e2104 "duplicate bound variable in") (let ((labels2118 (gen-labels1137 ids2116)) (new-vars2119 (map gen-var1179 ids2116))) (let ((w2120 (make-binding-wrap1148 ids2116 labels2118 w2106)) (r2121 (extend-var-env1126 labels2118 new-vars2119 r2105))) (build-letrec1113 s2107 new-vars2119 (map (lambda (x2122) (chi1167 x2122 r2121 w2120 mod2108)) val2113) (chi-body1171 (cons e12114 e22115) (source-wrap1160 e2104 w2120 s2107 mod2108) r2121 w2120 mod2108))))))) tmp2110) ((lambda (_2125) (syntax-error (source-wrap1160 e2104 w2106 s2107 mod2108))) tmp2109))) (syntax-dispatch tmp2109 (quote (any #(each (any any)) any . each-any))))) e2104))) (global-extend1129 (quote core) (quote set!) (lambda (e2126 r2127 w2128 s2129 mod2130) ((lambda (tmp2131) ((lambda (tmp2132) (if (if tmp2132 (apply (lambda (_2133 id2134 val2135) (id?1131 id2134)) tmp2132) #f) (apply (lambda (_2136 id2137 val2138) (let ((val2139 (chi1167 val2138 r2127 w2128 mod2130)) (n2140 (id-var-name1153 id2137 w2128))) (let ((b2141 (lookup1128 n2140 r2127 mod2130))) (let ((t2142 (binding-type1123 b2141))) (if (memv t2142 (quote (lexical))) (build-annotated1108 s2129 (list (quote set!) (binding-value1124 b2141) val2139)) (if (memv t2142 (quote (global))) (build-annotated1108 s2129 (list (quote set!) (if mod2130 (make-module-ref (cdr mod2130) n2140 (car mod2130)) (make-module-ref mod2130 n2140 (quote bare))) val2139)) (if (memv t2142 (quote (displaced-lexical))) (syntax-error (wrap1159 id2137 w2128 mod2130) "identifier out of context") (syntax-error (source-wrap1160 e2126 w2128 s2129 mod2130))))))))) tmp2132) ((lambda (tmp2143) (if tmp2143 (apply (lambda (_2144 head2145 tail2146 val2147) (call-with-values (lambda () (syntax-type1165 head2145 r2127 (quote (())) #f #f mod2130)) (lambda (type2148 value2149 ee2150 ww2151 ss2152 modmod2153) (let ((t2154 type2148)) (if (memv t2154 (quote (module-ref))) (let ((val2155 (chi1167 val2147 r2127 w2128 mod2130))) (call-with-values (lambda () (value2149 (cons head2145 tail2146))) (lambda (id2157 mod2158) (build-annotated1108 s2129 (list (quote set!) (if mod2158 (make-module-ref (cdr mod2158) id2157 (car mod2158)) (make-module-ref mod2158 id2157 (quote bare))) val2155))))) (build-annotated1108 s2129 (cons (chi1167 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2145) r2127 w2128 mod2130) (map (lambda (e2159) (chi1167 e2159 r2127 w2128 mod2130)) (append tail2146 (list val2147)))))))))) tmp2143) ((lambda (_2161) (syntax-error (source-wrap1160 e2126 w2128 s2129 mod2130))) tmp2131))) (syntax-dispatch tmp2131 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2131 (quote (any any any))))) e2126))) (global-extend1129 (quote module-ref) (quote @) (lambda (e2162) ((lambda (tmp2163) ((lambda (tmp2164) (if (if tmp2164 (apply (lambda (_2165 mod2166 id2167) (and (andmap id?1131 mod2166) (id?1131 id2167))) tmp2164) #f) (apply (lambda (_2169 mod2170 id2171) (values (syntax-object->datum id2171) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2170)))) tmp2164) (syntax-error tmp2163))) (syntax-dispatch tmp2163 (quote (any each-any any))))) e2162))) (global-extend1129 (quote module-ref) (quote @@) (lambda (e2173) ((lambda (tmp2174) ((lambda (tmp2175) (if (if tmp2175 (apply (lambda (_2176 mod2177 id2178) (and (andmap id?1131 mod2177) (id?1131 id2178))) tmp2175) #f) (apply (lambda (_2180 mod2181 id2182) (values (syntax-object->datum id2182) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2181)))) tmp2175) (syntax-error tmp2174))) (syntax-dispatch tmp2174 (quote (any each-any any))))) e2173))) (global-extend1129 (quote begin) (quote begin) (quote ())) (global-extend1129 (quote define) (quote define) (quote ())) (global-extend1129 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1129 (quote eval-when) (quote eval-when) (quote ())) (global-extend1129 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2187 (lambda (x2188 keys2189 clauses2190 r2191 mod2192) (if (null? clauses2190) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-error)) x2188)) ((lambda (tmp2193) ((lambda (tmp2194) (if tmp2194 (apply (lambda (pat2195 exp2196) (if (and (id?1131 pat2195) (andmap (lambda (x2197) (not (free-id=?1154 pat2195 x2197))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2189))) (let ((labels2198 (list (gen-label1136))) (var2199 (gen-var1179 pat2195))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list var2199) (chi1167 exp2196 (extend-env1125 labels2198 (list (cons (quote syntax) (cons var2199 0))) r2191) (make-binding-wrap1148 (list pat2195) labels2198 (quote (()))) mod2192))) x2188))) (gen-clause2186 x2188 keys2189 (cdr clauses2190) r2191 pat2195 #t exp2196 mod2192))) tmp2194) ((lambda (tmp2200) (if tmp2200 (apply (lambda (pat2201 fender2202 exp2203) (gen-clause2186 x2188 keys2189 (cdr clauses2190) r2191 pat2201 fender2202 exp2203 mod2192)) tmp2200) ((lambda (_2204) (syntax-error (car clauses2190) "invalid syntax-case clause")) tmp2193))) (syntax-dispatch tmp2193 (quote (any any any)))))) (syntax-dispatch tmp2193 (quote (any any))))) (car clauses2190))))) (gen-clause2186 (lambda (x2205 keys2206 clauses2207 r2208 pat2209 fender2210 exp2211 mod2212) (call-with-values (lambda () (convert-pattern2184 pat2209 keys2206)) (lambda (p2213 pvars2214) (cond ((not (distinct-bound-ids?1157 (map car pvars2214))) (syntax-error pat2209 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2215) (not (ellipsis?1176 (car x2215)))) pvars2214)) (syntax-error pat2209 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2216 (gen-var1179 (quote tmp)))) (build-annotated1108 #f (list (build-annotated1108 #f (list (quote lambda) (list y2216) (let ((y2217 (build-annotated1108 #f y2216))) (build-annotated1108 #f (list (quote if) ((lambda (tmp2218) ((lambda (tmp2219) (if tmp2219 (apply (lambda () y2217) tmp2219) ((lambda (_2220) (build-annotated1108 #f (list (quote if) y2217 (build-dispatch-call2185 pvars2214 fender2210 y2217 r2208 mod2212) (build-data1109 #f #f)))) tmp2218))) (syntax-dispatch tmp2218 (quote #(atom #t))))) fender2210) (build-dispatch-call2185 pvars2214 exp2211 y2217 r2208 mod2212) (gen-syntax-case2187 x2205 keys2206 clauses2207 r2208 mod2212)))))) (if (eq? p2213 (quote any)) (build-annotated1108 #f (list (build-annotated1108 #f (quote list)) x2205)) (build-annotated1108 #f (list (build-annotated1108 #f (quote syntax-dispatch)) x2205 (build-data1109 #f p2213))))))))))))) (build-dispatch-call2185 (lambda (pvars2221 exp2222 y2223 r2224 mod2225) (let ((ids2226 (map car pvars2221)) (levels2227 (map cdr pvars2221))) (let ((labels2228 (gen-labels1137 ids2226)) (new-vars2229 (map gen-var1179 ids2226))) (build-annotated1108 #f (list (build-annotated1108 #f (quote apply)) (build-annotated1108 #f (list (quote lambda) new-vars2229 (chi1167 exp2222 (extend-env1125 labels2228 (map (lambda (var2230 level2231) (cons (quote syntax) (cons var2230 level2231))) new-vars2229 (map cdr pvars2221)) r2224) (make-binding-wrap1148 ids2226 labels2228 (quote (()))) mod2225))) y2223)))))) (convert-pattern2184 (lambda (pattern2232 keys2233) (let cvt2234 ((p2235 pattern2232) (n2236 0) (ids2237 (quote ()))) (if (id?1131 p2235) (if (bound-id-member?1158 p2235 keys2233) (values (vector (quote free-id) p2235) ids2237) (values (quote any) (cons (cons p2235 n2236) ids2237))) ((lambda (tmp2238) ((lambda (tmp2239) (if (if tmp2239 (apply (lambda (x2240 dots2241) (ellipsis?1176 dots2241)) tmp2239) #f) (apply (lambda (x2242 dots2243) (call-with-values (lambda () (cvt2234 x2242 (fx+1098 n2236 1) ids2237)) (lambda (p2244 ids2245) (values (if (eq? p2244 (quote any)) (quote each-any) (vector (quote each) p2244)) ids2245)))) tmp2239) ((lambda (tmp2246) (if tmp2246 (apply (lambda (x2247 y2248) (call-with-values (lambda () (cvt2234 y2248 n2236 ids2237)) (lambda (y2249 ids2250) (call-with-values (lambda () (cvt2234 x2247 n2236 ids2250)) (lambda (x2251 ids2252) (values (cons x2251 y2249) ids2252)))))) tmp2246) ((lambda (tmp2253) (if tmp2253 (apply (lambda () (values (quote ()) ids2237)) tmp2253) ((lambda (tmp2254) (if tmp2254 (apply (lambda (x2255) (call-with-values (lambda () (cvt2234 x2255 n2236 ids2237)) (lambda (p2257 ids2258) (values (vector (quote vector) p2257) ids2258)))) tmp2254) ((lambda (x2259) (values (vector (quote atom) (strip1178 p2235 (quote (())))) ids2237)) tmp2238))) (syntax-dispatch tmp2238 (quote #(vector each-any)))))) (syntax-dispatch tmp2238 (quote ()))))) (syntax-dispatch tmp2238 (quote (any . any)))))) (syntax-dispatch tmp2238 (quote (any any))))) p2235)))))) (lambda (e2260 r2261 w2262 s2263 mod2264) (let ((e2265 (source-wrap1160 e2260 w2262 s2263 mod2264))) ((lambda (tmp2266) ((lambda (tmp2267) (if tmp2267 (apply (lambda (_2268 val2269 key2270 m2271) (if (andmap (lambda (x2272) (and (id?1131 x2272) (not (ellipsis?1176 x2272)))) key2270) (let ((x2274 (gen-var1179 (quote tmp)))) (build-annotated1108 s2263 (list (build-annotated1108 #f (list (quote lambda) (list x2274) (gen-syntax-case2187 (build-annotated1108 #f x2274) key2270 m2271 r2261 mod2264))) (chi1167 val2269 r2261 (quote (())) mod2264)))) (syntax-error e2265 "invalid literals list in"))) tmp2267) (syntax-error tmp2266))) (syntax-dispatch tmp2266 (quote (any any each-any . each-any))))) e2265))))) (set! sc-expand (let ((m2277 (quote e)) (esew2278 (quote (eval)))) (lambda (x2279) (if (and (pair? x2279) (equal? (car x2279) noexpand1097)) (cadr x2279) (chi-top1166 x2279 (quote ()) (quote ((top))) m2277 esew2278 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2280 (quote e)) (esew2281 (quote (eval)))) (lambda (x2283 . rest2282) (if (and (pair? x2283) (equal? (car x2283) noexpand1097)) (cadr x2283) (chi-top1166 x2283 (quote ()) (quote ((top))) (if (null? rest2282) m2280 (car rest2282)) (if (or (null? rest2282) (null? (cdr rest2282))) esew2281 (cadr rest2282)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2284) (nonsymbol-id?1130 x2284))) (set! datum->syntax-object (lambda (id2285 datum2286) (make-syntax-object1114 datum2286 (syntax-object-wrap1117 id2285) #f))) (set! syntax-object->datum (lambda (x2287) (strip1178 x2287 (quote (()))))) (set! generate-temporaries (lambda (ls2288) (begin (let ((x2289 ls2288)) (if (not (list? x2289)) (error-hook1104 (quote generate-temporaries) "invalid argument" x2289))) (map (lambda (x2290) (wrap1159 (gensym) (quote ((top))) #f)) ls2288)))) (set! free-identifier=? (lambda (x2291 y2292) (begin (let ((x2293 x2291)) (if (not (nonsymbol-id?1130 x2293)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2293))) (let ((x2294 y2292)) (if (not (nonsymbol-id?1130 x2294)) (error-hook1104 (quote free-identifier=?) "invalid argument" x2294))) (free-id=?1154 x2291 y2292)))) (set! bound-identifier=? (lambda (x2295 y2296) (begin (let ((x2297 x2295)) (if (not (nonsymbol-id?1130 x2297)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2297))) (let ((x2298 y2296)) (if (not (nonsymbol-id?1130 x2298)) (error-hook1104 (quote bound-identifier=?) "invalid argument" x2298))) (bound-id=?1155 x2295 y2296)))) (set! syntax-error (lambda (object2300 . messages2299) (begin (for-each (lambda (x2301) (let ((x2302 x2301)) (if (not (string? x2302)) (error-hook1104 (quote syntax-error) "invalid argument" x2302)))) messages2299) (let ((message2303 (if (null? messages2299) "invalid syntax" (apply string-append messages2299)))) (error-hook1104 #f message2303 (strip1178 object2300 (quote (())))))))) (set! install-global-transformer (lambda (sym2304 v2305) (begin (let ((x2306 sym2304)) (if (not (symbol? x2306)) (error-hook1104 (quote define-syntax) "invalid argument" x2306))) (let ((x2307 v2305)) (if (not (procedure? x2307)) (error-hook1104 (quote define-syntax) "invalid argument" x2307))) (global-extend1129 (quote macro) sym2304 v2305)))) (letrec ((match2312 (lambda (e2313 p2314 w2315 r2316 mod2317) (cond ((not r2316) #f) ((eq? p2314 (quote any)) (cons (wrap1159 e2313 w2315 mod2317) r2316)) ((syntax-object?1115 e2313) (match*2311 (let ((e2318 (syntax-object-expression1116 e2313))) (if (annotation? e2318) (annotation-expression e2318) e2318)) p2314 (join-wraps1150 w2315 (syntax-object-wrap1117 e2313)) r2316 (syntax-object-module1118 e2313))) (else (match*2311 (let ((e2319 e2313)) (if (annotation? e2319) (annotation-expression e2319) e2319)) p2314 w2315 r2316 mod2317))))) (match*2311 (lambda (e2320 p2321 w2322 r2323 mod2324) (cond ((null? p2321) (and (null? e2320) r2323)) ((pair? p2321) (and (pair? e2320) (match2312 (car e2320) (car p2321) w2322 (match2312 (cdr e2320) (cdr p2321) w2322 r2323 mod2324) mod2324))) ((eq? p2321 (quote each-any)) (let ((l2325 (match-each-any2309 e2320 w2322 mod2324))) (and l2325 (cons l2325 r2323)))) (else (let ((t2326 (vector-ref p2321 0))) (if (memv t2326 (quote (each))) (if (null? e2320) (match-empty2310 (vector-ref p2321 1) r2323) (let ((l2327 (match-each2308 e2320 (vector-ref p2321 1) w2322 mod2324))) (and l2327 (let collect2328 ((l2329 l2327)) (if (null? (car l2329)) r2323 (cons (map car l2329) (collect2328 (map cdr l2329)))))))) (if (memv t2326 (quote (free-id))) (and (id?1131 e2320) (free-id=?1154 (wrap1159 e2320 w2322 mod2324) (vector-ref p2321 1)) r2323) (if (memv t2326 (quote (atom))) (and (equal? (vector-ref p2321 1) (strip1178 e2320 w2322)) r2323) (if (memv t2326 (quote (vector))) (and (vector? e2320) (match2312 (vector->list e2320) (vector-ref p2321 1) w2322 r2323 mod2324))))))))))) (match-empty2310 (lambda (p2330 r2331) (cond ((null? p2330) r2331) ((eq? p2330 (quote any)) (cons (quote ()) r2331)) ((pair? p2330) (match-empty2310 (car p2330) (match-empty2310 (cdr p2330) r2331))) ((eq? p2330 (quote each-any)) (cons (quote ()) r2331)) (else (let ((t2332 (vector-ref p2330 0))) (if (memv t2332 (quote (each))) (match-empty2310 (vector-ref p2330 1) r2331) (if (memv t2332 (quote (free-id atom))) r2331 (if (memv t2332 (quote (vector))) (match-empty2310 (vector-ref p2330 1) r2331))))))))) (match-each-any2309 (lambda (e2333 w2334 mod2335) (cond ((annotation? e2333) (match-each-any2309 (annotation-expression e2333) w2334 mod2335)) ((pair? e2333) (let ((l2336 (match-each-any2309 (cdr e2333) w2334 mod2335))) (and l2336 (cons (wrap1159 (car e2333) w2334 mod2335) l2336)))) ((null? e2333) (quote ())) ((syntax-object?1115 e2333) (match-each-any2309 (syntax-object-expression1116 e2333) (join-wraps1150 w2334 (syntax-object-wrap1117 e2333)) mod2335)) (else #f)))) (match-each2308 (lambda (e2337 p2338 w2339 mod2340) (cond ((annotation? e2337) (match-each2308 (annotation-expression e2337) p2338 w2339 mod2340)) ((pair? e2337) (let ((first2341 (match2312 (car e2337) p2338 w2339 (quote ()) mod2340))) (and first2341 (let ((rest2342 (match-each2308 (cdr e2337) p2338 w2339 mod2340))) (and rest2342 (cons first2341 rest2342)))))) ((null? e2337) (quote ())) ((syntax-object?1115 e2337) (match-each2308 (syntax-object-expression1116 e2337) p2338 (join-wraps1150 w2339 (syntax-object-wrap1117 e2337)) (syntax-object-module1118 e2337))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2343 p2344) (cond ((eq? p2344 (quote any)) (list e2343)) ((syntax-object?1115 e2343) (match*2311 (let ((e2345 (syntax-object-expression1116 e2343))) (if (annotation? e2345) (annotation-expression e2345) e2345)) p2344 (syntax-object-wrap1117 e2343) (quote ()) (syntax-object-module1118 e2343))) (else (match*2311 (let ((e2346 e2343)) (if (annotation? e2346) (annotation-expression e2346) e2346)) p2344 (quote (())) (quote ()) #f))))) (set! sc-chi chi1167))))) -(install-global-transformer (quote with-syntax) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if tmp2349 (apply (lambda (_2350 e12351 e22352) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12351 e22352))) tmp2349) ((lambda (tmp2354) (if tmp2354 (apply (lambda (_2355 out2356 in2357 e12358 e22359) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2357 (quote ()) (list out2356 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12358 e22359))))) tmp2354) ((lambda (tmp2361) (if tmp2361 (apply (lambda (_2362 out2363 in2364 e12365 e22366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2364) (quote ()) (list out2363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12365 e22366))))) tmp2361) (syntax-error tmp2348))) (syntax-dispatch tmp2348 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2348 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2348 (quote (any () any . each-any))))) x2347))) -(install-global-transformer (quote syntax-rules) (lambda (x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 k2374 keyword2375 pattern2376 template2377) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2374 (map (lambda (tmp2380 tmp2379) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2379) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2380))) template2377 pattern2376)))))) tmp2372) (syntax-error tmp2371))) (syntax-dispatch tmp2371 (quote (any each-any . #(each ((any . any) any))))))) x2370))) -(install-global-transformer (quote let*) (lambda (x2381) ((lambda (tmp2382) ((lambda (tmp2383) (if (if tmp2383 (apply (lambda (let*2384 x2385 v2386 e12387 e22388) (andmap identifier? x2385)) tmp2383) #f) (apply (lambda (let*2390 x2391 v2392 e12393 e22394) (let f2395 ((bindings2396 (map list x2391 v2392))) (if (null? bindings2396) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12393 e22394))) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply (lambda (body2402 binding2403) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2403) body2402)) tmp2401) (syntax-error tmp2400))) (syntax-dispatch tmp2400 (quote (any any))))) (list (f2395 (cdr bindings2396)) (car bindings2396)))))) tmp2383) (syntax-error tmp2382))) (syntax-dispatch tmp2382 (quote (any #(each (any any)) any . each-any))))) x2381))) -(install-global-transformer (quote do) (lambda (orig-x2404) ((lambda (tmp2405) ((lambda (tmp2406) (if tmp2406 (apply (lambda (_2407 var2408 init2409 step2410 e02411 e12412 c2413) ((lambda (tmp2414) ((lambda (tmp2415) (if tmp2415 (apply (lambda (step2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2408 init2409) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02411) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2416))))))) tmp2418) ((lambda (tmp2423) (if tmp2423 (apply (lambda (e12424 e22425) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2408 init2409) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02411 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12424 e22425)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2416))))))) tmp2423) (syntax-error tmp2417))) (syntax-dispatch tmp2417 (quote (any . each-any)))))) (syntax-dispatch tmp2417 (quote ())))) e12412)) tmp2415) (syntax-error tmp2414))) (syntax-dispatch tmp2414 (quote each-any)))) (map (lambda (v2432 s2433) ((lambda (tmp2434) ((lambda (tmp2435) (if tmp2435 (apply (lambda () v2432) tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda (e2437) e2437) tmp2436) ((lambda (_2438) (syntax-error orig-x2404)) tmp2434))) (syntax-dispatch tmp2434 (quote (any)))))) (syntax-dispatch tmp2434 (quote ())))) s2433)) var2408 step2410))) tmp2406) (syntax-error tmp2405))) (syntax-dispatch tmp2405 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2404))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2441 (lambda (x2445 y2446) ((lambda (tmp2447) ((lambda (tmp2448) (if tmp2448 (apply (lambda (x2449 y2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (dy2453) ((lambda (tmp2454) ((lambda (tmp2455) (if tmp2455 (apply (lambda (dx2456) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2456 dy2453))) tmp2455) ((lambda (_2457) (if (null? dy2453) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2449) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2449 y2450))) tmp2454))) (syntax-dispatch tmp2454 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2449)) tmp2452) ((lambda (tmp2458) (if tmp2458 (apply (lambda (stuff2459) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2449 stuff2459))) tmp2458) ((lambda (else2460) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2449 y2450)) tmp2451))) (syntax-dispatch tmp2451 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2451 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2450)) tmp2448) (syntax-error tmp2447))) (syntax-dispatch tmp2447 (quote (any any))))) (list x2445 y2446)))) (quasiappend2442 (lambda (x2461 y2462) ((lambda (tmp2463) ((lambda (tmp2464) (if tmp2464 (apply (lambda (x2465 y2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda () x2465) tmp2468) ((lambda (_2469) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2465 y2466)) tmp2467))) (syntax-dispatch tmp2467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2466)) tmp2464) (syntax-error tmp2463))) (syntax-dispatch tmp2463 (quote (any any))))) (list x2461 y2462)))) (quasivector2443 (lambda (x2470) ((lambda (tmp2471) ((lambda (x2472) ((lambda (tmp2473) ((lambda (tmp2474) (if tmp2474 (apply (lambda (x2475) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2475))) tmp2474) ((lambda (tmp2477) (if tmp2477 (apply (lambda (x2478) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2478)) tmp2477) ((lambda (_2480) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2472)) tmp2473))) (syntax-dispatch tmp2473 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2473 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2472)) tmp2471)) x2470))) (quasi2444 (lambda (p2481 lev2482) ((lambda (tmp2483) ((lambda (tmp2484) (if tmp2484 (apply (lambda (p2485) (if (= lev2482 0) p2485 (quasicons2441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2444 (list p2485) (- lev2482 1))))) tmp2484) ((lambda (tmp2486) (if tmp2486 (apply (lambda (p2487 q2488) (if (= lev2482 0) (quasiappend2442 p2487 (quasi2444 q2488 lev2482)) (quasicons2441 (quasicons2441 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2444 (list p2487) (- lev2482 1))) (quasi2444 q2488 lev2482)))) tmp2486) ((lambda (tmp2489) (if tmp2489 (apply (lambda (p2490) (quasicons2441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2444 (list p2490) (+ lev2482 1)))) tmp2489) ((lambda (tmp2491) (if tmp2491 (apply (lambda (p2492 q2493) (quasicons2441 (quasi2444 p2492 lev2482) (quasi2444 q2493 lev2482))) tmp2491) ((lambda (tmp2494) (if tmp2494 (apply (lambda (x2495) (quasivector2443 (quasi2444 x2495 lev2482))) tmp2494) ((lambda (p2497) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2497)) tmp2483))) (syntax-dispatch tmp2483 (quote #(vector each-any)))))) (syntax-dispatch tmp2483 (quote (any . any)))))) (syntax-dispatch tmp2483 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2483 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2483 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2481)))) (lambda (x2498) ((lambda (tmp2499) ((lambda (tmp2500) (if tmp2500 (apply (lambda (_2501 e2502) (quasi2444 e2502 0)) tmp2500) (syntax-error tmp2499))) (syntax-dispatch tmp2499 (quote (any any))))) x2498)))) -(install-global-transformer (quote include) (lambda (x2503) (letrec ((read-file2504 (lambda (fn2505 k2506) (let ((p2507 (open-input-file fn2505))) (let f2508 ((x2509 (read p2507))) (if (eof-object? x2509) (begin (close-input-port p2507) (quote ())) (cons (datum->syntax-object k2506 x2509) (f2508 (read p2507))))))))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (k2512 filename2513) (let ((fn2514 (syntax-object->datum filename2513))) ((lambda (tmp2515) ((lambda (tmp2516) (if tmp2516 (apply (lambda (exp2517) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2517)) tmp2516) (syntax-error tmp2515))) (syntax-dispatch tmp2515 (quote each-any)))) (read-file2504 fn2514 k2512)))) tmp2511) (syntax-error tmp2510))) (syntax-dispatch tmp2510 (quote (any any))))) x2503)))) -(install-global-transformer (quote unquote) (lambda (x2519) ((lambda (tmp2520) ((lambda (tmp2521) (if tmp2521 (apply (lambda (_2522 e2523) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2523))) tmp2521) (syntax-error tmp2520))) (syntax-dispatch tmp2520 (quote (any any))))) x2519))) -(install-global-transformer (quote unquote-splicing) (lambda (x2524) ((lambda (tmp2525) ((lambda (tmp2526) (if tmp2526 (apply (lambda (_2527 e2528) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2528))) tmp2526) (syntax-error tmp2525))) (syntax-dispatch tmp2525 (quote (any any))))) x2524))) -(install-global-transformer (quote case) (lambda (x2529) ((lambda (tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda (_2532 e2533 m12534 m22535) ((lambda (tmp2536) ((lambda (body2537) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2533)) body2537)) tmp2536)) (let f2538 ((clause2539 m12534) (clauses2540 m22535)) (if (null? clauses2540) ((lambda (tmp2542) ((lambda (tmp2543) (if tmp2543 (apply (lambda (e12544 e22545) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12544 e22545))) tmp2543) ((lambda (tmp2547) (if tmp2547 (apply (lambda (k2548 e12549 e22550) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2548)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12549 e22550)))) tmp2547) ((lambda (_2553) (syntax-error x2529)) tmp2542))) (syntax-dispatch tmp2542 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2542 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2539) ((lambda (tmp2554) ((lambda (rest2555) ((lambda (tmp2556) ((lambda (tmp2557) (if tmp2557 (apply (lambda (k2558 e12559 e22560) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2558)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12559 e22560)) rest2555)) tmp2557) ((lambda (_2563) (syntax-error x2529)) tmp2556))) (syntax-dispatch tmp2556 (quote (each-any any . each-any))))) clause2539)) tmp2554)) (f2538 (car clauses2540) (cdr clauses2540))))))) tmp2531) (syntax-error tmp2530))) (syntax-dispatch tmp2530 (quote (any any any . each-any))))) x2529))) -(install-global-transformer (quote identifier-syntax) (lambda (x2564) ((lambda (tmp2565) ((lambda (tmp2566) (if tmp2566 (apply (lambda (_2567 e2568) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2568)) (list (cons _2567 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2568 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2566) (syntax-error tmp2565))) (syntax-dispatch tmp2565 (quote (any any))))) x2564))) +(letrec ((lambda-var-list175 (lambda (vars380) (let lvl381 ((vars382 vars380) (ls383 (quote ())) (w384 (quote (())))) (cond ((pair? vars382) (lvl381 (cdr vars382) (cons (wrap154 (car vars382) w384 #f) ls383) w384)) ((id?126 vars382) (cons (wrap154 vars382 w384 #f) ls383)) ((null? vars382) ls383) ((syntax-object?110 vars382) (lvl381 (syntax-object-expression111 vars382) ls383 (join-wraps145 w384 (syntax-object-wrap112 vars382)))) ((annotation? vars382) (lvl381 (annotation-expression vars382) ls383 w384)) (else (cons vars382 ls383)))))) (gen-var174 (lambda (id385) (let ((id386 (if (syntax-object?110 id385) (syntax-object-expression111 id385) id385))) (if (annotation? id386) (build-annotated103 (annotation-source id386) (gensym (symbol->string (annotation-expression id386)))) (build-annotated103 #f (gensym (symbol->string id386))))))) (strip173 (lambda (x387 w388) (if (memq (quote top) (wrap-marks129 w388)) (if (or (annotation? x387) (and (pair? x387) (annotation? (car x387)))) (strip-annotation172 x387 #f) x387) (let f389 ((x390 x387)) (cond ((syntax-object?110 x390) (strip173 (syntax-object-expression111 x390) (syntax-object-wrap112 x390))) ((pair? x390) (let ((a391 (f389 (car x390))) (d392 (f389 (cdr x390)))) (if (and (eq? a391 (car x390)) (eq? d392 (cdr x390))) x390 (cons a391 d392)))) ((vector? x390) (let ((old393 (vector->list x390))) (let ((new394 (map f389 old393))) (if (andmap eq? old393 new394) x390 (list->vector new394))))) (else x390)))))) (strip-annotation172 (lambda (x395 parent396) (cond ((pair? x395) (let ((new397 (cons #f #f))) (begin (if parent396 (set-annotation-stripped! parent396 new397)) (set-car! new397 (strip-annotation172 (car x395) #f)) (set-cdr! new397 (strip-annotation172 (cdr x395) #f)) new397))) ((annotation? x395) (or (annotation-stripped x395) (strip-annotation172 (annotation-expression x395) x395))) ((vector? x395) (let ((new398 (make-vector (vector-length x395)))) (begin (if parent396 (set-annotation-stripped! parent396 new398)) (let loop399 ((i400 (- (vector-length x395) 1))) (unless (fx<96 i400 0) (vector-set! new398 i400 (strip-annotation172 (vector-ref x395 i400) #f)) (loop399 (fx-94 i400 1)))) new398))) (else x395)))) (ellipsis?171 (lambda (x401) (and (nonsymbol-id?125 x401) (free-id=?149 x401 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void170 (lambda () (build-annotated103 #f (list (build-annotated103 #f (quote void)))))) (eval-local-transformer169 (lambda (expanded402 mod403) (let ((p404 (local-eval-hook98 expanded402 mod403))) (if (procedure? p404) p404 (syntax-error p404 "nonprocedure transformer"))))) (chi-local-syntax168 (lambda (rec?405 e406 r407 w408 s409 mod410 k411) ((lambda (tmp412) ((lambda (tmp413) (if tmp413 (apply (lambda (_414 id415 val416 e1417 e2418) (let ((ids419 id415)) (if (not (valid-bound-ids?151 ids419)) (syntax-error e406 "duplicate bound keyword in") (let ((labels421 (gen-labels132 ids419))) (let ((new-w422 (make-binding-wrap143 ids419 labels421 w408))) (k411 (cons e1417 e2418) (extend-env120 labels421 (let ((w424 (if rec?405 new-w422 w408)) (trans-r425 (macros-only-env122 r407))) (map (lambda (x426) (cons (quote macro) (eval-local-transformer169 (chi162 x426 trans-r425 w424 mod410) mod410))) val416)) r407) new-w422 s409 mod410)))))) tmp413) ((lambda (_428) (syntax-error (source-wrap155 e406 w408 s409 mod410))) tmp412))) (syntax-dispatch tmp412 (quote (any #(each (any any)) any . each-any))))) e406))) (chi-lambda-clause167 (lambda (e429 docstring430 c431 r432 w433 mod434 k435) ((lambda (tmp436) ((lambda (tmp437) (if (if tmp437 (apply (lambda (args438 doc439 e1440 e2441) (and (string? (syntax-object->datum doc439)) (not docstring430))) tmp437) #f) (apply (lambda (args442 doc443 e1444 e2445) (chi-lambda-clause167 e429 doc443 (cons args442 (cons e1444 e2445)) r432 w433 mod434 k435)) tmp437) ((lambda (tmp447) (if tmp447 (apply (lambda (id448 e1449 e2450) (let ((ids451 id448)) (if (not (valid-bound-ids?151 ids451)) (syntax-error e429 "invalid parameter list in") (let ((labels453 (gen-labels132 ids451)) (new-vars454 (map gen-var174 ids451))) (k435 new-vars454 docstring430 (chi-body166 (cons e1449 e2450) e429 (extend-var-env121 labels453 new-vars454 r432) (make-binding-wrap143 ids451 labels453 w433) mod434)))))) tmp447) ((lambda (tmp456) (if tmp456 (apply (lambda (ids457 e1458 e2459) (let ((old-ids460 (lambda-var-list175 ids457))) (if (not (valid-bound-ids?151 old-ids460)) (syntax-error e429 "invalid parameter list in") (let ((labels461 (gen-labels132 old-ids460)) (new-vars462 (map gen-var174 old-ids460))) (k435 (let f463 ((ls1464 (cdr new-vars462)) (ls2465 (car new-vars462))) (if (null? ls1464) ls2465 (f463 (cdr ls1464) (cons (car ls1464) ls2465)))) docstring430 (chi-body166 (cons e1458 e2459) e429 (extend-var-env121 labels461 new-vars462 r432) (make-binding-wrap143 old-ids460 labels461 w433) mod434)))))) tmp456) ((lambda (_467) (syntax-error e429)) tmp436))) (syntax-dispatch tmp436 (quote (any any . each-any)))))) (syntax-dispatch tmp436 (quote (each-any any . each-any)))))) (syntax-dispatch tmp436 (quote (any any any . each-any))))) c431))) (chi-body166 (lambda (body468 outer-form469 r470 w471 mod472) (let ((r473 (cons (quote ("placeholder" placeholder)) r470))) (let ((ribcage474 (make-ribcage133 (quote ()) (quote ()) (quote ())))) (let ((w475 (make-wrap128 (wrap-marks129 w471) (cons ribcage474 (wrap-subst130 w471))))) (let parse476 ((body477 (map (lambda (x483) (cons r473 (wrap154 x483 w475 mod472))) body468)) (ids478 (quote ())) (labels479 (quote ())) (vars480 (quote ())) (vals481 (quote ())) (bindings482 (quote ()))) (if (null? body477) (syntax-error outer-form469 "no expressions in body") (let ((e484 (cdar body477)) (er485 (caar body477))) (call-with-values (lambda () (syntax-type160 e484 er485 (quote (())) #f ribcage474 mod472)) (lambda (type486 value487 e488 w489 s490 mod491) (let ((t492 type486)) (if (memv t492 (quote (define-form))) (let ((id493 (wrap154 value487 w489 mod491)) (label494 (gen-label131))) (let ((var495 (gen-var174 id493))) (begin (extend-ribcage!142 ribcage474 id493 label494) (parse476 (cdr body477) (cons id493 ids478) (cons label494 labels479) (cons var495 vars480) (cons (cons er485 (wrap154 e488 w489 mod491)) vals481) (cons (cons (quote lexical) var495) bindings482))))) (if (memv t492 (quote (define-syntax-form))) (let ((id496 (wrap154 value487 w489 mod491)) (label497 (gen-label131))) (begin (extend-ribcage!142 ribcage474 id496 label497) (parse476 (cdr body477) (cons id496 ids478) (cons label497 labels479) vars480 vals481 (cons (cons (quote macro) (cons er485 (wrap154 e488 w489 mod491))) bindings482)))) (if (memv t492 (quote (begin-form))) ((lambda (tmp498) ((lambda (tmp499) (if tmp499 (apply (lambda (_500 e1501) (parse476 (let f502 ((forms503 e1501)) (if (null? forms503) (cdr body477) (cons (cons er485 (wrap154 (car forms503) w489 mod491)) (f502 (cdr forms503))))) ids478 labels479 vars480 vals481 bindings482)) tmp499) (syntax-error tmp498))) (syntax-dispatch tmp498 (quote (any . each-any))))) e488) (if (memv t492 (quote (local-syntax-form))) (chi-local-syntax168 value487 e488 er485 w489 s490 mod491 (lambda (forms505 er506 w507 s508 mod509) (parse476 (let f510 ((forms511 forms505)) (if (null? forms511) (cdr body477) (cons (cons er506 (wrap154 (car forms511) w507 mod509)) (f510 (cdr forms511))))) ids478 labels479 vars480 vals481 bindings482))) (if (null? ids478) (build-sequence105 #f (map (lambda (x512) (chi162 (cdr x512) (car x512) (quote (())) mod491)) (cons (cons er485 (source-wrap155 e488 w489 s490 mod491)) (cdr body477)))) (begin (if (not (valid-bound-ids?151 ids478)) (syntax-error outer-form469 "invalid or duplicate identifier in definition")) (let loop513 ((bs514 bindings482) (er-cache515 #f) (r-cache516 #f)) (if (not (null? bs514)) (let ((b517 (car bs514))) (if (eq? (car b517) (quote macro)) (let ((er518 (cadr b517))) (let ((r-cache519 (if (eq? er518 er-cache515) r-cache516 (macros-only-env122 er518)))) (begin (set-cdr! b517 (eval-local-transformer169 (chi162 (cddr b517) r-cache519 (quote (())) mod491) mod491)) (loop513 (cdr bs514) er518 r-cache519)))) (loop513 (cdr bs514) er-cache515 r-cache516))))) (set-cdr! r473 (extend-env120 labels479 bindings482 (cdr r473))) (build-letrec108 #f vars480 (map (lambda (x520) (chi162 (cdr x520) (car x520) (quote (())) mod491)) vals481) (build-sequence105 #f (map (lambda (x521) (chi162 (cdr x521) (car x521) (quote (())) mod491)) (cons (cons er485 (source-wrap155 e488 w489 s490 mod491)) (cdr body477)))))))))))))))))))))) (chi-macro165 (lambda (p522 e523 r524 w525 rib526 mod527) (letrec ((rebuild-macro-output528 (lambda (x529 m530) (cond ((pair? x529) (cons (rebuild-macro-output528 (car x529) m530) (rebuild-macro-output528 (cdr x529) m530))) ((syntax-object?110 x529) (let ((w531 (syntax-object-wrap112 x529))) (let ((ms532 (wrap-marks129 w531)) (s533 (wrap-subst130 w531))) (if (and (pair? ms532) (eq? (car ms532) #f)) (make-syntax-object109 (syntax-object-expression111 x529) (make-wrap128 (cdr ms532) (if rib526 (cons rib526 (cdr s533)) (cdr s533))) (syntax-object-module113 x529)) (make-syntax-object109 (syntax-object-expression111 x529) (make-wrap128 (cons m530 ms532) (if rib526 (cons rib526 (cons (quote shift) s533)) (cons (quote shift) s533))) (let ((pmod534 (procedure-module p522))) (if pmod534 (cons (quote hygiene) (module-name pmod534)) (quote (hygiene guile))))))))) ((vector? x529) (let ((n535 (vector-length x529))) (let ((v536 (make-vector n535))) (let doloop537 ((i538 0)) (if (fx=95 i538 n535) v536 (begin (vector-set! v536 i538 (rebuild-macro-output528 (vector-ref x529 i538) m530)) (doloop537 (fx+93 i538 1)))))))) ((symbol? x529) (syntax-error x529 "encountered raw symbol in macro output")) (else x529))))) (rebuild-macro-output528 (p522 (wrap154 e523 (anti-mark141 w525) mod527)) (string #\m))))) (chi-application164 (lambda (x539 e540 r541 w542 s543 mod544) ((lambda (tmp545) ((lambda (tmp546) (if tmp546 (apply (lambda (e0547 e1548) (build-annotated103 s543 (cons x539 (map (lambda (e549) (chi162 e549 r541 w542 mod544)) e1548)))) tmp546) (syntax-error tmp545))) (syntax-dispatch tmp545 (quote (any . each-any))))) e540))) (chi-expr163 (lambda (type551 value552 e553 r554 w555 s556 mod557) (let ((t558 type551)) (if (memv t558 (quote (lexical))) (build-annotated103 s556 value552) (if (memv t558 (quote (core external-macro))) (value552 e553 r554 w555 s556 mod557) (if (memv t558 (quote (module-ref))) (call-with-values (lambda () (value552 e553)) (lambda (id559 mod560) (build-annotated103 s556 (if mod560 (make-module-ref (cdr mod560) id559 (car mod560)) (make-module-ref mod560 id559 (quote bare)))))) (if (memv t558 (quote (lexical-call))) (chi-application164 (build-annotated103 (source-annotation117 (car e553)) value552) e553 r554 w555 s556 mod557) (if (memv t558 (quote (global-call))) (chi-application164 (build-annotated103 (source-annotation117 (car e553)) (if (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557) (make-module-ref (cdr (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557)) value552 (car (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557))) (make-module-ref (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557) value552 (quote bare)))) e553 r554 w555 s556 mod557) (if (memv t558 (quote (constant))) (build-data104 s556 (strip173 (source-wrap155 e553 w555 s556 mod557) (quote (())))) (if (memv t558 (quote (global))) (build-annotated103 s556 (if mod557 (make-module-ref (cdr mod557) value552 (car mod557)) (make-module-ref mod557 value552 (quote bare)))) (if (memv t558 (quote (call))) (chi-application164 (chi162 (car e553) r554 w555 mod557) e553 r554 w555 s556 mod557) (if (memv t558 (quote (begin-form))) ((lambda (tmp561) ((lambda (tmp562) (if tmp562 (apply (lambda (_563 e1564 e2565) (chi-sequence156 (cons e1564 e2565) r554 w555 s556 mod557)) tmp562) (syntax-error tmp561))) (syntax-dispatch tmp561 (quote (any any . each-any))))) e553) (if (memv t558 (quote (local-syntax-form))) (chi-local-syntax168 value552 e553 r554 w555 s556 mod557 chi-sequence156) (if (memv t558 (quote (eval-when-form))) ((lambda (tmp567) ((lambda (tmp568) (if tmp568 (apply (lambda (_569 x570 e1571 e2572) (let ((when-list573 (chi-when-list159 e553 x570 w555))) (if (memq (quote eval) when-list573) (chi-sequence156 (cons e1571 e2572) r554 w555 s556 mod557) (chi-void170)))) tmp568) (syntax-error tmp567))) (syntax-dispatch tmp567 (quote (any each-any any . each-any))))) e553) (if (memv t558 (quote (define-form define-syntax-form))) (syntax-error (wrap154 value552 w555 mod557) "invalid context for definition of") (if (memv t558 (quote (syntax))) (syntax-error (source-wrap155 e553 w555 s556 mod557) "reference to pattern variable outside syntax form") (if (memv t558 (quote (displaced-lexical))) (syntax-error (source-wrap155 e553 w555 s556 mod557) "reference to identifier outside its scope") (syntax-error (source-wrap155 e553 w555 s556 mod557))))))))))))))))))) (chi162 (lambda (e576 r577 w578 mod579) (call-with-values (lambda () (syntax-type160 e576 r577 w578 #f #f mod579)) (lambda (type580 value581 e582 w583 s584 mod585) (chi-expr163 type580 value581 e582 r577 w583 s584 mod585))))) (chi-top161 (lambda (e586 r587 w588 m589 esew590 mod591) (call-with-values (lambda () (syntax-type160 e586 r587 w588 #f #f mod591)) (lambda (type599 value600 e601 w602 s603 mod604) (let ((t605 type599)) (if (memv t605 (quote (begin-form))) ((lambda (tmp606) ((lambda (tmp607) (if tmp607 (apply (lambda (_608) (chi-void170)) tmp607) ((lambda (tmp609) (if tmp609 (apply (lambda (_610 e1611 e2612) (chi-top-sequence157 (cons e1611 e2612) r587 w602 s603 m589 esew590 mod604)) tmp609) (syntax-error tmp606))) (syntax-dispatch tmp606 (quote (any any . each-any)))))) (syntax-dispatch tmp606 (quote (any))))) e601) (if (memv t605 (quote (local-syntax-form))) (chi-local-syntax168 value600 e601 r587 w602 s603 mod604 (lambda (body614 r615 w616 s617 mod618) (chi-top-sequence157 body614 r615 w616 s617 m589 esew590 mod618))) (if (memv t605 (quote (eval-when-form))) ((lambda (tmp619) ((lambda (tmp620) (if tmp620 (apply (lambda (_621 x622 e1623 e2624) (let ((when-list625 (chi-when-list159 e601 x622 w602)) (body626 (cons e1623 e2624))) (cond ((eq? m589 (quote e)) (if (memq (quote eval) when-list625) (chi-top-sequence157 body626 r587 w602 s603 (quote e) (quote (eval)) mod604) (chi-void170))) ((memq (quote load) when-list625) (if (or (memq (quote compile) when-list625) (and (eq? m589 (quote c&e)) (memq (quote eval) when-list625))) (chi-top-sequence157 body626 r587 w602 s603 (quote c&e) (quote (compile load)) mod604) (if (memq m589 (quote (c c&e))) (chi-top-sequence157 body626 r587 w602 s603 (quote c) (quote (load)) mod604) (chi-void170)))) ((or (memq (quote compile) when-list625) (and (eq? m589 (quote c&e)) (memq (quote eval) when-list625))) (top-level-eval-hook97 (chi-top-sequence157 body626 r587 w602 s603 (quote e) (quote (eval)) mod604) mod604) (chi-void170)) (else (chi-void170))))) tmp620) (syntax-error tmp619))) (syntax-dispatch tmp619 (quote (any each-any any . each-any))))) e601) (if (memv t605 (quote (define-syntax-form))) (let ((n629 (id-var-name148 value600 w602)) (r630 (macros-only-env122 r587))) (let ((t631 m589)) (if (memv t631 (quote (c))) (if (memq (quote compile) esew590) (let ((e632 (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)))) (begin (top-level-eval-hook97 e632 mod604) (if (memq (quote load) esew590) e632 (chi-void170)))) (if (memq (quote load) esew590) (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)) (chi-void170))) (if (memv t631 (quote (c&e))) (let ((e633 (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)))) (begin (top-level-eval-hook97 e633 mod604) e633)) (begin (if (memq (quote eval) esew590) (top-level-eval-hook97 (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)) mod604)) (chi-void170)))))) (if (memv t605 (quote (define-form))) (let ((n634 (id-var-name148 value600 w602))) (let ((type635 (binding-type118 (lookup123 n634 r587 mod604)))) (let ((t636 type635)) (if (memv t636 (quote (global))) (let ((x637 (build-annotated103 s603 (list (quote define) n634 (chi162 e601 r587 w602 mod604))))) (begin (if (eq? m589 (quote c&e)) (top-level-eval-hook97 x637 mod604)) x637)) (if (memv t636 (quote (displaced-lexical))) (syntax-error (wrap154 value600 w602 mod604) "identifier out of context") (if (memv t636 (quote (core macro module-ref))) (begin (remove-global-definition-hook101 n634) (let ((x638 (build-annotated103 s603 (list (quote define) n634 (chi162 e601 r587 w602 mod604))))) (begin (if (eq? m589 (quote c&e)) (top-level-eval-hook97 x638 mod604)) x638))) (syntax-error (wrap154 value600 w602 mod604) "cannot define keyword at top level"))))))) (let ((x639 (chi-expr163 type599 value600 e601 r587 w602 s603 mod604))) (begin (if (eq? m589 (quote c&e)) (top-level-eval-hook97 x639 mod604)) x639)))))))))))) (syntax-type160 (lambda (e640 r641 w642 s643 rib644 mod645) (cond ((symbol? e640) (let ((n646 (id-var-name148 e640 w642))) (let ((b647 (lookup123 n646 r641 mod645))) (let ((type648 (binding-type118 b647))) (let ((t649 type648)) (if (memv t649 (quote (lexical))) (values type648 (binding-value119 b647) e640 w642 s643 mod645) (if (memv t649 (quote (global))) (values type648 n646 e640 w642 s643 mod645) (if (memv t649 (quote (macro))) (syntax-type160 (chi-macro165 (binding-value119 b647) e640 r641 w642 rib644 mod645) r641 (quote (())) s643 rib644 mod645) (values type648 (binding-value119 b647) e640 w642 s643 mod645))))))))) ((pair? e640) (let ((first650 (car e640))) (if (id?126 first650) (let ((n651 (id-var-name148 first650 w642))) (let ((b652 (lookup123 n651 r641 (or (and (syntax-object?110 first650) (syntax-object-module113 first650)) mod645)))) (let ((type653 (binding-type118 b652))) (let ((t654 type653)) (if (memv t654 (quote (lexical))) (values (quote lexical-call) (binding-value119 b652) e640 w642 s643 mod645) (if (memv t654 (quote (global))) (values (quote global-call) n651 e640 w642 s643 mod645) (if (memv t654 (quote (macro))) (syntax-type160 (chi-macro165 (binding-value119 b652) e640 r641 w642 rib644 mod645) r641 (quote (())) s643 rib644 mod645) (if (memv t654 (quote (core external-macro module-ref))) (values type653 (binding-value119 b652) e640 w642 s643 mod645) (if (memv t654 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value119 b652) e640 w642 s643 mod645) (if (memv t654 (quote (begin))) (values (quote begin-form) #f e640 w642 s643 mod645) (if (memv t654 (quote (eval-when))) (values (quote eval-when-form) #f e640 w642 s643 mod645) (if (memv t654 (quote (define))) ((lambda (tmp655) ((lambda (tmp656) (if (if tmp656 (apply (lambda (_657 name658 val659) (id?126 name658)) tmp656) #f) (apply (lambda (_660 name661 val662) (values (quote define-form) name661 val662 w642 s643 mod645)) tmp656) ((lambda (tmp663) (if (if tmp663 (apply (lambda (_664 name665 args666 e1667 e2668) (and (id?126 name665) (valid-bound-ids?151 (lambda-var-list175 args666)))) tmp663) #f) (apply (lambda (_669 name670 args671 e1672 e2673) (values (quote define-form) (wrap154 name670 w642 mod645) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap154 (cons args671 (cons e1672 e2673)) w642 mod645)) (quote (())) s643 mod645)) tmp663) ((lambda (tmp675) (if (if tmp675 (apply (lambda (_676 name677) (id?126 name677)) tmp675) #f) (apply (lambda (_678 name679) (values (quote define-form) (wrap154 name679 w642 mod645) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s643 mod645)) tmp675) (syntax-error tmp655))) (syntax-dispatch tmp655 (quote (any any)))))) (syntax-dispatch tmp655 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp655 (quote (any any any))))) e640) (if (memv t654 (quote (define-syntax))) ((lambda (tmp680) ((lambda (tmp681) (if (if tmp681 (apply (lambda (_682 name683 val684) (id?126 name683)) tmp681) #f) (apply (lambda (_685 name686 val687) (values (quote define-syntax-form) name686 val687 w642 s643 mod645)) tmp681) (syntax-error tmp680))) (syntax-dispatch tmp680 (quote (any any any))))) e640) (values (quote call) #f e640 w642 s643 mod645)))))))))))))) (values (quote call) #f e640 w642 s643 mod645)))) ((syntax-object?110 e640) (syntax-type160 (syntax-object-expression111 e640) r641 (join-wraps145 w642 (syntax-object-wrap112 e640)) #f rib644 (or (syntax-object-module113 e640) mod645))) ((annotation? e640) (syntax-type160 (annotation-expression e640) r641 w642 (annotation-source e640) rib644 mod645)) ((self-evaluating? e640) (values (quote constant) #f e640 w642 s643 mod645)) (else (values (quote other) #f e640 w642 s643 mod645))))) (chi-when-list159 (lambda (e688 when-list689 w690) (let f691 ((when-list692 when-list689) (situations693 (quote ()))) (if (null? when-list692) situations693 (f691 (cdr when-list692) (cons (let ((x694 (car when-list692))) (cond ((free-id=?149 x694 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?149 x694 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?149 x694 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap154 x694 w690 #f) "invalid eval-when situation")))) situations693)))))) (chi-install-global158 (lambda (name695 e696) (build-annotated103 #f (list (build-annotated103 #f (quote install-global-transformer)) (build-data104 #f name695) e696)))) (chi-top-sequence157 (lambda (body697 r698 w699 s700 m701 esew702 mod703) (build-sequence105 s700 (let dobody704 ((body705 body697) (r706 r698) (w707 w699) (m708 m701) (esew709 esew702) (mod710 mod703)) (if (null? body705) (quote ()) (let ((first711 (chi-top161 (car body705) r706 w707 m708 esew709 mod710))) (cons first711 (dobody704 (cdr body705) r706 w707 m708 esew709 mod710)))))))) (chi-sequence156 (lambda (body712 r713 w714 s715 mod716) (build-sequence105 s715 (let dobody717 ((body718 body712) (r719 r713) (w720 w714) (mod721 mod716)) (if (null? body718) (quote ()) (let ((first722 (chi162 (car body718) r719 w720 mod721))) (cons first722 (dobody717 (cdr body718) r719 w720 mod721)))))))) (source-wrap155 (lambda (x723 w724 s725 defmod726) (wrap154 (if s725 (make-annotation x723 s725 #f) x723) w724 defmod726))) (wrap154 (lambda (x727 w728 defmod729) (cond ((and (null? (wrap-marks129 w728)) (null? (wrap-subst130 w728))) x727) ((syntax-object?110 x727) (make-syntax-object109 (syntax-object-expression111 x727) (join-wraps145 w728 (syntax-object-wrap112 x727)) (syntax-object-module113 x727))) ((null? x727) x727) (else (make-syntax-object109 x727 w728 defmod729))))) (bound-id-member?153 (lambda (x730 list731) (and (not (null? list731)) (or (bound-id=?150 x730 (car list731)) (bound-id-member?153 x730 (cdr list731)))))) (distinct-bound-ids?152 (lambda (ids732) (let distinct?733 ((ids734 ids732)) (or (null? ids734) (and (not (bound-id-member?153 (car ids734) (cdr ids734))) (distinct?733 (cdr ids734))))))) (valid-bound-ids?151 (lambda (ids735) (and (let all-ids?736 ((ids737 ids735)) (or (null? ids737) (and (id?126 (car ids737)) (all-ids?736 (cdr ids737))))) (distinct-bound-ids?152 ids735)))) (bound-id=?150 (lambda (i738 j739) (if (and (syntax-object?110 i738) (syntax-object?110 j739)) (and (eq? (let ((e740 (syntax-object-expression111 i738))) (if (annotation? e740) (annotation-expression e740) e740)) (let ((e741 (syntax-object-expression111 j739))) (if (annotation? e741) (annotation-expression e741) e741))) (same-marks?147 (wrap-marks129 (syntax-object-wrap112 i738)) (wrap-marks129 (syntax-object-wrap112 j739)))) (eq? (let ((e742 i738)) (if (annotation? e742) (annotation-expression e742) e742)) (let ((e743 j739)) (if (annotation? e743) (annotation-expression e743) e743)))))) (free-id=?149 (lambda (i744 j745) (and (eq? (let ((x746 i744)) (let ((e747 (if (syntax-object?110 x746) (syntax-object-expression111 x746) x746))) (if (annotation? e747) (annotation-expression e747) e747))) (let ((x748 j745)) (let ((e749 (if (syntax-object?110 x748) (syntax-object-expression111 x748) x748))) (if (annotation? e749) (annotation-expression e749) e749)))) (eq? (id-var-name148 i744 (quote (()))) (id-var-name148 j745 (quote (()))))))) (id-var-name148 (lambda (id750 w751) (letrec ((search-vector-rib754 (lambda (sym760 subst761 marks762 symnames763 ribcage764) (let ((n765 (vector-length symnames763))) (let f766 ((i767 0)) (cond ((fx=95 i767 n765) (search752 sym760 (cdr subst761) marks762)) ((and (eq? (vector-ref symnames763 i767) sym760) (same-marks?147 marks762 (vector-ref (ribcage-marks136 ribcage764) i767))) (values (vector-ref (ribcage-labels137 ribcage764) i767) marks762)) (else (f766 (fx+93 i767 1)))))))) (search-list-rib753 (lambda (sym768 subst769 marks770 symnames771 ribcage772) (let f773 ((symnames774 symnames771) (i775 0)) (cond ((null? symnames774) (search752 sym768 (cdr subst769) marks770)) ((and (eq? (car symnames774) sym768) (same-marks?147 marks770 (list-ref (ribcage-marks136 ribcage772) i775))) (values (list-ref (ribcage-labels137 ribcage772) i775) marks770)) (else (f773 (cdr symnames774) (fx+93 i775 1))))))) (search752 (lambda (sym776 subst777 marks778) (if (null? subst777) (values #f marks778) (let ((fst779 (car subst777))) (if (eq? fst779 (quote shift)) (search752 sym776 (cdr subst777) (cdr marks778)) (let ((symnames780 (ribcage-symnames135 fst779))) (if (vector? symnames780) (search-vector-rib754 sym776 subst777 marks778 symnames780 fst779) (search-list-rib753 sym776 subst777 marks778 symnames780 fst779))))))))) (cond ((symbol? id750) (or (call-with-values (lambda () (search752 id750 (wrap-subst130 w751) (wrap-marks129 w751))) (lambda (x782 . ignore781) x782)) id750)) ((syntax-object?110 id750) (let ((id783 (let ((e785 (syntax-object-expression111 id750))) (if (annotation? e785) (annotation-expression e785) e785))) (w1784 (syntax-object-wrap112 id750))) (let ((marks786 (join-marks146 (wrap-marks129 w751) (wrap-marks129 w1784)))) (call-with-values (lambda () (search752 id783 (wrap-subst130 w751) marks786)) (lambda (new-id787 marks788) (or new-id787 (call-with-values (lambda () (search752 id783 (wrap-subst130 w1784) marks788)) (lambda (x790 . ignore789) x790)) id783)))))) ((annotation? id750) (let ((id791 (let ((e792 id750)) (if (annotation? e792) (annotation-expression e792) e792)))) (or (call-with-values (lambda () (search752 id791 (wrap-subst130 w751) (wrap-marks129 w751))) (lambda (x794 . ignore793) x794)) id791))) (else (error-hook99 (quote id-var-name) "invalid id" id750)))))) (same-marks?147 (lambda (x795 y796) (or (eq? x795 y796) (and (not (null? x795)) (not (null? y796)) (eq? (car x795) (car y796)) (same-marks?147 (cdr x795) (cdr y796)))))) (join-marks146 (lambda (m1797 m2798) (smart-append144 m1797 m2798))) (join-wraps145 (lambda (w1799 w2800) (let ((m1801 (wrap-marks129 w1799)) (s1802 (wrap-subst130 w1799))) (if (null? m1801) (if (null? s1802) w2800 (make-wrap128 (wrap-marks129 w2800) (smart-append144 s1802 (wrap-subst130 w2800)))) (make-wrap128 (smart-append144 m1801 (wrap-marks129 w2800)) (smart-append144 s1802 (wrap-subst130 w2800))))))) (smart-append144 (lambda (m1803 m2804) (if (null? m2804) m1803 (append m1803 m2804)))) (make-binding-wrap143 (lambda (ids805 labels806 w807) (if (null? ids805) w807 (make-wrap128 (wrap-marks129 w807) (cons (let ((labelvec808 (list->vector labels806))) (let ((n809 (vector-length labelvec808))) (let ((symnamevec810 (make-vector n809)) (marksvec811 (make-vector n809))) (begin (let f812 ((ids813 ids805) (i814 0)) (if (not (null? ids813)) (call-with-values (lambda () (id-sym-name&marks127 (car ids813) w807)) (lambda (symname815 marks816) (begin (vector-set! symnamevec810 i814 symname815) (vector-set! marksvec811 i814 marks816) (f812 (cdr ids813) (fx+93 i814 1))))))) (make-ribcage133 symnamevec810 marksvec811 labelvec808))))) (wrap-subst130 w807)))))) (extend-ribcage!142 (lambda (ribcage817 id818 label819) (begin (set-ribcage-symnames!138 ribcage817 (cons (let ((e820 (syntax-object-expression111 id818))) (if (annotation? e820) (annotation-expression e820) e820)) (ribcage-symnames135 ribcage817))) (set-ribcage-marks!139 ribcage817 (cons (wrap-marks129 (syntax-object-wrap112 id818)) (ribcage-marks136 ribcage817))) (set-ribcage-labels!140 ribcage817 (cons label819 (ribcage-labels137 ribcage817)))))) (anti-mark141 (lambda (w821) (make-wrap128 (cons #f (wrap-marks129 w821)) (cons (quote shift) (wrap-subst130 w821))))) (set-ribcage-labels!140 (lambda (x822 update823) (vector-set! x822 3 update823))) (set-ribcage-marks!139 (lambda (x824 update825) (vector-set! x824 2 update825))) (set-ribcage-symnames!138 (lambda (x826 update827) (vector-set! x826 1 update827))) (ribcage-labels137 (lambda (x828) (vector-ref x828 3))) (ribcage-marks136 (lambda (x829) (vector-ref x829 2))) (ribcage-symnames135 (lambda (x830) (vector-ref x830 1))) (ribcage?134 (lambda (x831) (and (vector? x831) (= (vector-length x831) 4) (eq? (vector-ref x831 0) (quote ribcage))))) (make-ribcage133 (lambda (symnames832 marks833 labels834) (vector (quote ribcage) symnames832 marks833 labels834))) (gen-labels132 (lambda (ls835) (if (null? ls835) (quote ()) (cons (gen-label131) (gen-labels132 (cdr ls835)))))) (gen-label131 (lambda () (string #\i))) (wrap-subst130 cdr) (wrap-marks129 car) (make-wrap128 cons) (id-sym-name&marks127 (lambda (x836 w837) (if (syntax-object?110 x836) (values (let ((e838 (syntax-object-expression111 x836))) (if (annotation? e838) (annotation-expression e838) e838)) (join-marks146 (wrap-marks129 w837) (wrap-marks129 (syntax-object-wrap112 x836)))) (values (let ((e839 x836)) (if (annotation? e839) (annotation-expression e839) e839)) (wrap-marks129 w837))))) (id?126 (lambda (x840) (cond ((symbol? x840) #t) ((syntax-object?110 x840) (symbol? (let ((e841 (syntax-object-expression111 x840))) (if (annotation? e841) (annotation-expression e841) e841)))) ((annotation? x840) (symbol? (annotation-expression x840))) (else #f)))) (nonsymbol-id?125 (lambda (x842) (and (syntax-object?110 x842) (symbol? (let ((e843 (syntax-object-expression111 x842))) (if (annotation? e843) (annotation-expression e843) e843)))))) (global-extend124 (lambda (type844 sym845 val846) (put-global-definition-hook100 sym845 (cons type844 val846)))) (lookup123 (lambda (x847 r848 mod849) (cond ((assq x847 r848) => cdr) ((symbol? x847) (or (get-global-definition-hook102 x847 mod849) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env122 (lambda (r850) (if (null? r850) (quote ()) (let ((a851 (car r850))) (if (eq? (cadr a851) (quote macro)) (cons a851 (macros-only-env122 (cdr r850))) (macros-only-env122 (cdr r850))))))) (extend-var-env121 (lambda (labels852 vars853 r854) (if (null? labels852) r854 (extend-var-env121 (cdr labels852) (cdr vars853) (cons (cons (car labels852) (cons (quote lexical) (car vars853))) r854))))) (extend-env120 (lambda (labels855 bindings856 r857) (if (null? labels855) r857 (extend-env120 (cdr labels855) (cdr bindings856) (cons (cons (car labels855) (car bindings856)) r857))))) (binding-value119 cdr) (binding-type118 car) (source-annotation117 (lambda (x858) (cond ((annotation? x858) (annotation-source x858)) ((syntax-object?110 x858) (source-annotation117 (syntax-object-expression111 x858))) (else #f)))) (set-syntax-object-module!116 (lambda (x859 update860) (vector-set! x859 3 update860))) (set-syntax-object-wrap!115 (lambda (x861 update862) (vector-set! x861 2 update862))) (set-syntax-object-expression!114 (lambda (x863 update864) (vector-set! x863 1 update864))) (syntax-object-module113 (lambda (x865) (vector-ref x865 3))) (syntax-object-wrap112 (lambda (x866) (vector-ref x866 2))) (syntax-object-expression111 (lambda (x867) (vector-ref x867 1))) (syntax-object?110 (lambda (x868) (and (vector? x868) (= (vector-length x868) 4) (eq? (vector-ref x868 0) (quote syntax-object))))) (make-syntax-object109 (lambda (expression869 wrap870 module871) (vector (quote syntax-object) expression869 wrap870 module871))) (build-letrec108 (lambda (src872 vars873 val-exps874 body-exp875) (if (null? vars873) (build-annotated103 src872 body-exp875) (build-annotated103 src872 (list (quote letrec) (map list vars873 val-exps874) body-exp875))))) (build-named-let107 (lambda (src876 vars877 val-exps878 body-exp879) (if (null? vars877) (build-annotated103 src876 body-exp879) (build-annotated103 src876 (list (quote let) (car vars877) (map list (cdr vars877) val-exps878) body-exp879))))) (build-let106 (lambda (src880 vars881 val-exps882 body-exp883) (if (null? vars881) (build-annotated103 src880 body-exp883) (build-annotated103 src880 (list (quote let) (map list vars881 val-exps882) body-exp883))))) (build-sequence105 (lambda (src884 exps885) (if (null? (cdr exps885)) (build-annotated103 src884 (car exps885)) (build-annotated103 src884 (cons (quote begin) exps885))))) (build-data104 (lambda (src886 exp887) (if (and (self-evaluating? exp887) (not (vector? exp887))) (build-annotated103 src886 exp887) (build-annotated103 src886 (list (quote quote) exp887))))) (build-annotated103 (lambda (src888 exp889) (if (and src888 (not (annotation? exp889))) (make-annotation exp889 src888 #t) exp889))) (get-global-definition-hook102 (lambda (symbol890 module891) (let ((module892 (if module891 (resolve-module (cdr module891)) (let ((mod893 (current-module))) (begin (if mod893 (warn "wha" symbol890)) mod893))))) (let ((v894 (module-variable module892 symbol890))) (and v894 (object-property v894 (quote *sc-expander*))))))) (remove-global-definition-hook101 (lambda (symbol895) (let ((module896 (current-module))) (let ((v897 (module-local-variable module896 symbol895))) (if v897 (let ((p898 (assq (quote *sc-expander*) (object-properties v897)))) (set-object-properties! v897 (delq p898 (object-properties v897))))))))) (put-global-definition-hook100 (lambda (symbol899 binding900) (let ((module901 (current-module))) (let ((v902 (or (module-variable module901 symbol899) (let ((v903 (make-variable (gensym)))) (begin (module-add! module901 symbol899 v903) v903))))) (begin (if (not (variable-bound? v902)) (variable-set! v902 (gensym))) (set-object-property! v902 (quote *sc-expander*) binding900)))))) (error-hook99 (lambda (who904 why905 what906) (error who904 "~a ~s" why905 what906))) (local-eval-hook98 (lambda (x907 mod908) (primitive-eval (list noexpand92 x907)))) (top-level-eval-hook97 (lambda (x909 mod910) (primitive-eval (list noexpand92 x909)))) (fx<96 <) (fx=95 =) (fx-94 -) (fx+93 +) (noexpand92 "noexpand")) (begin (global-extend124 (quote local-syntax) (quote letrec-syntax) #t) (global-extend124 (quote local-syntax) (quote let-syntax) #f) (global-extend124 (quote core) (quote fluid-let-syntax) (lambda (e911 r912 w913 s914 mod915) ((lambda (tmp916) ((lambda (tmp917) (if (if tmp917 (apply (lambda (_918 var919 val920 e1921 e2922) (valid-bound-ids?151 var919)) tmp917) #f) (apply (lambda (_924 var925 val926 e1927 e2928) (let ((names929 (map (lambda (x930) (id-var-name148 x930 w913)) var925))) (begin (for-each (lambda (id932 n933) (let ((t934 (binding-type118 (lookup123 n933 r912 mod915)))) (if (memv t934 (quote (displaced-lexical))) (syntax-error (source-wrap155 id932 w913 s914 mod915) "identifier out of context")))) var925 names929) (chi-body166 (cons e1927 e2928) (source-wrap155 e911 w913 s914 mod915) (extend-env120 names929 (let ((trans-r937 (macros-only-env122 r912))) (map (lambda (x938) (cons (quote macro) (eval-local-transformer169 (chi162 x938 trans-r937 w913 mod915) mod915))) val926)) r912) w913 mod915)))) tmp917) ((lambda (_940) (syntax-error (source-wrap155 e911 w913 s914 mod915))) tmp916))) (syntax-dispatch tmp916 (quote (any #(each (any any)) any . each-any))))) e911))) (global-extend124 (quote core) (quote quote) (lambda (e941 r942 w943 s944 mod945) ((lambda (tmp946) ((lambda (tmp947) (if tmp947 (apply (lambda (_948 e949) (build-data104 s944 (strip173 e949 w943))) tmp947) ((lambda (_950) (syntax-error (source-wrap155 e941 w943 s944 mod945))) tmp946))) (syntax-dispatch tmp946 (quote (any any))))) e941))) (global-extend124 (quote core) (quote syntax) (letrec ((regen958 (lambda (x959) (let ((t960 (car x959))) (if (memv t960 (quote (ref))) (build-annotated103 #f (cadr x959)) (if (memv t960 (quote (primitive))) (build-annotated103 #f (cadr x959)) (if (memv t960 (quote (quote))) (build-data104 #f (cadr x959)) (if (memv t960 (quote (lambda))) (build-annotated103 #f (list (quote lambda) (cadr x959) (regen958 (caddr x959)))) (if (memv t960 (quote (map))) (let ((ls961 (map regen958 (cdr x959)))) (build-annotated103 #f (cons (if (fx=95 (length ls961) 2) (build-annotated103 #f (quote map)) (build-annotated103 #f (quote map))) ls961))) (build-annotated103 #f (cons (build-annotated103 #f (car x959)) (map regen958 (cdr x959)))))))))))) (gen-vector957 (lambda (x962) (cond ((eq? (car x962) (quote list)) (cons (quote vector) (cdr x962))) ((eq? (car x962) (quote quote)) (list (quote quote) (list->vector (cadr x962)))) (else (list (quote list->vector) x962))))) (gen-append956 (lambda (x963 y964) (if (equal? y964 (quote (quote ()))) x963 (list (quote append) x963 y964)))) (gen-cons955 (lambda (x965 y966) (let ((t967 (car y966))) (if (memv t967 (quote (quote))) (if (eq? (car x965) (quote quote)) (list (quote quote) (cons (cadr x965) (cadr y966))) (if (eq? (cadr y966) (quote ())) (list (quote list) x965) (list (quote cons) x965 y966))) (if (memv t967 (quote (list))) (cons (quote list) (cons x965 (cdr y966))) (list (quote cons) x965 y966)))))) (gen-map954 (lambda (e968 map-env969) (let ((formals970 (map cdr map-env969)) (actuals971 (map (lambda (x972) (list (quote ref) (car x972))) map-env969))) (cond ((eq? (car e968) (quote ref)) (car actuals971)) ((andmap (lambda (x973) (and (eq? (car x973) (quote ref)) (memq (cadr x973) formals970))) (cdr e968)) (cons (quote map) (cons (list (quote primitive) (car e968)) (map (let ((r974 (map cons formals970 actuals971))) (lambda (x975) (cdr (assq (cadr x975) r974)))) (cdr e968))))) (else (cons (quote map) (cons (list (quote lambda) formals970 e968) actuals971))))))) (gen-mappend953 (lambda (e976 map-env977) (list (quote apply) (quote (primitive append)) (gen-map954 e976 map-env977)))) (gen-ref952 (lambda (src978 var979 level980 maps981) (if (fx=95 level980 0) (values var979 maps981) (if (null? maps981) (syntax-error src978 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref952 src978 var979 (fx-94 level980 1) (cdr maps981))) (lambda (outer-var982 outer-maps983) (let ((b984 (assq outer-var982 (car maps981)))) (if b984 (values (cdr b984) maps981) (let ((inner-var985 (gen-var174 (quote tmp)))) (values inner-var985 (cons (cons (cons outer-var982 inner-var985) (car maps981)) outer-maps983))))))))))) (gen-syntax951 (lambda (src986 e987 r988 maps989 ellipsis?990 mod991) (if (id?126 e987) (let ((label992 (id-var-name148 e987 (quote (()))))) (let ((b993 (lookup123 label992 r988 mod991))) (if (eq? (binding-type118 b993) (quote syntax)) (call-with-values (lambda () (let ((var.lev994 (binding-value119 b993))) (gen-ref952 src986 (car var.lev994) (cdr var.lev994) maps989))) (lambda (var995 maps996) (values (list (quote ref) var995) maps996))) (if (ellipsis?990 e987) (syntax-error src986 "misplaced ellipsis in syntax form") (values (list (quote quote) e987) maps989))))) ((lambda (tmp997) ((lambda (tmp998) (if (if tmp998 (apply (lambda (dots999 e1000) (ellipsis?990 dots999)) tmp998) #f) (apply (lambda (dots1001 e1002) (gen-syntax951 src986 e1002 r988 maps989 (lambda (x1003) #f) mod991)) tmp998) ((lambda (tmp1004) (if (if tmp1004 (apply (lambda (x1005 dots1006 y1007) (ellipsis?990 dots1006)) tmp1004) #f) (apply (lambda (x1008 dots1009 y1010) (let f1011 ((y1012 y1010) (k1013 (lambda (maps1014) (call-with-values (lambda () (gen-syntax951 src986 x1008 r988 (cons (quote ()) maps1014) ellipsis?990 mod991)) (lambda (x1015 maps1016) (if (null? (car maps1016)) (syntax-error src986 "extra ellipsis in syntax form") (values (gen-map954 x1015 (car maps1016)) (cdr maps1016)))))))) ((lambda (tmp1017) ((lambda (tmp1018) (if (if tmp1018 (apply (lambda (dots1019 y1020) (ellipsis?990 dots1019)) tmp1018) #f) (apply (lambda (dots1021 y1022) (f1011 y1022 (lambda (maps1023) (call-with-values (lambda () (k1013 (cons (quote ()) maps1023))) (lambda (x1024 maps1025) (if (null? (car maps1025)) (syntax-error src986 "extra ellipsis in syntax form") (values (gen-mappend953 x1024 (car maps1025)) (cdr maps1025)))))))) tmp1018) ((lambda (_1026) (call-with-values (lambda () (gen-syntax951 src986 y1012 r988 maps989 ellipsis?990 mod991)) (lambda (y1027 maps1028) (call-with-values (lambda () (k1013 maps1028)) (lambda (x1029 maps1030) (values (gen-append956 x1029 y1027) maps1030)))))) tmp1017))) (syntax-dispatch tmp1017 (quote (any . any))))) y1012))) tmp1004) ((lambda (tmp1031) (if tmp1031 (apply (lambda (x1032 y1033) (call-with-values (lambda () (gen-syntax951 src986 x1032 r988 maps989 ellipsis?990 mod991)) (lambda (x1034 maps1035) (call-with-values (lambda () (gen-syntax951 src986 y1033 r988 maps1035 ellipsis?990 mod991)) (lambda (y1036 maps1037) (values (gen-cons955 x1034 y1036) maps1037)))))) tmp1031) ((lambda (tmp1038) (if tmp1038 (apply (lambda (e11039 e21040) (call-with-values (lambda () (gen-syntax951 src986 (cons e11039 e21040) r988 maps989 ellipsis?990 mod991)) (lambda (e1042 maps1043) (values (gen-vector957 e1042) maps1043)))) tmp1038) ((lambda (_1044) (values (list (quote quote) e987) maps989)) tmp997))) (syntax-dispatch tmp997 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp997 (quote (any . any)))))) (syntax-dispatch tmp997 (quote (any any . any)))))) (syntax-dispatch tmp997 (quote (any any))))) e987))))) (lambda (e1045 r1046 w1047 s1048 mod1049) (let ((e1050 (source-wrap155 e1045 w1047 s1048 mod1049))) ((lambda (tmp1051) ((lambda (tmp1052) (if tmp1052 (apply (lambda (_1053 x1054) (call-with-values (lambda () (gen-syntax951 e1050 x1054 r1046 (quote ()) ellipsis?171 mod1049)) (lambda (e1055 maps1056) (regen958 e1055)))) tmp1052) ((lambda (_1057) (syntax-error e1050)) tmp1051))) (syntax-dispatch tmp1051 (quote (any any))))) e1050))))) (global-extend124 (quote core) (quote lambda) (lambda (e1058 r1059 w1060 s1061 mod1062) ((lambda (tmp1063) ((lambda (tmp1064) (if tmp1064 (apply (lambda (_1065 c1066) (chi-lambda-clause167 (source-wrap155 e1058 w1060 s1061 mod1062) #f c1066 r1059 w1060 mod1062 (lambda (vars1067 docstring1068 body1069) (build-annotated103 s1061 (cons (quote lambda) (cons vars1067 (append (if docstring1068 (list docstring1068) (quote ())) (list body1069)))))))) tmp1064) (syntax-error tmp1063))) (syntax-dispatch tmp1063 (quote (any . any))))) e1058))) (global-extend124 (quote core) (quote let) (letrec ((chi-let1070 (lambda (e1071 r1072 w1073 s1074 mod1075 constructor1076 ids1077 vals1078 exps1079) (if (not (valid-bound-ids?151 ids1077)) (syntax-error e1071 "duplicate bound variable in") (let ((labels1080 (gen-labels132 ids1077)) (new-vars1081 (map gen-var174 ids1077))) (let ((nw1082 (make-binding-wrap143 ids1077 labels1080 w1073)) (nr1083 (extend-var-env121 labels1080 new-vars1081 r1072))) (constructor1076 s1074 new-vars1081 (map (lambda (x1084) (chi162 x1084 r1072 w1073 mod1075)) vals1078) (chi-body166 exps1079 (source-wrap155 e1071 nw1082 s1074 mod1075) nr1083 nw1082 mod1075)))))))) (lambda (e1085 r1086 w1087 s1088 mod1089) ((lambda (tmp1090) ((lambda (tmp1091) (if tmp1091 (apply (lambda (_1092 id1093 val1094 e11095 e21096) (chi-let1070 e1085 r1086 w1087 s1088 mod1089 build-let106 id1093 val1094 (cons e11095 e21096))) tmp1091) ((lambda (tmp1100) (if (if tmp1100 (apply (lambda (_1101 f1102 id1103 val1104 e11105 e21106) (id?126 f1102)) tmp1100) #f) (apply (lambda (_1107 f1108 id1109 val1110 e11111 e21112) (chi-let1070 e1085 r1086 w1087 s1088 mod1089 build-named-let107 (cons f1108 id1109) val1110 (cons e11111 e21112))) tmp1100) ((lambda (_1116) (syntax-error (source-wrap155 e1085 w1087 s1088 mod1089))) tmp1090))) (syntax-dispatch tmp1090 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1090 (quote (any #(each (any any)) any . each-any))))) e1085)))) (global-extend124 (quote core) (quote letrec) (lambda (e1117 r1118 w1119 s1120 mod1121) ((lambda (tmp1122) ((lambda (tmp1123) (if tmp1123 (apply (lambda (_1124 id1125 val1126 e11127 e21128) (let ((ids1129 id1125)) (if (not (valid-bound-ids?151 ids1129)) (syntax-error e1117 "duplicate bound variable in") (let ((labels1131 (gen-labels132 ids1129)) (new-vars1132 (map gen-var174 ids1129))) (let ((w1133 (make-binding-wrap143 ids1129 labels1131 w1119)) (r1134 (extend-var-env121 labels1131 new-vars1132 r1118))) (build-letrec108 s1120 new-vars1132 (map (lambda (x1135) (chi162 x1135 r1134 w1133 mod1121)) val1126) (chi-body166 (cons e11127 e21128) (source-wrap155 e1117 w1133 s1120 mod1121) r1134 w1133 mod1121))))))) tmp1123) ((lambda (_1138) (syntax-error (source-wrap155 e1117 w1119 s1120 mod1121))) tmp1122))) (syntax-dispatch tmp1122 (quote (any #(each (any any)) any . each-any))))) e1117))) (global-extend124 (quote core) (quote set!) (lambda (e1139 r1140 w1141 s1142 mod1143) ((lambda (tmp1144) ((lambda (tmp1145) (if (if tmp1145 (apply (lambda (_1146 id1147 val1148) (id?126 id1147)) tmp1145) #f) (apply (lambda (_1149 id1150 val1151) (let ((val1152 (chi162 val1151 r1140 w1141 mod1143)) (n1153 (id-var-name148 id1150 w1141))) (let ((b1154 (lookup123 n1153 r1140 mod1143))) (let ((t1155 (binding-type118 b1154))) (if (memv t1155 (quote (lexical))) (build-annotated103 s1142 (list (quote set!) (binding-value119 b1154) val1152)) (if (memv t1155 (quote (global))) (build-annotated103 s1142 (list (quote set!) (if mod1143 (make-module-ref (cdr mod1143) n1153 (car mod1143)) (make-module-ref mod1143 n1153 (quote bare))) val1152)) (if (memv t1155 (quote (displaced-lexical))) (syntax-error (wrap154 id1150 w1141 mod1143) "identifier out of context") (syntax-error (source-wrap155 e1139 w1141 s1142 mod1143))))))))) tmp1145) ((lambda (tmp1156) (if tmp1156 (apply (lambda (_1157 head1158 tail1159 val1160) (call-with-values (lambda () (syntax-type160 head1158 r1140 (quote (())) #f #f mod1143)) (lambda (type1161 value1162 ee1163 ww1164 ss1165 modmod1166) (let ((t1167 type1161)) (if (memv t1167 (quote (module-ref))) (let ((val1168 (chi162 val1160 r1140 w1141 mod1143))) (call-with-values (lambda () (value1162 (cons head1158 tail1159))) (lambda (id1170 mod1171) (build-annotated103 s1142 (list (quote set!) (if mod1171 (make-module-ref (cdr mod1171) id1170 (car mod1171)) (make-module-ref mod1171 id1170 (quote bare))) val1168))))) (build-annotated103 s1142 (cons (chi162 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head1158) r1140 w1141 mod1143) (map (lambda (e1172) (chi162 e1172 r1140 w1141 mod1143)) (append tail1159 (list val1160)))))))))) tmp1156) ((lambda (_1174) (syntax-error (source-wrap155 e1139 w1141 s1142 mod1143))) tmp1144))) (syntax-dispatch tmp1144 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1144 (quote (any any any))))) e1139))) (global-extend124 (quote module-ref) (quote @) (lambda (e1175) ((lambda (tmp1176) ((lambda (tmp1177) (if (if tmp1177 (apply (lambda (_1178 mod1179 id1180) (and (andmap id?126 mod1179) (id?126 id1180))) tmp1177) #f) (apply (lambda (_1182 mod1183 id1184) (values (syntax-object->datum id1184) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod1183)))) tmp1177) (syntax-error tmp1176))) (syntax-dispatch tmp1176 (quote (any each-any any))))) e1175))) (global-extend124 (quote module-ref) (quote @@) (lambda (e1186) ((lambda (tmp1187) ((lambda (tmp1188) (if (if tmp1188 (apply (lambda (_1189 mod1190 id1191) (and (andmap id?126 mod1190) (id?126 id1191))) tmp1188) #f) (apply (lambda (_1193 mod1194 id1195) (values (syntax-object->datum id1195) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod1194)))) tmp1188) (syntax-error tmp1187))) (syntax-dispatch tmp1187 (quote (any each-any any))))) e1186))) (global-extend124 (quote begin) (quote begin) (quote ())) (global-extend124 (quote define) (quote define) (quote ())) (global-extend124 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend124 (quote eval-when) (quote eval-when) (quote ())) (global-extend124 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1200 (lambda (x1201 keys1202 clauses1203 r1204 mod1205) (if (null? clauses1203) (build-annotated103 #f (list (build-annotated103 #f (quote syntax-error)) x1201)) ((lambda (tmp1206) ((lambda (tmp1207) (if tmp1207 (apply (lambda (pat1208 exp1209) (if (and (id?126 pat1208) (andmap (lambda (x1210) (not (free-id=?149 pat1208 x1210))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys1202))) (let ((labels1211 (list (gen-label131))) (var1212 (gen-var174 pat1208))) (build-annotated103 #f (list (build-annotated103 #f (list (quote lambda) (list var1212) (chi162 exp1209 (extend-env120 labels1211 (list (cons (quote syntax) (cons var1212 0))) r1204) (make-binding-wrap143 (list pat1208) labels1211 (quote (()))) mod1205))) x1201))) (gen-clause1199 x1201 keys1202 (cdr clauses1203) r1204 pat1208 #t exp1209 mod1205))) tmp1207) ((lambda (tmp1213) (if tmp1213 (apply (lambda (pat1214 fender1215 exp1216) (gen-clause1199 x1201 keys1202 (cdr clauses1203) r1204 pat1214 fender1215 exp1216 mod1205)) tmp1213) ((lambda (_1217) (syntax-error (car clauses1203) "invalid syntax-case clause")) tmp1206))) (syntax-dispatch tmp1206 (quote (any any any)))))) (syntax-dispatch tmp1206 (quote (any any))))) (car clauses1203))))) (gen-clause1199 (lambda (x1218 keys1219 clauses1220 r1221 pat1222 fender1223 exp1224 mod1225) (call-with-values (lambda () (convert-pattern1197 pat1222 keys1219)) (lambda (p1226 pvars1227) (cond ((not (distinct-bound-ids?152 (map car pvars1227))) (syntax-error pat1222 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x1228) (not (ellipsis?171 (car x1228)))) pvars1227)) (syntax-error pat1222 "misplaced ellipsis in syntax-case pattern")) (else (let ((y1229 (gen-var174 (quote tmp)))) (build-annotated103 #f (list (build-annotated103 #f (list (quote lambda) (list y1229) (let ((y1230 (build-annotated103 #f y1229))) (build-annotated103 #f (list (quote if) ((lambda (tmp1231) ((lambda (tmp1232) (if tmp1232 (apply (lambda () y1230) tmp1232) ((lambda (_1233) (build-annotated103 #f (list (quote if) y1230 (build-dispatch-call1198 pvars1227 fender1223 y1230 r1221 mod1225) (build-data104 #f #f)))) tmp1231))) (syntax-dispatch tmp1231 (quote #(atom #t))))) fender1223) (build-dispatch-call1198 pvars1227 exp1224 y1230 r1221 mod1225) (gen-syntax-case1200 x1218 keys1219 clauses1220 r1221 mod1225)))))) (if (eq? p1226 (quote any)) (build-annotated103 #f (list (build-annotated103 #f (quote list)) x1218)) (build-annotated103 #f (list (build-annotated103 #f (quote syntax-dispatch)) x1218 (build-data104 #f p1226))))))))))))) (build-dispatch-call1198 (lambda (pvars1234 exp1235 y1236 r1237 mod1238) (let ((ids1239 (map car pvars1234)) (levels1240 (map cdr pvars1234))) (let ((labels1241 (gen-labels132 ids1239)) (new-vars1242 (map gen-var174 ids1239))) (build-annotated103 #f (list (build-annotated103 #f (quote apply)) (build-annotated103 #f (list (quote lambda) new-vars1242 (chi162 exp1235 (extend-env120 labels1241 (map (lambda (var1243 level1244) (cons (quote syntax) (cons var1243 level1244))) new-vars1242 (map cdr pvars1234)) r1237) (make-binding-wrap143 ids1239 labels1241 (quote (()))) mod1238))) y1236)))))) (convert-pattern1197 (lambda (pattern1245 keys1246) (let cvt1247 ((p1248 pattern1245) (n1249 0) (ids1250 (quote ()))) (if (id?126 p1248) (if (bound-id-member?153 p1248 keys1246) (values (vector (quote free-id) p1248) ids1250) (values (quote any) (cons (cons p1248 n1249) ids1250))) ((lambda (tmp1251) ((lambda (tmp1252) (if (if tmp1252 (apply (lambda (x1253 dots1254) (ellipsis?171 dots1254)) tmp1252) #f) (apply (lambda (x1255 dots1256) (call-with-values (lambda () (cvt1247 x1255 (fx+93 n1249 1) ids1250)) (lambda (p1257 ids1258) (values (if (eq? p1257 (quote any)) (quote each-any) (vector (quote each) p1257)) ids1258)))) tmp1252) ((lambda (tmp1259) (if tmp1259 (apply (lambda (x1260 y1261) (call-with-values (lambda () (cvt1247 y1261 n1249 ids1250)) (lambda (y1262 ids1263) (call-with-values (lambda () (cvt1247 x1260 n1249 ids1263)) (lambda (x1264 ids1265) (values (cons x1264 y1262) ids1265)))))) tmp1259) ((lambda (tmp1266) (if tmp1266 (apply (lambda () (values (quote ()) ids1250)) tmp1266) ((lambda (tmp1267) (if tmp1267 (apply (lambda (x1268) (call-with-values (lambda () (cvt1247 x1268 n1249 ids1250)) (lambda (p1270 ids1271) (values (vector (quote vector) p1270) ids1271)))) tmp1267) ((lambda (x1272) (values (vector (quote atom) (strip173 p1248 (quote (())))) ids1250)) tmp1251))) (syntax-dispatch tmp1251 (quote #(vector each-any)))))) (syntax-dispatch tmp1251 (quote ()))))) (syntax-dispatch tmp1251 (quote (any . any)))))) (syntax-dispatch tmp1251 (quote (any any))))) p1248)))))) (lambda (e1273 r1274 w1275 s1276 mod1277) (let ((e1278 (source-wrap155 e1273 w1275 s1276 mod1277))) ((lambda (tmp1279) ((lambda (tmp1280) (if tmp1280 (apply (lambda (_1281 val1282 key1283 m1284) (if (andmap (lambda (x1285) (and (id?126 x1285) (not (ellipsis?171 x1285)))) key1283) (let ((x1287 (gen-var174 (quote tmp)))) (build-annotated103 s1276 (list (build-annotated103 #f (list (quote lambda) (list x1287) (gen-syntax-case1200 (build-annotated103 #f x1287) key1283 m1284 r1274 mod1277))) (chi162 val1282 r1274 (quote (())) mod1277)))) (syntax-error e1278 "invalid literals list in"))) tmp1280) (syntax-error tmp1279))) (syntax-dispatch tmp1279 (quote (any any each-any . each-any))))) e1278))))) (set! sc-expand (let ((m1290 (quote e)) (esew1291 (quote (eval)))) (lambda (x1292) (if (and (pair? x1292) (equal? (car x1292) noexpand92)) (cadr x1292) (chi-top161 x1292 (quote ()) (quote ((top))) m1290 esew1291 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m1293 (quote e)) (esew1294 (quote (eval)))) (lambda (x1296 . rest1295) (if (and (pair? x1296) (equal? (car x1296) noexpand92)) (cadr x1296) (chi-top161 x1296 (quote ()) (quote ((top))) (if (null? rest1295) m1293 (car rest1295)) (if (or (null? rest1295) (null? (cdr rest1295))) esew1294 (cadr rest1295)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x1297) (nonsymbol-id?125 x1297))) (set! datum->syntax-object (lambda (id1298 datum1299) (make-syntax-object109 datum1299 (syntax-object-wrap112 id1298) #f))) (set! syntax-object->datum (lambda (x1300) (strip173 x1300 (quote (()))))) (set! generate-temporaries (lambda (ls1301) (begin (let ((x1302 ls1301)) (if (not (list? x1302)) (error-hook99 (quote generate-temporaries) "invalid argument" x1302))) (map (lambda (x1303) (wrap154 (gensym) (quote ((top))) #f)) ls1301)))) (set! free-identifier=? (lambda (x1304 y1305) (begin (let ((x1306 x1304)) (if (not (nonsymbol-id?125 x1306)) (error-hook99 (quote free-identifier=?) "invalid argument" x1306))) (let ((x1307 y1305)) (if (not (nonsymbol-id?125 x1307)) (error-hook99 (quote free-identifier=?) "invalid argument" x1307))) (free-id=?149 x1304 y1305)))) (set! bound-identifier=? (lambda (x1308 y1309) (begin (let ((x1310 x1308)) (if (not (nonsymbol-id?125 x1310)) (error-hook99 (quote bound-identifier=?) "invalid argument" x1310))) (let ((x1311 y1309)) (if (not (nonsymbol-id?125 x1311)) (error-hook99 (quote bound-identifier=?) "invalid argument" x1311))) (bound-id=?150 x1308 y1309)))) (set! syntax-error (lambda (object1313 . messages1312) (begin (for-each (lambda (x1314) (let ((x1315 x1314)) (if (not (string? x1315)) (error-hook99 (quote syntax-error) "invalid argument" x1315)))) messages1312) (let ((message1316 (if (null? messages1312) "invalid syntax" (apply string-append messages1312)))) (error-hook99 #f message1316 (strip173 object1313 (quote (())))))))) (set! install-global-transformer (lambda (sym1317 v1318) (begin (let ((x1319 sym1317)) (if (not (symbol? x1319)) (error-hook99 (quote define-syntax) "invalid argument" x1319))) (let ((x1320 v1318)) (if (not (procedure? x1320)) (error-hook99 (quote define-syntax) "invalid argument" x1320))) (global-extend124 (quote macro) sym1317 v1318)))) (letrec ((match1325 (lambda (e1326 p1327 w1328 r1329 mod1330) (cond ((not r1329) #f) ((eq? p1327 (quote any)) (cons (wrap154 e1326 w1328 mod1330) r1329)) ((syntax-object?110 e1326) (match*1324 (let ((e1331 (syntax-object-expression111 e1326))) (if (annotation? e1331) (annotation-expression e1331) e1331)) p1327 (join-wraps145 w1328 (syntax-object-wrap112 e1326)) r1329 (syntax-object-module113 e1326))) (else (match*1324 (let ((e1332 e1326)) (if (annotation? e1332) (annotation-expression e1332) e1332)) p1327 w1328 r1329 mod1330))))) (match*1324 (lambda (e1333 p1334 w1335 r1336 mod1337) (cond ((null? p1334) (and (null? e1333) r1336)) ((pair? p1334) (and (pair? e1333) (match1325 (car e1333) (car p1334) w1335 (match1325 (cdr e1333) (cdr p1334) w1335 r1336 mod1337) mod1337))) ((eq? p1334 (quote each-any)) (let ((l1338 (match-each-any1322 e1333 w1335 mod1337))) (and l1338 (cons l1338 r1336)))) (else (let ((t1339 (vector-ref p1334 0))) (if (memv t1339 (quote (each))) (if (null? e1333) (match-empty1323 (vector-ref p1334 1) r1336) (let ((l1340 (match-each1321 e1333 (vector-ref p1334 1) w1335 mod1337))) (and l1340 (let collect1341 ((l1342 l1340)) (if (null? (car l1342)) r1336 (cons (map car l1342) (collect1341 (map cdr l1342)))))))) (if (memv t1339 (quote (free-id))) (and (id?126 e1333) (free-id=?149 (wrap154 e1333 w1335 mod1337) (vector-ref p1334 1)) r1336) (if (memv t1339 (quote (atom))) (and (equal? (vector-ref p1334 1) (strip173 e1333 w1335)) r1336) (if (memv t1339 (quote (vector))) (and (vector? e1333) (match1325 (vector->list e1333) (vector-ref p1334 1) w1335 r1336 mod1337))))))))))) (match-empty1323 (lambda (p1343 r1344) (cond ((null? p1343) r1344) ((eq? p1343 (quote any)) (cons (quote ()) r1344)) ((pair? p1343) (match-empty1323 (car p1343) (match-empty1323 (cdr p1343) r1344))) ((eq? p1343 (quote each-any)) (cons (quote ()) r1344)) (else (let ((t1345 (vector-ref p1343 0))) (if (memv t1345 (quote (each))) (match-empty1323 (vector-ref p1343 1) r1344) (if (memv t1345 (quote (free-id atom))) r1344 (if (memv t1345 (quote (vector))) (match-empty1323 (vector-ref p1343 1) r1344))))))))) (match-each-any1322 (lambda (e1346 w1347 mod1348) (cond ((annotation? e1346) (match-each-any1322 (annotation-expression e1346) w1347 mod1348)) ((pair? e1346) (let ((l1349 (match-each-any1322 (cdr e1346) w1347 mod1348))) (and l1349 (cons (wrap154 (car e1346) w1347 mod1348) l1349)))) ((null? e1346) (quote ())) ((syntax-object?110 e1346) (match-each-any1322 (syntax-object-expression111 e1346) (join-wraps145 w1347 (syntax-object-wrap112 e1346)) mod1348)) (else #f)))) (match-each1321 (lambda (e1350 p1351 w1352 mod1353) (cond ((annotation? e1350) (match-each1321 (annotation-expression e1350) p1351 w1352 mod1353)) ((pair? e1350) (let ((first1354 (match1325 (car e1350) p1351 w1352 (quote ()) mod1353))) (and first1354 (let ((rest1355 (match-each1321 (cdr e1350) p1351 w1352 mod1353))) (and rest1355 (cons first1354 rest1355)))))) ((null? e1350) (quote ())) ((syntax-object?110 e1350) (match-each1321 (syntax-object-expression111 e1350) p1351 (join-wraps145 w1352 (syntax-object-wrap112 e1350)) (syntax-object-module113 e1350))) (else #f))))) (begin (set! syntax-dispatch (lambda (e1356 p1357) (cond ((eq? p1357 (quote any)) (list e1356)) ((syntax-object?110 e1356) (match*1324 (let ((e1358 (syntax-object-expression111 e1356))) (if (annotation? e1358) (annotation-expression e1358) e1358)) p1357 (syntax-object-wrap112 e1356) (quote ()) (syntax-object-module113 e1356))) (else (match*1324 (let ((e1359 e1356)) (if (annotation? e1359) (annotation-expression e1359) e1359)) p1357 (quote (())) (quote ()) #f))))) (set! sc-chi chi162))))) +(install-global-transformer (quote with-syntax) (lambda (x1360) ((lambda (tmp1361) ((lambda (tmp1362) (if tmp1362 (apply (lambda (_1363 e11364 e21365) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11364 e21365))) tmp1362) ((lambda (tmp1367) (if tmp1367 (apply (lambda (_1368 out1369 in1370 e11371 e21372) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1370 (quote ()) (list out1369 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11371 e21372))))) tmp1367) ((lambda (tmp1374) (if tmp1374 (apply (lambda (_1375 out1376 in1377 e11378 e21379) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1377) (quote ()) (list out1376 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11378 e21379))))) tmp1374) (syntax-error tmp1361))) (syntax-dispatch tmp1361 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1361 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1361 (quote (any () any . each-any))))) x1360))) +(install-global-transformer (quote syntax-rules) (lambda (x1383) ((lambda (tmp1384) ((lambda (tmp1385) (if tmp1385 (apply (lambda (_1386 k1387 keyword1388 pattern1389 template1390) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1387 (map (lambda (tmp1393 tmp1392) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1392) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1393))) template1390 pattern1389)))))) tmp1385) (syntax-error tmp1384))) (syntax-dispatch tmp1384 (quote (any each-any . #(each ((any . any) any))))))) x1383))) +(install-global-transformer (quote let*) (lambda (x1394) ((lambda (tmp1395) ((lambda (tmp1396) (if (if tmp1396 (apply (lambda (let*1397 x1398 v1399 e11400 e21401) (andmap identifier? x1398)) tmp1396) #f) (apply (lambda (let*1403 x1404 v1405 e11406 e21407) (let f1408 ((bindings1409 (map list x1404 v1405))) (if (null? bindings1409) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11406 e21407))) ((lambda (tmp1413) ((lambda (tmp1414) (if tmp1414 (apply (lambda (body1415 binding1416) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1416) body1415)) tmp1414) (syntax-error tmp1413))) (syntax-dispatch tmp1413 (quote (any any))))) (list (f1408 (cdr bindings1409)) (car bindings1409)))))) tmp1396) (syntax-error tmp1395))) (syntax-dispatch tmp1395 (quote (any #(each (any any)) any . each-any))))) x1394))) +(install-global-transformer (quote do) (lambda (orig-x1417) ((lambda (tmp1418) ((lambda (tmp1419) (if tmp1419 (apply (lambda (_1420 var1421 init1422 step1423 e01424 e11425 c1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (step1429) ((lambda (tmp1430) ((lambda (tmp1431) (if tmp1431 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1421 init1422) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01424) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1426 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1429))))))) tmp1431) ((lambda (tmp1436) (if tmp1436 (apply (lambda (e11437 e21438) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1421 init1422) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01424 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11437 e21438)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1426 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1429))))))) tmp1436) (syntax-error tmp1430))) (syntax-dispatch tmp1430 (quote (any . each-any)))))) (syntax-dispatch tmp1430 (quote ())))) e11425)) tmp1428) (syntax-error tmp1427))) (syntax-dispatch tmp1427 (quote each-any)))) (map (lambda (v1445 s1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda () v1445) tmp1448) ((lambda (tmp1449) (if tmp1449 (apply (lambda (e1450) e1450) tmp1449) ((lambda (_1451) (syntax-error orig-x1417)) tmp1447))) (syntax-dispatch tmp1447 (quote (any)))))) (syntax-dispatch tmp1447 (quote ())))) s1446)) var1421 step1423))) tmp1419) (syntax-error tmp1418))) (syntax-dispatch tmp1418 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1417))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons1454 (lambda (x1458 y1459) ((lambda (tmp1460) ((lambda (tmp1461) (if tmp1461 (apply (lambda (x1462 y1463) ((lambda (tmp1464) ((lambda (tmp1465) (if tmp1465 (apply (lambda (dy1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda (dx1469) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1469 dy1466))) tmp1468) ((lambda (_1470) (if (null? dy1466) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462 y1463))) tmp1467))) (syntax-dispatch tmp1467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1462)) tmp1465) ((lambda (tmp1471) (if tmp1471 (apply (lambda (stuff1472) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1462 stuff1472))) tmp1471) ((lambda (else1473) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462 y1463)) tmp1464))) (syntax-dispatch tmp1464 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp1464 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1463)) tmp1461) (syntax-error tmp1460))) (syntax-dispatch tmp1460 (quote (any any))))) (list x1458 y1459)))) (quasiappend1455 (lambda (x1474 y1475) ((lambda (tmp1476) ((lambda (tmp1477) (if tmp1477 (apply (lambda (x1478 y1479) ((lambda (tmp1480) ((lambda (tmp1481) (if tmp1481 (apply (lambda () x1478) tmp1481) ((lambda (_1482) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1478 y1479)) tmp1480))) (syntax-dispatch tmp1480 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1479)) tmp1477) (syntax-error tmp1476))) (syntax-dispatch tmp1476 (quote (any any))))) (list x1474 y1475)))) (quasivector1456 (lambda (x1483) ((lambda (tmp1484) ((lambda (x1485) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (x1488) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1488))) tmp1487) ((lambda (tmp1490) (if tmp1490 (apply (lambda (x1491) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1491)) tmp1490) ((lambda (_1493) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1485)) tmp1486))) (syntax-dispatch tmp1486 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp1486 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1485)) tmp1484)) x1483))) (quasi1457 (lambda (p1494 lev1495) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (p1498) (if (= lev1495 0) p1498 (quasicons1454 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1457 (list p1498) (- lev1495 1))))) tmp1497) ((lambda (tmp1499) (if tmp1499 (apply (lambda (p1500 q1501) (if (= lev1495 0) (quasiappend1455 p1500 (quasi1457 q1501 lev1495)) (quasicons1454 (quasicons1454 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1457 (list p1500) (- lev1495 1))) (quasi1457 q1501 lev1495)))) tmp1499) ((lambda (tmp1502) (if tmp1502 (apply (lambda (p1503) (quasicons1454 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1457 (list p1503) (+ lev1495 1)))) tmp1502) ((lambda (tmp1504) (if tmp1504 (apply (lambda (p1505 q1506) (quasicons1454 (quasi1457 p1505 lev1495) (quasi1457 q1506 lev1495))) tmp1504) ((lambda (tmp1507) (if tmp1507 (apply (lambda (x1508) (quasivector1456 (quasi1457 x1508 lev1495))) tmp1507) ((lambda (p1510) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1510)) tmp1496))) (syntax-dispatch tmp1496 (quote #(vector each-any)))))) (syntax-dispatch tmp1496 (quote (any . any)))))) (syntax-dispatch tmp1496 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp1496 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp1496 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1494)))) (lambda (x1511) ((lambda (tmp1512) ((lambda (tmp1513) (if tmp1513 (apply (lambda (_1514 e1515) (quasi1457 e1515 0)) tmp1513) (syntax-error tmp1512))) (syntax-dispatch tmp1512 (quote (any any))))) x1511)))) +(install-global-transformer (quote include) (lambda (x1516) (letrec ((read-file1517 (lambda (fn1518 k1519) (let ((p1520 (open-input-file fn1518))) (let f1521 ((x1522 (read p1520))) (if (eof-object? x1522) (begin (close-input-port p1520) (quote ())) (cons (datum->syntax-object k1519 x1522) (f1521 (read p1520))))))))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (k1525 filename1526) (let ((fn1527 (syntax-object->datum filename1526))) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (exp1530) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1530)) tmp1529) (syntax-error tmp1528))) (syntax-dispatch tmp1528 (quote each-any)))) (read-file1517 fn1527 k1525)))) tmp1524) (syntax-error tmp1523))) (syntax-dispatch tmp1523 (quote (any any))))) x1516)))) +(install-global-transformer (quote unquote) (lambda (x1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (_1535 e1536) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e1536))) tmp1534) (syntax-error tmp1533))) (syntax-dispatch tmp1533 (quote (any any))))) x1532))) +(install-global-transformer (quote unquote-splicing) (lambda (x1537) ((lambda (tmp1538) ((lambda (tmp1539) (if tmp1539 (apply (lambda (_1540 e1541) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e1541))) tmp1539) (syntax-error tmp1538))) (syntax-dispatch tmp1538 (quote (any any))))) x1537))) +(install-global-transformer (quote case) (lambda (x1542) ((lambda (tmp1543) ((lambda (tmp1544) (if tmp1544 (apply (lambda (_1545 e1546 m11547 m21548) ((lambda (tmp1549) ((lambda (body1550) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1546)) body1550)) tmp1549)) (let f1551 ((clause1552 m11547) (clauses1553 m21548)) (if (null? clauses1553) ((lambda (tmp1555) ((lambda (tmp1556) (if tmp1556 (apply (lambda (e11557 e21558) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11557 e21558))) tmp1556) ((lambda (tmp1560) (if tmp1560 (apply (lambda (k1561 e11562 e21563) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1561)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11562 e21563)))) tmp1560) ((lambda (_1566) (syntax-error x1542)) tmp1555))) (syntax-dispatch tmp1555 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1555 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1552) ((lambda (tmp1567) ((lambda (rest1568) ((lambda (tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (k1571 e11572 e21573) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1571)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11572 e21573)) rest1568)) tmp1570) ((lambda (_1576) (syntax-error x1542)) tmp1569))) (syntax-dispatch tmp1569 (quote (each-any any . each-any))))) clause1552)) tmp1567)) (f1551 (car clauses1553) (cdr clauses1553))))))) tmp1544) (syntax-error tmp1543))) (syntax-dispatch tmp1543 (quote (any any any . each-any))))) x1542))) +(install-global-transformer (quote identifier-syntax) (lambda (x1577) ((lambda (tmp1578) ((lambda (tmp1579) (if tmp1579 (apply (lambda (_1580 e1581) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1581)) (list (cons _1580 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1581 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1579) (syntax-error tmp1578))) (syntax-dispatch tmp1578 (quote (any any))))) x1577))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index a5ea0ac60..c17b3c480 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -421,6 +421,9 @@ (define-syntax build-lambda (syntax-rules () + ((_ src vars docstring exp) + (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '()) + ,exp))) ((_ src vars exp) (build-annotated src `(lambda ,vars ,exp))))) @@ -1353,8 +1356,11 @@ (cdr body))))))))))))))))) (define chi-lambda-clause - (lambda (e c r w mod k) + (lambda (e docstring c r w mod k) (syntax-case c () + ((args doc e1 e2 ...) + (and (string? (syntax-object->datum (syntax doc))) (not docstring)) + (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k)) (((id ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) @@ -1362,6 +1368,7 @@ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (k new-vars + docstring (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) @@ -1377,6 +1384,7 @@ (if (null? ls1) ls2 (f (cdr ls1) (cons (car ls1) ls2)))) + docstring (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) @@ -1716,8 +1724,8 @@ (lambda (e r w s mod) (syntax-case e () ((_ . c) - (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod - (lambda (vars body) (build-lambda s vars body))))))) + (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod + (lambda (vars docstring body) (build-lambda s vars docstring body))))))) (global-extend 'core 'let diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm deleted file mode 100644 index cbf3f1862..000000000 --- a/module/language/scheme/expand.scm +++ /dev/null @@ -1,306 +0,0 @@ -;;; Guile Scheme specification - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (language scheme expand) - #:use-module (language scheme amatch) - #:use-module (ice-9 expand-support) - #:use-module (ice-9 optargs) - #:use-module ((system base compile) #:select (syntax-error)) - #:export (expand *expand-table* define-scheme-expander)) - -(define (aref x) (if (annotation? x) (annotation-expression x) x)) -(define (apair? x) (pair? (aref x))) -(define (acar x) (car (aref x))) -(define (acdr x) (cdr (aref x))) -(define (acaar x) (acar (acar x))) -(define (acdar x) (acdr (acar x))) -(define (acadr x) (acar (acdr x))) -(define (acddr x) (acdr (acdr x))) -(define (aloc x) (and (annotation? x) (annotation-source x))) -(define (re-annotate x y) - (if (and (annotation? x) (not (annotation? y))) - (make-annotation y (annotation-source x)) - y)) -(define-macro (-> exp) `(re-annotate x ,exp)) - -(define* (expand x #:optional (mod (current-module)) (once? #f)) - (define re-expand - (if once? - (lambda (x) x) - (lambda (x) (expand x mod once?)))) - (let ((exp (if (annotation? x) (annotation-expression x) x))) - (cond - ((pair? exp) - (let ((head (car exp)) (tail (cdr exp))) - (cond - ;; allow macros to be unquoted into the output of a macro - ;; expansion - ((or (symbol? head) (macro? head)) - (let ((val (cond - ((macro? head) head) - ((module-variable mod head) - => (lambda (var) - ;; unbound vars can happen if the module - ;; definition forward-declared them - (and (variable-bound? var) (variable-ref var)))) - (else #f)))) - (cond - ((hashq-ref *expand-table* val) - => (lambda (expand1) (expand1 x re-expand))) - - ((defmacro? val) - (re-expand (-> (apply (defmacro-transformer val) - (deannotate tail))))) - - ((eq? val sc-macro) - ;; syncase! - (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure)) - (sc-expand3 (@@ (ice-9 syncase) sc-expand3))) - (re-expand - (with-fluids ((eec (module-eval-closure mod))) - ;; fixme -- use ewes fluid? - (sc-expand3 exp 'c '(compile load eval)))))) - - ((primitive-macro? val) - (syntax-error (aloc x) "unhandled primitive macro" head)) - - ((macro? val) - (syntax-error (aloc x) "unknown kind of macro" head)) - - (else - (-> (cons head (map re-expand tail))))))) - - (else - (-> (map re-expand exp)))))) - - (else x)))) - - -(define *expand-table* (make-hash-table)) - -(define-macro (define-scheme-expander sym . clauses) - `(hashq-set! (@ (language scheme expand) *expand-table*) - ,sym - (lambda (x re-expand) - (define syntax-error (@ (system base compile) syntax-error)) - (amatch (acdr x) - ,@clauses - ,@(if (assq 'else clauses) '() - `((else - (syntax-error (aloc x) (format #f "bad ~A" ',sym) x)))))))) - -(define-scheme-expander quote - ;; (quote OBJ) - ((,obj) x)) - -(define-scheme-expander quasiquote - ;; (quasiquote OBJ) - ((,obj) - (-> `(,'quasiquote - ,(let lp ((x obj) (level 0)) - (cond ((not (apair? x)) x) - ;; FIXME: hygiene regarding imported , / ,@ rebinding - ((memq (acar x) '(unquote unquote-splicing)) - (amatch (acdr x) - ((,obj) - (cond - ((zero? level) - (-> `(,(acar x) ,(re-expand obj)))) - (else - (-> `(,(acar x) ,(lp obj (1- level))))))) - (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x)))) - ((eq? (acar x) 'quasiquote) - (amatch (acdr x) - ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level))))) - (else (syntax-error (aloc x) "bad quasiquote" x)))) - (else (-> (cons (lp (acar x) level) (lp (acdr x) level)))))))))) - -(define-scheme-expander define - ;; (define NAME VAL) - ((,name ,val) (guard (symbol? name)) - (-> `(define ,name ,(re-expand val)))) - ;; (define (NAME FORMALS...) BODY...) - (((,name . ,formals) . ,body) (guard (symbol? name)) - ;; -> (define NAME (lambda FORMALS BODY...)) - (re-expand (-> `(define ,name (lambda ,formals . ,body)))))) - -(define-scheme-expander set! - ;; (set! (NAME ARGS...) VAL) - (((,name . ,args) ,val) (guard (symbol? name) - (not (eq? name '@)) (not (eq? name '@@))) - ;; -> ((setter NAME) ARGS... VAL) - (re-expand (-> `((setter ,name) ,@args ,val)))) - - ;; (set! NAME VAL) - ((,name ,val) (guard (symbol? name)) - (-> `(set! ,name ,(re-expand val))))) - -(define-scheme-expander if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (-> `(if ,(re-expand test) ,(re-expand then)))) - ((,test ,then ,else) - (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else))))) - -(define-scheme-expander and - ;; (and EXPS...) - (,tail - (-> `(and . ,(map re-expand tail))))) - -(define-scheme-expander or - ;; (or EXPS...) - (,tail - (-> `(or . ,(map re-expand tail))))) - -(define-scheme-expander begin - ;; (begin EXPS...) - ((,single-exp) - (-> (re-expand single-exp))) - (,tail - (-> `(begin . ,(map re-expand tail))))) - -(define (valid-bindings? bindings . it-is-for-do) - (define (valid-binding? b) - (amatch b - ((,sym ,var) (guard (symbol? sym)) #t) - ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) - (else #f))) - (and (list? (aref bindings)) - (and-map valid-binding? (aref bindings)))) - -(define-scheme-expander let - ;; (let NAME ((SYM VAL) ...) BODY...) - ((,name ,bindings . ,body) (guard (symbol? name) - (valid-bindings? bindings)) - ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) - (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings)) - . ,body))) - (,name . ,(map acadr (aref bindings))))))) - - ((() . ,body) - (re-expand (expand-internal-defines body))) - - ;; (let ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (-> `(let ,(map (lambda (x) - ;; nb, relies on -> non-hygiene - (-> `(,(acar x) ,(re-expand (acadr x))))) - (aref bindings)) - ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander let* - ;; (let* ((SYM VAL) ...) BODY...) - ((() . ,body) - (re-expand (-> `(let () . ,body)))) - ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) - (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body)))))) - -(define-scheme-expander letrec - ;; (letrec ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (-> `(letrec ,(map (lambda (x) - ;; nb, relies on -> non-hygiene - (-> `(,(acar x) ,(re-expand (acadr x))))) - (aref bindings)) - ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander cond - ;; (cond (CLAUSE BODY...) ...) - (() (-> '(begin))) - (((else . ,body)) (re-expand (-> `(begin ,@body)))) - (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest))))) - (((,test => ,proc) . ,rest) - ;; FIXME hygiene! - (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))) - (((,test . ,body) . ,rest) - (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest)))))) - -(define-scheme-expander case - ;; (case EXP ((KEY...) BODY...) ...) - ((,exp . ,clauses) - ;; FIXME hygiene! - (re-expand - (->`(let ((_t ,exp)) - ,(let loop ((ls clauses)) - (cond ((null? ls) '(begin)) - ((eq? (acaar ls) 'else) `(begin ,@(acdar ls))) - (else `(if (memv _t ',(acaar ls)) - (begin ,@(acdar ls)) - ,(loop (acdr ls))))))))))) - -(define-scheme-expander do - ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) - ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t)) - (let ((sym (map acar (aref bindings))) - (val (map acadr (aref bindings))) - (update (map acddr (aref bindings)))) - (define (next s x) (if (pair? x) (car x) s)) - (re-expand - ;; FIXME hygiene! - (-> `(letrec ((_l (lambda ,sym - (if ,test - (begin ,@result) - (begin ,@body - (_l ,@(map next sym update))))))) - (_l ,@val))))))) - -(define-scheme-expander lambda - ;; (lambda FORMALS BODY...) - ((,formals ,docstring ,body1 . ,body) (guard (string? docstring)) - (-> `(lambda ,formals ,docstring ,(expand-internal-defines - (map re-expand (cons body1 body)))))) - ((,formals . ,body) - (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander delay - ;; FIXME not hygienic - ((,expr) - (re-expand `(make-promise (lambda () ,expr))))) - -(define-scheme-expander @ - ((,modname ,sym) - x)) - -(define-scheme-expander @@ - ((,modname ,sym) - x)) - -(define-scheme-expander eval-when - ((,when . ,body) (guard (list? when) (and-map symbol? when)) - (if (memq 'compile when) - (primitive-eval `(begin . ,body))) - (if (memq 'load when) - (-> `(begin . ,body)) - (-> `(begin))))) - -;;; Hum, I don't think this takes imported modifications to `define' -;;; properly into account. (Lexical bindings are OK because of alpha -;;; renaming.) -(define (expand-internal-defines body) - (let loop ((ls body) (ds '())) - (amatch ls - (() (syntax-error l "bad body" body)) - (((define ,name ,val) . _) - (loop (acdr ls) (cons (list name val) ds))) - (else - (if (null? ds) - (if (null? (cdr ls)) (car ls) `(begin ,@ls)) - `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls)))))))) From 2ce560b944c8af2047415612835fcd23fa3de473 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Apr 2009 12:50:53 +0200 Subject: [PATCH 074/375] fix bad syntax in define-macro, (ice-9 match), and (oop goops) * module/ice-9/boot-9.scm (define-macro): Use syntax-case to destructure macro arguments, so we get good errors. * module/ice-9/match.scm (defstruct, define-const-structure): Don't unquote in the `defstruct' macro as a value in expansions. * module/oop/goops.scm (standard-define-class): Can't define a macro with `define', use `define-syntax' instead. (define-accessor): Use syntax-rules. Doesn't give us much in this case. (toplevel-define!): New helper, to let us keep GOOPS' behavior with the new expander. Some solution that works lexically and at the toplevel would be nice, though. (define-method): Reimplement with syntax-rules -- soooo much nicer. * module/oop/goops/dispatch.scm (lookup-create-cmethod): Don't define within an expression. --- module/ice-9/boot-9.scm | 6 ++- module/ice-9/match.scm | 4 +- module/oop/goops.scm | 78 +++++++++++++++-------------------- module/oop/goops/dispatch.scm | 5 +-- 4 files changed, 42 insertions(+), 51 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 235d96c9a..51f195851 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -216,8 +216,10 @@ (syntax (define-syntax macro (lambda (y) - (let ((v (syntax-object->datum y))) - (datum->syntax-object y (apply transformer (cdr v))))))))))) + (syntax-case y () + ((_ . args) + (let ((v (syntax-object->datum (syntax args)))) + (datum->syntax-object y (apply transformer v)))))))))))) (define-syntax defmacro (lambda (x) diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm index e6fe56063..baa4d5aad 100644 --- a/module/ice-9/match.scm +++ b/module/ice-9/match.scm @@ -194,6 +194,6 @@ (define match:runtime-structures #f) (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) (define match:primitive-vector? vector?) -(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) +(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) -(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) +(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 2254f93e5..7e9eae9a9 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -204,7 +204,9 @@ (class ,supers ,@slots #:name ',name)) (define ,name (class ,supers ,@slots #:name ',name))))) -(define standard-define-class define-class) +(define-syntax standard-define-class + (syntax-rules () + ((_ arg ...) (define-class arg ...)))) ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) ;;; @@ -363,13 +365,13 @@ (else (make #:name name))))) ;; same semantics as -(define-macro (define-accessor name) - (if (not (symbol? name)) - (goops-error "bad accessor name: ~S" name)) - `(define ,name - (if (and (defined? ',name) (is-a? ,name )) - (make #:name ',name) - (ensure-accessor (if (defined? ',name) ,name #f) ',name)))) +(define-syntax define-accessor + (syntax-rules () + ((_ name) + (define name + (cond ((not (defined? 'name)) (ensure-accessor #f 'name)) + ((is-a? name ) (make #:name 'name)) + (else (ensure-accessor name 'name))))))) (define (make-setter-name name) (string->symbol (string-append "setter:" (symbol->string name)))) @@ -424,42 +426,30 @@ ;;; {Methods} ;;; -(define-macro (define-method head . body) - (if (not (pair? head)) - (goops-error "bad method head: ~S" head)) - (let ((gf (car head))) - (cond ((and (pair? gf) - (eq? (car gf) 'setter) - (pair? (cdr gf)) - (symbol? (cadr gf)) - (null? (cddr gf))) - ;; named setter method - (let ((name (cadr gf))) - (cond ((not (symbol? name)) - `(add-method! (setter ,name) - (method ,(cdr head) ,@body))) - (else - `(begin - (if (or (not (defined? ',name)) - (not (is-a? ,name ))) - (define-accessor ,name)) - (add-method! (setter ,name) - (method ,(cdr head) ,@body))))))) - ((not (symbol? gf)) - `(add-method! ,gf (method ,(cdr head) ,@body))) - (else - `(begin - ;; FIXME: this code is how it always was, but it's quite - ;; cracky: it will only define the generic function if it - ;; was undefined before (ok), or *was defined to #f*. The - ;; latter is crack. But there are bootstrap issues about - ;; fixing this -- change it to (is-a? ,gf ) and - ;; see. - (if (or (not (defined? ',gf)) - (not ,gf)) - (define-generic ,gf)) - (add-method! ,gf - (method ,(cdr head) ,@body))))))) +(define (toplevel-define! name val) + (module-define! (current-module) name val)) + +(define-syntax define-method + (syntax-rules (setter) + ((_ ((setter name) . args) body ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method args body ...)))) + ((_ (name . args) body ...) + (begin + ;; FIXME: this code is how it always was, but it's quite cracky: + ;; it will only define the generic function if it was undefined + ;; before (ok), or *was defined to #f*. The latter is crack. But + ;; there are bootstrap issues about fixing this -- change it to + ;; (is-a? name ) and see. + (if (or (not (defined? 'name)) + (not name)) + (toplevel-define! 'name (make #:name 'name))) + (add-method! name (method args body ...)))))) (define-macro (method args . body) (letrec ((specializers diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index a54044729..ed9f3077e 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -209,9 +209,8 @@ ;;; ;; Backward compatibility -(if (not (defined? 'lookup-create-cmethod)) - (define (lookup-create-cmethod gf args) - (no-applicable-method (car args) (cadr args)))) +(define (lookup-create-cmethod gf args) + (no-applicable-method (car args) (cadr args))) (define (memoize-method! gf args exp) (if (not (slot-ref gf 'used-by)) From b3501b8043d36a3215ec51e321a2aa3733ea54cc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Apr 2009 14:10:08 +0200 Subject: [PATCH 075/375] all of guile compiles now, expanded with syncase * libguile/eval.c (scm_m_eval_when): Whoops, eval-when has an implicit begin. Fix. * module/oop/goops.scm: Syncase doesn't like definitions in expression context, and grudgingly I have decided to go along with that. But that doesn't mean we can't keep the old semantics, via accessing the module system directly. So do so. I took the opportunity to rewrite some macros with syntax-rules and syntax-case -- the former is nicer than the latter, of course. * module/oop/goops/save.scm: Don't define within an expression. * module/oop/goops/simple.scm (define-class): Use define-syntax. * module/oop/goops/stklos.scm (define-class): Use define-syntax. --- libguile/eval.c | 4 +- module/oop/goops.scm | 183 +++++++++++++++++++++--------------- module/oop/goops/save.scm | 4 +- module/oop/goops/simple.scm | 5 +- module/oop/goops/stklos.scm | 71 +++++--------- 5 files changed, 138 insertions(+), 129 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 5b1473e06..05af5a1c5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2149,12 +2149,12 @@ SCM_SYMBOL (sym_load, "load"); SCM scm_m_eval_when (SCM expr, SCM env SCM_UNUSED) { - ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr))) || scm_is_true (scm_memq (sym_load, scm_cadr (expr)))) - return scm_caddr (expr); + return scm_cons (SCM_IM_BEGIN, scm_cddr (expr)); return scm_list_1 (SCM_IM_BEGIN); } diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 7e9eae9a9..873e4b831 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -154,17 +154,6 @@ ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) ;;; OPTION ::= KEYWORD VALUE ;;; -(define (define-class-pre-definition kw val) - (case kw - ((#:getter #:setter) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-generic ,val))) - ((#:accessor) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-accessor ,val))) - (else #f))) (define (kw-do-map mapper f kwargs) (define (keywords l) @@ -180,71 +169,6 @@ (a (args kwargs))) (mapper f k a))) -;;; This code should be implemented in C. -;;; -(define-macro (define-class name supers . slots) - ;; Some slot options require extra definitions to be made. In - ;; particular, we want to make sure that the generic function objects - ;; which represent accessors exist before `make-class' tries to add - ;; methods to them. - ;; - ;; Postpone some error handling to class macro. - ;; - `(begin - ;; define accessors - ,@(append-map (lambda (slot) - (kw-do-map filter-map - define-class-pre-definition - (if (pair? slot) (cdr slot) '()))) - (take-while (lambda (x) (not (keyword? x))) slots)) - (if (and (defined? ',name) - (is-a? ,name ) - (memq (class-precedence-list ,name))) - (class-redefinition ,name - (class ,supers ,@slots #:name ',name)) - (define ,name (class ,supers ,@slots #:name ',name))))) - -(define-syntax standard-define-class - (syntax-rules () - ((_ arg ...) (define-class arg ...)))) - -;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) -;;; -;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) -;;; OPTION ::= KEYWORD VALUE -;;; -(define-macro (class supers . slots) - (define (make-slot-definition-forms slots) - (map - (lambda (def) - (cond - ((pair? def) - `(list ',(car def) - ,@(kw-do-map append-map - (lambda (kw arg) - (case kw - ((#:init-form) - `(#:init-form ',arg - #:init-thunk (lambda () ,arg))) - (else (list kw arg)))) - (cdr def)))) - (else - `(list ',def)))) - slots)) - - (if (not (list? supers)) - (goops-error "malformed superclass list: ~S" supers)) - (let ((slot-defs (cons #f '())) - (slots (take-while (lambda (x) (not (keyword? x))) slots)) - (options (or (find-tail keyword? slots) '()))) - `(make-class - ;; evaluate super class variables - (list ,@supers) - ;; evaluate slot definitions, except the slot name! - (list ,@(make-slot-definition-forms slots)) - ;; evaluate class options - ,@options))) - (define (make-class supers slots . options) (let ((env (or (get-keyword #:environment options #f) (top-level-env)))) @@ -277,6 +201,108 @@ #:environment env options)))) +;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(define-macro (class supers . slots) + (define (make-slot-definition-forms slots) + (map + (lambda (def) + (cond + ((pair? def) + `(list ',(car def) + ,@(kw-do-map append-map + (lambda (kw arg) + (case kw + ((#:init-form) + `(#:init-form ',arg + #:init-thunk (lambda () ,arg))) + (else (list kw arg)))) + (cdr def)))) + (else + `(list ',def)))) + slots)) + (if (not (list? supers)) + (goops-error "malformed superclass list: ~S" supers)) + (let ((slot-defs (cons #f '())) + (slots (take-while (lambda (x) (not (keyword? x))) slots)) + (options (or (find-tail keyword? slots) '()))) + `(make-class + ;; evaluate super class variables + (list ,@supers) + ;; evaluate slot definitions, except the slot name! + (list ,@(make-slot-definition-forms slots)) + ;; evaluate class options + ,@options))) + +(define-syntax define-class-pre-definition + (lambda (x) + (syntax-case x () + ((_ (k arg rest ...) out ...) + (keyword? (syntax-object->datum (syntax k))) + (case (syntax-object->datum (syntax k)) + ((#:getter #:setter) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))) + ((#:accessor) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))) + (else + (syntax + (define-class-pre-definition (rest ...) out ...))))) + ((_ () out ...) + (syntax (begin out ...)))))) + +;; Some slot options require extra definitions to be made. In +;; particular, we want to make sure that the generic function objects +;; which represent accessors exist before `make-class' tries to add +;; methods to them. +(define-syntax define-class-pre-definitions + (lambda (x) + (syntax-case x () + ((_ () out ...) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (keyword? (syntax-object->datum (syntax slot))) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (identifier? (syntax slot)) + (syntax (define-class-pre-definitions (rest ...) + out ...))) + ((_ ((slotname slotopt ...) rest ...) out ...) + (syntax (define-class-pre-definitions (rest ...) + out ... (define-class-pre-definition (slotopt ...)))))))) + +(define-syntax define-class + (syntax-rules () + ((_ name supers slot ...) + (begin + (define-class-pre-definitions (slot ...)) + (if (and (defined? 'name) + (is-a? name ) + (memq (class-precedence-list name))) + (class-redefinition name + (class supers slot ... #:name 'name)) + (toplevel-define! 'name (class supers slot ... #:name 'name))))))) + +(define-syntax standard-define-class + (syntax-rules () + ((_ arg ...) (define-class arg ...)))) + ;;; ;;; {Generic functions and accessors} ;;; @@ -1035,11 +1061,14 @@ ;; the idea is to compile the index into the procedure, for fastest ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. +;; separate expression so that we affect the expansion of the subsequent +;; expression (eval-when (compile) (use-modules ((language scheme compile-ghil) :select (define-scheme-translator)) ((language ghil) :select (make-ghil-inline make-ghil-call)) - (system base pmatch)) + (system base pmatch))) +(eval-when (compile) ;; unfortunately, can't use define-inline because these are primitive ;; syntaxen. (define-scheme-translator @slot-ref diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm index 4d64da8bb..2aedd7698 100644 --- a/module/oop/goops/save.scm +++ b/module/oop/goops/save.scm @@ -110,9 +110,7 @@ ;;; Readables ;;; -(if (or (not (defined? 'readables)) - (not readables)) - (define readables (make-weak-key-hash-table 61))) +(define readables (make-weak-key-hash-table 61)) (define-macro (readable exp) `(make-readable ,exp ',(copy-tree exp))) diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm index 48e76f312..c0cb76fbb 100644 --- a/module/oop/goops/simple.scm +++ b/module/oop/goops/simple.scm @@ -23,6 +23,9 @@ :export (define-class) :no-backtrace) -(define define-class define-class-with-accessors-keywords) +(define-syntax define-class + (syntax-rules () + ((_ arg ...) + (define-class-with-accessors-keywords arg ...)))) (module-use! %module-public-interface (resolve-interface '(oop goops))) diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm index 60ab293c3..ef943cf96 100644 --- a/module/oop/goops/stklos.scm +++ b/module/oop/goops/stklos.scm @@ -47,51 +47,30 @@ ;;; Enable keyword support (*fixme*---currently this has global effect) (read-set! keywords 'prefix) -(define standard-define-class-transformer - (macro-transformer standard-define-class)) +(define-syntax define-class + (syntax-rules () + ((_ name supers (slot ...) rest ...) + (standard-define-class name supers slot ... rest ...)))) -(define define-class - ;; Syntax - (let ((name cadr) - (supers caddr) - (slots cadddr) - (rest cddddr)) - (procedure->memoizing-macro - (lambda (exp env) - (standard-define-class-transformer - `(define-class ,(name exp) ,(supers exp) ,@(slots exp) - ,@(rest exp)) - env))))) +(define (toplevel-define! name val) + (module-define! (current-module) name val)) -(define define-method - (procedure->memoizing-macro - (lambda (exp env) - (let ((name (cadr exp))) - (if (and (pair? name) - (eq? (car name) 'setter) - (pair? (cdr name)) - (null? (cddr name))) - (let ((name (cadr name))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (is-a? ,name )) - (define-accessor ,name)) - (add-method! (setter ,name) (method ,@(cddr exp))))) - (else - `(begin - (define-accessor ,name) - (add-method! (setter ,name) (method ,@(cddr exp))))))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (or (is-a? ,name ) - (is-a? ,name ))) - (define-generic ,name)) - (add-method! ,name (method ,@(cddr exp))))) - (else - `(begin - (define-generic ,name) - (add-method! ,name (method ,@(cddr exp))))))))))) +(define-syntax define-method + (syntax-rules (setter) + ((_ (setter name) rest ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method rest ...)))) + ((_ name rest ...) + (begin + (if (or (not (defined? 'name)) + (not (or (is-a? name ) + (is-a? name )))) + (toplevel-define! 'name + (ensure-generic + (if (defined? 'name) name #f) 'name))) + (add-method! name (method rest ...)))))) From 97ce9dbf2158a08980189bcb3c3016ba30246829 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Apr 2009 16:31:52 +0200 Subject: [PATCH 076/375] allow defmacros to have docstrings * module/ice-9/boot-9.scm (define-macro, defmacro): Add the ability to have a docstring. * module/ice-9/documentation.scm (object-documentation): Remove references to defmacro? and macro?. Since we store the transformation procedure as the binding, we can get docs from the procedure directly. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/psyntax.scm (put-global-definition-hook): Take the type and the value separately, so we can set the variable to the procedure, while keeping the *sc-expander* to be the "binding object". (global-extend): Pass type and val separately. --- module/ice-9/boot-9.scm | 21 ++++++++++++++++----- module/ice-9/documentation.scm | 6 ------ module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 11 ++++++----- 4 files changed, 33 insertions(+), 27 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 51f195851..b9484b79c 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -209,13 +209,20 @@ (define-syntax define-macro (lambda (x) + "Define a defmacro." (syntax-case x () - ((_ (macro . args) . body) - (syntax (define-macro macro (lambda args . body)))) - ((_ macro transformer) + ((_ (macro . args) doc body1 body ...) + (string? (syntax-object->datum (syntax doc))) + (syntax (define-macro macro doc (lambda args body1 body ...)))) + ((_ (macro . args) body ...) + (syntax (define-macro macro #f (lambda args body ...)))) + ((_ macro doc transformer) + (or (string? (syntax-object->datum (syntax doc))) + (not (syntax-object->datum (syntax doc)))) (syntax (define-syntax macro (lambda (y) + doc (syntax-case y () ((_ . args) (let ((v (syntax-object->datum (syntax args)))) @@ -223,9 +230,13 @@ (define-syntax defmacro (lambda (x) + "Define a defmacro, with the old lispy defun syntax." (syntax-case x () - ((_ macro args . body) - (syntax (define-macro macro (lambda args . body))))))) + ((_ macro args doc body1 body ...) + (string? (syntax-object->datum (syntax doc))) + (syntax (define-macro macro doc (lambda args body1 body ...)))) + ((_ macro args body ...) + (syntax (define-macro macro #f (lambda args body ...))))))) (provide 'defmacro) diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index c5f447e78..234cd064c 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -195,12 +195,6 @@ OBJECT can be a procedure, macro or any object that has its `documentation' property set." (or (and (procedure? object) (proc-doc object)) - (and (defmacro? object) - (proc-doc (defmacro-transformer object))) - (and (macro? object) - (let ((transformer (macro-transformer object))) - (and transformer - (proc-doc transformer)))) (object-property object 'documentation) (and (program? object) (program-documentation object)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index aa637415e..37b02c455 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list175 (lambda (vars380) (let lvl381 ((vars382 vars380) (ls383 (quote ())) (w384 (quote (())))) (cond ((pair? vars382) (lvl381 (cdr vars382) (cons (wrap154 (car vars382) w384 #f) ls383) w384)) ((id?126 vars382) (cons (wrap154 vars382 w384 #f) ls383)) ((null? vars382) ls383) ((syntax-object?110 vars382) (lvl381 (syntax-object-expression111 vars382) ls383 (join-wraps145 w384 (syntax-object-wrap112 vars382)))) ((annotation? vars382) (lvl381 (annotation-expression vars382) ls383 w384)) (else (cons vars382 ls383)))))) (gen-var174 (lambda (id385) (let ((id386 (if (syntax-object?110 id385) (syntax-object-expression111 id385) id385))) (if (annotation? id386) (build-annotated103 (annotation-source id386) (gensym (symbol->string (annotation-expression id386)))) (build-annotated103 #f (gensym (symbol->string id386))))))) (strip173 (lambda (x387 w388) (if (memq (quote top) (wrap-marks129 w388)) (if (or (annotation? x387) (and (pair? x387) (annotation? (car x387)))) (strip-annotation172 x387 #f) x387) (let f389 ((x390 x387)) (cond ((syntax-object?110 x390) (strip173 (syntax-object-expression111 x390) (syntax-object-wrap112 x390))) ((pair? x390) (let ((a391 (f389 (car x390))) (d392 (f389 (cdr x390)))) (if (and (eq? a391 (car x390)) (eq? d392 (cdr x390))) x390 (cons a391 d392)))) ((vector? x390) (let ((old393 (vector->list x390))) (let ((new394 (map f389 old393))) (if (andmap eq? old393 new394) x390 (list->vector new394))))) (else x390)))))) (strip-annotation172 (lambda (x395 parent396) (cond ((pair? x395) (let ((new397 (cons #f #f))) (begin (if parent396 (set-annotation-stripped! parent396 new397)) (set-car! new397 (strip-annotation172 (car x395) #f)) (set-cdr! new397 (strip-annotation172 (cdr x395) #f)) new397))) ((annotation? x395) (or (annotation-stripped x395) (strip-annotation172 (annotation-expression x395) x395))) ((vector? x395) (let ((new398 (make-vector (vector-length x395)))) (begin (if parent396 (set-annotation-stripped! parent396 new398)) (let loop399 ((i400 (- (vector-length x395) 1))) (unless (fx<96 i400 0) (vector-set! new398 i400 (strip-annotation172 (vector-ref x395 i400) #f)) (loop399 (fx-94 i400 1)))) new398))) (else x395)))) (ellipsis?171 (lambda (x401) (and (nonsymbol-id?125 x401) (free-id=?149 x401 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void170 (lambda () (build-annotated103 #f (list (build-annotated103 #f (quote void)))))) (eval-local-transformer169 (lambda (expanded402 mod403) (let ((p404 (local-eval-hook98 expanded402 mod403))) (if (procedure? p404) p404 (syntax-error p404 "nonprocedure transformer"))))) (chi-local-syntax168 (lambda (rec?405 e406 r407 w408 s409 mod410 k411) ((lambda (tmp412) ((lambda (tmp413) (if tmp413 (apply (lambda (_414 id415 val416 e1417 e2418) (let ((ids419 id415)) (if (not (valid-bound-ids?151 ids419)) (syntax-error e406 "duplicate bound keyword in") (let ((labels421 (gen-labels132 ids419))) (let ((new-w422 (make-binding-wrap143 ids419 labels421 w408))) (k411 (cons e1417 e2418) (extend-env120 labels421 (let ((w424 (if rec?405 new-w422 w408)) (trans-r425 (macros-only-env122 r407))) (map (lambda (x426) (cons (quote macro) (eval-local-transformer169 (chi162 x426 trans-r425 w424 mod410) mod410))) val416)) r407) new-w422 s409 mod410)))))) tmp413) ((lambda (_428) (syntax-error (source-wrap155 e406 w408 s409 mod410))) tmp412))) (syntax-dispatch tmp412 (quote (any #(each (any any)) any . each-any))))) e406))) (chi-lambda-clause167 (lambda (e429 docstring430 c431 r432 w433 mod434 k435) ((lambda (tmp436) ((lambda (tmp437) (if (if tmp437 (apply (lambda (args438 doc439 e1440 e2441) (and (string? (syntax-object->datum doc439)) (not docstring430))) tmp437) #f) (apply (lambda (args442 doc443 e1444 e2445) (chi-lambda-clause167 e429 doc443 (cons args442 (cons e1444 e2445)) r432 w433 mod434 k435)) tmp437) ((lambda (tmp447) (if tmp447 (apply (lambda (id448 e1449 e2450) (let ((ids451 id448)) (if (not (valid-bound-ids?151 ids451)) (syntax-error e429 "invalid parameter list in") (let ((labels453 (gen-labels132 ids451)) (new-vars454 (map gen-var174 ids451))) (k435 new-vars454 docstring430 (chi-body166 (cons e1449 e2450) e429 (extend-var-env121 labels453 new-vars454 r432) (make-binding-wrap143 ids451 labels453 w433) mod434)))))) tmp447) ((lambda (tmp456) (if tmp456 (apply (lambda (ids457 e1458 e2459) (let ((old-ids460 (lambda-var-list175 ids457))) (if (not (valid-bound-ids?151 old-ids460)) (syntax-error e429 "invalid parameter list in") (let ((labels461 (gen-labels132 old-ids460)) (new-vars462 (map gen-var174 old-ids460))) (k435 (let f463 ((ls1464 (cdr new-vars462)) (ls2465 (car new-vars462))) (if (null? ls1464) ls2465 (f463 (cdr ls1464) (cons (car ls1464) ls2465)))) docstring430 (chi-body166 (cons e1458 e2459) e429 (extend-var-env121 labels461 new-vars462 r432) (make-binding-wrap143 old-ids460 labels461 w433) mod434)))))) tmp456) ((lambda (_467) (syntax-error e429)) tmp436))) (syntax-dispatch tmp436 (quote (any any . each-any)))))) (syntax-dispatch tmp436 (quote (each-any any . each-any)))))) (syntax-dispatch tmp436 (quote (any any any . each-any))))) c431))) (chi-body166 (lambda (body468 outer-form469 r470 w471 mod472) (let ((r473 (cons (quote ("placeholder" placeholder)) r470))) (let ((ribcage474 (make-ribcage133 (quote ()) (quote ()) (quote ())))) (let ((w475 (make-wrap128 (wrap-marks129 w471) (cons ribcage474 (wrap-subst130 w471))))) (let parse476 ((body477 (map (lambda (x483) (cons r473 (wrap154 x483 w475 mod472))) body468)) (ids478 (quote ())) (labels479 (quote ())) (vars480 (quote ())) (vals481 (quote ())) (bindings482 (quote ()))) (if (null? body477) (syntax-error outer-form469 "no expressions in body") (let ((e484 (cdar body477)) (er485 (caar body477))) (call-with-values (lambda () (syntax-type160 e484 er485 (quote (())) #f ribcage474 mod472)) (lambda (type486 value487 e488 w489 s490 mod491) (let ((t492 type486)) (if (memv t492 (quote (define-form))) (let ((id493 (wrap154 value487 w489 mod491)) (label494 (gen-label131))) (let ((var495 (gen-var174 id493))) (begin (extend-ribcage!142 ribcage474 id493 label494) (parse476 (cdr body477) (cons id493 ids478) (cons label494 labels479) (cons var495 vars480) (cons (cons er485 (wrap154 e488 w489 mod491)) vals481) (cons (cons (quote lexical) var495) bindings482))))) (if (memv t492 (quote (define-syntax-form))) (let ((id496 (wrap154 value487 w489 mod491)) (label497 (gen-label131))) (begin (extend-ribcage!142 ribcage474 id496 label497) (parse476 (cdr body477) (cons id496 ids478) (cons label497 labels479) vars480 vals481 (cons (cons (quote macro) (cons er485 (wrap154 e488 w489 mod491))) bindings482)))) (if (memv t492 (quote (begin-form))) ((lambda (tmp498) ((lambda (tmp499) (if tmp499 (apply (lambda (_500 e1501) (parse476 (let f502 ((forms503 e1501)) (if (null? forms503) (cdr body477) (cons (cons er485 (wrap154 (car forms503) w489 mod491)) (f502 (cdr forms503))))) ids478 labels479 vars480 vals481 bindings482)) tmp499) (syntax-error tmp498))) (syntax-dispatch tmp498 (quote (any . each-any))))) e488) (if (memv t492 (quote (local-syntax-form))) (chi-local-syntax168 value487 e488 er485 w489 s490 mod491 (lambda (forms505 er506 w507 s508 mod509) (parse476 (let f510 ((forms511 forms505)) (if (null? forms511) (cdr body477) (cons (cons er506 (wrap154 (car forms511) w507 mod509)) (f510 (cdr forms511))))) ids478 labels479 vars480 vals481 bindings482))) (if (null? ids478) (build-sequence105 #f (map (lambda (x512) (chi162 (cdr x512) (car x512) (quote (())) mod491)) (cons (cons er485 (source-wrap155 e488 w489 s490 mod491)) (cdr body477)))) (begin (if (not (valid-bound-ids?151 ids478)) (syntax-error outer-form469 "invalid or duplicate identifier in definition")) (let loop513 ((bs514 bindings482) (er-cache515 #f) (r-cache516 #f)) (if (not (null? bs514)) (let ((b517 (car bs514))) (if (eq? (car b517) (quote macro)) (let ((er518 (cadr b517))) (let ((r-cache519 (if (eq? er518 er-cache515) r-cache516 (macros-only-env122 er518)))) (begin (set-cdr! b517 (eval-local-transformer169 (chi162 (cddr b517) r-cache519 (quote (())) mod491) mod491)) (loop513 (cdr bs514) er518 r-cache519)))) (loop513 (cdr bs514) er-cache515 r-cache516))))) (set-cdr! r473 (extend-env120 labels479 bindings482 (cdr r473))) (build-letrec108 #f vars480 (map (lambda (x520) (chi162 (cdr x520) (car x520) (quote (())) mod491)) vals481) (build-sequence105 #f (map (lambda (x521) (chi162 (cdr x521) (car x521) (quote (())) mod491)) (cons (cons er485 (source-wrap155 e488 w489 s490 mod491)) (cdr body477)))))))))))))))))))))) (chi-macro165 (lambda (p522 e523 r524 w525 rib526 mod527) (letrec ((rebuild-macro-output528 (lambda (x529 m530) (cond ((pair? x529) (cons (rebuild-macro-output528 (car x529) m530) (rebuild-macro-output528 (cdr x529) m530))) ((syntax-object?110 x529) (let ((w531 (syntax-object-wrap112 x529))) (let ((ms532 (wrap-marks129 w531)) (s533 (wrap-subst130 w531))) (if (and (pair? ms532) (eq? (car ms532) #f)) (make-syntax-object109 (syntax-object-expression111 x529) (make-wrap128 (cdr ms532) (if rib526 (cons rib526 (cdr s533)) (cdr s533))) (syntax-object-module113 x529)) (make-syntax-object109 (syntax-object-expression111 x529) (make-wrap128 (cons m530 ms532) (if rib526 (cons rib526 (cons (quote shift) s533)) (cons (quote shift) s533))) (let ((pmod534 (procedure-module p522))) (if pmod534 (cons (quote hygiene) (module-name pmod534)) (quote (hygiene guile))))))))) ((vector? x529) (let ((n535 (vector-length x529))) (let ((v536 (make-vector n535))) (let doloop537 ((i538 0)) (if (fx=95 i538 n535) v536 (begin (vector-set! v536 i538 (rebuild-macro-output528 (vector-ref x529 i538) m530)) (doloop537 (fx+93 i538 1)))))))) ((symbol? x529) (syntax-error x529 "encountered raw symbol in macro output")) (else x529))))) (rebuild-macro-output528 (p522 (wrap154 e523 (anti-mark141 w525) mod527)) (string #\m))))) (chi-application164 (lambda (x539 e540 r541 w542 s543 mod544) ((lambda (tmp545) ((lambda (tmp546) (if tmp546 (apply (lambda (e0547 e1548) (build-annotated103 s543 (cons x539 (map (lambda (e549) (chi162 e549 r541 w542 mod544)) e1548)))) tmp546) (syntax-error tmp545))) (syntax-dispatch tmp545 (quote (any . each-any))))) e540))) (chi-expr163 (lambda (type551 value552 e553 r554 w555 s556 mod557) (let ((t558 type551)) (if (memv t558 (quote (lexical))) (build-annotated103 s556 value552) (if (memv t558 (quote (core external-macro))) (value552 e553 r554 w555 s556 mod557) (if (memv t558 (quote (module-ref))) (call-with-values (lambda () (value552 e553)) (lambda (id559 mod560) (build-annotated103 s556 (if mod560 (make-module-ref (cdr mod560) id559 (car mod560)) (make-module-ref mod560 id559 (quote bare)))))) (if (memv t558 (quote (lexical-call))) (chi-application164 (build-annotated103 (source-annotation117 (car e553)) value552) e553 r554 w555 s556 mod557) (if (memv t558 (quote (global-call))) (chi-application164 (build-annotated103 (source-annotation117 (car e553)) (if (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557) (make-module-ref (cdr (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557)) value552 (car (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557))) (make-module-ref (if (syntax-object?110 (car e553)) (syntax-object-module113 (car e553)) mod557) value552 (quote bare)))) e553 r554 w555 s556 mod557) (if (memv t558 (quote (constant))) (build-data104 s556 (strip173 (source-wrap155 e553 w555 s556 mod557) (quote (())))) (if (memv t558 (quote (global))) (build-annotated103 s556 (if mod557 (make-module-ref (cdr mod557) value552 (car mod557)) (make-module-ref mod557 value552 (quote bare)))) (if (memv t558 (quote (call))) (chi-application164 (chi162 (car e553) r554 w555 mod557) e553 r554 w555 s556 mod557) (if (memv t558 (quote (begin-form))) ((lambda (tmp561) ((lambda (tmp562) (if tmp562 (apply (lambda (_563 e1564 e2565) (chi-sequence156 (cons e1564 e2565) r554 w555 s556 mod557)) tmp562) (syntax-error tmp561))) (syntax-dispatch tmp561 (quote (any any . each-any))))) e553) (if (memv t558 (quote (local-syntax-form))) (chi-local-syntax168 value552 e553 r554 w555 s556 mod557 chi-sequence156) (if (memv t558 (quote (eval-when-form))) ((lambda (tmp567) ((lambda (tmp568) (if tmp568 (apply (lambda (_569 x570 e1571 e2572) (let ((when-list573 (chi-when-list159 e553 x570 w555))) (if (memq (quote eval) when-list573) (chi-sequence156 (cons e1571 e2572) r554 w555 s556 mod557) (chi-void170)))) tmp568) (syntax-error tmp567))) (syntax-dispatch tmp567 (quote (any each-any any . each-any))))) e553) (if (memv t558 (quote (define-form define-syntax-form))) (syntax-error (wrap154 value552 w555 mod557) "invalid context for definition of") (if (memv t558 (quote (syntax))) (syntax-error (source-wrap155 e553 w555 s556 mod557) "reference to pattern variable outside syntax form") (if (memv t558 (quote (displaced-lexical))) (syntax-error (source-wrap155 e553 w555 s556 mod557) "reference to identifier outside its scope") (syntax-error (source-wrap155 e553 w555 s556 mod557))))))))))))))))))) (chi162 (lambda (e576 r577 w578 mod579) (call-with-values (lambda () (syntax-type160 e576 r577 w578 #f #f mod579)) (lambda (type580 value581 e582 w583 s584 mod585) (chi-expr163 type580 value581 e582 r577 w583 s584 mod585))))) (chi-top161 (lambda (e586 r587 w588 m589 esew590 mod591) (call-with-values (lambda () (syntax-type160 e586 r587 w588 #f #f mod591)) (lambda (type599 value600 e601 w602 s603 mod604) (let ((t605 type599)) (if (memv t605 (quote (begin-form))) ((lambda (tmp606) ((lambda (tmp607) (if tmp607 (apply (lambda (_608) (chi-void170)) tmp607) ((lambda (tmp609) (if tmp609 (apply (lambda (_610 e1611 e2612) (chi-top-sequence157 (cons e1611 e2612) r587 w602 s603 m589 esew590 mod604)) tmp609) (syntax-error tmp606))) (syntax-dispatch tmp606 (quote (any any . each-any)))))) (syntax-dispatch tmp606 (quote (any))))) e601) (if (memv t605 (quote (local-syntax-form))) (chi-local-syntax168 value600 e601 r587 w602 s603 mod604 (lambda (body614 r615 w616 s617 mod618) (chi-top-sequence157 body614 r615 w616 s617 m589 esew590 mod618))) (if (memv t605 (quote (eval-when-form))) ((lambda (tmp619) ((lambda (tmp620) (if tmp620 (apply (lambda (_621 x622 e1623 e2624) (let ((when-list625 (chi-when-list159 e601 x622 w602)) (body626 (cons e1623 e2624))) (cond ((eq? m589 (quote e)) (if (memq (quote eval) when-list625) (chi-top-sequence157 body626 r587 w602 s603 (quote e) (quote (eval)) mod604) (chi-void170))) ((memq (quote load) when-list625) (if (or (memq (quote compile) when-list625) (and (eq? m589 (quote c&e)) (memq (quote eval) when-list625))) (chi-top-sequence157 body626 r587 w602 s603 (quote c&e) (quote (compile load)) mod604) (if (memq m589 (quote (c c&e))) (chi-top-sequence157 body626 r587 w602 s603 (quote c) (quote (load)) mod604) (chi-void170)))) ((or (memq (quote compile) when-list625) (and (eq? m589 (quote c&e)) (memq (quote eval) when-list625))) (top-level-eval-hook97 (chi-top-sequence157 body626 r587 w602 s603 (quote e) (quote (eval)) mod604) mod604) (chi-void170)) (else (chi-void170))))) tmp620) (syntax-error tmp619))) (syntax-dispatch tmp619 (quote (any each-any any . each-any))))) e601) (if (memv t605 (quote (define-syntax-form))) (let ((n629 (id-var-name148 value600 w602)) (r630 (macros-only-env122 r587))) (let ((t631 m589)) (if (memv t631 (quote (c))) (if (memq (quote compile) esew590) (let ((e632 (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)))) (begin (top-level-eval-hook97 e632 mod604) (if (memq (quote load) esew590) e632 (chi-void170)))) (if (memq (quote load) esew590) (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)) (chi-void170))) (if (memv t631 (quote (c&e))) (let ((e633 (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)))) (begin (top-level-eval-hook97 e633 mod604) e633)) (begin (if (memq (quote eval) esew590) (top-level-eval-hook97 (chi-install-global158 n629 (chi162 e601 r630 w602 mod604)) mod604)) (chi-void170)))))) (if (memv t605 (quote (define-form))) (let ((n634 (id-var-name148 value600 w602))) (let ((type635 (binding-type118 (lookup123 n634 r587 mod604)))) (let ((t636 type635)) (if (memv t636 (quote (global))) (let ((x637 (build-annotated103 s603 (list (quote define) n634 (chi162 e601 r587 w602 mod604))))) (begin (if (eq? m589 (quote c&e)) (top-level-eval-hook97 x637 mod604)) x637)) (if (memv t636 (quote (displaced-lexical))) (syntax-error (wrap154 value600 w602 mod604) "identifier out of context") (if (memv t636 (quote (core macro module-ref))) (begin (remove-global-definition-hook101 n634) (let ((x638 (build-annotated103 s603 (list (quote define) n634 (chi162 e601 r587 w602 mod604))))) (begin (if (eq? m589 (quote c&e)) (top-level-eval-hook97 x638 mod604)) x638))) (syntax-error (wrap154 value600 w602 mod604) "cannot define keyword at top level"))))))) (let ((x639 (chi-expr163 type599 value600 e601 r587 w602 s603 mod604))) (begin (if (eq? m589 (quote c&e)) (top-level-eval-hook97 x639 mod604)) x639)))))))))))) (syntax-type160 (lambda (e640 r641 w642 s643 rib644 mod645) (cond ((symbol? e640) (let ((n646 (id-var-name148 e640 w642))) (let ((b647 (lookup123 n646 r641 mod645))) (let ((type648 (binding-type118 b647))) (let ((t649 type648)) (if (memv t649 (quote (lexical))) (values type648 (binding-value119 b647) e640 w642 s643 mod645) (if (memv t649 (quote (global))) (values type648 n646 e640 w642 s643 mod645) (if (memv t649 (quote (macro))) (syntax-type160 (chi-macro165 (binding-value119 b647) e640 r641 w642 rib644 mod645) r641 (quote (())) s643 rib644 mod645) (values type648 (binding-value119 b647) e640 w642 s643 mod645))))))))) ((pair? e640) (let ((first650 (car e640))) (if (id?126 first650) (let ((n651 (id-var-name148 first650 w642))) (let ((b652 (lookup123 n651 r641 (or (and (syntax-object?110 first650) (syntax-object-module113 first650)) mod645)))) (let ((type653 (binding-type118 b652))) (let ((t654 type653)) (if (memv t654 (quote (lexical))) (values (quote lexical-call) (binding-value119 b652) e640 w642 s643 mod645) (if (memv t654 (quote (global))) (values (quote global-call) n651 e640 w642 s643 mod645) (if (memv t654 (quote (macro))) (syntax-type160 (chi-macro165 (binding-value119 b652) e640 r641 w642 rib644 mod645) r641 (quote (())) s643 rib644 mod645) (if (memv t654 (quote (core external-macro module-ref))) (values type653 (binding-value119 b652) e640 w642 s643 mod645) (if (memv t654 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value119 b652) e640 w642 s643 mod645) (if (memv t654 (quote (begin))) (values (quote begin-form) #f e640 w642 s643 mod645) (if (memv t654 (quote (eval-when))) (values (quote eval-when-form) #f e640 w642 s643 mod645) (if (memv t654 (quote (define))) ((lambda (tmp655) ((lambda (tmp656) (if (if tmp656 (apply (lambda (_657 name658 val659) (id?126 name658)) tmp656) #f) (apply (lambda (_660 name661 val662) (values (quote define-form) name661 val662 w642 s643 mod645)) tmp656) ((lambda (tmp663) (if (if tmp663 (apply (lambda (_664 name665 args666 e1667 e2668) (and (id?126 name665) (valid-bound-ids?151 (lambda-var-list175 args666)))) tmp663) #f) (apply (lambda (_669 name670 args671 e1672 e2673) (values (quote define-form) (wrap154 name670 w642 mod645) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap154 (cons args671 (cons e1672 e2673)) w642 mod645)) (quote (())) s643 mod645)) tmp663) ((lambda (tmp675) (if (if tmp675 (apply (lambda (_676 name677) (id?126 name677)) tmp675) #f) (apply (lambda (_678 name679) (values (quote define-form) (wrap154 name679 w642 mod645) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s643 mod645)) tmp675) (syntax-error tmp655))) (syntax-dispatch tmp655 (quote (any any)))))) (syntax-dispatch tmp655 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp655 (quote (any any any))))) e640) (if (memv t654 (quote (define-syntax))) ((lambda (tmp680) ((lambda (tmp681) (if (if tmp681 (apply (lambda (_682 name683 val684) (id?126 name683)) tmp681) #f) (apply (lambda (_685 name686 val687) (values (quote define-syntax-form) name686 val687 w642 s643 mod645)) tmp681) (syntax-error tmp680))) (syntax-dispatch tmp680 (quote (any any any))))) e640) (values (quote call) #f e640 w642 s643 mod645)))))))))))))) (values (quote call) #f e640 w642 s643 mod645)))) ((syntax-object?110 e640) (syntax-type160 (syntax-object-expression111 e640) r641 (join-wraps145 w642 (syntax-object-wrap112 e640)) #f rib644 (or (syntax-object-module113 e640) mod645))) ((annotation? e640) (syntax-type160 (annotation-expression e640) r641 w642 (annotation-source e640) rib644 mod645)) ((self-evaluating? e640) (values (quote constant) #f e640 w642 s643 mod645)) (else (values (quote other) #f e640 w642 s643 mod645))))) (chi-when-list159 (lambda (e688 when-list689 w690) (let f691 ((when-list692 when-list689) (situations693 (quote ()))) (if (null? when-list692) situations693 (f691 (cdr when-list692) (cons (let ((x694 (car when-list692))) (cond ((free-id=?149 x694 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?149 x694 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?149 x694 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap154 x694 w690 #f) "invalid eval-when situation")))) situations693)))))) (chi-install-global158 (lambda (name695 e696) (build-annotated103 #f (list (build-annotated103 #f (quote install-global-transformer)) (build-data104 #f name695) e696)))) (chi-top-sequence157 (lambda (body697 r698 w699 s700 m701 esew702 mod703) (build-sequence105 s700 (let dobody704 ((body705 body697) (r706 r698) (w707 w699) (m708 m701) (esew709 esew702) (mod710 mod703)) (if (null? body705) (quote ()) (let ((first711 (chi-top161 (car body705) r706 w707 m708 esew709 mod710))) (cons first711 (dobody704 (cdr body705) r706 w707 m708 esew709 mod710)))))))) (chi-sequence156 (lambda (body712 r713 w714 s715 mod716) (build-sequence105 s715 (let dobody717 ((body718 body712) (r719 r713) (w720 w714) (mod721 mod716)) (if (null? body718) (quote ()) (let ((first722 (chi162 (car body718) r719 w720 mod721))) (cons first722 (dobody717 (cdr body718) r719 w720 mod721)))))))) (source-wrap155 (lambda (x723 w724 s725 defmod726) (wrap154 (if s725 (make-annotation x723 s725 #f) x723) w724 defmod726))) (wrap154 (lambda (x727 w728 defmod729) (cond ((and (null? (wrap-marks129 w728)) (null? (wrap-subst130 w728))) x727) ((syntax-object?110 x727) (make-syntax-object109 (syntax-object-expression111 x727) (join-wraps145 w728 (syntax-object-wrap112 x727)) (syntax-object-module113 x727))) ((null? x727) x727) (else (make-syntax-object109 x727 w728 defmod729))))) (bound-id-member?153 (lambda (x730 list731) (and (not (null? list731)) (or (bound-id=?150 x730 (car list731)) (bound-id-member?153 x730 (cdr list731)))))) (distinct-bound-ids?152 (lambda (ids732) (let distinct?733 ((ids734 ids732)) (or (null? ids734) (and (not (bound-id-member?153 (car ids734) (cdr ids734))) (distinct?733 (cdr ids734))))))) (valid-bound-ids?151 (lambda (ids735) (and (let all-ids?736 ((ids737 ids735)) (or (null? ids737) (and (id?126 (car ids737)) (all-ids?736 (cdr ids737))))) (distinct-bound-ids?152 ids735)))) (bound-id=?150 (lambda (i738 j739) (if (and (syntax-object?110 i738) (syntax-object?110 j739)) (and (eq? (let ((e740 (syntax-object-expression111 i738))) (if (annotation? e740) (annotation-expression e740) e740)) (let ((e741 (syntax-object-expression111 j739))) (if (annotation? e741) (annotation-expression e741) e741))) (same-marks?147 (wrap-marks129 (syntax-object-wrap112 i738)) (wrap-marks129 (syntax-object-wrap112 j739)))) (eq? (let ((e742 i738)) (if (annotation? e742) (annotation-expression e742) e742)) (let ((e743 j739)) (if (annotation? e743) (annotation-expression e743) e743)))))) (free-id=?149 (lambda (i744 j745) (and (eq? (let ((x746 i744)) (let ((e747 (if (syntax-object?110 x746) (syntax-object-expression111 x746) x746))) (if (annotation? e747) (annotation-expression e747) e747))) (let ((x748 j745)) (let ((e749 (if (syntax-object?110 x748) (syntax-object-expression111 x748) x748))) (if (annotation? e749) (annotation-expression e749) e749)))) (eq? (id-var-name148 i744 (quote (()))) (id-var-name148 j745 (quote (()))))))) (id-var-name148 (lambda (id750 w751) (letrec ((search-vector-rib754 (lambda (sym760 subst761 marks762 symnames763 ribcage764) (let ((n765 (vector-length symnames763))) (let f766 ((i767 0)) (cond ((fx=95 i767 n765) (search752 sym760 (cdr subst761) marks762)) ((and (eq? (vector-ref symnames763 i767) sym760) (same-marks?147 marks762 (vector-ref (ribcage-marks136 ribcage764) i767))) (values (vector-ref (ribcage-labels137 ribcage764) i767) marks762)) (else (f766 (fx+93 i767 1)))))))) (search-list-rib753 (lambda (sym768 subst769 marks770 symnames771 ribcage772) (let f773 ((symnames774 symnames771) (i775 0)) (cond ((null? symnames774) (search752 sym768 (cdr subst769) marks770)) ((and (eq? (car symnames774) sym768) (same-marks?147 marks770 (list-ref (ribcage-marks136 ribcage772) i775))) (values (list-ref (ribcage-labels137 ribcage772) i775) marks770)) (else (f773 (cdr symnames774) (fx+93 i775 1))))))) (search752 (lambda (sym776 subst777 marks778) (if (null? subst777) (values #f marks778) (let ((fst779 (car subst777))) (if (eq? fst779 (quote shift)) (search752 sym776 (cdr subst777) (cdr marks778)) (let ((symnames780 (ribcage-symnames135 fst779))) (if (vector? symnames780) (search-vector-rib754 sym776 subst777 marks778 symnames780 fst779) (search-list-rib753 sym776 subst777 marks778 symnames780 fst779))))))))) (cond ((symbol? id750) (or (call-with-values (lambda () (search752 id750 (wrap-subst130 w751) (wrap-marks129 w751))) (lambda (x782 . ignore781) x782)) id750)) ((syntax-object?110 id750) (let ((id783 (let ((e785 (syntax-object-expression111 id750))) (if (annotation? e785) (annotation-expression e785) e785))) (w1784 (syntax-object-wrap112 id750))) (let ((marks786 (join-marks146 (wrap-marks129 w751) (wrap-marks129 w1784)))) (call-with-values (lambda () (search752 id783 (wrap-subst130 w751) marks786)) (lambda (new-id787 marks788) (or new-id787 (call-with-values (lambda () (search752 id783 (wrap-subst130 w1784) marks788)) (lambda (x790 . ignore789) x790)) id783)))))) ((annotation? id750) (let ((id791 (let ((e792 id750)) (if (annotation? e792) (annotation-expression e792) e792)))) (or (call-with-values (lambda () (search752 id791 (wrap-subst130 w751) (wrap-marks129 w751))) (lambda (x794 . ignore793) x794)) id791))) (else (error-hook99 (quote id-var-name) "invalid id" id750)))))) (same-marks?147 (lambda (x795 y796) (or (eq? x795 y796) (and (not (null? x795)) (not (null? y796)) (eq? (car x795) (car y796)) (same-marks?147 (cdr x795) (cdr y796)))))) (join-marks146 (lambda (m1797 m2798) (smart-append144 m1797 m2798))) (join-wraps145 (lambda (w1799 w2800) (let ((m1801 (wrap-marks129 w1799)) (s1802 (wrap-subst130 w1799))) (if (null? m1801) (if (null? s1802) w2800 (make-wrap128 (wrap-marks129 w2800) (smart-append144 s1802 (wrap-subst130 w2800)))) (make-wrap128 (smart-append144 m1801 (wrap-marks129 w2800)) (smart-append144 s1802 (wrap-subst130 w2800))))))) (smart-append144 (lambda (m1803 m2804) (if (null? m2804) m1803 (append m1803 m2804)))) (make-binding-wrap143 (lambda (ids805 labels806 w807) (if (null? ids805) w807 (make-wrap128 (wrap-marks129 w807) (cons (let ((labelvec808 (list->vector labels806))) (let ((n809 (vector-length labelvec808))) (let ((symnamevec810 (make-vector n809)) (marksvec811 (make-vector n809))) (begin (let f812 ((ids813 ids805) (i814 0)) (if (not (null? ids813)) (call-with-values (lambda () (id-sym-name&marks127 (car ids813) w807)) (lambda (symname815 marks816) (begin (vector-set! symnamevec810 i814 symname815) (vector-set! marksvec811 i814 marks816) (f812 (cdr ids813) (fx+93 i814 1))))))) (make-ribcage133 symnamevec810 marksvec811 labelvec808))))) (wrap-subst130 w807)))))) (extend-ribcage!142 (lambda (ribcage817 id818 label819) (begin (set-ribcage-symnames!138 ribcage817 (cons (let ((e820 (syntax-object-expression111 id818))) (if (annotation? e820) (annotation-expression e820) e820)) (ribcage-symnames135 ribcage817))) (set-ribcage-marks!139 ribcage817 (cons (wrap-marks129 (syntax-object-wrap112 id818)) (ribcage-marks136 ribcage817))) (set-ribcage-labels!140 ribcage817 (cons label819 (ribcage-labels137 ribcage817)))))) (anti-mark141 (lambda (w821) (make-wrap128 (cons #f (wrap-marks129 w821)) (cons (quote shift) (wrap-subst130 w821))))) (set-ribcage-labels!140 (lambda (x822 update823) (vector-set! x822 3 update823))) (set-ribcage-marks!139 (lambda (x824 update825) (vector-set! x824 2 update825))) (set-ribcage-symnames!138 (lambda (x826 update827) (vector-set! x826 1 update827))) (ribcage-labels137 (lambda (x828) (vector-ref x828 3))) (ribcage-marks136 (lambda (x829) (vector-ref x829 2))) (ribcage-symnames135 (lambda (x830) (vector-ref x830 1))) (ribcage?134 (lambda (x831) (and (vector? x831) (= (vector-length x831) 4) (eq? (vector-ref x831 0) (quote ribcage))))) (make-ribcage133 (lambda (symnames832 marks833 labels834) (vector (quote ribcage) symnames832 marks833 labels834))) (gen-labels132 (lambda (ls835) (if (null? ls835) (quote ()) (cons (gen-label131) (gen-labels132 (cdr ls835)))))) (gen-label131 (lambda () (string #\i))) (wrap-subst130 cdr) (wrap-marks129 car) (make-wrap128 cons) (id-sym-name&marks127 (lambda (x836 w837) (if (syntax-object?110 x836) (values (let ((e838 (syntax-object-expression111 x836))) (if (annotation? e838) (annotation-expression e838) e838)) (join-marks146 (wrap-marks129 w837) (wrap-marks129 (syntax-object-wrap112 x836)))) (values (let ((e839 x836)) (if (annotation? e839) (annotation-expression e839) e839)) (wrap-marks129 w837))))) (id?126 (lambda (x840) (cond ((symbol? x840) #t) ((syntax-object?110 x840) (symbol? (let ((e841 (syntax-object-expression111 x840))) (if (annotation? e841) (annotation-expression e841) e841)))) ((annotation? x840) (symbol? (annotation-expression x840))) (else #f)))) (nonsymbol-id?125 (lambda (x842) (and (syntax-object?110 x842) (symbol? (let ((e843 (syntax-object-expression111 x842))) (if (annotation? e843) (annotation-expression e843) e843)))))) (global-extend124 (lambda (type844 sym845 val846) (put-global-definition-hook100 sym845 (cons type844 val846)))) (lookup123 (lambda (x847 r848 mod849) (cond ((assq x847 r848) => cdr) ((symbol? x847) (or (get-global-definition-hook102 x847 mod849) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env122 (lambda (r850) (if (null? r850) (quote ()) (let ((a851 (car r850))) (if (eq? (cadr a851) (quote macro)) (cons a851 (macros-only-env122 (cdr r850))) (macros-only-env122 (cdr r850))))))) (extend-var-env121 (lambda (labels852 vars853 r854) (if (null? labels852) r854 (extend-var-env121 (cdr labels852) (cdr vars853) (cons (cons (car labels852) (cons (quote lexical) (car vars853))) r854))))) (extend-env120 (lambda (labels855 bindings856 r857) (if (null? labels855) r857 (extend-env120 (cdr labels855) (cdr bindings856) (cons (cons (car labels855) (car bindings856)) r857))))) (binding-value119 cdr) (binding-type118 car) (source-annotation117 (lambda (x858) (cond ((annotation? x858) (annotation-source x858)) ((syntax-object?110 x858) (source-annotation117 (syntax-object-expression111 x858))) (else #f)))) (set-syntax-object-module!116 (lambda (x859 update860) (vector-set! x859 3 update860))) (set-syntax-object-wrap!115 (lambda (x861 update862) (vector-set! x861 2 update862))) (set-syntax-object-expression!114 (lambda (x863 update864) (vector-set! x863 1 update864))) (syntax-object-module113 (lambda (x865) (vector-ref x865 3))) (syntax-object-wrap112 (lambda (x866) (vector-ref x866 2))) (syntax-object-expression111 (lambda (x867) (vector-ref x867 1))) (syntax-object?110 (lambda (x868) (and (vector? x868) (= (vector-length x868) 4) (eq? (vector-ref x868 0) (quote syntax-object))))) (make-syntax-object109 (lambda (expression869 wrap870 module871) (vector (quote syntax-object) expression869 wrap870 module871))) (build-letrec108 (lambda (src872 vars873 val-exps874 body-exp875) (if (null? vars873) (build-annotated103 src872 body-exp875) (build-annotated103 src872 (list (quote letrec) (map list vars873 val-exps874) body-exp875))))) (build-named-let107 (lambda (src876 vars877 val-exps878 body-exp879) (if (null? vars877) (build-annotated103 src876 body-exp879) (build-annotated103 src876 (list (quote let) (car vars877) (map list (cdr vars877) val-exps878) body-exp879))))) (build-let106 (lambda (src880 vars881 val-exps882 body-exp883) (if (null? vars881) (build-annotated103 src880 body-exp883) (build-annotated103 src880 (list (quote let) (map list vars881 val-exps882) body-exp883))))) (build-sequence105 (lambda (src884 exps885) (if (null? (cdr exps885)) (build-annotated103 src884 (car exps885)) (build-annotated103 src884 (cons (quote begin) exps885))))) (build-data104 (lambda (src886 exp887) (if (and (self-evaluating? exp887) (not (vector? exp887))) (build-annotated103 src886 exp887) (build-annotated103 src886 (list (quote quote) exp887))))) (build-annotated103 (lambda (src888 exp889) (if (and src888 (not (annotation? exp889))) (make-annotation exp889 src888 #t) exp889))) (get-global-definition-hook102 (lambda (symbol890 module891) (let ((module892 (if module891 (resolve-module (cdr module891)) (let ((mod893 (current-module))) (begin (if mod893 (warn "wha" symbol890)) mod893))))) (let ((v894 (module-variable module892 symbol890))) (and v894 (object-property v894 (quote *sc-expander*))))))) (remove-global-definition-hook101 (lambda (symbol895) (let ((module896 (current-module))) (let ((v897 (module-local-variable module896 symbol895))) (if v897 (let ((p898 (assq (quote *sc-expander*) (object-properties v897)))) (set-object-properties! v897 (delq p898 (object-properties v897))))))))) (put-global-definition-hook100 (lambda (symbol899 binding900) (let ((module901 (current-module))) (let ((v902 (or (module-variable module901 symbol899) (let ((v903 (make-variable (gensym)))) (begin (module-add! module901 symbol899 v903) v903))))) (begin (if (not (variable-bound? v902)) (variable-set! v902 (gensym))) (set-object-property! v902 (quote *sc-expander*) binding900)))))) (error-hook99 (lambda (who904 why905 what906) (error who904 "~a ~s" why905 what906))) (local-eval-hook98 (lambda (x907 mod908) (primitive-eval (list noexpand92 x907)))) (top-level-eval-hook97 (lambda (x909 mod910) (primitive-eval (list noexpand92 x909)))) (fx<96 <) (fx=95 =) (fx-94 -) (fx+93 +) (noexpand92 "noexpand")) (begin (global-extend124 (quote local-syntax) (quote letrec-syntax) #t) (global-extend124 (quote local-syntax) (quote let-syntax) #f) (global-extend124 (quote core) (quote fluid-let-syntax) (lambda (e911 r912 w913 s914 mod915) ((lambda (tmp916) ((lambda (tmp917) (if (if tmp917 (apply (lambda (_918 var919 val920 e1921 e2922) (valid-bound-ids?151 var919)) tmp917) #f) (apply (lambda (_924 var925 val926 e1927 e2928) (let ((names929 (map (lambda (x930) (id-var-name148 x930 w913)) var925))) (begin (for-each (lambda (id932 n933) (let ((t934 (binding-type118 (lookup123 n933 r912 mod915)))) (if (memv t934 (quote (displaced-lexical))) (syntax-error (source-wrap155 id932 w913 s914 mod915) "identifier out of context")))) var925 names929) (chi-body166 (cons e1927 e2928) (source-wrap155 e911 w913 s914 mod915) (extend-env120 names929 (let ((trans-r937 (macros-only-env122 r912))) (map (lambda (x938) (cons (quote macro) (eval-local-transformer169 (chi162 x938 trans-r937 w913 mod915) mod915))) val926)) r912) w913 mod915)))) tmp917) ((lambda (_940) (syntax-error (source-wrap155 e911 w913 s914 mod915))) tmp916))) (syntax-dispatch tmp916 (quote (any #(each (any any)) any . each-any))))) e911))) (global-extend124 (quote core) (quote quote) (lambda (e941 r942 w943 s944 mod945) ((lambda (tmp946) ((lambda (tmp947) (if tmp947 (apply (lambda (_948 e949) (build-data104 s944 (strip173 e949 w943))) tmp947) ((lambda (_950) (syntax-error (source-wrap155 e941 w943 s944 mod945))) tmp946))) (syntax-dispatch tmp946 (quote (any any))))) e941))) (global-extend124 (quote core) (quote syntax) (letrec ((regen958 (lambda (x959) (let ((t960 (car x959))) (if (memv t960 (quote (ref))) (build-annotated103 #f (cadr x959)) (if (memv t960 (quote (primitive))) (build-annotated103 #f (cadr x959)) (if (memv t960 (quote (quote))) (build-data104 #f (cadr x959)) (if (memv t960 (quote (lambda))) (build-annotated103 #f (list (quote lambda) (cadr x959) (regen958 (caddr x959)))) (if (memv t960 (quote (map))) (let ((ls961 (map regen958 (cdr x959)))) (build-annotated103 #f (cons (if (fx=95 (length ls961) 2) (build-annotated103 #f (quote map)) (build-annotated103 #f (quote map))) ls961))) (build-annotated103 #f (cons (build-annotated103 #f (car x959)) (map regen958 (cdr x959)))))))))))) (gen-vector957 (lambda (x962) (cond ((eq? (car x962) (quote list)) (cons (quote vector) (cdr x962))) ((eq? (car x962) (quote quote)) (list (quote quote) (list->vector (cadr x962)))) (else (list (quote list->vector) x962))))) (gen-append956 (lambda (x963 y964) (if (equal? y964 (quote (quote ()))) x963 (list (quote append) x963 y964)))) (gen-cons955 (lambda (x965 y966) (let ((t967 (car y966))) (if (memv t967 (quote (quote))) (if (eq? (car x965) (quote quote)) (list (quote quote) (cons (cadr x965) (cadr y966))) (if (eq? (cadr y966) (quote ())) (list (quote list) x965) (list (quote cons) x965 y966))) (if (memv t967 (quote (list))) (cons (quote list) (cons x965 (cdr y966))) (list (quote cons) x965 y966)))))) (gen-map954 (lambda (e968 map-env969) (let ((formals970 (map cdr map-env969)) (actuals971 (map (lambda (x972) (list (quote ref) (car x972))) map-env969))) (cond ((eq? (car e968) (quote ref)) (car actuals971)) ((andmap (lambda (x973) (and (eq? (car x973) (quote ref)) (memq (cadr x973) formals970))) (cdr e968)) (cons (quote map) (cons (list (quote primitive) (car e968)) (map (let ((r974 (map cons formals970 actuals971))) (lambda (x975) (cdr (assq (cadr x975) r974)))) (cdr e968))))) (else (cons (quote map) (cons (list (quote lambda) formals970 e968) actuals971))))))) (gen-mappend953 (lambda (e976 map-env977) (list (quote apply) (quote (primitive append)) (gen-map954 e976 map-env977)))) (gen-ref952 (lambda (src978 var979 level980 maps981) (if (fx=95 level980 0) (values var979 maps981) (if (null? maps981) (syntax-error src978 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref952 src978 var979 (fx-94 level980 1) (cdr maps981))) (lambda (outer-var982 outer-maps983) (let ((b984 (assq outer-var982 (car maps981)))) (if b984 (values (cdr b984) maps981) (let ((inner-var985 (gen-var174 (quote tmp)))) (values inner-var985 (cons (cons (cons outer-var982 inner-var985) (car maps981)) outer-maps983))))))))))) (gen-syntax951 (lambda (src986 e987 r988 maps989 ellipsis?990 mod991) (if (id?126 e987) (let ((label992 (id-var-name148 e987 (quote (()))))) (let ((b993 (lookup123 label992 r988 mod991))) (if (eq? (binding-type118 b993) (quote syntax)) (call-with-values (lambda () (let ((var.lev994 (binding-value119 b993))) (gen-ref952 src986 (car var.lev994) (cdr var.lev994) maps989))) (lambda (var995 maps996) (values (list (quote ref) var995) maps996))) (if (ellipsis?990 e987) (syntax-error src986 "misplaced ellipsis in syntax form") (values (list (quote quote) e987) maps989))))) ((lambda (tmp997) ((lambda (tmp998) (if (if tmp998 (apply (lambda (dots999 e1000) (ellipsis?990 dots999)) tmp998) #f) (apply (lambda (dots1001 e1002) (gen-syntax951 src986 e1002 r988 maps989 (lambda (x1003) #f) mod991)) tmp998) ((lambda (tmp1004) (if (if tmp1004 (apply (lambda (x1005 dots1006 y1007) (ellipsis?990 dots1006)) tmp1004) #f) (apply (lambda (x1008 dots1009 y1010) (let f1011 ((y1012 y1010) (k1013 (lambda (maps1014) (call-with-values (lambda () (gen-syntax951 src986 x1008 r988 (cons (quote ()) maps1014) ellipsis?990 mod991)) (lambda (x1015 maps1016) (if (null? (car maps1016)) (syntax-error src986 "extra ellipsis in syntax form") (values (gen-map954 x1015 (car maps1016)) (cdr maps1016)))))))) ((lambda (tmp1017) ((lambda (tmp1018) (if (if tmp1018 (apply (lambda (dots1019 y1020) (ellipsis?990 dots1019)) tmp1018) #f) (apply (lambda (dots1021 y1022) (f1011 y1022 (lambda (maps1023) (call-with-values (lambda () (k1013 (cons (quote ()) maps1023))) (lambda (x1024 maps1025) (if (null? (car maps1025)) (syntax-error src986 "extra ellipsis in syntax form") (values (gen-mappend953 x1024 (car maps1025)) (cdr maps1025)))))))) tmp1018) ((lambda (_1026) (call-with-values (lambda () (gen-syntax951 src986 y1012 r988 maps989 ellipsis?990 mod991)) (lambda (y1027 maps1028) (call-with-values (lambda () (k1013 maps1028)) (lambda (x1029 maps1030) (values (gen-append956 x1029 y1027) maps1030)))))) tmp1017))) (syntax-dispatch tmp1017 (quote (any . any))))) y1012))) tmp1004) ((lambda (tmp1031) (if tmp1031 (apply (lambda (x1032 y1033) (call-with-values (lambda () (gen-syntax951 src986 x1032 r988 maps989 ellipsis?990 mod991)) (lambda (x1034 maps1035) (call-with-values (lambda () (gen-syntax951 src986 y1033 r988 maps1035 ellipsis?990 mod991)) (lambda (y1036 maps1037) (values (gen-cons955 x1034 y1036) maps1037)))))) tmp1031) ((lambda (tmp1038) (if tmp1038 (apply (lambda (e11039 e21040) (call-with-values (lambda () (gen-syntax951 src986 (cons e11039 e21040) r988 maps989 ellipsis?990 mod991)) (lambda (e1042 maps1043) (values (gen-vector957 e1042) maps1043)))) tmp1038) ((lambda (_1044) (values (list (quote quote) e987) maps989)) tmp997))) (syntax-dispatch tmp997 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp997 (quote (any . any)))))) (syntax-dispatch tmp997 (quote (any any . any)))))) (syntax-dispatch tmp997 (quote (any any))))) e987))))) (lambda (e1045 r1046 w1047 s1048 mod1049) (let ((e1050 (source-wrap155 e1045 w1047 s1048 mod1049))) ((lambda (tmp1051) ((lambda (tmp1052) (if tmp1052 (apply (lambda (_1053 x1054) (call-with-values (lambda () (gen-syntax951 e1050 x1054 r1046 (quote ()) ellipsis?171 mod1049)) (lambda (e1055 maps1056) (regen958 e1055)))) tmp1052) ((lambda (_1057) (syntax-error e1050)) tmp1051))) (syntax-dispatch tmp1051 (quote (any any))))) e1050))))) (global-extend124 (quote core) (quote lambda) (lambda (e1058 r1059 w1060 s1061 mod1062) ((lambda (tmp1063) ((lambda (tmp1064) (if tmp1064 (apply (lambda (_1065 c1066) (chi-lambda-clause167 (source-wrap155 e1058 w1060 s1061 mod1062) #f c1066 r1059 w1060 mod1062 (lambda (vars1067 docstring1068 body1069) (build-annotated103 s1061 (cons (quote lambda) (cons vars1067 (append (if docstring1068 (list docstring1068) (quote ())) (list body1069)))))))) tmp1064) (syntax-error tmp1063))) (syntax-dispatch tmp1063 (quote (any . any))))) e1058))) (global-extend124 (quote core) (quote let) (letrec ((chi-let1070 (lambda (e1071 r1072 w1073 s1074 mod1075 constructor1076 ids1077 vals1078 exps1079) (if (not (valid-bound-ids?151 ids1077)) (syntax-error e1071 "duplicate bound variable in") (let ((labels1080 (gen-labels132 ids1077)) (new-vars1081 (map gen-var174 ids1077))) (let ((nw1082 (make-binding-wrap143 ids1077 labels1080 w1073)) (nr1083 (extend-var-env121 labels1080 new-vars1081 r1072))) (constructor1076 s1074 new-vars1081 (map (lambda (x1084) (chi162 x1084 r1072 w1073 mod1075)) vals1078) (chi-body166 exps1079 (source-wrap155 e1071 nw1082 s1074 mod1075) nr1083 nw1082 mod1075)))))))) (lambda (e1085 r1086 w1087 s1088 mod1089) ((lambda (tmp1090) ((lambda (tmp1091) (if tmp1091 (apply (lambda (_1092 id1093 val1094 e11095 e21096) (chi-let1070 e1085 r1086 w1087 s1088 mod1089 build-let106 id1093 val1094 (cons e11095 e21096))) tmp1091) ((lambda (tmp1100) (if (if tmp1100 (apply (lambda (_1101 f1102 id1103 val1104 e11105 e21106) (id?126 f1102)) tmp1100) #f) (apply (lambda (_1107 f1108 id1109 val1110 e11111 e21112) (chi-let1070 e1085 r1086 w1087 s1088 mod1089 build-named-let107 (cons f1108 id1109) val1110 (cons e11111 e21112))) tmp1100) ((lambda (_1116) (syntax-error (source-wrap155 e1085 w1087 s1088 mod1089))) tmp1090))) (syntax-dispatch tmp1090 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1090 (quote (any #(each (any any)) any . each-any))))) e1085)))) (global-extend124 (quote core) (quote letrec) (lambda (e1117 r1118 w1119 s1120 mod1121) ((lambda (tmp1122) ((lambda (tmp1123) (if tmp1123 (apply (lambda (_1124 id1125 val1126 e11127 e21128) (let ((ids1129 id1125)) (if (not (valid-bound-ids?151 ids1129)) (syntax-error e1117 "duplicate bound variable in") (let ((labels1131 (gen-labels132 ids1129)) (new-vars1132 (map gen-var174 ids1129))) (let ((w1133 (make-binding-wrap143 ids1129 labels1131 w1119)) (r1134 (extend-var-env121 labels1131 new-vars1132 r1118))) (build-letrec108 s1120 new-vars1132 (map (lambda (x1135) (chi162 x1135 r1134 w1133 mod1121)) val1126) (chi-body166 (cons e11127 e21128) (source-wrap155 e1117 w1133 s1120 mod1121) r1134 w1133 mod1121))))))) tmp1123) ((lambda (_1138) (syntax-error (source-wrap155 e1117 w1119 s1120 mod1121))) tmp1122))) (syntax-dispatch tmp1122 (quote (any #(each (any any)) any . each-any))))) e1117))) (global-extend124 (quote core) (quote set!) (lambda (e1139 r1140 w1141 s1142 mod1143) ((lambda (tmp1144) ((lambda (tmp1145) (if (if tmp1145 (apply (lambda (_1146 id1147 val1148) (id?126 id1147)) tmp1145) #f) (apply (lambda (_1149 id1150 val1151) (let ((val1152 (chi162 val1151 r1140 w1141 mod1143)) (n1153 (id-var-name148 id1150 w1141))) (let ((b1154 (lookup123 n1153 r1140 mod1143))) (let ((t1155 (binding-type118 b1154))) (if (memv t1155 (quote (lexical))) (build-annotated103 s1142 (list (quote set!) (binding-value119 b1154) val1152)) (if (memv t1155 (quote (global))) (build-annotated103 s1142 (list (quote set!) (if mod1143 (make-module-ref (cdr mod1143) n1153 (car mod1143)) (make-module-ref mod1143 n1153 (quote bare))) val1152)) (if (memv t1155 (quote (displaced-lexical))) (syntax-error (wrap154 id1150 w1141 mod1143) "identifier out of context") (syntax-error (source-wrap155 e1139 w1141 s1142 mod1143))))))))) tmp1145) ((lambda (tmp1156) (if tmp1156 (apply (lambda (_1157 head1158 tail1159 val1160) (call-with-values (lambda () (syntax-type160 head1158 r1140 (quote (())) #f #f mod1143)) (lambda (type1161 value1162 ee1163 ww1164 ss1165 modmod1166) (let ((t1167 type1161)) (if (memv t1167 (quote (module-ref))) (let ((val1168 (chi162 val1160 r1140 w1141 mod1143))) (call-with-values (lambda () (value1162 (cons head1158 tail1159))) (lambda (id1170 mod1171) (build-annotated103 s1142 (list (quote set!) (if mod1171 (make-module-ref (cdr mod1171) id1170 (car mod1171)) (make-module-ref mod1171 id1170 (quote bare))) val1168))))) (build-annotated103 s1142 (cons (chi162 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head1158) r1140 w1141 mod1143) (map (lambda (e1172) (chi162 e1172 r1140 w1141 mod1143)) (append tail1159 (list val1160)))))))))) tmp1156) ((lambda (_1174) (syntax-error (source-wrap155 e1139 w1141 s1142 mod1143))) tmp1144))) (syntax-dispatch tmp1144 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1144 (quote (any any any))))) e1139))) (global-extend124 (quote module-ref) (quote @) (lambda (e1175) ((lambda (tmp1176) ((lambda (tmp1177) (if (if tmp1177 (apply (lambda (_1178 mod1179 id1180) (and (andmap id?126 mod1179) (id?126 id1180))) tmp1177) #f) (apply (lambda (_1182 mod1183 id1184) (values (syntax-object->datum id1184) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod1183)))) tmp1177) (syntax-error tmp1176))) (syntax-dispatch tmp1176 (quote (any each-any any))))) e1175))) (global-extend124 (quote module-ref) (quote @@) (lambda (e1186) ((lambda (tmp1187) ((lambda (tmp1188) (if (if tmp1188 (apply (lambda (_1189 mod1190 id1191) (and (andmap id?126 mod1190) (id?126 id1191))) tmp1188) #f) (apply (lambda (_1193 mod1194 id1195) (values (syntax-object->datum id1195) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod1194)))) tmp1188) (syntax-error tmp1187))) (syntax-dispatch tmp1187 (quote (any each-any any))))) e1186))) (global-extend124 (quote begin) (quote begin) (quote ())) (global-extend124 (quote define) (quote define) (quote ())) (global-extend124 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend124 (quote eval-when) (quote eval-when) (quote ())) (global-extend124 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1200 (lambda (x1201 keys1202 clauses1203 r1204 mod1205) (if (null? clauses1203) (build-annotated103 #f (list (build-annotated103 #f (quote syntax-error)) x1201)) ((lambda (tmp1206) ((lambda (tmp1207) (if tmp1207 (apply (lambda (pat1208 exp1209) (if (and (id?126 pat1208) (andmap (lambda (x1210) (not (free-id=?149 pat1208 x1210))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys1202))) (let ((labels1211 (list (gen-label131))) (var1212 (gen-var174 pat1208))) (build-annotated103 #f (list (build-annotated103 #f (list (quote lambda) (list var1212) (chi162 exp1209 (extend-env120 labels1211 (list (cons (quote syntax) (cons var1212 0))) r1204) (make-binding-wrap143 (list pat1208) labels1211 (quote (()))) mod1205))) x1201))) (gen-clause1199 x1201 keys1202 (cdr clauses1203) r1204 pat1208 #t exp1209 mod1205))) tmp1207) ((lambda (tmp1213) (if tmp1213 (apply (lambda (pat1214 fender1215 exp1216) (gen-clause1199 x1201 keys1202 (cdr clauses1203) r1204 pat1214 fender1215 exp1216 mod1205)) tmp1213) ((lambda (_1217) (syntax-error (car clauses1203) "invalid syntax-case clause")) tmp1206))) (syntax-dispatch tmp1206 (quote (any any any)))))) (syntax-dispatch tmp1206 (quote (any any))))) (car clauses1203))))) (gen-clause1199 (lambda (x1218 keys1219 clauses1220 r1221 pat1222 fender1223 exp1224 mod1225) (call-with-values (lambda () (convert-pattern1197 pat1222 keys1219)) (lambda (p1226 pvars1227) (cond ((not (distinct-bound-ids?152 (map car pvars1227))) (syntax-error pat1222 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x1228) (not (ellipsis?171 (car x1228)))) pvars1227)) (syntax-error pat1222 "misplaced ellipsis in syntax-case pattern")) (else (let ((y1229 (gen-var174 (quote tmp)))) (build-annotated103 #f (list (build-annotated103 #f (list (quote lambda) (list y1229) (let ((y1230 (build-annotated103 #f y1229))) (build-annotated103 #f (list (quote if) ((lambda (tmp1231) ((lambda (tmp1232) (if tmp1232 (apply (lambda () y1230) tmp1232) ((lambda (_1233) (build-annotated103 #f (list (quote if) y1230 (build-dispatch-call1198 pvars1227 fender1223 y1230 r1221 mod1225) (build-data104 #f #f)))) tmp1231))) (syntax-dispatch tmp1231 (quote #(atom #t))))) fender1223) (build-dispatch-call1198 pvars1227 exp1224 y1230 r1221 mod1225) (gen-syntax-case1200 x1218 keys1219 clauses1220 r1221 mod1225)))))) (if (eq? p1226 (quote any)) (build-annotated103 #f (list (build-annotated103 #f (quote list)) x1218)) (build-annotated103 #f (list (build-annotated103 #f (quote syntax-dispatch)) x1218 (build-data104 #f p1226))))))))))))) (build-dispatch-call1198 (lambda (pvars1234 exp1235 y1236 r1237 mod1238) (let ((ids1239 (map car pvars1234)) (levels1240 (map cdr pvars1234))) (let ((labels1241 (gen-labels132 ids1239)) (new-vars1242 (map gen-var174 ids1239))) (build-annotated103 #f (list (build-annotated103 #f (quote apply)) (build-annotated103 #f (list (quote lambda) new-vars1242 (chi162 exp1235 (extend-env120 labels1241 (map (lambda (var1243 level1244) (cons (quote syntax) (cons var1243 level1244))) new-vars1242 (map cdr pvars1234)) r1237) (make-binding-wrap143 ids1239 labels1241 (quote (()))) mod1238))) y1236)))))) (convert-pattern1197 (lambda (pattern1245 keys1246) (let cvt1247 ((p1248 pattern1245) (n1249 0) (ids1250 (quote ()))) (if (id?126 p1248) (if (bound-id-member?153 p1248 keys1246) (values (vector (quote free-id) p1248) ids1250) (values (quote any) (cons (cons p1248 n1249) ids1250))) ((lambda (tmp1251) ((lambda (tmp1252) (if (if tmp1252 (apply (lambda (x1253 dots1254) (ellipsis?171 dots1254)) tmp1252) #f) (apply (lambda (x1255 dots1256) (call-with-values (lambda () (cvt1247 x1255 (fx+93 n1249 1) ids1250)) (lambda (p1257 ids1258) (values (if (eq? p1257 (quote any)) (quote each-any) (vector (quote each) p1257)) ids1258)))) tmp1252) ((lambda (tmp1259) (if tmp1259 (apply (lambda (x1260 y1261) (call-with-values (lambda () (cvt1247 y1261 n1249 ids1250)) (lambda (y1262 ids1263) (call-with-values (lambda () (cvt1247 x1260 n1249 ids1263)) (lambda (x1264 ids1265) (values (cons x1264 y1262) ids1265)))))) tmp1259) ((lambda (tmp1266) (if tmp1266 (apply (lambda () (values (quote ()) ids1250)) tmp1266) ((lambda (tmp1267) (if tmp1267 (apply (lambda (x1268) (call-with-values (lambda () (cvt1247 x1268 n1249 ids1250)) (lambda (p1270 ids1271) (values (vector (quote vector) p1270) ids1271)))) tmp1267) ((lambda (x1272) (values (vector (quote atom) (strip173 p1248 (quote (())))) ids1250)) tmp1251))) (syntax-dispatch tmp1251 (quote #(vector each-any)))))) (syntax-dispatch tmp1251 (quote ()))))) (syntax-dispatch tmp1251 (quote (any . any)))))) (syntax-dispatch tmp1251 (quote (any any))))) p1248)))))) (lambda (e1273 r1274 w1275 s1276 mod1277) (let ((e1278 (source-wrap155 e1273 w1275 s1276 mod1277))) ((lambda (tmp1279) ((lambda (tmp1280) (if tmp1280 (apply (lambda (_1281 val1282 key1283 m1284) (if (andmap (lambda (x1285) (and (id?126 x1285) (not (ellipsis?171 x1285)))) key1283) (let ((x1287 (gen-var174 (quote tmp)))) (build-annotated103 s1276 (list (build-annotated103 #f (list (quote lambda) (list x1287) (gen-syntax-case1200 (build-annotated103 #f x1287) key1283 m1284 r1274 mod1277))) (chi162 val1282 r1274 (quote (())) mod1277)))) (syntax-error e1278 "invalid literals list in"))) tmp1280) (syntax-error tmp1279))) (syntax-dispatch tmp1279 (quote (any any each-any . each-any))))) e1278))))) (set! sc-expand (let ((m1290 (quote e)) (esew1291 (quote (eval)))) (lambda (x1292) (if (and (pair? x1292) (equal? (car x1292) noexpand92)) (cadr x1292) (chi-top161 x1292 (quote ()) (quote ((top))) m1290 esew1291 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m1293 (quote e)) (esew1294 (quote (eval)))) (lambda (x1296 . rest1295) (if (and (pair? x1296) (equal? (car x1296) noexpand92)) (cadr x1296) (chi-top161 x1296 (quote ()) (quote ((top))) (if (null? rest1295) m1293 (car rest1295)) (if (or (null? rest1295) (null? (cdr rest1295))) esew1294 (cadr rest1295)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x1297) (nonsymbol-id?125 x1297))) (set! datum->syntax-object (lambda (id1298 datum1299) (make-syntax-object109 datum1299 (syntax-object-wrap112 id1298) #f))) (set! syntax-object->datum (lambda (x1300) (strip173 x1300 (quote (()))))) (set! generate-temporaries (lambda (ls1301) (begin (let ((x1302 ls1301)) (if (not (list? x1302)) (error-hook99 (quote generate-temporaries) "invalid argument" x1302))) (map (lambda (x1303) (wrap154 (gensym) (quote ((top))) #f)) ls1301)))) (set! free-identifier=? (lambda (x1304 y1305) (begin (let ((x1306 x1304)) (if (not (nonsymbol-id?125 x1306)) (error-hook99 (quote free-identifier=?) "invalid argument" x1306))) (let ((x1307 y1305)) (if (not (nonsymbol-id?125 x1307)) (error-hook99 (quote free-identifier=?) "invalid argument" x1307))) (free-id=?149 x1304 y1305)))) (set! bound-identifier=? (lambda (x1308 y1309) (begin (let ((x1310 x1308)) (if (not (nonsymbol-id?125 x1310)) (error-hook99 (quote bound-identifier=?) "invalid argument" x1310))) (let ((x1311 y1309)) (if (not (nonsymbol-id?125 x1311)) (error-hook99 (quote bound-identifier=?) "invalid argument" x1311))) (bound-id=?150 x1308 y1309)))) (set! syntax-error (lambda (object1313 . messages1312) (begin (for-each (lambda (x1314) (let ((x1315 x1314)) (if (not (string? x1315)) (error-hook99 (quote syntax-error) "invalid argument" x1315)))) messages1312) (let ((message1316 (if (null? messages1312) "invalid syntax" (apply string-append messages1312)))) (error-hook99 #f message1316 (strip173 object1313 (quote (())))))))) (set! install-global-transformer (lambda (sym1317 v1318) (begin (let ((x1319 sym1317)) (if (not (symbol? x1319)) (error-hook99 (quote define-syntax) "invalid argument" x1319))) (let ((x1320 v1318)) (if (not (procedure? x1320)) (error-hook99 (quote define-syntax) "invalid argument" x1320))) (global-extend124 (quote macro) sym1317 v1318)))) (letrec ((match1325 (lambda (e1326 p1327 w1328 r1329 mod1330) (cond ((not r1329) #f) ((eq? p1327 (quote any)) (cons (wrap154 e1326 w1328 mod1330) r1329)) ((syntax-object?110 e1326) (match*1324 (let ((e1331 (syntax-object-expression111 e1326))) (if (annotation? e1331) (annotation-expression e1331) e1331)) p1327 (join-wraps145 w1328 (syntax-object-wrap112 e1326)) r1329 (syntax-object-module113 e1326))) (else (match*1324 (let ((e1332 e1326)) (if (annotation? e1332) (annotation-expression e1332) e1332)) p1327 w1328 r1329 mod1330))))) (match*1324 (lambda (e1333 p1334 w1335 r1336 mod1337) (cond ((null? p1334) (and (null? e1333) r1336)) ((pair? p1334) (and (pair? e1333) (match1325 (car e1333) (car p1334) w1335 (match1325 (cdr e1333) (cdr p1334) w1335 r1336 mod1337) mod1337))) ((eq? p1334 (quote each-any)) (let ((l1338 (match-each-any1322 e1333 w1335 mod1337))) (and l1338 (cons l1338 r1336)))) (else (let ((t1339 (vector-ref p1334 0))) (if (memv t1339 (quote (each))) (if (null? e1333) (match-empty1323 (vector-ref p1334 1) r1336) (let ((l1340 (match-each1321 e1333 (vector-ref p1334 1) w1335 mod1337))) (and l1340 (let collect1341 ((l1342 l1340)) (if (null? (car l1342)) r1336 (cons (map car l1342) (collect1341 (map cdr l1342)))))))) (if (memv t1339 (quote (free-id))) (and (id?126 e1333) (free-id=?149 (wrap154 e1333 w1335 mod1337) (vector-ref p1334 1)) r1336) (if (memv t1339 (quote (atom))) (and (equal? (vector-ref p1334 1) (strip173 e1333 w1335)) r1336) (if (memv t1339 (quote (vector))) (and (vector? e1333) (match1325 (vector->list e1333) (vector-ref p1334 1) w1335 r1336 mod1337))))))))))) (match-empty1323 (lambda (p1343 r1344) (cond ((null? p1343) r1344) ((eq? p1343 (quote any)) (cons (quote ()) r1344)) ((pair? p1343) (match-empty1323 (car p1343) (match-empty1323 (cdr p1343) r1344))) ((eq? p1343 (quote each-any)) (cons (quote ()) r1344)) (else (let ((t1345 (vector-ref p1343 0))) (if (memv t1345 (quote (each))) (match-empty1323 (vector-ref p1343 1) r1344) (if (memv t1345 (quote (free-id atom))) r1344 (if (memv t1345 (quote (vector))) (match-empty1323 (vector-ref p1343 1) r1344))))))))) (match-each-any1322 (lambda (e1346 w1347 mod1348) (cond ((annotation? e1346) (match-each-any1322 (annotation-expression e1346) w1347 mod1348)) ((pair? e1346) (let ((l1349 (match-each-any1322 (cdr e1346) w1347 mod1348))) (and l1349 (cons (wrap154 (car e1346) w1347 mod1348) l1349)))) ((null? e1346) (quote ())) ((syntax-object?110 e1346) (match-each-any1322 (syntax-object-expression111 e1346) (join-wraps145 w1347 (syntax-object-wrap112 e1346)) mod1348)) (else #f)))) (match-each1321 (lambda (e1350 p1351 w1352 mod1353) (cond ((annotation? e1350) (match-each1321 (annotation-expression e1350) p1351 w1352 mod1353)) ((pair? e1350) (let ((first1354 (match1325 (car e1350) p1351 w1352 (quote ()) mod1353))) (and first1354 (let ((rest1355 (match-each1321 (cdr e1350) p1351 w1352 mod1353))) (and rest1355 (cons first1354 rest1355)))))) ((null? e1350) (quote ())) ((syntax-object?110 e1350) (match-each1321 (syntax-object-expression111 e1350) p1351 (join-wraps145 w1352 (syntax-object-wrap112 e1350)) (syntax-object-module113 e1350))) (else #f))))) (begin (set! syntax-dispatch (lambda (e1356 p1357) (cond ((eq? p1357 (quote any)) (list e1356)) ((syntax-object?110 e1356) (match*1324 (let ((e1358 (syntax-object-expression111 e1356))) (if (annotation? e1358) (annotation-expression e1358) e1358)) p1357 (syntax-object-wrap112 e1356) (quote ()) (syntax-object-module113 e1356))) (else (match*1324 (let ((e1359 e1356)) (if (annotation? e1359) (annotation-expression e1359) e1359)) p1357 (quote (())) (quote ()) #f))))) (set! sc-chi chi162))))) -(install-global-transformer (quote with-syntax) (lambda (x1360) ((lambda (tmp1361) ((lambda (tmp1362) (if tmp1362 (apply (lambda (_1363 e11364 e21365) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11364 e21365))) tmp1362) ((lambda (tmp1367) (if tmp1367 (apply (lambda (_1368 out1369 in1370 e11371 e21372) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1370 (quote ()) (list out1369 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11371 e21372))))) tmp1367) ((lambda (tmp1374) (if tmp1374 (apply (lambda (_1375 out1376 in1377 e11378 e21379) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1377) (quote ()) (list out1376 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11378 e21379))))) tmp1374) (syntax-error tmp1361))) (syntax-dispatch tmp1361 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1361 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1361 (quote (any () any . each-any))))) x1360))) -(install-global-transformer (quote syntax-rules) (lambda (x1383) ((lambda (tmp1384) ((lambda (tmp1385) (if tmp1385 (apply (lambda (_1386 k1387 keyword1388 pattern1389 template1390) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1387 (map (lambda (tmp1393 tmp1392) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1392) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1393))) template1390 pattern1389)))))) tmp1385) (syntax-error tmp1384))) (syntax-dispatch tmp1384 (quote (any each-any . #(each ((any . any) any))))))) x1383))) -(install-global-transformer (quote let*) (lambda (x1394) ((lambda (tmp1395) ((lambda (tmp1396) (if (if tmp1396 (apply (lambda (let*1397 x1398 v1399 e11400 e21401) (andmap identifier? x1398)) tmp1396) #f) (apply (lambda (let*1403 x1404 v1405 e11406 e21407) (let f1408 ((bindings1409 (map list x1404 v1405))) (if (null? bindings1409) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11406 e21407))) ((lambda (tmp1413) ((lambda (tmp1414) (if tmp1414 (apply (lambda (body1415 binding1416) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1416) body1415)) tmp1414) (syntax-error tmp1413))) (syntax-dispatch tmp1413 (quote (any any))))) (list (f1408 (cdr bindings1409)) (car bindings1409)))))) tmp1396) (syntax-error tmp1395))) (syntax-dispatch tmp1395 (quote (any #(each (any any)) any . each-any))))) x1394))) -(install-global-transformer (quote do) (lambda (orig-x1417) ((lambda (tmp1418) ((lambda (tmp1419) (if tmp1419 (apply (lambda (_1420 var1421 init1422 step1423 e01424 e11425 c1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (step1429) ((lambda (tmp1430) ((lambda (tmp1431) (if tmp1431 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1421 init1422) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01424) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1426 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1429))))))) tmp1431) ((lambda (tmp1436) (if tmp1436 (apply (lambda (e11437 e21438) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1421 init1422) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01424 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11437 e21438)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1426 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1429))))))) tmp1436) (syntax-error tmp1430))) (syntax-dispatch tmp1430 (quote (any . each-any)))))) (syntax-dispatch tmp1430 (quote ())))) e11425)) tmp1428) (syntax-error tmp1427))) (syntax-dispatch tmp1427 (quote each-any)))) (map (lambda (v1445 s1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda () v1445) tmp1448) ((lambda (tmp1449) (if tmp1449 (apply (lambda (e1450) e1450) tmp1449) ((lambda (_1451) (syntax-error orig-x1417)) tmp1447))) (syntax-dispatch tmp1447 (quote (any)))))) (syntax-dispatch tmp1447 (quote ())))) s1446)) var1421 step1423))) tmp1419) (syntax-error tmp1418))) (syntax-dispatch tmp1418 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1417))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons1454 (lambda (x1458 y1459) ((lambda (tmp1460) ((lambda (tmp1461) (if tmp1461 (apply (lambda (x1462 y1463) ((lambda (tmp1464) ((lambda (tmp1465) (if tmp1465 (apply (lambda (dy1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda (dx1469) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1469 dy1466))) tmp1468) ((lambda (_1470) (if (null? dy1466) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462 y1463))) tmp1467))) (syntax-dispatch tmp1467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1462)) tmp1465) ((lambda (tmp1471) (if tmp1471 (apply (lambda (stuff1472) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1462 stuff1472))) tmp1471) ((lambda (else1473) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462 y1463)) tmp1464))) (syntax-dispatch tmp1464 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp1464 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1463)) tmp1461) (syntax-error tmp1460))) (syntax-dispatch tmp1460 (quote (any any))))) (list x1458 y1459)))) (quasiappend1455 (lambda (x1474 y1475) ((lambda (tmp1476) ((lambda (tmp1477) (if tmp1477 (apply (lambda (x1478 y1479) ((lambda (tmp1480) ((lambda (tmp1481) (if tmp1481 (apply (lambda () x1478) tmp1481) ((lambda (_1482) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1478 y1479)) tmp1480))) (syntax-dispatch tmp1480 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1479)) tmp1477) (syntax-error tmp1476))) (syntax-dispatch tmp1476 (quote (any any))))) (list x1474 y1475)))) (quasivector1456 (lambda (x1483) ((lambda (tmp1484) ((lambda (x1485) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (x1488) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1488))) tmp1487) ((lambda (tmp1490) (if tmp1490 (apply (lambda (x1491) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1491)) tmp1490) ((lambda (_1493) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1485)) tmp1486))) (syntax-dispatch tmp1486 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp1486 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1485)) tmp1484)) x1483))) (quasi1457 (lambda (p1494 lev1495) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (p1498) (if (= lev1495 0) p1498 (quasicons1454 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1457 (list p1498) (- lev1495 1))))) tmp1497) ((lambda (tmp1499) (if tmp1499 (apply (lambda (p1500 q1501) (if (= lev1495 0) (quasiappend1455 p1500 (quasi1457 q1501 lev1495)) (quasicons1454 (quasicons1454 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1457 (list p1500) (- lev1495 1))) (quasi1457 q1501 lev1495)))) tmp1499) ((lambda (tmp1502) (if tmp1502 (apply (lambda (p1503) (quasicons1454 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1457 (list p1503) (+ lev1495 1)))) tmp1502) ((lambda (tmp1504) (if tmp1504 (apply (lambda (p1505 q1506) (quasicons1454 (quasi1457 p1505 lev1495) (quasi1457 q1506 lev1495))) tmp1504) ((lambda (tmp1507) (if tmp1507 (apply (lambda (x1508) (quasivector1456 (quasi1457 x1508 lev1495))) tmp1507) ((lambda (p1510) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1510)) tmp1496))) (syntax-dispatch tmp1496 (quote #(vector each-any)))))) (syntax-dispatch tmp1496 (quote (any . any)))))) (syntax-dispatch tmp1496 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp1496 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp1496 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1494)))) (lambda (x1511) ((lambda (tmp1512) ((lambda (tmp1513) (if tmp1513 (apply (lambda (_1514 e1515) (quasi1457 e1515 0)) tmp1513) (syntax-error tmp1512))) (syntax-dispatch tmp1512 (quote (any any))))) x1511)))) -(install-global-transformer (quote include) (lambda (x1516) (letrec ((read-file1517 (lambda (fn1518 k1519) (let ((p1520 (open-input-file fn1518))) (let f1521 ((x1522 (read p1520))) (if (eof-object? x1522) (begin (close-input-port p1520) (quote ())) (cons (datum->syntax-object k1519 x1522) (f1521 (read p1520))))))))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (k1525 filename1526) (let ((fn1527 (syntax-object->datum filename1526))) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (exp1530) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1530)) tmp1529) (syntax-error tmp1528))) (syntax-dispatch tmp1528 (quote each-any)))) (read-file1517 fn1527 k1525)))) tmp1524) (syntax-error tmp1523))) (syntax-dispatch tmp1523 (quote (any any))))) x1516)))) -(install-global-transformer (quote unquote) (lambda (x1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (_1535 e1536) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e1536))) tmp1534) (syntax-error tmp1533))) (syntax-dispatch tmp1533 (quote (any any))))) x1532))) -(install-global-transformer (quote unquote-splicing) (lambda (x1537) ((lambda (tmp1538) ((lambda (tmp1539) (if tmp1539 (apply (lambda (_1540 e1541) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e1541))) tmp1539) (syntax-error tmp1538))) (syntax-dispatch tmp1538 (quote (any any))))) x1537))) -(install-global-transformer (quote case) (lambda (x1542) ((lambda (tmp1543) ((lambda (tmp1544) (if tmp1544 (apply (lambda (_1545 e1546 m11547 m21548) ((lambda (tmp1549) ((lambda (body1550) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1546)) body1550)) tmp1549)) (let f1551 ((clause1552 m11547) (clauses1553 m21548)) (if (null? clauses1553) ((lambda (tmp1555) ((lambda (tmp1556) (if tmp1556 (apply (lambda (e11557 e21558) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11557 e21558))) tmp1556) ((lambda (tmp1560) (if tmp1560 (apply (lambda (k1561 e11562 e21563) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1561)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11562 e21563)))) tmp1560) ((lambda (_1566) (syntax-error x1542)) tmp1555))) (syntax-dispatch tmp1555 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1555 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1552) ((lambda (tmp1567) ((lambda (rest1568) ((lambda (tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (k1571 e11572 e21573) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1571)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11572 e21573)) rest1568)) tmp1570) ((lambda (_1576) (syntax-error x1542)) tmp1569))) (syntax-dispatch tmp1569 (quote (each-any any . each-any))))) clause1552)) tmp1567)) (f1551 (car clauses1553) (cdr clauses1553))))))) tmp1544) (syntax-error tmp1543))) (syntax-dispatch tmp1543 (quote (any any any . each-any))))) x1542))) -(install-global-transformer (quote identifier-syntax) (lambda (x1577) ((lambda (tmp1578) ((lambda (tmp1579) (if tmp1579 (apply (lambda (_1580 e1581) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1581)) (list (cons _1580 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1581 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1579) (syntax-error tmp1578))) (syntax-dispatch tmp1578 (quote (any any))))) x1577))) +(letrec ((lambda-var-list1165 (lambda (vars1370) (let lvl1371 ((vars1372 vars1370) (ls1373 (quote ())) (w1374 (quote (())))) (cond ((pair? vars1372) (lvl1371 (cdr vars1372) (cons (wrap1144 (car vars1372) w1374 #f) ls1373) w1374)) ((id?1116 vars1372) (cons (wrap1144 vars1372 w1374 #f) ls1373)) ((null? vars1372) ls1373) ((syntax-object?1100 vars1372) (lvl1371 (syntax-object-expression1101 vars1372) ls1373 (join-wraps1135 w1374 (syntax-object-wrap1102 vars1372)))) ((annotation? vars1372) (lvl1371 (annotation-expression vars1372) ls1373 w1374)) (else (cons vars1372 ls1373)))))) (gen-var1164 (lambda (id1375) (let ((id1376 (if (syntax-object?1100 id1375) (syntax-object-expression1101 id1375) id1375))) (if (annotation? id1376) (build-annotated1093 (annotation-source id1376) (gensym (symbol->string (annotation-expression id1376)))) (build-annotated1093 #f (gensym (symbol->string id1376))))))) (strip1163 (lambda (x1377 w1378) (if (memq (quote top) (wrap-marks1119 w1378)) (if (or (annotation? x1377) (and (pair? x1377) (annotation? (car x1377)))) (strip-annotation1162 x1377 #f) x1377) (let f1379 ((x1380 x1377)) (cond ((syntax-object?1100 x1380) (strip1163 (syntax-object-expression1101 x1380) (syntax-object-wrap1102 x1380))) ((pair? x1380) (let ((a1381 (f1379 (car x1380))) (d1382 (f1379 (cdr x1380)))) (if (and (eq? a1381 (car x1380)) (eq? d1382 (cdr x1380))) x1380 (cons a1381 d1382)))) ((vector? x1380) (let ((old1383 (vector->list x1380))) (let ((new1384 (map f1379 old1383))) (if (andmap eq? old1383 new1384) x1380 (list->vector new1384))))) (else x1380)))))) (strip-annotation1162 (lambda (x1385 parent1386) (cond ((pair? x1385) (let ((new1387 (cons #f #f))) (begin (if parent1386 (set-annotation-stripped! parent1386 new1387)) (set-car! new1387 (strip-annotation1162 (car x1385) #f)) (set-cdr! new1387 (strip-annotation1162 (cdr x1385) #f)) new1387))) ((annotation? x1385) (or (annotation-stripped x1385) (strip-annotation1162 (annotation-expression x1385) x1385))) ((vector? x1385) (let ((new1388 (make-vector (vector-length x1385)))) (begin (if parent1386 (set-annotation-stripped! parent1386 new1388)) (let loop1389 ((i1390 (- (vector-length x1385) 1))) (unless (fx<1086 i1390 0) (vector-set! new1388 i1390 (strip-annotation1162 (vector-ref x1385 i1390) #f)) (loop1389 (fx-1084 i1390 1)))) new1388))) (else x1385)))) (ellipsis?1161 (lambda (x1391) (and (nonsymbol-id?1115 x1391) (free-id=?1139 x1391 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1160 (lambda () (build-annotated1093 #f (list (build-annotated1093 #f (quote void)))))) (eval-local-transformer1159 (lambda (expanded1392 mod1393) (let ((p1394 (local-eval-hook1088 expanded1392 mod1393))) (if (procedure? p1394) p1394 (syntax-error p1394 "nonprocedure transformer"))))) (chi-local-syntax1158 (lambda (rec?1395 e1396 r1397 w1398 s1399 mod1400 k1401) ((lambda (tmp1402) ((lambda (tmp1403) (if tmp1403 (apply (lambda (_1404 id1405 val1406 e11407 e21408) (let ((ids1409 id1405)) (if (not (valid-bound-ids?1141 ids1409)) (syntax-error e1396 "duplicate bound keyword in") (let ((labels1411 (gen-labels1122 ids1409))) (let ((new-w1412 (make-binding-wrap1133 ids1409 labels1411 w1398))) (k1401 (cons e11407 e21408) (extend-env1110 labels1411 (let ((w1414 (if rec?1395 new-w1412 w1398)) (trans-r1415 (macros-only-env1112 r1397))) (map (lambda (x1416) (cons (quote macro) (eval-local-transformer1159 (chi1152 x1416 trans-r1415 w1414 mod1400) mod1400))) val1406)) r1397) new-w1412 s1399 mod1400)))))) tmp1403) ((lambda (_1418) (syntax-error (source-wrap1145 e1396 w1398 s1399 mod1400))) tmp1402))) (syntax-dispatch tmp1402 (quote (any #(each (any any)) any . each-any))))) e1396))) (chi-lambda-clause1157 (lambda (e1419 docstring1420 c1421 r1422 w1423 mod1424 k1425) ((lambda (tmp1426) ((lambda (tmp1427) (if (if tmp1427 (apply (lambda (args1428 doc1429 e11430 e21431) (and (string? (syntax-object->datum doc1429)) (not docstring1420))) tmp1427) #f) (apply (lambda (args1432 doc1433 e11434 e21435) (chi-lambda-clause1157 e1419 doc1433 (cons args1432 (cons e11434 e21435)) r1422 w1423 mod1424 k1425)) tmp1427) ((lambda (tmp1437) (if tmp1437 (apply (lambda (id1438 e11439 e21440) (let ((ids1441 id1438)) (if (not (valid-bound-ids?1141 ids1441)) (syntax-error e1419 "invalid parameter list in") (let ((labels1443 (gen-labels1122 ids1441)) (new-vars1444 (map gen-var1164 ids1441))) (k1425 new-vars1444 docstring1420 (chi-body1156 (cons e11439 e21440) e1419 (extend-var-env1111 labels1443 new-vars1444 r1422) (make-binding-wrap1133 ids1441 labels1443 w1423) mod1424)))))) tmp1437) ((lambda (tmp1446) (if tmp1446 (apply (lambda (ids1447 e11448 e21449) (let ((old-ids1450 (lambda-var-list1165 ids1447))) (if (not (valid-bound-ids?1141 old-ids1450)) (syntax-error e1419 "invalid parameter list in") (let ((labels1451 (gen-labels1122 old-ids1450)) (new-vars1452 (map gen-var1164 old-ids1450))) (k1425 (let f1453 ((ls11454 (cdr new-vars1452)) (ls21455 (car new-vars1452))) (if (null? ls11454) ls21455 (f1453 (cdr ls11454) (cons (car ls11454) ls21455)))) docstring1420 (chi-body1156 (cons e11448 e21449) e1419 (extend-var-env1111 labels1451 new-vars1452 r1422) (make-binding-wrap1133 old-ids1450 labels1451 w1423) mod1424)))))) tmp1446) ((lambda (_1457) (syntax-error e1419)) tmp1426))) (syntax-dispatch tmp1426 (quote (any any . each-any)))))) (syntax-dispatch tmp1426 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1426 (quote (any any any . each-any))))) c1421))) (chi-body1156 (lambda (body1458 outer-form1459 r1460 w1461 mod1462) (let ((r1463 (cons (quote ("placeholder" placeholder)) r1460))) (let ((ribcage1464 (make-ribcage1123 (quote ()) (quote ()) (quote ())))) (let ((w1465 (make-wrap1118 (wrap-marks1119 w1461) (cons ribcage1464 (wrap-subst1120 w1461))))) (let parse1466 ((body1467 (map (lambda (x1473) (cons r1463 (wrap1144 x1473 w1465 mod1462))) body1458)) (ids1468 (quote ())) (labels1469 (quote ())) (vars1470 (quote ())) (vals1471 (quote ())) (bindings1472 (quote ()))) (if (null? body1467) (syntax-error outer-form1459 "no expressions in body") (let ((e1474 (cdar body1467)) (er1475 (caar body1467))) (call-with-values (lambda () (syntax-type1150 e1474 er1475 (quote (())) #f ribcage1464 mod1462)) (lambda (type1476 value1477 e1478 w1479 s1480 mod1481) (let ((t1482 type1476)) (if (memv t1482 (quote (define-form))) (let ((id1483 (wrap1144 value1477 w1479 mod1481)) (label1484 (gen-label1121))) (let ((var1485 (gen-var1164 id1483))) (begin (extend-ribcage!1132 ribcage1464 id1483 label1484) (parse1466 (cdr body1467) (cons id1483 ids1468) (cons label1484 labels1469) (cons var1485 vars1470) (cons (cons er1475 (wrap1144 e1478 w1479 mod1481)) vals1471) (cons (cons (quote lexical) var1485) bindings1472))))) (if (memv t1482 (quote (define-syntax-form))) (let ((id1486 (wrap1144 value1477 w1479 mod1481)) (label1487 (gen-label1121))) (begin (extend-ribcage!1132 ribcage1464 id1486 label1487) (parse1466 (cdr body1467) (cons id1486 ids1468) (cons label1487 labels1469) vars1470 vals1471 (cons (cons (quote macro) (cons er1475 (wrap1144 e1478 w1479 mod1481))) bindings1472)))) (if (memv t1482 (quote (begin-form))) ((lambda (tmp1488) ((lambda (tmp1489) (if tmp1489 (apply (lambda (_1490 e11491) (parse1466 (let f1492 ((forms1493 e11491)) (if (null? forms1493) (cdr body1467) (cons (cons er1475 (wrap1144 (car forms1493) w1479 mod1481)) (f1492 (cdr forms1493))))) ids1468 labels1469 vars1470 vals1471 bindings1472)) tmp1489) (syntax-error tmp1488))) (syntax-dispatch tmp1488 (quote (any . each-any))))) e1478) (if (memv t1482 (quote (local-syntax-form))) (chi-local-syntax1158 value1477 e1478 er1475 w1479 s1480 mod1481 (lambda (forms1495 er1496 w1497 s1498 mod1499) (parse1466 (let f1500 ((forms1501 forms1495)) (if (null? forms1501) (cdr body1467) (cons (cons er1496 (wrap1144 (car forms1501) w1497 mod1499)) (f1500 (cdr forms1501))))) ids1468 labels1469 vars1470 vals1471 bindings1472))) (if (null? ids1468) (build-sequence1095 #f (map (lambda (x1502) (chi1152 (cdr x1502) (car x1502) (quote (())) mod1481)) (cons (cons er1475 (source-wrap1145 e1478 w1479 s1480 mod1481)) (cdr body1467)))) (begin (if (not (valid-bound-ids?1141 ids1468)) (syntax-error outer-form1459 "invalid or duplicate identifier in definition")) (let loop1503 ((bs1504 bindings1472) (er-cache1505 #f) (r-cache1506 #f)) (if (not (null? bs1504)) (let ((b1507 (car bs1504))) (if (eq? (car b1507) (quote macro)) (let ((er1508 (cadr b1507))) (let ((r-cache1509 (if (eq? er1508 er-cache1505) r-cache1506 (macros-only-env1112 er1508)))) (begin (set-cdr! b1507 (eval-local-transformer1159 (chi1152 (cddr b1507) r-cache1509 (quote (())) mod1481) mod1481)) (loop1503 (cdr bs1504) er1508 r-cache1509)))) (loop1503 (cdr bs1504) er-cache1505 r-cache1506))))) (set-cdr! r1463 (extend-env1110 labels1469 bindings1472 (cdr r1463))) (build-letrec1098 #f vars1470 (map (lambda (x1510) (chi1152 (cdr x1510) (car x1510) (quote (())) mod1481)) vals1471) (build-sequence1095 #f (map (lambda (x1511) (chi1152 (cdr x1511) (car x1511) (quote (())) mod1481)) (cons (cons er1475 (source-wrap1145 e1478 w1479 s1480 mod1481)) (cdr body1467)))))))))))))))))))))) (chi-macro1155 (lambda (p1512 e1513 r1514 w1515 rib1516 mod1517) (letrec ((rebuild-macro-output1518 (lambda (x1519 m1520) (cond ((pair? x1519) (cons (rebuild-macro-output1518 (car x1519) m1520) (rebuild-macro-output1518 (cdr x1519) m1520))) ((syntax-object?1100 x1519) (let ((w1521 (syntax-object-wrap1102 x1519))) (let ((ms1522 (wrap-marks1119 w1521)) (s1523 (wrap-subst1120 w1521))) (if (and (pair? ms1522) (eq? (car ms1522) #f)) (make-syntax-object1099 (syntax-object-expression1101 x1519) (make-wrap1118 (cdr ms1522) (if rib1516 (cons rib1516 (cdr s1523)) (cdr s1523))) (syntax-object-module1103 x1519)) (make-syntax-object1099 (syntax-object-expression1101 x1519) (make-wrap1118 (cons m1520 ms1522) (if rib1516 (cons rib1516 (cons (quote shift) s1523)) (cons (quote shift) s1523))) (let ((pmod1524 (procedure-module p1512))) (if pmod1524 (cons (quote hygiene) (module-name pmod1524)) (quote (hygiene guile))))))))) ((vector? x1519) (let ((n1525 (vector-length x1519))) (let ((v1526 (make-vector n1525))) (let doloop1527 ((i1528 0)) (if (fx=1085 i1528 n1525) v1526 (begin (vector-set! v1526 i1528 (rebuild-macro-output1518 (vector-ref x1519 i1528) m1520)) (doloop1527 (fx+1083 i1528 1)))))))) ((symbol? x1519) (syntax-error x1519 "encountered raw symbol in macro output")) (else x1519))))) (rebuild-macro-output1518 (p1512 (wrap1144 e1513 (anti-mark1131 w1515) mod1517)) (string #\m))))) (chi-application1154 (lambda (x1529 e1530 r1531 w1532 s1533 mod1534) ((lambda (tmp1535) ((lambda (tmp1536) (if tmp1536 (apply (lambda (e01537 e11538) (build-annotated1093 s1533 (cons x1529 (map (lambda (e1539) (chi1152 e1539 r1531 w1532 mod1534)) e11538)))) tmp1536) (syntax-error tmp1535))) (syntax-dispatch tmp1535 (quote (any . each-any))))) e1530))) (chi-expr1153 (lambda (type1541 value1542 e1543 r1544 w1545 s1546 mod1547) (let ((t1548 type1541)) (if (memv t1548 (quote (lexical))) (build-annotated1093 s1546 value1542) (if (memv t1548 (quote (core external-macro))) (value1542 e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (module-ref))) (call-with-values (lambda () (value1542 e1543)) (lambda (id1549 mod1550) (build-annotated1093 s1546 (if mod1550 (make-module-ref (cdr mod1550) id1549 (car mod1550)) (make-module-ref mod1550 id1549 (quote bare)))))) (if (memv t1548 (quote (lexical-call))) (chi-application1154 (build-annotated1093 (source-annotation1107 (car e1543)) value1542) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (global-call))) (chi-application1154 (build-annotated1093 (source-annotation1107 (car e1543)) (if (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547) (make-module-ref (cdr (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547)) value1542 (car (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547))) (make-module-ref (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547) value1542 (quote bare)))) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (constant))) (build-data1094 s1546 (strip1163 (source-wrap1145 e1543 w1545 s1546 mod1547) (quote (())))) (if (memv t1548 (quote (global))) (build-annotated1093 s1546 (if mod1547 (make-module-ref (cdr mod1547) value1542 (car mod1547)) (make-module-ref mod1547 value1542 (quote bare)))) (if (memv t1548 (quote (call))) (chi-application1154 (chi1152 (car e1543) r1544 w1545 mod1547) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (begin-form))) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e11554 e21555) (chi-sequence1146 (cons e11554 e21555) r1544 w1545 s1546 mod1547)) tmp1552) (syntax-error tmp1551))) (syntax-dispatch tmp1551 (quote (any any . each-any))))) e1543) (if (memv t1548 (quote (local-syntax-form))) (chi-local-syntax1158 value1542 e1543 r1544 w1545 s1546 mod1547 chi-sequence1146) (if (memv t1548 (quote (eval-when-form))) ((lambda (tmp1557) ((lambda (tmp1558) (if tmp1558 (apply (lambda (_1559 x1560 e11561 e21562) (let ((when-list1563 (chi-when-list1149 e1543 x1560 w1545))) (if (memq (quote eval) when-list1563) (chi-sequence1146 (cons e11561 e21562) r1544 w1545 s1546 mod1547) (chi-void1160)))) tmp1558) (syntax-error tmp1557))) (syntax-dispatch tmp1557 (quote (any each-any any . each-any))))) e1543) (if (memv t1548 (quote (define-form define-syntax-form))) (syntax-error (wrap1144 value1542 w1545 mod1547) "invalid context for definition of") (if (memv t1548 (quote (syntax))) (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547) "reference to pattern variable outside syntax form") (if (memv t1548 (quote (displaced-lexical))) (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547) "reference to identifier outside its scope") (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547))))))))))))))))))) (chi1152 (lambda (e1566 r1567 w1568 mod1569) (call-with-values (lambda () (syntax-type1150 e1566 r1567 w1568 #f #f mod1569)) (lambda (type1570 value1571 e1572 w1573 s1574 mod1575) (chi-expr1153 type1570 value1571 e1572 r1567 w1573 s1574 mod1575))))) (chi-top1151 (lambda (e1576 r1577 w1578 m1579 esew1580 mod1581) (call-with-values (lambda () (syntax-type1150 e1576 r1577 w1578 #f #f mod1581)) (lambda (type1589 value1590 e1591 w1592 s1593 mod1594) (let ((t1595 type1589)) (if (memv t1595 (quote (begin-form))) ((lambda (tmp1596) ((lambda (tmp1597) (if tmp1597 (apply (lambda (_1598) (chi-void1160)) tmp1597) ((lambda (tmp1599) (if tmp1599 (apply (lambda (_1600 e11601 e21602) (chi-top-sequence1147 (cons e11601 e21602) r1577 w1592 s1593 m1579 esew1580 mod1594)) tmp1599) (syntax-error tmp1596))) (syntax-dispatch tmp1596 (quote (any any . each-any)))))) (syntax-dispatch tmp1596 (quote (any))))) e1591) (if (memv t1595 (quote (local-syntax-form))) (chi-local-syntax1158 value1590 e1591 r1577 w1592 s1593 mod1594 (lambda (body1604 r1605 w1606 s1607 mod1608) (chi-top-sequence1147 body1604 r1605 w1606 s1607 m1579 esew1580 mod1608))) (if (memv t1595 (quote (eval-when-form))) ((lambda (tmp1609) ((lambda (tmp1610) (if tmp1610 (apply (lambda (_1611 x1612 e11613 e21614) (let ((when-list1615 (chi-when-list1149 e1591 x1612 w1592)) (body1616 (cons e11613 e21614))) (cond ((eq? m1579 (quote e)) (if (memq (quote eval) when-list1615) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote e) (quote (eval)) mod1594) (chi-void1160))) ((memq (quote load) when-list1615) (if (or (memq (quote compile) when-list1615) (and (eq? m1579 (quote c&e)) (memq (quote eval) when-list1615))) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote c&e) (quote (compile load)) mod1594) (if (memq m1579 (quote (c c&e))) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote c) (quote (load)) mod1594) (chi-void1160)))) ((or (memq (quote compile) when-list1615) (and (eq? m1579 (quote c&e)) (memq (quote eval) when-list1615))) (top-level-eval-hook1087 (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote e) (quote (eval)) mod1594) mod1594) (chi-void1160)) (else (chi-void1160))))) tmp1610) (syntax-error tmp1609))) (syntax-dispatch tmp1609 (quote (any each-any any . each-any))))) e1591) (if (memv t1595 (quote (define-syntax-form))) (let ((n1619 (id-var-name1138 value1590 w1592)) (r1620 (macros-only-env1112 r1577))) (let ((t1621 m1579)) (if (memv t1621 (quote (c))) (if (memq (quote compile) esew1580) (let ((e1622 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)))) (begin (top-level-eval-hook1087 e1622 mod1594) (if (memq (quote load) esew1580) e1622 (chi-void1160)))) (if (memq (quote load) esew1580) (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)) (chi-void1160))) (if (memv t1621 (quote (c&e))) (let ((e1623 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)))) (begin (top-level-eval-hook1087 e1623 mod1594) e1623)) (begin (if (memq (quote eval) esew1580) (top-level-eval-hook1087 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)) mod1594)) (chi-void1160)))))) (if (memv t1595 (quote (define-form))) (let ((n1624 (id-var-name1138 value1590 w1592))) (let ((type1625 (binding-type1108 (lookup1113 n1624 r1577 mod1594)))) (let ((t1626 type1625)) (if (memv t1626 (quote (global))) (let ((x1627 (build-annotated1093 s1593 (list (quote define) n1624 (chi1152 e1591 r1577 w1592 mod1594))))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1627 mod1594)) x1627)) (if (memv t1626 (quote (displaced-lexical))) (syntax-error (wrap1144 value1590 w1592 mod1594) "identifier out of context") (if (memv t1626 (quote (core macro module-ref))) (begin (remove-global-definition-hook1091 n1624) (let ((x1628 (build-annotated1093 s1593 (list (quote define) n1624 (chi1152 e1591 r1577 w1592 mod1594))))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1628 mod1594)) x1628))) (syntax-error (wrap1144 value1590 w1592 mod1594) "cannot define keyword at top level"))))))) (let ((x1629 (chi-expr1153 type1589 value1590 e1591 r1577 w1592 s1593 mod1594))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1629 mod1594)) x1629)))))))))))) (syntax-type1150 (lambda (e1630 r1631 w1632 s1633 rib1634 mod1635) (cond ((symbol? e1630) (let ((n1636 (id-var-name1138 e1630 w1632))) (let ((b1637 (lookup1113 n1636 r1631 mod1635))) (let ((type1638 (binding-type1108 b1637))) (let ((t1639 type1638)) (if (memv t1639 (quote (lexical))) (values type1638 (binding-value1109 b1637) e1630 w1632 s1633 mod1635) (if (memv t1639 (quote (global))) (values type1638 n1636 e1630 w1632 s1633 mod1635) (if (memv t1639 (quote (macro))) (syntax-type1150 (chi-macro1155 (binding-value1109 b1637) e1630 r1631 w1632 rib1634 mod1635) r1631 (quote (())) s1633 rib1634 mod1635) (values type1638 (binding-value1109 b1637) e1630 w1632 s1633 mod1635))))))))) ((pair? e1630) (let ((first1640 (car e1630))) (if (id?1116 first1640) (let ((n1641 (id-var-name1138 first1640 w1632))) (let ((b1642 (lookup1113 n1641 r1631 (or (and (syntax-object?1100 first1640) (syntax-object-module1103 first1640)) mod1635)))) (let ((type1643 (binding-type1108 b1642))) (let ((t1644 type1643)) (if (memv t1644 (quote (lexical))) (values (quote lexical-call) (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (global))) (values (quote global-call) n1641 e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (macro))) (syntax-type1150 (chi-macro1155 (binding-value1109 b1642) e1630 r1631 w1632 rib1634 mod1635) r1631 (quote (())) s1633 rib1634 mod1635) (if (memv t1644 (quote (core external-macro module-ref))) (values type1643 (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (begin))) (values (quote begin-form) #f e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (eval-when))) (values (quote eval-when-form) #f e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (define))) ((lambda (tmp1645) ((lambda (tmp1646) (if (if tmp1646 (apply (lambda (_1647 name1648 val1649) (id?1116 name1648)) tmp1646) #f) (apply (lambda (_1650 name1651 val1652) (values (quote define-form) name1651 val1652 w1632 s1633 mod1635)) tmp1646) ((lambda (tmp1653) (if (if tmp1653 (apply (lambda (_1654 name1655 args1656 e11657 e21658) (and (id?1116 name1655) (valid-bound-ids?1141 (lambda-var-list1165 args1656)))) tmp1653) #f) (apply (lambda (_1659 name1660 args1661 e11662 e21663) (values (quote define-form) (wrap1144 name1660 w1632 mod1635) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1144 (cons args1661 (cons e11662 e21663)) w1632 mod1635)) (quote (())) s1633 mod1635)) tmp1653) ((lambda (tmp1665) (if (if tmp1665 (apply (lambda (_1666 name1667) (id?1116 name1667)) tmp1665) #f) (apply (lambda (_1668 name1669) (values (quote define-form) (wrap1144 name1669 w1632 mod1635) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1633 mod1635)) tmp1665) (syntax-error tmp1645))) (syntax-dispatch tmp1645 (quote (any any)))))) (syntax-dispatch tmp1645 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1645 (quote (any any any))))) e1630) (if (memv t1644 (quote (define-syntax))) ((lambda (tmp1670) ((lambda (tmp1671) (if (if tmp1671 (apply (lambda (_1672 name1673 val1674) (id?1116 name1673)) tmp1671) #f) (apply (lambda (_1675 name1676 val1677) (values (quote define-syntax-form) name1676 val1677 w1632 s1633 mod1635)) tmp1671) (syntax-error tmp1670))) (syntax-dispatch tmp1670 (quote (any any any))))) e1630) (values (quote call) #f e1630 w1632 s1633 mod1635)))))))))))))) (values (quote call) #f e1630 w1632 s1633 mod1635)))) ((syntax-object?1100 e1630) (syntax-type1150 (syntax-object-expression1101 e1630) r1631 (join-wraps1135 w1632 (syntax-object-wrap1102 e1630)) #f rib1634 (or (syntax-object-module1103 e1630) mod1635))) ((annotation? e1630) (syntax-type1150 (annotation-expression e1630) r1631 w1632 (annotation-source e1630) rib1634 mod1635)) ((self-evaluating? e1630) (values (quote constant) #f e1630 w1632 s1633 mod1635)) (else (values (quote other) #f e1630 w1632 s1633 mod1635))))) (chi-when-list1149 (lambda (e1678 when-list1679 w1680) (let f1681 ((when-list1682 when-list1679) (situations1683 (quote ()))) (if (null? when-list1682) situations1683 (f1681 (cdr when-list1682) (cons (let ((x1684 (car when-list1682))) (cond ((free-id=?1139 x1684 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1139 x1684 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1139 x1684 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1144 x1684 w1680 #f) "invalid eval-when situation")))) situations1683)))))) (chi-install-global1148 (lambda (name1685 e1686) (build-annotated1093 #f (list (build-annotated1093 #f (quote install-global-transformer)) (build-data1094 #f name1685) e1686)))) (chi-top-sequence1147 (lambda (body1687 r1688 w1689 s1690 m1691 esew1692 mod1693) (build-sequence1095 s1690 (let dobody1694 ((body1695 body1687) (r1696 r1688) (w1697 w1689) (m1698 m1691) (esew1699 esew1692) (mod1700 mod1693)) (if (null? body1695) (quote ()) (let ((first1701 (chi-top1151 (car body1695) r1696 w1697 m1698 esew1699 mod1700))) (cons first1701 (dobody1694 (cdr body1695) r1696 w1697 m1698 esew1699 mod1700)))))))) (chi-sequence1146 (lambda (body1702 r1703 w1704 s1705 mod1706) (build-sequence1095 s1705 (let dobody1707 ((body1708 body1702) (r1709 r1703) (w1710 w1704) (mod1711 mod1706)) (if (null? body1708) (quote ()) (let ((first1712 (chi1152 (car body1708) r1709 w1710 mod1711))) (cons first1712 (dobody1707 (cdr body1708) r1709 w1710 mod1711)))))))) (source-wrap1145 (lambda (x1713 w1714 s1715 defmod1716) (wrap1144 (if s1715 (make-annotation x1713 s1715 #f) x1713) w1714 defmod1716))) (wrap1144 (lambda (x1717 w1718 defmod1719) (cond ((and (null? (wrap-marks1119 w1718)) (null? (wrap-subst1120 w1718))) x1717) ((syntax-object?1100 x1717) (make-syntax-object1099 (syntax-object-expression1101 x1717) (join-wraps1135 w1718 (syntax-object-wrap1102 x1717)) (syntax-object-module1103 x1717))) ((null? x1717) x1717) (else (make-syntax-object1099 x1717 w1718 defmod1719))))) (bound-id-member?1143 (lambda (x1720 list1721) (and (not (null? list1721)) (or (bound-id=?1140 x1720 (car list1721)) (bound-id-member?1143 x1720 (cdr list1721)))))) (distinct-bound-ids?1142 (lambda (ids1722) (let distinct?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (not (bound-id-member?1143 (car ids1724) (cdr ids1724))) (distinct?1723 (cdr ids1724))))))) (valid-bound-ids?1141 (lambda (ids1725) (and (let all-ids?1726 ((ids1727 ids1725)) (or (null? ids1727) (and (id?1116 (car ids1727)) (all-ids?1726 (cdr ids1727))))) (distinct-bound-ids?1142 ids1725)))) (bound-id=?1140 (lambda (i1728 j1729) (if (and (syntax-object?1100 i1728) (syntax-object?1100 j1729)) (and (eq? (let ((e1730 (syntax-object-expression1101 i1728))) (if (annotation? e1730) (annotation-expression e1730) e1730)) (let ((e1731 (syntax-object-expression1101 j1729))) (if (annotation? e1731) (annotation-expression e1731) e1731))) (same-marks?1137 (wrap-marks1119 (syntax-object-wrap1102 i1728)) (wrap-marks1119 (syntax-object-wrap1102 j1729)))) (eq? (let ((e1732 i1728)) (if (annotation? e1732) (annotation-expression e1732) e1732)) (let ((e1733 j1729)) (if (annotation? e1733) (annotation-expression e1733) e1733)))))) (free-id=?1139 (lambda (i1734 j1735) (and (eq? (let ((x1736 i1734)) (let ((e1737 (if (syntax-object?1100 x1736) (syntax-object-expression1101 x1736) x1736))) (if (annotation? e1737) (annotation-expression e1737) e1737))) (let ((x1738 j1735)) (let ((e1739 (if (syntax-object?1100 x1738) (syntax-object-expression1101 x1738) x1738))) (if (annotation? e1739) (annotation-expression e1739) e1739)))) (eq? (id-var-name1138 i1734 (quote (()))) (id-var-name1138 j1735 (quote (()))))))) (id-var-name1138 (lambda (id1740 w1741) (letrec ((search-vector-rib1744 (lambda (sym1750 subst1751 marks1752 symnames1753 ribcage1754) (let ((n1755 (vector-length symnames1753))) (let f1756 ((i1757 0)) (cond ((fx=1085 i1757 n1755) (search1742 sym1750 (cdr subst1751) marks1752)) ((and (eq? (vector-ref symnames1753 i1757) sym1750) (same-marks?1137 marks1752 (vector-ref (ribcage-marks1126 ribcage1754) i1757))) (values (vector-ref (ribcage-labels1127 ribcage1754) i1757) marks1752)) (else (f1756 (fx+1083 i1757 1)))))))) (search-list-rib1743 (lambda (sym1758 subst1759 marks1760 symnames1761 ribcage1762) (let f1763 ((symnames1764 symnames1761) (i1765 0)) (cond ((null? symnames1764) (search1742 sym1758 (cdr subst1759) marks1760)) ((and (eq? (car symnames1764) sym1758) (same-marks?1137 marks1760 (list-ref (ribcage-marks1126 ribcage1762) i1765))) (values (list-ref (ribcage-labels1127 ribcage1762) i1765) marks1760)) (else (f1763 (cdr symnames1764) (fx+1083 i1765 1))))))) (search1742 (lambda (sym1766 subst1767 marks1768) (if (null? subst1767) (values #f marks1768) (let ((fst1769 (car subst1767))) (if (eq? fst1769 (quote shift)) (search1742 sym1766 (cdr subst1767) (cdr marks1768)) (let ((symnames1770 (ribcage-symnames1125 fst1769))) (if (vector? symnames1770) (search-vector-rib1744 sym1766 subst1767 marks1768 symnames1770 fst1769) (search-list-rib1743 sym1766 subst1767 marks1768 symnames1770 fst1769))))))))) (cond ((symbol? id1740) (or (call-with-values (lambda () (search1742 id1740 (wrap-subst1120 w1741) (wrap-marks1119 w1741))) (lambda (x1772 . ignore1771) x1772)) id1740)) ((syntax-object?1100 id1740) (let ((id1773 (let ((e1775 (syntax-object-expression1101 id1740))) (if (annotation? e1775) (annotation-expression e1775) e1775))) (w11774 (syntax-object-wrap1102 id1740))) (let ((marks1776 (join-marks1136 (wrap-marks1119 w1741) (wrap-marks1119 w11774)))) (call-with-values (lambda () (search1742 id1773 (wrap-subst1120 w1741) marks1776)) (lambda (new-id1777 marks1778) (or new-id1777 (call-with-values (lambda () (search1742 id1773 (wrap-subst1120 w11774) marks1778)) (lambda (x1780 . ignore1779) x1780)) id1773)))))) ((annotation? id1740) (let ((id1781 (let ((e1782 id1740)) (if (annotation? e1782) (annotation-expression e1782) e1782)))) (or (call-with-values (lambda () (search1742 id1781 (wrap-subst1120 w1741) (wrap-marks1119 w1741))) (lambda (x1784 . ignore1783) x1784)) id1781))) (else (error-hook1089 (quote id-var-name) "invalid id" id1740)))))) (same-marks?1137 (lambda (x1785 y1786) (or (eq? x1785 y1786) (and (not (null? x1785)) (not (null? y1786)) (eq? (car x1785) (car y1786)) (same-marks?1137 (cdr x1785) (cdr y1786)))))) (join-marks1136 (lambda (m11787 m21788) (smart-append1134 m11787 m21788))) (join-wraps1135 (lambda (w11789 w21790) (let ((m11791 (wrap-marks1119 w11789)) (s11792 (wrap-subst1120 w11789))) (if (null? m11791) (if (null? s11792) w21790 (make-wrap1118 (wrap-marks1119 w21790) (smart-append1134 s11792 (wrap-subst1120 w21790)))) (make-wrap1118 (smart-append1134 m11791 (wrap-marks1119 w21790)) (smart-append1134 s11792 (wrap-subst1120 w21790))))))) (smart-append1134 (lambda (m11793 m21794) (if (null? m21794) m11793 (append m11793 m21794)))) (make-binding-wrap1133 (lambda (ids1795 labels1796 w1797) (if (null? ids1795) w1797 (make-wrap1118 (wrap-marks1119 w1797) (cons (let ((labelvec1798 (list->vector labels1796))) (let ((n1799 (vector-length labelvec1798))) (let ((symnamevec1800 (make-vector n1799)) (marksvec1801 (make-vector n1799))) (begin (let f1802 ((ids1803 ids1795) (i1804 0)) (if (not (null? ids1803)) (call-with-values (lambda () (id-sym-name&marks1117 (car ids1803) w1797)) (lambda (symname1805 marks1806) (begin (vector-set! symnamevec1800 i1804 symname1805) (vector-set! marksvec1801 i1804 marks1806) (f1802 (cdr ids1803) (fx+1083 i1804 1))))))) (make-ribcage1123 symnamevec1800 marksvec1801 labelvec1798))))) (wrap-subst1120 w1797)))))) (extend-ribcage!1132 (lambda (ribcage1807 id1808 label1809) (begin (set-ribcage-symnames!1128 ribcage1807 (cons (let ((e1810 (syntax-object-expression1101 id1808))) (if (annotation? e1810) (annotation-expression e1810) e1810)) (ribcage-symnames1125 ribcage1807))) (set-ribcage-marks!1129 ribcage1807 (cons (wrap-marks1119 (syntax-object-wrap1102 id1808)) (ribcage-marks1126 ribcage1807))) (set-ribcage-labels!1130 ribcage1807 (cons label1809 (ribcage-labels1127 ribcage1807)))))) (anti-mark1131 (lambda (w1811) (make-wrap1118 (cons #f (wrap-marks1119 w1811)) (cons (quote shift) (wrap-subst1120 w1811))))) (set-ribcage-labels!1130 (lambda (x1812 update1813) (vector-set! x1812 3 update1813))) (set-ribcage-marks!1129 (lambda (x1814 update1815) (vector-set! x1814 2 update1815))) (set-ribcage-symnames!1128 (lambda (x1816 update1817) (vector-set! x1816 1 update1817))) (ribcage-labels1127 (lambda (x1818) (vector-ref x1818 3))) (ribcage-marks1126 (lambda (x1819) (vector-ref x1819 2))) (ribcage-symnames1125 (lambda (x1820) (vector-ref x1820 1))) (ribcage?1124 (lambda (x1821) (and (vector? x1821) (= (vector-length x1821) 4) (eq? (vector-ref x1821 0) (quote ribcage))))) (make-ribcage1123 (lambda (symnames1822 marks1823 labels1824) (vector (quote ribcage) symnames1822 marks1823 labels1824))) (gen-labels1122 (lambda (ls1825) (if (null? ls1825) (quote ()) (cons (gen-label1121) (gen-labels1122 (cdr ls1825)))))) (gen-label1121 (lambda () (string #\i))) (wrap-subst1120 cdr) (wrap-marks1119 car) (make-wrap1118 cons) (id-sym-name&marks1117 (lambda (x1826 w1827) (if (syntax-object?1100 x1826) (values (let ((e1828 (syntax-object-expression1101 x1826))) (if (annotation? e1828) (annotation-expression e1828) e1828)) (join-marks1136 (wrap-marks1119 w1827) (wrap-marks1119 (syntax-object-wrap1102 x1826)))) (values (let ((e1829 x1826)) (if (annotation? e1829) (annotation-expression e1829) e1829)) (wrap-marks1119 w1827))))) (id?1116 (lambda (x1830) (cond ((symbol? x1830) #t) ((syntax-object?1100 x1830) (symbol? (let ((e1831 (syntax-object-expression1101 x1830))) (if (annotation? e1831) (annotation-expression e1831) e1831)))) ((annotation? x1830) (symbol? (annotation-expression x1830))) (else #f)))) (nonsymbol-id?1115 (lambda (x1832) (and (syntax-object?1100 x1832) (symbol? (let ((e1833 (syntax-object-expression1101 x1832))) (if (annotation? e1833) (annotation-expression e1833) e1833)))))) (global-extend1114 (lambda (type1834 sym1835 val1836) (put-global-definition-hook1090 sym1835 type1834 val1836))) (lookup1113 (lambda (x1837 r1838 mod1839) (cond ((assq x1837 r1838) => cdr) ((symbol? x1837) (or (get-global-definition-hook1092 x1837 mod1839) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1112 (lambda (r1840) (if (null? r1840) (quote ()) (let ((a1841 (car r1840))) (if (eq? (cadr a1841) (quote macro)) (cons a1841 (macros-only-env1112 (cdr r1840))) (macros-only-env1112 (cdr r1840))))))) (extend-var-env1111 (lambda (labels1842 vars1843 r1844) (if (null? labels1842) r1844 (extend-var-env1111 (cdr labels1842) (cdr vars1843) (cons (cons (car labels1842) (cons (quote lexical) (car vars1843))) r1844))))) (extend-env1110 (lambda (labels1845 bindings1846 r1847) (if (null? labels1845) r1847 (extend-env1110 (cdr labels1845) (cdr bindings1846) (cons (cons (car labels1845) (car bindings1846)) r1847))))) (binding-value1109 cdr) (binding-type1108 car) (source-annotation1107 (lambda (x1848) (cond ((annotation? x1848) (annotation-source x1848)) ((syntax-object?1100 x1848) (source-annotation1107 (syntax-object-expression1101 x1848))) (else #f)))) (set-syntax-object-module!1106 (lambda (x1849 update1850) (vector-set! x1849 3 update1850))) (set-syntax-object-wrap!1105 (lambda (x1851 update1852) (vector-set! x1851 2 update1852))) (set-syntax-object-expression!1104 (lambda (x1853 update1854) (vector-set! x1853 1 update1854))) (syntax-object-module1103 (lambda (x1855) (vector-ref x1855 3))) (syntax-object-wrap1102 (lambda (x1856) (vector-ref x1856 2))) (syntax-object-expression1101 (lambda (x1857) (vector-ref x1857 1))) (syntax-object?1100 (lambda (x1858) (and (vector? x1858) (= (vector-length x1858) 4) (eq? (vector-ref x1858 0) (quote syntax-object))))) (make-syntax-object1099 (lambda (expression1859 wrap1860 module1861) (vector (quote syntax-object) expression1859 wrap1860 module1861))) (build-letrec1098 (lambda (src1862 vars1863 val-exps1864 body-exp1865) (if (null? vars1863) (build-annotated1093 src1862 body-exp1865) (build-annotated1093 src1862 (list (quote letrec) (map list vars1863 val-exps1864) body-exp1865))))) (build-named-let1097 (lambda (src1866 vars1867 val-exps1868 body-exp1869) (if (null? vars1867) (build-annotated1093 src1866 body-exp1869) (build-annotated1093 src1866 (list (quote let) (car vars1867) (map list (cdr vars1867) val-exps1868) body-exp1869))))) (build-let1096 (lambda (src1870 vars1871 val-exps1872 body-exp1873) (if (null? vars1871) (build-annotated1093 src1870 body-exp1873) (build-annotated1093 src1870 (list (quote let) (map list vars1871 val-exps1872) body-exp1873))))) (build-sequence1095 (lambda (src1874 exps1875) (if (null? (cdr exps1875)) (build-annotated1093 src1874 (car exps1875)) (build-annotated1093 src1874 (cons (quote begin) exps1875))))) (build-data1094 (lambda (src1876 exp1877) (if (and (self-evaluating? exp1877) (not (vector? exp1877))) (build-annotated1093 src1876 exp1877) (build-annotated1093 src1876 (list (quote quote) exp1877))))) (build-annotated1093 (lambda (src1878 exp1879) (if (and src1878 (not (annotation? exp1879))) (make-annotation exp1879 src1878 #t) exp1879))) (get-global-definition-hook1092 (lambda (symbol1880 module1881) (let ((module1882 (if module1881 (resolve-module (cdr module1881)) (let ((mod1883 (current-module))) (begin (if mod1883 (warn "wha" symbol1880)) mod1883))))) (let ((v1884 (module-variable module1882 symbol1880))) (and v1884 (object-property v1884 (quote *sc-expander*))))))) (remove-global-definition-hook1091 (lambda (symbol1885) (let ((module1886 (current-module))) (let ((v1887 (module-local-variable module1886 symbol1885))) (if v1887 (let ((p1888 (assq (quote *sc-expander*) (object-properties v1887)))) (set-object-properties! v1887 (delq p1888 (object-properties v1887))))))))) (put-global-definition-hook1090 (lambda (symbol1889 type1890 val1891) (let ((module1892 (current-module))) (let ((v1893 (or (module-variable module1892 symbol1889) (let ((v1894 (make-variable val1891))) (begin (module-add! module1892 symbol1889 v1894) v1894))))) (begin (if (not (variable-bound? v1893)) (variable-set! v1893 val1891)) (set-object-property! v1893 (quote *sc-expander*) (cons type1890 val1891))))))) (error-hook1089 (lambda (who1895 why1896 what1897) (error who1895 "~a ~s" why1896 what1897))) (local-eval-hook1088 (lambda (x1898 mod1899) (primitive-eval (list noexpand1082 x1898)))) (top-level-eval-hook1087 (lambda (x1900 mod1901) (primitive-eval (list noexpand1082 x1900)))) (fx<1086 <) (fx=1085 =) (fx-1084 -) (fx+1083 +) (noexpand1082 "noexpand")) (begin (global-extend1114 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1114 (quote local-syntax) (quote let-syntax) #f) (global-extend1114 (quote core) (quote fluid-let-syntax) (lambda (e1902 r1903 w1904 s1905 mod1906) ((lambda (tmp1907) ((lambda (tmp1908) (if (if tmp1908 (apply (lambda (_1909 var1910 val1911 e11912 e21913) (valid-bound-ids?1141 var1910)) tmp1908) #f) (apply (lambda (_1915 var1916 val1917 e11918 e21919) (let ((names1920 (map (lambda (x1921) (id-var-name1138 x1921 w1904)) var1916))) (begin (for-each (lambda (id1923 n1924) (let ((t1925 (binding-type1108 (lookup1113 n1924 r1903 mod1906)))) (if (memv t1925 (quote (displaced-lexical))) (syntax-error (source-wrap1145 id1923 w1904 s1905 mod1906) "identifier out of context")))) var1916 names1920) (chi-body1156 (cons e11918 e21919) (source-wrap1145 e1902 w1904 s1905 mod1906) (extend-env1110 names1920 (let ((trans-r1928 (macros-only-env1112 r1903))) (map (lambda (x1929) (cons (quote macro) (eval-local-transformer1159 (chi1152 x1929 trans-r1928 w1904 mod1906) mod1906))) val1917)) r1903) w1904 mod1906)))) tmp1908) ((lambda (_1931) (syntax-error (source-wrap1145 e1902 w1904 s1905 mod1906))) tmp1907))) (syntax-dispatch tmp1907 (quote (any #(each (any any)) any . each-any))))) e1902))) (global-extend1114 (quote core) (quote quote) (lambda (e1932 r1933 w1934 s1935 mod1936) ((lambda (tmp1937) ((lambda (tmp1938) (if tmp1938 (apply (lambda (_1939 e1940) (build-data1094 s1935 (strip1163 e1940 w1934))) tmp1938) ((lambda (_1941) (syntax-error (source-wrap1145 e1932 w1934 s1935 mod1936))) tmp1937))) (syntax-dispatch tmp1937 (quote (any any))))) e1932))) (global-extend1114 (quote core) (quote syntax) (letrec ((regen1949 (lambda (x1950) (let ((t1951 (car x1950))) (if (memv t1951 (quote (ref))) (build-annotated1093 #f (cadr x1950)) (if (memv t1951 (quote (primitive))) (build-annotated1093 #f (cadr x1950)) (if (memv t1951 (quote (quote))) (build-data1094 #f (cadr x1950)) (if (memv t1951 (quote (lambda))) (build-annotated1093 #f (list (quote lambda) (cadr x1950) (regen1949 (caddr x1950)))) (if (memv t1951 (quote (map))) (let ((ls1952 (map regen1949 (cdr x1950)))) (build-annotated1093 #f (cons (if (fx=1085 (length ls1952) 2) (build-annotated1093 #f (quote map)) (build-annotated1093 #f (quote map))) ls1952))) (build-annotated1093 #f (cons (build-annotated1093 #f (car x1950)) (map regen1949 (cdr x1950)))))))))))) (gen-vector1948 (lambda (x1953) (cond ((eq? (car x1953) (quote list)) (cons (quote vector) (cdr x1953))) ((eq? (car x1953) (quote quote)) (list (quote quote) (list->vector (cadr x1953)))) (else (list (quote list->vector) x1953))))) (gen-append1947 (lambda (x1954 y1955) (if (equal? y1955 (quote (quote ()))) x1954 (list (quote append) x1954 y1955)))) (gen-cons1946 (lambda (x1956 y1957) (let ((t1958 (car y1957))) (if (memv t1958 (quote (quote))) (if (eq? (car x1956) (quote quote)) (list (quote quote) (cons (cadr x1956) (cadr y1957))) (if (eq? (cadr y1957) (quote ())) (list (quote list) x1956) (list (quote cons) x1956 y1957))) (if (memv t1958 (quote (list))) (cons (quote list) (cons x1956 (cdr y1957))) (list (quote cons) x1956 y1957)))))) (gen-map1945 (lambda (e1959 map-env1960) (let ((formals1961 (map cdr map-env1960)) (actuals1962 (map (lambda (x1963) (list (quote ref) (car x1963))) map-env1960))) (cond ((eq? (car e1959) (quote ref)) (car actuals1962)) ((andmap (lambda (x1964) (and (eq? (car x1964) (quote ref)) (memq (cadr x1964) formals1961))) (cdr e1959)) (cons (quote map) (cons (list (quote primitive) (car e1959)) (map (let ((r1965 (map cons formals1961 actuals1962))) (lambda (x1966) (cdr (assq (cadr x1966) r1965)))) (cdr e1959))))) (else (cons (quote map) (cons (list (quote lambda) formals1961 e1959) actuals1962))))))) (gen-mappend1944 (lambda (e1967 map-env1968) (list (quote apply) (quote (primitive append)) (gen-map1945 e1967 map-env1968)))) (gen-ref1943 (lambda (src1969 var1970 level1971 maps1972) (if (fx=1085 level1971 0) (values var1970 maps1972) (if (null? maps1972) (syntax-error src1969 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1943 src1969 var1970 (fx-1084 level1971 1) (cdr maps1972))) (lambda (outer-var1973 outer-maps1974) (let ((b1975 (assq outer-var1973 (car maps1972)))) (if b1975 (values (cdr b1975) maps1972) (let ((inner-var1976 (gen-var1164 (quote tmp)))) (values inner-var1976 (cons (cons (cons outer-var1973 inner-var1976) (car maps1972)) outer-maps1974))))))))))) (gen-syntax1942 (lambda (src1977 e1978 r1979 maps1980 ellipsis?1981 mod1982) (if (id?1116 e1978) (let ((label1983 (id-var-name1138 e1978 (quote (()))))) (let ((b1984 (lookup1113 label1983 r1979 mod1982))) (if (eq? (binding-type1108 b1984) (quote syntax)) (call-with-values (lambda () (let ((var.lev1985 (binding-value1109 b1984))) (gen-ref1943 src1977 (car var.lev1985) (cdr var.lev1985) maps1980))) (lambda (var1986 maps1987) (values (list (quote ref) var1986) maps1987))) (if (ellipsis?1981 e1978) (syntax-error src1977 "misplaced ellipsis in syntax form") (values (list (quote quote) e1978) maps1980))))) ((lambda (tmp1988) ((lambda (tmp1989) (if (if tmp1989 (apply (lambda (dots1990 e1991) (ellipsis?1981 dots1990)) tmp1989) #f) (apply (lambda (dots1992 e1993) (gen-syntax1942 src1977 e1993 r1979 maps1980 (lambda (x1994) #f) mod1982)) tmp1989) ((lambda (tmp1995) (if (if tmp1995 (apply (lambda (x1996 dots1997 y1998) (ellipsis?1981 dots1997)) tmp1995) #f) (apply (lambda (x1999 dots2000 y2001) (let f2002 ((y2003 y2001) (k2004 (lambda (maps2005) (call-with-values (lambda () (gen-syntax1942 src1977 x1999 r1979 (cons (quote ()) maps2005) ellipsis?1981 mod1982)) (lambda (x2006 maps2007) (if (null? (car maps2007)) (syntax-error src1977 "extra ellipsis in syntax form") (values (gen-map1945 x2006 (car maps2007)) (cdr maps2007)))))))) ((lambda (tmp2008) ((lambda (tmp2009) (if (if tmp2009 (apply (lambda (dots2010 y2011) (ellipsis?1981 dots2010)) tmp2009) #f) (apply (lambda (dots2012 y2013) (f2002 y2013 (lambda (maps2014) (call-with-values (lambda () (k2004 (cons (quote ()) maps2014))) (lambda (x2015 maps2016) (if (null? (car maps2016)) (syntax-error src1977 "extra ellipsis in syntax form") (values (gen-mappend1944 x2015 (car maps2016)) (cdr maps2016)))))))) tmp2009) ((lambda (_2017) (call-with-values (lambda () (gen-syntax1942 src1977 y2003 r1979 maps1980 ellipsis?1981 mod1982)) (lambda (y2018 maps2019) (call-with-values (lambda () (k2004 maps2019)) (lambda (x2020 maps2021) (values (gen-append1947 x2020 y2018) maps2021)))))) tmp2008))) (syntax-dispatch tmp2008 (quote (any . any))))) y2003))) tmp1995) ((lambda (tmp2022) (if tmp2022 (apply (lambda (x2023 y2024) (call-with-values (lambda () (gen-syntax1942 src1977 x2023 r1979 maps1980 ellipsis?1981 mod1982)) (lambda (x2025 maps2026) (call-with-values (lambda () (gen-syntax1942 src1977 y2024 r1979 maps2026 ellipsis?1981 mod1982)) (lambda (y2027 maps2028) (values (gen-cons1946 x2025 y2027) maps2028)))))) tmp2022) ((lambda (tmp2029) (if tmp2029 (apply (lambda (e12030 e22031) (call-with-values (lambda () (gen-syntax1942 src1977 (cons e12030 e22031) r1979 maps1980 ellipsis?1981 mod1982)) (lambda (e2033 maps2034) (values (gen-vector1948 e2033) maps2034)))) tmp2029) ((lambda (_2035) (values (list (quote quote) e1978) maps1980)) tmp1988))) (syntax-dispatch tmp1988 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1988 (quote (any . any)))))) (syntax-dispatch tmp1988 (quote (any any . any)))))) (syntax-dispatch tmp1988 (quote (any any))))) e1978))))) (lambda (e2036 r2037 w2038 s2039 mod2040) (let ((e2041 (source-wrap1145 e2036 w2038 s2039 mod2040))) ((lambda (tmp2042) ((lambda (tmp2043) (if tmp2043 (apply (lambda (_2044 x2045) (call-with-values (lambda () (gen-syntax1942 e2041 x2045 r2037 (quote ()) ellipsis?1161 mod2040)) (lambda (e2046 maps2047) (regen1949 e2046)))) tmp2043) ((lambda (_2048) (syntax-error e2041)) tmp2042))) (syntax-dispatch tmp2042 (quote (any any))))) e2041))))) (global-extend1114 (quote core) (quote lambda) (lambda (e2049 r2050 w2051 s2052 mod2053) ((lambda (tmp2054) ((lambda (tmp2055) (if tmp2055 (apply (lambda (_2056 c2057) (chi-lambda-clause1157 (source-wrap1145 e2049 w2051 s2052 mod2053) #f c2057 r2050 w2051 mod2053 (lambda (vars2058 docstring2059 body2060) (build-annotated1093 s2052 (cons (quote lambda) (cons vars2058 (append (if docstring2059 (list docstring2059) (quote ())) (list body2060)))))))) tmp2055) (syntax-error tmp2054))) (syntax-dispatch tmp2054 (quote (any . any))))) e2049))) (global-extend1114 (quote core) (quote let) (letrec ((chi-let2061 (lambda (e2062 r2063 w2064 s2065 mod2066 constructor2067 ids2068 vals2069 exps2070) (if (not (valid-bound-ids?1141 ids2068)) (syntax-error e2062 "duplicate bound variable in") (let ((labels2071 (gen-labels1122 ids2068)) (new-vars2072 (map gen-var1164 ids2068))) (let ((nw2073 (make-binding-wrap1133 ids2068 labels2071 w2064)) (nr2074 (extend-var-env1111 labels2071 new-vars2072 r2063))) (constructor2067 s2065 new-vars2072 (map (lambda (x2075) (chi1152 x2075 r2063 w2064 mod2066)) vals2069) (chi-body1156 exps2070 (source-wrap1145 e2062 nw2073 s2065 mod2066) nr2074 nw2073 mod2066)))))))) (lambda (e2076 r2077 w2078 s2079 mod2080) ((lambda (tmp2081) ((lambda (tmp2082) (if tmp2082 (apply (lambda (_2083 id2084 val2085 e12086 e22087) (chi-let2061 e2076 r2077 w2078 s2079 mod2080 build-let1096 id2084 val2085 (cons e12086 e22087))) tmp2082) ((lambda (tmp2091) (if (if tmp2091 (apply (lambda (_2092 f2093 id2094 val2095 e12096 e22097) (id?1116 f2093)) tmp2091) #f) (apply (lambda (_2098 f2099 id2100 val2101 e12102 e22103) (chi-let2061 e2076 r2077 w2078 s2079 mod2080 build-named-let1097 (cons f2099 id2100) val2101 (cons e12102 e22103))) tmp2091) ((lambda (_2107) (syntax-error (source-wrap1145 e2076 w2078 s2079 mod2080))) tmp2081))) (syntax-dispatch tmp2081 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2081 (quote (any #(each (any any)) any . each-any))))) e2076)))) (global-extend1114 (quote core) (quote letrec) (lambda (e2108 r2109 w2110 s2111 mod2112) ((lambda (tmp2113) ((lambda (tmp2114) (if tmp2114 (apply (lambda (_2115 id2116 val2117 e12118 e22119) (let ((ids2120 id2116)) (if (not (valid-bound-ids?1141 ids2120)) (syntax-error e2108 "duplicate bound variable in") (let ((labels2122 (gen-labels1122 ids2120)) (new-vars2123 (map gen-var1164 ids2120))) (let ((w2124 (make-binding-wrap1133 ids2120 labels2122 w2110)) (r2125 (extend-var-env1111 labels2122 new-vars2123 r2109))) (build-letrec1098 s2111 new-vars2123 (map (lambda (x2126) (chi1152 x2126 r2125 w2124 mod2112)) val2117) (chi-body1156 (cons e12118 e22119) (source-wrap1145 e2108 w2124 s2111 mod2112) r2125 w2124 mod2112))))))) tmp2114) ((lambda (_2129) (syntax-error (source-wrap1145 e2108 w2110 s2111 mod2112))) tmp2113))) (syntax-dispatch tmp2113 (quote (any #(each (any any)) any . each-any))))) e2108))) (global-extend1114 (quote core) (quote set!) (lambda (e2130 r2131 w2132 s2133 mod2134) ((lambda (tmp2135) ((lambda (tmp2136) (if (if tmp2136 (apply (lambda (_2137 id2138 val2139) (id?1116 id2138)) tmp2136) #f) (apply (lambda (_2140 id2141 val2142) (let ((val2143 (chi1152 val2142 r2131 w2132 mod2134)) (n2144 (id-var-name1138 id2141 w2132))) (let ((b2145 (lookup1113 n2144 r2131 mod2134))) (let ((t2146 (binding-type1108 b2145))) (if (memv t2146 (quote (lexical))) (build-annotated1093 s2133 (list (quote set!) (binding-value1109 b2145) val2143)) (if (memv t2146 (quote (global))) (build-annotated1093 s2133 (list (quote set!) (if mod2134 (make-module-ref (cdr mod2134) n2144 (car mod2134)) (make-module-ref mod2134 n2144 (quote bare))) val2143)) (if (memv t2146 (quote (displaced-lexical))) (syntax-error (wrap1144 id2141 w2132 mod2134) "identifier out of context") (syntax-error (source-wrap1145 e2130 w2132 s2133 mod2134))))))))) tmp2136) ((lambda (tmp2147) (if tmp2147 (apply (lambda (_2148 head2149 tail2150 val2151) (call-with-values (lambda () (syntax-type1150 head2149 r2131 (quote (())) #f #f mod2134)) (lambda (type2152 value2153 ee2154 ww2155 ss2156 modmod2157) (let ((t2158 type2152)) (if (memv t2158 (quote (module-ref))) (let ((val2159 (chi1152 val2151 r2131 w2132 mod2134))) (call-with-values (lambda () (value2153 (cons head2149 tail2150))) (lambda (id2161 mod2162) (build-annotated1093 s2133 (list (quote set!) (if mod2162 (make-module-ref (cdr mod2162) id2161 (car mod2162)) (make-module-ref mod2162 id2161 (quote bare))) val2159))))) (build-annotated1093 s2133 (cons (chi1152 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2149) r2131 w2132 mod2134) (map (lambda (e2163) (chi1152 e2163 r2131 w2132 mod2134)) (append tail2150 (list val2151)))))))))) tmp2147) ((lambda (_2165) (syntax-error (source-wrap1145 e2130 w2132 s2133 mod2134))) tmp2135))) (syntax-dispatch tmp2135 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2135 (quote (any any any))))) e2130))) (global-extend1114 (quote module-ref) (quote @) (lambda (e2166) ((lambda (tmp2167) ((lambda (tmp2168) (if (if tmp2168 (apply (lambda (_2169 mod2170 id2171) (and (andmap id?1116 mod2170) (id?1116 id2171))) tmp2168) #f) (apply (lambda (_2173 mod2174 id2175) (values (syntax-object->datum id2175) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2174)))) tmp2168) (syntax-error tmp2167))) (syntax-dispatch tmp2167 (quote (any each-any any))))) e2166))) (global-extend1114 (quote module-ref) (quote @@) (lambda (e2177) ((lambda (tmp2178) ((lambda (tmp2179) (if (if tmp2179 (apply (lambda (_2180 mod2181 id2182) (and (andmap id?1116 mod2181) (id?1116 id2182))) tmp2179) #f) (apply (lambda (_2184 mod2185 id2186) (values (syntax-object->datum id2186) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2185)))) tmp2179) (syntax-error tmp2178))) (syntax-dispatch tmp2178 (quote (any each-any any))))) e2177))) (global-extend1114 (quote begin) (quote begin) (quote ())) (global-extend1114 (quote define) (quote define) (quote ())) (global-extend1114 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1114 (quote eval-when) (quote eval-when) (quote ())) (global-extend1114 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2191 (lambda (x2192 keys2193 clauses2194 r2195 mod2196) (if (null? clauses2194) (build-annotated1093 #f (list (build-annotated1093 #f (quote syntax-error)) x2192)) ((lambda (tmp2197) ((lambda (tmp2198) (if tmp2198 (apply (lambda (pat2199 exp2200) (if (and (id?1116 pat2199) (andmap (lambda (x2201) (not (free-id=?1139 pat2199 x2201))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2193))) (let ((labels2202 (list (gen-label1121))) (var2203 (gen-var1164 pat2199))) (build-annotated1093 #f (list (build-annotated1093 #f (list (quote lambda) (list var2203) (chi1152 exp2200 (extend-env1110 labels2202 (list (cons (quote syntax) (cons var2203 0))) r2195) (make-binding-wrap1133 (list pat2199) labels2202 (quote (()))) mod2196))) x2192))) (gen-clause2190 x2192 keys2193 (cdr clauses2194) r2195 pat2199 #t exp2200 mod2196))) tmp2198) ((lambda (tmp2204) (if tmp2204 (apply (lambda (pat2205 fender2206 exp2207) (gen-clause2190 x2192 keys2193 (cdr clauses2194) r2195 pat2205 fender2206 exp2207 mod2196)) tmp2204) ((lambda (_2208) (syntax-error (car clauses2194) "invalid syntax-case clause")) tmp2197))) (syntax-dispatch tmp2197 (quote (any any any)))))) (syntax-dispatch tmp2197 (quote (any any))))) (car clauses2194))))) (gen-clause2190 (lambda (x2209 keys2210 clauses2211 r2212 pat2213 fender2214 exp2215 mod2216) (call-with-values (lambda () (convert-pattern2188 pat2213 keys2210)) (lambda (p2217 pvars2218) (cond ((not (distinct-bound-ids?1142 (map car pvars2218))) (syntax-error pat2213 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2219) (not (ellipsis?1161 (car x2219)))) pvars2218)) (syntax-error pat2213 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2220 (gen-var1164 (quote tmp)))) (build-annotated1093 #f (list (build-annotated1093 #f (list (quote lambda) (list y2220) (let ((y2221 (build-annotated1093 #f y2220))) (build-annotated1093 #f (list (quote if) ((lambda (tmp2222) ((lambda (tmp2223) (if tmp2223 (apply (lambda () y2221) tmp2223) ((lambda (_2224) (build-annotated1093 #f (list (quote if) y2221 (build-dispatch-call2189 pvars2218 fender2214 y2221 r2212 mod2216) (build-data1094 #f #f)))) tmp2222))) (syntax-dispatch tmp2222 (quote #(atom #t))))) fender2214) (build-dispatch-call2189 pvars2218 exp2215 y2221 r2212 mod2216) (gen-syntax-case2191 x2209 keys2210 clauses2211 r2212 mod2216)))))) (if (eq? p2217 (quote any)) (build-annotated1093 #f (list (build-annotated1093 #f (quote list)) x2209)) (build-annotated1093 #f (list (build-annotated1093 #f (quote syntax-dispatch)) x2209 (build-data1094 #f p2217))))))))))))) (build-dispatch-call2189 (lambda (pvars2225 exp2226 y2227 r2228 mod2229) (let ((ids2230 (map car pvars2225)) (levels2231 (map cdr pvars2225))) (let ((labels2232 (gen-labels1122 ids2230)) (new-vars2233 (map gen-var1164 ids2230))) (build-annotated1093 #f (list (build-annotated1093 #f (quote apply)) (build-annotated1093 #f (list (quote lambda) new-vars2233 (chi1152 exp2226 (extend-env1110 labels2232 (map (lambda (var2234 level2235) (cons (quote syntax) (cons var2234 level2235))) new-vars2233 (map cdr pvars2225)) r2228) (make-binding-wrap1133 ids2230 labels2232 (quote (()))) mod2229))) y2227)))))) (convert-pattern2188 (lambda (pattern2236 keys2237) (let cvt2238 ((p2239 pattern2236) (n2240 0) (ids2241 (quote ()))) (if (id?1116 p2239) (if (bound-id-member?1143 p2239 keys2237) (values (vector (quote free-id) p2239) ids2241) (values (quote any) (cons (cons p2239 n2240) ids2241))) ((lambda (tmp2242) ((lambda (tmp2243) (if (if tmp2243 (apply (lambda (x2244 dots2245) (ellipsis?1161 dots2245)) tmp2243) #f) (apply (lambda (x2246 dots2247) (call-with-values (lambda () (cvt2238 x2246 (fx+1083 n2240 1) ids2241)) (lambda (p2248 ids2249) (values (if (eq? p2248 (quote any)) (quote each-any) (vector (quote each) p2248)) ids2249)))) tmp2243) ((lambda (tmp2250) (if tmp2250 (apply (lambda (x2251 y2252) (call-with-values (lambda () (cvt2238 y2252 n2240 ids2241)) (lambda (y2253 ids2254) (call-with-values (lambda () (cvt2238 x2251 n2240 ids2254)) (lambda (x2255 ids2256) (values (cons x2255 y2253) ids2256)))))) tmp2250) ((lambda (tmp2257) (if tmp2257 (apply (lambda () (values (quote ()) ids2241)) tmp2257) ((lambda (tmp2258) (if tmp2258 (apply (lambda (x2259) (call-with-values (lambda () (cvt2238 x2259 n2240 ids2241)) (lambda (p2261 ids2262) (values (vector (quote vector) p2261) ids2262)))) tmp2258) ((lambda (x2263) (values (vector (quote atom) (strip1163 p2239 (quote (())))) ids2241)) tmp2242))) (syntax-dispatch tmp2242 (quote #(vector each-any)))))) (syntax-dispatch tmp2242 (quote ()))))) (syntax-dispatch tmp2242 (quote (any . any)))))) (syntax-dispatch tmp2242 (quote (any any))))) p2239)))))) (lambda (e2264 r2265 w2266 s2267 mod2268) (let ((e2269 (source-wrap1145 e2264 w2266 s2267 mod2268))) ((lambda (tmp2270) ((lambda (tmp2271) (if tmp2271 (apply (lambda (_2272 val2273 key2274 m2275) (if (andmap (lambda (x2276) (and (id?1116 x2276) (not (ellipsis?1161 x2276)))) key2274) (let ((x2278 (gen-var1164 (quote tmp)))) (build-annotated1093 s2267 (list (build-annotated1093 #f (list (quote lambda) (list x2278) (gen-syntax-case2191 (build-annotated1093 #f x2278) key2274 m2275 r2265 mod2268))) (chi1152 val2273 r2265 (quote (())) mod2268)))) (syntax-error e2269 "invalid literals list in"))) tmp2271) (syntax-error tmp2270))) (syntax-dispatch tmp2270 (quote (any any each-any . each-any))))) e2269))))) (set! sc-expand (let ((m2281 (quote e)) (esew2282 (quote (eval)))) (lambda (x2283) (if (and (pair? x2283) (equal? (car x2283) noexpand1082)) (cadr x2283) (chi-top1151 x2283 (quote ()) (quote ((top))) m2281 esew2282 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2284 (quote e)) (esew2285 (quote (eval)))) (lambda (x2287 . rest2286) (if (and (pair? x2287) (equal? (car x2287) noexpand1082)) (cadr x2287) (chi-top1151 x2287 (quote ()) (quote ((top))) (if (null? rest2286) m2284 (car rest2286)) (if (or (null? rest2286) (null? (cdr rest2286))) esew2285 (cadr rest2286)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2288) (nonsymbol-id?1115 x2288))) (set! datum->syntax-object (lambda (id2289 datum2290) (make-syntax-object1099 datum2290 (syntax-object-wrap1102 id2289) #f))) (set! syntax-object->datum (lambda (x2291) (strip1163 x2291 (quote (()))))) (set! generate-temporaries (lambda (ls2292) (begin (let ((x2293 ls2292)) (if (not (list? x2293)) (error-hook1089 (quote generate-temporaries) "invalid argument" x2293))) (map (lambda (x2294) (wrap1144 (gensym) (quote ((top))) #f)) ls2292)))) (set! free-identifier=? (lambda (x2295 y2296) (begin (let ((x2297 x2295)) (if (not (nonsymbol-id?1115 x2297)) (error-hook1089 (quote free-identifier=?) "invalid argument" x2297))) (let ((x2298 y2296)) (if (not (nonsymbol-id?1115 x2298)) (error-hook1089 (quote free-identifier=?) "invalid argument" x2298))) (free-id=?1139 x2295 y2296)))) (set! bound-identifier=? (lambda (x2299 y2300) (begin (let ((x2301 x2299)) (if (not (nonsymbol-id?1115 x2301)) (error-hook1089 (quote bound-identifier=?) "invalid argument" x2301))) (let ((x2302 y2300)) (if (not (nonsymbol-id?1115 x2302)) (error-hook1089 (quote bound-identifier=?) "invalid argument" x2302))) (bound-id=?1140 x2299 y2300)))) (set! syntax-error (lambda (object2304 . messages2303) (begin (for-each (lambda (x2305) (let ((x2306 x2305)) (if (not (string? x2306)) (error-hook1089 (quote syntax-error) "invalid argument" x2306)))) messages2303) (let ((message2307 (if (null? messages2303) "invalid syntax" (apply string-append messages2303)))) (error-hook1089 #f message2307 (strip1163 object2304 (quote (())))))))) (set! install-global-transformer (lambda (sym2308 v2309) (begin (let ((x2310 sym2308)) (if (not (symbol? x2310)) (error-hook1089 (quote define-syntax) "invalid argument" x2310))) (let ((x2311 v2309)) (if (not (procedure? x2311)) (error-hook1089 (quote define-syntax) "invalid argument" x2311))) (global-extend1114 (quote macro) sym2308 v2309)))) (letrec ((match2316 (lambda (e2317 p2318 w2319 r2320 mod2321) (cond ((not r2320) #f) ((eq? p2318 (quote any)) (cons (wrap1144 e2317 w2319 mod2321) r2320)) ((syntax-object?1100 e2317) (match*2315 (let ((e2322 (syntax-object-expression1101 e2317))) (if (annotation? e2322) (annotation-expression e2322) e2322)) p2318 (join-wraps1135 w2319 (syntax-object-wrap1102 e2317)) r2320 (syntax-object-module1103 e2317))) (else (match*2315 (let ((e2323 e2317)) (if (annotation? e2323) (annotation-expression e2323) e2323)) p2318 w2319 r2320 mod2321))))) (match*2315 (lambda (e2324 p2325 w2326 r2327 mod2328) (cond ((null? p2325) (and (null? e2324) r2327)) ((pair? p2325) (and (pair? e2324) (match2316 (car e2324) (car p2325) w2326 (match2316 (cdr e2324) (cdr p2325) w2326 r2327 mod2328) mod2328))) ((eq? p2325 (quote each-any)) (let ((l2329 (match-each-any2313 e2324 w2326 mod2328))) (and l2329 (cons l2329 r2327)))) (else (let ((t2330 (vector-ref p2325 0))) (if (memv t2330 (quote (each))) (if (null? e2324) (match-empty2314 (vector-ref p2325 1) r2327) (let ((l2331 (match-each2312 e2324 (vector-ref p2325 1) w2326 mod2328))) (and l2331 (let collect2332 ((l2333 l2331)) (if (null? (car l2333)) r2327 (cons (map car l2333) (collect2332 (map cdr l2333)))))))) (if (memv t2330 (quote (free-id))) (and (id?1116 e2324) (free-id=?1139 (wrap1144 e2324 w2326 mod2328) (vector-ref p2325 1)) r2327) (if (memv t2330 (quote (atom))) (and (equal? (vector-ref p2325 1) (strip1163 e2324 w2326)) r2327) (if (memv t2330 (quote (vector))) (and (vector? e2324) (match2316 (vector->list e2324) (vector-ref p2325 1) w2326 r2327 mod2328))))))))))) (match-empty2314 (lambda (p2334 r2335) (cond ((null? p2334) r2335) ((eq? p2334 (quote any)) (cons (quote ()) r2335)) ((pair? p2334) (match-empty2314 (car p2334) (match-empty2314 (cdr p2334) r2335))) ((eq? p2334 (quote each-any)) (cons (quote ()) r2335)) (else (let ((t2336 (vector-ref p2334 0))) (if (memv t2336 (quote (each))) (match-empty2314 (vector-ref p2334 1) r2335) (if (memv t2336 (quote (free-id atom))) r2335 (if (memv t2336 (quote (vector))) (match-empty2314 (vector-ref p2334 1) r2335))))))))) (match-each-any2313 (lambda (e2337 w2338 mod2339) (cond ((annotation? e2337) (match-each-any2313 (annotation-expression e2337) w2338 mod2339)) ((pair? e2337) (let ((l2340 (match-each-any2313 (cdr e2337) w2338 mod2339))) (and l2340 (cons (wrap1144 (car e2337) w2338 mod2339) l2340)))) ((null? e2337) (quote ())) ((syntax-object?1100 e2337) (match-each-any2313 (syntax-object-expression1101 e2337) (join-wraps1135 w2338 (syntax-object-wrap1102 e2337)) mod2339)) (else #f)))) (match-each2312 (lambda (e2341 p2342 w2343 mod2344) (cond ((annotation? e2341) (match-each2312 (annotation-expression e2341) p2342 w2343 mod2344)) ((pair? e2341) (let ((first2345 (match2316 (car e2341) p2342 w2343 (quote ()) mod2344))) (and first2345 (let ((rest2346 (match-each2312 (cdr e2341) p2342 w2343 mod2344))) (and rest2346 (cons first2345 rest2346)))))) ((null? e2341) (quote ())) ((syntax-object?1100 e2341) (match-each2312 (syntax-object-expression1101 e2341) p2342 (join-wraps1135 w2343 (syntax-object-wrap1102 e2341)) (syntax-object-module1103 e2341))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2347 p2348) (cond ((eq? p2348 (quote any)) (list e2347)) ((syntax-object?1100 e2347) (match*2315 (let ((e2349 (syntax-object-expression1101 e2347))) (if (annotation? e2349) (annotation-expression e2349) e2349)) p2348 (syntax-object-wrap1102 e2347) (quote ()) (syntax-object-module1103 e2347))) (else (match*2315 (let ((e2350 e2347)) (if (annotation? e2350) (annotation-expression e2350) e2350)) p2348 (quote (())) (quote ()) #f))))) (set! sc-chi chi1152))))) +(install-global-transformer (quote with-syntax) (lambda (x2351) ((lambda (tmp2352) ((lambda (tmp2353) (if tmp2353 (apply (lambda (_2354 e12355 e22356) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12355 e22356))) tmp2353) ((lambda (tmp2358) (if tmp2358 (apply (lambda (_2359 out2360 in2361 e12362 e22363) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2361 (quote ()) (list out2360 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12362 e22363))))) tmp2358) ((lambda (tmp2365) (if tmp2365 (apply (lambda (_2366 out2367 in2368 e12369 e22370) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2368) (quote ()) (list out2367 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12369 e22370))))) tmp2365) (syntax-error tmp2352))) (syntax-dispatch tmp2352 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2352 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2352 (quote (any () any . each-any))))) x2351))) +(install-global-transformer (quote syntax-rules) (lambda (x2374) ((lambda (tmp2375) ((lambda (tmp2376) (if tmp2376 (apply (lambda (_2377 k2378 keyword2379 pattern2380 template2381) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2378 (map (lambda (tmp2384 tmp2383) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2383) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2384))) template2381 pattern2380)))))) tmp2376) (syntax-error tmp2375))) (syntax-dispatch tmp2375 (quote (any each-any . #(each ((any . any) any))))))) x2374))) +(install-global-transformer (quote let*) (lambda (x2385) ((lambda (tmp2386) ((lambda (tmp2387) (if (if tmp2387 (apply (lambda (let*2388 x2389 v2390 e12391 e22392) (andmap identifier? x2389)) tmp2387) #f) (apply (lambda (let*2394 x2395 v2396 e12397 e22398) (let f2399 ((bindings2400 (map list x2395 v2396))) (if (null? bindings2400) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12397 e22398))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (body2406 binding2407) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2407) body2406)) tmp2405) (syntax-error tmp2404))) (syntax-dispatch tmp2404 (quote (any any))))) (list (f2399 (cdr bindings2400)) (car bindings2400)))))) tmp2387) (syntax-error tmp2386))) (syntax-dispatch tmp2386 (quote (any #(each (any any)) any . each-any))))) x2385))) +(install-global-transformer (quote do) (lambda (orig-x2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (_2411 var2412 init2413 step2414 e02415 e12416 c2417) ((lambda (tmp2418) ((lambda (tmp2419) (if tmp2419 (apply (lambda (step2420) ((lambda (tmp2421) ((lambda (tmp2422) (if tmp2422 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2412 init2413) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02415) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2417 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2420))))))) tmp2422) ((lambda (tmp2427) (if tmp2427 (apply (lambda (e12428 e22429) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2412 init2413) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02415 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12428 e22429)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2417 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2420))))))) tmp2427) (syntax-error tmp2421))) (syntax-dispatch tmp2421 (quote (any . each-any)))))) (syntax-dispatch tmp2421 (quote ())))) e12416)) tmp2419) (syntax-error tmp2418))) (syntax-dispatch tmp2418 (quote each-any)))) (map (lambda (v2436 s2437) ((lambda (tmp2438) ((lambda (tmp2439) (if tmp2439 (apply (lambda () v2436) tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (e2441) e2441) tmp2440) ((lambda (_2442) (syntax-error orig-x2408)) tmp2438))) (syntax-dispatch tmp2438 (quote (any)))))) (syntax-dispatch tmp2438 (quote ())))) s2437)) var2412 step2414))) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2408))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2445 (lambda (x2449 y2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (x2453 y2454) ((lambda (tmp2455) ((lambda (tmp2456) (if tmp2456 (apply (lambda (dy2457) ((lambda (tmp2458) ((lambda (tmp2459) (if tmp2459 (apply (lambda (dx2460) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2460 dy2457))) tmp2459) ((lambda (_2461) (if (null? dy2457) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2453) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2453 y2454))) tmp2458))) (syntax-dispatch tmp2458 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2453)) tmp2456) ((lambda (tmp2462) (if tmp2462 (apply (lambda (stuff2463) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2453 stuff2463))) tmp2462) ((lambda (else2464) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2453 y2454)) tmp2455))) (syntax-dispatch tmp2455 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2455 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2454)) tmp2452) (syntax-error tmp2451))) (syntax-dispatch tmp2451 (quote (any any))))) (list x2449 y2450)))) (quasiappend2446 (lambda (x2465 y2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda (x2469 y2470) ((lambda (tmp2471) ((lambda (tmp2472) (if tmp2472 (apply (lambda () x2469) tmp2472) ((lambda (_2473) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2469 y2470)) tmp2471))) (syntax-dispatch tmp2471 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2470)) tmp2468) (syntax-error tmp2467))) (syntax-dispatch tmp2467 (quote (any any))))) (list x2465 y2466)))) (quasivector2447 (lambda (x2474) ((lambda (tmp2475) ((lambda (x2476) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (x2479) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2479))) tmp2478) ((lambda (tmp2481) (if tmp2481 (apply (lambda (x2482) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2482)) tmp2481) ((lambda (_2484) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2476)) tmp2477))) (syntax-dispatch tmp2477 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2477 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2476)) tmp2475)) x2474))) (quasi2448 (lambda (p2485 lev2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (p2489) (if (= lev2486 0) p2489 (quasicons2445 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2448 (list p2489) (- lev2486 1))))) tmp2488) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491 q2492) (if (= lev2486 0) (quasiappend2446 p2491 (quasi2448 q2492 lev2486)) (quasicons2445 (quasicons2445 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2448 (list p2491) (- lev2486 1))) (quasi2448 q2492 lev2486)))) tmp2490) ((lambda (tmp2493) (if tmp2493 (apply (lambda (p2494) (quasicons2445 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2448 (list p2494) (+ lev2486 1)))) tmp2493) ((lambda (tmp2495) (if tmp2495 (apply (lambda (p2496 q2497) (quasicons2445 (quasi2448 p2496 lev2486) (quasi2448 q2497 lev2486))) tmp2495) ((lambda (tmp2498) (if tmp2498 (apply (lambda (x2499) (quasivector2447 (quasi2448 x2499 lev2486))) tmp2498) ((lambda (p2501) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2501)) tmp2487))) (syntax-dispatch tmp2487 (quote #(vector each-any)))))) (syntax-dispatch tmp2487 (quote (any . any)))))) (syntax-dispatch tmp2487 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2487 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2487 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2485)))) (lambda (x2502) ((lambda (tmp2503) ((lambda (tmp2504) (if tmp2504 (apply (lambda (_2505 e2506) (quasi2448 e2506 0)) tmp2504) (syntax-error tmp2503))) (syntax-dispatch tmp2503 (quote (any any))))) x2502)))) +(install-global-transformer (quote include) (lambda (x2507) (letrec ((read-file2508 (lambda (fn2509 k2510) (let ((p2511 (open-input-file fn2509))) (let f2512 ((x2513 (read p2511))) (if (eof-object? x2513) (begin (close-input-port p2511) (quote ())) (cons (datum->syntax-object k2510 x2513) (f2512 (read p2511))))))))) ((lambda (tmp2514) ((lambda (tmp2515) (if tmp2515 (apply (lambda (k2516 filename2517) (let ((fn2518 (syntax-object->datum filename2517))) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (exp2521) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2521)) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote each-any)))) (read-file2508 fn2518 k2516)))) tmp2515) (syntax-error tmp2514))) (syntax-dispatch tmp2514 (quote (any any))))) x2507)))) +(install-global-transformer (quote unquote) (lambda (x2523) ((lambda (tmp2524) ((lambda (tmp2525) (if tmp2525 (apply (lambda (_2526 e2527) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2527))) tmp2525) (syntax-error tmp2524))) (syntax-dispatch tmp2524 (quote (any any))))) x2523))) +(install-global-transformer (quote unquote-splicing) (lambda (x2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda (_2531 e2532) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2532))) tmp2530) (syntax-error tmp2529))) (syntax-dispatch tmp2529 (quote (any any))))) x2528))) +(install-global-transformer (quote case) (lambda (x2533) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (_2536 e2537 m12538 m22539) ((lambda (tmp2540) ((lambda (body2541) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2537)) body2541)) tmp2540)) (let f2542 ((clause2543 m12538) (clauses2544 m22539)) (if (null? clauses2544) ((lambda (tmp2546) ((lambda (tmp2547) (if tmp2547 (apply (lambda (e12548 e22549) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12548 e22549))) tmp2547) ((lambda (tmp2551) (if tmp2551 (apply (lambda (k2552 e12553 e22554) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2552)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12553 e22554)))) tmp2551) ((lambda (_2557) (syntax-error x2533)) tmp2546))) (syntax-dispatch tmp2546 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2546 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2543) ((lambda (tmp2558) ((lambda (rest2559) ((lambda (tmp2560) ((lambda (tmp2561) (if tmp2561 (apply (lambda (k2562 e12563 e22564) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2562)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12563 e22564)) rest2559)) tmp2561) ((lambda (_2567) (syntax-error x2533)) tmp2560))) (syntax-dispatch tmp2560 (quote (each-any any . each-any))))) clause2543)) tmp2558)) (f2542 (car clauses2544) (cdr clauses2544))))))) tmp2535) (syntax-error tmp2534))) (syntax-dispatch tmp2534 (quote (any any any . each-any))))) x2533))) +(install-global-transformer (quote identifier-syntax) (lambda (x2568) ((lambda (tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (_2571 e2572) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2572)) (list (cons _2571 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2572 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2570) (syntax-error tmp2569))) (syntax-dispatch tmp2569 (quote (any any))))) x2568))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index c17b3c480..8dfab12a5 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -338,16 +338,17 @@ ((_) (gensym)))) (define put-global-definition-hook - (lambda (symbol binding) + (lambda (symbol type val) (let* ((module (current-module)) (v (or (module-variable module symbol) - (let ((v (make-variable (gensym)))) + (let ((v (make-variable val))) (module-add! module symbol v) v)))) (if (not (variable-bound? v)) - (variable-set! v (gensym))) + (variable-set! v val)) ;; Properties are tied to variable objects - (set-object-property! v '*sc-expander* binding)))) + (set-object-property! v '*sc-expander* + (make-binding type val))))) (define remove-global-definition-hook (lambda (symbol) @@ -604,7 +605,7 @@ (define global-extend (lambda (type sym val) - (put-global-definition-hook sym (make-binding type val)))) + (put-global-definition-hook sym type val))) ;;; Conceptually, identifiers are always syntax objects. Internally, From 39f30ea29df55eda3f92d0cf68f1f89282a1418e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Apr 2009 19:09:19 +0200 Subject: [PATCH 077/375] Fix the elisp memoizer code for syncase-in-boot-9 * lang/elisp/interface.scm: * lang/elisp/internals/lambda.scm: * lang/elisp/primitives/syntax.scm: * lang/elisp/transform.scm: Use (lang elisp expand) as the transformer, because we really are intending this code for the memoizer and not the compiler. * lang/elisp/expand.scm: A null expander. * lang/elisp/interface.scm (use-elisp-file, use-elisp-library): * lang/elisp/transform.scm (scheme): Turn these defmacros into procedure->memoizing-macro calls, given that without syncase we have no defmacro either. * lang/elisp/primitives/fns.scm (macroexpand): Comment out, as Scheme's macro expander (temporarily on hiatus) won't work with elisp. --- lang/elisp/expand.scm | 4 +++ lang/elisp/interface.scm | 45 +++++++++++++++++++------------- lang/elisp/internals/lambda.scm | 1 + lang/elisp/primitives/fns.scm | 3 ++- lang/elisp/primitives/syntax.scm | 1 + lang/elisp/transform.scm | 39 +++++++++++++++------------ 6 files changed, 57 insertions(+), 36 deletions(-) create mode 100644 lang/elisp/expand.scm diff --git a/lang/elisp/expand.scm b/lang/elisp/expand.scm new file mode 100644 index 000000000..0599d5984 --- /dev/null +++ b/lang/elisp/expand.scm @@ -0,0 +1,4 @@ +(define-module (lang elisp expand) + #:export (expand)) + +(define (expand x) x) diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm index 1e0758569..fcd748f65 100644 --- a/lang/elisp/interface.scm +++ b/lang/elisp/interface.scm @@ -1,4 +1,5 @@ (define-module (lang elisp interface) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module ((lang elisp internals load) #:select ((load . elisp:load))) @@ -66,31 +67,39 @@ one of the directories of @code{load-path}." (string->symbol (string-append "imports:" (number->string counter))))))) -(define-macro (use-elisp-file file-name . imports) - "Load Elisp code file @var{file-name} and import its definitions +(define use-elisp-file + (procedure->memoizing-macro + (lambda (exp env) + "Load Elisp code file @var{file-name} and import its definitions into the current Scheme module. If any @var{imports} are specified, they are interpreted as selection and renaming specifiers as per @code{use-modules}." - (let ((export-module-name (export-module-name))) - `(begin - (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) - (beautify-user-module! (resolve-module ',export-module-name)) - (load-elisp-file ,file-name) - (use-modules (,export-module-name ,@imports)) - (fluid-set! ,elisp-export-module #f)))) + (let ((file-name (cadr exp)) + (env (cddr exp))) + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-file ,file-name) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f))))))) -(define-macro (use-elisp-library library . imports) - "Load Elisp library @var{library} and import its definitions into +(define use-elisp-library + (procedure->memoizing-macro + (lambda (exp env) + "Load Elisp library @var{library} and import its definitions into the current Scheme module. If any @var{imports} are specified, they are interpreted as selection and renaming specifiers as per @code{use-modules}." - (let ((export-module-name (export-module-name))) - `(begin - (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) - (beautify-user-module! (resolve-module ',export-module-name)) - (load-elisp-library ,library) - (use-modules (,export-module-name ,@imports)) - (fluid-set! ,elisp-export-module #f)))) + (let ((library (cadr exp)) + (env (cddr exp))) + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-library ,library) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f))))))) (define (export-to-elisp . defs) "Export procedures and variables specified by @var{defs} to Elisp. diff --git a/lang/elisp/internals/lambda.scm b/lang/elisp/internals/lambda.scm index 9917c08bd..f7c7a4d01 100644 --- a/lang/elisp/internals/lambda.scm +++ b/lang/elisp/internals/lambda.scm @@ -1,4 +1,5 @@ (define-module (lang elisp internals lambda) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals fset) #:use-module (lang elisp transform) #:export (parse-formals diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm index f7a4aa003..7beb8a51c 100644 --- a/lang/elisp/primitives/fns.scm +++ b/lang/elisp/primitives/fns.scm @@ -26,7 +26,8 @@ (fset 'symbol-function fref/error-if-void) -(fset 'macroexpand macroexpand) +;; FIXME -- lost in the syncase conversion +;; (fset 'macroexpand macroexpand) (fset 'subrp (lambda (obj) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index 6babb3dd3..118b3bc0c 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -1,4 +1,5 @@ (define-module (lang elisp primitives syntax) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals lambda) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index ee288a722..09159c073 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -1,4 +1,5 @@ (define-module (lang elisp transform) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals trace) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals evaluation) @@ -26,23 +27,27 @@ (define (syntax-error x) (error "Syntax error in expression" x)) -(define-macro (scheme exp . module) - (let ((m (if (null? module) - the-root-module - (save-module-excursion - (lambda () - ;; In order for `resolve-module' to work as - ;; expected, the current module must contain the - ;; `app' variable. This is not true for #:pure - ;; modules, specifically (lang elisp base). So, - ;; switch to the root module (guile) before calling - ;; resolve-module. - (set-current-module the-root-module) - (resolve-module (car module))))))) - (let ((x `(,eval (,quote ,exp) ,m))) - ;;(write x) - ;;(newline) - x))) +(define scheme + (procedure->memoizing-macro + (lambda (exp env) + (let ((exp (cadr exp)) + (module (cddr exp))) + (let ((m (if (null? module) + the-root-module + (save-module-excursion + (lambda () + ;; In order for `resolve-module' to work as + ;; expected, the current module must contain the + ;; `app' variable. This is not true for #:pure + ;; modules, specifically (lang elisp base). So, + ;; switch to the root module (guile) before calling + ;; resolve-module. + (set-current-module the-root-module) + (resolve-module (car module))))))) + (let ((x `(,eval (,quote ,exp) ,m))) + ;;(write x) + ;;(newline) + x)))))) (define (transformer x) (cond ((pair? x) From f176c584d0513f4dea82329011f81f114f3a8ec9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 11:35:23 +0200 Subject: [PATCH 078/375] fix module-bound?, start compiling srfi-18.scm * module/Makefile.am (SRFI_SOURCES): Let's finally start compiling srfi-18.scm, what the hell. * module/ice-9/boot-9.scm (module-bound?): module-bound? was returning true if (not (variable-bound? (module-local-variable m v))), but (variable-bound? (module-variable m v)). Fix to cut out on the first variable it finds. This bug has been there for a while now. --- module/Makefile.am | 4 ++-- module/ice-9/boot-9.scm | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/module/Makefile.am b/module/Makefile.am index 28372c7e7..baa91b9af 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -189,6 +189,7 @@ SRFI_SOURCES = \ srfi/srfi-14.scm \ srfi/srfi-16.scm \ srfi/srfi-17.scm \ + srfi/srfi-18.scm \ srfi/srfi-19.scm \ srfi/srfi-26.scm \ srfi/srfi-31.scm \ @@ -243,5 +244,4 @@ NOCOMP_SOURCES = \ ice-9/debugging/steps.scm \ ice-9/debugging/trace.scm \ ice-9/debugging/traps.scm \ - ice-9/debugging/trc.scm \ - srfi/srfi-18.scm + ice-9/debugging/trc.scm diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index b9484b79c..e529e2538 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1405,7 +1405,9 @@ ;; or its uses? ;; (define (module-bound? m v) - (module-search module-locally-bound? m v)) + (let ((var (module-variable m v))) + (and var + (variable-bound? var)))) ;;; {Is a symbol interned in a module?} ;;; From 00bbb89e9694faac612ecf2e234291df086ebd11 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 11:48:29 +0200 Subject: [PATCH 079/375] remove sc-macro definition * module/ice-9/boot-9.scm (sc-macro): Remove sc-macro definition, yay. --- module/ice-9/boot-9.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index e529e2538..5becaa8a3 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -140,7 +140,6 @@ '(guile)) (define (module-add! module sym var) (hashq-set! (%get-pre-modules-obarray) sym var)) -(define sc-macro 'sc-macro) (define (make-module-ref mod var kind) (case kind ((public) (if mod `(@ ,mod ,var) var)) From 165a7596ee62a2871de8569e3d41ef7f7c925594 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 13:10:30 +0200 Subject: [PATCH 080/375] add module-{define-keyword!,undefine-keyword!,lookup-keyword} * libguile/modules.c (scm_module_local_variable): Allow this to be called before modules are booted with #f as the module. * module/ice-9/boot-9.scm (module-define-keyword!) (module-lookup-keyword, module-undefine-keyword!): Well, if syncase forces us to allow the keyword bindings to be partitioned from value bindings, let's go ahead and do that in boot-9 instead of in psyntax. A step on the way to removing `install-global-transformer'. (sc-chi): Remove. * module/ice-9/psyntax.scm (put-global-definition-hook): (remove-global-definition-hook, get-global-definition-hook): Use our new module-* functions. (sc-chi): Remove, no longer needed. * module/ice-9/psyntax-pp.scm: Regenerated. --- libguile/modules.c | 4 ++-- module/ice-9/boot-9.scm | 25 ++++++++++++++++++++++++- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 30 +++++++----------------------- 4 files changed, 44 insertions(+), 37 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index 2cb8a7620..689510ce6 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -412,13 +412,13 @@ SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0, register SCM b; - /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being - evaluated. */ if (scm_module_system_booted_p) SCM_VALIDATE_MODULE (1, module); SCM_VALIDATE_SYMBOL (2, sym); + if (scm_is_false (module)) + return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED); /* 1. Check module obarray */ b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5becaa8a3..356a2416d 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -156,9 +156,32 @@ (define (resolve-module . args) #f) +;;; Here we use "keyword" in the sense that R6RS uses it, as in "a +;;; definition may be a keyword definition or a variable definition". +;;; Keywords are syntactic bindings; variables are value bindings. +(define (module-define-keyword! mod sym type val) + (let ((v (or (module-local-variable mod sym) + (let ((v (make-variable val))) + (module-add! mod sym v) + v)))) + (if (or (not (variable-bound? v)) + (not (macro? (variable-ref v)))) + (variable-set! v val)) + (set-object-property! v '*sc-expander* (cons type val)))) + +(define (module-lookup-keyword mod sym) + (let ((v (module-variable mod sym))) + (and v (object-property v '*sc-expander*)))) + +(define (module-undefine-keyword! mod sym) + (let ((v (module-local-variable mod sym))) + (if v + (let ((p (assq '*sc-expander* (object-properties v)))) + ;; probably should unbind the variable too + (set-object-properties! v (delq p (object-properties v))))))) + (define sc-expand #f) (define sc-expand3 #f) -(define sc-chi #f) (define install-global-transformer #f) (define syntax-dispatch #f) (define syntax-error #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 37b02c455..09e35e360 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1165 (lambda (vars1370) (let lvl1371 ((vars1372 vars1370) (ls1373 (quote ())) (w1374 (quote (())))) (cond ((pair? vars1372) (lvl1371 (cdr vars1372) (cons (wrap1144 (car vars1372) w1374 #f) ls1373) w1374)) ((id?1116 vars1372) (cons (wrap1144 vars1372 w1374 #f) ls1373)) ((null? vars1372) ls1373) ((syntax-object?1100 vars1372) (lvl1371 (syntax-object-expression1101 vars1372) ls1373 (join-wraps1135 w1374 (syntax-object-wrap1102 vars1372)))) ((annotation? vars1372) (lvl1371 (annotation-expression vars1372) ls1373 w1374)) (else (cons vars1372 ls1373)))))) (gen-var1164 (lambda (id1375) (let ((id1376 (if (syntax-object?1100 id1375) (syntax-object-expression1101 id1375) id1375))) (if (annotation? id1376) (build-annotated1093 (annotation-source id1376) (gensym (symbol->string (annotation-expression id1376)))) (build-annotated1093 #f (gensym (symbol->string id1376))))))) (strip1163 (lambda (x1377 w1378) (if (memq (quote top) (wrap-marks1119 w1378)) (if (or (annotation? x1377) (and (pair? x1377) (annotation? (car x1377)))) (strip-annotation1162 x1377 #f) x1377) (let f1379 ((x1380 x1377)) (cond ((syntax-object?1100 x1380) (strip1163 (syntax-object-expression1101 x1380) (syntax-object-wrap1102 x1380))) ((pair? x1380) (let ((a1381 (f1379 (car x1380))) (d1382 (f1379 (cdr x1380)))) (if (and (eq? a1381 (car x1380)) (eq? d1382 (cdr x1380))) x1380 (cons a1381 d1382)))) ((vector? x1380) (let ((old1383 (vector->list x1380))) (let ((new1384 (map f1379 old1383))) (if (andmap eq? old1383 new1384) x1380 (list->vector new1384))))) (else x1380)))))) (strip-annotation1162 (lambda (x1385 parent1386) (cond ((pair? x1385) (let ((new1387 (cons #f #f))) (begin (if parent1386 (set-annotation-stripped! parent1386 new1387)) (set-car! new1387 (strip-annotation1162 (car x1385) #f)) (set-cdr! new1387 (strip-annotation1162 (cdr x1385) #f)) new1387))) ((annotation? x1385) (or (annotation-stripped x1385) (strip-annotation1162 (annotation-expression x1385) x1385))) ((vector? x1385) (let ((new1388 (make-vector (vector-length x1385)))) (begin (if parent1386 (set-annotation-stripped! parent1386 new1388)) (let loop1389 ((i1390 (- (vector-length x1385) 1))) (unless (fx<1086 i1390 0) (vector-set! new1388 i1390 (strip-annotation1162 (vector-ref x1385 i1390) #f)) (loop1389 (fx-1084 i1390 1)))) new1388))) (else x1385)))) (ellipsis?1161 (lambda (x1391) (and (nonsymbol-id?1115 x1391) (free-id=?1139 x1391 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1160 (lambda () (build-annotated1093 #f (list (build-annotated1093 #f (quote void)))))) (eval-local-transformer1159 (lambda (expanded1392 mod1393) (let ((p1394 (local-eval-hook1088 expanded1392 mod1393))) (if (procedure? p1394) p1394 (syntax-error p1394 "nonprocedure transformer"))))) (chi-local-syntax1158 (lambda (rec?1395 e1396 r1397 w1398 s1399 mod1400 k1401) ((lambda (tmp1402) ((lambda (tmp1403) (if tmp1403 (apply (lambda (_1404 id1405 val1406 e11407 e21408) (let ((ids1409 id1405)) (if (not (valid-bound-ids?1141 ids1409)) (syntax-error e1396 "duplicate bound keyword in") (let ((labels1411 (gen-labels1122 ids1409))) (let ((new-w1412 (make-binding-wrap1133 ids1409 labels1411 w1398))) (k1401 (cons e11407 e21408) (extend-env1110 labels1411 (let ((w1414 (if rec?1395 new-w1412 w1398)) (trans-r1415 (macros-only-env1112 r1397))) (map (lambda (x1416) (cons (quote macro) (eval-local-transformer1159 (chi1152 x1416 trans-r1415 w1414 mod1400) mod1400))) val1406)) r1397) new-w1412 s1399 mod1400)))))) tmp1403) ((lambda (_1418) (syntax-error (source-wrap1145 e1396 w1398 s1399 mod1400))) tmp1402))) (syntax-dispatch tmp1402 (quote (any #(each (any any)) any . each-any))))) e1396))) (chi-lambda-clause1157 (lambda (e1419 docstring1420 c1421 r1422 w1423 mod1424 k1425) ((lambda (tmp1426) ((lambda (tmp1427) (if (if tmp1427 (apply (lambda (args1428 doc1429 e11430 e21431) (and (string? (syntax-object->datum doc1429)) (not docstring1420))) tmp1427) #f) (apply (lambda (args1432 doc1433 e11434 e21435) (chi-lambda-clause1157 e1419 doc1433 (cons args1432 (cons e11434 e21435)) r1422 w1423 mod1424 k1425)) tmp1427) ((lambda (tmp1437) (if tmp1437 (apply (lambda (id1438 e11439 e21440) (let ((ids1441 id1438)) (if (not (valid-bound-ids?1141 ids1441)) (syntax-error e1419 "invalid parameter list in") (let ((labels1443 (gen-labels1122 ids1441)) (new-vars1444 (map gen-var1164 ids1441))) (k1425 new-vars1444 docstring1420 (chi-body1156 (cons e11439 e21440) e1419 (extend-var-env1111 labels1443 new-vars1444 r1422) (make-binding-wrap1133 ids1441 labels1443 w1423) mod1424)))))) tmp1437) ((lambda (tmp1446) (if tmp1446 (apply (lambda (ids1447 e11448 e21449) (let ((old-ids1450 (lambda-var-list1165 ids1447))) (if (not (valid-bound-ids?1141 old-ids1450)) (syntax-error e1419 "invalid parameter list in") (let ((labels1451 (gen-labels1122 old-ids1450)) (new-vars1452 (map gen-var1164 old-ids1450))) (k1425 (let f1453 ((ls11454 (cdr new-vars1452)) (ls21455 (car new-vars1452))) (if (null? ls11454) ls21455 (f1453 (cdr ls11454) (cons (car ls11454) ls21455)))) docstring1420 (chi-body1156 (cons e11448 e21449) e1419 (extend-var-env1111 labels1451 new-vars1452 r1422) (make-binding-wrap1133 old-ids1450 labels1451 w1423) mod1424)))))) tmp1446) ((lambda (_1457) (syntax-error e1419)) tmp1426))) (syntax-dispatch tmp1426 (quote (any any . each-any)))))) (syntax-dispatch tmp1426 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1426 (quote (any any any . each-any))))) c1421))) (chi-body1156 (lambda (body1458 outer-form1459 r1460 w1461 mod1462) (let ((r1463 (cons (quote ("placeholder" placeholder)) r1460))) (let ((ribcage1464 (make-ribcage1123 (quote ()) (quote ()) (quote ())))) (let ((w1465 (make-wrap1118 (wrap-marks1119 w1461) (cons ribcage1464 (wrap-subst1120 w1461))))) (let parse1466 ((body1467 (map (lambda (x1473) (cons r1463 (wrap1144 x1473 w1465 mod1462))) body1458)) (ids1468 (quote ())) (labels1469 (quote ())) (vars1470 (quote ())) (vals1471 (quote ())) (bindings1472 (quote ()))) (if (null? body1467) (syntax-error outer-form1459 "no expressions in body") (let ((e1474 (cdar body1467)) (er1475 (caar body1467))) (call-with-values (lambda () (syntax-type1150 e1474 er1475 (quote (())) #f ribcage1464 mod1462)) (lambda (type1476 value1477 e1478 w1479 s1480 mod1481) (let ((t1482 type1476)) (if (memv t1482 (quote (define-form))) (let ((id1483 (wrap1144 value1477 w1479 mod1481)) (label1484 (gen-label1121))) (let ((var1485 (gen-var1164 id1483))) (begin (extend-ribcage!1132 ribcage1464 id1483 label1484) (parse1466 (cdr body1467) (cons id1483 ids1468) (cons label1484 labels1469) (cons var1485 vars1470) (cons (cons er1475 (wrap1144 e1478 w1479 mod1481)) vals1471) (cons (cons (quote lexical) var1485) bindings1472))))) (if (memv t1482 (quote (define-syntax-form))) (let ((id1486 (wrap1144 value1477 w1479 mod1481)) (label1487 (gen-label1121))) (begin (extend-ribcage!1132 ribcage1464 id1486 label1487) (parse1466 (cdr body1467) (cons id1486 ids1468) (cons label1487 labels1469) vars1470 vals1471 (cons (cons (quote macro) (cons er1475 (wrap1144 e1478 w1479 mod1481))) bindings1472)))) (if (memv t1482 (quote (begin-form))) ((lambda (tmp1488) ((lambda (tmp1489) (if tmp1489 (apply (lambda (_1490 e11491) (parse1466 (let f1492 ((forms1493 e11491)) (if (null? forms1493) (cdr body1467) (cons (cons er1475 (wrap1144 (car forms1493) w1479 mod1481)) (f1492 (cdr forms1493))))) ids1468 labels1469 vars1470 vals1471 bindings1472)) tmp1489) (syntax-error tmp1488))) (syntax-dispatch tmp1488 (quote (any . each-any))))) e1478) (if (memv t1482 (quote (local-syntax-form))) (chi-local-syntax1158 value1477 e1478 er1475 w1479 s1480 mod1481 (lambda (forms1495 er1496 w1497 s1498 mod1499) (parse1466 (let f1500 ((forms1501 forms1495)) (if (null? forms1501) (cdr body1467) (cons (cons er1496 (wrap1144 (car forms1501) w1497 mod1499)) (f1500 (cdr forms1501))))) ids1468 labels1469 vars1470 vals1471 bindings1472))) (if (null? ids1468) (build-sequence1095 #f (map (lambda (x1502) (chi1152 (cdr x1502) (car x1502) (quote (())) mod1481)) (cons (cons er1475 (source-wrap1145 e1478 w1479 s1480 mod1481)) (cdr body1467)))) (begin (if (not (valid-bound-ids?1141 ids1468)) (syntax-error outer-form1459 "invalid or duplicate identifier in definition")) (let loop1503 ((bs1504 bindings1472) (er-cache1505 #f) (r-cache1506 #f)) (if (not (null? bs1504)) (let ((b1507 (car bs1504))) (if (eq? (car b1507) (quote macro)) (let ((er1508 (cadr b1507))) (let ((r-cache1509 (if (eq? er1508 er-cache1505) r-cache1506 (macros-only-env1112 er1508)))) (begin (set-cdr! b1507 (eval-local-transformer1159 (chi1152 (cddr b1507) r-cache1509 (quote (())) mod1481) mod1481)) (loop1503 (cdr bs1504) er1508 r-cache1509)))) (loop1503 (cdr bs1504) er-cache1505 r-cache1506))))) (set-cdr! r1463 (extend-env1110 labels1469 bindings1472 (cdr r1463))) (build-letrec1098 #f vars1470 (map (lambda (x1510) (chi1152 (cdr x1510) (car x1510) (quote (())) mod1481)) vals1471) (build-sequence1095 #f (map (lambda (x1511) (chi1152 (cdr x1511) (car x1511) (quote (())) mod1481)) (cons (cons er1475 (source-wrap1145 e1478 w1479 s1480 mod1481)) (cdr body1467)))))))))))))))))))))) (chi-macro1155 (lambda (p1512 e1513 r1514 w1515 rib1516 mod1517) (letrec ((rebuild-macro-output1518 (lambda (x1519 m1520) (cond ((pair? x1519) (cons (rebuild-macro-output1518 (car x1519) m1520) (rebuild-macro-output1518 (cdr x1519) m1520))) ((syntax-object?1100 x1519) (let ((w1521 (syntax-object-wrap1102 x1519))) (let ((ms1522 (wrap-marks1119 w1521)) (s1523 (wrap-subst1120 w1521))) (if (and (pair? ms1522) (eq? (car ms1522) #f)) (make-syntax-object1099 (syntax-object-expression1101 x1519) (make-wrap1118 (cdr ms1522) (if rib1516 (cons rib1516 (cdr s1523)) (cdr s1523))) (syntax-object-module1103 x1519)) (make-syntax-object1099 (syntax-object-expression1101 x1519) (make-wrap1118 (cons m1520 ms1522) (if rib1516 (cons rib1516 (cons (quote shift) s1523)) (cons (quote shift) s1523))) (let ((pmod1524 (procedure-module p1512))) (if pmod1524 (cons (quote hygiene) (module-name pmod1524)) (quote (hygiene guile))))))))) ((vector? x1519) (let ((n1525 (vector-length x1519))) (let ((v1526 (make-vector n1525))) (let doloop1527 ((i1528 0)) (if (fx=1085 i1528 n1525) v1526 (begin (vector-set! v1526 i1528 (rebuild-macro-output1518 (vector-ref x1519 i1528) m1520)) (doloop1527 (fx+1083 i1528 1)))))))) ((symbol? x1519) (syntax-error x1519 "encountered raw symbol in macro output")) (else x1519))))) (rebuild-macro-output1518 (p1512 (wrap1144 e1513 (anti-mark1131 w1515) mod1517)) (string #\m))))) (chi-application1154 (lambda (x1529 e1530 r1531 w1532 s1533 mod1534) ((lambda (tmp1535) ((lambda (tmp1536) (if tmp1536 (apply (lambda (e01537 e11538) (build-annotated1093 s1533 (cons x1529 (map (lambda (e1539) (chi1152 e1539 r1531 w1532 mod1534)) e11538)))) tmp1536) (syntax-error tmp1535))) (syntax-dispatch tmp1535 (quote (any . each-any))))) e1530))) (chi-expr1153 (lambda (type1541 value1542 e1543 r1544 w1545 s1546 mod1547) (let ((t1548 type1541)) (if (memv t1548 (quote (lexical))) (build-annotated1093 s1546 value1542) (if (memv t1548 (quote (core external-macro))) (value1542 e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (module-ref))) (call-with-values (lambda () (value1542 e1543)) (lambda (id1549 mod1550) (build-annotated1093 s1546 (if mod1550 (make-module-ref (cdr mod1550) id1549 (car mod1550)) (make-module-ref mod1550 id1549 (quote bare)))))) (if (memv t1548 (quote (lexical-call))) (chi-application1154 (build-annotated1093 (source-annotation1107 (car e1543)) value1542) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (global-call))) (chi-application1154 (build-annotated1093 (source-annotation1107 (car e1543)) (if (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547) (make-module-ref (cdr (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547)) value1542 (car (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547))) (make-module-ref (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547) value1542 (quote bare)))) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (constant))) (build-data1094 s1546 (strip1163 (source-wrap1145 e1543 w1545 s1546 mod1547) (quote (())))) (if (memv t1548 (quote (global))) (build-annotated1093 s1546 (if mod1547 (make-module-ref (cdr mod1547) value1542 (car mod1547)) (make-module-ref mod1547 value1542 (quote bare)))) (if (memv t1548 (quote (call))) (chi-application1154 (chi1152 (car e1543) r1544 w1545 mod1547) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (begin-form))) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e11554 e21555) (chi-sequence1146 (cons e11554 e21555) r1544 w1545 s1546 mod1547)) tmp1552) (syntax-error tmp1551))) (syntax-dispatch tmp1551 (quote (any any . each-any))))) e1543) (if (memv t1548 (quote (local-syntax-form))) (chi-local-syntax1158 value1542 e1543 r1544 w1545 s1546 mod1547 chi-sequence1146) (if (memv t1548 (quote (eval-when-form))) ((lambda (tmp1557) ((lambda (tmp1558) (if tmp1558 (apply (lambda (_1559 x1560 e11561 e21562) (let ((when-list1563 (chi-when-list1149 e1543 x1560 w1545))) (if (memq (quote eval) when-list1563) (chi-sequence1146 (cons e11561 e21562) r1544 w1545 s1546 mod1547) (chi-void1160)))) tmp1558) (syntax-error tmp1557))) (syntax-dispatch tmp1557 (quote (any each-any any . each-any))))) e1543) (if (memv t1548 (quote (define-form define-syntax-form))) (syntax-error (wrap1144 value1542 w1545 mod1547) "invalid context for definition of") (if (memv t1548 (quote (syntax))) (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547) "reference to pattern variable outside syntax form") (if (memv t1548 (quote (displaced-lexical))) (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547) "reference to identifier outside its scope") (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547))))))))))))))))))) (chi1152 (lambda (e1566 r1567 w1568 mod1569) (call-with-values (lambda () (syntax-type1150 e1566 r1567 w1568 #f #f mod1569)) (lambda (type1570 value1571 e1572 w1573 s1574 mod1575) (chi-expr1153 type1570 value1571 e1572 r1567 w1573 s1574 mod1575))))) (chi-top1151 (lambda (e1576 r1577 w1578 m1579 esew1580 mod1581) (call-with-values (lambda () (syntax-type1150 e1576 r1577 w1578 #f #f mod1581)) (lambda (type1589 value1590 e1591 w1592 s1593 mod1594) (let ((t1595 type1589)) (if (memv t1595 (quote (begin-form))) ((lambda (tmp1596) ((lambda (tmp1597) (if tmp1597 (apply (lambda (_1598) (chi-void1160)) tmp1597) ((lambda (tmp1599) (if tmp1599 (apply (lambda (_1600 e11601 e21602) (chi-top-sequence1147 (cons e11601 e21602) r1577 w1592 s1593 m1579 esew1580 mod1594)) tmp1599) (syntax-error tmp1596))) (syntax-dispatch tmp1596 (quote (any any . each-any)))))) (syntax-dispatch tmp1596 (quote (any))))) e1591) (if (memv t1595 (quote (local-syntax-form))) (chi-local-syntax1158 value1590 e1591 r1577 w1592 s1593 mod1594 (lambda (body1604 r1605 w1606 s1607 mod1608) (chi-top-sequence1147 body1604 r1605 w1606 s1607 m1579 esew1580 mod1608))) (if (memv t1595 (quote (eval-when-form))) ((lambda (tmp1609) ((lambda (tmp1610) (if tmp1610 (apply (lambda (_1611 x1612 e11613 e21614) (let ((when-list1615 (chi-when-list1149 e1591 x1612 w1592)) (body1616 (cons e11613 e21614))) (cond ((eq? m1579 (quote e)) (if (memq (quote eval) when-list1615) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote e) (quote (eval)) mod1594) (chi-void1160))) ((memq (quote load) when-list1615) (if (or (memq (quote compile) when-list1615) (and (eq? m1579 (quote c&e)) (memq (quote eval) when-list1615))) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote c&e) (quote (compile load)) mod1594) (if (memq m1579 (quote (c c&e))) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote c) (quote (load)) mod1594) (chi-void1160)))) ((or (memq (quote compile) when-list1615) (and (eq? m1579 (quote c&e)) (memq (quote eval) when-list1615))) (top-level-eval-hook1087 (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote e) (quote (eval)) mod1594) mod1594) (chi-void1160)) (else (chi-void1160))))) tmp1610) (syntax-error tmp1609))) (syntax-dispatch tmp1609 (quote (any each-any any . each-any))))) e1591) (if (memv t1595 (quote (define-syntax-form))) (let ((n1619 (id-var-name1138 value1590 w1592)) (r1620 (macros-only-env1112 r1577))) (let ((t1621 m1579)) (if (memv t1621 (quote (c))) (if (memq (quote compile) esew1580) (let ((e1622 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)))) (begin (top-level-eval-hook1087 e1622 mod1594) (if (memq (quote load) esew1580) e1622 (chi-void1160)))) (if (memq (quote load) esew1580) (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)) (chi-void1160))) (if (memv t1621 (quote (c&e))) (let ((e1623 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)))) (begin (top-level-eval-hook1087 e1623 mod1594) e1623)) (begin (if (memq (quote eval) esew1580) (top-level-eval-hook1087 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)) mod1594)) (chi-void1160)))))) (if (memv t1595 (quote (define-form))) (let ((n1624 (id-var-name1138 value1590 w1592))) (let ((type1625 (binding-type1108 (lookup1113 n1624 r1577 mod1594)))) (let ((t1626 type1625)) (if (memv t1626 (quote (global))) (let ((x1627 (build-annotated1093 s1593 (list (quote define) n1624 (chi1152 e1591 r1577 w1592 mod1594))))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1627 mod1594)) x1627)) (if (memv t1626 (quote (displaced-lexical))) (syntax-error (wrap1144 value1590 w1592 mod1594) "identifier out of context") (if (memv t1626 (quote (core macro module-ref))) (begin (remove-global-definition-hook1091 n1624) (let ((x1628 (build-annotated1093 s1593 (list (quote define) n1624 (chi1152 e1591 r1577 w1592 mod1594))))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1628 mod1594)) x1628))) (syntax-error (wrap1144 value1590 w1592 mod1594) "cannot define keyword at top level"))))))) (let ((x1629 (chi-expr1153 type1589 value1590 e1591 r1577 w1592 s1593 mod1594))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1629 mod1594)) x1629)))))))))))) (syntax-type1150 (lambda (e1630 r1631 w1632 s1633 rib1634 mod1635) (cond ((symbol? e1630) (let ((n1636 (id-var-name1138 e1630 w1632))) (let ((b1637 (lookup1113 n1636 r1631 mod1635))) (let ((type1638 (binding-type1108 b1637))) (let ((t1639 type1638)) (if (memv t1639 (quote (lexical))) (values type1638 (binding-value1109 b1637) e1630 w1632 s1633 mod1635) (if (memv t1639 (quote (global))) (values type1638 n1636 e1630 w1632 s1633 mod1635) (if (memv t1639 (quote (macro))) (syntax-type1150 (chi-macro1155 (binding-value1109 b1637) e1630 r1631 w1632 rib1634 mod1635) r1631 (quote (())) s1633 rib1634 mod1635) (values type1638 (binding-value1109 b1637) e1630 w1632 s1633 mod1635))))))))) ((pair? e1630) (let ((first1640 (car e1630))) (if (id?1116 first1640) (let ((n1641 (id-var-name1138 first1640 w1632))) (let ((b1642 (lookup1113 n1641 r1631 (or (and (syntax-object?1100 first1640) (syntax-object-module1103 first1640)) mod1635)))) (let ((type1643 (binding-type1108 b1642))) (let ((t1644 type1643)) (if (memv t1644 (quote (lexical))) (values (quote lexical-call) (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (global))) (values (quote global-call) n1641 e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (macro))) (syntax-type1150 (chi-macro1155 (binding-value1109 b1642) e1630 r1631 w1632 rib1634 mod1635) r1631 (quote (())) s1633 rib1634 mod1635) (if (memv t1644 (quote (core external-macro module-ref))) (values type1643 (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (begin))) (values (quote begin-form) #f e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (eval-when))) (values (quote eval-when-form) #f e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (define))) ((lambda (tmp1645) ((lambda (tmp1646) (if (if tmp1646 (apply (lambda (_1647 name1648 val1649) (id?1116 name1648)) tmp1646) #f) (apply (lambda (_1650 name1651 val1652) (values (quote define-form) name1651 val1652 w1632 s1633 mod1635)) tmp1646) ((lambda (tmp1653) (if (if tmp1653 (apply (lambda (_1654 name1655 args1656 e11657 e21658) (and (id?1116 name1655) (valid-bound-ids?1141 (lambda-var-list1165 args1656)))) tmp1653) #f) (apply (lambda (_1659 name1660 args1661 e11662 e21663) (values (quote define-form) (wrap1144 name1660 w1632 mod1635) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1144 (cons args1661 (cons e11662 e21663)) w1632 mod1635)) (quote (())) s1633 mod1635)) tmp1653) ((lambda (tmp1665) (if (if tmp1665 (apply (lambda (_1666 name1667) (id?1116 name1667)) tmp1665) #f) (apply (lambda (_1668 name1669) (values (quote define-form) (wrap1144 name1669 w1632 mod1635) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1633 mod1635)) tmp1665) (syntax-error tmp1645))) (syntax-dispatch tmp1645 (quote (any any)))))) (syntax-dispatch tmp1645 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1645 (quote (any any any))))) e1630) (if (memv t1644 (quote (define-syntax))) ((lambda (tmp1670) ((lambda (tmp1671) (if (if tmp1671 (apply (lambda (_1672 name1673 val1674) (id?1116 name1673)) tmp1671) #f) (apply (lambda (_1675 name1676 val1677) (values (quote define-syntax-form) name1676 val1677 w1632 s1633 mod1635)) tmp1671) (syntax-error tmp1670))) (syntax-dispatch tmp1670 (quote (any any any))))) e1630) (values (quote call) #f e1630 w1632 s1633 mod1635)))))))))))))) (values (quote call) #f e1630 w1632 s1633 mod1635)))) ((syntax-object?1100 e1630) (syntax-type1150 (syntax-object-expression1101 e1630) r1631 (join-wraps1135 w1632 (syntax-object-wrap1102 e1630)) #f rib1634 (or (syntax-object-module1103 e1630) mod1635))) ((annotation? e1630) (syntax-type1150 (annotation-expression e1630) r1631 w1632 (annotation-source e1630) rib1634 mod1635)) ((self-evaluating? e1630) (values (quote constant) #f e1630 w1632 s1633 mod1635)) (else (values (quote other) #f e1630 w1632 s1633 mod1635))))) (chi-when-list1149 (lambda (e1678 when-list1679 w1680) (let f1681 ((when-list1682 when-list1679) (situations1683 (quote ()))) (if (null? when-list1682) situations1683 (f1681 (cdr when-list1682) (cons (let ((x1684 (car when-list1682))) (cond ((free-id=?1139 x1684 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1139 x1684 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1139 x1684 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1144 x1684 w1680 #f) "invalid eval-when situation")))) situations1683)))))) (chi-install-global1148 (lambda (name1685 e1686) (build-annotated1093 #f (list (build-annotated1093 #f (quote install-global-transformer)) (build-data1094 #f name1685) e1686)))) (chi-top-sequence1147 (lambda (body1687 r1688 w1689 s1690 m1691 esew1692 mod1693) (build-sequence1095 s1690 (let dobody1694 ((body1695 body1687) (r1696 r1688) (w1697 w1689) (m1698 m1691) (esew1699 esew1692) (mod1700 mod1693)) (if (null? body1695) (quote ()) (let ((first1701 (chi-top1151 (car body1695) r1696 w1697 m1698 esew1699 mod1700))) (cons first1701 (dobody1694 (cdr body1695) r1696 w1697 m1698 esew1699 mod1700)))))))) (chi-sequence1146 (lambda (body1702 r1703 w1704 s1705 mod1706) (build-sequence1095 s1705 (let dobody1707 ((body1708 body1702) (r1709 r1703) (w1710 w1704) (mod1711 mod1706)) (if (null? body1708) (quote ()) (let ((first1712 (chi1152 (car body1708) r1709 w1710 mod1711))) (cons first1712 (dobody1707 (cdr body1708) r1709 w1710 mod1711)))))))) (source-wrap1145 (lambda (x1713 w1714 s1715 defmod1716) (wrap1144 (if s1715 (make-annotation x1713 s1715 #f) x1713) w1714 defmod1716))) (wrap1144 (lambda (x1717 w1718 defmod1719) (cond ((and (null? (wrap-marks1119 w1718)) (null? (wrap-subst1120 w1718))) x1717) ((syntax-object?1100 x1717) (make-syntax-object1099 (syntax-object-expression1101 x1717) (join-wraps1135 w1718 (syntax-object-wrap1102 x1717)) (syntax-object-module1103 x1717))) ((null? x1717) x1717) (else (make-syntax-object1099 x1717 w1718 defmod1719))))) (bound-id-member?1143 (lambda (x1720 list1721) (and (not (null? list1721)) (or (bound-id=?1140 x1720 (car list1721)) (bound-id-member?1143 x1720 (cdr list1721)))))) (distinct-bound-ids?1142 (lambda (ids1722) (let distinct?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (not (bound-id-member?1143 (car ids1724) (cdr ids1724))) (distinct?1723 (cdr ids1724))))))) (valid-bound-ids?1141 (lambda (ids1725) (and (let all-ids?1726 ((ids1727 ids1725)) (or (null? ids1727) (and (id?1116 (car ids1727)) (all-ids?1726 (cdr ids1727))))) (distinct-bound-ids?1142 ids1725)))) (bound-id=?1140 (lambda (i1728 j1729) (if (and (syntax-object?1100 i1728) (syntax-object?1100 j1729)) (and (eq? (let ((e1730 (syntax-object-expression1101 i1728))) (if (annotation? e1730) (annotation-expression e1730) e1730)) (let ((e1731 (syntax-object-expression1101 j1729))) (if (annotation? e1731) (annotation-expression e1731) e1731))) (same-marks?1137 (wrap-marks1119 (syntax-object-wrap1102 i1728)) (wrap-marks1119 (syntax-object-wrap1102 j1729)))) (eq? (let ((e1732 i1728)) (if (annotation? e1732) (annotation-expression e1732) e1732)) (let ((e1733 j1729)) (if (annotation? e1733) (annotation-expression e1733) e1733)))))) (free-id=?1139 (lambda (i1734 j1735) (and (eq? (let ((x1736 i1734)) (let ((e1737 (if (syntax-object?1100 x1736) (syntax-object-expression1101 x1736) x1736))) (if (annotation? e1737) (annotation-expression e1737) e1737))) (let ((x1738 j1735)) (let ((e1739 (if (syntax-object?1100 x1738) (syntax-object-expression1101 x1738) x1738))) (if (annotation? e1739) (annotation-expression e1739) e1739)))) (eq? (id-var-name1138 i1734 (quote (()))) (id-var-name1138 j1735 (quote (()))))))) (id-var-name1138 (lambda (id1740 w1741) (letrec ((search-vector-rib1744 (lambda (sym1750 subst1751 marks1752 symnames1753 ribcage1754) (let ((n1755 (vector-length symnames1753))) (let f1756 ((i1757 0)) (cond ((fx=1085 i1757 n1755) (search1742 sym1750 (cdr subst1751) marks1752)) ((and (eq? (vector-ref symnames1753 i1757) sym1750) (same-marks?1137 marks1752 (vector-ref (ribcage-marks1126 ribcage1754) i1757))) (values (vector-ref (ribcage-labels1127 ribcage1754) i1757) marks1752)) (else (f1756 (fx+1083 i1757 1)))))))) (search-list-rib1743 (lambda (sym1758 subst1759 marks1760 symnames1761 ribcage1762) (let f1763 ((symnames1764 symnames1761) (i1765 0)) (cond ((null? symnames1764) (search1742 sym1758 (cdr subst1759) marks1760)) ((and (eq? (car symnames1764) sym1758) (same-marks?1137 marks1760 (list-ref (ribcage-marks1126 ribcage1762) i1765))) (values (list-ref (ribcage-labels1127 ribcage1762) i1765) marks1760)) (else (f1763 (cdr symnames1764) (fx+1083 i1765 1))))))) (search1742 (lambda (sym1766 subst1767 marks1768) (if (null? subst1767) (values #f marks1768) (let ((fst1769 (car subst1767))) (if (eq? fst1769 (quote shift)) (search1742 sym1766 (cdr subst1767) (cdr marks1768)) (let ((symnames1770 (ribcage-symnames1125 fst1769))) (if (vector? symnames1770) (search-vector-rib1744 sym1766 subst1767 marks1768 symnames1770 fst1769) (search-list-rib1743 sym1766 subst1767 marks1768 symnames1770 fst1769))))))))) (cond ((symbol? id1740) (or (call-with-values (lambda () (search1742 id1740 (wrap-subst1120 w1741) (wrap-marks1119 w1741))) (lambda (x1772 . ignore1771) x1772)) id1740)) ((syntax-object?1100 id1740) (let ((id1773 (let ((e1775 (syntax-object-expression1101 id1740))) (if (annotation? e1775) (annotation-expression e1775) e1775))) (w11774 (syntax-object-wrap1102 id1740))) (let ((marks1776 (join-marks1136 (wrap-marks1119 w1741) (wrap-marks1119 w11774)))) (call-with-values (lambda () (search1742 id1773 (wrap-subst1120 w1741) marks1776)) (lambda (new-id1777 marks1778) (or new-id1777 (call-with-values (lambda () (search1742 id1773 (wrap-subst1120 w11774) marks1778)) (lambda (x1780 . ignore1779) x1780)) id1773)))))) ((annotation? id1740) (let ((id1781 (let ((e1782 id1740)) (if (annotation? e1782) (annotation-expression e1782) e1782)))) (or (call-with-values (lambda () (search1742 id1781 (wrap-subst1120 w1741) (wrap-marks1119 w1741))) (lambda (x1784 . ignore1783) x1784)) id1781))) (else (error-hook1089 (quote id-var-name) "invalid id" id1740)))))) (same-marks?1137 (lambda (x1785 y1786) (or (eq? x1785 y1786) (and (not (null? x1785)) (not (null? y1786)) (eq? (car x1785) (car y1786)) (same-marks?1137 (cdr x1785) (cdr y1786)))))) (join-marks1136 (lambda (m11787 m21788) (smart-append1134 m11787 m21788))) (join-wraps1135 (lambda (w11789 w21790) (let ((m11791 (wrap-marks1119 w11789)) (s11792 (wrap-subst1120 w11789))) (if (null? m11791) (if (null? s11792) w21790 (make-wrap1118 (wrap-marks1119 w21790) (smart-append1134 s11792 (wrap-subst1120 w21790)))) (make-wrap1118 (smart-append1134 m11791 (wrap-marks1119 w21790)) (smart-append1134 s11792 (wrap-subst1120 w21790))))))) (smart-append1134 (lambda (m11793 m21794) (if (null? m21794) m11793 (append m11793 m21794)))) (make-binding-wrap1133 (lambda (ids1795 labels1796 w1797) (if (null? ids1795) w1797 (make-wrap1118 (wrap-marks1119 w1797) (cons (let ((labelvec1798 (list->vector labels1796))) (let ((n1799 (vector-length labelvec1798))) (let ((symnamevec1800 (make-vector n1799)) (marksvec1801 (make-vector n1799))) (begin (let f1802 ((ids1803 ids1795) (i1804 0)) (if (not (null? ids1803)) (call-with-values (lambda () (id-sym-name&marks1117 (car ids1803) w1797)) (lambda (symname1805 marks1806) (begin (vector-set! symnamevec1800 i1804 symname1805) (vector-set! marksvec1801 i1804 marks1806) (f1802 (cdr ids1803) (fx+1083 i1804 1))))))) (make-ribcage1123 symnamevec1800 marksvec1801 labelvec1798))))) (wrap-subst1120 w1797)))))) (extend-ribcage!1132 (lambda (ribcage1807 id1808 label1809) (begin (set-ribcage-symnames!1128 ribcage1807 (cons (let ((e1810 (syntax-object-expression1101 id1808))) (if (annotation? e1810) (annotation-expression e1810) e1810)) (ribcage-symnames1125 ribcage1807))) (set-ribcage-marks!1129 ribcage1807 (cons (wrap-marks1119 (syntax-object-wrap1102 id1808)) (ribcage-marks1126 ribcage1807))) (set-ribcage-labels!1130 ribcage1807 (cons label1809 (ribcage-labels1127 ribcage1807)))))) (anti-mark1131 (lambda (w1811) (make-wrap1118 (cons #f (wrap-marks1119 w1811)) (cons (quote shift) (wrap-subst1120 w1811))))) (set-ribcage-labels!1130 (lambda (x1812 update1813) (vector-set! x1812 3 update1813))) (set-ribcage-marks!1129 (lambda (x1814 update1815) (vector-set! x1814 2 update1815))) (set-ribcage-symnames!1128 (lambda (x1816 update1817) (vector-set! x1816 1 update1817))) (ribcage-labels1127 (lambda (x1818) (vector-ref x1818 3))) (ribcage-marks1126 (lambda (x1819) (vector-ref x1819 2))) (ribcage-symnames1125 (lambda (x1820) (vector-ref x1820 1))) (ribcage?1124 (lambda (x1821) (and (vector? x1821) (= (vector-length x1821) 4) (eq? (vector-ref x1821 0) (quote ribcage))))) (make-ribcage1123 (lambda (symnames1822 marks1823 labels1824) (vector (quote ribcage) symnames1822 marks1823 labels1824))) (gen-labels1122 (lambda (ls1825) (if (null? ls1825) (quote ()) (cons (gen-label1121) (gen-labels1122 (cdr ls1825)))))) (gen-label1121 (lambda () (string #\i))) (wrap-subst1120 cdr) (wrap-marks1119 car) (make-wrap1118 cons) (id-sym-name&marks1117 (lambda (x1826 w1827) (if (syntax-object?1100 x1826) (values (let ((e1828 (syntax-object-expression1101 x1826))) (if (annotation? e1828) (annotation-expression e1828) e1828)) (join-marks1136 (wrap-marks1119 w1827) (wrap-marks1119 (syntax-object-wrap1102 x1826)))) (values (let ((e1829 x1826)) (if (annotation? e1829) (annotation-expression e1829) e1829)) (wrap-marks1119 w1827))))) (id?1116 (lambda (x1830) (cond ((symbol? x1830) #t) ((syntax-object?1100 x1830) (symbol? (let ((e1831 (syntax-object-expression1101 x1830))) (if (annotation? e1831) (annotation-expression e1831) e1831)))) ((annotation? x1830) (symbol? (annotation-expression x1830))) (else #f)))) (nonsymbol-id?1115 (lambda (x1832) (and (syntax-object?1100 x1832) (symbol? (let ((e1833 (syntax-object-expression1101 x1832))) (if (annotation? e1833) (annotation-expression e1833) e1833)))))) (global-extend1114 (lambda (type1834 sym1835 val1836) (put-global-definition-hook1090 sym1835 type1834 val1836))) (lookup1113 (lambda (x1837 r1838 mod1839) (cond ((assq x1837 r1838) => cdr) ((symbol? x1837) (or (get-global-definition-hook1092 x1837 mod1839) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1112 (lambda (r1840) (if (null? r1840) (quote ()) (let ((a1841 (car r1840))) (if (eq? (cadr a1841) (quote macro)) (cons a1841 (macros-only-env1112 (cdr r1840))) (macros-only-env1112 (cdr r1840))))))) (extend-var-env1111 (lambda (labels1842 vars1843 r1844) (if (null? labels1842) r1844 (extend-var-env1111 (cdr labels1842) (cdr vars1843) (cons (cons (car labels1842) (cons (quote lexical) (car vars1843))) r1844))))) (extend-env1110 (lambda (labels1845 bindings1846 r1847) (if (null? labels1845) r1847 (extend-env1110 (cdr labels1845) (cdr bindings1846) (cons (cons (car labels1845) (car bindings1846)) r1847))))) (binding-value1109 cdr) (binding-type1108 car) (source-annotation1107 (lambda (x1848) (cond ((annotation? x1848) (annotation-source x1848)) ((syntax-object?1100 x1848) (source-annotation1107 (syntax-object-expression1101 x1848))) (else #f)))) (set-syntax-object-module!1106 (lambda (x1849 update1850) (vector-set! x1849 3 update1850))) (set-syntax-object-wrap!1105 (lambda (x1851 update1852) (vector-set! x1851 2 update1852))) (set-syntax-object-expression!1104 (lambda (x1853 update1854) (vector-set! x1853 1 update1854))) (syntax-object-module1103 (lambda (x1855) (vector-ref x1855 3))) (syntax-object-wrap1102 (lambda (x1856) (vector-ref x1856 2))) (syntax-object-expression1101 (lambda (x1857) (vector-ref x1857 1))) (syntax-object?1100 (lambda (x1858) (and (vector? x1858) (= (vector-length x1858) 4) (eq? (vector-ref x1858 0) (quote syntax-object))))) (make-syntax-object1099 (lambda (expression1859 wrap1860 module1861) (vector (quote syntax-object) expression1859 wrap1860 module1861))) (build-letrec1098 (lambda (src1862 vars1863 val-exps1864 body-exp1865) (if (null? vars1863) (build-annotated1093 src1862 body-exp1865) (build-annotated1093 src1862 (list (quote letrec) (map list vars1863 val-exps1864) body-exp1865))))) (build-named-let1097 (lambda (src1866 vars1867 val-exps1868 body-exp1869) (if (null? vars1867) (build-annotated1093 src1866 body-exp1869) (build-annotated1093 src1866 (list (quote let) (car vars1867) (map list (cdr vars1867) val-exps1868) body-exp1869))))) (build-let1096 (lambda (src1870 vars1871 val-exps1872 body-exp1873) (if (null? vars1871) (build-annotated1093 src1870 body-exp1873) (build-annotated1093 src1870 (list (quote let) (map list vars1871 val-exps1872) body-exp1873))))) (build-sequence1095 (lambda (src1874 exps1875) (if (null? (cdr exps1875)) (build-annotated1093 src1874 (car exps1875)) (build-annotated1093 src1874 (cons (quote begin) exps1875))))) (build-data1094 (lambda (src1876 exp1877) (if (and (self-evaluating? exp1877) (not (vector? exp1877))) (build-annotated1093 src1876 exp1877) (build-annotated1093 src1876 (list (quote quote) exp1877))))) (build-annotated1093 (lambda (src1878 exp1879) (if (and src1878 (not (annotation? exp1879))) (make-annotation exp1879 src1878 #t) exp1879))) (get-global-definition-hook1092 (lambda (symbol1880 module1881) (let ((module1882 (if module1881 (resolve-module (cdr module1881)) (let ((mod1883 (current-module))) (begin (if mod1883 (warn "wha" symbol1880)) mod1883))))) (let ((v1884 (module-variable module1882 symbol1880))) (and v1884 (object-property v1884 (quote *sc-expander*))))))) (remove-global-definition-hook1091 (lambda (symbol1885) (let ((module1886 (current-module))) (let ((v1887 (module-local-variable module1886 symbol1885))) (if v1887 (let ((p1888 (assq (quote *sc-expander*) (object-properties v1887)))) (set-object-properties! v1887 (delq p1888 (object-properties v1887))))))))) (put-global-definition-hook1090 (lambda (symbol1889 type1890 val1891) (let ((module1892 (current-module))) (let ((v1893 (or (module-variable module1892 symbol1889) (let ((v1894 (make-variable val1891))) (begin (module-add! module1892 symbol1889 v1894) v1894))))) (begin (if (not (variable-bound? v1893)) (variable-set! v1893 val1891)) (set-object-property! v1893 (quote *sc-expander*) (cons type1890 val1891))))))) (error-hook1089 (lambda (who1895 why1896 what1897) (error who1895 "~a ~s" why1896 what1897))) (local-eval-hook1088 (lambda (x1898 mod1899) (primitive-eval (list noexpand1082 x1898)))) (top-level-eval-hook1087 (lambda (x1900 mod1901) (primitive-eval (list noexpand1082 x1900)))) (fx<1086 <) (fx=1085 =) (fx-1084 -) (fx+1083 +) (noexpand1082 "noexpand")) (begin (global-extend1114 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1114 (quote local-syntax) (quote let-syntax) #f) (global-extend1114 (quote core) (quote fluid-let-syntax) (lambda (e1902 r1903 w1904 s1905 mod1906) ((lambda (tmp1907) ((lambda (tmp1908) (if (if tmp1908 (apply (lambda (_1909 var1910 val1911 e11912 e21913) (valid-bound-ids?1141 var1910)) tmp1908) #f) (apply (lambda (_1915 var1916 val1917 e11918 e21919) (let ((names1920 (map (lambda (x1921) (id-var-name1138 x1921 w1904)) var1916))) (begin (for-each (lambda (id1923 n1924) (let ((t1925 (binding-type1108 (lookup1113 n1924 r1903 mod1906)))) (if (memv t1925 (quote (displaced-lexical))) (syntax-error (source-wrap1145 id1923 w1904 s1905 mod1906) "identifier out of context")))) var1916 names1920) (chi-body1156 (cons e11918 e21919) (source-wrap1145 e1902 w1904 s1905 mod1906) (extend-env1110 names1920 (let ((trans-r1928 (macros-only-env1112 r1903))) (map (lambda (x1929) (cons (quote macro) (eval-local-transformer1159 (chi1152 x1929 trans-r1928 w1904 mod1906) mod1906))) val1917)) r1903) w1904 mod1906)))) tmp1908) ((lambda (_1931) (syntax-error (source-wrap1145 e1902 w1904 s1905 mod1906))) tmp1907))) (syntax-dispatch tmp1907 (quote (any #(each (any any)) any . each-any))))) e1902))) (global-extend1114 (quote core) (quote quote) (lambda (e1932 r1933 w1934 s1935 mod1936) ((lambda (tmp1937) ((lambda (tmp1938) (if tmp1938 (apply (lambda (_1939 e1940) (build-data1094 s1935 (strip1163 e1940 w1934))) tmp1938) ((lambda (_1941) (syntax-error (source-wrap1145 e1932 w1934 s1935 mod1936))) tmp1937))) (syntax-dispatch tmp1937 (quote (any any))))) e1932))) (global-extend1114 (quote core) (quote syntax) (letrec ((regen1949 (lambda (x1950) (let ((t1951 (car x1950))) (if (memv t1951 (quote (ref))) (build-annotated1093 #f (cadr x1950)) (if (memv t1951 (quote (primitive))) (build-annotated1093 #f (cadr x1950)) (if (memv t1951 (quote (quote))) (build-data1094 #f (cadr x1950)) (if (memv t1951 (quote (lambda))) (build-annotated1093 #f (list (quote lambda) (cadr x1950) (regen1949 (caddr x1950)))) (if (memv t1951 (quote (map))) (let ((ls1952 (map regen1949 (cdr x1950)))) (build-annotated1093 #f (cons (if (fx=1085 (length ls1952) 2) (build-annotated1093 #f (quote map)) (build-annotated1093 #f (quote map))) ls1952))) (build-annotated1093 #f (cons (build-annotated1093 #f (car x1950)) (map regen1949 (cdr x1950)))))))))))) (gen-vector1948 (lambda (x1953) (cond ((eq? (car x1953) (quote list)) (cons (quote vector) (cdr x1953))) ((eq? (car x1953) (quote quote)) (list (quote quote) (list->vector (cadr x1953)))) (else (list (quote list->vector) x1953))))) (gen-append1947 (lambda (x1954 y1955) (if (equal? y1955 (quote (quote ()))) x1954 (list (quote append) x1954 y1955)))) (gen-cons1946 (lambda (x1956 y1957) (let ((t1958 (car y1957))) (if (memv t1958 (quote (quote))) (if (eq? (car x1956) (quote quote)) (list (quote quote) (cons (cadr x1956) (cadr y1957))) (if (eq? (cadr y1957) (quote ())) (list (quote list) x1956) (list (quote cons) x1956 y1957))) (if (memv t1958 (quote (list))) (cons (quote list) (cons x1956 (cdr y1957))) (list (quote cons) x1956 y1957)))))) (gen-map1945 (lambda (e1959 map-env1960) (let ((formals1961 (map cdr map-env1960)) (actuals1962 (map (lambda (x1963) (list (quote ref) (car x1963))) map-env1960))) (cond ((eq? (car e1959) (quote ref)) (car actuals1962)) ((andmap (lambda (x1964) (and (eq? (car x1964) (quote ref)) (memq (cadr x1964) formals1961))) (cdr e1959)) (cons (quote map) (cons (list (quote primitive) (car e1959)) (map (let ((r1965 (map cons formals1961 actuals1962))) (lambda (x1966) (cdr (assq (cadr x1966) r1965)))) (cdr e1959))))) (else (cons (quote map) (cons (list (quote lambda) formals1961 e1959) actuals1962))))))) (gen-mappend1944 (lambda (e1967 map-env1968) (list (quote apply) (quote (primitive append)) (gen-map1945 e1967 map-env1968)))) (gen-ref1943 (lambda (src1969 var1970 level1971 maps1972) (if (fx=1085 level1971 0) (values var1970 maps1972) (if (null? maps1972) (syntax-error src1969 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1943 src1969 var1970 (fx-1084 level1971 1) (cdr maps1972))) (lambda (outer-var1973 outer-maps1974) (let ((b1975 (assq outer-var1973 (car maps1972)))) (if b1975 (values (cdr b1975) maps1972) (let ((inner-var1976 (gen-var1164 (quote tmp)))) (values inner-var1976 (cons (cons (cons outer-var1973 inner-var1976) (car maps1972)) outer-maps1974))))))))))) (gen-syntax1942 (lambda (src1977 e1978 r1979 maps1980 ellipsis?1981 mod1982) (if (id?1116 e1978) (let ((label1983 (id-var-name1138 e1978 (quote (()))))) (let ((b1984 (lookup1113 label1983 r1979 mod1982))) (if (eq? (binding-type1108 b1984) (quote syntax)) (call-with-values (lambda () (let ((var.lev1985 (binding-value1109 b1984))) (gen-ref1943 src1977 (car var.lev1985) (cdr var.lev1985) maps1980))) (lambda (var1986 maps1987) (values (list (quote ref) var1986) maps1987))) (if (ellipsis?1981 e1978) (syntax-error src1977 "misplaced ellipsis in syntax form") (values (list (quote quote) e1978) maps1980))))) ((lambda (tmp1988) ((lambda (tmp1989) (if (if tmp1989 (apply (lambda (dots1990 e1991) (ellipsis?1981 dots1990)) tmp1989) #f) (apply (lambda (dots1992 e1993) (gen-syntax1942 src1977 e1993 r1979 maps1980 (lambda (x1994) #f) mod1982)) tmp1989) ((lambda (tmp1995) (if (if tmp1995 (apply (lambda (x1996 dots1997 y1998) (ellipsis?1981 dots1997)) tmp1995) #f) (apply (lambda (x1999 dots2000 y2001) (let f2002 ((y2003 y2001) (k2004 (lambda (maps2005) (call-with-values (lambda () (gen-syntax1942 src1977 x1999 r1979 (cons (quote ()) maps2005) ellipsis?1981 mod1982)) (lambda (x2006 maps2007) (if (null? (car maps2007)) (syntax-error src1977 "extra ellipsis in syntax form") (values (gen-map1945 x2006 (car maps2007)) (cdr maps2007)))))))) ((lambda (tmp2008) ((lambda (tmp2009) (if (if tmp2009 (apply (lambda (dots2010 y2011) (ellipsis?1981 dots2010)) tmp2009) #f) (apply (lambda (dots2012 y2013) (f2002 y2013 (lambda (maps2014) (call-with-values (lambda () (k2004 (cons (quote ()) maps2014))) (lambda (x2015 maps2016) (if (null? (car maps2016)) (syntax-error src1977 "extra ellipsis in syntax form") (values (gen-mappend1944 x2015 (car maps2016)) (cdr maps2016)))))))) tmp2009) ((lambda (_2017) (call-with-values (lambda () (gen-syntax1942 src1977 y2003 r1979 maps1980 ellipsis?1981 mod1982)) (lambda (y2018 maps2019) (call-with-values (lambda () (k2004 maps2019)) (lambda (x2020 maps2021) (values (gen-append1947 x2020 y2018) maps2021)))))) tmp2008))) (syntax-dispatch tmp2008 (quote (any . any))))) y2003))) tmp1995) ((lambda (tmp2022) (if tmp2022 (apply (lambda (x2023 y2024) (call-with-values (lambda () (gen-syntax1942 src1977 x2023 r1979 maps1980 ellipsis?1981 mod1982)) (lambda (x2025 maps2026) (call-with-values (lambda () (gen-syntax1942 src1977 y2024 r1979 maps2026 ellipsis?1981 mod1982)) (lambda (y2027 maps2028) (values (gen-cons1946 x2025 y2027) maps2028)))))) tmp2022) ((lambda (tmp2029) (if tmp2029 (apply (lambda (e12030 e22031) (call-with-values (lambda () (gen-syntax1942 src1977 (cons e12030 e22031) r1979 maps1980 ellipsis?1981 mod1982)) (lambda (e2033 maps2034) (values (gen-vector1948 e2033) maps2034)))) tmp2029) ((lambda (_2035) (values (list (quote quote) e1978) maps1980)) tmp1988))) (syntax-dispatch tmp1988 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1988 (quote (any . any)))))) (syntax-dispatch tmp1988 (quote (any any . any)))))) (syntax-dispatch tmp1988 (quote (any any))))) e1978))))) (lambda (e2036 r2037 w2038 s2039 mod2040) (let ((e2041 (source-wrap1145 e2036 w2038 s2039 mod2040))) ((lambda (tmp2042) ((lambda (tmp2043) (if tmp2043 (apply (lambda (_2044 x2045) (call-with-values (lambda () (gen-syntax1942 e2041 x2045 r2037 (quote ()) ellipsis?1161 mod2040)) (lambda (e2046 maps2047) (regen1949 e2046)))) tmp2043) ((lambda (_2048) (syntax-error e2041)) tmp2042))) (syntax-dispatch tmp2042 (quote (any any))))) e2041))))) (global-extend1114 (quote core) (quote lambda) (lambda (e2049 r2050 w2051 s2052 mod2053) ((lambda (tmp2054) ((lambda (tmp2055) (if tmp2055 (apply (lambda (_2056 c2057) (chi-lambda-clause1157 (source-wrap1145 e2049 w2051 s2052 mod2053) #f c2057 r2050 w2051 mod2053 (lambda (vars2058 docstring2059 body2060) (build-annotated1093 s2052 (cons (quote lambda) (cons vars2058 (append (if docstring2059 (list docstring2059) (quote ())) (list body2060)))))))) tmp2055) (syntax-error tmp2054))) (syntax-dispatch tmp2054 (quote (any . any))))) e2049))) (global-extend1114 (quote core) (quote let) (letrec ((chi-let2061 (lambda (e2062 r2063 w2064 s2065 mod2066 constructor2067 ids2068 vals2069 exps2070) (if (not (valid-bound-ids?1141 ids2068)) (syntax-error e2062 "duplicate bound variable in") (let ((labels2071 (gen-labels1122 ids2068)) (new-vars2072 (map gen-var1164 ids2068))) (let ((nw2073 (make-binding-wrap1133 ids2068 labels2071 w2064)) (nr2074 (extend-var-env1111 labels2071 new-vars2072 r2063))) (constructor2067 s2065 new-vars2072 (map (lambda (x2075) (chi1152 x2075 r2063 w2064 mod2066)) vals2069) (chi-body1156 exps2070 (source-wrap1145 e2062 nw2073 s2065 mod2066) nr2074 nw2073 mod2066)))))))) (lambda (e2076 r2077 w2078 s2079 mod2080) ((lambda (tmp2081) ((lambda (tmp2082) (if tmp2082 (apply (lambda (_2083 id2084 val2085 e12086 e22087) (chi-let2061 e2076 r2077 w2078 s2079 mod2080 build-let1096 id2084 val2085 (cons e12086 e22087))) tmp2082) ((lambda (tmp2091) (if (if tmp2091 (apply (lambda (_2092 f2093 id2094 val2095 e12096 e22097) (id?1116 f2093)) tmp2091) #f) (apply (lambda (_2098 f2099 id2100 val2101 e12102 e22103) (chi-let2061 e2076 r2077 w2078 s2079 mod2080 build-named-let1097 (cons f2099 id2100) val2101 (cons e12102 e22103))) tmp2091) ((lambda (_2107) (syntax-error (source-wrap1145 e2076 w2078 s2079 mod2080))) tmp2081))) (syntax-dispatch tmp2081 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2081 (quote (any #(each (any any)) any . each-any))))) e2076)))) (global-extend1114 (quote core) (quote letrec) (lambda (e2108 r2109 w2110 s2111 mod2112) ((lambda (tmp2113) ((lambda (tmp2114) (if tmp2114 (apply (lambda (_2115 id2116 val2117 e12118 e22119) (let ((ids2120 id2116)) (if (not (valid-bound-ids?1141 ids2120)) (syntax-error e2108 "duplicate bound variable in") (let ((labels2122 (gen-labels1122 ids2120)) (new-vars2123 (map gen-var1164 ids2120))) (let ((w2124 (make-binding-wrap1133 ids2120 labels2122 w2110)) (r2125 (extend-var-env1111 labels2122 new-vars2123 r2109))) (build-letrec1098 s2111 new-vars2123 (map (lambda (x2126) (chi1152 x2126 r2125 w2124 mod2112)) val2117) (chi-body1156 (cons e12118 e22119) (source-wrap1145 e2108 w2124 s2111 mod2112) r2125 w2124 mod2112))))))) tmp2114) ((lambda (_2129) (syntax-error (source-wrap1145 e2108 w2110 s2111 mod2112))) tmp2113))) (syntax-dispatch tmp2113 (quote (any #(each (any any)) any . each-any))))) e2108))) (global-extend1114 (quote core) (quote set!) (lambda (e2130 r2131 w2132 s2133 mod2134) ((lambda (tmp2135) ((lambda (tmp2136) (if (if tmp2136 (apply (lambda (_2137 id2138 val2139) (id?1116 id2138)) tmp2136) #f) (apply (lambda (_2140 id2141 val2142) (let ((val2143 (chi1152 val2142 r2131 w2132 mod2134)) (n2144 (id-var-name1138 id2141 w2132))) (let ((b2145 (lookup1113 n2144 r2131 mod2134))) (let ((t2146 (binding-type1108 b2145))) (if (memv t2146 (quote (lexical))) (build-annotated1093 s2133 (list (quote set!) (binding-value1109 b2145) val2143)) (if (memv t2146 (quote (global))) (build-annotated1093 s2133 (list (quote set!) (if mod2134 (make-module-ref (cdr mod2134) n2144 (car mod2134)) (make-module-ref mod2134 n2144 (quote bare))) val2143)) (if (memv t2146 (quote (displaced-lexical))) (syntax-error (wrap1144 id2141 w2132 mod2134) "identifier out of context") (syntax-error (source-wrap1145 e2130 w2132 s2133 mod2134))))))))) tmp2136) ((lambda (tmp2147) (if tmp2147 (apply (lambda (_2148 head2149 tail2150 val2151) (call-with-values (lambda () (syntax-type1150 head2149 r2131 (quote (())) #f #f mod2134)) (lambda (type2152 value2153 ee2154 ww2155 ss2156 modmod2157) (let ((t2158 type2152)) (if (memv t2158 (quote (module-ref))) (let ((val2159 (chi1152 val2151 r2131 w2132 mod2134))) (call-with-values (lambda () (value2153 (cons head2149 tail2150))) (lambda (id2161 mod2162) (build-annotated1093 s2133 (list (quote set!) (if mod2162 (make-module-ref (cdr mod2162) id2161 (car mod2162)) (make-module-ref mod2162 id2161 (quote bare))) val2159))))) (build-annotated1093 s2133 (cons (chi1152 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2149) r2131 w2132 mod2134) (map (lambda (e2163) (chi1152 e2163 r2131 w2132 mod2134)) (append tail2150 (list val2151)))))))))) tmp2147) ((lambda (_2165) (syntax-error (source-wrap1145 e2130 w2132 s2133 mod2134))) tmp2135))) (syntax-dispatch tmp2135 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2135 (quote (any any any))))) e2130))) (global-extend1114 (quote module-ref) (quote @) (lambda (e2166) ((lambda (tmp2167) ((lambda (tmp2168) (if (if tmp2168 (apply (lambda (_2169 mod2170 id2171) (and (andmap id?1116 mod2170) (id?1116 id2171))) tmp2168) #f) (apply (lambda (_2173 mod2174 id2175) (values (syntax-object->datum id2175) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2174)))) tmp2168) (syntax-error tmp2167))) (syntax-dispatch tmp2167 (quote (any each-any any))))) e2166))) (global-extend1114 (quote module-ref) (quote @@) (lambda (e2177) ((lambda (tmp2178) ((lambda (tmp2179) (if (if tmp2179 (apply (lambda (_2180 mod2181 id2182) (and (andmap id?1116 mod2181) (id?1116 id2182))) tmp2179) #f) (apply (lambda (_2184 mod2185 id2186) (values (syntax-object->datum id2186) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2185)))) tmp2179) (syntax-error tmp2178))) (syntax-dispatch tmp2178 (quote (any each-any any))))) e2177))) (global-extend1114 (quote begin) (quote begin) (quote ())) (global-extend1114 (quote define) (quote define) (quote ())) (global-extend1114 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1114 (quote eval-when) (quote eval-when) (quote ())) (global-extend1114 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2191 (lambda (x2192 keys2193 clauses2194 r2195 mod2196) (if (null? clauses2194) (build-annotated1093 #f (list (build-annotated1093 #f (quote syntax-error)) x2192)) ((lambda (tmp2197) ((lambda (tmp2198) (if tmp2198 (apply (lambda (pat2199 exp2200) (if (and (id?1116 pat2199) (andmap (lambda (x2201) (not (free-id=?1139 pat2199 x2201))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2193))) (let ((labels2202 (list (gen-label1121))) (var2203 (gen-var1164 pat2199))) (build-annotated1093 #f (list (build-annotated1093 #f (list (quote lambda) (list var2203) (chi1152 exp2200 (extend-env1110 labels2202 (list (cons (quote syntax) (cons var2203 0))) r2195) (make-binding-wrap1133 (list pat2199) labels2202 (quote (()))) mod2196))) x2192))) (gen-clause2190 x2192 keys2193 (cdr clauses2194) r2195 pat2199 #t exp2200 mod2196))) tmp2198) ((lambda (tmp2204) (if tmp2204 (apply (lambda (pat2205 fender2206 exp2207) (gen-clause2190 x2192 keys2193 (cdr clauses2194) r2195 pat2205 fender2206 exp2207 mod2196)) tmp2204) ((lambda (_2208) (syntax-error (car clauses2194) "invalid syntax-case clause")) tmp2197))) (syntax-dispatch tmp2197 (quote (any any any)))))) (syntax-dispatch tmp2197 (quote (any any))))) (car clauses2194))))) (gen-clause2190 (lambda (x2209 keys2210 clauses2211 r2212 pat2213 fender2214 exp2215 mod2216) (call-with-values (lambda () (convert-pattern2188 pat2213 keys2210)) (lambda (p2217 pvars2218) (cond ((not (distinct-bound-ids?1142 (map car pvars2218))) (syntax-error pat2213 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2219) (not (ellipsis?1161 (car x2219)))) pvars2218)) (syntax-error pat2213 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2220 (gen-var1164 (quote tmp)))) (build-annotated1093 #f (list (build-annotated1093 #f (list (quote lambda) (list y2220) (let ((y2221 (build-annotated1093 #f y2220))) (build-annotated1093 #f (list (quote if) ((lambda (tmp2222) ((lambda (tmp2223) (if tmp2223 (apply (lambda () y2221) tmp2223) ((lambda (_2224) (build-annotated1093 #f (list (quote if) y2221 (build-dispatch-call2189 pvars2218 fender2214 y2221 r2212 mod2216) (build-data1094 #f #f)))) tmp2222))) (syntax-dispatch tmp2222 (quote #(atom #t))))) fender2214) (build-dispatch-call2189 pvars2218 exp2215 y2221 r2212 mod2216) (gen-syntax-case2191 x2209 keys2210 clauses2211 r2212 mod2216)))))) (if (eq? p2217 (quote any)) (build-annotated1093 #f (list (build-annotated1093 #f (quote list)) x2209)) (build-annotated1093 #f (list (build-annotated1093 #f (quote syntax-dispatch)) x2209 (build-data1094 #f p2217))))))))))))) (build-dispatch-call2189 (lambda (pvars2225 exp2226 y2227 r2228 mod2229) (let ((ids2230 (map car pvars2225)) (levels2231 (map cdr pvars2225))) (let ((labels2232 (gen-labels1122 ids2230)) (new-vars2233 (map gen-var1164 ids2230))) (build-annotated1093 #f (list (build-annotated1093 #f (quote apply)) (build-annotated1093 #f (list (quote lambda) new-vars2233 (chi1152 exp2226 (extend-env1110 labels2232 (map (lambda (var2234 level2235) (cons (quote syntax) (cons var2234 level2235))) new-vars2233 (map cdr pvars2225)) r2228) (make-binding-wrap1133 ids2230 labels2232 (quote (()))) mod2229))) y2227)))))) (convert-pattern2188 (lambda (pattern2236 keys2237) (let cvt2238 ((p2239 pattern2236) (n2240 0) (ids2241 (quote ()))) (if (id?1116 p2239) (if (bound-id-member?1143 p2239 keys2237) (values (vector (quote free-id) p2239) ids2241) (values (quote any) (cons (cons p2239 n2240) ids2241))) ((lambda (tmp2242) ((lambda (tmp2243) (if (if tmp2243 (apply (lambda (x2244 dots2245) (ellipsis?1161 dots2245)) tmp2243) #f) (apply (lambda (x2246 dots2247) (call-with-values (lambda () (cvt2238 x2246 (fx+1083 n2240 1) ids2241)) (lambda (p2248 ids2249) (values (if (eq? p2248 (quote any)) (quote each-any) (vector (quote each) p2248)) ids2249)))) tmp2243) ((lambda (tmp2250) (if tmp2250 (apply (lambda (x2251 y2252) (call-with-values (lambda () (cvt2238 y2252 n2240 ids2241)) (lambda (y2253 ids2254) (call-with-values (lambda () (cvt2238 x2251 n2240 ids2254)) (lambda (x2255 ids2256) (values (cons x2255 y2253) ids2256)))))) tmp2250) ((lambda (tmp2257) (if tmp2257 (apply (lambda () (values (quote ()) ids2241)) tmp2257) ((lambda (tmp2258) (if tmp2258 (apply (lambda (x2259) (call-with-values (lambda () (cvt2238 x2259 n2240 ids2241)) (lambda (p2261 ids2262) (values (vector (quote vector) p2261) ids2262)))) tmp2258) ((lambda (x2263) (values (vector (quote atom) (strip1163 p2239 (quote (())))) ids2241)) tmp2242))) (syntax-dispatch tmp2242 (quote #(vector each-any)))))) (syntax-dispatch tmp2242 (quote ()))))) (syntax-dispatch tmp2242 (quote (any . any)))))) (syntax-dispatch tmp2242 (quote (any any))))) p2239)))))) (lambda (e2264 r2265 w2266 s2267 mod2268) (let ((e2269 (source-wrap1145 e2264 w2266 s2267 mod2268))) ((lambda (tmp2270) ((lambda (tmp2271) (if tmp2271 (apply (lambda (_2272 val2273 key2274 m2275) (if (andmap (lambda (x2276) (and (id?1116 x2276) (not (ellipsis?1161 x2276)))) key2274) (let ((x2278 (gen-var1164 (quote tmp)))) (build-annotated1093 s2267 (list (build-annotated1093 #f (list (quote lambda) (list x2278) (gen-syntax-case2191 (build-annotated1093 #f x2278) key2274 m2275 r2265 mod2268))) (chi1152 val2273 r2265 (quote (())) mod2268)))) (syntax-error e2269 "invalid literals list in"))) tmp2271) (syntax-error tmp2270))) (syntax-dispatch tmp2270 (quote (any any each-any . each-any))))) e2269))))) (set! sc-expand (let ((m2281 (quote e)) (esew2282 (quote (eval)))) (lambda (x2283) (if (and (pair? x2283) (equal? (car x2283) noexpand1082)) (cadr x2283) (chi-top1151 x2283 (quote ()) (quote ((top))) m2281 esew2282 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2284 (quote e)) (esew2285 (quote (eval)))) (lambda (x2287 . rest2286) (if (and (pair? x2287) (equal? (car x2287) noexpand1082)) (cadr x2287) (chi-top1151 x2287 (quote ()) (quote ((top))) (if (null? rest2286) m2284 (car rest2286)) (if (or (null? rest2286) (null? (cdr rest2286))) esew2285 (cadr rest2286)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2288) (nonsymbol-id?1115 x2288))) (set! datum->syntax-object (lambda (id2289 datum2290) (make-syntax-object1099 datum2290 (syntax-object-wrap1102 id2289) #f))) (set! syntax-object->datum (lambda (x2291) (strip1163 x2291 (quote (()))))) (set! generate-temporaries (lambda (ls2292) (begin (let ((x2293 ls2292)) (if (not (list? x2293)) (error-hook1089 (quote generate-temporaries) "invalid argument" x2293))) (map (lambda (x2294) (wrap1144 (gensym) (quote ((top))) #f)) ls2292)))) (set! free-identifier=? (lambda (x2295 y2296) (begin (let ((x2297 x2295)) (if (not (nonsymbol-id?1115 x2297)) (error-hook1089 (quote free-identifier=?) "invalid argument" x2297))) (let ((x2298 y2296)) (if (not (nonsymbol-id?1115 x2298)) (error-hook1089 (quote free-identifier=?) "invalid argument" x2298))) (free-id=?1139 x2295 y2296)))) (set! bound-identifier=? (lambda (x2299 y2300) (begin (let ((x2301 x2299)) (if (not (nonsymbol-id?1115 x2301)) (error-hook1089 (quote bound-identifier=?) "invalid argument" x2301))) (let ((x2302 y2300)) (if (not (nonsymbol-id?1115 x2302)) (error-hook1089 (quote bound-identifier=?) "invalid argument" x2302))) (bound-id=?1140 x2299 y2300)))) (set! syntax-error (lambda (object2304 . messages2303) (begin (for-each (lambda (x2305) (let ((x2306 x2305)) (if (not (string? x2306)) (error-hook1089 (quote syntax-error) "invalid argument" x2306)))) messages2303) (let ((message2307 (if (null? messages2303) "invalid syntax" (apply string-append messages2303)))) (error-hook1089 #f message2307 (strip1163 object2304 (quote (())))))))) (set! install-global-transformer (lambda (sym2308 v2309) (begin (let ((x2310 sym2308)) (if (not (symbol? x2310)) (error-hook1089 (quote define-syntax) "invalid argument" x2310))) (let ((x2311 v2309)) (if (not (procedure? x2311)) (error-hook1089 (quote define-syntax) "invalid argument" x2311))) (global-extend1114 (quote macro) sym2308 v2309)))) (letrec ((match2316 (lambda (e2317 p2318 w2319 r2320 mod2321) (cond ((not r2320) #f) ((eq? p2318 (quote any)) (cons (wrap1144 e2317 w2319 mod2321) r2320)) ((syntax-object?1100 e2317) (match*2315 (let ((e2322 (syntax-object-expression1101 e2317))) (if (annotation? e2322) (annotation-expression e2322) e2322)) p2318 (join-wraps1135 w2319 (syntax-object-wrap1102 e2317)) r2320 (syntax-object-module1103 e2317))) (else (match*2315 (let ((e2323 e2317)) (if (annotation? e2323) (annotation-expression e2323) e2323)) p2318 w2319 r2320 mod2321))))) (match*2315 (lambda (e2324 p2325 w2326 r2327 mod2328) (cond ((null? p2325) (and (null? e2324) r2327)) ((pair? p2325) (and (pair? e2324) (match2316 (car e2324) (car p2325) w2326 (match2316 (cdr e2324) (cdr p2325) w2326 r2327 mod2328) mod2328))) ((eq? p2325 (quote each-any)) (let ((l2329 (match-each-any2313 e2324 w2326 mod2328))) (and l2329 (cons l2329 r2327)))) (else (let ((t2330 (vector-ref p2325 0))) (if (memv t2330 (quote (each))) (if (null? e2324) (match-empty2314 (vector-ref p2325 1) r2327) (let ((l2331 (match-each2312 e2324 (vector-ref p2325 1) w2326 mod2328))) (and l2331 (let collect2332 ((l2333 l2331)) (if (null? (car l2333)) r2327 (cons (map car l2333) (collect2332 (map cdr l2333)))))))) (if (memv t2330 (quote (free-id))) (and (id?1116 e2324) (free-id=?1139 (wrap1144 e2324 w2326 mod2328) (vector-ref p2325 1)) r2327) (if (memv t2330 (quote (atom))) (and (equal? (vector-ref p2325 1) (strip1163 e2324 w2326)) r2327) (if (memv t2330 (quote (vector))) (and (vector? e2324) (match2316 (vector->list e2324) (vector-ref p2325 1) w2326 r2327 mod2328))))))))))) (match-empty2314 (lambda (p2334 r2335) (cond ((null? p2334) r2335) ((eq? p2334 (quote any)) (cons (quote ()) r2335)) ((pair? p2334) (match-empty2314 (car p2334) (match-empty2314 (cdr p2334) r2335))) ((eq? p2334 (quote each-any)) (cons (quote ()) r2335)) (else (let ((t2336 (vector-ref p2334 0))) (if (memv t2336 (quote (each))) (match-empty2314 (vector-ref p2334 1) r2335) (if (memv t2336 (quote (free-id atom))) r2335 (if (memv t2336 (quote (vector))) (match-empty2314 (vector-ref p2334 1) r2335))))))))) (match-each-any2313 (lambda (e2337 w2338 mod2339) (cond ((annotation? e2337) (match-each-any2313 (annotation-expression e2337) w2338 mod2339)) ((pair? e2337) (let ((l2340 (match-each-any2313 (cdr e2337) w2338 mod2339))) (and l2340 (cons (wrap1144 (car e2337) w2338 mod2339) l2340)))) ((null? e2337) (quote ())) ((syntax-object?1100 e2337) (match-each-any2313 (syntax-object-expression1101 e2337) (join-wraps1135 w2338 (syntax-object-wrap1102 e2337)) mod2339)) (else #f)))) (match-each2312 (lambda (e2341 p2342 w2343 mod2344) (cond ((annotation? e2341) (match-each2312 (annotation-expression e2341) p2342 w2343 mod2344)) ((pair? e2341) (let ((first2345 (match2316 (car e2341) p2342 w2343 (quote ()) mod2344))) (and first2345 (let ((rest2346 (match-each2312 (cdr e2341) p2342 w2343 mod2344))) (and rest2346 (cons first2345 rest2346)))))) ((null? e2341) (quote ())) ((syntax-object?1100 e2341) (match-each2312 (syntax-object-expression1101 e2341) p2342 (join-wraps1135 w2343 (syntax-object-wrap1102 e2341)) (syntax-object-module1103 e2341))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2347 p2348) (cond ((eq? p2348 (quote any)) (list e2347)) ((syntax-object?1100 e2347) (match*2315 (let ((e2349 (syntax-object-expression1101 e2347))) (if (annotation? e2349) (annotation-expression e2349) e2349)) p2348 (syntax-object-wrap1102 e2347) (quote ()) (syntax-object-module1103 e2347))) (else (match*2315 (let ((e2350 e2347)) (if (annotation? e2350) (annotation-expression e2350) e2350)) p2348 (quote (())) (quote ()) #f))))) (set! sc-chi chi1152))))) -(install-global-transformer (quote with-syntax) (lambda (x2351) ((lambda (tmp2352) ((lambda (tmp2353) (if tmp2353 (apply (lambda (_2354 e12355 e22356) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12355 e22356))) tmp2353) ((lambda (tmp2358) (if tmp2358 (apply (lambda (_2359 out2360 in2361 e12362 e22363) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2361 (quote ()) (list out2360 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12362 e22363))))) tmp2358) ((lambda (tmp2365) (if tmp2365 (apply (lambda (_2366 out2367 in2368 e12369 e22370) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2368) (quote ()) (list out2367 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12369 e22370))))) tmp2365) (syntax-error tmp2352))) (syntax-dispatch tmp2352 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2352 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2352 (quote (any () any . each-any))))) x2351))) -(install-global-transformer (quote syntax-rules) (lambda (x2374) ((lambda (tmp2375) ((lambda (tmp2376) (if tmp2376 (apply (lambda (_2377 k2378 keyword2379 pattern2380 template2381) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2378 (map (lambda (tmp2384 tmp2383) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2383) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2384))) template2381 pattern2380)))))) tmp2376) (syntax-error tmp2375))) (syntax-dispatch tmp2375 (quote (any each-any . #(each ((any . any) any))))))) x2374))) -(install-global-transformer (quote let*) (lambda (x2385) ((lambda (tmp2386) ((lambda (tmp2387) (if (if tmp2387 (apply (lambda (let*2388 x2389 v2390 e12391 e22392) (andmap identifier? x2389)) tmp2387) #f) (apply (lambda (let*2394 x2395 v2396 e12397 e22398) (let f2399 ((bindings2400 (map list x2395 v2396))) (if (null? bindings2400) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12397 e22398))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (body2406 binding2407) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2407) body2406)) tmp2405) (syntax-error tmp2404))) (syntax-dispatch tmp2404 (quote (any any))))) (list (f2399 (cdr bindings2400)) (car bindings2400)))))) tmp2387) (syntax-error tmp2386))) (syntax-dispatch tmp2386 (quote (any #(each (any any)) any . each-any))))) x2385))) -(install-global-transformer (quote do) (lambda (orig-x2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (_2411 var2412 init2413 step2414 e02415 e12416 c2417) ((lambda (tmp2418) ((lambda (tmp2419) (if tmp2419 (apply (lambda (step2420) ((lambda (tmp2421) ((lambda (tmp2422) (if tmp2422 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2412 init2413) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02415) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2417 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2420))))))) tmp2422) ((lambda (tmp2427) (if tmp2427 (apply (lambda (e12428 e22429) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2412 init2413) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02415 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12428 e22429)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2417 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2420))))))) tmp2427) (syntax-error tmp2421))) (syntax-dispatch tmp2421 (quote (any . each-any)))))) (syntax-dispatch tmp2421 (quote ())))) e12416)) tmp2419) (syntax-error tmp2418))) (syntax-dispatch tmp2418 (quote each-any)))) (map (lambda (v2436 s2437) ((lambda (tmp2438) ((lambda (tmp2439) (if tmp2439 (apply (lambda () v2436) tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (e2441) e2441) tmp2440) ((lambda (_2442) (syntax-error orig-x2408)) tmp2438))) (syntax-dispatch tmp2438 (quote (any)))))) (syntax-dispatch tmp2438 (quote ())))) s2437)) var2412 step2414))) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2408))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2445 (lambda (x2449 y2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (x2453 y2454) ((lambda (tmp2455) ((lambda (tmp2456) (if tmp2456 (apply (lambda (dy2457) ((lambda (tmp2458) ((lambda (tmp2459) (if tmp2459 (apply (lambda (dx2460) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2460 dy2457))) tmp2459) ((lambda (_2461) (if (null? dy2457) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2453) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2453 y2454))) tmp2458))) (syntax-dispatch tmp2458 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2453)) tmp2456) ((lambda (tmp2462) (if tmp2462 (apply (lambda (stuff2463) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2453 stuff2463))) tmp2462) ((lambda (else2464) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2453 y2454)) tmp2455))) (syntax-dispatch tmp2455 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2455 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2454)) tmp2452) (syntax-error tmp2451))) (syntax-dispatch tmp2451 (quote (any any))))) (list x2449 y2450)))) (quasiappend2446 (lambda (x2465 y2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda (x2469 y2470) ((lambda (tmp2471) ((lambda (tmp2472) (if tmp2472 (apply (lambda () x2469) tmp2472) ((lambda (_2473) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2469 y2470)) tmp2471))) (syntax-dispatch tmp2471 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2470)) tmp2468) (syntax-error tmp2467))) (syntax-dispatch tmp2467 (quote (any any))))) (list x2465 y2466)))) (quasivector2447 (lambda (x2474) ((lambda (tmp2475) ((lambda (x2476) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (x2479) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2479))) tmp2478) ((lambda (tmp2481) (if tmp2481 (apply (lambda (x2482) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2482)) tmp2481) ((lambda (_2484) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2476)) tmp2477))) (syntax-dispatch tmp2477 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2477 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2476)) tmp2475)) x2474))) (quasi2448 (lambda (p2485 lev2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (p2489) (if (= lev2486 0) p2489 (quasicons2445 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2448 (list p2489) (- lev2486 1))))) tmp2488) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491 q2492) (if (= lev2486 0) (quasiappend2446 p2491 (quasi2448 q2492 lev2486)) (quasicons2445 (quasicons2445 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2448 (list p2491) (- lev2486 1))) (quasi2448 q2492 lev2486)))) tmp2490) ((lambda (tmp2493) (if tmp2493 (apply (lambda (p2494) (quasicons2445 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2448 (list p2494) (+ lev2486 1)))) tmp2493) ((lambda (tmp2495) (if tmp2495 (apply (lambda (p2496 q2497) (quasicons2445 (quasi2448 p2496 lev2486) (quasi2448 q2497 lev2486))) tmp2495) ((lambda (tmp2498) (if tmp2498 (apply (lambda (x2499) (quasivector2447 (quasi2448 x2499 lev2486))) tmp2498) ((lambda (p2501) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2501)) tmp2487))) (syntax-dispatch tmp2487 (quote #(vector each-any)))))) (syntax-dispatch tmp2487 (quote (any . any)))))) (syntax-dispatch tmp2487 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2487 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2487 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2485)))) (lambda (x2502) ((lambda (tmp2503) ((lambda (tmp2504) (if tmp2504 (apply (lambda (_2505 e2506) (quasi2448 e2506 0)) tmp2504) (syntax-error tmp2503))) (syntax-dispatch tmp2503 (quote (any any))))) x2502)))) -(install-global-transformer (quote include) (lambda (x2507) (letrec ((read-file2508 (lambda (fn2509 k2510) (let ((p2511 (open-input-file fn2509))) (let f2512 ((x2513 (read p2511))) (if (eof-object? x2513) (begin (close-input-port p2511) (quote ())) (cons (datum->syntax-object k2510 x2513) (f2512 (read p2511))))))))) ((lambda (tmp2514) ((lambda (tmp2515) (if tmp2515 (apply (lambda (k2516 filename2517) (let ((fn2518 (syntax-object->datum filename2517))) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (exp2521) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2521)) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote each-any)))) (read-file2508 fn2518 k2516)))) tmp2515) (syntax-error tmp2514))) (syntax-dispatch tmp2514 (quote (any any))))) x2507)))) -(install-global-transformer (quote unquote) (lambda (x2523) ((lambda (tmp2524) ((lambda (tmp2525) (if tmp2525 (apply (lambda (_2526 e2527) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2527))) tmp2525) (syntax-error tmp2524))) (syntax-dispatch tmp2524 (quote (any any))))) x2523))) -(install-global-transformer (quote unquote-splicing) (lambda (x2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda (_2531 e2532) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2532))) tmp2530) (syntax-error tmp2529))) (syntax-dispatch tmp2529 (quote (any any))))) x2528))) -(install-global-transformer (quote case) (lambda (x2533) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (_2536 e2537 m12538 m22539) ((lambda (tmp2540) ((lambda (body2541) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2537)) body2541)) tmp2540)) (let f2542 ((clause2543 m12538) (clauses2544 m22539)) (if (null? clauses2544) ((lambda (tmp2546) ((lambda (tmp2547) (if tmp2547 (apply (lambda (e12548 e22549) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12548 e22549))) tmp2547) ((lambda (tmp2551) (if tmp2551 (apply (lambda (k2552 e12553 e22554) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2552)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12553 e22554)))) tmp2551) ((lambda (_2557) (syntax-error x2533)) tmp2546))) (syntax-dispatch tmp2546 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2546 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2543) ((lambda (tmp2558) ((lambda (rest2559) ((lambda (tmp2560) ((lambda (tmp2561) (if tmp2561 (apply (lambda (k2562 e12563 e22564) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2562)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12563 e22564)) rest2559)) tmp2561) ((lambda (_2567) (syntax-error x2533)) tmp2560))) (syntax-dispatch tmp2560 (quote (each-any any . each-any))))) clause2543)) tmp2558)) (f2542 (car clauses2544) (cdr clauses2544))))))) tmp2535) (syntax-error tmp2534))) (syntax-dispatch tmp2534 (quote (any any any . each-any))))) x2533))) -(install-global-transformer (quote identifier-syntax) (lambda (x2568) ((lambda (tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (_2571 e2572) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2572)) (list (cons _2571 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2572 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2570) (syntax-error tmp2569))) (syntax-dispatch tmp2569 (quote (any any))))) x2568))) +(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-error p1361 "nonprocedure transformer"))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-error e1363 "duplicate bound keyword in") (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-error (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) (syntax-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax-object->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-error e1386 "invalid parameter list in") (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-error e1386 "invalid parameter list in") (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-error e1386)) tmp1393))) (syntax-dispatch tmp1393 (quote (any any . each-any)))))) (syntax-dispatch tmp1393 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-error outer-form1426 "no expressions in body") (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-error tmp1455))) (syntax-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-error outer-form1426 "invalid or duplicate identifier in definition")) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-error x1486 "encountered raw symbol in macro output")) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-error tmp1502))) (syntax-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-error tmp1518))) (syntax-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-error tmp1524))) (syntax-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-error (wrap1111 value1509 w1512 mod1514) "invalid context for definition of") (if (memv t1515 (quote (syntax))) (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to pattern variable outside syntax form") (if (memv t1515 (quote (displaced-lexical))) (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-error tmp1563))) (syntax-dispatch tmp1563 (quote (any any . each-any)))))) (syntax-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-error tmp1576))) (syntax-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-error (wrap1111 value1557 w1559 mod1561) "identifier out of context") (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-error (wrap1111 value1557 w1559 mod1561) "cannot define keyword at top level"))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-error tmp1612))) (syntax-dispatch tmp1612 (quote (any any)))))) (syntax-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-error tmp1637))) (syntax-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1111 x1651 w1647 #f) "invalid eval-when situation")))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-error (source-wrap1112 id1881 w1862 s1863 mod1864) "identifier out of context")))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-error (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) (syntax-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-error (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) (syntax-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-error src1927 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-error src1935 "misplaced ellipsis in syntax form") (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) (syntax-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) (syntax-dispatch tmp1946 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1946 (quote (any . any)))))) (syntax-dispatch tmp1946 (quote (any any . any)))))) (syntax-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-error e1999)) tmp2000))) (syntax-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-error tmp2012))) (syntax-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-error e2020 "duplicate bound variable in") (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-error (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) (syntax-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-error e2066 "duplicate bound variable in") (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-error (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) (syntax-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-error (wrap1111 id2099 w2090 mod2092) "identifier out of context") (syntax-error (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-error (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) (syntax-dispatch tmp2093 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax-object->datum id2133) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-error tmp2125))) (syntax-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax-object->datum id2144) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-error tmp2136))) (syntax-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-error)) x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-error (car clauses2152) "invalid syntax-case clause")) tmp2155))) (syntax-dispatch tmp2155 (quote (any any any)))))) (syntax-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-error pat2171 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-error pat2171 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) (syntax-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) (syntax-dispatch tmp2200 (quote #(vector each-any)))))) (syntax-dispatch tmp2200 (quote ()))))) (syntax-dispatch tmp2200 (quote (any . any)))))) (syntax-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-error e2227 "invalid literals list in"))) tmp2229) (syntax-error tmp2228))) (syntax-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax-object (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax-object->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-error (lambda (object2262 . messages2261) (begin (for-each (lambda (x2263) (let ((x2264 x2263)) (if (not (string? x2264)) (error-hook1056 (quote syntax-error) "invalid argument" x2264)))) messages2261) (let ((message2265 (if (null? messages2261) "invalid syntax" (apply string-append messages2261)))) (error-hook1056 #f message2265 (strip1130 object2262 (quote (())))))))) (set! install-global-transformer (lambda (sym2266 v2267) (begin (let ((x2268 sym2266)) (if (not (symbol? x2268)) (error-hook1056 (quote define-syntax) "invalid argument" x2268))) (let ((x2269 v2267)) (if (not (procedure? x2269)) (error-hook1056 (quote define-syntax) "invalid argument" x2269))) (global-extend1081 (quote macro) sym2266 v2267)))) (letrec ((match2274 (lambda (e2275 p2276 w2277 r2278 mod2279) (cond ((not r2278) #f) ((eq? p2276 (quote any)) (cons (wrap1111 e2275 w2277 mod2279) r2278)) ((syntax-object?1067 e2275) (match*2273 (let ((e2280 (syntax-object-expression1068 e2275))) (if (annotation? e2280) (annotation-expression e2280) e2280)) p2276 (join-wraps1102 w2277 (syntax-object-wrap1069 e2275)) r2278 (syntax-object-module1070 e2275))) (else (match*2273 (let ((e2281 e2275)) (if (annotation? e2281) (annotation-expression e2281) e2281)) p2276 w2277 r2278 mod2279))))) (match*2273 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((null? p2283) (and (null? e2282) r2285)) ((pair? p2283) (and (pair? e2282) (match2274 (car e2282) (car p2283) w2284 (match2274 (cdr e2282) (cdr p2283) w2284 r2285 mod2286) mod2286))) ((eq? p2283 (quote each-any)) (let ((l2287 (match-each-any2271 e2282 w2284 mod2286))) (and l2287 (cons l2287 r2285)))) (else (let ((t2288 (vector-ref p2283 0))) (if (memv t2288 (quote (each))) (if (null? e2282) (match-empty2272 (vector-ref p2283 1) r2285) (let ((l2289 (match-each2270 e2282 (vector-ref p2283 1) w2284 mod2286))) (and l2289 (let collect2290 ((l2291 l2289)) (if (null? (car l2291)) r2285 (cons (map car l2291) (collect2290 (map cdr l2291)))))))) (if (memv t2288 (quote (free-id))) (and (id?1083 e2282) (free-id=?1106 (wrap1111 e2282 w2284 mod2286) (vector-ref p2283 1)) r2285) (if (memv t2288 (quote (atom))) (and (equal? (vector-ref p2283 1) (strip1130 e2282 w2284)) r2285) (if (memv t2288 (quote (vector))) (and (vector? e2282) (match2274 (vector->list e2282) (vector-ref p2283 1) w2284 r2285 mod2286))))))))))) (match-empty2272 (lambda (p2292 r2293) (cond ((null? p2292) r2293) ((eq? p2292 (quote any)) (cons (quote ()) r2293)) ((pair? p2292) (match-empty2272 (car p2292) (match-empty2272 (cdr p2292) r2293))) ((eq? p2292 (quote each-any)) (cons (quote ()) r2293)) (else (let ((t2294 (vector-ref p2292 0))) (if (memv t2294 (quote (each))) (match-empty2272 (vector-ref p2292 1) r2293) (if (memv t2294 (quote (free-id atom))) r2293 (if (memv t2294 (quote (vector))) (match-empty2272 (vector-ref p2292 1) r2293))))))))) (match-each-any2271 (lambda (e2295 w2296 mod2297) (cond ((annotation? e2295) (match-each-any2271 (annotation-expression e2295) w2296 mod2297)) ((pair? e2295) (let ((l2298 (match-each-any2271 (cdr e2295) w2296 mod2297))) (and l2298 (cons (wrap1111 (car e2295) w2296 mod2297) l2298)))) ((null? e2295) (quote ())) ((syntax-object?1067 e2295) (match-each-any2271 (syntax-object-expression1068 e2295) (join-wraps1102 w2296 (syntax-object-wrap1069 e2295)) mod2297)) (else #f)))) (match-each2270 (lambda (e2299 p2300 w2301 mod2302) (cond ((annotation? e2299) (match-each2270 (annotation-expression e2299) p2300 w2301 mod2302)) ((pair? e2299) (let ((first2303 (match2274 (car e2299) p2300 w2301 (quote ()) mod2302))) (and first2303 (let ((rest2304 (match-each2270 (cdr e2299) p2300 w2301 mod2302))) (and rest2304 (cons first2303 rest2304)))))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each2270 (syntax-object-expression1068 e2299) p2300 (join-wraps1102 w2301 (syntax-object-wrap1069 e2299)) (syntax-object-module1070 e2299))) (else #f))))) (set! syntax-dispatch (lambda (e2305 p2306) (cond ((eq? p2306 (quote any)) (list e2305)) ((syntax-object?1067 e2305) (match*2273 (let ((e2307 (syntax-object-expression1068 e2305))) (if (annotation? e2307) (annotation-expression e2307) e2307)) p2306 (syntax-object-wrap1069 e2305) (quote ()) (syntax-object-module1070 e2305))) (else (match*2273 (let ((e2308 e2305)) (if (annotation? e2308) (annotation-expression e2308) e2308)) p2306 (quote (())) (quote ()) #f)))))))) +(install-global-transformer (quote with-syntax) (lambda (x2309) ((lambda (tmp2310) ((lambda (tmp2311) (if tmp2311 (apply (lambda (_2312 e12313 e22314) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12313 e22314))) tmp2311) ((lambda (tmp2316) (if tmp2316 (apply (lambda (_2317 out2318 in2319 e12320 e22321) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2319 (quote ()) (list out2318 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12320 e22321))))) tmp2316) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2326) (quote ()) (list out2325 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12327 e22328))))) tmp2323) (syntax-error tmp2310))) (syntax-dispatch tmp2310 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any () any . each-any))))) x2309))) +(install-global-transformer (quote syntax-rules) (lambda (x2332) ((lambda (tmp2333) ((lambda (tmp2334) (if tmp2334 (apply (lambda (_2335 k2336 keyword2337 pattern2338 template2339) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2336 (map (lambda (tmp2342 tmp2341) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2341) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2342))) template2339 pattern2338)))))) tmp2334) (syntax-error tmp2333))) (syntax-dispatch tmp2333 (quote (any each-any . #(each ((any . any) any))))))) x2332))) +(install-global-transformer (quote let*) (lambda (x2343) ((lambda (tmp2344) ((lambda (tmp2345) (if (if tmp2345 (apply (lambda (let*2346 x2347 v2348 e12349 e22350) (andmap identifier? x2347)) tmp2345) #f) (apply (lambda (let*2352 x2353 v2354 e12355 e22356) (let f2357 ((bindings2358 (map list x2353 v2354))) (if (null? bindings2358) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12355 e22356))) ((lambda (tmp2362) ((lambda (tmp2363) (if tmp2363 (apply (lambda (body2364 binding2365) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2365) body2364)) tmp2363) (syntax-error tmp2362))) (syntax-dispatch tmp2362 (quote (any any))))) (list (f2357 (cdr bindings2358)) (car bindings2358)))))) tmp2345) (syntax-error tmp2344))) (syntax-dispatch tmp2344 (quote (any #(each (any any)) any . each-any))))) x2343))) +(install-global-transformer (quote do) (lambda (orig-x2366) ((lambda (tmp2367) ((lambda (tmp2368) (if tmp2368 (apply (lambda (_2369 var2370 init2371 step2372 e02373 e12374 c2375) ((lambda (tmp2376) ((lambda (tmp2377) (if tmp2377 (apply (lambda (step2378) ((lambda (tmp2379) ((lambda (tmp2380) (if tmp2380 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02373) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2378))))))) tmp2380) ((lambda (tmp2385) (if tmp2385 (apply (lambda (e12386 e22387) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02373 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12386 e22387)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2378))))))) tmp2385) (syntax-error tmp2379))) (syntax-dispatch tmp2379 (quote (any . each-any)))))) (syntax-dispatch tmp2379 (quote ())))) e12374)) tmp2377) (syntax-error tmp2376))) (syntax-dispatch tmp2376 (quote each-any)))) (map (lambda (v2394 s2395) ((lambda (tmp2396) ((lambda (tmp2397) (if tmp2397 (apply (lambda () v2394) tmp2397) ((lambda (tmp2398) (if tmp2398 (apply (lambda (e2399) e2399) tmp2398) ((lambda (_2400) (syntax-error orig-x2366)) tmp2396))) (syntax-dispatch tmp2396 (quote (any)))))) (syntax-dispatch tmp2396 (quote ())))) s2395)) var2370 step2372))) tmp2368) (syntax-error tmp2367))) (syntax-dispatch tmp2367 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2366))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2403 (lambda (x2407 y2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (dy2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (dx2418) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2418 dy2415))) tmp2417) ((lambda (_2419) (if (null? dy2415) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2411) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2411 y2412))) tmp2416))) (syntax-dispatch tmp2416 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2411)) tmp2414) ((lambda (tmp2420) (if tmp2420 (apply (lambda (stuff2421) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2411 stuff2421))) tmp2420) ((lambda (else2422) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2411 y2412)) tmp2413))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2412)) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any any))))) (list x2407 y2408)))) (quasiappend2404 (lambda (x2423 y2424) ((lambda (tmp2425) ((lambda (tmp2426) (if tmp2426 (apply (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda () x2427) tmp2430) ((lambda (_2431) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2427 y2428)) tmp2429))) (syntax-dispatch tmp2429 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2428)) tmp2426) (syntax-error tmp2425))) (syntax-dispatch tmp2425 (quote (any any))))) (list x2423 y2424)))) (quasivector2405 (lambda (x2432) ((lambda (tmp2433) ((lambda (x2434) ((lambda (tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda (x2437) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2437))) tmp2436) ((lambda (tmp2439) (if tmp2439 (apply (lambda (x2440) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2440)) tmp2439) ((lambda (_2442) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2434)) tmp2435))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2434)) tmp2433)) x2432))) (quasi2406 (lambda (p2443 lev2444) ((lambda (tmp2445) ((lambda (tmp2446) (if tmp2446 (apply (lambda (p2447) (if (= lev2444 0) p2447 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2406 (list p2447) (- lev2444 1))))) tmp2446) ((lambda (tmp2448) (if tmp2448 (apply (lambda (p2449 q2450) (if (= lev2444 0) (quasiappend2404 p2449 (quasi2406 q2450 lev2444)) (quasicons2403 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2406 (list p2449) (- lev2444 1))) (quasi2406 q2450 lev2444)))) tmp2448) ((lambda (tmp2451) (if tmp2451 (apply (lambda (p2452) (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2406 (list p2452) (+ lev2444 1)))) tmp2451) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454 q2455) (quasicons2403 (quasi2406 p2454 lev2444) (quasi2406 q2455 lev2444))) tmp2453) ((lambda (tmp2456) (if tmp2456 (apply (lambda (x2457) (quasivector2405 (quasi2406 x2457 lev2444))) tmp2456) ((lambda (p2459) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2459)) tmp2445))) (syntax-dispatch tmp2445 (quote #(vector each-any)))))) (syntax-dispatch tmp2445 (quote (any . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2445 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2443)))) (lambda (x2460) ((lambda (tmp2461) ((lambda (tmp2462) (if tmp2462 (apply (lambda (_2463 e2464) (quasi2406 e2464 0)) tmp2462) (syntax-error tmp2461))) (syntax-dispatch tmp2461 (quote (any any))))) x2460)))) +(install-global-transformer (quote include) (lambda (x2465) (letrec ((read-file2466 (lambda (fn2467 k2468) (let ((p2469 (open-input-file fn2467))) (let f2470 ((x2471 (read p2469))) (if (eof-object? x2471) (begin (close-input-port p2469) (quote ())) (cons (datum->syntax-object k2468 x2471) (f2470 (read p2469))))))))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (k2474 filename2475) (let ((fn2476 (syntax-object->datum filename2475))) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (exp2479) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2479)) tmp2478) (syntax-error tmp2477))) (syntax-dispatch tmp2477 (quote each-any)))) (read-file2466 fn2476 k2474)))) tmp2473) (syntax-error tmp2472))) (syntax-dispatch tmp2472 (quote (any any))))) x2465)))) +(install-global-transformer (quote unquote) (lambda (x2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (_2484 e2485) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2485))) tmp2483) (syntax-error tmp2482))) (syntax-dispatch tmp2482 (quote (any any))))) x2481))) +(install-global-transformer (quote unquote-splicing) (lambda (x2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (_2489 e2490) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2490))) tmp2488) (syntax-error tmp2487))) (syntax-dispatch tmp2487 (quote (any any))))) x2486))) +(install-global-transformer (quote case) (lambda (x2491) ((lambda (tmp2492) ((lambda (tmp2493) (if tmp2493 (apply (lambda (_2494 e2495 m12496 m22497) ((lambda (tmp2498) ((lambda (body2499) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2495)) body2499)) tmp2498)) (let f2500 ((clause2501 m12496) (clauses2502 m22497)) (if (null? clauses2502) ((lambda (tmp2504) ((lambda (tmp2505) (if tmp2505 (apply (lambda (e12506 e22507) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12506 e22507))) tmp2505) ((lambda (tmp2509) (if tmp2509 (apply (lambda (k2510 e12511 e22512) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2510)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12511 e22512)))) tmp2509) ((lambda (_2515) (syntax-error x2491)) tmp2504))) (syntax-dispatch tmp2504 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2504 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2501) ((lambda (tmp2516) ((lambda (rest2517) ((lambda (tmp2518) ((lambda (tmp2519) (if tmp2519 (apply (lambda (k2520 e12521 e22522) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2520)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12521 e22522)) rest2517)) tmp2519) ((lambda (_2525) (syntax-error x2491)) tmp2518))) (syntax-dispatch tmp2518 (quote (each-any any . each-any))))) clause2501)) tmp2516)) (f2500 (car clauses2502) (cdr clauses2502))))))) tmp2493) (syntax-error tmp2492))) (syntax-dispatch tmp2492 (quote (any any any . each-any))))) x2491))) +(install-global-transformer (quote identifier-syntax) (lambda (x2526) ((lambda (tmp2527) ((lambda (tmp2528) (if tmp2528 (apply (lambda (_2529 e2530) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2530)) (list (cons _2529 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2530 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2528) (syntax-error tmp2527))) (syntax-dispatch tmp2527 (quote (any any))))) x2526))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 8dfab12a5..23a6efdc5 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -339,34 +339,19 @@ (define put-global-definition-hook (lambda (symbol type val) - (let* ((module (current-module)) - (v (or (module-variable module symbol) - (let ((v (make-variable val))) - (module-add! module symbol v) - v)))) - (if (not (variable-bound? v)) - (variable-set! v val)) - ;; Properties are tied to variable objects - (set-object-property! v '*sc-expander* - (make-binding type val))))) + (module-define-keyword! (current-module) symbol type val))) (define remove-global-definition-hook (lambda (symbol) - (let* ((module (current-module)) - (v (module-local-variable module symbol))) - (if v - (let ((p (assq '*sc-expander* (object-properties v)))) - (set-object-properties! v (delq p (object-properties v)))))))) + (module-undefine-keyword! (current-module) symbol))) (define get-global-definition-hook (lambda (symbol module) - (let* ((module (if module - (resolve-module (cdr module)) - (let ((mod (current-module))) - (if mod (warn "wha" symbol)) - mod))) - (v (module-variable module symbol))) - (and v (object-property v '*sc-expander*))))) + (if (and (not module) (current-module)) + (warn "module system is booted, we should have a module" symbol)) + (module-lookup-keyword (if module (resolve-module (cdr module)) + (current-module)) + symbol))) ) @@ -2170,7 +2155,6 @@ p (syntax-object-wrap e) '() (syntax-object-module e))) (else (match* (unannotate e) p empty-wrap '() #f))))) -(set! sc-chi chi) )) ) From e4721dde312fb2e00963e826441edcc71ee840be Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 20:36:58 +0200 Subject: [PATCH 081/375] replace psyntax's syntax-error with r6rs' syntax-violation * module/ice-9/boot-9.scm (syntax-violation): Well, as long as we have to have a function for indicating syntax errors, let's let it be a well-thought-out one -- syntax-violation from r6rs. No more syntax-error. * module/ice-9/psyntax-pp.scm: Regenerated. * module/ice-9/psyntax.scm: Replace instances of syntax-error with syntax-violation. Implement as a scm-error to 'syntax-error, with some nice arguments. --- module/ice-9/boot-9.scm | 2 +- module/ice-9/psyntax-pp.scm | 22 +++--- module/ice-9/psyntax.scm | 137 +++++++++++++++++++++--------------- 3 files changed, 91 insertions(+), 70 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 356a2416d..f01bcf4ef 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -184,7 +184,7 @@ (define sc-expand3 #f) (define install-global-transformer #f) (define syntax-dispatch #f) -(define syntax-error #f) +(define syntax-violation #f) (define (annotation? x) #f) (define bound-identifier=? #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 09e35e360..99668596d 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-error p1361 "nonprocedure transformer"))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-error e1363 "duplicate bound keyword in") (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-error (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) (syntax-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax-object->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-error e1386 "invalid parameter list in") (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-error e1386 "invalid parameter list in") (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-error e1386)) tmp1393))) (syntax-dispatch tmp1393 (quote (any any . each-any)))))) (syntax-dispatch tmp1393 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-error outer-form1426 "no expressions in body") (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-error tmp1455))) (syntax-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-error outer-form1426 "invalid or duplicate identifier in definition")) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-error x1486 "encountered raw symbol in macro output")) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-error tmp1502))) (syntax-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-error tmp1518))) (syntax-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-error tmp1524))) (syntax-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-error (wrap1111 value1509 w1512 mod1514) "invalid context for definition of") (if (memv t1515 (quote (syntax))) (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to pattern variable outside syntax form") (if (memv t1515 (quote (displaced-lexical))) (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-error tmp1563))) (syntax-dispatch tmp1563 (quote (any any . each-any)))))) (syntax-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-error tmp1576))) (syntax-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-error (wrap1111 value1557 w1559 mod1561) "identifier out of context") (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-error (wrap1111 value1557 w1559 mod1561) "cannot define keyword at top level"))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-error tmp1612))) (syntax-dispatch tmp1612 (quote (any any)))))) (syntax-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-error tmp1637))) (syntax-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1111 x1651 w1647 #f) "invalid eval-when situation")))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-error (source-wrap1112 id1881 w1862 s1863 mod1864) "identifier out of context")))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-error (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) (syntax-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-error (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) (syntax-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-error src1927 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-error src1935 "misplaced ellipsis in syntax form") (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) (syntax-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) (syntax-dispatch tmp1946 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1946 (quote (any . any)))))) (syntax-dispatch tmp1946 (quote (any any . any)))))) (syntax-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-error e1999)) tmp2000))) (syntax-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-error tmp2012))) (syntax-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-error e2020 "duplicate bound variable in") (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-error (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) (syntax-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-error e2066 "duplicate bound variable in") (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-error (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) (syntax-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-error (wrap1111 id2099 w2090 mod2092) "identifier out of context") (syntax-error (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-error (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) (syntax-dispatch tmp2093 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax-object->datum id2133) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-error tmp2125))) (syntax-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax-object->datum id2144) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-error tmp2136))) (syntax-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-error)) x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-error (car clauses2152) "invalid syntax-case clause")) tmp2155))) (syntax-dispatch tmp2155 (quote (any any any)))))) (syntax-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-error pat2171 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-error pat2171 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) (syntax-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) (syntax-dispatch tmp2200 (quote #(vector each-any)))))) (syntax-dispatch tmp2200 (quote ()))))) (syntax-dispatch tmp2200 (quote (any . any)))))) (syntax-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-error e2227 "invalid literals list in"))) tmp2229) (syntax-error tmp2228))) (syntax-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax-object (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax-object->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-error (lambda (object2262 . messages2261) (begin (for-each (lambda (x2263) (let ((x2264 x2263)) (if (not (string? x2264)) (error-hook1056 (quote syntax-error) "invalid argument" x2264)))) messages2261) (let ((message2265 (if (null? messages2261) "invalid syntax" (apply string-append messages2261)))) (error-hook1056 #f message2265 (strip1130 object2262 (quote (())))))))) (set! install-global-transformer (lambda (sym2266 v2267) (begin (let ((x2268 sym2266)) (if (not (symbol? x2268)) (error-hook1056 (quote define-syntax) "invalid argument" x2268))) (let ((x2269 v2267)) (if (not (procedure? x2269)) (error-hook1056 (quote define-syntax) "invalid argument" x2269))) (global-extend1081 (quote macro) sym2266 v2267)))) (letrec ((match2274 (lambda (e2275 p2276 w2277 r2278 mod2279) (cond ((not r2278) #f) ((eq? p2276 (quote any)) (cons (wrap1111 e2275 w2277 mod2279) r2278)) ((syntax-object?1067 e2275) (match*2273 (let ((e2280 (syntax-object-expression1068 e2275))) (if (annotation? e2280) (annotation-expression e2280) e2280)) p2276 (join-wraps1102 w2277 (syntax-object-wrap1069 e2275)) r2278 (syntax-object-module1070 e2275))) (else (match*2273 (let ((e2281 e2275)) (if (annotation? e2281) (annotation-expression e2281) e2281)) p2276 w2277 r2278 mod2279))))) (match*2273 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((null? p2283) (and (null? e2282) r2285)) ((pair? p2283) (and (pair? e2282) (match2274 (car e2282) (car p2283) w2284 (match2274 (cdr e2282) (cdr p2283) w2284 r2285 mod2286) mod2286))) ((eq? p2283 (quote each-any)) (let ((l2287 (match-each-any2271 e2282 w2284 mod2286))) (and l2287 (cons l2287 r2285)))) (else (let ((t2288 (vector-ref p2283 0))) (if (memv t2288 (quote (each))) (if (null? e2282) (match-empty2272 (vector-ref p2283 1) r2285) (let ((l2289 (match-each2270 e2282 (vector-ref p2283 1) w2284 mod2286))) (and l2289 (let collect2290 ((l2291 l2289)) (if (null? (car l2291)) r2285 (cons (map car l2291) (collect2290 (map cdr l2291)))))))) (if (memv t2288 (quote (free-id))) (and (id?1083 e2282) (free-id=?1106 (wrap1111 e2282 w2284 mod2286) (vector-ref p2283 1)) r2285) (if (memv t2288 (quote (atom))) (and (equal? (vector-ref p2283 1) (strip1130 e2282 w2284)) r2285) (if (memv t2288 (quote (vector))) (and (vector? e2282) (match2274 (vector->list e2282) (vector-ref p2283 1) w2284 r2285 mod2286))))))))))) (match-empty2272 (lambda (p2292 r2293) (cond ((null? p2292) r2293) ((eq? p2292 (quote any)) (cons (quote ()) r2293)) ((pair? p2292) (match-empty2272 (car p2292) (match-empty2272 (cdr p2292) r2293))) ((eq? p2292 (quote each-any)) (cons (quote ()) r2293)) (else (let ((t2294 (vector-ref p2292 0))) (if (memv t2294 (quote (each))) (match-empty2272 (vector-ref p2292 1) r2293) (if (memv t2294 (quote (free-id atom))) r2293 (if (memv t2294 (quote (vector))) (match-empty2272 (vector-ref p2292 1) r2293))))))))) (match-each-any2271 (lambda (e2295 w2296 mod2297) (cond ((annotation? e2295) (match-each-any2271 (annotation-expression e2295) w2296 mod2297)) ((pair? e2295) (let ((l2298 (match-each-any2271 (cdr e2295) w2296 mod2297))) (and l2298 (cons (wrap1111 (car e2295) w2296 mod2297) l2298)))) ((null? e2295) (quote ())) ((syntax-object?1067 e2295) (match-each-any2271 (syntax-object-expression1068 e2295) (join-wraps1102 w2296 (syntax-object-wrap1069 e2295)) mod2297)) (else #f)))) (match-each2270 (lambda (e2299 p2300 w2301 mod2302) (cond ((annotation? e2299) (match-each2270 (annotation-expression e2299) p2300 w2301 mod2302)) ((pair? e2299) (let ((first2303 (match2274 (car e2299) p2300 w2301 (quote ()) mod2302))) (and first2303 (let ((rest2304 (match-each2270 (cdr e2299) p2300 w2301 mod2302))) (and rest2304 (cons first2303 rest2304)))))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each2270 (syntax-object-expression1068 e2299) p2300 (join-wraps1102 w2301 (syntax-object-wrap1069 e2299)) (syntax-object-module1070 e2299))) (else #f))))) (set! syntax-dispatch (lambda (e2305 p2306) (cond ((eq? p2306 (quote any)) (list e2305)) ((syntax-object?1067 e2305) (match*2273 (let ((e2307 (syntax-object-expression1068 e2305))) (if (annotation? e2307) (annotation-expression e2307) e2307)) p2306 (syntax-object-wrap1069 e2305) (quote ()) (syntax-object-module1070 e2305))) (else (match*2273 (let ((e2308 e2305)) (if (annotation? e2308) (annotation-expression e2308) e2308)) p2306 (quote (())) (quote ()) #f)))))))) -(install-global-transformer (quote with-syntax) (lambda (x2309) ((lambda (tmp2310) ((lambda (tmp2311) (if tmp2311 (apply (lambda (_2312 e12313 e22314) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12313 e22314))) tmp2311) ((lambda (tmp2316) (if tmp2316 (apply (lambda (_2317 out2318 in2319 e12320 e22321) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2319 (quote ()) (list out2318 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12320 e22321))))) tmp2316) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2326) (quote ()) (list out2325 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12327 e22328))))) tmp2323) (syntax-error tmp2310))) (syntax-dispatch tmp2310 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any () any . each-any))))) x2309))) -(install-global-transformer (quote syntax-rules) (lambda (x2332) ((lambda (tmp2333) ((lambda (tmp2334) (if tmp2334 (apply (lambda (_2335 k2336 keyword2337 pattern2338 template2339) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2336 (map (lambda (tmp2342 tmp2341) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2341) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2342))) template2339 pattern2338)))))) tmp2334) (syntax-error tmp2333))) (syntax-dispatch tmp2333 (quote (any each-any . #(each ((any . any) any))))))) x2332))) -(install-global-transformer (quote let*) (lambda (x2343) ((lambda (tmp2344) ((lambda (tmp2345) (if (if tmp2345 (apply (lambda (let*2346 x2347 v2348 e12349 e22350) (andmap identifier? x2347)) tmp2345) #f) (apply (lambda (let*2352 x2353 v2354 e12355 e22356) (let f2357 ((bindings2358 (map list x2353 v2354))) (if (null? bindings2358) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12355 e22356))) ((lambda (tmp2362) ((lambda (tmp2363) (if tmp2363 (apply (lambda (body2364 binding2365) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2365) body2364)) tmp2363) (syntax-error tmp2362))) (syntax-dispatch tmp2362 (quote (any any))))) (list (f2357 (cdr bindings2358)) (car bindings2358)))))) tmp2345) (syntax-error tmp2344))) (syntax-dispatch tmp2344 (quote (any #(each (any any)) any . each-any))))) x2343))) -(install-global-transformer (quote do) (lambda (orig-x2366) ((lambda (tmp2367) ((lambda (tmp2368) (if tmp2368 (apply (lambda (_2369 var2370 init2371 step2372 e02373 e12374 c2375) ((lambda (tmp2376) ((lambda (tmp2377) (if tmp2377 (apply (lambda (step2378) ((lambda (tmp2379) ((lambda (tmp2380) (if tmp2380 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02373) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2378))))))) tmp2380) ((lambda (tmp2385) (if tmp2385 (apply (lambda (e12386 e22387) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2370 init2371) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02373 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12386 e22387)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2375 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2378))))))) tmp2385) (syntax-error tmp2379))) (syntax-dispatch tmp2379 (quote (any . each-any)))))) (syntax-dispatch tmp2379 (quote ())))) e12374)) tmp2377) (syntax-error tmp2376))) (syntax-dispatch tmp2376 (quote each-any)))) (map (lambda (v2394 s2395) ((lambda (tmp2396) ((lambda (tmp2397) (if tmp2397 (apply (lambda () v2394) tmp2397) ((lambda (tmp2398) (if tmp2398 (apply (lambda (e2399) e2399) tmp2398) ((lambda (_2400) (syntax-error orig-x2366)) tmp2396))) (syntax-dispatch tmp2396 (quote (any)))))) (syntax-dispatch tmp2396 (quote ())))) s2395)) var2370 step2372))) tmp2368) (syntax-error tmp2367))) (syntax-dispatch tmp2367 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2366))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2403 (lambda (x2407 y2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (dy2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (dx2418) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2418 dy2415))) tmp2417) ((lambda (_2419) (if (null? dy2415) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2411) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2411 y2412))) tmp2416))) (syntax-dispatch tmp2416 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2411)) tmp2414) ((lambda (tmp2420) (if tmp2420 (apply (lambda (stuff2421) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2411 stuff2421))) tmp2420) ((lambda (else2422) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2411 y2412)) tmp2413))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2413 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2412)) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any any))))) (list x2407 y2408)))) (quasiappend2404 (lambda (x2423 y2424) ((lambda (tmp2425) ((lambda (tmp2426) (if tmp2426 (apply (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda () x2427) tmp2430) ((lambda (_2431) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2427 y2428)) tmp2429))) (syntax-dispatch tmp2429 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2428)) tmp2426) (syntax-error tmp2425))) (syntax-dispatch tmp2425 (quote (any any))))) (list x2423 y2424)))) (quasivector2405 (lambda (x2432) ((lambda (tmp2433) ((lambda (x2434) ((lambda (tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda (x2437) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2437))) tmp2436) ((lambda (tmp2439) (if tmp2439 (apply (lambda (x2440) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2440)) tmp2439) ((lambda (_2442) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2434)) tmp2435))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2434)) tmp2433)) x2432))) (quasi2406 (lambda (p2443 lev2444) ((lambda (tmp2445) ((lambda (tmp2446) (if tmp2446 (apply (lambda (p2447) (if (= lev2444 0) p2447 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2406 (list p2447) (- lev2444 1))))) tmp2446) ((lambda (tmp2448) (if tmp2448 (apply (lambda (p2449 q2450) (if (= lev2444 0) (quasiappend2404 p2449 (quasi2406 q2450 lev2444)) (quasicons2403 (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2406 (list p2449) (- lev2444 1))) (quasi2406 q2450 lev2444)))) tmp2448) ((lambda (tmp2451) (if tmp2451 (apply (lambda (p2452) (quasicons2403 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2406 (list p2452) (+ lev2444 1)))) tmp2451) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454 q2455) (quasicons2403 (quasi2406 p2454 lev2444) (quasi2406 q2455 lev2444))) tmp2453) ((lambda (tmp2456) (if tmp2456 (apply (lambda (x2457) (quasivector2405 (quasi2406 x2457 lev2444))) tmp2456) ((lambda (p2459) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2459)) tmp2445))) (syntax-dispatch tmp2445 (quote #(vector each-any)))))) (syntax-dispatch tmp2445 (quote (any . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2445 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2445 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2443)))) (lambda (x2460) ((lambda (tmp2461) ((lambda (tmp2462) (if tmp2462 (apply (lambda (_2463 e2464) (quasi2406 e2464 0)) tmp2462) (syntax-error tmp2461))) (syntax-dispatch tmp2461 (quote (any any))))) x2460)))) -(install-global-transformer (quote include) (lambda (x2465) (letrec ((read-file2466 (lambda (fn2467 k2468) (let ((p2469 (open-input-file fn2467))) (let f2470 ((x2471 (read p2469))) (if (eof-object? x2471) (begin (close-input-port p2469) (quote ())) (cons (datum->syntax-object k2468 x2471) (f2470 (read p2469))))))))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (k2474 filename2475) (let ((fn2476 (syntax-object->datum filename2475))) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (exp2479) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2479)) tmp2478) (syntax-error tmp2477))) (syntax-dispatch tmp2477 (quote each-any)))) (read-file2466 fn2476 k2474)))) tmp2473) (syntax-error tmp2472))) (syntax-dispatch tmp2472 (quote (any any))))) x2465)))) -(install-global-transformer (quote unquote) (lambda (x2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (_2484 e2485) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2485))) tmp2483) (syntax-error tmp2482))) (syntax-dispatch tmp2482 (quote (any any))))) x2481))) -(install-global-transformer (quote unquote-splicing) (lambda (x2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (_2489 e2490) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2490))) tmp2488) (syntax-error tmp2487))) (syntax-dispatch tmp2487 (quote (any any))))) x2486))) -(install-global-transformer (quote case) (lambda (x2491) ((lambda (tmp2492) ((lambda (tmp2493) (if tmp2493 (apply (lambda (_2494 e2495 m12496 m22497) ((lambda (tmp2498) ((lambda (body2499) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2495)) body2499)) tmp2498)) (let f2500 ((clause2501 m12496) (clauses2502 m22497)) (if (null? clauses2502) ((lambda (tmp2504) ((lambda (tmp2505) (if tmp2505 (apply (lambda (e12506 e22507) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12506 e22507))) tmp2505) ((lambda (tmp2509) (if tmp2509 (apply (lambda (k2510 e12511 e22512) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2510)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12511 e22512)))) tmp2509) ((lambda (_2515) (syntax-error x2491)) tmp2504))) (syntax-dispatch tmp2504 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2504 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2501) ((lambda (tmp2516) ((lambda (rest2517) ((lambda (tmp2518) ((lambda (tmp2519) (if tmp2519 (apply (lambda (k2520 e12521 e22522) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2520)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12521 e22522)) rest2517)) tmp2519) ((lambda (_2525) (syntax-error x2491)) tmp2518))) (syntax-dispatch tmp2518 (quote (each-any any . each-any))))) clause2501)) tmp2516)) (f2500 (car clauses2502) (cdr clauses2502))))))) tmp2493) (syntax-error tmp2492))) (syntax-dispatch tmp2492 (quote (any any any . each-any))))) x2491))) -(install-global-transformer (quote identifier-syntax) (lambda (x2526) ((lambda (tmp2527) ((lambda (tmp2528) (if tmp2528 (apply (lambda (_2529 e2530) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2530)) (list (cons _2529 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2530 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2528) (syntax-error tmp2527))) (syntax-dispatch tmp2527 (quote (any any))))) x2526))) +(letrec ((lambda-var-list1262 (lambda (vars1467) (let lvl1468 ((vars1469 vars1467) (ls1470 (quote ())) (w1471 (quote (())))) (cond ((pair? vars1469) (lvl1468 (cdr vars1469) (cons (wrap1241 (car vars1469) w1471 #f) ls1470) w1471)) ((id?1213 vars1469) (cons (wrap1241 vars1469 w1471 #f) ls1470)) ((null? vars1469) ls1470) ((syntax-object?1197 vars1469) (lvl1468 (syntax-object-expression1198 vars1469) ls1470 (join-wraps1232 w1471 (syntax-object-wrap1199 vars1469)))) ((annotation? vars1469) (lvl1468 (annotation-expression vars1469) ls1470 w1471)) (else (cons vars1469 ls1470)))))) (gen-var1261 (lambda (id1472) (let ((id1473 (if (syntax-object?1197 id1472) (syntax-object-expression1198 id1472) id1472))) (if (annotation? id1473) (build-annotated1190 (annotation-source id1473) (gensym (symbol->string (annotation-expression id1473)))) (build-annotated1190 #f (gensym (symbol->string id1473))))))) (strip1260 (lambda (x1474 w1475) (if (memq (quote top) (wrap-marks1216 w1475)) (if (or (annotation? x1474) (and (pair? x1474) (annotation? (car x1474)))) (strip-annotation1259 x1474 #f) x1474) (let f1476 ((x1477 x1474)) (cond ((syntax-object?1197 x1477) (strip1260 (syntax-object-expression1198 x1477) (syntax-object-wrap1199 x1477))) ((pair? x1477) (let ((a1478 (f1476 (car x1477))) (d1479 (f1476 (cdr x1477)))) (if (and (eq? a1478 (car x1477)) (eq? d1479 (cdr x1477))) x1477 (cons a1478 d1479)))) ((vector? x1477) (let ((old1480 (vector->list x1477))) (let ((new1481 (map f1476 old1480))) (if (andmap eq? old1480 new1481) x1477 (list->vector new1481))))) (else x1477)))))) (strip-annotation1259 (lambda (x1482 parent1483) (cond ((pair? x1482) (let ((new1484 (cons #f #f))) (begin (if parent1483 (set-annotation-stripped! parent1483 new1484)) (set-car! new1484 (strip-annotation1259 (car x1482) #f)) (set-cdr! new1484 (strip-annotation1259 (cdr x1482) #f)) new1484))) ((annotation? x1482) (or (annotation-stripped x1482) (strip-annotation1259 (annotation-expression x1482) x1482))) ((vector? x1482) (let ((new1485 (make-vector (vector-length x1482)))) (begin (if parent1483 (set-annotation-stripped! parent1483 new1485)) (let loop1486 ((i1487 (- (vector-length x1482) 1))) (unless (fx<1183 i1487 0) (vector-set! new1485 i1487 (strip-annotation1259 (vector-ref x1482 i1487) #f)) (loop1486 (fx-1181 i1487 1)))) new1485))) (else x1482)))) (ellipsis?1258 (lambda (x1488) (and (nonsymbol-id?1212 x1488) (free-id=?1236 x1488 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1257 (lambda () (build-annotated1190 #f (list (build-annotated1190 #f (quote void)))))) (eval-local-transformer1256 (lambda (expanded1489 mod1490) (let ((p1491 (local-eval-hook1185 expanded1489 mod1490))) (if (procedure? p1491) p1491 (syntax-violation #f "nonprocedure transformer" p1491))))) (chi-local-syntax1255 (lambda (rec?1492 e1493 r1494 w1495 s1496 mod1497 k1498) ((lambda (tmp1499) ((lambda (tmp1500) (if tmp1500 (apply (lambda (_1501 id1502 val1503 e11504 e21505) (let ((ids1506 id1502)) (if (not (valid-bound-ids?1238 ids1506)) (syntax-violation #f "duplicate bound keyword" e1493) (let ((labels1508 (gen-labels1219 ids1506))) (let ((new-w1509 (make-binding-wrap1230 ids1506 labels1508 w1495))) (k1498 (cons e11504 e21505) (extend-env1207 labels1508 (let ((w1511 (if rec?1492 new-w1509 w1495)) (trans-r1512 (macros-only-env1209 r1494))) (map (lambda (x1513) (cons (quote macro) (eval-local-transformer1256 (chi1249 x1513 trans-r1512 w1511 mod1497) mod1497))) val1503)) r1494) new-w1509 s1496 mod1497)))))) tmp1500) ((lambda (_1515) (syntax-violation #f "bad local syntax definition" (source-wrap1242 e1493 w1495 s1496 mod1497))) tmp1499))) (syntax-dispatch tmp1499 (quote (any #(each (any any)) any . each-any))))) e1493))) (chi-lambda-clause1254 (lambda (e1516 docstring1517 c1518 r1519 w1520 mod1521 k1522) ((lambda (tmp1523) ((lambda (tmp1524) (if (if tmp1524 (apply (lambda (args1525 doc1526 e11527 e21528) (and (string? (syntax-object->datum doc1526)) (not docstring1517))) tmp1524) #f) (apply (lambda (args1529 doc1530 e11531 e21532) (chi-lambda-clause1254 e1516 doc1530 (cons args1529 (cons e11531 e21532)) r1519 w1520 mod1521 k1522)) tmp1524) ((lambda (tmp1534) (if tmp1534 (apply (lambda (id1535 e11536 e21537) (let ((ids1538 id1535)) (if (not (valid-bound-ids?1238 ids1538)) (syntax-violation (quote lambda) "invalid parameter list" e1516) (let ((labels1540 (gen-labels1219 ids1538)) (new-vars1541 (map gen-var1261 ids1538))) (k1522 new-vars1541 docstring1517 (chi-body1253 (cons e11536 e21537) e1516 (extend-var-env1208 labels1540 new-vars1541 r1519) (make-binding-wrap1230 ids1538 labels1540 w1520) mod1521)))))) tmp1534) ((lambda (tmp1543) (if tmp1543 (apply (lambda (ids1544 e11545 e21546) (let ((old-ids1547 (lambda-var-list1262 ids1544))) (if (not (valid-bound-ids?1238 old-ids1547)) (syntax-violation (quote lambda) "invalid parameter list" e1516) (let ((labels1548 (gen-labels1219 old-ids1547)) (new-vars1549 (map gen-var1261 old-ids1547))) (k1522 (let f1550 ((ls11551 (cdr new-vars1549)) (ls21552 (car new-vars1549))) (if (null? ls11551) ls21552 (f1550 (cdr ls11551) (cons (car ls11551) ls21552)))) docstring1517 (chi-body1253 (cons e11545 e21546) e1516 (extend-var-env1208 labels1548 new-vars1549 r1519) (make-binding-wrap1230 old-ids1547 labels1548 w1520) mod1521)))))) tmp1543) ((lambda (_1554) (syntax-violation (quote lambda) "bad lambda" e1516)) tmp1523))) (syntax-dispatch tmp1523 (quote (any any . each-any)))))) (syntax-dispatch tmp1523 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1523 (quote (any any any . each-any))))) c1518))) (chi-body1253 (lambda (body1555 outer-form1556 r1557 w1558 mod1559) (let ((r1560 (cons (quote ("placeholder" placeholder)) r1557))) (let ((ribcage1561 (make-ribcage1220 (quote ()) (quote ()) (quote ())))) (let ((w1562 (make-wrap1215 (wrap-marks1216 w1558) (cons ribcage1561 (wrap-subst1217 w1558))))) (let parse1563 ((body1564 (map (lambda (x1570) (cons r1560 (wrap1241 x1570 w1562 mod1559))) body1555)) (ids1565 (quote ())) (labels1566 (quote ())) (vars1567 (quote ())) (vals1568 (quote ())) (bindings1569 (quote ()))) (if (null? body1564) (syntax-violation #f "no expressions in body" outer-form1556) (let ((e1571 (cdar body1564)) (er1572 (caar body1564))) (call-with-values (lambda () (syntax-type1247 e1571 er1572 (quote (())) #f ribcage1561 mod1559)) (lambda (type1573 value1574 e1575 w1576 s1577 mod1578) (let ((t1579 type1573)) (if (memv t1579 (quote (define-form))) (let ((id1580 (wrap1241 value1574 w1576 mod1578)) (label1581 (gen-label1218))) (let ((var1582 (gen-var1261 id1580))) (begin (extend-ribcage!1229 ribcage1561 id1580 label1581) (parse1563 (cdr body1564) (cons id1580 ids1565) (cons label1581 labels1566) (cons var1582 vars1567) (cons (cons er1572 (wrap1241 e1575 w1576 mod1578)) vals1568) (cons (cons (quote lexical) var1582) bindings1569))))) (if (memv t1579 (quote (define-syntax-form))) (let ((id1583 (wrap1241 value1574 w1576 mod1578)) (label1584 (gen-label1218))) (begin (extend-ribcage!1229 ribcage1561 id1583 label1584) (parse1563 (cdr body1564) (cons id1583 ids1565) (cons label1584 labels1566) vars1567 vals1568 (cons (cons (quote macro) (cons er1572 (wrap1241 e1575 w1576 mod1578))) bindings1569)))) (if (memv t1579 (quote (begin-form))) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (_1587 e11588) (parse1563 (let f1589 ((forms1590 e11588)) (if (null? forms1590) (cdr body1564) (cons (cons er1572 (wrap1241 (car forms1590) w1576 mod1578)) (f1589 (cdr forms1590))))) ids1565 labels1566 vars1567 vals1568 bindings1569)) tmp1586) (syntax-violation #f "source expression failed to match any pattern" tmp1585))) (syntax-dispatch tmp1585 (quote (any . each-any))))) e1575) (if (memv t1579 (quote (local-syntax-form))) (chi-local-syntax1255 value1574 e1575 er1572 w1576 s1577 mod1578 (lambda (forms1592 er1593 w1594 s1595 mod1596) (parse1563 (let f1597 ((forms1598 forms1592)) (if (null? forms1598) (cdr body1564) (cons (cons er1593 (wrap1241 (car forms1598) w1594 mod1596)) (f1597 (cdr forms1598))))) ids1565 labels1566 vars1567 vals1568 bindings1569))) (if (null? ids1565) (build-sequence1192 #f (map (lambda (x1599) (chi1249 (cdr x1599) (car x1599) (quote (())) mod1578)) (cons (cons er1572 (source-wrap1242 e1575 w1576 s1577 mod1578)) (cdr body1564)))) (begin (if (not (valid-bound-ids?1238 ids1565)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1556)) (let loop1600 ((bs1601 bindings1569) (er-cache1602 #f) (r-cache1603 #f)) (if (not (null? bs1601)) (let ((b1604 (car bs1601))) (if (eq? (car b1604) (quote macro)) (let ((er1605 (cadr b1604))) (let ((r-cache1606 (if (eq? er1605 er-cache1602) r-cache1603 (macros-only-env1209 er1605)))) (begin (set-cdr! b1604 (eval-local-transformer1256 (chi1249 (cddr b1604) r-cache1606 (quote (())) mod1578) mod1578)) (loop1600 (cdr bs1601) er1605 r-cache1606)))) (loop1600 (cdr bs1601) er-cache1602 r-cache1603))))) (set-cdr! r1560 (extend-env1207 labels1566 bindings1569 (cdr r1560))) (build-letrec1195 #f vars1567 (map (lambda (x1607) (chi1249 (cdr x1607) (car x1607) (quote (())) mod1578)) vals1568) (build-sequence1192 #f (map (lambda (x1608) (chi1249 (cdr x1608) (car x1608) (quote (())) mod1578)) (cons (cons er1572 (source-wrap1242 e1575 w1576 s1577 mod1578)) (cdr body1564)))))))))))))))))))))) (chi-macro1252 (lambda (p1609 e1610 r1611 w1612 rib1613 mod1614) (letrec ((rebuild-macro-output1615 (lambda (x1616 m1617) (cond ((pair? x1616) (cons (rebuild-macro-output1615 (car x1616) m1617) (rebuild-macro-output1615 (cdr x1616) m1617))) ((syntax-object?1197 x1616) (let ((w1618 (syntax-object-wrap1199 x1616))) (let ((ms1619 (wrap-marks1216 w1618)) (s1620 (wrap-subst1217 w1618))) (if (and (pair? ms1619) (eq? (car ms1619) #f)) (make-syntax-object1196 (syntax-object-expression1198 x1616) (make-wrap1215 (cdr ms1619) (if rib1613 (cons rib1613 (cdr s1620)) (cdr s1620))) (syntax-object-module1200 x1616)) (make-syntax-object1196 (syntax-object-expression1198 x1616) (make-wrap1215 (cons m1617 ms1619) (if rib1613 (cons rib1613 (cons (quote shift) s1620)) (cons (quote shift) s1620))) (let ((pmod1621 (procedure-module p1609))) (if pmod1621 (cons (quote hygiene) (module-name pmod1621)) (quote (hygiene guile))))))))) ((vector? x1616) (let ((n1622 (vector-length x1616))) (let ((v1623 (make-vector n1622))) (let doloop1624 ((i1625 0)) (if (fx=1182 i1625 n1622) v1623 (begin (vector-set! v1623 i1625 (rebuild-macro-output1615 (vector-ref x1616 i1625) m1617)) (doloop1624 (fx+1180 i1625 1)))))))) ((symbol? x1616) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1242 e1610 w1612 s mod1614) x1616)) (else x1616))))) (rebuild-macro-output1615 (p1609 (wrap1241 e1610 (anti-mark1228 w1612) mod1614)) (string #\m))))) (chi-application1251 (lambda (x1626 e1627 r1628 w1629 s1630 mod1631) ((lambda (tmp1632) ((lambda (tmp1633) (if tmp1633 (apply (lambda (e01634 e11635) (build-annotated1190 s1630 (cons x1626 (map (lambda (e1636) (chi1249 e1636 r1628 w1629 mod1631)) e11635)))) tmp1633) (syntax-violation #f "source expression failed to match any pattern" tmp1632))) (syntax-dispatch tmp1632 (quote (any . each-any))))) e1627))) (chi-expr1250 (lambda (type1638 value1639 e1640 r1641 w1642 s1643 mod1644) (let ((t1645 type1638)) (if (memv t1645 (quote (lexical))) (build-annotated1190 s1643 value1639) (if (memv t1645 (quote (core external-macro))) (value1639 e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (module-ref))) (call-with-values (lambda () (value1639 e1640)) (lambda (id1646 mod1647) (build-annotated1190 s1643 (if mod1647 (make-module-ref (cdr mod1647) id1646 (car mod1647)) (make-module-ref mod1647 id1646 (quote bare)))))) (if (memv t1645 (quote (lexical-call))) (chi-application1251 (build-annotated1190 (source-annotation1204 (car e1640)) value1639) e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (global-call))) (chi-application1251 (build-annotated1190 (source-annotation1204 (car e1640)) (if (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644) (make-module-ref (cdr (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644)) value1639 (car (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644))) (make-module-ref (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644) value1639 (quote bare)))) e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (constant))) (build-data1191 s1643 (strip1260 (source-wrap1242 e1640 w1642 s1643 mod1644) (quote (())))) (if (memv t1645 (quote (global))) (build-annotated1190 s1643 (if mod1644 (make-module-ref (cdr mod1644) value1639 (car mod1644)) (make-module-ref mod1644 value1639 (quote bare)))) (if (memv t1645 (quote (call))) (chi-application1251 (chi1249 (car e1640) r1641 w1642 mod1644) e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (begin-form))) ((lambda (tmp1648) ((lambda (tmp1649) (if tmp1649 (apply (lambda (_1650 e11651 e21652) (chi-sequence1243 (cons e11651 e21652) r1641 w1642 s1643 mod1644)) tmp1649) (syntax-violation #f "source expression failed to match any pattern" tmp1648))) (syntax-dispatch tmp1648 (quote (any any . each-any))))) e1640) (if (memv t1645 (quote (local-syntax-form))) (chi-local-syntax1255 value1639 e1640 r1641 w1642 s1643 mod1644 chi-sequence1243) (if (memv t1645 (quote (eval-when-form))) ((lambda (tmp1654) ((lambda (tmp1655) (if tmp1655 (apply (lambda (_1656 x1657 e11658 e21659) (let ((when-list1660 (chi-when-list1246 e1640 x1657 w1642))) (if (memq (quote eval) when-list1660) (chi-sequence1243 (cons e11658 e21659) r1641 w1642 s1643 mod1644) (chi-void1257)))) tmp1655) (syntax-violation #f "source expression failed to match any pattern" tmp1654))) (syntax-dispatch tmp1654 (quote (any each-any any . each-any))))) e1640) (if (memv t1645 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1640 (wrap1241 value1639 w1642 mod1644)) (if (memv t1645 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1242 e1640 w1642 s1643 mod1644)) (if (memv t1645 (quote (displaced-lexical))) (syntax-violation #f (source-wrap1242 e1640 w1642 s1643 mod1644) "reference to identifier outside its scope") (syntax-violation #f "unexpected syntax" (source-wrap1242 e1640 w1642 s1643 mod1644))))))))))))))))))) (chi1249 (lambda (e1663 r1664 w1665 mod1666) (call-with-values (lambda () (syntax-type1247 e1663 r1664 w1665 #f #f mod1666)) (lambda (type1667 value1668 e1669 w1670 s1671 mod1672) (chi-expr1250 type1667 value1668 e1669 r1664 w1670 s1671 mod1672))))) (chi-top1248 (lambda (e1673 r1674 w1675 m1676 esew1677 mod1678) (call-with-values (lambda () (syntax-type1247 e1673 r1674 w1675 #f #f mod1678)) (lambda (type1686 value1687 e1688 w1689 s1690 mod1691) (let ((t1692 type1686)) (if (memv t1692 (quote (begin-form))) ((lambda (tmp1693) ((lambda (tmp1694) (if tmp1694 (apply (lambda (_1695) (chi-void1257)) tmp1694) ((lambda (tmp1696) (if tmp1696 (apply (lambda (_1697 e11698 e21699) (chi-top-sequence1244 (cons e11698 e21699) r1674 w1689 s1690 m1676 esew1677 mod1691)) tmp1696) (syntax-violation #f "source expression failed to match any pattern" tmp1693))) (syntax-dispatch tmp1693 (quote (any any . each-any)))))) (syntax-dispatch tmp1693 (quote (any))))) e1688) (if (memv t1692 (quote (local-syntax-form))) (chi-local-syntax1255 value1687 e1688 r1674 w1689 s1690 mod1691 (lambda (body1701 r1702 w1703 s1704 mod1705) (chi-top-sequence1244 body1701 r1702 w1703 s1704 m1676 esew1677 mod1705))) (if (memv t1692 (quote (eval-when-form))) ((lambda (tmp1706) ((lambda (tmp1707) (if tmp1707 (apply (lambda (_1708 x1709 e11710 e21711) (let ((when-list1712 (chi-when-list1246 e1688 x1709 w1689)) (body1713 (cons e11710 e21711))) (cond ((eq? m1676 (quote e)) (if (memq (quote eval) when-list1712) (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote e) (quote (eval)) mod1691) (chi-void1257))) ((memq (quote load) when-list1712) (if (or (memq (quote compile) when-list1712) (and (eq? m1676 (quote c&e)) (memq (quote eval) when-list1712))) (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote c&e) (quote (compile load)) mod1691) (if (memq m1676 (quote (c c&e))) (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote c) (quote (load)) mod1691) (chi-void1257)))) ((or (memq (quote compile) when-list1712) (and (eq? m1676 (quote c&e)) (memq (quote eval) when-list1712))) (top-level-eval-hook1184 (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote e) (quote (eval)) mod1691) mod1691) (chi-void1257)) (else (chi-void1257))))) tmp1707) (syntax-violation #f "source expression failed to match any pattern" tmp1706))) (syntax-dispatch tmp1706 (quote (any each-any any . each-any))))) e1688) (if (memv t1692 (quote (define-syntax-form))) (let ((n1716 (id-var-name1235 value1687 w1689)) (r1717 (macros-only-env1209 r1674))) (let ((t1718 m1676)) (if (memv t1718 (quote (c))) (if (memq (quote compile) esew1677) (let ((e1719 (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)))) (begin (top-level-eval-hook1184 e1719 mod1691) (if (memq (quote load) esew1677) e1719 (chi-void1257)))) (if (memq (quote load) esew1677) (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)) (chi-void1257))) (if (memv t1718 (quote (c&e))) (let ((e1720 (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)))) (begin (top-level-eval-hook1184 e1720 mod1691) e1720)) (begin (if (memq (quote eval) esew1677) (top-level-eval-hook1184 (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)) mod1691)) (chi-void1257)))))) (if (memv t1692 (quote (define-form))) (let ((n1721 (id-var-name1235 value1687 w1689))) (let ((type1722 (binding-type1205 (lookup1210 n1721 r1674 mod1691)))) (let ((t1723 type1722)) (if (memv t1723 (quote (global))) (let ((x1724 (build-annotated1190 s1690 (list (quote define) n1721 (chi1249 e1688 r1674 w1689 mod1691))))) (begin (if (eq? m1676 (quote c&e)) (top-level-eval-hook1184 x1724 mod1691)) x1724)) (if (memv t1723 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1688 (wrap1241 value1687 w1689 mod1691)) (if (memv t1723 (quote (core macro module-ref))) (begin (remove-global-definition-hook1188 n1721) (let ((x1725 (build-annotated1190 s1690 (list (quote define) n1721 (chi1249 e1688 r1674 w1689 mod1691))))) (begin (if (eq? m1676 (quote c&e)) (top-level-eval-hook1184 x1725 mod1691)) x1725))) (syntax-violation #f "cannot define keyword at top level" e1688 (wrap1241 value1687 w1689 mod1691)))))))) (let ((x1726 (chi-expr1250 type1686 value1687 e1688 r1674 w1689 s1690 mod1691))) (begin (if (eq? m1676 (quote c&e)) (top-level-eval-hook1184 x1726 mod1691)) x1726)))))))))))) (syntax-type1247 (lambda (e1727 r1728 w1729 s1730 rib1731 mod1732) (cond ((symbol? e1727) (let ((n1733 (id-var-name1235 e1727 w1729))) (let ((b1734 (lookup1210 n1733 r1728 mod1732))) (let ((type1735 (binding-type1205 b1734))) (let ((t1736 type1735)) (if (memv t1736 (quote (lexical))) (values type1735 (binding-value1206 b1734) e1727 w1729 s1730 mod1732) (if (memv t1736 (quote (global))) (values type1735 n1733 e1727 w1729 s1730 mod1732) (if (memv t1736 (quote (macro))) (syntax-type1247 (chi-macro1252 (binding-value1206 b1734) e1727 r1728 w1729 rib1731 mod1732) r1728 (quote (())) s1730 rib1731 mod1732) (values type1735 (binding-value1206 b1734) e1727 w1729 s1730 mod1732))))))))) ((pair? e1727) (let ((first1737 (car e1727))) (if (id?1213 first1737) (let ((n1738 (id-var-name1235 first1737 w1729))) (let ((b1739 (lookup1210 n1738 r1728 (or (and (syntax-object?1197 first1737) (syntax-object-module1200 first1737)) mod1732)))) (let ((type1740 (binding-type1205 b1739))) (let ((t1741 type1740)) (if (memv t1741 (quote (lexical))) (values (quote lexical-call) (binding-value1206 b1739) e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (global))) (values (quote global-call) n1738 e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (macro))) (syntax-type1247 (chi-macro1252 (binding-value1206 b1739) e1727 r1728 w1729 rib1731 mod1732) r1728 (quote (())) s1730 rib1731 mod1732) (if (memv t1741 (quote (core external-macro module-ref))) (values type1740 (binding-value1206 b1739) e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1206 b1739) e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (begin))) (values (quote begin-form) #f e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (eval-when))) (values (quote eval-when-form) #f e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (define))) ((lambda (tmp1742) ((lambda (tmp1743) (if (if tmp1743 (apply (lambda (_1744 name1745 val1746) (id?1213 name1745)) tmp1743) #f) (apply (lambda (_1747 name1748 val1749) (values (quote define-form) name1748 val1749 w1729 s1730 mod1732)) tmp1743) ((lambda (tmp1750) (if (if tmp1750 (apply (lambda (_1751 name1752 args1753 e11754 e21755) (and (id?1213 name1752) (valid-bound-ids?1238 (lambda-var-list1262 args1753)))) tmp1750) #f) (apply (lambda (_1756 name1757 args1758 e11759 e21760) (values (quote define-form) (wrap1241 name1757 w1729 mod1732) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1241 (cons args1758 (cons e11759 e21760)) w1729 mod1732)) (quote (())) s1730 mod1732)) tmp1750) ((lambda (tmp1762) (if (if tmp1762 (apply (lambda (_1763 name1764) (id?1213 name1764)) tmp1762) #f) (apply (lambda (_1765 name1766) (values (quote define-form) (wrap1241 name1766 w1729 mod1732) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1730 mod1732)) tmp1762) (syntax-violation #f "source expression failed to match any pattern" tmp1742))) (syntax-dispatch tmp1742 (quote (any any)))))) (syntax-dispatch tmp1742 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1742 (quote (any any any))))) e1727) (if (memv t1741 (quote (define-syntax))) ((lambda (tmp1767) ((lambda (tmp1768) (if (if tmp1768 (apply (lambda (_1769 name1770 val1771) (id?1213 name1770)) tmp1768) #f) (apply (lambda (_1772 name1773 val1774) (values (quote define-syntax-form) name1773 val1774 w1729 s1730 mod1732)) tmp1768) (syntax-violation #f "source expression failed to match any pattern" tmp1767))) (syntax-dispatch tmp1767 (quote (any any any))))) e1727) (values (quote call) #f e1727 w1729 s1730 mod1732)))))))))))))) (values (quote call) #f e1727 w1729 s1730 mod1732)))) ((syntax-object?1197 e1727) (syntax-type1247 (syntax-object-expression1198 e1727) r1728 (join-wraps1232 w1729 (syntax-object-wrap1199 e1727)) #f rib1731 (or (syntax-object-module1200 e1727) mod1732))) ((annotation? e1727) (syntax-type1247 (annotation-expression e1727) r1728 w1729 (annotation-source e1727) rib1731 mod1732)) ((self-evaluating? e1727) (values (quote constant) #f e1727 w1729 s1730 mod1732)) (else (values (quote other) #f e1727 w1729 s1730 mod1732))))) (chi-when-list1246 (lambda (e1775 when-list1776 w1777) (let f1778 ((when-list1779 when-list1776) (situations1780 (quote ()))) (if (null? when-list1779) situations1780 (f1778 (cdr when-list1779) (cons (let ((x1781 (car when-list1779))) (cond ((free-id=?1236 x1781 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1236 x1781 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1236 x1781 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1775 (wrap1241 x1781 w1777 #f))))) situations1780)))))) (chi-install-global1245 (lambda (name1782 e1783) (build-annotated1190 #f (list (build-annotated1190 #f (quote install-global-transformer)) (build-data1191 #f name1782) e1783)))) (chi-top-sequence1244 (lambda (body1784 r1785 w1786 s1787 m1788 esew1789 mod1790) (build-sequence1192 s1787 (let dobody1791 ((body1792 body1784) (r1793 r1785) (w1794 w1786) (m1795 m1788) (esew1796 esew1789) (mod1797 mod1790)) (if (null? body1792) (quote ()) (let ((first1798 (chi-top1248 (car body1792) r1793 w1794 m1795 esew1796 mod1797))) (cons first1798 (dobody1791 (cdr body1792) r1793 w1794 m1795 esew1796 mod1797)))))))) (chi-sequence1243 (lambda (body1799 r1800 w1801 s1802 mod1803) (build-sequence1192 s1802 (let dobody1804 ((body1805 body1799) (r1806 r1800) (w1807 w1801) (mod1808 mod1803)) (if (null? body1805) (quote ()) (let ((first1809 (chi1249 (car body1805) r1806 w1807 mod1808))) (cons first1809 (dobody1804 (cdr body1805) r1806 w1807 mod1808)))))))) (source-wrap1242 (lambda (x1810 w1811 s1812 defmod1813) (wrap1241 (if s1812 (make-annotation x1810 s1812 #f) x1810) w1811 defmod1813))) (wrap1241 (lambda (x1814 w1815 defmod1816) (cond ((and (null? (wrap-marks1216 w1815)) (null? (wrap-subst1217 w1815))) x1814) ((syntax-object?1197 x1814) (make-syntax-object1196 (syntax-object-expression1198 x1814) (join-wraps1232 w1815 (syntax-object-wrap1199 x1814)) (syntax-object-module1200 x1814))) ((null? x1814) x1814) (else (make-syntax-object1196 x1814 w1815 defmod1816))))) (bound-id-member?1240 (lambda (x1817 list1818) (and (not (null? list1818)) (or (bound-id=?1237 x1817 (car list1818)) (bound-id-member?1240 x1817 (cdr list1818)))))) (distinct-bound-ids?1239 (lambda (ids1819) (let distinct?1820 ((ids1821 ids1819)) (or (null? ids1821) (and (not (bound-id-member?1240 (car ids1821) (cdr ids1821))) (distinct?1820 (cdr ids1821))))))) (valid-bound-ids?1238 (lambda (ids1822) (and (let all-ids?1823 ((ids1824 ids1822)) (or (null? ids1824) (and (id?1213 (car ids1824)) (all-ids?1823 (cdr ids1824))))) (distinct-bound-ids?1239 ids1822)))) (bound-id=?1237 (lambda (i1825 j1826) (if (and (syntax-object?1197 i1825) (syntax-object?1197 j1826)) (and (eq? (let ((e1827 (syntax-object-expression1198 i1825))) (if (annotation? e1827) (annotation-expression e1827) e1827)) (let ((e1828 (syntax-object-expression1198 j1826))) (if (annotation? e1828) (annotation-expression e1828) e1828))) (same-marks?1234 (wrap-marks1216 (syntax-object-wrap1199 i1825)) (wrap-marks1216 (syntax-object-wrap1199 j1826)))) (eq? (let ((e1829 i1825)) (if (annotation? e1829) (annotation-expression e1829) e1829)) (let ((e1830 j1826)) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (free-id=?1236 (lambda (i1831 j1832) (and (eq? (let ((x1833 i1831)) (let ((e1834 (if (syntax-object?1197 x1833) (syntax-object-expression1198 x1833) x1833))) (if (annotation? e1834) (annotation-expression e1834) e1834))) (let ((x1835 j1832)) (let ((e1836 (if (syntax-object?1197 x1835) (syntax-object-expression1198 x1835) x1835))) (if (annotation? e1836) (annotation-expression e1836) e1836)))) (eq? (id-var-name1235 i1831 (quote (()))) (id-var-name1235 j1832 (quote (()))))))) (id-var-name1235 (lambda (id1837 w1838) (letrec ((search-vector-rib1841 (lambda (sym1847 subst1848 marks1849 symnames1850 ribcage1851) (let ((n1852 (vector-length symnames1850))) (let f1853 ((i1854 0)) (cond ((fx=1182 i1854 n1852) (search1839 sym1847 (cdr subst1848) marks1849)) ((and (eq? (vector-ref symnames1850 i1854) sym1847) (same-marks?1234 marks1849 (vector-ref (ribcage-marks1223 ribcage1851) i1854))) (values (vector-ref (ribcage-labels1224 ribcage1851) i1854) marks1849)) (else (f1853 (fx+1180 i1854 1)))))))) (search-list-rib1840 (lambda (sym1855 subst1856 marks1857 symnames1858 ribcage1859) (let f1860 ((symnames1861 symnames1858) (i1862 0)) (cond ((null? symnames1861) (search1839 sym1855 (cdr subst1856) marks1857)) ((and (eq? (car symnames1861) sym1855) (same-marks?1234 marks1857 (list-ref (ribcage-marks1223 ribcage1859) i1862))) (values (list-ref (ribcage-labels1224 ribcage1859) i1862) marks1857)) (else (f1860 (cdr symnames1861) (fx+1180 i1862 1))))))) (search1839 (lambda (sym1863 subst1864 marks1865) (if (null? subst1864) (values #f marks1865) (let ((fst1866 (car subst1864))) (if (eq? fst1866 (quote shift)) (search1839 sym1863 (cdr subst1864) (cdr marks1865)) (let ((symnames1867 (ribcage-symnames1222 fst1866))) (if (vector? symnames1867) (search-vector-rib1841 sym1863 subst1864 marks1865 symnames1867 fst1866) (search-list-rib1840 sym1863 subst1864 marks1865 symnames1867 fst1866))))))))) (cond ((symbol? id1837) (or (call-with-values (lambda () (search1839 id1837 (wrap-subst1217 w1838) (wrap-marks1216 w1838))) (lambda (x1869 . ignore1868) x1869)) id1837)) ((syntax-object?1197 id1837) (let ((id1870 (let ((e1872 (syntax-object-expression1198 id1837))) (if (annotation? e1872) (annotation-expression e1872) e1872))) (w11871 (syntax-object-wrap1199 id1837))) (let ((marks1873 (join-marks1233 (wrap-marks1216 w1838) (wrap-marks1216 w11871)))) (call-with-values (lambda () (search1839 id1870 (wrap-subst1217 w1838) marks1873)) (lambda (new-id1874 marks1875) (or new-id1874 (call-with-values (lambda () (search1839 id1870 (wrap-subst1217 w11871) marks1875)) (lambda (x1877 . ignore1876) x1877)) id1870)))))) ((annotation? id1837) (let ((id1878 (let ((e1879 id1837)) (if (annotation? e1879) (annotation-expression e1879) e1879)))) (or (call-with-values (lambda () (search1839 id1878 (wrap-subst1217 w1838) (wrap-marks1216 w1838))) (lambda (x1881 . ignore1880) x1881)) id1878))) (else (error-hook1186 (quote id-var-name) "invalid id" id1837)))))) (same-marks?1234 (lambda (x1882 y1883) (or (eq? x1882 y1883) (and (not (null? x1882)) (not (null? y1883)) (eq? (car x1882) (car y1883)) (same-marks?1234 (cdr x1882) (cdr y1883)))))) (join-marks1233 (lambda (m11884 m21885) (smart-append1231 m11884 m21885))) (join-wraps1232 (lambda (w11886 w21887) (let ((m11888 (wrap-marks1216 w11886)) (s11889 (wrap-subst1217 w11886))) (if (null? m11888) (if (null? s11889) w21887 (make-wrap1215 (wrap-marks1216 w21887) (smart-append1231 s11889 (wrap-subst1217 w21887)))) (make-wrap1215 (smart-append1231 m11888 (wrap-marks1216 w21887)) (smart-append1231 s11889 (wrap-subst1217 w21887))))))) (smart-append1231 (lambda (m11890 m21891) (if (null? m21891) m11890 (append m11890 m21891)))) (make-binding-wrap1230 (lambda (ids1892 labels1893 w1894) (if (null? ids1892) w1894 (make-wrap1215 (wrap-marks1216 w1894) (cons (let ((labelvec1895 (list->vector labels1893))) (let ((n1896 (vector-length labelvec1895))) (let ((symnamevec1897 (make-vector n1896)) (marksvec1898 (make-vector n1896))) (begin (let f1899 ((ids1900 ids1892) (i1901 0)) (if (not (null? ids1900)) (call-with-values (lambda () (id-sym-name&marks1214 (car ids1900) w1894)) (lambda (symname1902 marks1903) (begin (vector-set! symnamevec1897 i1901 symname1902) (vector-set! marksvec1898 i1901 marks1903) (f1899 (cdr ids1900) (fx+1180 i1901 1))))))) (make-ribcage1220 symnamevec1897 marksvec1898 labelvec1895))))) (wrap-subst1217 w1894)))))) (extend-ribcage!1229 (lambda (ribcage1904 id1905 label1906) (begin (set-ribcage-symnames!1225 ribcage1904 (cons (let ((e1907 (syntax-object-expression1198 id1905))) (if (annotation? e1907) (annotation-expression e1907) e1907)) (ribcage-symnames1222 ribcage1904))) (set-ribcage-marks!1226 ribcage1904 (cons (wrap-marks1216 (syntax-object-wrap1199 id1905)) (ribcage-marks1223 ribcage1904))) (set-ribcage-labels!1227 ribcage1904 (cons label1906 (ribcage-labels1224 ribcage1904)))))) (anti-mark1228 (lambda (w1908) (make-wrap1215 (cons #f (wrap-marks1216 w1908)) (cons (quote shift) (wrap-subst1217 w1908))))) (set-ribcage-labels!1227 (lambda (x1909 update1910) (vector-set! x1909 3 update1910))) (set-ribcage-marks!1226 (lambda (x1911 update1912) (vector-set! x1911 2 update1912))) (set-ribcage-symnames!1225 (lambda (x1913 update1914) (vector-set! x1913 1 update1914))) (ribcage-labels1224 (lambda (x1915) (vector-ref x1915 3))) (ribcage-marks1223 (lambda (x1916) (vector-ref x1916 2))) (ribcage-symnames1222 (lambda (x1917) (vector-ref x1917 1))) (ribcage?1221 (lambda (x1918) (and (vector? x1918) (= (vector-length x1918) 4) (eq? (vector-ref x1918 0) (quote ribcage))))) (make-ribcage1220 (lambda (symnames1919 marks1920 labels1921) (vector (quote ribcage) symnames1919 marks1920 labels1921))) (gen-labels1219 (lambda (ls1922) (if (null? ls1922) (quote ()) (cons (gen-label1218) (gen-labels1219 (cdr ls1922)))))) (gen-label1218 (lambda () (string #\i))) (wrap-subst1217 cdr) (wrap-marks1216 car) (make-wrap1215 cons) (id-sym-name&marks1214 (lambda (x1923 w1924) (if (syntax-object?1197 x1923) (values (let ((e1925 (syntax-object-expression1198 x1923))) (if (annotation? e1925) (annotation-expression e1925) e1925)) (join-marks1233 (wrap-marks1216 w1924) (wrap-marks1216 (syntax-object-wrap1199 x1923)))) (values (let ((e1926 x1923)) (if (annotation? e1926) (annotation-expression e1926) e1926)) (wrap-marks1216 w1924))))) (id?1213 (lambda (x1927) (cond ((symbol? x1927) #t) ((syntax-object?1197 x1927) (symbol? (let ((e1928 (syntax-object-expression1198 x1927))) (if (annotation? e1928) (annotation-expression e1928) e1928)))) ((annotation? x1927) (symbol? (annotation-expression x1927))) (else #f)))) (nonsymbol-id?1212 (lambda (x1929) (and (syntax-object?1197 x1929) (symbol? (let ((e1930 (syntax-object-expression1198 x1929))) (if (annotation? e1930) (annotation-expression e1930) e1930)))))) (global-extend1211 (lambda (type1931 sym1932 val1933) (put-global-definition-hook1187 sym1932 type1931 val1933))) (lookup1210 (lambda (x1934 r1935 mod1936) (cond ((assq x1934 r1935) => cdr) ((symbol? x1934) (or (get-global-definition-hook1189 x1934 mod1936) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1209 (lambda (r1937) (if (null? r1937) (quote ()) (let ((a1938 (car r1937))) (if (eq? (cadr a1938) (quote macro)) (cons a1938 (macros-only-env1209 (cdr r1937))) (macros-only-env1209 (cdr r1937))))))) (extend-var-env1208 (lambda (labels1939 vars1940 r1941) (if (null? labels1939) r1941 (extend-var-env1208 (cdr labels1939) (cdr vars1940) (cons (cons (car labels1939) (cons (quote lexical) (car vars1940))) r1941))))) (extend-env1207 (lambda (labels1942 bindings1943 r1944) (if (null? labels1942) r1944 (extend-env1207 (cdr labels1942) (cdr bindings1943) (cons (cons (car labels1942) (car bindings1943)) r1944))))) (binding-value1206 cdr) (binding-type1205 car) (source-annotation1204 (lambda (x1945) (cond ((annotation? x1945) (annotation-source x1945)) ((syntax-object?1197 x1945) (source-annotation1204 (syntax-object-expression1198 x1945))) (else #f)))) (set-syntax-object-module!1203 (lambda (x1946 update1947) (vector-set! x1946 3 update1947))) (set-syntax-object-wrap!1202 (lambda (x1948 update1949) (vector-set! x1948 2 update1949))) (set-syntax-object-expression!1201 (lambda (x1950 update1951) (vector-set! x1950 1 update1951))) (syntax-object-module1200 (lambda (x1952) (vector-ref x1952 3))) (syntax-object-wrap1199 (lambda (x1953) (vector-ref x1953 2))) (syntax-object-expression1198 (lambda (x1954) (vector-ref x1954 1))) (syntax-object?1197 (lambda (x1955) (and (vector? x1955) (= (vector-length x1955) 4) (eq? (vector-ref x1955 0) (quote syntax-object))))) (make-syntax-object1196 (lambda (expression1956 wrap1957 module1958) (vector (quote syntax-object) expression1956 wrap1957 module1958))) (build-letrec1195 (lambda (src1959 vars1960 val-exps1961 body-exp1962) (if (null? vars1960) (build-annotated1190 src1959 body-exp1962) (build-annotated1190 src1959 (list (quote letrec) (map list vars1960 val-exps1961) body-exp1962))))) (build-named-let1194 (lambda (src1963 vars1964 val-exps1965 body-exp1966) (if (null? vars1964) (build-annotated1190 src1963 body-exp1966) (build-annotated1190 src1963 (list (quote let) (car vars1964) (map list (cdr vars1964) val-exps1965) body-exp1966))))) (build-let1193 (lambda (src1967 vars1968 val-exps1969 body-exp1970) (if (null? vars1968) (build-annotated1190 src1967 body-exp1970) (build-annotated1190 src1967 (list (quote let) (map list vars1968 val-exps1969) body-exp1970))))) (build-sequence1192 (lambda (src1971 exps1972) (if (null? (cdr exps1972)) (build-annotated1190 src1971 (car exps1972)) (build-annotated1190 src1971 (cons (quote begin) exps1972))))) (build-data1191 (lambda (src1973 exp1974) (if (and (self-evaluating? exp1974) (not (vector? exp1974))) (build-annotated1190 src1973 exp1974) (build-annotated1190 src1973 (list (quote quote) exp1974))))) (build-annotated1190 (lambda (src1975 exp1976) (if (and src1975 (not (annotation? exp1976))) (make-annotation exp1976 src1975 #t) exp1976))) (get-global-definition-hook1189 (lambda (symbol1977 module1978) (begin (if (and (not module1978) (current-module)) (warn "module system is booted, we should have a module" symbol1977)) (module-lookup-keyword (if module1978 (resolve-module (cdr module1978)) (current-module)) symbol1977)))) (remove-global-definition-hook1188 (lambda (symbol1979) (module-undefine-keyword! (current-module) symbol1979))) (put-global-definition-hook1187 (lambda (symbol1980 type1981 val1982) (module-define-keyword! (current-module) symbol1980 type1981 val1982))) (error-hook1186 (lambda (who1983 why1984 what1985) (error who1983 "~a ~s" why1984 what1985))) (local-eval-hook1185 (lambda (x1986 mod1987) (primitive-eval (list noexpand1179 x1986)))) (top-level-eval-hook1184 (lambda (x1988 mod1989) (primitive-eval (list noexpand1179 x1988)))) (fx<1183 <) (fx=1182 =) (fx-1181 -) (fx+1180 +) (noexpand1179 "noexpand")) (begin (global-extend1211 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1211 (quote local-syntax) (quote let-syntax) #f) (global-extend1211 (quote core) (quote fluid-let-syntax) (lambda (e1990 r1991 w1992 s1993 mod1994) ((lambda (tmp1995) ((lambda (tmp1996) (if (if tmp1996 (apply (lambda (_1997 var1998 val1999 e12000 e22001) (valid-bound-ids?1238 var1998)) tmp1996) #f) (apply (lambda (_2003 var2004 val2005 e12006 e22007) (let ((names2008 (map (lambda (x2009) (id-var-name1235 x2009 w1992)) var2004))) (begin (for-each (lambda (id2011 n2012) (let ((t2013 (binding-type1205 (lookup1210 n2012 r1991 mod1994)))) (if (memv t2013 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1990 (source-wrap1242 id2011 w1992 s1993 mod1994))))) var2004 names2008) (chi-body1253 (cons e12006 e22007) (source-wrap1242 e1990 w1992 s1993 mod1994) (extend-env1207 names2008 (let ((trans-r2016 (macros-only-env1209 r1991))) (map (lambda (x2017) (cons (quote macro) (eval-local-transformer1256 (chi1249 x2017 trans-r2016 w1992 mod1994) mod1994))) val2005)) r1991) w1992 mod1994)))) tmp1996) ((lambda (_2019) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1242 e1990 w1992 s1993 mod1994))) tmp1995))) (syntax-dispatch tmp1995 (quote (any #(each (any any)) any . each-any))))) e1990))) (global-extend1211 (quote core) (quote quote) (lambda (e2020 r2021 w2022 s2023 mod2024) ((lambda (tmp2025) ((lambda (tmp2026) (if tmp2026 (apply (lambda (_2027 e2028) (build-data1191 s2023 (strip1260 e2028 w2022))) tmp2026) ((lambda (_2029) (syntax-violation (quote quote) "bad syntax" (source-wrap1242 e2020 w2022 s2023 mod2024))) tmp2025))) (syntax-dispatch tmp2025 (quote (any any))))) e2020))) (global-extend1211 (quote core) (quote syntax) (letrec ((regen2037 (lambda (x2038) (let ((t2039 (car x2038))) (if (memv t2039 (quote (ref))) (build-annotated1190 #f (cadr x2038)) (if (memv t2039 (quote (primitive))) (build-annotated1190 #f (cadr x2038)) (if (memv t2039 (quote (quote))) (build-data1191 #f (cadr x2038)) (if (memv t2039 (quote (lambda))) (build-annotated1190 #f (list (quote lambda) (cadr x2038) (regen2037 (caddr x2038)))) (if (memv t2039 (quote (map))) (let ((ls2040 (map regen2037 (cdr x2038)))) (build-annotated1190 #f (cons (if (fx=1182 (length ls2040) 2) (build-annotated1190 #f (quote map)) (build-annotated1190 #f (quote map))) ls2040))) (build-annotated1190 #f (cons (build-annotated1190 #f (car x2038)) (map regen2037 (cdr x2038)))))))))))) (gen-vector2036 (lambda (x2041) (cond ((eq? (car x2041) (quote list)) (cons (quote vector) (cdr x2041))) ((eq? (car x2041) (quote quote)) (list (quote quote) (list->vector (cadr x2041)))) (else (list (quote list->vector) x2041))))) (gen-append2035 (lambda (x2042 y2043) (if (equal? y2043 (quote (quote ()))) x2042 (list (quote append) x2042 y2043)))) (gen-cons2034 (lambda (x2044 y2045) (let ((t2046 (car y2045))) (if (memv t2046 (quote (quote))) (if (eq? (car x2044) (quote quote)) (list (quote quote) (cons (cadr x2044) (cadr y2045))) (if (eq? (cadr y2045) (quote ())) (list (quote list) x2044) (list (quote cons) x2044 y2045))) (if (memv t2046 (quote (list))) (cons (quote list) (cons x2044 (cdr y2045))) (list (quote cons) x2044 y2045)))))) (gen-map2033 (lambda (e2047 map-env2048) (let ((formals2049 (map cdr map-env2048)) (actuals2050 (map (lambda (x2051) (list (quote ref) (car x2051))) map-env2048))) (cond ((eq? (car e2047) (quote ref)) (car actuals2050)) ((andmap (lambda (x2052) (and (eq? (car x2052) (quote ref)) (memq (cadr x2052) formals2049))) (cdr e2047)) (cons (quote map) (cons (list (quote primitive) (car e2047)) (map (let ((r2053 (map cons formals2049 actuals2050))) (lambda (x2054) (cdr (assq (cadr x2054) r2053)))) (cdr e2047))))) (else (cons (quote map) (cons (list (quote lambda) formals2049 e2047) actuals2050))))))) (gen-mappend2032 (lambda (e2055 map-env2056) (list (quote apply) (quote (primitive append)) (gen-map2033 e2055 map-env2056)))) (gen-ref2031 (lambda (src2057 var2058 level2059 maps2060) (if (fx=1182 level2059 0) (values var2058 maps2060) (if (null? maps2060) (syntax-violation (quote syntax) "missing ellipsis" src2057) (call-with-values (lambda () (gen-ref2031 src2057 var2058 (fx-1181 level2059 1) (cdr maps2060))) (lambda (outer-var2061 outer-maps2062) (let ((b2063 (assq outer-var2061 (car maps2060)))) (if b2063 (values (cdr b2063) maps2060) (let ((inner-var2064 (gen-var1261 (quote tmp)))) (values inner-var2064 (cons (cons (cons outer-var2061 inner-var2064) (car maps2060)) outer-maps2062))))))))))) (gen-syntax2030 (lambda (src2065 e2066 r2067 maps2068 ellipsis?2069 mod2070) (if (id?1213 e2066) (let ((label2071 (id-var-name1235 e2066 (quote (()))))) (let ((b2072 (lookup1210 label2071 r2067 mod2070))) (if (eq? (binding-type1205 b2072) (quote syntax)) (call-with-values (lambda () (let ((var.lev2073 (binding-value1206 b2072))) (gen-ref2031 src2065 (car var.lev2073) (cdr var.lev2073) maps2068))) (lambda (var2074 maps2075) (values (list (quote ref) var2074) maps2075))) (if (ellipsis?2069 e2066) (syntax-violation (quote syntax) "misplaced ellipsis" src2065) (values (list (quote quote) e2066) maps2068))))) ((lambda (tmp2076) ((lambda (tmp2077) (if (if tmp2077 (apply (lambda (dots2078 e2079) (ellipsis?2069 dots2078)) tmp2077) #f) (apply (lambda (dots2080 e2081) (gen-syntax2030 src2065 e2081 r2067 maps2068 (lambda (x2082) #f) mod2070)) tmp2077) ((lambda (tmp2083) (if (if tmp2083 (apply (lambda (x2084 dots2085 y2086) (ellipsis?2069 dots2085)) tmp2083) #f) (apply (lambda (x2087 dots2088 y2089) (let f2090 ((y2091 y2089) (k2092 (lambda (maps2093) (call-with-values (lambda () (gen-syntax2030 src2065 x2087 r2067 (cons (quote ()) maps2093) ellipsis?2069 mod2070)) (lambda (x2094 maps2095) (if (null? (car maps2095)) (syntax-violation (quote syntax) "extra ellipsis" src2065) (values (gen-map2033 x2094 (car maps2095)) (cdr maps2095)))))))) ((lambda (tmp2096) ((lambda (tmp2097) (if (if tmp2097 (apply (lambda (dots2098 y2099) (ellipsis?2069 dots2098)) tmp2097) #f) (apply (lambda (dots2100 y2101) (f2090 y2101 (lambda (maps2102) (call-with-values (lambda () (k2092 (cons (quote ()) maps2102))) (lambda (x2103 maps2104) (if (null? (car maps2104)) (syntax-violation (quote syntax) "extra ellipsis" src2065) (values (gen-mappend2032 x2103 (car maps2104)) (cdr maps2104)))))))) tmp2097) ((lambda (_2105) (call-with-values (lambda () (gen-syntax2030 src2065 y2091 r2067 maps2068 ellipsis?2069 mod2070)) (lambda (y2106 maps2107) (call-with-values (lambda () (k2092 maps2107)) (lambda (x2108 maps2109) (values (gen-append2035 x2108 y2106) maps2109)))))) tmp2096))) (syntax-dispatch tmp2096 (quote (any . any))))) y2091))) tmp2083) ((lambda (tmp2110) (if tmp2110 (apply (lambda (x2111 y2112) (call-with-values (lambda () (gen-syntax2030 src2065 x2111 r2067 maps2068 ellipsis?2069 mod2070)) (lambda (x2113 maps2114) (call-with-values (lambda () (gen-syntax2030 src2065 y2112 r2067 maps2114 ellipsis?2069 mod2070)) (lambda (y2115 maps2116) (values (gen-cons2034 x2113 y2115) maps2116)))))) tmp2110) ((lambda (tmp2117) (if tmp2117 (apply (lambda (e12118 e22119) (call-with-values (lambda () (gen-syntax2030 src2065 (cons e12118 e22119) r2067 maps2068 ellipsis?2069 mod2070)) (lambda (e2121 maps2122) (values (gen-vector2036 e2121) maps2122)))) tmp2117) ((lambda (_2123) (values (list (quote quote) e2066) maps2068)) tmp2076))) (syntax-dispatch tmp2076 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp2076 (quote (any . any)))))) (syntax-dispatch tmp2076 (quote (any any . any)))))) (syntax-dispatch tmp2076 (quote (any any))))) e2066))))) (lambda (e2124 r2125 w2126 s2127 mod2128) (let ((e2129 (source-wrap1242 e2124 w2126 s2127 mod2128))) ((lambda (tmp2130) ((lambda (tmp2131) (if tmp2131 (apply (lambda (_2132 x2133) (call-with-values (lambda () (gen-syntax2030 e2129 x2133 r2125 (quote ()) ellipsis?1258 mod2128)) (lambda (e2134 maps2135) (regen2037 e2134)))) tmp2131) ((lambda (_2136) (syntax-violation (quote syntax) "bad `syntax' form" e2129)) tmp2130))) (syntax-dispatch tmp2130 (quote (any any))))) e2129))))) (global-extend1211 (quote core) (quote lambda) (lambda (e2137 r2138 w2139 s2140 mod2141) ((lambda (tmp2142) ((lambda (tmp2143) (if tmp2143 (apply (lambda (_2144 c2145) (chi-lambda-clause1254 (source-wrap1242 e2137 w2139 s2140 mod2141) #f c2145 r2138 w2139 mod2141 (lambda (vars2146 docstring2147 body2148) (build-annotated1190 s2140 (cons (quote lambda) (cons vars2146 (append (if docstring2147 (list docstring2147) (quote ())) (list body2148)))))))) tmp2143) (syntax-violation #f "source expression failed to match any pattern" tmp2142))) (syntax-dispatch tmp2142 (quote (any . any))))) e2137))) (global-extend1211 (quote core) (quote let) (letrec ((chi-let2149 (lambda (e2150 r2151 w2152 s2153 mod2154 constructor2155 ids2156 vals2157 exps2158) (if (not (valid-bound-ids?1238 ids2156)) (syntax-violation (quote let) "duplicate bound variable" e2150) (let ((labels2159 (gen-labels1219 ids2156)) (new-vars2160 (map gen-var1261 ids2156))) (let ((nw2161 (make-binding-wrap1230 ids2156 labels2159 w2152)) (nr2162 (extend-var-env1208 labels2159 new-vars2160 r2151))) (constructor2155 s2153 new-vars2160 (map (lambda (x2163) (chi1249 x2163 r2151 w2152 mod2154)) vals2157) (chi-body1253 exps2158 (source-wrap1242 e2150 nw2161 s2153 mod2154) nr2162 nw2161 mod2154)))))))) (lambda (e2164 r2165 w2166 s2167 mod2168) ((lambda (tmp2169) ((lambda (tmp2170) (if tmp2170 (apply (lambda (_2171 id2172 val2173 e12174 e22175) (chi-let2149 e2164 r2165 w2166 s2167 mod2168 build-let1193 id2172 val2173 (cons e12174 e22175))) tmp2170) ((lambda (tmp2179) (if (if tmp2179 (apply (lambda (_2180 f2181 id2182 val2183 e12184 e22185) (id?1213 f2181)) tmp2179) #f) (apply (lambda (_2186 f2187 id2188 val2189 e12190 e22191) (chi-let2149 e2164 r2165 w2166 s2167 mod2168 build-named-let1194 (cons f2187 id2188) val2189 (cons e12190 e22191))) tmp2179) ((lambda (_2195) (syntax-violation (quote let) "bad let" (source-wrap1242 e2164 w2166 s2167 mod2168))) tmp2169))) (syntax-dispatch tmp2169 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2169 (quote (any #(each (any any)) any . each-any))))) e2164)))) (global-extend1211 (quote core) (quote letrec) (lambda (e2196 r2197 w2198 s2199 mod2200) ((lambda (tmp2201) ((lambda (tmp2202) (if tmp2202 (apply (lambda (_2203 id2204 val2205 e12206 e22207) (let ((ids2208 id2204)) (if (not (valid-bound-ids?1238 ids2208)) (syntax-violation (quote letrec) "duplicate bound variable" e2196) (let ((labels2210 (gen-labels1219 ids2208)) (new-vars2211 (map gen-var1261 ids2208))) (let ((w2212 (make-binding-wrap1230 ids2208 labels2210 w2198)) (r2213 (extend-var-env1208 labels2210 new-vars2211 r2197))) (build-letrec1195 s2199 new-vars2211 (map (lambda (x2214) (chi1249 x2214 r2213 w2212 mod2200)) val2205) (chi-body1253 (cons e12206 e22207) (source-wrap1242 e2196 w2212 s2199 mod2200) r2213 w2212 mod2200))))))) tmp2202) ((lambda (_2217) (syntax-violation (quote letrec) "bad letrec" (source-wrap1242 e2196 w2198 s2199 mod2200))) tmp2201))) (syntax-dispatch tmp2201 (quote (any #(each (any any)) any . each-any))))) e2196))) (global-extend1211 (quote core) (quote set!) (lambda (e2218 r2219 w2220 s2221 mod2222) ((lambda (tmp2223) ((lambda (tmp2224) (if (if tmp2224 (apply (lambda (_2225 id2226 val2227) (id?1213 id2226)) tmp2224) #f) (apply (lambda (_2228 id2229 val2230) (let ((val2231 (chi1249 val2230 r2219 w2220 mod2222)) (n2232 (id-var-name1235 id2229 w2220))) (let ((b2233 (lookup1210 n2232 r2219 mod2222))) (let ((t2234 (binding-type1205 b2233))) (if (memv t2234 (quote (lexical))) (build-annotated1190 s2221 (list (quote set!) (binding-value1206 b2233) val2231)) (if (memv t2234 (quote (global))) (build-annotated1190 s2221 (list (quote set!) (if mod2222 (make-module-ref (cdr mod2222) n2232 (car mod2222)) (make-module-ref mod2222 n2232 (quote bare))) val2231)) (if (memv t2234 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1241 id2229 w2220 mod2222)) (syntax-violation (quote set!) "bad set!" (source-wrap1242 e2218 w2220 s2221 mod2222))))))))) tmp2224) ((lambda (tmp2235) (if tmp2235 (apply (lambda (_2236 head2237 tail2238 val2239) (call-with-values (lambda () (syntax-type1247 head2237 r2219 (quote (())) #f #f mod2222)) (lambda (type2240 value2241 ee2242 ww2243 ss2244 modmod2245) (let ((t2246 type2240)) (if (memv t2246 (quote (module-ref))) (let ((val2247 (chi1249 val2239 r2219 w2220 mod2222))) (call-with-values (lambda () (value2241 (cons head2237 tail2238))) (lambda (id2249 mod2250) (build-annotated1190 s2221 (list (quote set!) (if mod2250 (make-module-ref (cdr mod2250) id2249 (car mod2250)) (make-module-ref mod2250 id2249 (quote bare))) val2247))))) (build-annotated1190 s2221 (cons (chi1249 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2237) r2219 w2220 mod2222) (map (lambda (e2251) (chi1249 e2251 r2219 w2220 mod2222)) (append tail2238 (list val2239)))))))))) tmp2235) ((lambda (_2253) (syntax-violation (quote set!) "bad set!" (source-wrap1242 e2218 w2220 s2221 mod2222))) tmp2223))) (syntax-dispatch tmp2223 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2223 (quote (any any any))))) e2218))) (global-extend1211 (quote module-ref) (quote @) (lambda (e2254) ((lambda (tmp2255) ((lambda (tmp2256) (if (if tmp2256 (apply (lambda (_2257 mod2258 id2259) (and (andmap id?1213 mod2258) (id?1213 id2259))) tmp2256) #f) (apply (lambda (_2261 mod2262 id2263) (values (syntax-object->datum id2263) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2262)))) tmp2256) (syntax-violation #f "source expression failed to match any pattern" tmp2255))) (syntax-dispatch tmp2255 (quote (any each-any any))))) e2254))) (global-extend1211 (quote module-ref) (quote @@) (lambda (e2265) ((lambda (tmp2266) ((lambda (tmp2267) (if (if tmp2267 (apply (lambda (_2268 mod2269 id2270) (and (andmap id?1213 mod2269) (id?1213 id2270))) tmp2267) #f) (apply (lambda (_2272 mod2273 id2274) (values (syntax-object->datum id2274) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2273)))) tmp2267) (syntax-violation #f "source expression failed to match any pattern" tmp2266))) (syntax-dispatch tmp2266 (quote (any each-any any))))) e2265))) (global-extend1211 (quote begin) (quote begin) (quote ())) (global-extend1211 (quote define) (quote define) (quote ())) (global-extend1211 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1211 (quote eval-when) (quote eval-when) (quote ())) (global-extend1211 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2279 (lambda (x2280 keys2281 clauses2282 r2283 mod2284) (if (null? clauses2282) (build-annotated1190 #f (list (build-annotated1190 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2280)) ((lambda (tmp2285) ((lambda (tmp2286) (if tmp2286 (apply (lambda (pat2287 exp2288) (if (and (id?1213 pat2287) (andmap (lambda (x2289) (not (free-id=?1236 pat2287 x2289))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2281))) (let ((labels2290 (list (gen-label1218))) (var2291 (gen-var1261 pat2287))) (build-annotated1190 #f (list (build-annotated1190 #f (list (quote lambda) (list var2291) (chi1249 exp2288 (extend-env1207 labels2290 (list (cons (quote syntax) (cons var2291 0))) r2283) (make-binding-wrap1230 (list pat2287) labels2290 (quote (()))) mod2284))) x2280))) (gen-clause2278 x2280 keys2281 (cdr clauses2282) r2283 pat2287 #t exp2288 mod2284))) tmp2286) ((lambda (tmp2292) (if tmp2292 (apply (lambda (pat2293 fender2294 exp2295) (gen-clause2278 x2280 keys2281 (cdr clauses2282) r2283 pat2293 fender2294 exp2295 mod2284)) tmp2292) ((lambda (_2296) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2282))) tmp2285))) (syntax-dispatch tmp2285 (quote (any any any)))))) (syntax-dispatch tmp2285 (quote (any any))))) (car clauses2282))))) (gen-clause2278 (lambda (x2297 keys2298 clauses2299 r2300 pat2301 fender2302 exp2303 mod2304) (call-with-values (lambda () (convert-pattern2276 pat2301 keys2298)) (lambda (p2305 pvars2306) (cond ((not (distinct-bound-ids?1239 (map car pvars2306))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2301)) ((not (andmap (lambda (x2307) (not (ellipsis?1258 (car x2307)))) pvars2306)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2301)) (else (let ((y2308 (gen-var1261 (quote tmp)))) (build-annotated1190 #f (list (build-annotated1190 #f (list (quote lambda) (list y2308) (let ((y2309 (build-annotated1190 #f y2308))) (build-annotated1190 #f (list (quote if) ((lambda (tmp2310) ((lambda (tmp2311) (if tmp2311 (apply (lambda () y2309) tmp2311) ((lambda (_2312) (build-annotated1190 #f (list (quote if) y2309 (build-dispatch-call2277 pvars2306 fender2302 y2309 r2300 mod2304) (build-data1191 #f #f)))) tmp2310))) (syntax-dispatch tmp2310 (quote #(atom #t))))) fender2302) (build-dispatch-call2277 pvars2306 exp2303 y2309 r2300 mod2304) (gen-syntax-case2279 x2297 keys2298 clauses2299 r2300 mod2304)))))) (if (eq? p2305 (quote any)) (build-annotated1190 #f (list (build-annotated1190 #f (quote list)) x2297)) (build-annotated1190 #f (list (build-annotated1190 #f (quote syntax-dispatch)) x2297 (build-data1191 #f p2305))))))))))))) (build-dispatch-call2277 (lambda (pvars2313 exp2314 y2315 r2316 mod2317) (let ((ids2318 (map car pvars2313)) (levels2319 (map cdr pvars2313))) (let ((labels2320 (gen-labels1219 ids2318)) (new-vars2321 (map gen-var1261 ids2318))) (build-annotated1190 #f (list (build-annotated1190 #f (quote apply)) (build-annotated1190 #f (list (quote lambda) new-vars2321 (chi1249 exp2314 (extend-env1207 labels2320 (map (lambda (var2322 level2323) (cons (quote syntax) (cons var2322 level2323))) new-vars2321 (map cdr pvars2313)) r2316) (make-binding-wrap1230 ids2318 labels2320 (quote (()))) mod2317))) y2315)))))) (convert-pattern2276 (lambda (pattern2324 keys2325) (let cvt2326 ((p2327 pattern2324) (n2328 0) (ids2329 (quote ()))) (if (id?1213 p2327) (if (bound-id-member?1240 p2327 keys2325) (values (vector (quote free-id) p2327) ids2329) (values (quote any) (cons (cons p2327 n2328) ids2329))) ((lambda (tmp2330) ((lambda (tmp2331) (if (if tmp2331 (apply (lambda (x2332 dots2333) (ellipsis?1258 dots2333)) tmp2331) #f) (apply (lambda (x2334 dots2335) (call-with-values (lambda () (cvt2326 x2334 (fx+1180 n2328 1) ids2329)) (lambda (p2336 ids2337) (values (if (eq? p2336 (quote any)) (quote each-any) (vector (quote each) p2336)) ids2337)))) tmp2331) ((lambda (tmp2338) (if tmp2338 (apply (lambda (x2339 y2340) (call-with-values (lambda () (cvt2326 y2340 n2328 ids2329)) (lambda (y2341 ids2342) (call-with-values (lambda () (cvt2326 x2339 n2328 ids2342)) (lambda (x2343 ids2344) (values (cons x2343 y2341) ids2344)))))) tmp2338) ((lambda (tmp2345) (if tmp2345 (apply (lambda () (values (quote ()) ids2329)) tmp2345) ((lambda (tmp2346) (if tmp2346 (apply (lambda (x2347) (call-with-values (lambda () (cvt2326 x2347 n2328 ids2329)) (lambda (p2349 ids2350) (values (vector (quote vector) p2349) ids2350)))) tmp2346) ((lambda (x2351) (values (vector (quote atom) (strip1260 p2327 (quote (())))) ids2329)) tmp2330))) (syntax-dispatch tmp2330 (quote #(vector each-any)))))) (syntax-dispatch tmp2330 (quote ()))))) (syntax-dispatch tmp2330 (quote (any . any)))))) (syntax-dispatch tmp2330 (quote (any any))))) p2327)))))) (lambda (e2352 r2353 w2354 s2355 mod2356) (let ((e2357 (source-wrap1242 e2352 w2354 s2355 mod2356))) ((lambda (tmp2358) ((lambda (tmp2359) (if tmp2359 (apply (lambda (_2360 val2361 key2362 m2363) (if (andmap (lambda (x2364) (and (id?1213 x2364) (not (ellipsis?1258 x2364)))) key2362) (let ((x2366 (gen-var1261 (quote tmp)))) (build-annotated1190 s2355 (list (build-annotated1190 #f (list (quote lambda) (list x2366) (gen-syntax-case2279 (build-annotated1190 #f x2366) key2362 m2363 r2353 mod2356))) (chi1249 val2361 r2353 (quote (())) mod2356)))) (syntax-violation (quote syntax-case) "invalid literals list" e2357))) tmp2359) (syntax-violation #f "source expression failed to match any pattern" tmp2358))) (syntax-dispatch tmp2358 (quote (any any each-any . each-any))))) e2357))))) (set! sc-expand (let ((m2369 (quote e)) (esew2370 (quote (eval)))) (lambda (x2371) (if (and (pair? x2371) (equal? (car x2371) noexpand1179)) (cadr x2371) (chi-top1248 x2371 (quote ()) (quote ((top))) m2369 esew2370 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2372 (quote e)) (esew2373 (quote (eval)))) (lambda (x2375 . rest2374) (if (and (pair? x2375) (equal? (car x2375) noexpand1179)) (cadr x2375) (chi-top1248 x2375 (quote ()) (quote ((top))) (if (null? rest2374) m2372 (car rest2374)) (if (or (null? rest2374) (null? (cdr rest2374))) esew2373 (cadr rest2374)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2376) (nonsymbol-id?1212 x2376))) (set! datum->syntax-object (lambda (id2377 datum2378) (make-syntax-object1196 datum2378 (syntax-object-wrap1199 id2377) #f))) (set! syntax-object->datum (lambda (x2379) (strip1260 x2379 (quote (()))))) (set! generate-temporaries (lambda (ls2380) (begin (let ((x2381 ls2380)) (if (not (list? x2381)) (error-hook1186 (quote generate-temporaries) "invalid argument" x2381))) (map (lambda (x2382) (wrap1241 (gensym) (quote ((top))) #f)) ls2380)))) (set! free-identifier=? (lambda (x2383 y2384) (begin (let ((x2385 x2383)) (if (not (nonsymbol-id?1212 x2385)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2385))) (let ((x2386 y2384)) (if (not (nonsymbol-id?1212 x2386)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2386))) (free-id=?1236 x2383 y2384)))) (set! bound-identifier=? (lambda (x2387 y2388) (begin (let ((x2389 x2387)) (if (not (nonsymbol-id?1212 x2389)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2389))) (let ((x2390 y2388)) (if (not (nonsymbol-id?1212 x2390)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2390))) (bound-id=?1237 x2387 y2388)))) (set! syntax-violation (lambda (who2394 message2393 form2392 . subform2391) (begin (let ((x2395 who2394)) (if (not ((lambda (x2396) (or (not x2396) (string? x2396) (symbol? x2396))) x2395)) (error-hook1186 (quote syntax-violation) "invalid argument" x2395))) (let ((x2397 message2393)) (if (not (string? x2397)) (error-hook1186 (quote syntax-violation) "invalid argument" x2397))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2394 "~a: " "") "~a " (if (null? subform2391) "in ~a" "in subform `~s' of `~s'")) (let ((tail2398 (cons message2393 (map (lambda (x2399) (strip1260 x2399 (quote (())))) (append subform2391 (list form2392)))))) (if who2394 (cons who2394 tail2398) tail2398)) #f)))) (set! install-global-transformer (lambda (sym2400 v2401) (begin (let ((x2402 sym2400)) (if (not (symbol? x2402)) (error-hook1186 (quote define-syntax) "invalid argument" x2402))) (let ((x2403 v2401)) (if (not (procedure? x2403)) (error-hook1186 (quote define-syntax) "invalid argument" x2403))) (global-extend1211 (quote macro) sym2400 v2401)))) (letrec ((match2408 (lambda (e2409 p2410 w2411 r2412 mod2413) (cond ((not r2412) #f) ((eq? p2410 (quote any)) (cons (wrap1241 e2409 w2411 mod2413) r2412)) ((syntax-object?1197 e2409) (match*2407 (let ((e2414 (syntax-object-expression1198 e2409))) (if (annotation? e2414) (annotation-expression e2414) e2414)) p2410 (join-wraps1232 w2411 (syntax-object-wrap1199 e2409)) r2412 (syntax-object-module1200 e2409))) (else (match*2407 (let ((e2415 e2409)) (if (annotation? e2415) (annotation-expression e2415) e2415)) p2410 w2411 r2412 mod2413))))) (match*2407 (lambda (e2416 p2417 w2418 r2419 mod2420) (cond ((null? p2417) (and (null? e2416) r2419)) ((pair? p2417) (and (pair? e2416) (match2408 (car e2416) (car p2417) w2418 (match2408 (cdr e2416) (cdr p2417) w2418 r2419 mod2420) mod2420))) ((eq? p2417 (quote each-any)) (let ((l2421 (match-each-any2405 e2416 w2418 mod2420))) (and l2421 (cons l2421 r2419)))) (else (let ((t2422 (vector-ref p2417 0))) (if (memv t2422 (quote (each))) (if (null? e2416) (match-empty2406 (vector-ref p2417 1) r2419) (let ((l2423 (match-each2404 e2416 (vector-ref p2417 1) w2418 mod2420))) (and l2423 (let collect2424 ((l2425 l2423)) (if (null? (car l2425)) r2419 (cons (map car l2425) (collect2424 (map cdr l2425)))))))) (if (memv t2422 (quote (free-id))) (and (id?1213 e2416) (free-id=?1236 (wrap1241 e2416 w2418 mod2420) (vector-ref p2417 1)) r2419) (if (memv t2422 (quote (atom))) (and (equal? (vector-ref p2417 1) (strip1260 e2416 w2418)) r2419) (if (memv t2422 (quote (vector))) (and (vector? e2416) (match2408 (vector->list e2416) (vector-ref p2417 1) w2418 r2419 mod2420))))))))))) (match-empty2406 (lambda (p2426 r2427) (cond ((null? p2426) r2427) ((eq? p2426 (quote any)) (cons (quote ()) r2427)) ((pair? p2426) (match-empty2406 (car p2426) (match-empty2406 (cdr p2426) r2427))) ((eq? p2426 (quote each-any)) (cons (quote ()) r2427)) (else (let ((t2428 (vector-ref p2426 0))) (if (memv t2428 (quote (each))) (match-empty2406 (vector-ref p2426 1) r2427) (if (memv t2428 (quote (free-id atom))) r2427 (if (memv t2428 (quote (vector))) (match-empty2406 (vector-ref p2426 1) r2427))))))))) (match-each-any2405 (lambda (e2429 w2430 mod2431) (cond ((annotation? e2429) (match-each-any2405 (annotation-expression e2429) w2430 mod2431)) ((pair? e2429) (let ((l2432 (match-each-any2405 (cdr e2429) w2430 mod2431))) (and l2432 (cons (wrap1241 (car e2429) w2430 mod2431) l2432)))) ((null? e2429) (quote ())) ((syntax-object?1197 e2429) (match-each-any2405 (syntax-object-expression1198 e2429) (join-wraps1232 w2430 (syntax-object-wrap1199 e2429)) mod2431)) (else #f)))) (match-each2404 (lambda (e2433 p2434 w2435 mod2436) (cond ((annotation? e2433) (match-each2404 (annotation-expression e2433) p2434 w2435 mod2436)) ((pair? e2433) (let ((first2437 (match2408 (car e2433) p2434 w2435 (quote ()) mod2436))) (and first2437 (let ((rest2438 (match-each2404 (cdr e2433) p2434 w2435 mod2436))) (and rest2438 (cons first2437 rest2438)))))) ((null? e2433) (quote ())) ((syntax-object?1197 e2433) (match-each2404 (syntax-object-expression1198 e2433) p2434 (join-wraps1232 w2435 (syntax-object-wrap1199 e2433)) (syntax-object-module1200 e2433))) (else #f))))) (set! syntax-dispatch (lambda (e2439 p2440) (cond ((eq? p2440 (quote any)) (list e2439)) ((syntax-object?1197 e2439) (match*2407 (let ((e2441 (syntax-object-expression1198 e2439))) (if (annotation? e2441) (annotation-expression e2441) e2441)) p2440 (syntax-object-wrap1199 e2439) (quote ()) (syntax-object-module1200 e2439))) (else (match*2407 (let ((e2442 e2439)) (if (annotation? e2442) (annotation-expression e2442) e2442)) p2440 (quote (())) (quote ()) #f)))))))) +(install-global-transformer (quote with-syntax) (lambda (x2443) ((lambda (tmp2444) ((lambda (tmp2445) (if tmp2445 (apply (lambda (_2446 e12447 e22448) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12447 e22448))) tmp2445) ((lambda (tmp2450) (if tmp2450 (apply (lambda (_2451 out2452 in2453 e12454 e22455) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2453 (quote ()) (list out2452 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12454 e22455))))) tmp2450) ((lambda (tmp2457) (if tmp2457 (apply (lambda (_2458 out2459 in2460 e12461 e22462) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2460) (quote ()) (list out2459 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12461 e22462))))) tmp2457) (syntax-violation #f "source expression failed to match any pattern" tmp2444))) (syntax-dispatch tmp2444 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2444 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2444 (quote (any () any . each-any))))) x2443))) +(install-global-transformer (quote syntax-rules) (lambda (x2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda (_2469 k2470 keyword2471 pattern2472 template2473) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2470 (map (lambda (tmp2476 tmp2475) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2475) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2476))) template2473 pattern2472)))))) tmp2468) (syntax-violation #f "source expression failed to match any pattern" tmp2467))) (syntax-dispatch tmp2467 (quote (any each-any . #(each ((any . any) any))))))) x2466))) +(install-global-transformer (quote let*) (lambda (x2477) ((lambda (tmp2478) ((lambda (tmp2479) (if (if tmp2479 (apply (lambda (let*2480 x2481 v2482 e12483 e22484) (andmap identifier? x2481)) tmp2479) #f) (apply (lambda (let*2486 x2487 v2488 e12489 e22490) (let f2491 ((bindings2492 (map list x2487 v2488))) (if (null? bindings2492) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12489 e22490))) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (body2498 binding2499) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2499) body2498)) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) (syntax-dispatch tmp2496 (quote (any any))))) (list (f2491 (cdr bindings2492)) (car bindings2492)))))) tmp2479) (syntax-violation #f "source expression failed to match any pattern" tmp2478))) (syntax-dispatch tmp2478 (quote (any #(each (any any)) any . each-any))))) x2477))) +(install-global-transformer (quote do) (lambda (orig-x2500) ((lambda (tmp2501) ((lambda (tmp2502) (if tmp2502 (apply (lambda (_2503 var2504 init2505 step2506 e02507 e12508 c2509) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (step2512) ((lambda (tmp2513) ((lambda (tmp2514) (if tmp2514 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2514) ((lambda (tmp2519) (if tmp2519 (apply (lambda (e12520 e22521) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12520 e22521)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2519) (syntax-violation #f "source expression failed to match any pattern" tmp2513))) (syntax-dispatch tmp2513 (quote (any . each-any)))))) (syntax-dispatch tmp2513 (quote ())))) e12508)) tmp2511) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) (syntax-dispatch tmp2510 (quote each-any)))) (map (lambda (v2528 s2529) ((lambda (tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda () v2528) tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (e2533) e2533) tmp2532) ((lambda (_2534) (syntax-violation (quote do) "bad step expression" orig-x2500 s2529)) tmp2530))) (syntax-dispatch tmp2530 (quote (any)))))) (syntax-dispatch tmp2530 (quote ())))) s2529)) var2504 step2506))) tmp2502) (syntax-violation #f "source expression failed to match any pattern" tmp2501))) (syntax-dispatch tmp2501 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2500))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2537 (lambda (x2541 y2542) ((lambda (tmp2543) ((lambda (tmp2544) (if tmp2544 (apply (lambda (x2545 y2546) ((lambda (tmp2547) ((lambda (tmp2548) (if tmp2548 (apply (lambda (dy2549) ((lambda (tmp2550) ((lambda (tmp2551) (if tmp2551 (apply (lambda (dx2552) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2552 dy2549))) tmp2551) ((lambda (_2553) (if (null? dy2549) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546))) tmp2550))) (syntax-dispatch tmp2550 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2545)) tmp2548) ((lambda (tmp2554) (if tmp2554 (apply (lambda (stuff2555) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2545 stuff2555))) tmp2554) ((lambda (else2556) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546)) tmp2547))) (syntax-dispatch tmp2547 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2547 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2546)) tmp2544) (syntax-violation #f "source expression failed to match any pattern" tmp2543))) (syntax-dispatch tmp2543 (quote (any any))))) (list x2541 y2542)))) (quasiappend2538 (lambda (x2557 y2558) ((lambda (tmp2559) ((lambda (tmp2560) (if tmp2560 (apply (lambda (x2561 y2562) ((lambda (tmp2563) ((lambda (tmp2564) (if tmp2564 (apply (lambda () x2561) tmp2564) ((lambda (_2565) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2561 y2562)) tmp2563))) (syntax-dispatch tmp2563 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2562)) tmp2560) (syntax-violation #f "source expression failed to match any pattern" tmp2559))) (syntax-dispatch tmp2559 (quote (any any))))) (list x2557 y2558)))) (quasivector2539 (lambda (x2566) ((lambda (tmp2567) ((lambda (x2568) ((lambda (tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (x2571) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2571))) tmp2570) ((lambda (tmp2573) (if tmp2573 (apply (lambda (x2574) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2574)) tmp2573) ((lambda (_2576) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2568)) tmp2569))) (syntax-dispatch tmp2569 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2569 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2568)) tmp2567)) x2566))) (quasi2540 (lambda (p2577 lev2578) ((lambda (tmp2579) ((lambda (tmp2580) (if tmp2580 (apply (lambda (p2581) (if (= lev2578 0) p2581 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2581) (- lev2578 1))))) tmp2580) ((lambda (tmp2582) (if tmp2582 (apply (lambda (p2583 q2584) (if (= lev2578 0) (quasiappend2538 p2583 (quasi2540 q2584 lev2578)) (quasicons2537 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2583) (- lev2578 1))) (quasi2540 q2584 lev2578)))) tmp2582) ((lambda (tmp2585) (if tmp2585 (apply (lambda (p2586) (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2586) (+ lev2578 1)))) tmp2585) ((lambda (tmp2587) (if tmp2587 (apply (lambda (p2588 q2589) (quasicons2537 (quasi2540 p2588 lev2578) (quasi2540 q2589 lev2578))) tmp2587) ((lambda (tmp2590) (if tmp2590 (apply (lambda (x2591) (quasivector2539 (quasi2540 x2591 lev2578))) tmp2590) ((lambda (p2593) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2593)) tmp2579))) (syntax-dispatch tmp2579 (quote #(vector each-any)))))) (syntax-dispatch tmp2579 (quote (any . any)))))) (syntax-dispatch tmp2579 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2579 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2579 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2577)))) (lambda (x2594) ((lambda (tmp2595) ((lambda (tmp2596) (if tmp2596 (apply (lambda (_2597 e2598) (quasi2540 e2598 0)) tmp2596) (syntax-violation #f "source expression failed to match any pattern" tmp2595))) (syntax-dispatch tmp2595 (quote (any any))))) x2594)))) +(install-global-transformer (quote include) (lambda (x2599) (letrec ((read-file2600 (lambda (fn2601 k2602) (let ((p2603 (open-input-file fn2601))) (let f2604 ((x2605 (read p2603))) (if (eof-object? x2605) (begin (close-input-port p2603) (quote ())) (cons (datum->syntax-object k2602 x2605) (f2604 (read p2603))))))))) ((lambda (tmp2606) ((lambda (tmp2607) (if tmp2607 (apply (lambda (k2608 filename2609) (let ((fn2610 (syntax-object->datum filename2609))) ((lambda (tmp2611) ((lambda (tmp2612) (if tmp2612 (apply (lambda (exp2613) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2613)) tmp2612) (syntax-violation #f "source expression failed to match any pattern" tmp2611))) (syntax-dispatch tmp2611 (quote each-any)))) (read-file2600 fn2610 k2608)))) tmp2607) (syntax-violation #f "source expression failed to match any pattern" tmp2606))) (syntax-dispatch tmp2606 (quote (any any))))) x2599)))) +(install-global-transformer (quote unquote) (lambda (x2615) ((lambda (tmp2616) ((lambda (tmp2617) (if tmp2617 (apply (lambda (_2618 e2619) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2619))) tmp2617) (syntax-violation #f "source expression failed to match any pattern" tmp2616))) (syntax-dispatch tmp2616 (quote (any any))))) x2615))) +(install-global-transformer (quote unquote-splicing) (lambda (x2620) ((lambda (tmp2621) ((lambda (tmp2622) (if tmp2622 (apply (lambda (_2623 e2624) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2624))) tmp2622) (syntax-violation #f "source expression failed to match any pattern" tmp2621))) (syntax-dispatch tmp2621 (quote (any any))))) x2620))) +(install-global-transformer (quote case) (lambda (x2625) ((lambda (tmp2626) ((lambda (tmp2627) (if tmp2627 (apply (lambda (_2628 e2629 m12630 m22631) ((lambda (tmp2632) ((lambda (body2633) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2629)) body2633)) tmp2632)) (let f2634 ((clause2635 m12630) (clauses2636 m22631)) (if (null? clauses2636) ((lambda (tmp2638) ((lambda (tmp2639) (if tmp2639 (apply (lambda (e12640 e22641) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12640 e22641))) tmp2639) ((lambda (tmp2643) (if tmp2643 (apply (lambda (k2644 e12645 e22646) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2644)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12645 e22646)))) tmp2643) ((lambda (_2649) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2638))) (syntax-dispatch tmp2638 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2638 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2635) ((lambda (tmp2650) ((lambda (rest2651) ((lambda (tmp2652) ((lambda (tmp2653) (if tmp2653 (apply (lambda (k2654 e12655 e22656) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2654)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12655 e22656)) rest2651)) tmp2653) ((lambda (_2659) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2652))) (syntax-dispatch tmp2652 (quote (each-any any . each-any))))) clause2635)) tmp2650)) (f2634 (car clauses2636) (cdr clauses2636))))))) tmp2627) (syntax-violation #f "source expression failed to match any pattern" tmp2626))) (syntax-dispatch tmp2626 (quote (any any any . each-any))))) x2625))) +(install-global-transformer (quote identifier-syntax) (lambda (x2660) ((lambda (tmp2661) ((lambda (tmp2662) (if tmp2662 (apply (lambda (_2663 e2664) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2664)) (list (cons _2663 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2664 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2662) (syntax-violation #f "source expression failed to match any pattern" tmp2661))) (syntax-dispatch tmp2661 (quote (any any))))) x2660))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 23a6efdc5..89701bc19 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -79,7 +79,7 @@ ;;; conditionally evaluates expr ... at compile-time or run-time ;;; depending upon situations (see the Chez Scheme System Manual, ;;; Revision 3, for a complete description) -;;; (syntax-error object message) +;;; (syntax-violation who message form [subform]) ;;; used to report errors found during expansion ;;; (install-global-transformer symbol value) ;;; used by expanded code to install top-level syntactic abstractions @@ -912,8 +912,9 @@ ((free-id=? x (syntax compile)) 'compile) ((free-id=? x (syntax load)) 'load) ((free-id=? x (syntax eval)) 'eval) - (else (syntax-error (wrap x w #f) - "invalid eval-when situation")))) + (else (syntax-violation 'eval-when + "invalid situation" + e (wrap x w #f))))) situations)))))) ;;; syntax-type returns six values: type, value, e, w, s, and mod. The @@ -1102,15 +1103,16 @@ (build-global-definition s n (chi e r w mod) mod) mod)) ((displaced-lexical) - (syntax-error (wrap value w mod) "identifier out of context")) + (syntax-violation #f "identifier out of context" + e (wrap value w mod))) ((core macro module-ref) (remove-global-definition-hook n) (eval-if-c&e m (build-global-definition s n (chi e r w mod) mod) mod)) (else - (syntax-error (wrap value w mod) - "cannot define keyword at top level"))))) + (syntax-violation #f "cannot define keyword at top level" + e (wrap value w mod)))))) (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) (define chi @@ -1159,14 +1161,16 @@ (chi-sequence (syntax (e1 e2 ...)) r w s mod) (chi-void)))))) ((define-form define-syntax-form) - (syntax-error (wrap value w mod) "invalid context for definition of")) + (syntax-violation #f "definition in expression context" + e (wrap value w mod))) ((syntax) - (syntax-error (source-wrap e w s mod) - "reference to pattern variable outside syntax form")) + (syntax-violation #f "reference to pattern variable outside syntax form" + (source-wrap e w s mod))) ((displaced-lexical) - (syntax-error (source-wrap e w s mod) + (syntax-violation #f (source-wrap e w s mod) "reference to identifier outside its scope")) - (else (syntax-error (source-wrap e w s mod)))))) + (else (syntax-violation #f "unexpected syntax" + (source-wrap e w s mod)))))) (define chi-application (lambda (x e r w s mod) @@ -1213,7 +1217,8 @@ (vector-set! v i (rebuild-macro-output (vector-ref x i) m))))) ((symbol? x) - (syntax-error x "encountered raw symbol in macro output")) + (syntax-violation #f "encountered raw symbol in macro output" + (source-wrap e w s mod) x)) (else x)))) (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark)))) @@ -1263,7 +1268,7 @@ (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) (ids '()) (labels '()) (vars '()) (vals '()) (bindings '())) (if (null? body) - (syntax-error outer-form "no expressions in body") + (syntax-violation #f "no expressions in body" outer-form) (let ((e (cdar body)) (er (caar body))) (call-with-values (lambda () (syntax-type e er empty-wrap no-source ribcage mod)) @@ -1312,8 +1317,9 @@ (cdr body)))) (begin (if (not (valid-bound-ids? ids)) - (syntax-error outer-form - "invalid or duplicate identifier in definition")) + (syntax-violation + #f "invalid or duplicate identifier in definition" + outer-form)) (let loop ((bs bindings) (er-cache #f) (r-cache #f)) (if (not (null? bs)) (let* ((b (car bs))) @@ -1350,7 +1356,7 @@ (((id ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "invalid parameter list in") + (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (k new-vars @@ -1363,7 +1369,7 @@ ((ids e1 e2 ...) (let ((old-ids (lambda-var-list (syntax ids)))) (if (not (valid-bound-ids? old-ids)) - (syntax-error e "invalid parameter list in") + (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels old-ids)) (new-vars (map gen-var old-ids))) (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) @@ -1376,7 +1382,7 @@ (extend-var-env labels new-vars r) (make-binding-wrap old-ids labels w) mod)))))) - (_ (syntax-error e))))) + (_ (syntax-violation 'lambda "bad lambda" e))))) (define chi-local-syntax (lambda (rec? e r w s mod k) @@ -1384,7 +1390,7 @@ ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound keyword in") + (syntax-violation #f "duplicate bound keyword" e) (let ((labels (gen-labels ids))) (let ((new-w (make-binding-wrap ids labels w))) (k (syntax (e1 e2 ...)) @@ -1402,14 +1408,15 @@ new-w s mod)))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation #f "bad local syntax definition" + (source-wrap e w s mod)))))) (define eval-local-transformer (lambda (expanded mod) (let ((p (local-eval-hook expanded mod))) (if (procedure? p) p - (syntax-error p "nonprocedure transformer"))))) + (syntax-violation #f "nonprocedure transformer" p))))) (define chi-void (lambda () @@ -1514,8 +1521,10 @@ (lambda (id n) (case (binding-type (lookup n r mod)) ((displaced-lexical) - (syntax-error (source-wrap id w s mod) - "identifier out of context")))) + (syntax-violation 'fluid-let-syntax + "identifier out of context" + e + (source-wrap id w s mod))))) (syntax (var ...)) names) (chi-body @@ -1532,13 +1541,15 @@ r) w mod))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'fluid-let-syntax "bad syntax" + (source-wrap e w s mod)))))) (global-extend 'core 'quote (lambda (e r w s mod) (syntax-case e () ((_ e) (build-data s (strip (syntax e) w))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'quote "bad syntax" + (source-wrap e w s mod)))))) (global-extend 'core 'syntax (let () @@ -1554,7 +1565,7 @@ (gen-ref src (car var.lev) (cdr var.lev) maps))) (lambda (var maps) (values `(ref ,var) maps))) (if (ellipsis? e) - (syntax-error src "misplaced ellipsis in syntax form") + (syntax-violation 'syntax "misplaced ellipsis" src) (values `(quote ,e) maps))))) (syntax-case e () ((dots e) @@ -1572,8 +1583,8 @@ (cons '() maps) ellipsis? mod)) (lambda (x maps) (if (null? (car maps)) - (syntax-error src - "extra ellipsis in syntax form") + (syntax-violation 'syntax "extra ellipsis" + src) (values (gen-map x (car maps)) (cdr maps)))))))) (syntax-case y () @@ -1585,8 +1596,7 @@ (lambda () (k (cons '() maps))) (lambda (x maps) (if (null? (car maps)) - (syntax-error src - "extra ellipsis in syntax form") + (syntax-violation 'syntax "extra ellipsis" src) (values (gen-mappend x (car maps)) (cdr maps)))))))) (_ (call-with-values @@ -1615,7 +1625,7 @@ (if (fx= level 0) (values var maps) (if (null? maps) - (syntax-error src "missing ellipsis in syntax form") + (syntax-violation 'syntax "missing ellipsis" src) (call-with-values (lambda () (gen-ref src var (fx- level 1) (cdr maps))) (lambda (outer-var outer-maps) @@ -1703,7 +1713,7 @@ (call-with-values (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod)) (lambda (e maps) (regen e)))) - (_ (syntax-error e))))))) + (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) (global-extend 'core 'lambda @@ -1718,7 +1728,7 @@ (let () (define (chi-let e r w s mod constructor ids vals exps) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound variable in") + (syntax-violation 'let "duplicate bound variable" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((nw (make-binding-wrap ids labels w)) @@ -1743,7 +1753,7 @@ (syntax (f id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) - (_ (syntax-error (source-wrap e w s mod))))))) + (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) (global-extend 'core 'letrec @@ -1752,7 +1762,7 @@ ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound variable in") + (syntax-violation 'letrec "duplicate bound variable" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((w (make-binding-wrap ids labels w)) @@ -1762,7 +1772,7 @@ (map (lambda (x) (chi x r w mod)) (syntax (val ...))) (chi-body (syntax (e1 e2 ...)) (source-wrap e w s mod) r w mod))))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) (global-extend 'core 'set! @@ -1778,9 +1788,10 @@ (build-lexical-assignment s (binding-value b) val)) ((global) (build-global-assignment s n val mod)) ((displaced-lexical) - (syntax-error (wrap (syntax id) w mod) - "identifier out of context")) - (else (syntax-error (source-wrap e w s mod))))))) + (syntax-violation 'set! "identifier out of context" + (wrap (syntax id) w mod))) + (else (syntax-violation 'set! "bad set!" + (source-wrap e w s mod))))))) ((_ (head tail ...) val) (call-with-values (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod)) @@ -1796,7 +1807,7 @@ (chi (syntax (setter head)) r w mod) (map (lambda (e) (chi e r w mod)) (syntax (tail ... val))))))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (global-extend 'module-ref '@ (lambda (e) @@ -1884,11 +1895,9 @@ (lambda (p pvars) (cond ((not (distinct-bound-ids? (map car pvars))) - (syntax-error pat - "duplicate pattern variable in syntax-case pattern")) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars)) - (syntax-error pat - "misplaced ellipsis in syntax-case pattern")) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) (else (let ((y (gen-var 'tmp))) ; fat finger binding and references to temp variable y @@ -1916,8 +1925,8 @@ (lambda (x keys clauses r mod) (if (null? clauses) (build-application no-source - (build-primref no-source 'syntax-error) - (list x)) + (build-primref no-source 'syntax-violation) + (list #f "source expression failed to match any pattern" x)) (syntax-case (car clauses) () ((pat exp) (if (and (id? (syntax pat)) @@ -1940,7 +1949,8 @@ ((pat fender exp) (gen-clause x keys (cdr clauses) r (syntax pat) (syntax fender) (syntax exp) mod)) - (_ (syntax-error (car clauses) "invalid syntax-case clause")))))) + (_ (syntax-violation 'syntax-case "invalid clause" + (car clauses))))))) (lambda (e r w s mod) (let ((e (source-wrap e w s mod))) @@ -1957,7 +1967,7 @@ r mod)) (list (chi (syntax val) r empty-wrap mod)))) - (syntax-error e "invalid literals list in")))))))) + (syntax-violation 'syntax-case "invalid literals list" e)))))))) ;;; The portable sc-expand seeds chi-top's mode m with 'e (for ;;; evaluating) and esew (which stands for "eval syntax expanders @@ -2021,13 +2031,21 @@ (arg-check nonsymbol-id? y 'bound-identifier=?) (bound-id=? x y))) -(set! syntax-error - (lambda (object . messages) - (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages) - (let ((message (if (null? messages) - "invalid syntax" - (apply string-append messages)))) - (error-hook #f message (strip object empty-wrap))))) +(set! syntax-violation + (lambda (who message form . subform) + (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) + who 'syntax-violation) + (arg-check string? message 'syntax-violation) + (scm-error 'syntax-error 'sc-expand + (string-append + (if who "~a: " "") + "~a " + (if (null? subform) "in ~a" "in subform `~s' of `~s'")) + (let ((tail (cons message + (map (lambda (x) (strip x empty-wrap)) + (append subform (list form)))))) + (if who (cons who tail) tail)) + #f))) (set! install-global-transformer (lambda (sym v) @@ -2199,7 +2217,9 @@ (syntax-case s () (() v) ((e) (syntax e)) - (_ (syntax-error orig-x)))) + (_ (syntax-violation + 'do "bad step expression" + orig-x s)))) (syntax (var ...)) (syntax (step ...))))) (syntax-case (syntax (e1 ...)) () @@ -2307,14 +2327,15 @@ ((else e1 e2 ...) (syntax (begin e1 e2 ...))) (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) (begin e1 e2 ...)))) - (_ (syntax-error x))) + (_ (syntax-violation 'case "bad clause" x clause))) (with-syntax ((rest (f (car clauses) (cdr clauses)))) (syntax-case clause (else) (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) (begin e1 e2 ...) rest))) - (_ (syntax-error x)))))))) + (_ (syntax-violation 'case "bad clause" x + clause)))))))) (syntax (let ((t e)) body))))))) (define-syntax identifier-syntax From 22225fc113e716ec20712825e71191fedf3eecd8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 20:56:24 +0200 Subject: [PATCH 082/375] syntax-object->datum => syntax->datum, likewise datum->syntax * module/ice-9/boot-9.scm (datum->syntax, syntax->datum): Rename from datum->syntax-object and syntax-object->datum, following r6rs. Change all callers. Reorder some of the other exports from psyntax. * module/ice-9/psyntax.scm: Change datum->syntax and syntax->datum definitions and callers. * module/ice-9/psyntax-pp.scm: Regenerated. * module/oop/goops.scm (define-class-pre-definition): Update for changes. --- module/ice-9/boot-9.scm | 23 ++++++++++++----------- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 32 ++++++++++++++++---------------- module/oop/goops.scm | 6 +++--- 4 files changed, 42 insertions(+), 41 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f01bcf4ef..b2b1f65cd 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -187,12 +187,13 @@ (define syntax-violation #f) (define (annotation? x) #f) -(define bound-identifier=? #f) -(define datum->syntax-object #f) -(define free-identifier=? #f) -(define generate-temporaries #f) +(define datum->syntax #f) +(define syntax->datum #f) + (define identifier? #f) -(define syntax-object->datum #f) +(define generate-temporaries #f) +(define bound-identifier=? #f) +(define free-identifier=? #f) (define andmap (lambda (f first . rest) @@ -234,28 +235,28 @@ "Define a defmacro." (syntax-case x () ((_ (macro . args) doc body1 body ...) - (string? (syntax-object->datum (syntax doc))) + (string? (syntax->datum (syntax doc))) (syntax (define-macro macro doc (lambda args body1 body ...)))) ((_ (macro . args) body ...) (syntax (define-macro macro #f (lambda args body ...)))) ((_ macro doc transformer) - (or (string? (syntax-object->datum (syntax doc))) - (not (syntax-object->datum (syntax doc)))) + (or (string? (syntax->datum (syntax doc))) + (not (syntax->datum (syntax doc)))) (syntax (define-syntax macro (lambda (y) doc (syntax-case y () ((_ . args) - (let ((v (syntax-object->datum (syntax args)))) - (datum->syntax-object y (apply transformer v)))))))))))) + (let ((v (syntax->datum (syntax args)))) + (datum->syntax y (apply transformer v)))))))))))) (define-syntax defmacro (lambda (x) "Define a defmacro, with the old lispy defun syntax." (syntax-case x () ((_ macro args doc body1 body ...) - (string? (syntax-object->datum (syntax doc))) + (string? (syntax->datum (syntax doc))) (syntax (define-macro macro doc (lambda args body1 body ...)))) ((_ macro args body ...) (syntax (define-macro macro #f (lambda args body ...))))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 99668596d..f17823484 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1262 (lambda (vars1467) (let lvl1468 ((vars1469 vars1467) (ls1470 (quote ())) (w1471 (quote (())))) (cond ((pair? vars1469) (lvl1468 (cdr vars1469) (cons (wrap1241 (car vars1469) w1471 #f) ls1470) w1471)) ((id?1213 vars1469) (cons (wrap1241 vars1469 w1471 #f) ls1470)) ((null? vars1469) ls1470) ((syntax-object?1197 vars1469) (lvl1468 (syntax-object-expression1198 vars1469) ls1470 (join-wraps1232 w1471 (syntax-object-wrap1199 vars1469)))) ((annotation? vars1469) (lvl1468 (annotation-expression vars1469) ls1470 w1471)) (else (cons vars1469 ls1470)))))) (gen-var1261 (lambda (id1472) (let ((id1473 (if (syntax-object?1197 id1472) (syntax-object-expression1198 id1472) id1472))) (if (annotation? id1473) (build-annotated1190 (annotation-source id1473) (gensym (symbol->string (annotation-expression id1473)))) (build-annotated1190 #f (gensym (symbol->string id1473))))))) (strip1260 (lambda (x1474 w1475) (if (memq (quote top) (wrap-marks1216 w1475)) (if (or (annotation? x1474) (and (pair? x1474) (annotation? (car x1474)))) (strip-annotation1259 x1474 #f) x1474) (let f1476 ((x1477 x1474)) (cond ((syntax-object?1197 x1477) (strip1260 (syntax-object-expression1198 x1477) (syntax-object-wrap1199 x1477))) ((pair? x1477) (let ((a1478 (f1476 (car x1477))) (d1479 (f1476 (cdr x1477)))) (if (and (eq? a1478 (car x1477)) (eq? d1479 (cdr x1477))) x1477 (cons a1478 d1479)))) ((vector? x1477) (let ((old1480 (vector->list x1477))) (let ((new1481 (map f1476 old1480))) (if (andmap eq? old1480 new1481) x1477 (list->vector new1481))))) (else x1477)))))) (strip-annotation1259 (lambda (x1482 parent1483) (cond ((pair? x1482) (let ((new1484 (cons #f #f))) (begin (if parent1483 (set-annotation-stripped! parent1483 new1484)) (set-car! new1484 (strip-annotation1259 (car x1482) #f)) (set-cdr! new1484 (strip-annotation1259 (cdr x1482) #f)) new1484))) ((annotation? x1482) (or (annotation-stripped x1482) (strip-annotation1259 (annotation-expression x1482) x1482))) ((vector? x1482) (let ((new1485 (make-vector (vector-length x1482)))) (begin (if parent1483 (set-annotation-stripped! parent1483 new1485)) (let loop1486 ((i1487 (- (vector-length x1482) 1))) (unless (fx<1183 i1487 0) (vector-set! new1485 i1487 (strip-annotation1259 (vector-ref x1482 i1487) #f)) (loop1486 (fx-1181 i1487 1)))) new1485))) (else x1482)))) (ellipsis?1258 (lambda (x1488) (and (nonsymbol-id?1212 x1488) (free-id=?1236 x1488 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1257 (lambda () (build-annotated1190 #f (list (build-annotated1190 #f (quote void)))))) (eval-local-transformer1256 (lambda (expanded1489 mod1490) (let ((p1491 (local-eval-hook1185 expanded1489 mod1490))) (if (procedure? p1491) p1491 (syntax-violation #f "nonprocedure transformer" p1491))))) (chi-local-syntax1255 (lambda (rec?1492 e1493 r1494 w1495 s1496 mod1497 k1498) ((lambda (tmp1499) ((lambda (tmp1500) (if tmp1500 (apply (lambda (_1501 id1502 val1503 e11504 e21505) (let ((ids1506 id1502)) (if (not (valid-bound-ids?1238 ids1506)) (syntax-violation #f "duplicate bound keyword" e1493) (let ((labels1508 (gen-labels1219 ids1506))) (let ((new-w1509 (make-binding-wrap1230 ids1506 labels1508 w1495))) (k1498 (cons e11504 e21505) (extend-env1207 labels1508 (let ((w1511 (if rec?1492 new-w1509 w1495)) (trans-r1512 (macros-only-env1209 r1494))) (map (lambda (x1513) (cons (quote macro) (eval-local-transformer1256 (chi1249 x1513 trans-r1512 w1511 mod1497) mod1497))) val1503)) r1494) new-w1509 s1496 mod1497)))))) tmp1500) ((lambda (_1515) (syntax-violation #f "bad local syntax definition" (source-wrap1242 e1493 w1495 s1496 mod1497))) tmp1499))) (syntax-dispatch tmp1499 (quote (any #(each (any any)) any . each-any))))) e1493))) (chi-lambda-clause1254 (lambda (e1516 docstring1517 c1518 r1519 w1520 mod1521 k1522) ((lambda (tmp1523) ((lambda (tmp1524) (if (if tmp1524 (apply (lambda (args1525 doc1526 e11527 e21528) (and (string? (syntax-object->datum doc1526)) (not docstring1517))) tmp1524) #f) (apply (lambda (args1529 doc1530 e11531 e21532) (chi-lambda-clause1254 e1516 doc1530 (cons args1529 (cons e11531 e21532)) r1519 w1520 mod1521 k1522)) tmp1524) ((lambda (tmp1534) (if tmp1534 (apply (lambda (id1535 e11536 e21537) (let ((ids1538 id1535)) (if (not (valid-bound-ids?1238 ids1538)) (syntax-violation (quote lambda) "invalid parameter list" e1516) (let ((labels1540 (gen-labels1219 ids1538)) (new-vars1541 (map gen-var1261 ids1538))) (k1522 new-vars1541 docstring1517 (chi-body1253 (cons e11536 e21537) e1516 (extend-var-env1208 labels1540 new-vars1541 r1519) (make-binding-wrap1230 ids1538 labels1540 w1520) mod1521)))))) tmp1534) ((lambda (tmp1543) (if tmp1543 (apply (lambda (ids1544 e11545 e21546) (let ((old-ids1547 (lambda-var-list1262 ids1544))) (if (not (valid-bound-ids?1238 old-ids1547)) (syntax-violation (quote lambda) "invalid parameter list" e1516) (let ((labels1548 (gen-labels1219 old-ids1547)) (new-vars1549 (map gen-var1261 old-ids1547))) (k1522 (let f1550 ((ls11551 (cdr new-vars1549)) (ls21552 (car new-vars1549))) (if (null? ls11551) ls21552 (f1550 (cdr ls11551) (cons (car ls11551) ls21552)))) docstring1517 (chi-body1253 (cons e11545 e21546) e1516 (extend-var-env1208 labels1548 new-vars1549 r1519) (make-binding-wrap1230 old-ids1547 labels1548 w1520) mod1521)))))) tmp1543) ((lambda (_1554) (syntax-violation (quote lambda) "bad lambda" e1516)) tmp1523))) (syntax-dispatch tmp1523 (quote (any any . each-any)))))) (syntax-dispatch tmp1523 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1523 (quote (any any any . each-any))))) c1518))) (chi-body1253 (lambda (body1555 outer-form1556 r1557 w1558 mod1559) (let ((r1560 (cons (quote ("placeholder" placeholder)) r1557))) (let ((ribcage1561 (make-ribcage1220 (quote ()) (quote ()) (quote ())))) (let ((w1562 (make-wrap1215 (wrap-marks1216 w1558) (cons ribcage1561 (wrap-subst1217 w1558))))) (let parse1563 ((body1564 (map (lambda (x1570) (cons r1560 (wrap1241 x1570 w1562 mod1559))) body1555)) (ids1565 (quote ())) (labels1566 (quote ())) (vars1567 (quote ())) (vals1568 (quote ())) (bindings1569 (quote ()))) (if (null? body1564) (syntax-violation #f "no expressions in body" outer-form1556) (let ((e1571 (cdar body1564)) (er1572 (caar body1564))) (call-with-values (lambda () (syntax-type1247 e1571 er1572 (quote (())) #f ribcage1561 mod1559)) (lambda (type1573 value1574 e1575 w1576 s1577 mod1578) (let ((t1579 type1573)) (if (memv t1579 (quote (define-form))) (let ((id1580 (wrap1241 value1574 w1576 mod1578)) (label1581 (gen-label1218))) (let ((var1582 (gen-var1261 id1580))) (begin (extend-ribcage!1229 ribcage1561 id1580 label1581) (parse1563 (cdr body1564) (cons id1580 ids1565) (cons label1581 labels1566) (cons var1582 vars1567) (cons (cons er1572 (wrap1241 e1575 w1576 mod1578)) vals1568) (cons (cons (quote lexical) var1582) bindings1569))))) (if (memv t1579 (quote (define-syntax-form))) (let ((id1583 (wrap1241 value1574 w1576 mod1578)) (label1584 (gen-label1218))) (begin (extend-ribcage!1229 ribcage1561 id1583 label1584) (parse1563 (cdr body1564) (cons id1583 ids1565) (cons label1584 labels1566) vars1567 vals1568 (cons (cons (quote macro) (cons er1572 (wrap1241 e1575 w1576 mod1578))) bindings1569)))) (if (memv t1579 (quote (begin-form))) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (_1587 e11588) (parse1563 (let f1589 ((forms1590 e11588)) (if (null? forms1590) (cdr body1564) (cons (cons er1572 (wrap1241 (car forms1590) w1576 mod1578)) (f1589 (cdr forms1590))))) ids1565 labels1566 vars1567 vals1568 bindings1569)) tmp1586) (syntax-violation #f "source expression failed to match any pattern" tmp1585))) (syntax-dispatch tmp1585 (quote (any . each-any))))) e1575) (if (memv t1579 (quote (local-syntax-form))) (chi-local-syntax1255 value1574 e1575 er1572 w1576 s1577 mod1578 (lambda (forms1592 er1593 w1594 s1595 mod1596) (parse1563 (let f1597 ((forms1598 forms1592)) (if (null? forms1598) (cdr body1564) (cons (cons er1593 (wrap1241 (car forms1598) w1594 mod1596)) (f1597 (cdr forms1598))))) ids1565 labels1566 vars1567 vals1568 bindings1569))) (if (null? ids1565) (build-sequence1192 #f (map (lambda (x1599) (chi1249 (cdr x1599) (car x1599) (quote (())) mod1578)) (cons (cons er1572 (source-wrap1242 e1575 w1576 s1577 mod1578)) (cdr body1564)))) (begin (if (not (valid-bound-ids?1238 ids1565)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1556)) (let loop1600 ((bs1601 bindings1569) (er-cache1602 #f) (r-cache1603 #f)) (if (not (null? bs1601)) (let ((b1604 (car bs1601))) (if (eq? (car b1604) (quote macro)) (let ((er1605 (cadr b1604))) (let ((r-cache1606 (if (eq? er1605 er-cache1602) r-cache1603 (macros-only-env1209 er1605)))) (begin (set-cdr! b1604 (eval-local-transformer1256 (chi1249 (cddr b1604) r-cache1606 (quote (())) mod1578) mod1578)) (loop1600 (cdr bs1601) er1605 r-cache1606)))) (loop1600 (cdr bs1601) er-cache1602 r-cache1603))))) (set-cdr! r1560 (extend-env1207 labels1566 bindings1569 (cdr r1560))) (build-letrec1195 #f vars1567 (map (lambda (x1607) (chi1249 (cdr x1607) (car x1607) (quote (())) mod1578)) vals1568) (build-sequence1192 #f (map (lambda (x1608) (chi1249 (cdr x1608) (car x1608) (quote (())) mod1578)) (cons (cons er1572 (source-wrap1242 e1575 w1576 s1577 mod1578)) (cdr body1564)))))))))))))))))))))) (chi-macro1252 (lambda (p1609 e1610 r1611 w1612 rib1613 mod1614) (letrec ((rebuild-macro-output1615 (lambda (x1616 m1617) (cond ((pair? x1616) (cons (rebuild-macro-output1615 (car x1616) m1617) (rebuild-macro-output1615 (cdr x1616) m1617))) ((syntax-object?1197 x1616) (let ((w1618 (syntax-object-wrap1199 x1616))) (let ((ms1619 (wrap-marks1216 w1618)) (s1620 (wrap-subst1217 w1618))) (if (and (pair? ms1619) (eq? (car ms1619) #f)) (make-syntax-object1196 (syntax-object-expression1198 x1616) (make-wrap1215 (cdr ms1619) (if rib1613 (cons rib1613 (cdr s1620)) (cdr s1620))) (syntax-object-module1200 x1616)) (make-syntax-object1196 (syntax-object-expression1198 x1616) (make-wrap1215 (cons m1617 ms1619) (if rib1613 (cons rib1613 (cons (quote shift) s1620)) (cons (quote shift) s1620))) (let ((pmod1621 (procedure-module p1609))) (if pmod1621 (cons (quote hygiene) (module-name pmod1621)) (quote (hygiene guile))))))))) ((vector? x1616) (let ((n1622 (vector-length x1616))) (let ((v1623 (make-vector n1622))) (let doloop1624 ((i1625 0)) (if (fx=1182 i1625 n1622) v1623 (begin (vector-set! v1623 i1625 (rebuild-macro-output1615 (vector-ref x1616 i1625) m1617)) (doloop1624 (fx+1180 i1625 1)))))))) ((symbol? x1616) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1242 e1610 w1612 s mod1614) x1616)) (else x1616))))) (rebuild-macro-output1615 (p1609 (wrap1241 e1610 (anti-mark1228 w1612) mod1614)) (string #\m))))) (chi-application1251 (lambda (x1626 e1627 r1628 w1629 s1630 mod1631) ((lambda (tmp1632) ((lambda (tmp1633) (if tmp1633 (apply (lambda (e01634 e11635) (build-annotated1190 s1630 (cons x1626 (map (lambda (e1636) (chi1249 e1636 r1628 w1629 mod1631)) e11635)))) tmp1633) (syntax-violation #f "source expression failed to match any pattern" tmp1632))) (syntax-dispatch tmp1632 (quote (any . each-any))))) e1627))) (chi-expr1250 (lambda (type1638 value1639 e1640 r1641 w1642 s1643 mod1644) (let ((t1645 type1638)) (if (memv t1645 (quote (lexical))) (build-annotated1190 s1643 value1639) (if (memv t1645 (quote (core external-macro))) (value1639 e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (module-ref))) (call-with-values (lambda () (value1639 e1640)) (lambda (id1646 mod1647) (build-annotated1190 s1643 (if mod1647 (make-module-ref (cdr mod1647) id1646 (car mod1647)) (make-module-ref mod1647 id1646 (quote bare)))))) (if (memv t1645 (quote (lexical-call))) (chi-application1251 (build-annotated1190 (source-annotation1204 (car e1640)) value1639) e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (global-call))) (chi-application1251 (build-annotated1190 (source-annotation1204 (car e1640)) (if (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644) (make-module-ref (cdr (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644)) value1639 (car (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644))) (make-module-ref (if (syntax-object?1197 (car e1640)) (syntax-object-module1200 (car e1640)) mod1644) value1639 (quote bare)))) e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (constant))) (build-data1191 s1643 (strip1260 (source-wrap1242 e1640 w1642 s1643 mod1644) (quote (())))) (if (memv t1645 (quote (global))) (build-annotated1190 s1643 (if mod1644 (make-module-ref (cdr mod1644) value1639 (car mod1644)) (make-module-ref mod1644 value1639 (quote bare)))) (if (memv t1645 (quote (call))) (chi-application1251 (chi1249 (car e1640) r1641 w1642 mod1644) e1640 r1641 w1642 s1643 mod1644) (if (memv t1645 (quote (begin-form))) ((lambda (tmp1648) ((lambda (tmp1649) (if tmp1649 (apply (lambda (_1650 e11651 e21652) (chi-sequence1243 (cons e11651 e21652) r1641 w1642 s1643 mod1644)) tmp1649) (syntax-violation #f "source expression failed to match any pattern" tmp1648))) (syntax-dispatch tmp1648 (quote (any any . each-any))))) e1640) (if (memv t1645 (quote (local-syntax-form))) (chi-local-syntax1255 value1639 e1640 r1641 w1642 s1643 mod1644 chi-sequence1243) (if (memv t1645 (quote (eval-when-form))) ((lambda (tmp1654) ((lambda (tmp1655) (if tmp1655 (apply (lambda (_1656 x1657 e11658 e21659) (let ((when-list1660 (chi-when-list1246 e1640 x1657 w1642))) (if (memq (quote eval) when-list1660) (chi-sequence1243 (cons e11658 e21659) r1641 w1642 s1643 mod1644) (chi-void1257)))) tmp1655) (syntax-violation #f "source expression failed to match any pattern" tmp1654))) (syntax-dispatch tmp1654 (quote (any each-any any . each-any))))) e1640) (if (memv t1645 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1640 (wrap1241 value1639 w1642 mod1644)) (if (memv t1645 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1242 e1640 w1642 s1643 mod1644)) (if (memv t1645 (quote (displaced-lexical))) (syntax-violation #f (source-wrap1242 e1640 w1642 s1643 mod1644) "reference to identifier outside its scope") (syntax-violation #f "unexpected syntax" (source-wrap1242 e1640 w1642 s1643 mod1644))))))))))))))))))) (chi1249 (lambda (e1663 r1664 w1665 mod1666) (call-with-values (lambda () (syntax-type1247 e1663 r1664 w1665 #f #f mod1666)) (lambda (type1667 value1668 e1669 w1670 s1671 mod1672) (chi-expr1250 type1667 value1668 e1669 r1664 w1670 s1671 mod1672))))) (chi-top1248 (lambda (e1673 r1674 w1675 m1676 esew1677 mod1678) (call-with-values (lambda () (syntax-type1247 e1673 r1674 w1675 #f #f mod1678)) (lambda (type1686 value1687 e1688 w1689 s1690 mod1691) (let ((t1692 type1686)) (if (memv t1692 (quote (begin-form))) ((lambda (tmp1693) ((lambda (tmp1694) (if tmp1694 (apply (lambda (_1695) (chi-void1257)) tmp1694) ((lambda (tmp1696) (if tmp1696 (apply (lambda (_1697 e11698 e21699) (chi-top-sequence1244 (cons e11698 e21699) r1674 w1689 s1690 m1676 esew1677 mod1691)) tmp1696) (syntax-violation #f "source expression failed to match any pattern" tmp1693))) (syntax-dispatch tmp1693 (quote (any any . each-any)))))) (syntax-dispatch tmp1693 (quote (any))))) e1688) (if (memv t1692 (quote (local-syntax-form))) (chi-local-syntax1255 value1687 e1688 r1674 w1689 s1690 mod1691 (lambda (body1701 r1702 w1703 s1704 mod1705) (chi-top-sequence1244 body1701 r1702 w1703 s1704 m1676 esew1677 mod1705))) (if (memv t1692 (quote (eval-when-form))) ((lambda (tmp1706) ((lambda (tmp1707) (if tmp1707 (apply (lambda (_1708 x1709 e11710 e21711) (let ((when-list1712 (chi-when-list1246 e1688 x1709 w1689)) (body1713 (cons e11710 e21711))) (cond ((eq? m1676 (quote e)) (if (memq (quote eval) when-list1712) (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote e) (quote (eval)) mod1691) (chi-void1257))) ((memq (quote load) when-list1712) (if (or (memq (quote compile) when-list1712) (and (eq? m1676 (quote c&e)) (memq (quote eval) when-list1712))) (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote c&e) (quote (compile load)) mod1691) (if (memq m1676 (quote (c c&e))) (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote c) (quote (load)) mod1691) (chi-void1257)))) ((or (memq (quote compile) when-list1712) (and (eq? m1676 (quote c&e)) (memq (quote eval) when-list1712))) (top-level-eval-hook1184 (chi-top-sequence1244 body1713 r1674 w1689 s1690 (quote e) (quote (eval)) mod1691) mod1691) (chi-void1257)) (else (chi-void1257))))) tmp1707) (syntax-violation #f "source expression failed to match any pattern" tmp1706))) (syntax-dispatch tmp1706 (quote (any each-any any . each-any))))) e1688) (if (memv t1692 (quote (define-syntax-form))) (let ((n1716 (id-var-name1235 value1687 w1689)) (r1717 (macros-only-env1209 r1674))) (let ((t1718 m1676)) (if (memv t1718 (quote (c))) (if (memq (quote compile) esew1677) (let ((e1719 (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)))) (begin (top-level-eval-hook1184 e1719 mod1691) (if (memq (quote load) esew1677) e1719 (chi-void1257)))) (if (memq (quote load) esew1677) (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)) (chi-void1257))) (if (memv t1718 (quote (c&e))) (let ((e1720 (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)))) (begin (top-level-eval-hook1184 e1720 mod1691) e1720)) (begin (if (memq (quote eval) esew1677) (top-level-eval-hook1184 (chi-install-global1245 n1716 (chi1249 e1688 r1717 w1689 mod1691)) mod1691)) (chi-void1257)))))) (if (memv t1692 (quote (define-form))) (let ((n1721 (id-var-name1235 value1687 w1689))) (let ((type1722 (binding-type1205 (lookup1210 n1721 r1674 mod1691)))) (let ((t1723 type1722)) (if (memv t1723 (quote (global))) (let ((x1724 (build-annotated1190 s1690 (list (quote define) n1721 (chi1249 e1688 r1674 w1689 mod1691))))) (begin (if (eq? m1676 (quote c&e)) (top-level-eval-hook1184 x1724 mod1691)) x1724)) (if (memv t1723 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1688 (wrap1241 value1687 w1689 mod1691)) (if (memv t1723 (quote (core macro module-ref))) (begin (remove-global-definition-hook1188 n1721) (let ((x1725 (build-annotated1190 s1690 (list (quote define) n1721 (chi1249 e1688 r1674 w1689 mod1691))))) (begin (if (eq? m1676 (quote c&e)) (top-level-eval-hook1184 x1725 mod1691)) x1725))) (syntax-violation #f "cannot define keyword at top level" e1688 (wrap1241 value1687 w1689 mod1691)))))))) (let ((x1726 (chi-expr1250 type1686 value1687 e1688 r1674 w1689 s1690 mod1691))) (begin (if (eq? m1676 (quote c&e)) (top-level-eval-hook1184 x1726 mod1691)) x1726)))))))))))) (syntax-type1247 (lambda (e1727 r1728 w1729 s1730 rib1731 mod1732) (cond ((symbol? e1727) (let ((n1733 (id-var-name1235 e1727 w1729))) (let ((b1734 (lookup1210 n1733 r1728 mod1732))) (let ((type1735 (binding-type1205 b1734))) (let ((t1736 type1735)) (if (memv t1736 (quote (lexical))) (values type1735 (binding-value1206 b1734) e1727 w1729 s1730 mod1732) (if (memv t1736 (quote (global))) (values type1735 n1733 e1727 w1729 s1730 mod1732) (if (memv t1736 (quote (macro))) (syntax-type1247 (chi-macro1252 (binding-value1206 b1734) e1727 r1728 w1729 rib1731 mod1732) r1728 (quote (())) s1730 rib1731 mod1732) (values type1735 (binding-value1206 b1734) e1727 w1729 s1730 mod1732))))))))) ((pair? e1727) (let ((first1737 (car e1727))) (if (id?1213 first1737) (let ((n1738 (id-var-name1235 first1737 w1729))) (let ((b1739 (lookup1210 n1738 r1728 (or (and (syntax-object?1197 first1737) (syntax-object-module1200 first1737)) mod1732)))) (let ((type1740 (binding-type1205 b1739))) (let ((t1741 type1740)) (if (memv t1741 (quote (lexical))) (values (quote lexical-call) (binding-value1206 b1739) e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (global))) (values (quote global-call) n1738 e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (macro))) (syntax-type1247 (chi-macro1252 (binding-value1206 b1739) e1727 r1728 w1729 rib1731 mod1732) r1728 (quote (())) s1730 rib1731 mod1732) (if (memv t1741 (quote (core external-macro module-ref))) (values type1740 (binding-value1206 b1739) e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1206 b1739) e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (begin))) (values (quote begin-form) #f e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (eval-when))) (values (quote eval-when-form) #f e1727 w1729 s1730 mod1732) (if (memv t1741 (quote (define))) ((lambda (tmp1742) ((lambda (tmp1743) (if (if tmp1743 (apply (lambda (_1744 name1745 val1746) (id?1213 name1745)) tmp1743) #f) (apply (lambda (_1747 name1748 val1749) (values (quote define-form) name1748 val1749 w1729 s1730 mod1732)) tmp1743) ((lambda (tmp1750) (if (if tmp1750 (apply (lambda (_1751 name1752 args1753 e11754 e21755) (and (id?1213 name1752) (valid-bound-ids?1238 (lambda-var-list1262 args1753)))) tmp1750) #f) (apply (lambda (_1756 name1757 args1758 e11759 e21760) (values (quote define-form) (wrap1241 name1757 w1729 mod1732) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1241 (cons args1758 (cons e11759 e21760)) w1729 mod1732)) (quote (())) s1730 mod1732)) tmp1750) ((lambda (tmp1762) (if (if tmp1762 (apply (lambda (_1763 name1764) (id?1213 name1764)) tmp1762) #f) (apply (lambda (_1765 name1766) (values (quote define-form) (wrap1241 name1766 w1729 mod1732) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1730 mod1732)) tmp1762) (syntax-violation #f "source expression failed to match any pattern" tmp1742))) (syntax-dispatch tmp1742 (quote (any any)))))) (syntax-dispatch tmp1742 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1742 (quote (any any any))))) e1727) (if (memv t1741 (quote (define-syntax))) ((lambda (tmp1767) ((lambda (tmp1768) (if (if tmp1768 (apply (lambda (_1769 name1770 val1771) (id?1213 name1770)) tmp1768) #f) (apply (lambda (_1772 name1773 val1774) (values (quote define-syntax-form) name1773 val1774 w1729 s1730 mod1732)) tmp1768) (syntax-violation #f "source expression failed to match any pattern" tmp1767))) (syntax-dispatch tmp1767 (quote (any any any))))) e1727) (values (quote call) #f e1727 w1729 s1730 mod1732)))))))))))))) (values (quote call) #f e1727 w1729 s1730 mod1732)))) ((syntax-object?1197 e1727) (syntax-type1247 (syntax-object-expression1198 e1727) r1728 (join-wraps1232 w1729 (syntax-object-wrap1199 e1727)) #f rib1731 (or (syntax-object-module1200 e1727) mod1732))) ((annotation? e1727) (syntax-type1247 (annotation-expression e1727) r1728 w1729 (annotation-source e1727) rib1731 mod1732)) ((self-evaluating? e1727) (values (quote constant) #f e1727 w1729 s1730 mod1732)) (else (values (quote other) #f e1727 w1729 s1730 mod1732))))) (chi-when-list1246 (lambda (e1775 when-list1776 w1777) (let f1778 ((when-list1779 when-list1776) (situations1780 (quote ()))) (if (null? when-list1779) situations1780 (f1778 (cdr when-list1779) (cons (let ((x1781 (car when-list1779))) (cond ((free-id=?1236 x1781 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1236 x1781 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1236 x1781 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1775 (wrap1241 x1781 w1777 #f))))) situations1780)))))) (chi-install-global1245 (lambda (name1782 e1783) (build-annotated1190 #f (list (build-annotated1190 #f (quote install-global-transformer)) (build-data1191 #f name1782) e1783)))) (chi-top-sequence1244 (lambda (body1784 r1785 w1786 s1787 m1788 esew1789 mod1790) (build-sequence1192 s1787 (let dobody1791 ((body1792 body1784) (r1793 r1785) (w1794 w1786) (m1795 m1788) (esew1796 esew1789) (mod1797 mod1790)) (if (null? body1792) (quote ()) (let ((first1798 (chi-top1248 (car body1792) r1793 w1794 m1795 esew1796 mod1797))) (cons first1798 (dobody1791 (cdr body1792) r1793 w1794 m1795 esew1796 mod1797)))))))) (chi-sequence1243 (lambda (body1799 r1800 w1801 s1802 mod1803) (build-sequence1192 s1802 (let dobody1804 ((body1805 body1799) (r1806 r1800) (w1807 w1801) (mod1808 mod1803)) (if (null? body1805) (quote ()) (let ((first1809 (chi1249 (car body1805) r1806 w1807 mod1808))) (cons first1809 (dobody1804 (cdr body1805) r1806 w1807 mod1808)))))))) (source-wrap1242 (lambda (x1810 w1811 s1812 defmod1813) (wrap1241 (if s1812 (make-annotation x1810 s1812 #f) x1810) w1811 defmod1813))) (wrap1241 (lambda (x1814 w1815 defmod1816) (cond ((and (null? (wrap-marks1216 w1815)) (null? (wrap-subst1217 w1815))) x1814) ((syntax-object?1197 x1814) (make-syntax-object1196 (syntax-object-expression1198 x1814) (join-wraps1232 w1815 (syntax-object-wrap1199 x1814)) (syntax-object-module1200 x1814))) ((null? x1814) x1814) (else (make-syntax-object1196 x1814 w1815 defmod1816))))) (bound-id-member?1240 (lambda (x1817 list1818) (and (not (null? list1818)) (or (bound-id=?1237 x1817 (car list1818)) (bound-id-member?1240 x1817 (cdr list1818)))))) (distinct-bound-ids?1239 (lambda (ids1819) (let distinct?1820 ((ids1821 ids1819)) (or (null? ids1821) (and (not (bound-id-member?1240 (car ids1821) (cdr ids1821))) (distinct?1820 (cdr ids1821))))))) (valid-bound-ids?1238 (lambda (ids1822) (and (let all-ids?1823 ((ids1824 ids1822)) (or (null? ids1824) (and (id?1213 (car ids1824)) (all-ids?1823 (cdr ids1824))))) (distinct-bound-ids?1239 ids1822)))) (bound-id=?1237 (lambda (i1825 j1826) (if (and (syntax-object?1197 i1825) (syntax-object?1197 j1826)) (and (eq? (let ((e1827 (syntax-object-expression1198 i1825))) (if (annotation? e1827) (annotation-expression e1827) e1827)) (let ((e1828 (syntax-object-expression1198 j1826))) (if (annotation? e1828) (annotation-expression e1828) e1828))) (same-marks?1234 (wrap-marks1216 (syntax-object-wrap1199 i1825)) (wrap-marks1216 (syntax-object-wrap1199 j1826)))) (eq? (let ((e1829 i1825)) (if (annotation? e1829) (annotation-expression e1829) e1829)) (let ((e1830 j1826)) (if (annotation? e1830) (annotation-expression e1830) e1830)))))) (free-id=?1236 (lambda (i1831 j1832) (and (eq? (let ((x1833 i1831)) (let ((e1834 (if (syntax-object?1197 x1833) (syntax-object-expression1198 x1833) x1833))) (if (annotation? e1834) (annotation-expression e1834) e1834))) (let ((x1835 j1832)) (let ((e1836 (if (syntax-object?1197 x1835) (syntax-object-expression1198 x1835) x1835))) (if (annotation? e1836) (annotation-expression e1836) e1836)))) (eq? (id-var-name1235 i1831 (quote (()))) (id-var-name1235 j1832 (quote (()))))))) (id-var-name1235 (lambda (id1837 w1838) (letrec ((search-vector-rib1841 (lambda (sym1847 subst1848 marks1849 symnames1850 ribcage1851) (let ((n1852 (vector-length symnames1850))) (let f1853 ((i1854 0)) (cond ((fx=1182 i1854 n1852) (search1839 sym1847 (cdr subst1848) marks1849)) ((and (eq? (vector-ref symnames1850 i1854) sym1847) (same-marks?1234 marks1849 (vector-ref (ribcage-marks1223 ribcage1851) i1854))) (values (vector-ref (ribcage-labels1224 ribcage1851) i1854) marks1849)) (else (f1853 (fx+1180 i1854 1)))))))) (search-list-rib1840 (lambda (sym1855 subst1856 marks1857 symnames1858 ribcage1859) (let f1860 ((symnames1861 symnames1858) (i1862 0)) (cond ((null? symnames1861) (search1839 sym1855 (cdr subst1856) marks1857)) ((and (eq? (car symnames1861) sym1855) (same-marks?1234 marks1857 (list-ref (ribcage-marks1223 ribcage1859) i1862))) (values (list-ref (ribcage-labels1224 ribcage1859) i1862) marks1857)) (else (f1860 (cdr symnames1861) (fx+1180 i1862 1))))))) (search1839 (lambda (sym1863 subst1864 marks1865) (if (null? subst1864) (values #f marks1865) (let ((fst1866 (car subst1864))) (if (eq? fst1866 (quote shift)) (search1839 sym1863 (cdr subst1864) (cdr marks1865)) (let ((symnames1867 (ribcage-symnames1222 fst1866))) (if (vector? symnames1867) (search-vector-rib1841 sym1863 subst1864 marks1865 symnames1867 fst1866) (search-list-rib1840 sym1863 subst1864 marks1865 symnames1867 fst1866))))))))) (cond ((symbol? id1837) (or (call-with-values (lambda () (search1839 id1837 (wrap-subst1217 w1838) (wrap-marks1216 w1838))) (lambda (x1869 . ignore1868) x1869)) id1837)) ((syntax-object?1197 id1837) (let ((id1870 (let ((e1872 (syntax-object-expression1198 id1837))) (if (annotation? e1872) (annotation-expression e1872) e1872))) (w11871 (syntax-object-wrap1199 id1837))) (let ((marks1873 (join-marks1233 (wrap-marks1216 w1838) (wrap-marks1216 w11871)))) (call-with-values (lambda () (search1839 id1870 (wrap-subst1217 w1838) marks1873)) (lambda (new-id1874 marks1875) (or new-id1874 (call-with-values (lambda () (search1839 id1870 (wrap-subst1217 w11871) marks1875)) (lambda (x1877 . ignore1876) x1877)) id1870)))))) ((annotation? id1837) (let ((id1878 (let ((e1879 id1837)) (if (annotation? e1879) (annotation-expression e1879) e1879)))) (or (call-with-values (lambda () (search1839 id1878 (wrap-subst1217 w1838) (wrap-marks1216 w1838))) (lambda (x1881 . ignore1880) x1881)) id1878))) (else (error-hook1186 (quote id-var-name) "invalid id" id1837)))))) (same-marks?1234 (lambda (x1882 y1883) (or (eq? x1882 y1883) (and (not (null? x1882)) (not (null? y1883)) (eq? (car x1882) (car y1883)) (same-marks?1234 (cdr x1882) (cdr y1883)))))) (join-marks1233 (lambda (m11884 m21885) (smart-append1231 m11884 m21885))) (join-wraps1232 (lambda (w11886 w21887) (let ((m11888 (wrap-marks1216 w11886)) (s11889 (wrap-subst1217 w11886))) (if (null? m11888) (if (null? s11889) w21887 (make-wrap1215 (wrap-marks1216 w21887) (smart-append1231 s11889 (wrap-subst1217 w21887)))) (make-wrap1215 (smart-append1231 m11888 (wrap-marks1216 w21887)) (smart-append1231 s11889 (wrap-subst1217 w21887))))))) (smart-append1231 (lambda (m11890 m21891) (if (null? m21891) m11890 (append m11890 m21891)))) (make-binding-wrap1230 (lambda (ids1892 labels1893 w1894) (if (null? ids1892) w1894 (make-wrap1215 (wrap-marks1216 w1894) (cons (let ((labelvec1895 (list->vector labels1893))) (let ((n1896 (vector-length labelvec1895))) (let ((symnamevec1897 (make-vector n1896)) (marksvec1898 (make-vector n1896))) (begin (let f1899 ((ids1900 ids1892) (i1901 0)) (if (not (null? ids1900)) (call-with-values (lambda () (id-sym-name&marks1214 (car ids1900) w1894)) (lambda (symname1902 marks1903) (begin (vector-set! symnamevec1897 i1901 symname1902) (vector-set! marksvec1898 i1901 marks1903) (f1899 (cdr ids1900) (fx+1180 i1901 1))))))) (make-ribcage1220 symnamevec1897 marksvec1898 labelvec1895))))) (wrap-subst1217 w1894)))))) (extend-ribcage!1229 (lambda (ribcage1904 id1905 label1906) (begin (set-ribcage-symnames!1225 ribcage1904 (cons (let ((e1907 (syntax-object-expression1198 id1905))) (if (annotation? e1907) (annotation-expression e1907) e1907)) (ribcage-symnames1222 ribcage1904))) (set-ribcage-marks!1226 ribcage1904 (cons (wrap-marks1216 (syntax-object-wrap1199 id1905)) (ribcage-marks1223 ribcage1904))) (set-ribcage-labels!1227 ribcage1904 (cons label1906 (ribcage-labels1224 ribcage1904)))))) (anti-mark1228 (lambda (w1908) (make-wrap1215 (cons #f (wrap-marks1216 w1908)) (cons (quote shift) (wrap-subst1217 w1908))))) (set-ribcage-labels!1227 (lambda (x1909 update1910) (vector-set! x1909 3 update1910))) (set-ribcage-marks!1226 (lambda (x1911 update1912) (vector-set! x1911 2 update1912))) (set-ribcage-symnames!1225 (lambda (x1913 update1914) (vector-set! x1913 1 update1914))) (ribcage-labels1224 (lambda (x1915) (vector-ref x1915 3))) (ribcage-marks1223 (lambda (x1916) (vector-ref x1916 2))) (ribcage-symnames1222 (lambda (x1917) (vector-ref x1917 1))) (ribcage?1221 (lambda (x1918) (and (vector? x1918) (= (vector-length x1918) 4) (eq? (vector-ref x1918 0) (quote ribcage))))) (make-ribcage1220 (lambda (symnames1919 marks1920 labels1921) (vector (quote ribcage) symnames1919 marks1920 labels1921))) (gen-labels1219 (lambda (ls1922) (if (null? ls1922) (quote ()) (cons (gen-label1218) (gen-labels1219 (cdr ls1922)))))) (gen-label1218 (lambda () (string #\i))) (wrap-subst1217 cdr) (wrap-marks1216 car) (make-wrap1215 cons) (id-sym-name&marks1214 (lambda (x1923 w1924) (if (syntax-object?1197 x1923) (values (let ((e1925 (syntax-object-expression1198 x1923))) (if (annotation? e1925) (annotation-expression e1925) e1925)) (join-marks1233 (wrap-marks1216 w1924) (wrap-marks1216 (syntax-object-wrap1199 x1923)))) (values (let ((e1926 x1923)) (if (annotation? e1926) (annotation-expression e1926) e1926)) (wrap-marks1216 w1924))))) (id?1213 (lambda (x1927) (cond ((symbol? x1927) #t) ((syntax-object?1197 x1927) (symbol? (let ((e1928 (syntax-object-expression1198 x1927))) (if (annotation? e1928) (annotation-expression e1928) e1928)))) ((annotation? x1927) (symbol? (annotation-expression x1927))) (else #f)))) (nonsymbol-id?1212 (lambda (x1929) (and (syntax-object?1197 x1929) (symbol? (let ((e1930 (syntax-object-expression1198 x1929))) (if (annotation? e1930) (annotation-expression e1930) e1930)))))) (global-extend1211 (lambda (type1931 sym1932 val1933) (put-global-definition-hook1187 sym1932 type1931 val1933))) (lookup1210 (lambda (x1934 r1935 mod1936) (cond ((assq x1934 r1935) => cdr) ((symbol? x1934) (or (get-global-definition-hook1189 x1934 mod1936) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1209 (lambda (r1937) (if (null? r1937) (quote ()) (let ((a1938 (car r1937))) (if (eq? (cadr a1938) (quote macro)) (cons a1938 (macros-only-env1209 (cdr r1937))) (macros-only-env1209 (cdr r1937))))))) (extend-var-env1208 (lambda (labels1939 vars1940 r1941) (if (null? labels1939) r1941 (extend-var-env1208 (cdr labels1939) (cdr vars1940) (cons (cons (car labels1939) (cons (quote lexical) (car vars1940))) r1941))))) (extend-env1207 (lambda (labels1942 bindings1943 r1944) (if (null? labels1942) r1944 (extend-env1207 (cdr labels1942) (cdr bindings1943) (cons (cons (car labels1942) (car bindings1943)) r1944))))) (binding-value1206 cdr) (binding-type1205 car) (source-annotation1204 (lambda (x1945) (cond ((annotation? x1945) (annotation-source x1945)) ((syntax-object?1197 x1945) (source-annotation1204 (syntax-object-expression1198 x1945))) (else #f)))) (set-syntax-object-module!1203 (lambda (x1946 update1947) (vector-set! x1946 3 update1947))) (set-syntax-object-wrap!1202 (lambda (x1948 update1949) (vector-set! x1948 2 update1949))) (set-syntax-object-expression!1201 (lambda (x1950 update1951) (vector-set! x1950 1 update1951))) (syntax-object-module1200 (lambda (x1952) (vector-ref x1952 3))) (syntax-object-wrap1199 (lambda (x1953) (vector-ref x1953 2))) (syntax-object-expression1198 (lambda (x1954) (vector-ref x1954 1))) (syntax-object?1197 (lambda (x1955) (and (vector? x1955) (= (vector-length x1955) 4) (eq? (vector-ref x1955 0) (quote syntax-object))))) (make-syntax-object1196 (lambda (expression1956 wrap1957 module1958) (vector (quote syntax-object) expression1956 wrap1957 module1958))) (build-letrec1195 (lambda (src1959 vars1960 val-exps1961 body-exp1962) (if (null? vars1960) (build-annotated1190 src1959 body-exp1962) (build-annotated1190 src1959 (list (quote letrec) (map list vars1960 val-exps1961) body-exp1962))))) (build-named-let1194 (lambda (src1963 vars1964 val-exps1965 body-exp1966) (if (null? vars1964) (build-annotated1190 src1963 body-exp1966) (build-annotated1190 src1963 (list (quote let) (car vars1964) (map list (cdr vars1964) val-exps1965) body-exp1966))))) (build-let1193 (lambda (src1967 vars1968 val-exps1969 body-exp1970) (if (null? vars1968) (build-annotated1190 src1967 body-exp1970) (build-annotated1190 src1967 (list (quote let) (map list vars1968 val-exps1969) body-exp1970))))) (build-sequence1192 (lambda (src1971 exps1972) (if (null? (cdr exps1972)) (build-annotated1190 src1971 (car exps1972)) (build-annotated1190 src1971 (cons (quote begin) exps1972))))) (build-data1191 (lambda (src1973 exp1974) (if (and (self-evaluating? exp1974) (not (vector? exp1974))) (build-annotated1190 src1973 exp1974) (build-annotated1190 src1973 (list (quote quote) exp1974))))) (build-annotated1190 (lambda (src1975 exp1976) (if (and src1975 (not (annotation? exp1976))) (make-annotation exp1976 src1975 #t) exp1976))) (get-global-definition-hook1189 (lambda (symbol1977 module1978) (begin (if (and (not module1978) (current-module)) (warn "module system is booted, we should have a module" symbol1977)) (module-lookup-keyword (if module1978 (resolve-module (cdr module1978)) (current-module)) symbol1977)))) (remove-global-definition-hook1188 (lambda (symbol1979) (module-undefine-keyword! (current-module) symbol1979))) (put-global-definition-hook1187 (lambda (symbol1980 type1981 val1982) (module-define-keyword! (current-module) symbol1980 type1981 val1982))) (error-hook1186 (lambda (who1983 why1984 what1985) (error who1983 "~a ~s" why1984 what1985))) (local-eval-hook1185 (lambda (x1986 mod1987) (primitive-eval (list noexpand1179 x1986)))) (top-level-eval-hook1184 (lambda (x1988 mod1989) (primitive-eval (list noexpand1179 x1988)))) (fx<1183 <) (fx=1182 =) (fx-1181 -) (fx+1180 +) (noexpand1179 "noexpand")) (begin (global-extend1211 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1211 (quote local-syntax) (quote let-syntax) #f) (global-extend1211 (quote core) (quote fluid-let-syntax) (lambda (e1990 r1991 w1992 s1993 mod1994) ((lambda (tmp1995) ((lambda (tmp1996) (if (if tmp1996 (apply (lambda (_1997 var1998 val1999 e12000 e22001) (valid-bound-ids?1238 var1998)) tmp1996) #f) (apply (lambda (_2003 var2004 val2005 e12006 e22007) (let ((names2008 (map (lambda (x2009) (id-var-name1235 x2009 w1992)) var2004))) (begin (for-each (lambda (id2011 n2012) (let ((t2013 (binding-type1205 (lookup1210 n2012 r1991 mod1994)))) (if (memv t2013 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1990 (source-wrap1242 id2011 w1992 s1993 mod1994))))) var2004 names2008) (chi-body1253 (cons e12006 e22007) (source-wrap1242 e1990 w1992 s1993 mod1994) (extend-env1207 names2008 (let ((trans-r2016 (macros-only-env1209 r1991))) (map (lambda (x2017) (cons (quote macro) (eval-local-transformer1256 (chi1249 x2017 trans-r2016 w1992 mod1994) mod1994))) val2005)) r1991) w1992 mod1994)))) tmp1996) ((lambda (_2019) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1242 e1990 w1992 s1993 mod1994))) tmp1995))) (syntax-dispatch tmp1995 (quote (any #(each (any any)) any . each-any))))) e1990))) (global-extend1211 (quote core) (quote quote) (lambda (e2020 r2021 w2022 s2023 mod2024) ((lambda (tmp2025) ((lambda (tmp2026) (if tmp2026 (apply (lambda (_2027 e2028) (build-data1191 s2023 (strip1260 e2028 w2022))) tmp2026) ((lambda (_2029) (syntax-violation (quote quote) "bad syntax" (source-wrap1242 e2020 w2022 s2023 mod2024))) tmp2025))) (syntax-dispatch tmp2025 (quote (any any))))) e2020))) (global-extend1211 (quote core) (quote syntax) (letrec ((regen2037 (lambda (x2038) (let ((t2039 (car x2038))) (if (memv t2039 (quote (ref))) (build-annotated1190 #f (cadr x2038)) (if (memv t2039 (quote (primitive))) (build-annotated1190 #f (cadr x2038)) (if (memv t2039 (quote (quote))) (build-data1191 #f (cadr x2038)) (if (memv t2039 (quote (lambda))) (build-annotated1190 #f (list (quote lambda) (cadr x2038) (regen2037 (caddr x2038)))) (if (memv t2039 (quote (map))) (let ((ls2040 (map regen2037 (cdr x2038)))) (build-annotated1190 #f (cons (if (fx=1182 (length ls2040) 2) (build-annotated1190 #f (quote map)) (build-annotated1190 #f (quote map))) ls2040))) (build-annotated1190 #f (cons (build-annotated1190 #f (car x2038)) (map regen2037 (cdr x2038)))))))))))) (gen-vector2036 (lambda (x2041) (cond ((eq? (car x2041) (quote list)) (cons (quote vector) (cdr x2041))) ((eq? (car x2041) (quote quote)) (list (quote quote) (list->vector (cadr x2041)))) (else (list (quote list->vector) x2041))))) (gen-append2035 (lambda (x2042 y2043) (if (equal? y2043 (quote (quote ()))) x2042 (list (quote append) x2042 y2043)))) (gen-cons2034 (lambda (x2044 y2045) (let ((t2046 (car y2045))) (if (memv t2046 (quote (quote))) (if (eq? (car x2044) (quote quote)) (list (quote quote) (cons (cadr x2044) (cadr y2045))) (if (eq? (cadr y2045) (quote ())) (list (quote list) x2044) (list (quote cons) x2044 y2045))) (if (memv t2046 (quote (list))) (cons (quote list) (cons x2044 (cdr y2045))) (list (quote cons) x2044 y2045)))))) (gen-map2033 (lambda (e2047 map-env2048) (let ((formals2049 (map cdr map-env2048)) (actuals2050 (map (lambda (x2051) (list (quote ref) (car x2051))) map-env2048))) (cond ((eq? (car e2047) (quote ref)) (car actuals2050)) ((andmap (lambda (x2052) (and (eq? (car x2052) (quote ref)) (memq (cadr x2052) formals2049))) (cdr e2047)) (cons (quote map) (cons (list (quote primitive) (car e2047)) (map (let ((r2053 (map cons formals2049 actuals2050))) (lambda (x2054) (cdr (assq (cadr x2054) r2053)))) (cdr e2047))))) (else (cons (quote map) (cons (list (quote lambda) formals2049 e2047) actuals2050))))))) (gen-mappend2032 (lambda (e2055 map-env2056) (list (quote apply) (quote (primitive append)) (gen-map2033 e2055 map-env2056)))) (gen-ref2031 (lambda (src2057 var2058 level2059 maps2060) (if (fx=1182 level2059 0) (values var2058 maps2060) (if (null? maps2060) (syntax-violation (quote syntax) "missing ellipsis" src2057) (call-with-values (lambda () (gen-ref2031 src2057 var2058 (fx-1181 level2059 1) (cdr maps2060))) (lambda (outer-var2061 outer-maps2062) (let ((b2063 (assq outer-var2061 (car maps2060)))) (if b2063 (values (cdr b2063) maps2060) (let ((inner-var2064 (gen-var1261 (quote tmp)))) (values inner-var2064 (cons (cons (cons outer-var2061 inner-var2064) (car maps2060)) outer-maps2062))))))))))) (gen-syntax2030 (lambda (src2065 e2066 r2067 maps2068 ellipsis?2069 mod2070) (if (id?1213 e2066) (let ((label2071 (id-var-name1235 e2066 (quote (()))))) (let ((b2072 (lookup1210 label2071 r2067 mod2070))) (if (eq? (binding-type1205 b2072) (quote syntax)) (call-with-values (lambda () (let ((var.lev2073 (binding-value1206 b2072))) (gen-ref2031 src2065 (car var.lev2073) (cdr var.lev2073) maps2068))) (lambda (var2074 maps2075) (values (list (quote ref) var2074) maps2075))) (if (ellipsis?2069 e2066) (syntax-violation (quote syntax) "misplaced ellipsis" src2065) (values (list (quote quote) e2066) maps2068))))) ((lambda (tmp2076) ((lambda (tmp2077) (if (if tmp2077 (apply (lambda (dots2078 e2079) (ellipsis?2069 dots2078)) tmp2077) #f) (apply (lambda (dots2080 e2081) (gen-syntax2030 src2065 e2081 r2067 maps2068 (lambda (x2082) #f) mod2070)) tmp2077) ((lambda (tmp2083) (if (if tmp2083 (apply (lambda (x2084 dots2085 y2086) (ellipsis?2069 dots2085)) tmp2083) #f) (apply (lambda (x2087 dots2088 y2089) (let f2090 ((y2091 y2089) (k2092 (lambda (maps2093) (call-with-values (lambda () (gen-syntax2030 src2065 x2087 r2067 (cons (quote ()) maps2093) ellipsis?2069 mod2070)) (lambda (x2094 maps2095) (if (null? (car maps2095)) (syntax-violation (quote syntax) "extra ellipsis" src2065) (values (gen-map2033 x2094 (car maps2095)) (cdr maps2095)))))))) ((lambda (tmp2096) ((lambda (tmp2097) (if (if tmp2097 (apply (lambda (dots2098 y2099) (ellipsis?2069 dots2098)) tmp2097) #f) (apply (lambda (dots2100 y2101) (f2090 y2101 (lambda (maps2102) (call-with-values (lambda () (k2092 (cons (quote ()) maps2102))) (lambda (x2103 maps2104) (if (null? (car maps2104)) (syntax-violation (quote syntax) "extra ellipsis" src2065) (values (gen-mappend2032 x2103 (car maps2104)) (cdr maps2104)))))))) tmp2097) ((lambda (_2105) (call-with-values (lambda () (gen-syntax2030 src2065 y2091 r2067 maps2068 ellipsis?2069 mod2070)) (lambda (y2106 maps2107) (call-with-values (lambda () (k2092 maps2107)) (lambda (x2108 maps2109) (values (gen-append2035 x2108 y2106) maps2109)))))) tmp2096))) (syntax-dispatch tmp2096 (quote (any . any))))) y2091))) tmp2083) ((lambda (tmp2110) (if tmp2110 (apply (lambda (x2111 y2112) (call-with-values (lambda () (gen-syntax2030 src2065 x2111 r2067 maps2068 ellipsis?2069 mod2070)) (lambda (x2113 maps2114) (call-with-values (lambda () (gen-syntax2030 src2065 y2112 r2067 maps2114 ellipsis?2069 mod2070)) (lambda (y2115 maps2116) (values (gen-cons2034 x2113 y2115) maps2116)))))) tmp2110) ((lambda (tmp2117) (if tmp2117 (apply (lambda (e12118 e22119) (call-with-values (lambda () (gen-syntax2030 src2065 (cons e12118 e22119) r2067 maps2068 ellipsis?2069 mod2070)) (lambda (e2121 maps2122) (values (gen-vector2036 e2121) maps2122)))) tmp2117) ((lambda (_2123) (values (list (quote quote) e2066) maps2068)) tmp2076))) (syntax-dispatch tmp2076 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp2076 (quote (any . any)))))) (syntax-dispatch tmp2076 (quote (any any . any)))))) (syntax-dispatch tmp2076 (quote (any any))))) e2066))))) (lambda (e2124 r2125 w2126 s2127 mod2128) (let ((e2129 (source-wrap1242 e2124 w2126 s2127 mod2128))) ((lambda (tmp2130) ((lambda (tmp2131) (if tmp2131 (apply (lambda (_2132 x2133) (call-with-values (lambda () (gen-syntax2030 e2129 x2133 r2125 (quote ()) ellipsis?1258 mod2128)) (lambda (e2134 maps2135) (regen2037 e2134)))) tmp2131) ((lambda (_2136) (syntax-violation (quote syntax) "bad `syntax' form" e2129)) tmp2130))) (syntax-dispatch tmp2130 (quote (any any))))) e2129))))) (global-extend1211 (quote core) (quote lambda) (lambda (e2137 r2138 w2139 s2140 mod2141) ((lambda (tmp2142) ((lambda (tmp2143) (if tmp2143 (apply (lambda (_2144 c2145) (chi-lambda-clause1254 (source-wrap1242 e2137 w2139 s2140 mod2141) #f c2145 r2138 w2139 mod2141 (lambda (vars2146 docstring2147 body2148) (build-annotated1190 s2140 (cons (quote lambda) (cons vars2146 (append (if docstring2147 (list docstring2147) (quote ())) (list body2148)))))))) tmp2143) (syntax-violation #f "source expression failed to match any pattern" tmp2142))) (syntax-dispatch tmp2142 (quote (any . any))))) e2137))) (global-extend1211 (quote core) (quote let) (letrec ((chi-let2149 (lambda (e2150 r2151 w2152 s2153 mod2154 constructor2155 ids2156 vals2157 exps2158) (if (not (valid-bound-ids?1238 ids2156)) (syntax-violation (quote let) "duplicate bound variable" e2150) (let ((labels2159 (gen-labels1219 ids2156)) (new-vars2160 (map gen-var1261 ids2156))) (let ((nw2161 (make-binding-wrap1230 ids2156 labels2159 w2152)) (nr2162 (extend-var-env1208 labels2159 new-vars2160 r2151))) (constructor2155 s2153 new-vars2160 (map (lambda (x2163) (chi1249 x2163 r2151 w2152 mod2154)) vals2157) (chi-body1253 exps2158 (source-wrap1242 e2150 nw2161 s2153 mod2154) nr2162 nw2161 mod2154)))))))) (lambda (e2164 r2165 w2166 s2167 mod2168) ((lambda (tmp2169) ((lambda (tmp2170) (if tmp2170 (apply (lambda (_2171 id2172 val2173 e12174 e22175) (chi-let2149 e2164 r2165 w2166 s2167 mod2168 build-let1193 id2172 val2173 (cons e12174 e22175))) tmp2170) ((lambda (tmp2179) (if (if tmp2179 (apply (lambda (_2180 f2181 id2182 val2183 e12184 e22185) (id?1213 f2181)) tmp2179) #f) (apply (lambda (_2186 f2187 id2188 val2189 e12190 e22191) (chi-let2149 e2164 r2165 w2166 s2167 mod2168 build-named-let1194 (cons f2187 id2188) val2189 (cons e12190 e22191))) tmp2179) ((lambda (_2195) (syntax-violation (quote let) "bad let" (source-wrap1242 e2164 w2166 s2167 mod2168))) tmp2169))) (syntax-dispatch tmp2169 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2169 (quote (any #(each (any any)) any . each-any))))) e2164)))) (global-extend1211 (quote core) (quote letrec) (lambda (e2196 r2197 w2198 s2199 mod2200) ((lambda (tmp2201) ((lambda (tmp2202) (if tmp2202 (apply (lambda (_2203 id2204 val2205 e12206 e22207) (let ((ids2208 id2204)) (if (not (valid-bound-ids?1238 ids2208)) (syntax-violation (quote letrec) "duplicate bound variable" e2196) (let ((labels2210 (gen-labels1219 ids2208)) (new-vars2211 (map gen-var1261 ids2208))) (let ((w2212 (make-binding-wrap1230 ids2208 labels2210 w2198)) (r2213 (extend-var-env1208 labels2210 new-vars2211 r2197))) (build-letrec1195 s2199 new-vars2211 (map (lambda (x2214) (chi1249 x2214 r2213 w2212 mod2200)) val2205) (chi-body1253 (cons e12206 e22207) (source-wrap1242 e2196 w2212 s2199 mod2200) r2213 w2212 mod2200))))))) tmp2202) ((lambda (_2217) (syntax-violation (quote letrec) "bad letrec" (source-wrap1242 e2196 w2198 s2199 mod2200))) tmp2201))) (syntax-dispatch tmp2201 (quote (any #(each (any any)) any . each-any))))) e2196))) (global-extend1211 (quote core) (quote set!) (lambda (e2218 r2219 w2220 s2221 mod2222) ((lambda (tmp2223) ((lambda (tmp2224) (if (if tmp2224 (apply (lambda (_2225 id2226 val2227) (id?1213 id2226)) tmp2224) #f) (apply (lambda (_2228 id2229 val2230) (let ((val2231 (chi1249 val2230 r2219 w2220 mod2222)) (n2232 (id-var-name1235 id2229 w2220))) (let ((b2233 (lookup1210 n2232 r2219 mod2222))) (let ((t2234 (binding-type1205 b2233))) (if (memv t2234 (quote (lexical))) (build-annotated1190 s2221 (list (quote set!) (binding-value1206 b2233) val2231)) (if (memv t2234 (quote (global))) (build-annotated1190 s2221 (list (quote set!) (if mod2222 (make-module-ref (cdr mod2222) n2232 (car mod2222)) (make-module-ref mod2222 n2232 (quote bare))) val2231)) (if (memv t2234 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1241 id2229 w2220 mod2222)) (syntax-violation (quote set!) "bad set!" (source-wrap1242 e2218 w2220 s2221 mod2222))))))))) tmp2224) ((lambda (tmp2235) (if tmp2235 (apply (lambda (_2236 head2237 tail2238 val2239) (call-with-values (lambda () (syntax-type1247 head2237 r2219 (quote (())) #f #f mod2222)) (lambda (type2240 value2241 ee2242 ww2243 ss2244 modmod2245) (let ((t2246 type2240)) (if (memv t2246 (quote (module-ref))) (let ((val2247 (chi1249 val2239 r2219 w2220 mod2222))) (call-with-values (lambda () (value2241 (cons head2237 tail2238))) (lambda (id2249 mod2250) (build-annotated1190 s2221 (list (quote set!) (if mod2250 (make-module-ref (cdr mod2250) id2249 (car mod2250)) (make-module-ref mod2250 id2249 (quote bare))) val2247))))) (build-annotated1190 s2221 (cons (chi1249 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2237) r2219 w2220 mod2222) (map (lambda (e2251) (chi1249 e2251 r2219 w2220 mod2222)) (append tail2238 (list val2239)))))))))) tmp2235) ((lambda (_2253) (syntax-violation (quote set!) "bad set!" (source-wrap1242 e2218 w2220 s2221 mod2222))) tmp2223))) (syntax-dispatch tmp2223 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2223 (quote (any any any))))) e2218))) (global-extend1211 (quote module-ref) (quote @) (lambda (e2254) ((lambda (tmp2255) ((lambda (tmp2256) (if (if tmp2256 (apply (lambda (_2257 mod2258 id2259) (and (andmap id?1213 mod2258) (id?1213 id2259))) tmp2256) #f) (apply (lambda (_2261 mod2262 id2263) (values (syntax-object->datum id2263) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2262)))) tmp2256) (syntax-violation #f "source expression failed to match any pattern" tmp2255))) (syntax-dispatch tmp2255 (quote (any each-any any))))) e2254))) (global-extend1211 (quote module-ref) (quote @@) (lambda (e2265) ((lambda (tmp2266) ((lambda (tmp2267) (if (if tmp2267 (apply (lambda (_2268 mod2269 id2270) (and (andmap id?1213 mod2269) (id?1213 id2270))) tmp2267) #f) (apply (lambda (_2272 mod2273 id2274) (values (syntax-object->datum id2274) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2273)))) tmp2267) (syntax-violation #f "source expression failed to match any pattern" tmp2266))) (syntax-dispatch tmp2266 (quote (any each-any any))))) e2265))) (global-extend1211 (quote begin) (quote begin) (quote ())) (global-extend1211 (quote define) (quote define) (quote ())) (global-extend1211 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1211 (quote eval-when) (quote eval-when) (quote ())) (global-extend1211 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2279 (lambda (x2280 keys2281 clauses2282 r2283 mod2284) (if (null? clauses2282) (build-annotated1190 #f (list (build-annotated1190 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2280)) ((lambda (tmp2285) ((lambda (tmp2286) (if tmp2286 (apply (lambda (pat2287 exp2288) (if (and (id?1213 pat2287) (andmap (lambda (x2289) (not (free-id=?1236 pat2287 x2289))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2281))) (let ((labels2290 (list (gen-label1218))) (var2291 (gen-var1261 pat2287))) (build-annotated1190 #f (list (build-annotated1190 #f (list (quote lambda) (list var2291) (chi1249 exp2288 (extend-env1207 labels2290 (list (cons (quote syntax) (cons var2291 0))) r2283) (make-binding-wrap1230 (list pat2287) labels2290 (quote (()))) mod2284))) x2280))) (gen-clause2278 x2280 keys2281 (cdr clauses2282) r2283 pat2287 #t exp2288 mod2284))) tmp2286) ((lambda (tmp2292) (if tmp2292 (apply (lambda (pat2293 fender2294 exp2295) (gen-clause2278 x2280 keys2281 (cdr clauses2282) r2283 pat2293 fender2294 exp2295 mod2284)) tmp2292) ((lambda (_2296) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2282))) tmp2285))) (syntax-dispatch tmp2285 (quote (any any any)))))) (syntax-dispatch tmp2285 (quote (any any))))) (car clauses2282))))) (gen-clause2278 (lambda (x2297 keys2298 clauses2299 r2300 pat2301 fender2302 exp2303 mod2304) (call-with-values (lambda () (convert-pattern2276 pat2301 keys2298)) (lambda (p2305 pvars2306) (cond ((not (distinct-bound-ids?1239 (map car pvars2306))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2301)) ((not (andmap (lambda (x2307) (not (ellipsis?1258 (car x2307)))) pvars2306)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2301)) (else (let ((y2308 (gen-var1261 (quote tmp)))) (build-annotated1190 #f (list (build-annotated1190 #f (list (quote lambda) (list y2308) (let ((y2309 (build-annotated1190 #f y2308))) (build-annotated1190 #f (list (quote if) ((lambda (tmp2310) ((lambda (tmp2311) (if tmp2311 (apply (lambda () y2309) tmp2311) ((lambda (_2312) (build-annotated1190 #f (list (quote if) y2309 (build-dispatch-call2277 pvars2306 fender2302 y2309 r2300 mod2304) (build-data1191 #f #f)))) tmp2310))) (syntax-dispatch tmp2310 (quote #(atom #t))))) fender2302) (build-dispatch-call2277 pvars2306 exp2303 y2309 r2300 mod2304) (gen-syntax-case2279 x2297 keys2298 clauses2299 r2300 mod2304)))))) (if (eq? p2305 (quote any)) (build-annotated1190 #f (list (build-annotated1190 #f (quote list)) x2297)) (build-annotated1190 #f (list (build-annotated1190 #f (quote syntax-dispatch)) x2297 (build-data1191 #f p2305))))))))))))) (build-dispatch-call2277 (lambda (pvars2313 exp2314 y2315 r2316 mod2317) (let ((ids2318 (map car pvars2313)) (levels2319 (map cdr pvars2313))) (let ((labels2320 (gen-labels1219 ids2318)) (new-vars2321 (map gen-var1261 ids2318))) (build-annotated1190 #f (list (build-annotated1190 #f (quote apply)) (build-annotated1190 #f (list (quote lambda) new-vars2321 (chi1249 exp2314 (extend-env1207 labels2320 (map (lambda (var2322 level2323) (cons (quote syntax) (cons var2322 level2323))) new-vars2321 (map cdr pvars2313)) r2316) (make-binding-wrap1230 ids2318 labels2320 (quote (()))) mod2317))) y2315)))))) (convert-pattern2276 (lambda (pattern2324 keys2325) (let cvt2326 ((p2327 pattern2324) (n2328 0) (ids2329 (quote ()))) (if (id?1213 p2327) (if (bound-id-member?1240 p2327 keys2325) (values (vector (quote free-id) p2327) ids2329) (values (quote any) (cons (cons p2327 n2328) ids2329))) ((lambda (tmp2330) ((lambda (tmp2331) (if (if tmp2331 (apply (lambda (x2332 dots2333) (ellipsis?1258 dots2333)) tmp2331) #f) (apply (lambda (x2334 dots2335) (call-with-values (lambda () (cvt2326 x2334 (fx+1180 n2328 1) ids2329)) (lambda (p2336 ids2337) (values (if (eq? p2336 (quote any)) (quote each-any) (vector (quote each) p2336)) ids2337)))) tmp2331) ((lambda (tmp2338) (if tmp2338 (apply (lambda (x2339 y2340) (call-with-values (lambda () (cvt2326 y2340 n2328 ids2329)) (lambda (y2341 ids2342) (call-with-values (lambda () (cvt2326 x2339 n2328 ids2342)) (lambda (x2343 ids2344) (values (cons x2343 y2341) ids2344)))))) tmp2338) ((lambda (tmp2345) (if tmp2345 (apply (lambda () (values (quote ()) ids2329)) tmp2345) ((lambda (tmp2346) (if tmp2346 (apply (lambda (x2347) (call-with-values (lambda () (cvt2326 x2347 n2328 ids2329)) (lambda (p2349 ids2350) (values (vector (quote vector) p2349) ids2350)))) tmp2346) ((lambda (x2351) (values (vector (quote atom) (strip1260 p2327 (quote (())))) ids2329)) tmp2330))) (syntax-dispatch tmp2330 (quote #(vector each-any)))))) (syntax-dispatch tmp2330 (quote ()))))) (syntax-dispatch tmp2330 (quote (any . any)))))) (syntax-dispatch tmp2330 (quote (any any))))) p2327)))))) (lambda (e2352 r2353 w2354 s2355 mod2356) (let ((e2357 (source-wrap1242 e2352 w2354 s2355 mod2356))) ((lambda (tmp2358) ((lambda (tmp2359) (if tmp2359 (apply (lambda (_2360 val2361 key2362 m2363) (if (andmap (lambda (x2364) (and (id?1213 x2364) (not (ellipsis?1258 x2364)))) key2362) (let ((x2366 (gen-var1261 (quote tmp)))) (build-annotated1190 s2355 (list (build-annotated1190 #f (list (quote lambda) (list x2366) (gen-syntax-case2279 (build-annotated1190 #f x2366) key2362 m2363 r2353 mod2356))) (chi1249 val2361 r2353 (quote (())) mod2356)))) (syntax-violation (quote syntax-case) "invalid literals list" e2357))) tmp2359) (syntax-violation #f "source expression failed to match any pattern" tmp2358))) (syntax-dispatch tmp2358 (quote (any any each-any . each-any))))) e2357))))) (set! sc-expand (let ((m2369 (quote e)) (esew2370 (quote (eval)))) (lambda (x2371) (if (and (pair? x2371) (equal? (car x2371) noexpand1179)) (cadr x2371) (chi-top1248 x2371 (quote ()) (quote ((top))) m2369 esew2370 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2372 (quote e)) (esew2373 (quote (eval)))) (lambda (x2375 . rest2374) (if (and (pair? x2375) (equal? (car x2375) noexpand1179)) (cadr x2375) (chi-top1248 x2375 (quote ()) (quote ((top))) (if (null? rest2374) m2372 (car rest2374)) (if (or (null? rest2374) (null? (cdr rest2374))) esew2373 (cadr rest2374)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2376) (nonsymbol-id?1212 x2376))) (set! datum->syntax-object (lambda (id2377 datum2378) (make-syntax-object1196 datum2378 (syntax-object-wrap1199 id2377) #f))) (set! syntax-object->datum (lambda (x2379) (strip1260 x2379 (quote (()))))) (set! generate-temporaries (lambda (ls2380) (begin (let ((x2381 ls2380)) (if (not (list? x2381)) (error-hook1186 (quote generate-temporaries) "invalid argument" x2381))) (map (lambda (x2382) (wrap1241 (gensym) (quote ((top))) #f)) ls2380)))) (set! free-identifier=? (lambda (x2383 y2384) (begin (let ((x2385 x2383)) (if (not (nonsymbol-id?1212 x2385)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2385))) (let ((x2386 y2384)) (if (not (nonsymbol-id?1212 x2386)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2386))) (free-id=?1236 x2383 y2384)))) (set! bound-identifier=? (lambda (x2387 y2388) (begin (let ((x2389 x2387)) (if (not (nonsymbol-id?1212 x2389)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2389))) (let ((x2390 y2388)) (if (not (nonsymbol-id?1212 x2390)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2390))) (bound-id=?1237 x2387 y2388)))) (set! syntax-violation (lambda (who2394 message2393 form2392 . subform2391) (begin (let ((x2395 who2394)) (if (not ((lambda (x2396) (or (not x2396) (string? x2396) (symbol? x2396))) x2395)) (error-hook1186 (quote syntax-violation) "invalid argument" x2395))) (let ((x2397 message2393)) (if (not (string? x2397)) (error-hook1186 (quote syntax-violation) "invalid argument" x2397))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2394 "~a: " "") "~a " (if (null? subform2391) "in ~a" "in subform `~s' of `~s'")) (let ((tail2398 (cons message2393 (map (lambda (x2399) (strip1260 x2399 (quote (())))) (append subform2391 (list form2392)))))) (if who2394 (cons who2394 tail2398) tail2398)) #f)))) (set! install-global-transformer (lambda (sym2400 v2401) (begin (let ((x2402 sym2400)) (if (not (symbol? x2402)) (error-hook1186 (quote define-syntax) "invalid argument" x2402))) (let ((x2403 v2401)) (if (not (procedure? x2403)) (error-hook1186 (quote define-syntax) "invalid argument" x2403))) (global-extend1211 (quote macro) sym2400 v2401)))) (letrec ((match2408 (lambda (e2409 p2410 w2411 r2412 mod2413) (cond ((not r2412) #f) ((eq? p2410 (quote any)) (cons (wrap1241 e2409 w2411 mod2413) r2412)) ((syntax-object?1197 e2409) (match*2407 (let ((e2414 (syntax-object-expression1198 e2409))) (if (annotation? e2414) (annotation-expression e2414) e2414)) p2410 (join-wraps1232 w2411 (syntax-object-wrap1199 e2409)) r2412 (syntax-object-module1200 e2409))) (else (match*2407 (let ((e2415 e2409)) (if (annotation? e2415) (annotation-expression e2415) e2415)) p2410 w2411 r2412 mod2413))))) (match*2407 (lambda (e2416 p2417 w2418 r2419 mod2420) (cond ((null? p2417) (and (null? e2416) r2419)) ((pair? p2417) (and (pair? e2416) (match2408 (car e2416) (car p2417) w2418 (match2408 (cdr e2416) (cdr p2417) w2418 r2419 mod2420) mod2420))) ((eq? p2417 (quote each-any)) (let ((l2421 (match-each-any2405 e2416 w2418 mod2420))) (and l2421 (cons l2421 r2419)))) (else (let ((t2422 (vector-ref p2417 0))) (if (memv t2422 (quote (each))) (if (null? e2416) (match-empty2406 (vector-ref p2417 1) r2419) (let ((l2423 (match-each2404 e2416 (vector-ref p2417 1) w2418 mod2420))) (and l2423 (let collect2424 ((l2425 l2423)) (if (null? (car l2425)) r2419 (cons (map car l2425) (collect2424 (map cdr l2425)))))))) (if (memv t2422 (quote (free-id))) (and (id?1213 e2416) (free-id=?1236 (wrap1241 e2416 w2418 mod2420) (vector-ref p2417 1)) r2419) (if (memv t2422 (quote (atom))) (and (equal? (vector-ref p2417 1) (strip1260 e2416 w2418)) r2419) (if (memv t2422 (quote (vector))) (and (vector? e2416) (match2408 (vector->list e2416) (vector-ref p2417 1) w2418 r2419 mod2420))))))))))) (match-empty2406 (lambda (p2426 r2427) (cond ((null? p2426) r2427) ((eq? p2426 (quote any)) (cons (quote ()) r2427)) ((pair? p2426) (match-empty2406 (car p2426) (match-empty2406 (cdr p2426) r2427))) ((eq? p2426 (quote each-any)) (cons (quote ()) r2427)) (else (let ((t2428 (vector-ref p2426 0))) (if (memv t2428 (quote (each))) (match-empty2406 (vector-ref p2426 1) r2427) (if (memv t2428 (quote (free-id atom))) r2427 (if (memv t2428 (quote (vector))) (match-empty2406 (vector-ref p2426 1) r2427))))))))) (match-each-any2405 (lambda (e2429 w2430 mod2431) (cond ((annotation? e2429) (match-each-any2405 (annotation-expression e2429) w2430 mod2431)) ((pair? e2429) (let ((l2432 (match-each-any2405 (cdr e2429) w2430 mod2431))) (and l2432 (cons (wrap1241 (car e2429) w2430 mod2431) l2432)))) ((null? e2429) (quote ())) ((syntax-object?1197 e2429) (match-each-any2405 (syntax-object-expression1198 e2429) (join-wraps1232 w2430 (syntax-object-wrap1199 e2429)) mod2431)) (else #f)))) (match-each2404 (lambda (e2433 p2434 w2435 mod2436) (cond ((annotation? e2433) (match-each2404 (annotation-expression e2433) p2434 w2435 mod2436)) ((pair? e2433) (let ((first2437 (match2408 (car e2433) p2434 w2435 (quote ()) mod2436))) (and first2437 (let ((rest2438 (match-each2404 (cdr e2433) p2434 w2435 mod2436))) (and rest2438 (cons first2437 rest2438)))))) ((null? e2433) (quote ())) ((syntax-object?1197 e2433) (match-each2404 (syntax-object-expression1198 e2433) p2434 (join-wraps1232 w2435 (syntax-object-wrap1199 e2433)) (syntax-object-module1200 e2433))) (else #f))))) (set! syntax-dispatch (lambda (e2439 p2440) (cond ((eq? p2440 (quote any)) (list e2439)) ((syntax-object?1197 e2439) (match*2407 (let ((e2441 (syntax-object-expression1198 e2439))) (if (annotation? e2441) (annotation-expression e2441) e2441)) p2440 (syntax-object-wrap1199 e2439) (quote ()) (syntax-object-module1200 e2439))) (else (match*2407 (let ((e2442 e2439)) (if (annotation? e2442) (annotation-expression e2442) e2442)) p2440 (quote (())) (quote ()) #f)))))))) -(install-global-transformer (quote with-syntax) (lambda (x2443) ((lambda (tmp2444) ((lambda (tmp2445) (if tmp2445 (apply (lambda (_2446 e12447 e22448) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12447 e22448))) tmp2445) ((lambda (tmp2450) (if tmp2450 (apply (lambda (_2451 out2452 in2453 e12454 e22455) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2453 (quote ()) (list out2452 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12454 e22455))))) tmp2450) ((lambda (tmp2457) (if tmp2457 (apply (lambda (_2458 out2459 in2460 e12461 e22462) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2460) (quote ()) (list out2459 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12461 e22462))))) tmp2457) (syntax-violation #f "source expression failed to match any pattern" tmp2444))) (syntax-dispatch tmp2444 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2444 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2444 (quote (any () any . each-any))))) x2443))) -(install-global-transformer (quote syntax-rules) (lambda (x2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda (_2469 k2470 keyword2471 pattern2472 template2473) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2470 (map (lambda (tmp2476 tmp2475) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2475) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2476))) template2473 pattern2472)))))) tmp2468) (syntax-violation #f "source expression failed to match any pattern" tmp2467))) (syntax-dispatch tmp2467 (quote (any each-any . #(each ((any . any) any))))))) x2466))) -(install-global-transformer (quote let*) (lambda (x2477) ((lambda (tmp2478) ((lambda (tmp2479) (if (if tmp2479 (apply (lambda (let*2480 x2481 v2482 e12483 e22484) (andmap identifier? x2481)) tmp2479) #f) (apply (lambda (let*2486 x2487 v2488 e12489 e22490) (let f2491 ((bindings2492 (map list x2487 v2488))) (if (null? bindings2492) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12489 e22490))) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (body2498 binding2499) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2499) body2498)) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) (syntax-dispatch tmp2496 (quote (any any))))) (list (f2491 (cdr bindings2492)) (car bindings2492)))))) tmp2479) (syntax-violation #f "source expression failed to match any pattern" tmp2478))) (syntax-dispatch tmp2478 (quote (any #(each (any any)) any . each-any))))) x2477))) -(install-global-transformer (quote do) (lambda (orig-x2500) ((lambda (tmp2501) ((lambda (tmp2502) (if tmp2502 (apply (lambda (_2503 var2504 init2505 step2506 e02507 e12508 c2509) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (step2512) ((lambda (tmp2513) ((lambda (tmp2514) (if tmp2514 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2514) ((lambda (tmp2519) (if tmp2519 (apply (lambda (e12520 e22521) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12520 e22521)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2519) (syntax-violation #f "source expression failed to match any pattern" tmp2513))) (syntax-dispatch tmp2513 (quote (any . each-any)))))) (syntax-dispatch tmp2513 (quote ())))) e12508)) tmp2511) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) (syntax-dispatch tmp2510 (quote each-any)))) (map (lambda (v2528 s2529) ((lambda (tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda () v2528) tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (e2533) e2533) tmp2532) ((lambda (_2534) (syntax-violation (quote do) "bad step expression" orig-x2500 s2529)) tmp2530))) (syntax-dispatch tmp2530 (quote (any)))))) (syntax-dispatch tmp2530 (quote ())))) s2529)) var2504 step2506))) tmp2502) (syntax-violation #f "source expression failed to match any pattern" tmp2501))) (syntax-dispatch tmp2501 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2500))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2537 (lambda (x2541 y2542) ((lambda (tmp2543) ((lambda (tmp2544) (if tmp2544 (apply (lambda (x2545 y2546) ((lambda (tmp2547) ((lambda (tmp2548) (if tmp2548 (apply (lambda (dy2549) ((lambda (tmp2550) ((lambda (tmp2551) (if tmp2551 (apply (lambda (dx2552) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2552 dy2549))) tmp2551) ((lambda (_2553) (if (null? dy2549) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546))) tmp2550))) (syntax-dispatch tmp2550 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2545)) tmp2548) ((lambda (tmp2554) (if tmp2554 (apply (lambda (stuff2555) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2545 stuff2555))) tmp2554) ((lambda (else2556) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546)) tmp2547))) (syntax-dispatch tmp2547 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2547 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2546)) tmp2544) (syntax-violation #f "source expression failed to match any pattern" tmp2543))) (syntax-dispatch tmp2543 (quote (any any))))) (list x2541 y2542)))) (quasiappend2538 (lambda (x2557 y2558) ((lambda (tmp2559) ((lambda (tmp2560) (if tmp2560 (apply (lambda (x2561 y2562) ((lambda (tmp2563) ((lambda (tmp2564) (if tmp2564 (apply (lambda () x2561) tmp2564) ((lambda (_2565) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2561 y2562)) tmp2563))) (syntax-dispatch tmp2563 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2562)) tmp2560) (syntax-violation #f "source expression failed to match any pattern" tmp2559))) (syntax-dispatch tmp2559 (quote (any any))))) (list x2557 y2558)))) (quasivector2539 (lambda (x2566) ((lambda (tmp2567) ((lambda (x2568) ((lambda (tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (x2571) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2571))) tmp2570) ((lambda (tmp2573) (if tmp2573 (apply (lambda (x2574) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2574)) tmp2573) ((lambda (_2576) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2568)) tmp2569))) (syntax-dispatch tmp2569 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2569 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2568)) tmp2567)) x2566))) (quasi2540 (lambda (p2577 lev2578) ((lambda (tmp2579) ((lambda (tmp2580) (if tmp2580 (apply (lambda (p2581) (if (= lev2578 0) p2581 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2581) (- lev2578 1))))) tmp2580) ((lambda (tmp2582) (if tmp2582 (apply (lambda (p2583 q2584) (if (= lev2578 0) (quasiappend2538 p2583 (quasi2540 q2584 lev2578)) (quasicons2537 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2583) (- lev2578 1))) (quasi2540 q2584 lev2578)))) tmp2582) ((lambda (tmp2585) (if tmp2585 (apply (lambda (p2586) (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2586) (+ lev2578 1)))) tmp2585) ((lambda (tmp2587) (if tmp2587 (apply (lambda (p2588 q2589) (quasicons2537 (quasi2540 p2588 lev2578) (quasi2540 q2589 lev2578))) tmp2587) ((lambda (tmp2590) (if tmp2590 (apply (lambda (x2591) (quasivector2539 (quasi2540 x2591 lev2578))) tmp2590) ((lambda (p2593) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2593)) tmp2579))) (syntax-dispatch tmp2579 (quote #(vector each-any)))))) (syntax-dispatch tmp2579 (quote (any . any)))))) (syntax-dispatch tmp2579 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2579 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2579 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2577)))) (lambda (x2594) ((lambda (tmp2595) ((lambda (tmp2596) (if tmp2596 (apply (lambda (_2597 e2598) (quasi2540 e2598 0)) tmp2596) (syntax-violation #f "source expression failed to match any pattern" tmp2595))) (syntax-dispatch tmp2595 (quote (any any))))) x2594)))) -(install-global-transformer (quote include) (lambda (x2599) (letrec ((read-file2600 (lambda (fn2601 k2602) (let ((p2603 (open-input-file fn2601))) (let f2604 ((x2605 (read p2603))) (if (eof-object? x2605) (begin (close-input-port p2603) (quote ())) (cons (datum->syntax-object k2602 x2605) (f2604 (read p2603))))))))) ((lambda (tmp2606) ((lambda (tmp2607) (if tmp2607 (apply (lambda (k2608 filename2609) (let ((fn2610 (syntax-object->datum filename2609))) ((lambda (tmp2611) ((lambda (tmp2612) (if tmp2612 (apply (lambda (exp2613) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2613)) tmp2612) (syntax-violation #f "source expression failed to match any pattern" tmp2611))) (syntax-dispatch tmp2611 (quote each-any)))) (read-file2600 fn2610 k2608)))) tmp2607) (syntax-violation #f "source expression failed to match any pattern" tmp2606))) (syntax-dispatch tmp2606 (quote (any any))))) x2599)))) -(install-global-transformer (quote unquote) (lambda (x2615) ((lambda (tmp2616) ((lambda (tmp2617) (if tmp2617 (apply (lambda (_2618 e2619) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2619))) tmp2617) (syntax-violation #f "source expression failed to match any pattern" tmp2616))) (syntax-dispatch tmp2616 (quote (any any))))) x2615))) -(install-global-transformer (quote unquote-splicing) (lambda (x2620) ((lambda (tmp2621) ((lambda (tmp2622) (if tmp2622 (apply (lambda (_2623 e2624) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2624))) tmp2622) (syntax-violation #f "source expression failed to match any pattern" tmp2621))) (syntax-dispatch tmp2621 (quote (any any))))) x2620))) -(install-global-transformer (quote case) (lambda (x2625) ((lambda (tmp2626) ((lambda (tmp2627) (if tmp2627 (apply (lambda (_2628 e2629 m12630 m22631) ((lambda (tmp2632) ((lambda (body2633) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2629)) body2633)) tmp2632)) (let f2634 ((clause2635 m12630) (clauses2636 m22631)) (if (null? clauses2636) ((lambda (tmp2638) ((lambda (tmp2639) (if tmp2639 (apply (lambda (e12640 e22641) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12640 e22641))) tmp2639) ((lambda (tmp2643) (if tmp2643 (apply (lambda (k2644 e12645 e22646) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2644)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12645 e22646)))) tmp2643) ((lambda (_2649) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2638))) (syntax-dispatch tmp2638 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2638 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2635) ((lambda (tmp2650) ((lambda (rest2651) ((lambda (tmp2652) ((lambda (tmp2653) (if tmp2653 (apply (lambda (k2654 e12655 e22656) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2654)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12655 e22656)) rest2651)) tmp2653) ((lambda (_2659) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2652))) (syntax-dispatch tmp2652 (quote (each-any any . each-any))))) clause2635)) tmp2650)) (f2634 (car clauses2636) (cdr clauses2636))))))) tmp2627) (syntax-violation #f "source expression failed to match any pattern" tmp2626))) (syntax-dispatch tmp2626 (quote (any any any . each-any))))) x2625))) -(install-global-transformer (quote identifier-syntax) (lambda (x2660) ((lambda (tmp2661) ((lambda (tmp2662) (if tmp2662 (apply (lambda (_2663 e2664) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2664)) (list (cons _2663 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2664 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2662) (syntax-violation #f "source expression failed to match any pattern" tmp2661))) (syntax-dispatch tmp2661 (quote (any any))))) x2660))) +(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) (syntax-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) (syntax-dispatch tmp1393 (quote (any any . each-any)))))) (syntax-dispatch tmp1393 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) (syntax-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) (syntax-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) (syntax-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) (syntax-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) (syntax-dispatch tmp1563 (quote (any any . each-any)))))) (syntax-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) (syntax-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) (syntax-dispatch tmp1612 (quote (any any)))))) (syntax-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) (syntax-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) (syntax-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) (syntax-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) (syntax-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) (syntax-dispatch tmp1946 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1946 (quote (any . any)))))) (syntax-dispatch tmp1946 (quote (any any . any)))))) (syntax-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) (syntax-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) (syntax-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) (syntax-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) (syntax-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) (syntax-dispatch tmp2093 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) (syntax-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) (syntax-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) (syntax-dispatch tmp2155 (quote (any any any)))))) (syntax-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) (syntax-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) (syntax-dispatch tmp2200 (quote #(vector each-any)))))) (syntax-dispatch tmp2200 (quote ()))))) (syntax-dispatch tmp2200 (quote (any . any)))))) (syntax-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) (syntax-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! syntax-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) +(install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2323 (quote ()) (list out2322 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda (tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2330) (quote ()) (list out2329 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source expression failed to match any pattern" tmp2314))) (syntax-dispatch tmp2314 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2314 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2314 (quote (any () any . each-any))))) x2313))) +(install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda (tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340 keyword2341 pattern2342 template2343) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346 tmp2345) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2345) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source expression failed to match any pattern" tmp2337))) (syntax-dispatch tmp2337 (quote (any each-any . #(each ((any . any) any))))))) x2336))) +(install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357 v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if (null? bindings2362) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply (lambda (body2368 binding2369) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2369) body2368)) tmp2367) (syntax-violation #f "source expression failed to match any pattern" tmp2366))) (syntax-dispatch tmp2366 (quote (any any))))) (list (f2361 (cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f "source expression failed to match any pattern" tmp2348))) (syntax-dispatch tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347))) +(install-global-transformer (quote do) (lambda (orig-x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 var2374 init2375 step2376 e02377 e12378 c2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply (lambda (step2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2384) ((lambda (tmp2389) (if tmp2389 (apply (lambda (e12390 e22391) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12390 e22391)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2389) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) (syntax-dispatch tmp2383 (quote (any . each-any)))))) (syntax-dispatch tmp2383 (quote ())))) e12378)) tmp2381) (syntax-violation #f "source expression failed to match any pattern" tmp2380))) (syntax-dispatch tmp2380 (quote each-any)))) (map (lambda (v2398 s2399) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply (lambda () v2398) tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (e2403) e2403) tmp2402) ((lambda (_2404) (syntax-violation (quote do) "bad step expression" orig-x2370 s2399)) tmp2400))) (syntax-dispatch tmp2400 (quote (any)))))) (syntax-dispatch tmp2400 (quote ())))) s2399)) var2374 step2376))) tmp2372) (syntax-violation #f "source expression failed to match any pattern" tmp2371))) (syntax-dispatch tmp2371 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2370))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2407 (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (dy2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dx2422) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2422 dy2419))) tmp2421) ((lambda (_2423) (if (null? dy2419) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416))) tmp2420))) (syntax-dispatch tmp2420 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2415)) tmp2418) ((lambda (tmp2424) (if tmp2424 (apply (lambda (stuff2425) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2415 stuff2425))) tmp2424) ((lambda (else2426) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416)) tmp2417))) (syntax-dispatch tmp2417 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2417 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2416)) tmp2414) (syntax-violation #f "source expression failed to match any pattern" tmp2413))) (syntax-dispatch tmp2413 (quote (any any))))) (list x2411 y2412)))) (quasiappend2408 (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () x2431) tmp2434) ((lambda (_2435) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2431 y2432)) tmp2433))) (syntax-dispatch tmp2433 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2432)) tmp2430) (syntax-violation #f "source expression failed to match any pattern" tmp2429))) (syntax-dispatch tmp2429 (quote (any any))))) (list x2427 y2428)))) (quasivector2409 (lambda (x2436) ((lambda (tmp2437) ((lambda (x2438) ((lambda (tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (x2441) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2441))) tmp2440) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2444)) tmp2443) ((lambda (_2446) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2438)) tmp2439))) (syntax-dispatch tmp2439 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2439 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2438)) tmp2437)) x2436))) (quasi2410 (lambda (p2447 lev2448) ((lambda (tmp2449) ((lambda (tmp2450) (if tmp2450 (apply (lambda (p2451) (if (= lev2448 0) p2451 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2451) (- lev2448 1))))) tmp2450) ((lambda (tmp2452) (if tmp2452 (apply (lambda (p2453 q2454) (if (= lev2448 0) (quasiappend2408 p2453 (quasi2410 q2454 lev2448)) (quasicons2407 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2453) (- lev2448 1))) (quasi2410 q2454 lev2448)))) tmp2452) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456) (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2456) (+ lev2448 1)))) tmp2455) ((lambda (tmp2457) (if tmp2457 (apply (lambda (p2458 q2459) (quasicons2407 (quasi2410 p2458 lev2448) (quasi2410 q2459 lev2448))) tmp2457) ((lambda (tmp2460) (if tmp2460 (apply (lambda (x2461) (quasivector2409 (quasi2410 x2461 lev2448))) tmp2460) ((lambda (p2463) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2463)) tmp2449))) (syntax-dispatch tmp2449 (quote #(vector each-any)))))) (syntax-dispatch tmp2449 (quote (any . any)))))) (syntax-dispatch tmp2449 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2449 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2449 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2447)))) (lambda (x2464) ((lambda (tmp2465) ((lambda (tmp2466) (if tmp2466 (apply (lambda (_2467 e2468) (quasi2410 e2468 0)) tmp2466) (syntax-violation #f "source expression failed to match any pattern" tmp2465))) (syntax-dispatch tmp2465 (quote (any any))))) x2464)))) +(install-global-transformer (quote include) (lambda (x2469) (letrec ((read-file2470 (lambda (fn2471 k2472) (let ((p2473 (open-input-file fn2471))) (let f2474 ((x2475 (read p2473))) (if (eof-object? x2475) (begin (close-input-port p2473) (quote ())) (cons (datum->syntax k2472 x2475) (f2474 (read p2473))))))))) ((lambda (tmp2476) ((lambda (tmp2477) (if tmp2477 (apply (lambda (k2478 filename2479) (let ((fn2480 (syntax->datum filename2479))) ((lambda (tmp2481) ((lambda (tmp2482) (if tmp2482 (apply (lambda (exp2483) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2483)) tmp2482) (syntax-violation #f "source expression failed to match any pattern" tmp2481))) (syntax-dispatch tmp2481 (quote each-any)))) (read-file2470 fn2480 k2478)))) tmp2477) (syntax-violation #f "source expression failed to match any pattern" tmp2476))) (syntax-dispatch tmp2476 (quote (any any))))) x2469)))) +(install-global-transformer (quote unquote) (lambda (x2485) ((lambda (tmp2486) ((lambda (tmp2487) (if tmp2487 (apply (lambda (_2488 e2489) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2489))) tmp2487) (syntax-violation #f "source expression failed to match any pattern" tmp2486))) (syntax-dispatch tmp2486 (quote (any any))))) x2485))) +(install-global-transformer (quote unquote-splicing) (lambda (x2490) ((lambda (tmp2491) ((lambda (tmp2492) (if tmp2492 (apply (lambda (_2493 e2494) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2494))) tmp2492) (syntax-violation #f "source expression failed to match any pattern" tmp2491))) (syntax-dispatch tmp2491 (quote (any any))))) x2490))) +(install-global-transformer (quote case) (lambda (x2495) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (_2498 e2499 m12500 m22501) ((lambda (tmp2502) ((lambda (body2503) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2499)) body2503)) tmp2502)) (let f2504 ((clause2505 m12500) (clauses2506 m22501)) (if (null? clauses2506) ((lambda (tmp2508) ((lambda (tmp2509) (if tmp2509 (apply (lambda (e12510 e22511) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12510 e22511))) tmp2509) ((lambda (tmp2513) (if tmp2513 (apply (lambda (k2514 e12515 e22516) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2514)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12515 e22516)))) tmp2513) ((lambda (_2519) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2508))) (syntax-dispatch tmp2508 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2508 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2505) ((lambda (tmp2520) ((lambda (rest2521) ((lambda (tmp2522) ((lambda (tmp2523) (if tmp2523 (apply (lambda (k2524 e12525 e22526) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2524)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12525 e22526)) rest2521)) tmp2523) ((lambda (_2529) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2522))) (syntax-dispatch tmp2522 (quote (each-any any . each-any))))) clause2505)) tmp2520)) (f2504 (car clauses2506) (cdr clauses2506))))))) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) (syntax-dispatch tmp2496 (quote (any any any . each-any))))) x2495))) +(install-global-transformer (quote identifier-syntax) (lambda (x2530) ((lambda (tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2534)) (list (cons _2533 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2534 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2532) (syntax-violation #f "source expression failed to match any pattern" tmp2531))) (syntax-dispatch tmp2531 (quote (any any))))) x2530))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 89701bc19..347a776ee 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -49,7 +49,7 @@ ;;; also documented in the R4RS and draft R5RS. ;;; ;;; bound-identifier=? -;;; datum->syntax-object +;;; datum->syntax ;;; define-syntax ;;; fluid-let-syntax ;;; free-identifier=? @@ -60,7 +60,7 @@ ;;; letrec-syntax ;;; syntax ;;; syntax-case -;;; syntax-object->datum +;;; syntax->datum ;;; syntax-rules ;;; with-syntax ;;; @@ -209,7 +209,7 @@ ;;; Objects with no standard print syntax, including objects containing ;;; cycles and syntax object, are allowed in quoted data as long as they -;;; are contained within a syntax form or produced by datum->syntax-object. +;;; are contained within a syntax form or produced by datum->syntax. ;;; Such objects are never copied. ;;; All identifiers that don't have macro definitions and are not bound @@ -264,14 +264,14 @@ (lambda (x) (define construct-name (lambda (template-identifier . args) - (datum->syntax-object + (datum->syntax template-identifier (string->symbol (apply string-append (map (lambda (x) (if (string? x) x - (symbol->string (syntax-object->datum x)))) + (symbol->string (syntax->datum x)))) args)))))) (syntax-case x () ((_ (name id1 ...)) @@ -1351,7 +1351,7 @@ (lambda (e docstring c r w mod k) (syntax-case c () ((args doc e1 e2 ...) - (and (string? (syntax-object->datum (syntax doc))) (not docstring)) + (and (string? (syntax->datum (syntax doc))) (not docstring)) (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k)) (((id ...) e1 e2 ...) (let ((ids (syntax (id ...)))) @@ -1814,8 +1814,8 @@ (syntax-case e () ((_ (mod ...) id) (and (andmap id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax-object->datum (syntax id)) - (syntax-object->datum + (values (syntax->datum (syntax id)) + (syntax->datum (syntax (public mod ...)))))))) (global-extend 'module-ref '@@ @@ -1823,8 +1823,8 @@ (syntax-case e () ((_ (mod ...) id) (and (andmap id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax-object->datum (syntax id)) - (syntax-object->datum + (values (syntax->datum (syntax id)) + (syntax->datum (syntax (private mod ...)))))))) (global-extend 'begin 'begin '()) @@ -2004,11 +2004,11 @@ (lambda (x) (nonsymbol-id? x))) -(set! datum->syntax-object +(set! datum->syntax (lambda (id datum) (make-syntax-object datum (syntax-object-wrap id) #f))) -(set! syntax-object->datum +(set! syntax->datum ; accepts any object, since syntax objects may consist partially ; or entirely of unwrapped, nonsymbolic data (lambda (x) @@ -2292,11 +2292,11 @@ (let f ((x (read p))) (if (eof-object? x) (begin (close-input-port p) '()) - (cons (datum->syntax-object k x) + (cons (datum->syntax k x) (f (read p)))))))) (syntax-case x () ((k filename) - (let ((fn (syntax-object->datum (syntax filename)))) + (let ((fn (syntax->datum (syntax filename)))) (with-syntax (((exp ...) (read-file fn (syntax k)))) (syntax (begin exp ...)))))))) @@ -2306,7 +2306,7 @@ ((_ e) (error 'unquote "expression ,~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + (syntax->datum (syntax e))))))) (define-syntax unquote-splicing (lambda (x) @@ -2314,7 +2314,7 @@ ((_ e) (error 'unquote-splicing "expression ,@~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + (syntax->datum (syntax e))))))) (define-syntax case (lambda (x) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 873e4b831..f84af33fc 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -241,8 +241,8 @@ (lambda (x) (syntax-case x () ((_ (k arg rest ...) out ...) - (keyword? (syntax-object->datum (syntax k))) - (case (syntax-object->datum (syntax k)) + (keyword? (syntax->datum (syntax k))) + (case (syntax->datum (syntax k)) ((#:getter #:setter) (syntax (define-class-pre-definition (rest ...) @@ -277,7 +277,7 @@ ((_ () out ...) (syntax (begin out ...))) ((_ (slot rest ...) out ...) - (keyword? (syntax-object->datum (syntax slot))) + (keyword? (syntax->datum (syntax slot))) (syntax (begin out ...))) ((_ (slot rest ...) out ...) (identifier? (syntax slot)) From bac0272216e89fa93bc935952befe0e7973625f7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 20:57:51 +0200 Subject: [PATCH 083/375] build ecmascript stuff last * module/Makefile.am: Wait to build ecmascript until the compiler has bootstrapped. --- module/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/Makefile.am b/module/Makefile.am index baa91b9af..9cda51aac 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -37,7 +37,7 @@ SOURCES = \ \ language/ghil.scm language/glil.scm language/assembly.scm \ \ - $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \ + $(SCHEME_LANG_SOURCES) \ $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ @@ -46,6 +46,7 @@ SOURCES = \ $(SRFI_SOURCES) \ $(OOP_SOURCES) \ $(SYSTEM_SOURCES) \ + $(ECMASCRIPT_LANG_SOURCES) \ $(SCRIPTS_SOURCES) ## test.scm is not currently installed. From 5f1a2fb10f5eb97e302c50f5b62d6df28f73d97a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 21:10:24 +0200 Subject: [PATCH 084/375] syntax-dispatch -> $sc-dispatch * module/ice-9/boot-9.scm: * module/ice-9/psyntax-pp.scm: * module/ice-9/psyntax.scm: Change syntax-dispatch to $sc-dispatch, as it is in current psyntax. The idea is that this isn't really a public variable, though it has to be, currently, so just obscure that fact with an obscure name. --- module/ice-9/boot-9.scm | 2 +- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 10 +++++----- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index b2b1f65cd..44f5f020e 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -183,7 +183,7 @@ (define sc-expand #f) (define sc-expand3 #f) (define install-global-transformer #f) -(define syntax-dispatch #f) +(define $sc-dispatch #f) (define syntax-violation #f) (define (annotation? x) #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index f17823484..31066c3f2 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) (syntax-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) (syntax-dispatch tmp1393 (quote (any any . each-any)))))) (syntax-dispatch tmp1393 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) (syntax-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) (syntax-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) (syntax-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) (syntax-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) (syntax-dispatch tmp1563 (quote (any any . each-any)))))) (syntax-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) (syntax-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) (syntax-dispatch tmp1612 (quote (any any)))))) (syntax-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) (syntax-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) (syntax-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) (syntax-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) (syntax-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) (syntax-dispatch tmp1946 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1946 (quote (any . any)))))) (syntax-dispatch tmp1946 (quote (any any . any)))))) (syntax-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) (syntax-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) (syntax-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) (syntax-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) (syntax-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) (syntax-dispatch tmp2093 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) (syntax-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) (syntax-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) (syntax-dispatch tmp2155 (quote (any any any)))))) (syntax-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) (syntax-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) (syntax-dispatch tmp2200 (quote #(vector each-any)))))) (syntax-dispatch tmp2200 (quote ()))))) (syntax-dispatch tmp2200 (quote (any . any)))))) (syntax-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) (syntax-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! syntax-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) -(install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2323 (quote ()) (list out2322 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda (tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2330) (quote ()) (list out2329 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source expression failed to match any pattern" tmp2314))) (syntax-dispatch tmp2314 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2314 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2314 (quote (any () any . each-any))))) x2313))) -(install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda (tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340 keyword2341 pattern2342 template2343) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346 tmp2345) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2345) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source expression failed to match any pattern" tmp2337))) (syntax-dispatch tmp2337 (quote (any each-any . #(each ((any . any) any))))))) x2336))) -(install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357 v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if (null? bindings2362) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply (lambda (body2368 binding2369) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2369) body2368)) tmp2367) (syntax-violation #f "source expression failed to match any pattern" tmp2366))) (syntax-dispatch tmp2366 (quote (any any))))) (list (f2361 (cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f "source expression failed to match any pattern" tmp2348))) (syntax-dispatch tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347))) -(install-global-transformer (quote do) (lambda (orig-x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 var2374 init2375 step2376 e02377 e12378 c2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply (lambda (step2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2384) ((lambda (tmp2389) (if tmp2389 (apply (lambda (e12390 e22391) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12390 e22391)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2389) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) (syntax-dispatch tmp2383 (quote (any . each-any)))))) (syntax-dispatch tmp2383 (quote ())))) e12378)) tmp2381) (syntax-violation #f "source expression failed to match any pattern" tmp2380))) (syntax-dispatch tmp2380 (quote each-any)))) (map (lambda (v2398 s2399) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply (lambda () v2398) tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (e2403) e2403) tmp2402) ((lambda (_2404) (syntax-violation (quote do) "bad step expression" orig-x2370 s2399)) tmp2400))) (syntax-dispatch tmp2400 (quote (any)))))) (syntax-dispatch tmp2400 (quote ())))) s2399)) var2374 step2376))) tmp2372) (syntax-violation #f "source expression failed to match any pattern" tmp2371))) (syntax-dispatch tmp2371 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2370))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2407 (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (dy2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dx2422) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2422 dy2419))) tmp2421) ((lambda (_2423) (if (null? dy2419) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416))) tmp2420))) (syntax-dispatch tmp2420 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2415)) tmp2418) ((lambda (tmp2424) (if tmp2424 (apply (lambda (stuff2425) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2415 stuff2425))) tmp2424) ((lambda (else2426) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416)) tmp2417))) (syntax-dispatch tmp2417 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2417 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2416)) tmp2414) (syntax-violation #f "source expression failed to match any pattern" tmp2413))) (syntax-dispatch tmp2413 (quote (any any))))) (list x2411 y2412)))) (quasiappend2408 (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () x2431) tmp2434) ((lambda (_2435) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2431 y2432)) tmp2433))) (syntax-dispatch tmp2433 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2432)) tmp2430) (syntax-violation #f "source expression failed to match any pattern" tmp2429))) (syntax-dispatch tmp2429 (quote (any any))))) (list x2427 y2428)))) (quasivector2409 (lambda (x2436) ((lambda (tmp2437) ((lambda (x2438) ((lambda (tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (x2441) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2441))) tmp2440) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2444)) tmp2443) ((lambda (_2446) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2438)) tmp2439))) (syntax-dispatch tmp2439 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2439 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2438)) tmp2437)) x2436))) (quasi2410 (lambda (p2447 lev2448) ((lambda (tmp2449) ((lambda (tmp2450) (if tmp2450 (apply (lambda (p2451) (if (= lev2448 0) p2451 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2451) (- lev2448 1))))) tmp2450) ((lambda (tmp2452) (if tmp2452 (apply (lambda (p2453 q2454) (if (= lev2448 0) (quasiappend2408 p2453 (quasi2410 q2454 lev2448)) (quasicons2407 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2453) (- lev2448 1))) (quasi2410 q2454 lev2448)))) tmp2452) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456) (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2456) (+ lev2448 1)))) tmp2455) ((lambda (tmp2457) (if tmp2457 (apply (lambda (p2458 q2459) (quasicons2407 (quasi2410 p2458 lev2448) (quasi2410 q2459 lev2448))) tmp2457) ((lambda (tmp2460) (if tmp2460 (apply (lambda (x2461) (quasivector2409 (quasi2410 x2461 lev2448))) tmp2460) ((lambda (p2463) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2463)) tmp2449))) (syntax-dispatch tmp2449 (quote #(vector each-any)))))) (syntax-dispatch tmp2449 (quote (any . any)))))) (syntax-dispatch tmp2449 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2449 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2449 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2447)))) (lambda (x2464) ((lambda (tmp2465) ((lambda (tmp2466) (if tmp2466 (apply (lambda (_2467 e2468) (quasi2410 e2468 0)) tmp2466) (syntax-violation #f "source expression failed to match any pattern" tmp2465))) (syntax-dispatch tmp2465 (quote (any any))))) x2464)))) -(install-global-transformer (quote include) (lambda (x2469) (letrec ((read-file2470 (lambda (fn2471 k2472) (let ((p2473 (open-input-file fn2471))) (let f2474 ((x2475 (read p2473))) (if (eof-object? x2475) (begin (close-input-port p2473) (quote ())) (cons (datum->syntax k2472 x2475) (f2474 (read p2473))))))))) ((lambda (tmp2476) ((lambda (tmp2477) (if tmp2477 (apply (lambda (k2478 filename2479) (let ((fn2480 (syntax->datum filename2479))) ((lambda (tmp2481) ((lambda (tmp2482) (if tmp2482 (apply (lambda (exp2483) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2483)) tmp2482) (syntax-violation #f "source expression failed to match any pattern" tmp2481))) (syntax-dispatch tmp2481 (quote each-any)))) (read-file2470 fn2480 k2478)))) tmp2477) (syntax-violation #f "source expression failed to match any pattern" tmp2476))) (syntax-dispatch tmp2476 (quote (any any))))) x2469)))) -(install-global-transformer (quote unquote) (lambda (x2485) ((lambda (tmp2486) ((lambda (tmp2487) (if tmp2487 (apply (lambda (_2488 e2489) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2489))) tmp2487) (syntax-violation #f "source expression failed to match any pattern" tmp2486))) (syntax-dispatch tmp2486 (quote (any any))))) x2485))) -(install-global-transformer (quote unquote-splicing) (lambda (x2490) ((lambda (tmp2491) ((lambda (tmp2492) (if tmp2492 (apply (lambda (_2493 e2494) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2494))) tmp2492) (syntax-violation #f "source expression failed to match any pattern" tmp2491))) (syntax-dispatch tmp2491 (quote (any any))))) x2490))) -(install-global-transformer (quote case) (lambda (x2495) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (_2498 e2499 m12500 m22501) ((lambda (tmp2502) ((lambda (body2503) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2499)) body2503)) tmp2502)) (let f2504 ((clause2505 m12500) (clauses2506 m22501)) (if (null? clauses2506) ((lambda (tmp2508) ((lambda (tmp2509) (if tmp2509 (apply (lambda (e12510 e22511) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12510 e22511))) tmp2509) ((lambda (tmp2513) (if tmp2513 (apply (lambda (k2514 e12515 e22516) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2514)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12515 e22516)))) tmp2513) ((lambda (_2519) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2508))) (syntax-dispatch tmp2508 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2508 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2505) ((lambda (tmp2520) ((lambda (rest2521) ((lambda (tmp2522) ((lambda (tmp2523) (if tmp2523 (apply (lambda (k2524 e12525 e22526) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2524)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12525 e22526)) rest2521)) tmp2523) ((lambda (_2529) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2522))) (syntax-dispatch tmp2522 (quote (each-any any . each-any))))) clause2505)) tmp2520)) (f2504 (car clauses2506) (cdr clauses2506))))))) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) (syntax-dispatch tmp2496 (quote (any any any . each-any))))) x2495))) -(install-global-transformer (quote identifier-syntax) (lambda (x2530) ((lambda (tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2534)) (list (cons _2533 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2534 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2532) (syntax-violation #f "source expression failed to match any pattern" tmp2531))) (syntax-dispatch tmp2531 (quote (any any))))) x2530))) +(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) ($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any . each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) ($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) ($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any)))))) ($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) ($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) ($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) ($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) ($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) ($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) ($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote $sc-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any)))))) ($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any . any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) ($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) +(install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2323 (quote ()) (list out2322 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda (tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2330) (quote ()) (list out2329 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source expression failed to match any pattern" tmp2314))) ($sc-dispatch tmp2314 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any () any . each-any))))) x2313))) +(install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda (tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340 keyword2341 pattern2342 template2343) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346 tmp2345) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2345) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source expression failed to match any pattern" tmp2337))) ($sc-dispatch tmp2337 (quote (any each-any . #(each ((any . any) any))))))) x2336))) +(install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357 v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if (null? bindings2362) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply (lambda (body2368 binding2369) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2369) body2368)) tmp2367) (syntax-violation #f "source expression failed to match any pattern" tmp2366))) ($sc-dispatch tmp2366 (quote (any any))))) (list (f2361 (cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f "source expression failed to match any pattern" tmp2348))) ($sc-dispatch tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347))) +(install-global-transformer (quote do) (lambda (orig-x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 var2374 init2375 step2376 e02377 e12378 c2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply (lambda (step2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2384) ((lambda (tmp2389) (if tmp2389 (apply (lambda (e12390 e22391) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12390 e22391)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2389) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) ($sc-dispatch tmp2383 (quote (any . each-any)))))) ($sc-dispatch tmp2383 (quote ())))) e12378)) tmp2381) (syntax-violation #f "source expression failed to match any pattern" tmp2380))) ($sc-dispatch tmp2380 (quote each-any)))) (map (lambda (v2398 s2399) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply (lambda () v2398) tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (e2403) e2403) tmp2402) ((lambda (_2404) (syntax-violation (quote do) "bad step expression" orig-x2370 s2399)) tmp2400))) ($sc-dispatch tmp2400 (quote (any)))))) ($sc-dispatch tmp2400 (quote ())))) s2399)) var2374 step2376))) tmp2372) (syntax-violation #f "source expression failed to match any pattern" tmp2371))) ($sc-dispatch tmp2371 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2370))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2407 (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (dy2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dx2422) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2422 dy2419))) tmp2421) ((lambda (_2423) (if (null? dy2419) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416))) tmp2420))) ($sc-dispatch tmp2420 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2415)) tmp2418) ((lambda (tmp2424) (if tmp2424 (apply (lambda (stuff2425) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2415 stuff2425))) tmp2424) ((lambda (else2426) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416)) tmp2417))) ($sc-dispatch tmp2417 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2417 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2416)) tmp2414) (syntax-violation #f "source expression failed to match any pattern" tmp2413))) ($sc-dispatch tmp2413 (quote (any any))))) (list x2411 y2412)))) (quasiappend2408 (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () x2431) tmp2434) ((lambda (_2435) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2431 y2432)) tmp2433))) ($sc-dispatch tmp2433 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2432)) tmp2430) (syntax-violation #f "source expression failed to match any pattern" tmp2429))) ($sc-dispatch tmp2429 (quote (any any))))) (list x2427 y2428)))) (quasivector2409 (lambda (x2436) ((lambda (tmp2437) ((lambda (x2438) ((lambda (tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (x2441) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2441))) tmp2440) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2444)) tmp2443) ((lambda (_2446) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2438)) tmp2439))) ($sc-dispatch tmp2439 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2439 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2438)) tmp2437)) x2436))) (quasi2410 (lambda (p2447 lev2448) ((lambda (tmp2449) ((lambda (tmp2450) (if tmp2450 (apply (lambda (p2451) (if (= lev2448 0) p2451 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2451) (- lev2448 1))))) tmp2450) ((lambda (tmp2452) (if tmp2452 (apply (lambda (p2453 q2454) (if (= lev2448 0) (quasiappend2408 p2453 (quasi2410 q2454 lev2448)) (quasicons2407 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2453) (- lev2448 1))) (quasi2410 q2454 lev2448)))) tmp2452) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456) (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2456) (+ lev2448 1)))) tmp2455) ((lambda (tmp2457) (if tmp2457 (apply (lambda (p2458 q2459) (quasicons2407 (quasi2410 p2458 lev2448) (quasi2410 q2459 lev2448))) tmp2457) ((lambda (tmp2460) (if tmp2460 (apply (lambda (x2461) (quasivector2409 (quasi2410 x2461 lev2448))) tmp2460) ((lambda (p2463) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2463)) tmp2449))) ($sc-dispatch tmp2449 (quote #(vector each-any)))))) ($sc-dispatch tmp2449 (quote (any . any)))))) ($sc-dispatch tmp2449 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2449 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2449 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2447)))) (lambda (x2464) ((lambda (tmp2465) ((lambda (tmp2466) (if tmp2466 (apply (lambda (_2467 e2468) (quasi2410 e2468 0)) tmp2466) (syntax-violation #f "source expression failed to match any pattern" tmp2465))) ($sc-dispatch tmp2465 (quote (any any))))) x2464)))) +(install-global-transformer (quote include) (lambda (x2469) (letrec ((read-file2470 (lambda (fn2471 k2472) (let ((p2473 (open-input-file fn2471))) (let f2474 ((x2475 (read p2473))) (if (eof-object? x2475) (begin (close-input-port p2473) (quote ())) (cons (datum->syntax k2472 x2475) (f2474 (read p2473))))))))) ((lambda (tmp2476) ((lambda (tmp2477) (if tmp2477 (apply (lambda (k2478 filename2479) (let ((fn2480 (syntax->datum filename2479))) ((lambda (tmp2481) ((lambda (tmp2482) (if tmp2482 (apply (lambda (exp2483) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2483)) tmp2482) (syntax-violation #f "source expression failed to match any pattern" tmp2481))) ($sc-dispatch tmp2481 (quote each-any)))) (read-file2470 fn2480 k2478)))) tmp2477) (syntax-violation #f "source expression failed to match any pattern" tmp2476))) ($sc-dispatch tmp2476 (quote (any any))))) x2469)))) +(install-global-transformer (quote unquote) (lambda (x2485) ((lambda (tmp2486) ((lambda (tmp2487) (if tmp2487 (apply (lambda (_2488 e2489) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2489))) tmp2487) (syntax-violation #f "source expression failed to match any pattern" tmp2486))) ($sc-dispatch tmp2486 (quote (any any))))) x2485))) +(install-global-transformer (quote unquote-splicing) (lambda (x2490) ((lambda (tmp2491) ((lambda (tmp2492) (if tmp2492 (apply (lambda (_2493 e2494) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2494))) tmp2492) (syntax-violation #f "source expression failed to match any pattern" tmp2491))) ($sc-dispatch tmp2491 (quote (any any))))) x2490))) +(install-global-transformer (quote case) (lambda (x2495) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (_2498 e2499 m12500 m22501) ((lambda (tmp2502) ((lambda (body2503) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2499)) body2503)) tmp2502)) (let f2504 ((clause2505 m12500) (clauses2506 m22501)) (if (null? clauses2506) ((lambda (tmp2508) ((lambda (tmp2509) (if tmp2509 (apply (lambda (e12510 e22511) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12510 e22511))) tmp2509) ((lambda (tmp2513) (if tmp2513 (apply (lambda (k2514 e12515 e22516) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2514)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12515 e22516)))) tmp2513) ((lambda (_2519) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2508))) ($sc-dispatch tmp2508 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2508 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2505) ((lambda (tmp2520) ((lambda (rest2521) ((lambda (tmp2522) ((lambda (tmp2523) (if tmp2523 (apply (lambda (k2524 e12525 e22526) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2524)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12525 e22526)) rest2521)) tmp2523) ((lambda (_2529) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2522))) ($sc-dispatch tmp2522 (quote (each-any any . each-any))))) clause2505)) tmp2520)) (f2504 (car clauses2506) (cdr clauses2506))))))) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) ($sc-dispatch tmp2496 (quote (any any any . each-any))))) x2495))) +(install-global-transformer (quote identifier-syntax) (lambda (x2530) ((lambda (tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2534)) (list (cons _2533 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2534 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2532) (syntax-violation #f "source expression failed to match any pattern" tmp2531))) ($sc-dispatch tmp2531 (quote (any any))))) x2530))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 347a776ee..00ce0b9b1 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -83,7 +83,7 @@ ;;; used to report errors found during expansion ;;; (install-global-transformer symbol value) ;;; used by expanded code to install top-level syntactic abstractions -;;; (syntax-dispatch e p) +;;; ($sc-dispatch e p) ;;; used by expanded code to handle syntax-case matching ;;; The following nonstandard procedures must be provided by the @@ -1839,7 +1839,7 @@ (let () (define convert-pattern ; accepts pattern & keys - ; returns syntax-dispatch pattern & ids + ; returns $sc-dispatch pattern & ids (lambda (pattern keys) (let cvt ((p pattern) (n 0) (ids '())) (if (id? p) @@ -1918,7 +1918,7 @@ (build-primref no-source 'list) (list x)) (build-application no-source - (build-primref no-source 'syntax-dispatch) + (build-primref no-source '$sc-dispatch) (list x (build-data no-source p))))))))))))) (define gen-syntax-case @@ -2053,7 +2053,7 @@ (arg-check procedure? v 'define-syntax) (global-extend 'macro sym v))) -;;; syntax-dispatch expects an expression and a pattern. If the expression +;;; $sc-dispatch expects an expression and a pattern. If the expression ;;; matches the pattern a list of the matching expressions for each ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will ;;; not work on r4rs implementations that violate the ieee requirement @@ -2164,7 +2164,7 @@ (syntax-object-module e))) (else (match* (unannotate e) p w r mod))))) -(set! syntax-dispatch +(set! $sc-dispatch (lambda (e p) (cond ((eq? p 'any) (list e)) From 5a0132b3375b35c69c6afb735acbaa8619237fb5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 00:38:12 +0200 Subject: [PATCH 085/375] a different tack for syncase macro representation * libguile/macros.c (macro_print): Show syntax-case bindings, if present. (macro_mark): Mark the extra two words if they're there. (scm_make_syncase_macro, scm_make_extended_syncase_macro): OK! A new take at the "how do we represent syncase macros in Guile" problem. Whereas we need a disjoint type, but would like it to be compatible with old predicates (e.g. `macro?'), and need to be able to extend existing syntax definitions (e.g. `cond'), let's add a bit to macros to indicate whether they have syncase macro bindings or not, and a fourth macro type for native syncase macros. (scm_macro_type): Return 'syntax-case for native syntax-case macros. Note that other macro types may have syntax-case bindings. (scm_macro_name): Return #f if the transformer is not a procedure. (scm_syncase_macro_type, scm_syncase_macro_binding): New accessors for the syncase macro bindings. * libguile/macros.h: Add API for syncase macros. * module/ice-9/boot-9.scm (module-define-keyword!): Adapt to use syncase macros, though they are not yet used. Reorder other syncase API. * module/ice-9/psyntax.scm (chi-expr): Fix syntax-violation invocation. --- libguile/macros.c | 109 ++++++++++++++++++++++++++++++++---- libguile/macros.h | 13 ++++- module/ice-9/boot-9.scm | 35 ++++++------ module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 4 +- 5 files changed, 132 insertions(+), 31 deletions(-) diff --git a/libguile/macros.c b/libguile/macros.c index d132c0159..535f3e050 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate) || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, macro, port, pstate))) { + scm_puts ("#<", port); + + if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) + scm_puts ("extended-", port); + if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) - scm_puts ("#', port); } return 1; } +static SCM +macro_mark (SCM macro) +{ + if (SCM_MACRO_IS_EXTENDED (macro)) + { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro)); + scm_gc_mark (SCM_SMOB_OBJECT_3 (macro)); + } + return SCM_SMOB_OBJECT (macro); +} + static SCM makmac (SCM code, scm_t_bits flags) { @@ -164,6 +187,40 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, #endif +SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0, + (SCM type, SCM binding), + "Return a @dfn{macro} that requires expansion by syntax-case.\n" + "While users should not call this function, it is useful to know\n" + "that syntax-case macros are represented as Guile primitive macros.") +#define FUNC_NAME s_scm_make_syncase_macro +{ + SCM z; + SCM_VALIDATE_SYMBOL (1, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0, + (SCM m, SCM type, SCM binding), + "Extend a core macro @var{m} with a syntax-case binding.") +#define FUNC_NAME s_scm_make_extended_syncase_macro +{ + SCM z; + SCM_VALIDATE_SMOB (1, m, macro); + SCM_VALIDATE_SYMBOL (2, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, (SCM obj), @@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro"); #endif SCM_SYMBOL (scm_sym_mmacro, "macro!"); SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); +SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro"); SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, (SCM m), - "Return one of the symbols @code{syntax}, @code{macro} or\n" - "@code{macro!}, depending on whether @var{m} is a syntax\n" - "transformer, a regular macro, or a memoizing macro,\n" - "respectively. If @var{m} is not a macro, @code{#f} is\n" - "returned.") + "Return one of the symbols @code{syntax}, @code{macro},\n" + "@code{macro!}, or @code{syntax-case}, depending on whether\n" + "@var{m} is a syntax transformer, a regular macro, a memoizing\n" + "macro, or a syntax-case macro, respectively. If @var{m} is\n" + "not a macro, @code{#f} is returned.") #define FUNC_NAME s_scm_macro_type { if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) @@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, #endif case 2: return scm_sym_mmacro; case 3: return scm_sym_bimacro; + case 4: return scm_sym_syncase_macro; default: scm_wrong_type_arg (FUNC_NAME, 1, m); } } @@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, #define FUNC_NAME s_scm_macro_name { SCM_VALIDATE_SMOB (1, m, macro); - return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m))); + if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m)))) + return scm_procedure_name (SCM_SMOB_OBJECT (m)); + return SCM_BOOL_F; } #undef FUNC_NAME @@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, + (SCM m), + "Return the type of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_type +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_2 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, + (SCM m), + "Return the binding of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_binding +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_3 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { @@ -249,7 +338,7 @@ void scm_init_macros () { scm_tc16_macro = scm_make_smob_type ("macro", 0); - scm_set_smob_mark (scm_tc16_macro, scm_markcdr); + scm_set_smob_mark (scm_tc16_macro, macro_mark); scm_set_smob_print (scm_tc16_macro, macro_print); #include "libguile/macros.x" } diff --git a/libguile/macros.h b/libguile/macros.h index e1de77ff9..5e3d64a55 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -29,9 +29,15 @@ #define SCM_ASSYNT(_cond, _msg, _subr) \ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); +#define SCM_MACRO_TYPE_BITS (3) +#define SCM_MACRO_TYPE_MASK ((1<syntax #f) (define syntax->datum #f) - (define identifier? #f) (define generate-temporaries #f) (define bound-identifier=? #f) (define free-identifier=? #f) +(define sc-expand #f) +(define sc-expand3 #f) + +;;; Implementation detail of psyntax -- the thing that does expand-time +;;; dispatch for syntax-case macros +(define $sc-dispatch #f) + +;;; Useless crap I'd like to get rid of +(define install-global-transformer #f) +(define (annotation? x) #f) + (define andmap (lambda (f first . rest) @@ -213,14 +219,9 @@ (apply f (cons x xr)) (and (apply f (cons x xr)) (andmap first rest))))))))) -(define (syncase-error who format-string why what) - (%start-stack 'syncase-stack - (lambda () - (scm-error 'misc-error who "~A ~S" (list why what) '())))) - -;; Until the module system is booted, this will be the current expander. (primitive-load-path "ice-9/psyntax-pp") +;; Until the module system is booted, this will be the current expander. (define %pre-modules-transformer sc-expand) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 31066c3f2..99510b892 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,6 +1,6 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) ($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any . each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) ($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) ($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any)))))) ($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) ($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) ($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) ($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) ($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) ($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) ($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote $sc-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any)))))) ($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any . any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) ($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) +(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) ($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1112 e1510 w1512 s1513 mod1514)) (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any . each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) ($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) ($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any)))))) ($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) ($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) ($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) ($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) ($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) ($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) ($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote $sc-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any)))))) ($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any . any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) ($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) (install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2323 (quote ()) (list out2322 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda (tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2330) (quote ()) (list out2329 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source expression failed to match any pattern" tmp2314))) ($sc-dispatch tmp2314 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any () any . each-any))))) x2313))) (install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda (tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340 keyword2341 pattern2342 template2343) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346 tmp2345) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2345) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source expression failed to match any pattern" tmp2337))) ($sc-dispatch tmp2337 (quote (any each-any . #(each ((any . any) any))))))) x2336))) (install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357 v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if (null? bindings2362) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply (lambda (body2368 binding2369) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2369) body2368)) tmp2367) (syntax-violation #f "source expression failed to match any pattern" tmp2366))) ($sc-dispatch tmp2366 (quote (any any))))) (list (f2361 (cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f "source expression failed to match any pattern" tmp2348))) ($sc-dispatch tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 00ce0b9b1..0af35dca9 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1167,8 +1167,8 @@ (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap e w s mod))) ((displaced-lexical) - (syntax-violation #f (source-wrap e w s mod) - "reference to identifier outside its scope")) + (syntax-violation #f "reference to identifier outside its scope" + (source-wrap e w s mod))) (else (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))) From 3d5f3091e100550052abc698e980b3e86cc01b65 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 21:19:23 +0200 Subject: [PATCH 086/375] first-class macro representation (no bits on variables) * libguile/macros.c (scm_macro_p): Update docs. * module/ice-9/boot-9.scm (module-define!, module-ref): Define pre-boot forms of these functions as well. I suspect module-add! can go soon. (module-lookup-keyword, module-define-keyword!) (module-undefine-keyword!) Remove these. * module/ice-9/psyntax-pp.scm: Regenerate. Notice the difference? * module/ice-9/psyntax.scm (put-global-definition-hook) (get-global-definition-hook): Rework to expect first-class macros. Heh heh. (remove-global-definition-hook): Pleasantly, this hook can go away. (chi-install-global): Terrorism to generate the right kind of output -- will clean up. (chi-top): Unify definition handling for all kinds of values. --- libguile/macros.c | 4 +-- module/ice-9/boot-9.scm | 35 +++++++---------------- module/ice-9/psyntax-pp.scm | 22 +++++++-------- module/ice-9/psyntax.scm | 56 ++++++++++++++++++++++++++----------- 4 files changed, 63 insertions(+), 54 deletions(-) diff --git a/libguile/macros.c b/libguile/macros.c index 535f3e050..ca3e83e29 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -224,8 +224,8 @@ SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0 SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, (SCM obj), - "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n" - "syntax transformer.") + "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n" + "syntax transformer, or a syntax-case macro.") #define FUNC_NAME s_scm_macro_p { return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 078801cf7..c12dc967b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -140,6 +140,16 @@ '(guile)) (define (module-add! module sym var) (hashq-set! (%get-pre-modules-obarray) sym var)) +(define (module-define! module sym val) + (let ((v (hashq-ref (%get-pre-modules-obarray) sym))) + (if v + (variable-set! v val) + (hashq-set! (%get-pre-modules-obarray) sym + (make-variable val))))) +(define (module-ref module sym) + (let ((v (module-variable module sym))) + (if v (variable-ref v) (error "badness!" (pk module) (pk sym))))) + (define (make-module-ref mod var kind) (case kind ((public) (if mod `(@ ,mod ,var) var)) @@ -156,31 +166,6 @@ (define (resolve-module . args) #f) -;;; Here we use "keyword" in the sense that R6RS uses it, as in "a -;;; definition may be a keyword definition or a variable definition". -;;; Keywords are syntactic bindings; variables are value bindings. -(define (module-define-keyword! mod sym type val) - (let ((v (or (module-local-variable mod sym) - (let ((v (make-undefined-variable))) - (module-add! mod sym v) - v)))) - (variable-set! v - (if (and (variable-bound? v) (macro? (variable-ref v))) - (make-extended-syncase-macro (variable-ref v) type val) - (make-syncase-macro type val))) - (set-object-property! v '*sc-expander* (cons type val)))) - -(define (module-lookup-keyword mod sym) - (let ((v (module-variable mod sym))) - (and v (object-property v '*sc-expander*)))) - -(define (module-undefine-keyword! mod sym) - (let ((v (module-local-variable mod sym))) - (if v - (let ((p (assq '*sc-expander* (object-properties v)))) - ;; probably should unbind the variable too - (set-object-properties! v (delq p (object-properties v))))))) - ;;; API provided by psyntax (define syntax-violation #f) (define datum->syntax #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 99510b892..5cb5213d5 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) ($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1112 e1510 w1512 s1513 mod1514)) (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any . each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) ($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) ($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any)))))) ($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) ($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) ($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) ($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) ($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) ($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook remove-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) ($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote $sc-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any)))))) ($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any . any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) ($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) -(install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2323 (quote ()) (list out2322 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda (tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2330) (quote ()) (list out2329 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source expression failed to match any pattern" tmp2314))) ($sc-dispatch tmp2314 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any () any . each-any))))) x2313))) -(install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda (tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340 keyword2341 pattern2342 template2343) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346 tmp2345) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2345) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source expression failed to match any pattern" tmp2337))) ($sc-dispatch tmp2337 (quote (any each-any . #(each ((any . any) any))))))) x2336))) -(install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357 v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if (null? bindings2362) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply (lambda (body2368 binding2369) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2369) body2368)) tmp2367) (syntax-violation #f "source expression failed to match any pattern" tmp2366))) ($sc-dispatch tmp2366 (quote (any any))))) (list (f2361 (cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f "source expression failed to match any pattern" tmp2348))) ($sc-dispatch tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347))) -(install-global-transformer (quote do) (lambda (orig-x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 var2374 init2375 step2376 e02377 e12378 c2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply (lambda (step2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2384) ((lambda (tmp2389) (if tmp2389 (apply (lambda (e12390 e22391) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12390 e22391)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2389) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) ($sc-dispatch tmp2383 (quote (any . each-any)))))) ($sc-dispatch tmp2383 (quote ())))) e12378)) tmp2381) (syntax-violation #f "source expression failed to match any pattern" tmp2380))) ($sc-dispatch tmp2380 (quote each-any)))) (map (lambda (v2398 s2399) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply (lambda () v2398) tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (e2403) e2403) tmp2402) ((lambda (_2404) (syntax-violation (quote do) "bad step expression" orig-x2370 s2399)) tmp2400))) ($sc-dispatch tmp2400 (quote (any)))))) ($sc-dispatch tmp2400 (quote ())))) s2399)) var2374 step2376))) tmp2372) (syntax-violation #f "source expression failed to match any pattern" tmp2371))) ($sc-dispatch tmp2371 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2370))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2407 (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (dy2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dx2422) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2422 dy2419))) tmp2421) ((lambda (_2423) (if (null? dy2419) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416))) tmp2420))) ($sc-dispatch tmp2420 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2415)) tmp2418) ((lambda (tmp2424) (if tmp2424 (apply (lambda (stuff2425) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2415 stuff2425))) tmp2424) ((lambda (else2426) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416)) tmp2417))) ($sc-dispatch tmp2417 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2417 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2416)) tmp2414) (syntax-violation #f "source expression failed to match any pattern" tmp2413))) ($sc-dispatch tmp2413 (quote (any any))))) (list x2411 y2412)))) (quasiappend2408 (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () x2431) tmp2434) ((lambda (_2435) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2431 y2432)) tmp2433))) ($sc-dispatch tmp2433 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2432)) tmp2430) (syntax-violation #f "source expression failed to match any pattern" tmp2429))) ($sc-dispatch tmp2429 (quote (any any))))) (list x2427 y2428)))) (quasivector2409 (lambda (x2436) ((lambda (tmp2437) ((lambda (x2438) ((lambda (tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (x2441) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2441))) tmp2440) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2444)) tmp2443) ((lambda (_2446) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2438)) tmp2439))) ($sc-dispatch tmp2439 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2439 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2438)) tmp2437)) x2436))) (quasi2410 (lambda (p2447 lev2448) ((lambda (tmp2449) ((lambda (tmp2450) (if tmp2450 (apply (lambda (p2451) (if (= lev2448 0) p2451 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2451) (- lev2448 1))))) tmp2450) ((lambda (tmp2452) (if tmp2452 (apply (lambda (p2453 q2454) (if (= lev2448 0) (quasiappend2408 p2453 (quasi2410 q2454 lev2448)) (quasicons2407 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2453) (- lev2448 1))) (quasi2410 q2454 lev2448)))) tmp2452) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456) (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2456) (+ lev2448 1)))) tmp2455) ((lambda (tmp2457) (if tmp2457 (apply (lambda (p2458 q2459) (quasicons2407 (quasi2410 p2458 lev2448) (quasi2410 q2459 lev2448))) tmp2457) ((lambda (tmp2460) (if tmp2460 (apply (lambda (x2461) (quasivector2409 (quasi2410 x2461 lev2448))) tmp2460) ((lambda (p2463) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2463)) tmp2449))) ($sc-dispatch tmp2449 (quote #(vector each-any)))))) ($sc-dispatch tmp2449 (quote (any . any)))))) ($sc-dispatch tmp2449 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2449 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2449 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2447)))) (lambda (x2464) ((lambda (tmp2465) ((lambda (tmp2466) (if tmp2466 (apply (lambda (_2467 e2468) (quasi2410 e2468 0)) tmp2466) (syntax-violation #f "source expression failed to match any pattern" tmp2465))) ($sc-dispatch tmp2465 (quote (any any))))) x2464)))) -(install-global-transformer (quote include) (lambda (x2469) (letrec ((read-file2470 (lambda (fn2471 k2472) (let ((p2473 (open-input-file fn2471))) (let f2474 ((x2475 (read p2473))) (if (eof-object? x2475) (begin (close-input-port p2473) (quote ())) (cons (datum->syntax k2472 x2475) (f2474 (read p2473))))))))) ((lambda (tmp2476) ((lambda (tmp2477) (if tmp2477 (apply (lambda (k2478 filename2479) (let ((fn2480 (syntax->datum filename2479))) ((lambda (tmp2481) ((lambda (tmp2482) (if tmp2482 (apply (lambda (exp2483) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2483)) tmp2482) (syntax-violation #f "source expression failed to match any pattern" tmp2481))) ($sc-dispatch tmp2481 (quote each-any)))) (read-file2470 fn2480 k2478)))) tmp2477) (syntax-violation #f "source expression failed to match any pattern" tmp2476))) ($sc-dispatch tmp2476 (quote (any any))))) x2469)))) -(install-global-transformer (quote unquote) (lambda (x2485) ((lambda (tmp2486) ((lambda (tmp2487) (if tmp2487 (apply (lambda (_2488 e2489) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2489))) tmp2487) (syntax-violation #f "source expression failed to match any pattern" tmp2486))) ($sc-dispatch tmp2486 (quote (any any))))) x2485))) -(install-global-transformer (quote unquote-splicing) (lambda (x2490) ((lambda (tmp2491) ((lambda (tmp2492) (if tmp2492 (apply (lambda (_2493 e2494) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2494))) tmp2492) (syntax-violation #f "source expression failed to match any pattern" tmp2491))) ($sc-dispatch tmp2491 (quote (any any))))) x2490))) -(install-global-transformer (quote case) (lambda (x2495) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (_2498 e2499 m12500 m22501) ((lambda (tmp2502) ((lambda (body2503) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2499)) body2503)) tmp2502)) (let f2504 ((clause2505 m12500) (clauses2506 m22501)) (if (null? clauses2506) ((lambda (tmp2508) ((lambda (tmp2509) (if tmp2509 (apply (lambda (e12510 e22511) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12510 e22511))) tmp2509) ((lambda (tmp2513) (if tmp2513 (apply (lambda (k2514 e12515 e22516) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2514)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12515 e22516)))) tmp2513) ((lambda (_2519) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2508))) ($sc-dispatch tmp2508 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2508 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2505) ((lambda (tmp2520) ((lambda (rest2521) ((lambda (tmp2522) ((lambda (tmp2523) (if tmp2523 (apply (lambda (k2524 e12525 e22526) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2524)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12525 e22526)) rest2521)) tmp2523) ((lambda (_2529) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2522))) ($sc-dispatch tmp2522 (quote (each-any any . each-any))))) clause2505)) tmp2520)) (f2504 (car clauses2506) (cdr clauses2506))))))) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) ($sc-dispatch tmp2496 (quote (any any any . each-any))))) x2495))) -(install-global-transformer (quote identifier-syntax) (lambda (x2530) ((lambda (tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2534)) (list (cons _2533 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2534 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2532) (syntax-violation #f "source expression failed to match any pattern" tmp2531))) ($sc-dispatch tmp2531 (quote (any any))))) x2530))) +(letrec ((lambda-var-list1131 (lambda (vars1336) (let lvl1337 ((vars1338 vars1336) (ls1339 (quote ())) (w1340 (quote (())))) (cond ((pair? vars1338) (lvl1337 (cdr vars1338) (cons (wrap1110 (car vars1338) w1340 #f) ls1339) w1340)) ((id?1082 vars1338) (cons (wrap1110 vars1338 w1340 #f) ls1339)) ((null? vars1338) ls1339) ((syntax-object?1066 vars1338) (lvl1337 (syntax-object-expression1067 vars1338) ls1339 (join-wraps1101 w1340 (syntax-object-wrap1068 vars1338)))) ((annotation? vars1338) (lvl1337 (annotation-expression vars1338) ls1339 w1340)) (else (cons vars1338 ls1339)))))) (gen-var1130 (lambda (id1341) (let ((id1342 (if (syntax-object?1066 id1341) (syntax-object-expression1067 id1341) id1341))) (if (annotation? id1342) (build-annotated1059 (annotation-source id1342) (gensym (symbol->string (annotation-expression id1342)))) (build-annotated1059 #f (gensym (symbol->string id1342))))))) (strip1129 (lambda (x1343 w1344) (if (memq (quote top) (wrap-marks1085 w1344)) (if (or (annotation? x1343) (and (pair? x1343) (annotation? (car x1343)))) (strip-annotation1128 x1343 #f) x1343) (let f1345 ((x1346 x1343)) (cond ((syntax-object?1066 x1346) (strip1129 (syntax-object-expression1067 x1346) (syntax-object-wrap1068 x1346))) ((pair? x1346) (let ((a1347 (f1345 (car x1346))) (d1348 (f1345 (cdr x1346)))) (if (and (eq? a1347 (car x1346)) (eq? d1348 (cdr x1346))) x1346 (cons a1347 d1348)))) ((vector? x1346) (let ((old1349 (vector->list x1346))) (let ((new1350 (map f1345 old1349))) (if (andmap eq? old1349 new1350) x1346 (list->vector new1350))))) (else x1346)))))) (strip-annotation1128 (lambda (x1351 parent1352) (cond ((pair? x1351) (let ((new1353 (cons #f #f))) (begin (if parent1352 (set-annotation-stripped! parent1352 new1353)) (set-car! new1353 (strip-annotation1128 (car x1351) #f)) (set-cdr! new1353 (strip-annotation1128 (cdr x1351) #f)) new1353))) ((annotation? x1351) (or (annotation-stripped x1351) (strip-annotation1128 (annotation-expression x1351) x1351))) ((vector? x1351) (let ((new1354 (make-vector (vector-length x1351)))) (begin (if parent1352 (set-annotation-stripped! parent1352 new1354)) (let loop1355 ((i1356 (- (vector-length x1351) 1))) (unless (fx<1053 i1356 0) (vector-set! new1354 i1356 (strip-annotation1128 (vector-ref x1351 i1356) #f)) (loop1355 (fx-1051 i1356 1)))) new1354))) (else x1351)))) (ellipsis?1127 (lambda (x1357) (and (nonsymbol-id?1081 x1357) (free-id=?1105 x1357 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1126 (lambda () (build-annotated1059 #f (list (build-annotated1059 #f (quote void)))))) (eval-local-transformer1125 (lambda (expanded1358 mod1359) (let ((p1360 (local-eval-hook1055 expanded1358 mod1359))) (if (procedure? p1360) p1360 (syntax-violation #f "nonprocedure transformer" p1360))))) (chi-local-syntax1124 (lambda (rec?1361 e1362 r1363 w1364 s1365 mod1366 k1367) ((lambda (tmp1368) ((lambda (tmp1369) (if tmp1369 (apply (lambda (_1370 id1371 val1372 e11373 e21374) (let ((ids1375 id1371)) (if (not (valid-bound-ids?1107 ids1375)) (syntax-violation #f "duplicate bound keyword" e1362) (let ((labels1377 (gen-labels1088 ids1375))) (let ((new-w1378 (make-binding-wrap1099 ids1375 labels1377 w1364))) (k1367 (cons e11373 e21374) (extend-env1076 labels1377 (let ((w1380 (if rec?1361 new-w1378 w1364)) (trans-r1381 (macros-only-env1078 r1363))) (map (lambda (x1382) (cons (quote macro) (eval-local-transformer1125 (chi1118 x1382 trans-r1381 w1380 mod1366) mod1366))) val1372)) r1363) new-w1378 s1365 mod1366)))))) tmp1369) ((lambda (_1384) (syntax-violation #f "bad local syntax definition" (source-wrap1111 e1362 w1364 s1365 mod1366))) tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) e1362))) (chi-lambda-clause1123 (lambda (e1385 docstring1386 c1387 r1388 w1389 mod1390 k1391) ((lambda (tmp1392) ((lambda (tmp1393) (if (if tmp1393 (apply (lambda (args1394 doc1395 e11396 e21397) (and (string? (syntax->datum doc1395)) (not docstring1386))) tmp1393) #f) (apply (lambda (args1398 doc1399 e11400 e21401) (chi-lambda-clause1123 e1385 doc1399 (cons args1398 (cons e11400 e21401)) r1388 w1389 mod1390 k1391)) tmp1393) ((lambda (tmp1403) (if tmp1403 (apply (lambda (id1404 e11405 e21406) (let ((ids1407 id1404)) (if (not (valid-bound-ids?1107 ids1407)) (syntax-violation (quote lambda) "invalid parameter list" e1385) (let ((labels1409 (gen-labels1088 ids1407)) (new-vars1410 (map gen-var1130 ids1407))) (k1391 new-vars1410 docstring1386 (chi-body1122 (cons e11405 e21406) e1385 (extend-var-env1077 labels1409 new-vars1410 r1388) (make-binding-wrap1099 ids1407 labels1409 w1389) mod1390)))))) tmp1403) ((lambda (tmp1412) (if tmp1412 (apply (lambda (ids1413 e11414 e21415) (let ((old-ids1416 (lambda-var-list1131 ids1413))) (if (not (valid-bound-ids?1107 old-ids1416)) (syntax-violation (quote lambda) "invalid parameter list" e1385) (let ((labels1417 (gen-labels1088 old-ids1416)) (new-vars1418 (map gen-var1130 old-ids1416))) (k1391 (let f1419 ((ls11420 (cdr new-vars1418)) (ls21421 (car new-vars1418))) (if (null? ls11420) ls21421 (f1419 (cdr ls11420) (cons (car ls11420) ls21421)))) docstring1386 (chi-body1122 (cons e11414 e21415) e1385 (extend-var-env1077 labels1417 new-vars1418 r1388) (make-binding-wrap1099 old-ids1416 labels1417 w1389) mod1390)))))) tmp1412) ((lambda (_1423) (syntax-violation (quote lambda) "bad lambda" e1385)) tmp1392))) ($sc-dispatch tmp1392 (quote (any any . each-any)))))) ($sc-dispatch tmp1392 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1392 (quote (any any any . each-any))))) c1387))) (chi-body1122 (lambda (body1424 outer-form1425 r1426 w1427 mod1428) (let ((r1429 (cons (quote ("placeholder" placeholder)) r1426))) (let ((ribcage1430 (make-ribcage1089 (quote ()) (quote ()) (quote ())))) (let ((w1431 (make-wrap1084 (wrap-marks1085 w1427) (cons ribcage1430 (wrap-subst1086 w1427))))) (let parse1432 ((body1433 (map (lambda (x1439) (cons r1429 (wrap1110 x1439 w1431 mod1428))) body1424)) (ids1434 (quote ())) (labels1435 (quote ())) (vars1436 (quote ())) (vals1437 (quote ())) (bindings1438 (quote ()))) (if (null? body1433) (syntax-violation #f "no expressions in body" outer-form1425) (let ((e1440 (cdar body1433)) (er1441 (caar body1433))) (call-with-values (lambda () (syntax-type1116 e1440 er1441 (quote (())) #f ribcage1430 mod1428)) (lambda (type1442 value1443 e1444 w1445 s1446 mod1447) (let ((t1448 type1442)) (if (memv t1448 (quote (define-form))) (let ((id1449 (wrap1110 value1443 w1445 mod1447)) (label1450 (gen-label1087))) (let ((var1451 (gen-var1130 id1449))) (begin (extend-ribcage!1098 ribcage1430 id1449 label1450) (parse1432 (cdr body1433) (cons id1449 ids1434) (cons label1450 labels1435) (cons var1451 vars1436) (cons (cons er1441 (wrap1110 e1444 w1445 mod1447)) vals1437) (cons (cons (quote lexical) var1451) bindings1438))))) (if (memv t1448 (quote (define-syntax-form))) (let ((id1452 (wrap1110 value1443 w1445 mod1447)) (label1453 (gen-label1087))) (begin (extend-ribcage!1098 ribcage1430 id1452 label1453) (parse1432 (cdr body1433) (cons id1452 ids1434) (cons label1453 labels1435) vars1436 vals1437 (cons (cons (quote macro) (cons er1441 (wrap1110 e1444 w1445 mod1447))) bindings1438)))) (if (memv t1448 (quote (begin-form))) ((lambda (tmp1454) ((lambda (tmp1455) (if tmp1455 (apply (lambda (_1456 e11457) (parse1432 (let f1458 ((forms1459 e11457)) (if (null? forms1459) (cdr body1433) (cons (cons er1441 (wrap1110 (car forms1459) w1445 mod1447)) (f1458 (cdr forms1459))))) ids1434 labels1435 vars1436 vals1437 bindings1438)) tmp1455) (syntax-violation #f "source expression failed to match any pattern" tmp1454))) ($sc-dispatch tmp1454 (quote (any . each-any))))) e1444) (if (memv t1448 (quote (local-syntax-form))) (chi-local-syntax1124 value1443 e1444 er1441 w1445 s1446 mod1447 (lambda (forms1461 er1462 w1463 s1464 mod1465) (parse1432 (let f1466 ((forms1467 forms1461)) (if (null? forms1467) (cdr body1433) (cons (cons er1462 (wrap1110 (car forms1467) w1463 mod1465)) (f1466 (cdr forms1467))))) ids1434 labels1435 vars1436 vals1437 bindings1438))) (if (null? ids1434) (build-sequence1061 #f (map (lambda (x1468) (chi1118 (cdr x1468) (car x1468) (quote (())) mod1447)) (cons (cons er1441 (source-wrap1111 e1444 w1445 s1446 mod1447)) (cdr body1433)))) (begin (if (not (valid-bound-ids?1107 ids1434)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1425)) (let loop1469 ((bs1470 bindings1438) (er-cache1471 #f) (r-cache1472 #f)) (if (not (null? bs1470)) (let ((b1473 (car bs1470))) (if (eq? (car b1473) (quote macro)) (let ((er1474 (cadr b1473))) (let ((r-cache1475 (if (eq? er1474 er-cache1471) r-cache1472 (macros-only-env1078 er1474)))) (begin (set-cdr! b1473 (eval-local-transformer1125 (chi1118 (cddr b1473) r-cache1475 (quote (())) mod1447) mod1447)) (loop1469 (cdr bs1470) er1474 r-cache1475)))) (loop1469 (cdr bs1470) er-cache1471 r-cache1472))))) (set-cdr! r1429 (extend-env1076 labels1435 bindings1438 (cdr r1429))) (build-letrec1064 #f vars1436 (map (lambda (x1476) (chi1118 (cdr x1476) (car x1476) (quote (())) mod1447)) vals1437) (build-sequence1061 #f (map (lambda (x1477) (chi1118 (cdr x1477) (car x1477) (quote (())) mod1447)) (cons (cons er1441 (source-wrap1111 e1444 w1445 s1446 mod1447)) (cdr body1433)))))))))))))))))))))) (chi-macro1121 (lambda (p1478 e1479 r1480 w1481 rib1482 mod1483) (letrec ((rebuild-macro-output1484 (lambda (x1485 m1486) (cond ((pair? x1485) (cons (rebuild-macro-output1484 (car x1485) m1486) (rebuild-macro-output1484 (cdr x1485) m1486))) ((syntax-object?1066 x1485) (let ((w1487 (syntax-object-wrap1068 x1485))) (let ((ms1488 (wrap-marks1085 w1487)) (s1489 (wrap-subst1086 w1487))) (if (and (pair? ms1488) (eq? (car ms1488) #f)) (make-syntax-object1065 (syntax-object-expression1067 x1485) (make-wrap1084 (cdr ms1488) (if rib1482 (cons rib1482 (cdr s1489)) (cdr s1489))) (syntax-object-module1069 x1485)) (make-syntax-object1065 (syntax-object-expression1067 x1485) (make-wrap1084 (cons m1486 ms1488) (if rib1482 (cons rib1482 (cons (quote shift) s1489)) (cons (quote shift) s1489))) (let ((pmod1490 (procedure-module p1478))) (if pmod1490 (cons (quote hygiene) (module-name pmod1490)) (quote (hygiene guile))))))))) ((vector? x1485) (let ((n1491 (vector-length x1485))) (let ((v1492 (make-vector n1491))) (let doloop1493 ((i1494 0)) (if (fx=1052 i1494 n1491) v1492 (begin (vector-set! v1492 i1494 (rebuild-macro-output1484 (vector-ref x1485 i1494) m1486)) (doloop1493 (fx+1050 i1494 1)))))))) ((symbol? x1485) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1111 e1479 w1481 s mod1483) x1485)) (else x1485))))) (rebuild-macro-output1484 (p1478 (wrap1110 e1479 (anti-mark1097 w1481) mod1483)) (string #\m))))) (chi-application1120 (lambda (x1495 e1496 r1497 w1498 s1499 mod1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (e01503 e11504) (build-annotated1059 s1499 (cons x1495 (map (lambda (e1505) (chi1118 e1505 r1497 w1498 mod1500)) e11504)))) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote (any . each-any))))) e1496))) (chi-expr1119 (lambda (type1507 value1508 e1509 r1510 w1511 s1512 mod1513) (let ((t1514 type1507)) (if (memv t1514 (quote (lexical))) (build-annotated1059 s1512 value1508) (if (memv t1514 (quote (core external-macro))) (value1508 e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (module-ref))) (call-with-values (lambda () (value1508 e1509)) (lambda (id1515 mod1516) (build-annotated1059 s1512 (if mod1516 (make-module-ref (cdr mod1516) id1515 (car mod1516)) (make-module-ref mod1516 id1515 (quote bare)))))) (if (memv t1514 (quote (lexical-call))) (chi-application1120 (build-annotated1059 (source-annotation1073 (car e1509)) value1508) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (global-call))) (chi-application1120 (build-annotated1059 (source-annotation1073 (car e1509)) (if (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513) (make-module-ref (cdr (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513)) value1508 (car (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513))) (make-module-ref (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513) value1508 (quote bare)))) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (constant))) (build-data1060 s1512 (strip1129 (source-wrap1111 e1509 w1511 s1512 mod1513) (quote (())))) (if (memv t1514 (quote (global))) (build-annotated1059 s1512 (if mod1513 (make-module-ref (cdr mod1513) value1508 (car mod1513)) (make-module-ref mod1513 value1508 (quote bare)))) (if (memv t1514 (quote (call))) (chi-application1120 (chi1118 (car e1509) r1510 w1511 mod1513) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (begin-form))) ((lambda (tmp1517) ((lambda (tmp1518) (if tmp1518 (apply (lambda (_1519 e11520 e21521) (chi-sequence1112 (cons e11520 e21521) r1510 w1511 s1512 mod1513)) tmp1518) (syntax-violation #f "source expression failed to match any pattern" tmp1517))) ($sc-dispatch tmp1517 (quote (any any . each-any))))) e1509) (if (memv t1514 (quote (local-syntax-form))) (chi-local-syntax1124 value1508 e1509 r1510 w1511 s1512 mod1513 chi-sequence1112) (if (memv t1514 (quote (eval-when-form))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (_1525 x1526 e11527 e21528) (let ((when-list1529 (chi-when-list1115 e1509 x1526 w1511))) (if (memq (quote eval) when-list1529) (chi-sequence1112 (cons e11527 e21528) r1510 w1511 s1512 mod1513) (chi-void1126)))) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote (any each-any any . each-any))))) e1509) (if (memv t1514 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1509 (wrap1110 value1508 w1511 mod1513)) (if (memv t1514 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1111 e1509 w1511 s1512 mod1513)) (if (memv t1514 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1111 e1509 w1511 s1512 mod1513)) (syntax-violation #f "unexpected syntax" (source-wrap1111 e1509 w1511 s1512 mod1513))))))))))))))))))) (chi1118 (lambda (e1532 r1533 w1534 mod1535) (call-with-values (lambda () (syntax-type1116 e1532 r1533 w1534 #f #f mod1535)) (lambda (type1536 value1537 e1538 w1539 s1540 mod1541) (chi-expr1119 type1536 value1537 e1538 r1533 w1539 s1540 mod1541))))) (chi-top1117 (lambda (e1542 r1543 w1544 m1545 esew1546 mod1547) (call-with-values (lambda () (syntax-type1116 e1542 r1543 w1544 #f #f mod1547)) (lambda (type1555 value1556 e1557 w1558 s1559 mod1560) (let ((t1561 type1555)) (if (memv t1561 (quote (begin-form))) ((lambda (tmp1562) ((lambda (tmp1563) (if tmp1563 (apply (lambda (_1564) (chi-void1126)) tmp1563) ((lambda (tmp1565) (if tmp1565 (apply (lambda (_1566 e11567 e21568) (chi-top-sequence1113 (cons e11567 e21568) r1543 w1558 s1559 m1545 esew1546 mod1560)) tmp1565) (syntax-violation #f "source expression failed to match any pattern" tmp1562))) ($sc-dispatch tmp1562 (quote (any any . each-any)))))) ($sc-dispatch tmp1562 (quote (any))))) e1557) (if (memv t1561 (quote (local-syntax-form))) (chi-local-syntax1124 value1556 e1557 r1543 w1558 s1559 mod1560 (lambda (body1570 r1571 w1572 s1573 mod1574) (chi-top-sequence1113 body1570 r1571 w1572 s1573 m1545 esew1546 mod1574))) (if (memv t1561 (quote (eval-when-form))) ((lambda (tmp1575) ((lambda (tmp1576) (if tmp1576 (apply (lambda (_1577 x1578 e11579 e21580) (let ((when-list1581 (chi-when-list1115 e1557 x1578 w1558)) (body1582 (cons e11579 e21580))) (cond ((eq? m1545 (quote e)) (if (memq (quote eval) when-list1581) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote e) (quote (eval)) mod1560) (chi-void1126))) ((memq (quote load) when-list1581) (if (or (memq (quote compile) when-list1581) (and (eq? m1545 (quote c&e)) (memq (quote eval) when-list1581))) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote c&e) (quote (compile load)) mod1560) (if (memq m1545 (quote (c c&e))) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote c) (quote (load)) mod1560) (chi-void1126)))) ((or (memq (quote compile) when-list1581) (and (eq? m1545 (quote c&e)) (memq (quote eval) when-list1581))) (top-level-eval-hook1054 (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote e) (quote (eval)) mod1560) mod1560) (chi-void1126)) (else (chi-void1126))))) tmp1576) (syntax-violation #f "source expression failed to match any pattern" tmp1575))) ($sc-dispatch tmp1575 (quote (any each-any any . each-any))))) e1557) (if (memv t1561 (quote (define-syntax-form))) (let ((n1585 (id-var-name1104 value1556 w1558)) (r1586 (macros-only-env1078 r1543))) (let ((t1587 m1545)) (if (memv t1587 (quote (c))) (if (memq (quote compile) esew1546) (let ((e1588 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)))) (begin (top-level-eval-hook1054 e1588 mod1560) (if (memq (quote load) esew1546) e1588 (chi-void1126)))) (if (memq (quote load) esew1546) (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)) (chi-void1126))) (if (memv t1587 (quote (c&e))) (let ((e1589 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)))) (begin (top-level-eval-hook1054 e1589 mod1560) e1589)) (begin (if (memq (quote eval) esew1546) (top-level-eval-hook1054 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)) mod1560)) (chi-void1126)))))) (if (memv t1561 (quote (define-form))) (let ((n1590 (id-var-name1104 value1556 w1558))) (let ((type1591 (binding-type1074 (lookup1079 n1590 r1543 mod1560)))) (let ((t1592 type1591)) (if (memv t1592 (quote (global core macro module-ref))) (let ((x1593 (build-annotated1059 s1559 (list (quote define) n1590 (chi1118 e1557 r1543 w1558 mod1560))))) (begin (if (eq? m1545 (quote c&e)) (top-level-eval-hook1054 x1593 mod1560)) x1593)) (if (memv t1592 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1557 (wrap1110 value1556 w1558 mod1560)) (syntax-violation #f "cannot define keyword at top level" e1557 (wrap1110 value1556 w1558 mod1560))))))) (let ((x1594 (chi-expr1119 type1555 value1556 e1557 r1543 w1558 s1559 mod1560))) (begin (if (eq? m1545 (quote c&e)) (top-level-eval-hook1054 x1594 mod1560)) x1594)))))))))))) (syntax-type1116 (lambda (e1595 r1596 w1597 s1598 rib1599 mod1600) (cond ((symbol? e1595) (let ((n1601 (id-var-name1104 e1595 w1597))) (let ((b1602 (lookup1079 n1601 r1596 mod1600))) (let ((type1603 (binding-type1074 b1602))) (let ((t1604 type1603)) (if (memv t1604 (quote (lexical))) (values type1603 (binding-value1075 b1602) e1595 w1597 s1598 mod1600) (if (memv t1604 (quote (global))) (values type1603 n1601 e1595 w1597 s1598 mod1600) (if (memv t1604 (quote (macro))) (syntax-type1116 (chi-macro1121 (binding-value1075 b1602) e1595 r1596 w1597 rib1599 mod1600) r1596 (quote (())) s1598 rib1599 mod1600) (values type1603 (binding-value1075 b1602) e1595 w1597 s1598 mod1600))))))))) ((pair? e1595) (let ((first1605 (car e1595))) (if (id?1082 first1605) (let ((n1606 (id-var-name1104 first1605 w1597))) (let ((b1607 (lookup1079 n1606 r1596 (or (and (syntax-object?1066 first1605) (syntax-object-module1069 first1605)) mod1600)))) (let ((type1608 (binding-type1074 b1607))) (let ((t1609 type1608)) (if (memv t1609 (quote (lexical))) (values (quote lexical-call) (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (global))) (values (quote global-call) n1606 e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (macro))) (syntax-type1116 (chi-macro1121 (binding-value1075 b1607) e1595 r1596 w1597 rib1599 mod1600) r1596 (quote (())) s1598 rib1599 mod1600) (if (memv t1609 (quote (core external-macro module-ref))) (values type1608 (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (begin))) (values (quote begin-form) #f e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (eval-when))) (values (quote eval-when-form) #f e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (define))) ((lambda (tmp1610) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 name1613 val1614) (id?1082 name1613)) tmp1611) #f) (apply (lambda (_1615 name1616 val1617) (values (quote define-form) name1616 val1617 w1597 s1598 mod1600)) tmp1611) ((lambda (tmp1618) (if (if tmp1618 (apply (lambda (_1619 name1620 args1621 e11622 e21623) (and (id?1082 name1620) (valid-bound-ids?1107 (lambda-var-list1131 args1621)))) tmp1618) #f) (apply (lambda (_1624 name1625 args1626 e11627 e21628) (values (quote define-form) (wrap1110 name1625 w1597 mod1600) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1110 (cons args1626 (cons e11627 e21628)) w1597 mod1600)) (quote (())) s1598 mod1600)) tmp1618) ((lambda (tmp1630) (if (if tmp1630 (apply (lambda (_1631 name1632) (id?1082 name1632)) tmp1630) #f) (apply (lambda (_1633 name1634) (values (quote define-form) (wrap1110 name1634 w1597 mod1600) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1598 mod1600)) tmp1630) (syntax-violation #f "source expression failed to match any pattern" tmp1610))) ($sc-dispatch tmp1610 (quote (any any)))))) ($sc-dispatch tmp1610 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1610 (quote (any any any))))) e1595) (if (memv t1609 (quote (define-syntax))) ((lambda (tmp1635) ((lambda (tmp1636) (if (if tmp1636 (apply (lambda (_1637 name1638 val1639) (id?1082 name1638)) tmp1636) #f) (apply (lambda (_1640 name1641 val1642) (values (quote define-syntax-form) name1641 val1642 w1597 s1598 mod1600)) tmp1636) (syntax-violation #f "source expression failed to match any pattern" tmp1635))) ($sc-dispatch tmp1635 (quote (any any any))))) e1595) (values (quote call) #f e1595 w1597 s1598 mod1600)))))))))))))) (values (quote call) #f e1595 w1597 s1598 mod1600)))) ((syntax-object?1066 e1595) (syntax-type1116 (syntax-object-expression1067 e1595) r1596 (join-wraps1101 w1597 (syntax-object-wrap1068 e1595)) #f rib1599 (or (syntax-object-module1069 e1595) mod1600))) ((annotation? e1595) (syntax-type1116 (annotation-expression e1595) r1596 w1597 (annotation-source e1595) rib1599 mod1600)) ((self-evaluating? e1595) (values (quote constant) #f e1595 w1597 s1598 mod1600)) (else (values (quote other) #f e1595 w1597 s1598 mod1600))))) (chi-when-list1115 (lambda (e1643 when-list1644 w1645) (let f1646 ((when-list1647 when-list1644) (situations1648 (quote ()))) (if (null? when-list1647) situations1648 (f1646 (cdr when-list1647) (cons (let ((x1649 (car when-list1647))) (cond ((free-id=?1105 x1649 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1105 x1649 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1105 x1649 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1643 (wrap1110 x1649 w1645 #f))))) situations1648)))))) (chi-install-global1114 (lambda (name1650 e1651) (build-annotated1059 #f (list (build-annotated1059 #f (quote define)) name1650 (if (let ((v1652 (module-variable (current-module) name1650))) (and v1652 (variable-bound? v1652) (macro? (variable-ref v1652)) (not (eq? (macro-type (variable-ref v1652)) (quote syncase-macro))))) (build-annotated1059 #f (list (build-annotated1059 #f (quote make-extended-syncase-macro)) (build-annotated1059 #f (list (build-annotated1059 #f (quote module-ref)) (build-annotated1059 #f (quote (current-module))) (build-data1060 #f name1650))) (build-data1060 #f (quote macro)) e1651)) (build-annotated1059 #f (list (build-annotated1059 #f (quote make-syncase-macro)) (build-data1060 #f (quote macro)) e1651))))))) (chi-top-sequence1113 (lambda (body1653 r1654 w1655 s1656 m1657 esew1658 mod1659) (build-sequence1061 s1656 (let dobody1660 ((body1661 body1653) (r1662 r1654) (w1663 w1655) (m1664 m1657) (esew1665 esew1658) (mod1666 mod1659)) (if (null? body1661) (quote ()) (let ((first1667 (chi-top1117 (car body1661) r1662 w1663 m1664 esew1665 mod1666))) (cons first1667 (dobody1660 (cdr body1661) r1662 w1663 m1664 esew1665 mod1666)))))))) (chi-sequence1112 (lambda (body1668 r1669 w1670 s1671 mod1672) (build-sequence1061 s1671 (let dobody1673 ((body1674 body1668) (r1675 r1669) (w1676 w1670) (mod1677 mod1672)) (if (null? body1674) (quote ()) (let ((first1678 (chi1118 (car body1674) r1675 w1676 mod1677))) (cons first1678 (dobody1673 (cdr body1674) r1675 w1676 mod1677)))))))) (source-wrap1111 (lambda (x1679 w1680 s1681 defmod1682) (wrap1110 (if s1681 (make-annotation x1679 s1681 #f) x1679) w1680 defmod1682))) (wrap1110 (lambda (x1683 w1684 defmod1685) (cond ((and (null? (wrap-marks1085 w1684)) (null? (wrap-subst1086 w1684))) x1683) ((syntax-object?1066 x1683) (make-syntax-object1065 (syntax-object-expression1067 x1683) (join-wraps1101 w1684 (syntax-object-wrap1068 x1683)) (syntax-object-module1069 x1683))) ((null? x1683) x1683) (else (make-syntax-object1065 x1683 w1684 defmod1685))))) (bound-id-member?1109 (lambda (x1686 list1687) (and (not (null? list1687)) (or (bound-id=?1106 x1686 (car list1687)) (bound-id-member?1109 x1686 (cdr list1687)))))) (distinct-bound-ids?1108 (lambda (ids1688) (let distinct?1689 ((ids1690 ids1688)) (or (null? ids1690) (and (not (bound-id-member?1109 (car ids1690) (cdr ids1690))) (distinct?1689 (cdr ids1690))))))) (valid-bound-ids?1107 (lambda (ids1691) (and (let all-ids?1692 ((ids1693 ids1691)) (or (null? ids1693) (and (id?1082 (car ids1693)) (all-ids?1692 (cdr ids1693))))) (distinct-bound-ids?1108 ids1691)))) (bound-id=?1106 (lambda (i1694 j1695) (if (and (syntax-object?1066 i1694) (syntax-object?1066 j1695)) (and (eq? (let ((e1696 (syntax-object-expression1067 i1694))) (if (annotation? e1696) (annotation-expression e1696) e1696)) (let ((e1697 (syntax-object-expression1067 j1695))) (if (annotation? e1697) (annotation-expression e1697) e1697))) (same-marks?1103 (wrap-marks1085 (syntax-object-wrap1068 i1694)) (wrap-marks1085 (syntax-object-wrap1068 j1695)))) (eq? (let ((e1698 i1694)) (if (annotation? e1698) (annotation-expression e1698) e1698)) (let ((e1699 j1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)))))) (free-id=?1105 (lambda (i1700 j1701) (and (eq? (let ((x1702 i1700)) (let ((e1703 (if (syntax-object?1066 x1702) (syntax-object-expression1067 x1702) x1702))) (if (annotation? e1703) (annotation-expression e1703) e1703))) (let ((x1704 j1701)) (let ((e1705 (if (syntax-object?1066 x1704) (syntax-object-expression1067 x1704) x1704))) (if (annotation? e1705) (annotation-expression e1705) e1705)))) (eq? (id-var-name1104 i1700 (quote (()))) (id-var-name1104 j1701 (quote (()))))))) (id-var-name1104 (lambda (id1706 w1707) (letrec ((search-vector-rib1710 (lambda (sym1716 subst1717 marks1718 symnames1719 ribcage1720) (let ((n1721 (vector-length symnames1719))) (let f1722 ((i1723 0)) (cond ((fx=1052 i1723 n1721) (search1708 sym1716 (cdr subst1717) marks1718)) ((and (eq? (vector-ref symnames1719 i1723) sym1716) (same-marks?1103 marks1718 (vector-ref (ribcage-marks1092 ribcage1720) i1723))) (values (vector-ref (ribcage-labels1093 ribcage1720) i1723) marks1718)) (else (f1722 (fx+1050 i1723 1)))))))) (search-list-rib1709 (lambda (sym1724 subst1725 marks1726 symnames1727 ribcage1728) (let f1729 ((symnames1730 symnames1727) (i1731 0)) (cond ((null? symnames1730) (search1708 sym1724 (cdr subst1725) marks1726)) ((and (eq? (car symnames1730) sym1724) (same-marks?1103 marks1726 (list-ref (ribcage-marks1092 ribcage1728) i1731))) (values (list-ref (ribcage-labels1093 ribcage1728) i1731) marks1726)) (else (f1729 (cdr symnames1730) (fx+1050 i1731 1))))))) (search1708 (lambda (sym1732 subst1733 marks1734) (if (null? subst1733) (values #f marks1734) (let ((fst1735 (car subst1733))) (if (eq? fst1735 (quote shift)) (search1708 sym1732 (cdr subst1733) (cdr marks1734)) (let ((symnames1736 (ribcage-symnames1091 fst1735))) (if (vector? symnames1736) (search-vector-rib1710 sym1732 subst1733 marks1734 symnames1736 fst1735) (search-list-rib1709 sym1732 subst1733 marks1734 symnames1736 fst1735))))))))) (cond ((symbol? id1706) (or (call-with-values (lambda () (search1708 id1706 (wrap-subst1086 w1707) (wrap-marks1085 w1707))) (lambda (x1738 . ignore1737) x1738)) id1706)) ((syntax-object?1066 id1706) (let ((id1739 (let ((e1741 (syntax-object-expression1067 id1706))) (if (annotation? e1741) (annotation-expression e1741) e1741))) (w11740 (syntax-object-wrap1068 id1706))) (let ((marks1742 (join-marks1102 (wrap-marks1085 w1707) (wrap-marks1085 w11740)))) (call-with-values (lambda () (search1708 id1739 (wrap-subst1086 w1707) marks1742)) (lambda (new-id1743 marks1744) (or new-id1743 (call-with-values (lambda () (search1708 id1739 (wrap-subst1086 w11740) marks1744)) (lambda (x1746 . ignore1745) x1746)) id1739)))))) ((annotation? id1706) (let ((id1747 (let ((e1748 id1706)) (if (annotation? e1748) (annotation-expression e1748) e1748)))) (or (call-with-values (lambda () (search1708 id1747 (wrap-subst1086 w1707) (wrap-marks1085 w1707))) (lambda (x1750 . ignore1749) x1750)) id1747))) (else (error-hook1056 (quote id-var-name) "invalid id" id1706)))))) (same-marks?1103 (lambda (x1751 y1752) (or (eq? x1751 y1752) (and (not (null? x1751)) (not (null? y1752)) (eq? (car x1751) (car y1752)) (same-marks?1103 (cdr x1751) (cdr y1752)))))) (join-marks1102 (lambda (m11753 m21754) (smart-append1100 m11753 m21754))) (join-wraps1101 (lambda (w11755 w21756) (let ((m11757 (wrap-marks1085 w11755)) (s11758 (wrap-subst1086 w11755))) (if (null? m11757) (if (null? s11758) w21756 (make-wrap1084 (wrap-marks1085 w21756) (smart-append1100 s11758 (wrap-subst1086 w21756)))) (make-wrap1084 (smart-append1100 m11757 (wrap-marks1085 w21756)) (smart-append1100 s11758 (wrap-subst1086 w21756))))))) (smart-append1100 (lambda (m11759 m21760) (if (null? m21760) m11759 (append m11759 m21760)))) (make-binding-wrap1099 (lambda (ids1761 labels1762 w1763) (if (null? ids1761) w1763 (make-wrap1084 (wrap-marks1085 w1763) (cons (let ((labelvec1764 (list->vector labels1762))) (let ((n1765 (vector-length labelvec1764))) (let ((symnamevec1766 (make-vector n1765)) (marksvec1767 (make-vector n1765))) (begin (let f1768 ((ids1769 ids1761) (i1770 0)) (if (not (null? ids1769)) (call-with-values (lambda () (id-sym-name&marks1083 (car ids1769) w1763)) (lambda (symname1771 marks1772) (begin (vector-set! symnamevec1766 i1770 symname1771) (vector-set! marksvec1767 i1770 marks1772) (f1768 (cdr ids1769) (fx+1050 i1770 1))))))) (make-ribcage1089 symnamevec1766 marksvec1767 labelvec1764))))) (wrap-subst1086 w1763)))))) (extend-ribcage!1098 (lambda (ribcage1773 id1774 label1775) (begin (set-ribcage-symnames!1094 ribcage1773 (cons (let ((e1776 (syntax-object-expression1067 id1774))) (if (annotation? e1776) (annotation-expression e1776) e1776)) (ribcage-symnames1091 ribcage1773))) (set-ribcage-marks!1095 ribcage1773 (cons (wrap-marks1085 (syntax-object-wrap1068 id1774)) (ribcage-marks1092 ribcage1773))) (set-ribcage-labels!1096 ribcage1773 (cons label1775 (ribcage-labels1093 ribcage1773)))))) (anti-mark1097 (lambda (w1777) (make-wrap1084 (cons #f (wrap-marks1085 w1777)) (cons (quote shift) (wrap-subst1086 w1777))))) (set-ribcage-labels!1096 (lambda (x1778 update1779) (vector-set! x1778 3 update1779))) (set-ribcage-marks!1095 (lambda (x1780 update1781) (vector-set! x1780 2 update1781))) (set-ribcage-symnames!1094 (lambda (x1782 update1783) (vector-set! x1782 1 update1783))) (ribcage-labels1093 (lambda (x1784) (vector-ref x1784 3))) (ribcage-marks1092 (lambda (x1785) (vector-ref x1785 2))) (ribcage-symnames1091 (lambda (x1786) (vector-ref x1786 1))) (ribcage?1090 (lambda (x1787) (and (vector? x1787) (= (vector-length x1787) 4) (eq? (vector-ref x1787 0) (quote ribcage))))) (make-ribcage1089 (lambda (symnames1788 marks1789 labels1790) (vector (quote ribcage) symnames1788 marks1789 labels1790))) (gen-labels1088 (lambda (ls1791) (if (null? ls1791) (quote ()) (cons (gen-label1087) (gen-labels1088 (cdr ls1791)))))) (gen-label1087 (lambda () (string #\i))) (wrap-subst1086 cdr) (wrap-marks1085 car) (make-wrap1084 cons) (id-sym-name&marks1083 (lambda (x1792 w1793) (if (syntax-object?1066 x1792) (values (let ((e1794 (syntax-object-expression1067 x1792))) (if (annotation? e1794) (annotation-expression e1794) e1794)) (join-marks1102 (wrap-marks1085 w1793) (wrap-marks1085 (syntax-object-wrap1068 x1792)))) (values (let ((e1795 x1792)) (if (annotation? e1795) (annotation-expression e1795) e1795)) (wrap-marks1085 w1793))))) (id?1082 (lambda (x1796) (cond ((symbol? x1796) #t) ((syntax-object?1066 x1796) (symbol? (let ((e1797 (syntax-object-expression1067 x1796))) (if (annotation? e1797) (annotation-expression e1797) e1797)))) ((annotation? x1796) (symbol? (annotation-expression x1796))) (else #f)))) (nonsymbol-id?1081 (lambda (x1798) (and (syntax-object?1066 x1798) (symbol? (let ((e1799 (syntax-object-expression1067 x1798))) (if (annotation? e1799) (annotation-expression e1799) e1799)))))) (global-extend1080 (lambda (type1800 sym1801 val1802) (put-global-definition-hook1057 sym1801 type1800 val1802))) (lookup1079 (lambda (x1803 r1804 mod1805) (cond ((assq x1803 r1804) => cdr) ((symbol? x1803) (or (get-global-definition-hook1058 x1803 mod1805) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1078 (lambda (r1806) (if (null? r1806) (quote ()) (let ((a1807 (car r1806))) (if (eq? (cadr a1807) (quote macro)) (cons a1807 (macros-only-env1078 (cdr r1806))) (macros-only-env1078 (cdr r1806))))))) (extend-var-env1077 (lambda (labels1808 vars1809 r1810) (if (null? labels1808) r1810 (extend-var-env1077 (cdr labels1808) (cdr vars1809) (cons (cons (car labels1808) (cons (quote lexical) (car vars1809))) r1810))))) (extend-env1076 (lambda (labels1811 bindings1812 r1813) (if (null? labels1811) r1813 (extend-env1076 (cdr labels1811) (cdr bindings1812) (cons (cons (car labels1811) (car bindings1812)) r1813))))) (binding-value1075 cdr) (binding-type1074 car) (source-annotation1073 (lambda (x1814) (cond ((annotation? x1814) (annotation-source x1814)) ((syntax-object?1066 x1814) (source-annotation1073 (syntax-object-expression1067 x1814))) (else #f)))) (set-syntax-object-module!1072 (lambda (x1815 update1816) (vector-set! x1815 3 update1816))) (set-syntax-object-wrap!1071 (lambda (x1817 update1818) (vector-set! x1817 2 update1818))) (set-syntax-object-expression!1070 (lambda (x1819 update1820) (vector-set! x1819 1 update1820))) (syntax-object-module1069 (lambda (x1821) (vector-ref x1821 3))) (syntax-object-wrap1068 (lambda (x1822) (vector-ref x1822 2))) (syntax-object-expression1067 (lambda (x1823) (vector-ref x1823 1))) (syntax-object?1066 (lambda (x1824) (and (vector? x1824) (= (vector-length x1824) 4) (eq? (vector-ref x1824 0) (quote syntax-object))))) (make-syntax-object1065 (lambda (expression1825 wrap1826 module1827) (vector (quote syntax-object) expression1825 wrap1826 module1827))) (build-letrec1064 (lambda (src1828 vars1829 val-exps1830 body-exp1831) (if (null? vars1829) (build-annotated1059 src1828 body-exp1831) (build-annotated1059 src1828 (list (quote letrec) (map list vars1829 val-exps1830) body-exp1831))))) (build-named-let1063 (lambda (src1832 vars1833 val-exps1834 body-exp1835) (if (null? vars1833) (build-annotated1059 src1832 body-exp1835) (build-annotated1059 src1832 (list (quote let) (car vars1833) (map list (cdr vars1833) val-exps1834) body-exp1835))))) (build-let1062 (lambda (src1836 vars1837 val-exps1838 body-exp1839) (if (null? vars1837) (build-annotated1059 src1836 body-exp1839) (build-annotated1059 src1836 (list (quote let) (map list vars1837 val-exps1838) body-exp1839))))) (build-sequence1061 (lambda (src1840 exps1841) (if (null? (cdr exps1841)) (build-annotated1059 src1840 (car exps1841)) (build-annotated1059 src1840 (cons (quote begin) exps1841))))) (build-data1060 (lambda (src1842 exp1843) (if (and (self-evaluating? exp1843) (not (vector? exp1843))) (build-annotated1059 src1842 exp1843) (build-annotated1059 src1842 (list (quote quote) exp1843))))) (build-annotated1059 (lambda (src1844 exp1845) (if (and src1844 (not (annotation? exp1845))) (make-annotation exp1845 src1844 #t) exp1845))) (get-global-definition-hook1058 (lambda (symbol1846 module1847) (begin (if (and (not module1847) (current-module)) (warn "module system is booted, we should have a module" symbol1846)) (let ((v1848 (module-variable (if module1847 (resolve-module (cdr module1847)) (current-module)) symbol1846))) (and v1848 (variable-bound? v1848) (let ((val1849 (variable-ref v1848))) (and (macro? val1849) (syncase-macro-type val1849) (cons (syncase-macro-type val1849) (syncase-macro-binding val1849))))))))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (let ((existing1853 (let ((v1854 (module-variable (current-module) symbol1850))) (and v1854 (variable-bound? v1854) (let ((val1855 (variable-ref v1854))) (and (macro? val1855) (not (syncase-macro-type val1855)) val1855)))))) (module-define! (current-module) symbol1850 (if existing1853 (make-extended-syncase-macro existing1853 type1851 val1852) (make-syncase-macro type1851 val1852)))))) (error-hook1056 (lambda (who1856 why1857 what1858) (error who1856 "~a ~s" why1857 what1858))) (local-eval-hook1055 (lambda (x1859 mod1860) (primitive-eval (list noexpand1049 x1859)))) (top-level-eval-hook1054 (lambda (x1861 mod1862) (primitive-eval (list noexpand1049 x1861)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1080 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1080 (quote local-syntax) (quote let-syntax) #f) (global-extend1080 (quote core) (quote fluid-let-syntax) (lambda (e1863 r1864 w1865 s1866 mod1867) ((lambda (tmp1868) ((lambda (tmp1869) (if (if tmp1869 (apply (lambda (_1870 var1871 val1872 e11873 e21874) (valid-bound-ids?1107 var1871)) tmp1869) #f) (apply (lambda (_1876 var1877 val1878 e11879 e21880) (let ((names1881 (map (lambda (x1882) (id-var-name1104 x1882 w1865)) var1877))) (begin (for-each (lambda (id1884 n1885) (let ((t1886 (binding-type1074 (lookup1079 n1885 r1864 mod1867)))) (if (memv t1886 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1863 (source-wrap1111 id1884 w1865 s1866 mod1867))))) var1877 names1881) (chi-body1122 (cons e11879 e21880) (source-wrap1111 e1863 w1865 s1866 mod1867) (extend-env1076 names1881 (let ((trans-r1889 (macros-only-env1078 r1864))) (map (lambda (x1890) (cons (quote macro) (eval-local-transformer1125 (chi1118 x1890 trans-r1889 w1865 mod1867) mod1867))) val1878)) r1864) w1865 mod1867)))) tmp1869) ((lambda (_1892) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1111 e1863 w1865 s1866 mod1867))) tmp1868))) ($sc-dispatch tmp1868 (quote (any #(each (any any)) any . each-any))))) e1863))) (global-extend1080 (quote core) (quote quote) (lambda (e1893 r1894 w1895 s1896 mod1897) ((lambda (tmp1898) ((lambda (tmp1899) (if tmp1899 (apply (lambda (_1900 e1901) (build-data1060 s1896 (strip1129 e1901 w1895))) tmp1899) ((lambda (_1902) (syntax-violation (quote quote) "bad syntax" (source-wrap1111 e1893 w1895 s1896 mod1897))) tmp1898))) ($sc-dispatch tmp1898 (quote (any any))))) e1893))) (global-extend1080 (quote core) (quote syntax) (letrec ((regen1910 (lambda (x1911) (let ((t1912 (car x1911))) (if (memv t1912 (quote (ref))) (build-annotated1059 #f (cadr x1911)) (if (memv t1912 (quote (primitive))) (build-annotated1059 #f (cadr x1911)) (if (memv t1912 (quote (quote))) (build-data1060 #f (cadr x1911)) (if (memv t1912 (quote (lambda))) (build-annotated1059 #f (list (quote lambda) (cadr x1911) (regen1910 (caddr x1911)))) (if (memv t1912 (quote (map))) (let ((ls1913 (map regen1910 (cdr x1911)))) (build-annotated1059 #f (cons (if (fx=1052 (length ls1913) 2) (build-annotated1059 #f (quote map)) (build-annotated1059 #f (quote map))) ls1913))) (build-annotated1059 #f (cons (build-annotated1059 #f (car x1911)) (map regen1910 (cdr x1911)))))))))))) (gen-vector1909 (lambda (x1914) (cond ((eq? (car x1914) (quote list)) (cons (quote vector) (cdr x1914))) ((eq? (car x1914) (quote quote)) (list (quote quote) (list->vector (cadr x1914)))) (else (list (quote list->vector) x1914))))) (gen-append1908 (lambda (x1915 y1916) (if (equal? y1916 (quote (quote ()))) x1915 (list (quote append) x1915 y1916)))) (gen-cons1907 (lambda (x1917 y1918) (let ((t1919 (car y1918))) (if (memv t1919 (quote (quote))) (if (eq? (car x1917) (quote quote)) (list (quote quote) (cons (cadr x1917) (cadr y1918))) (if (eq? (cadr y1918) (quote ())) (list (quote list) x1917) (list (quote cons) x1917 y1918))) (if (memv t1919 (quote (list))) (cons (quote list) (cons x1917 (cdr y1918))) (list (quote cons) x1917 y1918)))))) (gen-map1906 (lambda (e1920 map-env1921) (let ((formals1922 (map cdr map-env1921)) (actuals1923 (map (lambda (x1924) (list (quote ref) (car x1924))) map-env1921))) (cond ((eq? (car e1920) (quote ref)) (car actuals1923)) ((andmap (lambda (x1925) (and (eq? (car x1925) (quote ref)) (memq (cadr x1925) formals1922))) (cdr e1920)) (cons (quote map) (cons (list (quote primitive) (car e1920)) (map (let ((r1926 (map cons formals1922 actuals1923))) (lambda (x1927) (cdr (assq (cadr x1927) r1926)))) (cdr e1920))))) (else (cons (quote map) (cons (list (quote lambda) formals1922 e1920) actuals1923))))))) (gen-mappend1905 (lambda (e1928 map-env1929) (list (quote apply) (quote (primitive append)) (gen-map1906 e1928 map-env1929)))) (gen-ref1904 (lambda (src1930 var1931 level1932 maps1933) (if (fx=1052 level1932 0) (values var1931 maps1933) (if (null? maps1933) (syntax-violation (quote syntax) "missing ellipsis" src1930) (call-with-values (lambda () (gen-ref1904 src1930 var1931 (fx-1051 level1932 1) (cdr maps1933))) (lambda (outer-var1934 outer-maps1935) (let ((b1936 (assq outer-var1934 (car maps1933)))) (if b1936 (values (cdr b1936) maps1933) (let ((inner-var1937 (gen-var1130 (quote tmp)))) (values inner-var1937 (cons (cons (cons outer-var1934 inner-var1937) (car maps1933)) outer-maps1935))))))))))) (gen-syntax1903 (lambda (src1938 e1939 r1940 maps1941 ellipsis?1942 mod1943) (if (id?1082 e1939) (let ((label1944 (id-var-name1104 e1939 (quote (()))))) (let ((b1945 (lookup1079 label1944 r1940 mod1943))) (if (eq? (binding-type1074 b1945) (quote syntax)) (call-with-values (lambda () (let ((var.lev1946 (binding-value1075 b1945))) (gen-ref1904 src1938 (car var.lev1946) (cdr var.lev1946) maps1941))) (lambda (var1947 maps1948) (values (list (quote ref) var1947) maps1948))) (if (ellipsis?1942 e1939) (syntax-violation (quote syntax) "misplaced ellipsis" src1938) (values (list (quote quote) e1939) maps1941))))) ((lambda (tmp1949) ((lambda (tmp1950) (if (if tmp1950 (apply (lambda (dots1951 e1952) (ellipsis?1942 dots1951)) tmp1950) #f) (apply (lambda (dots1953 e1954) (gen-syntax1903 src1938 e1954 r1940 maps1941 (lambda (x1955) #f) mod1943)) tmp1950) ((lambda (tmp1956) (if (if tmp1956 (apply (lambda (x1957 dots1958 y1959) (ellipsis?1942 dots1958)) tmp1956) #f) (apply (lambda (x1960 dots1961 y1962) (let f1963 ((y1964 y1962) (k1965 (lambda (maps1966) (call-with-values (lambda () (gen-syntax1903 src1938 x1960 r1940 (cons (quote ()) maps1966) ellipsis?1942 mod1943)) (lambda (x1967 maps1968) (if (null? (car maps1968)) (syntax-violation (quote syntax) "extra ellipsis" src1938) (values (gen-map1906 x1967 (car maps1968)) (cdr maps1968)))))))) ((lambda (tmp1969) ((lambda (tmp1970) (if (if tmp1970 (apply (lambda (dots1971 y1972) (ellipsis?1942 dots1971)) tmp1970) #f) (apply (lambda (dots1973 y1974) (f1963 y1974 (lambda (maps1975) (call-with-values (lambda () (k1965 (cons (quote ()) maps1975))) (lambda (x1976 maps1977) (if (null? (car maps1977)) (syntax-violation (quote syntax) "extra ellipsis" src1938) (values (gen-mappend1905 x1976 (car maps1977)) (cdr maps1977)))))))) tmp1970) ((lambda (_1978) (call-with-values (lambda () (gen-syntax1903 src1938 y1964 r1940 maps1941 ellipsis?1942 mod1943)) (lambda (y1979 maps1980) (call-with-values (lambda () (k1965 maps1980)) (lambda (x1981 maps1982) (values (gen-append1908 x1981 y1979) maps1982)))))) tmp1969))) ($sc-dispatch tmp1969 (quote (any . any))))) y1964))) tmp1956) ((lambda (tmp1983) (if tmp1983 (apply (lambda (x1984 y1985) (call-with-values (lambda () (gen-syntax1903 src1938 x1984 r1940 maps1941 ellipsis?1942 mod1943)) (lambda (x1986 maps1987) (call-with-values (lambda () (gen-syntax1903 src1938 y1985 r1940 maps1987 ellipsis?1942 mod1943)) (lambda (y1988 maps1989) (values (gen-cons1907 x1986 y1988) maps1989)))))) tmp1983) ((lambda (tmp1990) (if tmp1990 (apply (lambda (e11991 e21992) (call-with-values (lambda () (gen-syntax1903 src1938 (cons e11991 e21992) r1940 maps1941 ellipsis?1942 mod1943)) (lambda (e1994 maps1995) (values (gen-vector1909 e1994) maps1995)))) tmp1990) ((lambda (_1996) (values (list (quote quote) e1939) maps1941)) tmp1949))) ($sc-dispatch tmp1949 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1949 (quote (any . any)))))) ($sc-dispatch tmp1949 (quote (any any . any)))))) ($sc-dispatch tmp1949 (quote (any any))))) e1939))))) (lambda (e1997 r1998 w1999 s2000 mod2001) (let ((e2002 (source-wrap1111 e1997 w1999 s2000 mod2001))) ((lambda (tmp2003) ((lambda (tmp2004) (if tmp2004 (apply (lambda (_2005 x2006) (call-with-values (lambda () (gen-syntax1903 e2002 x2006 r1998 (quote ()) ellipsis?1127 mod2001)) (lambda (e2007 maps2008) (regen1910 e2007)))) tmp2004) ((lambda (_2009) (syntax-violation (quote syntax) "bad `syntax' form" e2002)) tmp2003))) ($sc-dispatch tmp2003 (quote (any any))))) e2002))))) (global-extend1080 (quote core) (quote lambda) (lambda (e2010 r2011 w2012 s2013 mod2014) ((lambda (tmp2015) ((lambda (tmp2016) (if tmp2016 (apply (lambda (_2017 c2018) (chi-lambda-clause1123 (source-wrap1111 e2010 w2012 s2013 mod2014) #f c2018 r2011 w2012 mod2014 (lambda (vars2019 docstring2020 body2021) (build-annotated1059 s2013 (cons (quote lambda) (cons vars2019 (append (if docstring2020 (list docstring2020) (quote ())) (list body2021)))))))) tmp2016) (syntax-violation #f "source expression failed to match any pattern" tmp2015))) ($sc-dispatch tmp2015 (quote (any . any))))) e2010))) (global-extend1080 (quote core) (quote let) (letrec ((chi-let2022 (lambda (e2023 r2024 w2025 s2026 mod2027 constructor2028 ids2029 vals2030 exps2031) (if (not (valid-bound-ids?1107 ids2029)) (syntax-violation (quote let) "duplicate bound variable" e2023) (let ((labels2032 (gen-labels1088 ids2029)) (new-vars2033 (map gen-var1130 ids2029))) (let ((nw2034 (make-binding-wrap1099 ids2029 labels2032 w2025)) (nr2035 (extend-var-env1077 labels2032 new-vars2033 r2024))) (constructor2028 s2026 new-vars2033 (map (lambda (x2036) (chi1118 x2036 r2024 w2025 mod2027)) vals2030) (chi-body1122 exps2031 (source-wrap1111 e2023 nw2034 s2026 mod2027) nr2035 nw2034 mod2027)))))))) (lambda (e2037 r2038 w2039 s2040 mod2041) ((lambda (tmp2042) ((lambda (tmp2043) (if tmp2043 (apply (lambda (_2044 id2045 val2046 e12047 e22048) (chi-let2022 e2037 r2038 w2039 s2040 mod2041 build-let1062 id2045 val2046 (cons e12047 e22048))) tmp2043) ((lambda (tmp2052) (if (if tmp2052 (apply (lambda (_2053 f2054 id2055 val2056 e12057 e22058) (id?1082 f2054)) tmp2052) #f) (apply (lambda (_2059 f2060 id2061 val2062 e12063 e22064) (chi-let2022 e2037 r2038 w2039 s2040 mod2041 build-named-let1063 (cons f2060 id2061) val2062 (cons e12063 e22064))) tmp2052) ((lambda (_2068) (syntax-violation (quote let) "bad let" (source-wrap1111 e2037 w2039 s2040 mod2041))) tmp2042))) ($sc-dispatch tmp2042 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2042 (quote (any #(each (any any)) any . each-any))))) e2037)))) (global-extend1080 (quote core) (quote letrec) (lambda (e2069 r2070 w2071 s2072 mod2073) ((lambda (tmp2074) ((lambda (tmp2075) (if tmp2075 (apply (lambda (_2076 id2077 val2078 e12079 e22080) (let ((ids2081 id2077)) (if (not (valid-bound-ids?1107 ids2081)) (syntax-violation (quote letrec) "duplicate bound variable" e2069) (let ((labels2083 (gen-labels1088 ids2081)) (new-vars2084 (map gen-var1130 ids2081))) (let ((w2085 (make-binding-wrap1099 ids2081 labels2083 w2071)) (r2086 (extend-var-env1077 labels2083 new-vars2084 r2070))) (build-letrec1064 s2072 new-vars2084 (map (lambda (x2087) (chi1118 x2087 r2086 w2085 mod2073)) val2078) (chi-body1122 (cons e12079 e22080) (source-wrap1111 e2069 w2085 s2072 mod2073) r2086 w2085 mod2073))))))) tmp2075) ((lambda (_2090) (syntax-violation (quote letrec) "bad letrec" (source-wrap1111 e2069 w2071 s2072 mod2073))) tmp2074))) ($sc-dispatch tmp2074 (quote (any #(each (any any)) any . each-any))))) e2069))) (global-extend1080 (quote core) (quote set!) (lambda (e2091 r2092 w2093 s2094 mod2095) ((lambda (tmp2096) ((lambda (tmp2097) (if (if tmp2097 (apply (lambda (_2098 id2099 val2100) (id?1082 id2099)) tmp2097) #f) (apply (lambda (_2101 id2102 val2103) (let ((val2104 (chi1118 val2103 r2092 w2093 mod2095)) (n2105 (id-var-name1104 id2102 w2093))) (let ((b2106 (lookup1079 n2105 r2092 mod2095))) (let ((t2107 (binding-type1074 b2106))) (if (memv t2107 (quote (lexical))) (build-annotated1059 s2094 (list (quote set!) (binding-value1075 b2106) val2104)) (if (memv t2107 (quote (global))) (build-annotated1059 s2094 (list (quote set!) (if mod2095 (make-module-ref (cdr mod2095) n2105 (car mod2095)) (make-module-ref mod2095 n2105 (quote bare))) val2104)) (if (memv t2107 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1110 id2102 w2093 mod2095)) (syntax-violation (quote set!) "bad set!" (source-wrap1111 e2091 w2093 s2094 mod2095))))))))) tmp2097) ((lambda (tmp2108) (if tmp2108 (apply (lambda (_2109 head2110 tail2111 val2112) (call-with-values (lambda () (syntax-type1116 head2110 r2092 (quote (())) #f #f mod2095)) (lambda (type2113 value2114 ee2115 ww2116 ss2117 modmod2118) (let ((t2119 type2113)) (if (memv t2119 (quote (module-ref))) (let ((val2120 (chi1118 val2112 r2092 w2093 mod2095))) (call-with-values (lambda () (value2114 (cons head2110 tail2111))) (lambda (id2122 mod2123) (build-annotated1059 s2094 (list (quote set!) (if mod2123 (make-module-ref (cdr mod2123) id2122 (car mod2123)) (make-module-ref mod2123 id2122 (quote bare))) val2120))))) (build-annotated1059 s2094 (cons (chi1118 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2110) r2092 w2093 mod2095) (map (lambda (e2124) (chi1118 e2124 r2092 w2093 mod2095)) (append tail2111 (list val2112)))))))))) tmp2108) ((lambda (_2126) (syntax-violation (quote set!) "bad set!" (source-wrap1111 e2091 w2093 s2094 mod2095))) tmp2096))) ($sc-dispatch tmp2096 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2096 (quote (any any any))))) e2091))) (global-extend1080 (quote module-ref) (quote @) (lambda (e2127) ((lambda (tmp2128) ((lambda (tmp2129) (if (if tmp2129 (apply (lambda (_2130 mod2131 id2132) (and (andmap id?1082 mod2131) (id?1082 id2132))) tmp2129) #f) (apply (lambda (_2134 mod2135 id2136) (values (syntax->datum id2136) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2135)))) tmp2129) (syntax-violation #f "source expression failed to match any pattern" tmp2128))) ($sc-dispatch tmp2128 (quote (any each-any any))))) e2127))) (global-extend1080 (quote module-ref) (quote @@) (lambda (e2138) ((lambda (tmp2139) ((lambda (tmp2140) (if (if tmp2140 (apply (lambda (_2141 mod2142 id2143) (and (andmap id?1082 mod2142) (id?1082 id2143))) tmp2140) #f) (apply (lambda (_2145 mod2146 id2147) (values (syntax->datum id2147) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2146)))) tmp2140) (syntax-violation #f "source expression failed to match any pattern" tmp2139))) ($sc-dispatch tmp2139 (quote (any each-any any))))) e2138))) (global-extend1080 (quote begin) (quote begin) (quote ())) (global-extend1080 (quote define) (quote define) (quote ())) (global-extend1080 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1080 (quote eval-when) (quote eval-when) (quote ())) (global-extend1080 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2152 (lambda (x2153 keys2154 clauses2155 r2156 mod2157) (if (null? clauses2155) (build-annotated1059 #f (list (build-annotated1059 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2153)) ((lambda (tmp2158) ((lambda (tmp2159) (if tmp2159 (apply (lambda (pat2160 exp2161) (if (and (id?1082 pat2160) (andmap (lambda (x2162) (not (free-id=?1105 pat2160 x2162))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2154))) (let ((labels2163 (list (gen-label1087))) (var2164 (gen-var1130 pat2160))) (build-annotated1059 #f (list (build-annotated1059 #f (list (quote lambda) (list var2164) (chi1118 exp2161 (extend-env1076 labels2163 (list (cons (quote syntax) (cons var2164 0))) r2156) (make-binding-wrap1099 (list pat2160) labels2163 (quote (()))) mod2157))) x2153))) (gen-clause2151 x2153 keys2154 (cdr clauses2155) r2156 pat2160 #t exp2161 mod2157))) tmp2159) ((lambda (tmp2165) (if tmp2165 (apply (lambda (pat2166 fender2167 exp2168) (gen-clause2151 x2153 keys2154 (cdr clauses2155) r2156 pat2166 fender2167 exp2168 mod2157)) tmp2165) ((lambda (_2169) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2155))) tmp2158))) ($sc-dispatch tmp2158 (quote (any any any)))))) ($sc-dispatch tmp2158 (quote (any any))))) (car clauses2155))))) (gen-clause2151 (lambda (x2170 keys2171 clauses2172 r2173 pat2174 fender2175 exp2176 mod2177) (call-with-values (lambda () (convert-pattern2149 pat2174 keys2171)) (lambda (p2178 pvars2179) (cond ((not (distinct-bound-ids?1108 (map car pvars2179))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2174)) ((not (andmap (lambda (x2180) (not (ellipsis?1127 (car x2180)))) pvars2179)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2174)) (else (let ((y2181 (gen-var1130 (quote tmp)))) (build-annotated1059 #f (list (build-annotated1059 #f (list (quote lambda) (list y2181) (let ((y2182 (build-annotated1059 #f y2181))) (build-annotated1059 #f (list (quote if) ((lambda (tmp2183) ((lambda (tmp2184) (if tmp2184 (apply (lambda () y2182) tmp2184) ((lambda (_2185) (build-annotated1059 #f (list (quote if) y2182 (build-dispatch-call2150 pvars2179 fender2175 y2182 r2173 mod2177) (build-data1060 #f #f)))) tmp2183))) ($sc-dispatch tmp2183 (quote #(atom #t))))) fender2175) (build-dispatch-call2150 pvars2179 exp2176 y2182 r2173 mod2177) (gen-syntax-case2152 x2170 keys2171 clauses2172 r2173 mod2177)))))) (if (eq? p2178 (quote any)) (build-annotated1059 #f (list (build-annotated1059 #f (quote list)) x2170)) (build-annotated1059 #f (list (build-annotated1059 #f (quote $sc-dispatch)) x2170 (build-data1060 #f p2178))))))))))))) (build-dispatch-call2150 (lambda (pvars2186 exp2187 y2188 r2189 mod2190) (let ((ids2191 (map car pvars2186)) (levels2192 (map cdr pvars2186))) (let ((labels2193 (gen-labels1088 ids2191)) (new-vars2194 (map gen-var1130 ids2191))) (build-annotated1059 #f (list (build-annotated1059 #f (quote apply)) (build-annotated1059 #f (list (quote lambda) new-vars2194 (chi1118 exp2187 (extend-env1076 labels2193 (map (lambda (var2195 level2196) (cons (quote syntax) (cons var2195 level2196))) new-vars2194 (map cdr pvars2186)) r2189) (make-binding-wrap1099 ids2191 labels2193 (quote (()))) mod2190))) y2188)))))) (convert-pattern2149 (lambda (pattern2197 keys2198) (let cvt2199 ((p2200 pattern2197) (n2201 0) (ids2202 (quote ()))) (if (id?1082 p2200) (if (bound-id-member?1109 p2200 keys2198) (values (vector (quote free-id) p2200) ids2202) (values (quote any) (cons (cons p2200 n2201) ids2202))) ((lambda (tmp2203) ((lambda (tmp2204) (if (if tmp2204 (apply (lambda (x2205 dots2206) (ellipsis?1127 dots2206)) tmp2204) #f) (apply (lambda (x2207 dots2208) (call-with-values (lambda () (cvt2199 x2207 (fx+1050 n2201 1) ids2202)) (lambda (p2209 ids2210) (values (if (eq? p2209 (quote any)) (quote each-any) (vector (quote each) p2209)) ids2210)))) tmp2204) ((lambda (tmp2211) (if tmp2211 (apply (lambda (x2212 y2213) (call-with-values (lambda () (cvt2199 y2213 n2201 ids2202)) (lambda (y2214 ids2215) (call-with-values (lambda () (cvt2199 x2212 n2201 ids2215)) (lambda (x2216 ids2217) (values (cons x2216 y2214) ids2217)))))) tmp2211) ((lambda (tmp2218) (if tmp2218 (apply (lambda () (values (quote ()) ids2202)) tmp2218) ((lambda (tmp2219) (if tmp2219 (apply (lambda (x2220) (call-with-values (lambda () (cvt2199 x2220 n2201 ids2202)) (lambda (p2222 ids2223) (values (vector (quote vector) p2222) ids2223)))) tmp2219) ((lambda (x2224) (values (vector (quote atom) (strip1129 p2200 (quote (())))) ids2202)) tmp2203))) ($sc-dispatch tmp2203 (quote #(vector each-any)))))) ($sc-dispatch tmp2203 (quote ()))))) ($sc-dispatch tmp2203 (quote (any . any)))))) ($sc-dispatch tmp2203 (quote (any any))))) p2200)))))) (lambda (e2225 r2226 w2227 s2228 mod2229) (let ((e2230 (source-wrap1111 e2225 w2227 s2228 mod2229))) ((lambda (tmp2231) ((lambda (tmp2232) (if tmp2232 (apply (lambda (_2233 val2234 key2235 m2236) (if (andmap (lambda (x2237) (and (id?1082 x2237) (not (ellipsis?1127 x2237)))) key2235) (let ((x2239 (gen-var1130 (quote tmp)))) (build-annotated1059 s2228 (list (build-annotated1059 #f (list (quote lambda) (list x2239) (gen-syntax-case2152 (build-annotated1059 #f x2239) key2235 m2236 r2226 mod2229))) (chi1118 val2234 r2226 (quote (())) mod2229)))) (syntax-violation (quote syntax-case) "invalid literals list" e2230))) tmp2232) (syntax-violation #f "source expression failed to match any pattern" tmp2231))) ($sc-dispatch tmp2231 (quote (any any each-any . each-any))))) e2230))))) (set! sc-expand (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2244) (if (and (pair? x2244) (equal? (car x2244) noexpand1049)) (cadr x2244) (chi-top1117 x2244 (quote ()) (quote ((top))) m2242 esew2243 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2245 (quote e)) (esew2246 (quote (eval)))) (lambda (x2248 . rest2247) (if (and (pair? x2248) (equal? (car x2248) noexpand1049)) (cadr x2248) (chi-top1117 x2248 (quote ()) (quote ((top))) (if (null? rest2247) m2245 (car rest2247)) (if (or (null? rest2247) (null? (cdr rest2247))) esew2246 (cadr rest2247)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2249) (nonsymbol-id?1081 x2249))) (set! datum->syntax (lambda (id2250 datum2251) (make-syntax-object1065 datum2251 (syntax-object-wrap1068 id2250) #f))) (set! syntax->datum (lambda (x2252) (strip1129 x2252 (quote (()))))) (set! generate-temporaries (lambda (ls2253) (begin (let ((x2254 ls2253)) (if (not (list? x2254)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2254))) (map (lambda (x2255) (wrap1110 (gensym) (quote ((top))) #f)) ls2253)))) (set! free-identifier=? (lambda (x2256 y2257) (begin (let ((x2258 x2256)) (if (not (nonsymbol-id?1081 x2258)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2258))) (let ((x2259 y2257)) (if (not (nonsymbol-id?1081 x2259)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2259))) (free-id=?1105 x2256 y2257)))) (set! bound-identifier=? (lambda (x2260 y2261) (begin (let ((x2262 x2260)) (if (not (nonsymbol-id?1081 x2262)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2262))) (let ((x2263 y2261)) (if (not (nonsymbol-id?1081 x2263)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2263))) (bound-id=?1106 x2260 y2261)))) (set! syntax-violation (lambda (who2267 message2266 form2265 . subform2264) (begin (let ((x2268 who2267)) (if (not ((lambda (x2269) (or (not x2269) (string? x2269) (symbol? x2269))) x2268)) (error-hook1056 (quote syntax-violation) "invalid argument" x2268))) (let ((x2270 message2266)) (if (not (string? x2270)) (error-hook1056 (quote syntax-violation) "invalid argument" x2270))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2267 "~a: " "") "~a " (if (null? subform2264) "in ~a" "in subform `~s' of `~s'")) (let ((tail2271 (cons message2266 (map (lambda (x2272) (strip1129 x2272 (quote (())))) (append subform2264 (list form2265)))))) (if who2267 (cons who2267 tail2271) tail2271)) #f)))) (set! install-global-transformer (lambda (sym2273 v2274) (begin (let ((x2275 sym2273)) (if (not (symbol? x2275)) (error-hook1056 (quote define-syntax) "invalid argument" x2275))) (let ((x2276 v2274)) (if (not (procedure? x2276)) (error-hook1056 (quote define-syntax) "invalid argument" x2276))) (global-extend1080 (quote macro) sym2273 v2274)))) (letrec ((match2281 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((not r2285) #f) ((eq? p2283 (quote any)) (cons (wrap1110 e2282 w2284 mod2286) r2285)) ((syntax-object?1066 e2282) (match*2280 (let ((e2287 (syntax-object-expression1067 e2282))) (if (annotation? e2287) (annotation-expression e2287) e2287)) p2283 (join-wraps1101 w2284 (syntax-object-wrap1068 e2282)) r2285 (syntax-object-module1069 e2282))) (else (match*2280 (let ((e2288 e2282)) (if (annotation? e2288) (annotation-expression e2288) e2288)) p2283 w2284 r2285 mod2286))))) (match*2280 (lambda (e2289 p2290 w2291 r2292 mod2293) (cond ((null? p2290) (and (null? e2289) r2292)) ((pair? p2290) (and (pair? e2289) (match2281 (car e2289) (car p2290) w2291 (match2281 (cdr e2289) (cdr p2290) w2291 r2292 mod2293) mod2293))) ((eq? p2290 (quote each-any)) (let ((l2294 (match-each-any2278 e2289 w2291 mod2293))) (and l2294 (cons l2294 r2292)))) (else (let ((t2295 (vector-ref p2290 0))) (if (memv t2295 (quote (each))) (if (null? e2289) (match-empty2279 (vector-ref p2290 1) r2292) (let ((l2296 (match-each2277 e2289 (vector-ref p2290 1) w2291 mod2293))) (and l2296 (let collect2297 ((l2298 l2296)) (if (null? (car l2298)) r2292 (cons (map car l2298) (collect2297 (map cdr l2298)))))))) (if (memv t2295 (quote (free-id))) (and (id?1082 e2289) (free-id=?1105 (wrap1110 e2289 w2291 mod2293) (vector-ref p2290 1)) r2292) (if (memv t2295 (quote (atom))) (and (equal? (vector-ref p2290 1) (strip1129 e2289 w2291)) r2292) (if (memv t2295 (quote (vector))) (and (vector? e2289) (match2281 (vector->list e2289) (vector-ref p2290 1) w2291 r2292 mod2293))))))))))) (match-empty2279 (lambda (p2299 r2300) (cond ((null? p2299) r2300) ((eq? p2299 (quote any)) (cons (quote ()) r2300)) ((pair? p2299) (match-empty2279 (car p2299) (match-empty2279 (cdr p2299) r2300))) ((eq? p2299 (quote each-any)) (cons (quote ()) r2300)) (else (let ((t2301 (vector-ref p2299 0))) (if (memv t2301 (quote (each))) (match-empty2279 (vector-ref p2299 1) r2300) (if (memv t2301 (quote (free-id atom))) r2300 (if (memv t2301 (quote (vector))) (match-empty2279 (vector-ref p2299 1) r2300))))))))) (match-each-any2278 (lambda (e2302 w2303 mod2304) (cond ((annotation? e2302) (match-each-any2278 (annotation-expression e2302) w2303 mod2304)) ((pair? e2302) (let ((l2305 (match-each-any2278 (cdr e2302) w2303 mod2304))) (and l2305 (cons (wrap1110 (car e2302) w2303 mod2304) l2305)))) ((null? e2302) (quote ())) ((syntax-object?1066 e2302) (match-each-any2278 (syntax-object-expression1067 e2302) (join-wraps1101 w2303 (syntax-object-wrap1068 e2302)) mod2304)) (else #f)))) (match-each2277 (lambda (e2306 p2307 w2308 mod2309) (cond ((annotation? e2306) (match-each2277 (annotation-expression e2306) p2307 w2308 mod2309)) ((pair? e2306) (let ((first2310 (match2281 (car e2306) p2307 w2308 (quote ()) mod2309))) (and first2310 (let ((rest2311 (match-each2277 (cdr e2306) p2307 w2308 mod2309))) (and rest2311 (cons first2310 rest2311)))))) ((null? e2306) (quote ())) ((syntax-object?1066 e2306) (match-each2277 (syntax-object-expression1067 e2306) p2307 (join-wraps1101 w2308 (syntax-object-wrap1068 e2306)) (syntax-object-module1069 e2306))) (else #f))))) (set! $sc-dispatch (lambda (e2312 p2313) (cond ((eq? p2313 (quote any)) (list e2312)) ((syntax-object?1066 e2312) (match*2280 (let ((e2314 (syntax-object-expression1067 e2312))) (if (annotation? e2314) (annotation-expression e2314) e2314)) p2313 (syntax-object-wrap1068 e2312) (quote ()) (syntax-object-module1069 e2312))) (else (match*2280 (let ((e2315 e2312)) (if (annotation? e2315) (annotation-expression e2315) e2315)) p2313 (quote (())) (quote ()) #f)))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2316) ((lambda (tmp2317) ((lambda (tmp2318) (if tmp2318 (apply (lambda (_2319 e12320 e22321) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12320 e22321))) tmp2318) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2326 (quote ()) (list out2325 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12327 e22328))))) tmp2323) ((lambda (tmp2330) (if tmp2330 (apply (lambda (_2331 out2332 in2333 e12334 e22335) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2333) (quote ()) (list out2332 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12334 e22335))))) tmp2330) (syntax-violation #f "source expression failed to match any pattern" tmp2317))) ($sc-dispatch tmp2317 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2317 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2317 (quote (any () any . each-any))))) x2316)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2339) ((lambda (tmp2340) ((lambda (tmp2341) (if tmp2341 (apply (lambda (_2342 k2343 keyword2344 pattern2345 template2346) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2343 (map (lambda (tmp2349 tmp2348) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2348) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2349))) template2346 pattern2345)))))) tmp2341) (syntax-violation #f "source expression failed to match any pattern" tmp2340))) ($sc-dispatch tmp2340 (quote (any each-any . #(each ((any . any) any))))))) x2339)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2350) ((lambda (tmp2351) ((lambda (tmp2352) (if (if tmp2352 (apply (lambda (let*2353 x2354 v2355 e12356 e22357) (andmap identifier? x2354)) tmp2352) #f) (apply (lambda (let*2359 x2360 v2361 e12362 e22363) (let f2364 ((bindings2365 (map list x2360 v2361))) (if (null? bindings2365) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12362 e22363))) ((lambda (tmp2369) ((lambda (tmp2370) (if tmp2370 (apply (lambda (body2371 binding2372) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2372) body2371)) tmp2370) (syntax-violation #f "source expression failed to match any pattern" tmp2369))) ($sc-dispatch tmp2369 (quote (any any))))) (list (f2364 (cdr bindings2365)) (car bindings2365)))))) tmp2352) (syntax-violation #f "source expression failed to match any pattern" tmp2351))) ($sc-dispatch tmp2351 (quote (any #(each (any any)) any . each-any))))) x2350)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2373) ((lambda (tmp2374) ((lambda (tmp2375) (if tmp2375 (apply (lambda (_2376 var2377 init2378 step2379 e02380 e12381 c2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply (lambda (step2385) ((lambda (tmp2386) ((lambda (tmp2387) (if tmp2387 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2377 init2378) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02380) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2382 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2385))))))) tmp2387) ((lambda (tmp2392) (if tmp2392 (apply (lambda (e12393 e22394) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2377 init2378) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02380 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12393 e22394)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2382 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2385))))))) tmp2392) (syntax-violation #f "source expression failed to match any pattern" tmp2386))) ($sc-dispatch tmp2386 (quote (any . each-any)))))) ($sc-dispatch tmp2386 (quote ())))) e12381)) tmp2384) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) ($sc-dispatch tmp2383 (quote each-any)))) (map (lambda (v2401 s2402) ((lambda (tmp2403) ((lambda (tmp2404) (if tmp2404 (apply (lambda () v2401) tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (e2406) e2406) tmp2405) ((lambda (_2407) (syntax-violation (quote do) "bad step expression" orig-x2373 s2402)) tmp2403))) ($sc-dispatch tmp2403 (quote (any)))))) ($sc-dispatch tmp2403 (quote ())))) s2402)) var2377 step2379))) tmp2375) (syntax-violation #f "source expression failed to match any pattern" tmp2374))) ($sc-dispatch tmp2374 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2373)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2410 (lambda (x2414 y2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (x2418 y2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dy2422) ((lambda (tmp2423) ((lambda (tmp2424) (if tmp2424 (apply (lambda (dx2425) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2425 dy2422))) tmp2424) ((lambda (_2426) (if (null? dy2422) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2418) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2418 y2419))) tmp2423))) ($sc-dispatch tmp2423 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2418)) tmp2421) ((lambda (tmp2427) (if tmp2427 (apply (lambda (stuff2428) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2418 stuff2428))) tmp2427) ((lambda (else2429) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2418 y2419)) tmp2420))) ($sc-dispatch tmp2420 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2420 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2419)) tmp2417) (syntax-violation #f "source expression failed to match any pattern" tmp2416))) ($sc-dispatch tmp2416 (quote (any any))))) (list x2414 y2415)))) (quasiappend2411 (lambda (x2430 y2431) ((lambda (tmp2432) ((lambda (tmp2433) (if tmp2433 (apply (lambda (x2434 y2435) ((lambda (tmp2436) ((lambda (tmp2437) (if tmp2437 (apply (lambda () x2434) tmp2437) ((lambda (_2438) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2434 y2435)) tmp2436))) ($sc-dispatch tmp2436 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2435)) tmp2433) (syntax-violation #f "source expression failed to match any pattern" tmp2432))) ($sc-dispatch tmp2432 (quote (any any))))) (list x2430 y2431)))) (quasivector2412 (lambda (x2439) ((lambda (tmp2440) ((lambda (x2441) ((lambda (tmp2442) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2444))) tmp2443) ((lambda (tmp2446) (if tmp2446 (apply (lambda (x2447) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2447)) tmp2446) ((lambda (_2449) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2441)) tmp2442))) ($sc-dispatch tmp2442 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2442 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2441)) tmp2440)) x2439))) (quasi2413 (lambda (p2450 lev2451) ((lambda (tmp2452) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454) (if (= lev2451 0) p2454 (quasicons2410 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2413 (list p2454) (- lev2451 1))))) tmp2453) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456 q2457) (if (= lev2451 0) (quasiappend2411 p2456 (quasi2413 q2457 lev2451)) (quasicons2410 (quasicons2410 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2413 (list p2456) (- lev2451 1))) (quasi2413 q2457 lev2451)))) tmp2455) ((lambda (tmp2458) (if tmp2458 (apply (lambda (p2459) (quasicons2410 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2413 (list p2459) (+ lev2451 1)))) tmp2458) ((lambda (tmp2460) (if tmp2460 (apply (lambda (p2461 q2462) (quasicons2410 (quasi2413 p2461 lev2451) (quasi2413 q2462 lev2451))) tmp2460) ((lambda (tmp2463) (if tmp2463 (apply (lambda (x2464) (quasivector2412 (quasi2413 x2464 lev2451))) tmp2463) ((lambda (p2466) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2466)) tmp2452))) ($sc-dispatch tmp2452 (quote #(vector each-any)))))) ($sc-dispatch tmp2452 (quote (any . any)))))) ($sc-dispatch tmp2452 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2452 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2452 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2450)))) (lambda (x2467) ((lambda (tmp2468) ((lambda (tmp2469) (if tmp2469 (apply (lambda (_2470 e2471) (quasi2413 e2471 0)) tmp2469) (syntax-violation #f "source expression failed to match any pattern" tmp2468))) ($sc-dispatch tmp2468 (quote (any any))))) x2467))))) +(define include (make-syncase-macro (quote macro) (lambda (x2472) (letrec ((read-file2473 (lambda (fn2474 k2475) (let ((p2476 (open-input-file fn2474))) (let f2477 ((x2478 (read p2476))) (if (eof-object? x2478) (begin (close-input-port p2476) (quote ())) (cons (datum->syntax k2475 x2478) (f2477 (read p2476))))))))) ((lambda (tmp2479) ((lambda (tmp2480) (if tmp2480 (apply (lambda (k2481 filename2482) (let ((fn2483 (syntax->datum filename2482))) ((lambda (tmp2484) ((lambda (tmp2485) (if tmp2485 (apply (lambda (exp2486) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2486)) tmp2485) (syntax-violation #f "source expression failed to match any pattern" tmp2484))) ($sc-dispatch tmp2484 (quote each-any)))) (read-file2473 fn2483 k2481)))) tmp2480) (syntax-violation #f "source expression failed to match any pattern" tmp2479))) ($sc-dispatch tmp2479 (quote (any any))))) x2472))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2488) ((lambda (tmp2489) ((lambda (tmp2490) (if tmp2490 (apply (lambda (_2491 e2492) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2492))) tmp2490) (syntax-violation #f "source expression failed to match any pattern" tmp2489))) ($sc-dispatch tmp2489 (quote (any any))))) x2488)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2493) ((lambda (tmp2494) ((lambda (tmp2495) (if tmp2495 (apply (lambda (_2496 e2497) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2497))) tmp2495) (syntax-violation #f "source expression failed to match any pattern" tmp2494))) ($sc-dispatch tmp2494 (quote (any any))))) x2493)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2498) ((lambda (tmp2499) ((lambda (tmp2500) (if tmp2500 (apply (lambda (_2501 e2502 m12503 m22504) ((lambda (tmp2505) ((lambda (body2506) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2502)) body2506)) tmp2505)) (let f2507 ((clause2508 m12503) (clauses2509 m22504)) (if (null? clauses2509) ((lambda (tmp2511) ((lambda (tmp2512) (if tmp2512 (apply (lambda (e12513 e22514) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12513 e22514))) tmp2512) ((lambda (tmp2516) (if tmp2516 (apply (lambda (k2517 e12518 e22519) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2517)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12518 e22519)))) tmp2516) ((lambda (_2522) (syntax-violation (quote case) "bad clause" x2498 clause2508)) tmp2511))) ($sc-dispatch tmp2511 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2511 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2508) ((lambda (tmp2523) ((lambda (rest2524) ((lambda (tmp2525) ((lambda (tmp2526) (if tmp2526 (apply (lambda (k2527 e12528 e22529) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2527)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12528 e22529)) rest2524)) tmp2526) ((lambda (_2532) (syntax-violation (quote case) "bad clause" x2498 clause2508)) tmp2525))) ($sc-dispatch tmp2525 (quote (each-any any . each-any))))) clause2508)) tmp2523)) (f2507 (car clauses2509) (cdr clauses2509))))))) tmp2500) (syntax-violation #f "source expression failed to match any pattern" tmp2499))) ($sc-dispatch tmp2499 (quote (any any any . each-any))))) x2498)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2533) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (_2536 e2537) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2537)) (list (cons _2536 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2537 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2535) (syntax-violation #f "source expression failed to match any pattern" tmp2534))) ($sc-dispatch tmp2534 (quote (any any))))) x2533)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 0af35dca9..2cf83f771 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -339,19 +339,31 @@ (define put-global-definition-hook (lambda (symbol type val) - (module-define-keyword! (current-module) symbol type val))) - -(define remove-global-definition-hook - (lambda (symbol) - (module-undefine-keyword! (current-module) symbol))) + (let ((existing (let ((v (module-variable (current-module) symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) + (not (syncase-macro-type val)) + val)))))) + (module-define! (current-module) + symbol + (if existing + (make-extended-syncase-macro existing type val) + (make-syncase-macro type val)))))) (define get-global-definition-hook (lambda (symbol module) (if (and (not module) (current-module)) (warn "module system is booted, we should have a module" symbol)) - (module-lookup-keyword (if module (resolve-module (cdr module)) - (current-module)) - symbol))) + (let ((v (module-variable (if module + (resolve-module (cdr module)) + (current-module)) + symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) (syncase-macro-type val) + (cons (syncase-macro-type val) + (syncase-macro-binding val)))))))) ) @@ -897,8 +909,25 @@ (define chi-install-global (lambda (name e) (build-application no-source - (build-primref no-source 'install-global-transformer) - (list (build-data no-source name) e)))) + (build-primref no-source 'define) + (list + name + ;; FIXME: seems nasty to call current-module here + (if (let ((v (module-variable (current-module) name))) + ;; FIXME use primitive-macro? + (and v (variable-bound? v) (macro? (variable-ref v)) + (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) + (build-application no-source + (build-primref no-source 'make-extended-syncase-macro) + (list (build-application no-source + (build-primref no-source 'module-ref) + (list (build-application no-source 'current-module '()) + (build-data no-source name))) + (build-data no-source 'macro) + e)) + (build-application no-source + (build-primref no-source 'make-syncase-macro) + (list (build-data no-source 'macro) e))))))) (define chi-when-list (lambda (e when-list w) @@ -1098,18 +1127,13 @@ (let* ((n (id-var-name value w)) (type (binding-type (lookup n r mod)))) (case type - ((global) + ((global core macro module-ref) (eval-if-c&e m (build-global-definition s n (chi e r w mod) mod) mod)) ((displaced-lexical) (syntax-violation #f "identifier out of context" e (wrap value w mod))) - ((core macro module-ref) - (remove-global-definition-hook n) - (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) - mod)) (else (syntax-violation #f "cannot define keyword at top level" e (wrap value w mod)))))) From 12eae603c76edc8affc0e8331df7f22a4d8a8b2c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 22:50:45 +0200 Subject: [PATCH 087/375] cleanups to boot-9 * module/ice-9/boot-9.scm: Shuffle around some definitions. (module-add!): Removed stub definition, no longer used. (install-global-transformer): Removed, no longer used (yay!). * module/ice-9/psyntax-pp.scm: Regenerated. * module/ice-9/psyntax.scm: Remove install-global-transformer. --- module/ice-9/boot-9.scm | 11 ++++------- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 8 -------- 3 files changed, 15 insertions(+), 26 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index c12dc967b..c3531e156 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -134,12 +134,10 @@ -;; Before the module system boots, there are no module names. But -;; psyntax does want a module-name definition, so give it one. +;; Define a minimal stub of the module API for psyntax, before modules +;; have booted. (define (module-name x) '(guile)) -(define (module-add! module sym var) - (hashq-set! (%get-pre-modules-obarray) sym var)) (define (module-define! module sym val) (let ((v (hashq-ref (%get-pre-modules-obarray) sym))) (if v @@ -149,6 +147,8 @@ (define (module-ref module sym) (let ((v (module-variable module sym))) (if v (variable-ref v) (error "badness!" (pk module) (pk sym))))) +(define (resolve-module . args) + #f) (define (make-module-ref mod var kind) (case kind @@ -163,8 +163,6 @@ `(@@ ,mod ,var) var)) (else (error "foo" mod var kind)))) -(define (resolve-module . args) - #f) ;;; API provided by psyntax (define syntax-violation #f) @@ -182,7 +180,6 @@ (define $sc-dispatch #f) ;;; Useless crap I'd like to get rid of -(define install-global-transformer #f) (define (annotation? x) #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 5cb5213d5..03191991c 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1131 (lambda (vars1336) (let lvl1337 ((vars1338 vars1336) (ls1339 (quote ())) (w1340 (quote (())))) (cond ((pair? vars1338) (lvl1337 (cdr vars1338) (cons (wrap1110 (car vars1338) w1340 #f) ls1339) w1340)) ((id?1082 vars1338) (cons (wrap1110 vars1338 w1340 #f) ls1339)) ((null? vars1338) ls1339) ((syntax-object?1066 vars1338) (lvl1337 (syntax-object-expression1067 vars1338) ls1339 (join-wraps1101 w1340 (syntax-object-wrap1068 vars1338)))) ((annotation? vars1338) (lvl1337 (annotation-expression vars1338) ls1339 w1340)) (else (cons vars1338 ls1339)))))) (gen-var1130 (lambda (id1341) (let ((id1342 (if (syntax-object?1066 id1341) (syntax-object-expression1067 id1341) id1341))) (if (annotation? id1342) (build-annotated1059 (annotation-source id1342) (gensym (symbol->string (annotation-expression id1342)))) (build-annotated1059 #f (gensym (symbol->string id1342))))))) (strip1129 (lambda (x1343 w1344) (if (memq (quote top) (wrap-marks1085 w1344)) (if (or (annotation? x1343) (and (pair? x1343) (annotation? (car x1343)))) (strip-annotation1128 x1343 #f) x1343) (let f1345 ((x1346 x1343)) (cond ((syntax-object?1066 x1346) (strip1129 (syntax-object-expression1067 x1346) (syntax-object-wrap1068 x1346))) ((pair? x1346) (let ((a1347 (f1345 (car x1346))) (d1348 (f1345 (cdr x1346)))) (if (and (eq? a1347 (car x1346)) (eq? d1348 (cdr x1346))) x1346 (cons a1347 d1348)))) ((vector? x1346) (let ((old1349 (vector->list x1346))) (let ((new1350 (map f1345 old1349))) (if (andmap eq? old1349 new1350) x1346 (list->vector new1350))))) (else x1346)))))) (strip-annotation1128 (lambda (x1351 parent1352) (cond ((pair? x1351) (let ((new1353 (cons #f #f))) (begin (if parent1352 (set-annotation-stripped! parent1352 new1353)) (set-car! new1353 (strip-annotation1128 (car x1351) #f)) (set-cdr! new1353 (strip-annotation1128 (cdr x1351) #f)) new1353))) ((annotation? x1351) (or (annotation-stripped x1351) (strip-annotation1128 (annotation-expression x1351) x1351))) ((vector? x1351) (let ((new1354 (make-vector (vector-length x1351)))) (begin (if parent1352 (set-annotation-stripped! parent1352 new1354)) (let loop1355 ((i1356 (- (vector-length x1351) 1))) (unless (fx<1053 i1356 0) (vector-set! new1354 i1356 (strip-annotation1128 (vector-ref x1351 i1356) #f)) (loop1355 (fx-1051 i1356 1)))) new1354))) (else x1351)))) (ellipsis?1127 (lambda (x1357) (and (nonsymbol-id?1081 x1357) (free-id=?1105 x1357 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1126 (lambda () (build-annotated1059 #f (list (build-annotated1059 #f (quote void)))))) (eval-local-transformer1125 (lambda (expanded1358 mod1359) (let ((p1360 (local-eval-hook1055 expanded1358 mod1359))) (if (procedure? p1360) p1360 (syntax-violation #f "nonprocedure transformer" p1360))))) (chi-local-syntax1124 (lambda (rec?1361 e1362 r1363 w1364 s1365 mod1366 k1367) ((lambda (tmp1368) ((lambda (tmp1369) (if tmp1369 (apply (lambda (_1370 id1371 val1372 e11373 e21374) (let ((ids1375 id1371)) (if (not (valid-bound-ids?1107 ids1375)) (syntax-violation #f "duplicate bound keyword" e1362) (let ((labels1377 (gen-labels1088 ids1375))) (let ((new-w1378 (make-binding-wrap1099 ids1375 labels1377 w1364))) (k1367 (cons e11373 e21374) (extend-env1076 labels1377 (let ((w1380 (if rec?1361 new-w1378 w1364)) (trans-r1381 (macros-only-env1078 r1363))) (map (lambda (x1382) (cons (quote macro) (eval-local-transformer1125 (chi1118 x1382 trans-r1381 w1380 mod1366) mod1366))) val1372)) r1363) new-w1378 s1365 mod1366)))))) tmp1369) ((lambda (_1384) (syntax-violation #f "bad local syntax definition" (source-wrap1111 e1362 w1364 s1365 mod1366))) tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) e1362))) (chi-lambda-clause1123 (lambda (e1385 docstring1386 c1387 r1388 w1389 mod1390 k1391) ((lambda (tmp1392) ((lambda (tmp1393) (if (if tmp1393 (apply (lambda (args1394 doc1395 e11396 e21397) (and (string? (syntax->datum doc1395)) (not docstring1386))) tmp1393) #f) (apply (lambda (args1398 doc1399 e11400 e21401) (chi-lambda-clause1123 e1385 doc1399 (cons args1398 (cons e11400 e21401)) r1388 w1389 mod1390 k1391)) tmp1393) ((lambda (tmp1403) (if tmp1403 (apply (lambda (id1404 e11405 e21406) (let ((ids1407 id1404)) (if (not (valid-bound-ids?1107 ids1407)) (syntax-violation (quote lambda) "invalid parameter list" e1385) (let ((labels1409 (gen-labels1088 ids1407)) (new-vars1410 (map gen-var1130 ids1407))) (k1391 new-vars1410 docstring1386 (chi-body1122 (cons e11405 e21406) e1385 (extend-var-env1077 labels1409 new-vars1410 r1388) (make-binding-wrap1099 ids1407 labels1409 w1389) mod1390)))))) tmp1403) ((lambda (tmp1412) (if tmp1412 (apply (lambda (ids1413 e11414 e21415) (let ((old-ids1416 (lambda-var-list1131 ids1413))) (if (not (valid-bound-ids?1107 old-ids1416)) (syntax-violation (quote lambda) "invalid parameter list" e1385) (let ((labels1417 (gen-labels1088 old-ids1416)) (new-vars1418 (map gen-var1130 old-ids1416))) (k1391 (let f1419 ((ls11420 (cdr new-vars1418)) (ls21421 (car new-vars1418))) (if (null? ls11420) ls21421 (f1419 (cdr ls11420) (cons (car ls11420) ls21421)))) docstring1386 (chi-body1122 (cons e11414 e21415) e1385 (extend-var-env1077 labels1417 new-vars1418 r1388) (make-binding-wrap1099 old-ids1416 labels1417 w1389) mod1390)))))) tmp1412) ((lambda (_1423) (syntax-violation (quote lambda) "bad lambda" e1385)) tmp1392))) ($sc-dispatch tmp1392 (quote (any any . each-any)))))) ($sc-dispatch tmp1392 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1392 (quote (any any any . each-any))))) c1387))) (chi-body1122 (lambda (body1424 outer-form1425 r1426 w1427 mod1428) (let ((r1429 (cons (quote ("placeholder" placeholder)) r1426))) (let ((ribcage1430 (make-ribcage1089 (quote ()) (quote ()) (quote ())))) (let ((w1431 (make-wrap1084 (wrap-marks1085 w1427) (cons ribcage1430 (wrap-subst1086 w1427))))) (let parse1432 ((body1433 (map (lambda (x1439) (cons r1429 (wrap1110 x1439 w1431 mod1428))) body1424)) (ids1434 (quote ())) (labels1435 (quote ())) (vars1436 (quote ())) (vals1437 (quote ())) (bindings1438 (quote ()))) (if (null? body1433) (syntax-violation #f "no expressions in body" outer-form1425) (let ((e1440 (cdar body1433)) (er1441 (caar body1433))) (call-with-values (lambda () (syntax-type1116 e1440 er1441 (quote (())) #f ribcage1430 mod1428)) (lambda (type1442 value1443 e1444 w1445 s1446 mod1447) (let ((t1448 type1442)) (if (memv t1448 (quote (define-form))) (let ((id1449 (wrap1110 value1443 w1445 mod1447)) (label1450 (gen-label1087))) (let ((var1451 (gen-var1130 id1449))) (begin (extend-ribcage!1098 ribcage1430 id1449 label1450) (parse1432 (cdr body1433) (cons id1449 ids1434) (cons label1450 labels1435) (cons var1451 vars1436) (cons (cons er1441 (wrap1110 e1444 w1445 mod1447)) vals1437) (cons (cons (quote lexical) var1451) bindings1438))))) (if (memv t1448 (quote (define-syntax-form))) (let ((id1452 (wrap1110 value1443 w1445 mod1447)) (label1453 (gen-label1087))) (begin (extend-ribcage!1098 ribcage1430 id1452 label1453) (parse1432 (cdr body1433) (cons id1452 ids1434) (cons label1453 labels1435) vars1436 vals1437 (cons (cons (quote macro) (cons er1441 (wrap1110 e1444 w1445 mod1447))) bindings1438)))) (if (memv t1448 (quote (begin-form))) ((lambda (tmp1454) ((lambda (tmp1455) (if tmp1455 (apply (lambda (_1456 e11457) (parse1432 (let f1458 ((forms1459 e11457)) (if (null? forms1459) (cdr body1433) (cons (cons er1441 (wrap1110 (car forms1459) w1445 mod1447)) (f1458 (cdr forms1459))))) ids1434 labels1435 vars1436 vals1437 bindings1438)) tmp1455) (syntax-violation #f "source expression failed to match any pattern" tmp1454))) ($sc-dispatch tmp1454 (quote (any . each-any))))) e1444) (if (memv t1448 (quote (local-syntax-form))) (chi-local-syntax1124 value1443 e1444 er1441 w1445 s1446 mod1447 (lambda (forms1461 er1462 w1463 s1464 mod1465) (parse1432 (let f1466 ((forms1467 forms1461)) (if (null? forms1467) (cdr body1433) (cons (cons er1462 (wrap1110 (car forms1467) w1463 mod1465)) (f1466 (cdr forms1467))))) ids1434 labels1435 vars1436 vals1437 bindings1438))) (if (null? ids1434) (build-sequence1061 #f (map (lambda (x1468) (chi1118 (cdr x1468) (car x1468) (quote (())) mod1447)) (cons (cons er1441 (source-wrap1111 e1444 w1445 s1446 mod1447)) (cdr body1433)))) (begin (if (not (valid-bound-ids?1107 ids1434)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1425)) (let loop1469 ((bs1470 bindings1438) (er-cache1471 #f) (r-cache1472 #f)) (if (not (null? bs1470)) (let ((b1473 (car bs1470))) (if (eq? (car b1473) (quote macro)) (let ((er1474 (cadr b1473))) (let ((r-cache1475 (if (eq? er1474 er-cache1471) r-cache1472 (macros-only-env1078 er1474)))) (begin (set-cdr! b1473 (eval-local-transformer1125 (chi1118 (cddr b1473) r-cache1475 (quote (())) mod1447) mod1447)) (loop1469 (cdr bs1470) er1474 r-cache1475)))) (loop1469 (cdr bs1470) er-cache1471 r-cache1472))))) (set-cdr! r1429 (extend-env1076 labels1435 bindings1438 (cdr r1429))) (build-letrec1064 #f vars1436 (map (lambda (x1476) (chi1118 (cdr x1476) (car x1476) (quote (())) mod1447)) vals1437) (build-sequence1061 #f (map (lambda (x1477) (chi1118 (cdr x1477) (car x1477) (quote (())) mod1447)) (cons (cons er1441 (source-wrap1111 e1444 w1445 s1446 mod1447)) (cdr body1433)))))))))))))))))))))) (chi-macro1121 (lambda (p1478 e1479 r1480 w1481 rib1482 mod1483) (letrec ((rebuild-macro-output1484 (lambda (x1485 m1486) (cond ((pair? x1485) (cons (rebuild-macro-output1484 (car x1485) m1486) (rebuild-macro-output1484 (cdr x1485) m1486))) ((syntax-object?1066 x1485) (let ((w1487 (syntax-object-wrap1068 x1485))) (let ((ms1488 (wrap-marks1085 w1487)) (s1489 (wrap-subst1086 w1487))) (if (and (pair? ms1488) (eq? (car ms1488) #f)) (make-syntax-object1065 (syntax-object-expression1067 x1485) (make-wrap1084 (cdr ms1488) (if rib1482 (cons rib1482 (cdr s1489)) (cdr s1489))) (syntax-object-module1069 x1485)) (make-syntax-object1065 (syntax-object-expression1067 x1485) (make-wrap1084 (cons m1486 ms1488) (if rib1482 (cons rib1482 (cons (quote shift) s1489)) (cons (quote shift) s1489))) (let ((pmod1490 (procedure-module p1478))) (if pmod1490 (cons (quote hygiene) (module-name pmod1490)) (quote (hygiene guile))))))))) ((vector? x1485) (let ((n1491 (vector-length x1485))) (let ((v1492 (make-vector n1491))) (let doloop1493 ((i1494 0)) (if (fx=1052 i1494 n1491) v1492 (begin (vector-set! v1492 i1494 (rebuild-macro-output1484 (vector-ref x1485 i1494) m1486)) (doloop1493 (fx+1050 i1494 1)))))))) ((symbol? x1485) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1111 e1479 w1481 s mod1483) x1485)) (else x1485))))) (rebuild-macro-output1484 (p1478 (wrap1110 e1479 (anti-mark1097 w1481) mod1483)) (string #\m))))) (chi-application1120 (lambda (x1495 e1496 r1497 w1498 s1499 mod1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (e01503 e11504) (build-annotated1059 s1499 (cons x1495 (map (lambda (e1505) (chi1118 e1505 r1497 w1498 mod1500)) e11504)))) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote (any . each-any))))) e1496))) (chi-expr1119 (lambda (type1507 value1508 e1509 r1510 w1511 s1512 mod1513) (let ((t1514 type1507)) (if (memv t1514 (quote (lexical))) (build-annotated1059 s1512 value1508) (if (memv t1514 (quote (core external-macro))) (value1508 e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (module-ref))) (call-with-values (lambda () (value1508 e1509)) (lambda (id1515 mod1516) (build-annotated1059 s1512 (if mod1516 (make-module-ref (cdr mod1516) id1515 (car mod1516)) (make-module-ref mod1516 id1515 (quote bare)))))) (if (memv t1514 (quote (lexical-call))) (chi-application1120 (build-annotated1059 (source-annotation1073 (car e1509)) value1508) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (global-call))) (chi-application1120 (build-annotated1059 (source-annotation1073 (car e1509)) (if (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513) (make-module-ref (cdr (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513)) value1508 (car (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513))) (make-module-ref (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513) value1508 (quote bare)))) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (constant))) (build-data1060 s1512 (strip1129 (source-wrap1111 e1509 w1511 s1512 mod1513) (quote (())))) (if (memv t1514 (quote (global))) (build-annotated1059 s1512 (if mod1513 (make-module-ref (cdr mod1513) value1508 (car mod1513)) (make-module-ref mod1513 value1508 (quote bare)))) (if (memv t1514 (quote (call))) (chi-application1120 (chi1118 (car e1509) r1510 w1511 mod1513) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (begin-form))) ((lambda (tmp1517) ((lambda (tmp1518) (if tmp1518 (apply (lambda (_1519 e11520 e21521) (chi-sequence1112 (cons e11520 e21521) r1510 w1511 s1512 mod1513)) tmp1518) (syntax-violation #f "source expression failed to match any pattern" tmp1517))) ($sc-dispatch tmp1517 (quote (any any . each-any))))) e1509) (if (memv t1514 (quote (local-syntax-form))) (chi-local-syntax1124 value1508 e1509 r1510 w1511 s1512 mod1513 chi-sequence1112) (if (memv t1514 (quote (eval-when-form))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (_1525 x1526 e11527 e21528) (let ((when-list1529 (chi-when-list1115 e1509 x1526 w1511))) (if (memq (quote eval) when-list1529) (chi-sequence1112 (cons e11527 e21528) r1510 w1511 s1512 mod1513) (chi-void1126)))) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote (any each-any any . each-any))))) e1509) (if (memv t1514 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1509 (wrap1110 value1508 w1511 mod1513)) (if (memv t1514 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1111 e1509 w1511 s1512 mod1513)) (if (memv t1514 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1111 e1509 w1511 s1512 mod1513)) (syntax-violation #f "unexpected syntax" (source-wrap1111 e1509 w1511 s1512 mod1513))))))))))))))))))) (chi1118 (lambda (e1532 r1533 w1534 mod1535) (call-with-values (lambda () (syntax-type1116 e1532 r1533 w1534 #f #f mod1535)) (lambda (type1536 value1537 e1538 w1539 s1540 mod1541) (chi-expr1119 type1536 value1537 e1538 r1533 w1539 s1540 mod1541))))) (chi-top1117 (lambda (e1542 r1543 w1544 m1545 esew1546 mod1547) (call-with-values (lambda () (syntax-type1116 e1542 r1543 w1544 #f #f mod1547)) (lambda (type1555 value1556 e1557 w1558 s1559 mod1560) (let ((t1561 type1555)) (if (memv t1561 (quote (begin-form))) ((lambda (tmp1562) ((lambda (tmp1563) (if tmp1563 (apply (lambda (_1564) (chi-void1126)) tmp1563) ((lambda (tmp1565) (if tmp1565 (apply (lambda (_1566 e11567 e21568) (chi-top-sequence1113 (cons e11567 e21568) r1543 w1558 s1559 m1545 esew1546 mod1560)) tmp1565) (syntax-violation #f "source expression failed to match any pattern" tmp1562))) ($sc-dispatch tmp1562 (quote (any any . each-any)))))) ($sc-dispatch tmp1562 (quote (any))))) e1557) (if (memv t1561 (quote (local-syntax-form))) (chi-local-syntax1124 value1556 e1557 r1543 w1558 s1559 mod1560 (lambda (body1570 r1571 w1572 s1573 mod1574) (chi-top-sequence1113 body1570 r1571 w1572 s1573 m1545 esew1546 mod1574))) (if (memv t1561 (quote (eval-when-form))) ((lambda (tmp1575) ((lambda (tmp1576) (if tmp1576 (apply (lambda (_1577 x1578 e11579 e21580) (let ((when-list1581 (chi-when-list1115 e1557 x1578 w1558)) (body1582 (cons e11579 e21580))) (cond ((eq? m1545 (quote e)) (if (memq (quote eval) when-list1581) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote e) (quote (eval)) mod1560) (chi-void1126))) ((memq (quote load) when-list1581) (if (or (memq (quote compile) when-list1581) (and (eq? m1545 (quote c&e)) (memq (quote eval) when-list1581))) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote c&e) (quote (compile load)) mod1560) (if (memq m1545 (quote (c c&e))) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote c) (quote (load)) mod1560) (chi-void1126)))) ((or (memq (quote compile) when-list1581) (and (eq? m1545 (quote c&e)) (memq (quote eval) when-list1581))) (top-level-eval-hook1054 (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote e) (quote (eval)) mod1560) mod1560) (chi-void1126)) (else (chi-void1126))))) tmp1576) (syntax-violation #f "source expression failed to match any pattern" tmp1575))) ($sc-dispatch tmp1575 (quote (any each-any any . each-any))))) e1557) (if (memv t1561 (quote (define-syntax-form))) (let ((n1585 (id-var-name1104 value1556 w1558)) (r1586 (macros-only-env1078 r1543))) (let ((t1587 m1545)) (if (memv t1587 (quote (c))) (if (memq (quote compile) esew1546) (let ((e1588 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)))) (begin (top-level-eval-hook1054 e1588 mod1560) (if (memq (quote load) esew1546) e1588 (chi-void1126)))) (if (memq (quote load) esew1546) (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)) (chi-void1126))) (if (memv t1587 (quote (c&e))) (let ((e1589 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)))) (begin (top-level-eval-hook1054 e1589 mod1560) e1589)) (begin (if (memq (quote eval) esew1546) (top-level-eval-hook1054 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)) mod1560)) (chi-void1126)))))) (if (memv t1561 (quote (define-form))) (let ((n1590 (id-var-name1104 value1556 w1558))) (let ((type1591 (binding-type1074 (lookup1079 n1590 r1543 mod1560)))) (let ((t1592 type1591)) (if (memv t1592 (quote (global core macro module-ref))) (let ((x1593 (build-annotated1059 s1559 (list (quote define) n1590 (chi1118 e1557 r1543 w1558 mod1560))))) (begin (if (eq? m1545 (quote c&e)) (top-level-eval-hook1054 x1593 mod1560)) x1593)) (if (memv t1592 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1557 (wrap1110 value1556 w1558 mod1560)) (syntax-violation #f "cannot define keyword at top level" e1557 (wrap1110 value1556 w1558 mod1560))))))) (let ((x1594 (chi-expr1119 type1555 value1556 e1557 r1543 w1558 s1559 mod1560))) (begin (if (eq? m1545 (quote c&e)) (top-level-eval-hook1054 x1594 mod1560)) x1594)))))))))))) (syntax-type1116 (lambda (e1595 r1596 w1597 s1598 rib1599 mod1600) (cond ((symbol? e1595) (let ((n1601 (id-var-name1104 e1595 w1597))) (let ((b1602 (lookup1079 n1601 r1596 mod1600))) (let ((type1603 (binding-type1074 b1602))) (let ((t1604 type1603)) (if (memv t1604 (quote (lexical))) (values type1603 (binding-value1075 b1602) e1595 w1597 s1598 mod1600) (if (memv t1604 (quote (global))) (values type1603 n1601 e1595 w1597 s1598 mod1600) (if (memv t1604 (quote (macro))) (syntax-type1116 (chi-macro1121 (binding-value1075 b1602) e1595 r1596 w1597 rib1599 mod1600) r1596 (quote (())) s1598 rib1599 mod1600) (values type1603 (binding-value1075 b1602) e1595 w1597 s1598 mod1600))))))))) ((pair? e1595) (let ((first1605 (car e1595))) (if (id?1082 first1605) (let ((n1606 (id-var-name1104 first1605 w1597))) (let ((b1607 (lookup1079 n1606 r1596 (or (and (syntax-object?1066 first1605) (syntax-object-module1069 first1605)) mod1600)))) (let ((type1608 (binding-type1074 b1607))) (let ((t1609 type1608)) (if (memv t1609 (quote (lexical))) (values (quote lexical-call) (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (global))) (values (quote global-call) n1606 e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (macro))) (syntax-type1116 (chi-macro1121 (binding-value1075 b1607) e1595 r1596 w1597 rib1599 mod1600) r1596 (quote (())) s1598 rib1599 mod1600) (if (memv t1609 (quote (core external-macro module-ref))) (values type1608 (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (begin))) (values (quote begin-form) #f e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (eval-when))) (values (quote eval-when-form) #f e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (define))) ((lambda (tmp1610) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 name1613 val1614) (id?1082 name1613)) tmp1611) #f) (apply (lambda (_1615 name1616 val1617) (values (quote define-form) name1616 val1617 w1597 s1598 mod1600)) tmp1611) ((lambda (tmp1618) (if (if tmp1618 (apply (lambda (_1619 name1620 args1621 e11622 e21623) (and (id?1082 name1620) (valid-bound-ids?1107 (lambda-var-list1131 args1621)))) tmp1618) #f) (apply (lambda (_1624 name1625 args1626 e11627 e21628) (values (quote define-form) (wrap1110 name1625 w1597 mod1600) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1110 (cons args1626 (cons e11627 e21628)) w1597 mod1600)) (quote (())) s1598 mod1600)) tmp1618) ((lambda (tmp1630) (if (if tmp1630 (apply (lambda (_1631 name1632) (id?1082 name1632)) tmp1630) #f) (apply (lambda (_1633 name1634) (values (quote define-form) (wrap1110 name1634 w1597 mod1600) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1598 mod1600)) tmp1630) (syntax-violation #f "source expression failed to match any pattern" tmp1610))) ($sc-dispatch tmp1610 (quote (any any)))))) ($sc-dispatch tmp1610 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1610 (quote (any any any))))) e1595) (if (memv t1609 (quote (define-syntax))) ((lambda (tmp1635) ((lambda (tmp1636) (if (if tmp1636 (apply (lambda (_1637 name1638 val1639) (id?1082 name1638)) tmp1636) #f) (apply (lambda (_1640 name1641 val1642) (values (quote define-syntax-form) name1641 val1642 w1597 s1598 mod1600)) tmp1636) (syntax-violation #f "source expression failed to match any pattern" tmp1635))) ($sc-dispatch tmp1635 (quote (any any any))))) e1595) (values (quote call) #f e1595 w1597 s1598 mod1600)))))))))))))) (values (quote call) #f e1595 w1597 s1598 mod1600)))) ((syntax-object?1066 e1595) (syntax-type1116 (syntax-object-expression1067 e1595) r1596 (join-wraps1101 w1597 (syntax-object-wrap1068 e1595)) #f rib1599 (or (syntax-object-module1069 e1595) mod1600))) ((annotation? e1595) (syntax-type1116 (annotation-expression e1595) r1596 w1597 (annotation-source e1595) rib1599 mod1600)) ((self-evaluating? e1595) (values (quote constant) #f e1595 w1597 s1598 mod1600)) (else (values (quote other) #f e1595 w1597 s1598 mod1600))))) (chi-when-list1115 (lambda (e1643 when-list1644 w1645) (let f1646 ((when-list1647 when-list1644) (situations1648 (quote ()))) (if (null? when-list1647) situations1648 (f1646 (cdr when-list1647) (cons (let ((x1649 (car when-list1647))) (cond ((free-id=?1105 x1649 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1105 x1649 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1105 x1649 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1643 (wrap1110 x1649 w1645 #f))))) situations1648)))))) (chi-install-global1114 (lambda (name1650 e1651) (build-annotated1059 #f (list (build-annotated1059 #f (quote define)) name1650 (if (let ((v1652 (module-variable (current-module) name1650))) (and v1652 (variable-bound? v1652) (macro? (variable-ref v1652)) (not (eq? (macro-type (variable-ref v1652)) (quote syncase-macro))))) (build-annotated1059 #f (list (build-annotated1059 #f (quote make-extended-syncase-macro)) (build-annotated1059 #f (list (build-annotated1059 #f (quote module-ref)) (build-annotated1059 #f (quote (current-module))) (build-data1060 #f name1650))) (build-data1060 #f (quote macro)) e1651)) (build-annotated1059 #f (list (build-annotated1059 #f (quote make-syncase-macro)) (build-data1060 #f (quote macro)) e1651))))))) (chi-top-sequence1113 (lambda (body1653 r1654 w1655 s1656 m1657 esew1658 mod1659) (build-sequence1061 s1656 (let dobody1660 ((body1661 body1653) (r1662 r1654) (w1663 w1655) (m1664 m1657) (esew1665 esew1658) (mod1666 mod1659)) (if (null? body1661) (quote ()) (let ((first1667 (chi-top1117 (car body1661) r1662 w1663 m1664 esew1665 mod1666))) (cons first1667 (dobody1660 (cdr body1661) r1662 w1663 m1664 esew1665 mod1666)))))))) (chi-sequence1112 (lambda (body1668 r1669 w1670 s1671 mod1672) (build-sequence1061 s1671 (let dobody1673 ((body1674 body1668) (r1675 r1669) (w1676 w1670) (mod1677 mod1672)) (if (null? body1674) (quote ()) (let ((first1678 (chi1118 (car body1674) r1675 w1676 mod1677))) (cons first1678 (dobody1673 (cdr body1674) r1675 w1676 mod1677)))))))) (source-wrap1111 (lambda (x1679 w1680 s1681 defmod1682) (wrap1110 (if s1681 (make-annotation x1679 s1681 #f) x1679) w1680 defmod1682))) (wrap1110 (lambda (x1683 w1684 defmod1685) (cond ((and (null? (wrap-marks1085 w1684)) (null? (wrap-subst1086 w1684))) x1683) ((syntax-object?1066 x1683) (make-syntax-object1065 (syntax-object-expression1067 x1683) (join-wraps1101 w1684 (syntax-object-wrap1068 x1683)) (syntax-object-module1069 x1683))) ((null? x1683) x1683) (else (make-syntax-object1065 x1683 w1684 defmod1685))))) (bound-id-member?1109 (lambda (x1686 list1687) (and (not (null? list1687)) (or (bound-id=?1106 x1686 (car list1687)) (bound-id-member?1109 x1686 (cdr list1687)))))) (distinct-bound-ids?1108 (lambda (ids1688) (let distinct?1689 ((ids1690 ids1688)) (or (null? ids1690) (and (not (bound-id-member?1109 (car ids1690) (cdr ids1690))) (distinct?1689 (cdr ids1690))))))) (valid-bound-ids?1107 (lambda (ids1691) (and (let all-ids?1692 ((ids1693 ids1691)) (or (null? ids1693) (and (id?1082 (car ids1693)) (all-ids?1692 (cdr ids1693))))) (distinct-bound-ids?1108 ids1691)))) (bound-id=?1106 (lambda (i1694 j1695) (if (and (syntax-object?1066 i1694) (syntax-object?1066 j1695)) (and (eq? (let ((e1696 (syntax-object-expression1067 i1694))) (if (annotation? e1696) (annotation-expression e1696) e1696)) (let ((e1697 (syntax-object-expression1067 j1695))) (if (annotation? e1697) (annotation-expression e1697) e1697))) (same-marks?1103 (wrap-marks1085 (syntax-object-wrap1068 i1694)) (wrap-marks1085 (syntax-object-wrap1068 j1695)))) (eq? (let ((e1698 i1694)) (if (annotation? e1698) (annotation-expression e1698) e1698)) (let ((e1699 j1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)))))) (free-id=?1105 (lambda (i1700 j1701) (and (eq? (let ((x1702 i1700)) (let ((e1703 (if (syntax-object?1066 x1702) (syntax-object-expression1067 x1702) x1702))) (if (annotation? e1703) (annotation-expression e1703) e1703))) (let ((x1704 j1701)) (let ((e1705 (if (syntax-object?1066 x1704) (syntax-object-expression1067 x1704) x1704))) (if (annotation? e1705) (annotation-expression e1705) e1705)))) (eq? (id-var-name1104 i1700 (quote (()))) (id-var-name1104 j1701 (quote (()))))))) (id-var-name1104 (lambda (id1706 w1707) (letrec ((search-vector-rib1710 (lambda (sym1716 subst1717 marks1718 symnames1719 ribcage1720) (let ((n1721 (vector-length symnames1719))) (let f1722 ((i1723 0)) (cond ((fx=1052 i1723 n1721) (search1708 sym1716 (cdr subst1717) marks1718)) ((and (eq? (vector-ref symnames1719 i1723) sym1716) (same-marks?1103 marks1718 (vector-ref (ribcage-marks1092 ribcage1720) i1723))) (values (vector-ref (ribcage-labels1093 ribcage1720) i1723) marks1718)) (else (f1722 (fx+1050 i1723 1)))))))) (search-list-rib1709 (lambda (sym1724 subst1725 marks1726 symnames1727 ribcage1728) (let f1729 ((symnames1730 symnames1727) (i1731 0)) (cond ((null? symnames1730) (search1708 sym1724 (cdr subst1725) marks1726)) ((and (eq? (car symnames1730) sym1724) (same-marks?1103 marks1726 (list-ref (ribcage-marks1092 ribcage1728) i1731))) (values (list-ref (ribcage-labels1093 ribcage1728) i1731) marks1726)) (else (f1729 (cdr symnames1730) (fx+1050 i1731 1))))))) (search1708 (lambda (sym1732 subst1733 marks1734) (if (null? subst1733) (values #f marks1734) (let ((fst1735 (car subst1733))) (if (eq? fst1735 (quote shift)) (search1708 sym1732 (cdr subst1733) (cdr marks1734)) (let ((symnames1736 (ribcage-symnames1091 fst1735))) (if (vector? symnames1736) (search-vector-rib1710 sym1732 subst1733 marks1734 symnames1736 fst1735) (search-list-rib1709 sym1732 subst1733 marks1734 symnames1736 fst1735))))))))) (cond ((symbol? id1706) (or (call-with-values (lambda () (search1708 id1706 (wrap-subst1086 w1707) (wrap-marks1085 w1707))) (lambda (x1738 . ignore1737) x1738)) id1706)) ((syntax-object?1066 id1706) (let ((id1739 (let ((e1741 (syntax-object-expression1067 id1706))) (if (annotation? e1741) (annotation-expression e1741) e1741))) (w11740 (syntax-object-wrap1068 id1706))) (let ((marks1742 (join-marks1102 (wrap-marks1085 w1707) (wrap-marks1085 w11740)))) (call-with-values (lambda () (search1708 id1739 (wrap-subst1086 w1707) marks1742)) (lambda (new-id1743 marks1744) (or new-id1743 (call-with-values (lambda () (search1708 id1739 (wrap-subst1086 w11740) marks1744)) (lambda (x1746 . ignore1745) x1746)) id1739)))))) ((annotation? id1706) (let ((id1747 (let ((e1748 id1706)) (if (annotation? e1748) (annotation-expression e1748) e1748)))) (or (call-with-values (lambda () (search1708 id1747 (wrap-subst1086 w1707) (wrap-marks1085 w1707))) (lambda (x1750 . ignore1749) x1750)) id1747))) (else (error-hook1056 (quote id-var-name) "invalid id" id1706)))))) (same-marks?1103 (lambda (x1751 y1752) (or (eq? x1751 y1752) (and (not (null? x1751)) (not (null? y1752)) (eq? (car x1751) (car y1752)) (same-marks?1103 (cdr x1751) (cdr y1752)))))) (join-marks1102 (lambda (m11753 m21754) (smart-append1100 m11753 m21754))) (join-wraps1101 (lambda (w11755 w21756) (let ((m11757 (wrap-marks1085 w11755)) (s11758 (wrap-subst1086 w11755))) (if (null? m11757) (if (null? s11758) w21756 (make-wrap1084 (wrap-marks1085 w21756) (smart-append1100 s11758 (wrap-subst1086 w21756)))) (make-wrap1084 (smart-append1100 m11757 (wrap-marks1085 w21756)) (smart-append1100 s11758 (wrap-subst1086 w21756))))))) (smart-append1100 (lambda (m11759 m21760) (if (null? m21760) m11759 (append m11759 m21760)))) (make-binding-wrap1099 (lambda (ids1761 labels1762 w1763) (if (null? ids1761) w1763 (make-wrap1084 (wrap-marks1085 w1763) (cons (let ((labelvec1764 (list->vector labels1762))) (let ((n1765 (vector-length labelvec1764))) (let ((symnamevec1766 (make-vector n1765)) (marksvec1767 (make-vector n1765))) (begin (let f1768 ((ids1769 ids1761) (i1770 0)) (if (not (null? ids1769)) (call-with-values (lambda () (id-sym-name&marks1083 (car ids1769) w1763)) (lambda (symname1771 marks1772) (begin (vector-set! symnamevec1766 i1770 symname1771) (vector-set! marksvec1767 i1770 marks1772) (f1768 (cdr ids1769) (fx+1050 i1770 1))))))) (make-ribcage1089 symnamevec1766 marksvec1767 labelvec1764))))) (wrap-subst1086 w1763)))))) (extend-ribcage!1098 (lambda (ribcage1773 id1774 label1775) (begin (set-ribcage-symnames!1094 ribcage1773 (cons (let ((e1776 (syntax-object-expression1067 id1774))) (if (annotation? e1776) (annotation-expression e1776) e1776)) (ribcage-symnames1091 ribcage1773))) (set-ribcage-marks!1095 ribcage1773 (cons (wrap-marks1085 (syntax-object-wrap1068 id1774)) (ribcage-marks1092 ribcage1773))) (set-ribcage-labels!1096 ribcage1773 (cons label1775 (ribcage-labels1093 ribcage1773)))))) (anti-mark1097 (lambda (w1777) (make-wrap1084 (cons #f (wrap-marks1085 w1777)) (cons (quote shift) (wrap-subst1086 w1777))))) (set-ribcage-labels!1096 (lambda (x1778 update1779) (vector-set! x1778 3 update1779))) (set-ribcage-marks!1095 (lambda (x1780 update1781) (vector-set! x1780 2 update1781))) (set-ribcage-symnames!1094 (lambda (x1782 update1783) (vector-set! x1782 1 update1783))) (ribcage-labels1093 (lambda (x1784) (vector-ref x1784 3))) (ribcage-marks1092 (lambda (x1785) (vector-ref x1785 2))) (ribcage-symnames1091 (lambda (x1786) (vector-ref x1786 1))) (ribcage?1090 (lambda (x1787) (and (vector? x1787) (= (vector-length x1787) 4) (eq? (vector-ref x1787 0) (quote ribcage))))) (make-ribcage1089 (lambda (symnames1788 marks1789 labels1790) (vector (quote ribcage) symnames1788 marks1789 labels1790))) (gen-labels1088 (lambda (ls1791) (if (null? ls1791) (quote ()) (cons (gen-label1087) (gen-labels1088 (cdr ls1791)))))) (gen-label1087 (lambda () (string #\i))) (wrap-subst1086 cdr) (wrap-marks1085 car) (make-wrap1084 cons) (id-sym-name&marks1083 (lambda (x1792 w1793) (if (syntax-object?1066 x1792) (values (let ((e1794 (syntax-object-expression1067 x1792))) (if (annotation? e1794) (annotation-expression e1794) e1794)) (join-marks1102 (wrap-marks1085 w1793) (wrap-marks1085 (syntax-object-wrap1068 x1792)))) (values (let ((e1795 x1792)) (if (annotation? e1795) (annotation-expression e1795) e1795)) (wrap-marks1085 w1793))))) (id?1082 (lambda (x1796) (cond ((symbol? x1796) #t) ((syntax-object?1066 x1796) (symbol? (let ((e1797 (syntax-object-expression1067 x1796))) (if (annotation? e1797) (annotation-expression e1797) e1797)))) ((annotation? x1796) (symbol? (annotation-expression x1796))) (else #f)))) (nonsymbol-id?1081 (lambda (x1798) (and (syntax-object?1066 x1798) (symbol? (let ((e1799 (syntax-object-expression1067 x1798))) (if (annotation? e1799) (annotation-expression e1799) e1799)))))) (global-extend1080 (lambda (type1800 sym1801 val1802) (put-global-definition-hook1057 sym1801 type1800 val1802))) (lookup1079 (lambda (x1803 r1804 mod1805) (cond ((assq x1803 r1804) => cdr) ((symbol? x1803) (or (get-global-definition-hook1058 x1803 mod1805) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1078 (lambda (r1806) (if (null? r1806) (quote ()) (let ((a1807 (car r1806))) (if (eq? (cadr a1807) (quote macro)) (cons a1807 (macros-only-env1078 (cdr r1806))) (macros-only-env1078 (cdr r1806))))))) (extend-var-env1077 (lambda (labels1808 vars1809 r1810) (if (null? labels1808) r1810 (extend-var-env1077 (cdr labels1808) (cdr vars1809) (cons (cons (car labels1808) (cons (quote lexical) (car vars1809))) r1810))))) (extend-env1076 (lambda (labels1811 bindings1812 r1813) (if (null? labels1811) r1813 (extend-env1076 (cdr labels1811) (cdr bindings1812) (cons (cons (car labels1811) (car bindings1812)) r1813))))) (binding-value1075 cdr) (binding-type1074 car) (source-annotation1073 (lambda (x1814) (cond ((annotation? x1814) (annotation-source x1814)) ((syntax-object?1066 x1814) (source-annotation1073 (syntax-object-expression1067 x1814))) (else #f)))) (set-syntax-object-module!1072 (lambda (x1815 update1816) (vector-set! x1815 3 update1816))) (set-syntax-object-wrap!1071 (lambda (x1817 update1818) (vector-set! x1817 2 update1818))) (set-syntax-object-expression!1070 (lambda (x1819 update1820) (vector-set! x1819 1 update1820))) (syntax-object-module1069 (lambda (x1821) (vector-ref x1821 3))) (syntax-object-wrap1068 (lambda (x1822) (vector-ref x1822 2))) (syntax-object-expression1067 (lambda (x1823) (vector-ref x1823 1))) (syntax-object?1066 (lambda (x1824) (and (vector? x1824) (= (vector-length x1824) 4) (eq? (vector-ref x1824 0) (quote syntax-object))))) (make-syntax-object1065 (lambda (expression1825 wrap1826 module1827) (vector (quote syntax-object) expression1825 wrap1826 module1827))) (build-letrec1064 (lambda (src1828 vars1829 val-exps1830 body-exp1831) (if (null? vars1829) (build-annotated1059 src1828 body-exp1831) (build-annotated1059 src1828 (list (quote letrec) (map list vars1829 val-exps1830) body-exp1831))))) (build-named-let1063 (lambda (src1832 vars1833 val-exps1834 body-exp1835) (if (null? vars1833) (build-annotated1059 src1832 body-exp1835) (build-annotated1059 src1832 (list (quote let) (car vars1833) (map list (cdr vars1833) val-exps1834) body-exp1835))))) (build-let1062 (lambda (src1836 vars1837 val-exps1838 body-exp1839) (if (null? vars1837) (build-annotated1059 src1836 body-exp1839) (build-annotated1059 src1836 (list (quote let) (map list vars1837 val-exps1838) body-exp1839))))) (build-sequence1061 (lambda (src1840 exps1841) (if (null? (cdr exps1841)) (build-annotated1059 src1840 (car exps1841)) (build-annotated1059 src1840 (cons (quote begin) exps1841))))) (build-data1060 (lambda (src1842 exp1843) (if (and (self-evaluating? exp1843) (not (vector? exp1843))) (build-annotated1059 src1842 exp1843) (build-annotated1059 src1842 (list (quote quote) exp1843))))) (build-annotated1059 (lambda (src1844 exp1845) (if (and src1844 (not (annotation? exp1845))) (make-annotation exp1845 src1844 #t) exp1845))) (get-global-definition-hook1058 (lambda (symbol1846 module1847) (begin (if (and (not module1847) (current-module)) (warn "module system is booted, we should have a module" symbol1846)) (let ((v1848 (module-variable (if module1847 (resolve-module (cdr module1847)) (current-module)) symbol1846))) (and v1848 (variable-bound? v1848) (let ((val1849 (variable-ref v1848))) (and (macro? val1849) (syncase-macro-type val1849) (cons (syncase-macro-type val1849) (syncase-macro-binding val1849))))))))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (let ((existing1853 (let ((v1854 (module-variable (current-module) symbol1850))) (and v1854 (variable-bound? v1854) (let ((val1855 (variable-ref v1854))) (and (macro? val1855) (not (syncase-macro-type val1855)) val1855)))))) (module-define! (current-module) symbol1850 (if existing1853 (make-extended-syncase-macro existing1853 type1851 val1852) (make-syncase-macro type1851 val1852)))))) (error-hook1056 (lambda (who1856 why1857 what1858) (error who1856 "~a ~s" why1857 what1858))) (local-eval-hook1055 (lambda (x1859 mod1860) (primitive-eval (list noexpand1049 x1859)))) (top-level-eval-hook1054 (lambda (x1861 mod1862) (primitive-eval (list noexpand1049 x1861)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1080 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1080 (quote local-syntax) (quote let-syntax) #f) (global-extend1080 (quote core) (quote fluid-let-syntax) (lambda (e1863 r1864 w1865 s1866 mod1867) ((lambda (tmp1868) ((lambda (tmp1869) (if (if tmp1869 (apply (lambda (_1870 var1871 val1872 e11873 e21874) (valid-bound-ids?1107 var1871)) tmp1869) #f) (apply (lambda (_1876 var1877 val1878 e11879 e21880) (let ((names1881 (map (lambda (x1882) (id-var-name1104 x1882 w1865)) var1877))) (begin (for-each (lambda (id1884 n1885) (let ((t1886 (binding-type1074 (lookup1079 n1885 r1864 mod1867)))) (if (memv t1886 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1863 (source-wrap1111 id1884 w1865 s1866 mod1867))))) var1877 names1881) (chi-body1122 (cons e11879 e21880) (source-wrap1111 e1863 w1865 s1866 mod1867) (extend-env1076 names1881 (let ((trans-r1889 (macros-only-env1078 r1864))) (map (lambda (x1890) (cons (quote macro) (eval-local-transformer1125 (chi1118 x1890 trans-r1889 w1865 mod1867) mod1867))) val1878)) r1864) w1865 mod1867)))) tmp1869) ((lambda (_1892) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1111 e1863 w1865 s1866 mod1867))) tmp1868))) ($sc-dispatch tmp1868 (quote (any #(each (any any)) any . each-any))))) e1863))) (global-extend1080 (quote core) (quote quote) (lambda (e1893 r1894 w1895 s1896 mod1897) ((lambda (tmp1898) ((lambda (tmp1899) (if tmp1899 (apply (lambda (_1900 e1901) (build-data1060 s1896 (strip1129 e1901 w1895))) tmp1899) ((lambda (_1902) (syntax-violation (quote quote) "bad syntax" (source-wrap1111 e1893 w1895 s1896 mod1897))) tmp1898))) ($sc-dispatch tmp1898 (quote (any any))))) e1893))) (global-extend1080 (quote core) (quote syntax) (letrec ((regen1910 (lambda (x1911) (let ((t1912 (car x1911))) (if (memv t1912 (quote (ref))) (build-annotated1059 #f (cadr x1911)) (if (memv t1912 (quote (primitive))) (build-annotated1059 #f (cadr x1911)) (if (memv t1912 (quote (quote))) (build-data1060 #f (cadr x1911)) (if (memv t1912 (quote (lambda))) (build-annotated1059 #f (list (quote lambda) (cadr x1911) (regen1910 (caddr x1911)))) (if (memv t1912 (quote (map))) (let ((ls1913 (map regen1910 (cdr x1911)))) (build-annotated1059 #f (cons (if (fx=1052 (length ls1913) 2) (build-annotated1059 #f (quote map)) (build-annotated1059 #f (quote map))) ls1913))) (build-annotated1059 #f (cons (build-annotated1059 #f (car x1911)) (map regen1910 (cdr x1911)))))))))))) (gen-vector1909 (lambda (x1914) (cond ((eq? (car x1914) (quote list)) (cons (quote vector) (cdr x1914))) ((eq? (car x1914) (quote quote)) (list (quote quote) (list->vector (cadr x1914)))) (else (list (quote list->vector) x1914))))) (gen-append1908 (lambda (x1915 y1916) (if (equal? y1916 (quote (quote ()))) x1915 (list (quote append) x1915 y1916)))) (gen-cons1907 (lambda (x1917 y1918) (let ((t1919 (car y1918))) (if (memv t1919 (quote (quote))) (if (eq? (car x1917) (quote quote)) (list (quote quote) (cons (cadr x1917) (cadr y1918))) (if (eq? (cadr y1918) (quote ())) (list (quote list) x1917) (list (quote cons) x1917 y1918))) (if (memv t1919 (quote (list))) (cons (quote list) (cons x1917 (cdr y1918))) (list (quote cons) x1917 y1918)))))) (gen-map1906 (lambda (e1920 map-env1921) (let ((formals1922 (map cdr map-env1921)) (actuals1923 (map (lambda (x1924) (list (quote ref) (car x1924))) map-env1921))) (cond ((eq? (car e1920) (quote ref)) (car actuals1923)) ((andmap (lambda (x1925) (and (eq? (car x1925) (quote ref)) (memq (cadr x1925) formals1922))) (cdr e1920)) (cons (quote map) (cons (list (quote primitive) (car e1920)) (map (let ((r1926 (map cons formals1922 actuals1923))) (lambda (x1927) (cdr (assq (cadr x1927) r1926)))) (cdr e1920))))) (else (cons (quote map) (cons (list (quote lambda) formals1922 e1920) actuals1923))))))) (gen-mappend1905 (lambda (e1928 map-env1929) (list (quote apply) (quote (primitive append)) (gen-map1906 e1928 map-env1929)))) (gen-ref1904 (lambda (src1930 var1931 level1932 maps1933) (if (fx=1052 level1932 0) (values var1931 maps1933) (if (null? maps1933) (syntax-violation (quote syntax) "missing ellipsis" src1930) (call-with-values (lambda () (gen-ref1904 src1930 var1931 (fx-1051 level1932 1) (cdr maps1933))) (lambda (outer-var1934 outer-maps1935) (let ((b1936 (assq outer-var1934 (car maps1933)))) (if b1936 (values (cdr b1936) maps1933) (let ((inner-var1937 (gen-var1130 (quote tmp)))) (values inner-var1937 (cons (cons (cons outer-var1934 inner-var1937) (car maps1933)) outer-maps1935))))))))))) (gen-syntax1903 (lambda (src1938 e1939 r1940 maps1941 ellipsis?1942 mod1943) (if (id?1082 e1939) (let ((label1944 (id-var-name1104 e1939 (quote (()))))) (let ((b1945 (lookup1079 label1944 r1940 mod1943))) (if (eq? (binding-type1074 b1945) (quote syntax)) (call-with-values (lambda () (let ((var.lev1946 (binding-value1075 b1945))) (gen-ref1904 src1938 (car var.lev1946) (cdr var.lev1946) maps1941))) (lambda (var1947 maps1948) (values (list (quote ref) var1947) maps1948))) (if (ellipsis?1942 e1939) (syntax-violation (quote syntax) "misplaced ellipsis" src1938) (values (list (quote quote) e1939) maps1941))))) ((lambda (tmp1949) ((lambda (tmp1950) (if (if tmp1950 (apply (lambda (dots1951 e1952) (ellipsis?1942 dots1951)) tmp1950) #f) (apply (lambda (dots1953 e1954) (gen-syntax1903 src1938 e1954 r1940 maps1941 (lambda (x1955) #f) mod1943)) tmp1950) ((lambda (tmp1956) (if (if tmp1956 (apply (lambda (x1957 dots1958 y1959) (ellipsis?1942 dots1958)) tmp1956) #f) (apply (lambda (x1960 dots1961 y1962) (let f1963 ((y1964 y1962) (k1965 (lambda (maps1966) (call-with-values (lambda () (gen-syntax1903 src1938 x1960 r1940 (cons (quote ()) maps1966) ellipsis?1942 mod1943)) (lambda (x1967 maps1968) (if (null? (car maps1968)) (syntax-violation (quote syntax) "extra ellipsis" src1938) (values (gen-map1906 x1967 (car maps1968)) (cdr maps1968)))))))) ((lambda (tmp1969) ((lambda (tmp1970) (if (if tmp1970 (apply (lambda (dots1971 y1972) (ellipsis?1942 dots1971)) tmp1970) #f) (apply (lambda (dots1973 y1974) (f1963 y1974 (lambda (maps1975) (call-with-values (lambda () (k1965 (cons (quote ()) maps1975))) (lambda (x1976 maps1977) (if (null? (car maps1977)) (syntax-violation (quote syntax) "extra ellipsis" src1938) (values (gen-mappend1905 x1976 (car maps1977)) (cdr maps1977)))))))) tmp1970) ((lambda (_1978) (call-with-values (lambda () (gen-syntax1903 src1938 y1964 r1940 maps1941 ellipsis?1942 mod1943)) (lambda (y1979 maps1980) (call-with-values (lambda () (k1965 maps1980)) (lambda (x1981 maps1982) (values (gen-append1908 x1981 y1979) maps1982)))))) tmp1969))) ($sc-dispatch tmp1969 (quote (any . any))))) y1964))) tmp1956) ((lambda (tmp1983) (if tmp1983 (apply (lambda (x1984 y1985) (call-with-values (lambda () (gen-syntax1903 src1938 x1984 r1940 maps1941 ellipsis?1942 mod1943)) (lambda (x1986 maps1987) (call-with-values (lambda () (gen-syntax1903 src1938 y1985 r1940 maps1987 ellipsis?1942 mod1943)) (lambda (y1988 maps1989) (values (gen-cons1907 x1986 y1988) maps1989)))))) tmp1983) ((lambda (tmp1990) (if tmp1990 (apply (lambda (e11991 e21992) (call-with-values (lambda () (gen-syntax1903 src1938 (cons e11991 e21992) r1940 maps1941 ellipsis?1942 mod1943)) (lambda (e1994 maps1995) (values (gen-vector1909 e1994) maps1995)))) tmp1990) ((lambda (_1996) (values (list (quote quote) e1939) maps1941)) tmp1949))) ($sc-dispatch tmp1949 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1949 (quote (any . any)))))) ($sc-dispatch tmp1949 (quote (any any . any)))))) ($sc-dispatch tmp1949 (quote (any any))))) e1939))))) (lambda (e1997 r1998 w1999 s2000 mod2001) (let ((e2002 (source-wrap1111 e1997 w1999 s2000 mod2001))) ((lambda (tmp2003) ((lambda (tmp2004) (if tmp2004 (apply (lambda (_2005 x2006) (call-with-values (lambda () (gen-syntax1903 e2002 x2006 r1998 (quote ()) ellipsis?1127 mod2001)) (lambda (e2007 maps2008) (regen1910 e2007)))) tmp2004) ((lambda (_2009) (syntax-violation (quote syntax) "bad `syntax' form" e2002)) tmp2003))) ($sc-dispatch tmp2003 (quote (any any))))) e2002))))) (global-extend1080 (quote core) (quote lambda) (lambda (e2010 r2011 w2012 s2013 mod2014) ((lambda (tmp2015) ((lambda (tmp2016) (if tmp2016 (apply (lambda (_2017 c2018) (chi-lambda-clause1123 (source-wrap1111 e2010 w2012 s2013 mod2014) #f c2018 r2011 w2012 mod2014 (lambda (vars2019 docstring2020 body2021) (build-annotated1059 s2013 (cons (quote lambda) (cons vars2019 (append (if docstring2020 (list docstring2020) (quote ())) (list body2021)))))))) tmp2016) (syntax-violation #f "source expression failed to match any pattern" tmp2015))) ($sc-dispatch tmp2015 (quote (any . any))))) e2010))) (global-extend1080 (quote core) (quote let) (letrec ((chi-let2022 (lambda (e2023 r2024 w2025 s2026 mod2027 constructor2028 ids2029 vals2030 exps2031) (if (not (valid-bound-ids?1107 ids2029)) (syntax-violation (quote let) "duplicate bound variable" e2023) (let ((labels2032 (gen-labels1088 ids2029)) (new-vars2033 (map gen-var1130 ids2029))) (let ((nw2034 (make-binding-wrap1099 ids2029 labels2032 w2025)) (nr2035 (extend-var-env1077 labels2032 new-vars2033 r2024))) (constructor2028 s2026 new-vars2033 (map (lambda (x2036) (chi1118 x2036 r2024 w2025 mod2027)) vals2030) (chi-body1122 exps2031 (source-wrap1111 e2023 nw2034 s2026 mod2027) nr2035 nw2034 mod2027)))))))) (lambda (e2037 r2038 w2039 s2040 mod2041) ((lambda (tmp2042) ((lambda (tmp2043) (if tmp2043 (apply (lambda (_2044 id2045 val2046 e12047 e22048) (chi-let2022 e2037 r2038 w2039 s2040 mod2041 build-let1062 id2045 val2046 (cons e12047 e22048))) tmp2043) ((lambda (tmp2052) (if (if tmp2052 (apply (lambda (_2053 f2054 id2055 val2056 e12057 e22058) (id?1082 f2054)) tmp2052) #f) (apply (lambda (_2059 f2060 id2061 val2062 e12063 e22064) (chi-let2022 e2037 r2038 w2039 s2040 mod2041 build-named-let1063 (cons f2060 id2061) val2062 (cons e12063 e22064))) tmp2052) ((lambda (_2068) (syntax-violation (quote let) "bad let" (source-wrap1111 e2037 w2039 s2040 mod2041))) tmp2042))) ($sc-dispatch tmp2042 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2042 (quote (any #(each (any any)) any . each-any))))) e2037)))) (global-extend1080 (quote core) (quote letrec) (lambda (e2069 r2070 w2071 s2072 mod2073) ((lambda (tmp2074) ((lambda (tmp2075) (if tmp2075 (apply (lambda (_2076 id2077 val2078 e12079 e22080) (let ((ids2081 id2077)) (if (not (valid-bound-ids?1107 ids2081)) (syntax-violation (quote letrec) "duplicate bound variable" e2069) (let ((labels2083 (gen-labels1088 ids2081)) (new-vars2084 (map gen-var1130 ids2081))) (let ((w2085 (make-binding-wrap1099 ids2081 labels2083 w2071)) (r2086 (extend-var-env1077 labels2083 new-vars2084 r2070))) (build-letrec1064 s2072 new-vars2084 (map (lambda (x2087) (chi1118 x2087 r2086 w2085 mod2073)) val2078) (chi-body1122 (cons e12079 e22080) (source-wrap1111 e2069 w2085 s2072 mod2073) r2086 w2085 mod2073))))))) tmp2075) ((lambda (_2090) (syntax-violation (quote letrec) "bad letrec" (source-wrap1111 e2069 w2071 s2072 mod2073))) tmp2074))) ($sc-dispatch tmp2074 (quote (any #(each (any any)) any . each-any))))) e2069))) (global-extend1080 (quote core) (quote set!) (lambda (e2091 r2092 w2093 s2094 mod2095) ((lambda (tmp2096) ((lambda (tmp2097) (if (if tmp2097 (apply (lambda (_2098 id2099 val2100) (id?1082 id2099)) tmp2097) #f) (apply (lambda (_2101 id2102 val2103) (let ((val2104 (chi1118 val2103 r2092 w2093 mod2095)) (n2105 (id-var-name1104 id2102 w2093))) (let ((b2106 (lookup1079 n2105 r2092 mod2095))) (let ((t2107 (binding-type1074 b2106))) (if (memv t2107 (quote (lexical))) (build-annotated1059 s2094 (list (quote set!) (binding-value1075 b2106) val2104)) (if (memv t2107 (quote (global))) (build-annotated1059 s2094 (list (quote set!) (if mod2095 (make-module-ref (cdr mod2095) n2105 (car mod2095)) (make-module-ref mod2095 n2105 (quote bare))) val2104)) (if (memv t2107 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1110 id2102 w2093 mod2095)) (syntax-violation (quote set!) "bad set!" (source-wrap1111 e2091 w2093 s2094 mod2095))))))))) tmp2097) ((lambda (tmp2108) (if tmp2108 (apply (lambda (_2109 head2110 tail2111 val2112) (call-with-values (lambda () (syntax-type1116 head2110 r2092 (quote (())) #f #f mod2095)) (lambda (type2113 value2114 ee2115 ww2116 ss2117 modmod2118) (let ((t2119 type2113)) (if (memv t2119 (quote (module-ref))) (let ((val2120 (chi1118 val2112 r2092 w2093 mod2095))) (call-with-values (lambda () (value2114 (cons head2110 tail2111))) (lambda (id2122 mod2123) (build-annotated1059 s2094 (list (quote set!) (if mod2123 (make-module-ref (cdr mod2123) id2122 (car mod2123)) (make-module-ref mod2123 id2122 (quote bare))) val2120))))) (build-annotated1059 s2094 (cons (chi1118 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2110) r2092 w2093 mod2095) (map (lambda (e2124) (chi1118 e2124 r2092 w2093 mod2095)) (append tail2111 (list val2112)))))))))) tmp2108) ((lambda (_2126) (syntax-violation (quote set!) "bad set!" (source-wrap1111 e2091 w2093 s2094 mod2095))) tmp2096))) ($sc-dispatch tmp2096 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2096 (quote (any any any))))) e2091))) (global-extend1080 (quote module-ref) (quote @) (lambda (e2127) ((lambda (tmp2128) ((lambda (tmp2129) (if (if tmp2129 (apply (lambda (_2130 mod2131 id2132) (and (andmap id?1082 mod2131) (id?1082 id2132))) tmp2129) #f) (apply (lambda (_2134 mod2135 id2136) (values (syntax->datum id2136) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2135)))) tmp2129) (syntax-violation #f "source expression failed to match any pattern" tmp2128))) ($sc-dispatch tmp2128 (quote (any each-any any))))) e2127))) (global-extend1080 (quote module-ref) (quote @@) (lambda (e2138) ((lambda (tmp2139) ((lambda (tmp2140) (if (if tmp2140 (apply (lambda (_2141 mod2142 id2143) (and (andmap id?1082 mod2142) (id?1082 id2143))) tmp2140) #f) (apply (lambda (_2145 mod2146 id2147) (values (syntax->datum id2147) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2146)))) tmp2140) (syntax-violation #f "source expression failed to match any pattern" tmp2139))) ($sc-dispatch tmp2139 (quote (any each-any any))))) e2138))) (global-extend1080 (quote begin) (quote begin) (quote ())) (global-extend1080 (quote define) (quote define) (quote ())) (global-extend1080 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1080 (quote eval-when) (quote eval-when) (quote ())) (global-extend1080 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2152 (lambda (x2153 keys2154 clauses2155 r2156 mod2157) (if (null? clauses2155) (build-annotated1059 #f (list (build-annotated1059 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2153)) ((lambda (tmp2158) ((lambda (tmp2159) (if tmp2159 (apply (lambda (pat2160 exp2161) (if (and (id?1082 pat2160) (andmap (lambda (x2162) (not (free-id=?1105 pat2160 x2162))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2154))) (let ((labels2163 (list (gen-label1087))) (var2164 (gen-var1130 pat2160))) (build-annotated1059 #f (list (build-annotated1059 #f (list (quote lambda) (list var2164) (chi1118 exp2161 (extend-env1076 labels2163 (list (cons (quote syntax) (cons var2164 0))) r2156) (make-binding-wrap1099 (list pat2160) labels2163 (quote (()))) mod2157))) x2153))) (gen-clause2151 x2153 keys2154 (cdr clauses2155) r2156 pat2160 #t exp2161 mod2157))) tmp2159) ((lambda (tmp2165) (if tmp2165 (apply (lambda (pat2166 fender2167 exp2168) (gen-clause2151 x2153 keys2154 (cdr clauses2155) r2156 pat2166 fender2167 exp2168 mod2157)) tmp2165) ((lambda (_2169) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2155))) tmp2158))) ($sc-dispatch tmp2158 (quote (any any any)))))) ($sc-dispatch tmp2158 (quote (any any))))) (car clauses2155))))) (gen-clause2151 (lambda (x2170 keys2171 clauses2172 r2173 pat2174 fender2175 exp2176 mod2177) (call-with-values (lambda () (convert-pattern2149 pat2174 keys2171)) (lambda (p2178 pvars2179) (cond ((not (distinct-bound-ids?1108 (map car pvars2179))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2174)) ((not (andmap (lambda (x2180) (not (ellipsis?1127 (car x2180)))) pvars2179)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2174)) (else (let ((y2181 (gen-var1130 (quote tmp)))) (build-annotated1059 #f (list (build-annotated1059 #f (list (quote lambda) (list y2181) (let ((y2182 (build-annotated1059 #f y2181))) (build-annotated1059 #f (list (quote if) ((lambda (tmp2183) ((lambda (tmp2184) (if tmp2184 (apply (lambda () y2182) tmp2184) ((lambda (_2185) (build-annotated1059 #f (list (quote if) y2182 (build-dispatch-call2150 pvars2179 fender2175 y2182 r2173 mod2177) (build-data1060 #f #f)))) tmp2183))) ($sc-dispatch tmp2183 (quote #(atom #t))))) fender2175) (build-dispatch-call2150 pvars2179 exp2176 y2182 r2173 mod2177) (gen-syntax-case2152 x2170 keys2171 clauses2172 r2173 mod2177)))))) (if (eq? p2178 (quote any)) (build-annotated1059 #f (list (build-annotated1059 #f (quote list)) x2170)) (build-annotated1059 #f (list (build-annotated1059 #f (quote $sc-dispatch)) x2170 (build-data1060 #f p2178))))))))))))) (build-dispatch-call2150 (lambda (pvars2186 exp2187 y2188 r2189 mod2190) (let ((ids2191 (map car pvars2186)) (levels2192 (map cdr pvars2186))) (let ((labels2193 (gen-labels1088 ids2191)) (new-vars2194 (map gen-var1130 ids2191))) (build-annotated1059 #f (list (build-annotated1059 #f (quote apply)) (build-annotated1059 #f (list (quote lambda) new-vars2194 (chi1118 exp2187 (extend-env1076 labels2193 (map (lambda (var2195 level2196) (cons (quote syntax) (cons var2195 level2196))) new-vars2194 (map cdr pvars2186)) r2189) (make-binding-wrap1099 ids2191 labels2193 (quote (()))) mod2190))) y2188)))))) (convert-pattern2149 (lambda (pattern2197 keys2198) (let cvt2199 ((p2200 pattern2197) (n2201 0) (ids2202 (quote ()))) (if (id?1082 p2200) (if (bound-id-member?1109 p2200 keys2198) (values (vector (quote free-id) p2200) ids2202) (values (quote any) (cons (cons p2200 n2201) ids2202))) ((lambda (tmp2203) ((lambda (tmp2204) (if (if tmp2204 (apply (lambda (x2205 dots2206) (ellipsis?1127 dots2206)) tmp2204) #f) (apply (lambda (x2207 dots2208) (call-with-values (lambda () (cvt2199 x2207 (fx+1050 n2201 1) ids2202)) (lambda (p2209 ids2210) (values (if (eq? p2209 (quote any)) (quote each-any) (vector (quote each) p2209)) ids2210)))) tmp2204) ((lambda (tmp2211) (if tmp2211 (apply (lambda (x2212 y2213) (call-with-values (lambda () (cvt2199 y2213 n2201 ids2202)) (lambda (y2214 ids2215) (call-with-values (lambda () (cvt2199 x2212 n2201 ids2215)) (lambda (x2216 ids2217) (values (cons x2216 y2214) ids2217)))))) tmp2211) ((lambda (tmp2218) (if tmp2218 (apply (lambda () (values (quote ()) ids2202)) tmp2218) ((lambda (tmp2219) (if tmp2219 (apply (lambda (x2220) (call-with-values (lambda () (cvt2199 x2220 n2201 ids2202)) (lambda (p2222 ids2223) (values (vector (quote vector) p2222) ids2223)))) tmp2219) ((lambda (x2224) (values (vector (quote atom) (strip1129 p2200 (quote (())))) ids2202)) tmp2203))) ($sc-dispatch tmp2203 (quote #(vector each-any)))))) ($sc-dispatch tmp2203 (quote ()))))) ($sc-dispatch tmp2203 (quote (any . any)))))) ($sc-dispatch tmp2203 (quote (any any))))) p2200)))))) (lambda (e2225 r2226 w2227 s2228 mod2229) (let ((e2230 (source-wrap1111 e2225 w2227 s2228 mod2229))) ((lambda (tmp2231) ((lambda (tmp2232) (if tmp2232 (apply (lambda (_2233 val2234 key2235 m2236) (if (andmap (lambda (x2237) (and (id?1082 x2237) (not (ellipsis?1127 x2237)))) key2235) (let ((x2239 (gen-var1130 (quote tmp)))) (build-annotated1059 s2228 (list (build-annotated1059 #f (list (quote lambda) (list x2239) (gen-syntax-case2152 (build-annotated1059 #f x2239) key2235 m2236 r2226 mod2229))) (chi1118 val2234 r2226 (quote (())) mod2229)))) (syntax-violation (quote syntax-case) "invalid literals list" e2230))) tmp2232) (syntax-violation #f "source expression failed to match any pattern" tmp2231))) ($sc-dispatch tmp2231 (quote (any any each-any . each-any))))) e2230))))) (set! sc-expand (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2244) (if (and (pair? x2244) (equal? (car x2244) noexpand1049)) (cadr x2244) (chi-top1117 x2244 (quote ()) (quote ((top))) m2242 esew2243 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2245 (quote e)) (esew2246 (quote (eval)))) (lambda (x2248 . rest2247) (if (and (pair? x2248) (equal? (car x2248) noexpand1049)) (cadr x2248) (chi-top1117 x2248 (quote ()) (quote ((top))) (if (null? rest2247) m2245 (car rest2247)) (if (or (null? rest2247) (null? (cdr rest2247))) esew2246 (cadr rest2247)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2249) (nonsymbol-id?1081 x2249))) (set! datum->syntax (lambda (id2250 datum2251) (make-syntax-object1065 datum2251 (syntax-object-wrap1068 id2250) #f))) (set! syntax->datum (lambda (x2252) (strip1129 x2252 (quote (()))))) (set! generate-temporaries (lambda (ls2253) (begin (let ((x2254 ls2253)) (if (not (list? x2254)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2254))) (map (lambda (x2255) (wrap1110 (gensym) (quote ((top))) #f)) ls2253)))) (set! free-identifier=? (lambda (x2256 y2257) (begin (let ((x2258 x2256)) (if (not (nonsymbol-id?1081 x2258)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2258))) (let ((x2259 y2257)) (if (not (nonsymbol-id?1081 x2259)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2259))) (free-id=?1105 x2256 y2257)))) (set! bound-identifier=? (lambda (x2260 y2261) (begin (let ((x2262 x2260)) (if (not (nonsymbol-id?1081 x2262)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2262))) (let ((x2263 y2261)) (if (not (nonsymbol-id?1081 x2263)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2263))) (bound-id=?1106 x2260 y2261)))) (set! syntax-violation (lambda (who2267 message2266 form2265 . subform2264) (begin (let ((x2268 who2267)) (if (not ((lambda (x2269) (or (not x2269) (string? x2269) (symbol? x2269))) x2268)) (error-hook1056 (quote syntax-violation) "invalid argument" x2268))) (let ((x2270 message2266)) (if (not (string? x2270)) (error-hook1056 (quote syntax-violation) "invalid argument" x2270))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2267 "~a: " "") "~a " (if (null? subform2264) "in ~a" "in subform `~s' of `~s'")) (let ((tail2271 (cons message2266 (map (lambda (x2272) (strip1129 x2272 (quote (())))) (append subform2264 (list form2265)))))) (if who2267 (cons who2267 tail2271) tail2271)) #f)))) (set! install-global-transformer (lambda (sym2273 v2274) (begin (let ((x2275 sym2273)) (if (not (symbol? x2275)) (error-hook1056 (quote define-syntax) "invalid argument" x2275))) (let ((x2276 v2274)) (if (not (procedure? x2276)) (error-hook1056 (quote define-syntax) "invalid argument" x2276))) (global-extend1080 (quote macro) sym2273 v2274)))) (letrec ((match2281 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((not r2285) #f) ((eq? p2283 (quote any)) (cons (wrap1110 e2282 w2284 mod2286) r2285)) ((syntax-object?1066 e2282) (match*2280 (let ((e2287 (syntax-object-expression1067 e2282))) (if (annotation? e2287) (annotation-expression e2287) e2287)) p2283 (join-wraps1101 w2284 (syntax-object-wrap1068 e2282)) r2285 (syntax-object-module1069 e2282))) (else (match*2280 (let ((e2288 e2282)) (if (annotation? e2288) (annotation-expression e2288) e2288)) p2283 w2284 r2285 mod2286))))) (match*2280 (lambda (e2289 p2290 w2291 r2292 mod2293) (cond ((null? p2290) (and (null? e2289) r2292)) ((pair? p2290) (and (pair? e2289) (match2281 (car e2289) (car p2290) w2291 (match2281 (cdr e2289) (cdr p2290) w2291 r2292 mod2293) mod2293))) ((eq? p2290 (quote each-any)) (let ((l2294 (match-each-any2278 e2289 w2291 mod2293))) (and l2294 (cons l2294 r2292)))) (else (let ((t2295 (vector-ref p2290 0))) (if (memv t2295 (quote (each))) (if (null? e2289) (match-empty2279 (vector-ref p2290 1) r2292) (let ((l2296 (match-each2277 e2289 (vector-ref p2290 1) w2291 mod2293))) (and l2296 (let collect2297 ((l2298 l2296)) (if (null? (car l2298)) r2292 (cons (map car l2298) (collect2297 (map cdr l2298)))))))) (if (memv t2295 (quote (free-id))) (and (id?1082 e2289) (free-id=?1105 (wrap1110 e2289 w2291 mod2293) (vector-ref p2290 1)) r2292) (if (memv t2295 (quote (atom))) (and (equal? (vector-ref p2290 1) (strip1129 e2289 w2291)) r2292) (if (memv t2295 (quote (vector))) (and (vector? e2289) (match2281 (vector->list e2289) (vector-ref p2290 1) w2291 r2292 mod2293))))))))))) (match-empty2279 (lambda (p2299 r2300) (cond ((null? p2299) r2300) ((eq? p2299 (quote any)) (cons (quote ()) r2300)) ((pair? p2299) (match-empty2279 (car p2299) (match-empty2279 (cdr p2299) r2300))) ((eq? p2299 (quote each-any)) (cons (quote ()) r2300)) (else (let ((t2301 (vector-ref p2299 0))) (if (memv t2301 (quote (each))) (match-empty2279 (vector-ref p2299 1) r2300) (if (memv t2301 (quote (free-id atom))) r2300 (if (memv t2301 (quote (vector))) (match-empty2279 (vector-ref p2299 1) r2300))))))))) (match-each-any2278 (lambda (e2302 w2303 mod2304) (cond ((annotation? e2302) (match-each-any2278 (annotation-expression e2302) w2303 mod2304)) ((pair? e2302) (let ((l2305 (match-each-any2278 (cdr e2302) w2303 mod2304))) (and l2305 (cons (wrap1110 (car e2302) w2303 mod2304) l2305)))) ((null? e2302) (quote ())) ((syntax-object?1066 e2302) (match-each-any2278 (syntax-object-expression1067 e2302) (join-wraps1101 w2303 (syntax-object-wrap1068 e2302)) mod2304)) (else #f)))) (match-each2277 (lambda (e2306 p2307 w2308 mod2309) (cond ((annotation? e2306) (match-each2277 (annotation-expression e2306) p2307 w2308 mod2309)) ((pair? e2306) (let ((first2310 (match2281 (car e2306) p2307 w2308 (quote ()) mod2309))) (and first2310 (let ((rest2311 (match-each2277 (cdr e2306) p2307 w2308 mod2309))) (and rest2311 (cons first2310 rest2311)))))) ((null? e2306) (quote ())) ((syntax-object?1066 e2306) (match-each2277 (syntax-object-expression1067 e2306) p2307 (join-wraps1101 w2308 (syntax-object-wrap1068 e2306)) (syntax-object-module1069 e2306))) (else #f))))) (set! $sc-dispatch (lambda (e2312 p2313) (cond ((eq? p2313 (quote any)) (list e2312)) ((syntax-object?1066 e2312) (match*2280 (let ((e2314 (syntax-object-expression1067 e2312))) (if (annotation? e2314) (annotation-expression e2314) e2314)) p2313 (syntax-object-wrap1068 e2312) (quote ()) (syntax-object-module1069 e2312))) (else (match*2280 (let ((e2315 e2312)) (if (annotation? e2315) (annotation-expression e2315) e2315)) p2313 (quote (())) (quote ()) #f)))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x2316) ((lambda (tmp2317) ((lambda (tmp2318) (if tmp2318 (apply (lambda (_2319 e12320 e22321) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12320 e22321))) tmp2318) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2326 (quote ()) (list out2325 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12327 e22328))))) tmp2323) ((lambda (tmp2330) (if tmp2330 (apply (lambda (_2331 out2332 in2333 e12334 e22335) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2333) (quote ()) (list out2332 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12334 e22335))))) tmp2330) (syntax-violation #f "source expression failed to match any pattern" tmp2317))) ($sc-dispatch tmp2317 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2317 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2317 (quote (any () any . each-any))))) x2316)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2339) ((lambda (tmp2340) ((lambda (tmp2341) (if tmp2341 (apply (lambda (_2342 k2343 keyword2344 pattern2345 template2346) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2343 (map (lambda (tmp2349 tmp2348) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2348) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2349))) template2346 pattern2345)))))) tmp2341) (syntax-violation #f "source expression failed to match any pattern" tmp2340))) ($sc-dispatch tmp2340 (quote (any each-any . #(each ((any . any) any))))))) x2339)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2350) ((lambda (tmp2351) ((lambda (tmp2352) (if (if tmp2352 (apply (lambda (let*2353 x2354 v2355 e12356 e22357) (andmap identifier? x2354)) tmp2352) #f) (apply (lambda (let*2359 x2360 v2361 e12362 e22363) (let f2364 ((bindings2365 (map list x2360 v2361))) (if (null? bindings2365) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12362 e22363))) ((lambda (tmp2369) ((lambda (tmp2370) (if tmp2370 (apply (lambda (body2371 binding2372) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2372) body2371)) tmp2370) (syntax-violation #f "source expression failed to match any pattern" tmp2369))) ($sc-dispatch tmp2369 (quote (any any))))) (list (f2364 (cdr bindings2365)) (car bindings2365)))))) tmp2352) (syntax-violation #f "source expression failed to match any pattern" tmp2351))) ($sc-dispatch tmp2351 (quote (any #(each (any any)) any . each-any))))) x2350)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2373) ((lambda (tmp2374) ((lambda (tmp2375) (if tmp2375 (apply (lambda (_2376 var2377 init2378 step2379 e02380 e12381 c2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply (lambda (step2385) ((lambda (tmp2386) ((lambda (tmp2387) (if tmp2387 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2377 init2378) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02380) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2382 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2385))))))) tmp2387) ((lambda (tmp2392) (if tmp2392 (apply (lambda (e12393 e22394) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2377 init2378) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02380 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12393 e22394)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2382 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2385))))))) tmp2392) (syntax-violation #f "source expression failed to match any pattern" tmp2386))) ($sc-dispatch tmp2386 (quote (any . each-any)))))) ($sc-dispatch tmp2386 (quote ())))) e12381)) tmp2384) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) ($sc-dispatch tmp2383 (quote each-any)))) (map (lambda (v2401 s2402) ((lambda (tmp2403) ((lambda (tmp2404) (if tmp2404 (apply (lambda () v2401) tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (e2406) e2406) tmp2405) ((lambda (_2407) (syntax-violation (quote do) "bad step expression" orig-x2373 s2402)) tmp2403))) ($sc-dispatch tmp2403 (quote (any)))))) ($sc-dispatch tmp2403 (quote ())))) s2402)) var2377 step2379))) tmp2375) (syntax-violation #f "source expression failed to match any pattern" tmp2374))) ($sc-dispatch tmp2374 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2373)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2410 (lambda (x2414 y2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (x2418 y2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dy2422) ((lambda (tmp2423) ((lambda (tmp2424) (if tmp2424 (apply (lambda (dx2425) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2425 dy2422))) tmp2424) ((lambda (_2426) (if (null? dy2422) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2418) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2418 y2419))) tmp2423))) ($sc-dispatch tmp2423 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2418)) tmp2421) ((lambda (tmp2427) (if tmp2427 (apply (lambda (stuff2428) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2418 stuff2428))) tmp2427) ((lambda (else2429) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2418 y2419)) tmp2420))) ($sc-dispatch tmp2420 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2420 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2419)) tmp2417) (syntax-violation #f "source expression failed to match any pattern" tmp2416))) ($sc-dispatch tmp2416 (quote (any any))))) (list x2414 y2415)))) (quasiappend2411 (lambda (x2430 y2431) ((lambda (tmp2432) ((lambda (tmp2433) (if tmp2433 (apply (lambda (x2434 y2435) ((lambda (tmp2436) ((lambda (tmp2437) (if tmp2437 (apply (lambda () x2434) tmp2437) ((lambda (_2438) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2434 y2435)) tmp2436))) ($sc-dispatch tmp2436 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2435)) tmp2433) (syntax-violation #f "source expression failed to match any pattern" tmp2432))) ($sc-dispatch tmp2432 (quote (any any))))) (list x2430 y2431)))) (quasivector2412 (lambda (x2439) ((lambda (tmp2440) ((lambda (x2441) ((lambda (tmp2442) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2444))) tmp2443) ((lambda (tmp2446) (if tmp2446 (apply (lambda (x2447) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2447)) tmp2446) ((lambda (_2449) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2441)) tmp2442))) ($sc-dispatch tmp2442 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2442 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2441)) tmp2440)) x2439))) (quasi2413 (lambda (p2450 lev2451) ((lambda (tmp2452) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454) (if (= lev2451 0) p2454 (quasicons2410 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2413 (list p2454) (- lev2451 1))))) tmp2453) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456 q2457) (if (= lev2451 0) (quasiappend2411 p2456 (quasi2413 q2457 lev2451)) (quasicons2410 (quasicons2410 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2413 (list p2456) (- lev2451 1))) (quasi2413 q2457 lev2451)))) tmp2455) ((lambda (tmp2458) (if tmp2458 (apply (lambda (p2459) (quasicons2410 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2413 (list p2459) (+ lev2451 1)))) tmp2458) ((lambda (tmp2460) (if tmp2460 (apply (lambda (p2461 q2462) (quasicons2410 (quasi2413 p2461 lev2451) (quasi2413 q2462 lev2451))) tmp2460) ((lambda (tmp2463) (if tmp2463 (apply (lambda (x2464) (quasivector2412 (quasi2413 x2464 lev2451))) tmp2463) ((lambda (p2466) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2466)) tmp2452))) ($sc-dispatch tmp2452 (quote #(vector each-any)))))) ($sc-dispatch tmp2452 (quote (any . any)))))) ($sc-dispatch tmp2452 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2452 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2452 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2450)))) (lambda (x2467) ((lambda (tmp2468) ((lambda (tmp2469) (if tmp2469 (apply (lambda (_2470 e2471) (quasi2413 e2471 0)) tmp2469) (syntax-violation #f "source expression failed to match any pattern" tmp2468))) ($sc-dispatch tmp2468 (quote (any any))))) x2467))))) -(define include (make-syncase-macro (quote macro) (lambda (x2472) (letrec ((read-file2473 (lambda (fn2474 k2475) (let ((p2476 (open-input-file fn2474))) (let f2477 ((x2478 (read p2476))) (if (eof-object? x2478) (begin (close-input-port p2476) (quote ())) (cons (datum->syntax k2475 x2478) (f2477 (read p2476))))))))) ((lambda (tmp2479) ((lambda (tmp2480) (if tmp2480 (apply (lambda (k2481 filename2482) (let ((fn2483 (syntax->datum filename2482))) ((lambda (tmp2484) ((lambda (tmp2485) (if tmp2485 (apply (lambda (exp2486) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2486)) tmp2485) (syntax-violation #f "source expression failed to match any pattern" tmp2484))) ($sc-dispatch tmp2484 (quote each-any)))) (read-file2473 fn2483 k2481)))) tmp2480) (syntax-violation #f "source expression failed to match any pattern" tmp2479))) ($sc-dispatch tmp2479 (quote (any any))))) x2472))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x2488) ((lambda (tmp2489) ((lambda (tmp2490) (if tmp2490 (apply (lambda (_2491 e2492) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2492))) tmp2490) (syntax-violation #f "source expression failed to match any pattern" tmp2489))) ($sc-dispatch tmp2489 (quote (any any))))) x2488)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2493) ((lambda (tmp2494) ((lambda (tmp2495) (if tmp2495 (apply (lambda (_2496 e2497) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2497))) tmp2495) (syntax-violation #f "source expression failed to match any pattern" tmp2494))) ($sc-dispatch tmp2494 (quote (any any))))) x2493)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2498) ((lambda (tmp2499) ((lambda (tmp2500) (if tmp2500 (apply (lambda (_2501 e2502 m12503 m22504) ((lambda (tmp2505) ((lambda (body2506) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2502)) body2506)) tmp2505)) (let f2507 ((clause2508 m12503) (clauses2509 m22504)) (if (null? clauses2509) ((lambda (tmp2511) ((lambda (tmp2512) (if tmp2512 (apply (lambda (e12513 e22514) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12513 e22514))) tmp2512) ((lambda (tmp2516) (if tmp2516 (apply (lambda (k2517 e12518 e22519) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2517)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12518 e22519)))) tmp2516) ((lambda (_2522) (syntax-violation (quote case) "bad clause" x2498 clause2508)) tmp2511))) ($sc-dispatch tmp2511 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2511 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2508) ((lambda (tmp2523) ((lambda (rest2524) ((lambda (tmp2525) ((lambda (tmp2526) (if tmp2526 (apply (lambda (k2527 e12528 e22529) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2527)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12528 e22529)) rest2524)) tmp2526) ((lambda (_2532) (syntax-violation (quote case) "bad clause" x2498 clause2508)) tmp2525))) ($sc-dispatch tmp2525 (quote (each-any any . each-any))))) clause2508)) tmp2523)) (f2507 (car clauses2509) (cdr clauses2509))))))) tmp2500) (syntax-violation #f "source expression failed to match any pattern" tmp2499))) ($sc-dispatch tmp2499 (quote (any any any . each-any))))) x2498)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2533) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (_2536 e2537) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2537)) (list (cons _2536 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2537 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2535) (syntax-violation #f "source expression failed to match any pattern" tmp2534))) ($sc-dispatch tmp2534 (quote (any any))))) x2533)))) +(letrec ((lambda-var-list1261 (lambda (vars1466) (let lvl1467 ((vars1468 vars1466) (ls1469 (quote ())) (w1470 (quote (())))) (cond ((pair? vars1468) (lvl1467 (cdr vars1468) (cons (wrap1240 (car vars1468) w1470 #f) ls1469) w1470)) ((id?1212 vars1468) (cons (wrap1240 vars1468 w1470 #f) ls1469)) ((null? vars1468) ls1469) ((syntax-object?1196 vars1468) (lvl1467 (syntax-object-expression1197 vars1468) ls1469 (join-wraps1231 w1470 (syntax-object-wrap1198 vars1468)))) ((annotation? vars1468) (lvl1467 (annotation-expression vars1468) ls1469 w1470)) (else (cons vars1468 ls1469)))))) (gen-var1260 (lambda (id1471) (let ((id1472 (if (syntax-object?1196 id1471) (syntax-object-expression1197 id1471) id1471))) (if (annotation? id1472) (build-annotated1189 (annotation-source id1472) (gensym (symbol->string (annotation-expression id1472)))) (build-annotated1189 #f (gensym (symbol->string id1472))))))) (strip1259 (lambda (x1473 w1474) (if (memq (quote top) (wrap-marks1215 w1474)) (if (or (annotation? x1473) (and (pair? x1473) (annotation? (car x1473)))) (strip-annotation1258 x1473 #f) x1473) (let f1475 ((x1476 x1473)) (cond ((syntax-object?1196 x1476) (strip1259 (syntax-object-expression1197 x1476) (syntax-object-wrap1198 x1476))) ((pair? x1476) (let ((a1477 (f1475 (car x1476))) (d1478 (f1475 (cdr x1476)))) (if (and (eq? a1477 (car x1476)) (eq? d1478 (cdr x1476))) x1476 (cons a1477 d1478)))) ((vector? x1476) (let ((old1479 (vector->list x1476))) (let ((new1480 (map f1475 old1479))) (if (andmap eq? old1479 new1480) x1476 (list->vector new1480))))) (else x1476)))))) (strip-annotation1258 (lambda (x1481 parent1482) (cond ((pair? x1481) (let ((new1483 (cons #f #f))) (begin (if parent1482 (set-annotation-stripped! parent1482 new1483)) (set-car! new1483 (strip-annotation1258 (car x1481) #f)) (set-cdr! new1483 (strip-annotation1258 (cdr x1481) #f)) new1483))) ((annotation? x1481) (or (annotation-stripped x1481) (strip-annotation1258 (annotation-expression x1481) x1481))) ((vector? x1481) (let ((new1484 (make-vector (vector-length x1481)))) (begin (if parent1482 (set-annotation-stripped! parent1482 new1484)) (let loop1485 ((i1486 (- (vector-length x1481) 1))) (unless (fx<1183 i1486 0) (vector-set! new1484 i1486 (strip-annotation1258 (vector-ref x1481 i1486) #f)) (loop1485 (fx-1181 i1486 1)))) new1484))) (else x1481)))) (ellipsis?1257 (lambda (x1487) (and (nonsymbol-id?1211 x1487) (free-id=?1235 x1487 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1256 (lambda () (build-annotated1189 #f (list (build-annotated1189 #f (quote void)))))) (eval-local-transformer1255 (lambda (expanded1488 mod1489) (let ((p1490 (local-eval-hook1185 expanded1488 mod1489))) (if (procedure? p1490) p1490 (syntax-violation #f "nonprocedure transformer" p1490))))) (chi-local-syntax1254 (lambda (rec?1491 e1492 r1493 w1494 s1495 mod1496 k1497) ((lambda (tmp1498) ((lambda (tmp1499) (if tmp1499 (apply (lambda (_1500 id1501 val1502 e11503 e21504) (let ((ids1505 id1501)) (if (not (valid-bound-ids?1237 ids1505)) (syntax-violation #f "duplicate bound keyword" e1492) (let ((labels1507 (gen-labels1218 ids1505))) (let ((new-w1508 (make-binding-wrap1229 ids1505 labels1507 w1494))) (k1497 (cons e11503 e21504) (extend-env1206 labels1507 (let ((w1510 (if rec?1491 new-w1508 w1494)) (trans-r1511 (macros-only-env1208 r1493))) (map (lambda (x1512) (cons (quote macro) (eval-local-transformer1255 (chi1248 x1512 trans-r1511 w1510 mod1496) mod1496))) val1502)) r1493) new-w1508 s1495 mod1496)))))) tmp1499) ((lambda (_1514) (syntax-violation #f "bad local syntax definition" (source-wrap1241 e1492 w1494 s1495 mod1496))) tmp1498))) ($sc-dispatch tmp1498 (quote (any #(each (any any)) any . each-any))))) e1492))) (chi-lambda-clause1253 (lambda (e1515 docstring1516 c1517 r1518 w1519 mod1520 k1521) ((lambda (tmp1522) ((lambda (tmp1523) (if (if tmp1523 (apply (lambda (args1524 doc1525 e11526 e21527) (and (string? (syntax->datum doc1525)) (not docstring1516))) tmp1523) #f) (apply (lambda (args1528 doc1529 e11530 e21531) (chi-lambda-clause1253 e1515 doc1529 (cons args1528 (cons e11530 e21531)) r1518 w1519 mod1520 k1521)) tmp1523) ((lambda (tmp1533) (if tmp1533 (apply (lambda (id1534 e11535 e21536) (let ((ids1537 id1534)) (if (not (valid-bound-ids?1237 ids1537)) (syntax-violation (quote lambda) "invalid parameter list" e1515) (let ((labels1539 (gen-labels1218 ids1537)) (new-vars1540 (map gen-var1260 ids1537))) (k1521 new-vars1540 docstring1516 (chi-body1252 (cons e11535 e21536) e1515 (extend-var-env1207 labels1539 new-vars1540 r1518) (make-binding-wrap1229 ids1537 labels1539 w1519) mod1520)))))) tmp1533) ((lambda (tmp1542) (if tmp1542 (apply (lambda (ids1543 e11544 e21545) (let ((old-ids1546 (lambda-var-list1261 ids1543))) (if (not (valid-bound-ids?1237 old-ids1546)) (syntax-violation (quote lambda) "invalid parameter list" e1515) (let ((labels1547 (gen-labels1218 old-ids1546)) (new-vars1548 (map gen-var1260 old-ids1546))) (k1521 (let f1549 ((ls11550 (cdr new-vars1548)) (ls21551 (car new-vars1548))) (if (null? ls11550) ls21551 (f1549 (cdr ls11550) (cons (car ls11550) ls21551)))) docstring1516 (chi-body1252 (cons e11544 e21545) e1515 (extend-var-env1207 labels1547 new-vars1548 r1518) (make-binding-wrap1229 old-ids1546 labels1547 w1519) mod1520)))))) tmp1542) ((lambda (_1553) (syntax-violation (quote lambda) "bad lambda" e1515)) tmp1522))) ($sc-dispatch tmp1522 (quote (any any . each-any)))))) ($sc-dispatch tmp1522 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1522 (quote (any any any . each-any))))) c1517))) (chi-body1252 (lambda (body1554 outer-form1555 r1556 w1557 mod1558) (let ((r1559 (cons (quote ("placeholder" placeholder)) r1556))) (let ((ribcage1560 (make-ribcage1219 (quote ()) (quote ()) (quote ())))) (let ((w1561 (make-wrap1214 (wrap-marks1215 w1557) (cons ribcage1560 (wrap-subst1216 w1557))))) (let parse1562 ((body1563 (map (lambda (x1569) (cons r1559 (wrap1240 x1569 w1561 mod1558))) body1554)) (ids1564 (quote ())) (labels1565 (quote ())) (vars1566 (quote ())) (vals1567 (quote ())) (bindings1568 (quote ()))) (if (null? body1563) (syntax-violation #f "no expressions in body" outer-form1555) (let ((e1570 (cdar body1563)) (er1571 (caar body1563))) (call-with-values (lambda () (syntax-type1246 e1570 er1571 (quote (())) #f ribcage1560 mod1558)) (lambda (type1572 value1573 e1574 w1575 s1576 mod1577) (let ((t1578 type1572)) (if (memv t1578 (quote (define-form))) (let ((id1579 (wrap1240 value1573 w1575 mod1577)) (label1580 (gen-label1217))) (let ((var1581 (gen-var1260 id1579))) (begin (extend-ribcage!1228 ribcage1560 id1579 label1580) (parse1562 (cdr body1563) (cons id1579 ids1564) (cons label1580 labels1565) (cons var1581 vars1566) (cons (cons er1571 (wrap1240 e1574 w1575 mod1577)) vals1567) (cons (cons (quote lexical) var1581) bindings1568))))) (if (memv t1578 (quote (define-syntax-form))) (let ((id1582 (wrap1240 value1573 w1575 mod1577)) (label1583 (gen-label1217))) (begin (extend-ribcage!1228 ribcage1560 id1582 label1583) (parse1562 (cdr body1563) (cons id1582 ids1564) (cons label1583 labels1565) vars1566 vals1567 (cons (cons (quote macro) (cons er1571 (wrap1240 e1574 w1575 mod1577))) bindings1568)))) (if (memv t1578 (quote (begin-form))) ((lambda (tmp1584) ((lambda (tmp1585) (if tmp1585 (apply (lambda (_1586 e11587) (parse1562 (let f1588 ((forms1589 e11587)) (if (null? forms1589) (cdr body1563) (cons (cons er1571 (wrap1240 (car forms1589) w1575 mod1577)) (f1588 (cdr forms1589))))) ids1564 labels1565 vars1566 vals1567 bindings1568)) tmp1585) (syntax-violation #f "source expression failed to match any pattern" tmp1584))) ($sc-dispatch tmp1584 (quote (any . each-any))))) e1574) (if (memv t1578 (quote (local-syntax-form))) (chi-local-syntax1254 value1573 e1574 er1571 w1575 s1576 mod1577 (lambda (forms1591 er1592 w1593 s1594 mod1595) (parse1562 (let f1596 ((forms1597 forms1591)) (if (null? forms1597) (cdr body1563) (cons (cons er1592 (wrap1240 (car forms1597) w1593 mod1595)) (f1596 (cdr forms1597))))) ids1564 labels1565 vars1566 vals1567 bindings1568))) (if (null? ids1564) (build-sequence1191 #f (map (lambda (x1598) (chi1248 (cdr x1598) (car x1598) (quote (())) mod1577)) (cons (cons er1571 (source-wrap1241 e1574 w1575 s1576 mod1577)) (cdr body1563)))) (begin (if (not (valid-bound-ids?1237 ids1564)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1555)) (let loop1599 ((bs1600 bindings1568) (er-cache1601 #f) (r-cache1602 #f)) (if (not (null? bs1600)) (let ((b1603 (car bs1600))) (if (eq? (car b1603) (quote macro)) (let ((er1604 (cadr b1603))) (let ((r-cache1605 (if (eq? er1604 er-cache1601) r-cache1602 (macros-only-env1208 er1604)))) (begin (set-cdr! b1603 (eval-local-transformer1255 (chi1248 (cddr b1603) r-cache1605 (quote (())) mod1577) mod1577)) (loop1599 (cdr bs1600) er1604 r-cache1605)))) (loop1599 (cdr bs1600) er-cache1601 r-cache1602))))) (set-cdr! r1559 (extend-env1206 labels1565 bindings1568 (cdr r1559))) (build-letrec1194 #f vars1566 (map (lambda (x1606) (chi1248 (cdr x1606) (car x1606) (quote (())) mod1577)) vals1567) (build-sequence1191 #f (map (lambda (x1607) (chi1248 (cdr x1607) (car x1607) (quote (())) mod1577)) (cons (cons er1571 (source-wrap1241 e1574 w1575 s1576 mod1577)) (cdr body1563)))))))))))))))))))))) (chi-macro1251 (lambda (p1608 e1609 r1610 w1611 rib1612 mod1613) (letrec ((rebuild-macro-output1614 (lambda (x1615 m1616) (cond ((pair? x1615) (cons (rebuild-macro-output1614 (car x1615) m1616) (rebuild-macro-output1614 (cdr x1615) m1616))) ((syntax-object?1196 x1615) (let ((w1617 (syntax-object-wrap1198 x1615))) (let ((ms1618 (wrap-marks1215 w1617)) (s1619 (wrap-subst1216 w1617))) (if (and (pair? ms1618) (eq? (car ms1618) #f)) (make-syntax-object1195 (syntax-object-expression1197 x1615) (make-wrap1214 (cdr ms1618) (if rib1612 (cons rib1612 (cdr s1619)) (cdr s1619))) (syntax-object-module1199 x1615)) (make-syntax-object1195 (syntax-object-expression1197 x1615) (make-wrap1214 (cons m1616 ms1618) (if rib1612 (cons rib1612 (cons (quote shift) s1619)) (cons (quote shift) s1619))) (let ((pmod1620 (procedure-module p1608))) (if pmod1620 (cons (quote hygiene) (module-name pmod1620)) (quote (hygiene guile))))))))) ((vector? x1615) (let ((n1621 (vector-length x1615))) (let ((v1622 (make-vector n1621))) (let doloop1623 ((i1624 0)) (if (fx=1182 i1624 n1621) v1622 (begin (vector-set! v1622 i1624 (rebuild-macro-output1614 (vector-ref x1615 i1624) m1616)) (doloop1623 (fx+1180 i1624 1)))))))) ((symbol? x1615) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1241 e1609 w1611 s mod1613) x1615)) (else x1615))))) (rebuild-macro-output1614 (p1608 (wrap1240 e1609 (anti-mark1227 w1611) mod1613)) (string #\m))))) (chi-application1250 (lambda (x1625 e1626 r1627 w1628 s1629 mod1630) ((lambda (tmp1631) ((lambda (tmp1632) (if tmp1632 (apply (lambda (e01633 e11634) (build-annotated1189 s1629 (cons x1625 (map (lambda (e1635) (chi1248 e1635 r1627 w1628 mod1630)) e11634)))) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1631))) ($sc-dispatch tmp1631 (quote (any . each-any))))) e1626))) (chi-expr1249 (lambda (type1637 value1638 e1639 r1640 w1641 s1642 mod1643) (let ((t1644 type1637)) (if (memv t1644 (quote (lexical))) (build-annotated1189 s1642 value1638) (if (memv t1644 (quote (core external-macro))) (value1638 e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (module-ref))) (call-with-values (lambda () (value1638 e1639)) (lambda (id1645 mod1646) (build-annotated1189 s1642 (if mod1646 (make-module-ref (cdr mod1646) id1645 (car mod1646)) (make-module-ref mod1646 id1645 (quote bare)))))) (if (memv t1644 (quote (lexical-call))) (chi-application1250 (build-annotated1189 (source-annotation1203 (car e1639)) value1638) e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (global-call))) (chi-application1250 (build-annotated1189 (source-annotation1203 (car e1639)) (if (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643) (make-module-ref (cdr (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643)) value1638 (car (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643))) (make-module-ref (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643) value1638 (quote bare)))) e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (constant))) (build-data1190 s1642 (strip1259 (source-wrap1241 e1639 w1641 s1642 mod1643) (quote (())))) (if (memv t1644 (quote (global))) (build-annotated1189 s1642 (if mod1643 (make-module-ref (cdr mod1643) value1638 (car mod1643)) (make-module-ref mod1643 value1638 (quote bare)))) (if (memv t1644 (quote (call))) (chi-application1250 (chi1248 (car e1639) r1640 w1641 mod1643) e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (begin-form))) ((lambda (tmp1647) ((lambda (tmp1648) (if tmp1648 (apply (lambda (_1649 e11650 e21651) (chi-sequence1242 (cons e11650 e21651) r1640 w1641 s1642 mod1643)) tmp1648) (syntax-violation #f "source expression failed to match any pattern" tmp1647))) ($sc-dispatch tmp1647 (quote (any any . each-any))))) e1639) (if (memv t1644 (quote (local-syntax-form))) (chi-local-syntax1254 value1638 e1639 r1640 w1641 s1642 mod1643 chi-sequence1242) (if (memv t1644 (quote (eval-when-form))) ((lambda (tmp1653) ((lambda (tmp1654) (if tmp1654 (apply (lambda (_1655 x1656 e11657 e21658) (let ((when-list1659 (chi-when-list1245 e1639 x1656 w1641))) (if (memq (quote eval) when-list1659) (chi-sequence1242 (cons e11657 e21658) r1640 w1641 s1642 mod1643) (chi-void1256)))) tmp1654) (syntax-violation #f "source expression failed to match any pattern" tmp1653))) ($sc-dispatch tmp1653 (quote (any each-any any . each-any))))) e1639) (if (memv t1644 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1639 (wrap1240 value1638 w1641 mod1643)) (if (memv t1644 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1241 e1639 w1641 s1642 mod1643)) (if (memv t1644 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1241 e1639 w1641 s1642 mod1643)) (syntax-violation #f "unexpected syntax" (source-wrap1241 e1639 w1641 s1642 mod1643))))))))))))))))))) (chi1248 (lambda (e1662 r1663 w1664 mod1665) (call-with-values (lambda () (syntax-type1246 e1662 r1663 w1664 #f #f mod1665)) (lambda (type1666 value1667 e1668 w1669 s1670 mod1671) (chi-expr1249 type1666 value1667 e1668 r1663 w1669 s1670 mod1671))))) (chi-top1247 (lambda (e1672 r1673 w1674 m1675 esew1676 mod1677) (call-with-values (lambda () (syntax-type1246 e1672 r1673 w1674 #f #f mod1677)) (lambda (type1685 value1686 e1687 w1688 s1689 mod1690) (let ((t1691 type1685)) (if (memv t1691 (quote (begin-form))) ((lambda (tmp1692) ((lambda (tmp1693) (if tmp1693 (apply (lambda (_1694) (chi-void1256)) tmp1693) ((lambda (tmp1695) (if tmp1695 (apply (lambda (_1696 e11697 e21698) (chi-top-sequence1243 (cons e11697 e21698) r1673 w1688 s1689 m1675 esew1676 mod1690)) tmp1695) (syntax-violation #f "source expression failed to match any pattern" tmp1692))) ($sc-dispatch tmp1692 (quote (any any . each-any)))))) ($sc-dispatch tmp1692 (quote (any))))) e1687) (if (memv t1691 (quote (local-syntax-form))) (chi-local-syntax1254 value1686 e1687 r1673 w1688 s1689 mod1690 (lambda (body1700 r1701 w1702 s1703 mod1704) (chi-top-sequence1243 body1700 r1701 w1702 s1703 m1675 esew1676 mod1704))) (if (memv t1691 (quote (eval-when-form))) ((lambda (tmp1705) ((lambda (tmp1706) (if tmp1706 (apply (lambda (_1707 x1708 e11709 e21710) (let ((when-list1711 (chi-when-list1245 e1687 x1708 w1688)) (body1712 (cons e11709 e21710))) (cond ((eq? m1675 (quote e)) (if (memq (quote eval) when-list1711) (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote e) (quote (eval)) mod1690) (chi-void1256))) ((memq (quote load) when-list1711) (if (or (memq (quote compile) when-list1711) (and (eq? m1675 (quote c&e)) (memq (quote eval) when-list1711))) (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote c&e) (quote (compile load)) mod1690) (if (memq m1675 (quote (c c&e))) (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote c) (quote (load)) mod1690) (chi-void1256)))) ((or (memq (quote compile) when-list1711) (and (eq? m1675 (quote c&e)) (memq (quote eval) when-list1711))) (top-level-eval-hook1184 (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote e) (quote (eval)) mod1690) mod1690) (chi-void1256)) (else (chi-void1256))))) tmp1706) (syntax-violation #f "source expression failed to match any pattern" tmp1705))) ($sc-dispatch tmp1705 (quote (any each-any any . each-any))))) e1687) (if (memv t1691 (quote (define-syntax-form))) (let ((n1715 (id-var-name1234 value1686 w1688)) (r1716 (macros-only-env1208 r1673))) (let ((t1717 m1675)) (if (memv t1717 (quote (c))) (if (memq (quote compile) esew1676) (let ((e1718 (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)))) (begin (top-level-eval-hook1184 e1718 mod1690) (if (memq (quote load) esew1676) e1718 (chi-void1256)))) (if (memq (quote load) esew1676) (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)) (chi-void1256))) (if (memv t1717 (quote (c&e))) (let ((e1719 (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)))) (begin (top-level-eval-hook1184 e1719 mod1690) e1719)) (begin (if (memq (quote eval) esew1676) (top-level-eval-hook1184 (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)) mod1690)) (chi-void1256)))))) (if (memv t1691 (quote (define-form))) (let ((n1720 (id-var-name1234 value1686 w1688))) (let ((type1721 (binding-type1204 (lookup1209 n1720 r1673 mod1690)))) (let ((t1722 type1721)) (if (memv t1722 (quote (global core macro module-ref))) (let ((x1723 (build-annotated1189 s1689 (list (quote define) n1720 (chi1248 e1687 r1673 w1688 mod1690))))) (begin (if (eq? m1675 (quote c&e)) (top-level-eval-hook1184 x1723 mod1690)) x1723)) (if (memv t1722 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1687 (wrap1240 value1686 w1688 mod1690)) (syntax-violation #f "cannot define keyword at top level" e1687 (wrap1240 value1686 w1688 mod1690))))))) (let ((x1724 (chi-expr1249 type1685 value1686 e1687 r1673 w1688 s1689 mod1690))) (begin (if (eq? m1675 (quote c&e)) (top-level-eval-hook1184 x1724 mod1690)) x1724)))))))))))) (syntax-type1246 (lambda (e1725 r1726 w1727 s1728 rib1729 mod1730) (cond ((symbol? e1725) (let ((n1731 (id-var-name1234 e1725 w1727))) (let ((b1732 (lookup1209 n1731 r1726 mod1730))) (let ((type1733 (binding-type1204 b1732))) (let ((t1734 type1733)) (if (memv t1734 (quote (lexical))) (values type1733 (binding-value1205 b1732) e1725 w1727 s1728 mod1730) (if (memv t1734 (quote (global))) (values type1733 n1731 e1725 w1727 s1728 mod1730) (if (memv t1734 (quote (macro))) (syntax-type1246 (chi-macro1251 (binding-value1205 b1732) e1725 r1726 w1727 rib1729 mod1730) r1726 (quote (())) s1728 rib1729 mod1730) (values type1733 (binding-value1205 b1732) e1725 w1727 s1728 mod1730))))))))) ((pair? e1725) (let ((first1735 (car e1725))) (if (id?1212 first1735) (let ((n1736 (id-var-name1234 first1735 w1727))) (let ((b1737 (lookup1209 n1736 r1726 (or (and (syntax-object?1196 first1735) (syntax-object-module1199 first1735)) mod1730)))) (let ((type1738 (binding-type1204 b1737))) (let ((t1739 type1738)) (if (memv t1739 (quote (lexical))) (values (quote lexical-call) (binding-value1205 b1737) e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (global))) (values (quote global-call) n1736 e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (macro))) (syntax-type1246 (chi-macro1251 (binding-value1205 b1737) e1725 r1726 w1727 rib1729 mod1730) r1726 (quote (())) s1728 rib1729 mod1730) (if (memv t1739 (quote (core external-macro module-ref))) (values type1738 (binding-value1205 b1737) e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1205 b1737) e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (begin))) (values (quote begin-form) #f e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (eval-when))) (values (quote eval-when-form) #f e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (define))) ((lambda (tmp1740) ((lambda (tmp1741) (if (if tmp1741 (apply (lambda (_1742 name1743 val1744) (id?1212 name1743)) tmp1741) #f) (apply (lambda (_1745 name1746 val1747) (values (quote define-form) name1746 val1747 w1727 s1728 mod1730)) tmp1741) ((lambda (tmp1748) (if (if tmp1748 (apply (lambda (_1749 name1750 args1751 e11752 e21753) (and (id?1212 name1750) (valid-bound-ids?1237 (lambda-var-list1261 args1751)))) tmp1748) #f) (apply (lambda (_1754 name1755 args1756 e11757 e21758) (values (quote define-form) (wrap1240 name1755 w1727 mod1730) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1240 (cons args1756 (cons e11757 e21758)) w1727 mod1730)) (quote (())) s1728 mod1730)) tmp1748) ((lambda (tmp1760) (if (if tmp1760 (apply (lambda (_1761 name1762) (id?1212 name1762)) tmp1760) #f) (apply (lambda (_1763 name1764) (values (quote define-form) (wrap1240 name1764 w1727 mod1730) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1728 mod1730)) tmp1760) (syntax-violation #f "source expression failed to match any pattern" tmp1740))) ($sc-dispatch tmp1740 (quote (any any)))))) ($sc-dispatch tmp1740 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1740 (quote (any any any))))) e1725) (if (memv t1739 (quote (define-syntax))) ((lambda (tmp1765) ((lambda (tmp1766) (if (if tmp1766 (apply (lambda (_1767 name1768 val1769) (id?1212 name1768)) tmp1766) #f) (apply (lambda (_1770 name1771 val1772) (values (quote define-syntax-form) name1771 val1772 w1727 s1728 mod1730)) tmp1766) (syntax-violation #f "source expression failed to match any pattern" tmp1765))) ($sc-dispatch tmp1765 (quote (any any any))))) e1725) (values (quote call) #f e1725 w1727 s1728 mod1730)))))))))))))) (values (quote call) #f e1725 w1727 s1728 mod1730)))) ((syntax-object?1196 e1725) (syntax-type1246 (syntax-object-expression1197 e1725) r1726 (join-wraps1231 w1727 (syntax-object-wrap1198 e1725)) #f rib1729 (or (syntax-object-module1199 e1725) mod1730))) ((annotation? e1725) (syntax-type1246 (annotation-expression e1725) r1726 w1727 (annotation-source e1725) rib1729 mod1730)) ((self-evaluating? e1725) (values (quote constant) #f e1725 w1727 s1728 mod1730)) (else (values (quote other) #f e1725 w1727 s1728 mod1730))))) (chi-when-list1245 (lambda (e1773 when-list1774 w1775) (let f1776 ((when-list1777 when-list1774) (situations1778 (quote ()))) (if (null? when-list1777) situations1778 (f1776 (cdr when-list1777) (cons (let ((x1779 (car when-list1777))) (cond ((free-id=?1235 x1779 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1235 x1779 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1235 x1779 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1773 (wrap1240 x1779 w1775 #f))))) situations1778)))))) (chi-install-global1244 (lambda (name1780 e1781) (build-annotated1189 #f (list (build-annotated1189 #f (quote define)) name1780 (if (let ((v1782 (module-variable (current-module) name1780))) (and v1782 (variable-bound? v1782) (macro? (variable-ref v1782)) (not (eq? (macro-type (variable-ref v1782)) (quote syncase-macro))))) (build-annotated1189 #f (list (build-annotated1189 #f (quote make-extended-syncase-macro)) (build-annotated1189 #f (list (build-annotated1189 #f (quote module-ref)) (build-annotated1189 #f (quote (current-module))) (build-data1190 #f name1780))) (build-data1190 #f (quote macro)) e1781)) (build-annotated1189 #f (list (build-annotated1189 #f (quote make-syncase-macro)) (build-data1190 #f (quote macro)) e1781))))))) (chi-top-sequence1243 (lambda (body1783 r1784 w1785 s1786 m1787 esew1788 mod1789) (build-sequence1191 s1786 (let dobody1790 ((body1791 body1783) (r1792 r1784) (w1793 w1785) (m1794 m1787) (esew1795 esew1788) (mod1796 mod1789)) (if (null? body1791) (quote ()) (let ((first1797 (chi-top1247 (car body1791) r1792 w1793 m1794 esew1795 mod1796))) (cons first1797 (dobody1790 (cdr body1791) r1792 w1793 m1794 esew1795 mod1796)))))))) (chi-sequence1242 (lambda (body1798 r1799 w1800 s1801 mod1802) (build-sequence1191 s1801 (let dobody1803 ((body1804 body1798) (r1805 r1799) (w1806 w1800) (mod1807 mod1802)) (if (null? body1804) (quote ()) (let ((first1808 (chi1248 (car body1804) r1805 w1806 mod1807))) (cons first1808 (dobody1803 (cdr body1804) r1805 w1806 mod1807)))))))) (source-wrap1241 (lambda (x1809 w1810 s1811 defmod1812) (wrap1240 (if s1811 (make-annotation x1809 s1811 #f) x1809) w1810 defmod1812))) (wrap1240 (lambda (x1813 w1814 defmod1815) (cond ((and (null? (wrap-marks1215 w1814)) (null? (wrap-subst1216 w1814))) x1813) ((syntax-object?1196 x1813) (make-syntax-object1195 (syntax-object-expression1197 x1813) (join-wraps1231 w1814 (syntax-object-wrap1198 x1813)) (syntax-object-module1199 x1813))) ((null? x1813) x1813) (else (make-syntax-object1195 x1813 w1814 defmod1815))))) (bound-id-member?1239 (lambda (x1816 list1817) (and (not (null? list1817)) (or (bound-id=?1236 x1816 (car list1817)) (bound-id-member?1239 x1816 (cdr list1817)))))) (distinct-bound-ids?1238 (lambda (ids1818) (let distinct?1819 ((ids1820 ids1818)) (or (null? ids1820) (and (not (bound-id-member?1239 (car ids1820) (cdr ids1820))) (distinct?1819 (cdr ids1820))))))) (valid-bound-ids?1237 (lambda (ids1821) (and (let all-ids?1822 ((ids1823 ids1821)) (or (null? ids1823) (and (id?1212 (car ids1823)) (all-ids?1822 (cdr ids1823))))) (distinct-bound-ids?1238 ids1821)))) (bound-id=?1236 (lambda (i1824 j1825) (if (and (syntax-object?1196 i1824) (syntax-object?1196 j1825)) (and (eq? (let ((e1826 (syntax-object-expression1197 i1824))) (if (annotation? e1826) (annotation-expression e1826) e1826)) (let ((e1827 (syntax-object-expression1197 j1825))) (if (annotation? e1827) (annotation-expression e1827) e1827))) (same-marks?1233 (wrap-marks1215 (syntax-object-wrap1198 i1824)) (wrap-marks1215 (syntax-object-wrap1198 j1825)))) (eq? (let ((e1828 i1824)) (if (annotation? e1828) (annotation-expression e1828) e1828)) (let ((e1829 j1825)) (if (annotation? e1829) (annotation-expression e1829) e1829)))))) (free-id=?1235 (lambda (i1830 j1831) (and (eq? (let ((x1832 i1830)) (let ((e1833 (if (syntax-object?1196 x1832) (syntax-object-expression1197 x1832) x1832))) (if (annotation? e1833) (annotation-expression e1833) e1833))) (let ((x1834 j1831)) (let ((e1835 (if (syntax-object?1196 x1834) (syntax-object-expression1197 x1834) x1834))) (if (annotation? e1835) (annotation-expression e1835) e1835)))) (eq? (id-var-name1234 i1830 (quote (()))) (id-var-name1234 j1831 (quote (()))))))) (id-var-name1234 (lambda (id1836 w1837) (letrec ((search-vector-rib1840 (lambda (sym1846 subst1847 marks1848 symnames1849 ribcage1850) (let ((n1851 (vector-length symnames1849))) (let f1852 ((i1853 0)) (cond ((fx=1182 i1853 n1851) (search1838 sym1846 (cdr subst1847) marks1848)) ((and (eq? (vector-ref symnames1849 i1853) sym1846) (same-marks?1233 marks1848 (vector-ref (ribcage-marks1222 ribcage1850) i1853))) (values (vector-ref (ribcage-labels1223 ribcage1850) i1853) marks1848)) (else (f1852 (fx+1180 i1853 1)))))))) (search-list-rib1839 (lambda (sym1854 subst1855 marks1856 symnames1857 ribcage1858) (let f1859 ((symnames1860 symnames1857) (i1861 0)) (cond ((null? symnames1860) (search1838 sym1854 (cdr subst1855) marks1856)) ((and (eq? (car symnames1860) sym1854) (same-marks?1233 marks1856 (list-ref (ribcage-marks1222 ribcage1858) i1861))) (values (list-ref (ribcage-labels1223 ribcage1858) i1861) marks1856)) (else (f1859 (cdr symnames1860) (fx+1180 i1861 1))))))) (search1838 (lambda (sym1862 subst1863 marks1864) (if (null? subst1863) (values #f marks1864) (let ((fst1865 (car subst1863))) (if (eq? fst1865 (quote shift)) (search1838 sym1862 (cdr subst1863) (cdr marks1864)) (let ((symnames1866 (ribcage-symnames1221 fst1865))) (if (vector? symnames1866) (search-vector-rib1840 sym1862 subst1863 marks1864 symnames1866 fst1865) (search-list-rib1839 sym1862 subst1863 marks1864 symnames1866 fst1865))))))))) (cond ((symbol? id1836) (or (call-with-values (lambda () (search1838 id1836 (wrap-subst1216 w1837) (wrap-marks1215 w1837))) (lambda (x1868 . ignore1867) x1868)) id1836)) ((syntax-object?1196 id1836) (let ((id1869 (let ((e1871 (syntax-object-expression1197 id1836))) (if (annotation? e1871) (annotation-expression e1871) e1871))) (w11870 (syntax-object-wrap1198 id1836))) (let ((marks1872 (join-marks1232 (wrap-marks1215 w1837) (wrap-marks1215 w11870)))) (call-with-values (lambda () (search1838 id1869 (wrap-subst1216 w1837) marks1872)) (lambda (new-id1873 marks1874) (or new-id1873 (call-with-values (lambda () (search1838 id1869 (wrap-subst1216 w11870) marks1874)) (lambda (x1876 . ignore1875) x1876)) id1869)))))) ((annotation? id1836) (let ((id1877 (let ((e1878 id1836)) (if (annotation? e1878) (annotation-expression e1878) e1878)))) (or (call-with-values (lambda () (search1838 id1877 (wrap-subst1216 w1837) (wrap-marks1215 w1837))) (lambda (x1880 . ignore1879) x1880)) id1877))) (else (error-hook1186 (quote id-var-name) "invalid id" id1836)))))) (same-marks?1233 (lambda (x1881 y1882) (or (eq? x1881 y1882) (and (not (null? x1881)) (not (null? y1882)) (eq? (car x1881) (car y1882)) (same-marks?1233 (cdr x1881) (cdr y1882)))))) (join-marks1232 (lambda (m11883 m21884) (smart-append1230 m11883 m21884))) (join-wraps1231 (lambda (w11885 w21886) (let ((m11887 (wrap-marks1215 w11885)) (s11888 (wrap-subst1216 w11885))) (if (null? m11887) (if (null? s11888) w21886 (make-wrap1214 (wrap-marks1215 w21886) (smart-append1230 s11888 (wrap-subst1216 w21886)))) (make-wrap1214 (smart-append1230 m11887 (wrap-marks1215 w21886)) (smart-append1230 s11888 (wrap-subst1216 w21886))))))) (smart-append1230 (lambda (m11889 m21890) (if (null? m21890) m11889 (append m11889 m21890)))) (make-binding-wrap1229 (lambda (ids1891 labels1892 w1893) (if (null? ids1891) w1893 (make-wrap1214 (wrap-marks1215 w1893) (cons (let ((labelvec1894 (list->vector labels1892))) (let ((n1895 (vector-length labelvec1894))) (let ((symnamevec1896 (make-vector n1895)) (marksvec1897 (make-vector n1895))) (begin (let f1898 ((ids1899 ids1891) (i1900 0)) (if (not (null? ids1899)) (call-with-values (lambda () (id-sym-name&marks1213 (car ids1899) w1893)) (lambda (symname1901 marks1902) (begin (vector-set! symnamevec1896 i1900 symname1901) (vector-set! marksvec1897 i1900 marks1902) (f1898 (cdr ids1899) (fx+1180 i1900 1))))))) (make-ribcage1219 symnamevec1896 marksvec1897 labelvec1894))))) (wrap-subst1216 w1893)))))) (extend-ribcage!1228 (lambda (ribcage1903 id1904 label1905) (begin (set-ribcage-symnames!1224 ribcage1903 (cons (let ((e1906 (syntax-object-expression1197 id1904))) (if (annotation? e1906) (annotation-expression e1906) e1906)) (ribcage-symnames1221 ribcage1903))) (set-ribcage-marks!1225 ribcage1903 (cons (wrap-marks1215 (syntax-object-wrap1198 id1904)) (ribcage-marks1222 ribcage1903))) (set-ribcage-labels!1226 ribcage1903 (cons label1905 (ribcage-labels1223 ribcage1903)))))) (anti-mark1227 (lambda (w1907) (make-wrap1214 (cons #f (wrap-marks1215 w1907)) (cons (quote shift) (wrap-subst1216 w1907))))) (set-ribcage-labels!1226 (lambda (x1908 update1909) (vector-set! x1908 3 update1909))) (set-ribcage-marks!1225 (lambda (x1910 update1911) (vector-set! x1910 2 update1911))) (set-ribcage-symnames!1224 (lambda (x1912 update1913) (vector-set! x1912 1 update1913))) (ribcage-labels1223 (lambda (x1914) (vector-ref x1914 3))) (ribcage-marks1222 (lambda (x1915) (vector-ref x1915 2))) (ribcage-symnames1221 (lambda (x1916) (vector-ref x1916 1))) (ribcage?1220 (lambda (x1917) (and (vector? x1917) (= (vector-length x1917) 4) (eq? (vector-ref x1917 0) (quote ribcage))))) (make-ribcage1219 (lambda (symnames1918 marks1919 labels1920) (vector (quote ribcage) symnames1918 marks1919 labels1920))) (gen-labels1218 (lambda (ls1921) (if (null? ls1921) (quote ()) (cons (gen-label1217) (gen-labels1218 (cdr ls1921)))))) (gen-label1217 (lambda () (string #\i))) (wrap-subst1216 cdr) (wrap-marks1215 car) (make-wrap1214 cons) (id-sym-name&marks1213 (lambda (x1922 w1923) (if (syntax-object?1196 x1922) (values (let ((e1924 (syntax-object-expression1197 x1922))) (if (annotation? e1924) (annotation-expression e1924) e1924)) (join-marks1232 (wrap-marks1215 w1923) (wrap-marks1215 (syntax-object-wrap1198 x1922)))) (values (let ((e1925 x1922)) (if (annotation? e1925) (annotation-expression e1925) e1925)) (wrap-marks1215 w1923))))) (id?1212 (lambda (x1926) (cond ((symbol? x1926) #t) ((syntax-object?1196 x1926) (symbol? (let ((e1927 (syntax-object-expression1197 x1926))) (if (annotation? e1927) (annotation-expression e1927) e1927)))) ((annotation? x1926) (symbol? (annotation-expression x1926))) (else #f)))) (nonsymbol-id?1211 (lambda (x1928) (and (syntax-object?1196 x1928) (symbol? (let ((e1929 (syntax-object-expression1197 x1928))) (if (annotation? e1929) (annotation-expression e1929) e1929)))))) (global-extend1210 (lambda (type1930 sym1931 val1932) (put-global-definition-hook1187 sym1931 type1930 val1932))) (lookup1209 (lambda (x1933 r1934 mod1935) (cond ((assq x1933 r1934) => cdr) ((symbol? x1933) (or (get-global-definition-hook1188 x1933 mod1935) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1208 (lambda (r1936) (if (null? r1936) (quote ()) (let ((a1937 (car r1936))) (if (eq? (cadr a1937) (quote macro)) (cons a1937 (macros-only-env1208 (cdr r1936))) (macros-only-env1208 (cdr r1936))))))) (extend-var-env1207 (lambda (labels1938 vars1939 r1940) (if (null? labels1938) r1940 (extend-var-env1207 (cdr labels1938) (cdr vars1939) (cons (cons (car labels1938) (cons (quote lexical) (car vars1939))) r1940))))) (extend-env1206 (lambda (labels1941 bindings1942 r1943) (if (null? labels1941) r1943 (extend-env1206 (cdr labels1941) (cdr bindings1942) (cons (cons (car labels1941) (car bindings1942)) r1943))))) (binding-value1205 cdr) (binding-type1204 car) (source-annotation1203 (lambda (x1944) (cond ((annotation? x1944) (annotation-source x1944)) ((syntax-object?1196 x1944) (source-annotation1203 (syntax-object-expression1197 x1944))) (else #f)))) (set-syntax-object-module!1202 (lambda (x1945 update1946) (vector-set! x1945 3 update1946))) (set-syntax-object-wrap!1201 (lambda (x1947 update1948) (vector-set! x1947 2 update1948))) (set-syntax-object-expression!1200 (lambda (x1949 update1950) (vector-set! x1949 1 update1950))) (syntax-object-module1199 (lambda (x1951) (vector-ref x1951 3))) (syntax-object-wrap1198 (lambda (x1952) (vector-ref x1952 2))) (syntax-object-expression1197 (lambda (x1953) (vector-ref x1953 1))) (syntax-object?1196 (lambda (x1954) (and (vector? x1954) (= (vector-length x1954) 4) (eq? (vector-ref x1954 0) (quote syntax-object))))) (make-syntax-object1195 (lambda (expression1955 wrap1956 module1957) (vector (quote syntax-object) expression1955 wrap1956 module1957))) (build-letrec1194 (lambda (src1958 vars1959 val-exps1960 body-exp1961) (if (null? vars1959) (build-annotated1189 src1958 body-exp1961) (build-annotated1189 src1958 (list (quote letrec) (map list vars1959 val-exps1960) body-exp1961))))) (build-named-let1193 (lambda (src1962 vars1963 val-exps1964 body-exp1965) (if (null? vars1963) (build-annotated1189 src1962 body-exp1965) (build-annotated1189 src1962 (list (quote let) (car vars1963) (map list (cdr vars1963) val-exps1964) body-exp1965))))) (build-let1192 (lambda (src1966 vars1967 val-exps1968 body-exp1969) (if (null? vars1967) (build-annotated1189 src1966 body-exp1969) (build-annotated1189 src1966 (list (quote let) (map list vars1967 val-exps1968) body-exp1969))))) (build-sequence1191 (lambda (src1970 exps1971) (if (null? (cdr exps1971)) (build-annotated1189 src1970 (car exps1971)) (build-annotated1189 src1970 (cons (quote begin) exps1971))))) (build-data1190 (lambda (src1972 exp1973) (if (and (self-evaluating? exp1973) (not (vector? exp1973))) (build-annotated1189 src1972 exp1973) (build-annotated1189 src1972 (list (quote quote) exp1973))))) (build-annotated1189 (lambda (src1974 exp1975) (if (and src1974 (not (annotation? exp1975))) (make-annotation exp1975 src1974 #t) exp1975))) (get-global-definition-hook1188 (lambda (symbol1976 module1977) (begin (if (and (not module1977) (current-module)) (warn "module system is booted, we should have a module" symbol1976)) (let ((v1978 (module-variable (if module1977 (resolve-module (cdr module1977)) (current-module)) symbol1976))) (and v1978 (variable-bound? v1978) (let ((val1979 (variable-ref v1978))) (and (macro? val1979) (syncase-macro-type val1979) (cons (syncase-macro-type val1979) (syncase-macro-binding val1979))))))))) (put-global-definition-hook1187 (lambda (symbol1980 type1981 val1982) (let ((existing1983 (let ((v1984 (module-variable (current-module) symbol1980))) (and v1984 (variable-bound? v1984) (let ((val1985 (variable-ref v1984))) (and (macro? val1985) (not (syncase-macro-type val1985)) val1985)))))) (module-define! (current-module) symbol1980 (if existing1983 (make-extended-syncase-macro existing1983 type1981 val1982) (make-syncase-macro type1981 val1982)))))) (error-hook1186 (lambda (who1986 why1987 what1988) (error who1986 "~a ~s" why1987 what1988))) (local-eval-hook1185 (lambda (x1989 mod1990) (primitive-eval (list noexpand1179 x1989)))) (top-level-eval-hook1184 (lambda (x1991 mod1992) (primitive-eval (list noexpand1179 x1991)))) (fx<1183 <) (fx=1182 =) (fx-1181 -) (fx+1180 +) (noexpand1179 "noexpand")) (begin (global-extend1210 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1210 (quote local-syntax) (quote let-syntax) #f) (global-extend1210 (quote core) (quote fluid-let-syntax) (lambda (e1993 r1994 w1995 s1996 mod1997) ((lambda (tmp1998) ((lambda (tmp1999) (if (if tmp1999 (apply (lambda (_2000 var2001 val2002 e12003 e22004) (valid-bound-ids?1237 var2001)) tmp1999) #f) (apply (lambda (_2006 var2007 val2008 e12009 e22010) (let ((names2011 (map (lambda (x2012) (id-var-name1234 x2012 w1995)) var2007))) (begin (for-each (lambda (id2014 n2015) (let ((t2016 (binding-type1204 (lookup1209 n2015 r1994 mod1997)))) (if (memv t2016 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1993 (source-wrap1241 id2014 w1995 s1996 mod1997))))) var2007 names2011) (chi-body1252 (cons e12009 e22010) (source-wrap1241 e1993 w1995 s1996 mod1997) (extend-env1206 names2011 (let ((trans-r2019 (macros-only-env1208 r1994))) (map (lambda (x2020) (cons (quote macro) (eval-local-transformer1255 (chi1248 x2020 trans-r2019 w1995 mod1997) mod1997))) val2008)) r1994) w1995 mod1997)))) tmp1999) ((lambda (_2022) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1241 e1993 w1995 s1996 mod1997))) tmp1998))) ($sc-dispatch tmp1998 (quote (any #(each (any any)) any . each-any))))) e1993))) (global-extend1210 (quote core) (quote quote) (lambda (e2023 r2024 w2025 s2026 mod2027) ((lambda (tmp2028) ((lambda (tmp2029) (if tmp2029 (apply (lambda (_2030 e2031) (build-data1190 s2026 (strip1259 e2031 w2025))) tmp2029) ((lambda (_2032) (syntax-violation (quote quote) "bad syntax" (source-wrap1241 e2023 w2025 s2026 mod2027))) tmp2028))) ($sc-dispatch tmp2028 (quote (any any))))) e2023))) (global-extend1210 (quote core) (quote syntax) (letrec ((regen2040 (lambda (x2041) (let ((t2042 (car x2041))) (if (memv t2042 (quote (ref))) (build-annotated1189 #f (cadr x2041)) (if (memv t2042 (quote (primitive))) (build-annotated1189 #f (cadr x2041)) (if (memv t2042 (quote (quote))) (build-data1190 #f (cadr x2041)) (if (memv t2042 (quote (lambda))) (build-annotated1189 #f (list (quote lambda) (cadr x2041) (regen2040 (caddr x2041)))) (if (memv t2042 (quote (map))) (let ((ls2043 (map regen2040 (cdr x2041)))) (build-annotated1189 #f (cons (if (fx=1182 (length ls2043) 2) (build-annotated1189 #f (quote map)) (build-annotated1189 #f (quote map))) ls2043))) (build-annotated1189 #f (cons (build-annotated1189 #f (car x2041)) (map regen2040 (cdr x2041)))))))))))) (gen-vector2039 (lambda (x2044) (cond ((eq? (car x2044) (quote list)) (cons (quote vector) (cdr x2044))) ((eq? (car x2044) (quote quote)) (list (quote quote) (list->vector (cadr x2044)))) (else (list (quote list->vector) x2044))))) (gen-append2038 (lambda (x2045 y2046) (if (equal? y2046 (quote (quote ()))) x2045 (list (quote append) x2045 y2046)))) (gen-cons2037 (lambda (x2047 y2048) (let ((t2049 (car y2048))) (if (memv t2049 (quote (quote))) (if (eq? (car x2047) (quote quote)) (list (quote quote) (cons (cadr x2047) (cadr y2048))) (if (eq? (cadr y2048) (quote ())) (list (quote list) x2047) (list (quote cons) x2047 y2048))) (if (memv t2049 (quote (list))) (cons (quote list) (cons x2047 (cdr y2048))) (list (quote cons) x2047 y2048)))))) (gen-map2036 (lambda (e2050 map-env2051) (let ((formals2052 (map cdr map-env2051)) (actuals2053 (map (lambda (x2054) (list (quote ref) (car x2054))) map-env2051))) (cond ((eq? (car e2050) (quote ref)) (car actuals2053)) ((andmap (lambda (x2055) (and (eq? (car x2055) (quote ref)) (memq (cadr x2055) formals2052))) (cdr e2050)) (cons (quote map) (cons (list (quote primitive) (car e2050)) (map (let ((r2056 (map cons formals2052 actuals2053))) (lambda (x2057) (cdr (assq (cadr x2057) r2056)))) (cdr e2050))))) (else (cons (quote map) (cons (list (quote lambda) formals2052 e2050) actuals2053))))))) (gen-mappend2035 (lambda (e2058 map-env2059) (list (quote apply) (quote (primitive append)) (gen-map2036 e2058 map-env2059)))) (gen-ref2034 (lambda (src2060 var2061 level2062 maps2063) (if (fx=1182 level2062 0) (values var2061 maps2063) (if (null? maps2063) (syntax-violation (quote syntax) "missing ellipsis" src2060) (call-with-values (lambda () (gen-ref2034 src2060 var2061 (fx-1181 level2062 1) (cdr maps2063))) (lambda (outer-var2064 outer-maps2065) (let ((b2066 (assq outer-var2064 (car maps2063)))) (if b2066 (values (cdr b2066) maps2063) (let ((inner-var2067 (gen-var1260 (quote tmp)))) (values inner-var2067 (cons (cons (cons outer-var2064 inner-var2067) (car maps2063)) outer-maps2065))))))))))) (gen-syntax2033 (lambda (src2068 e2069 r2070 maps2071 ellipsis?2072 mod2073) (if (id?1212 e2069) (let ((label2074 (id-var-name1234 e2069 (quote (()))))) (let ((b2075 (lookup1209 label2074 r2070 mod2073))) (if (eq? (binding-type1204 b2075) (quote syntax)) (call-with-values (lambda () (let ((var.lev2076 (binding-value1205 b2075))) (gen-ref2034 src2068 (car var.lev2076) (cdr var.lev2076) maps2071))) (lambda (var2077 maps2078) (values (list (quote ref) var2077) maps2078))) (if (ellipsis?2072 e2069) (syntax-violation (quote syntax) "misplaced ellipsis" src2068) (values (list (quote quote) e2069) maps2071))))) ((lambda (tmp2079) ((lambda (tmp2080) (if (if tmp2080 (apply (lambda (dots2081 e2082) (ellipsis?2072 dots2081)) tmp2080) #f) (apply (lambda (dots2083 e2084) (gen-syntax2033 src2068 e2084 r2070 maps2071 (lambda (x2085) #f) mod2073)) tmp2080) ((lambda (tmp2086) (if (if tmp2086 (apply (lambda (x2087 dots2088 y2089) (ellipsis?2072 dots2088)) tmp2086) #f) (apply (lambda (x2090 dots2091 y2092) (let f2093 ((y2094 y2092) (k2095 (lambda (maps2096) (call-with-values (lambda () (gen-syntax2033 src2068 x2090 r2070 (cons (quote ()) maps2096) ellipsis?2072 mod2073)) (lambda (x2097 maps2098) (if (null? (car maps2098)) (syntax-violation (quote syntax) "extra ellipsis" src2068) (values (gen-map2036 x2097 (car maps2098)) (cdr maps2098)))))))) ((lambda (tmp2099) ((lambda (tmp2100) (if (if tmp2100 (apply (lambda (dots2101 y2102) (ellipsis?2072 dots2101)) tmp2100) #f) (apply (lambda (dots2103 y2104) (f2093 y2104 (lambda (maps2105) (call-with-values (lambda () (k2095 (cons (quote ()) maps2105))) (lambda (x2106 maps2107) (if (null? (car maps2107)) (syntax-violation (quote syntax) "extra ellipsis" src2068) (values (gen-mappend2035 x2106 (car maps2107)) (cdr maps2107)))))))) tmp2100) ((lambda (_2108) (call-with-values (lambda () (gen-syntax2033 src2068 y2094 r2070 maps2071 ellipsis?2072 mod2073)) (lambda (y2109 maps2110) (call-with-values (lambda () (k2095 maps2110)) (lambda (x2111 maps2112) (values (gen-append2038 x2111 y2109) maps2112)))))) tmp2099))) ($sc-dispatch tmp2099 (quote (any . any))))) y2094))) tmp2086) ((lambda (tmp2113) (if tmp2113 (apply (lambda (x2114 y2115) (call-with-values (lambda () (gen-syntax2033 src2068 x2114 r2070 maps2071 ellipsis?2072 mod2073)) (lambda (x2116 maps2117) (call-with-values (lambda () (gen-syntax2033 src2068 y2115 r2070 maps2117 ellipsis?2072 mod2073)) (lambda (y2118 maps2119) (values (gen-cons2037 x2116 y2118) maps2119)))))) tmp2113) ((lambda (tmp2120) (if tmp2120 (apply (lambda (e12121 e22122) (call-with-values (lambda () (gen-syntax2033 src2068 (cons e12121 e22122) r2070 maps2071 ellipsis?2072 mod2073)) (lambda (e2124 maps2125) (values (gen-vector2039 e2124) maps2125)))) tmp2120) ((lambda (_2126) (values (list (quote quote) e2069) maps2071)) tmp2079))) ($sc-dispatch tmp2079 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2079 (quote (any . any)))))) ($sc-dispatch tmp2079 (quote (any any . any)))))) ($sc-dispatch tmp2079 (quote (any any))))) e2069))))) (lambda (e2127 r2128 w2129 s2130 mod2131) (let ((e2132 (source-wrap1241 e2127 w2129 s2130 mod2131))) ((lambda (tmp2133) ((lambda (tmp2134) (if tmp2134 (apply (lambda (_2135 x2136) (call-with-values (lambda () (gen-syntax2033 e2132 x2136 r2128 (quote ()) ellipsis?1257 mod2131)) (lambda (e2137 maps2138) (regen2040 e2137)))) tmp2134) ((lambda (_2139) (syntax-violation (quote syntax) "bad `syntax' form" e2132)) tmp2133))) ($sc-dispatch tmp2133 (quote (any any))))) e2132))))) (global-extend1210 (quote core) (quote lambda) (lambda (e2140 r2141 w2142 s2143 mod2144) ((lambda (tmp2145) ((lambda (tmp2146) (if tmp2146 (apply (lambda (_2147 c2148) (chi-lambda-clause1253 (source-wrap1241 e2140 w2142 s2143 mod2144) #f c2148 r2141 w2142 mod2144 (lambda (vars2149 docstring2150 body2151) (build-annotated1189 s2143 (cons (quote lambda) (cons vars2149 (append (if docstring2150 (list docstring2150) (quote ())) (list body2151)))))))) tmp2146) (syntax-violation #f "source expression failed to match any pattern" tmp2145))) ($sc-dispatch tmp2145 (quote (any . any))))) e2140))) (global-extend1210 (quote core) (quote let) (letrec ((chi-let2152 (lambda (e2153 r2154 w2155 s2156 mod2157 constructor2158 ids2159 vals2160 exps2161) (if (not (valid-bound-ids?1237 ids2159)) (syntax-violation (quote let) "duplicate bound variable" e2153) (let ((labels2162 (gen-labels1218 ids2159)) (new-vars2163 (map gen-var1260 ids2159))) (let ((nw2164 (make-binding-wrap1229 ids2159 labels2162 w2155)) (nr2165 (extend-var-env1207 labels2162 new-vars2163 r2154))) (constructor2158 s2156 new-vars2163 (map (lambda (x2166) (chi1248 x2166 r2154 w2155 mod2157)) vals2160) (chi-body1252 exps2161 (source-wrap1241 e2153 nw2164 s2156 mod2157) nr2165 nw2164 mod2157)))))))) (lambda (e2167 r2168 w2169 s2170 mod2171) ((lambda (tmp2172) ((lambda (tmp2173) (if tmp2173 (apply (lambda (_2174 id2175 val2176 e12177 e22178) (chi-let2152 e2167 r2168 w2169 s2170 mod2171 build-let1192 id2175 val2176 (cons e12177 e22178))) tmp2173) ((lambda (tmp2182) (if (if tmp2182 (apply (lambda (_2183 f2184 id2185 val2186 e12187 e22188) (id?1212 f2184)) tmp2182) #f) (apply (lambda (_2189 f2190 id2191 val2192 e12193 e22194) (chi-let2152 e2167 r2168 w2169 s2170 mod2171 build-named-let1193 (cons f2190 id2191) val2192 (cons e12193 e22194))) tmp2182) ((lambda (_2198) (syntax-violation (quote let) "bad let" (source-wrap1241 e2167 w2169 s2170 mod2171))) tmp2172))) ($sc-dispatch tmp2172 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2172 (quote (any #(each (any any)) any . each-any))))) e2167)))) (global-extend1210 (quote core) (quote letrec) (lambda (e2199 r2200 w2201 s2202 mod2203) ((lambda (tmp2204) ((lambda (tmp2205) (if tmp2205 (apply (lambda (_2206 id2207 val2208 e12209 e22210) (let ((ids2211 id2207)) (if (not (valid-bound-ids?1237 ids2211)) (syntax-violation (quote letrec) "duplicate bound variable" e2199) (let ((labels2213 (gen-labels1218 ids2211)) (new-vars2214 (map gen-var1260 ids2211))) (let ((w2215 (make-binding-wrap1229 ids2211 labels2213 w2201)) (r2216 (extend-var-env1207 labels2213 new-vars2214 r2200))) (build-letrec1194 s2202 new-vars2214 (map (lambda (x2217) (chi1248 x2217 r2216 w2215 mod2203)) val2208) (chi-body1252 (cons e12209 e22210) (source-wrap1241 e2199 w2215 s2202 mod2203) r2216 w2215 mod2203))))))) tmp2205) ((lambda (_2220) (syntax-violation (quote letrec) "bad letrec" (source-wrap1241 e2199 w2201 s2202 mod2203))) tmp2204))) ($sc-dispatch tmp2204 (quote (any #(each (any any)) any . each-any))))) e2199))) (global-extend1210 (quote core) (quote set!) (lambda (e2221 r2222 w2223 s2224 mod2225) ((lambda (tmp2226) ((lambda (tmp2227) (if (if tmp2227 (apply (lambda (_2228 id2229 val2230) (id?1212 id2229)) tmp2227) #f) (apply (lambda (_2231 id2232 val2233) (let ((val2234 (chi1248 val2233 r2222 w2223 mod2225)) (n2235 (id-var-name1234 id2232 w2223))) (let ((b2236 (lookup1209 n2235 r2222 mod2225))) (let ((t2237 (binding-type1204 b2236))) (if (memv t2237 (quote (lexical))) (build-annotated1189 s2224 (list (quote set!) (binding-value1205 b2236) val2234)) (if (memv t2237 (quote (global))) (build-annotated1189 s2224 (list (quote set!) (if mod2225 (make-module-ref (cdr mod2225) n2235 (car mod2225)) (make-module-ref mod2225 n2235 (quote bare))) val2234)) (if (memv t2237 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1240 id2232 w2223 mod2225)) (syntax-violation (quote set!) "bad set!" (source-wrap1241 e2221 w2223 s2224 mod2225))))))))) tmp2227) ((lambda (tmp2238) (if tmp2238 (apply (lambda (_2239 head2240 tail2241 val2242) (call-with-values (lambda () (syntax-type1246 head2240 r2222 (quote (())) #f #f mod2225)) (lambda (type2243 value2244 ee2245 ww2246 ss2247 modmod2248) (let ((t2249 type2243)) (if (memv t2249 (quote (module-ref))) (let ((val2250 (chi1248 val2242 r2222 w2223 mod2225))) (call-with-values (lambda () (value2244 (cons head2240 tail2241))) (lambda (id2252 mod2253) (build-annotated1189 s2224 (list (quote set!) (if mod2253 (make-module-ref (cdr mod2253) id2252 (car mod2253)) (make-module-ref mod2253 id2252 (quote bare))) val2250))))) (build-annotated1189 s2224 (cons (chi1248 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2240) r2222 w2223 mod2225) (map (lambda (e2254) (chi1248 e2254 r2222 w2223 mod2225)) (append tail2241 (list val2242)))))))))) tmp2238) ((lambda (_2256) (syntax-violation (quote set!) "bad set!" (source-wrap1241 e2221 w2223 s2224 mod2225))) tmp2226))) ($sc-dispatch tmp2226 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2226 (quote (any any any))))) e2221))) (global-extend1210 (quote module-ref) (quote @) (lambda (e2257) ((lambda (tmp2258) ((lambda (tmp2259) (if (if tmp2259 (apply (lambda (_2260 mod2261 id2262) (and (andmap id?1212 mod2261) (id?1212 id2262))) tmp2259) #f) (apply (lambda (_2264 mod2265 id2266) (values (syntax->datum id2266) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2265)))) tmp2259) (syntax-violation #f "source expression failed to match any pattern" tmp2258))) ($sc-dispatch tmp2258 (quote (any each-any any))))) e2257))) (global-extend1210 (quote module-ref) (quote @@) (lambda (e2268) ((lambda (tmp2269) ((lambda (tmp2270) (if (if tmp2270 (apply (lambda (_2271 mod2272 id2273) (and (andmap id?1212 mod2272) (id?1212 id2273))) tmp2270) #f) (apply (lambda (_2275 mod2276 id2277) (values (syntax->datum id2277) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2276)))) tmp2270) (syntax-violation #f "source expression failed to match any pattern" tmp2269))) ($sc-dispatch tmp2269 (quote (any each-any any))))) e2268))) (global-extend1210 (quote begin) (quote begin) (quote ())) (global-extend1210 (quote define) (quote define) (quote ())) (global-extend1210 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1210 (quote eval-when) (quote eval-when) (quote ())) (global-extend1210 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2282 (lambda (x2283 keys2284 clauses2285 r2286 mod2287) (if (null? clauses2285) (build-annotated1189 #f (list (build-annotated1189 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2283)) ((lambda (tmp2288) ((lambda (tmp2289) (if tmp2289 (apply (lambda (pat2290 exp2291) (if (and (id?1212 pat2290) (andmap (lambda (x2292) (not (free-id=?1235 pat2290 x2292))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2284))) (let ((labels2293 (list (gen-label1217))) (var2294 (gen-var1260 pat2290))) (build-annotated1189 #f (list (build-annotated1189 #f (list (quote lambda) (list var2294) (chi1248 exp2291 (extend-env1206 labels2293 (list (cons (quote syntax) (cons var2294 0))) r2286) (make-binding-wrap1229 (list pat2290) labels2293 (quote (()))) mod2287))) x2283))) (gen-clause2281 x2283 keys2284 (cdr clauses2285) r2286 pat2290 #t exp2291 mod2287))) tmp2289) ((lambda (tmp2295) (if tmp2295 (apply (lambda (pat2296 fender2297 exp2298) (gen-clause2281 x2283 keys2284 (cdr clauses2285) r2286 pat2296 fender2297 exp2298 mod2287)) tmp2295) ((lambda (_2299) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2285))) tmp2288))) ($sc-dispatch tmp2288 (quote (any any any)))))) ($sc-dispatch tmp2288 (quote (any any))))) (car clauses2285))))) (gen-clause2281 (lambda (x2300 keys2301 clauses2302 r2303 pat2304 fender2305 exp2306 mod2307) (call-with-values (lambda () (convert-pattern2279 pat2304 keys2301)) (lambda (p2308 pvars2309) (cond ((not (distinct-bound-ids?1238 (map car pvars2309))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2304)) ((not (andmap (lambda (x2310) (not (ellipsis?1257 (car x2310)))) pvars2309)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2304)) (else (let ((y2311 (gen-var1260 (quote tmp)))) (build-annotated1189 #f (list (build-annotated1189 #f (list (quote lambda) (list y2311) (let ((y2312 (build-annotated1189 #f y2311))) (build-annotated1189 #f (list (quote if) ((lambda (tmp2313) ((lambda (tmp2314) (if tmp2314 (apply (lambda () y2312) tmp2314) ((lambda (_2315) (build-annotated1189 #f (list (quote if) y2312 (build-dispatch-call2280 pvars2309 fender2305 y2312 r2303 mod2307) (build-data1190 #f #f)))) tmp2313))) ($sc-dispatch tmp2313 (quote #(atom #t))))) fender2305) (build-dispatch-call2280 pvars2309 exp2306 y2312 r2303 mod2307) (gen-syntax-case2282 x2300 keys2301 clauses2302 r2303 mod2307)))))) (if (eq? p2308 (quote any)) (build-annotated1189 #f (list (build-annotated1189 #f (quote list)) x2300)) (build-annotated1189 #f (list (build-annotated1189 #f (quote $sc-dispatch)) x2300 (build-data1190 #f p2308))))))))))))) (build-dispatch-call2280 (lambda (pvars2316 exp2317 y2318 r2319 mod2320) (let ((ids2321 (map car pvars2316)) (levels2322 (map cdr pvars2316))) (let ((labels2323 (gen-labels1218 ids2321)) (new-vars2324 (map gen-var1260 ids2321))) (build-annotated1189 #f (list (build-annotated1189 #f (quote apply)) (build-annotated1189 #f (list (quote lambda) new-vars2324 (chi1248 exp2317 (extend-env1206 labels2323 (map (lambda (var2325 level2326) (cons (quote syntax) (cons var2325 level2326))) new-vars2324 (map cdr pvars2316)) r2319) (make-binding-wrap1229 ids2321 labels2323 (quote (()))) mod2320))) y2318)))))) (convert-pattern2279 (lambda (pattern2327 keys2328) (let cvt2329 ((p2330 pattern2327) (n2331 0) (ids2332 (quote ()))) (if (id?1212 p2330) (if (bound-id-member?1239 p2330 keys2328) (values (vector (quote free-id) p2330) ids2332) (values (quote any) (cons (cons p2330 n2331) ids2332))) ((lambda (tmp2333) ((lambda (tmp2334) (if (if tmp2334 (apply (lambda (x2335 dots2336) (ellipsis?1257 dots2336)) tmp2334) #f) (apply (lambda (x2337 dots2338) (call-with-values (lambda () (cvt2329 x2337 (fx+1180 n2331 1) ids2332)) (lambda (p2339 ids2340) (values (if (eq? p2339 (quote any)) (quote each-any) (vector (quote each) p2339)) ids2340)))) tmp2334) ((lambda (tmp2341) (if tmp2341 (apply (lambda (x2342 y2343) (call-with-values (lambda () (cvt2329 y2343 n2331 ids2332)) (lambda (y2344 ids2345) (call-with-values (lambda () (cvt2329 x2342 n2331 ids2345)) (lambda (x2346 ids2347) (values (cons x2346 y2344) ids2347)))))) tmp2341) ((lambda (tmp2348) (if tmp2348 (apply (lambda () (values (quote ()) ids2332)) tmp2348) ((lambda (tmp2349) (if tmp2349 (apply (lambda (x2350) (call-with-values (lambda () (cvt2329 x2350 n2331 ids2332)) (lambda (p2352 ids2353) (values (vector (quote vector) p2352) ids2353)))) tmp2349) ((lambda (x2354) (values (vector (quote atom) (strip1259 p2330 (quote (())))) ids2332)) tmp2333))) ($sc-dispatch tmp2333 (quote #(vector each-any)))))) ($sc-dispatch tmp2333 (quote ()))))) ($sc-dispatch tmp2333 (quote (any . any)))))) ($sc-dispatch tmp2333 (quote (any any))))) p2330)))))) (lambda (e2355 r2356 w2357 s2358 mod2359) (let ((e2360 (source-wrap1241 e2355 w2357 s2358 mod2359))) ((lambda (tmp2361) ((lambda (tmp2362) (if tmp2362 (apply (lambda (_2363 val2364 key2365 m2366) (if (andmap (lambda (x2367) (and (id?1212 x2367) (not (ellipsis?1257 x2367)))) key2365) (let ((x2369 (gen-var1260 (quote tmp)))) (build-annotated1189 s2358 (list (build-annotated1189 #f (list (quote lambda) (list x2369) (gen-syntax-case2282 (build-annotated1189 #f x2369) key2365 m2366 r2356 mod2359))) (chi1248 val2364 r2356 (quote (())) mod2359)))) (syntax-violation (quote syntax-case) "invalid literals list" e2360))) tmp2362) (syntax-violation #f "source expression failed to match any pattern" tmp2361))) ($sc-dispatch tmp2361 (quote (any any each-any . each-any))))) e2360))))) (set! sc-expand (let ((m2372 (quote e)) (esew2373 (quote (eval)))) (lambda (x2374) (if (and (pair? x2374) (equal? (car x2374) noexpand1179)) (cadr x2374) (chi-top1247 x2374 (quote ()) (quote ((top))) m2372 esew2373 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2375 (quote e)) (esew2376 (quote (eval)))) (lambda (x2378 . rest2377) (if (and (pair? x2378) (equal? (car x2378) noexpand1179)) (cadr x2378) (chi-top1247 x2378 (quote ()) (quote ((top))) (if (null? rest2377) m2375 (car rest2377)) (if (or (null? rest2377) (null? (cdr rest2377))) esew2376 (cadr rest2377)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2379) (nonsymbol-id?1211 x2379))) (set! datum->syntax (lambda (id2380 datum2381) (make-syntax-object1195 datum2381 (syntax-object-wrap1198 id2380) #f))) (set! syntax->datum (lambda (x2382) (strip1259 x2382 (quote (()))))) (set! generate-temporaries (lambda (ls2383) (begin (let ((x2384 ls2383)) (if (not (list? x2384)) (error-hook1186 (quote generate-temporaries) "invalid argument" x2384))) (map (lambda (x2385) (wrap1240 (gensym) (quote ((top))) #f)) ls2383)))) (set! free-identifier=? (lambda (x2386 y2387) (begin (let ((x2388 x2386)) (if (not (nonsymbol-id?1211 x2388)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2388))) (let ((x2389 y2387)) (if (not (nonsymbol-id?1211 x2389)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2389))) (free-id=?1235 x2386 y2387)))) (set! bound-identifier=? (lambda (x2390 y2391) (begin (let ((x2392 x2390)) (if (not (nonsymbol-id?1211 x2392)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2392))) (let ((x2393 y2391)) (if (not (nonsymbol-id?1211 x2393)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2393))) (bound-id=?1236 x2390 y2391)))) (set! syntax-violation (lambda (who2397 message2396 form2395 . subform2394) (begin (let ((x2398 who2397)) (if (not ((lambda (x2399) (or (not x2399) (string? x2399) (symbol? x2399))) x2398)) (error-hook1186 (quote syntax-violation) "invalid argument" x2398))) (let ((x2400 message2396)) (if (not (string? x2400)) (error-hook1186 (quote syntax-violation) "invalid argument" x2400))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2397 "~a: " "") "~a " (if (null? subform2394) "in ~a" "in subform `~s' of `~s'")) (let ((tail2401 (cons message2396 (map (lambda (x2402) (strip1259 x2402 (quote (())))) (append subform2394 (list form2395)))))) (if who2397 (cons who2397 tail2401) tail2401)) #f)))) (letrec ((match2407 (lambda (e2408 p2409 w2410 r2411 mod2412) (cond ((not r2411) #f) ((eq? p2409 (quote any)) (cons (wrap1240 e2408 w2410 mod2412) r2411)) ((syntax-object?1196 e2408) (match*2406 (let ((e2413 (syntax-object-expression1197 e2408))) (if (annotation? e2413) (annotation-expression e2413) e2413)) p2409 (join-wraps1231 w2410 (syntax-object-wrap1198 e2408)) r2411 (syntax-object-module1199 e2408))) (else (match*2406 (let ((e2414 e2408)) (if (annotation? e2414) (annotation-expression e2414) e2414)) p2409 w2410 r2411 mod2412))))) (match*2406 (lambda (e2415 p2416 w2417 r2418 mod2419) (cond ((null? p2416) (and (null? e2415) r2418)) ((pair? p2416) (and (pair? e2415) (match2407 (car e2415) (car p2416) w2417 (match2407 (cdr e2415) (cdr p2416) w2417 r2418 mod2419) mod2419))) ((eq? p2416 (quote each-any)) (let ((l2420 (match-each-any2404 e2415 w2417 mod2419))) (and l2420 (cons l2420 r2418)))) (else (let ((t2421 (vector-ref p2416 0))) (if (memv t2421 (quote (each))) (if (null? e2415) (match-empty2405 (vector-ref p2416 1) r2418) (let ((l2422 (match-each2403 e2415 (vector-ref p2416 1) w2417 mod2419))) (and l2422 (let collect2423 ((l2424 l2422)) (if (null? (car l2424)) r2418 (cons (map car l2424) (collect2423 (map cdr l2424)))))))) (if (memv t2421 (quote (free-id))) (and (id?1212 e2415) (free-id=?1235 (wrap1240 e2415 w2417 mod2419) (vector-ref p2416 1)) r2418) (if (memv t2421 (quote (atom))) (and (equal? (vector-ref p2416 1) (strip1259 e2415 w2417)) r2418) (if (memv t2421 (quote (vector))) (and (vector? e2415) (match2407 (vector->list e2415) (vector-ref p2416 1) w2417 r2418 mod2419))))))))))) (match-empty2405 (lambda (p2425 r2426) (cond ((null? p2425) r2426) ((eq? p2425 (quote any)) (cons (quote ()) r2426)) ((pair? p2425) (match-empty2405 (car p2425) (match-empty2405 (cdr p2425) r2426))) ((eq? p2425 (quote each-any)) (cons (quote ()) r2426)) (else (let ((t2427 (vector-ref p2425 0))) (if (memv t2427 (quote (each))) (match-empty2405 (vector-ref p2425 1) r2426) (if (memv t2427 (quote (free-id atom))) r2426 (if (memv t2427 (quote (vector))) (match-empty2405 (vector-ref p2425 1) r2426))))))))) (match-each-any2404 (lambda (e2428 w2429 mod2430) (cond ((annotation? e2428) (match-each-any2404 (annotation-expression e2428) w2429 mod2430)) ((pair? e2428) (let ((l2431 (match-each-any2404 (cdr e2428) w2429 mod2430))) (and l2431 (cons (wrap1240 (car e2428) w2429 mod2430) l2431)))) ((null? e2428) (quote ())) ((syntax-object?1196 e2428) (match-each-any2404 (syntax-object-expression1197 e2428) (join-wraps1231 w2429 (syntax-object-wrap1198 e2428)) mod2430)) (else #f)))) (match-each2403 (lambda (e2432 p2433 w2434 mod2435) (cond ((annotation? e2432) (match-each2403 (annotation-expression e2432) p2433 w2434 mod2435)) ((pair? e2432) (let ((first2436 (match2407 (car e2432) p2433 w2434 (quote ()) mod2435))) (and first2436 (let ((rest2437 (match-each2403 (cdr e2432) p2433 w2434 mod2435))) (and rest2437 (cons first2436 rest2437)))))) ((null? e2432) (quote ())) ((syntax-object?1196 e2432) (match-each2403 (syntax-object-expression1197 e2432) p2433 (join-wraps1231 w2434 (syntax-object-wrap1198 e2432)) (syntax-object-module1199 e2432))) (else #f))))) (set! $sc-dispatch (lambda (e2438 p2439) (cond ((eq? p2439 (quote any)) (list e2438)) ((syntax-object?1196 e2438) (match*2406 (let ((e2440 (syntax-object-expression1197 e2438))) (if (annotation? e2440) (annotation-expression e2440) e2440)) p2439 (syntax-object-wrap1198 e2438) (quote ()) (syntax-object-module1199 e2438))) (else (match*2406 (let ((e2441 e2438)) (if (annotation? e2441) (annotation-expression e2441) e2441)) p2439 (quote (())) (quote ()) #f)))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2442) ((lambda (tmp2443) ((lambda (tmp2444) (if tmp2444 (apply (lambda (_2445 e12446 e22447) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12446 e22447))) tmp2444) ((lambda (tmp2449) (if tmp2449 (apply (lambda (_2450 out2451 in2452 e12453 e22454) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2452 (quote ()) (list out2451 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12453 e22454))))) tmp2449) ((lambda (tmp2456) (if tmp2456 (apply (lambda (_2457 out2458 in2459 e12460 e22461) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2459) (quote ()) (list out2458 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12460 e22461))))) tmp2456) (syntax-violation #f "source expression failed to match any pattern" tmp2443))) ($sc-dispatch tmp2443 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2443 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2443 (quote (any () any . each-any))))) x2442)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2465) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 k2469 keyword2470 pattern2471 template2472) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2469 (map (lambda (tmp2475 tmp2474) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2474) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2475))) template2472 pattern2471)))))) tmp2467) (syntax-violation #f "source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any each-any . #(each ((any . any) any))))))) x2465)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2476) ((lambda (tmp2477) ((lambda (tmp2478) (if (if tmp2478 (apply (lambda (let*2479 x2480 v2481 e12482 e22483) (andmap identifier? x2480)) tmp2478) #f) (apply (lambda (let*2485 x2486 v2487 e12488 e22489) (let f2490 ((bindings2491 (map list x2486 v2487))) (if (null? bindings2491) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12488 e22489))) ((lambda (tmp2495) ((lambda (tmp2496) (if tmp2496 (apply (lambda (body2497 binding2498) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2498) body2497)) tmp2496) (syntax-violation #f "source expression failed to match any pattern" tmp2495))) ($sc-dispatch tmp2495 (quote (any any))))) (list (f2490 (cdr bindings2491)) (car bindings2491)))))) tmp2478) (syntax-violation #f "source expression failed to match any pattern" tmp2477))) ($sc-dispatch tmp2477 (quote (any #(each (any any)) any . each-any))))) x2476)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2499) ((lambda (tmp2500) ((lambda (tmp2501) (if tmp2501 (apply (lambda (_2502 var2503 init2504 step2505 e02506 e12507 c2508) ((lambda (tmp2509) ((lambda (tmp2510) (if tmp2510 (apply (lambda (step2511) ((lambda (tmp2512) ((lambda (tmp2513) (if tmp2513 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2503 init2504) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02506) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2508 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2511))))))) tmp2513) ((lambda (tmp2518) (if tmp2518 (apply (lambda (e12519 e22520) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2503 init2504) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02506 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12519 e22520)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2508 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2511))))))) tmp2518) (syntax-violation #f "source expression failed to match any pattern" tmp2512))) ($sc-dispatch tmp2512 (quote (any . each-any)))))) ($sc-dispatch tmp2512 (quote ())))) e12507)) tmp2510) (syntax-violation #f "source expression failed to match any pattern" tmp2509))) ($sc-dispatch tmp2509 (quote each-any)))) (map (lambda (v2527 s2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda () v2527) tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda (e2532) e2532) tmp2531) ((lambda (_2533) (syntax-violation (quote do) "bad step expression" orig-x2499 s2528)) tmp2529))) ($sc-dispatch tmp2529 (quote (any)))))) ($sc-dispatch tmp2529 (quote ())))) s2528)) var2503 step2505))) tmp2501) (syntax-violation #f "source expression failed to match any pattern" tmp2500))) ($sc-dispatch tmp2500 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2499)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2536 (lambda (x2540 y2541) ((lambda (tmp2542) ((lambda (tmp2543) (if tmp2543 (apply (lambda (x2544 y2545) ((lambda (tmp2546) ((lambda (tmp2547) (if tmp2547 (apply (lambda (dy2548) ((lambda (tmp2549) ((lambda (tmp2550) (if tmp2550 (apply (lambda (dx2551) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2551 dy2548))) tmp2550) ((lambda (_2552) (if (null? dy2548) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2544) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2544 y2545))) tmp2549))) ($sc-dispatch tmp2549 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2544)) tmp2547) ((lambda (tmp2553) (if tmp2553 (apply (lambda (stuff2554) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2544 stuff2554))) tmp2553) ((lambda (else2555) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2544 y2545)) tmp2546))) ($sc-dispatch tmp2546 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2546 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2545)) tmp2543) (syntax-violation #f "source expression failed to match any pattern" tmp2542))) ($sc-dispatch tmp2542 (quote (any any))))) (list x2540 y2541)))) (quasiappend2537 (lambda (x2556 y2557) ((lambda (tmp2558) ((lambda (tmp2559) (if tmp2559 (apply (lambda (x2560 y2561) ((lambda (tmp2562) ((lambda (tmp2563) (if tmp2563 (apply (lambda () x2560) tmp2563) ((lambda (_2564) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2560 y2561)) tmp2562))) ($sc-dispatch tmp2562 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2561)) tmp2559) (syntax-violation #f "source expression failed to match any pattern" tmp2558))) ($sc-dispatch tmp2558 (quote (any any))))) (list x2556 y2557)))) (quasivector2538 (lambda (x2565) ((lambda (tmp2566) ((lambda (x2567) ((lambda (tmp2568) ((lambda (tmp2569) (if tmp2569 (apply (lambda (x2570) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2570))) tmp2569) ((lambda (tmp2572) (if tmp2572 (apply (lambda (x2573) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2573)) tmp2572) ((lambda (_2575) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2567)) tmp2568))) ($sc-dispatch tmp2568 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2568 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2567)) tmp2566)) x2565))) (quasi2539 (lambda (p2576 lev2577) ((lambda (tmp2578) ((lambda (tmp2579) (if tmp2579 (apply (lambda (p2580) (if (= lev2577 0) p2580 (quasicons2536 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2539 (list p2580) (- lev2577 1))))) tmp2579) ((lambda (tmp2581) (if tmp2581 (apply (lambda (p2582 q2583) (if (= lev2577 0) (quasiappend2537 p2582 (quasi2539 q2583 lev2577)) (quasicons2536 (quasicons2536 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2539 (list p2582) (- lev2577 1))) (quasi2539 q2583 lev2577)))) tmp2581) ((lambda (tmp2584) (if tmp2584 (apply (lambda (p2585) (quasicons2536 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2539 (list p2585) (+ lev2577 1)))) tmp2584) ((lambda (tmp2586) (if tmp2586 (apply (lambda (p2587 q2588) (quasicons2536 (quasi2539 p2587 lev2577) (quasi2539 q2588 lev2577))) tmp2586) ((lambda (tmp2589) (if tmp2589 (apply (lambda (x2590) (quasivector2538 (quasi2539 x2590 lev2577))) tmp2589) ((lambda (p2592) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2592)) tmp2578))) ($sc-dispatch tmp2578 (quote #(vector each-any)))))) ($sc-dispatch tmp2578 (quote (any . any)))))) ($sc-dispatch tmp2578 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2578 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2578 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2576)))) (lambda (x2593) ((lambda (tmp2594) ((lambda (tmp2595) (if tmp2595 (apply (lambda (_2596 e2597) (quasi2539 e2597 0)) tmp2595) (syntax-violation #f "source expression failed to match any pattern" tmp2594))) ($sc-dispatch tmp2594 (quote (any any))))) x2593))))) +(define include (make-syncase-macro (quote macro) (lambda (x2598) (letrec ((read-file2599 (lambda (fn2600 k2601) (let ((p2602 (open-input-file fn2600))) (let f2603 ((x2604 (read p2602))) (if (eof-object? x2604) (begin (close-input-port p2602) (quote ())) (cons (datum->syntax k2601 x2604) (f2603 (read p2602))))))))) ((lambda (tmp2605) ((lambda (tmp2606) (if tmp2606 (apply (lambda (k2607 filename2608) (let ((fn2609 (syntax->datum filename2608))) ((lambda (tmp2610) ((lambda (tmp2611) (if tmp2611 (apply (lambda (exp2612) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2612)) tmp2611) (syntax-violation #f "source expression failed to match any pattern" tmp2610))) ($sc-dispatch tmp2610 (quote each-any)))) (read-file2599 fn2609 k2607)))) tmp2606) (syntax-violation #f "source expression failed to match any pattern" tmp2605))) ($sc-dispatch tmp2605 (quote (any any))))) x2598))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2614) ((lambda (tmp2615) ((lambda (tmp2616) (if tmp2616 (apply (lambda (_2617 e2618) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2618))) tmp2616) (syntax-violation #f "source expression failed to match any pattern" tmp2615))) ($sc-dispatch tmp2615 (quote (any any))))) x2614)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2619) ((lambda (tmp2620) ((lambda (tmp2621) (if tmp2621 (apply (lambda (_2622 e2623) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2623))) tmp2621) (syntax-violation #f "source expression failed to match any pattern" tmp2620))) ($sc-dispatch tmp2620 (quote (any any))))) x2619)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2624) ((lambda (tmp2625) ((lambda (tmp2626) (if tmp2626 (apply (lambda (_2627 e2628 m12629 m22630) ((lambda (tmp2631) ((lambda (body2632) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2628)) body2632)) tmp2631)) (let f2633 ((clause2634 m12629) (clauses2635 m22630)) (if (null? clauses2635) ((lambda (tmp2637) ((lambda (tmp2638) (if tmp2638 (apply (lambda (e12639 e22640) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12639 e22640))) tmp2638) ((lambda (tmp2642) (if tmp2642 (apply (lambda (k2643 e12644 e22645) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2643)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12644 e22645)))) tmp2642) ((lambda (_2648) (syntax-violation (quote case) "bad clause" x2624 clause2634)) tmp2637))) ($sc-dispatch tmp2637 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2637 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2634) ((lambda (tmp2649) ((lambda (rest2650) ((lambda (tmp2651) ((lambda (tmp2652) (if tmp2652 (apply (lambda (k2653 e12654 e22655) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2653)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12654 e22655)) rest2650)) tmp2652) ((lambda (_2658) (syntax-violation (quote case) "bad clause" x2624 clause2634)) tmp2651))) ($sc-dispatch tmp2651 (quote (each-any any . each-any))))) clause2634)) tmp2649)) (f2633 (car clauses2635) (cdr clauses2635))))))) tmp2626) (syntax-violation #f "source expression failed to match any pattern" tmp2625))) ($sc-dispatch tmp2625 (quote (any any any . each-any))))) x2624)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2659) ((lambda (tmp2660) ((lambda (tmp2661) (if tmp2661 (apply (lambda (_2662 e2663) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2663)) (list (cons _2662 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2663 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2661) (syntax-violation #f "source expression failed to match any pattern" tmp2660))) ($sc-dispatch tmp2660 (quote (any any))))) x2659)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 2cf83f771..9033a6034 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -81,8 +81,6 @@ ;;; Revision 3, for a complete description) ;;; (syntax-violation who message form [subform]) ;;; used to report errors found during expansion -;;; (install-global-transformer symbol value) -;;; used by expanded code to install top-level syntactic abstractions ;;; ($sc-dispatch e p) ;;; used by expanded code to handle syntax-case matching @@ -2071,12 +2069,6 @@ (if who (cons who tail) tail)) #f))) -(set! install-global-transformer - (lambda (sym v) - (arg-check symbol? sym 'define-syntax) - (arg-check procedure? v 'define-syntax) - (global-extend 'macro sym v))) - ;;; $sc-dispatch expects an expression and a pattern. If the expression ;;; matches the pattern a list of the matching expressions for each ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will From 4d24854111110b44a28a4d46242bac1285de387a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 23:12:12 +0200 Subject: [PATCH 088/375] remove andmap from public API (we still have and-map) * module/ice-9/boot-9.scm (and-map, or-map): Move these definitions up so psyntax can use them. (andmap): Remove, yay. * module/ice-9/psyntax.scm: Remove notes about andmap, and just use Guile's and-map -- except in cases that need the multiple list support, in which case we have a private and-map*. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/boot-9.scm | 89 +++++++++++++++---------------------- module/ice-9/psyntax-pp.scm | 22 ++++----- module/ice-9/psyntax.scm | 66 +++++++++++++-------------- 3 files changed, 79 insertions(+), 98 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index c3531e156..d375e84d0 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -95,6 +95,42 @@ (define (provided? feature) (and (memq feature *features*) #t)) + + +;;; {and-map and or-map} +;;; +;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) +;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) +;;; + +;; and-map f l +;; +;; Apply f to successive elements of l until exhaustion or f returns #f. +;; If returning early, return #f. Otherwise, return the last value returned +;; by f. If f has never been called because l is empty, return #t. +;; +(define (and-map f lst) + (let loop ((result #t) + (l lst)) + (and result + (or (and (null? l) + result) + (loop (f (car l)) (cdr l)))))) + +;; or-map f l +;; +;; Apply f to successive elements of l until exhaustion or while f returns #f. +;; If returning early, return the return value of f. +;; +(define (or-map f lst) + (let loop ((result #f) + (l lst)) + (or result + (and (not (null? l)) + (loop (f (car l)) (cdr l)))))) + + + ;; let format alias simple-format until the more complete version is loaded (define format simple-format) @@ -182,25 +218,6 @@ ;;; Useless crap I'd like to get rid of (define (annotation? x) #f) - -(define andmap - (lambda (f first . rest) - (or (null? first) - (if (null? rest) - (let andmap ((first first)) - (let ((x (car first)) (first (cdr first))) - (if (null? first) - (f x) - (and (f x) (andmap first))))) - (let andmap ((first first) (rest rest)) - (let ((x (car first)) - (xr (map car rest)) - (first (cdr first)) - (rest (map cdr rest))) - (if (null? first) - (apply f (cons x xr)) - (and (apply f (cons x xr)) (andmap first rest))))))))) - (primitive-load-path "ice-9/psyntax-pp") ;; Until the module system is booted, this will be the current expander. @@ -504,40 +521,6 @@ -;;; {and-map and or-map} -;;; -;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; - -;; and-map f l -;; -;; Apply f to successive elements of l until exhaustion or f returns #f. -;; If returning early, return #f. Otherwise, return the last value returned -;; by f. If f has never been called because l is empty, return #t. -;; -(define (and-map f lst) - (let loop ((result #t) - (l lst)) - (and result - (or (and (null? l) - result) - (loop (f (car l)) (cdr l)))))) - -;; or-map f l -;; -;; Apply f to successive elements of l until exhaustion or while f returns #f. -;; If returning early, return the return value of f. -;; -(define (or-map f lst) - (let loop ((result #f) - (l lst)) - (or result - (and (not (null? l)) - (loop (f (car l)) (cdr l)))))) - - - (if (provided? 'posix) (primitive-load-path "ice-9/posix")) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 03191991c..8783a53d5 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1261 (lambda (vars1466) (let lvl1467 ((vars1468 vars1466) (ls1469 (quote ())) (w1470 (quote (())))) (cond ((pair? vars1468) (lvl1467 (cdr vars1468) (cons (wrap1240 (car vars1468) w1470 #f) ls1469) w1470)) ((id?1212 vars1468) (cons (wrap1240 vars1468 w1470 #f) ls1469)) ((null? vars1468) ls1469) ((syntax-object?1196 vars1468) (lvl1467 (syntax-object-expression1197 vars1468) ls1469 (join-wraps1231 w1470 (syntax-object-wrap1198 vars1468)))) ((annotation? vars1468) (lvl1467 (annotation-expression vars1468) ls1469 w1470)) (else (cons vars1468 ls1469)))))) (gen-var1260 (lambda (id1471) (let ((id1472 (if (syntax-object?1196 id1471) (syntax-object-expression1197 id1471) id1471))) (if (annotation? id1472) (build-annotated1189 (annotation-source id1472) (gensym (symbol->string (annotation-expression id1472)))) (build-annotated1189 #f (gensym (symbol->string id1472))))))) (strip1259 (lambda (x1473 w1474) (if (memq (quote top) (wrap-marks1215 w1474)) (if (or (annotation? x1473) (and (pair? x1473) (annotation? (car x1473)))) (strip-annotation1258 x1473 #f) x1473) (let f1475 ((x1476 x1473)) (cond ((syntax-object?1196 x1476) (strip1259 (syntax-object-expression1197 x1476) (syntax-object-wrap1198 x1476))) ((pair? x1476) (let ((a1477 (f1475 (car x1476))) (d1478 (f1475 (cdr x1476)))) (if (and (eq? a1477 (car x1476)) (eq? d1478 (cdr x1476))) x1476 (cons a1477 d1478)))) ((vector? x1476) (let ((old1479 (vector->list x1476))) (let ((new1480 (map f1475 old1479))) (if (andmap eq? old1479 new1480) x1476 (list->vector new1480))))) (else x1476)))))) (strip-annotation1258 (lambda (x1481 parent1482) (cond ((pair? x1481) (let ((new1483 (cons #f #f))) (begin (if parent1482 (set-annotation-stripped! parent1482 new1483)) (set-car! new1483 (strip-annotation1258 (car x1481) #f)) (set-cdr! new1483 (strip-annotation1258 (cdr x1481) #f)) new1483))) ((annotation? x1481) (or (annotation-stripped x1481) (strip-annotation1258 (annotation-expression x1481) x1481))) ((vector? x1481) (let ((new1484 (make-vector (vector-length x1481)))) (begin (if parent1482 (set-annotation-stripped! parent1482 new1484)) (let loop1485 ((i1486 (- (vector-length x1481) 1))) (unless (fx<1183 i1486 0) (vector-set! new1484 i1486 (strip-annotation1258 (vector-ref x1481 i1486) #f)) (loop1485 (fx-1181 i1486 1)))) new1484))) (else x1481)))) (ellipsis?1257 (lambda (x1487) (and (nonsymbol-id?1211 x1487) (free-id=?1235 x1487 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1256 (lambda () (build-annotated1189 #f (list (build-annotated1189 #f (quote void)))))) (eval-local-transformer1255 (lambda (expanded1488 mod1489) (let ((p1490 (local-eval-hook1185 expanded1488 mod1489))) (if (procedure? p1490) p1490 (syntax-violation #f "nonprocedure transformer" p1490))))) (chi-local-syntax1254 (lambda (rec?1491 e1492 r1493 w1494 s1495 mod1496 k1497) ((lambda (tmp1498) ((lambda (tmp1499) (if tmp1499 (apply (lambda (_1500 id1501 val1502 e11503 e21504) (let ((ids1505 id1501)) (if (not (valid-bound-ids?1237 ids1505)) (syntax-violation #f "duplicate bound keyword" e1492) (let ((labels1507 (gen-labels1218 ids1505))) (let ((new-w1508 (make-binding-wrap1229 ids1505 labels1507 w1494))) (k1497 (cons e11503 e21504) (extend-env1206 labels1507 (let ((w1510 (if rec?1491 new-w1508 w1494)) (trans-r1511 (macros-only-env1208 r1493))) (map (lambda (x1512) (cons (quote macro) (eval-local-transformer1255 (chi1248 x1512 trans-r1511 w1510 mod1496) mod1496))) val1502)) r1493) new-w1508 s1495 mod1496)))))) tmp1499) ((lambda (_1514) (syntax-violation #f "bad local syntax definition" (source-wrap1241 e1492 w1494 s1495 mod1496))) tmp1498))) ($sc-dispatch tmp1498 (quote (any #(each (any any)) any . each-any))))) e1492))) (chi-lambda-clause1253 (lambda (e1515 docstring1516 c1517 r1518 w1519 mod1520 k1521) ((lambda (tmp1522) ((lambda (tmp1523) (if (if tmp1523 (apply (lambda (args1524 doc1525 e11526 e21527) (and (string? (syntax->datum doc1525)) (not docstring1516))) tmp1523) #f) (apply (lambda (args1528 doc1529 e11530 e21531) (chi-lambda-clause1253 e1515 doc1529 (cons args1528 (cons e11530 e21531)) r1518 w1519 mod1520 k1521)) tmp1523) ((lambda (tmp1533) (if tmp1533 (apply (lambda (id1534 e11535 e21536) (let ((ids1537 id1534)) (if (not (valid-bound-ids?1237 ids1537)) (syntax-violation (quote lambda) "invalid parameter list" e1515) (let ((labels1539 (gen-labels1218 ids1537)) (new-vars1540 (map gen-var1260 ids1537))) (k1521 new-vars1540 docstring1516 (chi-body1252 (cons e11535 e21536) e1515 (extend-var-env1207 labels1539 new-vars1540 r1518) (make-binding-wrap1229 ids1537 labels1539 w1519) mod1520)))))) tmp1533) ((lambda (tmp1542) (if tmp1542 (apply (lambda (ids1543 e11544 e21545) (let ((old-ids1546 (lambda-var-list1261 ids1543))) (if (not (valid-bound-ids?1237 old-ids1546)) (syntax-violation (quote lambda) "invalid parameter list" e1515) (let ((labels1547 (gen-labels1218 old-ids1546)) (new-vars1548 (map gen-var1260 old-ids1546))) (k1521 (let f1549 ((ls11550 (cdr new-vars1548)) (ls21551 (car new-vars1548))) (if (null? ls11550) ls21551 (f1549 (cdr ls11550) (cons (car ls11550) ls21551)))) docstring1516 (chi-body1252 (cons e11544 e21545) e1515 (extend-var-env1207 labels1547 new-vars1548 r1518) (make-binding-wrap1229 old-ids1546 labels1547 w1519) mod1520)))))) tmp1542) ((lambda (_1553) (syntax-violation (quote lambda) "bad lambda" e1515)) tmp1522))) ($sc-dispatch tmp1522 (quote (any any . each-any)))))) ($sc-dispatch tmp1522 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1522 (quote (any any any . each-any))))) c1517))) (chi-body1252 (lambda (body1554 outer-form1555 r1556 w1557 mod1558) (let ((r1559 (cons (quote ("placeholder" placeholder)) r1556))) (let ((ribcage1560 (make-ribcage1219 (quote ()) (quote ()) (quote ())))) (let ((w1561 (make-wrap1214 (wrap-marks1215 w1557) (cons ribcage1560 (wrap-subst1216 w1557))))) (let parse1562 ((body1563 (map (lambda (x1569) (cons r1559 (wrap1240 x1569 w1561 mod1558))) body1554)) (ids1564 (quote ())) (labels1565 (quote ())) (vars1566 (quote ())) (vals1567 (quote ())) (bindings1568 (quote ()))) (if (null? body1563) (syntax-violation #f "no expressions in body" outer-form1555) (let ((e1570 (cdar body1563)) (er1571 (caar body1563))) (call-with-values (lambda () (syntax-type1246 e1570 er1571 (quote (())) #f ribcage1560 mod1558)) (lambda (type1572 value1573 e1574 w1575 s1576 mod1577) (let ((t1578 type1572)) (if (memv t1578 (quote (define-form))) (let ((id1579 (wrap1240 value1573 w1575 mod1577)) (label1580 (gen-label1217))) (let ((var1581 (gen-var1260 id1579))) (begin (extend-ribcage!1228 ribcage1560 id1579 label1580) (parse1562 (cdr body1563) (cons id1579 ids1564) (cons label1580 labels1565) (cons var1581 vars1566) (cons (cons er1571 (wrap1240 e1574 w1575 mod1577)) vals1567) (cons (cons (quote lexical) var1581) bindings1568))))) (if (memv t1578 (quote (define-syntax-form))) (let ((id1582 (wrap1240 value1573 w1575 mod1577)) (label1583 (gen-label1217))) (begin (extend-ribcage!1228 ribcage1560 id1582 label1583) (parse1562 (cdr body1563) (cons id1582 ids1564) (cons label1583 labels1565) vars1566 vals1567 (cons (cons (quote macro) (cons er1571 (wrap1240 e1574 w1575 mod1577))) bindings1568)))) (if (memv t1578 (quote (begin-form))) ((lambda (tmp1584) ((lambda (tmp1585) (if tmp1585 (apply (lambda (_1586 e11587) (parse1562 (let f1588 ((forms1589 e11587)) (if (null? forms1589) (cdr body1563) (cons (cons er1571 (wrap1240 (car forms1589) w1575 mod1577)) (f1588 (cdr forms1589))))) ids1564 labels1565 vars1566 vals1567 bindings1568)) tmp1585) (syntax-violation #f "source expression failed to match any pattern" tmp1584))) ($sc-dispatch tmp1584 (quote (any . each-any))))) e1574) (if (memv t1578 (quote (local-syntax-form))) (chi-local-syntax1254 value1573 e1574 er1571 w1575 s1576 mod1577 (lambda (forms1591 er1592 w1593 s1594 mod1595) (parse1562 (let f1596 ((forms1597 forms1591)) (if (null? forms1597) (cdr body1563) (cons (cons er1592 (wrap1240 (car forms1597) w1593 mod1595)) (f1596 (cdr forms1597))))) ids1564 labels1565 vars1566 vals1567 bindings1568))) (if (null? ids1564) (build-sequence1191 #f (map (lambda (x1598) (chi1248 (cdr x1598) (car x1598) (quote (())) mod1577)) (cons (cons er1571 (source-wrap1241 e1574 w1575 s1576 mod1577)) (cdr body1563)))) (begin (if (not (valid-bound-ids?1237 ids1564)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1555)) (let loop1599 ((bs1600 bindings1568) (er-cache1601 #f) (r-cache1602 #f)) (if (not (null? bs1600)) (let ((b1603 (car bs1600))) (if (eq? (car b1603) (quote macro)) (let ((er1604 (cadr b1603))) (let ((r-cache1605 (if (eq? er1604 er-cache1601) r-cache1602 (macros-only-env1208 er1604)))) (begin (set-cdr! b1603 (eval-local-transformer1255 (chi1248 (cddr b1603) r-cache1605 (quote (())) mod1577) mod1577)) (loop1599 (cdr bs1600) er1604 r-cache1605)))) (loop1599 (cdr bs1600) er-cache1601 r-cache1602))))) (set-cdr! r1559 (extend-env1206 labels1565 bindings1568 (cdr r1559))) (build-letrec1194 #f vars1566 (map (lambda (x1606) (chi1248 (cdr x1606) (car x1606) (quote (())) mod1577)) vals1567) (build-sequence1191 #f (map (lambda (x1607) (chi1248 (cdr x1607) (car x1607) (quote (())) mod1577)) (cons (cons er1571 (source-wrap1241 e1574 w1575 s1576 mod1577)) (cdr body1563)))))))))))))))))))))) (chi-macro1251 (lambda (p1608 e1609 r1610 w1611 rib1612 mod1613) (letrec ((rebuild-macro-output1614 (lambda (x1615 m1616) (cond ((pair? x1615) (cons (rebuild-macro-output1614 (car x1615) m1616) (rebuild-macro-output1614 (cdr x1615) m1616))) ((syntax-object?1196 x1615) (let ((w1617 (syntax-object-wrap1198 x1615))) (let ((ms1618 (wrap-marks1215 w1617)) (s1619 (wrap-subst1216 w1617))) (if (and (pair? ms1618) (eq? (car ms1618) #f)) (make-syntax-object1195 (syntax-object-expression1197 x1615) (make-wrap1214 (cdr ms1618) (if rib1612 (cons rib1612 (cdr s1619)) (cdr s1619))) (syntax-object-module1199 x1615)) (make-syntax-object1195 (syntax-object-expression1197 x1615) (make-wrap1214 (cons m1616 ms1618) (if rib1612 (cons rib1612 (cons (quote shift) s1619)) (cons (quote shift) s1619))) (let ((pmod1620 (procedure-module p1608))) (if pmod1620 (cons (quote hygiene) (module-name pmod1620)) (quote (hygiene guile))))))))) ((vector? x1615) (let ((n1621 (vector-length x1615))) (let ((v1622 (make-vector n1621))) (let doloop1623 ((i1624 0)) (if (fx=1182 i1624 n1621) v1622 (begin (vector-set! v1622 i1624 (rebuild-macro-output1614 (vector-ref x1615 i1624) m1616)) (doloop1623 (fx+1180 i1624 1)))))))) ((symbol? x1615) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1241 e1609 w1611 s mod1613) x1615)) (else x1615))))) (rebuild-macro-output1614 (p1608 (wrap1240 e1609 (anti-mark1227 w1611) mod1613)) (string #\m))))) (chi-application1250 (lambda (x1625 e1626 r1627 w1628 s1629 mod1630) ((lambda (tmp1631) ((lambda (tmp1632) (if tmp1632 (apply (lambda (e01633 e11634) (build-annotated1189 s1629 (cons x1625 (map (lambda (e1635) (chi1248 e1635 r1627 w1628 mod1630)) e11634)))) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1631))) ($sc-dispatch tmp1631 (quote (any . each-any))))) e1626))) (chi-expr1249 (lambda (type1637 value1638 e1639 r1640 w1641 s1642 mod1643) (let ((t1644 type1637)) (if (memv t1644 (quote (lexical))) (build-annotated1189 s1642 value1638) (if (memv t1644 (quote (core external-macro))) (value1638 e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (module-ref))) (call-with-values (lambda () (value1638 e1639)) (lambda (id1645 mod1646) (build-annotated1189 s1642 (if mod1646 (make-module-ref (cdr mod1646) id1645 (car mod1646)) (make-module-ref mod1646 id1645 (quote bare)))))) (if (memv t1644 (quote (lexical-call))) (chi-application1250 (build-annotated1189 (source-annotation1203 (car e1639)) value1638) e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (global-call))) (chi-application1250 (build-annotated1189 (source-annotation1203 (car e1639)) (if (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643) (make-module-ref (cdr (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643)) value1638 (car (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643))) (make-module-ref (if (syntax-object?1196 (car e1639)) (syntax-object-module1199 (car e1639)) mod1643) value1638 (quote bare)))) e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (constant))) (build-data1190 s1642 (strip1259 (source-wrap1241 e1639 w1641 s1642 mod1643) (quote (())))) (if (memv t1644 (quote (global))) (build-annotated1189 s1642 (if mod1643 (make-module-ref (cdr mod1643) value1638 (car mod1643)) (make-module-ref mod1643 value1638 (quote bare)))) (if (memv t1644 (quote (call))) (chi-application1250 (chi1248 (car e1639) r1640 w1641 mod1643) e1639 r1640 w1641 s1642 mod1643) (if (memv t1644 (quote (begin-form))) ((lambda (tmp1647) ((lambda (tmp1648) (if tmp1648 (apply (lambda (_1649 e11650 e21651) (chi-sequence1242 (cons e11650 e21651) r1640 w1641 s1642 mod1643)) tmp1648) (syntax-violation #f "source expression failed to match any pattern" tmp1647))) ($sc-dispatch tmp1647 (quote (any any . each-any))))) e1639) (if (memv t1644 (quote (local-syntax-form))) (chi-local-syntax1254 value1638 e1639 r1640 w1641 s1642 mod1643 chi-sequence1242) (if (memv t1644 (quote (eval-when-form))) ((lambda (tmp1653) ((lambda (tmp1654) (if tmp1654 (apply (lambda (_1655 x1656 e11657 e21658) (let ((when-list1659 (chi-when-list1245 e1639 x1656 w1641))) (if (memq (quote eval) when-list1659) (chi-sequence1242 (cons e11657 e21658) r1640 w1641 s1642 mod1643) (chi-void1256)))) tmp1654) (syntax-violation #f "source expression failed to match any pattern" tmp1653))) ($sc-dispatch tmp1653 (quote (any each-any any . each-any))))) e1639) (if (memv t1644 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1639 (wrap1240 value1638 w1641 mod1643)) (if (memv t1644 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1241 e1639 w1641 s1642 mod1643)) (if (memv t1644 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1241 e1639 w1641 s1642 mod1643)) (syntax-violation #f "unexpected syntax" (source-wrap1241 e1639 w1641 s1642 mod1643))))))))))))))))))) (chi1248 (lambda (e1662 r1663 w1664 mod1665) (call-with-values (lambda () (syntax-type1246 e1662 r1663 w1664 #f #f mod1665)) (lambda (type1666 value1667 e1668 w1669 s1670 mod1671) (chi-expr1249 type1666 value1667 e1668 r1663 w1669 s1670 mod1671))))) (chi-top1247 (lambda (e1672 r1673 w1674 m1675 esew1676 mod1677) (call-with-values (lambda () (syntax-type1246 e1672 r1673 w1674 #f #f mod1677)) (lambda (type1685 value1686 e1687 w1688 s1689 mod1690) (let ((t1691 type1685)) (if (memv t1691 (quote (begin-form))) ((lambda (tmp1692) ((lambda (tmp1693) (if tmp1693 (apply (lambda (_1694) (chi-void1256)) tmp1693) ((lambda (tmp1695) (if tmp1695 (apply (lambda (_1696 e11697 e21698) (chi-top-sequence1243 (cons e11697 e21698) r1673 w1688 s1689 m1675 esew1676 mod1690)) tmp1695) (syntax-violation #f "source expression failed to match any pattern" tmp1692))) ($sc-dispatch tmp1692 (quote (any any . each-any)))))) ($sc-dispatch tmp1692 (quote (any))))) e1687) (if (memv t1691 (quote (local-syntax-form))) (chi-local-syntax1254 value1686 e1687 r1673 w1688 s1689 mod1690 (lambda (body1700 r1701 w1702 s1703 mod1704) (chi-top-sequence1243 body1700 r1701 w1702 s1703 m1675 esew1676 mod1704))) (if (memv t1691 (quote (eval-when-form))) ((lambda (tmp1705) ((lambda (tmp1706) (if tmp1706 (apply (lambda (_1707 x1708 e11709 e21710) (let ((when-list1711 (chi-when-list1245 e1687 x1708 w1688)) (body1712 (cons e11709 e21710))) (cond ((eq? m1675 (quote e)) (if (memq (quote eval) when-list1711) (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote e) (quote (eval)) mod1690) (chi-void1256))) ((memq (quote load) when-list1711) (if (or (memq (quote compile) when-list1711) (and (eq? m1675 (quote c&e)) (memq (quote eval) when-list1711))) (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote c&e) (quote (compile load)) mod1690) (if (memq m1675 (quote (c c&e))) (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote c) (quote (load)) mod1690) (chi-void1256)))) ((or (memq (quote compile) when-list1711) (and (eq? m1675 (quote c&e)) (memq (quote eval) when-list1711))) (top-level-eval-hook1184 (chi-top-sequence1243 body1712 r1673 w1688 s1689 (quote e) (quote (eval)) mod1690) mod1690) (chi-void1256)) (else (chi-void1256))))) tmp1706) (syntax-violation #f "source expression failed to match any pattern" tmp1705))) ($sc-dispatch tmp1705 (quote (any each-any any . each-any))))) e1687) (if (memv t1691 (quote (define-syntax-form))) (let ((n1715 (id-var-name1234 value1686 w1688)) (r1716 (macros-only-env1208 r1673))) (let ((t1717 m1675)) (if (memv t1717 (quote (c))) (if (memq (quote compile) esew1676) (let ((e1718 (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)))) (begin (top-level-eval-hook1184 e1718 mod1690) (if (memq (quote load) esew1676) e1718 (chi-void1256)))) (if (memq (quote load) esew1676) (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)) (chi-void1256))) (if (memv t1717 (quote (c&e))) (let ((e1719 (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)))) (begin (top-level-eval-hook1184 e1719 mod1690) e1719)) (begin (if (memq (quote eval) esew1676) (top-level-eval-hook1184 (chi-install-global1244 n1715 (chi1248 e1687 r1716 w1688 mod1690)) mod1690)) (chi-void1256)))))) (if (memv t1691 (quote (define-form))) (let ((n1720 (id-var-name1234 value1686 w1688))) (let ((type1721 (binding-type1204 (lookup1209 n1720 r1673 mod1690)))) (let ((t1722 type1721)) (if (memv t1722 (quote (global core macro module-ref))) (let ((x1723 (build-annotated1189 s1689 (list (quote define) n1720 (chi1248 e1687 r1673 w1688 mod1690))))) (begin (if (eq? m1675 (quote c&e)) (top-level-eval-hook1184 x1723 mod1690)) x1723)) (if (memv t1722 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1687 (wrap1240 value1686 w1688 mod1690)) (syntax-violation #f "cannot define keyword at top level" e1687 (wrap1240 value1686 w1688 mod1690))))))) (let ((x1724 (chi-expr1249 type1685 value1686 e1687 r1673 w1688 s1689 mod1690))) (begin (if (eq? m1675 (quote c&e)) (top-level-eval-hook1184 x1724 mod1690)) x1724)))))))))))) (syntax-type1246 (lambda (e1725 r1726 w1727 s1728 rib1729 mod1730) (cond ((symbol? e1725) (let ((n1731 (id-var-name1234 e1725 w1727))) (let ((b1732 (lookup1209 n1731 r1726 mod1730))) (let ((type1733 (binding-type1204 b1732))) (let ((t1734 type1733)) (if (memv t1734 (quote (lexical))) (values type1733 (binding-value1205 b1732) e1725 w1727 s1728 mod1730) (if (memv t1734 (quote (global))) (values type1733 n1731 e1725 w1727 s1728 mod1730) (if (memv t1734 (quote (macro))) (syntax-type1246 (chi-macro1251 (binding-value1205 b1732) e1725 r1726 w1727 rib1729 mod1730) r1726 (quote (())) s1728 rib1729 mod1730) (values type1733 (binding-value1205 b1732) e1725 w1727 s1728 mod1730))))))))) ((pair? e1725) (let ((first1735 (car e1725))) (if (id?1212 first1735) (let ((n1736 (id-var-name1234 first1735 w1727))) (let ((b1737 (lookup1209 n1736 r1726 (or (and (syntax-object?1196 first1735) (syntax-object-module1199 first1735)) mod1730)))) (let ((type1738 (binding-type1204 b1737))) (let ((t1739 type1738)) (if (memv t1739 (quote (lexical))) (values (quote lexical-call) (binding-value1205 b1737) e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (global))) (values (quote global-call) n1736 e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (macro))) (syntax-type1246 (chi-macro1251 (binding-value1205 b1737) e1725 r1726 w1727 rib1729 mod1730) r1726 (quote (())) s1728 rib1729 mod1730) (if (memv t1739 (quote (core external-macro module-ref))) (values type1738 (binding-value1205 b1737) e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1205 b1737) e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (begin))) (values (quote begin-form) #f e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (eval-when))) (values (quote eval-when-form) #f e1725 w1727 s1728 mod1730) (if (memv t1739 (quote (define))) ((lambda (tmp1740) ((lambda (tmp1741) (if (if tmp1741 (apply (lambda (_1742 name1743 val1744) (id?1212 name1743)) tmp1741) #f) (apply (lambda (_1745 name1746 val1747) (values (quote define-form) name1746 val1747 w1727 s1728 mod1730)) tmp1741) ((lambda (tmp1748) (if (if tmp1748 (apply (lambda (_1749 name1750 args1751 e11752 e21753) (and (id?1212 name1750) (valid-bound-ids?1237 (lambda-var-list1261 args1751)))) tmp1748) #f) (apply (lambda (_1754 name1755 args1756 e11757 e21758) (values (quote define-form) (wrap1240 name1755 w1727 mod1730) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1240 (cons args1756 (cons e11757 e21758)) w1727 mod1730)) (quote (())) s1728 mod1730)) tmp1748) ((lambda (tmp1760) (if (if tmp1760 (apply (lambda (_1761 name1762) (id?1212 name1762)) tmp1760) #f) (apply (lambda (_1763 name1764) (values (quote define-form) (wrap1240 name1764 w1727 mod1730) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1728 mod1730)) tmp1760) (syntax-violation #f "source expression failed to match any pattern" tmp1740))) ($sc-dispatch tmp1740 (quote (any any)))))) ($sc-dispatch tmp1740 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1740 (quote (any any any))))) e1725) (if (memv t1739 (quote (define-syntax))) ((lambda (tmp1765) ((lambda (tmp1766) (if (if tmp1766 (apply (lambda (_1767 name1768 val1769) (id?1212 name1768)) tmp1766) #f) (apply (lambda (_1770 name1771 val1772) (values (quote define-syntax-form) name1771 val1772 w1727 s1728 mod1730)) tmp1766) (syntax-violation #f "source expression failed to match any pattern" tmp1765))) ($sc-dispatch tmp1765 (quote (any any any))))) e1725) (values (quote call) #f e1725 w1727 s1728 mod1730)))))))))))))) (values (quote call) #f e1725 w1727 s1728 mod1730)))) ((syntax-object?1196 e1725) (syntax-type1246 (syntax-object-expression1197 e1725) r1726 (join-wraps1231 w1727 (syntax-object-wrap1198 e1725)) #f rib1729 (or (syntax-object-module1199 e1725) mod1730))) ((annotation? e1725) (syntax-type1246 (annotation-expression e1725) r1726 w1727 (annotation-source e1725) rib1729 mod1730)) ((self-evaluating? e1725) (values (quote constant) #f e1725 w1727 s1728 mod1730)) (else (values (quote other) #f e1725 w1727 s1728 mod1730))))) (chi-when-list1245 (lambda (e1773 when-list1774 w1775) (let f1776 ((when-list1777 when-list1774) (situations1778 (quote ()))) (if (null? when-list1777) situations1778 (f1776 (cdr when-list1777) (cons (let ((x1779 (car when-list1777))) (cond ((free-id=?1235 x1779 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1235 x1779 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1235 x1779 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1773 (wrap1240 x1779 w1775 #f))))) situations1778)))))) (chi-install-global1244 (lambda (name1780 e1781) (build-annotated1189 #f (list (build-annotated1189 #f (quote define)) name1780 (if (let ((v1782 (module-variable (current-module) name1780))) (and v1782 (variable-bound? v1782) (macro? (variable-ref v1782)) (not (eq? (macro-type (variable-ref v1782)) (quote syncase-macro))))) (build-annotated1189 #f (list (build-annotated1189 #f (quote make-extended-syncase-macro)) (build-annotated1189 #f (list (build-annotated1189 #f (quote module-ref)) (build-annotated1189 #f (quote (current-module))) (build-data1190 #f name1780))) (build-data1190 #f (quote macro)) e1781)) (build-annotated1189 #f (list (build-annotated1189 #f (quote make-syncase-macro)) (build-data1190 #f (quote macro)) e1781))))))) (chi-top-sequence1243 (lambda (body1783 r1784 w1785 s1786 m1787 esew1788 mod1789) (build-sequence1191 s1786 (let dobody1790 ((body1791 body1783) (r1792 r1784) (w1793 w1785) (m1794 m1787) (esew1795 esew1788) (mod1796 mod1789)) (if (null? body1791) (quote ()) (let ((first1797 (chi-top1247 (car body1791) r1792 w1793 m1794 esew1795 mod1796))) (cons first1797 (dobody1790 (cdr body1791) r1792 w1793 m1794 esew1795 mod1796)))))))) (chi-sequence1242 (lambda (body1798 r1799 w1800 s1801 mod1802) (build-sequence1191 s1801 (let dobody1803 ((body1804 body1798) (r1805 r1799) (w1806 w1800) (mod1807 mod1802)) (if (null? body1804) (quote ()) (let ((first1808 (chi1248 (car body1804) r1805 w1806 mod1807))) (cons first1808 (dobody1803 (cdr body1804) r1805 w1806 mod1807)))))))) (source-wrap1241 (lambda (x1809 w1810 s1811 defmod1812) (wrap1240 (if s1811 (make-annotation x1809 s1811 #f) x1809) w1810 defmod1812))) (wrap1240 (lambda (x1813 w1814 defmod1815) (cond ((and (null? (wrap-marks1215 w1814)) (null? (wrap-subst1216 w1814))) x1813) ((syntax-object?1196 x1813) (make-syntax-object1195 (syntax-object-expression1197 x1813) (join-wraps1231 w1814 (syntax-object-wrap1198 x1813)) (syntax-object-module1199 x1813))) ((null? x1813) x1813) (else (make-syntax-object1195 x1813 w1814 defmod1815))))) (bound-id-member?1239 (lambda (x1816 list1817) (and (not (null? list1817)) (or (bound-id=?1236 x1816 (car list1817)) (bound-id-member?1239 x1816 (cdr list1817)))))) (distinct-bound-ids?1238 (lambda (ids1818) (let distinct?1819 ((ids1820 ids1818)) (or (null? ids1820) (and (not (bound-id-member?1239 (car ids1820) (cdr ids1820))) (distinct?1819 (cdr ids1820))))))) (valid-bound-ids?1237 (lambda (ids1821) (and (let all-ids?1822 ((ids1823 ids1821)) (or (null? ids1823) (and (id?1212 (car ids1823)) (all-ids?1822 (cdr ids1823))))) (distinct-bound-ids?1238 ids1821)))) (bound-id=?1236 (lambda (i1824 j1825) (if (and (syntax-object?1196 i1824) (syntax-object?1196 j1825)) (and (eq? (let ((e1826 (syntax-object-expression1197 i1824))) (if (annotation? e1826) (annotation-expression e1826) e1826)) (let ((e1827 (syntax-object-expression1197 j1825))) (if (annotation? e1827) (annotation-expression e1827) e1827))) (same-marks?1233 (wrap-marks1215 (syntax-object-wrap1198 i1824)) (wrap-marks1215 (syntax-object-wrap1198 j1825)))) (eq? (let ((e1828 i1824)) (if (annotation? e1828) (annotation-expression e1828) e1828)) (let ((e1829 j1825)) (if (annotation? e1829) (annotation-expression e1829) e1829)))))) (free-id=?1235 (lambda (i1830 j1831) (and (eq? (let ((x1832 i1830)) (let ((e1833 (if (syntax-object?1196 x1832) (syntax-object-expression1197 x1832) x1832))) (if (annotation? e1833) (annotation-expression e1833) e1833))) (let ((x1834 j1831)) (let ((e1835 (if (syntax-object?1196 x1834) (syntax-object-expression1197 x1834) x1834))) (if (annotation? e1835) (annotation-expression e1835) e1835)))) (eq? (id-var-name1234 i1830 (quote (()))) (id-var-name1234 j1831 (quote (()))))))) (id-var-name1234 (lambda (id1836 w1837) (letrec ((search-vector-rib1840 (lambda (sym1846 subst1847 marks1848 symnames1849 ribcage1850) (let ((n1851 (vector-length symnames1849))) (let f1852 ((i1853 0)) (cond ((fx=1182 i1853 n1851) (search1838 sym1846 (cdr subst1847) marks1848)) ((and (eq? (vector-ref symnames1849 i1853) sym1846) (same-marks?1233 marks1848 (vector-ref (ribcage-marks1222 ribcage1850) i1853))) (values (vector-ref (ribcage-labels1223 ribcage1850) i1853) marks1848)) (else (f1852 (fx+1180 i1853 1)))))))) (search-list-rib1839 (lambda (sym1854 subst1855 marks1856 symnames1857 ribcage1858) (let f1859 ((symnames1860 symnames1857) (i1861 0)) (cond ((null? symnames1860) (search1838 sym1854 (cdr subst1855) marks1856)) ((and (eq? (car symnames1860) sym1854) (same-marks?1233 marks1856 (list-ref (ribcage-marks1222 ribcage1858) i1861))) (values (list-ref (ribcage-labels1223 ribcage1858) i1861) marks1856)) (else (f1859 (cdr symnames1860) (fx+1180 i1861 1))))))) (search1838 (lambda (sym1862 subst1863 marks1864) (if (null? subst1863) (values #f marks1864) (let ((fst1865 (car subst1863))) (if (eq? fst1865 (quote shift)) (search1838 sym1862 (cdr subst1863) (cdr marks1864)) (let ((symnames1866 (ribcage-symnames1221 fst1865))) (if (vector? symnames1866) (search-vector-rib1840 sym1862 subst1863 marks1864 symnames1866 fst1865) (search-list-rib1839 sym1862 subst1863 marks1864 symnames1866 fst1865))))))))) (cond ((symbol? id1836) (or (call-with-values (lambda () (search1838 id1836 (wrap-subst1216 w1837) (wrap-marks1215 w1837))) (lambda (x1868 . ignore1867) x1868)) id1836)) ((syntax-object?1196 id1836) (let ((id1869 (let ((e1871 (syntax-object-expression1197 id1836))) (if (annotation? e1871) (annotation-expression e1871) e1871))) (w11870 (syntax-object-wrap1198 id1836))) (let ((marks1872 (join-marks1232 (wrap-marks1215 w1837) (wrap-marks1215 w11870)))) (call-with-values (lambda () (search1838 id1869 (wrap-subst1216 w1837) marks1872)) (lambda (new-id1873 marks1874) (or new-id1873 (call-with-values (lambda () (search1838 id1869 (wrap-subst1216 w11870) marks1874)) (lambda (x1876 . ignore1875) x1876)) id1869)))))) ((annotation? id1836) (let ((id1877 (let ((e1878 id1836)) (if (annotation? e1878) (annotation-expression e1878) e1878)))) (or (call-with-values (lambda () (search1838 id1877 (wrap-subst1216 w1837) (wrap-marks1215 w1837))) (lambda (x1880 . ignore1879) x1880)) id1877))) (else (error-hook1186 (quote id-var-name) "invalid id" id1836)))))) (same-marks?1233 (lambda (x1881 y1882) (or (eq? x1881 y1882) (and (not (null? x1881)) (not (null? y1882)) (eq? (car x1881) (car y1882)) (same-marks?1233 (cdr x1881) (cdr y1882)))))) (join-marks1232 (lambda (m11883 m21884) (smart-append1230 m11883 m21884))) (join-wraps1231 (lambda (w11885 w21886) (let ((m11887 (wrap-marks1215 w11885)) (s11888 (wrap-subst1216 w11885))) (if (null? m11887) (if (null? s11888) w21886 (make-wrap1214 (wrap-marks1215 w21886) (smart-append1230 s11888 (wrap-subst1216 w21886)))) (make-wrap1214 (smart-append1230 m11887 (wrap-marks1215 w21886)) (smart-append1230 s11888 (wrap-subst1216 w21886))))))) (smart-append1230 (lambda (m11889 m21890) (if (null? m21890) m11889 (append m11889 m21890)))) (make-binding-wrap1229 (lambda (ids1891 labels1892 w1893) (if (null? ids1891) w1893 (make-wrap1214 (wrap-marks1215 w1893) (cons (let ((labelvec1894 (list->vector labels1892))) (let ((n1895 (vector-length labelvec1894))) (let ((symnamevec1896 (make-vector n1895)) (marksvec1897 (make-vector n1895))) (begin (let f1898 ((ids1899 ids1891) (i1900 0)) (if (not (null? ids1899)) (call-with-values (lambda () (id-sym-name&marks1213 (car ids1899) w1893)) (lambda (symname1901 marks1902) (begin (vector-set! symnamevec1896 i1900 symname1901) (vector-set! marksvec1897 i1900 marks1902) (f1898 (cdr ids1899) (fx+1180 i1900 1))))))) (make-ribcage1219 symnamevec1896 marksvec1897 labelvec1894))))) (wrap-subst1216 w1893)))))) (extend-ribcage!1228 (lambda (ribcage1903 id1904 label1905) (begin (set-ribcage-symnames!1224 ribcage1903 (cons (let ((e1906 (syntax-object-expression1197 id1904))) (if (annotation? e1906) (annotation-expression e1906) e1906)) (ribcage-symnames1221 ribcage1903))) (set-ribcage-marks!1225 ribcage1903 (cons (wrap-marks1215 (syntax-object-wrap1198 id1904)) (ribcage-marks1222 ribcage1903))) (set-ribcage-labels!1226 ribcage1903 (cons label1905 (ribcage-labels1223 ribcage1903)))))) (anti-mark1227 (lambda (w1907) (make-wrap1214 (cons #f (wrap-marks1215 w1907)) (cons (quote shift) (wrap-subst1216 w1907))))) (set-ribcage-labels!1226 (lambda (x1908 update1909) (vector-set! x1908 3 update1909))) (set-ribcage-marks!1225 (lambda (x1910 update1911) (vector-set! x1910 2 update1911))) (set-ribcage-symnames!1224 (lambda (x1912 update1913) (vector-set! x1912 1 update1913))) (ribcage-labels1223 (lambda (x1914) (vector-ref x1914 3))) (ribcage-marks1222 (lambda (x1915) (vector-ref x1915 2))) (ribcage-symnames1221 (lambda (x1916) (vector-ref x1916 1))) (ribcage?1220 (lambda (x1917) (and (vector? x1917) (= (vector-length x1917) 4) (eq? (vector-ref x1917 0) (quote ribcage))))) (make-ribcage1219 (lambda (symnames1918 marks1919 labels1920) (vector (quote ribcage) symnames1918 marks1919 labels1920))) (gen-labels1218 (lambda (ls1921) (if (null? ls1921) (quote ()) (cons (gen-label1217) (gen-labels1218 (cdr ls1921)))))) (gen-label1217 (lambda () (string #\i))) (wrap-subst1216 cdr) (wrap-marks1215 car) (make-wrap1214 cons) (id-sym-name&marks1213 (lambda (x1922 w1923) (if (syntax-object?1196 x1922) (values (let ((e1924 (syntax-object-expression1197 x1922))) (if (annotation? e1924) (annotation-expression e1924) e1924)) (join-marks1232 (wrap-marks1215 w1923) (wrap-marks1215 (syntax-object-wrap1198 x1922)))) (values (let ((e1925 x1922)) (if (annotation? e1925) (annotation-expression e1925) e1925)) (wrap-marks1215 w1923))))) (id?1212 (lambda (x1926) (cond ((symbol? x1926) #t) ((syntax-object?1196 x1926) (symbol? (let ((e1927 (syntax-object-expression1197 x1926))) (if (annotation? e1927) (annotation-expression e1927) e1927)))) ((annotation? x1926) (symbol? (annotation-expression x1926))) (else #f)))) (nonsymbol-id?1211 (lambda (x1928) (and (syntax-object?1196 x1928) (symbol? (let ((e1929 (syntax-object-expression1197 x1928))) (if (annotation? e1929) (annotation-expression e1929) e1929)))))) (global-extend1210 (lambda (type1930 sym1931 val1932) (put-global-definition-hook1187 sym1931 type1930 val1932))) (lookup1209 (lambda (x1933 r1934 mod1935) (cond ((assq x1933 r1934) => cdr) ((symbol? x1933) (or (get-global-definition-hook1188 x1933 mod1935) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1208 (lambda (r1936) (if (null? r1936) (quote ()) (let ((a1937 (car r1936))) (if (eq? (cadr a1937) (quote macro)) (cons a1937 (macros-only-env1208 (cdr r1936))) (macros-only-env1208 (cdr r1936))))))) (extend-var-env1207 (lambda (labels1938 vars1939 r1940) (if (null? labels1938) r1940 (extend-var-env1207 (cdr labels1938) (cdr vars1939) (cons (cons (car labels1938) (cons (quote lexical) (car vars1939))) r1940))))) (extend-env1206 (lambda (labels1941 bindings1942 r1943) (if (null? labels1941) r1943 (extend-env1206 (cdr labels1941) (cdr bindings1942) (cons (cons (car labels1941) (car bindings1942)) r1943))))) (binding-value1205 cdr) (binding-type1204 car) (source-annotation1203 (lambda (x1944) (cond ((annotation? x1944) (annotation-source x1944)) ((syntax-object?1196 x1944) (source-annotation1203 (syntax-object-expression1197 x1944))) (else #f)))) (set-syntax-object-module!1202 (lambda (x1945 update1946) (vector-set! x1945 3 update1946))) (set-syntax-object-wrap!1201 (lambda (x1947 update1948) (vector-set! x1947 2 update1948))) (set-syntax-object-expression!1200 (lambda (x1949 update1950) (vector-set! x1949 1 update1950))) (syntax-object-module1199 (lambda (x1951) (vector-ref x1951 3))) (syntax-object-wrap1198 (lambda (x1952) (vector-ref x1952 2))) (syntax-object-expression1197 (lambda (x1953) (vector-ref x1953 1))) (syntax-object?1196 (lambda (x1954) (and (vector? x1954) (= (vector-length x1954) 4) (eq? (vector-ref x1954 0) (quote syntax-object))))) (make-syntax-object1195 (lambda (expression1955 wrap1956 module1957) (vector (quote syntax-object) expression1955 wrap1956 module1957))) (build-letrec1194 (lambda (src1958 vars1959 val-exps1960 body-exp1961) (if (null? vars1959) (build-annotated1189 src1958 body-exp1961) (build-annotated1189 src1958 (list (quote letrec) (map list vars1959 val-exps1960) body-exp1961))))) (build-named-let1193 (lambda (src1962 vars1963 val-exps1964 body-exp1965) (if (null? vars1963) (build-annotated1189 src1962 body-exp1965) (build-annotated1189 src1962 (list (quote let) (car vars1963) (map list (cdr vars1963) val-exps1964) body-exp1965))))) (build-let1192 (lambda (src1966 vars1967 val-exps1968 body-exp1969) (if (null? vars1967) (build-annotated1189 src1966 body-exp1969) (build-annotated1189 src1966 (list (quote let) (map list vars1967 val-exps1968) body-exp1969))))) (build-sequence1191 (lambda (src1970 exps1971) (if (null? (cdr exps1971)) (build-annotated1189 src1970 (car exps1971)) (build-annotated1189 src1970 (cons (quote begin) exps1971))))) (build-data1190 (lambda (src1972 exp1973) (if (and (self-evaluating? exp1973) (not (vector? exp1973))) (build-annotated1189 src1972 exp1973) (build-annotated1189 src1972 (list (quote quote) exp1973))))) (build-annotated1189 (lambda (src1974 exp1975) (if (and src1974 (not (annotation? exp1975))) (make-annotation exp1975 src1974 #t) exp1975))) (get-global-definition-hook1188 (lambda (symbol1976 module1977) (begin (if (and (not module1977) (current-module)) (warn "module system is booted, we should have a module" symbol1976)) (let ((v1978 (module-variable (if module1977 (resolve-module (cdr module1977)) (current-module)) symbol1976))) (and v1978 (variable-bound? v1978) (let ((val1979 (variable-ref v1978))) (and (macro? val1979) (syncase-macro-type val1979) (cons (syncase-macro-type val1979) (syncase-macro-binding val1979))))))))) (put-global-definition-hook1187 (lambda (symbol1980 type1981 val1982) (let ((existing1983 (let ((v1984 (module-variable (current-module) symbol1980))) (and v1984 (variable-bound? v1984) (let ((val1985 (variable-ref v1984))) (and (macro? val1985) (not (syncase-macro-type val1985)) val1985)))))) (module-define! (current-module) symbol1980 (if existing1983 (make-extended-syncase-macro existing1983 type1981 val1982) (make-syncase-macro type1981 val1982)))))) (error-hook1186 (lambda (who1986 why1987 what1988) (error who1986 "~a ~s" why1987 what1988))) (local-eval-hook1185 (lambda (x1989 mod1990) (primitive-eval (list noexpand1179 x1989)))) (top-level-eval-hook1184 (lambda (x1991 mod1992) (primitive-eval (list noexpand1179 x1991)))) (fx<1183 <) (fx=1182 =) (fx-1181 -) (fx+1180 +) (noexpand1179 "noexpand")) (begin (global-extend1210 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1210 (quote local-syntax) (quote let-syntax) #f) (global-extend1210 (quote core) (quote fluid-let-syntax) (lambda (e1993 r1994 w1995 s1996 mod1997) ((lambda (tmp1998) ((lambda (tmp1999) (if (if tmp1999 (apply (lambda (_2000 var2001 val2002 e12003 e22004) (valid-bound-ids?1237 var2001)) tmp1999) #f) (apply (lambda (_2006 var2007 val2008 e12009 e22010) (let ((names2011 (map (lambda (x2012) (id-var-name1234 x2012 w1995)) var2007))) (begin (for-each (lambda (id2014 n2015) (let ((t2016 (binding-type1204 (lookup1209 n2015 r1994 mod1997)))) (if (memv t2016 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1993 (source-wrap1241 id2014 w1995 s1996 mod1997))))) var2007 names2011) (chi-body1252 (cons e12009 e22010) (source-wrap1241 e1993 w1995 s1996 mod1997) (extend-env1206 names2011 (let ((trans-r2019 (macros-only-env1208 r1994))) (map (lambda (x2020) (cons (quote macro) (eval-local-transformer1255 (chi1248 x2020 trans-r2019 w1995 mod1997) mod1997))) val2008)) r1994) w1995 mod1997)))) tmp1999) ((lambda (_2022) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1241 e1993 w1995 s1996 mod1997))) tmp1998))) ($sc-dispatch tmp1998 (quote (any #(each (any any)) any . each-any))))) e1993))) (global-extend1210 (quote core) (quote quote) (lambda (e2023 r2024 w2025 s2026 mod2027) ((lambda (tmp2028) ((lambda (tmp2029) (if tmp2029 (apply (lambda (_2030 e2031) (build-data1190 s2026 (strip1259 e2031 w2025))) tmp2029) ((lambda (_2032) (syntax-violation (quote quote) "bad syntax" (source-wrap1241 e2023 w2025 s2026 mod2027))) tmp2028))) ($sc-dispatch tmp2028 (quote (any any))))) e2023))) (global-extend1210 (quote core) (quote syntax) (letrec ((regen2040 (lambda (x2041) (let ((t2042 (car x2041))) (if (memv t2042 (quote (ref))) (build-annotated1189 #f (cadr x2041)) (if (memv t2042 (quote (primitive))) (build-annotated1189 #f (cadr x2041)) (if (memv t2042 (quote (quote))) (build-data1190 #f (cadr x2041)) (if (memv t2042 (quote (lambda))) (build-annotated1189 #f (list (quote lambda) (cadr x2041) (regen2040 (caddr x2041)))) (if (memv t2042 (quote (map))) (let ((ls2043 (map regen2040 (cdr x2041)))) (build-annotated1189 #f (cons (if (fx=1182 (length ls2043) 2) (build-annotated1189 #f (quote map)) (build-annotated1189 #f (quote map))) ls2043))) (build-annotated1189 #f (cons (build-annotated1189 #f (car x2041)) (map regen2040 (cdr x2041)))))))))))) (gen-vector2039 (lambda (x2044) (cond ((eq? (car x2044) (quote list)) (cons (quote vector) (cdr x2044))) ((eq? (car x2044) (quote quote)) (list (quote quote) (list->vector (cadr x2044)))) (else (list (quote list->vector) x2044))))) (gen-append2038 (lambda (x2045 y2046) (if (equal? y2046 (quote (quote ()))) x2045 (list (quote append) x2045 y2046)))) (gen-cons2037 (lambda (x2047 y2048) (let ((t2049 (car y2048))) (if (memv t2049 (quote (quote))) (if (eq? (car x2047) (quote quote)) (list (quote quote) (cons (cadr x2047) (cadr y2048))) (if (eq? (cadr y2048) (quote ())) (list (quote list) x2047) (list (quote cons) x2047 y2048))) (if (memv t2049 (quote (list))) (cons (quote list) (cons x2047 (cdr y2048))) (list (quote cons) x2047 y2048)))))) (gen-map2036 (lambda (e2050 map-env2051) (let ((formals2052 (map cdr map-env2051)) (actuals2053 (map (lambda (x2054) (list (quote ref) (car x2054))) map-env2051))) (cond ((eq? (car e2050) (quote ref)) (car actuals2053)) ((andmap (lambda (x2055) (and (eq? (car x2055) (quote ref)) (memq (cadr x2055) formals2052))) (cdr e2050)) (cons (quote map) (cons (list (quote primitive) (car e2050)) (map (let ((r2056 (map cons formals2052 actuals2053))) (lambda (x2057) (cdr (assq (cadr x2057) r2056)))) (cdr e2050))))) (else (cons (quote map) (cons (list (quote lambda) formals2052 e2050) actuals2053))))))) (gen-mappend2035 (lambda (e2058 map-env2059) (list (quote apply) (quote (primitive append)) (gen-map2036 e2058 map-env2059)))) (gen-ref2034 (lambda (src2060 var2061 level2062 maps2063) (if (fx=1182 level2062 0) (values var2061 maps2063) (if (null? maps2063) (syntax-violation (quote syntax) "missing ellipsis" src2060) (call-with-values (lambda () (gen-ref2034 src2060 var2061 (fx-1181 level2062 1) (cdr maps2063))) (lambda (outer-var2064 outer-maps2065) (let ((b2066 (assq outer-var2064 (car maps2063)))) (if b2066 (values (cdr b2066) maps2063) (let ((inner-var2067 (gen-var1260 (quote tmp)))) (values inner-var2067 (cons (cons (cons outer-var2064 inner-var2067) (car maps2063)) outer-maps2065))))))))))) (gen-syntax2033 (lambda (src2068 e2069 r2070 maps2071 ellipsis?2072 mod2073) (if (id?1212 e2069) (let ((label2074 (id-var-name1234 e2069 (quote (()))))) (let ((b2075 (lookup1209 label2074 r2070 mod2073))) (if (eq? (binding-type1204 b2075) (quote syntax)) (call-with-values (lambda () (let ((var.lev2076 (binding-value1205 b2075))) (gen-ref2034 src2068 (car var.lev2076) (cdr var.lev2076) maps2071))) (lambda (var2077 maps2078) (values (list (quote ref) var2077) maps2078))) (if (ellipsis?2072 e2069) (syntax-violation (quote syntax) "misplaced ellipsis" src2068) (values (list (quote quote) e2069) maps2071))))) ((lambda (tmp2079) ((lambda (tmp2080) (if (if tmp2080 (apply (lambda (dots2081 e2082) (ellipsis?2072 dots2081)) tmp2080) #f) (apply (lambda (dots2083 e2084) (gen-syntax2033 src2068 e2084 r2070 maps2071 (lambda (x2085) #f) mod2073)) tmp2080) ((lambda (tmp2086) (if (if tmp2086 (apply (lambda (x2087 dots2088 y2089) (ellipsis?2072 dots2088)) tmp2086) #f) (apply (lambda (x2090 dots2091 y2092) (let f2093 ((y2094 y2092) (k2095 (lambda (maps2096) (call-with-values (lambda () (gen-syntax2033 src2068 x2090 r2070 (cons (quote ()) maps2096) ellipsis?2072 mod2073)) (lambda (x2097 maps2098) (if (null? (car maps2098)) (syntax-violation (quote syntax) "extra ellipsis" src2068) (values (gen-map2036 x2097 (car maps2098)) (cdr maps2098)))))))) ((lambda (tmp2099) ((lambda (tmp2100) (if (if tmp2100 (apply (lambda (dots2101 y2102) (ellipsis?2072 dots2101)) tmp2100) #f) (apply (lambda (dots2103 y2104) (f2093 y2104 (lambda (maps2105) (call-with-values (lambda () (k2095 (cons (quote ()) maps2105))) (lambda (x2106 maps2107) (if (null? (car maps2107)) (syntax-violation (quote syntax) "extra ellipsis" src2068) (values (gen-mappend2035 x2106 (car maps2107)) (cdr maps2107)))))))) tmp2100) ((lambda (_2108) (call-with-values (lambda () (gen-syntax2033 src2068 y2094 r2070 maps2071 ellipsis?2072 mod2073)) (lambda (y2109 maps2110) (call-with-values (lambda () (k2095 maps2110)) (lambda (x2111 maps2112) (values (gen-append2038 x2111 y2109) maps2112)))))) tmp2099))) ($sc-dispatch tmp2099 (quote (any . any))))) y2094))) tmp2086) ((lambda (tmp2113) (if tmp2113 (apply (lambda (x2114 y2115) (call-with-values (lambda () (gen-syntax2033 src2068 x2114 r2070 maps2071 ellipsis?2072 mod2073)) (lambda (x2116 maps2117) (call-with-values (lambda () (gen-syntax2033 src2068 y2115 r2070 maps2117 ellipsis?2072 mod2073)) (lambda (y2118 maps2119) (values (gen-cons2037 x2116 y2118) maps2119)))))) tmp2113) ((lambda (tmp2120) (if tmp2120 (apply (lambda (e12121 e22122) (call-with-values (lambda () (gen-syntax2033 src2068 (cons e12121 e22122) r2070 maps2071 ellipsis?2072 mod2073)) (lambda (e2124 maps2125) (values (gen-vector2039 e2124) maps2125)))) tmp2120) ((lambda (_2126) (values (list (quote quote) e2069) maps2071)) tmp2079))) ($sc-dispatch tmp2079 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2079 (quote (any . any)))))) ($sc-dispatch tmp2079 (quote (any any . any)))))) ($sc-dispatch tmp2079 (quote (any any))))) e2069))))) (lambda (e2127 r2128 w2129 s2130 mod2131) (let ((e2132 (source-wrap1241 e2127 w2129 s2130 mod2131))) ((lambda (tmp2133) ((lambda (tmp2134) (if tmp2134 (apply (lambda (_2135 x2136) (call-with-values (lambda () (gen-syntax2033 e2132 x2136 r2128 (quote ()) ellipsis?1257 mod2131)) (lambda (e2137 maps2138) (regen2040 e2137)))) tmp2134) ((lambda (_2139) (syntax-violation (quote syntax) "bad `syntax' form" e2132)) tmp2133))) ($sc-dispatch tmp2133 (quote (any any))))) e2132))))) (global-extend1210 (quote core) (quote lambda) (lambda (e2140 r2141 w2142 s2143 mod2144) ((lambda (tmp2145) ((lambda (tmp2146) (if tmp2146 (apply (lambda (_2147 c2148) (chi-lambda-clause1253 (source-wrap1241 e2140 w2142 s2143 mod2144) #f c2148 r2141 w2142 mod2144 (lambda (vars2149 docstring2150 body2151) (build-annotated1189 s2143 (cons (quote lambda) (cons vars2149 (append (if docstring2150 (list docstring2150) (quote ())) (list body2151)))))))) tmp2146) (syntax-violation #f "source expression failed to match any pattern" tmp2145))) ($sc-dispatch tmp2145 (quote (any . any))))) e2140))) (global-extend1210 (quote core) (quote let) (letrec ((chi-let2152 (lambda (e2153 r2154 w2155 s2156 mod2157 constructor2158 ids2159 vals2160 exps2161) (if (not (valid-bound-ids?1237 ids2159)) (syntax-violation (quote let) "duplicate bound variable" e2153) (let ((labels2162 (gen-labels1218 ids2159)) (new-vars2163 (map gen-var1260 ids2159))) (let ((nw2164 (make-binding-wrap1229 ids2159 labels2162 w2155)) (nr2165 (extend-var-env1207 labels2162 new-vars2163 r2154))) (constructor2158 s2156 new-vars2163 (map (lambda (x2166) (chi1248 x2166 r2154 w2155 mod2157)) vals2160) (chi-body1252 exps2161 (source-wrap1241 e2153 nw2164 s2156 mod2157) nr2165 nw2164 mod2157)))))))) (lambda (e2167 r2168 w2169 s2170 mod2171) ((lambda (tmp2172) ((lambda (tmp2173) (if tmp2173 (apply (lambda (_2174 id2175 val2176 e12177 e22178) (chi-let2152 e2167 r2168 w2169 s2170 mod2171 build-let1192 id2175 val2176 (cons e12177 e22178))) tmp2173) ((lambda (tmp2182) (if (if tmp2182 (apply (lambda (_2183 f2184 id2185 val2186 e12187 e22188) (id?1212 f2184)) tmp2182) #f) (apply (lambda (_2189 f2190 id2191 val2192 e12193 e22194) (chi-let2152 e2167 r2168 w2169 s2170 mod2171 build-named-let1193 (cons f2190 id2191) val2192 (cons e12193 e22194))) tmp2182) ((lambda (_2198) (syntax-violation (quote let) "bad let" (source-wrap1241 e2167 w2169 s2170 mod2171))) tmp2172))) ($sc-dispatch tmp2172 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2172 (quote (any #(each (any any)) any . each-any))))) e2167)))) (global-extend1210 (quote core) (quote letrec) (lambda (e2199 r2200 w2201 s2202 mod2203) ((lambda (tmp2204) ((lambda (tmp2205) (if tmp2205 (apply (lambda (_2206 id2207 val2208 e12209 e22210) (let ((ids2211 id2207)) (if (not (valid-bound-ids?1237 ids2211)) (syntax-violation (quote letrec) "duplicate bound variable" e2199) (let ((labels2213 (gen-labels1218 ids2211)) (new-vars2214 (map gen-var1260 ids2211))) (let ((w2215 (make-binding-wrap1229 ids2211 labels2213 w2201)) (r2216 (extend-var-env1207 labels2213 new-vars2214 r2200))) (build-letrec1194 s2202 new-vars2214 (map (lambda (x2217) (chi1248 x2217 r2216 w2215 mod2203)) val2208) (chi-body1252 (cons e12209 e22210) (source-wrap1241 e2199 w2215 s2202 mod2203) r2216 w2215 mod2203))))))) tmp2205) ((lambda (_2220) (syntax-violation (quote letrec) "bad letrec" (source-wrap1241 e2199 w2201 s2202 mod2203))) tmp2204))) ($sc-dispatch tmp2204 (quote (any #(each (any any)) any . each-any))))) e2199))) (global-extend1210 (quote core) (quote set!) (lambda (e2221 r2222 w2223 s2224 mod2225) ((lambda (tmp2226) ((lambda (tmp2227) (if (if tmp2227 (apply (lambda (_2228 id2229 val2230) (id?1212 id2229)) tmp2227) #f) (apply (lambda (_2231 id2232 val2233) (let ((val2234 (chi1248 val2233 r2222 w2223 mod2225)) (n2235 (id-var-name1234 id2232 w2223))) (let ((b2236 (lookup1209 n2235 r2222 mod2225))) (let ((t2237 (binding-type1204 b2236))) (if (memv t2237 (quote (lexical))) (build-annotated1189 s2224 (list (quote set!) (binding-value1205 b2236) val2234)) (if (memv t2237 (quote (global))) (build-annotated1189 s2224 (list (quote set!) (if mod2225 (make-module-ref (cdr mod2225) n2235 (car mod2225)) (make-module-ref mod2225 n2235 (quote bare))) val2234)) (if (memv t2237 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1240 id2232 w2223 mod2225)) (syntax-violation (quote set!) "bad set!" (source-wrap1241 e2221 w2223 s2224 mod2225))))))))) tmp2227) ((lambda (tmp2238) (if tmp2238 (apply (lambda (_2239 head2240 tail2241 val2242) (call-with-values (lambda () (syntax-type1246 head2240 r2222 (quote (())) #f #f mod2225)) (lambda (type2243 value2244 ee2245 ww2246 ss2247 modmod2248) (let ((t2249 type2243)) (if (memv t2249 (quote (module-ref))) (let ((val2250 (chi1248 val2242 r2222 w2223 mod2225))) (call-with-values (lambda () (value2244 (cons head2240 tail2241))) (lambda (id2252 mod2253) (build-annotated1189 s2224 (list (quote set!) (if mod2253 (make-module-ref (cdr mod2253) id2252 (car mod2253)) (make-module-ref mod2253 id2252 (quote bare))) val2250))))) (build-annotated1189 s2224 (cons (chi1248 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2240) r2222 w2223 mod2225) (map (lambda (e2254) (chi1248 e2254 r2222 w2223 mod2225)) (append tail2241 (list val2242)))))))))) tmp2238) ((lambda (_2256) (syntax-violation (quote set!) "bad set!" (source-wrap1241 e2221 w2223 s2224 mod2225))) tmp2226))) ($sc-dispatch tmp2226 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2226 (quote (any any any))))) e2221))) (global-extend1210 (quote module-ref) (quote @) (lambda (e2257) ((lambda (tmp2258) ((lambda (tmp2259) (if (if tmp2259 (apply (lambda (_2260 mod2261 id2262) (and (andmap id?1212 mod2261) (id?1212 id2262))) tmp2259) #f) (apply (lambda (_2264 mod2265 id2266) (values (syntax->datum id2266) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2265)))) tmp2259) (syntax-violation #f "source expression failed to match any pattern" tmp2258))) ($sc-dispatch tmp2258 (quote (any each-any any))))) e2257))) (global-extend1210 (quote module-ref) (quote @@) (lambda (e2268) ((lambda (tmp2269) ((lambda (tmp2270) (if (if tmp2270 (apply (lambda (_2271 mod2272 id2273) (and (andmap id?1212 mod2272) (id?1212 id2273))) tmp2270) #f) (apply (lambda (_2275 mod2276 id2277) (values (syntax->datum id2277) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2276)))) tmp2270) (syntax-violation #f "source expression failed to match any pattern" tmp2269))) ($sc-dispatch tmp2269 (quote (any each-any any))))) e2268))) (global-extend1210 (quote begin) (quote begin) (quote ())) (global-extend1210 (quote define) (quote define) (quote ())) (global-extend1210 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1210 (quote eval-when) (quote eval-when) (quote ())) (global-extend1210 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2282 (lambda (x2283 keys2284 clauses2285 r2286 mod2287) (if (null? clauses2285) (build-annotated1189 #f (list (build-annotated1189 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2283)) ((lambda (tmp2288) ((lambda (tmp2289) (if tmp2289 (apply (lambda (pat2290 exp2291) (if (and (id?1212 pat2290) (andmap (lambda (x2292) (not (free-id=?1235 pat2290 x2292))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2284))) (let ((labels2293 (list (gen-label1217))) (var2294 (gen-var1260 pat2290))) (build-annotated1189 #f (list (build-annotated1189 #f (list (quote lambda) (list var2294) (chi1248 exp2291 (extend-env1206 labels2293 (list (cons (quote syntax) (cons var2294 0))) r2286) (make-binding-wrap1229 (list pat2290) labels2293 (quote (()))) mod2287))) x2283))) (gen-clause2281 x2283 keys2284 (cdr clauses2285) r2286 pat2290 #t exp2291 mod2287))) tmp2289) ((lambda (tmp2295) (if tmp2295 (apply (lambda (pat2296 fender2297 exp2298) (gen-clause2281 x2283 keys2284 (cdr clauses2285) r2286 pat2296 fender2297 exp2298 mod2287)) tmp2295) ((lambda (_2299) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2285))) tmp2288))) ($sc-dispatch tmp2288 (quote (any any any)))))) ($sc-dispatch tmp2288 (quote (any any))))) (car clauses2285))))) (gen-clause2281 (lambda (x2300 keys2301 clauses2302 r2303 pat2304 fender2305 exp2306 mod2307) (call-with-values (lambda () (convert-pattern2279 pat2304 keys2301)) (lambda (p2308 pvars2309) (cond ((not (distinct-bound-ids?1238 (map car pvars2309))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2304)) ((not (andmap (lambda (x2310) (not (ellipsis?1257 (car x2310)))) pvars2309)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2304)) (else (let ((y2311 (gen-var1260 (quote tmp)))) (build-annotated1189 #f (list (build-annotated1189 #f (list (quote lambda) (list y2311) (let ((y2312 (build-annotated1189 #f y2311))) (build-annotated1189 #f (list (quote if) ((lambda (tmp2313) ((lambda (tmp2314) (if tmp2314 (apply (lambda () y2312) tmp2314) ((lambda (_2315) (build-annotated1189 #f (list (quote if) y2312 (build-dispatch-call2280 pvars2309 fender2305 y2312 r2303 mod2307) (build-data1190 #f #f)))) tmp2313))) ($sc-dispatch tmp2313 (quote #(atom #t))))) fender2305) (build-dispatch-call2280 pvars2309 exp2306 y2312 r2303 mod2307) (gen-syntax-case2282 x2300 keys2301 clauses2302 r2303 mod2307)))))) (if (eq? p2308 (quote any)) (build-annotated1189 #f (list (build-annotated1189 #f (quote list)) x2300)) (build-annotated1189 #f (list (build-annotated1189 #f (quote $sc-dispatch)) x2300 (build-data1190 #f p2308))))))))))))) (build-dispatch-call2280 (lambda (pvars2316 exp2317 y2318 r2319 mod2320) (let ((ids2321 (map car pvars2316)) (levels2322 (map cdr pvars2316))) (let ((labels2323 (gen-labels1218 ids2321)) (new-vars2324 (map gen-var1260 ids2321))) (build-annotated1189 #f (list (build-annotated1189 #f (quote apply)) (build-annotated1189 #f (list (quote lambda) new-vars2324 (chi1248 exp2317 (extend-env1206 labels2323 (map (lambda (var2325 level2326) (cons (quote syntax) (cons var2325 level2326))) new-vars2324 (map cdr pvars2316)) r2319) (make-binding-wrap1229 ids2321 labels2323 (quote (()))) mod2320))) y2318)))))) (convert-pattern2279 (lambda (pattern2327 keys2328) (let cvt2329 ((p2330 pattern2327) (n2331 0) (ids2332 (quote ()))) (if (id?1212 p2330) (if (bound-id-member?1239 p2330 keys2328) (values (vector (quote free-id) p2330) ids2332) (values (quote any) (cons (cons p2330 n2331) ids2332))) ((lambda (tmp2333) ((lambda (tmp2334) (if (if tmp2334 (apply (lambda (x2335 dots2336) (ellipsis?1257 dots2336)) tmp2334) #f) (apply (lambda (x2337 dots2338) (call-with-values (lambda () (cvt2329 x2337 (fx+1180 n2331 1) ids2332)) (lambda (p2339 ids2340) (values (if (eq? p2339 (quote any)) (quote each-any) (vector (quote each) p2339)) ids2340)))) tmp2334) ((lambda (tmp2341) (if tmp2341 (apply (lambda (x2342 y2343) (call-with-values (lambda () (cvt2329 y2343 n2331 ids2332)) (lambda (y2344 ids2345) (call-with-values (lambda () (cvt2329 x2342 n2331 ids2345)) (lambda (x2346 ids2347) (values (cons x2346 y2344) ids2347)))))) tmp2341) ((lambda (tmp2348) (if tmp2348 (apply (lambda () (values (quote ()) ids2332)) tmp2348) ((lambda (tmp2349) (if tmp2349 (apply (lambda (x2350) (call-with-values (lambda () (cvt2329 x2350 n2331 ids2332)) (lambda (p2352 ids2353) (values (vector (quote vector) p2352) ids2353)))) tmp2349) ((lambda (x2354) (values (vector (quote atom) (strip1259 p2330 (quote (())))) ids2332)) tmp2333))) ($sc-dispatch tmp2333 (quote #(vector each-any)))))) ($sc-dispatch tmp2333 (quote ()))))) ($sc-dispatch tmp2333 (quote (any . any)))))) ($sc-dispatch tmp2333 (quote (any any))))) p2330)))))) (lambda (e2355 r2356 w2357 s2358 mod2359) (let ((e2360 (source-wrap1241 e2355 w2357 s2358 mod2359))) ((lambda (tmp2361) ((lambda (tmp2362) (if tmp2362 (apply (lambda (_2363 val2364 key2365 m2366) (if (andmap (lambda (x2367) (and (id?1212 x2367) (not (ellipsis?1257 x2367)))) key2365) (let ((x2369 (gen-var1260 (quote tmp)))) (build-annotated1189 s2358 (list (build-annotated1189 #f (list (quote lambda) (list x2369) (gen-syntax-case2282 (build-annotated1189 #f x2369) key2365 m2366 r2356 mod2359))) (chi1248 val2364 r2356 (quote (())) mod2359)))) (syntax-violation (quote syntax-case) "invalid literals list" e2360))) tmp2362) (syntax-violation #f "source expression failed to match any pattern" tmp2361))) ($sc-dispatch tmp2361 (quote (any any each-any . each-any))))) e2360))))) (set! sc-expand (let ((m2372 (quote e)) (esew2373 (quote (eval)))) (lambda (x2374) (if (and (pair? x2374) (equal? (car x2374) noexpand1179)) (cadr x2374) (chi-top1247 x2374 (quote ()) (quote ((top))) m2372 esew2373 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2375 (quote e)) (esew2376 (quote (eval)))) (lambda (x2378 . rest2377) (if (and (pair? x2378) (equal? (car x2378) noexpand1179)) (cadr x2378) (chi-top1247 x2378 (quote ()) (quote ((top))) (if (null? rest2377) m2375 (car rest2377)) (if (or (null? rest2377) (null? (cdr rest2377))) esew2376 (cadr rest2377)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2379) (nonsymbol-id?1211 x2379))) (set! datum->syntax (lambda (id2380 datum2381) (make-syntax-object1195 datum2381 (syntax-object-wrap1198 id2380) #f))) (set! syntax->datum (lambda (x2382) (strip1259 x2382 (quote (()))))) (set! generate-temporaries (lambda (ls2383) (begin (let ((x2384 ls2383)) (if (not (list? x2384)) (error-hook1186 (quote generate-temporaries) "invalid argument" x2384))) (map (lambda (x2385) (wrap1240 (gensym) (quote ((top))) #f)) ls2383)))) (set! free-identifier=? (lambda (x2386 y2387) (begin (let ((x2388 x2386)) (if (not (nonsymbol-id?1211 x2388)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2388))) (let ((x2389 y2387)) (if (not (nonsymbol-id?1211 x2389)) (error-hook1186 (quote free-identifier=?) "invalid argument" x2389))) (free-id=?1235 x2386 y2387)))) (set! bound-identifier=? (lambda (x2390 y2391) (begin (let ((x2392 x2390)) (if (not (nonsymbol-id?1211 x2392)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2392))) (let ((x2393 y2391)) (if (not (nonsymbol-id?1211 x2393)) (error-hook1186 (quote bound-identifier=?) "invalid argument" x2393))) (bound-id=?1236 x2390 y2391)))) (set! syntax-violation (lambda (who2397 message2396 form2395 . subform2394) (begin (let ((x2398 who2397)) (if (not ((lambda (x2399) (or (not x2399) (string? x2399) (symbol? x2399))) x2398)) (error-hook1186 (quote syntax-violation) "invalid argument" x2398))) (let ((x2400 message2396)) (if (not (string? x2400)) (error-hook1186 (quote syntax-violation) "invalid argument" x2400))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2397 "~a: " "") "~a " (if (null? subform2394) "in ~a" "in subform `~s' of `~s'")) (let ((tail2401 (cons message2396 (map (lambda (x2402) (strip1259 x2402 (quote (())))) (append subform2394 (list form2395)))))) (if who2397 (cons who2397 tail2401) tail2401)) #f)))) (letrec ((match2407 (lambda (e2408 p2409 w2410 r2411 mod2412) (cond ((not r2411) #f) ((eq? p2409 (quote any)) (cons (wrap1240 e2408 w2410 mod2412) r2411)) ((syntax-object?1196 e2408) (match*2406 (let ((e2413 (syntax-object-expression1197 e2408))) (if (annotation? e2413) (annotation-expression e2413) e2413)) p2409 (join-wraps1231 w2410 (syntax-object-wrap1198 e2408)) r2411 (syntax-object-module1199 e2408))) (else (match*2406 (let ((e2414 e2408)) (if (annotation? e2414) (annotation-expression e2414) e2414)) p2409 w2410 r2411 mod2412))))) (match*2406 (lambda (e2415 p2416 w2417 r2418 mod2419) (cond ((null? p2416) (and (null? e2415) r2418)) ((pair? p2416) (and (pair? e2415) (match2407 (car e2415) (car p2416) w2417 (match2407 (cdr e2415) (cdr p2416) w2417 r2418 mod2419) mod2419))) ((eq? p2416 (quote each-any)) (let ((l2420 (match-each-any2404 e2415 w2417 mod2419))) (and l2420 (cons l2420 r2418)))) (else (let ((t2421 (vector-ref p2416 0))) (if (memv t2421 (quote (each))) (if (null? e2415) (match-empty2405 (vector-ref p2416 1) r2418) (let ((l2422 (match-each2403 e2415 (vector-ref p2416 1) w2417 mod2419))) (and l2422 (let collect2423 ((l2424 l2422)) (if (null? (car l2424)) r2418 (cons (map car l2424) (collect2423 (map cdr l2424)))))))) (if (memv t2421 (quote (free-id))) (and (id?1212 e2415) (free-id=?1235 (wrap1240 e2415 w2417 mod2419) (vector-ref p2416 1)) r2418) (if (memv t2421 (quote (atom))) (and (equal? (vector-ref p2416 1) (strip1259 e2415 w2417)) r2418) (if (memv t2421 (quote (vector))) (and (vector? e2415) (match2407 (vector->list e2415) (vector-ref p2416 1) w2417 r2418 mod2419))))))))))) (match-empty2405 (lambda (p2425 r2426) (cond ((null? p2425) r2426) ((eq? p2425 (quote any)) (cons (quote ()) r2426)) ((pair? p2425) (match-empty2405 (car p2425) (match-empty2405 (cdr p2425) r2426))) ((eq? p2425 (quote each-any)) (cons (quote ()) r2426)) (else (let ((t2427 (vector-ref p2425 0))) (if (memv t2427 (quote (each))) (match-empty2405 (vector-ref p2425 1) r2426) (if (memv t2427 (quote (free-id atom))) r2426 (if (memv t2427 (quote (vector))) (match-empty2405 (vector-ref p2425 1) r2426))))))))) (match-each-any2404 (lambda (e2428 w2429 mod2430) (cond ((annotation? e2428) (match-each-any2404 (annotation-expression e2428) w2429 mod2430)) ((pair? e2428) (let ((l2431 (match-each-any2404 (cdr e2428) w2429 mod2430))) (and l2431 (cons (wrap1240 (car e2428) w2429 mod2430) l2431)))) ((null? e2428) (quote ())) ((syntax-object?1196 e2428) (match-each-any2404 (syntax-object-expression1197 e2428) (join-wraps1231 w2429 (syntax-object-wrap1198 e2428)) mod2430)) (else #f)))) (match-each2403 (lambda (e2432 p2433 w2434 mod2435) (cond ((annotation? e2432) (match-each2403 (annotation-expression e2432) p2433 w2434 mod2435)) ((pair? e2432) (let ((first2436 (match2407 (car e2432) p2433 w2434 (quote ()) mod2435))) (and first2436 (let ((rest2437 (match-each2403 (cdr e2432) p2433 w2434 mod2435))) (and rest2437 (cons first2436 rest2437)))))) ((null? e2432) (quote ())) ((syntax-object?1196 e2432) (match-each2403 (syntax-object-expression1197 e2432) p2433 (join-wraps1231 w2434 (syntax-object-wrap1198 e2432)) (syntax-object-module1199 e2432))) (else #f))))) (set! $sc-dispatch (lambda (e2438 p2439) (cond ((eq? p2439 (quote any)) (list e2438)) ((syntax-object?1196 e2438) (match*2406 (let ((e2440 (syntax-object-expression1197 e2438))) (if (annotation? e2440) (annotation-expression e2440) e2440)) p2439 (syntax-object-wrap1198 e2438) (quote ()) (syntax-object-module1199 e2438))) (else (match*2406 (let ((e2441 e2438)) (if (annotation? e2441) (annotation-expression e2441) e2441)) p2439 (quote (())) (quote ()) #f)))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x2442) ((lambda (tmp2443) ((lambda (tmp2444) (if tmp2444 (apply (lambda (_2445 e12446 e22447) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12446 e22447))) tmp2444) ((lambda (tmp2449) (if tmp2449 (apply (lambda (_2450 out2451 in2452 e12453 e22454) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2452 (quote ()) (list out2451 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12453 e22454))))) tmp2449) ((lambda (tmp2456) (if tmp2456 (apply (lambda (_2457 out2458 in2459 e12460 e22461) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2459) (quote ()) (list out2458 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12460 e22461))))) tmp2456) (syntax-violation #f "source expression failed to match any pattern" tmp2443))) ($sc-dispatch tmp2443 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2443 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2443 (quote (any () any . each-any))))) x2442)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2465) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 k2469 keyword2470 pattern2471 template2472) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2469 (map (lambda (tmp2475 tmp2474) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2474) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2475))) template2472 pattern2471)))))) tmp2467) (syntax-violation #f "source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any each-any . #(each ((any . any) any))))))) x2465)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2476) ((lambda (tmp2477) ((lambda (tmp2478) (if (if tmp2478 (apply (lambda (let*2479 x2480 v2481 e12482 e22483) (andmap identifier? x2480)) tmp2478) #f) (apply (lambda (let*2485 x2486 v2487 e12488 e22489) (let f2490 ((bindings2491 (map list x2486 v2487))) (if (null? bindings2491) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12488 e22489))) ((lambda (tmp2495) ((lambda (tmp2496) (if tmp2496 (apply (lambda (body2497 binding2498) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2498) body2497)) tmp2496) (syntax-violation #f "source expression failed to match any pattern" tmp2495))) ($sc-dispatch tmp2495 (quote (any any))))) (list (f2490 (cdr bindings2491)) (car bindings2491)))))) tmp2478) (syntax-violation #f "source expression failed to match any pattern" tmp2477))) ($sc-dispatch tmp2477 (quote (any #(each (any any)) any . each-any))))) x2476)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2499) ((lambda (tmp2500) ((lambda (tmp2501) (if tmp2501 (apply (lambda (_2502 var2503 init2504 step2505 e02506 e12507 c2508) ((lambda (tmp2509) ((lambda (tmp2510) (if tmp2510 (apply (lambda (step2511) ((lambda (tmp2512) ((lambda (tmp2513) (if tmp2513 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2503 init2504) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02506) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2508 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2511))))))) tmp2513) ((lambda (tmp2518) (if tmp2518 (apply (lambda (e12519 e22520) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2503 init2504) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02506 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12519 e22520)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2508 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2511))))))) tmp2518) (syntax-violation #f "source expression failed to match any pattern" tmp2512))) ($sc-dispatch tmp2512 (quote (any . each-any)))))) ($sc-dispatch tmp2512 (quote ())))) e12507)) tmp2510) (syntax-violation #f "source expression failed to match any pattern" tmp2509))) ($sc-dispatch tmp2509 (quote each-any)))) (map (lambda (v2527 s2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda () v2527) tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda (e2532) e2532) tmp2531) ((lambda (_2533) (syntax-violation (quote do) "bad step expression" orig-x2499 s2528)) tmp2529))) ($sc-dispatch tmp2529 (quote (any)))))) ($sc-dispatch tmp2529 (quote ())))) s2528)) var2503 step2505))) tmp2501) (syntax-violation #f "source expression failed to match any pattern" tmp2500))) ($sc-dispatch tmp2500 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2499)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2536 (lambda (x2540 y2541) ((lambda (tmp2542) ((lambda (tmp2543) (if tmp2543 (apply (lambda (x2544 y2545) ((lambda (tmp2546) ((lambda (tmp2547) (if tmp2547 (apply (lambda (dy2548) ((lambda (tmp2549) ((lambda (tmp2550) (if tmp2550 (apply (lambda (dx2551) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2551 dy2548))) tmp2550) ((lambda (_2552) (if (null? dy2548) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2544) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2544 y2545))) tmp2549))) ($sc-dispatch tmp2549 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2544)) tmp2547) ((lambda (tmp2553) (if tmp2553 (apply (lambda (stuff2554) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2544 stuff2554))) tmp2553) ((lambda (else2555) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2544 y2545)) tmp2546))) ($sc-dispatch tmp2546 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2546 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2545)) tmp2543) (syntax-violation #f "source expression failed to match any pattern" tmp2542))) ($sc-dispatch tmp2542 (quote (any any))))) (list x2540 y2541)))) (quasiappend2537 (lambda (x2556 y2557) ((lambda (tmp2558) ((lambda (tmp2559) (if tmp2559 (apply (lambda (x2560 y2561) ((lambda (tmp2562) ((lambda (tmp2563) (if tmp2563 (apply (lambda () x2560) tmp2563) ((lambda (_2564) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2560 y2561)) tmp2562))) ($sc-dispatch tmp2562 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2561)) tmp2559) (syntax-violation #f "source expression failed to match any pattern" tmp2558))) ($sc-dispatch tmp2558 (quote (any any))))) (list x2556 y2557)))) (quasivector2538 (lambda (x2565) ((lambda (tmp2566) ((lambda (x2567) ((lambda (tmp2568) ((lambda (tmp2569) (if tmp2569 (apply (lambda (x2570) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2570))) tmp2569) ((lambda (tmp2572) (if tmp2572 (apply (lambda (x2573) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2573)) tmp2572) ((lambda (_2575) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2567)) tmp2568))) ($sc-dispatch tmp2568 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2568 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2567)) tmp2566)) x2565))) (quasi2539 (lambda (p2576 lev2577) ((lambda (tmp2578) ((lambda (tmp2579) (if tmp2579 (apply (lambda (p2580) (if (= lev2577 0) p2580 (quasicons2536 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2539 (list p2580) (- lev2577 1))))) tmp2579) ((lambda (tmp2581) (if tmp2581 (apply (lambda (p2582 q2583) (if (= lev2577 0) (quasiappend2537 p2582 (quasi2539 q2583 lev2577)) (quasicons2536 (quasicons2536 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2539 (list p2582) (- lev2577 1))) (quasi2539 q2583 lev2577)))) tmp2581) ((lambda (tmp2584) (if tmp2584 (apply (lambda (p2585) (quasicons2536 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2539 (list p2585) (+ lev2577 1)))) tmp2584) ((lambda (tmp2586) (if tmp2586 (apply (lambda (p2587 q2588) (quasicons2536 (quasi2539 p2587 lev2577) (quasi2539 q2588 lev2577))) tmp2586) ((lambda (tmp2589) (if tmp2589 (apply (lambda (x2590) (quasivector2538 (quasi2539 x2590 lev2577))) tmp2589) ((lambda (p2592) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2592)) tmp2578))) ($sc-dispatch tmp2578 (quote #(vector each-any)))))) ($sc-dispatch tmp2578 (quote (any . any)))))) ($sc-dispatch tmp2578 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2578 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2578 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2576)))) (lambda (x2593) ((lambda (tmp2594) ((lambda (tmp2595) (if tmp2595 (apply (lambda (_2596 e2597) (quasi2539 e2597 0)) tmp2595) (syntax-violation #f "source expression failed to match any pattern" tmp2594))) ($sc-dispatch tmp2594 (quote (any any))))) x2593))))) -(define include (make-syncase-macro (quote macro) (lambda (x2598) (letrec ((read-file2599 (lambda (fn2600 k2601) (let ((p2602 (open-input-file fn2600))) (let f2603 ((x2604 (read p2602))) (if (eof-object? x2604) (begin (close-input-port p2602) (quote ())) (cons (datum->syntax k2601 x2604) (f2603 (read p2602))))))))) ((lambda (tmp2605) ((lambda (tmp2606) (if tmp2606 (apply (lambda (k2607 filename2608) (let ((fn2609 (syntax->datum filename2608))) ((lambda (tmp2610) ((lambda (tmp2611) (if tmp2611 (apply (lambda (exp2612) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2612)) tmp2611) (syntax-violation #f "source expression failed to match any pattern" tmp2610))) ($sc-dispatch tmp2610 (quote each-any)))) (read-file2599 fn2609 k2607)))) tmp2606) (syntax-violation #f "source expression failed to match any pattern" tmp2605))) ($sc-dispatch tmp2605 (quote (any any))))) x2598))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x2614) ((lambda (tmp2615) ((lambda (tmp2616) (if tmp2616 (apply (lambda (_2617 e2618) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2618))) tmp2616) (syntax-violation #f "source expression failed to match any pattern" tmp2615))) ($sc-dispatch tmp2615 (quote (any any))))) x2614)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2619) ((lambda (tmp2620) ((lambda (tmp2621) (if tmp2621 (apply (lambda (_2622 e2623) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2623))) tmp2621) (syntax-violation #f "source expression failed to match any pattern" tmp2620))) ($sc-dispatch tmp2620 (quote (any any))))) x2619)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2624) ((lambda (tmp2625) ((lambda (tmp2626) (if tmp2626 (apply (lambda (_2627 e2628 m12629 m22630) ((lambda (tmp2631) ((lambda (body2632) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2628)) body2632)) tmp2631)) (let f2633 ((clause2634 m12629) (clauses2635 m22630)) (if (null? clauses2635) ((lambda (tmp2637) ((lambda (tmp2638) (if tmp2638 (apply (lambda (e12639 e22640) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12639 e22640))) tmp2638) ((lambda (tmp2642) (if tmp2642 (apply (lambda (k2643 e12644 e22645) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2643)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12644 e22645)))) tmp2642) ((lambda (_2648) (syntax-violation (quote case) "bad clause" x2624 clause2634)) tmp2637))) ($sc-dispatch tmp2637 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2637 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2634) ((lambda (tmp2649) ((lambda (rest2650) ((lambda (tmp2651) ((lambda (tmp2652) (if tmp2652 (apply (lambda (k2653 e12654 e22655) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2653)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12654 e22655)) rest2650)) tmp2652) ((lambda (_2658) (syntax-violation (quote case) "bad clause" x2624 clause2634)) tmp2651))) ($sc-dispatch tmp2651 (quote (each-any any . each-any))))) clause2634)) tmp2649)) (f2633 (car clauses2635) (cdr clauses2635))))))) tmp2626) (syntax-violation #f "source expression failed to match any pattern" tmp2625))) ($sc-dispatch tmp2625 (quote (any any any . each-any))))) x2624)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2659) ((lambda (tmp2660) ((lambda (tmp2661) (if tmp2661 (apply (lambda (_2662 e2663) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2663)) (list (cons _2662 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2663 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2661) (syntax-violation #f "source expression failed to match any pattern" tmp2660))) ($sc-dispatch tmp2660 (quote (any any))))) x2659)))) +(letrec ((and-map*1002 (lambda (f1042 first1041 . rest1040) (or (null? first1041) (if (null? rest1040) (let andmap1043 ((first1044 first1041)) (let ((x1045 (car first1044)) (first1046 (cdr first1044))) (if (null? first1046) (f1042 x1045) (and (f1042 x1045) (andmap1043 first1046))))) (let andmap1047 ((first1048 first1041) (rest1049 rest1040)) (let ((x1050 (car first1048)) (xr1051 (map car rest1049)) (first1052 (cdr first1048)) (rest1053 (map cdr rest1049))) (if (null? first1052) (apply f1042 (cons x1050 xr1051)) (and (apply f1042 (cons x1050 xr1051)) (andmap1047 first1052 rest1053)))))))))) (letrec ((lambda-var-list1136 (lambda (vars1341) (let lvl1342 ((vars1343 vars1341) (ls1344 (quote ())) (w1345 (quote (())))) (cond ((pair? vars1343) (lvl1342 (cdr vars1343) (cons (wrap1115 (car vars1343) w1345 #f) ls1344) w1345)) ((id?1087 vars1343) (cons (wrap1115 vars1343 w1345 #f) ls1344)) ((null? vars1343) ls1344) ((syntax-object?1071 vars1343) (lvl1342 (syntax-object-expression1072 vars1343) ls1344 (join-wraps1106 w1345 (syntax-object-wrap1073 vars1343)))) ((annotation? vars1343) (lvl1342 (annotation-expression vars1343) ls1344 w1345)) (else (cons vars1343 ls1344)))))) (gen-var1135 (lambda (id1346) (let ((id1347 (if (syntax-object?1071 id1346) (syntax-object-expression1072 id1346) id1346))) (if (annotation? id1347) (build-annotated1064 (annotation-source id1347) (gensym (symbol->string (annotation-expression id1347)))) (build-annotated1064 #f (gensym (symbol->string id1347))))))) (strip1134 (lambda (x1348 w1349) (if (memq (quote top) (wrap-marks1090 w1349)) (if (or (annotation? x1348) (and (pair? x1348) (annotation? (car x1348)))) (strip-annotation1133 x1348 #f) x1348) (let f1350 ((x1351 x1348)) (cond ((syntax-object?1071 x1351) (strip1134 (syntax-object-expression1072 x1351) (syntax-object-wrap1073 x1351))) ((pair? x1351) (let ((a1352 (f1350 (car x1351))) (d1353 (f1350 (cdr x1351)))) (if (and (eq? a1352 (car x1351)) (eq? d1353 (cdr x1351))) x1351 (cons a1352 d1353)))) ((vector? x1351) (let ((old1354 (vector->list x1351))) (let ((new1355 (map f1350 old1354))) (if (and-map*1002 eq? old1354 new1355) x1351 (list->vector new1355))))) (else x1351)))))) (strip-annotation1133 (lambda (x1356 parent1357) (cond ((pair? x1356) (let ((new1358 (cons #f #f))) (begin (if parent1357 (set-annotation-stripped! parent1357 new1358)) (set-car! new1358 (strip-annotation1133 (car x1356) #f)) (set-cdr! new1358 (strip-annotation1133 (cdr x1356) #f)) new1358))) ((annotation? x1356) (or (annotation-stripped x1356) (strip-annotation1133 (annotation-expression x1356) x1356))) ((vector? x1356) (let ((new1359 (make-vector (vector-length x1356)))) (begin (if parent1357 (set-annotation-stripped! parent1357 new1359)) (let loop1360 ((i1361 (- (vector-length x1356) 1))) (unless (fx<1058 i1361 0) (vector-set! new1359 i1361 (strip-annotation1133 (vector-ref x1356 i1361) #f)) (loop1360 (fx-1056 i1361 1)))) new1359))) (else x1356)))) (ellipsis?1132 (lambda (x1362) (and (nonsymbol-id?1086 x1362) (free-id=?1110 x1362 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1131 (lambda () (build-annotated1064 #f (list (build-annotated1064 #f (quote void)))))) (eval-local-transformer1130 (lambda (expanded1363 mod1364) (let ((p1365 (local-eval-hook1060 expanded1363 mod1364))) (if (procedure? p1365) p1365 (syntax-violation #f "nonprocedure transformer" p1365))))) (chi-local-syntax1129 (lambda (rec?1366 e1367 r1368 w1369 s1370 mod1371 k1372) ((lambda (tmp1373) ((lambda (tmp1374) (if tmp1374 (apply (lambda (_1375 id1376 val1377 e11378 e21379) (let ((ids1380 id1376)) (if (not (valid-bound-ids?1112 ids1380)) (syntax-violation #f "duplicate bound keyword" e1367) (let ((labels1382 (gen-labels1093 ids1380))) (let ((new-w1383 (make-binding-wrap1104 ids1380 labels1382 w1369))) (k1372 (cons e11378 e21379) (extend-env1081 labels1382 (let ((w1385 (if rec?1366 new-w1383 w1369)) (trans-r1386 (macros-only-env1083 r1368))) (map (lambda (x1387) (cons (quote macro) (eval-local-transformer1130 (chi1123 x1387 trans-r1386 w1385 mod1371) mod1371))) val1377)) r1368) new-w1383 s1370 mod1371)))))) tmp1374) ((lambda (_1389) (syntax-violation #f "bad local syntax definition" (source-wrap1116 e1367 w1369 s1370 mod1371))) tmp1373))) ($sc-dispatch tmp1373 (quote (any #(each (any any)) any . each-any))))) e1367))) (chi-lambda-clause1128 (lambda (e1390 docstring1391 c1392 r1393 w1394 mod1395 k1396) ((lambda (tmp1397) ((lambda (tmp1398) (if (if tmp1398 (apply (lambda (args1399 doc1400 e11401 e21402) (and (string? (syntax->datum doc1400)) (not docstring1391))) tmp1398) #f) (apply (lambda (args1403 doc1404 e11405 e21406) (chi-lambda-clause1128 e1390 doc1404 (cons args1403 (cons e11405 e21406)) r1393 w1394 mod1395 k1396)) tmp1398) ((lambda (tmp1408) (if tmp1408 (apply (lambda (id1409 e11410 e21411) (let ((ids1412 id1409)) (if (not (valid-bound-ids?1112 ids1412)) (syntax-violation (quote lambda) "invalid parameter list" e1390) (let ((labels1414 (gen-labels1093 ids1412)) (new-vars1415 (map gen-var1135 ids1412))) (k1396 new-vars1415 docstring1391 (chi-body1127 (cons e11410 e21411) e1390 (extend-var-env1082 labels1414 new-vars1415 r1393) (make-binding-wrap1104 ids1412 labels1414 w1394) mod1395)))))) tmp1408) ((lambda (tmp1417) (if tmp1417 (apply (lambda (ids1418 e11419 e21420) (let ((old-ids1421 (lambda-var-list1136 ids1418))) (if (not (valid-bound-ids?1112 old-ids1421)) (syntax-violation (quote lambda) "invalid parameter list" e1390) (let ((labels1422 (gen-labels1093 old-ids1421)) (new-vars1423 (map gen-var1135 old-ids1421))) (k1396 (let f1424 ((ls11425 (cdr new-vars1423)) (ls21426 (car new-vars1423))) (if (null? ls11425) ls21426 (f1424 (cdr ls11425) (cons (car ls11425) ls21426)))) docstring1391 (chi-body1127 (cons e11419 e21420) e1390 (extend-var-env1082 labels1422 new-vars1423 r1393) (make-binding-wrap1104 old-ids1421 labels1422 w1394) mod1395)))))) tmp1417) ((lambda (_1428) (syntax-violation (quote lambda) "bad lambda" e1390)) tmp1397))) ($sc-dispatch tmp1397 (quote (any any . each-any)))))) ($sc-dispatch tmp1397 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1397 (quote (any any any . each-any))))) c1392))) (chi-body1127 (lambda (body1429 outer-form1430 r1431 w1432 mod1433) (let ((r1434 (cons (quote ("placeholder" placeholder)) r1431))) (let ((ribcage1435 (make-ribcage1094 (quote ()) (quote ()) (quote ())))) (let ((w1436 (make-wrap1089 (wrap-marks1090 w1432) (cons ribcage1435 (wrap-subst1091 w1432))))) (let parse1437 ((body1438 (map (lambda (x1444) (cons r1434 (wrap1115 x1444 w1436 mod1433))) body1429)) (ids1439 (quote ())) (labels1440 (quote ())) (vars1441 (quote ())) (vals1442 (quote ())) (bindings1443 (quote ()))) (if (null? body1438) (syntax-violation #f "no expressions in body" outer-form1430) (let ((e1445 (cdar body1438)) (er1446 (caar body1438))) (call-with-values (lambda () (syntax-type1121 e1445 er1446 (quote (())) #f ribcage1435 mod1433)) (lambda (type1447 value1448 e1449 w1450 s1451 mod1452) (let ((t1453 type1447)) (if (memv t1453 (quote (define-form))) (let ((id1454 (wrap1115 value1448 w1450 mod1452)) (label1455 (gen-label1092))) (let ((var1456 (gen-var1135 id1454))) (begin (extend-ribcage!1103 ribcage1435 id1454 label1455) (parse1437 (cdr body1438) (cons id1454 ids1439) (cons label1455 labels1440) (cons var1456 vars1441) (cons (cons er1446 (wrap1115 e1449 w1450 mod1452)) vals1442) (cons (cons (quote lexical) var1456) bindings1443))))) (if (memv t1453 (quote (define-syntax-form))) (let ((id1457 (wrap1115 value1448 w1450 mod1452)) (label1458 (gen-label1092))) (begin (extend-ribcage!1103 ribcage1435 id1457 label1458) (parse1437 (cdr body1438) (cons id1457 ids1439) (cons label1458 labels1440) vars1441 vals1442 (cons (cons (quote macro) (cons er1446 (wrap1115 e1449 w1450 mod1452))) bindings1443)))) (if (memv t1453 (quote (begin-form))) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (_1461 e11462) (parse1437 (let f1463 ((forms1464 e11462)) (if (null? forms1464) (cdr body1438) (cons (cons er1446 (wrap1115 (car forms1464) w1450 mod1452)) (f1463 (cdr forms1464))))) ids1439 labels1440 vars1441 vals1442 bindings1443)) tmp1460) (syntax-violation #f "source expression failed to match any pattern" tmp1459))) ($sc-dispatch tmp1459 (quote (any . each-any))))) e1449) (if (memv t1453 (quote (local-syntax-form))) (chi-local-syntax1129 value1448 e1449 er1446 w1450 s1451 mod1452 (lambda (forms1466 er1467 w1468 s1469 mod1470) (parse1437 (let f1471 ((forms1472 forms1466)) (if (null? forms1472) (cdr body1438) (cons (cons er1467 (wrap1115 (car forms1472) w1468 mod1470)) (f1471 (cdr forms1472))))) ids1439 labels1440 vars1441 vals1442 bindings1443))) (if (null? ids1439) (build-sequence1066 #f (map (lambda (x1473) (chi1123 (cdr x1473) (car x1473) (quote (())) mod1452)) (cons (cons er1446 (source-wrap1116 e1449 w1450 s1451 mod1452)) (cdr body1438)))) (begin (if (not (valid-bound-ids?1112 ids1439)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1430)) (let loop1474 ((bs1475 bindings1443) (er-cache1476 #f) (r-cache1477 #f)) (if (not (null? bs1475)) (let ((b1478 (car bs1475))) (if (eq? (car b1478) (quote macro)) (let ((er1479 (cadr b1478))) (let ((r-cache1480 (if (eq? er1479 er-cache1476) r-cache1477 (macros-only-env1083 er1479)))) (begin (set-cdr! b1478 (eval-local-transformer1130 (chi1123 (cddr b1478) r-cache1480 (quote (())) mod1452) mod1452)) (loop1474 (cdr bs1475) er1479 r-cache1480)))) (loop1474 (cdr bs1475) er-cache1476 r-cache1477))))) (set-cdr! r1434 (extend-env1081 labels1440 bindings1443 (cdr r1434))) (build-letrec1069 #f vars1441 (map (lambda (x1481) (chi1123 (cdr x1481) (car x1481) (quote (())) mod1452)) vals1442) (build-sequence1066 #f (map (lambda (x1482) (chi1123 (cdr x1482) (car x1482) (quote (())) mod1452)) (cons (cons er1446 (source-wrap1116 e1449 w1450 s1451 mod1452)) (cdr body1438)))))))))))))))))))))) (chi-macro1126 (lambda (p1483 e1484 r1485 w1486 rib1487 mod1488) (letrec ((rebuild-macro-output1489 (lambda (x1490 m1491) (cond ((pair? x1490) (cons (rebuild-macro-output1489 (car x1490) m1491) (rebuild-macro-output1489 (cdr x1490) m1491))) ((syntax-object?1071 x1490) (let ((w1492 (syntax-object-wrap1073 x1490))) (let ((ms1493 (wrap-marks1090 w1492)) (s1494 (wrap-subst1091 w1492))) (if (and (pair? ms1493) (eq? (car ms1493) #f)) (make-syntax-object1070 (syntax-object-expression1072 x1490) (make-wrap1089 (cdr ms1493) (if rib1487 (cons rib1487 (cdr s1494)) (cdr s1494))) (syntax-object-module1074 x1490)) (make-syntax-object1070 (syntax-object-expression1072 x1490) (make-wrap1089 (cons m1491 ms1493) (if rib1487 (cons rib1487 (cons (quote shift) s1494)) (cons (quote shift) s1494))) (let ((pmod1495 (procedure-module p1483))) (if pmod1495 (cons (quote hygiene) (module-name pmod1495)) (quote (hygiene guile))))))))) ((vector? x1490) (let ((n1496 (vector-length x1490))) (let ((v1497 (make-vector n1496))) (let doloop1498 ((i1499 0)) (if (fx=1057 i1499 n1496) v1497 (begin (vector-set! v1497 i1499 (rebuild-macro-output1489 (vector-ref x1490 i1499) m1491)) (doloop1498 (fx+1055 i1499 1)))))))) ((symbol? x1490) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1116 e1484 w1486 s mod1488) x1490)) (else x1490))))) (rebuild-macro-output1489 (p1483 (wrap1115 e1484 (anti-mark1102 w1486) mod1488)) (string #\m))))) (chi-application1125 (lambda (x1500 e1501 r1502 w1503 s1504 mod1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (e01508 e11509) (build-annotated1064 s1504 (cons x1500 (map (lambda (e1510) (chi1123 e1510 r1502 w1503 mod1505)) e11509)))) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any . each-any))))) e1501))) (chi-expr1124 (lambda (type1512 value1513 e1514 r1515 w1516 s1517 mod1518) (let ((t1519 type1512)) (if (memv t1519 (quote (lexical))) (build-annotated1064 s1517 value1513) (if (memv t1519 (quote (core external-macro))) (value1513 e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (module-ref))) (call-with-values (lambda () (value1513 e1514)) (lambda (id1520 mod1521) (build-annotated1064 s1517 (if mod1521 (make-module-ref (cdr mod1521) id1520 (car mod1521)) (make-module-ref mod1521 id1520 (quote bare)))))) (if (memv t1519 (quote (lexical-call))) (chi-application1125 (build-annotated1064 (source-annotation1078 (car e1514)) value1513) e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (global-call))) (chi-application1125 (build-annotated1064 (source-annotation1078 (car e1514)) (if (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518) (make-module-ref (cdr (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518)) value1513 (car (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518))) (make-module-ref (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518) value1513 (quote bare)))) e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (constant))) (build-data1065 s1517 (strip1134 (source-wrap1116 e1514 w1516 s1517 mod1518) (quote (())))) (if (memv t1519 (quote (global))) (build-annotated1064 s1517 (if mod1518 (make-module-ref (cdr mod1518) value1513 (car mod1518)) (make-module-ref mod1518 value1513 (quote bare)))) (if (memv t1519 (quote (call))) (chi-application1125 (chi1123 (car e1514) r1515 w1516 mod1518) e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (begin-form))) ((lambda (tmp1522) ((lambda (tmp1523) (if tmp1523 (apply (lambda (_1524 e11525 e21526) (chi-sequence1117 (cons e11525 e21526) r1515 w1516 s1517 mod1518)) tmp1523) (syntax-violation #f "source expression failed to match any pattern" tmp1522))) ($sc-dispatch tmp1522 (quote (any any . each-any))))) e1514) (if (memv t1519 (quote (local-syntax-form))) (chi-local-syntax1129 value1513 e1514 r1515 w1516 s1517 mod1518 chi-sequence1117) (if (memv t1519 (quote (eval-when-form))) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (_1530 x1531 e11532 e21533) (let ((when-list1534 (chi-when-list1120 e1514 x1531 w1516))) (if (memq (quote eval) when-list1534) (chi-sequence1117 (cons e11532 e21533) r1515 w1516 s1517 mod1518) (chi-void1131)))) tmp1529) (syntax-violation #f "source expression failed to match any pattern" tmp1528))) ($sc-dispatch tmp1528 (quote (any each-any any . each-any))))) e1514) (if (memv t1519 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1514 (wrap1115 value1513 w1516 mod1518)) (if (memv t1519 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1116 e1514 w1516 s1517 mod1518)) (if (memv t1519 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1116 e1514 w1516 s1517 mod1518)) (syntax-violation #f "unexpected syntax" (source-wrap1116 e1514 w1516 s1517 mod1518))))))))))))))))))) (chi1123 (lambda (e1537 r1538 w1539 mod1540) (call-with-values (lambda () (syntax-type1121 e1537 r1538 w1539 #f #f mod1540)) (lambda (type1541 value1542 e1543 w1544 s1545 mod1546) (chi-expr1124 type1541 value1542 e1543 r1538 w1544 s1545 mod1546))))) (chi-top1122 (lambda (e1547 r1548 w1549 m1550 esew1551 mod1552) (call-with-values (lambda () (syntax-type1121 e1547 r1548 w1549 #f #f mod1552)) (lambda (type1560 value1561 e1562 w1563 s1564 mod1565) (let ((t1566 type1560)) (if (memv t1566 (quote (begin-form))) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569) (chi-void1131)) tmp1568) ((lambda (tmp1570) (if tmp1570 (apply (lambda (_1571 e11572 e21573) (chi-top-sequence1118 (cons e11572 e21573) r1548 w1563 s1564 m1550 esew1551 mod1565)) tmp1570) (syntax-violation #f "source expression failed to match any pattern" tmp1567))) ($sc-dispatch tmp1567 (quote (any any . each-any)))))) ($sc-dispatch tmp1567 (quote (any))))) e1562) (if (memv t1566 (quote (local-syntax-form))) (chi-local-syntax1129 value1561 e1562 r1548 w1563 s1564 mod1565 (lambda (body1575 r1576 w1577 s1578 mod1579) (chi-top-sequence1118 body1575 r1576 w1577 s1578 m1550 esew1551 mod1579))) (if (memv t1566 (quote (eval-when-form))) ((lambda (tmp1580) ((lambda (tmp1581) (if tmp1581 (apply (lambda (_1582 x1583 e11584 e21585) (let ((when-list1586 (chi-when-list1120 e1562 x1583 w1563)) (body1587 (cons e11584 e21585))) (cond ((eq? m1550 (quote e)) (if (memq (quote eval) when-list1586) (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote e) (quote (eval)) mod1565) (chi-void1131))) ((memq (quote load) when-list1586) (if (or (memq (quote compile) when-list1586) (and (eq? m1550 (quote c&e)) (memq (quote eval) when-list1586))) (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote c&e) (quote (compile load)) mod1565) (if (memq m1550 (quote (c c&e))) (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote c) (quote (load)) mod1565) (chi-void1131)))) ((or (memq (quote compile) when-list1586) (and (eq? m1550 (quote c&e)) (memq (quote eval) when-list1586))) (top-level-eval-hook1059 (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote e) (quote (eval)) mod1565) mod1565) (chi-void1131)) (else (chi-void1131))))) tmp1581) (syntax-violation #f "source expression failed to match any pattern" tmp1580))) ($sc-dispatch tmp1580 (quote (any each-any any . each-any))))) e1562) (if (memv t1566 (quote (define-syntax-form))) (let ((n1590 (id-var-name1109 value1561 w1563)) (r1591 (macros-only-env1083 r1548))) (let ((t1592 m1550)) (if (memv t1592 (quote (c))) (if (memq (quote compile) esew1551) (let ((e1593 (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)))) (begin (top-level-eval-hook1059 e1593 mod1565) (if (memq (quote load) esew1551) e1593 (chi-void1131)))) (if (memq (quote load) esew1551) (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)) (chi-void1131))) (if (memv t1592 (quote (c&e))) (let ((e1594 (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)))) (begin (top-level-eval-hook1059 e1594 mod1565) e1594)) (begin (if (memq (quote eval) esew1551) (top-level-eval-hook1059 (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)) mod1565)) (chi-void1131)))))) (if (memv t1566 (quote (define-form))) (let ((n1595 (id-var-name1109 value1561 w1563))) (let ((type1596 (binding-type1079 (lookup1084 n1595 r1548 mod1565)))) (let ((t1597 type1596)) (if (memv t1597 (quote (global core macro module-ref))) (let ((x1598 (build-annotated1064 s1564 (list (quote define) n1595 (chi1123 e1562 r1548 w1563 mod1565))))) (begin (if (eq? m1550 (quote c&e)) (top-level-eval-hook1059 x1598 mod1565)) x1598)) (if (memv t1597 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1562 (wrap1115 value1561 w1563 mod1565)) (syntax-violation #f "cannot define keyword at top level" e1562 (wrap1115 value1561 w1563 mod1565))))))) (let ((x1599 (chi-expr1124 type1560 value1561 e1562 r1548 w1563 s1564 mod1565))) (begin (if (eq? m1550 (quote c&e)) (top-level-eval-hook1059 x1599 mod1565)) x1599)))))))))))) (syntax-type1121 (lambda (e1600 r1601 w1602 s1603 rib1604 mod1605) (cond ((symbol? e1600) (let ((n1606 (id-var-name1109 e1600 w1602))) (let ((b1607 (lookup1084 n1606 r1601 mod1605))) (let ((type1608 (binding-type1079 b1607))) (let ((t1609 type1608)) (if (memv t1609 (quote (lexical))) (values type1608 (binding-value1080 b1607) e1600 w1602 s1603 mod1605) (if (memv t1609 (quote (global))) (values type1608 n1606 e1600 w1602 s1603 mod1605) (if (memv t1609 (quote (macro))) (syntax-type1121 (chi-macro1126 (binding-value1080 b1607) e1600 r1601 w1602 rib1604 mod1605) r1601 (quote (())) s1603 rib1604 mod1605) (values type1608 (binding-value1080 b1607) e1600 w1602 s1603 mod1605))))))))) ((pair? e1600) (let ((first1610 (car e1600))) (if (id?1087 first1610) (let ((n1611 (id-var-name1109 first1610 w1602))) (let ((b1612 (lookup1084 n1611 r1601 (or (and (syntax-object?1071 first1610) (syntax-object-module1074 first1610)) mod1605)))) (let ((type1613 (binding-type1079 b1612))) (let ((t1614 type1613)) (if (memv t1614 (quote (lexical))) (values (quote lexical-call) (binding-value1080 b1612) e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (global))) (values (quote global-call) n1611 e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (macro))) (syntax-type1121 (chi-macro1126 (binding-value1080 b1612) e1600 r1601 w1602 rib1604 mod1605) r1601 (quote (())) s1603 rib1604 mod1605) (if (memv t1614 (quote (core external-macro module-ref))) (values type1613 (binding-value1080 b1612) e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1080 b1612) e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (begin))) (values (quote begin-form) #f e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (eval-when))) (values (quote eval-when-form) #f e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (define))) ((lambda (tmp1615) ((lambda (tmp1616) (if (if tmp1616 (apply (lambda (_1617 name1618 val1619) (id?1087 name1618)) tmp1616) #f) (apply (lambda (_1620 name1621 val1622) (values (quote define-form) name1621 val1622 w1602 s1603 mod1605)) tmp1616) ((lambda (tmp1623) (if (if tmp1623 (apply (lambda (_1624 name1625 args1626 e11627 e21628) (and (id?1087 name1625) (valid-bound-ids?1112 (lambda-var-list1136 args1626)))) tmp1623) #f) (apply (lambda (_1629 name1630 args1631 e11632 e21633) (values (quote define-form) (wrap1115 name1630 w1602 mod1605) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1115 (cons args1631 (cons e11632 e21633)) w1602 mod1605)) (quote (())) s1603 mod1605)) tmp1623) ((lambda (tmp1635) (if (if tmp1635 (apply (lambda (_1636 name1637) (id?1087 name1637)) tmp1635) #f) (apply (lambda (_1638 name1639) (values (quote define-form) (wrap1115 name1639 w1602 mod1605) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1603 mod1605)) tmp1635) (syntax-violation #f "source expression failed to match any pattern" tmp1615))) ($sc-dispatch tmp1615 (quote (any any)))))) ($sc-dispatch tmp1615 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1615 (quote (any any any))))) e1600) (if (memv t1614 (quote (define-syntax))) ((lambda (tmp1640) ((lambda (tmp1641) (if (if tmp1641 (apply (lambda (_1642 name1643 val1644) (id?1087 name1643)) tmp1641) #f) (apply (lambda (_1645 name1646 val1647) (values (quote define-syntax-form) name1646 val1647 w1602 s1603 mod1605)) tmp1641) (syntax-violation #f "source expression failed to match any pattern" tmp1640))) ($sc-dispatch tmp1640 (quote (any any any))))) e1600) (values (quote call) #f e1600 w1602 s1603 mod1605)))))))))))))) (values (quote call) #f e1600 w1602 s1603 mod1605)))) ((syntax-object?1071 e1600) (syntax-type1121 (syntax-object-expression1072 e1600) r1601 (join-wraps1106 w1602 (syntax-object-wrap1073 e1600)) #f rib1604 (or (syntax-object-module1074 e1600) mod1605))) ((annotation? e1600) (syntax-type1121 (annotation-expression e1600) r1601 w1602 (annotation-source e1600) rib1604 mod1605)) ((self-evaluating? e1600) (values (quote constant) #f e1600 w1602 s1603 mod1605)) (else (values (quote other) #f e1600 w1602 s1603 mod1605))))) (chi-when-list1120 (lambda (e1648 when-list1649 w1650) (let f1651 ((when-list1652 when-list1649) (situations1653 (quote ()))) (if (null? when-list1652) situations1653 (f1651 (cdr when-list1652) (cons (let ((x1654 (car when-list1652))) (cond ((free-id=?1110 x1654 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1110 x1654 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1110 x1654 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1648 (wrap1115 x1654 w1650 #f))))) situations1653)))))) (chi-install-global1119 (lambda (name1655 e1656) (build-annotated1064 #f (list (build-annotated1064 #f (quote define)) name1655 (if (let ((v1657 (module-variable (current-module) name1655))) (and v1657 (variable-bound? v1657) (macro? (variable-ref v1657)) (not (eq? (macro-type (variable-ref v1657)) (quote syncase-macro))))) (build-annotated1064 #f (list (build-annotated1064 #f (quote make-extended-syncase-macro)) (build-annotated1064 #f (list (build-annotated1064 #f (quote module-ref)) (build-annotated1064 #f (quote (current-module))) (build-data1065 #f name1655))) (build-data1065 #f (quote macro)) e1656)) (build-annotated1064 #f (list (build-annotated1064 #f (quote make-syncase-macro)) (build-data1065 #f (quote macro)) e1656))))))) (chi-top-sequence1118 (lambda (body1658 r1659 w1660 s1661 m1662 esew1663 mod1664) (build-sequence1066 s1661 (let dobody1665 ((body1666 body1658) (r1667 r1659) (w1668 w1660) (m1669 m1662) (esew1670 esew1663) (mod1671 mod1664)) (if (null? body1666) (quote ()) (let ((first1672 (chi-top1122 (car body1666) r1667 w1668 m1669 esew1670 mod1671))) (cons first1672 (dobody1665 (cdr body1666) r1667 w1668 m1669 esew1670 mod1671)))))))) (chi-sequence1117 (lambda (body1673 r1674 w1675 s1676 mod1677) (build-sequence1066 s1676 (let dobody1678 ((body1679 body1673) (r1680 r1674) (w1681 w1675) (mod1682 mod1677)) (if (null? body1679) (quote ()) (let ((first1683 (chi1123 (car body1679) r1680 w1681 mod1682))) (cons first1683 (dobody1678 (cdr body1679) r1680 w1681 mod1682)))))))) (source-wrap1116 (lambda (x1684 w1685 s1686 defmod1687) (wrap1115 (if s1686 (make-annotation x1684 s1686 #f) x1684) w1685 defmod1687))) (wrap1115 (lambda (x1688 w1689 defmod1690) (cond ((and (null? (wrap-marks1090 w1689)) (null? (wrap-subst1091 w1689))) x1688) ((syntax-object?1071 x1688) (make-syntax-object1070 (syntax-object-expression1072 x1688) (join-wraps1106 w1689 (syntax-object-wrap1073 x1688)) (syntax-object-module1074 x1688))) ((null? x1688) x1688) (else (make-syntax-object1070 x1688 w1689 defmod1690))))) (bound-id-member?1114 (lambda (x1691 list1692) (and (not (null? list1692)) (or (bound-id=?1111 x1691 (car list1692)) (bound-id-member?1114 x1691 (cdr list1692)))))) (distinct-bound-ids?1113 (lambda (ids1693) (let distinct?1694 ((ids1695 ids1693)) (or (null? ids1695) (and (not (bound-id-member?1114 (car ids1695) (cdr ids1695))) (distinct?1694 (cdr ids1695))))))) (valid-bound-ids?1112 (lambda (ids1696) (and (let all-ids?1697 ((ids1698 ids1696)) (or (null? ids1698) (and (id?1087 (car ids1698)) (all-ids?1697 (cdr ids1698))))) (distinct-bound-ids?1113 ids1696)))) (bound-id=?1111 (lambda (i1699 j1700) (if (and (syntax-object?1071 i1699) (syntax-object?1071 j1700)) (and (eq? (let ((e1701 (syntax-object-expression1072 i1699))) (if (annotation? e1701) (annotation-expression e1701) e1701)) (let ((e1702 (syntax-object-expression1072 j1700))) (if (annotation? e1702) (annotation-expression e1702) e1702))) (same-marks?1108 (wrap-marks1090 (syntax-object-wrap1073 i1699)) (wrap-marks1090 (syntax-object-wrap1073 j1700)))) (eq? (let ((e1703 i1699)) (if (annotation? e1703) (annotation-expression e1703) e1703)) (let ((e1704 j1700)) (if (annotation? e1704) (annotation-expression e1704) e1704)))))) (free-id=?1110 (lambda (i1705 j1706) (and (eq? (let ((x1707 i1705)) (let ((e1708 (if (syntax-object?1071 x1707) (syntax-object-expression1072 x1707) x1707))) (if (annotation? e1708) (annotation-expression e1708) e1708))) (let ((x1709 j1706)) (let ((e1710 (if (syntax-object?1071 x1709) (syntax-object-expression1072 x1709) x1709))) (if (annotation? e1710) (annotation-expression e1710) e1710)))) (eq? (id-var-name1109 i1705 (quote (()))) (id-var-name1109 j1706 (quote (()))))))) (id-var-name1109 (lambda (id1711 w1712) (letrec ((search-vector-rib1715 (lambda (sym1721 subst1722 marks1723 symnames1724 ribcage1725) (let ((n1726 (vector-length symnames1724))) (let f1727 ((i1728 0)) (cond ((fx=1057 i1728 n1726) (search1713 sym1721 (cdr subst1722) marks1723)) ((and (eq? (vector-ref symnames1724 i1728) sym1721) (same-marks?1108 marks1723 (vector-ref (ribcage-marks1097 ribcage1725) i1728))) (values (vector-ref (ribcage-labels1098 ribcage1725) i1728) marks1723)) (else (f1727 (fx+1055 i1728 1)))))))) (search-list-rib1714 (lambda (sym1729 subst1730 marks1731 symnames1732 ribcage1733) (let f1734 ((symnames1735 symnames1732) (i1736 0)) (cond ((null? symnames1735) (search1713 sym1729 (cdr subst1730) marks1731)) ((and (eq? (car symnames1735) sym1729) (same-marks?1108 marks1731 (list-ref (ribcage-marks1097 ribcage1733) i1736))) (values (list-ref (ribcage-labels1098 ribcage1733) i1736) marks1731)) (else (f1734 (cdr symnames1735) (fx+1055 i1736 1))))))) (search1713 (lambda (sym1737 subst1738 marks1739) (if (null? subst1738) (values #f marks1739) (let ((fst1740 (car subst1738))) (if (eq? fst1740 (quote shift)) (search1713 sym1737 (cdr subst1738) (cdr marks1739)) (let ((symnames1741 (ribcage-symnames1096 fst1740))) (if (vector? symnames1741) (search-vector-rib1715 sym1737 subst1738 marks1739 symnames1741 fst1740) (search-list-rib1714 sym1737 subst1738 marks1739 symnames1741 fst1740))))))))) (cond ((symbol? id1711) (or (call-with-values (lambda () (search1713 id1711 (wrap-subst1091 w1712) (wrap-marks1090 w1712))) (lambda (x1743 . ignore1742) x1743)) id1711)) ((syntax-object?1071 id1711) (let ((id1744 (let ((e1746 (syntax-object-expression1072 id1711))) (if (annotation? e1746) (annotation-expression e1746) e1746))) (w11745 (syntax-object-wrap1073 id1711))) (let ((marks1747 (join-marks1107 (wrap-marks1090 w1712) (wrap-marks1090 w11745)))) (call-with-values (lambda () (search1713 id1744 (wrap-subst1091 w1712) marks1747)) (lambda (new-id1748 marks1749) (or new-id1748 (call-with-values (lambda () (search1713 id1744 (wrap-subst1091 w11745) marks1749)) (lambda (x1751 . ignore1750) x1751)) id1744)))))) ((annotation? id1711) (let ((id1752 (let ((e1753 id1711)) (if (annotation? e1753) (annotation-expression e1753) e1753)))) (or (call-with-values (lambda () (search1713 id1752 (wrap-subst1091 w1712) (wrap-marks1090 w1712))) (lambda (x1755 . ignore1754) x1755)) id1752))) (else (error-hook1061 (quote id-var-name) "invalid id" id1711)))))) (same-marks?1108 (lambda (x1756 y1757) (or (eq? x1756 y1757) (and (not (null? x1756)) (not (null? y1757)) (eq? (car x1756) (car y1757)) (same-marks?1108 (cdr x1756) (cdr y1757)))))) (join-marks1107 (lambda (m11758 m21759) (smart-append1105 m11758 m21759))) (join-wraps1106 (lambda (w11760 w21761) (let ((m11762 (wrap-marks1090 w11760)) (s11763 (wrap-subst1091 w11760))) (if (null? m11762) (if (null? s11763) w21761 (make-wrap1089 (wrap-marks1090 w21761) (smart-append1105 s11763 (wrap-subst1091 w21761)))) (make-wrap1089 (smart-append1105 m11762 (wrap-marks1090 w21761)) (smart-append1105 s11763 (wrap-subst1091 w21761))))))) (smart-append1105 (lambda (m11764 m21765) (if (null? m21765) m11764 (append m11764 m21765)))) (make-binding-wrap1104 (lambda (ids1766 labels1767 w1768) (if (null? ids1766) w1768 (make-wrap1089 (wrap-marks1090 w1768) (cons (let ((labelvec1769 (list->vector labels1767))) (let ((n1770 (vector-length labelvec1769))) (let ((symnamevec1771 (make-vector n1770)) (marksvec1772 (make-vector n1770))) (begin (let f1773 ((ids1774 ids1766) (i1775 0)) (if (not (null? ids1774)) (call-with-values (lambda () (id-sym-name&marks1088 (car ids1774) w1768)) (lambda (symname1776 marks1777) (begin (vector-set! symnamevec1771 i1775 symname1776) (vector-set! marksvec1772 i1775 marks1777) (f1773 (cdr ids1774) (fx+1055 i1775 1))))))) (make-ribcage1094 symnamevec1771 marksvec1772 labelvec1769))))) (wrap-subst1091 w1768)))))) (extend-ribcage!1103 (lambda (ribcage1778 id1779 label1780) (begin (set-ribcage-symnames!1099 ribcage1778 (cons (let ((e1781 (syntax-object-expression1072 id1779))) (if (annotation? e1781) (annotation-expression e1781) e1781)) (ribcage-symnames1096 ribcage1778))) (set-ribcage-marks!1100 ribcage1778 (cons (wrap-marks1090 (syntax-object-wrap1073 id1779)) (ribcage-marks1097 ribcage1778))) (set-ribcage-labels!1101 ribcage1778 (cons label1780 (ribcage-labels1098 ribcage1778)))))) (anti-mark1102 (lambda (w1782) (make-wrap1089 (cons #f (wrap-marks1090 w1782)) (cons (quote shift) (wrap-subst1091 w1782))))) (set-ribcage-labels!1101 (lambda (x1783 update1784) (vector-set! x1783 3 update1784))) (set-ribcage-marks!1100 (lambda (x1785 update1786) (vector-set! x1785 2 update1786))) (set-ribcage-symnames!1099 (lambda (x1787 update1788) (vector-set! x1787 1 update1788))) (ribcage-labels1098 (lambda (x1789) (vector-ref x1789 3))) (ribcage-marks1097 (lambda (x1790) (vector-ref x1790 2))) (ribcage-symnames1096 (lambda (x1791) (vector-ref x1791 1))) (ribcage?1095 (lambda (x1792) (and (vector? x1792) (= (vector-length x1792) 4) (eq? (vector-ref x1792 0) (quote ribcage))))) (make-ribcage1094 (lambda (symnames1793 marks1794 labels1795) (vector (quote ribcage) symnames1793 marks1794 labels1795))) (gen-labels1093 (lambda (ls1796) (if (null? ls1796) (quote ()) (cons (gen-label1092) (gen-labels1093 (cdr ls1796)))))) (gen-label1092 (lambda () (string #\i))) (wrap-subst1091 cdr) (wrap-marks1090 car) (make-wrap1089 cons) (id-sym-name&marks1088 (lambda (x1797 w1798) (if (syntax-object?1071 x1797) (values (let ((e1799 (syntax-object-expression1072 x1797))) (if (annotation? e1799) (annotation-expression e1799) e1799)) (join-marks1107 (wrap-marks1090 w1798) (wrap-marks1090 (syntax-object-wrap1073 x1797)))) (values (let ((e1800 x1797)) (if (annotation? e1800) (annotation-expression e1800) e1800)) (wrap-marks1090 w1798))))) (id?1087 (lambda (x1801) (cond ((symbol? x1801) #t) ((syntax-object?1071 x1801) (symbol? (let ((e1802 (syntax-object-expression1072 x1801))) (if (annotation? e1802) (annotation-expression e1802) e1802)))) ((annotation? x1801) (symbol? (annotation-expression x1801))) (else #f)))) (nonsymbol-id?1086 (lambda (x1803) (and (syntax-object?1071 x1803) (symbol? (let ((e1804 (syntax-object-expression1072 x1803))) (if (annotation? e1804) (annotation-expression e1804) e1804)))))) (global-extend1085 (lambda (type1805 sym1806 val1807) (put-global-definition-hook1062 sym1806 type1805 val1807))) (lookup1084 (lambda (x1808 r1809 mod1810) (cond ((assq x1808 r1809) => cdr) ((symbol? x1808) (or (get-global-definition-hook1063 x1808 mod1810) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1083 (lambda (r1811) (if (null? r1811) (quote ()) (let ((a1812 (car r1811))) (if (eq? (cadr a1812) (quote macro)) (cons a1812 (macros-only-env1083 (cdr r1811))) (macros-only-env1083 (cdr r1811))))))) (extend-var-env1082 (lambda (labels1813 vars1814 r1815) (if (null? labels1813) r1815 (extend-var-env1082 (cdr labels1813) (cdr vars1814) (cons (cons (car labels1813) (cons (quote lexical) (car vars1814))) r1815))))) (extend-env1081 (lambda (labels1816 bindings1817 r1818) (if (null? labels1816) r1818 (extend-env1081 (cdr labels1816) (cdr bindings1817) (cons (cons (car labels1816) (car bindings1817)) r1818))))) (binding-value1080 cdr) (binding-type1079 car) (source-annotation1078 (lambda (x1819) (cond ((annotation? x1819) (annotation-source x1819)) ((syntax-object?1071 x1819) (source-annotation1078 (syntax-object-expression1072 x1819))) (else #f)))) (set-syntax-object-module!1077 (lambda (x1820 update1821) (vector-set! x1820 3 update1821))) (set-syntax-object-wrap!1076 (lambda (x1822 update1823) (vector-set! x1822 2 update1823))) (set-syntax-object-expression!1075 (lambda (x1824 update1825) (vector-set! x1824 1 update1825))) (syntax-object-module1074 (lambda (x1826) (vector-ref x1826 3))) (syntax-object-wrap1073 (lambda (x1827) (vector-ref x1827 2))) (syntax-object-expression1072 (lambda (x1828) (vector-ref x1828 1))) (syntax-object?1071 (lambda (x1829) (and (vector? x1829) (= (vector-length x1829) 4) (eq? (vector-ref x1829 0) (quote syntax-object))))) (make-syntax-object1070 (lambda (expression1830 wrap1831 module1832) (vector (quote syntax-object) expression1830 wrap1831 module1832))) (build-letrec1069 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1064 src1833 body-exp1836) (build-annotated1064 src1833 (list (quote letrec) (map list vars1834 val-exps1835) body-exp1836))))) (build-named-let1068 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1064 src1837 body-exp1840) (build-annotated1064 src1837 (list (quote let) (car vars1838) (map list (cdr vars1838) val-exps1839) body-exp1840))))) (build-let1067 (lambda (src1841 vars1842 val-exps1843 body-exp1844) (if (null? vars1842) (build-annotated1064 src1841 body-exp1844) (build-annotated1064 src1841 (list (quote let) (map list vars1842 val-exps1843) body-exp1844))))) (build-sequence1066 (lambda (src1845 exps1846) (if (null? (cdr exps1846)) (build-annotated1064 src1845 (car exps1846)) (build-annotated1064 src1845 (cons (quote begin) exps1846))))) (build-data1065 (lambda (src1847 exp1848) (if (and (self-evaluating? exp1848) (not (vector? exp1848))) (build-annotated1064 src1847 exp1848) (build-annotated1064 src1847 (list (quote quote) exp1848))))) (build-annotated1064 (lambda (src1849 exp1850) (if (and src1849 (not (annotation? exp1850))) (make-annotation exp1850 src1849 #t) exp1850))) (get-global-definition-hook1063 (lambda (symbol1851 module1852) (begin (if (and (not module1852) (current-module)) (warn "module system is booted, we should have a module" symbol1851)) (let ((v1853 (module-variable (if module1852 (resolve-module (cdr module1852)) (current-module)) symbol1851))) (and v1853 (variable-bound? v1853) (let ((val1854 (variable-ref v1853))) (and (macro? val1854) (syncase-macro-type val1854) (cons (syncase-macro-type val1854) (syncase-macro-binding val1854))))))))) (put-global-definition-hook1062 (lambda (symbol1855 type1856 val1857) (let ((existing1858 (let ((v1859 (module-variable (current-module) symbol1855))) (and v1859 (variable-bound? v1859) (let ((val1860 (variable-ref v1859))) (and (macro? val1860) (not (syncase-macro-type val1860)) val1860)))))) (module-define! (current-module) symbol1855 (if existing1858 (make-extended-syncase-macro existing1858 type1856 val1857) (make-syncase-macro type1856 val1857)))))) (error-hook1061 (lambda (who1861 why1862 what1863) (error who1861 "~a ~s" why1862 what1863))) (local-eval-hook1060 (lambda (x1864 mod1865) (primitive-eval (list noexpand1054 x1864)))) (top-level-eval-hook1059 (lambda (x1866 mod1867) (primitive-eval (list noexpand1054 x1866)))) (fx<1058 <) (fx=1057 =) (fx-1056 -) (fx+1055 +) (noexpand1054 "noexpand")) (begin (global-extend1085 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1085 (quote local-syntax) (quote let-syntax) #f) (global-extend1085 (quote core) (quote fluid-let-syntax) (lambda (e1868 r1869 w1870 s1871 mod1872) ((lambda (tmp1873) ((lambda (tmp1874) (if (if tmp1874 (apply (lambda (_1875 var1876 val1877 e11878 e21879) (valid-bound-ids?1112 var1876)) tmp1874) #f) (apply (lambda (_1881 var1882 val1883 e11884 e21885) (let ((names1886 (map (lambda (x1887) (id-var-name1109 x1887 w1870)) var1882))) (begin (for-each (lambda (id1889 n1890) (let ((t1891 (binding-type1079 (lookup1084 n1890 r1869 mod1872)))) (if (memv t1891 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1868 (source-wrap1116 id1889 w1870 s1871 mod1872))))) var1882 names1886) (chi-body1127 (cons e11884 e21885) (source-wrap1116 e1868 w1870 s1871 mod1872) (extend-env1081 names1886 (let ((trans-r1894 (macros-only-env1083 r1869))) (map (lambda (x1895) (cons (quote macro) (eval-local-transformer1130 (chi1123 x1895 trans-r1894 w1870 mod1872) mod1872))) val1883)) r1869) w1870 mod1872)))) tmp1874) ((lambda (_1897) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1116 e1868 w1870 s1871 mod1872))) tmp1873))) ($sc-dispatch tmp1873 (quote (any #(each (any any)) any . each-any))))) e1868))) (global-extend1085 (quote core) (quote quote) (lambda (e1898 r1899 w1900 s1901 mod1902) ((lambda (tmp1903) ((lambda (tmp1904) (if tmp1904 (apply (lambda (_1905 e1906) (build-data1065 s1901 (strip1134 e1906 w1900))) tmp1904) ((lambda (_1907) (syntax-violation (quote quote) "bad syntax" (source-wrap1116 e1898 w1900 s1901 mod1902))) tmp1903))) ($sc-dispatch tmp1903 (quote (any any))))) e1898))) (global-extend1085 (quote core) (quote syntax) (letrec ((regen1915 (lambda (x1916) (let ((t1917 (car x1916))) (if (memv t1917 (quote (ref))) (build-annotated1064 #f (cadr x1916)) (if (memv t1917 (quote (primitive))) (build-annotated1064 #f (cadr x1916)) (if (memv t1917 (quote (quote))) (build-data1065 #f (cadr x1916)) (if (memv t1917 (quote (lambda))) (build-annotated1064 #f (list (quote lambda) (cadr x1916) (regen1915 (caddr x1916)))) (if (memv t1917 (quote (map))) (let ((ls1918 (map regen1915 (cdr x1916)))) (build-annotated1064 #f (cons (if (fx=1057 (length ls1918) 2) (build-annotated1064 #f (quote map)) (build-annotated1064 #f (quote map))) ls1918))) (build-annotated1064 #f (cons (build-annotated1064 #f (car x1916)) (map regen1915 (cdr x1916)))))))))))) (gen-vector1914 (lambda (x1919) (cond ((eq? (car x1919) (quote list)) (cons (quote vector) (cdr x1919))) ((eq? (car x1919) (quote quote)) (list (quote quote) (list->vector (cadr x1919)))) (else (list (quote list->vector) x1919))))) (gen-append1913 (lambda (x1920 y1921) (if (equal? y1921 (quote (quote ()))) x1920 (list (quote append) x1920 y1921)))) (gen-cons1912 (lambda (x1922 y1923) (let ((t1924 (car y1923))) (if (memv t1924 (quote (quote))) (if (eq? (car x1922) (quote quote)) (list (quote quote) (cons (cadr x1922) (cadr y1923))) (if (eq? (cadr y1923) (quote ())) (list (quote list) x1922) (list (quote cons) x1922 y1923))) (if (memv t1924 (quote (list))) (cons (quote list) (cons x1922 (cdr y1923))) (list (quote cons) x1922 y1923)))))) (gen-map1911 (lambda (e1925 map-env1926) (let ((formals1927 (map cdr map-env1926)) (actuals1928 (map (lambda (x1929) (list (quote ref) (car x1929))) map-env1926))) (cond ((eq? (car e1925) (quote ref)) (car actuals1928)) ((and-map (lambda (x1930) (and (eq? (car x1930) (quote ref)) (memq (cadr x1930) formals1927))) (cdr e1925)) (cons (quote map) (cons (list (quote primitive) (car e1925)) (map (let ((r1931 (map cons formals1927 actuals1928))) (lambda (x1932) (cdr (assq (cadr x1932) r1931)))) (cdr e1925))))) (else (cons (quote map) (cons (list (quote lambda) formals1927 e1925) actuals1928))))))) (gen-mappend1910 (lambda (e1933 map-env1934) (list (quote apply) (quote (primitive append)) (gen-map1911 e1933 map-env1934)))) (gen-ref1909 (lambda (src1935 var1936 level1937 maps1938) (if (fx=1057 level1937 0) (values var1936 maps1938) (if (null? maps1938) (syntax-violation (quote syntax) "missing ellipsis" src1935) (call-with-values (lambda () (gen-ref1909 src1935 var1936 (fx-1056 level1937 1) (cdr maps1938))) (lambda (outer-var1939 outer-maps1940) (let ((b1941 (assq outer-var1939 (car maps1938)))) (if b1941 (values (cdr b1941) maps1938) (let ((inner-var1942 (gen-var1135 (quote tmp)))) (values inner-var1942 (cons (cons (cons outer-var1939 inner-var1942) (car maps1938)) outer-maps1940))))))))))) (gen-syntax1908 (lambda (src1943 e1944 r1945 maps1946 ellipsis?1947 mod1948) (if (id?1087 e1944) (let ((label1949 (id-var-name1109 e1944 (quote (()))))) (let ((b1950 (lookup1084 label1949 r1945 mod1948))) (if (eq? (binding-type1079 b1950) (quote syntax)) (call-with-values (lambda () (let ((var.lev1951 (binding-value1080 b1950))) (gen-ref1909 src1943 (car var.lev1951) (cdr var.lev1951) maps1946))) (lambda (var1952 maps1953) (values (list (quote ref) var1952) maps1953))) (if (ellipsis?1947 e1944) (syntax-violation (quote syntax) "misplaced ellipsis" src1943) (values (list (quote quote) e1944) maps1946))))) ((lambda (tmp1954) ((lambda (tmp1955) (if (if tmp1955 (apply (lambda (dots1956 e1957) (ellipsis?1947 dots1956)) tmp1955) #f) (apply (lambda (dots1958 e1959) (gen-syntax1908 src1943 e1959 r1945 maps1946 (lambda (x1960) #f) mod1948)) tmp1955) ((lambda (tmp1961) (if (if tmp1961 (apply (lambda (x1962 dots1963 y1964) (ellipsis?1947 dots1963)) tmp1961) #f) (apply (lambda (x1965 dots1966 y1967) (let f1968 ((y1969 y1967) (k1970 (lambda (maps1971) (call-with-values (lambda () (gen-syntax1908 src1943 x1965 r1945 (cons (quote ()) maps1971) ellipsis?1947 mod1948)) (lambda (x1972 maps1973) (if (null? (car maps1973)) (syntax-violation (quote syntax) "extra ellipsis" src1943) (values (gen-map1911 x1972 (car maps1973)) (cdr maps1973)))))))) ((lambda (tmp1974) ((lambda (tmp1975) (if (if tmp1975 (apply (lambda (dots1976 y1977) (ellipsis?1947 dots1976)) tmp1975) #f) (apply (lambda (dots1978 y1979) (f1968 y1979 (lambda (maps1980) (call-with-values (lambda () (k1970 (cons (quote ()) maps1980))) (lambda (x1981 maps1982) (if (null? (car maps1982)) (syntax-violation (quote syntax) "extra ellipsis" src1943) (values (gen-mappend1910 x1981 (car maps1982)) (cdr maps1982)))))))) tmp1975) ((lambda (_1983) (call-with-values (lambda () (gen-syntax1908 src1943 y1969 r1945 maps1946 ellipsis?1947 mod1948)) (lambda (y1984 maps1985) (call-with-values (lambda () (k1970 maps1985)) (lambda (x1986 maps1987) (values (gen-append1913 x1986 y1984) maps1987)))))) tmp1974))) ($sc-dispatch tmp1974 (quote (any . any))))) y1969))) tmp1961) ((lambda (tmp1988) (if tmp1988 (apply (lambda (x1989 y1990) (call-with-values (lambda () (gen-syntax1908 src1943 x1989 r1945 maps1946 ellipsis?1947 mod1948)) (lambda (x1991 maps1992) (call-with-values (lambda () (gen-syntax1908 src1943 y1990 r1945 maps1992 ellipsis?1947 mod1948)) (lambda (y1993 maps1994) (values (gen-cons1912 x1991 y1993) maps1994)))))) tmp1988) ((lambda (tmp1995) (if tmp1995 (apply (lambda (e11996 e21997) (call-with-values (lambda () (gen-syntax1908 src1943 (cons e11996 e21997) r1945 maps1946 ellipsis?1947 mod1948)) (lambda (e1999 maps2000) (values (gen-vector1914 e1999) maps2000)))) tmp1995) ((lambda (_2001) (values (list (quote quote) e1944) maps1946)) tmp1954))) ($sc-dispatch tmp1954 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1954 (quote (any . any)))))) ($sc-dispatch tmp1954 (quote (any any . any)))))) ($sc-dispatch tmp1954 (quote (any any))))) e1944))))) (lambda (e2002 r2003 w2004 s2005 mod2006) (let ((e2007 (source-wrap1116 e2002 w2004 s2005 mod2006))) ((lambda (tmp2008) ((lambda (tmp2009) (if tmp2009 (apply (lambda (_2010 x2011) (call-with-values (lambda () (gen-syntax1908 e2007 x2011 r2003 (quote ()) ellipsis?1132 mod2006)) (lambda (e2012 maps2013) (regen1915 e2012)))) tmp2009) ((lambda (_2014) (syntax-violation (quote syntax) "bad `syntax' form" e2007)) tmp2008))) ($sc-dispatch tmp2008 (quote (any any))))) e2007))))) (global-extend1085 (quote core) (quote lambda) (lambda (e2015 r2016 w2017 s2018 mod2019) ((lambda (tmp2020) ((lambda (tmp2021) (if tmp2021 (apply (lambda (_2022 c2023) (chi-lambda-clause1128 (source-wrap1116 e2015 w2017 s2018 mod2019) #f c2023 r2016 w2017 mod2019 (lambda (vars2024 docstring2025 body2026) (build-annotated1064 s2018 (cons (quote lambda) (cons vars2024 (append (if docstring2025 (list docstring2025) (quote ())) (list body2026)))))))) tmp2021) (syntax-violation #f "source expression failed to match any pattern" tmp2020))) ($sc-dispatch tmp2020 (quote (any . any))))) e2015))) (global-extend1085 (quote core) (quote let) (letrec ((chi-let2027 (lambda (e2028 r2029 w2030 s2031 mod2032 constructor2033 ids2034 vals2035 exps2036) (if (not (valid-bound-ids?1112 ids2034)) (syntax-violation (quote let) "duplicate bound variable" e2028) (let ((labels2037 (gen-labels1093 ids2034)) (new-vars2038 (map gen-var1135 ids2034))) (let ((nw2039 (make-binding-wrap1104 ids2034 labels2037 w2030)) (nr2040 (extend-var-env1082 labels2037 new-vars2038 r2029))) (constructor2033 s2031 new-vars2038 (map (lambda (x2041) (chi1123 x2041 r2029 w2030 mod2032)) vals2035) (chi-body1127 exps2036 (source-wrap1116 e2028 nw2039 s2031 mod2032) nr2040 nw2039 mod2032)))))))) (lambda (e2042 r2043 w2044 s2045 mod2046) ((lambda (tmp2047) ((lambda (tmp2048) (if tmp2048 (apply (lambda (_2049 id2050 val2051 e12052 e22053) (chi-let2027 e2042 r2043 w2044 s2045 mod2046 build-let1067 id2050 val2051 (cons e12052 e22053))) tmp2048) ((lambda (tmp2057) (if (if tmp2057 (apply (lambda (_2058 f2059 id2060 val2061 e12062 e22063) (id?1087 f2059)) tmp2057) #f) (apply (lambda (_2064 f2065 id2066 val2067 e12068 e22069) (chi-let2027 e2042 r2043 w2044 s2045 mod2046 build-named-let1068 (cons f2065 id2066) val2067 (cons e12068 e22069))) tmp2057) ((lambda (_2073) (syntax-violation (quote let) "bad let" (source-wrap1116 e2042 w2044 s2045 mod2046))) tmp2047))) ($sc-dispatch tmp2047 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2047 (quote (any #(each (any any)) any . each-any))))) e2042)))) (global-extend1085 (quote core) (quote letrec) (lambda (e2074 r2075 w2076 s2077 mod2078) ((lambda (tmp2079) ((lambda (tmp2080) (if tmp2080 (apply (lambda (_2081 id2082 val2083 e12084 e22085) (let ((ids2086 id2082)) (if (not (valid-bound-ids?1112 ids2086)) (syntax-violation (quote letrec) "duplicate bound variable" e2074) (let ((labels2088 (gen-labels1093 ids2086)) (new-vars2089 (map gen-var1135 ids2086))) (let ((w2090 (make-binding-wrap1104 ids2086 labels2088 w2076)) (r2091 (extend-var-env1082 labels2088 new-vars2089 r2075))) (build-letrec1069 s2077 new-vars2089 (map (lambda (x2092) (chi1123 x2092 r2091 w2090 mod2078)) val2083) (chi-body1127 (cons e12084 e22085) (source-wrap1116 e2074 w2090 s2077 mod2078) r2091 w2090 mod2078))))))) tmp2080) ((lambda (_2095) (syntax-violation (quote letrec) "bad letrec" (source-wrap1116 e2074 w2076 s2077 mod2078))) tmp2079))) ($sc-dispatch tmp2079 (quote (any #(each (any any)) any . each-any))))) e2074))) (global-extend1085 (quote core) (quote set!) (lambda (e2096 r2097 w2098 s2099 mod2100) ((lambda (tmp2101) ((lambda (tmp2102) (if (if tmp2102 (apply (lambda (_2103 id2104 val2105) (id?1087 id2104)) tmp2102) #f) (apply (lambda (_2106 id2107 val2108) (let ((val2109 (chi1123 val2108 r2097 w2098 mod2100)) (n2110 (id-var-name1109 id2107 w2098))) (let ((b2111 (lookup1084 n2110 r2097 mod2100))) (let ((t2112 (binding-type1079 b2111))) (if (memv t2112 (quote (lexical))) (build-annotated1064 s2099 (list (quote set!) (binding-value1080 b2111) val2109)) (if (memv t2112 (quote (global))) (build-annotated1064 s2099 (list (quote set!) (if mod2100 (make-module-ref (cdr mod2100) n2110 (car mod2100)) (make-module-ref mod2100 n2110 (quote bare))) val2109)) (if (memv t2112 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1115 id2107 w2098 mod2100)) (syntax-violation (quote set!) "bad set!" (source-wrap1116 e2096 w2098 s2099 mod2100))))))))) tmp2102) ((lambda (tmp2113) (if tmp2113 (apply (lambda (_2114 head2115 tail2116 val2117) (call-with-values (lambda () (syntax-type1121 head2115 r2097 (quote (())) #f #f mod2100)) (lambda (type2118 value2119 ee2120 ww2121 ss2122 modmod2123) (let ((t2124 type2118)) (if (memv t2124 (quote (module-ref))) (let ((val2125 (chi1123 val2117 r2097 w2098 mod2100))) (call-with-values (lambda () (value2119 (cons head2115 tail2116))) (lambda (id2127 mod2128) (build-annotated1064 s2099 (list (quote set!) (if mod2128 (make-module-ref (cdr mod2128) id2127 (car mod2128)) (make-module-ref mod2128 id2127 (quote bare))) val2125))))) (build-annotated1064 s2099 (cons (chi1123 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2115) r2097 w2098 mod2100) (map (lambda (e2129) (chi1123 e2129 r2097 w2098 mod2100)) (append tail2116 (list val2117)))))))))) tmp2113) ((lambda (_2131) (syntax-violation (quote set!) "bad set!" (source-wrap1116 e2096 w2098 s2099 mod2100))) tmp2101))) ($sc-dispatch tmp2101 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2101 (quote (any any any))))) e2096))) (global-extend1085 (quote module-ref) (quote @) (lambda (e2132) ((lambda (tmp2133) ((lambda (tmp2134) (if (if tmp2134 (apply (lambda (_2135 mod2136 id2137) (and (and-map id?1087 mod2136) (id?1087 id2137))) tmp2134) #f) (apply (lambda (_2139 mod2140 id2141) (values (syntax->datum id2141) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2140)))) tmp2134) (syntax-violation #f "source expression failed to match any pattern" tmp2133))) ($sc-dispatch tmp2133 (quote (any each-any any))))) e2132))) (global-extend1085 (quote module-ref) (quote @@) (lambda (e2143) ((lambda (tmp2144) ((lambda (tmp2145) (if (if tmp2145 (apply (lambda (_2146 mod2147 id2148) (and (and-map id?1087 mod2147) (id?1087 id2148))) tmp2145) #f) (apply (lambda (_2150 mod2151 id2152) (values (syntax->datum id2152) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2151)))) tmp2145) (syntax-violation #f "source expression failed to match any pattern" tmp2144))) ($sc-dispatch tmp2144 (quote (any each-any any))))) e2143))) (global-extend1085 (quote begin) (quote begin) (quote ())) (global-extend1085 (quote define) (quote define) (quote ())) (global-extend1085 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1085 (quote eval-when) (quote eval-when) (quote ())) (global-extend1085 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2157 (lambda (x2158 keys2159 clauses2160 r2161 mod2162) (if (null? clauses2160) (build-annotated1064 #f (list (build-annotated1064 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2158)) ((lambda (tmp2163) ((lambda (tmp2164) (if tmp2164 (apply (lambda (pat2165 exp2166) (if (and (id?1087 pat2165) (and-map (lambda (x2167) (not (free-id=?1110 pat2165 x2167))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2159))) (let ((labels2168 (list (gen-label1092))) (var2169 (gen-var1135 pat2165))) (build-annotated1064 #f (list (build-annotated1064 #f (list (quote lambda) (list var2169) (chi1123 exp2166 (extend-env1081 labels2168 (list (cons (quote syntax) (cons var2169 0))) r2161) (make-binding-wrap1104 (list pat2165) labels2168 (quote (()))) mod2162))) x2158))) (gen-clause2156 x2158 keys2159 (cdr clauses2160) r2161 pat2165 #t exp2166 mod2162))) tmp2164) ((lambda (tmp2170) (if tmp2170 (apply (lambda (pat2171 fender2172 exp2173) (gen-clause2156 x2158 keys2159 (cdr clauses2160) r2161 pat2171 fender2172 exp2173 mod2162)) tmp2170) ((lambda (_2174) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2160))) tmp2163))) ($sc-dispatch tmp2163 (quote (any any any)))))) ($sc-dispatch tmp2163 (quote (any any))))) (car clauses2160))))) (gen-clause2156 (lambda (x2175 keys2176 clauses2177 r2178 pat2179 fender2180 exp2181 mod2182) (call-with-values (lambda () (convert-pattern2154 pat2179 keys2176)) (lambda (p2183 pvars2184) (cond ((not (distinct-bound-ids?1113 (map car pvars2184))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2179)) ((not (and-map (lambda (x2185) (not (ellipsis?1132 (car x2185)))) pvars2184)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2179)) (else (let ((y2186 (gen-var1135 (quote tmp)))) (build-annotated1064 #f (list (build-annotated1064 #f (list (quote lambda) (list y2186) (let ((y2187 (build-annotated1064 #f y2186))) (build-annotated1064 #f (list (quote if) ((lambda (tmp2188) ((lambda (tmp2189) (if tmp2189 (apply (lambda () y2187) tmp2189) ((lambda (_2190) (build-annotated1064 #f (list (quote if) y2187 (build-dispatch-call2155 pvars2184 fender2180 y2187 r2178 mod2182) (build-data1065 #f #f)))) tmp2188))) ($sc-dispatch tmp2188 (quote #(atom #t))))) fender2180) (build-dispatch-call2155 pvars2184 exp2181 y2187 r2178 mod2182) (gen-syntax-case2157 x2175 keys2176 clauses2177 r2178 mod2182)))))) (if (eq? p2183 (quote any)) (build-annotated1064 #f (list (build-annotated1064 #f (quote list)) x2175)) (build-annotated1064 #f (list (build-annotated1064 #f (quote $sc-dispatch)) x2175 (build-data1065 #f p2183))))))))))))) (build-dispatch-call2155 (lambda (pvars2191 exp2192 y2193 r2194 mod2195) (let ((ids2196 (map car pvars2191)) (levels2197 (map cdr pvars2191))) (let ((labels2198 (gen-labels1093 ids2196)) (new-vars2199 (map gen-var1135 ids2196))) (build-annotated1064 #f (list (build-annotated1064 #f (quote apply)) (build-annotated1064 #f (list (quote lambda) new-vars2199 (chi1123 exp2192 (extend-env1081 labels2198 (map (lambda (var2200 level2201) (cons (quote syntax) (cons var2200 level2201))) new-vars2199 (map cdr pvars2191)) r2194) (make-binding-wrap1104 ids2196 labels2198 (quote (()))) mod2195))) y2193)))))) (convert-pattern2154 (lambda (pattern2202 keys2203) (let cvt2204 ((p2205 pattern2202) (n2206 0) (ids2207 (quote ()))) (if (id?1087 p2205) (if (bound-id-member?1114 p2205 keys2203) (values (vector (quote free-id) p2205) ids2207) (values (quote any) (cons (cons p2205 n2206) ids2207))) ((lambda (tmp2208) ((lambda (tmp2209) (if (if tmp2209 (apply (lambda (x2210 dots2211) (ellipsis?1132 dots2211)) tmp2209) #f) (apply (lambda (x2212 dots2213) (call-with-values (lambda () (cvt2204 x2212 (fx+1055 n2206 1) ids2207)) (lambda (p2214 ids2215) (values (if (eq? p2214 (quote any)) (quote each-any) (vector (quote each) p2214)) ids2215)))) tmp2209) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217 y2218) (call-with-values (lambda () (cvt2204 y2218 n2206 ids2207)) (lambda (y2219 ids2220) (call-with-values (lambda () (cvt2204 x2217 n2206 ids2220)) (lambda (x2221 ids2222) (values (cons x2221 y2219) ids2222)))))) tmp2216) ((lambda (tmp2223) (if tmp2223 (apply (lambda () (values (quote ()) ids2207)) tmp2223) ((lambda (tmp2224) (if tmp2224 (apply (lambda (x2225) (call-with-values (lambda () (cvt2204 x2225 n2206 ids2207)) (lambda (p2227 ids2228) (values (vector (quote vector) p2227) ids2228)))) tmp2224) ((lambda (x2229) (values (vector (quote atom) (strip1134 p2205 (quote (())))) ids2207)) tmp2208))) ($sc-dispatch tmp2208 (quote #(vector each-any)))))) ($sc-dispatch tmp2208 (quote ()))))) ($sc-dispatch tmp2208 (quote (any . any)))))) ($sc-dispatch tmp2208 (quote (any any))))) p2205)))))) (lambda (e2230 r2231 w2232 s2233 mod2234) (let ((e2235 (source-wrap1116 e2230 w2232 s2233 mod2234))) ((lambda (tmp2236) ((lambda (tmp2237) (if tmp2237 (apply (lambda (_2238 val2239 key2240 m2241) (if (and-map (lambda (x2242) (and (id?1087 x2242) (not (ellipsis?1132 x2242)))) key2240) (let ((x2244 (gen-var1135 (quote tmp)))) (build-annotated1064 s2233 (list (build-annotated1064 #f (list (quote lambda) (list x2244) (gen-syntax-case2157 (build-annotated1064 #f x2244) key2240 m2241 r2231 mod2234))) (chi1123 val2239 r2231 (quote (())) mod2234)))) (syntax-violation (quote syntax-case) "invalid literals list" e2235))) tmp2237) (syntax-violation #f "source expression failed to match any pattern" tmp2236))) ($sc-dispatch tmp2236 (quote (any any each-any . each-any))))) e2235))))) (set! sc-expand (let ((m2247 (quote e)) (esew2248 (quote (eval)))) (lambda (x2249) (if (and (pair? x2249) (equal? (car x2249) noexpand1054)) (cadr x2249) (chi-top1122 x2249 (quote ()) (quote ((top))) m2247 esew2248 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2250 (quote e)) (esew2251 (quote (eval)))) (lambda (x2253 . rest2252) (if (and (pair? x2253) (equal? (car x2253) noexpand1054)) (cadr x2253) (chi-top1122 x2253 (quote ()) (quote ((top))) (if (null? rest2252) m2250 (car rest2252)) (if (or (null? rest2252) (null? (cdr rest2252))) esew2251 (cadr rest2252)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2254) (nonsymbol-id?1086 x2254))) (set! datum->syntax (lambda (id2255 datum2256) (make-syntax-object1070 datum2256 (syntax-object-wrap1073 id2255) #f))) (set! syntax->datum (lambda (x2257) (strip1134 x2257 (quote (()))))) (set! generate-temporaries (lambda (ls2258) (begin (let ((x2259 ls2258)) (if (not (list? x2259)) (error-hook1061 (quote generate-temporaries) "invalid argument" x2259))) (map (lambda (x2260) (wrap1115 (gensym) (quote ((top))) #f)) ls2258)))) (set! free-identifier=? (lambda (x2261 y2262) (begin (let ((x2263 x2261)) (if (not (nonsymbol-id?1086 x2263)) (error-hook1061 (quote free-identifier=?) "invalid argument" x2263))) (let ((x2264 y2262)) (if (not (nonsymbol-id?1086 x2264)) (error-hook1061 (quote free-identifier=?) "invalid argument" x2264))) (free-id=?1110 x2261 y2262)))) (set! bound-identifier=? (lambda (x2265 y2266) (begin (let ((x2267 x2265)) (if (not (nonsymbol-id?1086 x2267)) (error-hook1061 (quote bound-identifier=?) "invalid argument" x2267))) (let ((x2268 y2266)) (if (not (nonsymbol-id?1086 x2268)) (error-hook1061 (quote bound-identifier=?) "invalid argument" x2268))) (bound-id=?1111 x2265 y2266)))) (set! syntax-violation (lambda (who2272 message2271 form2270 . subform2269) (begin (let ((x2273 who2272)) (if (not ((lambda (x2274) (or (not x2274) (string? x2274) (symbol? x2274))) x2273)) (error-hook1061 (quote syntax-violation) "invalid argument" x2273))) (let ((x2275 message2271)) (if (not (string? x2275)) (error-hook1061 (quote syntax-violation) "invalid argument" x2275))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2272 "~a: " "") "~a " (if (null? subform2269) "in ~a" "in subform `~s' of `~s'")) (let ((tail2276 (cons message2271 (map (lambda (x2277) (strip1134 x2277 (quote (())))) (append subform2269 (list form2270)))))) (if who2272 (cons who2272 tail2276) tail2276)) #f)))) (letrec ((match2282 (lambda (e2283 p2284 w2285 r2286 mod2287) (cond ((not r2286) #f) ((eq? p2284 (quote any)) (cons (wrap1115 e2283 w2285 mod2287) r2286)) ((syntax-object?1071 e2283) (match*2281 (let ((e2288 (syntax-object-expression1072 e2283))) (if (annotation? e2288) (annotation-expression e2288) e2288)) p2284 (join-wraps1106 w2285 (syntax-object-wrap1073 e2283)) r2286 (syntax-object-module1074 e2283))) (else (match*2281 (let ((e2289 e2283)) (if (annotation? e2289) (annotation-expression e2289) e2289)) p2284 w2285 r2286 mod2287))))) (match*2281 (lambda (e2290 p2291 w2292 r2293 mod2294) (cond ((null? p2291) (and (null? e2290) r2293)) ((pair? p2291) (and (pair? e2290) (match2282 (car e2290) (car p2291) w2292 (match2282 (cdr e2290) (cdr p2291) w2292 r2293 mod2294) mod2294))) ((eq? p2291 (quote each-any)) (let ((l2295 (match-each-any2279 e2290 w2292 mod2294))) (and l2295 (cons l2295 r2293)))) (else (let ((t2296 (vector-ref p2291 0))) (if (memv t2296 (quote (each))) (if (null? e2290) (match-empty2280 (vector-ref p2291 1) r2293) (let ((l2297 (match-each2278 e2290 (vector-ref p2291 1) w2292 mod2294))) (and l2297 (let collect2298 ((l2299 l2297)) (if (null? (car l2299)) r2293 (cons (map car l2299) (collect2298 (map cdr l2299)))))))) (if (memv t2296 (quote (free-id))) (and (id?1087 e2290) (free-id=?1110 (wrap1115 e2290 w2292 mod2294) (vector-ref p2291 1)) r2293) (if (memv t2296 (quote (atom))) (and (equal? (vector-ref p2291 1) (strip1134 e2290 w2292)) r2293) (if (memv t2296 (quote (vector))) (and (vector? e2290) (match2282 (vector->list e2290) (vector-ref p2291 1) w2292 r2293 mod2294))))))))))) (match-empty2280 (lambda (p2300 r2301) (cond ((null? p2300) r2301) ((eq? p2300 (quote any)) (cons (quote ()) r2301)) ((pair? p2300) (match-empty2280 (car p2300) (match-empty2280 (cdr p2300) r2301))) ((eq? p2300 (quote each-any)) (cons (quote ()) r2301)) (else (let ((t2302 (vector-ref p2300 0))) (if (memv t2302 (quote (each))) (match-empty2280 (vector-ref p2300 1) r2301) (if (memv t2302 (quote (free-id atom))) r2301 (if (memv t2302 (quote (vector))) (match-empty2280 (vector-ref p2300 1) r2301))))))))) (match-each-any2279 (lambda (e2303 w2304 mod2305) (cond ((annotation? e2303) (match-each-any2279 (annotation-expression e2303) w2304 mod2305)) ((pair? e2303) (let ((l2306 (match-each-any2279 (cdr e2303) w2304 mod2305))) (and l2306 (cons (wrap1115 (car e2303) w2304 mod2305) l2306)))) ((null? e2303) (quote ())) ((syntax-object?1071 e2303) (match-each-any2279 (syntax-object-expression1072 e2303) (join-wraps1106 w2304 (syntax-object-wrap1073 e2303)) mod2305)) (else #f)))) (match-each2278 (lambda (e2307 p2308 w2309 mod2310) (cond ((annotation? e2307) (match-each2278 (annotation-expression e2307) p2308 w2309 mod2310)) ((pair? e2307) (let ((first2311 (match2282 (car e2307) p2308 w2309 (quote ()) mod2310))) (and first2311 (let ((rest2312 (match-each2278 (cdr e2307) p2308 w2309 mod2310))) (and rest2312 (cons first2311 rest2312)))))) ((null? e2307) (quote ())) ((syntax-object?1071 e2307) (match-each2278 (syntax-object-expression1072 e2307) p2308 (join-wraps1106 w2309 (syntax-object-wrap1073 e2307)) (syntax-object-module1074 e2307))) (else #f))))) (set! $sc-dispatch (lambda (e2313 p2314) (cond ((eq? p2314 (quote any)) (list e2313)) ((syntax-object?1071 e2313) (match*2281 (let ((e2315 (syntax-object-expression1072 e2313))) (if (annotation? e2315) (annotation-expression e2315) e2315)) p2314 (syntax-object-wrap1073 e2313) (quote ()) (syntax-object-module1074 e2313))) (else (match*2281 (let ((e2316 e2313)) (if (annotation? e2316) (annotation-expression e2316) e2316)) p2314 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2317) ((lambda (tmp2318) ((lambda (tmp2319) (if tmp2319 (apply (lambda (_2320 e12321 e22322) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12321 e22322))) tmp2319) ((lambda (tmp2324) (if tmp2324 (apply (lambda (_2325 out2326 in2327 e12328 e22329) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2327 (quote ()) (list out2326 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12328 e22329))))) tmp2324) ((lambda (tmp2331) (if tmp2331 (apply (lambda (_2332 out2333 in2334 e12335 e22336) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2334) (quote ()) (list out2333 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12335 e22336))))) tmp2331) (syntax-violation #f "source expression failed to match any pattern" tmp2318))) ($sc-dispatch tmp2318 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2318 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2318 (quote (any () any . each-any))))) x2317)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2340) ((lambda (tmp2341) ((lambda (tmp2342) (if tmp2342 (apply (lambda (_2343 k2344 keyword2345 pattern2346 template2347) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2344 (map (lambda (tmp2350 tmp2349) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2349) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2350))) template2347 pattern2346)))))) tmp2342) (syntax-violation #f "source expression failed to match any pattern" tmp2341))) ($sc-dispatch tmp2341 (quote (any each-any . #(each ((any . any) any))))))) x2340)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2351) ((lambda (tmp2352) ((lambda (tmp2353) (if (if tmp2353 (apply (lambda (let*2354 x2355 v2356 e12357 e22358) (and-map identifier? x2355)) tmp2353) #f) (apply (lambda (let*2360 x2361 v2362 e12363 e22364) (let f2365 ((bindings2366 (map list x2361 v2362))) (if (null? bindings2366) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12363 e22364))) ((lambda (tmp2370) ((lambda (tmp2371) (if tmp2371 (apply (lambda (body2372 binding2373) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2373) body2372)) tmp2371) (syntax-violation #f "source expression failed to match any pattern" tmp2370))) ($sc-dispatch tmp2370 (quote (any any))))) (list (f2365 (cdr bindings2366)) (car bindings2366)))))) tmp2353) (syntax-violation #f "source expression failed to match any pattern" tmp2352))) ($sc-dispatch tmp2352 (quote (any #(each (any any)) any . each-any))))) x2351)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2374) ((lambda (tmp2375) ((lambda (tmp2376) (if tmp2376 (apply (lambda (_2377 var2378 init2379 step2380 e02381 e12382 c2383) ((lambda (tmp2384) ((lambda (tmp2385) (if tmp2385 (apply (lambda (step2386) ((lambda (tmp2387) ((lambda (tmp2388) (if tmp2388 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2378 init2379) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02381) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2383 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2386))))))) tmp2388) ((lambda (tmp2393) (if tmp2393 (apply (lambda (e12394 e22395) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2378 init2379) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02381 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12394 e22395)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2383 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2386))))))) tmp2393) (syntax-violation #f "source expression failed to match any pattern" tmp2387))) ($sc-dispatch tmp2387 (quote (any . each-any)))))) ($sc-dispatch tmp2387 (quote ())))) e12382)) tmp2385) (syntax-violation #f "source expression failed to match any pattern" tmp2384))) ($sc-dispatch tmp2384 (quote each-any)))) (map (lambda (v2402 s2403) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda () v2402) tmp2405) ((lambda (tmp2406) (if tmp2406 (apply (lambda (e2407) e2407) tmp2406) ((lambda (_2408) (syntax-violation (quote do) "bad step expression" orig-x2374 s2403)) tmp2404))) ($sc-dispatch tmp2404 (quote (any)))))) ($sc-dispatch tmp2404 (quote ())))) s2403)) var2378 step2380))) tmp2376) (syntax-violation #f "source expression failed to match any pattern" tmp2375))) ($sc-dispatch tmp2375 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2374)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2411 (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (x2419 y2420) ((lambda (tmp2421) ((lambda (tmp2422) (if tmp2422 (apply (lambda (dy2423) ((lambda (tmp2424) ((lambda (tmp2425) (if tmp2425 (apply (lambda (dx2426) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2426 dy2423))) tmp2425) ((lambda (_2427) (if (null? dy2423) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2419) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2419 y2420))) tmp2424))) ($sc-dispatch tmp2424 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2419)) tmp2422) ((lambda (tmp2428) (if tmp2428 (apply (lambda (stuff2429) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2419 stuff2429))) tmp2428) ((lambda (else2430) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2419 y2420)) tmp2421))) ($sc-dispatch tmp2421 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2421 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2420)) tmp2418) (syntax-violation #f "source expression failed to match any pattern" tmp2417))) ($sc-dispatch tmp2417 (quote (any any))))) (list x2415 y2416)))) (quasiappend2412 (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda (x2435 y2436) ((lambda (tmp2437) ((lambda (tmp2438) (if tmp2438 (apply (lambda () x2435) tmp2438) ((lambda (_2439) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2435 y2436)) tmp2437))) ($sc-dispatch tmp2437 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2436)) tmp2434) (syntax-violation #f "source expression failed to match any pattern" tmp2433))) ($sc-dispatch tmp2433 (quote (any any))))) (list x2431 y2432)))) (quasivector2413 (lambda (x2440) ((lambda (tmp2441) ((lambda (x2442) ((lambda (tmp2443) ((lambda (tmp2444) (if tmp2444 (apply (lambda (x2445) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2445))) tmp2444) ((lambda (tmp2447) (if tmp2447 (apply (lambda (x2448) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448)) tmp2447) ((lambda (_2450) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2442)) tmp2443))) ($sc-dispatch tmp2443 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2443 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2442)) tmp2441)) x2440))) (quasi2414 (lambda (p2451 lev2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (p2455) (if (= lev2452 0) p2455 (quasicons2411 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2414 (list p2455) (- lev2452 1))))) tmp2454) ((lambda (tmp2456) (if tmp2456 (apply (lambda (p2457 q2458) (if (= lev2452 0) (quasiappend2412 p2457 (quasi2414 q2458 lev2452)) (quasicons2411 (quasicons2411 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2414 (list p2457) (- lev2452 1))) (quasi2414 q2458 lev2452)))) tmp2456) ((lambda (tmp2459) (if tmp2459 (apply (lambda (p2460) (quasicons2411 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2414 (list p2460) (+ lev2452 1)))) tmp2459) ((lambda (tmp2461) (if tmp2461 (apply (lambda (p2462 q2463) (quasicons2411 (quasi2414 p2462 lev2452) (quasi2414 q2463 lev2452))) tmp2461) ((lambda (tmp2464) (if tmp2464 (apply (lambda (x2465) (quasivector2413 (quasi2414 x2465 lev2452))) tmp2464) ((lambda (p2467) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2467)) tmp2453))) ($sc-dispatch tmp2453 (quote #(vector each-any)))))) ($sc-dispatch tmp2453 (quote (any . any)))))) ($sc-dispatch tmp2453 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2453 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2453 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2451)))) (lambda (x2468) ((lambda (tmp2469) ((lambda (tmp2470) (if tmp2470 (apply (lambda (_2471 e2472) (quasi2414 e2472 0)) tmp2470) (syntax-violation #f "source expression failed to match any pattern" tmp2469))) ($sc-dispatch tmp2469 (quote (any any))))) x2468))))) +(define include (make-syncase-macro (quote macro) (lambda (x2473) (letrec ((read-file2474 (lambda (fn2475 k2476) (let ((p2477 (open-input-file fn2475))) (let f2478 ((x2479 (read p2477))) (if (eof-object? x2479) (begin (close-input-port p2477) (quote ())) (cons (datum->syntax k2476 x2479) (f2478 (read p2477))))))))) ((lambda (tmp2480) ((lambda (tmp2481) (if tmp2481 (apply (lambda (k2482 filename2483) (let ((fn2484 (syntax->datum filename2483))) ((lambda (tmp2485) ((lambda (tmp2486) (if tmp2486 (apply (lambda (exp2487) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2487)) tmp2486) (syntax-violation #f "source expression failed to match any pattern" tmp2485))) ($sc-dispatch tmp2485 (quote each-any)))) (read-file2474 fn2484 k2482)))) tmp2481) (syntax-violation #f "source expression failed to match any pattern" tmp2480))) ($sc-dispatch tmp2480 (quote (any any))))) x2473))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2489) ((lambda (tmp2490) ((lambda (tmp2491) (if tmp2491 (apply (lambda (_2492 e2493) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2493))) tmp2491) (syntax-violation #f "source expression failed to match any pattern" tmp2490))) ($sc-dispatch tmp2490 (quote (any any))))) x2489)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2494) ((lambda (tmp2495) ((lambda (tmp2496) (if tmp2496 (apply (lambda (_2497 e2498) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2498))) tmp2496) (syntax-violation #f "source expression failed to match any pattern" tmp2495))) ($sc-dispatch tmp2495 (quote (any any))))) x2494)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2499) ((lambda (tmp2500) ((lambda (tmp2501) (if tmp2501 (apply (lambda (_2502 e2503 m12504 m22505) ((lambda (tmp2506) ((lambda (body2507) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2503)) body2507)) tmp2506)) (let f2508 ((clause2509 m12504) (clauses2510 m22505)) (if (null? clauses2510) ((lambda (tmp2512) ((lambda (tmp2513) (if tmp2513 (apply (lambda (e12514 e22515) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12514 e22515))) tmp2513) ((lambda (tmp2517) (if tmp2517 (apply (lambda (k2518 e12519 e22520) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2518)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12519 e22520)))) tmp2517) ((lambda (_2523) (syntax-violation (quote case) "bad clause" x2499 clause2509)) tmp2512))) ($sc-dispatch tmp2512 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2512 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2509) ((lambda (tmp2524) ((lambda (rest2525) ((lambda (tmp2526) ((lambda (tmp2527) (if tmp2527 (apply (lambda (k2528 e12529 e22530) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2528)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12529 e22530)) rest2525)) tmp2527) ((lambda (_2533) (syntax-violation (quote case) "bad clause" x2499 clause2509)) tmp2526))) ($sc-dispatch tmp2526 (quote (each-any any . each-any))))) clause2509)) tmp2524)) (f2508 (car clauses2510) (cdr clauses2510))))))) tmp2501) (syntax-violation #f "source expression failed to match any pattern" tmp2500))) ($sc-dispatch tmp2500 (quote (any any any . each-any))))) x2499)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2534) ((lambda (tmp2535) ((lambda (tmp2536) (if tmp2536 (apply (lambda (_2537 e2538) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2538)) (list (cons _2537 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2538 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2536) (syntax-violation #f "source expression failed to match any pattern" tmp2535))) ($sc-dispatch tmp2535 (quote (any any))))) x2534)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 9033a6034..7ddb4e393 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -91,29 +91,6 @@ ;;; returns the implementation's cannonical "unspecified value". This ;;; usually works: (define void (lambda () (if #f #f))). ;;; -;;; (andmap proc list1 list2 ...) -;;; returns true if proc returns true when applied to each element of list1 -;;; along with the corresponding elements of list2 .... -;;; The following definition works but does no error checking: -;;; -;;; (define andmap -;;; (lambda (f first . rest) -;;; (or (null? first) -;;; (if (null? rest) -;;; (let andmap ((first first)) -;;; (let ((x (car first)) (first (cdr first))) -;;; (if (null? first) -;;; (f x) -;;; (and (f x) (andmap first))))) -;;; (let andmap ((first first) (rest rest)) -;;; (let ((x (car first)) -;;; (xr (map car rest)) -;;; (first (cdr first)) -;;; (rest (map cdr rest))) -;;; (if (null? first) -;;; (apply f (cons x xr)) -;;; (and (apply f (cons x xr)) (andmap first rest))))))))) -;;; ;;; The following nonstandard procedures must also be provided by the ;;; implementation for this code to run using the standard portable ;;; hooks and output constructors. They are not used by expanded code, @@ -258,6 +235,25 @@ (set-current-module (resolve-module '(guile)))) (let () +;;; Private version of and-map that handles multiple lists. +(define and-map* + (lambda (f first . rest) + (or (null? first) + (if (null? rest) + (let andmap ((first first)) + (let ((x (car first)) (first (cdr first))) + (if (null? first) + (f x) + (and (f x) (andmap first))))) + (let andmap ((first first) (rest rest)) + (let ((x (car first)) + (xr (map car rest)) + (first (cdr first)) + (rest (map cdr rest))) + (if (null? first) + (apply f (cons x xr)) + (and (apply f (cons x xr)) (andmap first rest))))))))) + (define-syntax define-structure (lambda (x) (define construct-name @@ -273,7 +269,9 @@ args)))))) (syntax-case x () ((_ (name id1 ...)) - (andmap identifier? (syntax (name id1 ...))) + ;; But here we use and-map, because andmap isn't yet in scope for + ;; syntax. + (and-map identifier? (syntax (name id1 ...))) (with-syntax ((constructor (construct-name (syntax name) "make-" (syntax name))) (predicate (construct-name (syntax name) (syntax name) "?")) @@ -1499,7 +1497,7 @@ ((vector? x) (let ((old (vector->list x))) (let ((new (map f old))) - (if (andmap eq? old new) x (list->vector new))))) + (if (and-map* eq? old new) x (list->vector new))))) (else x)))))) ;;; lexical variables @@ -1673,7 +1671,7 @@ ; identity map equivalence: ; (map (lambda (x) x) y) == y (car actuals)) - ((andmap + ((and-map (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (cdr e)) ; eta map equivalence: @@ -1835,7 +1833,7 @@ (lambda (e) (syntax-case e () ((_ (mod ...) id) - (and (andmap id? (syntax (mod ...))) (id? (syntax id))) + (and (and-map id? (syntax (mod ...))) (id? (syntax id))) (values (syntax->datum (syntax id)) (syntax->datum (syntax (public mod ...)))))))) @@ -1844,7 +1842,7 @@ (lambda (e) (syntax-case e () ((_ (mod ...) id) - (and (andmap id? (syntax (mod ...))) (id? (syntax id))) + (and (and-map id? (syntax (mod ...))) (id? (syntax id))) (values (syntax->datum (syntax id)) (syntax->datum (syntax (private mod ...)))))))) @@ -1918,7 +1916,7 @@ (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-violation 'syntax-case "duplicate pattern variable" pat)) - ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars)) + ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars)) (syntax-violation 'syntax-case "misplaced ellipsis" pat)) (else (let ((y (gen-var 'tmp))) @@ -1952,8 +1950,8 @@ (syntax-case (car clauses) () ((pat exp) (if (and (id? (syntax pat)) - (andmap (lambda (x) (not (free-id=? (syntax pat) x))) - (cons (syntax (... ...)) keys))) + (and-map (lambda (x) (not (free-id=? (syntax pat) x))) + (cons (syntax (... ...)) keys))) (let ((labels (list (gen-label))) (var (gen-var (syntax pat)))) (build-application no-source @@ -1978,8 +1976,8 @@ (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ val (key ...) m ...) - (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) - (syntax (key ...))) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) + (syntax (key ...))) (let ((x (gen-var 'tmp))) ; fat finger binding and references to temp variable x (build-application s @@ -2216,7 +2214,7 @@ (lambda (x) (syntax-case x () ((let* ((x v) ...) e1 e2 ...) - (andmap identifier? (syntax (x ...))) + (and-map identifier? (syntax (x ...))) (let f ((bindings (syntax ((x v) ...)))) (if (null? bindings) (syntax (let () e1 e2 ...)) From 6a952e0ee9093424cdc8f300406d09ce195ebf5c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 23:39:09 +0200 Subject: [PATCH 089/375] more cleanups to boot-9/psyntax * module/ice-9/boot-9.scm: Comment some more things. * module/ice-9/psyntax.scm: Remove error-hook -- callers should just use syntax-violation. Change all callers. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/boot-9.scm | 23 +++++++++++++--------- module/ice-9/psyntax-pp.scm | 22 ++++++++++----------- module/ice-9/psyntax.scm | 39 +++++++++++++------------------------ 3 files changed, 39 insertions(+), 45 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index d375e84d0..18c716033 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -186,6 +186,9 @@ (define (resolve-module . args) #f) +;; Output hook for syncase. It's here because we want to be able to +;; replace its definition, for compiling; but that isn't implemented +;; yet. (define (make-module-ref mod var kind) (case kind ((public) (if mod `(@ ,mod ,var) var)) @@ -200,7 +203,12 @@ var)) (else (error "foo" mod var kind)))) -;;; API provided by psyntax +;; Input hook to syncase -- so that we might be able to pass annotated +;; expressions in. Currently disabled. Maybe we should just use +;; source-properties directly. +(define (annotation? x) #f) + +;; API provided by psyntax (define syntax-violation #f) (define datum->syntax #f) (define syntax->datum #f) @@ -211,24 +219,21 @@ (define sc-expand #f) (define sc-expand3 #f) -;;; Implementation detail of psyntax -- the thing that does expand-time -;;; dispatch for syntax-case macros +;; $sc-expand is an implementation detail of psyntax. It is used by +;; expanded macros, to dispatch an input against a set of patterns. (define $sc-dispatch #f) -;;; Useless crap I'd like to get rid of -(define (annotation? x) #f) - +;; Load it up! (primitive-load-path "ice-9/psyntax-pp") -;; Until the module system is booted, this will be the current expander. +;; %pre-modules-transformer is the Scheme expander from now until the +;; module system has booted up. (define %pre-modules-transformer sc-expand) ;;; {Defmacros} ;;; -;;; Depends on: features, eval-case -;;; (define-syntax define-macro (lambda (x) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 8783a53d5..ba204275c 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((and-map*1002 (lambda (f1042 first1041 . rest1040) (or (null? first1041) (if (null? rest1040) (let andmap1043 ((first1044 first1041)) (let ((x1045 (car first1044)) (first1046 (cdr first1044))) (if (null? first1046) (f1042 x1045) (and (f1042 x1045) (andmap1043 first1046))))) (let andmap1047 ((first1048 first1041) (rest1049 rest1040)) (let ((x1050 (car first1048)) (xr1051 (map car rest1049)) (first1052 (cdr first1048)) (rest1053 (map cdr rest1049))) (if (null? first1052) (apply f1042 (cons x1050 xr1051)) (and (apply f1042 (cons x1050 xr1051)) (andmap1047 first1052 rest1053)))))))))) (letrec ((lambda-var-list1136 (lambda (vars1341) (let lvl1342 ((vars1343 vars1341) (ls1344 (quote ())) (w1345 (quote (())))) (cond ((pair? vars1343) (lvl1342 (cdr vars1343) (cons (wrap1115 (car vars1343) w1345 #f) ls1344) w1345)) ((id?1087 vars1343) (cons (wrap1115 vars1343 w1345 #f) ls1344)) ((null? vars1343) ls1344) ((syntax-object?1071 vars1343) (lvl1342 (syntax-object-expression1072 vars1343) ls1344 (join-wraps1106 w1345 (syntax-object-wrap1073 vars1343)))) ((annotation? vars1343) (lvl1342 (annotation-expression vars1343) ls1344 w1345)) (else (cons vars1343 ls1344)))))) (gen-var1135 (lambda (id1346) (let ((id1347 (if (syntax-object?1071 id1346) (syntax-object-expression1072 id1346) id1346))) (if (annotation? id1347) (build-annotated1064 (annotation-source id1347) (gensym (symbol->string (annotation-expression id1347)))) (build-annotated1064 #f (gensym (symbol->string id1347))))))) (strip1134 (lambda (x1348 w1349) (if (memq (quote top) (wrap-marks1090 w1349)) (if (or (annotation? x1348) (and (pair? x1348) (annotation? (car x1348)))) (strip-annotation1133 x1348 #f) x1348) (let f1350 ((x1351 x1348)) (cond ((syntax-object?1071 x1351) (strip1134 (syntax-object-expression1072 x1351) (syntax-object-wrap1073 x1351))) ((pair? x1351) (let ((a1352 (f1350 (car x1351))) (d1353 (f1350 (cdr x1351)))) (if (and (eq? a1352 (car x1351)) (eq? d1353 (cdr x1351))) x1351 (cons a1352 d1353)))) ((vector? x1351) (let ((old1354 (vector->list x1351))) (let ((new1355 (map f1350 old1354))) (if (and-map*1002 eq? old1354 new1355) x1351 (list->vector new1355))))) (else x1351)))))) (strip-annotation1133 (lambda (x1356 parent1357) (cond ((pair? x1356) (let ((new1358 (cons #f #f))) (begin (if parent1357 (set-annotation-stripped! parent1357 new1358)) (set-car! new1358 (strip-annotation1133 (car x1356) #f)) (set-cdr! new1358 (strip-annotation1133 (cdr x1356) #f)) new1358))) ((annotation? x1356) (or (annotation-stripped x1356) (strip-annotation1133 (annotation-expression x1356) x1356))) ((vector? x1356) (let ((new1359 (make-vector (vector-length x1356)))) (begin (if parent1357 (set-annotation-stripped! parent1357 new1359)) (let loop1360 ((i1361 (- (vector-length x1356) 1))) (unless (fx<1058 i1361 0) (vector-set! new1359 i1361 (strip-annotation1133 (vector-ref x1356 i1361) #f)) (loop1360 (fx-1056 i1361 1)))) new1359))) (else x1356)))) (ellipsis?1132 (lambda (x1362) (and (nonsymbol-id?1086 x1362) (free-id=?1110 x1362 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1131 (lambda () (build-annotated1064 #f (list (build-annotated1064 #f (quote void)))))) (eval-local-transformer1130 (lambda (expanded1363 mod1364) (let ((p1365 (local-eval-hook1060 expanded1363 mod1364))) (if (procedure? p1365) p1365 (syntax-violation #f "nonprocedure transformer" p1365))))) (chi-local-syntax1129 (lambda (rec?1366 e1367 r1368 w1369 s1370 mod1371 k1372) ((lambda (tmp1373) ((lambda (tmp1374) (if tmp1374 (apply (lambda (_1375 id1376 val1377 e11378 e21379) (let ((ids1380 id1376)) (if (not (valid-bound-ids?1112 ids1380)) (syntax-violation #f "duplicate bound keyword" e1367) (let ((labels1382 (gen-labels1093 ids1380))) (let ((new-w1383 (make-binding-wrap1104 ids1380 labels1382 w1369))) (k1372 (cons e11378 e21379) (extend-env1081 labels1382 (let ((w1385 (if rec?1366 new-w1383 w1369)) (trans-r1386 (macros-only-env1083 r1368))) (map (lambda (x1387) (cons (quote macro) (eval-local-transformer1130 (chi1123 x1387 trans-r1386 w1385 mod1371) mod1371))) val1377)) r1368) new-w1383 s1370 mod1371)))))) tmp1374) ((lambda (_1389) (syntax-violation #f "bad local syntax definition" (source-wrap1116 e1367 w1369 s1370 mod1371))) tmp1373))) ($sc-dispatch tmp1373 (quote (any #(each (any any)) any . each-any))))) e1367))) (chi-lambda-clause1128 (lambda (e1390 docstring1391 c1392 r1393 w1394 mod1395 k1396) ((lambda (tmp1397) ((lambda (tmp1398) (if (if tmp1398 (apply (lambda (args1399 doc1400 e11401 e21402) (and (string? (syntax->datum doc1400)) (not docstring1391))) tmp1398) #f) (apply (lambda (args1403 doc1404 e11405 e21406) (chi-lambda-clause1128 e1390 doc1404 (cons args1403 (cons e11405 e21406)) r1393 w1394 mod1395 k1396)) tmp1398) ((lambda (tmp1408) (if tmp1408 (apply (lambda (id1409 e11410 e21411) (let ((ids1412 id1409)) (if (not (valid-bound-ids?1112 ids1412)) (syntax-violation (quote lambda) "invalid parameter list" e1390) (let ((labels1414 (gen-labels1093 ids1412)) (new-vars1415 (map gen-var1135 ids1412))) (k1396 new-vars1415 docstring1391 (chi-body1127 (cons e11410 e21411) e1390 (extend-var-env1082 labels1414 new-vars1415 r1393) (make-binding-wrap1104 ids1412 labels1414 w1394) mod1395)))))) tmp1408) ((lambda (tmp1417) (if tmp1417 (apply (lambda (ids1418 e11419 e21420) (let ((old-ids1421 (lambda-var-list1136 ids1418))) (if (not (valid-bound-ids?1112 old-ids1421)) (syntax-violation (quote lambda) "invalid parameter list" e1390) (let ((labels1422 (gen-labels1093 old-ids1421)) (new-vars1423 (map gen-var1135 old-ids1421))) (k1396 (let f1424 ((ls11425 (cdr new-vars1423)) (ls21426 (car new-vars1423))) (if (null? ls11425) ls21426 (f1424 (cdr ls11425) (cons (car ls11425) ls21426)))) docstring1391 (chi-body1127 (cons e11419 e21420) e1390 (extend-var-env1082 labels1422 new-vars1423 r1393) (make-binding-wrap1104 old-ids1421 labels1422 w1394) mod1395)))))) tmp1417) ((lambda (_1428) (syntax-violation (quote lambda) "bad lambda" e1390)) tmp1397))) ($sc-dispatch tmp1397 (quote (any any . each-any)))))) ($sc-dispatch tmp1397 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1397 (quote (any any any . each-any))))) c1392))) (chi-body1127 (lambda (body1429 outer-form1430 r1431 w1432 mod1433) (let ((r1434 (cons (quote ("placeholder" placeholder)) r1431))) (let ((ribcage1435 (make-ribcage1094 (quote ()) (quote ()) (quote ())))) (let ((w1436 (make-wrap1089 (wrap-marks1090 w1432) (cons ribcage1435 (wrap-subst1091 w1432))))) (let parse1437 ((body1438 (map (lambda (x1444) (cons r1434 (wrap1115 x1444 w1436 mod1433))) body1429)) (ids1439 (quote ())) (labels1440 (quote ())) (vars1441 (quote ())) (vals1442 (quote ())) (bindings1443 (quote ()))) (if (null? body1438) (syntax-violation #f "no expressions in body" outer-form1430) (let ((e1445 (cdar body1438)) (er1446 (caar body1438))) (call-with-values (lambda () (syntax-type1121 e1445 er1446 (quote (())) #f ribcage1435 mod1433)) (lambda (type1447 value1448 e1449 w1450 s1451 mod1452) (let ((t1453 type1447)) (if (memv t1453 (quote (define-form))) (let ((id1454 (wrap1115 value1448 w1450 mod1452)) (label1455 (gen-label1092))) (let ((var1456 (gen-var1135 id1454))) (begin (extend-ribcage!1103 ribcage1435 id1454 label1455) (parse1437 (cdr body1438) (cons id1454 ids1439) (cons label1455 labels1440) (cons var1456 vars1441) (cons (cons er1446 (wrap1115 e1449 w1450 mod1452)) vals1442) (cons (cons (quote lexical) var1456) bindings1443))))) (if (memv t1453 (quote (define-syntax-form))) (let ((id1457 (wrap1115 value1448 w1450 mod1452)) (label1458 (gen-label1092))) (begin (extend-ribcage!1103 ribcage1435 id1457 label1458) (parse1437 (cdr body1438) (cons id1457 ids1439) (cons label1458 labels1440) vars1441 vals1442 (cons (cons (quote macro) (cons er1446 (wrap1115 e1449 w1450 mod1452))) bindings1443)))) (if (memv t1453 (quote (begin-form))) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (_1461 e11462) (parse1437 (let f1463 ((forms1464 e11462)) (if (null? forms1464) (cdr body1438) (cons (cons er1446 (wrap1115 (car forms1464) w1450 mod1452)) (f1463 (cdr forms1464))))) ids1439 labels1440 vars1441 vals1442 bindings1443)) tmp1460) (syntax-violation #f "source expression failed to match any pattern" tmp1459))) ($sc-dispatch tmp1459 (quote (any . each-any))))) e1449) (if (memv t1453 (quote (local-syntax-form))) (chi-local-syntax1129 value1448 e1449 er1446 w1450 s1451 mod1452 (lambda (forms1466 er1467 w1468 s1469 mod1470) (parse1437 (let f1471 ((forms1472 forms1466)) (if (null? forms1472) (cdr body1438) (cons (cons er1467 (wrap1115 (car forms1472) w1468 mod1470)) (f1471 (cdr forms1472))))) ids1439 labels1440 vars1441 vals1442 bindings1443))) (if (null? ids1439) (build-sequence1066 #f (map (lambda (x1473) (chi1123 (cdr x1473) (car x1473) (quote (())) mod1452)) (cons (cons er1446 (source-wrap1116 e1449 w1450 s1451 mod1452)) (cdr body1438)))) (begin (if (not (valid-bound-ids?1112 ids1439)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1430)) (let loop1474 ((bs1475 bindings1443) (er-cache1476 #f) (r-cache1477 #f)) (if (not (null? bs1475)) (let ((b1478 (car bs1475))) (if (eq? (car b1478) (quote macro)) (let ((er1479 (cadr b1478))) (let ((r-cache1480 (if (eq? er1479 er-cache1476) r-cache1477 (macros-only-env1083 er1479)))) (begin (set-cdr! b1478 (eval-local-transformer1130 (chi1123 (cddr b1478) r-cache1480 (quote (())) mod1452) mod1452)) (loop1474 (cdr bs1475) er1479 r-cache1480)))) (loop1474 (cdr bs1475) er-cache1476 r-cache1477))))) (set-cdr! r1434 (extend-env1081 labels1440 bindings1443 (cdr r1434))) (build-letrec1069 #f vars1441 (map (lambda (x1481) (chi1123 (cdr x1481) (car x1481) (quote (())) mod1452)) vals1442) (build-sequence1066 #f (map (lambda (x1482) (chi1123 (cdr x1482) (car x1482) (quote (())) mod1452)) (cons (cons er1446 (source-wrap1116 e1449 w1450 s1451 mod1452)) (cdr body1438)))))))))))))))))))))) (chi-macro1126 (lambda (p1483 e1484 r1485 w1486 rib1487 mod1488) (letrec ((rebuild-macro-output1489 (lambda (x1490 m1491) (cond ((pair? x1490) (cons (rebuild-macro-output1489 (car x1490) m1491) (rebuild-macro-output1489 (cdr x1490) m1491))) ((syntax-object?1071 x1490) (let ((w1492 (syntax-object-wrap1073 x1490))) (let ((ms1493 (wrap-marks1090 w1492)) (s1494 (wrap-subst1091 w1492))) (if (and (pair? ms1493) (eq? (car ms1493) #f)) (make-syntax-object1070 (syntax-object-expression1072 x1490) (make-wrap1089 (cdr ms1493) (if rib1487 (cons rib1487 (cdr s1494)) (cdr s1494))) (syntax-object-module1074 x1490)) (make-syntax-object1070 (syntax-object-expression1072 x1490) (make-wrap1089 (cons m1491 ms1493) (if rib1487 (cons rib1487 (cons (quote shift) s1494)) (cons (quote shift) s1494))) (let ((pmod1495 (procedure-module p1483))) (if pmod1495 (cons (quote hygiene) (module-name pmod1495)) (quote (hygiene guile))))))))) ((vector? x1490) (let ((n1496 (vector-length x1490))) (let ((v1497 (make-vector n1496))) (let doloop1498 ((i1499 0)) (if (fx=1057 i1499 n1496) v1497 (begin (vector-set! v1497 i1499 (rebuild-macro-output1489 (vector-ref x1490 i1499) m1491)) (doloop1498 (fx+1055 i1499 1)))))))) ((symbol? x1490) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1116 e1484 w1486 s mod1488) x1490)) (else x1490))))) (rebuild-macro-output1489 (p1483 (wrap1115 e1484 (anti-mark1102 w1486) mod1488)) (string #\m))))) (chi-application1125 (lambda (x1500 e1501 r1502 w1503 s1504 mod1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (e01508 e11509) (build-annotated1064 s1504 (cons x1500 (map (lambda (e1510) (chi1123 e1510 r1502 w1503 mod1505)) e11509)))) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any . each-any))))) e1501))) (chi-expr1124 (lambda (type1512 value1513 e1514 r1515 w1516 s1517 mod1518) (let ((t1519 type1512)) (if (memv t1519 (quote (lexical))) (build-annotated1064 s1517 value1513) (if (memv t1519 (quote (core external-macro))) (value1513 e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (module-ref))) (call-with-values (lambda () (value1513 e1514)) (lambda (id1520 mod1521) (build-annotated1064 s1517 (if mod1521 (make-module-ref (cdr mod1521) id1520 (car mod1521)) (make-module-ref mod1521 id1520 (quote bare)))))) (if (memv t1519 (quote (lexical-call))) (chi-application1125 (build-annotated1064 (source-annotation1078 (car e1514)) value1513) e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (global-call))) (chi-application1125 (build-annotated1064 (source-annotation1078 (car e1514)) (if (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518) (make-module-ref (cdr (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518)) value1513 (car (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518))) (make-module-ref (if (syntax-object?1071 (car e1514)) (syntax-object-module1074 (car e1514)) mod1518) value1513 (quote bare)))) e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (constant))) (build-data1065 s1517 (strip1134 (source-wrap1116 e1514 w1516 s1517 mod1518) (quote (())))) (if (memv t1519 (quote (global))) (build-annotated1064 s1517 (if mod1518 (make-module-ref (cdr mod1518) value1513 (car mod1518)) (make-module-ref mod1518 value1513 (quote bare)))) (if (memv t1519 (quote (call))) (chi-application1125 (chi1123 (car e1514) r1515 w1516 mod1518) e1514 r1515 w1516 s1517 mod1518) (if (memv t1519 (quote (begin-form))) ((lambda (tmp1522) ((lambda (tmp1523) (if tmp1523 (apply (lambda (_1524 e11525 e21526) (chi-sequence1117 (cons e11525 e21526) r1515 w1516 s1517 mod1518)) tmp1523) (syntax-violation #f "source expression failed to match any pattern" tmp1522))) ($sc-dispatch tmp1522 (quote (any any . each-any))))) e1514) (if (memv t1519 (quote (local-syntax-form))) (chi-local-syntax1129 value1513 e1514 r1515 w1516 s1517 mod1518 chi-sequence1117) (if (memv t1519 (quote (eval-when-form))) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (_1530 x1531 e11532 e21533) (let ((when-list1534 (chi-when-list1120 e1514 x1531 w1516))) (if (memq (quote eval) when-list1534) (chi-sequence1117 (cons e11532 e21533) r1515 w1516 s1517 mod1518) (chi-void1131)))) tmp1529) (syntax-violation #f "source expression failed to match any pattern" tmp1528))) ($sc-dispatch tmp1528 (quote (any each-any any . each-any))))) e1514) (if (memv t1519 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1514 (wrap1115 value1513 w1516 mod1518)) (if (memv t1519 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1116 e1514 w1516 s1517 mod1518)) (if (memv t1519 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1116 e1514 w1516 s1517 mod1518)) (syntax-violation #f "unexpected syntax" (source-wrap1116 e1514 w1516 s1517 mod1518))))))))))))))))))) (chi1123 (lambda (e1537 r1538 w1539 mod1540) (call-with-values (lambda () (syntax-type1121 e1537 r1538 w1539 #f #f mod1540)) (lambda (type1541 value1542 e1543 w1544 s1545 mod1546) (chi-expr1124 type1541 value1542 e1543 r1538 w1544 s1545 mod1546))))) (chi-top1122 (lambda (e1547 r1548 w1549 m1550 esew1551 mod1552) (call-with-values (lambda () (syntax-type1121 e1547 r1548 w1549 #f #f mod1552)) (lambda (type1560 value1561 e1562 w1563 s1564 mod1565) (let ((t1566 type1560)) (if (memv t1566 (quote (begin-form))) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569) (chi-void1131)) tmp1568) ((lambda (tmp1570) (if tmp1570 (apply (lambda (_1571 e11572 e21573) (chi-top-sequence1118 (cons e11572 e21573) r1548 w1563 s1564 m1550 esew1551 mod1565)) tmp1570) (syntax-violation #f "source expression failed to match any pattern" tmp1567))) ($sc-dispatch tmp1567 (quote (any any . each-any)))))) ($sc-dispatch tmp1567 (quote (any))))) e1562) (if (memv t1566 (quote (local-syntax-form))) (chi-local-syntax1129 value1561 e1562 r1548 w1563 s1564 mod1565 (lambda (body1575 r1576 w1577 s1578 mod1579) (chi-top-sequence1118 body1575 r1576 w1577 s1578 m1550 esew1551 mod1579))) (if (memv t1566 (quote (eval-when-form))) ((lambda (tmp1580) ((lambda (tmp1581) (if tmp1581 (apply (lambda (_1582 x1583 e11584 e21585) (let ((when-list1586 (chi-when-list1120 e1562 x1583 w1563)) (body1587 (cons e11584 e21585))) (cond ((eq? m1550 (quote e)) (if (memq (quote eval) when-list1586) (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote e) (quote (eval)) mod1565) (chi-void1131))) ((memq (quote load) when-list1586) (if (or (memq (quote compile) when-list1586) (and (eq? m1550 (quote c&e)) (memq (quote eval) when-list1586))) (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote c&e) (quote (compile load)) mod1565) (if (memq m1550 (quote (c c&e))) (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote c) (quote (load)) mod1565) (chi-void1131)))) ((or (memq (quote compile) when-list1586) (and (eq? m1550 (quote c&e)) (memq (quote eval) when-list1586))) (top-level-eval-hook1059 (chi-top-sequence1118 body1587 r1548 w1563 s1564 (quote e) (quote (eval)) mod1565) mod1565) (chi-void1131)) (else (chi-void1131))))) tmp1581) (syntax-violation #f "source expression failed to match any pattern" tmp1580))) ($sc-dispatch tmp1580 (quote (any each-any any . each-any))))) e1562) (if (memv t1566 (quote (define-syntax-form))) (let ((n1590 (id-var-name1109 value1561 w1563)) (r1591 (macros-only-env1083 r1548))) (let ((t1592 m1550)) (if (memv t1592 (quote (c))) (if (memq (quote compile) esew1551) (let ((e1593 (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)))) (begin (top-level-eval-hook1059 e1593 mod1565) (if (memq (quote load) esew1551) e1593 (chi-void1131)))) (if (memq (quote load) esew1551) (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)) (chi-void1131))) (if (memv t1592 (quote (c&e))) (let ((e1594 (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)))) (begin (top-level-eval-hook1059 e1594 mod1565) e1594)) (begin (if (memq (quote eval) esew1551) (top-level-eval-hook1059 (chi-install-global1119 n1590 (chi1123 e1562 r1591 w1563 mod1565)) mod1565)) (chi-void1131)))))) (if (memv t1566 (quote (define-form))) (let ((n1595 (id-var-name1109 value1561 w1563))) (let ((type1596 (binding-type1079 (lookup1084 n1595 r1548 mod1565)))) (let ((t1597 type1596)) (if (memv t1597 (quote (global core macro module-ref))) (let ((x1598 (build-annotated1064 s1564 (list (quote define) n1595 (chi1123 e1562 r1548 w1563 mod1565))))) (begin (if (eq? m1550 (quote c&e)) (top-level-eval-hook1059 x1598 mod1565)) x1598)) (if (memv t1597 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1562 (wrap1115 value1561 w1563 mod1565)) (syntax-violation #f "cannot define keyword at top level" e1562 (wrap1115 value1561 w1563 mod1565))))))) (let ((x1599 (chi-expr1124 type1560 value1561 e1562 r1548 w1563 s1564 mod1565))) (begin (if (eq? m1550 (quote c&e)) (top-level-eval-hook1059 x1599 mod1565)) x1599)))))))))))) (syntax-type1121 (lambda (e1600 r1601 w1602 s1603 rib1604 mod1605) (cond ((symbol? e1600) (let ((n1606 (id-var-name1109 e1600 w1602))) (let ((b1607 (lookup1084 n1606 r1601 mod1605))) (let ((type1608 (binding-type1079 b1607))) (let ((t1609 type1608)) (if (memv t1609 (quote (lexical))) (values type1608 (binding-value1080 b1607) e1600 w1602 s1603 mod1605) (if (memv t1609 (quote (global))) (values type1608 n1606 e1600 w1602 s1603 mod1605) (if (memv t1609 (quote (macro))) (syntax-type1121 (chi-macro1126 (binding-value1080 b1607) e1600 r1601 w1602 rib1604 mod1605) r1601 (quote (())) s1603 rib1604 mod1605) (values type1608 (binding-value1080 b1607) e1600 w1602 s1603 mod1605))))))))) ((pair? e1600) (let ((first1610 (car e1600))) (if (id?1087 first1610) (let ((n1611 (id-var-name1109 first1610 w1602))) (let ((b1612 (lookup1084 n1611 r1601 (or (and (syntax-object?1071 first1610) (syntax-object-module1074 first1610)) mod1605)))) (let ((type1613 (binding-type1079 b1612))) (let ((t1614 type1613)) (if (memv t1614 (quote (lexical))) (values (quote lexical-call) (binding-value1080 b1612) e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (global))) (values (quote global-call) n1611 e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (macro))) (syntax-type1121 (chi-macro1126 (binding-value1080 b1612) e1600 r1601 w1602 rib1604 mod1605) r1601 (quote (())) s1603 rib1604 mod1605) (if (memv t1614 (quote (core external-macro module-ref))) (values type1613 (binding-value1080 b1612) e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1080 b1612) e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (begin))) (values (quote begin-form) #f e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (eval-when))) (values (quote eval-when-form) #f e1600 w1602 s1603 mod1605) (if (memv t1614 (quote (define))) ((lambda (tmp1615) ((lambda (tmp1616) (if (if tmp1616 (apply (lambda (_1617 name1618 val1619) (id?1087 name1618)) tmp1616) #f) (apply (lambda (_1620 name1621 val1622) (values (quote define-form) name1621 val1622 w1602 s1603 mod1605)) tmp1616) ((lambda (tmp1623) (if (if tmp1623 (apply (lambda (_1624 name1625 args1626 e11627 e21628) (and (id?1087 name1625) (valid-bound-ids?1112 (lambda-var-list1136 args1626)))) tmp1623) #f) (apply (lambda (_1629 name1630 args1631 e11632 e21633) (values (quote define-form) (wrap1115 name1630 w1602 mod1605) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1115 (cons args1631 (cons e11632 e21633)) w1602 mod1605)) (quote (())) s1603 mod1605)) tmp1623) ((lambda (tmp1635) (if (if tmp1635 (apply (lambda (_1636 name1637) (id?1087 name1637)) tmp1635) #f) (apply (lambda (_1638 name1639) (values (quote define-form) (wrap1115 name1639 w1602 mod1605) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1603 mod1605)) tmp1635) (syntax-violation #f "source expression failed to match any pattern" tmp1615))) ($sc-dispatch tmp1615 (quote (any any)))))) ($sc-dispatch tmp1615 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1615 (quote (any any any))))) e1600) (if (memv t1614 (quote (define-syntax))) ((lambda (tmp1640) ((lambda (tmp1641) (if (if tmp1641 (apply (lambda (_1642 name1643 val1644) (id?1087 name1643)) tmp1641) #f) (apply (lambda (_1645 name1646 val1647) (values (quote define-syntax-form) name1646 val1647 w1602 s1603 mod1605)) tmp1641) (syntax-violation #f "source expression failed to match any pattern" tmp1640))) ($sc-dispatch tmp1640 (quote (any any any))))) e1600) (values (quote call) #f e1600 w1602 s1603 mod1605)))))))))))))) (values (quote call) #f e1600 w1602 s1603 mod1605)))) ((syntax-object?1071 e1600) (syntax-type1121 (syntax-object-expression1072 e1600) r1601 (join-wraps1106 w1602 (syntax-object-wrap1073 e1600)) #f rib1604 (or (syntax-object-module1074 e1600) mod1605))) ((annotation? e1600) (syntax-type1121 (annotation-expression e1600) r1601 w1602 (annotation-source e1600) rib1604 mod1605)) ((self-evaluating? e1600) (values (quote constant) #f e1600 w1602 s1603 mod1605)) (else (values (quote other) #f e1600 w1602 s1603 mod1605))))) (chi-when-list1120 (lambda (e1648 when-list1649 w1650) (let f1651 ((when-list1652 when-list1649) (situations1653 (quote ()))) (if (null? when-list1652) situations1653 (f1651 (cdr when-list1652) (cons (let ((x1654 (car when-list1652))) (cond ((free-id=?1110 x1654 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1110 x1654 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1110 x1654 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1648 (wrap1115 x1654 w1650 #f))))) situations1653)))))) (chi-install-global1119 (lambda (name1655 e1656) (build-annotated1064 #f (list (build-annotated1064 #f (quote define)) name1655 (if (let ((v1657 (module-variable (current-module) name1655))) (and v1657 (variable-bound? v1657) (macro? (variable-ref v1657)) (not (eq? (macro-type (variable-ref v1657)) (quote syncase-macro))))) (build-annotated1064 #f (list (build-annotated1064 #f (quote make-extended-syncase-macro)) (build-annotated1064 #f (list (build-annotated1064 #f (quote module-ref)) (build-annotated1064 #f (quote (current-module))) (build-data1065 #f name1655))) (build-data1065 #f (quote macro)) e1656)) (build-annotated1064 #f (list (build-annotated1064 #f (quote make-syncase-macro)) (build-data1065 #f (quote macro)) e1656))))))) (chi-top-sequence1118 (lambda (body1658 r1659 w1660 s1661 m1662 esew1663 mod1664) (build-sequence1066 s1661 (let dobody1665 ((body1666 body1658) (r1667 r1659) (w1668 w1660) (m1669 m1662) (esew1670 esew1663) (mod1671 mod1664)) (if (null? body1666) (quote ()) (let ((first1672 (chi-top1122 (car body1666) r1667 w1668 m1669 esew1670 mod1671))) (cons first1672 (dobody1665 (cdr body1666) r1667 w1668 m1669 esew1670 mod1671)))))))) (chi-sequence1117 (lambda (body1673 r1674 w1675 s1676 mod1677) (build-sequence1066 s1676 (let dobody1678 ((body1679 body1673) (r1680 r1674) (w1681 w1675) (mod1682 mod1677)) (if (null? body1679) (quote ()) (let ((first1683 (chi1123 (car body1679) r1680 w1681 mod1682))) (cons first1683 (dobody1678 (cdr body1679) r1680 w1681 mod1682)))))))) (source-wrap1116 (lambda (x1684 w1685 s1686 defmod1687) (wrap1115 (if s1686 (make-annotation x1684 s1686 #f) x1684) w1685 defmod1687))) (wrap1115 (lambda (x1688 w1689 defmod1690) (cond ((and (null? (wrap-marks1090 w1689)) (null? (wrap-subst1091 w1689))) x1688) ((syntax-object?1071 x1688) (make-syntax-object1070 (syntax-object-expression1072 x1688) (join-wraps1106 w1689 (syntax-object-wrap1073 x1688)) (syntax-object-module1074 x1688))) ((null? x1688) x1688) (else (make-syntax-object1070 x1688 w1689 defmod1690))))) (bound-id-member?1114 (lambda (x1691 list1692) (and (not (null? list1692)) (or (bound-id=?1111 x1691 (car list1692)) (bound-id-member?1114 x1691 (cdr list1692)))))) (distinct-bound-ids?1113 (lambda (ids1693) (let distinct?1694 ((ids1695 ids1693)) (or (null? ids1695) (and (not (bound-id-member?1114 (car ids1695) (cdr ids1695))) (distinct?1694 (cdr ids1695))))))) (valid-bound-ids?1112 (lambda (ids1696) (and (let all-ids?1697 ((ids1698 ids1696)) (or (null? ids1698) (and (id?1087 (car ids1698)) (all-ids?1697 (cdr ids1698))))) (distinct-bound-ids?1113 ids1696)))) (bound-id=?1111 (lambda (i1699 j1700) (if (and (syntax-object?1071 i1699) (syntax-object?1071 j1700)) (and (eq? (let ((e1701 (syntax-object-expression1072 i1699))) (if (annotation? e1701) (annotation-expression e1701) e1701)) (let ((e1702 (syntax-object-expression1072 j1700))) (if (annotation? e1702) (annotation-expression e1702) e1702))) (same-marks?1108 (wrap-marks1090 (syntax-object-wrap1073 i1699)) (wrap-marks1090 (syntax-object-wrap1073 j1700)))) (eq? (let ((e1703 i1699)) (if (annotation? e1703) (annotation-expression e1703) e1703)) (let ((e1704 j1700)) (if (annotation? e1704) (annotation-expression e1704) e1704)))))) (free-id=?1110 (lambda (i1705 j1706) (and (eq? (let ((x1707 i1705)) (let ((e1708 (if (syntax-object?1071 x1707) (syntax-object-expression1072 x1707) x1707))) (if (annotation? e1708) (annotation-expression e1708) e1708))) (let ((x1709 j1706)) (let ((e1710 (if (syntax-object?1071 x1709) (syntax-object-expression1072 x1709) x1709))) (if (annotation? e1710) (annotation-expression e1710) e1710)))) (eq? (id-var-name1109 i1705 (quote (()))) (id-var-name1109 j1706 (quote (()))))))) (id-var-name1109 (lambda (id1711 w1712) (letrec ((search-vector-rib1715 (lambda (sym1721 subst1722 marks1723 symnames1724 ribcage1725) (let ((n1726 (vector-length symnames1724))) (let f1727 ((i1728 0)) (cond ((fx=1057 i1728 n1726) (search1713 sym1721 (cdr subst1722) marks1723)) ((and (eq? (vector-ref symnames1724 i1728) sym1721) (same-marks?1108 marks1723 (vector-ref (ribcage-marks1097 ribcage1725) i1728))) (values (vector-ref (ribcage-labels1098 ribcage1725) i1728) marks1723)) (else (f1727 (fx+1055 i1728 1)))))))) (search-list-rib1714 (lambda (sym1729 subst1730 marks1731 symnames1732 ribcage1733) (let f1734 ((symnames1735 symnames1732) (i1736 0)) (cond ((null? symnames1735) (search1713 sym1729 (cdr subst1730) marks1731)) ((and (eq? (car symnames1735) sym1729) (same-marks?1108 marks1731 (list-ref (ribcage-marks1097 ribcage1733) i1736))) (values (list-ref (ribcage-labels1098 ribcage1733) i1736) marks1731)) (else (f1734 (cdr symnames1735) (fx+1055 i1736 1))))))) (search1713 (lambda (sym1737 subst1738 marks1739) (if (null? subst1738) (values #f marks1739) (let ((fst1740 (car subst1738))) (if (eq? fst1740 (quote shift)) (search1713 sym1737 (cdr subst1738) (cdr marks1739)) (let ((symnames1741 (ribcage-symnames1096 fst1740))) (if (vector? symnames1741) (search-vector-rib1715 sym1737 subst1738 marks1739 symnames1741 fst1740) (search-list-rib1714 sym1737 subst1738 marks1739 symnames1741 fst1740))))))))) (cond ((symbol? id1711) (or (call-with-values (lambda () (search1713 id1711 (wrap-subst1091 w1712) (wrap-marks1090 w1712))) (lambda (x1743 . ignore1742) x1743)) id1711)) ((syntax-object?1071 id1711) (let ((id1744 (let ((e1746 (syntax-object-expression1072 id1711))) (if (annotation? e1746) (annotation-expression e1746) e1746))) (w11745 (syntax-object-wrap1073 id1711))) (let ((marks1747 (join-marks1107 (wrap-marks1090 w1712) (wrap-marks1090 w11745)))) (call-with-values (lambda () (search1713 id1744 (wrap-subst1091 w1712) marks1747)) (lambda (new-id1748 marks1749) (or new-id1748 (call-with-values (lambda () (search1713 id1744 (wrap-subst1091 w11745) marks1749)) (lambda (x1751 . ignore1750) x1751)) id1744)))))) ((annotation? id1711) (let ((id1752 (let ((e1753 id1711)) (if (annotation? e1753) (annotation-expression e1753) e1753)))) (or (call-with-values (lambda () (search1713 id1752 (wrap-subst1091 w1712) (wrap-marks1090 w1712))) (lambda (x1755 . ignore1754) x1755)) id1752))) (else (error-hook1061 (quote id-var-name) "invalid id" id1711)))))) (same-marks?1108 (lambda (x1756 y1757) (or (eq? x1756 y1757) (and (not (null? x1756)) (not (null? y1757)) (eq? (car x1756) (car y1757)) (same-marks?1108 (cdr x1756) (cdr y1757)))))) (join-marks1107 (lambda (m11758 m21759) (smart-append1105 m11758 m21759))) (join-wraps1106 (lambda (w11760 w21761) (let ((m11762 (wrap-marks1090 w11760)) (s11763 (wrap-subst1091 w11760))) (if (null? m11762) (if (null? s11763) w21761 (make-wrap1089 (wrap-marks1090 w21761) (smart-append1105 s11763 (wrap-subst1091 w21761)))) (make-wrap1089 (smart-append1105 m11762 (wrap-marks1090 w21761)) (smart-append1105 s11763 (wrap-subst1091 w21761))))))) (smart-append1105 (lambda (m11764 m21765) (if (null? m21765) m11764 (append m11764 m21765)))) (make-binding-wrap1104 (lambda (ids1766 labels1767 w1768) (if (null? ids1766) w1768 (make-wrap1089 (wrap-marks1090 w1768) (cons (let ((labelvec1769 (list->vector labels1767))) (let ((n1770 (vector-length labelvec1769))) (let ((symnamevec1771 (make-vector n1770)) (marksvec1772 (make-vector n1770))) (begin (let f1773 ((ids1774 ids1766) (i1775 0)) (if (not (null? ids1774)) (call-with-values (lambda () (id-sym-name&marks1088 (car ids1774) w1768)) (lambda (symname1776 marks1777) (begin (vector-set! symnamevec1771 i1775 symname1776) (vector-set! marksvec1772 i1775 marks1777) (f1773 (cdr ids1774) (fx+1055 i1775 1))))))) (make-ribcage1094 symnamevec1771 marksvec1772 labelvec1769))))) (wrap-subst1091 w1768)))))) (extend-ribcage!1103 (lambda (ribcage1778 id1779 label1780) (begin (set-ribcage-symnames!1099 ribcage1778 (cons (let ((e1781 (syntax-object-expression1072 id1779))) (if (annotation? e1781) (annotation-expression e1781) e1781)) (ribcage-symnames1096 ribcage1778))) (set-ribcage-marks!1100 ribcage1778 (cons (wrap-marks1090 (syntax-object-wrap1073 id1779)) (ribcage-marks1097 ribcage1778))) (set-ribcage-labels!1101 ribcage1778 (cons label1780 (ribcage-labels1098 ribcage1778)))))) (anti-mark1102 (lambda (w1782) (make-wrap1089 (cons #f (wrap-marks1090 w1782)) (cons (quote shift) (wrap-subst1091 w1782))))) (set-ribcage-labels!1101 (lambda (x1783 update1784) (vector-set! x1783 3 update1784))) (set-ribcage-marks!1100 (lambda (x1785 update1786) (vector-set! x1785 2 update1786))) (set-ribcage-symnames!1099 (lambda (x1787 update1788) (vector-set! x1787 1 update1788))) (ribcage-labels1098 (lambda (x1789) (vector-ref x1789 3))) (ribcage-marks1097 (lambda (x1790) (vector-ref x1790 2))) (ribcage-symnames1096 (lambda (x1791) (vector-ref x1791 1))) (ribcage?1095 (lambda (x1792) (and (vector? x1792) (= (vector-length x1792) 4) (eq? (vector-ref x1792 0) (quote ribcage))))) (make-ribcage1094 (lambda (symnames1793 marks1794 labels1795) (vector (quote ribcage) symnames1793 marks1794 labels1795))) (gen-labels1093 (lambda (ls1796) (if (null? ls1796) (quote ()) (cons (gen-label1092) (gen-labels1093 (cdr ls1796)))))) (gen-label1092 (lambda () (string #\i))) (wrap-subst1091 cdr) (wrap-marks1090 car) (make-wrap1089 cons) (id-sym-name&marks1088 (lambda (x1797 w1798) (if (syntax-object?1071 x1797) (values (let ((e1799 (syntax-object-expression1072 x1797))) (if (annotation? e1799) (annotation-expression e1799) e1799)) (join-marks1107 (wrap-marks1090 w1798) (wrap-marks1090 (syntax-object-wrap1073 x1797)))) (values (let ((e1800 x1797)) (if (annotation? e1800) (annotation-expression e1800) e1800)) (wrap-marks1090 w1798))))) (id?1087 (lambda (x1801) (cond ((symbol? x1801) #t) ((syntax-object?1071 x1801) (symbol? (let ((e1802 (syntax-object-expression1072 x1801))) (if (annotation? e1802) (annotation-expression e1802) e1802)))) ((annotation? x1801) (symbol? (annotation-expression x1801))) (else #f)))) (nonsymbol-id?1086 (lambda (x1803) (and (syntax-object?1071 x1803) (symbol? (let ((e1804 (syntax-object-expression1072 x1803))) (if (annotation? e1804) (annotation-expression e1804) e1804)))))) (global-extend1085 (lambda (type1805 sym1806 val1807) (put-global-definition-hook1062 sym1806 type1805 val1807))) (lookup1084 (lambda (x1808 r1809 mod1810) (cond ((assq x1808 r1809) => cdr) ((symbol? x1808) (or (get-global-definition-hook1063 x1808 mod1810) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1083 (lambda (r1811) (if (null? r1811) (quote ()) (let ((a1812 (car r1811))) (if (eq? (cadr a1812) (quote macro)) (cons a1812 (macros-only-env1083 (cdr r1811))) (macros-only-env1083 (cdr r1811))))))) (extend-var-env1082 (lambda (labels1813 vars1814 r1815) (if (null? labels1813) r1815 (extend-var-env1082 (cdr labels1813) (cdr vars1814) (cons (cons (car labels1813) (cons (quote lexical) (car vars1814))) r1815))))) (extend-env1081 (lambda (labels1816 bindings1817 r1818) (if (null? labels1816) r1818 (extend-env1081 (cdr labels1816) (cdr bindings1817) (cons (cons (car labels1816) (car bindings1817)) r1818))))) (binding-value1080 cdr) (binding-type1079 car) (source-annotation1078 (lambda (x1819) (cond ((annotation? x1819) (annotation-source x1819)) ((syntax-object?1071 x1819) (source-annotation1078 (syntax-object-expression1072 x1819))) (else #f)))) (set-syntax-object-module!1077 (lambda (x1820 update1821) (vector-set! x1820 3 update1821))) (set-syntax-object-wrap!1076 (lambda (x1822 update1823) (vector-set! x1822 2 update1823))) (set-syntax-object-expression!1075 (lambda (x1824 update1825) (vector-set! x1824 1 update1825))) (syntax-object-module1074 (lambda (x1826) (vector-ref x1826 3))) (syntax-object-wrap1073 (lambda (x1827) (vector-ref x1827 2))) (syntax-object-expression1072 (lambda (x1828) (vector-ref x1828 1))) (syntax-object?1071 (lambda (x1829) (and (vector? x1829) (= (vector-length x1829) 4) (eq? (vector-ref x1829 0) (quote syntax-object))))) (make-syntax-object1070 (lambda (expression1830 wrap1831 module1832) (vector (quote syntax-object) expression1830 wrap1831 module1832))) (build-letrec1069 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1064 src1833 body-exp1836) (build-annotated1064 src1833 (list (quote letrec) (map list vars1834 val-exps1835) body-exp1836))))) (build-named-let1068 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1064 src1837 body-exp1840) (build-annotated1064 src1837 (list (quote let) (car vars1838) (map list (cdr vars1838) val-exps1839) body-exp1840))))) (build-let1067 (lambda (src1841 vars1842 val-exps1843 body-exp1844) (if (null? vars1842) (build-annotated1064 src1841 body-exp1844) (build-annotated1064 src1841 (list (quote let) (map list vars1842 val-exps1843) body-exp1844))))) (build-sequence1066 (lambda (src1845 exps1846) (if (null? (cdr exps1846)) (build-annotated1064 src1845 (car exps1846)) (build-annotated1064 src1845 (cons (quote begin) exps1846))))) (build-data1065 (lambda (src1847 exp1848) (if (and (self-evaluating? exp1848) (not (vector? exp1848))) (build-annotated1064 src1847 exp1848) (build-annotated1064 src1847 (list (quote quote) exp1848))))) (build-annotated1064 (lambda (src1849 exp1850) (if (and src1849 (not (annotation? exp1850))) (make-annotation exp1850 src1849 #t) exp1850))) (get-global-definition-hook1063 (lambda (symbol1851 module1852) (begin (if (and (not module1852) (current-module)) (warn "module system is booted, we should have a module" symbol1851)) (let ((v1853 (module-variable (if module1852 (resolve-module (cdr module1852)) (current-module)) symbol1851))) (and v1853 (variable-bound? v1853) (let ((val1854 (variable-ref v1853))) (and (macro? val1854) (syncase-macro-type val1854) (cons (syncase-macro-type val1854) (syncase-macro-binding val1854))))))))) (put-global-definition-hook1062 (lambda (symbol1855 type1856 val1857) (let ((existing1858 (let ((v1859 (module-variable (current-module) symbol1855))) (and v1859 (variable-bound? v1859) (let ((val1860 (variable-ref v1859))) (and (macro? val1860) (not (syncase-macro-type val1860)) val1860)))))) (module-define! (current-module) symbol1855 (if existing1858 (make-extended-syncase-macro existing1858 type1856 val1857) (make-syncase-macro type1856 val1857)))))) (error-hook1061 (lambda (who1861 why1862 what1863) (error who1861 "~a ~s" why1862 what1863))) (local-eval-hook1060 (lambda (x1864 mod1865) (primitive-eval (list noexpand1054 x1864)))) (top-level-eval-hook1059 (lambda (x1866 mod1867) (primitive-eval (list noexpand1054 x1866)))) (fx<1058 <) (fx=1057 =) (fx-1056 -) (fx+1055 +) (noexpand1054 "noexpand")) (begin (global-extend1085 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1085 (quote local-syntax) (quote let-syntax) #f) (global-extend1085 (quote core) (quote fluid-let-syntax) (lambda (e1868 r1869 w1870 s1871 mod1872) ((lambda (tmp1873) ((lambda (tmp1874) (if (if tmp1874 (apply (lambda (_1875 var1876 val1877 e11878 e21879) (valid-bound-ids?1112 var1876)) tmp1874) #f) (apply (lambda (_1881 var1882 val1883 e11884 e21885) (let ((names1886 (map (lambda (x1887) (id-var-name1109 x1887 w1870)) var1882))) (begin (for-each (lambda (id1889 n1890) (let ((t1891 (binding-type1079 (lookup1084 n1890 r1869 mod1872)))) (if (memv t1891 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1868 (source-wrap1116 id1889 w1870 s1871 mod1872))))) var1882 names1886) (chi-body1127 (cons e11884 e21885) (source-wrap1116 e1868 w1870 s1871 mod1872) (extend-env1081 names1886 (let ((trans-r1894 (macros-only-env1083 r1869))) (map (lambda (x1895) (cons (quote macro) (eval-local-transformer1130 (chi1123 x1895 trans-r1894 w1870 mod1872) mod1872))) val1883)) r1869) w1870 mod1872)))) tmp1874) ((lambda (_1897) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1116 e1868 w1870 s1871 mod1872))) tmp1873))) ($sc-dispatch tmp1873 (quote (any #(each (any any)) any . each-any))))) e1868))) (global-extend1085 (quote core) (quote quote) (lambda (e1898 r1899 w1900 s1901 mod1902) ((lambda (tmp1903) ((lambda (tmp1904) (if tmp1904 (apply (lambda (_1905 e1906) (build-data1065 s1901 (strip1134 e1906 w1900))) tmp1904) ((lambda (_1907) (syntax-violation (quote quote) "bad syntax" (source-wrap1116 e1898 w1900 s1901 mod1902))) tmp1903))) ($sc-dispatch tmp1903 (quote (any any))))) e1898))) (global-extend1085 (quote core) (quote syntax) (letrec ((regen1915 (lambda (x1916) (let ((t1917 (car x1916))) (if (memv t1917 (quote (ref))) (build-annotated1064 #f (cadr x1916)) (if (memv t1917 (quote (primitive))) (build-annotated1064 #f (cadr x1916)) (if (memv t1917 (quote (quote))) (build-data1065 #f (cadr x1916)) (if (memv t1917 (quote (lambda))) (build-annotated1064 #f (list (quote lambda) (cadr x1916) (regen1915 (caddr x1916)))) (if (memv t1917 (quote (map))) (let ((ls1918 (map regen1915 (cdr x1916)))) (build-annotated1064 #f (cons (if (fx=1057 (length ls1918) 2) (build-annotated1064 #f (quote map)) (build-annotated1064 #f (quote map))) ls1918))) (build-annotated1064 #f (cons (build-annotated1064 #f (car x1916)) (map regen1915 (cdr x1916)))))))))))) (gen-vector1914 (lambda (x1919) (cond ((eq? (car x1919) (quote list)) (cons (quote vector) (cdr x1919))) ((eq? (car x1919) (quote quote)) (list (quote quote) (list->vector (cadr x1919)))) (else (list (quote list->vector) x1919))))) (gen-append1913 (lambda (x1920 y1921) (if (equal? y1921 (quote (quote ()))) x1920 (list (quote append) x1920 y1921)))) (gen-cons1912 (lambda (x1922 y1923) (let ((t1924 (car y1923))) (if (memv t1924 (quote (quote))) (if (eq? (car x1922) (quote quote)) (list (quote quote) (cons (cadr x1922) (cadr y1923))) (if (eq? (cadr y1923) (quote ())) (list (quote list) x1922) (list (quote cons) x1922 y1923))) (if (memv t1924 (quote (list))) (cons (quote list) (cons x1922 (cdr y1923))) (list (quote cons) x1922 y1923)))))) (gen-map1911 (lambda (e1925 map-env1926) (let ((formals1927 (map cdr map-env1926)) (actuals1928 (map (lambda (x1929) (list (quote ref) (car x1929))) map-env1926))) (cond ((eq? (car e1925) (quote ref)) (car actuals1928)) ((and-map (lambda (x1930) (and (eq? (car x1930) (quote ref)) (memq (cadr x1930) formals1927))) (cdr e1925)) (cons (quote map) (cons (list (quote primitive) (car e1925)) (map (let ((r1931 (map cons formals1927 actuals1928))) (lambda (x1932) (cdr (assq (cadr x1932) r1931)))) (cdr e1925))))) (else (cons (quote map) (cons (list (quote lambda) formals1927 e1925) actuals1928))))))) (gen-mappend1910 (lambda (e1933 map-env1934) (list (quote apply) (quote (primitive append)) (gen-map1911 e1933 map-env1934)))) (gen-ref1909 (lambda (src1935 var1936 level1937 maps1938) (if (fx=1057 level1937 0) (values var1936 maps1938) (if (null? maps1938) (syntax-violation (quote syntax) "missing ellipsis" src1935) (call-with-values (lambda () (gen-ref1909 src1935 var1936 (fx-1056 level1937 1) (cdr maps1938))) (lambda (outer-var1939 outer-maps1940) (let ((b1941 (assq outer-var1939 (car maps1938)))) (if b1941 (values (cdr b1941) maps1938) (let ((inner-var1942 (gen-var1135 (quote tmp)))) (values inner-var1942 (cons (cons (cons outer-var1939 inner-var1942) (car maps1938)) outer-maps1940))))))))))) (gen-syntax1908 (lambda (src1943 e1944 r1945 maps1946 ellipsis?1947 mod1948) (if (id?1087 e1944) (let ((label1949 (id-var-name1109 e1944 (quote (()))))) (let ((b1950 (lookup1084 label1949 r1945 mod1948))) (if (eq? (binding-type1079 b1950) (quote syntax)) (call-with-values (lambda () (let ((var.lev1951 (binding-value1080 b1950))) (gen-ref1909 src1943 (car var.lev1951) (cdr var.lev1951) maps1946))) (lambda (var1952 maps1953) (values (list (quote ref) var1952) maps1953))) (if (ellipsis?1947 e1944) (syntax-violation (quote syntax) "misplaced ellipsis" src1943) (values (list (quote quote) e1944) maps1946))))) ((lambda (tmp1954) ((lambda (tmp1955) (if (if tmp1955 (apply (lambda (dots1956 e1957) (ellipsis?1947 dots1956)) tmp1955) #f) (apply (lambda (dots1958 e1959) (gen-syntax1908 src1943 e1959 r1945 maps1946 (lambda (x1960) #f) mod1948)) tmp1955) ((lambda (tmp1961) (if (if tmp1961 (apply (lambda (x1962 dots1963 y1964) (ellipsis?1947 dots1963)) tmp1961) #f) (apply (lambda (x1965 dots1966 y1967) (let f1968 ((y1969 y1967) (k1970 (lambda (maps1971) (call-with-values (lambda () (gen-syntax1908 src1943 x1965 r1945 (cons (quote ()) maps1971) ellipsis?1947 mod1948)) (lambda (x1972 maps1973) (if (null? (car maps1973)) (syntax-violation (quote syntax) "extra ellipsis" src1943) (values (gen-map1911 x1972 (car maps1973)) (cdr maps1973)))))))) ((lambda (tmp1974) ((lambda (tmp1975) (if (if tmp1975 (apply (lambda (dots1976 y1977) (ellipsis?1947 dots1976)) tmp1975) #f) (apply (lambda (dots1978 y1979) (f1968 y1979 (lambda (maps1980) (call-with-values (lambda () (k1970 (cons (quote ()) maps1980))) (lambda (x1981 maps1982) (if (null? (car maps1982)) (syntax-violation (quote syntax) "extra ellipsis" src1943) (values (gen-mappend1910 x1981 (car maps1982)) (cdr maps1982)))))))) tmp1975) ((lambda (_1983) (call-with-values (lambda () (gen-syntax1908 src1943 y1969 r1945 maps1946 ellipsis?1947 mod1948)) (lambda (y1984 maps1985) (call-with-values (lambda () (k1970 maps1985)) (lambda (x1986 maps1987) (values (gen-append1913 x1986 y1984) maps1987)))))) tmp1974))) ($sc-dispatch tmp1974 (quote (any . any))))) y1969))) tmp1961) ((lambda (tmp1988) (if tmp1988 (apply (lambda (x1989 y1990) (call-with-values (lambda () (gen-syntax1908 src1943 x1989 r1945 maps1946 ellipsis?1947 mod1948)) (lambda (x1991 maps1992) (call-with-values (lambda () (gen-syntax1908 src1943 y1990 r1945 maps1992 ellipsis?1947 mod1948)) (lambda (y1993 maps1994) (values (gen-cons1912 x1991 y1993) maps1994)))))) tmp1988) ((lambda (tmp1995) (if tmp1995 (apply (lambda (e11996 e21997) (call-with-values (lambda () (gen-syntax1908 src1943 (cons e11996 e21997) r1945 maps1946 ellipsis?1947 mod1948)) (lambda (e1999 maps2000) (values (gen-vector1914 e1999) maps2000)))) tmp1995) ((lambda (_2001) (values (list (quote quote) e1944) maps1946)) tmp1954))) ($sc-dispatch tmp1954 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1954 (quote (any . any)))))) ($sc-dispatch tmp1954 (quote (any any . any)))))) ($sc-dispatch tmp1954 (quote (any any))))) e1944))))) (lambda (e2002 r2003 w2004 s2005 mod2006) (let ((e2007 (source-wrap1116 e2002 w2004 s2005 mod2006))) ((lambda (tmp2008) ((lambda (tmp2009) (if tmp2009 (apply (lambda (_2010 x2011) (call-with-values (lambda () (gen-syntax1908 e2007 x2011 r2003 (quote ()) ellipsis?1132 mod2006)) (lambda (e2012 maps2013) (regen1915 e2012)))) tmp2009) ((lambda (_2014) (syntax-violation (quote syntax) "bad `syntax' form" e2007)) tmp2008))) ($sc-dispatch tmp2008 (quote (any any))))) e2007))))) (global-extend1085 (quote core) (quote lambda) (lambda (e2015 r2016 w2017 s2018 mod2019) ((lambda (tmp2020) ((lambda (tmp2021) (if tmp2021 (apply (lambda (_2022 c2023) (chi-lambda-clause1128 (source-wrap1116 e2015 w2017 s2018 mod2019) #f c2023 r2016 w2017 mod2019 (lambda (vars2024 docstring2025 body2026) (build-annotated1064 s2018 (cons (quote lambda) (cons vars2024 (append (if docstring2025 (list docstring2025) (quote ())) (list body2026)))))))) tmp2021) (syntax-violation #f "source expression failed to match any pattern" tmp2020))) ($sc-dispatch tmp2020 (quote (any . any))))) e2015))) (global-extend1085 (quote core) (quote let) (letrec ((chi-let2027 (lambda (e2028 r2029 w2030 s2031 mod2032 constructor2033 ids2034 vals2035 exps2036) (if (not (valid-bound-ids?1112 ids2034)) (syntax-violation (quote let) "duplicate bound variable" e2028) (let ((labels2037 (gen-labels1093 ids2034)) (new-vars2038 (map gen-var1135 ids2034))) (let ((nw2039 (make-binding-wrap1104 ids2034 labels2037 w2030)) (nr2040 (extend-var-env1082 labels2037 new-vars2038 r2029))) (constructor2033 s2031 new-vars2038 (map (lambda (x2041) (chi1123 x2041 r2029 w2030 mod2032)) vals2035) (chi-body1127 exps2036 (source-wrap1116 e2028 nw2039 s2031 mod2032) nr2040 nw2039 mod2032)))))))) (lambda (e2042 r2043 w2044 s2045 mod2046) ((lambda (tmp2047) ((lambda (tmp2048) (if tmp2048 (apply (lambda (_2049 id2050 val2051 e12052 e22053) (chi-let2027 e2042 r2043 w2044 s2045 mod2046 build-let1067 id2050 val2051 (cons e12052 e22053))) tmp2048) ((lambda (tmp2057) (if (if tmp2057 (apply (lambda (_2058 f2059 id2060 val2061 e12062 e22063) (id?1087 f2059)) tmp2057) #f) (apply (lambda (_2064 f2065 id2066 val2067 e12068 e22069) (chi-let2027 e2042 r2043 w2044 s2045 mod2046 build-named-let1068 (cons f2065 id2066) val2067 (cons e12068 e22069))) tmp2057) ((lambda (_2073) (syntax-violation (quote let) "bad let" (source-wrap1116 e2042 w2044 s2045 mod2046))) tmp2047))) ($sc-dispatch tmp2047 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2047 (quote (any #(each (any any)) any . each-any))))) e2042)))) (global-extend1085 (quote core) (quote letrec) (lambda (e2074 r2075 w2076 s2077 mod2078) ((lambda (tmp2079) ((lambda (tmp2080) (if tmp2080 (apply (lambda (_2081 id2082 val2083 e12084 e22085) (let ((ids2086 id2082)) (if (not (valid-bound-ids?1112 ids2086)) (syntax-violation (quote letrec) "duplicate bound variable" e2074) (let ((labels2088 (gen-labels1093 ids2086)) (new-vars2089 (map gen-var1135 ids2086))) (let ((w2090 (make-binding-wrap1104 ids2086 labels2088 w2076)) (r2091 (extend-var-env1082 labels2088 new-vars2089 r2075))) (build-letrec1069 s2077 new-vars2089 (map (lambda (x2092) (chi1123 x2092 r2091 w2090 mod2078)) val2083) (chi-body1127 (cons e12084 e22085) (source-wrap1116 e2074 w2090 s2077 mod2078) r2091 w2090 mod2078))))))) tmp2080) ((lambda (_2095) (syntax-violation (quote letrec) "bad letrec" (source-wrap1116 e2074 w2076 s2077 mod2078))) tmp2079))) ($sc-dispatch tmp2079 (quote (any #(each (any any)) any . each-any))))) e2074))) (global-extend1085 (quote core) (quote set!) (lambda (e2096 r2097 w2098 s2099 mod2100) ((lambda (tmp2101) ((lambda (tmp2102) (if (if tmp2102 (apply (lambda (_2103 id2104 val2105) (id?1087 id2104)) tmp2102) #f) (apply (lambda (_2106 id2107 val2108) (let ((val2109 (chi1123 val2108 r2097 w2098 mod2100)) (n2110 (id-var-name1109 id2107 w2098))) (let ((b2111 (lookup1084 n2110 r2097 mod2100))) (let ((t2112 (binding-type1079 b2111))) (if (memv t2112 (quote (lexical))) (build-annotated1064 s2099 (list (quote set!) (binding-value1080 b2111) val2109)) (if (memv t2112 (quote (global))) (build-annotated1064 s2099 (list (quote set!) (if mod2100 (make-module-ref (cdr mod2100) n2110 (car mod2100)) (make-module-ref mod2100 n2110 (quote bare))) val2109)) (if (memv t2112 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1115 id2107 w2098 mod2100)) (syntax-violation (quote set!) "bad set!" (source-wrap1116 e2096 w2098 s2099 mod2100))))))))) tmp2102) ((lambda (tmp2113) (if tmp2113 (apply (lambda (_2114 head2115 tail2116 val2117) (call-with-values (lambda () (syntax-type1121 head2115 r2097 (quote (())) #f #f mod2100)) (lambda (type2118 value2119 ee2120 ww2121 ss2122 modmod2123) (let ((t2124 type2118)) (if (memv t2124 (quote (module-ref))) (let ((val2125 (chi1123 val2117 r2097 w2098 mod2100))) (call-with-values (lambda () (value2119 (cons head2115 tail2116))) (lambda (id2127 mod2128) (build-annotated1064 s2099 (list (quote set!) (if mod2128 (make-module-ref (cdr mod2128) id2127 (car mod2128)) (make-module-ref mod2128 id2127 (quote bare))) val2125))))) (build-annotated1064 s2099 (cons (chi1123 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2115) r2097 w2098 mod2100) (map (lambda (e2129) (chi1123 e2129 r2097 w2098 mod2100)) (append tail2116 (list val2117)))))))))) tmp2113) ((lambda (_2131) (syntax-violation (quote set!) "bad set!" (source-wrap1116 e2096 w2098 s2099 mod2100))) tmp2101))) ($sc-dispatch tmp2101 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2101 (quote (any any any))))) e2096))) (global-extend1085 (quote module-ref) (quote @) (lambda (e2132) ((lambda (tmp2133) ((lambda (tmp2134) (if (if tmp2134 (apply (lambda (_2135 mod2136 id2137) (and (and-map id?1087 mod2136) (id?1087 id2137))) tmp2134) #f) (apply (lambda (_2139 mod2140 id2141) (values (syntax->datum id2141) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2140)))) tmp2134) (syntax-violation #f "source expression failed to match any pattern" tmp2133))) ($sc-dispatch tmp2133 (quote (any each-any any))))) e2132))) (global-extend1085 (quote module-ref) (quote @@) (lambda (e2143) ((lambda (tmp2144) ((lambda (tmp2145) (if (if tmp2145 (apply (lambda (_2146 mod2147 id2148) (and (and-map id?1087 mod2147) (id?1087 id2148))) tmp2145) #f) (apply (lambda (_2150 mod2151 id2152) (values (syntax->datum id2152) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2151)))) tmp2145) (syntax-violation #f "source expression failed to match any pattern" tmp2144))) ($sc-dispatch tmp2144 (quote (any each-any any))))) e2143))) (global-extend1085 (quote begin) (quote begin) (quote ())) (global-extend1085 (quote define) (quote define) (quote ())) (global-extend1085 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1085 (quote eval-when) (quote eval-when) (quote ())) (global-extend1085 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2157 (lambda (x2158 keys2159 clauses2160 r2161 mod2162) (if (null? clauses2160) (build-annotated1064 #f (list (build-annotated1064 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2158)) ((lambda (tmp2163) ((lambda (tmp2164) (if tmp2164 (apply (lambda (pat2165 exp2166) (if (and (id?1087 pat2165) (and-map (lambda (x2167) (not (free-id=?1110 pat2165 x2167))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2159))) (let ((labels2168 (list (gen-label1092))) (var2169 (gen-var1135 pat2165))) (build-annotated1064 #f (list (build-annotated1064 #f (list (quote lambda) (list var2169) (chi1123 exp2166 (extend-env1081 labels2168 (list (cons (quote syntax) (cons var2169 0))) r2161) (make-binding-wrap1104 (list pat2165) labels2168 (quote (()))) mod2162))) x2158))) (gen-clause2156 x2158 keys2159 (cdr clauses2160) r2161 pat2165 #t exp2166 mod2162))) tmp2164) ((lambda (tmp2170) (if tmp2170 (apply (lambda (pat2171 fender2172 exp2173) (gen-clause2156 x2158 keys2159 (cdr clauses2160) r2161 pat2171 fender2172 exp2173 mod2162)) tmp2170) ((lambda (_2174) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2160))) tmp2163))) ($sc-dispatch tmp2163 (quote (any any any)))))) ($sc-dispatch tmp2163 (quote (any any))))) (car clauses2160))))) (gen-clause2156 (lambda (x2175 keys2176 clauses2177 r2178 pat2179 fender2180 exp2181 mod2182) (call-with-values (lambda () (convert-pattern2154 pat2179 keys2176)) (lambda (p2183 pvars2184) (cond ((not (distinct-bound-ids?1113 (map car pvars2184))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2179)) ((not (and-map (lambda (x2185) (not (ellipsis?1132 (car x2185)))) pvars2184)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2179)) (else (let ((y2186 (gen-var1135 (quote tmp)))) (build-annotated1064 #f (list (build-annotated1064 #f (list (quote lambda) (list y2186) (let ((y2187 (build-annotated1064 #f y2186))) (build-annotated1064 #f (list (quote if) ((lambda (tmp2188) ((lambda (tmp2189) (if tmp2189 (apply (lambda () y2187) tmp2189) ((lambda (_2190) (build-annotated1064 #f (list (quote if) y2187 (build-dispatch-call2155 pvars2184 fender2180 y2187 r2178 mod2182) (build-data1065 #f #f)))) tmp2188))) ($sc-dispatch tmp2188 (quote #(atom #t))))) fender2180) (build-dispatch-call2155 pvars2184 exp2181 y2187 r2178 mod2182) (gen-syntax-case2157 x2175 keys2176 clauses2177 r2178 mod2182)))))) (if (eq? p2183 (quote any)) (build-annotated1064 #f (list (build-annotated1064 #f (quote list)) x2175)) (build-annotated1064 #f (list (build-annotated1064 #f (quote $sc-dispatch)) x2175 (build-data1065 #f p2183))))))))))))) (build-dispatch-call2155 (lambda (pvars2191 exp2192 y2193 r2194 mod2195) (let ((ids2196 (map car pvars2191)) (levels2197 (map cdr pvars2191))) (let ((labels2198 (gen-labels1093 ids2196)) (new-vars2199 (map gen-var1135 ids2196))) (build-annotated1064 #f (list (build-annotated1064 #f (quote apply)) (build-annotated1064 #f (list (quote lambda) new-vars2199 (chi1123 exp2192 (extend-env1081 labels2198 (map (lambda (var2200 level2201) (cons (quote syntax) (cons var2200 level2201))) new-vars2199 (map cdr pvars2191)) r2194) (make-binding-wrap1104 ids2196 labels2198 (quote (()))) mod2195))) y2193)))))) (convert-pattern2154 (lambda (pattern2202 keys2203) (let cvt2204 ((p2205 pattern2202) (n2206 0) (ids2207 (quote ()))) (if (id?1087 p2205) (if (bound-id-member?1114 p2205 keys2203) (values (vector (quote free-id) p2205) ids2207) (values (quote any) (cons (cons p2205 n2206) ids2207))) ((lambda (tmp2208) ((lambda (tmp2209) (if (if tmp2209 (apply (lambda (x2210 dots2211) (ellipsis?1132 dots2211)) tmp2209) #f) (apply (lambda (x2212 dots2213) (call-with-values (lambda () (cvt2204 x2212 (fx+1055 n2206 1) ids2207)) (lambda (p2214 ids2215) (values (if (eq? p2214 (quote any)) (quote each-any) (vector (quote each) p2214)) ids2215)))) tmp2209) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217 y2218) (call-with-values (lambda () (cvt2204 y2218 n2206 ids2207)) (lambda (y2219 ids2220) (call-with-values (lambda () (cvt2204 x2217 n2206 ids2220)) (lambda (x2221 ids2222) (values (cons x2221 y2219) ids2222)))))) tmp2216) ((lambda (tmp2223) (if tmp2223 (apply (lambda () (values (quote ()) ids2207)) tmp2223) ((lambda (tmp2224) (if tmp2224 (apply (lambda (x2225) (call-with-values (lambda () (cvt2204 x2225 n2206 ids2207)) (lambda (p2227 ids2228) (values (vector (quote vector) p2227) ids2228)))) tmp2224) ((lambda (x2229) (values (vector (quote atom) (strip1134 p2205 (quote (())))) ids2207)) tmp2208))) ($sc-dispatch tmp2208 (quote #(vector each-any)))))) ($sc-dispatch tmp2208 (quote ()))))) ($sc-dispatch tmp2208 (quote (any . any)))))) ($sc-dispatch tmp2208 (quote (any any))))) p2205)))))) (lambda (e2230 r2231 w2232 s2233 mod2234) (let ((e2235 (source-wrap1116 e2230 w2232 s2233 mod2234))) ((lambda (tmp2236) ((lambda (tmp2237) (if tmp2237 (apply (lambda (_2238 val2239 key2240 m2241) (if (and-map (lambda (x2242) (and (id?1087 x2242) (not (ellipsis?1132 x2242)))) key2240) (let ((x2244 (gen-var1135 (quote tmp)))) (build-annotated1064 s2233 (list (build-annotated1064 #f (list (quote lambda) (list x2244) (gen-syntax-case2157 (build-annotated1064 #f x2244) key2240 m2241 r2231 mod2234))) (chi1123 val2239 r2231 (quote (())) mod2234)))) (syntax-violation (quote syntax-case) "invalid literals list" e2235))) tmp2237) (syntax-violation #f "source expression failed to match any pattern" tmp2236))) ($sc-dispatch tmp2236 (quote (any any each-any . each-any))))) e2235))))) (set! sc-expand (let ((m2247 (quote e)) (esew2248 (quote (eval)))) (lambda (x2249) (if (and (pair? x2249) (equal? (car x2249) noexpand1054)) (cadr x2249) (chi-top1122 x2249 (quote ()) (quote ((top))) m2247 esew2248 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2250 (quote e)) (esew2251 (quote (eval)))) (lambda (x2253 . rest2252) (if (and (pair? x2253) (equal? (car x2253) noexpand1054)) (cadr x2253) (chi-top1122 x2253 (quote ()) (quote ((top))) (if (null? rest2252) m2250 (car rest2252)) (if (or (null? rest2252) (null? (cdr rest2252))) esew2251 (cadr rest2252)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2254) (nonsymbol-id?1086 x2254))) (set! datum->syntax (lambda (id2255 datum2256) (make-syntax-object1070 datum2256 (syntax-object-wrap1073 id2255) #f))) (set! syntax->datum (lambda (x2257) (strip1134 x2257 (quote (()))))) (set! generate-temporaries (lambda (ls2258) (begin (let ((x2259 ls2258)) (if (not (list? x2259)) (error-hook1061 (quote generate-temporaries) "invalid argument" x2259))) (map (lambda (x2260) (wrap1115 (gensym) (quote ((top))) #f)) ls2258)))) (set! free-identifier=? (lambda (x2261 y2262) (begin (let ((x2263 x2261)) (if (not (nonsymbol-id?1086 x2263)) (error-hook1061 (quote free-identifier=?) "invalid argument" x2263))) (let ((x2264 y2262)) (if (not (nonsymbol-id?1086 x2264)) (error-hook1061 (quote free-identifier=?) "invalid argument" x2264))) (free-id=?1110 x2261 y2262)))) (set! bound-identifier=? (lambda (x2265 y2266) (begin (let ((x2267 x2265)) (if (not (nonsymbol-id?1086 x2267)) (error-hook1061 (quote bound-identifier=?) "invalid argument" x2267))) (let ((x2268 y2266)) (if (not (nonsymbol-id?1086 x2268)) (error-hook1061 (quote bound-identifier=?) "invalid argument" x2268))) (bound-id=?1111 x2265 y2266)))) (set! syntax-violation (lambda (who2272 message2271 form2270 . subform2269) (begin (let ((x2273 who2272)) (if (not ((lambda (x2274) (or (not x2274) (string? x2274) (symbol? x2274))) x2273)) (error-hook1061 (quote syntax-violation) "invalid argument" x2273))) (let ((x2275 message2271)) (if (not (string? x2275)) (error-hook1061 (quote syntax-violation) "invalid argument" x2275))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2272 "~a: " "") "~a " (if (null? subform2269) "in ~a" "in subform `~s' of `~s'")) (let ((tail2276 (cons message2271 (map (lambda (x2277) (strip1134 x2277 (quote (())))) (append subform2269 (list form2270)))))) (if who2272 (cons who2272 tail2276) tail2276)) #f)))) (letrec ((match2282 (lambda (e2283 p2284 w2285 r2286 mod2287) (cond ((not r2286) #f) ((eq? p2284 (quote any)) (cons (wrap1115 e2283 w2285 mod2287) r2286)) ((syntax-object?1071 e2283) (match*2281 (let ((e2288 (syntax-object-expression1072 e2283))) (if (annotation? e2288) (annotation-expression e2288) e2288)) p2284 (join-wraps1106 w2285 (syntax-object-wrap1073 e2283)) r2286 (syntax-object-module1074 e2283))) (else (match*2281 (let ((e2289 e2283)) (if (annotation? e2289) (annotation-expression e2289) e2289)) p2284 w2285 r2286 mod2287))))) (match*2281 (lambda (e2290 p2291 w2292 r2293 mod2294) (cond ((null? p2291) (and (null? e2290) r2293)) ((pair? p2291) (and (pair? e2290) (match2282 (car e2290) (car p2291) w2292 (match2282 (cdr e2290) (cdr p2291) w2292 r2293 mod2294) mod2294))) ((eq? p2291 (quote each-any)) (let ((l2295 (match-each-any2279 e2290 w2292 mod2294))) (and l2295 (cons l2295 r2293)))) (else (let ((t2296 (vector-ref p2291 0))) (if (memv t2296 (quote (each))) (if (null? e2290) (match-empty2280 (vector-ref p2291 1) r2293) (let ((l2297 (match-each2278 e2290 (vector-ref p2291 1) w2292 mod2294))) (and l2297 (let collect2298 ((l2299 l2297)) (if (null? (car l2299)) r2293 (cons (map car l2299) (collect2298 (map cdr l2299)))))))) (if (memv t2296 (quote (free-id))) (and (id?1087 e2290) (free-id=?1110 (wrap1115 e2290 w2292 mod2294) (vector-ref p2291 1)) r2293) (if (memv t2296 (quote (atom))) (and (equal? (vector-ref p2291 1) (strip1134 e2290 w2292)) r2293) (if (memv t2296 (quote (vector))) (and (vector? e2290) (match2282 (vector->list e2290) (vector-ref p2291 1) w2292 r2293 mod2294))))))))))) (match-empty2280 (lambda (p2300 r2301) (cond ((null? p2300) r2301) ((eq? p2300 (quote any)) (cons (quote ()) r2301)) ((pair? p2300) (match-empty2280 (car p2300) (match-empty2280 (cdr p2300) r2301))) ((eq? p2300 (quote each-any)) (cons (quote ()) r2301)) (else (let ((t2302 (vector-ref p2300 0))) (if (memv t2302 (quote (each))) (match-empty2280 (vector-ref p2300 1) r2301) (if (memv t2302 (quote (free-id atom))) r2301 (if (memv t2302 (quote (vector))) (match-empty2280 (vector-ref p2300 1) r2301))))))))) (match-each-any2279 (lambda (e2303 w2304 mod2305) (cond ((annotation? e2303) (match-each-any2279 (annotation-expression e2303) w2304 mod2305)) ((pair? e2303) (let ((l2306 (match-each-any2279 (cdr e2303) w2304 mod2305))) (and l2306 (cons (wrap1115 (car e2303) w2304 mod2305) l2306)))) ((null? e2303) (quote ())) ((syntax-object?1071 e2303) (match-each-any2279 (syntax-object-expression1072 e2303) (join-wraps1106 w2304 (syntax-object-wrap1073 e2303)) mod2305)) (else #f)))) (match-each2278 (lambda (e2307 p2308 w2309 mod2310) (cond ((annotation? e2307) (match-each2278 (annotation-expression e2307) p2308 w2309 mod2310)) ((pair? e2307) (let ((first2311 (match2282 (car e2307) p2308 w2309 (quote ()) mod2310))) (and first2311 (let ((rest2312 (match-each2278 (cdr e2307) p2308 w2309 mod2310))) (and rest2312 (cons first2311 rest2312)))))) ((null? e2307) (quote ())) ((syntax-object?1071 e2307) (match-each2278 (syntax-object-expression1072 e2307) p2308 (join-wraps1106 w2309 (syntax-object-wrap1073 e2307)) (syntax-object-module1074 e2307))) (else #f))))) (set! $sc-dispatch (lambda (e2313 p2314) (cond ((eq? p2314 (quote any)) (list e2313)) ((syntax-object?1071 e2313) (match*2281 (let ((e2315 (syntax-object-expression1072 e2313))) (if (annotation? e2315) (annotation-expression e2315) e2315)) p2314 (syntax-object-wrap1073 e2313) (quote ()) (syntax-object-module1074 e2313))) (else (match*2281 (let ((e2316 e2313)) (if (annotation? e2316) (annotation-expression e2316) e2316)) p2314 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x2317) ((lambda (tmp2318) ((lambda (tmp2319) (if tmp2319 (apply (lambda (_2320 e12321 e22322) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12321 e22322))) tmp2319) ((lambda (tmp2324) (if tmp2324 (apply (lambda (_2325 out2326 in2327 e12328 e22329) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2327 (quote ()) (list out2326 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12328 e22329))))) tmp2324) ((lambda (tmp2331) (if tmp2331 (apply (lambda (_2332 out2333 in2334 e12335 e22336) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2334) (quote ()) (list out2333 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12335 e22336))))) tmp2331) (syntax-violation #f "source expression failed to match any pattern" tmp2318))) ($sc-dispatch tmp2318 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2318 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2318 (quote (any () any . each-any))))) x2317)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2340) ((lambda (tmp2341) ((lambda (tmp2342) (if tmp2342 (apply (lambda (_2343 k2344 keyword2345 pattern2346 template2347) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2344 (map (lambda (tmp2350 tmp2349) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2349) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2350))) template2347 pattern2346)))))) tmp2342) (syntax-violation #f "source expression failed to match any pattern" tmp2341))) ($sc-dispatch tmp2341 (quote (any each-any . #(each ((any . any) any))))))) x2340)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2351) ((lambda (tmp2352) ((lambda (tmp2353) (if (if tmp2353 (apply (lambda (let*2354 x2355 v2356 e12357 e22358) (and-map identifier? x2355)) tmp2353) #f) (apply (lambda (let*2360 x2361 v2362 e12363 e22364) (let f2365 ((bindings2366 (map list x2361 v2362))) (if (null? bindings2366) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12363 e22364))) ((lambda (tmp2370) ((lambda (tmp2371) (if tmp2371 (apply (lambda (body2372 binding2373) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2373) body2372)) tmp2371) (syntax-violation #f "source expression failed to match any pattern" tmp2370))) ($sc-dispatch tmp2370 (quote (any any))))) (list (f2365 (cdr bindings2366)) (car bindings2366)))))) tmp2353) (syntax-violation #f "source expression failed to match any pattern" tmp2352))) ($sc-dispatch tmp2352 (quote (any #(each (any any)) any . each-any))))) x2351)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2374) ((lambda (tmp2375) ((lambda (tmp2376) (if tmp2376 (apply (lambda (_2377 var2378 init2379 step2380 e02381 e12382 c2383) ((lambda (tmp2384) ((lambda (tmp2385) (if tmp2385 (apply (lambda (step2386) ((lambda (tmp2387) ((lambda (tmp2388) (if tmp2388 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2378 init2379) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02381) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2383 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2386))))))) tmp2388) ((lambda (tmp2393) (if tmp2393 (apply (lambda (e12394 e22395) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2378 init2379) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02381 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12394 e22395)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2383 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2386))))))) tmp2393) (syntax-violation #f "source expression failed to match any pattern" tmp2387))) ($sc-dispatch tmp2387 (quote (any . each-any)))))) ($sc-dispatch tmp2387 (quote ())))) e12382)) tmp2385) (syntax-violation #f "source expression failed to match any pattern" tmp2384))) ($sc-dispatch tmp2384 (quote each-any)))) (map (lambda (v2402 s2403) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda () v2402) tmp2405) ((lambda (tmp2406) (if tmp2406 (apply (lambda (e2407) e2407) tmp2406) ((lambda (_2408) (syntax-violation (quote do) "bad step expression" orig-x2374 s2403)) tmp2404))) ($sc-dispatch tmp2404 (quote (any)))))) ($sc-dispatch tmp2404 (quote ())))) s2403)) var2378 step2380))) tmp2376) (syntax-violation #f "source expression failed to match any pattern" tmp2375))) ($sc-dispatch tmp2375 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2374)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2411 (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (x2419 y2420) ((lambda (tmp2421) ((lambda (tmp2422) (if tmp2422 (apply (lambda (dy2423) ((lambda (tmp2424) ((lambda (tmp2425) (if tmp2425 (apply (lambda (dx2426) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2426 dy2423))) tmp2425) ((lambda (_2427) (if (null? dy2423) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2419) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2419 y2420))) tmp2424))) ($sc-dispatch tmp2424 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2419)) tmp2422) ((lambda (tmp2428) (if tmp2428 (apply (lambda (stuff2429) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2419 stuff2429))) tmp2428) ((lambda (else2430) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2419 y2420)) tmp2421))) ($sc-dispatch tmp2421 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2421 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2420)) tmp2418) (syntax-violation #f "source expression failed to match any pattern" tmp2417))) ($sc-dispatch tmp2417 (quote (any any))))) (list x2415 y2416)))) (quasiappend2412 (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda (x2435 y2436) ((lambda (tmp2437) ((lambda (tmp2438) (if tmp2438 (apply (lambda () x2435) tmp2438) ((lambda (_2439) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2435 y2436)) tmp2437))) ($sc-dispatch tmp2437 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2436)) tmp2434) (syntax-violation #f "source expression failed to match any pattern" tmp2433))) ($sc-dispatch tmp2433 (quote (any any))))) (list x2431 y2432)))) (quasivector2413 (lambda (x2440) ((lambda (tmp2441) ((lambda (x2442) ((lambda (tmp2443) ((lambda (tmp2444) (if tmp2444 (apply (lambda (x2445) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2445))) tmp2444) ((lambda (tmp2447) (if tmp2447 (apply (lambda (x2448) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2448)) tmp2447) ((lambda (_2450) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2442)) tmp2443))) ($sc-dispatch tmp2443 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2443 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2442)) tmp2441)) x2440))) (quasi2414 (lambda (p2451 lev2452) ((lambda (tmp2453) ((lambda (tmp2454) (if tmp2454 (apply (lambda (p2455) (if (= lev2452 0) p2455 (quasicons2411 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2414 (list p2455) (- lev2452 1))))) tmp2454) ((lambda (tmp2456) (if tmp2456 (apply (lambda (p2457 q2458) (if (= lev2452 0) (quasiappend2412 p2457 (quasi2414 q2458 lev2452)) (quasicons2411 (quasicons2411 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2414 (list p2457) (- lev2452 1))) (quasi2414 q2458 lev2452)))) tmp2456) ((lambda (tmp2459) (if tmp2459 (apply (lambda (p2460) (quasicons2411 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2414 (list p2460) (+ lev2452 1)))) tmp2459) ((lambda (tmp2461) (if tmp2461 (apply (lambda (p2462 q2463) (quasicons2411 (quasi2414 p2462 lev2452) (quasi2414 q2463 lev2452))) tmp2461) ((lambda (tmp2464) (if tmp2464 (apply (lambda (x2465) (quasivector2413 (quasi2414 x2465 lev2452))) tmp2464) ((lambda (p2467) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2467)) tmp2453))) ($sc-dispatch tmp2453 (quote #(vector each-any)))))) ($sc-dispatch tmp2453 (quote (any . any)))))) ($sc-dispatch tmp2453 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2453 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2453 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2451)))) (lambda (x2468) ((lambda (tmp2469) ((lambda (tmp2470) (if tmp2470 (apply (lambda (_2471 e2472) (quasi2414 e2472 0)) tmp2470) (syntax-violation #f "source expression failed to match any pattern" tmp2469))) ($sc-dispatch tmp2469 (quote (any any))))) x2468))))) -(define include (make-syncase-macro (quote macro) (lambda (x2473) (letrec ((read-file2474 (lambda (fn2475 k2476) (let ((p2477 (open-input-file fn2475))) (let f2478 ((x2479 (read p2477))) (if (eof-object? x2479) (begin (close-input-port p2477) (quote ())) (cons (datum->syntax k2476 x2479) (f2478 (read p2477))))))))) ((lambda (tmp2480) ((lambda (tmp2481) (if tmp2481 (apply (lambda (k2482 filename2483) (let ((fn2484 (syntax->datum filename2483))) ((lambda (tmp2485) ((lambda (tmp2486) (if tmp2486 (apply (lambda (exp2487) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2487)) tmp2486) (syntax-violation #f "source expression failed to match any pattern" tmp2485))) ($sc-dispatch tmp2485 (quote each-any)))) (read-file2474 fn2484 k2482)))) tmp2481) (syntax-violation #f "source expression failed to match any pattern" tmp2480))) ($sc-dispatch tmp2480 (quote (any any))))) x2473))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x2489) ((lambda (tmp2490) ((lambda (tmp2491) (if tmp2491 (apply (lambda (_2492 e2493) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2493))) tmp2491) (syntax-violation #f "source expression failed to match any pattern" tmp2490))) ($sc-dispatch tmp2490 (quote (any any))))) x2489)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2494) ((lambda (tmp2495) ((lambda (tmp2496) (if tmp2496 (apply (lambda (_2497 e2498) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2498))) tmp2496) (syntax-violation #f "source expression failed to match any pattern" tmp2495))) ($sc-dispatch tmp2495 (quote (any any))))) x2494)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2499) ((lambda (tmp2500) ((lambda (tmp2501) (if tmp2501 (apply (lambda (_2502 e2503 m12504 m22505) ((lambda (tmp2506) ((lambda (body2507) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2503)) body2507)) tmp2506)) (let f2508 ((clause2509 m12504) (clauses2510 m22505)) (if (null? clauses2510) ((lambda (tmp2512) ((lambda (tmp2513) (if tmp2513 (apply (lambda (e12514 e22515) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12514 e22515))) tmp2513) ((lambda (tmp2517) (if tmp2517 (apply (lambda (k2518 e12519 e22520) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2518)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12519 e22520)))) tmp2517) ((lambda (_2523) (syntax-violation (quote case) "bad clause" x2499 clause2509)) tmp2512))) ($sc-dispatch tmp2512 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2512 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2509) ((lambda (tmp2524) ((lambda (rest2525) ((lambda (tmp2526) ((lambda (tmp2527) (if tmp2527 (apply (lambda (k2528 e12529 e22530) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2528)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12529 e22530)) rest2525)) tmp2527) ((lambda (_2533) (syntax-violation (quote case) "bad clause" x2499 clause2509)) tmp2526))) ($sc-dispatch tmp2526 (quote (each-any any . each-any))))) clause2509)) tmp2524)) (f2508 (car clauses2510) (cdr clauses2510))))))) tmp2501) (syntax-violation #f "source expression failed to match any pattern" tmp2500))) ($sc-dispatch tmp2500 (quote (any any any . each-any))))) x2499)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2534) ((lambda (tmp2535) ((lambda (tmp2536) (if tmp2536 (apply (lambda (_2537 e2538) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2538)) (list (cons _2537 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2538 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2536) (syntax-violation #f "source expression failed to match any pattern" tmp2535))) ($sc-dispatch tmp2535 (quote (any any))))) x2534)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list150 (lambda (vars355) (let lvl356 ((vars357 vars355) (ls358 (quote ())) (w359 (quote (())))) (cond ((pair? vars357) (lvl356 (cdr vars357) (cons (wrap129 (car vars357) w359 #f) ls358) w359)) ((id?101 vars357) (cons (wrap129 vars357 w359 #f) ls358)) ((null? vars357) ls358) ((syntax-object?85 vars357) (lvl356 (syntax-object-expression86 vars357) ls358 (join-wraps120 w359 (syntax-object-wrap87 vars357)))) ((annotation? vars357) (lvl356 (annotation-expression vars357) ls358 w359)) (else (cons vars357 ls358)))))) (gen-var149 (lambda (id360) (let ((id361 (if (syntax-object?85 id360) (syntax-object-expression86 id360) id360))) (if (annotation? id361) (build-annotated78 (annotation-source id361) (gensym (symbol->string (annotation-expression id361)))) (build-annotated78 #f (gensym (symbol->string id361))))))) (strip148 (lambda (x362 w363) (if (memq (quote top) (wrap-marks104 w363)) (if (or (annotation? x362) (and (pair? x362) (annotation? (car x362)))) (strip-annotation147 x362 #f) x362) (let f364 ((x365 x362)) (cond ((syntax-object?85 x365) (strip148 (syntax-object-expression86 x365) (syntax-object-wrap87 x365))) ((pair? x365) (let ((a366 (f364 (car x365))) (d367 (f364 (cdr x365)))) (if (and (eq? a366 (car x365)) (eq? d367 (cdr x365))) x365 (cons a366 d367)))) ((vector? x365) (let ((old368 (vector->list x365))) (let ((new369 (map f364 old368))) (if (and-map*17 eq? old368 new369) x365 (list->vector new369))))) (else x365)))))) (strip-annotation147 (lambda (x370 parent371) (cond ((pair? x370) (let ((new372 (cons #f #f))) (begin (if parent371 (set-annotation-stripped! parent371 new372)) (set-car! new372 (strip-annotation147 (car x370) #f)) (set-cdr! new372 (strip-annotation147 (cdr x370) #f)) new372))) ((annotation? x370) (or (annotation-stripped x370) (strip-annotation147 (annotation-expression x370) x370))) ((vector? x370) (let ((new373 (make-vector (vector-length x370)))) (begin (if parent371 (set-annotation-stripped! parent371 new373)) (let loop374 ((i375 (- (vector-length x370) 1))) (unless (fx<73 i375 0) (vector-set! new373 i375 (strip-annotation147 (vector-ref x370 i375) #f)) (loop374 (fx-71 i375 1)))) new373))) (else x370)))) (ellipsis?146 (lambda (x376) (and (nonsymbol-id?100 x376) (free-id=?124 x376 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void145 (lambda () (build-annotated78 #f (list (build-annotated78 #f (quote void)))))) (eval-local-transformer144 (lambda (expanded377 mod378) (let ((p379 (local-eval-hook75 expanded377 mod378))) (if (procedure? p379) p379 (syntax-violation #f "nonprocedure transformer" p379))))) (chi-local-syntax143 (lambda (rec?380 e381 r382 w383 s384 mod385 k386) ((lambda (tmp387) ((lambda (tmp388) (if tmp388 (apply (lambda (_389 id390 val391 e1392 e2393) (let ((ids394 id390)) (if (not (valid-bound-ids?126 ids394)) (syntax-violation #f "duplicate bound keyword" e381) (let ((labels396 (gen-labels107 ids394))) (let ((new-w397 (make-binding-wrap118 ids394 labels396 w383))) (k386 (cons e1392 e2393) (extend-env95 labels396 (let ((w399 (if rec?380 new-w397 w383)) (trans-r400 (macros-only-env97 r382))) (map (lambda (x401) (cons (quote macro) (eval-local-transformer144 (chi137 x401 trans-r400 w399 mod385) mod385))) val391)) r382) new-w397 s384 mod385)))))) tmp388) ((lambda (_403) (syntax-violation #f "bad local syntax definition" (source-wrap130 e381 w383 s384 mod385))) tmp387))) ($sc-dispatch tmp387 (quote (any #(each (any any)) any . each-any))))) e381))) (chi-lambda-clause142 (lambda (e404 docstring405 c406 r407 w408 mod409 k410) ((lambda (tmp411) ((lambda (tmp412) (if (if tmp412 (apply (lambda (args413 doc414 e1415 e2416) (and (string? (syntax->datum doc414)) (not docstring405))) tmp412) #f) (apply (lambda (args417 doc418 e1419 e2420) (chi-lambda-clause142 e404 doc418 (cons args417 (cons e1419 e2420)) r407 w408 mod409 k410)) tmp412) ((lambda (tmp422) (if tmp422 (apply (lambda (id423 e1424 e2425) (let ((ids426 id423)) (if (not (valid-bound-ids?126 ids426)) (syntax-violation (quote lambda) "invalid parameter list" e404) (let ((labels428 (gen-labels107 ids426)) (new-vars429 (map gen-var149 ids426))) (k410 new-vars429 docstring405 (chi-body141 (cons e1424 e2425) e404 (extend-var-env96 labels428 new-vars429 r407) (make-binding-wrap118 ids426 labels428 w408) mod409)))))) tmp422) ((lambda (tmp431) (if tmp431 (apply (lambda (ids432 e1433 e2434) (let ((old-ids435 (lambda-var-list150 ids432))) (if (not (valid-bound-ids?126 old-ids435)) (syntax-violation (quote lambda) "invalid parameter list" e404) (let ((labels436 (gen-labels107 old-ids435)) (new-vars437 (map gen-var149 old-ids435))) (k410 (let f438 ((ls1439 (cdr new-vars437)) (ls2440 (car new-vars437))) (if (null? ls1439) ls2440 (f438 (cdr ls1439) (cons (car ls1439) ls2440)))) docstring405 (chi-body141 (cons e1433 e2434) e404 (extend-var-env96 labels436 new-vars437 r407) (make-binding-wrap118 old-ids435 labels436 w408) mod409)))))) tmp431) ((lambda (_442) (syntax-violation (quote lambda) "bad lambda" e404)) tmp411))) ($sc-dispatch tmp411 (quote (any any . each-any)))))) ($sc-dispatch tmp411 (quote (each-any any . each-any)))))) ($sc-dispatch tmp411 (quote (any any any . each-any))))) c406))) (chi-body141 (lambda (body443 outer-form444 r445 w446 mod447) (let ((r448 (cons (quote ("placeholder" placeholder)) r445))) (let ((ribcage449 (make-ribcage108 (quote ()) (quote ()) (quote ())))) (let ((w450 (make-wrap103 (wrap-marks104 w446) (cons ribcage449 (wrap-subst105 w446))))) (let parse451 ((body452 (map (lambda (x458) (cons r448 (wrap129 x458 w450 mod447))) body443)) (ids453 (quote ())) (labels454 (quote ())) (vars455 (quote ())) (vals456 (quote ())) (bindings457 (quote ()))) (if (null? body452) (syntax-violation #f "no expressions in body" outer-form444) (let ((e459 (cdar body452)) (er460 (caar body452))) (call-with-values (lambda () (syntax-type135 e459 er460 (quote (())) #f ribcage449 mod447)) (lambda (type461 value462 e463 w464 s465 mod466) (let ((t467 type461)) (if (memv t467 (quote (define-form))) (let ((id468 (wrap129 value462 w464 mod466)) (label469 (gen-label106))) (let ((var470 (gen-var149 id468))) (begin (extend-ribcage!117 ribcage449 id468 label469) (parse451 (cdr body452) (cons id468 ids453) (cons label469 labels454) (cons var470 vars455) (cons (cons er460 (wrap129 e463 w464 mod466)) vals456) (cons (cons (quote lexical) var470) bindings457))))) (if (memv t467 (quote (define-syntax-form))) (let ((id471 (wrap129 value462 w464 mod466)) (label472 (gen-label106))) (begin (extend-ribcage!117 ribcage449 id471 label472) (parse451 (cdr body452) (cons id471 ids453) (cons label472 labels454) vars455 vals456 (cons (cons (quote macro) (cons er460 (wrap129 e463 w464 mod466))) bindings457)))) (if (memv t467 (quote (begin-form))) ((lambda (tmp473) ((lambda (tmp474) (if tmp474 (apply (lambda (_475 e1476) (parse451 (let f477 ((forms478 e1476)) (if (null? forms478) (cdr body452) (cons (cons er460 (wrap129 (car forms478) w464 mod466)) (f477 (cdr forms478))))) ids453 labels454 vars455 vals456 bindings457)) tmp474) (syntax-violation #f "source expression failed to match any pattern" tmp473))) ($sc-dispatch tmp473 (quote (any . each-any))))) e463) (if (memv t467 (quote (local-syntax-form))) (chi-local-syntax143 value462 e463 er460 w464 s465 mod466 (lambda (forms480 er481 w482 s483 mod484) (parse451 (let f485 ((forms486 forms480)) (if (null? forms486) (cdr body452) (cons (cons er481 (wrap129 (car forms486) w482 mod484)) (f485 (cdr forms486))))) ids453 labels454 vars455 vals456 bindings457))) (if (null? ids453) (build-sequence80 #f (map (lambda (x487) (chi137 (cdr x487) (car x487) (quote (())) mod466)) (cons (cons er460 (source-wrap130 e463 w464 s465 mod466)) (cdr body452)))) (begin (if (not (valid-bound-ids?126 ids453)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form444)) (let loop488 ((bs489 bindings457) (er-cache490 #f) (r-cache491 #f)) (if (not (null? bs489)) (let ((b492 (car bs489))) (if (eq? (car b492) (quote macro)) (let ((er493 (cadr b492))) (let ((r-cache494 (if (eq? er493 er-cache490) r-cache491 (macros-only-env97 er493)))) (begin (set-cdr! b492 (eval-local-transformer144 (chi137 (cddr b492) r-cache494 (quote (())) mod466) mod466)) (loop488 (cdr bs489) er493 r-cache494)))) (loop488 (cdr bs489) er-cache490 r-cache491))))) (set-cdr! r448 (extend-env95 labels454 bindings457 (cdr r448))) (build-letrec83 #f vars455 (map (lambda (x495) (chi137 (cdr x495) (car x495) (quote (())) mod466)) vals456) (build-sequence80 #f (map (lambda (x496) (chi137 (cdr x496) (car x496) (quote (())) mod466)) (cons (cons er460 (source-wrap130 e463 w464 s465 mod466)) (cdr body452)))))))))))))))))))))) (chi-macro140 (lambda (p497 e498 r499 w500 rib501 mod502) (letrec ((rebuild-macro-output503 (lambda (x504 m505) (cond ((pair? x504) (cons (rebuild-macro-output503 (car x504) m505) (rebuild-macro-output503 (cdr x504) m505))) ((syntax-object?85 x504) (let ((w506 (syntax-object-wrap87 x504))) (let ((ms507 (wrap-marks104 w506)) (s508 (wrap-subst105 w506))) (if (and (pair? ms507) (eq? (car ms507) #f)) (make-syntax-object84 (syntax-object-expression86 x504) (make-wrap103 (cdr ms507) (if rib501 (cons rib501 (cdr s508)) (cdr s508))) (syntax-object-module88 x504)) (make-syntax-object84 (syntax-object-expression86 x504) (make-wrap103 (cons m505 ms507) (if rib501 (cons rib501 (cons (quote shift) s508)) (cons (quote shift) s508))) (let ((pmod509 (procedure-module p497))) (if pmod509 (cons (quote hygiene) (module-name pmod509)) (quote (hygiene guile))))))))) ((vector? x504) (let ((n510 (vector-length x504))) (let ((v511 (make-vector n510))) (let doloop512 ((i513 0)) (if (fx=72 i513 n510) v511 (begin (vector-set! v511 i513 (rebuild-macro-output503 (vector-ref x504 i513) m505)) (doloop512 (fx+70 i513 1)))))))) ((symbol? x504) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap130 e498 w500 s mod502) x504)) (else x504))))) (rebuild-macro-output503 (p497 (wrap129 e498 (anti-mark116 w500) mod502)) (string #\m))))) (chi-application139 (lambda (x514 e515 r516 w517 s518 mod519) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (e0522 e1523) (build-annotated78 s518 (cons x514 (map (lambda (e524) (chi137 e524 r516 w517 mod519)) e1523)))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any . each-any))))) e515))) (chi-expr138 (lambda (type526 value527 e528 r529 w530 s531 mod532) (let ((t533 type526)) (if (memv t533 (quote (lexical))) (build-annotated78 s531 value527) (if (memv t533 (quote (core external-macro))) (value527 e528 r529 w530 s531 mod532) (if (memv t533 (quote (module-ref))) (call-with-values (lambda () (value527 e528)) (lambda (id534 mod535) (build-annotated78 s531 (if mod535 (make-module-ref (cdr mod535) id534 (car mod535)) (make-module-ref mod535 id534 (quote bare)))))) (if (memv t533 (quote (lexical-call))) (chi-application139 (build-annotated78 (source-annotation92 (car e528)) value527) e528 r529 w530 s531 mod532) (if (memv t533 (quote (global-call))) (chi-application139 (build-annotated78 (source-annotation92 (car e528)) (if (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532) (make-module-ref (cdr (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532)) value527 (car (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532))) (make-module-ref (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532) value527 (quote bare)))) e528 r529 w530 s531 mod532) (if (memv t533 (quote (constant))) (build-data79 s531 (strip148 (source-wrap130 e528 w530 s531 mod532) (quote (())))) (if (memv t533 (quote (global))) (build-annotated78 s531 (if mod532 (make-module-ref (cdr mod532) value527 (car mod532)) (make-module-ref mod532 value527 (quote bare)))) (if (memv t533 (quote (call))) (chi-application139 (chi137 (car e528) r529 w530 mod532) e528 r529 w530 s531 mod532) (if (memv t533 (quote (begin-form))) ((lambda (tmp536) ((lambda (tmp537) (if tmp537 (apply (lambda (_538 e1539 e2540) (chi-sequence131 (cons e1539 e2540) r529 w530 s531 mod532)) tmp537) (syntax-violation #f "source expression failed to match any pattern" tmp536))) ($sc-dispatch tmp536 (quote (any any . each-any))))) e528) (if (memv t533 (quote (local-syntax-form))) (chi-local-syntax143 value527 e528 r529 w530 s531 mod532 chi-sequence131) (if (memv t533 (quote (eval-when-form))) ((lambda (tmp542) ((lambda (tmp543) (if tmp543 (apply (lambda (_544 x545 e1546 e2547) (let ((when-list548 (chi-when-list134 e528 x545 w530))) (if (memq (quote eval) when-list548) (chi-sequence131 (cons e1546 e2547) r529 w530 s531 mod532) (chi-void145)))) tmp543) (syntax-violation #f "source expression failed to match any pattern" tmp542))) ($sc-dispatch tmp542 (quote (any each-any any . each-any))))) e528) (if (memv t533 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e528 (wrap129 value527 w530 mod532)) (if (memv t533 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap130 e528 w530 s531 mod532)) (if (memv t533 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap130 e528 w530 s531 mod532)) (syntax-violation #f "unexpected syntax" (source-wrap130 e528 w530 s531 mod532))))))))))))))))))) (chi137 (lambda (e551 r552 w553 mod554) (call-with-values (lambda () (syntax-type135 e551 r552 w553 #f #f mod554)) (lambda (type555 value556 e557 w558 s559 mod560) (chi-expr138 type555 value556 e557 r552 w558 s559 mod560))))) (chi-top136 (lambda (e561 r562 w563 m564 esew565 mod566) (call-with-values (lambda () (syntax-type135 e561 r562 w563 #f #f mod566)) (lambda (type574 value575 e576 w577 s578 mod579) (let ((t580 type574)) (if (memv t580 (quote (begin-form))) ((lambda (tmp581) ((lambda (tmp582) (if tmp582 (apply (lambda (_583) (chi-void145)) tmp582) ((lambda (tmp584) (if tmp584 (apply (lambda (_585 e1586 e2587) (chi-top-sequence132 (cons e1586 e2587) r562 w577 s578 m564 esew565 mod579)) tmp584) (syntax-violation #f "source expression failed to match any pattern" tmp581))) ($sc-dispatch tmp581 (quote (any any . each-any)))))) ($sc-dispatch tmp581 (quote (any))))) e576) (if (memv t580 (quote (local-syntax-form))) (chi-local-syntax143 value575 e576 r562 w577 s578 mod579 (lambda (body589 r590 w591 s592 mod593) (chi-top-sequence132 body589 r590 w591 s592 m564 esew565 mod593))) (if (memv t580 (quote (eval-when-form))) ((lambda (tmp594) ((lambda (tmp595) (if tmp595 (apply (lambda (_596 x597 e1598 e2599) (let ((when-list600 (chi-when-list134 e576 x597 w577)) (body601 (cons e1598 e2599))) (cond ((eq? m564 (quote e)) (if (memq (quote eval) when-list600) (chi-top-sequence132 body601 r562 w577 s578 (quote e) (quote (eval)) mod579) (chi-void145))) ((memq (quote load) when-list600) (if (or (memq (quote compile) when-list600) (and (eq? m564 (quote c&e)) (memq (quote eval) when-list600))) (chi-top-sequence132 body601 r562 w577 s578 (quote c&e) (quote (compile load)) mod579) (if (memq m564 (quote (c c&e))) (chi-top-sequence132 body601 r562 w577 s578 (quote c) (quote (load)) mod579) (chi-void145)))) ((or (memq (quote compile) when-list600) (and (eq? m564 (quote c&e)) (memq (quote eval) when-list600))) (top-level-eval-hook74 (chi-top-sequence132 body601 r562 w577 s578 (quote e) (quote (eval)) mod579) mod579) (chi-void145)) (else (chi-void145))))) tmp595) (syntax-violation #f "source expression failed to match any pattern" tmp594))) ($sc-dispatch tmp594 (quote (any each-any any . each-any))))) e576) (if (memv t580 (quote (define-syntax-form))) (let ((n604 (id-var-name123 value575 w577)) (r605 (macros-only-env97 r562))) (let ((t606 m564)) (if (memv t606 (quote (c))) (if (memq (quote compile) esew565) (let ((e607 (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)))) (begin (top-level-eval-hook74 e607 mod579) (if (memq (quote load) esew565) e607 (chi-void145)))) (if (memq (quote load) esew565) (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)) (chi-void145))) (if (memv t606 (quote (c&e))) (let ((e608 (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)))) (begin (top-level-eval-hook74 e608 mod579) e608)) (begin (if (memq (quote eval) esew565) (top-level-eval-hook74 (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)) mod579)) (chi-void145)))))) (if (memv t580 (quote (define-form))) (let ((n609 (id-var-name123 value575 w577))) (let ((type610 (binding-type93 (lookup98 n609 r562 mod579)))) (let ((t611 type610)) (if (memv t611 (quote (global core macro module-ref))) (let ((x612 (build-annotated78 s578 (list (quote define) n609 (chi137 e576 r562 w577 mod579))))) (begin (if (eq? m564 (quote c&e)) (top-level-eval-hook74 x612 mod579)) x612)) (if (memv t611 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e576 (wrap129 value575 w577 mod579)) (syntax-violation #f "cannot define keyword at top level" e576 (wrap129 value575 w577 mod579))))))) (let ((x613 (chi-expr138 type574 value575 e576 r562 w577 s578 mod579))) (begin (if (eq? m564 (quote c&e)) (top-level-eval-hook74 x613 mod579)) x613)))))))))))) (syntax-type135 (lambda (e614 r615 w616 s617 rib618 mod619) (cond ((symbol? e614) (let ((n620 (id-var-name123 e614 w616))) (let ((b621 (lookup98 n620 r615 mod619))) (let ((type622 (binding-type93 b621))) (let ((t623 type622)) (if (memv t623 (quote (lexical))) (values type622 (binding-value94 b621) e614 w616 s617 mod619) (if (memv t623 (quote (global))) (values type622 n620 e614 w616 s617 mod619) (if (memv t623 (quote (macro))) (syntax-type135 (chi-macro140 (binding-value94 b621) e614 r615 w616 rib618 mod619) r615 (quote (())) s617 rib618 mod619) (values type622 (binding-value94 b621) e614 w616 s617 mod619))))))))) ((pair? e614) (let ((first624 (car e614))) (if (id?101 first624) (let ((n625 (id-var-name123 first624 w616))) (let ((b626 (lookup98 n625 r615 (or (and (syntax-object?85 first624) (syntax-object-module88 first624)) mod619)))) (let ((type627 (binding-type93 b626))) (let ((t628 type627)) (if (memv t628 (quote (lexical))) (values (quote lexical-call) (binding-value94 b626) e614 w616 s617 mod619) (if (memv t628 (quote (global))) (values (quote global-call) n625 e614 w616 s617 mod619) (if (memv t628 (quote (macro))) (syntax-type135 (chi-macro140 (binding-value94 b626) e614 r615 w616 rib618 mod619) r615 (quote (())) s617 rib618 mod619) (if (memv t628 (quote (core external-macro module-ref))) (values type627 (binding-value94 b626) e614 w616 s617 mod619) (if (memv t628 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value94 b626) e614 w616 s617 mod619) (if (memv t628 (quote (begin))) (values (quote begin-form) #f e614 w616 s617 mod619) (if (memv t628 (quote (eval-when))) (values (quote eval-when-form) #f e614 w616 s617 mod619) (if (memv t628 (quote (define))) ((lambda (tmp629) ((lambda (tmp630) (if (if tmp630 (apply (lambda (_631 name632 val633) (id?101 name632)) tmp630) #f) (apply (lambda (_634 name635 val636) (values (quote define-form) name635 val636 w616 s617 mod619)) tmp630) ((lambda (tmp637) (if (if tmp637 (apply (lambda (_638 name639 args640 e1641 e2642) (and (id?101 name639) (valid-bound-ids?126 (lambda-var-list150 args640)))) tmp637) #f) (apply (lambda (_643 name644 args645 e1646 e2647) (values (quote define-form) (wrap129 name644 w616 mod619) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap129 (cons args645 (cons e1646 e2647)) w616 mod619)) (quote (())) s617 mod619)) tmp637) ((lambda (tmp649) (if (if tmp649 (apply (lambda (_650 name651) (id?101 name651)) tmp649) #f) (apply (lambda (_652 name653) (values (quote define-form) (wrap129 name653 w616 mod619) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s617 mod619)) tmp649) (syntax-violation #f "source expression failed to match any pattern" tmp629))) ($sc-dispatch tmp629 (quote (any any)))))) ($sc-dispatch tmp629 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp629 (quote (any any any))))) e614) (if (memv t628 (quote (define-syntax))) ((lambda (tmp654) ((lambda (tmp655) (if (if tmp655 (apply (lambda (_656 name657 val658) (id?101 name657)) tmp655) #f) (apply (lambda (_659 name660 val661) (values (quote define-syntax-form) name660 val661 w616 s617 mod619)) tmp655) (syntax-violation #f "source expression failed to match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any any any))))) e614) (values (quote call) #f e614 w616 s617 mod619)))))))))))))) (values (quote call) #f e614 w616 s617 mod619)))) ((syntax-object?85 e614) (syntax-type135 (syntax-object-expression86 e614) r615 (join-wraps120 w616 (syntax-object-wrap87 e614)) #f rib618 (or (syntax-object-module88 e614) mod619))) ((annotation? e614) (syntax-type135 (annotation-expression e614) r615 w616 (annotation-source e614) rib618 mod619)) ((self-evaluating? e614) (values (quote constant) #f e614 w616 s617 mod619)) (else (values (quote other) #f e614 w616 s617 mod619))))) (chi-when-list134 (lambda (e662 when-list663 w664) (let f665 ((when-list666 when-list663) (situations667 (quote ()))) (if (null? when-list666) situations667 (f665 (cdr when-list666) (cons (let ((x668 (car when-list666))) (cond ((free-id=?124 x668 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?124 x668 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?124 x668 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e662 (wrap129 x668 w664 #f))))) situations667)))))) (chi-install-global133 (lambda (name669 e670) (build-annotated78 #f (list (build-annotated78 #f (quote define)) name669 (if (let ((v671 (module-variable (current-module) name669))) (and v671 (variable-bound? v671) (macro? (variable-ref v671)) (not (eq? (macro-type (variable-ref v671)) (quote syncase-macro))))) (build-annotated78 #f (list (build-annotated78 #f (quote make-extended-syncase-macro)) (build-annotated78 #f (list (build-annotated78 #f (quote module-ref)) (build-annotated78 #f (quote (current-module))) (build-data79 #f name669))) (build-data79 #f (quote macro)) e670)) (build-annotated78 #f (list (build-annotated78 #f (quote make-syncase-macro)) (build-data79 #f (quote macro)) e670))))))) (chi-top-sequence132 (lambda (body672 r673 w674 s675 m676 esew677 mod678) (build-sequence80 s675 (let dobody679 ((body680 body672) (r681 r673) (w682 w674) (m683 m676) (esew684 esew677) (mod685 mod678)) (if (null? body680) (quote ()) (let ((first686 (chi-top136 (car body680) r681 w682 m683 esew684 mod685))) (cons first686 (dobody679 (cdr body680) r681 w682 m683 esew684 mod685)))))))) (chi-sequence131 (lambda (body687 r688 w689 s690 mod691) (build-sequence80 s690 (let dobody692 ((body693 body687) (r694 r688) (w695 w689) (mod696 mod691)) (if (null? body693) (quote ()) (let ((first697 (chi137 (car body693) r694 w695 mod696))) (cons first697 (dobody692 (cdr body693) r694 w695 mod696)))))))) (source-wrap130 (lambda (x698 w699 s700 defmod701) (wrap129 (if s700 (make-annotation x698 s700 #f) x698) w699 defmod701))) (wrap129 (lambda (x702 w703 defmod704) (cond ((and (null? (wrap-marks104 w703)) (null? (wrap-subst105 w703))) x702) ((syntax-object?85 x702) (make-syntax-object84 (syntax-object-expression86 x702) (join-wraps120 w703 (syntax-object-wrap87 x702)) (syntax-object-module88 x702))) ((null? x702) x702) (else (make-syntax-object84 x702 w703 defmod704))))) (bound-id-member?128 (lambda (x705 list706) (and (not (null? list706)) (or (bound-id=?125 x705 (car list706)) (bound-id-member?128 x705 (cdr list706)))))) (distinct-bound-ids?127 (lambda (ids707) (let distinct?708 ((ids709 ids707)) (or (null? ids709) (and (not (bound-id-member?128 (car ids709) (cdr ids709))) (distinct?708 (cdr ids709))))))) (valid-bound-ids?126 (lambda (ids710) (and (let all-ids?711 ((ids712 ids710)) (or (null? ids712) (and (id?101 (car ids712)) (all-ids?711 (cdr ids712))))) (distinct-bound-ids?127 ids710)))) (bound-id=?125 (lambda (i713 j714) (if (and (syntax-object?85 i713) (syntax-object?85 j714)) (and (eq? (let ((e715 (syntax-object-expression86 i713))) (if (annotation? e715) (annotation-expression e715) e715)) (let ((e716 (syntax-object-expression86 j714))) (if (annotation? e716) (annotation-expression e716) e716))) (same-marks?122 (wrap-marks104 (syntax-object-wrap87 i713)) (wrap-marks104 (syntax-object-wrap87 j714)))) (eq? (let ((e717 i713)) (if (annotation? e717) (annotation-expression e717) e717)) (let ((e718 j714)) (if (annotation? e718) (annotation-expression e718) e718)))))) (free-id=?124 (lambda (i719 j720) (and (eq? (let ((x721 i719)) (let ((e722 (if (syntax-object?85 x721) (syntax-object-expression86 x721) x721))) (if (annotation? e722) (annotation-expression e722) e722))) (let ((x723 j720)) (let ((e724 (if (syntax-object?85 x723) (syntax-object-expression86 x723) x723))) (if (annotation? e724) (annotation-expression e724) e724)))) (eq? (id-var-name123 i719 (quote (()))) (id-var-name123 j720 (quote (()))))))) (id-var-name123 (lambda (id725 w726) (letrec ((search-vector-rib729 (lambda (sym735 subst736 marks737 symnames738 ribcage739) (let ((n740 (vector-length symnames738))) (let f741 ((i742 0)) (cond ((fx=72 i742 n740) (search727 sym735 (cdr subst736) marks737)) ((and (eq? (vector-ref symnames738 i742) sym735) (same-marks?122 marks737 (vector-ref (ribcage-marks111 ribcage739) i742))) (values (vector-ref (ribcage-labels112 ribcage739) i742) marks737)) (else (f741 (fx+70 i742 1)))))))) (search-list-rib728 (lambda (sym743 subst744 marks745 symnames746 ribcage747) (let f748 ((symnames749 symnames746) (i750 0)) (cond ((null? symnames749) (search727 sym743 (cdr subst744) marks745)) ((and (eq? (car symnames749) sym743) (same-marks?122 marks745 (list-ref (ribcage-marks111 ribcage747) i750))) (values (list-ref (ribcage-labels112 ribcage747) i750) marks745)) (else (f748 (cdr symnames749) (fx+70 i750 1))))))) (search727 (lambda (sym751 subst752 marks753) (if (null? subst752) (values #f marks753) (let ((fst754 (car subst752))) (if (eq? fst754 (quote shift)) (search727 sym751 (cdr subst752) (cdr marks753)) (let ((symnames755 (ribcage-symnames110 fst754))) (if (vector? symnames755) (search-vector-rib729 sym751 subst752 marks753 symnames755 fst754) (search-list-rib728 sym751 subst752 marks753 symnames755 fst754))))))))) (cond ((symbol? id725) (or (call-with-values (lambda () (search727 id725 (wrap-subst105 w726) (wrap-marks104 w726))) (lambda (x757 . ignore756) x757)) id725)) ((syntax-object?85 id725) (let ((id758 (let ((e760 (syntax-object-expression86 id725))) (if (annotation? e760) (annotation-expression e760) e760))) (w1759 (syntax-object-wrap87 id725))) (let ((marks761 (join-marks121 (wrap-marks104 w726) (wrap-marks104 w1759)))) (call-with-values (lambda () (search727 id758 (wrap-subst105 w726) marks761)) (lambda (new-id762 marks763) (or new-id762 (call-with-values (lambda () (search727 id758 (wrap-subst105 w1759) marks763)) (lambda (x765 . ignore764) x765)) id758)))))) ((annotation? id725) (let ((id766 (let ((e767 id725)) (if (annotation? e767) (annotation-expression e767) e767)))) (or (call-with-values (lambda () (search727 id766 (wrap-subst105 w726) (wrap-marks104 w726))) (lambda (x769 . ignore768) x769)) id766))) (else (syntax-violation (quote id-var-name) "invalid id" id725)))))) (same-marks?122 (lambda (x770 y771) (or (eq? x770 y771) (and (not (null? x770)) (not (null? y771)) (eq? (car x770) (car y771)) (same-marks?122 (cdr x770) (cdr y771)))))) (join-marks121 (lambda (m1772 m2773) (smart-append119 m1772 m2773))) (join-wraps120 (lambda (w1774 w2775) (let ((m1776 (wrap-marks104 w1774)) (s1777 (wrap-subst105 w1774))) (if (null? m1776) (if (null? s1777) w2775 (make-wrap103 (wrap-marks104 w2775) (smart-append119 s1777 (wrap-subst105 w2775)))) (make-wrap103 (smart-append119 m1776 (wrap-marks104 w2775)) (smart-append119 s1777 (wrap-subst105 w2775))))))) (smart-append119 (lambda (m1778 m2779) (if (null? m2779) m1778 (append m1778 m2779)))) (make-binding-wrap118 (lambda (ids780 labels781 w782) (if (null? ids780) w782 (make-wrap103 (wrap-marks104 w782) (cons (let ((labelvec783 (list->vector labels781))) (let ((n784 (vector-length labelvec783))) (let ((symnamevec785 (make-vector n784)) (marksvec786 (make-vector n784))) (begin (let f787 ((ids788 ids780) (i789 0)) (if (not (null? ids788)) (call-with-values (lambda () (id-sym-name&marks102 (car ids788) w782)) (lambda (symname790 marks791) (begin (vector-set! symnamevec785 i789 symname790) (vector-set! marksvec786 i789 marks791) (f787 (cdr ids788) (fx+70 i789 1))))))) (make-ribcage108 symnamevec785 marksvec786 labelvec783))))) (wrap-subst105 w782)))))) (extend-ribcage!117 (lambda (ribcage792 id793 label794) (begin (set-ribcage-symnames!113 ribcage792 (cons (let ((e795 (syntax-object-expression86 id793))) (if (annotation? e795) (annotation-expression e795) e795)) (ribcage-symnames110 ribcage792))) (set-ribcage-marks!114 ribcage792 (cons (wrap-marks104 (syntax-object-wrap87 id793)) (ribcage-marks111 ribcage792))) (set-ribcage-labels!115 ribcage792 (cons label794 (ribcage-labels112 ribcage792)))))) (anti-mark116 (lambda (w796) (make-wrap103 (cons #f (wrap-marks104 w796)) (cons (quote shift) (wrap-subst105 w796))))) (set-ribcage-labels!115 (lambda (x797 update798) (vector-set! x797 3 update798))) (set-ribcage-marks!114 (lambda (x799 update800) (vector-set! x799 2 update800))) (set-ribcage-symnames!113 (lambda (x801 update802) (vector-set! x801 1 update802))) (ribcage-labels112 (lambda (x803) (vector-ref x803 3))) (ribcage-marks111 (lambda (x804) (vector-ref x804 2))) (ribcage-symnames110 (lambda (x805) (vector-ref x805 1))) (ribcage?109 (lambda (x806) (and (vector? x806) (= (vector-length x806) 4) (eq? (vector-ref x806 0) (quote ribcage))))) (make-ribcage108 (lambda (symnames807 marks808 labels809) (vector (quote ribcage) symnames807 marks808 labels809))) (gen-labels107 (lambda (ls810) (if (null? ls810) (quote ()) (cons (gen-label106) (gen-labels107 (cdr ls810)))))) (gen-label106 (lambda () (string #\i))) (wrap-subst105 cdr) (wrap-marks104 car) (make-wrap103 cons) (id-sym-name&marks102 (lambda (x811 w812) (if (syntax-object?85 x811) (values (let ((e813 (syntax-object-expression86 x811))) (if (annotation? e813) (annotation-expression e813) e813)) (join-marks121 (wrap-marks104 w812) (wrap-marks104 (syntax-object-wrap87 x811)))) (values (let ((e814 x811)) (if (annotation? e814) (annotation-expression e814) e814)) (wrap-marks104 w812))))) (id?101 (lambda (x815) (cond ((symbol? x815) #t) ((syntax-object?85 x815) (symbol? (let ((e816 (syntax-object-expression86 x815))) (if (annotation? e816) (annotation-expression e816) e816)))) ((annotation? x815) (symbol? (annotation-expression x815))) (else #f)))) (nonsymbol-id?100 (lambda (x817) (and (syntax-object?85 x817) (symbol? (let ((e818 (syntax-object-expression86 x817))) (if (annotation? e818) (annotation-expression e818) e818)))))) (global-extend99 (lambda (type819 sym820 val821) (put-global-definition-hook76 sym820 type819 val821))) (lookup98 (lambda (x822 r823 mod824) (cond ((assq x822 r823) => cdr) ((symbol? x822) (or (get-global-definition-hook77 x822 mod824) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env97 (lambda (r825) (if (null? r825) (quote ()) (let ((a826 (car r825))) (if (eq? (cadr a826) (quote macro)) (cons a826 (macros-only-env97 (cdr r825))) (macros-only-env97 (cdr r825))))))) (extend-var-env96 (lambda (labels827 vars828 r829) (if (null? labels827) r829 (extend-var-env96 (cdr labels827) (cdr vars828) (cons (cons (car labels827) (cons (quote lexical) (car vars828))) r829))))) (extend-env95 (lambda (labels830 bindings831 r832) (if (null? labels830) r832 (extend-env95 (cdr labels830) (cdr bindings831) (cons (cons (car labels830) (car bindings831)) r832))))) (binding-value94 cdr) (binding-type93 car) (source-annotation92 (lambda (x833) (cond ((annotation? x833) (annotation-source x833)) ((syntax-object?85 x833) (source-annotation92 (syntax-object-expression86 x833))) (else #f)))) (set-syntax-object-module!91 (lambda (x834 update835) (vector-set! x834 3 update835))) (set-syntax-object-wrap!90 (lambda (x836 update837) (vector-set! x836 2 update837))) (set-syntax-object-expression!89 (lambda (x838 update839) (vector-set! x838 1 update839))) (syntax-object-module88 (lambda (x840) (vector-ref x840 3))) (syntax-object-wrap87 (lambda (x841) (vector-ref x841 2))) (syntax-object-expression86 (lambda (x842) (vector-ref x842 1))) (syntax-object?85 (lambda (x843) (and (vector? x843) (= (vector-length x843) 4) (eq? (vector-ref x843 0) (quote syntax-object))))) (make-syntax-object84 (lambda (expression844 wrap845 module846) (vector (quote syntax-object) expression844 wrap845 module846))) (build-letrec83 (lambda (src847 vars848 val-exps849 body-exp850) (if (null? vars848) (build-annotated78 src847 body-exp850) (build-annotated78 src847 (list (quote letrec) (map list vars848 val-exps849) body-exp850))))) (build-named-let82 (lambda (src851 vars852 val-exps853 body-exp854) (if (null? vars852) (build-annotated78 src851 body-exp854) (build-annotated78 src851 (list (quote let) (car vars852) (map list (cdr vars852) val-exps853) body-exp854))))) (build-let81 (lambda (src855 vars856 val-exps857 body-exp858) (if (null? vars856) (build-annotated78 src855 body-exp858) (build-annotated78 src855 (list (quote let) (map list vars856 val-exps857) body-exp858))))) (build-sequence80 (lambda (src859 exps860) (if (null? (cdr exps860)) (build-annotated78 src859 (car exps860)) (build-annotated78 src859 (cons (quote begin) exps860))))) (build-data79 (lambda (src861 exp862) (if (and (self-evaluating? exp862) (not (vector? exp862))) (build-annotated78 src861 exp862) (build-annotated78 src861 (list (quote quote) exp862))))) (build-annotated78 (lambda (src863 exp864) (if (and src863 (not (annotation? exp864))) (make-annotation exp864 src863 #t) exp864))) (get-global-definition-hook77 (lambda (symbol865 module866) (begin (if (and (not module866) (current-module)) (warn "module system is booted, we should have a module" symbol865)) (let ((v867 (module-variable (if module866 (resolve-module (cdr module866)) (current-module)) symbol865))) (and v867 (variable-bound? v867) (let ((val868 (variable-ref v867))) (and (macro? val868) (syncase-macro-type val868) (cons (syncase-macro-type val868) (syncase-macro-binding val868))))))))) (put-global-definition-hook76 (lambda (symbol869 type870 val871) (let ((existing872 (let ((v873 (module-variable (current-module) symbol869))) (and v873 (variable-bound? v873) (let ((val874 (variable-ref v873))) (and (macro? val874) (not (syncase-macro-type val874)) val874)))))) (module-define! (current-module) symbol869 (if existing872 (make-extended-syncase-macro existing872 type870 val871) (make-syncase-macro type870 val871)))))) (local-eval-hook75 (lambda (x875 mod876) (primitive-eval (list noexpand69 x875)))) (top-level-eval-hook74 (lambda (x877 mod878) (primitive-eval (list noexpand69 x877)))) (fx<73 <) (fx=72 =) (fx-71 -) (fx+70 +) (noexpand69 "noexpand")) (begin (global-extend99 (quote local-syntax) (quote letrec-syntax) #t) (global-extend99 (quote local-syntax) (quote let-syntax) #f) (global-extend99 (quote core) (quote fluid-let-syntax) (lambda (e879 r880 w881 s882 mod883) ((lambda (tmp884) ((lambda (tmp885) (if (if tmp885 (apply (lambda (_886 var887 val888 e1889 e2890) (valid-bound-ids?126 var887)) tmp885) #f) (apply (lambda (_892 var893 val894 e1895 e2896) (let ((names897 (map (lambda (x898) (id-var-name123 x898 w881)) var893))) (begin (for-each (lambda (id900 n901) (let ((t902 (binding-type93 (lookup98 n901 r880 mod883)))) (if (memv t902 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e879 (source-wrap130 id900 w881 s882 mod883))))) var893 names897) (chi-body141 (cons e1895 e2896) (source-wrap130 e879 w881 s882 mod883) (extend-env95 names897 (let ((trans-r905 (macros-only-env97 r880))) (map (lambda (x906) (cons (quote macro) (eval-local-transformer144 (chi137 x906 trans-r905 w881 mod883) mod883))) val894)) r880) w881 mod883)))) tmp885) ((lambda (_908) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap130 e879 w881 s882 mod883))) tmp884))) ($sc-dispatch tmp884 (quote (any #(each (any any)) any . each-any))))) e879))) (global-extend99 (quote core) (quote quote) (lambda (e909 r910 w911 s912 mod913) ((lambda (tmp914) ((lambda (tmp915) (if tmp915 (apply (lambda (_916 e917) (build-data79 s912 (strip148 e917 w911))) tmp915) ((lambda (_918) (syntax-violation (quote quote) "bad syntax" (source-wrap130 e909 w911 s912 mod913))) tmp914))) ($sc-dispatch tmp914 (quote (any any))))) e909))) (global-extend99 (quote core) (quote syntax) (letrec ((regen926 (lambda (x927) (let ((t928 (car x927))) (if (memv t928 (quote (ref))) (build-annotated78 #f (cadr x927)) (if (memv t928 (quote (primitive))) (build-annotated78 #f (cadr x927)) (if (memv t928 (quote (quote))) (build-data79 #f (cadr x927)) (if (memv t928 (quote (lambda))) (build-annotated78 #f (list (quote lambda) (cadr x927) (regen926 (caddr x927)))) (if (memv t928 (quote (map))) (let ((ls929 (map regen926 (cdr x927)))) (build-annotated78 #f (cons (if (fx=72 (length ls929) 2) (build-annotated78 #f (quote map)) (build-annotated78 #f (quote map))) ls929))) (build-annotated78 #f (cons (build-annotated78 #f (car x927)) (map regen926 (cdr x927)))))))))))) (gen-vector925 (lambda (x930) (cond ((eq? (car x930) (quote list)) (cons (quote vector) (cdr x930))) ((eq? (car x930) (quote quote)) (list (quote quote) (list->vector (cadr x930)))) (else (list (quote list->vector) x930))))) (gen-append924 (lambda (x931 y932) (if (equal? y932 (quote (quote ()))) x931 (list (quote append) x931 y932)))) (gen-cons923 (lambda (x933 y934) (let ((t935 (car y934))) (if (memv t935 (quote (quote))) (if (eq? (car x933) (quote quote)) (list (quote quote) (cons (cadr x933) (cadr y934))) (if (eq? (cadr y934) (quote ())) (list (quote list) x933) (list (quote cons) x933 y934))) (if (memv t935 (quote (list))) (cons (quote list) (cons x933 (cdr y934))) (list (quote cons) x933 y934)))))) (gen-map922 (lambda (e936 map-env937) (let ((formals938 (map cdr map-env937)) (actuals939 (map (lambda (x940) (list (quote ref) (car x940))) map-env937))) (cond ((eq? (car e936) (quote ref)) (car actuals939)) ((and-map (lambda (x941) (and (eq? (car x941) (quote ref)) (memq (cadr x941) formals938))) (cdr e936)) (cons (quote map) (cons (list (quote primitive) (car e936)) (map (let ((r942 (map cons formals938 actuals939))) (lambda (x943) (cdr (assq (cadr x943) r942)))) (cdr e936))))) (else (cons (quote map) (cons (list (quote lambda) formals938 e936) actuals939))))))) (gen-mappend921 (lambda (e944 map-env945) (list (quote apply) (quote (primitive append)) (gen-map922 e944 map-env945)))) (gen-ref920 (lambda (src946 var947 level948 maps949) (if (fx=72 level948 0) (values var947 maps949) (if (null? maps949) (syntax-violation (quote syntax) "missing ellipsis" src946) (call-with-values (lambda () (gen-ref920 src946 var947 (fx-71 level948 1) (cdr maps949))) (lambda (outer-var950 outer-maps951) (let ((b952 (assq outer-var950 (car maps949)))) (if b952 (values (cdr b952) maps949) (let ((inner-var953 (gen-var149 (quote tmp)))) (values inner-var953 (cons (cons (cons outer-var950 inner-var953) (car maps949)) outer-maps951))))))))))) (gen-syntax919 (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) (if (id?101 e955) (let ((label960 (id-var-name123 e955 (quote (()))))) (let ((b961 (lookup98 label960 r956 mod959))) (if (eq? (binding-type93 b961) (quote syntax)) (call-with-values (lambda () (let ((var.lev962 (binding-value94 b961))) (gen-ref920 src954 (car var.lev962) (cdr var.lev962) maps957))) (lambda (var963 maps964) (values (list (quote ref) var963) maps964))) (if (ellipsis?958 e955) (syntax-violation (quote syntax) "misplaced ellipsis" src954) (values (list (quote quote) e955) maps957))))) ((lambda (tmp965) ((lambda (tmp966) (if (if tmp966 (apply (lambda (dots967 e968) (ellipsis?958 dots967)) tmp966) #f) (apply (lambda (dots969 e970) (gen-syntax919 src954 e970 r956 maps957 (lambda (x971) #f) mod959)) tmp966) ((lambda (tmp972) (if (if tmp972 (apply (lambda (x973 dots974 y975) (ellipsis?958 dots974)) tmp972) #f) (apply (lambda (x976 dots977 y978) (let f979 ((y980 y978) (k981 (lambda (maps982) (call-with-values (lambda () (gen-syntax919 src954 x976 r956 (cons (quote ()) maps982) ellipsis?958 mod959)) (lambda (x983 maps984) (if (null? (car maps984)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-map922 x983 (car maps984)) (cdr maps984)))))))) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 y988) (ellipsis?958 dots987)) tmp986) #f) (apply (lambda (dots989 y990) (f979 y990 (lambda (maps991) (call-with-values (lambda () (k981 (cons (quote ()) maps991))) (lambda (x992 maps993) (if (null? (car maps993)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-mappend921 x992 (car maps993)) (cdr maps993)))))))) tmp986) ((lambda (_994) (call-with-values (lambda () (gen-syntax919 src954 y980 r956 maps957 ellipsis?958 mod959)) (lambda (y995 maps996) (call-with-values (lambda () (k981 maps996)) (lambda (x997 maps998) (values (gen-append924 x997 y995) maps998)))))) tmp985))) ($sc-dispatch tmp985 (quote (any . any))))) y980))) tmp972) ((lambda (tmp999) (if tmp999 (apply (lambda (x1000 y1001) (call-with-values (lambda () (gen-syntax919 src954 x1000 r956 maps957 ellipsis?958 mod959)) (lambda (x1002 maps1003) (call-with-values (lambda () (gen-syntax919 src954 y1001 r956 maps1003 ellipsis?958 mod959)) (lambda (y1004 maps1005) (values (gen-cons923 x1002 y1004) maps1005)))))) tmp999) ((lambda (tmp1006) (if tmp1006 (apply (lambda (e11007 e21008) (call-with-values (lambda () (gen-syntax919 src954 (cons e11007 e21008) r956 maps957 ellipsis?958 mod959)) (lambda (e1010 maps1011) (values (gen-vector925 e1010) maps1011)))) tmp1006) ((lambda (_1012) (values (list (quote quote) e955) maps957)) tmp965))) ($sc-dispatch tmp965 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp965 (quote (any . any)))))) ($sc-dispatch tmp965 (quote (any any . any)))))) ($sc-dispatch tmp965 (quote (any any))))) e955))))) (lambda (e1013 r1014 w1015 s1016 mod1017) (let ((e1018 (source-wrap130 e1013 w1015 s1016 mod1017))) ((lambda (tmp1019) ((lambda (tmp1020) (if tmp1020 (apply (lambda (_1021 x1022) (call-with-values (lambda () (gen-syntax919 e1018 x1022 r1014 (quote ()) ellipsis?146 mod1017)) (lambda (e1023 maps1024) (regen926 e1023)))) tmp1020) ((lambda (_1025) (syntax-violation (quote syntax) "bad `syntax' form" e1018)) tmp1019))) ($sc-dispatch tmp1019 (quote (any any))))) e1018))))) (global-extend99 (quote core) (quote lambda) (lambda (e1026 r1027 w1028 s1029 mod1030) ((lambda (tmp1031) ((lambda (tmp1032) (if tmp1032 (apply (lambda (_1033 c1034) (chi-lambda-clause142 (source-wrap130 e1026 w1028 s1029 mod1030) #f c1034 r1027 w1028 mod1030 (lambda (vars1035 docstring1036 body1037) (build-annotated78 s1029 (cons (quote lambda) (cons vars1035 (append (if docstring1036 (list docstring1036) (quote ())) (list body1037)))))))) tmp1032) (syntax-violation #f "source expression failed to match any pattern" tmp1031))) ($sc-dispatch tmp1031 (quote (any . any))))) e1026))) (global-extend99 (quote core) (quote let) (letrec ((chi-let1038 (lambda (e1039 r1040 w1041 s1042 mod1043 constructor1044 ids1045 vals1046 exps1047) (if (not (valid-bound-ids?126 ids1045)) (syntax-violation (quote let) "duplicate bound variable" e1039) (let ((labels1048 (gen-labels107 ids1045)) (new-vars1049 (map gen-var149 ids1045))) (let ((nw1050 (make-binding-wrap118 ids1045 labels1048 w1041)) (nr1051 (extend-var-env96 labels1048 new-vars1049 r1040))) (constructor1044 s1042 new-vars1049 (map (lambda (x1052) (chi137 x1052 r1040 w1041 mod1043)) vals1046) (chi-body141 exps1047 (source-wrap130 e1039 nw1050 s1042 mod1043) nr1051 nw1050 mod1043)))))))) (lambda (e1053 r1054 w1055 s1056 mod1057) ((lambda (tmp1058) ((lambda (tmp1059) (if tmp1059 (apply (lambda (_1060 id1061 val1062 e11063 e21064) (chi-let1038 e1053 r1054 w1055 s1056 mod1057 build-let81 id1061 val1062 (cons e11063 e21064))) tmp1059) ((lambda (tmp1068) (if (if tmp1068 (apply (lambda (_1069 f1070 id1071 val1072 e11073 e21074) (id?101 f1070)) tmp1068) #f) (apply (lambda (_1075 f1076 id1077 val1078 e11079 e21080) (chi-let1038 e1053 r1054 w1055 s1056 mod1057 build-named-let82 (cons f1076 id1077) val1078 (cons e11079 e21080))) tmp1068) ((lambda (_1084) (syntax-violation (quote let) "bad let" (source-wrap130 e1053 w1055 s1056 mod1057))) tmp1058))) ($sc-dispatch tmp1058 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1058 (quote (any #(each (any any)) any . each-any))))) e1053)))) (global-extend99 (quote core) (quote letrec) (lambda (e1085 r1086 w1087 s1088 mod1089) ((lambda (tmp1090) ((lambda (tmp1091) (if tmp1091 (apply (lambda (_1092 id1093 val1094 e11095 e21096) (let ((ids1097 id1093)) (if (not (valid-bound-ids?126 ids1097)) (syntax-violation (quote letrec) "duplicate bound variable" e1085) (let ((labels1099 (gen-labels107 ids1097)) (new-vars1100 (map gen-var149 ids1097))) (let ((w1101 (make-binding-wrap118 ids1097 labels1099 w1087)) (r1102 (extend-var-env96 labels1099 new-vars1100 r1086))) (build-letrec83 s1088 new-vars1100 (map (lambda (x1103) (chi137 x1103 r1102 w1101 mod1089)) val1094) (chi-body141 (cons e11095 e21096) (source-wrap130 e1085 w1101 s1088 mod1089) r1102 w1101 mod1089))))))) tmp1091) ((lambda (_1106) (syntax-violation (quote letrec) "bad letrec" (source-wrap130 e1085 w1087 s1088 mod1089))) tmp1090))) ($sc-dispatch tmp1090 (quote (any #(each (any any)) any . each-any))))) e1085))) (global-extend99 (quote core) (quote set!) (lambda (e1107 r1108 w1109 s1110 mod1111) ((lambda (tmp1112) ((lambda (tmp1113) (if (if tmp1113 (apply (lambda (_1114 id1115 val1116) (id?101 id1115)) tmp1113) #f) (apply (lambda (_1117 id1118 val1119) (let ((val1120 (chi137 val1119 r1108 w1109 mod1111)) (n1121 (id-var-name123 id1118 w1109))) (let ((b1122 (lookup98 n1121 r1108 mod1111))) (let ((t1123 (binding-type93 b1122))) (if (memv t1123 (quote (lexical))) (build-annotated78 s1110 (list (quote set!) (binding-value94 b1122) val1120)) (if (memv t1123 (quote (global))) (build-annotated78 s1110 (list (quote set!) (if mod1111 (make-module-ref (cdr mod1111) n1121 (car mod1111)) (make-module-ref mod1111 n1121 (quote bare))) val1120)) (if (memv t1123 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap129 id1118 w1109 mod1111)) (syntax-violation (quote set!) "bad set!" (source-wrap130 e1107 w1109 s1110 mod1111))))))))) tmp1113) ((lambda (tmp1124) (if tmp1124 (apply (lambda (_1125 head1126 tail1127 val1128) (call-with-values (lambda () (syntax-type135 head1126 r1108 (quote (())) #f #f mod1111)) (lambda (type1129 value1130 ee1131 ww1132 ss1133 modmod1134) (let ((t1135 type1129)) (if (memv t1135 (quote (module-ref))) (let ((val1136 (chi137 val1128 r1108 w1109 mod1111))) (call-with-values (lambda () (value1130 (cons head1126 tail1127))) (lambda (id1138 mod1139) (build-annotated78 s1110 (list (quote set!) (if mod1139 (make-module-ref (cdr mod1139) id1138 (car mod1139)) (make-module-ref mod1139 id1138 (quote bare))) val1136))))) (build-annotated78 s1110 (cons (chi137 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1126) r1108 w1109 mod1111) (map (lambda (e1140) (chi137 e1140 r1108 w1109 mod1111)) (append tail1127 (list val1128)))))))))) tmp1124) ((lambda (_1142) (syntax-violation (quote set!) "bad set!" (source-wrap130 e1107 w1109 s1110 mod1111))) tmp1112))) ($sc-dispatch tmp1112 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1112 (quote (any any any))))) e1107))) (global-extend99 (quote module-ref) (quote @) (lambda (e1143) ((lambda (tmp1144) ((lambda (tmp1145) (if (if tmp1145 (apply (lambda (_1146 mod1147 id1148) (and (and-map id?101 mod1147) (id?101 id1148))) tmp1145) #f) (apply (lambda (_1150 mod1151 id1152) (values (syntax->datum id1152) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1151)))) tmp1145) (syntax-violation #f "source expression failed to match any pattern" tmp1144))) ($sc-dispatch tmp1144 (quote (any each-any any))))) e1143))) (global-extend99 (quote module-ref) (quote @@) (lambda (e1154) ((lambda (tmp1155) ((lambda (tmp1156) (if (if tmp1156 (apply (lambda (_1157 mod1158 id1159) (and (and-map id?101 mod1158) (id?101 id1159))) tmp1156) #f) (apply (lambda (_1161 mod1162 id1163) (values (syntax->datum id1163) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1162)))) tmp1156) (syntax-violation #f "source expression failed to match any pattern" tmp1155))) ($sc-dispatch tmp1155 (quote (any each-any any))))) e1154))) (global-extend99 (quote begin) (quote begin) (quote ())) (global-extend99 (quote define) (quote define) (quote ())) (global-extend99 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend99 (quote eval-when) (quote eval-when) (quote ())) (global-extend99 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1168 (lambda (x1169 keys1170 clauses1171 r1172 mod1173) (if (null? clauses1171) (build-annotated78 #f (list (build-annotated78 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1169)) ((lambda (tmp1174) ((lambda (tmp1175) (if tmp1175 (apply (lambda (pat1176 exp1177) (if (and (id?101 pat1176) (and-map (lambda (x1178) (not (free-id=?124 pat1176 x1178))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1170))) (let ((labels1179 (list (gen-label106))) (var1180 (gen-var149 pat1176))) (build-annotated78 #f (list (build-annotated78 #f (list (quote lambda) (list var1180) (chi137 exp1177 (extend-env95 labels1179 (list (cons (quote syntax) (cons var1180 0))) r1172) (make-binding-wrap118 (list pat1176) labels1179 (quote (()))) mod1173))) x1169))) (gen-clause1167 x1169 keys1170 (cdr clauses1171) r1172 pat1176 #t exp1177 mod1173))) tmp1175) ((lambda (tmp1181) (if tmp1181 (apply (lambda (pat1182 fender1183 exp1184) (gen-clause1167 x1169 keys1170 (cdr clauses1171) r1172 pat1182 fender1183 exp1184 mod1173)) tmp1181) ((lambda (_1185) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1171))) tmp1174))) ($sc-dispatch tmp1174 (quote (any any any)))))) ($sc-dispatch tmp1174 (quote (any any))))) (car clauses1171))))) (gen-clause1167 (lambda (x1186 keys1187 clauses1188 r1189 pat1190 fender1191 exp1192 mod1193) (call-with-values (lambda () (convert-pattern1165 pat1190 keys1187)) (lambda (p1194 pvars1195) (cond ((not (distinct-bound-ids?127 (map car pvars1195))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1190)) ((not (and-map (lambda (x1196) (not (ellipsis?146 (car x1196)))) pvars1195)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1190)) (else (let ((y1197 (gen-var149 (quote tmp)))) (build-annotated78 #f (list (build-annotated78 #f (list (quote lambda) (list y1197) (let ((y1198 (build-annotated78 #f y1197))) (build-annotated78 #f (list (quote if) ((lambda (tmp1199) ((lambda (tmp1200) (if tmp1200 (apply (lambda () y1198) tmp1200) ((lambda (_1201) (build-annotated78 #f (list (quote if) y1198 (build-dispatch-call1166 pvars1195 fender1191 y1198 r1189 mod1193) (build-data79 #f #f)))) tmp1199))) ($sc-dispatch tmp1199 (quote #(atom #t))))) fender1191) (build-dispatch-call1166 pvars1195 exp1192 y1198 r1189 mod1193) (gen-syntax-case1168 x1186 keys1187 clauses1188 r1189 mod1193)))))) (if (eq? p1194 (quote any)) (build-annotated78 #f (list (build-annotated78 #f (quote list)) x1186)) (build-annotated78 #f (list (build-annotated78 #f (quote $sc-dispatch)) x1186 (build-data79 #f p1194))))))))))))) (build-dispatch-call1166 (lambda (pvars1202 exp1203 y1204 r1205 mod1206) (let ((ids1207 (map car pvars1202)) (levels1208 (map cdr pvars1202))) (let ((labels1209 (gen-labels107 ids1207)) (new-vars1210 (map gen-var149 ids1207))) (build-annotated78 #f (list (build-annotated78 #f (quote apply)) (build-annotated78 #f (list (quote lambda) new-vars1210 (chi137 exp1203 (extend-env95 labels1209 (map (lambda (var1211 level1212) (cons (quote syntax) (cons var1211 level1212))) new-vars1210 (map cdr pvars1202)) r1205) (make-binding-wrap118 ids1207 labels1209 (quote (()))) mod1206))) y1204)))))) (convert-pattern1165 (lambda (pattern1213 keys1214) (let cvt1215 ((p1216 pattern1213) (n1217 0) (ids1218 (quote ()))) (if (id?101 p1216) (if (bound-id-member?128 p1216 keys1214) (values (vector (quote free-id) p1216) ids1218) (values (quote any) (cons (cons p1216 n1217) ids1218))) ((lambda (tmp1219) ((lambda (tmp1220) (if (if tmp1220 (apply (lambda (x1221 dots1222) (ellipsis?146 dots1222)) tmp1220) #f) (apply (lambda (x1223 dots1224) (call-with-values (lambda () (cvt1215 x1223 (fx+70 n1217 1) ids1218)) (lambda (p1225 ids1226) (values (if (eq? p1225 (quote any)) (quote each-any) (vector (quote each) p1225)) ids1226)))) tmp1220) ((lambda (tmp1227) (if tmp1227 (apply (lambda (x1228 y1229) (call-with-values (lambda () (cvt1215 y1229 n1217 ids1218)) (lambda (y1230 ids1231) (call-with-values (lambda () (cvt1215 x1228 n1217 ids1231)) (lambda (x1232 ids1233) (values (cons x1232 y1230) ids1233)))))) tmp1227) ((lambda (tmp1234) (if tmp1234 (apply (lambda () (values (quote ()) ids1218)) tmp1234) ((lambda (tmp1235) (if tmp1235 (apply (lambda (x1236) (call-with-values (lambda () (cvt1215 x1236 n1217 ids1218)) (lambda (p1238 ids1239) (values (vector (quote vector) p1238) ids1239)))) tmp1235) ((lambda (x1240) (values (vector (quote atom) (strip148 p1216 (quote (())))) ids1218)) tmp1219))) ($sc-dispatch tmp1219 (quote #(vector each-any)))))) ($sc-dispatch tmp1219 (quote ()))))) ($sc-dispatch tmp1219 (quote (any . any)))))) ($sc-dispatch tmp1219 (quote (any any))))) p1216)))))) (lambda (e1241 r1242 w1243 s1244 mod1245) (let ((e1246 (source-wrap130 e1241 w1243 s1244 mod1245))) ((lambda (tmp1247) ((lambda (tmp1248) (if tmp1248 (apply (lambda (_1249 val1250 key1251 m1252) (if (and-map (lambda (x1253) (and (id?101 x1253) (not (ellipsis?146 x1253)))) key1251) (let ((x1255 (gen-var149 (quote tmp)))) (build-annotated78 s1244 (list (build-annotated78 #f (list (quote lambda) (list x1255) (gen-syntax-case1168 (build-annotated78 #f x1255) key1251 m1252 r1242 mod1245))) (chi137 val1250 r1242 (quote (())) mod1245)))) (syntax-violation (quote syntax-case) "invalid literals list" e1246))) tmp1248) (syntax-violation #f "source expression failed to match any pattern" tmp1247))) ($sc-dispatch tmp1247 (quote (any any each-any . each-any))))) e1246))))) (set! sc-expand (let ((m1258 (quote e)) (esew1259 (quote (eval)))) (lambda (x1260) (if (and (pair? x1260) (equal? (car x1260) noexpand69)) (cadr x1260) (chi-top136 x1260 (quote ()) (quote ((top))) m1258 esew1259 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m1261 (quote e)) (esew1262 (quote (eval)))) (lambda (x1264 . rest1263) (if (and (pair? x1264) (equal? (car x1264) noexpand69)) (cadr x1264) (chi-top136 x1264 (quote ()) (quote ((top))) (if (null? rest1263) m1261 (car rest1263)) (if (or (null? rest1263) (null? (cdr rest1263))) esew1262 (cadr rest1263)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x1265) (nonsymbol-id?100 x1265))) (set! datum->syntax (lambda (id1266 datum1267) (make-syntax-object84 datum1267 (syntax-object-wrap87 id1266) #f))) (set! syntax->datum (lambda (x1268) (strip148 x1268 (quote (()))))) (set! generate-temporaries (lambda (ls1269) (begin (let ((x1270 ls1269)) (if (not (list? x1270)) (syntax-violation (quote generate-temporaries) "invalid argument" x1270))) (map (lambda (x1271) (wrap129 (gensym) (quote ((top))) #f)) ls1269)))) (set! free-identifier=? (lambda (x1272 y1273) (begin (let ((x1274 x1272)) (if (not (nonsymbol-id?100 x1274)) (syntax-violation (quote free-identifier=?) "invalid argument" x1274))) (let ((x1275 y1273)) (if (not (nonsymbol-id?100 x1275)) (syntax-violation (quote free-identifier=?) "invalid argument" x1275))) (free-id=?124 x1272 y1273)))) (set! bound-identifier=? (lambda (x1276 y1277) (begin (let ((x1278 x1276)) (if (not (nonsymbol-id?100 x1278)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1278))) (let ((x1279 y1277)) (if (not (nonsymbol-id?100 x1279)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1279))) (bound-id=?125 x1276 y1277)))) (set! syntax-violation (lambda (who1283 message1282 form1281 . subform1280) (begin (let ((x1284 who1283)) (if (not ((lambda (x1285) (or (not x1285) (string? x1285) (symbol? x1285))) x1284)) (syntax-violation (quote syntax-violation) "invalid argument" x1284))) (let ((x1286 message1282)) (if (not (string? x1286)) (syntax-violation (quote syntax-violation) "invalid argument" x1286))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1283 "~a: " "") "~a " (if (null? subform1280) "in ~a" "in subform `~s' of `~s'")) (let ((tail1287 (cons message1282 (map (lambda (x1288) (strip148 x1288 (quote (())))) (append subform1280 (list form1281)))))) (if who1283 (cons who1283 tail1287) tail1287)) #f)))) (letrec ((match1293 (lambda (e1294 p1295 w1296 r1297 mod1298) (cond ((not r1297) #f) ((eq? p1295 (quote any)) (cons (wrap129 e1294 w1296 mod1298) r1297)) ((syntax-object?85 e1294) (match*1292 (let ((e1299 (syntax-object-expression86 e1294))) (if (annotation? e1299) (annotation-expression e1299) e1299)) p1295 (join-wraps120 w1296 (syntax-object-wrap87 e1294)) r1297 (syntax-object-module88 e1294))) (else (match*1292 (let ((e1300 e1294)) (if (annotation? e1300) (annotation-expression e1300) e1300)) p1295 w1296 r1297 mod1298))))) (match*1292 (lambda (e1301 p1302 w1303 r1304 mod1305) (cond ((null? p1302) (and (null? e1301) r1304)) ((pair? p1302) (and (pair? e1301) (match1293 (car e1301) (car p1302) w1303 (match1293 (cdr e1301) (cdr p1302) w1303 r1304 mod1305) mod1305))) ((eq? p1302 (quote each-any)) (let ((l1306 (match-each-any1290 e1301 w1303 mod1305))) (and l1306 (cons l1306 r1304)))) (else (let ((t1307 (vector-ref p1302 0))) (if (memv t1307 (quote (each))) (if (null? e1301) (match-empty1291 (vector-ref p1302 1) r1304) (let ((l1308 (match-each1289 e1301 (vector-ref p1302 1) w1303 mod1305))) (and l1308 (let collect1309 ((l1310 l1308)) (if (null? (car l1310)) r1304 (cons (map car l1310) (collect1309 (map cdr l1310)))))))) (if (memv t1307 (quote (free-id))) (and (id?101 e1301) (free-id=?124 (wrap129 e1301 w1303 mod1305) (vector-ref p1302 1)) r1304) (if (memv t1307 (quote (atom))) (and (equal? (vector-ref p1302 1) (strip148 e1301 w1303)) r1304) (if (memv t1307 (quote (vector))) (and (vector? e1301) (match1293 (vector->list e1301) (vector-ref p1302 1) w1303 r1304 mod1305))))))))))) (match-empty1291 (lambda (p1311 r1312) (cond ((null? p1311) r1312) ((eq? p1311 (quote any)) (cons (quote ()) r1312)) ((pair? p1311) (match-empty1291 (car p1311) (match-empty1291 (cdr p1311) r1312))) ((eq? p1311 (quote each-any)) (cons (quote ()) r1312)) (else (let ((t1313 (vector-ref p1311 0))) (if (memv t1313 (quote (each))) (match-empty1291 (vector-ref p1311 1) r1312) (if (memv t1313 (quote (free-id atom))) r1312 (if (memv t1313 (quote (vector))) (match-empty1291 (vector-ref p1311 1) r1312))))))))) (match-each-any1290 (lambda (e1314 w1315 mod1316) (cond ((annotation? e1314) (match-each-any1290 (annotation-expression e1314) w1315 mod1316)) ((pair? e1314) (let ((l1317 (match-each-any1290 (cdr e1314) w1315 mod1316))) (and l1317 (cons (wrap129 (car e1314) w1315 mod1316) l1317)))) ((null? e1314) (quote ())) ((syntax-object?85 e1314) (match-each-any1290 (syntax-object-expression86 e1314) (join-wraps120 w1315 (syntax-object-wrap87 e1314)) mod1316)) (else #f)))) (match-each1289 (lambda (e1318 p1319 w1320 mod1321) (cond ((annotation? e1318) (match-each1289 (annotation-expression e1318) p1319 w1320 mod1321)) ((pair? e1318) (let ((first1322 (match1293 (car e1318) p1319 w1320 (quote ()) mod1321))) (and first1322 (let ((rest1323 (match-each1289 (cdr e1318) p1319 w1320 mod1321))) (and rest1323 (cons first1322 rest1323)))))) ((null? e1318) (quote ())) ((syntax-object?85 e1318) (match-each1289 (syntax-object-expression86 e1318) p1319 (join-wraps120 w1320 (syntax-object-wrap87 e1318)) (syntax-object-module88 e1318))) (else #f))))) (set! $sc-dispatch (lambda (e1324 p1325) (cond ((eq? p1325 (quote any)) (list e1324)) ((syntax-object?85 e1324) (match*1292 (let ((e1326 (syntax-object-expression86 e1324))) (if (annotation? e1326) (annotation-expression e1326) e1326)) p1325 (syntax-object-wrap87 e1324) (quote ()) (syntax-object-module88 e1324))) (else (match*1292 (let ((e1327 e1324)) (if (annotation? e1327) (annotation-expression e1327) e1327)) p1325 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1328) ((lambda (tmp1329) ((lambda (tmp1330) (if tmp1330 (apply (lambda (_1331 e11332 e21333) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11332 e21333))) tmp1330) ((lambda (tmp1335) (if tmp1335 (apply (lambda (_1336 out1337 in1338 e11339 e21340) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1338 (quote ()) (list out1337 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11339 e21340))))) tmp1335) ((lambda (tmp1342) (if tmp1342 (apply (lambda (_1343 out1344 in1345 e11346 e21347) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1345) (quote ()) (list out1344 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11346 e21347))))) tmp1342) (syntax-violation #f "source expression failed to match any pattern" tmp1329))) ($sc-dispatch tmp1329 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1329 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1329 (quote (any () any . each-any))))) x1328)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1351) ((lambda (tmp1352) ((lambda (tmp1353) (if tmp1353 (apply (lambda (_1354 k1355 keyword1356 pattern1357 template1358) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1355 (map (lambda (tmp1361 tmp1360) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1360) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1361))) template1358 pattern1357)))))) tmp1353) (syntax-violation #f "source expression failed to match any pattern" tmp1352))) ($sc-dispatch tmp1352 (quote (any each-any . #(each ((any . any) any))))))) x1351)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1362) ((lambda (tmp1363) ((lambda (tmp1364) (if (if tmp1364 (apply (lambda (let*1365 x1366 v1367 e11368 e21369) (and-map identifier? x1366)) tmp1364) #f) (apply (lambda (let*1371 x1372 v1373 e11374 e21375) (let f1376 ((bindings1377 (map list x1372 v1373))) (if (null? bindings1377) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11374 e21375))) ((lambda (tmp1381) ((lambda (tmp1382) (if tmp1382 (apply (lambda (body1383 binding1384) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1384) body1383)) tmp1382) (syntax-violation #f "source expression failed to match any pattern" tmp1381))) ($sc-dispatch tmp1381 (quote (any any))))) (list (f1376 (cdr bindings1377)) (car bindings1377)))))) tmp1364) (syntax-violation #f "source expression failed to match any pattern" tmp1363))) ($sc-dispatch tmp1363 (quote (any #(each (any any)) any . each-any))))) x1362)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1385) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (_1388 var1389 init1390 step1391 e01392 e11393 c1394) ((lambda (tmp1395) ((lambda (tmp1396) (if tmp1396 (apply (lambda (step1397) ((lambda (tmp1398) ((lambda (tmp1399) (if tmp1399 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1389 init1390) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01392) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1394 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1397))))))) tmp1399) ((lambda (tmp1404) (if tmp1404 (apply (lambda (e11405 e21406) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1389 init1390) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01392 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11405 e21406)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1394 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1397))))))) tmp1404) (syntax-violation #f "source expression failed to match any pattern" tmp1398))) ($sc-dispatch tmp1398 (quote (any . each-any)))))) ($sc-dispatch tmp1398 (quote ())))) e11393)) tmp1396) (syntax-violation #f "source expression failed to match any pattern" tmp1395))) ($sc-dispatch tmp1395 (quote each-any)))) (map (lambda (v1413 s1414) ((lambda (tmp1415) ((lambda (tmp1416) (if tmp1416 (apply (lambda () v1413) tmp1416) ((lambda (tmp1417) (if tmp1417 (apply (lambda (e1418) e1418) tmp1417) ((lambda (_1419) (syntax-violation (quote do) "bad step expression" orig-x1385 s1414)) tmp1415))) ($sc-dispatch tmp1415 (quote (any)))))) ($sc-dispatch tmp1415 (quote ())))) s1414)) var1389 step1391))) tmp1387) (syntax-violation #f "source expression failed to match any pattern" tmp1386))) ($sc-dispatch tmp1386 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1385)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1422 (lambda (x1426 y1427) ((lambda (tmp1428) ((lambda (tmp1429) (if tmp1429 (apply (lambda (x1430 y1431) ((lambda (tmp1432) ((lambda (tmp1433) (if tmp1433 (apply (lambda (dy1434) ((lambda (tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (dx1437) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1437 dy1434))) tmp1436) ((lambda (_1438) (if (null? dy1434) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1430) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1430 y1431))) tmp1435))) ($sc-dispatch tmp1435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1430)) tmp1433) ((lambda (tmp1439) (if tmp1439 (apply (lambda (stuff1440) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1430 stuff1440))) tmp1439) ((lambda (else1441) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1430 y1431)) tmp1432))) ($sc-dispatch tmp1432 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1432 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1431)) tmp1429) (syntax-violation #f "source expression failed to match any pattern" tmp1428))) ($sc-dispatch tmp1428 (quote (any any))))) (list x1426 y1427)))) (quasiappend1423 (lambda (x1442 y1443) ((lambda (tmp1444) ((lambda (tmp1445) (if tmp1445 (apply (lambda (x1446 y1447) ((lambda (tmp1448) ((lambda (tmp1449) (if tmp1449 (apply (lambda () x1446) tmp1449) ((lambda (_1450) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1446 y1447)) tmp1448))) ($sc-dispatch tmp1448 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1447)) tmp1445) (syntax-violation #f "source expression failed to match any pattern" tmp1444))) ($sc-dispatch tmp1444 (quote (any any))))) (list x1442 y1443)))) (quasivector1424 (lambda (x1451) ((lambda (tmp1452) ((lambda (x1453) ((lambda (tmp1454) ((lambda (tmp1455) (if tmp1455 (apply (lambda (x1456) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1456))) tmp1455) ((lambda (tmp1458) (if tmp1458 (apply (lambda (x1459) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1459)) tmp1458) ((lambda (_1461) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1453)) tmp1454))) ($sc-dispatch tmp1454 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1454 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1453)) tmp1452)) x1451))) (quasi1425 (lambda (p1462 lev1463) ((lambda (tmp1464) ((lambda (tmp1465) (if tmp1465 (apply (lambda (p1466) (if (= lev1463 0) p1466 (quasicons1422 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1425 (list p1466) (- lev1463 1))))) tmp1465) ((lambda (tmp1467) (if tmp1467 (apply (lambda (p1468 q1469) (if (= lev1463 0) (quasiappend1423 p1468 (quasi1425 q1469 lev1463)) (quasicons1422 (quasicons1422 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1425 (list p1468) (- lev1463 1))) (quasi1425 q1469 lev1463)))) tmp1467) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471) (quasicons1422 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1425 (list p1471) (+ lev1463 1)))) tmp1470) ((lambda (tmp1472) (if tmp1472 (apply (lambda (p1473 q1474) (quasicons1422 (quasi1425 p1473 lev1463) (quasi1425 q1474 lev1463))) tmp1472) ((lambda (tmp1475) (if tmp1475 (apply (lambda (x1476) (quasivector1424 (quasi1425 x1476 lev1463))) tmp1475) ((lambda (p1478) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1478)) tmp1464))) ($sc-dispatch tmp1464 (quote #(vector each-any)))))) ($sc-dispatch tmp1464 (quote (any . any)))))) ($sc-dispatch tmp1464 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1464 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1464 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1462)))) (lambda (x1479) ((lambda (tmp1480) ((lambda (tmp1481) (if tmp1481 (apply (lambda (_1482 e1483) (quasi1425 e1483 0)) tmp1481) (syntax-violation #f "source expression failed to match any pattern" tmp1480))) ($sc-dispatch tmp1480 (quote (any any))))) x1479))))) +(define include (make-syncase-macro (quote macro) (lambda (x1484) (letrec ((read-file1485 (lambda (fn1486 k1487) (let ((p1488 (open-input-file fn1486))) (let f1489 ((x1490 (read p1488))) (if (eof-object? x1490) (begin (close-input-port p1488) (quote ())) (cons (datum->syntax k1487 x1490) (f1489 (read p1488))))))))) ((lambda (tmp1491) ((lambda (tmp1492) (if tmp1492 (apply (lambda (k1493 filename1494) (let ((fn1495 (syntax->datum filename1494))) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (exp1498) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1498)) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote each-any)))) (read-file1485 fn1495 k1493)))) tmp1492) (syntax-violation #f "source expression failed to match any pattern" tmp1491))) ($sc-dispatch tmp1491 (quote (any any))))) x1484))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (_1503 e1504) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1500)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote (any any))))) x1500)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1505)) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any))))) x1505)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1510) ((lambda (tmp1511) ((lambda (tmp1512) (if tmp1512 (apply (lambda (_1513 e1514 m11515 m21516) ((lambda (tmp1517) ((lambda (body1518) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1514)) body1518)) tmp1517)) (let f1519 ((clause1520 m11515) (clauses1521 m21516)) (if (null? clauses1521) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (e11525 e21526) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11525 e21526))) tmp1524) ((lambda (tmp1528) (if tmp1528 (apply (lambda (k1529 e11530 e21531) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1529)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11530 e21531)))) tmp1528) ((lambda (_1534) (syntax-violation (quote case) "bad clause" x1510 clause1520)) tmp1523))) ($sc-dispatch tmp1523 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1523 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1520) ((lambda (tmp1535) ((lambda (rest1536) ((lambda (tmp1537) ((lambda (tmp1538) (if tmp1538 (apply (lambda (k1539 e11540 e21541) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1539)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11540 e21541)) rest1536)) tmp1538) ((lambda (_1544) (syntax-violation (quote case) "bad clause" x1510 clause1520)) tmp1537))) ($sc-dispatch tmp1537 (quote (each-any any . each-any))))) clause1520)) tmp1535)) (f1519 (car clauses1521) (cdr clauses1521))))))) tmp1512) (syntax-violation #f "source expression failed to match any pattern" tmp1511))) ($sc-dispatch tmp1511 (quote (any any any . each-any))))) x1510)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1545) ((lambda (tmp1546) ((lambda (tmp1547) (if tmp1547 (apply (lambda (_1548 e1549) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1549)) (list (cons _1548 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1549 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1547) (syntax-violation #f "source expression failed to match any pattern" tmp1546))) ($sc-dispatch tmp1546 (quote (any any))))) x1545)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 7ddb4e393..fa289f365 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -109,13 +109,6 @@ ;;; by eval, and eval accepts one argument, nothing special must be done ;;; to support the "noexpand" flag, since it is handled by sc-expand. ;;; -;;; (error who format-string why what) -;;; where who is either a symbol or #f, format-string is always "~a ~s", -;;; why is always a string, and what may be any object. error should -;;; signal an error with a message something like -;;; -;;; "error in : " -;;; ;;; (gensym) ;;; returns a unique symbol each time it's called ;;; @@ -325,10 +318,6 @@ (lambda (x mod) (primitive-eval `(,noexpand ,x)))) -(define error-hook - (lambda (who why what) - (error who "~a ~s" why what))) - (define-syntax gensym-hook (syntax-rules () ((_) (gensym)))) @@ -488,7 +477,7 @@ (syntax-rules () ((_ pred? e who) (let ((x e)) - (if (not (pred? x)) (error-hook who "invalid argument" x)))))) + (if (not (pred? x)) (syntax-violation who "invalid argument" x)))))) ;;; compile-time environments @@ -808,7 +797,7 @@ ((annotation? id) (let ((id (unannotate id))) (or (first (search id (wrap-subst w) (wrap-marks w))) id))) - (else (error-hook 'id-var-name "invalid id" id))))) + (else (syntax-violation 'id-var-name "invalid id" id))))) ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y) ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. @@ -2315,20 +2304,20 @@ (syntax (begin exp ...)))))))) (define-syntax unquote - (lambda (x) - (syntax-case x () - ((_ e) - (error 'unquote - "expression ,~s not valid outside of quasiquote" - (syntax->datum (syntax e))))))) + (lambda (x) + (syntax-case x () + ((_ e) + (syntax-violation 'unquote + "expression not valid outside of quasiquote" + x))))) (define-syntax unquote-splicing - (lambda (x) - (syntax-case x () - ((_ e) - (error 'unquote-splicing - "expression ,@~s not valid outside of quasiquote" - (syntax->datum (syntax e))))))) + (lambda (x) + (syntax-case x () + ((_ e) + (syntax-violation 'unquote-splicing + "expression not valid outside of quasiquote" + x))))) (define-syntax case (lambda (x) From 41af238146428f5841880f26d84b5dc9ddfad2c4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 23:57:31 +0200 Subject: [PATCH 090/375] remove (void) from boot-9 and psyntax * module/ice-9/psyntax.scm: Tweak comments. Remove references to `void'; just produce (if #f #f) instead of (void). * module/ice-9/psyntax-pp.scm: Regenerated, twice. * module/ice-9/boot-9.scm (void): Remove this binding. --- module/ice-9/boot-9.scm | 2 -- module/ice-9/psyntax-pp.scm | 24 ++++++++++++------------ module/ice-9/psyntax.scm | 24 ++++++------------------ 3 files changed, 18 insertions(+), 32 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 18c716033..2f39c438b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -33,8 +33,6 @@ -(define (void) (if #f #f)) - ;; Before compiling, make sure any symbols are resolved in the (guile) ;; module, the primary location of those symbols, rather than in ;; (guile-user), the default module that we compile in. diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index ba204275c..035d1720e 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) -(void) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list150 (lambda (vars355) (let lvl356 ((vars357 vars355) (ls358 (quote ())) (w359 (quote (())))) (cond ((pair? vars357) (lvl356 (cdr vars357) (cons (wrap129 (car vars357) w359 #f) ls358) w359)) ((id?101 vars357) (cons (wrap129 vars357 w359 #f) ls358)) ((null? vars357) ls358) ((syntax-object?85 vars357) (lvl356 (syntax-object-expression86 vars357) ls358 (join-wraps120 w359 (syntax-object-wrap87 vars357)))) ((annotation? vars357) (lvl356 (annotation-expression vars357) ls358 w359)) (else (cons vars357 ls358)))))) (gen-var149 (lambda (id360) (let ((id361 (if (syntax-object?85 id360) (syntax-object-expression86 id360) id360))) (if (annotation? id361) (build-annotated78 (annotation-source id361) (gensym (symbol->string (annotation-expression id361)))) (build-annotated78 #f (gensym (symbol->string id361))))))) (strip148 (lambda (x362 w363) (if (memq (quote top) (wrap-marks104 w363)) (if (or (annotation? x362) (and (pair? x362) (annotation? (car x362)))) (strip-annotation147 x362 #f) x362) (let f364 ((x365 x362)) (cond ((syntax-object?85 x365) (strip148 (syntax-object-expression86 x365) (syntax-object-wrap87 x365))) ((pair? x365) (let ((a366 (f364 (car x365))) (d367 (f364 (cdr x365)))) (if (and (eq? a366 (car x365)) (eq? d367 (cdr x365))) x365 (cons a366 d367)))) ((vector? x365) (let ((old368 (vector->list x365))) (let ((new369 (map f364 old368))) (if (and-map*17 eq? old368 new369) x365 (list->vector new369))))) (else x365)))))) (strip-annotation147 (lambda (x370 parent371) (cond ((pair? x370) (let ((new372 (cons #f #f))) (begin (if parent371 (set-annotation-stripped! parent371 new372)) (set-car! new372 (strip-annotation147 (car x370) #f)) (set-cdr! new372 (strip-annotation147 (cdr x370) #f)) new372))) ((annotation? x370) (or (annotation-stripped x370) (strip-annotation147 (annotation-expression x370) x370))) ((vector? x370) (let ((new373 (make-vector (vector-length x370)))) (begin (if parent371 (set-annotation-stripped! parent371 new373)) (let loop374 ((i375 (- (vector-length x370) 1))) (unless (fx<73 i375 0) (vector-set! new373 i375 (strip-annotation147 (vector-ref x370 i375) #f)) (loop374 (fx-71 i375 1)))) new373))) (else x370)))) (ellipsis?146 (lambda (x376) (and (nonsymbol-id?100 x376) (free-id=?124 x376 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void145 (lambda () (build-annotated78 #f (list (build-annotated78 #f (quote void)))))) (eval-local-transformer144 (lambda (expanded377 mod378) (let ((p379 (local-eval-hook75 expanded377 mod378))) (if (procedure? p379) p379 (syntax-violation #f "nonprocedure transformer" p379))))) (chi-local-syntax143 (lambda (rec?380 e381 r382 w383 s384 mod385 k386) ((lambda (tmp387) ((lambda (tmp388) (if tmp388 (apply (lambda (_389 id390 val391 e1392 e2393) (let ((ids394 id390)) (if (not (valid-bound-ids?126 ids394)) (syntax-violation #f "duplicate bound keyword" e381) (let ((labels396 (gen-labels107 ids394))) (let ((new-w397 (make-binding-wrap118 ids394 labels396 w383))) (k386 (cons e1392 e2393) (extend-env95 labels396 (let ((w399 (if rec?380 new-w397 w383)) (trans-r400 (macros-only-env97 r382))) (map (lambda (x401) (cons (quote macro) (eval-local-transformer144 (chi137 x401 trans-r400 w399 mod385) mod385))) val391)) r382) new-w397 s384 mod385)))))) tmp388) ((lambda (_403) (syntax-violation #f "bad local syntax definition" (source-wrap130 e381 w383 s384 mod385))) tmp387))) ($sc-dispatch tmp387 (quote (any #(each (any any)) any . each-any))))) e381))) (chi-lambda-clause142 (lambda (e404 docstring405 c406 r407 w408 mod409 k410) ((lambda (tmp411) ((lambda (tmp412) (if (if tmp412 (apply (lambda (args413 doc414 e1415 e2416) (and (string? (syntax->datum doc414)) (not docstring405))) tmp412) #f) (apply (lambda (args417 doc418 e1419 e2420) (chi-lambda-clause142 e404 doc418 (cons args417 (cons e1419 e2420)) r407 w408 mod409 k410)) tmp412) ((lambda (tmp422) (if tmp422 (apply (lambda (id423 e1424 e2425) (let ((ids426 id423)) (if (not (valid-bound-ids?126 ids426)) (syntax-violation (quote lambda) "invalid parameter list" e404) (let ((labels428 (gen-labels107 ids426)) (new-vars429 (map gen-var149 ids426))) (k410 new-vars429 docstring405 (chi-body141 (cons e1424 e2425) e404 (extend-var-env96 labels428 new-vars429 r407) (make-binding-wrap118 ids426 labels428 w408) mod409)))))) tmp422) ((lambda (tmp431) (if tmp431 (apply (lambda (ids432 e1433 e2434) (let ((old-ids435 (lambda-var-list150 ids432))) (if (not (valid-bound-ids?126 old-ids435)) (syntax-violation (quote lambda) "invalid parameter list" e404) (let ((labels436 (gen-labels107 old-ids435)) (new-vars437 (map gen-var149 old-ids435))) (k410 (let f438 ((ls1439 (cdr new-vars437)) (ls2440 (car new-vars437))) (if (null? ls1439) ls2440 (f438 (cdr ls1439) (cons (car ls1439) ls2440)))) docstring405 (chi-body141 (cons e1433 e2434) e404 (extend-var-env96 labels436 new-vars437 r407) (make-binding-wrap118 old-ids435 labels436 w408) mod409)))))) tmp431) ((lambda (_442) (syntax-violation (quote lambda) "bad lambda" e404)) tmp411))) ($sc-dispatch tmp411 (quote (any any . each-any)))))) ($sc-dispatch tmp411 (quote (each-any any . each-any)))))) ($sc-dispatch tmp411 (quote (any any any . each-any))))) c406))) (chi-body141 (lambda (body443 outer-form444 r445 w446 mod447) (let ((r448 (cons (quote ("placeholder" placeholder)) r445))) (let ((ribcage449 (make-ribcage108 (quote ()) (quote ()) (quote ())))) (let ((w450 (make-wrap103 (wrap-marks104 w446) (cons ribcage449 (wrap-subst105 w446))))) (let parse451 ((body452 (map (lambda (x458) (cons r448 (wrap129 x458 w450 mod447))) body443)) (ids453 (quote ())) (labels454 (quote ())) (vars455 (quote ())) (vals456 (quote ())) (bindings457 (quote ()))) (if (null? body452) (syntax-violation #f "no expressions in body" outer-form444) (let ((e459 (cdar body452)) (er460 (caar body452))) (call-with-values (lambda () (syntax-type135 e459 er460 (quote (())) #f ribcage449 mod447)) (lambda (type461 value462 e463 w464 s465 mod466) (let ((t467 type461)) (if (memv t467 (quote (define-form))) (let ((id468 (wrap129 value462 w464 mod466)) (label469 (gen-label106))) (let ((var470 (gen-var149 id468))) (begin (extend-ribcage!117 ribcage449 id468 label469) (parse451 (cdr body452) (cons id468 ids453) (cons label469 labels454) (cons var470 vars455) (cons (cons er460 (wrap129 e463 w464 mod466)) vals456) (cons (cons (quote lexical) var470) bindings457))))) (if (memv t467 (quote (define-syntax-form))) (let ((id471 (wrap129 value462 w464 mod466)) (label472 (gen-label106))) (begin (extend-ribcage!117 ribcage449 id471 label472) (parse451 (cdr body452) (cons id471 ids453) (cons label472 labels454) vars455 vals456 (cons (cons (quote macro) (cons er460 (wrap129 e463 w464 mod466))) bindings457)))) (if (memv t467 (quote (begin-form))) ((lambda (tmp473) ((lambda (tmp474) (if tmp474 (apply (lambda (_475 e1476) (parse451 (let f477 ((forms478 e1476)) (if (null? forms478) (cdr body452) (cons (cons er460 (wrap129 (car forms478) w464 mod466)) (f477 (cdr forms478))))) ids453 labels454 vars455 vals456 bindings457)) tmp474) (syntax-violation #f "source expression failed to match any pattern" tmp473))) ($sc-dispatch tmp473 (quote (any . each-any))))) e463) (if (memv t467 (quote (local-syntax-form))) (chi-local-syntax143 value462 e463 er460 w464 s465 mod466 (lambda (forms480 er481 w482 s483 mod484) (parse451 (let f485 ((forms486 forms480)) (if (null? forms486) (cdr body452) (cons (cons er481 (wrap129 (car forms486) w482 mod484)) (f485 (cdr forms486))))) ids453 labels454 vars455 vals456 bindings457))) (if (null? ids453) (build-sequence80 #f (map (lambda (x487) (chi137 (cdr x487) (car x487) (quote (())) mod466)) (cons (cons er460 (source-wrap130 e463 w464 s465 mod466)) (cdr body452)))) (begin (if (not (valid-bound-ids?126 ids453)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form444)) (let loop488 ((bs489 bindings457) (er-cache490 #f) (r-cache491 #f)) (if (not (null? bs489)) (let ((b492 (car bs489))) (if (eq? (car b492) (quote macro)) (let ((er493 (cadr b492))) (let ((r-cache494 (if (eq? er493 er-cache490) r-cache491 (macros-only-env97 er493)))) (begin (set-cdr! b492 (eval-local-transformer144 (chi137 (cddr b492) r-cache494 (quote (())) mod466) mod466)) (loop488 (cdr bs489) er493 r-cache494)))) (loop488 (cdr bs489) er-cache490 r-cache491))))) (set-cdr! r448 (extend-env95 labels454 bindings457 (cdr r448))) (build-letrec83 #f vars455 (map (lambda (x495) (chi137 (cdr x495) (car x495) (quote (())) mod466)) vals456) (build-sequence80 #f (map (lambda (x496) (chi137 (cdr x496) (car x496) (quote (())) mod466)) (cons (cons er460 (source-wrap130 e463 w464 s465 mod466)) (cdr body452)))))))))))))))))))))) (chi-macro140 (lambda (p497 e498 r499 w500 rib501 mod502) (letrec ((rebuild-macro-output503 (lambda (x504 m505) (cond ((pair? x504) (cons (rebuild-macro-output503 (car x504) m505) (rebuild-macro-output503 (cdr x504) m505))) ((syntax-object?85 x504) (let ((w506 (syntax-object-wrap87 x504))) (let ((ms507 (wrap-marks104 w506)) (s508 (wrap-subst105 w506))) (if (and (pair? ms507) (eq? (car ms507) #f)) (make-syntax-object84 (syntax-object-expression86 x504) (make-wrap103 (cdr ms507) (if rib501 (cons rib501 (cdr s508)) (cdr s508))) (syntax-object-module88 x504)) (make-syntax-object84 (syntax-object-expression86 x504) (make-wrap103 (cons m505 ms507) (if rib501 (cons rib501 (cons (quote shift) s508)) (cons (quote shift) s508))) (let ((pmod509 (procedure-module p497))) (if pmod509 (cons (quote hygiene) (module-name pmod509)) (quote (hygiene guile))))))))) ((vector? x504) (let ((n510 (vector-length x504))) (let ((v511 (make-vector n510))) (let doloop512 ((i513 0)) (if (fx=72 i513 n510) v511 (begin (vector-set! v511 i513 (rebuild-macro-output503 (vector-ref x504 i513) m505)) (doloop512 (fx+70 i513 1)))))))) ((symbol? x504) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap130 e498 w500 s mod502) x504)) (else x504))))) (rebuild-macro-output503 (p497 (wrap129 e498 (anti-mark116 w500) mod502)) (string #\m))))) (chi-application139 (lambda (x514 e515 r516 w517 s518 mod519) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (e0522 e1523) (build-annotated78 s518 (cons x514 (map (lambda (e524) (chi137 e524 r516 w517 mod519)) e1523)))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any . each-any))))) e515))) (chi-expr138 (lambda (type526 value527 e528 r529 w530 s531 mod532) (let ((t533 type526)) (if (memv t533 (quote (lexical))) (build-annotated78 s531 value527) (if (memv t533 (quote (core external-macro))) (value527 e528 r529 w530 s531 mod532) (if (memv t533 (quote (module-ref))) (call-with-values (lambda () (value527 e528)) (lambda (id534 mod535) (build-annotated78 s531 (if mod535 (make-module-ref (cdr mod535) id534 (car mod535)) (make-module-ref mod535 id534 (quote bare)))))) (if (memv t533 (quote (lexical-call))) (chi-application139 (build-annotated78 (source-annotation92 (car e528)) value527) e528 r529 w530 s531 mod532) (if (memv t533 (quote (global-call))) (chi-application139 (build-annotated78 (source-annotation92 (car e528)) (if (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532) (make-module-ref (cdr (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532)) value527 (car (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532))) (make-module-ref (if (syntax-object?85 (car e528)) (syntax-object-module88 (car e528)) mod532) value527 (quote bare)))) e528 r529 w530 s531 mod532) (if (memv t533 (quote (constant))) (build-data79 s531 (strip148 (source-wrap130 e528 w530 s531 mod532) (quote (())))) (if (memv t533 (quote (global))) (build-annotated78 s531 (if mod532 (make-module-ref (cdr mod532) value527 (car mod532)) (make-module-ref mod532 value527 (quote bare)))) (if (memv t533 (quote (call))) (chi-application139 (chi137 (car e528) r529 w530 mod532) e528 r529 w530 s531 mod532) (if (memv t533 (quote (begin-form))) ((lambda (tmp536) ((lambda (tmp537) (if tmp537 (apply (lambda (_538 e1539 e2540) (chi-sequence131 (cons e1539 e2540) r529 w530 s531 mod532)) tmp537) (syntax-violation #f "source expression failed to match any pattern" tmp536))) ($sc-dispatch tmp536 (quote (any any . each-any))))) e528) (if (memv t533 (quote (local-syntax-form))) (chi-local-syntax143 value527 e528 r529 w530 s531 mod532 chi-sequence131) (if (memv t533 (quote (eval-when-form))) ((lambda (tmp542) ((lambda (tmp543) (if tmp543 (apply (lambda (_544 x545 e1546 e2547) (let ((when-list548 (chi-when-list134 e528 x545 w530))) (if (memq (quote eval) when-list548) (chi-sequence131 (cons e1546 e2547) r529 w530 s531 mod532) (chi-void145)))) tmp543) (syntax-violation #f "source expression failed to match any pattern" tmp542))) ($sc-dispatch tmp542 (quote (any each-any any . each-any))))) e528) (if (memv t533 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e528 (wrap129 value527 w530 mod532)) (if (memv t533 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap130 e528 w530 s531 mod532)) (if (memv t533 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap130 e528 w530 s531 mod532)) (syntax-violation #f "unexpected syntax" (source-wrap130 e528 w530 s531 mod532))))))))))))))))))) (chi137 (lambda (e551 r552 w553 mod554) (call-with-values (lambda () (syntax-type135 e551 r552 w553 #f #f mod554)) (lambda (type555 value556 e557 w558 s559 mod560) (chi-expr138 type555 value556 e557 r552 w558 s559 mod560))))) (chi-top136 (lambda (e561 r562 w563 m564 esew565 mod566) (call-with-values (lambda () (syntax-type135 e561 r562 w563 #f #f mod566)) (lambda (type574 value575 e576 w577 s578 mod579) (let ((t580 type574)) (if (memv t580 (quote (begin-form))) ((lambda (tmp581) ((lambda (tmp582) (if tmp582 (apply (lambda (_583) (chi-void145)) tmp582) ((lambda (tmp584) (if tmp584 (apply (lambda (_585 e1586 e2587) (chi-top-sequence132 (cons e1586 e2587) r562 w577 s578 m564 esew565 mod579)) tmp584) (syntax-violation #f "source expression failed to match any pattern" tmp581))) ($sc-dispatch tmp581 (quote (any any . each-any)))))) ($sc-dispatch tmp581 (quote (any))))) e576) (if (memv t580 (quote (local-syntax-form))) (chi-local-syntax143 value575 e576 r562 w577 s578 mod579 (lambda (body589 r590 w591 s592 mod593) (chi-top-sequence132 body589 r590 w591 s592 m564 esew565 mod593))) (if (memv t580 (quote (eval-when-form))) ((lambda (tmp594) ((lambda (tmp595) (if tmp595 (apply (lambda (_596 x597 e1598 e2599) (let ((when-list600 (chi-when-list134 e576 x597 w577)) (body601 (cons e1598 e2599))) (cond ((eq? m564 (quote e)) (if (memq (quote eval) when-list600) (chi-top-sequence132 body601 r562 w577 s578 (quote e) (quote (eval)) mod579) (chi-void145))) ((memq (quote load) when-list600) (if (or (memq (quote compile) when-list600) (and (eq? m564 (quote c&e)) (memq (quote eval) when-list600))) (chi-top-sequence132 body601 r562 w577 s578 (quote c&e) (quote (compile load)) mod579) (if (memq m564 (quote (c c&e))) (chi-top-sequence132 body601 r562 w577 s578 (quote c) (quote (load)) mod579) (chi-void145)))) ((or (memq (quote compile) when-list600) (and (eq? m564 (quote c&e)) (memq (quote eval) when-list600))) (top-level-eval-hook74 (chi-top-sequence132 body601 r562 w577 s578 (quote e) (quote (eval)) mod579) mod579) (chi-void145)) (else (chi-void145))))) tmp595) (syntax-violation #f "source expression failed to match any pattern" tmp594))) ($sc-dispatch tmp594 (quote (any each-any any . each-any))))) e576) (if (memv t580 (quote (define-syntax-form))) (let ((n604 (id-var-name123 value575 w577)) (r605 (macros-only-env97 r562))) (let ((t606 m564)) (if (memv t606 (quote (c))) (if (memq (quote compile) esew565) (let ((e607 (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)))) (begin (top-level-eval-hook74 e607 mod579) (if (memq (quote load) esew565) e607 (chi-void145)))) (if (memq (quote load) esew565) (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)) (chi-void145))) (if (memv t606 (quote (c&e))) (let ((e608 (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)))) (begin (top-level-eval-hook74 e608 mod579) e608)) (begin (if (memq (quote eval) esew565) (top-level-eval-hook74 (chi-install-global133 n604 (chi137 e576 r605 w577 mod579)) mod579)) (chi-void145)))))) (if (memv t580 (quote (define-form))) (let ((n609 (id-var-name123 value575 w577))) (let ((type610 (binding-type93 (lookup98 n609 r562 mod579)))) (let ((t611 type610)) (if (memv t611 (quote (global core macro module-ref))) (let ((x612 (build-annotated78 s578 (list (quote define) n609 (chi137 e576 r562 w577 mod579))))) (begin (if (eq? m564 (quote c&e)) (top-level-eval-hook74 x612 mod579)) x612)) (if (memv t611 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e576 (wrap129 value575 w577 mod579)) (syntax-violation #f "cannot define keyword at top level" e576 (wrap129 value575 w577 mod579))))))) (let ((x613 (chi-expr138 type574 value575 e576 r562 w577 s578 mod579))) (begin (if (eq? m564 (quote c&e)) (top-level-eval-hook74 x613 mod579)) x613)))))))))))) (syntax-type135 (lambda (e614 r615 w616 s617 rib618 mod619) (cond ((symbol? e614) (let ((n620 (id-var-name123 e614 w616))) (let ((b621 (lookup98 n620 r615 mod619))) (let ((type622 (binding-type93 b621))) (let ((t623 type622)) (if (memv t623 (quote (lexical))) (values type622 (binding-value94 b621) e614 w616 s617 mod619) (if (memv t623 (quote (global))) (values type622 n620 e614 w616 s617 mod619) (if (memv t623 (quote (macro))) (syntax-type135 (chi-macro140 (binding-value94 b621) e614 r615 w616 rib618 mod619) r615 (quote (())) s617 rib618 mod619) (values type622 (binding-value94 b621) e614 w616 s617 mod619))))))))) ((pair? e614) (let ((first624 (car e614))) (if (id?101 first624) (let ((n625 (id-var-name123 first624 w616))) (let ((b626 (lookup98 n625 r615 (or (and (syntax-object?85 first624) (syntax-object-module88 first624)) mod619)))) (let ((type627 (binding-type93 b626))) (let ((t628 type627)) (if (memv t628 (quote (lexical))) (values (quote lexical-call) (binding-value94 b626) e614 w616 s617 mod619) (if (memv t628 (quote (global))) (values (quote global-call) n625 e614 w616 s617 mod619) (if (memv t628 (quote (macro))) (syntax-type135 (chi-macro140 (binding-value94 b626) e614 r615 w616 rib618 mod619) r615 (quote (())) s617 rib618 mod619) (if (memv t628 (quote (core external-macro module-ref))) (values type627 (binding-value94 b626) e614 w616 s617 mod619) (if (memv t628 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value94 b626) e614 w616 s617 mod619) (if (memv t628 (quote (begin))) (values (quote begin-form) #f e614 w616 s617 mod619) (if (memv t628 (quote (eval-when))) (values (quote eval-when-form) #f e614 w616 s617 mod619) (if (memv t628 (quote (define))) ((lambda (tmp629) ((lambda (tmp630) (if (if tmp630 (apply (lambda (_631 name632 val633) (id?101 name632)) tmp630) #f) (apply (lambda (_634 name635 val636) (values (quote define-form) name635 val636 w616 s617 mod619)) tmp630) ((lambda (tmp637) (if (if tmp637 (apply (lambda (_638 name639 args640 e1641 e2642) (and (id?101 name639) (valid-bound-ids?126 (lambda-var-list150 args640)))) tmp637) #f) (apply (lambda (_643 name644 args645 e1646 e2647) (values (quote define-form) (wrap129 name644 w616 mod619) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap129 (cons args645 (cons e1646 e2647)) w616 mod619)) (quote (())) s617 mod619)) tmp637) ((lambda (tmp649) (if (if tmp649 (apply (lambda (_650 name651) (id?101 name651)) tmp649) #f) (apply (lambda (_652 name653) (values (quote define-form) (wrap129 name653 w616 mod619) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s617 mod619)) tmp649) (syntax-violation #f "source expression failed to match any pattern" tmp629))) ($sc-dispatch tmp629 (quote (any any)))))) ($sc-dispatch tmp629 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp629 (quote (any any any))))) e614) (if (memv t628 (quote (define-syntax))) ((lambda (tmp654) ((lambda (tmp655) (if (if tmp655 (apply (lambda (_656 name657 val658) (id?101 name657)) tmp655) #f) (apply (lambda (_659 name660 val661) (values (quote define-syntax-form) name660 val661 w616 s617 mod619)) tmp655) (syntax-violation #f "source expression failed to match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any any any))))) e614) (values (quote call) #f e614 w616 s617 mod619)))))))))))))) (values (quote call) #f e614 w616 s617 mod619)))) ((syntax-object?85 e614) (syntax-type135 (syntax-object-expression86 e614) r615 (join-wraps120 w616 (syntax-object-wrap87 e614)) #f rib618 (or (syntax-object-module88 e614) mod619))) ((annotation? e614) (syntax-type135 (annotation-expression e614) r615 w616 (annotation-source e614) rib618 mod619)) ((self-evaluating? e614) (values (quote constant) #f e614 w616 s617 mod619)) (else (values (quote other) #f e614 w616 s617 mod619))))) (chi-when-list134 (lambda (e662 when-list663 w664) (let f665 ((when-list666 when-list663) (situations667 (quote ()))) (if (null? when-list666) situations667 (f665 (cdr when-list666) (cons (let ((x668 (car when-list666))) (cond ((free-id=?124 x668 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?124 x668 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?124 x668 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e662 (wrap129 x668 w664 #f))))) situations667)))))) (chi-install-global133 (lambda (name669 e670) (build-annotated78 #f (list (build-annotated78 #f (quote define)) name669 (if (let ((v671 (module-variable (current-module) name669))) (and v671 (variable-bound? v671) (macro? (variable-ref v671)) (not (eq? (macro-type (variable-ref v671)) (quote syncase-macro))))) (build-annotated78 #f (list (build-annotated78 #f (quote make-extended-syncase-macro)) (build-annotated78 #f (list (build-annotated78 #f (quote module-ref)) (build-annotated78 #f (quote (current-module))) (build-data79 #f name669))) (build-data79 #f (quote macro)) e670)) (build-annotated78 #f (list (build-annotated78 #f (quote make-syncase-macro)) (build-data79 #f (quote macro)) e670))))))) (chi-top-sequence132 (lambda (body672 r673 w674 s675 m676 esew677 mod678) (build-sequence80 s675 (let dobody679 ((body680 body672) (r681 r673) (w682 w674) (m683 m676) (esew684 esew677) (mod685 mod678)) (if (null? body680) (quote ()) (let ((first686 (chi-top136 (car body680) r681 w682 m683 esew684 mod685))) (cons first686 (dobody679 (cdr body680) r681 w682 m683 esew684 mod685)))))))) (chi-sequence131 (lambda (body687 r688 w689 s690 mod691) (build-sequence80 s690 (let dobody692 ((body693 body687) (r694 r688) (w695 w689) (mod696 mod691)) (if (null? body693) (quote ()) (let ((first697 (chi137 (car body693) r694 w695 mod696))) (cons first697 (dobody692 (cdr body693) r694 w695 mod696)))))))) (source-wrap130 (lambda (x698 w699 s700 defmod701) (wrap129 (if s700 (make-annotation x698 s700 #f) x698) w699 defmod701))) (wrap129 (lambda (x702 w703 defmod704) (cond ((and (null? (wrap-marks104 w703)) (null? (wrap-subst105 w703))) x702) ((syntax-object?85 x702) (make-syntax-object84 (syntax-object-expression86 x702) (join-wraps120 w703 (syntax-object-wrap87 x702)) (syntax-object-module88 x702))) ((null? x702) x702) (else (make-syntax-object84 x702 w703 defmod704))))) (bound-id-member?128 (lambda (x705 list706) (and (not (null? list706)) (or (bound-id=?125 x705 (car list706)) (bound-id-member?128 x705 (cdr list706)))))) (distinct-bound-ids?127 (lambda (ids707) (let distinct?708 ((ids709 ids707)) (or (null? ids709) (and (not (bound-id-member?128 (car ids709) (cdr ids709))) (distinct?708 (cdr ids709))))))) (valid-bound-ids?126 (lambda (ids710) (and (let all-ids?711 ((ids712 ids710)) (or (null? ids712) (and (id?101 (car ids712)) (all-ids?711 (cdr ids712))))) (distinct-bound-ids?127 ids710)))) (bound-id=?125 (lambda (i713 j714) (if (and (syntax-object?85 i713) (syntax-object?85 j714)) (and (eq? (let ((e715 (syntax-object-expression86 i713))) (if (annotation? e715) (annotation-expression e715) e715)) (let ((e716 (syntax-object-expression86 j714))) (if (annotation? e716) (annotation-expression e716) e716))) (same-marks?122 (wrap-marks104 (syntax-object-wrap87 i713)) (wrap-marks104 (syntax-object-wrap87 j714)))) (eq? (let ((e717 i713)) (if (annotation? e717) (annotation-expression e717) e717)) (let ((e718 j714)) (if (annotation? e718) (annotation-expression e718) e718)))))) (free-id=?124 (lambda (i719 j720) (and (eq? (let ((x721 i719)) (let ((e722 (if (syntax-object?85 x721) (syntax-object-expression86 x721) x721))) (if (annotation? e722) (annotation-expression e722) e722))) (let ((x723 j720)) (let ((e724 (if (syntax-object?85 x723) (syntax-object-expression86 x723) x723))) (if (annotation? e724) (annotation-expression e724) e724)))) (eq? (id-var-name123 i719 (quote (()))) (id-var-name123 j720 (quote (()))))))) (id-var-name123 (lambda (id725 w726) (letrec ((search-vector-rib729 (lambda (sym735 subst736 marks737 symnames738 ribcage739) (let ((n740 (vector-length symnames738))) (let f741 ((i742 0)) (cond ((fx=72 i742 n740) (search727 sym735 (cdr subst736) marks737)) ((and (eq? (vector-ref symnames738 i742) sym735) (same-marks?122 marks737 (vector-ref (ribcage-marks111 ribcage739) i742))) (values (vector-ref (ribcage-labels112 ribcage739) i742) marks737)) (else (f741 (fx+70 i742 1)))))))) (search-list-rib728 (lambda (sym743 subst744 marks745 symnames746 ribcage747) (let f748 ((symnames749 symnames746) (i750 0)) (cond ((null? symnames749) (search727 sym743 (cdr subst744) marks745)) ((and (eq? (car symnames749) sym743) (same-marks?122 marks745 (list-ref (ribcage-marks111 ribcage747) i750))) (values (list-ref (ribcage-labels112 ribcage747) i750) marks745)) (else (f748 (cdr symnames749) (fx+70 i750 1))))))) (search727 (lambda (sym751 subst752 marks753) (if (null? subst752) (values #f marks753) (let ((fst754 (car subst752))) (if (eq? fst754 (quote shift)) (search727 sym751 (cdr subst752) (cdr marks753)) (let ((symnames755 (ribcage-symnames110 fst754))) (if (vector? symnames755) (search-vector-rib729 sym751 subst752 marks753 symnames755 fst754) (search-list-rib728 sym751 subst752 marks753 symnames755 fst754))))))))) (cond ((symbol? id725) (or (call-with-values (lambda () (search727 id725 (wrap-subst105 w726) (wrap-marks104 w726))) (lambda (x757 . ignore756) x757)) id725)) ((syntax-object?85 id725) (let ((id758 (let ((e760 (syntax-object-expression86 id725))) (if (annotation? e760) (annotation-expression e760) e760))) (w1759 (syntax-object-wrap87 id725))) (let ((marks761 (join-marks121 (wrap-marks104 w726) (wrap-marks104 w1759)))) (call-with-values (lambda () (search727 id758 (wrap-subst105 w726) marks761)) (lambda (new-id762 marks763) (or new-id762 (call-with-values (lambda () (search727 id758 (wrap-subst105 w1759) marks763)) (lambda (x765 . ignore764) x765)) id758)))))) ((annotation? id725) (let ((id766 (let ((e767 id725)) (if (annotation? e767) (annotation-expression e767) e767)))) (or (call-with-values (lambda () (search727 id766 (wrap-subst105 w726) (wrap-marks104 w726))) (lambda (x769 . ignore768) x769)) id766))) (else (syntax-violation (quote id-var-name) "invalid id" id725)))))) (same-marks?122 (lambda (x770 y771) (or (eq? x770 y771) (and (not (null? x770)) (not (null? y771)) (eq? (car x770) (car y771)) (same-marks?122 (cdr x770) (cdr y771)))))) (join-marks121 (lambda (m1772 m2773) (smart-append119 m1772 m2773))) (join-wraps120 (lambda (w1774 w2775) (let ((m1776 (wrap-marks104 w1774)) (s1777 (wrap-subst105 w1774))) (if (null? m1776) (if (null? s1777) w2775 (make-wrap103 (wrap-marks104 w2775) (smart-append119 s1777 (wrap-subst105 w2775)))) (make-wrap103 (smart-append119 m1776 (wrap-marks104 w2775)) (smart-append119 s1777 (wrap-subst105 w2775))))))) (smart-append119 (lambda (m1778 m2779) (if (null? m2779) m1778 (append m1778 m2779)))) (make-binding-wrap118 (lambda (ids780 labels781 w782) (if (null? ids780) w782 (make-wrap103 (wrap-marks104 w782) (cons (let ((labelvec783 (list->vector labels781))) (let ((n784 (vector-length labelvec783))) (let ((symnamevec785 (make-vector n784)) (marksvec786 (make-vector n784))) (begin (let f787 ((ids788 ids780) (i789 0)) (if (not (null? ids788)) (call-with-values (lambda () (id-sym-name&marks102 (car ids788) w782)) (lambda (symname790 marks791) (begin (vector-set! symnamevec785 i789 symname790) (vector-set! marksvec786 i789 marks791) (f787 (cdr ids788) (fx+70 i789 1))))))) (make-ribcage108 symnamevec785 marksvec786 labelvec783))))) (wrap-subst105 w782)))))) (extend-ribcage!117 (lambda (ribcage792 id793 label794) (begin (set-ribcage-symnames!113 ribcage792 (cons (let ((e795 (syntax-object-expression86 id793))) (if (annotation? e795) (annotation-expression e795) e795)) (ribcage-symnames110 ribcage792))) (set-ribcage-marks!114 ribcage792 (cons (wrap-marks104 (syntax-object-wrap87 id793)) (ribcage-marks111 ribcage792))) (set-ribcage-labels!115 ribcage792 (cons label794 (ribcage-labels112 ribcage792)))))) (anti-mark116 (lambda (w796) (make-wrap103 (cons #f (wrap-marks104 w796)) (cons (quote shift) (wrap-subst105 w796))))) (set-ribcage-labels!115 (lambda (x797 update798) (vector-set! x797 3 update798))) (set-ribcage-marks!114 (lambda (x799 update800) (vector-set! x799 2 update800))) (set-ribcage-symnames!113 (lambda (x801 update802) (vector-set! x801 1 update802))) (ribcage-labels112 (lambda (x803) (vector-ref x803 3))) (ribcage-marks111 (lambda (x804) (vector-ref x804 2))) (ribcage-symnames110 (lambda (x805) (vector-ref x805 1))) (ribcage?109 (lambda (x806) (and (vector? x806) (= (vector-length x806) 4) (eq? (vector-ref x806 0) (quote ribcage))))) (make-ribcage108 (lambda (symnames807 marks808 labels809) (vector (quote ribcage) symnames807 marks808 labels809))) (gen-labels107 (lambda (ls810) (if (null? ls810) (quote ()) (cons (gen-label106) (gen-labels107 (cdr ls810)))))) (gen-label106 (lambda () (string #\i))) (wrap-subst105 cdr) (wrap-marks104 car) (make-wrap103 cons) (id-sym-name&marks102 (lambda (x811 w812) (if (syntax-object?85 x811) (values (let ((e813 (syntax-object-expression86 x811))) (if (annotation? e813) (annotation-expression e813) e813)) (join-marks121 (wrap-marks104 w812) (wrap-marks104 (syntax-object-wrap87 x811)))) (values (let ((e814 x811)) (if (annotation? e814) (annotation-expression e814) e814)) (wrap-marks104 w812))))) (id?101 (lambda (x815) (cond ((symbol? x815) #t) ((syntax-object?85 x815) (symbol? (let ((e816 (syntax-object-expression86 x815))) (if (annotation? e816) (annotation-expression e816) e816)))) ((annotation? x815) (symbol? (annotation-expression x815))) (else #f)))) (nonsymbol-id?100 (lambda (x817) (and (syntax-object?85 x817) (symbol? (let ((e818 (syntax-object-expression86 x817))) (if (annotation? e818) (annotation-expression e818) e818)))))) (global-extend99 (lambda (type819 sym820 val821) (put-global-definition-hook76 sym820 type819 val821))) (lookup98 (lambda (x822 r823 mod824) (cond ((assq x822 r823) => cdr) ((symbol? x822) (or (get-global-definition-hook77 x822 mod824) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env97 (lambda (r825) (if (null? r825) (quote ()) (let ((a826 (car r825))) (if (eq? (cadr a826) (quote macro)) (cons a826 (macros-only-env97 (cdr r825))) (macros-only-env97 (cdr r825))))))) (extend-var-env96 (lambda (labels827 vars828 r829) (if (null? labels827) r829 (extend-var-env96 (cdr labels827) (cdr vars828) (cons (cons (car labels827) (cons (quote lexical) (car vars828))) r829))))) (extend-env95 (lambda (labels830 bindings831 r832) (if (null? labels830) r832 (extend-env95 (cdr labels830) (cdr bindings831) (cons (cons (car labels830) (car bindings831)) r832))))) (binding-value94 cdr) (binding-type93 car) (source-annotation92 (lambda (x833) (cond ((annotation? x833) (annotation-source x833)) ((syntax-object?85 x833) (source-annotation92 (syntax-object-expression86 x833))) (else #f)))) (set-syntax-object-module!91 (lambda (x834 update835) (vector-set! x834 3 update835))) (set-syntax-object-wrap!90 (lambda (x836 update837) (vector-set! x836 2 update837))) (set-syntax-object-expression!89 (lambda (x838 update839) (vector-set! x838 1 update839))) (syntax-object-module88 (lambda (x840) (vector-ref x840 3))) (syntax-object-wrap87 (lambda (x841) (vector-ref x841 2))) (syntax-object-expression86 (lambda (x842) (vector-ref x842 1))) (syntax-object?85 (lambda (x843) (and (vector? x843) (= (vector-length x843) 4) (eq? (vector-ref x843 0) (quote syntax-object))))) (make-syntax-object84 (lambda (expression844 wrap845 module846) (vector (quote syntax-object) expression844 wrap845 module846))) (build-letrec83 (lambda (src847 vars848 val-exps849 body-exp850) (if (null? vars848) (build-annotated78 src847 body-exp850) (build-annotated78 src847 (list (quote letrec) (map list vars848 val-exps849) body-exp850))))) (build-named-let82 (lambda (src851 vars852 val-exps853 body-exp854) (if (null? vars852) (build-annotated78 src851 body-exp854) (build-annotated78 src851 (list (quote let) (car vars852) (map list (cdr vars852) val-exps853) body-exp854))))) (build-let81 (lambda (src855 vars856 val-exps857 body-exp858) (if (null? vars856) (build-annotated78 src855 body-exp858) (build-annotated78 src855 (list (quote let) (map list vars856 val-exps857) body-exp858))))) (build-sequence80 (lambda (src859 exps860) (if (null? (cdr exps860)) (build-annotated78 src859 (car exps860)) (build-annotated78 src859 (cons (quote begin) exps860))))) (build-data79 (lambda (src861 exp862) (if (and (self-evaluating? exp862) (not (vector? exp862))) (build-annotated78 src861 exp862) (build-annotated78 src861 (list (quote quote) exp862))))) (build-annotated78 (lambda (src863 exp864) (if (and src863 (not (annotation? exp864))) (make-annotation exp864 src863 #t) exp864))) (get-global-definition-hook77 (lambda (symbol865 module866) (begin (if (and (not module866) (current-module)) (warn "module system is booted, we should have a module" symbol865)) (let ((v867 (module-variable (if module866 (resolve-module (cdr module866)) (current-module)) symbol865))) (and v867 (variable-bound? v867) (let ((val868 (variable-ref v867))) (and (macro? val868) (syncase-macro-type val868) (cons (syncase-macro-type val868) (syncase-macro-binding val868))))))))) (put-global-definition-hook76 (lambda (symbol869 type870 val871) (let ((existing872 (let ((v873 (module-variable (current-module) symbol869))) (and v873 (variable-bound? v873) (let ((val874 (variable-ref v873))) (and (macro? val874) (not (syncase-macro-type val874)) val874)))))) (module-define! (current-module) symbol869 (if existing872 (make-extended-syncase-macro existing872 type870 val871) (make-syncase-macro type870 val871)))))) (local-eval-hook75 (lambda (x875 mod876) (primitive-eval (list noexpand69 x875)))) (top-level-eval-hook74 (lambda (x877 mod878) (primitive-eval (list noexpand69 x877)))) (fx<73 <) (fx=72 =) (fx-71 -) (fx+70 +) (noexpand69 "noexpand")) (begin (global-extend99 (quote local-syntax) (quote letrec-syntax) #t) (global-extend99 (quote local-syntax) (quote let-syntax) #f) (global-extend99 (quote core) (quote fluid-let-syntax) (lambda (e879 r880 w881 s882 mod883) ((lambda (tmp884) ((lambda (tmp885) (if (if tmp885 (apply (lambda (_886 var887 val888 e1889 e2890) (valid-bound-ids?126 var887)) tmp885) #f) (apply (lambda (_892 var893 val894 e1895 e2896) (let ((names897 (map (lambda (x898) (id-var-name123 x898 w881)) var893))) (begin (for-each (lambda (id900 n901) (let ((t902 (binding-type93 (lookup98 n901 r880 mod883)))) (if (memv t902 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e879 (source-wrap130 id900 w881 s882 mod883))))) var893 names897) (chi-body141 (cons e1895 e2896) (source-wrap130 e879 w881 s882 mod883) (extend-env95 names897 (let ((trans-r905 (macros-only-env97 r880))) (map (lambda (x906) (cons (quote macro) (eval-local-transformer144 (chi137 x906 trans-r905 w881 mod883) mod883))) val894)) r880) w881 mod883)))) tmp885) ((lambda (_908) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap130 e879 w881 s882 mod883))) tmp884))) ($sc-dispatch tmp884 (quote (any #(each (any any)) any . each-any))))) e879))) (global-extend99 (quote core) (quote quote) (lambda (e909 r910 w911 s912 mod913) ((lambda (tmp914) ((lambda (tmp915) (if tmp915 (apply (lambda (_916 e917) (build-data79 s912 (strip148 e917 w911))) tmp915) ((lambda (_918) (syntax-violation (quote quote) "bad syntax" (source-wrap130 e909 w911 s912 mod913))) tmp914))) ($sc-dispatch tmp914 (quote (any any))))) e909))) (global-extend99 (quote core) (quote syntax) (letrec ((regen926 (lambda (x927) (let ((t928 (car x927))) (if (memv t928 (quote (ref))) (build-annotated78 #f (cadr x927)) (if (memv t928 (quote (primitive))) (build-annotated78 #f (cadr x927)) (if (memv t928 (quote (quote))) (build-data79 #f (cadr x927)) (if (memv t928 (quote (lambda))) (build-annotated78 #f (list (quote lambda) (cadr x927) (regen926 (caddr x927)))) (if (memv t928 (quote (map))) (let ((ls929 (map regen926 (cdr x927)))) (build-annotated78 #f (cons (if (fx=72 (length ls929) 2) (build-annotated78 #f (quote map)) (build-annotated78 #f (quote map))) ls929))) (build-annotated78 #f (cons (build-annotated78 #f (car x927)) (map regen926 (cdr x927)))))))))))) (gen-vector925 (lambda (x930) (cond ((eq? (car x930) (quote list)) (cons (quote vector) (cdr x930))) ((eq? (car x930) (quote quote)) (list (quote quote) (list->vector (cadr x930)))) (else (list (quote list->vector) x930))))) (gen-append924 (lambda (x931 y932) (if (equal? y932 (quote (quote ()))) x931 (list (quote append) x931 y932)))) (gen-cons923 (lambda (x933 y934) (let ((t935 (car y934))) (if (memv t935 (quote (quote))) (if (eq? (car x933) (quote quote)) (list (quote quote) (cons (cadr x933) (cadr y934))) (if (eq? (cadr y934) (quote ())) (list (quote list) x933) (list (quote cons) x933 y934))) (if (memv t935 (quote (list))) (cons (quote list) (cons x933 (cdr y934))) (list (quote cons) x933 y934)))))) (gen-map922 (lambda (e936 map-env937) (let ((formals938 (map cdr map-env937)) (actuals939 (map (lambda (x940) (list (quote ref) (car x940))) map-env937))) (cond ((eq? (car e936) (quote ref)) (car actuals939)) ((and-map (lambda (x941) (and (eq? (car x941) (quote ref)) (memq (cadr x941) formals938))) (cdr e936)) (cons (quote map) (cons (list (quote primitive) (car e936)) (map (let ((r942 (map cons formals938 actuals939))) (lambda (x943) (cdr (assq (cadr x943) r942)))) (cdr e936))))) (else (cons (quote map) (cons (list (quote lambda) formals938 e936) actuals939))))))) (gen-mappend921 (lambda (e944 map-env945) (list (quote apply) (quote (primitive append)) (gen-map922 e944 map-env945)))) (gen-ref920 (lambda (src946 var947 level948 maps949) (if (fx=72 level948 0) (values var947 maps949) (if (null? maps949) (syntax-violation (quote syntax) "missing ellipsis" src946) (call-with-values (lambda () (gen-ref920 src946 var947 (fx-71 level948 1) (cdr maps949))) (lambda (outer-var950 outer-maps951) (let ((b952 (assq outer-var950 (car maps949)))) (if b952 (values (cdr b952) maps949) (let ((inner-var953 (gen-var149 (quote tmp)))) (values inner-var953 (cons (cons (cons outer-var950 inner-var953) (car maps949)) outer-maps951))))))))))) (gen-syntax919 (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) (if (id?101 e955) (let ((label960 (id-var-name123 e955 (quote (()))))) (let ((b961 (lookup98 label960 r956 mod959))) (if (eq? (binding-type93 b961) (quote syntax)) (call-with-values (lambda () (let ((var.lev962 (binding-value94 b961))) (gen-ref920 src954 (car var.lev962) (cdr var.lev962) maps957))) (lambda (var963 maps964) (values (list (quote ref) var963) maps964))) (if (ellipsis?958 e955) (syntax-violation (quote syntax) "misplaced ellipsis" src954) (values (list (quote quote) e955) maps957))))) ((lambda (tmp965) ((lambda (tmp966) (if (if tmp966 (apply (lambda (dots967 e968) (ellipsis?958 dots967)) tmp966) #f) (apply (lambda (dots969 e970) (gen-syntax919 src954 e970 r956 maps957 (lambda (x971) #f) mod959)) tmp966) ((lambda (tmp972) (if (if tmp972 (apply (lambda (x973 dots974 y975) (ellipsis?958 dots974)) tmp972) #f) (apply (lambda (x976 dots977 y978) (let f979 ((y980 y978) (k981 (lambda (maps982) (call-with-values (lambda () (gen-syntax919 src954 x976 r956 (cons (quote ()) maps982) ellipsis?958 mod959)) (lambda (x983 maps984) (if (null? (car maps984)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-map922 x983 (car maps984)) (cdr maps984)))))))) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 y988) (ellipsis?958 dots987)) tmp986) #f) (apply (lambda (dots989 y990) (f979 y990 (lambda (maps991) (call-with-values (lambda () (k981 (cons (quote ()) maps991))) (lambda (x992 maps993) (if (null? (car maps993)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-mappend921 x992 (car maps993)) (cdr maps993)))))))) tmp986) ((lambda (_994) (call-with-values (lambda () (gen-syntax919 src954 y980 r956 maps957 ellipsis?958 mod959)) (lambda (y995 maps996) (call-with-values (lambda () (k981 maps996)) (lambda (x997 maps998) (values (gen-append924 x997 y995) maps998)))))) tmp985))) ($sc-dispatch tmp985 (quote (any . any))))) y980))) tmp972) ((lambda (tmp999) (if tmp999 (apply (lambda (x1000 y1001) (call-with-values (lambda () (gen-syntax919 src954 x1000 r956 maps957 ellipsis?958 mod959)) (lambda (x1002 maps1003) (call-with-values (lambda () (gen-syntax919 src954 y1001 r956 maps1003 ellipsis?958 mod959)) (lambda (y1004 maps1005) (values (gen-cons923 x1002 y1004) maps1005)))))) tmp999) ((lambda (tmp1006) (if tmp1006 (apply (lambda (e11007 e21008) (call-with-values (lambda () (gen-syntax919 src954 (cons e11007 e21008) r956 maps957 ellipsis?958 mod959)) (lambda (e1010 maps1011) (values (gen-vector925 e1010) maps1011)))) tmp1006) ((lambda (_1012) (values (list (quote quote) e955) maps957)) tmp965))) ($sc-dispatch tmp965 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp965 (quote (any . any)))))) ($sc-dispatch tmp965 (quote (any any . any)))))) ($sc-dispatch tmp965 (quote (any any))))) e955))))) (lambda (e1013 r1014 w1015 s1016 mod1017) (let ((e1018 (source-wrap130 e1013 w1015 s1016 mod1017))) ((lambda (tmp1019) ((lambda (tmp1020) (if tmp1020 (apply (lambda (_1021 x1022) (call-with-values (lambda () (gen-syntax919 e1018 x1022 r1014 (quote ()) ellipsis?146 mod1017)) (lambda (e1023 maps1024) (regen926 e1023)))) tmp1020) ((lambda (_1025) (syntax-violation (quote syntax) "bad `syntax' form" e1018)) tmp1019))) ($sc-dispatch tmp1019 (quote (any any))))) e1018))))) (global-extend99 (quote core) (quote lambda) (lambda (e1026 r1027 w1028 s1029 mod1030) ((lambda (tmp1031) ((lambda (tmp1032) (if tmp1032 (apply (lambda (_1033 c1034) (chi-lambda-clause142 (source-wrap130 e1026 w1028 s1029 mod1030) #f c1034 r1027 w1028 mod1030 (lambda (vars1035 docstring1036 body1037) (build-annotated78 s1029 (cons (quote lambda) (cons vars1035 (append (if docstring1036 (list docstring1036) (quote ())) (list body1037)))))))) tmp1032) (syntax-violation #f "source expression failed to match any pattern" tmp1031))) ($sc-dispatch tmp1031 (quote (any . any))))) e1026))) (global-extend99 (quote core) (quote let) (letrec ((chi-let1038 (lambda (e1039 r1040 w1041 s1042 mod1043 constructor1044 ids1045 vals1046 exps1047) (if (not (valid-bound-ids?126 ids1045)) (syntax-violation (quote let) "duplicate bound variable" e1039) (let ((labels1048 (gen-labels107 ids1045)) (new-vars1049 (map gen-var149 ids1045))) (let ((nw1050 (make-binding-wrap118 ids1045 labels1048 w1041)) (nr1051 (extend-var-env96 labels1048 new-vars1049 r1040))) (constructor1044 s1042 new-vars1049 (map (lambda (x1052) (chi137 x1052 r1040 w1041 mod1043)) vals1046) (chi-body141 exps1047 (source-wrap130 e1039 nw1050 s1042 mod1043) nr1051 nw1050 mod1043)))))))) (lambda (e1053 r1054 w1055 s1056 mod1057) ((lambda (tmp1058) ((lambda (tmp1059) (if tmp1059 (apply (lambda (_1060 id1061 val1062 e11063 e21064) (chi-let1038 e1053 r1054 w1055 s1056 mod1057 build-let81 id1061 val1062 (cons e11063 e21064))) tmp1059) ((lambda (tmp1068) (if (if tmp1068 (apply (lambda (_1069 f1070 id1071 val1072 e11073 e21074) (id?101 f1070)) tmp1068) #f) (apply (lambda (_1075 f1076 id1077 val1078 e11079 e21080) (chi-let1038 e1053 r1054 w1055 s1056 mod1057 build-named-let82 (cons f1076 id1077) val1078 (cons e11079 e21080))) tmp1068) ((lambda (_1084) (syntax-violation (quote let) "bad let" (source-wrap130 e1053 w1055 s1056 mod1057))) tmp1058))) ($sc-dispatch tmp1058 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1058 (quote (any #(each (any any)) any . each-any))))) e1053)))) (global-extend99 (quote core) (quote letrec) (lambda (e1085 r1086 w1087 s1088 mod1089) ((lambda (tmp1090) ((lambda (tmp1091) (if tmp1091 (apply (lambda (_1092 id1093 val1094 e11095 e21096) (let ((ids1097 id1093)) (if (not (valid-bound-ids?126 ids1097)) (syntax-violation (quote letrec) "duplicate bound variable" e1085) (let ((labels1099 (gen-labels107 ids1097)) (new-vars1100 (map gen-var149 ids1097))) (let ((w1101 (make-binding-wrap118 ids1097 labels1099 w1087)) (r1102 (extend-var-env96 labels1099 new-vars1100 r1086))) (build-letrec83 s1088 new-vars1100 (map (lambda (x1103) (chi137 x1103 r1102 w1101 mod1089)) val1094) (chi-body141 (cons e11095 e21096) (source-wrap130 e1085 w1101 s1088 mod1089) r1102 w1101 mod1089))))))) tmp1091) ((lambda (_1106) (syntax-violation (quote letrec) "bad letrec" (source-wrap130 e1085 w1087 s1088 mod1089))) tmp1090))) ($sc-dispatch tmp1090 (quote (any #(each (any any)) any . each-any))))) e1085))) (global-extend99 (quote core) (quote set!) (lambda (e1107 r1108 w1109 s1110 mod1111) ((lambda (tmp1112) ((lambda (tmp1113) (if (if tmp1113 (apply (lambda (_1114 id1115 val1116) (id?101 id1115)) tmp1113) #f) (apply (lambda (_1117 id1118 val1119) (let ((val1120 (chi137 val1119 r1108 w1109 mod1111)) (n1121 (id-var-name123 id1118 w1109))) (let ((b1122 (lookup98 n1121 r1108 mod1111))) (let ((t1123 (binding-type93 b1122))) (if (memv t1123 (quote (lexical))) (build-annotated78 s1110 (list (quote set!) (binding-value94 b1122) val1120)) (if (memv t1123 (quote (global))) (build-annotated78 s1110 (list (quote set!) (if mod1111 (make-module-ref (cdr mod1111) n1121 (car mod1111)) (make-module-ref mod1111 n1121 (quote bare))) val1120)) (if (memv t1123 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap129 id1118 w1109 mod1111)) (syntax-violation (quote set!) "bad set!" (source-wrap130 e1107 w1109 s1110 mod1111))))))))) tmp1113) ((lambda (tmp1124) (if tmp1124 (apply (lambda (_1125 head1126 tail1127 val1128) (call-with-values (lambda () (syntax-type135 head1126 r1108 (quote (())) #f #f mod1111)) (lambda (type1129 value1130 ee1131 ww1132 ss1133 modmod1134) (let ((t1135 type1129)) (if (memv t1135 (quote (module-ref))) (let ((val1136 (chi137 val1128 r1108 w1109 mod1111))) (call-with-values (lambda () (value1130 (cons head1126 tail1127))) (lambda (id1138 mod1139) (build-annotated78 s1110 (list (quote set!) (if mod1139 (make-module-ref (cdr mod1139) id1138 (car mod1139)) (make-module-ref mod1139 id1138 (quote bare))) val1136))))) (build-annotated78 s1110 (cons (chi137 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1126) r1108 w1109 mod1111) (map (lambda (e1140) (chi137 e1140 r1108 w1109 mod1111)) (append tail1127 (list val1128)))))))))) tmp1124) ((lambda (_1142) (syntax-violation (quote set!) "bad set!" (source-wrap130 e1107 w1109 s1110 mod1111))) tmp1112))) ($sc-dispatch tmp1112 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1112 (quote (any any any))))) e1107))) (global-extend99 (quote module-ref) (quote @) (lambda (e1143) ((lambda (tmp1144) ((lambda (tmp1145) (if (if tmp1145 (apply (lambda (_1146 mod1147 id1148) (and (and-map id?101 mod1147) (id?101 id1148))) tmp1145) #f) (apply (lambda (_1150 mod1151 id1152) (values (syntax->datum id1152) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1151)))) tmp1145) (syntax-violation #f "source expression failed to match any pattern" tmp1144))) ($sc-dispatch tmp1144 (quote (any each-any any))))) e1143))) (global-extend99 (quote module-ref) (quote @@) (lambda (e1154) ((lambda (tmp1155) ((lambda (tmp1156) (if (if tmp1156 (apply (lambda (_1157 mod1158 id1159) (and (and-map id?101 mod1158) (id?101 id1159))) tmp1156) #f) (apply (lambda (_1161 mod1162 id1163) (values (syntax->datum id1163) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1162)))) tmp1156) (syntax-violation #f "source expression failed to match any pattern" tmp1155))) ($sc-dispatch tmp1155 (quote (any each-any any))))) e1154))) (global-extend99 (quote begin) (quote begin) (quote ())) (global-extend99 (quote define) (quote define) (quote ())) (global-extend99 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend99 (quote eval-when) (quote eval-when) (quote ())) (global-extend99 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1168 (lambda (x1169 keys1170 clauses1171 r1172 mod1173) (if (null? clauses1171) (build-annotated78 #f (list (build-annotated78 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1169)) ((lambda (tmp1174) ((lambda (tmp1175) (if tmp1175 (apply (lambda (pat1176 exp1177) (if (and (id?101 pat1176) (and-map (lambda (x1178) (not (free-id=?124 pat1176 x1178))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1170))) (let ((labels1179 (list (gen-label106))) (var1180 (gen-var149 pat1176))) (build-annotated78 #f (list (build-annotated78 #f (list (quote lambda) (list var1180) (chi137 exp1177 (extend-env95 labels1179 (list (cons (quote syntax) (cons var1180 0))) r1172) (make-binding-wrap118 (list pat1176) labels1179 (quote (()))) mod1173))) x1169))) (gen-clause1167 x1169 keys1170 (cdr clauses1171) r1172 pat1176 #t exp1177 mod1173))) tmp1175) ((lambda (tmp1181) (if tmp1181 (apply (lambda (pat1182 fender1183 exp1184) (gen-clause1167 x1169 keys1170 (cdr clauses1171) r1172 pat1182 fender1183 exp1184 mod1173)) tmp1181) ((lambda (_1185) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1171))) tmp1174))) ($sc-dispatch tmp1174 (quote (any any any)))))) ($sc-dispatch tmp1174 (quote (any any))))) (car clauses1171))))) (gen-clause1167 (lambda (x1186 keys1187 clauses1188 r1189 pat1190 fender1191 exp1192 mod1193) (call-with-values (lambda () (convert-pattern1165 pat1190 keys1187)) (lambda (p1194 pvars1195) (cond ((not (distinct-bound-ids?127 (map car pvars1195))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1190)) ((not (and-map (lambda (x1196) (not (ellipsis?146 (car x1196)))) pvars1195)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1190)) (else (let ((y1197 (gen-var149 (quote tmp)))) (build-annotated78 #f (list (build-annotated78 #f (list (quote lambda) (list y1197) (let ((y1198 (build-annotated78 #f y1197))) (build-annotated78 #f (list (quote if) ((lambda (tmp1199) ((lambda (tmp1200) (if tmp1200 (apply (lambda () y1198) tmp1200) ((lambda (_1201) (build-annotated78 #f (list (quote if) y1198 (build-dispatch-call1166 pvars1195 fender1191 y1198 r1189 mod1193) (build-data79 #f #f)))) tmp1199))) ($sc-dispatch tmp1199 (quote #(atom #t))))) fender1191) (build-dispatch-call1166 pvars1195 exp1192 y1198 r1189 mod1193) (gen-syntax-case1168 x1186 keys1187 clauses1188 r1189 mod1193)))))) (if (eq? p1194 (quote any)) (build-annotated78 #f (list (build-annotated78 #f (quote list)) x1186)) (build-annotated78 #f (list (build-annotated78 #f (quote $sc-dispatch)) x1186 (build-data79 #f p1194))))))))))))) (build-dispatch-call1166 (lambda (pvars1202 exp1203 y1204 r1205 mod1206) (let ((ids1207 (map car pvars1202)) (levels1208 (map cdr pvars1202))) (let ((labels1209 (gen-labels107 ids1207)) (new-vars1210 (map gen-var149 ids1207))) (build-annotated78 #f (list (build-annotated78 #f (quote apply)) (build-annotated78 #f (list (quote lambda) new-vars1210 (chi137 exp1203 (extend-env95 labels1209 (map (lambda (var1211 level1212) (cons (quote syntax) (cons var1211 level1212))) new-vars1210 (map cdr pvars1202)) r1205) (make-binding-wrap118 ids1207 labels1209 (quote (()))) mod1206))) y1204)))))) (convert-pattern1165 (lambda (pattern1213 keys1214) (let cvt1215 ((p1216 pattern1213) (n1217 0) (ids1218 (quote ()))) (if (id?101 p1216) (if (bound-id-member?128 p1216 keys1214) (values (vector (quote free-id) p1216) ids1218) (values (quote any) (cons (cons p1216 n1217) ids1218))) ((lambda (tmp1219) ((lambda (tmp1220) (if (if tmp1220 (apply (lambda (x1221 dots1222) (ellipsis?146 dots1222)) tmp1220) #f) (apply (lambda (x1223 dots1224) (call-with-values (lambda () (cvt1215 x1223 (fx+70 n1217 1) ids1218)) (lambda (p1225 ids1226) (values (if (eq? p1225 (quote any)) (quote each-any) (vector (quote each) p1225)) ids1226)))) tmp1220) ((lambda (tmp1227) (if tmp1227 (apply (lambda (x1228 y1229) (call-with-values (lambda () (cvt1215 y1229 n1217 ids1218)) (lambda (y1230 ids1231) (call-with-values (lambda () (cvt1215 x1228 n1217 ids1231)) (lambda (x1232 ids1233) (values (cons x1232 y1230) ids1233)))))) tmp1227) ((lambda (tmp1234) (if tmp1234 (apply (lambda () (values (quote ()) ids1218)) tmp1234) ((lambda (tmp1235) (if tmp1235 (apply (lambda (x1236) (call-with-values (lambda () (cvt1215 x1236 n1217 ids1218)) (lambda (p1238 ids1239) (values (vector (quote vector) p1238) ids1239)))) tmp1235) ((lambda (x1240) (values (vector (quote atom) (strip148 p1216 (quote (())))) ids1218)) tmp1219))) ($sc-dispatch tmp1219 (quote #(vector each-any)))))) ($sc-dispatch tmp1219 (quote ()))))) ($sc-dispatch tmp1219 (quote (any . any)))))) ($sc-dispatch tmp1219 (quote (any any))))) p1216)))))) (lambda (e1241 r1242 w1243 s1244 mod1245) (let ((e1246 (source-wrap130 e1241 w1243 s1244 mod1245))) ((lambda (tmp1247) ((lambda (tmp1248) (if tmp1248 (apply (lambda (_1249 val1250 key1251 m1252) (if (and-map (lambda (x1253) (and (id?101 x1253) (not (ellipsis?146 x1253)))) key1251) (let ((x1255 (gen-var149 (quote tmp)))) (build-annotated78 s1244 (list (build-annotated78 #f (list (quote lambda) (list x1255) (gen-syntax-case1168 (build-annotated78 #f x1255) key1251 m1252 r1242 mod1245))) (chi137 val1250 r1242 (quote (())) mod1245)))) (syntax-violation (quote syntax-case) "invalid literals list" e1246))) tmp1248) (syntax-violation #f "source expression failed to match any pattern" tmp1247))) ($sc-dispatch tmp1247 (quote (any any each-any . each-any))))) e1246))))) (set! sc-expand (let ((m1258 (quote e)) (esew1259 (quote (eval)))) (lambda (x1260) (if (and (pair? x1260) (equal? (car x1260) noexpand69)) (cadr x1260) (chi-top136 x1260 (quote ()) (quote ((top))) m1258 esew1259 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m1261 (quote e)) (esew1262 (quote (eval)))) (lambda (x1264 . rest1263) (if (and (pair? x1264) (equal? (car x1264) noexpand69)) (cadr x1264) (chi-top136 x1264 (quote ()) (quote ((top))) (if (null? rest1263) m1261 (car rest1263)) (if (or (null? rest1263) (null? (cdr rest1263))) esew1262 (cadr rest1263)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x1265) (nonsymbol-id?100 x1265))) (set! datum->syntax (lambda (id1266 datum1267) (make-syntax-object84 datum1267 (syntax-object-wrap87 id1266) #f))) (set! syntax->datum (lambda (x1268) (strip148 x1268 (quote (()))))) (set! generate-temporaries (lambda (ls1269) (begin (let ((x1270 ls1269)) (if (not (list? x1270)) (syntax-violation (quote generate-temporaries) "invalid argument" x1270))) (map (lambda (x1271) (wrap129 (gensym) (quote ((top))) #f)) ls1269)))) (set! free-identifier=? (lambda (x1272 y1273) (begin (let ((x1274 x1272)) (if (not (nonsymbol-id?100 x1274)) (syntax-violation (quote free-identifier=?) "invalid argument" x1274))) (let ((x1275 y1273)) (if (not (nonsymbol-id?100 x1275)) (syntax-violation (quote free-identifier=?) "invalid argument" x1275))) (free-id=?124 x1272 y1273)))) (set! bound-identifier=? (lambda (x1276 y1277) (begin (let ((x1278 x1276)) (if (not (nonsymbol-id?100 x1278)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1278))) (let ((x1279 y1277)) (if (not (nonsymbol-id?100 x1279)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1279))) (bound-id=?125 x1276 y1277)))) (set! syntax-violation (lambda (who1283 message1282 form1281 . subform1280) (begin (let ((x1284 who1283)) (if (not ((lambda (x1285) (or (not x1285) (string? x1285) (symbol? x1285))) x1284)) (syntax-violation (quote syntax-violation) "invalid argument" x1284))) (let ((x1286 message1282)) (if (not (string? x1286)) (syntax-violation (quote syntax-violation) "invalid argument" x1286))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1283 "~a: " "") "~a " (if (null? subform1280) "in ~a" "in subform `~s' of `~s'")) (let ((tail1287 (cons message1282 (map (lambda (x1288) (strip148 x1288 (quote (())))) (append subform1280 (list form1281)))))) (if who1283 (cons who1283 tail1287) tail1287)) #f)))) (letrec ((match1293 (lambda (e1294 p1295 w1296 r1297 mod1298) (cond ((not r1297) #f) ((eq? p1295 (quote any)) (cons (wrap129 e1294 w1296 mod1298) r1297)) ((syntax-object?85 e1294) (match*1292 (let ((e1299 (syntax-object-expression86 e1294))) (if (annotation? e1299) (annotation-expression e1299) e1299)) p1295 (join-wraps120 w1296 (syntax-object-wrap87 e1294)) r1297 (syntax-object-module88 e1294))) (else (match*1292 (let ((e1300 e1294)) (if (annotation? e1300) (annotation-expression e1300) e1300)) p1295 w1296 r1297 mod1298))))) (match*1292 (lambda (e1301 p1302 w1303 r1304 mod1305) (cond ((null? p1302) (and (null? e1301) r1304)) ((pair? p1302) (and (pair? e1301) (match1293 (car e1301) (car p1302) w1303 (match1293 (cdr e1301) (cdr p1302) w1303 r1304 mod1305) mod1305))) ((eq? p1302 (quote each-any)) (let ((l1306 (match-each-any1290 e1301 w1303 mod1305))) (and l1306 (cons l1306 r1304)))) (else (let ((t1307 (vector-ref p1302 0))) (if (memv t1307 (quote (each))) (if (null? e1301) (match-empty1291 (vector-ref p1302 1) r1304) (let ((l1308 (match-each1289 e1301 (vector-ref p1302 1) w1303 mod1305))) (and l1308 (let collect1309 ((l1310 l1308)) (if (null? (car l1310)) r1304 (cons (map car l1310) (collect1309 (map cdr l1310)))))))) (if (memv t1307 (quote (free-id))) (and (id?101 e1301) (free-id=?124 (wrap129 e1301 w1303 mod1305) (vector-ref p1302 1)) r1304) (if (memv t1307 (quote (atom))) (and (equal? (vector-ref p1302 1) (strip148 e1301 w1303)) r1304) (if (memv t1307 (quote (vector))) (and (vector? e1301) (match1293 (vector->list e1301) (vector-ref p1302 1) w1303 r1304 mod1305))))))))))) (match-empty1291 (lambda (p1311 r1312) (cond ((null? p1311) r1312) ((eq? p1311 (quote any)) (cons (quote ()) r1312)) ((pair? p1311) (match-empty1291 (car p1311) (match-empty1291 (cdr p1311) r1312))) ((eq? p1311 (quote each-any)) (cons (quote ()) r1312)) (else (let ((t1313 (vector-ref p1311 0))) (if (memv t1313 (quote (each))) (match-empty1291 (vector-ref p1311 1) r1312) (if (memv t1313 (quote (free-id atom))) r1312 (if (memv t1313 (quote (vector))) (match-empty1291 (vector-ref p1311 1) r1312))))))))) (match-each-any1290 (lambda (e1314 w1315 mod1316) (cond ((annotation? e1314) (match-each-any1290 (annotation-expression e1314) w1315 mod1316)) ((pair? e1314) (let ((l1317 (match-each-any1290 (cdr e1314) w1315 mod1316))) (and l1317 (cons (wrap129 (car e1314) w1315 mod1316) l1317)))) ((null? e1314) (quote ())) ((syntax-object?85 e1314) (match-each-any1290 (syntax-object-expression86 e1314) (join-wraps120 w1315 (syntax-object-wrap87 e1314)) mod1316)) (else #f)))) (match-each1289 (lambda (e1318 p1319 w1320 mod1321) (cond ((annotation? e1318) (match-each1289 (annotation-expression e1318) p1319 w1320 mod1321)) ((pair? e1318) (let ((first1322 (match1293 (car e1318) p1319 w1320 (quote ()) mod1321))) (and first1322 (let ((rest1323 (match-each1289 (cdr e1318) p1319 w1320 mod1321))) (and rest1323 (cons first1322 rest1323)))))) ((null? e1318) (quote ())) ((syntax-object?85 e1318) (match-each1289 (syntax-object-expression86 e1318) p1319 (join-wraps120 w1320 (syntax-object-wrap87 e1318)) (syntax-object-module88 e1318))) (else #f))))) (set! $sc-dispatch (lambda (e1324 p1325) (cond ((eq? p1325 (quote any)) (list e1324)) ((syntax-object?85 e1324) (match*1292 (let ((e1326 (syntax-object-expression86 e1324))) (if (annotation? e1326) (annotation-expression e1326) e1326)) p1325 (syntax-object-wrap87 e1324) (quote ()) (syntax-object-module88 e1324))) (else (match*1292 (let ((e1327 e1324)) (if (annotation? e1327) (annotation-expression e1327) e1327)) p1325 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1328) ((lambda (tmp1329) ((lambda (tmp1330) (if tmp1330 (apply (lambda (_1331 e11332 e21333) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11332 e21333))) tmp1330) ((lambda (tmp1335) (if tmp1335 (apply (lambda (_1336 out1337 in1338 e11339 e21340) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1338 (quote ()) (list out1337 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11339 e21340))))) tmp1335) ((lambda (tmp1342) (if tmp1342 (apply (lambda (_1343 out1344 in1345 e11346 e21347) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1345) (quote ()) (list out1344 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11346 e21347))))) tmp1342) (syntax-violation #f "source expression failed to match any pattern" tmp1329))) ($sc-dispatch tmp1329 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1329 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1329 (quote (any () any . each-any))))) x1328)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1351) ((lambda (tmp1352) ((lambda (tmp1353) (if tmp1353 (apply (lambda (_1354 k1355 keyword1356 pattern1357 template1358) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1355 (map (lambda (tmp1361 tmp1360) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1360) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1361))) template1358 pattern1357)))))) tmp1353) (syntax-violation #f "source expression failed to match any pattern" tmp1352))) ($sc-dispatch tmp1352 (quote (any each-any . #(each ((any . any) any))))))) x1351)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1362) ((lambda (tmp1363) ((lambda (tmp1364) (if (if tmp1364 (apply (lambda (let*1365 x1366 v1367 e11368 e21369) (and-map identifier? x1366)) tmp1364) #f) (apply (lambda (let*1371 x1372 v1373 e11374 e21375) (let f1376 ((bindings1377 (map list x1372 v1373))) (if (null? bindings1377) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11374 e21375))) ((lambda (tmp1381) ((lambda (tmp1382) (if tmp1382 (apply (lambda (body1383 binding1384) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1384) body1383)) tmp1382) (syntax-violation #f "source expression failed to match any pattern" tmp1381))) ($sc-dispatch tmp1381 (quote (any any))))) (list (f1376 (cdr bindings1377)) (car bindings1377)))))) tmp1364) (syntax-violation #f "source expression failed to match any pattern" tmp1363))) ($sc-dispatch tmp1363 (quote (any #(each (any any)) any . each-any))))) x1362)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1385) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (_1388 var1389 init1390 step1391 e01392 e11393 c1394) ((lambda (tmp1395) ((lambda (tmp1396) (if tmp1396 (apply (lambda (step1397) ((lambda (tmp1398) ((lambda (tmp1399) (if tmp1399 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1389 init1390) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01392) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1394 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1397))))))) tmp1399) ((lambda (tmp1404) (if tmp1404 (apply (lambda (e11405 e21406) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1389 init1390) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01392 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11405 e21406)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1394 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1397))))))) tmp1404) (syntax-violation #f "source expression failed to match any pattern" tmp1398))) ($sc-dispatch tmp1398 (quote (any . each-any)))))) ($sc-dispatch tmp1398 (quote ())))) e11393)) tmp1396) (syntax-violation #f "source expression failed to match any pattern" tmp1395))) ($sc-dispatch tmp1395 (quote each-any)))) (map (lambda (v1413 s1414) ((lambda (tmp1415) ((lambda (tmp1416) (if tmp1416 (apply (lambda () v1413) tmp1416) ((lambda (tmp1417) (if tmp1417 (apply (lambda (e1418) e1418) tmp1417) ((lambda (_1419) (syntax-violation (quote do) "bad step expression" orig-x1385 s1414)) tmp1415))) ($sc-dispatch tmp1415 (quote (any)))))) ($sc-dispatch tmp1415 (quote ())))) s1414)) var1389 step1391))) tmp1387) (syntax-violation #f "source expression failed to match any pattern" tmp1386))) ($sc-dispatch tmp1386 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1385)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1422 (lambda (x1426 y1427) ((lambda (tmp1428) ((lambda (tmp1429) (if tmp1429 (apply (lambda (x1430 y1431) ((lambda (tmp1432) ((lambda (tmp1433) (if tmp1433 (apply (lambda (dy1434) ((lambda (tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (dx1437) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1437 dy1434))) tmp1436) ((lambda (_1438) (if (null? dy1434) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1430) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1430 y1431))) tmp1435))) ($sc-dispatch tmp1435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1430)) tmp1433) ((lambda (tmp1439) (if tmp1439 (apply (lambda (stuff1440) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1430 stuff1440))) tmp1439) ((lambda (else1441) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1430 y1431)) tmp1432))) ($sc-dispatch tmp1432 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1432 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1431)) tmp1429) (syntax-violation #f "source expression failed to match any pattern" tmp1428))) ($sc-dispatch tmp1428 (quote (any any))))) (list x1426 y1427)))) (quasiappend1423 (lambda (x1442 y1443) ((lambda (tmp1444) ((lambda (tmp1445) (if tmp1445 (apply (lambda (x1446 y1447) ((lambda (tmp1448) ((lambda (tmp1449) (if tmp1449 (apply (lambda () x1446) tmp1449) ((lambda (_1450) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1446 y1447)) tmp1448))) ($sc-dispatch tmp1448 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1447)) tmp1445) (syntax-violation #f "source expression failed to match any pattern" tmp1444))) ($sc-dispatch tmp1444 (quote (any any))))) (list x1442 y1443)))) (quasivector1424 (lambda (x1451) ((lambda (tmp1452) ((lambda (x1453) ((lambda (tmp1454) ((lambda (tmp1455) (if tmp1455 (apply (lambda (x1456) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1456))) tmp1455) ((lambda (tmp1458) (if tmp1458 (apply (lambda (x1459) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1459)) tmp1458) ((lambda (_1461) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1453)) tmp1454))) ($sc-dispatch tmp1454 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1454 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1453)) tmp1452)) x1451))) (quasi1425 (lambda (p1462 lev1463) ((lambda (tmp1464) ((lambda (tmp1465) (if tmp1465 (apply (lambda (p1466) (if (= lev1463 0) p1466 (quasicons1422 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1425 (list p1466) (- lev1463 1))))) tmp1465) ((lambda (tmp1467) (if tmp1467 (apply (lambda (p1468 q1469) (if (= lev1463 0) (quasiappend1423 p1468 (quasi1425 q1469 lev1463)) (quasicons1422 (quasicons1422 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1425 (list p1468) (- lev1463 1))) (quasi1425 q1469 lev1463)))) tmp1467) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471) (quasicons1422 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1425 (list p1471) (+ lev1463 1)))) tmp1470) ((lambda (tmp1472) (if tmp1472 (apply (lambda (p1473 q1474) (quasicons1422 (quasi1425 p1473 lev1463) (quasi1425 q1474 lev1463))) tmp1472) ((lambda (tmp1475) (if tmp1475 (apply (lambda (x1476) (quasivector1424 (quasi1425 x1476 lev1463))) tmp1475) ((lambda (p1478) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1478)) tmp1464))) ($sc-dispatch tmp1464 (quote #(vector each-any)))))) ($sc-dispatch tmp1464 (quote (any . any)))))) ($sc-dispatch tmp1464 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1464 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1464 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1462)))) (lambda (x1479) ((lambda (tmp1480) ((lambda (tmp1481) (if tmp1481 (apply (lambda (_1482 e1483) (quasi1425 e1483 0)) tmp1481) (syntax-violation #f "source expression failed to match any pattern" tmp1480))) ($sc-dispatch tmp1480 (quote (any any))))) x1479))))) -(define include (make-syncase-macro (quote macro) (lambda (x1484) (letrec ((read-file1485 (lambda (fn1486 k1487) (let ((p1488 (open-input-file fn1486))) (let f1489 ((x1490 (read p1488))) (if (eof-object? x1490) (begin (close-input-port p1488) (quote ())) (cons (datum->syntax k1487 x1490) (f1489 (read p1488))))))))) ((lambda (tmp1491) ((lambda (tmp1492) (if tmp1492 (apply (lambda (k1493 filename1494) (let ((fn1495 (syntax->datum filename1494))) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (exp1498) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1498)) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote each-any)))) (read-file1485 fn1495 k1493)))) tmp1492) (syntax-violation #f "source expression failed to match any pattern" tmp1491))) ($sc-dispatch tmp1491 (quote (any any))))) x1484))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (_1503 e1504) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1500)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote (any any))))) x1500)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1505)) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any))))) x1505)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1510) ((lambda (tmp1511) ((lambda (tmp1512) (if tmp1512 (apply (lambda (_1513 e1514 m11515 m21516) ((lambda (tmp1517) ((lambda (body1518) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1514)) body1518)) tmp1517)) (let f1519 ((clause1520 m11515) (clauses1521 m21516)) (if (null? clauses1521) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (e11525 e21526) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11525 e21526))) tmp1524) ((lambda (tmp1528) (if tmp1528 (apply (lambda (k1529 e11530 e21531) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1529)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11530 e21531)))) tmp1528) ((lambda (_1534) (syntax-violation (quote case) "bad clause" x1510 clause1520)) tmp1523))) ($sc-dispatch tmp1523 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1523 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1520) ((lambda (tmp1535) ((lambda (rest1536) ((lambda (tmp1537) ((lambda (tmp1538) (if tmp1538 (apply (lambda (k1539 e11540 e21541) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1539)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11540 e21541)) rest1536)) tmp1538) ((lambda (_1544) (syntax-violation (quote case) "bad clause" x1510 clause1520)) tmp1537))) ($sc-dispatch tmp1537 (quote (each-any any . each-any))))) clause1520)) tmp1535)) (f1519 (car clauses1521) (cdr clauses1521))))))) tmp1512) (syntax-violation #f "source expression failed to match any pattern" tmp1511))) ($sc-dispatch tmp1511 (quote (any any any . each-any))))) x1510)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1545) ((lambda (tmp1546) ((lambda (tmp1547) (if tmp1547 (apply (lambda (_1548 e1549) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1549)) (list (cons _1548 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1549 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1547) (syntax-violation #f "source expression failed to match any pattern" tmp1546))) ($sc-dispatch tmp1546 (quote (any any))))) x1545)))) +(if #f #f) +(letrec ((and-map*1132 (lambda (f1172 first1171 . rest1170) (or (null? first1171) (if (null? rest1170) (let andmap1173 ((first1174 first1171)) (let ((x1175 (car first1174)) (first1176 (cdr first1174))) (if (null? first1176) (f1172 x1175) (and (f1172 x1175) (andmap1173 first1176))))) (let andmap1177 ((first1178 first1171) (rest1179 rest1170)) (let ((x1180 (car first1178)) (xr1181 (map car rest1179)) (first1182 (cdr first1178)) (rest1183 (map cdr rest1179))) (if (null? first1182) (apply f1172 (cons x1180 xr1181)) (and (apply f1172 (cons x1180 xr1181)) (andmap1177 first1182 rest1183)))))))))) (letrec ((lambda-var-list1265 (lambda (vars1470) (let lvl1471 ((vars1472 vars1470) (ls1473 (quote ())) (w1474 (quote (())))) (cond ((pair? vars1472) (lvl1471 (cdr vars1472) (cons (wrap1244 (car vars1472) w1474 #f) ls1473) w1474)) ((id?1216 vars1472) (cons (wrap1244 vars1472 w1474 #f) ls1473)) ((null? vars1472) ls1473) ((syntax-object?1200 vars1472) (lvl1471 (syntax-object-expression1201 vars1472) ls1473 (join-wraps1235 w1474 (syntax-object-wrap1202 vars1472)))) ((annotation? vars1472) (lvl1471 (annotation-expression vars1472) ls1473 w1474)) (else (cons vars1472 ls1473)))))) (gen-var1264 (lambda (id1475) (let ((id1476 (if (syntax-object?1200 id1475) (syntax-object-expression1201 id1475) id1475))) (if (annotation? id1476) (build-annotated1193 (annotation-source id1476) (gensym (symbol->string (annotation-expression id1476)))) (build-annotated1193 #f (gensym (symbol->string id1476))))))) (strip1263 (lambda (x1477 w1478) (if (memq (quote top) (wrap-marks1219 w1478)) (if (or (annotation? x1477) (and (pair? x1477) (annotation? (car x1477)))) (strip-annotation1262 x1477 #f) x1477) (let f1479 ((x1480 x1477)) (cond ((syntax-object?1200 x1480) (strip1263 (syntax-object-expression1201 x1480) (syntax-object-wrap1202 x1480))) ((pair? x1480) (let ((a1481 (f1479 (car x1480))) (d1482 (f1479 (cdr x1480)))) (if (and (eq? a1481 (car x1480)) (eq? d1482 (cdr x1480))) x1480 (cons a1481 d1482)))) ((vector? x1480) (let ((old1483 (vector->list x1480))) (let ((new1484 (map f1479 old1483))) (if (and-map*1132 eq? old1483 new1484) x1480 (list->vector new1484))))) (else x1480)))))) (strip-annotation1262 (lambda (x1485 parent1486) (cond ((pair? x1485) (let ((new1487 (cons #f #f))) (begin (if parent1486 (set-annotation-stripped! parent1486 new1487)) (set-car! new1487 (strip-annotation1262 (car x1485) #f)) (set-cdr! new1487 (strip-annotation1262 (cdr x1485) #f)) new1487))) ((annotation? x1485) (or (annotation-stripped x1485) (strip-annotation1262 (annotation-expression x1485) x1485))) ((vector? x1485) (let ((new1488 (make-vector (vector-length x1485)))) (begin (if parent1486 (set-annotation-stripped! parent1486 new1488)) (let loop1489 ((i1490 (- (vector-length x1485) 1))) (unless (fx<1188 i1490 0) (vector-set! new1488 i1490 (strip-annotation1262 (vector-ref x1485 i1490) #f)) (loop1489 (fx-1186 i1490 1)))) new1488))) (else x1485)))) (ellipsis?1261 (lambda (x1491) (and (nonsymbol-id?1215 x1491) (free-id=?1239 x1491 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1260 (lambda () (build-annotated1193 #f (cons (build-annotated1193 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer1259 (lambda (expanded1492 mod1493) (let ((p1494 (local-eval-hook1190 expanded1492 mod1493))) (if (procedure? p1494) p1494 (syntax-violation #f "nonprocedure transformer" p1494))))) (chi-local-syntax1258 (lambda (rec?1495 e1496 r1497 w1498 s1499 mod1500 k1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (_1504 id1505 val1506 e11507 e21508) (let ((ids1509 id1505)) (if (not (valid-bound-ids?1241 ids1509)) (syntax-violation #f "duplicate bound keyword" e1496) (let ((labels1511 (gen-labels1222 ids1509))) (let ((new-w1512 (make-binding-wrap1233 ids1509 labels1511 w1498))) (k1501 (cons e11507 e21508) (extend-env1210 labels1511 (let ((w1514 (if rec?1495 new-w1512 w1498)) (trans-r1515 (macros-only-env1212 r1497))) (map (lambda (x1516) (cons (quote macro) (eval-local-transformer1259 (chi1252 x1516 trans-r1515 w1514 mod1500) mod1500))) val1506)) r1497) new-w1512 s1499 mod1500)))))) tmp1503) ((lambda (_1518) (syntax-violation #f "bad local syntax definition" (source-wrap1245 e1496 w1498 s1499 mod1500))) tmp1502))) ($sc-dispatch tmp1502 (quote (any #(each (any any)) any . each-any))))) e1496))) (chi-lambda-clause1257 (lambda (e1519 docstring1520 c1521 r1522 w1523 mod1524 k1525) ((lambda (tmp1526) ((lambda (tmp1527) (if (if tmp1527 (apply (lambda (args1528 doc1529 e11530 e21531) (and (string? (syntax->datum doc1529)) (not docstring1520))) tmp1527) #f) (apply (lambda (args1532 doc1533 e11534 e21535) (chi-lambda-clause1257 e1519 doc1533 (cons args1532 (cons e11534 e21535)) r1522 w1523 mod1524 k1525)) tmp1527) ((lambda (tmp1537) (if tmp1537 (apply (lambda (id1538 e11539 e21540) (let ((ids1541 id1538)) (if (not (valid-bound-ids?1241 ids1541)) (syntax-violation (quote lambda) "invalid parameter list" e1519) (let ((labels1543 (gen-labels1222 ids1541)) (new-vars1544 (map gen-var1264 ids1541))) (k1525 new-vars1544 docstring1520 (chi-body1256 (cons e11539 e21540) e1519 (extend-var-env1211 labels1543 new-vars1544 r1522) (make-binding-wrap1233 ids1541 labels1543 w1523) mod1524)))))) tmp1537) ((lambda (tmp1546) (if tmp1546 (apply (lambda (ids1547 e11548 e21549) (let ((old-ids1550 (lambda-var-list1265 ids1547))) (if (not (valid-bound-ids?1241 old-ids1550)) (syntax-violation (quote lambda) "invalid parameter list" e1519) (let ((labels1551 (gen-labels1222 old-ids1550)) (new-vars1552 (map gen-var1264 old-ids1550))) (k1525 (let f1553 ((ls11554 (cdr new-vars1552)) (ls21555 (car new-vars1552))) (if (null? ls11554) ls21555 (f1553 (cdr ls11554) (cons (car ls11554) ls21555)))) docstring1520 (chi-body1256 (cons e11548 e21549) e1519 (extend-var-env1211 labels1551 new-vars1552 r1522) (make-binding-wrap1233 old-ids1550 labels1551 w1523) mod1524)))))) tmp1546) ((lambda (_1557) (syntax-violation (quote lambda) "bad lambda" e1519)) tmp1526))) ($sc-dispatch tmp1526 (quote (any any . each-any)))))) ($sc-dispatch tmp1526 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1526 (quote (any any any . each-any))))) c1521))) (chi-body1256 (lambda (body1558 outer-form1559 r1560 w1561 mod1562) (let ((r1563 (cons (quote ("placeholder" placeholder)) r1560))) (let ((ribcage1564 (make-ribcage1223 (quote ()) (quote ()) (quote ())))) (let ((w1565 (make-wrap1218 (wrap-marks1219 w1561) (cons ribcage1564 (wrap-subst1220 w1561))))) (let parse1566 ((body1567 (map (lambda (x1573) (cons r1563 (wrap1244 x1573 w1565 mod1562))) body1558)) (ids1568 (quote ())) (labels1569 (quote ())) (vars1570 (quote ())) (vals1571 (quote ())) (bindings1572 (quote ()))) (if (null? body1567) (syntax-violation #f "no expressions in body" outer-form1559) (let ((e1574 (cdar body1567)) (er1575 (caar body1567))) (call-with-values (lambda () (syntax-type1250 e1574 er1575 (quote (())) #f ribcage1564 mod1562)) (lambda (type1576 value1577 e1578 w1579 s1580 mod1581) (let ((t1582 type1576)) (if (memv t1582 (quote (define-form))) (let ((id1583 (wrap1244 value1577 w1579 mod1581)) (label1584 (gen-label1221))) (let ((var1585 (gen-var1264 id1583))) (begin (extend-ribcage!1232 ribcage1564 id1583 label1584) (parse1566 (cdr body1567) (cons id1583 ids1568) (cons label1584 labels1569) (cons var1585 vars1570) (cons (cons er1575 (wrap1244 e1578 w1579 mod1581)) vals1571) (cons (cons (quote lexical) var1585) bindings1572))))) (if (memv t1582 (quote (define-syntax-form))) (let ((id1586 (wrap1244 value1577 w1579 mod1581)) (label1587 (gen-label1221))) (begin (extend-ribcage!1232 ribcage1564 id1586 label1587) (parse1566 (cdr body1567) (cons id1586 ids1568) (cons label1587 labels1569) vars1570 vals1571 (cons (cons (quote macro) (cons er1575 (wrap1244 e1578 w1579 mod1581))) bindings1572)))) (if (memv t1582 (quote (begin-form))) ((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (_1590 e11591) (parse1566 (let f1592 ((forms1593 e11591)) (if (null? forms1593) (cdr body1567) (cons (cons er1575 (wrap1244 (car forms1593) w1579 mod1581)) (f1592 (cdr forms1593))))) ids1568 labels1569 vars1570 vals1571 bindings1572)) tmp1589) (syntax-violation #f "source expression failed to match any pattern" tmp1588))) ($sc-dispatch tmp1588 (quote (any . each-any))))) e1578) (if (memv t1582 (quote (local-syntax-form))) (chi-local-syntax1258 value1577 e1578 er1575 w1579 s1580 mod1581 (lambda (forms1595 er1596 w1597 s1598 mod1599) (parse1566 (let f1600 ((forms1601 forms1595)) (if (null? forms1601) (cdr body1567) (cons (cons er1596 (wrap1244 (car forms1601) w1597 mod1599)) (f1600 (cdr forms1601))))) ids1568 labels1569 vars1570 vals1571 bindings1572))) (if (null? ids1568) (build-sequence1195 #f (map (lambda (x1602) (chi1252 (cdr x1602) (car x1602) (quote (())) mod1581)) (cons (cons er1575 (source-wrap1245 e1578 w1579 s1580 mod1581)) (cdr body1567)))) (begin (if (not (valid-bound-ids?1241 ids1568)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1559)) (let loop1603 ((bs1604 bindings1572) (er-cache1605 #f) (r-cache1606 #f)) (if (not (null? bs1604)) (let ((b1607 (car bs1604))) (if (eq? (car b1607) (quote macro)) (let ((er1608 (cadr b1607))) (let ((r-cache1609 (if (eq? er1608 er-cache1605) r-cache1606 (macros-only-env1212 er1608)))) (begin (set-cdr! b1607 (eval-local-transformer1259 (chi1252 (cddr b1607) r-cache1609 (quote (())) mod1581) mod1581)) (loop1603 (cdr bs1604) er1608 r-cache1609)))) (loop1603 (cdr bs1604) er-cache1605 r-cache1606))))) (set-cdr! r1563 (extend-env1210 labels1569 bindings1572 (cdr r1563))) (build-letrec1198 #f vars1570 (map (lambda (x1610) (chi1252 (cdr x1610) (car x1610) (quote (())) mod1581)) vals1571) (build-sequence1195 #f (map (lambda (x1611) (chi1252 (cdr x1611) (car x1611) (quote (())) mod1581)) (cons (cons er1575 (source-wrap1245 e1578 w1579 s1580 mod1581)) (cdr body1567)))))))))))))))))))))) (chi-macro1255 (lambda (p1612 e1613 r1614 w1615 rib1616 mod1617) (letrec ((rebuild-macro-output1618 (lambda (x1619 m1620) (cond ((pair? x1619) (cons (rebuild-macro-output1618 (car x1619) m1620) (rebuild-macro-output1618 (cdr x1619) m1620))) ((syntax-object?1200 x1619) (let ((w1621 (syntax-object-wrap1202 x1619))) (let ((ms1622 (wrap-marks1219 w1621)) (s1623 (wrap-subst1220 w1621))) (if (and (pair? ms1622) (eq? (car ms1622) #f)) (make-syntax-object1199 (syntax-object-expression1201 x1619) (make-wrap1218 (cdr ms1622) (if rib1616 (cons rib1616 (cdr s1623)) (cdr s1623))) (syntax-object-module1203 x1619)) (make-syntax-object1199 (syntax-object-expression1201 x1619) (make-wrap1218 (cons m1620 ms1622) (if rib1616 (cons rib1616 (cons (quote shift) s1623)) (cons (quote shift) s1623))) (let ((pmod1624 (procedure-module p1612))) (if pmod1624 (cons (quote hygiene) (module-name pmod1624)) (quote (hygiene guile))))))))) ((vector? x1619) (let ((n1625 (vector-length x1619))) (let ((v1626 (make-vector n1625))) (let doloop1627 ((i1628 0)) (if (fx=1187 i1628 n1625) v1626 (begin (vector-set! v1626 i1628 (rebuild-macro-output1618 (vector-ref x1619 i1628) m1620)) (doloop1627 (fx+1185 i1628 1)))))))) ((symbol? x1619) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1245 e1613 w1615 s mod1617) x1619)) (else x1619))))) (rebuild-macro-output1618 (p1612 (wrap1244 e1613 (anti-mark1231 w1615) mod1617)) (string #\m))))) (chi-application1254 (lambda (x1629 e1630 r1631 w1632 s1633 mod1634) ((lambda (tmp1635) ((lambda (tmp1636) (if tmp1636 (apply (lambda (e01637 e11638) (build-annotated1193 s1633 (cons x1629 (map (lambda (e1639) (chi1252 e1639 r1631 w1632 mod1634)) e11638)))) tmp1636) (syntax-violation #f "source expression failed to match any pattern" tmp1635))) ($sc-dispatch tmp1635 (quote (any . each-any))))) e1630))) (chi-expr1253 (lambda (type1641 value1642 e1643 r1644 w1645 s1646 mod1647) (let ((t1648 type1641)) (if (memv t1648 (quote (lexical))) (build-annotated1193 s1646 value1642) (if (memv t1648 (quote (core external-macro))) (value1642 e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (module-ref))) (call-with-values (lambda () (value1642 e1643)) (lambda (id1649 mod1650) (build-annotated1193 s1646 (if mod1650 (make-module-ref (cdr mod1650) id1649 (car mod1650)) (make-module-ref mod1650 id1649 (quote bare)))))) (if (memv t1648 (quote (lexical-call))) (chi-application1254 (build-annotated1193 (source-annotation1207 (car e1643)) value1642) e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (global-call))) (chi-application1254 (build-annotated1193 (source-annotation1207 (car e1643)) (if (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647) (make-module-ref (cdr (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647)) value1642 (car (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647))) (make-module-ref (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647) value1642 (quote bare)))) e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (constant))) (build-data1194 s1646 (strip1263 (source-wrap1245 e1643 w1645 s1646 mod1647) (quote (())))) (if (memv t1648 (quote (global))) (build-annotated1193 s1646 (if mod1647 (make-module-ref (cdr mod1647) value1642 (car mod1647)) (make-module-ref mod1647 value1642 (quote bare)))) (if (memv t1648 (quote (call))) (chi-application1254 (chi1252 (car e1643) r1644 w1645 mod1647) e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (begin-form))) ((lambda (tmp1651) ((lambda (tmp1652) (if tmp1652 (apply (lambda (_1653 e11654 e21655) (chi-sequence1246 (cons e11654 e21655) r1644 w1645 s1646 mod1647)) tmp1652) (syntax-violation #f "source expression failed to match any pattern" tmp1651))) ($sc-dispatch tmp1651 (quote (any any . each-any))))) e1643) (if (memv t1648 (quote (local-syntax-form))) (chi-local-syntax1258 value1642 e1643 r1644 w1645 s1646 mod1647 chi-sequence1246) (if (memv t1648 (quote (eval-when-form))) ((lambda (tmp1657) ((lambda (tmp1658) (if tmp1658 (apply (lambda (_1659 x1660 e11661 e21662) (let ((when-list1663 (chi-when-list1249 e1643 x1660 w1645))) (if (memq (quote eval) when-list1663) (chi-sequence1246 (cons e11661 e21662) r1644 w1645 s1646 mod1647) (chi-void1260)))) tmp1658) (syntax-violation #f "source expression failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote (any each-any any . each-any))))) e1643) (if (memv t1648 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1643 (wrap1244 value1642 w1645 mod1647)) (if (memv t1648 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1245 e1643 w1645 s1646 mod1647)) (if (memv t1648 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1245 e1643 w1645 s1646 mod1647)) (syntax-violation #f "unexpected syntax" (source-wrap1245 e1643 w1645 s1646 mod1647))))))))))))))))))) (chi1252 (lambda (e1666 r1667 w1668 mod1669) (call-with-values (lambda () (syntax-type1250 e1666 r1667 w1668 #f #f mod1669)) (lambda (type1670 value1671 e1672 w1673 s1674 mod1675) (chi-expr1253 type1670 value1671 e1672 r1667 w1673 s1674 mod1675))))) (chi-top1251 (lambda (e1676 r1677 w1678 m1679 esew1680 mod1681) (call-with-values (lambda () (syntax-type1250 e1676 r1677 w1678 #f #f mod1681)) (lambda (type1689 value1690 e1691 w1692 s1693 mod1694) (let ((t1695 type1689)) (if (memv t1695 (quote (begin-form))) ((lambda (tmp1696) ((lambda (tmp1697) (if tmp1697 (apply (lambda (_1698) (chi-void1260)) tmp1697) ((lambda (tmp1699) (if tmp1699 (apply (lambda (_1700 e11701 e21702) (chi-top-sequence1247 (cons e11701 e21702) r1677 w1692 s1693 m1679 esew1680 mod1694)) tmp1699) (syntax-violation #f "source expression failed to match any pattern" tmp1696))) ($sc-dispatch tmp1696 (quote (any any . each-any)))))) ($sc-dispatch tmp1696 (quote (any))))) e1691) (if (memv t1695 (quote (local-syntax-form))) (chi-local-syntax1258 value1690 e1691 r1677 w1692 s1693 mod1694 (lambda (body1704 r1705 w1706 s1707 mod1708) (chi-top-sequence1247 body1704 r1705 w1706 s1707 m1679 esew1680 mod1708))) (if (memv t1695 (quote (eval-when-form))) ((lambda (tmp1709) ((lambda (tmp1710) (if tmp1710 (apply (lambda (_1711 x1712 e11713 e21714) (let ((when-list1715 (chi-when-list1249 e1691 x1712 w1692)) (body1716 (cons e11713 e21714))) (cond ((eq? m1679 (quote e)) (if (memq (quote eval) when-list1715) (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote e) (quote (eval)) mod1694) (chi-void1260))) ((memq (quote load) when-list1715) (if (or (memq (quote compile) when-list1715) (and (eq? m1679 (quote c&e)) (memq (quote eval) when-list1715))) (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote c&e) (quote (compile load)) mod1694) (if (memq m1679 (quote (c c&e))) (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote c) (quote (load)) mod1694) (chi-void1260)))) ((or (memq (quote compile) when-list1715) (and (eq? m1679 (quote c&e)) (memq (quote eval) when-list1715))) (top-level-eval-hook1189 (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote e) (quote (eval)) mod1694) mod1694) (chi-void1260)) (else (chi-void1260))))) tmp1710) (syntax-violation #f "source expression failed to match any pattern" tmp1709))) ($sc-dispatch tmp1709 (quote (any each-any any . each-any))))) e1691) (if (memv t1695 (quote (define-syntax-form))) (let ((n1719 (id-var-name1238 value1690 w1692)) (r1720 (macros-only-env1212 r1677))) (let ((t1721 m1679)) (if (memv t1721 (quote (c))) (if (memq (quote compile) esew1680) (let ((e1722 (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)))) (begin (top-level-eval-hook1189 e1722 mod1694) (if (memq (quote load) esew1680) e1722 (chi-void1260)))) (if (memq (quote load) esew1680) (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)) (chi-void1260))) (if (memv t1721 (quote (c&e))) (let ((e1723 (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)))) (begin (top-level-eval-hook1189 e1723 mod1694) e1723)) (begin (if (memq (quote eval) esew1680) (top-level-eval-hook1189 (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)) mod1694)) (chi-void1260)))))) (if (memv t1695 (quote (define-form))) (let ((n1724 (id-var-name1238 value1690 w1692))) (let ((type1725 (binding-type1208 (lookup1213 n1724 r1677 mod1694)))) (let ((t1726 type1725)) (if (memv t1726 (quote (global core macro module-ref))) (let ((x1727 (build-annotated1193 s1693 (list (quote define) n1724 (chi1252 e1691 r1677 w1692 mod1694))))) (begin (if (eq? m1679 (quote c&e)) (top-level-eval-hook1189 x1727 mod1694)) x1727)) (if (memv t1726 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1691 (wrap1244 value1690 w1692 mod1694)) (syntax-violation #f "cannot define keyword at top level" e1691 (wrap1244 value1690 w1692 mod1694))))))) (let ((x1728 (chi-expr1253 type1689 value1690 e1691 r1677 w1692 s1693 mod1694))) (begin (if (eq? m1679 (quote c&e)) (top-level-eval-hook1189 x1728 mod1694)) x1728)))))))))))) (syntax-type1250 (lambda (e1729 r1730 w1731 s1732 rib1733 mod1734) (cond ((symbol? e1729) (let ((n1735 (id-var-name1238 e1729 w1731))) (let ((b1736 (lookup1213 n1735 r1730 mod1734))) (let ((type1737 (binding-type1208 b1736))) (let ((t1738 type1737)) (if (memv t1738 (quote (lexical))) (values type1737 (binding-value1209 b1736) e1729 w1731 s1732 mod1734) (if (memv t1738 (quote (global))) (values type1737 n1735 e1729 w1731 s1732 mod1734) (if (memv t1738 (quote (macro))) (syntax-type1250 (chi-macro1255 (binding-value1209 b1736) e1729 r1730 w1731 rib1733 mod1734) r1730 (quote (())) s1732 rib1733 mod1734) (values type1737 (binding-value1209 b1736) e1729 w1731 s1732 mod1734))))))))) ((pair? e1729) (let ((first1739 (car e1729))) (if (id?1216 first1739) (let ((n1740 (id-var-name1238 first1739 w1731))) (let ((b1741 (lookup1213 n1740 r1730 (or (and (syntax-object?1200 first1739) (syntax-object-module1203 first1739)) mod1734)))) (let ((type1742 (binding-type1208 b1741))) (let ((t1743 type1742)) (if (memv t1743 (quote (lexical))) (values (quote lexical-call) (binding-value1209 b1741) e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (global))) (values (quote global-call) n1740 e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (macro))) (syntax-type1250 (chi-macro1255 (binding-value1209 b1741) e1729 r1730 w1731 rib1733 mod1734) r1730 (quote (())) s1732 rib1733 mod1734) (if (memv t1743 (quote (core external-macro module-ref))) (values type1742 (binding-value1209 b1741) e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1209 b1741) e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (begin))) (values (quote begin-form) #f e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (eval-when))) (values (quote eval-when-form) #f e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (define))) ((lambda (tmp1744) ((lambda (tmp1745) (if (if tmp1745 (apply (lambda (_1746 name1747 val1748) (id?1216 name1747)) tmp1745) #f) (apply (lambda (_1749 name1750 val1751) (values (quote define-form) name1750 val1751 w1731 s1732 mod1734)) tmp1745) ((lambda (tmp1752) (if (if tmp1752 (apply (lambda (_1753 name1754 args1755 e11756 e21757) (and (id?1216 name1754) (valid-bound-ids?1241 (lambda-var-list1265 args1755)))) tmp1752) #f) (apply (lambda (_1758 name1759 args1760 e11761 e21762) (values (quote define-form) (wrap1244 name1759 w1731 mod1734) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1244 (cons args1760 (cons e11761 e21762)) w1731 mod1734)) (quote (())) s1732 mod1734)) tmp1752) ((lambda (tmp1764) (if (if tmp1764 (apply (lambda (_1765 name1766) (id?1216 name1766)) tmp1764) #f) (apply (lambda (_1767 name1768) (values (quote define-form) (wrap1244 name1768 w1731 mod1734) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1732 mod1734)) tmp1764) (syntax-violation #f "source expression failed to match any pattern" tmp1744))) ($sc-dispatch tmp1744 (quote (any any)))))) ($sc-dispatch tmp1744 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1744 (quote (any any any))))) e1729) (if (memv t1743 (quote (define-syntax))) ((lambda (tmp1769) ((lambda (tmp1770) (if (if tmp1770 (apply (lambda (_1771 name1772 val1773) (id?1216 name1772)) tmp1770) #f) (apply (lambda (_1774 name1775 val1776) (values (quote define-syntax-form) name1775 val1776 w1731 s1732 mod1734)) tmp1770) (syntax-violation #f "source expression failed to match any pattern" tmp1769))) ($sc-dispatch tmp1769 (quote (any any any))))) e1729) (values (quote call) #f e1729 w1731 s1732 mod1734)))))))))))))) (values (quote call) #f e1729 w1731 s1732 mod1734)))) ((syntax-object?1200 e1729) (syntax-type1250 (syntax-object-expression1201 e1729) r1730 (join-wraps1235 w1731 (syntax-object-wrap1202 e1729)) #f rib1733 (or (syntax-object-module1203 e1729) mod1734))) ((annotation? e1729) (syntax-type1250 (annotation-expression e1729) r1730 w1731 (annotation-source e1729) rib1733 mod1734)) ((self-evaluating? e1729) (values (quote constant) #f e1729 w1731 s1732 mod1734)) (else (values (quote other) #f e1729 w1731 s1732 mod1734))))) (chi-when-list1249 (lambda (e1777 when-list1778 w1779) (let f1780 ((when-list1781 when-list1778) (situations1782 (quote ()))) (if (null? when-list1781) situations1782 (f1780 (cdr when-list1781) (cons (let ((x1783 (car when-list1781))) (cond ((free-id=?1239 x1783 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1239 x1783 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1239 x1783 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1777 (wrap1244 x1783 w1779 #f))))) situations1782)))))) (chi-install-global1248 (lambda (name1784 e1785) (build-annotated1193 #f (list (build-annotated1193 #f (quote define)) name1784 (if (let ((v1786 (module-variable (current-module) name1784))) (and v1786 (variable-bound? v1786) (macro? (variable-ref v1786)) (not (eq? (macro-type (variable-ref v1786)) (quote syncase-macro))))) (build-annotated1193 #f (list (build-annotated1193 #f (quote make-extended-syncase-macro)) (build-annotated1193 #f (list (build-annotated1193 #f (quote module-ref)) (build-annotated1193 #f (quote (current-module))) (build-data1194 #f name1784))) (build-data1194 #f (quote macro)) e1785)) (build-annotated1193 #f (list (build-annotated1193 #f (quote make-syncase-macro)) (build-data1194 #f (quote macro)) e1785))))))) (chi-top-sequence1247 (lambda (body1787 r1788 w1789 s1790 m1791 esew1792 mod1793) (build-sequence1195 s1790 (let dobody1794 ((body1795 body1787) (r1796 r1788) (w1797 w1789) (m1798 m1791) (esew1799 esew1792) (mod1800 mod1793)) (if (null? body1795) (quote ()) (let ((first1801 (chi-top1251 (car body1795) r1796 w1797 m1798 esew1799 mod1800))) (cons first1801 (dobody1794 (cdr body1795) r1796 w1797 m1798 esew1799 mod1800)))))))) (chi-sequence1246 (lambda (body1802 r1803 w1804 s1805 mod1806) (build-sequence1195 s1805 (let dobody1807 ((body1808 body1802) (r1809 r1803) (w1810 w1804) (mod1811 mod1806)) (if (null? body1808) (quote ()) (let ((first1812 (chi1252 (car body1808) r1809 w1810 mod1811))) (cons first1812 (dobody1807 (cdr body1808) r1809 w1810 mod1811)))))))) (source-wrap1245 (lambda (x1813 w1814 s1815 defmod1816) (wrap1244 (if s1815 (make-annotation x1813 s1815 #f) x1813) w1814 defmod1816))) (wrap1244 (lambda (x1817 w1818 defmod1819) (cond ((and (null? (wrap-marks1219 w1818)) (null? (wrap-subst1220 w1818))) x1817) ((syntax-object?1200 x1817) (make-syntax-object1199 (syntax-object-expression1201 x1817) (join-wraps1235 w1818 (syntax-object-wrap1202 x1817)) (syntax-object-module1203 x1817))) ((null? x1817) x1817) (else (make-syntax-object1199 x1817 w1818 defmod1819))))) (bound-id-member?1243 (lambda (x1820 list1821) (and (not (null? list1821)) (or (bound-id=?1240 x1820 (car list1821)) (bound-id-member?1243 x1820 (cdr list1821)))))) (distinct-bound-ids?1242 (lambda (ids1822) (let distinct?1823 ((ids1824 ids1822)) (or (null? ids1824) (and (not (bound-id-member?1243 (car ids1824) (cdr ids1824))) (distinct?1823 (cdr ids1824))))))) (valid-bound-ids?1241 (lambda (ids1825) (and (let all-ids?1826 ((ids1827 ids1825)) (or (null? ids1827) (and (id?1216 (car ids1827)) (all-ids?1826 (cdr ids1827))))) (distinct-bound-ids?1242 ids1825)))) (bound-id=?1240 (lambda (i1828 j1829) (if (and (syntax-object?1200 i1828) (syntax-object?1200 j1829)) (and (eq? (let ((e1830 (syntax-object-expression1201 i1828))) (if (annotation? e1830) (annotation-expression e1830) e1830)) (let ((e1831 (syntax-object-expression1201 j1829))) (if (annotation? e1831) (annotation-expression e1831) e1831))) (same-marks?1237 (wrap-marks1219 (syntax-object-wrap1202 i1828)) (wrap-marks1219 (syntax-object-wrap1202 j1829)))) (eq? (let ((e1832 i1828)) (if (annotation? e1832) (annotation-expression e1832) e1832)) (let ((e1833 j1829)) (if (annotation? e1833) (annotation-expression e1833) e1833)))))) (free-id=?1239 (lambda (i1834 j1835) (and (eq? (let ((x1836 i1834)) (let ((e1837 (if (syntax-object?1200 x1836) (syntax-object-expression1201 x1836) x1836))) (if (annotation? e1837) (annotation-expression e1837) e1837))) (let ((x1838 j1835)) (let ((e1839 (if (syntax-object?1200 x1838) (syntax-object-expression1201 x1838) x1838))) (if (annotation? e1839) (annotation-expression e1839) e1839)))) (eq? (id-var-name1238 i1834 (quote (()))) (id-var-name1238 j1835 (quote (()))))))) (id-var-name1238 (lambda (id1840 w1841) (letrec ((search-vector-rib1844 (lambda (sym1850 subst1851 marks1852 symnames1853 ribcage1854) (let ((n1855 (vector-length symnames1853))) (let f1856 ((i1857 0)) (cond ((fx=1187 i1857 n1855) (search1842 sym1850 (cdr subst1851) marks1852)) ((and (eq? (vector-ref symnames1853 i1857) sym1850) (same-marks?1237 marks1852 (vector-ref (ribcage-marks1226 ribcage1854) i1857))) (values (vector-ref (ribcage-labels1227 ribcage1854) i1857) marks1852)) (else (f1856 (fx+1185 i1857 1)))))))) (search-list-rib1843 (lambda (sym1858 subst1859 marks1860 symnames1861 ribcage1862) (let f1863 ((symnames1864 symnames1861) (i1865 0)) (cond ((null? symnames1864) (search1842 sym1858 (cdr subst1859) marks1860)) ((and (eq? (car symnames1864) sym1858) (same-marks?1237 marks1860 (list-ref (ribcage-marks1226 ribcage1862) i1865))) (values (list-ref (ribcage-labels1227 ribcage1862) i1865) marks1860)) (else (f1863 (cdr symnames1864) (fx+1185 i1865 1))))))) (search1842 (lambda (sym1866 subst1867 marks1868) (if (null? subst1867) (values #f marks1868) (let ((fst1869 (car subst1867))) (if (eq? fst1869 (quote shift)) (search1842 sym1866 (cdr subst1867) (cdr marks1868)) (let ((symnames1870 (ribcage-symnames1225 fst1869))) (if (vector? symnames1870) (search-vector-rib1844 sym1866 subst1867 marks1868 symnames1870 fst1869) (search-list-rib1843 sym1866 subst1867 marks1868 symnames1870 fst1869))))))))) (cond ((symbol? id1840) (or (call-with-values (lambda () (search1842 id1840 (wrap-subst1220 w1841) (wrap-marks1219 w1841))) (lambda (x1872 . ignore1871) x1872)) id1840)) ((syntax-object?1200 id1840) (let ((id1873 (let ((e1875 (syntax-object-expression1201 id1840))) (if (annotation? e1875) (annotation-expression e1875) e1875))) (w11874 (syntax-object-wrap1202 id1840))) (let ((marks1876 (join-marks1236 (wrap-marks1219 w1841) (wrap-marks1219 w11874)))) (call-with-values (lambda () (search1842 id1873 (wrap-subst1220 w1841) marks1876)) (lambda (new-id1877 marks1878) (or new-id1877 (call-with-values (lambda () (search1842 id1873 (wrap-subst1220 w11874) marks1878)) (lambda (x1880 . ignore1879) x1880)) id1873)))))) ((annotation? id1840) (let ((id1881 (let ((e1882 id1840)) (if (annotation? e1882) (annotation-expression e1882) e1882)))) (or (call-with-values (lambda () (search1842 id1881 (wrap-subst1220 w1841) (wrap-marks1219 w1841))) (lambda (x1884 . ignore1883) x1884)) id1881))) (else (syntax-violation (quote id-var-name) "invalid id" id1840)))))) (same-marks?1237 (lambda (x1885 y1886) (or (eq? x1885 y1886) (and (not (null? x1885)) (not (null? y1886)) (eq? (car x1885) (car y1886)) (same-marks?1237 (cdr x1885) (cdr y1886)))))) (join-marks1236 (lambda (m11887 m21888) (smart-append1234 m11887 m21888))) (join-wraps1235 (lambda (w11889 w21890) (let ((m11891 (wrap-marks1219 w11889)) (s11892 (wrap-subst1220 w11889))) (if (null? m11891) (if (null? s11892) w21890 (make-wrap1218 (wrap-marks1219 w21890) (smart-append1234 s11892 (wrap-subst1220 w21890)))) (make-wrap1218 (smart-append1234 m11891 (wrap-marks1219 w21890)) (smart-append1234 s11892 (wrap-subst1220 w21890))))))) (smart-append1234 (lambda (m11893 m21894) (if (null? m21894) m11893 (append m11893 m21894)))) (make-binding-wrap1233 (lambda (ids1895 labels1896 w1897) (if (null? ids1895) w1897 (make-wrap1218 (wrap-marks1219 w1897) (cons (let ((labelvec1898 (list->vector labels1896))) (let ((n1899 (vector-length labelvec1898))) (let ((symnamevec1900 (make-vector n1899)) (marksvec1901 (make-vector n1899))) (begin (let f1902 ((ids1903 ids1895) (i1904 0)) (if (not (null? ids1903)) (call-with-values (lambda () (id-sym-name&marks1217 (car ids1903) w1897)) (lambda (symname1905 marks1906) (begin (vector-set! symnamevec1900 i1904 symname1905) (vector-set! marksvec1901 i1904 marks1906) (f1902 (cdr ids1903) (fx+1185 i1904 1))))))) (make-ribcage1223 symnamevec1900 marksvec1901 labelvec1898))))) (wrap-subst1220 w1897)))))) (extend-ribcage!1232 (lambda (ribcage1907 id1908 label1909) (begin (set-ribcage-symnames!1228 ribcage1907 (cons (let ((e1910 (syntax-object-expression1201 id1908))) (if (annotation? e1910) (annotation-expression e1910) e1910)) (ribcage-symnames1225 ribcage1907))) (set-ribcage-marks!1229 ribcage1907 (cons (wrap-marks1219 (syntax-object-wrap1202 id1908)) (ribcage-marks1226 ribcage1907))) (set-ribcage-labels!1230 ribcage1907 (cons label1909 (ribcage-labels1227 ribcage1907)))))) (anti-mark1231 (lambda (w1911) (make-wrap1218 (cons #f (wrap-marks1219 w1911)) (cons (quote shift) (wrap-subst1220 w1911))))) (set-ribcage-labels!1230 (lambda (x1912 update1913) (vector-set! x1912 3 update1913))) (set-ribcage-marks!1229 (lambda (x1914 update1915) (vector-set! x1914 2 update1915))) (set-ribcage-symnames!1228 (lambda (x1916 update1917) (vector-set! x1916 1 update1917))) (ribcage-labels1227 (lambda (x1918) (vector-ref x1918 3))) (ribcage-marks1226 (lambda (x1919) (vector-ref x1919 2))) (ribcage-symnames1225 (lambda (x1920) (vector-ref x1920 1))) (ribcage?1224 (lambda (x1921) (and (vector? x1921) (= (vector-length x1921) 4) (eq? (vector-ref x1921 0) (quote ribcage))))) (make-ribcage1223 (lambda (symnames1922 marks1923 labels1924) (vector (quote ribcage) symnames1922 marks1923 labels1924))) (gen-labels1222 (lambda (ls1925) (if (null? ls1925) (quote ()) (cons (gen-label1221) (gen-labels1222 (cdr ls1925)))))) (gen-label1221 (lambda () (string #\i))) (wrap-subst1220 cdr) (wrap-marks1219 car) (make-wrap1218 cons) (id-sym-name&marks1217 (lambda (x1926 w1927) (if (syntax-object?1200 x1926) (values (let ((e1928 (syntax-object-expression1201 x1926))) (if (annotation? e1928) (annotation-expression e1928) e1928)) (join-marks1236 (wrap-marks1219 w1927) (wrap-marks1219 (syntax-object-wrap1202 x1926)))) (values (let ((e1929 x1926)) (if (annotation? e1929) (annotation-expression e1929) e1929)) (wrap-marks1219 w1927))))) (id?1216 (lambda (x1930) (cond ((symbol? x1930) #t) ((syntax-object?1200 x1930) (symbol? (let ((e1931 (syntax-object-expression1201 x1930))) (if (annotation? e1931) (annotation-expression e1931) e1931)))) ((annotation? x1930) (symbol? (annotation-expression x1930))) (else #f)))) (nonsymbol-id?1215 (lambda (x1932) (and (syntax-object?1200 x1932) (symbol? (let ((e1933 (syntax-object-expression1201 x1932))) (if (annotation? e1933) (annotation-expression e1933) e1933)))))) (global-extend1214 (lambda (type1934 sym1935 val1936) (put-global-definition-hook1191 sym1935 type1934 val1936))) (lookup1213 (lambda (x1937 r1938 mod1939) (cond ((assq x1937 r1938) => cdr) ((symbol? x1937) (or (get-global-definition-hook1192 x1937 mod1939) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1212 (lambda (r1940) (if (null? r1940) (quote ()) (let ((a1941 (car r1940))) (if (eq? (cadr a1941) (quote macro)) (cons a1941 (macros-only-env1212 (cdr r1940))) (macros-only-env1212 (cdr r1940))))))) (extend-var-env1211 (lambda (labels1942 vars1943 r1944) (if (null? labels1942) r1944 (extend-var-env1211 (cdr labels1942) (cdr vars1943) (cons (cons (car labels1942) (cons (quote lexical) (car vars1943))) r1944))))) (extend-env1210 (lambda (labels1945 bindings1946 r1947) (if (null? labels1945) r1947 (extend-env1210 (cdr labels1945) (cdr bindings1946) (cons (cons (car labels1945) (car bindings1946)) r1947))))) (binding-value1209 cdr) (binding-type1208 car) (source-annotation1207 (lambda (x1948) (cond ((annotation? x1948) (annotation-source x1948)) ((syntax-object?1200 x1948) (source-annotation1207 (syntax-object-expression1201 x1948))) (else #f)))) (set-syntax-object-module!1206 (lambda (x1949 update1950) (vector-set! x1949 3 update1950))) (set-syntax-object-wrap!1205 (lambda (x1951 update1952) (vector-set! x1951 2 update1952))) (set-syntax-object-expression!1204 (lambda (x1953 update1954) (vector-set! x1953 1 update1954))) (syntax-object-module1203 (lambda (x1955) (vector-ref x1955 3))) (syntax-object-wrap1202 (lambda (x1956) (vector-ref x1956 2))) (syntax-object-expression1201 (lambda (x1957) (vector-ref x1957 1))) (syntax-object?1200 (lambda (x1958) (and (vector? x1958) (= (vector-length x1958) 4) (eq? (vector-ref x1958 0) (quote syntax-object))))) (make-syntax-object1199 (lambda (expression1959 wrap1960 module1961) (vector (quote syntax-object) expression1959 wrap1960 module1961))) (build-letrec1198 (lambda (src1962 vars1963 val-exps1964 body-exp1965) (if (null? vars1963) (build-annotated1193 src1962 body-exp1965) (build-annotated1193 src1962 (list (quote letrec) (map list vars1963 val-exps1964) body-exp1965))))) (build-named-let1197 (lambda (src1966 vars1967 val-exps1968 body-exp1969) (if (null? vars1967) (build-annotated1193 src1966 body-exp1969) (build-annotated1193 src1966 (list (quote let) (car vars1967) (map list (cdr vars1967) val-exps1968) body-exp1969))))) (build-let1196 (lambda (src1970 vars1971 val-exps1972 body-exp1973) (if (null? vars1971) (build-annotated1193 src1970 body-exp1973) (build-annotated1193 src1970 (list (quote let) (map list vars1971 val-exps1972) body-exp1973))))) (build-sequence1195 (lambda (src1974 exps1975) (if (null? (cdr exps1975)) (build-annotated1193 src1974 (car exps1975)) (build-annotated1193 src1974 (cons (quote begin) exps1975))))) (build-data1194 (lambda (src1976 exp1977) (if (and (self-evaluating? exp1977) (not (vector? exp1977))) (build-annotated1193 src1976 exp1977) (build-annotated1193 src1976 (list (quote quote) exp1977))))) (build-annotated1193 (lambda (src1978 exp1979) (if (and src1978 (not (annotation? exp1979))) (make-annotation exp1979 src1978 #t) exp1979))) (get-global-definition-hook1192 (lambda (symbol1980 module1981) (begin (if (and (not module1981) (current-module)) (warn "module system is booted, we should have a module" symbol1980)) (let ((v1982 (module-variable (if module1981 (resolve-module (cdr module1981)) (current-module)) symbol1980))) (and v1982 (variable-bound? v1982) (let ((val1983 (variable-ref v1982))) (and (macro? val1983) (syncase-macro-type val1983) (cons (syncase-macro-type val1983) (syncase-macro-binding val1983))))))))) (put-global-definition-hook1191 (lambda (symbol1984 type1985 val1986) (let ((existing1987 (let ((v1988 (module-variable (current-module) symbol1984))) (and v1988 (variable-bound? v1988) (let ((val1989 (variable-ref v1988))) (and (macro? val1989) (not (syncase-macro-type val1989)) val1989)))))) (module-define! (current-module) symbol1984 (if existing1987 (make-extended-syncase-macro existing1987 type1985 val1986) (make-syncase-macro type1985 val1986)))))) (local-eval-hook1190 (lambda (x1990 mod1991) (primitive-eval (list noexpand1184 x1990)))) (top-level-eval-hook1189 (lambda (x1992 mod1993) (primitive-eval (list noexpand1184 x1992)))) (fx<1188 <) (fx=1187 =) (fx-1186 -) (fx+1185 +) (noexpand1184 "noexpand")) (begin (global-extend1214 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1214 (quote local-syntax) (quote let-syntax) #f) (global-extend1214 (quote core) (quote fluid-let-syntax) (lambda (e1994 r1995 w1996 s1997 mod1998) ((lambda (tmp1999) ((lambda (tmp2000) (if (if tmp2000 (apply (lambda (_2001 var2002 val2003 e12004 e22005) (valid-bound-ids?1241 var2002)) tmp2000) #f) (apply (lambda (_2007 var2008 val2009 e12010 e22011) (let ((names2012 (map (lambda (x2013) (id-var-name1238 x2013 w1996)) var2008))) (begin (for-each (lambda (id2015 n2016) (let ((t2017 (binding-type1208 (lookup1213 n2016 r1995 mod1998)))) (if (memv t2017 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1994 (source-wrap1245 id2015 w1996 s1997 mod1998))))) var2008 names2012) (chi-body1256 (cons e12010 e22011) (source-wrap1245 e1994 w1996 s1997 mod1998) (extend-env1210 names2012 (let ((trans-r2020 (macros-only-env1212 r1995))) (map (lambda (x2021) (cons (quote macro) (eval-local-transformer1259 (chi1252 x2021 trans-r2020 w1996 mod1998) mod1998))) val2009)) r1995) w1996 mod1998)))) tmp2000) ((lambda (_2023) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1245 e1994 w1996 s1997 mod1998))) tmp1999))) ($sc-dispatch tmp1999 (quote (any #(each (any any)) any . each-any))))) e1994))) (global-extend1214 (quote core) (quote quote) (lambda (e2024 r2025 w2026 s2027 mod2028) ((lambda (tmp2029) ((lambda (tmp2030) (if tmp2030 (apply (lambda (_2031 e2032) (build-data1194 s2027 (strip1263 e2032 w2026))) tmp2030) ((lambda (_2033) (syntax-violation (quote quote) "bad syntax" (source-wrap1245 e2024 w2026 s2027 mod2028))) tmp2029))) ($sc-dispatch tmp2029 (quote (any any))))) e2024))) (global-extend1214 (quote core) (quote syntax) (letrec ((regen2041 (lambda (x2042) (let ((t2043 (car x2042))) (if (memv t2043 (quote (ref))) (build-annotated1193 #f (cadr x2042)) (if (memv t2043 (quote (primitive))) (build-annotated1193 #f (cadr x2042)) (if (memv t2043 (quote (quote))) (build-data1194 #f (cadr x2042)) (if (memv t2043 (quote (lambda))) (build-annotated1193 #f (list (quote lambda) (cadr x2042) (regen2041 (caddr x2042)))) (if (memv t2043 (quote (map))) (let ((ls2044 (map regen2041 (cdr x2042)))) (build-annotated1193 #f (cons (if (fx=1187 (length ls2044) 2) (build-annotated1193 #f (quote map)) (build-annotated1193 #f (quote map))) ls2044))) (build-annotated1193 #f (cons (build-annotated1193 #f (car x2042)) (map regen2041 (cdr x2042)))))))))))) (gen-vector2040 (lambda (x2045) (cond ((eq? (car x2045) (quote list)) (cons (quote vector) (cdr x2045))) ((eq? (car x2045) (quote quote)) (list (quote quote) (list->vector (cadr x2045)))) (else (list (quote list->vector) x2045))))) (gen-append2039 (lambda (x2046 y2047) (if (equal? y2047 (quote (quote ()))) x2046 (list (quote append) x2046 y2047)))) (gen-cons2038 (lambda (x2048 y2049) (let ((t2050 (car y2049))) (if (memv t2050 (quote (quote))) (if (eq? (car x2048) (quote quote)) (list (quote quote) (cons (cadr x2048) (cadr y2049))) (if (eq? (cadr y2049) (quote ())) (list (quote list) x2048) (list (quote cons) x2048 y2049))) (if (memv t2050 (quote (list))) (cons (quote list) (cons x2048 (cdr y2049))) (list (quote cons) x2048 y2049)))))) (gen-map2037 (lambda (e2051 map-env2052) (let ((formals2053 (map cdr map-env2052)) (actuals2054 (map (lambda (x2055) (list (quote ref) (car x2055))) map-env2052))) (cond ((eq? (car e2051) (quote ref)) (car actuals2054)) ((and-map (lambda (x2056) (and (eq? (car x2056) (quote ref)) (memq (cadr x2056) formals2053))) (cdr e2051)) (cons (quote map) (cons (list (quote primitive) (car e2051)) (map (let ((r2057 (map cons formals2053 actuals2054))) (lambda (x2058) (cdr (assq (cadr x2058) r2057)))) (cdr e2051))))) (else (cons (quote map) (cons (list (quote lambda) formals2053 e2051) actuals2054))))))) (gen-mappend2036 (lambda (e2059 map-env2060) (list (quote apply) (quote (primitive append)) (gen-map2037 e2059 map-env2060)))) (gen-ref2035 (lambda (src2061 var2062 level2063 maps2064) (if (fx=1187 level2063 0) (values var2062 maps2064) (if (null? maps2064) (syntax-violation (quote syntax) "missing ellipsis" src2061) (call-with-values (lambda () (gen-ref2035 src2061 var2062 (fx-1186 level2063 1) (cdr maps2064))) (lambda (outer-var2065 outer-maps2066) (let ((b2067 (assq outer-var2065 (car maps2064)))) (if b2067 (values (cdr b2067) maps2064) (let ((inner-var2068 (gen-var1264 (quote tmp)))) (values inner-var2068 (cons (cons (cons outer-var2065 inner-var2068) (car maps2064)) outer-maps2066))))))))))) (gen-syntax2034 (lambda (src2069 e2070 r2071 maps2072 ellipsis?2073 mod2074) (if (id?1216 e2070) (let ((label2075 (id-var-name1238 e2070 (quote (()))))) (let ((b2076 (lookup1213 label2075 r2071 mod2074))) (if (eq? (binding-type1208 b2076) (quote syntax)) (call-with-values (lambda () (let ((var.lev2077 (binding-value1209 b2076))) (gen-ref2035 src2069 (car var.lev2077) (cdr var.lev2077) maps2072))) (lambda (var2078 maps2079) (values (list (quote ref) var2078) maps2079))) (if (ellipsis?2073 e2070) (syntax-violation (quote syntax) "misplaced ellipsis" src2069) (values (list (quote quote) e2070) maps2072))))) ((lambda (tmp2080) ((lambda (tmp2081) (if (if tmp2081 (apply (lambda (dots2082 e2083) (ellipsis?2073 dots2082)) tmp2081) #f) (apply (lambda (dots2084 e2085) (gen-syntax2034 src2069 e2085 r2071 maps2072 (lambda (x2086) #f) mod2074)) tmp2081) ((lambda (tmp2087) (if (if tmp2087 (apply (lambda (x2088 dots2089 y2090) (ellipsis?2073 dots2089)) tmp2087) #f) (apply (lambda (x2091 dots2092 y2093) (let f2094 ((y2095 y2093) (k2096 (lambda (maps2097) (call-with-values (lambda () (gen-syntax2034 src2069 x2091 r2071 (cons (quote ()) maps2097) ellipsis?2073 mod2074)) (lambda (x2098 maps2099) (if (null? (car maps2099)) (syntax-violation (quote syntax) "extra ellipsis" src2069) (values (gen-map2037 x2098 (car maps2099)) (cdr maps2099)))))))) ((lambda (tmp2100) ((lambda (tmp2101) (if (if tmp2101 (apply (lambda (dots2102 y2103) (ellipsis?2073 dots2102)) tmp2101) #f) (apply (lambda (dots2104 y2105) (f2094 y2105 (lambda (maps2106) (call-with-values (lambda () (k2096 (cons (quote ()) maps2106))) (lambda (x2107 maps2108) (if (null? (car maps2108)) (syntax-violation (quote syntax) "extra ellipsis" src2069) (values (gen-mappend2036 x2107 (car maps2108)) (cdr maps2108)))))))) tmp2101) ((lambda (_2109) (call-with-values (lambda () (gen-syntax2034 src2069 y2095 r2071 maps2072 ellipsis?2073 mod2074)) (lambda (y2110 maps2111) (call-with-values (lambda () (k2096 maps2111)) (lambda (x2112 maps2113) (values (gen-append2039 x2112 y2110) maps2113)))))) tmp2100))) ($sc-dispatch tmp2100 (quote (any . any))))) y2095))) tmp2087) ((lambda (tmp2114) (if tmp2114 (apply (lambda (x2115 y2116) (call-with-values (lambda () (gen-syntax2034 src2069 x2115 r2071 maps2072 ellipsis?2073 mod2074)) (lambda (x2117 maps2118) (call-with-values (lambda () (gen-syntax2034 src2069 y2116 r2071 maps2118 ellipsis?2073 mod2074)) (lambda (y2119 maps2120) (values (gen-cons2038 x2117 y2119) maps2120)))))) tmp2114) ((lambda (tmp2121) (if tmp2121 (apply (lambda (e12122 e22123) (call-with-values (lambda () (gen-syntax2034 src2069 (cons e12122 e22123) r2071 maps2072 ellipsis?2073 mod2074)) (lambda (e2125 maps2126) (values (gen-vector2040 e2125) maps2126)))) tmp2121) ((lambda (_2127) (values (list (quote quote) e2070) maps2072)) tmp2080))) ($sc-dispatch tmp2080 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2080 (quote (any . any)))))) ($sc-dispatch tmp2080 (quote (any any . any)))))) ($sc-dispatch tmp2080 (quote (any any))))) e2070))))) (lambda (e2128 r2129 w2130 s2131 mod2132) (let ((e2133 (source-wrap1245 e2128 w2130 s2131 mod2132))) ((lambda (tmp2134) ((lambda (tmp2135) (if tmp2135 (apply (lambda (_2136 x2137) (call-with-values (lambda () (gen-syntax2034 e2133 x2137 r2129 (quote ()) ellipsis?1261 mod2132)) (lambda (e2138 maps2139) (regen2041 e2138)))) tmp2135) ((lambda (_2140) (syntax-violation (quote syntax) "bad `syntax' form" e2133)) tmp2134))) ($sc-dispatch tmp2134 (quote (any any))))) e2133))))) (global-extend1214 (quote core) (quote lambda) (lambda (e2141 r2142 w2143 s2144 mod2145) ((lambda (tmp2146) ((lambda (tmp2147) (if tmp2147 (apply (lambda (_2148 c2149) (chi-lambda-clause1257 (source-wrap1245 e2141 w2143 s2144 mod2145) #f c2149 r2142 w2143 mod2145 (lambda (vars2150 docstring2151 body2152) (build-annotated1193 s2144 (cons (quote lambda) (cons vars2150 (append (if docstring2151 (list docstring2151) (quote ())) (list body2152)))))))) tmp2147) (syntax-violation #f "source expression failed to match any pattern" tmp2146))) ($sc-dispatch tmp2146 (quote (any . any))))) e2141))) (global-extend1214 (quote core) (quote let) (letrec ((chi-let2153 (lambda (e2154 r2155 w2156 s2157 mod2158 constructor2159 ids2160 vals2161 exps2162) (if (not (valid-bound-ids?1241 ids2160)) (syntax-violation (quote let) "duplicate bound variable" e2154) (let ((labels2163 (gen-labels1222 ids2160)) (new-vars2164 (map gen-var1264 ids2160))) (let ((nw2165 (make-binding-wrap1233 ids2160 labels2163 w2156)) (nr2166 (extend-var-env1211 labels2163 new-vars2164 r2155))) (constructor2159 s2157 new-vars2164 (map (lambda (x2167) (chi1252 x2167 r2155 w2156 mod2158)) vals2161) (chi-body1256 exps2162 (source-wrap1245 e2154 nw2165 s2157 mod2158) nr2166 nw2165 mod2158)))))))) (lambda (e2168 r2169 w2170 s2171 mod2172) ((lambda (tmp2173) ((lambda (tmp2174) (if tmp2174 (apply (lambda (_2175 id2176 val2177 e12178 e22179) (chi-let2153 e2168 r2169 w2170 s2171 mod2172 build-let1196 id2176 val2177 (cons e12178 e22179))) tmp2174) ((lambda (tmp2183) (if (if tmp2183 (apply (lambda (_2184 f2185 id2186 val2187 e12188 e22189) (id?1216 f2185)) tmp2183) #f) (apply (lambda (_2190 f2191 id2192 val2193 e12194 e22195) (chi-let2153 e2168 r2169 w2170 s2171 mod2172 build-named-let1197 (cons f2191 id2192) val2193 (cons e12194 e22195))) tmp2183) ((lambda (_2199) (syntax-violation (quote let) "bad let" (source-wrap1245 e2168 w2170 s2171 mod2172))) tmp2173))) ($sc-dispatch tmp2173 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2173 (quote (any #(each (any any)) any . each-any))))) e2168)))) (global-extend1214 (quote core) (quote letrec) (lambda (e2200 r2201 w2202 s2203 mod2204) ((lambda (tmp2205) ((lambda (tmp2206) (if tmp2206 (apply (lambda (_2207 id2208 val2209 e12210 e22211) (let ((ids2212 id2208)) (if (not (valid-bound-ids?1241 ids2212)) (syntax-violation (quote letrec) "duplicate bound variable" e2200) (let ((labels2214 (gen-labels1222 ids2212)) (new-vars2215 (map gen-var1264 ids2212))) (let ((w2216 (make-binding-wrap1233 ids2212 labels2214 w2202)) (r2217 (extend-var-env1211 labels2214 new-vars2215 r2201))) (build-letrec1198 s2203 new-vars2215 (map (lambda (x2218) (chi1252 x2218 r2217 w2216 mod2204)) val2209) (chi-body1256 (cons e12210 e22211) (source-wrap1245 e2200 w2216 s2203 mod2204) r2217 w2216 mod2204))))))) tmp2206) ((lambda (_2221) (syntax-violation (quote letrec) "bad letrec" (source-wrap1245 e2200 w2202 s2203 mod2204))) tmp2205))) ($sc-dispatch tmp2205 (quote (any #(each (any any)) any . each-any))))) e2200))) (global-extend1214 (quote core) (quote set!) (lambda (e2222 r2223 w2224 s2225 mod2226) ((lambda (tmp2227) ((lambda (tmp2228) (if (if tmp2228 (apply (lambda (_2229 id2230 val2231) (id?1216 id2230)) tmp2228) #f) (apply (lambda (_2232 id2233 val2234) (let ((val2235 (chi1252 val2234 r2223 w2224 mod2226)) (n2236 (id-var-name1238 id2233 w2224))) (let ((b2237 (lookup1213 n2236 r2223 mod2226))) (let ((t2238 (binding-type1208 b2237))) (if (memv t2238 (quote (lexical))) (build-annotated1193 s2225 (list (quote set!) (binding-value1209 b2237) val2235)) (if (memv t2238 (quote (global))) (build-annotated1193 s2225 (list (quote set!) (if mod2226 (make-module-ref (cdr mod2226) n2236 (car mod2226)) (make-module-ref mod2226 n2236 (quote bare))) val2235)) (if (memv t2238 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1244 id2233 w2224 mod2226)) (syntax-violation (quote set!) "bad set!" (source-wrap1245 e2222 w2224 s2225 mod2226))))))))) tmp2228) ((lambda (tmp2239) (if tmp2239 (apply (lambda (_2240 head2241 tail2242 val2243) (call-with-values (lambda () (syntax-type1250 head2241 r2223 (quote (())) #f #f mod2226)) (lambda (type2244 value2245 ee2246 ww2247 ss2248 modmod2249) (let ((t2250 type2244)) (if (memv t2250 (quote (module-ref))) (let ((val2251 (chi1252 val2243 r2223 w2224 mod2226))) (call-with-values (lambda () (value2245 (cons head2241 tail2242))) (lambda (id2253 mod2254) (build-annotated1193 s2225 (list (quote set!) (if mod2254 (make-module-ref (cdr mod2254) id2253 (car mod2254)) (make-module-ref mod2254 id2253 (quote bare))) val2251))))) (build-annotated1193 s2225 (cons (chi1252 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2241) r2223 w2224 mod2226) (map (lambda (e2255) (chi1252 e2255 r2223 w2224 mod2226)) (append tail2242 (list val2243)))))))))) tmp2239) ((lambda (_2257) (syntax-violation (quote set!) "bad set!" (source-wrap1245 e2222 w2224 s2225 mod2226))) tmp2227))) ($sc-dispatch tmp2227 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2227 (quote (any any any))))) e2222))) (global-extend1214 (quote module-ref) (quote @) (lambda (e2258) ((lambda (tmp2259) ((lambda (tmp2260) (if (if tmp2260 (apply (lambda (_2261 mod2262 id2263) (and (and-map id?1216 mod2262) (id?1216 id2263))) tmp2260) #f) (apply (lambda (_2265 mod2266 id2267) (values (syntax->datum id2267) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2266)))) tmp2260) (syntax-violation #f "source expression failed to match any pattern" tmp2259))) ($sc-dispatch tmp2259 (quote (any each-any any))))) e2258))) (global-extend1214 (quote module-ref) (quote @@) (lambda (e2269) ((lambda (tmp2270) ((lambda (tmp2271) (if (if tmp2271 (apply (lambda (_2272 mod2273 id2274) (and (and-map id?1216 mod2273) (id?1216 id2274))) tmp2271) #f) (apply (lambda (_2276 mod2277 id2278) (values (syntax->datum id2278) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2277)))) tmp2271) (syntax-violation #f "source expression failed to match any pattern" tmp2270))) ($sc-dispatch tmp2270 (quote (any each-any any))))) e2269))) (global-extend1214 (quote begin) (quote begin) (quote ())) (global-extend1214 (quote define) (quote define) (quote ())) (global-extend1214 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1214 (quote eval-when) (quote eval-when) (quote ())) (global-extend1214 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2283 (lambda (x2284 keys2285 clauses2286 r2287 mod2288) (if (null? clauses2286) (build-annotated1193 #f (list (build-annotated1193 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2284)) ((lambda (tmp2289) ((lambda (tmp2290) (if tmp2290 (apply (lambda (pat2291 exp2292) (if (and (id?1216 pat2291) (and-map (lambda (x2293) (not (free-id=?1239 pat2291 x2293))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2285))) (let ((labels2294 (list (gen-label1221))) (var2295 (gen-var1264 pat2291))) (build-annotated1193 #f (list (build-annotated1193 #f (list (quote lambda) (list var2295) (chi1252 exp2292 (extend-env1210 labels2294 (list (cons (quote syntax) (cons var2295 0))) r2287) (make-binding-wrap1233 (list pat2291) labels2294 (quote (()))) mod2288))) x2284))) (gen-clause2282 x2284 keys2285 (cdr clauses2286) r2287 pat2291 #t exp2292 mod2288))) tmp2290) ((lambda (tmp2296) (if tmp2296 (apply (lambda (pat2297 fender2298 exp2299) (gen-clause2282 x2284 keys2285 (cdr clauses2286) r2287 pat2297 fender2298 exp2299 mod2288)) tmp2296) ((lambda (_2300) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2286))) tmp2289))) ($sc-dispatch tmp2289 (quote (any any any)))))) ($sc-dispatch tmp2289 (quote (any any))))) (car clauses2286))))) (gen-clause2282 (lambda (x2301 keys2302 clauses2303 r2304 pat2305 fender2306 exp2307 mod2308) (call-with-values (lambda () (convert-pattern2280 pat2305 keys2302)) (lambda (p2309 pvars2310) (cond ((not (distinct-bound-ids?1242 (map car pvars2310))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2305)) ((not (and-map (lambda (x2311) (not (ellipsis?1261 (car x2311)))) pvars2310)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2305)) (else (let ((y2312 (gen-var1264 (quote tmp)))) (build-annotated1193 #f (list (build-annotated1193 #f (list (quote lambda) (list y2312) (let ((y2313 (build-annotated1193 #f y2312))) (build-annotated1193 #f (list (quote if) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda () y2313) tmp2315) ((lambda (_2316) (build-annotated1193 #f (list (quote if) y2313 (build-dispatch-call2281 pvars2310 fender2306 y2313 r2304 mod2308) (build-data1194 #f #f)))) tmp2314))) ($sc-dispatch tmp2314 (quote #(atom #t))))) fender2306) (build-dispatch-call2281 pvars2310 exp2307 y2313 r2304 mod2308) (gen-syntax-case2283 x2301 keys2302 clauses2303 r2304 mod2308)))))) (if (eq? p2309 (quote any)) (build-annotated1193 #f (list (build-annotated1193 #f (quote list)) x2301)) (build-annotated1193 #f (list (build-annotated1193 #f (quote $sc-dispatch)) x2301 (build-data1194 #f p2309))))))))))))) (build-dispatch-call2281 (lambda (pvars2317 exp2318 y2319 r2320 mod2321) (let ((ids2322 (map car pvars2317)) (levels2323 (map cdr pvars2317))) (let ((labels2324 (gen-labels1222 ids2322)) (new-vars2325 (map gen-var1264 ids2322))) (build-annotated1193 #f (list (build-annotated1193 #f (quote apply)) (build-annotated1193 #f (list (quote lambda) new-vars2325 (chi1252 exp2318 (extend-env1210 labels2324 (map (lambda (var2326 level2327) (cons (quote syntax) (cons var2326 level2327))) new-vars2325 (map cdr pvars2317)) r2320) (make-binding-wrap1233 ids2322 labels2324 (quote (()))) mod2321))) y2319)))))) (convert-pattern2280 (lambda (pattern2328 keys2329) (let cvt2330 ((p2331 pattern2328) (n2332 0) (ids2333 (quote ()))) (if (id?1216 p2331) (if (bound-id-member?1243 p2331 keys2329) (values (vector (quote free-id) p2331) ids2333) (values (quote any) (cons (cons p2331 n2332) ids2333))) ((lambda (tmp2334) ((lambda (tmp2335) (if (if tmp2335 (apply (lambda (x2336 dots2337) (ellipsis?1261 dots2337)) tmp2335) #f) (apply (lambda (x2338 dots2339) (call-with-values (lambda () (cvt2330 x2338 (fx+1185 n2332 1) ids2333)) (lambda (p2340 ids2341) (values (if (eq? p2340 (quote any)) (quote each-any) (vector (quote each) p2340)) ids2341)))) tmp2335) ((lambda (tmp2342) (if tmp2342 (apply (lambda (x2343 y2344) (call-with-values (lambda () (cvt2330 y2344 n2332 ids2333)) (lambda (y2345 ids2346) (call-with-values (lambda () (cvt2330 x2343 n2332 ids2346)) (lambda (x2347 ids2348) (values (cons x2347 y2345) ids2348)))))) tmp2342) ((lambda (tmp2349) (if tmp2349 (apply (lambda () (values (quote ()) ids2333)) tmp2349) ((lambda (tmp2350) (if tmp2350 (apply (lambda (x2351) (call-with-values (lambda () (cvt2330 x2351 n2332 ids2333)) (lambda (p2353 ids2354) (values (vector (quote vector) p2353) ids2354)))) tmp2350) ((lambda (x2355) (values (vector (quote atom) (strip1263 p2331 (quote (())))) ids2333)) tmp2334))) ($sc-dispatch tmp2334 (quote #(vector each-any)))))) ($sc-dispatch tmp2334 (quote ()))))) ($sc-dispatch tmp2334 (quote (any . any)))))) ($sc-dispatch tmp2334 (quote (any any))))) p2331)))))) (lambda (e2356 r2357 w2358 s2359 mod2360) (let ((e2361 (source-wrap1245 e2356 w2358 s2359 mod2360))) ((lambda (tmp2362) ((lambda (tmp2363) (if tmp2363 (apply (lambda (_2364 val2365 key2366 m2367) (if (and-map (lambda (x2368) (and (id?1216 x2368) (not (ellipsis?1261 x2368)))) key2366) (let ((x2370 (gen-var1264 (quote tmp)))) (build-annotated1193 s2359 (list (build-annotated1193 #f (list (quote lambda) (list x2370) (gen-syntax-case2283 (build-annotated1193 #f x2370) key2366 m2367 r2357 mod2360))) (chi1252 val2365 r2357 (quote (())) mod2360)))) (syntax-violation (quote syntax-case) "invalid literals list" e2361))) tmp2363) (syntax-violation #f "source expression failed to match any pattern" tmp2362))) ($sc-dispatch tmp2362 (quote (any any each-any . each-any))))) e2361))))) (set! sc-expand (let ((m2373 (quote e)) (esew2374 (quote (eval)))) (lambda (x2375) (if (and (pair? x2375) (equal? (car x2375) noexpand1184)) (cadr x2375) (chi-top1251 x2375 (quote ()) (quote ((top))) m2373 esew2374 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2376 (quote e)) (esew2377 (quote (eval)))) (lambda (x2379 . rest2378) (if (and (pair? x2379) (equal? (car x2379) noexpand1184)) (cadr x2379) (chi-top1251 x2379 (quote ()) (quote ((top))) (if (null? rest2378) m2376 (car rest2378)) (if (or (null? rest2378) (null? (cdr rest2378))) esew2377 (cadr rest2378)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2380) (nonsymbol-id?1215 x2380))) (set! datum->syntax (lambda (id2381 datum2382) (make-syntax-object1199 datum2382 (syntax-object-wrap1202 id2381) #f))) (set! syntax->datum (lambda (x2383) (strip1263 x2383 (quote (()))))) (set! generate-temporaries (lambda (ls2384) (begin (let ((x2385 ls2384)) (if (not (list? x2385)) (syntax-violation (quote generate-temporaries) "invalid argument" x2385))) (map (lambda (x2386) (wrap1244 (gensym) (quote ((top))) #f)) ls2384)))) (set! free-identifier=? (lambda (x2387 y2388) (begin (let ((x2389 x2387)) (if (not (nonsymbol-id?1215 x2389)) (syntax-violation (quote free-identifier=?) "invalid argument" x2389))) (let ((x2390 y2388)) (if (not (nonsymbol-id?1215 x2390)) (syntax-violation (quote free-identifier=?) "invalid argument" x2390))) (free-id=?1239 x2387 y2388)))) (set! bound-identifier=? (lambda (x2391 y2392) (begin (let ((x2393 x2391)) (if (not (nonsymbol-id?1215 x2393)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2393))) (let ((x2394 y2392)) (if (not (nonsymbol-id?1215 x2394)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2394))) (bound-id=?1240 x2391 y2392)))) (set! syntax-violation (lambda (who2398 message2397 form2396 . subform2395) (begin (let ((x2399 who2398)) (if (not ((lambda (x2400) (or (not x2400) (string? x2400) (symbol? x2400))) x2399)) (syntax-violation (quote syntax-violation) "invalid argument" x2399))) (let ((x2401 message2397)) (if (not (string? x2401)) (syntax-violation (quote syntax-violation) "invalid argument" x2401))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2398 "~a: " "") "~a " (if (null? subform2395) "in ~a" "in subform `~s' of `~s'")) (let ((tail2402 (cons message2397 (map (lambda (x2403) (strip1263 x2403 (quote (())))) (append subform2395 (list form2396)))))) (if who2398 (cons who2398 tail2402) tail2402)) #f)))) (letrec ((match2408 (lambda (e2409 p2410 w2411 r2412 mod2413) (cond ((not r2412) #f) ((eq? p2410 (quote any)) (cons (wrap1244 e2409 w2411 mod2413) r2412)) ((syntax-object?1200 e2409) (match*2407 (let ((e2414 (syntax-object-expression1201 e2409))) (if (annotation? e2414) (annotation-expression e2414) e2414)) p2410 (join-wraps1235 w2411 (syntax-object-wrap1202 e2409)) r2412 (syntax-object-module1203 e2409))) (else (match*2407 (let ((e2415 e2409)) (if (annotation? e2415) (annotation-expression e2415) e2415)) p2410 w2411 r2412 mod2413))))) (match*2407 (lambda (e2416 p2417 w2418 r2419 mod2420) (cond ((null? p2417) (and (null? e2416) r2419)) ((pair? p2417) (and (pair? e2416) (match2408 (car e2416) (car p2417) w2418 (match2408 (cdr e2416) (cdr p2417) w2418 r2419 mod2420) mod2420))) ((eq? p2417 (quote each-any)) (let ((l2421 (match-each-any2405 e2416 w2418 mod2420))) (and l2421 (cons l2421 r2419)))) (else (let ((t2422 (vector-ref p2417 0))) (if (memv t2422 (quote (each))) (if (null? e2416) (match-empty2406 (vector-ref p2417 1) r2419) (let ((l2423 (match-each2404 e2416 (vector-ref p2417 1) w2418 mod2420))) (and l2423 (let collect2424 ((l2425 l2423)) (if (null? (car l2425)) r2419 (cons (map car l2425) (collect2424 (map cdr l2425)))))))) (if (memv t2422 (quote (free-id))) (and (id?1216 e2416) (free-id=?1239 (wrap1244 e2416 w2418 mod2420) (vector-ref p2417 1)) r2419) (if (memv t2422 (quote (atom))) (and (equal? (vector-ref p2417 1) (strip1263 e2416 w2418)) r2419) (if (memv t2422 (quote (vector))) (and (vector? e2416) (match2408 (vector->list e2416) (vector-ref p2417 1) w2418 r2419 mod2420))))))))))) (match-empty2406 (lambda (p2426 r2427) (cond ((null? p2426) r2427) ((eq? p2426 (quote any)) (cons (quote ()) r2427)) ((pair? p2426) (match-empty2406 (car p2426) (match-empty2406 (cdr p2426) r2427))) ((eq? p2426 (quote each-any)) (cons (quote ()) r2427)) (else (let ((t2428 (vector-ref p2426 0))) (if (memv t2428 (quote (each))) (match-empty2406 (vector-ref p2426 1) r2427) (if (memv t2428 (quote (free-id atom))) r2427 (if (memv t2428 (quote (vector))) (match-empty2406 (vector-ref p2426 1) r2427))))))))) (match-each-any2405 (lambda (e2429 w2430 mod2431) (cond ((annotation? e2429) (match-each-any2405 (annotation-expression e2429) w2430 mod2431)) ((pair? e2429) (let ((l2432 (match-each-any2405 (cdr e2429) w2430 mod2431))) (and l2432 (cons (wrap1244 (car e2429) w2430 mod2431) l2432)))) ((null? e2429) (quote ())) ((syntax-object?1200 e2429) (match-each-any2405 (syntax-object-expression1201 e2429) (join-wraps1235 w2430 (syntax-object-wrap1202 e2429)) mod2431)) (else #f)))) (match-each2404 (lambda (e2433 p2434 w2435 mod2436) (cond ((annotation? e2433) (match-each2404 (annotation-expression e2433) p2434 w2435 mod2436)) ((pair? e2433) (let ((first2437 (match2408 (car e2433) p2434 w2435 (quote ()) mod2436))) (and first2437 (let ((rest2438 (match-each2404 (cdr e2433) p2434 w2435 mod2436))) (and rest2438 (cons first2437 rest2438)))))) ((null? e2433) (quote ())) ((syntax-object?1200 e2433) (match-each2404 (syntax-object-expression1201 e2433) p2434 (join-wraps1235 w2435 (syntax-object-wrap1202 e2433)) (syntax-object-module1203 e2433))) (else #f))))) (set! $sc-dispatch (lambda (e2439 p2440) (cond ((eq? p2440 (quote any)) (list e2439)) ((syntax-object?1200 e2439) (match*2407 (let ((e2441 (syntax-object-expression1201 e2439))) (if (annotation? e2441) (annotation-expression e2441) e2441)) p2440 (syntax-object-wrap1202 e2439) (quote ()) (syntax-object-module1203 e2439))) (else (match*2407 (let ((e2442 e2439)) (if (annotation? e2442) (annotation-expression e2442) e2442)) p2440 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2443) ((lambda (tmp2444) ((lambda (tmp2445) (if tmp2445 (apply (lambda (_2446 e12447 e22448) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12447 e22448))) tmp2445) ((lambda (tmp2450) (if tmp2450 (apply (lambda (_2451 out2452 in2453 e12454 e22455) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2453 (quote ()) (list out2452 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12454 e22455))))) tmp2450) ((lambda (tmp2457) (if tmp2457 (apply (lambda (_2458 out2459 in2460 e12461 e22462) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2460) (quote ()) (list out2459 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12461 e22462))))) tmp2457) (syntax-violation #f "source expression failed to match any pattern" tmp2444))) ($sc-dispatch tmp2444 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2444 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2444 (quote (any () any . each-any))))) x2443)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda (_2469 k2470 keyword2471 pattern2472 template2473) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2470 (map (lambda (tmp2476 tmp2475) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2475) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2476))) template2473 pattern2472)))))) tmp2468) (syntax-violation #f "source expression failed to match any pattern" tmp2467))) ($sc-dispatch tmp2467 (quote (any each-any . #(each ((any . any) any))))))) x2466)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2477) ((lambda (tmp2478) ((lambda (tmp2479) (if (if tmp2479 (apply (lambda (let*2480 x2481 v2482 e12483 e22484) (and-map identifier? x2481)) tmp2479) #f) (apply (lambda (let*2486 x2487 v2488 e12489 e22490) (let f2491 ((bindings2492 (map list x2487 v2488))) (if (null? bindings2492) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12489 e22490))) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (body2498 binding2499) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2499) body2498)) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) ($sc-dispatch tmp2496 (quote (any any))))) (list (f2491 (cdr bindings2492)) (car bindings2492)))))) tmp2479) (syntax-violation #f "source expression failed to match any pattern" tmp2478))) ($sc-dispatch tmp2478 (quote (any #(each (any any)) any . each-any))))) x2477)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2500) ((lambda (tmp2501) ((lambda (tmp2502) (if tmp2502 (apply (lambda (_2503 var2504 init2505 step2506 e02507 e12508 c2509) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (step2512) ((lambda (tmp2513) ((lambda (tmp2514) (if tmp2514 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2514) ((lambda (tmp2519) (if tmp2519 (apply (lambda (e12520 e22521) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12520 e22521)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2519) (syntax-violation #f "source expression failed to match any pattern" tmp2513))) ($sc-dispatch tmp2513 (quote (any . each-any)))))) ($sc-dispatch tmp2513 (quote ())))) e12508)) tmp2511) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote each-any)))) (map (lambda (v2528 s2529) ((lambda (tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda () v2528) tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (e2533) e2533) tmp2532) ((lambda (_2534) (syntax-violation (quote do) "bad step expression" orig-x2500 s2529)) tmp2530))) ($sc-dispatch tmp2530 (quote (any)))))) ($sc-dispatch tmp2530 (quote ())))) s2529)) var2504 step2506))) tmp2502) (syntax-violation #f "source expression failed to match any pattern" tmp2501))) ($sc-dispatch tmp2501 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2500)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2537 (lambda (x2541 y2542) ((lambda (tmp2543) ((lambda (tmp2544) (if tmp2544 (apply (lambda (x2545 y2546) ((lambda (tmp2547) ((lambda (tmp2548) (if tmp2548 (apply (lambda (dy2549) ((lambda (tmp2550) ((lambda (tmp2551) (if tmp2551 (apply (lambda (dx2552) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2552 dy2549))) tmp2551) ((lambda (_2553) (if (null? dy2549) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546))) tmp2550))) ($sc-dispatch tmp2550 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2545)) tmp2548) ((lambda (tmp2554) (if tmp2554 (apply (lambda (stuff2555) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2545 stuff2555))) tmp2554) ((lambda (else2556) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546)) tmp2547))) ($sc-dispatch tmp2547 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2547 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2546)) tmp2544) (syntax-violation #f "source expression failed to match any pattern" tmp2543))) ($sc-dispatch tmp2543 (quote (any any))))) (list x2541 y2542)))) (quasiappend2538 (lambda (x2557 y2558) ((lambda (tmp2559) ((lambda (tmp2560) (if tmp2560 (apply (lambda (x2561 y2562) ((lambda (tmp2563) ((lambda (tmp2564) (if tmp2564 (apply (lambda () x2561) tmp2564) ((lambda (_2565) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2561 y2562)) tmp2563))) ($sc-dispatch tmp2563 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2562)) tmp2560) (syntax-violation #f "source expression failed to match any pattern" tmp2559))) ($sc-dispatch tmp2559 (quote (any any))))) (list x2557 y2558)))) (quasivector2539 (lambda (x2566) ((lambda (tmp2567) ((lambda (x2568) ((lambda (tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (x2571) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2571))) tmp2570) ((lambda (tmp2573) (if tmp2573 (apply (lambda (x2574) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2574)) tmp2573) ((lambda (_2576) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2568)) tmp2569))) ($sc-dispatch tmp2569 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2569 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2568)) tmp2567)) x2566))) (quasi2540 (lambda (p2577 lev2578) ((lambda (tmp2579) ((lambda (tmp2580) (if tmp2580 (apply (lambda (p2581) (if (= lev2578 0) p2581 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2581) (- lev2578 1))))) tmp2580) ((lambda (tmp2582) (if tmp2582 (apply (lambda (p2583 q2584) (if (= lev2578 0) (quasiappend2538 p2583 (quasi2540 q2584 lev2578)) (quasicons2537 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2583) (- lev2578 1))) (quasi2540 q2584 lev2578)))) tmp2582) ((lambda (tmp2585) (if tmp2585 (apply (lambda (p2586) (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2586) (+ lev2578 1)))) tmp2585) ((lambda (tmp2587) (if tmp2587 (apply (lambda (p2588 q2589) (quasicons2537 (quasi2540 p2588 lev2578) (quasi2540 q2589 lev2578))) tmp2587) ((lambda (tmp2590) (if tmp2590 (apply (lambda (x2591) (quasivector2539 (quasi2540 x2591 lev2578))) tmp2590) ((lambda (p2593) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2593)) tmp2579))) ($sc-dispatch tmp2579 (quote #(vector each-any)))))) ($sc-dispatch tmp2579 (quote (any . any)))))) ($sc-dispatch tmp2579 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2579 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2579 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2577)))) (lambda (x2594) ((lambda (tmp2595) ((lambda (tmp2596) (if tmp2596 (apply (lambda (_2597 e2598) (quasi2540 e2598 0)) tmp2596) (syntax-violation #f "source expression failed to match any pattern" tmp2595))) ($sc-dispatch tmp2595 (quote (any any))))) x2594))))) +(define include (make-syncase-macro (quote macro) (lambda (x2599) (letrec ((read-file2600 (lambda (fn2601 k2602) (let ((p2603 (open-input-file fn2601))) (let f2604 ((x2605 (read p2603))) (if (eof-object? x2605) (begin (close-input-port p2603) (quote ())) (cons (datum->syntax k2602 x2605) (f2604 (read p2603))))))))) ((lambda (tmp2606) ((lambda (tmp2607) (if tmp2607 (apply (lambda (k2608 filename2609) (let ((fn2610 (syntax->datum filename2609))) ((lambda (tmp2611) ((lambda (tmp2612) (if tmp2612 (apply (lambda (exp2613) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2613)) tmp2612) (syntax-violation #f "source expression failed to match any pattern" tmp2611))) ($sc-dispatch tmp2611 (quote each-any)))) (read-file2600 fn2610 k2608)))) tmp2607) (syntax-violation #f "source expression failed to match any pattern" tmp2606))) ($sc-dispatch tmp2606 (quote (any any))))) x2599))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2615) ((lambda (tmp2616) ((lambda (tmp2617) (if tmp2617 (apply (lambda (_2618 e2619) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2615)) tmp2617) (syntax-violation #f "source expression failed to match any pattern" tmp2616))) ($sc-dispatch tmp2616 (quote (any any))))) x2615)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2620) ((lambda (tmp2621) ((lambda (tmp2622) (if tmp2622 (apply (lambda (_2623 e2624) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2620)) tmp2622) (syntax-violation #f "source expression failed to match any pattern" tmp2621))) ($sc-dispatch tmp2621 (quote (any any))))) x2620)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2625) ((lambda (tmp2626) ((lambda (tmp2627) (if tmp2627 (apply (lambda (_2628 e2629 m12630 m22631) ((lambda (tmp2632) ((lambda (body2633) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2629)) body2633)) tmp2632)) (let f2634 ((clause2635 m12630) (clauses2636 m22631)) (if (null? clauses2636) ((lambda (tmp2638) ((lambda (tmp2639) (if tmp2639 (apply (lambda (e12640 e22641) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12640 e22641))) tmp2639) ((lambda (tmp2643) (if tmp2643 (apply (lambda (k2644 e12645 e22646) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2644)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12645 e22646)))) tmp2643) ((lambda (_2649) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2638))) ($sc-dispatch tmp2638 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2638 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2635) ((lambda (tmp2650) ((lambda (rest2651) ((lambda (tmp2652) ((lambda (tmp2653) (if tmp2653 (apply (lambda (k2654 e12655 e22656) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2654)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12655 e22656)) rest2651)) tmp2653) ((lambda (_2659) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2652))) ($sc-dispatch tmp2652 (quote (each-any any . each-any))))) clause2635)) tmp2650)) (f2634 (car clauses2636) (cdr clauses2636))))))) tmp2627) (syntax-violation #f "source expression failed to match any pattern" tmp2626))) ($sc-dispatch tmp2626 (quote (any any any . each-any))))) x2625)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2660) ((lambda (tmp2661) ((lambda (tmp2662) (if tmp2662 (apply (lambda (_2663 e2664) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2664)) (list (cons _2663 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2664 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2662) (syntax-violation #f "source expression failed to match any pattern" tmp2661))) ($sc-dispatch tmp2661 (quote (any any))))) x2660)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index fa289f365..9329e6fbf 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -22,6 +22,9 @@ ;;; Extracted from Chez Scheme Version 5.9f ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman +;;; Modified by Andy Wingo according to the Git +;;; revision control logs corresponding to this file: 2009. + ;;; Modified by Mikael Djurfeldt according ;;; to the ChangeLog distributed in the same directory as this file: ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24, @@ -85,15 +88,8 @@ ;;; used by expanded code to handle syntax-case matching ;;; The following nonstandard procedures must be provided by the -;;; implementation for this code to run. -;;; -;;; (void) -;;; returns the implementation's cannonical "unspecified value". This -;;; usually works: (define void (lambda () (if #f #f))). -;;; -;;; The following nonstandard procedures must also be provided by the ;;; implementation for this code to run using the standard portable -;;; hooks and output constructors. They are not used by expanded code, +;;; hooks and output constructors. They are not used by expanded code, ;;; and so need be present only at expansion time. ;;; ;;; (eval x) @@ -111,12 +107,6 @@ ;;; ;;; (gensym) ;;; returns a unique symbol each time it's called -;;; -;;; (putprop symbol key value) -;;; (getprop symbol key) -;;; key is always the symbol *sc-expander*; value may be any object. -;;; putprop should associate the given value with the given symbol in -;;; some way that it can be retrieved later with getprop. ;;; When porting to a new Scheme implementation, you should define the ;;; procedures listed above, load the expanded version of psyntax.ss @@ -262,8 +252,6 @@ args)))))) (syntax-case x () ((_ (name id1 ...)) - ;; But here we use and-map, because andmap isn't yet in scope for - ;; syntax. (and-map identifier? (syntax (name id1 ...))) (with-syntax ((constructor (construct-name (syntax name) "make-" (syntax name))) @@ -1020,7 +1008,7 @@ ((_ name) (id? (syntax name)) (values 'define-form (wrap (syntax name) w mod) - (syntax (void)) + (syntax (if #f #f)) empty-wrap s mod)))) ((define-syntax) (syntax-case e () @@ -1429,7 +1417,7 @@ (define chi-void (lambda () - (build-application no-source (build-primref no-source 'void) '()))) + (build-application no-source (build-primref no-source 'if) '(#f #f)))) (define ellipsis? (lambda (x) From 123f8abb2da5ed7b2d8ccd67b3bd3532aa9d257e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 May 2009 10:47:31 +0200 Subject: [PATCH 091/375] replace sc-expand with sc-expand3, removing binding for sc-expand3 * module/ice-9/boot-9.scm (sc-expand3): * module/ice-9/psyntax.scm (sc-expand3): Replace sc-expand with sc-expand3, as expand3 with one argument is the same as sc-expand. * module/ice-9/psyntax-pp.scm: Regenerated. * module/ice-9/compile-psyntax.scm: * module/language/scheme/compile-ghil.scm: Change callers to sc-expand3 to use sc-expand. --- module/ice-9/boot-9.scm | 1 - module/ice-9/compile-psyntax.scm | 2 +- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 8 -------- module/language/scheme/compile-ghil.scm | 2 +- 5 files changed, 13 insertions(+), 22 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 2f39c438b..d8e1267a8 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -215,7 +215,6 @@ (define bound-identifier=? #f) (define free-identifier=? #f) (define sc-expand #f) -(define sc-expand3 #f) ;; $sc-expand is an implementation detail of psyntax. It is used by ;; expanded macros, to dispatch an input against a set of patterns. diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 7091ef9fb..3a8a4fad9 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -11,7 +11,7 @@ (close-port out) (close-port in)) (begin - (write (sc-expand3 x 'c '(compile load eval)) + (write (sc-expand x 'c '(compile load eval)) out) (newline out) (loop (read in)))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 035d1720e..2ad36491f 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*1132 (lambda (f1172 first1171 . rest1170) (or (null? first1171) (if (null? rest1170) (let andmap1173 ((first1174 first1171)) (let ((x1175 (car first1174)) (first1176 (cdr first1174))) (if (null? first1176) (f1172 x1175) (and (f1172 x1175) (andmap1173 first1176))))) (let andmap1177 ((first1178 first1171) (rest1179 rest1170)) (let ((x1180 (car first1178)) (xr1181 (map car rest1179)) (first1182 (cdr first1178)) (rest1183 (map cdr rest1179))) (if (null? first1182) (apply f1172 (cons x1180 xr1181)) (and (apply f1172 (cons x1180 xr1181)) (andmap1177 first1182 rest1183)))))))))) (letrec ((lambda-var-list1265 (lambda (vars1470) (let lvl1471 ((vars1472 vars1470) (ls1473 (quote ())) (w1474 (quote (())))) (cond ((pair? vars1472) (lvl1471 (cdr vars1472) (cons (wrap1244 (car vars1472) w1474 #f) ls1473) w1474)) ((id?1216 vars1472) (cons (wrap1244 vars1472 w1474 #f) ls1473)) ((null? vars1472) ls1473) ((syntax-object?1200 vars1472) (lvl1471 (syntax-object-expression1201 vars1472) ls1473 (join-wraps1235 w1474 (syntax-object-wrap1202 vars1472)))) ((annotation? vars1472) (lvl1471 (annotation-expression vars1472) ls1473 w1474)) (else (cons vars1472 ls1473)))))) (gen-var1264 (lambda (id1475) (let ((id1476 (if (syntax-object?1200 id1475) (syntax-object-expression1201 id1475) id1475))) (if (annotation? id1476) (build-annotated1193 (annotation-source id1476) (gensym (symbol->string (annotation-expression id1476)))) (build-annotated1193 #f (gensym (symbol->string id1476))))))) (strip1263 (lambda (x1477 w1478) (if (memq (quote top) (wrap-marks1219 w1478)) (if (or (annotation? x1477) (and (pair? x1477) (annotation? (car x1477)))) (strip-annotation1262 x1477 #f) x1477) (let f1479 ((x1480 x1477)) (cond ((syntax-object?1200 x1480) (strip1263 (syntax-object-expression1201 x1480) (syntax-object-wrap1202 x1480))) ((pair? x1480) (let ((a1481 (f1479 (car x1480))) (d1482 (f1479 (cdr x1480)))) (if (and (eq? a1481 (car x1480)) (eq? d1482 (cdr x1480))) x1480 (cons a1481 d1482)))) ((vector? x1480) (let ((old1483 (vector->list x1480))) (let ((new1484 (map f1479 old1483))) (if (and-map*1132 eq? old1483 new1484) x1480 (list->vector new1484))))) (else x1480)))))) (strip-annotation1262 (lambda (x1485 parent1486) (cond ((pair? x1485) (let ((new1487 (cons #f #f))) (begin (if parent1486 (set-annotation-stripped! parent1486 new1487)) (set-car! new1487 (strip-annotation1262 (car x1485) #f)) (set-cdr! new1487 (strip-annotation1262 (cdr x1485) #f)) new1487))) ((annotation? x1485) (or (annotation-stripped x1485) (strip-annotation1262 (annotation-expression x1485) x1485))) ((vector? x1485) (let ((new1488 (make-vector (vector-length x1485)))) (begin (if parent1486 (set-annotation-stripped! parent1486 new1488)) (let loop1489 ((i1490 (- (vector-length x1485) 1))) (unless (fx<1188 i1490 0) (vector-set! new1488 i1490 (strip-annotation1262 (vector-ref x1485 i1490) #f)) (loop1489 (fx-1186 i1490 1)))) new1488))) (else x1485)))) (ellipsis?1261 (lambda (x1491) (and (nonsymbol-id?1215 x1491) (free-id=?1239 x1491 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1260 (lambda () (build-annotated1193 #f (cons (build-annotated1193 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer1259 (lambda (expanded1492 mod1493) (let ((p1494 (local-eval-hook1190 expanded1492 mod1493))) (if (procedure? p1494) p1494 (syntax-violation #f "nonprocedure transformer" p1494))))) (chi-local-syntax1258 (lambda (rec?1495 e1496 r1497 w1498 s1499 mod1500 k1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (_1504 id1505 val1506 e11507 e21508) (let ((ids1509 id1505)) (if (not (valid-bound-ids?1241 ids1509)) (syntax-violation #f "duplicate bound keyword" e1496) (let ((labels1511 (gen-labels1222 ids1509))) (let ((new-w1512 (make-binding-wrap1233 ids1509 labels1511 w1498))) (k1501 (cons e11507 e21508) (extend-env1210 labels1511 (let ((w1514 (if rec?1495 new-w1512 w1498)) (trans-r1515 (macros-only-env1212 r1497))) (map (lambda (x1516) (cons (quote macro) (eval-local-transformer1259 (chi1252 x1516 trans-r1515 w1514 mod1500) mod1500))) val1506)) r1497) new-w1512 s1499 mod1500)))))) tmp1503) ((lambda (_1518) (syntax-violation #f "bad local syntax definition" (source-wrap1245 e1496 w1498 s1499 mod1500))) tmp1502))) ($sc-dispatch tmp1502 (quote (any #(each (any any)) any . each-any))))) e1496))) (chi-lambda-clause1257 (lambda (e1519 docstring1520 c1521 r1522 w1523 mod1524 k1525) ((lambda (tmp1526) ((lambda (tmp1527) (if (if tmp1527 (apply (lambda (args1528 doc1529 e11530 e21531) (and (string? (syntax->datum doc1529)) (not docstring1520))) tmp1527) #f) (apply (lambda (args1532 doc1533 e11534 e21535) (chi-lambda-clause1257 e1519 doc1533 (cons args1532 (cons e11534 e21535)) r1522 w1523 mod1524 k1525)) tmp1527) ((lambda (tmp1537) (if tmp1537 (apply (lambda (id1538 e11539 e21540) (let ((ids1541 id1538)) (if (not (valid-bound-ids?1241 ids1541)) (syntax-violation (quote lambda) "invalid parameter list" e1519) (let ((labels1543 (gen-labels1222 ids1541)) (new-vars1544 (map gen-var1264 ids1541))) (k1525 new-vars1544 docstring1520 (chi-body1256 (cons e11539 e21540) e1519 (extend-var-env1211 labels1543 new-vars1544 r1522) (make-binding-wrap1233 ids1541 labels1543 w1523) mod1524)))))) tmp1537) ((lambda (tmp1546) (if tmp1546 (apply (lambda (ids1547 e11548 e21549) (let ((old-ids1550 (lambda-var-list1265 ids1547))) (if (not (valid-bound-ids?1241 old-ids1550)) (syntax-violation (quote lambda) "invalid parameter list" e1519) (let ((labels1551 (gen-labels1222 old-ids1550)) (new-vars1552 (map gen-var1264 old-ids1550))) (k1525 (let f1553 ((ls11554 (cdr new-vars1552)) (ls21555 (car new-vars1552))) (if (null? ls11554) ls21555 (f1553 (cdr ls11554) (cons (car ls11554) ls21555)))) docstring1520 (chi-body1256 (cons e11548 e21549) e1519 (extend-var-env1211 labels1551 new-vars1552 r1522) (make-binding-wrap1233 old-ids1550 labels1551 w1523) mod1524)))))) tmp1546) ((lambda (_1557) (syntax-violation (quote lambda) "bad lambda" e1519)) tmp1526))) ($sc-dispatch tmp1526 (quote (any any . each-any)))))) ($sc-dispatch tmp1526 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1526 (quote (any any any . each-any))))) c1521))) (chi-body1256 (lambda (body1558 outer-form1559 r1560 w1561 mod1562) (let ((r1563 (cons (quote ("placeholder" placeholder)) r1560))) (let ((ribcage1564 (make-ribcage1223 (quote ()) (quote ()) (quote ())))) (let ((w1565 (make-wrap1218 (wrap-marks1219 w1561) (cons ribcage1564 (wrap-subst1220 w1561))))) (let parse1566 ((body1567 (map (lambda (x1573) (cons r1563 (wrap1244 x1573 w1565 mod1562))) body1558)) (ids1568 (quote ())) (labels1569 (quote ())) (vars1570 (quote ())) (vals1571 (quote ())) (bindings1572 (quote ()))) (if (null? body1567) (syntax-violation #f "no expressions in body" outer-form1559) (let ((e1574 (cdar body1567)) (er1575 (caar body1567))) (call-with-values (lambda () (syntax-type1250 e1574 er1575 (quote (())) #f ribcage1564 mod1562)) (lambda (type1576 value1577 e1578 w1579 s1580 mod1581) (let ((t1582 type1576)) (if (memv t1582 (quote (define-form))) (let ((id1583 (wrap1244 value1577 w1579 mod1581)) (label1584 (gen-label1221))) (let ((var1585 (gen-var1264 id1583))) (begin (extend-ribcage!1232 ribcage1564 id1583 label1584) (parse1566 (cdr body1567) (cons id1583 ids1568) (cons label1584 labels1569) (cons var1585 vars1570) (cons (cons er1575 (wrap1244 e1578 w1579 mod1581)) vals1571) (cons (cons (quote lexical) var1585) bindings1572))))) (if (memv t1582 (quote (define-syntax-form))) (let ((id1586 (wrap1244 value1577 w1579 mod1581)) (label1587 (gen-label1221))) (begin (extend-ribcage!1232 ribcage1564 id1586 label1587) (parse1566 (cdr body1567) (cons id1586 ids1568) (cons label1587 labels1569) vars1570 vals1571 (cons (cons (quote macro) (cons er1575 (wrap1244 e1578 w1579 mod1581))) bindings1572)))) (if (memv t1582 (quote (begin-form))) ((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (_1590 e11591) (parse1566 (let f1592 ((forms1593 e11591)) (if (null? forms1593) (cdr body1567) (cons (cons er1575 (wrap1244 (car forms1593) w1579 mod1581)) (f1592 (cdr forms1593))))) ids1568 labels1569 vars1570 vals1571 bindings1572)) tmp1589) (syntax-violation #f "source expression failed to match any pattern" tmp1588))) ($sc-dispatch tmp1588 (quote (any . each-any))))) e1578) (if (memv t1582 (quote (local-syntax-form))) (chi-local-syntax1258 value1577 e1578 er1575 w1579 s1580 mod1581 (lambda (forms1595 er1596 w1597 s1598 mod1599) (parse1566 (let f1600 ((forms1601 forms1595)) (if (null? forms1601) (cdr body1567) (cons (cons er1596 (wrap1244 (car forms1601) w1597 mod1599)) (f1600 (cdr forms1601))))) ids1568 labels1569 vars1570 vals1571 bindings1572))) (if (null? ids1568) (build-sequence1195 #f (map (lambda (x1602) (chi1252 (cdr x1602) (car x1602) (quote (())) mod1581)) (cons (cons er1575 (source-wrap1245 e1578 w1579 s1580 mod1581)) (cdr body1567)))) (begin (if (not (valid-bound-ids?1241 ids1568)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1559)) (let loop1603 ((bs1604 bindings1572) (er-cache1605 #f) (r-cache1606 #f)) (if (not (null? bs1604)) (let ((b1607 (car bs1604))) (if (eq? (car b1607) (quote macro)) (let ((er1608 (cadr b1607))) (let ((r-cache1609 (if (eq? er1608 er-cache1605) r-cache1606 (macros-only-env1212 er1608)))) (begin (set-cdr! b1607 (eval-local-transformer1259 (chi1252 (cddr b1607) r-cache1609 (quote (())) mod1581) mod1581)) (loop1603 (cdr bs1604) er1608 r-cache1609)))) (loop1603 (cdr bs1604) er-cache1605 r-cache1606))))) (set-cdr! r1563 (extend-env1210 labels1569 bindings1572 (cdr r1563))) (build-letrec1198 #f vars1570 (map (lambda (x1610) (chi1252 (cdr x1610) (car x1610) (quote (())) mod1581)) vals1571) (build-sequence1195 #f (map (lambda (x1611) (chi1252 (cdr x1611) (car x1611) (quote (())) mod1581)) (cons (cons er1575 (source-wrap1245 e1578 w1579 s1580 mod1581)) (cdr body1567)))))))))))))))))))))) (chi-macro1255 (lambda (p1612 e1613 r1614 w1615 rib1616 mod1617) (letrec ((rebuild-macro-output1618 (lambda (x1619 m1620) (cond ((pair? x1619) (cons (rebuild-macro-output1618 (car x1619) m1620) (rebuild-macro-output1618 (cdr x1619) m1620))) ((syntax-object?1200 x1619) (let ((w1621 (syntax-object-wrap1202 x1619))) (let ((ms1622 (wrap-marks1219 w1621)) (s1623 (wrap-subst1220 w1621))) (if (and (pair? ms1622) (eq? (car ms1622) #f)) (make-syntax-object1199 (syntax-object-expression1201 x1619) (make-wrap1218 (cdr ms1622) (if rib1616 (cons rib1616 (cdr s1623)) (cdr s1623))) (syntax-object-module1203 x1619)) (make-syntax-object1199 (syntax-object-expression1201 x1619) (make-wrap1218 (cons m1620 ms1622) (if rib1616 (cons rib1616 (cons (quote shift) s1623)) (cons (quote shift) s1623))) (let ((pmod1624 (procedure-module p1612))) (if pmod1624 (cons (quote hygiene) (module-name pmod1624)) (quote (hygiene guile))))))))) ((vector? x1619) (let ((n1625 (vector-length x1619))) (let ((v1626 (make-vector n1625))) (let doloop1627 ((i1628 0)) (if (fx=1187 i1628 n1625) v1626 (begin (vector-set! v1626 i1628 (rebuild-macro-output1618 (vector-ref x1619 i1628) m1620)) (doloop1627 (fx+1185 i1628 1)))))))) ((symbol? x1619) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1245 e1613 w1615 s mod1617) x1619)) (else x1619))))) (rebuild-macro-output1618 (p1612 (wrap1244 e1613 (anti-mark1231 w1615) mod1617)) (string #\m))))) (chi-application1254 (lambda (x1629 e1630 r1631 w1632 s1633 mod1634) ((lambda (tmp1635) ((lambda (tmp1636) (if tmp1636 (apply (lambda (e01637 e11638) (build-annotated1193 s1633 (cons x1629 (map (lambda (e1639) (chi1252 e1639 r1631 w1632 mod1634)) e11638)))) tmp1636) (syntax-violation #f "source expression failed to match any pattern" tmp1635))) ($sc-dispatch tmp1635 (quote (any . each-any))))) e1630))) (chi-expr1253 (lambda (type1641 value1642 e1643 r1644 w1645 s1646 mod1647) (let ((t1648 type1641)) (if (memv t1648 (quote (lexical))) (build-annotated1193 s1646 value1642) (if (memv t1648 (quote (core external-macro))) (value1642 e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (module-ref))) (call-with-values (lambda () (value1642 e1643)) (lambda (id1649 mod1650) (build-annotated1193 s1646 (if mod1650 (make-module-ref (cdr mod1650) id1649 (car mod1650)) (make-module-ref mod1650 id1649 (quote bare)))))) (if (memv t1648 (quote (lexical-call))) (chi-application1254 (build-annotated1193 (source-annotation1207 (car e1643)) value1642) e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (global-call))) (chi-application1254 (build-annotated1193 (source-annotation1207 (car e1643)) (if (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647) (make-module-ref (cdr (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647)) value1642 (car (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647))) (make-module-ref (if (syntax-object?1200 (car e1643)) (syntax-object-module1203 (car e1643)) mod1647) value1642 (quote bare)))) e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (constant))) (build-data1194 s1646 (strip1263 (source-wrap1245 e1643 w1645 s1646 mod1647) (quote (())))) (if (memv t1648 (quote (global))) (build-annotated1193 s1646 (if mod1647 (make-module-ref (cdr mod1647) value1642 (car mod1647)) (make-module-ref mod1647 value1642 (quote bare)))) (if (memv t1648 (quote (call))) (chi-application1254 (chi1252 (car e1643) r1644 w1645 mod1647) e1643 r1644 w1645 s1646 mod1647) (if (memv t1648 (quote (begin-form))) ((lambda (tmp1651) ((lambda (tmp1652) (if tmp1652 (apply (lambda (_1653 e11654 e21655) (chi-sequence1246 (cons e11654 e21655) r1644 w1645 s1646 mod1647)) tmp1652) (syntax-violation #f "source expression failed to match any pattern" tmp1651))) ($sc-dispatch tmp1651 (quote (any any . each-any))))) e1643) (if (memv t1648 (quote (local-syntax-form))) (chi-local-syntax1258 value1642 e1643 r1644 w1645 s1646 mod1647 chi-sequence1246) (if (memv t1648 (quote (eval-when-form))) ((lambda (tmp1657) ((lambda (tmp1658) (if tmp1658 (apply (lambda (_1659 x1660 e11661 e21662) (let ((when-list1663 (chi-when-list1249 e1643 x1660 w1645))) (if (memq (quote eval) when-list1663) (chi-sequence1246 (cons e11661 e21662) r1644 w1645 s1646 mod1647) (chi-void1260)))) tmp1658) (syntax-violation #f "source expression failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote (any each-any any . each-any))))) e1643) (if (memv t1648 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1643 (wrap1244 value1642 w1645 mod1647)) (if (memv t1648 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1245 e1643 w1645 s1646 mod1647)) (if (memv t1648 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1245 e1643 w1645 s1646 mod1647)) (syntax-violation #f "unexpected syntax" (source-wrap1245 e1643 w1645 s1646 mod1647))))))))))))))))))) (chi1252 (lambda (e1666 r1667 w1668 mod1669) (call-with-values (lambda () (syntax-type1250 e1666 r1667 w1668 #f #f mod1669)) (lambda (type1670 value1671 e1672 w1673 s1674 mod1675) (chi-expr1253 type1670 value1671 e1672 r1667 w1673 s1674 mod1675))))) (chi-top1251 (lambda (e1676 r1677 w1678 m1679 esew1680 mod1681) (call-with-values (lambda () (syntax-type1250 e1676 r1677 w1678 #f #f mod1681)) (lambda (type1689 value1690 e1691 w1692 s1693 mod1694) (let ((t1695 type1689)) (if (memv t1695 (quote (begin-form))) ((lambda (tmp1696) ((lambda (tmp1697) (if tmp1697 (apply (lambda (_1698) (chi-void1260)) tmp1697) ((lambda (tmp1699) (if tmp1699 (apply (lambda (_1700 e11701 e21702) (chi-top-sequence1247 (cons e11701 e21702) r1677 w1692 s1693 m1679 esew1680 mod1694)) tmp1699) (syntax-violation #f "source expression failed to match any pattern" tmp1696))) ($sc-dispatch tmp1696 (quote (any any . each-any)))))) ($sc-dispatch tmp1696 (quote (any))))) e1691) (if (memv t1695 (quote (local-syntax-form))) (chi-local-syntax1258 value1690 e1691 r1677 w1692 s1693 mod1694 (lambda (body1704 r1705 w1706 s1707 mod1708) (chi-top-sequence1247 body1704 r1705 w1706 s1707 m1679 esew1680 mod1708))) (if (memv t1695 (quote (eval-when-form))) ((lambda (tmp1709) ((lambda (tmp1710) (if tmp1710 (apply (lambda (_1711 x1712 e11713 e21714) (let ((when-list1715 (chi-when-list1249 e1691 x1712 w1692)) (body1716 (cons e11713 e21714))) (cond ((eq? m1679 (quote e)) (if (memq (quote eval) when-list1715) (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote e) (quote (eval)) mod1694) (chi-void1260))) ((memq (quote load) when-list1715) (if (or (memq (quote compile) when-list1715) (and (eq? m1679 (quote c&e)) (memq (quote eval) when-list1715))) (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote c&e) (quote (compile load)) mod1694) (if (memq m1679 (quote (c c&e))) (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote c) (quote (load)) mod1694) (chi-void1260)))) ((or (memq (quote compile) when-list1715) (and (eq? m1679 (quote c&e)) (memq (quote eval) when-list1715))) (top-level-eval-hook1189 (chi-top-sequence1247 body1716 r1677 w1692 s1693 (quote e) (quote (eval)) mod1694) mod1694) (chi-void1260)) (else (chi-void1260))))) tmp1710) (syntax-violation #f "source expression failed to match any pattern" tmp1709))) ($sc-dispatch tmp1709 (quote (any each-any any . each-any))))) e1691) (if (memv t1695 (quote (define-syntax-form))) (let ((n1719 (id-var-name1238 value1690 w1692)) (r1720 (macros-only-env1212 r1677))) (let ((t1721 m1679)) (if (memv t1721 (quote (c))) (if (memq (quote compile) esew1680) (let ((e1722 (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)))) (begin (top-level-eval-hook1189 e1722 mod1694) (if (memq (quote load) esew1680) e1722 (chi-void1260)))) (if (memq (quote load) esew1680) (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)) (chi-void1260))) (if (memv t1721 (quote (c&e))) (let ((e1723 (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)))) (begin (top-level-eval-hook1189 e1723 mod1694) e1723)) (begin (if (memq (quote eval) esew1680) (top-level-eval-hook1189 (chi-install-global1248 n1719 (chi1252 e1691 r1720 w1692 mod1694)) mod1694)) (chi-void1260)))))) (if (memv t1695 (quote (define-form))) (let ((n1724 (id-var-name1238 value1690 w1692))) (let ((type1725 (binding-type1208 (lookup1213 n1724 r1677 mod1694)))) (let ((t1726 type1725)) (if (memv t1726 (quote (global core macro module-ref))) (let ((x1727 (build-annotated1193 s1693 (list (quote define) n1724 (chi1252 e1691 r1677 w1692 mod1694))))) (begin (if (eq? m1679 (quote c&e)) (top-level-eval-hook1189 x1727 mod1694)) x1727)) (if (memv t1726 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1691 (wrap1244 value1690 w1692 mod1694)) (syntax-violation #f "cannot define keyword at top level" e1691 (wrap1244 value1690 w1692 mod1694))))))) (let ((x1728 (chi-expr1253 type1689 value1690 e1691 r1677 w1692 s1693 mod1694))) (begin (if (eq? m1679 (quote c&e)) (top-level-eval-hook1189 x1728 mod1694)) x1728)))))))))))) (syntax-type1250 (lambda (e1729 r1730 w1731 s1732 rib1733 mod1734) (cond ((symbol? e1729) (let ((n1735 (id-var-name1238 e1729 w1731))) (let ((b1736 (lookup1213 n1735 r1730 mod1734))) (let ((type1737 (binding-type1208 b1736))) (let ((t1738 type1737)) (if (memv t1738 (quote (lexical))) (values type1737 (binding-value1209 b1736) e1729 w1731 s1732 mod1734) (if (memv t1738 (quote (global))) (values type1737 n1735 e1729 w1731 s1732 mod1734) (if (memv t1738 (quote (macro))) (syntax-type1250 (chi-macro1255 (binding-value1209 b1736) e1729 r1730 w1731 rib1733 mod1734) r1730 (quote (())) s1732 rib1733 mod1734) (values type1737 (binding-value1209 b1736) e1729 w1731 s1732 mod1734))))))))) ((pair? e1729) (let ((first1739 (car e1729))) (if (id?1216 first1739) (let ((n1740 (id-var-name1238 first1739 w1731))) (let ((b1741 (lookup1213 n1740 r1730 (or (and (syntax-object?1200 first1739) (syntax-object-module1203 first1739)) mod1734)))) (let ((type1742 (binding-type1208 b1741))) (let ((t1743 type1742)) (if (memv t1743 (quote (lexical))) (values (quote lexical-call) (binding-value1209 b1741) e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (global))) (values (quote global-call) n1740 e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (macro))) (syntax-type1250 (chi-macro1255 (binding-value1209 b1741) e1729 r1730 w1731 rib1733 mod1734) r1730 (quote (())) s1732 rib1733 mod1734) (if (memv t1743 (quote (core external-macro module-ref))) (values type1742 (binding-value1209 b1741) e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1209 b1741) e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (begin))) (values (quote begin-form) #f e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (eval-when))) (values (quote eval-when-form) #f e1729 w1731 s1732 mod1734) (if (memv t1743 (quote (define))) ((lambda (tmp1744) ((lambda (tmp1745) (if (if tmp1745 (apply (lambda (_1746 name1747 val1748) (id?1216 name1747)) tmp1745) #f) (apply (lambda (_1749 name1750 val1751) (values (quote define-form) name1750 val1751 w1731 s1732 mod1734)) tmp1745) ((lambda (tmp1752) (if (if tmp1752 (apply (lambda (_1753 name1754 args1755 e11756 e21757) (and (id?1216 name1754) (valid-bound-ids?1241 (lambda-var-list1265 args1755)))) tmp1752) #f) (apply (lambda (_1758 name1759 args1760 e11761 e21762) (values (quote define-form) (wrap1244 name1759 w1731 mod1734) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1244 (cons args1760 (cons e11761 e21762)) w1731 mod1734)) (quote (())) s1732 mod1734)) tmp1752) ((lambda (tmp1764) (if (if tmp1764 (apply (lambda (_1765 name1766) (id?1216 name1766)) tmp1764) #f) (apply (lambda (_1767 name1768) (values (quote define-form) (wrap1244 name1768 w1731 mod1734) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1732 mod1734)) tmp1764) (syntax-violation #f "source expression failed to match any pattern" tmp1744))) ($sc-dispatch tmp1744 (quote (any any)))))) ($sc-dispatch tmp1744 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1744 (quote (any any any))))) e1729) (if (memv t1743 (quote (define-syntax))) ((lambda (tmp1769) ((lambda (tmp1770) (if (if tmp1770 (apply (lambda (_1771 name1772 val1773) (id?1216 name1772)) tmp1770) #f) (apply (lambda (_1774 name1775 val1776) (values (quote define-syntax-form) name1775 val1776 w1731 s1732 mod1734)) tmp1770) (syntax-violation #f "source expression failed to match any pattern" tmp1769))) ($sc-dispatch tmp1769 (quote (any any any))))) e1729) (values (quote call) #f e1729 w1731 s1732 mod1734)))))))))))))) (values (quote call) #f e1729 w1731 s1732 mod1734)))) ((syntax-object?1200 e1729) (syntax-type1250 (syntax-object-expression1201 e1729) r1730 (join-wraps1235 w1731 (syntax-object-wrap1202 e1729)) #f rib1733 (or (syntax-object-module1203 e1729) mod1734))) ((annotation? e1729) (syntax-type1250 (annotation-expression e1729) r1730 w1731 (annotation-source e1729) rib1733 mod1734)) ((self-evaluating? e1729) (values (quote constant) #f e1729 w1731 s1732 mod1734)) (else (values (quote other) #f e1729 w1731 s1732 mod1734))))) (chi-when-list1249 (lambda (e1777 when-list1778 w1779) (let f1780 ((when-list1781 when-list1778) (situations1782 (quote ()))) (if (null? when-list1781) situations1782 (f1780 (cdr when-list1781) (cons (let ((x1783 (car when-list1781))) (cond ((free-id=?1239 x1783 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1239 x1783 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1239 x1783 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1777 (wrap1244 x1783 w1779 #f))))) situations1782)))))) (chi-install-global1248 (lambda (name1784 e1785) (build-annotated1193 #f (list (build-annotated1193 #f (quote define)) name1784 (if (let ((v1786 (module-variable (current-module) name1784))) (and v1786 (variable-bound? v1786) (macro? (variable-ref v1786)) (not (eq? (macro-type (variable-ref v1786)) (quote syncase-macro))))) (build-annotated1193 #f (list (build-annotated1193 #f (quote make-extended-syncase-macro)) (build-annotated1193 #f (list (build-annotated1193 #f (quote module-ref)) (build-annotated1193 #f (quote (current-module))) (build-data1194 #f name1784))) (build-data1194 #f (quote macro)) e1785)) (build-annotated1193 #f (list (build-annotated1193 #f (quote make-syncase-macro)) (build-data1194 #f (quote macro)) e1785))))))) (chi-top-sequence1247 (lambda (body1787 r1788 w1789 s1790 m1791 esew1792 mod1793) (build-sequence1195 s1790 (let dobody1794 ((body1795 body1787) (r1796 r1788) (w1797 w1789) (m1798 m1791) (esew1799 esew1792) (mod1800 mod1793)) (if (null? body1795) (quote ()) (let ((first1801 (chi-top1251 (car body1795) r1796 w1797 m1798 esew1799 mod1800))) (cons first1801 (dobody1794 (cdr body1795) r1796 w1797 m1798 esew1799 mod1800)))))))) (chi-sequence1246 (lambda (body1802 r1803 w1804 s1805 mod1806) (build-sequence1195 s1805 (let dobody1807 ((body1808 body1802) (r1809 r1803) (w1810 w1804) (mod1811 mod1806)) (if (null? body1808) (quote ()) (let ((first1812 (chi1252 (car body1808) r1809 w1810 mod1811))) (cons first1812 (dobody1807 (cdr body1808) r1809 w1810 mod1811)))))))) (source-wrap1245 (lambda (x1813 w1814 s1815 defmod1816) (wrap1244 (if s1815 (make-annotation x1813 s1815 #f) x1813) w1814 defmod1816))) (wrap1244 (lambda (x1817 w1818 defmod1819) (cond ((and (null? (wrap-marks1219 w1818)) (null? (wrap-subst1220 w1818))) x1817) ((syntax-object?1200 x1817) (make-syntax-object1199 (syntax-object-expression1201 x1817) (join-wraps1235 w1818 (syntax-object-wrap1202 x1817)) (syntax-object-module1203 x1817))) ((null? x1817) x1817) (else (make-syntax-object1199 x1817 w1818 defmod1819))))) (bound-id-member?1243 (lambda (x1820 list1821) (and (not (null? list1821)) (or (bound-id=?1240 x1820 (car list1821)) (bound-id-member?1243 x1820 (cdr list1821)))))) (distinct-bound-ids?1242 (lambda (ids1822) (let distinct?1823 ((ids1824 ids1822)) (or (null? ids1824) (and (not (bound-id-member?1243 (car ids1824) (cdr ids1824))) (distinct?1823 (cdr ids1824))))))) (valid-bound-ids?1241 (lambda (ids1825) (and (let all-ids?1826 ((ids1827 ids1825)) (or (null? ids1827) (and (id?1216 (car ids1827)) (all-ids?1826 (cdr ids1827))))) (distinct-bound-ids?1242 ids1825)))) (bound-id=?1240 (lambda (i1828 j1829) (if (and (syntax-object?1200 i1828) (syntax-object?1200 j1829)) (and (eq? (let ((e1830 (syntax-object-expression1201 i1828))) (if (annotation? e1830) (annotation-expression e1830) e1830)) (let ((e1831 (syntax-object-expression1201 j1829))) (if (annotation? e1831) (annotation-expression e1831) e1831))) (same-marks?1237 (wrap-marks1219 (syntax-object-wrap1202 i1828)) (wrap-marks1219 (syntax-object-wrap1202 j1829)))) (eq? (let ((e1832 i1828)) (if (annotation? e1832) (annotation-expression e1832) e1832)) (let ((e1833 j1829)) (if (annotation? e1833) (annotation-expression e1833) e1833)))))) (free-id=?1239 (lambda (i1834 j1835) (and (eq? (let ((x1836 i1834)) (let ((e1837 (if (syntax-object?1200 x1836) (syntax-object-expression1201 x1836) x1836))) (if (annotation? e1837) (annotation-expression e1837) e1837))) (let ((x1838 j1835)) (let ((e1839 (if (syntax-object?1200 x1838) (syntax-object-expression1201 x1838) x1838))) (if (annotation? e1839) (annotation-expression e1839) e1839)))) (eq? (id-var-name1238 i1834 (quote (()))) (id-var-name1238 j1835 (quote (()))))))) (id-var-name1238 (lambda (id1840 w1841) (letrec ((search-vector-rib1844 (lambda (sym1850 subst1851 marks1852 symnames1853 ribcage1854) (let ((n1855 (vector-length symnames1853))) (let f1856 ((i1857 0)) (cond ((fx=1187 i1857 n1855) (search1842 sym1850 (cdr subst1851) marks1852)) ((and (eq? (vector-ref symnames1853 i1857) sym1850) (same-marks?1237 marks1852 (vector-ref (ribcage-marks1226 ribcage1854) i1857))) (values (vector-ref (ribcage-labels1227 ribcage1854) i1857) marks1852)) (else (f1856 (fx+1185 i1857 1)))))))) (search-list-rib1843 (lambda (sym1858 subst1859 marks1860 symnames1861 ribcage1862) (let f1863 ((symnames1864 symnames1861) (i1865 0)) (cond ((null? symnames1864) (search1842 sym1858 (cdr subst1859) marks1860)) ((and (eq? (car symnames1864) sym1858) (same-marks?1237 marks1860 (list-ref (ribcage-marks1226 ribcage1862) i1865))) (values (list-ref (ribcage-labels1227 ribcage1862) i1865) marks1860)) (else (f1863 (cdr symnames1864) (fx+1185 i1865 1))))))) (search1842 (lambda (sym1866 subst1867 marks1868) (if (null? subst1867) (values #f marks1868) (let ((fst1869 (car subst1867))) (if (eq? fst1869 (quote shift)) (search1842 sym1866 (cdr subst1867) (cdr marks1868)) (let ((symnames1870 (ribcage-symnames1225 fst1869))) (if (vector? symnames1870) (search-vector-rib1844 sym1866 subst1867 marks1868 symnames1870 fst1869) (search-list-rib1843 sym1866 subst1867 marks1868 symnames1870 fst1869))))))))) (cond ((symbol? id1840) (or (call-with-values (lambda () (search1842 id1840 (wrap-subst1220 w1841) (wrap-marks1219 w1841))) (lambda (x1872 . ignore1871) x1872)) id1840)) ((syntax-object?1200 id1840) (let ((id1873 (let ((e1875 (syntax-object-expression1201 id1840))) (if (annotation? e1875) (annotation-expression e1875) e1875))) (w11874 (syntax-object-wrap1202 id1840))) (let ((marks1876 (join-marks1236 (wrap-marks1219 w1841) (wrap-marks1219 w11874)))) (call-with-values (lambda () (search1842 id1873 (wrap-subst1220 w1841) marks1876)) (lambda (new-id1877 marks1878) (or new-id1877 (call-with-values (lambda () (search1842 id1873 (wrap-subst1220 w11874) marks1878)) (lambda (x1880 . ignore1879) x1880)) id1873)))))) ((annotation? id1840) (let ((id1881 (let ((e1882 id1840)) (if (annotation? e1882) (annotation-expression e1882) e1882)))) (or (call-with-values (lambda () (search1842 id1881 (wrap-subst1220 w1841) (wrap-marks1219 w1841))) (lambda (x1884 . ignore1883) x1884)) id1881))) (else (syntax-violation (quote id-var-name) "invalid id" id1840)))))) (same-marks?1237 (lambda (x1885 y1886) (or (eq? x1885 y1886) (and (not (null? x1885)) (not (null? y1886)) (eq? (car x1885) (car y1886)) (same-marks?1237 (cdr x1885) (cdr y1886)))))) (join-marks1236 (lambda (m11887 m21888) (smart-append1234 m11887 m21888))) (join-wraps1235 (lambda (w11889 w21890) (let ((m11891 (wrap-marks1219 w11889)) (s11892 (wrap-subst1220 w11889))) (if (null? m11891) (if (null? s11892) w21890 (make-wrap1218 (wrap-marks1219 w21890) (smart-append1234 s11892 (wrap-subst1220 w21890)))) (make-wrap1218 (smart-append1234 m11891 (wrap-marks1219 w21890)) (smart-append1234 s11892 (wrap-subst1220 w21890))))))) (smart-append1234 (lambda (m11893 m21894) (if (null? m21894) m11893 (append m11893 m21894)))) (make-binding-wrap1233 (lambda (ids1895 labels1896 w1897) (if (null? ids1895) w1897 (make-wrap1218 (wrap-marks1219 w1897) (cons (let ((labelvec1898 (list->vector labels1896))) (let ((n1899 (vector-length labelvec1898))) (let ((symnamevec1900 (make-vector n1899)) (marksvec1901 (make-vector n1899))) (begin (let f1902 ((ids1903 ids1895) (i1904 0)) (if (not (null? ids1903)) (call-with-values (lambda () (id-sym-name&marks1217 (car ids1903) w1897)) (lambda (symname1905 marks1906) (begin (vector-set! symnamevec1900 i1904 symname1905) (vector-set! marksvec1901 i1904 marks1906) (f1902 (cdr ids1903) (fx+1185 i1904 1))))))) (make-ribcage1223 symnamevec1900 marksvec1901 labelvec1898))))) (wrap-subst1220 w1897)))))) (extend-ribcage!1232 (lambda (ribcage1907 id1908 label1909) (begin (set-ribcage-symnames!1228 ribcage1907 (cons (let ((e1910 (syntax-object-expression1201 id1908))) (if (annotation? e1910) (annotation-expression e1910) e1910)) (ribcage-symnames1225 ribcage1907))) (set-ribcage-marks!1229 ribcage1907 (cons (wrap-marks1219 (syntax-object-wrap1202 id1908)) (ribcage-marks1226 ribcage1907))) (set-ribcage-labels!1230 ribcage1907 (cons label1909 (ribcage-labels1227 ribcage1907)))))) (anti-mark1231 (lambda (w1911) (make-wrap1218 (cons #f (wrap-marks1219 w1911)) (cons (quote shift) (wrap-subst1220 w1911))))) (set-ribcage-labels!1230 (lambda (x1912 update1913) (vector-set! x1912 3 update1913))) (set-ribcage-marks!1229 (lambda (x1914 update1915) (vector-set! x1914 2 update1915))) (set-ribcage-symnames!1228 (lambda (x1916 update1917) (vector-set! x1916 1 update1917))) (ribcage-labels1227 (lambda (x1918) (vector-ref x1918 3))) (ribcage-marks1226 (lambda (x1919) (vector-ref x1919 2))) (ribcage-symnames1225 (lambda (x1920) (vector-ref x1920 1))) (ribcage?1224 (lambda (x1921) (and (vector? x1921) (= (vector-length x1921) 4) (eq? (vector-ref x1921 0) (quote ribcage))))) (make-ribcage1223 (lambda (symnames1922 marks1923 labels1924) (vector (quote ribcage) symnames1922 marks1923 labels1924))) (gen-labels1222 (lambda (ls1925) (if (null? ls1925) (quote ()) (cons (gen-label1221) (gen-labels1222 (cdr ls1925)))))) (gen-label1221 (lambda () (string #\i))) (wrap-subst1220 cdr) (wrap-marks1219 car) (make-wrap1218 cons) (id-sym-name&marks1217 (lambda (x1926 w1927) (if (syntax-object?1200 x1926) (values (let ((e1928 (syntax-object-expression1201 x1926))) (if (annotation? e1928) (annotation-expression e1928) e1928)) (join-marks1236 (wrap-marks1219 w1927) (wrap-marks1219 (syntax-object-wrap1202 x1926)))) (values (let ((e1929 x1926)) (if (annotation? e1929) (annotation-expression e1929) e1929)) (wrap-marks1219 w1927))))) (id?1216 (lambda (x1930) (cond ((symbol? x1930) #t) ((syntax-object?1200 x1930) (symbol? (let ((e1931 (syntax-object-expression1201 x1930))) (if (annotation? e1931) (annotation-expression e1931) e1931)))) ((annotation? x1930) (symbol? (annotation-expression x1930))) (else #f)))) (nonsymbol-id?1215 (lambda (x1932) (and (syntax-object?1200 x1932) (symbol? (let ((e1933 (syntax-object-expression1201 x1932))) (if (annotation? e1933) (annotation-expression e1933) e1933)))))) (global-extend1214 (lambda (type1934 sym1935 val1936) (put-global-definition-hook1191 sym1935 type1934 val1936))) (lookup1213 (lambda (x1937 r1938 mod1939) (cond ((assq x1937 r1938) => cdr) ((symbol? x1937) (or (get-global-definition-hook1192 x1937 mod1939) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1212 (lambda (r1940) (if (null? r1940) (quote ()) (let ((a1941 (car r1940))) (if (eq? (cadr a1941) (quote macro)) (cons a1941 (macros-only-env1212 (cdr r1940))) (macros-only-env1212 (cdr r1940))))))) (extend-var-env1211 (lambda (labels1942 vars1943 r1944) (if (null? labels1942) r1944 (extend-var-env1211 (cdr labels1942) (cdr vars1943) (cons (cons (car labels1942) (cons (quote lexical) (car vars1943))) r1944))))) (extend-env1210 (lambda (labels1945 bindings1946 r1947) (if (null? labels1945) r1947 (extend-env1210 (cdr labels1945) (cdr bindings1946) (cons (cons (car labels1945) (car bindings1946)) r1947))))) (binding-value1209 cdr) (binding-type1208 car) (source-annotation1207 (lambda (x1948) (cond ((annotation? x1948) (annotation-source x1948)) ((syntax-object?1200 x1948) (source-annotation1207 (syntax-object-expression1201 x1948))) (else #f)))) (set-syntax-object-module!1206 (lambda (x1949 update1950) (vector-set! x1949 3 update1950))) (set-syntax-object-wrap!1205 (lambda (x1951 update1952) (vector-set! x1951 2 update1952))) (set-syntax-object-expression!1204 (lambda (x1953 update1954) (vector-set! x1953 1 update1954))) (syntax-object-module1203 (lambda (x1955) (vector-ref x1955 3))) (syntax-object-wrap1202 (lambda (x1956) (vector-ref x1956 2))) (syntax-object-expression1201 (lambda (x1957) (vector-ref x1957 1))) (syntax-object?1200 (lambda (x1958) (and (vector? x1958) (= (vector-length x1958) 4) (eq? (vector-ref x1958 0) (quote syntax-object))))) (make-syntax-object1199 (lambda (expression1959 wrap1960 module1961) (vector (quote syntax-object) expression1959 wrap1960 module1961))) (build-letrec1198 (lambda (src1962 vars1963 val-exps1964 body-exp1965) (if (null? vars1963) (build-annotated1193 src1962 body-exp1965) (build-annotated1193 src1962 (list (quote letrec) (map list vars1963 val-exps1964) body-exp1965))))) (build-named-let1197 (lambda (src1966 vars1967 val-exps1968 body-exp1969) (if (null? vars1967) (build-annotated1193 src1966 body-exp1969) (build-annotated1193 src1966 (list (quote let) (car vars1967) (map list (cdr vars1967) val-exps1968) body-exp1969))))) (build-let1196 (lambda (src1970 vars1971 val-exps1972 body-exp1973) (if (null? vars1971) (build-annotated1193 src1970 body-exp1973) (build-annotated1193 src1970 (list (quote let) (map list vars1971 val-exps1972) body-exp1973))))) (build-sequence1195 (lambda (src1974 exps1975) (if (null? (cdr exps1975)) (build-annotated1193 src1974 (car exps1975)) (build-annotated1193 src1974 (cons (quote begin) exps1975))))) (build-data1194 (lambda (src1976 exp1977) (if (and (self-evaluating? exp1977) (not (vector? exp1977))) (build-annotated1193 src1976 exp1977) (build-annotated1193 src1976 (list (quote quote) exp1977))))) (build-annotated1193 (lambda (src1978 exp1979) (if (and src1978 (not (annotation? exp1979))) (make-annotation exp1979 src1978 #t) exp1979))) (get-global-definition-hook1192 (lambda (symbol1980 module1981) (begin (if (and (not module1981) (current-module)) (warn "module system is booted, we should have a module" symbol1980)) (let ((v1982 (module-variable (if module1981 (resolve-module (cdr module1981)) (current-module)) symbol1980))) (and v1982 (variable-bound? v1982) (let ((val1983 (variable-ref v1982))) (and (macro? val1983) (syncase-macro-type val1983) (cons (syncase-macro-type val1983) (syncase-macro-binding val1983))))))))) (put-global-definition-hook1191 (lambda (symbol1984 type1985 val1986) (let ((existing1987 (let ((v1988 (module-variable (current-module) symbol1984))) (and v1988 (variable-bound? v1988) (let ((val1989 (variable-ref v1988))) (and (macro? val1989) (not (syncase-macro-type val1989)) val1989)))))) (module-define! (current-module) symbol1984 (if existing1987 (make-extended-syncase-macro existing1987 type1985 val1986) (make-syncase-macro type1985 val1986)))))) (local-eval-hook1190 (lambda (x1990 mod1991) (primitive-eval (list noexpand1184 x1990)))) (top-level-eval-hook1189 (lambda (x1992 mod1993) (primitive-eval (list noexpand1184 x1992)))) (fx<1188 <) (fx=1187 =) (fx-1186 -) (fx+1185 +) (noexpand1184 "noexpand")) (begin (global-extend1214 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1214 (quote local-syntax) (quote let-syntax) #f) (global-extend1214 (quote core) (quote fluid-let-syntax) (lambda (e1994 r1995 w1996 s1997 mod1998) ((lambda (tmp1999) ((lambda (tmp2000) (if (if tmp2000 (apply (lambda (_2001 var2002 val2003 e12004 e22005) (valid-bound-ids?1241 var2002)) tmp2000) #f) (apply (lambda (_2007 var2008 val2009 e12010 e22011) (let ((names2012 (map (lambda (x2013) (id-var-name1238 x2013 w1996)) var2008))) (begin (for-each (lambda (id2015 n2016) (let ((t2017 (binding-type1208 (lookup1213 n2016 r1995 mod1998)))) (if (memv t2017 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1994 (source-wrap1245 id2015 w1996 s1997 mod1998))))) var2008 names2012) (chi-body1256 (cons e12010 e22011) (source-wrap1245 e1994 w1996 s1997 mod1998) (extend-env1210 names2012 (let ((trans-r2020 (macros-only-env1212 r1995))) (map (lambda (x2021) (cons (quote macro) (eval-local-transformer1259 (chi1252 x2021 trans-r2020 w1996 mod1998) mod1998))) val2009)) r1995) w1996 mod1998)))) tmp2000) ((lambda (_2023) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1245 e1994 w1996 s1997 mod1998))) tmp1999))) ($sc-dispatch tmp1999 (quote (any #(each (any any)) any . each-any))))) e1994))) (global-extend1214 (quote core) (quote quote) (lambda (e2024 r2025 w2026 s2027 mod2028) ((lambda (tmp2029) ((lambda (tmp2030) (if tmp2030 (apply (lambda (_2031 e2032) (build-data1194 s2027 (strip1263 e2032 w2026))) tmp2030) ((lambda (_2033) (syntax-violation (quote quote) "bad syntax" (source-wrap1245 e2024 w2026 s2027 mod2028))) tmp2029))) ($sc-dispatch tmp2029 (quote (any any))))) e2024))) (global-extend1214 (quote core) (quote syntax) (letrec ((regen2041 (lambda (x2042) (let ((t2043 (car x2042))) (if (memv t2043 (quote (ref))) (build-annotated1193 #f (cadr x2042)) (if (memv t2043 (quote (primitive))) (build-annotated1193 #f (cadr x2042)) (if (memv t2043 (quote (quote))) (build-data1194 #f (cadr x2042)) (if (memv t2043 (quote (lambda))) (build-annotated1193 #f (list (quote lambda) (cadr x2042) (regen2041 (caddr x2042)))) (if (memv t2043 (quote (map))) (let ((ls2044 (map regen2041 (cdr x2042)))) (build-annotated1193 #f (cons (if (fx=1187 (length ls2044) 2) (build-annotated1193 #f (quote map)) (build-annotated1193 #f (quote map))) ls2044))) (build-annotated1193 #f (cons (build-annotated1193 #f (car x2042)) (map regen2041 (cdr x2042)))))))))))) (gen-vector2040 (lambda (x2045) (cond ((eq? (car x2045) (quote list)) (cons (quote vector) (cdr x2045))) ((eq? (car x2045) (quote quote)) (list (quote quote) (list->vector (cadr x2045)))) (else (list (quote list->vector) x2045))))) (gen-append2039 (lambda (x2046 y2047) (if (equal? y2047 (quote (quote ()))) x2046 (list (quote append) x2046 y2047)))) (gen-cons2038 (lambda (x2048 y2049) (let ((t2050 (car y2049))) (if (memv t2050 (quote (quote))) (if (eq? (car x2048) (quote quote)) (list (quote quote) (cons (cadr x2048) (cadr y2049))) (if (eq? (cadr y2049) (quote ())) (list (quote list) x2048) (list (quote cons) x2048 y2049))) (if (memv t2050 (quote (list))) (cons (quote list) (cons x2048 (cdr y2049))) (list (quote cons) x2048 y2049)))))) (gen-map2037 (lambda (e2051 map-env2052) (let ((formals2053 (map cdr map-env2052)) (actuals2054 (map (lambda (x2055) (list (quote ref) (car x2055))) map-env2052))) (cond ((eq? (car e2051) (quote ref)) (car actuals2054)) ((and-map (lambda (x2056) (and (eq? (car x2056) (quote ref)) (memq (cadr x2056) formals2053))) (cdr e2051)) (cons (quote map) (cons (list (quote primitive) (car e2051)) (map (let ((r2057 (map cons formals2053 actuals2054))) (lambda (x2058) (cdr (assq (cadr x2058) r2057)))) (cdr e2051))))) (else (cons (quote map) (cons (list (quote lambda) formals2053 e2051) actuals2054))))))) (gen-mappend2036 (lambda (e2059 map-env2060) (list (quote apply) (quote (primitive append)) (gen-map2037 e2059 map-env2060)))) (gen-ref2035 (lambda (src2061 var2062 level2063 maps2064) (if (fx=1187 level2063 0) (values var2062 maps2064) (if (null? maps2064) (syntax-violation (quote syntax) "missing ellipsis" src2061) (call-with-values (lambda () (gen-ref2035 src2061 var2062 (fx-1186 level2063 1) (cdr maps2064))) (lambda (outer-var2065 outer-maps2066) (let ((b2067 (assq outer-var2065 (car maps2064)))) (if b2067 (values (cdr b2067) maps2064) (let ((inner-var2068 (gen-var1264 (quote tmp)))) (values inner-var2068 (cons (cons (cons outer-var2065 inner-var2068) (car maps2064)) outer-maps2066))))))))))) (gen-syntax2034 (lambda (src2069 e2070 r2071 maps2072 ellipsis?2073 mod2074) (if (id?1216 e2070) (let ((label2075 (id-var-name1238 e2070 (quote (()))))) (let ((b2076 (lookup1213 label2075 r2071 mod2074))) (if (eq? (binding-type1208 b2076) (quote syntax)) (call-with-values (lambda () (let ((var.lev2077 (binding-value1209 b2076))) (gen-ref2035 src2069 (car var.lev2077) (cdr var.lev2077) maps2072))) (lambda (var2078 maps2079) (values (list (quote ref) var2078) maps2079))) (if (ellipsis?2073 e2070) (syntax-violation (quote syntax) "misplaced ellipsis" src2069) (values (list (quote quote) e2070) maps2072))))) ((lambda (tmp2080) ((lambda (tmp2081) (if (if tmp2081 (apply (lambda (dots2082 e2083) (ellipsis?2073 dots2082)) tmp2081) #f) (apply (lambda (dots2084 e2085) (gen-syntax2034 src2069 e2085 r2071 maps2072 (lambda (x2086) #f) mod2074)) tmp2081) ((lambda (tmp2087) (if (if tmp2087 (apply (lambda (x2088 dots2089 y2090) (ellipsis?2073 dots2089)) tmp2087) #f) (apply (lambda (x2091 dots2092 y2093) (let f2094 ((y2095 y2093) (k2096 (lambda (maps2097) (call-with-values (lambda () (gen-syntax2034 src2069 x2091 r2071 (cons (quote ()) maps2097) ellipsis?2073 mod2074)) (lambda (x2098 maps2099) (if (null? (car maps2099)) (syntax-violation (quote syntax) "extra ellipsis" src2069) (values (gen-map2037 x2098 (car maps2099)) (cdr maps2099)))))))) ((lambda (tmp2100) ((lambda (tmp2101) (if (if tmp2101 (apply (lambda (dots2102 y2103) (ellipsis?2073 dots2102)) tmp2101) #f) (apply (lambda (dots2104 y2105) (f2094 y2105 (lambda (maps2106) (call-with-values (lambda () (k2096 (cons (quote ()) maps2106))) (lambda (x2107 maps2108) (if (null? (car maps2108)) (syntax-violation (quote syntax) "extra ellipsis" src2069) (values (gen-mappend2036 x2107 (car maps2108)) (cdr maps2108)))))))) tmp2101) ((lambda (_2109) (call-with-values (lambda () (gen-syntax2034 src2069 y2095 r2071 maps2072 ellipsis?2073 mod2074)) (lambda (y2110 maps2111) (call-with-values (lambda () (k2096 maps2111)) (lambda (x2112 maps2113) (values (gen-append2039 x2112 y2110) maps2113)))))) tmp2100))) ($sc-dispatch tmp2100 (quote (any . any))))) y2095))) tmp2087) ((lambda (tmp2114) (if tmp2114 (apply (lambda (x2115 y2116) (call-with-values (lambda () (gen-syntax2034 src2069 x2115 r2071 maps2072 ellipsis?2073 mod2074)) (lambda (x2117 maps2118) (call-with-values (lambda () (gen-syntax2034 src2069 y2116 r2071 maps2118 ellipsis?2073 mod2074)) (lambda (y2119 maps2120) (values (gen-cons2038 x2117 y2119) maps2120)))))) tmp2114) ((lambda (tmp2121) (if tmp2121 (apply (lambda (e12122 e22123) (call-with-values (lambda () (gen-syntax2034 src2069 (cons e12122 e22123) r2071 maps2072 ellipsis?2073 mod2074)) (lambda (e2125 maps2126) (values (gen-vector2040 e2125) maps2126)))) tmp2121) ((lambda (_2127) (values (list (quote quote) e2070) maps2072)) tmp2080))) ($sc-dispatch tmp2080 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2080 (quote (any . any)))))) ($sc-dispatch tmp2080 (quote (any any . any)))))) ($sc-dispatch tmp2080 (quote (any any))))) e2070))))) (lambda (e2128 r2129 w2130 s2131 mod2132) (let ((e2133 (source-wrap1245 e2128 w2130 s2131 mod2132))) ((lambda (tmp2134) ((lambda (tmp2135) (if tmp2135 (apply (lambda (_2136 x2137) (call-with-values (lambda () (gen-syntax2034 e2133 x2137 r2129 (quote ()) ellipsis?1261 mod2132)) (lambda (e2138 maps2139) (regen2041 e2138)))) tmp2135) ((lambda (_2140) (syntax-violation (quote syntax) "bad `syntax' form" e2133)) tmp2134))) ($sc-dispatch tmp2134 (quote (any any))))) e2133))))) (global-extend1214 (quote core) (quote lambda) (lambda (e2141 r2142 w2143 s2144 mod2145) ((lambda (tmp2146) ((lambda (tmp2147) (if tmp2147 (apply (lambda (_2148 c2149) (chi-lambda-clause1257 (source-wrap1245 e2141 w2143 s2144 mod2145) #f c2149 r2142 w2143 mod2145 (lambda (vars2150 docstring2151 body2152) (build-annotated1193 s2144 (cons (quote lambda) (cons vars2150 (append (if docstring2151 (list docstring2151) (quote ())) (list body2152)))))))) tmp2147) (syntax-violation #f "source expression failed to match any pattern" tmp2146))) ($sc-dispatch tmp2146 (quote (any . any))))) e2141))) (global-extend1214 (quote core) (quote let) (letrec ((chi-let2153 (lambda (e2154 r2155 w2156 s2157 mod2158 constructor2159 ids2160 vals2161 exps2162) (if (not (valid-bound-ids?1241 ids2160)) (syntax-violation (quote let) "duplicate bound variable" e2154) (let ((labels2163 (gen-labels1222 ids2160)) (new-vars2164 (map gen-var1264 ids2160))) (let ((nw2165 (make-binding-wrap1233 ids2160 labels2163 w2156)) (nr2166 (extend-var-env1211 labels2163 new-vars2164 r2155))) (constructor2159 s2157 new-vars2164 (map (lambda (x2167) (chi1252 x2167 r2155 w2156 mod2158)) vals2161) (chi-body1256 exps2162 (source-wrap1245 e2154 nw2165 s2157 mod2158) nr2166 nw2165 mod2158)))))))) (lambda (e2168 r2169 w2170 s2171 mod2172) ((lambda (tmp2173) ((lambda (tmp2174) (if tmp2174 (apply (lambda (_2175 id2176 val2177 e12178 e22179) (chi-let2153 e2168 r2169 w2170 s2171 mod2172 build-let1196 id2176 val2177 (cons e12178 e22179))) tmp2174) ((lambda (tmp2183) (if (if tmp2183 (apply (lambda (_2184 f2185 id2186 val2187 e12188 e22189) (id?1216 f2185)) tmp2183) #f) (apply (lambda (_2190 f2191 id2192 val2193 e12194 e22195) (chi-let2153 e2168 r2169 w2170 s2171 mod2172 build-named-let1197 (cons f2191 id2192) val2193 (cons e12194 e22195))) tmp2183) ((lambda (_2199) (syntax-violation (quote let) "bad let" (source-wrap1245 e2168 w2170 s2171 mod2172))) tmp2173))) ($sc-dispatch tmp2173 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2173 (quote (any #(each (any any)) any . each-any))))) e2168)))) (global-extend1214 (quote core) (quote letrec) (lambda (e2200 r2201 w2202 s2203 mod2204) ((lambda (tmp2205) ((lambda (tmp2206) (if tmp2206 (apply (lambda (_2207 id2208 val2209 e12210 e22211) (let ((ids2212 id2208)) (if (not (valid-bound-ids?1241 ids2212)) (syntax-violation (quote letrec) "duplicate bound variable" e2200) (let ((labels2214 (gen-labels1222 ids2212)) (new-vars2215 (map gen-var1264 ids2212))) (let ((w2216 (make-binding-wrap1233 ids2212 labels2214 w2202)) (r2217 (extend-var-env1211 labels2214 new-vars2215 r2201))) (build-letrec1198 s2203 new-vars2215 (map (lambda (x2218) (chi1252 x2218 r2217 w2216 mod2204)) val2209) (chi-body1256 (cons e12210 e22211) (source-wrap1245 e2200 w2216 s2203 mod2204) r2217 w2216 mod2204))))))) tmp2206) ((lambda (_2221) (syntax-violation (quote letrec) "bad letrec" (source-wrap1245 e2200 w2202 s2203 mod2204))) tmp2205))) ($sc-dispatch tmp2205 (quote (any #(each (any any)) any . each-any))))) e2200))) (global-extend1214 (quote core) (quote set!) (lambda (e2222 r2223 w2224 s2225 mod2226) ((lambda (tmp2227) ((lambda (tmp2228) (if (if tmp2228 (apply (lambda (_2229 id2230 val2231) (id?1216 id2230)) tmp2228) #f) (apply (lambda (_2232 id2233 val2234) (let ((val2235 (chi1252 val2234 r2223 w2224 mod2226)) (n2236 (id-var-name1238 id2233 w2224))) (let ((b2237 (lookup1213 n2236 r2223 mod2226))) (let ((t2238 (binding-type1208 b2237))) (if (memv t2238 (quote (lexical))) (build-annotated1193 s2225 (list (quote set!) (binding-value1209 b2237) val2235)) (if (memv t2238 (quote (global))) (build-annotated1193 s2225 (list (quote set!) (if mod2226 (make-module-ref (cdr mod2226) n2236 (car mod2226)) (make-module-ref mod2226 n2236 (quote bare))) val2235)) (if (memv t2238 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1244 id2233 w2224 mod2226)) (syntax-violation (quote set!) "bad set!" (source-wrap1245 e2222 w2224 s2225 mod2226))))))))) tmp2228) ((lambda (tmp2239) (if tmp2239 (apply (lambda (_2240 head2241 tail2242 val2243) (call-with-values (lambda () (syntax-type1250 head2241 r2223 (quote (())) #f #f mod2226)) (lambda (type2244 value2245 ee2246 ww2247 ss2248 modmod2249) (let ((t2250 type2244)) (if (memv t2250 (quote (module-ref))) (let ((val2251 (chi1252 val2243 r2223 w2224 mod2226))) (call-with-values (lambda () (value2245 (cons head2241 tail2242))) (lambda (id2253 mod2254) (build-annotated1193 s2225 (list (quote set!) (if mod2254 (make-module-ref (cdr mod2254) id2253 (car mod2254)) (make-module-ref mod2254 id2253 (quote bare))) val2251))))) (build-annotated1193 s2225 (cons (chi1252 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2241) r2223 w2224 mod2226) (map (lambda (e2255) (chi1252 e2255 r2223 w2224 mod2226)) (append tail2242 (list val2243)))))))))) tmp2239) ((lambda (_2257) (syntax-violation (quote set!) "bad set!" (source-wrap1245 e2222 w2224 s2225 mod2226))) tmp2227))) ($sc-dispatch tmp2227 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2227 (quote (any any any))))) e2222))) (global-extend1214 (quote module-ref) (quote @) (lambda (e2258) ((lambda (tmp2259) ((lambda (tmp2260) (if (if tmp2260 (apply (lambda (_2261 mod2262 id2263) (and (and-map id?1216 mod2262) (id?1216 id2263))) tmp2260) #f) (apply (lambda (_2265 mod2266 id2267) (values (syntax->datum id2267) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2266)))) tmp2260) (syntax-violation #f "source expression failed to match any pattern" tmp2259))) ($sc-dispatch tmp2259 (quote (any each-any any))))) e2258))) (global-extend1214 (quote module-ref) (quote @@) (lambda (e2269) ((lambda (tmp2270) ((lambda (tmp2271) (if (if tmp2271 (apply (lambda (_2272 mod2273 id2274) (and (and-map id?1216 mod2273) (id?1216 id2274))) tmp2271) #f) (apply (lambda (_2276 mod2277 id2278) (values (syntax->datum id2278) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2277)))) tmp2271) (syntax-violation #f "source expression failed to match any pattern" tmp2270))) ($sc-dispatch tmp2270 (quote (any each-any any))))) e2269))) (global-extend1214 (quote begin) (quote begin) (quote ())) (global-extend1214 (quote define) (quote define) (quote ())) (global-extend1214 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1214 (quote eval-when) (quote eval-when) (quote ())) (global-extend1214 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2283 (lambda (x2284 keys2285 clauses2286 r2287 mod2288) (if (null? clauses2286) (build-annotated1193 #f (list (build-annotated1193 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2284)) ((lambda (tmp2289) ((lambda (tmp2290) (if tmp2290 (apply (lambda (pat2291 exp2292) (if (and (id?1216 pat2291) (and-map (lambda (x2293) (not (free-id=?1239 pat2291 x2293))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2285))) (let ((labels2294 (list (gen-label1221))) (var2295 (gen-var1264 pat2291))) (build-annotated1193 #f (list (build-annotated1193 #f (list (quote lambda) (list var2295) (chi1252 exp2292 (extend-env1210 labels2294 (list (cons (quote syntax) (cons var2295 0))) r2287) (make-binding-wrap1233 (list pat2291) labels2294 (quote (()))) mod2288))) x2284))) (gen-clause2282 x2284 keys2285 (cdr clauses2286) r2287 pat2291 #t exp2292 mod2288))) tmp2290) ((lambda (tmp2296) (if tmp2296 (apply (lambda (pat2297 fender2298 exp2299) (gen-clause2282 x2284 keys2285 (cdr clauses2286) r2287 pat2297 fender2298 exp2299 mod2288)) tmp2296) ((lambda (_2300) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2286))) tmp2289))) ($sc-dispatch tmp2289 (quote (any any any)))))) ($sc-dispatch tmp2289 (quote (any any))))) (car clauses2286))))) (gen-clause2282 (lambda (x2301 keys2302 clauses2303 r2304 pat2305 fender2306 exp2307 mod2308) (call-with-values (lambda () (convert-pattern2280 pat2305 keys2302)) (lambda (p2309 pvars2310) (cond ((not (distinct-bound-ids?1242 (map car pvars2310))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2305)) ((not (and-map (lambda (x2311) (not (ellipsis?1261 (car x2311)))) pvars2310)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2305)) (else (let ((y2312 (gen-var1264 (quote tmp)))) (build-annotated1193 #f (list (build-annotated1193 #f (list (quote lambda) (list y2312) (let ((y2313 (build-annotated1193 #f y2312))) (build-annotated1193 #f (list (quote if) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda () y2313) tmp2315) ((lambda (_2316) (build-annotated1193 #f (list (quote if) y2313 (build-dispatch-call2281 pvars2310 fender2306 y2313 r2304 mod2308) (build-data1194 #f #f)))) tmp2314))) ($sc-dispatch tmp2314 (quote #(atom #t))))) fender2306) (build-dispatch-call2281 pvars2310 exp2307 y2313 r2304 mod2308) (gen-syntax-case2283 x2301 keys2302 clauses2303 r2304 mod2308)))))) (if (eq? p2309 (quote any)) (build-annotated1193 #f (list (build-annotated1193 #f (quote list)) x2301)) (build-annotated1193 #f (list (build-annotated1193 #f (quote $sc-dispatch)) x2301 (build-data1194 #f p2309))))))))))))) (build-dispatch-call2281 (lambda (pvars2317 exp2318 y2319 r2320 mod2321) (let ((ids2322 (map car pvars2317)) (levels2323 (map cdr pvars2317))) (let ((labels2324 (gen-labels1222 ids2322)) (new-vars2325 (map gen-var1264 ids2322))) (build-annotated1193 #f (list (build-annotated1193 #f (quote apply)) (build-annotated1193 #f (list (quote lambda) new-vars2325 (chi1252 exp2318 (extend-env1210 labels2324 (map (lambda (var2326 level2327) (cons (quote syntax) (cons var2326 level2327))) new-vars2325 (map cdr pvars2317)) r2320) (make-binding-wrap1233 ids2322 labels2324 (quote (()))) mod2321))) y2319)))))) (convert-pattern2280 (lambda (pattern2328 keys2329) (let cvt2330 ((p2331 pattern2328) (n2332 0) (ids2333 (quote ()))) (if (id?1216 p2331) (if (bound-id-member?1243 p2331 keys2329) (values (vector (quote free-id) p2331) ids2333) (values (quote any) (cons (cons p2331 n2332) ids2333))) ((lambda (tmp2334) ((lambda (tmp2335) (if (if tmp2335 (apply (lambda (x2336 dots2337) (ellipsis?1261 dots2337)) tmp2335) #f) (apply (lambda (x2338 dots2339) (call-with-values (lambda () (cvt2330 x2338 (fx+1185 n2332 1) ids2333)) (lambda (p2340 ids2341) (values (if (eq? p2340 (quote any)) (quote each-any) (vector (quote each) p2340)) ids2341)))) tmp2335) ((lambda (tmp2342) (if tmp2342 (apply (lambda (x2343 y2344) (call-with-values (lambda () (cvt2330 y2344 n2332 ids2333)) (lambda (y2345 ids2346) (call-with-values (lambda () (cvt2330 x2343 n2332 ids2346)) (lambda (x2347 ids2348) (values (cons x2347 y2345) ids2348)))))) tmp2342) ((lambda (tmp2349) (if tmp2349 (apply (lambda () (values (quote ()) ids2333)) tmp2349) ((lambda (tmp2350) (if tmp2350 (apply (lambda (x2351) (call-with-values (lambda () (cvt2330 x2351 n2332 ids2333)) (lambda (p2353 ids2354) (values (vector (quote vector) p2353) ids2354)))) tmp2350) ((lambda (x2355) (values (vector (quote atom) (strip1263 p2331 (quote (())))) ids2333)) tmp2334))) ($sc-dispatch tmp2334 (quote #(vector each-any)))))) ($sc-dispatch tmp2334 (quote ()))))) ($sc-dispatch tmp2334 (quote (any . any)))))) ($sc-dispatch tmp2334 (quote (any any))))) p2331)))))) (lambda (e2356 r2357 w2358 s2359 mod2360) (let ((e2361 (source-wrap1245 e2356 w2358 s2359 mod2360))) ((lambda (tmp2362) ((lambda (tmp2363) (if tmp2363 (apply (lambda (_2364 val2365 key2366 m2367) (if (and-map (lambda (x2368) (and (id?1216 x2368) (not (ellipsis?1261 x2368)))) key2366) (let ((x2370 (gen-var1264 (quote tmp)))) (build-annotated1193 s2359 (list (build-annotated1193 #f (list (quote lambda) (list x2370) (gen-syntax-case2283 (build-annotated1193 #f x2370) key2366 m2367 r2357 mod2360))) (chi1252 val2365 r2357 (quote (())) mod2360)))) (syntax-violation (quote syntax-case) "invalid literals list" e2361))) tmp2363) (syntax-violation #f "source expression failed to match any pattern" tmp2362))) ($sc-dispatch tmp2362 (quote (any any each-any . each-any))))) e2361))))) (set! sc-expand (let ((m2373 (quote e)) (esew2374 (quote (eval)))) (lambda (x2375) (if (and (pair? x2375) (equal? (car x2375) noexpand1184)) (cadr x2375) (chi-top1251 x2375 (quote ()) (quote ((top))) m2373 esew2374 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2376 (quote e)) (esew2377 (quote (eval)))) (lambda (x2379 . rest2378) (if (and (pair? x2379) (equal? (car x2379) noexpand1184)) (cadr x2379) (chi-top1251 x2379 (quote ()) (quote ((top))) (if (null? rest2378) m2376 (car rest2378)) (if (or (null? rest2378) (null? (cdr rest2378))) esew2377 (cadr rest2378)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2380) (nonsymbol-id?1215 x2380))) (set! datum->syntax (lambda (id2381 datum2382) (make-syntax-object1199 datum2382 (syntax-object-wrap1202 id2381) #f))) (set! syntax->datum (lambda (x2383) (strip1263 x2383 (quote (()))))) (set! generate-temporaries (lambda (ls2384) (begin (let ((x2385 ls2384)) (if (not (list? x2385)) (syntax-violation (quote generate-temporaries) "invalid argument" x2385))) (map (lambda (x2386) (wrap1244 (gensym) (quote ((top))) #f)) ls2384)))) (set! free-identifier=? (lambda (x2387 y2388) (begin (let ((x2389 x2387)) (if (not (nonsymbol-id?1215 x2389)) (syntax-violation (quote free-identifier=?) "invalid argument" x2389))) (let ((x2390 y2388)) (if (not (nonsymbol-id?1215 x2390)) (syntax-violation (quote free-identifier=?) "invalid argument" x2390))) (free-id=?1239 x2387 y2388)))) (set! bound-identifier=? (lambda (x2391 y2392) (begin (let ((x2393 x2391)) (if (not (nonsymbol-id?1215 x2393)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2393))) (let ((x2394 y2392)) (if (not (nonsymbol-id?1215 x2394)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2394))) (bound-id=?1240 x2391 y2392)))) (set! syntax-violation (lambda (who2398 message2397 form2396 . subform2395) (begin (let ((x2399 who2398)) (if (not ((lambda (x2400) (or (not x2400) (string? x2400) (symbol? x2400))) x2399)) (syntax-violation (quote syntax-violation) "invalid argument" x2399))) (let ((x2401 message2397)) (if (not (string? x2401)) (syntax-violation (quote syntax-violation) "invalid argument" x2401))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2398 "~a: " "") "~a " (if (null? subform2395) "in ~a" "in subform `~s' of `~s'")) (let ((tail2402 (cons message2397 (map (lambda (x2403) (strip1263 x2403 (quote (())))) (append subform2395 (list form2396)))))) (if who2398 (cons who2398 tail2402) tail2402)) #f)))) (letrec ((match2408 (lambda (e2409 p2410 w2411 r2412 mod2413) (cond ((not r2412) #f) ((eq? p2410 (quote any)) (cons (wrap1244 e2409 w2411 mod2413) r2412)) ((syntax-object?1200 e2409) (match*2407 (let ((e2414 (syntax-object-expression1201 e2409))) (if (annotation? e2414) (annotation-expression e2414) e2414)) p2410 (join-wraps1235 w2411 (syntax-object-wrap1202 e2409)) r2412 (syntax-object-module1203 e2409))) (else (match*2407 (let ((e2415 e2409)) (if (annotation? e2415) (annotation-expression e2415) e2415)) p2410 w2411 r2412 mod2413))))) (match*2407 (lambda (e2416 p2417 w2418 r2419 mod2420) (cond ((null? p2417) (and (null? e2416) r2419)) ((pair? p2417) (and (pair? e2416) (match2408 (car e2416) (car p2417) w2418 (match2408 (cdr e2416) (cdr p2417) w2418 r2419 mod2420) mod2420))) ((eq? p2417 (quote each-any)) (let ((l2421 (match-each-any2405 e2416 w2418 mod2420))) (and l2421 (cons l2421 r2419)))) (else (let ((t2422 (vector-ref p2417 0))) (if (memv t2422 (quote (each))) (if (null? e2416) (match-empty2406 (vector-ref p2417 1) r2419) (let ((l2423 (match-each2404 e2416 (vector-ref p2417 1) w2418 mod2420))) (and l2423 (let collect2424 ((l2425 l2423)) (if (null? (car l2425)) r2419 (cons (map car l2425) (collect2424 (map cdr l2425)))))))) (if (memv t2422 (quote (free-id))) (and (id?1216 e2416) (free-id=?1239 (wrap1244 e2416 w2418 mod2420) (vector-ref p2417 1)) r2419) (if (memv t2422 (quote (atom))) (and (equal? (vector-ref p2417 1) (strip1263 e2416 w2418)) r2419) (if (memv t2422 (quote (vector))) (and (vector? e2416) (match2408 (vector->list e2416) (vector-ref p2417 1) w2418 r2419 mod2420))))))))))) (match-empty2406 (lambda (p2426 r2427) (cond ((null? p2426) r2427) ((eq? p2426 (quote any)) (cons (quote ()) r2427)) ((pair? p2426) (match-empty2406 (car p2426) (match-empty2406 (cdr p2426) r2427))) ((eq? p2426 (quote each-any)) (cons (quote ()) r2427)) (else (let ((t2428 (vector-ref p2426 0))) (if (memv t2428 (quote (each))) (match-empty2406 (vector-ref p2426 1) r2427) (if (memv t2428 (quote (free-id atom))) r2427 (if (memv t2428 (quote (vector))) (match-empty2406 (vector-ref p2426 1) r2427))))))))) (match-each-any2405 (lambda (e2429 w2430 mod2431) (cond ((annotation? e2429) (match-each-any2405 (annotation-expression e2429) w2430 mod2431)) ((pair? e2429) (let ((l2432 (match-each-any2405 (cdr e2429) w2430 mod2431))) (and l2432 (cons (wrap1244 (car e2429) w2430 mod2431) l2432)))) ((null? e2429) (quote ())) ((syntax-object?1200 e2429) (match-each-any2405 (syntax-object-expression1201 e2429) (join-wraps1235 w2430 (syntax-object-wrap1202 e2429)) mod2431)) (else #f)))) (match-each2404 (lambda (e2433 p2434 w2435 mod2436) (cond ((annotation? e2433) (match-each2404 (annotation-expression e2433) p2434 w2435 mod2436)) ((pair? e2433) (let ((first2437 (match2408 (car e2433) p2434 w2435 (quote ()) mod2436))) (and first2437 (let ((rest2438 (match-each2404 (cdr e2433) p2434 w2435 mod2436))) (and rest2438 (cons first2437 rest2438)))))) ((null? e2433) (quote ())) ((syntax-object?1200 e2433) (match-each2404 (syntax-object-expression1201 e2433) p2434 (join-wraps1235 w2435 (syntax-object-wrap1202 e2433)) (syntax-object-module1203 e2433))) (else #f))))) (set! $sc-dispatch (lambda (e2439 p2440) (cond ((eq? p2440 (quote any)) (list e2439)) ((syntax-object?1200 e2439) (match*2407 (let ((e2441 (syntax-object-expression1201 e2439))) (if (annotation? e2441) (annotation-expression e2441) e2441)) p2440 (syntax-object-wrap1202 e2439) (quote ()) (syntax-object-module1203 e2439))) (else (match*2407 (let ((e2442 e2439)) (if (annotation? e2442) (annotation-expression e2442) e2442)) p2440 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x2443) ((lambda (tmp2444) ((lambda (tmp2445) (if tmp2445 (apply (lambda (_2446 e12447 e22448) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12447 e22448))) tmp2445) ((lambda (tmp2450) (if tmp2450 (apply (lambda (_2451 out2452 in2453 e12454 e22455) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2453 (quote ()) (list out2452 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12454 e22455))))) tmp2450) ((lambda (tmp2457) (if tmp2457 (apply (lambda (_2458 out2459 in2460 e12461 e22462) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2460) (quote ()) (list out2459 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12461 e22462))))) tmp2457) (syntax-violation #f "source expression failed to match any pattern" tmp2444))) ($sc-dispatch tmp2444 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2444 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2444 (quote (any () any . each-any))))) x2443)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda (_2469 k2470 keyword2471 pattern2472 template2473) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2470 (map (lambda (tmp2476 tmp2475) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2475) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2476))) template2473 pattern2472)))))) tmp2468) (syntax-violation #f "source expression failed to match any pattern" tmp2467))) ($sc-dispatch tmp2467 (quote (any each-any . #(each ((any . any) any))))))) x2466)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2477) ((lambda (tmp2478) ((lambda (tmp2479) (if (if tmp2479 (apply (lambda (let*2480 x2481 v2482 e12483 e22484) (and-map identifier? x2481)) tmp2479) #f) (apply (lambda (let*2486 x2487 v2488 e12489 e22490) (let f2491 ((bindings2492 (map list x2487 v2488))) (if (null? bindings2492) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12489 e22490))) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (body2498 binding2499) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2499) body2498)) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) ($sc-dispatch tmp2496 (quote (any any))))) (list (f2491 (cdr bindings2492)) (car bindings2492)))))) tmp2479) (syntax-violation #f "source expression failed to match any pattern" tmp2478))) ($sc-dispatch tmp2478 (quote (any #(each (any any)) any . each-any))))) x2477)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2500) ((lambda (tmp2501) ((lambda (tmp2502) (if tmp2502 (apply (lambda (_2503 var2504 init2505 step2506 e02507 e12508 c2509) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (step2512) ((lambda (tmp2513) ((lambda (tmp2514) (if tmp2514 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2514) ((lambda (tmp2519) (if tmp2519 (apply (lambda (e12520 e22521) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2504 init2505) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02507 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12520 e22521)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2509 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2512))))))) tmp2519) (syntax-violation #f "source expression failed to match any pattern" tmp2513))) ($sc-dispatch tmp2513 (quote (any . each-any)))))) ($sc-dispatch tmp2513 (quote ())))) e12508)) tmp2511) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote each-any)))) (map (lambda (v2528 s2529) ((lambda (tmp2530) ((lambda (tmp2531) (if tmp2531 (apply (lambda () v2528) tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (e2533) e2533) tmp2532) ((lambda (_2534) (syntax-violation (quote do) "bad step expression" orig-x2500 s2529)) tmp2530))) ($sc-dispatch tmp2530 (quote (any)))))) ($sc-dispatch tmp2530 (quote ())))) s2529)) var2504 step2506))) tmp2502) (syntax-violation #f "source expression failed to match any pattern" tmp2501))) ($sc-dispatch tmp2501 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2500)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2537 (lambda (x2541 y2542) ((lambda (tmp2543) ((lambda (tmp2544) (if tmp2544 (apply (lambda (x2545 y2546) ((lambda (tmp2547) ((lambda (tmp2548) (if tmp2548 (apply (lambda (dy2549) ((lambda (tmp2550) ((lambda (tmp2551) (if tmp2551 (apply (lambda (dx2552) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2552 dy2549))) tmp2551) ((lambda (_2553) (if (null? dy2549) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546))) tmp2550))) ($sc-dispatch tmp2550 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2545)) tmp2548) ((lambda (tmp2554) (if tmp2554 (apply (lambda (stuff2555) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2545 stuff2555))) tmp2554) ((lambda (else2556) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2545 y2546)) tmp2547))) ($sc-dispatch tmp2547 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2547 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2546)) tmp2544) (syntax-violation #f "source expression failed to match any pattern" tmp2543))) ($sc-dispatch tmp2543 (quote (any any))))) (list x2541 y2542)))) (quasiappend2538 (lambda (x2557 y2558) ((lambda (tmp2559) ((lambda (tmp2560) (if tmp2560 (apply (lambda (x2561 y2562) ((lambda (tmp2563) ((lambda (tmp2564) (if tmp2564 (apply (lambda () x2561) tmp2564) ((lambda (_2565) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2561 y2562)) tmp2563))) ($sc-dispatch tmp2563 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2562)) tmp2560) (syntax-violation #f "source expression failed to match any pattern" tmp2559))) ($sc-dispatch tmp2559 (quote (any any))))) (list x2557 y2558)))) (quasivector2539 (lambda (x2566) ((lambda (tmp2567) ((lambda (x2568) ((lambda (tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (x2571) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2571))) tmp2570) ((lambda (tmp2573) (if tmp2573 (apply (lambda (x2574) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2574)) tmp2573) ((lambda (_2576) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2568)) tmp2569))) ($sc-dispatch tmp2569 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2569 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2568)) tmp2567)) x2566))) (quasi2540 (lambda (p2577 lev2578) ((lambda (tmp2579) ((lambda (tmp2580) (if tmp2580 (apply (lambda (p2581) (if (= lev2578 0) p2581 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2581) (- lev2578 1))))) tmp2580) ((lambda (tmp2582) (if tmp2582 (apply (lambda (p2583 q2584) (if (= lev2578 0) (quasiappend2538 p2583 (quasi2540 q2584 lev2578)) (quasicons2537 (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2583) (- lev2578 1))) (quasi2540 q2584 lev2578)))) tmp2582) ((lambda (tmp2585) (if tmp2585 (apply (lambda (p2586) (quasicons2537 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2540 (list p2586) (+ lev2578 1)))) tmp2585) ((lambda (tmp2587) (if tmp2587 (apply (lambda (p2588 q2589) (quasicons2537 (quasi2540 p2588 lev2578) (quasi2540 q2589 lev2578))) tmp2587) ((lambda (tmp2590) (if tmp2590 (apply (lambda (x2591) (quasivector2539 (quasi2540 x2591 lev2578))) tmp2590) ((lambda (p2593) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2593)) tmp2579))) ($sc-dispatch tmp2579 (quote #(vector each-any)))))) ($sc-dispatch tmp2579 (quote (any . any)))))) ($sc-dispatch tmp2579 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2579 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2579 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2577)))) (lambda (x2594) ((lambda (tmp2595) ((lambda (tmp2596) (if tmp2596 (apply (lambda (_2597 e2598) (quasi2540 e2598 0)) tmp2596) (syntax-violation #f "source expression failed to match any pattern" tmp2595))) ($sc-dispatch tmp2595 (quote (any any))))) x2594))))) -(define include (make-syncase-macro (quote macro) (lambda (x2599) (letrec ((read-file2600 (lambda (fn2601 k2602) (let ((p2603 (open-input-file fn2601))) (let f2604 ((x2605 (read p2603))) (if (eof-object? x2605) (begin (close-input-port p2603) (quote ())) (cons (datum->syntax k2602 x2605) (f2604 (read p2603))))))))) ((lambda (tmp2606) ((lambda (tmp2607) (if tmp2607 (apply (lambda (k2608 filename2609) (let ((fn2610 (syntax->datum filename2609))) ((lambda (tmp2611) ((lambda (tmp2612) (if tmp2612 (apply (lambda (exp2613) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2613)) tmp2612) (syntax-violation #f "source expression failed to match any pattern" tmp2611))) ($sc-dispatch tmp2611 (quote each-any)))) (read-file2600 fn2610 k2608)))) tmp2607) (syntax-violation #f "source expression failed to match any pattern" tmp2606))) ($sc-dispatch tmp2606 (quote (any any))))) x2599))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x2615) ((lambda (tmp2616) ((lambda (tmp2617) (if tmp2617 (apply (lambda (_2618 e2619) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2615)) tmp2617) (syntax-violation #f "source expression failed to match any pattern" tmp2616))) ($sc-dispatch tmp2616 (quote (any any))))) x2615)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2620) ((lambda (tmp2621) ((lambda (tmp2622) (if tmp2622 (apply (lambda (_2623 e2624) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2620)) tmp2622) (syntax-violation #f "source expression failed to match any pattern" tmp2621))) ($sc-dispatch tmp2621 (quote (any any))))) x2620)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2625) ((lambda (tmp2626) ((lambda (tmp2627) (if tmp2627 (apply (lambda (_2628 e2629 m12630 m22631) ((lambda (tmp2632) ((lambda (body2633) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2629)) body2633)) tmp2632)) (let f2634 ((clause2635 m12630) (clauses2636 m22631)) (if (null? clauses2636) ((lambda (tmp2638) ((lambda (tmp2639) (if tmp2639 (apply (lambda (e12640 e22641) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12640 e22641))) tmp2639) ((lambda (tmp2643) (if tmp2643 (apply (lambda (k2644 e12645 e22646) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2644)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12645 e22646)))) tmp2643) ((lambda (_2649) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2638))) ($sc-dispatch tmp2638 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2638 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2635) ((lambda (tmp2650) ((lambda (rest2651) ((lambda (tmp2652) ((lambda (tmp2653) (if tmp2653 (apply (lambda (k2654 e12655 e22656) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2654)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12655 e22656)) rest2651)) tmp2653) ((lambda (_2659) (syntax-violation (quote case) "bad clause" x2625 clause2635)) tmp2652))) ($sc-dispatch tmp2652 (quote (each-any any . each-any))))) clause2635)) tmp2650)) (f2634 (car clauses2636) (cdr clauses2636))))))) tmp2627) (syntax-violation #f "source expression failed to match any pattern" tmp2626))) ($sc-dispatch tmp2626 (quote (any any any . each-any))))) x2625)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2660) ((lambda (tmp2661) ((lambda (tmp2662) (if tmp2662 (apply (lambda (_2663 e2664) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2664)) (list (cons _2663 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2664 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2662) (syntax-violation #f "source expression failed to match any pattern" tmp2661))) ($sc-dispatch tmp2661 (quote (any any))))) x2660)))) +(letrec ((and-map*1002 (lambda (f1042 first1041 . rest1040) (or (null? first1041) (if (null? rest1040) (let andmap1043 ((first1044 first1041)) (let ((x1045 (car first1044)) (first1046 (cdr first1044))) (if (null? first1046) (f1042 x1045) (and (f1042 x1045) (andmap1043 first1046))))) (let andmap1047 ((first1048 first1041) (rest1049 rest1040)) (let ((x1050 (car first1048)) (xr1051 (map car rest1049)) (first1052 (cdr first1048)) (rest1053 (map cdr rest1049))) (if (null? first1052) (apply f1042 (cons x1050 xr1051)) (and (apply f1042 (cons x1050 xr1051)) (andmap1047 first1052 rest1053)))))))))) (letrec ((lambda-var-list1135 (lambda (vars1340) (let lvl1341 ((vars1342 vars1340) (ls1343 (quote ())) (w1344 (quote (())))) (cond ((pair? vars1342) (lvl1341 (cdr vars1342) (cons (wrap1114 (car vars1342) w1344 #f) ls1343) w1344)) ((id?1086 vars1342) (cons (wrap1114 vars1342 w1344 #f) ls1343)) ((null? vars1342) ls1343) ((syntax-object?1070 vars1342) (lvl1341 (syntax-object-expression1071 vars1342) ls1343 (join-wraps1105 w1344 (syntax-object-wrap1072 vars1342)))) ((annotation? vars1342) (lvl1341 (annotation-expression vars1342) ls1343 w1344)) (else (cons vars1342 ls1343)))))) (gen-var1134 (lambda (id1345) (let ((id1346 (if (syntax-object?1070 id1345) (syntax-object-expression1071 id1345) id1345))) (if (annotation? id1346) (build-annotated1063 (annotation-source id1346) (gensym (symbol->string (annotation-expression id1346)))) (build-annotated1063 #f (gensym (symbol->string id1346))))))) (strip1133 (lambda (x1347 w1348) (if (memq (quote top) (wrap-marks1089 w1348)) (if (or (annotation? x1347) (and (pair? x1347) (annotation? (car x1347)))) (strip-annotation1132 x1347 #f) x1347) (let f1349 ((x1350 x1347)) (cond ((syntax-object?1070 x1350) (strip1133 (syntax-object-expression1071 x1350) (syntax-object-wrap1072 x1350))) ((pair? x1350) (let ((a1351 (f1349 (car x1350))) (d1352 (f1349 (cdr x1350)))) (if (and (eq? a1351 (car x1350)) (eq? d1352 (cdr x1350))) x1350 (cons a1351 d1352)))) ((vector? x1350) (let ((old1353 (vector->list x1350))) (let ((new1354 (map f1349 old1353))) (if (and-map*1002 eq? old1353 new1354) x1350 (list->vector new1354))))) (else x1350)))))) (strip-annotation1132 (lambda (x1355 parent1356) (cond ((pair? x1355) (let ((new1357 (cons #f #f))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1357)) (set-car! new1357 (strip-annotation1132 (car x1355) #f)) (set-cdr! new1357 (strip-annotation1132 (cdr x1355) #f)) new1357))) ((annotation? x1355) (or (annotation-stripped x1355) (strip-annotation1132 (annotation-expression x1355) x1355))) ((vector? x1355) (let ((new1358 (make-vector (vector-length x1355)))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1358)) (let loop1359 ((i1360 (- (vector-length x1355) 1))) (unless (fx<1058 i1360 0) (vector-set! new1358 i1360 (strip-annotation1132 (vector-ref x1355 i1360) #f)) (loop1359 (fx-1056 i1360 1)))) new1358))) (else x1355)))) (ellipsis?1131 (lambda (x1361) (and (nonsymbol-id?1085 x1361) (free-id=?1109 x1361 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1130 (lambda () (build-annotated1063 #f (cons (build-annotated1063 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer1129 (lambda (expanded1362 mod1363) (let ((p1364 (local-eval-hook1060 expanded1362 mod1363))) (if (procedure? p1364) p1364 (syntax-violation #f "nonprocedure transformer" p1364))))) (chi-local-syntax1128 (lambda (rec?1365 e1366 r1367 w1368 s1369 mod1370 k1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 id1375 val1376 e11377 e21378) (let ((ids1379 id1375)) (if (not (valid-bound-ids?1111 ids1379)) (syntax-violation #f "duplicate bound keyword" e1366) (let ((labels1381 (gen-labels1092 ids1379))) (let ((new-w1382 (make-binding-wrap1103 ids1379 labels1381 w1368))) (k1371 (cons e11377 e21378) (extend-env1080 labels1381 (let ((w1384 (if rec?1365 new-w1382 w1368)) (trans-r1385 (macros-only-env1082 r1367))) (map (lambda (x1386) (cons (quote macro) (eval-local-transformer1129 (chi1122 x1386 trans-r1385 w1384 mod1370) mod1370))) val1376)) r1367) new-w1382 s1369 mod1370)))))) tmp1373) ((lambda (_1388) (syntax-violation #f "bad local syntax definition" (source-wrap1115 e1366 w1368 s1369 mod1370))) tmp1372))) ($sc-dispatch tmp1372 (quote (any #(each (any any)) any . each-any))))) e1366))) (chi-lambda-clause1127 (lambda (e1389 docstring1390 c1391 r1392 w1393 mod1394 k1395) ((lambda (tmp1396) ((lambda (tmp1397) (if (if tmp1397 (apply (lambda (args1398 doc1399 e11400 e21401) (and (string? (syntax->datum doc1399)) (not docstring1390))) tmp1397) #f) (apply (lambda (args1402 doc1403 e11404 e21405) (chi-lambda-clause1127 e1389 doc1403 (cons args1402 (cons e11404 e21405)) r1392 w1393 mod1394 k1395)) tmp1397) ((lambda (tmp1407) (if tmp1407 (apply (lambda (id1408 e11409 e21410) (let ((ids1411 id1408)) (if (not (valid-bound-ids?1111 ids1411)) (syntax-violation (quote lambda) "invalid parameter list" e1389) (let ((labels1413 (gen-labels1092 ids1411)) (new-vars1414 (map gen-var1134 ids1411))) (k1395 new-vars1414 docstring1390 (chi-body1126 (cons e11409 e21410) e1389 (extend-var-env1081 labels1413 new-vars1414 r1392) (make-binding-wrap1103 ids1411 labels1413 w1393) mod1394)))))) tmp1407) ((lambda (tmp1416) (if tmp1416 (apply (lambda (ids1417 e11418 e21419) (let ((old-ids1420 (lambda-var-list1135 ids1417))) (if (not (valid-bound-ids?1111 old-ids1420)) (syntax-violation (quote lambda) "invalid parameter list" e1389) (let ((labels1421 (gen-labels1092 old-ids1420)) (new-vars1422 (map gen-var1134 old-ids1420))) (k1395 (let f1423 ((ls11424 (cdr new-vars1422)) (ls21425 (car new-vars1422))) (if (null? ls11424) ls21425 (f1423 (cdr ls11424) (cons (car ls11424) ls21425)))) docstring1390 (chi-body1126 (cons e11418 e21419) e1389 (extend-var-env1081 labels1421 new-vars1422 r1392) (make-binding-wrap1103 old-ids1420 labels1421 w1393) mod1394)))))) tmp1416) ((lambda (_1427) (syntax-violation (quote lambda) "bad lambda" e1389)) tmp1396))) ($sc-dispatch tmp1396 (quote (any any . each-any)))))) ($sc-dispatch tmp1396 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1396 (quote (any any any . each-any))))) c1391))) (chi-body1126 (lambda (body1428 outer-form1429 r1430 w1431 mod1432) (let ((r1433 (cons (quote ("placeholder" placeholder)) r1430))) (let ((ribcage1434 (make-ribcage1093 (quote ()) (quote ()) (quote ())))) (let ((w1435 (make-wrap1088 (wrap-marks1089 w1431) (cons ribcage1434 (wrap-subst1090 w1431))))) (let parse1436 ((body1437 (map (lambda (x1443) (cons r1433 (wrap1114 x1443 w1435 mod1432))) body1428)) (ids1438 (quote ())) (labels1439 (quote ())) (vars1440 (quote ())) (vals1441 (quote ())) (bindings1442 (quote ()))) (if (null? body1437) (syntax-violation #f "no expressions in body" outer-form1429) (let ((e1444 (cdar body1437)) (er1445 (caar body1437))) (call-with-values (lambda () (syntax-type1120 e1444 er1445 (quote (())) #f ribcage1434 mod1432)) (lambda (type1446 value1447 e1448 w1449 s1450 mod1451) (let ((t1452 type1446)) (if (memv t1452 (quote (define-form))) (let ((id1453 (wrap1114 value1447 w1449 mod1451)) (label1454 (gen-label1091))) (let ((var1455 (gen-var1134 id1453))) (begin (extend-ribcage!1102 ribcage1434 id1453 label1454) (parse1436 (cdr body1437) (cons id1453 ids1438) (cons label1454 labels1439) (cons var1455 vars1440) (cons (cons er1445 (wrap1114 e1448 w1449 mod1451)) vals1441) (cons (cons (quote lexical) var1455) bindings1442))))) (if (memv t1452 (quote (define-syntax-form))) (let ((id1456 (wrap1114 value1447 w1449 mod1451)) (label1457 (gen-label1091))) (begin (extend-ribcage!1102 ribcage1434 id1456 label1457) (parse1436 (cdr body1437) (cons id1456 ids1438) (cons label1457 labels1439) vars1440 vals1441 (cons (cons (quote macro) (cons er1445 (wrap1114 e1448 w1449 mod1451))) bindings1442)))) (if (memv t1452 (quote (begin-form))) ((lambda (tmp1458) ((lambda (tmp1459) (if tmp1459 (apply (lambda (_1460 e11461) (parse1436 (let f1462 ((forms1463 e11461)) (if (null? forms1463) (cdr body1437) (cons (cons er1445 (wrap1114 (car forms1463) w1449 mod1451)) (f1462 (cdr forms1463))))) ids1438 labels1439 vars1440 vals1441 bindings1442)) tmp1459) (syntax-violation #f "source expression failed to match any pattern" tmp1458))) ($sc-dispatch tmp1458 (quote (any . each-any))))) e1448) (if (memv t1452 (quote (local-syntax-form))) (chi-local-syntax1128 value1447 e1448 er1445 w1449 s1450 mod1451 (lambda (forms1465 er1466 w1467 s1468 mod1469) (parse1436 (let f1470 ((forms1471 forms1465)) (if (null? forms1471) (cdr body1437) (cons (cons er1466 (wrap1114 (car forms1471) w1467 mod1469)) (f1470 (cdr forms1471))))) ids1438 labels1439 vars1440 vals1441 bindings1442))) (if (null? ids1438) (build-sequence1065 #f (map (lambda (x1472) (chi1122 (cdr x1472) (car x1472) (quote (())) mod1451)) (cons (cons er1445 (source-wrap1115 e1448 w1449 s1450 mod1451)) (cdr body1437)))) (begin (if (not (valid-bound-ids?1111 ids1438)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1429)) (let loop1473 ((bs1474 bindings1442) (er-cache1475 #f) (r-cache1476 #f)) (if (not (null? bs1474)) (let ((b1477 (car bs1474))) (if (eq? (car b1477) (quote macro)) (let ((er1478 (cadr b1477))) (let ((r-cache1479 (if (eq? er1478 er-cache1475) r-cache1476 (macros-only-env1082 er1478)))) (begin (set-cdr! b1477 (eval-local-transformer1129 (chi1122 (cddr b1477) r-cache1479 (quote (())) mod1451) mod1451)) (loop1473 (cdr bs1474) er1478 r-cache1479)))) (loop1473 (cdr bs1474) er-cache1475 r-cache1476))))) (set-cdr! r1433 (extend-env1080 labels1439 bindings1442 (cdr r1433))) (build-letrec1068 #f vars1440 (map (lambda (x1480) (chi1122 (cdr x1480) (car x1480) (quote (())) mod1451)) vals1441) (build-sequence1065 #f (map (lambda (x1481) (chi1122 (cdr x1481) (car x1481) (quote (())) mod1451)) (cons (cons er1445 (source-wrap1115 e1448 w1449 s1450 mod1451)) (cdr body1437)))))))))))))))))))))) (chi-macro1125 (lambda (p1482 e1483 r1484 w1485 rib1486 mod1487) (letrec ((rebuild-macro-output1488 (lambda (x1489 m1490) (cond ((pair? x1489) (cons (rebuild-macro-output1488 (car x1489) m1490) (rebuild-macro-output1488 (cdr x1489) m1490))) ((syntax-object?1070 x1489) (let ((w1491 (syntax-object-wrap1072 x1489))) (let ((ms1492 (wrap-marks1089 w1491)) (s1493 (wrap-subst1090 w1491))) (if (and (pair? ms1492) (eq? (car ms1492) #f)) (make-syntax-object1069 (syntax-object-expression1071 x1489) (make-wrap1088 (cdr ms1492) (if rib1486 (cons rib1486 (cdr s1493)) (cdr s1493))) (syntax-object-module1073 x1489)) (make-syntax-object1069 (syntax-object-expression1071 x1489) (make-wrap1088 (cons m1490 ms1492) (if rib1486 (cons rib1486 (cons (quote shift) s1493)) (cons (quote shift) s1493))) (let ((pmod1494 (procedure-module p1482))) (if pmod1494 (cons (quote hygiene) (module-name pmod1494)) (quote (hygiene guile))))))))) ((vector? x1489) (let ((n1495 (vector-length x1489))) (let ((v1496 (make-vector n1495))) (let doloop1497 ((i1498 0)) (if (fx=1057 i1498 n1495) v1496 (begin (vector-set! v1496 i1498 (rebuild-macro-output1488 (vector-ref x1489 i1498) m1490)) (doloop1497 (fx+1055 i1498 1)))))))) ((symbol? x1489) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1115 e1483 w1485 s mod1487) x1489)) (else x1489))))) (rebuild-macro-output1488 (p1482 (wrap1114 e1483 (anti-mark1101 w1485) mod1487)) (string #\m))))) (chi-application1124 (lambda (x1499 e1500 r1501 w1502 s1503 mod1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (e01507 e11508) (build-annotated1063 s1503 (cons x1499 (map (lambda (e1509) (chi1122 e1509 r1501 w1502 mod1504)) e11508)))) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any . each-any))))) e1500))) (chi-expr1123 (lambda (type1511 value1512 e1513 r1514 w1515 s1516 mod1517) (let ((t1518 type1511)) (if (memv t1518 (quote (lexical))) (build-annotated1063 s1516 value1512) (if (memv t1518 (quote (core external-macro))) (value1512 e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (module-ref))) (call-with-values (lambda () (value1512 e1513)) (lambda (id1519 mod1520) (build-annotated1063 s1516 (if mod1520 (make-module-ref (cdr mod1520) id1519 (car mod1520)) (make-module-ref mod1520 id1519 (quote bare)))))) (if (memv t1518 (quote (lexical-call))) (chi-application1124 (build-annotated1063 (source-annotation1077 (car e1513)) value1512) e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (global-call))) (chi-application1124 (build-annotated1063 (source-annotation1077 (car e1513)) (if (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517) (make-module-ref (cdr (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517)) value1512 (car (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517))) (make-module-ref (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517) value1512 (quote bare)))) e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (constant))) (build-data1064 s1516 (strip1133 (source-wrap1115 e1513 w1515 s1516 mod1517) (quote (())))) (if (memv t1518 (quote (global))) (build-annotated1063 s1516 (if mod1517 (make-module-ref (cdr mod1517) value1512 (car mod1517)) (make-module-ref mod1517 value1512 (quote bare)))) (if (memv t1518 (quote (call))) (chi-application1124 (chi1122 (car e1513) r1514 w1515 mod1517) e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (begin-form))) ((lambda (tmp1521) ((lambda (tmp1522) (if tmp1522 (apply (lambda (_1523 e11524 e21525) (chi-sequence1116 (cons e11524 e21525) r1514 w1515 s1516 mod1517)) tmp1522) (syntax-violation #f "source expression failed to match any pattern" tmp1521))) ($sc-dispatch tmp1521 (quote (any any . each-any))))) e1513) (if (memv t1518 (quote (local-syntax-form))) (chi-local-syntax1128 value1512 e1513 r1514 w1515 s1516 mod1517 chi-sequence1116) (if (memv t1518 (quote (eval-when-form))) ((lambda (tmp1527) ((lambda (tmp1528) (if tmp1528 (apply (lambda (_1529 x1530 e11531 e21532) (let ((when-list1533 (chi-when-list1119 e1513 x1530 w1515))) (if (memq (quote eval) when-list1533) (chi-sequence1116 (cons e11531 e21532) r1514 w1515 s1516 mod1517) (chi-void1130)))) tmp1528) (syntax-violation #f "source expression failed to match any pattern" tmp1527))) ($sc-dispatch tmp1527 (quote (any each-any any . each-any))))) e1513) (if (memv t1518 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1513 (wrap1114 value1512 w1515 mod1517)) (if (memv t1518 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1115 e1513 w1515 s1516 mod1517)) (if (memv t1518 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1115 e1513 w1515 s1516 mod1517)) (syntax-violation #f "unexpected syntax" (source-wrap1115 e1513 w1515 s1516 mod1517))))))))))))))))))) (chi1122 (lambda (e1536 r1537 w1538 mod1539) (call-with-values (lambda () (syntax-type1120 e1536 r1537 w1538 #f #f mod1539)) (lambda (type1540 value1541 e1542 w1543 s1544 mod1545) (chi-expr1123 type1540 value1541 e1542 r1537 w1543 s1544 mod1545))))) (chi-top1121 (lambda (e1546 r1547 w1548 m1549 esew1550 mod1551) (call-with-values (lambda () (syntax-type1120 e1546 r1547 w1548 #f #f mod1551)) (lambda (type1559 value1560 e1561 w1562 s1563 mod1564) (let ((t1565 type1559)) (if (memv t1565 (quote (begin-form))) ((lambda (tmp1566) ((lambda (tmp1567) (if tmp1567 (apply (lambda (_1568) (chi-void1130)) tmp1567) ((lambda (tmp1569) (if tmp1569 (apply (lambda (_1570 e11571 e21572) (chi-top-sequence1117 (cons e11571 e21572) r1547 w1562 s1563 m1549 esew1550 mod1564)) tmp1569) (syntax-violation #f "source expression failed to match any pattern" tmp1566))) ($sc-dispatch tmp1566 (quote (any any . each-any)))))) ($sc-dispatch tmp1566 (quote (any))))) e1561) (if (memv t1565 (quote (local-syntax-form))) (chi-local-syntax1128 value1560 e1561 r1547 w1562 s1563 mod1564 (lambda (body1574 r1575 w1576 s1577 mod1578) (chi-top-sequence1117 body1574 r1575 w1576 s1577 m1549 esew1550 mod1578))) (if (memv t1565 (quote (eval-when-form))) ((lambda (tmp1579) ((lambda (tmp1580) (if tmp1580 (apply (lambda (_1581 x1582 e11583 e21584) (let ((when-list1585 (chi-when-list1119 e1561 x1582 w1562)) (body1586 (cons e11583 e21584))) (cond ((eq? m1549 (quote e)) (if (memq (quote eval) when-list1585) (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote e) (quote (eval)) mod1564) (chi-void1130))) ((memq (quote load) when-list1585) (if (or (memq (quote compile) when-list1585) (and (eq? m1549 (quote c&e)) (memq (quote eval) when-list1585))) (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote c&e) (quote (compile load)) mod1564) (if (memq m1549 (quote (c c&e))) (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote c) (quote (load)) mod1564) (chi-void1130)))) ((or (memq (quote compile) when-list1585) (and (eq? m1549 (quote c&e)) (memq (quote eval) when-list1585))) (top-level-eval-hook1059 (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote e) (quote (eval)) mod1564) mod1564) (chi-void1130)) (else (chi-void1130))))) tmp1580) (syntax-violation #f "source expression failed to match any pattern" tmp1579))) ($sc-dispatch tmp1579 (quote (any each-any any . each-any))))) e1561) (if (memv t1565 (quote (define-syntax-form))) (let ((n1589 (id-var-name1108 value1560 w1562)) (r1590 (macros-only-env1082 r1547))) (let ((t1591 m1549)) (if (memv t1591 (quote (c))) (if (memq (quote compile) esew1550) (let ((e1592 (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)))) (begin (top-level-eval-hook1059 e1592 mod1564) (if (memq (quote load) esew1550) e1592 (chi-void1130)))) (if (memq (quote load) esew1550) (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)) (chi-void1130))) (if (memv t1591 (quote (c&e))) (let ((e1593 (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)))) (begin (top-level-eval-hook1059 e1593 mod1564) e1593)) (begin (if (memq (quote eval) esew1550) (top-level-eval-hook1059 (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)) mod1564)) (chi-void1130)))))) (if (memv t1565 (quote (define-form))) (let ((n1594 (id-var-name1108 value1560 w1562))) (let ((type1595 (binding-type1078 (lookup1083 n1594 r1547 mod1564)))) (let ((t1596 type1595)) (if (memv t1596 (quote (global core macro module-ref))) (let ((x1597 (build-annotated1063 s1563 (list (quote define) n1594 (chi1122 e1561 r1547 w1562 mod1564))))) (begin (if (eq? m1549 (quote c&e)) (top-level-eval-hook1059 x1597 mod1564)) x1597)) (if (memv t1596 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1561 (wrap1114 value1560 w1562 mod1564)) (syntax-violation #f "cannot define keyword at top level" e1561 (wrap1114 value1560 w1562 mod1564))))))) (let ((x1598 (chi-expr1123 type1559 value1560 e1561 r1547 w1562 s1563 mod1564))) (begin (if (eq? m1549 (quote c&e)) (top-level-eval-hook1059 x1598 mod1564)) x1598)))))))))))) (syntax-type1120 (lambda (e1599 r1600 w1601 s1602 rib1603 mod1604) (cond ((symbol? e1599) (let ((n1605 (id-var-name1108 e1599 w1601))) (let ((b1606 (lookup1083 n1605 r1600 mod1604))) (let ((type1607 (binding-type1078 b1606))) (let ((t1608 type1607)) (if (memv t1608 (quote (lexical))) (values type1607 (binding-value1079 b1606) e1599 w1601 s1602 mod1604) (if (memv t1608 (quote (global))) (values type1607 n1605 e1599 w1601 s1602 mod1604) (if (memv t1608 (quote (macro))) (syntax-type1120 (chi-macro1125 (binding-value1079 b1606) e1599 r1600 w1601 rib1603 mod1604) r1600 (quote (())) s1602 rib1603 mod1604) (values type1607 (binding-value1079 b1606) e1599 w1601 s1602 mod1604))))))))) ((pair? e1599) (let ((first1609 (car e1599))) (if (id?1086 first1609) (let ((n1610 (id-var-name1108 first1609 w1601))) (let ((b1611 (lookup1083 n1610 r1600 (or (and (syntax-object?1070 first1609) (syntax-object-module1073 first1609)) mod1604)))) (let ((type1612 (binding-type1078 b1611))) (let ((t1613 type1612)) (if (memv t1613 (quote (lexical))) (values (quote lexical-call) (binding-value1079 b1611) e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (global))) (values (quote global-call) n1610 e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (macro))) (syntax-type1120 (chi-macro1125 (binding-value1079 b1611) e1599 r1600 w1601 rib1603 mod1604) r1600 (quote (())) s1602 rib1603 mod1604) (if (memv t1613 (quote (core external-macro module-ref))) (values type1612 (binding-value1079 b1611) e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1079 b1611) e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (begin))) (values (quote begin-form) #f e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (eval-when))) (values (quote eval-when-form) #f e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (define))) ((lambda (tmp1614) ((lambda (tmp1615) (if (if tmp1615 (apply (lambda (_1616 name1617 val1618) (id?1086 name1617)) tmp1615) #f) (apply (lambda (_1619 name1620 val1621) (values (quote define-form) name1620 val1621 w1601 s1602 mod1604)) tmp1615) ((lambda (tmp1622) (if (if tmp1622 (apply (lambda (_1623 name1624 args1625 e11626 e21627) (and (id?1086 name1624) (valid-bound-ids?1111 (lambda-var-list1135 args1625)))) tmp1622) #f) (apply (lambda (_1628 name1629 args1630 e11631 e21632) (values (quote define-form) (wrap1114 name1629 w1601 mod1604) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1114 (cons args1630 (cons e11631 e21632)) w1601 mod1604)) (quote (())) s1602 mod1604)) tmp1622) ((lambda (tmp1634) (if (if tmp1634 (apply (lambda (_1635 name1636) (id?1086 name1636)) tmp1634) #f) (apply (lambda (_1637 name1638) (values (quote define-form) (wrap1114 name1638 w1601 mod1604) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1602 mod1604)) tmp1634) (syntax-violation #f "source expression failed to match any pattern" tmp1614))) ($sc-dispatch tmp1614 (quote (any any)))))) ($sc-dispatch tmp1614 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1614 (quote (any any any))))) e1599) (if (memv t1613 (quote (define-syntax))) ((lambda (tmp1639) ((lambda (tmp1640) (if (if tmp1640 (apply (lambda (_1641 name1642 val1643) (id?1086 name1642)) tmp1640) #f) (apply (lambda (_1644 name1645 val1646) (values (quote define-syntax-form) name1645 val1646 w1601 s1602 mod1604)) tmp1640) (syntax-violation #f "source expression failed to match any pattern" tmp1639))) ($sc-dispatch tmp1639 (quote (any any any))))) e1599) (values (quote call) #f e1599 w1601 s1602 mod1604)))))))))))))) (values (quote call) #f e1599 w1601 s1602 mod1604)))) ((syntax-object?1070 e1599) (syntax-type1120 (syntax-object-expression1071 e1599) r1600 (join-wraps1105 w1601 (syntax-object-wrap1072 e1599)) #f rib1603 (or (syntax-object-module1073 e1599) mod1604))) ((annotation? e1599) (syntax-type1120 (annotation-expression e1599) r1600 w1601 (annotation-source e1599) rib1603 mod1604)) ((self-evaluating? e1599) (values (quote constant) #f e1599 w1601 s1602 mod1604)) (else (values (quote other) #f e1599 w1601 s1602 mod1604))))) (chi-when-list1119 (lambda (e1647 when-list1648 w1649) (let f1650 ((when-list1651 when-list1648) (situations1652 (quote ()))) (if (null? when-list1651) situations1652 (f1650 (cdr when-list1651) (cons (let ((x1653 (car when-list1651))) (cond ((free-id=?1109 x1653 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1109 x1653 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1109 x1653 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1647 (wrap1114 x1653 w1649 #f))))) situations1652)))))) (chi-install-global1118 (lambda (name1654 e1655) (build-annotated1063 #f (list (build-annotated1063 #f (quote define)) name1654 (if (let ((v1656 (module-variable (current-module) name1654))) (and v1656 (variable-bound? v1656) (macro? (variable-ref v1656)) (not (eq? (macro-type (variable-ref v1656)) (quote syncase-macro))))) (build-annotated1063 #f (list (build-annotated1063 #f (quote make-extended-syncase-macro)) (build-annotated1063 #f (list (build-annotated1063 #f (quote module-ref)) (build-annotated1063 #f (quote (current-module))) (build-data1064 #f name1654))) (build-data1064 #f (quote macro)) e1655)) (build-annotated1063 #f (list (build-annotated1063 #f (quote make-syncase-macro)) (build-data1064 #f (quote macro)) e1655))))))) (chi-top-sequence1117 (lambda (body1657 r1658 w1659 s1660 m1661 esew1662 mod1663) (build-sequence1065 s1660 (let dobody1664 ((body1665 body1657) (r1666 r1658) (w1667 w1659) (m1668 m1661) (esew1669 esew1662) (mod1670 mod1663)) (if (null? body1665) (quote ()) (let ((first1671 (chi-top1121 (car body1665) r1666 w1667 m1668 esew1669 mod1670))) (cons first1671 (dobody1664 (cdr body1665) r1666 w1667 m1668 esew1669 mod1670)))))))) (chi-sequence1116 (lambda (body1672 r1673 w1674 s1675 mod1676) (build-sequence1065 s1675 (let dobody1677 ((body1678 body1672) (r1679 r1673) (w1680 w1674) (mod1681 mod1676)) (if (null? body1678) (quote ()) (let ((first1682 (chi1122 (car body1678) r1679 w1680 mod1681))) (cons first1682 (dobody1677 (cdr body1678) r1679 w1680 mod1681)))))))) (source-wrap1115 (lambda (x1683 w1684 s1685 defmod1686) (wrap1114 (if s1685 (make-annotation x1683 s1685 #f) x1683) w1684 defmod1686))) (wrap1114 (lambda (x1687 w1688 defmod1689) (cond ((and (null? (wrap-marks1089 w1688)) (null? (wrap-subst1090 w1688))) x1687) ((syntax-object?1070 x1687) (make-syntax-object1069 (syntax-object-expression1071 x1687) (join-wraps1105 w1688 (syntax-object-wrap1072 x1687)) (syntax-object-module1073 x1687))) ((null? x1687) x1687) (else (make-syntax-object1069 x1687 w1688 defmod1689))))) (bound-id-member?1113 (lambda (x1690 list1691) (and (not (null? list1691)) (or (bound-id=?1110 x1690 (car list1691)) (bound-id-member?1113 x1690 (cdr list1691)))))) (distinct-bound-ids?1112 (lambda (ids1692) (let distinct?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (not (bound-id-member?1113 (car ids1694) (cdr ids1694))) (distinct?1693 (cdr ids1694))))))) (valid-bound-ids?1111 (lambda (ids1695) (and (let all-ids?1696 ((ids1697 ids1695)) (or (null? ids1697) (and (id?1086 (car ids1697)) (all-ids?1696 (cdr ids1697))))) (distinct-bound-ids?1112 ids1695)))) (bound-id=?1110 (lambda (i1698 j1699) (if (and (syntax-object?1070 i1698) (syntax-object?1070 j1699)) (and (eq? (let ((e1700 (syntax-object-expression1071 i1698))) (if (annotation? e1700) (annotation-expression e1700) e1700)) (let ((e1701 (syntax-object-expression1071 j1699))) (if (annotation? e1701) (annotation-expression e1701) e1701))) (same-marks?1107 (wrap-marks1089 (syntax-object-wrap1072 i1698)) (wrap-marks1089 (syntax-object-wrap1072 j1699)))) (eq? (let ((e1702 i1698)) (if (annotation? e1702) (annotation-expression e1702) e1702)) (let ((e1703 j1699)) (if (annotation? e1703) (annotation-expression e1703) e1703)))))) (free-id=?1109 (lambda (i1704 j1705) (and (eq? (let ((x1706 i1704)) (let ((e1707 (if (syntax-object?1070 x1706) (syntax-object-expression1071 x1706) x1706))) (if (annotation? e1707) (annotation-expression e1707) e1707))) (let ((x1708 j1705)) (let ((e1709 (if (syntax-object?1070 x1708) (syntax-object-expression1071 x1708) x1708))) (if (annotation? e1709) (annotation-expression e1709) e1709)))) (eq? (id-var-name1108 i1704 (quote (()))) (id-var-name1108 j1705 (quote (()))))))) (id-var-name1108 (lambda (id1710 w1711) (letrec ((search-vector-rib1714 (lambda (sym1720 subst1721 marks1722 symnames1723 ribcage1724) (let ((n1725 (vector-length symnames1723))) (let f1726 ((i1727 0)) (cond ((fx=1057 i1727 n1725) (search1712 sym1720 (cdr subst1721) marks1722)) ((and (eq? (vector-ref symnames1723 i1727) sym1720) (same-marks?1107 marks1722 (vector-ref (ribcage-marks1096 ribcage1724) i1727))) (values (vector-ref (ribcage-labels1097 ribcage1724) i1727) marks1722)) (else (f1726 (fx+1055 i1727 1)))))))) (search-list-rib1713 (lambda (sym1728 subst1729 marks1730 symnames1731 ribcage1732) (let f1733 ((symnames1734 symnames1731) (i1735 0)) (cond ((null? symnames1734) (search1712 sym1728 (cdr subst1729) marks1730)) ((and (eq? (car symnames1734) sym1728) (same-marks?1107 marks1730 (list-ref (ribcage-marks1096 ribcage1732) i1735))) (values (list-ref (ribcage-labels1097 ribcage1732) i1735) marks1730)) (else (f1733 (cdr symnames1734) (fx+1055 i1735 1))))))) (search1712 (lambda (sym1736 subst1737 marks1738) (if (null? subst1737) (values #f marks1738) (let ((fst1739 (car subst1737))) (if (eq? fst1739 (quote shift)) (search1712 sym1736 (cdr subst1737) (cdr marks1738)) (let ((symnames1740 (ribcage-symnames1095 fst1739))) (if (vector? symnames1740) (search-vector-rib1714 sym1736 subst1737 marks1738 symnames1740 fst1739) (search-list-rib1713 sym1736 subst1737 marks1738 symnames1740 fst1739))))))))) (cond ((symbol? id1710) (or (call-with-values (lambda () (search1712 id1710 (wrap-subst1090 w1711) (wrap-marks1089 w1711))) (lambda (x1742 . ignore1741) x1742)) id1710)) ((syntax-object?1070 id1710) (let ((id1743 (let ((e1745 (syntax-object-expression1071 id1710))) (if (annotation? e1745) (annotation-expression e1745) e1745))) (w11744 (syntax-object-wrap1072 id1710))) (let ((marks1746 (join-marks1106 (wrap-marks1089 w1711) (wrap-marks1089 w11744)))) (call-with-values (lambda () (search1712 id1743 (wrap-subst1090 w1711) marks1746)) (lambda (new-id1747 marks1748) (or new-id1747 (call-with-values (lambda () (search1712 id1743 (wrap-subst1090 w11744) marks1748)) (lambda (x1750 . ignore1749) x1750)) id1743)))))) ((annotation? id1710) (let ((id1751 (let ((e1752 id1710)) (if (annotation? e1752) (annotation-expression e1752) e1752)))) (or (call-with-values (lambda () (search1712 id1751 (wrap-subst1090 w1711) (wrap-marks1089 w1711))) (lambda (x1754 . ignore1753) x1754)) id1751))) (else (syntax-violation (quote id-var-name) "invalid id" id1710)))))) (same-marks?1107 (lambda (x1755 y1756) (or (eq? x1755 y1756) (and (not (null? x1755)) (not (null? y1756)) (eq? (car x1755) (car y1756)) (same-marks?1107 (cdr x1755) (cdr y1756)))))) (join-marks1106 (lambda (m11757 m21758) (smart-append1104 m11757 m21758))) (join-wraps1105 (lambda (w11759 w21760) (let ((m11761 (wrap-marks1089 w11759)) (s11762 (wrap-subst1090 w11759))) (if (null? m11761) (if (null? s11762) w21760 (make-wrap1088 (wrap-marks1089 w21760) (smart-append1104 s11762 (wrap-subst1090 w21760)))) (make-wrap1088 (smart-append1104 m11761 (wrap-marks1089 w21760)) (smart-append1104 s11762 (wrap-subst1090 w21760))))))) (smart-append1104 (lambda (m11763 m21764) (if (null? m21764) m11763 (append m11763 m21764)))) (make-binding-wrap1103 (lambda (ids1765 labels1766 w1767) (if (null? ids1765) w1767 (make-wrap1088 (wrap-marks1089 w1767) (cons (let ((labelvec1768 (list->vector labels1766))) (let ((n1769 (vector-length labelvec1768))) (let ((symnamevec1770 (make-vector n1769)) (marksvec1771 (make-vector n1769))) (begin (let f1772 ((ids1773 ids1765) (i1774 0)) (if (not (null? ids1773)) (call-with-values (lambda () (id-sym-name&marks1087 (car ids1773) w1767)) (lambda (symname1775 marks1776) (begin (vector-set! symnamevec1770 i1774 symname1775) (vector-set! marksvec1771 i1774 marks1776) (f1772 (cdr ids1773) (fx+1055 i1774 1))))))) (make-ribcage1093 symnamevec1770 marksvec1771 labelvec1768))))) (wrap-subst1090 w1767)))))) (extend-ribcage!1102 (lambda (ribcage1777 id1778 label1779) (begin (set-ribcage-symnames!1098 ribcage1777 (cons (let ((e1780 (syntax-object-expression1071 id1778))) (if (annotation? e1780) (annotation-expression e1780) e1780)) (ribcage-symnames1095 ribcage1777))) (set-ribcage-marks!1099 ribcage1777 (cons (wrap-marks1089 (syntax-object-wrap1072 id1778)) (ribcage-marks1096 ribcage1777))) (set-ribcage-labels!1100 ribcage1777 (cons label1779 (ribcage-labels1097 ribcage1777)))))) (anti-mark1101 (lambda (w1781) (make-wrap1088 (cons #f (wrap-marks1089 w1781)) (cons (quote shift) (wrap-subst1090 w1781))))) (set-ribcage-labels!1100 (lambda (x1782 update1783) (vector-set! x1782 3 update1783))) (set-ribcage-marks!1099 (lambda (x1784 update1785) (vector-set! x1784 2 update1785))) (set-ribcage-symnames!1098 (lambda (x1786 update1787) (vector-set! x1786 1 update1787))) (ribcage-labels1097 (lambda (x1788) (vector-ref x1788 3))) (ribcage-marks1096 (lambda (x1789) (vector-ref x1789 2))) (ribcage-symnames1095 (lambda (x1790) (vector-ref x1790 1))) (ribcage?1094 (lambda (x1791) (and (vector? x1791) (= (vector-length x1791) 4) (eq? (vector-ref x1791 0) (quote ribcage))))) (make-ribcage1093 (lambda (symnames1792 marks1793 labels1794) (vector (quote ribcage) symnames1792 marks1793 labels1794))) (gen-labels1092 (lambda (ls1795) (if (null? ls1795) (quote ()) (cons (gen-label1091) (gen-labels1092 (cdr ls1795)))))) (gen-label1091 (lambda () (string #\i))) (wrap-subst1090 cdr) (wrap-marks1089 car) (make-wrap1088 cons) (id-sym-name&marks1087 (lambda (x1796 w1797) (if (syntax-object?1070 x1796) (values (let ((e1798 (syntax-object-expression1071 x1796))) (if (annotation? e1798) (annotation-expression e1798) e1798)) (join-marks1106 (wrap-marks1089 w1797) (wrap-marks1089 (syntax-object-wrap1072 x1796)))) (values (let ((e1799 x1796)) (if (annotation? e1799) (annotation-expression e1799) e1799)) (wrap-marks1089 w1797))))) (id?1086 (lambda (x1800) (cond ((symbol? x1800) #t) ((syntax-object?1070 x1800) (symbol? (let ((e1801 (syntax-object-expression1071 x1800))) (if (annotation? e1801) (annotation-expression e1801) e1801)))) ((annotation? x1800) (symbol? (annotation-expression x1800))) (else #f)))) (nonsymbol-id?1085 (lambda (x1802) (and (syntax-object?1070 x1802) (symbol? (let ((e1803 (syntax-object-expression1071 x1802))) (if (annotation? e1803) (annotation-expression e1803) e1803)))))) (global-extend1084 (lambda (type1804 sym1805 val1806) (put-global-definition-hook1061 sym1805 type1804 val1806))) (lookup1083 (lambda (x1807 r1808 mod1809) (cond ((assq x1807 r1808) => cdr) ((symbol? x1807) (or (get-global-definition-hook1062 x1807 mod1809) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1082 (lambda (r1810) (if (null? r1810) (quote ()) (let ((a1811 (car r1810))) (if (eq? (cadr a1811) (quote macro)) (cons a1811 (macros-only-env1082 (cdr r1810))) (macros-only-env1082 (cdr r1810))))))) (extend-var-env1081 (lambda (labels1812 vars1813 r1814) (if (null? labels1812) r1814 (extend-var-env1081 (cdr labels1812) (cdr vars1813) (cons (cons (car labels1812) (cons (quote lexical) (car vars1813))) r1814))))) (extend-env1080 (lambda (labels1815 bindings1816 r1817) (if (null? labels1815) r1817 (extend-env1080 (cdr labels1815) (cdr bindings1816) (cons (cons (car labels1815) (car bindings1816)) r1817))))) (binding-value1079 cdr) (binding-type1078 car) (source-annotation1077 (lambda (x1818) (cond ((annotation? x1818) (annotation-source x1818)) ((syntax-object?1070 x1818) (source-annotation1077 (syntax-object-expression1071 x1818))) (else #f)))) (set-syntax-object-module!1076 (lambda (x1819 update1820) (vector-set! x1819 3 update1820))) (set-syntax-object-wrap!1075 (lambda (x1821 update1822) (vector-set! x1821 2 update1822))) (set-syntax-object-expression!1074 (lambda (x1823 update1824) (vector-set! x1823 1 update1824))) (syntax-object-module1073 (lambda (x1825) (vector-ref x1825 3))) (syntax-object-wrap1072 (lambda (x1826) (vector-ref x1826 2))) (syntax-object-expression1071 (lambda (x1827) (vector-ref x1827 1))) (syntax-object?1070 (lambda (x1828) (and (vector? x1828) (= (vector-length x1828) 4) (eq? (vector-ref x1828 0) (quote syntax-object))))) (make-syntax-object1069 (lambda (expression1829 wrap1830 module1831) (vector (quote syntax-object) expression1829 wrap1830 module1831))) (build-letrec1068 (lambda (src1832 vars1833 val-exps1834 body-exp1835) (if (null? vars1833) (build-annotated1063 src1832 body-exp1835) (build-annotated1063 src1832 (list (quote letrec) (map list vars1833 val-exps1834) body-exp1835))))) (build-named-let1067 (lambda (src1836 vars1837 val-exps1838 body-exp1839) (if (null? vars1837) (build-annotated1063 src1836 body-exp1839) (build-annotated1063 src1836 (list (quote let) (car vars1837) (map list (cdr vars1837) val-exps1838) body-exp1839))))) (build-let1066 (lambda (src1840 vars1841 val-exps1842 body-exp1843) (if (null? vars1841) (build-annotated1063 src1840 body-exp1843) (build-annotated1063 src1840 (list (quote let) (map list vars1841 val-exps1842) body-exp1843))))) (build-sequence1065 (lambda (src1844 exps1845) (if (null? (cdr exps1845)) (build-annotated1063 src1844 (car exps1845)) (build-annotated1063 src1844 (cons (quote begin) exps1845))))) (build-data1064 (lambda (src1846 exp1847) (if (and (self-evaluating? exp1847) (not (vector? exp1847))) (build-annotated1063 src1846 exp1847) (build-annotated1063 src1846 (list (quote quote) exp1847))))) (build-annotated1063 (lambda (src1848 exp1849) (if (and src1848 (not (annotation? exp1849))) (make-annotation exp1849 src1848 #t) exp1849))) (get-global-definition-hook1062 (lambda (symbol1850 module1851) (begin (if (and (not module1851) (current-module)) (warn "module system is booted, we should have a module" symbol1850)) (let ((v1852 (module-variable (if module1851 (resolve-module (cdr module1851)) (current-module)) symbol1850))) (and v1852 (variable-bound? v1852) (let ((val1853 (variable-ref v1852))) (and (macro? val1853) (syncase-macro-type val1853) (cons (syncase-macro-type val1853) (syncase-macro-binding val1853))))))))) (put-global-definition-hook1061 (lambda (symbol1854 type1855 val1856) (let ((existing1857 (let ((v1858 (module-variable (current-module) symbol1854))) (and v1858 (variable-bound? v1858) (let ((val1859 (variable-ref v1858))) (and (macro? val1859) (not (syncase-macro-type val1859)) val1859)))))) (module-define! (current-module) symbol1854 (if existing1857 (make-extended-syncase-macro existing1857 type1855 val1856) (make-syncase-macro type1855 val1856)))))) (local-eval-hook1060 (lambda (x1860 mod1861) (primitive-eval (list noexpand1054 x1860)))) (top-level-eval-hook1059 (lambda (x1862 mod1863) (primitive-eval (list noexpand1054 x1862)))) (fx<1058 <) (fx=1057 =) (fx-1056 -) (fx+1055 +) (noexpand1054 "noexpand")) (begin (global-extend1084 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1084 (quote local-syntax) (quote let-syntax) #f) (global-extend1084 (quote core) (quote fluid-let-syntax) (lambda (e1864 r1865 w1866 s1867 mod1868) ((lambda (tmp1869) ((lambda (tmp1870) (if (if tmp1870 (apply (lambda (_1871 var1872 val1873 e11874 e21875) (valid-bound-ids?1111 var1872)) tmp1870) #f) (apply (lambda (_1877 var1878 val1879 e11880 e21881) (let ((names1882 (map (lambda (x1883) (id-var-name1108 x1883 w1866)) var1878))) (begin (for-each (lambda (id1885 n1886) (let ((t1887 (binding-type1078 (lookup1083 n1886 r1865 mod1868)))) (if (memv t1887 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1864 (source-wrap1115 id1885 w1866 s1867 mod1868))))) var1878 names1882) (chi-body1126 (cons e11880 e21881) (source-wrap1115 e1864 w1866 s1867 mod1868) (extend-env1080 names1882 (let ((trans-r1890 (macros-only-env1082 r1865))) (map (lambda (x1891) (cons (quote macro) (eval-local-transformer1129 (chi1122 x1891 trans-r1890 w1866 mod1868) mod1868))) val1879)) r1865) w1866 mod1868)))) tmp1870) ((lambda (_1893) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1115 e1864 w1866 s1867 mod1868))) tmp1869))) ($sc-dispatch tmp1869 (quote (any #(each (any any)) any . each-any))))) e1864))) (global-extend1084 (quote core) (quote quote) (lambda (e1894 r1895 w1896 s1897 mod1898) ((lambda (tmp1899) ((lambda (tmp1900) (if tmp1900 (apply (lambda (_1901 e1902) (build-data1064 s1897 (strip1133 e1902 w1896))) tmp1900) ((lambda (_1903) (syntax-violation (quote quote) "bad syntax" (source-wrap1115 e1894 w1896 s1897 mod1898))) tmp1899))) ($sc-dispatch tmp1899 (quote (any any))))) e1894))) (global-extend1084 (quote core) (quote syntax) (letrec ((regen1911 (lambda (x1912) (let ((t1913 (car x1912))) (if (memv t1913 (quote (ref))) (build-annotated1063 #f (cadr x1912)) (if (memv t1913 (quote (primitive))) (build-annotated1063 #f (cadr x1912)) (if (memv t1913 (quote (quote))) (build-data1064 #f (cadr x1912)) (if (memv t1913 (quote (lambda))) (build-annotated1063 #f (list (quote lambda) (cadr x1912) (regen1911 (caddr x1912)))) (if (memv t1913 (quote (map))) (let ((ls1914 (map regen1911 (cdr x1912)))) (build-annotated1063 #f (cons (if (fx=1057 (length ls1914) 2) (build-annotated1063 #f (quote map)) (build-annotated1063 #f (quote map))) ls1914))) (build-annotated1063 #f (cons (build-annotated1063 #f (car x1912)) (map regen1911 (cdr x1912)))))))))))) (gen-vector1910 (lambda (x1915) (cond ((eq? (car x1915) (quote list)) (cons (quote vector) (cdr x1915))) ((eq? (car x1915) (quote quote)) (list (quote quote) (list->vector (cadr x1915)))) (else (list (quote list->vector) x1915))))) (gen-append1909 (lambda (x1916 y1917) (if (equal? y1917 (quote (quote ()))) x1916 (list (quote append) x1916 y1917)))) (gen-cons1908 (lambda (x1918 y1919) (let ((t1920 (car y1919))) (if (memv t1920 (quote (quote))) (if (eq? (car x1918) (quote quote)) (list (quote quote) (cons (cadr x1918) (cadr y1919))) (if (eq? (cadr y1919) (quote ())) (list (quote list) x1918) (list (quote cons) x1918 y1919))) (if (memv t1920 (quote (list))) (cons (quote list) (cons x1918 (cdr y1919))) (list (quote cons) x1918 y1919)))))) (gen-map1907 (lambda (e1921 map-env1922) (let ((formals1923 (map cdr map-env1922)) (actuals1924 (map (lambda (x1925) (list (quote ref) (car x1925))) map-env1922))) (cond ((eq? (car e1921) (quote ref)) (car actuals1924)) ((and-map (lambda (x1926) (and (eq? (car x1926) (quote ref)) (memq (cadr x1926) formals1923))) (cdr e1921)) (cons (quote map) (cons (list (quote primitive) (car e1921)) (map (let ((r1927 (map cons formals1923 actuals1924))) (lambda (x1928) (cdr (assq (cadr x1928) r1927)))) (cdr e1921))))) (else (cons (quote map) (cons (list (quote lambda) formals1923 e1921) actuals1924))))))) (gen-mappend1906 (lambda (e1929 map-env1930) (list (quote apply) (quote (primitive append)) (gen-map1907 e1929 map-env1930)))) (gen-ref1905 (lambda (src1931 var1932 level1933 maps1934) (if (fx=1057 level1933 0) (values var1932 maps1934) (if (null? maps1934) (syntax-violation (quote syntax) "missing ellipsis" src1931) (call-with-values (lambda () (gen-ref1905 src1931 var1932 (fx-1056 level1933 1) (cdr maps1934))) (lambda (outer-var1935 outer-maps1936) (let ((b1937 (assq outer-var1935 (car maps1934)))) (if b1937 (values (cdr b1937) maps1934) (let ((inner-var1938 (gen-var1134 (quote tmp)))) (values inner-var1938 (cons (cons (cons outer-var1935 inner-var1938) (car maps1934)) outer-maps1936))))))))))) (gen-syntax1904 (lambda (src1939 e1940 r1941 maps1942 ellipsis?1943 mod1944) (if (id?1086 e1940) (let ((label1945 (id-var-name1108 e1940 (quote (()))))) (let ((b1946 (lookup1083 label1945 r1941 mod1944))) (if (eq? (binding-type1078 b1946) (quote syntax)) (call-with-values (lambda () (let ((var.lev1947 (binding-value1079 b1946))) (gen-ref1905 src1939 (car var.lev1947) (cdr var.lev1947) maps1942))) (lambda (var1948 maps1949) (values (list (quote ref) var1948) maps1949))) (if (ellipsis?1943 e1940) (syntax-violation (quote syntax) "misplaced ellipsis" src1939) (values (list (quote quote) e1940) maps1942))))) ((lambda (tmp1950) ((lambda (tmp1951) (if (if tmp1951 (apply (lambda (dots1952 e1953) (ellipsis?1943 dots1952)) tmp1951) #f) (apply (lambda (dots1954 e1955) (gen-syntax1904 src1939 e1955 r1941 maps1942 (lambda (x1956) #f) mod1944)) tmp1951) ((lambda (tmp1957) (if (if tmp1957 (apply (lambda (x1958 dots1959 y1960) (ellipsis?1943 dots1959)) tmp1957) #f) (apply (lambda (x1961 dots1962 y1963) (let f1964 ((y1965 y1963) (k1966 (lambda (maps1967) (call-with-values (lambda () (gen-syntax1904 src1939 x1961 r1941 (cons (quote ()) maps1967) ellipsis?1943 mod1944)) (lambda (x1968 maps1969) (if (null? (car maps1969)) (syntax-violation (quote syntax) "extra ellipsis" src1939) (values (gen-map1907 x1968 (car maps1969)) (cdr maps1969)))))))) ((lambda (tmp1970) ((lambda (tmp1971) (if (if tmp1971 (apply (lambda (dots1972 y1973) (ellipsis?1943 dots1972)) tmp1971) #f) (apply (lambda (dots1974 y1975) (f1964 y1975 (lambda (maps1976) (call-with-values (lambda () (k1966 (cons (quote ()) maps1976))) (lambda (x1977 maps1978) (if (null? (car maps1978)) (syntax-violation (quote syntax) "extra ellipsis" src1939) (values (gen-mappend1906 x1977 (car maps1978)) (cdr maps1978)))))))) tmp1971) ((lambda (_1979) (call-with-values (lambda () (gen-syntax1904 src1939 y1965 r1941 maps1942 ellipsis?1943 mod1944)) (lambda (y1980 maps1981) (call-with-values (lambda () (k1966 maps1981)) (lambda (x1982 maps1983) (values (gen-append1909 x1982 y1980) maps1983)))))) tmp1970))) ($sc-dispatch tmp1970 (quote (any . any))))) y1965))) tmp1957) ((lambda (tmp1984) (if tmp1984 (apply (lambda (x1985 y1986) (call-with-values (lambda () (gen-syntax1904 src1939 x1985 r1941 maps1942 ellipsis?1943 mod1944)) (lambda (x1987 maps1988) (call-with-values (lambda () (gen-syntax1904 src1939 y1986 r1941 maps1988 ellipsis?1943 mod1944)) (lambda (y1989 maps1990) (values (gen-cons1908 x1987 y1989) maps1990)))))) tmp1984) ((lambda (tmp1991) (if tmp1991 (apply (lambda (e11992 e21993) (call-with-values (lambda () (gen-syntax1904 src1939 (cons e11992 e21993) r1941 maps1942 ellipsis?1943 mod1944)) (lambda (e1995 maps1996) (values (gen-vector1910 e1995) maps1996)))) tmp1991) ((lambda (_1997) (values (list (quote quote) e1940) maps1942)) tmp1950))) ($sc-dispatch tmp1950 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1950 (quote (any . any)))))) ($sc-dispatch tmp1950 (quote (any any . any)))))) ($sc-dispatch tmp1950 (quote (any any))))) e1940))))) (lambda (e1998 r1999 w2000 s2001 mod2002) (let ((e2003 (source-wrap1115 e1998 w2000 s2001 mod2002))) ((lambda (tmp2004) ((lambda (tmp2005) (if tmp2005 (apply (lambda (_2006 x2007) (call-with-values (lambda () (gen-syntax1904 e2003 x2007 r1999 (quote ()) ellipsis?1131 mod2002)) (lambda (e2008 maps2009) (regen1911 e2008)))) tmp2005) ((lambda (_2010) (syntax-violation (quote syntax) "bad `syntax' form" e2003)) tmp2004))) ($sc-dispatch tmp2004 (quote (any any))))) e2003))))) (global-extend1084 (quote core) (quote lambda) (lambda (e2011 r2012 w2013 s2014 mod2015) ((lambda (tmp2016) ((lambda (tmp2017) (if tmp2017 (apply (lambda (_2018 c2019) (chi-lambda-clause1127 (source-wrap1115 e2011 w2013 s2014 mod2015) #f c2019 r2012 w2013 mod2015 (lambda (vars2020 docstring2021 body2022) (build-annotated1063 s2014 (cons (quote lambda) (cons vars2020 (append (if docstring2021 (list docstring2021) (quote ())) (list body2022)))))))) tmp2017) (syntax-violation #f "source expression failed to match any pattern" tmp2016))) ($sc-dispatch tmp2016 (quote (any . any))))) e2011))) (global-extend1084 (quote core) (quote let) (letrec ((chi-let2023 (lambda (e2024 r2025 w2026 s2027 mod2028 constructor2029 ids2030 vals2031 exps2032) (if (not (valid-bound-ids?1111 ids2030)) (syntax-violation (quote let) "duplicate bound variable" e2024) (let ((labels2033 (gen-labels1092 ids2030)) (new-vars2034 (map gen-var1134 ids2030))) (let ((nw2035 (make-binding-wrap1103 ids2030 labels2033 w2026)) (nr2036 (extend-var-env1081 labels2033 new-vars2034 r2025))) (constructor2029 s2027 new-vars2034 (map (lambda (x2037) (chi1122 x2037 r2025 w2026 mod2028)) vals2031) (chi-body1126 exps2032 (source-wrap1115 e2024 nw2035 s2027 mod2028) nr2036 nw2035 mod2028)))))))) (lambda (e2038 r2039 w2040 s2041 mod2042) ((lambda (tmp2043) ((lambda (tmp2044) (if tmp2044 (apply (lambda (_2045 id2046 val2047 e12048 e22049) (chi-let2023 e2038 r2039 w2040 s2041 mod2042 build-let1066 id2046 val2047 (cons e12048 e22049))) tmp2044) ((lambda (tmp2053) (if (if tmp2053 (apply (lambda (_2054 f2055 id2056 val2057 e12058 e22059) (id?1086 f2055)) tmp2053) #f) (apply (lambda (_2060 f2061 id2062 val2063 e12064 e22065) (chi-let2023 e2038 r2039 w2040 s2041 mod2042 build-named-let1067 (cons f2061 id2062) val2063 (cons e12064 e22065))) tmp2053) ((lambda (_2069) (syntax-violation (quote let) "bad let" (source-wrap1115 e2038 w2040 s2041 mod2042))) tmp2043))) ($sc-dispatch tmp2043 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2043 (quote (any #(each (any any)) any . each-any))))) e2038)))) (global-extend1084 (quote core) (quote letrec) (lambda (e2070 r2071 w2072 s2073 mod2074) ((lambda (tmp2075) ((lambda (tmp2076) (if tmp2076 (apply (lambda (_2077 id2078 val2079 e12080 e22081) (let ((ids2082 id2078)) (if (not (valid-bound-ids?1111 ids2082)) (syntax-violation (quote letrec) "duplicate bound variable" e2070) (let ((labels2084 (gen-labels1092 ids2082)) (new-vars2085 (map gen-var1134 ids2082))) (let ((w2086 (make-binding-wrap1103 ids2082 labels2084 w2072)) (r2087 (extend-var-env1081 labels2084 new-vars2085 r2071))) (build-letrec1068 s2073 new-vars2085 (map (lambda (x2088) (chi1122 x2088 r2087 w2086 mod2074)) val2079) (chi-body1126 (cons e12080 e22081) (source-wrap1115 e2070 w2086 s2073 mod2074) r2087 w2086 mod2074))))))) tmp2076) ((lambda (_2091) (syntax-violation (quote letrec) "bad letrec" (source-wrap1115 e2070 w2072 s2073 mod2074))) tmp2075))) ($sc-dispatch tmp2075 (quote (any #(each (any any)) any . each-any))))) e2070))) (global-extend1084 (quote core) (quote set!) (lambda (e2092 r2093 w2094 s2095 mod2096) ((lambda (tmp2097) ((lambda (tmp2098) (if (if tmp2098 (apply (lambda (_2099 id2100 val2101) (id?1086 id2100)) tmp2098) #f) (apply (lambda (_2102 id2103 val2104) (let ((val2105 (chi1122 val2104 r2093 w2094 mod2096)) (n2106 (id-var-name1108 id2103 w2094))) (let ((b2107 (lookup1083 n2106 r2093 mod2096))) (let ((t2108 (binding-type1078 b2107))) (if (memv t2108 (quote (lexical))) (build-annotated1063 s2095 (list (quote set!) (binding-value1079 b2107) val2105)) (if (memv t2108 (quote (global))) (build-annotated1063 s2095 (list (quote set!) (if mod2096 (make-module-ref (cdr mod2096) n2106 (car mod2096)) (make-module-ref mod2096 n2106 (quote bare))) val2105)) (if (memv t2108 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1114 id2103 w2094 mod2096)) (syntax-violation (quote set!) "bad set!" (source-wrap1115 e2092 w2094 s2095 mod2096))))))))) tmp2098) ((lambda (tmp2109) (if tmp2109 (apply (lambda (_2110 head2111 tail2112 val2113) (call-with-values (lambda () (syntax-type1120 head2111 r2093 (quote (())) #f #f mod2096)) (lambda (type2114 value2115 ee2116 ww2117 ss2118 modmod2119) (let ((t2120 type2114)) (if (memv t2120 (quote (module-ref))) (let ((val2121 (chi1122 val2113 r2093 w2094 mod2096))) (call-with-values (lambda () (value2115 (cons head2111 tail2112))) (lambda (id2123 mod2124) (build-annotated1063 s2095 (list (quote set!) (if mod2124 (make-module-ref (cdr mod2124) id2123 (car mod2124)) (make-module-ref mod2124 id2123 (quote bare))) val2121))))) (build-annotated1063 s2095 (cons (chi1122 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2111) r2093 w2094 mod2096) (map (lambda (e2125) (chi1122 e2125 r2093 w2094 mod2096)) (append tail2112 (list val2113)))))))))) tmp2109) ((lambda (_2127) (syntax-violation (quote set!) "bad set!" (source-wrap1115 e2092 w2094 s2095 mod2096))) tmp2097))) ($sc-dispatch tmp2097 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2097 (quote (any any any))))) e2092))) (global-extend1084 (quote module-ref) (quote @) (lambda (e2128) ((lambda (tmp2129) ((lambda (tmp2130) (if (if tmp2130 (apply (lambda (_2131 mod2132 id2133) (and (and-map id?1086 mod2132) (id?1086 id2133))) tmp2130) #f) (apply (lambda (_2135 mod2136 id2137) (values (syntax->datum id2137) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2136)))) tmp2130) (syntax-violation #f "source expression failed to match any pattern" tmp2129))) ($sc-dispatch tmp2129 (quote (any each-any any))))) e2128))) (global-extend1084 (quote module-ref) (quote @@) (lambda (e2139) ((lambda (tmp2140) ((lambda (tmp2141) (if (if tmp2141 (apply (lambda (_2142 mod2143 id2144) (and (and-map id?1086 mod2143) (id?1086 id2144))) tmp2141) #f) (apply (lambda (_2146 mod2147 id2148) (values (syntax->datum id2148) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2147)))) tmp2141) (syntax-violation #f "source expression failed to match any pattern" tmp2140))) ($sc-dispatch tmp2140 (quote (any each-any any))))) e2139))) (global-extend1084 (quote begin) (quote begin) (quote ())) (global-extend1084 (quote define) (quote define) (quote ())) (global-extend1084 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1084 (quote eval-when) (quote eval-when) (quote ())) (global-extend1084 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2153 (lambda (x2154 keys2155 clauses2156 r2157 mod2158) (if (null? clauses2156) (build-annotated1063 #f (list (build-annotated1063 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2154)) ((lambda (tmp2159) ((lambda (tmp2160) (if tmp2160 (apply (lambda (pat2161 exp2162) (if (and (id?1086 pat2161) (and-map (lambda (x2163) (not (free-id=?1109 pat2161 x2163))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2155))) (let ((labels2164 (list (gen-label1091))) (var2165 (gen-var1134 pat2161))) (build-annotated1063 #f (list (build-annotated1063 #f (list (quote lambda) (list var2165) (chi1122 exp2162 (extend-env1080 labels2164 (list (cons (quote syntax) (cons var2165 0))) r2157) (make-binding-wrap1103 (list pat2161) labels2164 (quote (()))) mod2158))) x2154))) (gen-clause2152 x2154 keys2155 (cdr clauses2156) r2157 pat2161 #t exp2162 mod2158))) tmp2160) ((lambda (tmp2166) (if tmp2166 (apply (lambda (pat2167 fender2168 exp2169) (gen-clause2152 x2154 keys2155 (cdr clauses2156) r2157 pat2167 fender2168 exp2169 mod2158)) tmp2166) ((lambda (_2170) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2156))) tmp2159))) ($sc-dispatch tmp2159 (quote (any any any)))))) ($sc-dispatch tmp2159 (quote (any any))))) (car clauses2156))))) (gen-clause2152 (lambda (x2171 keys2172 clauses2173 r2174 pat2175 fender2176 exp2177 mod2178) (call-with-values (lambda () (convert-pattern2150 pat2175 keys2172)) (lambda (p2179 pvars2180) (cond ((not (distinct-bound-ids?1112 (map car pvars2180))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2175)) ((not (and-map (lambda (x2181) (not (ellipsis?1131 (car x2181)))) pvars2180)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2175)) (else (let ((y2182 (gen-var1134 (quote tmp)))) (build-annotated1063 #f (list (build-annotated1063 #f (list (quote lambda) (list y2182) (let ((y2183 (build-annotated1063 #f y2182))) (build-annotated1063 #f (list (quote if) ((lambda (tmp2184) ((lambda (tmp2185) (if tmp2185 (apply (lambda () y2183) tmp2185) ((lambda (_2186) (build-annotated1063 #f (list (quote if) y2183 (build-dispatch-call2151 pvars2180 fender2176 y2183 r2174 mod2178) (build-data1064 #f #f)))) tmp2184))) ($sc-dispatch tmp2184 (quote #(atom #t))))) fender2176) (build-dispatch-call2151 pvars2180 exp2177 y2183 r2174 mod2178) (gen-syntax-case2153 x2171 keys2172 clauses2173 r2174 mod2178)))))) (if (eq? p2179 (quote any)) (build-annotated1063 #f (list (build-annotated1063 #f (quote list)) x2171)) (build-annotated1063 #f (list (build-annotated1063 #f (quote $sc-dispatch)) x2171 (build-data1064 #f p2179))))))))))))) (build-dispatch-call2151 (lambda (pvars2187 exp2188 y2189 r2190 mod2191) (let ((ids2192 (map car pvars2187)) (levels2193 (map cdr pvars2187))) (let ((labels2194 (gen-labels1092 ids2192)) (new-vars2195 (map gen-var1134 ids2192))) (build-annotated1063 #f (list (build-annotated1063 #f (quote apply)) (build-annotated1063 #f (list (quote lambda) new-vars2195 (chi1122 exp2188 (extend-env1080 labels2194 (map (lambda (var2196 level2197) (cons (quote syntax) (cons var2196 level2197))) new-vars2195 (map cdr pvars2187)) r2190) (make-binding-wrap1103 ids2192 labels2194 (quote (()))) mod2191))) y2189)))))) (convert-pattern2150 (lambda (pattern2198 keys2199) (let cvt2200 ((p2201 pattern2198) (n2202 0) (ids2203 (quote ()))) (if (id?1086 p2201) (if (bound-id-member?1113 p2201 keys2199) (values (vector (quote free-id) p2201) ids2203) (values (quote any) (cons (cons p2201 n2202) ids2203))) ((lambda (tmp2204) ((lambda (tmp2205) (if (if tmp2205 (apply (lambda (x2206 dots2207) (ellipsis?1131 dots2207)) tmp2205) #f) (apply (lambda (x2208 dots2209) (call-with-values (lambda () (cvt2200 x2208 (fx+1055 n2202 1) ids2203)) (lambda (p2210 ids2211) (values (if (eq? p2210 (quote any)) (quote each-any) (vector (quote each) p2210)) ids2211)))) tmp2205) ((lambda (tmp2212) (if tmp2212 (apply (lambda (x2213 y2214) (call-with-values (lambda () (cvt2200 y2214 n2202 ids2203)) (lambda (y2215 ids2216) (call-with-values (lambda () (cvt2200 x2213 n2202 ids2216)) (lambda (x2217 ids2218) (values (cons x2217 y2215) ids2218)))))) tmp2212) ((lambda (tmp2219) (if tmp2219 (apply (lambda () (values (quote ()) ids2203)) tmp2219) ((lambda (tmp2220) (if tmp2220 (apply (lambda (x2221) (call-with-values (lambda () (cvt2200 x2221 n2202 ids2203)) (lambda (p2223 ids2224) (values (vector (quote vector) p2223) ids2224)))) tmp2220) ((lambda (x2225) (values (vector (quote atom) (strip1133 p2201 (quote (())))) ids2203)) tmp2204))) ($sc-dispatch tmp2204 (quote #(vector each-any)))))) ($sc-dispatch tmp2204 (quote ()))))) ($sc-dispatch tmp2204 (quote (any . any)))))) ($sc-dispatch tmp2204 (quote (any any))))) p2201)))))) (lambda (e2226 r2227 w2228 s2229 mod2230) (let ((e2231 (source-wrap1115 e2226 w2228 s2229 mod2230))) ((lambda (tmp2232) ((lambda (tmp2233) (if tmp2233 (apply (lambda (_2234 val2235 key2236 m2237) (if (and-map (lambda (x2238) (and (id?1086 x2238) (not (ellipsis?1131 x2238)))) key2236) (let ((x2240 (gen-var1134 (quote tmp)))) (build-annotated1063 s2229 (list (build-annotated1063 #f (list (quote lambda) (list x2240) (gen-syntax-case2153 (build-annotated1063 #f x2240) key2236 m2237 r2227 mod2230))) (chi1122 val2235 r2227 (quote (())) mod2230)))) (syntax-violation (quote syntax-case) "invalid literals list" e2231))) tmp2233) (syntax-violation #f "source expression failed to match any pattern" tmp2232))) ($sc-dispatch tmp2232 (quote (any any each-any . each-any))))) e2231))))) (set! sc-expand (let ((m2243 (quote e)) (esew2244 (quote (eval)))) (lambda (x2246 . rest2245) (if (and (pair? x2246) (equal? (car x2246) noexpand1054)) (cadr x2246) (chi-top1121 x2246 (quote ()) (quote ((top))) (if (null? rest2245) m2243 (car rest2245)) (if (or (null? rest2245) (null? (cdr rest2245))) esew2244 (cadr rest2245)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2247) (nonsymbol-id?1085 x2247))) (set! datum->syntax (lambda (id2248 datum2249) (make-syntax-object1069 datum2249 (syntax-object-wrap1072 id2248) #f))) (set! syntax->datum (lambda (x2250) (strip1133 x2250 (quote (()))))) (set! generate-temporaries (lambda (ls2251) (begin (let ((x2252 ls2251)) (if (not (list? x2252)) (syntax-violation (quote generate-temporaries) "invalid argument" x2252))) (map (lambda (x2253) (wrap1114 (gensym) (quote ((top))) #f)) ls2251)))) (set! free-identifier=? (lambda (x2254 y2255) (begin (let ((x2256 x2254)) (if (not (nonsymbol-id?1085 x2256)) (syntax-violation (quote free-identifier=?) "invalid argument" x2256))) (let ((x2257 y2255)) (if (not (nonsymbol-id?1085 x2257)) (syntax-violation (quote free-identifier=?) "invalid argument" x2257))) (free-id=?1109 x2254 y2255)))) (set! bound-identifier=? (lambda (x2258 y2259) (begin (let ((x2260 x2258)) (if (not (nonsymbol-id?1085 x2260)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2260))) (let ((x2261 y2259)) (if (not (nonsymbol-id?1085 x2261)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2261))) (bound-id=?1110 x2258 y2259)))) (set! syntax-violation (lambda (who2265 message2264 form2263 . subform2262) (begin (let ((x2266 who2265)) (if (not ((lambda (x2267) (or (not x2267) (string? x2267) (symbol? x2267))) x2266)) (syntax-violation (quote syntax-violation) "invalid argument" x2266))) (let ((x2268 message2264)) (if (not (string? x2268)) (syntax-violation (quote syntax-violation) "invalid argument" x2268))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2265 "~a: " "") "~a " (if (null? subform2262) "in ~a" "in subform `~s' of `~s'")) (let ((tail2269 (cons message2264 (map (lambda (x2270) (strip1133 x2270 (quote (())))) (append subform2262 (list form2263)))))) (if who2265 (cons who2265 tail2269) tail2269)) #f)))) (letrec ((match2275 (lambda (e2276 p2277 w2278 r2279 mod2280) (cond ((not r2279) #f) ((eq? p2277 (quote any)) (cons (wrap1114 e2276 w2278 mod2280) r2279)) ((syntax-object?1070 e2276) (match*2274 (let ((e2281 (syntax-object-expression1071 e2276))) (if (annotation? e2281) (annotation-expression e2281) e2281)) p2277 (join-wraps1105 w2278 (syntax-object-wrap1072 e2276)) r2279 (syntax-object-module1073 e2276))) (else (match*2274 (let ((e2282 e2276)) (if (annotation? e2282) (annotation-expression e2282) e2282)) p2277 w2278 r2279 mod2280))))) (match*2274 (lambda (e2283 p2284 w2285 r2286 mod2287) (cond ((null? p2284) (and (null? e2283) r2286)) ((pair? p2284) (and (pair? e2283) (match2275 (car e2283) (car p2284) w2285 (match2275 (cdr e2283) (cdr p2284) w2285 r2286 mod2287) mod2287))) ((eq? p2284 (quote each-any)) (let ((l2288 (match-each-any2272 e2283 w2285 mod2287))) (and l2288 (cons l2288 r2286)))) (else (let ((t2289 (vector-ref p2284 0))) (if (memv t2289 (quote (each))) (if (null? e2283) (match-empty2273 (vector-ref p2284 1) r2286) (let ((l2290 (match-each2271 e2283 (vector-ref p2284 1) w2285 mod2287))) (and l2290 (let collect2291 ((l2292 l2290)) (if (null? (car l2292)) r2286 (cons (map car l2292) (collect2291 (map cdr l2292)))))))) (if (memv t2289 (quote (free-id))) (and (id?1086 e2283) (free-id=?1109 (wrap1114 e2283 w2285 mod2287) (vector-ref p2284 1)) r2286) (if (memv t2289 (quote (atom))) (and (equal? (vector-ref p2284 1) (strip1133 e2283 w2285)) r2286) (if (memv t2289 (quote (vector))) (and (vector? e2283) (match2275 (vector->list e2283) (vector-ref p2284 1) w2285 r2286 mod2287))))))))))) (match-empty2273 (lambda (p2293 r2294) (cond ((null? p2293) r2294) ((eq? p2293 (quote any)) (cons (quote ()) r2294)) ((pair? p2293) (match-empty2273 (car p2293) (match-empty2273 (cdr p2293) r2294))) ((eq? p2293 (quote each-any)) (cons (quote ()) r2294)) (else (let ((t2295 (vector-ref p2293 0))) (if (memv t2295 (quote (each))) (match-empty2273 (vector-ref p2293 1) r2294) (if (memv t2295 (quote (free-id atom))) r2294 (if (memv t2295 (quote (vector))) (match-empty2273 (vector-ref p2293 1) r2294))))))))) (match-each-any2272 (lambda (e2296 w2297 mod2298) (cond ((annotation? e2296) (match-each-any2272 (annotation-expression e2296) w2297 mod2298)) ((pair? e2296) (let ((l2299 (match-each-any2272 (cdr e2296) w2297 mod2298))) (and l2299 (cons (wrap1114 (car e2296) w2297 mod2298) l2299)))) ((null? e2296) (quote ())) ((syntax-object?1070 e2296) (match-each-any2272 (syntax-object-expression1071 e2296) (join-wraps1105 w2297 (syntax-object-wrap1072 e2296)) mod2298)) (else #f)))) (match-each2271 (lambda (e2300 p2301 w2302 mod2303) (cond ((annotation? e2300) (match-each2271 (annotation-expression e2300) p2301 w2302 mod2303)) ((pair? e2300) (let ((first2304 (match2275 (car e2300) p2301 w2302 (quote ()) mod2303))) (and first2304 (let ((rest2305 (match-each2271 (cdr e2300) p2301 w2302 mod2303))) (and rest2305 (cons first2304 rest2305)))))) ((null? e2300) (quote ())) ((syntax-object?1070 e2300) (match-each2271 (syntax-object-expression1071 e2300) p2301 (join-wraps1105 w2302 (syntax-object-wrap1072 e2300)) (syntax-object-module1073 e2300))) (else #f))))) (set! $sc-dispatch (lambda (e2306 p2307) (cond ((eq? p2307 (quote any)) (list e2306)) ((syntax-object?1070 e2306) (match*2274 (let ((e2308 (syntax-object-expression1071 e2306))) (if (annotation? e2308) (annotation-expression e2308) e2308)) p2307 (syntax-object-wrap1072 e2306) (quote ()) (syntax-object-module1073 e2306))) (else (match*2274 (let ((e2309 e2306)) (if (annotation? e2309) (annotation-expression e2309) e2309)) p2307 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2310) ((lambda (tmp2311) ((lambda (tmp2312) (if tmp2312 (apply (lambda (_2313 e12314 e22315) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12314 e22315))) tmp2312) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 out2319 in2320 e12321 e22322) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2320 (quote ()) (list out2319 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12321 e22322))))) tmp2317) ((lambda (tmp2324) (if tmp2324 (apply (lambda (_2325 out2326 in2327 e12328 e22329) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2327) (quote ()) (list out2326 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12328 e22329))))) tmp2324) (syntax-violation #f "source expression failed to match any pattern" tmp2311))) ($sc-dispatch tmp2311 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2311 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2311 (quote (any () any . each-any))))) x2310)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2333) ((lambda (tmp2334) ((lambda (tmp2335) (if tmp2335 (apply (lambda (_2336 k2337 keyword2338 pattern2339 template2340) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2337 (map (lambda (tmp2343 tmp2342) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2342) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2343))) template2340 pattern2339)))))) tmp2335) (syntax-violation #f "source expression failed to match any pattern" tmp2334))) ($sc-dispatch tmp2334 (quote (any each-any . #(each ((any . any) any))))))) x2333)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2344) ((lambda (tmp2345) ((lambda (tmp2346) (if (if tmp2346 (apply (lambda (let*2347 x2348 v2349 e12350 e22351) (and-map identifier? x2348)) tmp2346) #f) (apply (lambda (let*2353 x2354 v2355 e12356 e22357) (let f2358 ((bindings2359 (map list x2354 v2355))) (if (null? bindings2359) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12356 e22357))) ((lambda (tmp2363) ((lambda (tmp2364) (if tmp2364 (apply (lambda (body2365 binding2366) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2366) body2365)) tmp2364) (syntax-violation #f "source expression failed to match any pattern" tmp2363))) ($sc-dispatch tmp2363 (quote (any any))))) (list (f2358 (cdr bindings2359)) (car bindings2359)))))) tmp2346) (syntax-violation #f "source expression failed to match any pattern" tmp2345))) ($sc-dispatch tmp2345 (quote (any #(each (any any)) any . each-any))))) x2344)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2367) ((lambda (tmp2368) ((lambda (tmp2369) (if tmp2369 (apply (lambda (_2370 var2371 init2372 step2373 e02374 e12375 c2376) ((lambda (tmp2377) ((lambda (tmp2378) (if tmp2378 (apply (lambda (step2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2371 init2372) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02374) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2376 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2379))))))) tmp2381) ((lambda (tmp2386) (if tmp2386 (apply (lambda (e12387 e22388) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2371 init2372) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02374 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12387 e22388)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2376 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2379))))))) tmp2386) (syntax-violation #f "source expression failed to match any pattern" tmp2380))) ($sc-dispatch tmp2380 (quote (any . each-any)))))) ($sc-dispatch tmp2380 (quote ())))) e12375)) tmp2378) (syntax-violation #f "source expression failed to match any pattern" tmp2377))) ($sc-dispatch tmp2377 (quote each-any)))) (map (lambda (v2395 s2396) ((lambda (tmp2397) ((lambda (tmp2398) (if tmp2398 (apply (lambda () v2395) tmp2398) ((lambda (tmp2399) (if tmp2399 (apply (lambda (e2400) e2400) tmp2399) ((lambda (_2401) (syntax-violation (quote do) "bad step expression" orig-x2367 s2396)) tmp2397))) ($sc-dispatch tmp2397 (quote (any)))))) ($sc-dispatch tmp2397 (quote ())))) s2396)) var2371 step2373))) tmp2369) (syntax-violation #f "source expression failed to match any pattern" tmp2368))) ($sc-dispatch tmp2368 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2367)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2404 (lambda (x2408 y2409) ((lambda (tmp2410) ((lambda (tmp2411) (if tmp2411 (apply (lambda (x2412 y2413) ((lambda (tmp2414) ((lambda (tmp2415) (if tmp2415 (apply (lambda (dy2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (dx2419) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2419 dy2416))) tmp2418) ((lambda (_2420) (if (null? dy2416) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2412) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2412 y2413))) tmp2417))) ($sc-dispatch tmp2417 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2412)) tmp2415) ((lambda (tmp2421) (if tmp2421 (apply (lambda (stuff2422) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2412 stuff2422))) tmp2421) ((lambda (else2423) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2412 y2413)) tmp2414))) ($sc-dispatch tmp2414 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2414 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2413)) tmp2411) (syntax-violation #f "source expression failed to match any pattern" tmp2410))) ($sc-dispatch tmp2410 (quote (any any))))) (list x2408 y2409)))) (quasiappend2405 (lambda (x2424 y2425) ((lambda (tmp2426) ((lambda (tmp2427) (if tmp2427 (apply (lambda (x2428 y2429) ((lambda (tmp2430) ((lambda (tmp2431) (if tmp2431 (apply (lambda () x2428) tmp2431) ((lambda (_2432) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2428 y2429)) tmp2430))) ($sc-dispatch tmp2430 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2429)) tmp2427) (syntax-violation #f "source expression failed to match any pattern" tmp2426))) ($sc-dispatch tmp2426 (quote (any any))))) (list x2424 y2425)))) (quasivector2406 (lambda (x2433) ((lambda (tmp2434) ((lambda (x2435) ((lambda (tmp2436) ((lambda (tmp2437) (if tmp2437 (apply (lambda (x2438) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2438))) tmp2437) ((lambda (tmp2440) (if tmp2440 (apply (lambda (x2441) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2441)) tmp2440) ((lambda (_2443) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2435)) tmp2436))) ($sc-dispatch tmp2436 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2436 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2435)) tmp2434)) x2433))) (quasi2407 (lambda (p2444 lev2445) ((lambda (tmp2446) ((lambda (tmp2447) (if tmp2447 (apply (lambda (p2448) (if (= lev2445 0) p2448 (quasicons2404 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2407 (list p2448) (- lev2445 1))))) tmp2447) ((lambda (tmp2449) (if tmp2449 (apply (lambda (p2450 q2451) (if (= lev2445 0) (quasiappend2405 p2450 (quasi2407 q2451 lev2445)) (quasicons2404 (quasicons2404 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2407 (list p2450) (- lev2445 1))) (quasi2407 q2451 lev2445)))) tmp2449) ((lambda (tmp2452) (if tmp2452 (apply (lambda (p2453) (quasicons2404 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2407 (list p2453) (+ lev2445 1)))) tmp2452) ((lambda (tmp2454) (if tmp2454 (apply (lambda (p2455 q2456) (quasicons2404 (quasi2407 p2455 lev2445) (quasi2407 q2456 lev2445))) tmp2454) ((lambda (tmp2457) (if tmp2457 (apply (lambda (x2458) (quasivector2406 (quasi2407 x2458 lev2445))) tmp2457) ((lambda (p2460) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2460)) tmp2446))) ($sc-dispatch tmp2446 (quote #(vector each-any)))))) ($sc-dispatch tmp2446 (quote (any . any)))))) ($sc-dispatch tmp2446 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2446 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2446 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2444)))) (lambda (x2461) ((lambda (tmp2462) ((lambda (tmp2463) (if tmp2463 (apply (lambda (_2464 e2465) (quasi2407 e2465 0)) tmp2463) (syntax-violation #f "source expression failed to match any pattern" tmp2462))) ($sc-dispatch tmp2462 (quote (any any))))) x2461))))) +(define include (make-syncase-macro (quote macro) (lambda (x2466) (letrec ((read-file2467 (lambda (fn2468 k2469) (let ((p2470 (open-input-file fn2468))) (let f2471 ((x2472 (read p2470))) (if (eof-object? x2472) (begin (close-input-port p2470) (quote ())) (cons (datum->syntax k2469 x2472) (f2471 (read p2470))))))))) ((lambda (tmp2473) ((lambda (tmp2474) (if tmp2474 (apply (lambda (k2475 filename2476) (let ((fn2477 (syntax->datum filename2476))) ((lambda (tmp2478) ((lambda (tmp2479) (if tmp2479 (apply (lambda (exp2480) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2480)) tmp2479) (syntax-violation #f "source expression failed to match any pattern" tmp2478))) ($sc-dispatch tmp2478 (quote each-any)))) (read-file2467 fn2477 k2475)))) tmp2474) (syntax-violation #f "source expression failed to match any pattern" tmp2473))) ($sc-dispatch tmp2473 (quote (any any))))) x2466))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2482) ((lambda (tmp2483) ((lambda (tmp2484) (if tmp2484 (apply (lambda (_2485 e2486) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2482)) tmp2484) (syntax-violation #f "source expression failed to match any pattern" tmp2483))) ($sc-dispatch tmp2483 (quote (any any))))) x2482)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2487) ((lambda (tmp2488) ((lambda (tmp2489) (if tmp2489 (apply (lambda (_2490 e2491) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2487)) tmp2489) (syntax-violation #f "source expression failed to match any pattern" tmp2488))) ($sc-dispatch tmp2488 (quote (any any))))) x2487)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2492) ((lambda (tmp2493) ((lambda (tmp2494) (if tmp2494 (apply (lambda (_2495 e2496 m12497 m22498) ((lambda (tmp2499) ((lambda (body2500) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2496)) body2500)) tmp2499)) (let f2501 ((clause2502 m12497) (clauses2503 m22498)) (if (null? clauses2503) ((lambda (tmp2505) ((lambda (tmp2506) (if tmp2506 (apply (lambda (e12507 e22508) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12507 e22508))) tmp2506) ((lambda (tmp2510) (if tmp2510 (apply (lambda (k2511 e12512 e22513) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2511)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12512 e22513)))) tmp2510) ((lambda (_2516) (syntax-violation (quote case) "bad clause" x2492 clause2502)) tmp2505))) ($sc-dispatch tmp2505 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2505 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2502) ((lambda (tmp2517) ((lambda (rest2518) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (k2521 e12522 e22523) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2521)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12522 e22523)) rest2518)) tmp2520) ((lambda (_2526) (syntax-violation (quote case) "bad clause" x2492 clause2502)) tmp2519))) ($sc-dispatch tmp2519 (quote (each-any any . each-any))))) clause2502)) tmp2517)) (f2501 (car clauses2503) (cdr clauses2503))))))) tmp2494) (syntax-violation #f "source expression failed to match any pattern" tmp2493))) ($sc-dispatch tmp2493 (quote (any any any . each-any))))) x2492)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2527) ((lambda (tmp2528) ((lambda (tmp2529) (if tmp2529 (apply (lambda (_2530 e2531) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2531)) (list (cons _2530 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2531 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2529) (syntax-violation #f "source expression failed to match any pattern" tmp2528))) ($sc-dispatch tmp2528 (quote (any any))))) x2527)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 9329e6fbf..b573cc8af 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1976,14 +1976,6 @@ ;;; expanded, and the expanded definitions are also residualized into ;;; the object file if we are compiling a file. (set! sc-expand - (let ((m 'e) (esew '(eval))) - (lambda (x) - (if (and (pair? x) (equal? (car x) noexpand)) - (cadr x) - (chi-top x null-env top-wrap m esew - (cons 'hygiene (module-name (current-module)))))))) - -(set! sc-expand3 (let ((m 'e) (esew '(eval))) (lambda (x . rest) (if (and (pair? x) (equal? (car x) noexpand)) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 689770e8f..5ff16b932 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -69,7 +69,7 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (let ((x (sc-expand3 x 'c '(compile load eval)))) + (let ((x (sc-expand x 'c '(compile load eval)))) (let ((x (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))) (cenv (make-cenv (current-module) From 71f46dbd5ecf62809c2aa475b6f5742993ada0b9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 May 2009 11:57:36 +0200 Subject: [PATCH 092/375] sc-expand in compile mode produces (ice-9 expand-support) structures * module/ice-9/psyntax.scm (*mode*): New moving part, a fluid. (sc-expand): Dynamically bind *mode* to the expansion mode. (build-global-reference): Change to be a procedure instead of local syntax. Import the logic about when to make a @ or @@ form to here, from boot-9.scm. If we are compiling, build output using (ice-9 expand-support)'s make-module-ref, otherwise just making the familiar s-expressions. (This will allow us to correctly expand in modules in which @ or @@ are not bound, at least when we are compiling.) (build-global-assignment): Use the result of build-global-reference. A bit hacky, but hey. (top-level-eval-hook, local-eval-hook): Strip expansion structures before evalling. * module/ice-9/boot-9.scm (make-module-ref): Remove, this logic is now back in psyntax.scm. * module/ice-9/compile-psyntax.scm (source): Since we expand in compile mode, we need to strip expansion structures. * module/ice-9/expand-support.scm (strip-expansion-structures): Remove the logic about whether and how to strip @/@@ from here, as it's part of psyntax now. * module/ice-9/psyntax-pp.scm: Regenerated. * module/language/scheme/compile-ghil.scm (compile-ghil): Strip expansion structures -- for now. In the future, we might translate directly from these structures into GHIL. --- module/ice-9/boot-9.scm | 17 ----- module/ice-9/compile-psyntax.scm | 4 +- module/ice-9/expand-support.scm | 16 +---- module/ice-9/psyntax-pp.scm | 22 +++--- module/ice-9/psyntax.scm | 90 ++++++++++++++++--------- module/language/scheme/compile-ghil.scm | 4 +- 6 files changed, 80 insertions(+), 73 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index d8e1267a8..ae6aa9f73 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -184,23 +184,6 @@ (define (resolve-module . args) #f) -;; Output hook for syncase. It's here because we want to be able to -;; replace its definition, for compiling; but that isn't implemented -;; yet. -(define (make-module-ref mod var kind) - (case kind - ((public) (if mod `(@ ,mod ,var) var)) - ((private) (if (and mod (not (equal? mod (module-name (current-module))))) - `(@@ ,mod ,var) - var)) - ((bare) var) - ((hygiene) (if (and mod - (not (equal? mod (module-name (current-module)))) - (module-variable (resolve-module mod) var)) - `(@@ ,mod ,var) - var)) - (else (error "foo" mod var kind)))) - ;; Input hook to syncase -- so that we might be able to pass annotated ;; expressions in. Currently disabled. Maybe we should just use ;; source-properties directly. diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 3a8a4fad9..853586e12 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,3 +1,4 @@ +(use-modules (ice-9 expand-support)) (let ((source (list-ref (command-line) 1)) (target (list-ref (command-line) 2))) (let ((in (open-input-file source)) @@ -11,7 +12,8 @@ (close-port out) (close-port in)) (begin - (write (sc-expand x 'c '(compile load eval)) + (write (strip-expansion-structures + (sc-expand x 'c '(compile load eval))) out) (newline out) (loop (read in)))))) diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm index 372d959a5..5215c2256 100644 --- a/module/ice-9/expand-support.scm +++ b/module/ice-9/expand-support.scm @@ -149,19 +149,9 @@ (set-source-properties! e source)) e)) ((module-ref? e) - (cond - ((or (not (module-ref-modname e)) - (eq? (module-ref-modname e) - (module-name (current-module))) - (and (not (module-ref-public? e)) - (not (module-variable - (resolve-module (module-ref-modname e)) - (module-ref-symbol e))))) - (module-ref-symbol e)) - (else - `(,(if (module-ref-public? e) '@ '@@) - ,(module-ref-modname e) - ,(module-ref-symbol e))))) + `(,(if (module-ref-public? e) '@ '@@) + ,(module-ref-modname e) + ,(module-ref-symbol e))) ((lexical? e) (lexical-gensym e)) ((record? e) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 2ad36491f..fa55048f3 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*1002 (lambda (f1042 first1041 . rest1040) (or (null? first1041) (if (null? rest1040) (let andmap1043 ((first1044 first1041)) (let ((x1045 (car first1044)) (first1046 (cdr first1044))) (if (null? first1046) (f1042 x1045) (and (f1042 x1045) (andmap1043 first1046))))) (let andmap1047 ((first1048 first1041) (rest1049 rest1040)) (let ((x1050 (car first1048)) (xr1051 (map car rest1049)) (first1052 (cdr first1048)) (rest1053 (map cdr rest1049))) (if (null? first1052) (apply f1042 (cons x1050 xr1051)) (and (apply f1042 (cons x1050 xr1051)) (andmap1047 first1052 rest1053)))))))))) (letrec ((lambda-var-list1135 (lambda (vars1340) (let lvl1341 ((vars1342 vars1340) (ls1343 (quote ())) (w1344 (quote (())))) (cond ((pair? vars1342) (lvl1341 (cdr vars1342) (cons (wrap1114 (car vars1342) w1344 #f) ls1343) w1344)) ((id?1086 vars1342) (cons (wrap1114 vars1342 w1344 #f) ls1343)) ((null? vars1342) ls1343) ((syntax-object?1070 vars1342) (lvl1341 (syntax-object-expression1071 vars1342) ls1343 (join-wraps1105 w1344 (syntax-object-wrap1072 vars1342)))) ((annotation? vars1342) (lvl1341 (annotation-expression vars1342) ls1343 w1344)) (else (cons vars1342 ls1343)))))) (gen-var1134 (lambda (id1345) (let ((id1346 (if (syntax-object?1070 id1345) (syntax-object-expression1071 id1345) id1345))) (if (annotation? id1346) (build-annotated1063 (annotation-source id1346) (gensym (symbol->string (annotation-expression id1346)))) (build-annotated1063 #f (gensym (symbol->string id1346))))))) (strip1133 (lambda (x1347 w1348) (if (memq (quote top) (wrap-marks1089 w1348)) (if (or (annotation? x1347) (and (pair? x1347) (annotation? (car x1347)))) (strip-annotation1132 x1347 #f) x1347) (let f1349 ((x1350 x1347)) (cond ((syntax-object?1070 x1350) (strip1133 (syntax-object-expression1071 x1350) (syntax-object-wrap1072 x1350))) ((pair? x1350) (let ((a1351 (f1349 (car x1350))) (d1352 (f1349 (cdr x1350)))) (if (and (eq? a1351 (car x1350)) (eq? d1352 (cdr x1350))) x1350 (cons a1351 d1352)))) ((vector? x1350) (let ((old1353 (vector->list x1350))) (let ((new1354 (map f1349 old1353))) (if (and-map*1002 eq? old1353 new1354) x1350 (list->vector new1354))))) (else x1350)))))) (strip-annotation1132 (lambda (x1355 parent1356) (cond ((pair? x1355) (let ((new1357 (cons #f #f))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1357)) (set-car! new1357 (strip-annotation1132 (car x1355) #f)) (set-cdr! new1357 (strip-annotation1132 (cdr x1355) #f)) new1357))) ((annotation? x1355) (or (annotation-stripped x1355) (strip-annotation1132 (annotation-expression x1355) x1355))) ((vector? x1355) (let ((new1358 (make-vector (vector-length x1355)))) (begin (if parent1356 (set-annotation-stripped! parent1356 new1358)) (let loop1359 ((i1360 (- (vector-length x1355) 1))) (unless (fx<1058 i1360 0) (vector-set! new1358 i1360 (strip-annotation1132 (vector-ref x1355 i1360) #f)) (loop1359 (fx-1056 i1360 1)))) new1358))) (else x1355)))) (ellipsis?1131 (lambda (x1361) (and (nonsymbol-id?1085 x1361) (free-id=?1109 x1361 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1130 (lambda () (build-annotated1063 #f (cons (build-annotated1063 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer1129 (lambda (expanded1362 mod1363) (let ((p1364 (local-eval-hook1060 expanded1362 mod1363))) (if (procedure? p1364) p1364 (syntax-violation #f "nonprocedure transformer" p1364))))) (chi-local-syntax1128 (lambda (rec?1365 e1366 r1367 w1368 s1369 mod1370 k1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 id1375 val1376 e11377 e21378) (let ((ids1379 id1375)) (if (not (valid-bound-ids?1111 ids1379)) (syntax-violation #f "duplicate bound keyword" e1366) (let ((labels1381 (gen-labels1092 ids1379))) (let ((new-w1382 (make-binding-wrap1103 ids1379 labels1381 w1368))) (k1371 (cons e11377 e21378) (extend-env1080 labels1381 (let ((w1384 (if rec?1365 new-w1382 w1368)) (trans-r1385 (macros-only-env1082 r1367))) (map (lambda (x1386) (cons (quote macro) (eval-local-transformer1129 (chi1122 x1386 trans-r1385 w1384 mod1370) mod1370))) val1376)) r1367) new-w1382 s1369 mod1370)))))) tmp1373) ((lambda (_1388) (syntax-violation #f "bad local syntax definition" (source-wrap1115 e1366 w1368 s1369 mod1370))) tmp1372))) ($sc-dispatch tmp1372 (quote (any #(each (any any)) any . each-any))))) e1366))) (chi-lambda-clause1127 (lambda (e1389 docstring1390 c1391 r1392 w1393 mod1394 k1395) ((lambda (tmp1396) ((lambda (tmp1397) (if (if tmp1397 (apply (lambda (args1398 doc1399 e11400 e21401) (and (string? (syntax->datum doc1399)) (not docstring1390))) tmp1397) #f) (apply (lambda (args1402 doc1403 e11404 e21405) (chi-lambda-clause1127 e1389 doc1403 (cons args1402 (cons e11404 e21405)) r1392 w1393 mod1394 k1395)) tmp1397) ((lambda (tmp1407) (if tmp1407 (apply (lambda (id1408 e11409 e21410) (let ((ids1411 id1408)) (if (not (valid-bound-ids?1111 ids1411)) (syntax-violation (quote lambda) "invalid parameter list" e1389) (let ((labels1413 (gen-labels1092 ids1411)) (new-vars1414 (map gen-var1134 ids1411))) (k1395 new-vars1414 docstring1390 (chi-body1126 (cons e11409 e21410) e1389 (extend-var-env1081 labels1413 new-vars1414 r1392) (make-binding-wrap1103 ids1411 labels1413 w1393) mod1394)))))) tmp1407) ((lambda (tmp1416) (if tmp1416 (apply (lambda (ids1417 e11418 e21419) (let ((old-ids1420 (lambda-var-list1135 ids1417))) (if (not (valid-bound-ids?1111 old-ids1420)) (syntax-violation (quote lambda) "invalid parameter list" e1389) (let ((labels1421 (gen-labels1092 old-ids1420)) (new-vars1422 (map gen-var1134 old-ids1420))) (k1395 (let f1423 ((ls11424 (cdr new-vars1422)) (ls21425 (car new-vars1422))) (if (null? ls11424) ls21425 (f1423 (cdr ls11424) (cons (car ls11424) ls21425)))) docstring1390 (chi-body1126 (cons e11418 e21419) e1389 (extend-var-env1081 labels1421 new-vars1422 r1392) (make-binding-wrap1103 old-ids1420 labels1421 w1393) mod1394)))))) tmp1416) ((lambda (_1427) (syntax-violation (quote lambda) "bad lambda" e1389)) tmp1396))) ($sc-dispatch tmp1396 (quote (any any . each-any)))))) ($sc-dispatch tmp1396 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1396 (quote (any any any . each-any))))) c1391))) (chi-body1126 (lambda (body1428 outer-form1429 r1430 w1431 mod1432) (let ((r1433 (cons (quote ("placeholder" placeholder)) r1430))) (let ((ribcage1434 (make-ribcage1093 (quote ()) (quote ()) (quote ())))) (let ((w1435 (make-wrap1088 (wrap-marks1089 w1431) (cons ribcage1434 (wrap-subst1090 w1431))))) (let parse1436 ((body1437 (map (lambda (x1443) (cons r1433 (wrap1114 x1443 w1435 mod1432))) body1428)) (ids1438 (quote ())) (labels1439 (quote ())) (vars1440 (quote ())) (vals1441 (quote ())) (bindings1442 (quote ()))) (if (null? body1437) (syntax-violation #f "no expressions in body" outer-form1429) (let ((e1444 (cdar body1437)) (er1445 (caar body1437))) (call-with-values (lambda () (syntax-type1120 e1444 er1445 (quote (())) #f ribcage1434 mod1432)) (lambda (type1446 value1447 e1448 w1449 s1450 mod1451) (let ((t1452 type1446)) (if (memv t1452 (quote (define-form))) (let ((id1453 (wrap1114 value1447 w1449 mod1451)) (label1454 (gen-label1091))) (let ((var1455 (gen-var1134 id1453))) (begin (extend-ribcage!1102 ribcage1434 id1453 label1454) (parse1436 (cdr body1437) (cons id1453 ids1438) (cons label1454 labels1439) (cons var1455 vars1440) (cons (cons er1445 (wrap1114 e1448 w1449 mod1451)) vals1441) (cons (cons (quote lexical) var1455) bindings1442))))) (if (memv t1452 (quote (define-syntax-form))) (let ((id1456 (wrap1114 value1447 w1449 mod1451)) (label1457 (gen-label1091))) (begin (extend-ribcage!1102 ribcage1434 id1456 label1457) (parse1436 (cdr body1437) (cons id1456 ids1438) (cons label1457 labels1439) vars1440 vals1441 (cons (cons (quote macro) (cons er1445 (wrap1114 e1448 w1449 mod1451))) bindings1442)))) (if (memv t1452 (quote (begin-form))) ((lambda (tmp1458) ((lambda (tmp1459) (if tmp1459 (apply (lambda (_1460 e11461) (parse1436 (let f1462 ((forms1463 e11461)) (if (null? forms1463) (cdr body1437) (cons (cons er1445 (wrap1114 (car forms1463) w1449 mod1451)) (f1462 (cdr forms1463))))) ids1438 labels1439 vars1440 vals1441 bindings1442)) tmp1459) (syntax-violation #f "source expression failed to match any pattern" tmp1458))) ($sc-dispatch tmp1458 (quote (any . each-any))))) e1448) (if (memv t1452 (quote (local-syntax-form))) (chi-local-syntax1128 value1447 e1448 er1445 w1449 s1450 mod1451 (lambda (forms1465 er1466 w1467 s1468 mod1469) (parse1436 (let f1470 ((forms1471 forms1465)) (if (null? forms1471) (cdr body1437) (cons (cons er1466 (wrap1114 (car forms1471) w1467 mod1469)) (f1470 (cdr forms1471))))) ids1438 labels1439 vars1440 vals1441 bindings1442))) (if (null? ids1438) (build-sequence1065 #f (map (lambda (x1472) (chi1122 (cdr x1472) (car x1472) (quote (())) mod1451)) (cons (cons er1445 (source-wrap1115 e1448 w1449 s1450 mod1451)) (cdr body1437)))) (begin (if (not (valid-bound-ids?1111 ids1438)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1429)) (let loop1473 ((bs1474 bindings1442) (er-cache1475 #f) (r-cache1476 #f)) (if (not (null? bs1474)) (let ((b1477 (car bs1474))) (if (eq? (car b1477) (quote macro)) (let ((er1478 (cadr b1477))) (let ((r-cache1479 (if (eq? er1478 er-cache1475) r-cache1476 (macros-only-env1082 er1478)))) (begin (set-cdr! b1477 (eval-local-transformer1129 (chi1122 (cddr b1477) r-cache1479 (quote (())) mod1451) mod1451)) (loop1473 (cdr bs1474) er1478 r-cache1479)))) (loop1473 (cdr bs1474) er-cache1475 r-cache1476))))) (set-cdr! r1433 (extend-env1080 labels1439 bindings1442 (cdr r1433))) (build-letrec1068 #f vars1440 (map (lambda (x1480) (chi1122 (cdr x1480) (car x1480) (quote (())) mod1451)) vals1441) (build-sequence1065 #f (map (lambda (x1481) (chi1122 (cdr x1481) (car x1481) (quote (())) mod1451)) (cons (cons er1445 (source-wrap1115 e1448 w1449 s1450 mod1451)) (cdr body1437)))))))))))))))))))))) (chi-macro1125 (lambda (p1482 e1483 r1484 w1485 rib1486 mod1487) (letrec ((rebuild-macro-output1488 (lambda (x1489 m1490) (cond ((pair? x1489) (cons (rebuild-macro-output1488 (car x1489) m1490) (rebuild-macro-output1488 (cdr x1489) m1490))) ((syntax-object?1070 x1489) (let ((w1491 (syntax-object-wrap1072 x1489))) (let ((ms1492 (wrap-marks1089 w1491)) (s1493 (wrap-subst1090 w1491))) (if (and (pair? ms1492) (eq? (car ms1492) #f)) (make-syntax-object1069 (syntax-object-expression1071 x1489) (make-wrap1088 (cdr ms1492) (if rib1486 (cons rib1486 (cdr s1493)) (cdr s1493))) (syntax-object-module1073 x1489)) (make-syntax-object1069 (syntax-object-expression1071 x1489) (make-wrap1088 (cons m1490 ms1492) (if rib1486 (cons rib1486 (cons (quote shift) s1493)) (cons (quote shift) s1493))) (let ((pmod1494 (procedure-module p1482))) (if pmod1494 (cons (quote hygiene) (module-name pmod1494)) (quote (hygiene guile))))))))) ((vector? x1489) (let ((n1495 (vector-length x1489))) (let ((v1496 (make-vector n1495))) (let doloop1497 ((i1498 0)) (if (fx=1057 i1498 n1495) v1496 (begin (vector-set! v1496 i1498 (rebuild-macro-output1488 (vector-ref x1489 i1498) m1490)) (doloop1497 (fx+1055 i1498 1)))))))) ((symbol? x1489) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1115 e1483 w1485 s mod1487) x1489)) (else x1489))))) (rebuild-macro-output1488 (p1482 (wrap1114 e1483 (anti-mark1101 w1485) mod1487)) (string #\m))))) (chi-application1124 (lambda (x1499 e1500 r1501 w1502 s1503 mod1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (e01507 e11508) (build-annotated1063 s1503 (cons x1499 (map (lambda (e1509) (chi1122 e1509 r1501 w1502 mod1504)) e11508)))) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any . each-any))))) e1500))) (chi-expr1123 (lambda (type1511 value1512 e1513 r1514 w1515 s1516 mod1517) (let ((t1518 type1511)) (if (memv t1518 (quote (lexical))) (build-annotated1063 s1516 value1512) (if (memv t1518 (quote (core external-macro))) (value1512 e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (module-ref))) (call-with-values (lambda () (value1512 e1513)) (lambda (id1519 mod1520) (build-annotated1063 s1516 (if mod1520 (make-module-ref (cdr mod1520) id1519 (car mod1520)) (make-module-ref mod1520 id1519 (quote bare)))))) (if (memv t1518 (quote (lexical-call))) (chi-application1124 (build-annotated1063 (source-annotation1077 (car e1513)) value1512) e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (global-call))) (chi-application1124 (build-annotated1063 (source-annotation1077 (car e1513)) (if (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517) (make-module-ref (cdr (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517)) value1512 (car (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517))) (make-module-ref (if (syntax-object?1070 (car e1513)) (syntax-object-module1073 (car e1513)) mod1517) value1512 (quote bare)))) e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (constant))) (build-data1064 s1516 (strip1133 (source-wrap1115 e1513 w1515 s1516 mod1517) (quote (())))) (if (memv t1518 (quote (global))) (build-annotated1063 s1516 (if mod1517 (make-module-ref (cdr mod1517) value1512 (car mod1517)) (make-module-ref mod1517 value1512 (quote bare)))) (if (memv t1518 (quote (call))) (chi-application1124 (chi1122 (car e1513) r1514 w1515 mod1517) e1513 r1514 w1515 s1516 mod1517) (if (memv t1518 (quote (begin-form))) ((lambda (tmp1521) ((lambda (tmp1522) (if tmp1522 (apply (lambda (_1523 e11524 e21525) (chi-sequence1116 (cons e11524 e21525) r1514 w1515 s1516 mod1517)) tmp1522) (syntax-violation #f "source expression failed to match any pattern" tmp1521))) ($sc-dispatch tmp1521 (quote (any any . each-any))))) e1513) (if (memv t1518 (quote (local-syntax-form))) (chi-local-syntax1128 value1512 e1513 r1514 w1515 s1516 mod1517 chi-sequence1116) (if (memv t1518 (quote (eval-when-form))) ((lambda (tmp1527) ((lambda (tmp1528) (if tmp1528 (apply (lambda (_1529 x1530 e11531 e21532) (let ((when-list1533 (chi-when-list1119 e1513 x1530 w1515))) (if (memq (quote eval) when-list1533) (chi-sequence1116 (cons e11531 e21532) r1514 w1515 s1516 mod1517) (chi-void1130)))) tmp1528) (syntax-violation #f "source expression failed to match any pattern" tmp1527))) ($sc-dispatch tmp1527 (quote (any each-any any . each-any))))) e1513) (if (memv t1518 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1513 (wrap1114 value1512 w1515 mod1517)) (if (memv t1518 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1115 e1513 w1515 s1516 mod1517)) (if (memv t1518 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1115 e1513 w1515 s1516 mod1517)) (syntax-violation #f "unexpected syntax" (source-wrap1115 e1513 w1515 s1516 mod1517))))))))))))))))))) (chi1122 (lambda (e1536 r1537 w1538 mod1539) (call-with-values (lambda () (syntax-type1120 e1536 r1537 w1538 #f #f mod1539)) (lambda (type1540 value1541 e1542 w1543 s1544 mod1545) (chi-expr1123 type1540 value1541 e1542 r1537 w1543 s1544 mod1545))))) (chi-top1121 (lambda (e1546 r1547 w1548 m1549 esew1550 mod1551) (call-with-values (lambda () (syntax-type1120 e1546 r1547 w1548 #f #f mod1551)) (lambda (type1559 value1560 e1561 w1562 s1563 mod1564) (let ((t1565 type1559)) (if (memv t1565 (quote (begin-form))) ((lambda (tmp1566) ((lambda (tmp1567) (if tmp1567 (apply (lambda (_1568) (chi-void1130)) tmp1567) ((lambda (tmp1569) (if tmp1569 (apply (lambda (_1570 e11571 e21572) (chi-top-sequence1117 (cons e11571 e21572) r1547 w1562 s1563 m1549 esew1550 mod1564)) tmp1569) (syntax-violation #f "source expression failed to match any pattern" tmp1566))) ($sc-dispatch tmp1566 (quote (any any . each-any)))))) ($sc-dispatch tmp1566 (quote (any))))) e1561) (if (memv t1565 (quote (local-syntax-form))) (chi-local-syntax1128 value1560 e1561 r1547 w1562 s1563 mod1564 (lambda (body1574 r1575 w1576 s1577 mod1578) (chi-top-sequence1117 body1574 r1575 w1576 s1577 m1549 esew1550 mod1578))) (if (memv t1565 (quote (eval-when-form))) ((lambda (tmp1579) ((lambda (tmp1580) (if tmp1580 (apply (lambda (_1581 x1582 e11583 e21584) (let ((when-list1585 (chi-when-list1119 e1561 x1582 w1562)) (body1586 (cons e11583 e21584))) (cond ((eq? m1549 (quote e)) (if (memq (quote eval) when-list1585) (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote e) (quote (eval)) mod1564) (chi-void1130))) ((memq (quote load) when-list1585) (if (or (memq (quote compile) when-list1585) (and (eq? m1549 (quote c&e)) (memq (quote eval) when-list1585))) (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote c&e) (quote (compile load)) mod1564) (if (memq m1549 (quote (c c&e))) (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote c) (quote (load)) mod1564) (chi-void1130)))) ((or (memq (quote compile) when-list1585) (and (eq? m1549 (quote c&e)) (memq (quote eval) when-list1585))) (top-level-eval-hook1059 (chi-top-sequence1117 body1586 r1547 w1562 s1563 (quote e) (quote (eval)) mod1564) mod1564) (chi-void1130)) (else (chi-void1130))))) tmp1580) (syntax-violation #f "source expression failed to match any pattern" tmp1579))) ($sc-dispatch tmp1579 (quote (any each-any any . each-any))))) e1561) (if (memv t1565 (quote (define-syntax-form))) (let ((n1589 (id-var-name1108 value1560 w1562)) (r1590 (macros-only-env1082 r1547))) (let ((t1591 m1549)) (if (memv t1591 (quote (c))) (if (memq (quote compile) esew1550) (let ((e1592 (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)))) (begin (top-level-eval-hook1059 e1592 mod1564) (if (memq (quote load) esew1550) e1592 (chi-void1130)))) (if (memq (quote load) esew1550) (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)) (chi-void1130))) (if (memv t1591 (quote (c&e))) (let ((e1593 (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)))) (begin (top-level-eval-hook1059 e1593 mod1564) e1593)) (begin (if (memq (quote eval) esew1550) (top-level-eval-hook1059 (chi-install-global1118 n1589 (chi1122 e1561 r1590 w1562 mod1564)) mod1564)) (chi-void1130)))))) (if (memv t1565 (quote (define-form))) (let ((n1594 (id-var-name1108 value1560 w1562))) (let ((type1595 (binding-type1078 (lookup1083 n1594 r1547 mod1564)))) (let ((t1596 type1595)) (if (memv t1596 (quote (global core macro module-ref))) (let ((x1597 (build-annotated1063 s1563 (list (quote define) n1594 (chi1122 e1561 r1547 w1562 mod1564))))) (begin (if (eq? m1549 (quote c&e)) (top-level-eval-hook1059 x1597 mod1564)) x1597)) (if (memv t1596 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1561 (wrap1114 value1560 w1562 mod1564)) (syntax-violation #f "cannot define keyword at top level" e1561 (wrap1114 value1560 w1562 mod1564))))))) (let ((x1598 (chi-expr1123 type1559 value1560 e1561 r1547 w1562 s1563 mod1564))) (begin (if (eq? m1549 (quote c&e)) (top-level-eval-hook1059 x1598 mod1564)) x1598)))))))))))) (syntax-type1120 (lambda (e1599 r1600 w1601 s1602 rib1603 mod1604) (cond ((symbol? e1599) (let ((n1605 (id-var-name1108 e1599 w1601))) (let ((b1606 (lookup1083 n1605 r1600 mod1604))) (let ((type1607 (binding-type1078 b1606))) (let ((t1608 type1607)) (if (memv t1608 (quote (lexical))) (values type1607 (binding-value1079 b1606) e1599 w1601 s1602 mod1604) (if (memv t1608 (quote (global))) (values type1607 n1605 e1599 w1601 s1602 mod1604) (if (memv t1608 (quote (macro))) (syntax-type1120 (chi-macro1125 (binding-value1079 b1606) e1599 r1600 w1601 rib1603 mod1604) r1600 (quote (())) s1602 rib1603 mod1604) (values type1607 (binding-value1079 b1606) e1599 w1601 s1602 mod1604))))))))) ((pair? e1599) (let ((first1609 (car e1599))) (if (id?1086 first1609) (let ((n1610 (id-var-name1108 first1609 w1601))) (let ((b1611 (lookup1083 n1610 r1600 (or (and (syntax-object?1070 first1609) (syntax-object-module1073 first1609)) mod1604)))) (let ((type1612 (binding-type1078 b1611))) (let ((t1613 type1612)) (if (memv t1613 (quote (lexical))) (values (quote lexical-call) (binding-value1079 b1611) e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (global))) (values (quote global-call) n1610 e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (macro))) (syntax-type1120 (chi-macro1125 (binding-value1079 b1611) e1599 r1600 w1601 rib1603 mod1604) r1600 (quote (())) s1602 rib1603 mod1604) (if (memv t1613 (quote (core external-macro module-ref))) (values type1612 (binding-value1079 b1611) e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1079 b1611) e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (begin))) (values (quote begin-form) #f e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (eval-when))) (values (quote eval-when-form) #f e1599 w1601 s1602 mod1604) (if (memv t1613 (quote (define))) ((lambda (tmp1614) ((lambda (tmp1615) (if (if tmp1615 (apply (lambda (_1616 name1617 val1618) (id?1086 name1617)) tmp1615) #f) (apply (lambda (_1619 name1620 val1621) (values (quote define-form) name1620 val1621 w1601 s1602 mod1604)) tmp1615) ((lambda (tmp1622) (if (if tmp1622 (apply (lambda (_1623 name1624 args1625 e11626 e21627) (and (id?1086 name1624) (valid-bound-ids?1111 (lambda-var-list1135 args1625)))) tmp1622) #f) (apply (lambda (_1628 name1629 args1630 e11631 e21632) (values (quote define-form) (wrap1114 name1629 w1601 mod1604) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1114 (cons args1630 (cons e11631 e21632)) w1601 mod1604)) (quote (())) s1602 mod1604)) tmp1622) ((lambda (tmp1634) (if (if tmp1634 (apply (lambda (_1635 name1636) (id?1086 name1636)) tmp1634) #f) (apply (lambda (_1637 name1638) (values (quote define-form) (wrap1114 name1638 w1601 mod1604) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1602 mod1604)) tmp1634) (syntax-violation #f "source expression failed to match any pattern" tmp1614))) ($sc-dispatch tmp1614 (quote (any any)))))) ($sc-dispatch tmp1614 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1614 (quote (any any any))))) e1599) (if (memv t1613 (quote (define-syntax))) ((lambda (tmp1639) ((lambda (tmp1640) (if (if tmp1640 (apply (lambda (_1641 name1642 val1643) (id?1086 name1642)) tmp1640) #f) (apply (lambda (_1644 name1645 val1646) (values (quote define-syntax-form) name1645 val1646 w1601 s1602 mod1604)) tmp1640) (syntax-violation #f "source expression failed to match any pattern" tmp1639))) ($sc-dispatch tmp1639 (quote (any any any))))) e1599) (values (quote call) #f e1599 w1601 s1602 mod1604)))))))))))))) (values (quote call) #f e1599 w1601 s1602 mod1604)))) ((syntax-object?1070 e1599) (syntax-type1120 (syntax-object-expression1071 e1599) r1600 (join-wraps1105 w1601 (syntax-object-wrap1072 e1599)) #f rib1603 (or (syntax-object-module1073 e1599) mod1604))) ((annotation? e1599) (syntax-type1120 (annotation-expression e1599) r1600 w1601 (annotation-source e1599) rib1603 mod1604)) ((self-evaluating? e1599) (values (quote constant) #f e1599 w1601 s1602 mod1604)) (else (values (quote other) #f e1599 w1601 s1602 mod1604))))) (chi-when-list1119 (lambda (e1647 when-list1648 w1649) (let f1650 ((when-list1651 when-list1648) (situations1652 (quote ()))) (if (null? when-list1651) situations1652 (f1650 (cdr when-list1651) (cons (let ((x1653 (car when-list1651))) (cond ((free-id=?1109 x1653 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1109 x1653 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1109 x1653 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1647 (wrap1114 x1653 w1649 #f))))) situations1652)))))) (chi-install-global1118 (lambda (name1654 e1655) (build-annotated1063 #f (list (build-annotated1063 #f (quote define)) name1654 (if (let ((v1656 (module-variable (current-module) name1654))) (and v1656 (variable-bound? v1656) (macro? (variable-ref v1656)) (not (eq? (macro-type (variable-ref v1656)) (quote syncase-macro))))) (build-annotated1063 #f (list (build-annotated1063 #f (quote make-extended-syncase-macro)) (build-annotated1063 #f (list (build-annotated1063 #f (quote module-ref)) (build-annotated1063 #f (quote (current-module))) (build-data1064 #f name1654))) (build-data1064 #f (quote macro)) e1655)) (build-annotated1063 #f (list (build-annotated1063 #f (quote make-syncase-macro)) (build-data1064 #f (quote macro)) e1655))))))) (chi-top-sequence1117 (lambda (body1657 r1658 w1659 s1660 m1661 esew1662 mod1663) (build-sequence1065 s1660 (let dobody1664 ((body1665 body1657) (r1666 r1658) (w1667 w1659) (m1668 m1661) (esew1669 esew1662) (mod1670 mod1663)) (if (null? body1665) (quote ()) (let ((first1671 (chi-top1121 (car body1665) r1666 w1667 m1668 esew1669 mod1670))) (cons first1671 (dobody1664 (cdr body1665) r1666 w1667 m1668 esew1669 mod1670)))))))) (chi-sequence1116 (lambda (body1672 r1673 w1674 s1675 mod1676) (build-sequence1065 s1675 (let dobody1677 ((body1678 body1672) (r1679 r1673) (w1680 w1674) (mod1681 mod1676)) (if (null? body1678) (quote ()) (let ((first1682 (chi1122 (car body1678) r1679 w1680 mod1681))) (cons first1682 (dobody1677 (cdr body1678) r1679 w1680 mod1681)))))))) (source-wrap1115 (lambda (x1683 w1684 s1685 defmod1686) (wrap1114 (if s1685 (make-annotation x1683 s1685 #f) x1683) w1684 defmod1686))) (wrap1114 (lambda (x1687 w1688 defmod1689) (cond ((and (null? (wrap-marks1089 w1688)) (null? (wrap-subst1090 w1688))) x1687) ((syntax-object?1070 x1687) (make-syntax-object1069 (syntax-object-expression1071 x1687) (join-wraps1105 w1688 (syntax-object-wrap1072 x1687)) (syntax-object-module1073 x1687))) ((null? x1687) x1687) (else (make-syntax-object1069 x1687 w1688 defmod1689))))) (bound-id-member?1113 (lambda (x1690 list1691) (and (not (null? list1691)) (or (bound-id=?1110 x1690 (car list1691)) (bound-id-member?1113 x1690 (cdr list1691)))))) (distinct-bound-ids?1112 (lambda (ids1692) (let distinct?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (not (bound-id-member?1113 (car ids1694) (cdr ids1694))) (distinct?1693 (cdr ids1694))))))) (valid-bound-ids?1111 (lambda (ids1695) (and (let all-ids?1696 ((ids1697 ids1695)) (or (null? ids1697) (and (id?1086 (car ids1697)) (all-ids?1696 (cdr ids1697))))) (distinct-bound-ids?1112 ids1695)))) (bound-id=?1110 (lambda (i1698 j1699) (if (and (syntax-object?1070 i1698) (syntax-object?1070 j1699)) (and (eq? (let ((e1700 (syntax-object-expression1071 i1698))) (if (annotation? e1700) (annotation-expression e1700) e1700)) (let ((e1701 (syntax-object-expression1071 j1699))) (if (annotation? e1701) (annotation-expression e1701) e1701))) (same-marks?1107 (wrap-marks1089 (syntax-object-wrap1072 i1698)) (wrap-marks1089 (syntax-object-wrap1072 j1699)))) (eq? (let ((e1702 i1698)) (if (annotation? e1702) (annotation-expression e1702) e1702)) (let ((e1703 j1699)) (if (annotation? e1703) (annotation-expression e1703) e1703)))))) (free-id=?1109 (lambda (i1704 j1705) (and (eq? (let ((x1706 i1704)) (let ((e1707 (if (syntax-object?1070 x1706) (syntax-object-expression1071 x1706) x1706))) (if (annotation? e1707) (annotation-expression e1707) e1707))) (let ((x1708 j1705)) (let ((e1709 (if (syntax-object?1070 x1708) (syntax-object-expression1071 x1708) x1708))) (if (annotation? e1709) (annotation-expression e1709) e1709)))) (eq? (id-var-name1108 i1704 (quote (()))) (id-var-name1108 j1705 (quote (()))))))) (id-var-name1108 (lambda (id1710 w1711) (letrec ((search-vector-rib1714 (lambda (sym1720 subst1721 marks1722 symnames1723 ribcage1724) (let ((n1725 (vector-length symnames1723))) (let f1726 ((i1727 0)) (cond ((fx=1057 i1727 n1725) (search1712 sym1720 (cdr subst1721) marks1722)) ((and (eq? (vector-ref symnames1723 i1727) sym1720) (same-marks?1107 marks1722 (vector-ref (ribcage-marks1096 ribcage1724) i1727))) (values (vector-ref (ribcage-labels1097 ribcage1724) i1727) marks1722)) (else (f1726 (fx+1055 i1727 1)))))))) (search-list-rib1713 (lambda (sym1728 subst1729 marks1730 symnames1731 ribcage1732) (let f1733 ((symnames1734 symnames1731) (i1735 0)) (cond ((null? symnames1734) (search1712 sym1728 (cdr subst1729) marks1730)) ((and (eq? (car symnames1734) sym1728) (same-marks?1107 marks1730 (list-ref (ribcage-marks1096 ribcage1732) i1735))) (values (list-ref (ribcage-labels1097 ribcage1732) i1735) marks1730)) (else (f1733 (cdr symnames1734) (fx+1055 i1735 1))))))) (search1712 (lambda (sym1736 subst1737 marks1738) (if (null? subst1737) (values #f marks1738) (let ((fst1739 (car subst1737))) (if (eq? fst1739 (quote shift)) (search1712 sym1736 (cdr subst1737) (cdr marks1738)) (let ((symnames1740 (ribcage-symnames1095 fst1739))) (if (vector? symnames1740) (search-vector-rib1714 sym1736 subst1737 marks1738 symnames1740 fst1739) (search-list-rib1713 sym1736 subst1737 marks1738 symnames1740 fst1739))))))))) (cond ((symbol? id1710) (or (call-with-values (lambda () (search1712 id1710 (wrap-subst1090 w1711) (wrap-marks1089 w1711))) (lambda (x1742 . ignore1741) x1742)) id1710)) ((syntax-object?1070 id1710) (let ((id1743 (let ((e1745 (syntax-object-expression1071 id1710))) (if (annotation? e1745) (annotation-expression e1745) e1745))) (w11744 (syntax-object-wrap1072 id1710))) (let ((marks1746 (join-marks1106 (wrap-marks1089 w1711) (wrap-marks1089 w11744)))) (call-with-values (lambda () (search1712 id1743 (wrap-subst1090 w1711) marks1746)) (lambda (new-id1747 marks1748) (or new-id1747 (call-with-values (lambda () (search1712 id1743 (wrap-subst1090 w11744) marks1748)) (lambda (x1750 . ignore1749) x1750)) id1743)))))) ((annotation? id1710) (let ((id1751 (let ((e1752 id1710)) (if (annotation? e1752) (annotation-expression e1752) e1752)))) (or (call-with-values (lambda () (search1712 id1751 (wrap-subst1090 w1711) (wrap-marks1089 w1711))) (lambda (x1754 . ignore1753) x1754)) id1751))) (else (syntax-violation (quote id-var-name) "invalid id" id1710)))))) (same-marks?1107 (lambda (x1755 y1756) (or (eq? x1755 y1756) (and (not (null? x1755)) (not (null? y1756)) (eq? (car x1755) (car y1756)) (same-marks?1107 (cdr x1755) (cdr y1756)))))) (join-marks1106 (lambda (m11757 m21758) (smart-append1104 m11757 m21758))) (join-wraps1105 (lambda (w11759 w21760) (let ((m11761 (wrap-marks1089 w11759)) (s11762 (wrap-subst1090 w11759))) (if (null? m11761) (if (null? s11762) w21760 (make-wrap1088 (wrap-marks1089 w21760) (smart-append1104 s11762 (wrap-subst1090 w21760)))) (make-wrap1088 (smart-append1104 m11761 (wrap-marks1089 w21760)) (smart-append1104 s11762 (wrap-subst1090 w21760))))))) (smart-append1104 (lambda (m11763 m21764) (if (null? m21764) m11763 (append m11763 m21764)))) (make-binding-wrap1103 (lambda (ids1765 labels1766 w1767) (if (null? ids1765) w1767 (make-wrap1088 (wrap-marks1089 w1767) (cons (let ((labelvec1768 (list->vector labels1766))) (let ((n1769 (vector-length labelvec1768))) (let ((symnamevec1770 (make-vector n1769)) (marksvec1771 (make-vector n1769))) (begin (let f1772 ((ids1773 ids1765) (i1774 0)) (if (not (null? ids1773)) (call-with-values (lambda () (id-sym-name&marks1087 (car ids1773) w1767)) (lambda (symname1775 marks1776) (begin (vector-set! symnamevec1770 i1774 symname1775) (vector-set! marksvec1771 i1774 marks1776) (f1772 (cdr ids1773) (fx+1055 i1774 1))))))) (make-ribcage1093 symnamevec1770 marksvec1771 labelvec1768))))) (wrap-subst1090 w1767)))))) (extend-ribcage!1102 (lambda (ribcage1777 id1778 label1779) (begin (set-ribcage-symnames!1098 ribcage1777 (cons (let ((e1780 (syntax-object-expression1071 id1778))) (if (annotation? e1780) (annotation-expression e1780) e1780)) (ribcage-symnames1095 ribcage1777))) (set-ribcage-marks!1099 ribcage1777 (cons (wrap-marks1089 (syntax-object-wrap1072 id1778)) (ribcage-marks1096 ribcage1777))) (set-ribcage-labels!1100 ribcage1777 (cons label1779 (ribcage-labels1097 ribcage1777)))))) (anti-mark1101 (lambda (w1781) (make-wrap1088 (cons #f (wrap-marks1089 w1781)) (cons (quote shift) (wrap-subst1090 w1781))))) (set-ribcage-labels!1100 (lambda (x1782 update1783) (vector-set! x1782 3 update1783))) (set-ribcage-marks!1099 (lambda (x1784 update1785) (vector-set! x1784 2 update1785))) (set-ribcage-symnames!1098 (lambda (x1786 update1787) (vector-set! x1786 1 update1787))) (ribcage-labels1097 (lambda (x1788) (vector-ref x1788 3))) (ribcage-marks1096 (lambda (x1789) (vector-ref x1789 2))) (ribcage-symnames1095 (lambda (x1790) (vector-ref x1790 1))) (ribcage?1094 (lambda (x1791) (and (vector? x1791) (= (vector-length x1791) 4) (eq? (vector-ref x1791 0) (quote ribcage))))) (make-ribcage1093 (lambda (symnames1792 marks1793 labels1794) (vector (quote ribcage) symnames1792 marks1793 labels1794))) (gen-labels1092 (lambda (ls1795) (if (null? ls1795) (quote ()) (cons (gen-label1091) (gen-labels1092 (cdr ls1795)))))) (gen-label1091 (lambda () (string #\i))) (wrap-subst1090 cdr) (wrap-marks1089 car) (make-wrap1088 cons) (id-sym-name&marks1087 (lambda (x1796 w1797) (if (syntax-object?1070 x1796) (values (let ((e1798 (syntax-object-expression1071 x1796))) (if (annotation? e1798) (annotation-expression e1798) e1798)) (join-marks1106 (wrap-marks1089 w1797) (wrap-marks1089 (syntax-object-wrap1072 x1796)))) (values (let ((e1799 x1796)) (if (annotation? e1799) (annotation-expression e1799) e1799)) (wrap-marks1089 w1797))))) (id?1086 (lambda (x1800) (cond ((symbol? x1800) #t) ((syntax-object?1070 x1800) (symbol? (let ((e1801 (syntax-object-expression1071 x1800))) (if (annotation? e1801) (annotation-expression e1801) e1801)))) ((annotation? x1800) (symbol? (annotation-expression x1800))) (else #f)))) (nonsymbol-id?1085 (lambda (x1802) (and (syntax-object?1070 x1802) (symbol? (let ((e1803 (syntax-object-expression1071 x1802))) (if (annotation? e1803) (annotation-expression e1803) e1803)))))) (global-extend1084 (lambda (type1804 sym1805 val1806) (put-global-definition-hook1061 sym1805 type1804 val1806))) (lookup1083 (lambda (x1807 r1808 mod1809) (cond ((assq x1807 r1808) => cdr) ((symbol? x1807) (or (get-global-definition-hook1062 x1807 mod1809) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1082 (lambda (r1810) (if (null? r1810) (quote ()) (let ((a1811 (car r1810))) (if (eq? (cadr a1811) (quote macro)) (cons a1811 (macros-only-env1082 (cdr r1810))) (macros-only-env1082 (cdr r1810))))))) (extend-var-env1081 (lambda (labels1812 vars1813 r1814) (if (null? labels1812) r1814 (extend-var-env1081 (cdr labels1812) (cdr vars1813) (cons (cons (car labels1812) (cons (quote lexical) (car vars1813))) r1814))))) (extend-env1080 (lambda (labels1815 bindings1816 r1817) (if (null? labels1815) r1817 (extend-env1080 (cdr labels1815) (cdr bindings1816) (cons (cons (car labels1815) (car bindings1816)) r1817))))) (binding-value1079 cdr) (binding-type1078 car) (source-annotation1077 (lambda (x1818) (cond ((annotation? x1818) (annotation-source x1818)) ((syntax-object?1070 x1818) (source-annotation1077 (syntax-object-expression1071 x1818))) (else #f)))) (set-syntax-object-module!1076 (lambda (x1819 update1820) (vector-set! x1819 3 update1820))) (set-syntax-object-wrap!1075 (lambda (x1821 update1822) (vector-set! x1821 2 update1822))) (set-syntax-object-expression!1074 (lambda (x1823 update1824) (vector-set! x1823 1 update1824))) (syntax-object-module1073 (lambda (x1825) (vector-ref x1825 3))) (syntax-object-wrap1072 (lambda (x1826) (vector-ref x1826 2))) (syntax-object-expression1071 (lambda (x1827) (vector-ref x1827 1))) (syntax-object?1070 (lambda (x1828) (and (vector? x1828) (= (vector-length x1828) 4) (eq? (vector-ref x1828 0) (quote syntax-object))))) (make-syntax-object1069 (lambda (expression1829 wrap1830 module1831) (vector (quote syntax-object) expression1829 wrap1830 module1831))) (build-letrec1068 (lambda (src1832 vars1833 val-exps1834 body-exp1835) (if (null? vars1833) (build-annotated1063 src1832 body-exp1835) (build-annotated1063 src1832 (list (quote letrec) (map list vars1833 val-exps1834) body-exp1835))))) (build-named-let1067 (lambda (src1836 vars1837 val-exps1838 body-exp1839) (if (null? vars1837) (build-annotated1063 src1836 body-exp1839) (build-annotated1063 src1836 (list (quote let) (car vars1837) (map list (cdr vars1837) val-exps1838) body-exp1839))))) (build-let1066 (lambda (src1840 vars1841 val-exps1842 body-exp1843) (if (null? vars1841) (build-annotated1063 src1840 body-exp1843) (build-annotated1063 src1840 (list (quote let) (map list vars1841 val-exps1842) body-exp1843))))) (build-sequence1065 (lambda (src1844 exps1845) (if (null? (cdr exps1845)) (build-annotated1063 src1844 (car exps1845)) (build-annotated1063 src1844 (cons (quote begin) exps1845))))) (build-data1064 (lambda (src1846 exp1847) (if (and (self-evaluating? exp1847) (not (vector? exp1847))) (build-annotated1063 src1846 exp1847) (build-annotated1063 src1846 (list (quote quote) exp1847))))) (build-annotated1063 (lambda (src1848 exp1849) (if (and src1848 (not (annotation? exp1849))) (make-annotation exp1849 src1848 #t) exp1849))) (get-global-definition-hook1062 (lambda (symbol1850 module1851) (begin (if (and (not module1851) (current-module)) (warn "module system is booted, we should have a module" symbol1850)) (let ((v1852 (module-variable (if module1851 (resolve-module (cdr module1851)) (current-module)) symbol1850))) (and v1852 (variable-bound? v1852) (let ((val1853 (variable-ref v1852))) (and (macro? val1853) (syncase-macro-type val1853) (cons (syncase-macro-type val1853) (syncase-macro-binding val1853))))))))) (put-global-definition-hook1061 (lambda (symbol1854 type1855 val1856) (let ((existing1857 (let ((v1858 (module-variable (current-module) symbol1854))) (and v1858 (variable-bound? v1858) (let ((val1859 (variable-ref v1858))) (and (macro? val1859) (not (syncase-macro-type val1859)) val1859)))))) (module-define! (current-module) symbol1854 (if existing1857 (make-extended-syncase-macro existing1857 type1855 val1856) (make-syncase-macro type1855 val1856)))))) (local-eval-hook1060 (lambda (x1860 mod1861) (primitive-eval (list noexpand1054 x1860)))) (top-level-eval-hook1059 (lambda (x1862 mod1863) (primitive-eval (list noexpand1054 x1862)))) (fx<1058 <) (fx=1057 =) (fx-1056 -) (fx+1055 +) (noexpand1054 "noexpand")) (begin (global-extend1084 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1084 (quote local-syntax) (quote let-syntax) #f) (global-extend1084 (quote core) (quote fluid-let-syntax) (lambda (e1864 r1865 w1866 s1867 mod1868) ((lambda (tmp1869) ((lambda (tmp1870) (if (if tmp1870 (apply (lambda (_1871 var1872 val1873 e11874 e21875) (valid-bound-ids?1111 var1872)) tmp1870) #f) (apply (lambda (_1877 var1878 val1879 e11880 e21881) (let ((names1882 (map (lambda (x1883) (id-var-name1108 x1883 w1866)) var1878))) (begin (for-each (lambda (id1885 n1886) (let ((t1887 (binding-type1078 (lookup1083 n1886 r1865 mod1868)))) (if (memv t1887 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1864 (source-wrap1115 id1885 w1866 s1867 mod1868))))) var1878 names1882) (chi-body1126 (cons e11880 e21881) (source-wrap1115 e1864 w1866 s1867 mod1868) (extend-env1080 names1882 (let ((trans-r1890 (macros-only-env1082 r1865))) (map (lambda (x1891) (cons (quote macro) (eval-local-transformer1129 (chi1122 x1891 trans-r1890 w1866 mod1868) mod1868))) val1879)) r1865) w1866 mod1868)))) tmp1870) ((lambda (_1893) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1115 e1864 w1866 s1867 mod1868))) tmp1869))) ($sc-dispatch tmp1869 (quote (any #(each (any any)) any . each-any))))) e1864))) (global-extend1084 (quote core) (quote quote) (lambda (e1894 r1895 w1896 s1897 mod1898) ((lambda (tmp1899) ((lambda (tmp1900) (if tmp1900 (apply (lambda (_1901 e1902) (build-data1064 s1897 (strip1133 e1902 w1896))) tmp1900) ((lambda (_1903) (syntax-violation (quote quote) "bad syntax" (source-wrap1115 e1894 w1896 s1897 mod1898))) tmp1899))) ($sc-dispatch tmp1899 (quote (any any))))) e1894))) (global-extend1084 (quote core) (quote syntax) (letrec ((regen1911 (lambda (x1912) (let ((t1913 (car x1912))) (if (memv t1913 (quote (ref))) (build-annotated1063 #f (cadr x1912)) (if (memv t1913 (quote (primitive))) (build-annotated1063 #f (cadr x1912)) (if (memv t1913 (quote (quote))) (build-data1064 #f (cadr x1912)) (if (memv t1913 (quote (lambda))) (build-annotated1063 #f (list (quote lambda) (cadr x1912) (regen1911 (caddr x1912)))) (if (memv t1913 (quote (map))) (let ((ls1914 (map regen1911 (cdr x1912)))) (build-annotated1063 #f (cons (if (fx=1057 (length ls1914) 2) (build-annotated1063 #f (quote map)) (build-annotated1063 #f (quote map))) ls1914))) (build-annotated1063 #f (cons (build-annotated1063 #f (car x1912)) (map regen1911 (cdr x1912)))))))))))) (gen-vector1910 (lambda (x1915) (cond ((eq? (car x1915) (quote list)) (cons (quote vector) (cdr x1915))) ((eq? (car x1915) (quote quote)) (list (quote quote) (list->vector (cadr x1915)))) (else (list (quote list->vector) x1915))))) (gen-append1909 (lambda (x1916 y1917) (if (equal? y1917 (quote (quote ()))) x1916 (list (quote append) x1916 y1917)))) (gen-cons1908 (lambda (x1918 y1919) (let ((t1920 (car y1919))) (if (memv t1920 (quote (quote))) (if (eq? (car x1918) (quote quote)) (list (quote quote) (cons (cadr x1918) (cadr y1919))) (if (eq? (cadr y1919) (quote ())) (list (quote list) x1918) (list (quote cons) x1918 y1919))) (if (memv t1920 (quote (list))) (cons (quote list) (cons x1918 (cdr y1919))) (list (quote cons) x1918 y1919)))))) (gen-map1907 (lambda (e1921 map-env1922) (let ((formals1923 (map cdr map-env1922)) (actuals1924 (map (lambda (x1925) (list (quote ref) (car x1925))) map-env1922))) (cond ((eq? (car e1921) (quote ref)) (car actuals1924)) ((and-map (lambda (x1926) (and (eq? (car x1926) (quote ref)) (memq (cadr x1926) formals1923))) (cdr e1921)) (cons (quote map) (cons (list (quote primitive) (car e1921)) (map (let ((r1927 (map cons formals1923 actuals1924))) (lambda (x1928) (cdr (assq (cadr x1928) r1927)))) (cdr e1921))))) (else (cons (quote map) (cons (list (quote lambda) formals1923 e1921) actuals1924))))))) (gen-mappend1906 (lambda (e1929 map-env1930) (list (quote apply) (quote (primitive append)) (gen-map1907 e1929 map-env1930)))) (gen-ref1905 (lambda (src1931 var1932 level1933 maps1934) (if (fx=1057 level1933 0) (values var1932 maps1934) (if (null? maps1934) (syntax-violation (quote syntax) "missing ellipsis" src1931) (call-with-values (lambda () (gen-ref1905 src1931 var1932 (fx-1056 level1933 1) (cdr maps1934))) (lambda (outer-var1935 outer-maps1936) (let ((b1937 (assq outer-var1935 (car maps1934)))) (if b1937 (values (cdr b1937) maps1934) (let ((inner-var1938 (gen-var1134 (quote tmp)))) (values inner-var1938 (cons (cons (cons outer-var1935 inner-var1938) (car maps1934)) outer-maps1936))))))))))) (gen-syntax1904 (lambda (src1939 e1940 r1941 maps1942 ellipsis?1943 mod1944) (if (id?1086 e1940) (let ((label1945 (id-var-name1108 e1940 (quote (()))))) (let ((b1946 (lookup1083 label1945 r1941 mod1944))) (if (eq? (binding-type1078 b1946) (quote syntax)) (call-with-values (lambda () (let ((var.lev1947 (binding-value1079 b1946))) (gen-ref1905 src1939 (car var.lev1947) (cdr var.lev1947) maps1942))) (lambda (var1948 maps1949) (values (list (quote ref) var1948) maps1949))) (if (ellipsis?1943 e1940) (syntax-violation (quote syntax) "misplaced ellipsis" src1939) (values (list (quote quote) e1940) maps1942))))) ((lambda (tmp1950) ((lambda (tmp1951) (if (if tmp1951 (apply (lambda (dots1952 e1953) (ellipsis?1943 dots1952)) tmp1951) #f) (apply (lambda (dots1954 e1955) (gen-syntax1904 src1939 e1955 r1941 maps1942 (lambda (x1956) #f) mod1944)) tmp1951) ((lambda (tmp1957) (if (if tmp1957 (apply (lambda (x1958 dots1959 y1960) (ellipsis?1943 dots1959)) tmp1957) #f) (apply (lambda (x1961 dots1962 y1963) (let f1964 ((y1965 y1963) (k1966 (lambda (maps1967) (call-with-values (lambda () (gen-syntax1904 src1939 x1961 r1941 (cons (quote ()) maps1967) ellipsis?1943 mod1944)) (lambda (x1968 maps1969) (if (null? (car maps1969)) (syntax-violation (quote syntax) "extra ellipsis" src1939) (values (gen-map1907 x1968 (car maps1969)) (cdr maps1969)))))))) ((lambda (tmp1970) ((lambda (tmp1971) (if (if tmp1971 (apply (lambda (dots1972 y1973) (ellipsis?1943 dots1972)) tmp1971) #f) (apply (lambda (dots1974 y1975) (f1964 y1975 (lambda (maps1976) (call-with-values (lambda () (k1966 (cons (quote ()) maps1976))) (lambda (x1977 maps1978) (if (null? (car maps1978)) (syntax-violation (quote syntax) "extra ellipsis" src1939) (values (gen-mappend1906 x1977 (car maps1978)) (cdr maps1978)))))))) tmp1971) ((lambda (_1979) (call-with-values (lambda () (gen-syntax1904 src1939 y1965 r1941 maps1942 ellipsis?1943 mod1944)) (lambda (y1980 maps1981) (call-with-values (lambda () (k1966 maps1981)) (lambda (x1982 maps1983) (values (gen-append1909 x1982 y1980) maps1983)))))) tmp1970))) ($sc-dispatch tmp1970 (quote (any . any))))) y1965))) tmp1957) ((lambda (tmp1984) (if tmp1984 (apply (lambda (x1985 y1986) (call-with-values (lambda () (gen-syntax1904 src1939 x1985 r1941 maps1942 ellipsis?1943 mod1944)) (lambda (x1987 maps1988) (call-with-values (lambda () (gen-syntax1904 src1939 y1986 r1941 maps1988 ellipsis?1943 mod1944)) (lambda (y1989 maps1990) (values (gen-cons1908 x1987 y1989) maps1990)))))) tmp1984) ((lambda (tmp1991) (if tmp1991 (apply (lambda (e11992 e21993) (call-with-values (lambda () (gen-syntax1904 src1939 (cons e11992 e21993) r1941 maps1942 ellipsis?1943 mod1944)) (lambda (e1995 maps1996) (values (gen-vector1910 e1995) maps1996)))) tmp1991) ((lambda (_1997) (values (list (quote quote) e1940) maps1942)) tmp1950))) ($sc-dispatch tmp1950 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1950 (quote (any . any)))))) ($sc-dispatch tmp1950 (quote (any any . any)))))) ($sc-dispatch tmp1950 (quote (any any))))) e1940))))) (lambda (e1998 r1999 w2000 s2001 mod2002) (let ((e2003 (source-wrap1115 e1998 w2000 s2001 mod2002))) ((lambda (tmp2004) ((lambda (tmp2005) (if tmp2005 (apply (lambda (_2006 x2007) (call-with-values (lambda () (gen-syntax1904 e2003 x2007 r1999 (quote ()) ellipsis?1131 mod2002)) (lambda (e2008 maps2009) (regen1911 e2008)))) tmp2005) ((lambda (_2010) (syntax-violation (quote syntax) "bad `syntax' form" e2003)) tmp2004))) ($sc-dispatch tmp2004 (quote (any any))))) e2003))))) (global-extend1084 (quote core) (quote lambda) (lambda (e2011 r2012 w2013 s2014 mod2015) ((lambda (tmp2016) ((lambda (tmp2017) (if tmp2017 (apply (lambda (_2018 c2019) (chi-lambda-clause1127 (source-wrap1115 e2011 w2013 s2014 mod2015) #f c2019 r2012 w2013 mod2015 (lambda (vars2020 docstring2021 body2022) (build-annotated1063 s2014 (cons (quote lambda) (cons vars2020 (append (if docstring2021 (list docstring2021) (quote ())) (list body2022)))))))) tmp2017) (syntax-violation #f "source expression failed to match any pattern" tmp2016))) ($sc-dispatch tmp2016 (quote (any . any))))) e2011))) (global-extend1084 (quote core) (quote let) (letrec ((chi-let2023 (lambda (e2024 r2025 w2026 s2027 mod2028 constructor2029 ids2030 vals2031 exps2032) (if (not (valid-bound-ids?1111 ids2030)) (syntax-violation (quote let) "duplicate bound variable" e2024) (let ((labels2033 (gen-labels1092 ids2030)) (new-vars2034 (map gen-var1134 ids2030))) (let ((nw2035 (make-binding-wrap1103 ids2030 labels2033 w2026)) (nr2036 (extend-var-env1081 labels2033 new-vars2034 r2025))) (constructor2029 s2027 new-vars2034 (map (lambda (x2037) (chi1122 x2037 r2025 w2026 mod2028)) vals2031) (chi-body1126 exps2032 (source-wrap1115 e2024 nw2035 s2027 mod2028) nr2036 nw2035 mod2028)))))))) (lambda (e2038 r2039 w2040 s2041 mod2042) ((lambda (tmp2043) ((lambda (tmp2044) (if tmp2044 (apply (lambda (_2045 id2046 val2047 e12048 e22049) (chi-let2023 e2038 r2039 w2040 s2041 mod2042 build-let1066 id2046 val2047 (cons e12048 e22049))) tmp2044) ((lambda (tmp2053) (if (if tmp2053 (apply (lambda (_2054 f2055 id2056 val2057 e12058 e22059) (id?1086 f2055)) tmp2053) #f) (apply (lambda (_2060 f2061 id2062 val2063 e12064 e22065) (chi-let2023 e2038 r2039 w2040 s2041 mod2042 build-named-let1067 (cons f2061 id2062) val2063 (cons e12064 e22065))) tmp2053) ((lambda (_2069) (syntax-violation (quote let) "bad let" (source-wrap1115 e2038 w2040 s2041 mod2042))) tmp2043))) ($sc-dispatch tmp2043 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2043 (quote (any #(each (any any)) any . each-any))))) e2038)))) (global-extend1084 (quote core) (quote letrec) (lambda (e2070 r2071 w2072 s2073 mod2074) ((lambda (tmp2075) ((lambda (tmp2076) (if tmp2076 (apply (lambda (_2077 id2078 val2079 e12080 e22081) (let ((ids2082 id2078)) (if (not (valid-bound-ids?1111 ids2082)) (syntax-violation (quote letrec) "duplicate bound variable" e2070) (let ((labels2084 (gen-labels1092 ids2082)) (new-vars2085 (map gen-var1134 ids2082))) (let ((w2086 (make-binding-wrap1103 ids2082 labels2084 w2072)) (r2087 (extend-var-env1081 labels2084 new-vars2085 r2071))) (build-letrec1068 s2073 new-vars2085 (map (lambda (x2088) (chi1122 x2088 r2087 w2086 mod2074)) val2079) (chi-body1126 (cons e12080 e22081) (source-wrap1115 e2070 w2086 s2073 mod2074) r2087 w2086 mod2074))))))) tmp2076) ((lambda (_2091) (syntax-violation (quote letrec) "bad letrec" (source-wrap1115 e2070 w2072 s2073 mod2074))) tmp2075))) ($sc-dispatch tmp2075 (quote (any #(each (any any)) any . each-any))))) e2070))) (global-extend1084 (quote core) (quote set!) (lambda (e2092 r2093 w2094 s2095 mod2096) ((lambda (tmp2097) ((lambda (tmp2098) (if (if tmp2098 (apply (lambda (_2099 id2100 val2101) (id?1086 id2100)) tmp2098) #f) (apply (lambda (_2102 id2103 val2104) (let ((val2105 (chi1122 val2104 r2093 w2094 mod2096)) (n2106 (id-var-name1108 id2103 w2094))) (let ((b2107 (lookup1083 n2106 r2093 mod2096))) (let ((t2108 (binding-type1078 b2107))) (if (memv t2108 (quote (lexical))) (build-annotated1063 s2095 (list (quote set!) (binding-value1079 b2107) val2105)) (if (memv t2108 (quote (global))) (build-annotated1063 s2095 (list (quote set!) (if mod2096 (make-module-ref (cdr mod2096) n2106 (car mod2096)) (make-module-ref mod2096 n2106 (quote bare))) val2105)) (if (memv t2108 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1114 id2103 w2094 mod2096)) (syntax-violation (quote set!) "bad set!" (source-wrap1115 e2092 w2094 s2095 mod2096))))))))) tmp2098) ((lambda (tmp2109) (if tmp2109 (apply (lambda (_2110 head2111 tail2112 val2113) (call-with-values (lambda () (syntax-type1120 head2111 r2093 (quote (())) #f #f mod2096)) (lambda (type2114 value2115 ee2116 ww2117 ss2118 modmod2119) (let ((t2120 type2114)) (if (memv t2120 (quote (module-ref))) (let ((val2121 (chi1122 val2113 r2093 w2094 mod2096))) (call-with-values (lambda () (value2115 (cons head2111 tail2112))) (lambda (id2123 mod2124) (build-annotated1063 s2095 (list (quote set!) (if mod2124 (make-module-ref (cdr mod2124) id2123 (car mod2124)) (make-module-ref mod2124 id2123 (quote bare))) val2121))))) (build-annotated1063 s2095 (cons (chi1122 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2111) r2093 w2094 mod2096) (map (lambda (e2125) (chi1122 e2125 r2093 w2094 mod2096)) (append tail2112 (list val2113)))))))))) tmp2109) ((lambda (_2127) (syntax-violation (quote set!) "bad set!" (source-wrap1115 e2092 w2094 s2095 mod2096))) tmp2097))) ($sc-dispatch tmp2097 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2097 (quote (any any any))))) e2092))) (global-extend1084 (quote module-ref) (quote @) (lambda (e2128) ((lambda (tmp2129) ((lambda (tmp2130) (if (if tmp2130 (apply (lambda (_2131 mod2132 id2133) (and (and-map id?1086 mod2132) (id?1086 id2133))) tmp2130) #f) (apply (lambda (_2135 mod2136 id2137) (values (syntax->datum id2137) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2136)))) tmp2130) (syntax-violation #f "source expression failed to match any pattern" tmp2129))) ($sc-dispatch tmp2129 (quote (any each-any any))))) e2128))) (global-extend1084 (quote module-ref) (quote @@) (lambda (e2139) ((lambda (tmp2140) ((lambda (tmp2141) (if (if tmp2141 (apply (lambda (_2142 mod2143 id2144) (and (and-map id?1086 mod2143) (id?1086 id2144))) tmp2141) #f) (apply (lambda (_2146 mod2147 id2148) (values (syntax->datum id2148) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2147)))) tmp2141) (syntax-violation #f "source expression failed to match any pattern" tmp2140))) ($sc-dispatch tmp2140 (quote (any each-any any))))) e2139))) (global-extend1084 (quote begin) (quote begin) (quote ())) (global-extend1084 (quote define) (quote define) (quote ())) (global-extend1084 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1084 (quote eval-when) (quote eval-when) (quote ())) (global-extend1084 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2153 (lambda (x2154 keys2155 clauses2156 r2157 mod2158) (if (null? clauses2156) (build-annotated1063 #f (list (build-annotated1063 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2154)) ((lambda (tmp2159) ((lambda (tmp2160) (if tmp2160 (apply (lambda (pat2161 exp2162) (if (and (id?1086 pat2161) (and-map (lambda (x2163) (not (free-id=?1109 pat2161 x2163))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2155))) (let ((labels2164 (list (gen-label1091))) (var2165 (gen-var1134 pat2161))) (build-annotated1063 #f (list (build-annotated1063 #f (list (quote lambda) (list var2165) (chi1122 exp2162 (extend-env1080 labels2164 (list (cons (quote syntax) (cons var2165 0))) r2157) (make-binding-wrap1103 (list pat2161) labels2164 (quote (()))) mod2158))) x2154))) (gen-clause2152 x2154 keys2155 (cdr clauses2156) r2157 pat2161 #t exp2162 mod2158))) tmp2160) ((lambda (tmp2166) (if tmp2166 (apply (lambda (pat2167 fender2168 exp2169) (gen-clause2152 x2154 keys2155 (cdr clauses2156) r2157 pat2167 fender2168 exp2169 mod2158)) tmp2166) ((lambda (_2170) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2156))) tmp2159))) ($sc-dispatch tmp2159 (quote (any any any)))))) ($sc-dispatch tmp2159 (quote (any any))))) (car clauses2156))))) (gen-clause2152 (lambda (x2171 keys2172 clauses2173 r2174 pat2175 fender2176 exp2177 mod2178) (call-with-values (lambda () (convert-pattern2150 pat2175 keys2172)) (lambda (p2179 pvars2180) (cond ((not (distinct-bound-ids?1112 (map car pvars2180))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2175)) ((not (and-map (lambda (x2181) (not (ellipsis?1131 (car x2181)))) pvars2180)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2175)) (else (let ((y2182 (gen-var1134 (quote tmp)))) (build-annotated1063 #f (list (build-annotated1063 #f (list (quote lambda) (list y2182) (let ((y2183 (build-annotated1063 #f y2182))) (build-annotated1063 #f (list (quote if) ((lambda (tmp2184) ((lambda (tmp2185) (if tmp2185 (apply (lambda () y2183) tmp2185) ((lambda (_2186) (build-annotated1063 #f (list (quote if) y2183 (build-dispatch-call2151 pvars2180 fender2176 y2183 r2174 mod2178) (build-data1064 #f #f)))) tmp2184))) ($sc-dispatch tmp2184 (quote #(atom #t))))) fender2176) (build-dispatch-call2151 pvars2180 exp2177 y2183 r2174 mod2178) (gen-syntax-case2153 x2171 keys2172 clauses2173 r2174 mod2178)))))) (if (eq? p2179 (quote any)) (build-annotated1063 #f (list (build-annotated1063 #f (quote list)) x2171)) (build-annotated1063 #f (list (build-annotated1063 #f (quote $sc-dispatch)) x2171 (build-data1064 #f p2179))))))))))))) (build-dispatch-call2151 (lambda (pvars2187 exp2188 y2189 r2190 mod2191) (let ((ids2192 (map car pvars2187)) (levels2193 (map cdr pvars2187))) (let ((labels2194 (gen-labels1092 ids2192)) (new-vars2195 (map gen-var1134 ids2192))) (build-annotated1063 #f (list (build-annotated1063 #f (quote apply)) (build-annotated1063 #f (list (quote lambda) new-vars2195 (chi1122 exp2188 (extend-env1080 labels2194 (map (lambda (var2196 level2197) (cons (quote syntax) (cons var2196 level2197))) new-vars2195 (map cdr pvars2187)) r2190) (make-binding-wrap1103 ids2192 labels2194 (quote (()))) mod2191))) y2189)))))) (convert-pattern2150 (lambda (pattern2198 keys2199) (let cvt2200 ((p2201 pattern2198) (n2202 0) (ids2203 (quote ()))) (if (id?1086 p2201) (if (bound-id-member?1113 p2201 keys2199) (values (vector (quote free-id) p2201) ids2203) (values (quote any) (cons (cons p2201 n2202) ids2203))) ((lambda (tmp2204) ((lambda (tmp2205) (if (if tmp2205 (apply (lambda (x2206 dots2207) (ellipsis?1131 dots2207)) tmp2205) #f) (apply (lambda (x2208 dots2209) (call-with-values (lambda () (cvt2200 x2208 (fx+1055 n2202 1) ids2203)) (lambda (p2210 ids2211) (values (if (eq? p2210 (quote any)) (quote each-any) (vector (quote each) p2210)) ids2211)))) tmp2205) ((lambda (tmp2212) (if tmp2212 (apply (lambda (x2213 y2214) (call-with-values (lambda () (cvt2200 y2214 n2202 ids2203)) (lambda (y2215 ids2216) (call-with-values (lambda () (cvt2200 x2213 n2202 ids2216)) (lambda (x2217 ids2218) (values (cons x2217 y2215) ids2218)))))) tmp2212) ((lambda (tmp2219) (if tmp2219 (apply (lambda () (values (quote ()) ids2203)) tmp2219) ((lambda (tmp2220) (if tmp2220 (apply (lambda (x2221) (call-with-values (lambda () (cvt2200 x2221 n2202 ids2203)) (lambda (p2223 ids2224) (values (vector (quote vector) p2223) ids2224)))) tmp2220) ((lambda (x2225) (values (vector (quote atom) (strip1133 p2201 (quote (())))) ids2203)) tmp2204))) ($sc-dispatch tmp2204 (quote #(vector each-any)))))) ($sc-dispatch tmp2204 (quote ()))))) ($sc-dispatch tmp2204 (quote (any . any)))))) ($sc-dispatch tmp2204 (quote (any any))))) p2201)))))) (lambda (e2226 r2227 w2228 s2229 mod2230) (let ((e2231 (source-wrap1115 e2226 w2228 s2229 mod2230))) ((lambda (tmp2232) ((lambda (tmp2233) (if tmp2233 (apply (lambda (_2234 val2235 key2236 m2237) (if (and-map (lambda (x2238) (and (id?1086 x2238) (not (ellipsis?1131 x2238)))) key2236) (let ((x2240 (gen-var1134 (quote tmp)))) (build-annotated1063 s2229 (list (build-annotated1063 #f (list (quote lambda) (list x2240) (gen-syntax-case2153 (build-annotated1063 #f x2240) key2236 m2237 r2227 mod2230))) (chi1122 val2235 r2227 (quote (())) mod2230)))) (syntax-violation (quote syntax-case) "invalid literals list" e2231))) tmp2233) (syntax-violation #f "source expression failed to match any pattern" tmp2232))) ($sc-dispatch tmp2232 (quote (any any each-any . each-any))))) e2231))))) (set! sc-expand (let ((m2243 (quote e)) (esew2244 (quote (eval)))) (lambda (x2246 . rest2245) (if (and (pair? x2246) (equal? (car x2246) noexpand1054)) (cadr x2246) (chi-top1121 x2246 (quote ()) (quote ((top))) (if (null? rest2245) m2243 (car rest2245)) (if (or (null? rest2245) (null? (cdr rest2245))) esew2244 (cadr rest2245)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2247) (nonsymbol-id?1085 x2247))) (set! datum->syntax (lambda (id2248 datum2249) (make-syntax-object1069 datum2249 (syntax-object-wrap1072 id2248) #f))) (set! syntax->datum (lambda (x2250) (strip1133 x2250 (quote (()))))) (set! generate-temporaries (lambda (ls2251) (begin (let ((x2252 ls2251)) (if (not (list? x2252)) (syntax-violation (quote generate-temporaries) "invalid argument" x2252))) (map (lambda (x2253) (wrap1114 (gensym) (quote ((top))) #f)) ls2251)))) (set! free-identifier=? (lambda (x2254 y2255) (begin (let ((x2256 x2254)) (if (not (nonsymbol-id?1085 x2256)) (syntax-violation (quote free-identifier=?) "invalid argument" x2256))) (let ((x2257 y2255)) (if (not (nonsymbol-id?1085 x2257)) (syntax-violation (quote free-identifier=?) "invalid argument" x2257))) (free-id=?1109 x2254 y2255)))) (set! bound-identifier=? (lambda (x2258 y2259) (begin (let ((x2260 x2258)) (if (not (nonsymbol-id?1085 x2260)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2260))) (let ((x2261 y2259)) (if (not (nonsymbol-id?1085 x2261)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2261))) (bound-id=?1110 x2258 y2259)))) (set! syntax-violation (lambda (who2265 message2264 form2263 . subform2262) (begin (let ((x2266 who2265)) (if (not ((lambda (x2267) (or (not x2267) (string? x2267) (symbol? x2267))) x2266)) (syntax-violation (quote syntax-violation) "invalid argument" x2266))) (let ((x2268 message2264)) (if (not (string? x2268)) (syntax-violation (quote syntax-violation) "invalid argument" x2268))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2265 "~a: " "") "~a " (if (null? subform2262) "in ~a" "in subform `~s' of `~s'")) (let ((tail2269 (cons message2264 (map (lambda (x2270) (strip1133 x2270 (quote (())))) (append subform2262 (list form2263)))))) (if who2265 (cons who2265 tail2269) tail2269)) #f)))) (letrec ((match2275 (lambda (e2276 p2277 w2278 r2279 mod2280) (cond ((not r2279) #f) ((eq? p2277 (quote any)) (cons (wrap1114 e2276 w2278 mod2280) r2279)) ((syntax-object?1070 e2276) (match*2274 (let ((e2281 (syntax-object-expression1071 e2276))) (if (annotation? e2281) (annotation-expression e2281) e2281)) p2277 (join-wraps1105 w2278 (syntax-object-wrap1072 e2276)) r2279 (syntax-object-module1073 e2276))) (else (match*2274 (let ((e2282 e2276)) (if (annotation? e2282) (annotation-expression e2282) e2282)) p2277 w2278 r2279 mod2280))))) (match*2274 (lambda (e2283 p2284 w2285 r2286 mod2287) (cond ((null? p2284) (and (null? e2283) r2286)) ((pair? p2284) (and (pair? e2283) (match2275 (car e2283) (car p2284) w2285 (match2275 (cdr e2283) (cdr p2284) w2285 r2286 mod2287) mod2287))) ((eq? p2284 (quote each-any)) (let ((l2288 (match-each-any2272 e2283 w2285 mod2287))) (and l2288 (cons l2288 r2286)))) (else (let ((t2289 (vector-ref p2284 0))) (if (memv t2289 (quote (each))) (if (null? e2283) (match-empty2273 (vector-ref p2284 1) r2286) (let ((l2290 (match-each2271 e2283 (vector-ref p2284 1) w2285 mod2287))) (and l2290 (let collect2291 ((l2292 l2290)) (if (null? (car l2292)) r2286 (cons (map car l2292) (collect2291 (map cdr l2292)))))))) (if (memv t2289 (quote (free-id))) (and (id?1086 e2283) (free-id=?1109 (wrap1114 e2283 w2285 mod2287) (vector-ref p2284 1)) r2286) (if (memv t2289 (quote (atom))) (and (equal? (vector-ref p2284 1) (strip1133 e2283 w2285)) r2286) (if (memv t2289 (quote (vector))) (and (vector? e2283) (match2275 (vector->list e2283) (vector-ref p2284 1) w2285 r2286 mod2287))))))))))) (match-empty2273 (lambda (p2293 r2294) (cond ((null? p2293) r2294) ((eq? p2293 (quote any)) (cons (quote ()) r2294)) ((pair? p2293) (match-empty2273 (car p2293) (match-empty2273 (cdr p2293) r2294))) ((eq? p2293 (quote each-any)) (cons (quote ()) r2294)) (else (let ((t2295 (vector-ref p2293 0))) (if (memv t2295 (quote (each))) (match-empty2273 (vector-ref p2293 1) r2294) (if (memv t2295 (quote (free-id atom))) r2294 (if (memv t2295 (quote (vector))) (match-empty2273 (vector-ref p2293 1) r2294))))))))) (match-each-any2272 (lambda (e2296 w2297 mod2298) (cond ((annotation? e2296) (match-each-any2272 (annotation-expression e2296) w2297 mod2298)) ((pair? e2296) (let ((l2299 (match-each-any2272 (cdr e2296) w2297 mod2298))) (and l2299 (cons (wrap1114 (car e2296) w2297 mod2298) l2299)))) ((null? e2296) (quote ())) ((syntax-object?1070 e2296) (match-each-any2272 (syntax-object-expression1071 e2296) (join-wraps1105 w2297 (syntax-object-wrap1072 e2296)) mod2298)) (else #f)))) (match-each2271 (lambda (e2300 p2301 w2302 mod2303) (cond ((annotation? e2300) (match-each2271 (annotation-expression e2300) p2301 w2302 mod2303)) ((pair? e2300) (let ((first2304 (match2275 (car e2300) p2301 w2302 (quote ()) mod2303))) (and first2304 (let ((rest2305 (match-each2271 (cdr e2300) p2301 w2302 mod2303))) (and rest2305 (cons first2304 rest2305)))))) ((null? e2300) (quote ())) ((syntax-object?1070 e2300) (match-each2271 (syntax-object-expression1071 e2300) p2301 (join-wraps1105 w2302 (syntax-object-wrap1072 e2300)) (syntax-object-module1073 e2300))) (else #f))))) (set! $sc-dispatch (lambda (e2306 p2307) (cond ((eq? p2307 (quote any)) (list e2306)) ((syntax-object?1070 e2306) (match*2274 (let ((e2308 (syntax-object-expression1071 e2306))) (if (annotation? e2308) (annotation-expression e2308) e2308)) p2307 (syntax-object-wrap1072 e2306) (quote ()) (syntax-object-module1073 e2306))) (else (match*2274 (let ((e2309 e2306)) (if (annotation? e2309) (annotation-expression e2309) e2309)) p2307 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x2310) ((lambda (tmp2311) ((lambda (tmp2312) (if tmp2312 (apply (lambda (_2313 e12314 e22315) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12314 e22315))) tmp2312) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 out2319 in2320 e12321 e22322) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2320 (quote ()) (list out2319 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12321 e22322))))) tmp2317) ((lambda (tmp2324) (if tmp2324 (apply (lambda (_2325 out2326 in2327 e12328 e22329) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2327) (quote ()) (list out2326 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12328 e22329))))) tmp2324) (syntax-violation #f "source expression failed to match any pattern" tmp2311))) ($sc-dispatch tmp2311 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2311 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2311 (quote (any () any . each-any))))) x2310)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2333) ((lambda (tmp2334) ((lambda (tmp2335) (if tmp2335 (apply (lambda (_2336 k2337 keyword2338 pattern2339 template2340) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2337 (map (lambda (tmp2343 tmp2342) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2342) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2343))) template2340 pattern2339)))))) tmp2335) (syntax-violation #f "source expression failed to match any pattern" tmp2334))) ($sc-dispatch tmp2334 (quote (any each-any . #(each ((any . any) any))))))) x2333)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2344) ((lambda (tmp2345) ((lambda (tmp2346) (if (if tmp2346 (apply (lambda (let*2347 x2348 v2349 e12350 e22351) (and-map identifier? x2348)) tmp2346) #f) (apply (lambda (let*2353 x2354 v2355 e12356 e22357) (let f2358 ((bindings2359 (map list x2354 v2355))) (if (null? bindings2359) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12356 e22357))) ((lambda (tmp2363) ((lambda (tmp2364) (if tmp2364 (apply (lambda (body2365 binding2366) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2366) body2365)) tmp2364) (syntax-violation #f "source expression failed to match any pattern" tmp2363))) ($sc-dispatch tmp2363 (quote (any any))))) (list (f2358 (cdr bindings2359)) (car bindings2359)))))) tmp2346) (syntax-violation #f "source expression failed to match any pattern" tmp2345))) ($sc-dispatch tmp2345 (quote (any #(each (any any)) any . each-any))))) x2344)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2367) ((lambda (tmp2368) ((lambda (tmp2369) (if tmp2369 (apply (lambda (_2370 var2371 init2372 step2373 e02374 e12375 c2376) ((lambda (tmp2377) ((lambda (tmp2378) (if tmp2378 (apply (lambda (step2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2371 init2372) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02374) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2376 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2379))))))) tmp2381) ((lambda (tmp2386) (if tmp2386 (apply (lambda (e12387 e22388) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2371 init2372) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02374 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12387 e22388)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2376 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2379))))))) tmp2386) (syntax-violation #f "source expression failed to match any pattern" tmp2380))) ($sc-dispatch tmp2380 (quote (any . each-any)))))) ($sc-dispatch tmp2380 (quote ())))) e12375)) tmp2378) (syntax-violation #f "source expression failed to match any pattern" tmp2377))) ($sc-dispatch tmp2377 (quote each-any)))) (map (lambda (v2395 s2396) ((lambda (tmp2397) ((lambda (tmp2398) (if tmp2398 (apply (lambda () v2395) tmp2398) ((lambda (tmp2399) (if tmp2399 (apply (lambda (e2400) e2400) tmp2399) ((lambda (_2401) (syntax-violation (quote do) "bad step expression" orig-x2367 s2396)) tmp2397))) ($sc-dispatch tmp2397 (quote (any)))))) ($sc-dispatch tmp2397 (quote ())))) s2396)) var2371 step2373))) tmp2369) (syntax-violation #f "source expression failed to match any pattern" tmp2368))) ($sc-dispatch tmp2368 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2367)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2404 (lambda (x2408 y2409) ((lambda (tmp2410) ((lambda (tmp2411) (if tmp2411 (apply (lambda (x2412 y2413) ((lambda (tmp2414) ((lambda (tmp2415) (if tmp2415 (apply (lambda (dy2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (dx2419) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2419 dy2416))) tmp2418) ((lambda (_2420) (if (null? dy2416) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2412) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2412 y2413))) tmp2417))) ($sc-dispatch tmp2417 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2412)) tmp2415) ((lambda (tmp2421) (if tmp2421 (apply (lambda (stuff2422) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2412 stuff2422))) tmp2421) ((lambda (else2423) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2412 y2413)) tmp2414))) ($sc-dispatch tmp2414 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2414 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2413)) tmp2411) (syntax-violation #f "source expression failed to match any pattern" tmp2410))) ($sc-dispatch tmp2410 (quote (any any))))) (list x2408 y2409)))) (quasiappend2405 (lambda (x2424 y2425) ((lambda (tmp2426) ((lambda (tmp2427) (if tmp2427 (apply (lambda (x2428 y2429) ((lambda (tmp2430) ((lambda (tmp2431) (if tmp2431 (apply (lambda () x2428) tmp2431) ((lambda (_2432) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2428 y2429)) tmp2430))) ($sc-dispatch tmp2430 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2429)) tmp2427) (syntax-violation #f "source expression failed to match any pattern" tmp2426))) ($sc-dispatch tmp2426 (quote (any any))))) (list x2424 y2425)))) (quasivector2406 (lambda (x2433) ((lambda (tmp2434) ((lambda (x2435) ((lambda (tmp2436) ((lambda (tmp2437) (if tmp2437 (apply (lambda (x2438) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2438))) tmp2437) ((lambda (tmp2440) (if tmp2440 (apply (lambda (x2441) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2441)) tmp2440) ((lambda (_2443) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2435)) tmp2436))) ($sc-dispatch tmp2436 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2436 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2435)) tmp2434)) x2433))) (quasi2407 (lambda (p2444 lev2445) ((lambda (tmp2446) ((lambda (tmp2447) (if tmp2447 (apply (lambda (p2448) (if (= lev2445 0) p2448 (quasicons2404 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2407 (list p2448) (- lev2445 1))))) tmp2447) ((lambda (tmp2449) (if tmp2449 (apply (lambda (p2450 q2451) (if (= lev2445 0) (quasiappend2405 p2450 (quasi2407 q2451 lev2445)) (quasicons2404 (quasicons2404 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2407 (list p2450) (- lev2445 1))) (quasi2407 q2451 lev2445)))) tmp2449) ((lambda (tmp2452) (if tmp2452 (apply (lambda (p2453) (quasicons2404 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2407 (list p2453) (+ lev2445 1)))) tmp2452) ((lambda (tmp2454) (if tmp2454 (apply (lambda (p2455 q2456) (quasicons2404 (quasi2407 p2455 lev2445) (quasi2407 q2456 lev2445))) tmp2454) ((lambda (tmp2457) (if tmp2457 (apply (lambda (x2458) (quasivector2406 (quasi2407 x2458 lev2445))) tmp2457) ((lambda (p2460) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2460)) tmp2446))) ($sc-dispatch tmp2446 (quote #(vector each-any)))))) ($sc-dispatch tmp2446 (quote (any . any)))))) ($sc-dispatch tmp2446 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2446 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2446 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2444)))) (lambda (x2461) ((lambda (tmp2462) ((lambda (tmp2463) (if tmp2463 (apply (lambda (_2464 e2465) (quasi2407 e2465 0)) tmp2463) (syntax-violation #f "source expression failed to match any pattern" tmp2462))) ($sc-dispatch tmp2462 (quote (any any))))) x2461))))) -(define include (make-syncase-macro (quote macro) (lambda (x2466) (letrec ((read-file2467 (lambda (fn2468 k2469) (let ((p2470 (open-input-file fn2468))) (let f2471 ((x2472 (read p2470))) (if (eof-object? x2472) (begin (close-input-port p2470) (quote ())) (cons (datum->syntax k2469 x2472) (f2471 (read p2470))))))))) ((lambda (tmp2473) ((lambda (tmp2474) (if tmp2474 (apply (lambda (k2475 filename2476) (let ((fn2477 (syntax->datum filename2476))) ((lambda (tmp2478) ((lambda (tmp2479) (if tmp2479 (apply (lambda (exp2480) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2480)) tmp2479) (syntax-violation #f "source expression failed to match any pattern" tmp2478))) ($sc-dispatch tmp2478 (quote each-any)))) (read-file2467 fn2477 k2475)))) tmp2474) (syntax-violation #f "source expression failed to match any pattern" tmp2473))) ($sc-dispatch tmp2473 (quote (any any))))) x2466))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x2482) ((lambda (tmp2483) ((lambda (tmp2484) (if tmp2484 (apply (lambda (_2485 e2486) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2482)) tmp2484) (syntax-violation #f "source expression failed to match any pattern" tmp2483))) ($sc-dispatch tmp2483 (quote (any any))))) x2482)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2487) ((lambda (tmp2488) ((lambda (tmp2489) (if tmp2489 (apply (lambda (_2490 e2491) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2487)) tmp2489) (syntax-violation #f "source expression failed to match any pattern" tmp2488))) ($sc-dispatch tmp2488 (quote (any any))))) x2487)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2492) ((lambda (tmp2493) ((lambda (tmp2494) (if tmp2494 (apply (lambda (_2495 e2496 m12497 m22498) ((lambda (tmp2499) ((lambda (body2500) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2496)) body2500)) tmp2499)) (let f2501 ((clause2502 m12497) (clauses2503 m22498)) (if (null? clauses2503) ((lambda (tmp2505) ((lambda (tmp2506) (if tmp2506 (apply (lambda (e12507 e22508) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12507 e22508))) tmp2506) ((lambda (tmp2510) (if tmp2510 (apply (lambda (k2511 e12512 e22513) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2511)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12512 e22513)))) tmp2510) ((lambda (_2516) (syntax-violation (quote case) "bad clause" x2492 clause2502)) tmp2505))) ($sc-dispatch tmp2505 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2505 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2502) ((lambda (tmp2517) ((lambda (rest2518) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (k2521 e12522 e22523) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2521)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12522 e22523)) rest2518)) tmp2520) ((lambda (_2526) (syntax-violation (quote case) "bad clause" x2492 clause2502)) tmp2519))) ($sc-dispatch tmp2519 (quote (each-any any . each-any))))) clause2502)) tmp2517)) (f2501 (car clauses2503) (cdr clauses2503))))))) tmp2494) (syntax-violation #f "source expression failed to match any pattern" tmp2493))) ($sc-dispatch tmp2493 (quote (any any any . each-any))))) x2492)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2527) ((lambda (tmp2528) ((lambda (tmp2529) (if tmp2529 (apply (lambda (_2530 e2531) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2531)) (list (cons _2530 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2531 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2529) (syntax-violation #f "source expression failed to match any pattern" tmp2528))) ($sc-dispatch tmp2528 (quote (any any))))) x2527)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list153 (lambda (vars343) (let lvl344 ((vars345 vars343) (ls346 (quote ())) (w347 (quote (())))) (cond ((pair? vars345) (lvl344 (cdr vars345) (cons (wrap132 (car vars345) w347 #f) ls346) w347)) ((id?104 vars345) (cons (wrap132 vars345 w347 #f) ls346)) ((null? vars345) ls346) ((syntax-object?88 vars345) (lvl344 (syntax-object-expression89 vars345) ls346 (join-wraps123 w347 (syntax-object-wrap90 vars345)))) ((annotation? vars345) (lvl344 (annotation-expression vars345) ls346 w347)) (else (cons vars345 ls346)))))) (gen-var152 (lambda (id348) (let ((id349 (if (syntax-object?88 id348) (syntax-object-expression89 id348) id348))) (if (annotation? id349) (build-annotated79 (annotation-source id349) (gensym (symbol->string (annotation-expression id349)))) (build-annotated79 #f (gensym (symbol->string id349))))))) (strip151 (lambda (x350 w351) (if (memq (quote top) (wrap-marks107 w351)) (if (or (annotation? x350) (and (pair? x350) (annotation? (car x350)))) (strip-annotation150 x350 #f) x350) (let f352 ((x353 x350)) (cond ((syntax-object?88 x353) (strip151 (syntax-object-expression89 x353) (syntax-object-wrap90 x353))) ((pair? x353) (let ((a354 (f352 (car x353))) (d355 (f352 (cdr x353)))) (if (and (eq? a354 (car x353)) (eq? d355 (cdr x353))) x353 (cons a354 d355)))) ((vector? x353) (let ((old356 (vector->list x353))) (let ((new357 (map f352 old356))) (if (and-map*17 eq? old356 new357) x353 (list->vector new357))))) (else x353)))))) (strip-annotation150 (lambda (x358 parent359) (cond ((pair? x358) (let ((new360 (cons #f #f))) (begin (if parent359 (set-annotation-stripped! parent359 new360)) (set-car! new360 (strip-annotation150 (car x358) #f)) (set-cdr! new360 (strip-annotation150 (cdr x358) #f)) new360))) ((annotation? x358) (or (annotation-stripped x358) (strip-annotation150 (annotation-expression x358) x358))) ((vector? x358) (let ((new361 (make-vector (vector-length x358)))) (begin (if parent359 (set-annotation-stripped! parent359 new361)) (let loop362 ((i363 (- (vector-length x358) 1))) (unless (fx<74 i363 0) (vector-set! new361 i363 (strip-annotation150 (vector-ref x358 i363) #f)) (loop362 (fx-72 i363 1)))) new361))) (else x358)))) (ellipsis?149 (lambda (x364) (and (nonsymbol-id?103 x364) (free-id=?127 x364 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void148 (lambda () (build-annotated79 #f (cons (build-annotated79 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer147 (lambda (expanded365 mod366) (let ((p367 (local-eval-hook76 expanded365 mod366))) (if (procedure? p367) p367 (syntax-violation #f "nonprocedure transformer" p367))))) (chi-local-syntax146 (lambda (rec?368 e369 r370 w371 s372 mod373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (_377 id378 val379 e1380 e2381) (let ((ids382 id378)) (if (not (valid-bound-ids?129 ids382)) (syntax-violation #f "duplicate bound keyword" e369) (let ((labels384 (gen-labels110 ids382))) (let ((new-w385 (make-binding-wrap121 ids382 labels384 w371))) (k374 (cons e1380 e2381) (extend-env98 labels384 (let ((w387 (if rec?368 new-w385 w371)) (trans-r388 (macros-only-env100 r370))) (map (lambda (x389) (cons (quote macro) (eval-local-transformer147 (chi140 x389 trans-r388 w387 mod373) mod373))) val379)) r370) new-w385 s372 mod373)))))) tmp376) ((lambda (_391) (syntax-violation #f "bad local syntax definition" (source-wrap133 e369 w371 s372 mod373))) tmp375))) ($sc-dispatch tmp375 (quote (any #(each (any any)) any . each-any))))) e369))) (chi-lambda-clause145 (lambda (e392 docstring393 c394 r395 w396 mod397 k398) ((lambda (tmp399) ((lambda (tmp400) (if (if tmp400 (apply (lambda (args401 doc402 e1403 e2404) (and (string? (syntax->datum doc402)) (not docstring393))) tmp400) #f) (apply (lambda (args405 doc406 e1407 e2408) (chi-lambda-clause145 e392 doc406 (cons args405 (cons e1407 e2408)) r395 w396 mod397 k398)) tmp400) ((lambda (tmp410) (if tmp410 (apply (lambda (id411 e1412 e2413) (let ((ids414 id411)) (if (not (valid-bound-ids?129 ids414)) (syntax-violation (quote lambda) "invalid parameter list" e392) (let ((labels416 (gen-labels110 ids414)) (new-vars417 (map gen-var152 ids414))) (k398 new-vars417 docstring393 (chi-body144 (cons e1412 e2413) e392 (extend-var-env99 labels416 new-vars417 r395) (make-binding-wrap121 ids414 labels416 w396) mod397)))))) tmp410) ((lambda (tmp419) (if tmp419 (apply (lambda (ids420 e1421 e2422) (let ((old-ids423 (lambda-var-list153 ids420))) (if (not (valid-bound-ids?129 old-ids423)) (syntax-violation (quote lambda) "invalid parameter list" e392) (let ((labels424 (gen-labels110 old-ids423)) (new-vars425 (map gen-var152 old-ids423))) (k398 (let f426 ((ls1427 (cdr new-vars425)) (ls2428 (car new-vars425))) (if (null? ls1427) ls2428 (f426 (cdr ls1427) (cons (car ls1427) ls2428)))) docstring393 (chi-body144 (cons e1421 e2422) e392 (extend-var-env99 labels424 new-vars425 r395) (make-binding-wrap121 old-ids423 labels424 w396) mod397)))))) tmp419) ((lambda (_430) (syntax-violation (quote lambda) "bad lambda" e392)) tmp399))) ($sc-dispatch tmp399 (quote (any any . each-any)))))) ($sc-dispatch tmp399 (quote (each-any any . each-any)))))) ($sc-dispatch tmp399 (quote (any any any . each-any))))) c394))) (chi-body144 (lambda (body431 outer-form432 r433 w434 mod435) (let ((r436 (cons (quote ("placeholder" placeholder)) r433))) (let ((ribcage437 (make-ribcage111 (quote ()) (quote ()) (quote ())))) (let ((w438 (make-wrap106 (wrap-marks107 w434) (cons ribcage437 (wrap-subst108 w434))))) (let parse439 ((body440 (map (lambda (x446) (cons r436 (wrap132 x446 w438 mod435))) body431)) (ids441 (quote ())) (labels442 (quote ())) (vars443 (quote ())) (vals444 (quote ())) (bindings445 (quote ()))) (if (null? body440) (syntax-violation #f "no expressions in body" outer-form432) (let ((e447 (cdar body440)) (er448 (caar body440))) (call-with-values (lambda () (syntax-type138 e447 er448 (quote (())) #f ribcage437 mod435)) (lambda (type449 value450 e451 w452 s453 mod454) (let ((t455 type449)) (if (memv t455 (quote (define-form))) (let ((id456 (wrap132 value450 w452 mod454)) (label457 (gen-label109))) (let ((var458 (gen-var152 id456))) (begin (extend-ribcage!120 ribcage437 id456 label457) (parse439 (cdr body440) (cons id456 ids441) (cons label457 labels442) (cons var458 vars443) (cons (cons er448 (wrap132 e451 w452 mod454)) vals444) (cons (cons (quote lexical) var458) bindings445))))) (if (memv t455 (quote (define-syntax-form))) (let ((id459 (wrap132 value450 w452 mod454)) (label460 (gen-label109))) (begin (extend-ribcage!120 ribcage437 id459 label460) (parse439 (cdr body440) (cons id459 ids441) (cons label460 labels442) vars443 vals444 (cons (cons (quote macro) (cons er448 (wrap132 e451 w452 mod454))) bindings445)))) (if (memv t455 (quote (begin-form))) ((lambda (tmp461) ((lambda (tmp462) (if tmp462 (apply (lambda (_463 e1464) (parse439 (let f465 ((forms466 e1464)) (if (null? forms466) (cdr body440) (cons (cons er448 (wrap132 (car forms466) w452 mod454)) (f465 (cdr forms466))))) ids441 labels442 vars443 vals444 bindings445)) tmp462) (syntax-violation #f "source expression failed to match any pattern" tmp461))) ($sc-dispatch tmp461 (quote (any . each-any))))) e451) (if (memv t455 (quote (local-syntax-form))) (chi-local-syntax146 value450 e451 er448 w452 s453 mod454 (lambda (forms468 er469 w470 s471 mod472) (parse439 (let f473 ((forms474 forms468)) (if (null? forms474) (cdr body440) (cons (cons er469 (wrap132 (car forms474) w470 mod472)) (f473 (cdr forms474))))) ids441 labels442 vars443 vals444 bindings445))) (if (null? ids441) (build-sequence83 #f (map (lambda (x475) (chi140 (cdr x475) (car x475) (quote (())) mod454)) (cons (cons er448 (source-wrap133 e451 w452 s453 mod454)) (cdr body440)))) (begin (if (not (valid-bound-ids?129 ids441)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form432)) (let loop476 ((bs477 bindings445) (er-cache478 #f) (r-cache479 #f)) (if (not (null? bs477)) (let ((b480 (car bs477))) (if (eq? (car b480) (quote macro)) (let ((er481 (cadr b480))) (let ((r-cache482 (if (eq? er481 er-cache478) r-cache479 (macros-only-env100 er481)))) (begin (set-cdr! b480 (eval-local-transformer147 (chi140 (cddr b480) r-cache482 (quote (())) mod454) mod454)) (loop476 (cdr bs477) er481 r-cache482)))) (loop476 (cdr bs477) er-cache478 r-cache479))))) (set-cdr! r436 (extend-env98 labels442 bindings445 (cdr r436))) (build-letrec86 #f vars443 (map (lambda (x483) (chi140 (cdr x483) (car x483) (quote (())) mod454)) vals444) (build-sequence83 #f (map (lambda (x484) (chi140 (cdr x484) (car x484) (quote (())) mod454)) (cons (cons er448 (source-wrap133 e451 w452 s453 mod454)) (cdr body440)))))))))))))))))))))) (chi-macro143 (lambda (p485 e486 r487 w488 rib489 mod490) (letrec ((rebuild-macro-output491 (lambda (x492 m493) (cond ((pair? x492) (cons (rebuild-macro-output491 (car x492) m493) (rebuild-macro-output491 (cdr x492) m493))) ((syntax-object?88 x492) (let ((w494 (syntax-object-wrap90 x492))) (let ((ms495 (wrap-marks107 w494)) (s496 (wrap-subst108 w494))) (if (and (pair? ms495) (eq? (car ms495) #f)) (make-syntax-object87 (syntax-object-expression89 x492) (make-wrap106 (cdr ms495) (if rib489 (cons rib489 (cdr s496)) (cdr s496))) (syntax-object-module91 x492)) (make-syntax-object87 (syntax-object-expression89 x492) (make-wrap106 (cons m493 ms495) (if rib489 (cons rib489 (cons (quote shift) s496)) (cons (quote shift) s496))) (let ((pmod497 (procedure-module p485))) (if pmod497 (cons (quote hygiene) (module-name pmod497)) (quote (hygiene guile))))))))) ((vector? x492) (let ((n498 (vector-length x492))) (let ((v499 (make-vector n498))) (let doloop500 ((i501 0)) (if (fx=73 i501 n498) v499 (begin (vector-set! v499 i501 (rebuild-macro-output491 (vector-ref x492 i501) m493)) (doloop500 (fx+71 i501 1)))))))) ((symbol? x492) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap133 e486 w488 s mod490) x492)) (else x492))))) (rebuild-macro-output491 (p485 (wrap132 e486 (anti-mark119 w488) mod490)) (string #\m))))) (chi-application142 (lambda (x502 e503 r504 w505 s506 mod507) ((lambda (tmp508) ((lambda (tmp509) (if tmp509 (apply (lambda (e0510 e1511) (build-annotated79 s506 (cons x502 (map (lambda (e512) (chi140 e512 r504 w505 mod507)) e1511)))) tmp509) (syntax-violation #f "source expression failed to match any pattern" tmp508))) ($sc-dispatch tmp508 (quote (any . each-any))))) e503))) (chi-expr141 (lambda (type514 value515 e516 r517 w518 s519 mod520) (let ((t521 type514)) (if (memv t521 (quote (lexical))) (build-annotated79 s519 value515) (if (memv t521 (quote (core external-macro))) (value515 e516 r517 w518 s519 mod520) (if (memv t521 (quote (module-ref))) (call-with-values (lambda () (value515 e516)) (lambda (id522 mod523) (build-global-reference80 s519 id522 mod523))) (if (memv t521 (quote (lexical-call))) (chi-application142 (build-annotated79 (source-annotation95 (car e516)) value515) e516 r517 w518 s519 mod520) (if (memv t521 (quote (global-call))) (chi-application142 (build-global-reference80 (source-annotation95 (car e516)) value515 (if (syntax-object?88 (car e516)) (syntax-object-module91 (car e516)) mod520)) e516 r517 w518 s519 mod520) (if (memv t521 (quote (constant))) (build-data82 s519 (strip151 (source-wrap133 e516 w518 s519 mod520) (quote (())))) (if (memv t521 (quote (global))) (build-global-reference80 s519 value515 mod520) (if (memv t521 (quote (call))) (chi-application142 (chi140 (car e516) r517 w518 mod520) e516 r517 w518 s519 mod520) (if (memv t521 (quote (begin-form))) ((lambda (tmp524) ((lambda (tmp525) (if tmp525 (apply (lambda (_526 e1527 e2528) (chi-sequence134 (cons e1527 e2528) r517 w518 s519 mod520)) tmp525) (syntax-violation #f "source expression failed to match any pattern" tmp524))) ($sc-dispatch tmp524 (quote (any any . each-any))))) e516) (if (memv t521 (quote (local-syntax-form))) (chi-local-syntax146 value515 e516 r517 w518 s519 mod520 chi-sequence134) (if (memv t521 (quote (eval-when-form))) ((lambda (tmp530) ((lambda (tmp531) (if tmp531 (apply (lambda (_532 x533 e1534 e2535) (let ((when-list536 (chi-when-list137 e516 x533 w518))) (if (memq (quote eval) when-list536) (chi-sequence134 (cons e1534 e2535) r517 w518 s519 mod520) (chi-void148)))) tmp531) (syntax-violation #f "source expression failed to match any pattern" tmp530))) ($sc-dispatch tmp530 (quote (any each-any any . each-any))))) e516) (if (memv t521 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e516 (wrap132 value515 w518 mod520)) (if (memv t521 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap133 e516 w518 s519 mod520)) (if (memv t521 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap133 e516 w518 s519 mod520)) (syntax-violation #f "unexpected syntax" (source-wrap133 e516 w518 s519 mod520))))))))))))))))))) (chi140 (lambda (e539 r540 w541 mod542) (call-with-values (lambda () (syntax-type138 e539 r540 w541 #f #f mod542)) (lambda (type543 value544 e545 w546 s547 mod548) (chi-expr141 type543 value544 e545 r540 w546 s547 mod548))))) (chi-top139 (lambda (e549 r550 w551 m552 esew553 mod554) (call-with-values (lambda () (syntax-type138 e549 r550 w551 #f #f mod554)) (lambda (type562 value563 e564 w565 s566 mod567) (let ((t568 type562)) (if (memv t568 (quote (begin-form))) ((lambda (tmp569) ((lambda (tmp570) (if tmp570 (apply (lambda (_571) (chi-void148)) tmp570) ((lambda (tmp572) (if tmp572 (apply (lambda (_573 e1574 e2575) (chi-top-sequence135 (cons e1574 e2575) r550 w565 s566 m552 esew553 mod567)) tmp572) (syntax-violation #f "source expression failed to match any pattern" tmp569))) ($sc-dispatch tmp569 (quote (any any . each-any)))))) ($sc-dispatch tmp569 (quote (any))))) e564) (if (memv t568 (quote (local-syntax-form))) (chi-local-syntax146 value563 e564 r550 w565 s566 mod567 (lambda (body577 r578 w579 s580 mod581) (chi-top-sequence135 body577 r578 w579 s580 m552 esew553 mod581))) (if (memv t568 (quote (eval-when-form))) ((lambda (tmp582) ((lambda (tmp583) (if tmp583 (apply (lambda (_584 x585 e1586 e2587) (let ((when-list588 (chi-when-list137 e564 x585 w565)) (body589 (cons e1586 e2587))) (cond ((eq? m552 (quote e)) (if (memq (quote eval) when-list588) (chi-top-sequence135 body589 r550 w565 s566 (quote e) (quote (eval)) mod567) (chi-void148))) ((memq (quote load) when-list588) (if (or (memq (quote compile) when-list588) (and (eq? m552 (quote c&e)) (memq (quote eval) when-list588))) (chi-top-sequence135 body589 r550 w565 s566 (quote c&e) (quote (compile load)) mod567) (if (memq m552 (quote (c c&e))) (chi-top-sequence135 body589 r550 w565 s566 (quote c) (quote (load)) mod567) (chi-void148)))) ((or (memq (quote compile) when-list588) (and (eq? m552 (quote c&e)) (memq (quote eval) when-list588))) (top-level-eval-hook75 (chi-top-sequence135 body589 r550 w565 s566 (quote e) (quote (eval)) mod567) mod567) (chi-void148)) (else (chi-void148))))) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp582))) ($sc-dispatch tmp582 (quote (any each-any any . each-any))))) e564) (if (memv t568 (quote (define-syntax-form))) (let ((n592 (id-var-name126 value563 w565)) (r593 (macros-only-env100 r550))) (let ((t594 m552)) (if (memv t594 (quote (c))) (if (memq (quote compile) esew553) (let ((e595 (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)))) (begin (top-level-eval-hook75 e595 mod567) (if (memq (quote load) esew553) e595 (chi-void148)))) (if (memq (quote load) esew553) (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)) (chi-void148))) (if (memv t594 (quote (c&e))) (let ((e596 (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)))) (begin (top-level-eval-hook75 e596 mod567) e596)) (begin (if (memq (quote eval) esew553) (top-level-eval-hook75 (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)) mod567)) (chi-void148)))))) (if (memv t568 (quote (define-form))) (let ((n597 (id-var-name126 value563 w565))) (let ((type598 (binding-type96 (lookup101 n597 r550 mod567)))) (let ((t599 type598)) (if (memv t599 (quote (global core macro module-ref))) (let ((x600 (build-annotated79 s566 (list (quote define) n597 (chi140 e564 r550 w565 mod567))))) (begin (if (eq? m552 (quote c&e)) (top-level-eval-hook75 x600 mod567)) x600)) (if (memv t599 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e564 (wrap132 value563 w565 mod567)) (syntax-violation #f "cannot define keyword at top level" e564 (wrap132 value563 w565 mod567))))))) (let ((x601 (chi-expr141 type562 value563 e564 r550 w565 s566 mod567))) (begin (if (eq? m552 (quote c&e)) (top-level-eval-hook75 x601 mod567)) x601)))))))))))) (syntax-type138 (lambda (e602 r603 w604 s605 rib606 mod607) (cond ((symbol? e602) (let ((n608 (id-var-name126 e602 w604))) (let ((b609 (lookup101 n608 r603 mod607))) (let ((type610 (binding-type96 b609))) (let ((t611 type610)) (if (memv t611 (quote (lexical))) (values type610 (binding-value97 b609) e602 w604 s605 mod607) (if (memv t611 (quote (global))) (values type610 n608 e602 w604 s605 mod607) (if (memv t611 (quote (macro))) (syntax-type138 (chi-macro143 (binding-value97 b609) e602 r603 w604 rib606 mod607) r603 (quote (())) s605 rib606 mod607) (values type610 (binding-value97 b609) e602 w604 s605 mod607))))))))) ((pair? e602) (let ((first612 (car e602))) (if (id?104 first612) (let ((n613 (id-var-name126 first612 w604))) (let ((b614 (lookup101 n613 r603 (or (and (syntax-object?88 first612) (syntax-object-module91 first612)) mod607)))) (let ((type615 (binding-type96 b614))) (let ((t616 type615)) (if (memv t616 (quote (lexical))) (values (quote lexical-call) (binding-value97 b614) e602 w604 s605 mod607) (if (memv t616 (quote (global))) (values (quote global-call) n613 e602 w604 s605 mod607) (if (memv t616 (quote (macro))) (syntax-type138 (chi-macro143 (binding-value97 b614) e602 r603 w604 rib606 mod607) r603 (quote (())) s605 rib606 mod607) (if (memv t616 (quote (core external-macro module-ref))) (values type615 (binding-value97 b614) e602 w604 s605 mod607) (if (memv t616 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value97 b614) e602 w604 s605 mod607) (if (memv t616 (quote (begin))) (values (quote begin-form) #f e602 w604 s605 mod607) (if (memv t616 (quote (eval-when))) (values (quote eval-when-form) #f e602 w604 s605 mod607) (if (memv t616 (quote (define))) ((lambda (tmp617) ((lambda (tmp618) (if (if tmp618 (apply (lambda (_619 name620 val621) (id?104 name620)) tmp618) #f) (apply (lambda (_622 name623 val624) (values (quote define-form) name623 val624 w604 s605 mod607)) tmp618) ((lambda (tmp625) (if (if tmp625 (apply (lambda (_626 name627 args628 e1629 e2630) (and (id?104 name627) (valid-bound-ids?129 (lambda-var-list153 args628)))) tmp625) #f) (apply (lambda (_631 name632 args633 e1634 e2635) (values (quote define-form) (wrap132 name632 w604 mod607) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap132 (cons args633 (cons e1634 e2635)) w604 mod607)) (quote (())) s605 mod607)) tmp625) ((lambda (tmp637) (if (if tmp637 (apply (lambda (_638 name639) (id?104 name639)) tmp637) #f) (apply (lambda (_640 name641) (values (quote define-form) (wrap132 name641 w604 mod607) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s605 mod607)) tmp637) (syntax-violation #f "source expression failed to match any pattern" tmp617))) ($sc-dispatch tmp617 (quote (any any)))))) ($sc-dispatch tmp617 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp617 (quote (any any any))))) e602) (if (memv t616 (quote (define-syntax))) ((lambda (tmp642) ((lambda (tmp643) (if (if tmp643 (apply (lambda (_644 name645 val646) (id?104 name645)) tmp643) #f) (apply (lambda (_647 name648 val649) (values (quote define-syntax-form) name648 val649 w604 s605 mod607)) tmp643) (syntax-violation #f "source expression failed to match any pattern" tmp642))) ($sc-dispatch tmp642 (quote (any any any))))) e602) (values (quote call) #f e602 w604 s605 mod607)))))))))))))) (values (quote call) #f e602 w604 s605 mod607)))) ((syntax-object?88 e602) (syntax-type138 (syntax-object-expression89 e602) r603 (join-wraps123 w604 (syntax-object-wrap90 e602)) #f rib606 (or (syntax-object-module91 e602) mod607))) ((annotation? e602) (syntax-type138 (annotation-expression e602) r603 w604 (annotation-source e602) rib606 mod607)) ((self-evaluating? e602) (values (quote constant) #f e602 w604 s605 mod607)) (else (values (quote other) #f e602 w604 s605 mod607))))) (chi-when-list137 (lambda (e650 when-list651 w652) (let f653 ((when-list654 when-list651) (situations655 (quote ()))) (if (null? when-list654) situations655 (f653 (cdr when-list654) (cons (let ((x656 (car when-list654))) (cond ((free-id=?127 x656 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?127 x656 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?127 x656 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e650 (wrap132 x656 w652 #f))))) situations655)))))) (chi-install-global136 (lambda (name657 e658) (build-annotated79 #f (list (build-annotated79 #f (quote define)) name657 (if (let ((v659 (module-variable (current-module) name657))) (and v659 (variable-bound? v659) (macro? (variable-ref v659)) (not (eq? (macro-type (variable-ref v659)) (quote syncase-macro))))) (build-annotated79 #f (list (build-annotated79 #f (quote make-extended-syncase-macro)) (build-annotated79 #f (list (build-annotated79 #f (quote module-ref)) (build-annotated79 #f (quote (current-module))) (build-data82 #f name657))) (build-data82 #f (quote macro)) e658)) (build-annotated79 #f (list (build-annotated79 #f (quote make-syncase-macro)) (build-data82 #f (quote macro)) e658))))))) (chi-top-sequence135 (lambda (body660 r661 w662 s663 m664 esew665 mod666) (build-sequence83 s663 (let dobody667 ((body668 body660) (r669 r661) (w670 w662) (m671 m664) (esew672 esew665) (mod673 mod666)) (if (null? body668) (quote ()) (let ((first674 (chi-top139 (car body668) r669 w670 m671 esew672 mod673))) (cons first674 (dobody667 (cdr body668) r669 w670 m671 esew672 mod673)))))))) (chi-sequence134 (lambda (body675 r676 w677 s678 mod679) (build-sequence83 s678 (let dobody680 ((body681 body675) (r682 r676) (w683 w677) (mod684 mod679)) (if (null? body681) (quote ()) (let ((first685 (chi140 (car body681) r682 w683 mod684))) (cons first685 (dobody680 (cdr body681) r682 w683 mod684)))))))) (source-wrap133 (lambda (x686 w687 s688 defmod689) (wrap132 (if s688 (make-annotation x686 s688 #f) x686) w687 defmod689))) (wrap132 (lambda (x690 w691 defmod692) (cond ((and (null? (wrap-marks107 w691)) (null? (wrap-subst108 w691))) x690) ((syntax-object?88 x690) (make-syntax-object87 (syntax-object-expression89 x690) (join-wraps123 w691 (syntax-object-wrap90 x690)) (syntax-object-module91 x690))) ((null? x690) x690) (else (make-syntax-object87 x690 w691 defmod692))))) (bound-id-member?131 (lambda (x693 list694) (and (not (null? list694)) (or (bound-id=?128 x693 (car list694)) (bound-id-member?131 x693 (cdr list694)))))) (distinct-bound-ids?130 (lambda (ids695) (let distinct?696 ((ids697 ids695)) (or (null? ids697) (and (not (bound-id-member?131 (car ids697) (cdr ids697))) (distinct?696 (cdr ids697))))))) (valid-bound-ids?129 (lambda (ids698) (and (let all-ids?699 ((ids700 ids698)) (or (null? ids700) (and (id?104 (car ids700)) (all-ids?699 (cdr ids700))))) (distinct-bound-ids?130 ids698)))) (bound-id=?128 (lambda (i701 j702) (if (and (syntax-object?88 i701) (syntax-object?88 j702)) (and (eq? (let ((e703 (syntax-object-expression89 i701))) (if (annotation? e703) (annotation-expression e703) e703)) (let ((e704 (syntax-object-expression89 j702))) (if (annotation? e704) (annotation-expression e704) e704))) (same-marks?125 (wrap-marks107 (syntax-object-wrap90 i701)) (wrap-marks107 (syntax-object-wrap90 j702)))) (eq? (let ((e705 i701)) (if (annotation? e705) (annotation-expression e705) e705)) (let ((e706 j702)) (if (annotation? e706) (annotation-expression e706) e706)))))) (free-id=?127 (lambda (i707 j708) (and (eq? (let ((x709 i707)) (let ((e710 (if (syntax-object?88 x709) (syntax-object-expression89 x709) x709))) (if (annotation? e710) (annotation-expression e710) e710))) (let ((x711 j708)) (let ((e712 (if (syntax-object?88 x711) (syntax-object-expression89 x711) x711))) (if (annotation? e712) (annotation-expression e712) e712)))) (eq? (id-var-name126 i707 (quote (()))) (id-var-name126 j708 (quote (()))))))) (id-var-name126 (lambda (id713 w714) (letrec ((search-vector-rib717 (lambda (sym723 subst724 marks725 symnames726 ribcage727) (let ((n728 (vector-length symnames726))) (let f729 ((i730 0)) (cond ((fx=73 i730 n728) (search715 sym723 (cdr subst724) marks725)) ((and (eq? (vector-ref symnames726 i730) sym723) (same-marks?125 marks725 (vector-ref (ribcage-marks114 ribcage727) i730))) (values (vector-ref (ribcage-labels115 ribcage727) i730) marks725)) (else (f729 (fx+71 i730 1)))))))) (search-list-rib716 (lambda (sym731 subst732 marks733 symnames734 ribcage735) (let f736 ((symnames737 symnames734) (i738 0)) (cond ((null? symnames737) (search715 sym731 (cdr subst732) marks733)) ((and (eq? (car symnames737) sym731) (same-marks?125 marks733 (list-ref (ribcage-marks114 ribcage735) i738))) (values (list-ref (ribcage-labels115 ribcage735) i738) marks733)) (else (f736 (cdr symnames737) (fx+71 i738 1))))))) (search715 (lambda (sym739 subst740 marks741) (if (null? subst740) (values #f marks741) (let ((fst742 (car subst740))) (if (eq? fst742 (quote shift)) (search715 sym739 (cdr subst740) (cdr marks741)) (let ((symnames743 (ribcage-symnames113 fst742))) (if (vector? symnames743) (search-vector-rib717 sym739 subst740 marks741 symnames743 fst742) (search-list-rib716 sym739 subst740 marks741 symnames743 fst742))))))))) (cond ((symbol? id713) (or (call-with-values (lambda () (search715 id713 (wrap-subst108 w714) (wrap-marks107 w714))) (lambda (x745 . ignore744) x745)) id713)) ((syntax-object?88 id713) (let ((id746 (let ((e748 (syntax-object-expression89 id713))) (if (annotation? e748) (annotation-expression e748) e748))) (w1747 (syntax-object-wrap90 id713))) (let ((marks749 (join-marks124 (wrap-marks107 w714) (wrap-marks107 w1747)))) (call-with-values (lambda () (search715 id746 (wrap-subst108 w714) marks749)) (lambda (new-id750 marks751) (or new-id750 (call-with-values (lambda () (search715 id746 (wrap-subst108 w1747) marks751)) (lambda (x753 . ignore752) x753)) id746)))))) ((annotation? id713) (let ((id754 (let ((e755 id713)) (if (annotation? e755) (annotation-expression e755) e755)))) (or (call-with-values (lambda () (search715 id754 (wrap-subst108 w714) (wrap-marks107 w714))) (lambda (x757 . ignore756) x757)) id754))) (else (syntax-violation (quote id-var-name) "invalid id" id713)))))) (same-marks?125 (lambda (x758 y759) (or (eq? x758 y759) (and (not (null? x758)) (not (null? y759)) (eq? (car x758) (car y759)) (same-marks?125 (cdr x758) (cdr y759)))))) (join-marks124 (lambda (m1760 m2761) (smart-append122 m1760 m2761))) (join-wraps123 (lambda (w1762 w2763) (let ((m1764 (wrap-marks107 w1762)) (s1765 (wrap-subst108 w1762))) (if (null? m1764) (if (null? s1765) w2763 (make-wrap106 (wrap-marks107 w2763) (smart-append122 s1765 (wrap-subst108 w2763)))) (make-wrap106 (smart-append122 m1764 (wrap-marks107 w2763)) (smart-append122 s1765 (wrap-subst108 w2763))))))) (smart-append122 (lambda (m1766 m2767) (if (null? m2767) m1766 (append m1766 m2767)))) (make-binding-wrap121 (lambda (ids768 labels769 w770) (if (null? ids768) w770 (make-wrap106 (wrap-marks107 w770) (cons (let ((labelvec771 (list->vector labels769))) (let ((n772 (vector-length labelvec771))) (let ((symnamevec773 (make-vector n772)) (marksvec774 (make-vector n772))) (begin (let f775 ((ids776 ids768) (i777 0)) (if (not (null? ids776)) (call-with-values (lambda () (id-sym-name&marks105 (car ids776) w770)) (lambda (symname778 marks779) (begin (vector-set! symnamevec773 i777 symname778) (vector-set! marksvec774 i777 marks779) (f775 (cdr ids776) (fx+71 i777 1))))))) (make-ribcage111 symnamevec773 marksvec774 labelvec771))))) (wrap-subst108 w770)))))) (extend-ribcage!120 (lambda (ribcage780 id781 label782) (begin (set-ribcage-symnames!116 ribcage780 (cons (let ((e783 (syntax-object-expression89 id781))) (if (annotation? e783) (annotation-expression e783) e783)) (ribcage-symnames113 ribcage780))) (set-ribcage-marks!117 ribcage780 (cons (wrap-marks107 (syntax-object-wrap90 id781)) (ribcage-marks114 ribcage780))) (set-ribcage-labels!118 ribcage780 (cons label782 (ribcage-labels115 ribcage780)))))) (anti-mark119 (lambda (w784) (make-wrap106 (cons #f (wrap-marks107 w784)) (cons (quote shift) (wrap-subst108 w784))))) (set-ribcage-labels!118 (lambda (x785 update786) (vector-set! x785 3 update786))) (set-ribcage-marks!117 (lambda (x787 update788) (vector-set! x787 2 update788))) (set-ribcage-symnames!116 (lambda (x789 update790) (vector-set! x789 1 update790))) (ribcage-labels115 (lambda (x791) (vector-ref x791 3))) (ribcage-marks114 (lambda (x792) (vector-ref x792 2))) (ribcage-symnames113 (lambda (x793) (vector-ref x793 1))) (ribcage?112 (lambda (x794) (and (vector? x794) (= (vector-length x794) 4) (eq? (vector-ref x794 0) (quote ribcage))))) (make-ribcage111 (lambda (symnames795 marks796 labels797) (vector (quote ribcage) symnames795 marks796 labels797))) (gen-labels110 (lambda (ls798) (if (null? ls798) (quote ()) (cons (gen-label109) (gen-labels110 (cdr ls798)))))) (gen-label109 (lambda () (string #\i))) (wrap-subst108 cdr) (wrap-marks107 car) (make-wrap106 cons) (id-sym-name&marks105 (lambda (x799 w800) (if (syntax-object?88 x799) (values (let ((e801 (syntax-object-expression89 x799))) (if (annotation? e801) (annotation-expression e801) e801)) (join-marks124 (wrap-marks107 w800) (wrap-marks107 (syntax-object-wrap90 x799)))) (values (let ((e802 x799)) (if (annotation? e802) (annotation-expression e802) e802)) (wrap-marks107 w800))))) (id?104 (lambda (x803) (cond ((symbol? x803) #t) ((syntax-object?88 x803) (symbol? (let ((e804 (syntax-object-expression89 x803))) (if (annotation? e804) (annotation-expression e804) e804)))) ((annotation? x803) (symbol? (annotation-expression x803))) (else #f)))) (nonsymbol-id?103 (lambda (x805) (and (syntax-object?88 x805) (symbol? (let ((e806 (syntax-object-expression89 x805))) (if (annotation? e806) (annotation-expression e806) e806)))))) (global-extend102 (lambda (type807 sym808 val809) (put-global-definition-hook77 sym808 type807 val809))) (lookup101 (lambda (x810 r811 mod812) (cond ((assq x810 r811) => cdr) ((symbol? x810) (or (get-global-definition-hook78 x810 mod812) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env100 (lambda (r813) (if (null? r813) (quote ()) (let ((a814 (car r813))) (if (eq? (cadr a814) (quote macro)) (cons a814 (macros-only-env100 (cdr r813))) (macros-only-env100 (cdr r813))))))) (extend-var-env99 (lambda (labels815 vars816 r817) (if (null? labels815) r817 (extend-var-env99 (cdr labels815) (cdr vars816) (cons (cons (car labels815) (cons (quote lexical) (car vars816))) r817))))) (extend-env98 (lambda (labels818 bindings819 r820) (if (null? labels818) r820 (extend-env98 (cdr labels818) (cdr bindings819) (cons (cons (car labels818) (car bindings819)) r820))))) (binding-value97 cdr) (binding-type96 car) (source-annotation95 (lambda (x821) (cond ((annotation? x821) (annotation-source x821)) ((syntax-object?88 x821) (source-annotation95 (syntax-object-expression89 x821))) (else #f)))) (set-syntax-object-module!94 (lambda (x822 update823) (vector-set! x822 3 update823))) (set-syntax-object-wrap!93 (lambda (x824 update825) (vector-set! x824 2 update825))) (set-syntax-object-expression!92 (lambda (x826 update827) (vector-set! x826 1 update827))) (syntax-object-module91 (lambda (x828) (vector-ref x828 3))) (syntax-object-wrap90 (lambda (x829) (vector-ref x829 2))) (syntax-object-expression89 (lambda (x830) (vector-ref x830 1))) (syntax-object?88 (lambda (x831) (and (vector? x831) (= (vector-length x831) 4) (eq? (vector-ref x831 0) (quote syntax-object))))) (make-syntax-object87 (lambda (expression832 wrap833 module834) (vector (quote syntax-object) expression832 wrap833 module834))) (build-letrec86 (lambda (src835 vars836 val-exps837 body-exp838) (if (null? vars836) (build-annotated79 src835 body-exp838) (build-annotated79 src835 (list (quote letrec) (map list vars836 val-exps837) body-exp838))))) (build-named-let85 (lambda (src839 vars840 val-exps841 body-exp842) (if (null? vars840) (build-annotated79 src839 body-exp842) (build-annotated79 src839 (list (quote let) (car vars840) (map list (cdr vars840) val-exps841) body-exp842))))) (build-let84 (lambda (src843 vars844 val-exps845 body-exp846) (if (null? vars844) (build-annotated79 src843 body-exp846) (build-annotated79 src843 (list (quote let) (map list vars844 val-exps845) body-exp846))))) (build-sequence83 (lambda (src847 exps848) (if (null? (cdr exps848)) (build-annotated79 src847 (car exps848)) (build-annotated79 src847 (cons (quote begin) exps848))))) (build-data82 (lambda (src849 exp850) (if (and (self-evaluating? exp850) (not (vector? exp850))) (build-annotated79 src849 exp850) (build-annotated79 src849 (list (quote quote) exp850))))) (build-global-assignment81 (lambda (source851 var852 exp853 mod854) (let ((ref855 (build-global-reference80 source851 var852 mod854))) (build-annotated79 source851 (list (quote set!) ref855 exp853))))) (build-global-reference80 (lambda (source856 var857 mod858) (build-annotated79 source856 (if (not mod858) var857 (let ((make-module-ref859 (let ((t862 (fluid-ref *mode*70))) (if (memv t862 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (mod863 var864 public?865) (list (if public?865 (quote @) (quote @@)) mod863 var864))))) (kind860 (car mod858)) (mod861 (cdr mod858))) (let ((t866 kind860)) (if (memv t866 (quote (public))) (make-module-ref859 mod861 var857 #t) (if (memv t866 (quote (private))) (if (not (equal? mod861 (module-name (current-module)))) (make-module-ref859 mod861 var857 #f) var857) (if (memv t866 (quote (bare))) var857 (if (memv t866 (quote (hygiene))) (if (and (not (equal? mod861 (module-name (current-module)))) (module-variable (resolve-module mod861) var857)) (make-module-ref859 mod861 var857 #f) var857) (syntax-violation #f "bad module kind" var857 mod861))))))))))) (build-annotated79 (lambda (src867 exp868) (if (and src867 (not (annotation? exp868))) (make-annotation exp868 src867 #t) exp868))) (get-global-definition-hook78 (lambda (symbol869 module870) (begin (if (and (not module870) (current-module)) (warn "module system is booted, we should have a module" symbol869)) (let ((v871 (module-variable (if module870 (resolve-module (cdr module870)) (current-module)) symbol869))) (and v871 (variable-bound? v871) (let ((val872 (variable-ref v871))) (and (macro? val872) (syncase-macro-type val872) (cons (syncase-macro-type val872) (syncase-macro-binding val872))))))))) (put-global-definition-hook77 (lambda (symbol873 type874 val875) (let ((existing876 (let ((v877 (module-variable (current-module) symbol873))) (and v877 (variable-bound? v877) (let ((val878 (variable-ref v877))) (and (macro? val878) (not (syncase-macro-type val878)) val878)))))) (module-define! (current-module) symbol873 (if existing876 (make-extended-syncase-macro existing876 type874 val875) (make-syncase-macro type874 val875)))))) (local-eval-hook76 (lambda (x879 mod880) (primitive-eval (list noexpand69 (let ((t881 (fluid-ref *mode*70))) (if (memv t881 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x879) x879)))))) (top-level-eval-hook75 (lambda (x882 mod883) (primitive-eval (list noexpand69 (let ((t884 (fluid-ref *mode*70))) (if (memv t884 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x882) x882)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend102 (quote local-syntax) (quote let-syntax) #f) (global-extend102 (quote core) (quote fluid-let-syntax) (lambda (e885 r886 w887 s888 mod889) ((lambda (tmp890) ((lambda (tmp891) (if (if tmp891 (apply (lambda (_892 var893 val894 e1895 e2896) (valid-bound-ids?129 var893)) tmp891) #f) (apply (lambda (_898 var899 val900 e1901 e2902) (let ((names903 (map (lambda (x904) (id-var-name126 x904 w887)) var899))) (begin (for-each (lambda (id906 n907) (let ((t908 (binding-type96 (lookup101 n907 r886 mod889)))) (if (memv t908 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e885 (source-wrap133 id906 w887 s888 mod889))))) var899 names903) (chi-body144 (cons e1901 e2902) (source-wrap133 e885 w887 s888 mod889) (extend-env98 names903 (let ((trans-r911 (macros-only-env100 r886))) (map (lambda (x912) (cons (quote macro) (eval-local-transformer147 (chi140 x912 trans-r911 w887 mod889) mod889))) val900)) r886) w887 mod889)))) tmp891) ((lambda (_914) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap133 e885 w887 s888 mod889))) tmp890))) ($sc-dispatch tmp890 (quote (any #(each (any any)) any . each-any))))) e885))) (global-extend102 (quote core) (quote quote) (lambda (e915 r916 w917 s918 mod919) ((lambda (tmp920) ((lambda (tmp921) (if tmp921 (apply (lambda (_922 e923) (build-data82 s918 (strip151 e923 w917))) tmp921) ((lambda (_924) (syntax-violation (quote quote) "bad syntax" (source-wrap133 e915 w917 s918 mod919))) tmp920))) ($sc-dispatch tmp920 (quote (any any))))) e915))) (global-extend102 (quote core) (quote syntax) (letrec ((regen932 (lambda (x933) (let ((t934 (car x933))) (if (memv t934 (quote (ref))) (build-annotated79 #f (cadr x933)) (if (memv t934 (quote (primitive))) (build-annotated79 #f (cadr x933)) (if (memv t934 (quote (quote))) (build-data82 #f (cadr x933)) (if (memv t934 (quote (lambda))) (build-annotated79 #f (list (quote lambda) (cadr x933) (regen932 (caddr x933)))) (if (memv t934 (quote (map))) (let ((ls935 (map regen932 (cdr x933)))) (build-annotated79 #f (cons (if (fx=73 (length ls935) 2) (build-annotated79 #f (quote map)) (build-annotated79 #f (quote map))) ls935))) (build-annotated79 #f (cons (build-annotated79 #f (car x933)) (map regen932 (cdr x933)))))))))))) (gen-vector931 (lambda (x936) (cond ((eq? (car x936) (quote list)) (cons (quote vector) (cdr x936))) ((eq? (car x936) (quote quote)) (list (quote quote) (list->vector (cadr x936)))) (else (list (quote list->vector) x936))))) (gen-append930 (lambda (x937 y938) (if (equal? y938 (quote (quote ()))) x937 (list (quote append) x937 y938)))) (gen-cons929 (lambda (x939 y940) (let ((t941 (car y940))) (if (memv t941 (quote (quote))) (if (eq? (car x939) (quote quote)) (list (quote quote) (cons (cadr x939) (cadr y940))) (if (eq? (cadr y940) (quote ())) (list (quote list) x939) (list (quote cons) x939 y940))) (if (memv t941 (quote (list))) (cons (quote list) (cons x939 (cdr y940))) (list (quote cons) x939 y940)))))) (gen-map928 (lambda (e942 map-env943) (let ((formals944 (map cdr map-env943)) (actuals945 (map (lambda (x946) (list (quote ref) (car x946))) map-env943))) (cond ((eq? (car e942) (quote ref)) (car actuals945)) ((and-map (lambda (x947) (and (eq? (car x947) (quote ref)) (memq (cadr x947) formals944))) (cdr e942)) (cons (quote map) (cons (list (quote primitive) (car e942)) (map (let ((r948 (map cons formals944 actuals945))) (lambda (x949) (cdr (assq (cadr x949) r948)))) (cdr e942))))) (else (cons (quote map) (cons (list (quote lambda) formals944 e942) actuals945))))))) (gen-mappend927 (lambda (e950 map-env951) (list (quote apply) (quote (primitive append)) (gen-map928 e950 map-env951)))) (gen-ref926 (lambda (src952 var953 level954 maps955) (if (fx=73 level954 0) (values var953 maps955) (if (null? maps955) (syntax-violation (quote syntax) "missing ellipsis" src952) (call-with-values (lambda () (gen-ref926 src952 var953 (fx-72 level954 1) (cdr maps955))) (lambda (outer-var956 outer-maps957) (let ((b958 (assq outer-var956 (car maps955)))) (if b958 (values (cdr b958) maps955) (let ((inner-var959 (gen-var152 (quote tmp)))) (values inner-var959 (cons (cons (cons outer-var956 inner-var959) (car maps955)) outer-maps957))))))))))) (gen-syntax925 (lambda (src960 e961 r962 maps963 ellipsis?964 mod965) (if (id?104 e961) (let ((label966 (id-var-name126 e961 (quote (()))))) (let ((b967 (lookup101 label966 r962 mod965))) (if (eq? (binding-type96 b967) (quote syntax)) (call-with-values (lambda () (let ((var.lev968 (binding-value97 b967))) (gen-ref926 src960 (car var.lev968) (cdr var.lev968) maps963))) (lambda (var969 maps970) (values (list (quote ref) var969) maps970))) (if (ellipsis?964 e961) (syntax-violation (quote syntax) "misplaced ellipsis" src960) (values (list (quote quote) e961) maps963))))) ((lambda (tmp971) ((lambda (tmp972) (if (if tmp972 (apply (lambda (dots973 e974) (ellipsis?964 dots973)) tmp972) #f) (apply (lambda (dots975 e976) (gen-syntax925 src960 e976 r962 maps963 (lambda (x977) #f) mod965)) tmp972) ((lambda (tmp978) (if (if tmp978 (apply (lambda (x979 dots980 y981) (ellipsis?964 dots980)) tmp978) #f) (apply (lambda (x982 dots983 y984) (let f985 ((y986 y984) (k987 (lambda (maps988) (call-with-values (lambda () (gen-syntax925 src960 x982 r962 (cons (quote ()) maps988) ellipsis?964 mod965)) (lambda (x989 maps990) (if (null? (car maps990)) (syntax-violation (quote syntax) "extra ellipsis" src960) (values (gen-map928 x989 (car maps990)) (cdr maps990)))))))) ((lambda (tmp991) ((lambda (tmp992) (if (if tmp992 (apply (lambda (dots993 y994) (ellipsis?964 dots993)) tmp992) #f) (apply (lambda (dots995 y996) (f985 y996 (lambda (maps997) (call-with-values (lambda () (k987 (cons (quote ()) maps997))) (lambda (x998 maps999) (if (null? (car maps999)) (syntax-violation (quote syntax) "extra ellipsis" src960) (values (gen-mappend927 x998 (car maps999)) (cdr maps999)))))))) tmp992) ((lambda (_1000) (call-with-values (lambda () (gen-syntax925 src960 y986 r962 maps963 ellipsis?964 mod965)) (lambda (y1001 maps1002) (call-with-values (lambda () (k987 maps1002)) (lambda (x1003 maps1004) (values (gen-append930 x1003 y1001) maps1004)))))) tmp991))) ($sc-dispatch tmp991 (quote (any . any))))) y986))) tmp978) ((lambda (tmp1005) (if tmp1005 (apply (lambda (x1006 y1007) (call-with-values (lambda () (gen-syntax925 src960 x1006 r962 maps963 ellipsis?964 mod965)) (lambda (x1008 maps1009) (call-with-values (lambda () (gen-syntax925 src960 y1007 r962 maps1009 ellipsis?964 mod965)) (lambda (y1010 maps1011) (values (gen-cons929 x1008 y1010) maps1011)))))) tmp1005) ((lambda (tmp1012) (if tmp1012 (apply (lambda (e11013 e21014) (call-with-values (lambda () (gen-syntax925 src960 (cons e11013 e21014) r962 maps963 ellipsis?964 mod965)) (lambda (e1016 maps1017) (values (gen-vector931 e1016) maps1017)))) tmp1012) ((lambda (_1018) (values (list (quote quote) e961) maps963)) tmp971))) ($sc-dispatch tmp971 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp971 (quote (any . any)))))) ($sc-dispatch tmp971 (quote (any any . any)))))) ($sc-dispatch tmp971 (quote (any any))))) e961))))) (lambda (e1019 r1020 w1021 s1022 mod1023) (let ((e1024 (source-wrap133 e1019 w1021 s1022 mod1023))) ((lambda (tmp1025) ((lambda (tmp1026) (if tmp1026 (apply (lambda (_1027 x1028) (call-with-values (lambda () (gen-syntax925 e1024 x1028 r1020 (quote ()) ellipsis?149 mod1023)) (lambda (e1029 maps1030) (regen932 e1029)))) tmp1026) ((lambda (_1031) (syntax-violation (quote syntax) "bad `syntax' form" e1024)) tmp1025))) ($sc-dispatch tmp1025 (quote (any any))))) e1024))))) (global-extend102 (quote core) (quote lambda) (lambda (e1032 r1033 w1034 s1035 mod1036) ((lambda (tmp1037) ((lambda (tmp1038) (if tmp1038 (apply (lambda (_1039 c1040) (chi-lambda-clause145 (source-wrap133 e1032 w1034 s1035 mod1036) #f c1040 r1033 w1034 mod1036 (lambda (vars1041 docstring1042 body1043) (build-annotated79 s1035 (cons (quote lambda) (cons vars1041 (append (if docstring1042 (list docstring1042) (quote ())) (list body1043)))))))) tmp1038) (syntax-violation #f "source expression failed to match any pattern" tmp1037))) ($sc-dispatch tmp1037 (quote (any . any))))) e1032))) (global-extend102 (quote core) (quote let) (letrec ((chi-let1044 (lambda (e1045 r1046 w1047 s1048 mod1049 constructor1050 ids1051 vals1052 exps1053) (if (not (valid-bound-ids?129 ids1051)) (syntax-violation (quote let) "duplicate bound variable" e1045) (let ((labels1054 (gen-labels110 ids1051)) (new-vars1055 (map gen-var152 ids1051))) (let ((nw1056 (make-binding-wrap121 ids1051 labels1054 w1047)) (nr1057 (extend-var-env99 labels1054 new-vars1055 r1046))) (constructor1050 s1048 new-vars1055 (map (lambda (x1058) (chi140 x1058 r1046 w1047 mod1049)) vals1052) (chi-body144 exps1053 (source-wrap133 e1045 nw1056 s1048 mod1049) nr1057 nw1056 mod1049)))))))) (lambda (e1059 r1060 w1061 s1062 mod1063) ((lambda (tmp1064) ((lambda (tmp1065) (if tmp1065 (apply (lambda (_1066 id1067 val1068 e11069 e21070) (chi-let1044 e1059 r1060 w1061 s1062 mod1063 build-let84 id1067 val1068 (cons e11069 e21070))) tmp1065) ((lambda (tmp1074) (if (if tmp1074 (apply (lambda (_1075 f1076 id1077 val1078 e11079 e21080) (id?104 f1076)) tmp1074) #f) (apply (lambda (_1081 f1082 id1083 val1084 e11085 e21086) (chi-let1044 e1059 r1060 w1061 s1062 mod1063 build-named-let85 (cons f1082 id1083) val1084 (cons e11085 e21086))) tmp1074) ((lambda (_1090) (syntax-violation (quote let) "bad let" (source-wrap133 e1059 w1061 s1062 mod1063))) tmp1064))) ($sc-dispatch tmp1064 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1064 (quote (any #(each (any any)) any . each-any))))) e1059)))) (global-extend102 (quote core) (quote letrec) (lambda (e1091 r1092 w1093 s1094 mod1095) ((lambda (tmp1096) ((lambda (tmp1097) (if tmp1097 (apply (lambda (_1098 id1099 val1100 e11101 e21102) (let ((ids1103 id1099)) (if (not (valid-bound-ids?129 ids1103)) (syntax-violation (quote letrec) "duplicate bound variable" e1091) (let ((labels1105 (gen-labels110 ids1103)) (new-vars1106 (map gen-var152 ids1103))) (let ((w1107 (make-binding-wrap121 ids1103 labels1105 w1093)) (r1108 (extend-var-env99 labels1105 new-vars1106 r1092))) (build-letrec86 s1094 new-vars1106 (map (lambda (x1109) (chi140 x1109 r1108 w1107 mod1095)) val1100) (chi-body144 (cons e11101 e21102) (source-wrap133 e1091 w1107 s1094 mod1095) r1108 w1107 mod1095))))))) tmp1097) ((lambda (_1112) (syntax-violation (quote letrec) "bad letrec" (source-wrap133 e1091 w1093 s1094 mod1095))) tmp1096))) ($sc-dispatch tmp1096 (quote (any #(each (any any)) any . each-any))))) e1091))) (global-extend102 (quote core) (quote set!) (lambda (e1113 r1114 w1115 s1116 mod1117) ((lambda (tmp1118) ((lambda (tmp1119) (if (if tmp1119 (apply (lambda (_1120 id1121 val1122) (id?104 id1121)) tmp1119) #f) (apply (lambda (_1123 id1124 val1125) (let ((val1126 (chi140 val1125 r1114 w1115 mod1117)) (n1127 (id-var-name126 id1124 w1115))) (let ((b1128 (lookup101 n1127 r1114 mod1117))) (let ((t1129 (binding-type96 b1128))) (if (memv t1129 (quote (lexical))) (build-annotated79 s1116 (list (quote set!) (binding-value97 b1128) val1126)) (if (memv t1129 (quote (global))) (build-global-assignment81 s1116 n1127 val1126 mod1117) (if (memv t1129 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap132 id1124 w1115 mod1117)) (syntax-violation (quote set!) "bad set!" (source-wrap133 e1113 w1115 s1116 mod1117))))))))) tmp1119) ((lambda (tmp1130) (if tmp1130 (apply (lambda (_1131 head1132 tail1133 val1134) (call-with-values (lambda () (syntax-type138 head1132 r1114 (quote (())) #f #f mod1117)) (lambda (type1135 value1136 ee1137 ww1138 ss1139 modmod1140) (let ((t1141 type1135)) (if (memv t1141 (quote (module-ref))) (let ((val1142 (chi140 val1134 r1114 w1115 mod1117))) (call-with-values (lambda () (value1136 (cons head1132 tail1133))) (lambda (id1144 mod1145) (build-global-assignment81 s1116 id1144 val1142 mod1145)))) (build-annotated79 s1116 (cons (chi140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1132) r1114 w1115 mod1117) (map (lambda (e1146) (chi140 e1146 r1114 w1115 mod1117)) (append tail1133 (list val1134)))))))))) tmp1130) ((lambda (_1148) (syntax-violation (quote set!) "bad set!" (source-wrap133 e1113 w1115 s1116 mod1117))) tmp1118))) ($sc-dispatch tmp1118 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1118 (quote (any any any))))) e1113))) (global-extend102 (quote module-ref) (quote @) (lambda (e1149) ((lambda (tmp1150) ((lambda (tmp1151) (if (if tmp1151 (apply (lambda (_1152 mod1153 id1154) (and (and-map id?104 mod1153) (id?104 id1154))) tmp1151) #f) (apply (lambda (_1156 mod1157 id1158) (values (syntax->datum id1158) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1157)))) tmp1151) (syntax-violation #f "source expression failed to match any pattern" tmp1150))) ($sc-dispatch tmp1150 (quote (any each-any any))))) e1149))) (global-extend102 (quote module-ref) (quote @@) (lambda (e1160) ((lambda (tmp1161) ((lambda (tmp1162) (if (if tmp1162 (apply (lambda (_1163 mod1164 id1165) (and (and-map id?104 mod1164) (id?104 id1165))) tmp1162) #f) (apply (lambda (_1167 mod1168 id1169) (values (syntax->datum id1169) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1168)))) tmp1162) (syntax-violation #f "source expression failed to match any pattern" tmp1161))) ($sc-dispatch tmp1161 (quote (any each-any any))))) e1160))) (global-extend102 (quote begin) (quote begin) (quote ())) (global-extend102 (quote define) (quote define) (quote ())) (global-extend102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend102 (quote eval-when) (quote eval-when) (quote ())) (global-extend102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1174 (lambda (x1175 keys1176 clauses1177 r1178 mod1179) (if (null? clauses1177) (build-annotated79 #f (list (build-annotated79 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1175)) ((lambda (tmp1180) ((lambda (tmp1181) (if tmp1181 (apply (lambda (pat1182 exp1183) (if (and (id?104 pat1182) (and-map (lambda (x1184) (not (free-id=?127 pat1182 x1184))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1176))) (let ((labels1185 (list (gen-label109))) (var1186 (gen-var152 pat1182))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list var1186) (chi140 exp1183 (extend-env98 labels1185 (list (cons (quote syntax) (cons var1186 0))) r1178) (make-binding-wrap121 (list pat1182) labels1185 (quote (()))) mod1179))) x1175))) (gen-clause1173 x1175 keys1176 (cdr clauses1177) r1178 pat1182 #t exp1183 mod1179))) tmp1181) ((lambda (tmp1187) (if tmp1187 (apply (lambda (pat1188 fender1189 exp1190) (gen-clause1173 x1175 keys1176 (cdr clauses1177) r1178 pat1188 fender1189 exp1190 mod1179)) tmp1187) ((lambda (_1191) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1177))) tmp1180))) ($sc-dispatch tmp1180 (quote (any any any)))))) ($sc-dispatch tmp1180 (quote (any any))))) (car clauses1177))))) (gen-clause1173 (lambda (x1192 keys1193 clauses1194 r1195 pat1196 fender1197 exp1198 mod1199) (call-with-values (lambda () (convert-pattern1171 pat1196 keys1193)) (lambda (p1200 pvars1201) (cond ((not (distinct-bound-ids?130 (map car pvars1201))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1196)) ((not (and-map (lambda (x1202) (not (ellipsis?149 (car x1202)))) pvars1201)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1196)) (else (let ((y1203 (gen-var152 (quote tmp)))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list y1203) (let ((y1204 (build-annotated79 #f y1203))) (build-annotated79 #f (list (quote if) ((lambda (tmp1205) ((lambda (tmp1206) (if tmp1206 (apply (lambda () y1204) tmp1206) ((lambda (_1207) (build-annotated79 #f (list (quote if) y1204 (build-dispatch-call1172 pvars1201 fender1197 y1204 r1195 mod1199) (build-data82 #f #f)))) tmp1205))) ($sc-dispatch tmp1205 (quote #(atom #t))))) fender1197) (build-dispatch-call1172 pvars1201 exp1198 y1204 r1195 mod1199) (gen-syntax-case1174 x1192 keys1193 clauses1194 r1195 mod1199)))))) (if (eq? p1200 (quote any)) (build-annotated79 #f (list (build-annotated79 #f (quote list)) x1192)) (build-annotated79 #f (list (build-annotated79 #f (quote $sc-dispatch)) x1192 (build-data82 #f p1200))))))))))))) (build-dispatch-call1172 (lambda (pvars1208 exp1209 y1210 r1211 mod1212) (let ((ids1213 (map car pvars1208)) (levels1214 (map cdr pvars1208))) (let ((labels1215 (gen-labels110 ids1213)) (new-vars1216 (map gen-var152 ids1213))) (build-annotated79 #f (list (build-annotated79 #f (quote apply)) (build-annotated79 #f (list (quote lambda) new-vars1216 (chi140 exp1209 (extend-env98 labels1215 (map (lambda (var1217 level1218) (cons (quote syntax) (cons var1217 level1218))) new-vars1216 (map cdr pvars1208)) r1211) (make-binding-wrap121 ids1213 labels1215 (quote (()))) mod1212))) y1210)))))) (convert-pattern1171 (lambda (pattern1219 keys1220) (let cvt1221 ((p1222 pattern1219) (n1223 0) (ids1224 (quote ()))) (if (id?104 p1222) (if (bound-id-member?131 p1222 keys1220) (values (vector (quote free-id) p1222) ids1224) (values (quote any) (cons (cons p1222 n1223) ids1224))) ((lambda (tmp1225) ((lambda (tmp1226) (if (if tmp1226 (apply (lambda (x1227 dots1228) (ellipsis?149 dots1228)) tmp1226) #f) (apply (lambda (x1229 dots1230) (call-with-values (lambda () (cvt1221 x1229 (fx+71 n1223 1) ids1224)) (lambda (p1231 ids1232) (values (if (eq? p1231 (quote any)) (quote each-any) (vector (quote each) p1231)) ids1232)))) tmp1226) ((lambda (tmp1233) (if tmp1233 (apply (lambda (x1234 y1235) (call-with-values (lambda () (cvt1221 y1235 n1223 ids1224)) (lambda (y1236 ids1237) (call-with-values (lambda () (cvt1221 x1234 n1223 ids1237)) (lambda (x1238 ids1239) (values (cons x1238 y1236) ids1239)))))) tmp1233) ((lambda (tmp1240) (if tmp1240 (apply (lambda () (values (quote ()) ids1224)) tmp1240) ((lambda (tmp1241) (if tmp1241 (apply (lambda (x1242) (call-with-values (lambda () (cvt1221 x1242 n1223 ids1224)) (lambda (p1244 ids1245) (values (vector (quote vector) p1244) ids1245)))) tmp1241) ((lambda (x1246) (values (vector (quote atom) (strip151 p1222 (quote (())))) ids1224)) tmp1225))) ($sc-dispatch tmp1225 (quote #(vector each-any)))))) ($sc-dispatch tmp1225 (quote ()))))) ($sc-dispatch tmp1225 (quote (any . any)))))) ($sc-dispatch tmp1225 (quote (any any))))) p1222)))))) (lambda (e1247 r1248 w1249 s1250 mod1251) (let ((e1252 (source-wrap133 e1247 w1249 s1250 mod1251))) ((lambda (tmp1253) ((lambda (tmp1254) (if tmp1254 (apply (lambda (_1255 val1256 key1257 m1258) (if (and-map (lambda (x1259) (and (id?104 x1259) (not (ellipsis?149 x1259)))) key1257) (let ((x1261 (gen-var152 (quote tmp)))) (build-annotated79 s1250 (list (build-annotated79 #f (list (quote lambda) (list x1261) (gen-syntax-case1174 (build-annotated79 #f x1261) key1257 m1258 r1248 mod1251))) (chi140 val1256 r1248 (quote (())) mod1251)))) (syntax-violation (quote syntax-case) "invalid literals list" e1252))) tmp1254) (syntax-violation #f "source expression failed to match any pattern" tmp1253))) ($sc-dispatch tmp1253 (quote (any any each-any . each-any))))) e1252))))) (set! sc-expand (lambda (x1265 . rest1264) (if (and (pair? x1265) (equal? (car x1265) noexpand69)) (cadr x1265) (let ((m1266 (if (null? rest1264) (quote e) (car rest1264))) (esew1267 (if (or (null? rest1264) (null? (cdr rest1264))) (quote (eval)) (cadr rest1264)))) (with-fluid* *mode*70 m1266 (lambda () (chi-top139 x1265 (quote ()) (quote ((top))) m1266 esew1267 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1268) (nonsymbol-id?103 x1268))) (set! datum->syntax (lambda (id1269 datum1270) (make-syntax-object87 datum1270 (syntax-object-wrap90 id1269) #f))) (set! syntax->datum (lambda (x1271) (strip151 x1271 (quote (()))))) (set! generate-temporaries (lambda (ls1272) (begin (let ((x1273 ls1272)) (if (not (list? x1273)) (syntax-violation (quote generate-temporaries) "invalid argument" x1273))) (map (lambda (x1274) (wrap132 (gensym) (quote ((top))) #f)) ls1272)))) (set! free-identifier=? (lambda (x1275 y1276) (begin (let ((x1277 x1275)) (if (not (nonsymbol-id?103 x1277)) (syntax-violation (quote free-identifier=?) "invalid argument" x1277))) (let ((x1278 y1276)) (if (not (nonsymbol-id?103 x1278)) (syntax-violation (quote free-identifier=?) "invalid argument" x1278))) (free-id=?127 x1275 y1276)))) (set! bound-identifier=? (lambda (x1279 y1280) (begin (let ((x1281 x1279)) (if (not (nonsymbol-id?103 x1281)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1281))) (let ((x1282 y1280)) (if (not (nonsymbol-id?103 x1282)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1282))) (bound-id=?128 x1279 y1280)))) (set! syntax-violation (lambda (who1286 message1285 form1284 . subform1283) (begin (let ((x1287 who1286)) (if (not ((lambda (x1288) (or (not x1288) (string? x1288) (symbol? x1288))) x1287)) (syntax-violation (quote syntax-violation) "invalid argument" x1287))) (let ((x1289 message1285)) (if (not (string? x1289)) (syntax-violation (quote syntax-violation) "invalid argument" x1289))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1286 "~a: " "") "~a " (if (null? subform1283) "in ~a" "in subform `~s' of `~s'")) (let ((tail1290 (cons message1285 (map (lambda (x1291) (strip151 x1291 (quote (())))) (append subform1283 (list form1284)))))) (if who1286 (cons who1286 tail1290) tail1290)) #f)))) (letrec ((match1296 (lambda (e1297 p1298 w1299 r1300 mod1301) (cond ((not r1300) #f) ((eq? p1298 (quote any)) (cons (wrap132 e1297 w1299 mod1301) r1300)) ((syntax-object?88 e1297) (match*1295 (let ((e1302 (syntax-object-expression89 e1297))) (if (annotation? e1302) (annotation-expression e1302) e1302)) p1298 (join-wraps123 w1299 (syntax-object-wrap90 e1297)) r1300 (syntax-object-module91 e1297))) (else (match*1295 (let ((e1303 e1297)) (if (annotation? e1303) (annotation-expression e1303) e1303)) p1298 w1299 r1300 mod1301))))) (match*1295 (lambda (e1304 p1305 w1306 r1307 mod1308) (cond ((null? p1305) (and (null? e1304) r1307)) ((pair? p1305) (and (pair? e1304) (match1296 (car e1304) (car p1305) w1306 (match1296 (cdr e1304) (cdr p1305) w1306 r1307 mod1308) mod1308))) ((eq? p1305 (quote each-any)) (let ((l1309 (match-each-any1293 e1304 w1306 mod1308))) (and l1309 (cons l1309 r1307)))) (else (let ((t1310 (vector-ref p1305 0))) (if (memv t1310 (quote (each))) (if (null? e1304) (match-empty1294 (vector-ref p1305 1) r1307) (let ((l1311 (match-each1292 e1304 (vector-ref p1305 1) w1306 mod1308))) (and l1311 (let collect1312 ((l1313 l1311)) (if (null? (car l1313)) r1307 (cons (map car l1313) (collect1312 (map cdr l1313)))))))) (if (memv t1310 (quote (free-id))) (and (id?104 e1304) (free-id=?127 (wrap132 e1304 w1306 mod1308) (vector-ref p1305 1)) r1307) (if (memv t1310 (quote (atom))) (and (equal? (vector-ref p1305 1) (strip151 e1304 w1306)) r1307) (if (memv t1310 (quote (vector))) (and (vector? e1304) (match1296 (vector->list e1304) (vector-ref p1305 1) w1306 r1307 mod1308))))))))))) (match-empty1294 (lambda (p1314 r1315) (cond ((null? p1314) r1315) ((eq? p1314 (quote any)) (cons (quote ()) r1315)) ((pair? p1314) (match-empty1294 (car p1314) (match-empty1294 (cdr p1314) r1315))) ((eq? p1314 (quote each-any)) (cons (quote ()) r1315)) (else (let ((t1316 (vector-ref p1314 0))) (if (memv t1316 (quote (each))) (match-empty1294 (vector-ref p1314 1) r1315) (if (memv t1316 (quote (free-id atom))) r1315 (if (memv t1316 (quote (vector))) (match-empty1294 (vector-ref p1314 1) r1315))))))))) (match-each-any1293 (lambda (e1317 w1318 mod1319) (cond ((annotation? e1317) (match-each-any1293 (annotation-expression e1317) w1318 mod1319)) ((pair? e1317) (let ((l1320 (match-each-any1293 (cdr e1317) w1318 mod1319))) (and l1320 (cons (wrap132 (car e1317) w1318 mod1319) l1320)))) ((null? e1317) (quote ())) ((syntax-object?88 e1317) (match-each-any1293 (syntax-object-expression89 e1317) (join-wraps123 w1318 (syntax-object-wrap90 e1317)) mod1319)) (else #f)))) (match-each1292 (lambda (e1321 p1322 w1323 mod1324) (cond ((annotation? e1321) (match-each1292 (annotation-expression e1321) p1322 w1323 mod1324)) ((pair? e1321) (let ((first1325 (match1296 (car e1321) p1322 w1323 (quote ()) mod1324))) (and first1325 (let ((rest1326 (match-each1292 (cdr e1321) p1322 w1323 mod1324))) (and rest1326 (cons first1325 rest1326)))))) ((null? e1321) (quote ())) ((syntax-object?88 e1321) (match-each1292 (syntax-object-expression89 e1321) p1322 (join-wraps123 w1323 (syntax-object-wrap90 e1321)) (syntax-object-module91 e1321))) (else #f))))) (set! $sc-dispatch (lambda (e1327 p1328) (cond ((eq? p1328 (quote any)) (list e1327)) ((syntax-object?88 e1327) (match*1295 (let ((e1329 (syntax-object-expression89 e1327))) (if (annotation? e1329) (annotation-expression e1329) e1329)) p1328 (syntax-object-wrap90 e1327) (quote ()) (syntax-object-module91 e1327))) (else (match*1295 (let ((e1330 e1327)) (if (annotation? e1330) (annotation-expression e1330) e1330)) p1328 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1331) ((lambda (tmp1332) ((lambda (tmp1333) (if tmp1333 (apply (lambda (_1334 e11335 e21336) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11335 e21336))) tmp1333) ((lambda (tmp1338) (if tmp1338 (apply (lambda (_1339 out1340 in1341 e11342 e21343) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1341 (quote ()) (list out1340 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11342 e21343))))) tmp1338) ((lambda (tmp1345) (if tmp1345 (apply (lambda (_1346 out1347 in1348 e11349 e21350) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1348) (quote ()) (list out1347 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11349 e21350))))) tmp1345) (syntax-violation #f "source expression failed to match any pattern" tmp1332))) ($sc-dispatch tmp1332 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1332 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1332 (quote (any () any . each-any))))) x1331)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1354) ((lambda (tmp1355) ((lambda (tmp1356) (if tmp1356 (apply (lambda (_1357 k1358 keyword1359 pattern1360 template1361) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1358 (map (lambda (tmp1364 tmp1363) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1363) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1364))) template1361 pattern1360)))))) tmp1356) (syntax-violation #f "source expression failed to match any pattern" tmp1355))) ($sc-dispatch tmp1355 (quote (any each-any . #(each ((any . any) any))))))) x1354)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1365) ((lambda (tmp1366) ((lambda (tmp1367) (if (if tmp1367 (apply (lambda (let*1368 x1369 v1370 e11371 e21372) (and-map identifier? x1369)) tmp1367) #f) (apply (lambda (let*1374 x1375 v1376 e11377 e21378) (let f1379 ((bindings1380 (map list x1375 v1376))) (if (null? bindings1380) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11377 e21378))) ((lambda (tmp1384) ((lambda (tmp1385) (if tmp1385 (apply (lambda (body1386 binding1387) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1387) body1386)) tmp1385) (syntax-violation #f "source expression failed to match any pattern" tmp1384))) ($sc-dispatch tmp1384 (quote (any any))))) (list (f1379 (cdr bindings1380)) (car bindings1380)))))) tmp1367) (syntax-violation #f "source expression failed to match any pattern" tmp1366))) ($sc-dispatch tmp1366 (quote (any #(each (any any)) any . each-any))))) x1365)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1388) ((lambda (tmp1389) ((lambda (tmp1390) (if tmp1390 (apply (lambda (_1391 var1392 init1393 step1394 e01395 e11396 c1397) ((lambda (tmp1398) ((lambda (tmp1399) (if tmp1399 (apply (lambda (step1400) ((lambda (tmp1401) ((lambda (tmp1402) (if tmp1402 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1392 init1393) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01395) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1397 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1400))))))) tmp1402) ((lambda (tmp1407) (if tmp1407 (apply (lambda (e11408 e21409) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1392 init1393) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01395 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11408 e21409)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1397 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1400))))))) tmp1407) (syntax-violation #f "source expression failed to match any pattern" tmp1401))) ($sc-dispatch tmp1401 (quote (any . each-any)))))) ($sc-dispatch tmp1401 (quote ())))) e11396)) tmp1399) (syntax-violation #f "source expression failed to match any pattern" tmp1398))) ($sc-dispatch tmp1398 (quote each-any)))) (map (lambda (v1416 s1417) ((lambda (tmp1418) ((lambda (tmp1419) (if tmp1419 (apply (lambda () v1416) tmp1419) ((lambda (tmp1420) (if tmp1420 (apply (lambda (e1421) e1421) tmp1420) ((lambda (_1422) (syntax-violation (quote do) "bad step expression" orig-x1388 s1417)) tmp1418))) ($sc-dispatch tmp1418 (quote (any)))))) ($sc-dispatch tmp1418 (quote ())))) s1417)) var1392 step1394))) tmp1390) (syntax-violation #f "source expression failed to match any pattern" tmp1389))) ($sc-dispatch tmp1389 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1388)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1425 (lambda (x1429 y1430) ((lambda (tmp1431) ((lambda (tmp1432) (if tmp1432 (apply (lambda (x1433 y1434) ((lambda (tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (dy1437) ((lambda (tmp1438) ((lambda (tmp1439) (if tmp1439 (apply (lambda (dx1440) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1440 dy1437))) tmp1439) ((lambda (_1441) (if (null? dy1437) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1433) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1433 y1434))) tmp1438))) ($sc-dispatch tmp1438 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1433)) tmp1436) ((lambda (tmp1442) (if tmp1442 (apply (lambda (stuff1443) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1433 stuff1443))) tmp1442) ((lambda (else1444) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1433 y1434)) tmp1435))) ($sc-dispatch tmp1435 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1434)) tmp1432) (syntax-violation #f "source expression failed to match any pattern" tmp1431))) ($sc-dispatch tmp1431 (quote (any any))))) (list x1429 y1430)))) (quasiappend1426 (lambda (x1445 y1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (x1449 y1450) ((lambda (tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda () x1449) tmp1452) ((lambda (_1453) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449 y1450)) tmp1451))) ($sc-dispatch tmp1451 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1450)) tmp1448) (syntax-violation #f "source expression failed to match any pattern" tmp1447))) ($sc-dispatch tmp1447 (quote (any any))))) (list x1445 y1446)))) (quasivector1427 (lambda (x1454) ((lambda (tmp1455) ((lambda (x1456) ((lambda (tmp1457) ((lambda (tmp1458) (if tmp1458 (apply (lambda (x1459) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1459))) tmp1458) ((lambda (tmp1461) (if tmp1461 (apply (lambda (x1462) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462)) tmp1461) ((lambda (_1464) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1456)) tmp1457))) ($sc-dispatch tmp1457 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1457 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1456)) tmp1455)) x1454))) (quasi1428 (lambda (p1465 lev1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda (p1469) (if (= lev1466 0) p1469 (quasicons1425 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1428 (list p1469) (- lev1466 1))))) tmp1468) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471 q1472) (if (= lev1466 0) (quasiappend1426 p1471 (quasi1428 q1472 lev1466)) (quasicons1425 (quasicons1425 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1428 (list p1471) (- lev1466 1))) (quasi1428 q1472 lev1466)))) tmp1470) ((lambda (tmp1473) (if tmp1473 (apply (lambda (p1474) (quasicons1425 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1428 (list p1474) (+ lev1466 1)))) tmp1473) ((lambda (tmp1475) (if tmp1475 (apply (lambda (p1476 q1477) (quasicons1425 (quasi1428 p1476 lev1466) (quasi1428 q1477 lev1466))) tmp1475) ((lambda (tmp1478) (if tmp1478 (apply (lambda (x1479) (quasivector1427 (quasi1428 x1479 lev1466))) tmp1478) ((lambda (p1481) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1481)) tmp1467))) ($sc-dispatch tmp1467 (quote #(vector each-any)))))) ($sc-dispatch tmp1467 (quote (any . any)))))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1467 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1465)))) (lambda (x1482) ((lambda (tmp1483) ((lambda (tmp1484) (if tmp1484 (apply (lambda (_1485 e1486) (quasi1428 e1486 0)) tmp1484) (syntax-violation #f "source expression failed to match any pattern" tmp1483))) ($sc-dispatch tmp1483 (quote (any any))))) x1482))))) +(define include (make-syncase-macro (quote macro) (lambda (x1487) (letrec ((read-file1488 (lambda (fn1489 k1490) (let ((p1491 (open-input-file fn1489))) (let f1492 ((x1493 (read p1491))) (if (eof-object? x1493) (begin (close-input-port p1491) (quote ())) (cons (datum->syntax k1490 x1493) (f1492 (read p1491))))))))) ((lambda (tmp1494) ((lambda (tmp1495) (if tmp1495 (apply (lambda (k1496 filename1497) (let ((fn1498 (syntax->datum filename1497))) ((lambda (tmp1499) ((lambda (tmp1500) (if tmp1500 (apply (lambda (exp1501) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1501)) tmp1500) (syntax-violation #f "source expression failed to match any pattern" tmp1499))) ($sc-dispatch tmp1499 (quote each-any)))) (read-file1488 fn1498 k1496)))) tmp1495) (syntax-violation #f "source expression failed to match any pattern" tmp1494))) ($sc-dispatch tmp1494 (quote (any any))))) x1487))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1503) ((lambda (tmp1504) ((lambda (tmp1505) (if tmp1505 (apply (lambda (_1506 e1507) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1503)) tmp1505) (syntax-violation #f "source expression failed to match any pattern" tmp1504))) ($sc-dispatch tmp1504 (quote (any any))))) x1503)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1508) ((lambda (tmp1509) ((lambda (tmp1510) (if tmp1510 (apply (lambda (_1511 e1512) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1508)) tmp1510) (syntax-violation #f "source expression failed to match any pattern" tmp1509))) ($sc-dispatch tmp1509 (quote (any any))))) x1508)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1513) ((lambda (tmp1514) ((lambda (tmp1515) (if tmp1515 (apply (lambda (_1516 e1517 m11518 m21519) ((lambda (tmp1520) ((lambda (body1521) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1517)) body1521)) tmp1520)) (let f1522 ((clause1523 m11518) (clauses1524 m21519)) (if (null? clauses1524) ((lambda (tmp1526) ((lambda (tmp1527) (if tmp1527 (apply (lambda (e11528 e21529) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11528 e21529))) tmp1527) ((lambda (tmp1531) (if tmp1531 (apply (lambda (k1532 e11533 e21534) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1532)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11533 e21534)))) tmp1531) ((lambda (_1537) (syntax-violation (quote case) "bad clause" x1513 clause1523)) tmp1526))) ($sc-dispatch tmp1526 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1526 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1523) ((lambda (tmp1538) ((lambda (rest1539) ((lambda (tmp1540) ((lambda (tmp1541) (if tmp1541 (apply (lambda (k1542 e11543 e21544) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1542)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11543 e21544)) rest1539)) tmp1541) ((lambda (_1547) (syntax-violation (quote case) "bad clause" x1513 clause1523)) tmp1540))) ($sc-dispatch tmp1540 (quote (each-any any . each-any))))) clause1523)) tmp1538)) (f1522 (car clauses1524) (cdr clauses1524))))))) tmp1515) (syntax-violation #f "source expression failed to match any pattern" tmp1514))) ($sc-dispatch tmp1514 (quote (any any any . each-any))))) x1513)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1548) ((lambda (tmp1549) ((lambda (tmp1550) (if tmp1550 (apply (lambda (_1551 e1552) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1552)) (list (cons _1551 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1552 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1550) (syntax-violation #f "source expression failed to match any pattern" tmp1549))) ($sc-dispatch tmp1549 (quote (any any))))) x1548)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index b573cc8af..56d61e599 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -290,6 +290,7 @@ (let () (define noexpand "noexpand") +(define *mode* (make-fluid)) ;;; hooks to nonportable run-time helpers (begin @@ -300,11 +301,19 @@ (define top-level-eval-hook (lambda (x mod) - (primitive-eval `(,noexpand ,x)))) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x)) + (else x)))))) (define local-eval-hook (lambda (x mod) - (primitive-eval `(,noexpand ,x)))) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x)) + (else x)))))) (define-syntax gensym-hook (syntax-rules () @@ -367,23 +376,45 @@ ((_ source var exp) (build-annotated source `(set! ,var ,exp))))) -(define-syntax build-global-reference - (syntax-rules () - ((_ source var mod) - (build-annotated - source - (if mod - (make-module-ref (cdr mod) var (car mod)) - (make-module-ref mod var 'bare)))))) +;; Before modules are booted, we can't expand into data structures from +;; (ice-9 expand-support) -- we need to give the evaluator the +;; s-expressions that it understands natively. Actually the real truth +;; of the matter is that the evaluator doesn't understand expand-support +;; structures at all. So until we fix the evaluator, if ever, the +;; conflation that we should use expand-support iff we are compiling +;; holds true. +;; +(define build-global-reference + (lambda (source var mod) + (build-annotated + source + (if (not mod) + var + (let ((make-module-ref + (case (fluid-ref *mode*) + ((c) (@ (ice-9 expand-support) make-module-ref)) + (else (lambda (mod var public?) + (list (if public? '@ '@@) mod var))))) + (kind (car mod)) + (mod (cdr mod))) + (case kind + ((public) (make-module-ref mod var #t)) + ((private) (if (not (equal? mod (module-name (current-module)))) + (make-module-ref mod var #f) + var)) + ((bare) var) + ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + (make-module-ref mod var #f) + var)) + (else (syntax-violation #f "bad module kind" var mod)))))))) -(define-syntax build-global-assignment - (syntax-rules () - ((_ source var exp mod) - (build-annotated source - `(set! ,(if mod - (make-module-ref (cdr mod) var (car mod)) - (make-module-ref mod var 'bare)) - ,exp))))) +(define build-global-assignment + (lambda (source var exp mod) + (let ((ref (build-global-reference source var mod))) + (build-annotated + source + `(set! ,ref ,exp))))) (define-syntax build-global-definition (syntax-rules () @@ -1976,18 +2007,17 @@ ;;; expanded, and the expanded definitions are also residualized into ;;; the object file if we are compiling a file. (set! sc-expand - (let ((m 'e) (esew '(eval))) - (lambda (x . rest) - (if (and (pair? x) (equal? (car x) noexpand)) - (cadr x) - (chi-top x - null-env - top-wrap - (if (null? rest) m (car rest)) - (if (or (null? rest) (null? (cdr rest))) - esew - (cadr rest)) - (cons 'hygiene (module-name (current-module)))))))) + (lambda (x . rest) + (if (and (pair? x) (equal? (car x) noexpand)) + (cadr x) + (let ((m (if (null? rest) 'e (car rest))) + (esew (if (or (null? rest) (null? (cdr rest))) + '(eval) + (cadr rest)))) + (with-fluid* *mode* m + (lambda () + (chi-top x null-env top-wrap m esew + (cons 'hygiene (module-name (current-module)))))))))) (set! identifier? (lambda (x) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 5ff16b932..163b4b72d 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,6 +27,7 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) + #:use-module (ice-9 expand-support) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 *translate-table* define-scheme-translator)) @@ -69,7 +70,8 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (let ((x (sc-expand x 'c '(compile load eval)))) + (let ((x (strip-expansion-structures + (sc-expand x 'c '(compile load eval))))) (let ((x (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))) (cenv (make-cenv (current-module) From f4a644ee886903df43810f1a0e65ce2ef891999f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 May 2009 12:18:14 +0200 Subject: [PATCH 093/375] when compiling, use make-lexical to residualize original var names * module/ice-9/psyntax.scm (build-lexical-reference): Change to be a function. Take an extra arg, the original name of the variable. If we are compiling, make a #, annotated with the original var name. All callers changed. (build-lexical-assignment): Also a function, taking also the original var name, using build-lexical-reference to build its output. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 ++++++++++----------- module/ice-9/psyntax.scm | 39 ++++++++++++++++++++++++------------- 2 files changed, 36 insertions(+), 25 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index fa55048f3..8b41c5ebf 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list153 (lambda (vars343) (let lvl344 ((vars345 vars343) (ls346 (quote ())) (w347 (quote (())))) (cond ((pair? vars345) (lvl344 (cdr vars345) (cons (wrap132 (car vars345) w347 #f) ls346) w347)) ((id?104 vars345) (cons (wrap132 vars345 w347 #f) ls346)) ((null? vars345) ls346) ((syntax-object?88 vars345) (lvl344 (syntax-object-expression89 vars345) ls346 (join-wraps123 w347 (syntax-object-wrap90 vars345)))) ((annotation? vars345) (lvl344 (annotation-expression vars345) ls346 w347)) (else (cons vars345 ls346)))))) (gen-var152 (lambda (id348) (let ((id349 (if (syntax-object?88 id348) (syntax-object-expression89 id348) id348))) (if (annotation? id349) (build-annotated79 (annotation-source id349) (gensym (symbol->string (annotation-expression id349)))) (build-annotated79 #f (gensym (symbol->string id349))))))) (strip151 (lambda (x350 w351) (if (memq (quote top) (wrap-marks107 w351)) (if (or (annotation? x350) (and (pair? x350) (annotation? (car x350)))) (strip-annotation150 x350 #f) x350) (let f352 ((x353 x350)) (cond ((syntax-object?88 x353) (strip151 (syntax-object-expression89 x353) (syntax-object-wrap90 x353))) ((pair? x353) (let ((a354 (f352 (car x353))) (d355 (f352 (cdr x353)))) (if (and (eq? a354 (car x353)) (eq? d355 (cdr x353))) x353 (cons a354 d355)))) ((vector? x353) (let ((old356 (vector->list x353))) (let ((new357 (map f352 old356))) (if (and-map*17 eq? old356 new357) x353 (list->vector new357))))) (else x353)))))) (strip-annotation150 (lambda (x358 parent359) (cond ((pair? x358) (let ((new360 (cons #f #f))) (begin (if parent359 (set-annotation-stripped! parent359 new360)) (set-car! new360 (strip-annotation150 (car x358) #f)) (set-cdr! new360 (strip-annotation150 (cdr x358) #f)) new360))) ((annotation? x358) (or (annotation-stripped x358) (strip-annotation150 (annotation-expression x358) x358))) ((vector? x358) (let ((new361 (make-vector (vector-length x358)))) (begin (if parent359 (set-annotation-stripped! parent359 new361)) (let loop362 ((i363 (- (vector-length x358) 1))) (unless (fx<74 i363 0) (vector-set! new361 i363 (strip-annotation150 (vector-ref x358 i363) #f)) (loop362 (fx-72 i363 1)))) new361))) (else x358)))) (ellipsis?149 (lambda (x364) (and (nonsymbol-id?103 x364) (free-id=?127 x364 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void148 (lambda () (build-annotated79 #f (cons (build-annotated79 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer147 (lambda (expanded365 mod366) (let ((p367 (local-eval-hook76 expanded365 mod366))) (if (procedure? p367) p367 (syntax-violation #f "nonprocedure transformer" p367))))) (chi-local-syntax146 (lambda (rec?368 e369 r370 w371 s372 mod373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (_377 id378 val379 e1380 e2381) (let ((ids382 id378)) (if (not (valid-bound-ids?129 ids382)) (syntax-violation #f "duplicate bound keyword" e369) (let ((labels384 (gen-labels110 ids382))) (let ((new-w385 (make-binding-wrap121 ids382 labels384 w371))) (k374 (cons e1380 e2381) (extend-env98 labels384 (let ((w387 (if rec?368 new-w385 w371)) (trans-r388 (macros-only-env100 r370))) (map (lambda (x389) (cons (quote macro) (eval-local-transformer147 (chi140 x389 trans-r388 w387 mod373) mod373))) val379)) r370) new-w385 s372 mod373)))))) tmp376) ((lambda (_391) (syntax-violation #f "bad local syntax definition" (source-wrap133 e369 w371 s372 mod373))) tmp375))) ($sc-dispatch tmp375 (quote (any #(each (any any)) any . each-any))))) e369))) (chi-lambda-clause145 (lambda (e392 docstring393 c394 r395 w396 mod397 k398) ((lambda (tmp399) ((lambda (tmp400) (if (if tmp400 (apply (lambda (args401 doc402 e1403 e2404) (and (string? (syntax->datum doc402)) (not docstring393))) tmp400) #f) (apply (lambda (args405 doc406 e1407 e2408) (chi-lambda-clause145 e392 doc406 (cons args405 (cons e1407 e2408)) r395 w396 mod397 k398)) tmp400) ((lambda (tmp410) (if tmp410 (apply (lambda (id411 e1412 e2413) (let ((ids414 id411)) (if (not (valid-bound-ids?129 ids414)) (syntax-violation (quote lambda) "invalid parameter list" e392) (let ((labels416 (gen-labels110 ids414)) (new-vars417 (map gen-var152 ids414))) (k398 new-vars417 docstring393 (chi-body144 (cons e1412 e2413) e392 (extend-var-env99 labels416 new-vars417 r395) (make-binding-wrap121 ids414 labels416 w396) mod397)))))) tmp410) ((lambda (tmp419) (if tmp419 (apply (lambda (ids420 e1421 e2422) (let ((old-ids423 (lambda-var-list153 ids420))) (if (not (valid-bound-ids?129 old-ids423)) (syntax-violation (quote lambda) "invalid parameter list" e392) (let ((labels424 (gen-labels110 old-ids423)) (new-vars425 (map gen-var152 old-ids423))) (k398 (let f426 ((ls1427 (cdr new-vars425)) (ls2428 (car new-vars425))) (if (null? ls1427) ls2428 (f426 (cdr ls1427) (cons (car ls1427) ls2428)))) docstring393 (chi-body144 (cons e1421 e2422) e392 (extend-var-env99 labels424 new-vars425 r395) (make-binding-wrap121 old-ids423 labels424 w396) mod397)))))) tmp419) ((lambda (_430) (syntax-violation (quote lambda) "bad lambda" e392)) tmp399))) ($sc-dispatch tmp399 (quote (any any . each-any)))))) ($sc-dispatch tmp399 (quote (each-any any . each-any)))))) ($sc-dispatch tmp399 (quote (any any any . each-any))))) c394))) (chi-body144 (lambda (body431 outer-form432 r433 w434 mod435) (let ((r436 (cons (quote ("placeholder" placeholder)) r433))) (let ((ribcage437 (make-ribcage111 (quote ()) (quote ()) (quote ())))) (let ((w438 (make-wrap106 (wrap-marks107 w434) (cons ribcage437 (wrap-subst108 w434))))) (let parse439 ((body440 (map (lambda (x446) (cons r436 (wrap132 x446 w438 mod435))) body431)) (ids441 (quote ())) (labels442 (quote ())) (vars443 (quote ())) (vals444 (quote ())) (bindings445 (quote ()))) (if (null? body440) (syntax-violation #f "no expressions in body" outer-form432) (let ((e447 (cdar body440)) (er448 (caar body440))) (call-with-values (lambda () (syntax-type138 e447 er448 (quote (())) #f ribcage437 mod435)) (lambda (type449 value450 e451 w452 s453 mod454) (let ((t455 type449)) (if (memv t455 (quote (define-form))) (let ((id456 (wrap132 value450 w452 mod454)) (label457 (gen-label109))) (let ((var458 (gen-var152 id456))) (begin (extend-ribcage!120 ribcage437 id456 label457) (parse439 (cdr body440) (cons id456 ids441) (cons label457 labels442) (cons var458 vars443) (cons (cons er448 (wrap132 e451 w452 mod454)) vals444) (cons (cons (quote lexical) var458) bindings445))))) (if (memv t455 (quote (define-syntax-form))) (let ((id459 (wrap132 value450 w452 mod454)) (label460 (gen-label109))) (begin (extend-ribcage!120 ribcage437 id459 label460) (parse439 (cdr body440) (cons id459 ids441) (cons label460 labels442) vars443 vals444 (cons (cons (quote macro) (cons er448 (wrap132 e451 w452 mod454))) bindings445)))) (if (memv t455 (quote (begin-form))) ((lambda (tmp461) ((lambda (tmp462) (if tmp462 (apply (lambda (_463 e1464) (parse439 (let f465 ((forms466 e1464)) (if (null? forms466) (cdr body440) (cons (cons er448 (wrap132 (car forms466) w452 mod454)) (f465 (cdr forms466))))) ids441 labels442 vars443 vals444 bindings445)) tmp462) (syntax-violation #f "source expression failed to match any pattern" tmp461))) ($sc-dispatch tmp461 (quote (any . each-any))))) e451) (if (memv t455 (quote (local-syntax-form))) (chi-local-syntax146 value450 e451 er448 w452 s453 mod454 (lambda (forms468 er469 w470 s471 mod472) (parse439 (let f473 ((forms474 forms468)) (if (null? forms474) (cdr body440) (cons (cons er469 (wrap132 (car forms474) w470 mod472)) (f473 (cdr forms474))))) ids441 labels442 vars443 vals444 bindings445))) (if (null? ids441) (build-sequence83 #f (map (lambda (x475) (chi140 (cdr x475) (car x475) (quote (())) mod454)) (cons (cons er448 (source-wrap133 e451 w452 s453 mod454)) (cdr body440)))) (begin (if (not (valid-bound-ids?129 ids441)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form432)) (let loop476 ((bs477 bindings445) (er-cache478 #f) (r-cache479 #f)) (if (not (null? bs477)) (let ((b480 (car bs477))) (if (eq? (car b480) (quote macro)) (let ((er481 (cadr b480))) (let ((r-cache482 (if (eq? er481 er-cache478) r-cache479 (macros-only-env100 er481)))) (begin (set-cdr! b480 (eval-local-transformer147 (chi140 (cddr b480) r-cache482 (quote (())) mod454) mod454)) (loop476 (cdr bs477) er481 r-cache482)))) (loop476 (cdr bs477) er-cache478 r-cache479))))) (set-cdr! r436 (extend-env98 labels442 bindings445 (cdr r436))) (build-letrec86 #f vars443 (map (lambda (x483) (chi140 (cdr x483) (car x483) (quote (())) mod454)) vals444) (build-sequence83 #f (map (lambda (x484) (chi140 (cdr x484) (car x484) (quote (())) mod454)) (cons (cons er448 (source-wrap133 e451 w452 s453 mod454)) (cdr body440)))))))))))))))))))))) (chi-macro143 (lambda (p485 e486 r487 w488 rib489 mod490) (letrec ((rebuild-macro-output491 (lambda (x492 m493) (cond ((pair? x492) (cons (rebuild-macro-output491 (car x492) m493) (rebuild-macro-output491 (cdr x492) m493))) ((syntax-object?88 x492) (let ((w494 (syntax-object-wrap90 x492))) (let ((ms495 (wrap-marks107 w494)) (s496 (wrap-subst108 w494))) (if (and (pair? ms495) (eq? (car ms495) #f)) (make-syntax-object87 (syntax-object-expression89 x492) (make-wrap106 (cdr ms495) (if rib489 (cons rib489 (cdr s496)) (cdr s496))) (syntax-object-module91 x492)) (make-syntax-object87 (syntax-object-expression89 x492) (make-wrap106 (cons m493 ms495) (if rib489 (cons rib489 (cons (quote shift) s496)) (cons (quote shift) s496))) (let ((pmod497 (procedure-module p485))) (if pmod497 (cons (quote hygiene) (module-name pmod497)) (quote (hygiene guile))))))))) ((vector? x492) (let ((n498 (vector-length x492))) (let ((v499 (make-vector n498))) (let doloop500 ((i501 0)) (if (fx=73 i501 n498) v499 (begin (vector-set! v499 i501 (rebuild-macro-output491 (vector-ref x492 i501) m493)) (doloop500 (fx+71 i501 1)))))))) ((symbol? x492) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap133 e486 w488 s mod490) x492)) (else x492))))) (rebuild-macro-output491 (p485 (wrap132 e486 (anti-mark119 w488) mod490)) (string #\m))))) (chi-application142 (lambda (x502 e503 r504 w505 s506 mod507) ((lambda (tmp508) ((lambda (tmp509) (if tmp509 (apply (lambda (e0510 e1511) (build-annotated79 s506 (cons x502 (map (lambda (e512) (chi140 e512 r504 w505 mod507)) e1511)))) tmp509) (syntax-violation #f "source expression failed to match any pattern" tmp508))) ($sc-dispatch tmp508 (quote (any . each-any))))) e503))) (chi-expr141 (lambda (type514 value515 e516 r517 w518 s519 mod520) (let ((t521 type514)) (if (memv t521 (quote (lexical))) (build-annotated79 s519 value515) (if (memv t521 (quote (core external-macro))) (value515 e516 r517 w518 s519 mod520) (if (memv t521 (quote (module-ref))) (call-with-values (lambda () (value515 e516)) (lambda (id522 mod523) (build-global-reference80 s519 id522 mod523))) (if (memv t521 (quote (lexical-call))) (chi-application142 (build-annotated79 (source-annotation95 (car e516)) value515) e516 r517 w518 s519 mod520) (if (memv t521 (quote (global-call))) (chi-application142 (build-global-reference80 (source-annotation95 (car e516)) value515 (if (syntax-object?88 (car e516)) (syntax-object-module91 (car e516)) mod520)) e516 r517 w518 s519 mod520) (if (memv t521 (quote (constant))) (build-data82 s519 (strip151 (source-wrap133 e516 w518 s519 mod520) (quote (())))) (if (memv t521 (quote (global))) (build-global-reference80 s519 value515 mod520) (if (memv t521 (quote (call))) (chi-application142 (chi140 (car e516) r517 w518 mod520) e516 r517 w518 s519 mod520) (if (memv t521 (quote (begin-form))) ((lambda (tmp524) ((lambda (tmp525) (if tmp525 (apply (lambda (_526 e1527 e2528) (chi-sequence134 (cons e1527 e2528) r517 w518 s519 mod520)) tmp525) (syntax-violation #f "source expression failed to match any pattern" tmp524))) ($sc-dispatch tmp524 (quote (any any . each-any))))) e516) (if (memv t521 (quote (local-syntax-form))) (chi-local-syntax146 value515 e516 r517 w518 s519 mod520 chi-sequence134) (if (memv t521 (quote (eval-when-form))) ((lambda (tmp530) ((lambda (tmp531) (if tmp531 (apply (lambda (_532 x533 e1534 e2535) (let ((when-list536 (chi-when-list137 e516 x533 w518))) (if (memq (quote eval) when-list536) (chi-sequence134 (cons e1534 e2535) r517 w518 s519 mod520) (chi-void148)))) tmp531) (syntax-violation #f "source expression failed to match any pattern" tmp530))) ($sc-dispatch tmp530 (quote (any each-any any . each-any))))) e516) (if (memv t521 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e516 (wrap132 value515 w518 mod520)) (if (memv t521 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap133 e516 w518 s519 mod520)) (if (memv t521 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap133 e516 w518 s519 mod520)) (syntax-violation #f "unexpected syntax" (source-wrap133 e516 w518 s519 mod520))))))))))))))))))) (chi140 (lambda (e539 r540 w541 mod542) (call-with-values (lambda () (syntax-type138 e539 r540 w541 #f #f mod542)) (lambda (type543 value544 e545 w546 s547 mod548) (chi-expr141 type543 value544 e545 r540 w546 s547 mod548))))) (chi-top139 (lambda (e549 r550 w551 m552 esew553 mod554) (call-with-values (lambda () (syntax-type138 e549 r550 w551 #f #f mod554)) (lambda (type562 value563 e564 w565 s566 mod567) (let ((t568 type562)) (if (memv t568 (quote (begin-form))) ((lambda (tmp569) ((lambda (tmp570) (if tmp570 (apply (lambda (_571) (chi-void148)) tmp570) ((lambda (tmp572) (if tmp572 (apply (lambda (_573 e1574 e2575) (chi-top-sequence135 (cons e1574 e2575) r550 w565 s566 m552 esew553 mod567)) tmp572) (syntax-violation #f "source expression failed to match any pattern" tmp569))) ($sc-dispatch tmp569 (quote (any any . each-any)))))) ($sc-dispatch tmp569 (quote (any))))) e564) (if (memv t568 (quote (local-syntax-form))) (chi-local-syntax146 value563 e564 r550 w565 s566 mod567 (lambda (body577 r578 w579 s580 mod581) (chi-top-sequence135 body577 r578 w579 s580 m552 esew553 mod581))) (if (memv t568 (quote (eval-when-form))) ((lambda (tmp582) ((lambda (tmp583) (if tmp583 (apply (lambda (_584 x585 e1586 e2587) (let ((when-list588 (chi-when-list137 e564 x585 w565)) (body589 (cons e1586 e2587))) (cond ((eq? m552 (quote e)) (if (memq (quote eval) when-list588) (chi-top-sequence135 body589 r550 w565 s566 (quote e) (quote (eval)) mod567) (chi-void148))) ((memq (quote load) when-list588) (if (or (memq (quote compile) when-list588) (and (eq? m552 (quote c&e)) (memq (quote eval) when-list588))) (chi-top-sequence135 body589 r550 w565 s566 (quote c&e) (quote (compile load)) mod567) (if (memq m552 (quote (c c&e))) (chi-top-sequence135 body589 r550 w565 s566 (quote c) (quote (load)) mod567) (chi-void148)))) ((or (memq (quote compile) when-list588) (and (eq? m552 (quote c&e)) (memq (quote eval) when-list588))) (top-level-eval-hook75 (chi-top-sequence135 body589 r550 w565 s566 (quote e) (quote (eval)) mod567) mod567) (chi-void148)) (else (chi-void148))))) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp582))) ($sc-dispatch tmp582 (quote (any each-any any . each-any))))) e564) (if (memv t568 (quote (define-syntax-form))) (let ((n592 (id-var-name126 value563 w565)) (r593 (macros-only-env100 r550))) (let ((t594 m552)) (if (memv t594 (quote (c))) (if (memq (quote compile) esew553) (let ((e595 (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)))) (begin (top-level-eval-hook75 e595 mod567) (if (memq (quote load) esew553) e595 (chi-void148)))) (if (memq (quote load) esew553) (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)) (chi-void148))) (if (memv t594 (quote (c&e))) (let ((e596 (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)))) (begin (top-level-eval-hook75 e596 mod567) e596)) (begin (if (memq (quote eval) esew553) (top-level-eval-hook75 (chi-install-global136 n592 (chi140 e564 r593 w565 mod567)) mod567)) (chi-void148)))))) (if (memv t568 (quote (define-form))) (let ((n597 (id-var-name126 value563 w565))) (let ((type598 (binding-type96 (lookup101 n597 r550 mod567)))) (let ((t599 type598)) (if (memv t599 (quote (global core macro module-ref))) (let ((x600 (build-annotated79 s566 (list (quote define) n597 (chi140 e564 r550 w565 mod567))))) (begin (if (eq? m552 (quote c&e)) (top-level-eval-hook75 x600 mod567)) x600)) (if (memv t599 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e564 (wrap132 value563 w565 mod567)) (syntax-violation #f "cannot define keyword at top level" e564 (wrap132 value563 w565 mod567))))))) (let ((x601 (chi-expr141 type562 value563 e564 r550 w565 s566 mod567))) (begin (if (eq? m552 (quote c&e)) (top-level-eval-hook75 x601 mod567)) x601)))))))))))) (syntax-type138 (lambda (e602 r603 w604 s605 rib606 mod607) (cond ((symbol? e602) (let ((n608 (id-var-name126 e602 w604))) (let ((b609 (lookup101 n608 r603 mod607))) (let ((type610 (binding-type96 b609))) (let ((t611 type610)) (if (memv t611 (quote (lexical))) (values type610 (binding-value97 b609) e602 w604 s605 mod607) (if (memv t611 (quote (global))) (values type610 n608 e602 w604 s605 mod607) (if (memv t611 (quote (macro))) (syntax-type138 (chi-macro143 (binding-value97 b609) e602 r603 w604 rib606 mod607) r603 (quote (())) s605 rib606 mod607) (values type610 (binding-value97 b609) e602 w604 s605 mod607))))))))) ((pair? e602) (let ((first612 (car e602))) (if (id?104 first612) (let ((n613 (id-var-name126 first612 w604))) (let ((b614 (lookup101 n613 r603 (or (and (syntax-object?88 first612) (syntax-object-module91 first612)) mod607)))) (let ((type615 (binding-type96 b614))) (let ((t616 type615)) (if (memv t616 (quote (lexical))) (values (quote lexical-call) (binding-value97 b614) e602 w604 s605 mod607) (if (memv t616 (quote (global))) (values (quote global-call) n613 e602 w604 s605 mod607) (if (memv t616 (quote (macro))) (syntax-type138 (chi-macro143 (binding-value97 b614) e602 r603 w604 rib606 mod607) r603 (quote (())) s605 rib606 mod607) (if (memv t616 (quote (core external-macro module-ref))) (values type615 (binding-value97 b614) e602 w604 s605 mod607) (if (memv t616 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value97 b614) e602 w604 s605 mod607) (if (memv t616 (quote (begin))) (values (quote begin-form) #f e602 w604 s605 mod607) (if (memv t616 (quote (eval-when))) (values (quote eval-when-form) #f e602 w604 s605 mod607) (if (memv t616 (quote (define))) ((lambda (tmp617) ((lambda (tmp618) (if (if tmp618 (apply (lambda (_619 name620 val621) (id?104 name620)) tmp618) #f) (apply (lambda (_622 name623 val624) (values (quote define-form) name623 val624 w604 s605 mod607)) tmp618) ((lambda (tmp625) (if (if tmp625 (apply (lambda (_626 name627 args628 e1629 e2630) (and (id?104 name627) (valid-bound-ids?129 (lambda-var-list153 args628)))) tmp625) #f) (apply (lambda (_631 name632 args633 e1634 e2635) (values (quote define-form) (wrap132 name632 w604 mod607) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap132 (cons args633 (cons e1634 e2635)) w604 mod607)) (quote (())) s605 mod607)) tmp625) ((lambda (tmp637) (if (if tmp637 (apply (lambda (_638 name639) (id?104 name639)) tmp637) #f) (apply (lambda (_640 name641) (values (quote define-form) (wrap132 name641 w604 mod607) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s605 mod607)) tmp637) (syntax-violation #f "source expression failed to match any pattern" tmp617))) ($sc-dispatch tmp617 (quote (any any)))))) ($sc-dispatch tmp617 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp617 (quote (any any any))))) e602) (if (memv t616 (quote (define-syntax))) ((lambda (tmp642) ((lambda (tmp643) (if (if tmp643 (apply (lambda (_644 name645 val646) (id?104 name645)) tmp643) #f) (apply (lambda (_647 name648 val649) (values (quote define-syntax-form) name648 val649 w604 s605 mod607)) tmp643) (syntax-violation #f "source expression failed to match any pattern" tmp642))) ($sc-dispatch tmp642 (quote (any any any))))) e602) (values (quote call) #f e602 w604 s605 mod607)))))))))))))) (values (quote call) #f e602 w604 s605 mod607)))) ((syntax-object?88 e602) (syntax-type138 (syntax-object-expression89 e602) r603 (join-wraps123 w604 (syntax-object-wrap90 e602)) #f rib606 (or (syntax-object-module91 e602) mod607))) ((annotation? e602) (syntax-type138 (annotation-expression e602) r603 w604 (annotation-source e602) rib606 mod607)) ((self-evaluating? e602) (values (quote constant) #f e602 w604 s605 mod607)) (else (values (quote other) #f e602 w604 s605 mod607))))) (chi-when-list137 (lambda (e650 when-list651 w652) (let f653 ((when-list654 when-list651) (situations655 (quote ()))) (if (null? when-list654) situations655 (f653 (cdr when-list654) (cons (let ((x656 (car when-list654))) (cond ((free-id=?127 x656 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?127 x656 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?127 x656 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e650 (wrap132 x656 w652 #f))))) situations655)))))) (chi-install-global136 (lambda (name657 e658) (build-annotated79 #f (list (build-annotated79 #f (quote define)) name657 (if (let ((v659 (module-variable (current-module) name657))) (and v659 (variable-bound? v659) (macro? (variable-ref v659)) (not (eq? (macro-type (variable-ref v659)) (quote syncase-macro))))) (build-annotated79 #f (list (build-annotated79 #f (quote make-extended-syncase-macro)) (build-annotated79 #f (list (build-annotated79 #f (quote module-ref)) (build-annotated79 #f (quote (current-module))) (build-data82 #f name657))) (build-data82 #f (quote macro)) e658)) (build-annotated79 #f (list (build-annotated79 #f (quote make-syncase-macro)) (build-data82 #f (quote macro)) e658))))))) (chi-top-sequence135 (lambda (body660 r661 w662 s663 m664 esew665 mod666) (build-sequence83 s663 (let dobody667 ((body668 body660) (r669 r661) (w670 w662) (m671 m664) (esew672 esew665) (mod673 mod666)) (if (null? body668) (quote ()) (let ((first674 (chi-top139 (car body668) r669 w670 m671 esew672 mod673))) (cons first674 (dobody667 (cdr body668) r669 w670 m671 esew672 mod673)))))))) (chi-sequence134 (lambda (body675 r676 w677 s678 mod679) (build-sequence83 s678 (let dobody680 ((body681 body675) (r682 r676) (w683 w677) (mod684 mod679)) (if (null? body681) (quote ()) (let ((first685 (chi140 (car body681) r682 w683 mod684))) (cons first685 (dobody680 (cdr body681) r682 w683 mod684)))))))) (source-wrap133 (lambda (x686 w687 s688 defmod689) (wrap132 (if s688 (make-annotation x686 s688 #f) x686) w687 defmod689))) (wrap132 (lambda (x690 w691 defmod692) (cond ((and (null? (wrap-marks107 w691)) (null? (wrap-subst108 w691))) x690) ((syntax-object?88 x690) (make-syntax-object87 (syntax-object-expression89 x690) (join-wraps123 w691 (syntax-object-wrap90 x690)) (syntax-object-module91 x690))) ((null? x690) x690) (else (make-syntax-object87 x690 w691 defmod692))))) (bound-id-member?131 (lambda (x693 list694) (and (not (null? list694)) (or (bound-id=?128 x693 (car list694)) (bound-id-member?131 x693 (cdr list694)))))) (distinct-bound-ids?130 (lambda (ids695) (let distinct?696 ((ids697 ids695)) (or (null? ids697) (and (not (bound-id-member?131 (car ids697) (cdr ids697))) (distinct?696 (cdr ids697))))))) (valid-bound-ids?129 (lambda (ids698) (and (let all-ids?699 ((ids700 ids698)) (or (null? ids700) (and (id?104 (car ids700)) (all-ids?699 (cdr ids700))))) (distinct-bound-ids?130 ids698)))) (bound-id=?128 (lambda (i701 j702) (if (and (syntax-object?88 i701) (syntax-object?88 j702)) (and (eq? (let ((e703 (syntax-object-expression89 i701))) (if (annotation? e703) (annotation-expression e703) e703)) (let ((e704 (syntax-object-expression89 j702))) (if (annotation? e704) (annotation-expression e704) e704))) (same-marks?125 (wrap-marks107 (syntax-object-wrap90 i701)) (wrap-marks107 (syntax-object-wrap90 j702)))) (eq? (let ((e705 i701)) (if (annotation? e705) (annotation-expression e705) e705)) (let ((e706 j702)) (if (annotation? e706) (annotation-expression e706) e706)))))) (free-id=?127 (lambda (i707 j708) (and (eq? (let ((x709 i707)) (let ((e710 (if (syntax-object?88 x709) (syntax-object-expression89 x709) x709))) (if (annotation? e710) (annotation-expression e710) e710))) (let ((x711 j708)) (let ((e712 (if (syntax-object?88 x711) (syntax-object-expression89 x711) x711))) (if (annotation? e712) (annotation-expression e712) e712)))) (eq? (id-var-name126 i707 (quote (()))) (id-var-name126 j708 (quote (()))))))) (id-var-name126 (lambda (id713 w714) (letrec ((search-vector-rib717 (lambda (sym723 subst724 marks725 symnames726 ribcage727) (let ((n728 (vector-length symnames726))) (let f729 ((i730 0)) (cond ((fx=73 i730 n728) (search715 sym723 (cdr subst724) marks725)) ((and (eq? (vector-ref symnames726 i730) sym723) (same-marks?125 marks725 (vector-ref (ribcage-marks114 ribcage727) i730))) (values (vector-ref (ribcage-labels115 ribcage727) i730) marks725)) (else (f729 (fx+71 i730 1)))))))) (search-list-rib716 (lambda (sym731 subst732 marks733 symnames734 ribcage735) (let f736 ((symnames737 symnames734) (i738 0)) (cond ((null? symnames737) (search715 sym731 (cdr subst732) marks733)) ((and (eq? (car symnames737) sym731) (same-marks?125 marks733 (list-ref (ribcage-marks114 ribcage735) i738))) (values (list-ref (ribcage-labels115 ribcage735) i738) marks733)) (else (f736 (cdr symnames737) (fx+71 i738 1))))))) (search715 (lambda (sym739 subst740 marks741) (if (null? subst740) (values #f marks741) (let ((fst742 (car subst740))) (if (eq? fst742 (quote shift)) (search715 sym739 (cdr subst740) (cdr marks741)) (let ((symnames743 (ribcage-symnames113 fst742))) (if (vector? symnames743) (search-vector-rib717 sym739 subst740 marks741 symnames743 fst742) (search-list-rib716 sym739 subst740 marks741 symnames743 fst742))))))))) (cond ((symbol? id713) (or (call-with-values (lambda () (search715 id713 (wrap-subst108 w714) (wrap-marks107 w714))) (lambda (x745 . ignore744) x745)) id713)) ((syntax-object?88 id713) (let ((id746 (let ((e748 (syntax-object-expression89 id713))) (if (annotation? e748) (annotation-expression e748) e748))) (w1747 (syntax-object-wrap90 id713))) (let ((marks749 (join-marks124 (wrap-marks107 w714) (wrap-marks107 w1747)))) (call-with-values (lambda () (search715 id746 (wrap-subst108 w714) marks749)) (lambda (new-id750 marks751) (or new-id750 (call-with-values (lambda () (search715 id746 (wrap-subst108 w1747) marks751)) (lambda (x753 . ignore752) x753)) id746)))))) ((annotation? id713) (let ((id754 (let ((e755 id713)) (if (annotation? e755) (annotation-expression e755) e755)))) (or (call-with-values (lambda () (search715 id754 (wrap-subst108 w714) (wrap-marks107 w714))) (lambda (x757 . ignore756) x757)) id754))) (else (syntax-violation (quote id-var-name) "invalid id" id713)))))) (same-marks?125 (lambda (x758 y759) (or (eq? x758 y759) (and (not (null? x758)) (not (null? y759)) (eq? (car x758) (car y759)) (same-marks?125 (cdr x758) (cdr y759)))))) (join-marks124 (lambda (m1760 m2761) (smart-append122 m1760 m2761))) (join-wraps123 (lambda (w1762 w2763) (let ((m1764 (wrap-marks107 w1762)) (s1765 (wrap-subst108 w1762))) (if (null? m1764) (if (null? s1765) w2763 (make-wrap106 (wrap-marks107 w2763) (smart-append122 s1765 (wrap-subst108 w2763)))) (make-wrap106 (smart-append122 m1764 (wrap-marks107 w2763)) (smart-append122 s1765 (wrap-subst108 w2763))))))) (smart-append122 (lambda (m1766 m2767) (if (null? m2767) m1766 (append m1766 m2767)))) (make-binding-wrap121 (lambda (ids768 labels769 w770) (if (null? ids768) w770 (make-wrap106 (wrap-marks107 w770) (cons (let ((labelvec771 (list->vector labels769))) (let ((n772 (vector-length labelvec771))) (let ((symnamevec773 (make-vector n772)) (marksvec774 (make-vector n772))) (begin (let f775 ((ids776 ids768) (i777 0)) (if (not (null? ids776)) (call-with-values (lambda () (id-sym-name&marks105 (car ids776) w770)) (lambda (symname778 marks779) (begin (vector-set! symnamevec773 i777 symname778) (vector-set! marksvec774 i777 marks779) (f775 (cdr ids776) (fx+71 i777 1))))))) (make-ribcage111 symnamevec773 marksvec774 labelvec771))))) (wrap-subst108 w770)))))) (extend-ribcage!120 (lambda (ribcage780 id781 label782) (begin (set-ribcage-symnames!116 ribcage780 (cons (let ((e783 (syntax-object-expression89 id781))) (if (annotation? e783) (annotation-expression e783) e783)) (ribcage-symnames113 ribcage780))) (set-ribcage-marks!117 ribcage780 (cons (wrap-marks107 (syntax-object-wrap90 id781)) (ribcage-marks114 ribcage780))) (set-ribcage-labels!118 ribcage780 (cons label782 (ribcage-labels115 ribcage780)))))) (anti-mark119 (lambda (w784) (make-wrap106 (cons #f (wrap-marks107 w784)) (cons (quote shift) (wrap-subst108 w784))))) (set-ribcage-labels!118 (lambda (x785 update786) (vector-set! x785 3 update786))) (set-ribcage-marks!117 (lambda (x787 update788) (vector-set! x787 2 update788))) (set-ribcage-symnames!116 (lambda (x789 update790) (vector-set! x789 1 update790))) (ribcage-labels115 (lambda (x791) (vector-ref x791 3))) (ribcage-marks114 (lambda (x792) (vector-ref x792 2))) (ribcage-symnames113 (lambda (x793) (vector-ref x793 1))) (ribcage?112 (lambda (x794) (and (vector? x794) (= (vector-length x794) 4) (eq? (vector-ref x794 0) (quote ribcage))))) (make-ribcage111 (lambda (symnames795 marks796 labels797) (vector (quote ribcage) symnames795 marks796 labels797))) (gen-labels110 (lambda (ls798) (if (null? ls798) (quote ()) (cons (gen-label109) (gen-labels110 (cdr ls798)))))) (gen-label109 (lambda () (string #\i))) (wrap-subst108 cdr) (wrap-marks107 car) (make-wrap106 cons) (id-sym-name&marks105 (lambda (x799 w800) (if (syntax-object?88 x799) (values (let ((e801 (syntax-object-expression89 x799))) (if (annotation? e801) (annotation-expression e801) e801)) (join-marks124 (wrap-marks107 w800) (wrap-marks107 (syntax-object-wrap90 x799)))) (values (let ((e802 x799)) (if (annotation? e802) (annotation-expression e802) e802)) (wrap-marks107 w800))))) (id?104 (lambda (x803) (cond ((symbol? x803) #t) ((syntax-object?88 x803) (symbol? (let ((e804 (syntax-object-expression89 x803))) (if (annotation? e804) (annotation-expression e804) e804)))) ((annotation? x803) (symbol? (annotation-expression x803))) (else #f)))) (nonsymbol-id?103 (lambda (x805) (and (syntax-object?88 x805) (symbol? (let ((e806 (syntax-object-expression89 x805))) (if (annotation? e806) (annotation-expression e806) e806)))))) (global-extend102 (lambda (type807 sym808 val809) (put-global-definition-hook77 sym808 type807 val809))) (lookup101 (lambda (x810 r811 mod812) (cond ((assq x810 r811) => cdr) ((symbol? x810) (or (get-global-definition-hook78 x810 mod812) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env100 (lambda (r813) (if (null? r813) (quote ()) (let ((a814 (car r813))) (if (eq? (cadr a814) (quote macro)) (cons a814 (macros-only-env100 (cdr r813))) (macros-only-env100 (cdr r813))))))) (extend-var-env99 (lambda (labels815 vars816 r817) (if (null? labels815) r817 (extend-var-env99 (cdr labels815) (cdr vars816) (cons (cons (car labels815) (cons (quote lexical) (car vars816))) r817))))) (extend-env98 (lambda (labels818 bindings819 r820) (if (null? labels818) r820 (extend-env98 (cdr labels818) (cdr bindings819) (cons (cons (car labels818) (car bindings819)) r820))))) (binding-value97 cdr) (binding-type96 car) (source-annotation95 (lambda (x821) (cond ((annotation? x821) (annotation-source x821)) ((syntax-object?88 x821) (source-annotation95 (syntax-object-expression89 x821))) (else #f)))) (set-syntax-object-module!94 (lambda (x822 update823) (vector-set! x822 3 update823))) (set-syntax-object-wrap!93 (lambda (x824 update825) (vector-set! x824 2 update825))) (set-syntax-object-expression!92 (lambda (x826 update827) (vector-set! x826 1 update827))) (syntax-object-module91 (lambda (x828) (vector-ref x828 3))) (syntax-object-wrap90 (lambda (x829) (vector-ref x829 2))) (syntax-object-expression89 (lambda (x830) (vector-ref x830 1))) (syntax-object?88 (lambda (x831) (and (vector? x831) (= (vector-length x831) 4) (eq? (vector-ref x831 0) (quote syntax-object))))) (make-syntax-object87 (lambda (expression832 wrap833 module834) (vector (quote syntax-object) expression832 wrap833 module834))) (build-letrec86 (lambda (src835 vars836 val-exps837 body-exp838) (if (null? vars836) (build-annotated79 src835 body-exp838) (build-annotated79 src835 (list (quote letrec) (map list vars836 val-exps837) body-exp838))))) (build-named-let85 (lambda (src839 vars840 val-exps841 body-exp842) (if (null? vars840) (build-annotated79 src839 body-exp842) (build-annotated79 src839 (list (quote let) (car vars840) (map list (cdr vars840) val-exps841) body-exp842))))) (build-let84 (lambda (src843 vars844 val-exps845 body-exp846) (if (null? vars844) (build-annotated79 src843 body-exp846) (build-annotated79 src843 (list (quote let) (map list vars844 val-exps845) body-exp846))))) (build-sequence83 (lambda (src847 exps848) (if (null? (cdr exps848)) (build-annotated79 src847 (car exps848)) (build-annotated79 src847 (cons (quote begin) exps848))))) (build-data82 (lambda (src849 exp850) (if (and (self-evaluating? exp850) (not (vector? exp850))) (build-annotated79 src849 exp850) (build-annotated79 src849 (list (quote quote) exp850))))) (build-global-assignment81 (lambda (source851 var852 exp853 mod854) (let ((ref855 (build-global-reference80 source851 var852 mod854))) (build-annotated79 source851 (list (quote set!) ref855 exp853))))) (build-global-reference80 (lambda (source856 var857 mod858) (build-annotated79 source856 (if (not mod858) var857 (let ((make-module-ref859 (let ((t862 (fluid-ref *mode*70))) (if (memv t862 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (mod863 var864 public?865) (list (if public?865 (quote @) (quote @@)) mod863 var864))))) (kind860 (car mod858)) (mod861 (cdr mod858))) (let ((t866 kind860)) (if (memv t866 (quote (public))) (make-module-ref859 mod861 var857 #t) (if (memv t866 (quote (private))) (if (not (equal? mod861 (module-name (current-module)))) (make-module-ref859 mod861 var857 #f) var857) (if (memv t866 (quote (bare))) var857 (if (memv t866 (quote (hygiene))) (if (and (not (equal? mod861 (module-name (current-module)))) (module-variable (resolve-module mod861) var857)) (make-module-ref859 mod861 var857 #f) var857) (syntax-violation #f "bad module kind" var857 mod861))))))))))) (build-annotated79 (lambda (src867 exp868) (if (and src867 (not (annotation? exp868))) (make-annotation exp868 src867 #t) exp868))) (get-global-definition-hook78 (lambda (symbol869 module870) (begin (if (and (not module870) (current-module)) (warn "module system is booted, we should have a module" symbol869)) (let ((v871 (module-variable (if module870 (resolve-module (cdr module870)) (current-module)) symbol869))) (and v871 (variable-bound? v871) (let ((val872 (variable-ref v871))) (and (macro? val872) (syncase-macro-type val872) (cons (syncase-macro-type val872) (syncase-macro-binding val872))))))))) (put-global-definition-hook77 (lambda (symbol873 type874 val875) (let ((existing876 (let ((v877 (module-variable (current-module) symbol873))) (and v877 (variable-bound? v877) (let ((val878 (variable-ref v877))) (and (macro? val878) (not (syncase-macro-type val878)) val878)))))) (module-define! (current-module) symbol873 (if existing876 (make-extended-syncase-macro existing876 type874 val875) (make-syncase-macro type874 val875)))))) (local-eval-hook76 (lambda (x879 mod880) (primitive-eval (list noexpand69 (let ((t881 (fluid-ref *mode*70))) (if (memv t881 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x879) x879)))))) (top-level-eval-hook75 (lambda (x882 mod883) (primitive-eval (list noexpand69 (let ((t884 (fluid-ref *mode*70))) (if (memv t884 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x882) x882)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend102 (quote local-syntax) (quote let-syntax) #f) (global-extend102 (quote core) (quote fluid-let-syntax) (lambda (e885 r886 w887 s888 mod889) ((lambda (tmp890) ((lambda (tmp891) (if (if tmp891 (apply (lambda (_892 var893 val894 e1895 e2896) (valid-bound-ids?129 var893)) tmp891) #f) (apply (lambda (_898 var899 val900 e1901 e2902) (let ((names903 (map (lambda (x904) (id-var-name126 x904 w887)) var899))) (begin (for-each (lambda (id906 n907) (let ((t908 (binding-type96 (lookup101 n907 r886 mod889)))) (if (memv t908 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e885 (source-wrap133 id906 w887 s888 mod889))))) var899 names903) (chi-body144 (cons e1901 e2902) (source-wrap133 e885 w887 s888 mod889) (extend-env98 names903 (let ((trans-r911 (macros-only-env100 r886))) (map (lambda (x912) (cons (quote macro) (eval-local-transformer147 (chi140 x912 trans-r911 w887 mod889) mod889))) val900)) r886) w887 mod889)))) tmp891) ((lambda (_914) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap133 e885 w887 s888 mod889))) tmp890))) ($sc-dispatch tmp890 (quote (any #(each (any any)) any . each-any))))) e885))) (global-extend102 (quote core) (quote quote) (lambda (e915 r916 w917 s918 mod919) ((lambda (tmp920) ((lambda (tmp921) (if tmp921 (apply (lambda (_922 e923) (build-data82 s918 (strip151 e923 w917))) tmp921) ((lambda (_924) (syntax-violation (quote quote) "bad syntax" (source-wrap133 e915 w917 s918 mod919))) tmp920))) ($sc-dispatch tmp920 (quote (any any))))) e915))) (global-extend102 (quote core) (quote syntax) (letrec ((regen932 (lambda (x933) (let ((t934 (car x933))) (if (memv t934 (quote (ref))) (build-annotated79 #f (cadr x933)) (if (memv t934 (quote (primitive))) (build-annotated79 #f (cadr x933)) (if (memv t934 (quote (quote))) (build-data82 #f (cadr x933)) (if (memv t934 (quote (lambda))) (build-annotated79 #f (list (quote lambda) (cadr x933) (regen932 (caddr x933)))) (if (memv t934 (quote (map))) (let ((ls935 (map regen932 (cdr x933)))) (build-annotated79 #f (cons (if (fx=73 (length ls935) 2) (build-annotated79 #f (quote map)) (build-annotated79 #f (quote map))) ls935))) (build-annotated79 #f (cons (build-annotated79 #f (car x933)) (map regen932 (cdr x933)))))))))))) (gen-vector931 (lambda (x936) (cond ((eq? (car x936) (quote list)) (cons (quote vector) (cdr x936))) ((eq? (car x936) (quote quote)) (list (quote quote) (list->vector (cadr x936)))) (else (list (quote list->vector) x936))))) (gen-append930 (lambda (x937 y938) (if (equal? y938 (quote (quote ()))) x937 (list (quote append) x937 y938)))) (gen-cons929 (lambda (x939 y940) (let ((t941 (car y940))) (if (memv t941 (quote (quote))) (if (eq? (car x939) (quote quote)) (list (quote quote) (cons (cadr x939) (cadr y940))) (if (eq? (cadr y940) (quote ())) (list (quote list) x939) (list (quote cons) x939 y940))) (if (memv t941 (quote (list))) (cons (quote list) (cons x939 (cdr y940))) (list (quote cons) x939 y940)))))) (gen-map928 (lambda (e942 map-env943) (let ((formals944 (map cdr map-env943)) (actuals945 (map (lambda (x946) (list (quote ref) (car x946))) map-env943))) (cond ((eq? (car e942) (quote ref)) (car actuals945)) ((and-map (lambda (x947) (and (eq? (car x947) (quote ref)) (memq (cadr x947) formals944))) (cdr e942)) (cons (quote map) (cons (list (quote primitive) (car e942)) (map (let ((r948 (map cons formals944 actuals945))) (lambda (x949) (cdr (assq (cadr x949) r948)))) (cdr e942))))) (else (cons (quote map) (cons (list (quote lambda) formals944 e942) actuals945))))))) (gen-mappend927 (lambda (e950 map-env951) (list (quote apply) (quote (primitive append)) (gen-map928 e950 map-env951)))) (gen-ref926 (lambda (src952 var953 level954 maps955) (if (fx=73 level954 0) (values var953 maps955) (if (null? maps955) (syntax-violation (quote syntax) "missing ellipsis" src952) (call-with-values (lambda () (gen-ref926 src952 var953 (fx-72 level954 1) (cdr maps955))) (lambda (outer-var956 outer-maps957) (let ((b958 (assq outer-var956 (car maps955)))) (if b958 (values (cdr b958) maps955) (let ((inner-var959 (gen-var152 (quote tmp)))) (values inner-var959 (cons (cons (cons outer-var956 inner-var959) (car maps955)) outer-maps957))))))))))) (gen-syntax925 (lambda (src960 e961 r962 maps963 ellipsis?964 mod965) (if (id?104 e961) (let ((label966 (id-var-name126 e961 (quote (()))))) (let ((b967 (lookup101 label966 r962 mod965))) (if (eq? (binding-type96 b967) (quote syntax)) (call-with-values (lambda () (let ((var.lev968 (binding-value97 b967))) (gen-ref926 src960 (car var.lev968) (cdr var.lev968) maps963))) (lambda (var969 maps970) (values (list (quote ref) var969) maps970))) (if (ellipsis?964 e961) (syntax-violation (quote syntax) "misplaced ellipsis" src960) (values (list (quote quote) e961) maps963))))) ((lambda (tmp971) ((lambda (tmp972) (if (if tmp972 (apply (lambda (dots973 e974) (ellipsis?964 dots973)) tmp972) #f) (apply (lambda (dots975 e976) (gen-syntax925 src960 e976 r962 maps963 (lambda (x977) #f) mod965)) tmp972) ((lambda (tmp978) (if (if tmp978 (apply (lambda (x979 dots980 y981) (ellipsis?964 dots980)) tmp978) #f) (apply (lambda (x982 dots983 y984) (let f985 ((y986 y984) (k987 (lambda (maps988) (call-with-values (lambda () (gen-syntax925 src960 x982 r962 (cons (quote ()) maps988) ellipsis?964 mod965)) (lambda (x989 maps990) (if (null? (car maps990)) (syntax-violation (quote syntax) "extra ellipsis" src960) (values (gen-map928 x989 (car maps990)) (cdr maps990)))))))) ((lambda (tmp991) ((lambda (tmp992) (if (if tmp992 (apply (lambda (dots993 y994) (ellipsis?964 dots993)) tmp992) #f) (apply (lambda (dots995 y996) (f985 y996 (lambda (maps997) (call-with-values (lambda () (k987 (cons (quote ()) maps997))) (lambda (x998 maps999) (if (null? (car maps999)) (syntax-violation (quote syntax) "extra ellipsis" src960) (values (gen-mappend927 x998 (car maps999)) (cdr maps999)))))))) tmp992) ((lambda (_1000) (call-with-values (lambda () (gen-syntax925 src960 y986 r962 maps963 ellipsis?964 mod965)) (lambda (y1001 maps1002) (call-with-values (lambda () (k987 maps1002)) (lambda (x1003 maps1004) (values (gen-append930 x1003 y1001) maps1004)))))) tmp991))) ($sc-dispatch tmp991 (quote (any . any))))) y986))) tmp978) ((lambda (tmp1005) (if tmp1005 (apply (lambda (x1006 y1007) (call-with-values (lambda () (gen-syntax925 src960 x1006 r962 maps963 ellipsis?964 mod965)) (lambda (x1008 maps1009) (call-with-values (lambda () (gen-syntax925 src960 y1007 r962 maps1009 ellipsis?964 mod965)) (lambda (y1010 maps1011) (values (gen-cons929 x1008 y1010) maps1011)))))) tmp1005) ((lambda (tmp1012) (if tmp1012 (apply (lambda (e11013 e21014) (call-with-values (lambda () (gen-syntax925 src960 (cons e11013 e21014) r962 maps963 ellipsis?964 mod965)) (lambda (e1016 maps1017) (values (gen-vector931 e1016) maps1017)))) tmp1012) ((lambda (_1018) (values (list (quote quote) e961) maps963)) tmp971))) ($sc-dispatch tmp971 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp971 (quote (any . any)))))) ($sc-dispatch tmp971 (quote (any any . any)))))) ($sc-dispatch tmp971 (quote (any any))))) e961))))) (lambda (e1019 r1020 w1021 s1022 mod1023) (let ((e1024 (source-wrap133 e1019 w1021 s1022 mod1023))) ((lambda (tmp1025) ((lambda (tmp1026) (if tmp1026 (apply (lambda (_1027 x1028) (call-with-values (lambda () (gen-syntax925 e1024 x1028 r1020 (quote ()) ellipsis?149 mod1023)) (lambda (e1029 maps1030) (regen932 e1029)))) tmp1026) ((lambda (_1031) (syntax-violation (quote syntax) "bad `syntax' form" e1024)) tmp1025))) ($sc-dispatch tmp1025 (quote (any any))))) e1024))))) (global-extend102 (quote core) (quote lambda) (lambda (e1032 r1033 w1034 s1035 mod1036) ((lambda (tmp1037) ((lambda (tmp1038) (if tmp1038 (apply (lambda (_1039 c1040) (chi-lambda-clause145 (source-wrap133 e1032 w1034 s1035 mod1036) #f c1040 r1033 w1034 mod1036 (lambda (vars1041 docstring1042 body1043) (build-annotated79 s1035 (cons (quote lambda) (cons vars1041 (append (if docstring1042 (list docstring1042) (quote ())) (list body1043)))))))) tmp1038) (syntax-violation #f "source expression failed to match any pattern" tmp1037))) ($sc-dispatch tmp1037 (quote (any . any))))) e1032))) (global-extend102 (quote core) (quote let) (letrec ((chi-let1044 (lambda (e1045 r1046 w1047 s1048 mod1049 constructor1050 ids1051 vals1052 exps1053) (if (not (valid-bound-ids?129 ids1051)) (syntax-violation (quote let) "duplicate bound variable" e1045) (let ((labels1054 (gen-labels110 ids1051)) (new-vars1055 (map gen-var152 ids1051))) (let ((nw1056 (make-binding-wrap121 ids1051 labels1054 w1047)) (nr1057 (extend-var-env99 labels1054 new-vars1055 r1046))) (constructor1050 s1048 new-vars1055 (map (lambda (x1058) (chi140 x1058 r1046 w1047 mod1049)) vals1052) (chi-body144 exps1053 (source-wrap133 e1045 nw1056 s1048 mod1049) nr1057 nw1056 mod1049)))))))) (lambda (e1059 r1060 w1061 s1062 mod1063) ((lambda (tmp1064) ((lambda (tmp1065) (if tmp1065 (apply (lambda (_1066 id1067 val1068 e11069 e21070) (chi-let1044 e1059 r1060 w1061 s1062 mod1063 build-let84 id1067 val1068 (cons e11069 e21070))) tmp1065) ((lambda (tmp1074) (if (if tmp1074 (apply (lambda (_1075 f1076 id1077 val1078 e11079 e21080) (id?104 f1076)) tmp1074) #f) (apply (lambda (_1081 f1082 id1083 val1084 e11085 e21086) (chi-let1044 e1059 r1060 w1061 s1062 mod1063 build-named-let85 (cons f1082 id1083) val1084 (cons e11085 e21086))) tmp1074) ((lambda (_1090) (syntax-violation (quote let) "bad let" (source-wrap133 e1059 w1061 s1062 mod1063))) tmp1064))) ($sc-dispatch tmp1064 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1064 (quote (any #(each (any any)) any . each-any))))) e1059)))) (global-extend102 (quote core) (quote letrec) (lambda (e1091 r1092 w1093 s1094 mod1095) ((lambda (tmp1096) ((lambda (tmp1097) (if tmp1097 (apply (lambda (_1098 id1099 val1100 e11101 e21102) (let ((ids1103 id1099)) (if (not (valid-bound-ids?129 ids1103)) (syntax-violation (quote letrec) "duplicate bound variable" e1091) (let ((labels1105 (gen-labels110 ids1103)) (new-vars1106 (map gen-var152 ids1103))) (let ((w1107 (make-binding-wrap121 ids1103 labels1105 w1093)) (r1108 (extend-var-env99 labels1105 new-vars1106 r1092))) (build-letrec86 s1094 new-vars1106 (map (lambda (x1109) (chi140 x1109 r1108 w1107 mod1095)) val1100) (chi-body144 (cons e11101 e21102) (source-wrap133 e1091 w1107 s1094 mod1095) r1108 w1107 mod1095))))))) tmp1097) ((lambda (_1112) (syntax-violation (quote letrec) "bad letrec" (source-wrap133 e1091 w1093 s1094 mod1095))) tmp1096))) ($sc-dispatch tmp1096 (quote (any #(each (any any)) any . each-any))))) e1091))) (global-extend102 (quote core) (quote set!) (lambda (e1113 r1114 w1115 s1116 mod1117) ((lambda (tmp1118) ((lambda (tmp1119) (if (if tmp1119 (apply (lambda (_1120 id1121 val1122) (id?104 id1121)) tmp1119) #f) (apply (lambda (_1123 id1124 val1125) (let ((val1126 (chi140 val1125 r1114 w1115 mod1117)) (n1127 (id-var-name126 id1124 w1115))) (let ((b1128 (lookup101 n1127 r1114 mod1117))) (let ((t1129 (binding-type96 b1128))) (if (memv t1129 (quote (lexical))) (build-annotated79 s1116 (list (quote set!) (binding-value97 b1128) val1126)) (if (memv t1129 (quote (global))) (build-global-assignment81 s1116 n1127 val1126 mod1117) (if (memv t1129 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap132 id1124 w1115 mod1117)) (syntax-violation (quote set!) "bad set!" (source-wrap133 e1113 w1115 s1116 mod1117))))))))) tmp1119) ((lambda (tmp1130) (if tmp1130 (apply (lambda (_1131 head1132 tail1133 val1134) (call-with-values (lambda () (syntax-type138 head1132 r1114 (quote (())) #f #f mod1117)) (lambda (type1135 value1136 ee1137 ww1138 ss1139 modmod1140) (let ((t1141 type1135)) (if (memv t1141 (quote (module-ref))) (let ((val1142 (chi140 val1134 r1114 w1115 mod1117))) (call-with-values (lambda () (value1136 (cons head1132 tail1133))) (lambda (id1144 mod1145) (build-global-assignment81 s1116 id1144 val1142 mod1145)))) (build-annotated79 s1116 (cons (chi140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1132) r1114 w1115 mod1117) (map (lambda (e1146) (chi140 e1146 r1114 w1115 mod1117)) (append tail1133 (list val1134)))))))))) tmp1130) ((lambda (_1148) (syntax-violation (quote set!) "bad set!" (source-wrap133 e1113 w1115 s1116 mod1117))) tmp1118))) ($sc-dispatch tmp1118 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1118 (quote (any any any))))) e1113))) (global-extend102 (quote module-ref) (quote @) (lambda (e1149) ((lambda (tmp1150) ((lambda (tmp1151) (if (if tmp1151 (apply (lambda (_1152 mod1153 id1154) (and (and-map id?104 mod1153) (id?104 id1154))) tmp1151) #f) (apply (lambda (_1156 mod1157 id1158) (values (syntax->datum id1158) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1157)))) tmp1151) (syntax-violation #f "source expression failed to match any pattern" tmp1150))) ($sc-dispatch tmp1150 (quote (any each-any any))))) e1149))) (global-extend102 (quote module-ref) (quote @@) (lambda (e1160) ((lambda (tmp1161) ((lambda (tmp1162) (if (if tmp1162 (apply (lambda (_1163 mod1164 id1165) (and (and-map id?104 mod1164) (id?104 id1165))) tmp1162) #f) (apply (lambda (_1167 mod1168 id1169) (values (syntax->datum id1169) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1168)))) tmp1162) (syntax-violation #f "source expression failed to match any pattern" tmp1161))) ($sc-dispatch tmp1161 (quote (any each-any any))))) e1160))) (global-extend102 (quote begin) (quote begin) (quote ())) (global-extend102 (quote define) (quote define) (quote ())) (global-extend102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend102 (quote eval-when) (quote eval-when) (quote ())) (global-extend102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1174 (lambda (x1175 keys1176 clauses1177 r1178 mod1179) (if (null? clauses1177) (build-annotated79 #f (list (build-annotated79 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1175)) ((lambda (tmp1180) ((lambda (tmp1181) (if tmp1181 (apply (lambda (pat1182 exp1183) (if (and (id?104 pat1182) (and-map (lambda (x1184) (not (free-id=?127 pat1182 x1184))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1176))) (let ((labels1185 (list (gen-label109))) (var1186 (gen-var152 pat1182))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list var1186) (chi140 exp1183 (extend-env98 labels1185 (list (cons (quote syntax) (cons var1186 0))) r1178) (make-binding-wrap121 (list pat1182) labels1185 (quote (()))) mod1179))) x1175))) (gen-clause1173 x1175 keys1176 (cdr clauses1177) r1178 pat1182 #t exp1183 mod1179))) tmp1181) ((lambda (tmp1187) (if tmp1187 (apply (lambda (pat1188 fender1189 exp1190) (gen-clause1173 x1175 keys1176 (cdr clauses1177) r1178 pat1188 fender1189 exp1190 mod1179)) tmp1187) ((lambda (_1191) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1177))) tmp1180))) ($sc-dispatch tmp1180 (quote (any any any)))))) ($sc-dispatch tmp1180 (quote (any any))))) (car clauses1177))))) (gen-clause1173 (lambda (x1192 keys1193 clauses1194 r1195 pat1196 fender1197 exp1198 mod1199) (call-with-values (lambda () (convert-pattern1171 pat1196 keys1193)) (lambda (p1200 pvars1201) (cond ((not (distinct-bound-ids?130 (map car pvars1201))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1196)) ((not (and-map (lambda (x1202) (not (ellipsis?149 (car x1202)))) pvars1201)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1196)) (else (let ((y1203 (gen-var152 (quote tmp)))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list y1203) (let ((y1204 (build-annotated79 #f y1203))) (build-annotated79 #f (list (quote if) ((lambda (tmp1205) ((lambda (tmp1206) (if tmp1206 (apply (lambda () y1204) tmp1206) ((lambda (_1207) (build-annotated79 #f (list (quote if) y1204 (build-dispatch-call1172 pvars1201 fender1197 y1204 r1195 mod1199) (build-data82 #f #f)))) tmp1205))) ($sc-dispatch tmp1205 (quote #(atom #t))))) fender1197) (build-dispatch-call1172 pvars1201 exp1198 y1204 r1195 mod1199) (gen-syntax-case1174 x1192 keys1193 clauses1194 r1195 mod1199)))))) (if (eq? p1200 (quote any)) (build-annotated79 #f (list (build-annotated79 #f (quote list)) x1192)) (build-annotated79 #f (list (build-annotated79 #f (quote $sc-dispatch)) x1192 (build-data82 #f p1200))))))))))))) (build-dispatch-call1172 (lambda (pvars1208 exp1209 y1210 r1211 mod1212) (let ((ids1213 (map car pvars1208)) (levels1214 (map cdr pvars1208))) (let ((labels1215 (gen-labels110 ids1213)) (new-vars1216 (map gen-var152 ids1213))) (build-annotated79 #f (list (build-annotated79 #f (quote apply)) (build-annotated79 #f (list (quote lambda) new-vars1216 (chi140 exp1209 (extend-env98 labels1215 (map (lambda (var1217 level1218) (cons (quote syntax) (cons var1217 level1218))) new-vars1216 (map cdr pvars1208)) r1211) (make-binding-wrap121 ids1213 labels1215 (quote (()))) mod1212))) y1210)))))) (convert-pattern1171 (lambda (pattern1219 keys1220) (let cvt1221 ((p1222 pattern1219) (n1223 0) (ids1224 (quote ()))) (if (id?104 p1222) (if (bound-id-member?131 p1222 keys1220) (values (vector (quote free-id) p1222) ids1224) (values (quote any) (cons (cons p1222 n1223) ids1224))) ((lambda (tmp1225) ((lambda (tmp1226) (if (if tmp1226 (apply (lambda (x1227 dots1228) (ellipsis?149 dots1228)) tmp1226) #f) (apply (lambda (x1229 dots1230) (call-with-values (lambda () (cvt1221 x1229 (fx+71 n1223 1) ids1224)) (lambda (p1231 ids1232) (values (if (eq? p1231 (quote any)) (quote each-any) (vector (quote each) p1231)) ids1232)))) tmp1226) ((lambda (tmp1233) (if tmp1233 (apply (lambda (x1234 y1235) (call-with-values (lambda () (cvt1221 y1235 n1223 ids1224)) (lambda (y1236 ids1237) (call-with-values (lambda () (cvt1221 x1234 n1223 ids1237)) (lambda (x1238 ids1239) (values (cons x1238 y1236) ids1239)))))) tmp1233) ((lambda (tmp1240) (if tmp1240 (apply (lambda () (values (quote ()) ids1224)) tmp1240) ((lambda (tmp1241) (if tmp1241 (apply (lambda (x1242) (call-with-values (lambda () (cvt1221 x1242 n1223 ids1224)) (lambda (p1244 ids1245) (values (vector (quote vector) p1244) ids1245)))) tmp1241) ((lambda (x1246) (values (vector (quote atom) (strip151 p1222 (quote (())))) ids1224)) tmp1225))) ($sc-dispatch tmp1225 (quote #(vector each-any)))))) ($sc-dispatch tmp1225 (quote ()))))) ($sc-dispatch tmp1225 (quote (any . any)))))) ($sc-dispatch tmp1225 (quote (any any))))) p1222)))))) (lambda (e1247 r1248 w1249 s1250 mod1251) (let ((e1252 (source-wrap133 e1247 w1249 s1250 mod1251))) ((lambda (tmp1253) ((lambda (tmp1254) (if tmp1254 (apply (lambda (_1255 val1256 key1257 m1258) (if (and-map (lambda (x1259) (and (id?104 x1259) (not (ellipsis?149 x1259)))) key1257) (let ((x1261 (gen-var152 (quote tmp)))) (build-annotated79 s1250 (list (build-annotated79 #f (list (quote lambda) (list x1261) (gen-syntax-case1174 (build-annotated79 #f x1261) key1257 m1258 r1248 mod1251))) (chi140 val1256 r1248 (quote (())) mod1251)))) (syntax-violation (quote syntax-case) "invalid literals list" e1252))) tmp1254) (syntax-violation #f "source expression failed to match any pattern" tmp1253))) ($sc-dispatch tmp1253 (quote (any any each-any . each-any))))) e1252))))) (set! sc-expand (lambda (x1265 . rest1264) (if (and (pair? x1265) (equal? (car x1265) noexpand69)) (cadr x1265) (let ((m1266 (if (null? rest1264) (quote e) (car rest1264))) (esew1267 (if (or (null? rest1264) (null? (cdr rest1264))) (quote (eval)) (cadr rest1264)))) (with-fluid* *mode*70 m1266 (lambda () (chi-top139 x1265 (quote ()) (quote ((top))) m1266 esew1267 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1268) (nonsymbol-id?103 x1268))) (set! datum->syntax (lambda (id1269 datum1270) (make-syntax-object87 datum1270 (syntax-object-wrap90 id1269) #f))) (set! syntax->datum (lambda (x1271) (strip151 x1271 (quote (()))))) (set! generate-temporaries (lambda (ls1272) (begin (let ((x1273 ls1272)) (if (not (list? x1273)) (syntax-violation (quote generate-temporaries) "invalid argument" x1273))) (map (lambda (x1274) (wrap132 (gensym) (quote ((top))) #f)) ls1272)))) (set! free-identifier=? (lambda (x1275 y1276) (begin (let ((x1277 x1275)) (if (not (nonsymbol-id?103 x1277)) (syntax-violation (quote free-identifier=?) "invalid argument" x1277))) (let ((x1278 y1276)) (if (not (nonsymbol-id?103 x1278)) (syntax-violation (quote free-identifier=?) "invalid argument" x1278))) (free-id=?127 x1275 y1276)))) (set! bound-identifier=? (lambda (x1279 y1280) (begin (let ((x1281 x1279)) (if (not (nonsymbol-id?103 x1281)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1281))) (let ((x1282 y1280)) (if (not (nonsymbol-id?103 x1282)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1282))) (bound-id=?128 x1279 y1280)))) (set! syntax-violation (lambda (who1286 message1285 form1284 . subform1283) (begin (let ((x1287 who1286)) (if (not ((lambda (x1288) (or (not x1288) (string? x1288) (symbol? x1288))) x1287)) (syntax-violation (quote syntax-violation) "invalid argument" x1287))) (let ((x1289 message1285)) (if (not (string? x1289)) (syntax-violation (quote syntax-violation) "invalid argument" x1289))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1286 "~a: " "") "~a " (if (null? subform1283) "in ~a" "in subform `~s' of `~s'")) (let ((tail1290 (cons message1285 (map (lambda (x1291) (strip151 x1291 (quote (())))) (append subform1283 (list form1284)))))) (if who1286 (cons who1286 tail1290) tail1290)) #f)))) (letrec ((match1296 (lambda (e1297 p1298 w1299 r1300 mod1301) (cond ((not r1300) #f) ((eq? p1298 (quote any)) (cons (wrap132 e1297 w1299 mod1301) r1300)) ((syntax-object?88 e1297) (match*1295 (let ((e1302 (syntax-object-expression89 e1297))) (if (annotation? e1302) (annotation-expression e1302) e1302)) p1298 (join-wraps123 w1299 (syntax-object-wrap90 e1297)) r1300 (syntax-object-module91 e1297))) (else (match*1295 (let ((e1303 e1297)) (if (annotation? e1303) (annotation-expression e1303) e1303)) p1298 w1299 r1300 mod1301))))) (match*1295 (lambda (e1304 p1305 w1306 r1307 mod1308) (cond ((null? p1305) (and (null? e1304) r1307)) ((pair? p1305) (and (pair? e1304) (match1296 (car e1304) (car p1305) w1306 (match1296 (cdr e1304) (cdr p1305) w1306 r1307 mod1308) mod1308))) ((eq? p1305 (quote each-any)) (let ((l1309 (match-each-any1293 e1304 w1306 mod1308))) (and l1309 (cons l1309 r1307)))) (else (let ((t1310 (vector-ref p1305 0))) (if (memv t1310 (quote (each))) (if (null? e1304) (match-empty1294 (vector-ref p1305 1) r1307) (let ((l1311 (match-each1292 e1304 (vector-ref p1305 1) w1306 mod1308))) (and l1311 (let collect1312 ((l1313 l1311)) (if (null? (car l1313)) r1307 (cons (map car l1313) (collect1312 (map cdr l1313)))))))) (if (memv t1310 (quote (free-id))) (and (id?104 e1304) (free-id=?127 (wrap132 e1304 w1306 mod1308) (vector-ref p1305 1)) r1307) (if (memv t1310 (quote (atom))) (and (equal? (vector-ref p1305 1) (strip151 e1304 w1306)) r1307) (if (memv t1310 (quote (vector))) (and (vector? e1304) (match1296 (vector->list e1304) (vector-ref p1305 1) w1306 r1307 mod1308))))))))))) (match-empty1294 (lambda (p1314 r1315) (cond ((null? p1314) r1315) ((eq? p1314 (quote any)) (cons (quote ()) r1315)) ((pair? p1314) (match-empty1294 (car p1314) (match-empty1294 (cdr p1314) r1315))) ((eq? p1314 (quote each-any)) (cons (quote ()) r1315)) (else (let ((t1316 (vector-ref p1314 0))) (if (memv t1316 (quote (each))) (match-empty1294 (vector-ref p1314 1) r1315) (if (memv t1316 (quote (free-id atom))) r1315 (if (memv t1316 (quote (vector))) (match-empty1294 (vector-ref p1314 1) r1315))))))))) (match-each-any1293 (lambda (e1317 w1318 mod1319) (cond ((annotation? e1317) (match-each-any1293 (annotation-expression e1317) w1318 mod1319)) ((pair? e1317) (let ((l1320 (match-each-any1293 (cdr e1317) w1318 mod1319))) (and l1320 (cons (wrap132 (car e1317) w1318 mod1319) l1320)))) ((null? e1317) (quote ())) ((syntax-object?88 e1317) (match-each-any1293 (syntax-object-expression89 e1317) (join-wraps123 w1318 (syntax-object-wrap90 e1317)) mod1319)) (else #f)))) (match-each1292 (lambda (e1321 p1322 w1323 mod1324) (cond ((annotation? e1321) (match-each1292 (annotation-expression e1321) p1322 w1323 mod1324)) ((pair? e1321) (let ((first1325 (match1296 (car e1321) p1322 w1323 (quote ()) mod1324))) (and first1325 (let ((rest1326 (match-each1292 (cdr e1321) p1322 w1323 mod1324))) (and rest1326 (cons first1325 rest1326)))))) ((null? e1321) (quote ())) ((syntax-object?88 e1321) (match-each1292 (syntax-object-expression89 e1321) p1322 (join-wraps123 w1323 (syntax-object-wrap90 e1321)) (syntax-object-module91 e1321))) (else #f))))) (set! $sc-dispatch (lambda (e1327 p1328) (cond ((eq? p1328 (quote any)) (list e1327)) ((syntax-object?88 e1327) (match*1295 (let ((e1329 (syntax-object-expression89 e1327))) (if (annotation? e1329) (annotation-expression e1329) e1329)) p1328 (syntax-object-wrap90 e1327) (quote ()) (syntax-object-module91 e1327))) (else (match*1295 (let ((e1330 e1327)) (if (annotation? e1330) (annotation-expression e1330) e1330)) p1328 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1331) ((lambda (tmp1332) ((lambda (tmp1333) (if tmp1333 (apply (lambda (_1334 e11335 e21336) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11335 e21336))) tmp1333) ((lambda (tmp1338) (if tmp1338 (apply (lambda (_1339 out1340 in1341 e11342 e21343) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1341 (quote ()) (list out1340 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11342 e21343))))) tmp1338) ((lambda (tmp1345) (if tmp1345 (apply (lambda (_1346 out1347 in1348 e11349 e21350) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1348) (quote ()) (list out1347 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11349 e21350))))) tmp1345) (syntax-violation #f "source expression failed to match any pattern" tmp1332))) ($sc-dispatch tmp1332 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1332 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1332 (quote (any () any . each-any))))) x1331)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1354) ((lambda (tmp1355) ((lambda (tmp1356) (if tmp1356 (apply (lambda (_1357 k1358 keyword1359 pattern1360 template1361) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1358 (map (lambda (tmp1364 tmp1363) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1363) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1364))) template1361 pattern1360)))))) tmp1356) (syntax-violation #f "source expression failed to match any pattern" tmp1355))) ($sc-dispatch tmp1355 (quote (any each-any . #(each ((any . any) any))))))) x1354)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1365) ((lambda (tmp1366) ((lambda (tmp1367) (if (if tmp1367 (apply (lambda (let*1368 x1369 v1370 e11371 e21372) (and-map identifier? x1369)) tmp1367) #f) (apply (lambda (let*1374 x1375 v1376 e11377 e21378) (let f1379 ((bindings1380 (map list x1375 v1376))) (if (null? bindings1380) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11377 e21378))) ((lambda (tmp1384) ((lambda (tmp1385) (if tmp1385 (apply (lambda (body1386 binding1387) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1387) body1386)) tmp1385) (syntax-violation #f "source expression failed to match any pattern" tmp1384))) ($sc-dispatch tmp1384 (quote (any any))))) (list (f1379 (cdr bindings1380)) (car bindings1380)))))) tmp1367) (syntax-violation #f "source expression failed to match any pattern" tmp1366))) ($sc-dispatch tmp1366 (quote (any #(each (any any)) any . each-any))))) x1365)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1388) ((lambda (tmp1389) ((lambda (tmp1390) (if tmp1390 (apply (lambda (_1391 var1392 init1393 step1394 e01395 e11396 c1397) ((lambda (tmp1398) ((lambda (tmp1399) (if tmp1399 (apply (lambda (step1400) ((lambda (tmp1401) ((lambda (tmp1402) (if tmp1402 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1392 init1393) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01395) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1397 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1400))))))) tmp1402) ((lambda (tmp1407) (if tmp1407 (apply (lambda (e11408 e21409) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1392 init1393) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01395 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11408 e21409)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1397 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1400))))))) tmp1407) (syntax-violation #f "source expression failed to match any pattern" tmp1401))) ($sc-dispatch tmp1401 (quote (any . each-any)))))) ($sc-dispatch tmp1401 (quote ())))) e11396)) tmp1399) (syntax-violation #f "source expression failed to match any pattern" tmp1398))) ($sc-dispatch tmp1398 (quote each-any)))) (map (lambda (v1416 s1417) ((lambda (tmp1418) ((lambda (tmp1419) (if tmp1419 (apply (lambda () v1416) tmp1419) ((lambda (tmp1420) (if tmp1420 (apply (lambda (e1421) e1421) tmp1420) ((lambda (_1422) (syntax-violation (quote do) "bad step expression" orig-x1388 s1417)) tmp1418))) ($sc-dispatch tmp1418 (quote (any)))))) ($sc-dispatch tmp1418 (quote ())))) s1417)) var1392 step1394))) tmp1390) (syntax-violation #f "source expression failed to match any pattern" tmp1389))) ($sc-dispatch tmp1389 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1388)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1425 (lambda (x1429 y1430) ((lambda (tmp1431) ((lambda (tmp1432) (if tmp1432 (apply (lambda (x1433 y1434) ((lambda (tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (dy1437) ((lambda (tmp1438) ((lambda (tmp1439) (if tmp1439 (apply (lambda (dx1440) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1440 dy1437))) tmp1439) ((lambda (_1441) (if (null? dy1437) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1433) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1433 y1434))) tmp1438))) ($sc-dispatch tmp1438 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1433)) tmp1436) ((lambda (tmp1442) (if tmp1442 (apply (lambda (stuff1443) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1433 stuff1443))) tmp1442) ((lambda (else1444) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1433 y1434)) tmp1435))) ($sc-dispatch tmp1435 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1435 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1434)) tmp1432) (syntax-violation #f "source expression failed to match any pattern" tmp1431))) ($sc-dispatch tmp1431 (quote (any any))))) (list x1429 y1430)))) (quasiappend1426 (lambda (x1445 y1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (x1449 y1450) ((lambda (tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda () x1449) tmp1452) ((lambda (_1453) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449 y1450)) tmp1451))) ($sc-dispatch tmp1451 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1450)) tmp1448) (syntax-violation #f "source expression failed to match any pattern" tmp1447))) ($sc-dispatch tmp1447 (quote (any any))))) (list x1445 y1446)))) (quasivector1427 (lambda (x1454) ((lambda (tmp1455) ((lambda (x1456) ((lambda (tmp1457) ((lambda (tmp1458) (if tmp1458 (apply (lambda (x1459) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1459))) tmp1458) ((lambda (tmp1461) (if tmp1461 (apply (lambda (x1462) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1462)) tmp1461) ((lambda (_1464) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1456)) tmp1457))) ($sc-dispatch tmp1457 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1457 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1456)) tmp1455)) x1454))) (quasi1428 (lambda (p1465 lev1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda (p1469) (if (= lev1466 0) p1469 (quasicons1425 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1428 (list p1469) (- lev1466 1))))) tmp1468) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471 q1472) (if (= lev1466 0) (quasiappend1426 p1471 (quasi1428 q1472 lev1466)) (quasicons1425 (quasicons1425 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1428 (list p1471) (- lev1466 1))) (quasi1428 q1472 lev1466)))) tmp1470) ((lambda (tmp1473) (if tmp1473 (apply (lambda (p1474) (quasicons1425 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1428 (list p1474) (+ lev1466 1)))) tmp1473) ((lambda (tmp1475) (if tmp1475 (apply (lambda (p1476 q1477) (quasicons1425 (quasi1428 p1476 lev1466) (quasi1428 q1477 lev1466))) tmp1475) ((lambda (tmp1478) (if tmp1478 (apply (lambda (x1479) (quasivector1427 (quasi1428 x1479 lev1466))) tmp1478) ((lambda (p1481) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1481)) tmp1467))) ($sc-dispatch tmp1467 (quote #(vector each-any)))))) ($sc-dispatch tmp1467 (quote (any . any)))))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1467 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1465)))) (lambda (x1482) ((lambda (tmp1483) ((lambda (tmp1484) (if tmp1484 (apply (lambda (_1485 e1486) (quasi1428 e1486 0)) tmp1484) (syntax-violation #f "source expression failed to match any pattern" tmp1483))) ($sc-dispatch tmp1483 (quote (any any))))) x1482))))) -(define include (make-syncase-macro (quote macro) (lambda (x1487) (letrec ((read-file1488 (lambda (fn1489 k1490) (let ((p1491 (open-input-file fn1489))) (let f1492 ((x1493 (read p1491))) (if (eof-object? x1493) (begin (close-input-port p1491) (quote ())) (cons (datum->syntax k1490 x1493) (f1492 (read p1491))))))))) ((lambda (tmp1494) ((lambda (tmp1495) (if tmp1495 (apply (lambda (k1496 filename1497) (let ((fn1498 (syntax->datum filename1497))) ((lambda (tmp1499) ((lambda (tmp1500) (if tmp1500 (apply (lambda (exp1501) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1501)) tmp1500) (syntax-violation #f "source expression failed to match any pattern" tmp1499))) ($sc-dispatch tmp1499 (quote each-any)))) (read-file1488 fn1498 k1496)))) tmp1495) (syntax-violation #f "source expression failed to match any pattern" tmp1494))) ($sc-dispatch tmp1494 (quote (any any))))) x1487))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1503) ((lambda (tmp1504) ((lambda (tmp1505) (if tmp1505 (apply (lambda (_1506 e1507) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1503)) tmp1505) (syntax-violation #f "source expression failed to match any pattern" tmp1504))) ($sc-dispatch tmp1504 (quote (any any))))) x1503)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1508) ((lambda (tmp1509) ((lambda (tmp1510) (if tmp1510 (apply (lambda (_1511 e1512) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1508)) tmp1510) (syntax-violation #f "source expression failed to match any pattern" tmp1509))) ($sc-dispatch tmp1509 (quote (any any))))) x1508)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1513) ((lambda (tmp1514) ((lambda (tmp1515) (if tmp1515 (apply (lambda (_1516 e1517 m11518 m21519) ((lambda (tmp1520) ((lambda (body1521) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1517)) body1521)) tmp1520)) (let f1522 ((clause1523 m11518) (clauses1524 m21519)) (if (null? clauses1524) ((lambda (tmp1526) ((lambda (tmp1527) (if tmp1527 (apply (lambda (e11528 e21529) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11528 e21529))) tmp1527) ((lambda (tmp1531) (if tmp1531 (apply (lambda (k1532 e11533 e21534) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1532)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11533 e21534)))) tmp1531) ((lambda (_1537) (syntax-violation (quote case) "bad clause" x1513 clause1523)) tmp1526))) ($sc-dispatch tmp1526 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1526 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1523) ((lambda (tmp1538) ((lambda (rest1539) ((lambda (tmp1540) ((lambda (tmp1541) (if tmp1541 (apply (lambda (k1542 e11543 e21544) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1542)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11543 e21544)) rest1539)) tmp1541) ((lambda (_1547) (syntax-violation (quote case) "bad clause" x1513 clause1523)) tmp1540))) ($sc-dispatch tmp1540 (quote (each-any any . each-any))))) clause1523)) tmp1538)) (f1522 (car clauses1524) (cdr clauses1524))))))) tmp1515) (syntax-violation #f "source expression failed to match any pattern" tmp1514))) ($sc-dispatch tmp1514 (quote (any any any . each-any))))) x1513)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1548) ((lambda (tmp1549) ((lambda (tmp1550) (if tmp1550 (apply (lambda (_1551 e1552) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1552)) (list (cons _1551 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1552 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1550) (syntax-violation #f "source expression failed to match any pattern" tmp1549))) ($sc-dispatch tmp1549 (quote (any any))))) x1548)))) +(letrec ((and-map*1170 (lambda (f1210 first1209 . rest1208) (or (null? first1209) (if (null? rest1208) (let andmap1211 ((first1212 first1209)) (let ((x1213 (car first1212)) (first1214 (cdr first1212))) (if (null? first1214) (f1210 x1213) (and (f1210 x1213) (andmap1211 first1214))))) (let andmap1215 ((first1216 first1209) (rest1217 rest1208)) (let ((x1218 (car first1216)) (xr1219 (map car rest1217)) (first1220 (cdr first1216)) (rest1221 (map cdr rest1217))) (if (null? first1220) (apply f1210 (cons x1218 xr1219)) (and (apply f1210 (cons x1218 xr1219)) (andmap1215 first1220 rest1221)))))))))) (letrec ((lambda-var-list1308 (lambda (vars1484) (let lvl1485 ((vars1486 vars1484) (ls1487 (quote ())) (w1488 (quote (())))) (cond ((pair? vars1486) (lvl1485 (cdr vars1486) (cons (wrap1287 (car vars1486) w1488 #f) ls1487) w1488)) ((id?1259 vars1486) (cons (wrap1287 vars1486 w1488 #f) ls1487)) ((null? vars1486) ls1487) ((syntax-object?1243 vars1486) (lvl1485 (syntax-object-expression1244 vars1486) ls1487 (join-wraps1278 w1488 (syntax-object-wrap1245 vars1486)))) ((annotation? vars1486) (lvl1485 (annotation-expression vars1486) ls1487 w1488)) (else (cons vars1486 ls1487)))))) (gen-var1307 (lambda (id1489) (let ((id1490 (if (syntax-object?1243 id1489) (syntax-object-expression1244 id1489) id1489))) (if (annotation? id1490) (build-annotated1232 (annotation-source id1490) (gensym (symbol->string (annotation-expression id1490)))) (build-annotated1232 #f (gensym (symbol->string id1490))))))) (strip1306 (lambda (x1491 w1492) (if (memq (quote top) (wrap-marks1262 w1492)) (if (or (annotation? x1491) (and (pair? x1491) (annotation? (car x1491)))) (strip-annotation1305 x1491 #f) x1491) (let f1493 ((x1494 x1491)) (cond ((syntax-object?1243 x1494) (strip1306 (syntax-object-expression1244 x1494) (syntax-object-wrap1245 x1494))) ((pair? x1494) (let ((a1495 (f1493 (car x1494))) (d1496 (f1493 (cdr x1494)))) (if (and (eq? a1495 (car x1494)) (eq? d1496 (cdr x1494))) x1494 (cons a1495 d1496)))) ((vector? x1494) (let ((old1497 (vector->list x1494))) (let ((new1498 (map f1493 old1497))) (if (and-map*1170 eq? old1497 new1498) x1494 (list->vector new1498))))) (else x1494)))))) (strip-annotation1305 (lambda (x1499 parent1500) (cond ((pair? x1499) (let ((new1501 (cons #f #f))) (begin (if parent1500 (set-annotation-stripped! parent1500 new1501)) (set-car! new1501 (strip-annotation1305 (car x1499) #f)) (set-cdr! new1501 (strip-annotation1305 (cdr x1499) #f)) new1501))) ((annotation? x1499) (or (annotation-stripped x1499) (strip-annotation1305 (annotation-expression x1499) x1499))) ((vector? x1499) (let ((new1502 (make-vector (vector-length x1499)))) (begin (if parent1500 (set-annotation-stripped! parent1500 new1502)) (let loop1503 ((i1504 (- (vector-length x1499) 1))) (unless (fx<1227 i1504 0) (vector-set! new1502 i1504 (strip-annotation1305 (vector-ref x1499 i1504) #f)) (loop1503 (fx-1225 i1504 1)))) new1502))) (else x1499)))) (ellipsis?1304 (lambda (x1505) (and (nonsymbol-id?1258 x1505) (free-id=?1282 x1505 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1303 (lambda () (build-annotated1232 #f (cons (build-annotated1232 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer1302 (lambda (expanded1506 mod1507) (let ((p1508 (local-eval-hook1229 expanded1506 mod1507))) (if (procedure? p1508) p1508 (syntax-violation #f "nonprocedure transformer" p1508))))) (chi-local-syntax1301 (lambda (rec?1509 e1510 r1511 w1512 s1513 mod1514 k1515) ((lambda (tmp1516) ((lambda (tmp1517) (if tmp1517 (apply (lambda (_1518 id1519 val1520 e11521 e21522) (let ((ids1523 id1519)) (if (not (valid-bound-ids?1284 ids1523)) (syntax-violation #f "duplicate bound keyword" e1510) (let ((labels1525 (gen-labels1265 ids1523))) (let ((new-w1526 (make-binding-wrap1276 ids1523 labels1525 w1512))) (k1515 (cons e11521 e21522) (extend-env1253 labels1525 (let ((w1528 (if rec?1509 new-w1526 w1512)) (trans-r1529 (macros-only-env1255 r1511))) (map (lambda (x1530) (cons (quote macro) (eval-local-transformer1302 (chi1295 x1530 trans-r1529 w1528 mod1514) mod1514))) val1520)) r1511) new-w1526 s1513 mod1514)))))) tmp1517) ((lambda (_1532) (syntax-violation #f "bad local syntax definition" (source-wrap1288 e1510 w1512 s1513 mod1514))) tmp1516))) ($sc-dispatch tmp1516 (quote (any #(each (any any)) any . each-any))))) e1510))) (chi-lambda-clause1300 (lambda (e1533 docstring1534 c1535 r1536 w1537 mod1538 k1539) ((lambda (tmp1540) ((lambda (tmp1541) (if (if tmp1541 (apply (lambda (args1542 doc1543 e11544 e21545) (and (string? (syntax->datum doc1543)) (not docstring1534))) tmp1541) #f) (apply (lambda (args1546 doc1547 e11548 e21549) (chi-lambda-clause1300 e1533 doc1547 (cons args1546 (cons e11548 e21549)) r1536 w1537 mod1538 k1539)) tmp1541) ((lambda (tmp1551) (if tmp1551 (apply (lambda (id1552 e11553 e21554) (let ((ids1555 id1552)) (if (not (valid-bound-ids?1284 ids1555)) (syntax-violation (quote lambda) "invalid parameter list" e1533) (let ((labels1557 (gen-labels1265 ids1555)) (new-vars1558 (map gen-var1307 ids1555))) (k1539 new-vars1558 docstring1534 (chi-body1299 (cons e11553 e21554) e1533 (extend-var-env1254 labels1557 new-vars1558 r1536) (make-binding-wrap1276 ids1555 labels1557 w1537) mod1538)))))) tmp1551) ((lambda (tmp1560) (if tmp1560 (apply (lambda (ids1561 e11562 e21563) (let ((old-ids1564 (lambda-var-list1308 ids1561))) (if (not (valid-bound-ids?1284 old-ids1564)) (syntax-violation (quote lambda) "invalid parameter list" e1533) (let ((labels1565 (gen-labels1265 old-ids1564)) (new-vars1566 (map gen-var1307 old-ids1564))) (k1539 (let f1567 ((ls11568 (cdr new-vars1566)) (ls21569 (car new-vars1566))) (if (null? ls11568) ls21569 (f1567 (cdr ls11568) (cons (car ls11568) ls21569)))) docstring1534 (chi-body1299 (cons e11562 e21563) e1533 (extend-var-env1254 labels1565 new-vars1566 r1536) (make-binding-wrap1276 old-ids1564 labels1565 w1537) mod1538)))))) tmp1560) ((lambda (_1571) (syntax-violation (quote lambda) "bad lambda" e1533)) tmp1540))) ($sc-dispatch tmp1540 (quote (any any . each-any)))))) ($sc-dispatch tmp1540 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1540 (quote (any any any . each-any))))) c1535))) (chi-body1299 (lambda (body1572 outer-form1573 r1574 w1575 mod1576) (let ((r1577 (cons (quote ("placeholder" placeholder)) r1574))) (let ((ribcage1578 (make-ribcage1266 (quote ()) (quote ()) (quote ())))) (let ((w1579 (make-wrap1261 (wrap-marks1262 w1575) (cons ribcage1578 (wrap-subst1263 w1575))))) (let parse1580 ((body1581 (map (lambda (x1587) (cons r1577 (wrap1287 x1587 w1579 mod1576))) body1572)) (ids1582 (quote ())) (labels1583 (quote ())) (vars1584 (quote ())) (vals1585 (quote ())) (bindings1586 (quote ()))) (if (null? body1581) (syntax-violation #f "no expressions in body" outer-form1573) (let ((e1588 (cdar body1581)) (er1589 (caar body1581))) (call-with-values (lambda () (syntax-type1293 e1588 er1589 (quote (())) #f ribcage1578 mod1576)) (lambda (type1590 value1591 e1592 w1593 s1594 mod1595) (let ((t1596 type1590)) (if (memv t1596 (quote (define-form))) (let ((id1597 (wrap1287 value1591 w1593 mod1595)) (label1598 (gen-label1264))) (let ((var1599 (gen-var1307 id1597))) (begin (extend-ribcage!1275 ribcage1578 id1597 label1598) (parse1580 (cdr body1581) (cons id1597 ids1582) (cons label1598 labels1583) (cons var1599 vars1584) (cons (cons er1589 (wrap1287 e1592 w1593 mod1595)) vals1585) (cons (cons (quote lexical) var1599) bindings1586))))) (if (memv t1596 (quote (define-syntax-form))) (let ((id1600 (wrap1287 value1591 w1593 mod1595)) (label1601 (gen-label1264))) (begin (extend-ribcage!1275 ribcage1578 id1600 label1601) (parse1580 (cdr body1581) (cons id1600 ids1582) (cons label1601 labels1583) vars1584 vals1585 (cons (cons (quote macro) (cons er1589 (wrap1287 e1592 w1593 mod1595))) bindings1586)))) (if (memv t1596 (quote (begin-form))) ((lambda (tmp1602) ((lambda (tmp1603) (if tmp1603 (apply (lambda (_1604 e11605) (parse1580 (let f1606 ((forms1607 e11605)) (if (null? forms1607) (cdr body1581) (cons (cons er1589 (wrap1287 (car forms1607) w1593 mod1595)) (f1606 (cdr forms1607))))) ids1582 labels1583 vars1584 vals1585 bindings1586)) tmp1603) (syntax-violation #f "source expression failed to match any pattern" tmp1602))) ($sc-dispatch tmp1602 (quote (any . each-any))))) e1592) (if (memv t1596 (quote (local-syntax-form))) (chi-local-syntax1301 value1591 e1592 er1589 w1593 s1594 mod1595 (lambda (forms1609 er1610 w1611 s1612 mod1613) (parse1580 (let f1614 ((forms1615 forms1609)) (if (null? forms1615) (cdr body1581) (cons (cons er1610 (wrap1287 (car forms1615) w1611 mod1613)) (f1614 (cdr forms1615))))) ids1582 labels1583 vars1584 vals1585 bindings1586))) (if (null? ids1582) (build-sequence1238 #f (map (lambda (x1616) (chi1295 (cdr x1616) (car x1616) (quote (())) mod1595)) (cons (cons er1589 (source-wrap1288 e1592 w1593 s1594 mod1595)) (cdr body1581)))) (begin (if (not (valid-bound-ids?1284 ids1582)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1573)) (let loop1617 ((bs1618 bindings1586) (er-cache1619 #f) (r-cache1620 #f)) (if (not (null? bs1618)) (let ((b1621 (car bs1618))) (if (eq? (car b1621) (quote macro)) (let ((er1622 (cadr b1621))) (let ((r-cache1623 (if (eq? er1622 er-cache1619) r-cache1620 (macros-only-env1255 er1622)))) (begin (set-cdr! b1621 (eval-local-transformer1302 (chi1295 (cddr b1621) r-cache1623 (quote (())) mod1595) mod1595)) (loop1617 (cdr bs1618) er1622 r-cache1623)))) (loop1617 (cdr bs1618) er-cache1619 r-cache1620))))) (set-cdr! r1577 (extend-env1253 labels1583 bindings1586 (cdr r1577))) (build-letrec1241 #f vars1584 (map (lambda (x1624) (chi1295 (cdr x1624) (car x1624) (quote (())) mod1595)) vals1585) (build-sequence1238 #f (map (lambda (x1625) (chi1295 (cdr x1625) (car x1625) (quote (())) mod1595)) (cons (cons er1589 (source-wrap1288 e1592 w1593 s1594 mod1595)) (cdr body1581)))))))))))))))))))))) (chi-macro1298 (lambda (p1626 e1627 r1628 w1629 rib1630 mod1631) (letrec ((rebuild-macro-output1632 (lambda (x1633 m1634) (cond ((pair? x1633) (cons (rebuild-macro-output1632 (car x1633) m1634) (rebuild-macro-output1632 (cdr x1633) m1634))) ((syntax-object?1243 x1633) (let ((w1635 (syntax-object-wrap1245 x1633))) (let ((ms1636 (wrap-marks1262 w1635)) (s1637 (wrap-subst1263 w1635))) (if (and (pair? ms1636) (eq? (car ms1636) #f)) (make-syntax-object1242 (syntax-object-expression1244 x1633) (make-wrap1261 (cdr ms1636) (if rib1630 (cons rib1630 (cdr s1637)) (cdr s1637))) (syntax-object-module1246 x1633)) (make-syntax-object1242 (syntax-object-expression1244 x1633) (make-wrap1261 (cons m1634 ms1636) (if rib1630 (cons rib1630 (cons (quote shift) s1637)) (cons (quote shift) s1637))) (let ((pmod1638 (procedure-module p1626))) (if pmod1638 (cons (quote hygiene) (module-name pmod1638)) (quote (hygiene guile))))))))) ((vector? x1633) (let ((n1639 (vector-length x1633))) (let ((v1640 (make-vector n1639))) (let doloop1641 ((i1642 0)) (if (fx=1226 i1642 n1639) v1640 (begin (vector-set! v1640 i1642 (rebuild-macro-output1632 (vector-ref x1633 i1642) m1634)) (doloop1641 (fx+1224 i1642 1)))))))) ((symbol? x1633) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1288 e1627 w1629 s mod1631) x1633)) (else x1633))))) (rebuild-macro-output1632 (p1626 (wrap1287 e1627 (anti-mark1274 w1629) mod1631)) (string #\m))))) (chi-application1297 (lambda (x1643 e1644 r1645 w1646 s1647 mod1648) ((lambda (tmp1649) ((lambda (tmp1650) (if tmp1650 (apply (lambda (e01651 e11652) (build-annotated1232 s1647 (cons x1643 (map (lambda (e1653) (chi1295 e1653 r1645 w1646 mod1648)) e11652)))) tmp1650) (syntax-violation #f "source expression failed to match any pattern" tmp1649))) ($sc-dispatch tmp1649 (quote (any . each-any))))) e1644))) (chi-expr1296 (lambda (type1655 value1656 e1657 r1658 w1659 s1660 mod1661) (let ((t1662 type1655)) (if (memv t1662 (quote (lexical))) (build-lexical-reference1233 (quote value) s1660 e1657 value1656) (if (memv t1662 (quote (core external-macro))) (value1656 e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (module-ref))) (call-with-values (lambda () (value1656 e1657)) (lambda (id1663 mod1664) (build-global-reference1235 s1660 id1663 mod1664))) (if (memv t1662 (quote (lexical-call))) (chi-application1297 (build-lexical-reference1233 (quote fun) (source-annotation1250 (car e1657)) (car e1657) value1656) e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (global-call))) (chi-application1297 (build-global-reference1235 (source-annotation1250 (car e1657)) value1656 (if (syntax-object?1243 (car e1657)) (syntax-object-module1246 (car e1657)) mod1661)) e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (constant))) (build-data1237 s1660 (strip1306 (source-wrap1288 e1657 w1659 s1660 mod1661) (quote (())))) (if (memv t1662 (quote (global))) (build-global-reference1235 s1660 value1656 mod1661) (if (memv t1662 (quote (call))) (chi-application1297 (chi1295 (car e1657) r1658 w1659 mod1661) e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (begin-form))) ((lambda (tmp1665) ((lambda (tmp1666) (if tmp1666 (apply (lambda (_1667 e11668 e21669) (chi-sequence1289 (cons e11668 e21669) r1658 w1659 s1660 mod1661)) tmp1666) (syntax-violation #f "source expression failed to match any pattern" tmp1665))) ($sc-dispatch tmp1665 (quote (any any . each-any))))) e1657) (if (memv t1662 (quote (local-syntax-form))) (chi-local-syntax1301 value1656 e1657 r1658 w1659 s1660 mod1661 chi-sequence1289) (if (memv t1662 (quote (eval-when-form))) ((lambda (tmp1671) ((lambda (tmp1672) (if tmp1672 (apply (lambda (_1673 x1674 e11675 e21676) (let ((when-list1677 (chi-when-list1292 e1657 x1674 w1659))) (if (memq (quote eval) when-list1677) (chi-sequence1289 (cons e11675 e21676) r1658 w1659 s1660 mod1661) (chi-void1303)))) tmp1672) (syntax-violation #f "source expression failed to match any pattern" tmp1671))) ($sc-dispatch tmp1671 (quote (any each-any any . each-any))))) e1657) (if (memv t1662 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1657 (wrap1287 value1656 w1659 mod1661)) (if (memv t1662 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1288 e1657 w1659 s1660 mod1661)) (if (memv t1662 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1288 e1657 w1659 s1660 mod1661)) (syntax-violation #f "unexpected syntax" (source-wrap1288 e1657 w1659 s1660 mod1661))))))))))))))))))) (chi1295 (lambda (e1680 r1681 w1682 mod1683) (call-with-values (lambda () (syntax-type1293 e1680 r1681 w1682 #f #f mod1683)) (lambda (type1684 value1685 e1686 w1687 s1688 mod1689) (chi-expr1296 type1684 value1685 e1686 r1681 w1687 s1688 mod1689))))) (chi-top1294 (lambda (e1690 r1691 w1692 m1693 esew1694 mod1695) (call-with-values (lambda () (syntax-type1293 e1690 r1691 w1692 #f #f mod1695)) (lambda (type1703 value1704 e1705 w1706 s1707 mod1708) (let ((t1709 type1703)) (if (memv t1709 (quote (begin-form))) ((lambda (tmp1710) ((lambda (tmp1711) (if tmp1711 (apply (lambda (_1712) (chi-void1303)) tmp1711) ((lambda (tmp1713) (if tmp1713 (apply (lambda (_1714 e11715 e21716) (chi-top-sequence1290 (cons e11715 e21716) r1691 w1706 s1707 m1693 esew1694 mod1708)) tmp1713) (syntax-violation #f "source expression failed to match any pattern" tmp1710))) ($sc-dispatch tmp1710 (quote (any any . each-any)))))) ($sc-dispatch tmp1710 (quote (any))))) e1705) (if (memv t1709 (quote (local-syntax-form))) (chi-local-syntax1301 value1704 e1705 r1691 w1706 s1707 mod1708 (lambda (body1718 r1719 w1720 s1721 mod1722) (chi-top-sequence1290 body1718 r1719 w1720 s1721 m1693 esew1694 mod1722))) (if (memv t1709 (quote (eval-when-form))) ((lambda (tmp1723) ((lambda (tmp1724) (if tmp1724 (apply (lambda (_1725 x1726 e11727 e21728) (let ((when-list1729 (chi-when-list1292 e1705 x1726 w1706)) (body1730 (cons e11727 e21728))) (cond ((eq? m1693 (quote e)) (if (memq (quote eval) when-list1729) (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote e) (quote (eval)) mod1708) (chi-void1303))) ((memq (quote load) when-list1729) (if (or (memq (quote compile) when-list1729) (and (eq? m1693 (quote c&e)) (memq (quote eval) when-list1729))) (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote c&e) (quote (compile load)) mod1708) (if (memq m1693 (quote (c c&e))) (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote c) (quote (load)) mod1708) (chi-void1303)))) ((or (memq (quote compile) when-list1729) (and (eq? m1693 (quote c&e)) (memq (quote eval) when-list1729))) (top-level-eval-hook1228 (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote e) (quote (eval)) mod1708) mod1708) (chi-void1303)) (else (chi-void1303))))) tmp1724) (syntax-violation #f "source expression failed to match any pattern" tmp1723))) ($sc-dispatch tmp1723 (quote (any each-any any . each-any))))) e1705) (if (memv t1709 (quote (define-syntax-form))) (let ((n1733 (id-var-name1281 value1704 w1706)) (r1734 (macros-only-env1255 r1691))) (let ((t1735 m1693)) (if (memv t1735 (quote (c))) (if (memq (quote compile) esew1694) (let ((e1736 (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)))) (begin (top-level-eval-hook1228 e1736 mod1708) (if (memq (quote load) esew1694) e1736 (chi-void1303)))) (if (memq (quote load) esew1694) (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)) (chi-void1303))) (if (memv t1735 (quote (c&e))) (let ((e1737 (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)))) (begin (top-level-eval-hook1228 e1737 mod1708) e1737)) (begin (if (memq (quote eval) esew1694) (top-level-eval-hook1228 (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)) mod1708)) (chi-void1303)))))) (if (memv t1709 (quote (define-form))) (let ((n1738 (id-var-name1281 value1704 w1706))) (let ((type1739 (binding-type1251 (lookup1256 n1738 r1691 mod1708)))) (let ((t1740 type1739)) (if (memv t1740 (quote (global core macro module-ref))) (let ((x1741 (build-annotated1232 s1707 (list (quote define) n1738 (chi1295 e1705 r1691 w1706 mod1708))))) (begin (if (eq? m1693 (quote c&e)) (top-level-eval-hook1228 x1741 mod1708)) x1741)) (if (memv t1740 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1705 (wrap1287 value1704 w1706 mod1708)) (syntax-violation #f "cannot define keyword at top level" e1705 (wrap1287 value1704 w1706 mod1708))))))) (let ((x1742 (chi-expr1296 type1703 value1704 e1705 r1691 w1706 s1707 mod1708))) (begin (if (eq? m1693 (quote c&e)) (top-level-eval-hook1228 x1742 mod1708)) x1742)))))))))))) (syntax-type1293 (lambda (e1743 r1744 w1745 s1746 rib1747 mod1748) (cond ((symbol? e1743) (let ((n1749 (id-var-name1281 e1743 w1745))) (let ((b1750 (lookup1256 n1749 r1744 mod1748))) (let ((type1751 (binding-type1251 b1750))) (let ((t1752 type1751)) (if (memv t1752 (quote (lexical))) (values type1751 (binding-value1252 b1750) e1743 w1745 s1746 mod1748) (if (memv t1752 (quote (global))) (values type1751 n1749 e1743 w1745 s1746 mod1748) (if (memv t1752 (quote (macro))) (syntax-type1293 (chi-macro1298 (binding-value1252 b1750) e1743 r1744 w1745 rib1747 mod1748) r1744 (quote (())) s1746 rib1747 mod1748) (values type1751 (binding-value1252 b1750) e1743 w1745 s1746 mod1748))))))))) ((pair? e1743) (let ((first1753 (car e1743))) (if (id?1259 first1753) (let ((n1754 (id-var-name1281 first1753 w1745))) (let ((b1755 (lookup1256 n1754 r1744 (or (and (syntax-object?1243 first1753) (syntax-object-module1246 first1753)) mod1748)))) (let ((type1756 (binding-type1251 b1755))) (let ((t1757 type1756)) (if (memv t1757 (quote (lexical))) (values (quote lexical-call) (binding-value1252 b1755) e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (global))) (values (quote global-call) n1754 e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (macro))) (syntax-type1293 (chi-macro1298 (binding-value1252 b1755) e1743 r1744 w1745 rib1747 mod1748) r1744 (quote (())) s1746 rib1747 mod1748) (if (memv t1757 (quote (core external-macro module-ref))) (values type1756 (binding-value1252 b1755) e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1252 b1755) e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (begin))) (values (quote begin-form) #f e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (eval-when))) (values (quote eval-when-form) #f e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (define))) ((lambda (tmp1758) ((lambda (tmp1759) (if (if tmp1759 (apply (lambda (_1760 name1761 val1762) (id?1259 name1761)) tmp1759) #f) (apply (lambda (_1763 name1764 val1765) (values (quote define-form) name1764 val1765 w1745 s1746 mod1748)) tmp1759) ((lambda (tmp1766) (if (if tmp1766 (apply (lambda (_1767 name1768 args1769 e11770 e21771) (and (id?1259 name1768) (valid-bound-ids?1284 (lambda-var-list1308 args1769)))) tmp1766) #f) (apply (lambda (_1772 name1773 args1774 e11775 e21776) (values (quote define-form) (wrap1287 name1773 w1745 mod1748) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1287 (cons args1774 (cons e11775 e21776)) w1745 mod1748)) (quote (())) s1746 mod1748)) tmp1766) ((lambda (tmp1778) (if (if tmp1778 (apply (lambda (_1779 name1780) (id?1259 name1780)) tmp1778) #f) (apply (lambda (_1781 name1782) (values (quote define-form) (wrap1287 name1782 w1745 mod1748) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1746 mod1748)) tmp1778) (syntax-violation #f "source expression failed to match any pattern" tmp1758))) ($sc-dispatch tmp1758 (quote (any any)))))) ($sc-dispatch tmp1758 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1758 (quote (any any any))))) e1743) (if (memv t1757 (quote (define-syntax))) ((lambda (tmp1783) ((lambda (tmp1784) (if (if tmp1784 (apply (lambda (_1785 name1786 val1787) (id?1259 name1786)) tmp1784) #f) (apply (lambda (_1788 name1789 val1790) (values (quote define-syntax-form) name1789 val1790 w1745 s1746 mod1748)) tmp1784) (syntax-violation #f "source expression failed to match any pattern" tmp1783))) ($sc-dispatch tmp1783 (quote (any any any))))) e1743) (values (quote call) #f e1743 w1745 s1746 mod1748)))))))))))))) (values (quote call) #f e1743 w1745 s1746 mod1748)))) ((syntax-object?1243 e1743) (syntax-type1293 (syntax-object-expression1244 e1743) r1744 (join-wraps1278 w1745 (syntax-object-wrap1245 e1743)) #f rib1747 (or (syntax-object-module1246 e1743) mod1748))) ((annotation? e1743) (syntax-type1293 (annotation-expression e1743) r1744 w1745 (annotation-source e1743) rib1747 mod1748)) ((self-evaluating? e1743) (values (quote constant) #f e1743 w1745 s1746 mod1748)) (else (values (quote other) #f e1743 w1745 s1746 mod1748))))) (chi-when-list1292 (lambda (e1791 when-list1792 w1793) (let f1794 ((when-list1795 when-list1792) (situations1796 (quote ()))) (if (null? when-list1795) situations1796 (f1794 (cdr when-list1795) (cons (let ((x1797 (car when-list1795))) (cond ((free-id=?1282 x1797 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1282 x1797 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1282 x1797 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1791 (wrap1287 x1797 w1793 #f))))) situations1796)))))) (chi-install-global1291 (lambda (name1798 e1799) (build-annotated1232 #f (list (build-annotated1232 #f (quote define)) name1798 (if (let ((v1800 (module-variable (current-module) name1798))) (and v1800 (variable-bound? v1800) (macro? (variable-ref v1800)) (not (eq? (macro-type (variable-ref v1800)) (quote syncase-macro))))) (build-annotated1232 #f (list (build-annotated1232 #f (quote make-extended-syncase-macro)) (build-annotated1232 #f (list (build-annotated1232 #f (quote module-ref)) (build-annotated1232 #f (quote (current-module))) (build-data1237 #f name1798))) (build-data1237 #f (quote macro)) e1799)) (build-annotated1232 #f (list (build-annotated1232 #f (quote make-syncase-macro)) (build-data1237 #f (quote macro)) e1799))))))) (chi-top-sequence1290 (lambda (body1801 r1802 w1803 s1804 m1805 esew1806 mod1807) (build-sequence1238 s1804 (let dobody1808 ((body1809 body1801) (r1810 r1802) (w1811 w1803) (m1812 m1805) (esew1813 esew1806) (mod1814 mod1807)) (if (null? body1809) (quote ()) (let ((first1815 (chi-top1294 (car body1809) r1810 w1811 m1812 esew1813 mod1814))) (cons first1815 (dobody1808 (cdr body1809) r1810 w1811 m1812 esew1813 mod1814)))))))) (chi-sequence1289 (lambda (body1816 r1817 w1818 s1819 mod1820) (build-sequence1238 s1819 (let dobody1821 ((body1822 body1816) (r1823 r1817) (w1824 w1818) (mod1825 mod1820)) (if (null? body1822) (quote ()) (let ((first1826 (chi1295 (car body1822) r1823 w1824 mod1825))) (cons first1826 (dobody1821 (cdr body1822) r1823 w1824 mod1825)))))))) (source-wrap1288 (lambda (x1827 w1828 s1829 defmod1830) (wrap1287 (if s1829 (make-annotation x1827 s1829 #f) x1827) w1828 defmod1830))) (wrap1287 (lambda (x1831 w1832 defmod1833) (cond ((and (null? (wrap-marks1262 w1832)) (null? (wrap-subst1263 w1832))) x1831) ((syntax-object?1243 x1831) (make-syntax-object1242 (syntax-object-expression1244 x1831) (join-wraps1278 w1832 (syntax-object-wrap1245 x1831)) (syntax-object-module1246 x1831))) ((null? x1831) x1831) (else (make-syntax-object1242 x1831 w1832 defmod1833))))) (bound-id-member?1286 (lambda (x1834 list1835) (and (not (null? list1835)) (or (bound-id=?1283 x1834 (car list1835)) (bound-id-member?1286 x1834 (cdr list1835)))))) (distinct-bound-ids?1285 (lambda (ids1836) (let distinct?1837 ((ids1838 ids1836)) (or (null? ids1838) (and (not (bound-id-member?1286 (car ids1838) (cdr ids1838))) (distinct?1837 (cdr ids1838))))))) (valid-bound-ids?1284 (lambda (ids1839) (and (let all-ids?1840 ((ids1841 ids1839)) (or (null? ids1841) (and (id?1259 (car ids1841)) (all-ids?1840 (cdr ids1841))))) (distinct-bound-ids?1285 ids1839)))) (bound-id=?1283 (lambda (i1842 j1843) (if (and (syntax-object?1243 i1842) (syntax-object?1243 j1843)) (and (eq? (let ((e1844 (syntax-object-expression1244 i1842))) (if (annotation? e1844) (annotation-expression e1844) e1844)) (let ((e1845 (syntax-object-expression1244 j1843))) (if (annotation? e1845) (annotation-expression e1845) e1845))) (same-marks?1280 (wrap-marks1262 (syntax-object-wrap1245 i1842)) (wrap-marks1262 (syntax-object-wrap1245 j1843)))) (eq? (let ((e1846 i1842)) (if (annotation? e1846) (annotation-expression e1846) e1846)) (let ((e1847 j1843)) (if (annotation? e1847) (annotation-expression e1847) e1847)))))) (free-id=?1282 (lambda (i1848 j1849) (and (eq? (let ((x1850 i1848)) (let ((e1851 (if (syntax-object?1243 x1850) (syntax-object-expression1244 x1850) x1850))) (if (annotation? e1851) (annotation-expression e1851) e1851))) (let ((x1852 j1849)) (let ((e1853 (if (syntax-object?1243 x1852) (syntax-object-expression1244 x1852) x1852))) (if (annotation? e1853) (annotation-expression e1853) e1853)))) (eq? (id-var-name1281 i1848 (quote (()))) (id-var-name1281 j1849 (quote (()))))))) (id-var-name1281 (lambda (id1854 w1855) (letrec ((search-vector-rib1858 (lambda (sym1864 subst1865 marks1866 symnames1867 ribcage1868) (let ((n1869 (vector-length symnames1867))) (let f1870 ((i1871 0)) (cond ((fx=1226 i1871 n1869) (search1856 sym1864 (cdr subst1865) marks1866)) ((and (eq? (vector-ref symnames1867 i1871) sym1864) (same-marks?1280 marks1866 (vector-ref (ribcage-marks1269 ribcage1868) i1871))) (values (vector-ref (ribcage-labels1270 ribcage1868) i1871) marks1866)) (else (f1870 (fx+1224 i1871 1)))))))) (search-list-rib1857 (lambda (sym1872 subst1873 marks1874 symnames1875 ribcage1876) (let f1877 ((symnames1878 symnames1875) (i1879 0)) (cond ((null? symnames1878) (search1856 sym1872 (cdr subst1873) marks1874)) ((and (eq? (car symnames1878) sym1872) (same-marks?1280 marks1874 (list-ref (ribcage-marks1269 ribcage1876) i1879))) (values (list-ref (ribcage-labels1270 ribcage1876) i1879) marks1874)) (else (f1877 (cdr symnames1878) (fx+1224 i1879 1))))))) (search1856 (lambda (sym1880 subst1881 marks1882) (if (null? subst1881) (values #f marks1882) (let ((fst1883 (car subst1881))) (if (eq? fst1883 (quote shift)) (search1856 sym1880 (cdr subst1881) (cdr marks1882)) (let ((symnames1884 (ribcage-symnames1268 fst1883))) (if (vector? symnames1884) (search-vector-rib1858 sym1880 subst1881 marks1882 symnames1884 fst1883) (search-list-rib1857 sym1880 subst1881 marks1882 symnames1884 fst1883))))))))) (cond ((symbol? id1854) (or (call-with-values (lambda () (search1856 id1854 (wrap-subst1263 w1855) (wrap-marks1262 w1855))) (lambda (x1886 . ignore1885) x1886)) id1854)) ((syntax-object?1243 id1854) (let ((id1887 (let ((e1889 (syntax-object-expression1244 id1854))) (if (annotation? e1889) (annotation-expression e1889) e1889))) (w11888 (syntax-object-wrap1245 id1854))) (let ((marks1890 (join-marks1279 (wrap-marks1262 w1855) (wrap-marks1262 w11888)))) (call-with-values (lambda () (search1856 id1887 (wrap-subst1263 w1855) marks1890)) (lambda (new-id1891 marks1892) (or new-id1891 (call-with-values (lambda () (search1856 id1887 (wrap-subst1263 w11888) marks1892)) (lambda (x1894 . ignore1893) x1894)) id1887)))))) ((annotation? id1854) (let ((id1895 (let ((e1896 id1854)) (if (annotation? e1896) (annotation-expression e1896) e1896)))) (or (call-with-values (lambda () (search1856 id1895 (wrap-subst1263 w1855) (wrap-marks1262 w1855))) (lambda (x1898 . ignore1897) x1898)) id1895))) (else (syntax-violation (quote id-var-name) "invalid id" id1854)))))) (same-marks?1280 (lambda (x1899 y1900) (or (eq? x1899 y1900) (and (not (null? x1899)) (not (null? y1900)) (eq? (car x1899) (car y1900)) (same-marks?1280 (cdr x1899) (cdr y1900)))))) (join-marks1279 (lambda (m11901 m21902) (smart-append1277 m11901 m21902))) (join-wraps1278 (lambda (w11903 w21904) (let ((m11905 (wrap-marks1262 w11903)) (s11906 (wrap-subst1263 w11903))) (if (null? m11905) (if (null? s11906) w21904 (make-wrap1261 (wrap-marks1262 w21904) (smart-append1277 s11906 (wrap-subst1263 w21904)))) (make-wrap1261 (smart-append1277 m11905 (wrap-marks1262 w21904)) (smart-append1277 s11906 (wrap-subst1263 w21904))))))) (smart-append1277 (lambda (m11907 m21908) (if (null? m21908) m11907 (append m11907 m21908)))) (make-binding-wrap1276 (lambda (ids1909 labels1910 w1911) (if (null? ids1909) w1911 (make-wrap1261 (wrap-marks1262 w1911) (cons (let ((labelvec1912 (list->vector labels1910))) (let ((n1913 (vector-length labelvec1912))) (let ((symnamevec1914 (make-vector n1913)) (marksvec1915 (make-vector n1913))) (begin (let f1916 ((ids1917 ids1909) (i1918 0)) (if (not (null? ids1917)) (call-with-values (lambda () (id-sym-name&marks1260 (car ids1917) w1911)) (lambda (symname1919 marks1920) (begin (vector-set! symnamevec1914 i1918 symname1919) (vector-set! marksvec1915 i1918 marks1920) (f1916 (cdr ids1917) (fx+1224 i1918 1))))))) (make-ribcage1266 symnamevec1914 marksvec1915 labelvec1912))))) (wrap-subst1263 w1911)))))) (extend-ribcage!1275 (lambda (ribcage1921 id1922 label1923) (begin (set-ribcage-symnames!1271 ribcage1921 (cons (let ((e1924 (syntax-object-expression1244 id1922))) (if (annotation? e1924) (annotation-expression e1924) e1924)) (ribcage-symnames1268 ribcage1921))) (set-ribcage-marks!1272 ribcage1921 (cons (wrap-marks1262 (syntax-object-wrap1245 id1922)) (ribcage-marks1269 ribcage1921))) (set-ribcage-labels!1273 ribcage1921 (cons label1923 (ribcage-labels1270 ribcage1921)))))) (anti-mark1274 (lambda (w1925) (make-wrap1261 (cons #f (wrap-marks1262 w1925)) (cons (quote shift) (wrap-subst1263 w1925))))) (set-ribcage-labels!1273 (lambda (x1926 update1927) (vector-set! x1926 3 update1927))) (set-ribcage-marks!1272 (lambda (x1928 update1929) (vector-set! x1928 2 update1929))) (set-ribcage-symnames!1271 (lambda (x1930 update1931) (vector-set! x1930 1 update1931))) (ribcage-labels1270 (lambda (x1932) (vector-ref x1932 3))) (ribcage-marks1269 (lambda (x1933) (vector-ref x1933 2))) (ribcage-symnames1268 (lambda (x1934) (vector-ref x1934 1))) (ribcage?1267 (lambda (x1935) (and (vector? x1935) (= (vector-length x1935) 4) (eq? (vector-ref x1935 0) (quote ribcage))))) (make-ribcage1266 (lambda (symnames1936 marks1937 labels1938) (vector (quote ribcage) symnames1936 marks1937 labels1938))) (gen-labels1265 (lambda (ls1939) (if (null? ls1939) (quote ()) (cons (gen-label1264) (gen-labels1265 (cdr ls1939)))))) (gen-label1264 (lambda () (string #\i))) (wrap-subst1263 cdr) (wrap-marks1262 car) (make-wrap1261 cons) (id-sym-name&marks1260 (lambda (x1940 w1941) (if (syntax-object?1243 x1940) (values (let ((e1942 (syntax-object-expression1244 x1940))) (if (annotation? e1942) (annotation-expression e1942) e1942)) (join-marks1279 (wrap-marks1262 w1941) (wrap-marks1262 (syntax-object-wrap1245 x1940)))) (values (let ((e1943 x1940)) (if (annotation? e1943) (annotation-expression e1943) e1943)) (wrap-marks1262 w1941))))) (id?1259 (lambda (x1944) (cond ((symbol? x1944) #t) ((syntax-object?1243 x1944) (symbol? (let ((e1945 (syntax-object-expression1244 x1944))) (if (annotation? e1945) (annotation-expression e1945) e1945)))) ((annotation? x1944) (symbol? (annotation-expression x1944))) (else #f)))) (nonsymbol-id?1258 (lambda (x1946) (and (syntax-object?1243 x1946) (symbol? (let ((e1947 (syntax-object-expression1244 x1946))) (if (annotation? e1947) (annotation-expression e1947) e1947)))))) (global-extend1257 (lambda (type1948 sym1949 val1950) (put-global-definition-hook1230 sym1949 type1948 val1950))) (lookup1256 (lambda (x1951 r1952 mod1953) (cond ((assq x1951 r1952) => cdr) ((symbol? x1951) (or (get-global-definition-hook1231 x1951 mod1953) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1255 (lambda (r1954) (if (null? r1954) (quote ()) (let ((a1955 (car r1954))) (if (eq? (cadr a1955) (quote macro)) (cons a1955 (macros-only-env1255 (cdr r1954))) (macros-only-env1255 (cdr r1954))))))) (extend-var-env1254 (lambda (labels1956 vars1957 r1958) (if (null? labels1956) r1958 (extend-var-env1254 (cdr labels1956) (cdr vars1957) (cons (cons (car labels1956) (cons (quote lexical) (car vars1957))) r1958))))) (extend-env1253 (lambda (labels1959 bindings1960 r1961) (if (null? labels1959) r1961 (extend-env1253 (cdr labels1959) (cdr bindings1960) (cons (cons (car labels1959) (car bindings1960)) r1961))))) (binding-value1252 cdr) (binding-type1251 car) (source-annotation1250 (lambda (x1962) (cond ((annotation? x1962) (annotation-source x1962)) ((syntax-object?1243 x1962) (source-annotation1250 (syntax-object-expression1244 x1962))) (else #f)))) (set-syntax-object-module!1249 (lambda (x1963 update1964) (vector-set! x1963 3 update1964))) (set-syntax-object-wrap!1248 (lambda (x1965 update1966) (vector-set! x1965 2 update1966))) (set-syntax-object-expression!1247 (lambda (x1967 update1968) (vector-set! x1967 1 update1968))) (syntax-object-module1246 (lambda (x1969) (vector-ref x1969 3))) (syntax-object-wrap1245 (lambda (x1970) (vector-ref x1970 2))) (syntax-object-expression1244 (lambda (x1971) (vector-ref x1971 1))) (syntax-object?1243 (lambda (x1972) (and (vector? x1972) (= (vector-length x1972) 4) (eq? (vector-ref x1972 0) (quote syntax-object))))) (make-syntax-object1242 (lambda (expression1973 wrap1974 module1975) (vector (quote syntax-object) expression1973 wrap1974 module1975))) (build-letrec1241 (lambda (src1976 vars1977 val-exps1978 body-exp1979) (if (null? vars1977) (build-annotated1232 src1976 body-exp1979) (build-annotated1232 src1976 (list (quote letrec) (map list vars1977 val-exps1978) body-exp1979))))) (build-named-let1240 (lambda (src1980 vars1981 val-exps1982 body-exp1983) (if (null? vars1981) (build-annotated1232 src1980 body-exp1983) (build-annotated1232 src1980 (list (quote let) (car vars1981) (map list (cdr vars1981) val-exps1982) body-exp1983))))) (build-let1239 (lambda (src1984 vars1985 val-exps1986 body-exp1987) (if (null? vars1985) (build-annotated1232 src1984 body-exp1987) (build-annotated1232 src1984 (list (quote let) (map list vars1985 val-exps1986) body-exp1987))))) (build-sequence1238 (lambda (src1988 exps1989) (if (null? (cdr exps1989)) (build-annotated1232 src1988 (car exps1989)) (build-annotated1232 src1988 (cons (quote begin) exps1989))))) (build-data1237 (lambda (src1990 exp1991) (if (and (self-evaluating? exp1991) (not (vector? exp1991))) (build-annotated1232 src1990 exp1991) (build-annotated1232 src1990 (list (quote quote) exp1991))))) (build-global-assignment1236 (lambda (source1992 var1993 exp1994 mod1995) (let ((ref1996 (build-global-reference1235 source1992 var1993 mod1995))) (build-annotated1232 source1992 (list (quote set!) ref1996 exp1994))))) (build-global-reference1235 (lambda (source1997 var1998 mod1999) (build-annotated1232 source1997 (if (not mod1999) var1998 (let ((make-module-ref2000 (let ((t2003 (fluid-ref *mode*1223))) (if (memv t2003 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (mod2004 var2005 public?2006) (list (if public?2006 (quote @) (quote @@)) mod2004 var2005))))) (kind2001 (car mod1999)) (mod2002 (cdr mod1999))) (let ((t2007 kind2001)) (if (memv t2007 (quote (public))) (make-module-ref2000 mod2002 var1998 #t) (if (memv t2007 (quote (private))) (if (not (equal? mod2002 (module-name (current-module)))) (make-module-ref2000 mod2002 var1998 #f) var1998) (if (memv t2007 (quote (bare))) var1998 (if (memv t2007 (quote (hygiene))) (if (and (not (equal? mod2002 (module-name (current-module)))) (module-variable (resolve-module mod2002) var1998)) (make-module-ref2000 mod2002 var1998 #f) var1998) (syntax-violation #f "bad module kind" var1998 mod2002))))))))))) (build-lexical-assignment1234 (lambda (source2008 name2009 var2010 exp2011) (build-annotated1232 source2008 (list (quote set!) (build-lexical-reference1233 (quote set) #f name2009 var2010) exp2011)))) (build-lexical-reference1233 (lambda (type2012 source2013 name2014 var2015) (build-annotated1232 source2013 (let ((t2016 (fluid-ref *mode*1223))) (if (memv t2016 (quote (c))) ((@ (ice-9 expand-support) make-lexical) name2014 var2015) var2015))))) (build-annotated1232 (lambda (src2017 exp2018) (if (and src2017 (not (annotation? exp2018))) (make-annotation exp2018 src2017 #t) exp2018))) (get-global-definition-hook1231 (lambda (symbol2019 module2020) (begin (if (and (not module2020) (current-module)) (warn "module system is booted, we should have a module" symbol2019)) (let ((v2021 (module-variable (if module2020 (resolve-module (cdr module2020)) (current-module)) symbol2019))) (and v2021 (variable-bound? v2021) (let ((val2022 (variable-ref v2021))) (and (macro? val2022) (syncase-macro-type val2022) (cons (syncase-macro-type val2022) (syncase-macro-binding val2022))))))))) (put-global-definition-hook1230 (lambda (symbol2023 type2024 val2025) (let ((existing2026 (let ((v2027 (module-variable (current-module) symbol2023))) (and v2027 (variable-bound? v2027) (let ((val2028 (variable-ref v2027))) (and (macro? val2028) (not (syncase-macro-type val2028)) val2028)))))) (module-define! (current-module) symbol2023 (if existing2026 (make-extended-syncase-macro existing2026 type2024 val2025) (make-syncase-macro type2024 val2025)))))) (local-eval-hook1229 (lambda (x2029 mod2030) (primitive-eval (list noexpand1222 (let ((t2031 (fluid-ref *mode*1223))) (if (memv t2031 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x2029) x2029)))))) (top-level-eval-hook1228 (lambda (x2032 mod2033) (primitive-eval (list noexpand1222 (let ((t2034 (fluid-ref *mode*1223))) (if (memv t2034 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x2032) x2032)))))) (fx<1227 <) (fx=1226 =) (fx-1225 -) (fx+1224 +) (*mode*1223 (make-fluid)) (noexpand1222 "noexpand")) (begin (global-extend1257 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1257 (quote local-syntax) (quote let-syntax) #f) (global-extend1257 (quote core) (quote fluid-let-syntax) (lambda (e2035 r2036 w2037 s2038 mod2039) ((lambda (tmp2040) ((lambda (tmp2041) (if (if tmp2041 (apply (lambda (_2042 var2043 val2044 e12045 e22046) (valid-bound-ids?1284 var2043)) tmp2041) #f) (apply (lambda (_2048 var2049 val2050 e12051 e22052) (let ((names2053 (map (lambda (x2054) (id-var-name1281 x2054 w2037)) var2049))) (begin (for-each (lambda (id2056 n2057) (let ((t2058 (binding-type1251 (lookup1256 n2057 r2036 mod2039)))) (if (memv t2058 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2035 (source-wrap1288 id2056 w2037 s2038 mod2039))))) var2049 names2053) (chi-body1299 (cons e12051 e22052) (source-wrap1288 e2035 w2037 s2038 mod2039) (extend-env1253 names2053 (let ((trans-r2061 (macros-only-env1255 r2036))) (map (lambda (x2062) (cons (quote macro) (eval-local-transformer1302 (chi1295 x2062 trans-r2061 w2037 mod2039) mod2039))) val2050)) r2036) w2037 mod2039)))) tmp2041) ((lambda (_2064) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1288 e2035 w2037 s2038 mod2039))) tmp2040))) ($sc-dispatch tmp2040 (quote (any #(each (any any)) any . each-any))))) e2035))) (global-extend1257 (quote core) (quote quote) (lambda (e2065 r2066 w2067 s2068 mod2069) ((lambda (tmp2070) ((lambda (tmp2071) (if tmp2071 (apply (lambda (_2072 e2073) (build-data1237 s2068 (strip1306 e2073 w2067))) tmp2071) ((lambda (_2074) (syntax-violation (quote quote) "bad syntax" (source-wrap1288 e2065 w2067 s2068 mod2069))) tmp2070))) ($sc-dispatch tmp2070 (quote (any any))))) e2065))) (global-extend1257 (quote core) (quote syntax) (letrec ((regen2082 (lambda (x2083) (let ((t2084 (car x2083))) (if (memv t2084 (quote (ref))) (build-lexical-reference1233 (quote value) #f (cadr x2083) (cadr x2083)) (if (memv t2084 (quote (primitive))) (build-annotated1232 #f (cadr x2083)) (if (memv t2084 (quote (quote))) (build-data1237 #f (cadr x2083)) (if (memv t2084 (quote (lambda))) (build-annotated1232 #f (list (quote lambda) (cadr x2083) (regen2082 (caddr x2083)))) (if (memv t2084 (quote (map))) (let ((ls2085 (map regen2082 (cdr x2083)))) (build-annotated1232 #f (cons (if (fx=1226 (length ls2085) 2) (build-annotated1232 #f (quote map)) (build-annotated1232 #f (quote map))) ls2085))) (build-annotated1232 #f (cons (build-annotated1232 #f (car x2083)) (map regen2082 (cdr x2083)))))))))))) (gen-vector2081 (lambda (x2086) (cond ((eq? (car x2086) (quote list)) (cons (quote vector) (cdr x2086))) ((eq? (car x2086) (quote quote)) (list (quote quote) (list->vector (cadr x2086)))) (else (list (quote list->vector) x2086))))) (gen-append2080 (lambda (x2087 y2088) (if (equal? y2088 (quote (quote ()))) x2087 (list (quote append) x2087 y2088)))) (gen-cons2079 (lambda (x2089 y2090) (let ((t2091 (car y2090))) (if (memv t2091 (quote (quote))) (if (eq? (car x2089) (quote quote)) (list (quote quote) (cons (cadr x2089) (cadr y2090))) (if (eq? (cadr y2090) (quote ())) (list (quote list) x2089) (list (quote cons) x2089 y2090))) (if (memv t2091 (quote (list))) (cons (quote list) (cons x2089 (cdr y2090))) (list (quote cons) x2089 y2090)))))) (gen-map2078 (lambda (e2092 map-env2093) (let ((formals2094 (map cdr map-env2093)) (actuals2095 (map (lambda (x2096) (list (quote ref) (car x2096))) map-env2093))) (cond ((eq? (car e2092) (quote ref)) (car actuals2095)) ((and-map (lambda (x2097) (and (eq? (car x2097) (quote ref)) (memq (cadr x2097) formals2094))) (cdr e2092)) (cons (quote map) (cons (list (quote primitive) (car e2092)) (map (let ((r2098 (map cons formals2094 actuals2095))) (lambda (x2099) (cdr (assq (cadr x2099) r2098)))) (cdr e2092))))) (else (cons (quote map) (cons (list (quote lambda) formals2094 e2092) actuals2095))))))) (gen-mappend2077 (lambda (e2100 map-env2101) (list (quote apply) (quote (primitive append)) (gen-map2078 e2100 map-env2101)))) (gen-ref2076 (lambda (src2102 var2103 level2104 maps2105) (if (fx=1226 level2104 0) (values var2103 maps2105) (if (null? maps2105) (syntax-violation (quote syntax) "missing ellipsis" src2102) (call-with-values (lambda () (gen-ref2076 src2102 var2103 (fx-1225 level2104 1) (cdr maps2105))) (lambda (outer-var2106 outer-maps2107) (let ((b2108 (assq outer-var2106 (car maps2105)))) (if b2108 (values (cdr b2108) maps2105) (let ((inner-var2109 (gen-var1307 (quote tmp)))) (values inner-var2109 (cons (cons (cons outer-var2106 inner-var2109) (car maps2105)) outer-maps2107))))))))))) (gen-syntax2075 (lambda (src2110 e2111 r2112 maps2113 ellipsis?2114 mod2115) (if (id?1259 e2111) (let ((label2116 (id-var-name1281 e2111 (quote (()))))) (let ((b2117 (lookup1256 label2116 r2112 mod2115))) (if (eq? (binding-type1251 b2117) (quote syntax)) (call-with-values (lambda () (let ((var.lev2118 (binding-value1252 b2117))) (gen-ref2076 src2110 (car var.lev2118) (cdr var.lev2118) maps2113))) (lambda (var2119 maps2120) (values (list (quote ref) var2119) maps2120))) (if (ellipsis?2114 e2111) (syntax-violation (quote syntax) "misplaced ellipsis" src2110) (values (list (quote quote) e2111) maps2113))))) ((lambda (tmp2121) ((lambda (tmp2122) (if (if tmp2122 (apply (lambda (dots2123 e2124) (ellipsis?2114 dots2123)) tmp2122) #f) (apply (lambda (dots2125 e2126) (gen-syntax2075 src2110 e2126 r2112 maps2113 (lambda (x2127) #f) mod2115)) tmp2122) ((lambda (tmp2128) (if (if tmp2128 (apply (lambda (x2129 dots2130 y2131) (ellipsis?2114 dots2130)) tmp2128) #f) (apply (lambda (x2132 dots2133 y2134) (let f2135 ((y2136 y2134) (k2137 (lambda (maps2138) (call-with-values (lambda () (gen-syntax2075 src2110 x2132 r2112 (cons (quote ()) maps2138) ellipsis?2114 mod2115)) (lambda (x2139 maps2140) (if (null? (car maps2140)) (syntax-violation (quote syntax) "extra ellipsis" src2110) (values (gen-map2078 x2139 (car maps2140)) (cdr maps2140)))))))) ((lambda (tmp2141) ((lambda (tmp2142) (if (if tmp2142 (apply (lambda (dots2143 y2144) (ellipsis?2114 dots2143)) tmp2142) #f) (apply (lambda (dots2145 y2146) (f2135 y2146 (lambda (maps2147) (call-with-values (lambda () (k2137 (cons (quote ()) maps2147))) (lambda (x2148 maps2149) (if (null? (car maps2149)) (syntax-violation (quote syntax) "extra ellipsis" src2110) (values (gen-mappend2077 x2148 (car maps2149)) (cdr maps2149)))))))) tmp2142) ((lambda (_2150) (call-with-values (lambda () (gen-syntax2075 src2110 y2136 r2112 maps2113 ellipsis?2114 mod2115)) (lambda (y2151 maps2152) (call-with-values (lambda () (k2137 maps2152)) (lambda (x2153 maps2154) (values (gen-append2080 x2153 y2151) maps2154)))))) tmp2141))) ($sc-dispatch tmp2141 (quote (any . any))))) y2136))) tmp2128) ((lambda (tmp2155) (if tmp2155 (apply (lambda (x2156 y2157) (call-with-values (lambda () (gen-syntax2075 src2110 x2156 r2112 maps2113 ellipsis?2114 mod2115)) (lambda (x2158 maps2159) (call-with-values (lambda () (gen-syntax2075 src2110 y2157 r2112 maps2159 ellipsis?2114 mod2115)) (lambda (y2160 maps2161) (values (gen-cons2079 x2158 y2160) maps2161)))))) tmp2155) ((lambda (tmp2162) (if tmp2162 (apply (lambda (e12163 e22164) (call-with-values (lambda () (gen-syntax2075 src2110 (cons e12163 e22164) r2112 maps2113 ellipsis?2114 mod2115)) (lambda (e2166 maps2167) (values (gen-vector2081 e2166) maps2167)))) tmp2162) ((lambda (_2168) (values (list (quote quote) e2111) maps2113)) tmp2121))) ($sc-dispatch tmp2121 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2121 (quote (any . any)))))) ($sc-dispatch tmp2121 (quote (any any . any)))))) ($sc-dispatch tmp2121 (quote (any any))))) e2111))))) (lambda (e2169 r2170 w2171 s2172 mod2173) (let ((e2174 (source-wrap1288 e2169 w2171 s2172 mod2173))) ((lambda (tmp2175) ((lambda (tmp2176) (if tmp2176 (apply (lambda (_2177 x2178) (call-with-values (lambda () (gen-syntax2075 e2174 x2178 r2170 (quote ()) ellipsis?1304 mod2173)) (lambda (e2179 maps2180) (regen2082 e2179)))) tmp2176) ((lambda (_2181) (syntax-violation (quote syntax) "bad `syntax' form" e2174)) tmp2175))) ($sc-dispatch tmp2175 (quote (any any))))) e2174))))) (global-extend1257 (quote core) (quote lambda) (lambda (e2182 r2183 w2184 s2185 mod2186) ((lambda (tmp2187) ((lambda (tmp2188) (if tmp2188 (apply (lambda (_2189 c2190) (chi-lambda-clause1300 (source-wrap1288 e2182 w2184 s2185 mod2186) #f c2190 r2183 w2184 mod2186 (lambda (vars2191 docstring2192 body2193) (build-annotated1232 s2185 (cons (quote lambda) (cons vars2191 (append (if docstring2192 (list docstring2192) (quote ())) (list body2193)))))))) tmp2188) (syntax-violation #f "source expression failed to match any pattern" tmp2187))) ($sc-dispatch tmp2187 (quote (any . any))))) e2182))) (global-extend1257 (quote core) (quote let) (letrec ((chi-let2194 (lambda (e2195 r2196 w2197 s2198 mod2199 constructor2200 ids2201 vals2202 exps2203) (if (not (valid-bound-ids?1284 ids2201)) (syntax-violation (quote let) "duplicate bound variable" e2195) (let ((labels2204 (gen-labels1265 ids2201)) (new-vars2205 (map gen-var1307 ids2201))) (let ((nw2206 (make-binding-wrap1276 ids2201 labels2204 w2197)) (nr2207 (extend-var-env1254 labels2204 new-vars2205 r2196))) (constructor2200 s2198 new-vars2205 (map (lambda (x2208) (chi1295 x2208 r2196 w2197 mod2199)) vals2202) (chi-body1299 exps2203 (source-wrap1288 e2195 nw2206 s2198 mod2199) nr2207 nw2206 mod2199)))))))) (lambda (e2209 r2210 w2211 s2212 mod2213) ((lambda (tmp2214) ((lambda (tmp2215) (if tmp2215 (apply (lambda (_2216 id2217 val2218 e12219 e22220) (chi-let2194 e2209 r2210 w2211 s2212 mod2213 build-let1239 id2217 val2218 (cons e12219 e22220))) tmp2215) ((lambda (tmp2224) (if (if tmp2224 (apply (lambda (_2225 f2226 id2227 val2228 e12229 e22230) (id?1259 f2226)) tmp2224) #f) (apply (lambda (_2231 f2232 id2233 val2234 e12235 e22236) (chi-let2194 e2209 r2210 w2211 s2212 mod2213 build-named-let1240 (cons f2232 id2233) val2234 (cons e12235 e22236))) tmp2224) ((lambda (_2240) (syntax-violation (quote let) "bad let" (source-wrap1288 e2209 w2211 s2212 mod2213))) tmp2214))) ($sc-dispatch tmp2214 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2214 (quote (any #(each (any any)) any . each-any))))) e2209)))) (global-extend1257 (quote core) (quote letrec) (lambda (e2241 r2242 w2243 s2244 mod2245) ((lambda (tmp2246) ((lambda (tmp2247) (if tmp2247 (apply (lambda (_2248 id2249 val2250 e12251 e22252) (let ((ids2253 id2249)) (if (not (valid-bound-ids?1284 ids2253)) (syntax-violation (quote letrec) "duplicate bound variable" e2241) (let ((labels2255 (gen-labels1265 ids2253)) (new-vars2256 (map gen-var1307 ids2253))) (let ((w2257 (make-binding-wrap1276 ids2253 labels2255 w2243)) (r2258 (extend-var-env1254 labels2255 new-vars2256 r2242))) (build-letrec1241 s2244 new-vars2256 (map (lambda (x2259) (chi1295 x2259 r2258 w2257 mod2245)) val2250) (chi-body1299 (cons e12251 e22252) (source-wrap1288 e2241 w2257 s2244 mod2245) r2258 w2257 mod2245))))))) tmp2247) ((lambda (_2262) (syntax-violation (quote letrec) "bad letrec" (source-wrap1288 e2241 w2243 s2244 mod2245))) tmp2246))) ($sc-dispatch tmp2246 (quote (any #(each (any any)) any . each-any))))) e2241))) (global-extend1257 (quote core) (quote set!) (lambda (e2263 r2264 w2265 s2266 mod2267) ((lambda (tmp2268) ((lambda (tmp2269) (if (if tmp2269 (apply (lambda (_2270 id2271 val2272) (id?1259 id2271)) tmp2269) #f) (apply (lambda (_2273 id2274 val2275) (let ((val2276 (chi1295 val2275 r2264 w2265 mod2267)) (n2277 (id-var-name1281 id2274 w2265))) (let ((b2278 (lookup1256 n2277 r2264 mod2267))) (let ((t2279 (binding-type1251 b2278))) (if (memv t2279 (quote (lexical))) (build-lexical-assignment1234 s2266 (syntax->datum id2274) (binding-value1252 b2278) val2276) (if (memv t2279 (quote (global))) (build-global-assignment1236 s2266 n2277 val2276 mod2267) (if (memv t2279 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1287 id2274 w2265 mod2267)) (syntax-violation (quote set!) "bad set!" (source-wrap1288 e2263 w2265 s2266 mod2267))))))))) tmp2269) ((lambda (tmp2280) (if tmp2280 (apply (lambda (_2281 head2282 tail2283 val2284) (call-with-values (lambda () (syntax-type1293 head2282 r2264 (quote (())) #f #f mod2267)) (lambda (type2285 value2286 ee2287 ww2288 ss2289 modmod2290) (let ((t2291 type2285)) (if (memv t2291 (quote (module-ref))) (let ((val2292 (chi1295 val2284 r2264 w2265 mod2267))) (call-with-values (lambda () (value2286 (cons head2282 tail2283))) (lambda (id2294 mod2295) (build-global-assignment1236 s2266 id2294 val2292 mod2295)))) (build-annotated1232 s2266 (cons (chi1295 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2282) r2264 w2265 mod2267) (map (lambda (e2296) (chi1295 e2296 r2264 w2265 mod2267)) (append tail2283 (list val2284)))))))))) tmp2280) ((lambda (_2298) (syntax-violation (quote set!) "bad set!" (source-wrap1288 e2263 w2265 s2266 mod2267))) tmp2268))) ($sc-dispatch tmp2268 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2268 (quote (any any any))))) e2263))) (global-extend1257 (quote module-ref) (quote @) (lambda (e2299) ((lambda (tmp2300) ((lambda (tmp2301) (if (if tmp2301 (apply (lambda (_2302 mod2303 id2304) (and (and-map id?1259 mod2303) (id?1259 id2304))) tmp2301) #f) (apply (lambda (_2306 mod2307 id2308) (values (syntax->datum id2308) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2307)))) tmp2301) (syntax-violation #f "source expression failed to match any pattern" tmp2300))) ($sc-dispatch tmp2300 (quote (any each-any any))))) e2299))) (global-extend1257 (quote module-ref) (quote @@) (lambda (e2310) ((lambda (tmp2311) ((lambda (tmp2312) (if (if tmp2312 (apply (lambda (_2313 mod2314 id2315) (and (and-map id?1259 mod2314) (id?1259 id2315))) tmp2312) #f) (apply (lambda (_2317 mod2318 id2319) (values (syntax->datum id2319) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2318)))) tmp2312) (syntax-violation #f "source expression failed to match any pattern" tmp2311))) ($sc-dispatch tmp2311 (quote (any each-any any))))) e2310))) (global-extend1257 (quote begin) (quote begin) (quote ())) (global-extend1257 (quote define) (quote define) (quote ())) (global-extend1257 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1257 (quote eval-when) (quote eval-when) (quote ())) (global-extend1257 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2324 (lambda (x2325 keys2326 clauses2327 r2328 mod2329) (if (null? clauses2327) (build-annotated1232 #f (list (build-annotated1232 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2325)) ((lambda (tmp2330) ((lambda (tmp2331) (if tmp2331 (apply (lambda (pat2332 exp2333) (if (and (id?1259 pat2332) (and-map (lambda (x2334) (not (free-id=?1282 pat2332 x2334))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2326))) (let ((labels2335 (list (gen-label1264))) (var2336 (gen-var1307 pat2332))) (build-annotated1232 #f (list (build-annotated1232 #f (list (quote lambda) (list var2336) (chi1295 exp2333 (extend-env1253 labels2335 (list (cons (quote syntax) (cons var2336 0))) r2328) (make-binding-wrap1276 (list pat2332) labels2335 (quote (()))) mod2329))) x2325))) (gen-clause2323 x2325 keys2326 (cdr clauses2327) r2328 pat2332 #t exp2333 mod2329))) tmp2331) ((lambda (tmp2337) (if tmp2337 (apply (lambda (pat2338 fender2339 exp2340) (gen-clause2323 x2325 keys2326 (cdr clauses2327) r2328 pat2338 fender2339 exp2340 mod2329)) tmp2337) ((lambda (_2341) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2327))) tmp2330))) ($sc-dispatch tmp2330 (quote (any any any)))))) ($sc-dispatch tmp2330 (quote (any any))))) (car clauses2327))))) (gen-clause2323 (lambda (x2342 keys2343 clauses2344 r2345 pat2346 fender2347 exp2348 mod2349) (call-with-values (lambda () (convert-pattern2321 pat2346 keys2343)) (lambda (p2350 pvars2351) (cond ((not (distinct-bound-ids?1285 (map car pvars2351))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2346)) ((not (and-map (lambda (x2352) (not (ellipsis?1304 (car x2352)))) pvars2351)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2346)) (else (let ((y2353 (gen-var1307 (quote tmp)))) (build-annotated1232 #f (list (build-annotated1232 #f (list (quote lambda) (list y2353) (let ((y2354 (build-lexical-reference1233 (quote value) #f (quote tmp) y2353))) (build-annotated1232 #f (list (quote if) ((lambda (tmp2355) ((lambda (tmp2356) (if tmp2356 (apply (lambda () y2354) tmp2356) ((lambda (_2357) (build-annotated1232 #f (list (quote if) y2354 (build-dispatch-call2322 pvars2351 fender2347 y2354 r2345 mod2349) (build-data1237 #f #f)))) tmp2355))) ($sc-dispatch tmp2355 (quote #(atom #t))))) fender2347) (build-dispatch-call2322 pvars2351 exp2348 y2354 r2345 mod2349) (gen-syntax-case2324 x2342 keys2343 clauses2344 r2345 mod2349)))))) (if (eq? p2350 (quote any)) (build-annotated1232 #f (list (build-annotated1232 #f (quote list)) x2342)) (build-annotated1232 #f (list (build-annotated1232 #f (quote $sc-dispatch)) x2342 (build-data1237 #f p2350))))))))))))) (build-dispatch-call2322 (lambda (pvars2358 exp2359 y2360 r2361 mod2362) (let ((ids2363 (map car pvars2358)) (levels2364 (map cdr pvars2358))) (let ((labels2365 (gen-labels1265 ids2363)) (new-vars2366 (map gen-var1307 ids2363))) (build-annotated1232 #f (list (build-annotated1232 #f (quote apply)) (build-annotated1232 #f (list (quote lambda) new-vars2366 (chi1295 exp2359 (extend-env1253 labels2365 (map (lambda (var2367 level2368) (cons (quote syntax) (cons var2367 level2368))) new-vars2366 (map cdr pvars2358)) r2361) (make-binding-wrap1276 ids2363 labels2365 (quote (()))) mod2362))) y2360)))))) (convert-pattern2321 (lambda (pattern2369 keys2370) (let cvt2371 ((p2372 pattern2369) (n2373 0) (ids2374 (quote ()))) (if (id?1259 p2372) (if (bound-id-member?1286 p2372 keys2370) (values (vector (quote free-id) p2372) ids2374) (values (quote any) (cons (cons p2372 n2373) ids2374))) ((lambda (tmp2375) ((lambda (tmp2376) (if (if tmp2376 (apply (lambda (x2377 dots2378) (ellipsis?1304 dots2378)) tmp2376) #f) (apply (lambda (x2379 dots2380) (call-with-values (lambda () (cvt2371 x2379 (fx+1224 n2373 1) ids2374)) (lambda (p2381 ids2382) (values (if (eq? p2381 (quote any)) (quote each-any) (vector (quote each) p2381)) ids2382)))) tmp2376) ((lambda (tmp2383) (if tmp2383 (apply (lambda (x2384 y2385) (call-with-values (lambda () (cvt2371 y2385 n2373 ids2374)) (lambda (y2386 ids2387) (call-with-values (lambda () (cvt2371 x2384 n2373 ids2387)) (lambda (x2388 ids2389) (values (cons x2388 y2386) ids2389)))))) tmp2383) ((lambda (tmp2390) (if tmp2390 (apply (lambda () (values (quote ()) ids2374)) tmp2390) ((lambda (tmp2391) (if tmp2391 (apply (lambda (x2392) (call-with-values (lambda () (cvt2371 x2392 n2373 ids2374)) (lambda (p2394 ids2395) (values (vector (quote vector) p2394) ids2395)))) tmp2391) ((lambda (x2396) (values (vector (quote atom) (strip1306 p2372 (quote (())))) ids2374)) tmp2375))) ($sc-dispatch tmp2375 (quote #(vector each-any)))))) ($sc-dispatch tmp2375 (quote ()))))) ($sc-dispatch tmp2375 (quote (any . any)))))) ($sc-dispatch tmp2375 (quote (any any))))) p2372)))))) (lambda (e2397 r2398 w2399 s2400 mod2401) (let ((e2402 (source-wrap1288 e2397 w2399 s2400 mod2401))) ((lambda (tmp2403) ((lambda (tmp2404) (if tmp2404 (apply (lambda (_2405 val2406 key2407 m2408) (if (and-map (lambda (x2409) (and (id?1259 x2409) (not (ellipsis?1304 x2409)))) key2407) (let ((x2411 (gen-var1307 (quote tmp)))) (build-annotated1232 s2400 (list (build-annotated1232 #f (list (quote lambda) (list x2411) (gen-syntax-case2324 (build-lexical-reference1233 (quote value) #f (quote tmp) x2411) key2407 m2408 r2398 mod2401))) (chi1295 val2406 r2398 (quote (())) mod2401)))) (syntax-violation (quote syntax-case) "invalid literals list" e2402))) tmp2404) (syntax-violation #f "source expression failed to match any pattern" tmp2403))) ($sc-dispatch tmp2403 (quote (any any each-any . each-any))))) e2402))))) (set! sc-expand (lambda (x2415 . rest2414) (if (and (pair? x2415) (equal? (car x2415) noexpand1222)) (cadr x2415) (let ((m2416 (if (null? rest2414) (quote e) (car rest2414))) (esew2417 (if (or (null? rest2414) (null? (cdr rest2414))) (quote (eval)) (cadr rest2414)))) (with-fluid* *mode*1223 m2416 (lambda () (chi-top1294 x2415 (quote ()) (quote ((top))) m2416 esew2417 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x2418) (nonsymbol-id?1258 x2418))) (set! datum->syntax (lambda (id2419 datum2420) (make-syntax-object1242 datum2420 (syntax-object-wrap1245 id2419) #f))) (set! syntax->datum (lambda (x2421) (strip1306 x2421 (quote (()))))) (set! generate-temporaries (lambda (ls2422) (begin (let ((x2423 ls2422)) (if (not (list? x2423)) (syntax-violation (quote generate-temporaries) "invalid argument" x2423))) (map (lambda (x2424) (wrap1287 (gensym) (quote ((top))) #f)) ls2422)))) (set! free-identifier=? (lambda (x2425 y2426) (begin (let ((x2427 x2425)) (if (not (nonsymbol-id?1258 x2427)) (syntax-violation (quote free-identifier=?) "invalid argument" x2427))) (let ((x2428 y2426)) (if (not (nonsymbol-id?1258 x2428)) (syntax-violation (quote free-identifier=?) "invalid argument" x2428))) (free-id=?1282 x2425 y2426)))) (set! bound-identifier=? (lambda (x2429 y2430) (begin (let ((x2431 x2429)) (if (not (nonsymbol-id?1258 x2431)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2431))) (let ((x2432 y2430)) (if (not (nonsymbol-id?1258 x2432)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2432))) (bound-id=?1283 x2429 y2430)))) (set! syntax-violation (lambda (who2436 message2435 form2434 . subform2433) (begin (let ((x2437 who2436)) (if (not ((lambda (x2438) (or (not x2438) (string? x2438) (symbol? x2438))) x2437)) (syntax-violation (quote syntax-violation) "invalid argument" x2437))) (let ((x2439 message2435)) (if (not (string? x2439)) (syntax-violation (quote syntax-violation) "invalid argument" x2439))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2436 "~a: " "") "~a " (if (null? subform2433) "in ~a" "in subform `~s' of `~s'")) (let ((tail2440 (cons message2435 (map (lambda (x2441) (strip1306 x2441 (quote (())))) (append subform2433 (list form2434)))))) (if who2436 (cons who2436 tail2440) tail2440)) #f)))) (letrec ((match2446 (lambda (e2447 p2448 w2449 r2450 mod2451) (cond ((not r2450) #f) ((eq? p2448 (quote any)) (cons (wrap1287 e2447 w2449 mod2451) r2450)) ((syntax-object?1243 e2447) (match*2445 (let ((e2452 (syntax-object-expression1244 e2447))) (if (annotation? e2452) (annotation-expression e2452) e2452)) p2448 (join-wraps1278 w2449 (syntax-object-wrap1245 e2447)) r2450 (syntax-object-module1246 e2447))) (else (match*2445 (let ((e2453 e2447)) (if (annotation? e2453) (annotation-expression e2453) e2453)) p2448 w2449 r2450 mod2451))))) (match*2445 (lambda (e2454 p2455 w2456 r2457 mod2458) (cond ((null? p2455) (and (null? e2454) r2457)) ((pair? p2455) (and (pair? e2454) (match2446 (car e2454) (car p2455) w2456 (match2446 (cdr e2454) (cdr p2455) w2456 r2457 mod2458) mod2458))) ((eq? p2455 (quote each-any)) (let ((l2459 (match-each-any2443 e2454 w2456 mod2458))) (and l2459 (cons l2459 r2457)))) (else (let ((t2460 (vector-ref p2455 0))) (if (memv t2460 (quote (each))) (if (null? e2454) (match-empty2444 (vector-ref p2455 1) r2457) (let ((l2461 (match-each2442 e2454 (vector-ref p2455 1) w2456 mod2458))) (and l2461 (let collect2462 ((l2463 l2461)) (if (null? (car l2463)) r2457 (cons (map car l2463) (collect2462 (map cdr l2463)))))))) (if (memv t2460 (quote (free-id))) (and (id?1259 e2454) (free-id=?1282 (wrap1287 e2454 w2456 mod2458) (vector-ref p2455 1)) r2457) (if (memv t2460 (quote (atom))) (and (equal? (vector-ref p2455 1) (strip1306 e2454 w2456)) r2457) (if (memv t2460 (quote (vector))) (and (vector? e2454) (match2446 (vector->list e2454) (vector-ref p2455 1) w2456 r2457 mod2458))))))))))) (match-empty2444 (lambda (p2464 r2465) (cond ((null? p2464) r2465) ((eq? p2464 (quote any)) (cons (quote ()) r2465)) ((pair? p2464) (match-empty2444 (car p2464) (match-empty2444 (cdr p2464) r2465))) ((eq? p2464 (quote each-any)) (cons (quote ()) r2465)) (else (let ((t2466 (vector-ref p2464 0))) (if (memv t2466 (quote (each))) (match-empty2444 (vector-ref p2464 1) r2465) (if (memv t2466 (quote (free-id atom))) r2465 (if (memv t2466 (quote (vector))) (match-empty2444 (vector-ref p2464 1) r2465))))))))) (match-each-any2443 (lambda (e2467 w2468 mod2469) (cond ((annotation? e2467) (match-each-any2443 (annotation-expression e2467) w2468 mod2469)) ((pair? e2467) (let ((l2470 (match-each-any2443 (cdr e2467) w2468 mod2469))) (and l2470 (cons (wrap1287 (car e2467) w2468 mod2469) l2470)))) ((null? e2467) (quote ())) ((syntax-object?1243 e2467) (match-each-any2443 (syntax-object-expression1244 e2467) (join-wraps1278 w2468 (syntax-object-wrap1245 e2467)) mod2469)) (else #f)))) (match-each2442 (lambda (e2471 p2472 w2473 mod2474) (cond ((annotation? e2471) (match-each2442 (annotation-expression e2471) p2472 w2473 mod2474)) ((pair? e2471) (let ((first2475 (match2446 (car e2471) p2472 w2473 (quote ()) mod2474))) (and first2475 (let ((rest2476 (match-each2442 (cdr e2471) p2472 w2473 mod2474))) (and rest2476 (cons first2475 rest2476)))))) ((null? e2471) (quote ())) ((syntax-object?1243 e2471) (match-each2442 (syntax-object-expression1244 e2471) p2472 (join-wraps1278 w2473 (syntax-object-wrap1245 e2471)) (syntax-object-module1246 e2471))) (else #f))))) (set! $sc-dispatch (lambda (e2477 p2478) (cond ((eq? p2478 (quote any)) (list e2477)) ((syntax-object?1243 e2477) (match*2445 (let ((e2479 (syntax-object-expression1244 e2477))) (if (annotation? e2479) (annotation-expression e2479) e2479)) p2478 (syntax-object-wrap1245 e2477) (quote ()) (syntax-object-module1246 e2477))) (else (match*2445 (let ((e2480 e2477)) (if (annotation? e2480) (annotation-expression e2480) e2480)) p2478 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (_2484 e12485 e22486) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12485 e22486))) tmp2483) ((lambda (tmp2488) (if tmp2488 (apply (lambda (_2489 out2490 in2491 e12492 e22493) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2491 (quote ()) (list out2490 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12492 e22493))))) tmp2488) ((lambda (tmp2495) (if tmp2495 (apply (lambda (_2496 out2497 in2498 e12499 e22500) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2498) (quote ()) (list out2497 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12499 e22500))))) tmp2495) (syntax-violation #f "source expression failed to match any pattern" tmp2482))) ($sc-dispatch tmp2482 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2482 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2482 (quote (any () any . each-any))))) x2481)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2504) ((lambda (tmp2505) ((lambda (tmp2506) (if tmp2506 (apply (lambda (_2507 k2508 keyword2509 pattern2510 template2511) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2508 (map (lambda (tmp2514 tmp2513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2514))) template2511 pattern2510)))))) tmp2506) (syntax-violation #f "source expression failed to match any pattern" tmp2505))) ($sc-dispatch tmp2505 (quote (any each-any . #(each ((any . any) any))))))) x2504)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2515) ((lambda (tmp2516) ((lambda (tmp2517) (if (if tmp2517 (apply (lambda (let*2518 x2519 v2520 e12521 e22522) (and-map identifier? x2519)) tmp2517) #f) (apply (lambda (let*2524 x2525 v2526 e12527 e22528) (let f2529 ((bindings2530 (map list x2525 v2526))) (if (null? bindings2530) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12527 e22528))) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (body2536 binding2537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2537) body2536)) tmp2535) (syntax-violation #f "source expression failed to match any pattern" tmp2534))) ($sc-dispatch tmp2534 (quote (any any))))) (list (f2529 (cdr bindings2530)) (car bindings2530)))))) tmp2517) (syntax-violation #f "source expression failed to match any pattern" tmp2516))) ($sc-dispatch tmp2516 (quote (any #(each (any any)) any . each-any))))) x2515)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2538) ((lambda (tmp2539) ((lambda (tmp2540) (if tmp2540 (apply (lambda (_2541 var2542 init2543 step2544 e02545 e12546 c2547) ((lambda (tmp2548) ((lambda (tmp2549) (if tmp2549 (apply (lambda (step2550) ((lambda (tmp2551) ((lambda (tmp2552) (if tmp2552 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2542 init2543) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02545) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2550))))))) tmp2552) ((lambda (tmp2557) (if tmp2557 (apply (lambda (e12558 e22559) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2542 init2543) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02545 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12558 e22559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2550))))))) tmp2557) (syntax-violation #f "source expression failed to match any pattern" tmp2551))) ($sc-dispatch tmp2551 (quote (any . each-any)))))) ($sc-dispatch tmp2551 (quote ())))) e12546)) tmp2549) (syntax-violation #f "source expression failed to match any pattern" tmp2548))) ($sc-dispatch tmp2548 (quote each-any)))) (map (lambda (v2566 s2567) ((lambda (tmp2568) ((lambda (tmp2569) (if tmp2569 (apply (lambda () v2566) tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (e2571) e2571) tmp2570) ((lambda (_2572) (syntax-violation (quote do) "bad step expression" orig-x2538 s2567)) tmp2568))) ($sc-dispatch tmp2568 (quote (any)))))) ($sc-dispatch tmp2568 (quote ())))) s2567)) var2542 step2544))) tmp2540) (syntax-violation #f "source expression failed to match any pattern" tmp2539))) ($sc-dispatch tmp2539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2538)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2575 (lambda (x2579 y2580) ((lambda (tmp2581) ((lambda (tmp2582) (if tmp2582 (apply (lambda (x2583 y2584) ((lambda (tmp2585) ((lambda (tmp2586) (if tmp2586 (apply (lambda (dy2587) ((lambda (tmp2588) ((lambda (tmp2589) (if tmp2589 (apply (lambda (dx2590) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2590 dy2587))) tmp2589) ((lambda (_2591) (if (null? dy2587) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2583) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2583 y2584))) tmp2588))) ($sc-dispatch tmp2588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2583)) tmp2586) ((lambda (tmp2592) (if tmp2592 (apply (lambda (stuff2593) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2583 stuff2593))) tmp2592) ((lambda (else2594) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2583 y2584)) tmp2585))) ($sc-dispatch tmp2585 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2584)) tmp2582) (syntax-violation #f "source expression failed to match any pattern" tmp2581))) ($sc-dispatch tmp2581 (quote (any any))))) (list x2579 y2580)))) (quasiappend2576 (lambda (x2595 y2596) ((lambda (tmp2597) ((lambda (tmp2598) (if tmp2598 (apply (lambda (x2599 y2600) ((lambda (tmp2601) ((lambda (tmp2602) (if tmp2602 (apply (lambda () x2599) tmp2602) ((lambda (_2603) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2599 y2600)) tmp2601))) ($sc-dispatch tmp2601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2600)) tmp2598) (syntax-violation #f "source expression failed to match any pattern" tmp2597))) ($sc-dispatch tmp2597 (quote (any any))))) (list x2595 y2596)))) (quasivector2577 (lambda (x2604) ((lambda (tmp2605) ((lambda (x2606) ((lambda (tmp2607) ((lambda (tmp2608) (if tmp2608 (apply (lambda (x2609) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2609))) tmp2608) ((lambda (tmp2611) (if tmp2611 (apply (lambda (x2612) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2612)) tmp2611) ((lambda (_2614) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2606)) tmp2607))) ($sc-dispatch tmp2607 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2606)) tmp2605)) x2604))) (quasi2578 (lambda (p2615 lev2616) ((lambda (tmp2617) ((lambda (tmp2618) (if tmp2618 (apply (lambda (p2619) (if (= lev2616 0) p2619 (quasicons2575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2578 (list p2619) (- lev2616 1))))) tmp2618) ((lambda (tmp2620) (if tmp2620 (apply (lambda (p2621 q2622) (if (= lev2616 0) (quasiappend2576 p2621 (quasi2578 q2622 lev2616)) (quasicons2575 (quasicons2575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2578 (list p2621) (- lev2616 1))) (quasi2578 q2622 lev2616)))) tmp2620) ((lambda (tmp2623) (if tmp2623 (apply (lambda (p2624) (quasicons2575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2578 (list p2624) (+ lev2616 1)))) tmp2623) ((lambda (tmp2625) (if tmp2625 (apply (lambda (p2626 q2627) (quasicons2575 (quasi2578 p2626 lev2616) (quasi2578 q2627 lev2616))) tmp2625) ((lambda (tmp2628) (if tmp2628 (apply (lambda (x2629) (quasivector2577 (quasi2578 x2629 lev2616))) tmp2628) ((lambda (p2631) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2631)) tmp2617))) ($sc-dispatch tmp2617 (quote #(vector each-any)))))) ($sc-dispatch tmp2617 (quote (any . any)))))) ($sc-dispatch tmp2617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2615)))) (lambda (x2632) ((lambda (tmp2633) ((lambda (tmp2634) (if tmp2634 (apply (lambda (_2635 e2636) (quasi2578 e2636 0)) tmp2634) (syntax-violation #f "source expression failed to match any pattern" tmp2633))) ($sc-dispatch tmp2633 (quote (any any))))) x2632))))) +(define include (make-syncase-macro (quote macro) (lambda (x2637) (letrec ((read-file2638 (lambda (fn2639 k2640) (let ((p2641 (open-input-file fn2639))) (let f2642 ((x2643 (read p2641))) (if (eof-object? x2643) (begin (close-input-port p2641) (quote ())) (cons (datum->syntax k2640 x2643) (f2642 (read p2641))))))))) ((lambda (tmp2644) ((lambda (tmp2645) (if tmp2645 (apply (lambda (k2646 filename2647) (let ((fn2648 (syntax->datum filename2647))) ((lambda (tmp2649) ((lambda (tmp2650) (if tmp2650 (apply (lambda (exp2651) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2651)) tmp2650) (syntax-violation #f "source expression failed to match any pattern" tmp2649))) ($sc-dispatch tmp2649 (quote each-any)))) (read-file2638 fn2648 k2646)))) tmp2645) (syntax-violation #f "source expression failed to match any pattern" tmp2644))) ($sc-dispatch tmp2644 (quote (any any))))) x2637))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2653) ((lambda (tmp2654) ((lambda (tmp2655) (if tmp2655 (apply (lambda (_2656 e2657) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2653)) tmp2655) (syntax-violation #f "source expression failed to match any pattern" tmp2654))) ($sc-dispatch tmp2654 (quote (any any))))) x2653)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2658) ((lambda (tmp2659) ((lambda (tmp2660) (if tmp2660 (apply (lambda (_2661 e2662) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2658)) tmp2660) (syntax-violation #f "source expression failed to match any pattern" tmp2659))) ($sc-dispatch tmp2659 (quote (any any))))) x2658)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2663) ((lambda (tmp2664) ((lambda (tmp2665) (if tmp2665 (apply (lambda (_2666 e2667 m12668 m22669) ((lambda (tmp2670) ((lambda (body2671) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2667)) body2671)) tmp2670)) (let f2672 ((clause2673 m12668) (clauses2674 m22669)) (if (null? clauses2674) ((lambda (tmp2676) ((lambda (tmp2677) (if tmp2677 (apply (lambda (e12678 e22679) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12678 e22679))) tmp2677) ((lambda (tmp2681) (if tmp2681 (apply (lambda (k2682 e12683 e22684) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2682)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12683 e22684)))) tmp2681) ((lambda (_2687) (syntax-violation (quote case) "bad clause" x2663 clause2673)) tmp2676))) ($sc-dispatch tmp2676 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2676 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2673) ((lambda (tmp2688) ((lambda (rest2689) ((lambda (tmp2690) ((lambda (tmp2691) (if tmp2691 (apply (lambda (k2692 e12693 e22694) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2692)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12693 e22694)) rest2689)) tmp2691) ((lambda (_2697) (syntax-violation (quote case) "bad clause" x2663 clause2673)) tmp2690))) ($sc-dispatch tmp2690 (quote (each-any any . each-any))))) clause2673)) tmp2688)) (f2672 (car clauses2674) (cdr clauses2674))))))) tmp2665) (syntax-violation #f "source expression failed to match any pattern" tmp2664))) ($sc-dispatch tmp2664 (quote (any any any . each-any))))) x2663)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2698) ((lambda (tmp2699) ((lambda (tmp2700) (if tmp2700 (apply (lambda (_2701 e2702) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2702)) (list (cons _2701 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2702 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2700) (syntax-violation #f "source expression failed to match any pattern" tmp2699))) ($sc-dispatch tmp2699 (quote (any any))))) x2698)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 56d61e599..be0efb623 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -366,15 +366,20 @@ ((_ source test-exp then-exp else-exp) (build-annotated source `(if ,test-exp ,then-exp ,else-exp))))) -(define-syntax build-lexical-reference - (syntax-rules () - ((_ type source var) - (build-annotated source var)))) +(define build-lexical-reference + (lambda (type source name var) + (build-annotated + source + (case (fluid-ref *mode*) + ((c) ((@ (ice-9 expand-support) make-lexical) name var)) + (else var))))) -(define-syntax build-lexical-assignment - (syntax-rules () - ((_ source var exp) - (build-annotated source `(set! ,var ,exp))))) +(define build-lexical-assignment + (lambda (source name var exp) + (build-annotated + source + `(set! ,(build-lexical-reference 'set no-source name var) + ,exp)))) ;; Before modules are booted, we can't expand into data structures from ;; (ice-9 expand-support) -- we need to give the evaluator the @@ -1154,7 +1159,7 @@ (lambda (type value e r w s mod) (case type ((lexical) - (build-lexical-reference 'value s value)) + (build-lexical-reference 'value s e value)) ((core external-macro) ;; apply transformer (value e r w s mod)) @@ -1164,7 +1169,8 @@ (lambda (id mod) (build-global-reference s id mod)))) ((lexical-call) (chi-application - (build-lexical-reference 'fun (source-annotation (car e)) value) + (build-lexical-reference 'fun (source-annotation (car e)) + (car e) value) e r w s mod)) ((global-call) (chi-application @@ -1719,7 +1725,7 @@ (define regen (lambda (x) (case (car x) - ((ref) (build-lexical-reference 'value no-source (cadr x))) + ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) ((primitive) (build-primref no-source (cadr x))) ((quote) (build-data no-source (cadr x))) ((lambda) (build-lambda no-source (cadr x) (regen (caddr x)))) @@ -1813,7 +1819,10 @@ (let ((b (lookup n r mod))) (case (binding-type b) ((lexical) - (build-lexical-assignment s (binding-value b) val)) + (build-lexical-assignment s + (syntax->datum (syntax id)) + (binding-value b) + val)) ((global) (build-global-assignment s n val mod)) ((displaced-lexical) (syntax-violation 'set! "identifier out of context" @@ -1931,7 +1940,8 @@ ; fat finger binding and references to temp variable y (build-application no-source (build-lambda no-source (list y) - (let ((y (build-lexical-reference 'value no-source y))) + (let ((y (build-lexical-reference 'value no-source + 'tmp y))) (build-conditional no-source (syntax-case fender () (#t y) @@ -1990,7 +2000,8 @@ ; fat finger binding and references to temp variable x (build-application s (build-lambda no-source (list x) - (gen-syntax-case (build-lexical-reference 'value no-source x) + (gen-syntax-case (build-lexical-reference 'value no-source + 'tmp x) (syntax (key ...)) (syntax (m ...)) r mod)) From f27e9e11cd01eefa9eab3cfd277120ce73e3355a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 May 2009 10:27:53 +0200 Subject: [PATCH 094/375] fix install-global construction of `define' forms * module/ice-9/psyntax.scm (build-global-definition): Remove mod argument, as it does not seem we could ever define something in another module. (chi-install-global): Build the define as a definition, not an application. Doesn't matter now, but it will later. (chi-top): Fix build-global-definition call. * module/ice-9/psyntax.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 ++++++++--------- module/ice-9/psyntax.scm | 47 +++++++++++++++++++------------------ 2 files changed, 35 insertions(+), 34 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 8b41c5ebf..e97081722 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*1170 (lambda (f1210 first1209 . rest1208) (or (null? first1209) (if (null? rest1208) (let andmap1211 ((first1212 first1209)) (let ((x1213 (car first1212)) (first1214 (cdr first1212))) (if (null? first1214) (f1210 x1213) (and (f1210 x1213) (andmap1211 first1214))))) (let andmap1215 ((first1216 first1209) (rest1217 rest1208)) (let ((x1218 (car first1216)) (xr1219 (map car rest1217)) (first1220 (cdr first1216)) (rest1221 (map cdr rest1217))) (if (null? first1220) (apply f1210 (cons x1218 xr1219)) (and (apply f1210 (cons x1218 xr1219)) (andmap1215 first1220 rest1221)))))))))) (letrec ((lambda-var-list1308 (lambda (vars1484) (let lvl1485 ((vars1486 vars1484) (ls1487 (quote ())) (w1488 (quote (())))) (cond ((pair? vars1486) (lvl1485 (cdr vars1486) (cons (wrap1287 (car vars1486) w1488 #f) ls1487) w1488)) ((id?1259 vars1486) (cons (wrap1287 vars1486 w1488 #f) ls1487)) ((null? vars1486) ls1487) ((syntax-object?1243 vars1486) (lvl1485 (syntax-object-expression1244 vars1486) ls1487 (join-wraps1278 w1488 (syntax-object-wrap1245 vars1486)))) ((annotation? vars1486) (lvl1485 (annotation-expression vars1486) ls1487 w1488)) (else (cons vars1486 ls1487)))))) (gen-var1307 (lambda (id1489) (let ((id1490 (if (syntax-object?1243 id1489) (syntax-object-expression1244 id1489) id1489))) (if (annotation? id1490) (build-annotated1232 (annotation-source id1490) (gensym (symbol->string (annotation-expression id1490)))) (build-annotated1232 #f (gensym (symbol->string id1490))))))) (strip1306 (lambda (x1491 w1492) (if (memq (quote top) (wrap-marks1262 w1492)) (if (or (annotation? x1491) (and (pair? x1491) (annotation? (car x1491)))) (strip-annotation1305 x1491 #f) x1491) (let f1493 ((x1494 x1491)) (cond ((syntax-object?1243 x1494) (strip1306 (syntax-object-expression1244 x1494) (syntax-object-wrap1245 x1494))) ((pair? x1494) (let ((a1495 (f1493 (car x1494))) (d1496 (f1493 (cdr x1494)))) (if (and (eq? a1495 (car x1494)) (eq? d1496 (cdr x1494))) x1494 (cons a1495 d1496)))) ((vector? x1494) (let ((old1497 (vector->list x1494))) (let ((new1498 (map f1493 old1497))) (if (and-map*1170 eq? old1497 new1498) x1494 (list->vector new1498))))) (else x1494)))))) (strip-annotation1305 (lambda (x1499 parent1500) (cond ((pair? x1499) (let ((new1501 (cons #f #f))) (begin (if parent1500 (set-annotation-stripped! parent1500 new1501)) (set-car! new1501 (strip-annotation1305 (car x1499) #f)) (set-cdr! new1501 (strip-annotation1305 (cdr x1499) #f)) new1501))) ((annotation? x1499) (or (annotation-stripped x1499) (strip-annotation1305 (annotation-expression x1499) x1499))) ((vector? x1499) (let ((new1502 (make-vector (vector-length x1499)))) (begin (if parent1500 (set-annotation-stripped! parent1500 new1502)) (let loop1503 ((i1504 (- (vector-length x1499) 1))) (unless (fx<1227 i1504 0) (vector-set! new1502 i1504 (strip-annotation1305 (vector-ref x1499 i1504) #f)) (loop1503 (fx-1225 i1504 1)))) new1502))) (else x1499)))) (ellipsis?1304 (lambda (x1505) (and (nonsymbol-id?1258 x1505) (free-id=?1282 x1505 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1303 (lambda () (build-annotated1232 #f (cons (build-annotated1232 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer1302 (lambda (expanded1506 mod1507) (let ((p1508 (local-eval-hook1229 expanded1506 mod1507))) (if (procedure? p1508) p1508 (syntax-violation #f "nonprocedure transformer" p1508))))) (chi-local-syntax1301 (lambda (rec?1509 e1510 r1511 w1512 s1513 mod1514 k1515) ((lambda (tmp1516) ((lambda (tmp1517) (if tmp1517 (apply (lambda (_1518 id1519 val1520 e11521 e21522) (let ((ids1523 id1519)) (if (not (valid-bound-ids?1284 ids1523)) (syntax-violation #f "duplicate bound keyword" e1510) (let ((labels1525 (gen-labels1265 ids1523))) (let ((new-w1526 (make-binding-wrap1276 ids1523 labels1525 w1512))) (k1515 (cons e11521 e21522) (extend-env1253 labels1525 (let ((w1528 (if rec?1509 new-w1526 w1512)) (trans-r1529 (macros-only-env1255 r1511))) (map (lambda (x1530) (cons (quote macro) (eval-local-transformer1302 (chi1295 x1530 trans-r1529 w1528 mod1514) mod1514))) val1520)) r1511) new-w1526 s1513 mod1514)))))) tmp1517) ((lambda (_1532) (syntax-violation #f "bad local syntax definition" (source-wrap1288 e1510 w1512 s1513 mod1514))) tmp1516))) ($sc-dispatch tmp1516 (quote (any #(each (any any)) any . each-any))))) e1510))) (chi-lambda-clause1300 (lambda (e1533 docstring1534 c1535 r1536 w1537 mod1538 k1539) ((lambda (tmp1540) ((lambda (tmp1541) (if (if tmp1541 (apply (lambda (args1542 doc1543 e11544 e21545) (and (string? (syntax->datum doc1543)) (not docstring1534))) tmp1541) #f) (apply (lambda (args1546 doc1547 e11548 e21549) (chi-lambda-clause1300 e1533 doc1547 (cons args1546 (cons e11548 e21549)) r1536 w1537 mod1538 k1539)) tmp1541) ((lambda (tmp1551) (if tmp1551 (apply (lambda (id1552 e11553 e21554) (let ((ids1555 id1552)) (if (not (valid-bound-ids?1284 ids1555)) (syntax-violation (quote lambda) "invalid parameter list" e1533) (let ((labels1557 (gen-labels1265 ids1555)) (new-vars1558 (map gen-var1307 ids1555))) (k1539 new-vars1558 docstring1534 (chi-body1299 (cons e11553 e21554) e1533 (extend-var-env1254 labels1557 new-vars1558 r1536) (make-binding-wrap1276 ids1555 labels1557 w1537) mod1538)))))) tmp1551) ((lambda (tmp1560) (if tmp1560 (apply (lambda (ids1561 e11562 e21563) (let ((old-ids1564 (lambda-var-list1308 ids1561))) (if (not (valid-bound-ids?1284 old-ids1564)) (syntax-violation (quote lambda) "invalid parameter list" e1533) (let ((labels1565 (gen-labels1265 old-ids1564)) (new-vars1566 (map gen-var1307 old-ids1564))) (k1539 (let f1567 ((ls11568 (cdr new-vars1566)) (ls21569 (car new-vars1566))) (if (null? ls11568) ls21569 (f1567 (cdr ls11568) (cons (car ls11568) ls21569)))) docstring1534 (chi-body1299 (cons e11562 e21563) e1533 (extend-var-env1254 labels1565 new-vars1566 r1536) (make-binding-wrap1276 old-ids1564 labels1565 w1537) mod1538)))))) tmp1560) ((lambda (_1571) (syntax-violation (quote lambda) "bad lambda" e1533)) tmp1540))) ($sc-dispatch tmp1540 (quote (any any . each-any)))))) ($sc-dispatch tmp1540 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1540 (quote (any any any . each-any))))) c1535))) (chi-body1299 (lambda (body1572 outer-form1573 r1574 w1575 mod1576) (let ((r1577 (cons (quote ("placeholder" placeholder)) r1574))) (let ((ribcage1578 (make-ribcage1266 (quote ()) (quote ()) (quote ())))) (let ((w1579 (make-wrap1261 (wrap-marks1262 w1575) (cons ribcage1578 (wrap-subst1263 w1575))))) (let parse1580 ((body1581 (map (lambda (x1587) (cons r1577 (wrap1287 x1587 w1579 mod1576))) body1572)) (ids1582 (quote ())) (labels1583 (quote ())) (vars1584 (quote ())) (vals1585 (quote ())) (bindings1586 (quote ()))) (if (null? body1581) (syntax-violation #f "no expressions in body" outer-form1573) (let ((e1588 (cdar body1581)) (er1589 (caar body1581))) (call-with-values (lambda () (syntax-type1293 e1588 er1589 (quote (())) #f ribcage1578 mod1576)) (lambda (type1590 value1591 e1592 w1593 s1594 mod1595) (let ((t1596 type1590)) (if (memv t1596 (quote (define-form))) (let ((id1597 (wrap1287 value1591 w1593 mod1595)) (label1598 (gen-label1264))) (let ((var1599 (gen-var1307 id1597))) (begin (extend-ribcage!1275 ribcage1578 id1597 label1598) (parse1580 (cdr body1581) (cons id1597 ids1582) (cons label1598 labels1583) (cons var1599 vars1584) (cons (cons er1589 (wrap1287 e1592 w1593 mod1595)) vals1585) (cons (cons (quote lexical) var1599) bindings1586))))) (if (memv t1596 (quote (define-syntax-form))) (let ((id1600 (wrap1287 value1591 w1593 mod1595)) (label1601 (gen-label1264))) (begin (extend-ribcage!1275 ribcage1578 id1600 label1601) (parse1580 (cdr body1581) (cons id1600 ids1582) (cons label1601 labels1583) vars1584 vals1585 (cons (cons (quote macro) (cons er1589 (wrap1287 e1592 w1593 mod1595))) bindings1586)))) (if (memv t1596 (quote (begin-form))) ((lambda (tmp1602) ((lambda (tmp1603) (if tmp1603 (apply (lambda (_1604 e11605) (parse1580 (let f1606 ((forms1607 e11605)) (if (null? forms1607) (cdr body1581) (cons (cons er1589 (wrap1287 (car forms1607) w1593 mod1595)) (f1606 (cdr forms1607))))) ids1582 labels1583 vars1584 vals1585 bindings1586)) tmp1603) (syntax-violation #f "source expression failed to match any pattern" tmp1602))) ($sc-dispatch tmp1602 (quote (any . each-any))))) e1592) (if (memv t1596 (quote (local-syntax-form))) (chi-local-syntax1301 value1591 e1592 er1589 w1593 s1594 mod1595 (lambda (forms1609 er1610 w1611 s1612 mod1613) (parse1580 (let f1614 ((forms1615 forms1609)) (if (null? forms1615) (cdr body1581) (cons (cons er1610 (wrap1287 (car forms1615) w1611 mod1613)) (f1614 (cdr forms1615))))) ids1582 labels1583 vars1584 vals1585 bindings1586))) (if (null? ids1582) (build-sequence1238 #f (map (lambda (x1616) (chi1295 (cdr x1616) (car x1616) (quote (())) mod1595)) (cons (cons er1589 (source-wrap1288 e1592 w1593 s1594 mod1595)) (cdr body1581)))) (begin (if (not (valid-bound-ids?1284 ids1582)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1573)) (let loop1617 ((bs1618 bindings1586) (er-cache1619 #f) (r-cache1620 #f)) (if (not (null? bs1618)) (let ((b1621 (car bs1618))) (if (eq? (car b1621) (quote macro)) (let ((er1622 (cadr b1621))) (let ((r-cache1623 (if (eq? er1622 er-cache1619) r-cache1620 (macros-only-env1255 er1622)))) (begin (set-cdr! b1621 (eval-local-transformer1302 (chi1295 (cddr b1621) r-cache1623 (quote (())) mod1595) mod1595)) (loop1617 (cdr bs1618) er1622 r-cache1623)))) (loop1617 (cdr bs1618) er-cache1619 r-cache1620))))) (set-cdr! r1577 (extend-env1253 labels1583 bindings1586 (cdr r1577))) (build-letrec1241 #f vars1584 (map (lambda (x1624) (chi1295 (cdr x1624) (car x1624) (quote (())) mod1595)) vals1585) (build-sequence1238 #f (map (lambda (x1625) (chi1295 (cdr x1625) (car x1625) (quote (())) mod1595)) (cons (cons er1589 (source-wrap1288 e1592 w1593 s1594 mod1595)) (cdr body1581)))))))))))))))))))))) (chi-macro1298 (lambda (p1626 e1627 r1628 w1629 rib1630 mod1631) (letrec ((rebuild-macro-output1632 (lambda (x1633 m1634) (cond ((pair? x1633) (cons (rebuild-macro-output1632 (car x1633) m1634) (rebuild-macro-output1632 (cdr x1633) m1634))) ((syntax-object?1243 x1633) (let ((w1635 (syntax-object-wrap1245 x1633))) (let ((ms1636 (wrap-marks1262 w1635)) (s1637 (wrap-subst1263 w1635))) (if (and (pair? ms1636) (eq? (car ms1636) #f)) (make-syntax-object1242 (syntax-object-expression1244 x1633) (make-wrap1261 (cdr ms1636) (if rib1630 (cons rib1630 (cdr s1637)) (cdr s1637))) (syntax-object-module1246 x1633)) (make-syntax-object1242 (syntax-object-expression1244 x1633) (make-wrap1261 (cons m1634 ms1636) (if rib1630 (cons rib1630 (cons (quote shift) s1637)) (cons (quote shift) s1637))) (let ((pmod1638 (procedure-module p1626))) (if pmod1638 (cons (quote hygiene) (module-name pmod1638)) (quote (hygiene guile))))))))) ((vector? x1633) (let ((n1639 (vector-length x1633))) (let ((v1640 (make-vector n1639))) (let doloop1641 ((i1642 0)) (if (fx=1226 i1642 n1639) v1640 (begin (vector-set! v1640 i1642 (rebuild-macro-output1632 (vector-ref x1633 i1642) m1634)) (doloop1641 (fx+1224 i1642 1)))))))) ((symbol? x1633) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1288 e1627 w1629 s mod1631) x1633)) (else x1633))))) (rebuild-macro-output1632 (p1626 (wrap1287 e1627 (anti-mark1274 w1629) mod1631)) (string #\m))))) (chi-application1297 (lambda (x1643 e1644 r1645 w1646 s1647 mod1648) ((lambda (tmp1649) ((lambda (tmp1650) (if tmp1650 (apply (lambda (e01651 e11652) (build-annotated1232 s1647 (cons x1643 (map (lambda (e1653) (chi1295 e1653 r1645 w1646 mod1648)) e11652)))) tmp1650) (syntax-violation #f "source expression failed to match any pattern" tmp1649))) ($sc-dispatch tmp1649 (quote (any . each-any))))) e1644))) (chi-expr1296 (lambda (type1655 value1656 e1657 r1658 w1659 s1660 mod1661) (let ((t1662 type1655)) (if (memv t1662 (quote (lexical))) (build-lexical-reference1233 (quote value) s1660 e1657 value1656) (if (memv t1662 (quote (core external-macro))) (value1656 e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (module-ref))) (call-with-values (lambda () (value1656 e1657)) (lambda (id1663 mod1664) (build-global-reference1235 s1660 id1663 mod1664))) (if (memv t1662 (quote (lexical-call))) (chi-application1297 (build-lexical-reference1233 (quote fun) (source-annotation1250 (car e1657)) (car e1657) value1656) e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (global-call))) (chi-application1297 (build-global-reference1235 (source-annotation1250 (car e1657)) value1656 (if (syntax-object?1243 (car e1657)) (syntax-object-module1246 (car e1657)) mod1661)) e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (constant))) (build-data1237 s1660 (strip1306 (source-wrap1288 e1657 w1659 s1660 mod1661) (quote (())))) (if (memv t1662 (quote (global))) (build-global-reference1235 s1660 value1656 mod1661) (if (memv t1662 (quote (call))) (chi-application1297 (chi1295 (car e1657) r1658 w1659 mod1661) e1657 r1658 w1659 s1660 mod1661) (if (memv t1662 (quote (begin-form))) ((lambda (tmp1665) ((lambda (tmp1666) (if tmp1666 (apply (lambda (_1667 e11668 e21669) (chi-sequence1289 (cons e11668 e21669) r1658 w1659 s1660 mod1661)) tmp1666) (syntax-violation #f "source expression failed to match any pattern" tmp1665))) ($sc-dispatch tmp1665 (quote (any any . each-any))))) e1657) (if (memv t1662 (quote (local-syntax-form))) (chi-local-syntax1301 value1656 e1657 r1658 w1659 s1660 mod1661 chi-sequence1289) (if (memv t1662 (quote (eval-when-form))) ((lambda (tmp1671) ((lambda (tmp1672) (if tmp1672 (apply (lambda (_1673 x1674 e11675 e21676) (let ((when-list1677 (chi-when-list1292 e1657 x1674 w1659))) (if (memq (quote eval) when-list1677) (chi-sequence1289 (cons e11675 e21676) r1658 w1659 s1660 mod1661) (chi-void1303)))) tmp1672) (syntax-violation #f "source expression failed to match any pattern" tmp1671))) ($sc-dispatch tmp1671 (quote (any each-any any . each-any))))) e1657) (if (memv t1662 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1657 (wrap1287 value1656 w1659 mod1661)) (if (memv t1662 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1288 e1657 w1659 s1660 mod1661)) (if (memv t1662 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1288 e1657 w1659 s1660 mod1661)) (syntax-violation #f "unexpected syntax" (source-wrap1288 e1657 w1659 s1660 mod1661))))))))))))))))))) (chi1295 (lambda (e1680 r1681 w1682 mod1683) (call-with-values (lambda () (syntax-type1293 e1680 r1681 w1682 #f #f mod1683)) (lambda (type1684 value1685 e1686 w1687 s1688 mod1689) (chi-expr1296 type1684 value1685 e1686 r1681 w1687 s1688 mod1689))))) (chi-top1294 (lambda (e1690 r1691 w1692 m1693 esew1694 mod1695) (call-with-values (lambda () (syntax-type1293 e1690 r1691 w1692 #f #f mod1695)) (lambda (type1703 value1704 e1705 w1706 s1707 mod1708) (let ((t1709 type1703)) (if (memv t1709 (quote (begin-form))) ((lambda (tmp1710) ((lambda (tmp1711) (if tmp1711 (apply (lambda (_1712) (chi-void1303)) tmp1711) ((lambda (tmp1713) (if tmp1713 (apply (lambda (_1714 e11715 e21716) (chi-top-sequence1290 (cons e11715 e21716) r1691 w1706 s1707 m1693 esew1694 mod1708)) tmp1713) (syntax-violation #f "source expression failed to match any pattern" tmp1710))) ($sc-dispatch tmp1710 (quote (any any . each-any)))))) ($sc-dispatch tmp1710 (quote (any))))) e1705) (if (memv t1709 (quote (local-syntax-form))) (chi-local-syntax1301 value1704 e1705 r1691 w1706 s1707 mod1708 (lambda (body1718 r1719 w1720 s1721 mod1722) (chi-top-sequence1290 body1718 r1719 w1720 s1721 m1693 esew1694 mod1722))) (if (memv t1709 (quote (eval-when-form))) ((lambda (tmp1723) ((lambda (tmp1724) (if tmp1724 (apply (lambda (_1725 x1726 e11727 e21728) (let ((when-list1729 (chi-when-list1292 e1705 x1726 w1706)) (body1730 (cons e11727 e21728))) (cond ((eq? m1693 (quote e)) (if (memq (quote eval) when-list1729) (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote e) (quote (eval)) mod1708) (chi-void1303))) ((memq (quote load) when-list1729) (if (or (memq (quote compile) when-list1729) (and (eq? m1693 (quote c&e)) (memq (quote eval) when-list1729))) (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote c&e) (quote (compile load)) mod1708) (if (memq m1693 (quote (c c&e))) (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote c) (quote (load)) mod1708) (chi-void1303)))) ((or (memq (quote compile) when-list1729) (and (eq? m1693 (quote c&e)) (memq (quote eval) when-list1729))) (top-level-eval-hook1228 (chi-top-sequence1290 body1730 r1691 w1706 s1707 (quote e) (quote (eval)) mod1708) mod1708) (chi-void1303)) (else (chi-void1303))))) tmp1724) (syntax-violation #f "source expression failed to match any pattern" tmp1723))) ($sc-dispatch tmp1723 (quote (any each-any any . each-any))))) e1705) (if (memv t1709 (quote (define-syntax-form))) (let ((n1733 (id-var-name1281 value1704 w1706)) (r1734 (macros-only-env1255 r1691))) (let ((t1735 m1693)) (if (memv t1735 (quote (c))) (if (memq (quote compile) esew1694) (let ((e1736 (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)))) (begin (top-level-eval-hook1228 e1736 mod1708) (if (memq (quote load) esew1694) e1736 (chi-void1303)))) (if (memq (quote load) esew1694) (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)) (chi-void1303))) (if (memv t1735 (quote (c&e))) (let ((e1737 (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)))) (begin (top-level-eval-hook1228 e1737 mod1708) e1737)) (begin (if (memq (quote eval) esew1694) (top-level-eval-hook1228 (chi-install-global1291 n1733 (chi1295 e1705 r1734 w1706 mod1708)) mod1708)) (chi-void1303)))))) (if (memv t1709 (quote (define-form))) (let ((n1738 (id-var-name1281 value1704 w1706))) (let ((type1739 (binding-type1251 (lookup1256 n1738 r1691 mod1708)))) (let ((t1740 type1739)) (if (memv t1740 (quote (global core macro module-ref))) (let ((x1741 (build-annotated1232 s1707 (list (quote define) n1738 (chi1295 e1705 r1691 w1706 mod1708))))) (begin (if (eq? m1693 (quote c&e)) (top-level-eval-hook1228 x1741 mod1708)) x1741)) (if (memv t1740 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1705 (wrap1287 value1704 w1706 mod1708)) (syntax-violation #f "cannot define keyword at top level" e1705 (wrap1287 value1704 w1706 mod1708))))))) (let ((x1742 (chi-expr1296 type1703 value1704 e1705 r1691 w1706 s1707 mod1708))) (begin (if (eq? m1693 (quote c&e)) (top-level-eval-hook1228 x1742 mod1708)) x1742)))))))))))) (syntax-type1293 (lambda (e1743 r1744 w1745 s1746 rib1747 mod1748) (cond ((symbol? e1743) (let ((n1749 (id-var-name1281 e1743 w1745))) (let ((b1750 (lookup1256 n1749 r1744 mod1748))) (let ((type1751 (binding-type1251 b1750))) (let ((t1752 type1751)) (if (memv t1752 (quote (lexical))) (values type1751 (binding-value1252 b1750) e1743 w1745 s1746 mod1748) (if (memv t1752 (quote (global))) (values type1751 n1749 e1743 w1745 s1746 mod1748) (if (memv t1752 (quote (macro))) (syntax-type1293 (chi-macro1298 (binding-value1252 b1750) e1743 r1744 w1745 rib1747 mod1748) r1744 (quote (())) s1746 rib1747 mod1748) (values type1751 (binding-value1252 b1750) e1743 w1745 s1746 mod1748))))))))) ((pair? e1743) (let ((first1753 (car e1743))) (if (id?1259 first1753) (let ((n1754 (id-var-name1281 first1753 w1745))) (let ((b1755 (lookup1256 n1754 r1744 (or (and (syntax-object?1243 first1753) (syntax-object-module1246 first1753)) mod1748)))) (let ((type1756 (binding-type1251 b1755))) (let ((t1757 type1756)) (if (memv t1757 (quote (lexical))) (values (quote lexical-call) (binding-value1252 b1755) e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (global))) (values (quote global-call) n1754 e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (macro))) (syntax-type1293 (chi-macro1298 (binding-value1252 b1755) e1743 r1744 w1745 rib1747 mod1748) r1744 (quote (())) s1746 rib1747 mod1748) (if (memv t1757 (quote (core external-macro module-ref))) (values type1756 (binding-value1252 b1755) e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1252 b1755) e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (begin))) (values (quote begin-form) #f e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (eval-when))) (values (quote eval-when-form) #f e1743 w1745 s1746 mod1748) (if (memv t1757 (quote (define))) ((lambda (tmp1758) ((lambda (tmp1759) (if (if tmp1759 (apply (lambda (_1760 name1761 val1762) (id?1259 name1761)) tmp1759) #f) (apply (lambda (_1763 name1764 val1765) (values (quote define-form) name1764 val1765 w1745 s1746 mod1748)) tmp1759) ((lambda (tmp1766) (if (if tmp1766 (apply (lambda (_1767 name1768 args1769 e11770 e21771) (and (id?1259 name1768) (valid-bound-ids?1284 (lambda-var-list1308 args1769)))) tmp1766) #f) (apply (lambda (_1772 name1773 args1774 e11775 e21776) (values (quote define-form) (wrap1287 name1773 w1745 mod1748) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1287 (cons args1774 (cons e11775 e21776)) w1745 mod1748)) (quote (())) s1746 mod1748)) tmp1766) ((lambda (tmp1778) (if (if tmp1778 (apply (lambda (_1779 name1780) (id?1259 name1780)) tmp1778) #f) (apply (lambda (_1781 name1782) (values (quote define-form) (wrap1287 name1782 w1745 mod1748) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1746 mod1748)) tmp1778) (syntax-violation #f "source expression failed to match any pattern" tmp1758))) ($sc-dispatch tmp1758 (quote (any any)))))) ($sc-dispatch tmp1758 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1758 (quote (any any any))))) e1743) (if (memv t1757 (quote (define-syntax))) ((lambda (tmp1783) ((lambda (tmp1784) (if (if tmp1784 (apply (lambda (_1785 name1786 val1787) (id?1259 name1786)) tmp1784) #f) (apply (lambda (_1788 name1789 val1790) (values (quote define-syntax-form) name1789 val1790 w1745 s1746 mod1748)) tmp1784) (syntax-violation #f "source expression failed to match any pattern" tmp1783))) ($sc-dispatch tmp1783 (quote (any any any))))) e1743) (values (quote call) #f e1743 w1745 s1746 mod1748)))))))))))))) (values (quote call) #f e1743 w1745 s1746 mod1748)))) ((syntax-object?1243 e1743) (syntax-type1293 (syntax-object-expression1244 e1743) r1744 (join-wraps1278 w1745 (syntax-object-wrap1245 e1743)) #f rib1747 (or (syntax-object-module1246 e1743) mod1748))) ((annotation? e1743) (syntax-type1293 (annotation-expression e1743) r1744 w1745 (annotation-source e1743) rib1747 mod1748)) ((self-evaluating? e1743) (values (quote constant) #f e1743 w1745 s1746 mod1748)) (else (values (quote other) #f e1743 w1745 s1746 mod1748))))) (chi-when-list1292 (lambda (e1791 when-list1792 w1793) (let f1794 ((when-list1795 when-list1792) (situations1796 (quote ()))) (if (null? when-list1795) situations1796 (f1794 (cdr when-list1795) (cons (let ((x1797 (car when-list1795))) (cond ((free-id=?1282 x1797 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1282 x1797 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1282 x1797 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1791 (wrap1287 x1797 w1793 #f))))) situations1796)))))) (chi-install-global1291 (lambda (name1798 e1799) (build-annotated1232 #f (list (build-annotated1232 #f (quote define)) name1798 (if (let ((v1800 (module-variable (current-module) name1798))) (and v1800 (variable-bound? v1800) (macro? (variable-ref v1800)) (not (eq? (macro-type (variable-ref v1800)) (quote syncase-macro))))) (build-annotated1232 #f (list (build-annotated1232 #f (quote make-extended-syncase-macro)) (build-annotated1232 #f (list (build-annotated1232 #f (quote module-ref)) (build-annotated1232 #f (quote (current-module))) (build-data1237 #f name1798))) (build-data1237 #f (quote macro)) e1799)) (build-annotated1232 #f (list (build-annotated1232 #f (quote make-syncase-macro)) (build-data1237 #f (quote macro)) e1799))))))) (chi-top-sequence1290 (lambda (body1801 r1802 w1803 s1804 m1805 esew1806 mod1807) (build-sequence1238 s1804 (let dobody1808 ((body1809 body1801) (r1810 r1802) (w1811 w1803) (m1812 m1805) (esew1813 esew1806) (mod1814 mod1807)) (if (null? body1809) (quote ()) (let ((first1815 (chi-top1294 (car body1809) r1810 w1811 m1812 esew1813 mod1814))) (cons first1815 (dobody1808 (cdr body1809) r1810 w1811 m1812 esew1813 mod1814)))))))) (chi-sequence1289 (lambda (body1816 r1817 w1818 s1819 mod1820) (build-sequence1238 s1819 (let dobody1821 ((body1822 body1816) (r1823 r1817) (w1824 w1818) (mod1825 mod1820)) (if (null? body1822) (quote ()) (let ((first1826 (chi1295 (car body1822) r1823 w1824 mod1825))) (cons first1826 (dobody1821 (cdr body1822) r1823 w1824 mod1825)))))))) (source-wrap1288 (lambda (x1827 w1828 s1829 defmod1830) (wrap1287 (if s1829 (make-annotation x1827 s1829 #f) x1827) w1828 defmod1830))) (wrap1287 (lambda (x1831 w1832 defmod1833) (cond ((and (null? (wrap-marks1262 w1832)) (null? (wrap-subst1263 w1832))) x1831) ((syntax-object?1243 x1831) (make-syntax-object1242 (syntax-object-expression1244 x1831) (join-wraps1278 w1832 (syntax-object-wrap1245 x1831)) (syntax-object-module1246 x1831))) ((null? x1831) x1831) (else (make-syntax-object1242 x1831 w1832 defmod1833))))) (bound-id-member?1286 (lambda (x1834 list1835) (and (not (null? list1835)) (or (bound-id=?1283 x1834 (car list1835)) (bound-id-member?1286 x1834 (cdr list1835)))))) (distinct-bound-ids?1285 (lambda (ids1836) (let distinct?1837 ((ids1838 ids1836)) (or (null? ids1838) (and (not (bound-id-member?1286 (car ids1838) (cdr ids1838))) (distinct?1837 (cdr ids1838))))))) (valid-bound-ids?1284 (lambda (ids1839) (and (let all-ids?1840 ((ids1841 ids1839)) (or (null? ids1841) (and (id?1259 (car ids1841)) (all-ids?1840 (cdr ids1841))))) (distinct-bound-ids?1285 ids1839)))) (bound-id=?1283 (lambda (i1842 j1843) (if (and (syntax-object?1243 i1842) (syntax-object?1243 j1843)) (and (eq? (let ((e1844 (syntax-object-expression1244 i1842))) (if (annotation? e1844) (annotation-expression e1844) e1844)) (let ((e1845 (syntax-object-expression1244 j1843))) (if (annotation? e1845) (annotation-expression e1845) e1845))) (same-marks?1280 (wrap-marks1262 (syntax-object-wrap1245 i1842)) (wrap-marks1262 (syntax-object-wrap1245 j1843)))) (eq? (let ((e1846 i1842)) (if (annotation? e1846) (annotation-expression e1846) e1846)) (let ((e1847 j1843)) (if (annotation? e1847) (annotation-expression e1847) e1847)))))) (free-id=?1282 (lambda (i1848 j1849) (and (eq? (let ((x1850 i1848)) (let ((e1851 (if (syntax-object?1243 x1850) (syntax-object-expression1244 x1850) x1850))) (if (annotation? e1851) (annotation-expression e1851) e1851))) (let ((x1852 j1849)) (let ((e1853 (if (syntax-object?1243 x1852) (syntax-object-expression1244 x1852) x1852))) (if (annotation? e1853) (annotation-expression e1853) e1853)))) (eq? (id-var-name1281 i1848 (quote (()))) (id-var-name1281 j1849 (quote (()))))))) (id-var-name1281 (lambda (id1854 w1855) (letrec ((search-vector-rib1858 (lambda (sym1864 subst1865 marks1866 symnames1867 ribcage1868) (let ((n1869 (vector-length symnames1867))) (let f1870 ((i1871 0)) (cond ((fx=1226 i1871 n1869) (search1856 sym1864 (cdr subst1865) marks1866)) ((and (eq? (vector-ref symnames1867 i1871) sym1864) (same-marks?1280 marks1866 (vector-ref (ribcage-marks1269 ribcage1868) i1871))) (values (vector-ref (ribcage-labels1270 ribcage1868) i1871) marks1866)) (else (f1870 (fx+1224 i1871 1)))))))) (search-list-rib1857 (lambda (sym1872 subst1873 marks1874 symnames1875 ribcage1876) (let f1877 ((symnames1878 symnames1875) (i1879 0)) (cond ((null? symnames1878) (search1856 sym1872 (cdr subst1873) marks1874)) ((and (eq? (car symnames1878) sym1872) (same-marks?1280 marks1874 (list-ref (ribcage-marks1269 ribcage1876) i1879))) (values (list-ref (ribcage-labels1270 ribcage1876) i1879) marks1874)) (else (f1877 (cdr symnames1878) (fx+1224 i1879 1))))))) (search1856 (lambda (sym1880 subst1881 marks1882) (if (null? subst1881) (values #f marks1882) (let ((fst1883 (car subst1881))) (if (eq? fst1883 (quote shift)) (search1856 sym1880 (cdr subst1881) (cdr marks1882)) (let ((symnames1884 (ribcage-symnames1268 fst1883))) (if (vector? symnames1884) (search-vector-rib1858 sym1880 subst1881 marks1882 symnames1884 fst1883) (search-list-rib1857 sym1880 subst1881 marks1882 symnames1884 fst1883))))))))) (cond ((symbol? id1854) (or (call-with-values (lambda () (search1856 id1854 (wrap-subst1263 w1855) (wrap-marks1262 w1855))) (lambda (x1886 . ignore1885) x1886)) id1854)) ((syntax-object?1243 id1854) (let ((id1887 (let ((e1889 (syntax-object-expression1244 id1854))) (if (annotation? e1889) (annotation-expression e1889) e1889))) (w11888 (syntax-object-wrap1245 id1854))) (let ((marks1890 (join-marks1279 (wrap-marks1262 w1855) (wrap-marks1262 w11888)))) (call-with-values (lambda () (search1856 id1887 (wrap-subst1263 w1855) marks1890)) (lambda (new-id1891 marks1892) (or new-id1891 (call-with-values (lambda () (search1856 id1887 (wrap-subst1263 w11888) marks1892)) (lambda (x1894 . ignore1893) x1894)) id1887)))))) ((annotation? id1854) (let ((id1895 (let ((e1896 id1854)) (if (annotation? e1896) (annotation-expression e1896) e1896)))) (or (call-with-values (lambda () (search1856 id1895 (wrap-subst1263 w1855) (wrap-marks1262 w1855))) (lambda (x1898 . ignore1897) x1898)) id1895))) (else (syntax-violation (quote id-var-name) "invalid id" id1854)))))) (same-marks?1280 (lambda (x1899 y1900) (or (eq? x1899 y1900) (and (not (null? x1899)) (not (null? y1900)) (eq? (car x1899) (car y1900)) (same-marks?1280 (cdr x1899) (cdr y1900)))))) (join-marks1279 (lambda (m11901 m21902) (smart-append1277 m11901 m21902))) (join-wraps1278 (lambda (w11903 w21904) (let ((m11905 (wrap-marks1262 w11903)) (s11906 (wrap-subst1263 w11903))) (if (null? m11905) (if (null? s11906) w21904 (make-wrap1261 (wrap-marks1262 w21904) (smart-append1277 s11906 (wrap-subst1263 w21904)))) (make-wrap1261 (smart-append1277 m11905 (wrap-marks1262 w21904)) (smart-append1277 s11906 (wrap-subst1263 w21904))))))) (smart-append1277 (lambda (m11907 m21908) (if (null? m21908) m11907 (append m11907 m21908)))) (make-binding-wrap1276 (lambda (ids1909 labels1910 w1911) (if (null? ids1909) w1911 (make-wrap1261 (wrap-marks1262 w1911) (cons (let ((labelvec1912 (list->vector labels1910))) (let ((n1913 (vector-length labelvec1912))) (let ((symnamevec1914 (make-vector n1913)) (marksvec1915 (make-vector n1913))) (begin (let f1916 ((ids1917 ids1909) (i1918 0)) (if (not (null? ids1917)) (call-with-values (lambda () (id-sym-name&marks1260 (car ids1917) w1911)) (lambda (symname1919 marks1920) (begin (vector-set! symnamevec1914 i1918 symname1919) (vector-set! marksvec1915 i1918 marks1920) (f1916 (cdr ids1917) (fx+1224 i1918 1))))))) (make-ribcage1266 symnamevec1914 marksvec1915 labelvec1912))))) (wrap-subst1263 w1911)))))) (extend-ribcage!1275 (lambda (ribcage1921 id1922 label1923) (begin (set-ribcage-symnames!1271 ribcage1921 (cons (let ((e1924 (syntax-object-expression1244 id1922))) (if (annotation? e1924) (annotation-expression e1924) e1924)) (ribcage-symnames1268 ribcage1921))) (set-ribcage-marks!1272 ribcage1921 (cons (wrap-marks1262 (syntax-object-wrap1245 id1922)) (ribcage-marks1269 ribcage1921))) (set-ribcage-labels!1273 ribcage1921 (cons label1923 (ribcage-labels1270 ribcage1921)))))) (anti-mark1274 (lambda (w1925) (make-wrap1261 (cons #f (wrap-marks1262 w1925)) (cons (quote shift) (wrap-subst1263 w1925))))) (set-ribcage-labels!1273 (lambda (x1926 update1927) (vector-set! x1926 3 update1927))) (set-ribcage-marks!1272 (lambda (x1928 update1929) (vector-set! x1928 2 update1929))) (set-ribcage-symnames!1271 (lambda (x1930 update1931) (vector-set! x1930 1 update1931))) (ribcage-labels1270 (lambda (x1932) (vector-ref x1932 3))) (ribcage-marks1269 (lambda (x1933) (vector-ref x1933 2))) (ribcage-symnames1268 (lambda (x1934) (vector-ref x1934 1))) (ribcage?1267 (lambda (x1935) (and (vector? x1935) (= (vector-length x1935) 4) (eq? (vector-ref x1935 0) (quote ribcage))))) (make-ribcage1266 (lambda (symnames1936 marks1937 labels1938) (vector (quote ribcage) symnames1936 marks1937 labels1938))) (gen-labels1265 (lambda (ls1939) (if (null? ls1939) (quote ()) (cons (gen-label1264) (gen-labels1265 (cdr ls1939)))))) (gen-label1264 (lambda () (string #\i))) (wrap-subst1263 cdr) (wrap-marks1262 car) (make-wrap1261 cons) (id-sym-name&marks1260 (lambda (x1940 w1941) (if (syntax-object?1243 x1940) (values (let ((e1942 (syntax-object-expression1244 x1940))) (if (annotation? e1942) (annotation-expression e1942) e1942)) (join-marks1279 (wrap-marks1262 w1941) (wrap-marks1262 (syntax-object-wrap1245 x1940)))) (values (let ((e1943 x1940)) (if (annotation? e1943) (annotation-expression e1943) e1943)) (wrap-marks1262 w1941))))) (id?1259 (lambda (x1944) (cond ((symbol? x1944) #t) ((syntax-object?1243 x1944) (symbol? (let ((e1945 (syntax-object-expression1244 x1944))) (if (annotation? e1945) (annotation-expression e1945) e1945)))) ((annotation? x1944) (symbol? (annotation-expression x1944))) (else #f)))) (nonsymbol-id?1258 (lambda (x1946) (and (syntax-object?1243 x1946) (symbol? (let ((e1947 (syntax-object-expression1244 x1946))) (if (annotation? e1947) (annotation-expression e1947) e1947)))))) (global-extend1257 (lambda (type1948 sym1949 val1950) (put-global-definition-hook1230 sym1949 type1948 val1950))) (lookup1256 (lambda (x1951 r1952 mod1953) (cond ((assq x1951 r1952) => cdr) ((symbol? x1951) (or (get-global-definition-hook1231 x1951 mod1953) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1255 (lambda (r1954) (if (null? r1954) (quote ()) (let ((a1955 (car r1954))) (if (eq? (cadr a1955) (quote macro)) (cons a1955 (macros-only-env1255 (cdr r1954))) (macros-only-env1255 (cdr r1954))))))) (extend-var-env1254 (lambda (labels1956 vars1957 r1958) (if (null? labels1956) r1958 (extend-var-env1254 (cdr labels1956) (cdr vars1957) (cons (cons (car labels1956) (cons (quote lexical) (car vars1957))) r1958))))) (extend-env1253 (lambda (labels1959 bindings1960 r1961) (if (null? labels1959) r1961 (extend-env1253 (cdr labels1959) (cdr bindings1960) (cons (cons (car labels1959) (car bindings1960)) r1961))))) (binding-value1252 cdr) (binding-type1251 car) (source-annotation1250 (lambda (x1962) (cond ((annotation? x1962) (annotation-source x1962)) ((syntax-object?1243 x1962) (source-annotation1250 (syntax-object-expression1244 x1962))) (else #f)))) (set-syntax-object-module!1249 (lambda (x1963 update1964) (vector-set! x1963 3 update1964))) (set-syntax-object-wrap!1248 (lambda (x1965 update1966) (vector-set! x1965 2 update1966))) (set-syntax-object-expression!1247 (lambda (x1967 update1968) (vector-set! x1967 1 update1968))) (syntax-object-module1246 (lambda (x1969) (vector-ref x1969 3))) (syntax-object-wrap1245 (lambda (x1970) (vector-ref x1970 2))) (syntax-object-expression1244 (lambda (x1971) (vector-ref x1971 1))) (syntax-object?1243 (lambda (x1972) (and (vector? x1972) (= (vector-length x1972) 4) (eq? (vector-ref x1972 0) (quote syntax-object))))) (make-syntax-object1242 (lambda (expression1973 wrap1974 module1975) (vector (quote syntax-object) expression1973 wrap1974 module1975))) (build-letrec1241 (lambda (src1976 vars1977 val-exps1978 body-exp1979) (if (null? vars1977) (build-annotated1232 src1976 body-exp1979) (build-annotated1232 src1976 (list (quote letrec) (map list vars1977 val-exps1978) body-exp1979))))) (build-named-let1240 (lambda (src1980 vars1981 val-exps1982 body-exp1983) (if (null? vars1981) (build-annotated1232 src1980 body-exp1983) (build-annotated1232 src1980 (list (quote let) (car vars1981) (map list (cdr vars1981) val-exps1982) body-exp1983))))) (build-let1239 (lambda (src1984 vars1985 val-exps1986 body-exp1987) (if (null? vars1985) (build-annotated1232 src1984 body-exp1987) (build-annotated1232 src1984 (list (quote let) (map list vars1985 val-exps1986) body-exp1987))))) (build-sequence1238 (lambda (src1988 exps1989) (if (null? (cdr exps1989)) (build-annotated1232 src1988 (car exps1989)) (build-annotated1232 src1988 (cons (quote begin) exps1989))))) (build-data1237 (lambda (src1990 exp1991) (if (and (self-evaluating? exp1991) (not (vector? exp1991))) (build-annotated1232 src1990 exp1991) (build-annotated1232 src1990 (list (quote quote) exp1991))))) (build-global-assignment1236 (lambda (source1992 var1993 exp1994 mod1995) (let ((ref1996 (build-global-reference1235 source1992 var1993 mod1995))) (build-annotated1232 source1992 (list (quote set!) ref1996 exp1994))))) (build-global-reference1235 (lambda (source1997 var1998 mod1999) (build-annotated1232 source1997 (if (not mod1999) var1998 (let ((make-module-ref2000 (let ((t2003 (fluid-ref *mode*1223))) (if (memv t2003 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (mod2004 var2005 public?2006) (list (if public?2006 (quote @) (quote @@)) mod2004 var2005))))) (kind2001 (car mod1999)) (mod2002 (cdr mod1999))) (let ((t2007 kind2001)) (if (memv t2007 (quote (public))) (make-module-ref2000 mod2002 var1998 #t) (if (memv t2007 (quote (private))) (if (not (equal? mod2002 (module-name (current-module)))) (make-module-ref2000 mod2002 var1998 #f) var1998) (if (memv t2007 (quote (bare))) var1998 (if (memv t2007 (quote (hygiene))) (if (and (not (equal? mod2002 (module-name (current-module)))) (module-variable (resolve-module mod2002) var1998)) (make-module-ref2000 mod2002 var1998 #f) var1998) (syntax-violation #f "bad module kind" var1998 mod2002))))))))))) (build-lexical-assignment1234 (lambda (source2008 name2009 var2010 exp2011) (build-annotated1232 source2008 (list (quote set!) (build-lexical-reference1233 (quote set) #f name2009 var2010) exp2011)))) (build-lexical-reference1233 (lambda (type2012 source2013 name2014 var2015) (build-annotated1232 source2013 (let ((t2016 (fluid-ref *mode*1223))) (if (memv t2016 (quote (c))) ((@ (ice-9 expand-support) make-lexical) name2014 var2015) var2015))))) (build-annotated1232 (lambda (src2017 exp2018) (if (and src2017 (not (annotation? exp2018))) (make-annotation exp2018 src2017 #t) exp2018))) (get-global-definition-hook1231 (lambda (symbol2019 module2020) (begin (if (and (not module2020) (current-module)) (warn "module system is booted, we should have a module" symbol2019)) (let ((v2021 (module-variable (if module2020 (resolve-module (cdr module2020)) (current-module)) symbol2019))) (and v2021 (variable-bound? v2021) (let ((val2022 (variable-ref v2021))) (and (macro? val2022) (syncase-macro-type val2022) (cons (syncase-macro-type val2022) (syncase-macro-binding val2022))))))))) (put-global-definition-hook1230 (lambda (symbol2023 type2024 val2025) (let ((existing2026 (let ((v2027 (module-variable (current-module) symbol2023))) (and v2027 (variable-bound? v2027) (let ((val2028 (variable-ref v2027))) (and (macro? val2028) (not (syncase-macro-type val2028)) val2028)))))) (module-define! (current-module) symbol2023 (if existing2026 (make-extended-syncase-macro existing2026 type2024 val2025) (make-syncase-macro type2024 val2025)))))) (local-eval-hook1229 (lambda (x2029 mod2030) (primitive-eval (list noexpand1222 (let ((t2031 (fluid-ref *mode*1223))) (if (memv t2031 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x2029) x2029)))))) (top-level-eval-hook1228 (lambda (x2032 mod2033) (primitive-eval (list noexpand1222 (let ((t2034 (fluid-ref *mode*1223))) (if (memv t2034 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x2032) x2032)))))) (fx<1227 <) (fx=1226 =) (fx-1225 -) (fx+1224 +) (*mode*1223 (make-fluid)) (noexpand1222 "noexpand")) (begin (global-extend1257 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1257 (quote local-syntax) (quote let-syntax) #f) (global-extend1257 (quote core) (quote fluid-let-syntax) (lambda (e2035 r2036 w2037 s2038 mod2039) ((lambda (tmp2040) ((lambda (tmp2041) (if (if tmp2041 (apply (lambda (_2042 var2043 val2044 e12045 e22046) (valid-bound-ids?1284 var2043)) tmp2041) #f) (apply (lambda (_2048 var2049 val2050 e12051 e22052) (let ((names2053 (map (lambda (x2054) (id-var-name1281 x2054 w2037)) var2049))) (begin (for-each (lambda (id2056 n2057) (let ((t2058 (binding-type1251 (lookup1256 n2057 r2036 mod2039)))) (if (memv t2058 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2035 (source-wrap1288 id2056 w2037 s2038 mod2039))))) var2049 names2053) (chi-body1299 (cons e12051 e22052) (source-wrap1288 e2035 w2037 s2038 mod2039) (extend-env1253 names2053 (let ((trans-r2061 (macros-only-env1255 r2036))) (map (lambda (x2062) (cons (quote macro) (eval-local-transformer1302 (chi1295 x2062 trans-r2061 w2037 mod2039) mod2039))) val2050)) r2036) w2037 mod2039)))) tmp2041) ((lambda (_2064) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1288 e2035 w2037 s2038 mod2039))) tmp2040))) ($sc-dispatch tmp2040 (quote (any #(each (any any)) any . each-any))))) e2035))) (global-extend1257 (quote core) (quote quote) (lambda (e2065 r2066 w2067 s2068 mod2069) ((lambda (tmp2070) ((lambda (tmp2071) (if tmp2071 (apply (lambda (_2072 e2073) (build-data1237 s2068 (strip1306 e2073 w2067))) tmp2071) ((lambda (_2074) (syntax-violation (quote quote) "bad syntax" (source-wrap1288 e2065 w2067 s2068 mod2069))) tmp2070))) ($sc-dispatch tmp2070 (quote (any any))))) e2065))) (global-extend1257 (quote core) (quote syntax) (letrec ((regen2082 (lambda (x2083) (let ((t2084 (car x2083))) (if (memv t2084 (quote (ref))) (build-lexical-reference1233 (quote value) #f (cadr x2083) (cadr x2083)) (if (memv t2084 (quote (primitive))) (build-annotated1232 #f (cadr x2083)) (if (memv t2084 (quote (quote))) (build-data1237 #f (cadr x2083)) (if (memv t2084 (quote (lambda))) (build-annotated1232 #f (list (quote lambda) (cadr x2083) (regen2082 (caddr x2083)))) (if (memv t2084 (quote (map))) (let ((ls2085 (map regen2082 (cdr x2083)))) (build-annotated1232 #f (cons (if (fx=1226 (length ls2085) 2) (build-annotated1232 #f (quote map)) (build-annotated1232 #f (quote map))) ls2085))) (build-annotated1232 #f (cons (build-annotated1232 #f (car x2083)) (map regen2082 (cdr x2083)))))))))))) (gen-vector2081 (lambda (x2086) (cond ((eq? (car x2086) (quote list)) (cons (quote vector) (cdr x2086))) ((eq? (car x2086) (quote quote)) (list (quote quote) (list->vector (cadr x2086)))) (else (list (quote list->vector) x2086))))) (gen-append2080 (lambda (x2087 y2088) (if (equal? y2088 (quote (quote ()))) x2087 (list (quote append) x2087 y2088)))) (gen-cons2079 (lambda (x2089 y2090) (let ((t2091 (car y2090))) (if (memv t2091 (quote (quote))) (if (eq? (car x2089) (quote quote)) (list (quote quote) (cons (cadr x2089) (cadr y2090))) (if (eq? (cadr y2090) (quote ())) (list (quote list) x2089) (list (quote cons) x2089 y2090))) (if (memv t2091 (quote (list))) (cons (quote list) (cons x2089 (cdr y2090))) (list (quote cons) x2089 y2090)))))) (gen-map2078 (lambda (e2092 map-env2093) (let ((formals2094 (map cdr map-env2093)) (actuals2095 (map (lambda (x2096) (list (quote ref) (car x2096))) map-env2093))) (cond ((eq? (car e2092) (quote ref)) (car actuals2095)) ((and-map (lambda (x2097) (and (eq? (car x2097) (quote ref)) (memq (cadr x2097) formals2094))) (cdr e2092)) (cons (quote map) (cons (list (quote primitive) (car e2092)) (map (let ((r2098 (map cons formals2094 actuals2095))) (lambda (x2099) (cdr (assq (cadr x2099) r2098)))) (cdr e2092))))) (else (cons (quote map) (cons (list (quote lambda) formals2094 e2092) actuals2095))))))) (gen-mappend2077 (lambda (e2100 map-env2101) (list (quote apply) (quote (primitive append)) (gen-map2078 e2100 map-env2101)))) (gen-ref2076 (lambda (src2102 var2103 level2104 maps2105) (if (fx=1226 level2104 0) (values var2103 maps2105) (if (null? maps2105) (syntax-violation (quote syntax) "missing ellipsis" src2102) (call-with-values (lambda () (gen-ref2076 src2102 var2103 (fx-1225 level2104 1) (cdr maps2105))) (lambda (outer-var2106 outer-maps2107) (let ((b2108 (assq outer-var2106 (car maps2105)))) (if b2108 (values (cdr b2108) maps2105) (let ((inner-var2109 (gen-var1307 (quote tmp)))) (values inner-var2109 (cons (cons (cons outer-var2106 inner-var2109) (car maps2105)) outer-maps2107))))))))))) (gen-syntax2075 (lambda (src2110 e2111 r2112 maps2113 ellipsis?2114 mod2115) (if (id?1259 e2111) (let ((label2116 (id-var-name1281 e2111 (quote (()))))) (let ((b2117 (lookup1256 label2116 r2112 mod2115))) (if (eq? (binding-type1251 b2117) (quote syntax)) (call-with-values (lambda () (let ((var.lev2118 (binding-value1252 b2117))) (gen-ref2076 src2110 (car var.lev2118) (cdr var.lev2118) maps2113))) (lambda (var2119 maps2120) (values (list (quote ref) var2119) maps2120))) (if (ellipsis?2114 e2111) (syntax-violation (quote syntax) "misplaced ellipsis" src2110) (values (list (quote quote) e2111) maps2113))))) ((lambda (tmp2121) ((lambda (tmp2122) (if (if tmp2122 (apply (lambda (dots2123 e2124) (ellipsis?2114 dots2123)) tmp2122) #f) (apply (lambda (dots2125 e2126) (gen-syntax2075 src2110 e2126 r2112 maps2113 (lambda (x2127) #f) mod2115)) tmp2122) ((lambda (tmp2128) (if (if tmp2128 (apply (lambda (x2129 dots2130 y2131) (ellipsis?2114 dots2130)) tmp2128) #f) (apply (lambda (x2132 dots2133 y2134) (let f2135 ((y2136 y2134) (k2137 (lambda (maps2138) (call-with-values (lambda () (gen-syntax2075 src2110 x2132 r2112 (cons (quote ()) maps2138) ellipsis?2114 mod2115)) (lambda (x2139 maps2140) (if (null? (car maps2140)) (syntax-violation (quote syntax) "extra ellipsis" src2110) (values (gen-map2078 x2139 (car maps2140)) (cdr maps2140)))))))) ((lambda (tmp2141) ((lambda (tmp2142) (if (if tmp2142 (apply (lambda (dots2143 y2144) (ellipsis?2114 dots2143)) tmp2142) #f) (apply (lambda (dots2145 y2146) (f2135 y2146 (lambda (maps2147) (call-with-values (lambda () (k2137 (cons (quote ()) maps2147))) (lambda (x2148 maps2149) (if (null? (car maps2149)) (syntax-violation (quote syntax) "extra ellipsis" src2110) (values (gen-mappend2077 x2148 (car maps2149)) (cdr maps2149)))))))) tmp2142) ((lambda (_2150) (call-with-values (lambda () (gen-syntax2075 src2110 y2136 r2112 maps2113 ellipsis?2114 mod2115)) (lambda (y2151 maps2152) (call-with-values (lambda () (k2137 maps2152)) (lambda (x2153 maps2154) (values (gen-append2080 x2153 y2151) maps2154)))))) tmp2141))) ($sc-dispatch tmp2141 (quote (any . any))))) y2136))) tmp2128) ((lambda (tmp2155) (if tmp2155 (apply (lambda (x2156 y2157) (call-with-values (lambda () (gen-syntax2075 src2110 x2156 r2112 maps2113 ellipsis?2114 mod2115)) (lambda (x2158 maps2159) (call-with-values (lambda () (gen-syntax2075 src2110 y2157 r2112 maps2159 ellipsis?2114 mod2115)) (lambda (y2160 maps2161) (values (gen-cons2079 x2158 y2160) maps2161)))))) tmp2155) ((lambda (tmp2162) (if tmp2162 (apply (lambda (e12163 e22164) (call-with-values (lambda () (gen-syntax2075 src2110 (cons e12163 e22164) r2112 maps2113 ellipsis?2114 mod2115)) (lambda (e2166 maps2167) (values (gen-vector2081 e2166) maps2167)))) tmp2162) ((lambda (_2168) (values (list (quote quote) e2111) maps2113)) tmp2121))) ($sc-dispatch tmp2121 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2121 (quote (any . any)))))) ($sc-dispatch tmp2121 (quote (any any . any)))))) ($sc-dispatch tmp2121 (quote (any any))))) e2111))))) (lambda (e2169 r2170 w2171 s2172 mod2173) (let ((e2174 (source-wrap1288 e2169 w2171 s2172 mod2173))) ((lambda (tmp2175) ((lambda (tmp2176) (if tmp2176 (apply (lambda (_2177 x2178) (call-with-values (lambda () (gen-syntax2075 e2174 x2178 r2170 (quote ()) ellipsis?1304 mod2173)) (lambda (e2179 maps2180) (regen2082 e2179)))) tmp2176) ((lambda (_2181) (syntax-violation (quote syntax) "bad `syntax' form" e2174)) tmp2175))) ($sc-dispatch tmp2175 (quote (any any))))) e2174))))) (global-extend1257 (quote core) (quote lambda) (lambda (e2182 r2183 w2184 s2185 mod2186) ((lambda (tmp2187) ((lambda (tmp2188) (if tmp2188 (apply (lambda (_2189 c2190) (chi-lambda-clause1300 (source-wrap1288 e2182 w2184 s2185 mod2186) #f c2190 r2183 w2184 mod2186 (lambda (vars2191 docstring2192 body2193) (build-annotated1232 s2185 (cons (quote lambda) (cons vars2191 (append (if docstring2192 (list docstring2192) (quote ())) (list body2193)))))))) tmp2188) (syntax-violation #f "source expression failed to match any pattern" tmp2187))) ($sc-dispatch tmp2187 (quote (any . any))))) e2182))) (global-extend1257 (quote core) (quote let) (letrec ((chi-let2194 (lambda (e2195 r2196 w2197 s2198 mod2199 constructor2200 ids2201 vals2202 exps2203) (if (not (valid-bound-ids?1284 ids2201)) (syntax-violation (quote let) "duplicate bound variable" e2195) (let ((labels2204 (gen-labels1265 ids2201)) (new-vars2205 (map gen-var1307 ids2201))) (let ((nw2206 (make-binding-wrap1276 ids2201 labels2204 w2197)) (nr2207 (extend-var-env1254 labels2204 new-vars2205 r2196))) (constructor2200 s2198 new-vars2205 (map (lambda (x2208) (chi1295 x2208 r2196 w2197 mod2199)) vals2202) (chi-body1299 exps2203 (source-wrap1288 e2195 nw2206 s2198 mod2199) nr2207 nw2206 mod2199)))))))) (lambda (e2209 r2210 w2211 s2212 mod2213) ((lambda (tmp2214) ((lambda (tmp2215) (if tmp2215 (apply (lambda (_2216 id2217 val2218 e12219 e22220) (chi-let2194 e2209 r2210 w2211 s2212 mod2213 build-let1239 id2217 val2218 (cons e12219 e22220))) tmp2215) ((lambda (tmp2224) (if (if tmp2224 (apply (lambda (_2225 f2226 id2227 val2228 e12229 e22230) (id?1259 f2226)) tmp2224) #f) (apply (lambda (_2231 f2232 id2233 val2234 e12235 e22236) (chi-let2194 e2209 r2210 w2211 s2212 mod2213 build-named-let1240 (cons f2232 id2233) val2234 (cons e12235 e22236))) tmp2224) ((lambda (_2240) (syntax-violation (quote let) "bad let" (source-wrap1288 e2209 w2211 s2212 mod2213))) tmp2214))) ($sc-dispatch tmp2214 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2214 (quote (any #(each (any any)) any . each-any))))) e2209)))) (global-extend1257 (quote core) (quote letrec) (lambda (e2241 r2242 w2243 s2244 mod2245) ((lambda (tmp2246) ((lambda (tmp2247) (if tmp2247 (apply (lambda (_2248 id2249 val2250 e12251 e22252) (let ((ids2253 id2249)) (if (not (valid-bound-ids?1284 ids2253)) (syntax-violation (quote letrec) "duplicate bound variable" e2241) (let ((labels2255 (gen-labels1265 ids2253)) (new-vars2256 (map gen-var1307 ids2253))) (let ((w2257 (make-binding-wrap1276 ids2253 labels2255 w2243)) (r2258 (extend-var-env1254 labels2255 new-vars2256 r2242))) (build-letrec1241 s2244 new-vars2256 (map (lambda (x2259) (chi1295 x2259 r2258 w2257 mod2245)) val2250) (chi-body1299 (cons e12251 e22252) (source-wrap1288 e2241 w2257 s2244 mod2245) r2258 w2257 mod2245))))))) tmp2247) ((lambda (_2262) (syntax-violation (quote letrec) "bad letrec" (source-wrap1288 e2241 w2243 s2244 mod2245))) tmp2246))) ($sc-dispatch tmp2246 (quote (any #(each (any any)) any . each-any))))) e2241))) (global-extend1257 (quote core) (quote set!) (lambda (e2263 r2264 w2265 s2266 mod2267) ((lambda (tmp2268) ((lambda (tmp2269) (if (if tmp2269 (apply (lambda (_2270 id2271 val2272) (id?1259 id2271)) tmp2269) #f) (apply (lambda (_2273 id2274 val2275) (let ((val2276 (chi1295 val2275 r2264 w2265 mod2267)) (n2277 (id-var-name1281 id2274 w2265))) (let ((b2278 (lookup1256 n2277 r2264 mod2267))) (let ((t2279 (binding-type1251 b2278))) (if (memv t2279 (quote (lexical))) (build-lexical-assignment1234 s2266 (syntax->datum id2274) (binding-value1252 b2278) val2276) (if (memv t2279 (quote (global))) (build-global-assignment1236 s2266 n2277 val2276 mod2267) (if (memv t2279 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1287 id2274 w2265 mod2267)) (syntax-violation (quote set!) "bad set!" (source-wrap1288 e2263 w2265 s2266 mod2267))))))))) tmp2269) ((lambda (tmp2280) (if tmp2280 (apply (lambda (_2281 head2282 tail2283 val2284) (call-with-values (lambda () (syntax-type1293 head2282 r2264 (quote (())) #f #f mod2267)) (lambda (type2285 value2286 ee2287 ww2288 ss2289 modmod2290) (let ((t2291 type2285)) (if (memv t2291 (quote (module-ref))) (let ((val2292 (chi1295 val2284 r2264 w2265 mod2267))) (call-with-values (lambda () (value2286 (cons head2282 tail2283))) (lambda (id2294 mod2295) (build-global-assignment1236 s2266 id2294 val2292 mod2295)))) (build-annotated1232 s2266 (cons (chi1295 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2282) r2264 w2265 mod2267) (map (lambda (e2296) (chi1295 e2296 r2264 w2265 mod2267)) (append tail2283 (list val2284)))))))))) tmp2280) ((lambda (_2298) (syntax-violation (quote set!) "bad set!" (source-wrap1288 e2263 w2265 s2266 mod2267))) tmp2268))) ($sc-dispatch tmp2268 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2268 (quote (any any any))))) e2263))) (global-extend1257 (quote module-ref) (quote @) (lambda (e2299) ((lambda (tmp2300) ((lambda (tmp2301) (if (if tmp2301 (apply (lambda (_2302 mod2303 id2304) (and (and-map id?1259 mod2303) (id?1259 id2304))) tmp2301) #f) (apply (lambda (_2306 mod2307 id2308) (values (syntax->datum id2308) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2307)))) tmp2301) (syntax-violation #f "source expression failed to match any pattern" tmp2300))) ($sc-dispatch tmp2300 (quote (any each-any any))))) e2299))) (global-extend1257 (quote module-ref) (quote @@) (lambda (e2310) ((lambda (tmp2311) ((lambda (tmp2312) (if (if tmp2312 (apply (lambda (_2313 mod2314 id2315) (and (and-map id?1259 mod2314) (id?1259 id2315))) tmp2312) #f) (apply (lambda (_2317 mod2318 id2319) (values (syntax->datum id2319) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2318)))) tmp2312) (syntax-violation #f "source expression failed to match any pattern" tmp2311))) ($sc-dispatch tmp2311 (quote (any each-any any))))) e2310))) (global-extend1257 (quote begin) (quote begin) (quote ())) (global-extend1257 (quote define) (quote define) (quote ())) (global-extend1257 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1257 (quote eval-when) (quote eval-when) (quote ())) (global-extend1257 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2324 (lambda (x2325 keys2326 clauses2327 r2328 mod2329) (if (null? clauses2327) (build-annotated1232 #f (list (build-annotated1232 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2325)) ((lambda (tmp2330) ((lambda (tmp2331) (if tmp2331 (apply (lambda (pat2332 exp2333) (if (and (id?1259 pat2332) (and-map (lambda (x2334) (not (free-id=?1282 pat2332 x2334))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2326))) (let ((labels2335 (list (gen-label1264))) (var2336 (gen-var1307 pat2332))) (build-annotated1232 #f (list (build-annotated1232 #f (list (quote lambda) (list var2336) (chi1295 exp2333 (extend-env1253 labels2335 (list (cons (quote syntax) (cons var2336 0))) r2328) (make-binding-wrap1276 (list pat2332) labels2335 (quote (()))) mod2329))) x2325))) (gen-clause2323 x2325 keys2326 (cdr clauses2327) r2328 pat2332 #t exp2333 mod2329))) tmp2331) ((lambda (tmp2337) (if tmp2337 (apply (lambda (pat2338 fender2339 exp2340) (gen-clause2323 x2325 keys2326 (cdr clauses2327) r2328 pat2338 fender2339 exp2340 mod2329)) tmp2337) ((lambda (_2341) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2327))) tmp2330))) ($sc-dispatch tmp2330 (quote (any any any)))))) ($sc-dispatch tmp2330 (quote (any any))))) (car clauses2327))))) (gen-clause2323 (lambda (x2342 keys2343 clauses2344 r2345 pat2346 fender2347 exp2348 mod2349) (call-with-values (lambda () (convert-pattern2321 pat2346 keys2343)) (lambda (p2350 pvars2351) (cond ((not (distinct-bound-ids?1285 (map car pvars2351))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2346)) ((not (and-map (lambda (x2352) (not (ellipsis?1304 (car x2352)))) pvars2351)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2346)) (else (let ((y2353 (gen-var1307 (quote tmp)))) (build-annotated1232 #f (list (build-annotated1232 #f (list (quote lambda) (list y2353) (let ((y2354 (build-lexical-reference1233 (quote value) #f (quote tmp) y2353))) (build-annotated1232 #f (list (quote if) ((lambda (tmp2355) ((lambda (tmp2356) (if tmp2356 (apply (lambda () y2354) tmp2356) ((lambda (_2357) (build-annotated1232 #f (list (quote if) y2354 (build-dispatch-call2322 pvars2351 fender2347 y2354 r2345 mod2349) (build-data1237 #f #f)))) tmp2355))) ($sc-dispatch tmp2355 (quote #(atom #t))))) fender2347) (build-dispatch-call2322 pvars2351 exp2348 y2354 r2345 mod2349) (gen-syntax-case2324 x2342 keys2343 clauses2344 r2345 mod2349)))))) (if (eq? p2350 (quote any)) (build-annotated1232 #f (list (build-annotated1232 #f (quote list)) x2342)) (build-annotated1232 #f (list (build-annotated1232 #f (quote $sc-dispatch)) x2342 (build-data1237 #f p2350))))))))))))) (build-dispatch-call2322 (lambda (pvars2358 exp2359 y2360 r2361 mod2362) (let ((ids2363 (map car pvars2358)) (levels2364 (map cdr pvars2358))) (let ((labels2365 (gen-labels1265 ids2363)) (new-vars2366 (map gen-var1307 ids2363))) (build-annotated1232 #f (list (build-annotated1232 #f (quote apply)) (build-annotated1232 #f (list (quote lambda) new-vars2366 (chi1295 exp2359 (extend-env1253 labels2365 (map (lambda (var2367 level2368) (cons (quote syntax) (cons var2367 level2368))) new-vars2366 (map cdr pvars2358)) r2361) (make-binding-wrap1276 ids2363 labels2365 (quote (()))) mod2362))) y2360)))))) (convert-pattern2321 (lambda (pattern2369 keys2370) (let cvt2371 ((p2372 pattern2369) (n2373 0) (ids2374 (quote ()))) (if (id?1259 p2372) (if (bound-id-member?1286 p2372 keys2370) (values (vector (quote free-id) p2372) ids2374) (values (quote any) (cons (cons p2372 n2373) ids2374))) ((lambda (tmp2375) ((lambda (tmp2376) (if (if tmp2376 (apply (lambda (x2377 dots2378) (ellipsis?1304 dots2378)) tmp2376) #f) (apply (lambda (x2379 dots2380) (call-with-values (lambda () (cvt2371 x2379 (fx+1224 n2373 1) ids2374)) (lambda (p2381 ids2382) (values (if (eq? p2381 (quote any)) (quote each-any) (vector (quote each) p2381)) ids2382)))) tmp2376) ((lambda (tmp2383) (if tmp2383 (apply (lambda (x2384 y2385) (call-with-values (lambda () (cvt2371 y2385 n2373 ids2374)) (lambda (y2386 ids2387) (call-with-values (lambda () (cvt2371 x2384 n2373 ids2387)) (lambda (x2388 ids2389) (values (cons x2388 y2386) ids2389)))))) tmp2383) ((lambda (tmp2390) (if tmp2390 (apply (lambda () (values (quote ()) ids2374)) tmp2390) ((lambda (tmp2391) (if tmp2391 (apply (lambda (x2392) (call-with-values (lambda () (cvt2371 x2392 n2373 ids2374)) (lambda (p2394 ids2395) (values (vector (quote vector) p2394) ids2395)))) tmp2391) ((lambda (x2396) (values (vector (quote atom) (strip1306 p2372 (quote (())))) ids2374)) tmp2375))) ($sc-dispatch tmp2375 (quote #(vector each-any)))))) ($sc-dispatch tmp2375 (quote ()))))) ($sc-dispatch tmp2375 (quote (any . any)))))) ($sc-dispatch tmp2375 (quote (any any))))) p2372)))))) (lambda (e2397 r2398 w2399 s2400 mod2401) (let ((e2402 (source-wrap1288 e2397 w2399 s2400 mod2401))) ((lambda (tmp2403) ((lambda (tmp2404) (if tmp2404 (apply (lambda (_2405 val2406 key2407 m2408) (if (and-map (lambda (x2409) (and (id?1259 x2409) (not (ellipsis?1304 x2409)))) key2407) (let ((x2411 (gen-var1307 (quote tmp)))) (build-annotated1232 s2400 (list (build-annotated1232 #f (list (quote lambda) (list x2411) (gen-syntax-case2324 (build-lexical-reference1233 (quote value) #f (quote tmp) x2411) key2407 m2408 r2398 mod2401))) (chi1295 val2406 r2398 (quote (())) mod2401)))) (syntax-violation (quote syntax-case) "invalid literals list" e2402))) tmp2404) (syntax-violation #f "source expression failed to match any pattern" tmp2403))) ($sc-dispatch tmp2403 (quote (any any each-any . each-any))))) e2402))))) (set! sc-expand (lambda (x2415 . rest2414) (if (and (pair? x2415) (equal? (car x2415) noexpand1222)) (cadr x2415) (let ((m2416 (if (null? rest2414) (quote e) (car rest2414))) (esew2417 (if (or (null? rest2414) (null? (cdr rest2414))) (quote (eval)) (cadr rest2414)))) (with-fluid* *mode*1223 m2416 (lambda () (chi-top1294 x2415 (quote ()) (quote ((top))) m2416 esew2417 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x2418) (nonsymbol-id?1258 x2418))) (set! datum->syntax (lambda (id2419 datum2420) (make-syntax-object1242 datum2420 (syntax-object-wrap1245 id2419) #f))) (set! syntax->datum (lambda (x2421) (strip1306 x2421 (quote (()))))) (set! generate-temporaries (lambda (ls2422) (begin (let ((x2423 ls2422)) (if (not (list? x2423)) (syntax-violation (quote generate-temporaries) "invalid argument" x2423))) (map (lambda (x2424) (wrap1287 (gensym) (quote ((top))) #f)) ls2422)))) (set! free-identifier=? (lambda (x2425 y2426) (begin (let ((x2427 x2425)) (if (not (nonsymbol-id?1258 x2427)) (syntax-violation (quote free-identifier=?) "invalid argument" x2427))) (let ((x2428 y2426)) (if (not (nonsymbol-id?1258 x2428)) (syntax-violation (quote free-identifier=?) "invalid argument" x2428))) (free-id=?1282 x2425 y2426)))) (set! bound-identifier=? (lambda (x2429 y2430) (begin (let ((x2431 x2429)) (if (not (nonsymbol-id?1258 x2431)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2431))) (let ((x2432 y2430)) (if (not (nonsymbol-id?1258 x2432)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2432))) (bound-id=?1283 x2429 y2430)))) (set! syntax-violation (lambda (who2436 message2435 form2434 . subform2433) (begin (let ((x2437 who2436)) (if (not ((lambda (x2438) (or (not x2438) (string? x2438) (symbol? x2438))) x2437)) (syntax-violation (quote syntax-violation) "invalid argument" x2437))) (let ((x2439 message2435)) (if (not (string? x2439)) (syntax-violation (quote syntax-violation) "invalid argument" x2439))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2436 "~a: " "") "~a " (if (null? subform2433) "in ~a" "in subform `~s' of `~s'")) (let ((tail2440 (cons message2435 (map (lambda (x2441) (strip1306 x2441 (quote (())))) (append subform2433 (list form2434)))))) (if who2436 (cons who2436 tail2440) tail2440)) #f)))) (letrec ((match2446 (lambda (e2447 p2448 w2449 r2450 mod2451) (cond ((not r2450) #f) ((eq? p2448 (quote any)) (cons (wrap1287 e2447 w2449 mod2451) r2450)) ((syntax-object?1243 e2447) (match*2445 (let ((e2452 (syntax-object-expression1244 e2447))) (if (annotation? e2452) (annotation-expression e2452) e2452)) p2448 (join-wraps1278 w2449 (syntax-object-wrap1245 e2447)) r2450 (syntax-object-module1246 e2447))) (else (match*2445 (let ((e2453 e2447)) (if (annotation? e2453) (annotation-expression e2453) e2453)) p2448 w2449 r2450 mod2451))))) (match*2445 (lambda (e2454 p2455 w2456 r2457 mod2458) (cond ((null? p2455) (and (null? e2454) r2457)) ((pair? p2455) (and (pair? e2454) (match2446 (car e2454) (car p2455) w2456 (match2446 (cdr e2454) (cdr p2455) w2456 r2457 mod2458) mod2458))) ((eq? p2455 (quote each-any)) (let ((l2459 (match-each-any2443 e2454 w2456 mod2458))) (and l2459 (cons l2459 r2457)))) (else (let ((t2460 (vector-ref p2455 0))) (if (memv t2460 (quote (each))) (if (null? e2454) (match-empty2444 (vector-ref p2455 1) r2457) (let ((l2461 (match-each2442 e2454 (vector-ref p2455 1) w2456 mod2458))) (and l2461 (let collect2462 ((l2463 l2461)) (if (null? (car l2463)) r2457 (cons (map car l2463) (collect2462 (map cdr l2463)))))))) (if (memv t2460 (quote (free-id))) (and (id?1259 e2454) (free-id=?1282 (wrap1287 e2454 w2456 mod2458) (vector-ref p2455 1)) r2457) (if (memv t2460 (quote (atom))) (and (equal? (vector-ref p2455 1) (strip1306 e2454 w2456)) r2457) (if (memv t2460 (quote (vector))) (and (vector? e2454) (match2446 (vector->list e2454) (vector-ref p2455 1) w2456 r2457 mod2458))))))))))) (match-empty2444 (lambda (p2464 r2465) (cond ((null? p2464) r2465) ((eq? p2464 (quote any)) (cons (quote ()) r2465)) ((pair? p2464) (match-empty2444 (car p2464) (match-empty2444 (cdr p2464) r2465))) ((eq? p2464 (quote each-any)) (cons (quote ()) r2465)) (else (let ((t2466 (vector-ref p2464 0))) (if (memv t2466 (quote (each))) (match-empty2444 (vector-ref p2464 1) r2465) (if (memv t2466 (quote (free-id atom))) r2465 (if (memv t2466 (quote (vector))) (match-empty2444 (vector-ref p2464 1) r2465))))))))) (match-each-any2443 (lambda (e2467 w2468 mod2469) (cond ((annotation? e2467) (match-each-any2443 (annotation-expression e2467) w2468 mod2469)) ((pair? e2467) (let ((l2470 (match-each-any2443 (cdr e2467) w2468 mod2469))) (and l2470 (cons (wrap1287 (car e2467) w2468 mod2469) l2470)))) ((null? e2467) (quote ())) ((syntax-object?1243 e2467) (match-each-any2443 (syntax-object-expression1244 e2467) (join-wraps1278 w2468 (syntax-object-wrap1245 e2467)) mod2469)) (else #f)))) (match-each2442 (lambda (e2471 p2472 w2473 mod2474) (cond ((annotation? e2471) (match-each2442 (annotation-expression e2471) p2472 w2473 mod2474)) ((pair? e2471) (let ((first2475 (match2446 (car e2471) p2472 w2473 (quote ()) mod2474))) (and first2475 (let ((rest2476 (match-each2442 (cdr e2471) p2472 w2473 mod2474))) (and rest2476 (cons first2475 rest2476)))))) ((null? e2471) (quote ())) ((syntax-object?1243 e2471) (match-each2442 (syntax-object-expression1244 e2471) p2472 (join-wraps1278 w2473 (syntax-object-wrap1245 e2471)) (syntax-object-module1246 e2471))) (else #f))))) (set! $sc-dispatch (lambda (e2477 p2478) (cond ((eq? p2478 (quote any)) (list e2477)) ((syntax-object?1243 e2477) (match*2445 (let ((e2479 (syntax-object-expression1244 e2477))) (if (annotation? e2479) (annotation-expression e2479) e2479)) p2478 (syntax-object-wrap1245 e2477) (quote ()) (syntax-object-module1246 e2477))) (else (match*2445 (let ((e2480 e2477)) (if (annotation? e2480) (annotation-expression e2480) e2480)) p2478 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (_2484 e12485 e22486) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12485 e22486))) tmp2483) ((lambda (tmp2488) (if tmp2488 (apply (lambda (_2489 out2490 in2491 e12492 e22493) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2491 (quote ()) (list out2490 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12492 e22493))))) tmp2488) ((lambda (tmp2495) (if tmp2495 (apply (lambda (_2496 out2497 in2498 e12499 e22500) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2498) (quote ()) (list out2497 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12499 e22500))))) tmp2495) (syntax-violation #f "source expression failed to match any pattern" tmp2482))) ($sc-dispatch tmp2482 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2482 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2482 (quote (any () any . each-any))))) x2481)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2504) ((lambda (tmp2505) ((lambda (tmp2506) (if tmp2506 (apply (lambda (_2507 k2508 keyword2509 pattern2510 template2511) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2508 (map (lambda (tmp2514 tmp2513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2514))) template2511 pattern2510)))))) tmp2506) (syntax-violation #f "source expression failed to match any pattern" tmp2505))) ($sc-dispatch tmp2505 (quote (any each-any . #(each ((any . any) any))))))) x2504)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2515) ((lambda (tmp2516) ((lambda (tmp2517) (if (if tmp2517 (apply (lambda (let*2518 x2519 v2520 e12521 e22522) (and-map identifier? x2519)) tmp2517) #f) (apply (lambda (let*2524 x2525 v2526 e12527 e22528) (let f2529 ((bindings2530 (map list x2525 v2526))) (if (null? bindings2530) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12527 e22528))) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (body2536 binding2537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2537) body2536)) tmp2535) (syntax-violation #f "source expression failed to match any pattern" tmp2534))) ($sc-dispatch tmp2534 (quote (any any))))) (list (f2529 (cdr bindings2530)) (car bindings2530)))))) tmp2517) (syntax-violation #f "source expression failed to match any pattern" tmp2516))) ($sc-dispatch tmp2516 (quote (any #(each (any any)) any . each-any))))) x2515)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2538) ((lambda (tmp2539) ((lambda (tmp2540) (if tmp2540 (apply (lambda (_2541 var2542 init2543 step2544 e02545 e12546 c2547) ((lambda (tmp2548) ((lambda (tmp2549) (if tmp2549 (apply (lambda (step2550) ((lambda (tmp2551) ((lambda (tmp2552) (if tmp2552 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2542 init2543) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02545) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2550))))))) tmp2552) ((lambda (tmp2557) (if tmp2557 (apply (lambda (e12558 e22559) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2542 init2543) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02545 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12558 e22559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2550))))))) tmp2557) (syntax-violation #f "source expression failed to match any pattern" tmp2551))) ($sc-dispatch tmp2551 (quote (any . each-any)))))) ($sc-dispatch tmp2551 (quote ())))) e12546)) tmp2549) (syntax-violation #f "source expression failed to match any pattern" tmp2548))) ($sc-dispatch tmp2548 (quote each-any)))) (map (lambda (v2566 s2567) ((lambda (tmp2568) ((lambda (tmp2569) (if tmp2569 (apply (lambda () v2566) tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (e2571) e2571) tmp2570) ((lambda (_2572) (syntax-violation (quote do) "bad step expression" orig-x2538 s2567)) tmp2568))) ($sc-dispatch tmp2568 (quote (any)))))) ($sc-dispatch tmp2568 (quote ())))) s2567)) var2542 step2544))) tmp2540) (syntax-violation #f "source expression failed to match any pattern" tmp2539))) ($sc-dispatch tmp2539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2538)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2575 (lambda (x2579 y2580) ((lambda (tmp2581) ((lambda (tmp2582) (if tmp2582 (apply (lambda (x2583 y2584) ((lambda (tmp2585) ((lambda (tmp2586) (if tmp2586 (apply (lambda (dy2587) ((lambda (tmp2588) ((lambda (tmp2589) (if tmp2589 (apply (lambda (dx2590) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2590 dy2587))) tmp2589) ((lambda (_2591) (if (null? dy2587) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2583) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2583 y2584))) tmp2588))) ($sc-dispatch tmp2588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2583)) tmp2586) ((lambda (tmp2592) (if tmp2592 (apply (lambda (stuff2593) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2583 stuff2593))) tmp2592) ((lambda (else2594) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2583 y2584)) tmp2585))) ($sc-dispatch tmp2585 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2584)) tmp2582) (syntax-violation #f "source expression failed to match any pattern" tmp2581))) ($sc-dispatch tmp2581 (quote (any any))))) (list x2579 y2580)))) (quasiappend2576 (lambda (x2595 y2596) ((lambda (tmp2597) ((lambda (tmp2598) (if tmp2598 (apply (lambda (x2599 y2600) ((lambda (tmp2601) ((lambda (tmp2602) (if tmp2602 (apply (lambda () x2599) tmp2602) ((lambda (_2603) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2599 y2600)) tmp2601))) ($sc-dispatch tmp2601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2600)) tmp2598) (syntax-violation #f "source expression failed to match any pattern" tmp2597))) ($sc-dispatch tmp2597 (quote (any any))))) (list x2595 y2596)))) (quasivector2577 (lambda (x2604) ((lambda (tmp2605) ((lambda (x2606) ((lambda (tmp2607) ((lambda (tmp2608) (if tmp2608 (apply (lambda (x2609) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2609))) tmp2608) ((lambda (tmp2611) (if tmp2611 (apply (lambda (x2612) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2612)) tmp2611) ((lambda (_2614) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2606)) tmp2607))) ($sc-dispatch tmp2607 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2606)) tmp2605)) x2604))) (quasi2578 (lambda (p2615 lev2616) ((lambda (tmp2617) ((lambda (tmp2618) (if tmp2618 (apply (lambda (p2619) (if (= lev2616 0) p2619 (quasicons2575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2578 (list p2619) (- lev2616 1))))) tmp2618) ((lambda (tmp2620) (if tmp2620 (apply (lambda (p2621 q2622) (if (= lev2616 0) (quasiappend2576 p2621 (quasi2578 q2622 lev2616)) (quasicons2575 (quasicons2575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2578 (list p2621) (- lev2616 1))) (quasi2578 q2622 lev2616)))) tmp2620) ((lambda (tmp2623) (if tmp2623 (apply (lambda (p2624) (quasicons2575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2578 (list p2624) (+ lev2616 1)))) tmp2623) ((lambda (tmp2625) (if tmp2625 (apply (lambda (p2626 q2627) (quasicons2575 (quasi2578 p2626 lev2616) (quasi2578 q2627 lev2616))) tmp2625) ((lambda (tmp2628) (if tmp2628 (apply (lambda (x2629) (quasivector2577 (quasi2578 x2629 lev2616))) tmp2628) ((lambda (p2631) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2631)) tmp2617))) ($sc-dispatch tmp2617 (quote #(vector each-any)))))) ($sc-dispatch tmp2617 (quote (any . any)))))) ($sc-dispatch tmp2617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2615)))) (lambda (x2632) ((lambda (tmp2633) ((lambda (tmp2634) (if tmp2634 (apply (lambda (_2635 e2636) (quasi2578 e2636 0)) tmp2634) (syntax-violation #f "source expression failed to match any pattern" tmp2633))) ($sc-dispatch tmp2633 (quote (any any))))) x2632))))) -(define include (make-syncase-macro (quote macro) (lambda (x2637) (letrec ((read-file2638 (lambda (fn2639 k2640) (let ((p2641 (open-input-file fn2639))) (let f2642 ((x2643 (read p2641))) (if (eof-object? x2643) (begin (close-input-port p2641) (quote ())) (cons (datum->syntax k2640 x2643) (f2642 (read p2641))))))))) ((lambda (tmp2644) ((lambda (tmp2645) (if tmp2645 (apply (lambda (k2646 filename2647) (let ((fn2648 (syntax->datum filename2647))) ((lambda (tmp2649) ((lambda (tmp2650) (if tmp2650 (apply (lambda (exp2651) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2651)) tmp2650) (syntax-violation #f "source expression failed to match any pattern" tmp2649))) ($sc-dispatch tmp2649 (quote each-any)))) (read-file2638 fn2648 k2646)))) tmp2645) (syntax-violation #f "source expression failed to match any pattern" tmp2644))) ($sc-dispatch tmp2644 (quote (any any))))) x2637))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x2653) ((lambda (tmp2654) ((lambda (tmp2655) (if tmp2655 (apply (lambda (_2656 e2657) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2653)) tmp2655) (syntax-violation #f "source expression failed to match any pattern" tmp2654))) ($sc-dispatch tmp2654 (quote (any any))))) x2653)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2658) ((lambda (tmp2659) ((lambda (tmp2660) (if tmp2660 (apply (lambda (_2661 e2662) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2658)) tmp2660) (syntax-violation #f "source expression failed to match any pattern" tmp2659))) ($sc-dispatch tmp2659 (quote (any any))))) x2658)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2663) ((lambda (tmp2664) ((lambda (tmp2665) (if tmp2665 (apply (lambda (_2666 e2667 m12668 m22669) ((lambda (tmp2670) ((lambda (body2671) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2667)) body2671)) tmp2670)) (let f2672 ((clause2673 m12668) (clauses2674 m22669)) (if (null? clauses2674) ((lambda (tmp2676) ((lambda (tmp2677) (if tmp2677 (apply (lambda (e12678 e22679) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12678 e22679))) tmp2677) ((lambda (tmp2681) (if tmp2681 (apply (lambda (k2682 e12683 e22684) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2682)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12683 e22684)))) tmp2681) ((lambda (_2687) (syntax-violation (quote case) "bad clause" x2663 clause2673)) tmp2676))) ($sc-dispatch tmp2676 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2676 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2673) ((lambda (tmp2688) ((lambda (rest2689) ((lambda (tmp2690) ((lambda (tmp2691) (if tmp2691 (apply (lambda (k2692 e12693 e22694) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2692)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12693 e22694)) rest2689)) tmp2691) ((lambda (_2697) (syntax-violation (quote case) "bad clause" x2663 clause2673)) tmp2690))) ($sc-dispatch tmp2690 (quote (each-any any . each-any))))) clause2673)) tmp2688)) (f2672 (car clauses2674) (cdr clauses2674))))))) tmp2665) (syntax-violation #f "source expression failed to match any pattern" tmp2664))) ($sc-dispatch tmp2664 (quote (any any any . each-any))))) x2663)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2698) ((lambda (tmp2699) ((lambda (tmp2700) (if tmp2700 (apply (lambda (_2701 e2702) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2702)) (list (cons _2701 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2702 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2700) (syntax-violation #f "source expression failed to match any pattern" tmp2699))) ($sc-dispatch tmp2699 (quote (any any))))) x2698)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list155 (lambda (vars330) (let lvl331 ((vars332 vars330) (ls333 (quote ())) (w334 (quote (())))) (cond ((pair? vars332) (lvl331 (cdr vars332) (cons (wrap134 (car vars332) w334 #f) ls333) w334)) ((id?106 vars332) (cons (wrap134 vars332 w334 #f) ls333)) ((null? vars332) ls333) ((syntax-object?90 vars332) (lvl331 (syntax-object-expression91 vars332) ls333 (join-wraps125 w334 (syntax-object-wrap92 vars332)))) ((annotation? vars332) (lvl331 (annotation-expression vars332) ls333 w334)) (else (cons vars332 ls333)))))) (gen-var154 (lambda (id335) (let ((id336 (if (syntax-object?90 id335) (syntax-object-expression91 id335) id335))) (if (annotation? id336) (build-annotated79 (annotation-source id336) (gensym (symbol->string (annotation-expression id336)))) (build-annotated79 #f (gensym (symbol->string id336))))))) (strip153 (lambda (x337 w338) (if (memq (quote top) (wrap-marks109 w338)) (if (or (annotation? x337) (and (pair? x337) (annotation? (car x337)))) (strip-annotation152 x337 #f) x337) (let f339 ((x340 x337)) (cond ((syntax-object?90 x340) (strip153 (syntax-object-expression91 x340) (syntax-object-wrap92 x340))) ((pair? x340) (let ((a341 (f339 (car x340))) (d342 (f339 (cdr x340)))) (if (and (eq? a341 (car x340)) (eq? d342 (cdr x340))) x340 (cons a341 d342)))) ((vector? x340) (let ((old343 (vector->list x340))) (let ((new344 (map f339 old343))) (if (and-map*17 eq? old343 new344) x340 (list->vector new344))))) (else x340)))))) (strip-annotation152 (lambda (x345 parent346) (cond ((pair? x345) (let ((new347 (cons #f #f))) (begin (if parent346 (set-annotation-stripped! parent346 new347)) (set-car! new347 (strip-annotation152 (car x345) #f)) (set-cdr! new347 (strip-annotation152 (cdr x345) #f)) new347))) ((annotation? x345) (or (annotation-stripped x345) (strip-annotation152 (annotation-expression x345) x345))) ((vector? x345) (let ((new348 (make-vector (vector-length x345)))) (begin (if parent346 (set-annotation-stripped! parent346 new348)) (let loop349 ((i350 (- (vector-length x345) 1))) (unless (fx<74 i350 0) (vector-set! new348 i350 (strip-annotation152 (vector-ref x345 i350) #f)) (loop349 (fx-72 i350 1)))) new348))) (else x345)))) (ellipsis?151 (lambda (x351) (and (nonsymbol-id?105 x351) (free-id=?129 x351 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void150 (lambda () (build-annotated79 #f (cons (build-annotated79 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer149 (lambda (expanded352 mod353) (let ((p354 (local-eval-hook76 expanded352 mod353))) (if (procedure? p354) p354 (syntax-violation #f "nonprocedure transformer" p354))))) (chi-local-syntax148 (lambda (rec?355 e356 r357 w358 s359 mod360 k361) ((lambda (tmp362) ((lambda (tmp363) (if tmp363 (apply (lambda (_364 id365 val366 e1367 e2368) (let ((ids369 id365)) (if (not (valid-bound-ids?131 ids369)) (syntax-violation #f "duplicate bound keyword" e356) (let ((labels371 (gen-labels112 ids369))) (let ((new-w372 (make-binding-wrap123 ids369 labels371 w358))) (k361 (cons e1367 e2368) (extend-env100 labels371 (let ((w374 (if rec?355 new-w372 w358)) (trans-r375 (macros-only-env102 r357))) (map (lambda (x376) (cons (quote macro) (eval-local-transformer149 (chi142 x376 trans-r375 w374 mod360) mod360))) val366)) r357) new-w372 s359 mod360)))))) tmp363) ((lambda (_378) (syntax-violation #f "bad local syntax definition" (source-wrap135 e356 w358 s359 mod360))) tmp362))) ($sc-dispatch tmp362 (quote (any #(each (any any)) any . each-any))))) e356))) (chi-lambda-clause147 (lambda (e379 docstring380 c381 r382 w383 mod384 k385) ((lambda (tmp386) ((lambda (tmp387) (if (if tmp387 (apply (lambda (args388 doc389 e1390 e2391) (and (string? (syntax->datum doc389)) (not docstring380))) tmp387) #f) (apply (lambda (args392 doc393 e1394 e2395) (chi-lambda-clause147 e379 doc393 (cons args392 (cons e1394 e2395)) r382 w383 mod384 k385)) tmp387) ((lambda (tmp397) (if tmp397 (apply (lambda (id398 e1399 e2400) (let ((ids401 id398)) (if (not (valid-bound-ids?131 ids401)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels403 (gen-labels112 ids401)) (new-vars404 (map gen-var154 ids401))) (k385 new-vars404 docstring380 (chi-body146 (cons e1399 e2400) e379 (extend-var-env101 labels403 new-vars404 r382) (make-binding-wrap123 ids401 labels403 w383) mod384)))))) tmp397) ((lambda (tmp406) (if tmp406 (apply (lambda (ids407 e1408 e2409) (let ((old-ids410 (lambda-var-list155 ids407))) (if (not (valid-bound-ids?131 old-ids410)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels411 (gen-labels112 old-ids410)) (new-vars412 (map gen-var154 old-ids410))) (k385 (let f413 ((ls1414 (cdr new-vars412)) (ls2415 (car new-vars412))) (if (null? ls1414) ls2415 (f413 (cdr ls1414) (cons (car ls1414) ls2415)))) docstring380 (chi-body146 (cons e1408 e2409) e379 (extend-var-env101 labels411 new-vars412 r382) (make-binding-wrap123 old-ids410 labels411 w383) mod384)))))) tmp406) ((lambda (_417) (syntax-violation (quote lambda) "bad lambda" e379)) tmp386))) ($sc-dispatch tmp386 (quote (any any . each-any)))))) ($sc-dispatch tmp386 (quote (each-any any . each-any)))))) ($sc-dispatch tmp386 (quote (any any any . each-any))))) c381))) (chi-body146 (lambda (body418 outer-form419 r420 w421 mod422) (let ((r423 (cons (quote ("placeholder" placeholder)) r420))) (let ((ribcage424 (make-ribcage113 (quote ()) (quote ()) (quote ())))) (let ((w425 (make-wrap108 (wrap-marks109 w421) (cons ribcage424 (wrap-subst110 w421))))) (let parse426 ((body427 (map (lambda (x433) (cons r423 (wrap134 x433 w425 mod422))) body418)) (ids428 (quote ())) (labels429 (quote ())) (vars430 (quote ())) (vals431 (quote ())) (bindings432 (quote ()))) (if (null? body427) (syntax-violation #f "no expressions in body" outer-form419) (let ((e434 (cdar body427)) (er435 (caar body427))) (call-with-values (lambda () (syntax-type140 e434 er435 (quote (())) #f ribcage424 mod422)) (lambda (type436 value437 e438 w439 s440 mod441) (let ((t442 type436)) (if (memv t442 (quote (define-form))) (let ((id443 (wrap134 value437 w439 mod441)) (label444 (gen-label111))) (let ((var445 (gen-var154 id443))) (begin (extend-ribcage!122 ribcage424 id443 label444) (parse426 (cdr body427) (cons id443 ids428) (cons label444 labels429) (cons var445 vars430) (cons (cons er435 (wrap134 e438 w439 mod441)) vals431) (cons (cons (quote lexical) var445) bindings432))))) (if (memv t442 (quote (define-syntax-form))) (let ((id446 (wrap134 value437 w439 mod441)) (label447 (gen-label111))) (begin (extend-ribcage!122 ribcage424 id446 label447) (parse426 (cdr body427) (cons id446 ids428) (cons label447 labels429) vars430 vals431 (cons (cons (quote macro) (cons er435 (wrap134 e438 w439 mod441))) bindings432)))) (if (memv t442 (quote (begin-form))) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (_450 e1451) (parse426 (let f452 ((forms453 e1451)) (if (null? forms453) (cdr body427) (cons (cons er435 (wrap134 (car forms453) w439 mod441)) (f452 (cdr forms453))))) ids428 labels429 vars430 vals431 bindings432)) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e438) (if (memv t442 (quote (local-syntax-form))) (chi-local-syntax148 value437 e438 er435 w439 s440 mod441 (lambda (forms455 er456 w457 s458 mod459) (parse426 (let f460 ((forms461 forms455)) (if (null? forms461) (cdr body427) (cons (cons er456 (wrap134 (car forms461) w457 mod459)) (f460 (cdr forms461))))) ids428 labels429 vars430 vals431 bindings432))) (if (null? ids428) (build-sequence85 #f (map (lambda (x462) (chi142 (cdr x462) (car x462) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))) (begin (if (not (valid-bound-ids?131 ids428)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form419)) (let loop463 ((bs464 bindings432) (er-cache465 #f) (r-cache466 #f)) (if (not (null? bs464)) (let ((b467 (car bs464))) (if (eq? (car b467) (quote macro)) (let ((er468 (cadr b467))) (let ((r-cache469 (if (eq? er468 er-cache465) r-cache466 (macros-only-env102 er468)))) (begin (set-cdr! b467 (eval-local-transformer149 (chi142 (cddr b467) r-cache469 (quote (())) mod441) mod441)) (loop463 (cdr bs464) er468 r-cache469)))) (loop463 (cdr bs464) er-cache465 r-cache466))))) (set-cdr! r423 (extend-env100 labels429 bindings432 (cdr r423))) (build-letrec88 #f vars430 (map (lambda (x470) (chi142 (cdr x470) (car x470) (quote (())) mod441)) vals431) (build-sequence85 #f (map (lambda (x471) (chi142 (cdr x471) (car x471) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))))))))))))))))))))) (chi-macro145 (lambda (p472 e473 r474 w475 rib476 mod477) (letrec ((rebuild-macro-output478 (lambda (x479 m480) (cond ((pair? x479) (cons (rebuild-macro-output478 (car x479) m480) (rebuild-macro-output478 (cdr x479) m480))) ((syntax-object?90 x479) (let ((w481 (syntax-object-wrap92 x479))) (let ((ms482 (wrap-marks109 w481)) (s483 (wrap-subst110 w481))) (if (and (pair? ms482) (eq? (car ms482) #f)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cdr ms482) (if rib476 (cons rib476 (cdr s483)) (cdr s483))) (syntax-object-module93 x479)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cons m480 ms482) (if rib476 (cons rib476 (cons (quote shift) s483)) (cons (quote shift) s483))) (let ((pmod484 (procedure-module p472))) (if pmod484 (cons (quote hygiene) (module-name pmod484)) (quote (hygiene guile))))))))) ((vector? x479) (let ((n485 (vector-length x479))) (let ((v486 (make-vector n485))) (let doloop487 ((i488 0)) (if (fx=73 i488 n485) v486 (begin (vector-set! v486 i488 (rebuild-macro-output478 (vector-ref x479 i488) m480)) (doloop487 (fx+71 i488 1)))))))) ((symbol? x479) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap135 e473 w475 s mod477) x479)) (else x479))))) (rebuild-macro-output478 (p472 (wrap134 e473 (anti-mark121 w475) mod477)) (string #\m))))) (chi-application144 (lambda (x489 e490 r491 w492 s493 mod494) ((lambda (tmp495) ((lambda (tmp496) (if tmp496 (apply (lambda (e0497 e1498) (build-annotated79 s493 (cons x489 (map (lambda (e499) (chi142 e499 r491 w492 mod494)) e1498)))) tmp496) (syntax-violation #f "source expression failed to match any pattern" tmp495))) ($sc-dispatch tmp495 (quote (any . each-any))))) e490))) (chi-expr143 (lambda (type501 value502 e503 r504 w505 s506 mod507) (let ((t508 type501)) (if (memv t508 (quote (lexical))) (build-lexical-reference80 (quote value) s506 e503 value502) (if (memv t508 (quote (core external-macro))) (value502 e503 r504 w505 s506 mod507) (if (memv t508 (quote (module-ref))) (call-with-values (lambda () (value502 e503)) (lambda (id509 mod510) (build-global-reference82 s506 id509 mod510))) (if (memv t508 (quote (lexical-call))) (chi-application144 (build-lexical-reference80 (quote fun) (source-annotation97 (car e503)) (car e503) value502) e503 r504 w505 s506 mod507) (if (memv t508 (quote (global-call))) (chi-application144 (build-global-reference82 (source-annotation97 (car e503)) value502 (if (syntax-object?90 (car e503)) (syntax-object-module93 (car e503)) mod507)) e503 r504 w505 s506 mod507) (if (memv t508 (quote (constant))) (build-data84 s506 (strip153 (source-wrap135 e503 w505 s506 mod507) (quote (())))) (if (memv t508 (quote (global))) (build-global-reference82 s506 value502 mod507) (if (memv t508 (quote (call))) (chi-application144 (chi142 (car e503) r504 w505 mod507) e503 r504 w505 s506 mod507) (if (memv t508 (quote (begin-form))) ((lambda (tmp511) ((lambda (tmp512) (if tmp512 (apply (lambda (_513 e1514 e2515) (chi-sequence136 (cons e1514 e2515) r504 w505 s506 mod507)) tmp512) (syntax-violation #f "source expression failed to match any pattern" tmp511))) ($sc-dispatch tmp511 (quote (any any . each-any))))) e503) (if (memv t508 (quote (local-syntax-form))) (chi-local-syntax148 value502 e503 r504 w505 s506 mod507 chi-sequence136) (if (memv t508 (quote (eval-when-form))) ((lambda (tmp517) ((lambda (tmp518) (if tmp518 (apply (lambda (_519 x520 e1521 e2522) (let ((when-list523 (chi-when-list139 e503 x520 w505))) (if (memq (quote eval) when-list523) (chi-sequence136 (cons e1521 e2522) r504 w505 s506 mod507) (chi-void150)))) tmp518) (syntax-violation #f "source expression failed to match any pattern" tmp517))) ($sc-dispatch tmp517 (quote (any each-any any . each-any))))) e503) (if (memv t508 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e503 (wrap134 value502 w505 mod507)) (if (memv t508 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap135 e503 w505 s506 mod507)) (if (memv t508 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap135 e503 w505 s506 mod507)) (syntax-violation #f "unexpected syntax" (source-wrap135 e503 w505 s506 mod507))))))))))))))))))) (chi142 (lambda (e526 r527 w528 mod529) (call-with-values (lambda () (syntax-type140 e526 r527 w528 #f #f mod529)) (lambda (type530 value531 e532 w533 s534 mod535) (chi-expr143 type530 value531 e532 r527 w533 s534 mod535))))) (chi-top141 (lambda (e536 r537 w538 m539 esew540 mod541) (call-with-values (lambda () (syntax-type140 e536 r537 w538 #f #f mod541)) (lambda (type549 value550 e551 w552 s553 mod554) (let ((t555 type549)) (if (memv t555 (quote (begin-form))) ((lambda (tmp556) ((lambda (tmp557) (if tmp557 (apply (lambda (_558) (chi-void150)) tmp557) ((lambda (tmp559) (if tmp559 (apply (lambda (_560 e1561 e2562) (chi-top-sequence137 (cons e1561 e2562) r537 w552 s553 m539 esew540 mod554)) tmp559) (syntax-violation #f "source expression failed to match any pattern" tmp556))) ($sc-dispatch tmp556 (quote (any any . each-any)))))) ($sc-dispatch tmp556 (quote (any))))) e551) (if (memv t555 (quote (local-syntax-form))) (chi-local-syntax148 value550 e551 r537 w552 s553 mod554 (lambda (body564 r565 w566 s567 mod568) (chi-top-sequence137 body564 r565 w566 s567 m539 esew540 mod568))) (if (memv t555 (quote (eval-when-form))) ((lambda (tmp569) ((lambda (tmp570) (if tmp570 (apply (lambda (_571 x572 e1573 e2574) (let ((when-list575 (chi-when-list139 e551 x572 w552)) (body576 (cons e1573 e2574))) (cond ((eq? m539 (quote e)) (if (memq (quote eval) when-list575) (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) (chi-void150))) ((memq (quote load) when-list575) (if (or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (chi-top-sequence137 body576 r537 w552 s553 (quote c&e) (quote (compile load)) mod554) (if (memq m539 (quote (c c&e))) (chi-top-sequence137 body576 r537 w552 s553 (quote c) (quote (load)) mod554) (chi-void150)))) ((or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (top-level-eval-hook75 (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) mod554) (chi-void150)) (else (chi-void150))))) tmp570) (syntax-violation #f "source expression failed to match any pattern" tmp569))) ($sc-dispatch tmp569 (quote (any each-any any . each-any))))) e551) (if (memv t555 (quote (define-syntax-form))) (let ((n579 (id-var-name128 value550 w552)) (r580 (macros-only-env102 r537))) (let ((t581 m539)) (if (memv t581 (quote (c))) (if (memq (quote compile) esew540) (let ((e582 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e582 mod554) (if (memq (quote load) esew540) e582 (chi-void150)))) (if (memq (quote load) esew540) (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) (chi-void150))) (if (memv t581 (quote (c&e))) (let ((e583 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e583 mod554) e583)) (begin (if (memq (quote eval) esew540) (top-level-eval-hook75 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) mod554)) (chi-void150)))))) (if (memv t555 (quote (define-form))) (let ((n584 (id-var-name128 value550 w552))) (let ((type585 (binding-type98 (lookup103 n584 r537 mod554)))) (let ((t586 type585)) (if (memv t586 (quote (global core macro module-ref))) (let ((x587 (build-annotated79 s553 (list (quote define) n584 (chi142 e551 r537 w552 mod554))))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x587 mod554)) x587)) (if (memv t586 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e551 (wrap134 value550 w552 mod554)) (syntax-violation #f "cannot define keyword at top level" e551 (wrap134 value550 w552 mod554))))))) (let ((x588 (chi-expr143 type549 value550 e551 r537 w552 s553 mod554))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x588 mod554)) x588)))))))))))) (syntax-type140 (lambda (e589 r590 w591 s592 rib593 mod594) (cond ((symbol? e589) (let ((n595 (id-var-name128 e589 w591))) (let ((b596 (lookup103 n595 r590 mod594))) (let ((type597 (binding-type98 b596))) (let ((t598 type597)) (if (memv t598 (quote (lexical))) (values type597 (binding-value99 b596) e589 w591 s592 mod594) (if (memv t598 (quote (global))) (values type597 n595 e589 w591 s592 mod594) (if (memv t598 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b596) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (values type597 (binding-value99 b596) e589 w591 s592 mod594))))))))) ((pair? e589) (let ((first599 (car e589))) (if (id?106 first599) (let ((n600 (id-var-name128 first599 w591))) (let ((b601 (lookup103 n600 r590 (or (and (syntax-object?90 first599) (syntax-object-module93 first599)) mod594)))) (let ((type602 (binding-type98 b601))) (let ((t603 type602)) (if (memv t603 (quote (lexical))) (values (quote lexical-call) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (global))) (values (quote global-call) n600 e589 w591 s592 mod594) (if (memv t603 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b601) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (if (memv t603 (quote (core external-macro module-ref))) (values type602 (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (begin))) (values (quote begin-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (eval-when))) (values (quote eval-when-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (define))) ((lambda (tmp604) ((lambda (tmp605) (if (if tmp605 (apply (lambda (_606 name607 val608) (id?106 name607)) tmp605) #f) (apply (lambda (_609 name610 val611) (values (quote define-form) name610 val611 w591 s592 mod594)) tmp605) ((lambda (tmp612) (if (if tmp612 (apply (lambda (_613 name614 args615 e1616 e2617) (and (id?106 name614) (valid-bound-ids?131 (lambda-var-list155 args615)))) tmp612) #f) (apply (lambda (_618 name619 args620 e1621 e2622) (values (quote define-form) (wrap134 name619 w591 mod594) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap134 (cons args620 (cons e1621 e2622)) w591 mod594)) (quote (())) s592 mod594)) tmp612) ((lambda (tmp624) (if (if tmp624 (apply (lambda (_625 name626) (id?106 name626)) tmp624) #f) (apply (lambda (_627 name628) (values (quote define-form) (wrap134 name628 w591 mod594) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s592 mod594)) tmp624) (syntax-violation #f "source expression failed to match any pattern" tmp604))) ($sc-dispatch tmp604 (quote (any any)))))) ($sc-dispatch tmp604 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp604 (quote (any any any))))) e589) (if (memv t603 (quote (define-syntax))) ((lambda (tmp629) ((lambda (tmp630) (if (if tmp630 (apply (lambda (_631 name632 val633) (id?106 name632)) tmp630) #f) (apply (lambda (_634 name635 val636) (values (quote define-syntax-form) name635 val636 w591 s592 mod594)) tmp630) (syntax-violation #f "source expression failed to match any pattern" tmp629))) ($sc-dispatch tmp629 (quote (any any any))))) e589) (values (quote call) #f e589 w591 s592 mod594)))))))))))))) (values (quote call) #f e589 w591 s592 mod594)))) ((syntax-object?90 e589) (syntax-type140 (syntax-object-expression91 e589) r590 (join-wraps125 w591 (syntax-object-wrap92 e589)) #f rib593 (or (syntax-object-module93 e589) mod594))) ((annotation? e589) (syntax-type140 (annotation-expression e589) r590 w591 (annotation-source e589) rib593 mod594)) ((self-evaluating? e589) (values (quote constant) #f e589 w591 s592 mod594)) (else (values (quote other) #f e589 w591 s592 mod594))))) (chi-when-list139 (lambda (e637 when-list638 w639) (let f640 ((when-list641 when-list638) (situations642 (quote ()))) (if (null? when-list641) situations642 (f640 (cdr when-list641) (cons (let ((x643 (car when-list641))) (cond ((free-id=?129 x643 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?129 x643 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?129 x643 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e637 (wrap134 x643 w639 #f))))) situations642)))))) (chi-install-global138 (lambda (name644 e645) (build-annotated79 #f (list (quote define) name644 (if (let ((v646 (module-variable (current-module) name644))) (and v646 (variable-bound? v646) (macro? (variable-ref v646)) (not (eq? (macro-type (variable-ref v646)) (quote syncase-macro))))) (build-annotated79 #f (list (build-annotated79 #f (quote make-extended-syncase-macro)) (build-annotated79 #f (list (build-annotated79 #f (quote module-ref)) (build-annotated79 #f (quote (current-module))) (build-data84 #f name644))) (build-data84 #f (quote macro)) e645)) (build-annotated79 #f (list (build-annotated79 #f (quote make-syncase-macro)) (build-data84 #f (quote macro)) e645))))))) (chi-top-sequence137 (lambda (body647 r648 w649 s650 m651 esew652 mod653) (build-sequence85 s650 (let dobody654 ((body655 body647) (r656 r648) (w657 w649) (m658 m651) (esew659 esew652) (mod660 mod653)) (if (null? body655) (quote ()) (let ((first661 (chi-top141 (car body655) r656 w657 m658 esew659 mod660))) (cons first661 (dobody654 (cdr body655) r656 w657 m658 esew659 mod660)))))))) (chi-sequence136 (lambda (body662 r663 w664 s665 mod666) (build-sequence85 s665 (let dobody667 ((body668 body662) (r669 r663) (w670 w664) (mod671 mod666)) (if (null? body668) (quote ()) (let ((first672 (chi142 (car body668) r669 w670 mod671))) (cons first672 (dobody667 (cdr body668) r669 w670 mod671)))))))) (source-wrap135 (lambda (x673 w674 s675 defmod676) (wrap134 (if s675 (make-annotation x673 s675 #f) x673) w674 defmod676))) (wrap134 (lambda (x677 w678 defmod679) (cond ((and (null? (wrap-marks109 w678)) (null? (wrap-subst110 w678))) x677) ((syntax-object?90 x677) (make-syntax-object89 (syntax-object-expression91 x677) (join-wraps125 w678 (syntax-object-wrap92 x677)) (syntax-object-module93 x677))) ((null? x677) x677) (else (make-syntax-object89 x677 w678 defmod679))))) (bound-id-member?133 (lambda (x680 list681) (and (not (null? list681)) (or (bound-id=?130 x680 (car list681)) (bound-id-member?133 x680 (cdr list681)))))) (distinct-bound-ids?132 (lambda (ids682) (let distinct?683 ((ids684 ids682)) (or (null? ids684) (and (not (bound-id-member?133 (car ids684) (cdr ids684))) (distinct?683 (cdr ids684))))))) (valid-bound-ids?131 (lambda (ids685) (and (let all-ids?686 ((ids687 ids685)) (or (null? ids687) (and (id?106 (car ids687)) (all-ids?686 (cdr ids687))))) (distinct-bound-ids?132 ids685)))) (bound-id=?130 (lambda (i688 j689) (if (and (syntax-object?90 i688) (syntax-object?90 j689)) (and (eq? (let ((e690 (syntax-object-expression91 i688))) (if (annotation? e690) (annotation-expression e690) e690)) (let ((e691 (syntax-object-expression91 j689))) (if (annotation? e691) (annotation-expression e691) e691))) (same-marks?127 (wrap-marks109 (syntax-object-wrap92 i688)) (wrap-marks109 (syntax-object-wrap92 j689)))) (eq? (let ((e692 i688)) (if (annotation? e692) (annotation-expression e692) e692)) (let ((e693 j689)) (if (annotation? e693) (annotation-expression e693) e693)))))) (free-id=?129 (lambda (i694 j695) (and (eq? (let ((x696 i694)) (let ((e697 (if (syntax-object?90 x696) (syntax-object-expression91 x696) x696))) (if (annotation? e697) (annotation-expression e697) e697))) (let ((x698 j695)) (let ((e699 (if (syntax-object?90 x698) (syntax-object-expression91 x698) x698))) (if (annotation? e699) (annotation-expression e699) e699)))) (eq? (id-var-name128 i694 (quote (()))) (id-var-name128 j695 (quote (()))))))) (id-var-name128 (lambda (id700 w701) (letrec ((search-vector-rib704 (lambda (sym710 subst711 marks712 symnames713 ribcage714) (let ((n715 (vector-length symnames713))) (let f716 ((i717 0)) (cond ((fx=73 i717 n715) (search702 sym710 (cdr subst711) marks712)) ((and (eq? (vector-ref symnames713 i717) sym710) (same-marks?127 marks712 (vector-ref (ribcage-marks116 ribcage714) i717))) (values (vector-ref (ribcage-labels117 ribcage714) i717) marks712)) (else (f716 (fx+71 i717 1)))))))) (search-list-rib703 (lambda (sym718 subst719 marks720 symnames721 ribcage722) (let f723 ((symnames724 symnames721) (i725 0)) (cond ((null? symnames724) (search702 sym718 (cdr subst719) marks720)) ((and (eq? (car symnames724) sym718) (same-marks?127 marks720 (list-ref (ribcage-marks116 ribcage722) i725))) (values (list-ref (ribcage-labels117 ribcage722) i725) marks720)) (else (f723 (cdr symnames724) (fx+71 i725 1))))))) (search702 (lambda (sym726 subst727 marks728) (if (null? subst727) (values #f marks728) (let ((fst729 (car subst727))) (if (eq? fst729 (quote shift)) (search702 sym726 (cdr subst727) (cdr marks728)) (let ((symnames730 (ribcage-symnames115 fst729))) (if (vector? symnames730) (search-vector-rib704 sym726 subst727 marks728 symnames730 fst729) (search-list-rib703 sym726 subst727 marks728 symnames730 fst729))))))))) (cond ((symbol? id700) (or (call-with-values (lambda () (search702 id700 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x732 . ignore731) x732)) id700)) ((syntax-object?90 id700) (let ((id733 (let ((e735 (syntax-object-expression91 id700))) (if (annotation? e735) (annotation-expression e735) e735))) (w1734 (syntax-object-wrap92 id700))) (let ((marks736 (join-marks126 (wrap-marks109 w701) (wrap-marks109 w1734)))) (call-with-values (lambda () (search702 id733 (wrap-subst110 w701) marks736)) (lambda (new-id737 marks738) (or new-id737 (call-with-values (lambda () (search702 id733 (wrap-subst110 w1734) marks738)) (lambda (x740 . ignore739) x740)) id733)))))) ((annotation? id700) (let ((id741 (let ((e742 id700)) (if (annotation? e742) (annotation-expression e742) e742)))) (or (call-with-values (lambda () (search702 id741 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x744 . ignore743) x744)) id741))) (else (syntax-violation (quote id-var-name) "invalid id" id700)))))) (same-marks?127 (lambda (x745 y746) (or (eq? x745 y746) (and (not (null? x745)) (not (null? y746)) (eq? (car x745) (car y746)) (same-marks?127 (cdr x745) (cdr y746)))))) (join-marks126 (lambda (m1747 m2748) (smart-append124 m1747 m2748))) (join-wraps125 (lambda (w1749 w2750) (let ((m1751 (wrap-marks109 w1749)) (s1752 (wrap-subst110 w1749))) (if (null? m1751) (if (null? s1752) w2750 (make-wrap108 (wrap-marks109 w2750) (smart-append124 s1752 (wrap-subst110 w2750)))) (make-wrap108 (smart-append124 m1751 (wrap-marks109 w2750)) (smart-append124 s1752 (wrap-subst110 w2750))))))) (smart-append124 (lambda (m1753 m2754) (if (null? m2754) m1753 (append m1753 m2754)))) (make-binding-wrap123 (lambda (ids755 labels756 w757) (if (null? ids755) w757 (make-wrap108 (wrap-marks109 w757) (cons (let ((labelvec758 (list->vector labels756))) (let ((n759 (vector-length labelvec758))) (let ((symnamevec760 (make-vector n759)) (marksvec761 (make-vector n759))) (begin (let f762 ((ids763 ids755) (i764 0)) (if (not (null? ids763)) (call-with-values (lambda () (id-sym-name&marks107 (car ids763) w757)) (lambda (symname765 marks766) (begin (vector-set! symnamevec760 i764 symname765) (vector-set! marksvec761 i764 marks766) (f762 (cdr ids763) (fx+71 i764 1))))))) (make-ribcage113 symnamevec760 marksvec761 labelvec758))))) (wrap-subst110 w757)))))) (extend-ribcage!122 (lambda (ribcage767 id768 label769) (begin (set-ribcage-symnames!118 ribcage767 (cons (let ((e770 (syntax-object-expression91 id768))) (if (annotation? e770) (annotation-expression e770) e770)) (ribcage-symnames115 ribcage767))) (set-ribcage-marks!119 ribcage767 (cons (wrap-marks109 (syntax-object-wrap92 id768)) (ribcage-marks116 ribcage767))) (set-ribcage-labels!120 ribcage767 (cons label769 (ribcage-labels117 ribcage767)))))) (anti-mark121 (lambda (w771) (make-wrap108 (cons #f (wrap-marks109 w771)) (cons (quote shift) (wrap-subst110 w771))))) (set-ribcage-labels!120 (lambda (x772 update773) (vector-set! x772 3 update773))) (set-ribcage-marks!119 (lambda (x774 update775) (vector-set! x774 2 update775))) (set-ribcage-symnames!118 (lambda (x776 update777) (vector-set! x776 1 update777))) (ribcage-labels117 (lambda (x778) (vector-ref x778 3))) (ribcage-marks116 (lambda (x779) (vector-ref x779 2))) (ribcage-symnames115 (lambda (x780) (vector-ref x780 1))) (ribcage?114 (lambda (x781) (and (vector? x781) (= (vector-length x781) 4) (eq? (vector-ref x781 0) (quote ribcage))))) (make-ribcage113 (lambda (symnames782 marks783 labels784) (vector (quote ribcage) symnames782 marks783 labels784))) (gen-labels112 (lambda (ls785) (if (null? ls785) (quote ()) (cons (gen-label111) (gen-labels112 (cdr ls785)))))) (gen-label111 (lambda () (string #\i))) (wrap-subst110 cdr) (wrap-marks109 car) (make-wrap108 cons) (id-sym-name&marks107 (lambda (x786 w787) (if (syntax-object?90 x786) (values (let ((e788 (syntax-object-expression91 x786))) (if (annotation? e788) (annotation-expression e788) e788)) (join-marks126 (wrap-marks109 w787) (wrap-marks109 (syntax-object-wrap92 x786)))) (values (let ((e789 x786)) (if (annotation? e789) (annotation-expression e789) e789)) (wrap-marks109 w787))))) (id?106 (lambda (x790) (cond ((symbol? x790) #t) ((syntax-object?90 x790) (symbol? (let ((e791 (syntax-object-expression91 x790))) (if (annotation? e791) (annotation-expression e791) e791)))) ((annotation? x790) (symbol? (annotation-expression x790))) (else #f)))) (nonsymbol-id?105 (lambda (x792) (and (syntax-object?90 x792) (symbol? (let ((e793 (syntax-object-expression91 x792))) (if (annotation? e793) (annotation-expression e793) e793)))))) (global-extend104 (lambda (type794 sym795 val796) (put-global-definition-hook77 sym795 type794 val796))) (lookup103 (lambda (x797 r798 mod799) (cond ((assq x797 r798) => cdr) ((symbol? x797) (or (get-global-definition-hook78 x797 mod799) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env102 (lambda (r800) (if (null? r800) (quote ()) (let ((a801 (car r800))) (if (eq? (cadr a801) (quote macro)) (cons a801 (macros-only-env102 (cdr r800))) (macros-only-env102 (cdr r800))))))) (extend-var-env101 (lambda (labels802 vars803 r804) (if (null? labels802) r804 (extend-var-env101 (cdr labels802) (cdr vars803) (cons (cons (car labels802) (cons (quote lexical) (car vars803))) r804))))) (extend-env100 (lambda (labels805 bindings806 r807) (if (null? labels805) r807 (extend-env100 (cdr labels805) (cdr bindings806) (cons (cons (car labels805) (car bindings806)) r807))))) (binding-value99 cdr) (binding-type98 car) (source-annotation97 (lambda (x808) (cond ((annotation? x808) (annotation-source x808)) ((syntax-object?90 x808) (source-annotation97 (syntax-object-expression91 x808))) (else #f)))) (set-syntax-object-module!96 (lambda (x809 update810) (vector-set! x809 3 update810))) (set-syntax-object-wrap!95 (lambda (x811 update812) (vector-set! x811 2 update812))) (set-syntax-object-expression!94 (lambda (x813 update814) (vector-set! x813 1 update814))) (syntax-object-module93 (lambda (x815) (vector-ref x815 3))) (syntax-object-wrap92 (lambda (x816) (vector-ref x816 2))) (syntax-object-expression91 (lambda (x817) (vector-ref x817 1))) (syntax-object?90 (lambda (x818) (and (vector? x818) (= (vector-length x818) 4) (eq? (vector-ref x818 0) (quote syntax-object))))) (make-syntax-object89 (lambda (expression819 wrap820 module821) (vector (quote syntax-object) expression819 wrap820 module821))) (build-letrec88 (lambda (src822 vars823 val-exps824 body-exp825) (if (null? vars823) (build-annotated79 src822 body-exp825) (build-annotated79 src822 (list (quote letrec) (map list vars823 val-exps824) body-exp825))))) (build-named-let87 (lambda (src826 vars827 val-exps828 body-exp829) (if (null? vars827) (build-annotated79 src826 body-exp829) (build-annotated79 src826 (list (quote let) (car vars827) (map list (cdr vars827) val-exps828) body-exp829))))) (build-let86 (lambda (src830 vars831 val-exps832 body-exp833) (if (null? vars831) (build-annotated79 src830 body-exp833) (build-annotated79 src830 (list (quote let) (map list vars831 val-exps832) body-exp833))))) (build-sequence85 (lambda (src834 exps835) (if (null? (cdr exps835)) (build-annotated79 src834 (car exps835)) (build-annotated79 src834 (cons (quote begin) exps835))))) (build-data84 (lambda (src836 exp837) (if (and (self-evaluating? exp837) (not (vector? exp837))) (build-annotated79 src836 exp837) (build-annotated79 src836 (list (quote quote) exp837))))) (build-global-assignment83 (lambda (source838 var839 exp840 mod841) (let ((ref842 (build-global-reference82 source838 var839 mod841))) (build-annotated79 source838 (list (quote set!) ref842 exp840))))) (build-global-reference82 (lambda (source843 var844 mod845) (build-annotated79 source843 (if (not mod845) var844 (let ((make-module-ref846 (let ((t849 (fluid-ref *mode*70))) (if (memv t849 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851))))) (kind847 (car mod845)) (mod848 (cdr mod845))) (let ((t853 kind847)) (if (memv t853 (quote (public))) (make-module-ref846 mod848 var844 #t) (if (memv t853 (quote (private))) (if (not (equal? mod848 (module-name (current-module)))) (make-module-ref846 mod848 var844 #f) var844) (if (memv t853 (quote (bare))) var844 (if (memv t853 (quote (hygiene))) (if (and (not (equal? mod848 (module-name (current-module)))) (module-variable (resolve-module mod848) var844)) (make-module-ref846 mod848 var844 #f) var844) (syntax-violation #f "bad module kind" var844 mod848))))))))))) (build-lexical-assignment81 (lambda (source854 name855 var856 exp857) (build-annotated79 source854 (list (quote set!) (build-lexical-reference80 (quote set) #f name855 var856) exp857)))) (build-lexical-reference80 (lambda (type858 source859 name860 var861) (build-annotated79 source859 (let ((t862 (fluid-ref *mode*70))) (if (memv t862 (quote (c))) ((@ (ice-9 expand-support) make-lexical) name860 var861) var861))))) (build-annotated79 (lambda (src863 exp864) (if (and src863 (not (annotation? exp864))) (make-annotation exp864 src863 #t) exp864))) (get-global-definition-hook78 (lambda (symbol865 module866) (begin (if (and (not module866) (current-module)) (warn "module system is booted, we should have a module" symbol865)) (let ((v867 (module-variable (if module866 (resolve-module (cdr module866)) (current-module)) symbol865))) (and v867 (variable-bound? v867) (let ((val868 (variable-ref v867))) (and (macro? val868) (syncase-macro-type val868) (cons (syncase-macro-type val868) (syncase-macro-binding val868))))))))) (put-global-definition-hook77 (lambda (symbol869 type870 val871) (let ((existing872 (let ((v873 (module-variable (current-module) symbol869))) (and v873 (variable-bound? v873) (let ((val874 (variable-ref v873))) (and (macro? val874) (not (syncase-macro-type val874)) val874)))))) (module-define! (current-module) symbol869 (if existing872 (make-extended-syncase-macro existing872 type870 val871) (make-syncase-macro type870 val871)))))) (local-eval-hook76 (lambda (x875 mod876) (primitive-eval (list noexpand69 (let ((t877 (fluid-ref *mode*70))) (if (memv t877 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x875) x875)))))) (top-level-eval-hook75 (lambda (x878 mod879) (primitive-eval (list noexpand69 (let ((t880 (fluid-ref *mode*70))) (if (memv t880 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x878) x878)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend104 (quote local-syntax) (quote letrec-syntax) #t) (global-extend104 (quote local-syntax) (quote let-syntax) #f) (global-extend104 (quote core) (quote fluid-let-syntax) (lambda (e881 r882 w883 s884 mod885) ((lambda (tmp886) ((lambda (tmp887) (if (if tmp887 (apply (lambda (_888 var889 val890 e1891 e2892) (valid-bound-ids?131 var889)) tmp887) #f) (apply (lambda (_894 var895 val896 e1897 e2898) (let ((names899 (map (lambda (x900) (id-var-name128 x900 w883)) var895))) (begin (for-each (lambda (id902 n903) (let ((t904 (binding-type98 (lookup103 n903 r882 mod885)))) (if (memv t904 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e881 (source-wrap135 id902 w883 s884 mod885))))) var895 names899) (chi-body146 (cons e1897 e2898) (source-wrap135 e881 w883 s884 mod885) (extend-env100 names899 (let ((trans-r907 (macros-only-env102 r882))) (map (lambda (x908) (cons (quote macro) (eval-local-transformer149 (chi142 x908 trans-r907 w883 mod885) mod885))) val896)) r882) w883 mod885)))) tmp887) ((lambda (_910) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap135 e881 w883 s884 mod885))) tmp886))) ($sc-dispatch tmp886 (quote (any #(each (any any)) any . each-any))))) e881))) (global-extend104 (quote core) (quote quote) (lambda (e911 r912 w913 s914 mod915) ((lambda (tmp916) ((lambda (tmp917) (if tmp917 (apply (lambda (_918 e919) (build-data84 s914 (strip153 e919 w913))) tmp917) ((lambda (_920) (syntax-violation (quote quote) "bad syntax" (source-wrap135 e911 w913 s914 mod915))) tmp916))) ($sc-dispatch tmp916 (quote (any any))))) e911))) (global-extend104 (quote core) (quote syntax) (letrec ((regen928 (lambda (x929) (let ((t930 (car x929))) (if (memv t930 (quote (ref))) (build-lexical-reference80 (quote value) #f (cadr x929) (cadr x929)) (if (memv t930 (quote (primitive))) (build-annotated79 #f (cadr x929)) (if (memv t930 (quote (quote))) (build-data84 #f (cadr x929)) (if (memv t930 (quote (lambda))) (build-annotated79 #f (list (quote lambda) (cadr x929) (regen928 (caddr x929)))) (if (memv t930 (quote (map))) (let ((ls931 (map regen928 (cdr x929)))) (build-annotated79 #f (cons (if (fx=73 (length ls931) 2) (build-annotated79 #f (quote map)) (build-annotated79 #f (quote map))) ls931))) (build-annotated79 #f (cons (build-annotated79 #f (car x929)) (map regen928 (cdr x929)))))))))))) (gen-vector927 (lambda (x932) (cond ((eq? (car x932) (quote list)) (cons (quote vector) (cdr x932))) ((eq? (car x932) (quote quote)) (list (quote quote) (list->vector (cadr x932)))) (else (list (quote list->vector) x932))))) (gen-append926 (lambda (x933 y934) (if (equal? y934 (quote (quote ()))) x933 (list (quote append) x933 y934)))) (gen-cons925 (lambda (x935 y936) (let ((t937 (car y936))) (if (memv t937 (quote (quote))) (if (eq? (car x935) (quote quote)) (list (quote quote) (cons (cadr x935) (cadr y936))) (if (eq? (cadr y936) (quote ())) (list (quote list) x935) (list (quote cons) x935 y936))) (if (memv t937 (quote (list))) (cons (quote list) (cons x935 (cdr y936))) (list (quote cons) x935 y936)))))) (gen-map924 (lambda (e938 map-env939) (let ((formals940 (map cdr map-env939)) (actuals941 (map (lambda (x942) (list (quote ref) (car x942))) map-env939))) (cond ((eq? (car e938) (quote ref)) (car actuals941)) ((and-map (lambda (x943) (and (eq? (car x943) (quote ref)) (memq (cadr x943) formals940))) (cdr e938)) (cons (quote map) (cons (list (quote primitive) (car e938)) (map (let ((r944 (map cons formals940 actuals941))) (lambda (x945) (cdr (assq (cadr x945) r944)))) (cdr e938))))) (else (cons (quote map) (cons (list (quote lambda) formals940 e938) actuals941))))))) (gen-mappend923 (lambda (e946 map-env947) (list (quote apply) (quote (primitive append)) (gen-map924 e946 map-env947)))) (gen-ref922 (lambda (src948 var949 level950 maps951) (if (fx=73 level950 0) (values var949 maps951) (if (null? maps951) (syntax-violation (quote syntax) "missing ellipsis" src948) (call-with-values (lambda () (gen-ref922 src948 var949 (fx-72 level950 1) (cdr maps951))) (lambda (outer-var952 outer-maps953) (let ((b954 (assq outer-var952 (car maps951)))) (if b954 (values (cdr b954) maps951) (let ((inner-var955 (gen-var154 (quote tmp)))) (values inner-var955 (cons (cons (cons outer-var952 inner-var955) (car maps951)) outer-maps953))))))))))) (gen-syntax921 (lambda (src956 e957 r958 maps959 ellipsis?960 mod961) (if (id?106 e957) (let ((label962 (id-var-name128 e957 (quote (()))))) (let ((b963 (lookup103 label962 r958 mod961))) (if (eq? (binding-type98 b963) (quote syntax)) (call-with-values (lambda () (let ((var.lev964 (binding-value99 b963))) (gen-ref922 src956 (car var.lev964) (cdr var.lev964) maps959))) (lambda (var965 maps966) (values (list (quote ref) var965) maps966))) (if (ellipsis?960 e957) (syntax-violation (quote syntax) "misplaced ellipsis" src956) (values (list (quote quote) e957) maps959))))) ((lambda (tmp967) ((lambda (tmp968) (if (if tmp968 (apply (lambda (dots969 e970) (ellipsis?960 dots969)) tmp968) #f) (apply (lambda (dots971 e972) (gen-syntax921 src956 e972 r958 maps959 (lambda (x973) #f) mod961)) tmp968) ((lambda (tmp974) (if (if tmp974 (apply (lambda (x975 dots976 y977) (ellipsis?960 dots976)) tmp974) #f) (apply (lambda (x978 dots979 y980) (let f981 ((y982 y980) (k983 (lambda (maps984) (call-with-values (lambda () (gen-syntax921 src956 x978 r958 (cons (quote ()) maps984) ellipsis?960 mod961)) (lambda (x985 maps986) (if (null? (car maps986)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-map924 x985 (car maps986)) (cdr maps986)))))))) ((lambda (tmp987) ((lambda (tmp988) (if (if tmp988 (apply (lambda (dots989 y990) (ellipsis?960 dots989)) tmp988) #f) (apply (lambda (dots991 y992) (f981 y992 (lambda (maps993) (call-with-values (lambda () (k983 (cons (quote ()) maps993))) (lambda (x994 maps995) (if (null? (car maps995)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-mappend923 x994 (car maps995)) (cdr maps995)))))))) tmp988) ((lambda (_996) (call-with-values (lambda () (gen-syntax921 src956 y982 r958 maps959 ellipsis?960 mod961)) (lambda (y997 maps998) (call-with-values (lambda () (k983 maps998)) (lambda (x999 maps1000) (values (gen-append926 x999 y997) maps1000)))))) tmp987))) ($sc-dispatch tmp987 (quote (any . any))))) y982))) tmp974) ((lambda (tmp1001) (if tmp1001 (apply (lambda (x1002 y1003) (call-with-values (lambda () (gen-syntax921 src956 x1002 r958 maps959 ellipsis?960 mod961)) (lambda (x1004 maps1005) (call-with-values (lambda () (gen-syntax921 src956 y1003 r958 maps1005 ellipsis?960 mod961)) (lambda (y1006 maps1007) (values (gen-cons925 x1004 y1006) maps1007)))))) tmp1001) ((lambda (tmp1008) (if tmp1008 (apply (lambda (e11009 e21010) (call-with-values (lambda () (gen-syntax921 src956 (cons e11009 e21010) r958 maps959 ellipsis?960 mod961)) (lambda (e1012 maps1013) (values (gen-vector927 e1012) maps1013)))) tmp1008) ((lambda (_1014) (values (list (quote quote) e957) maps959)) tmp967))) ($sc-dispatch tmp967 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp967 (quote (any . any)))))) ($sc-dispatch tmp967 (quote (any any . any)))))) ($sc-dispatch tmp967 (quote (any any))))) e957))))) (lambda (e1015 r1016 w1017 s1018 mod1019) (let ((e1020 (source-wrap135 e1015 w1017 s1018 mod1019))) ((lambda (tmp1021) ((lambda (tmp1022) (if tmp1022 (apply (lambda (_1023 x1024) (call-with-values (lambda () (gen-syntax921 e1020 x1024 r1016 (quote ()) ellipsis?151 mod1019)) (lambda (e1025 maps1026) (regen928 e1025)))) tmp1022) ((lambda (_1027) (syntax-violation (quote syntax) "bad `syntax' form" e1020)) tmp1021))) ($sc-dispatch tmp1021 (quote (any any))))) e1020))))) (global-extend104 (quote core) (quote lambda) (lambda (e1028 r1029 w1030 s1031 mod1032) ((lambda (tmp1033) ((lambda (tmp1034) (if tmp1034 (apply (lambda (_1035 c1036) (chi-lambda-clause147 (source-wrap135 e1028 w1030 s1031 mod1032) #f c1036 r1029 w1030 mod1032 (lambda (vars1037 docstring1038 body1039) (build-annotated79 s1031 (cons (quote lambda) (cons vars1037 (append (if docstring1038 (list docstring1038) (quote ())) (list body1039)))))))) tmp1034) (syntax-violation #f "source expression failed to match any pattern" tmp1033))) ($sc-dispatch tmp1033 (quote (any . any))))) e1028))) (global-extend104 (quote core) (quote let) (letrec ((chi-let1040 (lambda (e1041 r1042 w1043 s1044 mod1045 constructor1046 ids1047 vals1048 exps1049) (if (not (valid-bound-ids?131 ids1047)) (syntax-violation (quote let) "duplicate bound variable" e1041) (let ((labels1050 (gen-labels112 ids1047)) (new-vars1051 (map gen-var154 ids1047))) (let ((nw1052 (make-binding-wrap123 ids1047 labels1050 w1043)) (nr1053 (extend-var-env101 labels1050 new-vars1051 r1042))) (constructor1046 s1044 new-vars1051 (map (lambda (x1054) (chi142 x1054 r1042 w1043 mod1045)) vals1048) (chi-body146 exps1049 (source-wrap135 e1041 nw1052 s1044 mod1045) nr1053 nw1052 mod1045)))))))) (lambda (e1055 r1056 w1057 s1058 mod1059) ((lambda (tmp1060) ((lambda (tmp1061) (if tmp1061 (apply (lambda (_1062 id1063 val1064 e11065 e21066) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-let86 id1063 val1064 (cons e11065 e21066))) tmp1061) ((lambda (tmp1070) (if (if tmp1070 (apply (lambda (_1071 f1072 id1073 val1074 e11075 e21076) (id?106 f1072)) tmp1070) #f) (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-named-let87 (cons f1078 id1079) val1080 (cons e11081 e21082))) tmp1070) ((lambda (_1086) (syntax-violation (quote let) "bad let" (source-wrap135 e1055 w1057 s1058 mod1059))) tmp1060))) ($sc-dispatch tmp1060 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1060 (quote (any #(each (any any)) any . each-any))))) e1055)))) (global-extend104 (quote core) (quote letrec) (lambda (e1087 r1088 w1089 s1090 mod1091) ((lambda (tmp1092) ((lambda (tmp1093) (if tmp1093 (apply (lambda (_1094 id1095 val1096 e11097 e21098) (let ((ids1099 id1095)) (if (not (valid-bound-ids?131 ids1099)) (syntax-violation (quote letrec) "duplicate bound variable" e1087) (let ((labels1101 (gen-labels112 ids1099)) (new-vars1102 (map gen-var154 ids1099))) (let ((w1103 (make-binding-wrap123 ids1099 labels1101 w1089)) (r1104 (extend-var-env101 labels1101 new-vars1102 r1088))) (build-letrec88 s1090 new-vars1102 (map (lambda (x1105) (chi142 x1105 r1104 w1103 mod1091)) val1096) (chi-body146 (cons e11097 e21098) (source-wrap135 e1087 w1103 s1090 mod1091) r1104 w1103 mod1091))))))) tmp1093) ((lambda (_1108) (syntax-violation (quote letrec) "bad letrec" (source-wrap135 e1087 w1089 s1090 mod1091))) tmp1092))) ($sc-dispatch tmp1092 (quote (any #(each (any any)) any . each-any))))) e1087))) (global-extend104 (quote core) (quote set!) (lambda (e1109 r1110 w1111 s1112 mod1113) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (_1116 id1117 val1118) (id?106 id1117)) tmp1115) #f) (apply (lambda (_1119 id1120 val1121) (let ((val1122 (chi142 val1121 r1110 w1111 mod1113)) (n1123 (id-var-name128 id1120 w1111))) (let ((b1124 (lookup103 n1123 r1110 mod1113))) (let ((t1125 (binding-type98 b1124))) (if (memv t1125 (quote (lexical))) (build-lexical-assignment81 s1112 (syntax->datum id1120) (binding-value99 b1124) val1122) (if (memv t1125 (quote (global))) (build-global-assignment83 s1112 n1123 val1122 mod1113) (if (memv t1125 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap134 id1120 w1111 mod1113)) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))))))))) tmp1115) ((lambda (tmp1126) (if tmp1126 (apply (lambda (_1127 head1128 tail1129 val1130) (call-with-values (lambda () (syntax-type140 head1128 r1110 (quote (())) #f #f mod1113)) (lambda (type1131 value1132 ee1133 ww1134 ss1135 modmod1136) (let ((t1137 type1131)) (if (memv t1137 (quote (module-ref))) (let ((val1138 (chi142 val1130 r1110 w1111 mod1113))) (call-with-values (lambda () (value1132 (cons head1128 tail1129))) (lambda (id1140 mod1141) (build-global-assignment83 s1112 id1140 val1138 mod1141)))) (build-annotated79 s1112 (cons (chi142 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1128) r1110 w1111 mod1113) (map (lambda (e1142) (chi142 e1142 r1110 w1111 mod1113)) (append tail1129 (list val1130)))))))))) tmp1126) ((lambda (_1144) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))) tmp1114))) ($sc-dispatch tmp1114 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1114 (quote (any any any))))) e1109))) (global-extend104 (quote module-ref) (quote @) (lambda (e1145) ((lambda (tmp1146) ((lambda (tmp1147) (if (if tmp1147 (apply (lambda (_1148 mod1149 id1150) (and (and-map id?106 mod1149) (id?106 id1150))) tmp1147) #f) (apply (lambda (_1152 mod1153 id1154) (values (syntax->datum id1154) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1153)))) tmp1147) (syntax-violation #f "source expression failed to match any pattern" tmp1146))) ($sc-dispatch tmp1146 (quote (any each-any any))))) e1145))) (global-extend104 (quote module-ref) (quote @@) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (and (and-map id?106 mod1160) (id?106 id1161))) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend104 (quote begin) (quote begin) (quote ())) (global-extend104 (quote define) (quote define) (quote ())) (global-extend104 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend104 (quote eval-when) (quote eval-when) (quote ())) (global-extend104 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1170 (lambda (x1171 keys1172 clauses1173 r1174 mod1175) (if (null? clauses1173) (build-annotated79 #f (list (build-annotated79 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1171)) ((lambda (tmp1176) ((lambda (tmp1177) (if tmp1177 (apply (lambda (pat1178 exp1179) (if (and (id?106 pat1178) (and-map (lambda (x1180) (not (free-id=?129 pat1178 x1180))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1172))) (let ((labels1181 (list (gen-label111))) (var1182 (gen-var154 pat1178))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list var1182) (chi142 exp1179 (extend-env100 labels1181 (list (cons (quote syntax) (cons var1182 0))) r1174) (make-binding-wrap123 (list pat1178) labels1181 (quote (()))) mod1175))) x1171))) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1178 #t exp1179 mod1175))) tmp1177) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 fender1185 exp1186) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1184 fender1185 exp1186 mod1175)) tmp1183) ((lambda (_1187) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1173))) tmp1176))) ($sc-dispatch tmp1176 (quote (any any any)))))) ($sc-dispatch tmp1176 (quote (any any))))) (car clauses1173))))) (gen-clause1169 (lambda (x1188 keys1189 clauses1190 r1191 pat1192 fender1193 exp1194 mod1195) (call-with-values (lambda () (convert-pattern1167 pat1192 keys1189)) (lambda (p1196 pvars1197) (cond ((not (distinct-bound-ids?132 (map car pvars1197))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1192)) ((not (and-map (lambda (x1198) (not (ellipsis?151 (car x1198)))) pvars1197)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1192)) (else (let ((y1199 (gen-var154 (quote tmp)))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list y1199) (let ((y1200 (build-lexical-reference80 (quote value) #f (quote tmp) y1199))) (build-annotated79 #f (list (quote if) ((lambda (tmp1201) ((lambda (tmp1202) (if tmp1202 (apply (lambda () y1200) tmp1202) ((lambda (_1203) (build-annotated79 #f (list (quote if) y1200 (build-dispatch-call1168 pvars1197 fender1193 y1200 r1191 mod1195) (build-data84 #f #f)))) tmp1201))) ($sc-dispatch tmp1201 (quote #(atom #t))))) fender1193) (build-dispatch-call1168 pvars1197 exp1194 y1200 r1191 mod1195) (gen-syntax-case1170 x1188 keys1189 clauses1190 r1191 mod1195)))))) (if (eq? p1196 (quote any)) (build-annotated79 #f (list (build-annotated79 #f (quote list)) x1188)) (build-annotated79 #f (list (build-annotated79 #f (quote $sc-dispatch)) x1188 (build-data84 #f p1196))))))))))))) (build-dispatch-call1168 (lambda (pvars1204 exp1205 y1206 r1207 mod1208) (let ((ids1209 (map car pvars1204)) (levels1210 (map cdr pvars1204))) (let ((labels1211 (gen-labels112 ids1209)) (new-vars1212 (map gen-var154 ids1209))) (build-annotated79 #f (list (build-annotated79 #f (quote apply)) (build-annotated79 #f (list (quote lambda) new-vars1212 (chi142 exp1205 (extend-env100 labels1211 (map (lambda (var1213 level1214) (cons (quote syntax) (cons var1213 level1214))) new-vars1212 (map cdr pvars1204)) r1207) (make-binding-wrap123 ids1209 labels1211 (quote (()))) mod1208))) y1206)))))) (convert-pattern1167 (lambda (pattern1215 keys1216) (let cvt1217 ((p1218 pattern1215) (n1219 0) (ids1220 (quote ()))) (if (id?106 p1218) (if (bound-id-member?133 p1218 keys1216) (values (vector (quote free-id) p1218) ids1220) (values (quote any) (cons (cons p1218 n1219) ids1220))) ((lambda (tmp1221) ((lambda (tmp1222) (if (if tmp1222 (apply (lambda (x1223 dots1224) (ellipsis?151 dots1224)) tmp1222) #f) (apply (lambda (x1225 dots1226) (call-with-values (lambda () (cvt1217 x1225 (fx+71 n1219 1) ids1220)) (lambda (p1227 ids1228) (values (if (eq? p1227 (quote any)) (quote each-any) (vector (quote each) p1227)) ids1228)))) tmp1222) ((lambda (tmp1229) (if tmp1229 (apply (lambda (x1230 y1231) (call-with-values (lambda () (cvt1217 y1231 n1219 ids1220)) (lambda (y1232 ids1233) (call-with-values (lambda () (cvt1217 x1230 n1219 ids1233)) (lambda (x1234 ids1235) (values (cons x1234 y1232) ids1235)))))) tmp1229) ((lambda (tmp1236) (if tmp1236 (apply (lambda () (values (quote ()) ids1220)) tmp1236) ((lambda (tmp1237) (if tmp1237 (apply (lambda (x1238) (call-with-values (lambda () (cvt1217 x1238 n1219 ids1220)) (lambda (p1240 ids1241) (values (vector (quote vector) p1240) ids1241)))) tmp1237) ((lambda (x1242) (values (vector (quote atom) (strip153 p1218 (quote (())))) ids1220)) tmp1221))) ($sc-dispatch tmp1221 (quote #(vector each-any)))))) ($sc-dispatch tmp1221 (quote ()))))) ($sc-dispatch tmp1221 (quote (any . any)))))) ($sc-dispatch tmp1221 (quote (any any))))) p1218)))))) (lambda (e1243 r1244 w1245 s1246 mod1247) (let ((e1248 (source-wrap135 e1243 w1245 s1246 mod1247))) ((lambda (tmp1249) ((lambda (tmp1250) (if tmp1250 (apply (lambda (_1251 val1252 key1253 m1254) (if (and-map (lambda (x1255) (and (id?106 x1255) (not (ellipsis?151 x1255)))) key1253) (let ((x1257 (gen-var154 (quote tmp)))) (build-annotated79 s1246 (list (build-annotated79 #f (list (quote lambda) (list x1257) (gen-syntax-case1170 (build-lexical-reference80 (quote value) #f (quote tmp) x1257) key1253 m1254 r1244 mod1247))) (chi142 val1252 r1244 (quote (())) mod1247)))) (syntax-violation (quote syntax-case) "invalid literals list" e1248))) tmp1250) (syntax-violation #f "source expression failed to match any pattern" tmp1249))) ($sc-dispatch tmp1249 (quote (any any each-any . each-any))))) e1248))))) (set! sc-expand (lambda (x1261 . rest1260) (if (and (pair? x1261) (equal? (car x1261) noexpand69)) (cadr x1261) (let ((m1262 (if (null? rest1260) (quote e) (car rest1260))) (esew1263 (if (or (null? rest1260) (null? (cdr rest1260))) (quote (eval)) (cadr rest1260)))) (with-fluid* *mode*70 m1262 (lambda () (chi-top141 x1261 (quote ()) (quote ((top))) m1262 esew1263 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1264) (nonsymbol-id?105 x1264))) (set! datum->syntax (lambda (id1265 datum1266) (make-syntax-object89 datum1266 (syntax-object-wrap92 id1265) #f))) (set! syntax->datum (lambda (x1267) (strip153 x1267 (quote (()))))) (set! generate-temporaries (lambda (ls1268) (begin (let ((x1269 ls1268)) (if (not (list? x1269)) (syntax-violation (quote generate-temporaries) "invalid argument" x1269))) (map (lambda (x1270) (wrap134 (gensym) (quote ((top))) #f)) ls1268)))) (set! free-identifier=? (lambda (x1271 y1272) (begin (let ((x1273 x1271)) (if (not (nonsymbol-id?105 x1273)) (syntax-violation (quote free-identifier=?) "invalid argument" x1273))) (let ((x1274 y1272)) (if (not (nonsymbol-id?105 x1274)) (syntax-violation (quote free-identifier=?) "invalid argument" x1274))) (free-id=?129 x1271 y1272)))) (set! bound-identifier=? (lambda (x1275 y1276) (begin (let ((x1277 x1275)) (if (not (nonsymbol-id?105 x1277)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1277))) (let ((x1278 y1276)) (if (not (nonsymbol-id?105 x1278)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1278))) (bound-id=?130 x1275 y1276)))) (set! syntax-violation (lambda (who1282 message1281 form1280 . subform1279) (begin (let ((x1283 who1282)) (if (not ((lambda (x1284) (or (not x1284) (string? x1284) (symbol? x1284))) x1283)) (syntax-violation (quote syntax-violation) "invalid argument" x1283))) (let ((x1285 message1281)) (if (not (string? x1285)) (syntax-violation (quote syntax-violation) "invalid argument" x1285))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1282 "~a: " "") "~a " (if (null? subform1279) "in ~a" "in subform `~s' of `~s'")) (let ((tail1286 (cons message1281 (map (lambda (x1287) (strip153 x1287 (quote (())))) (append subform1279 (list form1280)))))) (if who1282 (cons who1282 tail1286) tail1286)) #f)))) (letrec ((match1292 (lambda (e1293 p1294 w1295 r1296 mod1297) (cond ((not r1296) #f) ((eq? p1294 (quote any)) (cons (wrap134 e1293 w1295 mod1297) r1296)) ((syntax-object?90 e1293) (match*1291 (let ((e1298 (syntax-object-expression91 e1293))) (if (annotation? e1298) (annotation-expression e1298) e1298)) p1294 (join-wraps125 w1295 (syntax-object-wrap92 e1293)) r1296 (syntax-object-module93 e1293))) (else (match*1291 (let ((e1299 e1293)) (if (annotation? e1299) (annotation-expression e1299) e1299)) p1294 w1295 r1296 mod1297))))) (match*1291 (lambda (e1300 p1301 w1302 r1303 mod1304) (cond ((null? p1301) (and (null? e1300) r1303)) ((pair? p1301) (and (pair? e1300) (match1292 (car e1300) (car p1301) w1302 (match1292 (cdr e1300) (cdr p1301) w1302 r1303 mod1304) mod1304))) ((eq? p1301 (quote each-any)) (let ((l1305 (match-each-any1289 e1300 w1302 mod1304))) (and l1305 (cons l1305 r1303)))) (else (let ((t1306 (vector-ref p1301 0))) (if (memv t1306 (quote (each))) (if (null? e1300) (match-empty1290 (vector-ref p1301 1) r1303) (let ((l1307 (match-each1288 e1300 (vector-ref p1301 1) w1302 mod1304))) (and l1307 (let collect1308 ((l1309 l1307)) (if (null? (car l1309)) r1303 (cons (map car l1309) (collect1308 (map cdr l1309)))))))) (if (memv t1306 (quote (free-id))) (and (id?106 e1300) (free-id=?129 (wrap134 e1300 w1302 mod1304) (vector-ref p1301 1)) r1303) (if (memv t1306 (quote (atom))) (and (equal? (vector-ref p1301 1) (strip153 e1300 w1302)) r1303) (if (memv t1306 (quote (vector))) (and (vector? e1300) (match1292 (vector->list e1300) (vector-ref p1301 1) w1302 r1303 mod1304))))))))))) (match-empty1290 (lambda (p1310 r1311) (cond ((null? p1310) r1311) ((eq? p1310 (quote any)) (cons (quote ()) r1311)) ((pair? p1310) (match-empty1290 (car p1310) (match-empty1290 (cdr p1310) r1311))) ((eq? p1310 (quote each-any)) (cons (quote ()) r1311)) (else (let ((t1312 (vector-ref p1310 0))) (if (memv t1312 (quote (each))) (match-empty1290 (vector-ref p1310 1) r1311) (if (memv t1312 (quote (free-id atom))) r1311 (if (memv t1312 (quote (vector))) (match-empty1290 (vector-ref p1310 1) r1311))))))))) (match-each-any1289 (lambda (e1313 w1314 mod1315) (cond ((annotation? e1313) (match-each-any1289 (annotation-expression e1313) w1314 mod1315)) ((pair? e1313) (let ((l1316 (match-each-any1289 (cdr e1313) w1314 mod1315))) (and l1316 (cons (wrap134 (car e1313) w1314 mod1315) l1316)))) ((null? e1313) (quote ())) ((syntax-object?90 e1313) (match-each-any1289 (syntax-object-expression91 e1313) (join-wraps125 w1314 (syntax-object-wrap92 e1313)) mod1315)) (else #f)))) (match-each1288 (lambda (e1317 p1318 w1319 mod1320) (cond ((annotation? e1317) (match-each1288 (annotation-expression e1317) p1318 w1319 mod1320)) ((pair? e1317) (let ((first1321 (match1292 (car e1317) p1318 w1319 (quote ()) mod1320))) (and first1321 (let ((rest1322 (match-each1288 (cdr e1317) p1318 w1319 mod1320))) (and rest1322 (cons first1321 rest1322)))))) ((null? e1317) (quote ())) ((syntax-object?90 e1317) (match-each1288 (syntax-object-expression91 e1317) p1318 (join-wraps125 w1319 (syntax-object-wrap92 e1317)) (syntax-object-module93 e1317))) (else #f))))) (set! $sc-dispatch (lambda (e1323 p1324) (cond ((eq? p1324 (quote any)) (list e1323)) ((syntax-object?90 e1323) (match*1291 (let ((e1325 (syntax-object-expression91 e1323))) (if (annotation? e1325) (annotation-expression e1325) e1325)) p1324 (syntax-object-wrap92 e1323) (quote ()) (syntax-object-module93 e1323))) (else (match*1291 (let ((e1326 e1323)) (if (annotation? e1326) (annotation-expression e1326) e1326)) p1324 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1327) ((lambda (tmp1328) ((lambda (tmp1329) (if tmp1329 (apply (lambda (_1330 e11331 e21332) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11331 e21332))) tmp1329) ((lambda (tmp1334) (if tmp1334 (apply (lambda (_1335 out1336 in1337 e11338 e21339) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1337 (quote ()) (list out1336 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11338 e21339))))) tmp1334) ((lambda (tmp1341) (if tmp1341 (apply (lambda (_1342 out1343 in1344 e11345 e21346) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1344) (quote ()) (list out1343 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11345 e21346))))) tmp1341) (syntax-violation #f "source expression failed to match any pattern" tmp1328))) ($sc-dispatch tmp1328 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any () any . each-any))))) x1327)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1350) ((lambda (tmp1351) ((lambda (tmp1352) (if tmp1352 (apply (lambda (_1353 k1354 keyword1355 pattern1356 template1357) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1354 (map (lambda (tmp1360 tmp1359) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1359) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1360))) template1357 pattern1356)))))) tmp1352) (syntax-violation #f "source expression failed to match any pattern" tmp1351))) ($sc-dispatch tmp1351 (quote (any each-any . #(each ((any . any) any))))))) x1350)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1361) ((lambda (tmp1362) ((lambda (tmp1363) (if (if tmp1363 (apply (lambda (let*1364 x1365 v1366 e11367 e21368) (and-map identifier? x1365)) tmp1363) #f) (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (let f1375 ((bindings1376 (map list x1371 v1372))) (if (null? bindings1376) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11373 e21374))) ((lambda (tmp1380) ((lambda (tmp1381) (if tmp1381 (apply (lambda (body1382 binding1383) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1383) body1382)) tmp1381) (syntax-violation #f "source expression failed to match any pattern" tmp1380))) ($sc-dispatch tmp1380 (quote (any any))))) (list (f1375 (cdr bindings1376)) (car bindings1376)))))) tmp1363) (syntax-violation #f "source expression failed to match any pattern" tmp1362))) ($sc-dispatch tmp1362 (quote (any #(each (any any)) any . each-any))))) x1361)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1384) ((lambda (tmp1385) ((lambda (tmp1386) (if tmp1386 (apply (lambda (_1387 var1388 init1389 step1390 e01391 e11392 c1393) ((lambda (tmp1394) ((lambda (tmp1395) (if tmp1395 (apply (lambda (step1396) ((lambda (tmp1397) ((lambda (tmp1398) (if tmp1398 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1388 init1389) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01391) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1393 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1396))))))) tmp1398) ((lambda (tmp1403) (if tmp1403 (apply (lambda (e11404 e21405) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1388 init1389) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01391 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11404 e21405)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1393 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1396))))))) tmp1403) (syntax-violation #f "source expression failed to match any pattern" tmp1397))) ($sc-dispatch tmp1397 (quote (any . each-any)))))) ($sc-dispatch tmp1397 (quote ())))) e11392)) tmp1395) (syntax-violation #f "source expression failed to match any pattern" tmp1394))) ($sc-dispatch tmp1394 (quote each-any)))) (map (lambda (v1412 s1413) ((lambda (tmp1414) ((lambda (tmp1415) (if tmp1415 (apply (lambda () v1412) tmp1415) ((lambda (tmp1416) (if tmp1416 (apply (lambda (e1417) e1417) tmp1416) ((lambda (_1418) (syntax-violation (quote do) "bad step expression" orig-x1384 s1413)) tmp1414))) ($sc-dispatch tmp1414 (quote (any)))))) ($sc-dispatch tmp1414 (quote ())))) s1413)) var1388 step1390))) tmp1386) (syntax-violation #f "source expression failed to match any pattern" tmp1385))) ($sc-dispatch tmp1385 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1384)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1421 (lambda (x1425 y1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (x1429 y1430) ((lambda (tmp1431) ((lambda (tmp1432) (if tmp1432 (apply (lambda (dy1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (dx1436) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1436 dy1433))) tmp1435) ((lambda (_1437) (if (null? dy1433) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1429) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1429 y1430))) tmp1434))) ($sc-dispatch tmp1434 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1429)) tmp1432) ((lambda (tmp1438) (if tmp1438 (apply (lambda (stuff1439) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1429 stuff1439))) tmp1438) ((lambda (else1440) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1429 y1430)) tmp1431))) ($sc-dispatch tmp1431 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1431 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1430)) tmp1428) (syntax-violation #f "source expression failed to match any pattern" tmp1427))) ($sc-dispatch tmp1427 (quote (any any))))) (list x1425 y1426)))) (quasiappend1422 (lambda (x1441 y1442) ((lambda (tmp1443) ((lambda (tmp1444) (if tmp1444 (apply (lambda (x1445 y1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda () x1445) tmp1448) ((lambda (_1449) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1445 y1446)) tmp1447))) ($sc-dispatch tmp1447 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1446)) tmp1444) (syntax-violation #f "source expression failed to match any pattern" tmp1443))) ($sc-dispatch tmp1443 (quote (any any))))) (list x1441 y1442)))) (quasivector1423 (lambda (x1450) ((lambda (tmp1451) ((lambda (x1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda (x1455) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1455))) tmp1454) ((lambda (tmp1457) (if tmp1457 (apply (lambda (x1458) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1458)) tmp1457) ((lambda (_1460) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1452)) tmp1453))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1452)) tmp1451)) x1450))) (quasi1424 (lambda (p1461 lev1462) ((lambda (tmp1463) ((lambda (tmp1464) (if tmp1464 (apply (lambda (p1465) (if (= lev1462 0) p1465 (quasicons1421 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1424 (list p1465) (- lev1462 1))))) tmp1464) ((lambda (tmp1466) (if tmp1466 (apply (lambda (p1467 q1468) (if (= lev1462 0) (quasiappend1422 p1467 (quasi1424 q1468 lev1462)) (quasicons1421 (quasicons1421 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1424 (list p1467) (- lev1462 1))) (quasi1424 q1468 lev1462)))) tmp1466) ((lambda (tmp1469) (if tmp1469 (apply (lambda (p1470) (quasicons1421 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1424 (list p1470) (+ lev1462 1)))) tmp1469) ((lambda (tmp1471) (if tmp1471 (apply (lambda (p1472 q1473) (quasicons1421 (quasi1424 p1472 lev1462) (quasi1424 q1473 lev1462))) tmp1471) ((lambda (tmp1474) (if tmp1474 (apply (lambda (x1475) (quasivector1423 (quasi1424 x1475 lev1462))) tmp1474) ((lambda (p1477) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1477)) tmp1463))) ($sc-dispatch tmp1463 (quote #(vector each-any)))))) ($sc-dispatch tmp1463 (quote (any . any)))))) ($sc-dispatch tmp1463 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1463 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1463 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1461)))) (lambda (x1478) ((lambda (tmp1479) ((lambda (tmp1480) (if tmp1480 (apply (lambda (_1481 e1482) (quasi1424 e1482 0)) tmp1480) (syntax-violation #f "source expression failed to match any pattern" tmp1479))) ($sc-dispatch tmp1479 (quote (any any))))) x1478))))) +(define include (make-syncase-macro (quote macro) (lambda (x1483) (letrec ((read-file1484 (lambda (fn1485 k1486) (let ((p1487 (open-input-file fn1485))) (let f1488 ((x1489 (read p1487))) (if (eof-object? x1489) (begin (close-input-port p1487) (quote ())) (cons (datum->syntax k1486 x1489) (f1488 (read p1487))))))))) ((lambda (tmp1490) ((lambda (tmp1491) (if tmp1491 (apply (lambda (k1492 filename1493) (let ((fn1494 (syntax->datum filename1493))) ((lambda (tmp1495) ((lambda (tmp1496) (if tmp1496 (apply (lambda (exp1497) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1497)) tmp1496) (syntax-violation #f "source expression failed to match any pattern" tmp1495))) ($sc-dispatch tmp1495 (quote each-any)))) (read-file1484 fn1494 k1492)))) tmp1491) (syntax-violation #f "source expression failed to match any pattern" tmp1490))) ($sc-dispatch tmp1490 (quote (any any))))) x1483))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1499) ((lambda (tmp1500) ((lambda (tmp1501) (if tmp1501 (apply (lambda (_1502 e1503) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1499)) tmp1501) (syntax-violation #f "source expression failed to match any pattern" tmp1500))) ($sc-dispatch tmp1500 (quote (any any))))) x1499)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 e1508) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1504)) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any any))))) x1504)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1509) ((lambda (tmp1510) ((lambda (tmp1511) (if tmp1511 (apply (lambda (_1512 e1513 m11514 m21515) ((lambda (tmp1516) ((lambda (body1517) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1513)) body1517)) tmp1516)) (let f1518 ((clause1519 m11514) (clauses1520 m21515)) (if (null? clauses1520) ((lambda (tmp1522) ((lambda (tmp1523) (if tmp1523 (apply (lambda (e11524 e21525) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11524 e21525))) tmp1523) ((lambda (tmp1527) (if tmp1527 (apply (lambda (k1528 e11529 e21530) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1528)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11529 e21530)))) tmp1527) ((lambda (_1533) (syntax-violation (quote case) "bad clause" x1509 clause1519)) tmp1522))) ($sc-dispatch tmp1522 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1522 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1519) ((lambda (tmp1534) ((lambda (rest1535) ((lambda (tmp1536) ((lambda (tmp1537) (if tmp1537 (apply (lambda (k1538 e11539 e21540) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1538)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11539 e21540)) rest1535)) tmp1537) ((lambda (_1543) (syntax-violation (quote case) "bad clause" x1509 clause1519)) tmp1536))) ($sc-dispatch tmp1536 (quote (each-any any . each-any))))) clause1519)) tmp1534)) (f1518 (car clauses1520) (cdr clauses1520))))))) tmp1511) (syntax-violation #f "source expression failed to match any pattern" tmp1510))) ($sc-dispatch tmp1510 (quote (any any any . each-any))))) x1509)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1544) ((lambda (tmp1545) ((lambda (tmp1546) (if tmp1546 (apply (lambda (_1547 e1548) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1548)) (list (cons _1547 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1548 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1546) (syntax-violation #f "source expression failed to match any pattern" tmp1545))) ($sc-dispatch tmp1545 (quote (any any))))) x1544)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index be0efb623..8dfdda34b 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -423,7 +423,7 @@ (define-syntax build-global-definition (syntax-rules () - ((_ source var exp mod) + ((_ source var exp) (build-annotated source `(define ,var ,exp))))) (define-syntax build-lambda @@ -914,29 +914,30 @@ (let ((first (chi-top (car body) r w m esew mod))) (cons first (dobody (cdr body) r w m esew mod)))))))) -;; FIXME: module? (define chi-install-global (lambda (name e) - (build-application no-source - (build-primref no-source 'define) - (list - name - ;; FIXME: seems nasty to call current-module here - (if (let ((v (module-variable (current-module) name))) - ;; FIXME use primitive-macro? - (and v (variable-bound? v) (macro? (variable-ref v)) - (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) - (build-application no-source - (build-primref no-source 'make-extended-syncase-macro) - (list (build-application no-source - (build-primref no-source 'module-ref) - (list (build-application no-source 'current-module '()) - (build-data no-source name))) - (build-data no-source 'macro) - e)) - (build-application no-source - (build-primref no-source 'make-syncase-macro) - (list (build-data no-source 'macro) e))))))) + (build-global-definition + no-source + name + ;; FIXME: seems nasty to call current-module here + (if (let ((v (module-variable (current-module) name))) + ;; FIXME use primitive-macro? + (and v (variable-bound? v) (macro? (variable-ref v)) + (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) + (build-application + no-source + (build-primref no-source 'make-extended-syncase-macro) + (list (build-application + no-source + (build-primref no-source 'module-ref) + (list (build-application no-source 'current-module '()) + (build-data no-source name))) + (build-data no-source 'macro) + e)) + (build-application + no-source + (build-primref no-source 'make-syncase-macro) + (list (build-data no-source 'macro) e)))))) (define chi-when-list (lambda (e when-list w) @@ -1138,7 +1139,7 @@ (case type ((global core macro module-ref) (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) + (build-global-definition s n (chi e r w mod)) mod)) ((displaced-lexical) (syntax-violation #f "identifier out of context" From 1aeb082b8281eb12640d7a42c88a566418c64782 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 May 2009 11:02:10 +0200 Subject: [PATCH 095/375] make expand-support structure constructors take a source argument * module/ice-9/expand-support.scm (make-module-ref, make-lexical): Add source arguments to these constructors. * module/ice-9/psyntax.scm: * module/ice-9/psyntax-pp.scm: Adapt to match, though we don't wire everything up yet. --- module/ice-9/expand-support.scm | 4 ++-- module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 10 +++++----- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm index 5215c2256..33a9b3f00 100644 --- a/module/ice-9/expand-support.scm +++ b/module/ice-9/expand-support.scm @@ -102,7 +102,7 @@ (define (module-ref? x) (and (struct? x) (eq? (struct-vtable x) ))) -(define (make-module-ref modname symbol public?) +(define (make-module-ref source modname symbol public?) (make-struct 0 modname symbol public?)) (define (module-ref-modname a) @@ -126,7 +126,7 @@ (define (lexical? x) (and (struct? x) (eq? (struct-vtable x) ))) -(define (make-lexical name gensym) +(define (make-lexical source name gensym) (make-struct 0 name gensym)) (define (lexical-name a) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index e97081722..b92440648 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,6 +1,6 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list155 (lambda (vars330) (let lvl331 ((vars332 vars330) (ls333 (quote ())) (w334 (quote (())))) (cond ((pair? vars332) (lvl331 (cdr vars332) (cons (wrap134 (car vars332) w334 #f) ls333) w334)) ((id?106 vars332) (cons (wrap134 vars332 w334 #f) ls333)) ((null? vars332) ls333) ((syntax-object?90 vars332) (lvl331 (syntax-object-expression91 vars332) ls333 (join-wraps125 w334 (syntax-object-wrap92 vars332)))) ((annotation? vars332) (lvl331 (annotation-expression vars332) ls333 w334)) (else (cons vars332 ls333)))))) (gen-var154 (lambda (id335) (let ((id336 (if (syntax-object?90 id335) (syntax-object-expression91 id335) id335))) (if (annotation? id336) (build-annotated79 (annotation-source id336) (gensym (symbol->string (annotation-expression id336)))) (build-annotated79 #f (gensym (symbol->string id336))))))) (strip153 (lambda (x337 w338) (if (memq (quote top) (wrap-marks109 w338)) (if (or (annotation? x337) (and (pair? x337) (annotation? (car x337)))) (strip-annotation152 x337 #f) x337) (let f339 ((x340 x337)) (cond ((syntax-object?90 x340) (strip153 (syntax-object-expression91 x340) (syntax-object-wrap92 x340))) ((pair? x340) (let ((a341 (f339 (car x340))) (d342 (f339 (cdr x340)))) (if (and (eq? a341 (car x340)) (eq? d342 (cdr x340))) x340 (cons a341 d342)))) ((vector? x340) (let ((old343 (vector->list x340))) (let ((new344 (map f339 old343))) (if (and-map*17 eq? old343 new344) x340 (list->vector new344))))) (else x340)))))) (strip-annotation152 (lambda (x345 parent346) (cond ((pair? x345) (let ((new347 (cons #f #f))) (begin (if parent346 (set-annotation-stripped! parent346 new347)) (set-car! new347 (strip-annotation152 (car x345) #f)) (set-cdr! new347 (strip-annotation152 (cdr x345) #f)) new347))) ((annotation? x345) (or (annotation-stripped x345) (strip-annotation152 (annotation-expression x345) x345))) ((vector? x345) (let ((new348 (make-vector (vector-length x345)))) (begin (if parent346 (set-annotation-stripped! parent346 new348)) (let loop349 ((i350 (- (vector-length x345) 1))) (unless (fx<74 i350 0) (vector-set! new348 i350 (strip-annotation152 (vector-ref x345 i350) #f)) (loop349 (fx-72 i350 1)))) new348))) (else x345)))) (ellipsis?151 (lambda (x351) (and (nonsymbol-id?105 x351) (free-id=?129 x351 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void150 (lambda () (build-annotated79 #f (cons (build-annotated79 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer149 (lambda (expanded352 mod353) (let ((p354 (local-eval-hook76 expanded352 mod353))) (if (procedure? p354) p354 (syntax-violation #f "nonprocedure transformer" p354))))) (chi-local-syntax148 (lambda (rec?355 e356 r357 w358 s359 mod360 k361) ((lambda (tmp362) ((lambda (tmp363) (if tmp363 (apply (lambda (_364 id365 val366 e1367 e2368) (let ((ids369 id365)) (if (not (valid-bound-ids?131 ids369)) (syntax-violation #f "duplicate bound keyword" e356) (let ((labels371 (gen-labels112 ids369))) (let ((new-w372 (make-binding-wrap123 ids369 labels371 w358))) (k361 (cons e1367 e2368) (extend-env100 labels371 (let ((w374 (if rec?355 new-w372 w358)) (trans-r375 (macros-only-env102 r357))) (map (lambda (x376) (cons (quote macro) (eval-local-transformer149 (chi142 x376 trans-r375 w374 mod360) mod360))) val366)) r357) new-w372 s359 mod360)))))) tmp363) ((lambda (_378) (syntax-violation #f "bad local syntax definition" (source-wrap135 e356 w358 s359 mod360))) tmp362))) ($sc-dispatch tmp362 (quote (any #(each (any any)) any . each-any))))) e356))) (chi-lambda-clause147 (lambda (e379 docstring380 c381 r382 w383 mod384 k385) ((lambda (tmp386) ((lambda (tmp387) (if (if tmp387 (apply (lambda (args388 doc389 e1390 e2391) (and (string? (syntax->datum doc389)) (not docstring380))) tmp387) #f) (apply (lambda (args392 doc393 e1394 e2395) (chi-lambda-clause147 e379 doc393 (cons args392 (cons e1394 e2395)) r382 w383 mod384 k385)) tmp387) ((lambda (tmp397) (if tmp397 (apply (lambda (id398 e1399 e2400) (let ((ids401 id398)) (if (not (valid-bound-ids?131 ids401)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels403 (gen-labels112 ids401)) (new-vars404 (map gen-var154 ids401))) (k385 new-vars404 docstring380 (chi-body146 (cons e1399 e2400) e379 (extend-var-env101 labels403 new-vars404 r382) (make-binding-wrap123 ids401 labels403 w383) mod384)))))) tmp397) ((lambda (tmp406) (if tmp406 (apply (lambda (ids407 e1408 e2409) (let ((old-ids410 (lambda-var-list155 ids407))) (if (not (valid-bound-ids?131 old-ids410)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels411 (gen-labels112 old-ids410)) (new-vars412 (map gen-var154 old-ids410))) (k385 (let f413 ((ls1414 (cdr new-vars412)) (ls2415 (car new-vars412))) (if (null? ls1414) ls2415 (f413 (cdr ls1414) (cons (car ls1414) ls2415)))) docstring380 (chi-body146 (cons e1408 e2409) e379 (extend-var-env101 labels411 new-vars412 r382) (make-binding-wrap123 old-ids410 labels411 w383) mod384)))))) tmp406) ((lambda (_417) (syntax-violation (quote lambda) "bad lambda" e379)) tmp386))) ($sc-dispatch tmp386 (quote (any any . each-any)))))) ($sc-dispatch tmp386 (quote (each-any any . each-any)))))) ($sc-dispatch tmp386 (quote (any any any . each-any))))) c381))) (chi-body146 (lambda (body418 outer-form419 r420 w421 mod422) (let ((r423 (cons (quote ("placeholder" placeholder)) r420))) (let ((ribcage424 (make-ribcage113 (quote ()) (quote ()) (quote ())))) (let ((w425 (make-wrap108 (wrap-marks109 w421) (cons ribcage424 (wrap-subst110 w421))))) (let parse426 ((body427 (map (lambda (x433) (cons r423 (wrap134 x433 w425 mod422))) body418)) (ids428 (quote ())) (labels429 (quote ())) (vars430 (quote ())) (vals431 (quote ())) (bindings432 (quote ()))) (if (null? body427) (syntax-violation #f "no expressions in body" outer-form419) (let ((e434 (cdar body427)) (er435 (caar body427))) (call-with-values (lambda () (syntax-type140 e434 er435 (quote (())) #f ribcage424 mod422)) (lambda (type436 value437 e438 w439 s440 mod441) (let ((t442 type436)) (if (memv t442 (quote (define-form))) (let ((id443 (wrap134 value437 w439 mod441)) (label444 (gen-label111))) (let ((var445 (gen-var154 id443))) (begin (extend-ribcage!122 ribcage424 id443 label444) (parse426 (cdr body427) (cons id443 ids428) (cons label444 labels429) (cons var445 vars430) (cons (cons er435 (wrap134 e438 w439 mod441)) vals431) (cons (cons (quote lexical) var445) bindings432))))) (if (memv t442 (quote (define-syntax-form))) (let ((id446 (wrap134 value437 w439 mod441)) (label447 (gen-label111))) (begin (extend-ribcage!122 ribcage424 id446 label447) (parse426 (cdr body427) (cons id446 ids428) (cons label447 labels429) vars430 vals431 (cons (cons (quote macro) (cons er435 (wrap134 e438 w439 mod441))) bindings432)))) (if (memv t442 (quote (begin-form))) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (_450 e1451) (parse426 (let f452 ((forms453 e1451)) (if (null? forms453) (cdr body427) (cons (cons er435 (wrap134 (car forms453) w439 mod441)) (f452 (cdr forms453))))) ids428 labels429 vars430 vals431 bindings432)) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e438) (if (memv t442 (quote (local-syntax-form))) (chi-local-syntax148 value437 e438 er435 w439 s440 mod441 (lambda (forms455 er456 w457 s458 mod459) (parse426 (let f460 ((forms461 forms455)) (if (null? forms461) (cdr body427) (cons (cons er456 (wrap134 (car forms461) w457 mod459)) (f460 (cdr forms461))))) ids428 labels429 vars430 vals431 bindings432))) (if (null? ids428) (build-sequence85 #f (map (lambda (x462) (chi142 (cdr x462) (car x462) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))) (begin (if (not (valid-bound-ids?131 ids428)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form419)) (let loop463 ((bs464 bindings432) (er-cache465 #f) (r-cache466 #f)) (if (not (null? bs464)) (let ((b467 (car bs464))) (if (eq? (car b467) (quote macro)) (let ((er468 (cadr b467))) (let ((r-cache469 (if (eq? er468 er-cache465) r-cache466 (macros-only-env102 er468)))) (begin (set-cdr! b467 (eval-local-transformer149 (chi142 (cddr b467) r-cache469 (quote (())) mod441) mod441)) (loop463 (cdr bs464) er468 r-cache469)))) (loop463 (cdr bs464) er-cache465 r-cache466))))) (set-cdr! r423 (extend-env100 labels429 bindings432 (cdr r423))) (build-letrec88 #f vars430 (map (lambda (x470) (chi142 (cdr x470) (car x470) (quote (())) mod441)) vals431) (build-sequence85 #f (map (lambda (x471) (chi142 (cdr x471) (car x471) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))))))))))))))))))))) (chi-macro145 (lambda (p472 e473 r474 w475 rib476 mod477) (letrec ((rebuild-macro-output478 (lambda (x479 m480) (cond ((pair? x479) (cons (rebuild-macro-output478 (car x479) m480) (rebuild-macro-output478 (cdr x479) m480))) ((syntax-object?90 x479) (let ((w481 (syntax-object-wrap92 x479))) (let ((ms482 (wrap-marks109 w481)) (s483 (wrap-subst110 w481))) (if (and (pair? ms482) (eq? (car ms482) #f)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cdr ms482) (if rib476 (cons rib476 (cdr s483)) (cdr s483))) (syntax-object-module93 x479)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cons m480 ms482) (if rib476 (cons rib476 (cons (quote shift) s483)) (cons (quote shift) s483))) (let ((pmod484 (procedure-module p472))) (if pmod484 (cons (quote hygiene) (module-name pmod484)) (quote (hygiene guile))))))))) ((vector? x479) (let ((n485 (vector-length x479))) (let ((v486 (make-vector n485))) (let doloop487 ((i488 0)) (if (fx=73 i488 n485) v486 (begin (vector-set! v486 i488 (rebuild-macro-output478 (vector-ref x479 i488) m480)) (doloop487 (fx+71 i488 1)))))))) ((symbol? x479) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap135 e473 w475 s mod477) x479)) (else x479))))) (rebuild-macro-output478 (p472 (wrap134 e473 (anti-mark121 w475) mod477)) (string #\m))))) (chi-application144 (lambda (x489 e490 r491 w492 s493 mod494) ((lambda (tmp495) ((lambda (tmp496) (if tmp496 (apply (lambda (e0497 e1498) (build-annotated79 s493 (cons x489 (map (lambda (e499) (chi142 e499 r491 w492 mod494)) e1498)))) tmp496) (syntax-violation #f "source expression failed to match any pattern" tmp495))) ($sc-dispatch tmp495 (quote (any . each-any))))) e490))) (chi-expr143 (lambda (type501 value502 e503 r504 w505 s506 mod507) (let ((t508 type501)) (if (memv t508 (quote (lexical))) (build-lexical-reference80 (quote value) s506 e503 value502) (if (memv t508 (quote (core external-macro))) (value502 e503 r504 w505 s506 mod507) (if (memv t508 (quote (module-ref))) (call-with-values (lambda () (value502 e503)) (lambda (id509 mod510) (build-global-reference82 s506 id509 mod510))) (if (memv t508 (quote (lexical-call))) (chi-application144 (build-lexical-reference80 (quote fun) (source-annotation97 (car e503)) (car e503) value502) e503 r504 w505 s506 mod507) (if (memv t508 (quote (global-call))) (chi-application144 (build-global-reference82 (source-annotation97 (car e503)) value502 (if (syntax-object?90 (car e503)) (syntax-object-module93 (car e503)) mod507)) e503 r504 w505 s506 mod507) (if (memv t508 (quote (constant))) (build-data84 s506 (strip153 (source-wrap135 e503 w505 s506 mod507) (quote (())))) (if (memv t508 (quote (global))) (build-global-reference82 s506 value502 mod507) (if (memv t508 (quote (call))) (chi-application144 (chi142 (car e503) r504 w505 mod507) e503 r504 w505 s506 mod507) (if (memv t508 (quote (begin-form))) ((lambda (tmp511) ((lambda (tmp512) (if tmp512 (apply (lambda (_513 e1514 e2515) (chi-sequence136 (cons e1514 e2515) r504 w505 s506 mod507)) tmp512) (syntax-violation #f "source expression failed to match any pattern" tmp511))) ($sc-dispatch tmp511 (quote (any any . each-any))))) e503) (if (memv t508 (quote (local-syntax-form))) (chi-local-syntax148 value502 e503 r504 w505 s506 mod507 chi-sequence136) (if (memv t508 (quote (eval-when-form))) ((lambda (tmp517) ((lambda (tmp518) (if tmp518 (apply (lambda (_519 x520 e1521 e2522) (let ((when-list523 (chi-when-list139 e503 x520 w505))) (if (memq (quote eval) when-list523) (chi-sequence136 (cons e1521 e2522) r504 w505 s506 mod507) (chi-void150)))) tmp518) (syntax-violation #f "source expression failed to match any pattern" tmp517))) ($sc-dispatch tmp517 (quote (any each-any any . each-any))))) e503) (if (memv t508 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e503 (wrap134 value502 w505 mod507)) (if (memv t508 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap135 e503 w505 s506 mod507)) (if (memv t508 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap135 e503 w505 s506 mod507)) (syntax-violation #f "unexpected syntax" (source-wrap135 e503 w505 s506 mod507))))))))))))))))))) (chi142 (lambda (e526 r527 w528 mod529) (call-with-values (lambda () (syntax-type140 e526 r527 w528 #f #f mod529)) (lambda (type530 value531 e532 w533 s534 mod535) (chi-expr143 type530 value531 e532 r527 w533 s534 mod535))))) (chi-top141 (lambda (e536 r537 w538 m539 esew540 mod541) (call-with-values (lambda () (syntax-type140 e536 r537 w538 #f #f mod541)) (lambda (type549 value550 e551 w552 s553 mod554) (let ((t555 type549)) (if (memv t555 (quote (begin-form))) ((lambda (tmp556) ((lambda (tmp557) (if tmp557 (apply (lambda (_558) (chi-void150)) tmp557) ((lambda (tmp559) (if tmp559 (apply (lambda (_560 e1561 e2562) (chi-top-sequence137 (cons e1561 e2562) r537 w552 s553 m539 esew540 mod554)) tmp559) (syntax-violation #f "source expression failed to match any pattern" tmp556))) ($sc-dispatch tmp556 (quote (any any . each-any)))))) ($sc-dispatch tmp556 (quote (any))))) e551) (if (memv t555 (quote (local-syntax-form))) (chi-local-syntax148 value550 e551 r537 w552 s553 mod554 (lambda (body564 r565 w566 s567 mod568) (chi-top-sequence137 body564 r565 w566 s567 m539 esew540 mod568))) (if (memv t555 (quote (eval-when-form))) ((lambda (tmp569) ((lambda (tmp570) (if tmp570 (apply (lambda (_571 x572 e1573 e2574) (let ((when-list575 (chi-when-list139 e551 x572 w552)) (body576 (cons e1573 e2574))) (cond ((eq? m539 (quote e)) (if (memq (quote eval) when-list575) (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) (chi-void150))) ((memq (quote load) when-list575) (if (or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (chi-top-sequence137 body576 r537 w552 s553 (quote c&e) (quote (compile load)) mod554) (if (memq m539 (quote (c c&e))) (chi-top-sequence137 body576 r537 w552 s553 (quote c) (quote (load)) mod554) (chi-void150)))) ((or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (top-level-eval-hook75 (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) mod554) (chi-void150)) (else (chi-void150))))) tmp570) (syntax-violation #f "source expression failed to match any pattern" tmp569))) ($sc-dispatch tmp569 (quote (any each-any any . each-any))))) e551) (if (memv t555 (quote (define-syntax-form))) (let ((n579 (id-var-name128 value550 w552)) (r580 (macros-only-env102 r537))) (let ((t581 m539)) (if (memv t581 (quote (c))) (if (memq (quote compile) esew540) (let ((e582 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e582 mod554) (if (memq (quote load) esew540) e582 (chi-void150)))) (if (memq (quote load) esew540) (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) (chi-void150))) (if (memv t581 (quote (c&e))) (let ((e583 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e583 mod554) e583)) (begin (if (memq (quote eval) esew540) (top-level-eval-hook75 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) mod554)) (chi-void150)))))) (if (memv t555 (quote (define-form))) (let ((n584 (id-var-name128 value550 w552))) (let ((type585 (binding-type98 (lookup103 n584 r537 mod554)))) (let ((t586 type585)) (if (memv t586 (quote (global core macro module-ref))) (let ((x587 (build-annotated79 s553 (list (quote define) n584 (chi142 e551 r537 w552 mod554))))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x587 mod554)) x587)) (if (memv t586 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e551 (wrap134 value550 w552 mod554)) (syntax-violation #f "cannot define keyword at top level" e551 (wrap134 value550 w552 mod554))))))) (let ((x588 (chi-expr143 type549 value550 e551 r537 w552 s553 mod554))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x588 mod554)) x588)))))))))))) (syntax-type140 (lambda (e589 r590 w591 s592 rib593 mod594) (cond ((symbol? e589) (let ((n595 (id-var-name128 e589 w591))) (let ((b596 (lookup103 n595 r590 mod594))) (let ((type597 (binding-type98 b596))) (let ((t598 type597)) (if (memv t598 (quote (lexical))) (values type597 (binding-value99 b596) e589 w591 s592 mod594) (if (memv t598 (quote (global))) (values type597 n595 e589 w591 s592 mod594) (if (memv t598 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b596) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (values type597 (binding-value99 b596) e589 w591 s592 mod594))))))))) ((pair? e589) (let ((first599 (car e589))) (if (id?106 first599) (let ((n600 (id-var-name128 first599 w591))) (let ((b601 (lookup103 n600 r590 (or (and (syntax-object?90 first599) (syntax-object-module93 first599)) mod594)))) (let ((type602 (binding-type98 b601))) (let ((t603 type602)) (if (memv t603 (quote (lexical))) (values (quote lexical-call) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (global))) (values (quote global-call) n600 e589 w591 s592 mod594) (if (memv t603 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b601) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (if (memv t603 (quote (core external-macro module-ref))) (values type602 (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (begin))) (values (quote begin-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (eval-when))) (values (quote eval-when-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (define))) ((lambda (tmp604) ((lambda (tmp605) (if (if tmp605 (apply (lambda (_606 name607 val608) (id?106 name607)) tmp605) #f) (apply (lambda (_609 name610 val611) (values (quote define-form) name610 val611 w591 s592 mod594)) tmp605) ((lambda (tmp612) (if (if tmp612 (apply (lambda (_613 name614 args615 e1616 e2617) (and (id?106 name614) (valid-bound-ids?131 (lambda-var-list155 args615)))) tmp612) #f) (apply (lambda (_618 name619 args620 e1621 e2622) (values (quote define-form) (wrap134 name619 w591 mod594) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap134 (cons args620 (cons e1621 e2622)) w591 mod594)) (quote (())) s592 mod594)) tmp612) ((lambda (tmp624) (if (if tmp624 (apply (lambda (_625 name626) (id?106 name626)) tmp624) #f) (apply (lambda (_627 name628) (values (quote define-form) (wrap134 name628 w591 mod594) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s592 mod594)) tmp624) (syntax-violation #f "source expression failed to match any pattern" tmp604))) ($sc-dispatch tmp604 (quote (any any)))))) ($sc-dispatch tmp604 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp604 (quote (any any any))))) e589) (if (memv t603 (quote (define-syntax))) ((lambda (tmp629) ((lambda (tmp630) (if (if tmp630 (apply (lambda (_631 name632 val633) (id?106 name632)) tmp630) #f) (apply (lambda (_634 name635 val636) (values (quote define-syntax-form) name635 val636 w591 s592 mod594)) tmp630) (syntax-violation #f "source expression failed to match any pattern" tmp629))) ($sc-dispatch tmp629 (quote (any any any))))) e589) (values (quote call) #f e589 w591 s592 mod594)))))))))))))) (values (quote call) #f e589 w591 s592 mod594)))) ((syntax-object?90 e589) (syntax-type140 (syntax-object-expression91 e589) r590 (join-wraps125 w591 (syntax-object-wrap92 e589)) #f rib593 (or (syntax-object-module93 e589) mod594))) ((annotation? e589) (syntax-type140 (annotation-expression e589) r590 w591 (annotation-source e589) rib593 mod594)) ((self-evaluating? e589) (values (quote constant) #f e589 w591 s592 mod594)) (else (values (quote other) #f e589 w591 s592 mod594))))) (chi-when-list139 (lambda (e637 when-list638 w639) (let f640 ((when-list641 when-list638) (situations642 (quote ()))) (if (null? when-list641) situations642 (f640 (cdr when-list641) (cons (let ((x643 (car when-list641))) (cond ((free-id=?129 x643 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?129 x643 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?129 x643 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e637 (wrap134 x643 w639 #f))))) situations642)))))) (chi-install-global138 (lambda (name644 e645) (build-annotated79 #f (list (quote define) name644 (if (let ((v646 (module-variable (current-module) name644))) (and v646 (variable-bound? v646) (macro? (variable-ref v646)) (not (eq? (macro-type (variable-ref v646)) (quote syncase-macro))))) (build-annotated79 #f (list (build-annotated79 #f (quote make-extended-syncase-macro)) (build-annotated79 #f (list (build-annotated79 #f (quote module-ref)) (build-annotated79 #f (quote (current-module))) (build-data84 #f name644))) (build-data84 #f (quote macro)) e645)) (build-annotated79 #f (list (build-annotated79 #f (quote make-syncase-macro)) (build-data84 #f (quote macro)) e645))))))) (chi-top-sequence137 (lambda (body647 r648 w649 s650 m651 esew652 mod653) (build-sequence85 s650 (let dobody654 ((body655 body647) (r656 r648) (w657 w649) (m658 m651) (esew659 esew652) (mod660 mod653)) (if (null? body655) (quote ()) (let ((first661 (chi-top141 (car body655) r656 w657 m658 esew659 mod660))) (cons first661 (dobody654 (cdr body655) r656 w657 m658 esew659 mod660)))))))) (chi-sequence136 (lambda (body662 r663 w664 s665 mod666) (build-sequence85 s665 (let dobody667 ((body668 body662) (r669 r663) (w670 w664) (mod671 mod666)) (if (null? body668) (quote ()) (let ((first672 (chi142 (car body668) r669 w670 mod671))) (cons first672 (dobody667 (cdr body668) r669 w670 mod671)))))))) (source-wrap135 (lambda (x673 w674 s675 defmod676) (wrap134 (if s675 (make-annotation x673 s675 #f) x673) w674 defmod676))) (wrap134 (lambda (x677 w678 defmod679) (cond ((and (null? (wrap-marks109 w678)) (null? (wrap-subst110 w678))) x677) ((syntax-object?90 x677) (make-syntax-object89 (syntax-object-expression91 x677) (join-wraps125 w678 (syntax-object-wrap92 x677)) (syntax-object-module93 x677))) ((null? x677) x677) (else (make-syntax-object89 x677 w678 defmod679))))) (bound-id-member?133 (lambda (x680 list681) (and (not (null? list681)) (or (bound-id=?130 x680 (car list681)) (bound-id-member?133 x680 (cdr list681)))))) (distinct-bound-ids?132 (lambda (ids682) (let distinct?683 ((ids684 ids682)) (or (null? ids684) (and (not (bound-id-member?133 (car ids684) (cdr ids684))) (distinct?683 (cdr ids684))))))) (valid-bound-ids?131 (lambda (ids685) (and (let all-ids?686 ((ids687 ids685)) (or (null? ids687) (and (id?106 (car ids687)) (all-ids?686 (cdr ids687))))) (distinct-bound-ids?132 ids685)))) (bound-id=?130 (lambda (i688 j689) (if (and (syntax-object?90 i688) (syntax-object?90 j689)) (and (eq? (let ((e690 (syntax-object-expression91 i688))) (if (annotation? e690) (annotation-expression e690) e690)) (let ((e691 (syntax-object-expression91 j689))) (if (annotation? e691) (annotation-expression e691) e691))) (same-marks?127 (wrap-marks109 (syntax-object-wrap92 i688)) (wrap-marks109 (syntax-object-wrap92 j689)))) (eq? (let ((e692 i688)) (if (annotation? e692) (annotation-expression e692) e692)) (let ((e693 j689)) (if (annotation? e693) (annotation-expression e693) e693)))))) (free-id=?129 (lambda (i694 j695) (and (eq? (let ((x696 i694)) (let ((e697 (if (syntax-object?90 x696) (syntax-object-expression91 x696) x696))) (if (annotation? e697) (annotation-expression e697) e697))) (let ((x698 j695)) (let ((e699 (if (syntax-object?90 x698) (syntax-object-expression91 x698) x698))) (if (annotation? e699) (annotation-expression e699) e699)))) (eq? (id-var-name128 i694 (quote (()))) (id-var-name128 j695 (quote (()))))))) (id-var-name128 (lambda (id700 w701) (letrec ((search-vector-rib704 (lambda (sym710 subst711 marks712 symnames713 ribcage714) (let ((n715 (vector-length symnames713))) (let f716 ((i717 0)) (cond ((fx=73 i717 n715) (search702 sym710 (cdr subst711) marks712)) ((and (eq? (vector-ref symnames713 i717) sym710) (same-marks?127 marks712 (vector-ref (ribcage-marks116 ribcage714) i717))) (values (vector-ref (ribcage-labels117 ribcage714) i717) marks712)) (else (f716 (fx+71 i717 1)))))))) (search-list-rib703 (lambda (sym718 subst719 marks720 symnames721 ribcage722) (let f723 ((symnames724 symnames721) (i725 0)) (cond ((null? symnames724) (search702 sym718 (cdr subst719) marks720)) ((and (eq? (car symnames724) sym718) (same-marks?127 marks720 (list-ref (ribcage-marks116 ribcage722) i725))) (values (list-ref (ribcage-labels117 ribcage722) i725) marks720)) (else (f723 (cdr symnames724) (fx+71 i725 1))))))) (search702 (lambda (sym726 subst727 marks728) (if (null? subst727) (values #f marks728) (let ((fst729 (car subst727))) (if (eq? fst729 (quote shift)) (search702 sym726 (cdr subst727) (cdr marks728)) (let ((symnames730 (ribcage-symnames115 fst729))) (if (vector? symnames730) (search-vector-rib704 sym726 subst727 marks728 symnames730 fst729) (search-list-rib703 sym726 subst727 marks728 symnames730 fst729))))))))) (cond ((symbol? id700) (or (call-with-values (lambda () (search702 id700 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x732 . ignore731) x732)) id700)) ((syntax-object?90 id700) (let ((id733 (let ((e735 (syntax-object-expression91 id700))) (if (annotation? e735) (annotation-expression e735) e735))) (w1734 (syntax-object-wrap92 id700))) (let ((marks736 (join-marks126 (wrap-marks109 w701) (wrap-marks109 w1734)))) (call-with-values (lambda () (search702 id733 (wrap-subst110 w701) marks736)) (lambda (new-id737 marks738) (or new-id737 (call-with-values (lambda () (search702 id733 (wrap-subst110 w1734) marks738)) (lambda (x740 . ignore739) x740)) id733)))))) ((annotation? id700) (let ((id741 (let ((e742 id700)) (if (annotation? e742) (annotation-expression e742) e742)))) (or (call-with-values (lambda () (search702 id741 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x744 . ignore743) x744)) id741))) (else (syntax-violation (quote id-var-name) "invalid id" id700)))))) (same-marks?127 (lambda (x745 y746) (or (eq? x745 y746) (and (not (null? x745)) (not (null? y746)) (eq? (car x745) (car y746)) (same-marks?127 (cdr x745) (cdr y746)))))) (join-marks126 (lambda (m1747 m2748) (smart-append124 m1747 m2748))) (join-wraps125 (lambda (w1749 w2750) (let ((m1751 (wrap-marks109 w1749)) (s1752 (wrap-subst110 w1749))) (if (null? m1751) (if (null? s1752) w2750 (make-wrap108 (wrap-marks109 w2750) (smart-append124 s1752 (wrap-subst110 w2750)))) (make-wrap108 (smart-append124 m1751 (wrap-marks109 w2750)) (smart-append124 s1752 (wrap-subst110 w2750))))))) (smart-append124 (lambda (m1753 m2754) (if (null? m2754) m1753 (append m1753 m2754)))) (make-binding-wrap123 (lambda (ids755 labels756 w757) (if (null? ids755) w757 (make-wrap108 (wrap-marks109 w757) (cons (let ((labelvec758 (list->vector labels756))) (let ((n759 (vector-length labelvec758))) (let ((symnamevec760 (make-vector n759)) (marksvec761 (make-vector n759))) (begin (let f762 ((ids763 ids755) (i764 0)) (if (not (null? ids763)) (call-with-values (lambda () (id-sym-name&marks107 (car ids763) w757)) (lambda (symname765 marks766) (begin (vector-set! symnamevec760 i764 symname765) (vector-set! marksvec761 i764 marks766) (f762 (cdr ids763) (fx+71 i764 1))))))) (make-ribcage113 symnamevec760 marksvec761 labelvec758))))) (wrap-subst110 w757)))))) (extend-ribcage!122 (lambda (ribcage767 id768 label769) (begin (set-ribcage-symnames!118 ribcage767 (cons (let ((e770 (syntax-object-expression91 id768))) (if (annotation? e770) (annotation-expression e770) e770)) (ribcage-symnames115 ribcage767))) (set-ribcage-marks!119 ribcage767 (cons (wrap-marks109 (syntax-object-wrap92 id768)) (ribcage-marks116 ribcage767))) (set-ribcage-labels!120 ribcage767 (cons label769 (ribcage-labels117 ribcage767)))))) (anti-mark121 (lambda (w771) (make-wrap108 (cons #f (wrap-marks109 w771)) (cons (quote shift) (wrap-subst110 w771))))) (set-ribcage-labels!120 (lambda (x772 update773) (vector-set! x772 3 update773))) (set-ribcage-marks!119 (lambda (x774 update775) (vector-set! x774 2 update775))) (set-ribcage-symnames!118 (lambda (x776 update777) (vector-set! x776 1 update777))) (ribcage-labels117 (lambda (x778) (vector-ref x778 3))) (ribcage-marks116 (lambda (x779) (vector-ref x779 2))) (ribcage-symnames115 (lambda (x780) (vector-ref x780 1))) (ribcage?114 (lambda (x781) (and (vector? x781) (= (vector-length x781) 4) (eq? (vector-ref x781 0) (quote ribcage))))) (make-ribcage113 (lambda (symnames782 marks783 labels784) (vector (quote ribcage) symnames782 marks783 labels784))) (gen-labels112 (lambda (ls785) (if (null? ls785) (quote ()) (cons (gen-label111) (gen-labels112 (cdr ls785)))))) (gen-label111 (lambda () (string #\i))) (wrap-subst110 cdr) (wrap-marks109 car) (make-wrap108 cons) (id-sym-name&marks107 (lambda (x786 w787) (if (syntax-object?90 x786) (values (let ((e788 (syntax-object-expression91 x786))) (if (annotation? e788) (annotation-expression e788) e788)) (join-marks126 (wrap-marks109 w787) (wrap-marks109 (syntax-object-wrap92 x786)))) (values (let ((e789 x786)) (if (annotation? e789) (annotation-expression e789) e789)) (wrap-marks109 w787))))) (id?106 (lambda (x790) (cond ((symbol? x790) #t) ((syntax-object?90 x790) (symbol? (let ((e791 (syntax-object-expression91 x790))) (if (annotation? e791) (annotation-expression e791) e791)))) ((annotation? x790) (symbol? (annotation-expression x790))) (else #f)))) (nonsymbol-id?105 (lambda (x792) (and (syntax-object?90 x792) (symbol? (let ((e793 (syntax-object-expression91 x792))) (if (annotation? e793) (annotation-expression e793) e793)))))) (global-extend104 (lambda (type794 sym795 val796) (put-global-definition-hook77 sym795 type794 val796))) (lookup103 (lambda (x797 r798 mod799) (cond ((assq x797 r798) => cdr) ((symbol? x797) (or (get-global-definition-hook78 x797 mod799) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env102 (lambda (r800) (if (null? r800) (quote ()) (let ((a801 (car r800))) (if (eq? (cadr a801) (quote macro)) (cons a801 (macros-only-env102 (cdr r800))) (macros-only-env102 (cdr r800))))))) (extend-var-env101 (lambda (labels802 vars803 r804) (if (null? labels802) r804 (extend-var-env101 (cdr labels802) (cdr vars803) (cons (cons (car labels802) (cons (quote lexical) (car vars803))) r804))))) (extend-env100 (lambda (labels805 bindings806 r807) (if (null? labels805) r807 (extend-env100 (cdr labels805) (cdr bindings806) (cons (cons (car labels805) (car bindings806)) r807))))) (binding-value99 cdr) (binding-type98 car) (source-annotation97 (lambda (x808) (cond ((annotation? x808) (annotation-source x808)) ((syntax-object?90 x808) (source-annotation97 (syntax-object-expression91 x808))) (else #f)))) (set-syntax-object-module!96 (lambda (x809 update810) (vector-set! x809 3 update810))) (set-syntax-object-wrap!95 (lambda (x811 update812) (vector-set! x811 2 update812))) (set-syntax-object-expression!94 (lambda (x813 update814) (vector-set! x813 1 update814))) (syntax-object-module93 (lambda (x815) (vector-ref x815 3))) (syntax-object-wrap92 (lambda (x816) (vector-ref x816 2))) (syntax-object-expression91 (lambda (x817) (vector-ref x817 1))) (syntax-object?90 (lambda (x818) (and (vector? x818) (= (vector-length x818) 4) (eq? (vector-ref x818 0) (quote syntax-object))))) (make-syntax-object89 (lambda (expression819 wrap820 module821) (vector (quote syntax-object) expression819 wrap820 module821))) (build-letrec88 (lambda (src822 vars823 val-exps824 body-exp825) (if (null? vars823) (build-annotated79 src822 body-exp825) (build-annotated79 src822 (list (quote letrec) (map list vars823 val-exps824) body-exp825))))) (build-named-let87 (lambda (src826 vars827 val-exps828 body-exp829) (if (null? vars827) (build-annotated79 src826 body-exp829) (build-annotated79 src826 (list (quote let) (car vars827) (map list (cdr vars827) val-exps828) body-exp829))))) (build-let86 (lambda (src830 vars831 val-exps832 body-exp833) (if (null? vars831) (build-annotated79 src830 body-exp833) (build-annotated79 src830 (list (quote let) (map list vars831 val-exps832) body-exp833))))) (build-sequence85 (lambda (src834 exps835) (if (null? (cdr exps835)) (build-annotated79 src834 (car exps835)) (build-annotated79 src834 (cons (quote begin) exps835))))) (build-data84 (lambda (src836 exp837) (if (and (self-evaluating? exp837) (not (vector? exp837))) (build-annotated79 src836 exp837) (build-annotated79 src836 (list (quote quote) exp837))))) (build-global-assignment83 (lambda (source838 var839 exp840 mod841) (let ((ref842 (build-global-reference82 source838 var839 mod841))) (build-annotated79 source838 (list (quote set!) ref842 exp840))))) (build-global-reference82 (lambda (source843 var844 mod845) (build-annotated79 source843 (if (not mod845) var844 (let ((make-module-ref846 (let ((t849 (fluid-ref *mode*70))) (if (memv t849 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851))))) (kind847 (car mod845)) (mod848 (cdr mod845))) (let ((t853 kind847)) (if (memv t853 (quote (public))) (make-module-ref846 mod848 var844 #t) (if (memv t853 (quote (private))) (if (not (equal? mod848 (module-name (current-module)))) (make-module-ref846 mod848 var844 #f) var844) (if (memv t853 (quote (bare))) var844 (if (memv t853 (quote (hygiene))) (if (and (not (equal? mod848 (module-name (current-module)))) (module-variable (resolve-module mod848) var844)) (make-module-ref846 mod848 var844 #f) var844) (syntax-violation #f "bad module kind" var844 mod848))))))))))) (build-lexical-assignment81 (lambda (source854 name855 var856 exp857) (build-annotated79 source854 (list (quote set!) (build-lexical-reference80 (quote set) #f name855 var856) exp857)))) (build-lexical-reference80 (lambda (type858 source859 name860 var861) (build-annotated79 source859 (let ((t862 (fluid-ref *mode*70))) (if (memv t862 (quote (c))) ((@ (ice-9 expand-support) make-lexical) name860 var861) var861))))) (build-annotated79 (lambda (src863 exp864) (if (and src863 (not (annotation? exp864))) (make-annotation exp864 src863 #t) exp864))) (get-global-definition-hook78 (lambda (symbol865 module866) (begin (if (and (not module866) (current-module)) (warn "module system is booted, we should have a module" symbol865)) (let ((v867 (module-variable (if module866 (resolve-module (cdr module866)) (current-module)) symbol865))) (and v867 (variable-bound? v867) (let ((val868 (variable-ref v867))) (and (macro? val868) (syncase-macro-type val868) (cons (syncase-macro-type val868) (syncase-macro-binding val868))))))))) (put-global-definition-hook77 (lambda (symbol869 type870 val871) (let ((existing872 (let ((v873 (module-variable (current-module) symbol869))) (and v873 (variable-bound? v873) (let ((val874 (variable-ref v873))) (and (macro? val874) (not (syncase-macro-type val874)) val874)))))) (module-define! (current-module) symbol869 (if existing872 (make-extended-syncase-macro existing872 type870 val871) (make-syncase-macro type870 val871)))))) (local-eval-hook76 (lambda (x875 mod876) (primitive-eval (list noexpand69 (let ((t877 (fluid-ref *mode*70))) (if (memv t877 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x875) x875)))))) (top-level-eval-hook75 (lambda (x878 mod879) (primitive-eval (list noexpand69 (let ((t880 (fluid-ref *mode*70))) (if (memv t880 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x878) x878)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend104 (quote local-syntax) (quote letrec-syntax) #t) (global-extend104 (quote local-syntax) (quote let-syntax) #f) (global-extend104 (quote core) (quote fluid-let-syntax) (lambda (e881 r882 w883 s884 mod885) ((lambda (tmp886) ((lambda (tmp887) (if (if tmp887 (apply (lambda (_888 var889 val890 e1891 e2892) (valid-bound-ids?131 var889)) tmp887) #f) (apply (lambda (_894 var895 val896 e1897 e2898) (let ((names899 (map (lambda (x900) (id-var-name128 x900 w883)) var895))) (begin (for-each (lambda (id902 n903) (let ((t904 (binding-type98 (lookup103 n903 r882 mod885)))) (if (memv t904 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e881 (source-wrap135 id902 w883 s884 mod885))))) var895 names899) (chi-body146 (cons e1897 e2898) (source-wrap135 e881 w883 s884 mod885) (extend-env100 names899 (let ((trans-r907 (macros-only-env102 r882))) (map (lambda (x908) (cons (quote macro) (eval-local-transformer149 (chi142 x908 trans-r907 w883 mod885) mod885))) val896)) r882) w883 mod885)))) tmp887) ((lambda (_910) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap135 e881 w883 s884 mod885))) tmp886))) ($sc-dispatch tmp886 (quote (any #(each (any any)) any . each-any))))) e881))) (global-extend104 (quote core) (quote quote) (lambda (e911 r912 w913 s914 mod915) ((lambda (tmp916) ((lambda (tmp917) (if tmp917 (apply (lambda (_918 e919) (build-data84 s914 (strip153 e919 w913))) tmp917) ((lambda (_920) (syntax-violation (quote quote) "bad syntax" (source-wrap135 e911 w913 s914 mod915))) tmp916))) ($sc-dispatch tmp916 (quote (any any))))) e911))) (global-extend104 (quote core) (quote syntax) (letrec ((regen928 (lambda (x929) (let ((t930 (car x929))) (if (memv t930 (quote (ref))) (build-lexical-reference80 (quote value) #f (cadr x929) (cadr x929)) (if (memv t930 (quote (primitive))) (build-annotated79 #f (cadr x929)) (if (memv t930 (quote (quote))) (build-data84 #f (cadr x929)) (if (memv t930 (quote (lambda))) (build-annotated79 #f (list (quote lambda) (cadr x929) (regen928 (caddr x929)))) (if (memv t930 (quote (map))) (let ((ls931 (map regen928 (cdr x929)))) (build-annotated79 #f (cons (if (fx=73 (length ls931) 2) (build-annotated79 #f (quote map)) (build-annotated79 #f (quote map))) ls931))) (build-annotated79 #f (cons (build-annotated79 #f (car x929)) (map regen928 (cdr x929)))))))))))) (gen-vector927 (lambda (x932) (cond ((eq? (car x932) (quote list)) (cons (quote vector) (cdr x932))) ((eq? (car x932) (quote quote)) (list (quote quote) (list->vector (cadr x932)))) (else (list (quote list->vector) x932))))) (gen-append926 (lambda (x933 y934) (if (equal? y934 (quote (quote ()))) x933 (list (quote append) x933 y934)))) (gen-cons925 (lambda (x935 y936) (let ((t937 (car y936))) (if (memv t937 (quote (quote))) (if (eq? (car x935) (quote quote)) (list (quote quote) (cons (cadr x935) (cadr y936))) (if (eq? (cadr y936) (quote ())) (list (quote list) x935) (list (quote cons) x935 y936))) (if (memv t937 (quote (list))) (cons (quote list) (cons x935 (cdr y936))) (list (quote cons) x935 y936)))))) (gen-map924 (lambda (e938 map-env939) (let ((formals940 (map cdr map-env939)) (actuals941 (map (lambda (x942) (list (quote ref) (car x942))) map-env939))) (cond ((eq? (car e938) (quote ref)) (car actuals941)) ((and-map (lambda (x943) (and (eq? (car x943) (quote ref)) (memq (cadr x943) formals940))) (cdr e938)) (cons (quote map) (cons (list (quote primitive) (car e938)) (map (let ((r944 (map cons formals940 actuals941))) (lambda (x945) (cdr (assq (cadr x945) r944)))) (cdr e938))))) (else (cons (quote map) (cons (list (quote lambda) formals940 e938) actuals941))))))) (gen-mappend923 (lambda (e946 map-env947) (list (quote apply) (quote (primitive append)) (gen-map924 e946 map-env947)))) (gen-ref922 (lambda (src948 var949 level950 maps951) (if (fx=73 level950 0) (values var949 maps951) (if (null? maps951) (syntax-violation (quote syntax) "missing ellipsis" src948) (call-with-values (lambda () (gen-ref922 src948 var949 (fx-72 level950 1) (cdr maps951))) (lambda (outer-var952 outer-maps953) (let ((b954 (assq outer-var952 (car maps951)))) (if b954 (values (cdr b954) maps951) (let ((inner-var955 (gen-var154 (quote tmp)))) (values inner-var955 (cons (cons (cons outer-var952 inner-var955) (car maps951)) outer-maps953))))))))))) (gen-syntax921 (lambda (src956 e957 r958 maps959 ellipsis?960 mod961) (if (id?106 e957) (let ((label962 (id-var-name128 e957 (quote (()))))) (let ((b963 (lookup103 label962 r958 mod961))) (if (eq? (binding-type98 b963) (quote syntax)) (call-with-values (lambda () (let ((var.lev964 (binding-value99 b963))) (gen-ref922 src956 (car var.lev964) (cdr var.lev964) maps959))) (lambda (var965 maps966) (values (list (quote ref) var965) maps966))) (if (ellipsis?960 e957) (syntax-violation (quote syntax) "misplaced ellipsis" src956) (values (list (quote quote) e957) maps959))))) ((lambda (tmp967) ((lambda (tmp968) (if (if tmp968 (apply (lambda (dots969 e970) (ellipsis?960 dots969)) tmp968) #f) (apply (lambda (dots971 e972) (gen-syntax921 src956 e972 r958 maps959 (lambda (x973) #f) mod961)) tmp968) ((lambda (tmp974) (if (if tmp974 (apply (lambda (x975 dots976 y977) (ellipsis?960 dots976)) tmp974) #f) (apply (lambda (x978 dots979 y980) (let f981 ((y982 y980) (k983 (lambda (maps984) (call-with-values (lambda () (gen-syntax921 src956 x978 r958 (cons (quote ()) maps984) ellipsis?960 mod961)) (lambda (x985 maps986) (if (null? (car maps986)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-map924 x985 (car maps986)) (cdr maps986)))))))) ((lambda (tmp987) ((lambda (tmp988) (if (if tmp988 (apply (lambda (dots989 y990) (ellipsis?960 dots989)) tmp988) #f) (apply (lambda (dots991 y992) (f981 y992 (lambda (maps993) (call-with-values (lambda () (k983 (cons (quote ()) maps993))) (lambda (x994 maps995) (if (null? (car maps995)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-mappend923 x994 (car maps995)) (cdr maps995)))))))) tmp988) ((lambda (_996) (call-with-values (lambda () (gen-syntax921 src956 y982 r958 maps959 ellipsis?960 mod961)) (lambda (y997 maps998) (call-with-values (lambda () (k983 maps998)) (lambda (x999 maps1000) (values (gen-append926 x999 y997) maps1000)))))) tmp987))) ($sc-dispatch tmp987 (quote (any . any))))) y982))) tmp974) ((lambda (tmp1001) (if tmp1001 (apply (lambda (x1002 y1003) (call-with-values (lambda () (gen-syntax921 src956 x1002 r958 maps959 ellipsis?960 mod961)) (lambda (x1004 maps1005) (call-with-values (lambda () (gen-syntax921 src956 y1003 r958 maps1005 ellipsis?960 mod961)) (lambda (y1006 maps1007) (values (gen-cons925 x1004 y1006) maps1007)))))) tmp1001) ((lambda (tmp1008) (if tmp1008 (apply (lambda (e11009 e21010) (call-with-values (lambda () (gen-syntax921 src956 (cons e11009 e21010) r958 maps959 ellipsis?960 mod961)) (lambda (e1012 maps1013) (values (gen-vector927 e1012) maps1013)))) tmp1008) ((lambda (_1014) (values (list (quote quote) e957) maps959)) tmp967))) ($sc-dispatch tmp967 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp967 (quote (any . any)))))) ($sc-dispatch tmp967 (quote (any any . any)))))) ($sc-dispatch tmp967 (quote (any any))))) e957))))) (lambda (e1015 r1016 w1017 s1018 mod1019) (let ((e1020 (source-wrap135 e1015 w1017 s1018 mod1019))) ((lambda (tmp1021) ((lambda (tmp1022) (if tmp1022 (apply (lambda (_1023 x1024) (call-with-values (lambda () (gen-syntax921 e1020 x1024 r1016 (quote ()) ellipsis?151 mod1019)) (lambda (e1025 maps1026) (regen928 e1025)))) tmp1022) ((lambda (_1027) (syntax-violation (quote syntax) "bad `syntax' form" e1020)) tmp1021))) ($sc-dispatch tmp1021 (quote (any any))))) e1020))))) (global-extend104 (quote core) (quote lambda) (lambda (e1028 r1029 w1030 s1031 mod1032) ((lambda (tmp1033) ((lambda (tmp1034) (if tmp1034 (apply (lambda (_1035 c1036) (chi-lambda-clause147 (source-wrap135 e1028 w1030 s1031 mod1032) #f c1036 r1029 w1030 mod1032 (lambda (vars1037 docstring1038 body1039) (build-annotated79 s1031 (cons (quote lambda) (cons vars1037 (append (if docstring1038 (list docstring1038) (quote ())) (list body1039)))))))) tmp1034) (syntax-violation #f "source expression failed to match any pattern" tmp1033))) ($sc-dispatch tmp1033 (quote (any . any))))) e1028))) (global-extend104 (quote core) (quote let) (letrec ((chi-let1040 (lambda (e1041 r1042 w1043 s1044 mod1045 constructor1046 ids1047 vals1048 exps1049) (if (not (valid-bound-ids?131 ids1047)) (syntax-violation (quote let) "duplicate bound variable" e1041) (let ((labels1050 (gen-labels112 ids1047)) (new-vars1051 (map gen-var154 ids1047))) (let ((nw1052 (make-binding-wrap123 ids1047 labels1050 w1043)) (nr1053 (extend-var-env101 labels1050 new-vars1051 r1042))) (constructor1046 s1044 new-vars1051 (map (lambda (x1054) (chi142 x1054 r1042 w1043 mod1045)) vals1048) (chi-body146 exps1049 (source-wrap135 e1041 nw1052 s1044 mod1045) nr1053 nw1052 mod1045)))))))) (lambda (e1055 r1056 w1057 s1058 mod1059) ((lambda (tmp1060) ((lambda (tmp1061) (if tmp1061 (apply (lambda (_1062 id1063 val1064 e11065 e21066) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-let86 id1063 val1064 (cons e11065 e21066))) tmp1061) ((lambda (tmp1070) (if (if tmp1070 (apply (lambda (_1071 f1072 id1073 val1074 e11075 e21076) (id?106 f1072)) tmp1070) #f) (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-named-let87 (cons f1078 id1079) val1080 (cons e11081 e21082))) tmp1070) ((lambda (_1086) (syntax-violation (quote let) "bad let" (source-wrap135 e1055 w1057 s1058 mod1059))) tmp1060))) ($sc-dispatch tmp1060 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1060 (quote (any #(each (any any)) any . each-any))))) e1055)))) (global-extend104 (quote core) (quote letrec) (lambda (e1087 r1088 w1089 s1090 mod1091) ((lambda (tmp1092) ((lambda (tmp1093) (if tmp1093 (apply (lambda (_1094 id1095 val1096 e11097 e21098) (let ((ids1099 id1095)) (if (not (valid-bound-ids?131 ids1099)) (syntax-violation (quote letrec) "duplicate bound variable" e1087) (let ((labels1101 (gen-labels112 ids1099)) (new-vars1102 (map gen-var154 ids1099))) (let ((w1103 (make-binding-wrap123 ids1099 labels1101 w1089)) (r1104 (extend-var-env101 labels1101 new-vars1102 r1088))) (build-letrec88 s1090 new-vars1102 (map (lambda (x1105) (chi142 x1105 r1104 w1103 mod1091)) val1096) (chi-body146 (cons e11097 e21098) (source-wrap135 e1087 w1103 s1090 mod1091) r1104 w1103 mod1091))))))) tmp1093) ((lambda (_1108) (syntax-violation (quote letrec) "bad letrec" (source-wrap135 e1087 w1089 s1090 mod1091))) tmp1092))) ($sc-dispatch tmp1092 (quote (any #(each (any any)) any . each-any))))) e1087))) (global-extend104 (quote core) (quote set!) (lambda (e1109 r1110 w1111 s1112 mod1113) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (_1116 id1117 val1118) (id?106 id1117)) tmp1115) #f) (apply (lambda (_1119 id1120 val1121) (let ((val1122 (chi142 val1121 r1110 w1111 mod1113)) (n1123 (id-var-name128 id1120 w1111))) (let ((b1124 (lookup103 n1123 r1110 mod1113))) (let ((t1125 (binding-type98 b1124))) (if (memv t1125 (quote (lexical))) (build-lexical-assignment81 s1112 (syntax->datum id1120) (binding-value99 b1124) val1122) (if (memv t1125 (quote (global))) (build-global-assignment83 s1112 n1123 val1122 mod1113) (if (memv t1125 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap134 id1120 w1111 mod1113)) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))))))))) tmp1115) ((lambda (tmp1126) (if tmp1126 (apply (lambda (_1127 head1128 tail1129 val1130) (call-with-values (lambda () (syntax-type140 head1128 r1110 (quote (())) #f #f mod1113)) (lambda (type1131 value1132 ee1133 ww1134 ss1135 modmod1136) (let ((t1137 type1131)) (if (memv t1137 (quote (module-ref))) (let ((val1138 (chi142 val1130 r1110 w1111 mod1113))) (call-with-values (lambda () (value1132 (cons head1128 tail1129))) (lambda (id1140 mod1141) (build-global-assignment83 s1112 id1140 val1138 mod1141)))) (build-annotated79 s1112 (cons (chi142 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1128) r1110 w1111 mod1113) (map (lambda (e1142) (chi142 e1142 r1110 w1111 mod1113)) (append tail1129 (list val1130)))))))))) tmp1126) ((lambda (_1144) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))) tmp1114))) ($sc-dispatch tmp1114 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1114 (quote (any any any))))) e1109))) (global-extend104 (quote module-ref) (quote @) (lambda (e1145) ((lambda (tmp1146) ((lambda (tmp1147) (if (if tmp1147 (apply (lambda (_1148 mod1149 id1150) (and (and-map id?106 mod1149) (id?106 id1150))) tmp1147) #f) (apply (lambda (_1152 mod1153 id1154) (values (syntax->datum id1154) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1153)))) tmp1147) (syntax-violation #f "source expression failed to match any pattern" tmp1146))) ($sc-dispatch tmp1146 (quote (any each-any any))))) e1145))) (global-extend104 (quote module-ref) (quote @@) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (and (and-map id?106 mod1160) (id?106 id1161))) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend104 (quote begin) (quote begin) (quote ())) (global-extend104 (quote define) (quote define) (quote ())) (global-extend104 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend104 (quote eval-when) (quote eval-when) (quote ())) (global-extend104 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1170 (lambda (x1171 keys1172 clauses1173 r1174 mod1175) (if (null? clauses1173) (build-annotated79 #f (list (build-annotated79 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1171)) ((lambda (tmp1176) ((lambda (tmp1177) (if tmp1177 (apply (lambda (pat1178 exp1179) (if (and (id?106 pat1178) (and-map (lambda (x1180) (not (free-id=?129 pat1178 x1180))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1172))) (let ((labels1181 (list (gen-label111))) (var1182 (gen-var154 pat1178))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list var1182) (chi142 exp1179 (extend-env100 labels1181 (list (cons (quote syntax) (cons var1182 0))) r1174) (make-binding-wrap123 (list pat1178) labels1181 (quote (()))) mod1175))) x1171))) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1178 #t exp1179 mod1175))) tmp1177) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 fender1185 exp1186) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1184 fender1185 exp1186 mod1175)) tmp1183) ((lambda (_1187) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1173))) tmp1176))) ($sc-dispatch tmp1176 (quote (any any any)))))) ($sc-dispatch tmp1176 (quote (any any))))) (car clauses1173))))) (gen-clause1169 (lambda (x1188 keys1189 clauses1190 r1191 pat1192 fender1193 exp1194 mod1195) (call-with-values (lambda () (convert-pattern1167 pat1192 keys1189)) (lambda (p1196 pvars1197) (cond ((not (distinct-bound-ids?132 (map car pvars1197))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1192)) ((not (and-map (lambda (x1198) (not (ellipsis?151 (car x1198)))) pvars1197)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1192)) (else (let ((y1199 (gen-var154 (quote tmp)))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list y1199) (let ((y1200 (build-lexical-reference80 (quote value) #f (quote tmp) y1199))) (build-annotated79 #f (list (quote if) ((lambda (tmp1201) ((lambda (tmp1202) (if tmp1202 (apply (lambda () y1200) tmp1202) ((lambda (_1203) (build-annotated79 #f (list (quote if) y1200 (build-dispatch-call1168 pvars1197 fender1193 y1200 r1191 mod1195) (build-data84 #f #f)))) tmp1201))) ($sc-dispatch tmp1201 (quote #(atom #t))))) fender1193) (build-dispatch-call1168 pvars1197 exp1194 y1200 r1191 mod1195) (gen-syntax-case1170 x1188 keys1189 clauses1190 r1191 mod1195)))))) (if (eq? p1196 (quote any)) (build-annotated79 #f (list (build-annotated79 #f (quote list)) x1188)) (build-annotated79 #f (list (build-annotated79 #f (quote $sc-dispatch)) x1188 (build-data84 #f p1196))))))))))))) (build-dispatch-call1168 (lambda (pvars1204 exp1205 y1206 r1207 mod1208) (let ((ids1209 (map car pvars1204)) (levels1210 (map cdr pvars1204))) (let ((labels1211 (gen-labels112 ids1209)) (new-vars1212 (map gen-var154 ids1209))) (build-annotated79 #f (list (build-annotated79 #f (quote apply)) (build-annotated79 #f (list (quote lambda) new-vars1212 (chi142 exp1205 (extend-env100 labels1211 (map (lambda (var1213 level1214) (cons (quote syntax) (cons var1213 level1214))) new-vars1212 (map cdr pvars1204)) r1207) (make-binding-wrap123 ids1209 labels1211 (quote (()))) mod1208))) y1206)))))) (convert-pattern1167 (lambda (pattern1215 keys1216) (let cvt1217 ((p1218 pattern1215) (n1219 0) (ids1220 (quote ()))) (if (id?106 p1218) (if (bound-id-member?133 p1218 keys1216) (values (vector (quote free-id) p1218) ids1220) (values (quote any) (cons (cons p1218 n1219) ids1220))) ((lambda (tmp1221) ((lambda (tmp1222) (if (if tmp1222 (apply (lambda (x1223 dots1224) (ellipsis?151 dots1224)) tmp1222) #f) (apply (lambda (x1225 dots1226) (call-with-values (lambda () (cvt1217 x1225 (fx+71 n1219 1) ids1220)) (lambda (p1227 ids1228) (values (if (eq? p1227 (quote any)) (quote each-any) (vector (quote each) p1227)) ids1228)))) tmp1222) ((lambda (tmp1229) (if tmp1229 (apply (lambda (x1230 y1231) (call-with-values (lambda () (cvt1217 y1231 n1219 ids1220)) (lambda (y1232 ids1233) (call-with-values (lambda () (cvt1217 x1230 n1219 ids1233)) (lambda (x1234 ids1235) (values (cons x1234 y1232) ids1235)))))) tmp1229) ((lambda (tmp1236) (if tmp1236 (apply (lambda () (values (quote ()) ids1220)) tmp1236) ((lambda (tmp1237) (if tmp1237 (apply (lambda (x1238) (call-with-values (lambda () (cvt1217 x1238 n1219 ids1220)) (lambda (p1240 ids1241) (values (vector (quote vector) p1240) ids1241)))) tmp1237) ((lambda (x1242) (values (vector (quote atom) (strip153 p1218 (quote (())))) ids1220)) tmp1221))) ($sc-dispatch tmp1221 (quote #(vector each-any)))))) ($sc-dispatch tmp1221 (quote ()))))) ($sc-dispatch tmp1221 (quote (any . any)))))) ($sc-dispatch tmp1221 (quote (any any))))) p1218)))))) (lambda (e1243 r1244 w1245 s1246 mod1247) (let ((e1248 (source-wrap135 e1243 w1245 s1246 mod1247))) ((lambda (tmp1249) ((lambda (tmp1250) (if tmp1250 (apply (lambda (_1251 val1252 key1253 m1254) (if (and-map (lambda (x1255) (and (id?106 x1255) (not (ellipsis?151 x1255)))) key1253) (let ((x1257 (gen-var154 (quote tmp)))) (build-annotated79 s1246 (list (build-annotated79 #f (list (quote lambda) (list x1257) (gen-syntax-case1170 (build-lexical-reference80 (quote value) #f (quote tmp) x1257) key1253 m1254 r1244 mod1247))) (chi142 val1252 r1244 (quote (())) mod1247)))) (syntax-violation (quote syntax-case) "invalid literals list" e1248))) tmp1250) (syntax-violation #f "source expression failed to match any pattern" tmp1249))) ($sc-dispatch tmp1249 (quote (any any each-any . each-any))))) e1248))))) (set! sc-expand (lambda (x1261 . rest1260) (if (and (pair? x1261) (equal? (car x1261) noexpand69)) (cadr x1261) (let ((m1262 (if (null? rest1260) (quote e) (car rest1260))) (esew1263 (if (or (null? rest1260) (null? (cdr rest1260))) (quote (eval)) (cadr rest1260)))) (with-fluid* *mode*70 m1262 (lambda () (chi-top141 x1261 (quote ()) (quote ((top))) m1262 esew1263 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1264) (nonsymbol-id?105 x1264))) (set! datum->syntax (lambda (id1265 datum1266) (make-syntax-object89 datum1266 (syntax-object-wrap92 id1265) #f))) (set! syntax->datum (lambda (x1267) (strip153 x1267 (quote (()))))) (set! generate-temporaries (lambda (ls1268) (begin (let ((x1269 ls1268)) (if (not (list? x1269)) (syntax-violation (quote generate-temporaries) "invalid argument" x1269))) (map (lambda (x1270) (wrap134 (gensym) (quote ((top))) #f)) ls1268)))) (set! free-identifier=? (lambda (x1271 y1272) (begin (let ((x1273 x1271)) (if (not (nonsymbol-id?105 x1273)) (syntax-violation (quote free-identifier=?) "invalid argument" x1273))) (let ((x1274 y1272)) (if (not (nonsymbol-id?105 x1274)) (syntax-violation (quote free-identifier=?) "invalid argument" x1274))) (free-id=?129 x1271 y1272)))) (set! bound-identifier=? (lambda (x1275 y1276) (begin (let ((x1277 x1275)) (if (not (nonsymbol-id?105 x1277)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1277))) (let ((x1278 y1276)) (if (not (nonsymbol-id?105 x1278)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1278))) (bound-id=?130 x1275 y1276)))) (set! syntax-violation (lambda (who1282 message1281 form1280 . subform1279) (begin (let ((x1283 who1282)) (if (not ((lambda (x1284) (or (not x1284) (string? x1284) (symbol? x1284))) x1283)) (syntax-violation (quote syntax-violation) "invalid argument" x1283))) (let ((x1285 message1281)) (if (not (string? x1285)) (syntax-violation (quote syntax-violation) "invalid argument" x1285))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1282 "~a: " "") "~a " (if (null? subform1279) "in ~a" "in subform `~s' of `~s'")) (let ((tail1286 (cons message1281 (map (lambda (x1287) (strip153 x1287 (quote (())))) (append subform1279 (list form1280)))))) (if who1282 (cons who1282 tail1286) tail1286)) #f)))) (letrec ((match1292 (lambda (e1293 p1294 w1295 r1296 mod1297) (cond ((not r1296) #f) ((eq? p1294 (quote any)) (cons (wrap134 e1293 w1295 mod1297) r1296)) ((syntax-object?90 e1293) (match*1291 (let ((e1298 (syntax-object-expression91 e1293))) (if (annotation? e1298) (annotation-expression e1298) e1298)) p1294 (join-wraps125 w1295 (syntax-object-wrap92 e1293)) r1296 (syntax-object-module93 e1293))) (else (match*1291 (let ((e1299 e1293)) (if (annotation? e1299) (annotation-expression e1299) e1299)) p1294 w1295 r1296 mod1297))))) (match*1291 (lambda (e1300 p1301 w1302 r1303 mod1304) (cond ((null? p1301) (and (null? e1300) r1303)) ((pair? p1301) (and (pair? e1300) (match1292 (car e1300) (car p1301) w1302 (match1292 (cdr e1300) (cdr p1301) w1302 r1303 mod1304) mod1304))) ((eq? p1301 (quote each-any)) (let ((l1305 (match-each-any1289 e1300 w1302 mod1304))) (and l1305 (cons l1305 r1303)))) (else (let ((t1306 (vector-ref p1301 0))) (if (memv t1306 (quote (each))) (if (null? e1300) (match-empty1290 (vector-ref p1301 1) r1303) (let ((l1307 (match-each1288 e1300 (vector-ref p1301 1) w1302 mod1304))) (and l1307 (let collect1308 ((l1309 l1307)) (if (null? (car l1309)) r1303 (cons (map car l1309) (collect1308 (map cdr l1309)))))))) (if (memv t1306 (quote (free-id))) (and (id?106 e1300) (free-id=?129 (wrap134 e1300 w1302 mod1304) (vector-ref p1301 1)) r1303) (if (memv t1306 (quote (atom))) (and (equal? (vector-ref p1301 1) (strip153 e1300 w1302)) r1303) (if (memv t1306 (quote (vector))) (and (vector? e1300) (match1292 (vector->list e1300) (vector-ref p1301 1) w1302 r1303 mod1304))))))))))) (match-empty1290 (lambda (p1310 r1311) (cond ((null? p1310) r1311) ((eq? p1310 (quote any)) (cons (quote ()) r1311)) ((pair? p1310) (match-empty1290 (car p1310) (match-empty1290 (cdr p1310) r1311))) ((eq? p1310 (quote each-any)) (cons (quote ()) r1311)) (else (let ((t1312 (vector-ref p1310 0))) (if (memv t1312 (quote (each))) (match-empty1290 (vector-ref p1310 1) r1311) (if (memv t1312 (quote (free-id atom))) r1311 (if (memv t1312 (quote (vector))) (match-empty1290 (vector-ref p1310 1) r1311))))))))) (match-each-any1289 (lambda (e1313 w1314 mod1315) (cond ((annotation? e1313) (match-each-any1289 (annotation-expression e1313) w1314 mod1315)) ((pair? e1313) (let ((l1316 (match-each-any1289 (cdr e1313) w1314 mod1315))) (and l1316 (cons (wrap134 (car e1313) w1314 mod1315) l1316)))) ((null? e1313) (quote ())) ((syntax-object?90 e1313) (match-each-any1289 (syntax-object-expression91 e1313) (join-wraps125 w1314 (syntax-object-wrap92 e1313)) mod1315)) (else #f)))) (match-each1288 (lambda (e1317 p1318 w1319 mod1320) (cond ((annotation? e1317) (match-each1288 (annotation-expression e1317) p1318 w1319 mod1320)) ((pair? e1317) (let ((first1321 (match1292 (car e1317) p1318 w1319 (quote ()) mod1320))) (and first1321 (let ((rest1322 (match-each1288 (cdr e1317) p1318 w1319 mod1320))) (and rest1322 (cons first1321 rest1322)))))) ((null? e1317) (quote ())) ((syntax-object?90 e1317) (match-each1288 (syntax-object-expression91 e1317) p1318 (join-wraps125 w1319 (syntax-object-wrap92 e1317)) (syntax-object-module93 e1317))) (else #f))))) (set! $sc-dispatch (lambda (e1323 p1324) (cond ((eq? p1324 (quote any)) (list e1323)) ((syntax-object?90 e1323) (match*1291 (let ((e1325 (syntax-object-expression91 e1323))) (if (annotation? e1325) (annotation-expression e1325) e1325)) p1324 (syntax-object-wrap92 e1323) (quote ()) (syntax-object-module93 e1323))) (else (match*1291 (let ((e1326 e1323)) (if (annotation? e1326) (annotation-expression e1326) e1326)) p1324 (quote (())) (quote ()) #f))))))))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list155 (lambda (vars330) (let lvl331 ((vars332 vars330) (ls333 (quote ())) (w334 (quote (())))) (cond ((pair? vars332) (lvl331 (cdr vars332) (cons (wrap134 (car vars332) w334 #f) ls333) w334)) ((id?106 vars332) (cons (wrap134 vars332 w334 #f) ls333)) ((null? vars332) ls333) ((syntax-object?90 vars332) (lvl331 (syntax-object-expression91 vars332) ls333 (join-wraps125 w334 (syntax-object-wrap92 vars332)))) ((annotation? vars332) (lvl331 (annotation-expression vars332) ls333 w334)) (else (cons vars332 ls333)))))) (gen-var154 (lambda (id335) (let ((id336 (if (syntax-object?90 id335) (syntax-object-expression91 id335) id335))) (if (annotation? id336) (build-annotated79 (annotation-source id336) (gensym (symbol->string (annotation-expression id336)))) (build-annotated79 #f (gensym (symbol->string id336))))))) (strip153 (lambda (x337 w338) (if (memq (quote top) (wrap-marks109 w338)) (if (or (annotation? x337) (and (pair? x337) (annotation? (car x337)))) (strip-annotation152 x337 #f) x337) (let f339 ((x340 x337)) (cond ((syntax-object?90 x340) (strip153 (syntax-object-expression91 x340) (syntax-object-wrap92 x340))) ((pair? x340) (let ((a341 (f339 (car x340))) (d342 (f339 (cdr x340)))) (if (and (eq? a341 (car x340)) (eq? d342 (cdr x340))) x340 (cons a341 d342)))) ((vector? x340) (let ((old343 (vector->list x340))) (let ((new344 (map f339 old343))) (if (and-map*17 eq? old343 new344) x340 (list->vector new344))))) (else x340)))))) (strip-annotation152 (lambda (x345 parent346) (cond ((pair? x345) (let ((new347 (cons #f #f))) (begin (if parent346 (set-annotation-stripped! parent346 new347)) (set-car! new347 (strip-annotation152 (car x345) #f)) (set-cdr! new347 (strip-annotation152 (cdr x345) #f)) new347))) ((annotation? x345) (or (annotation-stripped x345) (strip-annotation152 (annotation-expression x345) x345))) ((vector? x345) (let ((new348 (make-vector (vector-length x345)))) (begin (if parent346 (set-annotation-stripped! parent346 new348)) (let loop349 ((i350 (- (vector-length x345) 1))) (unless (fx<74 i350 0) (vector-set! new348 i350 (strip-annotation152 (vector-ref x345 i350) #f)) (loop349 (fx-72 i350 1)))) new348))) (else x345)))) (ellipsis?151 (lambda (x351) (and (nonsymbol-id?105 x351) (free-id=?129 x351 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void150 (lambda () (build-annotated79 #f (cons (build-annotated79 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer149 (lambda (expanded352 mod353) (let ((p354 (local-eval-hook76 expanded352 mod353))) (if (procedure? p354) p354 (syntax-violation #f "nonprocedure transformer" p354))))) (chi-local-syntax148 (lambda (rec?355 e356 r357 w358 s359 mod360 k361) ((lambda (tmp362) ((lambda (tmp363) (if tmp363 (apply (lambda (_364 id365 val366 e1367 e2368) (let ((ids369 id365)) (if (not (valid-bound-ids?131 ids369)) (syntax-violation #f "duplicate bound keyword" e356) (let ((labels371 (gen-labels112 ids369))) (let ((new-w372 (make-binding-wrap123 ids369 labels371 w358))) (k361 (cons e1367 e2368) (extend-env100 labels371 (let ((w374 (if rec?355 new-w372 w358)) (trans-r375 (macros-only-env102 r357))) (map (lambda (x376) (cons (quote macro) (eval-local-transformer149 (chi142 x376 trans-r375 w374 mod360) mod360))) val366)) r357) new-w372 s359 mod360)))))) tmp363) ((lambda (_378) (syntax-violation #f "bad local syntax definition" (source-wrap135 e356 w358 s359 mod360))) tmp362))) ($sc-dispatch tmp362 (quote (any #(each (any any)) any . each-any))))) e356))) (chi-lambda-clause147 (lambda (e379 docstring380 c381 r382 w383 mod384 k385) ((lambda (tmp386) ((lambda (tmp387) (if (if tmp387 (apply (lambda (args388 doc389 e1390 e2391) (and (string? (syntax->datum doc389)) (not docstring380))) tmp387) #f) (apply (lambda (args392 doc393 e1394 e2395) (chi-lambda-clause147 e379 doc393 (cons args392 (cons e1394 e2395)) r382 w383 mod384 k385)) tmp387) ((lambda (tmp397) (if tmp397 (apply (lambda (id398 e1399 e2400) (let ((ids401 id398)) (if (not (valid-bound-ids?131 ids401)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels403 (gen-labels112 ids401)) (new-vars404 (map gen-var154 ids401))) (k385 new-vars404 docstring380 (chi-body146 (cons e1399 e2400) e379 (extend-var-env101 labels403 new-vars404 r382) (make-binding-wrap123 ids401 labels403 w383) mod384)))))) tmp397) ((lambda (tmp406) (if tmp406 (apply (lambda (ids407 e1408 e2409) (let ((old-ids410 (lambda-var-list155 ids407))) (if (not (valid-bound-ids?131 old-ids410)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels411 (gen-labels112 old-ids410)) (new-vars412 (map gen-var154 old-ids410))) (k385 (let f413 ((ls1414 (cdr new-vars412)) (ls2415 (car new-vars412))) (if (null? ls1414) ls2415 (f413 (cdr ls1414) (cons (car ls1414) ls2415)))) docstring380 (chi-body146 (cons e1408 e2409) e379 (extend-var-env101 labels411 new-vars412 r382) (make-binding-wrap123 old-ids410 labels411 w383) mod384)))))) tmp406) ((lambda (_417) (syntax-violation (quote lambda) "bad lambda" e379)) tmp386))) ($sc-dispatch tmp386 (quote (any any . each-any)))))) ($sc-dispatch tmp386 (quote (each-any any . each-any)))))) ($sc-dispatch tmp386 (quote (any any any . each-any))))) c381))) (chi-body146 (lambda (body418 outer-form419 r420 w421 mod422) (let ((r423 (cons (quote ("placeholder" placeholder)) r420))) (let ((ribcage424 (make-ribcage113 (quote ()) (quote ()) (quote ())))) (let ((w425 (make-wrap108 (wrap-marks109 w421) (cons ribcage424 (wrap-subst110 w421))))) (let parse426 ((body427 (map (lambda (x433) (cons r423 (wrap134 x433 w425 mod422))) body418)) (ids428 (quote ())) (labels429 (quote ())) (vars430 (quote ())) (vals431 (quote ())) (bindings432 (quote ()))) (if (null? body427) (syntax-violation #f "no expressions in body" outer-form419) (let ((e434 (cdar body427)) (er435 (caar body427))) (call-with-values (lambda () (syntax-type140 e434 er435 (quote (())) #f ribcage424 mod422)) (lambda (type436 value437 e438 w439 s440 mod441) (let ((t442 type436)) (if (memv t442 (quote (define-form))) (let ((id443 (wrap134 value437 w439 mod441)) (label444 (gen-label111))) (let ((var445 (gen-var154 id443))) (begin (extend-ribcage!122 ribcage424 id443 label444) (parse426 (cdr body427) (cons id443 ids428) (cons label444 labels429) (cons var445 vars430) (cons (cons er435 (wrap134 e438 w439 mod441)) vals431) (cons (cons (quote lexical) var445) bindings432))))) (if (memv t442 (quote (define-syntax-form))) (let ((id446 (wrap134 value437 w439 mod441)) (label447 (gen-label111))) (begin (extend-ribcage!122 ribcage424 id446 label447) (parse426 (cdr body427) (cons id446 ids428) (cons label447 labels429) vars430 vals431 (cons (cons (quote macro) (cons er435 (wrap134 e438 w439 mod441))) bindings432)))) (if (memv t442 (quote (begin-form))) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (_450 e1451) (parse426 (let f452 ((forms453 e1451)) (if (null? forms453) (cdr body427) (cons (cons er435 (wrap134 (car forms453) w439 mod441)) (f452 (cdr forms453))))) ids428 labels429 vars430 vals431 bindings432)) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e438) (if (memv t442 (quote (local-syntax-form))) (chi-local-syntax148 value437 e438 er435 w439 s440 mod441 (lambda (forms455 er456 w457 s458 mod459) (parse426 (let f460 ((forms461 forms455)) (if (null? forms461) (cdr body427) (cons (cons er456 (wrap134 (car forms461) w457 mod459)) (f460 (cdr forms461))))) ids428 labels429 vars430 vals431 bindings432))) (if (null? ids428) (build-sequence85 #f (map (lambda (x462) (chi142 (cdr x462) (car x462) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))) (begin (if (not (valid-bound-ids?131 ids428)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form419)) (let loop463 ((bs464 bindings432) (er-cache465 #f) (r-cache466 #f)) (if (not (null? bs464)) (let ((b467 (car bs464))) (if (eq? (car b467) (quote macro)) (let ((er468 (cadr b467))) (let ((r-cache469 (if (eq? er468 er-cache465) r-cache466 (macros-only-env102 er468)))) (begin (set-cdr! b467 (eval-local-transformer149 (chi142 (cddr b467) r-cache469 (quote (())) mod441) mod441)) (loop463 (cdr bs464) er468 r-cache469)))) (loop463 (cdr bs464) er-cache465 r-cache466))))) (set-cdr! r423 (extend-env100 labels429 bindings432 (cdr r423))) (build-letrec88 #f vars430 (map (lambda (x470) (chi142 (cdr x470) (car x470) (quote (())) mod441)) vals431) (build-sequence85 #f (map (lambda (x471) (chi142 (cdr x471) (car x471) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))))))))))))))))))))) (chi-macro145 (lambda (p472 e473 r474 w475 rib476 mod477) (letrec ((rebuild-macro-output478 (lambda (x479 m480) (cond ((pair? x479) (cons (rebuild-macro-output478 (car x479) m480) (rebuild-macro-output478 (cdr x479) m480))) ((syntax-object?90 x479) (let ((w481 (syntax-object-wrap92 x479))) (let ((ms482 (wrap-marks109 w481)) (s483 (wrap-subst110 w481))) (if (and (pair? ms482) (eq? (car ms482) #f)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cdr ms482) (if rib476 (cons rib476 (cdr s483)) (cdr s483))) (syntax-object-module93 x479)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cons m480 ms482) (if rib476 (cons rib476 (cons (quote shift) s483)) (cons (quote shift) s483))) (let ((pmod484 (procedure-module p472))) (if pmod484 (cons (quote hygiene) (module-name pmod484)) (quote (hygiene guile))))))))) ((vector? x479) (let ((n485 (vector-length x479))) (let ((v486 (make-vector n485))) (let doloop487 ((i488 0)) (if (fx=73 i488 n485) v486 (begin (vector-set! v486 i488 (rebuild-macro-output478 (vector-ref x479 i488) m480)) (doloop487 (fx+71 i488 1)))))))) ((symbol? x479) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap135 e473 w475 s mod477) x479)) (else x479))))) (rebuild-macro-output478 (p472 (wrap134 e473 (anti-mark121 w475) mod477)) (string #\m))))) (chi-application144 (lambda (x489 e490 r491 w492 s493 mod494) ((lambda (tmp495) ((lambda (tmp496) (if tmp496 (apply (lambda (e0497 e1498) (build-annotated79 s493 (cons x489 (map (lambda (e499) (chi142 e499 r491 w492 mod494)) e1498)))) tmp496) (syntax-violation #f "source expression failed to match any pattern" tmp495))) ($sc-dispatch tmp495 (quote (any . each-any))))) e490))) (chi-expr143 (lambda (type501 value502 e503 r504 w505 s506 mod507) (let ((t508 type501)) (if (memv t508 (quote (lexical))) (build-lexical-reference80 (quote value) s506 e503 value502) (if (memv t508 (quote (core external-macro))) (value502 e503 r504 w505 s506 mod507) (if (memv t508 (quote (module-ref))) (call-with-values (lambda () (value502 e503)) (lambda (id509 mod510) (build-global-reference82 s506 id509 mod510))) (if (memv t508 (quote (lexical-call))) (chi-application144 (build-lexical-reference80 (quote fun) (source-annotation97 (car e503)) (car e503) value502) e503 r504 w505 s506 mod507) (if (memv t508 (quote (global-call))) (chi-application144 (build-global-reference82 (source-annotation97 (car e503)) value502 (if (syntax-object?90 (car e503)) (syntax-object-module93 (car e503)) mod507)) e503 r504 w505 s506 mod507) (if (memv t508 (quote (constant))) (build-data84 s506 (strip153 (source-wrap135 e503 w505 s506 mod507) (quote (())))) (if (memv t508 (quote (global))) (build-global-reference82 s506 value502 mod507) (if (memv t508 (quote (call))) (chi-application144 (chi142 (car e503) r504 w505 mod507) e503 r504 w505 s506 mod507) (if (memv t508 (quote (begin-form))) ((lambda (tmp511) ((lambda (tmp512) (if tmp512 (apply (lambda (_513 e1514 e2515) (chi-sequence136 (cons e1514 e2515) r504 w505 s506 mod507)) tmp512) (syntax-violation #f "source expression failed to match any pattern" tmp511))) ($sc-dispatch tmp511 (quote (any any . each-any))))) e503) (if (memv t508 (quote (local-syntax-form))) (chi-local-syntax148 value502 e503 r504 w505 s506 mod507 chi-sequence136) (if (memv t508 (quote (eval-when-form))) ((lambda (tmp517) ((lambda (tmp518) (if tmp518 (apply (lambda (_519 x520 e1521 e2522) (let ((when-list523 (chi-when-list139 e503 x520 w505))) (if (memq (quote eval) when-list523) (chi-sequence136 (cons e1521 e2522) r504 w505 s506 mod507) (chi-void150)))) tmp518) (syntax-violation #f "source expression failed to match any pattern" tmp517))) ($sc-dispatch tmp517 (quote (any each-any any . each-any))))) e503) (if (memv t508 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e503 (wrap134 value502 w505 mod507)) (if (memv t508 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap135 e503 w505 s506 mod507)) (if (memv t508 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap135 e503 w505 s506 mod507)) (syntax-violation #f "unexpected syntax" (source-wrap135 e503 w505 s506 mod507))))))))))))))))))) (chi142 (lambda (e526 r527 w528 mod529) (call-with-values (lambda () (syntax-type140 e526 r527 w528 #f #f mod529)) (lambda (type530 value531 e532 w533 s534 mod535) (chi-expr143 type530 value531 e532 r527 w533 s534 mod535))))) (chi-top141 (lambda (e536 r537 w538 m539 esew540 mod541) (call-with-values (lambda () (syntax-type140 e536 r537 w538 #f #f mod541)) (lambda (type549 value550 e551 w552 s553 mod554) (let ((t555 type549)) (if (memv t555 (quote (begin-form))) ((lambda (tmp556) ((lambda (tmp557) (if tmp557 (apply (lambda (_558) (chi-void150)) tmp557) ((lambda (tmp559) (if tmp559 (apply (lambda (_560 e1561 e2562) (chi-top-sequence137 (cons e1561 e2562) r537 w552 s553 m539 esew540 mod554)) tmp559) (syntax-violation #f "source expression failed to match any pattern" tmp556))) ($sc-dispatch tmp556 (quote (any any . each-any)))))) ($sc-dispatch tmp556 (quote (any))))) e551) (if (memv t555 (quote (local-syntax-form))) (chi-local-syntax148 value550 e551 r537 w552 s553 mod554 (lambda (body564 r565 w566 s567 mod568) (chi-top-sequence137 body564 r565 w566 s567 m539 esew540 mod568))) (if (memv t555 (quote (eval-when-form))) ((lambda (tmp569) ((lambda (tmp570) (if tmp570 (apply (lambda (_571 x572 e1573 e2574) (let ((when-list575 (chi-when-list139 e551 x572 w552)) (body576 (cons e1573 e2574))) (cond ((eq? m539 (quote e)) (if (memq (quote eval) when-list575) (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) (chi-void150))) ((memq (quote load) when-list575) (if (or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (chi-top-sequence137 body576 r537 w552 s553 (quote c&e) (quote (compile load)) mod554) (if (memq m539 (quote (c c&e))) (chi-top-sequence137 body576 r537 w552 s553 (quote c) (quote (load)) mod554) (chi-void150)))) ((or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (top-level-eval-hook75 (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) mod554) (chi-void150)) (else (chi-void150))))) tmp570) (syntax-violation #f "source expression failed to match any pattern" tmp569))) ($sc-dispatch tmp569 (quote (any each-any any . each-any))))) e551) (if (memv t555 (quote (define-syntax-form))) (let ((n579 (id-var-name128 value550 w552)) (r580 (macros-only-env102 r537))) (let ((t581 m539)) (if (memv t581 (quote (c))) (if (memq (quote compile) esew540) (let ((e582 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e582 mod554) (if (memq (quote load) esew540) e582 (chi-void150)))) (if (memq (quote load) esew540) (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) (chi-void150))) (if (memv t581 (quote (c&e))) (let ((e583 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e583 mod554) e583)) (begin (if (memq (quote eval) esew540) (top-level-eval-hook75 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) mod554)) (chi-void150)))))) (if (memv t555 (quote (define-form))) (let ((n584 (id-var-name128 value550 w552))) (let ((type585 (binding-type98 (lookup103 n584 r537 mod554)))) (let ((t586 type585)) (if (memv t586 (quote (global core macro module-ref))) (let ((x587 (build-annotated79 s553 (list (quote define) n584 (chi142 e551 r537 w552 mod554))))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x587 mod554)) x587)) (if (memv t586 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e551 (wrap134 value550 w552 mod554)) (syntax-violation #f "cannot define keyword at top level" e551 (wrap134 value550 w552 mod554))))))) (let ((x588 (chi-expr143 type549 value550 e551 r537 w552 s553 mod554))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x588 mod554)) x588)))))))))))) (syntax-type140 (lambda (e589 r590 w591 s592 rib593 mod594) (cond ((symbol? e589) (let ((n595 (id-var-name128 e589 w591))) (let ((b596 (lookup103 n595 r590 mod594))) (let ((type597 (binding-type98 b596))) (let ((t598 type597)) (if (memv t598 (quote (lexical))) (values type597 (binding-value99 b596) e589 w591 s592 mod594) (if (memv t598 (quote (global))) (values type597 n595 e589 w591 s592 mod594) (if (memv t598 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b596) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (values type597 (binding-value99 b596) e589 w591 s592 mod594))))))))) ((pair? e589) (let ((first599 (car e589))) (if (id?106 first599) (let ((n600 (id-var-name128 first599 w591))) (let ((b601 (lookup103 n600 r590 (or (and (syntax-object?90 first599) (syntax-object-module93 first599)) mod594)))) (let ((type602 (binding-type98 b601))) (let ((t603 type602)) (if (memv t603 (quote (lexical))) (values (quote lexical-call) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (global))) (values (quote global-call) n600 e589 w591 s592 mod594) (if (memv t603 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b601) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (if (memv t603 (quote (core external-macro module-ref))) (values type602 (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (begin))) (values (quote begin-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (eval-when))) (values (quote eval-when-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (define))) ((lambda (tmp604) ((lambda (tmp605) (if (if tmp605 (apply (lambda (_606 name607 val608) (id?106 name607)) tmp605) #f) (apply (lambda (_609 name610 val611) (values (quote define-form) name610 val611 w591 s592 mod594)) tmp605) ((lambda (tmp612) (if (if tmp612 (apply (lambda (_613 name614 args615 e1616 e2617) (and (id?106 name614) (valid-bound-ids?131 (lambda-var-list155 args615)))) tmp612) #f) (apply (lambda (_618 name619 args620 e1621 e2622) (values (quote define-form) (wrap134 name619 w591 mod594) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap134 (cons args620 (cons e1621 e2622)) w591 mod594)) (quote (())) s592 mod594)) tmp612) ((lambda (tmp624) (if (if tmp624 (apply (lambda (_625 name626) (id?106 name626)) tmp624) #f) (apply (lambda (_627 name628) (values (quote define-form) (wrap134 name628 w591 mod594) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s592 mod594)) tmp624) (syntax-violation #f "source expression failed to match any pattern" tmp604))) ($sc-dispatch tmp604 (quote (any any)))))) ($sc-dispatch tmp604 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp604 (quote (any any any))))) e589) (if (memv t603 (quote (define-syntax))) ((lambda (tmp629) ((lambda (tmp630) (if (if tmp630 (apply (lambda (_631 name632 val633) (id?106 name632)) tmp630) #f) (apply (lambda (_634 name635 val636) (values (quote define-syntax-form) name635 val636 w591 s592 mod594)) tmp630) (syntax-violation #f "source expression failed to match any pattern" tmp629))) ($sc-dispatch tmp629 (quote (any any any))))) e589) (values (quote call) #f e589 w591 s592 mod594)))))))))))))) (values (quote call) #f e589 w591 s592 mod594)))) ((syntax-object?90 e589) (syntax-type140 (syntax-object-expression91 e589) r590 (join-wraps125 w591 (syntax-object-wrap92 e589)) #f rib593 (or (syntax-object-module93 e589) mod594))) ((annotation? e589) (syntax-type140 (annotation-expression e589) r590 w591 (annotation-source e589) rib593 mod594)) ((self-evaluating? e589) (values (quote constant) #f e589 w591 s592 mod594)) (else (values (quote other) #f e589 w591 s592 mod594))))) (chi-when-list139 (lambda (e637 when-list638 w639) (let f640 ((when-list641 when-list638) (situations642 (quote ()))) (if (null? when-list641) situations642 (f640 (cdr when-list641) (cons (let ((x643 (car when-list641))) (cond ((free-id=?129 x643 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?129 x643 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?129 x643 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e637 (wrap134 x643 w639 #f))))) situations642)))))) (chi-install-global138 (lambda (name644 e645) (build-annotated79 #f (list (quote define) name644 (if (let ((v646 (module-variable (current-module) name644))) (and v646 (variable-bound? v646) (macro? (variable-ref v646)) (not (eq? (macro-type (variable-ref v646)) (quote syncase-macro))))) (build-annotated79 #f (list (build-annotated79 #f (quote make-extended-syncase-macro)) (build-annotated79 #f (list (build-annotated79 #f (quote module-ref)) (build-annotated79 #f (quote (current-module))) (build-data84 #f name644))) (build-data84 #f (quote macro)) e645)) (build-annotated79 #f (list (build-annotated79 #f (quote make-syncase-macro)) (build-data84 #f (quote macro)) e645))))))) (chi-top-sequence137 (lambda (body647 r648 w649 s650 m651 esew652 mod653) (build-sequence85 s650 (let dobody654 ((body655 body647) (r656 r648) (w657 w649) (m658 m651) (esew659 esew652) (mod660 mod653)) (if (null? body655) (quote ()) (let ((first661 (chi-top141 (car body655) r656 w657 m658 esew659 mod660))) (cons first661 (dobody654 (cdr body655) r656 w657 m658 esew659 mod660)))))))) (chi-sequence136 (lambda (body662 r663 w664 s665 mod666) (build-sequence85 s665 (let dobody667 ((body668 body662) (r669 r663) (w670 w664) (mod671 mod666)) (if (null? body668) (quote ()) (let ((first672 (chi142 (car body668) r669 w670 mod671))) (cons first672 (dobody667 (cdr body668) r669 w670 mod671)))))))) (source-wrap135 (lambda (x673 w674 s675 defmod676) (wrap134 (if s675 (make-annotation x673 s675 #f) x673) w674 defmod676))) (wrap134 (lambda (x677 w678 defmod679) (cond ((and (null? (wrap-marks109 w678)) (null? (wrap-subst110 w678))) x677) ((syntax-object?90 x677) (make-syntax-object89 (syntax-object-expression91 x677) (join-wraps125 w678 (syntax-object-wrap92 x677)) (syntax-object-module93 x677))) ((null? x677) x677) (else (make-syntax-object89 x677 w678 defmod679))))) (bound-id-member?133 (lambda (x680 list681) (and (not (null? list681)) (or (bound-id=?130 x680 (car list681)) (bound-id-member?133 x680 (cdr list681)))))) (distinct-bound-ids?132 (lambda (ids682) (let distinct?683 ((ids684 ids682)) (or (null? ids684) (and (not (bound-id-member?133 (car ids684) (cdr ids684))) (distinct?683 (cdr ids684))))))) (valid-bound-ids?131 (lambda (ids685) (and (let all-ids?686 ((ids687 ids685)) (or (null? ids687) (and (id?106 (car ids687)) (all-ids?686 (cdr ids687))))) (distinct-bound-ids?132 ids685)))) (bound-id=?130 (lambda (i688 j689) (if (and (syntax-object?90 i688) (syntax-object?90 j689)) (and (eq? (let ((e690 (syntax-object-expression91 i688))) (if (annotation? e690) (annotation-expression e690) e690)) (let ((e691 (syntax-object-expression91 j689))) (if (annotation? e691) (annotation-expression e691) e691))) (same-marks?127 (wrap-marks109 (syntax-object-wrap92 i688)) (wrap-marks109 (syntax-object-wrap92 j689)))) (eq? (let ((e692 i688)) (if (annotation? e692) (annotation-expression e692) e692)) (let ((e693 j689)) (if (annotation? e693) (annotation-expression e693) e693)))))) (free-id=?129 (lambda (i694 j695) (and (eq? (let ((x696 i694)) (let ((e697 (if (syntax-object?90 x696) (syntax-object-expression91 x696) x696))) (if (annotation? e697) (annotation-expression e697) e697))) (let ((x698 j695)) (let ((e699 (if (syntax-object?90 x698) (syntax-object-expression91 x698) x698))) (if (annotation? e699) (annotation-expression e699) e699)))) (eq? (id-var-name128 i694 (quote (()))) (id-var-name128 j695 (quote (()))))))) (id-var-name128 (lambda (id700 w701) (letrec ((search-vector-rib704 (lambda (sym710 subst711 marks712 symnames713 ribcage714) (let ((n715 (vector-length symnames713))) (let f716 ((i717 0)) (cond ((fx=73 i717 n715) (search702 sym710 (cdr subst711) marks712)) ((and (eq? (vector-ref symnames713 i717) sym710) (same-marks?127 marks712 (vector-ref (ribcage-marks116 ribcage714) i717))) (values (vector-ref (ribcage-labels117 ribcage714) i717) marks712)) (else (f716 (fx+71 i717 1)))))))) (search-list-rib703 (lambda (sym718 subst719 marks720 symnames721 ribcage722) (let f723 ((symnames724 symnames721) (i725 0)) (cond ((null? symnames724) (search702 sym718 (cdr subst719) marks720)) ((and (eq? (car symnames724) sym718) (same-marks?127 marks720 (list-ref (ribcage-marks116 ribcage722) i725))) (values (list-ref (ribcage-labels117 ribcage722) i725) marks720)) (else (f723 (cdr symnames724) (fx+71 i725 1))))))) (search702 (lambda (sym726 subst727 marks728) (if (null? subst727) (values #f marks728) (let ((fst729 (car subst727))) (if (eq? fst729 (quote shift)) (search702 sym726 (cdr subst727) (cdr marks728)) (let ((symnames730 (ribcage-symnames115 fst729))) (if (vector? symnames730) (search-vector-rib704 sym726 subst727 marks728 symnames730 fst729) (search-list-rib703 sym726 subst727 marks728 symnames730 fst729))))))))) (cond ((symbol? id700) (or (call-with-values (lambda () (search702 id700 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x732 . ignore731) x732)) id700)) ((syntax-object?90 id700) (let ((id733 (let ((e735 (syntax-object-expression91 id700))) (if (annotation? e735) (annotation-expression e735) e735))) (w1734 (syntax-object-wrap92 id700))) (let ((marks736 (join-marks126 (wrap-marks109 w701) (wrap-marks109 w1734)))) (call-with-values (lambda () (search702 id733 (wrap-subst110 w701) marks736)) (lambda (new-id737 marks738) (or new-id737 (call-with-values (lambda () (search702 id733 (wrap-subst110 w1734) marks738)) (lambda (x740 . ignore739) x740)) id733)))))) ((annotation? id700) (let ((id741 (let ((e742 id700)) (if (annotation? e742) (annotation-expression e742) e742)))) (or (call-with-values (lambda () (search702 id741 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x744 . ignore743) x744)) id741))) (else (syntax-violation (quote id-var-name) "invalid id" id700)))))) (same-marks?127 (lambda (x745 y746) (or (eq? x745 y746) (and (not (null? x745)) (not (null? y746)) (eq? (car x745) (car y746)) (same-marks?127 (cdr x745) (cdr y746)))))) (join-marks126 (lambda (m1747 m2748) (smart-append124 m1747 m2748))) (join-wraps125 (lambda (w1749 w2750) (let ((m1751 (wrap-marks109 w1749)) (s1752 (wrap-subst110 w1749))) (if (null? m1751) (if (null? s1752) w2750 (make-wrap108 (wrap-marks109 w2750) (smart-append124 s1752 (wrap-subst110 w2750)))) (make-wrap108 (smart-append124 m1751 (wrap-marks109 w2750)) (smart-append124 s1752 (wrap-subst110 w2750))))))) (smart-append124 (lambda (m1753 m2754) (if (null? m2754) m1753 (append m1753 m2754)))) (make-binding-wrap123 (lambda (ids755 labels756 w757) (if (null? ids755) w757 (make-wrap108 (wrap-marks109 w757) (cons (let ((labelvec758 (list->vector labels756))) (let ((n759 (vector-length labelvec758))) (let ((symnamevec760 (make-vector n759)) (marksvec761 (make-vector n759))) (begin (let f762 ((ids763 ids755) (i764 0)) (if (not (null? ids763)) (call-with-values (lambda () (id-sym-name&marks107 (car ids763) w757)) (lambda (symname765 marks766) (begin (vector-set! symnamevec760 i764 symname765) (vector-set! marksvec761 i764 marks766) (f762 (cdr ids763) (fx+71 i764 1))))))) (make-ribcage113 symnamevec760 marksvec761 labelvec758))))) (wrap-subst110 w757)))))) (extend-ribcage!122 (lambda (ribcage767 id768 label769) (begin (set-ribcage-symnames!118 ribcage767 (cons (let ((e770 (syntax-object-expression91 id768))) (if (annotation? e770) (annotation-expression e770) e770)) (ribcage-symnames115 ribcage767))) (set-ribcage-marks!119 ribcage767 (cons (wrap-marks109 (syntax-object-wrap92 id768)) (ribcage-marks116 ribcage767))) (set-ribcage-labels!120 ribcage767 (cons label769 (ribcage-labels117 ribcage767)))))) (anti-mark121 (lambda (w771) (make-wrap108 (cons #f (wrap-marks109 w771)) (cons (quote shift) (wrap-subst110 w771))))) (set-ribcage-labels!120 (lambda (x772 update773) (vector-set! x772 3 update773))) (set-ribcage-marks!119 (lambda (x774 update775) (vector-set! x774 2 update775))) (set-ribcage-symnames!118 (lambda (x776 update777) (vector-set! x776 1 update777))) (ribcage-labels117 (lambda (x778) (vector-ref x778 3))) (ribcage-marks116 (lambda (x779) (vector-ref x779 2))) (ribcage-symnames115 (lambda (x780) (vector-ref x780 1))) (ribcage?114 (lambda (x781) (and (vector? x781) (= (vector-length x781) 4) (eq? (vector-ref x781 0) (quote ribcage))))) (make-ribcage113 (lambda (symnames782 marks783 labels784) (vector (quote ribcage) symnames782 marks783 labels784))) (gen-labels112 (lambda (ls785) (if (null? ls785) (quote ()) (cons (gen-label111) (gen-labels112 (cdr ls785)))))) (gen-label111 (lambda () (string #\i))) (wrap-subst110 cdr) (wrap-marks109 car) (make-wrap108 cons) (id-sym-name&marks107 (lambda (x786 w787) (if (syntax-object?90 x786) (values (let ((e788 (syntax-object-expression91 x786))) (if (annotation? e788) (annotation-expression e788) e788)) (join-marks126 (wrap-marks109 w787) (wrap-marks109 (syntax-object-wrap92 x786)))) (values (let ((e789 x786)) (if (annotation? e789) (annotation-expression e789) e789)) (wrap-marks109 w787))))) (id?106 (lambda (x790) (cond ((symbol? x790) #t) ((syntax-object?90 x790) (symbol? (let ((e791 (syntax-object-expression91 x790))) (if (annotation? e791) (annotation-expression e791) e791)))) ((annotation? x790) (symbol? (annotation-expression x790))) (else #f)))) (nonsymbol-id?105 (lambda (x792) (and (syntax-object?90 x792) (symbol? (let ((e793 (syntax-object-expression91 x792))) (if (annotation? e793) (annotation-expression e793) e793)))))) (global-extend104 (lambda (type794 sym795 val796) (put-global-definition-hook77 sym795 type794 val796))) (lookup103 (lambda (x797 r798 mod799) (cond ((assq x797 r798) => cdr) ((symbol? x797) (or (get-global-definition-hook78 x797 mod799) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env102 (lambda (r800) (if (null? r800) (quote ()) (let ((a801 (car r800))) (if (eq? (cadr a801) (quote macro)) (cons a801 (macros-only-env102 (cdr r800))) (macros-only-env102 (cdr r800))))))) (extend-var-env101 (lambda (labels802 vars803 r804) (if (null? labels802) r804 (extend-var-env101 (cdr labels802) (cdr vars803) (cons (cons (car labels802) (cons (quote lexical) (car vars803))) r804))))) (extend-env100 (lambda (labels805 bindings806 r807) (if (null? labels805) r807 (extend-env100 (cdr labels805) (cdr bindings806) (cons (cons (car labels805) (car bindings806)) r807))))) (binding-value99 cdr) (binding-type98 car) (source-annotation97 (lambda (x808) (cond ((annotation? x808) (annotation-source x808)) ((syntax-object?90 x808) (source-annotation97 (syntax-object-expression91 x808))) (else #f)))) (set-syntax-object-module!96 (lambda (x809 update810) (vector-set! x809 3 update810))) (set-syntax-object-wrap!95 (lambda (x811 update812) (vector-set! x811 2 update812))) (set-syntax-object-expression!94 (lambda (x813 update814) (vector-set! x813 1 update814))) (syntax-object-module93 (lambda (x815) (vector-ref x815 3))) (syntax-object-wrap92 (lambda (x816) (vector-ref x816 2))) (syntax-object-expression91 (lambda (x817) (vector-ref x817 1))) (syntax-object?90 (lambda (x818) (and (vector? x818) (= (vector-length x818) 4) (eq? (vector-ref x818 0) (quote syntax-object))))) (make-syntax-object89 (lambda (expression819 wrap820 module821) (vector (quote syntax-object) expression819 wrap820 module821))) (build-letrec88 (lambda (src822 vars823 val-exps824 body-exp825) (if (null? vars823) (build-annotated79 src822 body-exp825) (build-annotated79 src822 (list (quote letrec) (map list vars823 val-exps824) body-exp825))))) (build-named-let87 (lambda (src826 vars827 val-exps828 body-exp829) (if (null? vars827) (build-annotated79 src826 body-exp829) (build-annotated79 src826 (list (quote let) (car vars827) (map list (cdr vars827) val-exps828) body-exp829))))) (build-let86 (lambda (src830 vars831 val-exps832 body-exp833) (if (null? vars831) (build-annotated79 src830 body-exp833) (build-annotated79 src830 (list (quote let) (map list vars831 val-exps832) body-exp833))))) (build-sequence85 (lambda (src834 exps835) (if (null? (cdr exps835)) (build-annotated79 src834 (car exps835)) (build-annotated79 src834 (cons (quote begin) exps835))))) (build-data84 (lambda (src836 exp837) (if (and (self-evaluating? exp837) (not (vector? exp837))) (build-annotated79 src836 exp837) (build-annotated79 src836 (list (quote quote) exp837))))) (build-global-assignment83 (lambda (source838 var839 exp840 mod841) (let ((ref842 (build-global-reference82 source838 var839 mod841))) (build-annotated79 source838 (list (quote set!) ref842 exp840))))) (build-global-reference82 (lambda (source843 var844 mod845) (build-annotated79 source843 (if (not mod845) var844 (let ((make-module-ref846 (let ((t849 (fluid-ref *mode*70))) (if (memv t849 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (s mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851))))) (kind847 (car mod845)) (mod848 (cdr mod845))) (let ((t853 kind847)) (if (memv t853 (quote (public))) (make-module-ref846 #f mod848 var844 #t) (if (memv t853 (quote (private))) (if (not (equal? mod848 (module-name (current-module)))) (make-module-ref846 #f mod848 var844 #f) var844) (if (memv t853 (quote (bare))) var844 (if (memv t853 (quote (hygiene))) (if (and (not (equal? mod848 (module-name (current-module)))) (module-variable (resolve-module mod848) var844)) (make-module-ref846 #f mod848 var844 #f) var844) (syntax-violation #f "bad module kind" var844 mod848))))))))))) (build-lexical-assignment81 (lambda (source854 name855 var856 exp857) (build-annotated79 source854 (list (quote set!) (build-lexical-reference80 (quote set) #f name855 var856) exp857)))) (build-lexical-reference80 (lambda (type858 source859 name860 var861) (build-annotated79 source859 (let ((t862 (fluid-ref *mode*70))) (if (memv t862 (quote (c))) ((@ (ice-9 expand-support) make-lexical) #f name860 var861) var861))))) (build-annotated79 (lambda (src863 exp864) (if (and src863 (not (annotation? exp864))) (make-annotation exp864 src863 #t) exp864))) (get-global-definition-hook78 (lambda (symbol865 module866) (begin (if (and (not module866) (current-module)) (warn "module system is booted, we should have a module" symbol865)) (let ((v867 (module-variable (if module866 (resolve-module (cdr module866)) (current-module)) symbol865))) (and v867 (variable-bound? v867) (let ((val868 (variable-ref v867))) (and (macro? val868) (syncase-macro-type val868) (cons (syncase-macro-type val868) (syncase-macro-binding val868))))))))) (put-global-definition-hook77 (lambda (symbol869 type870 val871) (let ((existing872 (let ((v873 (module-variable (current-module) symbol869))) (and v873 (variable-bound? v873) (let ((val874 (variable-ref v873))) (and (macro? val874) (not (syncase-macro-type val874)) val874)))))) (module-define! (current-module) symbol869 (if existing872 (make-extended-syncase-macro existing872 type870 val871) (make-syncase-macro type870 val871)))))) (local-eval-hook76 (lambda (x875 mod876) (primitive-eval (list noexpand69 (let ((t877 (fluid-ref *mode*70))) (if (memv t877 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x875) x875)))))) (top-level-eval-hook75 (lambda (x878 mod879) (primitive-eval (list noexpand69 (let ((t880 (fluid-ref *mode*70))) (if (memv t880 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x878) x878)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend104 (quote local-syntax) (quote letrec-syntax) #t) (global-extend104 (quote local-syntax) (quote let-syntax) #f) (global-extend104 (quote core) (quote fluid-let-syntax) (lambda (e881 r882 w883 s884 mod885) ((lambda (tmp886) ((lambda (tmp887) (if (if tmp887 (apply (lambda (_888 var889 val890 e1891 e2892) (valid-bound-ids?131 var889)) tmp887) #f) (apply (lambda (_894 var895 val896 e1897 e2898) (let ((names899 (map (lambda (x900) (id-var-name128 x900 w883)) var895))) (begin (for-each (lambda (id902 n903) (let ((t904 (binding-type98 (lookup103 n903 r882 mod885)))) (if (memv t904 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e881 (source-wrap135 id902 w883 s884 mod885))))) var895 names899) (chi-body146 (cons e1897 e2898) (source-wrap135 e881 w883 s884 mod885) (extend-env100 names899 (let ((trans-r907 (macros-only-env102 r882))) (map (lambda (x908) (cons (quote macro) (eval-local-transformer149 (chi142 x908 trans-r907 w883 mod885) mod885))) val896)) r882) w883 mod885)))) tmp887) ((lambda (_910) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap135 e881 w883 s884 mod885))) tmp886))) ($sc-dispatch tmp886 (quote (any #(each (any any)) any . each-any))))) e881))) (global-extend104 (quote core) (quote quote) (lambda (e911 r912 w913 s914 mod915) ((lambda (tmp916) ((lambda (tmp917) (if tmp917 (apply (lambda (_918 e919) (build-data84 s914 (strip153 e919 w913))) tmp917) ((lambda (_920) (syntax-violation (quote quote) "bad syntax" (source-wrap135 e911 w913 s914 mod915))) tmp916))) ($sc-dispatch tmp916 (quote (any any))))) e911))) (global-extend104 (quote core) (quote syntax) (letrec ((regen928 (lambda (x929) (let ((t930 (car x929))) (if (memv t930 (quote (ref))) (build-lexical-reference80 (quote value) #f (cadr x929) (cadr x929)) (if (memv t930 (quote (primitive))) (build-annotated79 #f (cadr x929)) (if (memv t930 (quote (quote))) (build-data84 #f (cadr x929)) (if (memv t930 (quote (lambda))) (build-annotated79 #f (list (quote lambda) (cadr x929) (regen928 (caddr x929)))) (if (memv t930 (quote (map))) (let ((ls931 (map regen928 (cdr x929)))) (build-annotated79 #f (cons (if (fx=73 (length ls931) 2) (build-annotated79 #f (quote map)) (build-annotated79 #f (quote map))) ls931))) (build-annotated79 #f (cons (build-annotated79 #f (car x929)) (map regen928 (cdr x929)))))))))))) (gen-vector927 (lambda (x932) (cond ((eq? (car x932) (quote list)) (cons (quote vector) (cdr x932))) ((eq? (car x932) (quote quote)) (list (quote quote) (list->vector (cadr x932)))) (else (list (quote list->vector) x932))))) (gen-append926 (lambda (x933 y934) (if (equal? y934 (quote (quote ()))) x933 (list (quote append) x933 y934)))) (gen-cons925 (lambda (x935 y936) (let ((t937 (car y936))) (if (memv t937 (quote (quote))) (if (eq? (car x935) (quote quote)) (list (quote quote) (cons (cadr x935) (cadr y936))) (if (eq? (cadr y936) (quote ())) (list (quote list) x935) (list (quote cons) x935 y936))) (if (memv t937 (quote (list))) (cons (quote list) (cons x935 (cdr y936))) (list (quote cons) x935 y936)))))) (gen-map924 (lambda (e938 map-env939) (let ((formals940 (map cdr map-env939)) (actuals941 (map (lambda (x942) (list (quote ref) (car x942))) map-env939))) (cond ((eq? (car e938) (quote ref)) (car actuals941)) ((and-map (lambda (x943) (and (eq? (car x943) (quote ref)) (memq (cadr x943) formals940))) (cdr e938)) (cons (quote map) (cons (list (quote primitive) (car e938)) (map (let ((r944 (map cons formals940 actuals941))) (lambda (x945) (cdr (assq (cadr x945) r944)))) (cdr e938))))) (else (cons (quote map) (cons (list (quote lambda) formals940 e938) actuals941))))))) (gen-mappend923 (lambda (e946 map-env947) (list (quote apply) (quote (primitive append)) (gen-map924 e946 map-env947)))) (gen-ref922 (lambda (src948 var949 level950 maps951) (if (fx=73 level950 0) (values var949 maps951) (if (null? maps951) (syntax-violation (quote syntax) "missing ellipsis" src948) (call-with-values (lambda () (gen-ref922 src948 var949 (fx-72 level950 1) (cdr maps951))) (lambda (outer-var952 outer-maps953) (let ((b954 (assq outer-var952 (car maps951)))) (if b954 (values (cdr b954) maps951) (let ((inner-var955 (gen-var154 (quote tmp)))) (values inner-var955 (cons (cons (cons outer-var952 inner-var955) (car maps951)) outer-maps953))))))))))) (gen-syntax921 (lambda (src956 e957 r958 maps959 ellipsis?960 mod961) (if (id?106 e957) (let ((label962 (id-var-name128 e957 (quote (()))))) (let ((b963 (lookup103 label962 r958 mod961))) (if (eq? (binding-type98 b963) (quote syntax)) (call-with-values (lambda () (let ((var.lev964 (binding-value99 b963))) (gen-ref922 src956 (car var.lev964) (cdr var.lev964) maps959))) (lambda (var965 maps966) (values (list (quote ref) var965) maps966))) (if (ellipsis?960 e957) (syntax-violation (quote syntax) "misplaced ellipsis" src956) (values (list (quote quote) e957) maps959))))) ((lambda (tmp967) ((lambda (tmp968) (if (if tmp968 (apply (lambda (dots969 e970) (ellipsis?960 dots969)) tmp968) #f) (apply (lambda (dots971 e972) (gen-syntax921 src956 e972 r958 maps959 (lambda (x973) #f) mod961)) tmp968) ((lambda (tmp974) (if (if tmp974 (apply (lambda (x975 dots976 y977) (ellipsis?960 dots976)) tmp974) #f) (apply (lambda (x978 dots979 y980) (let f981 ((y982 y980) (k983 (lambda (maps984) (call-with-values (lambda () (gen-syntax921 src956 x978 r958 (cons (quote ()) maps984) ellipsis?960 mod961)) (lambda (x985 maps986) (if (null? (car maps986)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-map924 x985 (car maps986)) (cdr maps986)))))))) ((lambda (tmp987) ((lambda (tmp988) (if (if tmp988 (apply (lambda (dots989 y990) (ellipsis?960 dots989)) tmp988) #f) (apply (lambda (dots991 y992) (f981 y992 (lambda (maps993) (call-with-values (lambda () (k983 (cons (quote ()) maps993))) (lambda (x994 maps995) (if (null? (car maps995)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-mappend923 x994 (car maps995)) (cdr maps995)))))))) tmp988) ((lambda (_996) (call-with-values (lambda () (gen-syntax921 src956 y982 r958 maps959 ellipsis?960 mod961)) (lambda (y997 maps998) (call-with-values (lambda () (k983 maps998)) (lambda (x999 maps1000) (values (gen-append926 x999 y997) maps1000)))))) tmp987))) ($sc-dispatch tmp987 (quote (any . any))))) y982))) tmp974) ((lambda (tmp1001) (if tmp1001 (apply (lambda (x1002 y1003) (call-with-values (lambda () (gen-syntax921 src956 x1002 r958 maps959 ellipsis?960 mod961)) (lambda (x1004 maps1005) (call-with-values (lambda () (gen-syntax921 src956 y1003 r958 maps1005 ellipsis?960 mod961)) (lambda (y1006 maps1007) (values (gen-cons925 x1004 y1006) maps1007)))))) tmp1001) ((lambda (tmp1008) (if tmp1008 (apply (lambda (e11009 e21010) (call-with-values (lambda () (gen-syntax921 src956 (cons e11009 e21010) r958 maps959 ellipsis?960 mod961)) (lambda (e1012 maps1013) (values (gen-vector927 e1012) maps1013)))) tmp1008) ((lambda (_1014) (values (list (quote quote) e957) maps959)) tmp967))) ($sc-dispatch tmp967 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp967 (quote (any . any)))))) ($sc-dispatch tmp967 (quote (any any . any)))))) ($sc-dispatch tmp967 (quote (any any))))) e957))))) (lambda (e1015 r1016 w1017 s1018 mod1019) (let ((e1020 (source-wrap135 e1015 w1017 s1018 mod1019))) ((lambda (tmp1021) ((lambda (tmp1022) (if tmp1022 (apply (lambda (_1023 x1024) (call-with-values (lambda () (gen-syntax921 e1020 x1024 r1016 (quote ()) ellipsis?151 mod1019)) (lambda (e1025 maps1026) (regen928 e1025)))) tmp1022) ((lambda (_1027) (syntax-violation (quote syntax) "bad `syntax' form" e1020)) tmp1021))) ($sc-dispatch tmp1021 (quote (any any))))) e1020))))) (global-extend104 (quote core) (quote lambda) (lambda (e1028 r1029 w1030 s1031 mod1032) ((lambda (tmp1033) ((lambda (tmp1034) (if tmp1034 (apply (lambda (_1035 c1036) (chi-lambda-clause147 (source-wrap135 e1028 w1030 s1031 mod1032) #f c1036 r1029 w1030 mod1032 (lambda (vars1037 docstring1038 body1039) (build-annotated79 s1031 (cons (quote lambda) (cons vars1037 (append (if docstring1038 (list docstring1038) (quote ())) (list body1039)))))))) tmp1034) (syntax-violation #f "source expression failed to match any pattern" tmp1033))) ($sc-dispatch tmp1033 (quote (any . any))))) e1028))) (global-extend104 (quote core) (quote let) (letrec ((chi-let1040 (lambda (e1041 r1042 w1043 s1044 mod1045 constructor1046 ids1047 vals1048 exps1049) (if (not (valid-bound-ids?131 ids1047)) (syntax-violation (quote let) "duplicate bound variable" e1041) (let ((labels1050 (gen-labels112 ids1047)) (new-vars1051 (map gen-var154 ids1047))) (let ((nw1052 (make-binding-wrap123 ids1047 labels1050 w1043)) (nr1053 (extend-var-env101 labels1050 new-vars1051 r1042))) (constructor1046 s1044 new-vars1051 (map (lambda (x1054) (chi142 x1054 r1042 w1043 mod1045)) vals1048) (chi-body146 exps1049 (source-wrap135 e1041 nw1052 s1044 mod1045) nr1053 nw1052 mod1045)))))))) (lambda (e1055 r1056 w1057 s1058 mod1059) ((lambda (tmp1060) ((lambda (tmp1061) (if tmp1061 (apply (lambda (_1062 id1063 val1064 e11065 e21066) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-let86 id1063 val1064 (cons e11065 e21066))) tmp1061) ((lambda (tmp1070) (if (if tmp1070 (apply (lambda (_1071 f1072 id1073 val1074 e11075 e21076) (id?106 f1072)) tmp1070) #f) (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-named-let87 (cons f1078 id1079) val1080 (cons e11081 e21082))) tmp1070) ((lambda (_1086) (syntax-violation (quote let) "bad let" (source-wrap135 e1055 w1057 s1058 mod1059))) tmp1060))) ($sc-dispatch tmp1060 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1060 (quote (any #(each (any any)) any . each-any))))) e1055)))) (global-extend104 (quote core) (quote letrec) (lambda (e1087 r1088 w1089 s1090 mod1091) ((lambda (tmp1092) ((lambda (tmp1093) (if tmp1093 (apply (lambda (_1094 id1095 val1096 e11097 e21098) (let ((ids1099 id1095)) (if (not (valid-bound-ids?131 ids1099)) (syntax-violation (quote letrec) "duplicate bound variable" e1087) (let ((labels1101 (gen-labels112 ids1099)) (new-vars1102 (map gen-var154 ids1099))) (let ((w1103 (make-binding-wrap123 ids1099 labels1101 w1089)) (r1104 (extend-var-env101 labels1101 new-vars1102 r1088))) (build-letrec88 s1090 new-vars1102 (map (lambda (x1105) (chi142 x1105 r1104 w1103 mod1091)) val1096) (chi-body146 (cons e11097 e21098) (source-wrap135 e1087 w1103 s1090 mod1091) r1104 w1103 mod1091))))))) tmp1093) ((lambda (_1108) (syntax-violation (quote letrec) "bad letrec" (source-wrap135 e1087 w1089 s1090 mod1091))) tmp1092))) ($sc-dispatch tmp1092 (quote (any #(each (any any)) any . each-any))))) e1087))) (global-extend104 (quote core) (quote set!) (lambda (e1109 r1110 w1111 s1112 mod1113) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (_1116 id1117 val1118) (id?106 id1117)) tmp1115) #f) (apply (lambda (_1119 id1120 val1121) (let ((val1122 (chi142 val1121 r1110 w1111 mod1113)) (n1123 (id-var-name128 id1120 w1111))) (let ((b1124 (lookup103 n1123 r1110 mod1113))) (let ((t1125 (binding-type98 b1124))) (if (memv t1125 (quote (lexical))) (build-lexical-assignment81 s1112 (syntax->datum id1120) (binding-value99 b1124) val1122) (if (memv t1125 (quote (global))) (build-global-assignment83 s1112 n1123 val1122 mod1113) (if (memv t1125 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap134 id1120 w1111 mod1113)) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))))))))) tmp1115) ((lambda (tmp1126) (if tmp1126 (apply (lambda (_1127 head1128 tail1129 val1130) (call-with-values (lambda () (syntax-type140 head1128 r1110 (quote (())) #f #f mod1113)) (lambda (type1131 value1132 ee1133 ww1134 ss1135 modmod1136) (let ((t1137 type1131)) (if (memv t1137 (quote (module-ref))) (let ((val1138 (chi142 val1130 r1110 w1111 mod1113))) (call-with-values (lambda () (value1132 (cons head1128 tail1129))) (lambda (id1140 mod1141) (build-global-assignment83 s1112 id1140 val1138 mod1141)))) (build-annotated79 s1112 (cons (chi142 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1128) r1110 w1111 mod1113) (map (lambda (e1142) (chi142 e1142 r1110 w1111 mod1113)) (append tail1129 (list val1130)))))))))) tmp1126) ((lambda (_1144) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))) tmp1114))) ($sc-dispatch tmp1114 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1114 (quote (any any any))))) e1109))) (global-extend104 (quote module-ref) (quote @) (lambda (e1145) ((lambda (tmp1146) ((lambda (tmp1147) (if (if tmp1147 (apply (lambda (_1148 mod1149 id1150) (and (and-map id?106 mod1149) (id?106 id1150))) tmp1147) #f) (apply (lambda (_1152 mod1153 id1154) (values (syntax->datum id1154) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1153)))) tmp1147) (syntax-violation #f "source expression failed to match any pattern" tmp1146))) ($sc-dispatch tmp1146 (quote (any each-any any))))) e1145))) (global-extend104 (quote module-ref) (quote @@) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (and (and-map id?106 mod1160) (id?106 id1161))) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend104 (quote begin) (quote begin) (quote ())) (global-extend104 (quote define) (quote define) (quote ())) (global-extend104 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend104 (quote eval-when) (quote eval-when) (quote ())) (global-extend104 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1170 (lambda (x1171 keys1172 clauses1173 r1174 mod1175) (if (null? clauses1173) (build-annotated79 #f (list (build-annotated79 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1171)) ((lambda (tmp1176) ((lambda (tmp1177) (if tmp1177 (apply (lambda (pat1178 exp1179) (if (and (id?106 pat1178) (and-map (lambda (x1180) (not (free-id=?129 pat1178 x1180))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1172))) (let ((labels1181 (list (gen-label111))) (var1182 (gen-var154 pat1178))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list var1182) (chi142 exp1179 (extend-env100 labels1181 (list (cons (quote syntax) (cons var1182 0))) r1174) (make-binding-wrap123 (list pat1178) labels1181 (quote (()))) mod1175))) x1171))) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1178 #t exp1179 mod1175))) tmp1177) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 fender1185 exp1186) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1184 fender1185 exp1186 mod1175)) tmp1183) ((lambda (_1187) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1173))) tmp1176))) ($sc-dispatch tmp1176 (quote (any any any)))))) ($sc-dispatch tmp1176 (quote (any any))))) (car clauses1173))))) (gen-clause1169 (lambda (x1188 keys1189 clauses1190 r1191 pat1192 fender1193 exp1194 mod1195) (call-with-values (lambda () (convert-pattern1167 pat1192 keys1189)) (lambda (p1196 pvars1197) (cond ((not (distinct-bound-ids?132 (map car pvars1197))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1192)) ((not (and-map (lambda (x1198) (not (ellipsis?151 (car x1198)))) pvars1197)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1192)) (else (let ((y1199 (gen-var154 (quote tmp)))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list y1199) (let ((y1200 (build-lexical-reference80 (quote value) #f (quote tmp) y1199))) (build-annotated79 #f (list (quote if) ((lambda (tmp1201) ((lambda (tmp1202) (if tmp1202 (apply (lambda () y1200) tmp1202) ((lambda (_1203) (build-annotated79 #f (list (quote if) y1200 (build-dispatch-call1168 pvars1197 fender1193 y1200 r1191 mod1195) (build-data84 #f #f)))) tmp1201))) ($sc-dispatch tmp1201 (quote #(atom #t))))) fender1193) (build-dispatch-call1168 pvars1197 exp1194 y1200 r1191 mod1195) (gen-syntax-case1170 x1188 keys1189 clauses1190 r1191 mod1195)))))) (if (eq? p1196 (quote any)) (build-annotated79 #f (list (build-annotated79 #f (quote list)) x1188)) (build-annotated79 #f (list (build-annotated79 #f (quote $sc-dispatch)) x1188 (build-data84 #f p1196))))))))))))) (build-dispatch-call1168 (lambda (pvars1204 exp1205 y1206 r1207 mod1208) (let ((ids1209 (map car pvars1204)) (levels1210 (map cdr pvars1204))) (let ((labels1211 (gen-labels112 ids1209)) (new-vars1212 (map gen-var154 ids1209))) (build-annotated79 #f (list (build-annotated79 #f (quote apply)) (build-annotated79 #f (list (quote lambda) new-vars1212 (chi142 exp1205 (extend-env100 labels1211 (map (lambda (var1213 level1214) (cons (quote syntax) (cons var1213 level1214))) new-vars1212 (map cdr pvars1204)) r1207) (make-binding-wrap123 ids1209 labels1211 (quote (()))) mod1208))) y1206)))))) (convert-pattern1167 (lambda (pattern1215 keys1216) (let cvt1217 ((p1218 pattern1215) (n1219 0) (ids1220 (quote ()))) (if (id?106 p1218) (if (bound-id-member?133 p1218 keys1216) (values (vector (quote free-id) p1218) ids1220) (values (quote any) (cons (cons p1218 n1219) ids1220))) ((lambda (tmp1221) ((lambda (tmp1222) (if (if tmp1222 (apply (lambda (x1223 dots1224) (ellipsis?151 dots1224)) tmp1222) #f) (apply (lambda (x1225 dots1226) (call-with-values (lambda () (cvt1217 x1225 (fx+71 n1219 1) ids1220)) (lambda (p1227 ids1228) (values (if (eq? p1227 (quote any)) (quote each-any) (vector (quote each) p1227)) ids1228)))) tmp1222) ((lambda (tmp1229) (if tmp1229 (apply (lambda (x1230 y1231) (call-with-values (lambda () (cvt1217 y1231 n1219 ids1220)) (lambda (y1232 ids1233) (call-with-values (lambda () (cvt1217 x1230 n1219 ids1233)) (lambda (x1234 ids1235) (values (cons x1234 y1232) ids1235)))))) tmp1229) ((lambda (tmp1236) (if tmp1236 (apply (lambda () (values (quote ()) ids1220)) tmp1236) ((lambda (tmp1237) (if tmp1237 (apply (lambda (x1238) (call-with-values (lambda () (cvt1217 x1238 n1219 ids1220)) (lambda (p1240 ids1241) (values (vector (quote vector) p1240) ids1241)))) tmp1237) ((lambda (x1242) (values (vector (quote atom) (strip153 p1218 (quote (())))) ids1220)) tmp1221))) ($sc-dispatch tmp1221 (quote #(vector each-any)))))) ($sc-dispatch tmp1221 (quote ()))))) ($sc-dispatch tmp1221 (quote (any . any)))))) ($sc-dispatch tmp1221 (quote (any any))))) p1218)))))) (lambda (e1243 r1244 w1245 s1246 mod1247) (let ((e1248 (source-wrap135 e1243 w1245 s1246 mod1247))) ((lambda (tmp1249) ((lambda (tmp1250) (if tmp1250 (apply (lambda (_1251 val1252 key1253 m1254) (if (and-map (lambda (x1255) (and (id?106 x1255) (not (ellipsis?151 x1255)))) key1253) (let ((x1257 (gen-var154 (quote tmp)))) (build-annotated79 s1246 (list (build-annotated79 #f (list (quote lambda) (list x1257) (gen-syntax-case1170 (build-lexical-reference80 (quote value) #f (quote tmp) x1257) key1253 m1254 r1244 mod1247))) (chi142 val1252 r1244 (quote (())) mod1247)))) (syntax-violation (quote syntax-case) "invalid literals list" e1248))) tmp1250) (syntax-violation #f "source expression failed to match any pattern" tmp1249))) ($sc-dispatch tmp1249 (quote (any any each-any . each-any))))) e1248))))) (set! sc-expand (lambda (x1261 . rest1260) (if (and (pair? x1261) (equal? (car x1261) noexpand69)) (cadr x1261) (let ((m1262 (if (null? rest1260) (quote e) (car rest1260))) (esew1263 (if (or (null? rest1260) (null? (cdr rest1260))) (quote (eval)) (cadr rest1260)))) (with-fluid* *mode*70 m1262 (lambda () (chi-top141 x1261 (quote ()) (quote ((top))) m1262 esew1263 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1264) (nonsymbol-id?105 x1264))) (set! datum->syntax (lambda (id1265 datum1266) (make-syntax-object89 datum1266 (syntax-object-wrap92 id1265) #f))) (set! syntax->datum (lambda (x1267) (strip153 x1267 (quote (()))))) (set! generate-temporaries (lambda (ls1268) (begin (let ((x1269 ls1268)) (if (not (list? x1269)) (syntax-violation (quote generate-temporaries) "invalid argument" x1269))) (map (lambda (x1270) (wrap134 (gensym) (quote ((top))) #f)) ls1268)))) (set! free-identifier=? (lambda (x1271 y1272) (begin (let ((x1273 x1271)) (if (not (nonsymbol-id?105 x1273)) (syntax-violation (quote free-identifier=?) "invalid argument" x1273))) (let ((x1274 y1272)) (if (not (nonsymbol-id?105 x1274)) (syntax-violation (quote free-identifier=?) "invalid argument" x1274))) (free-id=?129 x1271 y1272)))) (set! bound-identifier=? (lambda (x1275 y1276) (begin (let ((x1277 x1275)) (if (not (nonsymbol-id?105 x1277)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1277))) (let ((x1278 y1276)) (if (not (nonsymbol-id?105 x1278)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1278))) (bound-id=?130 x1275 y1276)))) (set! syntax-violation (lambda (who1282 message1281 form1280 . subform1279) (begin (let ((x1283 who1282)) (if (not ((lambda (x1284) (or (not x1284) (string? x1284) (symbol? x1284))) x1283)) (syntax-violation (quote syntax-violation) "invalid argument" x1283))) (let ((x1285 message1281)) (if (not (string? x1285)) (syntax-violation (quote syntax-violation) "invalid argument" x1285))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1282 "~a: " "") "~a " (if (null? subform1279) "in ~a" "in subform `~s' of `~s'")) (let ((tail1286 (cons message1281 (map (lambda (x1287) (strip153 x1287 (quote (())))) (append subform1279 (list form1280)))))) (if who1282 (cons who1282 tail1286) tail1286)) #f)))) (letrec ((match1292 (lambda (e1293 p1294 w1295 r1296 mod1297) (cond ((not r1296) #f) ((eq? p1294 (quote any)) (cons (wrap134 e1293 w1295 mod1297) r1296)) ((syntax-object?90 e1293) (match*1291 (let ((e1298 (syntax-object-expression91 e1293))) (if (annotation? e1298) (annotation-expression e1298) e1298)) p1294 (join-wraps125 w1295 (syntax-object-wrap92 e1293)) r1296 (syntax-object-module93 e1293))) (else (match*1291 (let ((e1299 e1293)) (if (annotation? e1299) (annotation-expression e1299) e1299)) p1294 w1295 r1296 mod1297))))) (match*1291 (lambda (e1300 p1301 w1302 r1303 mod1304) (cond ((null? p1301) (and (null? e1300) r1303)) ((pair? p1301) (and (pair? e1300) (match1292 (car e1300) (car p1301) w1302 (match1292 (cdr e1300) (cdr p1301) w1302 r1303 mod1304) mod1304))) ((eq? p1301 (quote each-any)) (let ((l1305 (match-each-any1289 e1300 w1302 mod1304))) (and l1305 (cons l1305 r1303)))) (else (let ((t1306 (vector-ref p1301 0))) (if (memv t1306 (quote (each))) (if (null? e1300) (match-empty1290 (vector-ref p1301 1) r1303) (let ((l1307 (match-each1288 e1300 (vector-ref p1301 1) w1302 mod1304))) (and l1307 (let collect1308 ((l1309 l1307)) (if (null? (car l1309)) r1303 (cons (map car l1309) (collect1308 (map cdr l1309)))))))) (if (memv t1306 (quote (free-id))) (and (id?106 e1300) (free-id=?129 (wrap134 e1300 w1302 mod1304) (vector-ref p1301 1)) r1303) (if (memv t1306 (quote (atom))) (and (equal? (vector-ref p1301 1) (strip153 e1300 w1302)) r1303) (if (memv t1306 (quote (vector))) (and (vector? e1300) (match1292 (vector->list e1300) (vector-ref p1301 1) w1302 r1303 mod1304))))))))))) (match-empty1290 (lambda (p1310 r1311) (cond ((null? p1310) r1311) ((eq? p1310 (quote any)) (cons (quote ()) r1311)) ((pair? p1310) (match-empty1290 (car p1310) (match-empty1290 (cdr p1310) r1311))) ((eq? p1310 (quote each-any)) (cons (quote ()) r1311)) (else (let ((t1312 (vector-ref p1310 0))) (if (memv t1312 (quote (each))) (match-empty1290 (vector-ref p1310 1) r1311) (if (memv t1312 (quote (free-id atom))) r1311 (if (memv t1312 (quote (vector))) (match-empty1290 (vector-ref p1310 1) r1311))))))))) (match-each-any1289 (lambda (e1313 w1314 mod1315) (cond ((annotation? e1313) (match-each-any1289 (annotation-expression e1313) w1314 mod1315)) ((pair? e1313) (let ((l1316 (match-each-any1289 (cdr e1313) w1314 mod1315))) (and l1316 (cons (wrap134 (car e1313) w1314 mod1315) l1316)))) ((null? e1313) (quote ())) ((syntax-object?90 e1313) (match-each-any1289 (syntax-object-expression91 e1313) (join-wraps125 w1314 (syntax-object-wrap92 e1313)) mod1315)) (else #f)))) (match-each1288 (lambda (e1317 p1318 w1319 mod1320) (cond ((annotation? e1317) (match-each1288 (annotation-expression e1317) p1318 w1319 mod1320)) ((pair? e1317) (let ((first1321 (match1292 (car e1317) p1318 w1319 (quote ()) mod1320))) (and first1321 (let ((rest1322 (match-each1288 (cdr e1317) p1318 w1319 mod1320))) (and rest1322 (cons first1321 rest1322)))))) ((null? e1317) (quote ())) ((syntax-object?90 e1317) (match-each1288 (syntax-object-expression91 e1317) p1318 (join-wraps125 w1319 (syntax-object-wrap92 e1317)) (syntax-object-module93 e1317))) (else #f))))) (set! $sc-dispatch (lambda (e1323 p1324) (cond ((eq? p1324 (quote any)) (list e1323)) ((syntax-object?90 e1323) (match*1291 (let ((e1325 (syntax-object-expression91 e1323))) (if (annotation? e1325) (annotation-expression e1325) e1325)) p1324 (syntax-object-wrap92 e1323) (quote ()) (syntax-object-module93 e1323))) (else (match*1291 (let ((e1326 e1323)) (if (annotation? e1326) (annotation-expression e1326) e1326)) p1324 (quote (())) (quote ()) #f))))))))) (define with-syntax (make-syncase-macro (quote macro) (lambda (x1327) ((lambda (tmp1328) ((lambda (tmp1329) (if tmp1329 (apply (lambda (_1330 e11331 e21332) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11331 e21332))) tmp1329) ((lambda (tmp1334) (if tmp1334 (apply (lambda (_1335 out1336 in1337 e11338 e21339) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1337 (quote ()) (list out1336 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11338 e21339))))) tmp1334) ((lambda (tmp1341) (if tmp1341 (apply (lambda (_1342 out1343 in1344 e11345 e21346) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1344) (quote ()) (list out1343 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11345 e21346))))) tmp1341) (syntax-violation #f "source expression failed to match any pattern" tmp1328))) ($sc-dispatch tmp1328 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any () any . each-any))))) x1327)))) (define syntax-rules (make-syncase-macro (quote macro) (lambda (x1350) ((lambda (tmp1351) ((lambda (tmp1352) (if tmp1352 (apply (lambda (_1353 k1354 keyword1355 pattern1356 template1357) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1354 (map (lambda (tmp1360 tmp1359) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1359) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1360))) template1357 pattern1356)))))) tmp1352) (syntax-violation #f "source expression failed to match any pattern" tmp1351))) ($sc-dispatch tmp1351 (quote (any each-any . #(each ((any . any) any))))))) x1350)))) (define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1361) ((lambda (tmp1362) ((lambda (tmp1363) (if (if tmp1363 (apply (lambda (let*1364 x1365 v1366 e11367 e21368) (and-map identifier? x1365)) tmp1363) #f) (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (let f1375 ((bindings1376 (map list x1371 v1372))) (if (null? bindings1376) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11373 e21374))) ((lambda (tmp1380) ((lambda (tmp1381) (if tmp1381 (apply (lambda (body1382 binding1383) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1383) body1382)) tmp1381) (syntax-violation #f "source expression failed to match any pattern" tmp1380))) ($sc-dispatch tmp1380 (quote (any any))))) (list (f1375 (cdr bindings1376)) (car bindings1376)))))) tmp1363) (syntax-violation #f "source expression failed to match any pattern" tmp1362))) ($sc-dispatch tmp1362 (quote (any #(each (any any)) any . each-any))))) x1361)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 8dfdda34b..7173ba763 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -371,7 +371,7 @@ (build-annotated source (case (fluid-ref *mode*) - ((c) ((@ (ice-9 expand-support) make-lexical) name var)) + ((c) ((@ (ice-9 expand-support) make-lexical) source name var)) (else var))))) (define build-lexical-assignment @@ -398,19 +398,19 @@ (let ((make-module-ref (case (fluid-ref *mode*) ((c) (@ (ice-9 expand-support) make-module-ref)) - (else (lambda (mod var public?) + (else (lambda (source mod var public?) (list (if public? '@ '@@) mod var))))) (kind (car mod)) (mod (cdr mod))) (case kind - ((public) (make-module-ref mod var #t)) + ((public) (make-module-ref #f mod var #t)) ((private) (if (not (equal? mod (module-name (current-module)))) - (make-module-ref mod var #f) + (make-module-ref #f mod var #f) var)) ((bare) var) ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) (module-variable (resolve-module mod) var)) - (make-module-ref mod var #f) + (make-module-ref #f mod var #f) var)) (else (syntax-violation #f "bad module kind" var mod)))))))) From 811d10f5a2297e2fe6a881d02c67c45bf4311a27 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 May 2009 13:45:03 +0200 Subject: [PATCH 096/375] new language: tree-il. psyntax generates it when run in compile mode. * module/Makefile.am: Add tree-il sources. * module/ice-9/compile-psyntax.scm: Adjust for sc-expand producing tree-il in compile mode. * module/ice-9/psyntax.scm: Switch from expand-support to tree-il for generating output in compile mode. Completely generate tree-il -- the output wasn't Scheme before, but now it's completely not Scheme. * module/ice-9/psyntax-pp.scm: Regenerated. * module/language/scheme/compile-ghil.scm: Strip structures using tree-il, not expand-support. * module/language/tree-il.scm: * module/language/tree-il/spec.scm * module/language/tree-il/compile-glil.scm: New language. It will compile to GLIL, though it doesn't yet. --- module/Makefile.am | 7 +- module/ice-9/compile-psyntax.scm | 4 +- module/ice-9/psyntax-pp.scm | 22 +- module/ice-9/psyntax.scm | 207 ++++---- module/language/scheme/compile-ghil.scm | 4 +- module/language/tree-il.scm | 248 ++++++++++ module/language/tree-il/compile-glil.scm | 591 +++++++++++++++++++++++ module/language/tree-il/spec.scm | 52 ++ 8 files changed, 1024 insertions(+), 111 deletions(-) create mode 100644 module/language/tree-il.scm create mode 100644 module/language/tree-il/compile-glil.scm create mode 100644 module/language/tree-il/spec.scm diff --git a/module/Makefile.am b/module/Makefile.am index 9cda51aac..4bc52e474 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -31,13 +31,15 @@ modpath = # putting these core modules first. SOURCES = \ - ice-9/psyntax-pp.scm \ + ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ \ + language/tree-il.scm \ language/ghil.scm language/glil.scm language/assembly.scm \ \ $(SCHEME_LANG_SOURCES) \ + $(TREE_IL_LANG_SOURCES) \ $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ @@ -67,6 +69,9 @@ SCHEME_LANG_SOURCES = \ language/scheme/compile-ghil.scm language/scheme/spec.scm \ language/scheme/inline.scm +TREE_IL_LANG_SOURCES = \ + language/tree-il/spec.scm language/tree-il/compile-glil.scm + GHIL_LANG_SOURCES = \ language/ghil/spec.scm language/ghil/compile-glil.scm diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 853586e12..2b8eec0d2 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,4 +1,4 @@ -(use-modules (ice-9 expand-support)) +(use-modules (language tree-il)) (let ((source (list-ref (command-line) 1)) (target (list-ref (command-line) 2))) (let ((in (open-input-file source)) @@ -12,7 +12,7 @@ (close-port out) (close-port in)) (begin - (write (strip-expansion-structures + (write (tree-il->scheme (sc-expand x 'c '(compile load eval))) out) (newline out) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index b92440648..2718a1e87 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68)))))))))) (letrec ((lambda-var-list155 (lambda (vars330) (let lvl331 ((vars332 vars330) (ls333 (quote ())) (w334 (quote (())))) (cond ((pair? vars332) (lvl331 (cdr vars332) (cons (wrap134 (car vars332) w334 #f) ls333) w334)) ((id?106 vars332) (cons (wrap134 vars332 w334 #f) ls333)) ((null? vars332) ls333) ((syntax-object?90 vars332) (lvl331 (syntax-object-expression91 vars332) ls333 (join-wraps125 w334 (syntax-object-wrap92 vars332)))) ((annotation? vars332) (lvl331 (annotation-expression vars332) ls333 w334)) (else (cons vars332 ls333)))))) (gen-var154 (lambda (id335) (let ((id336 (if (syntax-object?90 id335) (syntax-object-expression91 id335) id335))) (if (annotation? id336) (build-annotated79 (annotation-source id336) (gensym (symbol->string (annotation-expression id336)))) (build-annotated79 #f (gensym (symbol->string id336))))))) (strip153 (lambda (x337 w338) (if (memq (quote top) (wrap-marks109 w338)) (if (or (annotation? x337) (and (pair? x337) (annotation? (car x337)))) (strip-annotation152 x337 #f) x337) (let f339 ((x340 x337)) (cond ((syntax-object?90 x340) (strip153 (syntax-object-expression91 x340) (syntax-object-wrap92 x340))) ((pair? x340) (let ((a341 (f339 (car x340))) (d342 (f339 (cdr x340)))) (if (and (eq? a341 (car x340)) (eq? d342 (cdr x340))) x340 (cons a341 d342)))) ((vector? x340) (let ((old343 (vector->list x340))) (let ((new344 (map f339 old343))) (if (and-map*17 eq? old343 new344) x340 (list->vector new344))))) (else x340)))))) (strip-annotation152 (lambda (x345 parent346) (cond ((pair? x345) (let ((new347 (cons #f #f))) (begin (if parent346 (set-annotation-stripped! parent346 new347)) (set-car! new347 (strip-annotation152 (car x345) #f)) (set-cdr! new347 (strip-annotation152 (cdr x345) #f)) new347))) ((annotation? x345) (or (annotation-stripped x345) (strip-annotation152 (annotation-expression x345) x345))) ((vector? x345) (let ((new348 (make-vector (vector-length x345)))) (begin (if parent346 (set-annotation-stripped! parent346 new348)) (let loop349 ((i350 (- (vector-length x345) 1))) (unless (fx<74 i350 0) (vector-set! new348 i350 (strip-annotation152 (vector-ref x345 i350) #f)) (loop349 (fx-72 i350 1)))) new348))) (else x345)))) (ellipsis?151 (lambda (x351) (and (nonsymbol-id?105 x351) (free-id=?129 x351 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void150 (lambda () (build-annotated79 #f (cons (build-annotated79 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer149 (lambda (expanded352 mod353) (let ((p354 (local-eval-hook76 expanded352 mod353))) (if (procedure? p354) p354 (syntax-violation #f "nonprocedure transformer" p354))))) (chi-local-syntax148 (lambda (rec?355 e356 r357 w358 s359 mod360 k361) ((lambda (tmp362) ((lambda (tmp363) (if tmp363 (apply (lambda (_364 id365 val366 e1367 e2368) (let ((ids369 id365)) (if (not (valid-bound-ids?131 ids369)) (syntax-violation #f "duplicate bound keyword" e356) (let ((labels371 (gen-labels112 ids369))) (let ((new-w372 (make-binding-wrap123 ids369 labels371 w358))) (k361 (cons e1367 e2368) (extend-env100 labels371 (let ((w374 (if rec?355 new-w372 w358)) (trans-r375 (macros-only-env102 r357))) (map (lambda (x376) (cons (quote macro) (eval-local-transformer149 (chi142 x376 trans-r375 w374 mod360) mod360))) val366)) r357) new-w372 s359 mod360)))))) tmp363) ((lambda (_378) (syntax-violation #f "bad local syntax definition" (source-wrap135 e356 w358 s359 mod360))) tmp362))) ($sc-dispatch tmp362 (quote (any #(each (any any)) any . each-any))))) e356))) (chi-lambda-clause147 (lambda (e379 docstring380 c381 r382 w383 mod384 k385) ((lambda (tmp386) ((lambda (tmp387) (if (if tmp387 (apply (lambda (args388 doc389 e1390 e2391) (and (string? (syntax->datum doc389)) (not docstring380))) tmp387) #f) (apply (lambda (args392 doc393 e1394 e2395) (chi-lambda-clause147 e379 doc393 (cons args392 (cons e1394 e2395)) r382 w383 mod384 k385)) tmp387) ((lambda (tmp397) (if tmp397 (apply (lambda (id398 e1399 e2400) (let ((ids401 id398)) (if (not (valid-bound-ids?131 ids401)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels403 (gen-labels112 ids401)) (new-vars404 (map gen-var154 ids401))) (k385 new-vars404 docstring380 (chi-body146 (cons e1399 e2400) e379 (extend-var-env101 labels403 new-vars404 r382) (make-binding-wrap123 ids401 labels403 w383) mod384)))))) tmp397) ((lambda (tmp406) (if tmp406 (apply (lambda (ids407 e1408 e2409) (let ((old-ids410 (lambda-var-list155 ids407))) (if (not (valid-bound-ids?131 old-ids410)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels411 (gen-labels112 old-ids410)) (new-vars412 (map gen-var154 old-ids410))) (k385 (let f413 ((ls1414 (cdr new-vars412)) (ls2415 (car new-vars412))) (if (null? ls1414) ls2415 (f413 (cdr ls1414) (cons (car ls1414) ls2415)))) docstring380 (chi-body146 (cons e1408 e2409) e379 (extend-var-env101 labels411 new-vars412 r382) (make-binding-wrap123 old-ids410 labels411 w383) mod384)))))) tmp406) ((lambda (_417) (syntax-violation (quote lambda) "bad lambda" e379)) tmp386))) ($sc-dispatch tmp386 (quote (any any . each-any)))))) ($sc-dispatch tmp386 (quote (each-any any . each-any)))))) ($sc-dispatch tmp386 (quote (any any any . each-any))))) c381))) (chi-body146 (lambda (body418 outer-form419 r420 w421 mod422) (let ((r423 (cons (quote ("placeholder" placeholder)) r420))) (let ((ribcage424 (make-ribcage113 (quote ()) (quote ()) (quote ())))) (let ((w425 (make-wrap108 (wrap-marks109 w421) (cons ribcage424 (wrap-subst110 w421))))) (let parse426 ((body427 (map (lambda (x433) (cons r423 (wrap134 x433 w425 mod422))) body418)) (ids428 (quote ())) (labels429 (quote ())) (vars430 (quote ())) (vals431 (quote ())) (bindings432 (quote ()))) (if (null? body427) (syntax-violation #f "no expressions in body" outer-form419) (let ((e434 (cdar body427)) (er435 (caar body427))) (call-with-values (lambda () (syntax-type140 e434 er435 (quote (())) #f ribcage424 mod422)) (lambda (type436 value437 e438 w439 s440 mod441) (let ((t442 type436)) (if (memv t442 (quote (define-form))) (let ((id443 (wrap134 value437 w439 mod441)) (label444 (gen-label111))) (let ((var445 (gen-var154 id443))) (begin (extend-ribcage!122 ribcage424 id443 label444) (parse426 (cdr body427) (cons id443 ids428) (cons label444 labels429) (cons var445 vars430) (cons (cons er435 (wrap134 e438 w439 mod441)) vals431) (cons (cons (quote lexical) var445) bindings432))))) (if (memv t442 (quote (define-syntax-form))) (let ((id446 (wrap134 value437 w439 mod441)) (label447 (gen-label111))) (begin (extend-ribcage!122 ribcage424 id446 label447) (parse426 (cdr body427) (cons id446 ids428) (cons label447 labels429) vars430 vals431 (cons (cons (quote macro) (cons er435 (wrap134 e438 w439 mod441))) bindings432)))) (if (memv t442 (quote (begin-form))) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (_450 e1451) (parse426 (let f452 ((forms453 e1451)) (if (null? forms453) (cdr body427) (cons (cons er435 (wrap134 (car forms453) w439 mod441)) (f452 (cdr forms453))))) ids428 labels429 vars430 vals431 bindings432)) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e438) (if (memv t442 (quote (local-syntax-form))) (chi-local-syntax148 value437 e438 er435 w439 s440 mod441 (lambda (forms455 er456 w457 s458 mod459) (parse426 (let f460 ((forms461 forms455)) (if (null? forms461) (cdr body427) (cons (cons er456 (wrap134 (car forms461) w457 mod459)) (f460 (cdr forms461))))) ids428 labels429 vars430 vals431 bindings432))) (if (null? ids428) (build-sequence85 #f (map (lambda (x462) (chi142 (cdr x462) (car x462) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))) (begin (if (not (valid-bound-ids?131 ids428)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form419)) (let loop463 ((bs464 bindings432) (er-cache465 #f) (r-cache466 #f)) (if (not (null? bs464)) (let ((b467 (car bs464))) (if (eq? (car b467) (quote macro)) (let ((er468 (cadr b467))) (let ((r-cache469 (if (eq? er468 er-cache465) r-cache466 (macros-only-env102 er468)))) (begin (set-cdr! b467 (eval-local-transformer149 (chi142 (cddr b467) r-cache469 (quote (())) mod441) mod441)) (loop463 (cdr bs464) er468 r-cache469)))) (loop463 (cdr bs464) er-cache465 r-cache466))))) (set-cdr! r423 (extend-env100 labels429 bindings432 (cdr r423))) (build-letrec88 #f vars430 (map (lambda (x470) (chi142 (cdr x470) (car x470) (quote (())) mod441)) vals431) (build-sequence85 #f (map (lambda (x471) (chi142 (cdr x471) (car x471) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))))))))))))))))))))) (chi-macro145 (lambda (p472 e473 r474 w475 rib476 mod477) (letrec ((rebuild-macro-output478 (lambda (x479 m480) (cond ((pair? x479) (cons (rebuild-macro-output478 (car x479) m480) (rebuild-macro-output478 (cdr x479) m480))) ((syntax-object?90 x479) (let ((w481 (syntax-object-wrap92 x479))) (let ((ms482 (wrap-marks109 w481)) (s483 (wrap-subst110 w481))) (if (and (pair? ms482) (eq? (car ms482) #f)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cdr ms482) (if rib476 (cons rib476 (cdr s483)) (cdr s483))) (syntax-object-module93 x479)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cons m480 ms482) (if rib476 (cons rib476 (cons (quote shift) s483)) (cons (quote shift) s483))) (let ((pmod484 (procedure-module p472))) (if pmod484 (cons (quote hygiene) (module-name pmod484)) (quote (hygiene guile))))))))) ((vector? x479) (let ((n485 (vector-length x479))) (let ((v486 (make-vector n485))) (let doloop487 ((i488 0)) (if (fx=73 i488 n485) v486 (begin (vector-set! v486 i488 (rebuild-macro-output478 (vector-ref x479 i488) m480)) (doloop487 (fx+71 i488 1)))))))) ((symbol? x479) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap135 e473 w475 s mod477) x479)) (else x479))))) (rebuild-macro-output478 (p472 (wrap134 e473 (anti-mark121 w475) mod477)) (string #\m))))) (chi-application144 (lambda (x489 e490 r491 w492 s493 mod494) ((lambda (tmp495) ((lambda (tmp496) (if tmp496 (apply (lambda (e0497 e1498) (build-annotated79 s493 (cons x489 (map (lambda (e499) (chi142 e499 r491 w492 mod494)) e1498)))) tmp496) (syntax-violation #f "source expression failed to match any pattern" tmp495))) ($sc-dispatch tmp495 (quote (any . each-any))))) e490))) (chi-expr143 (lambda (type501 value502 e503 r504 w505 s506 mod507) (let ((t508 type501)) (if (memv t508 (quote (lexical))) (build-lexical-reference80 (quote value) s506 e503 value502) (if (memv t508 (quote (core external-macro))) (value502 e503 r504 w505 s506 mod507) (if (memv t508 (quote (module-ref))) (call-with-values (lambda () (value502 e503)) (lambda (id509 mod510) (build-global-reference82 s506 id509 mod510))) (if (memv t508 (quote (lexical-call))) (chi-application144 (build-lexical-reference80 (quote fun) (source-annotation97 (car e503)) (car e503) value502) e503 r504 w505 s506 mod507) (if (memv t508 (quote (global-call))) (chi-application144 (build-global-reference82 (source-annotation97 (car e503)) value502 (if (syntax-object?90 (car e503)) (syntax-object-module93 (car e503)) mod507)) e503 r504 w505 s506 mod507) (if (memv t508 (quote (constant))) (build-data84 s506 (strip153 (source-wrap135 e503 w505 s506 mod507) (quote (())))) (if (memv t508 (quote (global))) (build-global-reference82 s506 value502 mod507) (if (memv t508 (quote (call))) (chi-application144 (chi142 (car e503) r504 w505 mod507) e503 r504 w505 s506 mod507) (if (memv t508 (quote (begin-form))) ((lambda (tmp511) ((lambda (tmp512) (if tmp512 (apply (lambda (_513 e1514 e2515) (chi-sequence136 (cons e1514 e2515) r504 w505 s506 mod507)) tmp512) (syntax-violation #f "source expression failed to match any pattern" tmp511))) ($sc-dispatch tmp511 (quote (any any . each-any))))) e503) (if (memv t508 (quote (local-syntax-form))) (chi-local-syntax148 value502 e503 r504 w505 s506 mod507 chi-sequence136) (if (memv t508 (quote (eval-when-form))) ((lambda (tmp517) ((lambda (tmp518) (if tmp518 (apply (lambda (_519 x520 e1521 e2522) (let ((when-list523 (chi-when-list139 e503 x520 w505))) (if (memq (quote eval) when-list523) (chi-sequence136 (cons e1521 e2522) r504 w505 s506 mod507) (chi-void150)))) tmp518) (syntax-violation #f "source expression failed to match any pattern" tmp517))) ($sc-dispatch tmp517 (quote (any each-any any . each-any))))) e503) (if (memv t508 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e503 (wrap134 value502 w505 mod507)) (if (memv t508 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap135 e503 w505 s506 mod507)) (if (memv t508 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap135 e503 w505 s506 mod507)) (syntax-violation #f "unexpected syntax" (source-wrap135 e503 w505 s506 mod507))))))))))))))))))) (chi142 (lambda (e526 r527 w528 mod529) (call-with-values (lambda () (syntax-type140 e526 r527 w528 #f #f mod529)) (lambda (type530 value531 e532 w533 s534 mod535) (chi-expr143 type530 value531 e532 r527 w533 s534 mod535))))) (chi-top141 (lambda (e536 r537 w538 m539 esew540 mod541) (call-with-values (lambda () (syntax-type140 e536 r537 w538 #f #f mod541)) (lambda (type549 value550 e551 w552 s553 mod554) (let ((t555 type549)) (if (memv t555 (quote (begin-form))) ((lambda (tmp556) ((lambda (tmp557) (if tmp557 (apply (lambda (_558) (chi-void150)) tmp557) ((lambda (tmp559) (if tmp559 (apply (lambda (_560 e1561 e2562) (chi-top-sequence137 (cons e1561 e2562) r537 w552 s553 m539 esew540 mod554)) tmp559) (syntax-violation #f "source expression failed to match any pattern" tmp556))) ($sc-dispatch tmp556 (quote (any any . each-any)))))) ($sc-dispatch tmp556 (quote (any))))) e551) (if (memv t555 (quote (local-syntax-form))) (chi-local-syntax148 value550 e551 r537 w552 s553 mod554 (lambda (body564 r565 w566 s567 mod568) (chi-top-sequence137 body564 r565 w566 s567 m539 esew540 mod568))) (if (memv t555 (quote (eval-when-form))) ((lambda (tmp569) ((lambda (tmp570) (if tmp570 (apply (lambda (_571 x572 e1573 e2574) (let ((when-list575 (chi-when-list139 e551 x572 w552)) (body576 (cons e1573 e2574))) (cond ((eq? m539 (quote e)) (if (memq (quote eval) when-list575) (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) (chi-void150))) ((memq (quote load) when-list575) (if (or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (chi-top-sequence137 body576 r537 w552 s553 (quote c&e) (quote (compile load)) mod554) (if (memq m539 (quote (c c&e))) (chi-top-sequence137 body576 r537 w552 s553 (quote c) (quote (load)) mod554) (chi-void150)))) ((or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (top-level-eval-hook75 (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) mod554) (chi-void150)) (else (chi-void150))))) tmp570) (syntax-violation #f "source expression failed to match any pattern" tmp569))) ($sc-dispatch tmp569 (quote (any each-any any . each-any))))) e551) (if (memv t555 (quote (define-syntax-form))) (let ((n579 (id-var-name128 value550 w552)) (r580 (macros-only-env102 r537))) (let ((t581 m539)) (if (memv t581 (quote (c))) (if (memq (quote compile) esew540) (let ((e582 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e582 mod554) (if (memq (quote load) esew540) e582 (chi-void150)))) (if (memq (quote load) esew540) (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) (chi-void150))) (if (memv t581 (quote (c&e))) (let ((e583 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e583 mod554) e583)) (begin (if (memq (quote eval) esew540) (top-level-eval-hook75 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) mod554)) (chi-void150)))))) (if (memv t555 (quote (define-form))) (let ((n584 (id-var-name128 value550 w552))) (let ((type585 (binding-type98 (lookup103 n584 r537 mod554)))) (let ((t586 type585)) (if (memv t586 (quote (global core macro module-ref))) (let ((x587 (build-annotated79 s553 (list (quote define) n584 (chi142 e551 r537 w552 mod554))))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x587 mod554)) x587)) (if (memv t586 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e551 (wrap134 value550 w552 mod554)) (syntax-violation #f "cannot define keyword at top level" e551 (wrap134 value550 w552 mod554))))))) (let ((x588 (chi-expr143 type549 value550 e551 r537 w552 s553 mod554))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x588 mod554)) x588)))))))))))) (syntax-type140 (lambda (e589 r590 w591 s592 rib593 mod594) (cond ((symbol? e589) (let ((n595 (id-var-name128 e589 w591))) (let ((b596 (lookup103 n595 r590 mod594))) (let ((type597 (binding-type98 b596))) (let ((t598 type597)) (if (memv t598 (quote (lexical))) (values type597 (binding-value99 b596) e589 w591 s592 mod594) (if (memv t598 (quote (global))) (values type597 n595 e589 w591 s592 mod594) (if (memv t598 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b596) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (values type597 (binding-value99 b596) e589 w591 s592 mod594))))))))) ((pair? e589) (let ((first599 (car e589))) (if (id?106 first599) (let ((n600 (id-var-name128 first599 w591))) (let ((b601 (lookup103 n600 r590 (or (and (syntax-object?90 first599) (syntax-object-module93 first599)) mod594)))) (let ((type602 (binding-type98 b601))) (let ((t603 type602)) (if (memv t603 (quote (lexical))) (values (quote lexical-call) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (global))) (values (quote global-call) n600 e589 w591 s592 mod594) (if (memv t603 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b601) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (if (memv t603 (quote (core external-macro module-ref))) (values type602 (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (begin))) (values (quote begin-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (eval-when))) (values (quote eval-when-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (define))) ((lambda (tmp604) ((lambda (tmp605) (if (if tmp605 (apply (lambda (_606 name607 val608) (id?106 name607)) tmp605) #f) (apply (lambda (_609 name610 val611) (values (quote define-form) name610 val611 w591 s592 mod594)) tmp605) ((lambda (tmp612) (if (if tmp612 (apply (lambda (_613 name614 args615 e1616 e2617) (and (id?106 name614) (valid-bound-ids?131 (lambda-var-list155 args615)))) tmp612) #f) (apply (lambda (_618 name619 args620 e1621 e2622) (values (quote define-form) (wrap134 name619 w591 mod594) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap134 (cons args620 (cons e1621 e2622)) w591 mod594)) (quote (())) s592 mod594)) tmp612) ((lambda (tmp624) (if (if tmp624 (apply (lambda (_625 name626) (id?106 name626)) tmp624) #f) (apply (lambda (_627 name628) (values (quote define-form) (wrap134 name628 w591 mod594) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s592 mod594)) tmp624) (syntax-violation #f "source expression failed to match any pattern" tmp604))) ($sc-dispatch tmp604 (quote (any any)))))) ($sc-dispatch tmp604 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp604 (quote (any any any))))) e589) (if (memv t603 (quote (define-syntax))) ((lambda (tmp629) ((lambda (tmp630) (if (if tmp630 (apply (lambda (_631 name632 val633) (id?106 name632)) tmp630) #f) (apply (lambda (_634 name635 val636) (values (quote define-syntax-form) name635 val636 w591 s592 mod594)) tmp630) (syntax-violation #f "source expression failed to match any pattern" tmp629))) ($sc-dispatch tmp629 (quote (any any any))))) e589) (values (quote call) #f e589 w591 s592 mod594)))))))))))))) (values (quote call) #f e589 w591 s592 mod594)))) ((syntax-object?90 e589) (syntax-type140 (syntax-object-expression91 e589) r590 (join-wraps125 w591 (syntax-object-wrap92 e589)) #f rib593 (or (syntax-object-module93 e589) mod594))) ((annotation? e589) (syntax-type140 (annotation-expression e589) r590 w591 (annotation-source e589) rib593 mod594)) ((self-evaluating? e589) (values (quote constant) #f e589 w591 s592 mod594)) (else (values (quote other) #f e589 w591 s592 mod594))))) (chi-when-list139 (lambda (e637 when-list638 w639) (let f640 ((when-list641 when-list638) (situations642 (quote ()))) (if (null? when-list641) situations642 (f640 (cdr when-list641) (cons (let ((x643 (car when-list641))) (cond ((free-id=?129 x643 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?129 x643 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?129 x643 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e637 (wrap134 x643 w639 #f))))) situations642)))))) (chi-install-global138 (lambda (name644 e645) (build-annotated79 #f (list (quote define) name644 (if (let ((v646 (module-variable (current-module) name644))) (and v646 (variable-bound? v646) (macro? (variable-ref v646)) (not (eq? (macro-type (variable-ref v646)) (quote syncase-macro))))) (build-annotated79 #f (list (build-annotated79 #f (quote make-extended-syncase-macro)) (build-annotated79 #f (list (build-annotated79 #f (quote module-ref)) (build-annotated79 #f (quote (current-module))) (build-data84 #f name644))) (build-data84 #f (quote macro)) e645)) (build-annotated79 #f (list (build-annotated79 #f (quote make-syncase-macro)) (build-data84 #f (quote macro)) e645))))))) (chi-top-sequence137 (lambda (body647 r648 w649 s650 m651 esew652 mod653) (build-sequence85 s650 (let dobody654 ((body655 body647) (r656 r648) (w657 w649) (m658 m651) (esew659 esew652) (mod660 mod653)) (if (null? body655) (quote ()) (let ((first661 (chi-top141 (car body655) r656 w657 m658 esew659 mod660))) (cons first661 (dobody654 (cdr body655) r656 w657 m658 esew659 mod660)))))))) (chi-sequence136 (lambda (body662 r663 w664 s665 mod666) (build-sequence85 s665 (let dobody667 ((body668 body662) (r669 r663) (w670 w664) (mod671 mod666)) (if (null? body668) (quote ()) (let ((first672 (chi142 (car body668) r669 w670 mod671))) (cons first672 (dobody667 (cdr body668) r669 w670 mod671)))))))) (source-wrap135 (lambda (x673 w674 s675 defmod676) (wrap134 (if s675 (make-annotation x673 s675 #f) x673) w674 defmod676))) (wrap134 (lambda (x677 w678 defmod679) (cond ((and (null? (wrap-marks109 w678)) (null? (wrap-subst110 w678))) x677) ((syntax-object?90 x677) (make-syntax-object89 (syntax-object-expression91 x677) (join-wraps125 w678 (syntax-object-wrap92 x677)) (syntax-object-module93 x677))) ((null? x677) x677) (else (make-syntax-object89 x677 w678 defmod679))))) (bound-id-member?133 (lambda (x680 list681) (and (not (null? list681)) (or (bound-id=?130 x680 (car list681)) (bound-id-member?133 x680 (cdr list681)))))) (distinct-bound-ids?132 (lambda (ids682) (let distinct?683 ((ids684 ids682)) (or (null? ids684) (and (not (bound-id-member?133 (car ids684) (cdr ids684))) (distinct?683 (cdr ids684))))))) (valid-bound-ids?131 (lambda (ids685) (and (let all-ids?686 ((ids687 ids685)) (or (null? ids687) (and (id?106 (car ids687)) (all-ids?686 (cdr ids687))))) (distinct-bound-ids?132 ids685)))) (bound-id=?130 (lambda (i688 j689) (if (and (syntax-object?90 i688) (syntax-object?90 j689)) (and (eq? (let ((e690 (syntax-object-expression91 i688))) (if (annotation? e690) (annotation-expression e690) e690)) (let ((e691 (syntax-object-expression91 j689))) (if (annotation? e691) (annotation-expression e691) e691))) (same-marks?127 (wrap-marks109 (syntax-object-wrap92 i688)) (wrap-marks109 (syntax-object-wrap92 j689)))) (eq? (let ((e692 i688)) (if (annotation? e692) (annotation-expression e692) e692)) (let ((e693 j689)) (if (annotation? e693) (annotation-expression e693) e693)))))) (free-id=?129 (lambda (i694 j695) (and (eq? (let ((x696 i694)) (let ((e697 (if (syntax-object?90 x696) (syntax-object-expression91 x696) x696))) (if (annotation? e697) (annotation-expression e697) e697))) (let ((x698 j695)) (let ((e699 (if (syntax-object?90 x698) (syntax-object-expression91 x698) x698))) (if (annotation? e699) (annotation-expression e699) e699)))) (eq? (id-var-name128 i694 (quote (()))) (id-var-name128 j695 (quote (()))))))) (id-var-name128 (lambda (id700 w701) (letrec ((search-vector-rib704 (lambda (sym710 subst711 marks712 symnames713 ribcage714) (let ((n715 (vector-length symnames713))) (let f716 ((i717 0)) (cond ((fx=73 i717 n715) (search702 sym710 (cdr subst711) marks712)) ((and (eq? (vector-ref symnames713 i717) sym710) (same-marks?127 marks712 (vector-ref (ribcage-marks116 ribcage714) i717))) (values (vector-ref (ribcage-labels117 ribcage714) i717) marks712)) (else (f716 (fx+71 i717 1)))))))) (search-list-rib703 (lambda (sym718 subst719 marks720 symnames721 ribcage722) (let f723 ((symnames724 symnames721) (i725 0)) (cond ((null? symnames724) (search702 sym718 (cdr subst719) marks720)) ((and (eq? (car symnames724) sym718) (same-marks?127 marks720 (list-ref (ribcage-marks116 ribcage722) i725))) (values (list-ref (ribcage-labels117 ribcage722) i725) marks720)) (else (f723 (cdr symnames724) (fx+71 i725 1))))))) (search702 (lambda (sym726 subst727 marks728) (if (null? subst727) (values #f marks728) (let ((fst729 (car subst727))) (if (eq? fst729 (quote shift)) (search702 sym726 (cdr subst727) (cdr marks728)) (let ((symnames730 (ribcage-symnames115 fst729))) (if (vector? symnames730) (search-vector-rib704 sym726 subst727 marks728 symnames730 fst729) (search-list-rib703 sym726 subst727 marks728 symnames730 fst729))))))))) (cond ((symbol? id700) (or (call-with-values (lambda () (search702 id700 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x732 . ignore731) x732)) id700)) ((syntax-object?90 id700) (let ((id733 (let ((e735 (syntax-object-expression91 id700))) (if (annotation? e735) (annotation-expression e735) e735))) (w1734 (syntax-object-wrap92 id700))) (let ((marks736 (join-marks126 (wrap-marks109 w701) (wrap-marks109 w1734)))) (call-with-values (lambda () (search702 id733 (wrap-subst110 w701) marks736)) (lambda (new-id737 marks738) (or new-id737 (call-with-values (lambda () (search702 id733 (wrap-subst110 w1734) marks738)) (lambda (x740 . ignore739) x740)) id733)))))) ((annotation? id700) (let ((id741 (let ((e742 id700)) (if (annotation? e742) (annotation-expression e742) e742)))) (or (call-with-values (lambda () (search702 id741 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x744 . ignore743) x744)) id741))) (else (syntax-violation (quote id-var-name) "invalid id" id700)))))) (same-marks?127 (lambda (x745 y746) (or (eq? x745 y746) (and (not (null? x745)) (not (null? y746)) (eq? (car x745) (car y746)) (same-marks?127 (cdr x745) (cdr y746)))))) (join-marks126 (lambda (m1747 m2748) (smart-append124 m1747 m2748))) (join-wraps125 (lambda (w1749 w2750) (let ((m1751 (wrap-marks109 w1749)) (s1752 (wrap-subst110 w1749))) (if (null? m1751) (if (null? s1752) w2750 (make-wrap108 (wrap-marks109 w2750) (smart-append124 s1752 (wrap-subst110 w2750)))) (make-wrap108 (smart-append124 m1751 (wrap-marks109 w2750)) (smart-append124 s1752 (wrap-subst110 w2750))))))) (smart-append124 (lambda (m1753 m2754) (if (null? m2754) m1753 (append m1753 m2754)))) (make-binding-wrap123 (lambda (ids755 labels756 w757) (if (null? ids755) w757 (make-wrap108 (wrap-marks109 w757) (cons (let ((labelvec758 (list->vector labels756))) (let ((n759 (vector-length labelvec758))) (let ((symnamevec760 (make-vector n759)) (marksvec761 (make-vector n759))) (begin (let f762 ((ids763 ids755) (i764 0)) (if (not (null? ids763)) (call-with-values (lambda () (id-sym-name&marks107 (car ids763) w757)) (lambda (symname765 marks766) (begin (vector-set! symnamevec760 i764 symname765) (vector-set! marksvec761 i764 marks766) (f762 (cdr ids763) (fx+71 i764 1))))))) (make-ribcage113 symnamevec760 marksvec761 labelvec758))))) (wrap-subst110 w757)))))) (extend-ribcage!122 (lambda (ribcage767 id768 label769) (begin (set-ribcage-symnames!118 ribcage767 (cons (let ((e770 (syntax-object-expression91 id768))) (if (annotation? e770) (annotation-expression e770) e770)) (ribcage-symnames115 ribcage767))) (set-ribcage-marks!119 ribcage767 (cons (wrap-marks109 (syntax-object-wrap92 id768)) (ribcage-marks116 ribcage767))) (set-ribcage-labels!120 ribcage767 (cons label769 (ribcage-labels117 ribcage767)))))) (anti-mark121 (lambda (w771) (make-wrap108 (cons #f (wrap-marks109 w771)) (cons (quote shift) (wrap-subst110 w771))))) (set-ribcage-labels!120 (lambda (x772 update773) (vector-set! x772 3 update773))) (set-ribcage-marks!119 (lambda (x774 update775) (vector-set! x774 2 update775))) (set-ribcage-symnames!118 (lambda (x776 update777) (vector-set! x776 1 update777))) (ribcage-labels117 (lambda (x778) (vector-ref x778 3))) (ribcage-marks116 (lambda (x779) (vector-ref x779 2))) (ribcage-symnames115 (lambda (x780) (vector-ref x780 1))) (ribcage?114 (lambda (x781) (and (vector? x781) (= (vector-length x781) 4) (eq? (vector-ref x781 0) (quote ribcage))))) (make-ribcage113 (lambda (symnames782 marks783 labels784) (vector (quote ribcage) symnames782 marks783 labels784))) (gen-labels112 (lambda (ls785) (if (null? ls785) (quote ()) (cons (gen-label111) (gen-labels112 (cdr ls785)))))) (gen-label111 (lambda () (string #\i))) (wrap-subst110 cdr) (wrap-marks109 car) (make-wrap108 cons) (id-sym-name&marks107 (lambda (x786 w787) (if (syntax-object?90 x786) (values (let ((e788 (syntax-object-expression91 x786))) (if (annotation? e788) (annotation-expression e788) e788)) (join-marks126 (wrap-marks109 w787) (wrap-marks109 (syntax-object-wrap92 x786)))) (values (let ((e789 x786)) (if (annotation? e789) (annotation-expression e789) e789)) (wrap-marks109 w787))))) (id?106 (lambda (x790) (cond ((symbol? x790) #t) ((syntax-object?90 x790) (symbol? (let ((e791 (syntax-object-expression91 x790))) (if (annotation? e791) (annotation-expression e791) e791)))) ((annotation? x790) (symbol? (annotation-expression x790))) (else #f)))) (nonsymbol-id?105 (lambda (x792) (and (syntax-object?90 x792) (symbol? (let ((e793 (syntax-object-expression91 x792))) (if (annotation? e793) (annotation-expression e793) e793)))))) (global-extend104 (lambda (type794 sym795 val796) (put-global-definition-hook77 sym795 type794 val796))) (lookup103 (lambda (x797 r798 mod799) (cond ((assq x797 r798) => cdr) ((symbol? x797) (or (get-global-definition-hook78 x797 mod799) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env102 (lambda (r800) (if (null? r800) (quote ()) (let ((a801 (car r800))) (if (eq? (cadr a801) (quote macro)) (cons a801 (macros-only-env102 (cdr r800))) (macros-only-env102 (cdr r800))))))) (extend-var-env101 (lambda (labels802 vars803 r804) (if (null? labels802) r804 (extend-var-env101 (cdr labels802) (cdr vars803) (cons (cons (car labels802) (cons (quote lexical) (car vars803))) r804))))) (extend-env100 (lambda (labels805 bindings806 r807) (if (null? labels805) r807 (extend-env100 (cdr labels805) (cdr bindings806) (cons (cons (car labels805) (car bindings806)) r807))))) (binding-value99 cdr) (binding-type98 car) (source-annotation97 (lambda (x808) (cond ((annotation? x808) (annotation-source x808)) ((syntax-object?90 x808) (source-annotation97 (syntax-object-expression91 x808))) (else #f)))) (set-syntax-object-module!96 (lambda (x809 update810) (vector-set! x809 3 update810))) (set-syntax-object-wrap!95 (lambda (x811 update812) (vector-set! x811 2 update812))) (set-syntax-object-expression!94 (lambda (x813 update814) (vector-set! x813 1 update814))) (syntax-object-module93 (lambda (x815) (vector-ref x815 3))) (syntax-object-wrap92 (lambda (x816) (vector-ref x816 2))) (syntax-object-expression91 (lambda (x817) (vector-ref x817 1))) (syntax-object?90 (lambda (x818) (and (vector? x818) (= (vector-length x818) 4) (eq? (vector-ref x818 0) (quote syntax-object))))) (make-syntax-object89 (lambda (expression819 wrap820 module821) (vector (quote syntax-object) expression819 wrap820 module821))) (build-letrec88 (lambda (src822 vars823 val-exps824 body-exp825) (if (null? vars823) (build-annotated79 src822 body-exp825) (build-annotated79 src822 (list (quote letrec) (map list vars823 val-exps824) body-exp825))))) (build-named-let87 (lambda (src826 vars827 val-exps828 body-exp829) (if (null? vars827) (build-annotated79 src826 body-exp829) (build-annotated79 src826 (list (quote let) (car vars827) (map list (cdr vars827) val-exps828) body-exp829))))) (build-let86 (lambda (src830 vars831 val-exps832 body-exp833) (if (null? vars831) (build-annotated79 src830 body-exp833) (build-annotated79 src830 (list (quote let) (map list vars831 val-exps832) body-exp833))))) (build-sequence85 (lambda (src834 exps835) (if (null? (cdr exps835)) (build-annotated79 src834 (car exps835)) (build-annotated79 src834 (cons (quote begin) exps835))))) (build-data84 (lambda (src836 exp837) (if (and (self-evaluating? exp837) (not (vector? exp837))) (build-annotated79 src836 exp837) (build-annotated79 src836 (list (quote quote) exp837))))) (build-global-assignment83 (lambda (source838 var839 exp840 mod841) (let ((ref842 (build-global-reference82 source838 var839 mod841))) (build-annotated79 source838 (list (quote set!) ref842 exp840))))) (build-global-reference82 (lambda (source843 var844 mod845) (build-annotated79 source843 (if (not mod845) var844 (let ((make-module-ref846 (let ((t849 (fluid-ref *mode*70))) (if (memv t849 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (s mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851))))) (kind847 (car mod845)) (mod848 (cdr mod845))) (let ((t853 kind847)) (if (memv t853 (quote (public))) (make-module-ref846 #f mod848 var844 #t) (if (memv t853 (quote (private))) (if (not (equal? mod848 (module-name (current-module)))) (make-module-ref846 #f mod848 var844 #f) var844) (if (memv t853 (quote (bare))) var844 (if (memv t853 (quote (hygiene))) (if (and (not (equal? mod848 (module-name (current-module)))) (module-variable (resolve-module mod848) var844)) (make-module-ref846 #f mod848 var844 #f) var844) (syntax-violation #f "bad module kind" var844 mod848))))))))))) (build-lexical-assignment81 (lambda (source854 name855 var856 exp857) (build-annotated79 source854 (list (quote set!) (build-lexical-reference80 (quote set) #f name855 var856) exp857)))) (build-lexical-reference80 (lambda (type858 source859 name860 var861) (build-annotated79 source859 (let ((t862 (fluid-ref *mode*70))) (if (memv t862 (quote (c))) ((@ (ice-9 expand-support) make-lexical) #f name860 var861) var861))))) (build-annotated79 (lambda (src863 exp864) (if (and src863 (not (annotation? exp864))) (make-annotation exp864 src863 #t) exp864))) (get-global-definition-hook78 (lambda (symbol865 module866) (begin (if (and (not module866) (current-module)) (warn "module system is booted, we should have a module" symbol865)) (let ((v867 (module-variable (if module866 (resolve-module (cdr module866)) (current-module)) symbol865))) (and v867 (variable-bound? v867) (let ((val868 (variable-ref v867))) (and (macro? val868) (syncase-macro-type val868) (cons (syncase-macro-type val868) (syncase-macro-binding val868))))))))) (put-global-definition-hook77 (lambda (symbol869 type870 val871) (let ((existing872 (let ((v873 (module-variable (current-module) symbol869))) (and v873 (variable-bound? v873) (let ((val874 (variable-ref v873))) (and (macro? val874) (not (syncase-macro-type val874)) val874)))))) (module-define! (current-module) symbol869 (if existing872 (make-extended-syncase-macro existing872 type870 val871) (make-syncase-macro type870 val871)))))) (local-eval-hook76 (lambda (x875 mod876) (primitive-eval (list noexpand69 (let ((t877 (fluid-ref *mode*70))) (if (memv t877 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x875) x875)))))) (top-level-eval-hook75 (lambda (x878 mod879) (primitive-eval (list noexpand69 (let ((t880 (fluid-ref *mode*70))) (if (memv t880 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x878) x878)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend104 (quote local-syntax) (quote letrec-syntax) #t) (global-extend104 (quote local-syntax) (quote let-syntax) #f) (global-extend104 (quote core) (quote fluid-let-syntax) (lambda (e881 r882 w883 s884 mod885) ((lambda (tmp886) ((lambda (tmp887) (if (if tmp887 (apply (lambda (_888 var889 val890 e1891 e2892) (valid-bound-ids?131 var889)) tmp887) #f) (apply (lambda (_894 var895 val896 e1897 e2898) (let ((names899 (map (lambda (x900) (id-var-name128 x900 w883)) var895))) (begin (for-each (lambda (id902 n903) (let ((t904 (binding-type98 (lookup103 n903 r882 mod885)))) (if (memv t904 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e881 (source-wrap135 id902 w883 s884 mod885))))) var895 names899) (chi-body146 (cons e1897 e2898) (source-wrap135 e881 w883 s884 mod885) (extend-env100 names899 (let ((trans-r907 (macros-only-env102 r882))) (map (lambda (x908) (cons (quote macro) (eval-local-transformer149 (chi142 x908 trans-r907 w883 mod885) mod885))) val896)) r882) w883 mod885)))) tmp887) ((lambda (_910) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap135 e881 w883 s884 mod885))) tmp886))) ($sc-dispatch tmp886 (quote (any #(each (any any)) any . each-any))))) e881))) (global-extend104 (quote core) (quote quote) (lambda (e911 r912 w913 s914 mod915) ((lambda (tmp916) ((lambda (tmp917) (if tmp917 (apply (lambda (_918 e919) (build-data84 s914 (strip153 e919 w913))) tmp917) ((lambda (_920) (syntax-violation (quote quote) "bad syntax" (source-wrap135 e911 w913 s914 mod915))) tmp916))) ($sc-dispatch tmp916 (quote (any any))))) e911))) (global-extend104 (quote core) (quote syntax) (letrec ((regen928 (lambda (x929) (let ((t930 (car x929))) (if (memv t930 (quote (ref))) (build-lexical-reference80 (quote value) #f (cadr x929) (cadr x929)) (if (memv t930 (quote (primitive))) (build-annotated79 #f (cadr x929)) (if (memv t930 (quote (quote))) (build-data84 #f (cadr x929)) (if (memv t930 (quote (lambda))) (build-annotated79 #f (list (quote lambda) (cadr x929) (regen928 (caddr x929)))) (if (memv t930 (quote (map))) (let ((ls931 (map regen928 (cdr x929)))) (build-annotated79 #f (cons (if (fx=73 (length ls931) 2) (build-annotated79 #f (quote map)) (build-annotated79 #f (quote map))) ls931))) (build-annotated79 #f (cons (build-annotated79 #f (car x929)) (map regen928 (cdr x929)))))))))))) (gen-vector927 (lambda (x932) (cond ((eq? (car x932) (quote list)) (cons (quote vector) (cdr x932))) ((eq? (car x932) (quote quote)) (list (quote quote) (list->vector (cadr x932)))) (else (list (quote list->vector) x932))))) (gen-append926 (lambda (x933 y934) (if (equal? y934 (quote (quote ()))) x933 (list (quote append) x933 y934)))) (gen-cons925 (lambda (x935 y936) (let ((t937 (car y936))) (if (memv t937 (quote (quote))) (if (eq? (car x935) (quote quote)) (list (quote quote) (cons (cadr x935) (cadr y936))) (if (eq? (cadr y936) (quote ())) (list (quote list) x935) (list (quote cons) x935 y936))) (if (memv t937 (quote (list))) (cons (quote list) (cons x935 (cdr y936))) (list (quote cons) x935 y936)))))) (gen-map924 (lambda (e938 map-env939) (let ((formals940 (map cdr map-env939)) (actuals941 (map (lambda (x942) (list (quote ref) (car x942))) map-env939))) (cond ((eq? (car e938) (quote ref)) (car actuals941)) ((and-map (lambda (x943) (and (eq? (car x943) (quote ref)) (memq (cadr x943) formals940))) (cdr e938)) (cons (quote map) (cons (list (quote primitive) (car e938)) (map (let ((r944 (map cons formals940 actuals941))) (lambda (x945) (cdr (assq (cadr x945) r944)))) (cdr e938))))) (else (cons (quote map) (cons (list (quote lambda) formals940 e938) actuals941))))))) (gen-mappend923 (lambda (e946 map-env947) (list (quote apply) (quote (primitive append)) (gen-map924 e946 map-env947)))) (gen-ref922 (lambda (src948 var949 level950 maps951) (if (fx=73 level950 0) (values var949 maps951) (if (null? maps951) (syntax-violation (quote syntax) "missing ellipsis" src948) (call-with-values (lambda () (gen-ref922 src948 var949 (fx-72 level950 1) (cdr maps951))) (lambda (outer-var952 outer-maps953) (let ((b954 (assq outer-var952 (car maps951)))) (if b954 (values (cdr b954) maps951) (let ((inner-var955 (gen-var154 (quote tmp)))) (values inner-var955 (cons (cons (cons outer-var952 inner-var955) (car maps951)) outer-maps953))))))))))) (gen-syntax921 (lambda (src956 e957 r958 maps959 ellipsis?960 mod961) (if (id?106 e957) (let ((label962 (id-var-name128 e957 (quote (()))))) (let ((b963 (lookup103 label962 r958 mod961))) (if (eq? (binding-type98 b963) (quote syntax)) (call-with-values (lambda () (let ((var.lev964 (binding-value99 b963))) (gen-ref922 src956 (car var.lev964) (cdr var.lev964) maps959))) (lambda (var965 maps966) (values (list (quote ref) var965) maps966))) (if (ellipsis?960 e957) (syntax-violation (quote syntax) "misplaced ellipsis" src956) (values (list (quote quote) e957) maps959))))) ((lambda (tmp967) ((lambda (tmp968) (if (if tmp968 (apply (lambda (dots969 e970) (ellipsis?960 dots969)) tmp968) #f) (apply (lambda (dots971 e972) (gen-syntax921 src956 e972 r958 maps959 (lambda (x973) #f) mod961)) tmp968) ((lambda (tmp974) (if (if tmp974 (apply (lambda (x975 dots976 y977) (ellipsis?960 dots976)) tmp974) #f) (apply (lambda (x978 dots979 y980) (let f981 ((y982 y980) (k983 (lambda (maps984) (call-with-values (lambda () (gen-syntax921 src956 x978 r958 (cons (quote ()) maps984) ellipsis?960 mod961)) (lambda (x985 maps986) (if (null? (car maps986)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-map924 x985 (car maps986)) (cdr maps986)))))))) ((lambda (tmp987) ((lambda (tmp988) (if (if tmp988 (apply (lambda (dots989 y990) (ellipsis?960 dots989)) tmp988) #f) (apply (lambda (dots991 y992) (f981 y992 (lambda (maps993) (call-with-values (lambda () (k983 (cons (quote ()) maps993))) (lambda (x994 maps995) (if (null? (car maps995)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-mappend923 x994 (car maps995)) (cdr maps995)))))))) tmp988) ((lambda (_996) (call-with-values (lambda () (gen-syntax921 src956 y982 r958 maps959 ellipsis?960 mod961)) (lambda (y997 maps998) (call-with-values (lambda () (k983 maps998)) (lambda (x999 maps1000) (values (gen-append926 x999 y997) maps1000)))))) tmp987))) ($sc-dispatch tmp987 (quote (any . any))))) y982))) tmp974) ((lambda (tmp1001) (if tmp1001 (apply (lambda (x1002 y1003) (call-with-values (lambda () (gen-syntax921 src956 x1002 r958 maps959 ellipsis?960 mod961)) (lambda (x1004 maps1005) (call-with-values (lambda () (gen-syntax921 src956 y1003 r958 maps1005 ellipsis?960 mod961)) (lambda (y1006 maps1007) (values (gen-cons925 x1004 y1006) maps1007)))))) tmp1001) ((lambda (tmp1008) (if tmp1008 (apply (lambda (e11009 e21010) (call-with-values (lambda () (gen-syntax921 src956 (cons e11009 e21010) r958 maps959 ellipsis?960 mod961)) (lambda (e1012 maps1013) (values (gen-vector927 e1012) maps1013)))) tmp1008) ((lambda (_1014) (values (list (quote quote) e957) maps959)) tmp967))) ($sc-dispatch tmp967 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp967 (quote (any . any)))))) ($sc-dispatch tmp967 (quote (any any . any)))))) ($sc-dispatch tmp967 (quote (any any))))) e957))))) (lambda (e1015 r1016 w1017 s1018 mod1019) (let ((e1020 (source-wrap135 e1015 w1017 s1018 mod1019))) ((lambda (tmp1021) ((lambda (tmp1022) (if tmp1022 (apply (lambda (_1023 x1024) (call-with-values (lambda () (gen-syntax921 e1020 x1024 r1016 (quote ()) ellipsis?151 mod1019)) (lambda (e1025 maps1026) (regen928 e1025)))) tmp1022) ((lambda (_1027) (syntax-violation (quote syntax) "bad `syntax' form" e1020)) tmp1021))) ($sc-dispatch tmp1021 (quote (any any))))) e1020))))) (global-extend104 (quote core) (quote lambda) (lambda (e1028 r1029 w1030 s1031 mod1032) ((lambda (tmp1033) ((lambda (tmp1034) (if tmp1034 (apply (lambda (_1035 c1036) (chi-lambda-clause147 (source-wrap135 e1028 w1030 s1031 mod1032) #f c1036 r1029 w1030 mod1032 (lambda (vars1037 docstring1038 body1039) (build-annotated79 s1031 (cons (quote lambda) (cons vars1037 (append (if docstring1038 (list docstring1038) (quote ())) (list body1039)))))))) tmp1034) (syntax-violation #f "source expression failed to match any pattern" tmp1033))) ($sc-dispatch tmp1033 (quote (any . any))))) e1028))) (global-extend104 (quote core) (quote let) (letrec ((chi-let1040 (lambda (e1041 r1042 w1043 s1044 mod1045 constructor1046 ids1047 vals1048 exps1049) (if (not (valid-bound-ids?131 ids1047)) (syntax-violation (quote let) "duplicate bound variable" e1041) (let ((labels1050 (gen-labels112 ids1047)) (new-vars1051 (map gen-var154 ids1047))) (let ((nw1052 (make-binding-wrap123 ids1047 labels1050 w1043)) (nr1053 (extend-var-env101 labels1050 new-vars1051 r1042))) (constructor1046 s1044 new-vars1051 (map (lambda (x1054) (chi142 x1054 r1042 w1043 mod1045)) vals1048) (chi-body146 exps1049 (source-wrap135 e1041 nw1052 s1044 mod1045) nr1053 nw1052 mod1045)))))))) (lambda (e1055 r1056 w1057 s1058 mod1059) ((lambda (tmp1060) ((lambda (tmp1061) (if tmp1061 (apply (lambda (_1062 id1063 val1064 e11065 e21066) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-let86 id1063 val1064 (cons e11065 e21066))) tmp1061) ((lambda (tmp1070) (if (if tmp1070 (apply (lambda (_1071 f1072 id1073 val1074 e11075 e21076) (id?106 f1072)) tmp1070) #f) (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-named-let87 (cons f1078 id1079) val1080 (cons e11081 e21082))) tmp1070) ((lambda (_1086) (syntax-violation (quote let) "bad let" (source-wrap135 e1055 w1057 s1058 mod1059))) tmp1060))) ($sc-dispatch tmp1060 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1060 (quote (any #(each (any any)) any . each-any))))) e1055)))) (global-extend104 (quote core) (quote letrec) (lambda (e1087 r1088 w1089 s1090 mod1091) ((lambda (tmp1092) ((lambda (tmp1093) (if tmp1093 (apply (lambda (_1094 id1095 val1096 e11097 e21098) (let ((ids1099 id1095)) (if (not (valid-bound-ids?131 ids1099)) (syntax-violation (quote letrec) "duplicate bound variable" e1087) (let ((labels1101 (gen-labels112 ids1099)) (new-vars1102 (map gen-var154 ids1099))) (let ((w1103 (make-binding-wrap123 ids1099 labels1101 w1089)) (r1104 (extend-var-env101 labels1101 new-vars1102 r1088))) (build-letrec88 s1090 new-vars1102 (map (lambda (x1105) (chi142 x1105 r1104 w1103 mod1091)) val1096) (chi-body146 (cons e11097 e21098) (source-wrap135 e1087 w1103 s1090 mod1091) r1104 w1103 mod1091))))))) tmp1093) ((lambda (_1108) (syntax-violation (quote letrec) "bad letrec" (source-wrap135 e1087 w1089 s1090 mod1091))) tmp1092))) ($sc-dispatch tmp1092 (quote (any #(each (any any)) any . each-any))))) e1087))) (global-extend104 (quote core) (quote set!) (lambda (e1109 r1110 w1111 s1112 mod1113) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (_1116 id1117 val1118) (id?106 id1117)) tmp1115) #f) (apply (lambda (_1119 id1120 val1121) (let ((val1122 (chi142 val1121 r1110 w1111 mod1113)) (n1123 (id-var-name128 id1120 w1111))) (let ((b1124 (lookup103 n1123 r1110 mod1113))) (let ((t1125 (binding-type98 b1124))) (if (memv t1125 (quote (lexical))) (build-lexical-assignment81 s1112 (syntax->datum id1120) (binding-value99 b1124) val1122) (if (memv t1125 (quote (global))) (build-global-assignment83 s1112 n1123 val1122 mod1113) (if (memv t1125 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap134 id1120 w1111 mod1113)) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))))))))) tmp1115) ((lambda (tmp1126) (if tmp1126 (apply (lambda (_1127 head1128 tail1129 val1130) (call-with-values (lambda () (syntax-type140 head1128 r1110 (quote (())) #f #f mod1113)) (lambda (type1131 value1132 ee1133 ww1134 ss1135 modmod1136) (let ((t1137 type1131)) (if (memv t1137 (quote (module-ref))) (let ((val1138 (chi142 val1130 r1110 w1111 mod1113))) (call-with-values (lambda () (value1132 (cons head1128 tail1129))) (lambda (id1140 mod1141) (build-global-assignment83 s1112 id1140 val1138 mod1141)))) (build-annotated79 s1112 (cons (chi142 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1128) r1110 w1111 mod1113) (map (lambda (e1142) (chi142 e1142 r1110 w1111 mod1113)) (append tail1129 (list val1130)))))))))) tmp1126) ((lambda (_1144) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))) tmp1114))) ($sc-dispatch tmp1114 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1114 (quote (any any any))))) e1109))) (global-extend104 (quote module-ref) (quote @) (lambda (e1145) ((lambda (tmp1146) ((lambda (tmp1147) (if (if tmp1147 (apply (lambda (_1148 mod1149 id1150) (and (and-map id?106 mod1149) (id?106 id1150))) tmp1147) #f) (apply (lambda (_1152 mod1153 id1154) (values (syntax->datum id1154) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1153)))) tmp1147) (syntax-violation #f "source expression failed to match any pattern" tmp1146))) ($sc-dispatch tmp1146 (quote (any each-any any))))) e1145))) (global-extend104 (quote module-ref) (quote @@) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (and (and-map id?106 mod1160) (id?106 id1161))) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend104 (quote begin) (quote begin) (quote ())) (global-extend104 (quote define) (quote define) (quote ())) (global-extend104 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend104 (quote eval-when) (quote eval-when) (quote ())) (global-extend104 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1170 (lambda (x1171 keys1172 clauses1173 r1174 mod1175) (if (null? clauses1173) (build-annotated79 #f (list (build-annotated79 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1171)) ((lambda (tmp1176) ((lambda (tmp1177) (if tmp1177 (apply (lambda (pat1178 exp1179) (if (and (id?106 pat1178) (and-map (lambda (x1180) (not (free-id=?129 pat1178 x1180))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1172))) (let ((labels1181 (list (gen-label111))) (var1182 (gen-var154 pat1178))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list var1182) (chi142 exp1179 (extend-env100 labels1181 (list (cons (quote syntax) (cons var1182 0))) r1174) (make-binding-wrap123 (list pat1178) labels1181 (quote (()))) mod1175))) x1171))) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1178 #t exp1179 mod1175))) tmp1177) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 fender1185 exp1186) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1184 fender1185 exp1186 mod1175)) tmp1183) ((lambda (_1187) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1173))) tmp1176))) ($sc-dispatch tmp1176 (quote (any any any)))))) ($sc-dispatch tmp1176 (quote (any any))))) (car clauses1173))))) (gen-clause1169 (lambda (x1188 keys1189 clauses1190 r1191 pat1192 fender1193 exp1194 mod1195) (call-with-values (lambda () (convert-pattern1167 pat1192 keys1189)) (lambda (p1196 pvars1197) (cond ((not (distinct-bound-ids?132 (map car pvars1197))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1192)) ((not (and-map (lambda (x1198) (not (ellipsis?151 (car x1198)))) pvars1197)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1192)) (else (let ((y1199 (gen-var154 (quote tmp)))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list y1199) (let ((y1200 (build-lexical-reference80 (quote value) #f (quote tmp) y1199))) (build-annotated79 #f (list (quote if) ((lambda (tmp1201) ((lambda (tmp1202) (if tmp1202 (apply (lambda () y1200) tmp1202) ((lambda (_1203) (build-annotated79 #f (list (quote if) y1200 (build-dispatch-call1168 pvars1197 fender1193 y1200 r1191 mod1195) (build-data84 #f #f)))) tmp1201))) ($sc-dispatch tmp1201 (quote #(atom #t))))) fender1193) (build-dispatch-call1168 pvars1197 exp1194 y1200 r1191 mod1195) (gen-syntax-case1170 x1188 keys1189 clauses1190 r1191 mod1195)))))) (if (eq? p1196 (quote any)) (build-annotated79 #f (list (build-annotated79 #f (quote list)) x1188)) (build-annotated79 #f (list (build-annotated79 #f (quote $sc-dispatch)) x1188 (build-data84 #f p1196))))))))))))) (build-dispatch-call1168 (lambda (pvars1204 exp1205 y1206 r1207 mod1208) (let ((ids1209 (map car pvars1204)) (levels1210 (map cdr pvars1204))) (let ((labels1211 (gen-labels112 ids1209)) (new-vars1212 (map gen-var154 ids1209))) (build-annotated79 #f (list (build-annotated79 #f (quote apply)) (build-annotated79 #f (list (quote lambda) new-vars1212 (chi142 exp1205 (extend-env100 labels1211 (map (lambda (var1213 level1214) (cons (quote syntax) (cons var1213 level1214))) new-vars1212 (map cdr pvars1204)) r1207) (make-binding-wrap123 ids1209 labels1211 (quote (()))) mod1208))) y1206)))))) (convert-pattern1167 (lambda (pattern1215 keys1216) (let cvt1217 ((p1218 pattern1215) (n1219 0) (ids1220 (quote ()))) (if (id?106 p1218) (if (bound-id-member?133 p1218 keys1216) (values (vector (quote free-id) p1218) ids1220) (values (quote any) (cons (cons p1218 n1219) ids1220))) ((lambda (tmp1221) ((lambda (tmp1222) (if (if tmp1222 (apply (lambda (x1223 dots1224) (ellipsis?151 dots1224)) tmp1222) #f) (apply (lambda (x1225 dots1226) (call-with-values (lambda () (cvt1217 x1225 (fx+71 n1219 1) ids1220)) (lambda (p1227 ids1228) (values (if (eq? p1227 (quote any)) (quote each-any) (vector (quote each) p1227)) ids1228)))) tmp1222) ((lambda (tmp1229) (if tmp1229 (apply (lambda (x1230 y1231) (call-with-values (lambda () (cvt1217 y1231 n1219 ids1220)) (lambda (y1232 ids1233) (call-with-values (lambda () (cvt1217 x1230 n1219 ids1233)) (lambda (x1234 ids1235) (values (cons x1234 y1232) ids1235)))))) tmp1229) ((lambda (tmp1236) (if tmp1236 (apply (lambda () (values (quote ()) ids1220)) tmp1236) ((lambda (tmp1237) (if tmp1237 (apply (lambda (x1238) (call-with-values (lambda () (cvt1217 x1238 n1219 ids1220)) (lambda (p1240 ids1241) (values (vector (quote vector) p1240) ids1241)))) tmp1237) ((lambda (x1242) (values (vector (quote atom) (strip153 p1218 (quote (())))) ids1220)) tmp1221))) ($sc-dispatch tmp1221 (quote #(vector each-any)))))) ($sc-dispatch tmp1221 (quote ()))))) ($sc-dispatch tmp1221 (quote (any . any)))))) ($sc-dispatch tmp1221 (quote (any any))))) p1218)))))) (lambda (e1243 r1244 w1245 s1246 mod1247) (let ((e1248 (source-wrap135 e1243 w1245 s1246 mod1247))) ((lambda (tmp1249) ((lambda (tmp1250) (if tmp1250 (apply (lambda (_1251 val1252 key1253 m1254) (if (and-map (lambda (x1255) (and (id?106 x1255) (not (ellipsis?151 x1255)))) key1253) (let ((x1257 (gen-var154 (quote tmp)))) (build-annotated79 s1246 (list (build-annotated79 #f (list (quote lambda) (list x1257) (gen-syntax-case1170 (build-lexical-reference80 (quote value) #f (quote tmp) x1257) key1253 m1254 r1244 mod1247))) (chi142 val1252 r1244 (quote (())) mod1247)))) (syntax-violation (quote syntax-case) "invalid literals list" e1248))) tmp1250) (syntax-violation #f "source expression failed to match any pattern" tmp1249))) ($sc-dispatch tmp1249 (quote (any any each-any . each-any))))) e1248))))) (set! sc-expand (lambda (x1261 . rest1260) (if (and (pair? x1261) (equal? (car x1261) noexpand69)) (cadr x1261) (let ((m1262 (if (null? rest1260) (quote e) (car rest1260))) (esew1263 (if (or (null? rest1260) (null? (cdr rest1260))) (quote (eval)) (cadr rest1260)))) (with-fluid* *mode*70 m1262 (lambda () (chi-top141 x1261 (quote ()) (quote ((top))) m1262 esew1263 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1264) (nonsymbol-id?105 x1264))) (set! datum->syntax (lambda (id1265 datum1266) (make-syntax-object89 datum1266 (syntax-object-wrap92 id1265) #f))) (set! syntax->datum (lambda (x1267) (strip153 x1267 (quote (()))))) (set! generate-temporaries (lambda (ls1268) (begin (let ((x1269 ls1268)) (if (not (list? x1269)) (syntax-violation (quote generate-temporaries) "invalid argument" x1269))) (map (lambda (x1270) (wrap134 (gensym) (quote ((top))) #f)) ls1268)))) (set! free-identifier=? (lambda (x1271 y1272) (begin (let ((x1273 x1271)) (if (not (nonsymbol-id?105 x1273)) (syntax-violation (quote free-identifier=?) "invalid argument" x1273))) (let ((x1274 y1272)) (if (not (nonsymbol-id?105 x1274)) (syntax-violation (quote free-identifier=?) "invalid argument" x1274))) (free-id=?129 x1271 y1272)))) (set! bound-identifier=? (lambda (x1275 y1276) (begin (let ((x1277 x1275)) (if (not (nonsymbol-id?105 x1277)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1277))) (let ((x1278 y1276)) (if (not (nonsymbol-id?105 x1278)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1278))) (bound-id=?130 x1275 y1276)))) (set! syntax-violation (lambda (who1282 message1281 form1280 . subform1279) (begin (let ((x1283 who1282)) (if (not ((lambda (x1284) (or (not x1284) (string? x1284) (symbol? x1284))) x1283)) (syntax-violation (quote syntax-violation) "invalid argument" x1283))) (let ((x1285 message1281)) (if (not (string? x1285)) (syntax-violation (quote syntax-violation) "invalid argument" x1285))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1282 "~a: " "") "~a " (if (null? subform1279) "in ~a" "in subform `~s' of `~s'")) (let ((tail1286 (cons message1281 (map (lambda (x1287) (strip153 x1287 (quote (())))) (append subform1279 (list form1280)))))) (if who1282 (cons who1282 tail1286) tail1286)) #f)))) (letrec ((match1292 (lambda (e1293 p1294 w1295 r1296 mod1297) (cond ((not r1296) #f) ((eq? p1294 (quote any)) (cons (wrap134 e1293 w1295 mod1297) r1296)) ((syntax-object?90 e1293) (match*1291 (let ((e1298 (syntax-object-expression91 e1293))) (if (annotation? e1298) (annotation-expression e1298) e1298)) p1294 (join-wraps125 w1295 (syntax-object-wrap92 e1293)) r1296 (syntax-object-module93 e1293))) (else (match*1291 (let ((e1299 e1293)) (if (annotation? e1299) (annotation-expression e1299) e1299)) p1294 w1295 r1296 mod1297))))) (match*1291 (lambda (e1300 p1301 w1302 r1303 mod1304) (cond ((null? p1301) (and (null? e1300) r1303)) ((pair? p1301) (and (pair? e1300) (match1292 (car e1300) (car p1301) w1302 (match1292 (cdr e1300) (cdr p1301) w1302 r1303 mod1304) mod1304))) ((eq? p1301 (quote each-any)) (let ((l1305 (match-each-any1289 e1300 w1302 mod1304))) (and l1305 (cons l1305 r1303)))) (else (let ((t1306 (vector-ref p1301 0))) (if (memv t1306 (quote (each))) (if (null? e1300) (match-empty1290 (vector-ref p1301 1) r1303) (let ((l1307 (match-each1288 e1300 (vector-ref p1301 1) w1302 mod1304))) (and l1307 (let collect1308 ((l1309 l1307)) (if (null? (car l1309)) r1303 (cons (map car l1309) (collect1308 (map cdr l1309)))))))) (if (memv t1306 (quote (free-id))) (and (id?106 e1300) (free-id=?129 (wrap134 e1300 w1302 mod1304) (vector-ref p1301 1)) r1303) (if (memv t1306 (quote (atom))) (and (equal? (vector-ref p1301 1) (strip153 e1300 w1302)) r1303) (if (memv t1306 (quote (vector))) (and (vector? e1300) (match1292 (vector->list e1300) (vector-ref p1301 1) w1302 r1303 mod1304))))))))))) (match-empty1290 (lambda (p1310 r1311) (cond ((null? p1310) r1311) ((eq? p1310 (quote any)) (cons (quote ()) r1311)) ((pair? p1310) (match-empty1290 (car p1310) (match-empty1290 (cdr p1310) r1311))) ((eq? p1310 (quote each-any)) (cons (quote ()) r1311)) (else (let ((t1312 (vector-ref p1310 0))) (if (memv t1312 (quote (each))) (match-empty1290 (vector-ref p1310 1) r1311) (if (memv t1312 (quote (free-id atom))) r1311 (if (memv t1312 (quote (vector))) (match-empty1290 (vector-ref p1310 1) r1311))))))))) (match-each-any1289 (lambda (e1313 w1314 mod1315) (cond ((annotation? e1313) (match-each-any1289 (annotation-expression e1313) w1314 mod1315)) ((pair? e1313) (let ((l1316 (match-each-any1289 (cdr e1313) w1314 mod1315))) (and l1316 (cons (wrap134 (car e1313) w1314 mod1315) l1316)))) ((null? e1313) (quote ())) ((syntax-object?90 e1313) (match-each-any1289 (syntax-object-expression91 e1313) (join-wraps125 w1314 (syntax-object-wrap92 e1313)) mod1315)) (else #f)))) (match-each1288 (lambda (e1317 p1318 w1319 mod1320) (cond ((annotation? e1317) (match-each1288 (annotation-expression e1317) p1318 w1319 mod1320)) ((pair? e1317) (let ((first1321 (match1292 (car e1317) p1318 w1319 (quote ()) mod1320))) (and first1321 (let ((rest1322 (match-each1288 (cdr e1317) p1318 w1319 mod1320))) (and rest1322 (cons first1321 rest1322)))))) ((null? e1317) (quote ())) ((syntax-object?90 e1317) (match-each1288 (syntax-object-expression91 e1317) p1318 (join-wraps125 w1319 (syntax-object-wrap92 e1317)) (syntax-object-module93 e1317))) (else #f))))) (set! $sc-dispatch (lambda (e1323 p1324) (cond ((eq? p1324 (quote any)) (list e1323)) ((syntax-object?90 e1323) (match*1291 (let ((e1325 (syntax-object-expression91 e1323))) (if (annotation? e1325) (annotation-expression e1325) e1325)) p1324 (syntax-object-wrap92 e1323) (quote ()) (syntax-object-module93 e1323))) (else (match*1291 (let ((e1326 e1323)) (if (annotation? e1326) (annotation-expression e1326) e1326)) p1324 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1327) ((lambda (tmp1328) ((lambda (tmp1329) (if tmp1329 (apply (lambda (_1330 e11331 e21332) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11331 e21332))) tmp1329) ((lambda (tmp1334) (if tmp1334 (apply (lambda (_1335 out1336 in1337 e11338 e21339) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1337 (quote ()) (list out1336 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11338 e21339))))) tmp1334) ((lambda (tmp1341) (if tmp1341 (apply (lambda (_1342 out1343 in1344 e11345 e21346) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1344) (quote ()) (list out1343 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11345 e21346))))) tmp1341) (syntax-violation #f "source expression failed to match any pattern" tmp1328))) ($sc-dispatch tmp1328 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any () any . each-any))))) x1327)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1350) ((lambda (tmp1351) ((lambda (tmp1352) (if tmp1352 (apply (lambda (_1353 k1354 keyword1355 pattern1356 template1357) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1354 (map (lambda (tmp1360 tmp1359) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1359) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1360))) template1357 pattern1356)))))) tmp1352) (syntax-violation #f "source expression failed to match any pattern" tmp1351))) ($sc-dispatch tmp1351 (quote (any each-any . #(each ((any . any) any))))))) x1350)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1361) ((lambda (tmp1362) ((lambda (tmp1363) (if (if tmp1363 (apply (lambda (let*1364 x1365 v1366 e11367 e21368) (and-map identifier? x1365)) tmp1363) #f) (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (let f1375 ((bindings1376 (map list x1371 v1372))) (if (null? bindings1376) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11373 e21374))) ((lambda (tmp1380) ((lambda (tmp1381) (if tmp1381 (apply (lambda (body1382 binding1383) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1383) body1382)) tmp1381) (syntax-violation #f "source expression failed to match any pattern" tmp1380))) ($sc-dispatch tmp1380 (quote (any any))))) (list (f1375 (cdr bindings1376)) (car bindings1376)))))) tmp1363) (syntax-violation #f "source expression failed to match any pattern" tmp1362))) ($sc-dispatch tmp1362 (quote (any #(each (any any)) any . each-any))))) x1361)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1384) ((lambda (tmp1385) ((lambda (tmp1386) (if tmp1386 (apply (lambda (_1387 var1388 init1389 step1390 e01391 e11392 c1393) ((lambda (tmp1394) ((lambda (tmp1395) (if tmp1395 (apply (lambda (step1396) ((lambda (tmp1397) ((lambda (tmp1398) (if tmp1398 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1388 init1389) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01391) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1393 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1396))))))) tmp1398) ((lambda (tmp1403) (if tmp1403 (apply (lambda (e11404 e21405) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1388 init1389) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01391 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11404 e21405)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1393 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1396))))))) tmp1403) (syntax-violation #f "source expression failed to match any pattern" tmp1397))) ($sc-dispatch tmp1397 (quote (any . each-any)))))) ($sc-dispatch tmp1397 (quote ())))) e11392)) tmp1395) (syntax-violation #f "source expression failed to match any pattern" tmp1394))) ($sc-dispatch tmp1394 (quote each-any)))) (map (lambda (v1412 s1413) ((lambda (tmp1414) ((lambda (tmp1415) (if tmp1415 (apply (lambda () v1412) tmp1415) ((lambda (tmp1416) (if tmp1416 (apply (lambda (e1417) e1417) tmp1416) ((lambda (_1418) (syntax-violation (quote do) "bad step expression" orig-x1384 s1413)) tmp1414))) ($sc-dispatch tmp1414 (quote (any)))))) ($sc-dispatch tmp1414 (quote ())))) s1413)) var1388 step1390))) tmp1386) (syntax-violation #f "source expression failed to match any pattern" tmp1385))) ($sc-dispatch tmp1385 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1384)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1421 (lambda (x1425 y1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (x1429 y1430) ((lambda (tmp1431) ((lambda (tmp1432) (if tmp1432 (apply (lambda (dy1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (dx1436) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1436 dy1433))) tmp1435) ((lambda (_1437) (if (null? dy1433) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1429) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1429 y1430))) tmp1434))) ($sc-dispatch tmp1434 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1429)) tmp1432) ((lambda (tmp1438) (if tmp1438 (apply (lambda (stuff1439) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1429 stuff1439))) tmp1438) ((lambda (else1440) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1429 y1430)) tmp1431))) ($sc-dispatch tmp1431 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1431 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1430)) tmp1428) (syntax-violation #f "source expression failed to match any pattern" tmp1427))) ($sc-dispatch tmp1427 (quote (any any))))) (list x1425 y1426)))) (quasiappend1422 (lambda (x1441 y1442) ((lambda (tmp1443) ((lambda (tmp1444) (if tmp1444 (apply (lambda (x1445 y1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda () x1445) tmp1448) ((lambda (_1449) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1445 y1446)) tmp1447))) ($sc-dispatch tmp1447 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1446)) tmp1444) (syntax-violation #f "source expression failed to match any pattern" tmp1443))) ($sc-dispatch tmp1443 (quote (any any))))) (list x1441 y1442)))) (quasivector1423 (lambda (x1450) ((lambda (tmp1451) ((lambda (x1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda (x1455) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1455))) tmp1454) ((lambda (tmp1457) (if tmp1457 (apply (lambda (x1458) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1458)) tmp1457) ((lambda (_1460) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1452)) tmp1453))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1452)) tmp1451)) x1450))) (quasi1424 (lambda (p1461 lev1462) ((lambda (tmp1463) ((lambda (tmp1464) (if tmp1464 (apply (lambda (p1465) (if (= lev1462 0) p1465 (quasicons1421 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1424 (list p1465) (- lev1462 1))))) tmp1464) ((lambda (tmp1466) (if tmp1466 (apply (lambda (p1467 q1468) (if (= lev1462 0) (quasiappend1422 p1467 (quasi1424 q1468 lev1462)) (quasicons1421 (quasicons1421 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1424 (list p1467) (- lev1462 1))) (quasi1424 q1468 lev1462)))) tmp1466) ((lambda (tmp1469) (if tmp1469 (apply (lambda (p1470) (quasicons1421 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1424 (list p1470) (+ lev1462 1)))) tmp1469) ((lambda (tmp1471) (if tmp1471 (apply (lambda (p1472 q1473) (quasicons1421 (quasi1424 p1472 lev1462) (quasi1424 q1473 lev1462))) tmp1471) ((lambda (tmp1474) (if tmp1474 (apply (lambda (x1475) (quasivector1423 (quasi1424 x1475 lev1462))) tmp1474) ((lambda (p1477) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1477)) tmp1463))) ($sc-dispatch tmp1463 (quote #(vector each-any)))))) ($sc-dispatch tmp1463 (quote (any . any)))))) ($sc-dispatch tmp1463 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1463 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1463 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1461)))) (lambda (x1478) ((lambda (tmp1479) ((lambda (tmp1480) (if tmp1480 (apply (lambda (_1481 e1482) (quasi1424 e1482 0)) tmp1480) (syntax-violation #f "source expression failed to match any pattern" tmp1479))) ($sc-dispatch tmp1479 (quote (any any))))) x1478))))) -(define include (make-syncase-macro (quote macro) (lambda (x1483) (letrec ((read-file1484 (lambda (fn1485 k1486) (let ((p1487 (open-input-file fn1485))) (let f1488 ((x1489 (read p1487))) (if (eof-object? x1489) (begin (close-input-port p1487) (quote ())) (cons (datum->syntax k1486 x1489) (f1488 (read p1487))))))))) ((lambda (tmp1490) ((lambda (tmp1491) (if tmp1491 (apply (lambda (k1492 filename1493) (let ((fn1494 (syntax->datum filename1493))) ((lambda (tmp1495) ((lambda (tmp1496) (if tmp1496 (apply (lambda (exp1497) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1497)) tmp1496) (syntax-violation #f "source expression failed to match any pattern" tmp1495))) ($sc-dispatch tmp1495 (quote each-any)))) (read-file1484 fn1494 k1492)))) tmp1491) (syntax-violation #f "source expression failed to match any pattern" tmp1490))) ($sc-dispatch tmp1490 (quote (any any))))) x1483))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1499) ((lambda (tmp1500) ((lambda (tmp1501) (if tmp1501 (apply (lambda (_1502 e1503) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1499)) tmp1501) (syntax-violation #f "source expression failed to match any pattern" tmp1500))) ($sc-dispatch tmp1500 (quote (any any))))) x1499)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 e1508) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1504)) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any any))))) x1504)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1509) ((lambda (tmp1510) ((lambda (tmp1511) (if tmp1511 (apply (lambda (_1512 e1513 m11514 m21515) ((lambda (tmp1516) ((lambda (body1517) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1513)) body1517)) tmp1516)) (let f1518 ((clause1519 m11514) (clauses1520 m21515)) (if (null? clauses1520) ((lambda (tmp1522) ((lambda (tmp1523) (if tmp1523 (apply (lambda (e11524 e21525) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11524 e21525))) tmp1523) ((lambda (tmp1527) (if tmp1527 (apply (lambda (k1528 e11529 e21530) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1528)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11529 e21530)))) tmp1527) ((lambda (_1533) (syntax-violation (quote case) "bad clause" x1509 clause1519)) tmp1522))) ($sc-dispatch tmp1522 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1522 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1519) ((lambda (tmp1534) ((lambda (rest1535) ((lambda (tmp1536) ((lambda (tmp1537) (if tmp1537 (apply (lambda (k1538 e11539 e21540) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1538)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11539 e21540)) rest1535)) tmp1537) ((lambda (_1543) (syntax-violation (quote case) "bad clause" x1509 clause1519)) tmp1536))) ($sc-dispatch tmp1536 (quote (each-any any . each-any))))) clause1519)) tmp1534)) (f1518 (car clauses1520) (cdr clauses1520))))))) tmp1511) (syntax-violation #f "source expression failed to match any pattern" tmp1510))) ($sc-dispatch tmp1510 (quote (any any any . each-any))))) x1509)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1544) ((lambda (tmp1545) ((lambda (tmp1546) (if tmp1546 (apply (lambda (_1547 e1548) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1548)) (list (cons _1547 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1548 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1546) (syntax-violation #f "source expression failed to match any pattern" tmp1545))) ($sc-dispatch tmp1545 (quote (any any))))) x1544)))) +(letrec ((and-map*1697 (lambda (f1737 first1736 . rest1735) (or (null? first1736) (if (null? rest1735) (letrec ((andmap1738 (lambda (first1739) (let ((x1740 (car first1739)) (first1741 (cdr first1739))) (if (null? first1741) (f1737 x1740) (and (f1737 x1740) (andmap1738 first1741))))))) (andmap1738 first1736)) (letrec ((andmap1742 (lambda (first1743 rest1744) (let ((x1745 (car first1743)) (xr1746 (map car rest1744)) (first1747 (cdr first1743)) (rest1748 (map cdr rest1744))) (if (null? first1747) (apply f1737 (cons x1745 xr1746)) (and (apply f1737 (cons x1745 xr1746)) (andmap1742 first1747 rest1748))))))) (andmap1742 first1736 rest1735))))))) (letrec ((lambda-var-list1840 (lambda (vars1969) (letrec ((lvl1970 (lambda (vars1971 ls1972 w1973) (cond ((pair? vars1971) (lvl1970 (cdr vars1971) (cons (wrap1819 (car vars1971) w1973 (quote #f)) ls1972) w1973)) ((id?1791 vars1971) (cons (wrap1819 vars1971 w1973 (quote #f)) ls1972)) ((null? vars1971) ls1972) ((syntax-object?1775 vars1971) (lvl1970 (syntax-object-expression1776 vars1971) ls1972 (join-wraps1810 w1973 (syntax-object-wrap1777 vars1971)))) ((annotation? vars1971) (lvl1970 (annotation-expression vars1971) ls1972 w1973)) (else (cons vars1971 ls1972)))))) (lvl1970 vars1969 (quote ()) (quote (())))))) (gen-var1839 (lambda (id1974) (let ((id1975 (if (syntax-object?1775 id1974) (syntax-object-expression1776 id1974) id1974))) (if (annotation? id1975) (gensym (symbol->string (annotation-expression id1975))) (gensym (symbol->string id1975)))))) (strip1838 (lambda (x1976 w1977) (if (memq (quote top) (wrap-marks1794 w1977)) (if (or (annotation? x1976) (and (pair? x1976) (annotation? (car x1976)))) (strip-annotation1837 x1976 (quote #f)) x1976) (letrec ((f1978 (lambda (x1979) (cond ((syntax-object?1775 x1979) (strip1838 (syntax-object-expression1776 x1979) (syntax-object-wrap1777 x1979))) ((pair? x1979) (let ((a1980 (f1978 (car x1979))) (d1981 (f1978 (cdr x1979)))) (if (and (eq? a1980 (car x1979)) (eq? d1981 (cdr x1979))) x1979 (cons a1980 d1981)))) ((vector? x1979) (let ((old1982 (vector->list x1979))) (let ((new1983 (map f1978 old1982))) (if (and-map*1697 eq? old1982 new1983) x1979 (list->vector new1983))))) (else x1979))))) (f1978 x1976))))) (strip-annotation1837 (lambda (x1984 parent1985) (cond ((pair? x1984) (let ((new1986 (cons (quote #f) (quote #f)))) (begin (if parent1985 (set-annotation-stripped! parent1985 new1986)) (set-car! new1986 (strip-annotation1837 (car x1984) (quote #f))) (set-cdr! new1986 (strip-annotation1837 (cdr x1984) (quote #f))) new1986))) ((annotation? x1984) (or (annotation-stripped x1984) (strip-annotation1837 (annotation-expression x1984) x1984))) ((vector? x1984) (let ((new1987 (make-vector (vector-length x1984)))) (begin (if parent1985 (set-annotation-stripped! parent1985 new1987)) (letrec ((loop1988 (lambda (i1989) (unless (fx<1754 i1989 (quote 0)) (vector-set! new1987 i1989 (strip-annotation1837 (vector-ref x1984 i1989) (quote #f))) (loop1988 (fx-1752 i1989 (quote 1))))))) (loop1988 (- (vector-length x1984) (quote 1)))) new1987))) (else x1984)))) (ellipsis?1836 (lambda (x1990) (and (nonsymbol-id?1790 x1990) (free-id=?1814 x1990 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1835 (lambda () (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote if)) (quote (#f #f))))) (eval-local-transformer1834 (lambda (expanded1991 mod1992) (let ((p1993 (local-eval-hook1756 expanded1991 mod1992))) (if (procedure? p1993) p1993 (syntax-violation (quote #f) (quote "nonprocedure transformer") p1993))))) (chi-local-syntax1833 (lambda (rec?1994 e1995 r1996 w1997 s1998 mod1999 k2000) ((lambda (tmp2001) ((lambda (tmp2002) (if tmp2002 (apply (lambda (_2003 id2004 val2005 e12006 e22007) (let ((ids2008 id2004)) (if (not (valid-bound-ids?1816 ids2008)) (syntax-violation (quote #f) (quote "duplicate bound keyword") e1995) (let ((labels2010 (gen-labels1797 ids2008))) (let ((new-w2011 (make-binding-wrap1808 ids2008 labels2010 w1997))) (k2000 (cons e12006 e22007) (extend-env1785 labels2010 (let ((w2013 (if rec?1994 new-w2011 w1997)) (trans-r2014 (macros-only-env1787 r1996))) (map (lambda (x2015) (cons (quote macro) (eval-local-transformer1834 (chi1827 x2015 trans-r2014 w2013 mod1999) mod1999))) val2005)) r1996) new-w2011 s1998 mod1999)))))) tmp2002) ((lambda (_2017) (syntax-violation (quote #f) (quote "bad local syntax definition") (source-wrap1820 e1995 w1997 s1998 mod1999))) tmp2001))) ($sc-dispatch tmp2001 (quote (any #(each (any any)) any . each-any))))) e1995))) (chi-lambda-clause1832 (lambda (e2018 docstring2019 c2020 r2021 w2022 mod2023 k2024) ((lambda (tmp2025) ((lambda (tmp2026) (if (if tmp2026 (apply (lambda (args2027 doc2028 e12029 e22030) (and (string? (syntax->datum doc2028)) (not docstring2019))) tmp2026) (quote #f)) (apply (lambda (args2031 doc2032 e12033 e22034) (chi-lambda-clause1832 e2018 doc2032 (cons args2031 (cons e12033 e22034)) r2021 w2022 mod2023 k2024)) tmp2026) ((lambda (tmp2036) (if tmp2036 (apply (lambda (id2037 e12038 e22039) (let ((ids2040 id2037)) (if (not (valid-bound-ids?1816 ids2040)) (syntax-violation (quote lambda) (quote "invalid parameter list") e2018) (let ((labels2042 (gen-labels1797 ids2040)) (new-vars2043 (map gen-var1839 ids2040))) (k2024 new-vars2043 docstring2019 (chi-body1831 (cons e12038 e22039) e2018 (extend-var-env1786 labels2042 new-vars2043 r2021) (make-binding-wrap1808 ids2040 labels2042 w2022) mod2023)))))) tmp2036) ((lambda (tmp2045) (if tmp2045 (apply (lambda (ids2046 e12047 e22048) (let ((old-ids2049 (lambda-var-list1840 ids2046))) (if (not (valid-bound-ids?1816 old-ids2049)) (syntax-violation (quote lambda) (quote "invalid parameter list") e2018) (let ((labels2050 (gen-labels1797 old-ids2049)) (new-vars2051 (map gen-var1839 old-ids2049))) (k2024 (letrec ((f2052 (lambda (ls12053 ls22054) (if (null? ls12053) ls22054 (f2052 (cdr ls12053) (cons (car ls12053) ls22054)))))) (f2052 (cdr new-vars2051) (car new-vars2051))) docstring2019 (chi-body1831 (cons e12047 e22048) e2018 (extend-var-env1786 labels2050 new-vars2051 r2021) (make-binding-wrap1808 old-ids2049 labels2050 w2022) mod2023)))))) tmp2045) ((lambda (_2056) (syntax-violation (quote lambda) (quote "bad lambda") e2018)) tmp2025))) ($sc-dispatch tmp2025 (quote (any any . each-any)))))) ($sc-dispatch tmp2025 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2025 (quote (any any any . each-any))))) c2020))) (chi-body1831 (lambda (body2057 outer-form2058 r2059 w2060 mod2061) (let ((r2062 (cons (quote ("placeholder" placeholder)) r2059))) (let ((ribcage2063 (make-ribcage1798 (quote ()) (quote ()) (quote ())))) (let ((w2064 (make-wrap1793 (wrap-marks1794 w2060) (cons ribcage2063 (wrap-subst1795 w2060))))) (letrec ((parse2065 (lambda (body2066 ids2067 labels2068 vars2069 vals2070 bindings2071) (if (null? body2066) (syntax-violation (quote #f) (quote "no expressions in body") outer-form2058) (let ((e2073 (cdar body2066)) (er2074 (caar body2066))) (call-with-values (lambda () (syntax-type1825 e2073 er2074 (quote (())) (quote #f) ribcage2063 mod2061)) (lambda (type2075 value2076 e2077 w2078 s2079 mod2080) (let ((t2081 type2075)) (if (memv t2081 (quote (define-form))) (let ((id2082 (wrap1819 value2076 w2078 mod2080)) (label2083 (gen-label1796))) (let ((var2084 (gen-var1839 id2082))) (begin (extend-ribcage!1807 ribcage2063 id2082 label2083) (parse2065 (cdr body2066) (cons id2082 ids2067) (cons label2083 labels2068) (cons var2084 vars2069) (cons (cons er2074 (wrap1819 e2077 w2078 mod2080)) vals2070) (cons (cons (quote lexical) var2084) bindings2071))))) (if (memv t2081 (quote (define-syntax-form))) (let ((id2085 (wrap1819 value2076 w2078 mod2080)) (label2086 (gen-label1796))) (begin (extend-ribcage!1807 ribcage2063 id2085 label2086) (parse2065 (cdr body2066) (cons id2085 ids2067) (cons label2086 labels2068) vars2069 vals2070 (cons (cons (quote macro) (cons er2074 (wrap1819 e2077 w2078 mod2080))) bindings2071)))) (if (memv t2081 (quote (begin-form))) ((lambda (tmp2087) ((lambda (tmp2088) (if tmp2088 (apply (lambda (_2089 e12090) (parse2065 (letrec ((f2091 (lambda (forms2092) (if (null? forms2092) (cdr body2066) (cons (cons er2074 (wrap1819 (car forms2092) w2078 mod2080)) (f2091 (cdr forms2092))))))) (f2091 e12090)) ids2067 labels2068 vars2069 vals2070 bindings2071)) tmp2088) (syntax-violation #f "source expression failed to match any pattern" tmp2087))) ($sc-dispatch tmp2087 (quote (any . each-any))))) e2077) (if (memv t2081 (quote (local-syntax-form))) (chi-local-syntax1833 value2076 e2077 er2074 w2078 s2079 mod2080 (lambda (forms2094 er2095 w2096 s2097 mod2098) (parse2065 (letrec ((f2099 (lambda (forms2100) (if (null? forms2100) (cdr body2066) (cons (cons er2095 (wrap1819 (car forms2100) w2096 mod2098)) (f2099 (cdr forms2100))))))) (f2099 forms2094)) ids2067 labels2068 vars2069 vals2070 bindings2071))) (if (null? ids2067) (build-sequence1770 (quote #f) (map (lambda (x2101) (chi1827 (cdr x2101) (car x2101) (quote (())) mod2080)) (cons (cons er2074 (source-wrap1820 e2077 w2078 s2079 mod2080)) (cdr body2066)))) (begin (if (not (valid-bound-ids?1816 ids2067)) (syntax-violation (quote #f) (quote "invalid or duplicate identifier in definition") outer-form2058)) (letrec ((loop2102 (lambda (bs2103 er-cache2104 r-cache2105) (if (not (null? bs2103)) (let ((b2106 (car bs2103))) (if (eq? (car b2106) (quote macro)) (let ((er2107 (cadr b2106))) (let ((r-cache2108 (if (eq? er2107 er-cache2104) r-cache2105 (macros-only-env1787 er2107)))) (begin (set-cdr! b2106 (eval-local-transformer1834 (chi1827 (cddr b2106) r-cache2108 (quote (())) mod2080) mod2080)) (loop2102 (cdr bs2103) er2107 r-cache2108)))) (loop2102 (cdr bs2103) er-cache2104 r-cache2105))))))) (loop2102 bindings2071 (quote #f) (quote #f))) (set-cdr! r2062 (extend-env1785 labels2068 bindings2071 (cdr r2062))) (build-letrec1773 (quote #f) vars2069 (map (lambda (x2109) (chi1827 (cdr x2109) (car x2109) (quote (())) mod2080)) vals2070) (build-sequence1770 (quote #f) (map (lambda (x2110) (chi1827 (cdr x2110) (car x2110) (quote (())) mod2080)) (cons (cons er2074 (source-wrap1820 e2077 w2078 s2079 mod2080)) (cdr body2066))))))))))))))))))) (parse2065 (map (lambda (x2072) (cons r2062 (wrap1819 x2072 w2064 mod2061))) body2057) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro1830 (lambda (p2111 e2112 r2113 w2114 rib2115 mod2116) (letrec ((rebuild-macro-output2117 (lambda (x2118 m2119) (cond ((pair? x2118) (cons (rebuild-macro-output2117 (car x2118) m2119) (rebuild-macro-output2117 (cdr x2118) m2119))) ((syntax-object?1775 x2118) (let ((w2120 (syntax-object-wrap1777 x2118))) (let ((ms2121 (wrap-marks1794 w2120)) (s2122 (wrap-subst1795 w2120))) (if (and (pair? ms2121) (eq? (car ms2121) (quote #f))) (make-syntax-object1774 (syntax-object-expression1776 x2118) (make-wrap1793 (cdr ms2121) (if rib2115 (cons rib2115 (cdr s2122)) (cdr s2122))) (syntax-object-module1778 x2118)) (make-syntax-object1774 (syntax-object-expression1776 x2118) (make-wrap1793 (cons m2119 ms2121) (if rib2115 (cons rib2115 (cons (quote shift) s2122)) (cons (quote shift) s2122))) (let ((pmod2123 (procedure-module p2111))) (if pmod2123 (cons (quote hygiene) (module-name pmod2123)) (quote (hygiene guile))))))))) ((vector? x2118) (let ((n2124 (vector-length x2118))) (let ((v2125 (make-vector n2124))) (letrec ((doloop2126 (lambda (i2127) (if (fx=1753 i2127 n2124) v2125 (begin (vector-set! v2125 i2127 (rebuild-macro-output2117 (vector-ref x2118 i2127) m2119)) (doloop2126 (fx+1751 i2127 (quote 1)))))))) (doloop2126 (quote 0)))))) ((symbol? x2118) (syntax-violation (quote #f) (quote "encountered raw symbol in macro output") (source-wrap1820 e2112 w2114 s mod2116) x2118)) (else x2118))))) (rebuild-macro-output2117 (p2111 (wrap1819 e2112 (anti-mark1806 w2114) mod2116)) (string (quote #\m)))))) (chi-application1829 (lambda (x2128 e2129 r2130 w2131 s2132 mod2133) ((lambda (tmp2134) ((lambda (tmp2135) (if tmp2135 (apply (lambda (e02136 e12137) (build-application1759 s2132 x2128 (map (lambda (e2138) (chi1827 e2138 r2130 w2131 mod2133)) e12137))) tmp2135) (syntax-violation #f "source expression failed to match any pattern" tmp2134))) ($sc-dispatch tmp2134 (quote (any . each-any))))) e2129))) (chi-expr1828 (lambda (type2140 value2141 e2142 r2143 w2144 s2145 mod2146) (let ((t2147 type2140)) (if (memv t2147 (quote (lexical))) (build-lexical-reference1761 (quote value) s2145 e2142 value2141) (if (memv t2147 (quote (core external-macro))) (value2141 e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (module-ref))) (call-with-values (lambda () (value2141 e2142)) (lambda (id2148 mod2149) (build-global-reference1764 s2145 id2148 mod2149))) (if (memv t2147 (quote (lexical-call))) (chi-application1829 (build-lexical-reference1761 (quote fun) (source-annotation1782 (car e2142)) (car e2142) value2141) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (global-call))) (chi-application1829 (build-global-reference1764 (source-annotation1782 (car e2142)) value2141 (if (syntax-object?1775 (car e2142)) (syntax-object-module1778 (car e2142)) mod2146)) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (constant))) (build-data1769 s2145 (strip1838 (source-wrap1820 e2142 w2144 s2145 mod2146) (quote (())))) (if (memv t2147 (quote (global))) (build-global-reference1764 s2145 value2141 mod2146) (if (memv t2147 (quote (call))) (chi-application1829 (chi1827 (car e2142) r2143 w2144 mod2146) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (begin-form))) ((lambda (tmp2150) ((lambda (tmp2151) (if tmp2151 (apply (lambda (_2152 e12153 e22154) (chi-sequence1821 (cons e12153 e22154) r2143 w2144 s2145 mod2146)) tmp2151) (syntax-violation #f "source expression failed to match any pattern" tmp2150))) ($sc-dispatch tmp2150 (quote (any any . each-any))))) e2142) (if (memv t2147 (quote (local-syntax-form))) (chi-local-syntax1833 value2141 e2142 r2143 w2144 s2145 mod2146 chi-sequence1821) (if (memv t2147 (quote (eval-when-form))) ((lambda (tmp2156) ((lambda (tmp2157) (if tmp2157 (apply (lambda (_2158 x2159 e12160 e22161) (let ((when-list2162 (chi-when-list1824 e2142 x2159 w2144))) (if (memq (quote eval) when-list2162) (chi-sequence1821 (cons e12160 e22161) r2143 w2144 s2145 mod2146) (chi-void1835)))) tmp2157) (syntax-violation #f "source expression failed to match any pattern" tmp2156))) ($sc-dispatch tmp2156 (quote (any each-any any . each-any))))) e2142) (if (memv t2147 (quote (define-form define-syntax-form))) (syntax-violation (quote #f) (quote "definition in expression context") e2142 (wrap1819 value2141 w2144 mod2146)) (if (memv t2147 (quote (syntax))) (syntax-violation (quote #f) (quote "reference to pattern variable outside syntax form") (source-wrap1820 e2142 w2144 s2145 mod2146)) (if (memv t2147 (quote (displaced-lexical))) (syntax-violation (quote #f) (quote "reference to identifier outside its scope") (source-wrap1820 e2142 w2144 s2145 mod2146)) (syntax-violation (quote #f) (quote "unexpected syntax") (source-wrap1820 e2142 w2144 s2145 mod2146))))))))))))))))))) (chi1827 (lambda (e2165 r2166 w2167 mod2168) (call-with-values (lambda () (syntax-type1825 e2165 r2166 w2167 (quote #f) (quote #f) mod2168)) (lambda (type2169 value2170 e2171 w2172 s2173 mod2174) (chi-expr1828 type2169 value2170 e2171 r2166 w2172 s2173 mod2174))))) (chi-top1826 (lambda (e2175 r2176 w2177 m2178 esew2179 mod2180) (call-with-values (lambda () (syntax-type1825 e2175 r2176 w2177 (quote #f) (quote #f) mod2180)) (lambda (type2188 value2189 e2190 w2191 s2192 mod2193) (let ((t2194 type2188)) (if (memv t2194 (quote (begin-form))) ((lambda (tmp2195) ((lambda (tmp2196) (if tmp2196 (apply (lambda (_2197) (chi-void1835)) tmp2196) ((lambda (tmp2198) (if tmp2198 (apply (lambda (_2199 e12200 e22201) (chi-top-sequence1822 (cons e12200 e22201) r2176 w2191 s2192 m2178 esew2179 mod2193)) tmp2198) (syntax-violation #f "source expression failed to match any pattern" tmp2195))) ($sc-dispatch tmp2195 (quote (any any . each-any)))))) ($sc-dispatch tmp2195 (quote (any))))) e2190) (if (memv t2194 (quote (local-syntax-form))) (chi-local-syntax1833 value2189 e2190 r2176 w2191 s2192 mod2193 (lambda (body2203 r2204 w2205 s2206 mod2207) (chi-top-sequence1822 body2203 r2204 w2205 s2206 m2178 esew2179 mod2207))) (if (memv t2194 (quote (eval-when-form))) ((lambda (tmp2208) ((lambda (tmp2209) (if tmp2209 (apply (lambda (_2210 x2211 e12212 e22213) (let ((when-list2214 (chi-when-list1824 e2190 x2211 w2191)) (body2215 (cons e12212 e22213))) (cond ((eq? m2178 (quote e)) (if (memq (quote eval) when-list2214) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote e) (quote (eval)) mod2193) (chi-void1835))) ((memq (quote load) when-list2214) (if (or (memq (quote compile) when-list2214) (and (eq? m2178 (quote c&e)) (memq (quote eval) when-list2214))) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote c&e) (quote (compile load)) mod2193) (if (memq m2178 (quote (c c&e))) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote c) (quote (load)) mod2193) (chi-void1835)))) ((or (memq (quote compile) when-list2214) (and (eq? m2178 (quote c&e)) (memq (quote eval) when-list2214))) (top-level-eval-hook1755 (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote e) (quote (eval)) mod2193) mod2193) (chi-void1835)) (else (chi-void1835))))) tmp2209) (syntax-violation #f "source expression failed to match any pattern" tmp2208))) ($sc-dispatch tmp2208 (quote (any each-any any . each-any))))) e2190) (if (memv t2194 (quote (define-syntax-form))) (let ((n2218 (id-var-name1813 value2189 w2191)) (r2219 (macros-only-env1787 r2176))) (let ((t2220 m2178)) (if (memv t2220 (quote (c))) (if (memq (quote compile) esew2179) (let ((e2221 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)))) (begin (top-level-eval-hook1755 e2221 mod2193) (if (memq (quote load) esew2179) e2221 (chi-void1835)))) (if (memq (quote load) esew2179) (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)) (chi-void1835))) (if (memv t2220 (quote (c&e))) (let ((e2222 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)))) (begin (top-level-eval-hook1755 e2222 mod2193) e2222)) (begin (if (memq (quote eval) esew2179) (top-level-eval-hook1755 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)) mod2193)) (chi-void1835)))))) (if (memv t2194 (quote (define-form))) (let ((n2223 (id-var-name1813 value2189 w2191))) (let ((type2224 (binding-type1783 (lookup1788 n2223 r2176 mod2193)))) (let ((t2225 type2224)) (if (memv t2225 (quote (global core macro module-ref))) (let ((x2226 (build-global-definition1766 s2192 n2223 (chi1827 e2190 r2176 w2191 mod2193)))) (begin (if (eq? m2178 (quote c&e)) (top-level-eval-hook1755 x2226 mod2193)) x2226)) (if (memv t2225 (quote (displaced-lexical))) (syntax-violation (quote #f) (quote "identifier out of context") e2190 (wrap1819 value2189 w2191 mod2193)) (syntax-violation (quote #f) (quote "cannot define keyword at top level") e2190 (wrap1819 value2189 w2191 mod2193))))))) (let ((x2227 (chi-expr1828 type2188 value2189 e2190 r2176 w2191 s2192 mod2193))) (begin (if (eq? m2178 (quote c&e)) (top-level-eval-hook1755 x2227 mod2193)) x2227)))))))))))) (syntax-type1825 (lambda (e2228 r2229 w2230 s2231 rib2232 mod2233) (cond ((symbol? e2228) (let ((n2234 (id-var-name1813 e2228 w2230))) (let ((b2235 (lookup1788 n2234 r2229 mod2233))) (let ((type2236 (binding-type1783 b2235))) (let ((t2237 type2236)) (if (memv t2237 (quote (lexical))) (values type2236 (binding-value1784 b2235) e2228 w2230 s2231 mod2233) (if (memv t2237 (quote (global))) (values type2236 n2234 e2228 w2230 s2231 mod2233) (if (memv t2237 (quote (macro))) (syntax-type1825 (chi-macro1830 (binding-value1784 b2235) e2228 r2229 w2230 rib2232 mod2233) r2229 (quote (())) s2231 rib2232 mod2233) (values type2236 (binding-value1784 b2235) e2228 w2230 s2231 mod2233))))))))) ((pair? e2228) (let ((first2238 (car e2228))) (if (id?1791 first2238) (let ((n2239 (id-var-name1813 first2238 w2230))) (let ((b2240 (lookup1788 n2239 r2229 (or (and (syntax-object?1775 first2238) (syntax-object-module1778 first2238)) mod2233)))) (let ((type2241 (binding-type1783 b2240))) (let ((t2242 type2241)) (if (memv t2242 (quote (lexical))) (values (quote lexical-call) (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (global))) (values (quote global-call) n2239 e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (macro))) (syntax-type1825 (chi-macro1830 (binding-value1784 b2240) e2228 r2229 w2230 rib2232 mod2233) r2229 (quote (())) s2231 rib2232 mod2233) (if (memv t2242 (quote (core external-macro module-ref))) (values type2241 (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (begin))) (values (quote begin-form) (quote #f) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (define))) ((lambda (tmp2243) ((lambda (tmp2244) (if (if tmp2244 (apply (lambda (_2245 name2246 val2247) (id?1791 name2246)) tmp2244) (quote #f)) (apply (lambda (_2248 name2249 val2250) (values (quote define-form) name2249 val2250 w2230 s2231 mod2233)) tmp2244) ((lambda (tmp2251) (if (if tmp2251 (apply (lambda (_2252 name2253 args2254 e12255 e22256) (and (id?1791 name2253) (valid-bound-ids?1816 (lambda-var-list1840 args2254)))) tmp2251) (quote #f)) (apply (lambda (_2257 name2258 args2259 e12260 e22261) (values (quote define-form) (wrap1819 name2258 w2230 mod2233) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1819 (cons args2259 (cons e12260 e22261)) w2230 mod2233)) (quote (())) s2231 mod2233)) tmp2251) ((lambda (tmp2263) (if (if tmp2263 (apply (lambda (_2264 name2265) (id?1791 name2265)) tmp2263) (quote #f)) (apply (lambda (_2266 name2267) (values (quote define-form) (wrap1819 name2267 w2230 mod2233) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2231 mod2233)) tmp2263) (syntax-violation #f "source expression failed to match any pattern" tmp2243))) ($sc-dispatch tmp2243 (quote (any any)))))) ($sc-dispatch tmp2243 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2243 (quote (any any any))))) e2228) (if (memv t2242 (quote (define-syntax))) ((lambda (tmp2268) ((lambda (tmp2269) (if (if tmp2269 (apply (lambda (_2270 name2271 val2272) (id?1791 name2271)) tmp2269) (quote #f)) (apply (lambda (_2273 name2274 val2275) (values (quote define-syntax-form) name2274 val2275 w2230 s2231 mod2233)) tmp2269) (syntax-violation #f "source expression failed to match any pattern" tmp2268))) ($sc-dispatch tmp2268 (quote (any any any))))) e2228) (values (quote call) (quote #f) e2228 w2230 s2231 mod2233)))))))))))))) (values (quote call) (quote #f) e2228 w2230 s2231 mod2233)))) ((syntax-object?1775 e2228) (syntax-type1825 (syntax-object-expression1776 e2228) r2229 (join-wraps1810 w2230 (syntax-object-wrap1777 e2228)) (quote #f) rib2232 (or (syntax-object-module1778 e2228) mod2233))) ((annotation? e2228) (syntax-type1825 (annotation-expression e2228) r2229 w2230 (annotation-source e2228) rib2232 mod2233)) ((self-evaluating? e2228) (values (quote constant) (quote #f) e2228 w2230 s2231 mod2233)) (else (values (quote other) (quote #f) e2228 w2230 s2231 mod2233))))) (chi-when-list1824 (lambda (e2276 when-list2277 w2278) (letrec ((f2279 (lambda (when-list2280 situations2281) (if (null? when-list2280) situations2281 (f2279 (cdr when-list2280) (cons (let ((x2282 (car when-list2280))) (cond ((free-id=?1814 x2282 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1814 x2282 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1814 x2282 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) (quote "invalid situation") e2276 (wrap1819 x2282 w2278 (quote #f)))))) situations2281)))))) (f2279 when-list2277 (quote ()))))) (chi-install-global1823 (lambda (name2283 e2284) (build-global-definition1766 (quote #f) name2283 (if (let ((v2285 (module-variable (current-module) name2283))) (and v2285 (variable-bound? v2285) (macro? (variable-ref v2285)) (not (eq? (macro-type (variable-ref v2285)) (quote syncase-macro))))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote make-extended-syncase-macro)) (list (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote module-ref)) (list (build-application1759 (quote #f) (quote current-module) (quote ())) (build-data1769 (quote #f) name2283))) (build-data1769 (quote #f) (quote macro)) e2284)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote make-syncase-macro)) (list (build-data1769 (quote #f) (quote macro)) e2284)))))) (chi-top-sequence1822 (lambda (body2286 r2287 w2288 s2289 m2290 esew2291 mod2292) (build-sequence1770 s2289 (letrec ((dobody2293 (lambda (body2294 r2295 w2296 m2297 esew2298 mod2299) (if (null? body2294) (quote ()) (let ((first2300 (chi-top1826 (car body2294) r2295 w2296 m2297 esew2298 mod2299))) (cons first2300 (dobody2293 (cdr body2294) r2295 w2296 m2297 esew2298 mod2299))))))) (dobody2293 body2286 r2287 w2288 m2290 esew2291 mod2292))))) (chi-sequence1821 (lambda (body2301 r2302 w2303 s2304 mod2305) (build-sequence1770 s2304 (letrec ((dobody2306 (lambda (body2307 r2308 w2309 mod2310) (if (null? body2307) (quote ()) (let ((first2311 (chi1827 (car body2307) r2308 w2309 mod2310))) (cons first2311 (dobody2306 (cdr body2307) r2308 w2309 mod2310))))))) (dobody2306 body2301 r2302 w2303 mod2305))))) (source-wrap1820 (lambda (x2312 w2313 s2314 defmod2315) (wrap1819 (if s2314 (make-annotation x2312 s2314 (quote #f)) x2312) w2313 defmod2315))) (wrap1819 (lambda (x2316 w2317 defmod2318) (cond ((and (null? (wrap-marks1794 w2317)) (null? (wrap-subst1795 w2317))) x2316) ((syntax-object?1775 x2316) (make-syntax-object1774 (syntax-object-expression1776 x2316) (join-wraps1810 w2317 (syntax-object-wrap1777 x2316)) (syntax-object-module1778 x2316))) ((null? x2316) x2316) (else (make-syntax-object1774 x2316 w2317 defmod2318))))) (bound-id-member?1818 (lambda (x2319 list2320) (and (not (null? list2320)) (or (bound-id=?1815 x2319 (car list2320)) (bound-id-member?1818 x2319 (cdr list2320)))))) (distinct-bound-ids?1817 (lambda (ids2321) (letrec ((distinct?2322 (lambda (ids2323) (or (null? ids2323) (and (not (bound-id-member?1818 (car ids2323) (cdr ids2323))) (distinct?2322 (cdr ids2323))))))) (distinct?2322 ids2321)))) (valid-bound-ids?1816 (lambda (ids2324) (and (letrec ((all-ids?2325 (lambda (ids2326) (or (null? ids2326) (and (id?1791 (car ids2326)) (all-ids?2325 (cdr ids2326))))))) (all-ids?2325 ids2324)) (distinct-bound-ids?1817 ids2324)))) (bound-id=?1815 (lambda (i2327 j2328) (if (and (syntax-object?1775 i2327) (syntax-object?1775 j2328)) (and (eq? (let ((e2329 (syntax-object-expression1776 i2327))) (if (annotation? e2329) (annotation-expression e2329) e2329)) (let ((e2330 (syntax-object-expression1776 j2328))) (if (annotation? e2330) (annotation-expression e2330) e2330))) (same-marks?1812 (wrap-marks1794 (syntax-object-wrap1777 i2327)) (wrap-marks1794 (syntax-object-wrap1777 j2328)))) (eq? (let ((e2331 i2327)) (if (annotation? e2331) (annotation-expression e2331) e2331)) (let ((e2332 j2328)) (if (annotation? e2332) (annotation-expression e2332) e2332)))))) (free-id=?1814 (lambda (i2333 j2334) (and (eq? (let ((x2335 i2333)) (let ((e2336 (if (syntax-object?1775 x2335) (syntax-object-expression1776 x2335) x2335))) (if (annotation? e2336) (annotation-expression e2336) e2336))) (let ((x2337 j2334)) (let ((e2338 (if (syntax-object?1775 x2337) (syntax-object-expression1776 x2337) x2337))) (if (annotation? e2338) (annotation-expression e2338) e2338)))) (eq? (id-var-name1813 i2333 (quote (()))) (id-var-name1813 j2334 (quote (()))))))) (id-var-name1813 (lambda (id2339 w2340) (letrec ((search-vector-rib2343 (lambda (sym2349 subst2350 marks2351 symnames2352 ribcage2353) (let ((n2354 (vector-length symnames2352))) (letrec ((f2355 (lambda (i2356) (cond ((fx=1753 i2356 n2354) (search2341 sym2349 (cdr subst2350) marks2351)) ((and (eq? (vector-ref symnames2352 i2356) sym2349) (same-marks?1812 marks2351 (vector-ref (ribcage-marks1801 ribcage2353) i2356))) (values (vector-ref (ribcage-labels1802 ribcage2353) i2356) marks2351)) (else (f2355 (fx+1751 i2356 (quote 1)))))))) (f2355 (quote 0)))))) (search-list-rib2342 (lambda (sym2357 subst2358 marks2359 symnames2360 ribcage2361) (letrec ((f2362 (lambda (symnames2363 i2364) (cond ((null? symnames2363) (search2341 sym2357 (cdr subst2358) marks2359)) ((and (eq? (car symnames2363) sym2357) (same-marks?1812 marks2359 (list-ref (ribcage-marks1801 ribcage2361) i2364))) (values (list-ref (ribcage-labels1802 ribcage2361) i2364) marks2359)) (else (f2362 (cdr symnames2363) (fx+1751 i2364 (quote 1)))))))) (f2362 symnames2360 (quote 0))))) (search2341 (lambda (sym2365 subst2366 marks2367) (if (null? subst2366) (values (quote #f) marks2367) (let ((fst2368 (car subst2366))) (if (eq? fst2368 (quote shift)) (search2341 sym2365 (cdr subst2366) (cdr marks2367)) (let ((symnames2369 (ribcage-symnames1800 fst2368))) (if (vector? symnames2369) (search-vector-rib2343 sym2365 subst2366 marks2367 symnames2369 fst2368) (search-list-rib2342 sym2365 subst2366 marks2367 symnames2369 fst2368))))))))) (cond ((symbol? id2339) (or (call-with-values (lambda () (search2341 id2339 (wrap-subst1795 w2340) (wrap-marks1794 w2340))) (lambda (x2371 . ignore2370) x2371)) id2339)) ((syntax-object?1775 id2339) (let ((id2372 (let ((e2374 (syntax-object-expression1776 id2339))) (if (annotation? e2374) (annotation-expression e2374) e2374))) (w12373 (syntax-object-wrap1777 id2339))) (let ((marks2375 (join-marks1811 (wrap-marks1794 w2340) (wrap-marks1794 w12373)))) (call-with-values (lambda () (search2341 id2372 (wrap-subst1795 w2340) marks2375)) (lambda (new-id2376 marks2377) (or new-id2376 (call-with-values (lambda () (search2341 id2372 (wrap-subst1795 w12373) marks2377)) (lambda (x2379 . ignore2378) x2379)) id2372)))))) ((annotation? id2339) (let ((id2380 (let ((e2381 id2339)) (if (annotation? e2381) (annotation-expression e2381) e2381)))) (or (call-with-values (lambda () (search2341 id2380 (wrap-subst1795 w2340) (wrap-marks1794 w2340))) (lambda (x2383 . ignore2382) x2383)) id2380))) (else (syntax-violation (quote id-var-name) (quote "invalid id") id2339)))))) (same-marks?1812 (lambda (x2384 y2385) (or (eq? x2384 y2385) (and (not (null? x2384)) (not (null? y2385)) (eq? (car x2384) (car y2385)) (same-marks?1812 (cdr x2384) (cdr y2385)))))) (join-marks1811 (lambda (m12386 m22387) (smart-append1809 m12386 m22387))) (join-wraps1810 (lambda (w12388 w22389) (let ((m12390 (wrap-marks1794 w12388)) (s12391 (wrap-subst1795 w12388))) (if (null? m12390) (if (null? s12391) w22389 (make-wrap1793 (wrap-marks1794 w22389) (smart-append1809 s12391 (wrap-subst1795 w22389)))) (make-wrap1793 (smart-append1809 m12390 (wrap-marks1794 w22389)) (smart-append1809 s12391 (wrap-subst1795 w22389))))))) (smart-append1809 (lambda (m12392 m22393) (if (null? m22393) m12392 (append m12392 m22393)))) (make-binding-wrap1808 (lambda (ids2394 labels2395 w2396) (if (null? ids2394) w2396 (make-wrap1793 (wrap-marks1794 w2396) (cons (let ((labelvec2397 (list->vector labels2395))) (let ((n2398 (vector-length labelvec2397))) (let ((symnamevec2399 (make-vector n2398)) (marksvec2400 (make-vector n2398))) (begin (letrec ((f2401 (lambda (ids2402 i2403) (if (not (null? ids2402)) (call-with-values (lambda () (id-sym-name&marks1792 (car ids2402) w2396)) (lambda (symname2404 marks2405) (begin (vector-set! symnamevec2399 i2403 symname2404) (vector-set! marksvec2400 i2403 marks2405) (f2401 (cdr ids2402) (fx+1751 i2403 (quote 1)))))))))) (f2401 ids2394 (quote 0))) (make-ribcage1798 symnamevec2399 marksvec2400 labelvec2397))))) (wrap-subst1795 w2396)))))) (extend-ribcage!1807 (lambda (ribcage2406 id2407 label2408) (begin (set-ribcage-symnames!1803 ribcage2406 (cons (let ((e2409 (syntax-object-expression1776 id2407))) (if (annotation? e2409) (annotation-expression e2409) e2409)) (ribcage-symnames1800 ribcage2406))) (set-ribcage-marks!1804 ribcage2406 (cons (wrap-marks1794 (syntax-object-wrap1777 id2407)) (ribcage-marks1801 ribcage2406))) (set-ribcage-labels!1805 ribcage2406 (cons label2408 (ribcage-labels1802 ribcage2406)))))) (anti-mark1806 (lambda (w2410) (make-wrap1793 (cons (quote #f) (wrap-marks1794 w2410)) (cons (quote shift) (wrap-subst1795 w2410))))) (set-ribcage-labels!1805 (lambda (x2411 update2412) (vector-set! x2411 (quote 3) update2412))) (set-ribcage-marks!1804 (lambda (x2413 update2414) (vector-set! x2413 (quote 2) update2414))) (set-ribcage-symnames!1803 (lambda (x2415 update2416) (vector-set! x2415 (quote 1) update2416))) (ribcage-labels1802 (lambda (x2417) (vector-ref x2417 (quote 3)))) (ribcage-marks1801 (lambda (x2418) (vector-ref x2418 (quote 2)))) (ribcage-symnames1800 (lambda (x2419) (vector-ref x2419 (quote 1)))) (ribcage?1799 (lambda (x2420) (and (vector? x2420) (= (vector-length x2420) (quote 4)) (eq? (vector-ref x2420 (quote 0)) (quote ribcage))))) (make-ribcage1798 (lambda (symnames2421 marks2422 labels2423) (vector (quote ribcage) symnames2421 marks2422 labels2423))) (gen-labels1797 (lambda (ls2424) (if (null? ls2424) (quote ()) (cons (gen-label1796) (gen-labels1797 (cdr ls2424)))))) (gen-label1796 (lambda () (string (quote #\i)))) (wrap-subst1795 cdr) (wrap-marks1794 car) (make-wrap1793 cons) (id-sym-name&marks1792 (lambda (x2425 w2426) (if (syntax-object?1775 x2425) (values (let ((e2427 (syntax-object-expression1776 x2425))) (if (annotation? e2427) (annotation-expression e2427) e2427)) (join-marks1811 (wrap-marks1794 w2426) (wrap-marks1794 (syntax-object-wrap1777 x2425)))) (values (let ((e2428 x2425)) (if (annotation? e2428) (annotation-expression e2428) e2428)) (wrap-marks1794 w2426))))) (id?1791 (lambda (x2429) (cond ((symbol? x2429) (quote #t)) ((syntax-object?1775 x2429) (symbol? (let ((e2430 (syntax-object-expression1776 x2429))) (if (annotation? e2430) (annotation-expression e2430) e2430)))) ((annotation? x2429) (symbol? (annotation-expression x2429))) (else (quote #f))))) (nonsymbol-id?1790 (lambda (x2431) (and (syntax-object?1775 x2431) (symbol? (let ((e2432 (syntax-object-expression1776 x2431))) (if (annotation? e2432) (annotation-expression e2432) e2432)))))) (global-extend1789 (lambda (type2433 sym2434 val2435) (put-global-definition-hook1757 sym2434 type2433 val2435))) (lookup1788 (lambda (x2436 r2437 mod2438) (cond ((assq x2436 r2437) => cdr) ((symbol? x2436) (or (get-global-definition-hook1758 x2436 mod2438) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1787 (lambda (r2439) (if (null? r2439) (quote ()) (let ((a2440 (car r2439))) (if (eq? (cadr a2440) (quote macro)) (cons a2440 (macros-only-env1787 (cdr r2439))) (macros-only-env1787 (cdr r2439))))))) (extend-var-env1786 (lambda (labels2441 vars2442 r2443) (if (null? labels2441) r2443 (extend-var-env1786 (cdr labels2441) (cdr vars2442) (cons (cons (car labels2441) (cons (quote lexical) (car vars2442))) r2443))))) (extend-env1785 (lambda (labels2444 bindings2445 r2446) (if (null? labels2444) r2446 (extend-env1785 (cdr labels2444) (cdr bindings2445) (cons (cons (car labels2444) (car bindings2445)) r2446))))) (binding-value1784 cdr) (binding-type1783 car) (source-annotation1782 (lambda (x2447) (cond ((annotation? x2447) (annotation-source x2447)) ((syntax-object?1775 x2447) (source-annotation1782 (syntax-object-expression1776 x2447))) (else (quote #f))))) (set-syntax-object-module!1781 (lambda (x2448 update2449) (vector-set! x2448 (quote 3) update2449))) (set-syntax-object-wrap!1780 (lambda (x2450 update2451) (vector-set! x2450 (quote 2) update2451))) (set-syntax-object-expression!1779 (lambda (x2452 update2453) (vector-set! x2452 (quote 1) update2453))) (syntax-object-module1778 (lambda (x2454) (vector-ref x2454 (quote 3)))) (syntax-object-wrap1777 (lambda (x2455) (vector-ref x2455 (quote 2)))) (syntax-object-expression1776 (lambda (x2456) (vector-ref x2456 (quote 1)))) (syntax-object?1775 (lambda (x2457) (and (vector? x2457) (= (vector-length x2457) (quote 4)) (eq? (vector-ref x2457 (quote 0)) (quote syntax-object))))) (make-syntax-object1774 (lambda (expression2458 wrap2459 module2460) (vector (quote syntax-object) expression2458 wrap2459 module2460))) (build-letrec1773 (lambda (src2461 vars2462 val-exps2463 body-exp2464) (if (null? vars2462) body-exp2464 (let ((t2465 (fluid-ref *mode*1750))) (if (memv t2465 (quote (c))) ((@ (language tree-il) make-letrec) src2461 vars2462 val-exps2463 body-exp2464) (list (quote letrec) (map list vars2462 val-exps2463) body-exp2464)))))) (build-named-let1772 (lambda (src2466 vars2467 val-exps2468 body-exp2469) (let ((f2470 (car vars2467)) (vars2471 (cdr vars2467))) (let ((t2472 (fluid-ref *mode*1750))) (if (memv t2472 (quote (c))) ((@ (language tree-il) make-letrec) src2466 (list f2470) (list (build-lambda1767 src2466 vars2471 (quote #f) body-exp2469)) (build-application1759 src2466 (build-lexical-reference1761 (quote fun) src2466 f2470 f2470) val-exps2468)) (list (quote let) f2470 (map list vars2471 val-exps2468) body-exp2469)))))) (build-let1771 (lambda (src2473 vars2474 val-exps2475 body-exp2476) (if (null? vars2474) body-exp2476 (let ((t2477 (fluid-ref *mode*1750))) (if (memv t2477 (quote (c))) ((@ (language tree-il) make-let) src2473 vars2474 val-exps2475 body-exp2476) (list (quote let) (map list vars2474 val-exps2475) body-exp2476)))))) (build-sequence1770 (lambda (src2478 exps2479) (if (null? (cdr exps2479)) (car exps2479) (let ((t2480 (fluid-ref *mode*1750))) (if (memv t2480 (quote (c))) ((@ (language tree-il) make-sequence) src2478 exps2479) (cons (quote begin) exps2479)))))) (build-data1769 (lambda (src2481 exp2482) (let ((t2483 (fluid-ref *mode*1750))) (if (memv t2483 (quote (c))) ((@ (language tree-il) make-const) src2481 exp2482) (if (and (self-evaluating? exp2482) (not (vector? exp2482))) exp2482 (list (quote quote) exp2482)))))) (build-primref1768 (lambda (src2484 name2485) (let ((t2486 (fluid-ref *mode*1750))) (if (memv t2486 (quote (c))) ((@ (language tree-il) make-primitive-ref) src2484 name2485) (build-global-reference1764 src2484 name2485 (quote (hygiene guile))))))) (build-lambda1767 (lambda (src2487 vars2488 docstring2489 exp2490) (let ((t2491 (fluid-ref *mode*1750))) (if (memv t2491 (quote (c))) ((@ (language tree-il) make-lambda) src2487 vars2488 (if docstring2489 (list (cons (quote documentation) docstring2489)) (quote ())) exp2490) (cons (quote lambda) (cons vars2488 (append (if docstring2489 (list docstring2489) (quote ())) (list exp2490)))))))) (build-global-definition1766 (lambda (source2492 var2493 exp2494) (let ((t2495 (fluid-ref *mode*1750))) (if (memv t2495 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2492 var2493 exp2494) (list (quote define) var2493 exp2494))))) (build-global-assignment1765 (lambda (source2496 var2497 exp2498 mod2499) (analyze-variable1763 mod2499 var2497 (lambda (mod2500 var2501 public?2502) (let ((t2503 (fluid-ref *mode*1750))) (if (memv t2503 (quote (c))) ((@ (language tree-il) make-module-set) source2496 mod2500 var2501 public?2502 exp2498) (list (quote set!) (list (if public?2502 (quote @) (quote @@)) mod2500 var2501) exp2498)))) (lambda (var2504) (let ((t2505 (fluid-ref *mode*1750))) (if (memv t2505 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2496 var2504 exp2498) (list (quote set!) var2504 exp2498))))))) (build-global-reference1764 (lambda (source2506 var2507 mod2508) (analyze-variable1763 mod2508 var2507 (lambda (mod2509 var2510 public?2511) (let ((t2512 (fluid-ref *mode*1750))) (if (memv t2512 (quote (c))) ((@ (language tree-il) make-module-ref) source2506 mod2509 var2510 public?2511) (list (if public?2511 (quote @) (quote @@)) mod2509 var2510)))) (lambda (var2513) (let ((t2514 (fluid-ref *mode*1750))) (if (memv t2514 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2506 var2513) var2513)))))) (analyze-variable1763 (lambda (mod2515 var2516 modref-cont2517 bare-cont2518) (if (not mod2515) (bare-cont2518 var2516) (let ((kind2519 (car mod2515)) (mod2520 (cdr mod2515))) (let ((t2521 kind2519)) (if (memv t2521 (quote (public))) (modref-cont2517 mod2520 var2516 (quote #t)) (if (memv t2521 (quote (private))) (if (not (equal? mod2520 (module-name (current-module)))) (modref-cont2517 mod2520 var2516 (quote #f)) (bare-cont2518 var2516)) (if (memv t2521 (quote (bare))) (bare-cont2518 var2516) (if (memv t2521 (quote (hygiene))) (if (and (not (equal? mod2520 (module-name (current-module)))) (module-variable (resolve-module mod2520) var2516)) (modref-cont2517 mod2520 var2516 (quote #f)) (bare-cont2518 var2516)) (syntax-violation (quote #f) (quote "bad module kind") var2516 mod2520)))))))))) (build-lexical-assignment1762 (lambda (source2522 name2523 var2524 exp2525) (let ((t2526 (fluid-ref *mode*1750))) (if (memv t2526 (quote (c))) ((@ (language tree-il) make-lexical-set) source2522 name2523 var2524 exp2525) (list (quote set!) var2524 exp2525))))) (build-lexical-reference1761 (lambda (type2527 source2528 name2529 var2530) (let ((t2531 (fluid-ref *mode*1750))) (if (memv t2531 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2528 name2529 var2530) var2530)))) (build-conditional1760 (lambda (source2532 test-exp2533 then-exp2534 else-exp2535) (let ((t2536 (fluid-ref *mode*1750))) (if (memv t2536 (quote (c))) ((@ (language tree-il) make-conditional) source2532 test-exp2533 then-exp2534 else-exp2535) (list (quote if) test-exp2533 then-exp2534 else-exp2535))))) (build-application1759 (lambda (source2537 fun-exp2538 arg-exps2539) (let ((t2540 (fluid-ref *mode*1750))) (if (memv t2540 (quote (c))) ((@ (language tree-il) make-application) source2537 fun-exp2538 arg-exps2539) (cons fun-exp2538 arg-exps2539))))) (get-global-definition-hook1758 (lambda (symbol2541 module2542) (begin (if (and (not module2542) (current-module)) (warn (quote "module system is booted, we should have a module") symbol2541)) (let ((v2543 (module-variable (if module2542 (resolve-module (cdr module2542)) (current-module)) symbol2541))) (and v2543 (variable-bound? v2543) (let ((val2544 (variable-ref v2543))) (and (macro? val2544) (syncase-macro-type val2544) (cons (syncase-macro-type val2544) (syncase-macro-binding val2544))))))))) (put-global-definition-hook1757 (lambda (symbol2545 type2546 val2547) (let ((existing2548 (let ((v2549 (module-variable (current-module) symbol2545))) (and v2549 (variable-bound? v2549) (let ((val2550 (variable-ref v2549))) (and (macro? val2550) (not (syncase-macro-type val2550)) val2550)))))) (module-define! (current-module) symbol2545 (if existing2548 (make-extended-syncase-macro existing2548 type2546 val2547) (make-syncase-macro type2546 val2547)))))) (local-eval-hook1756 (lambda (x2551 mod2552) (primitive-eval (list noexpand1749 (let ((t2553 (fluid-ref *mode*1750))) (if (memv t2553 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2551) x2551)))))) (top-level-eval-hook1755 (lambda (x2554 mod2555) (primitive-eval (list noexpand1749 (let ((t2556 (fluid-ref *mode*1750))) (if (memv t2556 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2554) x2554)))))) (fx<1754 <) (fx=1753 =) (fx-1752 -) (fx+1751 +) (*mode*1750 (make-fluid)) (noexpand1749 (quote "noexpand"))) (begin (global-extend1789 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend1789 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend1789 (quote core) (quote fluid-let-syntax) (lambda (e2557 r2558 w2559 s2560 mod2561) ((lambda (tmp2562) ((lambda (tmp2563) (if (if tmp2563 (apply (lambda (_2564 var2565 val2566 e12567 e22568) (valid-bound-ids?1816 var2565)) tmp2563) (quote #f)) (apply (lambda (_2570 var2571 val2572 e12573 e22574) (let ((names2575 (map (lambda (x2576) (id-var-name1813 x2576 w2559)) var2571))) (begin (for-each (lambda (id2578 n2579) (let ((t2580 (binding-type1783 (lookup1788 n2579 r2558 mod2561)))) (if (memv t2580 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) (quote "identifier out of context") e2557 (source-wrap1820 id2578 w2559 s2560 mod2561))))) var2571 names2575) (chi-body1831 (cons e12573 e22574) (source-wrap1820 e2557 w2559 s2560 mod2561) (extend-env1785 names2575 (let ((trans-r2583 (macros-only-env1787 r2558))) (map (lambda (x2584) (cons (quote macro) (eval-local-transformer1834 (chi1827 x2584 trans-r2583 w2559 mod2561) mod2561))) val2572)) r2558) w2559 mod2561)))) tmp2563) ((lambda (_2586) (syntax-violation (quote fluid-let-syntax) (quote "bad syntax") (source-wrap1820 e2557 w2559 s2560 mod2561))) tmp2562))) ($sc-dispatch tmp2562 (quote (any #(each (any any)) any . each-any))))) e2557))) (global-extend1789 (quote core) (quote quote) (lambda (e2587 r2588 w2589 s2590 mod2591) ((lambda (tmp2592) ((lambda (tmp2593) (if tmp2593 (apply (lambda (_2594 e2595) (build-data1769 s2590 (strip1838 e2595 w2589))) tmp2593) ((lambda (_2596) (syntax-violation (quote quote) (quote "bad syntax") (source-wrap1820 e2587 w2589 s2590 mod2591))) tmp2592))) ($sc-dispatch tmp2592 (quote (any any))))) e2587))) (global-extend1789 (quote core) (quote syntax) (letrec ((regen2604 (lambda (x2605) (let ((t2606 (car x2605))) (if (memv t2606 (quote (ref))) (build-lexical-reference1761 (quote value) (quote #f) (cadr x2605) (cadr x2605)) (if (memv t2606 (quote (primitive))) (build-primref1768 (quote #f) (cadr x2605)) (if (memv t2606 (quote (quote))) (build-data1769 (quote #f) (cadr x2605)) (if (memv t2606 (quote (lambda))) (build-lambda1767 (quote #f) (cadr x2605) (quote #f) (regen2604 (caddr x2605))) (if (memv t2606 (quote (map))) (let ((ls2607 (map regen2604 (cdr x2605)))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote map)) ls2607)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (car x2605)) (map regen2604 (cdr x2605))))))))))) (gen-vector2603 (lambda (x2608) (cond ((eq? (car x2608) (quote list)) (cons (quote vector) (cdr x2608))) ((eq? (car x2608) (quote quote)) (list (quote quote) (list->vector (cadr x2608)))) (else (list (quote list->vector) x2608))))) (gen-append2602 (lambda (x2609 y2610) (if (equal? y2610 (quote (quote ()))) x2609 (list (quote append) x2609 y2610)))) (gen-cons2601 (lambda (x2611 y2612) (let ((t2613 (car y2612))) (if (memv t2613 (quote (quote))) (if (eq? (car x2611) (quote quote)) (list (quote quote) (cons (cadr x2611) (cadr y2612))) (if (eq? (cadr y2612) (quote ())) (list (quote list) x2611) (list (quote cons) x2611 y2612))) (if (memv t2613 (quote (list))) (cons (quote list) (cons x2611 (cdr y2612))) (list (quote cons) x2611 y2612)))))) (gen-map2600 (lambda (e2614 map-env2615) (let ((formals2616 (map cdr map-env2615)) (actuals2617 (map (lambda (x2618) (list (quote ref) (car x2618))) map-env2615))) (cond ((eq? (car e2614) (quote ref)) (car actuals2617)) ((and-map (lambda (x2619) (and (eq? (car x2619) (quote ref)) (memq (cadr x2619) formals2616))) (cdr e2614)) (cons (quote map) (cons (list (quote primitive) (car e2614)) (map (let ((r2620 (map cons formals2616 actuals2617))) (lambda (x2621) (cdr (assq (cadr x2621) r2620)))) (cdr e2614))))) (else (cons (quote map) (cons (list (quote lambda) formals2616 e2614) actuals2617))))))) (gen-mappend2599 (lambda (e2622 map-env2623) (list (quote apply) (quote (primitive append)) (gen-map2600 e2622 map-env2623)))) (gen-ref2598 (lambda (src2624 var2625 level2626 maps2627) (if (fx=1753 level2626 (quote 0)) (values var2625 maps2627) (if (null? maps2627) (syntax-violation (quote syntax) (quote "missing ellipsis") src2624) (call-with-values (lambda () (gen-ref2598 src2624 var2625 (fx-1752 level2626 (quote 1)) (cdr maps2627))) (lambda (outer-var2628 outer-maps2629) (let ((b2630 (assq outer-var2628 (car maps2627)))) (if b2630 (values (cdr b2630) maps2627) (let ((inner-var2631 (gen-var1839 (quote tmp)))) (values inner-var2631 (cons (cons (cons outer-var2628 inner-var2631) (car maps2627)) outer-maps2629))))))))))) (gen-syntax2597 (lambda (src2632 e2633 r2634 maps2635 ellipsis?2636 mod2637) (if (id?1791 e2633) (let ((label2638 (id-var-name1813 e2633 (quote (()))))) (let ((b2639 (lookup1788 label2638 r2634 mod2637))) (if (eq? (binding-type1783 b2639) (quote syntax)) (call-with-values (lambda () (let ((var.lev2640 (binding-value1784 b2639))) (gen-ref2598 src2632 (car var.lev2640) (cdr var.lev2640) maps2635))) (lambda (var2641 maps2642) (values (list (quote ref) var2641) maps2642))) (if (ellipsis?2636 e2633) (syntax-violation (quote syntax) (quote "misplaced ellipsis") src2632) (values (list (quote quote) e2633) maps2635))))) ((lambda (tmp2643) ((lambda (tmp2644) (if (if tmp2644 (apply (lambda (dots2645 e2646) (ellipsis?2636 dots2645)) tmp2644) (quote #f)) (apply (lambda (dots2647 e2648) (gen-syntax2597 src2632 e2648 r2634 maps2635 (lambda (x2649) (quote #f)) mod2637)) tmp2644) ((lambda (tmp2650) (if (if tmp2650 (apply (lambda (x2651 dots2652 y2653) (ellipsis?2636 dots2652)) tmp2650) (quote #f)) (apply (lambda (x2654 dots2655 y2656) (letrec ((f2657 (lambda (y2658 k2659) ((lambda (tmp2663) ((lambda (tmp2664) (if (if tmp2664 (apply (lambda (dots2665 y2666) (ellipsis?2636 dots2665)) tmp2664) (quote #f)) (apply (lambda (dots2667 y2668) (f2657 y2668 (lambda (maps2669) (call-with-values (lambda () (k2659 (cons (quote ()) maps2669))) (lambda (x2670 maps2671) (if (null? (car maps2671)) (syntax-violation (quote syntax) (quote "extra ellipsis") src2632) (values (gen-mappend2599 x2670 (car maps2671)) (cdr maps2671)))))))) tmp2664) ((lambda (_2672) (call-with-values (lambda () (gen-syntax2597 src2632 y2658 r2634 maps2635 ellipsis?2636 mod2637)) (lambda (y2673 maps2674) (call-with-values (lambda () (k2659 maps2674)) (lambda (x2675 maps2676) (values (gen-append2602 x2675 y2673) maps2676)))))) tmp2663))) ($sc-dispatch tmp2663 (quote (any . any))))) y2658)))) (f2657 y2656 (lambda (maps2660) (call-with-values (lambda () (gen-syntax2597 src2632 x2654 r2634 (cons (quote ()) maps2660) ellipsis?2636 mod2637)) (lambda (x2661 maps2662) (if (null? (car maps2662)) (syntax-violation (quote syntax) (quote "extra ellipsis") src2632) (values (gen-map2600 x2661 (car maps2662)) (cdr maps2662))))))))) tmp2650) ((lambda (tmp2677) (if tmp2677 (apply (lambda (x2678 y2679) (call-with-values (lambda () (gen-syntax2597 src2632 x2678 r2634 maps2635 ellipsis?2636 mod2637)) (lambda (x2680 maps2681) (call-with-values (lambda () (gen-syntax2597 src2632 y2679 r2634 maps2681 ellipsis?2636 mod2637)) (lambda (y2682 maps2683) (values (gen-cons2601 x2680 y2682) maps2683)))))) tmp2677) ((lambda (tmp2684) (if tmp2684 (apply (lambda (e12685 e22686) (call-with-values (lambda () (gen-syntax2597 src2632 (cons e12685 e22686) r2634 maps2635 ellipsis?2636 mod2637)) (lambda (e2688 maps2689) (values (gen-vector2603 e2688) maps2689)))) tmp2684) ((lambda (_2690) (values (list (quote quote) e2633) maps2635)) tmp2643))) ($sc-dispatch tmp2643 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2643 (quote (any . any)))))) ($sc-dispatch tmp2643 (quote (any any . any)))))) ($sc-dispatch tmp2643 (quote (any any))))) e2633))))) (lambda (e2691 r2692 w2693 s2694 mod2695) (let ((e2696 (source-wrap1820 e2691 w2693 s2694 mod2695))) ((lambda (tmp2697) ((lambda (tmp2698) (if tmp2698 (apply (lambda (_2699 x2700) (call-with-values (lambda () (gen-syntax2597 e2696 x2700 r2692 (quote ()) ellipsis?1836 mod2695)) (lambda (e2701 maps2702) (regen2604 e2701)))) tmp2698) ((lambda (_2703) (syntax-violation (quote syntax) (quote "bad `syntax' form") e2696)) tmp2697))) ($sc-dispatch tmp2697 (quote (any any))))) e2696))))) (global-extend1789 (quote core) (quote lambda) (lambda (e2704 r2705 w2706 s2707 mod2708) ((lambda (tmp2709) ((lambda (tmp2710) (if tmp2710 (apply (lambda (_2711 c2712) (chi-lambda-clause1832 (source-wrap1820 e2704 w2706 s2707 mod2708) (quote #f) c2712 r2705 w2706 mod2708 (lambda (vars2713 docstring2714 body2715) (build-lambda1767 s2707 vars2713 docstring2714 body2715)))) tmp2710) (syntax-violation #f "source expression failed to match any pattern" tmp2709))) ($sc-dispatch tmp2709 (quote (any . any))))) e2704))) (global-extend1789 (quote core) (quote let) (letrec ((chi-let2716 (lambda (e2717 r2718 w2719 s2720 mod2721 constructor2722 ids2723 vals2724 exps2725) (if (not (valid-bound-ids?1816 ids2723)) (syntax-violation (quote let) (quote "duplicate bound variable") e2717) (let ((labels2726 (gen-labels1797 ids2723)) (new-vars2727 (map gen-var1839 ids2723))) (let ((nw2728 (make-binding-wrap1808 ids2723 labels2726 w2719)) (nr2729 (extend-var-env1786 labels2726 new-vars2727 r2718))) (constructor2722 s2720 new-vars2727 (map (lambda (x2730) (chi1827 x2730 r2718 w2719 mod2721)) vals2724) (chi-body1831 exps2725 (source-wrap1820 e2717 nw2728 s2720 mod2721) nr2729 nw2728 mod2721)))))))) (lambda (e2731 r2732 w2733 s2734 mod2735) ((lambda (tmp2736) ((lambda (tmp2737) (if tmp2737 (apply (lambda (_2738 id2739 val2740 e12741 e22742) (chi-let2716 e2731 r2732 w2733 s2734 mod2735 build-let1771 id2739 val2740 (cons e12741 e22742))) tmp2737) ((lambda (tmp2746) (if (if tmp2746 (apply (lambda (_2747 f2748 id2749 val2750 e12751 e22752) (id?1791 f2748)) tmp2746) (quote #f)) (apply (lambda (_2753 f2754 id2755 val2756 e12757 e22758) (chi-let2716 e2731 r2732 w2733 s2734 mod2735 build-named-let1772 (cons f2754 id2755) val2756 (cons e12757 e22758))) tmp2746) ((lambda (_2762) (syntax-violation (quote let) (quote "bad let") (source-wrap1820 e2731 w2733 s2734 mod2735))) tmp2736))) ($sc-dispatch tmp2736 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2736 (quote (any #(each (any any)) any . each-any))))) e2731)))) (global-extend1789 (quote core) (quote letrec) (lambda (e2763 r2764 w2765 s2766 mod2767) ((lambda (tmp2768) ((lambda (tmp2769) (if tmp2769 (apply (lambda (_2770 id2771 val2772 e12773 e22774) (let ((ids2775 id2771)) (if (not (valid-bound-ids?1816 ids2775)) (syntax-violation (quote letrec) (quote "duplicate bound variable") e2763) (let ((labels2777 (gen-labels1797 ids2775)) (new-vars2778 (map gen-var1839 ids2775))) (let ((w2779 (make-binding-wrap1808 ids2775 labels2777 w2765)) (r2780 (extend-var-env1786 labels2777 new-vars2778 r2764))) (build-letrec1773 s2766 new-vars2778 (map (lambda (x2781) (chi1827 x2781 r2780 w2779 mod2767)) val2772) (chi-body1831 (cons e12773 e22774) (source-wrap1820 e2763 w2779 s2766 mod2767) r2780 w2779 mod2767))))))) tmp2769) ((lambda (_2784) (syntax-violation (quote letrec) (quote "bad letrec") (source-wrap1820 e2763 w2765 s2766 mod2767))) tmp2768))) ($sc-dispatch tmp2768 (quote (any #(each (any any)) any . each-any))))) e2763))) (global-extend1789 (quote core) (quote set!) (lambda (e2785 r2786 w2787 s2788 mod2789) ((lambda (tmp2790) ((lambda (tmp2791) (if (if tmp2791 (apply (lambda (_2792 id2793 val2794) (id?1791 id2793)) tmp2791) (quote #f)) (apply (lambda (_2795 id2796 val2797) (let ((val2798 (chi1827 val2797 r2786 w2787 mod2789)) (n2799 (id-var-name1813 id2796 w2787))) (let ((b2800 (lookup1788 n2799 r2786 mod2789))) (let ((t2801 (binding-type1783 b2800))) (if (memv t2801 (quote (lexical))) (build-lexical-assignment1762 s2788 (syntax->datum id2796) (binding-value1784 b2800) val2798) (if (memv t2801 (quote (global))) (build-global-assignment1765 s2788 n2799 val2798 mod2789) (if (memv t2801 (quote (displaced-lexical))) (syntax-violation (quote set!) (quote "identifier out of context") (wrap1819 id2796 w2787 mod2789)) (syntax-violation (quote set!) (quote "bad set!") (source-wrap1820 e2785 w2787 s2788 mod2789))))))))) tmp2791) ((lambda (tmp2802) (if tmp2802 (apply (lambda (_2803 head2804 tail2805 val2806) (call-with-values (lambda () (syntax-type1825 head2804 r2786 (quote (())) (quote #f) (quote #f) mod2789)) (lambda (type2807 value2808 ee2809 ww2810 ss2811 modmod2812) (let ((t2813 type2807)) (if (memv t2813 (quote (module-ref))) (let ((val2814 (chi1827 val2806 r2786 w2787 mod2789))) (call-with-values (lambda () (value2808 (cons head2804 tail2805))) (lambda (id2816 mod2817) (build-global-assignment1765 s2788 id2816 val2814 mod2817)))) (build-application1759 s2788 (chi1827 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2804) r2786 w2787 mod2789) (map (lambda (e2818) (chi1827 e2818 r2786 w2787 mod2789)) (append tail2805 (list val2806))))))))) tmp2802) ((lambda (_2820) (syntax-violation (quote set!) (quote "bad set!") (source-wrap1820 e2785 w2787 s2788 mod2789))) tmp2790))) ($sc-dispatch tmp2790 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2790 (quote (any any any))))) e2785))) (global-extend1789 (quote module-ref) (quote @) (lambda (e2821) ((lambda (tmp2822) ((lambda (tmp2823) (if (if tmp2823 (apply (lambda (_2824 mod2825 id2826) (and (and-map id?1791 mod2825) (id?1791 id2826))) tmp2823) (quote #f)) (apply (lambda (_2828 mod2829 id2830) (values (syntax->datum id2830) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2829)))) tmp2823) (syntax-violation #f "source expression failed to match any pattern" tmp2822))) ($sc-dispatch tmp2822 (quote (any each-any any))))) e2821))) (global-extend1789 (quote module-ref) (quote @@) (lambda (e2832) ((lambda (tmp2833) ((lambda (tmp2834) (if (if tmp2834 (apply (lambda (_2835 mod2836 id2837) (and (and-map id?1791 mod2836) (id?1791 id2837))) tmp2834) (quote #f)) (apply (lambda (_2839 mod2840 id2841) (values (syntax->datum id2841) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2840)))) tmp2834) (syntax-violation #f "source expression failed to match any pattern" tmp2833))) ($sc-dispatch tmp2833 (quote (any each-any any))))) e2832))) (global-extend1789 (quote begin) (quote begin) (quote ())) (global-extend1789 (quote define) (quote define) (quote ())) (global-extend1789 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1789 (quote eval-when) (quote eval-when) (quote ())) (global-extend1789 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2846 (lambda (x2847 keys2848 clauses2849 r2850 mod2851) (if (null? clauses2849) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote syntax-violation)) (list (quote #f) (quote "source expression failed to match any pattern") x2847)) ((lambda (tmp2852) ((lambda (tmp2853) (if tmp2853 (apply (lambda (pat2854 exp2855) (if (and (id?1791 pat2854) (and-map (lambda (x2856) (not (free-id=?1814 pat2854 x2856))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2848))) (let ((labels2857 (list (gen-label1796))) (var2858 (gen-var1839 pat2854))) (build-application1759 (quote #f) (build-lambda1767 (quote #f) (list var2858) (quote #f) (chi1827 exp2855 (extend-env1785 labels2857 (list (cons (quote syntax) (cons var2858 (quote 0)))) r2850) (make-binding-wrap1808 (list pat2854) labels2857 (quote (()))) mod2851)) (list x2847))) (gen-clause2845 x2847 keys2848 (cdr clauses2849) r2850 pat2854 (quote #t) exp2855 mod2851))) tmp2853) ((lambda (tmp2859) (if tmp2859 (apply (lambda (pat2860 fender2861 exp2862) (gen-clause2845 x2847 keys2848 (cdr clauses2849) r2850 pat2860 fender2861 exp2862 mod2851)) tmp2859) ((lambda (_2863) (syntax-violation (quote syntax-case) (quote "invalid clause") (car clauses2849))) tmp2852))) ($sc-dispatch tmp2852 (quote (any any any)))))) ($sc-dispatch tmp2852 (quote (any any))))) (car clauses2849))))) (gen-clause2845 (lambda (x2864 keys2865 clauses2866 r2867 pat2868 fender2869 exp2870 mod2871) (call-with-values (lambda () (convert-pattern2843 pat2868 keys2865)) (lambda (p2872 pvars2873) (cond ((not (distinct-bound-ids?1817 (map car pvars2873))) (syntax-violation (quote syntax-case) (quote "duplicate pattern variable") pat2868)) ((not (and-map (lambda (x2874) (not (ellipsis?1836 (car x2874)))) pvars2873)) (syntax-violation (quote syntax-case) (quote "misplaced ellipsis") pat2868)) (else (let ((y2875 (gen-var1839 (quote tmp)))) (build-application1759 (quote #f) (build-lambda1767 (quote #f) (list y2875) (quote #f) (let ((y2876 (build-lexical-reference1761 (quote value) (quote #f) (quote tmp) y2875))) (build-conditional1760 (quote #f) ((lambda (tmp2877) ((lambda (tmp2878) (if tmp2878 (apply (lambda () y2876) tmp2878) ((lambda (_2879) (build-conditional1760 (quote #f) y2876 (build-dispatch-call2844 pvars2873 fender2869 y2876 r2867 mod2871) (build-data1769 (quote #f) (quote #f)))) tmp2877))) ($sc-dispatch tmp2877 (quote #(atom #t))))) fender2869) (build-dispatch-call2844 pvars2873 exp2870 y2876 r2867 mod2871) (gen-syntax-case2846 x2864 keys2865 clauses2866 r2867 mod2871)))) (list (if (eq? p2872 (quote any)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote list)) (list x2864)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote $sc-dispatch)) (list x2864 (build-data1769 (quote #f) p2872))))))))))))) (build-dispatch-call2844 (lambda (pvars2880 exp2881 y2882 r2883 mod2884) (let ((ids2885 (map car pvars2880)) (levels2886 (map cdr pvars2880))) (let ((labels2887 (gen-labels1797 ids2885)) (new-vars2888 (map gen-var1839 ids2885))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote apply)) (list (build-lambda1767 (quote #f) new-vars2888 (quote #f) (chi1827 exp2881 (extend-env1785 labels2887 (map (lambda (var2889 level2890) (cons (quote syntax) (cons var2889 level2890))) new-vars2888 (map cdr pvars2880)) r2883) (make-binding-wrap1808 ids2885 labels2887 (quote (()))) mod2884)) y2882)))))) (convert-pattern2843 (lambda (pattern2891 keys2892) (letrec ((cvt2893 (lambda (p2894 n2895 ids2896) (if (id?1791 p2894) (if (bound-id-member?1818 p2894 keys2892) (values (vector (quote free-id) p2894) ids2896) (values (quote any) (cons (cons p2894 n2895) ids2896))) ((lambda (tmp2897) ((lambda (tmp2898) (if (if tmp2898 (apply (lambda (x2899 dots2900) (ellipsis?1836 dots2900)) tmp2898) (quote #f)) (apply (lambda (x2901 dots2902) (call-with-values (lambda () (cvt2893 x2901 (fx+1751 n2895 (quote 1)) ids2896)) (lambda (p2903 ids2904) (values (if (eq? p2903 (quote any)) (quote each-any) (vector (quote each) p2903)) ids2904)))) tmp2898) ((lambda (tmp2905) (if tmp2905 (apply (lambda (x2906 y2907) (call-with-values (lambda () (cvt2893 y2907 n2895 ids2896)) (lambda (y2908 ids2909) (call-with-values (lambda () (cvt2893 x2906 n2895 ids2909)) (lambda (x2910 ids2911) (values (cons x2910 y2908) ids2911)))))) tmp2905) ((lambda (tmp2912) (if tmp2912 (apply (lambda () (values (quote ()) ids2896)) tmp2912) ((lambda (tmp2913) (if tmp2913 (apply (lambda (x2914) (call-with-values (lambda () (cvt2893 x2914 n2895 ids2896)) (lambda (p2916 ids2917) (values (vector (quote vector) p2916) ids2917)))) tmp2913) ((lambda (x2918) (values (vector (quote atom) (strip1838 p2894 (quote (())))) ids2896)) tmp2897))) ($sc-dispatch tmp2897 (quote #(vector each-any)))))) ($sc-dispatch tmp2897 (quote ()))))) ($sc-dispatch tmp2897 (quote (any . any)))))) ($sc-dispatch tmp2897 (quote (any any))))) p2894))))) (cvt2893 pattern2891 (quote 0) (quote ())))))) (lambda (e2919 r2920 w2921 s2922 mod2923) (let ((e2924 (source-wrap1820 e2919 w2921 s2922 mod2923))) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 val2928 key2929 m2930) (if (and-map (lambda (x2931) (and (id?1791 x2931) (not (ellipsis?1836 x2931)))) key2929) (let ((x2933 (gen-var1839 (quote tmp)))) (build-application1759 s2922 (build-lambda1767 (quote #f) (list x2933) (quote #f) (gen-syntax-case2846 (build-lexical-reference1761 (quote value) (quote #f) (quote tmp) x2933) key2929 m2930 r2920 mod2923)) (list (chi1827 val2928 r2920 (quote (())) mod2923)))) (syntax-violation (quote syntax-case) (quote "invalid literals list") e2924))) tmp2926) (syntax-violation #f "source expression failed to match any pattern" tmp2925))) ($sc-dispatch tmp2925 (quote (any any each-any . each-any))))) e2924))))) (set! sc-expand (lambda (x2937 . rest2936) (if (and (pair? x2937) (equal? (car x2937) noexpand1749)) (cadr x2937) (let ((m2938 (if (null? rest2936) (quote e) (car rest2936))) (esew2939 (if (or (null? rest2936) (null? (cdr rest2936))) (quote (eval)) (cadr rest2936)))) (with-fluid* *mode*1750 m2938 (lambda () (chi-top1826 x2937 (quote ()) (quote ((top))) m2938 esew2939 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x2940) (nonsymbol-id?1790 x2940))) (set! datum->syntax (lambda (id2941 datum2942) (make-syntax-object1774 datum2942 (syntax-object-wrap1777 id2941) (quote #f)))) (set! syntax->datum (lambda (x2943) (strip1838 x2943 (quote (()))))) (set! generate-temporaries (lambda (ls2944) (begin (let ((x2945 ls2944)) (if (not (list? x2945)) (syntax-violation (quote generate-temporaries) (quote "invalid argument") x2945))) (map (lambda (x2946) (wrap1819 (gensym) (quote ((top))) (quote #f))) ls2944)))) (set! free-identifier=? (lambda (x2947 y2948) (begin (let ((x2949 x2947)) (if (not (nonsymbol-id?1790 x2949)) (syntax-violation (quote free-identifier=?) (quote "invalid argument") x2949))) (let ((x2950 y2948)) (if (not (nonsymbol-id?1790 x2950)) (syntax-violation (quote free-identifier=?) (quote "invalid argument") x2950))) (free-id=?1814 x2947 y2948)))) (set! bound-identifier=? (lambda (x2951 y2952) (begin (let ((x2953 x2951)) (if (not (nonsymbol-id?1790 x2953)) (syntax-violation (quote bound-identifier=?) (quote "invalid argument") x2953))) (let ((x2954 y2952)) (if (not (nonsymbol-id?1790 x2954)) (syntax-violation (quote bound-identifier=?) (quote "invalid argument") x2954))) (bound-id=?1815 x2951 y2952)))) (set! syntax-violation (lambda (who2958 message2957 form2956 . subform2955) (begin (let ((x2959 who2958)) (if (not ((lambda (x2960) (or (not x2960) (string? x2960) (symbol? x2960))) x2959)) (syntax-violation (quote syntax-violation) (quote "invalid argument") x2959))) (let ((x2961 message2957)) (if (not (string? x2961)) (syntax-violation (quote syntax-violation) (quote "invalid argument") x2961))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2958 (quote "~a: ") (quote "")) (quote "~a ") (if (null? subform2955) (quote "in ~a") (quote "in subform `~s' of `~s'"))) (let ((tail2962 (cons message2957 (map (lambda (x2963) (strip1838 x2963 (quote (())))) (append subform2955 (list form2956)))))) (if who2958 (cons who2958 tail2962) tail2962)) (quote #f))))) (letrec ((match2968 (lambda (e2969 p2970 w2971 r2972 mod2973) (cond ((not r2972) (quote #f)) ((eq? p2970 (quote any)) (cons (wrap1819 e2969 w2971 mod2973) r2972)) ((syntax-object?1775 e2969) (match*2967 (let ((e2974 (syntax-object-expression1776 e2969))) (if (annotation? e2974) (annotation-expression e2974) e2974)) p2970 (join-wraps1810 w2971 (syntax-object-wrap1777 e2969)) r2972 (syntax-object-module1778 e2969))) (else (match*2967 (let ((e2975 e2969)) (if (annotation? e2975) (annotation-expression e2975) e2975)) p2970 w2971 r2972 mod2973))))) (match*2967 (lambda (e2976 p2977 w2978 r2979 mod2980) (cond ((null? p2977) (and (null? e2976) r2979)) ((pair? p2977) (and (pair? e2976) (match2968 (car e2976) (car p2977) w2978 (match2968 (cdr e2976) (cdr p2977) w2978 r2979 mod2980) mod2980))) ((eq? p2977 (quote each-any)) (let ((l2981 (match-each-any2965 e2976 w2978 mod2980))) (and l2981 (cons l2981 r2979)))) (else (let ((t2982 (vector-ref p2977 (quote 0)))) (if (memv t2982 (quote (each))) (if (null? e2976) (match-empty2966 (vector-ref p2977 (quote 1)) r2979) (let ((l2983 (match-each2964 e2976 (vector-ref p2977 (quote 1)) w2978 mod2980))) (and l2983 (letrec ((collect2984 (lambda (l2985) (if (null? (car l2985)) r2979 (cons (map car l2985) (collect2984 (map cdr l2985))))))) (collect2984 l2983))))) (if (memv t2982 (quote (free-id))) (and (id?1791 e2976) (free-id=?1814 (wrap1819 e2976 w2978 mod2980) (vector-ref p2977 (quote 1))) r2979) (if (memv t2982 (quote (atom))) (and (equal? (vector-ref p2977 (quote 1)) (strip1838 e2976 w2978)) r2979) (if (memv t2982 (quote (vector))) (and (vector? e2976) (match2968 (vector->list e2976) (vector-ref p2977 (quote 1)) w2978 r2979 mod2980))))))))))) (match-empty2966 (lambda (p2986 r2987) (cond ((null? p2986) r2987) ((eq? p2986 (quote any)) (cons (quote ()) r2987)) ((pair? p2986) (match-empty2966 (car p2986) (match-empty2966 (cdr p2986) r2987))) ((eq? p2986 (quote each-any)) (cons (quote ()) r2987)) (else (let ((t2988 (vector-ref p2986 (quote 0)))) (if (memv t2988 (quote (each))) (match-empty2966 (vector-ref p2986 (quote 1)) r2987) (if (memv t2988 (quote (free-id atom))) r2987 (if (memv t2988 (quote (vector))) (match-empty2966 (vector-ref p2986 (quote 1)) r2987))))))))) (match-each-any2965 (lambda (e2989 w2990 mod2991) (cond ((annotation? e2989) (match-each-any2965 (annotation-expression e2989) w2990 mod2991)) ((pair? e2989) (let ((l2992 (match-each-any2965 (cdr e2989) w2990 mod2991))) (and l2992 (cons (wrap1819 (car e2989) w2990 mod2991) l2992)))) ((null? e2989) (quote ())) ((syntax-object?1775 e2989) (match-each-any2965 (syntax-object-expression1776 e2989) (join-wraps1810 w2990 (syntax-object-wrap1777 e2989)) mod2991)) (else (quote #f))))) (match-each2964 (lambda (e2993 p2994 w2995 mod2996) (cond ((annotation? e2993) (match-each2964 (annotation-expression e2993) p2994 w2995 mod2996)) ((pair? e2993) (let ((first2997 (match2968 (car e2993) p2994 w2995 (quote ()) mod2996))) (and first2997 (let ((rest2998 (match-each2964 (cdr e2993) p2994 w2995 mod2996))) (and rest2998 (cons first2997 rest2998)))))) ((null? e2993) (quote ())) ((syntax-object?1775 e2993) (match-each2964 (syntax-object-expression1776 e2993) p2994 (join-wraps1810 w2995 (syntax-object-wrap1777 e2993)) (syntax-object-module1778 e2993))) (else (quote #f)))))) (set! $sc-dispatch (lambda (e2999 p3000) (cond ((eq? p3000 (quote any)) (list e2999)) ((syntax-object?1775 e2999) (match*2967 (let ((e3001 (syntax-object-expression1776 e2999))) (if (annotation? e3001) (annotation-expression e3001) e3001)) p3000 (syntax-object-wrap1777 e2999) (quote ()) (syntax-object-module1778 e2999))) (else (match*2967 (let ((e3002 e2999)) (if (annotation? e3002) (annotation-expression e3002) e3002)) p3000 (quote (())) (quote ()) (quote #f)))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x3003) ((lambda (tmp3004) ((lambda (tmp3005) (if tmp3005 (apply (lambda (_3006 e13007 e23008) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13007 e23008))) tmp3005) ((lambda (tmp3010) (if tmp3010 (apply (lambda (_3011 out3012 in3013 e13014 e23015) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3013 (quote ()) (list out3012 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13014 e23015))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (_3018 out3019 in3020 e13021 e23022) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3020) (quote ()) (list out3019 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13021 e23022))))) tmp3017) (syntax-violation #f "source expression failed to match any pattern" tmp3004))) ($sc-dispatch tmp3004 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3004 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3004 (quote (any () any . each-any))))) x3003)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3026) ((lambda (tmp3027) ((lambda (tmp3028) (if tmp3028 (apply (lambda (_3029 k3030 keyword3031 pattern3032 template3033) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k3030 (map (lambda (tmp3036 tmp3035) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3035) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3036))) template3033 pattern3032)))))) tmp3028) (syntax-violation #f "source expression failed to match any pattern" tmp3027))) ($sc-dispatch tmp3027 (quote (any each-any . #(each ((any . any) any))))))) x3026)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3037) ((lambda (tmp3038) ((lambda (tmp3039) (if (if tmp3039 (apply (lambda (let*3040 x3041 v3042 e13043 e23044) (and-map identifier? x3041)) tmp3039) (quote #f)) (apply (lambda (let*3046 x3047 v3048 e13049 e23050) (letrec ((f3051 (lambda (bindings3052) (if (null? bindings3052) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e13049 e23050))) ((lambda (tmp3056) ((lambda (tmp3057) (if tmp3057 (apply (lambda (body3058 binding3059) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding3059) body3058)) tmp3057) (syntax-violation #f "source expression failed to match any pattern" tmp3056))) ($sc-dispatch tmp3056 (quote (any any))))) (list (f3051 (cdr bindings3052)) (car bindings3052))))))) (f3051 (map list x3047 v3048)))) tmp3039) (syntax-violation #f "source expression failed to match any pattern" tmp3038))) ($sc-dispatch tmp3038 (quote (any #(each (any any)) any . each-any))))) x3037)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3060) ((lambda (tmp3061) ((lambda (tmp3062) (if tmp3062 (apply (lambda (_3063 var3064 init3065 step3066 e03067 e13068 c3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (step3072) ((lambda (tmp3073) ((lambda (tmp3074) (if tmp3074 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3064 init3065) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03067) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3069 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3072))))))) tmp3074) ((lambda (tmp3079) (if tmp3079 (apply (lambda (e13080 e23081) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3064 init3065) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03067 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e13080 e23081)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3069 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3072))))))) tmp3079) (syntax-violation #f "source expression failed to match any pattern" tmp3073))) ($sc-dispatch tmp3073 (quote (any . each-any)))))) ($sc-dispatch tmp3073 (quote ())))) e13068)) tmp3071) (syntax-violation #f "source expression failed to match any pattern" tmp3070))) ($sc-dispatch tmp3070 (quote each-any)))) (map (lambda (v3088 s3089) ((lambda (tmp3090) ((lambda (tmp3091) (if tmp3091 (apply (lambda () v3088) tmp3091) ((lambda (tmp3092) (if tmp3092 (apply (lambda (e3093) e3093) tmp3092) ((lambda (_3094) (syntax-violation (quote do) (quote "bad step expression") orig-x3060 s3089)) tmp3090))) ($sc-dispatch tmp3090 (quote (any)))))) ($sc-dispatch tmp3090 (quote ())))) s3089)) var3064 step3066))) tmp3062) (syntax-violation #f "source expression failed to match any pattern" tmp3061))) ($sc-dispatch tmp3061 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3060)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3097 (lambda (x3101 y3102) ((lambda (tmp3103) ((lambda (tmp3104) (if tmp3104 (apply (lambda (x3105 y3106) ((lambda (tmp3107) ((lambda (tmp3108) (if tmp3108 (apply (lambda (dy3109) ((lambda (tmp3110) ((lambda (tmp3111) (if tmp3111 (apply (lambda (dx3112) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx3112 dy3109))) tmp3111) ((lambda (_3113) (if (null? dy3109) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3105) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3105 y3106))) tmp3110))) ($sc-dispatch tmp3110 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x3105)) tmp3108) ((lambda (tmp3114) (if tmp3114 (apply (lambda (stuff3115) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x3105 stuff3115))) tmp3114) ((lambda (else3116) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3105 y3106)) tmp3107))) ($sc-dispatch tmp3107 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp3107 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y3106)) tmp3104) (syntax-violation #f "source expression failed to match any pattern" tmp3103))) ($sc-dispatch tmp3103 (quote (any any))))) (list x3101 y3102)))) (quasiappend3098 (lambda (x3117 y3118) ((lambda (tmp3119) ((lambda (tmp3120) (if tmp3120 (apply (lambda (x3121 y3122) ((lambda (tmp3123) ((lambda (tmp3124) (if tmp3124 (apply (lambda () x3121) tmp3124) ((lambda (_3125) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3121 y3122)) tmp3123))) ($sc-dispatch tmp3123 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y3122)) tmp3120) (syntax-violation #f "source expression failed to match any pattern" tmp3119))) ($sc-dispatch tmp3119 (quote (any any))))) (list x3117 y3118)))) (quasivector3099 (lambda (x3126) ((lambda (tmp3127) ((lambda (x3128) ((lambda (tmp3129) ((lambda (tmp3130) (if tmp3130 (apply (lambda (x3131) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x3131))) tmp3130) ((lambda (tmp3133) (if tmp3133 (apply (lambda (x3134) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3134)) tmp3133) ((lambda (_3136) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3128)) tmp3129))) ($sc-dispatch tmp3129 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp3129 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x3128)) tmp3127)) x3126))) (quasi3100 (lambda (p3137 lev3138) ((lambda (tmp3139) ((lambda (tmp3140) (if tmp3140 (apply (lambda (p3141) (if (= lev3138 (quote 0)) p3141 (quasicons3097 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3100 (list p3141) (- lev3138 (quote 1)))))) tmp3140) ((lambda (tmp3142) (if tmp3142 (apply (lambda (p3143 q3144) (if (= lev3138 (quote 0)) (quasiappend3098 p3143 (quasi3100 q3144 lev3138)) (quasicons3097 (quasicons3097 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3100 (list p3143) (- lev3138 (quote 1)))) (quasi3100 q3144 lev3138)))) tmp3142) ((lambda (tmp3145) (if tmp3145 (apply (lambda (p3146) (quasicons3097 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3100 (list p3146) (+ lev3138 (quote 1))))) tmp3145) ((lambda (tmp3147) (if tmp3147 (apply (lambda (p3148 q3149) (quasicons3097 (quasi3100 p3148 lev3138) (quasi3100 q3149 lev3138))) tmp3147) ((lambda (tmp3150) (if tmp3150 (apply (lambda (x3151) (quasivector3099 (quasi3100 x3151 lev3138))) tmp3150) ((lambda (p3153) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p3153)) tmp3139))) ($sc-dispatch tmp3139 (quote #(vector each-any)))))) ($sc-dispatch tmp3139 (quote (any . any)))))) ($sc-dispatch tmp3139 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp3139 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp3139 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p3137)))) (lambda (x3154) ((lambda (tmp3155) ((lambda (tmp3156) (if tmp3156 (apply (lambda (_3157 e3158) (quasi3100 e3158 (quote 0))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any any))))) x3154))))) +(define include (make-syncase-macro (quote macro) (lambda (x3159) (letrec ((read-file3160 (lambda (fn3161 k3162) (let ((p3163 (open-input-file fn3161))) (letrec ((f3164 (lambda (x3165) (if (eof-object? x3165) (begin (close-input-port p3163) (quote ())) (cons (datum->syntax k3162 x3165) (f3164 (read p3163))))))) (f3164 (read p3163))))))) ((lambda (tmp3166) ((lambda (tmp3167) (if tmp3167 (apply (lambda (k3168 filename3169) (let ((fn3170 (syntax->datum filename3169))) ((lambda (tmp3171) ((lambda (tmp3172) (if tmp3172 (apply (lambda (exp3173) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp3173)) tmp3172) (syntax-violation #f "source expression failed to match any pattern" tmp3171))) ($sc-dispatch tmp3171 (quote each-any)))) (read-file3160 fn3170 k3168)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any any))))) x3159))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x3175) ((lambda (tmp3176) ((lambda (tmp3177) (if tmp3177 (apply (lambda (_3178 e3179) (syntax-violation (quote unquote) (quote "expression not valid outside of quasiquote") x3175)) tmp3177) (syntax-violation #f "source expression failed to match any pattern" tmp3176))) ($sc-dispatch tmp3176 (quote (any any))))) x3175)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 e3184) (syntax-violation (quote unquote-splicing) (quote "expression not valid outside of quasiquote") x3180)) tmp3182) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any))))) x3180)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3185) ((lambda (tmp3186) ((lambda (tmp3187) (if tmp3187 (apply (lambda (_3188 e3189 m13190 m23191) ((lambda (tmp3192) ((lambda (body3193) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3189)) body3193)) tmp3192)) (letrec ((f3194 (lambda (clause3195 clauses3196) (if (null? clauses3196) ((lambda (tmp3198) ((lambda (tmp3199) (if tmp3199 (apply (lambda (e13200 e23201) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13200 e23201))) tmp3199) ((lambda (tmp3203) (if tmp3203 (apply (lambda (k3204 e13205 e23206) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3204)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13205 e23206)))) tmp3203) ((lambda (_3209) (syntax-violation (quote case) (quote "bad clause") x3185 clause3195)) tmp3198))) ($sc-dispatch tmp3198 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3198 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause3195) ((lambda (tmp3210) ((lambda (rest3211) ((lambda (tmp3212) ((lambda (tmp3213) (if tmp3213 (apply (lambda (k3214 e13215 e23216) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3214)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13215 e23216)) rest3211)) tmp3213) ((lambda (_3219) (syntax-violation (quote case) (quote "bad clause") x3185 clause3195)) tmp3212))) ($sc-dispatch tmp3212 (quote (each-any any . each-any))))) clause3195)) tmp3210)) (f3194 (car clauses3196) (cdr clauses3196))))))) (f3194 m13190 m23191)))) tmp3187) (syntax-violation #f "source expression failed to match any pattern" tmp3186))) ($sc-dispatch tmp3186 (quote (any any any . each-any))))) x3185)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3220) ((lambda (tmp3221) ((lambda (tmp3222) (if tmp3222 (apply (lambda (_3223 e3224) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3224)) (list (cons _3223 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e3224 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp3222) (syntax-violation #f "source expression failed to match any pattern" tmp3221))) ($sc-dispatch tmp3221 (quote (any any))))) x3220)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 7173ba763..85ef13814 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -304,7 +304,7 @@ (primitive-eval `(,noexpand ,(case (fluid-ref *mode*) - ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x)) + ((c) ((@ (language tree-il) tree-il->scheme) x)) (else x)))))) (define local-eval-hook @@ -312,7 +312,7 @@ (primitive-eval `(,noexpand ,(case (fluid-ref *mode*) - ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x)) + ((c) ((@ (language tree-il) tree-il->scheme) x)) (else x)))))) (define-syntax gensym-hook @@ -351,132 +351,150 @@ ;;; output constructors -(define (build-annotated src exp) - (if (and src (not (annotation? exp))) - (make-annotation exp src #t) - exp)) +(define build-application + (lambda (source fun-exp arg-exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps)) + (else `(,fun-exp . ,arg-exps))))) -(define-syntax build-application - (syntax-rules () - ((_ source fun-exp arg-exps) - (build-annotated source `(,fun-exp . ,arg-exps))))) - -(define-syntax build-conditional - (syntax-rules () - ((_ source test-exp then-exp else-exp) - (build-annotated source `(if ,test-exp ,then-exp ,else-exp))))) +(define build-conditional + (lambda (source test-exp then-exp else-exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-conditional) + source test-exp then-exp else-exp)) + (else `(if ,test-exp ,then-exp ,else-exp))))) (define build-lexical-reference (lambda (type source name var) - (build-annotated - source - (case (fluid-ref *mode*) - ((c) ((@ (ice-9 expand-support) make-lexical) source name var)) - (else var))))) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-ref) source name var)) + (else var)))) (define build-lexical-assignment (lambda (source name var exp) - (build-annotated - source - `(set! ,(build-lexical-reference 'set no-source name var) - ,exp)))) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-set) source name var exp)) + (else `(set! ,var ,exp))))) ;; Before modules are booted, we can't expand into data structures from -;; (ice-9 expand-support) -- we need to give the evaluator the +;; (language tree-il) -- we need to give the evaluator the ;; s-expressions that it understands natively. Actually the real truth ;; of the matter is that the evaluator doesn't understand expand-support ;; structures at all. So until we fix the evaluator, if ever, the -;; conflation that we should use expand-support iff we are compiling +;; conflation that we should use tree-il iff we are compiling ;; holds true. ;; +(define (analyze-variable mod var modref-cont bare-cont) + (if (not mod) + (bare-cont var) + (let ((kind (car mod)) + (mod (cdr mod))) + (case kind + ((public) (modref-cont mod var #t)) + ((private) (if (not (equal? mod (module-name (current-module)))) + (modref-cont mod var #f) + (bare-cont var))) + ((bare) (bare-cont var)) + ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + (modref-cont mod var #f) + (bare-cont var))) + (else (syntax-violation #f "bad module kind" var mod)))))) + (define build-global-reference (lambda (source var mod) - (build-annotated - source - (if (not mod) - var - (let ((make-module-ref - (case (fluid-ref *mode*) - ((c) (@ (ice-9 expand-support) make-module-ref)) - (else (lambda (source mod var public?) - (list (if public? '@ '@@) mod var))))) - (kind (car mod)) - (mod (cdr mod))) - (case kind - ((public) (make-module-ref #f mod var #t)) - ((private) (if (not (equal? mod (module-name (current-module)))) - (make-module-ref #f mod var #f) - var)) - ((bare) var) - ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) - (module-variable (resolve-module mod) var)) - (make-module-ref #f mod var #f) - var)) - (else (syntax-violation #f "bad module kind" var mod)))))))) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) source mod var public?)) + (else (list (if public? '@ '@@) mod var)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) source var)) + (else var)))))) (define build-global-assignment (lambda (source var exp mod) - (let ((ref (build-global-reference source var mod))) - (build-annotated - source - `(set! ,ref ,exp))))) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-set) source mod var public? exp)) + (else `(set! ,(list (if public? '@ '@@) mod var) ,exp)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-set) source var exp)) + (else `(set! ,var ,exp))))))) -(define-syntax build-global-definition - (syntax-rules () - ((_ source var exp) - (build-annotated source `(define ,var ,exp))))) +(define build-global-definition + (lambda (source var exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-define) source var exp)) + (else `(define ,var ,exp))))) -(define-syntax build-lambda - (syntax-rules () - ((_ src vars docstring exp) - (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '()) - ,exp))) - ((_ src vars exp) - (build-annotated src `(lambda ,vars ,exp))))) +(define build-lambda + (lambda (src vars docstring exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lambda) src vars + (if docstring `((documentation . ,docstring)) '()) + exp)) + (else `(lambda ,vars ,@(if docstring (list docstring) '()) + ,exp))))) -;; FIXME: wingo: add modules here somehow? -(define-syntax build-primref - (syntax-rules () - ((_ src name) (build-annotated src name)) - ((_ src level name) (build-annotated src name)))) +(define build-primref + (lambda (src name) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-primitive-ref) src name)) + ;; hygiene guile is a hack + (else (build-global-reference src name '(hygiene guile)))))) (define (build-data src exp) - (if (and (self-evaluating? exp) - (not (vector? exp))) - (build-annotated src exp) - (build-annotated src (list 'quote exp)))) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-const) src exp)) + (else (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))))) (define build-sequence (lambda (src exps) (if (null? (cdr exps)) - (build-annotated src (car exps)) - (build-annotated src `(begin ,@exps))))) + (car exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-sequence) src exps)) + (else `(begin ,@exps)))))) (define build-let (lambda (src vars val-exps body-exp) (if (null? vars) - (build-annotated src body-exp) - (build-annotated src `(let ,(map list vars val-exps) ,body-exp))))) + body-exp + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-let) src vars val-exps body-exp)) + (else `(let ,(map list vars val-exps) ,body-exp)))))) (define build-named-let (lambda (src vars val-exps body-exp) - (if (null? vars) - (build-annotated src body-exp) - (build-annotated src - `(let ,(car vars) - ,(map list (cdr vars) val-exps) ,body-exp))))) + (let ((f (car vars)) + (vars (cdr vars))) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-letrec) src + (list f) (list (build-lambda src vars #f body-exp)) + (build-application src (build-lexical-reference 'fun src f f) + val-exps))) + (else `(let ,f ,(map list vars val-exps) ,body-exp)))))) (define build-letrec (lambda (src vars val-exps body-exp) (if (null? vars) - (build-annotated src body-exp) - (build-annotated src - `(letrec ,(map list vars val-exps) ,body-exp))))) + body-exp + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-letrec) src vars val-exps body-exp)) + (else `(letrec ,(map list vars val-exps) ,body-exp)))))) -;; FIXME: wingo: use make-lexical +;; FIXME: wingo: use make-lexical ? (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (build-annotated src (gensym (symbol->string id)))))) + ((_ src id) (gensym (symbol->string id))))) (define-structure (syntax-object expression wrap module)) @@ -1729,13 +1747,12 @@ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) ((primitive) (build-primref no-source (cadr x))) ((quote) (build-data no-source (cadr x))) - ((lambda) (build-lambda no-source (cadr x) (regen (caddr x)))) + ((lambda) (build-lambda no-source (cadr x) #f (regen (caddr x)))) ((map) (let ((ls (map regen (cdr x)))) (build-application no-source - (if (fx= (length ls) 2) - (build-primref no-source 'map) - ; really need to do our own checking here - (build-primref no-source 2 'map)) ; require error check + ;; this check used to be here, not sure what for: + ;; (if (fx= (length ls) 2) + (build-primref no-source 'map) ls))) (else (build-application no-source (build-primref no-source (car x)) @@ -1913,7 +1930,7 @@ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (build-application no-source (build-primref no-source 'apply) - (list (build-lambda no-source new-vars + (list (build-lambda no-source new-vars #f (chi exp (extend-env labels @@ -1940,7 +1957,7 @@ (let ((y (gen-var 'tmp))) ; fat finger binding and references to temp variable y (build-application no-source - (build-lambda no-source (list y) + (build-lambda no-source (list y) #f (let ((y (build-lexical-reference 'value no-source 'tmp y))) (build-conditional no-source @@ -1974,7 +1991,7 @@ (let ((labels (list (gen-label))) (var (gen-var (syntax pat)))) (build-application no-source - (build-lambda no-source (list var) + (build-lambda no-source (list var) #f (chi (syntax exp) (extend-env labels (list (make-binding 'syntax `(,var . 0))) @@ -2000,7 +2017,7 @@ (let ((x (gen-var 'tmp))) ; fat finger binding and references to temp variable x (build-application s - (build-lambda no-source (list x) + (build-lambda no-source (list x) #f (gen-syntax-case (build-lexical-reference 'value no-source 'tmp x) (syntax (key ...)) (syntax (m ...)) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 163b4b72d..3d5b0159b 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,7 +27,7 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) - #:use-module (ice-9 expand-support) + #:use-module (language tree-il) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 *translate-table* define-scheme-translator)) @@ -70,7 +70,7 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (let ((x (strip-expansion-structures + (let ((x (tree-il->scheme (sc-expand x 'c '(compile load eval))))) (let ((x (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm new file mode 100644 index 000000000..fa655d815 --- /dev/null +++ b/module/language/tree-il.scm @@ -0,0 +1,248 @@ +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (language tree-il) + #:use-module (system base pmatch) + #:use-module (system base syntax) + :export (tree-il-loc + + make-lexical + lexical-name lexical-gensym + + make-application application-loc application-proc application-args + make-conditional conditional-loc conditional-test conditional-then conditional-else + make-primitive-ref primitive-ref-loc primitive-ref-name + make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym + make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp + make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public? + make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp + make-toplevel-ref toplevel-ref-loc toplevel-ref-name + make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp + make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp + make-lambda lambda-loc lambda-vars lambda-meta lambda-body + make-const const-loc const-exp + make-sequence sequence-loc sequence-exps + make-let let-loc let-vars let-vals let-exp + make-letrec letrec-loc letrec-vars letrec-vals letrec-exp + + parse-tree-il + unparse-tree-il + tree-il->scheme)) + +(define-type ( #:common-slots (src)) + ( proc args) + ( test then else) + ( name) + ( name gensym) + ( name gensym exp) + ( mod name public?) + ( mod name public? exp) + ( name) + ( name exp) + ( name exp) + ( vars meta body) + ( exp) + ( exps) + ( vars vals exp) + ( vars vals exp)) + +(define ) +(define lexical? lexical-ref?) +(define make-lexical make-lexical-ref) +(define lexical-name lexical-ref-name) +(define lexical-gensym lexical-ref-gensym) + + + +;; FIXME: use this in psyntax +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + (vector (assq-ref props 'line) + (assq-ref props 'column) + (assq-ref props 'filename)))))) + +(define (parse-tree-il env exp) + (let ((loc (location exp)) + (retrans (lambda (x) (parse-ghil env x)))) + (pmatch exp + ((apply ,proc ,args) + (make-application loc (retrans proc) (retrans args))) + + ((if ,test ,then ,else) + (make-conditional loc (retrans test) (retrans then) (retrans else))) + + ((primitive ,name) (guard (symbol? name)) + (make-primitive-ref loc name)) + + ((lexical ,name) (guard (symbol? name)) + (make-lexical-ref loc name name)) + + ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) + (make-lexical-ref loc name sym)) + + ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) + (make-lexical-set loc name sym (retrans exp))) + + ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #t)) + + ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #t (retrans exp))) + + ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #f)) + + ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #f (retrans exp))) + + ((toplevel ,name) (guard (symbol? name)) + (make-toplevel-ref loc name)) + + ((set! (toplevel ,name) exp) (guard (symbol? name)) + (make-toplevel-set loc name (retrans exp))) + + ((define ,name exp) (guard (symbol? name)) + (make-toplevel-define loc name (retrans exp))) + + ((lambda ,vars ,exp) + (make-lambda loc vars '() (retrans exp))) + + ((lambda ,vars ,meta ,exp) + (make-lambda loc vars meta (retrans exp))) + + ((const ,exp) + (make-const loc exp)) + + ((begin . ,exps) + (make-sequence loc (map retrans exps))) + + ((let ,vars ,vals ,exp) + (make-let loc vars vals (retrans exp))) + + ((letrec ,vars ,vals ,exp) + (make-letrec loc vars vals (retrans exp))) + + (else + (error "unrecognized tree-il" exp))))) + +(define (unparse-tree-il tree-il) + (record-case tree-il + (( proc args) + `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args))) + + (( test then else) + `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) + + (( name) + `(primitive ,name)) + + (( name gensym) + `(lexical ,name ,gensym)) + + (( name gensym exp) + `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) + + (( name) + `(toplevel ,name)) + + (( name exp) + `(set! (toplevel ,name) ,(unparse-tree-il exp))) + + (( name exp) + `(define ,name ,(unparse-tree-il exp))) + + (( vars meta body) + `(lambda ,vars ,meta ,(unparse-tree-il body))) + + (( exp) + `(const ,exp)) + + (( exps) + `(begin ,@(map unparse-tree-il exps))) + + (( vars vals exp) + `(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))) + + (( vars vals exp) + `(letrec ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))))) + +(define (tree-il->scheme e) + (cond ((list? e) + (map tree-il->scheme e)) + ((pair? e) + (cons (tree-il->scheme (car e)) + (tree-il->scheme (cdr e)))) + ((record? e) + (record-case e + (( proc args) + `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) + + (( test then else) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))) + + (( name) + name) + + (( name gensym) + gensym) + + (( name gensym exp) + `(set! ,gensym ,(tree-il->scheme exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) + + (( name) + name) + + (( name exp) + `(set! ,name ,(tree-il->scheme exp))) + + (( name exp) + `(define ,name ,(tree-il->scheme exp))) + + (( vars meta body) + `(lambda ,vars + ,@(cond ((assq-ref meta 'documentation) => list) (else '())) + ,(tree-il->scheme body))) + + (( exp) + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))) + + (( exps) + `(begin ,@(map tree-il->scheme exps))) + + (( vars vals exp) + `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))) + + (( vars vals exp) + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))))) + (else e))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm new file mode 100644 index 000000000..3a0225577 --- /dev/null +++ b/module/language/tree-il/compile-glil.scm @@ -0,0 +1,591 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il compile-glil) + #:use-module (system base syntax) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (ice-9 common-list) + #:export (compile-glil)) + +(define (compile-glil x e opts) + (if (memq #:O opts) (set! x (optimize x))) + (values (codegen x) + (and e (cons (car e) (cddr e))) + e)) + + +;;; +;;; Stage 2: Optimization +;;; + +(define (lift-variables! env) + (let ((parent-env (ghil-env-parent env))) + (for-each (lambda (v) + (case (ghil-var-kind v) + ((argument) (set! (ghil-var-kind v) 'local))) + (set! (ghil-var-env v) parent-env) + (ghil-env-add! parent-env v)) + (ghil-env-variables env)))) + +;; The premise of this, unused, approach to optimization is that you can +;; determine the environment of a variable lexically, because they have +;; been alpha-renamed. It makes the transformations *much* easier. +;; Unfortunately it doesn't work yet. +(define (optimize* x) + (transform-record ( env loc) x + ((quasiquote exp) + (define (optimize-qq x) + (cond ((list? x) (map optimize-qq x)) + ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x)))) + ((record? x) (optimize x)) + (else x))) + (-> (quasiquote (optimize-qq x)))) + + ((unquote exp) + (-> (unquote (optimize exp)))) + + ((unquote-splicing exp) + (-> (unquote-splicing (optimize exp)))) + + ((set var val) + (-> (set var (optimize val)))) + + ((define var val) + (-> (define var (optimize val)))) + + ((if test then else) + (-> (if (optimize test) (optimize then) (optimize else)))) + + ((and exps) + (-> (and (map optimize exps)))) + + ((or exps) + (-> (or (map optimize exps)))) + + ((begin exps) + (-> (begin (map optimize exps)))) + + ((bind vars vals body) + (-> (bind vars (map optimize vals) (optimize body)))) + + ((mv-bind producer vars rest body) + (-> (mv-bind (optimize producer) vars rest (optimize body)))) + + ((inline inst args) + (-> (inline inst (map optimize args)))) + + ((call (proc (lambda vars (rest #f) meta body)) args) + (-> (bind vars (optimize args) (optimize body)))) + + ((call proc args) + (-> (call (optimize proc) (map optimize args)))) + + ((lambda vars rest meta body) + (-> (lambda vars rest meta (optimize body)))) + + ((mv-call producer (consumer (lambda vars rest meta body))) + (-> (mv-bind (optimize producer) vars rest (optimize body)))) + + ((mv-call producer consumer) + (-> (mv-call (optimize producer) (optimize consumer)))) + + ((values values) + (-> (values (map optimize values)))) + + ((values* values) + (-> (values* (map optimize values)))) + + (else + (error "unrecognized GHIL" x)))) + +(define (optimize x) + (record-case x + (( env loc var val) + (make-ghil-set env var (optimize val))) + + (( env loc var val) + (make-ghil-define env var (optimize val))) + + (( env loc test then else) + (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) + + (( env loc exps) + (make-ghil-and env loc (map optimize exps))) + + (( env loc exps) + (make-ghil-or env loc (map optimize exps))) + + (( env loc exps) + (make-ghil-begin env loc (map optimize exps))) + + (( env loc vars vals body) + (make-ghil-bind env loc vars (map optimize vals) (optimize body))) + + (( env loc vars rest meta body) + (make-ghil-lambda env loc vars rest meta (optimize body))) + + (( env loc instruction args) + (make-ghil-inline env loc instruction (map optimize args))) + + (( env loc proc args) + (let ((parent-env env)) + (record-case proc + ;; ((@lambda (VAR...) BODY...) ARG...) => + ;; (@let ((VAR ARG) ...) BODY...) + (( env loc vars rest meta body) + (cond + ((not rest) + (lift-variables! env) + (make-ghil-bind parent-env loc (map optimize args))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args))))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))) + + (( env loc producer consumer) + (record-case consumer + ;; (mv-call PRODUCER (lambda ARGS BODY...)) => + ;; (mv-let PRODUCER ARGS BODY...) + (( env loc vars rest meta body) + (lift-variables! env) + (make-ghil-mv-bind producer vars rest body)) + (else + (make-ghil-mv-call env loc (optimize producer) (optimize consumer))))) + + (else x))) + + +;;; +;;; Stage 3: Code generation +;;; + +(define *ia-void* (make-glil-void)) +(define *ia-drop* (make-glil-call 'drop 1)) +(define *ia-return* (make-glil-call 'return 1)) + +(define (make-label) (gensym ":L")) + +(define (make-glil-var op env var) + (case (ghil-var-kind var) + ((argument) + (make-glil-argument op (ghil-var-index var))) + ((local) + (make-glil-local op (ghil-var-index var))) + ((external) + (do ((depth 0 (1+ depth)) + (e env (ghil-env-parent e))) + ((eq? e (ghil-var-env var)) + (make-glil-external op depth (ghil-var-index var))))) + ((toplevel) + (make-glil-toplevel op (ghil-var-name var))) + ((public private) + (make-glil-module op (ghil-var-env var) (ghil-var-name var) + (eq? (ghil-var-kind var) 'public))) + (else (error "Unknown kind of variable:" var)))) + +(define (constant? x) + (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t) + ((pair? x) (and (constant? (car x)) + (constant? (cdr x)))) + ((vector? x) (let lp ((i (vector-length x))) + (or (zero? i) + (and (constant? (vector-ref x (1- i))) + (lp (1- i)))))))) + +(define (codegen ghil) + (let ((stack '())) + (define (push-code! loc code) + (set! stack (cons code stack)) + (if loc (set! stack (cons (make-glil-source loc) stack)))) + (define (var->binding var) + (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) + (define (push-bindings! loc vars) + (if (not (null? vars)) + (push-code! loc (make-glil-bind (map var->binding vars))))) + (define (comp tree tail drop) + (define (push-label! label) + (push-code! #f (make-glil-label label))) + (define (push-branch! loc inst label) + (push-code! loc (make-glil-branch inst label))) + (define (push-call! loc inst args) + (for-each comp-push args) + (push-code! loc (make-glil-call inst (length args)))) + ;; possible tail position + (define (comp-tail tree) (comp tree tail drop)) + ;; push the result + (define (comp-push tree) (comp tree #f #f)) + ;; drop the result + (define (comp-drop tree) (comp tree #f #t)) + ;; drop the result if unnecessary + (define (maybe-drop) + (if drop (push-code! #f *ia-drop*))) + ;; return here if necessary + (define (maybe-return) + (if tail (push-code! #f *ia-return*))) + ;; return this code if necessary + (define (return-code! loc code) + (if (not drop) (push-code! loc code)) + (maybe-return)) + ;; return void if necessary + (define (return-void!) + (return-code! #f *ia-void*)) + ;; return object if necessary + (define (return-object! loc obj) + (return-code! loc (make-glil-const obj))) + ;; + ;; dispatch + (record-case tree + (() + (return-void!)) + + (( env loc obj) + (return-object! loc obj)) + + (( env loc exp) + (let loop ((x exp) (in-car? #f)) + (cond + ((list? x) + (push-call! #f 'mark '()) + (for-each (lambda (x) (loop x #t)) x) + (push-call! #f 'list-mark '())) + ((pair? x) + (push-call! #f 'mark '()) + (loop (car x) #t) + (loop (cdr x) #f) + (push-call! #f 'cons-mark '())) + ((record? x) + (record-case x + (( env loc exp) + (comp-push exp)) + (( env loc exp) + (if (not in-car?) + (error "unquote-splicing in the cdr of a pair" exp)) + (comp-push exp) + (push-call! #f 'list-break '())))) + ((constant? x) + (push-code! #f (make-glil-const x))) + (else + (error "element of quasiquote can't be compiled" x)))) + (maybe-drop) + (maybe-return)) + + (( env loc exp) + (error "unquote outside of quasiquote" exp)) + + (( env loc exp) + (error "unquote-splicing outside of quasiquote" exp)) + + (( env loc var) + (return-code! loc (make-glil-var 'ref env var))) + + (( env loc var val) + (comp-push val) + (push-code! loc (make-glil-var 'set env var)) + (return-void!)) + + (( env loc var val) + (comp-push val) + (push-code! loc (make-glil-var 'define env var)) + (return-void!)) + + (( env loc test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (push-branch! loc 'br-if-not L1) + (comp-tail then) + (if (not tail) (push-branch! #f 'br L2)) + (push-label! L1) + (comp-tail else) + (if (not tail) (push-label! L2)))) + + (( env loc exps) + ;; EXP + ;; (br-if-not L1) + ;; ... + ;; TAIL + ;; (br L2) + ;; L1: (const #f) + ;; L2: + (cond ((null? exps) (return-object! loc #t)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label)) (L2 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-branch! #f 'br L2) + (push-label! L1) + (return-object! #f #f) + (push-label! L2) + (maybe-return)) + (else + (comp-push (car exps)) + (push-branch! #f 'br-if-not L1) + (lp (cdr exps))))))))) + + (( env loc exps) + ;; EXP + ;; (dup) + ;; (br-if L1) + ;; (drop) + ;; ... + ;; TAIL + ;; L1: + (cond ((null? exps) (return-object! loc #f)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-label! L1) + (maybe-return)) + (else + (comp-push (car exps)) + (if (not drop) + (push-call! #f 'dup '())) + (push-branch! #f 'br-if L1) + (if (not drop) + (push-code! loc (make-glil-call 'drop 1))) + (lp (cdr exps))))))))) + + (( env loc exps) + ;; EXPS... + ;; TAIL + (if (null? exps) + (return-void!) + (do ((exps exps (cdr exps))) + ((null? (cdr exps)) + (comp-tail (car exps))) + (comp-drop (car exps))))) + + (( env loc vars vals body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (for-each comp-push vals) + (push-bindings! loc vars) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars)) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + + (( env loc producer vars rest body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (let ((MV (make-label))) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! #f (make-glil-const 1)) + (push-label! MV) + (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars))) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + + (( env loc vars rest meta body) + (return-code! loc (codegen tree))) + + (( env loc inline args) + ;; ARGS... + ;; (INST NARGS) + (let ((tail-table '((call . goto/args) + (apply . goto/apply) + (call/cc . goto/cc)))) + (cond ((and tail (assq-ref tail-table inline)) + => (lambda (tail-inst) + (push-call! loc tail-inst args))) + (else + (push-call! loc inline args) + (maybe-drop) + (maybe-return))))) + + (( env loc values) + (cond (tail ;; (lambda () (values 1 2)) + (push-call! loc 'return/values values)) + (drop ;; (lambda () (values 1 2) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (values 10 12) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! loc 'call values)))) + + (( env loc values) + (cond (tail ;; (lambda () (apply values '(1 2))) + (push-call! loc 'return/values* values)) + (drop ;; (lambda () (apply values '(1 2)) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (apply values '(10 12)) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! loc 'apply values)))) + + (( env loc proc args) + ;; PROC + ;; ARGS... + ;; ([tail-]call NARGS) + (comp-push proc) + (let ((nargs (length args))) + (cond ((< nargs 255) + (push-call! loc (if tail 'goto/args 'call) args)) + (else + (push-call! loc 'mark '()) + (for-each comp-push args) + (push-call! loc 'list-mark '()) + (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2))))) + (maybe-drop)) + + (( env loc producer consumer) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label))) + (comp-push consumer) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) + (cond ((not tail) + (push-branch! #f 'br POST))) + (push-label! MV) + (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) + (cond ((not tail) + (push-label! POST) + (maybe-drop))))) + + (( env loc) + (return-object! loc (ghil-env-reify env))))) + + ;; + ;; main + (record-case ghil + (( env loc vars rest meta body) + (let* ((evars (ghil-env-variables env)) + (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) + (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) + (nargs (allocate-indices-linearly! vars)) + (nlocs (allocate-locals! locs body)) + (nexts (allocate-indices-linearly! exts))) + ;; meta bindings + (push-bindings! #f vars) + ;; push on definition source location + (if loc (set! stack (cons (make-glil-source loc) stack))) + ;; copy args to the heap if they're marked as external + (do ((n 0 (1+ n)) + (l vars (cdr l))) + ((null? l)) + (let ((v (car l))) + (case (ghil-var-kind v) + ((external) + (push-code! #f (make-glil-argument 'ref n)) + (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) + ;; compile body + (comp body #t #f) + ;; create GLIL + (make-glil-program nargs (if rest 1 0) nlocs nexts meta + (reverse! stack))))))) + +(define (allocate-indices-linearly! vars) + (do ((n 0 (1+ n)) + (l vars (cdr l))) + ((null? l) n) + (let ((v (car l))) (set! (ghil-var-index v) n)))) + +(define (allocate-locals! vars body) + (let ((free '()) (nlocs 0)) + (define (allocate! var) + (cond + ((pair? free) + (set! (ghil-var-index var) (car free)) + (set! free (cdr free))) + (else + (set! (ghil-var-index var) nlocs) + (set! nlocs (1+ nlocs))))) + (define (deallocate! var) + (set! free (cons (ghil-var-index var) free))) + (let lp ((x body)) + (record-case x + (()) + (()) + (( exp) + (let qlp ((x exp)) + (cond ((list? x) (for-each qlp x)) + ((pair? x) (qlp (car x)) (qlp (cdr x))) + ((record? x) + (record-case x + (( exp) (lp exp)) + (( exp) (lp exp))))))) + (( exp) + (lp exp)) + (( exp) + (lp exp)) + (()) + (( val) + (lp val)) + (()) + (( val) + (lp val)) + (( test then else) + (lp test) (lp then) (lp else)) + (( exps) + (for-each lp exps)) + (( exps) + (for-each lp exps)) + (( exps) + (for-each lp exps)) + (( vars vals body) + (for-each allocate! vars) + (for-each lp vals) + (lp body) + (for-each deallocate! vars)) + (( vars producer body) + (lp producer) + (for-each allocate! vars) + (lp body) + (for-each deallocate! vars)) + (( args) + (for-each lp args)) + (( proc args) + (lp proc) + (for-each lp args)) + (()) + (( producer consumer) + (lp producer) + (lp consumer)) + (( values) + (for-each lp values)) + (( values) + (for-each lp values)))) + nlocs)) diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm new file mode 100644 index 000000000..d69a4ec37 --- /dev/null +++ b/module/language/tree-il/spec.scm @@ -0,0 +1,52 @@ +;;; Tree Intermediate Language + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il compile-glil) + #:export (tree-il)) + +(define (write-tree-il exp . port) + (apply write (unparse-tree-il exp) port)) + +(define (parse x) + (make-lambda #f '() '() (parse-tree-il x))) + +(define (join exps env) + (if (or-map (lambda (x) + (or (not (lambda? x)) + (not (null? (lambda-vars x))))) + exps) + (error "tree-il expressions to join must be thunks")) + + (make-lambda #f '() '() (make-sequence #f (map lambda-body exps)))) + +(define-language tree-il + #:title "Tree Intermediate Language" + #:version "1.0" + #:reader read + #:printer write-tree-il + #:parser parse + #:joiner join + #:compilers `((glil . ,compile-glil)) + ) From 982a1c205d2ff1dc61a2ff56ba2e6491974f9303 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 May 2009 17:38:40 +0200 Subject: [PATCH 097/375] remove (ice-9 expand-support) * module/ice-9/Makefile.am: * module/ice-9/expand-support.scm: Remove module, no longer used. * module/ice-9/psyntax.scm: Fix a comment. --- module/Makefile.am | 1 - module/ice-9/expand-support.scm | 159 -------------------------------- module/ice-9/psyntax.scm | 2 +- 3 files changed, 1 insertion(+), 161 deletions(-) delete mode 100644 module/ice-9/expand-support.scm diff --git a/module/Makefile.am b/module/Makefile.am index 4bc52e474..761b1868b 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -137,7 +137,6 @@ ICE_9_SOURCES = \ ice-9/debugger.scm \ ice-9/documentation.scm \ ice-9/emacs.scm \ - ice-9/expand-support.scm \ ice-9/expect.scm \ ice-9/format.scm \ ice-9/getopt-long.scm \ diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm deleted file mode 100644 index 33a9b3f00..000000000 --- a/module/ice-9/expand-support.scm +++ /dev/null @@ -1,159 +0,0 @@ -;;;; Copyright (C) 2009 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; - - -(define-module (ice-9 expand-support) - :export ( annotation? annotate deannotate make-annotation - annotation-expression annotation-source annotation-stripped - set-annotation-stripped! - deannotate/source-properties - - make-module-ref - module-ref-symbol module-ref-modname module-ref-public? - - make-lexical - lexical-name lexical-gensym - - strip-expansion-structures)) - -(define - (make-vtable "prprpw" - (lambda (struct port) - (display "#" port)))) - -(define (annotation? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-annotation e s . stripped?) - (if (null? stripped?) - (make-struct 0 e s #f) - (apply make-struct 0 e s stripped?))) - -(define (annotation-expression a) - (struct-ref a 0)) -(define (annotation-source a) - (struct-ref a 1)) -(define (annotation-stripped a) - (struct-ref a 2)) -(define (set-annotation-stripped! a stripped?) - (struct-set! a 2 stripped?)) - -(define (annotate e) - (let ((p (if (pair? e) (source-properties e) #f)) - (out (cond ((and (list? e) (not (null? e))) - (map annotate e)) - ((pair? e) - (cons (annotate (car e)) (annotate (cdr e)))) - (else e)))) - (if (pair? p) - (make-annotation out p #f) - out))) - -(define (deannotate e) - (cond ((list? e) - (map deannotate e)) - ((pair? e) - (cons (deannotate (car e)) (deannotate (cdr e)))) - ((annotation? e) (deannotate (annotation-expression e))) - (else e))) - -(define (deannotate/source-properties e) - (cond ((list? e) - (map deannotate/source-properties e)) - ((pair? e) - (cons (deannotate/source-properties (car e)) - (deannotate/source-properties (cdr e)))) - ((annotation? e) - (let ((e (deannotate/source-properties (annotation-expression e))) - (source (annotation-source e))) - (if (pair? e) - (set-source-properties! e source)) - e)) - (else e))) - - - -(define - (make-vtable "prprpr" - (lambda (struct port) - (display "#<" port) - (display (if (module-ref-public? struct) "@ " "@@ ") port) - (display (module-ref-modname struct) port) - (display " " port) - (display (module-ref-symbol struct) port) - (display ">" port)))) - -(define (module-ref? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-module-ref source modname symbol public?) - (make-struct 0 modname symbol public?)) - -(define (module-ref-modname a) - (struct-ref a 0)) -(define (module-ref-symbol a) - (struct-ref a 1)) -(define (module-ref-public? a) - (struct-ref a 2)) - - - -(define - (make-vtable "prpr" - (lambda (struct port) - (display "#" port)))) - -(define (lexical? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-lexical source name gensym) - (make-struct 0 name gensym)) - -(define (lexical-name a) - (struct-ref a 0)) -(define (lexical-gensym a) - (struct-ref a 1)) - - - -(define (strip-expansion-structures e) - (cond ((list? e) - (map strip-expansion-structures e)) - ((pair? e) - (cons (strip-expansion-structures (car e)) - (strip-expansion-structures (cdr e)))) - ((annotation? e) - (let ((e (strip-expansion-structures (annotation-expression e))) - (source (annotation-source e))) - (if (pair? e) - (set-source-properties! e source)) - e)) - ((module-ref? e) - `(,(if (module-ref-public? e) '@ '@@) - ,(module-ref-modname e) - ,(module-ref-symbol e))) - ((lexical? e) - (lexical-gensym e)) - ((record? e) - (error "unexpected record in expansion" e)) - (else e))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 85ef13814..ebdb43778 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -379,7 +379,7 @@ ;; Before modules are booted, we can't expand into data structures from ;; (language tree-il) -- we need to give the evaluator the ;; s-expressions that it understands natively. Actually the real truth -;; of the matter is that the evaluator doesn't understand expand-support +;; of the matter is that the evaluator doesn't understand tree-il ;; structures at all. So until we fix the evaluator, if ever, the ;; conflation that we should use tree-il iff we are compiling ;; holds true. From 06656e06d454f16694d0b550fb339efb0c36123a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 May 2009 17:44:51 +0200 Subject: [PATCH 098/375] go ahead and regenerate psyntax-pp.scm --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 2718a1e87..dca1b30f6 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*1697 (lambda (f1737 first1736 . rest1735) (or (null? first1736) (if (null? rest1735) (letrec ((andmap1738 (lambda (first1739) (let ((x1740 (car first1739)) (first1741 (cdr first1739))) (if (null? first1741) (f1737 x1740) (and (f1737 x1740) (andmap1738 first1741))))))) (andmap1738 first1736)) (letrec ((andmap1742 (lambda (first1743 rest1744) (let ((x1745 (car first1743)) (xr1746 (map car rest1744)) (first1747 (cdr first1743)) (rest1748 (map cdr rest1744))) (if (null? first1747) (apply f1737 (cons x1745 xr1746)) (and (apply f1737 (cons x1745 xr1746)) (andmap1742 first1747 rest1748))))))) (andmap1742 first1736 rest1735))))))) (letrec ((lambda-var-list1840 (lambda (vars1969) (letrec ((lvl1970 (lambda (vars1971 ls1972 w1973) (cond ((pair? vars1971) (lvl1970 (cdr vars1971) (cons (wrap1819 (car vars1971) w1973 (quote #f)) ls1972) w1973)) ((id?1791 vars1971) (cons (wrap1819 vars1971 w1973 (quote #f)) ls1972)) ((null? vars1971) ls1972) ((syntax-object?1775 vars1971) (lvl1970 (syntax-object-expression1776 vars1971) ls1972 (join-wraps1810 w1973 (syntax-object-wrap1777 vars1971)))) ((annotation? vars1971) (lvl1970 (annotation-expression vars1971) ls1972 w1973)) (else (cons vars1971 ls1972)))))) (lvl1970 vars1969 (quote ()) (quote (())))))) (gen-var1839 (lambda (id1974) (let ((id1975 (if (syntax-object?1775 id1974) (syntax-object-expression1776 id1974) id1974))) (if (annotation? id1975) (gensym (symbol->string (annotation-expression id1975))) (gensym (symbol->string id1975)))))) (strip1838 (lambda (x1976 w1977) (if (memq (quote top) (wrap-marks1794 w1977)) (if (or (annotation? x1976) (and (pair? x1976) (annotation? (car x1976)))) (strip-annotation1837 x1976 (quote #f)) x1976) (letrec ((f1978 (lambda (x1979) (cond ((syntax-object?1775 x1979) (strip1838 (syntax-object-expression1776 x1979) (syntax-object-wrap1777 x1979))) ((pair? x1979) (let ((a1980 (f1978 (car x1979))) (d1981 (f1978 (cdr x1979)))) (if (and (eq? a1980 (car x1979)) (eq? d1981 (cdr x1979))) x1979 (cons a1980 d1981)))) ((vector? x1979) (let ((old1982 (vector->list x1979))) (let ((new1983 (map f1978 old1982))) (if (and-map*1697 eq? old1982 new1983) x1979 (list->vector new1983))))) (else x1979))))) (f1978 x1976))))) (strip-annotation1837 (lambda (x1984 parent1985) (cond ((pair? x1984) (let ((new1986 (cons (quote #f) (quote #f)))) (begin (if parent1985 (set-annotation-stripped! parent1985 new1986)) (set-car! new1986 (strip-annotation1837 (car x1984) (quote #f))) (set-cdr! new1986 (strip-annotation1837 (cdr x1984) (quote #f))) new1986))) ((annotation? x1984) (or (annotation-stripped x1984) (strip-annotation1837 (annotation-expression x1984) x1984))) ((vector? x1984) (let ((new1987 (make-vector (vector-length x1984)))) (begin (if parent1985 (set-annotation-stripped! parent1985 new1987)) (letrec ((loop1988 (lambda (i1989) (unless (fx<1754 i1989 (quote 0)) (vector-set! new1987 i1989 (strip-annotation1837 (vector-ref x1984 i1989) (quote #f))) (loop1988 (fx-1752 i1989 (quote 1))))))) (loop1988 (- (vector-length x1984) (quote 1)))) new1987))) (else x1984)))) (ellipsis?1836 (lambda (x1990) (and (nonsymbol-id?1790 x1990) (free-id=?1814 x1990 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void1835 (lambda () (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote if)) (quote (#f #f))))) (eval-local-transformer1834 (lambda (expanded1991 mod1992) (let ((p1993 (local-eval-hook1756 expanded1991 mod1992))) (if (procedure? p1993) p1993 (syntax-violation (quote #f) (quote "nonprocedure transformer") p1993))))) (chi-local-syntax1833 (lambda (rec?1994 e1995 r1996 w1997 s1998 mod1999 k2000) ((lambda (tmp2001) ((lambda (tmp2002) (if tmp2002 (apply (lambda (_2003 id2004 val2005 e12006 e22007) (let ((ids2008 id2004)) (if (not (valid-bound-ids?1816 ids2008)) (syntax-violation (quote #f) (quote "duplicate bound keyword") e1995) (let ((labels2010 (gen-labels1797 ids2008))) (let ((new-w2011 (make-binding-wrap1808 ids2008 labels2010 w1997))) (k2000 (cons e12006 e22007) (extend-env1785 labels2010 (let ((w2013 (if rec?1994 new-w2011 w1997)) (trans-r2014 (macros-only-env1787 r1996))) (map (lambda (x2015) (cons (quote macro) (eval-local-transformer1834 (chi1827 x2015 trans-r2014 w2013 mod1999) mod1999))) val2005)) r1996) new-w2011 s1998 mod1999)))))) tmp2002) ((lambda (_2017) (syntax-violation (quote #f) (quote "bad local syntax definition") (source-wrap1820 e1995 w1997 s1998 mod1999))) tmp2001))) ($sc-dispatch tmp2001 (quote (any #(each (any any)) any . each-any))))) e1995))) (chi-lambda-clause1832 (lambda (e2018 docstring2019 c2020 r2021 w2022 mod2023 k2024) ((lambda (tmp2025) ((lambda (tmp2026) (if (if tmp2026 (apply (lambda (args2027 doc2028 e12029 e22030) (and (string? (syntax->datum doc2028)) (not docstring2019))) tmp2026) (quote #f)) (apply (lambda (args2031 doc2032 e12033 e22034) (chi-lambda-clause1832 e2018 doc2032 (cons args2031 (cons e12033 e22034)) r2021 w2022 mod2023 k2024)) tmp2026) ((lambda (tmp2036) (if tmp2036 (apply (lambda (id2037 e12038 e22039) (let ((ids2040 id2037)) (if (not (valid-bound-ids?1816 ids2040)) (syntax-violation (quote lambda) (quote "invalid parameter list") e2018) (let ((labels2042 (gen-labels1797 ids2040)) (new-vars2043 (map gen-var1839 ids2040))) (k2024 new-vars2043 docstring2019 (chi-body1831 (cons e12038 e22039) e2018 (extend-var-env1786 labels2042 new-vars2043 r2021) (make-binding-wrap1808 ids2040 labels2042 w2022) mod2023)))))) tmp2036) ((lambda (tmp2045) (if tmp2045 (apply (lambda (ids2046 e12047 e22048) (let ((old-ids2049 (lambda-var-list1840 ids2046))) (if (not (valid-bound-ids?1816 old-ids2049)) (syntax-violation (quote lambda) (quote "invalid parameter list") e2018) (let ((labels2050 (gen-labels1797 old-ids2049)) (new-vars2051 (map gen-var1839 old-ids2049))) (k2024 (letrec ((f2052 (lambda (ls12053 ls22054) (if (null? ls12053) ls22054 (f2052 (cdr ls12053) (cons (car ls12053) ls22054)))))) (f2052 (cdr new-vars2051) (car new-vars2051))) docstring2019 (chi-body1831 (cons e12047 e22048) e2018 (extend-var-env1786 labels2050 new-vars2051 r2021) (make-binding-wrap1808 old-ids2049 labels2050 w2022) mod2023)))))) tmp2045) ((lambda (_2056) (syntax-violation (quote lambda) (quote "bad lambda") e2018)) tmp2025))) ($sc-dispatch tmp2025 (quote (any any . each-any)))))) ($sc-dispatch tmp2025 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2025 (quote (any any any . each-any))))) c2020))) (chi-body1831 (lambda (body2057 outer-form2058 r2059 w2060 mod2061) (let ((r2062 (cons (quote ("placeholder" placeholder)) r2059))) (let ((ribcage2063 (make-ribcage1798 (quote ()) (quote ()) (quote ())))) (let ((w2064 (make-wrap1793 (wrap-marks1794 w2060) (cons ribcage2063 (wrap-subst1795 w2060))))) (letrec ((parse2065 (lambda (body2066 ids2067 labels2068 vars2069 vals2070 bindings2071) (if (null? body2066) (syntax-violation (quote #f) (quote "no expressions in body") outer-form2058) (let ((e2073 (cdar body2066)) (er2074 (caar body2066))) (call-with-values (lambda () (syntax-type1825 e2073 er2074 (quote (())) (quote #f) ribcage2063 mod2061)) (lambda (type2075 value2076 e2077 w2078 s2079 mod2080) (let ((t2081 type2075)) (if (memv t2081 (quote (define-form))) (let ((id2082 (wrap1819 value2076 w2078 mod2080)) (label2083 (gen-label1796))) (let ((var2084 (gen-var1839 id2082))) (begin (extend-ribcage!1807 ribcage2063 id2082 label2083) (parse2065 (cdr body2066) (cons id2082 ids2067) (cons label2083 labels2068) (cons var2084 vars2069) (cons (cons er2074 (wrap1819 e2077 w2078 mod2080)) vals2070) (cons (cons (quote lexical) var2084) bindings2071))))) (if (memv t2081 (quote (define-syntax-form))) (let ((id2085 (wrap1819 value2076 w2078 mod2080)) (label2086 (gen-label1796))) (begin (extend-ribcage!1807 ribcage2063 id2085 label2086) (parse2065 (cdr body2066) (cons id2085 ids2067) (cons label2086 labels2068) vars2069 vals2070 (cons (cons (quote macro) (cons er2074 (wrap1819 e2077 w2078 mod2080))) bindings2071)))) (if (memv t2081 (quote (begin-form))) ((lambda (tmp2087) ((lambda (tmp2088) (if tmp2088 (apply (lambda (_2089 e12090) (parse2065 (letrec ((f2091 (lambda (forms2092) (if (null? forms2092) (cdr body2066) (cons (cons er2074 (wrap1819 (car forms2092) w2078 mod2080)) (f2091 (cdr forms2092))))))) (f2091 e12090)) ids2067 labels2068 vars2069 vals2070 bindings2071)) tmp2088) (syntax-violation #f "source expression failed to match any pattern" tmp2087))) ($sc-dispatch tmp2087 (quote (any . each-any))))) e2077) (if (memv t2081 (quote (local-syntax-form))) (chi-local-syntax1833 value2076 e2077 er2074 w2078 s2079 mod2080 (lambda (forms2094 er2095 w2096 s2097 mod2098) (parse2065 (letrec ((f2099 (lambda (forms2100) (if (null? forms2100) (cdr body2066) (cons (cons er2095 (wrap1819 (car forms2100) w2096 mod2098)) (f2099 (cdr forms2100))))))) (f2099 forms2094)) ids2067 labels2068 vars2069 vals2070 bindings2071))) (if (null? ids2067) (build-sequence1770 (quote #f) (map (lambda (x2101) (chi1827 (cdr x2101) (car x2101) (quote (())) mod2080)) (cons (cons er2074 (source-wrap1820 e2077 w2078 s2079 mod2080)) (cdr body2066)))) (begin (if (not (valid-bound-ids?1816 ids2067)) (syntax-violation (quote #f) (quote "invalid or duplicate identifier in definition") outer-form2058)) (letrec ((loop2102 (lambda (bs2103 er-cache2104 r-cache2105) (if (not (null? bs2103)) (let ((b2106 (car bs2103))) (if (eq? (car b2106) (quote macro)) (let ((er2107 (cadr b2106))) (let ((r-cache2108 (if (eq? er2107 er-cache2104) r-cache2105 (macros-only-env1787 er2107)))) (begin (set-cdr! b2106 (eval-local-transformer1834 (chi1827 (cddr b2106) r-cache2108 (quote (())) mod2080) mod2080)) (loop2102 (cdr bs2103) er2107 r-cache2108)))) (loop2102 (cdr bs2103) er-cache2104 r-cache2105))))))) (loop2102 bindings2071 (quote #f) (quote #f))) (set-cdr! r2062 (extend-env1785 labels2068 bindings2071 (cdr r2062))) (build-letrec1773 (quote #f) vars2069 (map (lambda (x2109) (chi1827 (cdr x2109) (car x2109) (quote (())) mod2080)) vals2070) (build-sequence1770 (quote #f) (map (lambda (x2110) (chi1827 (cdr x2110) (car x2110) (quote (())) mod2080)) (cons (cons er2074 (source-wrap1820 e2077 w2078 s2079 mod2080)) (cdr body2066))))))))))))))))))) (parse2065 (map (lambda (x2072) (cons r2062 (wrap1819 x2072 w2064 mod2061))) body2057) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro1830 (lambda (p2111 e2112 r2113 w2114 rib2115 mod2116) (letrec ((rebuild-macro-output2117 (lambda (x2118 m2119) (cond ((pair? x2118) (cons (rebuild-macro-output2117 (car x2118) m2119) (rebuild-macro-output2117 (cdr x2118) m2119))) ((syntax-object?1775 x2118) (let ((w2120 (syntax-object-wrap1777 x2118))) (let ((ms2121 (wrap-marks1794 w2120)) (s2122 (wrap-subst1795 w2120))) (if (and (pair? ms2121) (eq? (car ms2121) (quote #f))) (make-syntax-object1774 (syntax-object-expression1776 x2118) (make-wrap1793 (cdr ms2121) (if rib2115 (cons rib2115 (cdr s2122)) (cdr s2122))) (syntax-object-module1778 x2118)) (make-syntax-object1774 (syntax-object-expression1776 x2118) (make-wrap1793 (cons m2119 ms2121) (if rib2115 (cons rib2115 (cons (quote shift) s2122)) (cons (quote shift) s2122))) (let ((pmod2123 (procedure-module p2111))) (if pmod2123 (cons (quote hygiene) (module-name pmod2123)) (quote (hygiene guile))))))))) ((vector? x2118) (let ((n2124 (vector-length x2118))) (let ((v2125 (make-vector n2124))) (letrec ((doloop2126 (lambda (i2127) (if (fx=1753 i2127 n2124) v2125 (begin (vector-set! v2125 i2127 (rebuild-macro-output2117 (vector-ref x2118 i2127) m2119)) (doloop2126 (fx+1751 i2127 (quote 1)))))))) (doloop2126 (quote 0)))))) ((symbol? x2118) (syntax-violation (quote #f) (quote "encountered raw symbol in macro output") (source-wrap1820 e2112 w2114 s mod2116) x2118)) (else x2118))))) (rebuild-macro-output2117 (p2111 (wrap1819 e2112 (anti-mark1806 w2114) mod2116)) (string (quote #\m)))))) (chi-application1829 (lambda (x2128 e2129 r2130 w2131 s2132 mod2133) ((lambda (tmp2134) ((lambda (tmp2135) (if tmp2135 (apply (lambda (e02136 e12137) (build-application1759 s2132 x2128 (map (lambda (e2138) (chi1827 e2138 r2130 w2131 mod2133)) e12137))) tmp2135) (syntax-violation #f "source expression failed to match any pattern" tmp2134))) ($sc-dispatch tmp2134 (quote (any . each-any))))) e2129))) (chi-expr1828 (lambda (type2140 value2141 e2142 r2143 w2144 s2145 mod2146) (let ((t2147 type2140)) (if (memv t2147 (quote (lexical))) (build-lexical-reference1761 (quote value) s2145 e2142 value2141) (if (memv t2147 (quote (core external-macro))) (value2141 e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (module-ref))) (call-with-values (lambda () (value2141 e2142)) (lambda (id2148 mod2149) (build-global-reference1764 s2145 id2148 mod2149))) (if (memv t2147 (quote (lexical-call))) (chi-application1829 (build-lexical-reference1761 (quote fun) (source-annotation1782 (car e2142)) (car e2142) value2141) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (global-call))) (chi-application1829 (build-global-reference1764 (source-annotation1782 (car e2142)) value2141 (if (syntax-object?1775 (car e2142)) (syntax-object-module1778 (car e2142)) mod2146)) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (constant))) (build-data1769 s2145 (strip1838 (source-wrap1820 e2142 w2144 s2145 mod2146) (quote (())))) (if (memv t2147 (quote (global))) (build-global-reference1764 s2145 value2141 mod2146) (if (memv t2147 (quote (call))) (chi-application1829 (chi1827 (car e2142) r2143 w2144 mod2146) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (begin-form))) ((lambda (tmp2150) ((lambda (tmp2151) (if tmp2151 (apply (lambda (_2152 e12153 e22154) (chi-sequence1821 (cons e12153 e22154) r2143 w2144 s2145 mod2146)) tmp2151) (syntax-violation #f "source expression failed to match any pattern" tmp2150))) ($sc-dispatch tmp2150 (quote (any any . each-any))))) e2142) (if (memv t2147 (quote (local-syntax-form))) (chi-local-syntax1833 value2141 e2142 r2143 w2144 s2145 mod2146 chi-sequence1821) (if (memv t2147 (quote (eval-when-form))) ((lambda (tmp2156) ((lambda (tmp2157) (if tmp2157 (apply (lambda (_2158 x2159 e12160 e22161) (let ((when-list2162 (chi-when-list1824 e2142 x2159 w2144))) (if (memq (quote eval) when-list2162) (chi-sequence1821 (cons e12160 e22161) r2143 w2144 s2145 mod2146) (chi-void1835)))) tmp2157) (syntax-violation #f "source expression failed to match any pattern" tmp2156))) ($sc-dispatch tmp2156 (quote (any each-any any . each-any))))) e2142) (if (memv t2147 (quote (define-form define-syntax-form))) (syntax-violation (quote #f) (quote "definition in expression context") e2142 (wrap1819 value2141 w2144 mod2146)) (if (memv t2147 (quote (syntax))) (syntax-violation (quote #f) (quote "reference to pattern variable outside syntax form") (source-wrap1820 e2142 w2144 s2145 mod2146)) (if (memv t2147 (quote (displaced-lexical))) (syntax-violation (quote #f) (quote "reference to identifier outside its scope") (source-wrap1820 e2142 w2144 s2145 mod2146)) (syntax-violation (quote #f) (quote "unexpected syntax") (source-wrap1820 e2142 w2144 s2145 mod2146))))))))))))))))))) (chi1827 (lambda (e2165 r2166 w2167 mod2168) (call-with-values (lambda () (syntax-type1825 e2165 r2166 w2167 (quote #f) (quote #f) mod2168)) (lambda (type2169 value2170 e2171 w2172 s2173 mod2174) (chi-expr1828 type2169 value2170 e2171 r2166 w2172 s2173 mod2174))))) (chi-top1826 (lambda (e2175 r2176 w2177 m2178 esew2179 mod2180) (call-with-values (lambda () (syntax-type1825 e2175 r2176 w2177 (quote #f) (quote #f) mod2180)) (lambda (type2188 value2189 e2190 w2191 s2192 mod2193) (let ((t2194 type2188)) (if (memv t2194 (quote (begin-form))) ((lambda (tmp2195) ((lambda (tmp2196) (if tmp2196 (apply (lambda (_2197) (chi-void1835)) tmp2196) ((lambda (tmp2198) (if tmp2198 (apply (lambda (_2199 e12200 e22201) (chi-top-sequence1822 (cons e12200 e22201) r2176 w2191 s2192 m2178 esew2179 mod2193)) tmp2198) (syntax-violation #f "source expression failed to match any pattern" tmp2195))) ($sc-dispatch tmp2195 (quote (any any . each-any)))))) ($sc-dispatch tmp2195 (quote (any))))) e2190) (if (memv t2194 (quote (local-syntax-form))) (chi-local-syntax1833 value2189 e2190 r2176 w2191 s2192 mod2193 (lambda (body2203 r2204 w2205 s2206 mod2207) (chi-top-sequence1822 body2203 r2204 w2205 s2206 m2178 esew2179 mod2207))) (if (memv t2194 (quote (eval-when-form))) ((lambda (tmp2208) ((lambda (tmp2209) (if tmp2209 (apply (lambda (_2210 x2211 e12212 e22213) (let ((when-list2214 (chi-when-list1824 e2190 x2211 w2191)) (body2215 (cons e12212 e22213))) (cond ((eq? m2178 (quote e)) (if (memq (quote eval) when-list2214) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote e) (quote (eval)) mod2193) (chi-void1835))) ((memq (quote load) when-list2214) (if (or (memq (quote compile) when-list2214) (and (eq? m2178 (quote c&e)) (memq (quote eval) when-list2214))) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote c&e) (quote (compile load)) mod2193) (if (memq m2178 (quote (c c&e))) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote c) (quote (load)) mod2193) (chi-void1835)))) ((or (memq (quote compile) when-list2214) (and (eq? m2178 (quote c&e)) (memq (quote eval) when-list2214))) (top-level-eval-hook1755 (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote e) (quote (eval)) mod2193) mod2193) (chi-void1835)) (else (chi-void1835))))) tmp2209) (syntax-violation #f "source expression failed to match any pattern" tmp2208))) ($sc-dispatch tmp2208 (quote (any each-any any . each-any))))) e2190) (if (memv t2194 (quote (define-syntax-form))) (let ((n2218 (id-var-name1813 value2189 w2191)) (r2219 (macros-only-env1787 r2176))) (let ((t2220 m2178)) (if (memv t2220 (quote (c))) (if (memq (quote compile) esew2179) (let ((e2221 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)))) (begin (top-level-eval-hook1755 e2221 mod2193) (if (memq (quote load) esew2179) e2221 (chi-void1835)))) (if (memq (quote load) esew2179) (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)) (chi-void1835))) (if (memv t2220 (quote (c&e))) (let ((e2222 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)))) (begin (top-level-eval-hook1755 e2222 mod2193) e2222)) (begin (if (memq (quote eval) esew2179) (top-level-eval-hook1755 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)) mod2193)) (chi-void1835)))))) (if (memv t2194 (quote (define-form))) (let ((n2223 (id-var-name1813 value2189 w2191))) (let ((type2224 (binding-type1783 (lookup1788 n2223 r2176 mod2193)))) (let ((t2225 type2224)) (if (memv t2225 (quote (global core macro module-ref))) (let ((x2226 (build-global-definition1766 s2192 n2223 (chi1827 e2190 r2176 w2191 mod2193)))) (begin (if (eq? m2178 (quote c&e)) (top-level-eval-hook1755 x2226 mod2193)) x2226)) (if (memv t2225 (quote (displaced-lexical))) (syntax-violation (quote #f) (quote "identifier out of context") e2190 (wrap1819 value2189 w2191 mod2193)) (syntax-violation (quote #f) (quote "cannot define keyword at top level") e2190 (wrap1819 value2189 w2191 mod2193))))))) (let ((x2227 (chi-expr1828 type2188 value2189 e2190 r2176 w2191 s2192 mod2193))) (begin (if (eq? m2178 (quote c&e)) (top-level-eval-hook1755 x2227 mod2193)) x2227)))))))))))) (syntax-type1825 (lambda (e2228 r2229 w2230 s2231 rib2232 mod2233) (cond ((symbol? e2228) (let ((n2234 (id-var-name1813 e2228 w2230))) (let ((b2235 (lookup1788 n2234 r2229 mod2233))) (let ((type2236 (binding-type1783 b2235))) (let ((t2237 type2236)) (if (memv t2237 (quote (lexical))) (values type2236 (binding-value1784 b2235) e2228 w2230 s2231 mod2233) (if (memv t2237 (quote (global))) (values type2236 n2234 e2228 w2230 s2231 mod2233) (if (memv t2237 (quote (macro))) (syntax-type1825 (chi-macro1830 (binding-value1784 b2235) e2228 r2229 w2230 rib2232 mod2233) r2229 (quote (())) s2231 rib2232 mod2233) (values type2236 (binding-value1784 b2235) e2228 w2230 s2231 mod2233))))))))) ((pair? e2228) (let ((first2238 (car e2228))) (if (id?1791 first2238) (let ((n2239 (id-var-name1813 first2238 w2230))) (let ((b2240 (lookup1788 n2239 r2229 (or (and (syntax-object?1775 first2238) (syntax-object-module1778 first2238)) mod2233)))) (let ((type2241 (binding-type1783 b2240))) (let ((t2242 type2241)) (if (memv t2242 (quote (lexical))) (values (quote lexical-call) (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (global))) (values (quote global-call) n2239 e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (macro))) (syntax-type1825 (chi-macro1830 (binding-value1784 b2240) e2228 r2229 w2230 rib2232 mod2233) r2229 (quote (())) s2231 rib2232 mod2233) (if (memv t2242 (quote (core external-macro module-ref))) (values type2241 (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (begin))) (values (quote begin-form) (quote #f) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (define))) ((lambda (tmp2243) ((lambda (tmp2244) (if (if tmp2244 (apply (lambda (_2245 name2246 val2247) (id?1791 name2246)) tmp2244) (quote #f)) (apply (lambda (_2248 name2249 val2250) (values (quote define-form) name2249 val2250 w2230 s2231 mod2233)) tmp2244) ((lambda (tmp2251) (if (if tmp2251 (apply (lambda (_2252 name2253 args2254 e12255 e22256) (and (id?1791 name2253) (valid-bound-ids?1816 (lambda-var-list1840 args2254)))) tmp2251) (quote #f)) (apply (lambda (_2257 name2258 args2259 e12260 e22261) (values (quote define-form) (wrap1819 name2258 w2230 mod2233) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1819 (cons args2259 (cons e12260 e22261)) w2230 mod2233)) (quote (())) s2231 mod2233)) tmp2251) ((lambda (tmp2263) (if (if tmp2263 (apply (lambda (_2264 name2265) (id?1791 name2265)) tmp2263) (quote #f)) (apply (lambda (_2266 name2267) (values (quote define-form) (wrap1819 name2267 w2230 mod2233) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2231 mod2233)) tmp2263) (syntax-violation #f "source expression failed to match any pattern" tmp2243))) ($sc-dispatch tmp2243 (quote (any any)))))) ($sc-dispatch tmp2243 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2243 (quote (any any any))))) e2228) (if (memv t2242 (quote (define-syntax))) ((lambda (tmp2268) ((lambda (tmp2269) (if (if tmp2269 (apply (lambda (_2270 name2271 val2272) (id?1791 name2271)) tmp2269) (quote #f)) (apply (lambda (_2273 name2274 val2275) (values (quote define-syntax-form) name2274 val2275 w2230 s2231 mod2233)) tmp2269) (syntax-violation #f "source expression failed to match any pattern" tmp2268))) ($sc-dispatch tmp2268 (quote (any any any))))) e2228) (values (quote call) (quote #f) e2228 w2230 s2231 mod2233)))))))))))))) (values (quote call) (quote #f) e2228 w2230 s2231 mod2233)))) ((syntax-object?1775 e2228) (syntax-type1825 (syntax-object-expression1776 e2228) r2229 (join-wraps1810 w2230 (syntax-object-wrap1777 e2228)) (quote #f) rib2232 (or (syntax-object-module1778 e2228) mod2233))) ((annotation? e2228) (syntax-type1825 (annotation-expression e2228) r2229 w2230 (annotation-source e2228) rib2232 mod2233)) ((self-evaluating? e2228) (values (quote constant) (quote #f) e2228 w2230 s2231 mod2233)) (else (values (quote other) (quote #f) e2228 w2230 s2231 mod2233))))) (chi-when-list1824 (lambda (e2276 when-list2277 w2278) (letrec ((f2279 (lambda (when-list2280 situations2281) (if (null? when-list2280) situations2281 (f2279 (cdr when-list2280) (cons (let ((x2282 (car when-list2280))) (cond ((free-id=?1814 x2282 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?1814 x2282 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?1814 x2282 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) (quote "invalid situation") e2276 (wrap1819 x2282 w2278 (quote #f)))))) situations2281)))))) (f2279 when-list2277 (quote ()))))) (chi-install-global1823 (lambda (name2283 e2284) (build-global-definition1766 (quote #f) name2283 (if (let ((v2285 (module-variable (current-module) name2283))) (and v2285 (variable-bound? v2285) (macro? (variable-ref v2285)) (not (eq? (macro-type (variable-ref v2285)) (quote syncase-macro))))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote make-extended-syncase-macro)) (list (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote module-ref)) (list (build-application1759 (quote #f) (quote current-module) (quote ())) (build-data1769 (quote #f) name2283))) (build-data1769 (quote #f) (quote macro)) e2284)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote make-syncase-macro)) (list (build-data1769 (quote #f) (quote macro)) e2284)))))) (chi-top-sequence1822 (lambda (body2286 r2287 w2288 s2289 m2290 esew2291 mod2292) (build-sequence1770 s2289 (letrec ((dobody2293 (lambda (body2294 r2295 w2296 m2297 esew2298 mod2299) (if (null? body2294) (quote ()) (let ((first2300 (chi-top1826 (car body2294) r2295 w2296 m2297 esew2298 mod2299))) (cons first2300 (dobody2293 (cdr body2294) r2295 w2296 m2297 esew2298 mod2299))))))) (dobody2293 body2286 r2287 w2288 m2290 esew2291 mod2292))))) (chi-sequence1821 (lambda (body2301 r2302 w2303 s2304 mod2305) (build-sequence1770 s2304 (letrec ((dobody2306 (lambda (body2307 r2308 w2309 mod2310) (if (null? body2307) (quote ()) (let ((first2311 (chi1827 (car body2307) r2308 w2309 mod2310))) (cons first2311 (dobody2306 (cdr body2307) r2308 w2309 mod2310))))))) (dobody2306 body2301 r2302 w2303 mod2305))))) (source-wrap1820 (lambda (x2312 w2313 s2314 defmod2315) (wrap1819 (if s2314 (make-annotation x2312 s2314 (quote #f)) x2312) w2313 defmod2315))) (wrap1819 (lambda (x2316 w2317 defmod2318) (cond ((and (null? (wrap-marks1794 w2317)) (null? (wrap-subst1795 w2317))) x2316) ((syntax-object?1775 x2316) (make-syntax-object1774 (syntax-object-expression1776 x2316) (join-wraps1810 w2317 (syntax-object-wrap1777 x2316)) (syntax-object-module1778 x2316))) ((null? x2316) x2316) (else (make-syntax-object1774 x2316 w2317 defmod2318))))) (bound-id-member?1818 (lambda (x2319 list2320) (and (not (null? list2320)) (or (bound-id=?1815 x2319 (car list2320)) (bound-id-member?1818 x2319 (cdr list2320)))))) (distinct-bound-ids?1817 (lambda (ids2321) (letrec ((distinct?2322 (lambda (ids2323) (or (null? ids2323) (and (not (bound-id-member?1818 (car ids2323) (cdr ids2323))) (distinct?2322 (cdr ids2323))))))) (distinct?2322 ids2321)))) (valid-bound-ids?1816 (lambda (ids2324) (and (letrec ((all-ids?2325 (lambda (ids2326) (or (null? ids2326) (and (id?1791 (car ids2326)) (all-ids?2325 (cdr ids2326))))))) (all-ids?2325 ids2324)) (distinct-bound-ids?1817 ids2324)))) (bound-id=?1815 (lambda (i2327 j2328) (if (and (syntax-object?1775 i2327) (syntax-object?1775 j2328)) (and (eq? (let ((e2329 (syntax-object-expression1776 i2327))) (if (annotation? e2329) (annotation-expression e2329) e2329)) (let ((e2330 (syntax-object-expression1776 j2328))) (if (annotation? e2330) (annotation-expression e2330) e2330))) (same-marks?1812 (wrap-marks1794 (syntax-object-wrap1777 i2327)) (wrap-marks1794 (syntax-object-wrap1777 j2328)))) (eq? (let ((e2331 i2327)) (if (annotation? e2331) (annotation-expression e2331) e2331)) (let ((e2332 j2328)) (if (annotation? e2332) (annotation-expression e2332) e2332)))))) (free-id=?1814 (lambda (i2333 j2334) (and (eq? (let ((x2335 i2333)) (let ((e2336 (if (syntax-object?1775 x2335) (syntax-object-expression1776 x2335) x2335))) (if (annotation? e2336) (annotation-expression e2336) e2336))) (let ((x2337 j2334)) (let ((e2338 (if (syntax-object?1775 x2337) (syntax-object-expression1776 x2337) x2337))) (if (annotation? e2338) (annotation-expression e2338) e2338)))) (eq? (id-var-name1813 i2333 (quote (()))) (id-var-name1813 j2334 (quote (()))))))) (id-var-name1813 (lambda (id2339 w2340) (letrec ((search-vector-rib2343 (lambda (sym2349 subst2350 marks2351 symnames2352 ribcage2353) (let ((n2354 (vector-length symnames2352))) (letrec ((f2355 (lambda (i2356) (cond ((fx=1753 i2356 n2354) (search2341 sym2349 (cdr subst2350) marks2351)) ((and (eq? (vector-ref symnames2352 i2356) sym2349) (same-marks?1812 marks2351 (vector-ref (ribcage-marks1801 ribcage2353) i2356))) (values (vector-ref (ribcage-labels1802 ribcage2353) i2356) marks2351)) (else (f2355 (fx+1751 i2356 (quote 1)))))))) (f2355 (quote 0)))))) (search-list-rib2342 (lambda (sym2357 subst2358 marks2359 symnames2360 ribcage2361) (letrec ((f2362 (lambda (symnames2363 i2364) (cond ((null? symnames2363) (search2341 sym2357 (cdr subst2358) marks2359)) ((and (eq? (car symnames2363) sym2357) (same-marks?1812 marks2359 (list-ref (ribcage-marks1801 ribcage2361) i2364))) (values (list-ref (ribcage-labels1802 ribcage2361) i2364) marks2359)) (else (f2362 (cdr symnames2363) (fx+1751 i2364 (quote 1)))))))) (f2362 symnames2360 (quote 0))))) (search2341 (lambda (sym2365 subst2366 marks2367) (if (null? subst2366) (values (quote #f) marks2367) (let ((fst2368 (car subst2366))) (if (eq? fst2368 (quote shift)) (search2341 sym2365 (cdr subst2366) (cdr marks2367)) (let ((symnames2369 (ribcage-symnames1800 fst2368))) (if (vector? symnames2369) (search-vector-rib2343 sym2365 subst2366 marks2367 symnames2369 fst2368) (search-list-rib2342 sym2365 subst2366 marks2367 symnames2369 fst2368))))))))) (cond ((symbol? id2339) (or (call-with-values (lambda () (search2341 id2339 (wrap-subst1795 w2340) (wrap-marks1794 w2340))) (lambda (x2371 . ignore2370) x2371)) id2339)) ((syntax-object?1775 id2339) (let ((id2372 (let ((e2374 (syntax-object-expression1776 id2339))) (if (annotation? e2374) (annotation-expression e2374) e2374))) (w12373 (syntax-object-wrap1777 id2339))) (let ((marks2375 (join-marks1811 (wrap-marks1794 w2340) (wrap-marks1794 w12373)))) (call-with-values (lambda () (search2341 id2372 (wrap-subst1795 w2340) marks2375)) (lambda (new-id2376 marks2377) (or new-id2376 (call-with-values (lambda () (search2341 id2372 (wrap-subst1795 w12373) marks2377)) (lambda (x2379 . ignore2378) x2379)) id2372)))))) ((annotation? id2339) (let ((id2380 (let ((e2381 id2339)) (if (annotation? e2381) (annotation-expression e2381) e2381)))) (or (call-with-values (lambda () (search2341 id2380 (wrap-subst1795 w2340) (wrap-marks1794 w2340))) (lambda (x2383 . ignore2382) x2383)) id2380))) (else (syntax-violation (quote id-var-name) (quote "invalid id") id2339)))))) (same-marks?1812 (lambda (x2384 y2385) (or (eq? x2384 y2385) (and (not (null? x2384)) (not (null? y2385)) (eq? (car x2384) (car y2385)) (same-marks?1812 (cdr x2384) (cdr y2385)))))) (join-marks1811 (lambda (m12386 m22387) (smart-append1809 m12386 m22387))) (join-wraps1810 (lambda (w12388 w22389) (let ((m12390 (wrap-marks1794 w12388)) (s12391 (wrap-subst1795 w12388))) (if (null? m12390) (if (null? s12391) w22389 (make-wrap1793 (wrap-marks1794 w22389) (smart-append1809 s12391 (wrap-subst1795 w22389)))) (make-wrap1793 (smart-append1809 m12390 (wrap-marks1794 w22389)) (smart-append1809 s12391 (wrap-subst1795 w22389))))))) (smart-append1809 (lambda (m12392 m22393) (if (null? m22393) m12392 (append m12392 m22393)))) (make-binding-wrap1808 (lambda (ids2394 labels2395 w2396) (if (null? ids2394) w2396 (make-wrap1793 (wrap-marks1794 w2396) (cons (let ((labelvec2397 (list->vector labels2395))) (let ((n2398 (vector-length labelvec2397))) (let ((symnamevec2399 (make-vector n2398)) (marksvec2400 (make-vector n2398))) (begin (letrec ((f2401 (lambda (ids2402 i2403) (if (not (null? ids2402)) (call-with-values (lambda () (id-sym-name&marks1792 (car ids2402) w2396)) (lambda (symname2404 marks2405) (begin (vector-set! symnamevec2399 i2403 symname2404) (vector-set! marksvec2400 i2403 marks2405) (f2401 (cdr ids2402) (fx+1751 i2403 (quote 1)))))))))) (f2401 ids2394 (quote 0))) (make-ribcage1798 symnamevec2399 marksvec2400 labelvec2397))))) (wrap-subst1795 w2396)))))) (extend-ribcage!1807 (lambda (ribcage2406 id2407 label2408) (begin (set-ribcage-symnames!1803 ribcage2406 (cons (let ((e2409 (syntax-object-expression1776 id2407))) (if (annotation? e2409) (annotation-expression e2409) e2409)) (ribcage-symnames1800 ribcage2406))) (set-ribcage-marks!1804 ribcage2406 (cons (wrap-marks1794 (syntax-object-wrap1777 id2407)) (ribcage-marks1801 ribcage2406))) (set-ribcage-labels!1805 ribcage2406 (cons label2408 (ribcage-labels1802 ribcage2406)))))) (anti-mark1806 (lambda (w2410) (make-wrap1793 (cons (quote #f) (wrap-marks1794 w2410)) (cons (quote shift) (wrap-subst1795 w2410))))) (set-ribcage-labels!1805 (lambda (x2411 update2412) (vector-set! x2411 (quote 3) update2412))) (set-ribcage-marks!1804 (lambda (x2413 update2414) (vector-set! x2413 (quote 2) update2414))) (set-ribcage-symnames!1803 (lambda (x2415 update2416) (vector-set! x2415 (quote 1) update2416))) (ribcage-labels1802 (lambda (x2417) (vector-ref x2417 (quote 3)))) (ribcage-marks1801 (lambda (x2418) (vector-ref x2418 (quote 2)))) (ribcage-symnames1800 (lambda (x2419) (vector-ref x2419 (quote 1)))) (ribcage?1799 (lambda (x2420) (and (vector? x2420) (= (vector-length x2420) (quote 4)) (eq? (vector-ref x2420 (quote 0)) (quote ribcage))))) (make-ribcage1798 (lambda (symnames2421 marks2422 labels2423) (vector (quote ribcage) symnames2421 marks2422 labels2423))) (gen-labels1797 (lambda (ls2424) (if (null? ls2424) (quote ()) (cons (gen-label1796) (gen-labels1797 (cdr ls2424)))))) (gen-label1796 (lambda () (string (quote #\i)))) (wrap-subst1795 cdr) (wrap-marks1794 car) (make-wrap1793 cons) (id-sym-name&marks1792 (lambda (x2425 w2426) (if (syntax-object?1775 x2425) (values (let ((e2427 (syntax-object-expression1776 x2425))) (if (annotation? e2427) (annotation-expression e2427) e2427)) (join-marks1811 (wrap-marks1794 w2426) (wrap-marks1794 (syntax-object-wrap1777 x2425)))) (values (let ((e2428 x2425)) (if (annotation? e2428) (annotation-expression e2428) e2428)) (wrap-marks1794 w2426))))) (id?1791 (lambda (x2429) (cond ((symbol? x2429) (quote #t)) ((syntax-object?1775 x2429) (symbol? (let ((e2430 (syntax-object-expression1776 x2429))) (if (annotation? e2430) (annotation-expression e2430) e2430)))) ((annotation? x2429) (symbol? (annotation-expression x2429))) (else (quote #f))))) (nonsymbol-id?1790 (lambda (x2431) (and (syntax-object?1775 x2431) (symbol? (let ((e2432 (syntax-object-expression1776 x2431))) (if (annotation? e2432) (annotation-expression e2432) e2432)))))) (global-extend1789 (lambda (type2433 sym2434 val2435) (put-global-definition-hook1757 sym2434 type2433 val2435))) (lookup1788 (lambda (x2436 r2437 mod2438) (cond ((assq x2436 r2437) => cdr) ((symbol? x2436) (or (get-global-definition-hook1758 x2436 mod2438) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1787 (lambda (r2439) (if (null? r2439) (quote ()) (let ((a2440 (car r2439))) (if (eq? (cadr a2440) (quote macro)) (cons a2440 (macros-only-env1787 (cdr r2439))) (macros-only-env1787 (cdr r2439))))))) (extend-var-env1786 (lambda (labels2441 vars2442 r2443) (if (null? labels2441) r2443 (extend-var-env1786 (cdr labels2441) (cdr vars2442) (cons (cons (car labels2441) (cons (quote lexical) (car vars2442))) r2443))))) (extend-env1785 (lambda (labels2444 bindings2445 r2446) (if (null? labels2444) r2446 (extend-env1785 (cdr labels2444) (cdr bindings2445) (cons (cons (car labels2444) (car bindings2445)) r2446))))) (binding-value1784 cdr) (binding-type1783 car) (source-annotation1782 (lambda (x2447) (cond ((annotation? x2447) (annotation-source x2447)) ((syntax-object?1775 x2447) (source-annotation1782 (syntax-object-expression1776 x2447))) (else (quote #f))))) (set-syntax-object-module!1781 (lambda (x2448 update2449) (vector-set! x2448 (quote 3) update2449))) (set-syntax-object-wrap!1780 (lambda (x2450 update2451) (vector-set! x2450 (quote 2) update2451))) (set-syntax-object-expression!1779 (lambda (x2452 update2453) (vector-set! x2452 (quote 1) update2453))) (syntax-object-module1778 (lambda (x2454) (vector-ref x2454 (quote 3)))) (syntax-object-wrap1777 (lambda (x2455) (vector-ref x2455 (quote 2)))) (syntax-object-expression1776 (lambda (x2456) (vector-ref x2456 (quote 1)))) (syntax-object?1775 (lambda (x2457) (and (vector? x2457) (= (vector-length x2457) (quote 4)) (eq? (vector-ref x2457 (quote 0)) (quote syntax-object))))) (make-syntax-object1774 (lambda (expression2458 wrap2459 module2460) (vector (quote syntax-object) expression2458 wrap2459 module2460))) (build-letrec1773 (lambda (src2461 vars2462 val-exps2463 body-exp2464) (if (null? vars2462) body-exp2464 (let ((t2465 (fluid-ref *mode*1750))) (if (memv t2465 (quote (c))) ((@ (language tree-il) make-letrec) src2461 vars2462 val-exps2463 body-exp2464) (list (quote letrec) (map list vars2462 val-exps2463) body-exp2464)))))) (build-named-let1772 (lambda (src2466 vars2467 val-exps2468 body-exp2469) (let ((f2470 (car vars2467)) (vars2471 (cdr vars2467))) (let ((t2472 (fluid-ref *mode*1750))) (if (memv t2472 (quote (c))) ((@ (language tree-il) make-letrec) src2466 (list f2470) (list (build-lambda1767 src2466 vars2471 (quote #f) body-exp2469)) (build-application1759 src2466 (build-lexical-reference1761 (quote fun) src2466 f2470 f2470) val-exps2468)) (list (quote let) f2470 (map list vars2471 val-exps2468) body-exp2469)))))) (build-let1771 (lambda (src2473 vars2474 val-exps2475 body-exp2476) (if (null? vars2474) body-exp2476 (let ((t2477 (fluid-ref *mode*1750))) (if (memv t2477 (quote (c))) ((@ (language tree-il) make-let) src2473 vars2474 val-exps2475 body-exp2476) (list (quote let) (map list vars2474 val-exps2475) body-exp2476)))))) (build-sequence1770 (lambda (src2478 exps2479) (if (null? (cdr exps2479)) (car exps2479) (let ((t2480 (fluid-ref *mode*1750))) (if (memv t2480 (quote (c))) ((@ (language tree-il) make-sequence) src2478 exps2479) (cons (quote begin) exps2479)))))) (build-data1769 (lambda (src2481 exp2482) (let ((t2483 (fluid-ref *mode*1750))) (if (memv t2483 (quote (c))) ((@ (language tree-il) make-const) src2481 exp2482) (if (and (self-evaluating? exp2482) (not (vector? exp2482))) exp2482 (list (quote quote) exp2482)))))) (build-primref1768 (lambda (src2484 name2485) (let ((t2486 (fluid-ref *mode*1750))) (if (memv t2486 (quote (c))) ((@ (language tree-il) make-primitive-ref) src2484 name2485) (build-global-reference1764 src2484 name2485 (quote (hygiene guile))))))) (build-lambda1767 (lambda (src2487 vars2488 docstring2489 exp2490) (let ((t2491 (fluid-ref *mode*1750))) (if (memv t2491 (quote (c))) ((@ (language tree-il) make-lambda) src2487 vars2488 (if docstring2489 (list (cons (quote documentation) docstring2489)) (quote ())) exp2490) (cons (quote lambda) (cons vars2488 (append (if docstring2489 (list docstring2489) (quote ())) (list exp2490)))))))) (build-global-definition1766 (lambda (source2492 var2493 exp2494) (let ((t2495 (fluid-ref *mode*1750))) (if (memv t2495 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2492 var2493 exp2494) (list (quote define) var2493 exp2494))))) (build-global-assignment1765 (lambda (source2496 var2497 exp2498 mod2499) (analyze-variable1763 mod2499 var2497 (lambda (mod2500 var2501 public?2502) (let ((t2503 (fluid-ref *mode*1750))) (if (memv t2503 (quote (c))) ((@ (language tree-il) make-module-set) source2496 mod2500 var2501 public?2502 exp2498) (list (quote set!) (list (if public?2502 (quote @) (quote @@)) mod2500 var2501) exp2498)))) (lambda (var2504) (let ((t2505 (fluid-ref *mode*1750))) (if (memv t2505 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2496 var2504 exp2498) (list (quote set!) var2504 exp2498))))))) (build-global-reference1764 (lambda (source2506 var2507 mod2508) (analyze-variable1763 mod2508 var2507 (lambda (mod2509 var2510 public?2511) (let ((t2512 (fluid-ref *mode*1750))) (if (memv t2512 (quote (c))) ((@ (language tree-il) make-module-ref) source2506 mod2509 var2510 public?2511) (list (if public?2511 (quote @) (quote @@)) mod2509 var2510)))) (lambda (var2513) (let ((t2514 (fluid-ref *mode*1750))) (if (memv t2514 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2506 var2513) var2513)))))) (analyze-variable1763 (lambda (mod2515 var2516 modref-cont2517 bare-cont2518) (if (not mod2515) (bare-cont2518 var2516) (let ((kind2519 (car mod2515)) (mod2520 (cdr mod2515))) (let ((t2521 kind2519)) (if (memv t2521 (quote (public))) (modref-cont2517 mod2520 var2516 (quote #t)) (if (memv t2521 (quote (private))) (if (not (equal? mod2520 (module-name (current-module)))) (modref-cont2517 mod2520 var2516 (quote #f)) (bare-cont2518 var2516)) (if (memv t2521 (quote (bare))) (bare-cont2518 var2516) (if (memv t2521 (quote (hygiene))) (if (and (not (equal? mod2520 (module-name (current-module)))) (module-variable (resolve-module mod2520) var2516)) (modref-cont2517 mod2520 var2516 (quote #f)) (bare-cont2518 var2516)) (syntax-violation (quote #f) (quote "bad module kind") var2516 mod2520)))))))))) (build-lexical-assignment1762 (lambda (source2522 name2523 var2524 exp2525) (let ((t2526 (fluid-ref *mode*1750))) (if (memv t2526 (quote (c))) ((@ (language tree-il) make-lexical-set) source2522 name2523 var2524 exp2525) (list (quote set!) var2524 exp2525))))) (build-lexical-reference1761 (lambda (type2527 source2528 name2529 var2530) (let ((t2531 (fluid-ref *mode*1750))) (if (memv t2531 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2528 name2529 var2530) var2530)))) (build-conditional1760 (lambda (source2532 test-exp2533 then-exp2534 else-exp2535) (let ((t2536 (fluid-ref *mode*1750))) (if (memv t2536 (quote (c))) ((@ (language tree-il) make-conditional) source2532 test-exp2533 then-exp2534 else-exp2535) (list (quote if) test-exp2533 then-exp2534 else-exp2535))))) (build-application1759 (lambda (source2537 fun-exp2538 arg-exps2539) (let ((t2540 (fluid-ref *mode*1750))) (if (memv t2540 (quote (c))) ((@ (language tree-il) make-application) source2537 fun-exp2538 arg-exps2539) (cons fun-exp2538 arg-exps2539))))) (get-global-definition-hook1758 (lambda (symbol2541 module2542) (begin (if (and (not module2542) (current-module)) (warn (quote "module system is booted, we should have a module") symbol2541)) (let ((v2543 (module-variable (if module2542 (resolve-module (cdr module2542)) (current-module)) symbol2541))) (and v2543 (variable-bound? v2543) (let ((val2544 (variable-ref v2543))) (and (macro? val2544) (syncase-macro-type val2544) (cons (syncase-macro-type val2544) (syncase-macro-binding val2544))))))))) (put-global-definition-hook1757 (lambda (symbol2545 type2546 val2547) (let ((existing2548 (let ((v2549 (module-variable (current-module) symbol2545))) (and v2549 (variable-bound? v2549) (let ((val2550 (variable-ref v2549))) (and (macro? val2550) (not (syncase-macro-type val2550)) val2550)))))) (module-define! (current-module) symbol2545 (if existing2548 (make-extended-syncase-macro existing2548 type2546 val2547) (make-syncase-macro type2546 val2547)))))) (local-eval-hook1756 (lambda (x2551 mod2552) (primitive-eval (list noexpand1749 (let ((t2553 (fluid-ref *mode*1750))) (if (memv t2553 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2551) x2551)))))) (top-level-eval-hook1755 (lambda (x2554 mod2555) (primitive-eval (list noexpand1749 (let ((t2556 (fluid-ref *mode*1750))) (if (memv t2556 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2554) x2554)))))) (fx<1754 <) (fx=1753 =) (fx-1752 -) (fx+1751 +) (*mode*1750 (make-fluid)) (noexpand1749 (quote "noexpand"))) (begin (global-extend1789 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend1789 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend1789 (quote core) (quote fluid-let-syntax) (lambda (e2557 r2558 w2559 s2560 mod2561) ((lambda (tmp2562) ((lambda (tmp2563) (if (if tmp2563 (apply (lambda (_2564 var2565 val2566 e12567 e22568) (valid-bound-ids?1816 var2565)) tmp2563) (quote #f)) (apply (lambda (_2570 var2571 val2572 e12573 e22574) (let ((names2575 (map (lambda (x2576) (id-var-name1813 x2576 w2559)) var2571))) (begin (for-each (lambda (id2578 n2579) (let ((t2580 (binding-type1783 (lookup1788 n2579 r2558 mod2561)))) (if (memv t2580 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) (quote "identifier out of context") e2557 (source-wrap1820 id2578 w2559 s2560 mod2561))))) var2571 names2575) (chi-body1831 (cons e12573 e22574) (source-wrap1820 e2557 w2559 s2560 mod2561) (extend-env1785 names2575 (let ((trans-r2583 (macros-only-env1787 r2558))) (map (lambda (x2584) (cons (quote macro) (eval-local-transformer1834 (chi1827 x2584 trans-r2583 w2559 mod2561) mod2561))) val2572)) r2558) w2559 mod2561)))) tmp2563) ((lambda (_2586) (syntax-violation (quote fluid-let-syntax) (quote "bad syntax") (source-wrap1820 e2557 w2559 s2560 mod2561))) tmp2562))) ($sc-dispatch tmp2562 (quote (any #(each (any any)) any . each-any))))) e2557))) (global-extend1789 (quote core) (quote quote) (lambda (e2587 r2588 w2589 s2590 mod2591) ((lambda (tmp2592) ((lambda (tmp2593) (if tmp2593 (apply (lambda (_2594 e2595) (build-data1769 s2590 (strip1838 e2595 w2589))) tmp2593) ((lambda (_2596) (syntax-violation (quote quote) (quote "bad syntax") (source-wrap1820 e2587 w2589 s2590 mod2591))) tmp2592))) ($sc-dispatch tmp2592 (quote (any any))))) e2587))) (global-extend1789 (quote core) (quote syntax) (letrec ((regen2604 (lambda (x2605) (let ((t2606 (car x2605))) (if (memv t2606 (quote (ref))) (build-lexical-reference1761 (quote value) (quote #f) (cadr x2605) (cadr x2605)) (if (memv t2606 (quote (primitive))) (build-primref1768 (quote #f) (cadr x2605)) (if (memv t2606 (quote (quote))) (build-data1769 (quote #f) (cadr x2605)) (if (memv t2606 (quote (lambda))) (build-lambda1767 (quote #f) (cadr x2605) (quote #f) (regen2604 (caddr x2605))) (if (memv t2606 (quote (map))) (let ((ls2607 (map regen2604 (cdr x2605)))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote map)) ls2607)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (car x2605)) (map regen2604 (cdr x2605))))))))))) (gen-vector2603 (lambda (x2608) (cond ((eq? (car x2608) (quote list)) (cons (quote vector) (cdr x2608))) ((eq? (car x2608) (quote quote)) (list (quote quote) (list->vector (cadr x2608)))) (else (list (quote list->vector) x2608))))) (gen-append2602 (lambda (x2609 y2610) (if (equal? y2610 (quote (quote ()))) x2609 (list (quote append) x2609 y2610)))) (gen-cons2601 (lambda (x2611 y2612) (let ((t2613 (car y2612))) (if (memv t2613 (quote (quote))) (if (eq? (car x2611) (quote quote)) (list (quote quote) (cons (cadr x2611) (cadr y2612))) (if (eq? (cadr y2612) (quote ())) (list (quote list) x2611) (list (quote cons) x2611 y2612))) (if (memv t2613 (quote (list))) (cons (quote list) (cons x2611 (cdr y2612))) (list (quote cons) x2611 y2612)))))) (gen-map2600 (lambda (e2614 map-env2615) (let ((formals2616 (map cdr map-env2615)) (actuals2617 (map (lambda (x2618) (list (quote ref) (car x2618))) map-env2615))) (cond ((eq? (car e2614) (quote ref)) (car actuals2617)) ((and-map (lambda (x2619) (and (eq? (car x2619) (quote ref)) (memq (cadr x2619) formals2616))) (cdr e2614)) (cons (quote map) (cons (list (quote primitive) (car e2614)) (map (let ((r2620 (map cons formals2616 actuals2617))) (lambda (x2621) (cdr (assq (cadr x2621) r2620)))) (cdr e2614))))) (else (cons (quote map) (cons (list (quote lambda) formals2616 e2614) actuals2617))))))) (gen-mappend2599 (lambda (e2622 map-env2623) (list (quote apply) (quote (primitive append)) (gen-map2600 e2622 map-env2623)))) (gen-ref2598 (lambda (src2624 var2625 level2626 maps2627) (if (fx=1753 level2626 (quote 0)) (values var2625 maps2627) (if (null? maps2627) (syntax-violation (quote syntax) (quote "missing ellipsis") src2624) (call-with-values (lambda () (gen-ref2598 src2624 var2625 (fx-1752 level2626 (quote 1)) (cdr maps2627))) (lambda (outer-var2628 outer-maps2629) (let ((b2630 (assq outer-var2628 (car maps2627)))) (if b2630 (values (cdr b2630) maps2627) (let ((inner-var2631 (gen-var1839 (quote tmp)))) (values inner-var2631 (cons (cons (cons outer-var2628 inner-var2631) (car maps2627)) outer-maps2629))))))))))) (gen-syntax2597 (lambda (src2632 e2633 r2634 maps2635 ellipsis?2636 mod2637) (if (id?1791 e2633) (let ((label2638 (id-var-name1813 e2633 (quote (()))))) (let ((b2639 (lookup1788 label2638 r2634 mod2637))) (if (eq? (binding-type1783 b2639) (quote syntax)) (call-with-values (lambda () (let ((var.lev2640 (binding-value1784 b2639))) (gen-ref2598 src2632 (car var.lev2640) (cdr var.lev2640) maps2635))) (lambda (var2641 maps2642) (values (list (quote ref) var2641) maps2642))) (if (ellipsis?2636 e2633) (syntax-violation (quote syntax) (quote "misplaced ellipsis") src2632) (values (list (quote quote) e2633) maps2635))))) ((lambda (tmp2643) ((lambda (tmp2644) (if (if tmp2644 (apply (lambda (dots2645 e2646) (ellipsis?2636 dots2645)) tmp2644) (quote #f)) (apply (lambda (dots2647 e2648) (gen-syntax2597 src2632 e2648 r2634 maps2635 (lambda (x2649) (quote #f)) mod2637)) tmp2644) ((lambda (tmp2650) (if (if tmp2650 (apply (lambda (x2651 dots2652 y2653) (ellipsis?2636 dots2652)) tmp2650) (quote #f)) (apply (lambda (x2654 dots2655 y2656) (letrec ((f2657 (lambda (y2658 k2659) ((lambda (tmp2663) ((lambda (tmp2664) (if (if tmp2664 (apply (lambda (dots2665 y2666) (ellipsis?2636 dots2665)) tmp2664) (quote #f)) (apply (lambda (dots2667 y2668) (f2657 y2668 (lambda (maps2669) (call-with-values (lambda () (k2659 (cons (quote ()) maps2669))) (lambda (x2670 maps2671) (if (null? (car maps2671)) (syntax-violation (quote syntax) (quote "extra ellipsis") src2632) (values (gen-mappend2599 x2670 (car maps2671)) (cdr maps2671)))))))) tmp2664) ((lambda (_2672) (call-with-values (lambda () (gen-syntax2597 src2632 y2658 r2634 maps2635 ellipsis?2636 mod2637)) (lambda (y2673 maps2674) (call-with-values (lambda () (k2659 maps2674)) (lambda (x2675 maps2676) (values (gen-append2602 x2675 y2673) maps2676)))))) tmp2663))) ($sc-dispatch tmp2663 (quote (any . any))))) y2658)))) (f2657 y2656 (lambda (maps2660) (call-with-values (lambda () (gen-syntax2597 src2632 x2654 r2634 (cons (quote ()) maps2660) ellipsis?2636 mod2637)) (lambda (x2661 maps2662) (if (null? (car maps2662)) (syntax-violation (quote syntax) (quote "extra ellipsis") src2632) (values (gen-map2600 x2661 (car maps2662)) (cdr maps2662))))))))) tmp2650) ((lambda (tmp2677) (if tmp2677 (apply (lambda (x2678 y2679) (call-with-values (lambda () (gen-syntax2597 src2632 x2678 r2634 maps2635 ellipsis?2636 mod2637)) (lambda (x2680 maps2681) (call-with-values (lambda () (gen-syntax2597 src2632 y2679 r2634 maps2681 ellipsis?2636 mod2637)) (lambda (y2682 maps2683) (values (gen-cons2601 x2680 y2682) maps2683)))))) tmp2677) ((lambda (tmp2684) (if tmp2684 (apply (lambda (e12685 e22686) (call-with-values (lambda () (gen-syntax2597 src2632 (cons e12685 e22686) r2634 maps2635 ellipsis?2636 mod2637)) (lambda (e2688 maps2689) (values (gen-vector2603 e2688) maps2689)))) tmp2684) ((lambda (_2690) (values (list (quote quote) e2633) maps2635)) tmp2643))) ($sc-dispatch tmp2643 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2643 (quote (any . any)))))) ($sc-dispatch tmp2643 (quote (any any . any)))))) ($sc-dispatch tmp2643 (quote (any any))))) e2633))))) (lambda (e2691 r2692 w2693 s2694 mod2695) (let ((e2696 (source-wrap1820 e2691 w2693 s2694 mod2695))) ((lambda (tmp2697) ((lambda (tmp2698) (if tmp2698 (apply (lambda (_2699 x2700) (call-with-values (lambda () (gen-syntax2597 e2696 x2700 r2692 (quote ()) ellipsis?1836 mod2695)) (lambda (e2701 maps2702) (regen2604 e2701)))) tmp2698) ((lambda (_2703) (syntax-violation (quote syntax) (quote "bad `syntax' form") e2696)) tmp2697))) ($sc-dispatch tmp2697 (quote (any any))))) e2696))))) (global-extend1789 (quote core) (quote lambda) (lambda (e2704 r2705 w2706 s2707 mod2708) ((lambda (tmp2709) ((lambda (tmp2710) (if tmp2710 (apply (lambda (_2711 c2712) (chi-lambda-clause1832 (source-wrap1820 e2704 w2706 s2707 mod2708) (quote #f) c2712 r2705 w2706 mod2708 (lambda (vars2713 docstring2714 body2715) (build-lambda1767 s2707 vars2713 docstring2714 body2715)))) tmp2710) (syntax-violation #f "source expression failed to match any pattern" tmp2709))) ($sc-dispatch tmp2709 (quote (any . any))))) e2704))) (global-extend1789 (quote core) (quote let) (letrec ((chi-let2716 (lambda (e2717 r2718 w2719 s2720 mod2721 constructor2722 ids2723 vals2724 exps2725) (if (not (valid-bound-ids?1816 ids2723)) (syntax-violation (quote let) (quote "duplicate bound variable") e2717) (let ((labels2726 (gen-labels1797 ids2723)) (new-vars2727 (map gen-var1839 ids2723))) (let ((nw2728 (make-binding-wrap1808 ids2723 labels2726 w2719)) (nr2729 (extend-var-env1786 labels2726 new-vars2727 r2718))) (constructor2722 s2720 new-vars2727 (map (lambda (x2730) (chi1827 x2730 r2718 w2719 mod2721)) vals2724) (chi-body1831 exps2725 (source-wrap1820 e2717 nw2728 s2720 mod2721) nr2729 nw2728 mod2721)))))))) (lambda (e2731 r2732 w2733 s2734 mod2735) ((lambda (tmp2736) ((lambda (tmp2737) (if tmp2737 (apply (lambda (_2738 id2739 val2740 e12741 e22742) (chi-let2716 e2731 r2732 w2733 s2734 mod2735 build-let1771 id2739 val2740 (cons e12741 e22742))) tmp2737) ((lambda (tmp2746) (if (if tmp2746 (apply (lambda (_2747 f2748 id2749 val2750 e12751 e22752) (id?1791 f2748)) tmp2746) (quote #f)) (apply (lambda (_2753 f2754 id2755 val2756 e12757 e22758) (chi-let2716 e2731 r2732 w2733 s2734 mod2735 build-named-let1772 (cons f2754 id2755) val2756 (cons e12757 e22758))) tmp2746) ((lambda (_2762) (syntax-violation (quote let) (quote "bad let") (source-wrap1820 e2731 w2733 s2734 mod2735))) tmp2736))) ($sc-dispatch tmp2736 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2736 (quote (any #(each (any any)) any . each-any))))) e2731)))) (global-extend1789 (quote core) (quote letrec) (lambda (e2763 r2764 w2765 s2766 mod2767) ((lambda (tmp2768) ((lambda (tmp2769) (if tmp2769 (apply (lambda (_2770 id2771 val2772 e12773 e22774) (let ((ids2775 id2771)) (if (not (valid-bound-ids?1816 ids2775)) (syntax-violation (quote letrec) (quote "duplicate bound variable") e2763) (let ((labels2777 (gen-labels1797 ids2775)) (new-vars2778 (map gen-var1839 ids2775))) (let ((w2779 (make-binding-wrap1808 ids2775 labels2777 w2765)) (r2780 (extend-var-env1786 labels2777 new-vars2778 r2764))) (build-letrec1773 s2766 new-vars2778 (map (lambda (x2781) (chi1827 x2781 r2780 w2779 mod2767)) val2772) (chi-body1831 (cons e12773 e22774) (source-wrap1820 e2763 w2779 s2766 mod2767) r2780 w2779 mod2767))))))) tmp2769) ((lambda (_2784) (syntax-violation (quote letrec) (quote "bad letrec") (source-wrap1820 e2763 w2765 s2766 mod2767))) tmp2768))) ($sc-dispatch tmp2768 (quote (any #(each (any any)) any . each-any))))) e2763))) (global-extend1789 (quote core) (quote set!) (lambda (e2785 r2786 w2787 s2788 mod2789) ((lambda (tmp2790) ((lambda (tmp2791) (if (if tmp2791 (apply (lambda (_2792 id2793 val2794) (id?1791 id2793)) tmp2791) (quote #f)) (apply (lambda (_2795 id2796 val2797) (let ((val2798 (chi1827 val2797 r2786 w2787 mod2789)) (n2799 (id-var-name1813 id2796 w2787))) (let ((b2800 (lookup1788 n2799 r2786 mod2789))) (let ((t2801 (binding-type1783 b2800))) (if (memv t2801 (quote (lexical))) (build-lexical-assignment1762 s2788 (syntax->datum id2796) (binding-value1784 b2800) val2798) (if (memv t2801 (quote (global))) (build-global-assignment1765 s2788 n2799 val2798 mod2789) (if (memv t2801 (quote (displaced-lexical))) (syntax-violation (quote set!) (quote "identifier out of context") (wrap1819 id2796 w2787 mod2789)) (syntax-violation (quote set!) (quote "bad set!") (source-wrap1820 e2785 w2787 s2788 mod2789))))))))) tmp2791) ((lambda (tmp2802) (if tmp2802 (apply (lambda (_2803 head2804 tail2805 val2806) (call-with-values (lambda () (syntax-type1825 head2804 r2786 (quote (())) (quote #f) (quote #f) mod2789)) (lambda (type2807 value2808 ee2809 ww2810 ss2811 modmod2812) (let ((t2813 type2807)) (if (memv t2813 (quote (module-ref))) (let ((val2814 (chi1827 val2806 r2786 w2787 mod2789))) (call-with-values (lambda () (value2808 (cons head2804 tail2805))) (lambda (id2816 mod2817) (build-global-assignment1765 s2788 id2816 val2814 mod2817)))) (build-application1759 s2788 (chi1827 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2804) r2786 w2787 mod2789) (map (lambda (e2818) (chi1827 e2818 r2786 w2787 mod2789)) (append tail2805 (list val2806))))))))) tmp2802) ((lambda (_2820) (syntax-violation (quote set!) (quote "bad set!") (source-wrap1820 e2785 w2787 s2788 mod2789))) tmp2790))) ($sc-dispatch tmp2790 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2790 (quote (any any any))))) e2785))) (global-extend1789 (quote module-ref) (quote @) (lambda (e2821) ((lambda (tmp2822) ((lambda (tmp2823) (if (if tmp2823 (apply (lambda (_2824 mod2825 id2826) (and (and-map id?1791 mod2825) (id?1791 id2826))) tmp2823) (quote #f)) (apply (lambda (_2828 mod2829 id2830) (values (syntax->datum id2830) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2829)))) tmp2823) (syntax-violation #f "source expression failed to match any pattern" tmp2822))) ($sc-dispatch tmp2822 (quote (any each-any any))))) e2821))) (global-extend1789 (quote module-ref) (quote @@) (lambda (e2832) ((lambda (tmp2833) ((lambda (tmp2834) (if (if tmp2834 (apply (lambda (_2835 mod2836 id2837) (and (and-map id?1791 mod2836) (id?1791 id2837))) tmp2834) (quote #f)) (apply (lambda (_2839 mod2840 id2841) (values (syntax->datum id2841) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2840)))) tmp2834) (syntax-violation #f "source expression failed to match any pattern" tmp2833))) ($sc-dispatch tmp2833 (quote (any each-any any))))) e2832))) (global-extend1789 (quote begin) (quote begin) (quote ())) (global-extend1789 (quote define) (quote define) (quote ())) (global-extend1789 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1789 (quote eval-when) (quote eval-when) (quote ())) (global-extend1789 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2846 (lambda (x2847 keys2848 clauses2849 r2850 mod2851) (if (null? clauses2849) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote syntax-violation)) (list (quote #f) (quote "source expression failed to match any pattern") x2847)) ((lambda (tmp2852) ((lambda (tmp2853) (if tmp2853 (apply (lambda (pat2854 exp2855) (if (and (id?1791 pat2854) (and-map (lambda (x2856) (not (free-id=?1814 pat2854 x2856))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2848))) (let ((labels2857 (list (gen-label1796))) (var2858 (gen-var1839 pat2854))) (build-application1759 (quote #f) (build-lambda1767 (quote #f) (list var2858) (quote #f) (chi1827 exp2855 (extend-env1785 labels2857 (list (cons (quote syntax) (cons var2858 (quote 0)))) r2850) (make-binding-wrap1808 (list pat2854) labels2857 (quote (()))) mod2851)) (list x2847))) (gen-clause2845 x2847 keys2848 (cdr clauses2849) r2850 pat2854 (quote #t) exp2855 mod2851))) tmp2853) ((lambda (tmp2859) (if tmp2859 (apply (lambda (pat2860 fender2861 exp2862) (gen-clause2845 x2847 keys2848 (cdr clauses2849) r2850 pat2860 fender2861 exp2862 mod2851)) tmp2859) ((lambda (_2863) (syntax-violation (quote syntax-case) (quote "invalid clause") (car clauses2849))) tmp2852))) ($sc-dispatch tmp2852 (quote (any any any)))))) ($sc-dispatch tmp2852 (quote (any any))))) (car clauses2849))))) (gen-clause2845 (lambda (x2864 keys2865 clauses2866 r2867 pat2868 fender2869 exp2870 mod2871) (call-with-values (lambda () (convert-pattern2843 pat2868 keys2865)) (lambda (p2872 pvars2873) (cond ((not (distinct-bound-ids?1817 (map car pvars2873))) (syntax-violation (quote syntax-case) (quote "duplicate pattern variable") pat2868)) ((not (and-map (lambda (x2874) (not (ellipsis?1836 (car x2874)))) pvars2873)) (syntax-violation (quote syntax-case) (quote "misplaced ellipsis") pat2868)) (else (let ((y2875 (gen-var1839 (quote tmp)))) (build-application1759 (quote #f) (build-lambda1767 (quote #f) (list y2875) (quote #f) (let ((y2876 (build-lexical-reference1761 (quote value) (quote #f) (quote tmp) y2875))) (build-conditional1760 (quote #f) ((lambda (tmp2877) ((lambda (tmp2878) (if tmp2878 (apply (lambda () y2876) tmp2878) ((lambda (_2879) (build-conditional1760 (quote #f) y2876 (build-dispatch-call2844 pvars2873 fender2869 y2876 r2867 mod2871) (build-data1769 (quote #f) (quote #f)))) tmp2877))) ($sc-dispatch tmp2877 (quote #(atom #t))))) fender2869) (build-dispatch-call2844 pvars2873 exp2870 y2876 r2867 mod2871) (gen-syntax-case2846 x2864 keys2865 clauses2866 r2867 mod2871)))) (list (if (eq? p2872 (quote any)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote list)) (list x2864)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote $sc-dispatch)) (list x2864 (build-data1769 (quote #f) p2872))))))))))))) (build-dispatch-call2844 (lambda (pvars2880 exp2881 y2882 r2883 mod2884) (let ((ids2885 (map car pvars2880)) (levels2886 (map cdr pvars2880))) (let ((labels2887 (gen-labels1797 ids2885)) (new-vars2888 (map gen-var1839 ids2885))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote apply)) (list (build-lambda1767 (quote #f) new-vars2888 (quote #f) (chi1827 exp2881 (extend-env1785 labels2887 (map (lambda (var2889 level2890) (cons (quote syntax) (cons var2889 level2890))) new-vars2888 (map cdr pvars2880)) r2883) (make-binding-wrap1808 ids2885 labels2887 (quote (()))) mod2884)) y2882)))))) (convert-pattern2843 (lambda (pattern2891 keys2892) (letrec ((cvt2893 (lambda (p2894 n2895 ids2896) (if (id?1791 p2894) (if (bound-id-member?1818 p2894 keys2892) (values (vector (quote free-id) p2894) ids2896) (values (quote any) (cons (cons p2894 n2895) ids2896))) ((lambda (tmp2897) ((lambda (tmp2898) (if (if tmp2898 (apply (lambda (x2899 dots2900) (ellipsis?1836 dots2900)) tmp2898) (quote #f)) (apply (lambda (x2901 dots2902) (call-with-values (lambda () (cvt2893 x2901 (fx+1751 n2895 (quote 1)) ids2896)) (lambda (p2903 ids2904) (values (if (eq? p2903 (quote any)) (quote each-any) (vector (quote each) p2903)) ids2904)))) tmp2898) ((lambda (tmp2905) (if tmp2905 (apply (lambda (x2906 y2907) (call-with-values (lambda () (cvt2893 y2907 n2895 ids2896)) (lambda (y2908 ids2909) (call-with-values (lambda () (cvt2893 x2906 n2895 ids2909)) (lambda (x2910 ids2911) (values (cons x2910 y2908) ids2911)))))) tmp2905) ((lambda (tmp2912) (if tmp2912 (apply (lambda () (values (quote ()) ids2896)) tmp2912) ((lambda (tmp2913) (if tmp2913 (apply (lambda (x2914) (call-with-values (lambda () (cvt2893 x2914 n2895 ids2896)) (lambda (p2916 ids2917) (values (vector (quote vector) p2916) ids2917)))) tmp2913) ((lambda (x2918) (values (vector (quote atom) (strip1838 p2894 (quote (())))) ids2896)) tmp2897))) ($sc-dispatch tmp2897 (quote #(vector each-any)))))) ($sc-dispatch tmp2897 (quote ()))))) ($sc-dispatch tmp2897 (quote (any . any)))))) ($sc-dispatch tmp2897 (quote (any any))))) p2894))))) (cvt2893 pattern2891 (quote 0) (quote ())))))) (lambda (e2919 r2920 w2921 s2922 mod2923) (let ((e2924 (source-wrap1820 e2919 w2921 s2922 mod2923))) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 val2928 key2929 m2930) (if (and-map (lambda (x2931) (and (id?1791 x2931) (not (ellipsis?1836 x2931)))) key2929) (let ((x2933 (gen-var1839 (quote tmp)))) (build-application1759 s2922 (build-lambda1767 (quote #f) (list x2933) (quote #f) (gen-syntax-case2846 (build-lexical-reference1761 (quote value) (quote #f) (quote tmp) x2933) key2929 m2930 r2920 mod2923)) (list (chi1827 val2928 r2920 (quote (())) mod2923)))) (syntax-violation (quote syntax-case) (quote "invalid literals list") e2924))) tmp2926) (syntax-violation #f "source expression failed to match any pattern" tmp2925))) ($sc-dispatch tmp2925 (quote (any any each-any . each-any))))) e2924))))) (set! sc-expand (lambda (x2937 . rest2936) (if (and (pair? x2937) (equal? (car x2937) noexpand1749)) (cadr x2937) (let ((m2938 (if (null? rest2936) (quote e) (car rest2936))) (esew2939 (if (or (null? rest2936) (null? (cdr rest2936))) (quote (eval)) (cadr rest2936)))) (with-fluid* *mode*1750 m2938 (lambda () (chi-top1826 x2937 (quote ()) (quote ((top))) m2938 esew2939 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x2940) (nonsymbol-id?1790 x2940))) (set! datum->syntax (lambda (id2941 datum2942) (make-syntax-object1774 datum2942 (syntax-object-wrap1777 id2941) (quote #f)))) (set! syntax->datum (lambda (x2943) (strip1838 x2943 (quote (()))))) (set! generate-temporaries (lambda (ls2944) (begin (let ((x2945 ls2944)) (if (not (list? x2945)) (syntax-violation (quote generate-temporaries) (quote "invalid argument") x2945))) (map (lambda (x2946) (wrap1819 (gensym) (quote ((top))) (quote #f))) ls2944)))) (set! free-identifier=? (lambda (x2947 y2948) (begin (let ((x2949 x2947)) (if (not (nonsymbol-id?1790 x2949)) (syntax-violation (quote free-identifier=?) (quote "invalid argument") x2949))) (let ((x2950 y2948)) (if (not (nonsymbol-id?1790 x2950)) (syntax-violation (quote free-identifier=?) (quote "invalid argument") x2950))) (free-id=?1814 x2947 y2948)))) (set! bound-identifier=? (lambda (x2951 y2952) (begin (let ((x2953 x2951)) (if (not (nonsymbol-id?1790 x2953)) (syntax-violation (quote bound-identifier=?) (quote "invalid argument") x2953))) (let ((x2954 y2952)) (if (not (nonsymbol-id?1790 x2954)) (syntax-violation (quote bound-identifier=?) (quote "invalid argument") x2954))) (bound-id=?1815 x2951 y2952)))) (set! syntax-violation (lambda (who2958 message2957 form2956 . subform2955) (begin (let ((x2959 who2958)) (if (not ((lambda (x2960) (or (not x2960) (string? x2960) (symbol? x2960))) x2959)) (syntax-violation (quote syntax-violation) (quote "invalid argument") x2959))) (let ((x2961 message2957)) (if (not (string? x2961)) (syntax-violation (quote syntax-violation) (quote "invalid argument") x2961))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2958 (quote "~a: ") (quote "")) (quote "~a ") (if (null? subform2955) (quote "in ~a") (quote "in subform `~s' of `~s'"))) (let ((tail2962 (cons message2957 (map (lambda (x2963) (strip1838 x2963 (quote (())))) (append subform2955 (list form2956)))))) (if who2958 (cons who2958 tail2962) tail2962)) (quote #f))))) (letrec ((match2968 (lambda (e2969 p2970 w2971 r2972 mod2973) (cond ((not r2972) (quote #f)) ((eq? p2970 (quote any)) (cons (wrap1819 e2969 w2971 mod2973) r2972)) ((syntax-object?1775 e2969) (match*2967 (let ((e2974 (syntax-object-expression1776 e2969))) (if (annotation? e2974) (annotation-expression e2974) e2974)) p2970 (join-wraps1810 w2971 (syntax-object-wrap1777 e2969)) r2972 (syntax-object-module1778 e2969))) (else (match*2967 (let ((e2975 e2969)) (if (annotation? e2975) (annotation-expression e2975) e2975)) p2970 w2971 r2972 mod2973))))) (match*2967 (lambda (e2976 p2977 w2978 r2979 mod2980) (cond ((null? p2977) (and (null? e2976) r2979)) ((pair? p2977) (and (pair? e2976) (match2968 (car e2976) (car p2977) w2978 (match2968 (cdr e2976) (cdr p2977) w2978 r2979 mod2980) mod2980))) ((eq? p2977 (quote each-any)) (let ((l2981 (match-each-any2965 e2976 w2978 mod2980))) (and l2981 (cons l2981 r2979)))) (else (let ((t2982 (vector-ref p2977 (quote 0)))) (if (memv t2982 (quote (each))) (if (null? e2976) (match-empty2966 (vector-ref p2977 (quote 1)) r2979) (let ((l2983 (match-each2964 e2976 (vector-ref p2977 (quote 1)) w2978 mod2980))) (and l2983 (letrec ((collect2984 (lambda (l2985) (if (null? (car l2985)) r2979 (cons (map car l2985) (collect2984 (map cdr l2985))))))) (collect2984 l2983))))) (if (memv t2982 (quote (free-id))) (and (id?1791 e2976) (free-id=?1814 (wrap1819 e2976 w2978 mod2980) (vector-ref p2977 (quote 1))) r2979) (if (memv t2982 (quote (atom))) (and (equal? (vector-ref p2977 (quote 1)) (strip1838 e2976 w2978)) r2979) (if (memv t2982 (quote (vector))) (and (vector? e2976) (match2968 (vector->list e2976) (vector-ref p2977 (quote 1)) w2978 r2979 mod2980))))))))))) (match-empty2966 (lambda (p2986 r2987) (cond ((null? p2986) r2987) ((eq? p2986 (quote any)) (cons (quote ()) r2987)) ((pair? p2986) (match-empty2966 (car p2986) (match-empty2966 (cdr p2986) r2987))) ((eq? p2986 (quote each-any)) (cons (quote ()) r2987)) (else (let ((t2988 (vector-ref p2986 (quote 0)))) (if (memv t2988 (quote (each))) (match-empty2966 (vector-ref p2986 (quote 1)) r2987) (if (memv t2988 (quote (free-id atom))) r2987 (if (memv t2988 (quote (vector))) (match-empty2966 (vector-ref p2986 (quote 1)) r2987))))))))) (match-each-any2965 (lambda (e2989 w2990 mod2991) (cond ((annotation? e2989) (match-each-any2965 (annotation-expression e2989) w2990 mod2991)) ((pair? e2989) (let ((l2992 (match-each-any2965 (cdr e2989) w2990 mod2991))) (and l2992 (cons (wrap1819 (car e2989) w2990 mod2991) l2992)))) ((null? e2989) (quote ())) ((syntax-object?1775 e2989) (match-each-any2965 (syntax-object-expression1776 e2989) (join-wraps1810 w2990 (syntax-object-wrap1777 e2989)) mod2991)) (else (quote #f))))) (match-each2964 (lambda (e2993 p2994 w2995 mod2996) (cond ((annotation? e2993) (match-each2964 (annotation-expression e2993) p2994 w2995 mod2996)) ((pair? e2993) (let ((first2997 (match2968 (car e2993) p2994 w2995 (quote ()) mod2996))) (and first2997 (let ((rest2998 (match-each2964 (cdr e2993) p2994 w2995 mod2996))) (and rest2998 (cons first2997 rest2998)))))) ((null? e2993) (quote ())) ((syntax-object?1775 e2993) (match-each2964 (syntax-object-expression1776 e2993) p2994 (join-wraps1810 w2995 (syntax-object-wrap1777 e2993)) (syntax-object-module1778 e2993))) (else (quote #f)))))) (set! $sc-dispatch (lambda (e2999 p3000) (cond ((eq? p3000 (quote any)) (list e2999)) ((syntax-object?1775 e2999) (match*2967 (let ((e3001 (syntax-object-expression1776 e2999))) (if (annotation? e3001) (annotation-expression e3001) e3001)) p3000 (syntax-object-wrap1777 e2999) (quote ()) (syntax-object-module1778 e2999))) (else (match*2967 (let ((e3002 e2999)) (if (annotation? e3002) (annotation-expression e3002) e3002)) p3000 (quote (())) (quote ()) (quote #f)))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x3003) ((lambda (tmp3004) ((lambda (tmp3005) (if tmp3005 (apply (lambda (_3006 e13007 e23008) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13007 e23008))) tmp3005) ((lambda (tmp3010) (if tmp3010 (apply (lambda (_3011 out3012 in3013 e13014 e23015) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3013 (quote ()) (list out3012 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13014 e23015))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (_3018 out3019 in3020 e13021 e23022) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3020) (quote ()) (list out3019 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13021 e23022))))) tmp3017) (syntax-violation #f "source expression failed to match any pattern" tmp3004))) ($sc-dispatch tmp3004 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3004 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3004 (quote (any () any . each-any))))) x3003)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3026) ((lambda (tmp3027) ((lambda (tmp3028) (if tmp3028 (apply (lambda (_3029 k3030 keyword3031 pattern3032 template3033) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k3030 (map (lambda (tmp3036 tmp3035) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3035) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3036))) template3033 pattern3032)))))) tmp3028) (syntax-violation #f "source expression failed to match any pattern" tmp3027))) ($sc-dispatch tmp3027 (quote (any each-any . #(each ((any . any) any))))))) x3026)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3037) ((lambda (tmp3038) ((lambda (tmp3039) (if (if tmp3039 (apply (lambda (let*3040 x3041 v3042 e13043 e23044) (and-map identifier? x3041)) tmp3039) (quote #f)) (apply (lambda (let*3046 x3047 v3048 e13049 e23050) (letrec ((f3051 (lambda (bindings3052) (if (null? bindings3052) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e13049 e23050))) ((lambda (tmp3056) ((lambda (tmp3057) (if tmp3057 (apply (lambda (body3058 binding3059) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding3059) body3058)) tmp3057) (syntax-violation #f "source expression failed to match any pattern" tmp3056))) ($sc-dispatch tmp3056 (quote (any any))))) (list (f3051 (cdr bindings3052)) (car bindings3052))))))) (f3051 (map list x3047 v3048)))) tmp3039) (syntax-violation #f "source expression failed to match any pattern" tmp3038))) ($sc-dispatch tmp3038 (quote (any #(each (any any)) any . each-any))))) x3037)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3060) ((lambda (tmp3061) ((lambda (tmp3062) (if tmp3062 (apply (lambda (_3063 var3064 init3065 step3066 e03067 e13068 c3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (step3072) ((lambda (tmp3073) ((lambda (tmp3074) (if tmp3074 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3064 init3065) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03067) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3069 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3072))))))) tmp3074) ((lambda (tmp3079) (if tmp3079 (apply (lambda (e13080 e23081) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3064 init3065) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03067 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e13080 e23081)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3069 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3072))))))) tmp3079) (syntax-violation #f "source expression failed to match any pattern" tmp3073))) ($sc-dispatch tmp3073 (quote (any . each-any)))))) ($sc-dispatch tmp3073 (quote ())))) e13068)) tmp3071) (syntax-violation #f "source expression failed to match any pattern" tmp3070))) ($sc-dispatch tmp3070 (quote each-any)))) (map (lambda (v3088 s3089) ((lambda (tmp3090) ((lambda (tmp3091) (if tmp3091 (apply (lambda () v3088) tmp3091) ((lambda (tmp3092) (if tmp3092 (apply (lambda (e3093) e3093) tmp3092) ((lambda (_3094) (syntax-violation (quote do) (quote "bad step expression") orig-x3060 s3089)) tmp3090))) ($sc-dispatch tmp3090 (quote (any)))))) ($sc-dispatch tmp3090 (quote ())))) s3089)) var3064 step3066))) tmp3062) (syntax-violation #f "source expression failed to match any pattern" tmp3061))) ($sc-dispatch tmp3061 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3060)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3097 (lambda (x3101 y3102) ((lambda (tmp3103) ((lambda (tmp3104) (if tmp3104 (apply (lambda (x3105 y3106) ((lambda (tmp3107) ((lambda (tmp3108) (if tmp3108 (apply (lambda (dy3109) ((lambda (tmp3110) ((lambda (tmp3111) (if tmp3111 (apply (lambda (dx3112) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx3112 dy3109))) tmp3111) ((lambda (_3113) (if (null? dy3109) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3105) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3105 y3106))) tmp3110))) ($sc-dispatch tmp3110 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x3105)) tmp3108) ((lambda (tmp3114) (if tmp3114 (apply (lambda (stuff3115) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x3105 stuff3115))) tmp3114) ((lambda (else3116) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3105 y3106)) tmp3107))) ($sc-dispatch tmp3107 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp3107 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y3106)) tmp3104) (syntax-violation #f "source expression failed to match any pattern" tmp3103))) ($sc-dispatch tmp3103 (quote (any any))))) (list x3101 y3102)))) (quasiappend3098 (lambda (x3117 y3118) ((lambda (tmp3119) ((lambda (tmp3120) (if tmp3120 (apply (lambda (x3121 y3122) ((lambda (tmp3123) ((lambda (tmp3124) (if tmp3124 (apply (lambda () x3121) tmp3124) ((lambda (_3125) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3121 y3122)) tmp3123))) ($sc-dispatch tmp3123 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y3122)) tmp3120) (syntax-violation #f "source expression failed to match any pattern" tmp3119))) ($sc-dispatch tmp3119 (quote (any any))))) (list x3117 y3118)))) (quasivector3099 (lambda (x3126) ((lambda (tmp3127) ((lambda (x3128) ((lambda (tmp3129) ((lambda (tmp3130) (if tmp3130 (apply (lambda (x3131) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x3131))) tmp3130) ((lambda (tmp3133) (if tmp3133 (apply (lambda (x3134) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3134)) tmp3133) ((lambda (_3136) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3128)) tmp3129))) ($sc-dispatch tmp3129 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp3129 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x3128)) tmp3127)) x3126))) (quasi3100 (lambda (p3137 lev3138) ((lambda (tmp3139) ((lambda (tmp3140) (if tmp3140 (apply (lambda (p3141) (if (= lev3138 (quote 0)) p3141 (quasicons3097 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3100 (list p3141) (- lev3138 (quote 1)))))) tmp3140) ((lambda (tmp3142) (if tmp3142 (apply (lambda (p3143 q3144) (if (= lev3138 (quote 0)) (quasiappend3098 p3143 (quasi3100 q3144 lev3138)) (quasicons3097 (quasicons3097 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3100 (list p3143) (- lev3138 (quote 1)))) (quasi3100 q3144 lev3138)))) tmp3142) ((lambda (tmp3145) (if tmp3145 (apply (lambda (p3146) (quasicons3097 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3100 (list p3146) (+ lev3138 (quote 1))))) tmp3145) ((lambda (tmp3147) (if tmp3147 (apply (lambda (p3148 q3149) (quasicons3097 (quasi3100 p3148 lev3138) (quasi3100 q3149 lev3138))) tmp3147) ((lambda (tmp3150) (if tmp3150 (apply (lambda (x3151) (quasivector3099 (quasi3100 x3151 lev3138))) tmp3150) ((lambda (p3153) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p3153)) tmp3139))) ($sc-dispatch tmp3139 (quote #(vector each-any)))))) ($sc-dispatch tmp3139 (quote (any . any)))))) ($sc-dispatch tmp3139 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp3139 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp3139 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p3137)))) (lambda (x3154) ((lambda (tmp3155) ((lambda (tmp3156) (if tmp3156 (apply (lambda (_3157 e3158) (quasi3100 e3158 (quote 0))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any any))))) x3154))))) -(define include (make-syncase-macro (quote macro) (lambda (x3159) (letrec ((read-file3160 (lambda (fn3161 k3162) (let ((p3163 (open-input-file fn3161))) (letrec ((f3164 (lambda (x3165) (if (eof-object? x3165) (begin (close-input-port p3163) (quote ())) (cons (datum->syntax k3162 x3165) (f3164 (read p3163))))))) (f3164 (read p3163))))))) ((lambda (tmp3166) ((lambda (tmp3167) (if tmp3167 (apply (lambda (k3168 filename3169) (let ((fn3170 (syntax->datum filename3169))) ((lambda (tmp3171) ((lambda (tmp3172) (if tmp3172 (apply (lambda (exp3173) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp3173)) tmp3172) (syntax-violation #f "source expression failed to match any pattern" tmp3171))) ($sc-dispatch tmp3171 (quote each-any)))) (read-file3160 fn3170 k3168)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any any))))) x3159))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x3175) ((lambda (tmp3176) ((lambda (tmp3177) (if tmp3177 (apply (lambda (_3178 e3179) (syntax-violation (quote unquote) (quote "expression not valid outside of quasiquote") x3175)) tmp3177) (syntax-violation #f "source expression failed to match any pattern" tmp3176))) ($sc-dispatch tmp3176 (quote (any any))))) x3175)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 e3184) (syntax-violation (quote unquote-splicing) (quote "expression not valid outside of quasiquote") x3180)) tmp3182) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any))))) x3180)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3185) ((lambda (tmp3186) ((lambda (tmp3187) (if tmp3187 (apply (lambda (_3188 e3189 m13190 m23191) ((lambda (tmp3192) ((lambda (body3193) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3189)) body3193)) tmp3192)) (letrec ((f3194 (lambda (clause3195 clauses3196) (if (null? clauses3196) ((lambda (tmp3198) ((lambda (tmp3199) (if tmp3199 (apply (lambda (e13200 e23201) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13200 e23201))) tmp3199) ((lambda (tmp3203) (if tmp3203 (apply (lambda (k3204 e13205 e23206) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3204)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13205 e23206)))) tmp3203) ((lambda (_3209) (syntax-violation (quote case) (quote "bad clause") x3185 clause3195)) tmp3198))) ($sc-dispatch tmp3198 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3198 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause3195) ((lambda (tmp3210) ((lambda (rest3211) ((lambda (tmp3212) ((lambda (tmp3213) (if tmp3213 (apply (lambda (k3214 e13215 e23216) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3214)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13215 e23216)) rest3211)) tmp3213) ((lambda (_3219) (syntax-violation (quote case) (quote "bad clause") x3185 clause3195)) tmp3212))) ($sc-dispatch tmp3212 (quote (each-any any . each-any))))) clause3195)) tmp3210)) (f3194 (car clauses3196) (cdr clauses3196))))))) (f3194 m13190 m23191)))) tmp3187) (syntax-violation #f "source expression failed to match any pattern" tmp3186))) ($sc-dispatch tmp3186 (quote (any any any . each-any))))) x3185)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3220) ((lambda (tmp3221) ((lambda (tmp3222) (if tmp3222 (apply (lambda (_3223 e3224) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3224)) (list (cons _3223 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e3224 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp3222) (syntax-violation #f "source expression failed to match any pattern" tmp3221))) ($sc-dispatch tmp3221 (quote (any any))))) x3220)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (letrec ((andmap58 (lambda (first59) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))))) (andmap58 first56)) (letrec ((andmap62 (lambda (first63 rest64) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68))))))) (andmap62 first56 rest55))))))) (letrec ((lambda-var-list160 (lambda (vars289) (letrec ((lvl290 (lambda (vars291 ls292 w293) (cond ((pair? vars291) (lvl290 (cdr vars291) (cons (wrap139 (car vars291) w293 #f) ls292) w293)) ((id?111 vars291) (cons (wrap139 vars291 w293 #f) ls292)) ((null? vars291) ls292) ((syntax-object?95 vars291) (lvl290 (syntax-object-expression96 vars291) ls292 (join-wraps130 w293 (syntax-object-wrap97 vars291)))) ((annotation? vars291) (lvl290 (annotation-expression vars291) ls292 w293)) (else (cons vars291 ls292)))))) (lvl290 vars289 (quote ()) (quote (())))))) (gen-var159 (lambda (id294) (let ((id295 (if (syntax-object?95 id294) (syntax-object-expression96 id294) id294))) (if (annotation? id295) (gensym (symbol->string (annotation-expression id295))) (gensym (symbol->string id295)))))) (strip158 (lambda (x296 w297) (if (memq (quote top) (wrap-marks114 w297)) (if (or (annotation? x296) (and (pair? x296) (annotation? (car x296)))) (strip-annotation157 x296 #f) x296) (letrec ((f298 (lambda (x299) (cond ((syntax-object?95 x299) (strip158 (syntax-object-expression96 x299) (syntax-object-wrap97 x299))) ((pair? x299) (let ((a300 (f298 (car x299))) (d301 (f298 (cdr x299)))) (if (and (eq? a300 (car x299)) (eq? d301 (cdr x299))) x299 (cons a300 d301)))) ((vector? x299) (let ((old302 (vector->list x299))) (let ((new303 (map f298 old302))) (if (and-map*17 eq? old302 new303) x299 (list->vector new303))))) (else x299))))) (f298 x296))))) (strip-annotation157 (lambda (x304 parent305) (cond ((pair? x304) (let ((new306 (cons #f #f))) (begin (if parent305 (set-annotation-stripped! parent305 new306)) (set-car! new306 (strip-annotation157 (car x304) #f)) (set-cdr! new306 (strip-annotation157 (cdr x304) #f)) new306))) ((annotation? x304) (or (annotation-stripped x304) (strip-annotation157 (annotation-expression x304) x304))) ((vector? x304) (let ((new307 (make-vector (vector-length x304)))) (begin (if parent305 (set-annotation-stripped! parent305 new307)) (letrec ((loop308 (lambda (i309) (unless (fx<74 i309 0) (vector-set! new307 i309 (strip-annotation157 (vector-ref x304 i309) #f)) (loop308 (fx-72 i309 1)))))) (loop308 (- (vector-length x304) 1))) new307))) (else x304)))) (ellipsis?156 (lambda (x310) (and (nonsymbol-id?110 x310) (free-id=?134 x310 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void155 (lambda () (build-application79 #f (build-primref88 #f (quote if)) (quote (#f #f))))) (eval-local-transformer154 (lambda (expanded311 mod312) (let ((p313 (local-eval-hook76 expanded311 mod312))) (if (procedure? p313) p313 (syntax-violation #f "nonprocedure transformer" p313))))) (chi-local-syntax153 (lambda (rec?314 e315 r316 w317 s318 mod319 k320) ((lambda (tmp321) ((lambda (tmp322) (if tmp322 (apply (lambda (_323 id324 val325 e1326 e2327) (let ((ids328 id324)) (if (not (valid-bound-ids?136 ids328)) (syntax-violation #f "duplicate bound keyword" e315) (let ((labels330 (gen-labels117 ids328))) (let ((new-w331 (make-binding-wrap128 ids328 labels330 w317))) (k320 (cons e1326 e2327) (extend-env105 labels330 (let ((w333 (if rec?314 new-w331 w317)) (trans-r334 (macros-only-env107 r316))) (map (lambda (x335) (cons (quote macro) (eval-local-transformer154 (chi147 x335 trans-r334 w333 mod319) mod319))) val325)) r316) new-w331 s318 mod319)))))) tmp322) ((lambda (_337) (syntax-violation #f "bad local syntax definition" (source-wrap140 e315 w317 s318 mod319))) tmp321))) ($sc-dispatch tmp321 (quote (any #(each (any any)) any . each-any))))) e315))) (chi-lambda-clause152 (lambda (e338 docstring339 c340 r341 w342 mod343 k344) ((lambda (tmp345) ((lambda (tmp346) (if (if tmp346 (apply (lambda (args347 doc348 e1349 e2350) (and (string? (syntax->datum doc348)) (not docstring339))) tmp346) #f) (apply (lambda (args351 doc352 e1353 e2354) (chi-lambda-clause152 e338 doc352 (cons args351 (cons e1353 e2354)) r341 w342 mod343 k344)) tmp346) ((lambda (tmp356) (if tmp356 (apply (lambda (id357 e1358 e2359) (let ((ids360 id357)) (if (not (valid-bound-ids?136 ids360)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels362 (gen-labels117 ids360)) (new-vars363 (map gen-var159 ids360))) (k344 new-vars363 docstring339 (chi-body151 (cons e1358 e2359) e338 (extend-var-env106 labels362 new-vars363 r341) (make-binding-wrap128 ids360 labels362 w342) mod343)))))) tmp356) ((lambda (tmp365) (if tmp365 (apply (lambda (ids366 e1367 e2368) (let ((old-ids369 (lambda-var-list160 ids366))) (if (not (valid-bound-ids?136 old-ids369)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels370 (gen-labels117 old-ids369)) (new-vars371 (map gen-var159 old-ids369))) (k344 (letrec ((f372 (lambda (ls1373 ls2374) (if (null? ls1373) ls2374 (f372 (cdr ls1373) (cons (car ls1373) ls2374)))))) (f372 (cdr new-vars371) (car new-vars371))) docstring339 (chi-body151 (cons e1367 e2368) e338 (extend-var-env106 labels370 new-vars371 r341) (make-binding-wrap128 old-ids369 labels370 w342) mod343)))))) tmp365) ((lambda (_376) (syntax-violation (quote lambda) "bad lambda" e338)) tmp345))) ($sc-dispatch tmp345 (quote (any any . each-any)))))) ($sc-dispatch tmp345 (quote (each-any any . each-any)))))) ($sc-dispatch tmp345 (quote (any any any . each-any))))) c340))) (chi-body151 (lambda (body377 outer-form378 r379 w380 mod381) (let ((r382 (cons (quote ("placeholder" placeholder)) r379))) (let ((ribcage383 (make-ribcage118 (quote ()) (quote ()) (quote ())))) (let ((w384 (make-wrap113 (wrap-marks114 w380) (cons ribcage383 (wrap-subst115 w380))))) (letrec ((parse385 (lambda (body386 ids387 labels388 vars389 vals390 bindings391) (if (null? body386) (syntax-violation #f "no expressions in body" outer-form378) (let ((e393 (cdar body386)) (er394 (caar body386))) (call-with-values (lambda () (syntax-type145 e393 er394 (quote (())) #f ribcage383 mod381)) (lambda (type395 value396 e397 w398 s399 mod400) (let ((t401 type395)) (if (memv t401 (quote (define-form))) (let ((id402 (wrap139 value396 w398 mod400)) (label403 (gen-label116))) (let ((var404 (gen-var159 id402))) (begin (extend-ribcage!127 ribcage383 id402 label403) (parse385 (cdr body386) (cons id402 ids387) (cons label403 labels388) (cons var404 vars389) (cons (cons er394 (wrap139 e397 w398 mod400)) vals390) (cons (cons (quote lexical) var404) bindings391))))) (if (memv t401 (quote (define-syntax-form))) (let ((id405 (wrap139 value396 w398 mod400)) (label406 (gen-label116))) (begin (extend-ribcage!127 ribcage383 id405 label406) (parse385 (cdr body386) (cons id405 ids387) (cons label406 labels388) vars389 vals390 (cons (cons (quote macro) (cons er394 (wrap139 e397 w398 mod400))) bindings391)))) (if (memv t401 (quote (begin-form))) ((lambda (tmp407) ((lambda (tmp408) (if tmp408 (apply (lambda (_409 e1410) (parse385 (letrec ((f411 (lambda (forms412) (if (null? forms412) (cdr body386) (cons (cons er394 (wrap139 (car forms412) w398 mod400)) (f411 (cdr forms412))))))) (f411 e1410)) ids387 labels388 vars389 vals390 bindings391)) tmp408) (syntax-violation #f "source expression failed to match any pattern" tmp407))) ($sc-dispatch tmp407 (quote (any . each-any))))) e397) (if (memv t401 (quote (local-syntax-form))) (chi-local-syntax153 value396 e397 er394 w398 s399 mod400 (lambda (forms414 er415 w416 s417 mod418) (parse385 (letrec ((f419 (lambda (forms420) (if (null? forms420) (cdr body386) (cons (cons er415 (wrap139 (car forms420) w416 mod418)) (f419 (cdr forms420))))))) (f419 forms414)) ids387 labels388 vars389 vals390 bindings391))) (if (null? ids387) (build-sequence90 #f (map (lambda (x421) (chi147 (cdr x421) (car x421) (quote (())) mod400)) (cons (cons er394 (source-wrap140 e397 w398 s399 mod400)) (cdr body386)))) (begin (if (not (valid-bound-ids?136 ids387)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form378)) (letrec ((loop422 (lambda (bs423 er-cache424 r-cache425) (if (not (null? bs423)) (let ((b426 (car bs423))) (if (eq? (car b426) (quote macro)) (let ((er427 (cadr b426))) (let ((r-cache428 (if (eq? er427 er-cache424) r-cache425 (macros-only-env107 er427)))) (begin (set-cdr! b426 (eval-local-transformer154 (chi147 (cddr b426) r-cache428 (quote (())) mod400) mod400)) (loop422 (cdr bs423) er427 r-cache428)))) (loop422 (cdr bs423) er-cache424 r-cache425))))))) (loop422 bindings391 #f #f)) (set-cdr! r382 (extend-env105 labels388 bindings391 (cdr r382))) (build-letrec93 #f vars389 (map (lambda (x429) (chi147 (cdr x429) (car x429) (quote (())) mod400)) vals390) (build-sequence90 #f (map (lambda (x430) (chi147 (cdr x430) (car x430) (quote (())) mod400)) (cons (cons er394 (source-wrap140 e397 w398 s399 mod400)) (cdr body386))))))))))))))))))) (parse385 (map (lambda (x392) (cons r382 (wrap139 x392 w384 mod381))) body377) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro150 (lambda (p431 e432 r433 w434 rib435 mod436) (letrec ((rebuild-macro-output437 (lambda (x438 m439) (cond ((pair? x438) (cons (rebuild-macro-output437 (car x438) m439) (rebuild-macro-output437 (cdr x438) m439))) ((syntax-object?95 x438) (let ((w440 (syntax-object-wrap97 x438))) (let ((ms441 (wrap-marks114 w440)) (s442 (wrap-subst115 w440))) (if (and (pair? ms441) (eq? (car ms441) #f)) (make-syntax-object94 (syntax-object-expression96 x438) (make-wrap113 (cdr ms441) (if rib435 (cons rib435 (cdr s442)) (cdr s442))) (syntax-object-module98 x438)) (make-syntax-object94 (syntax-object-expression96 x438) (make-wrap113 (cons m439 ms441) (if rib435 (cons rib435 (cons (quote shift) s442)) (cons (quote shift) s442))) (let ((pmod443 (procedure-module p431))) (if pmod443 (cons (quote hygiene) (module-name pmod443)) (quote (hygiene guile))))))))) ((vector? x438) (let ((n444 (vector-length x438))) (let ((v445 (make-vector n444))) (letrec ((doloop446 (lambda (i447) (if (fx=73 i447 n444) v445 (begin (vector-set! v445 i447 (rebuild-macro-output437 (vector-ref x438 i447) m439)) (doloop446 (fx+71 i447 1))))))) (doloop446 0))))) ((symbol? x438) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap140 e432 w434 s mod436) x438)) (else x438))))) (rebuild-macro-output437 (p431 (wrap139 e432 (anti-mark126 w434) mod436)) (string #\m))))) (chi-application149 (lambda (x448 e449 r450 w451 s452 mod453) ((lambda (tmp454) ((lambda (tmp455) (if tmp455 (apply (lambda (e0456 e1457) (build-application79 s452 x448 (map (lambda (e458) (chi147 e458 r450 w451 mod453)) e1457))) tmp455) (syntax-violation #f "source expression failed to match any pattern" tmp454))) ($sc-dispatch tmp454 (quote (any . each-any))))) e449))) (chi-expr148 (lambda (type460 value461 e462 r463 w464 s465 mod466) (let ((t467 type460)) (if (memv t467 (quote (lexical))) (build-lexical-reference81 (quote value) s465 e462 value461) (if (memv t467 (quote (core external-macro))) (value461 e462 r463 w464 s465 mod466) (if (memv t467 (quote (module-ref))) (call-with-values (lambda () (value461 e462)) (lambda (id468 mod469) (build-global-reference84 s465 id468 mod469))) (if (memv t467 (quote (lexical-call))) (chi-application149 (build-lexical-reference81 (quote fun) (source-annotation102 (car e462)) (car e462) value461) e462 r463 w464 s465 mod466) (if (memv t467 (quote (global-call))) (chi-application149 (build-global-reference84 (source-annotation102 (car e462)) value461 (if (syntax-object?95 (car e462)) (syntax-object-module98 (car e462)) mod466)) e462 r463 w464 s465 mod466) (if (memv t467 (quote (constant))) (build-data89 s465 (strip158 (source-wrap140 e462 w464 s465 mod466) (quote (())))) (if (memv t467 (quote (global))) (build-global-reference84 s465 value461 mod466) (if (memv t467 (quote (call))) (chi-application149 (chi147 (car e462) r463 w464 mod466) e462 r463 w464 s465 mod466) (if (memv t467 (quote (begin-form))) ((lambda (tmp470) ((lambda (tmp471) (if tmp471 (apply (lambda (_472 e1473 e2474) (chi-sequence141 (cons e1473 e2474) r463 w464 s465 mod466)) tmp471) (syntax-violation #f "source expression failed to match any pattern" tmp470))) ($sc-dispatch tmp470 (quote (any any . each-any))))) e462) (if (memv t467 (quote (local-syntax-form))) (chi-local-syntax153 value461 e462 r463 w464 s465 mod466 chi-sequence141) (if (memv t467 (quote (eval-when-form))) ((lambda (tmp476) ((lambda (tmp477) (if tmp477 (apply (lambda (_478 x479 e1480 e2481) (let ((when-list482 (chi-when-list144 e462 x479 w464))) (if (memq (quote eval) when-list482) (chi-sequence141 (cons e1480 e2481) r463 w464 s465 mod466) (chi-void155)))) tmp477) (syntax-violation #f "source expression failed to match any pattern" tmp476))) ($sc-dispatch tmp476 (quote (any each-any any . each-any))))) e462) (if (memv t467 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e462 (wrap139 value461 w464 mod466)) (if (memv t467 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap140 e462 w464 s465 mod466)) (if (memv t467 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap140 e462 w464 s465 mod466)) (syntax-violation #f "unexpected syntax" (source-wrap140 e462 w464 s465 mod466))))))))))))))))))) (chi147 (lambda (e485 r486 w487 mod488) (call-with-values (lambda () (syntax-type145 e485 r486 w487 #f #f mod488)) (lambda (type489 value490 e491 w492 s493 mod494) (chi-expr148 type489 value490 e491 r486 w492 s493 mod494))))) (chi-top146 (lambda (e495 r496 w497 m498 esew499 mod500) (call-with-values (lambda () (syntax-type145 e495 r496 w497 #f #f mod500)) (lambda (type508 value509 e510 w511 s512 mod513) (let ((t514 type508)) (if (memv t514 (quote (begin-form))) ((lambda (tmp515) ((lambda (tmp516) (if tmp516 (apply (lambda (_517) (chi-void155)) tmp516) ((lambda (tmp518) (if tmp518 (apply (lambda (_519 e1520 e2521) (chi-top-sequence142 (cons e1520 e2521) r496 w511 s512 m498 esew499 mod513)) tmp518) (syntax-violation #f "source expression failed to match any pattern" tmp515))) ($sc-dispatch tmp515 (quote (any any . each-any)))))) ($sc-dispatch tmp515 (quote (any))))) e510) (if (memv t514 (quote (local-syntax-form))) (chi-local-syntax153 value509 e510 r496 w511 s512 mod513 (lambda (body523 r524 w525 s526 mod527) (chi-top-sequence142 body523 r524 w525 s526 m498 esew499 mod527))) (if (memv t514 (quote (eval-when-form))) ((lambda (tmp528) ((lambda (tmp529) (if tmp529 (apply (lambda (_530 x531 e1532 e2533) (let ((when-list534 (chi-when-list144 e510 x531 w511)) (body535 (cons e1532 e2533))) (cond ((eq? m498 (quote e)) (if (memq (quote eval) when-list534) (chi-top-sequence142 body535 r496 w511 s512 (quote e) (quote (eval)) mod513) (chi-void155))) ((memq (quote load) when-list534) (if (or (memq (quote compile) when-list534) (and (eq? m498 (quote c&e)) (memq (quote eval) when-list534))) (chi-top-sequence142 body535 r496 w511 s512 (quote c&e) (quote (compile load)) mod513) (if (memq m498 (quote (c c&e))) (chi-top-sequence142 body535 r496 w511 s512 (quote c) (quote (load)) mod513) (chi-void155)))) ((or (memq (quote compile) when-list534) (and (eq? m498 (quote c&e)) (memq (quote eval) when-list534))) (top-level-eval-hook75 (chi-top-sequence142 body535 r496 w511 s512 (quote e) (quote (eval)) mod513) mod513) (chi-void155)) (else (chi-void155))))) tmp529) (syntax-violation #f "source expression failed to match any pattern" tmp528))) ($sc-dispatch tmp528 (quote (any each-any any . each-any))))) e510) (if (memv t514 (quote (define-syntax-form))) (let ((n538 (id-var-name133 value509 w511)) (r539 (macros-only-env107 r496))) (let ((t540 m498)) (if (memv t540 (quote (c))) (if (memq (quote compile) esew499) (let ((e541 (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)))) (begin (top-level-eval-hook75 e541 mod513) (if (memq (quote load) esew499) e541 (chi-void155)))) (if (memq (quote load) esew499) (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)) (chi-void155))) (if (memv t540 (quote (c&e))) (let ((e542 (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)))) (begin (top-level-eval-hook75 e542 mod513) e542)) (begin (if (memq (quote eval) esew499) (top-level-eval-hook75 (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)) mod513)) (chi-void155)))))) (if (memv t514 (quote (define-form))) (let ((n543 (id-var-name133 value509 w511))) (let ((type544 (binding-type103 (lookup108 n543 r496 mod513)))) (let ((t545 type544)) (if (memv t545 (quote (global core macro module-ref))) (let ((x546 (build-global-definition86 s512 n543 (chi147 e510 r496 w511 mod513)))) (begin (if (eq? m498 (quote c&e)) (top-level-eval-hook75 x546 mod513)) x546)) (if (memv t545 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e510 (wrap139 value509 w511 mod513)) (syntax-violation #f "cannot define keyword at top level" e510 (wrap139 value509 w511 mod513))))))) (let ((x547 (chi-expr148 type508 value509 e510 r496 w511 s512 mod513))) (begin (if (eq? m498 (quote c&e)) (top-level-eval-hook75 x547 mod513)) x547)))))))))))) (syntax-type145 (lambda (e548 r549 w550 s551 rib552 mod553) (cond ((symbol? e548) (let ((n554 (id-var-name133 e548 w550))) (let ((b555 (lookup108 n554 r549 mod553))) (let ((type556 (binding-type103 b555))) (let ((t557 type556)) (if (memv t557 (quote (lexical))) (values type556 (binding-value104 b555) e548 w550 s551 mod553) (if (memv t557 (quote (global))) (values type556 n554 e548 w550 s551 mod553) (if (memv t557 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b555) e548 r549 w550 rib552 mod553) r549 (quote (())) s551 rib552 mod553) (values type556 (binding-value104 b555) e548 w550 s551 mod553))))))))) ((pair? e548) (let ((first558 (car e548))) (if (id?111 first558) (let ((n559 (id-var-name133 first558 w550))) (let ((b560 (lookup108 n559 r549 (or (and (syntax-object?95 first558) (syntax-object-module98 first558)) mod553)))) (let ((type561 (binding-type103 b560))) (let ((t562 type561)) (if (memv t562 (quote (lexical))) (values (quote lexical-call) (binding-value104 b560) e548 w550 s551 mod553) (if (memv t562 (quote (global))) (values (quote global-call) n559 e548 w550 s551 mod553) (if (memv t562 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b560) e548 r549 w550 rib552 mod553) r549 (quote (())) s551 rib552 mod553) (if (memv t562 (quote (core external-macro module-ref))) (values type561 (binding-value104 b560) e548 w550 s551 mod553) (if (memv t562 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value104 b560) e548 w550 s551 mod553) (if (memv t562 (quote (begin))) (values (quote begin-form) #f e548 w550 s551 mod553) (if (memv t562 (quote (eval-when))) (values (quote eval-when-form) #f e548 w550 s551 mod553) (if (memv t562 (quote (define))) ((lambda (tmp563) ((lambda (tmp564) (if (if tmp564 (apply (lambda (_565 name566 val567) (id?111 name566)) tmp564) #f) (apply (lambda (_568 name569 val570) (values (quote define-form) name569 val570 w550 s551 mod553)) tmp564) ((lambda (tmp571) (if (if tmp571 (apply (lambda (_572 name573 args574 e1575 e2576) (and (id?111 name573) (valid-bound-ids?136 (lambda-var-list160 args574)))) tmp571) #f) (apply (lambda (_577 name578 args579 e1580 e2581) (values (quote define-form) (wrap139 name578 w550 mod553) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap139 (cons args579 (cons e1580 e2581)) w550 mod553)) (quote (())) s551 mod553)) tmp571) ((lambda (tmp583) (if (if tmp583 (apply (lambda (_584 name585) (id?111 name585)) tmp583) #f) (apply (lambda (_586 name587) (values (quote define-form) (wrap139 name587 w550 mod553) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s551 mod553)) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp563))) ($sc-dispatch tmp563 (quote (any any)))))) ($sc-dispatch tmp563 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp563 (quote (any any any))))) e548) (if (memv t562 (quote (define-syntax))) ((lambda (tmp588) ((lambda (tmp589) (if (if tmp589 (apply (lambda (_590 name591 val592) (id?111 name591)) tmp589) #f) (apply (lambda (_593 name594 val595) (values (quote define-syntax-form) name594 val595 w550 s551 mod553)) tmp589) (syntax-violation #f "source expression failed to match any pattern" tmp588))) ($sc-dispatch tmp588 (quote (any any any))))) e548) (values (quote call) #f e548 w550 s551 mod553)))))))))))))) (values (quote call) #f e548 w550 s551 mod553)))) ((syntax-object?95 e548) (syntax-type145 (syntax-object-expression96 e548) r549 (join-wraps130 w550 (syntax-object-wrap97 e548)) #f rib552 (or (syntax-object-module98 e548) mod553))) ((annotation? e548) (syntax-type145 (annotation-expression e548) r549 w550 (annotation-source e548) rib552 mod553)) ((self-evaluating? e548) (values (quote constant) #f e548 w550 s551 mod553)) (else (values (quote other) #f e548 w550 s551 mod553))))) (chi-when-list144 (lambda (e596 when-list597 w598) (letrec ((f599 (lambda (when-list600 situations601) (if (null? when-list600) situations601 (f599 (cdr when-list600) (cons (let ((x602 (car when-list600))) (cond ((free-id=?134 x602 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?134 x602 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?134 x602 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e596 (wrap139 x602 w598 #f))))) situations601)))))) (f599 when-list597 (quote ()))))) (chi-install-global143 (lambda (name603 e604) (build-global-definition86 #f name603 (if (let ((v605 (module-variable (current-module) name603))) (and v605 (variable-bound? v605) (macro? (variable-ref v605)) (not (eq? (macro-type (variable-ref v605)) (quote syncase-macro))))) (build-application79 #f (build-primref88 #f (quote make-extended-syncase-macro)) (list (build-application79 #f (build-primref88 #f (quote module-ref)) (list (build-application79 #f (quote current-module) (quote ())) (build-data89 #f name603))) (build-data89 #f (quote macro)) e604)) (build-application79 #f (build-primref88 #f (quote make-syncase-macro)) (list (build-data89 #f (quote macro)) e604)))))) (chi-top-sequence142 (lambda (body606 r607 w608 s609 m610 esew611 mod612) (build-sequence90 s609 (letrec ((dobody613 (lambda (body614 r615 w616 m617 esew618 mod619) (if (null? body614) (quote ()) (let ((first620 (chi-top146 (car body614) r615 w616 m617 esew618 mod619))) (cons first620 (dobody613 (cdr body614) r615 w616 m617 esew618 mod619))))))) (dobody613 body606 r607 w608 m610 esew611 mod612))))) (chi-sequence141 (lambda (body621 r622 w623 s624 mod625) (build-sequence90 s624 (letrec ((dobody626 (lambda (body627 r628 w629 mod630) (if (null? body627) (quote ()) (let ((first631 (chi147 (car body627) r628 w629 mod630))) (cons first631 (dobody626 (cdr body627) r628 w629 mod630))))))) (dobody626 body621 r622 w623 mod625))))) (source-wrap140 (lambda (x632 w633 s634 defmod635) (wrap139 (if s634 (make-annotation x632 s634 #f) x632) w633 defmod635))) (wrap139 (lambda (x636 w637 defmod638) (cond ((and (null? (wrap-marks114 w637)) (null? (wrap-subst115 w637))) x636) ((syntax-object?95 x636) (make-syntax-object94 (syntax-object-expression96 x636) (join-wraps130 w637 (syntax-object-wrap97 x636)) (syntax-object-module98 x636))) ((null? x636) x636) (else (make-syntax-object94 x636 w637 defmod638))))) (bound-id-member?138 (lambda (x639 list640) (and (not (null? list640)) (or (bound-id=?135 x639 (car list640)) (bound-id-member?138 x639 (cdr list640)))))) (distinct-bound-ids?137 (lambda (ids641) (letrec ((distinct?642 (lambda (ids643) (or (null? ids643) (and (not (bound-id-member?138 (car ids643) (cdr ids643))) (distinct?642 (cdr ids643))))))) (distinct?642 ids641)))) (valid-bound-ids?136 (lambda (ids644) (and (letrec ((all-ids?645 (lambda (ids646) (or (null? ids646) (and (id?111 (car ids646)) (all-ids?645 (cdr ids646))))))) (all-ids?645 ids644)) (distinct-bound-ids?137 ids644)))) (bound-id=?135 (lambda (i647 j648) (if (and (syntax-object?95 i647) (syntax-object?95 j648)) (and (eq? (let ((e649 (syntax-object-expression96 i647))) (if (annotation? e649) (annotation-expression e649) e649)) (let ((e650 (syntax-object-expression96 j648))) (if (annotation? e650) (annotation-expression e650) e650))) (same-marks?132 (wrap-marks114 (syntax-object-wrap97 i647)) (wrap-marks114 (syntax-object-wrap97 j648)))) (eq? (let ((e651 i647)) (if (annotation? e651) (annotation-expression e651) e651)) (let ((e652 j648)) (if (annotation? e652) (annotation-expression e652) e652)))))) (free-id=?134 (lambda (i653 j654) (and (eq? (let ((x655 i653)) (let ((e656 (if (syntax-object?95 x655) (syntax-object-expression96 x655) x655))) (if (annotation? e656) (annotation-expression e656) e656))) (let ((x657 j654)) (let ((e658 (if (syntax-object?95 x657) (syntax-object-expression96 x657) x657))) (if (annotation? e658) (annotation-expression e658) e658)))) (eq? (id-var-name133 i653 (quote (()))) (id-var-name133 j654 (quote (()))))))) (id-var-name133 (lambda (id659 w660) (letrec ((search-vector-rib663 (lambda (sym669 subst670 marks671 symnames672 ribcage673) (let ((n674 (vector-length symnames672))) (letrec ((f675 (lambda (i676) (cond ((fx=73 i676 n674) (search661 sym669 (cdr subst670) marks671)) ((and (eq? (vector-ref symnames672 i676) sym669) (same-marks?132 marks671 (vector-ref (ribcage-marks121 ribcage673) i676))) (values (vector-ref (ribcage-labels122 ribcage673) i676) marks671)) (else (f675 (fx+71 i676 1))))))) (f675 0))))) (search-list-rib662 (lambda (sym677 subst678 marks679 symnames680 ribcage681) (letrec ((f682 (lambda (symnames683 i684) (cond ((null? symnames683) (search661 sym677 (cdr subst678) marks679)) ((and (eq? (car symnames683) sym677) (same-marks?132 marks679 (list-ref (ribcage-marks121 ribcage681) i684))) (values (list-ref (ribcage-labels122 ribcage681) i684) marks679)) (else (f682 (cdr symnames683) (fx+71 i684 1))))))) (f682 symnames680 0)))) (search661 (lambda (sym685 subst686 marks687) (if (null? subst686) (values #f marks687) (let ((fst688 (car subst686))) (if (eq? fst688 (quote shift)) (search661 sym685 (cdr subst686) (cdr marks687)) (let ((symnames689 (ribcage-symnames120 fst688))) (if (vector? symnames689) (search-vector-rib663 sym685 subst686 marks687 symnames689 fst688) (search-list-rib662 sym685 subst686 marks687 symnames689 fst688))))))))) (cond ((symbol? id659) (or (call-with-values (lambda () (search661 id659 (wrap-subst115 w660) (wrap-marks114 w660))) (lambda (x691 . ignore690) x691)) id659)) ((syntax-object?95 id659) (let ((id692 (let ((e694 (syntax-object-expression96 id659))) (if (annotation? e694) (annotation-expression e694) e694))) (w1693 (syntax-object-wrap97 id659))) (let ((marks695 (join-marks131 (wrap-marks114 w660) (wrap-marks114 w1693)))) (call-with-values (lambda () (search661 id692 (wrap-subst115 w660) marks695)) (lambda (new-id696 marks697) (or new-id696 (call-with-values (lambda () (search661 id692 (wrap-subst115 w1693) marks697)) (lambda (x699 . ignore698) x699)) id692)))))) ((annotation? id659) (let ((id700 (let ((e701 id659)) (if (annotation? e701) (annotation-expression e701) e701)))) (or (call-with-values (lambda () (search661 id700 (wrap-subst115 w660) (wrap-marks114 w660))) (lambda (x703 . ignore702) x703)) id700))) (else (syntax-violation (quote id-var-name) "invalid id" id659)))))) (same-marks?132 (lambda (x704 y705) (or (eq? x704 y705) (and (not (null? x704)) (not (null? y705)) (eq? (car x704) (car y705)) (same-marks?132 (cdr x704) (cdr y705)))))) (join-marks131 (lambda (m1706 m2707) (smart-append129 m1706 m2707))) (join-wraps130 (lambda (w1708 w2709) (let ((m1710 (wrap-marks114 w1708)) (s1711 (wrap-subst115 w1708))) (if (null? m1710) (if (null? s1711) w2709 (make-wrap113 (wrap-marks114 w2709) (smart-append129 s1711 (wrap-subst115 w2709)))) (make-wrap113 (smart-append129 m1710 (wrap-marks114 w2709)) (smart-append129 s1711 (wrap-subst115 w2709))))))) (smart-append129 (lambda (m1712 m2713) (if (null? m2713) m1712 (append m1712 m2713)))) (make-binding-wrap128 (lambda (ids714 labels715 w716) (if (null? ids714) w716 (make-wrap113 (wrap-marks114 w716) (cons (let ((labelvec717 (list->vector labels715))) (let ((n718 (vector-length labelvec717))) (let ((symnamevec719 (make-vector n718)) (marksvec720 (make-vector n718))) (begin (letrec ((f721 (lambda (ids722 i723) (if (not (null? ids722)) (call-with-values (lambda () (id-sym-name&marks112 (car ids722) w716)) (lambda (symname724 marks725) (begin (vector-set! symnamevec719 i723 symname724) (vector-set! marksvec720 i723 marks725) (f721 (cdr ids722) (fx+71 i723 1))))))))) (f721 ids714 0)) (make-ribcage118 symnamevec719 marksvec720 labelvec717))))) (wrap-subst115 w716)))))) (extend-ribcage!127 (lambda (ribcage726 id727 label728) (begin (set-ribcage-symnames!123 ribcage726 (cons (let ((e729 (syntax-object-expression96 id727))) (if (annotation? e729) (annotation-expression e729) e729)) (ribcage-symnames120 ribcage726))) (set-ribcage-marks!124 ribcage726 (cons (wrap-marks114 (syntax-object-wrap97 id727)) (ribcage-marks121 ribcage726))) (set-ribcage-labels!125 ribcage726 (cons label728 (ribcage-labels122 ribcage726)))))) (anti-mark126 (lambda (w730) (make-wrap113 (cons #f (wrap-marks114 w730)) (cons (quote shift) (wrap-subst115 w730))))) (set-ribcage-labels!125 (lambda (x731 update732) (vector-set! x731 3 update732))) (set-ribcage-marks!124 (lambda (x733 update734) (vector-set! x733 2 update734))) (set-ribcage-symnames!123 (lambda (x735 update736) (vector-set! x735 1 update736))) (ribcage-labels122 (lambda (x737) (vector-ref x737 3))) (ribcage-marks121 (lambda (x738) (vector-ref x738 2))) (ribcage-symnames120 (lambda (x739) (vector-ref x739 1))) (ribcage?119 (lambda (x740) (and (vector? x740) (= (vector-length x740) 4) (eq? (vector-ref x740 0) (quote ribcage))))) (make-ribcage118 (lambda (symnames741 marks742 labels743) (vector (quote ribcage) symnames741 marks742 labels743))) (gen-labels117 (lambda (ls744) (if (null? ls744) (quote ()) (cons (gen-label116) (gen-labels117 (cdr ls744)))))) (gen-label116 (lambda () (string #\i))) (wrap-subst115 cdr) (wrap-marks114 car) (make-wrap113 cons) (id-sym-name&marks112 (lambda (x745 w746) (if (syntax-object?95 x745) (values (let ((e747 (syntax-object-expression96 x745))) (if (annotation? e747) (annotation-expression e747) e747)) (join-marks131 (wrap-marks114 w746) (wrap-marks114 (syntax-object-wrap97 x745)))) (values (let ((e748 x745)) (if (annotation? e748) (annotation-expression e748) e748)) (wrap-marks114 w746))))) (id?111 (lambda (x749) (cond ((symbol? x749) #t) ((syntax-object?95 x749) (symbol? (let ((e750 (syntax-object-expression96 x749))) (if (annotation? e750) (annotation-expression e750) e750)))) ((annotation? x749) (symbol? (annotation-expression x749))) (else #f)))) (nonsymbol-id?110 (lambda (x751) (and (syntax-object?95 x751) (symbol? (let ((e752 (syntax-object-expression96 x751))) (if (annotation? e752) (annotation-expression e752) e752)))))) (global-extend109 (lambda (type753 sym754 val755) (put-global-definition-hook77 sym754 type753 val755))) (lookup108 (lambda (x756 r757 mod758) (cond ((assq x756 r757) => cdr) ((symbol? x756) (or (get-global-definition-hook78 x756 mod758) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env107 (lambda (r759) (if (null? r759) (quote ()) (let ((a760 (car r759))) (if (eq? (cadr a760) (quote macro)) (cons a760 (macros-only-env107 (cdr r759))) (macros-only-env107 (cdr r759))))))) (extend-var-env106 (lambda (labels761 vars762 r763) (if (null? labels761) r763 (extend-var-env106 (cdr labels761) (cdr vars762) (cons (cons (car labels761) (cons (quote lexical) (car vars762))) r763))))) (extend-env105 (lambda (labels764 bindings765 r766) (if (null? labels764) r766 (extend-env105 (cdr labels764) (cdr bindings765) (cons (cons (car labels764) (car bindings765)) r766))))) (binding-value104 cdr) (binding-type103 car) (source-annotation102 (lambda (x767) (cond ((annotation? x767) (annotation-source x767)) ((syntax-object?95 x767) (source-annotation102 (syntax-object-expression96 x767))) (else #f)))) (set-syntax-object-module!101 (lambda (x768 update769) (vector-set! x768 3 update769))) (set-syntax-object-wrap!100 (lambda (x770 update771) (vector-set! x770 2 update771))) (set-syntax-object-expression!99 (lambda (x772 update773) (vector-set! x772 1 update773))) (syntax-object-module98 (lambda (x774) (vector-ref x774 3))) (syntax-object-wrap97 (lambda (x775) (vector-ref x775 2))) (syntax-object-expression96 (lambda (x776) (vector-ref x776 1))) (syntax-object?95 (lambda (x777) (and (vector? x777) (= (vector-length x777) 4) (eq? (vector-ref x777 0) (quote syntax-object))))) (make-syntax-object94 (lambda (expression778 wrap779 module780) (vector (quote syntax-object) expression778 wrap779 module780))) (build-letrec93 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (let ((t785 (fluid-ref *mode*70))) (if (memv t785 (quote (c))) ((@ (language tree-il) make-letrec) src781 vars782 val-exps783 body-exp784) (list (quote letrec) (map list vars782 val-exps783) body-exp784)))))) (build-named-let92 (lambda (src786 vars787 val-exps788 body-exp789) (let ((f790 (car vars787)) (vars791 (cdr vars787))) (let ((t792 (fluid-ref *mode*70))) (if (memv t792 (quote (c))) ((@ (language tree-il) make-letrec) src786 (list f790) (list (build-lambda87 src786 vars791 #f body-exp789)) (build-application79 src786 (build-lexical-reference81 (quote fun) src786 f790 f790) val-exps788)) (list (quote let) f790 (map list vars791 val-exps788) body-exp789)))))) (build-let91 (lambda (src793 vars794 val-exps795 body-exp796) (if (null? vars794) body-exp796 (let ((t797 (fluid-ref *mode*70))) (if (memv t797 (quote (c))) ((@ (language tree-il) make-let) src793 vars794 val-exps795 body-exp796) (list (quote let) (map list vars794 val-exps795) body-exp796)))))) (build-sequence90 (lambda (src798 exps799) (if (null? (cdr exps799)) (car exps799) (let ((t800 (fluid-ref *mode*70))) (if (memv t800 (quote (c))) ((@ (language tree-il) make-sequence) src798 exps799) (cons (quote begin) exps799)))))) (build-data89 (lambda (src801 exp802) (let ((t803 (fluid-ref *mode*70))) (if (memv t803 (quote (c))) ((@ (language tree-il) make-const) src801 exp802) (if (and (self-evaluating? exp802) (not (vector? exp802))) exp802 (list (quote quote) exp802)))))) (build-primref88 (lambda (src804 name805) (let ((t806 (fluid-ref *mode*70))) (if (memv t806 (quote (c))) ((@ (language tree-il) make-primitive-ref) src804 name805) (build-global-reference84 src804 name805 (quote (hygiene guile))))))) (build-lambda87 (lambda (src807 vars808 docstring809 exp810) (let ((t811 (fluid-ref *mode*70))) (if (memv t811 (quote (c))) ((@ (language tree-il) make-lambda) src807 vars808 (if docstring809 (list (cons (quote documentation) docstring809)) (quote ())) exp810) (cons (quote lambda) (cons vars808 (append (if docstring809 (list docstring809) (quote ())) (list exp810)))))))) (build-global-definition86 (lambda (source812 var813 exp814) (let ((t815 (fluid-ref *mode*70))) (if (memv t815 (quote (c))) ((@ (language tree-il) make-toplevel-define) source812 var813 exp814) (list (quote define) var813 exp814))))) (build-global-assignment85 (lambda (source816 var817 exp818 mod819) (analyze-variable83 mod819 var817 (lambda (mod820 var821 public?822) (let ((t823 (fluid-ref *mode*70))) (if (memv t823 (quote (c))) ((@ (language tree-il) make-module-set) source816 mod820 var821 public?822 exp818) (list (quote set!) (list (if public?822 (quote @) (quote @@)) mod820 var821) exp818)))) (lambda (var824) (let ((t825 (fluid-ref *mode*70))) (if (memv t825 (quote (c))) ((@ (language tree-il) make-toplevel-set) source816 var824 exp818) (list (quote set!) var824 exp818))))))) (build-global-reference84 (lambda (source826 var827 mod828) (analyze-variable83 mod828 var827 (lambda (mod829 var830 public?831) (let ((t832 (fluid-ref *mode*70))) (if (memv t832 (quote (c))) ((@ (language tree-il) make-module-ref) source826 mod829 var830 public?831) (list (if public?831 (quote @) (quote @@)) mod829 var830)))) (lambda (var833) (let ((t834 (fluid-ref *mode*70))) (if (memv t834 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source826 var833) var833)))))) (analyze-variable83 (lambda (mod835 var836 modref-cont837 bare-cont838) (if (not mod835) (bare-cont838 var836) (let ((kind839 (car mod835)) (mod840 (cdr mod835))) (let ((t841 kind839)) (if (memv t841 (quote (public))) (modref-cont837 mod840 var836 #t) (if (memv t841 (quote (private))) (if (not (equal? mod840 (module-name (current-module)))) (modref-cont837 mod840 var836 #f) (bare-cont838 var836)) (if (memv t841 (quote (bare))) (bare-cont838 var836) (if (memv t841 (quote (hygiene))) (if (and (not (equal? mod840 (module-name (current-module)))) (module-variable (resolve-module mod840) var836)) (modref-cont837 mod840 var836 #f) (bare-cont838 var836)) (syntax-violation #f "bad module kind" var836 mod840)))))))))) (build-lexical-assignment82 (lambda (source842 name843 var844 exp845) (let ((t846 (fluid-ref *mode*70))) (if (memv t846 (quote (c))) ((@ (language tree-il) make-lexical-set) source842 name843 var844 exp845) (list (quote set!) var844 exp845))))) (build-lexical-reference81 (lambda (type847 source848 name849 var850) (let ((t851 (fluid-ref *mode*70))) (if (memv t851 (quote (c))) ((@ (language tree-il) make-lexical-ref) source848 name849 var850) var850)))) (build-conditional80 (lambda (source852 test-exp853 then-exp854 else-exp855) (let ((t856 (fluid-ref *mode*70))) (if (memv t856 (quote (c))) ((@ (language tree-il) make-conditional) source852 test-exp853 then-exp854 else-exp855) (list (quote if) test-exp853 then-exp854 else-exp855))))) (build-application79 (lambda (source857 fun-exp858 arg-exps859) (let ((t860 (fluid-ref *mode*70))) (if (memv t860 (quote (c))) ((@ (language tree-il) make-application) source857 fun-exp858 arg-exps859) (cons fun-exp858 arg-exps859))))) (get-global-definition-hook78 (lambda (symbol861 module862) (begin (if (and (not module862) (current-module)) (warn "module system is booted, we should have a module" symbol861)) (let ((v863 (module-variable (if module862 (resolve-module (cdr module862)) (current-module)) symbol861))) (and v863 (variable-bound? v863) (let ((val864 (variable-ref v863))) (and (macro? val864) (syncase-macro-type val864) (cons (syncase-macro-type val864) (syncase-macro-binding val864))))))))) (put-global-definition-hook77 (lambda (symbol865 type866 val867) (let ((existing868 (let ((v869 (module-variable (current-module) symbol865))) (and v869 (variable-bound? v869) (let ((val870 (variable-ref v869))) (and (macro? val870) (not (syncase-macro-type val870)) val870)))))) (module-define! (current-module) symbol865 (if existing868 (make-extended-syncase-macro existing868 type866 val867) (make-syncase-macro type866 val867)))))) (local-eval-hook76 (lambda (x871 mod872) (primitive-eval (list noexpand69 (let ((t873 (fluid-ref *mode*70))) (if (memv t873 (quote (c))) ((@ (language tree-il) tree-il->scheme) x871) x871)))))) (top-level-eval-hook75 (lambda (x874 mod875) (primitive-eval (list noexpand69 (let ((t876 (fluid-ref *mode*70))) (if (memv t876 (quote (c))) ((@ (language tree-il) tree-il->scheme) x874) x874)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend109 (quote local-syntax) (quote letrec-syntax) #t) (global-extend109 (quote local-syntax) (quote let-syntax) #f) (global-extend109 (quote core) (quote fluid-let-syntax) (lambda (e877 r878 w879 s880 mod881) ((lambda (tmp882) ((lambda (tmp883) (if (if tmp883 (apply (lambda (_884 var885 val886 e1887 e2888) (valid-bound-ids?136 var885)) tmp883) #f) (apply (lambda (_890 var891 val892 e1893 e2894) (let ((names895 (map (lambda (x896) (id-var-name133 x896 w879)) var891))) (begin (for-each (lambda (id898 n899) (let ((t900 (binding-type103 (lookup108 n899 r878 mod881)))) (if (memv t900 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e877 (source-wrap140 id898 w879 s880 mod881))))) var891 names895) (chi-body151 (cons e1893 e2894) (source-wrap140 e877 w879 s880 mod881) (extend-env105 names895 (let ((trans-r903 (macros-only-env107 r878))) (map (lambda (x904) (cons (quote macro) (eval-local-transformer154 (chi147 x904 trans-r903 w879 mod881) mod881))) val892)) r878) w879 mod881)))) tmp883) ((lambda (_906) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap140 e877 w879 s880 mod881))) tmp882))) ($sc-dispatch tmp882 (quote (any #(each (any any)) any . each-any))))) e877))) (global-extend109 (quote core) (quote quote) (lambda (e907 r908 w909 s910 mod911) ((lambda (tmp912) ((lambda (tmp913) (if tmp913 (apply (lambda (_914 e915) (build-data89 s910 (strip158 e915 w909))) tmp913) ((lambda (_916) (syntax-violation (quote quote) "bad syntax" (source-wrap140 e907 w909 s910 mod911))) tmp912))) ($sc-dispatch tmp912 (quote (any any))))) e907))) (global-extend109 (quote core) (quote syntax) (letrec ((regen924 (lambda (x925) (let ((t926 (car x925))) (if (memv t926 (quote (ref))) (build-lexical-reference81 (quote value) #f (cadr x925) (cadr x925)) (if (memv t926 (quote (primitive))) (build-primref88 #f (cadr x925)) (if (memv t926 (quote (quote))) (build-data89 #f (cadr x925)) (if (memv t926 (quote (lambda))) (build-lambda87 #f (cadr x925) #f (regen924 (caddr x925))) (if (memv t926 (quote (map))) (let ((ls927 (map regen924 (cdr x925)))) (build-application79 #f (build-primref88 #f (quote map)) ls927)) (build-application79 #f (build-primref88 #f (car x925)) (map regen924 (cdr x925))))))))))) (gen-vector923 (lambda (x928) (cond ((eq? (car x928) (quote list)) (cons (quote vector) (cdr x928))) ((eq? (car x928) (quote quote)) (list (quote quote) (list->vector (cadr x928)))) (else (list (quote list->vector) x928))))) (gen-append922 (lambda (x929 y930) (if (equal? y930 (quote (quote ()))) x929 (list (quote append) x929 y930)))) (gen-cons921 (lambda (x931 y932) (let ((t933 (car y932))) (if (memv t933 (quote (quote))) (if (eq? (car x931) (quote quote)) (list (quote quote) (cons (cadr x931) (cadr y932))) (if (eq? (cadr y932) (quote ())) (list (quote list) x931) (list (quote cons) x931 y932))) (if (memv t933 (quote (list))) (cons (quote list) (cons x931 (cdr y932))) (list (quote cons) x931 y932)))))) (gen-map920 (lambda (e934 map-env935) (let ((formals936 (map cdr map-env935)) (actuals937 (map (lambda (x938) (list (quote ref) (car x938))) map-env935))) (cond ((eq? (car e934) (quote ref)) (car actuals937)) ((and-map (lambda (x939) (and (eq? (car x939) (quote ref)) (memq (cadr x939) formals936))) (cdr e934)) (cons (quote map) (cons (list (quote primitive) (car e934)) (map (let ((r940 (map cons formals936 actuals937))) (lambda (x941) (cdr (assq (cadr x941) r940)))) (cdr e934))))) (else (cons (quote map) (cons (list (quote lambda) formals936 e934) actuals937))))))) (gen-mappend919 (lambda (e942 map-env943) (list (quote apply) (quote (primitive append)) (gen-map920 e942 map-env943)))) (gen-ref918 (lambda (src944 var945 level946 maps947) (if (fx=73 level946 0) (values var945 maps947) (if (null? maps947) (syntax-violation (quote syntax) "missing ellipsis" src944) (call-with-values (lambda () (gen-ref918 src944 var945 (fx-72 level946 1) (cdr maps947))) (lambda (outer-var948 outer-maps949) (let ((b950 (assq outer-var948 (car maps947)))) (if b950 (values (cdr b950) maps947) (let ((inner-var951 (gen-var159 (quote tmp)))) (values inner-var951 (cons (cons (cons outer-var948 inner-var951) (car maps947)) outer-maps949))))))))))) (gen-syntax917 (lambda (src952 e953 r954 maps955 ellipsis?956 mod957) (if (id?111 e953) (let ((label958 (id-var-name133 e953 (quote (()))))) (let ((b959 (lookup108 label958 r954 mod957))) (if (eq? (binding-type103 b959) (quote syntax)) (call-with-values (lambda () (let ((var.lev960 (binding-value104 b959))) (gen-ref918 src952 (car var.lev960) (cdr var.lev960) maps955))) (lambda (var961 maps962) (values (list (quote ref) var961) maps962))) (if (ellipsis?956 e953) (syntax-violation (quote syntax) "misplaced ellipsis" src952) (values (list (quote quote) e953) maps955))))) ((lambda (tmp963) ((lambda (tmp964) (if (if tmp964 (apply (lambda (dots965 e966) (ellipsis?956 dots965)) tmp964) #f) (apply (lambda (dots967 e968) (gen-syntax917 src952 e968 r954 maps955 (lambda (x969) #f) mod957)) tmp964) ((lambda (tmp970) (if (if tmp970 (apply (lambda (x971 dots972 y973) (ellipsis?956 dots972)) tmp970) #f) (apply (lambda (x974 dots975 y976) (letrec ((f977 (lambda (y978 k979) ((lambda (tmp983) ((lambda (tmp984) (if (if tmp984 (apply (lambda (dots985 y986) (ellipsis?956 dots985)) tmp984) #f) (apply (lambda (dots987 y988) (f977 y988 (lambda (maps989) (call-with-values (lambda () (k979 (cons (quote ()) maps989))) (lambda (x990 maps991) (if (null? (car maps991)) (syntax-violation (quote syntax) "extra ellipsis" src952) (values (gen-mappend919 x990 (car maps991)) (cdr maps991)))))))) tmp984) ((lambda (_992) (call-with-values (lambda () (gen-syntax917 src952 y978 r954 maps955 ellipsis?956 mod957)) (lambda (y993 maps994) (call-with-values (lambda () (k979 maps994)) (lambda (x995 maps996) (values (gen-append922 x995 y993) maps996)))))) tmp983))) ($sc-dispatch tmp983 (quote (any . any))))) y978)))) (f977 y976 (lambda (maps980) (call-with-values (lambda () (gen-syntax917 src952 x974 r954 (cons (quote ()) maps980) ellipsis?956 mod957)) (lambda (x981 maps982) (if (null? (car maps982)) (syntax-violation (quote syntax) "extra ellipsis" src952) (values (gen-map920 x981 (car maps982)) (cdr maps982))))))))) tmp970) ((lambda (tmp997) (if tmp997 (apply (lambda (x998 y999) (call-with-values (lambda () (gen-syntax917 src952 x998 r954 maps955 ellipsis?956 mod957)) (lambda (x1000 maps1001) (call-with-values (lambda () (gen-syntax917 src952 y999 r954 maps1001 ellipsis?956 mod957)) (lambda (y1002 maps1003) (values (gen-cons921 x1000 y1002) maps1003)))))) tmp997) ((lambda (tmp1004) (if tmp1004 (apply (lambda (e11005 e21006) (call-with-values (lambda () (gen-syntax917 src952 (cons e11005 e21006) r954 maps955 ellipsis?956 mod957)) (lambda (e1008 maps1009) (values (gen-vector923 e1008) maps1009)))) tmp1004) ((lambda (_1010) (values (list (quote quote) e953) maps955)) tmp963))) ($sc-dispatch tmp963 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp963 (quote (any . any)))))) ($sc-dispatch tmp963 (quote (any any . any)))))) ($sc-dispatch tmp963 (quote (any any))))) e953))))) (lambda (e1011 r1012 w1013 s1014 mod1015) (let ((e1016 (source-wrap140 e1011 w1013 s1014 mod1015))) ((lambda (tmp1017) ((lambda (tmp1018) (if tmp1018 (apply (lambda (_1019 x1020) (call-with-values (lambda () (gen-syntax917 e1016 x1020 r1012 (quote ()) ellipsis?156 mod1015)) (lambda (e1021 maps1022) (regen924 e1021)))) tmp1018) ((lambda (_1023) (syntax-violation (quote syntax) "bad `syntax' form" e1016)) tmp1017))) ($sc-dispatch tmp1017 (quote (any any))))) e1016))))) (global-extend109 (quote core) (quote lambda) (lambda (e1024 r1025 w1026 s1027 mod1028) ((lambda (tmp1029) ((lambda (tmp1030) (if tmp1030 (apply (lambda (_1031 c1032) (chi-lambda-clause152 (source-wrap140 e1024 w1026 s1027 mod1028) #f c1032 r1025 w1026 mod1028 (lambda (vars1033 docstring1034 body1035) (build-lambda87 s1027 vars1033 docstring1034 body1035)))) tmp1030) (syntax-violation #f "source expression failed to match any pattern" tmp1029))) ($sc-dispatch tmp1029 (quote (any . any))))) e1024))) (global-extend109 (quote core) (quote let) (letrec ((chi-let1036 (lambda (e1037 r1038 w1039 s1040 mod1041 constructor1042 ids1043 vals1044 exps1045) (if (not (valid-bound-ids?136 ids1043)) (syntax-violation (quote let) "duplicate bound variable" e1037) (let ((labels1046 (gen-labels117 ids1043)) (new-vars1047 (map gen-var159 ids1043))) (let ((nw1048 (make-binding-wrap128 ids1043 labels1046 w1039)) (nr1049 (extend-var-env106 labels1046 new-vars1047 r1038))) (constructor1042 s1040 new-vars1047 (map (lambda (x1050) (chi147 x1050 r1038 w1039 mod1041)) vals1044) (chi-body151 exps1045 (source-wrap140 e1037 nw1048 s1040 mod1041) nr1049 nw1048 mod1041)))))))) (lambda (e1051 r1052 w1053 s1054 mod1055) ((lambda (tmp1056) ((lambda (tmp1057) (if tmp1057 (apply (lambda (_1058 id1059 val1060 e11061 e21062) (chi-let1036 e1051 r1052 w1053 s1054 mod1055 build-let91 id1059 val1060 (cons e11061 e21062))) tmp1057) ((lambda (tmp1066) (if (if tmp1066 (apply (lambda (_1067 f1068 id1069 val1070 e11071 e21072) (id?111 f1068)) tmp1066) #f) (apply (lambda (_1073 f1074 id1075 val1076 e11077 e21078) (chi-let1036 e1051 r1052 w1053 s1054 mod1055 build-named-let92 (cons f1074 id1075) val1076 (cons e11077 e21078))) tmp1066) ((lambda (_1082) (syntax-violation (quote let) "bad let" (source-wrap140 e1051 w1053 s1054 mod1055))) tmp1056))) ($sc-dispatch tmp1056 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1056 (quote (any #(each (any any)) any . each-any))))) e1051)))) (global-extend109 (quote core) (quote letrec) (lambda (e1083 r1084 w1085 s1086 mod1087) ((lambda (tmp1088) ((lambda (tmp1089) (if tmp1089 (apply (lambda (_1090 id1091 val1092 e11093 e21094) (let ((ids1095 id1091)) (if (not (valid-bound-ids?136 ids1095)) (syntax-violation (quote letrec) "duplicate bound variable" e1083) (let ((labels1097 (gen-labels117 ids1095)) (new-vars1098 (map gen-var159 ids1095))) (let ((w1099 (make-binding-wrap128 ids1095 labels1097 w1085)) (r1100 (extend-var-env106 labels1097 new-vars1098 r1084))) (build-letrec93 s1086 new-vars1098 (map (lambda (x1101) (chi147 x1101 r1100 w1099 mod1087)) val1092) (chi-body151 (cons e11093 e21094) (source-wrap140 e1083 w1099 s1086 mod1087) r1100 w1099 mod1087))))))) tmp1089) ((lambda (_1104) (syntax-violation (quote letrec) "bad letrec" (source-wrap140 e1083 w1085 s1086 mod1087))) tmp1088))) ($sc-dispatch tmp1088 (quote (any #(each (any any)) any . each-any))))) e1083))) (global-extend109 (quote core) (quote set!) (lambda (e1105 r1106 w1107 s1108 mod1109) ((lambda (tmp1110) ((lambda (tmp1111) (if (if tmp1111 (apply (lambda (_1112 id1113 val1114) (id?111 id1113)) tmp1111) #f) (apply (lambda (_1115 id1116 val1117) (let ((val1118 (chi147 val1117 r1106 w1107 mod1109)) (n1119 (id-var-name133 id1116 w1107))) (let ((b1120 (lookup108 n1119 r1106 mod1109))) (let ((t1121 (binding-type103 b1120))) (if (memv t1121 (quote (lexical))) (build-lexical-assignment82 s1108 (syntax->datum id1116) (binding-value104 b1120) val1118) (if (memv t1121 (quote (global))) (build-global-assignment85 s1108 n1119 val1118 mod1109) (if (memv t1121 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap139 id1116 w1107 mod1109)) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1105 w1107 s1108 mod1109))))))))) tmp1111) ((lambda (tmp1122) (if tmp1122 (apply (lambda (_1123 head1124 tail1125 val1126) (call-with-values (lambda () (syntax-type145 head1124 r1106 (quote (())) #f #f mod1109)) (lambda (type1127 value1128 ee1129 ww1130 ss1131 modmod1132) (let ((t1133 type1127)) (if (memv t1133 (quote (module-ref))) (let ((val1134 (chi147 val1126 r1106 w1107 mod1109))) (call-with-values (lambda () (value1128 (cons head1124 tail1125))) (lambda (id1136 mod1137) (build-global-assignment85 s1108 id1136 val1134 mod1137)))) (build-application79 s1108 (chi147 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1124) r1106 w1107 mod1109) (map (lambda (e1138) (chi147 e1138 r1106 w1107 mod1109)) (append tail1125 (list val1126))))))))) tmp1122) ((lambda (_1140) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1105 w1107 s1108 mod1109))) tmp1110))) ($sc-dispatch tmp1110 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1110 (quote (any any any))))) e1105))) (global-extend109 (quote module-ref) (quote @) (lambda (e1141) ((lambda (tmp1142) ((lambda (tmp1143) (if (if tmp1143 (apply (lambda (_1144 mod1145 id1146) (and (and-map id?111 mod1145) (id?111 id1146))) tmp1143) #f) (apply (lambda (_1148 mod1149 id1150) (values (syntax->datum id1150) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1149)))) tmp1143) (syntax-violation #f "source expression failed to match any pattern" tmp1142))) ($sc-dispatch tmp1142 (quote (any each-any any))))) e1141))) (global-extend109 (quote module-ref) (quote @@) (lambda (e1152) ((lambda (tmp1153) ((lambda (tmp1154) (if (if tmp1154 (apply (lambda (_1155 mod1156 id1157) (and (and-map id?111 mod1156) (id?111 id1157))) tmp1154) #f) (apply (lambda (_1159 mod1160 id1161) (values (syntax->datum id1161) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1160)))) tmp1154) (syntax-violation #f "source expression failed to match any pattern" tmp1153))) ($sc-dispatch tmp1153 (quote (any each-any any))))) e1152))) (global-extend109 (quote begin) (quote begin) (quote ())) (global-extend109 (quote define) (quote define) (quote ())) (global-extend109 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend109 (quote eval-when) (quote eval-when) (quote ())) (global-extend109 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1166 (lambda (x1167 keys1168 clauses1169 r1170 mod1171) (if (null? clauses1169) (build-application79 #f (build-primref88 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1167)) ((lambda (tmp1172) ((lambda (tmp1173) (if tmp1173 (apply (lambda (pat1174 exp1175) (if (and (id?111 pat1174) (and-map (lambda (x1176) (not (free-id=?134 pat1174 x1176))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1168))) (let ((labels1177 (list (gen-label116))) (var1178 (gen-var159 pat1174))) (build-application79 #f (build-lambda87 #f (list var1178) #f (chi147 exp1175 (extend-env105 labels1177 (list (cons (quote syntax) (cons var1178 0))) r1170) (make-binding-wrap128 (list pat1174) labels1177 (quote (()))) mod1171)) (list x1167))) (gen-clause1165 x1167 keys1168 (cdr clauses1169) r1170 pat1174 #t exp1175 mod1171))) tmp1173) ((lambda (tmp1179) (if tmp1179 (apply (lambda (pat1180 fender1181 exp1182) (gen-clause1165 x1167 keys1168 (cdr clauses1169) r1170 pat1180 fender1181 exp1182 mod1171)) tmp1179) ((lambda (_1183) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1169))) tmp1172))) ($sc-dispatch tmp1172 (quote (any any any)))))) ($sc-dispatch tmp1172 (quote (any any))))) (car clauses1169))))) (gen-clause1165 (lambda (x1184 keys1185 clauses1186 r1187 pat1188 fender1189 exp1190 mod1191) (call-with-values (lambda () (convert-pattern1163 pat1188 keys1185)) (lambda (p1192 pvars1193) (cond ((not (distinct-bound-ids?137 (map car pvars1193))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1188)) ((not (and-map (lambda (x1194) (not (ellipsis?156 (car x1194)))) pvars1193)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1188)) (else (let ((y1195 (gen-var159 (quote tmp)))) (build-application79 #f (build-lambda87 #f (list y1195) #f (let ((y1196 (build-lexical-reference81 (quote value) #f (quote tmp) y1195))) (build-conditional80 #f ((lambda (tmp1197) ((lambda (tmp1198) (if tmp1198 (apply (lambda () y1196) tmp1198) ((lambda (_1199) (build-conditional80 #f y1196 (build-dispatch-call1164 pvars1193 fender1189 y1196 r1187 mod1191) (build-data89 #f #f))) tmp1197))) ($sc-dispatch tmp1197 (quote #(atom #t))))) fender1189) (build-dispatch-call1164 pvars1193 exp1190 y1196 r1187 mod1191) (gen-syntax-case1166 x1184 keys1185 clauses1186 r1187 mod1191)))) (list (if (eq? p1192 (quote any)) (build-application79 #f (build-primref88 #f (quote list)) (list x1184)) (build-application79 #f (build-primref88 #f (quote $sc-dispatch)) (list x1184 (build-data89 #f p1192))))))))))))) (build-dispatch-call1164 (lambda (pvars1200 exp1201 y1202 r1203 mod1204) (let ((ids1205 (map car pvars1200)) (levels1206 (map cdr pvars1200))) (let ((labels1207 (gen-labels117 ids1205)) (new-vars1208 (map gen-var159 ids1205))) (build-application79 #f (build-primref88 #f (quote apply)) (list (build-lambda87 #f new-vars1208 #f (chi147 exp1201 (extend-env105 labels1207 (map (lambda (var1209 level1210) (cons (quote syntax) (cons var1209 level1210))) new-vars1208 (map cdr pvars1200)) r1203) (make-binding-wrap128 ids1205 labels1207 (quote (()))) mod1204)) y1202)))))) (convert-pattern1163 (lambda (pattern1211 keys1212) (letrec ((cvt1213 (lambda (p1214 n1215 ids1216) (if (id?111 p1214) (if (bound-id-member?138 p1214 keys1212) (values (vector (quote free-id) p1214) ids1216) (values (quote any) (cons (cons p1214 n1215) ids1216))) ((lambda (tmp1217) ((lambda (tmp1218) (if (if tmp1218 (apply (lambda (x1219 dots1220) (ellipsis?156 dots1220)) tmp1218) #f) (apply (lambda (x1221 dots1222) (call-with-values (lambda () (cvt1213 x1221 (fx+71 n1215 1) ids1216)) (lambda (p1223 ids1224) (values (if (eq? p1223 (quote any)) (quote each-any) (vector (quote each) p1223)) ids1224)))) tmp1218) ((lambda (tmp1225) (if tmp1225 (apply (lambda (x1226 y1227) (call-with-values (lambda () (cvt1213 y1227 n1215 ids1216)) (lambda (y1228 ids1229) (call-with-values (lambda () (cvt1213 x1226 n1215 ids1229)) (lambda (x1230 ids1231) (values (cons x1230 y1228) ids1231)))))) tmp1225) ((lambda (tmp1232) (if tmp1232 (apply (lambda () (values (quote ()) ids1216)) tmp1232) ((lambda (tmp1233) (if tmp1233 (apply (lambda (x1234) (call-with-values (lambda () (cvt1213 x1234 n1215 ids1216)) (lambda (p1236 ids1237) (values (vector (quote vector) p1236) ids1237)))) tmp1233) ((lambda (x1238) (values (vector (quote atom) (strip158 p1214 (quote (())))) ids1216)) tmp1217))) ($sc-dispatch tmp1217 (quote #(vector each-any)))))) ($sc-dispatch tmp1217 (quote ()))))) ($sc-dispatch tmp1217 (quote (any . any)))))) ($sc-dispatch tmp1217 (quote (any any))))) p1214))))) (cvt1213 pattern1211 0 (quote ())))))) (lambda (e1239 r1240 w1241 s1242 mod1243) (let ((e1244 (source-wrap140 e1239 w1241 s1242 mod1243))) ((lambda (tmp1245) ((lambda (tmp1246) (if tmp1246 (apply (lambda (_1247 val1248 key1249 m1250) (if (and-map (lambda (x1251) (and (id?111 x1251) (not (ellipsis?156 x1251)))) key1249) (let ((x1253 (gen-var159 (quote tmp)))) (build-application79 s1242 (build-lambda87 #f (list x1253) #f (gen-syntax-case1166 (build-lexical-reference81 (quote value) #f (quote tmp) x1253) key1249 m1250 r1240 mod1243)) (list (chi147 val1248 r1240 (quote (())) mod1243)))) (syntax-violation (quote syntax-case) "invalid literals list" e1244))) tmp1246) (syntax-violation #f "source expression failed to match any pattern" tmp1245))) ($sc-dispatch tmp1245 (quote (any any each-any . each-any))))) e1244))))) (set! sc-expand (lambda (x1257 . rest1256) (if (and (pair? x1257) (equal? (car x1257) noexpand69)) (cadr x1257) (let ((m1258 (if (null? rest1256) (quote e) (car rest1256))) (esew1259 (if (or (null? rest1256) (null? (cdr rest1256))) (quote (eval)) (cadr rest1256)))) (with-fluid* *mode*70 m1258 (lambda () (chi-top146 x1257 (quote ()) (quote ((top))) m1258 esew1259 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1260) (nonsymbol-id?110 x1260))) (set! datum->syntax (lambda (id1261 datum1262) (make-syntax-object94 datum1262 (syntax-object-wrap97 id1261) #f))) (set! syntax->datum (lambda (x1263) (strip158 x1263 (quote (()))))) (set! generate-temporaries (lambda (ls1264) (begin (let ((x1265 ls1264)) (if (not (list? x1265)) (syntax-violation (quote generate-temporaries) "invalid argument" x1265))) (map (lambda (x1266) (wrap139 (gensym) (quote ((top))) #f)) ls1264)))) (set! free-identifier=? (lambda (x1267 y1268) (begin (let ((x1269 x1267)) (if (not (nonsymbol-id?110 x1269)) (syntax-violation (quote free-identifier=?) "invalid argument" x1269))) (let ((x1270 y1268)) (if (not (nonsymbol-id?110 x1270)) (syntax-violation (quote free-identifier=?) "invalid argument" x1270))) (free-id=?134 x1267 y1268)))) (set! bound-identifier=? (lambda (x1271 y1272) (begin (let ((x1273 x1271)) (if (not (nonsymbol-id?110 x1273)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1273))) (let ((x1274 y1272)) (if (not (nonsymbol-id?110 x1274)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1274))) (bound-id=?135 x1271 y1272)))) (set! syntax-violation (lambda (who1278 message1277 form1276 . subform1275) (begin (let ((x1279 who1278)) (if (not ((lambda (x1280) (or (not x1280) (string? x1280) (symbol? x1280))) x1279)) (syntax-violation (quote syntax-violation) "invalid argument" x1279))) (let ((x1281 message1277)) (if (not (string? x1281)) (syntax-violation (quote syntax-violation) "invalid argument" x1281))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1278 "~a: " "") "~a " (if (null? subform1275) "in ~a" "in subform `~s' of `~s'")) (let ((tail1282 (cons message1277 (map (lambda (x1283) (strip158 x1283 (quote (())))) (append subform1275 (list form1276)))))) (if who1278 (cons who1278 tail1282) tail1282)) #f)))) (letrec ((match1288 (lambda (e1289 p1290 w1291 r1292 mod1293) (cond ((not r1292) #f) ((eq? p1290 (quote any)) (cons (wrap139 e1289 w1291 mod1293) r1292)) ((syntax-object?95 e1289) (match*1287 (let ((e1294 (syntax-object-expression96 e1289))) (if (annotation? e1294) (annotation-expression e1294) e1294)) p1290 (join-wraps130 w1291 (syntax-object-wrap97 e1289)) r1292 (syntax-object-module98 e1289))) (else (match*1287 (let ((e1295 e1289)) (if (annotation? e1295) (annotation-expression e1295) e1295)) p1290 w1291 r1292 mod1293))))) (match*1287 (lambda (e1296 p1297 w1298 r1299 mod1300) (cond ((null? p1297) (and (null? e1296) r1299)) ((pair? p1297) (and (pair? e1296) (match1288 (car e1296) (car p1297) w1298 (match1288 (cdr e1296) (cdr p1297) w1298 r1299 mod1300) mod1300))) ((eq? p1297 (quote each-any)) (let ((l1301 (match-each-any1285 e1296 w1298 mod1300))) (and l1301 (cons l1301 r1299)))) (else (let ((t1302 (vector-ref p1297 0))) (if (memv t1302 (quote (each))) (if (null? e1296) (match-empty1286 (vector-ref p1297 1) r1299) (let ((l1303 (match-each1284 e1296 (vector-ref p1297 1) w1298 mod1300))) (and l1303 (letrec ((collect1304 (lambda (l1305) (if (null? (car l1305)) r1299 (cons (map car l1305) (collect1304 (map cdr l1305))))))) (collect1304 l1303))))) (if (memv t1302 (quote (free-id))) (and (id?111 e1296) (free-id=?134 (wrap139 e1296 w1298 mod1300) (vector-ref p1297 1)) r1299) (if (memv t1302 (quote (atom))) (and (equal? (vector-ref p1297 1) (strip158 e1296 w1298)) r1299) (if (memv t1302 (quote (vector))) (and (vector? e1296) (match1288 (vector->list e1296) (vector-ref p1297 1) w1298 r1299 mod1300))))))))))) (match-empty1286 (lambda (p1306 r1307) (cond ((null? p1306) r1307) ((eq? p1306 (quote any)) (cons (quote ()) r1307)) ((pair? p1306) (match-empty1286 (car p1306) (match-empty1286 (cdr p1306) r1307))) ((eq? p1306 (quote each-any)) (cons (quote ()) r1307)) (else (let ((t1308 (vector-ref p1306 0))) (if (memv t1308 (quote (each))) (match-empty1286 (vector-ref p1306 1) r1307) (if (memv t1308 (quote (free-id atom))) r1307 (if (memv t1308 (quote (vector))) (match-empty1286 (vector-ref p1306 1) r1307))))))))) (match-each-any1285 (lambda (e1309 w1310 mod1311) (cond ((annotation? e1309) (match-each-any1285 (annotation-expression e1309) w1310 mod1311)) ((pair? e1309) (let ((l1312 (match-each-any1285 (cdr e1309) w1310 mod1311))) (and l1312 (cons (wrap139 (car e1309) w1310 mod1311) l1312)))) ((null? e1309) (quote ())) ((syntax-object?95 e1309) (match-each-any1285 (syntax-object-expression96 e1309) (join-wraps130 w1310 (syntax-object-wrap97 e1309)) mod1311)) (else #f)))) (match-each1284 (lambda (e1313 p1314 w1315 mod1316) (cond ((annotation? e1313) (match-each1284 (annotation-expression e1313) p1314 w1315 mod1316)) ((pair? e1313) (let ((first1317 (match1288 (car e1313) p1314 w1315 (quote ()) mod1316))) (and first1317 (let ((rest1318 (match-each1284 (cdr e1313) p1314 w1315 mod1316))) (and rest1318 (cons first1317 rest1318)))))) ((null? e1313) (quote ())) ((syntax-object?95 e1313) (match-each1284 (syntax-object-expression96 e1313) p1314 (join-wraps130 w1315 (syntax-object-wrap97 e1313)) (syntax-object-module98 e1313))) (else #f))))) (set! $sc-dispatch (lambda (e1319 p1320) (cond ((eq? p1320 (quote any)) (list e1319)) ((syntax-object?95 e1319) (match*1287 (let ((e1321 (syntax-object-expression96 e1319))) (if (annotation? e1321) (annotation-expression e1321) e1321)) p1320 (syntax-object-wrap97 e1319) (quote ()) (syntax-object-module98 e1319))) (else (match*1287 (let ((e1322 e1319)) (if (annotation? e1322) (annotation-expression e1322) e1322)) p1320 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1323) ((lambda (tmp1324) ((lambda (tmp1325) (if tmp1325 (apply (lambda (_1326 e11327 e21328) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11327 e21328))) tmp1325) ((lambda (tmp1330) (if tmp1330 (apply (lambda (_1331 out1332 in1333 e11334 e21335) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1333 (quote ()) (list out1332 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11334 e21335))))) tmp1330) ((lambda (tmp1337) (if tmp1337 (apply (lambda (_1338 out1339 in1340 e11341 e21342) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1340) (quote ()) (list out1339 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11341 e21342))))) tmp1337) (syntax-violation #f "source expression failed to match any pattern" tmp1324))) ($sc-dispatch tmp1324 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1324 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1324 (quote (any () any . each-any))))) x1323)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1346) ((lambda (tmp1347) ((lambda (tmp1348) (if tmp1348 (apply (lambda (_1349 k1350 keyword1351 pattern1352 template1353) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1350 (map (lambda (tmp1356 tmp1355) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1355) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1356))) template1353 pattern1352)))))) tmp1348) (syntax-violation #f "source expression failed to match any pattern" tmp1347))) ($sc-dispatch tmp1347 (quote (any each-any . #(each ((any . any) any))))))) x1346)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1357) ((lambda (tmp1358) ((lambda (tmp1359) (if (if tmp1359 (apply (lambda (let*1360 x1361 v1362 e11363 e21364) (and-map identifier? x1361)) tmp1359) #f) (apply (lambda (let*1366 x1367 v1368 e11369 e21370) (letrec ((f1371 (lambda (bindings1372) (if (null? bindings1372) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11369 e21370))) ((lambda (tmp1376) ((lambda (tmp1377) (if tmp1377 (apply (lambda (body1378 binding1379) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1379) body1378)) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1376))) ($sc-dispatch tmp1376 (quote (any any))))) (list (f1371 (cdr bindings1372)) (car bindings1372))))))) (f1371 (map list x1367 v1368)))) tmp1359) (syntax-violation #f "source expression failed to match any pattern" tmp1358))) ($sc-dispatch tmp1358 (quote (any #(each (any any)) any . each-any))))) x1357)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1380) ((lambda (tmp1381) ((lambda (tmp1382) (if tmp1382 (apply (lambda (_1383 var1384 init1385 step1386 e01387 e11388 c1389) ((lambda (tmp1390) ((lambda (tmp1391) (if tmp1391 (apply (lambda (step1392) ((lambda (tmp1393) ((lambda (tmp1394) (if tmp1394 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1384 init1385) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01387) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1389 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1392))))))) tmp1394) ((lambda (tmp1399) (if tmp1399 (apply (lambda (e11400 e21401) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1384 init1385) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01387 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11400 e21401)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1389 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1392))))))) tmp1399) (syntax-violation #f "source expression failed to match any pattern" tmp1393))) ($sc-dispatch tmp1393 (quote (any . each-any)))))) ($sc-dispatch tmp1393 (quote ())))) e11388)) tmp1391) (syntax-violation #f "source expression failed to match any pattern" tmp1390))) ($sc-dispatch tmp1390 (quote each-any)))) (map (lambda (v1408 s1409) ((lambda (tmp1410) ((lambda (tmp1411) (if tmp1411 (apply (lambda () v1408) tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (e1413) e1413) tmp1412) ((lambda (_1414) (syntax-violation (quote do) "bad step expression" orig-x1380 s1409)) tmp1410))) ($sc-dispatch tmp1410 (quote (any)))))) ($sc-dispatch tmp1410 (quote ())))) s1409)) var1384 step1386))) tmp1382) (syntax-violation #f "source expression failed to match any pattern" tmp1381))) ($sc-dispatch tmp1381 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1380)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1417 (lambda (x1421 y1422) ((lambda (tmp1423) ((lambda (tmp1424) (if tmp1424 (apply (lambda (x1425 y1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (dy1429) ((lambda (tmp1430) ((lambda (tmp1431) (if tmp1431 (apply (lambda (dx1432) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1432 dy1429))) tmp1431) ((lambda (_1433) (if (null? dy1429) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1425) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1425 y1426))) tmp1430))) ($sc-dispatch tmp1430 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1425)) tmp1428) ((lambda (tmp1434) (if tmp1434 (apply (lambda (stuff1435) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1425 stuff1435))) tmp1434) ((lambda (else1436) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1425 y1426)) tmp1427))) ($sc-dispatch tmp1427 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1427 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1426)) tmp1424) (syntax-violation #f "source expression failed to match any pattern" tmp1423))) ($sc-dispatch tmp1423 (quote (any any))))) (list x1421 y1422)))) (quasiappend1418 (lambda (x1437 y1438) ((lambda (tmp1439) ((lambda (tmp1440) (if tmp1440 (apply (lambda (x1441 y1442) ((lambda (tmp1443) ((lambda (tmp1444) (if tmp1444 (apply (lambda () x1441) tmp1444) ((lambda (_1445) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1441 y1442)) tmp1443))) ($sc-dispatch tmp1443 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1442)) tmp1440) (syntax-violation #f "source expression failed to match any pattern" tmp1439))) ($sc-dispatch tmp1439 (quote (any any))))) (list x1437 y1438)))) (quasivector1419 (lambda (x1446) ((lambda (tmp1447) ((lambda (x1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (x1451) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1451))) tmp1450) ((lambda (tmp1453) (if tmp1453 (apply (lambda (x1454) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454)) tmp1453) ((lambda (_1456) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1448)) tmp1449))) ($sc-dispatch tmp1449 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1449 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1448)) tmp1447)) x1446))) (quasi1420 (lambda (p1457 lev1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (p1461) (if (= lev1458 0) p1461 (quasicons1417 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1420 (list p1461) (- lev1458 1))))) tmp1460) ((lambda (tmp1462) (if tmp1462 (apply (lambda (p1463 q1464) (if (= lev1458 0) (quasiappend1418 p1463 (quasi1420 q1464 lev1458)) (quasicons1417 (quasicons1417 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1420 (list p1463) (- lev1458 1))) (quasi1420 q1464 lev1458)))) tmp1462) ((lambda (tmp1465) (if tmp1465 (apply (lambda (p1466) (quasicons1417 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1420 (list p1466) (+ lev1458 1)))) tmp1465) ((lambda (tmp1467) (if tmp1467 (apply (lambda (p1468 q1469) (quasicons1417 (quasi1420 p1468 lev1458) (quasi1420 q1469 lev1458))) tmp1467) ((lambda (tmp1470) (if tmp1470 (apply (lambda (x1471) (quasivector1419 (quasi1420 x1471 lev1458))) tmp1470) ((lambda (p1473) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1473)) tmp1459))) ($sc-dispatch tmp1459 (quote #(vector each-any)))))) ($sc-dispatch tmp1459 (quote (any . any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1459 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1457)))) (lambda (x1474) ((lambda (tmp1475) ((lambda (tmp1476) (if tmp1476 (apply (lambda (_1477 e1478) (quasi1420 e1478 0)) tmp1476) (syntax-violation #f "source expression failed to match any pattern" tmp1475))) ($sc-dispatch tmp1475 (quote (any any))))) x1474))))) +(define include (make-syncase-macro (quote macro) (lambda (x1479) (letrec ((read-file1480 (lambda (fn1481 k1482) (let ((p1483 (open-input-file fn1481))) (letrec ((f1484 (lambda (x1485) (if (eof-object? x1485) (begin (close-input-port p1483) (quote ())) (cons (datum->syntax k1482 x1485) (f1484 (read p1483))))))) (f1484 (read p1483))))))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (k1488 filename1489) (let ((fn1490 (syntax->datum filename1489))) ((lambda (tmp1491) ((lambda (tmp1492) (if tmp1492 (apply (lambda (exp1493) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1493)) tmp1492) (syntax-violation #f "source expression failed to match any pattern" tmp1491))) ($sc-dispatch tmp1491 (quote each-any)))) (read-file1480 fn1490 k1488)))) tmp1487) (syntax-violation #f "source expression failed to match any pattern" tmp1486))) ($sc-dispatch tmp1486 (quote (any any))))) x1479))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1495) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (_1498 e1499) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1495)) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any any))))) x1495)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (_1503 e1504) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1500)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote (any any))))) x1500)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509 m11510 m21511) ((lambda (tmp1512) ((lambda (body1513) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1509)) body1513)) tmp1512)) (letrec ((f1514 (lambda (clause1515 clauses1516) (if (null? clauses1516) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (e11520 e21521) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11520 e21521))) tmp1519) ((lambda (tmp1523) (if tmp1523 (apply (lambda (k1524 e11525 e21526) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1524)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11525 e21526)))) tmp1523) ((lambda (_1529) (syntax-violation (quote case) "bad clause" x1505 clause1515)) tmp1518))) ($sc-dispatch tmp1518 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1515) ((lambda (tmp1530) ((lambda (rest1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (k1534 e11535 e21536) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1534)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11535 e21536)) rest1531)) tmp1533) ((lambda (_1539) (syntax-violation (quote case) "bad clause" x1505 clause1515)) tmp1532))) ($sc-dispatch tmp1532 (quote (each-any any . each-any))))) clause1515)) tmp1530)) (f1514 (car clauses1516) (cdr clauses1516))))))) (f1514 m11510 m21511)))) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any any . each-any))))) x1505)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1540) ((lambda (tmp1541) ((lambda (tmp1542) (if tmp1542 (apply (lambda (_1543 e1544) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1544)) (list (cons _1543 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1544 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1542) (syntax-violation #f "source expression failed to match any pattern" tmp1541))) ($sc-dispatch tmp1541 (quote (any any))))) x1540)))) From b81d329e449420b6abaa2b689d7107b862111cbf Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 8 May 2009 12:56:18 +0200 Subject: [PATCH 099/375] more work on tree-il compilation * module/language/scheme/amatch.scm: Remove, this approach won't be used. * module/Makefile.am: Adjust for additions and removals. * module/language/scheme/compile-ghil.scm: Remove an vestigial debugging statement. * module/language/scheme/spec.scm: * module/language/scheme/compile-tree-il.scm: * module/language/scheme/decompile-tree-il.scm: Add tree-il compiler and decompiler. * module/language/tree-il/compile-glil.scm: Add some notes. * module/language/tree-il/spec.scm: No need to wrap expressions in lambdas -- GHIL needs somewhere to put its variables, we don't. --- module/Makefile.am | 6 +- module/language/scheme/amatch.scm | 35 ----------- module/language/scheme/compile-ghil.scm | 2 - module/language/scheme/compile-tree-il.scm | 64 ++++++++++++++++++++ module/language/scheme/decompile-tree-il.scm | 27 +++++++++ module/language/scheme/spec.scm | 6 +- module/language/tree-il/compile-glil.scm | 14 ++++- module/language/tree-il/spec.scm | 13 +--- 8 files changed, 115 insertions(+), 52 deletions(-) delete mode 100644 module/language/scheme/amatch.scm create mode 100644 module/language/scheme/compile-tree-il.scm create mode 100644 module/language/scheme/decompile-tree-il.scm diff --git a/module/Makefile.am b/module/Makefile.am index 761b1868b..ffe159ce9 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -65,8 +65,10 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm SCHEME_LANG_SOURCES = \ - language/scheme/amatch.scm \ - language/scheme/compile-ghil.scm language/scheme/spec.scm \ + language/scheme/compile-ghil.scm \ + language/scheme/spec.scm \ + language/scheme/compile-tree-il.scm \ + language/scheme/decompile-tree-il.scm \ language/scheme/inline.scm TREE_IL_LANG_SOURCES = \ diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm deleted file mode 100644 index 190b37f6a..000000000 --- a/module/language/scheme/amatch.scm +++ /dev/null @@ -1,35 +0,0 @@ -(define-module (language scheme amatch) - #:export (amatch)) - -;; This is exactly the same as pmatch except that it unpacks annotations -;; as needed. - -(define-syntax amatch - (syntax-rules (else guard) - ((_ (op arg ...) cs ...) - (let ((v (op arg ...))) - (amatch v cs ...))) - ((_ v) (if #f #f)) - ((_ v (else e0 e ...)) (begin e0 e ...)) - ((_ v (pat (guard g ...) e0 e ...) cs ...) - (let ((fk (lambda () (amatch v cs ...)))) - (apat v pat - (if (and g ...) (begin e0 e ...) (fk)) - (fk)))) - ((_ v (pat e0 e ...) cs ...) - (let ((fk (lambda () (amatch v cs ...)))) - (apat v pat (begin e0 e ...) (fk)))))) - -(define-syntax apat - (syntax-rules (_ quote unquote) - ((_ v _ kt kf) kt) - ((_ v () kt kf) (if (null? v) kt kf)) - ((_ v (quote lit) kt kf) - (if (equal? v (quote lit)) kt kf)) - ((_ v (unquote var) kt kf) (let ((var v)) kt)) - ((_ v (x . y) kt kf) - (if (apair? v) - (let ((vx (acar v)) (vy (acdr v))) - (apat vx x (apat vy y kt kf) kf)) - kf)) - ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 3d5b0159b..370488c05 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -32,8 +32,6 @@ #:export (compile-ghil translate-1 *translate-table* define-scheme-translator)) -(module-ref (current-module) 'receive) - ;;; environment := #f ;;; | MODULE ;;; | COMPILE-ENV diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm new file mode 100644 index 000000000..553a3fd43 --- /dev/null +++ b/module/language/scheme/compile-tree-il.scm @@ -0,0 +1,64 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language scheme compile-tree-il) + #:use-module (language tree-il) + #:export (compile-tree-il)) + +;;; environment := #f +;;; | MODULE +;;; | COMPILE-ENV +;;; compile-env := (MODULE LEXICALS . EXTERNALS) +(define (cenv-module env) + (cond ((not env) #f) + ((module? env) env) + ((and (pair? env) (module? (car env))) (car env)) + (else (error "bad environment" env)))) + +(define (cenv-lexicals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cadr env)) + (else (error "bad environment" env)))) + +(define (cenv-externals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cddr env)) + (else (error "bad environment" env)))) + +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + +(define (compile-tree-il x e opts) + (save-module-excursion + (lambda () + (and=> (cenv-module e) set-current-module) + (let ((x (sc-expand x 'c '(compile load eval))) + (cenv (make-cenv (current-module) + (cenv-lexicals e) (cenv-externals e)))) + (values x cenv cenv))))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm new file mode 100644 index 000000000..c4903d87f --- /dev/null +++ b/module/language/scheme/decompile-tree-il.scm @@ -0,0 +1,27 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001,2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language scheme decompile-tree-il) + #:use-module (language tree-il) + #:export (decompile-tree-il)) + +(define (decompile-tree-il x env opts) + (values (tree-il->scheme x) env)) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 8f958eb63..70085e8d7 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -22,6 +22,8 @@ (define-module (language scheme spec) #:use-module (system base language) #:use-module (language scheme compile-ghil) + #:use-module (language scheme compile-tree-il) + #:use-module (language scheme decompile-tree-il) #:export (scheme)) ;;; @@ -45,7 +47,9 @@ #:version "0.5" #:reader read #:read-file read-file - #:compilers `((ghil . ,compile-ghil)) + #:compilers `((ghil . ,compile-ghil) + (tree-il . ,compile-tree-il)) + #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write ) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 3a0225577..dbe4b25ef 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -1,6 +1,6 @@ ;;; TREE-IL -> GLIL compiler -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -46,6 +46,18 @@ (ghil-env-add! parent-env v)) (ghil-env-variables env)))) +;; Possible optimizations: +;; * compile primitives specially +;; * turn global-refs into primitive-refs +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations + + ;; The premise of this, unused, approach to optimization is that you can ;; determine the environment of a variable lexically, because they have ;; been alpha-renamed. It makes the transformations *much* easier. diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm index d69a4ec37..c1f098230 100644 --- a/module/language/tree-il/spec.scm +++ b/module/language/tree-il/spec.scm @@ -29,24 +29,15 @@ (define (write-tree-il exp . port) (apply write (unparse-tree-il exp) port)) -(define (parse x) - (make-lambda #f '() '() (parse-tree-il x))) - (define (join exps env) - (if (or-map (lambda (x) - (or (not (lambda? x)) - (not (null? (lambda-vars x))))) - exps) - (error "tree-il expressions to join must be thunks")) - - (make-lambda #f '() '() (make-sequence #f (map lambda-body exps)))) + (make-sequence #f exps)) (define-language tree-il #:title "Tree Intermediate Language" #:version "1.0" #:reader read #:printer write-tree-il - #:parser parse + #:parser parse-tree-il #:joiner join #:compilers `((glil . ,compile-glil)) ) From 9efc833d65adef11e76410fee7ea548143131417 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 May 2009 23:23:34 +0200 Subject: [PATCH 100/375] add tree-il optimizer * module/language/tree-il/optimize.scm: New module, for optimizations. Currently all we have is resolving some toplevel refs to primitive refs. * module/Makefile.am: Add new module. * module/language/tree-il.scm: Fix exports for accessors for `src'. * module/language/tree-il/compile-glil.scm: Tweaks, things still aren't working yet. --- module/Makefile.am | 6 +- module/language/tree-il.scm | 42 +-- module/language/tree-il/compile-glil.scm | 357 ++++------------------- module/language/tree-il/optimize.scm | 143 +++++++++ 4 files changed, 221 insertions(+), 327 deletions(-) create mode 100644 module/language/tree-il/optimize.scm diff --git a/module/Makefile.am b/module/Makefile.am index ffe159ce9..3f607f259 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -71,8 +71,10 @@ SCHEME_LANG_SOURCES = \ language/scheme/decompile-tree-il.scm \ language/scheme/inline.scm -TREE_IL_LANG_SOURCES = \ - language/tree-il/spec.scm language/tree-il/compile-glil.scm +TREE_IL_LANG_SOURCES = \ + language/tree-il/spec.scm \ + language/tree-il/compile-glil.scm \ + language/tree-il/optimize.scm GHIL_LANG_SOURCES = \ language/ghil/spec.scm language/ghil/compile-glil.scm diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index fa655d815..3de73b9c0 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -19,30 +19,30 @@ (define-module (language tree-il) #:use-module (system base pmatch) #:use-module (system base syntax) - :export (tree-il-loc + #:export (tree-il-src - make-lexical - lexical-name lexical-gensym + make-lexical + lexical-name lexical-gensym - make-application application-loc application-proc application-args - make-conditional conditional-loc conditional-test conditional-then conditional-else - make-primitive-ref primitive-ref-loc primitive-ref-name - make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym - make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp - make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public? - make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp - make-toplevel-ref toplevel-ref-loc toplevel-ref-name - make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp - make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp - make-lambda lambda-loc lambda-vars lambda-meta lambda-body - make-const const-loc const-exp - make-sequence sequence-loc sequence-exps - make-let let-loc let-vars let-vals let-exp - make-letrec letrec-loc letrec-vars letrec-vals letrec-exp + make-application application-src application-proc application-args + make-conditional conditional-src conditional-test conditional-then conditional-else + make-primitive-ref primitive-ref-src primitive-ref-name + make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym + make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp + make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? + make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp + make-toplevel-ref toplevel-ref-src toplevel-ref-name + make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp + make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp + make-lambda lambda-src lambda-vars lambda-meta lambda-body + make-const const-src const-exp + make-sequence sequence-src sequence-exps + make-let let-src let-vars let-vals let-exp + make-letrec letrec-src letrec-vars letrec-vals letrec-exp - parse-tree-il - unparse-tree-il - tree-il->scheme)) + parse-tree-il + unparse-tree-il + tree-il->scheme)) (define-type ( #:common-slots (src)) ( proc args) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index dbe4b25ef..d75ae7a56 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -27,168 +27,11 @@ #:export (compile-glil)) (define (compile-glil x e opts) - (if (memq #:O opts) (set! x (optimize x))) (values (codegen x) (and e (cons (car e) (cddr e))) e)) -;;; -;;; Stage 2: Optimization -;;; - -(define (lift-variables! env) - (let ((parent-env (ghil-env-parent env))) - (for-each (lambda (v) - (case (ghil-var-kind v) - ((argument) (set! (ghil-var-kind v) 'local))) - (set! (ghil-var-env v) parent-env) - (ghil-env-add! parent-env v)) - (ghil-env-variables env)))) - -;; Possible optimizations: -;; * compile primitives specially -;; * turn global-refs into primitive-refs -;; * constant folding, propagation -;; * procedure inlining -;; * always when single call site -;; * always for "trivial" procs -;; * otherwise who knows -;; * dead code elimination -;; * degenerate case optimizations - - -;; The premise of this, unused, approach to optimization is that you can -;; determine the environment of a variable lexically, because they have -;; been alpha-renamed. It makes the transformations *much* easier. -;; Unfortunately it doesn't work yet. -(define (optimize* x) - (transform-record ( env loc) x - ((quasiquote exp) - (define (optimize-qq x) - (cond ((list? x) (map optimize-qq x)) - ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x)))) - ((record? x) (optimize x)) - (else x))) - (-> (quasiquote (optimize-qq x)))) - - ((unquote exp) - (-> (unquote (optimize exp)))) - - ((unquote-splicing exp) - (-> (unquote-splicing (optimize exp)))) - - ((set var val) - (-> (set var (optimize val)))) - - ((define var val) - (-> (define var (optimize val)))) - - ((if test then else) - (-> (if (optimize test) (optimize then) (optimize else)))) - - ((and exps) - (-> (and (map optimize exps)))) - - ((or exps) - (-> (or (map optimize exps)))) - - ((begin exps) - (-> (begin (map optimize exps)))) - - ((bind vars vals body) - (-> (bind vars (map optimize vals) (optimize body)))) - - ((mv-bind producer vars rest body) - (-> (mv-bind (optimize producer) vars rest (optimize body)))) - - ((inline inst args) - (-> (inline inst (map optimize args)))) - - ((call (proc (lambda vars (rest #f) meta body)) args) - (-> (bind vars (optimize args) (optimize body)))) - - ((call proc args) - (-> (call (optimize proc) (map optimize args)))) - - ((lambda vars rest meta body) - (-> (lambda vars rest meta (optimize body)))) - - ((mv-call producer (consumer (lambda vars rest meta body))) - (-> (mv-bind (optimize producer) vars rest (optimize body)))) - - ((mv-call producer consumer) - (-> (mv-call (optimize producer) (optimize consumer)))) - - ((values values) - (-> (values (map optimize values)))) - - ((values* values) - (-> (values* (map optimize values)))) - - (else - (error "unrecognized GHIL" x)))) - -(define (optimize x) - (record-case x - (( env loc var val) - (make-ghil-set env var (optimize val))) - - (( env loc var val) - (make-ghil-define env var (optimize val))) - - (( env loc test then else) - (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) - - (( env loc exps) - (make-ghil-and env loc (map optimize exps))) - - (( env loc exps) - (make-ghil-or env loc (map optimize exps))) - - (( env loc exps) - (make-ghil-begin env loc (map optimize exps))) - - (( env loc vars vals body) - (make-ghil-bind env loc vars (map optimize vals) (optimize body))) - - (( env loc vars rest meta body) - (make-ghil-lambda env loc vars rest meta (optimize body))) - - (( env loc instruction args) - (make-ghil-inline env loc instruction (map optimize args))) - - (( env loc proc args) - (let ((parent-env env)) - (record-case proc - ;; ((@lambda (VAR...) BODY...) ARG...) => - ;; (@let ((VAR ARG) ...) BODY...) - (( env loc vars rest meta body) - (cond - ((not rest) - (lift-variables! env) - (make-ghil-bind parent-env loc (map optimize args))) - (else - (make-ghil-call parent-env loc (optimize proc) (map optimize args))))) - (else - (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))) - - (( env loc producer consumer) - (record-case consumer - ;; (mv-call PRODUCER (lambda ARGS BODY...)) => - ;; (mv-let PRODUCER ARGS BODY...) - (( env loc vars rest meta body) - (lift-variables! env) - (make-ghil-mv-bind producer vars rest body)) - (else - (make-ghil-mv-call env loc (optimize producer) (optimize consumer))))) - - (else x))) - - -;;; -;;; Stage 3: Code generation -;;; (define *ia-void* (make-glil-void)) (define *ia-drop* (make-glil-call 'drop 1)) @@ -214,33 +57,24 @@ (eq? (ghil-var-kind var) 'public))) (else (error "Unknown kind of variable:" var)))) -(define (constant? x) - (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t) - ((pair? x) (and (constant? (car x)) - (constant? (cdr x)))) - ((vector? x) (let lp ((i (vector-length x))) - (or (zero? i) - (and (constant? (vector-ref x (1- i))) - (lp (1- i)))))))) - (define (codegen ghil) (let ((stack '())) - (define (push-code! loc code) + (define (push-code! src code) (set! stack (cons code stack)) - (if loc (set! stack (cons (make-glil-source loc) stack)))) + (if src (set! stack (cons (make-glil-source src) stack)))) (define (var->binding var) (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) - (define (push-bindings! loc vars) + (define (push-bindings! src vars) (if (not (null? vars)) - (push-code! loc (make-glil-bind (map var->binding vars))))) + (push-code! src (make-glil-bind (map var->binding vars))))) (define (comp tree tail drop) (define (push-label! label) (push-code! #f (make-glil-label label))) - (define (push-branch! loc inst label) - (push-code! loc (make-glil-branch inst label))) - (define (push-call! loc inst args) + (define (push-branch! src inst label) + (push-code! src (make-glil-branch inst label))) + (define (push-call! src inst args) (for-each comp-push args) - (push-code! loc (make-glil-call inst (length args)))) + (push-code! src (make-glil-call inst (length args)))) ;; possible tail position (define (comp-tail tree) (comp tree tail drop)) ;; push the result @@ -254,72 +88,38 @@ (define (maybe-return) (if tail (push-code! #f *ia-return*))) ;; return this code if necessary - (define (return-code! loc code) - (if (not drop) (push-code! loc code)) + (define (return-code! src code) + (if (not drop) (push-code! src code)) (maybe-return)) ;; return void if necessary (define (return-void!) (return-code! #f *ia-void*)) ;; return object if necessary - (define (return-object! loc obj) - (return-code! loc (make-glil-const obj))) + (define (return-object! src obj) + (return-code! src (make-glil-const obj))) ;; ;; dispatch (record-case tree (() (return-void!)) - (( env loc obj) - (return-object! loc obj)) + (( env src obj) + (return-object! src obj)) - (( env loc exp) - (let loop ((x exp) (in-car? #f)) - (cond - ((list? x) - (push-call! #f 'mark '()) - (for-each (lambda (x) (loop x #t)) x) - (push-call! #f 'list-mark '())) - ((pair? x) - (push-call! #f 'mark '()) - (loop (car x) #t) - (loop (cdr x) #f) - (push-call! #f 'cons-mark '())) - ((record? x) - (record-case x - (( env loc exp) - (comp-push exp)) - (( env loc exp) - (if (not in-car?) - (error "unquote-splicing in the cdr of a pair" exp)) - (comp-push exp) - (push-call! #f 'list-break '())))) - ((constant? x) - (push-code! #f (make-glil-const x))) - (else - (error "element of quasiquote can't be compiled" x)))) - (maybe-drop) - (maybe-return)) + (( env src var) + (return-code! src (make-glil-var 'ref env var))) - (( env loc exp) - (error "unquote outside of quasiquote" exp)) - - (( env loc exp) - (error "unquote-splicing outside of quasiquote" exp)) - - (( env loc var) - (return-code! loc (make-glil-var 'ref env var))) - - (( env loc var val) + (( env src var val) (comp-push val) - (push-code! loc (make-glil-var 'set env var)) + (push-code! src (make-glil-var 'set env var)) (return-void!)) - (( env loc var val) - (comp-push val) - (push-code! loc (make-glil-var 'define env var)) + (( src name exp) + (comp-push exp) + (push-code! src (make-glil-var 'define env var)) (return-void!)) - (( env loc test then else) + (( src test then else) ;; TEST ;; (br-if-not L1) ;; THEN @@ -328,65 +128,14 @@ ;; L2: (let ((L1 (make-label)) (L2 (make-label))) (comp-push test) - (push-branch! loc 'br-if-not L1) + (push-branch! src 'br-if-not L1) (comp-tail then) (if (not tail) (push-branch! #f 'br L2)) (push-label! L1) (comp-tail else) (if (not tail) (push-label! L2)))) - (( env loc exps) - ;; EXP - ;; (br-if-not L1) - ;; ... - ;; TAIL - ;; (br L2) - ;; L1: (const #f) - ;; L2: - (cond ((null? exps) (return-object! loc #t)) - ((null? (cdr exps)) (comp-tail (car exps))) - (else - (let ((L1 (make-label)) (L2 (make-label))) - (let lp ((exps exps)) - (cond ((null? (cdr exps)) - (comp-tail (car exps)) - (push-branch! #f 'br L2) - (push-label! L1) - (return-object! #f #f) - (push-label! L2) - (maybe-return)) - (else - (comp-push (car exps)) - (push-branch! #f 'br-if-not L1) - (lp (cdr exps))))))))) - - (( env loc exps) - ;; EXP - ;; (dup) - ;; (br-if L1) - ;; (drop) - ;; ... - ;; TAIL - ;; L1: - (cond ((null? exps) (return-object! loc #f)) - ((null? (cdr exps)) (comp-tail (car exps))) - (else - (let ((L1 (make-label))) - (let lp ((exps exps)) - (cond ((null? (cdr exps)) - (comp-tail (car exps)) - (push-label! L1) - (maybe-return)) - (else - (comp-push (car exps)) - (if (not drop) - (push-call! #f 'dup '())) - (push-branch! #f 'br-if L1) - (if (not drop) - (push-code! loc (make-glil-call 'drop 1))) - (lp (cdr exps))))))))) - - (( env loc exps) + (( src exps) ;; EXPS... ;; TAIL (if (null? exps) @@ -396,24 +145,24 @@ (comp-tail (car exps))) (comp-drop (car exps))))) - (( env loc vars vals body) + (( src vars vals body) ;; VALS... ;; (set VARS)... ;; BODY (for-each comp-push vals) - (push-bindings! loc vars) + (push-bindings! src vars) (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) (reverse vars)) (comp-tail body) (push-code! #f (make-glil-unbind))) - (( env loc producer vars rest body) + (( env src producer vars rest body) ;; VALS... ;; (set VARS)... ;; BODY (let ((MV (make-label))) (comp-push producer) - (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! src (make-glil-mv-call 0 MV)) (push-code! #f (make-glil-const 1)) (push-label! MV) (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) @@ -422,10 +171,10 @@ (comp-tail body) (push-code! #f (make-glil-unbind))) - (( env loc vars rest meta body) - (return-code! loc (codegen tree))) + (( env src vars rest meta body) + (return-code! src (codegen tree))) - (( env loc inline args) + (( env src inline args) ;; ARGS... ;; (INST NARGS) (let ((tail-table '((call . goto/args) @@ -433,50 +182,50 @@ (call/cc . goto/cc)))) (cond ((and tail (assq-ref tail-table inline)) => (lambda (tail-inst) - (push-call! loc tail-inst args))) + (push-call! src tail-inst args))) (else - (push-call! loc inline args) + (push-call! src inline args) (maybe-drop) (maybe-return))))) - (( env loc values) + (( env src values) (cond (tail ;; (lambda () (values 1 2)) - (push-call! loc 'return/values values)) + (push-call! src 'return/values values)) (drop ;; (lambda () (values 1 2) 3) (for-each comp-drop values)) (else ;; (lambda () (list (values 10 12) 1)) (push-code! #f (make-glil-const 'values)) (push-code! #f (make-glil-call 'link-now 1)) (push-code! #f (make-glil-call 'variable-ref 0)) - (push-call! loc 'call values)))) + (push-call! src 'call values)))) - (( env loc values) + (( env src values) (cond (tail ;; (lambda () (apply values '(1 2))) - (push-call! loc 'return/values* values)) + (push-call! src 'return/values* values)) (drop ;; (lambda () (apply values '(1 2)) 3) (for-each comp-drop values)) (else ;; (lambda () (list (apply values '(10 12)) 1)) (push-code! #f (make-glil-const 'values)) (push-code! #f (make-glil-call 'link-now 1)) (push-code! #f (make-glil-call 'variable-ref 0)) - (push-call! loc 'apply values)))) + (push-call! src 'apply values)))) - (( env loc proc args) + (( env src proc args) ;; PROC ;; ARGS... ;; ([tail-]call NARGS) (comp-push proc) (let ((nargs (length args))) (cond ((< nargs 255) - (push-call! loc (if tail 'goto/args 'call) args)) + (push-call! src (if tail 'goto/args 'call) args)) (else - (push-call! loc 'mark '()) + (push-call! src 'mark '()) (for-each comp-push args) - (push-call! loc 'list-mark '()) - (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2))))) + (push-call! src 'list-mark '()) + (push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2))))) (maybe-drop)) - (( env loc producer consumer) + (( env src producer consumer) ;; CONSUMER ;; PRODUCER ;; (mv-call MV) @@ -487,25 +236,25 @@ (let ((MV (make-label)) (POST (make-label))) (comp-push consumer) (comp-push producer) - (push-code! loc (make-glil-mv-call 0 MV)) - (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) + (push-code! src (make-glil-mv-call 0 MV)) + (push-code! src (make-glil-call (if tail 'goto/args 'call) 1)) (cond ((not tail) (push-branch! #f 'br POST))) (push-label! MV) - (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) + (push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) (cond ((not tail) (push-label! POST) (maybe-drop))))) - (( env loc) - (return-object! loc (ghil-env-reify env))))) + (( env src) + (return-object! src (ghil-env-reify env))))) ;; ;; main (record-case ghil - (( env loc vars rest meta body) + (( env src vars rest meta body) (let* ((evars (ghil-env-variables env)) - (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) + (srcs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) (nargs (allocate-indices-linearly! vars)) (nlocs (allocate-locals! locs body)) @@ -513,7 +262,7 @@ ;; meta bindings (push-bindings! #f vars) ;; push on definition source location - (if loc (set! stack (cons (make-glil-source loc) stack))) + (if src (set! stack (cons (make-glil-source src) stack))) ;; copy args to the heap if they're marked as external (do ((n 0 (1+ n)) (l vars (cdr l))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm new file mode 100644 index 000000000..69aff6f78 --- /dev/null +++ b/module/language/tree-il/optimize.scm @@ -0,0 +1,143 @@ +;;; Tree-il optimizer + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il optimize) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (resolve-primitives!)) + +;; Possible optimizations: +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations +;; * "fixing letrec" + +(define (post-order! f x) + (let lp ((x x)) + (record-case x + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args)) + (or (f x) x)) + + (( test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name gensym) + (or (f x) x)) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp)) + (or (f x) x)) + + (( mod name public?) + (or (f x) x)) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp)) + (or (f x) x)) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp)) + (or (f x) x)) + + (( vars meta body) + (set! (lambda-body x) (lp body)) + (or (f x) x)) + + (( exp) + (or (f x) x)) + + (( exps) + (set! (sequence-exps x) (map lp exps)) + (or (f x) x)) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp)) + (or (f x) x)) + + (( vars vals exp) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-exp x) (lp exp)) + (or (f x) x))))) + +(define *interesting-primitive-names* + '(apply @apply + call-with-values @call-with-values + call-with-current-continuation @call-with-current-continuation + values + ;; compile-time-environment + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + + car cdr + set-car! set-cdr! + + caar cadr cdar cddr + + caaar caadr cadar caddr cdaar cdadr cddar cdddr + + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) + +(define *interesting-primitive-vars* + (let ((h (make-hash-table))) + (for-each (lambda (x) + (hashq-set! h (module-variable the-root-module x) x)) + *interesting-primitive-names*) + h)) + +(define (resolve-primitives! x mod) + (post-order! + (lambda (x) + (record-case x + (( src name) + (and (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (make-primitive-ref src name))) + (( mod name public?) + (let ((m (if public? (resolve-interface mod) (resolve-module mod)))) + (and m (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (make-primitive-ref src name)))) + (else #f))) + x)) From cb28c08537790b49f7bc94f2f6b426497152bbe7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 12 May 2009 22:29:34 +0200 Subject: [PATCH 101/375] add primitive expander for tree-il * module/Makefile.am: Add inline.scm. * module/language/tree-il.scm (pre-order!, post-order!): pre-order! is new. post-order! existed but was not public. They do destructive tree traversals of tree-il, and need more documentation. Also, add predicates to tree-il's export list. * module/language/tree-il/inline.scm: New file, which expands primitives into more primitive primitives. In the future perhaps it will not be necessary, as the general inlining infrastructure will handle these cases, but for now it's useful. * module/language/tree-il/optimize.scm: Move post-order! out to better pastures. --- module/Makefile.am | 1 + module/language/tree-il.scm | 140 ++++++++++++++++++++++++--- module/language/tree-il/inline.scm | 139 ++++++++++++++++++++++++++ module/language/tree-il/optimize.scm | 63 ------------ 4 files changed, 264 insertions(+), 79 deletions(-) create mode 100644 module/language/tree-il/inline.scm diff --git a/module/Makefile.am b/module/Makefile.am index 3f607f259..36d670002 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -74,6 +74,7 @@ SCHEME_LANG_SOURCES = \ TREE_IL_LANG_SOURCES = \ language/tree-il/spec.scm \ language/tree-il/compile-glil.scm \ + language/tree-il/inline.scm \ language/tree-il/optimize.scm GHIL_LANG_SOURCES = \ diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 3de73b9c0..774ca2ca7 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -24,25 +24,28 @@ make-lexical lexical-name lexical-gensym - make-application application-src application-proc application-args - make-conditional conditional-src conditional-test conditional-then conditional-else - make-primitive-ref primitive-ref-src primitive-ref-name - make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym - make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp - make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? - make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp - make-toplevel-ref toplevel-ref-src toplevel-ref-name - make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp - make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp - make-lambda lambda-src lambda-vars lambda-meta lambda-body - make-const const-src const-exp - make-sequence sequence-src sequence-exps - make-let let-src let-vars let-vals let-exp - make-letrec letrec-src letrec-vars letrec-vals letrec-exp + application? make-application application-src application-proc application-args + conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name + lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym + lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp + module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? + module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp + toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name + toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp + toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp + lambda? make-lambda lambda-src lambda-vars lambda-meta lambda-body + const? make-const const-src const-exp + sequence? make-sequence sequence-src sequence-exps + let? make-let let-src let-vars let-vals let-exp + letrec? make-letrec letrec-src letrec-vars letrec-vals letrec-exp parse-tree-il unparse-tree-il - tree-il->scheme)) + tree-il->scheme + + post-order! + pre-order!)) (define-type ( #:common-slots (src)) ( proc args) @@ -246,3 +249,108 @@ (( vars vals exp) `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))))) (else e))) + +(define (post-order! f x) + (let lp ((x x)) + (record-case x + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args)) + (or (f x) x)) + + (( test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name gensym) + (or (f x) x)) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp)) + (or (f x) x)) + + (( mod name public?) + (or (f x) x)) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp)) + (or (f x) x)) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp)) + (or (f x) x)) + + (( vars meta body) + (set! (lambda-body x) (lp body)) + (or (f x) x)) + + (( exp) + (or (f x) x)) + + (( exps) + (set! (sequence-exps x) (map lp exps)) + (or (f x) x)) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp)) + (or (f x) x)) + + (( vars vals exp) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-exp x) (lp exp)) + (or (f x) x))))) + +(define (pre-order! f x) + (let lp ((x x)) + (let ((x (or (f x) x))) + (record-case x + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args))) + + (( test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else))) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp))) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp))) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp))) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp))) + + (( vars meta body) + (set! (lambda-body x) (lp body))) + + (( exps) + (set! (sequence-exps x) (map lp exps))) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp))) + + (( vars vals exp) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-exp x) (lp exp))) + + (else #f)) + x))) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm new file mode 100644 index 000000000..0161faf02 --- /dev/null +++ b/module/language/tree-il/inline.scm @@ -0,0 +1,139 @@ +;;; GHIL macros + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il inline) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:use-module (srfi srfi-16) + #:export (expand-primitives!)) + +(define *primitive-expand-table* (make-hash-table)) + +(define (expand-primitives! x) + (pre-order! + (lambda (x) + (record-case x + (( src proc args) + (and (primitive-ref? proc) + (let ((expand (hashq-ref *primitive-expand-table* + (primitive-ref-name proc)))) + (and expand (apply expand src args))))) + (else #f))) + x)) + +;;; I actually did spend about 10 minutes trying to redo this with +;;; syntax-rules. Patches appreciated. +;;; +(define-macro (define-primitive-expander sym . clauses) + (define (inline-args args) + (let lp ((in args) (out '())) + (cond ((null? in) `(list ,@(reverse out))) + ((symbol? in) `(cons* ,@(reverse out) ,in)) + ((pair? (car in)) + (lp (cdr in) + (cons `(make-application src (make-primitive-ref src ',(caar in)) + ,(inline-args (cdar in))) + out))) + ((symbol? (car in)) + ;; assume it's locally bound + (lp (cdr in) (cons (car in) out))) + ((number? (car in)) + (lp (cdr in) (cons `(make-const src ,(car in)) out))) + (else + (error "what what" (car in)))))) + (define (consequent exp) + (cond + ((pair? exp) + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))) + ((symbol? exp) + ;; assume locally bound + exp) + ((number? exp) + `(make-const src ,exp)) + (else (error "bad consequent yall" exp)))) + `(hashq-set! *primitive-expand-table* + ',sym + (case-lambda + ,@(let lp ((in clauses) (out '())) + (if (null? in) + (reverse (cons '(else #f) out)) + (lp (cddr in) + (cons `((src . ,(car in)) + ,(consequent (cadr in))) out))))))) + +(define-primitive-expander + + () 0 + (x) x + (x y z . rest) (+ x (+ y z . rest))) + +(define-primitive-expander * + () 1 + (x) x + (x y z . rest) (* x (* y z . rest))) + +(define-primitive-expander - + (x) (- 0 x) + (x y z . rest) (- x (+ y z . rest))) + +(define-primitive-expander 1- + (x) (- x 1)) + +(define-primitive-expander / + (x) (/ 1 x) + (x y z . rest) (div x (* y z . rest))) + +(define-primitive-expander caar (x) (car (car x))) +(define-primitive-expander cadr (x) (car (cdr x))) +(define-primitive-expander cdar (x) (cdr (car x))) +(define-primitive-expander cddr (x) (cdr (cdr x))) +(define-primitive-expander caaar (x) (car (car (car x)))) +(define-primitive-expander caadr (x) (car (car (cdr x)))) +(define-primitive-expander cadar (x) (car (cdr (car x)))) +(define-primitive-expander caddr (x) (car (cdr (cdr x)))) +(define-primitive-expander cdaar (x) (cdr (car (car x)))) +(define-primitive-expander cdadr (x) (cdr (car (cdr x)))) +(define-primitive-expander cddar (x) (cdr (cdr (car x)))) +(define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) +(define-primitive-expander caaaar (x) (car (car (car (car x))))) +(define-primitive-expander caaadr (x) (car (car (car (cdr x))))) +(define-primitive-expander caadar (x) (car (car (cdr (car x))))) +(define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) +(define-primitive-expander cadaar (x) (car (cdr (car (car x))))) +(define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) +(define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) +(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) +(define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) +(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) +(define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) +(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) +(define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) +(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) +(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) +(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) + +(define-primitive-expander cons* + (x) x + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) + +(define-primitive-expander acons + (x y z) (cons (cons x y) z)) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 69aff6f78..52baddb08 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -34,69 +34,6 @@ ;; * degenerate case optimizations ;; * "fixing letrec" -(define (post-order! f x) - (let lp ((x x)) - (record-case x - (( proc args) - (set! (application-proc x) (lp proc)) - (set! (application-args x) (map lp args)) - (or (f x) x)) - - (( test then else) - (set! (conditional-test x) (lp test)) - (set! (conditional-then x) (lp then)) - (set! (conditional-else x) (lp else)) - (or (f x) x)) - - (( name) - (or (f x) x)) - - (( name gensym) - (or (f x) x)) - - (( name gensym exp) - (set! (lexical-set-exp x) (lp exp)) - (or (f x) x)) - - (( mod name public?) - (or (f x) x)) - - (( mod name public? exp) - (set! (module-set-exp x) (lp exp)) - (or (f x) x)) - - (( name) - (or (f x) x)) - - (( name exp) - (set! (toplevel-set-exp x) (lp exp)) - (or (f x) x)) - - (( name exp) - (set! (toplevel-define-exp x) (lp exp)) - (or (f x) x)) - - (( vars meta body) - (set! (lambda-body x) (lp body)) - (or (f x) x)) - - (( exp) - (or (f x) x)) - - (( exps) - (set! (sequence-exps x) (map lp exps)) - (or (f x) x)) - - (( vars vals exp) - (set! (let-vals x) (map lp vals)) - (set! (let-exp x) (lp exp)) - (or (f x) x)) - - (( vars vals exp) - (set! (letrec-vals x) (map lp vals)) - (set! (letrec-exp x) (lp exp)) - (or (f x) x))))) - (define *interesting-primitive-names* '(apply @apply call-with-values @call-with-values From 073bb617eb7e5f76269ca6dba0fe498baff6f058 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 May 2009 00:11:25 +0200 Subject: [PATCH 102/375] add lexical analyzer and allocator * module/language/tree-il/optimize.scm: Rework to just export the optimize! procedure. * module/language/tree-il/compile-glil.scm (analyze-lexicals): New function, analyzes and allocates lexical variables. Almost ready to compile now. (codegen): Dedent. --- module/language/tree-il/compile-glil.scm | 627 +++++++++++++++-------- module/language/tree-il/optimize.scm | 9 +- 2 files changed, 415 insertions(+), 221 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index d75ae7a56..f54da31f0 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -23,13 +23,196 @@ #:use-module (system base syntax) #:use-module (language glil) #:use-module (language tree-il) + #:use-module (language tree-il optimize) #:use-module (ice-9 common-list) #:export (compile-glil)) +;; parents: lambda -> parent +;; useful when we see a closed-over var, so we can calculate its +;; coordinates (depth and index). +;; bindings: lambda -> (sym ...) +;; useful for two reasons: one, so we know how much space to allocate +;; when we go into a lambda; and two, so that we know when to stop, +;; when looking for closed-over vars. +;; heaps: sym -> lambda +;; allows us to heapify vars in an O(1) fashion + +;; allocation: the process of assigning a type and index to each var +;; a var is external if it is heaps; assigning index is easy +;; args are assigned in order +;; locals are indexed as their linear position in the binding path +;; (let (0 1) +;; (let (2 3) ...) +;; (let (2) ...)) +;; (let (2 3 4) ...)) +;; etc. + +;; allocation: +;; sym -> (local . index) | (heap level . index) + + +(define (analyze-lexicals x) + (define (find-diff parent this) + (let lp ((parent parent) (n 0)) + (if (eq? parent this) + n + (lp (hashq-ref parents parent) (1+ n))))) + + (define (find-heap sym parent) + ;; fixme: check displaced lexicals here? + (if (memq sym (hashq-ref bindings parent)) + parent + (find-binder sym (hashq-ref parents parent)))) + + (define (analyze! x parent level) + (define (step y) (analyze! y parent level)) + (define (recur x parent) (analyze! x parent (1+ level))) + (record-case x + (( proc args) + (step proc) (for-each step args)) + + (( test then else) + (step test) (step then) (step else)) + + (( name gensym) + (if (and (not (memq gensym (hashq-ref bindings parent))) + (not (hashq-ref heaps gensym))) + (hashq-set! heaps gensym (find-heap gensym parent level)))) + + (( name gensym exp) + (step exp) + (if (not (hashq-ref heaps gensym)) + (hashq-set! heaps gensym (find-heap gensym parent level)))) + + (( mod name public? exp) + (step exp)) + + (( name exp) + (step exp)) + + (( name exp) + (step exp)) + + (( exps) + (for-each step exps)) + + (( vars meta body) + (hashq-set! parents x parent) + (hashq-set! bindings x + (let rev* ((vars vars) (out '())) + (cond ((null? vars) out) + ((pair? vars) (rev* (cdr vars) + (cons (car vars) out))) + (else (cons vars out))))) + (recur body x) + (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) + + (( vars vals exp) + (for-each step vals) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (step exp)) + + (( vars vals exp) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (for-each step vals) + (step exp)) + + (else #f))) + + (define (allocate-heap! binder) + (hashq-set! heap-indexes binder + (1+ (hashq-ref heap-indexes binder -1)))) + + (define (allocate! x level n) + (define (step y) (allocate! y level n)) + (record-case x + (( proc args) + (step proc) (for-each step args)) + + (( test then else) + (step test) (step then) (step else)) + + (( name gensym exp) + (step exp)) + + (( mod name public? exp) + (step exp)) + + (( name exp) + (step exp)) + + (( name exp) + (step exp)) + + (( exps) + (for-each step exps)) + + (( vars meta body) + (let lp ((vars vars) (n 0)) + (if (null? vars) + (allocate! body (1+ level) n) + (let ((v (if (pair? vars) (car vars) vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap (1+ level) (allocate-heap! binder)) + (cons 'stack n)))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))) + + (( vars vals exp) + (for-each step vals) + (let lp ((vars vars) (n n)) + (if (null? vars) + (allocate! exp level n) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n)))) + (lp (cdr vars) (1+ n)))))) + + (( vars vals exp) + (let lp ((vars vars) (n n)) + (if (null? vars) + (begin + (for-each (lambda (x) (allocate! x level n)) + vals) + (allocate! exp level n)) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n)))) + (lp (cdr vars) (1+ n)))))) + + (else #f))) + + (define parents (make-hash-table)) + (define bindings (make-hash-table)) + (define heaps (make-hash-table)) + (define allocation (make-hash-table)) + (define heap-indexes (make-hash-table)) + + (hashq-set! bindings #f '()) + (analyze! x #f 0) + (allocate! x 0 0) + + allocation) + (define (compile-glil x e opts) - (values (codegen x) - (and e (cons (car e) (cddr e))) - e)) + (let ((x (optimize! x e opts))) + (let ((allocation (analyze-lexicals x))) + (values (codegen (make-lambda (tree-il-src x) '() '() x) + allocation) + (and e (cons (car e) (cddr e))) + e)))) @@ -57,226 +240,230 @@ (eq? (ghil-var-kind var) 'public))) (else (error "Unknown kind of variable:" var)))) -(define (codegen ghil) - (let ((stack '())) - (define (push-code! src code) - (set! stack (cons code stack)) - (if src (set! stack (cons (make-glil-source src) stack)))) - (define (var->binding var) - (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) - (define (push-bindings! src vars) - (if (not (null? vars)) - (push-code! src (make-glil-bind (map var->binding vars))))) - (define (comp tree tail drop) - (define (push-label! label) - (push-code! #f (make-glil-label label))) - (define (push-branch! src inst label) - (push-code! src (make-glil-branch inst label))) - (define (push-call! src inst args) - (for-each comp-push args) - (push-code! src (make-glil-call inst (length args)))) - ;; possible tail position - (define (comp-tail tree) (comp tree tail drop)) - ;; push the result - (define (comp-push tree) (comp tree #f #f)) - ;; drop the result - (define (comp-drop tree) (comp tree #f #t)) - ;; drop the result if unnecessary - (define (maybe-drop) - (if drop (push-code! #f *ia-drop*))) - ;; return here if necessary - (define (maybe-return) - (if tail (push-code! #f *ia-return*))) - ;; return this code if necessary - (define (return-code! src code) - (if (not drop) (push-code! src code)) - (maybe-return)) - ;; return void if necessary - (define (return-void!) - (return-code! #f *ia-void*)) - ;; return object if necessary - (define (return-object! src obj) - (return-code! src (make-glil-const obj))) - ;; - ;; dispatch - (record-case tree - (() - (return-void!)) - - (( env src obj) - (return-object! src obj)) - - (( env src var) - (return-code! src (make-glil-var 'ref env var))) - - (( env src var val) - (comp-push val) - (push-code! src (make-glil-var 'set env var)) - (return-void!)) - - (( src name exp) - (comp-push exp) - (push-code! src (make-glil-var 'define env var)) - (return-void!)) - - (( src test then else) - ;; TEST - ;; (br-if-not L1) - ;; THEN - ;; (br L2) - ;; L1: ELSE - ;; L2: - (let ((L1 (make-label)) (L2 (make-label))) - (comp-push test) - (push-branch! src 'br-if-not L1) - (comp-tail then) - (if (not tail) (push-branch! #f 'br L2)) - (push-label! L1) - (comp-tail else) - (if (not tail) (push-label! L2)))) - - (( src exps) - ;; EXPS... - ;; TAIL - (if (null? exps) - (return-void!) - (do ((exps exps (cdr exps))) - ((null? (cdr exps)) - (comp-tail (car exps))) - (comp-drop (car exps))))) - - (( src vars vals body) - ;; VALS... - ;; (set VARS)... - ;; BODY - (for-each comp-push vals) - (push-bindings! src vars) - (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) - (reverse vars)) - (comp-tail body) - (push-code! #f (make-glil-unbind))) - - (( env src producer vars rest body) - ;; VALS... - ;; (set VARS)... - ;; BODY - (let ((MV (make-label))) - (comp-push producer) - (push-code! src (make-glil-mv-call 0 MV)) - (push-code! #f (make-glil-const 1)) - (push-label! MV) - (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) - (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) - (reverse vars))) - (comp-tail body) - (push-code! #f (make-glil-unbind))) - - (( env src vars rest meta body) - (return-code! src (codegen tree))) - - (( env src inline args) - ;; ARGS... - ;; (INST NARGS) - (let ((tail-table '((call . goto/args) - (apply . goto/apply) - (call/cc . goto/cc)))) - (cond ((and tail (assq-ref tail-table inline)) - => (lambda (tail-inst) - (push-call! src tail-inst args))) - (else - (push-call! src inline args) - (maybe-drop) - (maybe-return))))) - - (( env src values) - (cond (tail ;; (lambda () (values 1 2)) - (push-call! src 'return/values values)) - (drop ;; (lambda () (values 1 2) 3) - (for-each comp-drop values)) - (else ;; (lambda () (list (values 10 12) 1)) - (push-code! #f (make-glil-const 'values)) - (push-code! #f (make-glil-call 'link-now 1)) - (push-code! #f (make-glil-call 'variable-ref 0)) - (push-call! src 'call values)))) - - (( env src values) - (cond (tail ;; (lambda () (apply values '(1 2))) - (push-call! src 'return/values* values)) - (drop ;; (lambda () (apply values '(1 2)) 3) - (for-each comp-drop values)) - (else ;; (lambda () (list (apply values '(10 12)) 1)) - (push-code! #f (make-glil-const 'values)) - (push-code! #f (make-glil-call 'link-now 1)) - (push-code! #f (make-glil-call 'variable-ref 0)) - (push-call! src 'apply values)))) - - (( env src proc args) - ;; PROC - ;; ARGS... - ;; ([tail-]call NARGS) - (comp-push proc) - (let ((nargs (length args))) - (cond ((< nargs 255) - (push-call! src (if tail 'goto/args 'call) args)) - (else - (push-call! src 'mark '()) - (for-each comp-push args) - (push-call! src 'list-mark '()) - (push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2))))) - (maybe-drop)) - - (( env src producer consumer) - ;; CONSUMER - ;; PRODUCER - ;; (mv-call MV) - ;; ([tail]-call 1) - ;; goto POST - ;; MV: [tail-]call/nargs - ;; POST: (maybe-drop) - (let ((MV (make-label)) (POST (make-label))) - (comp-push consumer) - (comp-push producer) - (push-code! src (make-glil-mv-call 0 MV)) - (push-code! src (make-glil-call (if tail 'goto/args 'call) 1)) - (cond ((not tail) - (push-branch! #f 'br POST))) - (push-label! MV) - (push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) - (cond ((not tail) - (push-label! POST) - (maybe-drop))))) - - (( env src) - (return-object! src (ghil-env-reify env))))) +(define (codegen x) + (define stack '()) + (define (push-code! src code) + (set! stack (cons code stack)) + (if src (set! stack (cons (make-glil-source src) stack)))) + (define (var->binding var) + (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) + (define (push-bindings! src vars) + (if (not (null? vars)) + (push-code! src (make-glil-bind (map var->binding vars))))) + (define (comp tree tail drop) + (define (push-label! label) + (push-code! #f (make-glil-label label))) + (define (push-branch! src inst label) + (push-code! src (make-glil-branch inst label))) + (define (push-call! src inst args) + (for-each comp-push args) + (push-code! src (make-glil-call inst (length args)))) + ;; possible tail position + (define (comp-tail tree) (comp tree tail drop)) + ;; push the result + (define (comp-push tree) (comp tree #f #f)) + ;; drop the result + (define (comp-drop tree) (comp tree #f #t)) + ;; drop the result if unnecessary + (define (maybe-drop) + (if drop (push-code! #f *ia-drop*))) + ;; return here if necessary + (define (maybe-return) + (if tail (push-code! #f *ia-return*))) + ;; return this code if necessary + (define (return-code! src code) + (if (not drop) (push-code! src code)) + (maybe-return)) + ;; return void if necessary + (define (return-void!) + (return-code! #f *ia-void*)) + ;; return object if necessary + (define (return-object! src obj) + (return-code! src (make-glil-const obj))) ;; - ;; main - (record-case ghil + ;; dispatch + (record-case tree + (() + (return-void!)) + + (( env src obj) + (return-object! src obj)) + + (( env src var) + (return-code! src (make-glil-var 'ref env var))) + + (( env src var val) + (comp-push val) + (push-code! src (make-glil-var 'set env var)) + (return-void!)) + + (( src name exp) + (comp-push exp) + (push-code! src (make-glil-var 'define env var)) + (return-void!)) + + (( src test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (push-branch! src 'br-if-not L1) + (comp-tail then) + (if (not tail) (push-branch! #f 'br L2)) + (push-label! L1) + (comp-tail else) + (if (not tail) (push-label! L2)))) + + (( src exps) + ;; EXPS... + ;; TAIL + (if (null? exps) + (return-void!) + (do ((exps exps (cdr exps))) + ((null? (cdr exps)) + (comp-tail (car exps))) + (comp-drop (car exps))))) + + (( src vars vals body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (for-each comp-push vals) + (push-bindings! src vars) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars)) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + + (( env src producer vars rest body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (let ((MV (make-label))) + (comp-push producer) + (push-code! src (make-glil-mv-call 0 MV)) + (push-code! #f (make-glil-const 1)) + (push-label! MV) + (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars))) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + (( env src vars rest meta body) - (let* ((evars (ghil-env-variables env)) - (srcs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) - (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) - (nargs (allocate-indices-linearly! vars)) - (nlocs (allocate-locals! locs body)) - (nexts (allocate-indices-linearly! exts))) - ;; meta bindings - (push-bindings! #f vars) - ;; push on definition source location - (if src (set! stack (cons (make-glil-source src) stack))) - ;; copy args to the heap if they're marked as external - (do ((n 0 (1+ n)) - (l vars (cdr l))) - ((null? l)) - (let ((v (car l))) - (case (ghil-var-kind v) - ((external) - (push-code! #f (make-glil-argument 'ref n)) - (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) - ;; compile body - (comp body #t #f) - ;; create GLIL - (make-glil-program nargs (if rest 1 0) nlocs nexts meta - (reverse! stack))))))) + (return-code! src (codegen tree))) + + (( env src inline args) + ;; ARGS... + ;; (INST NARGS) + (let ((tail-table '((call . goto/args) + (apply . goto/apply) + (call/cc . goto/cc)))) + (cond ((and tail (assq-ref tail-table inline)) + => (lambda (tail-inst) + (push-call! src tail-inst args))) + (else + (push-call! src inline args) + (maybe-drop) + (maybe-return))))) + + (( env src values) + (cond (tail ;; (lambda () (values 1 2)) + (push-call! src 'return/values values)) + (drop ;; (lambda () (values 1 2) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (values 10 12) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! src 'call values)))) + + (( env src values) + (cond (tail ;; (lambda () (apply values '(1 2))) + (push-call! src 'return/values* values)) + (drop ;; (lambda () (apply values '(1 2)) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (apply values '(10 12)) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! src 'apply values)))) + + (( env src proc args) + ;; PROC + ;; ARGS... + ;; ([tail-]call NARGS) + (comp-push proc) + (let ((nargs (length args))) + (cond ((< nargs 255) + (push-call! src (if tail 'goto/args 'call) args)) + (else + (push-call! src 'mark '()) + (for-each comp-push args) + (push-call! src 'list-mark '()) + (push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2))))) + (maybe-drop)) + + (( env src producer consumer) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label))) + (comp-push consumer) + (comp-push producer) + (push-code! src (make-glil-mv-call 0 MV)) + (push-code! src (make-glil-call (if tail 'goto/args 'call) 1)) + (cond ((not tail) + (push-branch! #f 'br POST))) + (push-label! MV) + (push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) + (cond ((not tail) + (push-label! POST) + (maybe-drop))))) + + (( env src) + (return-object! src (ghil-env-reify env))))) + + ;; + ;; main + ;; + + ;; analyze vars: partition into args, locs, exts, and assign indices + (record-case x + (( env src vars rest meta body) + (let* ((evars (ghil-env-variables env)) + (srcs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) + (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) + (nargs (allocate-indices-linearly! vars)) + (nlocs (allocate-locals! locs body)) + (nexts (allocate-indices-linearly! exts))) + ;; meta bindings + (push-bindings! #f vars) + ;; push on definition source location + (if src (set! stack (cons (make-glil-source src) stack))) + ;; copy args to the heap if they're marked as external + (do ((n 0 (1+ n)) + (l vars (cdr l))) + ((null? l)) + (let ((v (car l))) + (case (ghil-var-kind v) + ((external) + (push-code! #f (make-glil-argument 'ref n)) + (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) + ;; compile body + (comp body #t #f) + ;; create GLIL + (make-glil-program nargs (if rest 1 0) nlocs nexts meta + (reverse! stack)))))) (define (allocate-indices-linearly! vars) (do ((n 0 (1+ n)) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 52baddb08..14460ebab 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -22,7 +22,14 @@ (define-module (language tree-il optimize) #:use-module (system base syntax) #:use-module (language tree-il) - #:export (resolve-primitives!)) + #:use-module (language tree-il inline) + #:export (optimize!)) + +(define (env-module e) + (if e (car e) (current-module))) + +(define (optimize! x env opts) + (expand-primitives! (resolve-primitives! x (env-module env)))) ;; Possible optimizations: ;; * constant folding, propagation From cf10678fe7014a67020c45ee02f2aabb44598adc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 15 May 2009 23:44:14 +0200 Subject: [PATCH 103/375] tree-il -> glil compiler works now, at least in initial tests * module/language/tree-il/analyze.scm: Break analyzer out into its own file. * module/language/tree-il/compile-glil.scm: Port the GHIL->GLIL compiler over to work on tree-il. Works, but still misses a number of important optimizations. * module/language/tree-il.scm: Add . Not used quite yet. * module/language/glil.scm: Remove , as it is the same as (minus an offset). * module/language/glil/compile-assembly.scm: * module/language/glil/decompile-assembly.scm: * module/language/ghil/compile-glil.scm: Adapt for * removal. * module/Makefile.am (TREE_IL_LANG_SOURCES): Reorder, and add analyze.scm. --- module/Makefile.am | 7 +- module/language/ghil/compile-glil.scm | 14 +- module/language/glil.scm | 7 - module/language/glil/compile-assembly.scm | 24 +- module/language/glil/decompile-assembly.scm | 8 +- module/language/tree-il.scm | 14 + module/language/tree-il/analyze.scm | 201 ++++++ module/language/tree-il/compile-glil.scm | 698 ++++++-------------- 8 files changed, 456 insertions(+), 517 deletions(-) create mode 100644 module/language/tree-il/analyze.scm diff --git a/module/Makefile.am b/module/Makefile.am index 36d670002..22a95626d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -72,10 +72,11 @@ SCHEME_LANG_SOURCES = \ language/scheme/inline.scm TREE_IL_LANG_SOURCES = \ - language/tree-il/spec.scm \ - language/tree-il/compile-glil.scm \ language/tree-il/inline.scm \ - language/tree-il/optimize.scm + language/tree-il/optimize.scm \ + language/tree-il/analyze.scm \ + language/tree-il/compile-glil.scm \ + language/tree-il/spec.scm GHIL_LANG_SOURCES = \ language/ghil/spec.scm language/ghil/compile-glil.scm diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm index c813319d6..02187be05 100644 --- a/module/language/ghil/compile-glil.scm +++ b/module/language/ghil/compile-glil.scm @@ -187,7 +187,7 @@ (define (make-glil-var op env var) (case (ghil-var-kind var) ((argument) - (make-glil-argument op (ghil-var-index var))) + (make-glil-local op (ghil-var-index var))) ((local) (make-glil-local op (ghil-var-index var))) ((external) @@ -217,7 +217,9 @@ (set! stack (cons code stack)) (if loc (set! stack (cons (make-glil-source loc) stack)))) (define (var->binding var) - (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) + (list (ghil-var-name var) (let ((kind (ghil-var-kind var))) + (case kind ((argument) 'local) (else kind))) + (ghil-var-index var))) (define (push-bindings! loc vars) (if (not (null? vars)) (push-code! loc (make-glil-bind (map var->binding vars))))) @@ -496,7 +498,7 @@ (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) (nargs (allocate-indices-linearly! vars)) - (nlocs (allocate-locals! locs body)) + (nlocs (allocate-locals! locs body nargs)) (nexts (allocate-indices-linearly! exts))) ;; meta bindings (push-bindings! #f vars) @@ -509,7 +511,7 @@ (let ((v (car l))) (case (ghil-var-kind v) ((external) - (push-code! #f (make-glil-argument 'ref n)) + (push-code! #f (make-glil-local 'ref n)) (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) ;; compile body (comp body #t #f) @@ -523,8 +525,8 @@ ((null? l) n) (let ((v (car l))) (set! (ghil-var-index v) n)))) -(define (allocate-locals! vars body) - (let ((free '()) (nlocs 0)) +(define (allocate-locals! vars body nargs) + (let ((free '()) (nlocs nargs)) (define (allocate! var) (cond ((pair? free) diff --git a/module/language/glil.scm b/module/language/glil.scm index 51e7efac4..625760eaa 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -44,9 +44,6 @@ make-glil-const glil-const? glil-const-obj - make-glil-argument glil-argument? - glil-argument-op glil-argument-index - make-glil-local glil-local? glil-local-op glil-local-index @@ -87,7 +84,6 @@ () ( obj) ;; Variables - ( op index) ( op index) ( op depth index) ( op name) @@ -125,7 +121,6 @@ ((source ,props) (make-glil-source props)) ((void) (make-glil-void)) ((const ,obj) (make-glil-const obj)) - ((argument ,op ,index) (make-glil-argument op index)) ((local ,op ,index) (make-glil-local op index)) ((external ,op ,depth ,index) (make-glil-external op depth index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) @@ -150,8 +145,6 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op index) - `(argument ,op ,index)) (( op index) `(local ,op ,index)) (( op depth index) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index ffac9dbfb..73b2cd132 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -83,16 +83,15 @@ (define (make-closed-binding open-binding start end) (make-binding (car open-binding) (cadr open-binding) (caddr open-binding) start end)) -(define (open-binding bindings vars nargs start) +(define (open-binding bindings vars start) (cons (acons start (map (lambda (v) (pmatch v - ((,name argument ,i) (make-open-binding name #f i)) - ((,name local ,i) (make-open-binding name #f (+ nargs i))) + ((,name local ,i) (make-open-binding name #f i)) ((,name external ,i) (make-open-binding name #t i)) - (else (error "unknown binding type" name type)))) + (else (error "unknown binding type" v)))) vars) (car bindings)) (cdr bindings))) @@ -129,13 +128,13 @@ (define (compile-assembly glil) (receive (code . _) - (glil->assembly glil 0 '() '(()) '() '() #f -1) + (glil->assembly glil '() '(()) '() '() #f -1) (car code))) (define (make-object-table objects) (and (not (null? objects)) (list->vector (cons #f objects)))) -(define (glil->assembly glil nargs nexts-stack bindings +(define (glil->assembly glil nexts-stack bindings source-alist label-alist object-alist addr) (define (emit-code x) (values (map assembly-pack x) bindings source-alist label-alist object-alist)) @@ -159,7 +158,7 @@ addr)) (else (receive (subcode bindings source-alist label-alist object-alist) - (glil->assembly (car body) nargs nexts-stack bindings + (glil->assembly (car body) nexts-stack bindings source-alist label-alist object-alist addr) (lp (cdr body) (append (reverse subcode) code) bindings source-alist label-alist object-alist @@ -196,14 +195,14 @@ (( vars) (values '() - (open-binding bindings vars nargs addr) + (open-binding bindings vars addr) source-alist label-alist object-alist)) (( vars rest) (values `((truncate-values ,(length vars) ,(if rest 1 0))) - (open-binding bindings vars nargs addr) + (open-binding bindings vars addr) source-alist label-alist object-alist)) @@ -238,16 +237,11 @@ (emit-code/object `((object-ref ,i)) object-alist))))) - (( op index) + (( op index) (emit-code (if (eq? op 'ref) `((local-ref ,index)) `((local-set ,index))))) - (( op index) - (emit-code (if (eq? op 'ref) - `((local-ref ,(+ nargs index))) - `((local-set ,(+ nargs index)))))) - (( op depth index) (emit-code (let lp ((d depth) (n 0) (stack nexts-stack)) (if (> d 0) diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index a98c39975..a47bd80b2 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@ -175,15 +175,11 @@ (1+ pos))) ((local-ref ,n) (lp (cdr in) (cons *placeholder* stack) - (cons (if (< n nargs) - (make-glil-argument 'ref n) - (make-glil-local 'ref (- n nargs))) + (cons (make-glil-local 'ref n) out) (+ pos 2))) ((local-set ,n) (lp (cdr in) (cdr stack) - (cons (if (< n nargs) - (make-glil-argument 'set n) - (make-glil-local 'set (- n nargs))) + (cons (make-glil-local 'set n) (emit-constants (list-head stack 1) out)) (+ pos 2))) ((br-if-not ,l) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 774ca2ca7..c9857ac14 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -24,6 +24,7 @@ make-lexical lexical-name lexical-gensym + void? make-void void-src application? make-application application-src application-proc application-args conditional? make-conditional conditional-src conditional-test conditional-then conditional-else primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name @@ -48,6 +49,7 @@ pre-order!)) (define-type ( #:common-slots (src)) + () ( proc args) ( test then else) ( name) @@ -85,6 +87,9 @@ (let ((loc (location exp)) (retrans (lambda (x) (parse-ghil env x)))) (pmatch exp + ((void) + (make-void loc)) + ((apply ,proc ,args) (make-application loc (retrans proc) (retrans args))) @@ -147,6 +152,9 @@ (define (unparse-tree-il tree-il) (record-case tree-il + (() + '(void)) + (( proc args) `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args))) @@ -200,6 +208,9 @@ (tree-il->scheme (cdr e)))) ((record? e) (record-case e + (() + '(if #f #f)) + (( proc args) `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) @@ -253,6 +264,9 @@ (define (post-order! f x) (let lp ((x x)) (record-case x + (() + (or (f x) x)) + (( proc args) (set! (application-proc x) (lp proc)) (set! (application-args x) (map lp args)) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm new file mode 100644 index 000000000..fdcd190b4 --- /dev/null +++ b/module/language/tree-il/analyze.scm @@ -0,0 +1,201 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il analyze) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (analyze-lexicals)) + +;; allocation: the process of assigning a type and index to each var +;; a var is external if it is heaps; assigning index is easy +;; args are assigned in order +;; locals are indexed as their linear position in the binding path +;; (let (0 1) +;; (let (2 3) ...) +;; (let (2) ...)) +;; (let (2 3 4) ...)) +;; etc. +;; +;; allocation: +;; sym -> (local . index) | (heap level . index) +;; lambda -> (nlocs . nexts) + +(define (analyze-lexicals x) + ;; parents: lambda -> parent + ;; useful when we see a closed-over var, so we can calculate its + ;; coordinates (depth and index). + ;; bindings: lambda -> (sym ...) + ;; useful for two reasons: one, so we know how much space to allocate + ;; when we go into a lambda; and two, so that we know when to stop, + ;; when looking for closed-over vars. + ;; heaps: sym -> lambda + ;; allows us to heapify vars in an O(1) fashion + + (define (find-heap sym parent) + ;; fixme: check displaced lexicals here? + (if (memq sym (hashq-ref bindings parent)) + parent + (find-heap sym (hashq-ref parents parent)))) + + (define (analyze! x parent level) + (define (step y) (analyze! y parent level)) + (define (recur x parent) (analyze! x parent (1+ level))) + (record-case x + (( proc args) + (step proc) (for-each step args)) + + (( test then else) + (step test) (step then) (step else)) + + (( name gensym) + (if (and (not (memq gensym (hashq-ref bindings parent))) + (not (hashq-ref heaps gensym))) + (hashq-set! heaps gensym (find-heap gensym parent)))) + + (( name gensym exp) + (step exp) + (if (not (hashq-ref heaps gensym)) + (hashq-set! heaps gensym (find-heap gensym parent)))) + + (( mod name public? exp) + (step exp)) + + (( name exp) + (step exp)) + + (( name exp) + (step exp)) + + (( exps) + (for-each step exps)) + + (( vars meta body) + (hashq-set! parents x parent) + (hashq-set! bindings x + (let rev* ((vars vars) (out '())) + (cond ((null? vars) out) + ((pair? vars) (rev* (cdr vars) + (cons (car vars) out))) + (else (cons vars out))))) + (recur body x) + (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) + + (( vars vals exp) + (for-each step vals) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (step exp)) + + (( vars vals exp) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (for-each step vals) + (step exp)) + + (else #f))) + + (define (allocate-heap! binder) + (hashq-set! heap-indexes binder + (1+ (hashq-ref heap-indexes binder -1)))) + + (define (allocate! x level n) + (define (recur y) (allocate! y level n)) + (record-case x + (( proc args) + (apply max (recur proc) (map recur args))) + + (( test then else) + (max (recur test) (recur then) (recur else))) + + (( name gensym exp) + (recur exp)) + + (( mod name public? exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( exps) + (apply max (map recur exps))) + + (( vars meta body) + (let lp ((vars vars) (n 0)) + (if (null? vars) + (hashq-set! allocation x + (let ((nlocs (allocate! body (1+ level) n))) + (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) + (let ((v (if (pair? vars) (car vars) vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap (1+ level) (allocate-heap! binder)) + (cons 'stack n)))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))))) + n) + + (( vars vals exp) + (let ((nmax (apply max (map recur vals)))) + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! exp level n)) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n)))) + (lp (cdr vars) (1+ n))))))) + + (( vars vals exp) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x level n)) + vals)))) + (max nmax (allocate! exp level n))) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n)))) + (lp (cdr vars) (1+ n)))))) + + (else n))) + + (define parents (make-hash-table)) + (define bindings (make-hash-table)) + (define heaps (make-hash-table)) + (define allocation (make-hash-table)) + (define heap-indexes (make-hash-table)) + + (analyze! x #f -1) + (allocate! x -1 0) + + allocation) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index f54da31f0..2b2410051 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -21,287 +21,123 @@ (define-module (language tree-il compile-glil) #:use-module (system base syntax) + #:use-module (ice-9 receive) #:use-module (language glil) #:use-module (language tree-il) #:use-module (language tree-il optimize) - #:use-module (ice-9 common-list) + #:use-module (language tree-il analyze) #:export (compile-glil)) -;; parents: lambda -> parent -;; useful when we see a closed-over var, so we can calculate its -;; coordinates (depth and index). -;; bindings: lambda -> (sym ...) -;; useful for two reasons: one, so we know how much space to allocate -;; when we go into a lambda; and two, so that we know when to stop, -;; when looking for closed-over vars. -;; heaps: sym -> lambda -;; allows us to heapify vars in an O(1) fashion - -;; allocation: the process of assigning a type and index to each var -;; a var is external if it is heaps; assigning index is easy -;; args are assigned in order -;; locals are indexed as their linear position in the binding path -;; (let (0 1) -;; (let (2 3) ...) -;; (let (2) ...)) -;; (let (2 3 4) ...)) -;; etc. - ;; allocation: ;; sym -> (local . index) | (heap level . index) - - -(define (analyze-lexicals x) - (define (find-diff parent this) - (let lp ((parent parent) (n 0)) - (if (eq? parent this) - n - (lp (hashq-ref parents parent) (1+ n))))) - - (define (find-heap sym parent) - ;; fixme: check displaced lexicals here? - (if (memq sym (hashq-ref bindings parent)) - parent - (find-binder sym (hashq-ref parents parent)))) - - (define (analyze! x parent level) - (define (step y) (analyze! y parent level)) - (define (recur x parent) (analyze! x parent (1+ level))) - (record-case x - (( proc args) - (step proc) (for-each step args)) - - (( test then else) - (step test) (step then) (step else)) - - (( name gensym) - (if (and (not (memq gensym (hashq-ref bindings parent))) - (not (hashq-ref heaps gensym))) - (hashq-set! heaps gensym (find-heap gensym parent level)))) - - (( name gensym exp) - (step exp) - (if (not (hashq-ref heaps gensym)) - (hashq-set! heaps gensym (find-heap gensym parent level)))) - - (( mod name public? exp) - (step exp)) - - (( name exp) - (step exp)) - - (( name exp) - (step exp)) - - (( exps) - (for-each step exps)) - - (( vars meta body) - (hashq-set! parents x parent) - (hashq-set! bindings x - (let rev* ((vars vars) (out '())) - (cond ((null? vars) out) - ((pair? vars) (rev* (cdr vars) - (cons (car vars) out))) - (else (cons vars out))))) - (recur body x) - (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) - - (( vars vals exp) - (for-each step vals) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (step exp)) - - (( vars vals exp) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (for-each step vals) - (step exp)) - - (else #f))) - - (define (allocate-heap! binder) - (hashq-set! heap-indexes binder - (1+ (hashq-ref heap-indexes binder -1)))) - - (define (allocate! x level n) - (define (step y) (allocate! y level n)) - (record-case x - (( proc args) - (step proc) (for-each step args)) - - (( test then else) - (step test) (step then) (step else)) - - (( name gensym exp) - (step exp)) - - (( mod name public? exp) - (step exp)) - - (( name exp) - (step exp)) - - (( name exp) - (step exp)) - - (( exps) - (for-each step exps)) - - (( vars meta body) - (let lp ((vars vars) (n 0)) - (if (null? vars) - (allocate! body (1+ level) n) - (let ((v (if (pair? vars) (car vars) vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap (1+ level) (allocate-heap! binder)) - (cons 'stack n)))) - (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))) - - (( vars vals exp) - (for-each step vals) - (let lp ((vars vars) (n n)) - (if (null? vars) - (allocate! exp level n) - (let ((v (car vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n)))) - (lp (cdr vars) (1+ n)))))) - - (( vars vals exp) - (let lp ((vars vars) (n n)) - (if (null? vars) - (begin - (for-each (lambda (x) (allocate! x level n)) - vals) - (allocate! exp level n)) - (let ((v (car vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n)))) - (lp (cdr vars) (1+ n)))))) - - (else #f))) - - (define parents (make-hash-table)) - (define bindings (make-hash-table)) - (define heaps (make-hash-table)) - (define allocation (make-hash-table)) - (define heap-indexes (make-hash-table)) - - (hashq-set! bindings #f '()) - (analyze! x #f 0) - (allocate! x 0 0) - - allocation) +;; lambda -> (nlocs . nexts) (define (compile-glil x e opts) - (let ((x (optimize! x e opts))) - (let ((allocation (analyze-lexicals x))) - (values (codegen (make-lambda (tree-il-src x) '() '() x) - allocation) - (and e (cons (car e) (cddr e))) - e)))) + (let* ((x (make-lambda (tree-il-src x) '() '() x)) + (x (optimize! x e opts)) + (allocation (analyze-lexicals x))) + (values (flatten-lambda x -1 allocation) + (and e (cons (car e) (cddr e))) + e))) -(define *ia-void* (make-glil-void)) -(define *ia-drop* (make-glil-call 'drop 1)) -(define *ia-return* (make-glil-call 'return 1)) - (define (make-label) (gensym ":L")) -(define (make-glil-var op env var) - (case (ghil-var-kind var) - ((argument) - (make-glil-argument op (ghil-var-index var))) - ((local) - (make-glil-local op (ghil-var-index var))) - ((external) - (do ((depth 0 (1+ depth)) - (e env (ghil-env-parent e))) - ((eq? e (ghil-var-env var)) - (make-glil-external op depth (ghil-var-index var))))) - ((toplevel) - (make-glil-toplevel op (ghil-var-name var))) - ((public private) - (make-glil-module op (ghil-var-env var) (ghil-var-name var) - (eq? (ghil-var-kind var) 'public))) - (else (error "Unknown kind of variable:" var)))) +(define (vars->bind-list vars allocation) + (map (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) (list v 'local (cdr loc))) + ((heap) (list v 'external (cddr loc))) + (else (error "badness" v loc))))) + vars)) +(define (emit-bindings src vars allocation emit-code) + (if (pair? vars) + (emit-code src (make-glil-bind (vars->bind-list vars allocation))))) -(define (codegen x) - (define stack '()) - (define (push-code! src code) - (set! stack (cons code stack)) - (if src (set! stack (cons (make-glil-source src) stack)))) - (define (var->binding var) - (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) - (define (push-bindings! src vars) - (if (not (null? vars)) - (push-code! src (make-glil-bind (map var->binding vars))))) - (define (comp tree tail drop) - (define (push-label! label) - (push-code! #f (make-glil-label label))) - (define (push-branch! src inst label) - (push-code! src (make-glil-branch inst label))) - (define (push-call! src inst args) - (for-each comp-push args) - (push-code! src (make-glil-call inst (length args)))) - ;; possible tail position - (define (comp-tail tree) (comp tree tail drop)) - ;; push the result - (define (comp-push tree) (comp tree #f #f)) - ;; drop the result - (define (comp-drop tree) (comp tree #f #t)) - ;; drop the result if unnecessary - (define (maybe-drop) - (if drop (push-code! #f *ia-drop*))) - ;; return here if necessary - (define (maybe-return) - (if tail (push-code! #f *ia-return*))) - ;; return this code if necessary - (define (return-code! src code) - (if (not drop) (push-code! src code)) - (maybe-return)) - ;; return void if necessary - (define (return-void!) - (return-code! #f *ia-void*)) - ;; return object if necessary - (define (return-object! src obj) - (return-code! src (make-glil-const obj))) - ;; - ;; dispatch - (record-case tree - (() - (return-void!)) +(define (with-output-to-code proc) + (let ((out '())) + (define (emit-code src x) + (set! out (cons x out)) + (if src + (set! out (cons (make-glil-source src) out)))) + (proc emit-code) + (reverse out))) - (( env src obj) - (return-object! src obj)) +(define (flatten-lambda x level allocation) + (receive (vars nargs nrest) + (let lp ((vars (lambda-vars x)) (out '()) (n 0)) + (cond ((null? vars) (values (reverse out) n 0)) + ((pair? vars) (lp (cdr vars) (cons (car vars) out) (1+ n))) + (else (values (reverse (cons vars out)) (1+ n) 1)))) + (let ((nlocs (car (hashq-ref allocation x))) + (nexts (cdr (hashq-ref allocation x)))) + (make-glil-program + nargs nrest nlocs nexts (lambda-meta x) + (with-output-to-code + (lambda (emit-code) + ;; write bindings and source debugging info + (emit-bindings #f vars allocation emit-code) + (if (lambda-src x) + (emit-code (make-glil-src (lambda-src x)))) - (( env src var) - (return-code! src (make-glil-var 'ref env var))) + ;; copy args to the heap if necessary + (let lp ((in vars) (n 0)) + (if (not (null? in)) + (let ((loc (hashq-ref allocation (car vars)))) + (case (car loc) + ((heap) + (emit-code (make-glil-argument 'ref n)) + (emit-code (make-glil-external 'set 0 (cddr loc))))) + (lp (cdr in) (1+ n))))) - (( env src var val) - (comp-push val) - (push-code! src (make-glil-var 'set env var)) - (return-void!)) + ;; and here, here, dear reader: we compile. + (flatten (lambda-body x) (1+ level) allocation emit-code))))))) - (( src name exp) - (comp-push exp) - (push-code! src (make-glil-var 'define env var)) - (return-void!)) +(define (flatten x level allocation emit-code) + (define (emit-label label) + (emit-code #f (make-glil-label label))) + (define (emit-branch src inst label) + (emit-code src (make-glil-branch inst label))) + + (let comp ((x x) (context 'tail)) + (define (comp-tail tree) (comp tree context)) + (define (comp-push tree) (comp tree 'push)) + (define (comp-drop tree) (comp tree 'drop)) + + (record-case x + (() + (case context + ((push) (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src exp) + (case context + ((push) (emit-code src (make-glil-const exp))) + ((tail) + (emit-code src (make-glil-const exp)) + (emit-code #f (make-glil-call 'return 1))))) + + ;; FIXME: should represent sequence as exps tail + (( src exps) + (let lp ((exps exps)) + (if (null? (cdr exps)) + (comp-tail (car exps)) + (begin + (comp-drop (car exps)) + (lp (cdr exps)))))) + + (( src proc args) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call (case context + ((tail) 'goto/args) + (else 'call)) + (length args)))) (( src test then else) ;; TEST @@ -312,228 +148,130 @@ ;; L2: (let ((L1 (make-label)) (L2 (make-label))) (comp-push test) - (push-branch! src 'br-if-not L1) + (emit-branch src 'br-if-not L1) (comp-tail then) - (if (not tail) (push-branch! #f 'br L2)) - (push-label! L1) + (if (not (eq? context 'tail)) + (emit-branch #f 'br L2)) + (emit-label L1) (comp-tail else) - (if (not tail) (push-label! L2)))) + (if (not (eq? context 'tail)) + (emit-label L2)))) - (( src exps) - ;; EXPS... - ;; TAIL - (if (null? exps) - (return-void!) - (do ((exps exps (cdr exps))) - ((null? (cdr exps)) - (comp-tail (car exps))) - (comp-drop (car exps))))) + (( src name) + (case context + ((push) + (emit-code src (make-glil-module 'ref '(guile) name #f))) + ((tail) + (emit-code src (make-glil-module 'ref '(guile) name #f)) + (emit-code #f (make-glil-call 'return 1))))) - (( src vars vals body) - ;; VALS... - ;; (set VARS)... - ;; BODY + (( src name gensym) + (case context + ((push tail) + (let ((loc (hashq-ref allocation gensym))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'ref (cdr loc)))) + ((heap) + (emit-code src (make-glil-external + 'ref (- level (cadr loc)) (cddr loc)))) + (else (error "badness" x loc))) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))))) + + (( src name gensym exp) + (comp-push exp) + (let ((loc (hashq-ref allocation gensym))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external + 'set (- level (cadr loc)) (cddr loc)))) + (else (error "badness" x loc)))) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src mod name public?) + (emit-code src (make-glil-module 'ref mod name public?)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1))) + ((tail) (emit-code #f (make-glil-call 'return 1))))) + + (( src mod name public? exp) + (comp-push exp) + (emit-code src (make-glil-module 'set mod name public?)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src name) + (emit-code src (make-glil-toplevel 'ref name)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1))) + ((tail) (emit-code #f (make-glil-call 'return 1))))) + + (( src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'set name)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'define name)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (() + (case context + ((push) + (emit-code #f (flatten-lambda x level allocation))) + ((tail) + (emit-code #f (flatten-lambda x level allocation)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src vars vals exp) (for-each comp-push vals) - (push-bindings! src vars) - (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) - (reverse vars)) - (comp-tail body) - (push-code! #f (make-glil-unbind))) + (emit-bindings src vars allocation emit-code) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail exp) + (emit-code #f (make-glil-unbind))) - (( env src producer vars rest body) - ;; VALS... - ;; (set VARS)... - ;; BODY - (let ((MV (make-label))) - (comp-push producer) - (push-code! src (make-glil-mv-call 0 MV)) - (push-code! #f (make-glil-const 1)) - (push-label! MV) - (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) - (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) - (reverse vars))) - (comp-tail body) - (push-code! #f (make-glil-unbind))) - - (( env src vars rest meta body) - (return-code! src (codegen tree))) - - (( env src inline args) - ;; ARGS... - ;; (INST NARGS) - (let ((tail-table '((call . goto/args) - (apply . goto/apply) - (call/cc . goto/cc)))) - (cond ((and tail (assq-ref tail-table inline)) - => (lambda (tail-inst) - (push-call! src tail-inst args))) - (else - (push-call! src inline args) - (maybe-drop) - (maybe-return))))) - - (( env src values) - (cond (tail ;; (lambda () (values 1 2)) - (push-call! src 'return/values values)) - (drop ;; (lambda () (values 1 2) 3) - (for-each comp-drop values)) - (else ;; (lambda () (list (values 10 12) 1)) - (push-code! #f (make-glil-const 'values)) - (push-code! #f (make-glil-call 'link-now 1)) - (push-code! #f (make-glil-call 'variable-ref 0)) - (push-call! src 'call values)))) - - (( env src values) - (cond (tail ;; (lambda () (apply values '(1 2))) - (push-call! src 'return/values* values)) - (drop ;; (lambda () (apply values '(1 2)) 3) - (for-each comp-drop values)) - (else ;; (lambda () (list (apply values '(10 12)) 1)) - (push-code! #f (make-glil-const 'values)) - (push-code! #f (make-glil-call 'link-now 1)) - (push-code! #f (make-glil-call 'variable-ref 0)) - (push-call! src 'apply values)))) - - (( env src proc args) - ;; PROC - ;; ARGS... - ;; ([tail-]call NARGS) - (comp-push proc) - (let ((nargs (length args))) - (cond ((< nargs 255) - (push-call! src (if tail 'goto/args 'call) args)) - (else - (push-call! src 'mark '()) - (for-each comp-push args) - (push-call! src 'list-mark '()) - (push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2))))) - (maybe-drop)) - - (( env src producer consumer) - ;; CONSUMER - ;; PRODUCER - ;; (mv-call MV) - ;; ([tail]-call 1) - ;; goto POST - ;; MV: [tail-]call/nargs - ;; POST: (maybe-drop) - (let ((MV (make-label)) (POST (make-label))) - (comp-push consumer) - (comp-push producer) - (push-code! src (make-glil-mv-call 0 MV)) - (push-code! src (make-glil-call (if tail 'goto/args 'call) 1)) - (cond ((not tail) - (push-branch! #f 'br POST))) - (push-label! MV) - (push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) - (cond ((not tail) - (push-label! POST) - (maybe-drop))))) - - (( env src) - (return-object! src (ghil-env-reify env))))) - - ;; - ;; main - ;; - - ;; analyze vars: partition into args, locs, exts, and assign indices - (record-case x - (( env src vars rest meta body) - (let* ((evars (ghil-env-variables env)) - (srcs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) - (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) - (nargs (allocate-indices-linearly! vars)) - (nlocs (allocate-locals! locs body)) - (nexts (allocate-indices-linearly! exts))) - ;; meta bindings - (push-bindings! #f vars) - ;; push on definition source location - (if src (set! stack (cons (make-glil-source src) stack))) - ;; copy args to the heap if they're marked as external - (do ((n 0 (1+ n)) - (l vars (cdr l))) - ((null? l)) - (let ((v (car l))) - (case (ghil-var-kind v) - ((external) - (push-code! #f (make-glil-argument 'ref n)) - (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) - ;; compile body - (comp body #t #f) - ;; create GLIL - (make-glil-program nargs (if rest 1 0) nlocs nexts meta - (reverse! stack)))))) - -(define (allocate-indices-linearly! vars) - (do ((n 0 (1+ n)) - (l vars (cdr l))) - ((null? l) n) - (let ((v (car l))) (set! (ghil-var-index v) n)))) - -(define (allocate-locals! vars body) - (let ((free '()) (nlocs 0)) - (define (allocate! var) - (cond - ((pair? free) - (set! (ghil-var-index var) (car free)) - (set! free (cdr free))) - (else - (set! (ghil-var-index var) nlocs) - (set! nlocs (1+ nlocs))))) - (define (deallocate! var) - (set! free (cons (ghil-var-index var) free))) - (let lp ((x body)) - (record-case x - (()) - (()) - (( exp) - (let qlp ((x exp)) - (cond ((list? x) (for-each qlp x)) - ((pair? x) (qlp (car x)) (qlp (cdr x))) - ((record? x) - (record-case x - (( exp) (lp exp)) - (( exp) (lp exp))))))) - (( exp) - (lp exp)) - (( exp) - (lp exp)) - (()) - (( val) - (lp val)) - (()) - (( val) - (lp val)) - (( test then else) - (lp test) (lp then) (lp else)) - (( exps) - (for-each lp exps)) - (( exps) - (for-each lp exps)) - (( exps) - (for-each lp exps)) - (( vars vals body) - (for-each allocate! vars) - (for-each lp vals) - (lp body) - (for-each deallocate! vars)) - (( vars producer body) - (lp producer) - (for-each allocate! vars) - (lp body) - (for-each deallocate! vars)) - (( args) - (for-each lp args)) - (( proc args) - (lp proc) - (for-each lp args)) - (()) - (( producer consumer) - (lp producer) - (lp consumer)) - (( values) - (for-each lp values)) - (( values) - (for-each lp values)))) - nlocs)) + (( src vars vals exp) + (for-each comp-push vals) + (emit-bindings src vars allocation emit-code) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail exp) + (emit-code #f (make-glil-unbind)))))) From 547a602d1ef4d3622cf2d476ff311957b447eaba Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 May 2009 16:27:18 +0200 Subject: [PATCH 104/375] preserve original var names in lets and lambdas * module/ice-9/psyntax.scm (build-letrec, build-let, build-lambda) (build-named-let): Take extra args for the original names of the gensyms. Not used yet. Callers adapted. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 +++++++++--------- module/ice-9/psyntax.scm | 45 ++++++++++++++++++++++++------------- 2 files changed, 41 insertions(+), 26 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index dca1b30f6..f89d44756 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (letrec ((andmap58 (lambda (first59) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))))) (andmap58 first56)) (letrec ((andmap62 (lambda (first63 rest64) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68))))))) (andmap62 first56 rest55))))))) (letrec ((lambda-var-list160 (lambda (vars289) (letrec ((lvl290 (lambda (vars291 ls292 w293) (cond ((pair? vars291) (lvl290 (cdr vars291) (cons (wrap139 (car vars291) w293 #f) ls292) w293)) ((id?111 vars291) (cons (wrap139 vars291 w293 #f) ls292)) ((null? vars291) ls292) ((syntax-object?95 vars291) (lvl290 (syntax-object-expression96 vars291) ls292 (join-wraps130 w293 (syntax-object-wrap97 vars291)))) ((annotation? vars291) (lvl290 (annotation-expression vars291) ls292 w293)) (else (cons vars291 ls292)))))) (lvl290 vars289 (quote ()) (quote (())))))) (gen-var159 (lambda (id294) (let ((id295 (if (syntax-object?95 id294) (syntax-object-expression96 id294) id294))) (if (annotation? id295) (gensym (symbol->string (annotation-expression id295))) (gensym (symbol->string id295)))))) (strip158 (lambda (x296 w297) (if (memq (quote top) (wrap-marks114 w297)) (if (or (annotation? x296) (and (pair? x296) (annotation? (car x296)))) (strip-annotation157 x296 #f) x296) (letrec ((f298 (lambda (x299) (cond ((syntax-object?95 x299) (strip158 (syntax-object-expression96 x299) (syntax-object-wrap97 x299))) ((pair? x299) (let ((a300 (f298 (car x299))) (d301 (f298 (cdr x299)))) (if (and (eq? a300 (car x299)) (eq? d301 (cdr x299))) x299 (cons a300 d301)))) ((vector? x299) (let ((old302 (vector->list x299))) (let ((new303 (map f298 old302))) (if (and-map*17 eq? old302 new303) x299 (list->vector new303))))) (else x299))))) (f298 x296))))) (strip-annotation157 (lambda (x304 parent305) (cond ((pair? x304) (let ((new306 (cons #f #f))) (begin (if parent305 (set-annotation-stripped! parent305 new306)) (set-car! new306 (strip-annotation157 (car x304) #f)) (set-cdr! new306 (strip-annotation157 (cdr x304) #f)) new306))) ((annotation? x304) (or (annotation-stripped x304) (strip-annotation157 (annotation-expression x304) x304))) ((vector? x304) (let ((new307 (make-vector (vector-length x304)))) (begin (if parent305 (set-annotation-stripped! parent305 new307)) (letrec ((loop308 (lambda (i309) (unless (fx<74 i309 0) (vector-set! new307 i309 (strip-annotation157 (vector-ref x304 i309) #f)) (loop308 (fx-72 i309 1)))))) (loop308 (- (vector-length x304) 1))) new307))) (else x304)))) (ellipsis?156 (lambda (x310) (and (nonsymbol-id?110 x310) (free-id=?134 x310 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void155 (lambda () (build-application79 #f (build-primref88 #f (quote if)) (quote (#f #f))))) (eval-local-transformer154 (lambda (expanded311 mod312) (let ((p313 (local-eval-hook76 expanded311 mod312))) (if (procedure? p313) p313 (syntax-violation #f "nonprocedure transformer" p313))))) (chi-local-syntax153 (lambda (rec?314 e315 r316 w317 s318 mod319 k320) ((lambda (tmp321) ((lambda (tmp322) (if tmp322 (apply (lambda (_323 id324 val325 e1326 e2327) (let ((ids328 id324)) (if (not (valid-bound-ids?136 ids328)) (syntax-violation #f "duplicate bound keyword" e315) (let ((labels330 (gen-labels117 ids328))) (let ((new-w331 (make-binding-wrap128 ids328 labels330 w317))) (k320 (cons e1326 e2327) (extend-env105 labels330 (let ((w333 (if rec?314 new-w331 w317)) (trans-r334 (macros-only-env107 r316))) (map (lambda (x335) (cons (quote macro) (eval-local-transformer154 (chi147 x335 trans-r334 w333 mod319) mod319))) val325)) r316) new-w331 s318 mod319)))))) tmp322) ((lambda (_337) (syntax-violation #f "bad local syntax definition" (source-wrap140 e315 w317 s318 mod319))) tmp321))) ($sc-dispatch tmp321 (quote (any #(each (any any)) any . each-any))))) e315))) (chi-lambda-clause152 (lambda (e338 docstring339 c340 r341 w342 mod343 k344) ((lambda (tmp345) ((lambda (tmp346) (if (if tmp346 (apply (lambda (args347 doc348 e1349 e2350) (and (string? (syntax->datum doc348)) (not docstring339))) tmp346) #f) (apply (lambda (args351 doc352 e1353 e2354) (chi-lambda-clause152 e338 doc352 (cons args351 (cons e1353 e2354)) r341 w342 mod343 k344)) tmp346) ((lambda (tmp356) (if tmp356 (apply (lambda (id357 e1358 e2359) (let ((ids360 id357)) (if (not (valid-bound-ids?136 ids360)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels362 (gen-labels117 ids360)) (new-vars363 (map gen-var159 ids360))) (k344 new-vars363 docstring339 (chi-body151 (cons e1358 e2359) e338 (extend-var-env106 labels362 new-vars363 r341) (make-binding-wrap128 ids360 labels362 w342) mod343)))))) tmp356) ((lambda (tmp365) (if tmp365 (apply (lambda (ids366 e1367 e2368) (let ((old-ids369 (lambda-var-list160 ids366))) (if (not (valid-bound-ids?136 old-ids369)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels370 (gen-labels117 old-ids369)) (new-vars371 (map gen-var159 old-ids369))) (k344 (letrec ((f372 (lambda (ls1373 ls2374) (if (null? ls1373) ls2374 (f372 (cdr ls1373) (cons (car ls1373) ls2374)))))) (f372 (cdr new-vars371) (car new-vars371))) docstring339 (chi-body151 (cons e1367 e2368) e338 (extend-var-env106 labels370 new-vars371 r341) (make-binding-wrap128 old-ids369 labels370 w342) mod343)))))) tmp365) ((lambda (_376) (syntax-violation (quote lambda) "bad lambda" e338)) tmp345))) ($sc-dispatch tmp345 (quote (any any . each-any)))))) ($sc-dispatch tmp345 (quote (each-any any . each-any)))))) ($sc-dispatch tmp345 (quote (any any any . each-any))))) c340))) (chi-body151 (lambda (body377 outer-form378 r379 w380 mod381) (let ((r382 (cons (quote ("placeholder" placeholder)) r379))) (let ((ribcage383 (make-ribcage118 (quote ()) (quote ()) (quote ())))) (let ((w384 (make-wrap113 (wrap-marks114 w380) (cons ribcage383 (wrap-subst115 w380))))) (letrec ((parse385 (lambda (body386 ids387 labels388 vars389 vals390 bindings391) (if (null? body386) (syntax-violation #f "no expressions in body" outer-form378) (let ((e393 (cdar body386)) (er394 (caar body386))) (call-with-values (lambda () (syntax-type145 e393 er394 (quote (())) #f ribcage383 mod381)) (lambda (type395 value396 e397 w398 s399 mod400) (let ((t401 type395)) (if (memv t401 (quote (define-form))) (let ((id402 (wrap139 value396 w398 mod400)) (label403 (gen-label116))) (let ((var404 (gen-var159 id402))) (begin (extend-ribcage!127 ribcage383 id402 label403) (parse385 (cdr body386) (cons id402 ids387) (cons label403 labels388) (cons var404 vars389) (cons (cons er394 (wrap139 e397 w398 mod400)) vals390) (cons (cons (quote lexical) var404) bindings391))))) (if (memv t401 (quote (define-syntax-form))) (let ((id405 (wrap139 value396 w398 mod400)) (label406 (gen-label116))) (begin (extend-ribcage!127 ribcage383 id405 label406) (parse385 (cdr body386) (cons id405 ids387) (cons label406 labels388) vars389 vals390 (cons (cons (quote macro) (cons er394 (wrap139 e397 w398 mod400))) bindings391)))) (if (memv t401 (quote (begin-form))) ((lambda (tmp407) ((lambda (tmp408) (if tmp408 (apply (lambda (_409 e1410) (parse385 (letrec ((f411 (lambda (forms412) (if (null? forms412) (cdr body386) (cons (cons er394 (wrap139 (car forms412) w398 mod400)) (f411 (cdr forms412))))))) (f411 e1410)) ids387 labels388 vars389 vals390 bindings391)) tmp408) (syntax-violation #f "source expression failed to match any pattern" tmp407))) ($sc-dispatch tmp407 (quote (any . each-any))))) e397) (if (memv t401 (quote (local-syntax-form))) (chi-local-syntax153 value396 e397 er394 w398 s399 mod400 (lambda (forms414 er415 w416 s417 mod418) (parse385 (letrec ((f419 (lambda (forms420) (if (null? forms420) (cdr body386) (cons (cons er415 (wrap139 (car forms420) w416 mod418)) (f419 (cdr forms420))))))) (f419 forms414)) ids387 labels388 vars389 vals390 bindings391))) (if (null? ids387) (build-sequence90 #f (map (lambda (x421) (chi147 (cdr x421) (car x421) (quote (())) mod400)) (cons (cons er394 (source-wrap140 e397 w398 s399 mod400)) (cdr body386)))) (begin (if (not (valid-bound-ids?136 ids387)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form378)) (letrec ((loop422 (lambda (bs423 er-cache424 r-cache425) (if (not (null? bs423)) (let ((b426 (car bs423))) (if (eq? (car b426) (quote macro)) (let ((er427 (cadr b426))) (let ((r-cache428 (if (eq? er427 er-cache424) r-cache425 (macros-only-env107 er427)))) (begin (set-cdr! b426 (eval-local-transformer154 (chi147 (cddr b426) r-cache428 (quote (())) mod400) mod400)) (loop422 (cdr bs423) er427 r-cache428)))) (loop422 (cdr bs423) er-cache424 r-cache425))))))) (loop422 bindings391 #f #f)) (set-cdr! r382 (extend-env105 labels388 bindings391 (cdr r382))) (build-letrec93 #f vars389 (map (lambda (x429) (chi147 (cdr x429) (car x429) (quote (())) mod400)) vals390) (build-sequence90 #f (map (lambda (x430) (chi147 (cdr x430) (car x430) (quote (())) mod400)) (cons (cons er394 (source-wrap140 e397 w398 s399 mod400)) (cdr body386))))))))))))))))))) (parse385 (map (lambda (x392) (cons r382 (wrap139 x392 w384 mod381))) body377) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro150 (lambda (p431 e432 r433 w434 rib435 mod436) (letrec ((rebuild-macro-output437 (lambda (x438 m439) (cond ((pair? x438) (cons (rebuild-macro-output437 (car x438) m439) (rebuild-macro-output437 (cdr x438) m439))) ((syntax-object?95 x438) (let ((w440 (syntax-object-wrap97 x438))) (let ((ms441 (wrap-marks114 w440)) (s442 (wrap-subst115 w440))) (if (and (pair? ms441) (eq? (car ms441) #f)) (make-syntax-object94 (syntax-object-expression96 x438) (make-wrap113 (cdr ms441) (if rib435 (cons rib435 (cdr s442)) (cdr s442))) (syntax-object-module98 x438)) (make-syntax-object94 (syntax-object-expression96 x438) (make-wrap113 (cons m439 ms441) (if rib435 (cons rib435 (cons (quote shift) s442)) (cons (quote shift) s442))) (let ((pmod443 (procedure-module p431))) (if pmod443 (cons (quote hygiene) (module-name pmod443)) (quote (hygiene guile))))))))) ((vector? x438) (let ((n444 (vector-length x438))) (let ((v445 (make-vector n444))) (letrec ((doloop446 (lambda (i447) (if (fx=73 i447 n444) v445 (begin (vector-set! v445 i447 (rebuild-macro-output437 (vector-ref x438 i447) m439)) (doloop446 (fx+71 i447 1))))))) (doloop446 0))))) ((symbol? x438) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap140 e432 w434 s mod436) x438)) (else x438))))) (rebuild-macro-output437 (p431 (wrap139 e432 (anti-mark126 w434) mod436)) (string #\m))))) (chi-application149 (lambda (x448 e449 r450 w451 s452 mod453) ((lambda (tmp454) ((lambda (tmp455) (if tmp455 (apply (lambda (e0456 e1457) (build-application79 s452 x448 (map (lambda (e458) (chi147 e458 r450 w451 mod453)) e1457))) tmp455) (syntax-violation #f "source expression failed to match any pattern" tmp454))) ($sc-dispatch tmp454 (quote (any . each-any))))) e449))) (chi-expr148 (lambda (type460 value461 e462 r463 w464 s465 mod466) (let ((t467 type460)) (if (memv t467 (quote (lexical))) (build-lexical-reference81 (quote value) s465 e462 value461) (if (memv t467 (quote (core external-macro))) (value461 e462 r463 w464 s465 mod466) (if (memv t467 (quote (module-ref))) (call-with-values (lambda () (value461 e462)) (lambda (id468 mod469) (build-global-reference84 s465 id468 mod469))) (if (memv t467 (quote (lexical-call))) (chi-application149 (build-lexical-reference81 (quote fun) (source-annotation102 (car e462)) (car e462) value461) e462 r463 w464 s465 mod466) (if (memv t467 (quote (global-call))) (chi-application149 (build-global-reference84 (source-annotation102 (car e462)) value461 (if (syntax-object?95 (car e462)) (syntax-object-module98 (car e462)) mod466)) e462 r463 w464 s465 mod466) (if (memv t467 (quote (constant))) (build-data89 s465 (strip158 (source-wrap140 e462 w464 s465 mod466) (quote (())))) (if (memv t467 (quote (global))) (build-global-reference84 s465 value461 mod466) (if (memv t467 (quote (call))) (chi-application149 (chi147 (car e462) r463 w464 mod466) e462 r463 w464 s465 mod466) (if (memv t467 (quote (begin-form))) ((lambda (tmp470) ((lambda (tmp471) (if tmp471 (apply (lambda (_472 e1473 e2474) (chi-sequence141 (cons e1473 e2474) r463 w464 s465 mod466)) tmp471) (syntax-violation #f "source expression failed to match any pattern" tmp470))) ($sc-dispatch tmp470 (quote (any any . each-any))))) e462) (if (memv t467 (quote (local-syntax-form))) (chi-local-syntax153 value461 e462 r463 w464 s465 mod466 chi-sequence141) (if (memv t467 (quote (eval-when-form))) ((lambda (tmp476) ((lambda (tmp477) (if tmp477 (apply (lambda (_478 x479 e1480 e2481) (let ((when-list482 (chi-when-list144 e462 x479 w464))) (if (memq (quote eval) when-list482) (chi-sequence141 (cons e1480 e2481) r463 w464 s465 mod466) (chi-void155)))) tmp477) (syntax-violation #f "source expression failed to match any pattern" tmp476))) ($sc-dispatch tmp476 (quote (any each-any any . each-any))))) e462) (if (memv t467 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e462 (wrap139 value461 w464 mod466)) (if (memv t467 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap140 e462 w464 s465 mod466)) (if (memv t467 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap140 e462 w464 s465 mod466)) (syntax-violation #f "unexpected syntax" (source-wrap140 e462 w464 s465 mod466))))))))))))))))))) (chi147 (lambda (e485 r486 w487 mod488) (call-with-values (lambda () (syntax-type145 e485 r486 w487 #f #f mod488)) (lambda (type489 value490 e491 w492 s493 mod494) (chi-expr148 type489 value490 e491 r486 w492 s493 mod494))))) (chi-top146 (lambda (e495 r496 w497 m498 esew499 mod500) (call-with-values (lambda () (syntax-type145 e495 r496 w497 #f #f mod500)) (lambda (type508 value509 e510 w511 s512 mod513) (let ((t514 type508)) (if (memv t514 (quote (begin-form))) ((lambda (tmp515) ((lambda (tmp516) (if tmp516 (apply (lambda (_517) (chi-void155)) tmp516) ((lambda (tmp518) (if tmp518 (apply (lambda (_519 e1520 e2521) (chi-top-sequence142 (cons e1520 e2521) r496 w511 s512 m498 esew499 mod513)) tmp518) (syntax-violation #f "source expression failed to match any pattern" tmp515))) ($sc-dispatch tmp515 (quote (any any . each-any)))))) ($sc-dispatch tmp515 (quote (any))))) e510) (if (memv t514 (quote (local-syntax-form))) (chi-local-syntax153 value509 e510 r496 w511 s512 mod513 (lambda (body523 r524 w525 s526 mod527) (chi-top-sequence142 body523 r524 w525 s526 m498 esew499 mod527))) (if (memv t514 (quote (eval-when-form))) ((lambda (tmp528) ((lambda (tmp529) (if tmp529 (apply (lambda (_530 x531 e1532 e2533) (let ((when-list534 (chi-when-list144 e510 x531 w511)) (body535 (cons e1532 e2533))) (cond ((eq? m498 (quote e)) (if (memq (quote eval) when-list534) (chi-top-sequence142 body535 r496 w511 s512 (quote e) (quote (eval)) mod513) (chi-void155))) ((memq (quote load) when-list534) (if (or (memq (quote compile) when-list534) (and (eq? m498 (quote c&e)) (memq (quote eval) when-list534))) (chi-top-sequence142 body535 r496 w511 s512 (quote c&e) (quote (compile load)) mod513) (if (memq m498 (quote (c c&e))) (chi-top-sequence142 body535 r496 w511 s512 (quote c) (quote (load)) mod513) (chi-void155)))) ((or (memq (quote compile) when-list534) (and (eq? m498 (quote c&e)) (memq (quote eval) when-list534))) (top-level-eval-hook75 (chi-top-sequence142 body535 r496 w511 s512 (quote e) (quote (eval)) mod513) mod513) (chi-void155)) (else (chi-void155))))) tmp529) (syntax-violation #f "source expression failed to match any pattern" tmp528))) ($sc-dispatch tmp528 (quote (any each-any any . each-any))))) e510) (if (memv t514 (quote (define-syntax-form))) (let ((n538 (id-var-name133 value509 w511)) (r539 (macros-only-env107 r496))) (let ((t540 m498)) (if (memv t540 (quote (c))) (if (memq (quote compile) esew499) (let ((e541 (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)))) (begin (top-level-eval-hook75 e541 mod513) (if (memq (quote load) esew499) e541 (chi-void155)))) (if (memq (quote load) esew499) (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)) (chi-void155))) (if (memv t540 (quote (c&e))) (let ((e542 (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)))) (begin (top-level-eval-hook75 e542 mod513) e542)) (begin (if (memq (quote eval) esew499) (top-level-eval-hook75 (chi-install-global143 n538 (chi147 e510 r539 w511 mod513)) mod513)) (chi-void155)))))) (if (memv t514 (quote (define-form))) (let ((n543 (id-var-name133 value509 w511))) (let ((type544 (binding-type103 (lookup108 n543 r496 mod513)))) (let ((t545 type544)) (if (memv t545 (quote (global core macro module-ref))) (let ((x546 (build-global-definition86 s512 n543 (chi147 e510 r496 w511 mod513)))) (begin (if (eq? m498 (quote c&e)) (top-level-eval-hook75 x546 mod513)) x546)) (if (memv t545 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e510 (wrap139 value509 w511 mod513)) (syntax-violation #f "cannot define keyword at top level" e510 (wrap139 value509 w511 mod513))))))) (let ((x547 (chi-expr148 type508 value509 e510 r496 w511 s512 mod513))) (begin (if (eq? m498 (quote c&e)) (top-level-eval-hook75 x547 mod513)) x547)))))))))))) (syntax-type145 (lambda (e548 r549 w550 s551 rib552 mod553) (cond ((symbol? e548) (let ((n554 (id-var-name133 e548 w550))) (let ((b555 (lookup108 n554 r549 mod553))) (let ((type556 (binding-type103 b555))) (let ((t557 type556)) (if (memv t557 (quote (lexical))) (values type556 (binding-value104 b555) e548 w550 s551 mod553) (if (memv t557 (quote (global))) (values type556 n554 e548 w550 s551 mod553) (if (memv t557 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b555) e548 r549 w550 rib552 mod553) r549 (quote (())) s551 rib552 mod553) (values type556 (binding-value104 b555) e548 w550 s551 mod553))))))))) ((pair? e548) (let ((first558 (car e548))) (if (id?111 first558) (let ((n559 (id-var-name133 first558 w550))) (let ((b560 (lookup108 n559 r549 (or (and (syntax-object?95 first558) (syntax-object-module98 first558)) mod553)))) (let ((type561 (binding-type103 b560))) (let ((t562 type561)) (if (memv t562 (quote (lexical))) (values (quote lexical-call) (binding-value104 b560) e548 w550 s551 mod553) (if (memv t562 (quote (global))) (values (quote global-call) n559 e548 w550 s551 mod553) (if (memv t562 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b560) e548 r549 w550 rib552 mod553) r549 (quote (())) s551 rib552 mod553) (if (memv t562 (quote (core external-macro module-ref))) (values type561 (binding-value104 b560) e548 w550 s551 mod553) (if (memv t562 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value104 b560) e548 w550 s551 mod553) (if (memv t562 (quote (begin))) (values (quote begin-form) #f e548 w550 s551 mod553) (if (memv t562 (quote (eval-when))) (values (quote eval-when-form) #f e548 w550 s551 mod553) (if (memv t562 (quote (define))) ((lambda (tmp563) ((lambda (tmp564) (if (if tmp564 (apply (lambda (_565 name566 val567) (id?111 name566)) tmp564) #f) (apply (lambda (_568 name569 val570) (values (quote define-form) name569 val570 w550 s551 mod553)) tmp564) ((lambda (tmp571) (if (if tmp571 (apply (lambda (_572 name573 args574 e1575 e2576) (and (id?111 name573) (valid-bound-ids?136 (lambda-var-list160 args574)))) tmp571) #f) (apply (lambda (_577 name578 args579 e1580 e2581) (values (quote define-form) (wrap139 name578 w550 mod553) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap139 (cons args579 (cons e1580 e2581)) w550 mod553)) (quote (())) s551 mod553)) tmp571) ((lambda (tmp583) (if (if tmp583 (apply (lambda (_584 name585) (id?111 name585)) tmp583) #f) (apply (lambda (_586 name587) (values (quote define-form) (wrap139 name587 w550 mod553) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s551 mod553)) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp563))) ($sc-dispatch tmp563 (quote (any any)))))) ($sc-dispatch tmp563 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp563 (quote (any any any))))) e548) (if (memv t562 (quote (define-syntax))) ((lambda (tmp588) ((lambda (tmp589) (if (if tmp589 (apply (lambda (_590 name591 val592) (id?111 name591)) tmp589) #f) (apply (lambda (_593 name594 val595) (values (quote define-syntax-form) name594 val595 w550 s551 mod553)) tmp589) (syntax-violation #f "source expression failed to match any pattern" tmp588))) ($sc-dispatch tmp588 (quote (any any any))))) e548) (values (quote call) #f e548 w550 s551 mod553)))))))))))))) (values (quote call) #f e548 w550 s551 mod553)))) ((syntax-object?95 e548) (syntax-type145 (syntax-object-expression96 e548) r549 (join-wraps130 w550 (syntax-object-wrap97 e548)) #f rib552 (or (syntax-object-module98 e548) mod553))) ((annotation? e548) (syntax-type145 (annotation-expression e548) r549 w550 (annotation-source e548) rib552 mod553)) ((self-evaluating? e548) (values (quote constant) #f e548 w550 s551 mod553)) (else (values (quote other) #f e548 w550 s551 mod553))))) (chi-when-list144 (lambda (e596 when-list597 w598) (letrec ((f599 (lambda (when-list600 situations601) (if (null? when-list600) situations601 (f599 (cdr when-list600) (cons (let ((x602 (car when-list600))) (cond ((free-id=?134 x602 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?134 x602 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?134 x602 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e596 (wrap139 x602 w598 #f))))) situations601)))))) (f599 when-list597 (quote ()))))) (chi-install-global143 (lambda (name603 e604) (build-global-definition86 #f name603 (if (let ((v605 (module-variable (current-module) name603))) (and v605 (variable-bound? v605) (macro? (variable-ref v605)) (not (eq? (macro-type (variable-ref v605)) (quote syncase-macro))))) (build-application79 #f (build-primref88 #f (quote make-extended-syncase-macro)) (list (build-application79 #f (build-primref88 #f (quote module-ref)) (list (build-application79 #f (quote current-module) (quote ())) (build-data89 #f name603))) (build-data89 #f (quote macro)) e604)) (build-application79 #f (build-primref88 #f (quote make-syncase-macro)) (list (build-data89 #f (quote macro)) e604)))))) (chi-top-sequence142 (lambda (body606 r607 w608 s609 m610 esew611 mod612) (build-sequence90 s609 (letrec ((dobody613 (lambda (body614 r615 w616 m617 esew618 mod619) (if (null? body614) (quote ()) (let ((first620 (chi-top146 (car body614) r615 w616 m617 esew618 mod619))) (cons first620 (dobody613 (cdr body614) r615 w616 m617 esew618 mod619))))))) (dobody613 body606 r607 w608 m610 esew611 mod612))))) (chi-sequence141 (lambda (body621 r622 w623 s624 mod625) (build-sequence90 s624 (letrec ((dobody626 (lambda (body627 r628 w629 mod630) (if (null? body627) (quote ()) (let ((first631 (chi147 (car body627) r628 w629 mod630))) (cons first631 (dobody626 (cdr body627) r628 w629 mod630))))))) (dobody626 body621 r622 w623 mod625))))) (source-wrap140 (lambda (x632 w633 s634 defmod635) (wrap139 (if s634 (make-annotation x632 s634 #f) x632) w633 defmod635))) (wrap139 (lambda (x636 w637 defmod638) (cond ((and (null? (wrap-marks114 w637)) (null? (wrap-subst115 w637))) x636) ((syntax-object?95 x636) (make-syntax-object94 (syntax-object-expression96 x636) (join-wraps130 w637 (syntax-object-wrap97 x636)) (syntax-object-module98 x636))) ((null? x636) x636) (else (make-syntax-object94 x636 w637 defmod638))))) (bound-id-member?138 (lambda (x639 list640) (and (not (null? list640)) (or (bound-id=?135 x639 (car list640)) (bound-id-member?138 x639 (cdr list640)))))) (distinct-bound-ids?137 (lambda (ids641) (letrec ((distinct?642 (lambda (ids643) (or (null? ids643) (and (not (bound-id-member?138 (car ids643) (cdr ids643))) (distinct?642 (cdr ids643))))))) (distinct?642 ids641)))) (valid-bound-ids?136 (lambda (ids644) (and (letrec ((all-ids?645 (lambda (ids646) (or (null? ids646) (and (id?111 (car ids646)) (all-ids?645 (cdr ids646))))))) (all-ids?645 ids644)) (distinct-bound-ids?137 ids644)))) (bound-id=?135 (lambda (i647 j648) (if (and (syntax-object?95 i647) (syntax-object?95 j648)) (and (eq? (let ((e649 (syntax-object-expression96 i647))) (if (annotation? e649) (annotation-expression e649) e649)) (let ((e650 (syntax-object-expression96 j648))) (if (annotation? e650) (annotation-expression e650) e650))) (same-marks?132 (wrap-marks114 (syntax-object-wrap97 i647)) (wrap-marks114 (syntax-object-wrap97 j648)))) (eq? (let ((e651 i647)) (if (annotation? e651) (annotation-expression e651) e651)) (let ((e652 j648)) (if (annotation? e652) (annotation-expression e652) e652)))))) (free-id=?134 (lambda (i653 j654) (and (eq? (let ((x655 i653)) (let ((e656 (if (syntax-object?95 x655) (syntax-object-expression96 x655) x655))) (if (annotation? e656) (annotation-expression e656) e656))) (let ((x657 j654)) (let ((e658 (if (syntax-object?95 x657) (syntax-object-expression96 x657) x657))) (if (annotation? e658) (annotation-expression e658) e658)))) (eq? (id-var-name133 i653 (quote (()))) (id-var-name133 j654 (quote (()))))))) (id-var-name133 (lambda (id659 w660) (letrec ((search-vector-rib663 (lambda (sym669 subst670 marks671 symnames672 ribcage673) (let ((n674 (vector-length symnames672))) (letrec ((f675 (lambda (i676) (cond ((fx=73 i676 n674) (search661 sym669 (cdr subst670) marks671)) ((and (eq? (vector-ref symnames672 i676) sym669) (same-marks?132 marks671 (vector-ref (ribcage-marks121 ribcage673) i676))) (values (vector-ref (ribcage-labels122 ribcage673) i676) marks671)) (else (f675 (fx+71 i676 1))))))) (f675 0))))) (search-list-rib662 (lambda (sym677 subst678 marks679 symnames680 ribcage681) (letrec ((f682 (lambda (symnames683 i684) (cond ((null? symnames683) (search661 sym677 (cdr subst678) marks679)) ((and (eq? (car symnames683) sym677) (same-marks?132 marks679 (list-ref (ribcage-marks121 ribcage681) i684))) (values (list-ref (ribcage-labels122 ribcage681) i684) marks679)) (else (f682 (cdr symnames683) (fx+71 i684 1))))))) (f682 symnames680 0)))) (search661 (lambda (sym685 subst686 marks687) (if (null? subst686) (values #f marks687) (let ((fst688 (car subst686))) (if (eq? fst688 (quote shift)) (search661 sym685 (cdr subst686) (cdr marks687)) (let ((symnames689 (ribcage-symnames120 fst688))) (if (vector? symnames689) (search-vector-rib663 sym685 subst686 marks687 symnames689 fst688) (search-list-rib662 sym685 subst686 marks687 symnames689 fst688))))))))) (cond ((symbol? id659) (or (call-with-values (lambda () (search661 id659 (wrap-subst115 w660) (wrap-marks114 w660))) (lambda (x691 . ignore690) x691)) id659)) ((syntax-object?95 id659) (let ((id692 (let ((e694 (syntax-object-expression96 id659))) (if (annotation? e694) (annotation-expression e694) e694))) (w1693 (syntax-object-wrap97 id659))) (let ((marks695 (join-marks131 (wrap-marks114 w660) (wrap-marks114 w1693)))) (call-with-values (lambda () (search661 id692 (wrap-subst115 w660) marks695)) (lambda (new-id696 marks697) (or new-id696 (call-with-values (lambda () (search661 id692 (wrap-subst115 w1693) marks697)) (lambda (x699 . ignore698) x699)) id692)))))) ((annotation? id659) (let ((id700 (let ((e701 id659)) (if (annotation? e701) (annotation-expression e701) e701)))) (or (call-with-values (lambda () (search661 id700 (wrap-subst115 w660) (wrap-marks114 w660))) (lambda (x703 . ignore702) x703)) id700))) (else (syntax-violation (quote id-var-name) "invalid id" id659)))))) (same-marks?132 (lambda (x704 y705) (or (eq? x704 y705) (and (not (null? x704)) (not (null? y705)) (eq? (car x704) (car y705)) (same-marks?132 (cdr x704) (cdr y705)))))) (join-marks131 (lambda (m1706 m2707) (smart-append129 m1706 m2707))) (join-wraps130 (lambda (w1708 w2709) (let ((m1710 (wrap-marks114 w1708)) (s1711 (wrap-subst115 w1708))) (if (null? m1710) (if (null? s1711) w2709 (make-wrap113 (wrap-marks114 w2709) (smart-append129 s1711 (wrap-subst115 w2709)))) (make-wrap113 (smart-append129 m1710 (wrap-marks114 w2709)) (smart-append129 s1711 (wrap-subst115 w2709))))))) (smart-append129 (lambda (m1712 m2713) (if (null? m2713) m1712 (append m1712 m2713)))) (make-binding-wrap128 (lambda (ids714 labels715 w716) (if (null? ids714) w716 (make-wrap113 (wrap-marks114 w716) (cons (let ((labelvec717 (list->vector labels715))) (let ((n718 (vector-length labelvec717))) (let ((symnamevec719 (make-vector n718)) (marksvec720 (make-vector n718))) (begin (letrec ((f721 (lambda (ids722 i723) (if (not (null? ids722)) (call-with-values (lambda () (id-sym-name&marks112 (car ids722) w716)) (lambda (symname724 marks725) (begin (vector-set! symnamevec719 i723 symname724) (vector-set! marksvec720 i723 marks725) (f721 (cdr ids722) (fx+71 i723 1))))))))) (f721 ids714 0)) (make-ribcage118 symnamevec719 marksvec720 labelvec717))))) (wrap-subst115 w716)))))) (extend-ribcage!127 (lambda (ribcage726 id727 label728) (begin (set-ribcage-symnames!123 ribcage726 (cons (let ((e729 (syntax-object-expression96 id727))) (if (annotation? e729) (annotation-expression e729) e729)) (ribcage-symnames120 ribcage726))) (set-ribcage-marks!124 ribcage726 (cons (wrap-marks114 (syntax-object-wrap97 id727)) (ribcage-marks121 ribcage726))) (set-ribcage-labels!125 ribcage726 (cons label728 (ribcage-labels122 ribcage726)))))) (anti-mark126 (lambda (w730) (make-wrap113 (cons #f (wrap-marks114 w730)) (cons (quote shift) (wrap-subst115 w730))))) (set-ribcage-labels!125 (lambda (x731 update732) (vector-set! x731 3 update732))) (set-ribcage-marks!124 (lambda (x733 update734) (vector-set! x733 2 update734))) (set-ribcage-symnames!123 (lambda (x735 update736) (vector-set! x735 1 update736))) (ribcage-labels122 (lambda (x737) (vector-ref x737 3))) (ribcage-marks121 (lambda (x738) (vector-ref x738 2))) (ribcage-symnames120 (lambda (x739) (vector-ref x739 1))) (ribcage?119 (lambda (x740) (and (vector? x740) (= (vector-length x740) 4) (eq? (vector-ref x740 0) (quote ribcage))))) (make-ribcage118 (lambda (symnames741 marks742 labels743) (vector (quote ribcage) symnames741 marks742 labels743))) (gen-labels117 (lambda (ls744) (if (null? ls744) (quote ()) (cons (gen-label116) (gen-labels117 (cdr ls744)))))) (gen-label116 (lambda () (string #\i))) (wrap-subst115 cdr) (wrap-marks114 car) (make-wrap113 cons) (id-sym-name&marks112 (lambda (x745 w746) (if (syntax-object?95 x745) (values (let ((e747 (syntax-object-expression96 x745))) (if (annotation? e747) (annotation-expression e747) e747)) (join-marks131 (wrap-marks114 w746) (wrap-marks114 (syntax-object-wrap97 x745)))) (values (let ((e748 x745)) (if (annotation? e748) (annotation-expression e748) e748)) (wrap-marks114 w746))))) (id?111 (lambda (x749) (cond ((symbol? x749) #t) ((syntax-object?95 x749) (symbol? (let ((e750 (syntax-object-expression96 x749))) (if (annotation? e750) (annotation-expression e750) e750)))) ((annotation? x749) (symbol? (annotation-expression x749))) (else #f)))) (nonsymbol-id?110 (lambda (x751) (and (syntax-object?95 x751) (symbol? (let ((e752 (syntax-object-expression96 x751))) (if (annotation? e752) (annotation-expression e752) e752)))))) (global-extend109 (lambda (type753 sym754 val755) (put-global-definition-hook77 sym754 type753 val755))) (lookup108 (lambda (x756 r757 mod758) (cond ((assq x756 r757) => cdr) ((symbol? x756) (or (get-global-definition-hook78 x756 mod758) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env107 (lambda (r759) (if (null? r759) (quote ()) (let ((a760 (car r759))) (if (eq? (cadr a760) (quote macro)) (cons a760 (macros-only-env107 (cdr r759))) (macros-only-env107 (cdr r759))))))) (extend-var-env106 (lambda (labels761 vars762 r763) (if (null? labels761) r763 (extend-var-env106 (cdr labels761) (cdr vars762) (cons (cons (car labels761) (cons (quote lexical) (car vars762))) r763))))) (extend-env105 (lambda (labels764 bindings765 r766) (if (null? labels764) r766 (extend-env105 (cdr labels764) (cdr bindings765) (cons (cons (car labels764) (car bindings765)) r766))))) (binding-value104 cdr) (binding-type103 car) (source-annotation102 (lambda (x767) (cond ((annotation? x767) (annotation-source x767)) ((syntax-object?95 x767) (source-annotation102 (syntax-object-expression96 x767))) (else #f)))) (set-syntax-object-module!101 (lambda (x768 update769) (vector-set! x768 3 update769))) (set-syntax-object-wrap!100 (lambda (x770 update771) (vector-set! x770 2 update771))) (set-syntax-object-expression!99 (lambda (x772 update773) (vector-set! x772 1 update773))) (syntax-object-module98 (lambda (x774) (vector-ref x774 3))) (syntax-object-wrap97 (lambda (x775) (vector-ref x775 2))) (syntax-object-expression96 (lambda (x776) (vector-ref x776 1))) (syntax-object?95 (lambda (x777) (and (vector? x777) (= (vector-length x777) 4) (eq? (vector-ref x777 0) (quote syntax-object))))) (make-syntax-object94 (lambda (expression778 wrap779 module780) (vector (quote syntax-object) expression778 wrap779 module780))) (build-letrec93 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (let ((t785 (fluid-ref *mode*70))) (if (memv t785 (quote (c))) ((@ (language tree-il) make-letrec) src781 vars782 val-exps783 body-exp784) (list (quote letrec) (map list vars782 val-exps783) body-exp784)))))) (build-named-let92 (lambda (src786 vars787 val-exps788 body-exp789) (let ((f790 (car vars787)) (vars791 (cdr vars787))) (let ((t792 (fluid-ref *mode*70))) (if (memv t792 (quote (c))) ((@ (language tree-il) make-letrec) src786 (list f790) (list (build-lambda87 src786 vars791 #f body-exp789)) (build-application79 src786 (build-lexical-reference81 (quote fun) src786 f790 f790) val-exps788)) (list (quote let) f790 (map list vars791 val-exps788) body-exp789)))))) (build-let91 (lambda (src793 vars794 val-exps795 body-exp796) (if (null? vars794) body-exp796 (let ((t797 (fluid-ref *mode*70))) (if (memv t797 (quote (c))) ((@ (language tree-il) make-let) src793 vars794 val-exps795 body-exp796) (list (quote let) (map list vars794 val-exps795) body-exp796)))))) (build-sequence90 (lambda (src798 exps799) (if (null? (cdr exps799)) (car exps799) (let ((t800 (fluid-ref *mode*70))) (if (memv t800 (quote (c))) ((@ (language tree-il) make-sequence) src798 exps799) (cons (quote begin) exps799)))))) (build-data89 (lambda (src801 exp802) (let ((t803 (fluid-ref *mode*70))) (if (memv t803 (quote (c))) ((@ (language tree-il) make-const) src801 exp802) (if (and (self-evaluating? exp802) (not (vector? exp802))) exp802 (list (quote quote) exp802)))))) (build-primref88 (lambda (src804 name805) (let ((t806 (fluid-ref *mode*70))) (if (memv t806 (quote (c))) ((@ (language tree-il) make-primitive-ref) src804 name805) (build-global-reference84 src804 name805 (quote (hygiene guile))))))) (build-lambda87 (lambda (src807 vars808 docstring809 exp810) (let ((t811 (fluid-ref *mode*70))) (if (memv t811 (quote (c))) ((@ (language tree-il) make-lambda) src807 vars808 (if docstring809 (list (cons (quote documentation) docstring809)) (quote ())) exp810) (cons (quote lambda) (cons vars808 (append (if docstring809 (list docstring809) (quote ())) (list exp810)))))))) (build-global-definition86 (lambda (source812 var813 exp814) (let ((t815 (fluid-ref *mode*70))) (if (memv t815 (quote (c))) ((@ (language tree-il) make-toplevel-define) source812 var813 exp814) (list (quote define) var813 exp814))))) (build-global-assignment85 (lambda (source816 var817 exp818 mod819) (analyze-variable83 mod819 var817 (lambda (mod820 var821 public?822) (let ((t823 (fluid-ref *mode*70))) (if (memv t823 (quote (c))) ((@ (language tree-il) make-module-set) source816 mod820 var821 public?822 exp818) (list (quote set!) (list (if public?822 (quote @) (quote @@)) mod820 var821) exp818)))) (lambda (var824) (let ((t825 (fluid-ref *mode*70))) (if (memv t825 (quote (c))) ((@ (language tree-il) make-toplevel-set) source816 var824 exp818) (list (quote set!) var824 exp818))))))) (build-global-reference84 (lambda (source826 var827 mod828) (analyze-variable83 mod828 var827 (lambda (mod829 var830 public?831) (let ((t832 (fluid-ref *mode*70))) (if (memv t832 (quote (c))) ((@ (language tree-il) make-module-ref) source826 mod829 var830 public?831) (list (if public?831 (quote @) (quote @@)) mod829 var830)))) (lambda (var833) (let ((t834 (fluid-ref *mode*70))) (if (memv t834 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source826 var833) var833)))))) (analyze-variable83 (lambda (mod835 var836 modref-cont837 bare-cont838) (if (not mod835) (bare-cont838 var836) (let ((kind839 (car mod835)) (mod840 (cdr mod835))) (let ((t841 kind839)) (if (memv t841 (quote (public))) (modref-cont837 mod840 var836 #t) (if (memv t841 (quote (private))) (if (not (equal? mod840 (module-name (current-module)))) (modref-cont837 mod840 var836 #f) (bare-cont838 var836)) (if (memv t841 (quote (bare))) (bare-cont838 var836) (if (memv t841 (quote (hygiene))) (if (and (not (equal? mod840 (module-name (current-module)))) (module-variable (resolve-module mod840) var836)) (modref-cont837 mod840 var836 #f) (bare-cont838 var836)) (syntax-violation #f "bad module kind" var836 mod840)))))))))) (build-lexical-assignment82 (lambda (source842 name843 var844 exp845) (let ((t846 (fluid-ref *mode*70))) (if (memv t846 (quote (c))) ((@ (language tree-il) make-lexical-set) source842 name843 var844 exp845) (list (quote set!) var844 exp845))))) (build-lexical-reference81 (lambda (type847 source848 name849 var850) (let ((t851 (fluid-ref *mode*70))) (if (memv t851 (quote (c))) ((@ (language tree-il) make-lexical-ref) source848 name849 var850) var850)))) (build-conditional80 (lambda (source852 test-exp853 then-exp854 else-exp855) (let ((t856 (fluid-ref *mode*70))) (if (memv t856 (quote (c))) ((@ (language tree-il) make-conditional) source852 test-exp853 then-exp854 else-exp855) (list (quote if) test-exp853 then-exp854 else-exp855))))) (build-application79 (lambda (source857 fun-exp858 arg-exps859) (let ((t860 (fluid-ref *mode*70))) (if (memv t860 (quote (c))) ((@ (language tree-il) make-application) source857 fun-exp858 arg-exps859) (cons fun-exp858 arg-exps859))))) (get-global-definition-hook78 (lambda (symbol861 module862) (begin (if (and (not module862) (current-module)) (warn "module system is booted, we should have a module" symbol861)) (let ((v863 (module-variable (if module862 (resolve-module (cdr module862)) (current-module)) symbol861))) (and v863 (variable-bound? v863) (let ((val864 (variable-ref v863))) (and (macro? val864) (syncase-macro-type val864) (cons (syncase-macro-type val864) (syncase-macro-binding val864))))))))) (put-global-definition-hook77 (lambda (symbol865 type866 val867) (let ((existing868 (let ((v869 (module-variable (current-module) symbol865))) (and v869 (variable-bound? v869) (let ((val870 (variable-ref v869))) (and (macro? val870) (not (syncase-macro-type val870)) val870)))))) (module-define! (current-module) symbol865 (if existing868 (make-extended-syncase-macro existing868 type866 val867) (make-syncase-macro type866 val867)))))) (local-eval-hook76 (lambda (x871 mod872) (primitive-eval (list noexpand69 (let ((t873 (fluid-ref *mode*70))) (if (memv t873 (quote (c))) ((@ (language tree-il) tree-il->scheme) x871) x871)))))) (top-level-eval-hook75 (lambda (x874 mod875) (primitive-eval (list noexpand69 (let ((t876 (fluid-ref *mode*70))) (if (memv t876 (quote (c))) ((@ (language tree-il) tree-il->scheme) x874) x874)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend109 (quote local-syntax) (quote letrec-syntax) #t) (global-extend109 (quote local-syntax) (quote let-syntax) #f) (global-extend109 (quote core) (quote fluid-let-syntax) (lambda (e877 r878 w879 s880 mod881) ((lambda (tmp882) ((lambda (tmp883) (if (if tmp883 (apply (lambda (_884 var885 val886 e1887 e2888) (valid-bound-ids?136 var885)) tmp883) #f) (apply (lambda (_890 var891 val892 e1893 e2894) (let ((names895 (map (lambda (x896) (id-var-name133 x896 w879)) var891))) (begin (for-each (lambda (id898 n899) (let ((t900 (binding-type103 (lookup108 n899 r878 mod881)))) (if (memv t900 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e877 (source-wrap140 id898 w879 s880 mod881))))) var891 names895) (chi-body151 (cons e1893 e2894) (source-wrap140 e877 w879 s880 mod881) (extend-env105 names895 (let ((trans-r903 (macros-only-env107 r878))) (map (lambda (x904) (cons (quote macro) (eval-local-transformer154 (chi147 x904 trans-r903 w879 mod881) mod881))) val892)) r878) w879 mod881)))) tmp883) ((lambda (_906) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap140 e877 w879 s880 mod881))) tmp882))) ($sc-dispatch tmp882 (quote (any #(each (any any)) any . each-any))))) e877))) (global-extend109 (quote core) (quote quote) (lambda (e907 r908 w909 s910 mod911) ((lambda (tmp912) ((lambda (tmp913) (if tmp913 (apply (lambda (_914 e915) (build-data89 s910 (strip158 e915 w909))) tmp913) ((lambda (_916) (syntax-violation (quote quote) "bad syntax" (source-wrap140 e907 w909 s910 mod911))) tmp912))) ($sc-dispatch tmp912 (quote (any any))))) e907))) (global-extend109 (quote core) (quote syntax) (letrec ((regen924 (lambda (x925) (let ((t926 (car x925))) (if (memv t926 (quote (ref))) (build-lexical-reference81 (quote value) #f (cadr x925) (cadr x925)) (if (memv t926 (quote (primitive))) (build-primref88 #f (cadr x925)) (if (memv t926 (quote (quote))) (build-data89 #f (cadr x925)) (if (memv t926 (quote (lambda))) (build-lambda87 #f (cadr x925) #f (regen924 (caddr x925))) (if (memv t926 (quote (map))) (let ((ls927 (map regen924 (cdr x925)))) (build-application79 #f (build-primref88 #f (quote map)) ls927)) (build-application79 #f (build-primref88 #f (car x925)) (map regen924 (cdr x925))))))))))) (gen-vector923 (lambda (x928) (cond ((eq? (car x928) (quote list)) (cons (quote vector) (cdr x928))) ((eq? (car x928) (quote quote)) (list (quote quote) (list->vector (cadr x928)))) (else (list (quote list->vector) x928))))) (gen-append922 (lambda (x929 y930) (if (equal? y930 (quote (quote ()))) x929 (list (quote append) x929 y930)))) (gen-cons921 (lambda (x931 y932) (let ((t933 (car y932))) (if (memv t933 (quote (quote))) (if (eq? (car x931) (quote quote)) (list (quote quote) (cons (cadr x931) (cadr y932))) (if (eq? (cadr y932) (quote ())) (list (quote list) x931) (list (quote cons) x931 y932))) (if (memv t933 (quote (list))) (cons (quote list) (cons x931 (cdr y932))) (list (quote cons) x931 y932)))))) (gen-map920 (lambda (e934 map-env935) (let ((formals936 (map cdr map-env935)) (actuals937 (map (lambda (x938) (list (quote ref) (car x938))) map-env935))) (cond ((eq? (car e934) (quote ref)) (car actuals937)) ((and-map (lambda (x939) (and (eq? (car x939) (quote ref)) (memq (cadr x939) formals936))) (cdr e934)) (cons (quote map) (cons (list (quote primitive) (car e934)) (map (let ((r940 (map cons formals936 actuals937))) (lambda (x941) (cdr (assq (cadr x941) r940)))) (cdr e934))))) (else (cons (quote map) (cons (list (quote lambda) formals936 e934) actuals937))))))) (gen-mappend919 (lambda (e942 map-env943) (list (quote apply) (quote (primitive append)) (gen-map920 e942 map-env943)))) (gen-ref918 (lambda (src944 var945 level946 maps947) (if (fx=73 level946 0) (values var945 maps947) (if (null? maps947) (syntax-violation (quote syntax) "missing ellipsis" src944) (call-with-values (lambda () (gen-ref918 src944 var945 (fx-72 level946 1) (cdr maps947))) (lambda (outer-var948 outer-maps949) (let ((b950 (assq outer-var948 (car maps947)))) (if b950 (values (cdr b950) maps947) (let ((inner-var951 (gen-var159 (quote tmp)))) (values inner-var951 (cons (cons (cons outer-var948 inner-var951) (car maps947)) outer-maps949))))))))))) (gen-syntax917 (lambda (src952 e953 r954 maps955 ellipsis?956 mod957) (if (id?111 e953) (let ((label958 (id-var-name133 e953 (quote (()))))) (let ((b959 (lookup108 label958 r954 mod957))) (if (eq? (binding-type103 b959) (quote syntax)) (call-with-values (lambda () (let ((var.lev960 (binding-value104 b959))) (gen-ref918 src952 (car var.lev960) (cdr var.lev960) maps955))) (lambda (var961 maps962) (values (list (quote ref) var961) maps962))) (if (ellipsis?956 e953) (syntax-violation (quote syntax) "misplaced ellipsis" src952) (values (list (quote quote) e953) maps955))))) ((lambda (tmp963) ((lambda (tmp964) (if (if tmp964 (apply (lambda (dots965 e966) (ellipsis?956 dots965)) tmp964) #f) (apply (lambda (dots967 e968) (gen-syntax917 src952 e968 r954 maps955 (lambda (x969) #f) mod957)) tmp964) ((lambda (tmp970) (if (if tmp970 (apply (lambda (x971 dots972 y973) (ellipsis?956 dots972)) tmp970) #f) (apply (lambda (x974 dots975 y976) (letrec ((f977 (lambda (y978 k979) ((lambda (tmp983) ((lambda (tmp984) (if (if tmp984 (apply (lambda (dots985 y986) (ellipsis?956 dots985)) tmp984) #f) (apply (lambda (dots987 y988) (f977 y988 (lambda (maps989) (call-with-values (lambda () (k979 (cons (quote ()) maps989))) (lambda (x990 maps991) (if (null? (car maps991)) (syntax-violation (quote syntax) "extra ellipsis" src952) (values (gen-mappend919 x990 (car maps991)) (cdr maps991)))))))) tmp984) ((lambda (_992) (call-with-values (lambda () (gen-syntax917 src952 y978 r954 maps955 ellipsis?956 mod957)) (lambda (y993 maps994) (call-with-values (lambda () (k979 maps994)) (lambda (x995 maps996) (values (gen-append922 x995 y993) maps996)))))) tmp983))) ($sc-dispatch tmp983 (quote (any . any))))) y978)))) (f977 y976 (lambda (maps980) (call-with-values (lambda () (gen-syntax917 src952 x974 r954 (cons (quote ()) maps980) ellipsis?956 mod957)) (lambda (x981 maps982) (if (null? (car maps982)) (syntax-violation (quote syntax) "extra ellipsis" src952) (values (gen-map920 x981 (car maps982)) (cdr maps982))))))))) tmp970) ((lambda (tmp997) (if tmp997 (apply (lambda (x998 y999) (call-with-values (lambda () (gen-syntax917 src952 x998 r954 maps955 ellipsis?956 mod957)) (lambda (x1000 maps1001) (call-with-values (lambda () (gen-syntax917 src952 y999 r954 maps1001 ellipsis?956 mod957)) (lambda (y1002 maps1003) (values (gen-cons921 x1000 y1002) maps1003)))))) tmp997) ((lambda (tmp1004) (if tmp1004 (apply (lambda (e11005 e21006) (call-with-values (lambda () (gen-syntax917 src952 (cons e11005 e21006) r954 maps955 ellipsis?956 mod957)) (lambda (e1008 maps1009) (values (gen-vector923 e1008) maps1009)))) tmp1004) ((lambda (_1010) (values (list (quote quote) e953) maps955)) tmp963))) ($sc-dispatch tmp963 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp963 (quote (any . any)))))) ($sc-dispatch tmp963 (quote (any any . any)))))) ($sc-dispatch tmp963 (quote (any any))))) e953))))) (lambda (e1011 r1012 w1013 s1014 mod1015) (let ((e1016 (source-wrap140 e1011 w1013 s1014 mod1015))) ((lambda (tmp1017) ((lambda (tmp1018) (if tmp1018 (apply (lambda (_1019 x1020) (call-with-values (lambda () (gen-syntax917 e1016 x1020 r1012 (quote ()) ellipsis?156 mod1015)) (lambda (e1021 maps1022) (regen924 e1021)))) tmp1018) ((lambda (_1023) (syntax-violation (quote syntax) "bad `syntax' form" e1016)) tmp1017))) ($sc-dispatch tmp1017 (quote (any any))))) e1016))))) (global-extend109 (quote core) (quote lambda) (lambda (e1024 r1025 w1026 s1027 mod1028) ((lambda (tmp1029) ((lambda (tmp1030) (if tmp1030 (apply (lambda (_1031 c1032) (chi-lambda-clause152 (source-wrap140 e1024 w1026 s1027 mod1028) #f c1032 r1025 w1026 mod1028 (lambda (vars1033 docstring1034 body1035) (build-lambda87 s1027 vars1033 docstring1034 body1035)))) tmp1030) (syntax-violation #f "source expression failed to match any pattern" tmp1029))) ($sc-dispatch tmp1029 (quote (any . any))))) e1024))) (global-extend109 (quote core) (quote let) (letrec ((chi-let1036 (lambda (e1037 r1038 w1039 s1040 mod1041 constructor1042 ids1043 vals1044 exps1045) (if (not (valid-bound-ids?136 ids1043)) (syntax-violation (quote let) "duplicate bound variable" e1037) (let ((labels1046 (gen-labels117 ids1043)) (new-vars1047 (map gen-var159 ids1043))) (let ((nw1048 (make-binding-wrap128 ids1043 labels1046 w1039)) (nr1049 (extend-var-env106 labels1046 new-vars1047 r1038))) (constructor1042 s1040 new-vars1047 (map (lambda (x1050) (chi147 x1050 r1038 w1039 mod1041)) vals1044) (chi-body151 exps1045 (source-wrap140 e1037 nw1048 s1040 mod1041) nr1049 nw1048 mod1041)))))))) (lambda (e1051 r1052 w1053 s1054 mod1055) ((lambda (tmp1056) ((lambda (tmp1057) (if tmp1057 (apply (lambda (_1058 id1059 val1060 e11061 e21062) (chi-let1036 e1051 r1052 w1053 s1054 mod1055 build-let91 id1059 val1060 (cons e11061 e21062))) tmp1057) ((lambda (tmp1066) (if (if tmp1066 (apply (lambda (_1067 f1068 id1069 val1070 e11071 e21072) (id?111 f1068)) tmp1066) #f) (apply (lambda (_1073 f1074 id1075 val1076 e11077 e21078) (chi-let1036 e1051 r1052 w1053 s1054 mod1055 build-named-let92 (cons f1074 id1075) val1076 (cons e11077 e21078))) tmp1066) ((lambda (_1082) (syntax-violation (quote let) "bad let" (source-wrap140 e1051 w1053 s1054 mod1055))) tmp1056))) ($sc-dispatch tmp1056 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1056 (quote (any #(each (any any)) any . each-any))))) e1051)))) (global-extend109 (quote core) (quote letrec) (lambda (e1083 r1084 w1085 s1086 mod1087) ((lambda (tmp1088) ((lambda (tmp1089) (if tmp1089 (apply (lambda (_1090 id1091 val1092 e11093 e21094) (let ((ids1095 id1091)) (if (not (valid-bound-ids?136 ids1095)) (syntax-violation (quote letrec) "duplicate bound variable" e1083) (let ((labels1097 (gen-labels117 ids1095)) (new-vars1098 (map gen-var159 ids1095))) (let ((w1099 (make-binding-wrap128 ids1095 labels1097 w1085)) (r1100 (extend-var-env106 labels1097 new-vars1098 r1084))) (build-letrec93 s1086 new-vars1098 (map (lambda (x1101) (chi147 x1101 r1100 w1099 mod1087)) val1092) (chi-body151 (cons e11093 e21094) (source-wrap140 e1083 w1099 s1086 mod1087) r1100 w1099 mod1087))))))) tmp1089) ((lambda (_1104) (syntax-violation (quote letrec) "bad letrec" (source-wrap140 e1083 w1085 s1086 mod1087))) tmp1088))) ($sc-dispatch tmp1088 (quote (any #(each (any any)) any . each-any))))) e1083))) (global-extend109 (quote core) (quote set!) (lambda (e1105 r1106 w1107 s1108 mod1109) ((lambda (tmp1110) ((lambda (tmp1111) (if (if tmp1111 (apply (lambda (_1112 id1113 val1114) (id?111 id1113)) tmp1111) #f) (apply (lambda (_1115 id1116 val1117) (let ((val1118 (chi147 val1117 r1106 w1107 mod1109)) (n1119 (id-var-name133 id1116 w1107))) (let ((b1120 (lookup108 n1119 r1106 mod1109))) (let ((t1121 (binding-type103 b1120))) (if (memv t1121 (quote (lexical))) (build-lexical-assignment82 s1108 (syntax->datum id1116) (binding-value104 b1120) val1118) (if (memv t1121 (quote (global))) (build-global-assignment85 s1108 n1119 val1118 mod1109) (if (memv t1121 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap139 id1116 w1107 mod1109)) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1105 w1107 s1108 mod1109))))))))) tmp1111) ((lambda (tmp1122) (if tmp1122 (apply (lambda (_1123 head1124 tail1125 val1126) (call-with-values (lambda () (syntax-type145 head1124 r1106 (quote (())) #f #f mod1109)) (lambda (type1127 value1128 ee1129 ww1130 ss1131 modmod1132) (let ((t1133 type1127)) (if (memv t1133 (quote (module-ref))) (let ((val1134 (chi147 val1126 r1106 w1107 mod1109))) (call-with-values (lambda () (value1128 (cons head1124 tail1125))) (lambda (id1136 mod1137) (build-global-assignment85 s1108 id1136 val1134 mod1137)))) (build-application79 s1108 (chi147 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1124) r1106 w1107 mod1109) (map (lambda (e1138) (chi147 e1138 r1106 w1107 mod1109)) (append tail1125 (list val1126))))))))) tmp1122) ((lambda (_1140) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1105 w1107 s1108 mod1109))) tmp1110))) ($sc-dispatch tmp1110 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1110 (quote (any any any))))) e1105))) (global-extend109 (quote module-ref) (quote @) (lambda (e1141) ((lambda (tmp1142) ((lambda (tmp1143) (if (if tmp1143 (apply (lambda (_1144 mod1145 id1146) (and (and-map id?111 mod1145) (id?111 id1146))) tmp1143) #f) (apply (lambda (_1148 mod1149 id1150) (values (syntax->datum id1150) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1149)))) tmp1143) (syntax-violation #f "source expression failed to match any pattern" tmp1142))) ($sc-dispatch tmp1142 (quote (any each-any any))))) e1141))) (global-extend109 (quote module-ref) (quote @@) (lambda (e1152) ((lambda (tmp1153) ((lambda (tmp1154) (if (if tmp1154 (apply (lambda (_1155 mod1156 id1157) (and (and-map id?111 mod1156) (id?111 id1157))) tmp1154) #f) (apply (lambda (_1159 mod1160 id1161) (values (syntax->datum id1161) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1160)))) tmp1154) (syntax-violation #f "source expression failed to match any pattern" tmp1153))) ($sc-dispatch tmp1153 (quote (any each-any any))))) e1152))) (global-extend109 (quote begin) (quote begin) (quote ())) (global-extend109 (quote define) (quote define) (quote ())) (global-extend109 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend109 (quote eval-when) (quote eval-when) (quote ())) (global-extend109 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1166 (lambda (x1167 keys1168 clauses1169 r1170 mod1171) (if (null? clauses1169) (build-application79 #f (build-primref88 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1167)) ((lambda (tmp1172) ((lambda (tmp1173) (if tmp1173 (apply (lambda (pat1174 exp1175) (if (and (id?111 pat1174) (and-map (lambda (x1176) (not (free-id=?134 pat1174 x1176))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1168))) (let ((labels1177 (list (gen-label116))) (var1178 (gen-var159 pat1174))) (build-application79 #f (build-lambda87 #f (list var1178) #f (chi147 exp1175 (extend-env105 labels1177 (list (cons (quote syntax) (cons var1178 0))) r1170) (make-binding-wrap128 (list pat1174) labels1177 (quote (()))) mod1171)) (list x1167))) (gen-clause1165 x1167 keys1168 (cdr clauses1169) r1170 pat1174 #t exp1175 mod1171))) tmp1173) ((lambda (tmp1179) (if tmp1179 (apply (lambda (pat1180 fender1181 exp1182) (gen-clause1165 x1167 keys1168 (cdr clauses1169) r1170 pat1180 fender1181 exp1182 mod1171)) tmp1179) ((lambda (_1183) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1169))) tmp1172))) ($sc-dispatch tmp1172 (quote (any any any)))))) ($sc-dispatch tmp1172 (quote (any any))))) (car clauses1169))))) (gen-clause1165 (lambda (x1184 keys1185 clauses1186 r1187 pat1188 fender1189 exp1190 mod1191) (call-with-values (lambda () (convert-pattern1163 pat1188 keys1185)) (lambda (p1192 pvars1193) (cond ((not (distinct-bound-ids?137 (map car pvars1193))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1188)) ((not (and-map (lambda (x1194) (not (ellipsis?156 (car x1194)))) pvars1193)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1188)) (else (let ((y1195 (gen-var159 (quote tmp)))) (build-application79 #f (build-lambda87 #f (list y1195) #f (let ((y1196 (build-lexical-reference81 (quote value) #f (quote tmp) y1195))) (build-conditional80 #f ((lambda (tmp1197) ((lambda (tmp1198) (if tmp1198 (apply (lambda () y1196) tmp1198) ((lambda (_1199) (build-conditional80 #f y1196 (build-dispatch-call1164 pvars1193 fender1189 y1196 r1187 mod1191) (build-data89 #f #f))) tmp1197))) ($sc-dispatch tmp1197 (quote #(atom #t))))) fender1189) (build-dispatch-call1164 pvars1193 exp1190 y1196 r1187 mod1191) (gen-syntax-case1166 x1184 keys1185 clauses1186 r1187 mod1191)))) (list (if (eq? p1192 (quote any)) (build-application79 #f (build-primref88 #f (quote list)) (list x1184)) (build-application79 #f (build-primref88 #f (quote $sc-dispatch)) (list x1184 (build-data89 #f p1192))))))))))))) (build-dispatch-call1164 (lambda (pvars1200 exp1201 y1202 r1203 mod1204) (let ((ids1205 (map car pvars1200)) (levels1206 (map cdr pvars1200))) (let ((labels1207 (gen-labels117 ids1205)) (new-vars1208 (map gen-var159 ids1205))) (build-application79 #f (build-primref88 #f (quote apply)) (list (build-lambda87 #f new-vars1208 #f (chi147 exp1201 (extend-env105 labels1207 (map (lambda (var1209 level1210) (cons (quote syntax) (cons var1209 level1210))) new-vars1208 (map cdr pvars1200)) r1203) (make-binding-wrap128 ids1205 labels1207 (quote (()))) mod1204)) y1202)))))) (convert-pattern1163 (lambda (pattern1211 keys1212) (letrec ((cvt1213 (lambda (p1214 n1215 ids1216) (if (id?111 p1214) (if (bound-id-member?138 p1214 keys1212) (values (vector (quote free-id) p1214) ids1216) (values (quote any) (cons (cons p1214 n1215) ids1216))) ((lambda (tmp1217) ((lambda (tmp1218) (if (if tmp1218 (apply (lambda (x1219 dots1220) (ellipsis?156 dots1220)) tmp1218) #f) (apply (lambda (x1221 dots1222) (call-with-values (lambda () (cvt1213 x1221 (fx+71 n1215 1) ids1216)) (lambda (p1223 ids1224) (values (if (eq? p1223 (quote any)) (quote each-any) (vector (quote each) p1223)) ids1224)))) tmp1218) ((lambda (tmp1225) (if tmp1225 (apply (lambda (x1226 y1227) (call-with-values (lambda () (cvt1213 y1227 n1215 ids1216)) (lambda (y1228 ids1229) (call-with-values (lambda () (cvt1213 x1226 n1215 ids1229)) (lambda (x1230 ids1231) (values (cons x1230 y1228) ids1231)))))) tmp1225) ((lambda (tmp1232) (if tmp1232 (apply (lambda () (values (quote ()) ids1216)) tmp1232) ((lambda (tmp1233) (if tmp1233 (apply (lambda (x1234) (call-with-values (lambda () (cvt1213 x1234 n1215 ids1216)) (lambda (p1236 ids1237) (values (vector (quote vector) p1236) ids1237)))) tmp1233) ((lambda (x1238) (values (vector (quote atom) (strip158 p1214 (quote (())))) ids1216)) tmp1217))) ($sc-dispatch tmp1217 (quote #(vector each-any)))))) ($sc-dispatch tmp1217 (quote ()))))) ($sc-dispatch tmp1217 (quote (any . any)))))) ($sc-dispatch tmp1217 (quote (any any))))) p1214))))) (cvt1213 pattern1211 0 (quote ())))))) (lambda (e1239 r1240 w1241 s1242 mod1243) (let ((e1244 (source-wrap140 e1239 w1241 s1242 mod1243))) ((lambda (tmp1245) ((lambda (tmp1246) (if tmp1246 (apply (lambda (_1247 val1248 key1249 m1250) (if (and-map (lambda (x1251) (and (id?111 x1251) (not (ellipsis?156 x1251)))) key1249) (let ((x1253 (gen-var159 (quote tmp)))) (build-application79 s1242 (build-lambda87 #f (list x1253) #f (gen-syntax-case1166 (build-lexical-reference81 (quote value) #f (quote tmp) x1253) key1249 m1250 r1240 mod1243)) (list (chi147 val1248 r1240 (quote (())) mod1243)))) (syntax-violation (quote syntax-case) "invalid literals list" e1244))) tmp1246) (syntax-violation #f "source expression failed to match any pattern" tmp1245))) ($sc-dispatch tmp1245 (quote (any any each-any . each-any))))) e1244))))) (set! sc-expand (lambda (x1257 . rest1256) (if (and (pair? x1257) (equal? (car x1257) noexpand69)) (cadr x1257) (let ((m1258 (if (null? rest1256) (quote e) (car rest1256))) (esew1259 (if (or (null? rest1256) (null? (cdr rest1256))) (quote (eval)) (cadr rest1256)))) (with-fluid* *mode*70 m1258 (lambda () (chi-top146 x1257 (quote ()) (quote ((top))) m1258 esew1259 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1260) (nonsymbol-id?110 x1260))) (set! datum->syntax (lambda (id1261 datum1262) (make-syntax-object94 datum1262 (syntax-object-wrap97 id1261) #f))) (set! syntax->datum (lambda (x1263) (strip158 x1263 (quote (()))))) (set! generate-temporaries (lambda (ls1264) (begin (let ((x1265 ls1264)) (if (not (list? x1265)) (syntax-violation (quote generate-temporaries) "invalid argument" x1265))) (map (lambda (x1266) (wrap139 (gensym) (quote ((top))) #f)) ls1264)))) (set! free-identifier=? (lambda (x1267 y1268) (begin (let ((x1269 x1267)) (if (not (nonsymbol-id?110 x1269)) (syntax-violation (quote free-identifier=?) "invalid argument" x1269))) (let ((x1270 y1268)) (if (not (nonsymbol-id?110 x1270)) (syntax-violation (quote free-identifier=?) "invalid argument" x1270))) (free-id=?134 x1267 y1268)))) (set! bound-identifier=? (lambda (x1271 y1272) (begin (let ((x1273 x1271)) (if (not (nonsymbol-id?110 x1273)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1273))) (let ((x1274 y1272)) (if (not (nonsymbol-id?110 x1274)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1274))) (bound-id=?135 x1271 y1272)))) (set! syntax-violation (lambda (who1278 message1277 form1276 . subform1275) (begin (let ((x1279 who1278)) (if (not ((lambda (x1280) (or (not x1280) (string? x1280) (symbol? x1280))) x1279)) (syntax-violation (quote syntax-violation) "invalid argument" x1279))) (let ((x1281 message1277)) (if (not (string? x1281)) (syntax-violation (quote syntax-violation) "invalid argument" x1281))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1278 "~a: " "") "~a " (if (null? subform1275) "in ~a" "in subform `~s' of `~s'")) (let ((tail1282 (cons message1277 (map (lambda (x1283) (strip158 x1283 (quote (())))) (append subform1275 (list form1276)))))) (if who1278 (cons who1278 tail1282) tail1282)) #f)))) (letrec ((match1288 (lambda (e1289 p1290 w1291 r1292 mod1293) (cond ((not r1292) #f) ((eq? p1290 (quote any)) (cons (wrap139 e1289 w1291 mod1293) r1292)) ((syntax-object?95 e1289) (match*1287 (let ((e1294 (syntax-object-expression96 e1289))) (if (annotation? e1294) (annotation-expression e1294) e1294)) p1290 (join-wraps130 w1291 (syntax-object-wrap97 e1289)) r1292 (syntax-object-module98 e1289))) (else (match*1287 (let ((e1295 e1289)) (if (annotation? e1295) (annotation-expression e1295) e1295)) p1290 w1291 r1292 mod1293))))) (match*1287 (lambda (e1296 p1297 w1298 r1299 mod1300) (cond ((null? p1297) (and (null? e1296) r1299)) ((pair? p1297) (and (pair? e1296) (match1288 (car e1296) (car p1297) w1298 (match1288 (cdr e1296) (cdr p1297) w1298 r1299 mod1300) mod1300))) ((eq? p1297 (quote each-any)) (let ((l1301 (match-each-any1285 e1296 w1298 mod1300))) (and l1301 (cons l1301 r1299)))) (else (let ((t1302 (vector-ref p1297 0))) (if (memv t1302 (quote (each))) (if (null? e1296) (match-empty1286 (vector-ref p1297 1) r1299) (let ((l1303 (match-each1284 e1296 (vector-ref p1297 1) w1298 mod1300))) (and l1303 (letrec ((collect1304 (lambda (l1305) (if (null? (car l1305)) r1299 (cons (map car l1305) (collect1304 (map cdr l1305))))))) (collect1304 l1303))))) (if (memv t1302 (quote (free-id))) (and (id?111 e1296) (free-id=?134 (wrap139 e1296 w1298 mod1300) (vector-ref p1297 1)) r1299) (if (memv t1302 (quote (atom))) (and (equal? (vector-ref p1297 1) (strip158 e1296 w1298)) r1299) (if (memv t1302 (quote (vector))) (and (vector? e1296) (match1288 (vector->list e1296) (vector-ref p1297 1) w1298 r1299 mod1300))))))))))) (match-empty1286 (lambda (p1306 r1307) (cond ((null? p1306) r1307) ((eq? p1306 (quote any)) (cons (quote ()) r1307)) ((pair? p1306) (match-empty1286 (car p1306) (match-empty1286 (cdr p1306) r1307))) ((eq? p1306 (quote each-any)) (cons (quote ()) r1307)) (else (let ((t1308 (vector-ref p1306 0))) (if (memv t1308 (quote (each))) (match-empty1286 (vector-ref p1306 1) r1307) (if (memv t1308 (quote (free-id atom))) r1307 (if (memv t1308 (quote (vector))) (match-empty1286 (vector-ref p1306 1) r1307))))))))) (match-each-any1285 (lambda (e1309 w1310 mod1311) (cond ((annotation? e1309) (match-each-any1285 (annotation-expression e1309) w1310 mod1311)) ((pair? e1309) (let ((l1312 (match-each-any1285 (cdr e1309) w1310 mod1311))) (and l1312 (cons (wrap139 (car e1309) w1310 mod1311) l1312)))) ((null? e1309) (quote ())) ((syntax-object?95 e1309) (match-each-any1285 (syntax-object-expression96 e1309) (join-wraps130 w1310 (syntax-object-wrap97 e1309)) mod1311)) (else #f)))) (match-each1284 (lambda (e1313 p1314 w1315 mod1316) (cond ((annotation? e1313) (match-each1284 (annotation-expression e1313) p1314 w1315 mod1316)) ((pair? e1313) (let ((first1317 (match1288 (car e1313) p1314 w1315 (quote ()) mod1316))) (and first1317 (let ((rest1318 (match-each1284 (cdr e1313) p1314 w1315 mod1316))) (and rest1318 (cons first1317 rest1318)))))) ((null? e1313) (quote ())) ((syntax-object?95 e1313) (match-each1284 (syntax-object-expression96 e1313) p1314 (join-wraps130 w1315 (syntax-object-wrap97 e1313)) (syntax-object-module98 e1313))) (else #f))))) (set! $sc-dispatch (lambda (e1319 p1320) (cond ((eq? p1320 (quote any)) (list e1319)) ((syntax-object?95 e1319) (match*1287 (let ((e1321 (syntax-object-expression96 e1319))) (if (annotation? e1321) (annotation-expression e1321) e1321)) p1320 (syntax-object-wrap97 e1319) (quote ()) (syntax-object-module98 e1319))) (else (match*1287 (let ((e1322 e1319)) (if (annotation? e1322) (annotation-expression e1322) e1322)) p1320 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1323) ((lambda (tmp1324) ((lambda (tmp1325) (if tmp1325 (apply (lambda (_1326 e11327 e21328) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11327 e21328))) tmp1325) ((lambda (tmp1330) (if tmp1330 (apply (lambda (_1331 out1332 in1333 e11334 e21335) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1333 (quote ()) (list out1332 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11334 e21335))))) tmp1330) ((lambda (tmp1337) (if tmp1337 (apply (lambda (_1338 out1339 in1340 e11341 e21342) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1340) (quote ()) (list out1339 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11341 e21342))))) tmp1337) (syntax-violation #f "source expression failed to match any pattern" tmp1324))) ($sc-dispatch tmp1324 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1324 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1324 (quote (any () any . each-any))))) x1323)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1346) ((lambda (tmp1347) ((lambda (tmp1348) (if tmp1348 (apply (lambda (_1349 k1350 keyword1351 pattern1352 template1353) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1350 (map (lambda (tmp1356 tmp1355) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1355) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1356))) template1353 pattern1352)))))) tmp1348) (syntax-violation #f "source expression failed to match any pattern" tmp1347))) ($sc-dispatch tmp1347 (quote (any each-any . #(each ((any . any) any))))))) x1346)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1357) ((lambda (tmp1358) ((lambda (tmp1359) (if (if tmp1359 (apply (lambda (let*1360 x1361 v1362 e11363 e21364) (and-map identifier? x1361)) tmp1359) #f) (apply (lambda (let*1366 x1367 v1368 e11369 e21370) (letrec ((f1371 (lambda (bindings1372) (if (null? bindings1372) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11369 e21370))) ((lambda (tmp1376) ((lambda (tmp1377) (if tmp1377 (apply (lambda (body1378 binding1379) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1379) body1378)) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1376))) ($sc-dispatch tmp1376 (quote (any any))))) (list (f1371 (cdr bindings1372)) (car bindings1372))))))) (f1371 (map list x1367 v1368)))) tmp1359) (syntax-violation #f "source expression failed to match any pattern" tmp1358))) ($sc-dispatch tmp1358 (quote (any #(each (any any)) any . each-any))))) x1357)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1380) ((lambda (tmp1381) ((lambda (tmp1382) (if tmp1382 (apply (lambda (_1383 var1384 init1385 step1386 e01387 e11388 c1389) ((lambda (tmp1390) ((lambda (tmp1391) (if tmp1391 (apply (lambda (step1392) ((lambda (tmp1393) ((lambda (tmp1394) (if tmp1394 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1384 init1385) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01387) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1389 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1392))))))) tmp1394) ((lambda (tmp1399) (if tmp1399 (apply (lambda (e11400 e21401) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1384 init1385) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01387 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11400 e21401)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1389 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1392))))))) tmp1399) (syntax-violation #f "source expression failed to match any pattern" tmp1393))) ($sc-dispatch tmp1393 (quote (any . each-any)))))) ($sc-dispatch tmp1393 (quote ())))) e11388)) tmp1391) (syntax-violation #f "source expression failed to match any pattern" tmp1390))) ($sc-dispatch tmp1390 (quote each-any)))) (map (lambda (v1408 s1409) ((lambda (tmp1410) ((lambda (tmp1411) (if tmp1411 (apply (lambda () v1408) tmp1411) ((lambda (tmp1412) (if tmp1412 (apply (lambda (e1413) e1413) tmp1412) ((lambda (_1414) (syntax-violation (quote do) "bad step expression" orig-x1380 s1409)) tmp1410))) ($sc-dispatch tmp1410 (quote (any)))))) ($sc-dispatch tmp1410 (quote ())))) s1409)) var1384 step1386))) tmp1382) (syntax-violation #f "source expression failed to match any pattern" tmp1381))) ($sc-dispatch tmp1381 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1380)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1417 (lambda (x1421 y1422) ((lambda (tmp1423) ((lambda (tmp1424) (if tmp1424 (apply (lambda (x1425 y1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (dy1429) ((lambda (tmp1430) ((lambda (tmp1431) (if tmp1431 (apply (lambda (dx1432) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1432 dy1429))) tmp1431) ((lambda (_1433) (if (null? dy1429) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1425) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1425 y1426))) tmp1430))) ($sc-dispatch tmp1430 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1425)) tmp1428) ((lambda (tmp1434) (if tmp1434 (apply (lambda (stuff1435) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1425 stuff1435))) tmp1434) ((lambda (else1436) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1425 y1426)) tmp1427))) ($sc-dispatch tmp1427 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1427 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1426)) tmp1424) (syntax-violation #f "source expression failed to match any pattern" tmp1423))) ($sc-dispatch tmp1423 (quote (any any))))) (list x1421 y1422)))) (quasiappend1418 (lambda (x1437 y1438) ((lambda (tmp1439) ((lambda (tmp1440) (if tmp1440 (apply (lambda (x1441 y1442) ((lambda (tmp1443) ((lambda (tmp1444) (if tmp1444 (apply (lambda () x1441) tmp1444) ((lambda (_1445) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1441 y1442)) tmp1443))) ($sc-dispatch tmp1443 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1442)) tmp1440) (syntax-violation #f "source expression failed to match any pattern" tmp1439))) ($sc-dispatch tmp1439 (quote (any any))))) (list x1437 y1438)))) (quasivector1419 (lambda (x1446) ((lambda (tmp1447) ((lambda (x1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (x1451) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1451))) tmp1450) ((lambda (tmp1453) (if tmp1453 (apply (lambda (x1454) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454)) tmp1453) ((lambda (_1456) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1448)) tmp1449))) ($sc-dispatch tmp1449 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1449 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1448)) tmp1447)) x1446))) (quasi1420 (lambda (p1457 lev1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (p1461) (if (= lev1458 0) p1461 (quasicons1417 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1420 (list p1461) (- lev1458 1))))) tmp1460) ((lambda (tmp1462) (if tmp1462 (apply (lambda (p1463 q1464) (if (= lev1458 0) (quasiappend1418 p1463 (quasi1420 q1464 lev1458)) (quasicons1417 (quasicons1417 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1420 (list p1463) (- lev1458 1))) (quasi1420 q1464 lev1458)))) tmp1462) ((lambda (tmp1465) (if tmp1465 (apply (lambda (p1466) (quasicons1417 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1420 (list p1466) (+ lev1458 1)))) tmp1465) ((lambda (tmp1467) (if tmp1467 (apply (lambda (p1468 q1469) (quasicons1417 (quasi1420 p1468 lev1458) (quasi1420 q1469 lev1458))) tmp1467) ((lambda (tmp1470) (if tmp1470 (apply (lambda (x1471) (quasivector1419 (quasi1420 x1471 lev1458))) tmp1470) ((lambda (p1473) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1473)) tmp1459))) ($sc-dispatch tmp1459 (quote #(vector each-any)))))) ($sc-dispatch tmp1459 (quote (any . any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1459 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1457)))) (lambda (x1474) ((lambda (tmp1475) ((lambda (tmp1476) (if tmp1476 (apply (lambda (_1477 e1478) (quasi1420 e1478 0)) tmp1476) (syntax-violation #f "source expression failed to match any pattern" tmp1475))) ($sc-dispatch tmp1475 (quote (any any))))) x1474))))) -(define include (make-syncase-macro (quote macro) (lambda (x1479) (letrec ((read-file1480 (lambda (fn1481 k1482) (let ((p1483 (open-input-file fn1481))) (letrec ((f1484 (lambda (x1485) (if (eof-object? x1485) (begin (close-input-port p1483) (quote ())) (cons (datum->syntax k1482 x1485) (f1484 (read p1483))))))) (f1484 (read p1483))))))) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (k1488 filename1489) (let ((fn1490 (syntax->datum filename1489))) ((lambda (tmp1491) ((lambda (tmp1492) (if tmp1492 (apply (lambda (exp1493) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1493)) tmp1492) (syntax-violation #f "source expression failed to match any pattern" tmp1491))) ($sc-dispatch tmp1491 (quote each-any)))) (read-file1480 fn1490 k1488)))) tmp1487) (syntax-violation #f "source expression failed to match any pattern" tmp1486))) ($sc-dispatch tmp1486 (quote (any any))))) x1479))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1495) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (_1498 e1499) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1495)) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any any))))) x1495)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (_1503 e1504) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1500)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote (any any))))) x1500)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509 m11510 m21511) ((lambda (tmp1512) ((lambda (body1513) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1509)) body1513)) tmp1512)) (letrec ((f1514 (lambda (clause1515 clauses1516) (if (null? clauses1516) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (e11520 e21521) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11520 e21521))) tmp1519) ((lambda (tmp1523) (if tmp1523 (apply (lambda (k1524 e11525 e21526) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1524)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11525 e21526)))) tmp1523) ((lambda (_1529) (syntax-violation (quote case) "bad clause" x1505 clause1515)) tmp1518))) ($sc-dispatch tmp1518 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1515) ((lambda (tmp1530) ((lambda (rest1531) ((lambda (tmp1532) ((lambda (tmp1533) (if tmp1533 (apply (lambda (k1534 e11535 e21536) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1534)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11535 e21536)) rest1531)) tmp1533) ((lambda (_1539) (syntax-violation (quote case) "bad clause" x1505 clause1515)) tmp1532))) ($sc-dispatch tmp1532 (quote (each-any any . each-any))))) clause1515)) tmp1530)) (f1514 (car clauses1516) (cdr clauses1516))))))) (f1514 m11510 m21511)))) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any any . each-any))))) x1505)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1540) ((lambda (tmp1541) ((lambda (tmp1542) (if tmp1542 (apply (lambda (_1543 e1544) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1544)) (list (cons _1543 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1544 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1542) (syntax-violation #f "source expression failed to match any pattern" tmp1541))) ($sc-dispatch tmp1541 (quote (any any))))) x1540)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (letrec ((andmap58 (lambda (first59) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))))) (andmap58 first56)) (letrec ((andmap62 (lambda (first63 rest64) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68))))))) (andmap62 first56 rest55))))))) (letrec ((lambda-var-list160 (lambda (vars289) (letrec ((lvl290 (lambda (vars291 ls292 w293) (cond ((pair? vars291) (lvl290 (cdr vars291) (cons (wrap139 (car vars291) w293 #f) ls292) w293)) ((id?111 vars291) (cons (wrap139 vars291 w293 #f) ls292)) ((null? vars291) ls292) ((syntax-object?95 vars291) (lvl290 (syntax-object-expression96 vars291) ls292 (join-wraps130 w293 (syntax-object-wrap97 vars291)))) ((annotation? vars291) (lvl290 (annotation-expression vars291) ls292 w293)) (else (cons vars291 ls292)))))) (lvl290 vars289 (quote ()) (quote (())))))) (gen-var159 (lambda (id294) (let ((id295 (if (syntax-object?95 id294) (syntax-object-expression96 id294) id294))) (if (annotation? id295) (gensym (symbol->string (annotation-expression id295))) (gensym (symbol->string id295)))))) (strip158 (lambda (x296 w297) (if (memq (quote top) (wrap-marks114 w297)) (if (or (annotation? x296) (and (pair? x296) (annotation? (car x296)))) (strip-annotation157 x296 #f) x296) (letrec ((f298 (lambda (x299) (cond ((syntax-object?95 x299) (strip158 (syntax-object-expression96 x299) (syntax-object-wrap97 x299))) ((pair? x299) (let ((a300 (f298 (car x299))) (d301 (f298 (cdr x299)))) (if (and (eq? a300 (car x299)) (eq? d301 (cdr x299))) x299 (cons a300 d301)))) ((vector? x299) (let ((old302 (vector->list x299))) (let ((new303 (map f298 old302))) (if (and-map*17 eq? old302 new303) x299 (list->vector new303))))) (else x299))))) (f298 x296))))) (strip-annotation157 (lambda (x304 parent305) (cond ((pair? x304) (let ((new306 (cons #f #f))) (begin (if parent305 (set-annotation-stripped! parent305 new306)) (set-car! new306 (strip-annotation157 (car x304) #f)) (set-cdr! new306 (strip-annotation157 (cdr x304) #f)) new306))) ((annotation? x304) (or (annotation-stripped x304) (strip-annotation157 (annotation-expression x304) x304))) ((vector? x304) (let ((new307 (make-vector (vector-length x304)))) (begin (if parent305 (set-annotation-stripped! parent305 new307)) (letrec ((loop308 (lambda (i309) (unless (fx<74 i309 0) (vector-set! new307 i309 (strip-annotation157 (vector-ref x304 i309) #f)) (loop308 (fx-72 i309 1)))))) (loop308 (- (vector-length x304) 1))) new307))) (else x304)))) (ellipsis?156 (lambda (x310) (and (nonsymbol-id?110 x310) (free-id=?134 x310 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void155 (lambda () (build-application79 #f (build-primref88 #f (quote if)) (quote (#f #f))))) (eval-local-transformer154 (lambda (expanded311 mod312) (let ((p313 (local-eval-hook76 expanded311 mod312))) (if (procedure? p313) p313 (syntax-violation #f "nonprocedure transformer" p313))))) (chi-local-syntax153 (lambda (rec?314 e315 r316 w317 s318 mod319 k320) ((lambda (tmp321) ((lambda (tmp322) (if tmp322 (apply (lambda (_323 id324 val325 e1326 e2327) (let ((ids328 id324)) (if (not (valid-bound-ids?136 ids328)) (syntax-violation #f "duplicate bound keyword" e315) (let ((labels330 (gen-labels117 ids328))) (let ((new-w331 (make-binding-wrap128 ids328 labels330 w317))) (k320 (cons e1326 e2327) (extend-env105 labels330 (let ((w333 (if rec?314 new-w331 w317)) (trans-r334 (macros-only-env107 r316))) (map (lambda (x335) (cons (quote macro) (eval-local-transformer154 (chi147 x335 trans-r334 w333 mod319) mod319))) val325)) r316) new-w331 s318 mod319)))))) tmp322) ((lambda (_337) (syntax-violation #f "bad local syntax definition" (source-wrap140 e315 w317 s318 mod319))) tmp321))) ($sc-dispatch tmp321 (quote (any #(each (any any)) any . each-any))))) e315))) (chi-lambda-clause152 (lambda (e338 docstring339 c340 r341 w342 mod343 k344) ((lambda (tmp345) ((lambda (tmp346) (if (if tmp346 (apply (lambda (args347 doc348 e1349 e2350) (and (string? (syntax->datum doc348)) (not docstring339))) tmp346) #f) (apply (lambda (args351 doc352 e1353 e2354) (chi-lambda-clause152 e338 doc352 (cons args351 (cons e1353 e2354)) r341 w342 mod343 k344)) tmp346) ((lambda (tmp356) (if tmp356 (apply (lambda (id357 e1358 e2359) (let ((ids360 id357)) (if (not (valid-bound-ids?136 ids360)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels362 (gen-labels117 ids360)) (new-vars363 (map gen-var159 ids360))) (k344 (map syntax->datum ids360) new-vars363 docstring339 (chi-body151 (cons e1358 e2359) e338 (extend-var-env106 labels362 new-vars363 r341) (make-binding-wrap128 ids360 labels362 w342) mod343)))))) tmp356) ((lambda (tmp365) (if tmp365 (apply (lambda (ids366 e1367 e2368) (let ((old-ids369 (lambda-var-list160 ids366))) (if (not (valid-bound-ids?136 old-ids369)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels370 (gen-labels117 old-ids369)) (new-vars371 (map gen-var159 old-ids369))) (k344 (letrec ((f372 (lambda (ls1373 ls2374) (if (null? ls1373) (syntax->datum ls2374) (f372 (cdr ls1373) (cons (syntax->datum (car ls1373)) ls2374)))))) (f372 (cdr old-ids369) (car old-ids369))) (letrec ((f375 (lambda (ls1376 ls2377) (if (null? ls1376) ls2377 (f375 (cdr ls1376) (cons (car ls1376) ls2377)))))) (f375 (cdr new-vars371) (car new-vars371))) docstring339 (chi-body151 (cons e1367 e2368) e338 (extend-var-env106 labels370 new-vars371 r341) (make-binding-wrap128 old-ids369 labels370 w342) mod343)))))) tmp365) ((lambda (_379) (syntax-violation (quote lambda) "bad lambda" e338)) tmp345))) ($sc-dispatch tmp345 (quote (any any . each-any)))))) ($sc-dispatch tmp345 (quote (each-any any . each-any)))))) ($sc-dispatch tmp345 (quote (any any any . each-any))))) c340))) (chi-body151 (lambda (body380 outer-form381 r382 w383 mod384) (let ((r385 (cons (quote ("placeholder" placeholder)) r382))) (let ((ribcage386 (make-ribcage118 (quote ()) (quote ()) (quote ())))) (let ((w387 (make-wrap113 (wrap-marks114 w383) (cons ribcage386 (wrap-subst115 w383))))) (letrec ((parse388 (lambda (body389 ids390 labels391 vars392 vals393 bindings394) (if (null? body389) (syntax-violation #f "no expressions in body" outer-form381) (let ((e396 (cdar body389)) (er397 (caar body389))) (call-with-values (lambda () (syntax-type145 e396 er397 (quote (())) #f ribcage386 mod384)) (lambda (type398 value399 e400 w401 s402 mod403) (let ((t404 type398)) (if (memv t404 (quote (define-form))) (let ((id405 (wrap139 value399 w401 mod403)) (label406 (gen-label116))) (let ((var407 (gen-var159 id405))) (begin (extend-ribcage!127 ribcage386 id405 label406) (parse388 (cdr body389) (cons id405 ids390) (cons label406 labels391) (cons var407 vars392) (cons (cons er397 (wrap139 e400 w401 mod403)) vals393) (cons (cons (quote lexical) var407) bindings394))))) (if (memv t404 (quote (define-syntax-form))) (let ((id408 (wrap139 value399 w401 mod403)) (label409 (gen-label116))) (begin (extend-ribcage!127 ribcage386 id408 label409) (parse388 (cdr body389) (cons id408 ids390) (cons label409 labels391) vars392 vals393 (cons (cons (quote macro) (cons er397 (wrap139 e400 w401 mod403))) bindings394)))) (if (memv t404 (quote (begin-form))) ((lambda (tmp410) ((lambda (tmp411) (if tmp411 (apply (lambda (_412 e1413) (parse388 (letrec ((f414 (lambda (forms415) (if (null? forms415) (cdr body389) (cons (cons er397 (wrap139 (car forms415) w401 mod403)) (f414 (cdr forms415))))))) (f414 e1413)) ids390 labels391 vars392 vals393 bindings394)) tmp411) (syntax-violation #f "source expression failed to match any pattern" tmp410))) ($sc-dispatch tmp410 (quote (any . each-any))))) e400) (if (memv t404 (quote (local-syntax-form))) (chi-local-syntax153 value399 e400 er397 w401 s402 mod403 (lambda (forms417 er418 w419 s420 mod421) (parse388 (letrec ((f422 (lambda (forms423) (if (null? forms423) (cdr body389) (cons (cons er418 (wrap139 (car forms423) w419 mod421)) (f422 (cdr forms423))))))) (f422 forms417)) ids390 labels391 vars392 vals393 bindings394))) (if (null? ids390) (build-sequence90 #f (map (lambda (x424) (chi147 (cdr x424) (car x424) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389)))) (begin (if (not (valid-bound-ids?136 ids390)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form381)) (letrec ((loop425 (lambda (bs426 er-cache427 r-cache428) (if (not (null? bs426)) (let ((b429 (car bs426))) (if (eq? (car b429) (quote macro)) (let ((er430 (cadr b429))) (let ((r-cache431 (if (eq? er430 er-cache427) r-cache428 (macros-only-env107 er430)))) (begin (set-cdr! b429 (eval-local-transformer154 (chi147 (cddr b429) r-cache431 (quote (())) mod403) mod403)) (loop425 (cdr bs426) er430 r-cache431)))) (loop425 (cdr bs426) er-cache427 r-cache428))))))) (loop425 bindings394 #f #f)) (set-cdr! r385 (extend-env105 labels391 bindings394 (cdr r385))) (build-letrec93 #f (map syntax->datum ids390) vars392 (map (lambda (x432) (chi147 (cdr x432) (car x432) (quote (())) mod403)) vals393) (build-sequence90 #f (map (lambda (x433) (chi147 (cdr x433) (car x433) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389))))))))))))))))))) (parse388 (map (lambda (x395) (cons r385 (wrap139 x395 w387 mod384))) body380) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro150 (lambda (p434 e435 r436 w437 rib438 mod439) (letrec ((rebuild-macro-output440 (lambda (x441 m442) (cond ((pair? x441) (cons (rebuild-macro-output440 (car x441) m442) (rebuild-macro-output440 (cdr x441) m442))) ((syntax-object?95 x441) (let ((w443 (syntax-object-wrap97 x441))) (let ((ms444 (wrap-marks114 w443)) (s445 (wrap-subst115 w443))) (if (and (pair? ms444) (eq? (car ms444) #f)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cdr ms444) (if rib438 (cons rib438 (cdr s445)) (cdr s445))) (syntax-object-module98 x441)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cons m442 ms444) (if rib438 (cons rib438 (cons (quote shift) s445)) (cons (quote shift) s445))) (let ((pmod446 (procedure-module p434))) (if pmod446 (cons (quote hygiene) (module-name pmod446)) (quote (hygiene guile))))))))) ((vector? x441) (let ((n447 (vector-length x441))) (let ((v448 (make-vector n447))) (letrec ((doloop449 (lambda (i450) (if (fx=73 i450 n447) v448 (begin (vector-set! v448 i450 (rebuild-macro-output440 (vector-ref x441 i450) m442)) (doloop449 (fx+71 i450 1))))))) (doloop449 0))))) ((symbol? x441) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap140 e435 w437 s mod439) x441)) (else x441))))) (rebuild-macro-output440 (p434 (wrap139 e435 (anti-mark126 w437) mod439)) (string #\m))))) (chi-application149 (lambda (x451 e452 r453 w454 s455 mod456) ((lambda (tmp457) ((lambda (tmp458) (if tmp458 (apply (lambda (e0459 e1460) (build-application79 s455 x451 (map (lambda (e461) (chi147 e461 r453 w454 mod456)) e1460))) tmp458) (syntax-violation #f "source expression failed to match any pattern" tmp457))) ($sc-dispatch tmp457 (quote (any . each-any))))) e452))) (chi-expr148 (lambda (type463 value464 e465 r466 w467 s468 mod469) (let ((t470 type463)) (if (memv t470 (quote (lexical))) (build-lexical-reference81 (quote value) s468 e465 value464) (if (memv t470 (quote (core external-macro))) (value464 e465 r466 w467 s468 mod469) (if (memv t470 (quote (module-ref))) (call-with-values (lambda () (value464 e465)) (lambda (id471 mod472) (build-global-reference84 s468 id471 mod472))) (if (memv t470 (quote (lexical-call))) (chi-application149 (build-lexical-reference81 (quote fun) (source-annotation102 (car e465)) (car e465) value464) e465 r466 w467 s468 mod469) (if (memv t470 (quote (global-call))) (chi-application149 (build-global-reference84 (source-annotation102 (car e465)) value464 (if (syntax-object?95 (car e465)) (syntax-object-module98 (car e465)) mod469)) e465 r466 w467 s468 mod469) (if (memv t470 (quote (constant))) (build-data89 s468 (strip158 (source-wrap140 e465 w467 s468 mod469) (quote (())))) (if (memv t470 (quote (global))) (build-global-reference84 s468 value464 mod469) (if (memv t470 (quote (call))) (chi-application149 (chi147 (car e465) r466 w467 mod469) e465 r466 w467 s468 mod469) (if (memv t470 (quote (begin-form))) ((lambda (tmp473) ((lambda (tmp474) (if tmp474 (apply (lambda (_475 e1476 e2477) (chi-sequence141 (cons e1476 e2477) r466 w467 s468 mod469)) tmp474) (syntax-violation #f "source expression failed to match any pattern" tmp473))) ($sc-dispatch tmp473 (quote (any any . each-any))))) e465) (if (memv t470 (quote (local-syntax-form))) (chi-local-syntax153 value464 e465 r466 w467 s468 mod469 chi-sequence141) (if (memv t470 (quote (eval-when-form))) ((lambda (tmp479) ((lambda (tmp480) (if tmp480 (apply (lambda (_481 x482 e1483 e2484) (let ((when-list485 (chi-when-list144 e465 x482 w467))) (if (memq (quote eval) when-list485) (chi-sequence141 (cons e1483 e2484) r466 w467 s468 mod469) (chi-void155)))) tmp480) (syntax-violation #f "source expression failed to match any pattern" tmp479))) ($sc-dispatch tmp479 (quote (any each-any any . each-any))))) e465) (if (memv t470 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e465 (wrap139 value464 w467 mod469)) (if (memv t470 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap140 e465 w467 s468 mod469)) (if (memv t470 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap140 e465 w467 s468 mod469)) (syntax-violation #f "unexpected syntax" (source-wrap140 e465 w467 s468 mod469))))))))))))))))))) (chi147 (lambda (e488 r489 w490 mod491) (call-with-values (lambda () (syntax-type145 e488 r489 w490 #f #f mod491)) (lambda (type492 value493 e494 w495 s496 mod497) (chi-expr148 type492 value493 e494 r489 w495 s496 mod497))))) (chi-top146 (lambda (e498 r499 w500 m501 esew502 mod503) (call-with-values (lambda () (syntax-type145 e498 r499 w500 #f #f mod503)) (lambda (type511 value512 e513 w514 s515 mod516) (let ((t517 type511)) (if (memv t517 (quote (begin-form))) ((lambda (tmp518) ((lambda (tmp519) (if tmp519 (apply (lambda (_520) (chi-void155)) tmp519) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 e1523 e2524) (chi-top-sequence142 (cons e1523 e2524) r499 w514 s515 m501 esew502 mod516)) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp518))) ($sc-dispatch tmp518 (quote (any any . each-any)))))) ($sc-dispatch tmp518 (quote (any))))) e513) (if (memv t517 (quote (local-syntax-form))) (chi-local-syntax153 value512 e513 r499 w514 s515 mod516 (lambda (body526 r527 w528 s529 mod530) (chi-top-sequence142 body526 r527 w528 s529 m501 esew502 mod530))) (if (memv t517 (quote (eval-when-form))) ((lambda (tmp531) ((lambda (tmp532) (if tmp532 (apply (lambda (_533 x534 e1535 e2536) (let ((when-list537 (chi-when-list144 e513 x534 w514)) (body538 (cons e1535 e2536))) (cond ((eq? m501 (quote e)) (if (memq (quote eval) when-list537) (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) (chi-void155))) ((memq (quote load) when-list537) (if (or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (chi-top-sequence142 body538 r499 w514 s515 (quote c&e) (quote (compile load)) mod516) (if (memq m501 (quote (c c&e))) (chi-top-sequence142 body538 r499 w514 s515 (quote c) (quote (load)) mod516) (chi-void155)))) ((or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (top-level-eval-hook75 (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) mod516) (chi-void155)) (else (chi-void155))))) tmp532) (syntax-violation #f "source expression failed to match any pattern" tmp531))) ($sc-dispatch tmp531 (quote (any each-any any . each-any))))) e513) (if (memv t517 (quote (define-syntax-form))) (let ((n541 (id-var-name133 value512 w514)) (r542 (macros-only-env107 r499))) (let ((t543 m501)) (if (memv t543 (quote (c))) (if (memq (quote compile) esew502) (let ((e544 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e544 mod516) (if (memq (quote load) esew502) e544 (chi-void155)))) (if (memq (quote load) esew502) (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) (chi-void155))) (if (memv t543 (quote (c&e))) (let ((e545 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e545 mod516) e545)) (begin (if (memq (quote eval) esew502) (top-level-eval-hook75 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) mod516)) (chi-void155)))))) (if (memv t517 (quote (define-form))) (let ((n546 (id-var-name133 value512 w514))) (let ((type547 (binding-type103 (lookup108 n546 r499 mod516)))) (let ((t548 type547)) (if (memv t548 (quote (global core macro module-ref))) (let ((x549 (build-global-definition86 s515 n546 (chi147 e513 r499 w514 mod516)))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x549 mod516)) x549)) (if (memv t548 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e513 (wrap139 value512 w514 mod516)) (syntax-violation #f "cannot define keyword at top level" e513 (wrap139 value512 w514 mod516))))))) (let ((x550 (chi-expr148 type511 value512 e513 r499 w514 s515 mod516))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x550 mod516)) x550)))))))))))) (syntax-type145 (lambda (e551 r552 w553 s554 rib555 mod556) (cond ((symbol? e551) (let ((n557 (id-var-name133 e551 w553))) (let ((b558 (lookup108 n557 r552 mod556))) (let ((type559 (binding-type103 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value104 b558) e551 w553 s554 mod556) (if (memv t560 (quote (global))) (values type559 n557 e551 w553 s554 mod556) (if (memv t560 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b558) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (values type559 (binding-value104 b558) e551 w553 s554 mod556))))))))) ((pair? e551) (let ((first561 (car e551))) (if (id?111 first561) (let ((n562 (id-var-name133 first561 w553))) (let ((b563 (lookup108 n562 r552 (or (and (syntax-object?95 first561) (syntax-object-module98 first561)) mod556)))) (let ((type564 (binding-type103 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (global))) (values (quote global-call) n562 e551 w553 s554 mod556) (if (memv t565 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b563) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (if (memv t565 (quote (core external-macro module-ref))) (values type564 (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (begin))) (values (quote begin-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?111 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w553 s554 mod556)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?111 name576) (valid-bound-ids?136 (lambda-var-list160 args577)))) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap139 name581 w553 mod556) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap139 (cons args582 (cons e1583 e2584)) w553 mod556)) (quote (())) s554 mod556)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?111 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap139 name590 w553 mod556) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s554 mod556)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e551) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?111 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w553 s554 mod556)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e551) (values (quote call) #f e551 w553 s554 mod556)))))))))))))) (values (quote call) #f e551 w553 s554 mod556)))) ((syntax-object?95 e551) (syntax-type145 (syntax-object-expression96 e551) r552 (join-wraps130 w553 (syntax-object-wrap97 e551)) #f rib555 (or (syntax-object-module98 e551) mod556))) ((annotation? e551) (syntax-type145 (annotation-expression e551) r552 w553 (annotation-source e551) rib555 mod556)) ((self-evaluating? e551) (values (quote constant) #f e551 w553 s554 mod556)) (else (values (quote other) #f e551 w553 s554 mod556))))) (chi-when-list144 (lambda (e599 when-list600 w601) (letrec ((f602 (lambda (when-list603 situations604) (if (null? when-list603) situations604 (f602 (cdr when-list603) (cons (let ((x605 (car when-list603))) (cond ((free-id=?134 x605 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?134 x605 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?134 x605 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e599 (wrap139 x605 w601 #f))))) situations604)))))) (f602 when-list600 (quote ()))))) (chi-install-global143 (lambda (name606 e607) (build-global-definition86 #f name606 (if (let ((v608 (module-variable (current-module) name606))) (and v608 (variable-bound? v608) (macro? (variable-ref v608)) (not (eq? (macro-type (variable-ref v608)) (quote syncase-macro))))) (build-application79 #f (build-primref88 #f (quote make-extended-syncase-macro)) (list (build-application79 #f (build-primref88 #f (quote module-ref)) (list (build-application79 #f (quote current-module) (quote ())) (build-data89 #f name606))) (build-data89 #f (quote macro)) e607)) (build-application79 #f (build-primref88 #f (quote make-syncase-macro)) (list (build-data89 #f (quote macro)) e607)))))) (chi-top-sequence142 (lambda (body609 r610 w611 s612 m613 esew614 mod615) (build-sequence90 s612 (letrec ((dobody616 (lambda (body617 r618 w619 m620 esew621 mod622) (if (null? body617) (quote ()) (let ((first623 (chi-top146 (car body617) r618 w619 m620 esew621 mod622))) (cons first623 (dobody616 (cdr body617) r618 w619 m620 esew621 mod622))))))) (dobody616 body609 r610 w611 m613 esew614 mod615))))) (chi-sequence141 (lambda (body624 r625 w626 s627 mod628) (build-sequence90 s627 (letrec ((dobody629 (lambda (body630 r631 w632 mod633) (if (null? body630) (quote ()) (let ((first634 (chi147 (car body630) r631 w632 mod633))) (cons first634 (dobody629 (cdr body630) r631 w632 mod633))))))) (dobody629 body624 r625 w626 mod628))))) (source-wrap140 (lambda (x635 w636 s637 defmod638) (wrap139 (if s637 (make-annotation x635 s637 #f) x635) w636 defmod638))) (wrap139 (lambda (x639 w640 defmod641) (cond ((and (null? (wrap-marks114 w640)) (null? (wrap-subst115 w640))) x639) ((syntax-object?95 x639) (make-syntax-object94 (syntax-object-expression96 x639) (join-wraps130 w640 (syntax-object-wrap97 x639)) (syntax-object-module98 x639))) ((null? x639) x639) (else (make-syntax-object94 x639 w640 defmod641))))) (bound-id-member?138 (lambda (x642 list643) (and (not (null? list643)) (or (bound-id=?135 x642 (car list643)) (bound-id-member?138 x642 (cdr list643)))))) (distinct-bound-ids?137 (lambda (ids644) (letrec ((distinct?645 (lambda (ids646) (or (null? ids646) (and (not (bound-id-member?138 (car ids646) (cdr ids646))) (distinct?645 (cdr ids646))))))) (distinct?645 ids644)))) (valid-bound-ids?136 (lambda (ids647) (and (letrec ((all-ids?648 (lambda (ids649) (or (null? ids649) (and (id?111 (car ids649)) (all-ids?648 (cdr ids649))))))) (all-ids?648 ids647)) (distinct-bound-ids?137 ids647)))) (bound-id=?135 (lambda (i650 j651) (if (and (syntax-object?95 i650) (syntax-object?95 j651)) (and (eq? (let ((e652 (syntax-object-expression96 i650))) (if (annotation? e652) (annotation-expression e652) e652)) (let ((e653 (syntax-object-expression96 j651))) (if (annotation? e653) (annotation-expression e653) e653))) (same-marks?132 (wrap-marks114 (syntax-object-wrap97 i650)) (wrap-marks114 (syntax-object-wrap97 j651)))) (eq? (let ((e654 i650)) (if (annotation? e654) (annotation-expression e654) e654)) (let ((e655 j651)) (if (annotation? e655) (annotation-expression e655) e655)))))) (free-id=?134 (lambda (i656 j657) (and (eq? (let ((x658 i656)) (let ((e659 (if (syntax-object?95 x658) (syntax-object-expression96 x658) x658))) (if (annotation? e659) (annotation-expression e659) e659))) (let ((x660 j657)) (let ((e661 (if (syntax-object?95 x660) (syntax-object-expression96 x660) x660))) (if (annotation? e661) (annotation-expression e661) e661)))) (eq? (id-var-name133 i656 (quote (()))) (id-var-name133 j657 (quote (()))))))) (id-var-name133 (lambda (id662 w663) (letrec ((search-vector-rib666 (lambda (sym672 subst673 marks674 symnames675 ribcage676) (let ((n677 (vector-length symnames675))) (letrec ((f678 (lambda (i679) (cond ((fx=73 i679 n677) (search664 sym672 (cdr subst673) marks674)) ((and (eq? (vector-ref symnames675 i679) sym672) (same-marks?132 marks674 (vector-ref (ribcage-marks121 ribcage676) i679))) (values (vector-ref (ribcage-labels122 ribcage676) i679) marks674)) (else (f678 (fx+71 i679 1))))))) (f678 0))))) (search-list-rib665 (lambda (sym680 subst681 marks682 symnames683 ribcage684) (letrec ((f685 (lambda (symnames686 i687) (cond ((null? symnames686) (search664 sym680 (cdr subst681) marks682)) ((and (eq? (car symnames686) sym680) (same-marks?132 marks682 (list-ref (ribcage-marks121 ribcage684) i687))) (values (list-ref (ribcage-labels122 ribcage684) i687) marks682)) (else (f685 (cdr symnames686) (fx+71 i687 1))))))) (f685 symnames683 0)))) (search664 (lambda (sym688 subst689 marks690) (if (null? subst689) (values #f marks690) (let ((fst691 (car subst689))) (if (eq? fst691 (quote shift)) (search664 sym688 (cdr subst689) (cdr marks690)) (let ((symnames692 (ribcage-symnames120 fst691))) (if (vector? symnames692) (search-vector-rib666 sym688 subst689 marks690 symnames692 fst691) (search-list-rib665 sym688 subst689 marks690 symnames692 fst691))))))))) (cond ((symbol? id662) (or (call-with-values (lambda () (search664 id662 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x694 . ignore693) x694)) id662)) ((syntax-object?95 id662) (let ((id695 (let ((e697 (syntax-object-expression96 id662))) (if (annotation? e697) (annotation-expression e697) e697))) (w1696 (syntax-object-wrap97 id662))) (let ((marks698 (join-marks131 (wrap-marks114 w663) (wrap-marks114 w1696)))) (call-with-values (lambda () (search664 id695 (wrap-subst115 w663) marks698)) (lambda (new-id699 marks700) (or new-id699 (call-with-values (lambda () (search664 id695 (wrap-subst115 w1696) marks700)) (lambda (x702 . ignore701) x702)) id695)))))) ((annotation? id662) (let ((id703 (let ((e704 id662)) (if (annotation? e704) (annotation-expression e704) e704)))) (or (call-with-values (lambda () (search664 id703 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x706 . ignore705) x706)) id703))) (else (syntax-violation (quote id-var-name) "invalid id" id662)))))) (same-marks?132 (lambda (x707 y708) (or (eq? x707 y708) (and (not (null? x707)) (not (null? y708)) (eq? (car x707) (car y708)) (same-marks?132 (cdr x707) (cdr y708)))))) (join-marks131 (lambda (m1709 m2710) (smart-append129 m1709 m2710))) (join-wraps130 (lambda (w1711 w2712) (let ((m1713 (wrap-marks114 w1711)) (s1714 (wrap-subst115 w1711))) (if (null? m1713) (if (null? s1714) w2712 (make-wrap113 (wrap-marks114 w2712) (smart-append129 s1714 (wrap-subst115 w2712)))) (make-wrap113 (smart-append129 m1713 (wrap-marks114 w2712)) (smart-append129 s1714 (wrap-subst115 w2712))))))) (smart-append129 (lambda (m1715 m2716) (if (null? m2716) m1715 (append m1715 m2716)))) (make-binding-wrap128 (lambda (ids717 labels718 w719) (if (null? ids717) w719 (make-wrap113 (wrap-marks114 w719) (cons (let ((labelvec720 (list->vector labels718))) (let ((n721 (vector-length labelvec720))) (let ((symnamevec722 (make-vector n721)) (marksvec723 (make-vector n721))) (begin (letrec ((f724 (lambda (ids725 i726) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks112 (car ids725) w719)) (lambda (symname727 marks728) (begin (vector-set! symnamevec722 i726 symname727) (vector-set! marksvec723 i726 marks728) (f724 (cdr ids725) (fx+71 i726 1))))))))) (f724 ids717 0)) (make-ribcage118 symnamevec722 marksvec723 labelvec720))))) (wrap-subst115 w719)))))) (extend-ribcage!127 (lambda (ribcage729 id730 label731) (begin (set-ribcage-symnames!123 ribcage729 (cons (let ((e732 (syntax-object-expression96 id730))) (if (annotation? e732) (annotation-expression e732) e732)) (ribcage-symnames120 ribcage729))) (set-ribcage-marks!124 ribcage729 (cons (wrap-marks114 (syntax-object-wrap97 id730)) (ribcage-marks121 ribcage729))) (set-ribcage-labels!125 ribcage729 (cons label731 (ribcage-labels122 ribcage729)))))) (anti-mark126 (lambda (w733) (make-wrap113 (cons #f (wrap-marks114 w733)) (cons (quote shift) (wrap-subst115 w733))))) (set-ribcage-labels!125 (lambda (x734 update735) (vector-set! x734 3 update735))) (set-ribcage-marks!124 (lambda (x736 update737) (vector-set! x736 2 update737))) (set-ribcage-symnames!123 (lambda (x738 update739) (vector-set! x738 1 update739))) (ribcage-labels122 (lambda (x740) (vector-ref x740 3))) (ribcage-marks121 (lambda (x741) (vector-ref x741 2))) (ribcage-symnames120 (lambda (x742) (vector-ref x742 1))) (ribcage?119 (lambda (x743) (and (vector? x743) (= (vector-length x743) 4) (eq? (vector-ref x743 0) (quote ribcage))))) (make-ribcage118 (lambda (symnames744 marks745 labels746) (vector (quote ribcage) symnames744 marks745 labels746))) (gen-labels117 (lambda (ls747) (if (null? ls747) (quote ()) (cons (gen-label116) (gen-labels117 (cdr ls747)))))) (gen-label116 (lambda () (string #\i))) (wrap-subst115 cdr) (wrap-marks114 car) (make-wrap113 cons) (id-sym-name&marks112 (lambda (x748 w749) (if (syntax-object?95 x748) (values (let ((e750 (syntax-object-expression96 x748))) (if (annotation? e750) (annotation-expression e750) e750)) (join-marks131 (wrap-marks114 w749) (wrap-marks114 (syntax-object-wrap97 x748)))) (values (let ((e751 x748)) (if (annotation? e751) (annotation-expression e751) e751)) (wrap-marks114 w749))))) (id?111 (lambda (x752) (cond ((symbol? x752) #t) ((syntax-object?95 x752) (symbol? (let ((e753 (syntax-object-expression96 x752))) (if (annotation? e753) (annotation-expression e753) e753)))) ((annotation? x752) (symbol? (annotation-expression x752))) (else #f)))) (nonsymbol-id?110 (lambda (x754) (and (syntax-object?95 x754) (symbol? (let ((e755 (syntax-object-expression96 x754))) (if (annotation? e755) (annotation-expression e755) e755)))))) (global-extend109 (lambda (type756 sym757 val758) (put-global-definition-hook77 sym757 type756 val758))) (lookup108 (lambda (x759 r760 mod761) (cond ((assq x759 r760) => cdr) ((symbol? x759) (or (get-global-definition-hook78 x759 mod761) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env107 (lambda (r762) (if (null? r762) (quote ()) (let ((a763 (car r762))) (if (eq? (cadr a763) (quote macro)) (cons a763 (macros-only-env107 (cdr r762))) (macros-only-env107 (cdr r762))))))) (extend-var-env106 (lambda (labels764 vars765 r766) (if (null? labels764) r766 (extend-var-env106 (cdr labels764) (cdr vars765) (cons (cons (car labels764) (cons (quote lexical) (car vars765))) r766))))) (extend-env105 (lambda (labels767 bindings768 r769) (if (null? labels767) r769 (extend-env105 (cdr labels767) (cdr bindings768) (cons (cons (car labels767) (car bindings768)) r769))))) (binding-value104 cdr) (binding-type103 car) (source-annotation102 (lambda (x770) (cond ((annotation? x770) (annotation-source x770)) ((syntax-object?95 x770) (source-annotation102 (syntax-object-expression96 x770))) (else #f)))) (set-syntax-object-module!101 (lambda (x771 update772) (vector-set! x771 3 update772))) (set-syntax-object-wrap!100 (lambda (x773 update774) (vector-set! x773 2 update774))) (set-syntax-object-expression!99 (lambda (x775 update776) (vector-set! x775 1 update776))) (syntax-object-module98 (lambda (x777) (vector-ref x777 3))) (syntax-object-wrap97 (lambda (x778) (vector-ref x778 2))) (syntax-object-expression96 (lambda (x779) (vector-ref x779 1))) (syntax-object?95 (lambda (x780) (and (vector? x780) (= (vector-length x780) 4) (eq? (vector-ref x780 0) (quote syntax-object))))) (make-syntax-object94 (lambda (expression781 wrap782 module783) (vector (quote syntax-object) expression781 wrap782 module783))) (build-letrec93 (lambda (src784 ids785 vars786 val-exps787 body-exp788) (if (null? vars786) body-exp788 (let ((t789 (fluid-ref *mode*70))) (if (memv t789 (quote (c))) ((@ (language tree-il) make-letrec) src784 vars786 val-exps787 body-exp788) (list (quote letrec) (map list vars786 val-exps787) body-exp788)))))) (build-named-let92 (lambda (src790 ids791 vars792 val-exps793 body-exp794) (let ((f795 (car vars792)) (f-name796 (car ids791)) (vars797 (cdr vars792)) (ids798 (cdr ids791))) (let ((t799 (fluid-ref *mode*70))) (if (memv t799 (quote (c))) ((@ (language tree-il) make-letrec) src790 (list f795) (list (build-lambda87 src790 ids798 vars797 #f body-exp794)) (build-application79 src790 (build-lexical-reference81 (quote fun) src790 f-name796 f795) val-exps793)) (list (quote let) f795 (map list vars797 val-exps793) body-exp794)))))) (build-let91 (lambda (src800 ids801 vars802 val-exps803 body-exp804) (if (null? vars802) body-exp804 (let ((t805 (fluid-ref *mode*70))) (if (memv t805 (quote (c))) ((@ (language tree-il) make-let) src800 vars802 val-exps803 body-exp804) (list (quote let) (map list vars802 val-exps803) body-exp804)))))) (build-sequence90 (lambda (src806 exps807) (if (null? (cdr exps807)) (car exps807) (let ((t808 (fluid-ref *mode*70))) (if (memv t808 (quote (c))) ((@ (language tree-il) make-sequence) src806 exps807) (cons (quote begin) exps807)))))) (build-data89 (lambda (src809 exp810) (let ((t811 (fluid-ref *mode*70))) (if (memv t811 (quote (c))) ((@ (language tree-il) make-const) src809 exp810) (if (and (self-evaluating? exp810) (not (vector? exp810))) exp810 (list (quote quote) exp810)))))) (build-primref88 (lambda (src812 name813) (let ((t814 (fluid-ref *mode*70))) (if (memv t814 (quote (c))) ((@ (language tree-il) make-primitive-ref) src812 name813) (build-global-reference84 src812 name813 (quote (hygiene guile))))))) (build-lambda87 (lambda (src815 ids816 vars817 docstring818 exp819) (let ((t820 (fluid-ref *mode*70))) (if (memv t820 (quote (c))) ((@ (language tree-il) make-lambda) src815 vars817 (if docstring818 (list (cons (quote documentation) docstring818)) (quote ())) exp819) (cons (quote lambda) (cons vars817 (append (if docstring818 (list docstring818) (quote ())) (list exp819)))))))) (build-global-definition86 (lambda (source821 var822 exp823) (let ((t824 (fluid-ref *mode*70))) (if (memv t824 (quote (c))) ((@ (language tree-il) make-toplevel-define) source821 var822 exp823) (list (quote define) var822 exp823))))) (build-global-assignment85 (lambda (source825 var826 exp827 mod828) (analyze-variable83 mod828 var826 (lambda (mod829 var830 public?831) (let ((t832 (fluid-ref *mode*70))) (if (memv t832 (quote (c))) ((@ (language tree-il) make-module-set) source825 mod829 var830 public?831 exp827) (list (quote set!) (list (if public?831 (quote @) (quote @@)) mod829 var830) exp827)))) (lambda (var833) (let ((t834 (fluid-ref *mode*70))) (if (memv t834 (quote (c))) ((@ (language tree-il) make-toplevel-set) source825 var833 exp827) (list (quote set!) var833 exp827))))))) (build-global-reference84 (lambda (source835 var836 mod837) (analyze-variable83 mod837 var836 (lambda (mod838 var839 public?840) (let ((t841 (fluid-ref *mode*70))) (if (memv t841 (quote (c))) ((@ (language tree-il) make-module-ref) source835 mod838 var839 public?840) (list (if public?840 (quote @) (quote @@)) mod838 var839)))) (lambda (var842) (let ((t843 (fluid-ref *mode*70))) (if (memv t843 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source835 var842) var842)))))) (analyze-variable83 (lambda (mod844 var845 modref-cont846 bare-cont847) (if (not mod844) (bare-cont847 var845) (let ((kind848 (car mod844)) (mod849 (cdr mod844))) (let ((t850 kind848)) (if (memv t850 (quote (public))) (modref-cont846 mod849 var845 #t) (if (memv t850 (quote (private))) (if (not (equal? mod849 (module-name (current-module)))) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (if (memv t850 (quote (bare))) (bare-cont847 var845) (if (memv t850 (quote (hygiene))) (if (and (not (equal? mod849 (module-name (current-module)))) (module-variable (resolve-module mod849) var845)) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (syntax-violation #f "bad module kind" var845 mod849)))))))))) (build-lexical-assignment82 (lambda (source851 name852 var853 exp854) (let ((t855 (fluid-ref *mode*70))) (if (memv t855 (quote (c))) ((@ (language tree-il) make-lexical-set) source851 name852 var853 exp854) (list (quote set!) var853 exp854))))) (build-lexical-reference81 (lambda (type856 source857 name858 var859) (let ((t860 (fluid-ref *mode*70))) (if (memv t860 (quote (c))) ((@ (language tree-il) make-lexical-ref) source857 name858 var859) var859)))) (build-conditional80 (lambda (source861 test-exp862 then-exp863 else-exp864) (let ((t865 (fluid-ref *mode*70))) (if (memv t865 (quote (c))) ((@ (language tree-il) make-conditional) source861 test-exp862 then-exp863 else-exp864) (list (quote if) test-exp862 then-exp863 else-exp864))))) (build-application79 (lambda (source866 fun-exp867 arg-exps868) (let ((t869 (fluid-ref *mode*70))) (if (memv t869 (quote (c))) ((@ (language tree-il) make-application) source866 fun-exp867 arg-exps868) (cons fun-exp867 arg-exps868))))) (get-global-definition-hook78 (lambda (symbol870 module871) (begin (if (and (not module871) (current-module)) (warn "module system is booted, we should have a module" symbol870)) (let ((v872 (module-variable (if module871 (resolve-module (cdr module871)) (current-module)) symbol870))) (and v872 (variable-bound? v872) (let ((val873 (variable-ref v872))) (and (macro? val873) (syncase-macro-type val873) (cons (syncase-macro-type val873) (syncase-macro-binding val873))))))))) (put-global-definition-hook77 (lambda (symbol874 type875 val876) (let ((existing877 (let ((v878 (module-variable (current-module) symbol874))) (and v878 (variable-bound? v878) (let ((val879 (variable-ref v878))) (and (macro? val879) (not (syncase-macro-type val879)) val879)))))) (module-define! (current-module) symbol874 (if existing877 (make-extended-syncase-macro existing877 type875 val876) (make-syncase-macro type875 val876)))))) (local-eval-hook76 (lambda (x880 mod881) (primitive-eval (list noexpand69 (let ((t882 (fluid-ref *mode*70))) (if (memv t882 (quote (c))) ((@ (language tree-il) tree-il->scheme) x880) x880)))))) (top-level-eval-hook75 (lambda (x883 mod884) (primitive-eval (list noexpand69 (let ((t885 (fluid-ref *mode*70))) (if (memv t885 (quote (c))) ((@ (language tree-il) tree-il->scheme) x883) x883)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend109 (quote local-syntax) (quote letrec-syntax) #t) (global-extend109 (quote local-syntax) (quote let-syntax) #f) (global-extend109 (quote core) (quote fluid-let-syntax) (lambda (e886 r887 w888 s889 mod890) ((lambda (tmp891) ((lambda (tmp892) (if (if tmp892 (apply (lambda (_893 var894 val895 e1896 e2897) (valid-bound-ids?136 var894)) tmp892) #f) (apply (lambda (_899 var900 val901 e1902 e2903) (let ((names904 (map (lambda (x905) (id-var-name133 x905 w888)) var900))) (begin (for-each (lambda (id907 n908) (let ((t909 (binding-type103 (lookup108 n908 r887 mod890)))) (if (memv t909 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e886 (source-wrap140 id907 w888 s889 mod890))))) var900 names904) (chi-body151 (cons e1902 e2903) (source-wrap140 e886 w888 s889 mod890) (extend-env105 names904 (let ((trans-r912 (macros-only-env107 r887))) (map (lambda (x913) (cons (quote macro) (eval-local-transformer154 (chi147 x913 trans-r912 w888 mod890) mod890))) val901)) r887) w888 mod890)))) tmp892) ((lambda (_915) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap140 e886 w888 s889 mod890))) tmp891))) ($sc-dispatch tmp891 (quote (any #(each (any any)) any . each-any))))) e886))) (global-extend109 (quote core) (quote quote) (lambda (e916 r917 w918 s919 mod920) ((lambda (tmp921) ((lambda (tmp922) (if tmp922 (apply (lambda (_923 e924) (build-data89 s919 (strip158 e924 w918))) tmp922) ((lambda (_925) (syntax-violation (quote quote) "bad syntax" (source-wrap140 e916 w918 s919 mod920))) tmp921))) ($sc-dispatch tmp921 (quote (any any))))) e916))) (global-extend109 (quote core) (quote syntax) (letrec ((regen933 (lambda (x934) (let ((t935 (car x934))) (if (memv t935 (quote (ref))) (build-lexical-reference81 (quote value) #f (cadr x934) (cadr x934)) (if (memv t935 (quote (primitive))) (build-primref88 #f (cadr x934)) (if (memv t935 (quote (quote))) (build-data89 #f (cadr x934)) (if (memv t935 (quote (lambda))) (build-lambda87 #f (cadr x934) (cadr x934) #f (regen933 (caddr x934))) (if (memv t935 (quote (map))) (let ((ls936 (map regen933 (cdr x934)))) (build-application79 #f (build-primref88 #f (quote map)) ls936)) (build-application79 #f (build-primref88 #f (car x934)) (map regen933 (cdr x934))))))))))) (gen-vector932 (lambda (x937) (cond ((eq? (car x937) (quote list)) (cons (quote vector) (cdr x937))) ((eq? (car x937) (quote quote)) (list (quote quote) (list->vector (cadr x937)))) (else (list (quote list->vector) x937))))) (gen-append931 (lambda (x938 y939) (if (equal? y939 (quote (quote ()))) x938 (list (quote append) x938 y939)))) (gen-cons930 (lambda (x940 y941) (let ((t942 (car y941))) (if (memv t942 (quote (quote))) (if (eq? (car x940) (quote quote)) (list (quote quote) (cons (cadr x940) (cadr y941))) (if (eq? (cadr y941) (quote ())) (list (quote list) x940) (list (quote cons) x940 y941))) (if (memv t942 (quote (list))) (cons (quote list) (cons x940 (cdr y941))) (list (quote cons) x940 y941)))))) (gen-map929 (lambda (e943 map-env944) (let ((formals945 (map cdr map-env944)) (actuals946 (map (lambda (x947) (list (quote ref) (car x947))) map-env944))) (cond ((eq? (car e943) (quote ref)) (car actuals946)) ((and-map (lambda (x948) (and (eq? (car x948) (quote ref)) (memq (cadr x948) formals945))) (cdr e943)) (cons (quote map) (cons (list (quote primitive) (car e943)) (map (let ((r949 (map cons formals945 actuals946))) (lambda (x950) (cdr (assq (cadr x950) r949)))) (cdr e943))))) (else (cons (quote map) (cons (list (quote lambda) formals945 e943) actuals946))))))) (gen-mappend928 (lambda (e951 map-env952) (list (quote apply) (quote (primitive append)) (gen-map929 e951 map-env952)))) (gen-ref927 (lambda (src953 var954 level955 maps956) (if (fx=73 level955 0) (values var954 maps956) (if (null? maps956) (syntax-violation (quote syntax) "missing ellipsis" src953) (call-with-values (lambda () (gen-ref927 src953 var954 (fx-72 level955 1) (cdr maps956))) (lambda (outer-var957 outer-maps958) (let ((b959 (assq outer-var957 (car maps956)))) (if b959 (values (cdr b959) maps956) (let ((inner-var960 (gen-var159 (quote tmp)))) (values inner-var960 (cons (cons (cons outer-var957 inner-var960) (car maps956)) outer-maps958))))))))))) (gen-syntax926 (lambda (src961 e962 r963 maps964 ellipsis?965 mod966) (if (id?111 e962) (let ((label967 (id-var-name133 e962 (quote (()))))) (let ((b968 (lookup108 label967 r963 mod966))) (if (eq? (binding-type103 b968) (quote syntax)) (call-with-values (lambda () (let ((var.lev969 (binding-value104 b968))) (gen-ref927 src961 (car var.lev969) (cdr var.lev969) maps964))) (lambda (var970 maps971) (values (list (quote ref) var970) maps971))) (if (ellipsis?965 e962) (syntax-violation (quote syntax) "misplaced ellipsis" src961) (values (list (quote quote) e962) maps964))))) ((lambda (tmp972) ((lambda (tmp973) (if (if tmp973 (apply (lambda (dots974 e975) (ellipsis?965 dots974)) tmp973) #f) (apply (lambda (dots976 e977) (gen-syntax926 src961 e977 r963 maps964 (lambda (x978) #f) mod966)) tmp973) ((lambda (tmp979) (if (if tmp979 (apply (lambda (x980 dots981 y982) (ellipsis?965 dots981)) tmp979) #f) (apply (lambda (x983 dots984 y985) (letrec ((f986 (lambda (y987 k988) ((lambda (tmp992) ((lambda (tmp993) (if (if tmp993 (apply (lambda (dots994 y995) (ellipsis?965 dots994)) tmp993) #f) (apply (lambda (dots996 y997) (f986 y997 (lambda (maps998) (call-with-values (lambda () (k988 (cons (quote ()) maps998))) (lambda (x999 maps1000) (if (null? (car maps1000)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-mappend928 x999 (car maps1000)) (cdr maps1000)))))))) tmp993) ((lambda (_1001) (call-with-values (lambda () (gen-syntax926 src961 y987 r963 maps964 ellipsis?965 mod966)) (lambda (y1002 maps1003) (call-with-values (lambda () (k988 maps1003)) (lambda (x1004 maps1005) (values (gen-append931 x1004 y1002) maps1005)))))) tmp992))) ($sc-dispatch tmp992 (quote (any . any))))) y987)))) (f986 y985 (lambda (maps989) (call-with-values (lambda () (gen-syntax926 src961 x983 r963 (cons (quote ()) maps989) ellipsis?965 mod966)) (lambda (x990 maps991) (if (null? (car maps991)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-map929 x990 (car maps991)) (cdr maps991))))))))) tmp979) ((lambda (tmp1006) (if tmp1006 (apply (lambda (x1007 y1008) (call-with-values (lambda () (gen-syntax926 src961 x1007 r963 maps964 ellipsis?965 mod966)) (lambda (x1009 maps1010) (call-with-values (lambda () (gen-syntax926 src961 y1008 r963 maps1010 ellipsis?965 mod966)) (lambda (y1011 maps1012) (values (gen-cons930 x1009 y1011) maps1012)))))) tmp1006) ((lambda (tmp1013) (if tmp1013 (apply (lambda (e11014 e21015) (call-with-values (lambda () (gen-syntax926 src961 (cons e11014 e21015) r963 maps964 ellipsis?965 mod966)) (lambda (e1017 maps1018) (values (gen-vector932 e1017) maps1018)))) tmp1013) ((lambda (_1019) (values (list (quote quote) e962) maps964)) tmp972))) ($sc-dispatch tmp972 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp972 (quote (any . any)))))) ($sc-dispatch tmp972 (quote (any any . any)))))) ($sc-dispatch tmp972 (quote (any any))))) e962))))) (lambda (e1020 r1021 w1022 s1023 mod1024) (let ((e1025 (source-wrap140 e1020 w1022 s1023 mod1024))) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda (_1028 x1029) (call-with-values (lambda () (gen-syntax926 e1025 x1029 r1021 (quote ()) ellipsis?156 mod1024)) (lambda (e1030 maps1031) (regen933 e1030)))) tmp1027) ((lambda (_1032) (syntax-violation (quote syntax) "bad `syntax' form" e1025)) tmp1026))) ($sc-dispatch tmp1026 (quote (any any))))) e1025))))) (global-extend109 (quote core) (quote lambda) (lambda (e1033 r1034 w1035 s1036 mod1037) ((lambda (tmp1038) ((lambda (tmp1039) (if tmp1039 (apply (lambda (_1040 c1041) (chi-lambda-clause152 (source-wrap140 e1033 w1035 s1036 mod1037) #f c1041 r1034 w1035 mod1037 (lambda (names1042 vars1043 docstring1044 body1045) (build-lambda87 s1036 names1042 vars1043 docstring1044 body1045)))) tmp1039) (syntax-violation #f "source expression failed to match any pattern" tmp1038))) ($sc-dispatch tmp1038 (quote (any . any))))) e1033))) (global-extend109 (quote core) (quote let) (letrec ((chi-let1046 (lambda (e1047 r1048 w1049 s1050 mod1051 constructor1052 ids1053 vals1054 exps1055) (if (not (valid-bound-ids?136 ids1053)) (syntax-violation (quote let) "duplicate bound variable" e1047) (let ((labels1056 (gen-labels117 ids1053)) (new-vars1057 (map gen-var159 ids1053))) (let ((nw1058 (make-binding-wrap128 ids1053 labels1056 w1049)) (nr1059 (extend-var-env106 labels1056 new-vars1057 r1048))) (constructor1052 s1050 (map syntax->datum ids1053) new-vars1057 (map (lambda (x1060) (chi147 x1060 r1048 w1049 mod1051)) vals1054) (chi-body151 exps1055 (source-wrap140 e1047 nw1058 s1050 mod1051) nr1059 nw1058 mod1051)))))))) (lambda (e1061 r1062 w1063 s1064 mod1065) ((lambda (tmp1066) ((lambda (tmp1067) (if tmp1067 (apply (lambda (_1068 id1069 val1070 e11071 e21072) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-let91 id1069 val1070 (cons e11071 e21072))) tmp1067) ((lambda (tmp1076) (if (if tmp1076 (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (id?111 f1078)) tmp1076) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-named-let92 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1076) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap140 e1061 w1063 s1064 mod1065))) tmp1066))) ($sc-dispatch tmp1066 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1066 (quote (any #(each (any any)) any . each-any))))) e1061)))) (global-extend109 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (let ((ids1105 id1101)) (if (not (valid-bound-ids?136 ids1105)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1107 (gen-labels117 ids1105)) (new-vars1108 (map gen-var159 ids1105))) (let ((w1109 (make-binding-wrap128 ids1105 labels1107 w1095)) (r1110 (extend-var-env106 labels1107 new-vars1108 r1094))) (build-letrec93 s1096 (map syntax->datum ids1105) new-vars1108 (map (lambda (x1111) (chi147 x1111 r1110 w1109 mod1097)) val1102) (chi-body151 (cons e11103 e21104) (source-wrap140 e1093 w1109 s1096 mod1097) r1110 w1109 mod1097))))))) tmp1099) ((lambda (_1114) (syntax-violation (quote letrec) "bad letrec" (source-wrap140 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend109 (quote core) (quote set!) (lambda (e1115 r1116 w1117 s1118 mod1119) ((lambda (tmp1120) ((lambda (tmp1121) (if (if tmp1121 (apply (lambda (_1122 id1123 val1124) (id?111 id1123)) tmp1121) #f) (apply (lambda (_1125 id1126 val1127) (let ((val1128 (chi147 val1127 r1116 w1117 mod1119)) (n1129 (id-var-name133 id1126 w1117))) (let ((b1130 (lookup108 n1129 r1116 mod1119))) (let ((t1131 (binding-type103 b1130))) (if (memv t1131 (quote (lexical))) (build-lexical-assignment82 s1118 (syntax->datum id1126) (binding-value104 b1130) val1128) (if (memv t1131 (quote (global))) (build-global-assignment85 s1118 n1129 val1128 mod1119) (if (memv t1131 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap139 id1126 w1117 mod1119)) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))))))))) tmp1121) ((lambda (tmp1132) (if tmp1132 (apply (lambda (_1133 head1134 tail1135 val1136) (call-with-values (lambda () (syntax-type145 head1134 r1116 (quote (())) #f #f mod1119)) (lambda (type1137 value1138 ee1139 ww1140 ss1141 modmod1142) (let ((t1143 type1137)) (if (memv t1143 (quote (module-ref))) (let ((val1144 (chi147 val1136 r1116 w1117 mod1119))) (call-with-values (lambda () (value1138 (cons head1134 tail1135))) (lambda (id1146 mod1147) (build-global-assignment85 s1118 id1146 val1144 mod1147)))) (build-application79 s1118 (chi147 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1134) r1116 w1117 mod1119) (map (lambda (e1148) (chi147 e1148 r1116 w1117 mod1119)) (append tail1135 (list val1136))))))))) tmp1132) ((lambda (_1150) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))) tmp1120))) ($sc-dispatch tmp1120 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1120 (quote (any any any))))) e1115))) (global-extend109 (quote module-ref) (quote @) (lambda (e1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 mod1155 id1156) (and (and-map id?111 mod1155) (id?111 id1156))) tmp1153) #f) (apply (lambda (_1158 mod1159 id1160) (values (syntax->datum id1160) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1159)))) tmp1153) (syntax-violation #f "source expression failed to match any pattern" tmp1152))) ($sc-dispatch tmp1152 (quote (any each-any any))))) e1151))) (global-extend109 (quote module-ref) (quote @@) (lambda (e1162) ((lambda (tmp1163) ((lambda (tmp1164) (if (if tmp1164 (apply (lambda (_1165 mod1166 id1167) (and (and-map id?111 mod1166) (id?111 id1167))) tmp1164) #f) (apply (lambda (_1169 mod1170 id1171) (values (syntax->datum id1171) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1170)))) tmp1164) (syntax-violation #f "source expression failed to match any pattern" tmp1163))) ($sc-dispatch tmp1163 (quote (any each-any any))))) e1162))) (global-extend109 (quote begin) (quote begin) (quote ())) (global-extend109 (quote define) (quote define) (quote ())) (global-extend109 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend109 (quote eval-when) (quote eval-when) (quote ())) (global-extend109 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1176 (lambda (x1177 keys1178 clauses1179 r1180 mod1181) (if (null? clauses1179) (build-application79 #f (build-primref88 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1177)) ((lambda (tmp1182) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 exp1185) (if (and (id?111 pat1184) (and-map (lambda (x1186) (not (free-id=?134 pat1184 x1186))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1178))) (let ((labels1187 (list (gen-label116))) (var1188 (gen-var159 pat1184))) (build-application79 #f (build-lambda87 #f (list (syntax->datum pat1184)) (list var1188) #f (chi147 exp1185 (extend-env105 labels1187 (list (cons (quote syntax) (cons var1188 0))) r1180) (make-binding-wrap128 (list pat1184) labels1187 (quote (()))) mod1181)) (list x1177))) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1184 #t exp1185 mod1181))) tmp1183) ((lambda (tmp1189) (if tmp1189 (apply (lambda (pat1190 fender1191 exp1192) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1190 fender1191 exp1192 mod1181)) tmp1189) ((lambda (_1193) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1179))) tmp1182))) ($sc-dispatch tmp1182 (quote (any any any)))))) ($sc-dispatch tmp1182 (quote (any any))))) (car clauses1179))))) (gen-clause1175 (lambda (x1194 keys1195 clauses1196 r1197 pat1198 fender1199 exp1200 mod1201) (call-with-values (lambda () (convert-pattern1173 pat1198 keys1195)) (lambda (p1202 pvars1203) (cond ((not (distinct-bound-ids?137 (map car pvars1203))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1198)) ((not (and-map (lambda (x1204) (not (ellipsis?156 (car x1204)))) pvars1203)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1198)) (else (let ((y1205 (gen-var159 (quote tmp)))) (build-application79 #f (build-lambda87 #f (list (quote tmp)) (list y1205) #f (let ((y1206 (build-lexical-reference81 (quote value) #f (quote tmp) y1205))) (build-conditional80 #f ((lambda (tmp1207) ((lambda (tmp1208) (if tmp1208 (apply (lambda () y1206) tmp1208) ((lambda (_1209) (build-conditional80 #f y1206 (build-dispatch-call1174 pvars1203 fender1199 y1206 r1197 mod1201) (build-data89 #f #f))) tmp1207))) ($sc-dispatch tmp1207 (quote #(atom #t))))) fender1199) (build-dispatch-call1174 pvars1203 exp1200 y1206 r1197 mod1201) (gen-syntax-case1176 x1194 keys1195 clauses1196 r1197 mod1201)))) (list (if (eq? p1202 (quote any)) (build-application79 #f (build-primref88 #f (quote list)) (list x1194)) (build-application79 #f (build-primref88 #f (quote $sc-dispatch)) (list x1194 (build-data89 #f p1202))))))))))))) (build-dispatch-call1174 (lambda (pvars1210 exp1211 y1212 r1213 mod1214) (let ((ids1215 (map car pvars1210)) (levels1216 (map cdr pvars1210))) (let ((labels1217 (gen-labels117 ids1215)) (new-vars1218 (map gen-var159 ids1215))) (build-application79 #f (build-primref88 #f (quote apply)) (list (build-lambda87 #f (map syntax->datum ids1215) new-vars1218 #f (chi147 exp1211 (extend-env105 labels1217 (map (lambda (var1219 level1220) (cons (quote syntax) (cons var1219 level1220))) new-vars1218 (map cdr pvars1210)) r1213) (make-binding-wrap128 ids1215 labels1217 (quote (()))) mod1214)) y1212)))))) (convert-pattern1173 (lambda (pattern1221 keys1222) (letrec ((cvt1223 (lambda (p1224 n1225 ids1226) (if (id?111 p1224) (if (bound-id-member?138 p1224 keys1222) (values (vector (quote free-id) p1224) ids1226) (values (quote any) (cons (cons p1224 n1225) ids1226))) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (x1229 dots1230) (ellipsis?156 dots1230)) tmp1228) #f) (apply (lambda (x1231 dots1232) (call-with-values (lambda () (cvt1223 x1231 (fx+71 n1225 1) ids1226)) (lambda (p1233 ids1234) (values (if (eq? p1233 (quote any)) (quote each-any) (vector (quote each) p1233)) ids1234)))) tmp1228) ((lambda (tmp1235) (if tmp1235 (apply (lambda (x1236 y1237) (call-with-values (lambda () (cvt1223 y1237 n1225 ids1226)) (lambda (y1238 ids1239) (call-with-values (lambda () (cvt1223 x1236 n1225 ids1239)) (lambda (x1240 ids1241) (values (cons x1240 y1238) ids1241)))))) tmp1235) ((lambda (tmp1242) (if tmp1242 (apply (lambda () (values (quote ()) ids1226)) tmp1242) ((lambda (tmp1243) (if tmp1243 (apply (lambda (x1244) (call-with-values (lambda () (cvt1223 x1244 n1225 ids1226)) (lambda (p1246 ids1247) (values (vector (quote vector) p1246) ids1247)))) tmp1243) ((lambda (x1248) (values (vector (quote atom) (strip158 p1224 (quote (())))) ids1226)) tmp1227))) ($sc-dispatch tmp1227 (quote #(vector each-any)))))) ($sc-dispatch tmp1227 (quote ()))))) ($sc-dispatch tmp1227 (quote (any . any)))))) ($sc-dispatch tmp1227 (quote (any any))))) p1224))))) (cvt1223 pattern1221 0 (quote ())))))) (lambda (e1249 r1250 w1251 s1252 mod1253) (let ((e1254 (source-wrap140 e1249 w1251 s1252 mod1253))) ((lambda (tmp1255) ((lambda (tmp1256) (if tmp1256 (apply (lambda (_1257 val1258 key1259 m1260) (if (and-map (lambda (x1261) (and (id?111 x1261) (not (ellipsis?156 x1261)))) key1259) (let ((x1263 (gen-var159 (quote tmp)))) (build-application79 s1252 (build-lambda87 #f (list (quote tmp)) (list x1263) #f (gen-syntax-case1176 (build-lexical-reference81 (quote value) #f (quote tmp) x1263) key1259 m1260 r1250 mod1253)) (list (chi147 val1258 r1250 (quote (())) mod1253)))) (syntax-violation (quote syntax-case) "invalid literals list" e1254))) tmp1256) (syntax-violation #f "source expression failed to match any pattern" tmp1255))) ($sc-dispatch tmp1255 (quote (any any each-any . each-any))))) e1254))))) (set! sc-expand (lambda (x1267 . rest1266) (if (and (pair? x1267) (equal? (car x1267) noexpand69)) (cadr x1267) (let ((m1268 (if (null? rest1266) (quote e) (car rest1266))) (esew1269 (if (or (null? rest1266) (null? (cdr rest1266))) (quote (eval)) (cadr rest1266)))) (with-fluid* *mode*70 m1268 (lambda () (chi-top146 x1267 (quote ()) (quote ((top))) m1268 esew1269 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1270) (nonsymbol-id?110 x1270))) (set! datum->syntax (lambda (id1271 datum1272) (make-syntax-object94 datum1272 (syntax-object-wrap97 id1271) #f))) (set! syntax->datum (lambda (x1273) (strip158 x1273 (quote (()))))) (set! generate-temporaries (lambda (ls1274) (begin (let ((x1275 ls1274)) (if (not (list? x1275)) (syntax-violation (quote generate-temporaries) "invalid argument" x1275))) (map (lambda (x1276) (wrap139 (gensym) (quote ((top))) #f)) ls1274)))) (set! free-identifier=? (lambda (x1277 y1278) (begin (let ((x1279 x1277)) (if (not (nonsymbol-id?110 x1279)) (syntax-violation (quote free-identifier=?) "invalid argument" x1279))) (let ((x1280 y1278)) (if (not (nonsymbol-id?110 x1280)) (syntax-violation (quote free-identifier=?) "invalid argument" x1280))) (free-id=?134 x1277 y1278)))) (set! bound-identifier=? (lambda (x1281 y1282) (begin (let ((x1283 x1281)) (if (not (nonsymbol-id?110 x1283)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1283))) (let ((x1284 y1282)) (if (not (nonsymbol-id?110 x1284)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1284))) (bound-id=?135 x1281 y1282)))) (set! syntax-violation (lambda (who1288 message1287 form1286 . subform1285) (begin (let ((x1289 who1288)) (if (not ((lambda (x1290) (or (not x1290) (string? x1290) (symbol? x1290))) x1289)) (syntax-violation (quote syntax-violation) "invalid argument" x1289))) (let ((x1291 message1287)) (if (not (string? x1291)) (syntax-violation (quote syntax-violation) "invalid argument" x1291))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1288 "~a: " "") "~a " (if (null? subform1285) "in ~a" "in subform `~s' of `~s'")) (let ((tail1292 (cons message1287 (map (lambda (x1293) (strip158 x1293 (quote (())))) (append subform1285 (list form1286)))))) (if who1288 (cons who1288 tail1292) tail1292)) #f)))) (letrec ((match1298 (lambda (e1299 p1300 w1301 r1302 mod1303) (cond ((not r1302) #f) ((eq? p1300 (quote any)) (cons (wrap139 e1299 w1301 mod1303) r1302)) ((syntax-object?95 e1299) (match*1297 (let ((e1304 (syntax-object-expression96 e1299))) (if (annotation? e1304) (annotation-expression e1304) e1304)) p1300 (join-wraps130 w1301 (syntax-object-wrap97 e1299)) r1302 (syntax-object-module98 e1299))) (else (match*1297 (let ((e1305 e1299)) (if (annotation? e1305) (annotation-expression e1305) e1305)) p1300 w1301 r1302 mod1303))))) (match*1297 (lambda (e1306 p1307 w1308 r1309 mod1310) (cond ((null? p1307) (and (null? e1306) r1309)) ((pair? p1307) (and (pair? e1306) (match1298 (car e1306) (car p1307) w1308 (match1298 (cdr e1306) (cdr p1307) w1308 r1309 mod1310) mod1310))) ((eq? p1307 (quote each-any)) (let ((l1311 (match-each-any1295 e1306 w1308 mod1310))) (and l1311 (cons l1311 r1309)))) (else (let ((t1312 (vector-ref p1307 0))) (if (memv t1312 (quote (each))) (if (null? e1306) (match-empty1296 (vector-ref p1307 1) r1309) (let ((l1313 (match-each1294 e1306 (vector-ref p1307 1) w1308 mod1310))) (and l1313 (letrec ((collect1314 (lambda (l1315) (if (null? (car l1315)) r1309 (cons (map car l1315) (collect1314 (map cdr l1315))))))) (collect1314 l1313))))) (if (memv t1312 (quote (free-id))) (and (id?111 e1306) (free-id=?134 (wrap139 e1306 w1308 mod1310) (vector-ref p1307 1)) r1309) (if (memv t1312 (quote (atom))) (and (equal? (vector-ref p1307 1) (strip158 e1306 w1308)) r1309) (if (memv t1312 (quote (vector))) (and (vector? e1306) (match1298 (vector->list e1306) (vector-ref p1307 1) w1308 r1309 mod1310))))))))))) (match-empty1296 (lambda (p1316 r1317) (cond ((null? p1316) r1317) ((eq? p1316 (quote any)) (cons (quote ()) r1317)) ((pair? p1316) (match-empty1296 (car p1316) (match-empty1296 (cdr p1316) r1317))) ((eq? p1316 (quote each-any)) (cons (quote ()) r1317)) (else (let ((t1318 (vector-ref p1316 0))) (if (memv t1318 (quote (each))) (match-empty1296 (vector-ref p1316 1) r1317) (if (memv t1318 (quote (free-id atom))) r1317 (if (memv t1318 (quote (vector))) (match-empty1296 (vector-ref p1316 1) r1317))))))))) (match-each-any1295 (lambda (e1319 w1320 mod1321) (cond ((annotation? e1319) (match-each-any1295 (annotation-expression e1319) w1320 mod1321)) ((pair? e1319) (let ((l1322 (match-each-any1295 (cdr e1319) w1320 mod1321))) (and l1322 (cons (wrap139 (car e1319) w1320 mod1321) l1322)))) ((null? e1319) (quote ())) ((syntax-object?95 e1319) (match-each-any1295 (syntax-object-expression96 e1319) (join-wraps130 w1320 (syntax-object-wrap97 e1319)) mod1321)) (else #f)))) (match-each1294 (lambda (e1323 p1324 w1325 mod1326) (cond ((annotation? e1323) (match-each1294 (annotation-expression e1323) p1324 w1325 mod1326)) ((pair? e1323) (let ((first1327 (match1298 (car e1323) p1324 w1325 (quote ()) mod1326))) (and first1327 (let ((rest1328 (match-each1294 (cdr e1323) p1324 w1325 mod1326))) (and rest1328 (cons first1327 rest1328)))))) ((null? e1323) (quote ())) ((syntax-object?95 e1323) (match-each1294 (syntax-object-expression96 e1323) p1324 (join-wraps130 w1325 (syntax-object-wrap97 e1323)) (syntax-object-module98 e1323))) (else #f))))) (set! $sc-dispatch (lambda (e1329 p1330) (cond ((eq? p1330 (quote any)) (list e1329)) ((syntax-object?95 e1329) (match*1297 (let ((e1331 (syntax-object-expression96 e1329))) (if (annotation? e1331) (annotation-expression e1331) e1331)) p1330 (syntax-object-wrap97 e1329) (quote ()) (syntax-object-module98 e1329))) (else (match*1297 (let ((e1332 e1329)) (if (annotation? e1332) (annotation-expression e1332) e1332)) p1330 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1333) ((lambda (tmp1334) ((lambda (tmp1335) (if tmp1335 (apply (lambda (_1336 e11337 e21338) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11337 e21338))) tmp1335) ((lambda (tmp1340) (if tmp1340 (apply (lambda (_1341 out1342 in1343 e11344 e21345) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1343 (quote ()) (list out1342 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11344 e21345))))) tmp1340) ((lambda (tmp1347) (if tmp1347 (apply (lambda (_1348 out1349 in1350 e11351 e21352) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1350) (quote ()) (list out1349 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11351 e21352))))) tmp1347) (syntax-violation #f "source expression failed to match any pattern" tmp1334))) ($sc-dispatch tmp1334 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any () any . each-any))))) x1333)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1356) ((lambda (tmp1357) ((lambda (tmp1358) (if tmp1358 (apply (lambda (_1359 k1360 keyword1361 pattern1362 template1363) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1360 (map (lambda (tmp1366 tmp1365) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1365) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1366))) template1363 pattern1362)))))) tmp1358) (syntax-violation #f "source expression failed to match any pattern" tmp1357))) ($sc-dispatch tmp1357 (quote (any each-any . #(each ((any . any) any))))))) x1356)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1367) ((lambda (tmp1368) ((lambda (tmp1369) (if (if tmp1369 (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (and-map identifier? x1371)) tmp1369) #f) (apply (lambda (let*1376 x1377 v1378 e11379 e21380) (letrec ((f1381 (lambda (bindings1382) (if (null? bindings1382) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11379 e21380))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (body1388 binding1389) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1389) body1388)) tmp1387) (syntax-violation #f "source expression failed to match any pattern" tmp1386))) ($sc-dispatch tmp1386 (quote (any any))))) (list (f1381 (cdr bindings1382)) (car bindings1382))))))) (f1381 (map list x1377 v1378)))) tmp1369) (syntax-violation #f "source expression failed to match any pattern" tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) x1367)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1390) ((lambda (tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (_1393 var1394 init1395 step1396 e01397 e11398 c1399) ((lambda (tmp1400) ((lambda (tmp1401) (if tmp1401 (apply (lambda (step1402) ((lambda (tmp1403) ((lambda (tmp1404) (if tmp1404 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1404) ((lambda (tmp1409) (if tmp1409 (apply (lambda (e11410 e21411) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11410 e21411)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1409) (syntax-violation #f "source expression failed to match any pattern" tmp1403))) ($sc-dispatch tmp1403 (quote (any . each-any)))))) ($sc-dispatch tmp1403 (quote ())))) e11398)) tmp1401) (syntax-violation #f "source expression failed to match any pattern" tmp1400))) ($sc-dispatch tmp1400 (quote each-any)))) (map (lambda (v1418 s1419) ((lambda (tmp1420) ((lambda (tmp1421) (if tmp1421 (apply (lambda () v1418) tmp1421) ((lambda (tmp1422) (if tmp1422 (apply (lambda (e1423) e1423) tmp1422) ((lambda (_1424) (syntax-violation (quote do) "bad step expression" orig-x1390 s1419)) tmp1420))) ($sc-dispatch tmp1420 (quote (any)))))) ($sc-dispatch tmp1420 (quote ())))) s1419)) var1394 step1396))) tmp1392) (syntax-violation #f "source expression failed to match any pattern" tmp1391))) ($sc-dispatch tmp1391 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1390)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1427 (lambda (x1431 y1432) ((lambda (tmp1433) ((lambda (tmp1434) (if tmp1434 (apply (lambda (x1435 y1436) ((lambda (tmp1437) ((lambda (tmp1438) (if tmp1438 (apply (lambda (dy1439) ((lambda (tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (dx1442) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1442 dy1439))) tmp1441) ((lambda (_1443) (if (null? dy1439) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436))) tmp1440))) ($sc-dispatch tmp1440 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1435)) tmp1438) ((lambda (tmp1444) (if tmp1444 (apply (lambda (stuff1445) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1435 stuff1445))) tmp1444) ((lambda (else1446) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436)) tmp1437))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1436)) tmp1434) (syntax-violation #f "source expression failed to match any pattern" tmp1433))) ($sc-dispatch tmp1433 (quote (any any))))) (list x1431 y1432)))) (quasiappend1428 (lambda (x1447 y1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (x1451 y1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda () x1451) tmp1454) ((lambda (_1455) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1451 y1452)) tmp1453))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1452)) tmp1450) (syntax-violation #f "source expression failed to match any pattern" tmp1449))) ($sc-dispatch tmp1449 (quote (any any))))) (list x1447 y1448)))) (quasivector1429 (lambda (x1456) ((lambda (tmp1457) ((lambda (x1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (x1461) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1461))) tmp1460) ((lambda (tmp1463) (if tmp1463 (apply (lambda (x1464) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1464)) tmp1463) ((lambda (_1466) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1458)) tmp1459))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1458)) tmp1457)) x1456))) (quasi1430 (lambda (p1467 lev1468) ((lambda (tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471) (if (= lev1468 0) p1471 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1471) (- lev1468 1))))) tmp1470) ((lambda (tmp1472) (if tmp1472 (apply (lambda (p1473 q1474) (if (= lev1468 0) (quasiappend1428 p1473 (quasi1430 q1474 lev1468)) (quasicons1427 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1473) (- lev1468 1))) (quasi1430 q1474 lev1468)))) tmp1472) ((lambda (tmp1475) (if tmp1475 (apply (lambda (p1476) (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1476) (+ lev1468 1)))) tmp1475) ((lambda (tmp1477) (if tmp1477 (apply (lambda (p1478 q1479) (quasicons1427 (quasi1430 p1478 lev1468) (quasi1430 q1479 lev1468))) tmp1477) ((lambda (tmp1480) (if tmp1480 (apply (lambda (x1481) (quasivector1429 (quasi1430 x1481 lev1468))) tmp1480) ((lambda (p1483) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1483)) tmp1469))) ($sc-dispatch tmp1469 (quote #(vector each-any)))))) ($sc-dispatch tmp1469 (quote (any . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1469 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1467)))) (lambda (x1484) ((lambda (tmp1485) ((lambda (tmp1486) (if tmp1486 (apply (lambda (_1487 e1488) (quasi1430 e1488 0)) tmp1486) (syntax-violation #f "source expression failed to match any pattern" tmp1485))) ($sc-dispatch tmp1485 (quote (any any))))) x1484))))) +(define include (make-syncase-macro (quote macro) (lambda (x1489) (letrec ((read-file1490 (lambda (fn1491 k1492) (let ((p1493 (open-input-file fn1491))) (letrec ((f1494 (lambda (x1495) (if (eof-object? x1495) (begin (close-input-port p1493) (quote ())) (cons (datum->syntax k1492 x1495) (f1494 (read p1493))))))) (f1494 (read p1493))))))) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (k1498 filename1499) (let ((fn1500 (syntax->datum filename1499))) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (exp1503) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1503)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote each-any)))) (read-file1490 fn1500 k1498)))) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any any))))) x1489))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1505)) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any))))) x1505)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1510) ((lambda (tmp1511) ((lambda (tmp1512) (if tmp1512 (apply (lambda (_1513 e1514) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1510)) tmp1512) (syntax-violation #f "source expression failed to match any pattern" tmp1511))) ($sc-dispatch tmp1511 (quote (any any))))) x1510)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if tmp1517 (apply (lambda (_1518 e1519 m11520 m21521) ((lambda (tmp1522) ((lambda (body1523) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1519)) body1523)) tmp1522)) (letrec ((f1524 (lambda (clause1525 clauses1526) (if (null? clauses1526) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (e11530 e21531) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11530 e21531))) tmp1529) ((lambda (tmp1533) (if tmp1533 (apply (lambda (k1534 e11535 e21536) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1534)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11535 e21536)))) tmp1533) ((lambda (_1539) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1528))) ($sc-dispatch tmp1528 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1528 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1525) ((lambda (tmp1540) ((lambda (rest1541) ((lambda (tmp1542) ((lambda (tmp1543) (if tmp1543 (apply (lambda (k1544 e11545 e21546) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1544)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11545 e21546)) rest1541)) tmp1543) ((lambda (_1549) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1542))) ($sc-dispatch tmp1542 (quote (each-any any . each-any))))) clause1525)) tmp1540)) (f1524 (car clauses1526) (cdr clauses1526))))))) (f1524 m11520 m21521)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any any any . each-any))))) x1515)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e1554) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1554)) (list (cons _1553 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1554 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1552) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any any))))) x1550)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index ebdb43778..7b0b69d4b 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -434,7 +434,7 @@ (else `(define ,var ,exp))))) (define build-lambda - (lambda (src vars docstring exp) + (lambda (src ids vars docstring exp) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-lambda) src vars (if docstring `((documentation . ,docstring)) '()) @@ -465,7 +465,7 @@ (else `(begin ,@exps)))))) (define build-let - (lambda (src vars val-exps body-exp) + (lambda (src ids vars val-exps body-exp) (if (null? vars) body-exp (case (fluid-ref *mode*) @@ -473,18 +473,22 @@ (else `(let ,(map list vars val-exps) ,body-exp)))))) (define build-named-let - (lambda (src vars val-exps body-exp) + (lambda (src ids vars val-exps body-exp) (let ((f (car vars)) - (vars (cdr vars))) + (f-name (car ids)) + (vars (cdr vars)) + (ids (cdr ids))) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-letrec) src - (list f) (list (build-lambda src vars #f body-exp)) - (build-application src (build-lexical-reference 'fun src f f) + ; (list f-name) + (list f) + (list (build-lambda src ids vars #f body-exp)) + (build-application src (build-lexical-reference 'fun src f-name f) val-exps))) (else `(let ,f ,(map list vars val-exps) ,body-exp)))))) (define build-letrec - (lambda (src vars val-exps body-exp) + (lambda (src ids vars val-exps body-exp) (if (null? vars) body-exp (case (fluid-ref *mode*) @@ -1390,6 +1394,7 @@ (loop (cdr bs) er-cache r-cache))))) (set-cdr! r (extend-env labels bindings (cdr r))) (build-letrec no-source + (map syntax->datum ids) vars (map (lambda (x) (chi (cdr x) (car x) empty-wrap mod)) @@ -1412,7 +1417,8 @@ (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (k new-vars + (k (map syntax->datum ids) + new-vars docstring (chi-body (syntax (e1 e2 ...)) e @@ -1425,7 +1431,11 @@ (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels old-ids)) (new-vars (map gen-var old-ids))) - (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) + (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids))) + (if (null? ls1) + (syntax->datum ls2) + (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2)))) + (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) (if (null? ls1) ls2 (f (cdr ls1) (cons (car ls1) ls2)))) @@ -1747,7 +1757,7 @@ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) ((primitive) (build-primref no-source (cadr x))) ((quote) (build-data no-source (cadr x))) - ((lambda) (build-lambda no-source (cadr x) #f (regen (caddr x)))) + ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x)))) ((map) (let ((ls (map regen (cdr x)))) (build-application no-source ;; this check used to be here, not sure what for: @@ -1773,7 +1783,8 @@ (syntax-case e () ((_ . c) (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod - (lambda (vars docstring body) (build-lambda s vars docstring body))))))) + (lambda (names vars docstring body) + (build-lambda s names vars docstring body))))))) (global-extend 'core 'let @@ -1786,6 +1797,7 @@ (let ((nw (make-binding-wrap ids labels w)) (nr (extend-var-env labels new-vars r))) (constructor s + (map syntax->datum ids) new-vars (map (lambda (x) (chi x r w mod)) vals) (chi-body exps (source-wrap e nw s mod) @@ -1820,6 +1832,7 @@ (let ((w (make-binding-wrap ids labels w)) (r (extend-var-env labels new-vars r))) (build-letrec s + (map syntax->datum ids) new-vars (map (lambda (x) (chi x r w mod)) (syntax (val ...))) (chi-body (syntax (e1 e2 ...)) @@ -1930,7 +1943,7 @@ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (build-application no-source (build-primref no-source 'apply) - (list (build-lambda no-source new-vars #f + (list (build-lambda no-source (map syntax->datum ids) new-vars #f (chi exp (extend-env labels @@ -1957,7 +1970,7 @@ (let ((y (gen-var 'tmp))) ; fat finger binding and references to temp variable y (build-application no-source - (build-lambda no-source (list y) #f + (build-lambda no-source (list 'tmp) (list y) #f (let ((y (build-lexical-reference 'value no-source 'tmp y))) (build-conditional no-source @@ -1991,7 +2004,9 @@ (let ((labels (list (gen-label))) (var (gen-var (syntax pat)))) (build-application no-source - (build-lambda no-source (list var) #f + (build-lambda no-source + (list (syntax->datum (syntax pat))) (list var) + #f (chi (syntax exp) (extend-env labels (list (make-binding 'syntax `(,var . 0))) @@ -2017,7 +2032,7 @@ (let ((x (gen-var 'tmp))) ; fat finger binding and references to temp variable x (build-application s - (build-lambda no-source (list x) #f + (build-lambda no-source (list 'tmp) (list x) #f (gen-syntax-case (build-lexical-reference 'value no-source 'tmp x) (syntax (key ...)) (syntax (m ...)) From 696495f4d21fc8bc479b50588c08ea55e7c6e3a7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 May 2009 16:39:55 +0200 Subject: [PATCH 105/375] actually pass original ids on to tree-il data types * module/ice-9/psyntax.scm (build-lambda, build-let, build-named-let) (build-letrec): Actually pass along the original ids to tree-il constructors. * module/ice-9/psyntax-pp.scm: Regenerated. * module/language/tree-il.scm: Add fields in , , and for the original variable names. * module/language/tree-il/compile-glil.scm (compile-glil): Adapt for new make-lambda arg. --- module/ice-9/psyntax-pp.scm | 22 ++++++------- module/ice-9/psyntax.scm | 8 ++--- module/language/tree-il.scm | 40 ++++++++++++------------ module/language/tree-il/compile-glil.scm | 2 +- 4 files changed, 36 insertions(+), 36 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index f89d44756..a7f294901 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (letrec ((andmap58 (lambda (first59) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))))) (andmap58 first56)) (letrec ((andmap62 (lambda (first63 rest64) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68))))))) (andmap62 first56 rest55))))))) (letrec ((lambda-var-list160 (lambda (vars289) (letrec ((lvl290 (lambda (vars291 ls292 w293) (cond ((pair? vars291) (lvl290 (cdr vars291) (cons (wrap139 (car vars291) w293 #f) ls292) w293)) ((id?111 vars291) (cons (wrap139 vars291 w293 #f) ls292)) ((null? vars291) ls292) ((syntax-object?95 vars291) (lvl290 (syntax-object-expression96 vars291) ls292 (join-wraps130 w293 (syntax-object-wrap97 vars291)))) ((annotation? vars291) (lvl290 (annotation-expression vars291) ls292 w293)) (else (cons vars291 ls292)))))) (lvl290 vars289 (quote ()) (quote (())))))) (gen-var159 (lambda (id294) (let ((id295 (if (syntax-object?95 id294) (syntax-object-expression96 id294) id294))) (if (annotation? id295) (gensym (symbol->string (annotation-expression id295))) (gensym (symbol->string id295)))))) (strip158 (lambda (x296 w297) (if (memq (quote top) (wrap-marks114 w297)) (if (or (annotation? x296) (and (pair? x296) (annotation? (car x296)))) (strip-annotation157 x296 #f) x296) (letrec ((f298 (lambda (x299) (cond ((syntax-object?95 x299) (strip158 (syntax-object-expression96 x299) (syntax-object-wrap97 x299))) ((pair? x299) (let ((a300 (f298 (car x299))) (d301 (f298 (cdr x299)))) (if (and (eq? a300 (car x299)) (eq? d301 (cdr x299))) x299 (cons a300 d301)))) ((vector? x299) (let ((old302 (vector->list x299))) (let ((new303 (map f298 old302))) (if (and-map*17 eq? old302 new303) x299 (list->vector new303))))) (else x299))))) (f298 x296))))) (strip-annotation157 (lambda (x304 parent305) (cond ((pair? x304) (let ((new306 (cons #f #f))) (begin (if parent305 (set-annotation-stripped! parent305 new306)) (set-car! new306 (strip-annotation157 (car x304) #f)) (set-cdr! new306 (strip-annotation157 (cdr x304) #f)) new306))) ((annotation? x304) (or (annotation-stripped x304) (strip-annotation157 (annotation-expression x304) x304))) ((vector? x304) (let ((new307 (make-vector (vector-length x304)))) (begin (if parent305 (set-annotation-stripped! parent305 new307)) (letrec ((loop308 (lambda (i309) (unless (fx<74 i309 0) (vector-set! new307 i309 (strip-annotation157 (vector-ref x304 i309) #f)) (loop308 (fx-72 i309 1)))))) (loop308 (- (vector-length x304) 1))) new307))) (else x304)))) (ellipsis?156 (lambda (x310) (and (nonsymbol-id?110 x310) (free-id=?134 x310 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void155 (lambda () (build-application79 #f (build-primref88 #f (quote if)) (quote (#f #f))))) (eval-local-transformer154 (lambda (expanded311 mod312) (let ((p313 (local-eval-hook76 expanded311 mod312))) (if (procedure? p313) p313 (syntax-violation #f "nonprocedure transformer" p313))))) (chi-local-syntax153 (lambda (rec?314 e315 r316 w317 s318 mod319 k320) ((lambda (tmp321) ((lambda (tmp322) (if tmp322 (apply (lambda (_323 id324 val325 e1326 e2327) (let ((ids328 id324)) (if (not (valid-bound-ids?136 ids328)) (syntax-violation #f "duplicate bound keyword" e315) (let ((labels330 (gen-labels117 ids328))) (let ((new-w331 (make-binding-wrap128 ids328 labels330 w317))) (k320 (cons e1326 e2327) (extend-env105 labels330 (let ((w333 (if rec?314 new-w331 w317)) (trans-r334 (macros-only-env107 r316))) (map (lambda (x335) (cons (quote macro) (eval-local-transformer154 (chi147 x335 trans-r334 w333 mod319) mod319))) val325)) r316) new-w331 s318 mod319)))))) tmp322) ((lambda (_337) (syntax-violation #f "bad local syntax definition" (source-wrap140 e315 w317 s318 mod319))) tmp321))) ($sc-dispatch tmp321 (quote (any #(each (any any)) any . each-any))))) e315))) (chi-lambda-clause152 (lambda (e338 docstring339 c340 r341 w342 mod343 k344) ((lambda (tmp345) ((lambda (tmp346) (if (if tmp346 (apply (lambda (args347 doc348 e1349 e2350) (and (string? (syntax->datum doc348)) (not docstring339))) tmp346) #f) (apply (lambda (args351 doc352 e1353 e2354) (chi-lambda-clause152 e338 doc352 (cons args351 (cons e1353 e2354)) r341 w342 mod343 k344)) tmp346) ((lambda (tmp356) (if tmp356 (apply (lambda (id357 e1358 e2359) (let ((ids360 id357)) (if (not (valid-bound-ids?136 ids360)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels362 (gen-labels117 ids360)) (new-vars363 (map gen-var159 ids360))) (k344 (map syntax->datum ids360) new-vars363 docstring339 (chi-body151 (cons e1358 e2359) e338 (extend-var-env106 labels362 new-vars363 r341) (make-binding-wrap128 ids360 labels362 w342) mod343)))))) tmp356) ((lambda (tmp365) (if tmp365 (apply (lambda (ids366 e1367 e2368) (let ((old-ids369 (lambda-var-list160 ids366))) (if (not (valid-bound-ids?136 old-ids369)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels370 (gen-labels117 old-ids369)) (new-vars371 (map gen-var159 old-ids369))) (k344 (letrec ((f372 (lambda (ls1373 ls2374) (if (null? ls1373) (syntax->datum ls2374) (f372 (cdr ls1373) (cons (syntax->datum (car ls1373)) ls2374)))))) (f372 (cdr old-ids369) (car old-ids369))) (letrec ((f375 (lambda (ls1376 ls2377) (if (null? ls1376) ls2377 (f375 (cdr ls1376) (cons (car ls1376) ls2377)))))) (f375 (cdr new-vars371) (car new-vars371))) docstring339 (chi-body151 (cons e1367 e2368) e338 (extend-var-env106 labels370 new-vars371 r341) (make-binding-wrap128 old-ids369 labels370 w342) mod343)))))) tmp365) ((lambda (_379) (syntax-violation (quote lambda) "bad lambda" e338)) tmp345))) ($sc-dispatch tmp345 (quote (any any . each-any)))))) ($sc-dispatch tmp345 (quote (each-any any . each-any)))))) ($sc-dispatch tmp345 (quote (any any any . each-any))))) c340))) (chi-body151 (lambda (body380 outer-form381 r382 w383 mod384) (let ((r385 (cons (quote ("placeholder" placeholder)) r382))) (let ((ribcage386 (make-ribcage118 (quote ()) (quote ()) (quote ())))) (let ((w387 (make-wrap113 (wrap-marks114 w383) (cons ribcage386 (wrap-subst115 w383))))) (letrec ((parse388 (lambda (body389 ids390 labels391 vars392 vals393 bindings394) (if (null? body389) (syntax-violation #f "no expressions in body" outer-form381) (let ((e396 (cdar body389)) (er397 (caar body389))) (call-with-values (lambda () (syntax-type145 e396 er397 (quote (())) #f ribcage386 mod384)) (lambda (type398 value399 e400 w401 s402 mod403) (let ((t404 type398)) (if (memv t404 (quote (define-form))) (let ((id405 (wrap139 value399 w401 mod403)) (label406 (gen-label116))) (let ((var407 (gen-var159 id405))) (begin (extend-ribcage!127 ribcage386 id405 label406) (parse388 (cdr body389) (cons id405 ids390) (cons label406 labels391) (cons var407 vars392) (cons (cons er397 (wrap139 e400 w401 mod403)) vals393) (cons (cons (quote lexical) var407) bindings394))))) (if (memv t404 (quote (define-syntax-form))) (let ((id408 (wrap139 value399 w401 mod403)) (label409 (gen-label116))) (begin (extend-ribcage!127 ribcage386 id408 label409) (parse388 (cdr body389) (cons id408 ids390) (cons label409 labels391) vars392 vals393 (cons (cons (quote macro) (cons er397 (wrap139 e400 w401 mod403))) bindings394)))) (if (memv t404 (quote (begin-form))) ((lambda (tmp410) ((lambda (tmp411) (if tmp411 (apply (lambda (_412 e1413) (parse388 (letrec ((f414 (lambda (forms415) (if (null? forms415) (cdr body389) (cons (cons er397 (wrap139 (car forms415) w401 mod403)) (f414 (cdr forms415))))))) (f414 e1413)) ids390 labels391 vars392 vals393 bindings394)) tmp411) (syntax-violation #f "source expression failed to match any pattern" tmp410))) ($sc-dispatch tmp410 (quote (any . each-any))))) e400) (if (memv t404 (quote (local-syntax-form))) (chi-local-syntax153 value399 e400 er397 w401 s402 mod403 (lambda (forms417 er418 w419 s420 mod421) (parse388 (letrec ((f422 (lambda (forms423) (if (null? forms423) (cdr body389) (cons (cons er418 (wrap139 (car forms423) w419 mod421)) (f422 (cdr forms423))))))) (f422 forms417)) ids390 labels391 vars392 vals393 bindings394))) (if (null? ids390) (build-sequence90 #f (map (lambda (x424) (chi147 (cdr x424) (car x424) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389)))) (begin (if (not (valid-bound-ids?136 ids390)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form381)) (letrec ((loop425 (lambda (bs426 er-cache427 r-cache428) (if (not (null? bs426)) (let ((b429 (car bs426))) (if (eq? (car b429) (quote macro)) (let ((er430 (cadr b429))) (let ((r-cache431 (if (eq? er430 er-cache427) r-cache428 (macros-only-env107 er430)))) (begin (set-cdr! b429 (eval-local-transformer154 (chi147 (cddr b429) r-cache431 (quote (())) mod403) mod403)) (loop425 (cdr bs426) er430 r-cache431)))) (loop425 (cdr bs426) er-cache427 r-cache428))))))) (loop425 bindings394 #f #f)) (set-cdr! r385 (extend-env105 labels391 bindings394 (cdr r385))) (build-letrec93 #f (map syntax->datum ids390) vars392 (map (lambda (x432) (chi147 (cdr x432) (car x432) (quote (())) mod403)) vals393) (build-sequence90 #f (map (lambda (x433) (chi147 (cdr x433) (car x433) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389))))))))))))))))))) (parse388 (map (lambda (x395) (cons r385 (wrap139 x395 w387 mod384))) body380) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro150 (lambda (p434 e435 r436 w437 rib438 mod439) (letrec ((rebuild-macro-output440 (lambda (x441 m442) (cond ((pair? x441) (cons (rebuild-macro-output440 (car x441) m442) (rebuild-macro-output440 (cdr x441) m442))) ((syntax-object?95 x441) (let ((w443 (syntax-object-wrap97 x441))) (let ((ms444 (wrap-marks114 w443)) (s445 (wrap-subst115 w443))) (if (and (pair? ms444) (eq? (car ms444) #f)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cdr ms444) (if rib438 (cons rib438 (cdr s445)) (cdr s445))) (syntax-object-module98 x441)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cons m442 ms444) (if rib438 (cons rib438 (cons (quote shift) s445)) (cons (quote shift) s445))) (let ((pmod446 (procedure-module p434))) (if pmod446 (cons (quote hygiene) (module-name pmod446)) (quote (hygiene guile))))))))) ((vector? x441) (let ((n447 (vector-length x441))) (let ((v448 (make-vector n447))) (letrec ((doloop449 (lambda (i450) (if (fx=73 i450 n447) v448 (begin (vector-set! v448 i450 (rebuild-macro-output440 (vector-ref x441 i450) m442)) (doloop449 (fx+71 i450 1))))))) (doloop449 0))))) ((symbol? x441) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap140 e435 w437 s mod439) x441)) (else x441))))) (rebuild-macro-output440 (p434 (wrap139 e435 (anti-mark126 w437) mod439)) (string #\m))))) (chi-application149 (lambda (x451 e452 r453 w454 s455 mod456) ((lambda (tmp457) ((lambda (tmp458) (if tmp458 (apply (lambda (e0459 e1460) (build-application79 s455 x451 (map (lambda (e461) (chi147 e461 r453 w454 mod456)) e1460))) tmp458) (syntax-violation #f "source expression failed to match any pattern" tmp457))) ($sc-dispatch tmp457 (quote (any . each-any))))) e452))) (chi-expr148 (lambda (type463 value464 e465 r466 w467 s468 mod469) (let ((t470 type463)) (if (memv t470 (quote (lexical))) (build-lexical-reference81 (quote value) s468 e465 value464) (if (memv t470 (quote (core external-macro))) (value464 e465 r466 w467 s468 mod469) (if (memv t470 (quote (module-ref))) (call-with-values (lambda () (value464 e465)) (lambda (id471 mod472) (build-global-reference84 s468 id471 mod472))) (if (memv t470 (quote (lexical-call))) (chi-application149 (build-lexical-reference81 (quote fun) (source-annotation102 (car e465)) (car e465) value464) e465 r466 w467 s468 mod469) (if (memv t470 (quote (global-call))) (chi-application149 (build-global-reference84 (source-annotation102 (car e465)) value464 (if (syntax-object?95 (car e465)) (syntax-object-module98 (car e465)) mod469)) e465 r466 w467 s468 mod469) (if (memv t470 (quote (constant))) (build-data89 s468 (strip158 (source-wrap140 e465 w467 s468 mod469) (quote (())))) (if (memv t470 (quote (global))) (build-global-reference84 s468 value464 mod469) (if (memv t470 (quote (call))) (chi-application149 (chi147 (car e465) r466 w467 mod469) e465 r466 w467 s468 mod469) (if (memv t470 (quote (begin-form))) ((lambda (tmp473) ((lambda (tmp474) (if tmp474 (apply (lambda (_475 e1476 e2477) (chi-sequence141 (cons e1476 e2477) r466 w467 s468 mod469)) tmp474) (syntax-violation #f "source expression failed to match any pattern" tmp473))) ($sc-dispatch tmp473 (quote (any any . each-any))))) e465) (if (memv t470 (quote (local-syntax-form))) (chi-local-syntax153 value464 e465 r466 w467 s468 mod469 chi-sequence141) (if (memv t470 (quote (eval-when-form))) ((lambda (tmp479) ((lambda (tmp480) (if tmp480 (apply (lambda (_481 x482 e1483 e2484) (let ((when-list485 (chi-when-list144 e465 x482 w467))) (if (memq (quote eval) when-list485) (chi-sequence141 (cons e1483 e2484) r466 w467 s468 mod469) (chi-void155)))) tmp480) (syntax-violation #f "source expression failed to match any pattern" tmp479))) ($sc-dispatch tmp479 (quote (any each-any any . each-any))))) e465) (if (memv t470 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e465 (wrap139 value464 w467 mod469)) (if (memv t470 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap140 e465 w467 s468 mod469)) (if (memv t470 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap140 e465 w467 s468 mod469)) (syntax-violation #f "unexpected syntax" (source-wrap140 e465 w467 s468 mod469))))))))))))))))))) (chi147 (lambda (e488 r489 w490 mod491) (call-with-values (lambda () (syntax-type145 e488 r489 w490 #f #f mod491)) (lambda (type492 value493 e494 w495 s496 mod497) (chi-expr148 type492 value493 e494 r489 w495 s496 mod497))))) (chi-top146 (lambda (e498 r499 w500 m501 esew502 mod503) (call-with-values (lambda () (syntax-type145 e498 r499 w500 #f #f mod503)) (lambda (type511 value512 e513 w514 s515 mod516) (let ((t517 type511)) (if (memv t517 (quote (begin-form))) ((lambda (tmp518) ((lambda (tmp519) (if tmp519 (apply (lambda (_520) (chi-void155)) tmp519) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 e1523 e2524) (chi-top-sequence142 (cons e1523 e2524) r499 w514 s515 m501 esew502 mod516)) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp518))) ($sc-dispatch tmp518 (quote (any any . each-any)))))) ($sc-dispatch tmp518 (quote (any))))) e513) (if (memv t517 (quote (local-syntax-form))) (chi-local-syntax153 value512 e513 r499 w514 s515 mod516 (lambda (body526 r527 w528 s529 mod530) (chi-top-sequence142 body526 r527 w528 s529 m501 esew502 mod530))) (if (memv t517 (quote (eval-when-form))) ((lambda (tmp531) ((lambda (tmp532) (if tmp532 (apply (lambda (_533 x534 e1535 e2536) (let ((when-list537 (chi-when-list144 e513 x534 w514)) (body538 (cons e1535 e2536))) (cond ((eq? m501 (quote e)) (if (memq (quote eval) when-list537) (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) (chi-void155))) ((memq (quote load) when-list537) (if (or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (chi-top-sequence142 body538 r499 w514 s515 (quote c&e) (quote (compile load)) mod516) (if (memq m501 (quote (c c&e))) (chi-top-sequence142 body538 r499 w514 s515 (quote c) (quote (load)) mod516) (chi-void155)))) ((or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (top-level-eval-hook75 (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) mod516) (chi-void155)) (else (chi-void155))))) tmp532) (syntax-violation #f "source expression failed to match any pattern" tmp531))) ($sc-dispatch tmp531 (quote (any each-any any . each-any))))) e513) (if (memv t517 (quote (define-syntax-form))) (let ((n541 (id-var-name133 value512 w514)) (r542 (macros-only-env107 r499))) (let ((t543 m501)) (if (memv t543 (quote (c))) (if (memq (quote compile) esew502) (let ((e544 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e544 mod516) (if (memq (quote load) esew502) e544 (chi-void155)))) (if (memq (quote load) esew502) (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) (chi-void155))) (if (memv t543 (quote (c&e))) (let ((e545 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e545 mod516) e545)) (begin (if (memq (quote eval) esew502) (top-level-eval-hook75 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) mod516)) (chi-void155)))))) (if (memv t517 (quote (define-form))) (let ((n546 (id-var-name133 value512 w514))) (let ((type547 (binding-type103 (lookup108 n546 r499 mod516)))) (let ((t548 type547)) (if (memv t548 (quote (global core macro module-ref))) (let ((x549 (build-global-definition86 s515 n546 (chi147 e513 r499 w514 mod516)))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x549 mod516)) x549)) (if (memv t548 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e513 (wrap139 value512 w514 mod516)) (syntax-violation #f "cannot define keyword at top level" e513 (wrap139 value512 w514 mod516))))))) (let ((x550 (chi-expr148 type511 value512 e513 r499 w514 s515 mod516))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x550 mod516)) x550)))))))))))) (syntax-type145 (lambda (e551 r552 w553 s554 rib555 mod556) (cond ((symbol? e551) (let ((n557 (id-var-name133 e551 w553))) (let ((b558 (lookup108 n557 r552 mod556))) (let ((type559 (binding-type103 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value104 b558) e551 w553 s554 mod556) (if (memv t560 (quote (global))) (values type559 n557 e551 w553 s554 mod556) (if (memv t560 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b558) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (values type559 (binding-value104 b558) e551 w553 s554 mod556))))))))) ((pair? e551) (let ((first561 (car e551))) (if (id?111 first561) (let ((n562 (id-var-name133 first561 w553))) (let ((b563 (lookup108 n562 r552 (or (and (syntax-object?95 first561) (syntax-object-module98 first561)) mod556)))) (let ((type564 (binding-type103 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (global))) (values (quote global-call) n562 e551 w553 s554 mod556) (if (memv t565 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b563) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (if (memv t565 (quote (core external-macro module-ref))) (values type564 (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (begin))) (values (quote begin-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?111 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w553 s554 mod556)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?111 name576) (valid-bound-ids?136 (lambda-var-list160 args577)))) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap139 name581 w553 mod556) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap139 (cons args582 (cons e1583 e2584)) w553 mod556)) (quote (())) s554 mod556)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?111 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap139 name590 w553 mod556) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s554 mod556)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e551) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?111 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w553 s554 mod556)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e551) (values (quote call) #f e551 w553 s554 mod556)))))))))))))) (values (quote call) #f e551 w553 s554 mod556)))) ((syntax-object?95 e551) (syntax-type145 (syntax-object-expression96 e551) r552 (join-wraps130 w553 (syntax-object-wrap97 e551)) #f rib555 (or (syntax-object-module98 e551) mod556))) ((annotation? e551) (syntax-type145 (annotation-expression e551) r552 w553 (annotation-source e551) rib555 mod556)) ((self-evaluating? e551) (values (quote constant) #f e551 w553 s554 mod556)) (else (values (quote other) #f e551 w553 s554 mod556))))) (chi-when-list144 (lambda (e599 when-list600 w601) (letrec ((f602 (lambda (when-list603 situations604) (if (null? when-list603) situations604 (f602 (cdr when-list603) (cons (let ((x605 (car when-list603))) (cond ((free-id=?134 x605 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?134 x605 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?134 x605 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e599 (wrap139 x605 w601 #f))))) situations604)))))) (f602 when-list600 (quote ()))))) (chi-install-global143 (lambda (name606 e607) (build-global-definition86 #f name606 (if (let ((v608 (module-variable (current-module) name606))) (and v608 (variable-bound? v608) (macro? (variable-ref v608)) (not (eq? (macro-type (variable-ref v608)) (quote syncase-macro))))) (build-application79 #f (build-primref88 #f (quote make-extended-syncase-macro)) (list (build-application79 #f (build-primref88 #f (quote module-ref)) (list (build-application79 #f (quote current-module) (quote ())) (build-data89 #f name606))) (build-data89 #f (quote macro)) e607)) (build-application79 #f (build-primref88 #f (quote make-syncase-macro)) (list (build-data89 #f (quote macro)) e607)))))) (chi-top-sequence142 (lambda (body609 r610 w611 s612 m613 esew614 mod615) (build-sequence90 s612 (letrec ((dobody616 (lambda (body617 r618 w619 m620 esew621 mod622) (if (null? body617) (quote ()) (let ((first623 (chi-top146 (car body617) r618 w619 m620 esew621 mod622))) (cons first623 (dobody616 (cdr body617) r618 w619 m620 esew621 mod622))))))) (dobody616 body609 r610 w611 m613 esew614 mod615))))) (chi-sequence141 (lambda (body624 r625 w626 s627 mod628) (build-sequence90 s627 (letrec ((dobody629 (lambda (body630 r631 w632 mod633) (if (null? body630) (quote ()) (let ((first634 (chi147 (car body630) r631 w632 mod633))) (cons first634 (dobody629 (cdr body630) r631 w632 mod633))))))) (dobody629 body624 r625 w626 mod628))))) (source-wrap140 (lambda (x635 w636 s637 defmod638) (wrap139 (if s637 (make-annotation x635 s637 #f) x635) w636 defmod638))) (wrap139 (lambda (x639 w640 defmod641) (cond ((and (null? (wrap-marks114 w640)) (null? (wrap-subst115 w640))) x639) ((syntax-object?95 x639) (make-syntax-object94 (syntax-object-expression96 x639) (join-wraps130 w640 (syntax-object-wrap97 x639)) (syntax-object-module98 x639))) ((null? x639) x639) (else (make-syntax-object94 x639 w640 defmod641))))) (bound-id-member?138 (lambda (x642 list643) (and (not (null? list643)) (or (bound-id=?135 x642 (car list643)) (bound-id-member?138 x642 (cdr list643)))))) (distinct-bound-ids?137 (lambda (ids644) (letrec ((distinct?645 (lambda (ids646) (or (null? ids646) (and (not (bound-id-member?138 (car ids646) (cdr ids646))) (distinct?645 (cdr ids646))))))) (distinct?645 ids644)))) (valid-bound-ids?136 (lambda (ids647) (and (letrec ((all-ids?648 (lambda (ids649) (or (null? ids649) (and (id?111 (car ids649)) (all-ids?648 (cdr ids649))))))) (all-ids?648 ids647)) (distinct-bound-ids?137 ids647)))) (bound-id=?135 (lambda (i650 j651) (if (and (syntax-object?95 i650) (syntax-object?95 j651)) (and (eq? (let ((e652 (syntax-object-expression96 i650))) (if (annotation? e652) (annotation-expression e652) e652)) (let ((e653 (syntax-object-expression96 j651))) (if (annotation? e653) (annotation-expression e653) e653))) (same-marks?132 (wrap-marks114 (syntax-object-wrap97 i650)) (wrap-marks114 (syntax-object-wrap97 j651)))) (eq? (let ((e654 i650)) (if (annotation? e654) (annotation-expression e654) e654)) (let ((e655 j651)) (if (annotation? e655) (annotation-expression e655) e655)))))) (free-id=?134 (lambda (i656 j657) (and (eq? (let ((x658 i656)) (let ((e659 (if (syntax-object?95 x658) (syntax-object-expression96 x658) x658))) (if (annotation? e659) (annotation-expression e659) e659))) (let ((x660 j657)) (let ((e661 (if (syntax-object?95 x660) (syntax-object-expression96 x660) x660))) (if (annotation? e661) (annotation-expression e661) e661)))) (eq? (id-var-name133 i656 (quote (()))) (id-var-name133 j657 (quote (()))))))) (id-var-name133 (lambda (id662 w663) (letrec ((search-vector-rib666 (lambda (sym672 subst673 marks674 symnames675 ribcage676) (let ((n677 (vector-length symnames675))) (letrec ((f678 (lambda (i679) (cond ((fx=73 i679 n677) (search664 sym672 (cdr subst673) marks674)) ((and (eq? (vector-ref symnames675 i679) sym672) (same-marks?132 marks674 (vector-ref (ribcage-marks121 ribcage676) i679))) (values (vector-ref (ribcage-labels122 ribcage676) i679) marks674)) (else (f678 (fx+71 i679 1))))))) (f678 0))))) (search-list-rib665 (lambda (sym680 subst681 marks682 symnames683 ribcage684) (letrec ((f685 (lambda (symnames686 i687) (cond ((null? symnames686) (search664 sym680 (cdr subst681) marks682)) ((and (eq? (car symnames686) sym680) (same-marks?132 marks682 (list-ref (ribcage-marks121 ribcage684) i687))) (values (list-ref (ribcage-labels122 ribcage684) i687) marks682)) (else (f685 (cdr symnames686) (fx+71 i687 1))))))) (f685 symnames683 0)))) (search664 (lambda (sym688 subst689 marks690) (if (null? subst689) (values #f marks690) (let ((fst691 (car subst689))) (if (eq? fst691 (quote shift)) (search664 sym688 (cdr subst689) (cdr marks690)) (let ((symnames692 (ribcage-symnames120 fst691))) (if (vector? symnames692) (search-vector-rib666 sym688 subst689 marks690 symnames692 fst691) (search-list-rib665 sym688 subst689 marks690 symnames692 fst691))))))))) (cond ((symbol? id662) (or (call-with-values (lambda () (search664 id662 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x694 . ignore693) x694)) id662)) ((syntax-object?95 id662) (let ((id695 (let ((e697 (syntax-object-expression96 id662))) (if (annotation? e697) (annotation-expression e697) e697))) (w1696 (syntax-object-wrap97 id662))) (let ((marks698 (join-marks131 (wrap-marks114 w663) (wrap-marks114 w1696)))) (call-with-values (lambda () (search664 id695 (wrap-subst115 w663) marks698)) (lambda (new-id699 marks700) (or new-id699 (call-with-values (lambda () (search664 id695 (wrap-subst115 w1696) marks700)) (lambda (x702 . ignore701) x702)) id695)))))) ((annotation? id662) (let ((id703 (let ((e704 id662)) (if (annotation? e704) (annotation-expression e704) e704)))) (or (call-with-values (lambda () (search664 id703 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x706 . ignore705) x706)) id703))) (else (syntax-violation (quote id-var-name) "invalid id" id662)))))) (same-marks?132 (lambda (x707 y708) (or (eq? x707 y708) (and (not (null? x707)) (not (null? y708)) (eq? (car x707) (car y708)) (same-marks?132 (cdr x707) (cdr y708)))))) (join-marks131 (lambda (m1709 m2710) (smart-append129 m1709 m2710))) (join-wraps130 (lambda (w1711 w2712) (let ((m1713 (wrap-marks114 w1711)) (s1714 (wrap-subst115 w1711))) (if (null? m1713) (if (null? s1714) w2712 (make-wrap113 (wrap-marks114 w2712) (smart-append129 s1714 (wrap-subst115 w2712)))) (make-wrap113 (smart-append129 m1713 (wrap-marks114 w2712)) (smart-append129 s1714 (wrap-subst115 w2712))))))) (smart-append129 (lambda (m1715 m2716) (if (null? m2716) m1715 (append m1715 m2716)))) (make-binding-wrap128 (lambda (ids717 labels718 w719) (if (null? ids717) w719 (make-wrap113 (wrap-marks114 w719) (cons (let ((labelvec720 (list->vector labels718))) (let ((n721 (vector-length labelvec720))) (let ((symnamevec722 (make-vector n721)) (marksvec723 (make-vector n721))) (begin (letrec ((f724 (lambda (ids725 i726) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks112 (car ids725) w719)) (lambda (symname727 marks728) (begin (vector-set! symnamevec722 i726 symname727) (vector-set! marksvec723 i726 marks728) (f724 (cdr ids725) (fx+71 i726 1))))))))) (f724 ids717 0)) (make-ribcage118 symnamevec722 marksvec723 labelvec720))))) (wrap-subst115 w719)))))) (extend-ribcage!127 (lambda (ribcage729 id730 label731) (begin (set-ribcage-symnames!123 ribcage729 (cons (let ((e732 (syntax-object-expression96 id730))) (if (annotation? e732) (annotation-expression e732) e732)) (ribcage-symnames120 ribcage729))) (set-ribcage-marks!124 ribcage729 (cons (wrap-marks114 (syntax-object-wrap97 id730)) (ribcage-marks121 ribcage729))) (set-ribcage-labels!125 ribcage729 (cons label731 (ribcage-labels122 ribcage729)))))) (anti-mark126 (lambda (w733) (make-wrap113 (cons #f (wrap-marks114 w733)) (cons (quote shift) (wrap-subst115 w733))))) (set-ribcage-labels!125 (lambda (x734 update735) (vector-set! x734 3 update735))) (set-ribcage-marks!124 (lambda (x736 update737) (vector-set! x736 2 update737))) (set-ribcage-symnames!123 (lambda (x738 update739) (vector-set! x738 1 update739))) (ribcage-labels122 (lambda (x740) (vector-ref x740 3))) (ribcage-marks121 (lambda (x741) (vector-ref x741 2))) (ribcage-symnames120 (lambda (x742) (vector-ref x742 1))) (ribcage?119 (lambda (x743) (and (vector? x743) (= (vector-length x743) 4) (eq? (vector-ref x743 0) (quote ribcage))))) (make-ribcage118 (lambda (symnames744 marks745 labels746) (vector (quote ribcage) symnames744 marks745 labels746))) (gen-labels117 (lambda (ls747) (if (null? ls747) (quote ()) (cons (gen-label116) (gen-labels117 (cdr ls747)))))) (gen-label116 (lambda () (string #\i))) (wrap-subst115 cdr) (wrap-marks114 car) (make-wrap113 cons) (id-sym-name&marks112 (lambda (x748 w749) (if (syntax-object?95 x748) (values (let ((e750 (syntax-object-expression96 x748))) (if (annotation? e750) (annotation-expression e750) e750)) (join-marks131 (wrap-marks114 w749) (wrap-marks114 (syntax-object-wrap97 x748)))) (values (let ((e751 x748)) (if (annotation? e751) (annotation-expression e751) e751)) (wrap-marks114 w749))))) (id?111 (lambda (x752) (cond ((symbol? x752) #t) ((syntax-object?95 x752) (symbol? (let ((e753 (syntax-object-expression96 x752))) (if (annotation? e753) (annotation-expression e753) e753)))) ((annotation? x752) (symbol? (annotation-expression x752))) (else #f)))) (nonsymbol-id?110 (lambda (x754) (and (syntax-object?95 x754) (symbol? (let ((e755 (syntax-object-expression96 x754))) (if (annotation? e755) (annotation-expression e755) e755)))))) (global-extend109 (lambda (type756 sym757 val758) (put-global-definition-hook77 sym757 type756 val758))) (lookup108 (lambda (x759 r760 mod761) (cond ((assq x759 r760) => cdr) ((symbol? x759) (or (get-global-definition-hook78 x759 mod761) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env107 (lambda (r762) (if (null? r762) (quote ()) (let ((a763 (car r762))) (if (eq? (cadr a763) (quote macro)) (cons a763 (macros-only-env107 (cdr r762))) (macros-only-env107 (cdr r762))))))) (extend-var-env106 (lambda (labels764 vars765 r766) (if (null? labels764) r766 (extend-var-env106 (cdr labels764) (cdr vars765) (cons (cons (car labels764) (cons (quote lexical) (car vars765))) r766))))) (extend-env105 (lambda (labels767 bindings768 r769) (if (null? labels767) r769 (extend-env105 (cdr labels767) (cdr bindings768) (cons (cons (car labels767) (car bindings768)) r769))))) (binding-value104 cdr) (binding-type103 car) (source-annotation102 (lambda (x770) (cond ((annotation? x770) (annotation-source x770)) ((syntax-object?95 x770) (source-annotation102 (syntax-object-expression96 x770))) (else #f)))) (set-syntax-object-module!101 (lambda (x771 update772) (vector-set! x771 3 update772))) (set-syntax-object-wrap!100 (lambda (x773 update774) (vector-set! x773 2 update774))) (set-syntax-object-expression!99 (lambda (x775 update776) (vector-set! x775 1 update776))) (syntax-object-module98 (lambda (x777) (vector-ref x777 3))) (syntax-object-wrap97 (lambda (x778) (vector-ref x778 2))) (syntax-object-expression96 (lambda (x779) (vector-ref x779 1))) (syntax-object?95 (lambda (x780) (and (vector? x780) (= (vector-length x780) 4) (eq? (vector-ref x780 0) (quote syntax-object))))) (make-syntax-object94 (lambda (expression781 wrap782 module783) (vector (quote syntax-object) expression781 wrap782 module783))) (build-letrec93 (lambda (src784 ids785 vars786 val-exps787 body-exp788) (if (null? vars786) body-exp788 (let ((t789 (fluid-ref *mode*70))) (if (memv t789 (quote (c))) ((@ (language tree-il) make-letrec) src784 vars786 val-exps787 body-exp788) (list (quote letrec) (map list vars786 val-exps787) body-exp788)))))) (build-named-let92 (lambda (src790 ids791 vars792 val-exps793 body-exp794) (let ((f795 (car vars792)) (f-name796 (car ids791)) (vars797 (cdr vars792)) (ids798 (cdr ids791))) (let ((t799 (fluid-ref *mode*70))) (if (memv t799 (quote (c))) ((@ (language tree-il) make-letrec) src790 (list f795) (list (build-lambda87 src790 ids798 vars797 #f body-exp794)) (build-application79 src790 (build-lexical-reference81 (quote fun) src790 f-name796 f795) val-exps793)) (list (quote let) f795 (map list vars797 val-exps793) body-exp794)))))) (build-let91 (lambda (src800 ids801 vars802 val-exps803 body-exp804) (if (null? vars802) body-exp804 (let ((t805 (fluid-ref *mode*70))) (if (memv t805 (quote (c))) ((@ (language tree-il) make-let) src800 vars802 val-exps803 body-exp804) (list (quote let) (map list vars802 val-exps803) body-exp804)))))) (build-sequence90 (lambda (src806 exps807) (if (null? (cdr exps807)) (car exps807) (let ((t808 (fluid-ref *mode*70))) (if (memv t808 (quote (c))) ((@ (language tree-il) make-sequence) src806 exps807) (cons (quote begin) exps807)))))) (build-data89 (lambda (src809 exp810) (let ((t811 (fluid-ref *mode*70))) (if (memv t811 (quote (c))) ((@ (language tree-il) make-const) src809 exp810) (if (and (self-evaluating? exp810) (not (vector? exp810))) exp810 (list (quote quote) exp810)))))) (build-primref88 (lambda (src812 name813) (let ((t814 (fluid-ref *mode*70))) (if (memv t814 (quote (c))) ((@ (language tree-il) make-primitive-ref) src812 name813) (build-global-reference84 src812 name813 (quote (hygiene guile))))))) (build-lambda87 (lambda (src815 ids816 vars817 docstring818 exp819) (let ((t820 (fluid-ref *mode*70))) (if (memv t820 (quote (c))) ((@ (language tree-il) make-lambda) src815 vars817 (if docstring818 (list (cons (quote documentation) docstring818)) (quote ())) exp819) (cons (quote lambda) (cons vars817 (append (if docstring818 (list docstring818) (quote ())) (list exp819)))))))) (build-global-definition86 (lambda (source821 var822 exp823) (let ((t824 (fluid-ref *mode*70))) (if (memv t824 (quote (c))) ((@ (language tree-il) make-toplevel-define) source821 var822 exp823) (list (quote define) var822 exp823))))) (build-global-assignment85 (lambda (source825 var826 exp827 mod828) (analyze-variable83 mod828 var826 (lambda (mod829 var830 public?831) (let ((t832 (fluid-ref *mode*70))) (if (memv t832 (quote (c))) ((@ (language tree-il) make-module-set) source825 mod829 var830 public?831 exp827) (list (quote set!) (list (if public?831 (quote @) (quote @@)) mod829 var830) exp827)))) (lambda (var833) (let ((t834 (fluid-ref *mode*70))) (if (memv t834 (quote (c))) ((@ (language tree-il) make-toplevel-set) source825 var833 exp827) (list (quote set!) var833 exp827))))))) (build-global-reference84 (lambda (source835 var836 mod837) (analyze-variable83 mod837 var836 (lambda (mod838 var839 public?840) (let ((t841 (fluid-ref *mode*70))) (if (memv t841 (quote (c))) ((@ (language tree-il) make-module-ref) source835 mod838 var839 public?840) (list (if public?840 (quote @) (quote @@)) mod838 var839)))) (lambda (var842) (let ((t843 (fluid-ref *mode*70))) (if (memv t843 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source835 var842) var842)))))) (analyze-variable83 (lambda (mod844 var845 modref-cont846 bare-cont847) (if (not mod844) (bare-cont847 var845) (let ((kind848 (car mod844)) (mod849 (cdr mod844))) (let ((t850 kind848)) (if (memv t850 (quote (public))) (modref-cont846 mod849 var845 #t) (if (memv t850 (quote (private))) (if (not (equal? mod849 (module-name (current-module)))) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (if (memv t850 (quote (bare))) (bare-cont847 var845) (if (memv t850 (quote (hygiene))) (if (and (not (equal? mod849 (module-name (current-module)))) (module-variable (resolve-module mod849) var845)) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (syntax-violation #f "bad module kind" var845 mod849)))))))))) (build-lexical-assignment82 (lambda (source851 name852 var853 exp854) (let ((t855 (fluid-ref *mode*70))) (if (memv t855 (quote (c))) ((@ (language tree-il) make-lexical-set) source851 name852 var853 exp854) (list (quote set!) var853 exp854))))) (build-lexical-reference81 (lambda (type856 source857 name858 var859) (let ((t860 (fluid-ref *mode*70))) (if (memv t860 (quote (c))) ((@ (language tree-il) make-lexical-ref) source857 name858 var859) var859)))) (build-conditional80 (lambda (source861 test-exp862 then-exp863 else-exp864) (let ((t865 (fluid-ref *mode*70))) (if (memv t865 (quote (c))) ((@ (language tree-il) make-conditional) source861 test-exp862 then-exp863 else-exp864) (list (quote if) test-exp862 then-exp863 else-exp864))))) (build-application79 (lambda (source866 fun-exp867 arg-exps868) (let ((t869 (fluid-ref *mode*70))) (if (memv t869 (quote (c))) ((@ (language tree-il) make-application) source866 fun-exp867 arg-exps868) (cons fun-exp867 arg-exps868))))) (get-global-definition-hook78 (lambda (symbol870 module871) (begin (if (and (not module871) (current-module)) (warn "module system is booted, we should have a module" symbol870)) (let ((v872 (module-variable (if module871 (resolve-module (cdr module871)) (current-module)) symbol870))) (and v872 (variable-bound? v872) (let ((val873 (variable-ref v872))) (and (macro? val873) (syncase-macro-type val873) (cons (syncase-macro-type val873) (syncase-macro-binding val873))))))))) (put-global-definition-hook77 (lambda (symbol874 type875 val876) (let ((existing877 (let ((v878 (module-variable (current-module) symbol874))) (and v878 (variable-bound? v878) (let ((val879 (variable-ref v878))) (and (macro? val879) (not (syncase-macro-type val879)) val879)))))) (module-define! (current-module) symbol874 (if existing877 (make-extended-syncase-macro existing877 type875 val876) (make-syncase-macro type875 val876)))))) (local-eval-hook76 (lambda (x880 mod881) (primitive-eval (list noexpand69 (let ((t882 (fluid-ref *mode*70))) (if (memv t882 (quote (c))) ((@ (language tree-il) tree-il->scheme) x880) x880)))))) (top-level-eval-hook75 (lambda (x883 mod884) (primitive-eval (list noexpand69 (let ((t885 (fluid-ref *mode*70))) (if (memv t885 (quote (c))) ((@ (language tree-il) tree-il->scheme) x883) x883)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend109 (quote local-syntax) (quote letrec-syntax) #t) (global-extend109 (quote local-syntax) (quote let-syntax) #f) (global-extend109 (quote core) (quote fluid-let-syntax) (lambda (e886 r887 w888 s889 mod890) ((lambda (tmp891) ((lambda (tmp892) (if (if tmp892 (apply (lambda (_893 var894 val895 e1896 e2897) (valid-bound-ids?136 var894)) tmp892) #f) (apply (lambda (_899 var900 val901 e1902 e2903) (let ((names904 (map (lambda (x905) (id-var-name133 x905 w888)) var900))) (begin (for-each (lambda (id907 n908) (let ((t909 (binding-type103 (lookup108 n908 r887 mod890)))) (if (memv t909 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e886 (source-wrap140 id907 w888 s889 mod890))))) var900 names904) (chi-body151 (cons e1902 e2903) (source-wrap140 e886 w888 s889 mod890) (extend-env105 names904 (let ((trans-r912 (macros-only-env107 r887))) (map (lambda (x913) (cons (quote macro) (eval-local-transformer154 (chi147 x913 trans-r912 w888 mod890) mod890))) val901)) r887) w888 mod890)))) tmp892) ((lambda (_915) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap140 e886 w888 s889 mod890))) tmp891))) ($sc-dispatch tmp891 (quote (any #(each (any any)) any . each-any))))) e886))) (global-extend109 (quote core) (quote quote) (lambda (e916 r917 w918 s919 mod920) ((lambda (tmp921) ((lambda (tmp922) (if tmp922 (apply (lambda (_923 e924) (build-data89 s919 (strip158 e924 w918))) tmp922) ((lambda (_925) (syntax-violation (quote quote) "bad syntax" (source-wrap140 e916 w918 s919 mod920))) tmp921))) ($sc-dispatch tmp921 (quote (any any))))) e916))) (global-extend109 (quote core) (quote syntax) (letrec ((regen933 (lambda (x934) (let ((t935 (car x934))) (if (memv t935 (quote (ref))) (build-lexical-reference81 (quote value) #f (cadr x934) (cadr x934)) (if (memv t935 (quote (primitive))) (build-primref88 #f (cadr x934)) (if (memv t935 (quote (quote))) (build-data89 #f (cadr x934)) (if (memv t935 (quote (lambda))) (build-lambda87 #f (cadr x934) (cadr x934) #f (regen933 (caddr x934))) (if (memv t935 (quote (map))) (let ((ls936 (map regen933 (cdr x934)))) (build-application79 #f (build-primref88 #f (quote map)) ls936)) (build-application79 #f (build-primref88 #f (car x934)) (map regen933 (cdr x934))))))))))) (gen-vector932 (lambda (x937) (cond ((eq? (car x937) (quote list)) (cons (quote vector) (cdr x937))) ((eq? (car x937) (quote quote)) (list (quote quote) (list->vector (cadr x937)))) (else (list (quote list->vector) x937))))) (gen-append931 (lambda (x938 y939) (if (equal? y939 (quote (quote ()))) x938 (list (quote append) x938 y939)))) (gen-cons930 (lambda (x940 y941) (let ((t942 (car y941))) (if (memv t942 (quote (quote))) (if (eq? (car x940) (quote quote)) (list (quote quote) (cons (cadr x940) (cadr y941))) (if (eq? (cadr y941) (quote ())) (list (quote list) x940) (list (quote cons) x940 y941))) (if (memv t942 (quote (list))) (cons (quote list) (cons x940 (cdr y941))) (list (quote cons) x940 y941)))))) (gen-map929 (lambda (e943 map-env944) (let ((formals945 (map cdr map-env944)) (actuals946 (map (lambda (x947) (list (quote ref) (car x947))) map-env944))) (cond ((eq? (car e943) (quote ref)) (car actuals946)) ((and-map (lambda (x948) (and (eq? (car x948) (quote ref)) (memq (cadr x948) formals945))) (cdr e943)) (cons (quote map) (cons (list (quote primitive) (car e943)) (map (let ((r949 (map cons formals945 actuals946))) (lambda (x950) (cdr (assq (cadr x950) r949)))) (cdr e943))))) (else (cons (quote map) (cons (list (quote lambda) formals945 e943) actuals946))))))) (gen-mappend928 (lambda (e951 map-env952) (list (quote apply) (quote (primitive append)) (gen-map929 e951 map-env952)))) (gen-ref927 (lambda (src953 var954 level955 maps956) (if (fx=73 level955 0) (values var954 maps956) (if (null? maps956) (syntax-violation (quote syntax) "missing ellipsis" src953) (call-with-values (lambda () (gen-ref927 src953 var954 (fx-72 level955 1) (cdr maps956))) (lambda (outer-var957 outer-maps958) (let ((b959 (assq outer-var957 (car maps956)))) (if b959 (values (cdr b959) maps956) (let ((inner-var960 (gen-var159 (quote tmp)))) (values inner-var960 (cons (cons (cons outer-var957 inner-var960) (car maps956)) outer-maps958))))))))))) (gen-syntax926 (lambda (src961 e962 r963 maps964 ellipsis?965 mod966) (if (id?111 e962) (let ((label967 (id-var-name133 e962 (quote (()))))) (let ((b968 (lookup108 label967 r963 mod966))) (if (eq? (binding-type103 b968) (quote syntax)) (call-with-values (lambda () (let ((var.lev969 (binding-value104 b968))) (gen-ref927 src961 (car var.lev969) (cdr var.lev969) maps964))) (lambda (var970 maps971) (values (list (quote ref) var970) maps971))) (if (ellipsis?965 e962) (syntax-violation (quote syntax) "misplaced ellipsis" src961) (values (list (quote quote) e962) maps964))))) ((lambda (tmp972) ((lambda (tmp973) (if (if tmp973 (apply (lambda (dots974 e975) (ellipsis?965 dots974)) tmp973) #f) (apply (lambda (dots976 e977) (gen-syntax926 src961 e977 r963 maps964 (lambda (x978) #f) mod966)) tmp973) ((lambda (tmp979) (if (if tmp979 (apply (lambda (x980 dots981 y982) (ellipsis?965 dots981)) tmp979) #f) (apply (lambda (x983 dots984 y985) (letrec ((f986 (lambda (y987 k988) ((lambda (tmp992) ((lambda (tmp993) (if (if tmp993 (apply (lambda (dots994 y995) (ellipsis?965 dots994)) tmp993) #f) (apply (lambda (dots996 y997) (f986 y997 (lambda (maps998) (call-with-values (lambda () (k988 (cons (quote ()) maps998))) (lambda (x999 maps1000) (if (null? (car maps1000)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-mappend928 x999 (car maps1000)) (cdr maps1000)))))))) tmp993) ((lambda (_1001) (call-with-values (lambda () (gen-syntax926 src961 y987 r963 maps964 ellipsis?965 mod966)) (lambda (y1002 maps1003) (call-with-values (lambda () (k988 maps1003)) (lambda (x1004 maps1005) (values (gen-append931 x1004 y1002) maps1005)))))) tmp992))) ($sc-dispatch tmp992 (quote (any . any))))) y987)))) (f986 y985 (lambda (maps989) (call-with-values (lambda () (gen-syntax926 src961 x983 r963 (cons (quote ()) maps989) ellipsis?965 mod966)) (lambda (x990 maps991) (if (null? (car maps991)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-map929 x990 (car maps991)) (cdr maps991))))))))) tmp979) ((lambda (tmp1006) (if tmp1006 (apply (lambda (x1007 y1008) (call-with-values (lambda () (gen-syntax926 src961 x1007 r963 maps964 ellipsis?965 mod966)) (lambda (x1009 maps1010) (call-with-values (lambda () (gen-syntax926 src961 y1008 r963 maps1010 ellipsis?965 mod966)) (lambda (y1011 maps1012) (values (gen-cons930 x1009 y1011) maps1012)))))) tmp1006) ((lambda (tmp1013) (if tmp1013 (apply (lambda (e11014 e21015) (call-with-values (lambda () (gen-syntax926 src961 (cons e11014 e21015) r963 maps964 ellipsis?965 mod966)) (lambda (e1017 maps1018) (values (gen-vector932 e1017) maps1018)))) tmp1013) ((lambda (_1019) (values (list (quote quote) e962) maps964)) tmp972))) ($sc-dispatch tmp972 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp972 (quote (any . any)))))) ($sc-dispatch tmp972 (quote (any any . any)))))) ($sc-dispatch tmp972 (quote (any any))))) e962))))) (lambda (e1020 r1021 w1022 s1023 mod1024) (let ((e1025 (source-wrap140 e1020 w1022 s1023 mod1024))) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda (_1028 x1029) (call-with-values (lambda () (gen-syntax926 e1025 x1029 r1021 (quote ()) ellipsis?156 mod1024)) (lambda (e1030 maps1031) (regen933 e1030)))) tmp1027) ((lambda (_1032) (syntax-violation (quote syntax) "bad `syntax' form" e1025)) tmp1026))) ($sc-dispatch tmp1026 (quote (any any))))) e1025))))) (global-extend109 (quote core) (quote lambda) (lambda (e1033 r1034 w1035 s1036 mod1037) ((lambda (tmp1038) ((lambda (tmp1039) (if tmp1039 (apply (lambda (_1040 c1041) (chi-lambda-clause152 (source-wrap140 e1033 w1035 s1036 mod1037) #f c1041 r1034 w1035 mod1037 (lambda (names1042 vars1043 docstring1044 body1045) (build-lambda87 s1036 names1042 vars1043 docstring1044 body1045)))) tmp1039) (syntax-violation #f "source expression failed to match any pattern" tmp1038))) ($sc-dispatch tmp1038 (quote (any . any))))) e1033))) (global-extend109 (quote core) (quote let) (letrec ((chi-let1046 (lambda (e1047 r1048 w1049 s1050 mod1051 constructor1052 ids1053 vals1054 exps1055) (if (not (valid-bound-ids?136 ids1053)) (syntax-violation (quote let) "duplicate bound variable" e1047) (let ((labels1056 (gen-labels117 ids1053)) (new-vars1057 (map gen-var159 ids1053))) (let ((nw1058 (make-binding-wrap128 ids1053 labels1056 w1049)) (nr1059 (extend-var-env106 labels1056 new-vars1057 r1048))) (constructor1052 s1050 (map syntax->datum ids1053) new-vars1057 (map (lambda (x1060) (chi147 x1060 r1048 w1049 mod1051)) vals1054) (chi-body151 exps1055 (source-wrap140 e1047 nw1058 s1050 mod1051) nr1059 nw1058 mod1051)))))))) (lambda (e1061 r1062 w1063 s1064 mod1065) ((lambda (tmp1066) ((lambda (tmp1067) (if tmp1067 (apply (lambda (_1068 id1069 val1070 e11071 e21072) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-let91 id1069 val1070 (cons e11071 e21072))) tmp1067) ((lambda (tmp1076) (if (if tmp1076 (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (id?111 f1078)) tmp1076) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-named-let92 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1076) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap140 e1061 w1063 s1064 mod1065))) tmp1066))) ($sc-dispatch tmp1066 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1066 (quote (any #(each (any any)) any . each-any))))) e1061)))) (global-extend109 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (let ((ids1105 id1101)) (if (not (valid-bound-ids?136 ids1105)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1107 (gen-labels117 ids1105)) (new-vars1108 (map gen-var159 ids1105))) (let ((w1109 (make-binding-wrap128 ids1105 labels1107 w1095)) (r1110 (extend-var-env106 labels1107 new-vars1108 r1094))) (build-letrec93 s1096 (map syntax->datum ids1105) new-vars1108 (map (lambda (x1111) (chi147 x1111 r1110 w1109 mod1097)) val1102) (chi-body151 (cons e11103 e21104) (source-wrap140 e1093 w1109 s1096 mod1097) r1110 w1109 mod1097))))))) tmp1099) ((lambda (_1114) (syntax-violation (quote letrec) "bad letrec" (source-wrap140 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend109 (quote core) (quote set!) (lambda (e1115 r1116 w1117 s1118 mod1119) ((lambda (tmp1120) ((lambda (tmp1121) (if (if tmp1121 (apply (lambda (_1122 id1123 val1124) (id?111 id1123)) tmp1121) #f) (apply (lambda (_1125 id1126 val1127) (let ((val1128 (chi147 val1127 r1116 w1117 mod1119)) (n1129 (id-var-name133 id1126 w1117))) (let ((b1130 (lookup108 n1129 r1116 mod1119))) (let ((t1131 (binding-type103 b1130))) (if (memv t1131 (quote (lexical))) (build-lexical-assignment82 s1118 (syntax->datum id1126) (binding-value104 b1130) val1128) (if (memv t1131 (quote (global))) (build-global-assignment85 s1118 n1129 val1128 mod1119) (if (memv t1131 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap139 id1126 w1117 mod1119)) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))))))))) tmp1121) ((lambda (tmp1132) (if tmp1132 (apply (lambda (_1133 head1134 tail1135 val1136) (call-with-values (lambda () (syntax-type145 head1134 r1116 (quote (())) #f #f mod1119)) (lambda (type1137 value1138 ee1139 ww1140 ss1141 modmod1142) (let ((t1143 type1137)) (if (memv t1143 (quote (module-ref))) (let ((val1144 (chi147 val1136 r1116 w1117 mod1119))) (call-with-values (lambda () (value1138 (cons head1134 tail1135))) (lambda (id1146 mod1147) (build-global-assignment85 s1118 id1146 val1144 mod1147)))) (build-application79 s1118 (chi147 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1134) r1116 w1117 mod1119) (map (lambda (e1148) (chi147 e1148 r1116 w1117 mod1119)) (append tail1135 (list val1136))))))))) tmp1132) ((lambda (_1150) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))) tmp1120))) ($sc-dispatch tmp1120 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1120 (quote (any any any))))) e1115))) (global-extend109 (quote module-ref) (quote @) (lambda (e1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 mod1155 id1156) (and (and-map id?111 mod1155) (id?111 id1156))) tmp1153) #f) (apply (lambda (_1158 mod1159 id1160) (values (syntax->datum id1160) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1159)))) tmp1153) (syntax-violation #f "source expression failed to match any pattern" tmp1152))) ($sc-dispatch tmp1152 (quote (any each-any any))))) e1151))) (global-extend109 (quote module-ref) (quote @@) (lambda (e1162) ((lambda (tmp1163) ((lambda (tmp1164) (if (if tmp1164 (apply (lambda (_1165 mod1166 id1167) (and (and-map id?111 mod1166) (id?111 id1167))) tmp1164) #f) (apply (lambda (_1169 mod1170 id1171) (values (syntax->datum id1171) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1170)))) tmp1164) (syntax-violation #f "source expression failed to match any pattern" tmp1163))) ($sc-dispatch tmp1163 (quote (any each-any any))))) e1162))) (global-extend109 (quote begin) (quote begin) (quote ())) (global-extend109 (quote define) (quote define) (quote ())) (global-extend109 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend109 (quote eval-when) (quote eval-when) (quote ())) (global-extend109 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1176 (lambda (x1177 keys1178 clauses1179 r1180 mod1181) (if (null? clauses1179) (build-application79 #f (build-primref88 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1177)) ((lambda (tmp1182) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 exp1185) (if (and (id?111 pat1184) (and-map (lambda (x1186) (not (free-id=?134 pat1184 x1186))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1178))) (let ((labels1187 (list (gen-label116))) (var1188 (gen-var159 pat1184))) (build-application79 #f (build-lambda87 #f (list (syntax->datum pat1184)) (list var1188) #f (chi147 exp1185 (extend-env105 labels1187 (list (cons (quote syntax) (cons var1188 0))) r1180) (make-binding-wrap128 (list pat1184) labels1187 (quote (()))) mod1181)) (list x1177))) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1184 #t exp1185 mod1181))) tmp1183) ((lambda (tmp1189) (if tmp1189 (apply (lambda (pat1190 fender1191 exp1192) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1190 fender1191 exp1192 mod1181)) tmp1189) ((lambda (_1193) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1179))) tmp1182))) ($sc-dispatch tmp1182 (quote (any any any)))))) ($sc-dispatch tmp1182 (quote (any any))))) (car clauses1179))))) (gen-clause1175 (lambda (x1194 keys1195 clauses1196 r1197 pat1198 fender1199 exp1200 mod1201) (call-with-values (lambda () (convert-pattern1173 pat1198 keys1195)) (lambda (p1202 pvars1203) (cond ((not (distinct-bound-ids?137 (map car pvars1203))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1198)) ((not (and-map (lambda (x1204) (not (ellipsis?156 (car x1204)))) pvars1203)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1198)) (else (let ((y1205 (gen-var159 (quote tmp)))) (build-application79 #f (build-lambda87 #f (list (quote tmp)) (list y1205) #f (let ((y1206 (build-lexical-reference81 (quote value) #f (quote tmp) y1205))) (build-conditional80 #f ((lambda (tmp1207) ((lambda (tmp1208) (if tmp1208 (apply (lambda () y1206) tmp1208) ((lambda (_1209) (build-conditional80 #f y1206 (build-dispatch-call1174 pvars1203 fender1199 y1206 r1197 mod1201) (build-data89 #f #f))) tmp1207))) ($sc-dispatch tmp1207 (quote #(atom #t))))) fender1199) (build-dispatch-call1174 pvars1203 exp1200 y1206 r1197 mod1201) (gen-syntax-case1176 x1194 keys1195 clauses1196 r1197 mod1201)))) (list (if (eq? p1202 (quote any)) (build-application79 #f (build-primref88 #f (quote list)) (list x1194)) (build-application79 #f (build-primref88 #f (quote $sc-dispatch)) (list x1194 (build-data89 #f p1202))))))))))))) (build-dispatch-call1174 (lambda (pvars1210 exp1211 y1212 r1213 mod1214) (let ((ids1215 (map car pvars1210)) (levels1216 (map cdr pvars1210))) (let ((labels1217 (gen-labels117 ids1215)) (new-vars1218 (map gen-var159 ids1215))) (build-application79 #f (build-primref88 #f (quote apply)) (list (build-lambda87 #f (map syntax->datum ids1215) new-vars1218 #f (chi147 exp1211 (extend-env105 labels1217 (map (lambda (var1219 level1220) (cons (quote syntax) (cons var1219 level1220))) new-vars1218 (map cdr pvars1210)) r1213) (make-binding-wrap128 ids1215 labels1217 (quote (()))) mod1214)) y1212)))))) (convert-pattern1173 (lambda (pattern1221 keys1222) (letrec ((cvt1223 (lambda (p1224 n1225 ids1226) (if (id?111 p1224) (if (bound-id-member?138 p1224 keys1222) (values (vector (quote free-id) p1224) ids1226) (values (quote any) (cons (cons p1224 n1225) ids1226))) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (x1229 dots1230) (ellipsis?156 dots1230)) tmp1228) #f) (apply (lambda (x1231 dots1232) (call-with-values (lambda () (cvt1223 x1231 (fx+71 n1225 1) ids1226)) (lambda (p1233 ids1234) (values (if (eq? p1233 (quote any)) (quote each-any) (vector (quote each) p1233)) ids1234)))) tmp1228) ((lambda (tmp1235) (if tmp1235 (apply (lambda (x1236 y1237) (call-with-values (lambda () (cvt1223 y1237 n1225 ids1226)) (lambda (y1238 ids1239) (call-with-values (lambda () (cvt1223 x1236 n1225 ids1239)) (lambda (x1240 ids1241) (values (cons x1240 y1238) ids1241)))))) tmp1235) ((lambda (tmp1242) (if tmp1242 (apply (lambda () (values (quote ()) ids1226)) tmp1242) ((lambda (tmp1243) (if tmp1243 (apply (lambda (x1244) (call-with-values (lambda () (cvt1223 x1244 n1225 ids1226)) (lambda (p1246 ids1247) (values (vector (quote vector) p1246) ids1247)))) tmp1243) ((lambda (x1248) (values (vector (quote atom) (strip158 p1224 (quote (())))) ids1226)) tmp1227))) ($sc-dispatch tmp1227 (quote #(vector each-any)))))) ($sc-dispatch tmp1227 (quote ()))))) ($sc-dispatch tmp1227 (quote (any . any)))))) ($sc-dispatch tmp1227 (quote (any any))))) p1224))))) (cvt1223 pattern1221 0 (quote ())))))) (lambda (e1249 r1250 w1251 s1252 mod1253) (let ((e1254 (source-wrap140 e1249 w1251 s1252 mod1253))) ((lambda (tmp1255) ((lambda (tmp1256) (if tmp1256 (apply (lambda (_1257 val1258 key1259 m1260) (if (and-map (lambda (x1261) (and (id?111 x1261) (not (ellipsis?156 x1261)))) key1259) (let ((x1263 (gen-var159 (quote tmp)))) (build-application79 s1252 (build-lambda87 #f (list (quote tmp)) (list x1263) #f (gen-syntax-case1176 (build-lexical-reference81 (quote value) #f (quote tmp) x1263) key1259 m1260 r1250 mod1253)) (list (chi147 val1258 r1250 (quote (())) mod1253)))) (syntax-violation (quote syntax-case) "invalid literals list" e1254))) tmp1256) (syntax-violation #f "source expression failed to match any pattern" tmp1255))) ($sc-dispatch tmp1255 (quote (any any each-any . each-any))))) e1254))))) (set! sc-expand (lambda (x1267 . rest1266) (if (and (pair? x1267) (equal? (car x1267) noexpand69)) (cadr x1267) (let ((m1268 (if (null? rest1266) (quote e) (car rest1266))) (esew1269 (if (or (null? rest1266) (null? (cdr rest1266))) (quote (eval)) (cadr rest1266)))) (with-fluid* *mode*70 m1268 (lambda () (chi-top146 x1267 (quote ()) (quote ((top))) m1268 esew1269 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1270) (nonsymbol-id?110 x1270))) (set! datum->syntax (lambda (id1271 datum1272) (make-syntax-object94 datum1272 (syntax-object-wrap97 id1271) #f))) (set! syntax->datum (lambda (x1273) (strip158 x1273 (quote (()))))) (set! generate-temporaries (lambda (ls1274) (begin (let ((x1275 ls1274)) (if (not (list? x1275)) (syntax-violation (quote generate-temporaries) "invalid argument" x1275))) (map (lambda (x1276) (wrap139 (gensym) (quote ((top))) #f)) ls1274)))) (set! free-identifier=? (lambda (x1277 y1278) (begin (let ((x1279 x1277)) (if (not (nonsymbol-id?110 x1279)) (syntax-violation (quote free-identifier=?) "invalid argument" x1279))) (let ((x1280 y1278)) (if (not (nonsymbol-id?110 x1280)) (syntax-violation (quote free-identifier=?) "invalid argument" x1280))) (free-id=?134 x1277 y1278)))) (set! bound-identifier=? (lambda (x1281 y1282) (begin (let ((x1283 x1281)) (if (not (nonsymbol-id?110 x1283)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1283))) (let ((x1284 y1282)) (if (not (nonsymbol-id?110 x1284)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1284))) (bound-id=?135 x1281 y1282)))) (set! syntax-violation (lambda (who1288 message1287 form1286 . subform1285) (begin (let ((x1289 who1288)) (if (not ((lambda (x1290) (or (not x1290) (string? x1290) (symbol? x1290))) x1289)) (syntax-violation (quote syntax-violation) "invalid argument" x1289))) (let ((x1291 message1287)) (if (not (string? x1291)) (syntax-violation (quote syntax-violation) "invalid argument" x1291))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1288 "~a: " "") "~a " (if (null? subform1285) "in ~a" "in subform `~s' of `~s'")) (let ((tail1292 (cons message1287 (map (lambda (x1293) (strip158 x1293 (quote (())))) (append subform1285 (list form1286)))))) (if who1288 (cons who1288 tail1292) tail1292)) #f)))) (letrec ((match1298 (lambda (e1299 p1300 w1301 r1302 mod1303) (cond ((not r1302) #f) ((eq? p1300 (quote any)) (cons (wrap139 e1299 w1301 mod1303) r1302)) ((syntax-object?95 e1299) (match*1297 (let ((e1304 (syntax-object-expression96 e1299))) (if (annotation? e1304) (annotation-expression e1304) e1304)) p1300 (join-wraps130 w1301 (syntax-object-wrap97 e1299)) r1302 (syntax-object-module98 e1299))) (else (match*1297 (let ((e1305 e1299)) (if (annotation? e1305) (annotation-expression e1305) e1305)) p1300 w1301 r1302 mod1303))))) (match*1297 (lambda (e1306 p1307 w1308 r1309 mod1310) (cond ((null? p1307) (and (null? e1306) r1309)) ((pair? p1307) (and (pair? e1306) (match1298 (car e1306) (car p1307) w1308 (match1298 (cdr e1306) (cdr p1307) w1308 r1309 mod1310) mod1310))) ((eq? p1307 (quote each-any)) (let ((l1311 (match-each-any1295 e1306 w1308 mod1310))) (and l1311 (cons l1311 r1309)))) (else (let ((t1312 (vector-ref p1307 0))) (if (memv t1312 (quote (each))) (if (null? e1306) (match-empty1296 (vector-ref p1307 1) r1309) (let ((l1313 (match-each1294 e1306 (vector-ref p1307 1) w1308 mod1310))) (and l1313 (letrec ((collect1314 (lambda (l1315) (if (null? (car l1315)) r1309 (cons (map car l1315) (collect1314 (map cdr l1315))))))) (collect1314 l1313))))) (if (memv t1312 (quote (free-id))) (and (id?111 e1306) (free-id=?134 (wrap139 e1306 w1308 mod1310) (vector-ref p1307 1)) r1309) (if (memv t1312 (quote (atom))) (and (equal? (vector-ref p1307 1) (strip158 e1306 w1308)) r1309) (if (memv t1312 (quote (vector))) (and (vector? e1306) (match1298 (vector->list e1306) (vector-ref p1307 1) w1308 r1309 mod1310))))))))))) (match-empty1296 (lambda (p1316 r1317) (cond ((null? p1316) r1317) ((eq? p1316 (quote any)) (cons (quote ()) r1317)) ((pair? p1316) (match-empty1296 (car p1316) (match-empty1296 (cdr p1316) r1317))) ((eq? p1316 (quote each-any)) (cons (quote ()) r1317)) (else (let ((t1318 (vector-ref p1316 0))) (if (memv t1318 (quote (each))) (match-empty1296 (vector-ref p1316 1) r1317) (if (memv t1318 (quote (free-id atom))) r1317 (if (memv t1318 (quote (vector))) (match-empty1296 (vector-ref p1316 1) r1317))))))))) (match-each-any1295 (lambda (e1319 w1320 mod1321) (cond ((annotation? e1319) (match-each-any1295 (annotation-expression e1319) w1320 mod1321)) ((pair? e1319) (let ((l1322 (match-each-any1295 (cdr e1319) w1320 mod1321))) (and l1322 (cons (wrap139 (car e1319) w1320 mod1321) l1322)))) ((null? e1319) (quote ())) ((syntax-object?95 e1319) (match-each-any1295 (syntax-object-expression96 e1319) (join-wraps130 w1320 (syntax-object-wrap97 e1319)) mod1321)) (else #f)))) (match-each1294 (lambda (e1323 p1324 w1325 mod1326) (cond ((annotation? e1323) (match-each1294 (annotation-expression e1323) p1324 w1325 mod1326)) ((pair? e1323) (let ((first1327 (match1298 (car e1323) p1324 w1325 (quote ()) mod1326))) (and first1327 (let ((rest1328 (match-each1294 (cdr e1323) p1324 w1325 mod1326))) (and rest1328 (cons first1327 rest1328)))))) ((null? e1323) (quote ())) ((syntax-object?95 e1323) (match-each1294 (syntax-object-expression96 e1323) p1324 (join-wraps130 w1325 (syntax-object-wrap97 e1323)) (syntax-object-module98 e1323))) (else #f))))) (set! $sc-dispatch (lambda (e1329 p1330) (cond ((eq? p1330 (quote any)) (list e1329)) ((syntax-object?95 e1329) (match*1297 (let ((e1331 (syntax-object-expression96 e1329))) (if (annotation? e1331) (annotation-expression e1331) e1331)) p1330 (syntax-object-wrap97 e1329) (quote ()) (syntax-object-module98 e1329))) (else (match*1297 (let ((e1332 e1329)) (if (annotation? e1332) (annotation-expression e1332) e1332)) p1330 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1333) ((lambda (tmp1334) ((lambda (tmp1335) (if tmp1335 (apply (lambda (_1336 e11337 e21338) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11337 e21338))) tmp1335) ((lambda (tmp1340) (if tmp1340 (apply (lambda (_1341 out1342 in1343 e11344 e21345) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1343 (quote ()) (list out1342 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11344 e21345))))) tmp1340) ((lambda (tmp1347) (if tmp1347 (apply (lambda (_1348 out1349 in1350 e11351 e21352) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1350) (quote ()) (list out1349 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11351 e21352))))) tmp1347) (syntax-violation #f "source expression failed to match any pattern" tmp1334))) ($sc-dispatch tmp1334 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any () any . each-any))))) x1333)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1356) ((lambda (tmp1357) ((lambda (tmp1358) (if tmp1358 (apply (lambda (_1359 k1360 keyword1361 pattern1362 template1363) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1360 (map (lambda (tmp1366 tmp1365) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1365) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1366))) template1363 pattern1362)))))) tmp1358) (syntax-violation #f "source expression failed to match any pattern" tmp1357))) ($sc-dispatch tmp1357 (quote (any each-any . #(each ((any . any) any))))))) x1356)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1367) ((lambda (tmp1368) ((lambda (tmp1369) (if (if tmp1369 (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (and-map identifier? x1371)) tmp1369) #f) (apply (lambda (let*1376 x1377 v1378 e11379 e21380) (letrec ((f1381 (lambda (bindings1382) (if (null? bindings1382) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11379 e21380))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (body1388 binding1389) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1389) body1388)) tmp1387) (syntax-violation #f "source expression failed to match any pattern" tmp1386))) ($sc-dispatch tmp1386 (quote (any any))))) (list (f1381 (cdr bindings1382)) (car bindings1382))))))) (f1381 (map list x1377 v1378)))) tmp1369) (syntax-violation #f "source expression failed to match any pattern" tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) x1367)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1390) ((lambda (tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (_1393 var1394 init1395 step1396 e01397 e11398 c1399) ((lambda (tmp1400) ((lambda (tmp1401) (if tmp1401 (apply (lambda (step1402) ((lambda (tmp1403) ((lambda (tmp1404) (if tmp1404 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1404) ((lambda (tmp1409) (if tmp1409 (apply (lambda (e11410 e21411) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11410 e21411)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1409) (syntax-violation #f "source expression failed to match any pattern" tmp1403))) ($sc-dispatch tmp1403 (quote (any . each-any)))))) ($sc-dispatch tmp1403 (quote ())))) e11398)) tmp1401) (syntax-violation #f "source expression failed to match any pattern" tmp1400))) ($sc-dispatch tmp1400 (quote each-any)))) (map (lambda (v1418 s1419) ((lambda (tmp1420) ((lambda (tmp1421) (if tmp1421 (apply (lambda () v1418) tmp1421) ((lambda (tmp1422) (if tmp1422 (apply (lambda (e1423) e1423) tmp1422) ((lambda (_1424) (syntax-violation (quote do) "bad step expression" orig-x1390 s1419)) tmp1420))) ($sc-dispatch tmp1420 (quote (any)))))) ($sc-dispatch tmp1420 (quote ())))) s1419)) var1394 step1396))) tmp1392) (syntax-violation #f "source expression failed to match any pattern" tmp1391))) ($sc-dispatch tmp1391 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1390)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1427 (lambda (x1431 y1432) ((lambda (tmp1433) ((lambda (tmp1434) (if tmp1434 (apply (lambda (x1435 y1436) ((lambda (tmp1437) ((lambda (tmp1438) (if tmp1438 (apply (lambda (dy1439) ((lambda (tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (dx1442) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1442 dy1439))) tmp1441) ((lambda (_1443) (if (null? dy1439) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436))) tmp1440))) ($sc-dispatch tmp1440 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1435)) tmp1438) ((lambda (tmp1444) (if tmp1444 (apply (lambda (stuff1445) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1435 stuff1445))) tmp1444) ((lambda (else1446) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436)) tmp1437))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1436)) tmp1434) (syntax-violation #f "source expression failed to match any pattern" tmp1433))) ($sc-dispatch tmp1433 (quote (any any))))) (list x1431 y1432)))) (quasiappend1428 (lambda (x1447 y1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (x1451 y1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda () x1451) tmp1454) ((lambda (_1455) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1451 y1452)) tmp1453))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1452)) tmp1450) (syntax-violation #f "source expression failed to match any pattern" tmp1449))) ($sc-dispatch tmp1449 (quote (any any))))) (list x1447 y1448)))) (quasivector1429 (lambda (x1456) ((lambda (tmp1457) ((lambda (x1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (x1461) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1461))) tmp1460) ((lambda (tmp1463) (if tmp1463 (apply (lambda (x1464) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1464)) tmp1463) ((lambda (_1466) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1458)) tmp1459))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1458)) tmp1457)) x1456))) (quasi1430 (lambda (p1467 lev1468) ((lambda (tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471) (if (= lev1468 0) p1471 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1471) (- lev1468 1))))) tmp1470) ((lambda (tmp1472) (if tmp1472 (apply (lambda (p1473 q1474) (if (= lev1468 0) (quasiappend1428 p1473 (quasi1430 q1474 lev1468)) (quasicons1427 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1473) (- lev1468 1))) (quasi1430 q1474 lev1468)))) tmp1472) ((lambda (tmp1475) (if tmp1475 (apply (lambda (p1476) (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1476) (+ lev1468 1)))) tmp1475) ((lambda (tmp1477) (if tmp1477 (apply (lambda (p1478 q1479) (quasicons1427 (quasi1430 p1478 lev1468) (quasi1430 q1479 lev1468))) tmp1477) ((lambda (tmp1480) (if tmp1480 (apply (lambda (x1481) (quasivector1429 (quasi1430 x1481 lev1468))) tmp1480) ((lambda (p1483) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1483)) tmp1469))) ($sc-dispatch tmp1469 (quote #(vector each-any)))))) ($sc-dispatch tmp1469 (quote (any . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1469 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1467)))) (lambda (x1484) ((lambda (tmp1485) ((lambda (tmp1486) (if tmp1486 (apply (lambda (_1487 e1488) (quasi1430 e1488 0)) tmp1486) (syntax-violation #f "source expression failed to match any pattern" tmp1485))) ($sc-dispatch tmp1485 (quote (any any))))) x1484))))) -(define include (make-syncase-macro (quote macro) (lambda (x1489) (letrec ((read-file1490 (lambda (fn1491 k1492) (let ((p1493 (open-input-file fn1491))) (letrec ((f1494 (lambda (x1495) (if (eof-object? x1495) (begin (close-input-port p1493) (quote ())) (cons (datum->syntax k1492 x1495) (f1494 (read p1493))))))) (f1494 (read p1493))))))) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (k1498 filename1499) (let ((fn1500 (syntax->datum filename1499))) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (exp1503) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1503)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote each-any)))) (read-file1490 fn1500 k1498)))) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any any))))) x1489))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1505)) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any))))) x1505)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1510) ((lambda (tmp1511) ((lambda (tmp1512) (if tmp1512 (apply (lambda (_1513 e1514) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1510)) tmp1512) (syntax-violation #f "source expression failed to match any pattern" tmp1511))) ($sc-dispatch tmp1511 (quote (any any))))) x1510)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if tmp1517 (apply (lambda (_1518 e1519 m11520 m21521) ((lambda (tmp1522) ((lambda (body1523) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1519)) body1523)) tmp1522)) (letrec ((f1524 (lambda (clause1525 clauses1526) (if (null? clauses1526) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (e11530 e21531) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11530 e21531))) tmp1529) ((lambda (tmp1533) (if tmp1533 (apply (lambda (k1534 e11535 e21536) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1534)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11535 e21536)))) tmp1533) ((lambda (_1539) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1528))) ($sc-dispatch tmp1528 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1528 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1525) ((lambda (tmp1540) ((lambda (rest1541) ((lambda (tmp1542) ((lambda (tmp1543) (if tmp1543 (apply (lambda (k1544 e11545 e21546) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1544)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11545 e21546)) rest1541)) tmp1543) ((lambda (_1549) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1542))) ($sc-dispatch tmp1542 (quote (each-any any . each-any))))) clause1525)) tmp1540)) (f1524 (car clauses1526) (cdr clauses1526))))))) (f1524 m11520 m21521)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any any any . each-any))))) x1515)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e1554) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1554)) (list (cons _1553 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1554 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1552) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any any))))) x1550)))) +(letrec ((and-map*475 (lambda (f515 first514 . rest513) (or (null? first514) (if (null? rest513) (letrec ((andmap516 (lambda (first517) (let ((x518 (car first517)) (first519 (cdr first517))) (if (null? first519) (f515 x518) (and (f515 x518) (andmap516 first519))))))) (andmap516 first514)) (letrec ((andmap520 (lambda (first521 rest522) (let ((x523 (car first521)) (xr524 (map car rest522)) (first525 (cdr first521)) (rest526 (map cdr rest522))) (if (null? first525) (apply f515 (cons x523 xr524)) (and (apply f515 (cons x523 xr524)) (andmap520 first525 rest526))))))) (andmap520 first514 rest513))))))) (letrec ((lambda-var-list618 (lambda (vars747) (letrec ((lvl748 (lambda (vars749 ls750 w751) (cond ((pair? vars749) (lvl748 (cdr vars749) (cons (wrap597 (car vars749) w751 #f) ls750) w751)) ((id?569 vars749) (cons (wrap597 vars749 w751 #f) ls750)) ((null? vars749) ls750) ((syntax-object?553 vars749) (lvl748 (syntax-object-expression554 vars749) ls750 (join-wraps588 w751 (syntax-object-wrap555 vars749)))) ((annotation? vars749) (lvl748 (annotation-expression vars749) ls750 w751)) (else (cons vars749 ls750)))))) (lvl748 vars747 (quote ()) (quote (())))))) (gen-var617 (lambda (id752) (let ((id753 (if (syntax-object?553 id752) (syntax-object-expression554 id752) id752))) (if (annotation? id753) (gensym (symbol->string (annotation-expression id753))) (gensym (symbol->string id753)))))) (strip616 (lambda (x754 w755) (if (memq (quote top) (wrap-marks572 w755)) (if (or (annotation? x754) (and (pair? x754) (annotation? (car x754)))) (strip-annotation615 x754 #f) x754) (letrec ((f756 (lambda (x757) (cond ((syntax-object?553 x757) (strip616 (syntax-object-expression554 x757) (syntax-object-wrap555 x757))) ((pair? x757) (let ((a758 (f756 (car x757))) (d759 (f756 (cdr x757)))) (if (and (eq? a758 (car x757)) (eq? d759 (cdr x757))) x757 (cons a758 d759)))) ((vector? x757) (let ((old760 (vector->list x757))) (let ((new761 (map f756 old760))) (if (and-map*475 eq? old760 new761) x757 (list->vector new761))))) (else x757))))) (f756 x754))))) (strip-annotation615 (lambda (x762 parent763) (cond ((pair? x762) (let ((new764 (cons #f #f))) (begin (if parent763 (set-annotation-stripped! parent763 new764)) (set-car! new764 (strip-annotation615 (car x762) #f)) (set-cdr! new764 (strip-annotation615 (cdr x762) #f)) new764))) ((annotation? x762) (or (annotation-stripped x762) (strip-annotation615 (annotation-expression x762) x762))) ((vector? x762) (let ((new765 (make-vector (vector-length x762)))) (begin (if parent763 (set-annotation-stripped! parent763 new765)) (letrec ((loop766 (lambda (i767) (unless (fx<532 i767 0) (vector-set! new765 i767 (strip-annotation615 (vector-ref x762 i767) #f)) (loop766 (fx-530 i767 1)))))) (loop766 (- (vector-length x762) 1))) new765))) (else x762)))) (ellipsis?614 (lambda (x768) (and (nonsymbol-id?568 x768) (free-id=?592 x768 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void613 (lambda () (build-application537 #f (build-primref546 #f (quote if)) (quote (#f #f))))) (eval-local-transformer612 (lambda (expanded769 mod770) (let ((p771 (local-eval-hook534 expanded769 mod770))) (if (procedure? p771) p771 (syntax-violation #f "nonprocedure transformer" p771))))) (chi-local-syntax611 (lambda (rec?772 e773 r774 w775 s776 mod777 k778) ((lambda (tmp779) ((lambda (tmp780) (if tmp780 (apply (lambda (_781 id782 val783 e1784 e2785) (let ((ids786 id782)) (if (not (valid-bound-ids?594 ids786)) (syntax-violation #f "duplicate bound keyword" e773) (let ((labels788 (gen-labels575 ids786))) (let ((new-w789 (make-binding-wrap586 ids786 labels788 w775))) (k778 (cons e1784 e2785) (extend-env563 labels788 (let ((w791 (if rec?772 new-w789 w775)) (trans-r792 (macros-only-env565 r774))) (map (lambda (x793) (cons (quote macro) (eval-local-transformer612 (chi605 x793 trans-r792 w791 mod777) mod777))) val783)) r774) new-w789 s776 mod777)))))) tmp780) ((lambda (_795) (syntax-violation #f "bad local syntax definition" (source-wrap598 e773 w775 s776 mod777))) tmp779))) ($sc-dispatch tmp779 (quote (any #(each (any any)) any . each-any))))) e773))) (chi-lambda-clause610 (lambda (e796 docstring797 c798 r799 w800 mod801 k802) ((lambda (tmp803) ((lambda (tmp804) (if (if tmp804 (apply (lambda (args805 doc806 e1807 e2808) (and (string? (syntax->datum doc806)) (not docstring797))) tmp804) #f) (apply (lambda (args809 doc810 e1811 e2812) (chi-lambda-clause610 e796 doc810 (cons args809 (cons e1811 e2812)) r799 w800 mod801 k802)) tmp804) ((lambda (tmp814) (if tmp814 (apply (lambda (id815 e1816 e2817) (let ((ids818 id815)) (if (not (valid-bound-ids?594 ids818)) (syntax-violation (quote lambda) "invalid parameter list" e796) (let ((labels820 (gen-labels575 ids818)) (new-vars821 (map gen-var617 ids818))) (k802 (map syntax->datum ids818) new-vars821 docstring797 (chi-body609 (cons e1816 e2817) e796 (extend-var-env564 labels820 new-vars821 r799) (make-binding-wrap586 ids818 labels820 w800) mod801)))))) tmp814) ((lambda (tmp823) (if tmp823 (apply (lambda (ids824 e1825 e2826) (let ((old-ids827 (lambda-var-list618 ids824))) (if (not (valid-bound-ids?594 old-ids827)) (syntax-violation (quote lambda) "invalid parameter list" e796) (let ((labels828 (gen-labels575 old-ids827)) (new-vars829 (map gen-var617 old-ids827))) (k802 (letrec ((f830 (lambda (ls1831 ls2832) (if (null? ls1831) (syntax->datum ls2832) (f830 (cdr ls1831) (cons (syntax->datum (car ls1831)) ls2832)))))) (f830 (cdr old-ids827) (car old-ids827))) (letrec ((f833 (lambda (ls1834 ls2835) (if (null? ls1834) ls2835 (f833 (cdr ls1834) (cons (car ls1834) ls2835)))))) (f833 (cdr new-vars829) (car new-vars829))) docstring797 (chi-body609 (cons e1825 e2826) e796 (extend-var-env564 labels828 new-vars829 r799) (make-binding-wrap586 old-ids827 labels828 w800) mod801)))))) tmp823) ((lambda (_837) (syntax-violation (quote lambda) "bad lambda" e796)) tmp803))) ($sc-dispatch tmp803 (quote (any any . each-any)))))) ($sc-dispatch tmp803 (quote (each-any any . each-any)))))) ($sc-dispatch tmp803 (quote (any any any . each-any))))) c798))) (chi-body609 (lambda (body838 outer-form839 r840 w841 mod842) (let ((r843 (cons (quote ("placeholder" placeholder)) r840))) (let ((ribcage844 (make-ribcage576 (quote ()) (quote ()) (quote ())))) (let ((w845 (make-wrap571 (wrap-marks572 w841) (cons ribcage844 (wrap-subst573 w841))))) (letrec ((parse846 (lambda (body847 ids848 labels849 vars850 vals851 bindings852) (if (null? body847) (syntax-violation #f "no expressions in body" outer-form839) (let ((e854 (cdar body847)) (er855 (caar body847))) (call-with-values (lambda () (syntax-type603 e854 er855 (quote (())) #f ribcage844 mod842)) (lambda (type856 value857 e858 w859 s860 mod861) (let ((t862 type856)) (if (memv t862 (quote (define-form))) (let ((id863 (wrap597 value857 w859 mod861)) (label864 (gen-label574))) (let ((var865 (gen-var617 id863))) (begin (extend-ribcage!585 ribcage844 id863 label864) (parse846 (cdr body847) (cons id863 ids848) (cons label864 labels849) (cons var865 vars850) (cons (cons er855 (wrap597 e858 w859 mod861)) vals851) (cons (cons (quote lexical) var865) bindings852))))) (if (memv t862 (quote (define-syntax-form))) (let ((id866 (wrap597 value857 w859 mod861)) (label867 (gen-label574))) (begin (extend-ribcage!585 ribcage844 id866 label867) (parse846 (cdr body847) (cons id866 ids848) (cons label867 labels849) vars850 vals851 (cons (cons (quote macro) (cons er855 (wrap597 e858 w859 mod861))) bindings852)))) (if (memv t862 (quote (begin-form))) ((lambda (tmp868) ((lambda (tmp869) (if tmp869 (apply (lambda (_870 e1871) (parse846 (letrec ((f872 (lambda (forms873) (if (null? forms873) (cdr body847) (cons (cons er855 (wrap597 (car forms873) w859 mod861)) (f872 (cdr forms873))))))) (f872 e1871)) ids848 labels849 vars850 vals851 bindings852)) tmp869) (syntax-violation #f "source expression failed to match any pattern" tmp868))) ($sc-dispatch tmp868 (quote (any . each-any))))) e858) (if (memv t862 (quote (local-syntax-form))) (chi-local-syntax611 value857 e858 er855 w859 s860 mod861 (lambda (forms875 er876 w877 s878 mod879) (parse846 (letrec ((f880 (lambda (forms881) (if (null? forms881) (cdr body847) (cons (cons er876 (wrap597 (car forms881) w877 mod879)) (f880 (cdr forms881))))))) (f880 forms875)) ids848 labels849 vars850 vals851 bindings852))) (if (null? ids848) (build-sequence548 #f (map (lambda (x882) (chi605 (cdr x882) (car x882) (quote (())) mod861)) (cons (cons er855 (source-wrap598 e858 w859 s860 mod861)) (cdr body847)))) (begin (if (not (valid-bound-ids?594 ids848)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form839)) (letrec ((loop883 (lambda (bs884 er-cache885 r-cache886) (if (not (null? bs884)) (let ((b887 (car bs884))) (if (eq? (car b887) (quote macro)) (let ((er888 (cadr b887))) (let ((r-cache889 (if (eq? er888 er-cache885) r-cache886 (macros-only-env565 er888)))) (begin (set-cdr! b887 (eval-local-transformer612 (chi605 (cddr b887) r-cache889 (quote (())) mod861) mod861)) (loop883 (cdr bs884) er888 r-cache889)))) (loop883 (cdr bs884) er-cache885 r-cache886))))))) (loop883 bindings852 #f #f)) (set-cdr! r843 (extend-env563 labels849 bindings852 (cdr r843))) (build-letrec551 #f (map syntax->datum ids848) vars850 (map (lambda (x890) (chi605 (cdr x890) (car x890) (quote (())) mod861)) vals851) (build-sequence548 #f (map (lambda (x891) (chi605 (cdr x891) (car x891) (quote (())) mod861)) (cons (cons er855 (source-wrap598 e858 w859 s860 mod861)) (cdr body847))))))))))))))))))) (parse846 (map (lambda (x853) (cons r843 (wrap597 x853 w845 mod842))) body838) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro608 (lambda (p892 e893 r894 w895 rib896 mod897) (letrec ((rebuild-macro-output898 (lambda (x899 m900) (cond ((pair? x899) (cons (rebuild-macro-output898 (car x899) m900) (rebuild-macro-output898 (cdr x899) m900))) ((syntax-object?553 x899) (let ((w901 (syntax-object-wrap555 x899))) (let ((ms902 (wrap-marks572 w901)) (s903 (wrap-subst573 w901))) (if (and (pair? ms902) (eq? (car ms902) #f)) (make-syntax-object552 (syntax-object-expression554 x899) (make-wrap571 (cdr ms902) (if rib896 (cons rib896 (cdr s903)) (cdr s903))) (syntax-object-module556 x899)) (make-syntax-object552 (syntax-object-expression554 x899) (make-wrap571 (cons m900 ms902) (if rib896 (cons rib896 (cons (quote shift) s903)) (cons (quote shift) s903))) (let ((pmod904 (procedure-module p892))) (if pmod904 (cons (quote hygiene) (module-name pmod904)) (quote (hygiene guile))))))))) ((vector? x899) (let ((n905 (vector-length x899))) (let ((v906 (make-vector n905))) (letrec ((doloop907 (lambda (i908) (if (fx=531 i908 n905) v906 (begin (vector-set! v906 i908 (rebuild-macro-output898 (vector-ref x899 i908) m900)) (doloop907 (fx+529 i908 1))))))) (doloop907 0))))) ((symbol? x899) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap598 e893 w895 s mod897) x899)) (else x899))))) (rebuild-macro-output898 (p892 (wrap597 e893 (anti-mark584 w895) mod897)) (string #\m))))) (chi-application607 (lambda (x909 e910 r911 w912 s913 mod914) ((lambda (tmp915) ((lambda (tmp916) (if tmp916 (apply (lambda (e0917 e1918) (build-application537 s913 x909 (map (lambda (e919) (chi605 e919 r911 w912 mod914)) e1918))) tmp916) (syntax-violation #f "source expression failed to match any pattern" tmp915))) ($sc-dispatch tmp915 (quote (any . each-any))))) e910))) (chi-expr606 (lambda (type921 value922 e923 r924 w925 s926 mod927) (let ((t928 type921)) (if (memv t928 (quote (lexical))) (build-lexical-reference539 (quote value) s926 e923 value922) (if (memv t928 (quote (core external-macro))) (value922 e923 r924 w925 s926 mod927) (if (memv t928 (quote (module-ref))) (call-with-values (lambda () (value922 e923)) (lambda (id929 mod930) (build-global-reference542 s926 id929 mod930))) (if (memv t928 (quote (lexical-call))) (chi-application607 (build-lexical-reference539 (quote fun) (source-annotation560 (car e923)) (car e923) value922) e923 r924 w925 s926 mod927) (if (memv t928 (quote (global-call))) (chi-application607 (build-global-reference542 (source-annotation560 (car e923)) value922 (if (syntax-object?553 (car e923)) (syntax-object-module556 (car e923)) mod927)) e923 r924 w925 s926 mod927) (if (memv t928 (quote (constant))) (build-data547 s926 (strip616 (source-wrap598 e923 w925 s926 mod927) (quote (())))) (if (memv t928 (quote (global))) (build-global-reference542 s926 value922 mod927) (if (memv t928 (quote (call))) (chi-application607 (chi605 (car e923) r924 w925 mod927) e923 r924 w925 s926 mod927) (if (memv t928 (quote (begin-form))) ((lambda (tmp931) ((lambda (tmp932) (if tmp932 (apply (lambda (_933 e1934 e2935) (chi-sequence599 (cons e1934 e2935) r924 w925 s926 mod927)) tmp932) (syntax-violation #f "source expression failed to match any pattern" tmp931))) ($sc-dispatch tmp931 (quote (any any . each-any))))) e923) (if (memv t928 (quote (local-syntax-form))) (chi-local-syntax611 value922 e923 r924 w925 s926 mod927 chi-sequence599) (if (memv t928 (quote (eval-when-form))) ((lambda (tmp937) ((lambda (tmp938) (if tmp938 (apply (lambda (_939 x940 e1941 e2942) (let ((when-list943 (chi-when-list602 e923 x940 w925))) (if (memq (quote eval) when-list943) (chi-sequence599 (cons e1941 e2942) r924 w925 s926 mod927) (chi-void613)))) tmp938) (syntax-violation #f "source expression failed to match any pattern" tmp937))) ($sc-dispatch tmp937 (quote (any each-any any . each-any))))) e923) (if (memv t928 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e923 (wrap597 value922 w925 mod927)) (if (memv t928 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap598 e923 w925 s926 mod927)) (if (memv t928 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap598 e923 w925 s926 mod927)) (syntax-violation #f "unexpected syntax" (source-wrap598 e923 w925 s926 mod927))))))))))))))))))) (chi605 (lambda (e946 r947 w948 mod949) (call-with-values (lambda () (syntax-type603 e946 r947 w948 #f #f mod949)) (lambda (type950 value951 e952 w953 s954 mod955) (chi-expr606 type950 value951 e952 r947 w953 s954 mod955))))) (chi-top604 (lambda (e956 r957 w958 m959 esew960 mod961) (call-with-values (lambda () (syntax-type603 e956 r957 w958 #f #f mod961)) (lambda (type969 value970 e971 w972 s973 mod974) (let ((t975 type969)) (if (memv t975 (quote (begin-form))) ((lambda (tmp976) ((lambda (tmp977) (if tmp977 (apply (lambda (_978) (chi-void613)) tmp977) ((lambda (tmp979) (if tmp979 (apply (lambda (_980 e1981 e2982) (chi-top-sequence600 (cons e1981 e2982) r957 w972 s973 m959 esew960 mod974)) tmp979) (syntax-violation #f "source expression failed to match any pattern" tmp976))) ($sc-dispatch tmp976 (quote (any any . each-any)))))) ($sc-dispatch tmp976 (quote (any))))) e971) (if (memv t975 (quote (local-syntax-form))) (chi-local-syntax611 value970 e971 r957 w972 s973 mod974 (lambda (body984 r985 w986 s987 mod988) (chi-top-sequence600 body984 r985 w986 s987 m959 esew960 mod988))) (if (memv t975 (quote (eval-when-form))) ((lambda (tmp989) ((lambda (tmp990) (if tmp990 (apply (lambda (_991 x992 e1993 e2994) (let ((when-list995 (chi-when-list602 e971 x992 w972)) (body996 (cons e1993 e2994))) (cond ((eq? m959 (quote e)) (if (memq (quote eval) when-list995) (chi-top-sequence600 body996 r957 w972 s973 (quote e) (quote (eval)) mod974) (chi-void613))) ((memq (quote load) when-list995) (if (or (memq (quote compile) when-list995) (and (eq? m959 (quote c&e)) (memq (quote eval) when-list995))) (chi-top-sequence600 body996 r957 w972 s973 (quote c&e) (quote (compile load)) mod974) (if (memq m959 (quote (c c&e))) (chi-top-sequence600 body996 r957 w972 s973 (quote c) (quote (load)) mod974) (chi-void613)))) ((or (memq (quote compile) when-list995) (and (eq? m959 (quote c&e)) (memq (quote eval) when-list995))) (top-level-eval-hook533 (chi-top-sequence600 body996 r957 w972 s973 (quote e) (quote (eval)) mod974) mod974) (chi-void613)) (else (chi-void613))))) tmp990) (syntax-violation #f "source expression failed to match any pattern" tmp989))) ($sc-dispatch tmp989 (quote (any each-any any . each-any))))) e971) (if (memv t975 (quote (define-syntax-form))) (let ((n999 (id-var-name591 value970 w972)) (r1000 (macros-only-env565 r957))) (let ((t1001 m959)) (if (memv t1001 (quote (c))) (if (memq (quote compile) esew960) (let ((e1002 (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)))) (begin (top-level-eval-hook533 e1002 mod974) (if (memq (quote load) esew960) e1002 (chi-void613)))) (if (memq (quote load) esew960) (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)) (chi-void613))) (if (memv t1001 (quote (c&e))) (let ((e1003 (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)))) (begin (top-level-eval-hook533 e1003 mod974) e1003)) (begin (if (memq (quote eval) esew960) (top-level-eval-hook533 (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)) mod974)) (chi-void613)))))) (if (memv t975 (quote (define-form))) (let ((n1004 (id-var-name591 value970 w972))) (let ((type1005 (binding-type561 (lookup566 n1004 r957 mod974)))) (let ((t1006 type1005)) (if (memv t1006 (quote (global core macro module-ref))) (let ((x1007 (build-global-definition544 s973 n1004 (chi605 e971 r957 w972 mod974)))) (begin (if (eq? m959 (quote c&e)) (top-level-eval-hook533 x1007 mod974)) x1007)) (if (memv t1006 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e971 (wrap597 value970 w972 mod974)) (syntax-violation #f "cannot define keyword at top level" e971 (wrap597 value970 w972 mod974))))))) (let ((x1008 (chi-expr606 type969 value970 e971 r957 w972 s973 mod974))) (begin (if (eq? m959 (quote c&e)) (top-level-eval-hook533 x1008 mod974)) x1008)))))))))))) (syntax-type603 (lambda (e1009 r1010 w1011 s1012 rib1013 mod1014) (cond ((symbol? e1009) (let ((n1015 (id-var-name591 e1009 w1011))) (let ((b1016 (lookup566 n1015 r1010 mod1014))) (let ((type1017 (binding-type561 b1016))) (let ((t1018 type1017)) (if (memv t1018 (quote (lexical))) (values type1017 (binding-value562 b1016) e1009 w1011 s1012 mod1014) (if (memv t1018 (quote (global))) (values type1017 n1015 e1009 w1011 s1012 mod1014) (if (memv t1018 (quote (macro))) (syntax-type603 (chi-macro608 (binding-value562 b1016) e1009 r1010 w1011 rib1013 mod1014) r1010 (quote (())) s1012 rib1013 mod1014) (values type1017 (binding-value562 b1016) e1009 w1011 s1012 mod1014))))))))) ((pair? e1009) (let ((first1019 (car e1009))) (if (id?569 first1019) (let ((n1020 (id-var-name591 first1019 w1011))) (let ((b1021 (lookup566 n1020 r1010 (or (and (syntax-object?553 first1019) (syntax-object-module556 first1019)) mod1014)))) (let ((type1022 (binding-type561 b1021))) (let ((t1023 type1022)) (if (memv t1023 (quote (lexical))) (values (quote lexical-call) (binding-value562 b1021) e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (global))) (values (quote global-call) n1020 e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (macro))) (syntax-type603 (chi-macro608 (binding-value562 b1021) e1009 r1010 w1011 rib1013 mod1014) r1010 (quote (())) s1012 rib1013 mod1014) (if (memv t1023 (quote (core external-macro module-ref))) (values type1022 (binding-value562 b1021) e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value562 b1021) e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (begin))) (values (quote begin-form) #f e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (eval-when))) (values (quote eval-when-form) #f e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (define))) ((lambda (tmp1024) ((lambda (tmp1025) (if (if tmp1025 (apply (lambda (_1026 name1027 val1028) (id?569 name1027)) tmp1025) #f) (apply (lambda (_1029 name1030 val1031) (values (quote define-form) name1030 val1031 w1011 s1012 mod1014)) tmp1025) ((lambda (tmp1032) (if (if tmp1032 (apply (lambda (_1033 name1034 args1035 e11036 e21037) (and (id?569 name1034) (valid-bound-ids?594 (lambda-var-list618 args1035)))) tmp1032) #f) (apply (lambda (_1038 name1039 args1040 e11041 e21042) (values (quote define-form) (wrap597 name1039 w1011 mod1014) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap597 (cons args1040 (cons e11041 e21042)) w1011 mod1014)) (quote (())) s1012 mod1014)) tmp1032) ((lambda (tmp1044) (if (if tmp1044 (apply (lambda (_1045 name1046) (id?569 name1046)) tmp1044) #f) (apply (lambda (_1047 name1048) (values (quote define-form) (wrap597 name1048 w1011 mod1014) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1012 mod1014)) tmp1044) (syntax-violation #f "source expression failed to match any pattern" tmp1024))) ($sc-dispatch tmp1024 (quote (any any)))))) ($sc-dispatch tmp1024 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1024 (quote (any any any))))) e1009) (if (memv t1023 (quote (define-syntax))) ((lambda (tmp1049) ((lambda (tmp1050) (if (if tmp1050 (apply (lambda (_1051 name1052 val1053) (id?569 name1052)) tmp1050) #f) (apply (lambda (_1054 name1055 val1056) (values (quote define-syntax-form) name1055 val1056 w1011 s1012 mod1014)) tmp1050) (syntax-violation #f "source expression failed to match any pattern" tmp1049))) ($sc-dispatch tmp1049 (quote (any any any))))) e1009) (values (quote call) #f e1009 w1011 s1012 mod1014)))))))))))))) (values (quote call) #f e1009 w1011 s1012 mod1014)))) ((syntax-object?553 e1009) (syntax-type603 (syntax-object-expression554 e1009) r1010 (join-wraps588 w1011 (syntax-object-wrap555 e1009)) #f rib1013 (or (syntax-object-module556 e1009) mod1014))) ((annotation? e1009) (syntax-type603 (annotation-expression e1009) r1010 w1011 (annotation-source e1009) rib1013 mod1014)) ((self-evaluating? e1009) (values (quote constant) #f e1009 w1011 s1012 mod1014)) (else (values (quote other) #f e1009 w1011 s1012 mod1014))))) (chi-when-list602 (lambda (e1057 when-list1058 w1059) (letrec ((f1060 (lambda (when-list1061 situations1062) (if (null? when-list1061) situations1062 (f1060 (cdr when-list1061) (cons (let ((x1063 (car when-list1061))) (cond ((free-id=?592 x1063 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?592 x1063 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?592 x1063 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1057 (wrap597 x1063 w1059 #f))))) situations1062)))))) (f1060 when-list1058 (quote ()))))) (chi-install-global601 (lambda (name1064 e1065) (build-global-definition544 #f name1064 (if (let ((v1066 (module-variable (current-module) name1064))) (and v1066 (variable-bound? v1066) (macro? (variable-ref v1066)) (not (eq? (macro-type (variable-ref v1066)) (quote syncase-macro))))) (build-application537 #f (build-primref546 #f (quote make-extended-syncase-macro)) (list (build-application537 #f (build-primref546 #f (quote module-ref)) (list (build-application537 #f (quote current-module) (quote ())) (build-data547 #f name1064))) (build-data547 #f (quote macro)) e1065)) (build-application537 #f (build-primref546 #f (quote make-syncase-macro)) (list (build-data547 #f (quote macro)) e1065)))))) (chi-top-sequence600 (lambda (body1067 r1068 w1069 s1070 m1071 esew1072 mod1073) (build-sequence548 s1070 (letrec ((dobody1074 (lambda (body1075 r1076 w1077 m1078 esew1079 mod1080) (if (null? body1075) (quote ()) (let ((first1081 (chi-top604 (car body1075) r1076 w1077 m1078 esew1079 mod1080))) (cons first1081 (dobody1074 (cdr body1075) r1076 w1077 m1078 esew1079 mod1080))))))) (dobody1074 body1067 r1068 w1069 m1071 esew1072 mod1073))))) (chi-sequence599 (lambda (body1082 r1083 w1084 s1085 mod1086) (build-sequence548 s1085 (letrec ((dobody1087 (lambda (body1088 r1089 w1090 mod1091) (if (null? body1088) (quote ()) (let ((first1092 (chi605 (car body1088) r1089 w1090 mod1091))) (cons first1092 (dobody1087 (cdr body1088) r1089 w1090 mod1091))))))) (dobody1087 body1082 r1083 w1084 mod1086))))) (source-wrap598 (lambda (x1093 w1094 s1095 defmod1096) (wrap597 (if s1095 (make-annotation x1093 s1095 #f) x1093) w1094 defmod1096))) (wrap597 (lambda (x1097 w1098 defmod1099) (cond ((and (null? (wrap-marks572 w1098)) (null? (wrap-subst573 w1098))) x1097) ((syntax-object?553 x1097) (make-syntax-object552 (syntax-object-expression554 x1097) (join-wraps588 w1098 (syntax-object-wrap555 x1097)) (syntax-object-module556 x1097))) ((null? x1097) x1097) (else (make-syntax-object552 x1097 w1098 defmod1099))))) (bound-id-member?596 (lambda (x1100 list1101) (and (not (null? list1101)) (or (bound-id=?593 x1100 (car list1101)) (bound-id-member?596 x1100 (cdr list1101)))))) (distinct-bound-ids?595 (lambda (ids1102) (letrec ((distinct?1103 (lambda (ids1104) (or (null? ids1104) (and (not (bound-id-member?596 (car ids1104) (cdr ids1104))) (distinct?1103 (cdr ids1104))))))) (distinct?1103 ids1102)))) (valid-bound-ids?594 (lambda (ids1105) (and (letrec ((all-ids?1106 (lambda (ids1107) (or (null? ids1107) (and (id?569 (car ids1107)) (all-ids?1106 (cdr ids1107))))))) (all-ids?1106 ids1105)) (distinct-bound-ids?595 ids1105)))) (bound-id=?593 (lambda (i1108 j1109) (if (and (syntax-object?553 i1108) (syntax-object?553 j1109)) (and (eq? (let ((e1110 (syntax-object-expression554 i1108))) (if (annotation? e1110) (annotation-expression e1110) e1110)) (let ((e1111 (syntax-object-expression554 j1109))) (if (annotation? e1111) (annotation-expression e1111) e1111))) (same-marks?590 (wrap-marks572 (syntax-object-wrap555 i1108)) (wrap-marks572 (syntax-object-wrap555 j1109)))) (eq? (let ((e1112 i1108)) (if (annotation? e1112) (annotation-expression e1112) e1112)) (let ((e1113 j1109)) (if (annotation? e1113) (annotation-expression e1113) e1113)))))) (free-id=?592 (lambda (i1114 j1115) (and (eq? (let ((x1116 i1114)) (let ((e1117 (if (syntax-object?553 x1116) (syntax-object-expression554 x1116) x1116))) (if (annotation? e1117) (annotation-expression e1117) e1117))) (let ((x1118 j1115)) (let ((e1119 (if (syntax-object?553 x1118) (syntax-object-expression554 x1118) x1118))) (if (annotation? e1119) (annotation-expression e1119) e1119)))) (eq? (id-var-name591 i1114 (quote (()))) (id-var-name591 j1115 (quote (()))))))) (id-var-name591 (lambda (id1120 w1121) (letrec ((search-vector-rib1124 (lambda (sym1130 subst1131 marks1132 symnames1133 ribcage1134) (let ((n1135 (vector-length symnames1133))) (letrec ((f1136 (lambda (i1137) (cond ((fx=531 i1137 n1135) (search1122 sym1130 (cdr subst1131) marks1132)) ((and (eq? (vector-ref symnames1133 i1137) sym1130) (same-marks?590 marks1132 (vector-ref (ribcage-marks579 ribcage1134) i1137))) (values (vector-ref (ribcage-labels580 ribcage1134) i1137) marks1132)) (else (f1136 (fx+529 i1137 1))))))) (f1136 0))))) (search-list-rib1123 (lambda (sym1138 subst1139 marks1140 symnames1141 ribcage1142) (letrec ((f1143 (lambda (symnames1144 i1145) (cond ((null? symnames1144) (search1122 sym1138 (cdr subst1139) marks1140)) ((and (eq? (car symnames1144) sym1138) (same-marks?590 marks1140 (list-ref (ribcage-marks579 ribcage1142) i1145))) (values (list-ref (ribcage-labels580 ribcage1142) i1145) marks1140)) (else (f1143 (cdr symnames1144) (fx+529 i1145 1))))))) (f1143 symnames1141 0)))) (search1122 (lambda (sym1146 subst1147 marks1148) (if (null? subst1147) (values #f marks1148) (let ((fst1149 (car subst1147))) (if (eq? fst1149 (quote shift)) (search1122 sym1146 (cdr subst1147) (cdr marks1148)) (let ((symnames1150 (ribcage-symnames578 fst1149))) (if (vector? symnames1150) (search-vector-rib1124 sym1146 subst1147 marks1148 symnames1150 fst1149) (search-list-rib1123 sym1146 subst1147 marks1148 symnames1150 fst1149))))))))) (cond ((symbol? id1120) (or (call-with-values (lambda () (search1122 id1120 (wrap-subst573 w1121) (wrap-marks572 w1121))) (lambda (x1152 . ignore1151) x1152)) id1120)) ((syntax-object?553 id1120) (let ((id1153 (let ((e1155 (syntax-object-expression554 id1120))) (if (annotation? e1155) (annotation-expression e1155) e1155))) (w11154 (syntax-object-wrap555 id1120))) (let ((marks1156 (join-marks589 (wrap-marks572 w1121) (wrap-marks572 w11154)))) (call-with-values (lambda () (search1122 id1153 (wrap-subst573 w1121) marks1156)) (lambda (new-id1157 marks1158) (or new-id1157 (call-with-values (lambda () (search1122 id1153 (wrap-subst573 w11154) marks1158)) (lambda (x1160 . ignore1159) x1160)) id1153)))))) ((annotation? id1120) (let ((id1161 (let ((e1162 id1120)) (if (annotation? e1162) (annotation-expression e1162) e1162)))) (or (call-with-values (lambda () (search1122 id1161 (wrap-subst573 w1121) (wrap-marks572 w1121))) (lambda (x1164 . ignore1163) x1164)) id1161))) (else (syntax-violation (quote id-var-name) "invalid id" id1120)))))) (same-marks?590 (lambda (x1165 y1166) (or (eq? x1165 y1166) (and (not (null? x1165)) (not (null? y1166)) (eq? (car x1165) (car y1166)) (same-marks?590 (cdr x1165) (cdr y1166)))))) (join-marks589 (lambda (m11167 m21168) (smart-append587 m11167 m21168))) (join-wraps588 (lambda (w11169 w21170) (let ((m11171 (wrap-marks572 w11169)) (s11172 (wrap-subst573 w11169))) (if (null? m11171) (if (null? s11172) w21170 (make-wrap571 (wrap-marks572 w21170) (smart-append587 s11172 (wrap-subst573 w21170)))) (make-wrap571 (smart-append587 m11171 (wrap-marks572 w21170)) (smart-append587 s11172 (wrap-subst573 w21170))))))) (smart-append587 (lambda (m11173 m21174) (if (null? m21174) m11173 (append m11173 m21174)))) (make-binding-wrap586 (lambda (ids1175 labels1176 w1177) (if (null? ids1175) w1177 (make-wrap571 (wrap-marks572 w1177) (cons (let ((labelvec1178 (list->vector labels1176))) (let ((n1179 (vector-length labelvec1178))) (let ((symnamevec1180 (make-vector n1179)) (marksvec1181 (make-vector n1179))) (begin (letrec ((f1182 (lambda (ids1183 i1184) (if (not (null? ids1183)) (call-with-values (lambda () (id-sym-name&marks570 (car ids1183) w1177)) (lambda (symname1185 marks1186) (begin (vector-set! symnamevec1180 i1184 symname1185) (vector-set! marksvec1181 i1184 marks1186) (f1182 (cdr ids1183) (fx+529 i1184 1))))))))) (f1182 ids1175 0)) (make-ribcage576 symnamevec1180 marksvec1181 labelvec1178))))) (wrap-subst573 w1177)))))) (extend-ribcage!585 (lambda (ribcage1187 id1188 label1189) (begin (set-ribcage-symnames!581 ribcage1187 (cons (let ((e1190 (syntax-object-expression554 id1188))) (if (annotation? e1190) (annotation-expression e1190) e1190)) (ribcage-symnames578 ribcage1187))) (set-ribcage-marks!582 ribcage1187 (cons (wrap-marks572 (syntax-object-wrap555 id1188)) (ribcage-marks579 ribcage1187))) (set-ribcage-labels!583 ribcage1187 (cons label1189 (ribcage-labels580 ribcage1187)))))) (anti-mark584 (lambda (w1191) (make-wrap571 (cons #f (wrap-marks572 w1191)) (cons (quote shift) (wrap-subst573 w1191))))) (set-ribcage-labels!583 (lambda (x1192 update1193) (vector-set! x1192 3 update1193))) (set-ribcage-marks!582 (lambda (x1194 update1195) (vector-set! x1194 2 update1195))) (set-ribcage-symnames!581 (lambda (x1196 update1197) (vector-set! x1196 1 update1197))) (ribcage-labels580 (lambda (x1198) (vector-ref x1198 3))) (ribcage-marks579 (lambda (x1199) (vector-ref x1199 2))) (ribcage-symnames578 (lambda (x1200) (vector-ref x1200 1))) (ribcage?577 (lambda (x1201) (and (vector? x1201) (= (vector-length x1201) 4) (eq? (vector-ref x1201 0) (quote ribcage))))) (make-ribcage576 (lambda (symnames1202 marks1203 labels1204) (vector (quote ribcage) symnames1202 marks1203 labels1204))) (gen-labels575 (lambda (ls1205) (if (null? ls1205) (quote ()) (cons (gen-label574) (gen-labels575 (cdr ls1205)))))) (gen-label574 (lambda () (string #\i))) (wrap-subst573 cdr) (wrap-marks572 car) (make-wrap571 cons) (id-sym-name&marks570 (lambda (x1206 w1207) (if (syntax-object?553 x1206) (values (let ((e1208 (syntax-object-expression554 x1206))) (if (annotation? e1208) (annotation-expression e1208) e1208)) (join-marks589 (wrap-marks572 w1207) (wrap-marks572 (syntax-object-wrap555 x1206)))) (values (let ((e1209 x1206)) (if (annotation? e1209) (annotation-expression e1209) e1209)) (wrap-marks572 w1207))))) (id?569 (lambda (x1210) (cond ((symbol? x1210) #t) ((syntax-object?553 x1210) (symbol? (let ((e1211 (syntax-object-expression554 x1210))) (if (annotation? e1211) (annotation-expression e1211) e1211)))) ((annotation? x1210) (symbol? (annotation-expression x1210))) (else #f)))) (nonsymbol-id?568 (lambda (x1212) (and (syntax-object?553 x1212) (symbol? (let ((e1213 (syntax-object-expression554 x1212))) (if (annotation? e1213) (annotation-expression e1213) e1213)))))) (global-extend567 (lambda (type1214 sym1215 val1216) (put-global-definition-hook535 sym1215 type1214 val1216))) (lookup566 (lambda (x1217 r1218 mod1219) (cond ((assq x1217 r1218) => cdr) ((symbol? x1217) (or (get-global-definition-hook536 x1217 mod1219) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env565 (lambda (r1220) (if (null? r1220) (quote ()) (let ((a1221 (car r1220))) (if (eq? (cadr a1221) (quote macro)) (cons a1221 (macros-only-env565 (cdr r1220))) (macros-only-env565 (cdr r1220))))))) (extend-var-env564 (lambda (labels1222 vars1223 r1224) (if (null? labels1222) r1224 (extend-var-env564 (cdr labels1222) (cdr vars1223) (cons (cons (car labels1222) (cons (quote lexical) (car vars1223))) r1224))))) (extend-env563 (lambda (labels1225 bindings1226 r1227) (if (null? labels1225) r1227 (extend-env563 (cdr labels1225) (cdr bindings1226) (cons (cons (car labels1225) (car bindings1226)) r1227))))) (binding-value562 cdr) (binding-type561 car) (source-annotation560 (lambda (x1228) (cond ((annotation? x1228) (annotation-source x1228)) ((syntax-object?553 x1228) (source-annotation560 (syntax-object-expression554 x1228))) (else #f)))) (set-syntax-object-module!559 (lambda (x1229 update1230) (vector-set! x1229 3 update1230))) (set-syntax-object-wrap!558 (lambda (x1231 update1232) (vector-set! x1231 2 update1232))) (set-syntax-object-expression!557 (lambda (x1233 update1234) (vector-set! x1233 1 update1234))) (syntax-object-module556 (lambda (x1235) (vector-ref x1235 3))) (syntax-object-wrap555 (lambda (x1236) (vector-ref x1236 2))) (syntax-object-expression554 (lambda (x1237) (vector-ref x1237 1))) (syntax-object?553 (lambda (x1238) (and (vector? x1238) (= (vector-length x1238) 4) (eq? (vector-ref x1238 0) (quote syntax-object))))) (make-syntax-object552 (lambda (expression1239 wrap1240 module1241) (vector (quote syntax-object) expression1239 wrap1240 module1241))) (build-letrec551 (lambda (src1242 ids1243 vars1244 val-exps1245 body-exp1246) (if (null? vars1244) body-exp1246 (let ((t1247 (fluid-ref *mode*528))) (if (memv t1247 (quote (c))) ((@ (language tree-il) make-letrec) src1242 ids1243 vars1244 val-exps1245 body-exp1246) (list (quote letrec) (map list vars1244 val-exps1245) body-exp1246)))))) (build-named-let550 (lambda (src1248 ids1249 vars1250 val-exps1251 body-exp1252) (let ((f1253 (car vars1250)) (f-name1254 (car ids1249)) (vars1255 (cdr vars1250)) (ids1256 (cdr ids1249))) (let ((t1257 (fluid-ref *mode*528))) (if (memv t1257 (quote (c))) ((@ (language tree-il) make-letrec) src1248 (list f-name1254) (list f1253) (list (build-lambda545 src1248 ids1256 vars1255 #f body-exp1252)) (build-application537 src1248 (build-lexical-reference539 (quote fun) src1248 f-name1254 f1253) val-exps1251)) (list (quote let) f1253 (map list vars1255 val-exps1251) body-exp1252)))))) (build-let549 (lambda (src1258 ids1259 vars1260 val-exps1261 body-exp1262) (if (null? vars1260) body-exp1262 (let ((t1263 (fluid-ref *mode*528))) (if (memv t1263 (quote (c))) ((@ (language tree-il) make-let) src1258 ids1259 vars1260 val-exps1261 body-exp1262) (list (quote let) (map list vars1260 val-exps1261) body-exp1262)))))) (build-sequence548 (lambda (src1264 exps1265) (if (null? (cdr exps1265)) (car exps1265) (let ((t1266 (fluid-ref *mode*528))) (if (memv t1266 (quote (c))) ((@ (language tree-il) make-sequence) src1264 exps1265) (cons (quote begin) exps1265)))))) (build-data547 (lambda (src1267 exp1268) (let ((t1269 (fluid-ref *mode*528))) (if (memv t1269 (quote (c))) ((@ (language tree-il) make-const) src1267 exp1268) (if (and (self-evaluating? exp1268) (not (vector? exp1268))) exp1268 (list (quote quote) exp1268)))))) (build-primref546 (lambda (src1270 name1271) (let ((t1272 (fluid-ref *mode*528))) (if (memv t1272 (quote (c))) ((@ (language tree-il) make-primitive-ref) src1270 name1271) (build-global-reference542 src1270 name1271 (quote (hygiene guile))))))) (build-lambda545 (lambda (src1273 ids1274 vars1275 docstring1276 exp1277) (let ((t1278 (fluid-ref *mode*528))) (if (memv t1278 (quote (c))) ((@ (language tree-il) make-lambda) src1273 ids1274 vars1275 (if docstring1276 (list (cons (quote documentation) docstring1276)) (quote ())) exp1277) (cons (quote lambda) (cons vars1275 (append (if docstring1276 (list docstring1276) (quote ())) (list exp1277)))))))) (build-global-definition544 (lambda (source1279 var1280 exp1281) (let ((t1282 (fluid-ref *mode*528))) (if (memv t1282 (quote (c))) ((@ (language tree-il) make-toplevel-define) source1279 var1280 exp1281) (list (quote define) var1280 exp1281))))) (build-global-assignment543 (lambda (source1283 var1284 exp1285 mod1286) (analyze-variable541 mod1286 var1284 (lambda (mod1287 var1288 public?1289) (let ((t1290 (fluid-ref *mode*528))) (if (memv t1290 (quote (c))) ((@ (language tree-il) make-module-set) source1283 mod1287 var1288 public?1289 exp1285) (list (quote set!) (list (if public?1289 (quote @) (quote @@)) mod1287 var1288) exp1285)))) (lambda (var1291) (let ((t1292 (fluid-ref *mode*528))) (if (memv t1292 (quote (c))) ((@ (language tree-il) make-toplevel-set) source1283 var1291 exp1285) (list (quote set!) var1291 exp1285))))))) (build-global-reference542 (lambda (source1293 var1294 mod1295) (analyze-variable541 mod1295 var1294 (lambda (mod1296 var1297 public?1298) (let ((t1299 (fluid-ref *mode*528))) (if (memv t1299 (quote (c))) ((@ (language tree-il) make-module-ref) source1293 mod1296 var1297 public?1298) (list (if public?1298 (quote @) (quote @@)) mod1296 var1297)))) (lambda (var1300) (let ((t1301 (fluid-ref *mode*528))) (if (memv t1301 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source1293 var1300) var1300)))))) (analyze-variable541 (lambda (mod1302 var1303 modref-cont1304 bare-cont1305) (if (not mod1302) (bare-cont1305 var1303) (let ((kind1306 (car mod1302)) (mod1307 (cdr mod1302))) (let ((t1308 kind1306)) (if (memv t1308 (quote (public))) (modref-cont1304 mod1307 var1303 #t) (if (memv t1308 (quote (private))) (if (not (equal? mod1307 (module-name (current-module)))) (modref-cont1304 mod1307 var1303 #f) (bare-cont1305 var1303)) (if (memv t1308 (quote (bare))) (bare-cont1305 var1303) (if (memv t1308 (quote (hygiene))) (if (and (not (equal? mod1307 (module-name (current-module)))) (module-variable (resolve-module mod1307) var1303)) (modref-cont1304 mod1307 var1303 #f) (bare-cont1305 var1303)) (syntax-violation #f "bad module kind" var1303 mod1307)))))))))) (build-lexical-assignment540 (lambda (source1309 name1310 var1311 exp1312) (let ((t1313 (fluid-ref *mode*528))) (if (memv t1313 (quote (c))) ((@ (language tree-il) make-lexical-set) source1309 name1310 var1311 exp1312) (list (quote set!) var1311 exp1312))))) (build-lexical-reference539 (lambda (type1314 source1315 name1316 var1317) (let ((t1318 (fluid-ref *mode*528))) (if (memv t1318 (quote (c))) ((@ (language tree-il) make-lexical-ref) source1315 name1316 var1317) var1317)))) (build-conditional538 (lambda (source1319 test-exp1320 then-exp1321 else-exp1322) (let ((t1323 (fluid-ref *mode*528))) (if (memv t1323 (quote (c))) ((@ (language tree-il) make-conditional) source1319 test-exp1320 then-exp1321 else-exp1322) (list (quote if) test-exp1320 then-exp1321 else-exp1322))))) (build-application537 (lambda (source1324 fun-exp1325 arg-exps1326) (let ((t1327 (fluid-ref *mode*528))) (if (memv t1327 (quote (c))) ((@ (language tree-il) make-application) source1324 fun-exp1325 arg-exps1326) (cons fun-exp1325 arg-exps1326))))) (get-global-definition-hook536 (lambda (symbol1328 module1329) (begin (if (and (not module1329) (current-module)) (warn "module system is booted, we should have a module" symbol1328)) (let ((v1330 (module-variable (if module1329 (resolve-module (cdr module1329)) (current-module)) symbol1328))) (and v1330 (variable-bound? v1330) (let ((val1331 (variable-ref v1330))) (and (macro? val1331) (syncase-macro-type val1331) (cons (syncase-macro-type val1331) (syncase-macro-binding val1331))))))))) (put-global-definition-hook535 (lambda (symbol1332 type1333 val1334) (let ((existing1335 (let ((v1336 (module-variable (current-module) symbol1332))) (and v1336 (variable-bound? v1336) (let ((val1337 (variable-ref v1336))) (and (macro? val1337) (not (syncase-macro-type val1337)) val1337)))))) (module-define! (current-module) symbol1332 (if existing1335 (make-extended-syncase-macro existing1335 type1333 val1334) (make-syncase-macro type1333 val1334)))))) (local-eval-hook534 (lambda (x1338 mod1339) (primitive-eval (list noexpand527 (let ((t1340 (fluid-ref *mode*528))) (if (memv t1340 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1338) x1338)))))) (top-level-eval-hook533 (lambda (x1341 mod1342) (primitive-eval (list noexpand527 (let ((t1343 (fluid-ref *mode*528))) (if (memv t1343 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1341) x1341)))))) (fx<532 <) (fx=531 =) (fx-530 -) (fx+529 +) (*mode*528 (make-fluid)) (noexpand527 "noexpand")) (begin (global-extend567 (quote local-syntax) (quote letrec-syntax) #t) (global-extend567 (quote local-syntax) (quote let-syntax) #f) (global-extend567 (quote core) (quote fluid-let-syntax) (lambda (e1344 r1345 w1346 s1347 mod1348) ((lambda (tmp1349) ((lambda (tmp1350) (if (if tmp1350 (apply (lambda (_1351 var1352 val1353 e11354 e21355) (valid-bound-ids?594 var1352)) tmp1350) #f) (apply (lambda (_1357 var1358 val1359 e11360 e21361) (let ((names1362 (map (lambda (x1363) (id-var-name591 x1363 w1346)) var1358))) (begin (for-each (lambda (id1365 n1366) (let ((t1367 (binding-type561 (lookup566 n1366 r1345 mod1348)))) (if (memv t1367 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1344 (source-wrap598 id1365 w1346 s1347 mod1348))))) var1358 names1362) (chi-body609 (cons e11360 e21361) (source-wrap598 e1344 w1346 s1347 mod1348) (extend-env563 names1362 (let ((trans-r1370 (macros-only-env565 r1345))) (map (lambda (x1371) (cons (quote macro) (eval-local-transformer612 (chi605 x1371 trans-r1370 w1346 mod1348) mod1348))) val1359)) r1345) w1346 mod1348)))) tmp1350) ((lambda (_1373) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap598 e1344 w1346 s1347 mod1348))) tmp1349))) ($sc-dispatch tmp1349 (quote (any #(each (any any)) any . each-any))))) e1344))) (global-extend567 (quote core) (quote quote) (lambda (e1374 r1375 w1376 s1377 mod1378) ((lambda (tmp1379) ((lambda (tmp1380) (if tmp1380 (apply (lambda (_1381 e1382) (build-data547 s1377 (strip616 e1382 w1376))) tmp1380) ((lambda (_1383) (syntax-violation (quote quote) "bad syntax" (source-wrap598 e1374 w1376 s1377 mod1378))) tmp1379))) ($sc-dispatch tmp1379 (quote (any any))))) e1374))) (global-extend567 (quote core) (quote syntax) (letrec ((regen1391 (lambda (x1392) (let ((t1393 (car x1392))) (if (memv t1393 (quote (ref))) (build-lexical-reference539 (quote value) #f (cadr x1392) (cadr x1392)) (if (memv t1393 (quote (primitive))) (build-primref546 #f (cadr x1392)) (if (memv t1393 (quote (quote))) (build-data547 #f (cadr x1392)) (if (memv t1393 (quote (lambda))) (build-lambda545 #f (cadr x1392) (cadr x1392) #f (regen1391 (caddr x1392))) (if (memv t1393 (quote (map))) (let ((ls1394 (map regen1391 (cdr x1392)))) (build-application537 #f (build-primref546 #f (quote map)) ls1394)) (build-application537 #f (build-primref546 #f (car x1392)) (map regen1391 (cdr x1392))))))))))) (gen-vector1390 (lambda (x1395) (cond ((eq? (car x1395) (quote list)) (cons (quote vector) (cdr x1395))) ((eq? (car x1395) (quote quote)) (list (quote quote) (list->vector (cadr x1395)))) (else (list (quote list->vector) x1395))))) (gen-append1389 (lambda (x1396 y1397) (if (equal? y1397 (quote (quote ()))) x1396 (list (quote append) x1396 y1397)))) (gen-cons1388 (lambda (x1398 y1399) (let ((t1400 (car y1399))) (if (memv t1400 (quote (quote))) (if (eq? (car x1398) (quote quote)) (list (quote quote) (cons (cadr x1398) (cadr y1399))) (if (eq? (cadr y1399) (quote ())) (list (quote list) x1398) (list (quote cons) x1398 y1399))) (if (memv t1400 (quote (list))) (cons (quote list) (cons x1398 (cdr y1399))) (list (quote cons) x1398 y1399)))))) (gen-map1387 (lambda (e1401 map-env1402) (let ((formals1403 (map cdr map-env1402)) (actuals1404 (map (lambda (x1405) (list (quote ref) (car x1405))) map-env1402))) (cond ((eq? (car e1401) (quote ref)) (car actuals1404)) ((and-map (lambda (x1406) (and (eq? (car x1406) (quote ref)) (memq (cadr x1406) formals1403))) (cdr e1401)) (cons (quote map) (cons (list (quote primitive) (car e1401)) (map (let ((r1407 (map cons formals1403 actuals1404))) (lambda (x1408) (cdr (assq (cadr x1408) r1407)))) (cdr e1401))))) (else (cons (quote map) (cons (list (quote lambda) formals1403 e1401) actuals1404))))))) (gen-mappend1386 (lambda (e1409 map-env1410) (list (quote apply) (quote (primitive append)) (gen-map1387 e1409 map-env1410)))) (gen-ref1385 (lambda (src1411 var1412 level1413 maps1414) (if (fx=531 level1413 0) (values var1412 maps1414) (if (null? maps1414) (syntax-violation (quote syntax) "missing ellipsis" src1411) (call-with-values (lambda () (gen-ref1385 src1411 var1412 (fx-530 level1413 1) (cdr maps1414))) (lambda (outer-var1415 outer-maps1416) (let ((b1417 (assq outer-var1415 (car maps1414)))) (if b1417 (values (cdr b1417) maps1414) (let ((inner-var1418 (gen-var617 (quote tmp)))) (values inner-var1418 (cons (cons (cons outer-var1415 inner-var1418) (car maps1414)) outer-maps1416))))))))))) (gen-syntax1384 (lambda (src1419 e1420 r1421 maps1422 ellipsis?1423 mod1424) (if (id?569 e1420) (let ((label1425 (id-var-name591 e1420 (quote (()))))) (let ((b1426 (lookup566 label1425 r1421 mod1424))) (if (eq? (binding-type561 b1426) (quote syntax)) (call-with-values (lambda () (let ((var.lev1427 (binding-value562 b1426))) (gen-ref1385 src1419 (car var.lev1427) (cdr var.lev1427) maps1422))) (lambda (var1428 maps1429) (values (list (quote ref) var1428) maps1429))) (if (ellipsis?1423 e1420) (syntax-violation (quote syntax) "misplaced ellipsis" src1419) (values (list (quote quote) e1420) maps1422))))) ((lambda (tmp1430) ((lambda (tmp1431) (if (if tmp1431 (apply (lambda (dots1432 e1433) (ellipsis?1423 dots1432)) tmp1431) #f) (apply (lambda (dots1434 e1435) (gen-syntax1384 src1419 e1435 r1421 maps1422 (lambda (x1436) #f) mod1424)) tmp1431) ((lambda (tmp1437) (if (if tmp1437 (apply (lambda (x1438 dots1439 y1440) (ellipsis?1423 dots1439)) tmp1437) #f) (apply (lambda (x1441 dots1442 y1443) (letrec ((f1444 (lambda (y1445 k1446) ((lambda (tmp1450) ((lambda (tmp1451) (if (if tmp1451 (apply (lambda (dots1452 y1453) (ellipsis?1423 dots1452)) tmp1451) #f) (apply (lambda (dots1454 y1455) (f1444 y1455 (lambda (maps1456) (call-with-values (lambda () (k1446 (cons (quote ()) maps1456))) (lambda (x1457 maps1458) (if (null? (car maps1458)) (syntax-violation (quote syntax) "extra ellipsis" src1419) (values (gen-mappend1386 x1457 (car maps1458)) (cdr maps1458)))))))) tmp1451) ((lambda (_1459) (call-with-values (lambda () (gen-syntax1384 src1419 y1445 r1421 maps1422 ellipsis?1423 mod1424)) (lambda (y1460 maps1461) (call-with-values (lambda () (k1446 maps1461)) (lambda (x1462 maps1463) (values (gen-append1389 x1462 y1460) maps1463)))))) tmp1450))) ($sc-dispatch tmp1450 (quote (any . any))))) y1445)))) (f1444 y1443 (lambda (maps1447) (call-with-values (lambda () (gen-syntax1384 src1419 x1441 r1421 (cons (quote ()) maps1447) ellipsis?1423 mod1424)) (lambda (x1448 maps1449) (if (null? (car maps1449)) (syntax-violation (quote syntax) "extra ellipsis" src1419) (values (gen-map1387 x1448 (car maps1449)) (cdr maps1449))))))))) tmp1437) ((lambda (tmp1464) (if tmp1464 (apply (lambda (x1465 y1466) (call-with-values (lambda () (gen-syntax1384 src1419 x1465 r1421 maps1422 ellipsis?1423 mod1424)) (lambda (x1467 maps1468) (call-with-values (lambda () (gen-syntax1384 src1419 y1466 r1421 maps1468 ellipsis?1423 mod1424)) (lambda (y1469 maps1470) (values (gen-cons1388 x1467 y1469) maps1470)))))) tmp1464) ((lambda (tmp1471) (if tmp1471 (apply (lambda (e11472 e21473) (call-with-values (lambda () (gen-syntax1384 src1419 (cons e11472 e21473) r1421 maps1422 ellipsis?1423 mod1424)) (lambda (e1475 maps1476) (values (gen-vector1390 e1475) maps1476)))) tmp1471) ((lambda (_1477) (values (list (quote quote) e1420) maps1422)) tmp1430))) ($sc-dispatch tmp1430 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1430 (quote (any . any)))))) ($sc-dispatch tmp1430 (quote (any any . any)))))) ($sc-dispatch tmp1430 (quote (any any))))) e1420))))) (lambda (e1478 r1479 w1480 s1481 mod1482) (let ((e1483 (source-wrap598 e1478 w1480 s1481 mod1482))) ((lambda (tmp1484) ((lambda (tmp1485) (if tmp1485 (apply (lambda (_1486 x1487) (call-with-values (lambda () (gen-syntax1384 e1483 x1487 r1479 (quote ()) ellipsis?614 mod1482)) (lambda (e1488 maps1489) (regen1391 e1488)))) tmp1485) ((lambda (_1490) (syntax-violation (quote syntax) "bad `syntax' form" e1483)) tmp1484))) ($sc-dispatch tmp1484 (quote (any any))))) e1483))))) (global-extend567 (quote core) (quote lambda) (lambda (e1491 r1492 w1493 s1494 mod1495) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (_1498 c1499) (chi-lambda-clause610 (source-wrap598 e1491 w1493 s1494 mod1495) #f c1499 r1492 w1493 mod1495 (lambda (names1500 vars1501 docstring1502 body1503) (build-lambda545 s1494 names1500 vars1501 docstring1502 body1503)))) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any . any))))) e1491))) (global-extend567 (quote core) (quote let) (letrec ((chi-let1504 (lambda (e1505 r1506 w1507 s1508 mod1509 constructor1510 ids1511 vals1512 exps1513) (if (not (valid-bound-ids?594 ids1511)) (syntax-violation (quote let) "duplicate bound variable" e1505) (let ((labels1514 (gen-labels575 ids1511)) (new-vars1515 (map gen-var617 ids1511))) (let ((nw1516 (make-binding-wrap586 ids1511 labels1514 w1507)) (nr1517 (extend-var-env564 labels1514 new-vars1515 r1506))) (constructor1510 s1508 (map syntax->datum ids1511) new-vars1515 (map (lambda (x1518) (chi605 x1518 r1506 w1507 mod1509)) vals1512) (chi-body609 exps1513 (source-wrap598 e1505 nw1516 s1508 mod1509) nr1517 nw1516 mod1509)))))))) (lambda (e1519 r1520 w1521 s1522 mod1523) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 id1527 val1528 e11529 e21530) (chi-let1504 e1519 r1520 w1521 s1522 mod1523 build-let549 id1527 val1528 (cons e11529 e21530))) tmp1525) ((lambda (tmp1534) (if (if tmp1534 (apply (lambda (_1535 f1536 id1537 val1538 e11539 e21540) (id?569 f1536)) tmp1534) #f) (apply (lambda (_1541 f1542 id1543 val1544 e11545 e21546) (chi-let1504 e1519 r1520 w1521 s1522 mod1523 build-named-let550 (cons f1542 id1543) val1544 (cons e11545 e21546))) tmp1534) ((lambda (_1550) (syntax-violation (quote let) "bad let" (source-wrap598 e1519 w1521 s1522 mod1523))) tmp1524))) ($sc-dispatch tmp1524 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1524 (quote (any #(each (any any)) any . each-any))))) e1519)))) (global-extend567 (quote core) (quote letrec) (lambda (e1551 r1552 w1553 s1554 mod1555) ((lambda (tmp1556) ((lambda (tmp1557) (if tmp1557 (apply (lambda (_1558 id1559 val1560 e11561 e21562) (let ((ids1563 id1559)) (if (not (valid-bound-ids?594 ids1563)) (syntax-violation (quote letrec) "duplicate bound variable" e1551) (let ((labels1565 (gen-labels575 ids1563)) (new-vars1566 (map gen-var617 ids1563))) (let ((w1567 (make-binding-wrap586 ids1563 labels1565 w1553)) (r1568 (extend-var-env564 labels1565 new-vars1566 r1552))) (build-letrec551 s1554 (map syntax->datum ids1563) new-vars1566 (map (lambda (x1569) (chi605 x1569 r1568 w1567 mod1555)) val1560) (chi-body609 (cons e11561 e21562) (source-wrap598 e1551 w1567 s1554 mod1555) r1568 w1567 mod1555))))))) tmp1557) ((lambda (_1572) (syntax-violation (quote letrec) "bad letrec" (source-wrap598 e1551 w1553 s1554 mod1555))) tmp1556))) ($sc-dispatch tmp1556 (quote (any #(each (any any)) any . each-any))))) e1551))) (global-extend567 (quote core) (quote set!) (lambda (e1573 r1574 w1575 s1576 mod1577) ((lambda (tmp1578) ((lambda (tmp1579) (if (if tmp1579 (apply (lambda (_1580 id1581 val1582) (id?569 id1581)) tmp1579) #f) (apply (lambda (_1583 id1584 val1585) (let ((val1586 (chi605 val1585 r1574 w1575 mod1577)) (n1587 (id-var-name591 id1584 w1575))) (let ((b1588 (lookup566 n1587 r1574 mod1577))) (let ((t1589 (binding-type561 b1588))) (if (memv t1589 (quote (lexical))) (build-lexical-assignment540 s1576 (syntax->datum id1584) (binding-value562 b1588) val1586) (if (memv t1589 (quote (global))) (build-global-assignment543 s1576 n1587 val1586 mod1577) (if (memv t1589 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap597 id1584 w1575 mod1577)) (syntax-violation (quote set!) "bad set!" (source-wrap598 e1573 w1575 s1576 mod1577))))))))) tmp1579) ((lambda (tmp1590) (if tmp1590 (apply (lambda (_1591 head1592 tail1593 val1594) (call-with-values (lambda () (syntax-type603 head1592 r1574 (quote (())) #f #f mod1577)) (lambda (type1595 value1596 ee1597 ww1598 ss1599 modmod1600) (let ((t1601 type1595)) (if (memv t1601 (quote (module-ref))) (let ((val1602 (chi605 val1594 r1574 w1575 mod1577))) (call-with-values (lambda () (value1596 (cons head1592 tail1593))) (lambda (id1604 mod1605) (build-global-assignment543 s1576 id1604 val1602 mod1605)))) (build-application537 s1576 (chi605 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1592) r1574 w1575 mod1577) (map (lambda (e1606) (chi605 e1606 r1574 w1575 mod1577)) (append tail1593 (list val1594))))))))) tmp1590) ((lambda (_1608) (syntax-violation (quote set!) "bad set!" (source-wrap598 e1573 w1575 s1576 mod1577))) tmp1578))) ($sc-dispatch tmp1578 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1578 (quote (any any any))))) e1573))) (global-extend567 (quote module-ref) (quote @) (lambda (e1609) ((lambda (tmp1610) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 mod1613 id1614) (and (and-map id?569 mod1613) (id?569 id1614))) tmp1611) #f) (apply (lambda (_1616 mod1617 id1618) (values (syntax->datum id1618) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1617)))) tmp1611) (syntax-violation #f "source expression failed to match any pattern" tmp1610))) ($sc-dispatch tmp1610 (quote (any each-any any))))) e1609))) (global-extend567 (quote module-ref) (quote @@) (lambda (e1620) ((lambda (tmp1621) ((lambda (tmp1622) (if (if tmp1622 (apply (lambda (_1623 mod1624 id1625) (and (and-map id?569 mod1624) (id?569 id1625))) tmp1622) #f) (apply (lambda (_1627 mod1628 id1629) (values (syntax->datum id1629) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1628)))) tmp1622) (syntax-violation #f "source expression failed to match any pattern" tmp1621))) ($sc-dispatch tmp1621 (quote (any each-any any))))) e1620))) (global-extend567 (quote begin) (quote begin) (quote ())) (global-extend567 (quote define) (quote define) (quote ())) (global-extend567 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend567 (quote eval-when) (quote eval-when) (quote ())) (global-extend567 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1634 (lambda (x1635 keys1636 clauses1637 r1638 mod1639) (if (null? clauses1637) (build-application537 #f (build-primref546 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1635)) ((lambda (tmp1640) ((lambda (tmp1641) (if tmp1641 (apply (lambda (pat1642 exp1643) (if (and (id?569 pat1642) (and-map (lambda (x1644) (not (free-id=?592 pat1642 x1644))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1636))) (let ((labels1645 (list (gen-label574))) (var1646 (gen-var617 pat1642))) (build-application537 #f (build-lambda545 #f (list (syntax->datum pat1642)) (list var1646) #f (chi605 exp1643 (extend-env563 labels1645 (list (cons (quote syntax) (cons var1646 0))) r1638) (make-binding-wrap586 (list pat1642) labels1645 (quote (()))) mod1639)) (list x1635))) (gen-clause1633 x1635 keys1636 (cdr clauses1637) r1638 pat1642 #t exp1643 mod1639))) tmp1641) ((lambda (tmp1647) (if tmp1647 (apply (lambda (pat1648 fender1649 exp1650) (gen-clause1633 x1635 keys1636 (cdr clauses1637) r1638 pat1648 fender1649 exp1650 mod1639)) tmp1647) ((lambda (_1651) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1637))) tmp1640))) ($sc-dispatch tmp1640 (quote (any any any)))))) ($sc-dispatch tmp1640 (quote (any any))))) (car clauses1637))))) (gen-clause1633 (lambda (x1652 keys1653 clauses1654 r1655 pat1656 fender1657 exp1658 mod1659) (call-with-values (lambda () (convert-pattern1631 pat1656 keys1653)) (lambda (p1660 pvars1661) (cond ((not (distinct-bound-ids?595 (map car pvars1661))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1656)) ((not (and-map (lambda (x1662) (not (ellipsis?614 (car x1662)))) pvars1661)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1656)) (else (let ((y1663 (gen-var617 (quote tmp)))) (build-application537 #f (build-lambda545 #f (list (quote tmp)) (list y1663) #f (let ((y1664 (build-lexical-reference539 (quote value) #f (quote tmp) y1663))) (build-conditional538 #f ((lambda (tmp1665) ((lambda (tmp1666) (if tmp1666 (apply (lambda () y1664) tmp1666) ((lambda (_1667) (build-conditional538 #f y1664 (build-dispatch-call1632 pvars1661 fender1657 y1664 r1655 mod1659) (build-data547 #f #f))) tmp1665))) ($sc-dispatch tmp1665 (quote #(atom #t))))) fender1657) (build-dispatch-call1632 pvars1661 exp1658 y1664 r1655 mod1659) (gen-syntax-case1634 x1652 keys1653 clauses1654 r1655 mod1659)))) (list (if (eq? p1660 (quote any)) (build-application537 #f (build-primref546 #f (quote list)) (list x1652)) (build-application537 #f (build-primref546 #f (quote $sc-dispatch)) (list x1652 (build-data547 #f p1660))))))))))))) (build-dispatch-call1632 (lambda (pvars1668 exp1669 y1670 r1671 mod1672) (let ((ids1673 (map car pvars1668)) (levels1674 (map cdr pvars1668))) (let ((labels1675 (gen-labels575 ids1673)) (new-vars1676 (map gen-var617 ids1673))) (build-application537 #f (build-primref546 #f (quote apply)) (list (build-lambda545 #f (map syntax->datum ids1673) new-vars1676 #f (chi605 exp1669 (extend-env563 labels1675 (map (lambda (var1677 level1678) (cons (quote syntax) (cons var1677 level1678))) new-vars1676 (map cdr pvars1668)) r1671) (make-binding-wrap586 ids1673 labels1675 (quote (()))) mod1672)) y1670)))))) (convert-pattern1631 (lambda (pattern1679 keys1680) (letrec ((cvt1681 (lambda (p1682 n1683 ids1684) (if (id?569 p1682) (if (bound-id-member?596 p1682 keys1680) (values (vector (quote free-id) p1682) ids1684) (values (quote any) (cons (cons p1682 n1683) ids1684))) ((lambda (tmp1685) ((lambda (tmp1686) (if (if tmp1686 (apply (lambda (x1687 dots1688) (ellipsis?614 dots1688)) tmp1686) #f) (apply (lambda (x1689 dots1690) (call-with-values (lambda () (cvt1681 x1689 (fx+529 n1683 1) ids1684)) (lambda (p1691 ids1692) (values (if (eq? p1691 (quote any)) (quote each-any) (vector (quote each) p1691)) ids1692)))) tmp1686) ((lambda (tmp1693) (if tmp1693 (apply (lambda (x1694 y1695) (call-with-values (lambda () (cvt1681 y1695 n1683 ids1684)) (lambda (y1696 ids1697) (call-with-values (lambda () (cvt1681 x1694 n1683 ids1697)) (lambda (x1698 ids1699) (values (cons x1698 y1696) ids1699)))))) tmp1693) ((lambda (tmp1700) (if tmp1700 (apply (lambda () (values (quote ()) ids1684)) tmp1700) ((lambda (tmp1701) (if tmp1701 (apply (lambda (x1702) (call-with-values (lambda () (cvt1681 x1702 n1683 ids1684)) (lambda (p1704 ids1705) (values (vector (quote vector) p1704) ids1705)))) tmp1701) ((lambda (x1706) (values (vector (quote atom) (strip616 p1682 (quote (())))) ids1684)) tmp1685))) ($sc-dispatch tmp1685 (quote #(vector each-any)))))) ($sc-dispatch tmp1685 (quote ()))))) ($sc-dispatch tmp1685 (quote (any . any)))))) ($sc-dispatch tmp1685 (quote (any any))))) p1682))))) (cvt1681 pattern1679 0 (quote ())))))) (lambda (e1707 r1708 w1709 s1710 mod1711) (let ((e1712 (source-wrap598 e1707 w1709 s1710 mod1711))) ((lambda (tmp1713) ((lambda (tmp1714) (if tmp1714 (apply (lambda (_1715 val1716 key1717 m1718) (if (and-map (lambda (x1719) (and (id?569 x1719) (not (ellipsis?614 x1719)))) key1717) (let ((x1721 (gen-var617 (quote tmp)))) (build-application537 s1710 (build-lambda545 #f (list (quote tmp)) (list x1721) #f (gen-syntax-case1634 (build-lexical-reference539 (quote value) #f (quote tmp) x1721) key1717 m1718 r1708 mod1711)) (list (chi605 val1716 r1708 (quote (())) mod1711)))) (syntax-violation (quote syntax-case) "invalid literals list" e1712))) tmp1714) (syntax-violation #f "source expression failed to match any pattern" tmp1713))) ($sc-dispatch tmp1713 (quote (any any each-any . each-any))))) e1712))))) (set! sc-expand (lambda (x1725 . rest1724) (if (and (pair? x1725) (equal? (car x1725) noexpand527)) (cadr x1725) (let ((m1726 (if (null? rest1724) (quote e) (car rest1724))) (esew1727 (if (or (null? rest1724) (null? (cdr rest1724))) (quote (eval)) (cadr rest1724)))) (with-fluid* *mode*528 m1726 (lambda () (chi-top604 x1725 (quote ()) (quote ((top))) m1726 esew1727 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1728) (nonsymbol-id?568 x1728))) (set! datum->syntax (lambda (id1729 datum1730) (make-syntax-object552 datum1730 (syntax-object-wrap555 id1729) #f))) (set! syntax->datum (lambda (x1731) (strip616 x1731 (quote (()))))) (set! generate-temporaries (lambda (ls1732) (begin (let ((x1733 ls1732)) (if (not (list? x1733)) (syntax-violation (quote generate-temporaries) "invalid argument" x1733))) (map (lambda (x1734) (wrap597 (gensym) (quote ((top))) #f)) ls1732)))) (set! free-identifier=? (lambda (x1735 y1736) (begin (let ((x1737 x1735)) (if (not (nonsymbol-id?568 x1737)) (syntax-violation (quote free-identifier=?) "invalid argument" x1737))) (let ((x1738 y1736)) (if (not (nonsymbol-id?568 x1738)) (syntax-violation (quote free-identifier=?) "invalid argument" x1738))) (free-id=?592 x1735 y1736)))) (set! bound-identifier=? (lambda (x1739 y1740) (begin (let ((x1741 x1739)) (if (not (nonsymbol-id?568 x1741)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1741))) (let ((x1742 y1740)) (if (not (nonsymbol-id?568 x1742)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1742))) (bound-id=?593 x1739 y1740)))) (set! syntax-violation (lambda (who1746 message1745 form1744 . subform1743) (begin (let ((x1747 who1746)) (if (not ((lambda (x1748) (or (not x1748) (string? x1748) (symbol? x1748))) x1747)) (syntax-violation (quote syntax-violation) "invalid argument" x1747))) (let ((x1749 message1745)) (if (not (string? x1749)) (syntax-violation (quote syntax-violation) "invalid argument" x1749))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1746 "~a: " "") "~a " (if (null? subform1743) "in ~a" "in subform `~s' of `~s'")) (let ((tail1750 (cons message1745 (map (lambda (x1751) (strip616 x1751 (quote (())))) (append subform1743 (list form1744)))))) (if who1746 (cons who1746 tail1750) tail1750)) #f)))) (letrec ((match1756 (lambda (e1757 p1758 w1759 r1760 mod1761) (cond ((not r1760) #f) ((eq? p1758 (quote any)) (cons (wrap597 e1757 w1759 mod1761) r1760)) ((syntax-object?553 e1757) (match*1755 (let ((e1762 (syntax-object-expression554 e1757))) (if (annotation? e1762) (annotation-expression e1762) e1762)) p1758 (join-wraps588 w1759 (syntax-object-wrap555 e1757)) r1760 (syntax-object-module556 e1757))) (else (match*1755 (let ((e1763 e1757)) (if (annotation? e1763) (annotation-expression e1763) e1763)) p1758 w1759 r1760 mod1761))))) (match*1755 (lambda (e1764 p1765 w1766 r1767 mod1768) (cond ((null? p1765) (and (null? e1764) r1767)) ((pair? p1765) (and (pair? e1764) (match1756 (car e1764) (car p1765) w1766 (match1756 (cdr e1764) (cdr p1765) w1766 r1767 mod1768) mod1768))) ((eq? p1765 (quote each-any)) (let ((l1769 (match-each-any1753 e1764 w1766 mod1768))) (and l1769 (cons l1769 r1767)))) (else (let ((t1770 (vector-ref p1765 0))) (if (memv t1770 (quote (each))) (if (null? e1764) (match-empty1754 (vector-ref p1765 1) r1767) (let ((l1771 (match-each1752 e1764 (vector-ref p1765 1) w1766 mod1768))) (and l1771 (letrec ((collect1772 (lambda (l1773) (if (null? (car l1773)) r1767 (cons (map car l1773) (collect1772 (map cdr l1773))))))) (collect1772 l1771))))) (if (memv t1770 (quote (free-id))) (and (id?569 e1764) (free-id=?592 (wrap597 e1764 w1766 mod1768) (vector-ref p1765 1)) r1767) (if (memv t1770 (quote (atom))) (and (equal? (vector-ref p1765 1) (strip616 e1764 w1766)) r1767) (if (memv t1770 (quote (vector))) (and (vector? e1764) (match1756 (vector->list e1764) (vector-ref p1765 1) w1766 r1767 mod1768))))))))))) (match-empty1754 (lambda (p1774 r1775) (cond ((null? p1774) r1775) ((eq? p1774 (quote any)) (cons (quote ()) r1775)) ((pair? p1774) (match-empty1754 (car p1774) (match-empty1754 (cdr p1774) r1775))) ((eq? p1774 (quote each-any)) (cons (quote ()) r1775)) (else (let ((t1776 (vector-ref p1774 0))) (if (memv t1776 (quote (each))) (match-empty1754 (vector-ref p1774 1) r1775) (if (memv t1776 (quote (free-id atom))) r1775 (if (memv t1776 (quote (vector))) (match-empty1754 (vector-ref p1774 1) r1775))))))))) (match-each-any1753 (lambda (e1777 w1778 mod1779) (cond ((annotation? e1777) (match-each-any1753 (annotation-expression e1777) w1778 mod1779)) ((pair? e1777) (let ((l1780 (match-each-any1753 (cdr e1777) w1778 mod1779))) (and l1780 (cons (wrap597 (car e1777) w1778 mod1779) l1780)))) ((null? e1777) (quote ())) ((syntax-object?553 e1777) (match-each-any1753 (syntax-object-expression554 e1777) (join-wraps588 w1778 (syntax-object-wrap555 e1777)) mod1779)) (else #f)))) (match-each1752 (lambda (e1781 p1782 w1783 mod1784) (cond ((annotation? e1781) (match-each1752 (annotation-expression e1781) p1782 w1783 mod1784)) ((pair? e1781) (let ((first1785 (match1756 (car e1781) p1782 w1783 (quote ()) mod1784))) (and first1785 (let ((rest1786 (match-each1752 (cdr e1781) p1782 w1783 mod1784))) (and rest1786 (cons first1785 rest1786)))))) ((null? e1781) (quote ())) ((syntax-object?553 e1781) (match-each1752 (syntax-object-expression554 e1781) p1782 (join-wraps588 w1783 (syntax-object-wrap555 e1781)) (syntax-object-module556 e1781))) (else #f))))) (set! $sc-dispatch (lambda (e1787 p1788) (cond ((eq? p1788 (quote any)) (list e1787)) ((syntax-object?553 e1787) (match*1755 (let ((e1789 (syntax-object-expression554 e1787))) (if (annotation? e1789) (annotation-expression e1789) e1789)) p1788 (syntax-object-wrap555 e1787) (quote ()) (syntax-object-module556 e1787))) (else (match*1755 (let ((e1790 e1787)) (if (annotation? e1790) (annotation-expression e1790) e1790)) p1788 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1791) ((lambda (tmp1792) ((lambda (tmp1793) (if tmp1793 (apply (lambda (_1794 e11795 e21796) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11795 e21796))) tmp1793) ((lambda (tmp1798) (if tmp1798 (apply (lambda (_1799 out1800 in1801 e11802 e21803) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1801 (quote ()) (list out1800 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11802 e21803))))) tmp1798) ((lambda (tmp1805) (if tmp1805 (apply (lambda (_1806 out1807 in1808 e11809 e21810) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1808) (quote ()) (list out1807 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11809 e21810))))) tmp1805) (syntax-violation #f "source expression failed to match any pattern" tmp1792))) ($sc-dispatch tmp1792 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1792 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1792 (quote (any () any . each-any))))) x1791)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1814) ((lambda (tmp1815) ((lambda (tmp1816) (if tmp1816 (apply (lambda (_1817 k1818 keyword1819 pattern1820 template1821) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1818 (map (lambda (tmp1824 tmp1823) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1823) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1824))) template1821 pattern1820)))))) tmp1816) (syntax-violation #f "source expression failed to match any pattern" tmp1815))) ($sc-dispatch tmp1815 (quote (any each-any . #(each ((any . any) any))))))) x1814)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1825) ((lambda (tmp1826) ((lambda (tmp1827) (if (if tmp1827 (apply (lambda (let*1828 x1829 v1830 e11831 e21832) (and-map identifier? x1829)) tmp1827) #f) (apply (lambda (let*1834 x1835 v1836 e11837 e21838) (letrec ((f1839 (lambda (bindings1840) (if (null? bindings1840) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11837 e21838))) ((lambda (tmp1844) ((lambda (tmp1845) (if tmp1845 (apply (lambda (body1846 binding1847) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1847) body1846)) tmp1845) (syntax-violation #f "source expression failed to match any pattern" tmp1844))) ($sc-dispatch tmp1844 (quote (any any))))) (list (f1839 (cdr bindings1840)) (car bindings1840))))))) (f1839 (map list x1835 v1836)))) tmp1827) (syntax-violation #f "source expression failed to match any pattern" tmp1826))) ($sc-dispatch tmp1826 (quote (any #(each (any any)) any . each-any))))) x1825)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1848) ((lambda (tmp1849) ((lambda (tmp1850) (if tmp1850 (apply (lambda (_1851 var1852 init1853 step1854 e01855 e11856 c1857) ((lambda (tmp1858) ((lambda (tmp1859) (if tmp1859 (apply (lambda (step1860) ((lambda (tmp1861) ((lambda (tmp1862) (if tmp1862 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1852 init1853) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01855) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1857 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1860))))))) tmp1862) ((lambda (tmp1867) (if tmp1867 (apply (lambda (e11868 e21869) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1852 init1853) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01855 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11868 e21869)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1857 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1860))))))) tmp1867) (syntax-violation #f "source expression failed to match any pattern" tmp1861))) ($sc-dispatch tmp1861 (quote (any . each-any)))))) ($sc-dispatch tmp1861 (quote ())))) e11856)) tmp1859) (syntax-violation #f "source expression failed to match any pattern" tmp1858))) ($sc-dispatch tmp1858 (quote each-any)))) (map (lambda (v1876 s1877) ((lambda (tmp1878) ((lambda (tmp1879) (if tmp1879 (apply (lambda () v1876) tmp1879) ((lambda (tmp1880) (if tmp1880 (apply (lambda (e1881) e1881) tmp1880) ((lambda (_1882) (syntax-violation (quote do) "bad step expression" orig-x1848 s1877)) tmp1878))) ($sc-dispatch tmp1878 (quote (any)))))) ($sc-dispatch tmp1878 (quote ())))) s1877)) var1852 step1854))) tmp1850) (syntax-violation #f "source expression failed to match any pattern" tmp1849))) ($sc-dispatch tmp1849 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1848)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1885 (lambda (x1889 y1890) ((lambda (tmp1891) ((lambda (tmp1892) (if tmp1892 (apply (lambda (x1893 y1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (dy1897) ((lambda (tmp1898) ((lambda (tmp1899) (if tmp1899 (apply (lambda (dx1900) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1900 dy1897))) tmp1899) ((lambda (_1901) (if (null? dy1897) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1893) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1893 y1894))) tmp1898))) ($sc-dispatch tmp1898 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1893)) tmp1896) ((lambda (tmp1902) (if tmp1902 (apply (lambda (stuff1903) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1893 stuff1903))) tmp1902) ((lambda (else1904) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1893 y1894)) tmp1895))) ($sc-dispatch tmp1895 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1895 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1894)) tmp1892) (syntax-violation #f "source expression failed to match any pattern" tmp1891))) ($sc-dispatch tmp1891 (quote (any any))))) (list x1889 y1890)))) (quasiappend1886 (lambda (x1905 y1906) ((lambda (tmp1907) ((lambda (tmp1908) (if tmp1908 (apply (lambda (x1909 y1910) ((lambda (tmp1911) ((lambda (tmp1912) (if tmp1912 (apply (lambda () x1909) tmp1912) ((lambda (_1913) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1909 y1910)) tmp1911))) ($sc-dispatch tmp1911 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1910)) tmp1908) (syntax-violation #f "source expression failed to match any pattern" tmp1907))) ($sc-dispatch tmp1907 (quote (any any))))) (list x1905 y1906)))) (quasivector1887 (lambda (x1914) ((lambda (tmp1915) ((lambda (x1916) ((lambda (tmp1917) ((lambda (tmp1918) (if tmp1918 (apply (lambda (x1919) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1919))) tmp1918) ((lambda (tmp1921) (if tmp1921 (apply (lambda (x1922) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1922)) tmp1921) ((lambda (_1924) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1916)) tmp1917))) ($sc-dispatch tmp1917 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1917 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1916)) tmp1915)) x1914))) (quasi1888 (lambda (p1925 lev1926) ((lambda (tmp1927) ((lambda (tmp1928) (if tmp1928 (apply (lambda (p1929) (if (= lev1926 0) p1929 (quasicons1885 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1888 (list p1929) (- lev1926 1))))) tmp1928) ((lambda (tmp1930) (if tmp1930 (apply (lambda (p1931 q1932) (if (= lev1926 0) (quasiappend1886 p1931 (quasi1888 q1932 lev1926)) (quasicons1885 (quasicons1885 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1888 (list p1931) (- lev1926 1))) (quasi1888 q1932 lev1926)))) tmp1930) ((lambda (tmp1933) (if tmp1933 (apply (lambda (p1934) (quasicons1885 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1888 (list p1934) (+ lev1926 1)))) tmp1933) ((lambda (tmp1935) (if tmp1935 (apply (lambda (p1936 q1937) (quasicons1885 (quasi1888 p1936 lev1926) (quasi1888 q1937 lev1926))) tmp1935) ((lambda (tmp1938) (if tmp1938 (apply (lambda (x1939) (quasivector1887 (quasi1888 x1939 lev1926))) tmp1938) ((lambda (p1941) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1941)) tmp1927))) ($sc-dispatch tmp1927 (quote #(vector each-any)))))) ($sc-dispatch tmp1927 (quote (any . any)))))) ($sc-dispatch tmp1927 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1927 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1927 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1925)))) (lambda (x1942) ((lambda (tmp1943) ((lambda (tmp1944) (if tmp1944 (apply (lambda (_1945 e1946) (quasi1888 e1946 0)) tmp1944) (syntax-violation #f "source expression failed to match any pattern" tmp1943))) ($sc-dispatch tmp1943 (quote (any any))))) x1942))))) +(define include (make-syncase-macro (quote macro) (lambda (x1947) (letrec ((read-file1948 (lambda (fn1949 k1950) (let ((p1951 (open-input-file fn1949))) (letrec ((f1952 (lambda (x1953) (if (eof-object? x1953) (begin (close-input-port p1951) (quote ())) (cons (datum->syntax k1950 x1953) (f1952 (read p1951))))))) (f1952 (read p1951))))))) ((lambda (tmp1954) ((lambda (tmp1955) (if tmp1955 (apply (lambda (k1956 filename1957) (let ((fn1958 (syntax->datum filename1957))) ((lambda (tmp1959) ((lambda (tmp1960) (if tmp1960 (apply (lambda (exp1961) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1961)) tmp1960) (syntax-violation #f "source expression failed to match any pattern" tmp1959))) ($sc-dispatch tmp1959 (quote each-any)))) (read-file1948 fn1958 k1956)))) tmp1955) (syntax-violation #f "source expression failed to match any pattern" tmp1954))) ($sc-dispatch tmp1954 (quote (any any))))) x1947))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1963) ((lambda (tmp1964) ((lambda (tmp1965) (if tmp1965 (apply (lambda (_1966 e1967) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1963)) tmp1965) (syntax-violation #f "source expression failed to match any pattern" tmp1964))) ($sc-dispatch tmp1964 (quote (any any))))) x1963)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1968) ((lambda (tmp1969) ((lambda (tmp1970) (if tmp1970 (apply (lambda (_1971 e1972) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1968)) tmp1970) (syntax-violation #f "source expression failed to match any pattern" tmp1969))) ($sc-dispatch tmp1969 (quote (any any))))) x1968)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1973) ((lambda (tmp1974) ((lambda (tmp1975) (if tmp1975 (apply (lambda (_1976 e1977 m11978 m21979) ((lambda (tmp1980) ((lambda (body1981) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1977)) body1981)) tmp1980)) (letrec ((f1982 (lambda (clause1983 clauses1984) (if (null? clauses1984) ((lambda (tmp1986) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11988 e21989))) tmp1987) ((lambda (tmp1991) (if tmp1991 (apply (lambda (k1992 e11993 e21994) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1992)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11993 e21994)))) tmp1991) ((lambda (_1997) (syntax-violation (quote case) "bad clause" x1973 clause1983)) tmp1986))) ($sc-dispatch tmp1986 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1986 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1983) ((lambda (tmp1998) ((lambda (rest1999) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (k2002 e12003 e22004) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2002)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12003 e22004)) rest1999)) tmp2001) ((lambda (_2007) (syntax-violation (quote case) "bad clause" x1973 clause1983)) tmp2000))) ($sc-dispatch tmp2000 (quote (each-any any . each-any))))) clause1983)) tmp1998)) (f1982 (car clauses1984) (cdr clauses1984))))))) (f1982 m11978 m21979)))) tmp1975) (syntax-violation #f "source expression failed to match any pattern" tmp1974))) ($sc-dispatch tmp1974 (quote (any any any . each-any))))) x1973)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2008) ((lambda (tmp2009) ((lambda (tmp2010) (if tmp2010 (apply (lambda (_2011 e2012) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2012)) (list (cons _2011 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2012 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2010) (syntax-violation #f "source expression failed to match any pattern" tmp2009))) ($sc-dispatch tmp2009 (quote (any any))))) x2008)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 7b0b69d4b..fd7ad5906 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -436,7 +436,7 @@ (define build-lambda (lambda (src ids vars docstring exp) (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-lambda) src vars + ((c) ((@ (language tree-il) make-lambda) src ids vars (if docstring `((documentation . ,docstring)) '()) exp)) (else `(lambda ,vars ,@(if docstring (list docstring) '()) @@ -469,7 +469,7 @@ (if (null? vars) body-exp (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-let) src vars val-exps body-exp)) + ((c) ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) (else `(let ,(map list vars val-exps) ,body-exp)))))) (define build-named-let @@ -480,7 +480,7 @@ (ids (cdr ids))) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-letrec) src - ; (list f-name) + (list f-name) (list f) (list (build-lambda src ids vars #f body-exp)) (build-application src (build-lexical-reference 'fun src f-name f) @@ -492,7 +492,7 @@ (if (null? vars) body-exp (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-letrec) src vars val-exps body-exp)) + ((c) ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) (else `(letrec ,(map list vars val-exps) ,body-exp)))))) ;; FIXME: wingo: use make-lexical ? diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index c9857ac14..9b36f1808 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -35,11 +35,11 @@ toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp - lambda? make-lambda lambda-src lambda-vars lambda-meta lambda-body + lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body const? make-const const-src const-exp sequence? make-sequence sequence-src sequence-exps - let? make-let let-src let-vars let-vals let-exp - letrec? make-letrec letrec-src letrec-vars letrec-vals letrec-exp + let? make-let let-src let-names let-vars let-vals let-exp + letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp parse-tree-il unparse-tree-il @@ -60,11 +60,11 @@ ( name) ( name exp) ( name exp) - ( vars meta body) + ( names vars meta body) ( exp) ( exps) - ( vars vals exp) - ( vars vals exp)) + ( names vars vals exp) + ( names vars vals exp)) (define ) (define lexical? lexical-ref?) @@ -129,11 +129,11 @@ ((define ,name exp) (guard (symbol? name)) (make-toplevel-define loc name (retrans exp))) - ((lambda ,vars ,exp) - (make-lambda loc vars '() (retrans exp))) + ((lambda ,names ,vars ,exp) + (make-lambda loc names vars '() (retrans exp))) - ((lambda ,vars ,meta ,exp) - (make-lambda loc vars meta (retrans exp))) + ((lambda ,names ,vars ,meta ,exp) + (make-lambda loc names vars meta (retrans exp))) ((const ,exp) (make-const loc exp)) @@ -141,11 +141,11 @@ ((begin . ,exps) (make-sequence loc (map retrans exps))) - ((let ,vars ,vals ,exp) - (make-let loc vars vals (retrans exp))) + ((let ,names ,vars ,vals ,exp) + (make-let loc names vars vals (retrans exp))) - ((letrec ,vars ,vals ,exp) - (make-letrec loc vars vals (retrans exp))) + ((letrec ,names ,vars ,vals ,exp) + (make-letrec loc names vars vals (retrans exp))) (else (error "unrecognized tree-il" exp))))) @@ -185,8 +185,8 @@ (( name exp) `(define ,name ,(unparse-tree-il exp))) - (( vars meta body) - `(lambda ,vars ,meta ,(unparse-tree-il body))) + (( names vars meta body) + `(lambda ,names ,vars ,meta ,(unparse-tree-il body))) (( exp) `(const ,exp)) @@ -194,11 +194,11 @@ (( exps) `(begin ,@(map unparse-tree-il exps))) - (( vars vals exp) - `(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))) + (( names vars vals exp) + `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))) - (( vars vals exp) - `(letrec ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))))) + (( names vars vals exp) + `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))))) (define (tree-il->scheme e) (cond ((list? e) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 2b2410051..75d3f9603 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -33,7 +33,7 @@ ;; lambda -> (nlocs . nexts) (define (compile-glil x e opts) - (let* ((x (make-lambda (tree-il-src x) '() '() x)) + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) (x (optimize! x e opts)) (allocation (analyze-lexicals x))) (values (flatten-lambda x -1 allocation) From 2ce77f2d95271887b54d0c56d1e81d7f472ae1ae Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 May 2009 16:46:46 +0200 Subject: [PATCH 106/375] and now, we residualize the original names into the metadata. yay! * module/language/tree-il/compile-glil.scm (vars->bind-list) (emit-bindings, flatten-lambda, flatten): Write the original names into structures. Yaaaaay! --- module/language/tree-il/compile-glil.scm | 41 ++++++++++++++---------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 75d3f9603..29a9ee976 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -44,18 +44,20 @@ (define (make-label) (gensym ":L")) -(define (vars->bind-list vars allocation) - (map (lambda (v) +(define (vars->bind-list ids vars allocation) + (map (lambda (id v) (let ((loc (hashq-ref allocation v))) (case (car loc) - ((stack) (list v 'local (cdr loc))) - ((heap) (list v 'external (cddr loc))) - (else (error "badness" v loc))))) + ((stack) (list id 'local (cdr loc))) + ((heap) (list id 'external (cddr loc))) + (else (error "badness" id v loc))))) + ids vars)) -(define (emit-bindings src vars allocation emit-code) +(define (emit-bindings src ids vars allocation emit-code) (if (pair? vars) - (emit-code src (make-glil-bind (vars->bind-list vars allocation))))) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation))))) (define (with-output-to-code proc) (let ((out '())) @@ -67,11 +69,16 @@ (reverse out))) (define (flatten-lambda x level allocation) - (receive (vars nargs nrest) - (let lp ((vars (lambda-vars x)) (out '()) (n 0)) - (cond ((null? vars) (values (reverse out) n 0)) - ((pair? vars) (lp (cdr vars) (cons (car vars) out) (1+ n))) - (else (values (reverse (cons vars out)) (1+ n) 1)))) + (receive (ids vars nargs nrest) + (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) + (oids '()) (ovars '()) (n 0)) + (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) + ((pair? vars) (lp (cdr ids) (cdr vars) + (cons (car ids) oids) (cons (car vars) ovars) + (1+ n))) + (else (values (reverse (cons ids oids)) + (reverse (cons vars ovars)) + (1+ n) 1)))) (let ((nlocs (car (hashq-ref allocation x))) (nexts (cdr (hashq-ref allocation x)))) (make-glil-program @@ -79,7 +86,7 @@ (with-output-to-code (lambda (emit-code) ;; write bindings and source debugging info - (emit-bindings #f vars allocation emit-code) + (emit-bindings #f ids vars allocation emit-code) (if (lambda-src x) (emit-code (make-glil-src (lambda-src x)))) @@ -246,9 +253,9 @@ (emit-code #f (flatten-lambda x level allocation)) (emit-code #f (make-glil-call 'return 1))))) - (( src vars vals exp) + (( src names vars vals exp) (for-each comp-push vals) - (emit-bindings src vars allocation emit-code) + (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) (let ((loc (hashq-ref allocation v))) (case (car loc) @@ -261,9 +268,9 @@ (comp-tail exp) (emit-code #f (make-glil-unbind))) - (( src vars vals exp) + (( src names vars vals exp) (for-each comp-push vals) - (emit-bindings src vars allocation emit-code) + (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) (let ((loc (hashq-ref allocation v))) (case (car loc) From 1eec95f8def91bcb6f9f22c21c6d27ec2a7175ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 May 2009 18:04:36 +0200 Subject: [PATCH 107/375] define `delay' in terms of make-promise * module/ice-9/boot-9.scm (delay): Define `delay' in terms of make-promise. * module/ice-9/psyntax-pp.scm (compile): Regenerated with a fully compiled Guile, so that the gensym numbers are the same. * module/language/tree-il/compile-glil.scm: Add some notes about what needs doing to catch up to the old compiler. --- module/ice-9/boot-9.scm | 4 ++++ module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/language/tree-il/compile-glil.scm | 13 +++++++++++++ 3 files changed, 28 insertions(+), 11 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ae6aa9f73..94a9a39e2 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -210,6 +210,10 @@ ;; module system has booted up. (define %pre-modules-transformer sc-expand) +(define-syntax delay + (syntax-rules () + ((_ exp) (make-promise (lambda () exp))))) + ;;; {Defmacros} diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index a7f294901..55064eec8 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*475 (lambda (f515 first514 . rest513) (or (null? first514) (if (null? rest513) (letrec ((andmap516 (lambda (first517) (let ((x518 (car first517)) (first519 (cdr first517))) (if (null? first519) (f515 x518) (and (f515 x518) (andmap516 first519))))))) (andmap516 first514)) (letrec ((andmap520 (lambda (first521 rest522) (let ((x523 (car first521)) (xr524 (map car rest522)) (first525 (cdr first521)) (rest526 (map cdr rest522))) (if (null? first525) (apply f515 (cons x523 xr524)) (and (apply f515 (cons x523 xr524)) (andmap520 first525 rest526))))))) (andmap520 first514 rest513))))))) (letrec ((lambda-var-list618 (lambda (vars747) (letrec ((lvl748 (lambda (vars749 ls750 w751) (cond ((pair? vars749) (lvl748 (cdr vars749) (cons (wrap597 (car vars749) w751 #f) ls750) w751)) ((id?569 vars749) (cons (wrap597 vars749 w751 #f) ls750)) ((null? vars749) ls750) ((syntax-object?553 vars749) (lvl748 (syntax-object-expression554 vars749) ls750 (join-wraps588 w751 (syntax-object-wrap555 vars749)))) ((annotation? vars749) (lvl748 (annotation-expression vars749) ls750 w751)) (else (cons vars749 ls750)))))) (lvl748 vars747 (quote ()) (quote (())))))) (gen-var617 (lambda (id752) (let ((id753 (if (syntax-object?553 id752) (syntax-object-expression554 id752) id752))) (if (annotation? id753) (gensym (symbol->string (annotation-expression id753))) (gensym (symbol->string id753)))))) (strip616 (lambda (x754 w755) (if (memq (quote top) (wrap-marks572 w755)) (if (or (annotation? x754) (and (pair? x754) (annotation? (car x754)))) (strip-annotation615 x754 #f) x754) (letrec ((f756 (lambda (x757) (cond ((syntax-object?553 x757) (strip616 (syntax-object-expression554 x757) (syntax-object-wrap555 x757))) ((pair? x757) (let ((a758 (f756 (car x757))) (d759 (f756 (cdr x757)))) (if (and (eq? a758 (car x757)) (eq? d759 (cdr x757))) x757 (cons a758 d759)))) ((vector? x757) (let ((old760 (vector->list x757))) (let ((new761 (map f756 old760))) (if (and-map*475 eq? old760 new761) x757 (list->vector new761))))) (else x757))))) (f756 x754))))) (strip-annotation615 (lambda (x762 parent763) (cond ((pair? x762) (let ((new764 (cons #f #f))) (begin (if parent763 (set-annotation-stripped! parent763 new764)) (set-car! new764 (strip-annotation615 (car x762) #f)) (set-cdr! new764 (strip-annotation615 (cdr x762) #f)) new764))) ((annotation? x762) (or (annotation-stripped x762) (strip-annotation615 (annotation-expression x762) x762))) ((vector? x762) (let ((new765 (make-vector (vector-length x762)))) (begin (if parent763 (set-annotation-stripped! parent763 new765)) (letrec ((loop766 (lambda (i767) (unless (fx<532 i767 0) (vector-set! new765 i767 (strip-annotation615 (vector-ref x762 i767) #f)) (loop766 (fx-530 i767 1)))))) (loop766 (- (vector-length x762) 1))) new765))) (else x762)))) (ellipsis?614 (lambda (x768) (and (nonsymbol-id?568 x768) (free-id=?592 x768 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void613 (lambda () (build-application537 #f (build-primref546 #f (quote if)) (quote (#f #f))))) (eval-local-transformer612 (lambda (expanded769 mod770) (let ((p771 (local-eval-hook534 expanded769 mod770))) (if (procedure? p771) p771 (syntax-violation #f "nonprocedure transformer" p771))))) (chi-local-syntax611 (lambda (rec?772 e773 r774 w775 s776 mod777 k778) ((lambda (tmp779) ((lambda (tmp780) (if tmp780 (apply (lambda (_781 id782 val783 e1784 e2785) (let ((ids786 id782)) (if (not (valid-bound-ids?594 ids786)) (syntax-violation #f "duplicate bound keyword" e773) (let ((labels788 (gen-labels575 ids786))) (let ((new-w789 (make-binding-wrap586 ids786 labels788 w775))) (k778 (cons e1784 e2785) (extend-env563 labels788 (let ((w791 (if rec?772 new-w789 w775)) (trans-r792 (macros-only-env565 r774))) (map (lambda (x793) (cons (quote macro) (eval-local-transformer612 (chi605 x793 trans-r792 w791 mod777) mod777))) val783)) r774) new-w789 s776 mod777)))))) tmp780) ((lambda (_795) (syntax-violation #f "bad local syntax definition" (source-wrap598 e773 w775 s776 mod777))) tmp779))) ($sc-dispatch tmp779 (quote (any #(each (any any)) any . each-any))))) e773))) (chi-lambda-clause610 (lambda (e796 docstring797 c798 r799 w800 mod801 k802) ((lambda (tmp803) ((lambda (tmp804) (if (if tmp804 (apply (lambda (args805 doc806 e1807 e2808) (and (string? (syntax->datum doc806)) (not docstring797))) tmp804) #f) (apply (lambda (args809 doc810 e1811 e2812) (chi-lambda-clause610 e796 doc810 (cons args809 (cons e1811 e2812)) r799 w800 mod801 k802)) tmp804) ((lambda (tmp814) (if tmp814 (apply (lambda (id815 e1816 e2817) (let ((ids818 id815)) (if (not (valid-bound-ids?594 ids818)) (syntax-violation (quote lambda) "invalid parameter list" e796) (let ((labels820 (gen-labels575 ids818)) (new-vars821 (map gen-var617 ids818))) (k802 (map syntax->datum ids818) new-vars821 docstring797 (chi-body609 (cons e1816 e2817) e796 (extend-var-env564 labels820 new-vars821 r799) (make-binding-wrap586 ids818 labels820 w800) mod801)))))) tmp814) ((lambda (tmp823) (if tmp823 (apply (lambda (ids824 e1825 e2826) (let ((old-ids827 (lambda-var-list618 ids824))) (if (not (valid-bound-ids?594 old-ids827)) (syntax-violation (quote lambda) "invalid parameter list" e796) (let ((labels828 (gen-labels575 old-ids827)) (new-vars829 (map gen-var617 old-ids827))) (k802 (letrec ((f830 (lambda (ls1831 ls2832) (if (null? ls1831) (syntax->datum ls2832) (f830 (cdr ls1831) (cons (syntax->datum (car ls1831)) ls2832)))))) (f830 (cdr old-ids827) (car old-ids827))) (letrec ((f833 (lambda (ls1834 ls2835) (if (null? ls1834) ls2835 (f833 (cdr ls1834) (cons (car ls1834) ls2835)))))) (f833 (cdr new-vars829) (car new-vars829))) docstring797 (chi-body609 (cons e1825 e2826) e796 (extend-var-env564 labels828 new-vars829 r799) (make-binding-wrap586 old-ids827 labels828 w800) mod801)))))) tmp823) ((lambda (_837) (syntax-violation (quote lambda) "bad lambda" e796)) tmp803))) ($sc-dispatch tmp803 (quote (any any . each-any)))))) ($sc-dispatch tmp803 (quote (each-any any . each-any)))))) ($sc-dispatch tmp803 (quote (any any any . each-any))))) c798))) (chi-body609 (lambda (body838 outer-form839 r840 w841 mod842) (let ((r843 (cons (quote ("placeholder" placeholder)) r840))) (let ((ribcage844 (make-ribcage576 (quote ()) (quote ()) (quote ())))) (let ((w845 (make-wrap571 (wrap-marks572 w841) (cons ribcage844 (wrap-subst573 w841))))) (letrec ((parse846 (lambda (body847 ids848 labels849 vars850 vals851 bindings852) (if (null? body847) (syntax-violation #f "no expressions in body" outer-form839) (let ((e854 (cdar body847)) (er855 (caar body847))) (call-with-values (lambda () (syntax-type603 e854 er855 (quote (())) #f ribcage844 mod842)) (lambda (type856 value857 e858 w859 s860 mod861) (let ((t862 type856)) (if (memv t862 (quote (define-form))) (let ((id863 (wrap597 value857 w859 mod861)) (label864 (gen-label574))) (let ((var865 (gen-var617 id863))) (begin (extend-ribcage!585 ribcage844 id863 label864) (parse846 (cdr body847) (cons id863 ids848) (cons label864 labels849) (cons var865 vars850) (cons (cons er855 (wrap597 e858 w859 mod861)) vals851) (cons (cons (quote lexical) var865) bindings852))))) (if (memv t862 (quote (define-syntax-form))) (let ((id866 (wrap597 value857 w859 mod861)) (label867 (gen-label574))) (begin (extend-ribcage!585 ribcage844 id866 label867) (parse846 (cdr body847) (cons id866 ids848) (cons label867 labels849) vars850 vals851 (cons (cons (quote macro) (cons er855 (wrap597 e858 w859 mod861))) bindings852)))) (if (memv t862 (quote (begin-form))) ((lambda (tmp868) ((lambda (tmp869) (if tmp869 (apply (lambda (_870 e1871) (parse846 (letrec ((f872 (lambda (forms873) (if (null? forms873) (cdr body847) (cons (cons er855 (wrap597 (car forms873) w859 mod861)) (f872 (cdr forms873))))))) (f872 e1871)) ids848 labels849 vars850 vals851 bindings852)) tmp869) (syntax-violation #f "source expression failed to match any pattern" tmp868))) ($sc-dispatch tmp868 (quote (any . each-any))))) e858) (if (memv t862 (quote (local-syntax-form))) (chi-local-syntax611 value857 e858 er855 w859 s860 mod861 (lambda (forms875 er876 w877 s878 mod879) (parse846 (letrec ((f880 (lambda (forms881) (if (null? forms881) (cdr body847) (cons (cons er876 (wrap597 (car forms881) w877 mod879)) (f880 (cdr forms881))))))) (f880 forms875)) ids848 labels849 vars850 vals851 bindings852))) (if (null? ids848) (build-sequence548 #f (map (lambda (x882) (chi605 (cdr x882) (car x882) (quote (())) mod861)) (cons (cons er855 (source-wrap598 e858 w859 s860 mod861)) (cdr body847)))) (begin (if (not (valid-bound-ids?594 ids848)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form839)) (letrec ((loop883 (lambda (bs884 er-cache885 r-cache886) (if (not (null? bs884)) (let ((b887 (car bs884))) (if (eq? (car b887) (quote macro)) (let ((er888 (cadr b887))) (let ((r-cache889 (if (eq? er888 er-cache885) r-cache886 (macros-only-env565 er888)))) (begin (set-cdr! b887 (eval-local-transformer612 (chi605 (cddr b887) r-cache889 (quote (())) mod861) mod861)) (loop883 (cdr bs884) er888 r-cache889)))) (loop883 (cdr bs884) er-cache885 r-cache886))))))) (loop883 bindings852 #f #f)) (set-cdr! r843 (extend-env563 labels849 bindings852 (cdr r843))) (build-letrec551 #f (map syntax->datum ids848) vars850 (map (lambda (x890) (chi605 (cdr x890) (car x890) (quote (())) mod861)) vals851) (build-sequence548 #f (map (lambda (x891) (chi605 (cdr x891) (car x891) (quote (())) mod861)) (cons (cons er855 (source-wrap598 e858 w859 s860 mod861)) (cdr body847))))))))))))))))))) (parse846 (map (lambda (x853) (cons r843 (wrap597 x853 w845 mod842))) body838) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro608 (lambda (p892 e893 r894 w895 rib896 mod897) (letrec ((rebuild-macro-output898 (lambda (x899 m900) (cond ((pair? x899) (cons (rebuild-macro-output898 (car x899) m900) (rebuild-macro-output898 (cdr x899) m900))) ((syntax-object?553 x899) (let ((w901 (syntax-object-wrap555 x899))) (let ((ms902 (wrap-marks572 w901)) (s903 (wrap-subst573 w901))) (if (and (pair? ms902) (eq? (car ms902) #f)) (make-syntax-object552 (syntax-object-expression554 x899) (make-wrap571 (cdr ms902) (if rib896 (cons rib896 (cdr s903)) (cdr s903))) (syntax-object-module556 x899)) (make-syntax-object552 (syntax-object-expression554 x899) (make-wrap571 (cons m900 ms902) (if rib896 (cons rib896 (cons (quote shift) s903)) (cons (quote shift) s903))) (let ((pmod904 (procedure-module p892))) (if pmod904 (cons (quote hygiene) (module-name pmod904)) (quote (hygiene guile))))))))) ((vector? x899) (let ((n905 (vector-length x899))) (let ((v906 (make-vector n905))) (letrec ((doloop907 (lambda (i908) (if (fx=531 i908 n905) v906 (begin (vector-set! v906 i908 (rebuild-macro-output898 (vector-ref x899 i908) m900)) (doloop907 (fx+529 i908 1))))))) (doloop907 0))))) ((symbol? x899) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap598 e893 w895 s mod897) x899)) (else x899))))) (rebuild-macro-output898 (p892 (wrap597 e893 (anti-mark584 w895) mod897)) (string #\m))))) (chi-application607 (lambda (x909 e910 r911 w912 s913 mod914) ((lambda (tmp915) ((lambda (tmp916) (if tmp916 (apply (lambda (e0917 e1918) (build-application537 s913 x909 (map (lambda (e919) (chi605 e919 r911 w912 mod914)) e1918))) tmp916) (syntax-violation #f "source expression failed to match any pattern" tmp915))) ($sc-dispatch tmp915 (quote (any . each-any))))) e910))) (chi-expr606 (lambda (type921 value922 e923 r924 w925 s926 mod927) (let ((t928 type921)) (if (memv t928 (quote (lexical))) (build-lexical-reference539 (quote value) s926 e923 value922) (if (memv t928 (quote (core external-macro))) (value922 e923 r924 w925 s926 mod927) (if (memv t928 (quote (module-ref))) (call-with-values (lambda () (value922 e923)) (lambda (id929 mod930) (build-global-reference542 s926 id929 mod930))) (if (memv t928 (quote (lexical-call))) (chi-application607 (build-lexical-reference539 (quote fun) (source-annotation560 (car e923)) (car e923) value922) e923 r924 w925 s926 mod927) (if (memv t928 (quote (global-call))) (chi-application607 (build-global-reference542 (source-annotation560 (car e923)) value922 (if (syntax-object?553 (car e923)) (syntax-object-module556 (car e923)) mod927)) e923 r924 w925 s926 mod927) (if (memv t928 (quote (constant))) (build-data547 s926 (strip616 (source-wrap598 e923 w925 s926 mod927) (quote (())))) (if (memv t928 (quote (global))) (build-global-reference542 s926 value922 mod927) (if (memv t928 (quote (call))) (chi-application607 (chi605 (car e923) r924 w925 mod927) e923 r924 w925 s926 mod927) (if (memv t928 (quote (begin-form))) ((lambda (tmp931) ((lambda (tmp932) (if tmp932 (apply (lambda (_933 e1934 e2935) (chi-sequence599 (cons e1934 e2935) r924 w925 s926 mod927)) tmp932) (syntax-violation #f "source expression failed to match any pattern" tmp931))) ($sc-dispatch tmp931 (quote (any any . each-any))))) e923) (if (memv t928 (quote (local-syntax-form))) (chi-local-syntax611 value922 e923 r924 w925 s926 mod927 chi-sequence599) (if (memv t928 (quote (eval-when-form))) ((lambda (tmp937) ((lambda (tmp938) (if tmp938 (apply (lambda (_939 x940 e1941 e2942) (let ((when-list943 (chi-when-list602 e923 x940 w925))) (if (memq (quote eval) when-list943) (chi-sequence599 (cons e1941 e2942) r924 w925 s926 mod927) (chi-void613)))) tmp938) (syntax-violation #f "source expression failed to match any pattern" tmp937))) ($sc-dispatch tmp937 (quote (any each-any any . each-any))))) e923) (if (memv t928 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e923 (wrap597 value922 w925 mod927)) (if (memv t928 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap598 e923 w925 s926 mod927)) (if (memv t928 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap598 e923 w925 s926 mod927)) (syntax-violation #f "unexpected syntax" (source-wrap598 e923 w925 s926 mod927))))))))))))))))))) (chi605 (lambda (e946 r947 w948 mod949) (call-with-values (lambda () (syntax-type603 e946 r947 w948 #f #f mod949)) (lambda (type950 value951 e952 w953 s954 mod955) (chi-expr606 type950 value951 e952 r947 w953 s954 mod955))))) (chi-top604 (lambda (e956 r957 w958 m959 esew960 mod961) (call-with-values (lambda () (syntax-type603 e956 r957 w958 #f #f mod961)) (lambda (type969 value970 e971 w972 s973 mod974) (let ((t975 type969)) (if (memv t975 (quote (begin-form))) ((lambda (tmp976) ((lambda (tmp977) (if tmp977 (apply (lambda (_978) (chi-void613)) tmp977) ((lambda (tmp979) (if tmp979 (apply (lambda (_980 e1981 e2982) (chi-top-sequence600 (cons e1981 e2982) r957 w972 s973 m959 esew960 mod974)) tmp979) (syntax-violation #f "source expression failed to match any pattern" tmp976))) ($sc-dispatch tmp976 (quote (any any . each-any)))))) ($sc-dispatch tmp976 (quote (any))))) e971) (if (memv t975 (quote (local-syntax-form))) (chi-local-syntax611 value970 e971 r957 w972 s973 mod974 (lambda (body984 r985 w986 s987 mod988) (chi-top-sequence600 body984 r985 w986 s987 m959 esew960 mod988))) (if (memv t975 (quote (eval-when-form))) ((lambda (tmp989) ((lambda (tmp990) (if tmp990 (apply (lambda (_991 x992 e1993 e2994) (let ((when-list995 (chi-when-list602 e971 x992 w972)) (body996 (cons e1993 e2994))) (cond ((eq? m959 (quote e)) (if (memq (quote eval) when-list995) (chi-top-sequence600 body996 r957 w972 s973 (quote e) (quote (eval)) mod974) (chi-void613))) ((memq (quote load) when-list995) (if (or (memq (quote compile) when-list995) (and (eq? m959 (quote c&e)) (memq (quote eval) when-list995))) (chi-top-sequence600 body996 r957 w972 s973 (quote c&e) (quote (compile load)) mod974) (if (memq m959 (quote (c c&e))) (chi-top-sequence600 body996 r957 w972 s973 (quote c) (quote (load)) mod974) (chi-void613)))) ((or (memq (quote compile) when-list995) (and (eq? m959 (quote c&e)) (memq (quote eval) when-list995))) (top-level-eval-hook533 (chi-top-sequence600 body996 r957 w972 s973 (quote e) (quote (eval)) mod974) mod974) (chi-void613)) (else (chi-void613))))) tmp990) (syntax-violation #f "source expression failed to match any pattern" tmp989))) ($sc-dispatch tmp989 (quote (any each-any any . each-any))))) e971) (if (memv t975 (quote (define-syntax-form))) (let ((n999 (id-var-name591 value970 w972)) (r1000 (macros-only-env565 r957))) (let ((t1001 m959)) (if (memv t1001 (quote (c))) (if (memq (quote compile) esew960) (let ((e1002 (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)))) (begin (top-level-eval-hook533 e1002 mod974) (if (memq (quote load) esew960) e1002 (chi-void613)))) (if (memq (quote load) esew960) (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)) (chi-void613))) (if (memv t1001 (quote (c&e))) (let ((e1003 (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)))) (begin (top-level-eval-hook533 e1003 mod974) e1003)) (begin (if (memq (quote eval) esew960) (top-level-eval-hook533 (chi-install-global601 n999 (chi605 e971 r1000 w972 mod974)) mod974)) (chi-void613)))))) (if (memv t975 (quote (define-form))) (let ((n1004 (id-var-name591 value970 w972))) (let ((type1005 (binding-type561 (lookup566 n1004 r957 mod974)))) (let ((t1006 type1005)) (if (memv t1006 (quote (global core macro module-ref))) (let ((x1007 (build-global-definition544 s973 n1004 (chi605 e971 r957 w972 mod974)))) (begin (if (eq? m959 (quote c&e)) (top-level-eval-hook533 x1007 mod974)) x1007)) (if (memv t1006 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e971 (wrap597 value970 w972 mod974)) (syntax-violation #f "cannot define keyword at top level" e971 (wrap597 value970 w972 mod974))))))) (let ((x1008 (chi-expr606 type969 value970 e971 r957 w972 s973 mod974))) (begin (if (eq? m959 (quote c&e)) (top-level-eval-hook533 x1008 mod974)) x1008)))))))))))) (syntax-type603 (lambda (e1009 r1010 w1011 s1012 rib1013 mod1014) (cond ((symbol? e1009) (let ((n1015 (id-var-name591 e1009 w1011))) (let ((b1016 (lookup566 n1015 r1010 mod1014))) (let ((type1017 (binding-type561 b1016))) (let ((t1018 type1017)) (if (memv t1018 (quote (lexical))) (values type1017 (binding-value562 b1016) e1009 w1011 s1012 mod1014) (if (memv t1018 (quote (global))) (values type1017 n1015 e1009 w1011 s1012 mod1014) (if (memv t1018 (quote (macro))) (syntax-type603 (chi-macro608 (binding-value562 b1016) e1009 r1010 w1011 rib1013 mod1014) r1010 (quote (())) s1012 rib1013 mod1014) (values type1017 (binding-value562 b1016) e1009 w1011 s1012 mod1014))))))))) ((pair? e1009) (let ((first1019 (car e1009))) (if (id?569 first1019) (let ((n1020 (id-var-name591 first1019 w1011))) (let ((b1021 (lookup566 n1020 r1010 (or (and (syntax-object?553 first1019) (syntax-object-module556 first1019)) mod1014)))) (let ((type1022 (binding-type561 b1021))) (let ((t1023 type1022)) (if (memv t1023 (quote (lexical))) (values (quote lexical-call) (binding-value562 b1021) e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (global))) (values (quote global-call) n1020 e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (macro))) (syntax-type603 (chi-macro608 (binding-value562 b1021) e1009 r1010 w1011 rib1013 mod1014) r1010 (quote (())) s1012 rib1013 mod1014) (if (memv t1023 (quote (core external-macro module-ref))) (values type1022 (binding-value562 b1021) e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value562 b1021) e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (begin))) (values (quote begin-form) #f e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (eval-when))) (values (quote eval-when-form) #f e1009 w1011 s1012 mod1014) (if (memv t1023 (quote (define))) ((lambda (tmp1024) ((lambda (tmp1025) (if (if tmp1025 (apply (lambda (_1026 name1027 val1028) (id?569 name1027)) tmp1025) #f) (apply (lambda (_1029 name1030 val1031) (values (quote define-form) name1030 val1031 w1011 s1012 mod1014)) tmp1025) ((lambda (tmp1032) (if (if tmp1032 (apply (lambda (_1033 name1034 args1035 e11036 e21037) (and (id?569 name1034) (valid-bound-ids?594 (lambda-var-list618 args1035)))) tmp1032) #f) (apply (lambda (_1038 name1039 args1040 e11041 e21042) (values (quote define-form) (wrap597 name1039 w1011 mod1014) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap597 (cons args1040 (cons e11041 e21042)) w1011 mod1014)) (quote (())) s1012 mod1014)) tmp1032) ((lambda (tmp1044) (if (if tmp1044 (apply (lambda (_1045 name1046) (id?569 name1046)) tmp1044) #f) (apply (lambda (_1047 name1048) (values (quote define-form) (wrap597 name1048 w1011 mod1014) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1012 mod1014)) tmp1044) (syntax-violation #f "source expression failed to match any pattern" tmp1024))) ($sc-dispatch tmp1024 (quote (any any)))))) ($sc-dispatch tmp1024 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1024 (quote (any any any))))) e1009) (if (memv t1023 (quote (define-syntax))) ((lambda (tmp1049) ((lambda (tmp1050) (if (if tmp1050 (apply (lambda (_1051 name1052 val1053) (id?569 name1052)) tmp1050) #f) (apply (lambda (_1054 name1055 val1056) (values (quote define-syntax-form) name1055 val1056 w1011 s1012 mod1014)) tmp1050) (syntax-violation #f "source expression failed to match any pattern" tmp1049))) ($sc-dispatch tmp1049 (quote (any any any))))) e1009) (values (quote call) #f e1009 w1011 s1012 mod1014)))))))))))))) (values (quote call) #f e1009 w1011 s1012 mod1014)))) ((syntax-object?553 e1009) (syntax-type603 (syntax-object-expression554 e1009) r1010 (join-wraps588 w1011 (syntax-object-wrap555 e1009)) #f rib1013 (or (syntax-object-module556 e1009) mod1014))) ((annotation? e1009) (syntax-type603 (annotation-expression e1009) r1010 w1011 (annotation-source e1009) rib1013 mod1014)) ((self-evaluating? e1009) (values (quote constant) #f e1009 w1011 s1012 mod1014)) (else (values (quote other) #f e1009 w1011 s1012 mod1014))))) (chi-when-list602 (lambda (e1057 when-list1058 w1059) (letrec ((f1060 (lambda (when-list1061 situations1062) (if (null? when-list1061) situations1062 (f1060 (cdr when-list1061) (cons (let ((x1063 (car when-list1061))) (cond ((free-id=?592 x1063 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?592 x1063 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?592 x1063 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1057 (wrap597 x1063 w1059 #f))))) situations1062)))))) (f1060 when-list1058 (quote ()))))) (chi-install-global601 (lambda (name1064 e1065) (build-global-definition544 #f name1064 (if (let ((v1066 (module-variable (current-module) name1064))) (and v1066 (variable-bound? v1066) (macro? (variable-ref v1066)) (not (eq? (macro-type (variable-ref v1066)) (quote syncase-macro))))) (build-application537 #f (build-primref546 #f (quote make-extended-syncase-macro)) (list (build-application537 #f (build-primref546 #f (quote module-ref)) (list (build-application537 #f (quote current-module) (quote ())) (build-data547 #f name1064))) (build-data547 #f (quote macro)) e1065)) (build-application537 #f (build-primref546 #f (quote make-syncase-macro)) (list (build-data547 #f (quote macro)) e1065)))))) (chi-top-sequence600 (lambda (body1067 r1068 w1069 s1070 m1071 esew1072 mod1073) (build-sequence548 s1070 (letrec ((dobody1074 (lambda (body1075 r1076 w1077 m1078 esew1079 mod1080) (if (null? body1075) (quote ()) (let ((first1081 (chi-top604 (car body1075) r1076 w1077 m1078 esew1079 mod1080))) (cons first1081 (dobody1074 (cdr body1075) r1076 w1077 m1078 esew1079 mod1080))))))) (dobody1074 body1067 r1068 w1069 m1071 esew1072 mod1073))))) (chi-sequence599 (lambda (body1082 r1083 w1084 s1085 mod1086) (build-sequence548 s1085 (letrec ((dobody1087 (lambda (body1088 r1089 w1090 mod1091) (if (null? body1088) (quote ()) (let ((first1092 (chi605 (car body1088) r1089 w1090 mod1091))) (cons first1092 (dobody1087 (cdr body1088) r1089 w1090 mod1091))))))) (dobody1087 body1082 r1083 w1084 mod1086))))) (source-wrap598 (lambda (x1093 w1094 s1095 defmod1096) (wrap597 (if s1095 (make-annotation x1093 s1095 #f) x1093) w1094 defmod1096))) (wrap597 (lambda (x1097 w1098 defmod1099) (cond ((and (null? (wrap-marks572 w1098)) (null? (wrap-subst573 w1098))) x1097) ((syntax-object?553 x1097) (make-syntax-object552 (syntax-object-expression554 x1097) (join-wraps588 w1098 (syntax-object-wrap555 x1097)) (syntax-object-module556 x1097))) ((null? x1097) x1097) (else (make-syntax-object552 x1097 w1098 defmod1099))))) (bound-id-member?596 (lambda (x1100 list1101) (and (not (null? list1101)) (or (bound-id=?593 x1100 (car list1101)) (bound-id-member?596 x1100 (cdr list1101)))))) (distinct-bound-ids?595 (lambda (ids1102) (letrec ((distinct?1103 (lambda (ids1104) (or (null? ids1104) (and (not (bound-id-member?596 (car ids1104) (cdr ids1104))) (distinct?1103 (cdr ids1104))))))) (distinct?1103 ids1102)))) (valid-bound-ids?594 (lambda (ids1105) (and (letrec ((all-ids?1106 (lambda (ids1107) (or (null? ids1107) (and (id?569 (car ids1107)) (all-ids?1106 (cdr ids1107))))))) (all-ids?1106 ids1105)) (distinct-bound-ids?595 ids1105)))) (bound-id=?593 (lambda (i1108 j1109) (if (and (syntax-object?553 i1108) (syntax-object?553 j1109)) (and (eq? (let ((e1110 (syntax-object-expression554 i1108))) (if (annotation? e1110) (annotation-expression e1110) e1110)) (let ((e1111 (syntax-object-expression554 j1109))) (if (annotation? e1111) (annotation-expression e1111) e1111))) (same-marks?590 (wrap-marks572 (syntax-object-wrap555 i1108)) (wrap-marks572 (syntax-object-wrap555 j1109)))) (eq? (let ((e1112 i1108)) (if (annotation? e1112) (annotation-expression e1112) e1112)) (let ((e1113 j1109)) (if (annotation? e1113) (annotation-expression e1113) e1113)))))) (free-id=?592 (lambda (i1114 j1115) (and (eq? (let ((x1116 i1114)) (let ((e1117 (if (syntax-object?553 x1116) (syntax-object-expression554 x1116) x1116))) (if (annotation? e1117) (annotation-expression e1117) e1117))) (let ((x1118 j1115)) (let ((e1119 (if (syntax-object?553 x1118) (syntax-object-expression554 x1118) x1118))) (if (annotation? e1119) (annotation-expression e1119) e1119)))) (eq? (id-var-name591 i1114 (quote (()))) (id-var-name591 j1115 (quote (()))))))) (id-var-name591 (lambda (id1120 w1121) (letrec ((search-vector-rib1124 (lambda (sym1130 subst1131 marks1132 symnames1133 ribcage1134) (let ((n1135 (vector-length symnames1133))) (letrec ((f1136 (lambda (i1137) (cond ((fx=531 i1137 n1135) (search1122 sym1130 (cdr subst1131) marks1132)) ((and (eq? (vector-ref symnames1133 i1137) sym1130) (same-marks?590 marks1132 (vector-ref (ribcage-marks579 ribcage1134) i1137))) (values (vector-ref (ribcage-labels580 ribcage1134) i1137) marks1132)) (else (f1136 (fx+529 i1137 1))))))) (f1136 0))))) (search-list-rib1123 (lambda (sym1138 subst1139 marks1140 symnames1141 ribcage1142) (letrec ((f1143 (lambda (symnames1144 i1145) (cond ((null? symnames1144) (search1122 sym1138 (cdr subst1139) marks1140)) ((and (eq? (car symnames1144) sym1138) (same-marks?590 marks1140 (list-ref (ribcage-marks579 ribcage1142) i1145))) (values (list-ref (ribcage-labels580 ribcage1142) i1145) marks1140)) (else (f1143 (cdr symnames1144) (fx+529 i1145 1))))))) (f1143 symnames1141 0)))) (search1122 (lambda (sym1146 subst1147 marks1148) (if (null? subst1147) (values #f marks1148) (let ((fst1149 (car subst1147))) (if (eq? fst1149 (quote shift)) (search1122 sym1146 (cdr subst1147) (cdr marks1148)) (let ((symnames1150 (ribcage-symnames578 fst1149))) (if (vector? symnames1150) (search-vector-rib1124 sym1146 subst1147 marks1148 symnames1150 fst1149) (search-list-rib1123 sym1146 subst1147 marks1148 symnames1150 fst1149))))))))) (cond ((symbol? id1120) (or (call-with-values (lambda () (search1122 id1120 (wrap-subst573 w1121) (wrap-marks572 w1121))) (lambda (x1152 . ignore1151) x1152)) id1120)) ((syntax-object?553 id1120) (let ((id1153 (let ((e1155 (syntax-object-expression554 id1120))) (if (annotation? e1155) (annotation-expression e1155) e1155))) (w11154 (syntax-object-wrap555 id1120))) (let ((marks1156 (join-marks589 (wrap-marks572 w1121) (wrap-marks572 w11154)))) (call-with-values (lambda () (search1122 id1153 (wrap-subst573 w1121) marks1156)) (lambda (new-id1157 marks1158) (or new-id1157 (call-with-values (lambda () (search1122 id1153 (wrap-subst573 w11154) marks1158)) (lambda (x1160 . ignore1159) x1160)) id1153)))))) ((annotation? id1120) (let ((id1161 (let ((e1162 id1120)) (if (annotation? e1162) (annotation-expression e1162) e1162)))) (or (call-with-values (lambda () (search1122 id1161 (wrap-subst573 w1121) (wrap-marks572 w1121))) (lambda (x1164 . ignore1163) x1164)) id1161))) (else (syntax-violation (quote id-var-name) "invalid id" id1120)))))) (same-marks?590 (lambda (x1165 y1166) (or (eq? x1165 y1166) (and (not (null? x1165)) (not (null? y1166)) (eq? (car x1165) (car y1166)) (same-marks?590 (cdr x1165) (cdr y1166)))))) (join-marks589 (lambda (m11167 m21168) (smart-append587 m11167 m21168))) (join-wraps588 (lambda (w11169 w21170) (let ((m11171 (wrap-marks572 w11169)) (s11172 (wrap-subst573 w11169))) (if (null? m11171) (if (null? s11172) w21170 (make-wrap571 (wrap-marks572 w21170) (smart-append587 s11172 (wrap-subst573 w21170)))) (make-wrap571 (smart-append587 m11171 (wrap-marks572 w21170)) (smart-append587 s11172 (wrap-subst573 w21170))))))) (smart-append587 (lambda (m11173 m21174) (if (null? m21174) m11173 (append m11173 m21174)))) (make-binding-wrap586 (lambda (ids1175 labels1176 w1177) (if (null? ids1175) w1177 (make-wrap571 (wrap-marks572 w1177) (cons (let ((labelvec1178 (list->vector labels1176))) (let ((n1179 (vector-length labelvec1178))) (let ((symnamevec1180 (make-vector n1179)) (marksvec1181 (make-vector n1179))) (begin (letrec ((f1182 (lambda (ids1183 i1184) (if (not (null? ids1183)) (call-with-values (lambda () (id-sym-name&marks570 (car ids1183) w1177)) (lambda (symname1185 marks1186) (begin (vector-set! symnamevec1180 i1184 symname1185) (vector-set! marksvec1181 i1184 marks1186) (f1182 (cdr ids1183) (fx+529 i1184 1))))))))) (f1182 ids1175 0)) (make-ribcage576 symnamevec1180 marksvec1181 labelvec1178))))) (wrap-subst573 w1177)))))) (extend-ribcage!585 (lambda (ribcage1187 id1188 label1189) (begin (set-ribcage-symnames!581 ribcage1187 (cons (let ((e1190 (syntax-object-expression554 id1188))) (if (annotation? e1190) (annotation-expression e1190) e1190)) (ribcage-symnames578 ribcage1187))) (set-ribcage-marks!582 ribcage1187 (cons (wrap-marks572 (syntax-object-wrap555 id1188)) (ribcage-marks579 ribcage1187))) (set-ribcage-labels!583 ribcage1187 (cons label1189 (ribcage-labels580 ribcage1187)))))) (anti-mark584 (lambda (w1191) (make-wrap571 (cons #f (wrap-marks572 w1191)) (cons (quote shift) (wrap-subst573 w1191))))) (set-ribcage-labels!583 (lambda (x1192 update1193) (vector-set! x1192 3 update1193))) (set-ribcage-marks!582 (lambda (x1194 update1195) (vector-set! x1194 2 update1195))) (set-ribcage-symnames!581 (lambda (x1196 update1197) (vector-set! x1196 1 update1197))) (ribcage-labels580 (lambda (x1198) (vector-ref x1198 3))) (ribcage-marks579 (lambda (x1199) (vector-ref x1199 2))) (ribcage-symnames578 (lambda (x1200) (vector-ref x1200 1))) (ribcage?577 (lambda (x1201) (and (vector? x1201) (= (vector-length x1201) 4) (eq? (vector-ref x1201 0) (quote ribcage))))) (make-ribcage576 (lambda (symnames1202 marks1203 labels1204) (vector (quote ribcage) symnames1202 marks1203 labels1204))) (gen-labels575 (lambda (ls1205) (if (null? ls1205) (quote ()) (cons (gen-label574) (gen-labels575 (cdr ls1205)))))) (gen-label574 (lambda () (string #\i))) (wrap-subst573 cdr) (wrap-marks572 car) (make-wrap571 cons) (id-sym-name&marks570 (lambda (x1206 w1207) (if (syntax-object?553 x1206) (values (let ((e1208 (syntax-object-expression554 x1206))) (if (annotation? e1208) (annotation-expression e1208) e1208)) (join-marks589 (wrap-marks572 w1207) (wrap-marks572 (syntax-object-wrap555 x1206)))) (values (let ((e1209 x1206)) (if (annotation? e1209) (annotation-expression e1209) e1209)) (wrap-marks572 w1207))))) (id?569 (lambda (x1210) (cond ((symbol? x1210) #t) ((syntax-object?553 x1210) (symbol? (let ((e1211 (syntax-object-expression554 x1210))) (if (annotation? e1211) (annotation-expression e1211) e1211)))) ((annotation? x1210) (symbol? (annotation-expression x1210))) (else #f)))) (nonsymbol-id?568 (lambda (x1212) (and (syntax-object?553 x1212) (symbol? (let ((e1213 (syntax-object-expression554 x1212))) (if (annotation? e1213) (annotation-expression e1213) e1213)))))) (global-extend567 (lambda (type1214 sym1215 val1216) (put-global-definition-hook535 sym1215 type1214 val1216))) (lookup566 (lambda (x1217 r1218 mod1219) (cond ((assq x1217 r1218) => cdr) ((symbol? x1217) (or (get-global-definition-hook536 x1217 mod1219) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env565 (lambda (r1220) (if (null? r1220) (quote ()) (let ((a1221 (car r1220))) (if (eq? (cadr a1221) (quote macro)) (cons a1221 (macros-only-env565 (cdr r1220))) (macros-only-env565 (cdr r1220))))))) (extend-var-env564 (lambda (labels1222 vars1223 r1224) (if (null? labels1222) r1224 (extend-var-env564 (cdr labels1222) (cdr vars1223) (cons (cons (car labels1222) (cons (quote lexical) (car vars1223))) r1224))))) (extend-env563 (lambda (labels1225 bindings1226 r1227) (if (null? labels1225) r1227 (extend-env563 (cdr labels1225) (cdr bindings1226) (cons (cons (car labels1225) (car bindings1226)) r1227))))) (binding-value562 cdr) (binding-type561 car) (source-annotation560 (lambda (x1228) (cond ((annotation? x1228) (annotation-source x1228)) ((syntax-object?553 x1228) (source-annotation560 (syntax-object-expression554 x1228))) (else #f)))) (set-syntax-object-module!559 (lambda (x1229 update1230) (vector-set! x1229 3 update1230))) (set-syntax-object-wrap!558 (lambda (x1231 update1232) (vector-set! x1231 2 update1232))) (set-syntax-object-expression!557 (lambda (x1233 update1234) (vector-set! x1233 1 update1234))) (syntax-object-module556 (lambda (x1235) (vector-ref x1235 3))) (syntax-object-wrap555 (lambda (x1236) (vector-ref x1236 2))) (syntax-object-expression554 (lambda (x1237) (vector-ref x1237 1))) (syntax-object?553 (lambda (x1238) (and (vector? x1238) (= (vector-length x1238) 4) (eq? (vector-ref x1238 0) (quote syntax-object))))) (make-syntax-object552 (lambda (expression1239 wrap1240 module1241) (vector (quote syntax-object) expression1239 wrap1240 module1241))) (build-letrec551 (lambda (src1242 ids1243 vars1244 val-exps1245 body-exp1246) (if (null? vars1244) body-exp1246 (let ((t1247 (fluid-ref *mode*528))) (if (memv t1247 (quote (c))) ((@ (language tree-il) make-letrec) src1242 ids1243 vars1244 val-exps1245 body-exp1246) (list (quote letrec) (map list vars1244 val-exps1245) body-exp1246)))))) (build-named-let550 (lambda (src1248 ids1249 vars1250 val-exps1251 body-exp1252) (let ((f1253 (car vars1250)) (f-name1254 (car ids1249)) (vars1255 (cdr vars1250)) (ids1256 (cdr ids1249))) (let ((t1257 (fluid-ref *mode*528))) (if (memv t1257 (quote (c))) ((@ (language tree-il) make-letrec) src1248 (list f-name1254) (list f1253) (list (build-lambda545 src1248 ids1256 vars1255 #f body-exp1252)) (build-application537 src1248 (build-lexical-reference539 (quote fun) src1248 f-name1254 f1253) val-exps1251)) (list (quote let) f1253 (map list vars1255 val-exps1251) body-exp1252)))))) (build-let549 (lambda (src1258 ids1259 vars1260 val-exps1261 body-exp1262) (if (null? vars1260) body-exp1262 (let ((t1263 (fluid-ref *mode*528))) (if (memv t1263 (quote (c))) ((@ (language tree-il) make-let) src1258 ids1259 vars1260 val-exps1261 body-exp1262) (list (quote let) (map list vars1260 val-exps1261) body-exp1262)))))) (build-sequence548 (lambda (src1264 exps1265) (if (null? (cdr exps1265)) (car exps1265) (let ((t1266 (fluid-ref *mode*528))) (if (memv t1266 (quote (c))) ((@ (language tree-il) make-sequence) src1264 exps1265) (cons (quote begin) exps1265)))))) (build-data547 (lambda (src1267 exp1268) (let ((t1269 (fluid-ref *mode*528))) (if (memv t1269 (quote (c))) ((@ (language tree-il) make-const) src1267 exp1268) (if (and (self-evaluating? exp1268) (not (vector? exp1268))) exp1268 (list (quote quote) exp1268)))))) (build-primref546 (lambda (src1270 name1271) (let ((t1272 (fluid-ref *mode*528))) (if (memv t1272 (quote (c))) ((@ (language tree-il) make-primitive-ref) src1270 name1271) (build-global-reference542 src1270 name1271 (quote (hygiene guile))))))) (build-lambda545 (lambda (src1273 ids1274 vars1275 docstring1276 exp1277) (let ((t1278 (fluid-ref *mode*528))) (if (memv t1278 (quote (c))) ((@ (language tree-il) make-lambda) src1273 ids1274 vars1275 (if docstring1276 (list (cons (quote documentation) docstring1276)) (quote ())) exp1277) (cons (quote lambda) (cons vars1275 (append (if docstring1276 (list docstring1276) (quote ())) (list exp1277)))))))) (build-global-definition544 (lambda (source1279 var1280 exp1281) (let ((t1282 (fluid-ref *mode*528))) (if (memv t1282 (quote (c))) ((@ (language tree-il) make-toplevel-define) source1279 var1280 exp1281) (list (quote define) var1280 exp1281))))) (build-global-assignment543 (lambda (source1283 var1284 exp1285 mod1286) (analyze-variable541 mod1286 var1284 (lambda (mod1287 var1288 public?1289) (let ((t1290 (fluid-ref *mode*528))) (if (memv t1290 (quote (c))) ((@ (language tree-il) make-module-set) source1283 mod1287 var1288 public?1289 exp1285) (list (quote set!) (list (if public?1289 (quote @) (quote @@)) mod1287 var1288) exp1285)))) (lambda (var1291) (let ((t1292 (fluid-ref *mode*528))) (if (memv t1292 (quote (c))) ((@ (language tree-il) make-toplevel-set) source1283 var1291 exp1285) (list (quote set!) var1291 exp1285))))))) (build-global-reference542 (lambda (source1293 var1294 mod1295) (analyze-variable541 mod1295 var1294 (lambda (mod1296 var1297 public?1298) (let ((t1299 (fluid-ref *mode*528))) (if (memv t1299 (quote (c))) ((@ (language tree-il) make-module-ref) source1293 mod1296 var1297 public?1298) (list (if public?1298 (quote @) (quote @@)) mod1296 var1297)))) (lambda (var1300) (let ((t1301 (fluid-ref *mode*528))) (if (memv t1301 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source1293 var1300) var1300)))))) (analyze-variable541 (lambda (mod1302 var1303 modref-cont1304 bare-cont1305) (if (not mod1302) (bare-cont1305 var1303) (let ((kind1306 (car mod1302)) (mod1307 (cdr mod1302))) (let ((t1308 kind1306)) (if (memv t1308 (quote (public))) (modref-cont1304 mod1307 var1303 #t) (if (memv t1308 (quote (private))) (if (not (equal? mod1307 (module-name (current-module)))) (modref-cont1304 mod1307 var1303 #f) (bare-cont1305 var1303)) (if (memv t1308 (quote (bare))) (bare-cont1305 var1303) (if (memv t1308 (quote (hygiene))) (if (and (not (equal? mod1307 (module-name (current-module)))) (module-variable (resolve-module mod1307) var1303)) (modref-cont1304 mod1307 var1303 #f) (bare-cont1305 var1303)) (syntax-violation #f "bad module kind" var1303 mod1307)))))))))) (build-lexical-assignment540 (lambda (source1309 name1310 var1311 exp1312) (let ((t1313 (fluid-ref *mode*528))) (if (memv t1313 (quote (c))) ((@ (language tree-il) make-lexical-set) source1309 name1310 var1311 exp1312) (list (quote set!) var1311 exp1312))))) (build-lexical-reference539 (lambda (type1314 source1315 name1316 var1317) (let ((t1318 (fluid-ref *mode*528))) (if (memv t1318 (quote (c))) ((@ (language tree-il) make-lexical-ref) source1315 name1316 var1317) var1317)))) (build-conditional538 (lambda (source1319 test-exp1320 then-exp1321 else-exp1322) (let ((t1323 (fluid-ref *mode*528))) (if (memv t1323 (quote (c))) ((@ (language tree-il) make-conditional) source1319 test-exp1320 then-exp1321 else-exp1322) (list (quote if) test-exp1320 then-exp1321 else-exp1322))))) (build-application537 (lambda (source1324 fun-exp1325 arg-exps1326) (let ((t1327 (fluid-ref *mode*528))) (if (memv t1327 (quote (c))) ((@ (language tree-il) make-application) source1324 fun-exp1325 arg-exps1326) (cons fun-exp1325 arg-exps1326))))) (get-global-definition-hook536 (lambda (symbol1328 module1329) (begin (if (and (not module1329) (current-module)) (warn "module system is booted, we should have a module" symbol1328)) (let ((v1330 (module-variable (if module1329 (resolve-module (cdr module1329)) (current-module)) symbol1328))) (and v1330 (variable-bound? v1330) (let ((val1331 (variable-ref v1330))) (and (macro? val1331) (syncase-macro-type val1331) (cons (syncase-macro-type val1331) (syncase-macro-binding val1331))))))))) (put-global-definition-hook535 (lambda (symbol1332 type1333 val1334) (let ((existing1335 (let ((v1336 (module-variable (current-module) symbol1332))) (and v1336 (variable-bound? v1336) (let ((val1337 (variable-ref v1336))) (and (macro? val1337) (not (syncase-macro-type val1337)) val1337)))))) (module-define! (current-module) symbol1332 (if existing1335 (make-extended-syncase-macro existing1335 type1333 val1334) (make-syncase-macro type1333 val1334)))))) (local-eval-hook534 (lambda (x1338 mod1339) (primitive-eval (list noexpand527 (let ((t1340 (fluid-ref *mode*528))) (if (memv t1340 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1338) x1338)))))) (top-level-eval-hook533 (lambda (x1341 mod1342) (primitive-eval (list noexpand527 (let ((t1343 (fluid-ref *mode*528))) (if (memv t1343 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1341) x1341)))))) (fx<532 <) (fx=531 =) (fx-530 -) (fx+529 +) (*mode*528 (make-fluid)) (noexpand527 "noexpand")) (begin (global-extend567 (quote local-syntax) (quote letrec-syntax) #t) (global-extend567 (quote local-syntax) (quote let-syntax) #f) (global-extend567 (quote core) (quote fluid-let-syntax) (lambda (e1344 r1345 w1346 s1347 mod1348) ((lambda (tmp1349) ((lambda (tmp1350) (if (if tmp1350 (apply (lambda (_1351 var1352 val1353 e11354 e21355) (valid-bound-ids?594 var1352)) tmp1350) #f) (apply (lambda (_1357 var1358 val1359 e11360 e21361) (let ((names1362 (map (lambda (x1363) (id-var-name591 x1363 w1346)) var1358))) (begin (for-each (lambda (id1365 n1366) (let ((t1367 (binding-type561 (lookup566 n1366 r1345 mod1348)))) (if (memv t1367 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1344 (source-wrap598 id1365 w1346 s1347 mod1348))))) var1358 names1362) (chi-body609 (cons e11360 e21361) (source-wrap598 e1344 w1346 s1347 mod1348) (extend-env563 names1362 (let ((trans-r1370 (macros-only-env565 r1345))) (map (lambda (x1371) (cons (quote macro) (eval-local-transformer612 (chi605 x1371 trans-r1370 w1346 mod1348) mod1348))) val1359)) r1345) w1346 mod1348)))) tmp1350) ((lambda (_1373) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap598 e1344 w1346 s1347 mod1348))) tmp1349))) ($sc-dispatch tmp1349 (quote (any #(each (any any)) any . each-any))))) e1344))) (global-extend567 (quote core) (quote quote) (lambda (e1374 r1375 w1376 s1377 mod1378) ((lambda (tmp1379) ((lambda (tmp1380) (if tmp1380 (apply (lambda (_1381 e1382) (build-data547 s1377 (strip616 e1382 w1376))) tmp1380) ((lambda (_1383) (syntax-violation (quote quote) "bad syntax" (source-wrap598 e1374 w1376 s1377 mod1378))) tmp1379))) ($sc-dispatch tmp1379 (quote (any any))))) e1374))) (global-extend567 (quote core) (quote syntax) (letrec ((regen1391 (lambda (x1392) (let ((t1393 (car x1392))) (if (memv t1393 (quote (ref))) (build-lexical-reference539 (quote value) #f (cadr x1392) (cadr x1392)) (if (memv t1393 (quote (primitive))) (build-primref546 #f (cadr x1392)) (if (memv t1393 (quote (quote))) (build-data547 #f (cadr x1392)) (if (memv t1393 (quote (lambda))) (build-lambda545 #f (cadr x1392) (cadr x1392) #f (regen1391 (caddr x1392))) (if (memv t1393 (quote (map))) (let ((ls1394 (map regen1391 (cdr x1392)))) (build-application537 #f (build-primref546 #f (quote map)) ls1394)) (build-application537 #f (build-primref546 #f (car x1392)) (map regen1391 (cdr x1392))))))))))) (gen-vector1390 (lambda (x1395) (cond ((eq? (car x1395) (quote list)) (cons (quote vector) (cdr x1395))) ((eq? (car x1395) (quote quote)) (list (quote quote) (list->vector (cadr x1395)))) (else (list (quote list->vector) x1395))))) (gen-append1389 (lambda (x1396 y1397) (if (equal? y1397 (quote (quote ()))) x1396 (list (quote append) x1396 y1397)))) (gen-cons1388 (lambda (x1398 y1399) (let ((t1400 (car y1399))) (if (memv t1400 (quote (quote))) (if (eq? (car x1398) (quote quote)) (list (quote quote) (cons (cadr x1398) (cadr y1399))) (if (eq? (cadr y1399) (quote ())) (list (quote list) x1398) (list (quote cons) x1398 y1399))) (if (memv t1400 (quote (list))) (cons (quote list) (cons x1398 (cdr y1399))) (list (quote cons) x1398 y1399)))))) (gen-map1387 (lambda (e1401 map-env1402) (let ((formals1403 (map cdr map-env1402)) (actuals1404 (map (lambda (x1405) (list (quote ref) (car x1405))) map-env1402))) (cond ((eq? (car e1401) (quote ref)) (car actuals1404)) ((and-map (lambda (x1406) (and (eq? (car x1406) (quote ref)) (memq (cadr x1406) formals1403))) (cdr e1401)) (cons (quote map) (cons (list (quote primitive) (car e1401)) (map (let ((r1407 (map cons formals1403 actuals1404))) (lambda (x1408) (cdr (assq (cadr x1408) r1407)))) (cdr e1401))))) (else (cons (quote map) (cons (list (quote lambda) formals1403 e1401) actuals1404))))))) (gen-mappend1386 (lambda (e1409 map-env1410) (list (quote apply) (quote (primitive append)) (gen-map1387 e1409 map-env1410)))) (gen-ref1385 (lambda (src1411 var1412 level1413 maps1414) (if (fx=531 level1413 0) (values var1412 maps1414) (if (null? maps1414) (syntax-violation (quote syntax) "missing ellipsis" src1411) (call-with-values (lambda () (gen-ref1385 src1411 var1412 (fx-530 level1413 1) (cdr maps1414))) (lambda (outer-var1415 outer-maps1416) (let ((b1417 (assq outer-var1415 (car maps1414)))) (if b1417 (values (cdr b1417) maps1414) (let ((inner-var1418 (gen-var617 (quote tmp)))) (values inner-var1418 (cons (cons (cons outer-var1415 inner-var1418) (car maps1414)) outer-maps1416))))))))))) (gen-syntax1384 (lambda (src1419 e1420 r1421 maps1422 ellipsis?1423 mod1424) (if (id?569 e1420) (let ((label1425 (id-var-name591 e1420 (quote (()))))) (let ((b1426 (lookup566 label1425 r1421 mod1424))) (if (eq? (binding-type561 b1426) (quote syntax)) (call-with-values (lambda () (let ((var.lev1427 (binding-value562 b1426))) (gen-ref1385 src1419 (car var.lev1427) (cdr var.lev1427) maps1422))) (lambda (var1428 maps1429) (values (list (quote ref) var1428) maps1429))) (if (ellipsis?1423 e1420) (syntax-violation (quote syntax) "misplaced ellipsis" src1419) (values (list (quote quote) e1420) maps1422))))) ((lambda (tmp1430) ((lambda (tmp1431) (if (if tmp1431 (apply (lambda (dots1432 e1433) (ellipsis?1423 dots1432)) tmp1431) #f) (apply (lambda (dots1434 e1435) (gen-syntax1384 src1419 e1435 r1421 maps1422 (lambda (x1436) #f) mod1424)) tmp1431) ((lambda (tmp1437) (if (if tmp1437 (apply (lambda (x1438 dots1439 y1440) (ellipsis?1423 dots1439)) tmp1437) #f) (apply (lambda (x1441 dots1442 y1443) (letrec ((f1444 (lambda (y1445 k1446) ((lambda (tmp1450) ((lambda (tmp1451) (if (if tmp1451 (apply (lambda (dots1452 y1453) (ellipsis?1423 dots1452)) tmp1451) #f) (apply (lambda (dots1454 y1455) (f1444 y1455 (lambda (maps1456) (call-with-values (lambda () (k1446 (cons (quote ()) maps1456))) (lambda (x1457 maps1458) (if (null? (car maps1458)) (syntax-violation (quote syntax) "extra ellipsis" src1419) (values (gen-mappend1386 x1457 (car maps1458)) (cdr maps1458)))))))) tmp1451) ((lambda (_1459) (call-with-values (lambda () (gen-syntax1384 src1419 y1445 r1421 maps1422 ellipsis?1423 mod1424)) (lambda (y1460 maps1461) (call-with-values (lambda () (k1446 maps1461)) (lambda (x1462 maps1463) (values (gen-append1389 x1462 y1460) maps1463)))))) tmp1450))) ($sc-dispatch tmp1450 (quote (any . any))))) y1445)))) (f1444 y1443 (lambda (maps1447) (call-with-values (lambda () (gen-syntax1384 src1419 x1441 r1421 (cons (quote ()) maps1447) ellipsis?1423 mod1424)) (lambda (x1448 maps1449) (if (null? (car maps1449)) (syntax-violation (quote syntax) "extra ellipsis" src1419) (values (gen-map1387 x1448 (car maps1449)) (cdr maps1449))))))))) tmp1437) ((lambda (tmp1464) (if tmp1464 (apply (lambda (x1465 y1466) (call-with-values (lambda () (gen-syntax1384 src1419 x1465 r1421 maps1422 ellipsis?1423 mod1424)) (lambda (x1467 maps1468) (call-with-values (lambda () (gen-syntax1384 src1419 y1466 r1421 maps1468 ellipsis?1423 mod1424)) (lambda (y1469 maps1470) (values (gen-cons1388 x1467 y1469) maps1470)))))) tmp1464) ((lambda (tmp1471) (if tmp1471 (apply (lambda (e11472 e21473) (call-with-values (lambda () (gen-syntax1384 src1419 (cons e11472 e21473) r1421 maps1422 ellipsis?1423 mod1424)) (lambda (e1475 maps1476) (values (gen-vector1390 e1475) maps1476)))) tmp1471) ((lambda (_1477) (values (list (quote quote) e1420) maps1422)) tmp1430))) ($sc-dispatch tmp1430 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1430 (quote (any . any)))))) ($sc-dispatch tmp1430 (quote (any any . any)))))) ($sc-dispatch tmp1430 (quote (any any))))) e1420))))) (lambda (e1478 r1479 w1480 s1481 mod1482) (let ((e1483 (source-wrap598 e1478 w1480 s1481 mod1482))) ((lambda (tmp1484) ((lambda (tmp1485) (if tmp1485 (apply (lambda (_1486 x1487) (call-with-values (lambda () (gen-syntax1384 e1483 x1487 r1479 (quote ()) ellipsis?614 mod1482)) (lambda (e1488 maps1489) (regen1391 e1488)))) tmp1485) ((lambda (_1490) (syntax-violation (quote syntax) "bad `syntax' form" e1483)) tmp1484))) ($sc-dispatch tmp1484 (quote (any any))))) e1483))))) (global-extend567 (quote core) (quote lambda) (lambda (e1491 r1492 w1493 s1494 mod1495) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (_1498 c1499) (chi-lambda-clause610 (source-wrap598 e1491 w1493 s1494 mod1495) #f c1499 r1492 w1493 mod1495 (lambda (names1500 vars1501 docstring1502 body1503) (build-lambda545 s1494 names1500 vars1501 docstring1502 body1503)))) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any . any))))) e1491))) (global-extend567 (quote core) (quote let) (letrec ((chi-let1504 (lambda (e1505 r1506 w1507 s1508 mod1509 constructor1510 ids1511 vals1512 exps1513) (if (not (valid-bound-ids?594 ids1511)) (syntax-violation (quote let) "duplicate bound variable" e1505) (let ((labels1514 (gen-labels575 ids1511)) (new-vars1515 (map gen-var617 ids1511))) (let ((nw1516 (make-binding-wrap586 ids1511 labels1514 w1507)) (nr1517 (extend-var-env564 labels1514 new-vars1515 r1506))) (constructor1510 s1508 (map syntax->datum ids1511) new-vars1515 (map (lambda (x1518) (chi605 x1518 r1506 w1507 mod1509)) vals1512) (chi-body609 exps1513 (source-wrap598 e1505 nw1516 s1508 mod1509) nr1517 nw1516 mod1509)))))))) (lambda (e1519 r1520 w1521 s1522 mod1523) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 id1527 val1528 e11529 e21530) (chi-let1504 e1519 r1520 w1521 s1522 mod1523 build-let549 id1527 val1528 (cons e11529 e21530))) tmp1525) ((lambda (tmp1534) (if (if tmp1534 (apply (lambda (_1535 f1536 id1537 val1538 e11539 e21540) (id?569 f1536)) tmp1534) #f) (apply (lambda (_1541 f1542 id1543 val1544 e11545 e21546) (chi-let1504 e1519 r1520 w1521 s1522 mod1523 build-named-let550 (cons f1542 id1543) val1544 (cons e11545 e21546))) tmp1534) ((lambda (_1550) (syntax-violation (quote let) "bad let" (source-wrap598 e1519 w1521 s1522 mod1523))) tmp1524))) ($sc-dispatch tmp1524 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1524 (quote (any #(each (any any)) any . each-any))))) e1519)))) (global-extend567 (quote core) (quote letrec) (lambda (e1551 r1552 w1553 s1554 mod1555) ((lambda (tmp1556) ((lambda (tmp1557) (if tmp1557 (apply (lambda (_1558 id1559 val1560 e11561 e21562) (let ((ids1563 id1559)) (if (not (valid-bound-ids?594 ids1563)) (syntax-violation (quote letrec) "duplicate bound variable" e1551) (let ((labels1565 (gen-labels575 ids1563)) (new-vars1566 (map gen-var617 ids1563))) (let ((w1567 (make-binding-wrap586 ids1563 labels1565 w1553)) (r1568 (extend-var-env564 labels1565 new-vars1566 r1552))) (build-letrec551 s1554 (map syntax->datum ids1563) new-vars1566 (map (lambda (x1569) (chi605 x1569 r1568 w1567 mod1555)) val1560) (chi-body609 (cons e11561 e21562) (source-wrap598 e1551 w1567 s1554 mod1555) r1568 w1567 mod1555))))))) tmp1557) ((lambda (_1572) (syntax-violation (quote letrec) "bad letrec" (source-wrap598 e1551 w1553 s1554 mod1555))) tmp1556))) ($sc-dispatch tmp1556 (quote (any #(each (any any)) any . each-any))))) e1551))) (global-extend567 (quote core) (quote set!) (lambda (e1573 r1574 w1575 s1576 mod1577) ((lambda (tmp1578) ((lambda (tmp1579) (if (if tmp1579 (apply (lambda (_1580 id1581 val1582) (id?569 id1581)) tmp1579) #f) (apply (lambda (_1583 id1584 val1585) (let ((val1586 (chi605 val1585 r1574 w1575 mod1577)) (n1587 (id-var-name591 id1584 w1575))) (let ((b1588 (lookup566 n1587 r1574 mod1577))) (let ((t1589 (binding-type561 b1588))) (if (memv t1589 (quote (lexical))) (build-lexical-assignment540 s1576 (syntax->datum id1584) (binding-value562 b1588) val1586) (if (memv t1589 (quote (global))) (build-global-assignment543 s1576 n1587 val1586 mod1577) (if (memv t1589 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap597 id1584 w1575 mod1577)) (syntax-violation (quote set!) "bad set!" (source-wrap598 e1573 w1575 s1576 mod1577))))))))) tmp1579) ((lambda (tmp1590) (if tmp1590 (apply (lambda (_1591 head1592 tail1593 val1594) (call-with-values (lambda () (syntax-type603 head1592 r1574 (quote (())) #f #f mod1577)) (lambda (type1595 value1596 ee1597 ww1598 ss1599 modmod1600) (let ((t1601 type1595)) (if (memv t1601 (quote (module-ref))) (let ((val1602 (chi605 val1594 r1574 w1575 mod1577))) (call-with-values (lambda () (value1596 (cons head1592 tail1593))) (lambda (id1604 mod1605) (build-global-assignment543 s1576 id1604 val1602 mod1605)))) (build-application537 s1576 (chi605 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1592) r1574 w1575 mod1577) (map (lambda (e1606) (chi605 e1606 r1574 w1575 mod1577)) (append tail1593 (list val1594))))))))) tmp1590) ((lambda (_1608) (syntax-violation (quote set!) "bad set!" (source-wrap598 e1573 w1575 s1576 mod1577))) tmp1578))) ($sc-dispatch tmp1578 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1578 (quote (any any any))))) e1573))) (global-extend567 (quote module-ref) (quote @) (lambda (e1609) ((lambda (tmp1610) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 mod1613 id1614) (and (and-map id?569 mod1613) (id?569 id1614))) tmp1611) #f) (apply (lambda (_1616 mod1617 id1618) (values (syntax->datum id1618) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1617)))) tmp1611) (syntax-violation #f "source expression failed to match any pattern" tmp1610))) ($sc-dispatch tmp1610 (quote (any each-any any))))) e1609))) (global-extend567 (quote module-ref) (quote @@) (lambda (e1620) ((lambda (tmp1621) ((lambda (tmp1622) (if (if tmp1622 (apply (lambda (_1623 mod1624 id1625) (and (and-map id?569 mod1624) (id?569 id1625))) tmp1622) #f) (apply (lambda (_1627 mod1628 id1629) (values (syntax->datum id1629) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1628)))) tmp1622) (syntax-violation #f "source expression failed to match any pattern" tmp1621))) ($sc-dispatch tmp1621 (quote (any each-any any))))) e1620))) (global-extend567 (quote begin) (quote begin) (quote ())) (global-extend567 (quote define) (quote define) (quote ())) (global-extend567 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend567 (quote eval-when) (quote eval-when) (quote ())) (global-extend567 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1634 (lambda (x1635 keys1636 clauses1637 r1638 mod1639) (if (null? clauses1637) (build-application537 #f (build-primref546 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1635)) ((lambda (tmp1640) ((lambda (tmp1641) (if tmp1641 (apply (lambda (pat1642 exp1643) (if (and (id?569 pat1642) (and-map (lambda (x1644) (not (free-id=?592 pat1642 x1644))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1636))) (let ((labels1645 (list (gen-label574))) (var1646 (gen-var617 pat1642))) (build-application537 #f (build-lambda545 #f (list (syntax->datum pat1642)) (list var1646) #f (chi605 exp1643 (extend-env563 labels1645 (list (cons (quote syntax) (cons var1646 0))) r1638) (make-binding-wrap586 (list pat1642) labels1645 (quote (()))) mod1639)) (list x1635))) (gen-clause1633 x1635 keys1636 (cdr clauses1637) r1638 pat1642 #t exp1643 mod1639))) tmp1641) ((lambda (tmp1647) (if tmp1647 (apply (lambda (pat1648 fender1649 exp1650) (gen-clause1633 x1635 keys1636 (cdr clauses1637) r1638 pat1648 fender1649 exp1650 mod1639)) tmp1647) ((lambda (_1651) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1637))) tmp1640))) ($sc-dispatch tmp1640 (quote (any any any)))))) ($sc-dispatch tmp1640 (quote (any any))))) (car clauses1637))))) (gen-clause1633 (lambda (x1652 keys1653 clauses1654 r1655 pat1656 fender1657 exp1658 mod1659) (call-with-values (lambda () (convert-pattern1631 pat1656 keys1653)) (lambda (p1660 pvars1661) (cond ((not (distinct-bound-ids?595 (map car pvars1661))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1656)) ((not (and-map (lambda (x1662) (not (ellipsis?614 (car x1662)))) pvars1661)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1656)) (else (let ((y1663 (gen-var617 (quote tmp)))) (build-application537 #f (build-lambda545 #f (list (quote tmp)) (list y1663) #f (let ((y1664 (build-lexical-reference539 (quote value) #f (quote tmp) y1663))) (build-conditional538 #f ((lambda (tmp1665) ((lambda (tmp1666) (if tmp1666 (apply (lambda () y1664) tmp1666) ((lambda (_1667) (build-conditional538 #f y1664 (build-dispatch-call1632 pvars1661 fender1657 y1664 r1655 mod1659) (build-data547 #f #f))) tmp1665))) ($sc-dispatch tmp1665 (quote #(atom #t))))) fender1657) (build-dispatch-call1632 pvars1661 exp1658 y1664 r1655 mod1659) (gen-syntax-case1634 x1652 keys1653 clauses1654 r1655 mod1659)))) (list (if (eq? p1660 (quote any)) (build-application537 #f (build-primref546 #f (quote list)) (list x1652)) (build-application537 #f (build-primref546 #f (quote $sc-dispatch)) (list x1652 (build-data547 #f p1660))))))))))))) (build-dispatch-call1632 (lambda (pvars1668 exp1669 y1670 r1671 mod1672) (let ((ids1673 (map car pvars1668)) (levels1674 (map cdr pvars1668))) (let ((labels1675 (gen-labels575 ids1673)) (new-vars1676 (map gen-var617 ids1673))) (build-application537 #f (build-primref546 #f (quote apply)) (list (build-lambda545 #f (map syntax->datum ids1673) new-vars1676 #f (chi605 exp1669 (extend-env563 labels1675 (map (lambda (var1677 level1678) (cons (quote syntax) (cons var1677 level1678))) new-vars1676 (map cdr pvars1668)) r1671) (make-binding-wrap586 ids1673 labels1675 (quote (()))) mod1672)) y1670)))))) (convert-pattern1631 (lambda (pattern1679 keys1680) (letrec ((cvt1681 (lambda (p1682 n1683 ids1684) (if (id?569 p1682) (if (bound-id-member?596 p1682 keys1680) (values (vector (quote free-id) p1682) ids1684) (values (quote any) (cons (cons p1682 n1683) ids1684))) ((lambda (tmp1685) ((lambda (tmp1686) (if (if tmp1686 (apply (lambda (x1687 dots1688) (ellipsis?614 dots1688)) tmp1686) #f) (apply (lambda (x1689 dots1690) (call-with-values (lambda () (cvt1681 x1689 (fx+529 n1683 1) ids1684)) (lambda (p1691 ids1692) (values (if (eq? p1691 (quote any)) (quote each-any) (vector (quote each) p1691)) ids1692)))) tmp1686) ((lambda (tmp1693) (if tmp1693 (apply (lambda (x1694 y1695) (call-with-values (lambda () (cvt1681 y1695 n1683 ids1684)) (lambda (y1696 ids1697) (call-with-values (lambda () (cvt1681 x1694 n1683 ids1697)) (lambda (x1698 ids1699) (values (cons x1698 y1696) ids1699)))))) tmp1693) ((lambda (tmp1700) (if tmp1700 (apply (lambda () (values (quote ()) ids1684)) tmp1700) ((lambda (tmp1701) (if tmp1701 (apply (lambda (x1702) (call-with-values (lambda () (cvt1681 x1702 n1683 ids1684)) (lambda (p1704 ids1705) (values (vector (quote vector) p1704) ids1705)))) tmp1701) ((lambda (x1706) (values (vector (quote atom) (strip616 p1682 (quote (())))) ids1684)) tmp1685))) ($sc-dispatch tmp1685 (quote #(vector each-any)))))) ($sc-dispatch tmp1685 (quote ()))))) ($sc-dispatch tmp1685 (quote (any . any)))))) ($sc-dispatch tmp1685 (quote (any any))))) p1682))))) (cvt1681 pattern1679 0 (quote ())))))) (lambda (e1707 r1708 w1709 s1710 mod1711) (let ((e1712 (source-wrap598 e1707 w1709 s1710 mod1711))) ((lambda (tmp1713) ((lambda (tmp1714) (if tmp1714 (apply (lambda (_1715 val1716 key1717 m1718) (if (and-map (lambda (x1719) (and (id?569 x1719) (not (ellipsis?614 x1719)))) key1717) (let ((x1721 (gen-var617 (quote tmp)))) (build-application537 s1710 (build-lambda545 #f (list (quote tmp)) (list x1721) #f (gen-syntax-case1634 (build-lexical-reference539 (quote value) #f (quote tmp) x1721) key1717 m1718 r1708 mod1711)) (list (chi605 val1716 r1708 (quote (())) mod1711)))) (syntax-violation (quote syntax-case) "invalid literals list" e1712))) tmp1714) (syntax-violation #f "source expression failed to match any pattern" tmp1713))) ($sc-dispatch tmp1713 (quote (any any each-any . each-any))))) e1712))))) (set! sc-expand (lambda (x1725 . rest1724) (if (and (pair? x1725) (equal? (car x1725) noexpand527)) (cadr x1725) (let ((m1726 (if (null? rest1724) (quote e) (car rest1724))) (esew1727 (if (or (null? rest1724) (null? (cdr rest1724))) (quote (eval)) (cadr rest1724)))) (with-fluid* *mode*528 m1726 (lambda () (chi-top604 x1725 (quote ()) (quote ((top))) m1726 esew1727 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1728) (nonsymbol-id?568 x1728))) (set! datum->syntax (lambda (id1729 datum1730) (make-syntax-object552 datum1730 (syntax-object-wrap555 id1729) #f))) (set! syntax->datum (lambda (x1731) (strip616 x1731 (quote (()))))) (set! generate-temporaries (lambda (ls1732) (begin (let ((x1733 ls1732)) (if (not (list? x1733)) (syntax-violation (quote generate-temporaries) "invalid argument" x1733))) (map (lambda (x1734) (wrap597 (gensym) (quote ((top))) #f)) ls1732)))) (set! free-identifier=? (lambda (x1735 y1736) (begin (let ((x1737 x1735)) (if (not (nonsymbol-id?568 x1737)) (syntax-violation (quote free-identifier=?) "invalid argument" x1737))) (let ((x1738 y1736)) (if (not (nonsymbol-id?568 x1738)) (syntax-violation (quote free-identifier=?) "invalid argument" x1738))) (free-id=?592 x1735 y1736)))) (set! bound-identifier=? (lambda (x1739 y1740) (begin (let ((x1741 x1739)) (if (not (nonsymbol-id?568 x1741)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1741))) (let ((x1742 y1740)) (if (not (nonsymbol-id?568 x1742)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1742))) (bound-id=?593 x1739 y1740)))) (set! syntax-violation (lambda (who1746 message1745 form1744 . subform1743) (begin (let ((x1747 who1746)) (if (not ((lambda (x1748) (or (not x1748) (string? x1748) (symbol? x1748))) x1747)) (syntax-violation (quote syntax-violation) "invalid argument" x1747))) (let ((x1749 message1745)) (if (not (string? x1749)) (syntax-violation (quote syntax-violation) "invalid argument" x1749))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1746 "~a: " "") "~a " (if (null? subform1743) "in ~a" "in subform `~s' of `~s'")) (let ((tail1750 (cons message1745 (map (lambda (x1751) (strip616 x1751 (quote (())))) (append subform1743 (list form1744)))))) (if who1746 (cons who1746 tail1750) tail1750)) #f)))) (letrec ((match1756 (lambda (e1757 p1758 w1759 r1760 mod1761) (cond ((not r1760) #f) ((eq? p1758 (quote any)) (cons (wrap597 e1757 w1759 mod1761) r1760)) ((syntax-object?553 e1757) (match*1755 (let ((e1762 (syntax-object-expression554 e1757))) (if (annotation? e1762) (annotation-expression e1762) e1762)) p1758 (join-wraps588 w1759 (syntax-object-wrap555 e1757)) r1760 (syntax-object-module556 e1757))) (else (match*1755 (let ((e1763 e1757)) (if (annotation? e1763) (annotation-expression e1763) e1763)) p1758 w1759 r1760 mod1761))))) (match*1755 (lambda (e1764 p1765 w1766 r1767 mod1768) (cond ((null? p1765) (and (null? e1764) r1767)) ((pair? p1765) (and (pair? e1764) (match1756 (car e1764) (car p1765) w1766 (match1756 (cdr e1764) (cdr p1765) w1766 r1767 mod1768) mod1768))) ((eq? p1765 (quote each-any)) (let ((l1769 (match-each-any1753 e1764 w1766 mod1768))) (and l1769 (cons l1769 r1767)))) (else (let ((t1770 (vector-ref p1765 0))) (if (memv t1770 (quote (each))) (if (null? e1764) (match-empty1754 (vector-ref p1765 1) r1767) (let ((l1771 (match-each1752 e1764 (vector-ref p1765 1) w1766 mod1768))) (and l1771 (letrec ((collect1772 (lambda (l1773) (if (null? (car l1773)) r1767 (cons (map car l1773) (collect1772 (map cdr l1773))))))) (collect1772 l1771))))) (if (memv t1770 (quote (free-id))) (and (id?569 e1764) (free-id=?592 (wrap597 e1764 w1766 mod1768) (vector-ref p1765 1)) r1767) (if (memv t1770 (quote (atom))) (and (equal? (vector-ref p1765 1) (strip616 e1764 w1766)) r1767) (if (memv t1770 (quote (vector))) (and (vector? e1764) (match1756 (vector->list e1764) (vector-ref p1765 1) w1766 r1767 mod1768))))))))))) (match-empty1754 (lambda (p1774 r1775) (cond ((null? p1774) r1775) ((eq? p1774 (quote any)) (cons (quote ()) r1775)) ((pair? p1774) (match-empty1754 (car p1774) (match-empty1754 (cdr p1774) r1775))) ((eq? p1774 (quote each-any)) (cons (quote ()) r1775)) (else (let ((t1776 (vector-ref p1774 0))) (if (memv t1776 (quote (each))) (match-empty1754 (vector-ref p1774 1) r1775) (if (memv t1776 (quote (free-id atom))) r1775 (if (memv t1776 (quote (vector))) (match-empty1754 (vector-ref p1774 1) r1775))))))))) (match-each-any1753 (lambda (e1777 w1778 mod1779) (cond ((annotation? e1777) (match-each-any1753 (annotation-expression e1777) w1778 mod1779)) ((pair? e1777) (let ((l1780 (match-each-any1753 (cdr e1777) w1778 mod1779))) (and l1780 (cons (wrap597 (car e1777) w1778 mod1779) l1780)))) ((null? e1777) (quote ())) ((syntax-object?553 e1777) (match-each-any1753 (syntax-object-expression554 e1777) (join-wraps588 w1778 (syntax-object-wrap555 e1777)) mod1779)) (else #f)))) (match-each1752 (lambda (e1781 p1782 w1783 mod1784) (cond ((annotation? e1781) (match-each1752 (annotation-expression e1781) p1782 w1783 mod1784)) ((pair? e1781) (let ((first1785 (match1756 (car e1781) p1782 w1783 (quote ()) mod1784))) (and first1785 (let ((rest1786 (match-each1752 (cdr e1781) p1782 w1783 mod1784))) (and rest1786 (cons first1785 rest1786)))))) ((null? e1781) (quote ())) ((syntax-object?553 e1781) (match-each1752 (syntax-object-expression554 e1781) p1782 (join-wraps588 w1783 (syntax-object-wrap555 e1781)) (syntax-object-module556 e1781))) (else #f))))) (set! $sc-dispatch (lambda (e1787 p1788) (cond ((eq? p1788 (quote any)) (list e1787)) ((syntax-object?553 e1787) (match*1755 (let ((e1789 (syntax-object-expression554 e1787))) (if (annotation? e1789) (annotation-expression e1789) e1789)) p1788 (syntax-object-wrap555 e1787) (quote ()) (syntax-object-module556 e1787))) (else (match*1755 (let ((e1790 e1787)) (if (annotation? e1790) (annotation-expression e1790) e1790)) p1788 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1791) ((lambda (tmp1792) ((lambda (tmp1793) (if tmp1793 (apply (lambda (_1794 e11795 e21796) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11795 e21796))) tmp1793) ((lambda (tmp1798) (if tmp1798 (apply (lambda (_1799 out1800 in1801 e11802 e21803) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1801 (quote ()) (list out1800 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11802 e21803))))) tmp1798) ((lambda (tmp1805) (if tmp1805 (apply (lambda (_1806 out1807 in1808 e11809 e21810) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1808) (quote ()) (list out1807 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11809 e21810))))) tmp1805) (syntax-violation #f "source expression failed to match any pattern" tmp1792))) ($sc-dispatch tmp1792 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1792 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1792 (quote (any () any . each-any))))) x1791)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1814) ((lambda (tmp1815) ((lambda (tmp1816) (if tmp1816 (apply (lambda (_1817 k1818 keyword1819 pattern1820 template1821) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1818 (map (lambda (tmp1824 tmp1823) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1823) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1824))) template1821 pattern1820)))))) tmp1816) (syntax-violation #f "source expression failed to match any pattern" tmp1815))) ($sc-dispatch tmp1815 (quote (any each-any . #(each ((any . any) any))))))) x1814)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1825) ((lambda (tmp1826) ((lambda (tmp1827) (if (if tmp1827 (apply (lambda (let*1828 x1829 v1830 e11831 e21832) (and-map identifier? x1829)) tmp1827) #f) (apply (lambda (let*1834 x1835 v1836 e11837 e21838) (letrec ((f1839 (lambda (bindings1840) (if (null? bindings1840) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11837 e21838))) ((lambda (tmp1844) ((lambda (tmp1845) (if tmp1845 (apply (lambda (body1846 binding1847) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1847) body1846)) tmp1845) (syntax-violation #f "source expression failed to match any pattern" tmp1844))) ($sc-dispatch tmp1844 (quote (any any))))) (list (f1839 (cdr bindings1840)) (car bindings1840))))))) (f1839 (map list x1835 v1836)))) tmp1827) (syntax-violation #f "source expression failed to match any pattern" tmp1826))) ($sc-dispatch tmp1826 (quote (any #(each (any any)) any . each-any))))) x1825)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1848) ((lambda (tmp1849) ((lambda (tmp1850) (if tmp1850 (apply (lambda (_1851 var1852 init1853 step1854 e01855 e11856 c1857) ((lambda (tmp1858) ((lambda (tmp1859) (if tmp1859 (apply (lambda (step1860) ((lambda (tmp1861) ((lambda (tmp1862) (if tmp1862 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1852 init1853) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01855) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1857 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1860))))))) tmp1862) ((lambda (tmp1867) (if tmp1867 (apply (lambda (e11868 e21869) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1852 init1853) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01855 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11868 e21869)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1857 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1860))))))) tmp1867) (syntax-violation #f "source expression failed to match any pattern" tmp1861))) ($sc-dispatch tmp1861 (quote (any . each-any)))))) ($sc-dispatch tmp1861 (quote ())))) e11856)) tmp1859) (syntax-violation #f "source expression failed to match any pattern" tmp1858))) ($sc-dispatch tmp1858 (quote each-any)))) (map (lambda (v1876 s1877) ((lambda (tmp1878) ((lambda (tmp1879) (if tmp1879 (apply (lambda () v1876) tmp1879) ((lambda (tmp1880) (if tmp1880 (apply (lambda (e1881) e1881) tmp1880) ((lambda (_1882) (syntax-violation (quote do) "bad step expression" orig-x1848 s1877)) tmp1878))) ($sc-dispatch tmp1878 (quote (any)))))) ($sc-dispatch tmp1878 (quote ())))) s1877)) var1852 step1854))) tmp1850) (syntax-violation #f "source expression failed to match any pattern" tmp1849))) ($sc-dispatch tmp1849 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1848)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1885 (lambda (x1889 y1890) ((lambda (tmp1891) ((lambda (tmp1892) (if tmp1892 (apply (lambda (x1893 y1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (dy1897) ((lambda (tmp1898) ((lambda (tmp1899) (if tmp1899 (apply (lambda (dx1900) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1900 dy1897))) tmp1899) ((lambda (_1901) (if (null? dy1897) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1893) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1893 y1894))) tmp1898))) ($sc-dispatch tmp1898 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1893)) tmp1896) ((lambda (tmp1902) (if tmp1902 (apply (lambda (stuff1903) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1893 stuff1903))) tmp1902) ((lambda (else1904) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1893 y1894)) tmp1895))) ($sc-dispatch tmp1895 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1895 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1894)) tmp1892) (syntax-violation #f "source expression failed to match any pattern" tmp1891))) ($sc-dispatch tmp1891 (quote (any any))))) (list x1889 y1890)))) (quasiappend1886 (lambda (x1905 y1906) ((lambda (tmp1907) ((lambda (tmp1908) (if tmp1908 (apply (lambda (x1909 y1910) ((lambda (tmp1911) ((lambda (tmp1912) (if tmp1912 (apply (lambda () x1909) tmp1912) ((lambda (_1913) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1909 y1910)) tmp1911))) ($sc-dispatch tmp1911 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1910)) tmp1908) (syntax-violation #f "source expression failed to match any pattern" tmp1907))) ($sc-dispatch tmp1907 (quote (any any))))) (list x1905 y1906)))) (quasivector1887 (lambda (x1914) ((lambda (tmp1915) ((lambda (x1916) ((lambda (tmp1917) ((lambda (tmp1918) (if tmp1918 (apply (lambda (x1919) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1919))) tmp1918) ((lambda (tmp1921) (if tmp1921 (apply (lambda (x1922) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1922)) tmp1921) ((lambda (_1924) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1916)) tmp1917))) ($sc-dispatch tmp1917 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1917 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1916)) tmp1915)) x1914))) (quasi1888 (lambda (p1925 lev1926) ((lambda (tmp1927) ((lambda (tmp1928) (if tmp1928 (apply (lambda (p1929) (if (= lev1926 0) p1929 (quasicons1885 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1888 (list p1929) (- lev1926 1))))) tmp1928) ((lambda (tmp1930) (if tmp1930 (apply (lambda (p1931 q1932) (if (= lev1926 0) (quasiappend1886 p1931 (quasi1888 q1932 lev1926)) (quasicons1885 (quasicons1885 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1888 (list p1931) (- lev1926 1))) (quasi1888 q1932 lev1926)))) tmp1930) ((lambda (tmp1933) (if tmp1933 (apply (lambda (p1934) (quasicons1885 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1888 (list p1934) (+ lev1926 1)))) tmp1933) ((lambda (tmp1935) (if tmp1935 (apply (lambda (p1936 q1937) (quasicons1885 (quasi1888 p1936 lev1926) (quasi1888 q1937 lev1926))) tmp1935) ((lambda (tmp1938) (if tmp1938 (apply (lambda (x1939) (quasivector1887 (quasi1888 x1939 lev1926))) tmp1938) ((lambda (p1941) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1941)) tmp1927))) ($sc-dispatch tmp1927 (quote #(vector each-any)))))) ($sc-dispatch tmp1927 (quote (any . any)))))) ($sc-dispatch tmp1927 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1927 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1927 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1925)))) (lambda (x1942) ((lambda (tmp1943) ((lambda (tmp1944) (if tmp1944 (apply (lambda (_1945 e1946) (quasi1888 e1946 0)) tmp1944) (syntax-violation #f "source expression failed to match any pattern" tmp1943))) ($sc-dispatch tmp1943 (quote (any any))))) x1942))))) -(define include (make-syncase-macro (quote macro) (lambda (x1947) (letrec ((read-file1948 (lambda (fn1949 k1950) (let ((p1951 (open-input-file fn1949))) (letrec ((f1952 (lambda (x1953) (if (eof-object? x1953) (begin (close-input-port p1951) (quote ())) (cons (datum->syntax k1950 x1953) (f1952 (read p1951))))))) (f1952 (read p1951))))))) ((lambda (tmp1954) ((lambda (tmp1955) (if tmp1955 (apply (lambda (k1956 filename1957) (let ((fn1958 (syntax->datum filename1957))) ((lambda (tmp1959) ((lambda (tmp1960) (if tmp1960 (apply (lambda (exp1961) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1961)) tmp1960) (syntax-violation #f "source expression failed to match any pattern" tmp1959))) ($sc-dispatch tmp1959 (quote each-any)))) (read-file1948 fn1958 k1956)))) tmp1955) (syntax-violation #f "source expression failed to match any pattern" tmp1954))) ($sc-dispatch tmp1954 (quote (any any))))) x1947))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1963) ((lambda (tmp1964) ((lambda (tmp1965) (if tmp1965 (apply (lambda (_1966 e1967) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1963)) tmp1965) (syntax-violation #f "source expression failed to match any pattern" tmp1964))) ($sc-dispatch tmp1964 (quote (any any))))) x1963)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1968) ((lambda (tmp1969) ((lambda (tmp1970) (if tmp1970 (apply (lambda (_1971 e1972) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1968)) tmp1970) (syntax-violation #f "source expression failed to match any pattern" tmp1969))) ($sc-dispatch tmp1969 (quote (any any))))) x1968)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1973) ((lambda (tmp1974) ((lambda (tmp1975) (if tmp1975 (apply (lambda (_1976 e1977 m11978 m21979) ((lambda (tmp1980) ((lambda (body1981) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1977)) body1981)) tmp1980)) (letrec ((f1982 (lambda (clause1983 clauses1984) (if (null? clauses1984) ((lambda (tmp1986) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11988 e21989))) tmp1987) ((lambda (tmp1991) (if tmp1991 (apply (lambda (k1992 e11993 e21994) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1992)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11993 e21994)))) tmp1991) ((lambda (_1997) (syntax-violation (quote case) "bad clause" x1973 clause1983)) tmp1986))) ($sc-dispatch tmp1986 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1986 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1983) ((lambda (tmp1998) ((lambda (rest1999) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (k2002 e12003 e22004) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2002)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12003 e22004)) rest1999)) tmp2001) ((lambda (_2007) (syntax-violation (quote case) "bad clause" x1973 clause1983)) tmp2000))) ($sc-dispatch tmp2000 (quote (each-any any . each-any))))) clause1983)) tmp1998)) (f1982 (car clauses1984) (cdr clauses1984))))))) (f1982 m11978 m21979)))) tmp1975) (syntax-violation #f "source expression failed to match any pattern" tmp1974))) ($sc-dispatch tmp1974 (quote (any any any . each-any))))) x1973)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2008) ((lambda (tmp2009) ((lambda (tmp2010) (if tmp2010 (apply (lambda (_2011 e2012) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2012)) (list (cons _2011 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2012 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2010) (syntax-violation #f "source expression failed to match any pattern" tmp2009))) ($sc-dispatch tmp2009 (quote (any any))))) x2008)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (letrec ((andmap58 (lambda (first59) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))))) (andmap58 first56)) (letrec ((andmap62 (lambda (first63 rest64) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68))))))) (andmap62 first56 rest55))))))) (letrec ((lambda-var-list160 (lambda (vars289) (letrec ((lvl290 (lambda (vars291 ls292 w293) (cond ((pair? vars291) (lvl290 (cdr vars291) (cons (wrap139 (car vars291) w293 #f) ls292) w293)) ((id?111 vars291) (cons (wrap139 vars291 w293 #f) ls292)) ((null? vars291) ls292) ((syntax-object?95 vars291) (lvl290 (syntax-object-expression96 vars291) ls292 (join-wraps130 w293 (syntax-object-wrap97 vars291)))) ((annotation? vars291) (lvl290 (annotation-expression vars291) ls292 w293)) (else (cons vars291 ls292)))))) (lvl290 vars289 (quote ()) (quote (())))))) (gen-var159 (lambda (id294) (let ((id295 (if (syntax-object?95 id294) (syntax-object-expression96 id294) id294))) (if (annotation? id295) (gensym (symbol->string (annotation-expression id295))) (gensym (symbol->string id295)))))) (strip158 (lambda (x296 w297) (if (memq (quote top) (wrap-marks114 w297)) (if (or (annotation? x296) (and (pair? x296) (annotation? (car x296)))) (strip-annotation157 x296 #f) x296) (letrec ((f298 (lambda (x299) (cond ((syntax-object?95 x299) (strip158 (syntax-object-expression96 x299) (syntax-object-wrap97 x299))) ((pair? x299) (let ((a300 (f298 (car x299))) (d301 (f298 (cdr x299)))) (if (and (eq? a300 (car x299)) (eq? d301 (cdr x299))) x299 (cons a300 d301)))) ((vector? x299) (let ((old302 (vector->list x299))) (let ((new303 (map f298 old302))) (if (and-map*17 eq? old302 new303) x299 (list->vector new303))))) (else x299))))) (f298 x296))))) (strip-annotation157 (lambda (x304 parent305) (cond ((pair? x304) (let ((new306 (cons #f #f))) (begin (if parent305 (set-annotation-stripped! parent305 new306)) (set-car! new306 (strip-annotation157 (car x304) #f)) (set-cdr! new306 (strip-annotation157 (cdr x304) #f)) new306))) ((annotation? x304) (or (annotation-stripped x304) (strip-annotation157 (annotation-expression x304) x304))) ((vector? x304) (let ((new307 (make-vector (vector-length x304)))) (begin (if parent305 (set-annotation-stripped! parent305 new307)) (letrec ((loop308 (lambda (i309) (unless (fx<74 i309 0) (vector-set! new307 i309 (strip-annotation157 (vector-ref x304 i309) #f)) (loop308 (fx-72 i309 1)))))) (loop308 (- (vector-length x304) 1))) new307))) (else x304)))) (ellipsis?156 (lambda (x310) (and (nonsymbol-id?110 x310) (free-id=?134 x310 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void155 (lambda () (build-application79 #f (build-primref88 #f (quote if)) (quote (#f #f))))) (eval-local-transformer154 (lambda (expanded311 mod312) (let ((p313 (local-eval-hook76 expanded311 mod312))) (if (procedure? p313) p313 (syntax-violation #f "nonprocedure transformer" p313))))) (chi-local-syntax153 (lambda (rec?314 e315 r316 w317 s318 mod319 k320) ((lambda (tmp321) ((lambda (tmp322) (if tmp322 (apply (lambda (_323 id324 val325 e1326 e2327) (let ((ids328 id324)) (if (not (valid-bound-ids?136 ids328)) (syntax-violation #f "duplicate bound keyword" e315) (let ((labels330 (gen-labels117 ids328))) (let ((new-w331 (make-binding-wrap128 ids328 labels330 w317))) (k320 (cons e1326 e2327) (extend-env105 labels330 (let ((w333 (if rec?314 new-w331 w317)) (trans-r334 (macros-only-env107 r316))) (map (lambda (x335) (cons (quote macro) (eval-local-transformer154 (chi147 x335 trans-r334 w333 mod319) mod319))) val325)) r316) new-w331 s318 mod319)))))) tmp322) ((lambda (_337) (syntax-violation #f "bad local syntax definition" (source-wrap140 e315 w317 s318 mod319))) tmp321))) ($sc-dispatch tmp321 (quote (any #(each (any any)) any . each-any))))) e315))) (chi-lambda-clause152 (lambda (e338 docstring339 c340 r341 w342 mod343 k344) ((lambda (tmp345) ((lambda (tmp346) (if (if tmp346 (apply (lambda (args347 doc348 e1349 e2350) (and (string? (syntax->datum doc348)) (not docstring339))) tmp346) #f) (apply (lambda (args351 doc352 e1353 e2354) (chi-lambda-clause152 e338 doc352 (cons args351 (cons e1353 e2354)) r341 w342 mod343 k344)) tmp346) ((lambda (tmp356) (if tmp356 (apply (lambda (id357 e1358 e2359) (let ((ids360 id357)) (if (not (valid-bound-ids?136 ids360)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels362 (gen-labels117 ids360)) (new-vars363 (map gen-var159 ids360))) (k344 (map syntax->datum ids360) new-vars363 docstring339 (chi-body151 (cons e1358 e2359) e338 (extend-var-env106 labels362 new-vars363 r341) (make-binding-wrap128 ids360 labels362 w342) mod343)))))) tmp356) ((lambda (tmp365) (if tmp365 (apply (lambda (ids366 e1367 e2368) (let ((old-ids369 (lambda-var-list160 ids366))) (if (not (valid-bound-ids?136 old-ids369)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels370 (gen-labels117 old-ids369)) (new-vars371 (map gen-var159 old-ids369))) (k344 (letrec ((f372 (lambda (ls1373 ls2374) (if (null? ls1373) (syntax->datum ls2374) (f372 (cdr ls1373) (cons (syntax->datum (car ls1373)) ls2374)))))) (f372 (cdr old-ids369) (car old-ids369))) (letrec ((f375 (lambda (ls1376 ls2377) (if (null? ls1376) ls2377 (f375 (cdr ls1376) (cons (car ls1376) ls2377)))))) (f375 (cdr new-vars371) (car new-vars371))) docstring339 (chi-body151 (cons e1367 e2368) e338 (extend-var-env106 labels370 new-vars371 r341) (make-binding-wrap128 old-ids369 labels370 w342) mod343)))))) tmp365) ((lambda (_379) (syntax-violation (quote lambda) "bad lambda" e338)) tmp345))) ($sc-dispatch tmp345 (quote (any any . each-any)))))) ($sc-dispatch tmp345 (quote (each-any any . each-any)))))) ($sc-dispatch tmp345 (quote (any any any . each-any))))) c340))) (chi-body151 (lambda (body380 outer-form381 r382 w383 mod384) (let ((r385 (cons (quote ("placeholder" placeholder)) r382))) (let ((ribcage386 (make-ribcage118 (quote ()) (quote ()) (quote ())))) (let ((w387 (make-wrap113 (wrap-marks114 w383) (cons ribcage386 (wrap-subst115 w383))))) (letrec ((parse388 (lambda (body389 ids390 labels391 vars392 vals393 bindings394) (if (null? body389) (syntax-violation #f "no expressions in body" outer-form381) (let ((e396 (cdar body389)) (er397 (caar body389))) (call-with-values (lambda () (syntax-type145 e396 er397 (quote (())) #f ribcage386 mod384)) (lambda (type398 value399 e400 w401 s402 mod403) (let ((t404 type398)) (if (memv t404 (quote (define-form))) (let ((id405 (wrap139 value399 w401 mod403)) (label406 (gen-label116))) (let ((var407 (gen-var159 id405))) (begin (extend-ribcage!127 ribcage386 id405 label406) (parse388 (cdr body389) (cons id405 ids390) (cons label406 labels391) (cons var407 vars392) (cons (cons er397 (wrap139 e400 w401 mod403)) vals393) (cons (cons (quote lexical) var407) bindings394))))) (if (memv t404 (quote (define-syntax-form))) (let ((id408 (wrap139 value399 w401 mod403)) (label409 (gen-label116))) (begin (extend-ribcage!127 ribcage386 id408 label409) (parse388 (cdr body389) (cons id408 ids390) (cons label409 labels391) vars392 vals393 (cons (cons (quote macro) (cons er397 (wrap139 e400 w401 mod403))) bindings394)))) (if (memv t404 (quote (begin-form))) ((lambda (tmp410) ((lambda (tmp411) (if tmp411 (apply (lambda (_412 e1413) (parse388 (letrec ((f414 (lambda (forms415) (if (null? forms415) (cdr body389) (cons (cons er397 (wrap139 (car forms415) w401 mod403)) (f414 (cdr forms415))))))) (f414 e1413)) ids390 labels391 vars392 vals393 bindings394)) tmp411) (syntax-violation #f "source expression failed to match any pattern" tmp410))) ($sc-dispatch tmp410 (quote (any . each-any))))) e400) (if (memv t404 (quote (local-syntax-form))) (chi-local-syntax153 value399 e400 er397 w401 s402 mod403 (lambda (forms417 er418 w419 s420 mod421) (parse388 (letrec ((f422 (lambda (forms423) (if (null? forms423) (cdr body389) (cons (cons er418 (wrap139 (car forms423) w419 mod421)) (f422 (cdr forms423))))))) (f422 forms417)) ids390 labels391 vars392 vals393 bindings394))) (if (null? ids390) (build-sequence90 #f (map (lambda (x424) (chi147 (cdr x424) (car x424) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389)))) (begin (if (not (valid-bound-ids?136 ids390)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form381)) (letrec ((loop425 (lambda (bs426 er-cache427 r-cache428) (if (not (null? bs426)) (let ((b429 (car bs426))) (if (eq? (car b429) (quote macro)) (let ((er430 (cadr b429))) (let ((r-cache431 (if (eq? er430 er-cache427) r-cache428 (macros-only-env107 er430)))) (begin (set-cdr! b429 (eval-local-transformer154 (chi147 (cddr b429) r-cache431 (quote (())) mod403) mod403)) (loop425 (cdr bs426) er430 r-cache431)))) (loop425 (cdr bs426) er-cache427 r-cache428))))))) (loop425 bindings394 #f #f)) (set-cdr! r385 (extend-env105 labels391 bindings394 (cdr r385))) (build-letrec93 #f (map syntax->datum ids390) vars392 (map (lambda (x432) (chi147 (cdr x432) (car x432) (quote (())) mod403)) vals393) (build-sequence90 #f (map (lambda (x433) (chi147 (cdr x433) (car x433) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389))))))))))))))))))) (parse388 (map (lambda (x395) (cons r385 (wrap139 x395 w387 mod384))) body380) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro150 (lambda (p434 e435 r436 w437 rib438 mod439) (letrec ((rebuild-macro-output440 (lambda (x441 m442) (cond ((pair? x441) (cons (rebuild-macro-output440 (car x441) m442) (rebuild-macro-output440 (cdr x441) m442))) ((syntax-object?95 x441) (let ((w443 (syntax-object-wrap97 x441))) (let ((ms444 (wrap-marks114 w443)) (s445 (wrap-subst115 w443))) (if (and (pair? ms444) (eq? (car ms444) #f)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cdr ms444) (if rib438 (cons rib438 (cdr s445)) (cdr s445))) (syntax-object-module98 x441)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cons m442 ms444) (if rib438 (cons rib438 (cons (quote shift) s445)) (cons (quote shift) s445))) (let ((pmod446 (procedure-module p434))) (if pmod446 (cons (quote hygiene) (module-name pmod446)) (quote (hygiene guile))))))))) ((vector? x441) (let ((n447 (vector-length x441))) (let ((v448 (make-vector n447))) (letrec ((doloop449 (lambda (i450) (if (fx=73 i450 n447) v448 (begin (vector-set! v448 i450 (rebuild-macro-output440 (vector-ref x441 i450) m442)) (doloop449 (fx+71 i450 1))))))) (doloop449 0))))) ((symbol? x441) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap140 e435 w437 s mod439) x441)) (else x441))))) (rebuild-macro-output440 (p434 (wrap139 e435 (anti-mark126 w437) mod439)) (string #\m))))) (chi-application149 (lambda (x451 e452 r453 w454 s455 mod456) ((lambda (tmp457) ((lambda (tmp458) (if tmp458 (apply (lambda (e0459 e1460) (build-application79 s455 x451 (map (lambda (e461) (chi147 e461 r453 w454 mod456)) e1460))) tmp458) (syntax-violation #f "source expression failed to match any pattern" tmp457))) ($sc-dispatch tmp457 (quote (any . each-any))))) e452))) (chi-expr148 (lambda (type463 value464 e465 r466 w467 s468 mod469) (let ((t470 type463)) (if (memv t470 (quote (lexical))) (build-lexical-reference81 (quote value) s468 e465 value464) (if (memv t470 (quote (core external-macro))) (value464 e465 r466 w467 s468 mod469) (if (memv t470 (quote (module-ref))) (call-with-values (lambda () (value464 e465)) (lambda (id471 mod472) (build-global-reference84 s468 id471 mod472))) (if (memv t470 (quote (lexical-call))) (chi-application149 (build-lexical-reference81 (quote fun) (source-annotation102 (car e465)) (car e465) value464) e465 r466 w467 s468 mod469) (if (memv t470 (quote (global-call))) (chi-application149 (build-global-reference84 (source-annotation102 (car e465)) value464 (if (syntax-object?95 (car e465)) (syntax-object-module98 (car e465)) mod469)) e465 r466 w467 s468 mod469) (if (memv t470 (quote (constant))) (build-data89 s468 (strip158 (source-wrap140 e465 w467 s468 mod469) (quote (())))) (if (memv t470 (quote (global))) (build-global-reference84 s468 value464 mod469) (if (memv t470 (quote (call))) (chi-application149 (chi147 (car e465) r466 w467 mod469) e465 r466 w467 s468 mod469) (if (memv t470 (quote (begin-form))) ((lambda (tmp473) ((lambda (tmp474) (if tmp474 (apply (lambda (_475 e1476 e2477) (chi-sequence141 (cons e1476 e2477) r466 w467 s468 mod469)) tmp474) (syntax-violation #f "source expression failed to match any pattern" tmp473))) ($sc-dispatch tmp473 (quote (any any . each-any))))) e465) (if (memv t470 (quote (local-syntax-form))) (chi-local-syntax153 value464 e465 r466 w467 s468 mod469 chi-sequence141) (if (memv t470 (quote (eval-when-form))) ((lambda (tmp479) ((lambda (tmp480) (if tmp480 (apply (lambda (_481 x482 e1483 e2484) (let ((when-list485 (chi-when-list144 e465 x482 w467))) (if (memq (quote eval) when-list485) (chi-sequence141 (cons e1483 e2484) r466 w467 s468 mod469) (chi-void155)))) tmp480) (syntax-violation #f "source expression failed to match any pattern" tmp479))) ($sc-dispatch tmp479 (quote (any each-any any . each-any))))) e465) (if (memv t470 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e465 (wrap139 value464 w467 mod469)) (if (memv t470 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap140 e465 w467 s468 mod469)) (if (memv t470 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap140 e465 w467 s468 mod469)) (syntax-violation #f "unexpected syntax" (source-wrap140 e465 w467 s468 mod469))))))))))))))))))) (chi147 (lambda (e488 r489 w490 mod491) (call-with-values (lambda () (syntax-type145 e488 r489 w490 #f #f mod491)) (lambda (type492 value493 e494 w495 s496 mod497) (chi-expr148 type492 value493 e494 r489 w495 s496 mod497))))) (chi-top146 (lambda (e498 r499 w500 m501 esew502 mod503) (call-with-values (lambda () (syntax-type145 e498 r499 w500 #f #f mod503)) (lambda (type511 value512 e513 w514 s515 mod516) (let ((t517 type511)) (if (memv t517 (quote (begin-form))) ((lambda (tmp518) ((lambda (tmp519) (if tmp519 (apply (lambda (_520) (chi-void155)) tmp519) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 e1523 e2524) (chi-top-sequence142 (cons e1523 e2524) r499 w514 s515 m501 esew502 mod516)) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp518))) ($sc-dispatch tmp518 (quote (any any . each-any)))))) ($sc-dispatch tmp518 (quote (any))))) e513) (if (memv t517 (quote (local-syntax-form))) (chi-local-syntax153 value512 e513 r499 w514 s515 mod516 (lambda (body526 r527 w528 s529 mod530) (chi-top-sequence142 body526 r527 w528 s529 m501 esew502 mod530))) (if (memv t517 (quote (eval-when-form))) ((lambda (tmp531) ((lambda (tmp532) (if tmp532 (apply (lambda (_533 x534 e1535 e2536) (let ((when-list537 (chi-when-list144 e513 x534 w514)) (body538 (cons e1535 e2536))) (cond ((eq? m501 (quote e)) (if (memq (quote eval) when-list537) (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) (chi-void155))) ((memq (quote load) when-list537) (if (or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (chi-top-sequence142 body538 r499 w514 s515 (quote c&e) (quote (compile load)) mod516) (if (memq m501 (quote (c c&e))) (chi-top-sequence142 body538 r499 w514 s515 (quote c) (quote (load)) mod516) (chi-void155)))) ((or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (top-level-eval-hook75 (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) mod516) (chi-void155)) (else (chi-void155))))) tmp532) (syntax-violation #f "source expression failed to match any pattern" tmp531))) ($sc-dispatch tmp531 (quote (any each-any any . each-any))))) e513) (if (memv t517 (quote (define-syntax-form))) (let ((n541 (id-var-name133 value512 w514)) (r542 (macros-only-env107 r499))) (let ((t543 m501)) (if (memv t543 (quote (c))) (if (memq (quote compile) esew502) (let ((e544 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e544 mod516) (if (memq (quote load) esew502) e544 (chi-void155)))) (if (memq (quote load) esew502) (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) (chi-void155))) (if (memv t543 (quote (c&e))) (let ((e545 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e545 mod516) e545)) (begin (if (memq (quote eval) esew502) (top-level-eval-hook75 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) mod516)) (chi-void155)))))) (if (memv t517 (quote (define-form))) (let ((n546 (id-var-name133 value512 w514))) (let ((type547 (binding-type103 (lookup108 n546 r499 mod516)))) (let ((t548 type547)) (if (memv t548 (quote (global core macro module-ref))) (let ((x549 (build-global-definition86 s515 n546 (chi147 e513 r499 w514 mod516)))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x549 mod516)) x549)) (if (memv t548 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e513 (wrap139 value512 w514 mod516)) (syntax-violation #f "cannot define keyword at top level" e513 (wrap139 value512 w514 mod516))))))) (let ((x550 (chi-expr148 type511 value512 e513 r499 w514 s515 mod516))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x550 mod516)) x550)))))))))))) (syntax-type145 (lambda (e551 r552 w553 s554 rib555 mod556) (cond ((symbol? e551) (let ((n557 (id-var-name133 e551 w553))) (let ((b558 (lookup108 n557 r552 mod556))) (let ((type559 (binding-type103 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value104 b558) e551 w553 s554 mod556) (if (memv t560 (quote (global))) (values type559 n557 e551 w553 s554 mod556) (if (memv t560 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b558) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (values type559 (binding-value104 b558) e551 w553 s554 mod556))))))))) ((pair? e551) (let ((first561 (car e551))) (if (id?111 first561) (let ((n562 (id-var-name133 first561 w553))) (let ((b563 (lookup108 n562 r552 (or (and (syntax-object?95 first561) (syntax-object-module98 first561)) mod556)))) (let ((type564 (binding-type103 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (global))) (values (quote global-call) n562 e551 w553 s554 mod556) (if (memv t565 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b563) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (if (memv t565 (quote (core external-macro module-ref))) (values type564 (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (begin))) (values (quote begin-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?111 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w553 s554 mod556)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?111 name576) (valid-bound-ids?136 (lambda-var-list160 args577)))) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap139 name581 w553 mod556) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap139 (cons args582 (cons e1583 e2584)) w553 mod556)) (quote (())) s554 mod556)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?111 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap139 name590 w553 mod556) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s554 mod556)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e551) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?111 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w553 s554 mod556)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e551) (values (quote call) #f e551 w553 s554 mod556)))))))))))))) (values (quote call) #f e551 w553 s554 mod556)))) ((syntax-object?95 e551) (syntax-type145 (syntax-object-expression96 e551) r552 (join-wraps130 w553 (syntax-object-wrap97 e551)) #f rib555 (or (syntax-object-module98 e551) mod556))) ((annotation? e551) (syntax-type145 (annotation-expression e551) r552 w553 (annotation-source e551) rib555 mod556)) ((self-evaluating? e551) (values (quote constant) #f e551 w553 s554 mod556)) (else (values (quote other) #f e551 w553 s554 mod556))))) (chi-when-list144 (lambda (e599 when-list600 w601) (letrec ((f602 (lambda (when-list603 situations604) (if (null? when-list603) situations604 (f602 (cdr when-list603) (cons (let ((x605 (car when-list603))) (cond ((free-id=?134 x605 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?134 x605 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?134 x605 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e599 (wrap139 x605 w601 #f))))) situations604)))))) (f602 when-list600 (quote ()))))) (chi-install-global143 (lambda (name606 e607) (build-global-definition86 #f name606 (if (let ((v608 (module-variable (current-module) name606))) (and v608 (variable-bound? v608) (macro? (variable-ref v608)) (not (eq? (macro-type (variable-ref v608)) (quote syncase-macro))))) (build-application79 #f (build-primref88 #f (quote make-extended-syncase-macro)) (list (build-application79 #f (build-primref88 #f (quote module-ref)) (list (build-application79 #f (quote current-module) (quote ())) (build-data89 #f name606))) (build-data89 #f (quote macro)) e607)) (build-application79 #f (build-primref88 #f (quote make-syncase-macro)) (list (build-data89 #f (quote macro)) e607)))))) (chi-top-sequence142 (lambda (body609 r610 w611 s612 m613 esew614 mod615) (build-sequence90 s612 (letrec ((dobody616 (lambda (body617 r618 w619 m620 esew621 mod622) (if (null? body617) (quote ()) (let ((first623 (chi-top146 (car body617) r618 w619 m620 esew621 mod622))) (cons first623 (dobody616 (cdr body617) r618 w619 m620 esew621 mod622))))))) (dobody616 body609 r610 w611 m613 esew614 mod615))))) (chi-sequence141 (lambda (body624 r625 w626 s627 mod628) (build-sequence90 s627 (letrec ((dobody629 (lambda (body630 r631 w632 mod633) (if (null? body630) (quote ()) (let ((first634 (chi147 (car body630) r631 w632 mod633))) (cons first634 (dobody629 (cdr body630) r631 w632 mod633))))))) (dobody629 body624 r625 w626 mod628))))) (source-wrap140 (lambda (x635 w636 s637 defmod638) (wrap139 (if s637 (make-annotation x635 s637 #f) x635) w636 defmod638))) (wrap139 (lambda (x639 w640 defmod641) (cond ((and (null? (wrap-marks114 w640)) (null? (wrap-subst115 w640))) x639) ((syntax-object?95 x639) (make-syntax-object94 (syntax-object-expression96 x639) (join-wraps130 w640 (syntax-object-wrap97 x639)) (syntax-object-module98 x639))) ((null? x639) x639) (else (make-syntax-object94 x639 w640 defmod641))))) (bound-id-member?138 (lambda (x642 list643) (and (not (null? list643)) (or (bound-id=?135 x642 (car list643)) (bound-id-member?138 x642 (cdr list643)))))) (distinct-bound-ids?137 (lambda (ids644) (letrec ((distinct?645 (lambda (ids646) (or (null? ids646) (and (not (bound-id-member?138 (car ids646) (cdr ids646))) (distinct?645 (cdr ids646))))))) (distinct?645 ids644)))) (valid-bound-ids?136 (lambda (ids647) (and (letrec ((all-ids?648 (lambda (ids649) (or (null? ids649) (and (id?111 (car ids649)) (all-ids?648 (cdr ids649))))))) (all-ids?648 ids647)) (distinct-bound-ids?137 ids647)))) (bound-id=?135 (lambda (i650 j651) (if (and (syntax-object?95 i650) (syntax-object?95 j651)) (and (eq? (let ((e652 (syntax-object-expression96 i650))) (if (annotation? e652) (annotation-expression e652) e652)) (let ((e653 (syntax-object-expression96 j651))) (if (annotation? e653) (annotation-expression e653) e653))) (same-marks?132 (wrap-marks114 (syntax-object-wrap97 i650)) (wrap-marks114 (syntax-object-wrap97 j651)))) (eq? (let ((e654 i650)) (if (annotation? e654) (annotation-expression e654) e654)) (let ((e655 j651)) (if (annotation? e655) (annotation-expression e655) e655)))))) (free-id=?134 (lambda (i656 j657) (and (eq? (let ((x658 i656)) (let ((e659 (if (syntax-object?95 x658) (syntax-object-expression96 x658) x658))) (if (annotation? e659) (annotation-expression e659) e659))) (let ((x660 j657)) (let ((e661 (if (syntax-object?95 x660) (syntax-object-expression96 x660) x660))) (if (annotation? e661) (annotation-expression e661) e661)))) (eq? (id-var-name133 i656 (quote (()))) (id-var-name133 j657 (quote (()))))))) (id-var-name133 (lambda (id662 w663) (letrec ((search-vector-rib666 (lambda (sym672 subst673 marks674 symnames675 ribcage676) (let ((n677 (vector-length symnames675))) (letrec ((f678 (lambda (i679) (cond ((fx=73 i679 n677) (search664 sym672 (cdr subst673) marks674)) ((and (eq? (vector-ref symnames675 i679) sym672) (same-marks?132 marks674 (vector-ref (ribcage-marks121 ribcage676) i679))) (values (vector-ref (ribcage-labels122 ribcage676) i679) marks674)) (else (f678 (fx+71 i679 1))))))) (f678 0))))) (search-list-rib665 (lambda (sym680 subst681 marks682 symnames683 ribcage684) (letrec ((f685 (lambda (symnames686 i687) (cond ((null? symnames686) (search664 sym680 (cdr subst681) marks682)) ((and (eq? (car symnames686) sym680) (same-marks?132 marks682 (list-ref (ribcage-marks121 ribcage684) i687))) (values (list-ref (ribcage-labels122 ribcage684) i687) marks682)) (else (f685 (cdr symnames686) (fx+71 i687 1))))))) (f685 symnames683 0)))) (search664 (lambda (sym688 subst689 marks690) (if (null? subst689) (values #f marks690) (let ((fst691 (car subst689))) (if (eq? fst691 (quote shift)) (search664 sym688 (cdr subst689) (cdr marks690)) (let ((symnames692 (ribcage-symnames120 fst691))) (if (vector? symnames692) (search-vector-rib666 sym688 subst689 marks690 symnames692 fst691) (search-list-rib665 sym688 subst689 marks690 symnames692 fst691))))))))) (cond ((symbol? id662) (or (call-with-values (lambda () (search664 id662 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x694 . ignore693) x694)) id662)) ((syntax-object?95 id662) (let ((id695 (let ((e697 (syntax-object-expression96 id662))) (if (annotation? e697) (annotation-expression e697) e697))) (w1696 (syntax-object-wrap97 id662))) (let ((marks698 (join-marks131 (wrap-marks114 w663) (wrap-marks114 w1696)))) (call-with-values (lambda () (search664 id695 (wrap-subst115 w663) marks698)) (lambda (new-id699 marks700) (or new-id699 (call-with-values (lambda () (search664 id695 (wrap-subst115 w1696) marks700)) (lambda (x702 . ignore701) x702)) id695)))))) ((annotation? id662) (let ((id703 (let ((e704 id662)) (if (annotation? e704) (annotation-expression e704) e704)))) (or (call-with-values (lambda () (search664 id703 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x706 . ignore705) x706)) id703))) (else (syntax-violation (quote id-var-name) "invalid id" id662)))))) (same-marks?132 (lambda (x707 y708) (or (eq? x707 y708) (and (not (null? x707)) (not (null? y708)) (eq? (car x707) (car y708)) (same-marks?132 (cdr x707) (cdr y708)))))) (join-marks131 (lambda (m1709 m2710) (smart-append129 m1709 m2710))) (join-wraps130 (lambda (w1711 w2712) (let ((m1713 (wrap-marks114 w1711)) (s1714 (wrap-subst115 w1711))) (if (null? m1713) (if (null? s1714) w2712 (make-wrap113 (wrap-marks114 w2712) (smart-append129 s1714 (wrap-subst115 w2712)))) (make-wrap113 (smart-append129 m1713 (wrap-marks114 w2712)) (smart-append129 s1714 (wrap-subst115 w2712))))))) (smart-append129 (lambda (m1715 m2716) (if (null? m2716) m1715 (append m1715 m2716)))) (make-binding-wrap128 (lambda (ids717 labels718 w719) (if (null? ids717) w719 (make-wrap113 (wrap-marks114 w719) (cons (let ((labelvec720 (list->vector labels718))) (let ((n721 (vector-length labelvec720))) (let ((symnamevec722 (make-vector n721)) (marksvec723 (make-vector n721))) (begin (letrec ((f724 (lambda (ids725 i726) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks112 (car ids725) w719)) (lambda (symname727 marks728) (begin (vector-set! symnamevec722 i726 symname727) (vector-set! marksvec723 i726 marks728) (f724 (cdr ids725) (fx+71 i726 1))))))))) (f724 ids717 0)) (make-ribcage118 symnamevec722 marksvec723 labelvec720))))) (wrap-subst115 w719)))))) (extend-ribcage!127 (lambda (ribcage729 id730 label731) (begin (set-ribcage-symnames!123 ribcage729 (cons (let ((e732 (syntax-object-expression96 id730))) (if (annotation? e732) (annotation-expression e732) e732)) (ribcage-symnames120 ribcage729))) (set-ribcage-marks!124 ribcage729 (cons (wrap-marks114 (syntax-object-wrap97 id730)) (ribcage-marks121 ribcage729))) (set-ribcage-labels!125 ribcage729 (cons label731 (ribcage-labels122 ribcage729)))))) (anti-mark126 (lambda (w733) (make-wrap113 (cons #f (wrap-marks114 w733)) (cons (quote shift) (wrap-subst115 w733))))) (set-ribcage-labels!125 (lambda (x734 update735) (vector-set! x734 3 update735))) (set-ribcage-marks!124 (lambda (x736 update737) (vector-set! x736 2 update737))) (set-ribcage-symnames!123 (lambda (x738 update739) (vector-set! x738 1 update739))) (ribcage-labels122 (lambda (x740) (vector-ref x740 3))) (ribcage-marks121 (lambda (x741) (vector-ref x741 2))) (ribcage-symnames120 (lambda (x742) (vector-ref x742 1))) (ribcage?119 (lambda (x743) (and (vector? x743) (= (vector-length x743) 4) (eq? (vector-ref x743 0) (quote ribcage))))) (make-ribcage118 (lambda (symnames744 marks745 labels746) (vector (quote ribcage) symnames744 marks745 labels746))) (gen-labels117 (lambda (ls747) (if (null? ls747) (quote ()) (cons (gen-label116) (gen-labels117 (cdr ls747)))))) (gen-label116 (lambda () (string #\i))) (wrap-subst115 cdr) (wrap-marks114 car) (make-wrap113 cons) (id-sym-name&marks112 (lambda (x748 w749) (if (syntax-object?95 x748) (values (let ((e750 (syntax-object-expression96 x748))) (if (annotation? e750) (annotation-expression e750) e750)) (join-marks131 (wrap-marks114 w749) (wrap-marks114 (syntax-object-wrap97 x748)))) (values (let ((e751 x748)) (if (annotation? e751) (annotation-expression e751) e751)) (wrap-marks114 w749))))) (id?111 (lambda (x752) (cond ((symbol? x752) #t) ((syntax-object?95 x752) (symbol? (let ((e753 (syntax-object-expression96 x752))) (if (annotation? e753) (annotation-expression e753) e753)))) ((annotation? x752) (symbol? (annotation-expression x752))) (else #f)))) (nonsymbol-id?110 (lambda (x754) (and (syntax-object?95 x754) (symbol? (let ((e755 (syntax-object-expression96 x754))) (if (annotation? e755) (annotation-expression e755) e755)))))) (global-extend109 (lambda (type756 sym757 val758) (put-global-definition-hook77 sym757 type756 val758))) (lookup108 (lambda (x759 r760 mod761) (cond ((assq x759 r760) => cdr) ((symbol? x759) (or (get-global-definition-hook78 x759 mod761) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env107 (lambda (r762) (if (null? r762) (quote ()) (let ((a763 (car r762))) (if (eq? (cadr a763) (quote macro)) (cons a763 (macros-only-env107 (cdr r762))) (macros-only-env107 (cdr r762))))))) (extend-var-env106 (lambda (labels764 vars765 r766) (if (null? labels764) r766 (extend-var-env106 (cdr labels764) (cdr vars765) (cons (cons (car labels764) (cons (quote lexical) (car vars765))) r766))))) (extend-env105 (lambda (labels767 bindings768 r769) (if (null? labels767) r769 (extend-env105 (cdr labels767) (cdr bindings768) (cons (cons (car labels767) (car bindings768)) r769))))) (binding-value104 cdr) (binding-type103 car) (source-annotation102 (lambda (x770) (cond ((annotation? x770) (annotation-source x770)) ((syntax-object?95 x770) (source-annotation102 (syntax-object-expression96 x770))) (else #f)))) (set-syntax-object-module!101 (lambda (x771 update772) (vector-set! x771 3 update772))) (set-syntax-object-wrap!100 (lambda (x773 update774) (vector-set! x773 2 update774))) (set-syntax-object-expression!99 (lambda (x775 update776) (vector-set! x775 1 update776))) (syntax-object-module98 (lambda (x777) (vector-ref x777 3))) (syntax-object-wrap97 (lambda (x778) (vector-ref x778 2))) (syntax-object-expression96 (lambda (x779) (vector-ref x779 1))) (syntax-object?95 (lambda (x780) (and (vector? x780) (= (vector-length x780) 4) (eq? (vector-ref x780 0) (quote syntax-object))))) (make-syntax-object94 (lambda (expression781 wrap782 module783) (vector (quote syntax-object) expression781 wrap782 module783))) (build-letrec93 (lambda (src784 ids785 vars786 val-exps787 body-exp788) (if (null? vars786) body-exp788 (let ((t789 (fluid-ref *mode*70))) (if (memv t789 (quote (c))) ((@ (language tree-il) make-letrec) src784 ids785 vars786 val-exps787 body-exp788) (list (quote letrec) (map list vars786 val-exps787) body-exp788)))))) (build-named-let92 (lambda (src790 ids791 vars792 val-exps793 body-exp794) (let ((f795 (car vars792)) (f-name796 (car ids791)) (vars797 (cdr vars792)) (ids798 (cdr ids791))) (let ((t799 (fluid-ref *mode*70))) (if (memv t799 (quote (c))) ((@ (language tree-il) make-letrec) src790 (list f-name796) (list f795) (list (build-lambda87 src790 ids798 vars797 #f body-exp794)) (build-application79 src790 (build-lexical-reference81 (quote fun) src790 f-name796 f795) val-exps793)) (list (quote let) f795 (map list vars797 val-exps793) body-exp794)))))) (build-let91 (lambda (src800 ids801 vars802 val-exps803 body-exp804) (if (null? vars802) body-exp804 (let ((t805 (fluid-ref *mode*70))) (if (memv t805 (quote (c))) ((@ (language tree-il) make-let) src800 ids801 vars802 val-exps803 body-exp804) (list (quote let) (map list vars802 val-exps803) body-exp804)))))) (build-sequence90 (lambda (src806 exps807) (if (null? (cdr exps807)) (car exps807) (let ((t808 (fluid-ref *mode*70))) (if (memv t808 (quote (c))) ((@ (language tree-il) make-sequence) src806 exps807) (cons (quote begin) exps807)))))) (build-data89 (lambda (src809 exp810) (let ((t811 (fluid-ref *mode*70))) (if (memv t811 (quote (c))) ((@ (language tree-il) make-const) src809 exp810) (if (and (self-evaluating? exp810) (not (vector? exp810))) exp810 (list (quote quote) exp810)))))) (build-primref88 (lambda (src812 name813) (let ((t814 (fluid-ref *mode*70))) (if (memv t814 (quote (c))) ((@ (language tree-il) make-primitive-ref) src812 name813) (build-global-reference84 src812 name813 (quote (hygiene guile))))))) (build-lambda87 (lambda (src815 ids816 vars817 docstring818 exp819) (let ((t820 (fluid-ref *mode*70))) (if (memv t820 (quote (c))) ((@ (language tree-il) make-lambda) src815 ids816 vars817 (if docstring818 (list (cons (quote documentation) docstring818)) (quote ())) exp819) (cons (quote lambda) (cons vars817 (append (if docstring818 (list docstring818) (quote ())) (list exp819)))))))) (build-global-definition86 (lambda (source821 var822 exp823) (let ((t824 (fluid-ref *mode*70))) (if (memv t824 (quote (c))) ((@ (language tree-il) make-toplevel-define) source821 var822 exp823) (list (quote define) var822 exp823))))) (build-global-assignment85 (lambda (source825 var826 exp827 mod828) (analyze-variable83 mod828 var826 (lambda (mod829 var830 public?831) (let ((t832 (fluid-ref *mode*70))) (if (memv t832 (quote (c))) ((@ (language tree-il) make-module-set) source825 mod829 var830 public?831 exp827) (list (quote set!) (list (if public?831 (quote @) (quote @@)) mod829 var830) exp827)))) (lambda (var833) (let ((t834 (fluid-ref *mode*70))) (if (memv t834 (quote (c))) ((@ (language tree-il) make-toplevel-set) source825 var833 exp827) (list (quote set!) var833 exp827))))))) (build-global-reference84 (lambda (source835 var836 mod837) (analyze-variable83 mod837 var836 (lambda (mod838 var839 public?840) (let ((t841 (fluid-ref *mode*70))) (if (memv t841 (quote (c))) ((@ (language tree-il) make-module-ref) source835 mod838 var839 public?840) (list (if public?840 (quote @) (quote @@)) mod838 var839)))) (lambda (var842) (let ((t843 (fluid-ref *mode*70))) (if (memv t843 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source835 var842) var842)))))) (analyze-variable83 (lambda (mod844 var845 modref-cont846 bare-cont847) (if (not mod844) (bare-cont847 var845) (let ((kind848 (car mod844)) (mod849 (cdr mod844))) (let ((t850 kind848)) (if (memv t850 (quote (public))) (modref-cont846 mod849 var845 #t) (if (memv t850 (quote (private))) (if (not (equal? mod849 (module-name (current-module)))) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (if (memv t850 (quote (bare))) (bare-cont847 var845) (if (memv t850 (quote (hygiene))) (if (and (not (equal? mod849 (module-name (current-module)))) (module-variable (resolve-module mod849) var845)) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (syntax-violation #f "bad module kind" var845 mod849)))))))))) (build-lexical-assignment82 (lambda (source851 name852 var853 exp854) (let ((t855 (fluid-ref *mode*70))) (if (memv t855 (quote (c))) ((@ (language tree-il) make-lexical-set) source851 name852 var853 exp854) (list (quote set!) var853 exp854))))) (build-lexical-reference81 (lambda (type856 source857 name858 var859) (let ((t860 (fluid-ref *mode*70))) (if (memv t860 (quote (c))) ((@ (language tree-il) make-lexical-ref) source857 name858 var859) var859)))) (build-conditional80 (lambda (source861 test-exp862 then-exp863 else-exp864) (let ((t865 (fluid-ref *mode*70))) (if (memv t865 (quote (c))) ((@ (language tree-il) make-conditional) source861 test-exp862 then-exp863 else-exp864) (list (quote if) test-exp862 then-exp863 else-exp864))))) (build-application79 (lambda (source866 fun-exp867 arg-exps868) (let ((t869 (fluid-ref *mode*70))) (if (memv t869 (quote (c))) ((@ (language tree-il) make-application) source866 fun-exp867 arg-exps868) (cons fun-exp867 arg-exps868))))) (get-global-definition-hook78 (lambda (symbol870 module871) (begin (if (and (not module871) (current-module)) (warn "module system is booted, we should have a module" symbol870)) (let ((v872 (module-variable (if module871 (resolve-module (cdr module871)) (current-module)) symbol870))) (and v872 (variable-bound? v872) (let ((val873 (variable-ref v872))) (and (macro? val873) (syncase-macro-type val873) (cons (syncase-macro-type val873) (syncase-macro-binding val873))))))))) (put-global-definition-hook77 (lambda (symbol874 type875 val876) (let ((existing877 (let ((v878 (module-variable (current-module) symbol874))) (and v878 (variable-bound? v878) (let ((val879 (variable-ref v878))) (and (macro? val879) (not (syncase-macro-type val879)) val879)))))) (module-define! (current-module) symbol874 (if existing877 (make-extended-syncase-macro existing877 type875 val876) (make-syncase-macro type875 val876)))))) (local-eval-hook76 (lambda (x880 mod881) (primitive-eval (list noexpand69 (let ((t882 (fluid-ref *mode*70))) (if (memv t882 (quote (c))) ((@ (language tree-il) tree-il->scheme) x880) x880)))))) (top-level-eval-hook75 (lambda (x883 mod884) (primitive-eval (list noexpand69 (let ((t885 (fluid-ref *mode*70))) (if (memv t885 (quote (c))) ((@ (language tree-il) tree-il->scheme) x883) x883)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend109 (quote local-syntax) (quote letrec-syntax) #t) (global-extend109 (quote local-syntax) (quote let-syntax) #f) (global-extend109 (quote core) (quote fluid-let-syntax) (lambda (e886 r887 w888 s889 mod890) ((lambda (tmp891) ((lambda (tmp892) (if (if tmp892 (apply (lambda (_893 var894 val895 e1896 e2897) (valid-bound-ids?136 var894)) tmp892) #f) (apply (lambda (_899 var900 val901 e1902 e2903) (let ((names904 (map (lambda (x905) (id-var-name133 x905 w888)) var900))) (begin (for-each (lambda (id907 n908) (let ((t909 (binding-type103 (lookup108 n908 r887 mod890)))) (if (memv t909 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e886 (source-wrap140 id907 w888 s889 mod890))))) var900 names904) (chi-body151 (cons e1902 e2903) (source-wrap140 e886 w888 s889 mod890) (extend-env105 names904 (let ((trans-r912 (macros-only-env107 r887))) (map (lambda (x913) (cons (quote macro) (eval-local-transformer154 (chi147 x913 trans-r912 w888 mod890) mod890))) val901)) r887) w888 mod890)))) tmp892) ((lambda (_915) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap140 e886 w888 s889 mod890))) tmp891))) ($sc-dispatch tmp891 (quote (any #(each (any any)) any . each-any))))) e886))) (global-extend109 (quote core) (quote quote) (lambda (e916 r917 w918 s919 mod920) ((lambda (tmp921) ((lambda (tmp922) (if tmp922 (apply (lambda (_923 e924) (build-data89 s919 (strip158 e924 w918))) tmp922) ((lambda (_925) (syntax-violation (quote quote) "bad syntax" (source-wrap140 e916 w918 s919 mod920))) tmp921))) ($sc-dispatch tmp921 (quote (any any))))) e916))) (global-extend109 (quote core) (quote syntax) (letrec ((regen933 (lambda (x934) (let ((t935 (car x934))) (if (memv t935 (quote (ref))) (build-lexical-reference81 (quote value) #f (cadr x934) (cadr x934)) (if (memv t935 (quote (primitive))) (build-primref88 #f (cadr x934)) (if (memv t935 (quote (quote))) (build-data89 #f (cadr x934)) (if (memv t935 (quote (lambda))) (build-lambda87 #f (cadr x934) (cadr x934) #f (regen933 (caddr x934))) (if (memv t935 (quote (map))) (let ((ls936 (map regen933 (cdr x934)))) (build-application79 #f (build-primref88 #f (quote map)) ls936)) (build-application79 #f (build-primref88 #f (car x934)) (map regen933 (cdr x934))))))))))) (gen-vector932 (lambda (x937) (cond ((eq? (car x937) (quote list)) (cons (quote vector) (cdr x937))) ((eq? (car x937) (quote quote)) (list (quote quote) (list->vector (cadr x937)))) (else (list (quote list->vector) x937))))) (gen-append931 (lambda (x938 y939) (if (equal? y939 (quote (quote ()))) x938 (list (quote append) x938 y939)))) (gen-cons930 (lambda (x940 y941) (let ((t942 (car y941))) (if (memv t942 (quote (quote))) (if (eq? (car x940) (quote quote)) (list (quote quote) (cons (cadr x940) (cadr y941))) (if (eq? (cadr y941) (quote ())) (list (quote list) x940) (list (quote cons) x940 y941))) (if (memv t942 (quote (list))) (cons (quote list) (cons x940 (cdr y941))) (list (quote cons) x940 y941)))))) (gen-map929 (lambda (e943 map-env944) (let ((formals945 (map cdr map-env944)) (actuals946 (map (lambda (x947) (list (quote ref) (car x947))) map-env944))) (cond ((eq? (car e943) (quote ref)) (car actuals946)) ((and-map (lambda (x948) (and (eq? (car x948) (quote ref)) (memq (cadr x948) formals945))) (cdr e943)) (cons (quote map) (cons (list (quote primitive) (car e943)) (map (let ((r949 (map cons formals945 actuals946))) (lambda (x950) (cdr (assq (cadr x950) r949)))) (cdr e943))))) (else (cons (quote map) (cons (list (quote lambda) formals945 e943) actuals946))))))) (gen-mappend928 (lambda (e951 map-env952) (list (quote apply) (quote (primitive append)) (gen-map929 e951 map-env952)))) (gen-ref927 (lambda (src953 var954 level955 maps956) (if (fx=73 level955 0) (values var954 maps956) (if (null? maps956) (syntax-violation (quote syntax) "missing ellipsis" src953) (call-with-values (lambda () (gen-ref927 src953 var954 (fx-72 level955 1) (cdr maps956))) (lambda (outer-var957 outer-maps958) (let ((b959 (assq outer-var957 (car maps956)))) (if b959 (values (cdr b959) maps956) (let ((inner-var960 (gen-var159 (quote tmp)))) (values inner-var960 (cons (cons (cons outer-var957 inner-var960) (car maps956)) outer-maps958))))))))))) (gen-syntax926 (lambda (src961 e962 r963 maps964 ellipsis?965 mod966) (if (id?111 e962) (let ((label967 (id-var-name133 e962 (quote (()))))) (let ((b968 (lookup108 label967 r963 mod966))) (if (eq? (binding-type103 b968) (quote syntax)) (call-with-values (lambda () (let ((var.lev969 (binding-value104 b968))) (gen-ref927 src961 (car var.lev969) (cdr var.lev969) maps964))) (lambda (var970 maps971) (values (list (quote ref) var970) maps971))) (if (ellipsis?965 e962) (syntax-violation (quote syntax) "misplaced ellipsis" src961) (values (list (quote quote) e962) maps964))))) ((lambda (tmp972) ((lambda (tmp973) (if (if tmp973 (apply (lambda (dots974 e975) (ellipsis?965 dots974)) tmp973) #f) (apply (lambda (dots976 e977) (gen-syntax926 src961 e977 r963 maps964 (lambda (x978) #f) mod966)) tmp973) ((lambda (tmp979) (if (if tmp979 (apply (lambda (x980 dots981 y982) (ellipsis?965 dots981)) tmp979) #f) (apply (lambda (x983 dots984 y985) (letrec ((f986 (lambda (y987 k988) ((lambda (tmp992) ((lambda (tmp993) (if (if tmp993 (apply (lambda (dots994 y995) (ellipsis?965 dots994)) tmp993) #f) (apply (lambda (dots996 y997) (f986 y997 (lambda (maps998) (call-with-values (lambda () (k988 (cons (quote ()) maps998))) (lambda (x999 maps1000) (if (null? (car maps1000)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-mappend928 x999 (car maps1000)) (cdr maps1000)))))))) tmp993) ((lambda (_1001) (call-with-values (lambda () (gen-syntax926 src961 y987 r963 maps964 ellipsis?965 mod966)) (lambda (y1002 maps1003) (call-with-values (lambda () (k988 maps1003)) (lambda (x1004 maps1005) (values (gen-append931 x1004 y1002) maps1005)))))) tmp992))) ($sc-dispatch tmp992 (quote (any . any))))) y987)))) (f986 y985 (lambda (maps989) (call-with-values (lambda () (gen-syntax926 src961 x983 r963 (cons (quote ()) maps989) ellipsis?965 mod966)) (lambda (x990 maps991) (if (null? (car maps991)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-map929 x990 (car maps991)) (cdr maps991))))))))) tmp979) ((lambda (tmp1006) (if tmp1006 (apply (lambda (x1007 y1008) (call-with-values (lambda () (gen-syntax926 src961 x1007 r963 maps964 ellipsis?965 mod966)) (lambda (x1009 maps1010) (call-with-values (lambda () (gen-syntax926 src961 y1008 r963 maps1010 ellipsis?965 mod966)) (lambda (y1011 maps1012) (values (gen-cons930 x1009 y1011) maps1012)))))) tmp1006) ((lambda (tmp1013) (if tmp1013 (apply (lambda (e11014 e21015) (call-with-values (lambda () (gen-syntax926 src961 (cons e11014 e21015) r963 maps964 ellipsis?965 mod966)) (lambda (e1017 maps1018) (values (gen-vector932 e1017) maps1018)))) tmp1013) ((lambda (_1019) (values (list (quote quote) e962) maps964)) tmp972))) ($sc-dispatch tmp972 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp972 (quote (any . any)))))) ($sc-dispatch tmp972 (quote (any any . any)))))) ($sc-dispatch tmp972 (quote (any any))))) e962))))) (lambda (e1020 r1021 w1022 s1023 mod1024) (let ((e1025 (source-wrap140 e1020 w1022 s1023 mod1024))) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda (_1028 x1029) (call-with-values (lambda () (gen-syntax926 e1025 x1029 r1021 (quote ()) ellipsis?156 mod1024)) (lambda (e1030 maps1031) (regen933 e1030)))) tmp1027) ((lambda (_1032) (syntax-violation (quote syntax) "bad `syntax' form" e1025)) tmp1026))) ($sc-dispatch tmp1026 (quote (any any))))) e1025))))) (global-extend109 (quote core) (quote lambda) (lambda (e1033 r1034 w1035 s1036 mod1037) ((lambda (tmp1038) ((lambda (tmp1039) (if tmp1039 (apply (lambda (_1040 c1041) (chi-lambda-clause152 (source-wrap140 e1033 w1035 s1036 mod1037) #f c1041 r1034 w1035 mod1037 (lambda (names1042 vars1043 docstring1044 body1045) (build-lambda87 s1036 names1042 vars1043 docstring1044 body1045)))) tmp1039) (syntax-violation #f "source expression failed to match any pattern" tmp1038))) ($sc-dispatch tmp1038 (quote (any . any))))) e1033))) (global-extend109 (quote core) (quote let) (letrec ((chi-let1046 (lambda (e1047 r1048 w1049 s1050 mod1051 constructor1052 ids1053 vals1054 exps1055) (if (not (valid-bound-ids?136 ids1053)) (syntax-violation (quote let) "duplicate bound variable" e1047) (let ((labels1056 (gen-labels117 ids1053)) (new-vars1057 (map gen-var159 ids1053))) (let ((nw1058 (make-binding-wrap128 ids1053 labels1056 w1049)) (nr1059 (extend-var-env106 labels1056 new-vars1057 r1048))) (constructor1052 s1050 (map syntax->datum ids1053) new-vars1057 (map (lambda (x1060) (chi147 x1060 r1048 w1049 mod1051)) vals1054) (chi-body151 exps1055 (source-wrap140 e1047 nw1058 s1050 mod1051) nr1059 nw1058 mod1051)))))))) (lambda (e1061 r1062 w1063 s1064 mod1065) ((lambda (tmp1066) ((lambda (tmp1067) (if tmp1067 (apply (lambda (_1068 id1069 val1070 e11071 e21072) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-let91 id1069 val1070 (cons e11071 e21072))) tmp1067) ((lambda (tmp1076) (if (if tmp1076 (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (id?111 f1078)) tmp1076) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-named-let92 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1076) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap140 e1061 w1063 s1064 mod1065))) tmp1066))) ($sc-dispatch tmp1066 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1066 (quote (any #(each (any any)) any . each-any))))) e1061)))) (global-extend109 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (let ((ids1105 id1101)) (if (not (valid-bound-ids?136 ids1105)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1107 (gen-labels117 ids1105)) (new-vars1108 (map gen-var159 ids1105))) (let ((w1109 (make-binding-wrap128 ids1105 labels1107 w1095)) (r1110 (extend-var-env106 labels1107 new-vars1108 r1094))) (build-letrec93 s1096 (map syntax->datum ids1105) new-vars1108 (map (lambda (x1111) (chi147 x1111 r1110 w1109 mod1097)) val1102) (chi-body151 (cons e11103 e21104) (source-wrap140 e1093 w1109 s1096 mod1097) r1110 w1109 mod1097))))))) tmp1099) ((lambda (_1114) (syntax-violation (quote letrec) "bad letrec" (source-wrap140 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend109 (quote core) (quote set!) (lambda (e1115 r1116 w1117 s1118 mod1119) ((lambda (tmp1120) ((lambda (tmp1121) (if (if tmp1121 (apply (lambda (_1122 id1123 val1124) (id?111 id1123)) tmp1121) #f) (apply (lambda (_1125 id1126 val1127) (let ((val1128 (chi147 val1127 r1116 w1117 mod1119)) (n1129 (id-var-name133 id1126 w1117))) (let ((b1130 (lookup108 n1129 r1116 mod1119))) (let ((t1131 (binding-type103 b1130))) (if (memv t1131 (quote (lexical))) (build-lexical-assignment82 s1118 (syntax->datum id1126) (binding-value104 b1130) val1128) (if (memv t1131 (quote (global))) (build-global-assignment85 s1118 n1129 val1128 mod1119) (if (memv t1131 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap139 id1126 w1117 mod1119)) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))))))))) tmp1121) ((lambda (tmp1132) (if tmp1132 (apply (lambda (_1133 head1134 tail1135 val1136) (call-with-values (lambda () (syntax-type145 head1134 r1116 (quote (())) #f #f mod1119)) (lambda (type1137 value1138 ee1139 ww1140 ss1141 modmod1142) (let ((t1143 type1137)) (if (memv t1143 (quote (module-ref))) (let ((val1144 (chi147 val1136 r1116 w1117 mod1119))) (call-with-values (lambda () (value1138 (cons head1134 tail1135))) (lambda (id1146 mod1147) (build-global-assignment85 s1118 id1146 val1144 mod1147)))) (build-application79 s1118 (chi147 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1134) r1116 w1117 mod1119) (map (lambda (e1148) (chi147 e1148 r1116 w1117 mod1119)) (append tail1135 (list val1136))))))))) tmp1132) ((lambda (_1150) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))) tmp1120))) ($sc-dispatch tmp1120 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1120 (quote (any any any))))) e1115))) (global-extend109 (quote module-ref) (quote @) (lambda (e1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 mod1155 id1156) (and (and-map id?111 mod1155) (id?111 id1156))) tmp1153) #f) (apply (lambda (_1158 mod1159 id1160) (values (syntax->datum id1160) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1159)))) tmp1153) (syntax-violation #f "source expression failed to match any pattern" tmp1152))) ($sc-dispatch tmp1152 (quote (any each-any any))))) e1151))) (global-extend109 (quote module-ref) (quote @@) (lambda (e1162) ((lambda (tmp1163) ((lambda (tmp1164) (if (if tmp1164 (apply (lambda (_1165 mod1166 id1167) (and (and-map id?111 mod1166) (id?111 id1167))) tmp1164) #f) (apply (lambda (_1169 mod1170 id1171) (values (syntax->datum id1171) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1170)))) tmp1164) (syntax-violation #f "source expression failed to match any pattern" tmp1163))) ($sc-dispatch tmp1163 (quote (any each-any any))))) e1162))) (global-extend109 (quote begin) (quote begin) (quote ())) (global-extend109 (quote define) (quote define) (quote ())) (global-extend109 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend109 (quote eval-when) (quote eval-when) (quote ())) (global-extend109 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1176 (lambda (x1177 keys1178 clauses1179 r1180 mod1181) (if (null? clauses1179) (build-application79 #f (build-primref88 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1177)) ((lambda (tmp1182) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 exp1185) (if (and (id?111 pat1184) (and-map (lambda (x1186) (not (free-id=?134 pat1184 x1186))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1178))) (let ((labels1187 (list (gen-label116))) (var1188 (gen-var159 pat1184))) (build-application79 #f (build-lambda87 #f (list (syntax->datum pat1184)) (list var1188) #f (chi147 exp1185 (extend-env105 labels1187 (list (cons (quote syntax) (cons var1188 0))) r1180) (make-binding-wrap128 (list pat1184) labels1187 (quote (()))) mod1181)) (list x1177))) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1184 #t exp1185 mod1181))) tmp1183) ((lambda (tmp1189) (if tmp1189 (apply (lambda (pat1190 fender1191 exp1192) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1190 fender1191 exp1192 mod1181)) tmp1189) ((lambda (_1193) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1179))) tmp1182))) ($sc-dispatch tmp1182 (quote (any any any)))))) ($sc-dispatch tmp1182 (quote (any any))))) (car clauses1179))))) (gen-clause1175 (lambda (x1194 keys1195 clauses1196 r1197 pat1198 fender1199 exp1200 mod1201) (call-with-values (lambda () (convert-pattern1173 pat1198 keys1195)) (lambda (p1202 pvars1203) (cond ((not (distinct-bound-ids?137 (map car pvars1203))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1198)) ((not (and-map (lambda (x1204) (not (ellipsis?156 (car x1204)))) pvars1203)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1198)) (else (let ((y1205 (gen-var159 (quote tmp)))) (build-application79 #f (build-lambda87 #f (list (quote tmp)) (list y1205) #f (let ((y1206 (build-lexical-reference81 (quote value) #f (quote tmp) y1205))) (build-conditional80 #f ((lambda (tmp1207) ((lambda (tmp1208) (if tmp1208 (apply (lambda () y1206) tmp1208) ((lambda (_1209) (build-conditional80 #f y1206 (build-dispatch-call1174 pvars1203 fender1199 y1206 r1197 mod1201) (build-data89 #f #f))) tmp1207))) ($sc-dispatch tmp1207 (quote #(atom #t))))) fender1199) (build-dispatch-call1174 pvars1203 exp1200 y1206 r1197 mod1201) (gen-syntax-case1176 x1194 keys1195 clauses1196 r1197 mod1201)))) (list (if (eq? p1202 (quote any)) (build-application79 #f (build-primref88 #f (quote list)) (list x1194)) (build-application79 #f (build-primref88 #f (quote $sc-dispatch)) (list x1194 (build-data89 #f p1202))))))))))))) (build-dispatch-call1174 (lambda (pvars1210 exp1211 y1212 r1213 mod1214) (let ((ids1215 (map car pvars1210)) (levels1216 (map cdr pvars1210))) (let ((labels1217 (gen-labels117 ids1215)) (new-vars1218 (map gen-var159 ids1215))) (build-application79 #f (build-primref88 #f (quote apply)) (list (build-lambda87 #f (map syntax->datum ids1215) new-vars1218 #f (chi147 exp1211 (extend-env105 labels1217 (map (lambda (var1219 level1220) (cons (quote syntax) (cons var1219 level1220))) new-vars1218 (map cdr pvars1210)) r1213) (make-binding-wrap128 ids1215 labels1217 (quote (()))) mod1214)) y1212)))))) (convert-pattern1173 (lambda (pattern1221 keys1222) (letrec ((cvt1223 (lambda (p1224 n1225 ids1226) (if (id?111 p1224) (if (bound-id-member?138 p1224 keys1222) (values (vector (quote free-id) p1224) ids1226) (values (quote any) (cons (cons p1224 n1225) ids1226))) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (x1229 dots1230) (ellipsis?156 dots1230)) tmp1228) #f) (apply (lambda (x1231 dots1232) (call-with-values (lambda () (cvt1223 x1231 (fx+71 n1225 1) ids1226)) (lambda (p1233 ids1234) (values (if (eq? p1233 (quote any)) (quote each-any) (vector (quote each) p1233)) ids1234)))) tmp1228) ((lambda (tmp1235) (if tmp1235 (apply (lambda (x1236 y1237) (call-with-values (lambda () (cvt1223 y1237 n1225 ids1226)) (lambda (y1238 ids1239) (call-with-values (lambda () (cvt1223 x1236 n1225 ids1239)) (lambda (x1240 ids1241) (values (cons x1240 y1238) ids1241)))))) tmp1235) ((lambda (tmp1242) (if tmp1242 (apply (lambda () (values (quote ()) ids1226)) tmp1242) ((lambda (tmp1243) (if tmp1243 (apply (lambda (x1244) (call-with-values (lambda () (cvt1223 x1244 n1225 ids1226)) (lambda (p1246 ids1247) (values (vector (quote vector) p1246) ids1247)))) tmp1243) ((lambda (x1248) (values (vector (quote atom) (strip158 p1224 (quote (())))) ids1226)) tmp1227))) ($sc-dispatch tmp1227 (quote #(vector each-any)))))) ($sc-dispatch tmp1227 (quote ()))))) ($sc-dispatch tmp1227 (quote (any . any)))))) ($sc-dispatch tmp1227 (quote (any any))))) p1224))))) (cvt1223 pattern1221 0 (quote ())))))) (lambda (e1249 r1250 w1251 s1252 mod1253) (let ((e1254 (source-wrap140 e1249 w1251 s1252 mod1253))) ((lambda (tmp1255) ((lambda (tmp1256) (if tmp1256 (apply (lambda (_1257 val1258 key1259 m1260) (if (and-map (lambda (x1261) (and (id?111 x1261) (not (ellipsis?156 x1261)))) key1259) (let ((x1263 (gen-var159 (quote tmp)))) (build-application79 s1252 (build-lambda87 #f (list (quote tmp)) (list x1263) #f (gen-syntax-case1176 (build-lexical-reference81 (quote value) #f (quote tmp) x1263) key1259 m1260 r1250 mod1253)) (list (chi147 val1258 r1250 (quote (())) mod1253)))) (syntax-violation (quote syntax-case) "invalid literals list" e1254))) tmp1256) (syntax-violation #f "source expression failed to match any pattern" tmp1255))) ($sc-dispatch tmp1255 (quote (any any each-any . each-any))))) e1254))))) (set! sc-expand (lambda (x1267 . rest1266) (if (and (pair? x1267) (equal? (car x1267) noexpand69)) (cadr x1267) (let ((m1268 (if (null? rest1266) (quote e) (car rest1266))) (esew1269 (if (or (null? rest1266) (null? (cdr rest1266))) (quote (eval)) (cadr rest1266)))) (with-fluid* *mode*70 m1268 (lambda () (chi-top146 x1267 (quote ()) (quote ((top))) m1268 esew1269 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1270) (nonsymbol-id?110 x1270))) (set! datum->syntax (lambda (id1271 datum1272) (make-syntax-object94 datum1272 (syntax-object-wrap97 id1271) #f))) (set! syntax->datum (lambda (x1273) (strip158 x1273 (quote (()))))) (set! generate-temporaries (lambda (ls1274) (begin (let ((x1275 ls1274)) (if (not (list? x1275)) (syntax-violation (quote generate-temporaries) "invalid argument" x1275))) (map (lambda (x1276) (wrap139 (gensym) (quote ((top))) #f)) ls1274)))) (set! free-identifier=? (lambda (x1277 y1278) (begin (let ((x1279 x1277)) (if (not (nonsymbol-id?110 x1279)) (syntax-violation (quote free-identifier=?) "invalid argument" x1279))) (let ((x1280 y1278)) (if (not (nonsymbol-id?110 x1280)) (syntax-violation (quote free-identifier=?) "invalid argument" x1280))) (free-id=?134 x1277 y1278)))) (set! bound-identifier=? (lambda (x1281 y1282) (begin (let ((x1283 x1281)) (if (not (nonsymbol-id?110 x1283)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1283))) (let ((x1284 y1282)) (if (not (nonsymbol-id?110 x1284)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1284))) (bound-id=?135 x1281 y1282)))) (set! syntax-violation (lambda (who1288 message1287 form1286 . subform1285) (begin (let ((x1289 who1288)) (if (not ((lambda (x1290) (or (not x1290) (string? x1290) (symbol? x1290))) x1289)) (syntax-violation (quote syntax-violation) "invalid argument" x1289))) (let ((x1291 message1287)) (if (not (string? x1291)) (syntax-violation (quote syntax-violation) "invalid argument" x1291))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1288 "~a: " "") "~a " (if (null? subform1285) "in ~a" "in subform `~s' of `~s'")) (let ((tail1292 (cons message1287 (map (lambda (x1293) (strip158 x1293 (quote (())))) (append subform1285 (list form1286)))))) (if who1288 (cons who1288 tail1292) tail1292)) #f)))) (letrec ((match1298 (lambda (e1299 p1300 w1301 r1302 mod1303) (cond ((not r1302) #f) ((eq? p1300 (quote any)) (cons (wrap139 e1299 w1301 mod1303) r1302)) ((syntax-object?95 e1299) (match*1297 (let ((e1304 (syntax-object-expression96 e1299))) (if (annotation? e1304) (annotation-expression e1304) e1304)) p1300 (join-wraps130 w1301 (syntax-object-wrap97 e1299)) r1302 (syntax-object-module98 e1299))) (else (match*1297 (let ((e1305 e1299)) (if (annotation? e1305) (annotation-expression e1305) e1305)) p1300 w1301 r1302 mod1303))))) (match*1297 (lambda (e1306 p1307 w1308 r1309 mod1310) (cond ((null? p1307) (and (null? e1306) r1309)) ((pair? p1307) (and (pair? e1306) (match1298 (car e1306) (car p1307) w1308 (match1298 (cdr e1306) (cdr p1307) w1308 r1309 mod1310) mod1310))) ((eq? p1307 (quote each-any)) (let ((l1311 (match-each-any1295 e1306 w1308 mod1310))) (and l1311 (cons l1311 r1309)))) (else (let ((t1312 (vector-ref p1307 0))) (if (memv t1312 (quote (each))) (if (null? e1306) (match-empty1296 (vector-ref p1307 1) r1309) (let ((l1313 (match-each1294 e1306 (vector-ref p1307 1) w1308 mod1310))) (and l1313 (letrec ((collect1314 (lambda (l1315) (if (null? (car l1315)) r1309 (cons (map car l1315) (collect1314 (map cdr l1315))))))) (collect1314 l1313))))) (if (memv t1312 (quote (free-id))) (and (id?111 e1306) (free-id=?134 (wrap139 e1306 w1308 mod1310) (vector-ref p1307 1)) r1309) (if (memv t1312 (quote (atom))) (and (equal? (vector-ref p1307 1) (strip158 e1306 w1308)) r1309) (if (memv t1312 (quote (vector))) (and (vector? e1306) (match1298 (vector->list e1306) (vector-ref p1307 1) w1308 r1309 mod1310))))))))))) (match-empty1296 (lambda (p1316 r1317) (cond ((null? p1316) r1317) ((eq? p1316 (quote any)) (cons (quote ()) r1317)) ((pair? p1316) (match-empty1296 (car p1316) (match-empty1296 (cdr p1316) r1317))) ((eq? p1316 (quote each-any)) (cons (quote ()) r1317)) (else (let ((t1318 (vector-ref p1316 0))) (if (memv t1318 (quote (each))) (match-empty1296 (vector-ref p1316 1) r1317) (if (memv t1318 (quote (free-id atom))) r1317 (if (memv t1318 (quote (vector))) (match-empty1296 (vector-ref p1316 1) r1317))))))))) (match-each-any1295 (lambda (e1319 w1320 mod1321) (cond ((annotation? e1319) (match-each-any1295 (annotation-expression e1319) w1320 mod1321)) ((pair? e1319) (let ((l1322 (match-each-any1295 (cdr e1319) w1320 mod1321))) (and l1322 (cons (wrap139 (car e1319) w1320 mod1321) l1322)))) ((null? e1319) (quote ())) ((syntax-object?95 e1319) (match-each-any1295 (syntax-object-expression96 e1319) (join-wraps130 w1320 (syntax-object-wrap97 e1319)) mod1321)) (else #f)))) (match-each1294 (lambda (e1323 p1324 w1325 mod1326) (cond ((annotation? e1323) (match-each1294 (annotation-expression e1323) p1324 w1325 mod1326)) ((pair? e1323) (let ((first1327 (match1298 (car e1323) p1324 w1325 (quote ()) mod1326))) (and first1327 (let ((rest1328 (match-each1294 (cdr e1323) p1324 w1325 mod1326))) (and rest1328 (cons first1327 rest1328)))))) ((null? e1323) (quote ())) ((syntax-object?95 e1323) (match-each1294 (syntax-object-expression96 e1323) p1324 (join-wraps130 w1325 (syntax-object-wrap97 e1323)) (syntax-object-module98 e1323))) (else #f))))) (set! $sc-dispatch (lambda (e1329 p1330) (cond ((eq? p1330 (quote any)) (list e1329)) ((syntax-object?95 e1329) (match*1297 (let ((e1331 (syntax-object-expression96 e1329))) (if (annotation? e1331) (annotation-expression e1331) e1331)) p1330 (syntax-object-wrap97 e1329) (quote ()) (syntax-object-module98 e1329))) (else (match*1297 (let ((e1332 e1329)) (if (annotation? e1332) (annotation-expression e1332) e1332)) p1330 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1333) ((lambda (tmp1334) ((lambda (tmp1335) (if tmp1335 (apply (lambda (_1336 e11337 e21338) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11337 e21338))) tmp1335) ((lambda (tmp1340) (if tmp1340 (apply (lambda (_1341 out1342 in1343 e11344 e21345) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1343 (quote ()) (list out1342 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11344 e21345))))) tmp1340) ((lambda (tmp1347) (if tmp1347 (apply (lambda (_1348 out1349 in1350 e11351 e21352) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1350) (quote ()) (list out1349 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11351 e21352))))) tmp1347) (syntax-violation #f "source expression failed to match any pattern" tmp1334))) ($sc-dispatch tmp1334 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any () any . each-any))))) x1333)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1356) ((lambda (tmp1357) ((lambda (tmp1358) (if tmp1358 (apply (lambda (_1359 k1360 keyword1361 pattern1362 template1363) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1360 (map (lambda (tmp1366 tmp1365) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1365) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1366))) template1363 pattern1362)))))) tmp1358) (syntax-violation #f "source expression failed to match any pattern" tmp1357))) ($sc-dispatch tmp1357 (quote (any each-any . #(each ((any . any) any))))))) x1356)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1367) ((lambda (tmp1368) ((lambda (tmp1369) (if (if tmp1369 (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (and-map identifier? x1371)) tmp1369) #f) (apply (lambda (let*1376 x1377 v1378 e11379 e21380) (letrec ((f1381 (lambda (bindings1382) (if (null? bindings1382) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11379 e21380))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (body1388 binding1389) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1389) body1388)) tmp1387) (syntax-violation #f "source expression failed to match any pattern" tmp1386))) ($sc-dispatch tmp1386 (quote (any any))))) (list (f1381 (cdr bindings1382)) (car bindings1382))))))) (f1381 (map list x1377 v1378)))) tmp1369) (syntax-violation #f "source expression failed to match any pattern" tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) x1367)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1390) ((lambda (tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (_1393 var1394 init1395 step1396 e01397 e11398 c1399) ((lambda (tmp1400) ((lambda (tmp1401) (if tmp1401 (apply (lambda (step1402) ((lambda (tmp1403) ((lambda (tmp1404) (if tmp1404 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1404) ((lambda (tmp1409) (if tmp1409 (apply (lambda (e11410 e21411) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11410 e21411)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1409) (syntax-violation #f "source expression failed to match any pattern" tmp1403))) ($sc-dispatch tmp1403 (quote (any . each-any)))))) ($sc-dispatch tmp1403 (quote ())))) e11398)) tmp1401) (syntax-violation #f "source expression failed to match any pattern" tmp1400))) ($sc-dispatch tmp1400 (quote each-any)))) (map (lambda (v1418 s1419) ((lambda (tmp1420) ((lambda (tmp1421) (if tmp1421 (apply (lambda () v1418) tmp1421) ((lambda (tmp1422) (if tmp1422 (apply (lambda (e1423) e1423) tmp1422) ((lambda (_1424) (syntax-violation (quote do) "bad step expression" orig-x1390 s1419)) tmp1420))) ($sc-dispatch tmp1420 (quote (any)))))) ($sc-dispatch tmp1420 (quote ())))) s1419)) var1394 step1396))) tmp1392) (syntax-violation #f "source expression failed to match any pattern" tmp1391))) ($sc-dispatch tmp1391 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1390)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1427 (lambda (x1431 y1432) ((lambda (tmp1433) ((lambda (tmp1434) (if tmp1434 (apply (lambda (x1435 y1436) ((lambda (tmp1437) ((lambda (tmp1438) (if tmp1438 (apply (lambda (dy1439) ((lambda (tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (dx1442) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1442 dy1439))) tmp1441) ((lambda (_1443) (if (null? dy1439) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436))) tmp1440))) ($sc-dispatch tmp1440 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1435)) tmp1438) ((lambda (tmp1444) (if tmp1444 (apply (lambda (stuff1445) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1435 stuff1445))) tmp1444) ((lambda (else1446) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436)) tmp1437))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1436)) tmp1434) (syntax-violation #f "source expression failed to match any pattern" tmp1433))) ($sc-dispatch tmp1433 (quote (any any))))) (list x1431 y1432)))) (quasiappend1428 (lambda (x1447 y1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (x1451 y1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda () x1451) tmp1454) ((lambda (_1455) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1451 y1452)) tmp1453))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1452)) tmp1450) (syntax-violation #f "source expression failed to match any pattern" tmp1449))) ($sc-dispatch tmp1449 (quote (any any))))) (list x1447 y1448)))) (quasivector1429 (lambda (x1456) ((lambda (tmp1457) ((lambda (x1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (x1461) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1461))) tmp1460) ((lambda (tmp1463) (if tmp1463 (apply (lambda (x1464) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1464)) tmp1463) ((lambda (_1466) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1458)) tmp1459))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1458)) tmp1457)) x1456))) (quasi1430 (lambda (p1467 lev1468) ((lambda (tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471) (if (= lev1468 0) p1471 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1471) (- lev1468 1))))) tmp1470) ((lambda (tmp1472) (if tmp1472 (apply (lambda (p1473 q1474) (if (= lev1468 0) (quasiappend1428 p1473 (quasi1430 q1474 lev1468)) (quasicons1427 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1473) (- lev1468 1))) (quasi1430 q1474 lev1468)))) tmp1472) ((lambda (tmp1475) (if tmp1475 (apply (lambda (p1476) (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1476) (+ lev1468 1)))) tmp1475) ((lambda (tmp1477) (if tmp1477 (apply (lambda (p1478 q1479) (quasicons1427 (quasi1430 p1478 lev1468) (quasi1430 q1479 lev1468))) tmp1477) ((lambda (tmp1480) (if tmp1480 (apply (lambda (x1481) (quasivector1429 (quasi1430 x1481 lev1468))) tmp1480) ((lambda (p1483) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1483)) tmp1469))) ($sc-dispatch tmp1469 (quote #(vector each-any)))))) ($sc-dispatch tmp1469 (quote (any . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1469 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1467)))) (lambda (x1484) ((lambda (tmp1485) ((lambda (tmp1486) (if tmp1486 (apply (lambda (_1487 e1488) (quasi1430 e1488 0)) tmp1486) (syntax-violation #f "source expression failed to match any pattern" tmp1485))) ($sc-dispatch tmp1485 (quote (any any))))) x1484))))) +(define include (make-syncase-macro (quote macro) (lambda (x1489) (letrec ((read-file1490 (lambda (fn1491 k1492) (let ((p1493 (open-input-file fn1491))) (letrec ((f1494 (lambda (x1495) (if (eof-object? x1495) (begin (close-input-port p1493) (quote ())) (cons (datum->syntax k1492 x1495) (f1494 (read p1493))))))) (f1494 (read p1493))))))) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (k1498 filename1499) (let ((fn1500 (syntax->datum filename1499))) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (exp1503) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1503)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote each-any)))) (read-file1490 fn1500 k1498)))) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any any))))) x1489))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1505)) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any))))) x1505)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1510) ((lambda (tmp1511) ((lambda (tmp1512) (if tmp1512 (apply (lambda (_1513 e1514) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1510)) tmp1512) (syntax-violation #f "source expression failed to match any pattern" tmp1511))) ($sc-dispatch tmp1511 (quote (any any))))) x1510)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if tmp1517 (apply (lambda (_1518 e1519 m11520 m21521) ((lambda (tmp1522) ((lambda (body1523) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1519)) body1523)) tmp1522)) (letrec ((f1524 (lambda (clause1525 clauses1526) (if (null? clauses1526) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (e11530 e21531) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11530 e21531))) tmp1529) ((lambda (tmp1533) (if tmp1533 (apply (lambda (k1534 e11535 e21536) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1534)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11535 e21536)))) tmp1533) ((lambda (_1539) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1528))) ($sc-dispatch tmp1528 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1528 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1525) ((lambda (tmp1540) ((lambda (rest1541) ((lambda (tmp1542) ((lambda (tmp1543) (if tmp1543 (apply (lambda (k1544 e11545 e21546) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1544)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11545 e21546)) rest1541)) tmp1543) ((lambda (_1549) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1542))) ($sc-dispatch tmp1542 (quote (each-any any . each-any))))) clause1525)) tmp1540)) (f1524 (car clauses1526) (cdr clauses1526))))))) (f1524 m11520 m21521)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any any any . each-any))))) x1515)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e1554) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1554)) (list (cons _1553 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1554 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1552) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any any))))) x1550)))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 29a9ee976..3b329e549 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -28,6 +28,19 @@ #:use-module (language tree-il analyze) #:export (compile-glil)) +;;; TODO: +;; +;; * (delay x) -> (make-promise (lambda () x)) +;; * ([@]apply f args) -> goto/apply or similar +;; * ([@]apply values args) -> goto/values or similar +;; * ([@]call-with-values prod cons) ... +;; * ([@]call-with-current-continuation prod cons) ... +;; call-with-values -> mv-bind +;; compile-time-environment +;; GOOPS' @slot-ref, @slot-set +;; basic degenerate-case reduction +;; vm op "inlining" + ;; allocation: ;; sym -> (local . index) | (heap level . index) ;; lambda -> (nlocs . nexts) From 112edbaea3e48e002261c72064d6602d661c3df4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 May 2009 23:24:26 +0200 Subject: [PATCH 108/375] inline calls to some primitives * module/system/base/pmatch.scm: Wrap consequents in (let () ) instead of (begin ) so that they can have local definitions. * module/language/tree-il/compile-glil.scm: Inline some calls to primitives. --- module/language/tree-il/compile-glil.scm | 53 ++++++++++++++++++++---- module/system/base/pmatch.scm | 6 +-- 2 files changed, 48 insertions(+), 11 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 3b329e549..23d05c330 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -30,7 +30,6 @@ ;;; TODO: ;; -;; * (delay x) -> (make-promise (lambda () x)) ;; * ([@]apply f args) -> goto/apply or similar ;; * ([@]apply values args) -> goto/values or similar ;; * ([@]call-with-values prod cons) ... @@ -39,7 +38,6 @@ ;; compile-time-environment ;; GOOPS' @slot-ref, @slot-set ;; basic degenerate-case reduction -;; vm op "inlining" ;; allocation: ;; sym -> (local . index) | (heap level . index) @@ -55,6 +53,34 @@ +(define *primcall-ops* (make-hash-table)) +(for-each + (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) + '(((eq? . 2) . eq?) + ((eqv? . 2) . eqv?) + ((equal? . 2) . equal?) + ((= . 2) . ee?) + ((< . 2) . lt?) + ((> . 2) . gt?) + ((<= . 2) . le?) + ((>= . 2) . ge?) + ((+ . 2) . add) + ((- . 2) . sub) + ((* . 2) . mul) + ((/ . 2) . div) + ((quotient . 2) . quo) + ((remainder . 2) . rem) + ((modulo . 2) . mod) + ((not . 1) . not) + ((pair? . 1) . pair?) + ((cons . 2) . cons) + ((car . 1) . car) + ((cdr . 1) . cdr) + ((set-car! . 2) . set-car!) + ((set-cdr! . 2) . set-cdr!) + ((null? . 1) . null?) + ((list? . 1) . list?))) + (define (make-label) (gensym ":L")) (define (vars->bind-list ids vars allocation) @@ -152,12 +178,23 @@ (lp (cdr exps)))))) (( src proc args) - (comp-push proc) - (for-each comp-push args) - (emit-code src (make-glil-call (case context - ((tail) 'goto/args) - (else 'call)) - (length args)))) + (cond + ((and (primitive-ref? proc) + (hash-ref *primcall-ops* + (cons (primitive-ref-name proc) (length args)))) + => (lambda (op) + (for-each comp-push args) + (emit-code src (make-glil-call op (length args))) + (case context + ((tail) (emit-code #f (make-glil-call 'return 1))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))))) + (else + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call (case context + ((tail) 'goto/args) + (else 'call)) + (length args)))))) (( src test then else) ;; TEST diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm index 5dae355e6..4777431e5 100644 --- a/module/system/base/pmatch.scm +++ b/module/system/base/pmatch.scm @@ -16,15 +16,15 @@ (let ((v (op arg ...))) (pmatch v cs ...))) ((_ v) (if #f #f)) - ((_ v (else e0 e ...)) (begin e0 e ...)) + ((_ v (else e0 e ...)) (let () e0 e ...)) ((_ v (pat (guard g ...) e0 e ...) cs ...) (let ((fk (lambda () (pmatch v cs ...)))) (ppat v pat - (if (and g ...) (begin e0 e ...) (fk)) + (if (and g ...) (let () e0 e ...) (fk)) (fk)))) ((_ v (pat e0 e ...) cs ...) (let ((fk (lambda () (pmatch v cs ...)))) - (ppat v pat (begin e0 e ...) (fk)))))) + (ppat v pat (let () e0 e ...) (fk)))))) (define-syntax ppat (syntax-rules (_ quote unquote) From dce042f1f74f8ef5ca5089beb50fd7496feae5da Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 18 May 2009 01:08:34 +0200 Subject: [PATCH 109/375] special cases for more types of known applications * module/language/tree-il/compile-glil.scm (flatten): Handle a number of interesting applications, and fix a bug for calls in `drop' contexts. * module/language/tree-il/inline.scm: Define expanders for apply, call-with-values, call-with-current-continuation, and values. --- module/language/tree-il/compile-glil.scm | 78 +++++++++++++++++++++--- module/language/tree-il/inline.scm | 15 ++++- 2 files changed, 83 insertions(+), 10 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 23d05c330..b617bd899 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -30,10 +30,6 @@ ;;; TODO: ;; -;; * ([@]apply f args) -> goto/apply or similar -;; * ([@]apply values args) -> goto/values or similar -;; * ([@]call-with-values prod cons) ... -;; * ([@]call-with-current-continuation prod cons) ... ;; call-with-values -> mv-bind ;; compile-time-environment ;; GOOPS' @slot-ref, @slot-set @@ -178,7 +174,71 @@ (lp (cdr exps)))))) (( src proc args) + ;; FIXME: need a better pattern-matcher here (cond + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@apply) + (>= (length args) 2)) + (let ((proc (car args)) + (args (cdr args))) + (cond + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (apply values '(1 2))) + ;; drop: (lambda () (apply values '(1 2)) 3) + ;; push: (lambda () (list (apply values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values* (length args)))))) + + (else + (comp-push proc) + (for-each comp-push args) + (case context + ((drop) (emit-code src (make-glil-call 'apply (length args))) + (emit-code src (make-glil-call 'drop 1))) + ((tail) (emit-code src (make-glil-call 'goto/apply (length args)))) + ((push) (emit-code src (make-glil-call 'apply (length args))))))))) + + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2)) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label)) + (producer (car args)) (consumer (cadr args))) + (comp-push consumer) + (comp-push producer) + (emit-code src (make-glil-mv-call 0 MV)) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args 1))) + (else (emit-code src (make-glil-call 'call 1)) + (emit-branch #f 'br POST))) + (emit-label MV) + (case context + ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) + (else (emit-code src (make-glil-call 'call/nargs 0)) + (emit-label POST) + (if (eq? context 'drop) + (emit-code #f (make-glil-call 'drop 1))))))) + + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-current-continuation) + (= (length args 1))) + (comp-push (car args)) + (case context + ((tail) (emit-code src (make-glil-call 'goto/cc 1))) + ((push) (emit-code src (make-glil-call 'call/cc 1))) + ((drop) (emit-code src (make-glil-call 'call/cc 1)) + (emit-code src (make-glil-call 'drop 1))))) + ((and (primitive-ref? proc) (hash-ref *primcall-ops* (cons (primitive-ref-name proc) (length args)))) @@ -191,10 +251,12 @@ (else (comp-push proc) (for-each comp-push args) - (emit-code src (make-glil-call (case context - ((tail) 'goto/args) - (else 'call)) - (length args)))))) + (let ((len (length args))) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args len))) + ((push) (emit-code src (make-glil-call 'call len))) + ((drop) (emit-code src (make-glil-call 'call len)) + (emit-code src (make-glil-call 'drop 1)))))))) (( src test then else) ;; TEST diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index 0161faf02..d0fa74fab 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -135,5 +135,16 @@ (x y) (cons x y) (x y . rest) (cons x (cons* y . rest))) -(define-primitive-expander acons - (x y z) (cons (cons x y) z)) +(define-primitive-expander acons (x y z) + (cons (cons x y) z)) + +(define-primitive-expander apply (f . args) + (@apply f . args)) + +(define-primitive-expander call-with-values (producer consumer) + (@call-with-values producer consumer)) + +(define-primitive-expander call-with-current-continuation (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander values (x) x) From ce09ee19892d391f3b2ca13e0616d343929c2c14 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 18 May 2009 23:45:35 +0200 Subject: [PATCH 110/375] add tree-il->glil compilation test suite * module/language/tree-il.scm (parse-tree-il): Fix a number of bugs. (unparse-tree-il): Apply takes rest args now. * module/language/tree-il/analyze.scm (analyze-lexicals) (analyze-lexicals): Heap vars shouldn't increment the number of locals. * module/language/tree-il/optimize.scm (resolve-primitives!): Don't resolve public refs to primitives, not at the moment anyway. * test-suite/Makefile.am (SCM_TESTS): Add tree-il test. * test-suite/lib.scm (pass-if, expect-fail, pass-if-exception) (expect-fail-exception): Rewrite as syntax-rules macros. In a very amusing turn of events, it turns out that bindings introduced by hygienic macros are not visible inside expansions produced by defmacros. This seems to be expected, so go ahead and work around the problem. * test-suite/tests/srfi-31.test ("rec special form"): Expand in eval. * test-suite/tests/syntax.test ("begin"): Do some more expanding in eval, though all is not yet well. * test-suite/tests/tree-il.test: New test suite, for tree-il->glil compilation. --- module/language/tree-il.scm | 20 +- module/language/tree-il/analyze.scm | 8 +- module/language/tree-il/optimize.scm | 4 +- test-suite/Makefile.am | 1 + test-suite/lib.scm | 40 +-- test-suite/tests/srfi-31.test | 2 +- test-suite/tests/syntax.test | 24 +- test-suite/tests/tree-il.test | 366 +++++++++++++++++++++++++++ 8 files changed, 426 insertions(+), 39 deletions(-) create mode 100644 test-suite/tests/tree-il.test diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 9b36f1808..a89d8cfd6 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -83,15 +83,15 @@ (assq-ref props 'column) (assq-ref props 'filename)))))) -(define (parse-tree-il env exp) +(define (parse-tree-il exp) (let ((loc (location exp)) - (retrans (lambda (x) (parse-ghil env x)))) + (retrans (lambda (x) (parse-tree-il x)))) (pmatch exp ((void) (make-void loc)) - ((apply ,proc ,args) - (make-application loc (retrans proc) (retrans args))) + ((apply ,proc . ,args) + (make-application loc (retrans proc) (map retrans args))) ((if ,test ,then ,else) (make-conditional loc (retrans test) (retrans then) (retrans else))) @@ -117,16 +117,16 @@ ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) (make-module-ref loc mod name #f)) - ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) (make-module-set loc mod name #f (retrans exp))) ((toplevel ,name) (guard (symbol? name)) (make-toplevel-ref loc name)) - ((set! (toplevel ,name) exp) (guard (symbol? name)) + ((set! (toplevel ,name) ,exp) (guard (symbol? name)) (make-toplevel-set loc name (retrans exp))) - ((define ,name exp) (guard (symbol? name)) + ((define ,name ,exp) (guard (symbol? name)) (make-toplevel-define loc name (retrans exp))) ((lambda ,names ,vars ,exp) @@ -142,10 +142,10 @@ (make-sequence loc (map retrans exps))) ((let ,names ,vars ,vals ,exp) - (make-let loc names vars vals (retrans exp))) + (make-let loc names vars (map retrans vals) (retrans exp))) ((letrec ,names ,vars ,vals ,exp) - (make-letrec loc names vars vals (retrans exp))) + (make-letrec loc names vars (map retrans vals) (retrans exp))) (else (error "unrecognized tree-il" exp))))) @@ -156,7 +156,7 @@ '(void)) (( proc args) - `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args))) + `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) (( test then else) `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index fdcd190b4..1bd8d15d6 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -167,8 +167,8 @@ allocation v (if binder (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n)))) - (lp (cdr vars) (1+ n))))))) + (cons 'stack n))) + (lp (cdr vars) (if binder n (1+ n))))))))) (( vars vals exp) (let lp ((vars vars) (n n)) @@ -184,8 +184,8 @@ allocation v (if binder (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n)))) - (lp (cdr vars) (1+ n)))))) + (cons 'stack n))) + (lp (cdr vars) (if binder n (1+ n)))))))) (else n))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 14460ebab..e4e4996fc 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -79,7 +79,9 @@ (module-variable mod name)) (make-primitive-ref src name))) (( mod name public?) - (let ((m (if public? (resolve-interface mod) (resolve-module mod)))) + ;; for the moment, we're disabling primitive resolution for + ;; public refs because resolve-interface can raise errors. + (let ((m (and (not public?) (resolve-module mod)))) (and m (hashq-ref *interesting-primitive-vars* (module-variable m name)) (make-primitive-ref src name)))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3854d4ab1..358421aa6 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -93,6 +93,7 @@ SCM_TESTS = tests/alist.test \ tests/syntax.test \ tests/threads.test \ tests/time.test \ + tests/tree-il.test \ tests/unif.test \ tests/version.test \ tests/weaks.test diff --git a/test-suite/lib.scm b/test-suite/lib.scm index c4ddf9e7c..3f09ce48a 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -317,20 +317,24 @@ (set! run-test local-run-test)) ;;; A short form for tests that are expected to pass, taken from Greg. -(defmacro pass-if (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (pass-if (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #t (lambda () ,name)) - `(run-test ,name #t (lambda () ,@rest)))) +(define-syntax pass-if + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (pass-if (even? 2)) + ;; where the body should also be the name. + (run-test 'name #t (lambda () name))) + ((_ name rest ...) + (run-test name #t (lambda () rest ...))))) ;;; A short form for tests that are expected to fail, taken from Greg. -(defmacro expect-fail (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (expect-fail (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #f (lambda () ,name)) - `(run-test ,name #f (lambda () ,@rest)))) +(define-syntax expect-fail + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (expect-fail (even? 2)) + ;; where the body should also be the name. + (run-test 'name #f (lambda () name))) + ((_ name rest ...) + (run-test name #f (lambda () rest ...))))) ;;; A helper function to implement the macros that test for exceptions. (define (run-test-exception name exception expect-pass thunk) @@ -362,12 +366,16 @@ (apply throw key proc message rest)))))))) ;;; A short form for tests that expect a certain exception to be thrown. -(defmacro pass-if-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest))) +(define-syntax pass-if-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #t (lambda () body rest ...))))) ;;; A short form for tests expected to fail to throw a certain exception. -(defmacro expect-fail-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest))) +(define-syntax expect-fail-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #f (lambda () body rest ...))))) ;;;; TEST NAMES diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index bd6977333..b23d3e20f 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -23,7 +23,7 @@ (with-test-prefix "rec special form" (pass-if-exception "bogus variable" '(misc-error . ".*") - (rec #:foo)) + (sc-expand '(rec #:foo))) (pass-if "rec expressions" (let ((ones-list (rec ones (cons 1 (delay ones))))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 1277e5204..2f6eb2433 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -112,8 +112,7 @@ (with-test-prefix "begin" (pass-if "legal (begin)" - (begin) - #t) + (eval '(begin (begin) #t) (interaction-environment))) (with-test-prefix "unmemoization" @@ -137,8 +136,7 @@ (expect-fail-exception "illegal (begin)" exception:bad-body - (if #t (begin)) - #t)) + (eval '(begin (if #t (begin)) #t) (interaction-environment)))) (with-test-prefix "lambda" @@ -1010,9 +1008,21 @@ (do ((n 0 (1+ n))) ((> n 5)) (pass-if n - (let ((cond (make-iterations-cond n))) - (while (cond))) - #t))) + (eval `(letrec ((make-iterations-cond + (lambda (n) + (lambda () + (cond ((not n) + (error "oops, condition re-tested after giving false")) + ((= 0 n) + (set! n #f) + #f) + (else + (set! n (1- n)) + #t)))))) + (let ((cond (make-iterations-cond ,n))) + (while (cond)) + #t)) + (interaction-environment))))) (pass-if "initially false" (while #f diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test new file mode 100644 index 000000000..a92ba923d --- /dev/null +++ b/test-suite/tests/tree-il.test @@ -0,0 +1,366 @@ +;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- +;;;; Andy Wingo --- May 2009 +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite tree-il) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system base pmatch) + #:use-module (language tree-il) + #:use-module (language glil)) + +(define-syntax assert-scheme->glil + (syntax-rules () + ((_ in out) + (let ((tree-il (compile 'in #:from 'scheme #:to 'tree-il))) + (pass-if 'in + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil + (syntax-rules () + ((_ in out) + (pass-if 'in + (let ((tree-il (parse-tree-il 'in))) + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil/pmatch + (syntax-rules () + ((_ in pat test ...) + (let ((exp 'in)) + (pass-if 'in + (let ((glil (unparse-glil + (compile (parse-tree-il exp) + #:from 'tree-il #:to 'glil)))) + (pmatch glil + (pat (guard test ...) #t) + (else #f)))))))) + + +(with-test-prefix "void" + (assert-tree-il->glil + (void) + (program 0 0 0 0 () (void) (call return 1))) + (assert-tree-il->glil + (begin (void) (const 1)) + (program 0 0 0 0 () (const 1) (call return 1))) + (assert-tree-il->glil + (apply (primitive +) (void) (const 1)) + (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + +(with-test-prefix "application" + (assert-tree-il->glil + (apply (toplevel foo) (const 1)) + (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) + (assert-tree-il->glil + (begin (apply (toplevel foo) (const 1)) (void)) + (program 0 0 0 0 () (toplevel ref foo) (const 1) (call call 1) + (call drop 1) (void) (call return 1))) + (assert-tree-il->glil + (apply (toplevel foo) (apply (toplevel bar))) + (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) + (call goto/args 1)))) + +(with-test-prefix "conditional" + (assert-tree-il->glil/pmatch + (if (const #t) (const 1) (const 2)) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (call return 1) + (label ,l2) (const 2) (call return 1)) + (eq? l1 l2)) + + (assert-tree-il->glil/pmatch + (begin (if (const #t) (const 1) (const 2)) (const #f)) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) + (label ,l3) (label ,l4) (const #f) (call return 1)) + (eq? l1 l3) (eq? l2 l4)) + + (assert-tree-il->glil/pmatch + (apply (primitive null?) (if (const #t) (const 1) (const 2))) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (branch br ,l2) + (label ,l3) (const 2) (label ,l4) + (call null? 1) (call return 1)) + (eq? l1 l3) (eq? l2 l4))) + +(with-test-prefix "primitive-ref" + (assert-tree-il->glil + (primitive +) + (program 0 0 0 0 () (module private ref (guile) +) (call return 1))) + + (assert-tree-il->glil + (begin (primitive +) (const #f)) + (program 0 0 0 0 () (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (primitive +)) + (program 0 0 0 0 () (module private ref (guile) +) (call null? 1) + (call return 1)))) + +(with-test-prefix "lexical refs" + (assert-tree-il->glil + (let (x) (y) ((const 1)) (lexical x y)) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (const #f) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "lexical sets" + (assert-tree-il->glil + (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (void) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (const #f) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) + (apply (primitive null?) (set! (lexical x y) (const 2)))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (void) (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "module refs" + (assert-tree-il->glil + (@ (foo) bar) + (program 0 0 0 0 () + (module public ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@ (foo) bar) (const #f)) + (program 0 0 0 0 () + (module public ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@ (foo) bar)) + (program 0 0 0 0 () + (module public ref (foo) bar) + (call null? 1) (call return 1))) + + (assert-tree-il->glil + (@@ (foo) bar) + (program 0 0 0 0 () + (module private ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@@ (foo) bar) (const #f)) + (program 0 0 0 0 () + (module private ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@@ (foo) bar)) + (program 0 0 0 0 () + (module private ref (foo) bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "module sets" + (assert-tree-il->glil + (set! (@ (foo) bar) (const 2)) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@ (foo) bar) (const 2))) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call null? 1) (call return 1))) + + (assert-tree-il->glil + (set! (@@ (foo) bar) (const 2)) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel refs" + (assert-tree-il->glil + (toplevel bar) + (program 0 0 0 0 () + (toplevel ref bar) + (call return 1))) + + (assert-tree-il->glil + (begin (toplevel bar) (const #f)) + (program 0 0 0 0 () + (toplevel ref bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (toplevel bar)) + (program 0 0 0 0 () + (toplevel ref bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel sets" + (assert-tree-il->glil + (set! (toplevel bar) (const 2)) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (toplevel bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (toplevel bar) (const 2))) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel defines" + (assert-tree-il->glil + (define bar (const 2)) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (define bar (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (define bar (const 2))) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "constants" + (assert-tree-il->glil + (const 2) + (program 0 0 0 0 () + (const 2) (call return 1))) + + (assert-tree-il->glil + (begin (const 2) (const #f)) + (program 0 0 0 0 () + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (const 2)) + (program 0 0 0 0 () + (const 2) (call null? 1) (call return 1)))) + +(with-test-prefix "lambda" + (assert-tree-il->glil + (lambda (x) (y) () (const 2)) + (program 0 0 0 0 () + (program 1 0 1 0 () + (bind (x local 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x x1) (y y1) () (const 2)) + (program 0 0 0 0 () + (program 2 0 2 0 () + (bind (x local 0) (x1 local 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda x y () (const 2)) + (program 0 0 0 0 () + (program 1 1 1 0 () + (bind (x local 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (const 2)) + (program 0 0 0 0 () + (program 2 1 2 0 () + (bind (x local 0) (x1 local 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x y)) + (program 0 0 0 0 () + (program 2 1 2 0 () + (bind (x local 0) (x1 local 1)) + (local ref 0) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x1 y1)) + (program 0 0 0 0 () + (program 2 1 2 0 () + (bind (x local 0) (x1 local 1)) + (local ref 1) (call return 1)) + (call return 1)))) + +(with-test-prefix "sequence" + (assert-tree-il->glil + (begin (begin (const 2) (const #f)) (const #t)) + (program 0 0 0 0 () + (const #t) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (begin (const #f) (const 2))) + (program 0 0 0 0 () + (const 2) (call null? 1) (call return 1)))) From a1a482e0e9518b5711bc2734aa014254f9207919 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 11:15:22 +0200 Subject: [PATCH 111/375] and, or, cond etc use syntax-rules, compile scheme through tree-il * libguile/vm-i-system.c: * libguile/vm-engine.h (ASSERT_BOUND): New assertion, that a value is bound. Used by local-ref and external-ref in paranoid mode. * module/ice-9/boot-9.scm (and, or, cond, case, do): Since we are switching to use psyntax as the first pass of the compiler, and perhaps soon of the interpreter too, we need to make sure it expands out all forms to primitive expressions. So define expanders for these derived syntax forms, as in the R5RS report. * module/ice-9/psyntax-pp.scm: Regenerate, with core forms fully expanded. * module/ice-9/psyntax.scm (build-void): New constructor, for making undefined values. (build-primref): Add in a hack so that primitive refs in the boot module expand out to toplevel refs, not module refs. (chi-void): Use build-void. (if): Define an expander for if that calls build-conditional. * module/language/scheme/compile-tree-il.scm (compile-tree-il): Use let* so as not to depend on binding order for the result of (current-module). * module/language/scheme/spec.scm (scheme): Switch over to tree-il as the primary intermediate language. Not yet fully tested, but at least it can compile psyntax-pp.scm. * module/language/tree-il/analyze.scm (analyze-lexicals): Arguments don't count towards a function's nlocs. * module/language/tree-il/compile-glil.scm (*comp-module*, compile-glil): Define a "compilation module" fluid. (flatten-lambda): Fix a call to make-glil-argument. Fix bug in heapifying arguments. (flatten): Fix number of arguments passed to apply instruction. Add a special case for `(values ...)'. If inlining primitive-refs fails, try expanding into toplevel-refs if the comp-module's variable is the same as the root variable. * module/language/tree-il/optimize.scm (resolve-primitives!): Add missing src variable for . * test-suite/tests/tree-il.test ("lambda"): Fix nlocs counts. Add a closure test case. --- libguile/vm-engine.h | 4 ++ libguile/vm-i-system.c | 2 + module/ice-9/boot-9.scm | 81 ++++++++++++++++++++++ module/ice-9/psyntax-pp.scm | 22 +++--- module/ice-9/psyntax.scm | 35 ++++++++-- module/language/scheme/compile-tree-il.scm | 6 +- module/language/scheme/spec.scm | 6 +- module/language/tree-il/analyze.scm | 2 +- module/language/tree-il/compile-glil.scm | 55 +++++++++++---- module/language/tree-il/optimize.scm | 2 +- test-suite/tests/tree-il.test | 28 +++++--- 11 files changed, 197 insertions(+), 46 deletions(-) diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 6bb235401..fbd2c6c75 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -147,8 +147,12 @@ #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) +#define ASSERT_BOUND(x) \ + do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \ + } while (0) #else #define CHECK_IP() +#define ASSERT_BOUND(x) #endif /* Get a local copy of the program's "object table" (i.e. the vector of diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 5468604d2..a6cb66dbc 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); + ASSERT_BOUND (*sp); NEXT; } @@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1) } CHECK_EXTERNAL(e); PUSH (SCM_CAR (e)); + ASSERT_BOUND (*sp); NEXT; } diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 94a9a39e2..cdd840f14 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -210,6 +210,87 @@ ;; module system has booted up. (define %pre-modules-transformer sc-expand) +(define-syntax and + (syntax-rules () + ((_) #t) + ((_ x) x) + ((_ x y ...) (if x (and y ...) #f)))) + +(define-syntax or + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x y ...) (let ((t x)) (if t t (or y ...)))))) + +(define-syntax cond + (syntax-rules (else =>) + ((cond (else result1 result2 ...)) + (begin result1 result2 ...)) + ((cond (test => result)) + (let ((temp test)) + (if temp (result temp)))) + ((cond (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp + (result temp) + (cond clause1 clause2 ...)))) + ((cond (test)) test) + ((cond (test) clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (cond clause1 clause2 ...)))) + ((cond (test result1 result2 ...)) + (if test (begin result1 result2 ...))) + ((cond (test result1 result2 ...) + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (cond clause1 clause2 ...))))) + +(define-syntax case + (syntax-rules (else) + ((case (key ...) + clauses ...) + (let ((atom-key (key ...))) + (case atom-key clauses ...))) + ((case key + (else result1 result2 ...)) + (begin result1 result2 ...)) + ((case key + ((atoms ...) result1 result2 ...)) + (if (memv key '(atoms ...)) + (begin result1 result2 ...))) + ((case key + ((atoms ...) result1 result2 ...) + clause clauses ...) + (if (memv key '(atoms ...)) + (begin result1 result2 ...) + (case key clause clauses ...))))) + +(define-syntax do + (syntax-rules () + ((do ((var init step ...) ...) + (test expr ...) + command ...) + (letrec + ((loop + (lambda (var ...) + (if test + (begin + (if #f #f) + expr ...) + (begin + command + ... + (loop (do "step" var step ...) + ...)))))) + (loop init ...))) + ((do "step" x) + x) + ((do "step" x y) + y))) + (define-syntax delay (syntax-rules () ((_ exp) (make-promise (lambda () exp))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 55064eec8..829812eda 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (letrec ((andmap58 (lambda (first59) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))))) (andmap58 first56)) (letrec ((andmap62 (lambda (first63 rest64) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68))))))) (andmap62 first56 rest55))))))) (letrec ((lambda-var-list160 (lambda (vars289) (letrec ((lvl290 (lambda (vars291 ls292 w293) (cond ((pair? vars291) (lvl290 (cdr vars291) (cons (wrap139 (car vars291) w293 #f) ls292) w293)) ((id?111 vars291) (cons (wrap139 vars291 w293 #f) ls292)) ((null? vars291) ls292) ((syntax-object?95 vars291) (lvl290 (syntax-object-expression96 vars291) ls292 (join-wraps130 w293 (syntax-object-wrap97 vars291)))) ((annotation? vars291) (lvl290 (annotation-expression vars291) ls292 w293)) (else (cons vars291 ls292)))))) (lvl290 vars289 (quote ()) (quote (())))))) (gen-var159 (lambda (id294) (let ((id295 (if (syntax-object?95 id294) (syntax-object-expression96 id294) id294))) (if (annotation? id295) (gensym (symbol->string (annotation-expression id295))) (gensym (symbol->string id295)))))) (strip158 (lambda (x296 w297) (if (memq (quote top) (wrap-marks114 w297)) (if (or (annotation? x296) (and (pair? x296) (annotation? (car x296)))) (strip-annotation157 x296 #f) x296) (letrec ((f298 (lambda (x299) (cond ((syntax-object?95 x299) (strip158 (syntax-object-expression96 x299) (syntax-object-wrap97 x299))) ((pair? x299) (let ((a300 (f298 (car x299))) (d301 (f298 (cdr x299)))) (if (and (eq? a300 (car x299)) (eq? d301 (cdr x299))) x299 (cons a300 d301)))) ((vector? x299) (let ((old302 (vector->list x299))) (let ((new303 (map f298 old302))) (if (and-map*17 eq? old302 new303) x299 (list->vector new303))))) (else x299))))) (f298 x296))))) (strip-annotation157 (lambda (x304 parent305) (cond ((pair? x304) (let ((new306 (cons #f #f))) (begin (if parent305 (set-annotation-stripped! parent305 new306)) (set-car! new306 (strip-annotation157 (car x304) #f)) (set-cdr! new306 (strip-annotation157 (cdr x304) #f)) new306))) ((annotation? x304) (or (annotation-stripped x304) (strip-annotation157 (annotation-expression x304) x304))) ((vector? x304) (let ((new307 (make-vector (vector-length x304)))) (begin (if parent305 (set-annotation-stripped! parent305 new307)) (letrec ((loop308 (lambda (i309) (unless (fx<74 i309 0) (vector-set! new307 i309 (strip-annotation157 (vector-ref x304 i309) #f)) (loop308 (fx-72 i309 1)))))) (loop308 (- (vector-length x304) 1))) new307))) (else x304)))) (ellipsis?156 (lambda (x310) (and (nonsymbol-id?110 x310) (free-id=?134 x310 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void155 (lambda () (build-application79 #f (build-primref88 #f (quote if)) (quote (#f #f))))) (eval-local-transformer154 (lambda (expanded311 mod312) (let ((p313 (local-eval-hook76 expanded311 mod312))) (if (procedure? p313) p313 (syntax-violation #f "nonprocedure transformer" p313))))) (chi-local-syntax153 (lambda (rec?314 e315 r316 w317 s318 mod319 k320) ((lambda (tmp321) ((lambda (tmp322) (if tmp322 (apply (lambda (_323 id324 val325 e1326 e2327) (let ((ids328 id324)) (if (not (valid-bound-ids?136 ids328)) (syntax-violation #f "duplicate bound keyword" e315) (let ((labels330 (gen-labels117 ids328))) (let ((new-w331 (make-binding-wrap128 ids328 labels330 w317))) (k320 (cons e1326 e2327) (extend-env105 labels330 (let ((w333 (if rec?314 new-w331 w317)) (trans-r334 (macros-only-env107 r316))) (map (lambda (x335) (cons (quote macro) (eval-local-transformer154 (chi147 x335 trans-r334 w333 mod319) mod319))) val325)) r316) new-w331 s318 mod319)))))) tmp322) ((lambda (_337) (syntax-violation #f "bad local syntax definition" (source-wrap140 e315 w317 s318 mod319))) tmp321))) ($sc-dispatch tmp321 (quote (any #(each (any any)) any . each-any))))) e315))) (chi-lambda-clause152 (lambda (e338 docstring339 c340 r341 w342 mod343 k344) ((lambda (tmp345) ((lambda (tmp346) (if (if tmp346 (apply (lambda (args347 doc348 e1349 e2350) (and (string? (syntax->datum doc348)) (not docstring339))) tmp346) #f) (apply (lambda (args351 doc352 e1353 e2354) (chi-lambda-clause152 e338 doc352 (cons args351 (cons e1353 e2354)) r341 w342 mod343 k344)) tmp346) ((lambda (tmp356) (if tmp356 (apply (lambda (id357 e1358 e2359) (let ((ids360 id357)) (if (not (valid-bound-ids?136 ids360)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels362 (gen-labels117 ids360)) (new-vars363 (map gen-var159 ids360))) (k344 (map syntax->datum ids360) new-vars363 docstring339 (chi-body151 (cons e1358 e2359) e338 (extend-var-env106 labels362 new-vars363 r341) (make-binding-wrap128 ids360 labels362 w342) mod343)))))) tmp356) ((lambda (tmp365) (if tmp365 (apply (lambda (ids366 e1367 e2368) (let ((old-ids369 (lambda-var-list160 ids366))) (if (not (valid-bound-ids?136 old-ids369)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels370 (gen-labels117 old-ids369)) (new-vars371 (map gen-var159 old-ids369))) (k344 (letrec ((f372 (lambda (ls1373 ls2374) (if (null? ls1373) (syntax->datum ls2374) (f372 (cdr ls1373) (cons (syntax->datum (car ls1373)) ls2374)))))) (f372 (cdr old-ids369) (car old-ids369))) (letrec ((f375 (lambda (ls1376 ls2377) (if (null? ls1376) ls2377 (f375 (cdr ls1376) (cons (car ls1376) ls2377)))))) (f375 (cdr new-vars371) (car new-vars371))) docstring339 (chi-body151 (cons e1367 e2368) e338 (extend-var-env106 labels370 new-vars371 r341) (make-binding-wrap128 old-ids369 labels370 w342) mod343)))))) tmp365) ((lambda (_379) (syntax-violation (quote lambda) "bad lambda" e338)) tmp345))) ($sc-dispatch tmp345 (quote (any any . each-any)))))) ($sc-dispatch tmp345 (quote (each-any any . each-any)))))) ($sc-dispatch tmp345 (quote (any any any . each-any))))) c340))) (chi-body151 (lambda (body380 outer-form381 r382 w383 mod384) (let ((r385 (cons (quote ("placeholder" placeholder)) r382))) (let ((ribcage386 (make-ribcage118 (quote ()) (quote ()) (quote ())))) (let ((w387 (make-wrap113 (wrap-marks114 w383) (cons ribcage386 (wrap-subst115 w383))))) (letrec ((parse388 (lambda (body389 ids390 labels391 vars392 vals393 bindings394) (if (null? body389) (syntax-violation #f "no expressions in body" outer-form381) (let ((e396 (cdar body389)) (er397 (caar body389))) (call-with-values (lambda () (syntax-type145 e396 er397 (quote (())) #f ribcage386 mod384)) (lambda (type398 value399 e400 w401 s402 mod403) (let ((t404 type398)) (if (memv t404 (quote (define-form))) (let ((id405 (wrap139 value399 w401 mod403)) (label406 (gen-label116))) (let ((var407 (gen-var159 id405))) (begin (extend-ribcage!127 ribcage386 id405 label406) (parse388 (cdr body389) (cons id405 ids390) (cons label406 labels391) (cons var407 vars392) (cons (cons er397 (wrap139 e400 w401 mod403)) vals393) (cons (cons (quote lexical) var407) bindings394))))) (if (memv t404 (quote (define-syntax-form))) (let ((id408 (wrap139 value399 w401 mod403)) (label409 (gen-label116))) (begin (extend-ribcage!127 ribcage386 id408 label409) (parse388 (cdr body389) (cons id408 ids390) (cons label409 labels391) vars392 vals393 (cons (cons (quote macro) (cons er397 (wrap139 e400 w401 mod403))) bindings394)))) (if (memv t404 (quote (begin-form))) ((lambda (tmp410) ((lambda (tmp411) (if tmp411 (apply (lambda (_412 e1413) (parse388 (letrec ((f414 (lambda (forms415) (if (null? forms415) (cdr body389) (cons (cons er397 (wrap139 (car forms415) w401 mod403)) (f414 (cdr forms415))))))) (f414 e1413)) ids390 labels391 vars392 vals393 bindings394)) tmp411) (syntax-violation #f "source expression failed to match any pattern" tmp410))) ($sc-dispatch tmp410 (quote (any . each-any))))) e400) (if (memv t404 (quote (local-syntax-form))) (chi-local-syntax153 value399 e400 er397 w401 s402 mod403 (lambda (forms417 er418 w419 s420 mod421) (parse388 (letrec ((f422 (lambda (forms423) (if (null? forms423) (cdr body389) (cons (cons er418 (wrap139 (car forms423) w419 mod421)) (f422 (cdr forms423))))))) (f422 forms417)) ids390 labels391 vars392 vals393 bindings394))) (if (null? ids390) (build-sequence90 #f (map (lambda (x424) (chi147 (cdr x424) (car x424) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389)))) (begin (if (not (valid-bound-ids?136 ids390)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form381)) (letrec ((loop425 (lambda (bs426 er-cache427 r-cache428) (if (not (null? bs426)) (let ((b429 (car bs426))) (if (eq? (car b429) (quote macro)) (let ((er430 (cadr b429))) (let ((r-cache431 (if (eq? er430 er-cache427) r-cache428 (macros-only-env107 er430)))) (begin (set-cdr! b429 (eval-local-transformer154 (chi147 (cddr b429) r-cache431 (quote (())) mod403) mod403)) (loop425 (cdr bs426) er430 r-cache431)))) (loop425 (cdr bs426) er-cache427 r-cache428))))))) (loop425 bindings394 #f #f)) (set-cdr! r385 (extend-env105 labels391 bindings394 (cdr r385))) (build-letrec93 #f (map syntax->datum ids390) vars392 (map (lambda (x432) (chi147 (cdr x432) (car x432) (quote (())) mod403)) vals393) (build-sequence90 #f (map (lambda (x433) (chi147 (cdr x433) (car x433) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389))))))))))))))))))) (parse388 (map (lambda (x395) (cons r385 (wrap139 x395 w387 mod384))) body380) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro150 (lambda (p434 e435 r436 w437 rib438 mod439) (letrec ((rebuild-macro-output440 (lambda (x441 m442) (cond ((pair? x441) (cons (rebuild-macro-output440 (car x441) m442) (rebuild-macro-output440 (cdr x441) m442))) ((syntax-object?95 x441) (let ((w443 (syntax-object-wrap97 x441))) (let ((ms444 (wrap-marks114 w443)) (s445 (wrap-subst115 w443))) (if (and (pair? ms444) (eq? (car ms444) #f)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cdr ms444) (if rib438 (cons rib438 (cdr s445)) (cdr s445))) (syntax-object-module98 x441)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cons m442 ms444) (if rib438 (cons rib438 (cons (quote shift) s445)) (cons (quote shift) s445))) (let ((pmod446 (procedure-module p434))) (if pmod446 (cons (quote hygiene) (module-name pmod446)) (quote (hygiene guile))))))))) ((vector? x441) (let ((n447 (vector-length x441))) (let ((v448 (make-vector n447))) (letrec ((doloop449 (lambda (i450) (if (fx=73 i450 n447) v448 (begin (vector-set! v448 i450 (rebuild-macro-output440 (vector-ref x441 i450) m442)) (doloop449 (fx+71 i450 1))))))) (doloop449 0))))) ((symbol? x441) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap140 e435 w437 s mod439) x441)) (else x441))))) (rebuild-macro-output440 (p434 (wrap139 e435 (anti-mark126 w437) mod439)) (string #\m))))) (chi-application149 (lambda (x451 e452 r453 w454 s455 mod456) ((lambda (tmp457) ((lambda (tmp458) (if tmp458 (apply (lambda (e0459 e1460) (build-application79 s455 x451 (map (lambda (e461) (chi147 e461 r453 w454 mod456)) e1460))) tmp458) (syntax-violation #f "source expression failed to match any pattern" tmp457))) ($sc-dispatch tmp457 (quote (any . each-any))))) e452))) (chi-expr148 (lambda (type463 value464 e465 r466 w467 s468 mod469) (let ((t470 type463)) (if (memv t470 (quote (lexical))) (build-lexical-reference81 (quote value) s468 e465 value464) (if (memv t470 (quote (core external-macro))) (value464 e465 r466 w467 s468 mod469) (if (memv t470 (quote (module-ref))) (call-with-values (lambda () (value464 e465)) (lambda (id471 mod472) (build-global-reference84 s468 id471 mod472))) (if (memv t470 (quote (lexical-call))) (chi-application149 (build-lexical-reference81 (quote fun) (source-annotation102 (car e465)) (car e465) value464) e465 r466 w467 s468 mod469) (if (memv t470 (quote (global-call))) (chi-application149 (build-global-reference84 (source-annotation102 (car e465)) value464 (if (syntax-object?95 (car e465)) (syntax-object-module98 (car e465)) mod469)) e465 r466 w467 s468 mod469) (if (memv t470 (quote (constant))) (build-data89 s468 (strip158 (source-wrap140 e465 w467 s468 mod469) (quote (())))) (if (memv t470 (quote (global))) (build-global-reference84 s468 value464 mod469) (if (memv t470 (quote (call))) (chi-application149 (chi147 (car e465) r466 w467 mod469) e465 r466 w467 s468 mod469) (if (memv t470 (quote (begin-form))) ((lambda (tmp473) ((lambda (tmp474) (if tmp474 (apply (lambda (_475 e1476 e2477) (chi-sequence141 (cons e1476 e2477) r466 w467 s468 mod469)) tmp474) (syntax-violation #f "source expression failed to match any pattern" tmp473))) ($sc-dispatch tmp473 (quote (any any . each-any))))) e465) (if (memv t470 (quote (local-syntax-form))) (chi-local-syntax153 value464 e465 r466 w467 s468 mod469 chi-sequence141) (if (memv t470 (quote (eval-when-form))) ((lambda (tmp479) ((lambda (tmp480) (if tmp480 (apply (lambda (_481 x482 e1483 e2484) (let ((when-list485 (chi-when-list144 e465 x482 w467))) (if (memq (quote eval) when-list485) (chi-sequence141 (cons e1483 e2484) r466 w467 s468 mod469) (chi-void155)))) tmp480) (syntax-violation #f "source expression failed to match any pattern" tmp479))) ($sc-dispatch tmp479 (quote (any each-any any . each-any))))) e465) (if (memv t470 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e465 (wrap139 value464 w467 mod469)) (if (memv t470 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap140 e465 w467 s468 mod469)) (if (memv t470 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap140 e465 w467 s468 mod469)) (syntax-violation #f "unexpected syntax" (source-wrap140 e465 w467 s468 mod469))))))))))))))))))) (chi147 (lambda (e488 r489 w490 mod491) (call-with-values (lambda () (syntax-type145 e488 r489 w490 #f #f mod491)) (lambda (type492 value493 e494 w495 s496 mod497) (chi-expr148 type492 value493 e494 r489 w495 s496 mod497))))) (chi-top146 (lambda (e498 r499 w500 m501 esew502 mod503) (call-with-values (lambda () (syntax-type145 e498 r499 w500 #f #f mod503)) (lambda (type511 value512 e513 w514 s515 mod516) (let ((t517 type511)) (if (memv t517 (quote (begin-form))) ((lambda (tmp518) ((lambda (tmp519) (if tmp519 (apply (lambda (_520) (chi-void155)) tmp519) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 e1523 e2524) (chi-top-sequence142 (cons e1523 e2524) r499 w514 s515 m501 esew502 mod516)) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp518))) ($sc-dispatch tmp518 (quote (any any . each-any)))))) ($sc-dispatch tmp518 (quote (any))))) e513) (if (memv t517 (quote (local-syntax-form))) (chi-local-syntax153 value512 e513 r499 w514 s515 mod516 (lambda (body526 r527 w528 s529 mod530) (chi-top-sequence142 body526 r527 w528 s529 m501 esew502 mod530))) (if (memv t517 (quote (eval-when-form))) ((lambda (tmp531) ((lambda (tmp532) (if tmp532 (apply (lambda (_533 x534 e1535 e2536) (let ((when-list537 (chi-when-list144 e513 x534 w514)) (body538 (cons e1535 e2536))) (cond ((eq? m501 (quote e)) (if (memq (quote eval) when-list537) (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) (chi-void155))) ((memq (quote load) when-list537) (if (or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (chi-top-sequence142 body538 r499 w514 s515 (quote c&e) (quote (compile load)) mod516) (if (memq m501 (quote (c c&e))) (chi-top-sequence142 body538 r499 w514 s515 (quote c) (quote (load)) mod516) (chi-void155)))) ((or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (top-level-eval-hook75 (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) mod516) (chi-void155)) (else (chi-void155))))) tmp532) (syntax-violation #f "source expression failed to match any pattern" tmp531))) ($sc-dispatch tmp531 (quote (any each-any any . each-any))))) e513) (if (memv t517 (quote (define-syntax-form))) (let ((n541 (id-var-name133 value512 w514)) (r542 (macros-only-env107 r499))) (let ((t543 m501)) (if (memv t543 (quote (c))) (if (memq (quote compile) esew502) (let ((e544 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e544 mod516) (if (memq (quote load) esew502) e544 (chi-void155)))) (if (memq (quote load) esew502) (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) (chi-void155))) (if (memv t543 (quote (c&e))) (let ((e545 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e545 mod516) e545)) (begin (if (memq (quote eval) esew502) (top-level-eval-hook75 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) mod516)) (chi-void155)))))) (if (memv t517 (quote (define-form))) (let ((n546 (id-var-name133 value512 w514))) (let ((type547 (binding-type103 (lookup108 n546 r499 mod516)))) (let ((t548 type547)) (if (memv t548 (quote (global core macro module-ref))) (let ((x549 (build-global-definition86 s515 n546 (chi147 e513 r499 w514 mod516)))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x549 mod516)) x549)) (if (memv t548 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e513 (wrap139 value512 w514 mod516)) (syntax-violation #f "cannot define keyword at top level" e513 (wrap139 value512 w514 mod516))))))) (let ((x550 (chi-expr148 type511 value512 e513 r499 w514 s515 mod516))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x550 mod516)) x550)))))))))))) (syntax-type145 (lambda (e551 r552 w553 s554 rib555 mod556) (cond ((symbol? e551) (let ((n557 (id-var-name133 e551 w553))) (let ((b558 (lookup108 n557 r552 mod556))) (let ((type559 (binding-type103 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value104 b558) e551 w553 s554 mod556) (if (memv t560 (quote (global))) (values type559 n557 e551 w553 s554 mod556) (if (memv t560 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b558) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (values type559 (binding-value104 b558) e551 w553 s554 mod556))))))))) ((pair? e551) (let ((first561 (car e551))) (if (id?111 first561) (let ((n562 (id-var-name133 first561 w553))) (let ((b563 (lookup108 n562 r552 (or (and (syntax-object?95 first561) (syntax-object-module98 first561)) mod556)))) (let ((type564 (binding-type103 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (global))) (values (quote global-call) n562 e551 w553 s554 mod556) (if (memv t565 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b563) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (if (memv t565 (quote (core external-macro module-ref))) (values type564 (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (begin))) (values (quote begin-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?111 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w553 s554 mod556)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?111 name576) (valid-bound-ids?136 (lambda-var-list160 args577)))) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap139 name581 w553 mod556) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap139 (cons args582 (cons e1583 e2584)) w553 mod556)) (quote (())) s554 mod556)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?111 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap139 name590 w553 mod556) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s554 mod556)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e551) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?111 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w553 s554 mod556)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e551) (values (quote call) #f e551 w553 s554 mod556)))))))))))))) (values (quote call) #f e551 w553 s554 mod556)))) ((syntax-object?95 e551) (syntax-type145 (syntax-object-expression96 e551) r552 (join-wraps130 w553 (syntax-object-wrap97 e551)) #f rib555 (or (syntax-object-module98 e551) mod556))) ((annotation? e551) (syntax-type145 (annotation-expression e551) r552 w553 (annotation-source e551) rib555 mod556)) ((self-evaluating? e551) (values (quote constant) #f e551 w553 s554 mod556)) (else (values (quote other) #f e551 w553 s554 mod556))))) (chi-when-list144 (lambda (e599 when-list600 w601) (letrec ((f602 (lambda (when-list603 situations604) (if (null? when-list603) situations604 (f602 (cdr when-list603) (cons (let ((x605 (car when-list603))) (cond ((free-id=?134 x605 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?134 x605 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?134 x605 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e599 (wrap139 x605 w601 #f))))) situations604)))))) (f602 when-list600 (quote ()))))) (chi-install-global143 (lambda (name606 e607) (build-global-definition86 #f name606 (if (let ((v608 (module-variable (current-module) name606))) (and v608 (variable-bound? v608) (macro? (variable-ref v608)) (not (eq? (macro-type (variable-ref v608)) (quote syncase-macro))))) (build-application79 #f (build-primref88 #f (quote make-extended-syncase-macro)) (list (build-application79 #f (build-primref88 #f (quote module-ref)) (list (build-application79 #f (quote current-module) (quote ())) (build-data89 #f name606))) (build-data89 #f (quote macro)) e607)) (build-application79 #f (build-primref88 #f (quote make-syncase-macro)) (list (build-data89 #f (quote macro)) e607)))))) (chi-top-sequence142 (lambda (body609 r610 w611 s612 m613 esew614 mod615) (build-sequence90 s612 (letrec ((dobody616 (lambda (body617 r618 w619 m620 esew621 mod622) (if (null? body617) (quote ()) (let ((first623 (chi-top146 (car body617) r618 w619 m620 esew621 mod622))) (cons first623 (dobody616 (cdr body617) r618 w619 m620 esew621 mod622))))))) (dobody616 body609 r610 w611 m613 esew614 mod615))))) (chi-sequence141 (lambda (body624 r625 w626 s627 mod628) (build-sequence90 s627 (letrec ((dobody629 (lambda (body630 r631 w632 mod633) (if (null? body630) (quote ()) (let ((first634 (chi147 (car body630) r631 w632 mod633))) (cons first634 (dobody629 (cdr body630) r631 w632 mod633))))))) (dobody629 body624 r625 w626 mod628))))) (source-wrap140 (lambda (x635 w636 s637 defmod638) (wrap139 (if s637 (make-annotation x635 s637 #f) x635) w636 defmod638))) (wrap139 (lambda (x639 w640 defmod641) (cond ((and (null? (wrap-marks114 w640)) (null? (wrap-subst115 w640))) x639) ((syntax-object?95 x639) (make-syntax-object94 (syntax-object-expression96 x639) (join-wraps130 w640 (syntax-object-wrap97 x639)) (syntax-object-module98 x639))) ((null? x639) x639) (else (make-syntax-object94 x639 w640 defmod641))))) (bound-id-member?138 (lambda (x642 list643) (and (not (null? list643)) (or (bound-id=?135 x642 (car list643)) (bound-id-member?138 x642 (cdr list643)))))) (distinct-bound-ids?137 (lambda (ids644) (letrec ((distinct?645 (lambda (ids646) (or (null? ids646) (and (not (bound-id-member?138 (car ids646) (cdr ids646))) (distinct?645 (cdr ids646))))))) (distinct?645 ids644)))) (valid-bound-ids?136 (lambda (ids647) (and (letrec ((all-ids?648 (lambda (ids649) (or (null? ids649) (and (id?111 (car ids649)) (all-ids?648 (cdr ids649))))))) (all-ids?648 ids647)) (distinct-bound-ids?137 ids647)))) (bound-id=?135 (lambda (i650 j651) (if (and (syntax-object?95 i650) (syntax-object?95 j651)) (and (eq? (let ((e652 (syntax-object-expression96 i650))) (if (annotation? e652) (annotation-expression e652) e652)) (let ((e653 (syntax-object-expression96 j651))) (if (annotation? e653) (annotation-expression e653) e653))) (same-marks?132 (wrap-marks114 (syntax-object-wrap97 i650)) (wrap-marks114 (syntax-object-wrap97 j651)))) (eq? (let ((e654 i650)) (if (annotation? e654) (annotation-expression e654) e654)) (let ((e655 j651)) (if (annotation? e655) (annotation-expression e655) e655)))))) (free-id=?134 (lambda (i656 j657) (and (eq? (let ((x658 i656)) (let ((e659 (if (syntax-object?95 x658) (syntax-object-expression96 x658) x658))) (if (annotation? e659) (annotation-expression e659) e659))) (let ((x660 j657)) (let ((e661 (if (syntax-object?95 x660) (syntax-object-expression96 x660) x660))) (if (annotation? e661) (annotation-expression e661) e661)))) (eq? (id-var-name133 i656 (quote (()))) (id-var-name133 j657 (quote (()))))))) (id-var-name133 (lambda (id662 w663) (letrec ((search-vector-rib666 (lambda (sym672 subst673 marks674 symnames675 ribcage676) (let ((n677 (vector-length symnames675))) (letrec ((f678 (lambda (i679) (cond ((fx=73 i679 n677) (search664 sym672 (cdr subst673) marks674)) ((and (eq? (vector-ref symnames675 i679) sym672) (same-marks?132 marks674 (vector-ref (ribcage-marks121 ribcage676) i679))) (values (vector-ref (ribcage-labels122 ribcage676) i679) marks674)) (else (f678 (fx+71 i679 1))))))) (f678 0))))) (search-list-rib665 (lambda (sym680 subst681 marks682 symnames683 ribcage684) (letrec ((f685 (lambda (symnames686 i687) (cond ((null? symnames686) (search664 sym680 (cdr subst681) marks682)) ((and (eq? (car symnames686) sym680) (same-marks?132 marks682 (list-ref (ribcage-marks121 ribcage684) i687))) (values (list-ref (ribcage-labels122 ribcage684) i687) marks682)) (else (f685 (cdr symnames686) (fx+71 i687 1))))))) (f685 symnames683 0)))) (search664 (lambda (sym688 subst689 marks690) (if (null? subst689) (values #f marks690) (let ((fst691 (car subst689))) (if (eq? fst691 (quote shift)) (search664 sym688 (cdr subst689) (cdr marks690)) (let ((symnames692 (ribcage-symnames120 fst691))) (if (vector? symnames692) (search-vector-rib666 sym688 subst689 marks690 symnames692 fst691) (search-list-rib665 sym688 subst689 marks690 symnames692 fst691))))))))) (cond ((symbol? id662) (or (call-with-values (lambda () (search664 id662 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x694 . ignore693) x694)) id662)) ((syntax-object?95 id662) (let ((id695 (let ((e697 (syntax-object-expression96 id662))) (if (annotation? e697) (annotation-expression e697) e697))) (w1696 (syntax-object-wrap97 id662))) (let ((marks698 (join-marks131 (wrap-marks114 w663) (wrap-marks114 w1696)))) (call-with-values (lambda () (search664 id695 (wrap-subst115 w663) marks698)) (lambda (new-id699 marks700) (or new-id699 (call-with-values (lambda () (search664 id695 (wrap-subst115 w1696) marks700)) (lambda (x702 . ignore701) x702)) id695)))))) ((annotation? id662) (let ((id703 (let ((e704 id662)) (if (annotation? e704) (annotation-expression e704) e704)))) (or (call-with-values (lambda () (search664 id703 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x706 . ignore705) x706)) id703))) (else (syntax-violation (quote id-var-name) "invalid id" id662)))))) (same-marks?132 (lambda (x707 y708) (or (eq? x707 y708) (and (not (null? x707)) (not (null? y708)) (eq? (car x707) (car y708)) (same-marks?132 (cdr x707) (cdr y708)))))) (join-marks131 (lambda (m1709 m2710) (smart-append129 m1709 m2710))) (join-wraps130 (lambda (w1711 w2712) (let ((m1713 (wrap-marks114 w1711)) (s1714 (wrap-subst115 w1711))) (if (null? m1713) (if (null? s1714) w2712 (make-wrap113 (wrap-marks114 w2712) (smart-append129 s1714 (wrap-subst115 w2712)))) (make-wrap113 (smart-append129 m1713 (wrap-marks114 w2712)) (smart-append129 s1714 (wrap-subst115 w2712))))))) (smart-append129 (lambda (m1715 m2716) (if (null? m2716) m1715 (append m1715 m2716)))) (make-binding-wrap128 (lambda (ids717 labels718 w719) (if (null? ids717) w719 (make-wrap113 (wrap-marks114 w719) (cons (let ((labelvec720 (list->vector labels718))) (let ((n721 (vector-length labelvec720))) (let ((symnamevec722 (make-vector n721)) (marksvec723 (make-vector n721))) (begin (letrec ((f724 (lambda (ids725 i726) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks112 (car ids725) w719)) (lambda (symname727 marks728) (begin (vector-set! symnamevec722 i726 symname727) (vector-set! marksvec723 i726 marks728) (f724 (cdr ids725) (fx+71 i726 1))))))))) (f724 ids717 0)) (make-ribcage118 symnamevec722 marksvec723 labelvec720))))) (wrap-subst115 w719)))))) (extend-ribcage!127 (lambda (ribcage729 id730 label731) (begin (set-ribcage-symnames!123 ribcage729 (cons (let ((e732 (syntax-object-expression96 id730))) (if (annotation? e732) (annotation-expression e732) e732)) (ribcage-symnames120 ribcage729))) (set-ribcage-marks!124 ribcage729 (cons (wrap-marks114 (syntax-object-wrap97 id730)) (ribcage-marks121 ribcage729))) (set-ribcage-labels!125 ribcage729 (cons label731 (ribcage-labels122 ribcage729)))))) (anti-mark126 (lambda (w733) (make-wrap113 (cons #f (wrap-marks114 w733)) (cons (quote shift) (wrap-subst115 w733))))) (set-ribcage-labels!125 (lambda (x734 update735) (vector-set! x734 3 update735))) (set-ribcage-marks!124 (lambda (x736 update737) (vector-set! x736 2 update737))) (set-ribcage-symnames!123 (lambda (x738 update739) (vector-set! x738 1 update739))) (ribcage-labels122 (lambda (x740) (vector-ref x740 3))) (ribcage-marks121 (lambda (x741) (vector-ref x741 2))) (ribcage-symnames120 (lambda (x742) (vector-ref x742 1))) (ribcage?119 (lambda (x743) (and (vector? x743) (= (vector-length x743) 4) (eq? (vector-ref x743 0) (quote ribcage))))) (make-ribcage118 (lambda (symnames744 marks745 labels746) (vector (quote ribcage) symnames744 marks745 labels746))) (gen-labels117 (lambda (ls747) (if (null? ls747) (quote ()) (cons (gen-label116) (gen-labels117 (cdr ls747)))))) (gen-label116 (lambda () (string #\i))) (wrap-subst115 cdr) (wrap-marks114 car) (make-wrap113 cons) (id-sym-name&marks112 (lambda (x748 w749) (if (syntax-object?95 x748) (values (let ((e750 (syntax-object-expression96 x748))) (if (annotation? e750) (annotation-expression e750) e750)) (join-marks131 (wrap-marks114 w749) (wrap-marks114 (syntax-object-wrap97 x748)))) (values (let ((e751 x748)) (if (annotation? e751) (annotation-expression e751) e751)) (wrap-marks114 w749))))) (id?111 (lambda (x752) (cond ((symbol? x752) #t) ((syntax-object?95 x752) (symbol? (let ((e753 (syntax-object-expression96 x752))) (if (annotation? e753) (annotation-expression e753) e753)))) ((annotation? x752) (symbol? (annotation-expression x752))) (else #f)))) (nonsymbol-id?110 (lambda (x754) (and (syntax-object?95 x754) (symbol? (let ((e755 (syntax-object-expression96 x754))) (if (annotation? e755) (annotation-expression e755) e755)))))) (global-extend109 (lambda (type756 sym757 val758) (put-global-definition-hook77 sym757 type756 val758))) (lookup108 (lambda (x759 r760 mod761) (cond ((assq x759 r760) => cdr) ((symbol? x759) (or (get-global-definition-hook78 x759 mod761) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env107 (lambda (r762) (if (null? r762) (quote ()) (let ((a763 (car r762))) (if (eq? (cadr a763) (quote macro)) (cons a763 (macros-only-env107 (cdr r762))) (macros-only-env107 (cdr r762))))))) (extend-var-env106 (lambda (labels764 vars765 r766) (if (null? labels764) r766 (extend-var-env106 (cdr labels764) (cdr vars765) (cons (cons (car labels764) (cons (quote lexical) (car vars765))) r766))))) (extend-env105 (lambda (labels767 bindings768 r769) (if (null? labels767) r769 (extend-env105 (cdr labels767) (cdr bindings768) (cons (cons (car labels767) (car bindings768)) r769))))) (binding-value104 cdr) (binding-type103 car) (source-annotation102 (lambda (x770) (cond ((annotation? x770) (annotation-source x770)) ((syntax-object?95 x770) (source-annotation102 (syntax-object-expression96 x770))) (else #f)))) (set-syntax-object-module!101 (lambda (x771 update772) (vector-set! x771 3 update772))) (set-syntax-object-wrap!100 (lambda (x773 update774) (vector-set! x773 2 update774))) (set-syntax-object-expression!99 (lambda (x775 update776) (vector-set! x775 1 update776))) (syntax-object-module98 (lambda (x777) (vector-ref x777 3))) (syntax-object-wrap97 (lambda (x778) (vector-ref x778 2))) (syntax-object-expression96 (lambda (x779) (vector-ref x779 1))) (syntax-object?95 (lambda (x780) (and (vector? x780) (= (vector-length x780) 4) (eq? (vector-ref x780 0) (quote syntax-object))))) (make-syntax-object94 (lambda (expression781 wrap782 module783) (vector (quote syntax-object) expression781 wrap782 module783))) (build-letrec93 (lambda (src784 ids785 vars786 val-exps787 body-exp788) (if (null? vars786) body-exp788 (let ((t789 (fluid-ref *mode*70))) (if (memv t789 (quote (c))) ((@ (language tree-il) make-letrec) src784 ids785 vars786 val-exps787 body-exp788) (list (quote letrec) (map list vars786 val-exps787) body-exp788)))))) (build-named-let92 (lambda (src790 ids791 vars792 val-exps793 body-exp794) (let ((f795 (car vars792)) (f-name796 (car ids791)) (vars797 (cdr vars792)) (ids798 (cdr ids791))) (let ((t799 (fluid-ref *mode*70))) (if (memv t799 (quote (c))) ((@ (language tree-il) make-letrec) src790 (list f-name796) (list f795) (list (build-lambda87 src790 ids798 vars797 #f body-exp794)) (build-application79 src790 (build-lexical-reference81 (quote fun) src790 f-name796 f795) val-exps793)) (list (quote let) f795 (map list vars797 val-exps793) body-exp794)))))) (build-let91 (lambda (src800 ids801 vars802 val-exps803 body-exp804) (if (null? vars802) body-exp804 (let ((t805 (fluid-ref *mode*70))) (if (memv t805 (quote (c))) ((@ (language tree-il) make-let) src800 ids801 vars802 val-exps803 body-exp804) (list (quote let) (map list vars802 val-exps803) body-exp804)))))) (build-sequence90 (lambda (src806 exps807) (if (null? (cdr exps807)) (car exps807) (let ((t808 (fluid-ref *mode*70))) (if (memv t808 (quote (c))) ((@ (language tree-il) make-sequence) src806 exps807) (cons (quote begin) exps807)))))) (build-data89 (lambda (src809 exp810) (let ((t811 (fluid-ref *mode*70))) (if (memv t811 (quote (c))) ((@ (language tree-il) make-const) src809 exp810) (if (and (self-evaluating? exp810) (not (vector? exp810))) exp810 (list (quote quote) exp810)))))) (build-primref88 (lambda (src812 name813) (let ((t814 (fluid-ref *mode*70))) (if (memv t814 (quote (c))) ((@ (language tree-il) make-primitive-ref) src812 name813) (build-global-reference84 src812 name813 (quote (hygiene guile))))))) (build-lambda87 (lambda (src815 ids816 vars817 docstring818 exp819) (let ((t820 (fluid-ref *mode*70))) (if (memv t820 (quote (c))) ((@ (language tree-il) make-lambda) src815 ids816 vars817 (if docstring818 (list (cons (quote documentation) docstring818)) (quote ())) exp819) (cons (quote lambda) (cons vars817 (append (if docstring818 (list docstring818) (quote ())) (list exp819)))))))) (build-global-definition86 (lambda (source821 var822 exp823) (let ((t824 (fluid-ref *mode*70))) (if (memv t824 (quote (c))) ((@ (language tree-il) make-toplevel-define) source821 var822 exp823) (list (quote define) var822 exp823))))) (build-global-assignment85 (lambda (source825 var826 exp827 mod828) (analyze-variable83 mod828 var826 (lambda (mod829 var830 public?831) (let ((t832 (fluid-ref *mode*70))) (if (memv t832 (quote (c))) ((@ (language tree-il) make-module-set) source825 mod829 var830 public?831 exp827) (list (quote set!) (list (if public?831 (quote @) (quote @@)) mod829 var830) exp827)))) (lambda (var833) (let ((t834 (fluid-ref *mode*70))) (if (memv t834 (quote (c))) ((@ (language tree-il) make-toplevel-set) source825 var833 exp827) (list (quote set!) var833 exp827))))))) (build-global-reference84 (lambda (source835 var836 mod837) (analyze-variable83 mod837 var836 (lambda (mod838 var839 public?840) (let ((t841 (fluid-ref *mode*70))) (if (memv t841 (quote (c))) ((@ (language tree-il) make-module-ref) source835 mod838 var839 public?840) (list (if public?840 (quote @) (quote @@)) mod838 var839)))) (lambda (var842) (let ((t843 (fluid-ref *mode*70))) (if (memv t843 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source835 var842) var842)))))) (analyze-variable83 (lambda (mod844 var845 modref-cont846 bare-cont847) (if (not mod844) (bare-cont847 var845) (let ((kind848 (car mod844)) (mod849 (cdr mod844))) (let ((t850 kind848)) (if (memv t850 (quote (public))) (modref-cont846 mod849 var845 #t) (if (memv t850 (quote (private))) (if (not (equal? mod849 (module-name (current-module)))) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (if (memv t850 (quote (bare))) (bare-cont847 var845) (if (memv t850 (quote (hygiene))) (if (and (not (equal? mod849 (module-name (current-module)))) (module-variable (resolve-module mod849) var845)) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (syntax-violation #f "bad module kind" var845 mod849)))))))))) (build-lexical-assignment82 (lambda (source851 name852 var853 exp854) (let ((t855 (fluid-ref *mode*70))) (if (memv t855 (quote (c))) ((@ (language tree-il) make-lexical-set) source851 name852 var853 exp854) (list (quote set!) var853 exp854))))) (build-lexical-reference81 (lambda (type856 source857 name858 var859) (let ((t860 (fluid-ref *mode*70))) (if (memv t860 (quote (c))) ((@ (language tree-il) make-lexical-ref) source857 name858 var859) var859)))) (build-conditional80 (lambda (source861 test-exp862 then-exp863 else-exp864) (let ((t865 (fluid-ref *mode*70))) (if (memv t865 (quote (c))) ((@ (language tree-il) make-conditional) source861 test-exp862 then-exp863 else-exp864) (list (quote if) test-exp862 then-exp863 else-exp864))))) (build-application79 (lambda (source866 fun-exp867 arg-exps868) (let ((t869 (fluid-ref *mode*70))) (if (memv t869 (quote (c))) ((@ (language tree-il) make-application) source866 fun-exp867 arg-exps868) (cons fun-exp867 arg-exps868))))) (get-global-definition-hook78 (lambda (symbol870 module871) (begin (if (and (not module871) (current-module)) (warn "module system is booted, we should have a module" symbol870)) (let ((v872 (module-variable (if module871 (resolve-module (cdr module871)) (current-module)) symbol870))) (and v872 (variable-bound? v872) (let ((val873 (variable-ref v872))) (and (macro? val873) (syncase-macro-type val873) (cons (syncase-macro-type val873) (syncase-macro-binding val873))))))))) (put-global-definition-hook77 (lambda (symbol874 type875 val876) (let ((existing877 (let ((v878 (module-variable (current-module) symbol874))) (and v878 (variable-bound? v878) (let ((val879 (variable-ref v878))) (and (macro? val879) (not (syncase-macro-type val879)) val879)))))) (module-define! (current-module) symbol874 (if existing877 (make-extended-syncase-macro existing877 type875 val876) (make-syncase-macro type875 val876)))))) (local-eval-hook76 (lambda (x880 mod881) (primitive-eval (list noexpand69 (let ((t882 (fluid-ref *mode*70))) (if (memv t882 (quote (c))) ((@ (language tree-il) tree-il->scheme) x880) x880)))))) (top-level-eval-hook75 (lambda (x883 mod884) (primitive-eval (list noexpand69 (let ((t885 (fluid-ref *mode*70))) (if (memv t885 (quote (c))) ((@ (language tree-il) tree-il->scheme) x883) x883)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend109 (quote local-syntax) (quote letrec-syntax) #t) (global-extend109 (quote local-syntax) (quote let-syntax) #f) (global-extend109 (quote core) (quote fluid-let-syntax) (lambda (e886 r887 w888 s889 mod890) ((lambda (tmp891) ((lambda (tmp892) (if (if tmp892 (apply (lambda (_893 var894 val895 e1896 e2897) (valid-bound-ids?136 var894)) tmp892) #f) (apply (lambda (_899 var900 val901 e1902 e2903) (let ((names904 (map (lambda (x905) (id-var-name133 x905 w888)) var900))) (begin (for-each (lambda (id907 n908) (let ((t909 (binding-type103 (lookup108 n908 r887 mod890)))) (if (memv t909 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e886 (source-wrap140 id907 w888 s889 mod890))))) var900 names904) (chi-body151 (cons e1902 e2903) (source-wrap140 e886 w888 s889 mod890) (extend-env105 names904 (let ((trans-r912 (macros-only-env107 r887))) (map (lambda (x913) (cons (quote macro) (eval-local-transformer154 (chi147 x913 trans-r912 w888 mod890) mod890))) val901)) r887) w888 mod890)))) tmp892) ((lambda (_915) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap140 e886 w888 s889 mod890))) tmp891))) ($sc-dispatch tmp891 (quote (any #(each (any any)) any . each-any))))) e886))) (global-extend109 (quote core) (quote quote) (lambda (e916 r917 w918 s919 mod920) ((lambda (tmp921) ((lambda (tmp922) (if tmp922 (apply (lambda (_923 e924) (build-data89 s919 (strip158 e924 w918))) tmp922) ((lambda (_925) (syntax-violation (quote quote) "bad syntax" (source-wrap140 e916 w918 s919 mod920))) tmp921))) ($sc-dispatch tmp921 (quote (any any))))) e916))) (global-extend109 (quote core) (quote syntax) (letrec ((regen933 (lambda (x934) (let ((t935 (car x934))) (if (memv t935 (quote (ref))) (build-lexical-reference81 (quote value) #f (cadr x934) (cadr x934)) (if (memv t935 (quote (primitive))) (build-primref88 #f (cadr x934)) (if (memv t935 (quote (quote))) (build-data89 #f (cadr x934)) (if (memv t935 (quote (lambda))) (build-lambda87 #f (cadr x934) (cadr x934) #f (regen933 (caddr x934))) (if (memv t935 (quote (map))) (let ((ls936 (map regen933 (cdr x934)))) (build-application79 #f (build-primref88 #f (quote map)) ls936)) (build-application79 #f (build-primref88 #f (car x934)) (map regen933 (cdr x934))))))))))) (gen-vector932 (lambda (x937) (cond ((eq? (car x937) (quote list)) (cons (quote vector) (cdr x937))) ((eq? (car x937) (quote quote)) (list (quote quote) (list->vector (cadr x937)))) (else (list (quote list->vector) x937))))) (gen-append931 (lambda (x938 y939) (if (equal? y939 (quote (quote ()))) x938 (list (quote append) x938 y939)))) (gen-cons930 (lambda (x940 y941) (let ((t942 (car y941))) (if (memv t942 (quote (quote))) (if (eq? (car x940) (quote quote)) (list (quote quote) (cons (cadr x940) (cadr y941))) (if (eq? (cadr y941) (quote ())) (list (quote list) x940) (list (quote cons) x940 y941))) (if (memv t942 (quote (list))) (cons (quote list) (cons x940 (cdr y941))) (list (quote cons) x940 y941)))))) (gen-map929 (lambda (e943 map-env944) (let ((formals945 (map cdr map-env944)) (actuals946 (map (lambda (x947) (list (quote ref) (car x947))) map-env944))) (cond ((eq? (car e943) (quote ref)) (car actuals946)) ((and-map (lambda (x948) (and (eq? (car x948) (quote ref)) (memq (cadr x948) formals945))) (cdr e943)) (cons (quote map) (cons (list (quote primitive) (car e943)) (map (let ((r949 (map cons formals945 actuals946))) (lambda (x950) (cdr (assq (cadr x950) r949)))) (cdr e943))))) (else (cons (quote map) (cons (list (quote lambda) formals945 e943) actuals946))))))) (gen-mappend928 (lambda (e951 map-env952) (list (quote apply) (quote (primitive append)) (gen-map929 e951 map-env952)))) (gen-ref927 (lambda (src953 var954 level955 maps956) (if (fx=73 level955 0) (values var954 maps956) (if (null? maps956) (syntax-violation (quote syntax) "missing ellipsis" src953) (call-with-values (lambda () (gen-ref927 src953 var954 (fx-72 level955 1) (cdr maps956))) (lambda (outer-var957 outer-maps958) (let ((b959 (assq outer-var957 (car maps956)))) (if b959 (values (cdr b959) maps956) (let ((inner-var960 (gen-var159 (quote tmp)))) (values inner-var960 (cons (cons (cons outer-var957 inner-var960) (car maps956)) outer-maps958))))))))))) (gen-syntax926 (lambda (src961 e962 r963 maps964 ellipsis?965 mod966) (if (id?111 e962) (let ((label967 (id-var-name133 e962 (quote (()))))) (let ((b968 (lookup108 label967 r963 mod966))) (if (eq? (binding-type103 b968) (quote syntax)) (call-with-values (lambda () (let ((var.lev969 (binding-value104 b968))) (gen-ref927 src961 (car var.lev969) (cdr var.lev969) maps964))) (lambda (var970 maps971) (values (list (quote ref) var970) maps971))) (if (ellipsis?965 e962) (syntax-violation (quote syntax) "misplaced ellipsis" src961) (values (list (quote quote) e962) maps964))))) ((lambda (tmp972) ((lambda (tmp973) (if (if tmp973 (apply (lambda (dots974 e975) (ellipsis?965 dots974)) tmp973) #f) (apply (lambda (dots976 e977) (gen-syntax926 src961 e977 r963 maps964 (lambda (x978) #f) mod966)) tmp973) ((lambda (tmp979) (if (if tmp979 (apply (lambda (x980 dots981 y982) (ellipsis?965 dots981)) tmp979) #f) (apply (lambda (x983 dots984 y985) (letrec ((f986 (lambda (y987 k988) ((lambda (tmp992) ((lambda (tmp993) (if (if tmp993 (apply (lambda (dots994 y995) (ellipsis?965 dots994)) tmp993) #f) (apply (lambda (dots996 y997) (f986 y997 (lambda (maps998) (call-with-values (lambda () (k988 (cons (quote ()) maps998))) (lambda (x999 maps1000) (if (null? (car maps1000)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-mappend928 x999 (car maps1000)) (cdr maps1000)))))))) tmp993) ((lambda (_1001) (call-with-values (lambda () (gen-syntax926 src961 y987 r963 maps964 ellipsis?965 mod966)) (lambda (y1002 maps1003) (call-with-values (lambda () (k988 maps1003)) (lambda (x1004 maps1005) (values (gen-append931 x1004 y1002) maps1005)))))) tmp992))) ($sc-dispatch tmp992 (quote (any . any))))) y987)))) (f986 y985 (lambda (maps989) (call-with-values (lambda () (gen-syntax926 src961 x983 r963 (cons (quote ()) maps989) ellipsis?965 mod966)) (lambda (x990 maps991) (if (null? (car maps991)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-map929 x990 (car maps991)) (cdr maps991))))))))) tmp979) ((lambda (tmp1006) (if tmp1006 (apply (lambda (x1007 y1008) (call-with-values (lambda () (gen-syntax926 src961 x1007 r963 maps964 ellipsis?965 mod966)) (lambda (x1009 maps1010) (call-with-values (lambda () (gen-syntax926 src961 y1008 r963 maps1010 ellipsis?965 mod966)) (lambda (y1011 maps1012) (values (gen-cons930 x1009 y1011) maps1012)))))) tmp1006) ((lambda (tmp1013) (if tmp1013 (apply (lambda (e11014 e21015) (call-with-values (lambda () (gen-syntax926 src961 (cons e11014 e21015) r963 maps964 ellipsis?965 mod966)) (lambda (e1017 maps1018) (values (gen-vector932 e1017) maps1018)))) tmp1013) ((lambda (_1019) (values (list (quote quote) e962) maps964)) tmp972))) ($sc-dispatch tmp972 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp972 (quote (any . any)))))) ($sc-dispatch tmp972 (quote (any any . any)))))) ($sc-dispatch tmp972 (quote (any any))))) e962))))) (lambda (e1020 r1021 w1022 s1023 mod1024) (let ((e1025 (source-wrap140 e1020 w1022 s1023 mod1024))) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda (_1028 x1029) (call-with-values (lambda () (gen-syntax926 e1025 x1029 r1021 (quote ()) ellipsis?156 mod1024)) (lambda (e1030 maps1031) (regen933 e1030)))) tmp1027) ((lambda (_1032) (syntax-violation (quote syntax) "bad `syntax' form" e1025)) tmp1026))) ($sc-dispatch tmp1026 (quote (any any))))) e1025))))) (global-extend109 (quote core) (quote lambda) (lambda (e1033 r1034 w1035 s1036 mod1037) ((lambda (tmp1038) ((lambda (tmp1039) (if tmp1039 (apply (lambda (_1040 c1041) (chi-lambda-clause152 (source-wrap140 e1033 w1035 s1036 mod1037) #f c1041 r1034 w1035 mod1037 (lambda (names1042 vars1043 docstring1044 body1045) (build-lambda87 s1036 names1042 vars1043 docstring1044 body1045)))) tmp1039) (syntax-violation #f "source expression failed to match any pattern" tmp1038))) ($sc-dispatch tmp1038 (quote (any . any))))) e1033))) (global-extend109 (quote core) (quote let) (letrec ((chi-let1046 (lambda (e1047 r1048 w1049 s1050 mod1051 constructor1052 ids1053 vals1054 exps1055) (if (not (valid-bound-ids?136 ids1053)) (syntax-violation (quote let) "duplicate bound variable" e1047) (let ((labels1056 (gen-labels117 ids1053)) (new-vars1057 (map gen-var159 ids1053))) (let ((nw1058 (make-binding-wrap128 ids1053 labels1056 w1049)) (nr1059 (extend-var-env106 labels1056 new-vars1057 r1048))) (constructor1052 s1050 (map syntax->datum ids1053) new-vars1057 (map (lambda (x1060) (chi147 x1060 r1048 w1049 mod1051)) vals1054) (chi-body151 exps1055 (source-wrap140 e1047 nw1058 s1050 mod1051) nr1059 nw1058 mod1051)))))))) (lambda (e1061 r1062 w1063 s1064 mod1065) ((lambda (tmp1066) ((lambda (tmp1067) (if tmp1067 (apply (lambda (_1068 id1069 val1070 e11071 e21072) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-let91 id1069 val1070 (cons e11071 e21072))) tmp1067) ((lambda (tmp1076) (if (if tmp1076 (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (id?111 f1078)) tmp1076) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-named-let92 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1076) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap140 e1061 w1063 s1064 mod1065))) tmp1066))) ($sc-dispatch tmp1066 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1066 (quote (any #(each (any any)) any . each-any))))) e1061)))) (global-extend109 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (let ((ids1105 id1101)) (if (not (valid-bound-ids?136 ids1105)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1107 (gen-labels117 ids1105)) (new-vars1108 (map gen-var159 ids1105))) (let ((w1109 (make-binding-wrap128 ids1105 labels1107 w1095)) (r1110 (extend-var-env106 labels1107 new-vars1108 r1094))) (build-letrec93 s1096 (map syntax->datum ids1105) new-vars1108 (map (lambda (x1111) (chi147 x1111 r1110 w1109 mod1097)) val1102) (chi-body151 (cons e11103 e21104) (source-wrap140 e1093 w1109 s1096 mod1097) r1110 w1109 mod1097))))))) tmp1099) ((lambda (_1114) (syntax-violation (quote letrec) "bad letrec" (source-wrap140 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend109 (quote core) (quote set!) (lambda (e1115 r1116 w1117 s1118 mod1119) ((lambda (tmp1120) ((lambda (tmp1121) (if (if tmp1121 (apply (lambda (_1122 id1123 val1124) (id?111 id1123)) tmp1121) #f) (apply (lambda (_1125 id1126 val1127) (let ((val1128 (chi147 val1127 r1116 w1117 mod1119)) (n1129 (id-var-name133 id1126 w1117))) (let ((b1130 (lookup108 n1129 r1116 mod1119))) (let ((t1131 (binding-type103 b1130))) (if (memv t1131 (quote (lexical))) (build-lexical-assignment82 s1118 (syntax->datum id1126) (binding-value104 b1130) val1128) (if (memv t1131 (quote (global))) (build-global-assignment85 s1118 n1129 val1128 mod1119) (if (memv t1131 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap139 id1126 w1117 mod1119)) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))))))))) tmp1121) ((lambda (tmp1132) (if tmp1132 (apply (lambda (_1133 head1134 tail1135 val1136) (call-with-values (lambda () (syntax-type145 head1134 r1116 (quote (())) #f #f mod1119)) (lambda (type1137 value1138 ee1139 ww1140 ss1141 modmod1142) (let ((t1143 type1137)) (if (memv t1143 (quote (module-ref))) (let ((val1144 (chi147 val1136 r1116 w1117 mod1119))) (call-with-values (lambda () (value1138 (cons head1134 tail1135))) (lambda (id1146 mod1147) (build-global-assignment85 s1118 id1146 val1144 mod1147)))) (build-application79 s1118 (chi147 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1134) r1116 w1117 mod1119) (map (lambda (e1148) (chi147 e1148 r1116 w1117 mod1119)) (append tail1135 (list val1136))))))))) tmp1132) ((lambda (_1150) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))) tmp1120))) ($sc-dispatch tmp1120 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1120 (quote (any any any))))) e1115))) (global-extend109 (quote module-ref) (quote @) (lambda (e1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 mod1155 id1156) (and (and-map id?111 mod1155) (id?111 id1156))) tmp1153) #f) (apply (lambda (_1158 mod1159 id1160) (values (syntax->datum id1160) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1159)))) tmp1153) (syntax-violation #f "source expression failed to match any pattern" tmp1152))) ($sc-dispatch tmp1152 (quote (any each-any any))))) e1151))) (global-extend109 (quote module-ref) (quote @@) (lambda (e1162) ((lambda (tmp1163) ((lambda (tmp1164) (if (if tmp1164 (apply (lambda (_1165 mod1166 id1167) (and (and-map id?111 mod1166) (id?111 id1167))) tmp1164) #f) (apply (lambda (_1169 mod1170 id1171) (values (syntax->datum id1171) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1170)))) tmp1164) (syntax-violation #f "source expression failed to match any pattern" tmp1163))) ($sc-dispatch tmp1163 (quote (any each-any any))))) e1162))) (global-extend109 (quote begin) (quote begin) (quote ())) (global-extend109 (quote define) (quote define) (quote ())) (global-extend109 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend109 (quote eval-when) (quote eval-when) (quote ())) (global-extend109 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1176 (lambda (x1177 keys1178 clauses1179 r1180 mod1181) (if (null? clauses1179) (build-application79 #f (build-primref88 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1177)) ((lambda (tmp1182) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 exp1185) (if (and (id?111 pat1184) (and-map (lambda (x1186) (not (free-id=?134 pat1184 x1186))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1178))) (let ((labels1187 (list (gen-label116))) (var1188 (gen-var159 pat1184))) (build-application79 #f (build-lambda87 #f (list (syntax->datum pat1184)) (list var1188) #f (chi147 exp1185 (extend-env105 labels1187 (list (cons (quote syntax) (cons var1188 0))) r1180) (make-binding-wrap128 (list pat1184) labels1187 (quote (()))) mod1181)) (list x1177))) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1184 #t exp1185 mod1181))) tmp1183) ((lambda (tmp1189) (if tmp1189 (apply (lambda (pat1190 fender1191 exp1192) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1190 fender1191 exp1192 mod1181)) tmp1189) ((lambda (_1193) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1179))) tmp1182))) ($sc-dispatch tmp1182 (quote (any any any)))))) ($sc-dispatch tmp1182 (quote (any any))))) (car clauses1179))))) (gen-clause1175 (lambda (x1194 keys1195 clauses1196 r1197 pat1198 fender1199 exp1200 mod1201) (call-with-values (lambda () (convert-pattern1173 pat1198 keys1195)) (lambda (p1202 pvars1203) (cond ((not (distinct-bound-ids?137 (map car pvars1203))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1198)) ((not (and-map (lambda (x1204) (not (ellipsis?156 (car x1204)))) pvars1203)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1198)) (else (let ((y1205 (gen-var159 (quote tmp)))) (build-application79 #f (build-lambda87 #f (list (quote tmp)) (list y1205) #f (let ((y1206 (build-lexical-reference81 (quote value) #f (quote tmp) y1205))) (build-conditional80 #f ((lambda (tmp1207) ((lambda (tmp1208) (if tmp1208 (apply (lambda () y1206) tmp1208) ((lambda (_1209) (build-conditional80 #f y1206 (build-dispatch-call1174 pvars1203 fender1199 y1206 r1197 mod1201) (build-data89 #f #f))) tmp1207))) ($sc-dispatch tmp1207 (quote #(atom #t))))) fender1199) (build-dispatch-call1174 pvars1203 exp1200 y1206 r1197 mod1201) (gen-syntax-case1176 x1194 keys1195 clauses1196 r1197 mod1201)))) (list (if (eq? p1202 (quote any)) (build-application79 #f (build-primref88 #f (quote list)) (list x1194)) (build-application79 #f (build-primref88 #f (quote $sc-dispatch)) (list x1194 (build-data89 #f p1202))))))))))))) (build-dispatch-call1174 (lambda (pvars1210 exp1211 y1212 r1213 mod1214) (let ((ids1215 (map car pvars1210)) (levels1216 (map cdr pvars1210))) (let ((labels1217 (gen-labels117 ids1215)) (new-vars1218 (map gen-var159 ids1215))) (build-application79 #f (build-primref88 #f (quote apply)) (list (build-lambda87 #f (map syntax->datum ids1215) new-vars1218 #f (chi147 exp1211 (extend-env105 labels1217 (map (lambda (var1219 level1220) (cons (quote syntax) (cons var1219 level1220))) new-vars1218 (map cdr pvars1210)) r1213) (make-binding-wrap128 ids1215 labels1217 (quote (()))) mod1214)) y1212)))))) (convert-pattern1173 (lambda (pattern1221 keys1222) (letrec ((cvt1223 (lambda (p1224 n1225 ids1226) (if (id?111 p1224) (if (bound-id-member?138 p1224 keys1222) (values (vector (quote free-id) p1224) ids1226) (values (quote any) (cons (cons p1224 n1225) ids1226))) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (x1229 dots1230) (ellipsis?156 dots1230)) tmp1228) #f) (apply (lambda (x1231 dots1232) (call-with-values (lambda () (cvt1223 x1231 (fx+71 n1225 1) ids1226)) (lambda (p1233 ids1234) (values (if (eq? p1233 (quote any)) (quote each-any) (vector (quote each) p1233)) ids1234)))) tmp1228) ((lambda (tmp1235) (if tmp1235 (apply (lambda (x1236 y1237) (call-with-values (lambda () (cvt1223 y1237 n1225 ids1226)) (lambda (y1238 ids1239) (call-with-values (lambda () (cvt1223 x1236 n1225 ids1239)) (lambda (x1240 ids1241) (values (cons x1240 y1238) ids1241)))))) tmp1235) ((lambda (tmp1242) (if tmp1242 (apply (lambda () (values (quote ()) ids1226)) tmp1242) ((lambda (tmp1243) (if tmp1243 (apply (lambda (x1244) (call-with-values (lambda () (cvt1223 x1244 n1225 ids1226)) (lambda (p1246 ids1247) (values (vector (quote vector) p1246) ids1247)))) tmp1243) ((lambda (x1248) (values (vector (quote atom) (strip158 p1224 (quote (())))) ids1226)) tmp1227))) ($sc-dispatch tmp1227 (quote #(vector each-any)))))) ($sc-dispatch tmp1227 (quote ()))))) ($sc-dispatch tmp1227 (quote (any . any)))))) ($sc-dispatch tmp1227 (quote (any any))))) p1224))))) (cvt1223 pattern1221 0 (quote ())))))) (lambda (e1249 r1250 w1251 s1252 mod1253) (let ((e1254 (source-wrap140 e1249 w1251 s1252 mod1253))) ((lambda (tmp1255) ((lambda (tmp1256) (if tmp1256 (apply (lambda (_1257 val1258 key1259 m1260) (if (and-map (lambda (x1261) (and (id?111 x1261) (not (ellipsis?156 x1261)))) key1259) (let ((x1263 (gen-var159 (quote tmp)))) (build-application79 s1252 (build-lambda87 #f (list (quote tmp)) (list x1263) #f (gen-syntax-case1176 (build-lexical-reference81 (quote value) #f (quote tmp) x1263) key1259 m1260 r1250 mod1253)) (list (chi147 val1258 r1250 (quote (())) mod1253)))) (syntax-violation (quote syntax-case) "invalid literals list" e1254))) tmp1256) (syntax-violation #f "source expression failed to match any pattern" tmp1255))) ($sc-dispatch tmp1255 (quote (any any each-any . each-any))))) e1254))))) (set! sc-expand (lambda (x1267 . rest1266) (if (and (pair? x1267) (equal? (car x1267) noexpand69)) (cadr x1267) (let ((m1268 (if (null? rest1266) (quote e) (car rest1266))) (esew1269 (if (or (null? rest1266) (null? (cdr rest1266))) (quote (eval)) (cadr rest1266)))) (with-fluid* *mode*70 m1268 (lambda () (chi-top146 x1267 (quote ()) (quote ((top))) m1268 esew1269 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1270) (nonsymbol-id?110 x1270))) (set! datum->syntax (lambda (id1271 datum1272) (make-syntax-object94 datum1272 (syntax-object-wrap97 id1271) #f))) (set! syntax->datum (lambda (x1273) (strip158 x1273 (quote (()))))) (set! generate-temporaries (lambda (ls1274) (begin (let ((x1275 ls1274)) (if (not (list? x1275)) (syntax-violation (quote generate-temporaries) "invalid argument" x1275))) (map (lambda (x1276) (wrap139 (gensym) (quote ((top))) #f)) ls1274)))) (set! free-identifier=? (lambda (x1277 y1278) (begin (let ((x1279 x1277)) (if (not (nonsymbol-id?110 x1279)) (syntax-violation (quote free-identifier=?) "invalid argument" x1279))) (let ((x1280 y1278)) (if (not (nonsymbol-id?110 x1280)) (syntax-violation (quote free-identifier=?) "invalid argument" x1280))) (free-id=?134 x1277 y1278)))) (set! bound-identifier=? (lambda (x1281 y1282) (begin (let ((x1283 x1281)) (if (not (nonsymbol-id?110 x1283)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1283))) (let ((x1284 y1282)) (if (not (nonsymbol-id?110 x1284)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1284))) (bound-id=?135 x1281 y1282)))) (set! syntax-violation (lambda (who1288 message1287 form1286 . subform1285) (begin (let ((x1289 who1288)) (if (not ((lambda (x1290) (or (not x1290) (string? x1290) (symbol? x1290))) x1289)) (syntax-violation (quote syntax-violation) "invalid argument" x1289))) (let ((x1291 message1287)) (if (not (string? x1291)) (syntax-violation (quote syntax-violation) "invalid argument" x1291))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1288 "~a: " "") "~a " (if (null? subform1285) "in ~a" "in subform `~s' of `~s'")) (let ((tail1292 (cons message1287 (map (lambda (x1293) (strip158 x1293 (quote (())))) (append subform1285 (list form1286)))))) (if who1288 (cons who1288 tail1292) tail1292)) #f)))) (letrec ((match1298 (lambda (e1299 p1300 w1301 r1302 mod1303) (cond ((not r1302) #f) ((eq? p1300 (quote any)) (cons (wrap139 e1299 w1301 mod1303) r1302)) ((syntax-object?95 e1299) (match*1297 (let ((e1304 (syntax-object-expression96 e1299))) (if (annotation? e1304) (annotation-expression e1304) e1304)) p1300 (join-wraps130 w1301 (syntax-object-wrap97 e1299)) r1302 (syntax-object-module98 e1299))) (else (match*1297 (let ((e1305 e1299)) (if (annotation? e1305) (annotation-expression e1305) e1305)) p1300 w1301 r1302 mod1303))))) (match*1297 (lambda (e1306 p1307 w1308 r1309 mod1310) (cond ((null? p1307) (and (null? e1306) r1309)) ((pair? p1307) (and (pair? e1306) (match1298 (car e1306) (car p1307) w1308 (match1298 (cdr e1306) (cdr p1307) w1308 r1309 mod1310) mod1310))) ((eq? p1307 (quote each-any)) (let ((l1311 (match-each-any1295 e1306 w1308 mod1310))) (and l1311 (cons l1311 r1309)))) (else (let ((t1312 (vector-ref p1307 0))) (if (memv t1312 (quote (each))) (if (null? e1306) (match-empty1296 (vector-ref p1307 1) r1309) (let ((l1313 (match-each1294 e1306 (vector-ref p1307 1) w1308 mod1310))) (and l1313 (letrec ((collect1314 (lambda (l1315) (if (null? (car l1315)) r1309 (cons (map car l1315) (collect1314 (map cdr l1315))))))) (collect1314 l1313))))) (if (memv t1312 (quote (free-id))) (and (id?111 e1306) (free-id=?134 (wrap139 e1306 w1308 mod1310) (vector-ref p1307 1)) r1309) (if (memv t1312 (quote (atom))) (and (equal? (vector-ref p1307 1) (strip158 e1306 w1308)) r1309) (if (memv t1312 (quote (vector))) (and (vector? e1306) (match1298 (vector->list e1306) (vector-ref p1307 1) w1308 r1309 mod1310))))))))))) (match-empty1296 (lambda (p1316 r1317) (cond ((null? p1316) r1317) ((eq? p1316 (quote any)) (cons (quote ()) r1317)) ((pair? p1316) (match-empty1296 (car p1316) (match-empty1296 (cdr p1316) r1317))) ((eq? p1316 (quote each-any)) (cons (quote ()) r1317)) (else (let ((t1318 (vector-ref p1316 0))) (if (memv t1318 (quote (each))) (match-empty1296 (vector-ref p1316 1) r1317) (if (memv t1318 (quote (free-id atom))) r1317 (if (memv t1318 (quote (vector))) (match-empty1296 (vector-ref p1316 1) r1317))))))))) (match-each-any1295 (lambda (e1319 w1320 mod1321) (cond ((annotation? e1319) (match-each-any1295 (annotation-expression e1319) w1320 mod1321)) ((pair? e1319) (let ((l1322 (match-each-any1295 (cdr e1319) w1320 mod1321))) (and l1322 (cons (wrap139 (car e1319) w1320 mod1321) l1322)))) ((null? e1319) (quote ())) ((syntax-object?95 e1319) (match-each-any1295 (syntax-object-expression96 e1319) (join-wraps130 w1320 (syntax-object-wrap97 e1319)) mod1321)) (else #f)))) (match-each1294 (lambda (e1323 p1324 w1325 mod1326) (cond ((annotation? e1323) (match-each1294 (annotation-expression e1323) p1324 w1325 mod1326)) ((pair? e1323) (let ((first1327 (match1298 (car e1323) p1324 w1325 (quote ()) mod1326))) (and first1327 (let ((rest1328 (match-each1294 (cdr e1323) p1324 w1325 mod1326))) (and rest1328 (cons first1327 rest1328)))))) ((null? e1323) (quote ())) ((syntax-object?95 e1323) (match-each1294 (syntax-object-expression96 e1323) p1324 (join-wraps130 w1325 (syntax-object-wrap97 e1323)) (syntax-object-module98 e1323))) (else #f))))) (set! $sc-dispatch (lambda (e1329 p1330) (cond ((eq? p1330 (quote any)) (list e1329)) ((syntax-object?95 e1329) (match*1297 (let ((e1331 (syntax-object-expression96 e1329))) (if (annotation? e1331) (annotation-expression e1331) e1331)) p1330 (syntax-object-wrap97 e1329) (quote ()) (syntax-object-module98 e1329))) (else (match*1297 (let ((e1332 e1329)) (if (annotation? e1332) (annotation-expression e1332) e1332)) p1330 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1333) ((lambda (tmp1334) ((lambda (tmp1335) (if tmp1335 (apply (lambda (_1336 e11337 e21338) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11337 e21338))) tmp1335) ((lambda (tmp1340) (if tmp1340 (apply (lambda (_1341 out1342 in1343 e11344 e21345) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1343 (quote ()) (list out1342 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11344 e21345))))) tmp1340) ((lambda (tmp1347) (if tmp1347 (apply (lambda (_1348 out1349 in1350 e11351 e21352) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1350) (quote ()) (list out1349 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11351 e21352))))) tmp1347) (syntax-violation #f "source expression failed to match any pattern" tmp1334))) ($sc-dispatch tmp1334 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any () any . each-any))))) x1333)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1356) ((lambda (tmp1357) ((lambda (tmp1358) (if tmp1358 (apply (lambda (_1359 k1360 keyword1361 pattern1362 template1363) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1360 (map (lambda (tmp1366 tmp1365) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1365) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1366))) template1363 pattern1362)))))) tmp1358) (syntax-violation #f "source expression failed to match any pattern" tmp1357))) ($sc-dispatch tmp1357 (quote (any each-any . #(each ((any . any) any))))))) x1356)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1367) ((lambda (tmp1368) ((lambda (tmp1369) (if (if tmp1369 (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (and-map identifier? x1371)) tmp1369) #f) (apply (lambda (let*1376 x1377 v1378 e11379 e21380) (letrec ((f1381 (lambda (bindings1382) (if (null? bindings1382) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11379 e21380))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (body1388 binding1389) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1389) body1388)) tmp1387) (syntax-violation #f "source expression failed to match any pattern" tmp1386))) ($sc-dispatch tmp1386 (quote (any any))))) (list (f1381 (cdr bindings1382)) (car bindings1382))))))) (f1381 (map list x1377 v1378)))) tmp1369) (syntax-violation #f "source expression failed to match any pattern" tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) x1367)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1390) ((lambda (tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (_1393 var1394 init1395 step1396 e01397 e11398 c1399) ((lambda (tmp1400) ((lambda (tmp1401) (if tmp1401 (apply (lambda (step1402) ((lambda (tmp1403) ((lambda (tmp1404) (if tmp1404 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1404) ((lambda (tmp1409) (if tmp1409 (apply (lambda (e11410 e21411) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1394 init1395) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01397 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11410 e21411)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1399 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1402))))))) tmp1409) (syntax-violation #f "source expression failed to match any pattern" tmp1403))) ($sc-dispatch tmp1403 (quote (any . each-any)))))) ($sc-dispatch tmp1403 (quote ())))) e11398)) tmp1401) (syntax-violation #f "source expression failed to match any pattern" tmp1400))) ($sc-dispatch tmp1400 (quote each-any)))) (map (lambda (v1418 s1419) ((lambda (tmp1420) ((lambda (tmp1421) (if tmp1421 (apply (lambda () v1418) tmp1421) ((lambda (tmp1422) (if tmp1422 (apply (lambda (e1423) e1423) tmp1422) ((lambda (_1424) (syntax-violation (quote do) "bad step expression" orig-x1390 s1419)) tmp1420))) ($sc-dispatch tmp1420 (quote (any)))))) ($sc-dispatch tmp1420 (quote ())))) s1419)) var1394 step1396))) tmp1392) (syntax-violation #f "source expression failed to match any pattern" tmp1391))) ($sc-dispatch tmp1391 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1390)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1427 (lambda (x1431 y1432) ((lambda (tmp1433) ((lambda (tmp1434) (if tmp1434 (apply (lambda (x1435 y1436) ((lambda (tmp1437) ((lambda (tmp1438) (if tmp1438 (apply (lambda (dy1439) ((lambda (tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (dx1442) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1442 dy1439))) tmp1441) ((lambda (_1443) (if (null? dy1439) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436))) tmp1440))) ($sc-dispatch tmp1440 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1435)) tmp1438) ((lambda (tmp1444) (if tmp1444 (apply (lambda (stuff1445) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1435 stuff1445))) tmp1444) ((lambda (else1446) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1435 y1436)) tmp1437))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1437 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1436)) tmp1434) (syntax-violation #f "source expression failed to match any pattern" tmp1433))) ($sc-dispatch tmp1433 (quote (any any))))) (list x1431 y1432)))) (quasiappend1428 (lambda (x1447 y1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (x1451 y1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda () x1451) tmp1454) ((lambda (_1455) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1451 y1452)) tmp1453))) ($sc-dispatch tmp1453 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1452)) tmp1450) (syntax-violation #f "source expression failed to match any pattern" tmp1449))) ($sc-dispatch tmp1449 (quote (any any))))) (list x1447 y1448)))) (quasivector1429 (lambda (x1456) ((lambda (tmp1457) ((lambda (x1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (x1461) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1461))) tmp1460) ((lambda (tmp1463) (if tmp1463 (apply (lambda (x1464) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1464)) tmp1463) ((lambda (_1466) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1458)) tmp1459))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1458)) tmp1457)) x1456))) (quasi1430 (lambda (p1467 lev1468) ((lambda (tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471) (if (= lev1468 0) p1471 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1471) (- lev1468 1))))) tmp1470) ((lambda (tmp1472) (if tmp1472 (apply (lambda (p1473 q1474) (if (= lev1468 0) (quasiappend1428 p1473 (quasi1430 q1474 lev1468)) (quasicons1427 (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1473) (- lev1468 1))) (quasi1430 q1474 lev1468)))) tmp1472) ((lambda (tmp1475) (if tmp1475 (apply (lambda (p1476) (quasicons1427 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1430 (list p1476) (+ lev1468 1)))) tmp1475) ((lambda (tmp1477) (if tmp1477 (apply (lambda (p1478 q1479) (quasicons1427 (quasi1430 p1478 lev1468) (quasi1430 q1479 lev1468))) tmp1477) ((lambda (tmp1480) (if tmp1480 (apply (lambda (x1481) (quasivector1429 (quasi1430 x1481 lev1468))) tmp1480) ((lambda (p1483) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1483)) tmp1469))) ($sc-dispatch tmp1469 (quote #(vector each-any)))))) ($sc-dispatch tmp1469 (quote (any . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1469 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1469 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1467)))) (lambda (x1484) ((lambda (tmp1485) ((lambda (tmp1486) (if tmp1486 (apply (lambda (_1487 e1488) (quasi1430 e1488 0)) tmp1486) (syntax-violation #f "source expression failed to match any pattern" tmp1485))) ($sc-dispatch tmp1485 (quote (any any))))) x1484))))) -(define include (make-syncase-macro (quote macro) (lambda (x1489) (letrec ((read-file1490 (lambda (fn1491 k1492) (let ((p1493 (open-input-file fn1491))) (letrec ((f1494 (lambda (x1495) (if (eof-object? x1495) (begin (close-input-port p1493) (quote ())) (cons (datum->syntax k1492 x1495) (f1494 (read p1493))))))) (f1494 (read p1493))))))) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (k1498 filename1499) (let ((fn1500 (syntax->datum filename1499))) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (exp1503) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1503)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote each-any)))) (read-file1490 fn1500 k1498)))) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any any))))) x1489))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1505)) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any))))) x1505)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1510) ((lambda (tmp1511) ((lambda (tmp1512) (if tmp1512 (apply (lambda (_1513 e1514) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1510)) tmp1512) (syntax-violation #f "source expression failed to match any pattern" tmp1511))) ($sc-dispatch tmp1511 (quote (any any))))) x1510)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if tmp1517 (apply (lambda (_1518 e1519 m11520 m21521) ((lambda (tmp1522) ((lambda (body1523) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1519)) body1523)) tmp1522)) (letrec ((f1524 (lambda (clause1525 clauses1526) (if (null? clauses1526) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (e11530 e21531) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11530 e21531))) tmp1529) ((lambda (tmp1533) (if tmp1533 (apply (lambda (k1534 e11535 e21536) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1534)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11535 e21536)))) tmp1533) ((lambda (_1539) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1528))) ($sc-dispatch tmp1528 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1528 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1525) ((lambda (tmp1540) ((lambda (rest1541) ((lambda (tmp1542) ((lambda (tmp1543) (if tmp1543 (apply (lambda (k1544 e11545 e21546) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1544)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11545 e21546)) rest1541)) tmp1543) ((lambda (_1549) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1542))) ($sc-dispatch tmp1542 (quote (each-any any . each-any))))) clause1525)) tmp1540)) (f1524 (car clauses1526) (cdr clauses1526))))))) (f1524 m11520 m21521)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any any any . each-any))))) x1515)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e1554) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1554)) (list (cons _1553 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1554 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1552) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any any))))) x1550)))) +(letrec ((and-map*2008 (lambda (f2048 first2047 . rest2046) (let ((t2049 (null? first2047))) (if t2049 t2049 (if (null? rest2046) (letrec ((andmap2050 (lambda (first2051) (let ((x2052 (car first2051)) (first2053 (cdr first2051))) (if (null? first2053) (f2048 x2052) (if (f2048 x2052) (andmap2050 first2053) #f)))))) (andmap2050 first2047)) (letrec ((andmap2054 (lambda (first2055 rest2056) (let ((x2057 (car first2055)) (xr2058 (map car rest2056)) (first2059 (cdr first2055)) (rest2060 (map cdr rest2056))) (if (null? first2059) (apply f2048 (cons x2057 xr2058)) (if (apply f2048 (cons x2057 xr2058)) (andmap2054 first2059 rest2060) #f)))))) (andmap2054 first2047 rest2046)))))))) (letrec ((lambda-var-list2153 (lambda (vars2282) (letrec ((lvl2283 (lambda (vars2284 ls2285 w2286) (if (pair? vars2284) (lvl2283 (cdr vars2284) (cons (wrap2132 (car vars2284) w2286 #f) ls2285) w2286) (if (id?2104 vars2284) (cons (wrap2132 vars2284 w2286 #f) ls2285) (if (null? vars2284) ls2285 (if (syntax-object?2088 vars2284) (lvl2283 (syntax-object-expression2089 vars2284) ls2285 (join-wraps2123 w2286 (syntax-object-wrap2090 vars2284))) (if (annotation? vars2284) (lvl2283 (annotation-expression vars2284) ls2285 w2286) (cons vars2284 ls2285))))))))) (lvl2283 vars2282 (quote ()) (quote (())))))) (gen-var2152 (lambda (id2287) (let ((id2288 (if (syntax-object?2088 id2287) (syntax-object-expression2089 id2287) id2287))) (if (annotation? id2288) (gensym (symbol->string (annotation-expression id2288))) (gensym (symbol->string id2288)))))) (strip2151 (lambda (x2289 w2290) (if (memq (quote top) (wrap-marks2107 w2290)) (if (let ((t2291 (annotation? x2289))) (if t2291 t2291 (if (pair? x2289) (annotation? (car x2289)) #f))) (strip-annotation2150 x2289 #f) x2289) (letrec ((f2292 (lambda (x2293) (if (syntax-object?2088 x2293) (strip2151 (syntax-object-expression2089 x2293) (syntax-object-wrap2090 x2293)) (if (pair? x2293) (let ((a2294 (f2292 (car x2293))) (d2295 (f2292 (cdr x2293)))) (if (if (eq? a2294 (car x2293)) (eq? d2295 (cdr x2293)) #f) x2293 (cons a2294 d2295))) (if (vector? x2293) (let ((old2296 (vector->list x2293))) (let ((new2297 (map f2292 old2296))) (if (and-map*2008 eq? old2296 new2297) x2293 (list->vector new2297)))) x2293)))))) (f2292 x2289))))) (strip-annotation2150 (lambda (x2298 parent2299) (if (pair? x2298) (let ((new2300 (cons #f #f))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2300) (if #f #f)) (set-car! new2300 (strip-annotation2150 (car x2298) #f)) (set-cdr! new2300 (strip-annotation2150 (cdr x2298) #f)) new2300)) (if (annotation? x2298) (let ((t2301 (annotation-stripped x2298))) (if t2301 t2301 (strip-annotation2150 (annotation-expression x2298) x2298))) (if (vector? x2298) (let ((new2302 (make-vector (vector-length x2298)))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2302) (if #f #f)) (letrec ((loop2303 (lambda (i2304) (unless (fx<2066 i2304 0) (vector-set! new2302 i2304 (strip-annotation2150 (vector-ref x2298 i2304) #f)) (loop2303 (fx-2064 i2304 1)))))) (loop2303 (- (vector-length x2298) 1))) new2302)) x2298))))) (ellipsis?2149 (lambda (x2305) (if (nonsymbol-id?2103 x2305) (free-id=?2127 x2305 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void2148 (lambda () (build-void2071 #f))) (eval-local-transformer2147 (lambda (expanded2306 mod2307) (let ((p2308 (local-eval-hook2068 expanded2306 mod2307))) (if (procedure? p2308) p2308 (syntax-violation #f "nonprocedure transformer" p2308))))) (chi-local-syntax2146 (lambda (rec?2309 e2310 r2311 w2312 s2313 mod2314 k2315) ((lambda (tmp2316) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 id2319 val2320 e12321 e22322) (let ((ids2323 id2319)) (if (not (valid-bound-ids?2129 ids2323)) (syntax-violation #f "duplicate bound keyword" e2310) (let ((labels2325 (gen-labels2110 ids2323))) (let ((new-w2326 (make-binding-wrap2121 ids2323 labels2325 w2312))) (k2315 (cons e12321 e22322) (extend-env2098 labels2325 (let ((w2328 (if rec?2309 new-w2326 w2312)) (trans-r2329 (macros-only-env2100 r2311))) (map (lambda (x2330) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2330 trans-r2329 w2328 mod2314) mod2314))) val2320)) r2311) new-w2326 s2313 mod2314)))))) tmp2317) ((lambda (_2332) (syntax-violation #f "bad local syntax definition" (source-wrap2133 e2310 w2312 s2313 mod2314))) tmp2316))) ($sc-dispatch tmp2316 (quote (any #(each (any any)) any . each-any))))) e2310))) (chi-lambda-clause2145 (lambda (e2333 docstring2334 c2335 r2336 w2337 mod2338 k2339) ((lambda (tmp2340) ((lambda (tmp2341) (if (if tmp2341 (apply (lambda (args2342 doc2343 e12344 e22345) (if (string? (syntax->datum doc2343)) (not docstring2334) #f)) tmp2341) #f) (apply (lambda (args2346 doc2347 e12348 e22349) (chi-lambda-clause2145 e2333 doc2347 (cons args2346 (cons e12348 e22349)) r2336 w2337 mod2338 k2339)) tmp2341) ((lambda (tmp2351) (if tmp2351 (apply (lambda (id2352 e12353 e22354) (let ((ids2355 id2352)) (if (not (valid-bound-ids?2129 ids2355)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2357 (gen-labels2110 ids2355)) (new-vars2358 (map gen-var2152 ids2355))) (k2339 (map syntax->datum ids2355) new-vars2358 docstring2334 (chi-body2144 (cons e12353 e22354) e2333 (extend-var-env2099 labels2357 new-vars2358 r2336) (make-binding-wrap2121 ids2355 labels2357 w2337) mod2338)))))) tmp2351) ((lambda (tmp2360) (if tmp2360 (apply (lambda (ids2361 e12362 e22363) (let ((old-ids2364 (lambda-var-list2153 ids2361))) (if (not (valid-bound-ids?2129 old-ids2364)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2365 (gen-labels2110 old-ids2364)) (new-vars2366 (map gen-var2152 old-ids2364))) (k2339 (letrec ((f2367 (lambda (ls12368 ls22369) (if (null? ls12368) (syntax->datum ls22369) (f2367 (cdr ls12368) (cons (syntax->datum (car ls12368)) ls22369)))))) (f2367 (cdr old-ids2364) (car old-ids2364))) (letrec ((f2370 (lambda (ls12371 ls22372) (if (null? ls12371) ls22372 (f2370 (cdr ls12371) (cons (car ls12371) ls22372)))))) (f2370 (cdr new-vars2366) (car new-vars2366))) docstring2334 (chi-body2144 (cons e12362 e22363) e2333 (extend-var-env2099 labels2365 new-vars2366 r2336) (make-binding-wrap2121 old-ids2364 labels2365 w2337) mod2338)))))) tmp2360) ((lambda (_2374) (syntax-violation (quote lambda) "bad lambda" e2333)) tmp2340))) ($sc-dispatch tmp2340 (quote (any any . each-any)))))) ($sc-dispatch tmp2340 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2340 (quote (any any any . each-any))))) c2335))) (chi-body2144 (lambda (body2375 outer-form2376 r2377 w2378 mod2379) (let ((r2380 (cons (quote ("placeholder" placeholder)) r2377))) (let ((ribcage2381 (make-ribcage2111 (quote ()) (quote ()) (quote ())))) (let ((w2382 (make-wrap2106 (wrap-marks2107 w2378) (cons ribcage2381 (wrap-subst2108 w2378))))) (letrec ((parse2383 (lambda (body2384 ids2385 labels2386 vars2387 vals2388 bindings2389) (if (null? body2384) (syntax-violation #f "no expressions in body" outer-form2376) (let ((e2391 (cdar body2384)) (er2392 (caar body2384))) (call-with-values (lambda () (syntax-type2138 e2391 er2392 (quote (())) #f ribcage2381 mod2379)) (lambda (type2393 value2394 e2395 w2396 s2397 mod2398) (if (memv type2393 (quote (define-form))) (let ((id2399 (wrap2132 value2394 w2396 mod2398)) (label2400 (gen-label2109))) (let ((var2401 (gen-var2152 id2399))) (begin (extend-ribcage!2120 ribcage2381 id2399 label2400) (parse2383 (cdr body2384) (cons id2399 ids2385) (cons label2400 labels2386) (cons var2401 vars2387) (cons (cons er2392 (wrap2132 e2395 w2396 mod2398)) vals2388) (cons (cons (quote lexical) var2401) bindings2389))))) (if (memv type2393 (quote (define-syntax-form))) (let ((id2402 (wrap2132 value2394 w2396 mod2398)) (label2403 (gen-label2109))) (begin (extend-ribcage!2120 ribcage2381 id2402 label2403) (parse2383 (cdr body2384) (cons id2402 ids2385) (cons label2403 labels2386) vars2387 vals2388 (cons (cons (quote macro) (cons er2392 (wrap2132 e2395 w2396 mod2398))) bindings2389)))) (if (memv type2393 (quote (begin-form))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 e12407) (parse2383 (letrec ((f2408 (lambda (forms2409) (if (null? forms2409) (cdr body2384) (cons (cons er2392 (wrap2132 (car forms2409) w2396 mod2398)) (f2408 (cdr forms2409))))))) (f2408 e12407)) ids2385 labels2386 vars2387 vals2388 bindings2389)) tmp2405) (syntax-violation #f "source expression failed to match any pattern" tmp2404))) ($sc-dispatch tmp2404 (quote (any . each-any))))) e2395) (if (memv type2393 (quote (local-syntax-form))) (chi-local-syntax2146 value2394 e2395 er2392 w2396 s2397 mod2398 (lambda (forms2411 er2412 w2413 s2414 mod2415) (parse2383 (letrec ((f2416 (lambda (forms2417) (if (null? forms2417) (cdr body2384) (cons (cons er2412 (wrap2132 (car forms2417) w2413 mod2415)) (f2416 (cdr forms2417))))))) (f2416 forms2411)) ids2385 labels2386 vars2387 vals2388 bindings2389))) (if (null? ids2385) (build-sequence2083 #f (map (lambda (x2418) (chi2140 (cdr x2418) (car x2418) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))) (begin (if (not (valid-bound-ids?2129 ids2385)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form2376) (if #f #f)) (letrec ((loop2419 (lambda (bs2420 er-cache2421 r-cache2422) (if (not (null? bs2420)) (let ((b2423 (car bs2420))) (if (eq? (car b2423) (quote macro)) (let ((er2424 (cadr b2423))) (let ((r-cache2425 (if (eq? er2424 er-cache2421) r-cache2422 (macros-only-env2100 er2424)))) (begin (set-cdr! b2423 (eval-local-transformer2147 (chi2140 (cddr b2423) r-cache2425 (quote (())) mod2398) mod2398)) (loop2419 (cdr bs2420) er2424 r-cache2425)))) (loop2419 (cdr bs2420) er-cache2421 r-cache2422))) (if #f #f))))) (loop2419 bindings2389 #f #f)) (set-cdr! r2380 (extend-env2098 labels2386 bindings2389 (cdr r2380))) (build-letrec2086 #f (map syntax->datum ids2385) vars2387 (map (lambda (x2426) (chi2140 (cdr x2426) (car x2426) (quote (())) mod2398)) vals2388) (build-sequence2083 #f (map (lambda (x2427) (chi2140 (cdr x2427) (car x2427) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))))))))))))))))) (parse2383 (map (lambda (x2390) (cons r2380 (wrap2132 x2390 w2382 mod2379))) body2375) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro2143 (lambda (p2428 e2429 r2430 w2431 rib2432 mod2433) (letrec ((rebuild-macro-output2434 (lambda (x2435 m2436) (if (pair? x2435) (cons (rebuild-macro-output2434 (car x2435) m2436) (rebuild-macro-output2434 (cdr x2435) m2436)) (if (syntax-object?2088 x2435) (let ((w2437 (syntax-object-wrap2090 x2435))) (let ((ms2438 (wrap-marks2107 w2437)) (s2439 (wrap-subst2108 w2437))) (if (if (pair? ms2438) (eq? (car ms2438) #f) #f) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cdr ms2438) (if rib2432 (cons rib2432 (cdr s2439)) (cdr s2439))) (syntax-object-module2091 x2435)) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cons m2436 ms2438) (if rib2432 (cons rib2432 (cons (quote shift) s2439)) (cons (quote shift) s2439))) (let ((pmod2440 (procedure-module p2428))) (if pmod2440 (cons (quote hygiene) (module-name pmod2440)) (quote (hygiene guile)))))))) (if (vector? x2435) (let ((n2441 (vector-length x2435))) (let ((v2442 (make-vector n2441))) (letrec ((loop2443 (lambda (i2444) (if (fx=2065 i2444 n2441) (begin (if #f #f (if #f #f)) v2442) (begin (vector-set! v2442 i2444 (rebuild-macro-output2434 (vector-ref x2435 i2444) m2436)) (loop2443 (fx+2063 i2444 1))))))) (loop2443 0)))) (if (symbol? x2435) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap2133 e2429 w2431 s mod2433) x2435) x2435))))))) (rebuild-macro-output2434 (p2428 (wrap2132 e2429 (anti-mark2119 w2431) mod2433)) (string #\m))))) (chi-application2142 (lambda (x2445 e2446 r2447 w2448 s2449 mod2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (e02453 e12454) (build-application2072 s2449 x2445 (map (lambda (e2455) (chi2140 e2455 r2447 w2448 mod2450)) e12454))) tmp2452) (syntax-violation #f "source expression failed to match any pattern" tmp2451))) ($sc-dispatch tmp2451 (quote (any . each-any))))) e2446))) (chi-expr2141 (lambda (type2457 value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (lexical))) (build-lexical-reference2074 (quote value) s2462 e2459 value2458) (if (memv type2457 (quote (core external-macro))) (value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (module-ref))) (call-with-values (lambda () (value2458 e2459)) (lambda (id2464 mod2465) (build-global-reference2077 s2462 id2464 mod2465))) (if (memv type2457 (quote (lexical-call))) (chi-application2142 (build-lexical-reference2074 (quote fun) (source-annotation2095 (car e2459)) (car e2459) value2458) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (global-call))) (chi-application2142 (build-global-reference2077 (source-annotation2095 (car e2459)) value2458 (if (syntax-object?2088 (car e2459)) (syntax-object-module2091 (car e2459)) mod2463)) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (constant))) (build-data2082 s2462 (strip2151 (source-wrap2133 e2459 w2461 s2462 mod2463) (quote (())))) (if (memv type2457 (quote (global))) (build-global-reference2077 s2462 value2458 mod2463) (if (memv type2457 (quote (call))) (chi-application2142 (chi2140 (car e2459) r2460 w2461 mod2463) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (begin-form))) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 e12469 e22470) (chi-sequence2134 (cons e12469 e22470) r2460 w2461 s2462 mod2463)) tmp2467) (syntax-violation #f "source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any any . each-any))))) e2459) (if (memv type2457 (quote (local-syntax-form))) (chi-local-syntax2146 value2458 e2459 r2460 w2461 s2462 mod2463 chi-sequence2134) (if (memv type2457 (quote (eval-when-form))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (_2474 x2475 e12476 e22477) (let ((when-list2478 (chi-when-list2137 e2459 x2475 w2461))) (if (memq (quote eval) when-list2478) (chi-sequence2134 (cons e12476 e22477) r2460 w2461 s2462 mod2463) (chi-void2148)))) tmp2473) (syntax-violation #f "source expression failed to match any pattern" tmp2472))) ($sc-dispatch tmp2472 (quote (any each-any any . each-any))))) e2459) (if (memv type2457 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e2459 (wrap2132 value2458 w2461 mod2463)) (if (memv type2457 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap2133 e2459 w2461 s2462 mod2463)) (if (memv type2457 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap2133 e2459 w2461 s2462 mod2463)) (syntax-violation #f "unexpected syntax" (source-wrap2133 e2459 w2461 s2462 mod2463)))))))))))))))))) (chi2140 (lambda (e2481 r2482 w2483 mod2484) (call-with-values (lambda () (syntax-type2138 e2481 r2482 w2483 #f #f mod2484)) (lambda (type2485 value2486 e2487 w2488 s2489 mod2490) (chi-expr2141 type2485 value2486 e2487 r2482 w2488 s2489 mod2490))))) (chi-top2139 (lambda (e2491 r2492 w2493 m2494 esew2495 mod2496) (call-with-values (lambda () (syntax-type2138 e2491 r2492 w2493 #f #f mod2496)) (lambda (type2504 value2505 e2506 w2507 s2508 mod2509) (if (memv type2504 (quote (begin-form))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (_2512) (chi-void2148)) tmp2511) ((lambda (tmp2513) (if tmp2513 (apply (lambda (_2514 e12515 e22516) (chi-top-sequence2135 (cons e12515 e22516) r2492 w2507 s2508 m2494 esew2495 mod2509)) tmp2513) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote (any any . each-any)))))) ($sc-dispatch tmp2510 (quote (any))))) e2506) (if (memv type2504 (quote (local-syntax-form))) (chi-local-syntax2146 value2505 e2506 r2492 w2507 s2508 mod2509 (lambda (body2518 r2519 w2520 s2521 mod2522) (chi-top-sequence2135 body2518 r2519 w2520 s2521 m2494 esew2495 mod2522))) (if (memv type2504 (quote (eval-when-form))) ((lambda (tmp2523) ((lambda (tmp2524) (if tmp2524 (apply (lambda (_2525 x2526 e12527 e22528) (let ((when-list2529 (chi-when-list2137 e2506 x2526 w2507)) (body2530 (cons e12527 e22528))) (if (eq? m2494 (quote e)) (if (memq (quote eval) when-list2529) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) (chi-void2148)) (if (memq (quote load) when-list2529) (if (let ((t2533 (memq (quote compile) when-list2529))) (if t2533 t2533 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c&e) (quote (compile load)) mod2509) (if (memq m2494 (quote (c c&e))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c) (quote (load)) mod2509) (chi-void2148))) (if (let ((t2534 (memq (quote compile) when-list2529))) (if t2534 t2534 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (begin (top-level-eval-hook2067 (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) mod2509) (chi-void2148)) (chi-void2148)))))) tmp2524) (syntax-violation #f "source expression failed to match any pattern" tmp2523))) ($sc-dispatch tmp2523 (quote (any each-any any . each-any))))) e2506) (if (memv type2504 (quote (define-syntax-form))) (let ((n2535 (id-var-name2126 value2505 w2507)) (r2536 (macros-only-env2100 r2492))) (if (memv m2494 (quote (c))) (if (memq (quote compile) esew2495) (let ((e2537 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2537 mod2509) (if (memq (quote load) esew2495) e2537 (chi-void2148)))) (if (memq (quote load) esew2495) (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) (chi-void2148))) (if (memv m2494 (quote (c&e))) (let ((e2538 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2538 mod2509) e2538)) (begin (if (memq (quote eval) esew2495) (top-level-eval-hook2067 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) mod2509) (if #f #f)) (chi-void2148))))) (if (memv type2504 (quote (define-form))) (let ((n2539 (id-var-name2126 value2505 w2507))) (let ((type2540 (binding-type2096 (lookup2101 n2539 r2492 mod2509)))) (if (memv type2540 (quote (global core macro module-ref))) (let ((x2541 (build-global-definition2079 s2508 n2539 (chi2140 e2506 r2492 w2507 mod2509)))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2541 mod2509) (if #f #f)) x2541)) (if (memv type2540 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e2506 (wrap2132 value2505 w2507 mod2509)) (syntax-violation #f "cannot define keyword at top level" e2506 (wrap2132 value2505 w2507 mod2509)))))) (let ((x2542 (chi-expr2141 type2504 value2505 e2506 r2492 w2507 s2508 mod2509))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2542 mod2509) (if #f #f)) x2542))))))))))) (syntax-type2138 (lambda (e2543 r2544 w2545 s2546 rib2547 mod2548) (if (symbol? e2543) (let ((n2549 (id-var-name2126 e2543 w2545))) (let ((b2550 (lookup2101 n2549 r2544 mod2548))) (let ((type2551 (binding-type2096 b2550))) (if (memv type2551 (quote (lexical))) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (global))) (values type2551 n2549 e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2550) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548))))))) (if (pair? e2543) (let ((first2552 (car e2543))) (if (id?2104 first2552) (let ((n2553 (id-var-name2126 first2552 w2545))) (let ((b2554 (lookup2101 n2553 r2544 (let ((t2555 (if (syntax-object?2088 first2552) (syntax-object-module2091 first2552) #f))) (if t2555 t2555 mod2548))))) (let ((type2556 (binding-type2096 b2554))) (if (memv type2556 (quote (lexical))) (values (quote lexical-call) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (global))) (values (quote global-call) n2553 e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2554) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (if (memv type2556 (quote (core external-macro module-ref))) (values type2556 (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (begin))) (values (quote begin-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (eval-when))) (values (quote eval-when-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (define))) ((lambda (tmp2557) ((lambda (tmp2558) (if (if tmp2558 (apply (lambda (_2559 name2560 val2561) (id?2104 name2560)) tmp2558) #f) (apply (lambda (_2562 name2563 val2564) (values (quote define-form) name2563 val2564 w2545 s2546 mod2548)) tmp2558) ((lambda (tmp2565) (if (if tmp2565 (apply (lambda (_2566 name2567 args2568 e12569 e22570) (if (id?2104 name2567) (valid-bound-ids?2129 (lambda-var-list2153 args2568)) #f)) tmp2565) #f) (apply (lambda (_2571 name2572 args2573 e12574 e22575) (values (quote define-form) (wrap2132 name2572 w2545 mod2548) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap2132 (cons args2573 (cons e12574 e22575)) w2545 mod2548)) (quote (())) s2546 mod2548)) tmp2565) ((lambda (tmp2577) (if (if tmp2577 (apply (lambda (_2578 name2579) (id?2104 name2579)) tmp2577) #f) (apply (lambda (_2580 name2581) (values (quote define-form) (wrap2132 name2581 w2545 mod2548) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2546 mod2548)) tmp2577) (syntax-violation #f "source expression failed to match any pattern" tmp2557))) ($sc-dispatch tmp2557 (quote (any any)))))) ($sc-dispatch tmp2557 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2557 (quote (any any any))))) e2543) (if (memv type2556 (quote (define-syntax))) ((lambda (tmp2582) ((lambda (tmp2583) (if (if tmp2583 (apply (lambda (_2584 name2585 val2586) (id?2104 name2585)) tmp2583) #f) (apply (lambda (_2587 name2588 val2589) (values (quote define-syntax-form) name2588 val2589 w2545 s2546 mod2548)) tmp2583) (syntax-violation #f "source expression failed to match any pattern" tmp2582))) ($sc-dispatch tmp2582 (quote (any any any))))) e2543) (values (quote call) #f e2543 w2545 s2546 mod2548))))))))))))) (values (quote call) #f e2543 w2545 s2546 mod2548))) (if (syntax-object?2088 e2543) (syntax-type2138 (syntax-object-expression2089 e2543) r2544 (join-wraps2123 w2545 (syntax-object-wrap2090 e2543)) #f rib2547 (let ((t2590 (syntax-object-module2091 e2543))) (if t2590 t2590 mod2548))) (if (annotation? e2543) (syntax-type2138 (annotation-expression e2543) r2544 w2545 (annotation-source e2543) rib2547 mod2548) (if (self-evaluating? e2543) (values (quote constant) #f e2543 w2545 s2546 mod2548) (values (quote other) #f e2543 w2545 s2546 mod2548)))))))) (chi-when-list2137 (lambda (e2591 when-list2592 w2593) (letrec ((f2594 (lambda (when-list2595 situations2596) (if (null? when-list2595) situations2596 (f2594 (cdr when-list2595) (cons (let ((x2597 (car when-list2595))) (if (free-id=?2127 x2597 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?2127 x2597 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?2127 x2597 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e2591 (wrap2132 x2597 w2593 #f)))))) situations2596)))))) (f2594 when-list2592 (quote ()))))) (chi-install-global2136 (lambda (name2598 e2599) (build-global-definition2079 #f name2598 (if (let ((v2600 (module-variable (current-module) name2598))) (if v2600 (if (variable-bound? v2600) (if (macro? (variable-ref v2600)) (not (eq? (macro-type (variable-ref v2600)) (quote syncase-macro))) #f) #f) #f)) (build-application2072 #f (build-primref2081 #f (quote make-extended-syncase-macro)) (list (build-application2072 #f (build-primref2081 #f (quote module-ref)) (list (build-application2072 #f (quote current-module) (quote ())) (build-data2082 #f name2598))) (build-data2082 #f (quote macro)) e2599)) (build-application2072 #f (build-primref2081 #f (quote make-syncase-macro)) (list (build-data2082 #f (quote macro)) e2599)))))) (chi-top-sequence2135 (lambda (body2601 r2602 w2603 s2604 m2605 esew2606 mod2607) (build-sequence2083 s2604 (letrec ((dobody2608 (lambda (body2609 r2610 w2611 m2612 esew2613 mod2614) (if (null? body2609) (quote ()) (let ((first2615 (chi-top2139 (car body2609) r2610 w2611 m2612 esew2613 mod2614))) (cons first2615 (dobody2608 (cdr body2609) r2610 w2611 m2612 esew2613 mod2614))))))) (dobody2608 body2601 r2602 w2603 m2605 esew2606 mod2607))))) (chi-sequence2134 (lambda (body2616 r2617 w2618 s2619 mod2620) (build-sequence2083 s2619 (letrec ((dobody2621 (lambda (body2622 r2623 w2624 mod2625) (if (null? body2622) (quote ()) (let ((first2626 (chi2140 (car body2622) r2623 w2624 mod2625))) (cons first2626 (dobody2621 (cdr body2622) r2623 w2624 mod2625))))))) (dobody2621 body2616 r2617 w2618 mod2620))))) (source-wrap2133 (lambda (x2627 w2628 s2629 defmod2630) (wrap2132 (if s2629 (make-annotation x2627 s2629 #f) x2627) w2628 defmod2630))) (wrap2132 (lambda (x2631 w2632 defmod2633) (if (if (null? (wrap-marks2107 w2632)) (null? (wrap-subst2108 w2632)) #f) x2631 (if (syntax-object?2088 x2631) (make-syntax-object2087 (syntax-object-expression2089 x2631) (join-wraps2123 w2632 (syntax-object-wrap2090 x2631)) (syntax-object-module2091 x2631)) (if (null? x2631) x2631 (make-syntax-object2087 x2631 w2632 defmod2633)))))) (bound-id-member?2131 (lambda (x2634 list2635) (if (not (null? list2635)) (let ((t2636 (bound-id=?2128 x2634 (car list2635)))) (if t2636 t2636 (bound-id-member?2131 x2634 (cdr list2635)))) #f))) (distinct-bound-ids?2130 (lambda (ids2637) (letrec ((distinct?2638 (lambda (ids2639) (let ((t2640 (null? ids2639))) (if t2640 t2640 (if (not (bound-id-member?2131 (car ids2639) (cdr ids2639))) (distinct?2638 (cdr ids2639)) #f)))))) (distinct?2638 ids2637)))) (valid-bound-ids?2129 (lambda (ids2641) (if (letrec ((all-ids?2642 (lambda (ids2643) (let ((t2644 (null? ids2643))) (if t2644 t2644 (if (id?2104 (car ids2643)) (all-ids?2642 (cdr ids2643)) #f)))))) (all-ids?2642 ids2641)) (distinct-bound-ids?2130 ids2641) #f))) (bound-id=?2128 (lambda (i2645 j2646) (if (if (syntax-object?2088 i2645) (syntax-object?2088 j2646) #f) (if (eq? (let ((e2647 (syntax-object-expression2089 i2645))) (if (annotation? e2647) (annotation-expression e2647) e2647)) (let ((e2648 (syntax-object-expression2089 j2646))) (if (annotation? e2648) (annotation-expression e2648) e2648))) (same-marks?2125 (wrap-marks2107 (syntax-object-wrap2090 i2645)) (wrap-marks2107 (syntax-object-wrap2090 j2646))) #f) (eq? (let ((e2649 i2645)) (if (annotation? e2649) (annotation-expression e2649) e2649)) (let ((e2650 j2646)) (if (annotation? e2650) (annotation-expression e2650) e2650)))))) (free-id=?2127 (lambda (i2651 j2652) (if (eq? (let ((x2653 i2651)) (let ((e2654 (if (syntax-object?2088 x2653) (syntax-object-expression2089 x2653) x2653))) (if (annotation? e2654) (annotation-expression e2654) e2654))) (let ((x2655 j2652)) (let ((e2656 (if (syntax-object?2088 x2655) (syntax-object-expression2089 x2655) x2655))) (if (annotation? e2656) (annotation-expression e2656) e2656)))) (eq? (id-var-name2126 i2651 (quote (()))) (id-var-name2126 j2652 (quote (())))) #f))) (id-var-name2126 (lambda (id2657 w2658) (letrec ((search-vector-rib2661 (lambda (sym2667 subst2668 marks2669 symnames2670 ribcage2671) (let ((n2672 (vector-length symnames2670))) (letrec ((f2673 (lambda (i2674) (if (fx=2065 i2674 n2672) (search2659 sym2667 (cdr subst2668) marks2669) (if (if (eq? (vector-ref symnames2670 i2674) sym2667) (same-marks?2125 marks2669 (vector-ref (ribcage-marks2114 ribcage2671) i2674)) #f) (values (vector-ref (ribcage-labels2115 ribcage2671) i2674) marks2669) (f2673 (fx+2063 i2674 1))))))) (f2673 0))))) (search-list-rib2660 (lambda (sym2675 subst2676 marks2677 symnames2678 ribcage2679) (letrec ((f2680 (lambda (symnames2681 i2682) (if (null? symnames2681) (search2659 sym2675 (cdr subst2676) marks2677) (if (if (eq? (car symnames2681) sym2675) (same-marks?2125 marks2677 (list-ref (ribcage-marks2114 ribcage2679) i2682)) #f) (values (list-ref (ribcage-labels2115 ribcage2679) i2682) marks2677) (f2680 (cdr symnames2681) (fx+2063 i2682 1))))))) (f2680 symnames2678 0)))) (search2659 (lambda (sym2683 subst2684 marks2685) (if (null? subst2684) (values #f marks2685) (let ((fst2686 (car subst2684))) (if (eq? fst2686 (quote shift)) (search2659 sym2683 (cdr subst2684) (cdr marks2685)) (let ((symnames2687 (ribcage-symnames2113 fst2686))) (if (vector? symnames2687) (search-vector-rib2661 sym2683 subst2684 marks2685 symnames2687 fst2686) (search-list-rib2660 sym2683 subst2684 marks2685 symnames2687 fst2686))))))))) (if (symbol? id2657) (let ((t2688 (call-with-values (lambda () (search2659 id2657 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2690 . ignore2689) x2690)))) (if t2688 t2688 id2657)) (if (syntax-object?2088 id2657) (let ((id2691 (let ((e2693 (syntax-object-expression2089 id2657))) (if (annotation? e2693) (annotation-expression e2693) e2693))) (w12692 (syntax-object-wrap2090 id2657))) (let ((marks2694 (join-marks2124 (wrap-marks2107 w2658) (wrap-marks2107 w12692)))) (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w2658) marks2694)) (lambda (new-id2695 marks2696) (let ((t2697 new-id2695)) (if t2697 t2697 (let ((t2698 (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w12692) marks2696)) (lambda (x2700 . ignore2699) x2700)))) (if t2698 t2698 id2691)))))))) (if (annotation? id2657) (let ((id2701 (let ((e2702 id2657)) (if (annotation? e2702) (annotation-expression e2702) e2702)))) (let ((t2703 (call-with-values (lambda () (search2659 id2701 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2705 . ignore2704) x2705)))) (if t2703 t2703 id2701))) (syntax-violation (quote id-var-name) "invalid id" id2657))))))) (same-marks?2125 (lambda (x2706 y2707) (let ((t2708 (eq? x2706 y2707))) (if t2708 t2708 (if (not (null? x2706)) (if (not (null? y2707)) (if (eq? (car x2706) (car y2707)) (same-marks?2125 (cdr x2706) (cdr y2707)) #f) #f) #f))))) (join-marks2124 (lambda (m12709 m22710) (smart-append2122 m12709 m22710))) (join-wraps2123 (lambda (w12711 w22712) (let ((m12713 (wrap-marks2107 w12711)) (s12714 (wrap-subst2108 w12711))) (if (null? m12713) (if (null? s12714) w22712 (make-wrap2106 (wrap-marks2107 w22712) (smart-append2122 s12714 (wrap-subst2108 w22712)))) (make-wrap2106 (smart-append2122 m12713 (wrap-marks2107 w22712)) (smart-append2122 s12714 (wrap-subst2108 w22712))))))) (smart-append2122 (lambda (m12715 m22716) (if (null? m22716) m12715 (append m12715 m22716)))) (make-binding-wrap2121 (lambda (ids2717 labels2718 w2719) (if (null? ids2717) w2719 (make-wrap2106 (wrap-marks2107 w2719) (cons (let ((labelvec2720 (list->vector labels2718))) (let ((n2721 (vector-length labelvec2720))) (let ((symnamevec2722 (make-vector n2721)) (marksvec2723 (make-vector n2721))) (begin (letrec ((f2724 (lambda (ids2725 i2726) (if (not (null? ids2725)) (call-with-values (lambda () (id-sym-name&marks2105 (car ids2725) w2719)) (lambda (symname2727 marks2728) (begin (vector-set! symnamevec2722 i2726 symname2727) (vector-set! marksvec2723 i2726 marks2728) (f2724 (cdr ids2725) (fx+2063 i2726 1))))) (if #f #f))))) (f2724 ids2717 0)) (make-ribcage2111 symnamevec2722 marksvec2723 labelvec2720))))) (wrap-subst2108 w2719)))))) (extend-ribcage!2120 (lambda (ribcage2729 id2730 label2731) (begin (set-ribcage-symnames!2116 ribcage2729 (cons (let ((e2732 (syntax-object-expression2089 id2730))) (if (annotation? e2732) (annotation-expression e2732) e2732)) (ribcage-symnames2113 ribcage2729))) (set-ribcage-marks!2117 ribcage2729 (cons (wrap-marks2107 (syntax-object-wrap2090 id2730)) (ribcage-marks2114 ribcage2729))) (set-ribcage-labels!2118 ribcage2729 (cons label2731 (ribcage-labels2115 ribcage2729)))))) (anti-mark2119 (lambda (w2733) (make-wrap2106 (cons #f (wrap-marks2107 w2733)) (cons (quote shift) (wrap-subst2108 w2733))))) (set-ribcage-labels!2118 (lambda (x2734 update2735) (vector-set! x2734 3 update2735))) (set-ribcage-marks!2117 (lambda (x2736 update2737) (vector-set! x2736 2 update2737))) (set-ribcage-symnames!2116 (lambda (x2738 update2739) (vector-set! x2738 1 update2739))) (ribcage-labels2115 (lambda (x2740) (vector-ref x2740 3))) (ribcage-marks2114 (lambda (x2741) (vector-ref x2741 2))) (ribcage-symnames2113 (lambda (x2742) (vector-ref x2742 1))) (ribcage?2112 (lambda (x2743) (if (vector? x2743) (if (= (vector-length x2743) 4) (eq? (vector-ref x2743 0) (quote ribcage)) #f) #f))) (make-ribcage2111 (lambda (symnames2744 marks2745 labels2746) (vector (quote ribcage) symnames2744 marks2745 labels2746))) (gen-labels2110 (lambda (ls2747) (if (null? ls2747) (quote ()) (cons (gen-label2109) (gen-labels2110 (cdr ls2747)))))) (gen-label2109 (lambda () (string #\i))) (wrap-subst2108 cdr) (wrap-marks2107 car) (make-wrap2106 cons) (id-sym-name&marks2105 (lambda (x2748 w2749) (if (syntax-object?2088 x2748) (values (let ((e2750 (syntax-object-expression2089 x2748))) (if (annotation? e2750) (annotation-expression e2750) e2750)) (join-marks2124 (wrap-marks2107 w2749) (wrap-marks2107 (syntax-object-wrap2090 x2748)))) (values (let ((e2751 x2748)) (if (annotation? e2751) (annotation-expression e2751) e2751)) (wrap-marks2107 w2749))))) (id?2104 (lambda (x2752) (if (symbol? x2752) #t (if (syntax-object?2088 x2752) (symbol? (let ((e2753 (syntax-object-expression2089 x2752))) (if (annotation? e2753) (annotation-expression e2753) e2753))) (if (annotation? x2752) (symbol? (annotation-expression x2752)) #f))))) (nonsymbol-id?2103 (lambda (x2754) (if (syntax-object?2088 x2754) (symbol? (let ((e2755 (syntax-object-expression2089 x2754))) (if (annotation? e2755) (annotation-expression e2755) e2755))) #f))) (global-extend2102 (lambda (type2756 sym2757 val2758) (put-global-definition-hook2069 sym2757 type2756 val2758))) (lookup2101 (lambda (x2759 r2760 mod2761) (let ((temp2762 (assq x2759 r2760))) (if temp2762 (cdr temp2762) (if (symbol? x2759) (let ((t2763 (get-global-definition-hook2070 x2759 mod2761))) (if t2763 t2763 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env2100 (lambda (r2764) (if (null? r2764) (quote ()) (let ((a2765 (car r2764))) (if (eq? (cadr a2765) (quote macro)) (cons a2765 (macros-only-env2100 (cdr r2764))) (macros-only-env2100 (cdr r2764))))))) (extend-var-env2099 (lambda (labels2766 vars2767 r2768) (if (null? labels2766) r2768 (extend-var-env2099 (cdr labels2766) (cdr vars2767) (cons (cons (car labels2766) (cons (quote lexical) (car vars2767))) r2768))))) (extend-env2098 (lambda (labels2769 bindings2770 r2771) (if (null? labels2769) r2771 (extend-env2098 (cdr labels2769) (cdr bindings2770) (cons (cons (car labels2769) (car bindings2770)) r2771))))) (binding-value2097 cdr) (binding-type2096 car) (source-annotation2095 (lambda (x2772) (if (annotation? x2772) (annotation-source x2772) (if (syntax-object?2088 x2772) (source-annotation2095 (syntax-object-expression2089 x2772)) #f)))) (set-syntax-object-module!2094 (lambda (x2773 update2774) (vector-set! x2773 3 update2774))) (set-syntax-object-wrap!2093 (lambda (x2775 update2776) (vector-set! x2775 2 update2776))) (set-syntax-object-expression!2092 (lambda (x2777 update2778) (vector-set! x2777 1 update2778))) (syntax-object-module2091 (lambda (x2779) (vector-ref x2779 3))) (syntax-object-wrap2090 (lambda (x2780) (vector-ref x2780 2))) (syntax-object-expression2089 (lambda (x2781) (vector-ref x2781 1))) (syntax-object?2088 (lambda (x2782) (if (vector? x2782) (if (= (vector-length x2782) 4) (eq? (vector-ref x2782 0) (quote syntax-object)) #f) #f))) (make-syntax-object2087 (lambda (expression2783 wrap2784 module2785) (vector (quote syntax-object) expression2783 wrap2784 module2785))) (build-letrec2086 (lambda (src2786 ids2787 vars2788 val-exps2789 body-exp2790) (if (null? vars2788) body-exp2790 (let ((atom-key2791 (fluid-ref *mode*2062))) (if (memv atom-key2791 (quote (c))) ((@ (language tree-il) make-letrec) src2786 ids2787 vars2788 val-exps2789 body-exp2790) (list (quote letrec) (map list vars2788 val-exps2789) body-exp2790)))))) (build-named-let2085 (lambda (src2792 ids2793 vars2794 val-exps2795 body-exp2796) (let ((f2797 (car vars2794)) (f-name2798 (car ids2793)) (vars2799 (cdr vars2794)) (ids2800 (cdr ids2793))) (let ((atom-key2801 (fluid-ref *mode*2062))) (if (memv atom-key2801 (quote (c))) ((@ (language tree-il) make-letrec) src2792 (list f-name2798) (list f2797) (list (build-lambda2080 src2792 ids2800 vars2799 #f body-exp2796)) (build-application2072 src2792 (build-lexical-reference2074 (quote fun) src2792 f-name2798 f2797) val-exps2795)) (list (quote let) f2797 (map list vars2799 val-exps2795) body-exp2796)))))) (build-let2084 (lambda (src2802 ids2803 vars2804 val-exps2805 body-exp2806) (if (null? vars2804) body-exp2806 (let ((atom-key2807 (fluid-ref *mode*2062))) (if (memv atom-key2807 (quote (c))) ((@ (language tree-il) make-let) src2802 ids2803 vars2804 val-exps2805 body-exp2806) (list (quote let) (map list vars2804 val-exps2805) body-exp2806)))))) (build-sequence2083 (lambda (src2808 exps2809) (if (null? (cdr exps2809)) (car exps2809) (let ((atom-key2810 (fluid-ref *mode*2062))) (if (memv atom-key2810 (quote (c))) ((@ (language tree-il) make-sequence) src2808 exps2809) (cons (quote begin) exps2809)))))) (build-data2082 (lambda (src2811 exp2812) (let ((atom-key2813 (fluid-ref *mode*2062))) (if (memv atom-key2813 (quote (c))) ((@ (language tree-il) make-const) src2811 exp2812) (if (if (self-evaluating? exp2812) (not (vector? exp2812)) #f) exp2812 (list (quote quote) exp2812)))))) (build-primref2081 (lambda (src2814 name2815) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2816 (fluid-ref *mode*2062))) (if (memv atom-key2816 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2814 name2815) name2815)) (let ((atom-key2817 (fluid-ref *mode*2062))) (if (memv atom-key2817 (quote (c))) ((@ (language tree-il) make-module-ref) src2814 (quote (guile)) name2815 #f) (list (quote @@) (quote (guile)) name2815)))))) (build-lambda2080 (lambda (src2818 ids2819 vars2820 docstring2821 exp2822) (let ((atom-key2823 (fluid-ref *mode*2062))) (if (memv atom-key2823 (quote (c))) ((@ (language tree-il) make-lambda) src2818 ids2819 vars2820 (if docstring2821 (list (cons (quote documentation) docstring2821)) (quote ())) exp2822) (cons (quote lambda) (cons vars2820 (append (if docstring2821 (list docstring2821) (quote ())) (list exp2822)))))))) (build-global-definition2079 (lambda (source2824 var2825 exp2826) (let ((atom-key2827 (fluid-ref *mode*2062))) (if (memv atom-key2827 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2824 var2825 exp2826) (list (quote define) var2825 exp2826))))) (build-global-assignment2078 (lambda (source2828 var2829 exp2830 mod2831) (analyze-variable2076 mod2831 var2829 (lambda (mod2832 var2833 public?2834) (let ((atom-key2835 (fluid-ref *mode*2062))) (if (memv atom-key2835 (quote (c))) ((@ (language tree-il) make-module-set) source2828 mod2832 var2833 public?2834 exp2830) (list (quote set!) (list (if public?2834 (quote @) (quote @@)) mod2832 var2833) exp2830)))) (lambda (var2836) (let ((atom-key2837 (fluid-ref *mode*2062))) (if (memv atom-key2837 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2828 var2836 exp2830) (list (quote set!) var2836 exp2830))))))) (build-global-reference2077 (lambda (source2838 var2839 mod2840) (analyze-variable2076 mod2840 var2839 (lambda (mod2841 var2842 public?2843) (let ((atom-key2844 (fluid-ref *mode*2062))) (if (memv atom-key2844 (quote (c))) ((@ (language tree-il) make-module-ref) source2838 mod2841 var2842 public?2843) (list (if public?2843 (quote @) (quote @@)) mod2841 var2842)))) (lambda (var2845) (let ((atom-key2846 (fluid-ref *mode*2062))) (if (memv atom-key2846 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2838 var2845) var2845)))))) (analyze-variable2076 (lambda (mod2847 var2848 modref-cont2849 bare-cont2850) (if (not mod2847) (bare-cont2850 var2848) (let ((kind2851 (car mod2847)) (mod2852 (cdr mod2847))) (if (memv kind2851 (quote (public))) (modref-cont2849 mod2852 var2848 #t) (if (memv kind2851 (quote (private))) (if (not (equal? mod2852 (module-name (current-module)))) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (if (memv kind2851 (quote (bare))) (bare-cont2850 var2848) (if (memv kind2851 (quote (hygiene))) (if (if (not (equal? mod2852 (module-name (current-module)))) (module-variable (resolve-module mod2852) var2848) #f) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (syntax-violation #f "bad module kind" var2848 mod2852))))))))) (build-lexical-assignment2075 (lambda (source2853 name2854 var2855 exp2856) (let ((atom-key2857 (fluid-ref *mode*2062))) (if (memv atom-key2857 (quote (c))) ((@ (language tree-il) make-lexical-set) source2853 name2854 var2855 exp2856) (list (quote set!) var2855 exp2856))))) (build-lexical-reference2074 (lambda (type2858 source2859 name2860 var2861) (let ((atom-key2862 (fluid-ref *mode*2062))) (if (memv atom-key2862 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2859 name2860 var2861) var2861)))) (build-conditional2073 (lambda (source2863 test-exp2864 then-exp2865 else-exp2866) (let ((atom-key2867 (fluid-ref *mode*2062))) (if (memv atom-key2867 (quote (c))) ((@ (language tree-il) make-conditional) source2863 test-exp2864 then-exp2865 else-exp2866) (list (quote if) test-exp2864 then-exp2865 else-exp2866))))) (build-application2072 (lambda (source2868 fun-exp2869 arg-exps2870) (let ((atom-key2871 (fluid-ref *mode*2062))) (if (memv atom-key2871 (quote (c))) ((@ (language tree-il) make-application) source2868 fun-exp2869 arg-exps2870) (cons fun-exp2869 arg-exps2870))))) (build-void2071 (lambda (source2872) (let ((atom-key2873 (fluid-ref *mode*2062))) (if (memv atom-key2873 (quote (c))) ((@ (language tree-il) make-void) source2872) (quote (if #f #f)))))) (get-global-definition-hook2070 (lambda (symbol2874 module2875) (begin (if (if (not module2875) (current-module) #f) (warn "module system is booted, we should have a module" symbol2874) (if #f #f)) (let ((v2876 (module-variable (if module2875 (resolve-module (cdr module2875)) (current-module)) symbol2874))) (if v2876 (if (variable-bound? v2876) (let ((val2877 (variable-ref v2876))) (if (macro? val2877) (if (syncase-macro-type val2877) (cons (syncase-macro-type val2877) (syncase-macro-binding val2877)) #f) #f)) #f) #f))))) (put-global-definition-hook2069 (lambda (symbol2878 type2879 val2880) (let ((existing2881 (let ((v2882 (module-variable (current-module) symbol2878))) (if v2882 (if (variable-bound? v2882) (let ((val2883 (variable-ref v2882))) (if (macro? val2883) (if (not (syncase-macro-type val2883)) val2883 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2878 (if existing2881 (make-extended-syncase-macro existing2881 type2879 val2880) (make-syncase-macro type2879 val2880)))))) (local-eval-hook2068 (lambda (x2884 mod2885) (primitive-eval (list noexpand2061 (let ((atom-key2886 (fluid-ref *mode*2062))) (if (memv atom-key2886 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2884) x2884)))))) (top-level-eval-hook2067 (lambda (x2887 mod2888) (primitive-eval (list noexpand2061 (let ((atom-key2889 (fluid-ref *mode*2062))) (if (memv atom-key2889 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2887) x2887)))))) (fx<2066 <) (fx=2065 =) (fx-2064 -) (fx+2063 +) (*mode*2062 (make-fluid)) (noexpand2061 "noexpand")) (begin (global-extend2102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend2102 (quote local-syntax) (quote let-syntax) #f) (global-extend2102 (quote core) (quote fluid-let-syntax) (lambda (e2890 r2891 w2892 s2893 mod2894) ((lambda (tmp2895) ((lambda (tmp2896) (if (if tmp2896 (apply (lambda (_2897 var2898 val2899 e12900 e22901) (valid-bound-ids?2129 var2898)) tmp2896) #f) (apply (lambda (_2903 var2904 val2905 e12906 e22907) (let ((names2908 (map (lambda (x2909) (id-var-name2126 x2909 w2892)) var2904))) (begin (for-each (lambda (id2911 n2912) (let ((atom-key2913 (binding-type2096 (lookup2101 n2912 r2891 mod2894)))) (if (memv atom-key2913 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2890 (source-wrap2133 id2911 w2892 s2893 mod2894)) (if #f #f)))) var2904 names2908) (chi-body2144 (cons e12906 e22907) (source-wrap2133 e2890 w2892 s2893 mod2894) (extend-env2098 names2908 (let ((trans-r2916 (macros-only-env2100 r2891))) (map (lambda (x2917) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2917 trans-r2916 w2892 mod2894) mod2894))) val2905)) r2891) w2892 mod2894)))) tmp2896) ((lambda (_2919) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap2133 e2890 w2892 s2893 mod2894))) tmp2895))) ($sc-dispatch tmp2895 (quote (any #(each (any any)) any . each-any))))) e2890))) (global-extend2102 (quote core) (quote quote) (lambda (e2920 r2921 w2922 s2923 mod2924) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 e2928) (build-data2082 s2923 (strip2151 e2928 w2922))) tmp2926) ((lambda (_2929) (syntax-violation (quote quote) "bad syntax" (source-wrap2133 e2920 w2922 s2923 mod2924))) tmp2925))) ($sc-dispatch tmp2925 (quote (any any))))) e2920))) (global-extend2102 (quote core) (quote syntax) (letrec ((regen2937 (lambda (x2938) (let ((atom-key2939 (car x2938))) (if (memv atom-key2939 (quote (ref))) (build-lexical-reference2074 (quote value) #f (cadr x2938) (cadr x2938)) (if (memv atom-key2939 (quote (primitive))) (build-primref2081 #f (cadr x2938)) (if (memv atom-key2939 (quote (quote))) (build-data2082 #f (cadr x2938)) (if (memv atom-key2939 (quote (lambda))) (build-lambda2080 #f (cadr x2938) (cadr x2938) #f (regen2937 (caddr x2938))) (if (memv atom-key2939 (quote (map))) (let ((ls2940 (map regen2937 (cdr x2938)))) (build-application2072 #f (build-primref2081 #f (quote map)) ls2940)) (build-application2072 #f (build-primref2081 #f (car x2938)) (map regen2937 (cdr x2938))))))))))) (gen-vector2936 (lambda (x2941) (if (eq? (car x2941) (quote list)) (cons (quote vector) (cdr x2941)) (if (eq? (car x2941) (quote quote)) (list (quote quote) (list->vector (cadr x2941))) (list (quote list->vector) x2941))))) (gen-append2935 (lambda (x2942 y2943) (if (equal? y2943 (quote (quote ()))) x2942 (list (quote append) x2942 y2943)))) (gen-cons2934 (lambda (x2944 y2945) (let ((atom-key2946 (car y2945))) (if (memv atom-key2946 (quote (quote))) (if (eq? (car x2944) (quote quote)) (list (quote quote) (cons (cadr x2944) (cadr y2945))) (if (eq? (cadr y2945) (quote ())) (list (quote list) x2944) (list (quote cons) x2944 y2945))) (if (memv atom-key2946 (quote (list))) (cons (quote list) (cons x2944 (cdr y2945))) (list (quote cons) x2944 y2945)))))) (gen-map2933 (lambda (e2947 map-env2948) (let ((formals2949 (map cdr map-env2948)) (actuals2950 (map (lambda (x2951) (list (quote ref) (car x2951))) map-env2948))) (if (eq? (car e2947) (quote ref)) (car actuals2950) (if (and-map (lambda (x2952) (if (eq? (car x2952) (quote ref)) (memq (cadr x2952) formals2949) #f)) (cdr e2947)) (cons (quote map) (cons (list (quote primitive) (car e2947)) (map (let ((r2953 (map cons formals2949 actuals2950))) (lambda (x2954) (cdr (assq (cadr x2954) r2953)))) (cdr e2947)))) (cons (quote map) (cons (list (quote lambda) formals2949 e2947) actuals2950))))))) (gen-mappend2932 (lambda (e2955 map-env2956) (list (quote apply) (quote (primitive append)) (gen-map2933 e2955 map-env2956)))) (gen-ref2931 (lambda (src2957 var2958 level2959 maps2960) (if (fx=2065 level2959 0) (values var2958 maps2960) (if (null? maps2960) (syntax-violation (quote syntax) "missing ellipsis" src2957) (call-with-values (lambda () (gen-ref2931 src2957 var2958 (fx-2064 level2959 1) (cdr maps2960))) (lambda (outer-var2961 outer-maps2962) (let ((b2963 (assq outer-var2961 (car maps2960)))) (if b2963 (values (cdr b2963) maps2960) (let ((inner-var2964 (gen-var2152 (quote tmp)))) (values inner-var2964 (cons (cons (cons outer-var2961 inner-var2964) (car maps2960)) outer-maps2962))))))))))) (gen-syntax2930 (lambda (src2965 e2966 r2967 maps2968 ellipsis?2969 mod2970) (if (id?2104 e2966) (let ((label2971 (id-var-name2126 e2966 (quote (()))))) (let ((b2972 (lookup2101 label2971 r2967 mod2970))) (if (eq? (binding-type2096 b2972) (quote syntax)) (call-with-values (lambda () (let ((var.lev2973 (binding-value2097 b2972))) (gen-ref2931 src2965 (car var.lev2973) (cdr var.lev2973) maps2968))) (lambda (var2974 maps2975) (values (list (quote ref) var2974) maps2975))) (if (ellipsis?2969 e2966) (syntax-violation (quote syntax) "misplaced ellipsis" src2965) (values (list (quote quote) e2966) maps2968))))) ((lambda (tmp2976) ((lambda (tmp2977) (if (if tmp2977 (apply (lambda (dots2978 e2979) (ellipsis?2969 dots2978)) tmp2977) #f) (apply (lambda (dots2980 e2981) (gen-syntax2930 src2965 e2981 r2967 maps2968 (lambda (x2982) #f) mod2970)) tmp2977) ((lambda (tmp2983) (if (if tmp2983 (apply (lambda (x2984 dots2985 y2986) (ellipsis?2969 dots2985)) tmp2983) #f) (apply (lambda (x2987 dots2988 y2989) (letrec ((f2990 (lambda (y2991 k2992) ((lambda (tmp2996) ((lambda (tmp2997) (if (if tmp2997 (apply (lambda (dots2998 y2999) (ellipsis?2969 dots2998)) tmp2997) #f) (apply (lambda (dots3000 y3001) (f2990 y3001 (lambda (maps3002) (call-with-values (lambda () (k2992 (cons (quote ()) maps3002))) (lambda (x3003 maps3004) (if (null? (car maps3004)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-mappend2932 x3003 (car maps3004)) (cdr maps3004)))))))) tmp2997) ((lambda (_3005) (call-with-values (lambda () (gen-syntax2930 src2965 y2991 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (y3006 maps3007) (call-with-values (lambda () (k2992 maps3007)) (lambda (x3008 maps3009) (values (gen-append2935 x3008 y3006) maps3009)))))) tmp2996))) ($sc-dispatch tmp2996 (quote (any . any))))) y2991)))) (f2990 y2989 (lambda (maps2993) (call-with-values (lambda () (gen-syntax2930 src2965 x2987 r2967 (cons (quote ()) maps2993) ellipsis?2969 mod2970)) (lambda (x2994 maps2995) (if (null? (car maps2995)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-map2933 x2994 (car maps2995)) (cdr maps2995))))))))) tmp2983) ((lambda (tmp3010) (if tmp3010 (apply (lambda (x3011 y3012) (call-with-values (lambda () (gen-syntax2930 src2965 x3011 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (x3013 maps3014) (call-with-values (lambda () (gen-syntax2930 src2965 y3012 r2967 maps3014 ellipsis?2969 mod2970)) (lambda (y3015 maps3016) (values (gen-cons2934 x3013 y3015) maps3016)))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (e13018 e23019) (call-with-values (lambda () (gen-syntax2930 src2965 (cons e13018 e23019) r2967 maps2968 ellipsis?2969 mod2970)) (lambda (e3021 maps3022) (values (gen-vector2936 e3021) maps3022)))) tmp3017) ((lambda (_3023) (values (list (quote quote) e2966) maps2968)) tmp2976))) ($sc-dispatch tmp2976 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2976 (quote (any . any)))))) ($sc-dispatch tmp2976 (quote (any any . any)))))) ($sc-dispatch tmp2976 (quote (any any))))) e2966))))) (lambda (e3024 r3025 w3026 s3027 mod3028) (let ((e3029 (source-wrap2133 e3024 w3026 s3027 mod3028))) ((lambda (tmp3030) ((lambda (tmp3031) (if tmp3031 (apply (lambda (_3032 x3033) (call-with-values (lambda () (gen-syntax2930 e3029 x3033 r3025 (quote ()) ellipsis?2149 mod3028)) (lambda (e3034 maps3035) (regen2937 e3034)))) tmp3031) ((lambda (_3036) (syntax-violation (quote syntax) "bad `syntax' form" e3029)) tmp3030))) ($sc-dispatch tmp3030 (quote (any any))))) e3029))))) (global-extend2102 (quote core) (quote lambda) (lambda (e3037 r3038 w3039 s3040 mod3041) ((lambda (tmp3042) ((lambda (tmp3043) (if tmp3043 (apply (lambda (_3044 c3045) (chi-lambda-clause2145 (source-wrap2133 e3037 w3039 s3040 mod3041) #f c3045 r3038 w3039 mod3041 (lambda (names3046 vars3047 docstring3048 body3049) (build-lambda2080 s3040 names3046 vars3047 docstring3048 body3049)))) tmp3043) (syntax-violation #f "source expression failed to match any pattern" tmp3042))) ($sc-dispatch tmp3042 (quote (any . any))))) e3037))) (global-extend2102 (quote core) (quote let) (letrec ((chi-let3050 (lambda (e3051 r3052 w3053 s3054 mod3055 constructor3056 ids3057 vals3058 exps3059) (if (not (valid-bound-ids?2129 ids3057)) (syntax-violation (quote let) "duplicate bound variable" e3051) (let ((labels3060 (gen-labels2110 ids3057)) (new-vars3061 (map gen-var2152 ids3057))) (let ((nw3062 (make-binding-wrap2121 ids3057 labels3060 w3053)) (nr3063 (extend-var-env2099 labels3060 new-vars3061 r3052))) (constructor3056 s3054 (map syntax->datum ids3057) new-vars3061 (map (lambda (x3064) (chi2140 x3064 r3052 w3053 mod3055)) vals3058) (chi-body2144 exps3059 (source-wrap2133 e3051 nw3062 s3054 mod3055) nr3063 nw3062 mod3055)))))))) (lambda (e3065 r3066 w3067 s3068 mod3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (_3072 id3073 val3074 e13075 e23076) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-let2084 id3073 val3074 (cons e13075 e23076))) tmp3071) ((lambda (tmp3080) (if (if tmp3080 (apply (lambda (_3081 f3082 id3083 val3084 e13085 e23086) (id?2104 f3082)) tmp3080) #f) (apply (lambda (_3087 f3088 id3089 val3090 e13091 e23092) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-named-let2085 (cons f3088 id3089) val3090 (cons e13091 e23092))) tmp3080) ((lambda (_3096) (syntax-violation (quote let) "bad let" (source-wrap2133 e3065 w3067 s3068 mod3069))) tmp3070))) ($sc-dispatch tmp3070 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3070 (quote (any #(each (any any)) any . each-any))))) e3065)))) (global-extend2102 (quote core) (quote letrec) (lambda (e3097 r3098 w3099 s3100 mod3101) ((lambda (tmp3102) ((lambda (tmp3103) (if tmp3103 (apply (lambda (_3104 id3105 val3106 e13107 e23108) (let ((ids3109 id3105)) (if (not (valid-bound-ids?2129 ids3109)) (syntax-violation (quote letrec) "duplicate bound variable" e3097) (let ((labels3111 (gen-labels2110 ids3109)) (new-vars3112 (map gen-var2152 ids3109))) (let ((w3113 (make-binding-wrap2121 ids3109 labels3111 w3099)) (r3114 (extend-var-env2099 labels3111 new-vars3112 r3098))) (build-letrec2086 s3100 (map syntax->datum ids3109) new-vars3112 (map (lambda (x3115) (chi2140 x3115 r3114 w3113 mod3101)) val3106) (chi-body2144 (cons e13107 e23108) (source-wrap2133 e3097 w3113 s3100 mod3101) r3114 w3113 mod3101))))))) tmp3103) ((lambda (_3118) (syntax-violation (quote letrec) "bad letrec" (source-wrap2133 e3097 w3099 s3100 mod3101))) tmp3102))) ($sc-dispatch tmp3102 (quote (any #(each (any any)) any . each-any))))) e3097))) (global-extend2102 (quote core) (quote set!) (lambda (e3119 r3120 w3121 s3122 mod3123) ((lambda (tmp3124) ((lambda (tmp3125) (if (if tmp3125 (apply (lambda (_3126 id3127 val3128) (id?2104 id3127)) tmp3125) #f) (apply (lambda (_3129 id3130 val3131) (let ((val3132 (chi2140 val3131 r3120 w3121 mod3123)) (n3133 (id-var-name2126 id3130 w3121))) (let ((b3134 (lookup2101 n3133 r3120 mod3123))) (let ((atom-key3135 (binding-type2096 b3134))) (if (memv atom-key3135 (quote (lexical))) (build-lexical-assignment2075 s3122 (syntax->datum id3130) (binding-value2097 b3134) val3132) (if (memv atom-key3135 (quote (global))) (build-global-assignment2078 s3122 n3133 val3132 mod3123) (if (memv atom-key3135 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap2132 id3130 w3121 mod3123)) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))))))))) tmp3125) ((lambda (tmp3136) (if tmp3136 (apply (lambda (_3137 head3138 tail3139 val3140) (call-with-values (lambda () (syntax-type2138 head3138 r3120 (quote (())) #f #f mod3123)) (lambda (type3141 value3142 ee3143 ww3144 ss3145 modmod3146) (if (memv type3141 (quote (module-ref))) (let ((val3147 (chi2140 val3140 r3120 w3121 mod3123))) (call-with-values (lambda () (value3142 (cons head3138 tail3139))) (lambda (id3149 mod3150) (build-global-assignment2078 s3122 id3149 val3147 mod3150)))) (build-application2072 s3122 (chi2140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head3138) r3120 w3121 mod3123) (map (lambda (e3151) (chi2140 e3151 r3120 w3121 mod3123)) (append tail3139 (list val3140)))))))) tmp3136) ((lambda (_3153) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))) tmp3124))) ($sc-dispatch tmp3124 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp3124 (quote (any any any))))) e3119))) (global-extend2102 (quote module-ref) (quote @) (lambda (e3154) ((lambda (tmp3155) ((lambda (tmp3156) (if (if tmp3156 (apply (lambda (_3157 mod3158 id3159) (if (and-map id?2104 mod3158) (id?2104 id3159) #f)) tmp3156) #f) (apply (lambda (_3161 mod3162 id3163) (values (syntax->datum id3163) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3162)))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any each-any any))))) e3154))) (global-extend2102 (quote module-ref) (quote @@) (lambda (e3165) ((lambda (tmp3166) ((lambda (tmp3167) (if (if tmp3167 (apply (lambda (_3168 mod3169 id3170) (if (and-map id?2104 mod3169) (id?2104 id3170) #f)) tmp3167) #f) (apply (lambda (_3172 mod3173 id3174) (values (syntax->datum id3174) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3173)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any each-any any))))) e3165))) (global-extend2102 (quote core) (quote if) (lambda (e3176 r3177 w3178 s3179 mod3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 test3184 then3185) (build-conditional2073 s3179 (chi2140 test3184 r3177 w3178 mod3180) (chi2140 then3185 r3177 w3178 mod3180) (build-void2071 #f))) tmp3182) ((lambda (tmp3186) (if tmp3186 (apply (lambda (_3187 test3188 then3189 else3190) (build-conditional2073 s3179 (chi2140 test3188 r3177 w3178 mod3180) (chi2140 then3189 r3177 w3178 mod3180) (chi2140 else3190 r3177 w3178 mod3180))) tmp3186) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any any any)))))) ($sc-dispatch tmp3181 (quote (any any any))))) e3176))) (global-extend2102 (quote begin) (quote begin) (quote ())) (global-extend2102 (quote define) (quote define) (quote ())) (global-extend2102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend2102 (quote eval-when) (quote eval-when) (quote ())) (global-extend2102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case3194 (lambda (x3195 keys3196 clauses3197 r3198 mod3199) (if (null? clauses3197) (build-application2072 #f (build-primref2081 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x3195)) ((lambda (tmp3200) ((lambda (tmp3201) (if tmp3201 (apply (lambda (pat3202 exp3203) (if (if (id?2104 pat3202) (and-map (lambda (x3204) (not (free-id=?2127 pat3202 x3204))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys3196)) #f) (let ((labels3205 (list (gen-label2109))) (var3206 (gen-var2152 pat3202))) (build-application2072 #f (build-lambda2080 #f (list (syntax->datum pat3202)) (list var3206) #f (chi2140 exp3203 (extend-env2098 labels3205 (list (cons (quote syntax) (cons var3206 0))) r3198) (make-binding-wrap2121 (list pat3202) labels3205 (quote (()))) mod3199)) (list x3195))) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3202 #t exp3203 mod3199))) tmp3201) ((lambda (tmp3207) (if tmp3207 (apply (lambda (pat3208 fender3209 exp3210) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3208 fender3209 exp3210 mod3199)) tmp3207) ((lambda (_3211) (syntax-violation (quote syntax-case) "invalid clause" (car clauses3197))) tmp3200))) ($sc-dispatch tmp3200 (quote (any any any)))))) ($sc-dispatch tmp3200 (quote (any any))))) (car clauses3197))))) (gen-clause3193 (lambda (x3212 keys3213 clauses3214 r3215 pat3216 fender3217 exp3218 mod3219) (call-with-values (lambda () (convert-pattern3191 pat3216 keys3213)) (lambda (p3220 pvars3221) (if (not (distinct-bound-ids?2130 (map car pvars3221))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat3216) (if (not (and-map (lambda (x3222) (not (ellipsis?2149 (car x3222)))) pvars3221)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat3216) (let ((y3223 (gen-var2152 (quote tmp)))) (build-application2072 #f (build-lambda2080 #f (list (quote tmp)) (list y3223) #f (let ((y3224 (build-lexical-reference2074 (quote value) #f (quote tmp) y3223))) (build-conditional2073 #f ((lambda (tmp3225) ((lambda (tmp3226) (if tmp3226 (apply (lambda () y3224) tmp3226) ((lambda (_3227) (build-conditional2073 #f y3224 (build-dispatch-call3192 pvars3221 fender3217 y3224 r3215 mod3219) (build-data2082 #f #f))) tmp3225))) ($sc-dispatch tmp3225 (quote #(atom #t))))) fender3217) (build-dispatch-call3192 pvars3221 exp3218 y3224 r3215 mod3219) (gen-syntax-case3194 x3212 keys3213 clauses3214 r3215 mod3219)))) (list (if (eq? p3220 (quote any)) (build-application2072 #f (build-primref2081 #f (quote list)) (list x3212)) (build-application2072 #f (build-primref2081 #f (quote $sc-dispatch)) (list x3212 (build-data2082 #f p3220))))))))))))) (build-dispatch-call3192 (lambda (pvars3228 exp3229 y3230 r3231 mod3232) (let ((ids3233 (map car pvars3228)) (levels3234 (map cdr pvars3228))) (let ((labels3235 (gen-labels2110 ids3233)) (new-vars3236 (map gen-var2152 ids3233))) (build-application2072 #f (build-primref2081 #f (quote apply)) (list (build-lambda2080 #f (map syntax->datum ids3233) new-vars3236 #f (chi2140 exp3229 (extend-env2098 labels3235 (map (lambda (var3237 level3238) (cons (quote syntax) (cons var3237 level3238))) new-vars3236 (map cdr pvars3228)) r3231) (make-binding-wrap2121 ids3233 labels3235 (quote (()))) mod3232)) y3230)))))) (convert-pattern3191 (lambda (pattern3239 keys3240) (letrec ((cvt3241 (lambda (p3242 n3243 ids3244) (if (id?2104 p3242) (if (bound-id-member?2131 p3242 keys3240) (values (vector (quote free-id) p3242) ids3244) (values (quote any) (cons (cons p3242 n3243) ids3244))) ((lambda (tmp3245) ((lambda (tmp3246) (if (if tmp3246 (apply (lambda (x3247 dots3248) (ellipsis?2149 dots3248)) tmp3246) #f) (apply (lambda (x3249 dots3250) (call-with-values (lambda () (cvt3241 x3249 (fx+2063 n3243 1) ids3244)) (lambda (p3251 ids3252) (values (if (eq? p3251 (quote any)) (quote each-any) (vector (quote each) p3251)) ids3252)))) tmp3246) ((lambda (tmp3253) (if tmp3253 (apply (lambda (x3254 y3255) (call-with-values (lambda () (cvt3241 y3255 n3243 ids3244)) (lambda (y3256 ids3257) (call-with-values (lambda () (cvt3241 x3254 n3243 ids3257)) (lambda (x3258 ids3259) (values (cons x3258 y3256) ids3259)))))) tmp3253) ((lambda (tmp3260) (if tmp3260 (apply (lambda () (values (quote ()) ids3244)) tmp3260) ((lambda (tmp3261) (if tmp3261 (apply (lambda (x3262) (call-with-values (lambda () (cvt3241 x3262 n3243 ids3244)) (lambda (p3264 ids3265) (values (vector (quote vector) p3264) ids3265)))) tmp3261) ((lambda (x3266) (values (vector (quote atom) (strip2151 p3242 (quote (())))) ids3244)) tmp3245))) ($sc-dispatch tmp3245 (quote #(vector each-any)))))) ($sc-dispatch tmp3245 (quote ()))))) ($sc-dispatch tmp3245 (quote (any . any)))))) ($sc-dispatch tmp3245 (quote (any any))))) p3242))))) (cvt3241 pattern3239 0 (quote ())))))) (lambda (e3267 r3268 w3269 s3270 mod3271) (let ((e3272 (source-wrap2133 e3267 w3269 s3270 mod3271))) ((lambda (tmp3273) ((lambda (tmp3274) (if tmp3274 (apply (lambda (_3275 val3276 key3277 m3278) (if (and-map (lambda (x3279) (if (id?2104 x3279) (not (ellipsis?2149 x3279)) #f)) key3277) (let ((x3281 (gen-var2152 (quote tmp)))) (build-application2072 s3270 (build-lambda2080 #f (list (quote tmp)) (list x3281) #f (gen-syntax-case3194 (build-lexical-reference2074 (quote value) #f (quote tmp) x3281) key3277 m3278 r3268 mod3271)) (list (chi2140 val3276 r3268 (quote (())) mod3271)))) (syntax-violation (quote syntax-case) "invalid literals list" e3272))) tmp3274) (syntax-violation #f "source expression failed to match any pattern" tmp3273))) ($sc-dispatch tmp3273 (quote (any any each-any . each-any))))) e3272))))) (set! sc-expand (lambda (x3285 . rest3284) (if (if (pair? x3285) (equal? (car x3285) noexpand2061) #f) (cadr x3285) (let ((m3286 (if (null? rest3284) (quote e) (car rest3284))) (esew3287 (if (let ((t3288 (null? rest3284))) (if t3288 t3288 (null? (cdr rest3284)))) (quote (eval)) (cadr rest3284)))) (with-fluid* *mode*2062 m3286 (lambda () (chi-top2139 x3285 (quote ()) (quote ((top))) m3286 esew3287 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x3289) (nonsymbol-id?2103 x3289))) (set! datum->syntax (lambda (id3290 datum3291) (make-syntax-object2087 datum3291 (syntax-object-wrap2090 id3290) #f))) (set! syntax->datum (lambda (x3292) (strip2151 x3292 (quote (()))))) (set! generate-temporaries (lambda (ls3293) (begin (let ((x3294 ls3293)) (if (not (list? x3294)) (syntax-violation (quote generate-temporaries) "invalid argument" x3294) (if #f #f))) (map (lambda (x3295) (wrap2132 (gensym) (quote ((top))) #f)) ls3293)))) (set! free-identifier=? (lambda (x3296 y3297) (begin (let ((x3298 x3296)) (if (not (nonsymbol-id?2103 x3298)) (syntax-violation (quote free-identifier=?) "invalid argument" x3298) (if #f #f))) (let ((x3299 y3297)) (if (not (nonsymbol-id?2103 x3299)) (syntax-violation (quote free-identifier=?) "invalid argument" x3299) (if #f #f))) (free-id=?2127 x3296 y3297)))) (set! bound-identifier=? (lambda (x3300 y3301) (begin (let ((x3302 x3300)) (if (not (nonsymbol-id?2103 x3302)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3302) (if #f #f))) (let ((x3303 y3301)) (if (not (nonsymbol-id?2103 x3303)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3303) (if #f #f))) (bound-id=?2128 x3300 y3301)))) (set! syntax-violation (lambda (who3307 message3306 form3305 . subform3304) (begin (let ((x3308 who3307)) (if (not ((lambda (x3309) (let ((t3310 (not x3309))) (if t3310 t3310 (let ((t3311 (string? x3309))) (if t3311 t3311 (symbol? x3309)))))) x3308)) (syntax-violation (quote syntax-violation) "invalid argument" x3308) (if #f #f))) (let ((x3312 message3306)) (if (not (string? x3312)) (syntax-violation (quote syntax-violation) "invalid argument" x3312) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who3307 "~a: " "") "~a " (if (null? subform3304) "in ~a" "in subform `~s' of `~s'")) (let ((tail3313 (cons message3306 (map (lambda (x3314) (strip2151 x3314 (quote (())))) (append subform3304 (list form3305)))))) (if who3307 (cons who3307 tail3313) tail3313)) #f)))) (letrec ((match3319 (lambda (e3320 p3321 w3322 r3323 mod3324) (if (not r3323) #f (if (eq? p3321 (quote any)) (cons (wrap2132 e3320 w3322 mod3324) r3323) (if (syntax-object?2088 e3320) (match*3318 (let ((e3325 (syntax-object-expression2089 e3320))) (if (annotation? e3325) (annotation-expression e3325) e3325)) p3321 (join-wraps2123 w3322 (syntax-object-wrap2090 e3320)) r3323 (syntax-object-module2091 e3320)) (match*3318 (let ((e3326 e3320)) (if (annotation? e3326) (annotation-expression e3326) e3326)) p3321 w3322 r3323 mod3324)))))) (match*3318 (lambda (e3327 p3328 w3329 r3330 mod3331) (if (null? p3328) (if (null? e3327) r3330 #f) (if (pair? p3328) (if (pair? e3327) (match3319 (car e3327) (car p3328) w3329 (match3319 (cdr e3327) (cdr p3328) w3329 r3330 mod3331) mod3331) #f) (if (eq? p3328 (quote each-any)) (let ((l3332 (match-each-any3316 e3327 w3329 mod3331))) (if l3332 (cons l3332 r3330) #f)) (let ((atom-key3333 (vector-ref p3328 0))) (if (memv atom-key3333 (quote (each))) (if (null? e3327) (match-empty3317 (vector-ref p3328 1) r3330) (let ((l3334 (match-each3315 e3327 (vector-ref p3328 1) w3329 mod3331))) (if l3334 (letrec ((collect3335 (lambda (l3336) (if (null? (car l3336)) r3330 (cons (map car l3336) (collect3335 (map cdr l3336))))))) (collect3335 l3334)) #f))) (if (memv atom-key3333 (quote (free-id))) (if (id?2104 e3327) (if (free-id=?2127 (wrap2132 e3327 w3329 mod3331) (vector-ref p3328 1)) r3330 #f) #f) (if (memv atom-key3333 (quote (atom))) (if (equal? (vector-ref p3328 1) (strip2151 e3327 w3329)) r3330 #f) (if (memv atom-key3333 (quote (vector))) (if (vector? e3327) (match3319 (vector->list e3327) (vector-ref p3328 1) w3329 r3330 mod3331) #f) (if #f #f))))))))))) (match-empty3317 (lambda (p3337 r3338) (if (null? p3337) r3338 (if (eq? p3337 (quote any)) (cons (quote ()) r3338) (if (pair? p3337) (match-empty3317 (car p3337) (match-empty3317 (cdr p3337) r3338)) (if (eq? p3337 (quote each-any)) (cons (quote ()) r3338) (let ((atom-key3339 (vector-ref p3337 0))) (if (memv atom-key3339 (quote (each))) (match-empty3317 (vector-ref p3337 1) r3338) (if (memv atom-key3339 (quote (free-id atom))) r3338 (if (memv atom-key3339 (quote (vector))) (match-empty3317 (vector-ref p3337 1) r3338) (if #f #f))))))))))) (match-each-any3316 (lambda (e3340 w3341 mod3342) (if (annotation? e3340) (match-each-any3316 (annotation-expression e3340) w3341 mod3342) (if (pair? e3340) (let ((l3343 (match-each-any3316 (cdr e3340) w3341 mod3342))) (if l3343 (cons (wrap2132 (car e3340) w3341 mod3342) l3343) #f)) (if (null? e3340) (quote ()) (if (syntax-object?2088 e3340) (match-each-any3316 (syntax-object-expression2089 e3340) (join-wraps2123 w3341 (syntax-object-wrap2090 e3340)) mod3342) #f)))))) (match-each3315 (lambda (e3344 p3345 w3346 mod3347) (if (annotation? e3344) (match-each3315 (annotation-expression e3344) p3345 w3346 mod3347) (if (pair? e3344) (let ((first3348 (match3319 (car e3344) p3345 w3346 (quote ()) mod3347))) (if first3348 (let ((rest3349 (match-each3315 (cdr e3344) p3345 w3346 mod3347))) (if rest3349 (cons first3348 rest3349) #f)) #f)) (if (null? e3344) (quote ()) (if (syntax-object?2088 e3344) (match-each3315 (syntax-object-expression2089 e3344) p3345 (join-wraps2123 w3346 (syntax-object-wrap2090 e3344)) (syntax-object-module2091 e3344)) #f))))))) (set! $sc-dispatch (lambda (e3350 p3351) (if (eq? p3351 (quote any)) (list e3350) (if (syntax-object?2088 e3350) (match*3318 (let ((e3352 (syntax-object-expression2089 e3350))) (if (annotation? e3352) (annotation-expression e3352) e3352)) p3351 (syntax-object-wrap2090 e3350) (quote ()) (syntax-object-module2091 e3350)) (match*3318 (let ((e3353 e3350)) (if (annotation? e3353) (annotation-expression e3353) e3353)) p3351 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x3354) ((lambda (tmp3355) ((lambda (tmp3356) (if tmp3356 (apply (lambda (_3357 e13358 e23359) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13358 e23359))) tmp3356) ((lambda (tmp3361) (if tmp3361 (apply (lambda (_3362 out3363 in3364 e13365 e23366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3364 (quote ()) (list out3363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13365 e23366))))) tmp3361) ((lambda (tmp3368) (if tmp3368 (apply (lambda (_3369 out3370 in3371 e13372 e23373) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3371) (quote ()) (list out3370 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13372 e23373))))) tmp3368) (syntax-violation #f "source expression failed to match any pattern" tmp3355))) ($sc-dispatch tmp3355 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any () any . each-any))))) x3354)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3377) ((lambda (tmp3378) ((lambda (tmp3379) (if tmp3379 (apply (lambda (_3380 k3381 keyword3382 pattern3383 template3384) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k3381 (map (lambda (tmp3387 tmp3386) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3386) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3387))) template3384 pattern3383)))))) tmp3379) (syntax-violation #f "source expression failed to match any pattern" tmp3378))) ($sc-dispatch tmp3378 (quote (any each-any . #(each ((any . any) any))))))) x3377)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3388) ((lambda (tmp3389) ((lambda (tmp3390) (if (if tmp3390 (apply (lambda (let*3391 x3392 v3393 e13394 e23395) (and-map identifier? x3392)) tmp3390) #f) (apply (lambda (let*3397 x3398 v3399 e13400 e23401) (letrec ((f3402 (lambda (bindings3403) (if (null? bindings3403) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e13400 e23401))) ((lambda (tmp3407) ((lambda (tmp3408) (if tmp3408 (apply (lambda (body3409 binding3410) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding3410) body3409)) tmp3408) (syntax-violation #f "source expression failed to match any pattern" tmp3407))) ($sc-dispatch tmp3407 (quote (any any))))) (list (f3402 (cdr bindings3403)) (car bindings3403))))))) (f3402 (map list x3398 v3399)))) tmp3390) (syntax-violation #f "source expression failed to match any pattern" tmp3389))) ($sc-dispatch tmp3389 (quote (any #(each (any any)) any . each-any))))) x3388)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3411) ((lambda (tmp3412) ((lambda (tmp3413) (if tmp3413 (apply (lambda (_3414 var3415 init3416 step3417 e03418 e13419 c3420) ((lambda (tmp3421) ((lambda (tmp3422) (if tmp3422 (apply (lambda (step3423) ((lambda (tmp3424) ((lambda (tmp3425) (if tmp3425 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3425) ((lambda (tmp3430) (if tmp3430 (apply (lambda (e13431 e23432) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e13431 e23432)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3430) (syntax-violation #f "source expression failed to match any pattern" tmp3424))) ($sc-dispatch tmp3424 (quote (any . each-any)))))) ($sc-dispatch tmp3424 (quote ())))) e13419)) tmp3422) (syntax-violation #f "source expression failed to match any pattern" tmp3421))) ($sc-dispatch tmp3421 (quote each-any)))) (map (lambda (v3439 s3440) ((lambda (tmp3441) ((lambda (tmp3442) (if tmp3442 (apply (lambda () v3439) tmp3442) ((lambda (tmp3443) (if tmp3443 (apply (lambda (e3444) e3444) tmp3443) ((lambda (_3445) (syntax-violation (quote do) "bad step expression" orig-x3411 s3440)) tmp3441))) ($sc-dispatch tmp3441 (quote (any)))))) ($sc-dispatch tmp3441 (quote ())))) s3440)) var3415 step3417))) tmp3413) (syntax-violation #f "source expression failed to match any pattern" tmp3412))) ($sc-dispatch tmp3412 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3411)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3448 (lambda (x3452 y3453) ((lambda (tmp3454) ((lambda (tmp3455) (if tmp3455 (apply (lambda (x3456 y3457) ((lambda (tmp3458) ((lambda (tmp3459) (if tmp3459 (apply (lambda (dy3460) ((lambda (tmp3461) ((lambda (tmp3462) (if tmp3462 (apply (lambda (dx3463) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx3463 dy3460))) tmp3462) ((lambda (_3464) (if (null? dy3460) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457))) tmp3461))) ($sc-dispatch tmp3461 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x3456)) tmp3459) ((lambda (tmp3465) (if tmp3465 (apply (lambda (stuff3466) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x3456 stuff3466))) tmp3465) ((lambda (else3467) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457)) tmp3458))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y3457)) tmp3455) (syntax-violation #f "source expression failed to match any pattern" tmp3454))) ($sc-dispatch tmp3454 (quote (any any))))) (list x3452 y3453)))) (quasiappend3449 (lambda (x3468 y3469) ((lambda (tmp3470) ((lambda (tmp3471) (if tmp3471 (apply (lambda (x3472 y3473) ((lambda (tmp3474) ((lambda (tmp3475) (if tmp3475 (apply (lambda () x3472) tmp3475) ((lambda (_3476) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3472 y3473)) tmp3474))) ($sc-dispatch tmp3474 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y3473)) tmp3471) (syntax-violation #f "source expression failed to match any pattern" tmp3470))) ($sc-dispatch tmp3470 (quote (any any))))) (list x3468 y3469)))) (quasivector3450 (lambda (x3477) ((lambda (tmp3478) ((lambda (x3479) ((lambda (tmp3480) ((lambda (tmp3481) (if tmp3481 (apply (lambda (x3482) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x3482))) tmp3481) ((lambda (tmp3484) (if tmp3484 (apply (lambda (x3485) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3485)) tmp3484) ((lambda (_3487) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3479)) tmp3480))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x3479)) tmp3478)) x3477))) (quasi3451 (lambda (p3488 lev3489) ((lambda (tmp3490) ((lambda (tmp3491) (if tmp3491 (apply (lambda (p3492) (if (= lev3489 0) p3492 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3492) (- lev3489 1))))) tmp3491) ((lambda (tmp3493) (if tmp3493 (apply (lambda (p3494 q3495) (if (= lev3489 0) (quasiappend3449 p3494 (quasi3451 q3495 lev3489)) (quasicons3448 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3494) (- lev3489 1))) (quasi3451 q3495 lev3489)))) tmp3493) ((lambda (tmp3496) (if tmp3496 (apply (lambda (p3497) (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3497) (+ lev3489 1)))) tmp3496) ((lambda (tmp3498) (if tmp3498 (apply (lambda (p3499 q3500) (quasicons3448 (quasi3451 p3499 lev3489) (quasi3451 q3500 lev3489))) tmp3498) ((lambda (tmp3501) (if tmp3501 (apply (lambda (x3502) (quasivector3450 (quasi3451 x3502 lev3489))) tmp3501) ((lambda (p3504) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p3504)) tmp3490))) ($sc-dispatch tmp3490 (quote #(vector each-any)))))) ($sc-dispatch tmp3490 (quote (any . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp3490 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p3488)))) (lambda (x3505) ((lambda (tmp3506) ((lambda (tmp3507) (if tmp3507 (apply (lambda (_3508 e3509) (quasi3451 e3509 0)) tmp3507) (syntax-violation #f "source expression failed to match any pattern" tmp3506))) ($sc-dispatch tmp3506 (quote (any any))))) x3505))))) +(define include (make-syncase-macro (quote macro) (lambda (x3510) (letrec ((read-file3511 (lambda (fn3512 k3513) (let ((p3514 (open-input-file fn3512))) (letrec ((f3515 (lambda (x3516) (if (eof-object? x3516) (begin (close-input-port p3514) (quote ())) (cons (datum->syntax k3513 x3516) (f3515 (read p3514))))))) (f3515 (read p3514))))))) ((lambda (tmp3517) ((lambda (tmp3518) (if tmp3518 (apply (lambda (k3519 filename3520) (let ((fn3521 (syntax->datum filename3520))) ((lambda (tmp3522) ((lambda (tmp3523) (if tmp3523 (apply (lambda (exp3524) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp3524)) tmp3523) (syntax-violation #f "source expression failed to match any pattern" tmp3522))) ($sc-dispatch tmp3522 (quote each-any)))) (read-file3511 fn3521 k3519)))) tmp3518) (syntax-violation #f "source expression failed to match any pattern" tmp3517))) ($sc-dispatch tmp3517 (quote (any any))))) x3510))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x3526) ((lambda (tmp3527) ((lambda (tmp3528) (if tmp3528 (apply (lambda (_3529 e3530) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x3526)) tmp3528) (syntax-violation #f "source expression failed to match any pattern" tmp3527))) ($sc-dispatch tmp3527 (quote (any any))))) x3526)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3531) ((lambda (tmp3532) ((lambda (tmp3533) (if tmp3533 (apply (lambda (_3534 e3535) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x3531)) tmp3533) (syntax-violation #f "source expression failed to match any pattern" tmp3532))) ($sc-dispatch tmp3532 (quote (any any))))) x3531)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3536) ((lambda (tmp3537) ((lambda (tmp3538) (if tmp3538 (apply (lambda (_3539 e3540 m13541 m23542) ((lambda (tmp3543) ((lambda (body3544) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3540)) body3544)) tmp3543)) (letrec ((f3545 (lambda (clause3546 clauses3547) (if (null? clauses3547) ((lambda (tmp3549) ((lambda (tmp3550) (if tmp3550 (apply (lambda (e13551 e23552) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13551 e23552))) tmp3550) ((lambda (tmp3554) (if tmp3554 (apply (lambda (k3555 e13556 e23557) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3555)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13556 e23557)))) tmp3554) ((lambda (_3560) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3549))) ($sc-dispatch tmp3549 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3549 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause3546) ((lambda (tmp3561) ((lambda (rest3562) ((lambda (tmp3563) ((lambda (tmp3564) (if tmp3564 (apply (lambda (k3565 e13566 e23567) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3565)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13566 e23567)) rest3562)) tmp3564) ((lambda (_3570) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3563))) ($sc-dispatch tmp3563 (quote (each-any any . each-any))))) clause3546)) tmp3561)) (f3545 (car clauses3547) (cdr clauses3547))))))) (f3545 m13541 m23542)))) tmp3538) (syntax-violation #f "source expression failed to match any pattern" tmp3537))) ($sc-dispatch tmp3537 (quote (any any any . each-any))))) x3536)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3571) ((lambda (tmp3572) ((lambda (tmp3573) (if tmp3573 (apply (lambda (_3574 e3575) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3575)) (list (cons _3574 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e3575 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp3573) (syntax-violation #f "source expression failed to match any pattern" tmp3572))) ($sc-dispatch tmp3572 (quote (any any))))) x3571)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index fd7ad5906..1ad1ba60e 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -351,6 +351,12 @@ ;;; output constructors +(define build-void + (lambda (source) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-void) source)) + (else '(if #f #f))))) + (define build-application (lambda (source fun-exp arg-exps) (case (fluid-ref *mode*) @@ -444,10 +450,13 @@ (define build-primref (lambda (src name) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-primitive-ref) src name)) - ;; hygiene guile is a hack - (else (build-global-reference src name '(hygiene guile)))))) + (if (equal? (module-name (current-module)) '(guile)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) src name)) + (else name)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f)) + (else `(@@ (guile) ,name)))))) (define (build-data src exp) (case (fluid-ref *mode*) @@ -1483,7 +1492,7 @@ (define chi-void (lambda () - (build-application no-source (build-primref no-source 'if) '(#f #f)))) + (build-void no-source))) (define ellipsis? (lambda (x) @@ -1895,6 +1904,22 @@ (syntax->datum (syntax (private mod ...)))))))) +(global-extend 'core 'if + (lambda (e r w s mod) + (syntax-case e () + ((_ test then) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (build-void no-source))) + ((_ test then else) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (chi (syntax else) r w mod)))))) + (global-extend 'begin 'begin '()) (global-extend 'define 'define '()) diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm index 553a3fd43..4635abc8a 100644 --- a/module/language/scheme/compile-tree-il.scm +++ b/module/language/scheme/compile-tree-il.scm @@ -58,7 +58,7 @@ (save-module-excursion (lambda () (and=> (cenv-module e) set-current-module) - (let ((x (sc-expand x 'c '(compile load eval))) - (cenv (make-cenv (current-module) - (cenv-lexicals e) (cenv-externals e)))) + (let* ((x (sc-expand x 'c '(compile load eval))) + (cenv (make-cenv (current-module) + (cenv-lexicals e) (cenv-externals e)))) (values x cenv cenv))))) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 70085e8d7..e6b7d3bd3 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -47,8 +47,10 @@ #:version "0.5" #:reader read #:read-file read-file - #:compilers `((ghil . ,compile-ghil) - (tree-il . ,compile-tree-il)) + #:compilers `( + (tree-il . ,compile-tree-il) + (ghil . ,compile-ghil) + ) #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1bd8d15d6..55ca102f0 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -144,7 +144,7 @@ (let lp ((vars vars) (n 0)) (if (null? vars) (hashq-set! allocation x - (let ((nlocs (allocate! body (1+ level) n))) + (let ((nlocs (- (allocate! body (1+ level) n) n))) (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) (let ((v (if (pair? vars) (car vars) vars))) (let ((binder (hashq-ref heaps v))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index b617bd899..f69c91b86 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -39,13 +39,17 @@ ;; sym -> (local . index) | (heap level . index) ;; lambda -> (nlocs . nexts) +(define *comp-module* (make-fluid)) + (define (compile-glil x e opts) (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) (x (optimize! x e opts)) (allocation (analyze-lexicals x))) - (values (flatten-lambda x -1 allocation) - (and e (cons (car e) (cddr e))) - e))) + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) + (lambda () + (values (flatten-lambda x -1 allocation) + (and e (cons (car e) (cddr e))) + e))))) @@ -128,11 +132,11 @@ ;; copy args to the heap if necessary (let lp ((in vars) (n 0)) (if (not (null? in)) - (let ((loc (hashq-ref allocation (car vars)))) + (let ((loc (hashq-ref allocation (car in)))) (case (car loc) ((heap) - (emit-code (make-glil-argument 'ref n)) - (emit-code (make-glil-external 'set 0 (cddr loc))))) + (emit-code #f (make-glil-local 'ref n)) + (emit-code #f (make-glil-external 'set 0 (cddr loc))))) (lp (cdr in) (1+ n))))) ;; and here, here, dear reader: we compile. @@ -197,11 +201,21 @@ (comp-push proc) (for-each comp-push args) (case context - ((drop) (emit-code src (make-glil-call 'apply (length args))) + ((drop) (emit-code src (make-glil-call 'apply (1+ (length args)))) (emit-code src (make-glil-call 'drop 1))) - ((tail) (emit-code src (make-glil-call 'goto/apply (length args)))) - ((push) (emit-code src (make-glil-call 'apply (length args))))))))) + ((tail) (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) + ((push) (emit-code src (make-glil-call 'apply (1+ (length args)))))))))) + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (values '(1 2))) + ;; drop: (lambda () (values '(1 2)) 3) + ;; push: (lambda () (list (values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values (length args)))))) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-values) (= (length args) 2)) @@ -277,12 +291,23 @@ (emit-label L2)))) (( src name) - (case context - ((push) - (emit-code src (make-glil-module 'ref '(guile) name #f))) - ((tail) - (emit-code src (make-glil-module 'ref '(guile) name #f)) - (emit-code #f (make-glil-call 'return 1))))) + (cond + ((eq? (module-variable (fluid-ref *comp-module*) name) + (module-variable the-root-module name)) + (case context + ((push) + (emit-code src (make-glil-toplevel 'ref name))) + ((tail) + (emit-code src (make-glil-toplevel 'ref name)) + (emit-code #f (make-glil-call 'return 1))))) + (else + (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) + (case context + ((push) + (emit-code src (make-glil-module 'ref '(guile) name #f))) + ((tail) + (emit-code src (make-glil-module 'ref '(guile) name #f)) + (emit-code #f (make-glil-call 'return 1))))))) (( src name gensym) (case context diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index e4e4996fc..03193b256 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -78,7 +78,7 @@ (and (hashq-ref *interesting-primitive-vars* (module-variable mod name)) (make-primitive-ref src name))) - (( mod name public?) + (( src mod name public?) ;; for the moment, we're disabling primitive resolution for ;; public refs because resolve-interface can raise errors. (let ((m (and (not public?) (resolve-module mod)))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index a92ba923d..3150392ae 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -102,7 +102,7 @@ (with-test-prefix "primitive-ref" (assert-tree-il->glil (primitive +) - (program 0 0 0 0 () (module private ref (guile) +) (call return 1))) + (program 0 0 0 0 () (toplevel ref +) (call return 1))) (assert-tree-il->glil (begin (primitive +) (const #f)) @@ -110,7 +110,7 @@ (assert-tree-il->glil (apply (primitive null?) (primitive +)) - (program 0 0 0 0 () (module private ref (guile) +) (call null? 1) + (program 0 0 0 0 () (toplevel ref +) (call null? 1) (call return 1)))) (with-test-prefix "lexical refs" @@ -309,7 +309,7 @@ (assert-tree-il->glil (lambda (x) (y) () (const 2)) (program 0 0 0 0 () - (program 1 0 1 0 () + (program 1 0 0 0 () (bind (x local 0)) (const 2) (call return 1)) (call return 1))) @@ -317,7 +317,7 @@ (assert-tree-il->glil (lambda (x x1) (y y1) () (const 2)) (program 0 0 0 0 () - (program 2 0 2 0 () + (program 2 0 0 0 () (bind (x local 0) (x1 local 1)) (const 2) (call return 1)) (call return 1))) @@ -325,7 +325,7 @@ (assert-tree-il->glil (lambda x y () (const 2)) (program 0 0 0 0 () - (program 1 1 1 0 () + (program 1 1 0 0 () (bind (x local 0)) (const 2) (call return 1)) (call return 1))) @@ -333,7 +333,7 @@ (assert-tree-il->glil (lambda (x . x1) (y . y1) () (const 2)) (program 0 0 0 0 () - (program 2 1 2 0 () + (program 2 1 0 0 () (bind (x local 0) (x1 local 1)) (const 2) (call return 1)) (call return 1))) @@ -341,7 +341,7 @@ (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x y)) (program 0 0 0 0 () - (program 2 1 2 0 () + (program 2 1 0 0 () (bind (x local 0) (x1 local 1)) (local ref 0) (call return 1)) (call return 1))) @@ -349,9 +349,21 @@ (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x1 y1)) (program 0 0 0 0 () - (program 2 1 2 0 () + (program 2 1 0 0 () (bind (x local 0) (x1 local 1)) (local ref 1) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) + (program 0 0 0 0 () + (program 1 0 0 1 () + (bind (x external 0)) + (local ref 0) (external set 0 0) + (program 1 0 0 0 () + (bind (y local 0)) + (external ref 1 0) (call return 1)) + (call return 1)) (call return 1)))) (with-test-prefix "sequence" From e32a1792de84c20eaaae6ea7f33048b6eef2c9d8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 11:59:41 +0200 Subject: [PATCH 112/375] a few fixups * module/ice-9/psyntax.scm (chi-install-global, syntax-case): Fix a couple of cases in which bare datums were passed to output constructors. * module/ice-9/psyntax-pp.scm: Regenerated. * module/language/scheme/spec.scm (scheme): Clean up the #:compilers list. * module/language/tree-il/compile-glil.scm (flatten): Fix call to `length' in call/cc compiler. --- module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 10 ++++++++-- module/language/scheme/spec.scm | 6 ++---- module/language/tree-il/compile-glil.scm | 2 +- 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 829812eda..4476212f6 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,6 +1,6 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*2008 (lambda (f2048 first2047 . rest2046) (let ((t2049 (null? first2047))) (if t2049 t2049 (if (null? rest2046) (letrec ((andmap2050 (lambda (first2051) (let ((x2052 (car first2051)) (first2053 (cdr first2051))) (if (null? first2053) (f2048 x2052) (if (f2048 x2052) (andmap2050 first2053) #f)))))) (andmap2050 first2047)) (letrec ((andmap2054 (lambda (first2055 rest2056) (let ((x2057 (car first2055)) (xr2058 (map car rest2056)) (first2059 (cdr first2055)) (rest2060 (map cdr rest2056))) (if (null? first2059) (apply f2048 (cons x2057 xr2058)) (if (apply f2048 (cons x2057 xr2058)) (andmap2054 first2059 rest2060) #f)))))) (andmap2054 first2047 rest2046)))))))) (letrec ((lambda-var-list2153 (lambda (vars2282) (letrec ((lvl2283 (lambda (vars2284 ls2285 w2286) (if (pair? vars2284) (lvl2283 (cdr vars2284) (cons (wrap2132 (car vars2284) w2286 #f) ls2285) w2286) (if (id?2104 vars2284) (cons (wrap2132 vars2284 w2286 #f) ls2285) (if (null? vars2284) ls2285 (if (syntax-object?2088 vars2284) (lvl2283 (syntax-object-expression2089 vars2284) ls2285 (join-wraps2123 w2286 (syntax-object-wrap2090 vars2284))) (if (annotation? vars2284) (lvl2283 (annotation-expression vars2284) ls2285 w2286) (cons vars2284 ls2285))))))))) (lvl2283 vars2282 (quote ()) (quote (())))))) (gen-var2152 (lambda (id2287) (let ((id2288 (if (syntax-object?2088 id2287) (syntax-object-expression2089 id2287) id2287))) (if (annotation? id2288) (gensym (symbol->string (annotation-expression id2288))) (gensym (symbol->string id2288)))))) (strip2151 (lambda (x2289 w2290) (if (memq (quote top) (wrap-marks2107 w2290)) (if (let ((t2291 (annotation? x2289))) (if t2291 t2291 (if (pair? x2289) (annotation? (car x2289)) #f))) (strip-annotation2150 x2289 #f) x2289) (letrec ((f2292 (lambda (x2293) (if (syntax-object?2088 x2293) (strip2151 (syntax-object-expression2089 x2293) (syntax-object-wrap2090 x2293)) (if (pair? x2293) (let ((a2294 (f2292 (car x2293))) (d2295 (f2292 (cdr x2293)))) (if (if (eq? a2294 (car x2293)) (eq? d2295 (cdr x2293)) #f) x2293 (cons a2294 d2295))) (if (vector? x2293) (let ((old2296 (vector->list x2293))) (let ((new2297 (map f2292 old2296))) (if (and-map*2008 eq? old2296 new2297) x2293 (list->vector new2297)))) x2293)))))) (f2292 x2289))))) (strip-annotation2150 (lambda (x2298 parent2299) (if (pair? x2298) (let ((new2300 (cons #f #f))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2300) (if #f #f)) (set-car! new2300 (strip-annotation2150 (car x2298) #f)) (set-cdr! new2300 (strip-annotation2150 (cdr x2298) #f)) new2300)) (if (annotation? x2298) (let ((t2301 (annotation-stripped x2298))) (if t2301 t2301 (strip-annotation2150 (annotation-expression x2298) x2298))) (if (vector? x2298) (let ((new2302 (make-vector (vector-length x2298)))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2302) (if #f #f)) (letrec ((loop2303 (lambda (i2304) (unless (fx<2066 i2304 0) (vector-set! new2302 i2304 (strip-annotation2150 (vector-ref x2298 i2304) #f)) (loop2303 (fx-2064 i2304 1)))))) (loop2303 (- (vector-length x2298) 1))) new2302)) x2298))))) (ellipsis?2149 (lambda (x2305) (if (nonsymbol-id?2103 x2305) (free-id=?2127 x2305 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void2148 (lambda () (build-void2071 #f))) (eval-local-transformer2147 (lambda (expanded2306 mod2307) (let ((p2308 (local-eval-hook2068 expanded2306 mod2307))) (if (procedure? p2308) p2308 (syntax-violation #f "nonprocedure transformer" p2308))))) (chi-local-syntax2146 (lambda (rec?2309 e2310 r2311 w2312 s2313 mod2314 k2315) ((lambda (tmp2316) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 id2319 val2320 e12321 e22322) (let ((ids2323 id2319)) (if (not (valid-bound-ids?2129 ids2323)) (syntax-violation #f "duplicate bound keyword" e2310) (let ((labels2325 (gen-labels2110 ids2323))) (let ((new-w2326 (make-binding-wrap2121 ids2323 labels2325 w2312))) (k2315 (cons e12321 e22322) (extend-env2098 labels2325 (let ((w2328 (if rec?2309 new-w2326 w2312)) (trans-r2329 (macros-only-env2100 r2311))) (map (lambda (x2330) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2330 trans-r2329 w2328 mod2314) mod2314))) val2320)) r2311) new-w2326 s2313 mod2314)))))) tmp2317) ((lambda (_2332) (syntax-violation #f "bad local syntax definition" (source-wrap2133 e2310 w2312 s2313 mod2314))) tmp2316))) ($sc-dispatch tmp2316 (quote (any #(each (any any)) any . each-any))))) e2310))) (chi-lambda-clause2145 (lambda (e2333 docstring2334 c2335 r2336 w2337 mod2338 k2339) ((lambda (tmp2340) ((lambda (tmp2341) (if (if tmp2341 (apply (lambda (args2342 doc2343 e12344 e22345) (if (string? (syntax->datum doc2343)) (not docstring2334) #f)) tmp2341) #f) (apply (lambda (args2346 doc2347 e12348 e22349) (chi-lambda-clause2145 e2333 doc2347 (cons args2346 (cons e12348 e22349)) r2336 w2337 mod2338 k2339)) tmp2341) ((lambda (tmp2351) (if tmp2351 (apply (lambda (id2352 e12353 e22354) (let ((ids2355 id2352)) (if (not (valid-bound-ids?2129 ids2355)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2357 (gen-labels2110 ids2355)) (new-vars2358 (map gen-var2152 ids2355))) (k2339 (map syntax->datum ids2355) new-vars2358 docstring2334 (chi-body2144 (cons e12353 e22354) e2333 (extend-var-env2099 labels2357 new-vars2358 r2336) (make-binding-wrap2121 ids2355 labels2357 w2337) mod2338)))))) tmp2351) ((lambda (tmp2360) (if tmp2360 (apply (lambda (ids2361 e12362 e22363) (let ((old-ids2364 (lambda-var-list2153 ids2361))) (if (not (valid-bound-ids?2129 old-ids2364)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2365 (gen-labels2110 old-ids2364)) (new-vars2366 (map gen-var2152 old-ids2364))) (k2339 (letrec ((f2367 (lambda (ls12368 ls22369) (if (null? ls12368) (syntax->datum ls22369) (f2367 (cdr ls12368) (cons (syntax->datum (car ls12368)) ls22369)))))) (f2367 (cdr old-ids2364) (car old-ids2364))) (letrec ((f2370 (lambda (ls12371 ls22372) (if (null? ls12371) ls22372 (f2370 (cdr ls12371) (cons (car ls12371) ls22372)))))) (f2370 (cdr new-vars2366) (car new-vars2366))) docstring2334 (chi-body2144 (cons e12362 e22363) e2333 (extend-var-env2099 labels2365 new-vars2366 r2336) (make-binding-wrap2121 old-ids2364 labels2365 w2337) mod2338)))))) tmp2360) ((lambda (_2374) (syntax-violation (quote lambda) "bad lambda" e2333)) tmp2340))) ($sc-dispatch tmp2340 (quote (any any . each-any)))))) ($sc-dispatch tmp2340 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2340 (quote (any any any . each-any))))) c2335))) (chi-body2144 (lambda (body2375 outer-form2376 r2377 w2378 mod2379) (let ((r2380 (cons (quote ("placeholder" placeholder)) r2377))) (let ((ribcage2381 (make-ribcage2111 (quote ()) (quote ()) (quote ())))) (let ((w2382 (make-wrap2106 (wrap-marks2107 w2378) (cons ribcage2381 (wrap-subst2108 w2378))))) (letrec ((parse2383 (lambda (body2384 ids2385 labels2386 vars2387 vals2388 bindings2389) (if (null? body2384) (syntax-violation #f "no expressions in body" outer-form2376) (let ((e2391 (cdar body2384)) (er2392 (caar body2384))) (call-with-values (lambda () (syntax-type2138 e2391 er2392 (quote (())) #f ribcage2381 mod2379)) (lambda (type2393 value2394 e2395 w2396 s2397 mod2398) (if (memv type2393 (quote (define-form))) (let ((id2399 (wrap2132 value2394 w2396 mod2398)) (label2400 (gen-label2109))) (let ((var2401 (gen-var2152 id2399))) (begin (extend-ribcage!2120 ribcage2381 id2399 label2400) (parse2383 (cdr body2384) (cons id2399 ids2385) (cons label2400 labels2386) (cons var2401 vars2387) (cons (cons er2392 (wrap2132 e2395 w2396 mod2398)) vals2388) (cons (cons (quote lexical) var2401) bindings2389))))) (if (memv type2393 (quote (define-syntax-form))) (let ((id2402 (wrap2132 value2394 w2396 mod2398)) (label2403 (gen-label2109))) (begin (extend-ribcage!2120 ribcage2381 id2402 label2403) (parse2383 (cdr body2384) (cons id2402 ids2385) (cons label2403 labels2386) vars2387 vals2388 (cons (cons (quote macro) (cons er2392 (wrap2132 e2395 w2396 mod2398))) bindings2389)))) (if (memv type2393 (quote (begin-form))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 e12407) (parse2383 (letrec ((f2408 (lambda (forms2409) (if (null? forms2409) (cdr body2384) (cons (cons er2392 (wrap2132 (car forms2409) w2396 mod2398)) (f2408 (cdr forms2409))))))) (f2408 e12407)) ids2385 labels2386 vars2387 vals2388 bindings2389)) tmp2405) (syntax-violation #f "source expression failed to match any pattern" tmp2404))) ($sc-dispatch tmp2404 (quote (any . each-any))))) e2395) (if (memv type2393 (quote (local-syntax-form))) (chi-local-syntax2146 value2394 e2395 er2392 w2396 s2397 mod2398 (lambda (forms2411 er2412 w2413 s2414 mod2415) (parse2383 (letrec ((f2416 (lambda (forms2417) (if (null? forms2417) (cdr body2384) (cons (cons er2412 (wrap2132 (car forms2417) w2413 mod2415)) (f2416 (cdr forms2417))))))) (f2416 forms2411)) ids2385 labels2386 vars2387 vals2388 bindings2389))) (if (null? ids2385) (build-sequence2083 #f (map (lambda (x2418) (chi2140 (cdr x2418) (car x2418) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))) (begin (if (not (valid-bound-ids?2129 ids2385)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form2376) (if #f #f)) (letrec ((loop2419 (lambda (bs2420 er-cache2421 r-cache2422) (if (not (null? bs2420)) (let ((b2423 (car bs2420))) (if (eq? (car b2423) (quote macro)) (let ((er2424 (cadr b2423))) (let ((r-cache2425 (if (eq? er2424 er-cache2421) r-cache2422 (macros-only-env2100 er2424)))) (begin (set-cdr! b2423 (eval-local-transformer2147 (chi2140 (cddr b2423) r-cache2425 (quote (())) mod2398) mod2398)) (loop2419 (cdr bs2420) er2424 r-cache2425)))) (loop2419 (cdr bs2420) er-cache2421 r-cache2422))) (if #f #f))))) (loop2419 bindings2389 #f #f)) (set-cdr! r2380 (extend-env2098 labels2386 bindings2389 (cdr r2380))) (build-letrec2086 #f (map syntax->datum ids2385) vars2387 (map (lambda (x2426) (chi2140 (cdr x2426) (car x2426) (quote (())) mod2398)) vals2388) (build-sequence2083 #f (map (lambda (x2427) (chi2140 (cdr x2427) (car x2427) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))))))))))))))))) (parse2383 (map (lambda (x2390) (cons r2380 (wrap2132 x2390 w2382 mod2379))) body2375) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro2143 (lambda (p2428 e2429 r2430 w2431 rib2432 mod2433) (letrec ((rebuild-macro-output2434 (lambda (x2435 m2436) (if (pair? x2435) (cons (rebuild-macro-output2434 (car x2435) m2436) (rebuild-macro-output2434 (cdr x2435) m2436)) (if (syntax-object?2088 x2435) (let ((w2437 (syntax-object-wrap2090 x2435))) (let ((ms2438 (wrap-marks2107 w2437)) (s2439 (wrap-subst2108 w2437))) (if (if (pair? ms2438) (eq? (car ms2438) #f) #f) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cdr ms2438) (if rib2432 (cons rib2432 (cdr s2439)) (cdr s2439))) (syntax-object-module2091 x2435)) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cons m2436 ms2438) (if rib2432 (cons rib2432 (cons (quote shift) s2439)) (cons (quote shift) s2439))) (let ((pmod2440 (procedure-module p2428))) (if pmod2440 (cons (quote hygiene) (module-name pmod2440)) (quote (hygiene guile)))))))) (if (vector? x2435) (let ((n2441 (vector-length x2435))) (let ((v2442 (make-vector n2441))) (letrec ((loop2443 (lambda (i2444) (if (fx=2065 i2444 n2441) (begin (if #f #f (if #f #f)) v2442) (begin (vector-set! v2442 i2444 (rebuild-macro-output2434 (vector-ref x2435 i2444) m2436)) (loop2443 (fx+2063 i2444 1))))))) (loop2443 0)))) (if (symbol? x2435) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap2133 e2429 w2431 s mod2433) x2435) x2435))))))) (rebuild-macro-output2434 (p2428 (wrap2132 e2429 (anti-mark2119 w2431) mod2433)) (string #\m))))) (chi-application2142 (lambda (x2445 e2446 r2447 w2448 s2449 mod2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (e02453 e12454) (build-application2072 s2449 x2445 (map (lambda (e2455) (chi2140 e2455 r2447 w2448 mod2450)) e12454))) tmp2452) (syntax-violation #f "source expression failed to match any pattern" tmp2451))) ($sc-dispatch tmp2451 (quote (any . each-any))))) e2446))) (chi-expr2141 (lambda (type2457 value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (lexical))) (build-lexical-reference2074 (quote value) s2462 e2459 value2458) (if (memv type2457 (quote (core external-macro))) (value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (module-ref))) (call-with-values (lambda () (value2458 e2459)) (lambda (id2464 mod2465) (build-global-reference2077 s2462 id2464 mod2465))) (if (memv type2457 (quote (lexical-call))) (chi-application2142 (build-lexical-reference2074 (quote fun) (source-annotation2095 (car e2459)) (car e2459) value2458) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (global-call))) (chi-application2142 (build-global-reference2077 (source-annotation2095 (car e2459)) value2458 (if (syntax-object?2088 (car e2459)) (syntax-object-module2091 (car e2459)) mod2463)) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (constant))) (build-data2082 s2462 (strip2151 (source-wrap2133 e2459 w2461 s2462 mod2463) (quote (())))) (if (memv type2457 (quote (global))) (build-global-reference2077 s2462 value2458 mod2463) (if (memv type2457 (quote (call))) (chi-application2142 (chi2140 (car e2459) r2460 w2461 mod2463) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (begin-form))) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 e12469 e22470) (chi-sequence2134 (cons e12469 e22470) r2460 w2461 s2462 mod2463)) tmp2467) (syntax-violation #f "source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any any . each-any))))) e2459) (if (memv type2457 (quote (local-syntax-form))) (chi-local-syntax2146 value2458 e2459 r2460 w2461 s2462 mod2463 chi-sequence2134) (if (memv type2457 (quote (eval-when-form))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (_2474 x2475 e12476 e22477) (let ((when-list2478 (chi-when-list2137 e2459 x2475 w2461))) (if (memq (quote eval) when-list2478) (chi-sequence2134 (cons e12476 e22477) r2460 w2461 s2462 mod2463) (chi-void2148)))) tmp2473) (syntax-violation #f "source expression failed to match any pattern" tmp2472))) ($sc-dispatch tmp2472 (quote (any each-any any . each-any))))) e2459) (if (memv type2457 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e2459 (wrap2132 value2458 w2461 mod2463)) (if (memv type2457 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap2133 e2459 w2461 s2462 mod2463)) (if (memv type2457 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap2133 e2459 w2461 s2462 mod2463)) (syntax-violation #f "unexpected syntax" (source-wrap2133 e2459 w2461 s2462 mod2463)))))))))))))))))) (chi2140 (lambda (e2481 r2482 w2483 mod2484) (call-with-values (lambda () (syntax-type2138 e2481 r2482 w2483 #f #f mod2484)) (lambda (type2485 value2486 e2487 w2488 s2489 mod2490) (chi-expr2141 type2485 value2486 e2487 r2482 w2488 s2489 mod2490))))) (chi-top2139 (lambda (e2491 r2492 w2493 m2494 esew2495 mod2496) (call-with-values (lambda () (syntax-type2138 e2491 r2492 w2493 #f #f mod2496)) (lambda (type2504 value2505 e2506 w2507 s2508 mod2509) (if (memv type2504 (quote (begin-form))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (_2512) (chi-void2148)) tmp2511) ((lambda (tmp2513) (if tmp2513 (apply (lambda (_2514 e12515 e22516) (chi-top-sequence2135 (cons e12515 e22516) r2492 w2507 s2508 m2494 esew2495 mod2509)) tmp2513) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote (any any . each-any)))))) ($sc-dispatch tmp2510 (quote (any))))) e2506) (if (memv type2504 (quote (local-syntax-form))) (chi-local-syntax2146 value2505 e2506 r2492 w2507 s2508 mod2509 (lambda (body2518 r2519 w2520 s2521 mod2522) (chi-top-sequence2135 body2518 r2519 w2520 s2521 m2494 esew2495 mod2522))) (if (memv type2504 (quote (eval-when-form))) ((lambda (tmp2523) ((lambda (tmp2524) (if tmp2524 (apply (lambda (_2525 x2526 e12527 e22528) (let ((when-list2529 (chi-when-list2137 e2506 x2526 w2507)) (body2530 (cons e12527 e22528))) (if (eq? m2494 (quote e)) (if (memq (quote eval) when-list2529) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) (chi-void2148)) (if (memq (quote load) when-list2529) (if (let ((t2533 (memq (quote compile) when-list2529))) (if t2533 t2533 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c&e) (quote (compile load)) mod2509) (if (memq m2494 (quote (c c&e))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c) (quote (load)) mod2509) (chi-void2148))) (if (let ((t2534 (memq (quote compile) when-list2529))) (if t2534 t2534 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (begin (top-level-eval-hook2067 (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) mod2509) (chi-void2148)) (chi-void2148)))))) tmp2524) (syntax-violation #f "source expression failed to match any pattern" tmp2523))) ($sc-dispatch tmp2523 (quote (any each-any any . each-any))))) e2506) (if (memv type2504 (quote (define-syntax-form))) (let ((n2535 (id-var-name2126 value2505 w2507)) (r2536 (macros-only-env2100 r2492))) (if (memv m2494 (quote (c))) (if (memq (quote compile) esew2495) (let ((e2537 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2537 mod2509) (if (memq (quote load) esew2495) e2537 (chi-void2148)))) (if (memq (quote load) esew2495) (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) (chi-void2148))) (if (memv m2494 (quote (c&e))) (let ((e2538 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2538 mod2509) e2538)) (begin (if (memq (quote eval) esew2495) (top-level-eval-hook2067 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) mod2509) (if #f #f)) (chi-void2148))))) (if (memv type2504 (quote (define-form))) (let ((n2539 (id-var-name2126 value2505 w2507))) (let ((type2540 (binding-type2096 (lookup2101 n2539 r2492 mod2509)))) (if (memv type2540 (quote (global core macro module-ref))) (let ((x2541 (build-global-definition2079 s2508 n2539 (chi2140 e2506 r2492 w2507 mod2509)))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2541 mod2509) (if #f #f)) x2541)) (if (memv type2540 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e2506 (wrap2132 value2505 w2507 mod2509)) (syntax-violation #f "cannot define keyword at top level" e2506 (wrap2132 value2505 w2507 mod2509)))))) (let ((x2542 (chi-expr2141 type2504 value2505 e2506 r2492 w2507 s2508 mod2509))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2542 mod2509) (if #f #f)) x2542))))))))))) (syntax-type2138 (lambda (e2543 r2544 w2545 s2546 rib2547 mod2548) (if (symbol? e2543) (let ((n2549 (id-var-name2126 e2543 w2545))) (let ((b2550 (lookup2101 n2549 r2544 mod2548))) (let ((type2551 (binding-type2096 b2550))) (if (memv type2551 (quote (lexical))) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (global))) (values type2551 n2549 e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2550) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548))))))) (if (pair? e2543) (let ((first2552 (car e2543))) (if (id?2104 first2552) (let ((n2553 (id-var-name2126 first2552 w2545))) (let ((b2554 (lookup2101 n2553 r2544 (let ((t2555 (if (syntax-object?2088 first2552) (syntax-object-module2091 first2552) #f))) (if t2555 t2555 mod2548))))) (let ((type2556 (binding-type2096 b2554))) (if (memv type2556 (quote (lexical))) (values (quote lexical-call) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (global))) (values (quote global-call) n2553 e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2554) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (if (memv type2556 (quote (core external-macro module-ref))) (values type2556 (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (begin))) (values (quote begin-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (eval-when))) (values (quote eval-when-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (define))) ((lambda (tmp2557) ((lambda (tmp2558) (if (if tmp2558 (apply (lambda (_2559 name2560 val2561) (id?2104 name2560)) tmp2558) #f) (apply (lambda (_2562 name2563 val2564) (values (quote define-form) name2563 val2564 w2545 s2546 mod2548)) tmp2558) ((lambda (tmp2565) (if (if tmp2565 (apply (lambda (_2566 name2567 args2568 e12569 e22570) (if (id?2104 name2567) (valid-bound-ids?2129 (lambda-var-list2153 args2568)) #f)) tmp2565) #f) (apply (lambda (_2571 name2572 args2573 e12574 e22575) (values (quote define-form) (wrap2132 name2572 w2545 mod2548) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap2132 (cons args2573 (cons e12574 e22575)) w2545 mod2548)) (quote (())) s2546 mod2548)) tmp2565) ((lambda (tmp2577) (if (if tmp2577 (apply (lambda (_2578 name2579) (id?2104 name2579)) tmp2577) #f) (apply (lambda (_2580 name2581) (values (quote define-form) (wrap2132 name2581 w2545 mod2548) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2546 mod2548)) tmp2577) (syntax-violation #f "source expression failed to match any pattern" tmp2557))) ($sc-dispatch tmp2557 (quote (any any)))))) ($sc-dispatch tmp2557 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2557 (quote (any any any))))) e2543) (if (memv type2556 (quote (define-syntax))) ((lambda (tmp2582) ((lambda (tmp2583) (if (if tmp2583 (apply (lambda (_2584 name2585 val2586) (id?2104 name2585)) tmp2583) #f) (apply (lambda (_2587 name2588 val2589) (values (quote define-syntax-form) name2588 val2589 w2545 s2546 mod2548)) tmp2583) (syntax-violation #f "source expression failed to match any pattern" tmp2582))) ($sc-dispatch tmp2582 (quote (any any any))))) e2543) (values (quote call) #f e2543 w2545 s2546 mod2548))))))))))))) (values (quote call) #f e2543 w2545 s2546 mod2548))) (if (syntax-object?2088 e2543) (syntax-type2138 (syntax-object-expression2089 e2543) r2544 (join-wraps2123 w2545 (syntax-object-wrap2090 e2543)) #f rib2547 (let ((t2590 (syntax-object-module2091 e2543))) (if t2590 t2590 mod2548))) (if (annotation? e2543) (syntax-type2138 (annotation-expression e2543) r2544 w2545 (annotation-source e2543) rib2547 mod2548) (if (self-evaluating? e2543) (values (quote constant) #f e2543 w2545 s2546 mod2548) (values (quote other) #f e2543 w2545 s2546 mod2548)))))))) (chi-when-list2137 (lambda (e2591 when-list2592 w2593) (letrec ((f2594 (lambda (when-list2595 situations2596) (if (null? when-list2595) situations2596 (f2594 (cdr when-list2595) (cons (let ((x2597 (car when-list2595))) (if (free-id=?2127 x2597 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?2127 x2597 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?2127 x2597 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e2591 (wrap2132 x2597 w2593 #f)))))) situations2596)))))) (f2594 when-list2592 (quote ()))))) (chi-install-global2136 (lambda (name2598 e2599) (build-global-definition2079 #f name2598 (if (let ((v2600 (module-variable (current-module) name2598))) (if v2600 (if (variable-bound? v2600) (if (macro? (variable-ref v2600)) (not (eq? (macro-type (variable-ref v2600)) (quote syncase-macro))) #f) #f) #f)) (build-application2072 #f (build-primref2081 #f (quote make-extended-syncase-macro)) (list (build-application2072 #f (build-primref2081 #f (quote module-ref)) (list (build-application2072 #f (quote current-module) (quote ())) (build-data2082 #f name2598))) (build-data2082 #f (quote macro)) e2599)) (build-application2072 #f (build-primref2081 #f (quote make-syncase-macro)) (list (build-data2082 #f (quote macro)) e2599)))))) (chi-top-sequence2135 (lambda (body2601 r2602 w2603 s2604 m2605 esew2606 mod2607) (build-sequence2083 s2604 (letrec ((dobody2608 (lambda (body2609 r2610 w2611 m2612 esew2613 mod2614) (if (null? body2609) (quote ()) (let ((first2615 (chi-top2139 (car body2609) r2610 w2611 m2612 esew2613 mod2614))) (cons first2615 (dobody2608 (cdr body2609) r2610 w2611 m2612 esew2613 mod2614))))))) (dobody2608 body2601 r2602 w2603 m2605 esew2606 mod2607))))) (chi-sequence2134 (lambda (body2616 r2617 w2618 s2619 mod2620) (build-sequence2083 s2619 (letrec ((dobody2621 (lambda (body2622 r2623 w2624 mod2625) (if (null? body2622) (quote ()) (let ((first2626 (chi2140 (car body2622) r2623 w2624 mod2625))) (cons first2626 (dobody2621 (cdr body2622) r2623 w2624 mod2625))))))) (dobody2621 body2616 r2617 w2618 mod2620))))) (source-wrap2133 (lambda (x2627 w2628 s2629 defmod2630) (wrap2132 (if s2629 (make-annotation x2627 s2629 #f) x2627) w2628 defmod2630))) (wrap2132 (lambda (x2631 w2632 defmod2633) (if (if (null? (wrap-marks2107 w2632)) (null? (wrap-subst2108 w2632)) #f) x2631 (if (syntax-object?2088 x2631) (make-syntax-object2087 (syntax-object-expression2089 x2631) (join-wraps2123 w2632 (syntax-object-wrap2090 x2631)) (syntax-object-module2091 x2631)) (if (null? x2631) x2631 (make-syntax-object2087 x2631 w2632 defmod2633)))))) (bound-id-member?2131 (lambda (x2634 list2635) (if (not (null? list2635)) (let ((t2636 (bound-id=?2128 x2634 (car list2635)))) (if t2636 t2636 (bound-id-member?2131 x2634 (cdr list2635)))) #f))) (distinct-bound-ids?2130 (lambda (ids2637) (letrec ((distinct?2638 (lambda (ids2639) (let ((t2640 (null? ids2639))) (if t2640 t2640 (if (not (bound-id-member?2131 (car ids2639) (cdr ids2639))) (distinct?2638 (cdr ids2639)) #f)))))) (distinct?2638 ids2637)))) (valid-bound-ids?2129 (lambda (ids2641) (if (letrec ((all-ids?2642 (lambda (ids2643) (let ((t2644 (null? ids2643))) (if t2644 t2644 (if (id?2104 (car ids2643)) (all-ids?2642 (cdr ids2643)) #f)))))) (all-ids?2642 ids2641)) (distinct-bound-ids?2130 ids2641) #f))) (bound-id=?2128 (lambda (i2645 j2646) (if (if (syntax-object?2088 i2645) (syntax-object?2088 j2646) #f) (if (eq? (let ((e2647 (syntax-object-expression2089 i2645))) (if (annotation? e2647) (annotation-expression e2647) e2647)) (let ((e2648 (syntax-object-expression2089 j2646))) (if (annotation? e2648) (annotation-expression e2648) e2648))) (same-marks?2125 (wrap-marks2107 (syntax-object-wrap2090 i2645)) (wrap-marks2107 (syntax-object-wrap2090 j2646))) #f) (eq? (let ((e2649 i2645)) (if (annotation? e2649) (annotation-expression e2649) e2649)) (let ((e2650 j2646)) (if (annotation? e2650) (annotation-expression e2650) e2650)))))) (free-id=?2127 (lambda (i2651 j2652) (if (eq? (let ((x2653 i2651)) (let ((e2654 (if (syntax-object?2088 x2653) (syntax-object-expression2089 x2653) x2653))) (if (annotation? e2654) (annotation-expression e2654) e2654))) (let ((x2655 j2652)) (let ((e2656 (if (syntax-object?2088 x2655) (syntax-object-expression2089 x2655) x2655))) (if (annotation? e2656) (annotation-expression e2656) e2656)))) (eq? (id-var-name2126 i2651 (quote (()))) (id-var-name2126 j2652 (quote (())))) #f))) (id-var-name2126 (lambda (id2657 w2658) (letrec ((search-vector-rib2661 (lambda (sym2667 subst2668 marks2669 symnames2670 ribcage2671) (let ((n2672 (vector-length symnames2670))) (letrec ((f2673 (lambda (i2674) (if (fx=2065 i2674 n2672) (search2659 sym2667 (cdr subst2668) marks2669) (if (if (eq? (vector-ref symnames2670 i2674) sym2667) (same-marks?2125 marks2669 (vector-ref (ribcage-marks2114 ribcage2671) i2674)) #f) (values (vector-ref (ribcage-labels2115 ribcage2671) i2674) marks2669) (f2673 (fx+2063 i2674 1))))))) (f2673 0))))) (search-list-rib2660 (lambda (sym2675 subst2676 marks2677 symnames2678 ribcage2679) (letrec ((f2680 (lambda (symnames2681 i2682) (if (null? symnames2681) (search2659 sym2675 (cdr subst2676) marks2677) (if (if (eq? (car symnames2681) sym2675) (same-marks?2125 marks2677 (list-ref (ribcage-marks2114 ribcage2679) i2682)) #f) (values (list-ref (ribcage-labels2115 ribcage2679) i2682) marks2677) (f2680 (cdr symnames2681) (fx+2063 i2682 1))))))) (f2680 symnames2678 0)))) (search2659 (lambda (sym2683 subst2684 marks2685) (if (null? subst2684) (values #f marks2685) (let ((fst2686 (car subst2684))) (if (eq? fst2686 (quote shift)) (search2659 sym2683 (cdr subst2684) (cdr marks2685)) (let ((symnames2687 (ribcage-symnames2113 fst2686))) (if (vector? symnames2687) (search-vector-rib2661 sym2683 subst2684 marks2685 symnames2687 fst2686) (search-list-rib2660 sym2683 subst2684 marks2685 symnames2687 fst2686))))))))) (if (symbol? id2657) (let ((t2688 (call-with-values (lambda () (search2659 id2657 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2690 . ignore2689) x2690)))) (if t2688 t2688 id2657)) (if (syntax-object?2088 id2657) (let ((id2691 (let ((e2693 (syntax-object-expression2089 id2657))) (if (annotation? e2693) (annotation-expression e2693) e2693))) (w12692 (syntax-object-wrap2090 id2657))) (let ((marks2694 (join-marks2124 (wrap-marks2107 w2658) (wrap-marks2107 w12692)))) (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w2658) marks2694)) (lambda (new-id2695 marks2696) (let ((t2697 new-id2695)) (if t2697 t2697 (let ((t2698 (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w12692) marks2696)) (lambda (x2700 . ignore2699) x2700)))) (if t2698 t2698 id2691)))))))) (if (annotation? id2657) (let ((id2701 (let ((e2702 id2657)) (if (annotation? e2702) (annotation-expression e2702) e2702)))) (let ((t2703 (call-with-values (lambda () (search2659 id2701 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2705 . ignore2704) x2705)))) (if t2703 t2703 id2701))) (syntax-violation (quote id-var-name) "invalid id" id2657))))))) (same-marks?2125 (lambda (x2706 y2707) (let ((t2708 (eq? x2706 y2707))) (if t2708 t2708 (if (not (null? x2706)) (if (not (null? y2707)) (if (eq? (car x2706) (car y2707)) (same-marks?2125 (cdr x2706) (cdr y2707)) #f) #f) #f))))) (join-marks2124 (lambda (m12709 m22710) (smart-append2122 m12709 m22710))) (join-wraps2123 (lambda (w12711 w22712) (let ((m12713 (wrap-marks2107 w12711)) (s12714 (wrap-subst2108 w12711))) (if (null? m12713) (if (null? s12714) w22712 (make-wrap2106 (wrap-marks2107 w22712) (smart-append2122 s12714 (wrap-subst2108 w22712)))) (make-wrap2106 (smart-append2122 m12713 (wrap-marks2107 w22712)) (smart-append2122 s12714 (wrap-subst2108 w22712))))))) (smart-append2122 (lambda (m12715 m22716) (if (null? m22716) m12715 (append m12715 m22716)))) (make-binding-wrap2121 (lambda (ids2717 labels2718 w2719) (if (null? ids2717) w2719 (make-wrap2106 (wrap-marks2107 w2719) (cons (let ((labelvec2720 (list->vector labels2718))) (let ((n2721 (vector-length labelvec2720))) (let ((symnamevec2722 (make-vector n2721)) (marksvec2723 (make-vector n2721))) (begin (letrec ((f2724 (lambda (ids2725 i2726) (if (not (null? ids2725)) (call-with-values (lambda () (id-sym-name&marks2105 (car ids2725) w2719)) (lambda (symname2727 marks2728) (begin (vector-set! symnamevec2722 i2726 symname2727) (vector-set! marksvec2723 i2726 marks2728) (f2724 (cdr ids2725) (fx+2063 i2726 1))))) (if #f #f))))) (f2724 ids2717 0)) (make-ribcage2111 symnamevec2722 marksvec2723 labelvec2720))))) (wrap-subst2108 w2719)))))) (extend-ribcage!2120 (lambda (ribcage2729 id2730 label2731) (begin (set-ribcage-symnames!2116 ribcage2729 (cons (let ((e2732 (syntax-object-expression2089 id2730))) (if (annotation? e2732) (annotation-expression e2732) e2732)) (ribcage-symnames2113 ribcage2729))) (set-ribcage-marks!2117 ribcage2729 (cons (wrap-marks2107 (syntax-object-wrap2090 id2730)) (ribcage-marks2114 ribcage2729))) (set-ribcage-labels!2118 ribcage2729 (cons label2731 (ribcage-labels2115 ribcage2729)))))) (anti-mark2119 (lambda (w2733) (make-wrap2106 (cons #f (wrap-marks2107 w2733)) (cons (quote shift) (wrap-subst2108 w2733))))) (set-ribcage-labels!2118 (lambda (x2734 update2735) (vector-set! x2734 3 update2735))) (set-ribcage-marks!2117 (lambda (x2736 update2737) (vector-set! x2736 2 update2737))) (set-ribcage-symnames!2116 (lambda (x2738 update2739) (vector-set! x2738 1 update2739))) (ribcage-labels2115 (lambda (x2740) (vector-ref x2740 3))) (ribcage-marks2114 (lambda (x2741) (vector-ref x2741 2))) (ribcage-symnames2113 (lambda (x2742) (vector-ref x2742 1))) (ribcage?2112 (lambda (x2743) (if (vector? x2743) (if (= (vector-length x2743) 4) (eq? (vector-ref x2743 0) (quote ribcage)) #f) #f))) (make-ribcage2111 (lambda (symnames2744 marks2745 labels2746) (vector (quote ribcage) symnames2744 marks2745 labels2746))) (gen-labels2110 (lambda (ls2747) (if (null? ls2747) (quote ()) (cons (gen-label2109) (gen-labels2110 (cdr ls2747)))))) (gen-label2109 (lambda () (string #\i))) (wrap-subst2108 cdr) (wrap-marks2107 car) (make-wrap2106 cons) (id-sym-name&marks2105 (lambda (x2748 w2749) (if (syntax-object?2088 x2748) (values (let ((e2750 (syntax-object-expression2089 x2748))) (if (annotation? e2750) (annotation-expression e2750) e2750)) (join-marks2124 (wrap-marks2107 w2749) (wrap-marks2107 (syntax-object-wrap2090 x2748)))) (values (let ((e2751 x2748)) (if (annotation? e2751) (annotation-expression e2751) e2751)) (wrap-marks2107 w2749))))) (id?2104 (lambda (x2752) (if (symbol? x2752) #t (if (syntax-object?2088 x2752) (symbol? (let ((e2753 (syntax-object-expression2089 x2752))) (if (annotation? e2753) (annotation-expression e2753) e2753))) (if (annotation? x2752) (symbol? (annotation-expression x2752)) #f))))) (nonsymbol-id?2103 (lambda (x2754) (if (syntax-object?2088 x2754) (symbol? (let ((e2755 (syntax-object-expression2089 x2754))) (if (annotation? e2755) (annotation-expression e2755) e2755))) #f))) (global-extend2102 (lambda (type2756 sym2757 val2758) (put-global-definition-hook2069 sym2757 type2756 val2758))) (lookup2101 (lambda (x2759 r2760 mod2761) (let ((temp2762 (assq x2759 r2760))) (if temp2762 (cdr temp2762) (if (symbol? x2759) (let ((t2763 (get-global-definition-hook2070 x2759 mod2761))) (if t2763 t2763 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env2100 (lambda (r2764) (if (null? r2764) (quote ()) (let ((a2765 (car r2764))) (if (eq? (cadr a2765) (quote macro)) (cons a2765 (macros-only-env2100 (cdr r2764))) (macros-only-env2100 (cdr r2764))))))) (extend-var-env2099 (lambda (labels2766 vars2767 r2768) (if (null? labels2766) r2768 (extend-var-env2099 (cdr labels2766) (cdr vars2767) (cons (cons (car labels2766) (cons (quote lexical) (car vars2767))) r2768))))) (extend-env2098 (lambda (labels2769 bindings2770 r2771) (if (null? labels2769) r2771 (extend-env2098 (cdr labels2769) (cdr bindings2770) (cons (cons (car labels2769) (car bindings2770)) r2771))))) (binding-value2097 cdr) (binding-type2096 car) (source-annotation2095 (lambda (x2772) (if (annotation? x2772) (annotation-source x2772) (if (syntax-object?2088 x2772) (source-annotation2095 (syntax-object-expression2089 x2772)) #f)))) (set-syntax-object-module!2094 (lambda (x2773 update2774) (vector-set! x2773 3 update2774))) (set-syntax-object-wrap!2093 (lambda (x2775 update2776) (vector-set! x2775 2 update2776))) (set-syntax-object-expression!2092 (lambda (x2777 update2778) (vector-set! x2777 1 update2778))) (syntax-object-module2091 (lambda (x2779) (vector-ref x2779 3))) (syntax-object-wrap2090 (lambda (x2780) (vector-ref x2780 2))) (syntax-object-expression2089 (lambda (x2781) (vector-ref x2781 1))) (syntax-object?2088 (lambda (x2782) (if (vector? x2782) (if (= (vector-length x2782) 4) (eq? (vector-ref x2782 0) (quote syntax-object)) #f) #f))) (make-syntax-object2087 (lambda (expression2783 wrap2784 module2785) (vector (quote syntax-object) expression2783 wrap2784 module2785))) (build-letrec2086 (lambda (src2786 ids2787 vars2788 val-exps2789 body-exp2790) (if (null? vars2788) body-exp2790 (let ((atom-key2791 (fluid-ref *mode*2062))) (if (memv atom-key2791 (quote (c))) ((@ (language tree-il) make-letrec) src2786 ids2787 vars2788 val-exps2789 body-exp2790) (list (quote letrec) (map list vars2788 val-exps2789) body-exp2790)))))) (build-named-let2085 (lambda (src2792 ids2793 vars2794 val-exps2795 body-exp2796) (let ((f2797 (car vars2794)) (f-name2798 (car ids2793)) (vars2799 (cdr vars2794)) (ids2800 (cdr ids2793))) (let ((atom-key2801 (fluid-ref *mode*2062))) (if (memv atom-key2801 (quote (c))) ((@ (language tree-il) make-letrec) src2792 (list f-name2798) (list f2797) (list (build-lambda2080 src2792 ids2800 vars2799 #f body-exp2796)) (build-application2072 src2792 (build-lexical-reference2074 (quote fun) src2792 f-name2798 f2797) val-exps2795)) (list (quote let) f2797 (map list vars2799 val-exps2795) body-exp2796)))))) (build-let2084 (lambda (src2802 ids2803 vars2804 val-exps2805 body-exp2806) (if (null? vars2804) body-exp2806 (let ((atom-key2807 (fluid-ref *mode*2062))) (if (memv atom-key2807 (quote (c))) ((@ (language tree-il) make-let) src2802 ids2803 vars2804 val-exps2805 body-exp2806) (list (quote let) (map list vars2804 val-exps2805) body-exp2806)))))) (build-sequence2083 (lambda (src2808 exps2809) (if (null? (cdr exps2809)) (car exps2809) (let ((atom-key2810 (fluid-ref *mode*2062))) (if (memv atom-key2810 (quote (c))) ((@ (language tree-il) make-sequence) src2808 exps2809) (cons (quote begin) exps2809)))))) (build-data2082 (lambda (src2811 exp2812) (let ((atom-key2813 (fluid-ref *mode*2062))) (if (memv atom-key2813 (quote (c))) ((@ (language tree-il) make-const) src2811 exp2812) (if (if (self-evaluating? exp2812) (not (vector? exp2812)) #f) exp2812 (list (quote quote) exp2812)))))) (build-primref2081 (lambda (src2814 name2815) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2816 (fluid-ref *mode*2062))) (if (memv atom-key2816 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2814 name2815) name2815)) (let ((atom-key2817 (fluid-ref *mode*2062))) (if (memv atom-key2817 (quote (c))) ((@ (language tree-il) make-module-ref) src2814 (quote (guile)) name2815 #f) (list (quote @@) (quote (guile)) name2815)))))) (build-lambda2080 (lambda (src2818 ids2819 vars2820 docstring2821 exp2822) (let ((atom-key2823 (fluid-ref *mode*2062))) (if (memv atom-key2823 (quote (c))) ((@ (language tree-il) make-lambda) src2818 ids2819 vars2820 (if docstring2821 (list (cons (quote documentation) docstring2821)) (quote ())) exp2822) (cons (quote lambda) (cons vars2820 (append (if docstring2821 (list docstring2821) (quote ())) (list exp2822)))))))) (build-global-definition2079 (lambda (source2824 var2825 exp2826) (let ((atom-key2827 (fluid-ref *mode*2062))) (if (memv atom-key2827 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2824 var2825 exp2826) (list (quote define) var2825 exp2826))))) (build-global-assignment2078 (lambda (source2828 var2829 exp2830 mod2831) (analyze-variable2076 mod2831 var2829 (lambda (mod2832 var2833 public?2834) (let ((atom-key2835 (fluid-ref *mode*2062))) (if (memv atom-key2835 (quote (c))) ((@ (language tree-il) make-module-set) source2828 mod2832 var2833 public?2834 exp2830) (list (quote set!) (list (if public?2834 (quote @) (quote @@)) mod2832 var2833) exp2830)))) (lambda (var2836) (let ((atom-key2837 (fluid-ref *mode*2062))) (if (memv atom-key2837 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2828 var2836 exp2830) (list (quote set!) var2836 exp2830))))))) (build-global-reference2077 (lambda (source2838 var2839 mod2840) (analyze-variable2076 mod2840 var2839 (lambda (mod2841 var2842 public?2843) (let ((atom-key2844 (fluid-ref *mode*2062))) (if (memv atom-key2844 (quote (c))) ((@ (language tree-il) make-module-ref) source2838 mod2841 var2842 public?2843) (list (if public?2843 (quote @) (quote @@)) mod2841 var2842)))) (lambda (var2845) (let ((atom-key2846 (fluid-ref *mode*2062))) (if (memv atom-key2846 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2838 var2845) var2845)))))) (analyze-variable2076 (lambda (mod2847 var2848 modref-cont2849 bare-cont2850) (if (not mod2847) (bare-cont2850 var2848) (let ((kind2851 (car mod2847)) (mod2852 (cdr mod2847))) (if (memv kind2851 (quote (public))) (modref-cont2849 mod2852 var2848 #t) (if (memv kind2851 (quote (private))) (if (not (equal? mod2852 (module-name (current-module)))) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (if (memv kind2851 (quote (bare))) (bare-cont2850 var2848) (if (memv kind2851 (quote (hygiene))) (if (if (not (equal? mod2852 (module-name (current-module)))) (module-variable (resolve-module mod2852) var2848) #f) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (syntax-violation #f "bad module kind" var2848 mod2852))))))))) (build-lexical-assignment2075 (lambda (source2853 name2854 var2855 exp2856) (let ((atom-key2857 (fluid-ref *mode*2062))) (if (memv atom-key2857 (quote (c))) ((@ (language tree-il) make-lexical-set) source2853 name2854 var2855 exp2856) (list (quote set!) var2855 exp2856))))) (build-lexical-reference2074 (lambda (type2858 source2859 name2860 var2861) (let ((atom-key2862 (fluid-ref *mode*2062))) (if (memv atom-key2862 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2859 name2860 var2861) var2861)))) (build-conditional2073 (lambda (source2863 test-exp2864 then-exp2865 else-exp2866) (let ((atom-key2867 (fluid-ref *mode*2062))) (if (memv atom-key2867 (quote (c))) ((@ (language tree-il) make-conditional) source2863 test-exp2864 then-exp2865 else-exp2866) (list (quote if) test-exp2864 then-exp2865 else-exp2866))))) (build-application2072 (lambda (source2868 fun-exp2869 arg-exps2870) (let ((atom-key2871 (fluid-ref *mode*2062))) (if (memv atom-key2871 (quote (c))) ((@ (language tree-il) make-application) source2868 fun-exp2869 arg-exps2870) (cons fun-exp2869 arg-exps2870))))) (build-void2071 (lambda (source2872) (let ((atom-key2873 (fluid-ref *mode*2062))) (if (memv atom-key2873 (quote (c))) ((@ (language tree-il) make-void) source2872) (quote (if #f #f)))))) (get-global-definition-hook2070 (lambda (symbol2874 module2875) (begin (if (if (not module2875) (current-module) #f) (warn "module system is booted, we should have a module" symbol2874) (if #f #f)) (let ((v2876 (module-variable (if module2875 (resolve-module (cdr module2875)) (current-module)) symbol2874))) (if v2876 (if (variable-bound? v2876) (let ((val2877 (variable-ref v2876))) (if (macro? val2877) (if (syncase-macro-type val2877) (cons (syncase-macro-type val2877) (syncase-macro-binding val2877)) #f) #f)) #f) #f))))) (put-global-definition-hook2069 (lambda (symbol2878 type2879 val2880) (let ((existing2881 (let ((v2882 (module-variable (current-module) symbol2878))) (if v2882 (if (variable-bound? v2882) (let ((val2883 (variable-ref v2882))) (if (macro? val2883) (if (not (syncase-macro-type val2883)) val2883 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2878 (if existing2881 (make-extended-syncase-macro existing2881 type2879 val2880) (make-syncase-macro type2879 val2880)))))) (local-eval-hook2068 (lambda (x2884 mod2885) (primitive-eval (list noexpand2061 (let ((atom-key2886 (fluid-ref *mode*2062))) (if (memv atom-key2886 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2884) x2884)))))) (top-level-eval-hook2067 (lambda (x2887 mod2888) (primitive-eval (list noexpand2061 (let ((atom-key2889 (fluid-ref *mode*2062))) (if (memv atom-key2889 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2887) x2887)))))) (fx<2066 <) (fx=2065 =) (fx-2064 -) (fx+2063 +) (*mode*2062 (make-fluid)) (noexpand2061 "noexpand")) (begin (global-extend2102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend2102 (quote local-syntax) (quote let-syntax) #f) (global-extend2102 (quote core) (quote fluid-let-syntax) (lambda (e2890 r2891 w2892 s2893 mod2894) ((lambda (tmp2895) ((lambda (tmp2896) (if (if tmp2896 (apply (lambda (_2897 var2898 val2899 e12900 e22901) (valid-bound-ids?2129 var2898)) tmp2896) #f) (apply (lambda (_2903 var2904 val2905 e12906 e22907) (let ((names2908 (map (lambda (x2909) (id-var-name2126 x2909 w2892)) var2904))) (begin (for-each (lambda (id2911 n2912) (let ((atom-key2913 (binding-type2096 (lookup2101 n2912 r2891 mod2894)))) (if (memv atom-key2913 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2890 (source-wrap2133 id2911 w2892 s2893 mod2894)) (if #f #f)))) var2904 names2908) (chi-body2144 (cons e12906 e22907) (source-wrap2133 e2890 w2892 s2893 mod2894) (extend-env2098 names2908 (let ((trans-r2916 (macros-only-env2100 r2891))) (map (lambda (x2917) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2917 trans-r2916 w2892 mod2894) mod2894))) val2905)) r2891) w2892 mod2894)))) tmp2896) ((lambda (_2919) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap2133 e2890 w2892 s2893 mod2894))) tmp2895))) ($sc-dispatch tmp2895 (quote (any #(each (any any)) any . each-any))))) e2890))) (global-extend2102 (quote core) (quote quote) (lambda (e2920 r2921 w2922 s2923 mod2924) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 e2928) (build-data2082 s2923 (strip2151 e2928 w2922))) tmp2926) ((lambda (_2929) (syntax-violation (quote quote) "bad syntax" (source-wrap2133 e2920 w2922 s2923 mod2924))) tmp2925))) ($sc-dispatch tmp2925 (quote (any any))))) e2920))) (global-extend2102 (quote core) (quote syntax) (letrec ((regen2937 (lambda (x2938) (let ((atom-key2939 (car x2938))) (if (memv atom-key2939 (quote (ref))) (build-lexical-reference2074 (quote value) #f (cadr x2938) (cadr x2938)) (if (memv atom-key2939 (quote (primitive))) (build-primref2081 #f (cadr x2938)) (if (memv atom-key2939 (quote (quote))) (build-data2082 #f (cadr x2938)) (if (memv atom-key2939 (quote (lambda))) (build-lambda2080 #f (cadr x2938) (cadr x2938) #f (regen2937 (caddr x2938))) (if (memv atom-key2939 (quote (map))) (let ((ls2940 (map regen2937 (cdr x2938)))) (build-application2072 #f (build-primref2081 #f (quote map)) ls2940)) (build-application2072 #f (build-primref2081 #f (car x2938)) (map regen2937 (cdr x2938))))))))))) (gen-vector2936 (lambda (x2941) (if (eq? (car x2941) (quote list)) (cons (quote vector) (cdr x2941)) (if (eq? (car x2941) (quote quote)) (list (quote quote) (list->vector (cadr x2941))) (list (quote list->vector) x2941))))) (gen-append2935 (lambda (x2942 y2943) (if (equal? y2943 (quote (quote ()))) x2942 (list (quote append) x2942 y2943)))) (gen-cons2934 (lambda (x2944 y2945) (let ((atom-key2946 (car y2945))) (if (memv atom-key2946 (quote (quote))) (if (eq? (car x2944) (quote quote)) (list (quote quote) (cons (cadr x2944) (cadr y2945))) (if (eq? (cadr y2945) (quote ())) (list (quote list) x2944) (list (quote cons) x2944 y2945))) (if (memv atom-key2946 (quote (list))) (cons (quote list) (cons x2944 (cdr y2945))) (list (quote cons) x2944 y2945)))))) (gen-map2933 (lambda (e2947 map-env2948) (let ((formals2949 (map cdr map-env2948)) (actuals2950 (map (lambda (x2951) (list (quote ref) (car x2951))) map-env2948))) (if (eq? (car e2947) (quote ref)) (car actuals2950) (if (and-map (lambda (x2952) (if (eq? (car x2952) (quote ref)) (memq (cadr x2952) formals2949) #f)) (cdr e2947)) (cons (quote map) (cons (list (quote primitive) (car e2947)) (map (let ((r2953 (map cons formals2949 actuals2950))) (lambda (x2954) (cdr (assq (cadr x2954) r2953)))) (cdr e2947)))) (cons (quote map) (cons (list (quote lambda) formals2949 e2947) actuals2950))))))) (gen-mappend2932 (lambda (e2955 map-env2956) (list (quote apply) (quote (primitive append)) (gen-map2933 e2955 map-env2956)))) (gen-ref2931 (lambda (src2957 var2958 level2959 maps2960) (if (fx=2065 level2959 0) (values var2958 maps2960) (if (null? maps2960) (syntax-violation (quote syntax) "missing ellipsis" src2957) (call-with-values (lambda () (gen-ref2931 src2957 var2958 (fx-2064 level2959 1) (cdr maps2960))) (lambda (outer-var2961 outer-maps2962) (let ((b2963 (assq outer-var2961 (car maps2960)))) (if b2963 (values (cdr b2963) maps2960) (let ((inner-var2964 (gen-var2152 (quote tmp)))) (values inner-var2964 (cons (cons (cons outer-var2961 inner-var2964) (car maps2960)) outer-maps2962))))))))))) (gen-syntax2930 (lambda (src2965 e2966 r2967 maps2968 ellipsis?2969 mod2970) (if (id?2104 e2966) (let ((label2971 (id-var-name2126 e2966 (quote (()))))) (let ((b2972 (lookup2101 label2971 r2967 mod2970))) (if (eq? (binding-type2096 b2972) (quote syntax)) (call-with-values (lambda () (let ((var.lev2973 (binding-value2097 b2972))) (gen-ref2931 src2965 (car var.lev2973) (cdr var.lev2973) maps2968))) (lambda (var2974 maps2975) (values (list (quote ref) var2974) maps2975))) (if (ellipsis?2969 e2966) (syntax-violation (quote syntax) "misplaced ellipsis" src2965) (values (list (quote quote) e2966) maps2968))))) ((lambda (tmp2976) ((lambda (tmp2977) (if (if tmp2977 (apply (lambda (dots2978 e2979) (ellipsis?2969 dots2978)) tmp2977) #f) (apply (lambda (dots2980 e2981) (gen-syntax2930 src2965 e2981 r2967 maps2968 (lambda (x2982) #f) mod2970)) tmp2977) ((lambda (tmp2983) (if (if tmp2983 (apply (lambda (x2984 dots2985 y2986) (ellipsis?2969 dots2985)) tmp2983) #f) (apply (lambda (x2987 dots2988 y2989) (letrec ((f2990 (lambda (y2991 k2992) ((lambda (tmp2996) ((lambda (tmp2997) (if (if tmp2997 (apply (lambda (dots2998 y2999) (ellipsis?2969 dots2998)) tmp2997) #f) (apply (lambda (dots3000 y3001) (f2990 y3001 (lambda (maps3002) (call-with-values (lambda () (k2992 (cons (quote ()) maps3002))) (lambda (x3003 maps3004) (if (null? (car maps3004)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-mappend2932 x3003 (car maps3004)) (cdr maps3004)))))))) tmp2997) ((lambda (_3005) (call-with-values (lambda () (gen-syntax2930 src2965 y2991 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (y3006 maps3007) (call-with-values (lambda () (k2992 maps3007)) (lambda (x3008 maps3009) (values (gen-append2935 x3008 y3006) maps3009)))))) tmp2996))) ($sc-dispatch tmp2996 (quote (any . any))))) y2991)))) (f2990 y2989 (lambda (maps2993) (call-with-values (lambda () (gen-syntax2930 src2965 x2987 r2967 (cons (quote ()) maps2993) ellipsis?2969 mod2970)) (lambda (x2994 maps2995) (if (null? (car maps2995)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-map2933 x2994 (car maps2995)) (cdr maps2995))))))))) tmp2983) ((lambda (tmp3010) (if tmp3010 (apply (lambda (x3011 y3012) (call-with-values (lambda () (gen-syntax2930 src2965 x3011 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (x3013 maps3014) (call-with-values (lambda () (gen-syntax2930 src2965 y3012 r2967 maps3014 ellipsis?2969 mod2970)) (lambda (y3015 maps3016) (values (gen-cons2934 x3013 y3015) maps3016)))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (e13018 e23019) (call-with-values (lambda () (gen-syntax2930 src2965 (cons e13018 e23019) r2967 maps2968 ellipsis?2969 mod2970)) (lambda (e3021 maps3022) (values (gen-vector2936 e3021) maps3022)))) tmp3017) ((lambda (_3023) (values (list (quote quote) e2966) maps2968)) tmp2976))) ($sc-dispatch tmp2976 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2976 (quote (any . any)))))) ($sc-dispatch tmp2976 (quote (any any . any)))))) ($sc-dispatch tmp2976 (quote (any any))))) e2966))))) (lambda (e3024 r3025 w3026 s3027 mod3028) (let ((e3029 (source-wrap2133 e3024 w3026 s3027 mod3028))) ((lambda (tmp3030) ((lambda (tmp3031) (if tmp3031 (apply (lambda (_3032 x3033) (call-with-values (lambda () (gen-syntax2930 e3029 x3033 r3025 (quote ()) ellipsis?2149 mod3028)) (lambda (e3034 maps3035) (regen2937 e3034)))) tmp3031) ((lambda (_3036) (syntax-violation (quote syntax) "bad `syntax' form" e3029)) tmp3030))) ($sc-dispatch tmp3030 (quote (any any))))) e3029))))) (global-extend2102 (quote core) (quote lambda) (lambda (e3037 r3038 w3039 s3040 mod3041) ((lambda (tmp3042) ((lambda (tmp3043) (if tmp3043 (apply (lambda (_3044 c3045) (chi-lambda-clause2145 (source-wrap2133 e3037 w3039 s3040 mod3041) #f c3045 r3038 w3039 mod3041 (lambda (names3046 vars3047 docstring3048 body3049) (build-lambda2080 s3040 names3046 vars3047 docstring3048 body3049)))) tmp3043) (syntax-violation #f "source expression failed to match any pattern" tmp3042))) ($sc-dispatch tmp3042 (quote (any . any))))) e3037))) (global-extend2102 (quote core) (quote let) (letrec ((chi-let3050 (lambda (e3051 r3052 w3053 s3054 mod3055 constructor3056 ids3057 vals3058 exps3059) (if (not (valid-bound-ids?2129 ids3057)) (syntax-violation (quote let) "duplicate bound variable" e3051) (let ((labels3060 (gen-labels2110 ids3057)) (new-vars3061 (map gen-var2152 ids3057))) (let ((nw3062 (make-binding-wrap2121 ids3057 labels3060 w3053)) (nr3063 (extend-var-env2099 labels3060 new-vars3061 r3052))) (constructor3056 s3054 (map syntax->datum ids3057) new-vars3061 (map (lambda (x3064) (chi2140 x3064 r3052 w3053 mod3055)) vals3058) (chi-body2144 exps3059 (source-wrap2133 e3051 nw3062 s3054 mod3055) nr3063 nw3062 mod3055)))))))) (lambda (e3065 r3066 w3067 s3068 mod3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (_3072 id3073 val3074 e13075 e23076) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-let2084 id3073 val3074 (cons e13075 e23076))) tmp3071) ((lambda (tmp3080) (if (if tmp3080 (apply (lambda (_3081 f3082 id3083 val3084 e13085 e23086) (id?2104 f3082)) tmp3080) #f) (apply (lambda (_3087 f3088 id3089 val3090 e13091 e23092) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-named-let2085 (cons f3088 id3089) val3090 (cons e13091 e23092))) tmp3080) ((lambda (_3096) (syntax-violation (quote let) "bad let" (source-wrap2133 e3065 w3067 s3068 mod3069))) tmp3070))) ($sc-dispatch tmp3070 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3070 (quote (any #(each (any any)) any . each-any))))) e3065)))) (global-extend2102 (quote core) (quote letrec) (lambda (e3097 r3098 w3099 s3100 mod3101) ((lambda (tmp3102) ((lambda (tmp3103) (if tmp3103 (apply (lambda (_3104 id3105 val3106 e13107 e23108) (let ((ids3109 id3105)) (if (not (valid-bound-ids?2129 ids3109)) (syntax-violation (quote letrec) "duplicate bound variable" e3097) (let ((labels3111 (gen-labels2110 ids3109)) (new-vars3112 (map gen-var2152 ids3109))) (let ((w3113 (make-binding-wrap2121 ids3109 labels3111 w3099)) (r3114 (extend-var-env2099 labels3111 new-vars3112 r3098))) (build-letrec2086 s3100 (map syntax->datum ids3109) new-vars3112 (map (lambda (x3115) (chi2140 x3115 r3114 w3113 mod3101)) val3106) (chi-body2144 (cons e13107 e23108) (source-wrap2133 e3097 w3113 s3100 mod3101) r3114 w3113 mod3101))))))) tmp3103) ((lambda (_3118) (syntax-violation (quote letrec) "bad letrec" (source-wrap2133 e3097 w3099 s3100 mod3101))) tmp3102))) ($sc-dispatch tmp3102 (quote (any #(each (any any)) any . each-any))))) e3097))) (global-extend2102 (quote core) (quote set!) (lambda (e3119 r3120 w3121 s3122 mod3123) ((lambda (tmp3124) ((lambda (tmp3125) (if (if tmp3125 (apply (lambda (_3126 id3127 val3128) (id?2104 id3127)) tmp3125) #f) (apply (lambda (_3129 id3130 val3131) (let ((val3132 (chi2140 val3131 r3120 w3121 mod3123)) (n3133 (id-var-name2126 id3130 w3121))) (let ((b3134 (lookup2101 n3133 r3120 mod3123))) (let ((atom-key3135 (binding-type2096 b3134))) (if (memv atom-key3135 (quote (lexical))) (build-lexical-assignment2075 s3122 (syntax->datum id3130) (binding-value2097 b3134) val3132) (if (memv atom-key3135 (quote (global))) (build-global-assignment2078 s3122 n3133 val3132 mod3123) (if (memv atom-key3135 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap2132 id3130 w3121 mod3123)) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))))))))) tmp3125) ((lambda (tmp3136) (if tmp3136 (apply (lambda (_3137 head3138 tail3139 val3140) (call-with-values (lambda () (syntax-type2138 head3138 r3120 (quote (())) #f #f mod3123)) (lambda (type3141 value3142 ee3143 ww3144 ss3145 modmod3146) (if (memv type3141 (quote (module-ref))) (let ((val3147 (chi2140 val3140 r3120 w3121 mod3123))) (call-with-values (lambda () (value3142 (cons head3138 tail3139))) (lambda (id3149 mod3150) (build-global-assignment2078 s3122 id3149 val3147 mod3150)))) (build-application2072 s3122 (chi2140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head3138) r3120 w3121 mod3123) (map (lambda (e3151) (chi2140 e3151 r3120 w3121 mod3123)) (append tail3139 (list val3140)))))))) tmp3136) ((lambda (_3153) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))) tmp3124))) ($sc-dispatch tmp3124 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp3124 (quote (any any any))))) e3119))) (global-extend2102 (quote module-ref) (quote @) (lambda (e3154) ((lambda (tmp3155) ((lambda (tmp3156) (if (if tmp3156 (apply (lambda (_3157 mod3158 id3159) (if (and-map id?2104 mod3158) (id?2104 id3159) #f)) tmp3156) #f) (apply (lambda (_3161 mod3162 id3163) (values (syntax->datum id3163) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3162)))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any each-any any))))) e3154))) (global-extend2102 (quote module-ref) (quote @@) (lambda (e3165) ((lambda (tmp3166) ((lambda (tmp3167) (if (if tmp3167 (apply (lambda (_3168 mod3169 id3170) (if (and-map id?2104 mod3169) (id?2104 id3170) #f)) tmp3167) #f) (apply (lambda (_3172 mod3173 id3174) (values (syntax->datum id3174) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3173)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any each-any any))))) e3165))) (global-extend2102 (quote core) (quote if) (lambda (e3176 r3177 w3178 s3179 mod3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 test3184 then3185) (build-conditional2073 s3179 (chi2140 test3184 r3177 w3178 mod3180) (chi2140 then3185 r3177 w3178 mod3180) (build-void2071 #f))) tmp3182) ((lambda (tmp3186) (if tmp3186 (apply (lambda (_3187 test3188 then3189 else3190) (build-conditional2073 s3179 (chi2140 test3188 r3177 w3178 mod3180) (chi2140 then3189 r3177 w3178 mod3180) (chi2140 else3190 r3177 w3178 mod3180))) tmp3186) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any any any)))))) ($sc-dispatch tmp3181 (quote (any any any))))) e3176))) (global-extend2102 (quote begin) (quote begin) (quote ())) (global-extend2102 (quote define) (quote define) (quote ())) (global-extend2102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend2102 (quote eval-when) (quote eval-when) (quote ())) (global-extend2102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case3194 (lambda (x3195 keys3196 clauses3197 r3198 mod3199) (if (null? clauses3197) (build-application2072 #f (build-primref2081 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x3195)) ((lambda (tmp3200) ((lambda (tmp3201) (if tmp3201 (apply (lambda (pat3202 exp3203) (if (if (id?2104 pat3202) (and-map (lambda (x3204) (not (free-id=?2127 pat3202 x3204))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys3196)) #f) (let ((labels3205 (list (gen-label2109))) (var3206 (gen-var2152 pat3202))) (build-application2072 #f (build-lambda2080 #f (list (syntax->datum pat3202)) (list var3206) #f (chi2140 exp3203 (extend-env2098 labels3205 (list (cons (quote syntax) (cons var3206 0))) r3198) (make-binding-wrap2121 (list pat3202) labels3205 (quote (()))) mod3199)) (list x3195))) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3202 #t exp3203 mod3199))) tmp3201) ((lambda (tmp3207) (if tmp3207 (apply (lambda (pat3208 fender3209 exp3210) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3208 fender3209 exp3210 mod3199)) tmp3207) ((lambda (_3211) (syntax-violation (quote syntax-case) "invalid clause" (car clauses3197))) tmp3200))) ($sc-dispatch tmp3200 (quote (any any any)))))) ($sc-dispatch tmp3200 (quote (any any))))) (car clauses3197))))) (gen-clause3193 (lambda (x3212 keys3213 clauses3214 r3215 pat3216 fender3217 exp3218 mod3219) (call-with-values (lambda () (convert-pattern3191 pat3216 keys3213)) (lambda (p3220 pvars3221) (if (not (distinct-bound-ids?2130 (map car pvars3221))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat3216) (if (not (and-map (lambda (x3222) (not (ellipsis?2149 (car x3222)))) pvars3221)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat3216) (let ((y3223 (gen-var2152 (quote tmp)))) (build-application2072 #f (build-lambda2080 #f (list (quote tmp)) (list y3223) #f (let ((y3224 (build-lexical-reference2074 (quote value) #f (quote tmp) y3223))) (build-conditional2073 #f ((lambda (tmp3225) ((lambda (tmp3226) (if tmp3226 (apply (lambda () y3224) tmp3226) ((lambda (_3227) (build-conditional2073 #f y3224 (build-dispatch-call3192 pvars3221 fender3217 y3224 r3215 mod3219) (build-data2082 #f #f))) tmp3225))) ($sc-dispatch tmp3225 (quote #(atom #t))))) fender3217) (build-dispatch-call3192 pvars3221 exp3218 y3224 r3215 mod3219) (gen-syntax-case3194 x3212 keys3213 clauses3214 r3215 mod3219)))) (list (if (eq? p3220 (quote any)) (build-application2072 #f (build-primref2081 #f (quote list)) (list x3212)) (build-application2072 #f (build-primref2081 #f (quote $sc-dispatch)) (list x3212 (build-data2082 #f p3220))))))))))))) (build-dispatch-call3192 (lambda (pvars3228 exp3229 y3230 r3231 mod3232) (let ((ids3233 (map car pvars3228)) (levels3234 (map cdr pvars3228))) (let ((labels3235 (gen-labels2110 ids3233)) (new-vars3236 (map gen-var2152 ids3233))) (build-application2072 #f (build-primref2081 #f (quote apply)) (list (build-lambda2080 #f (map syntax->datum ids3233) new-vars3236 #f (chi2140 exp3229 (extend-env2098 labels3235 (map (lambda (var3237 level3238) (cons (quote syntax) (cons var3237 level3238))) new-vars3236 (map cdr pvars3228)) r3231) (make-binding-wrap2121 ids3233 labels3235 (quote (()))) mod3232)) y3230)))))) (convert-pattern3191 (lambda (pattern3239 keys3240) (letrec ((cvt3241 (lambda (p3242 n3243 ids3244) (if (id?2104 p3242) (if (bound-id-member?2131 p3242 keys3240) (values (vector (quote free-id) p3242) ids3244) (values (quote any) (cons (cons p3242 n3243) ids3244))) ((lambda (tmp3245) ((lambda (tmp3246) (if (if tmp3246 (apply (lambda (x3247 dots3248) (ellipsis?2149 dots3248)) tmp3246) #f) (apply (lambda (x3249 dots3250) (call-with-values (lambda () (cvt3241 x3249 (fx+2063 n3243 1) ids3244)) (lambda (p3251 ids3252) (values (if (eq? p3251 (quote any)) (quote each-any) (vector (quote each) p3251)) ids3252)))) tmp3246) ((lambda (tmp3253) (if tmp3253 (apply (lambda (x3254 y3255) (call-with-values (lambda () (cvt3241 y3255 n3243 ids3244)) (lambda (y3256 ids3257) (call-with-values (lambda () (cvt3241 x3254 n3243 ids3257)) (lambda (x3258 ids3259) (values (cons x3258 y3256) ids3259)))))) tmp3253) ((lambda (tmp3260) (if tmp3260 (apply (lambda () (values (quote ()) ids3244)) tmp3260) ((lambda (tmp3261) (if tmp3261 (apply (lambda (x3262) (call-with-values (lambda () (cvt3241 x3262 n3243 ids3244)) (lambda (p3264 ids3265) (values (vector (quote vector) p3264) ids3265)))) tmp3261) ((lambda (x3266) (values (vector (quote atom) (strip2151 p3242 (quote (())))) ids3244)) tmp3245))) ($sc-dispatch tmp3245 (quote #(vector each-any)))))) ($sc-dispatch tmp3245 (quote ()))))) ($sc-dispatch tmp3245 (quote (any . any)))))) ($sc-dispatch tmp3245 (quote (any any))))) p3242))))) (cvt3241 pattern3239 0 (quote ())))))) (lambda (e3267 r3268 w3269 s3270 mod3271) (let ((e3272 (source-wrap2133 e3267 w3269 s3270 mod3271))) ((lambda (tmp3273) ((lambda (tmp3274) (if tmp3274 (apply (lambda (_3275 val3276 key3277 m3278) (if (and-map (lambda (x3279) (if (id?2104 x3279) (not (ellipsis?2149 x3279)) #f)) key3277) (let ((x3281 (gen-var2152 (quote tmp)))) (build-application2072 s3270 (build-lambda2080 #f (list (quote tmp)) (list x3281) #f (gen-syntax-case3194 (build-lexical-reference2074 (quote value) #f (quote tmp) x3281) key3277 m3278 r3268 mod3271)) (list (chi2140 val3276 r3268 (quote (())) mod3271)))) (syntax-violation (quote syntax-case) "invalid literals list" e3272))) tmp3274) (syntax-violation #f "source expression failed to match any pattern" tmp3273))) ($sc-dispatch tmp3273 (quote (any any each-any . each-any))))) e3272))))) (set! sc-expand (lambda (x3285 . rest3284) (if (if (pair? x3285) (equal? (car x3285) noexpand2061) #f) (cadr x3285) (let ((m3286 (if (null? rest3284) (quote e) (car rest3284))) (esew3287 (if (let ((t3288 (null? rest3284))) (if t3288 t3288 (null? (cdr rest3284)))) (quote (eval)) (cadr rest3284)))) (with-fluid* *mode*2062 m3286 (lambda () (chi-top2139 x3285 (quote ()) (quote ((top))) m3286 esew3287 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x3289) (nonsymbol-id?2103 x3289))) (set! datum->syntax (lambda (id3290 datum3291) (make-syntax-object2087 datum3291 (syntax-object-wrap2090 id3290) #f))) (set! syntax->datum (lambda (x3292) (strip2151 x3292 (quote (()))))) (set! generate-temporaries (lambda (ls3293) (begin (let ((x3294 ls3293)) (if (not (list? x3294)) (syntax-violation (quote generate-temporaries) "invalid argument" x3294) (if #f #f))) (map (lambda (x3295) (wrap2132 (gensym) (quote ((top))) #f)) ls3293)))) (set! free-identifier=? (lambda (x3296 y3297) (begin (let ((x3298 x3296)) (if (not (nonsymbol-id?2103 x3298)) (syntax-violation (quote free-identifier=?) "invalid argument" x3298) (if #f #f))) (let ((x3299 y3297)) (if (not (nonsymbol-id?2103 x3299)) (syntax-violation (quote free-identifier=?) "invalid argument" x3299) (if #f #f))) (free-id=?2127 x3296 y3297)))) (set! bound-identifier=? (lambda (x3300 y3301) (begin (let ((x3302 x3300)) (if (not (nonsymbol-id?2103 x3302)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3302) (if #f #f))) (let ((x3303 y3301)) (if (not (nonsymbol-id?2103 x3303)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3303) (if #f #f))) (bound-id=?2128 x3300 y3301)))) (set! syntax-violation (lambda (who3307 message3306 form3305 . subform3304) (begin (let ((x3308 who3307)) (if (not ((lambda (x3309) (let ((t3310 (not x3309))) (if t3310 t3310 (let ((t3311 (string? x3309))) (if t3311 t3311 (symbol? x3309)))))) x3308)) (syntax-violation (quote syntax-violation) "invalid argument" x3308) (if #f #f))) (let ((x3312 message3306)) (if (not (string? x3312)) (syntax-violation (quote syntax-violation) "invalid argument" x3312) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who3307 "~a: " "") "~a " (if (null? subform3304) "in ~a" "in subform `~s' of `~s'")) (let ((tail3313 (cons message3306 (map (lambda (x3314) (strip2151 x3314 (quote (())))) (append subform3304 (list form3305)))))) (if who3307 (cons who3307 tail3313) tail3313)) #f)))) (letrec ((match3319 (lambda (e3320 p3321 w3322 r3323 mod3324) (if (not r3323) #f (if (eq? p3321 (quote any)) (cons (wrap2132 e3320 w3322 mod3324) r3323) (if (syntax-object?2088 e3320) (match*3318 (let ((e3325 (syntax-object-expression2089 e3320))) (if (annotation? e3325) (annotation-expression e3325) e3325)) p3321 (join-wraps2123 w3322 (syntax-object-wrap2090 e3320)) r3323 (syntax-object-module2091 e3320)) (match*3318 (let ((e3326 e3320)) (if (annotation? e3326) (annotation-expression e3326) e3326)) p3321 w3322 r3323 mod3324)))))) (match*3318 (lambda (e3327 p3328 w3329 r3330 mod3331) (if (null? p3328) (if (null? e3327) r3330 #f) (if (pair? p3328) (if (pair? e3327) (match3319 (car e3327) (car p3328) w3329 (match3319 (cdr e3327) (cdr p3328) w3329 r3330 mod3331) mod3331) #f) (if (eq? p3328 (quote each-any)) (let ((l3332 (match-each-any3316 e3327 w3329 mod3331))) (if l3332 (cons l3332 r3330) #f)) (let ((atom-key3333 (vector-ref p3328 0))) (if (memv atom-key3333 (quote (each))) (if (null? e3327) (match-empty3317 (vector-ref p3328 1) r3330) (let ((l3334 (match-each3315 e3327 (vector-ref p3328 1) w3329 mod3331))) (if l3334 (letrec ((collect3335 (lambda (l3336) (if (null? (car l3336)) r3330 (cons (map car l3336) (collect3335 (map cdr l3336))))))) (collect3335 l3334)) #f))) (if (memv atom-key3333 (quote (free-id))) (if (id?2104 e3327) (if (free-id=?2127 (wrap2132 e3327 w3329 mod3331) (vector-ref p3328 1)) r3330 #f) #f) (if (memv atom-key3333 (quote (atom))) (if (equal? (vector-ref p3328 1) (strip2151 e3327 w3329)) r3330 #f) (if (memv atom-key3333 (quote (vector))) (if (vector? e3327) (match3319 (vector->list e3327) (vector-ref p3328 1) w3329 r3330 mod3331) #f) (if #f #f))))))))))) (match-empty3317 (lambda (p3337 r3338) (if (null? p3337) r3338 (if (eq? p3337 (quote any)) (cons (quote ()) r3338) (if (pair? p3337) (match-empty3317 (car p3337) (match-empty3317 (cdr p3337) r3338)) (if (eq? p3337 (quote each-any)) (cons (quote ()) r3338) (let ((atom-key3339 (vector-ref p3337 0))) (if (memv atom-key3339 (quote (each))) (match-empty3317 (vector-ref p3337 1) r3338) (if (memv atom-key3339 (quote (free-id atom))) r3338 (if (memv atom-key3339 (quote (vector))) (match-empty3317 (vector-ref p3337 1) r3338) (if #f #f))))))))))) (match-each-any3316 (lambda (e3340 w3341 mod3342) (if (annotation? e3340) (match-each-any3316 (annotation-expression e3340) w3341 mod3342) (if (pair? e3340) (let ((l3343 (match-each-any3316 (cdr e3340) w3341 mod3342))) (if l3343 (cons (wrap2132 (car e3340) w3341 mod3342) l3343) #f)) (if (null? e3340) (quote ()) (if (syntax-object?2088 e3340) (match-each-any3316 (syntax-object-expression2089 e3340) (join-wraps2123 w3341 (syntax-object-wrap2090 e3340)) mod3342) #f)))))) (match-each3315 (lambda (e3344 p3345 w3346 mod3347) (if (annotation? e3344) (match-each3315 (annotation-expression e3344) p3345 w3346 mod3347) (if (pair? e3344) (let ((first3348 (match3319 (car e3344) p3345 w3346 (quote ()) mod3347))) (if first3348 (let ((rest3349 (match-each3315 (cdr e3344) p3345 w3346 mod3347))) (if rest3349 (cons first3348 rest3349) #f)) #f)) (if (null? e3344) (quote ()) (if (syntax-object?2088 e3344) (match-each3315 (syntax-object-expression2089 e3344) p3345 (join-wraps2123 w3346 (syntax-object-wrap2090 e3344)) (syntax-object-module2091 e3344)) #f))))))) (set! $sc-dispatch (lambda (e3350 p3351) (if (eq? p3351 (quote any)) (list e3350) (if (syntax-object?2088 e3350) (match*3318 (let ((e3352 (syntax-object-expression2089 e3350))) (if (annotation? e3352) (annotation-expression e3352) e3352)) p3351 (syntax-object-wrap2090 e3350) (quote ()) (syntax-object-module2091 e3350)) (match*3318 (let ((e3353 e3350)) (if (annotation? e3353) (annotation-expression e3353) e3353)) p3351 (quote (())) (quote ()) #f))))))))) +(letrec ((and-map*2008 (lambda (f2048 first2047 . rest2046) (let ((t2049 (null? first2047))) (if t2049 t2049 (if (null? rest2046) (letrec ((andmap2050 (lambda (first2051) (let ((x2052 (car first2051)) (first2053 (cdr first2051))) (if (null? first2053) (f2048 x2052) (if (f2048 x2052) (andmap2050 first2053) #f)))))) (andmap2050 first2047)) (letrec ((andmap2054 (lambda (first2055 rest2056) (let ((x2057 (car first2055)) (xr2058 (map car rest2056)) (first2059 (cdr first2055)) (rest2060 (map cdr rest2056))) (if (null? first2059) (apply f2048 (cons x2057 xr2058)) (if (apply f2048 (cons x2057 xr2058)) (andmap2054 first2059 rest2060) #f)))))) (andmap2054 first2047 rest2046)))))))) (letrec ((lambda-var-list2153 (lambda (vars2282) (letrec ((lvl2283 (lambda (vars2284 ls2285 w2286) (if (pair? vars2284) (lvl2283 (cdr vars2284) (cons (wrap2132 (car vars2284) w2286 #f) ls2285) w2286) (if (id?2104 vars2284) (cons (wrap2132 vars2284 w2286 #f) ls2285) (if (null? vars2284) ls2285 (if (syntax-object?2088 vars2284) (lvl2283 (syntax-object-expression2089 vars2284) ls2285 (join-wraps2123 w2286 (syntax-object-wrap2090 vars2284))) (if (annotation? vars2284) (lvl2283 (annotation-expression vars2284) ls2285 w2286) (cons vars2284 ls2285))))))))) (lvl2283 vars2282 (quote ()) (quote (())))))) (gen-var2152 (lambda (id2287) (let ((id2288 (if (syntax-object?2088 id2287) (syntax-object-expression2089 id2287) id2287))) (if (annotation? id2288) (gensym (symbol->string (annotation-expression id2288))) (gensym (symbol->string id2288)))))) (strip2151 (lambda (x2289 w2290) (if (memq (quote top) (wrap-marks2107 w2290)) (if (let ((t2291 (annotation? x2289))) (if t2291 t2291 (if (pair? x2289) (annotation? (car x2289)) #f))) (strip-annotation2150 x2289 #f) x2289) (letrec ((f2292 (lambda (x2293) (if (syntax-object?2088 x2293) (strip2151 (syntax-object-expression2089 x2293) (syntax-object-wrap2090 x2293)) (if (pair? x2293) (let ((a2294 (f2292 (car x2293))) (d2295 (f2292 (cdr x2293)))) (if (if (eq? a2294 (car x2293)) (eq? d2295 (cdr x2293)) #f) x2293 (cons a2294 d2295))) (if (vector? x2293) (let ((old2296 (vector->list x2293))) (let ((new2297 (map f2292 old2296))) (if (and-map*2008 eq? old2296 new2297) x2293 (list->vector new2297)))) x2293)))))) (f2292 x2289))))) (strip-annotation2150 (lambda (x2298 parent2299) (if (pair? x2298) (let ((new2300 (cons #f #f))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2300) (if #f #f)) (set-car! new2300 (strip-annotation2150 (car x2298) #f)) (set-cdr! new2300 (strip-annotation2150 (cdr x2298) #f)) new2300)) (if (annotation? x2298) (let ((t2301 (annotation-stripped x2298))) (if t2301 t2301 (strip-annotation2150 (annotation-expression x2298) x2298))) (if (vector? x2298) (let ((new2302 (make-vector (vector-length x2298)))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2302) (if #f #f)) (letrec ((loop2303 (lambda (i2304) (unless (fx<2066 i2304 0) (vector-set! new2302 i2304 (strip-annotation2150 (vector-ref x2298 i2304) #f)) (loop2303 (fx-2064 i2304 1)))))) (loop2303 (- (vector-length x2298) 1))) new2302)) x2298))))) (ellipsis?2149 (lambda (x2305) (if (nonsymbol-id?2103 x2305) (free-id=?2127 x2305 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void2148 (lambda () (build-void2071 #f))) (eval-local-transformer2147 (lambda (expanded2306 mod2307) (let ((p2308 (local-eval-hook2068 expanded2306 mod2307))) (if (procedure? p2308) p2308 (syntax-violation #f "nonprocedure transformer" p2308))))) (chi-local-syntax2146 (lambda (rec?2309 e2310 r2311 w2312 s2313 mod2314 k2315) ((lambda (tmp2316) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 id2319 val2320 e12321 e22322) (let ((ids2323 id2319)) (if (not (valid-bound-ids?2129 ids2323)) (syntax-violation #f "duplicate bound keyword" e2310) (let ((labels2325 (gen-labels2110 ids2323))) (let ((new-w2326 (make-binding-wrap2121 ids2323 labels2325 w2312))) (k2315 (cons e12321 e22322) (extend-env2098 labels2325 (let ((w2328 (if rec?2309 new-w2326 w2312)) (trans-r2329 (macros-only-env2100 r2311))) (map (lambda (x2330) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2330 trans-r2329 w2328 mod2314) mod2314))) val2320)) r2311) new-w2326 s2313 mod2314)))))) tmp2317) ((lambda (_2332) (syntax-violation #f "bad local syntax definition" (source-wrap2133 e2310 w2312 s2313 mod2314))) tmp2316))) ($sc-dispatch tmp2316 (quote (any #(each (any any)) any . each-any))))) e2310))) (chi-lambda-clause2145 (lambda (e2333 docstring2334 c2335 r2336 w2337 mod2338 k2339) ((lambda (tmp2340) ((lambda (tmp2341) (if (if tmp2341 (apply (lambda (args2342 doc2343 e12344 e22345) (if (string? (syntax->datum doc2343)) (not docstring2334) #f)) tmp2341) #f) (apply (lambda (args2346 doc2347 e12348 e22349) (chi-lambda-clause2145 e2333 doc2347 (cons args2346 (cons e12348 e22349)) r2336 w2337 mod2338 k2339)) tmp2341) ((lambda (tmp2351) (if tmp2351 (apply (lambda (id2352 e12353 e22354) (let ((ids2355 id2352)) (if (not (valid-bound-ids?2129 ids2355)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2357 (gen-labels2110 ids2355)) (new-vars2358 (map gen-var2152 ids2355))) (k2339 (map syntax->datum ids2355) new-vars2358 docstring2334 (chi-body2144 (cons e12353 e22354) e2333 (extend-var-env2099 labels2357 new-vars2358 r2336) (make-binding-wrap2121 ids2355 labels2357 w2337) mod2338)))))) tmp2351) ((lambda (tmp2360) (if tmp2360 (apply (lambda (ids2361 e12362 e22363) (let ((old-ids2364 (lambda-var-list2153 ids2361))) (if (not (valid-bound-ids?2129 old-ids2364)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2365 (gen-labels2110 old-ids2364)) (new-vars2366 (map gen-var2152 old-ids2364))) (k2339 (letrec ((f2367 (lambda (ls12368 ls22369) (if (null? ls12368) (syntax->datum ls22369) (f2367 (cdr ls12368) (cons (syntax->datum (car ls12368)) ls22369)))))) (f2367 (cdr old-ids2364) (car old-ids2364))) (letrec ((f2370 (lambda (ls12371 ls22372) (if (null? ls12371) ls22372 (f2370 (cdr ls12371) (cons (car ls12371) ls22372)))))) (f2370 (cdr new-vars2366) (car new-vars2366))) docstring2334 (chi-body2144 (cons e12362 e22363) e2333 (extend-var-env2099 labels2365 new-vars2366 r2336) (make-binding-wrap2121 old-ids2364 labels2365 w2337) mod2338)))))) tmp2360) ((lambda (_2374) (syntax-violation (quote lambda) "bad lambda" e2333)) tmp2340))) ($sc-dispatch tmp2340 (quote (any any . each-any)))))) ($sc-dispatch tmp2340 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2340 (quote (any any any . each-any))))) c2335))) (chi-body2144 (lambda (body2375 outer-form2376 r2377 w2378 mod2379) (let ((r2380 (cons (quote ("placeholder" placeholder)) r2377))) (let ((ribcage2381 (make-ribcage2111 (quote ()) (quote ()) (quote ())))) (let ((w2382 (make-wrap2106 (wrap-marks2107 w2378) (cons ribcage2381 (wrap-subst2108 w2378))))) (letrec ((parse2383 (lambda (body2384 ids2385 labels2386 vars2387 vals2388 bindings2389) (if (null? body2384) (syntax-violation #f "no expressions in body" outer-form2376) (let ((e2391 (cdar body2384)) (er2392 (caar body2384))) (call-with-values (lambda () (syntax-type2138 e2391 er2392 (quote (())) #f ribcage2381 mod2379)) (lambda (type2393 value2394 e2395 w2396 s2397 mod2398) (if (memv type2393 (quote (define-form))) (let ((id2399 (wrap2132 value2394 w2396 mod2398)) (label2400 (gen-label2109))) (let ((var2401 (gen-var2152 id2399))) (begin (extend-ribcage!2120 ribcage2381 id2399 label2400) (parse2383 (cdr body2384) (cons id2399 ids2385) (cons label2400 labels2386) (cons var2401 vars2387) (cons (cons er2392 (wrap2132 e2395 w2396 mod2398)) vals2388) (cons (cons (quote lexical) var2401) bindings2389))))) (if (memv type2393 (quote (define-syntax-form))) (let ((id2402 (wrap2132 value2394 w2396 mod2398)) (label2403 (gen-label2109))) (begin (extend-ribcage!2120 ribcage2381 id2402 label2403) (parse2383 (cdr body2384) (cons id2402 ids2385) (cons label2403 labels2386) vars2387 vals2388 (cons (cons (quote macro) (cons er2392 (wrap2132 e2395 w2396 mod2398))) bindings2389)))) (if (memv type2393 (quote (begin-form))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 e12407) (parse2383 (letrec ((f2408 (lambda (forms2409) (if (null? forms2409) (cdr body2384) (cons (cons er2392 (wrap2132 (car forms2409) w2396 mod2398)) (f2408 (cdr forms2409))))))) (f2408 e12407)) ids2385 labels2386 vars2387 vals2388 bindings2389)) tmp2405) (syntax-violation #f "source expression failed to match any pattern" tmp2404))) ($sc-dispatch tmp2404 (quote (any . each-any))))) e2395) (if (memv type2393 (quote (local-syntax-form))) (chi-local-syntax2146 value2394 e2395 er2392 w2396 s2397 mod2398 (lambda (forms2411 er2412 w2413 s2414 mod2415) (parse2383 (letrec ((f2416 (lambda (forms2417) (if (null? forms2417) (cdr body2384) (cons (cons er2412 (wrap2132 (car forms2417) w2413 mod2415)) (f2416 (cdr forms2417))))))) (f2416 forms2411)) ids2385 labels2386 vars2387 vals2388 bindings2389))) (if (null? ids2385) (build-sequence2083 #f (map (lambda (x2418) (chi2140 (cdr x2418) (car x2418) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))) (begin (if (not (valid-bound-ids?2129 ids2385)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form2376) (if #f #f)) (letrec ((loop2419 (lambda (bs2420 er-cache2421 r-cache2422) (if (not (null? bs2420)) (let ((b2423 (car bs2420))) (if (eq? (car b2423) (quote macro)) (let ((er2424 (cadr b2423))) (let ((r-cache2425 (if (eq? er2424 er-cache2421) r-cache2422 (macros-only-env2100 er2424)))) (begin (set-cdr! b2423 (eval-local-transformer2147 (chi2140 (cddr b2423) r-cache2425 (quote (())) mod2398) mod2398)) (loop2419 (cdr bs2420) er2424 r-cache2425)))) (loop2419 (cdr bs2420) er-cache2421 r-cache2422))) (if #f #f))))) (loop2419 bindings2389 #f #f)) (set-cdr! r2380 (extend-env2098 labels2386 bindings2389 (cdr r2380))) (build-letrec2086 #f (map syntax->datum ids2385) vars2387 (map (lambda (x2426) (chi2140 (cdr x2426) (car x2426) (quote (())) mod2398)) vals2388) (build-sequence2083 #f (map (lambda (x2427) (chi2140 (cdr x2427) (car x2427) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))))))))))))))))) (parse2383 (map (lambda (x2390) (cons r2380 (wrap2132 x2390 w2382 mod2379))) body2375) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro2143 (lambda (p2428 e2429 r2430 w2431 rib2432 mod2433) (letrec ((rebuild-macro-output2434 (lambda (x2435 m2436) (if (pair? x2435) (cons (rebuild-macro-output2434 (car x2435) m2436) (rebuild-macro-output2434 (cdr x2435) m2436)) (if (syntax-object?2088 x2435) (let ((w2437 (syntax-object-wrap2090 x2435))) (let ((ms2438 (wrap-marks2107 w2437)) (s2439 (wrap-subst2108 w2437))) (if (if (pair? ms2438) (eq? (car ms2438) #f) #f) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cdr ms2438) (if rib2432 (cons rib2432 (cdr s2439)) (cdr s2439))) (syntax-object-module2091 x2435)) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cons m2436 ms2438) (if rib2432 (cons rib2432 (cons (quote shift) s2439)) (cons (quote shift) s2439))) (let ((pmod2440 (procedure-module p2428))) (if pmod2440 (cons (quote hygiene) (module-name pmod2440)) (quote (hygiene guile)))))))) (if (vector? x2435) (let ((n2441 (vector-length x2435))) (let ((v2442 (make-vector n2441))) (letrec ((loop2443 (lambda (i2444) (if (fx=2065 i2444 n2441) (begin (if #f #f (if #f #f)) v2442) (begin (vector-set! v2442 i2444 (rebuild-macro-output2434 (vector-ref x2435 i2444) m2436)) (loop2443 (fx+2063 i2444 1))))))) (loop2443 0)))) (if (symbol? x2435) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap2133 e2429 w2431 s mod2433) x2435) x2435))))))) (rebuild-macro-output2434 (p2428 (wrap2132 e2429 (anti-mark2119 w2431) mod2433)) (string #\m))))) (chi-application2142 (lambda (x2445 e2446 r2447 w2448 s2449 mod2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (e02453 e12454) (build-application2072 s2449 x2445 (map (lambda (e2455) (chi2140 e2455 r2447 w2448 mod2450)) e12454))) tmp2452) (syntax-violation #f "source expression failed to match any pattern" tmp2451))) ($sc-dispatch tmp2451 (quote (any . each-any))))) e2446))) (chi-expr2141 (lambda (type2457 value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (lexical))) (build-lexical-reference2074 (quote value) s2462 e2459 value2458) (if (memv type2457 (quote (core external-macro))) (value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (module-ref))) (call-with-values (lambda () (value2458 e2459)) (lambda (id2464 mod2465) (build-global-reference2077 s2462 id2464 mod2465))) (if (memv type2457 (quote (lexical-call))) (chi-application2142 (build-lexical-reference2074 (quote fun) (source-annotation2095 (car e2459)) (car e2459) value2458) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (global-call))) (chi-application2142 (build-global-reference2077 (source-annotation2095 (car e2459)) value2458 (if (syntax-object?2088 (car e2459)) (syntax-object-module2091 (car e2459)) mod2463)) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (constant))) (build-data2082 s2462 (strip2151 (source-wrap2133 e2459 w2461 s2462 mod2463) (quote (())))) (if (memv type2457 (quote (global))) (build-global-reference2077 s2462 value2458 mod2463) (if (memv type2457 (quote (call))) (chi-application2142 (chi2140 (car e2459) r2460 w2461 mod2463) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (begin-form))) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 e12469 e22470) (chi-sequence2134 (cons e12469 e22470) r2460 w2461 s2462 mod2463)) tmp2467) (syntax-violation #f "source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any any . each-any))))) e2459) (if (memv type2457 (quote (local-syntax-form))) (chi-local-syntax2146 value2458 e2459 r2460 w2461 s2462 mod2463 chi-sequence2134) (if (memv type2457 (quote (eval-when-form))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (_2474 x2475 e12476 e22477) (let ((when-list2478 (chi-when-list2137 e2459 x2475 w2461))) (if (memq (quote eval) when-list2478) (chi-sequence2134 (cons e12476 e22477) r2460 w2461 s2462 mod2463) (chi-void2148)))) tmp2473) (syntax-violation #f "source expression failed to match any pattern" tmp2472))) ($sc-dispatch tmp2472 (quote (any each-any any . each-any))))) e2459) (if (memv type2457 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e2459 (wrap2132 value2458 w2461 mod2463)) (if (memv type2457 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap2133 e2459 w2461 s2462 mod2463)) (if (memv type2457 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap2133 e2459 w2461 s2462 mod2463)) (syntax-violation #f "unexpected syntax" (source-wrap2133 e2459 w2461 s2462 mod2463)))))))))))))))))) (chi2140 (lambda (e2481 r2482 w2483 mod2484) (call-with-values (lambda () (syntax-type2138 e2481 r2482 w2483 #f #f mod2484)) (lambda (type2485 value2486 e2487 w2488 s2489 mod2490) (chi-expr2141 type2485 value2486 e2487 r2482 w2488 s2489 mod2490))))) (chi-top2139 (lambda (e2491 r2492 w2493 m2494 esew2495 mod2496) (call-with-values (lambda () (syntax-type2138 e2491 r2492 w2493 #f #f mod2496)) (lambda (type2504 value2505 e2506 w2507 s2508 mod2509) (if (memv type2504 (quote (begin-form))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (_2512) (chi-void2148)) tmp2511) ((lambda (tmp2513) (if tmp2513 (apply (lambda (_2514 e12515 e22516) (chi-top-sequence2135 (cons e12515 e22516) r2492 w2507 s2508 m2494 esew2495 mod2509)) tmp2513) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote (any any . each-any)))))) ($sc-dispatch tmp2510 (quote (any))))) e2506) (if (memv type2504 (quote (local-syntax-form))) (chi-local-syntax2146 value2505 e2506 r2492 w2507 s2508 mod2509 (lambda (body2518 r2519 w2520 s2521 mod2522) (chi-top-sequence2135 body2518 r2519 w2520 s2521 m2494 esew2495 mod2522))) (if (memv type2504 (quote (eval-when-form))) ((lambda (tmp2523) ((lambda (tmp2524) (if tmp2524 (apply (lambda (_2525 x2526 e12527 e22528) (let ((when-list2529 (chi-when-list2137 e2506 x2526 w2507)) (body2530 (cons e12527 e22528))) (if (eq? m2494 (quote e)) (if (memq (quote eval) when-list2529) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) (chi-void2148)) (if (memq (quote load) when-list2529) (if (let ((t2533 (memq (quote compile) when-list2529))) (if t2533 t2533 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c&e) (quote (compile load)) mod2509) (if (memq m2494 (quote (c c&e))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c) (quote (load)) mod2509) (chi-void2148))) (if (let ((t2534 (memq (quote compile) when-list2529))) (if t2534 t2534 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (begin (top-level-eval-hook2067 (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) mod2509) (chi-void2148)) (chi-void2148)))))) tmp2524) (syntax-violation #f "source expression failed to match any pattern" tmp2523))) ($sc-dispatch tmp2523 (quote (any each-any any . each-any))))) e2506) (if (memv type2504 (quote (define-syntax-form))) (let ((n2535 (id-var-name2126 value2505 w2507)) (r2536 (macros-only-env2100 r2492))) (if (memv m2494 (quote (c))) (if (memq (quote compile) esew2495) (let ((e2537 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2537 mod2509) (if (memq (quote load) esew2495) e2537 (chi-void2148)))) (if (memq (quote load) esew2495) (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) (chi-void2148))) (if (memv m2494 (quote (c&e))) (let ((e2538 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2538 mod2509) e2538)) (begin (if (memq (quote eval) esew2495) (top-level-eval-hook2067 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) mod2509) (if #f #f)) (chi-void2148))))) (if (memv type2504 (quote (define-form))) (let ((n2539 (id-var-name2126 value2505 w2507))) (let ((type2540 (binding-type2096 (lookup2101 n2539 r2492 mod2509)))) (if (memv type2540 (quote (global core macro module-ref))) (let ((x2541 (build-global-definition2079 s2508 n2539 (chi2140 e2506 r2492 w2507 mod2509)))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2541 mod2509) (if #f #f)) x2541)) (if (memv type2540 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e2506 (wrap2132 value2505 w2507 mod2509)) (syntax-violation #f "cannot define keyword at top level" e2506 (wrap2132 value2505 w2507 mod2509)))))) (let ((x2542 (chi-expr2141 type2504 value2505 e2506 r2492 w2507 s2508 mod2509))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2542 mod2509) (if #f #f)) x2542))))))))))) (syntax-type2138 (lambda (e2543 r2544 w2545 s2546 rib2547 mod2548) (if (symbol? e2543) (let ((n2549 (id-var-name2126 e2543 w2545))) (let ((b2550 (lookup2101 n2549 r2544 mod2548))) (let ((type2551 (binding-type2096 b2550))) (if (memv type2551 (quote (lexical))) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (global))) (values type2551 n2549 e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2550) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548))))))) (if (pair? e2543) (let ((first2552 (car e2543))) (if (id?2104 first2552) (let ((n2553 (id-var-name2126 first2552 w2545))) (let ((b2554 (lookup2101 n2553 r2544 (let ((t2555 (if (syntax-object?2088 first2552) (syntax-object-module2091 first2552) #f))) (if t2555 t2555 mod2548))))) (let ((type2556 (binding-type2096 b2554))) (if (memv type2556 (quote (lexical))) (values (quote lexical-call) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (global))) (values (quote global-call) n2553 e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2554) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (if (memv type2556 (quote (core external-macro module-ref))) (values type2556 (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (begin))) (values (quote begin-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (eval-when))) (values (quote eval-when-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (define))) ((lambda (tmp2557) ((lambda (tmp2558) (if (if tmp2558 (apply (lambda (_2559 name2560 val2561) (id?2104 name2560)) tmp2558) #f) (apply (lambda (_2562 name2563 val2564) (values (quote define-form) name2563 val2564 w2545 s2546 mod2548)) tmp2558) ((lambda (tmp2565) (if (if tmp2565 (apply (lambda (_2566 name2567 args2568 e12569 e22570) (if (id?2104 name2567) (valid-bound-ids?2129 (lambda-var-list2153 args2568)) #f)) tmp2565) #f) (apply (lambda (_2571 name2572 args2573 e12574 e22575) (values (quote define-form) (wrap2132 name2572 w2545 mod2548) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap2132 (cons args2573 (cons e12574 e22575)) w2545 mod2548)) (quote (())) s2546 mod2548)) tmp2565) ((lambda (tmp2577) (if (if tmp2577 (apply (lambda (_2578 name2579) (id?2104 name2579)) tmp2577) #f) (apply (lambda (_2580 name2581) (values (quote define-form) (wrap2132 name2581 w2545 mod2548) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2546 mod2548)) tmp2577) (syntax-violation #f "source expression failed to match any pattern" tmp2557))) ($sc-dispatch tmp2557 (quote (any any)))))) ($sc-dispatch tmp2557 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2557 (quote (any any any))))) e2543) (if (memv type2556 (quote (define-syntax))) ((lambda (tmp2582) ((lambda (tmp2583) (if (if tmp2583 (apply (lambda (_2584 name2585 val2586) (id?2104 name2585)) tmp2583) #f) (apply (lambda (_2587 name2588 val2589) (values (quote define-syntax-form) name2588 val2589 w2545 s2546 mod2548)) tmp2583) (syntax-violation #f "source expression failed to match any pattern" tmp2582))) ($sc-dispatch tmp2582 (quote (any any any))))) e2543) (values (quote call) #f e2543 w2545 s2546 mod2548))))))))))))) (values (quote call) #f e2543 w2545 s2546 mod2548))) (if (syntax-object?2088 e2543) (syntax-type2138 (syntax-object-expression2089 e2543) r2544 (join-wraps2123 w2545 (syntax-object-wrap2090 e2543)) #f rib2547 (let ((t2590 (syntax-object-module2091 e2543))) (if t2590 t2590 mod2548))) (if (annotation? e2543) (syntax-type2138 (annotation-expression e2543) r2544 w2545 (annotation-source e2543) rib2547 mod2548) (if (self-evaluating? e2543) (values (quote constant) #f e2543 w2545 s2546 mod2548) (values (quote other) #f e2543 w2545 s2546 mod2548)))))))) (chi-when-list2137 (lambda (e2591 when-list2592 w2593) (letrec ((f2594 (lambda (when-list2595 situations2596) (if (null? when-list2595) situations2596 (f2594 (cdr when-list2595) (cons (let ((x2597 (car when-list2595))) (if (free-id=?2127 x2597 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?2127 x2597 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?2127 x2597 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e2591 (wrap2132 x2597 w2593 #f)))))) situations2596)))))) (f2594 when-list2592 (quote ()))))) (chi-install-global2136 (lambda (name2598 e2599) (build-global-definition2079 #f name2598 (if (let ((v2600 (module-variable (current-module) name2598))) (if v2600 (if (variable-bound? v2600) (if (macro? (variable-ref v2600)) (not (eq? (macro-type (variable-ref v2600)) (quote syncase-macro))) #f) #f) #f)) (build-application2072 #f (build-primref2081 #f (quote make-extended-syncase-macro)) (list (build-application2072 #f (build-primref2081 #f (quote module-ref)) (list (build-application2072 #f (build-primref2081 #f (quote current-module)) (quote ())) (build-data2082 #f name2598))) (build-data2082 #f (quote macro)) e2599)) (build-application2072 #f (build-primref2081 #f (quote make-syncase-macro)) (list (build-data2082 #f (quote macro)) e2599)))))) (chi-top-sequence2135 (lambda (body2601 r2602 w2603 s2604 m2605 esew2606 mod2607) (build-sequence2083 s2604 (letrec ((dobody2608 (lambda (body2609 r2610 w2611 m2612 esew2613 mod2614) (if (null? body2609) (quote ()) (let ((first2615 (chi-top2139 (car body2609) r2610 w2611 m2612 esew2613 mod2614))) (cons first2615 (dobody2608 (cdr body2609) r2610 w2611 m2612 esew2613 mod2614))))))) (dobody2608 body2601 r2602 w2603 m2605 esew2606 mod2607))))) (chi-sequence2134 (lambda (body2616 r2617 w2618 s2619 mod2620) (build-sequence2083 s2619 (letrec ((dobody2621 (lambda (body2622 r2623 w2624 mod2625) (if (null? body2622) (quote ()) (let ((first2626 (chi2140 (car body2622) r2623 w2624 mod2625))) (cons first2626 (dobody2621 (cdr body2622) r2623 w2624 mod2625))))))) (dobody2621 body2616 r2617 w2618 mod2620))))) (source-wrap2133 (lambda (x2627 w2628 s2629 defmod2630) (wrap2132 (if s2629 (make-annotation x2627 s2629 #f) x2627) w2628 defmod2630))) (wrap2132 (lambda (x2631 w2632 defmod2633) (if (if (null? (wrap-marks2107 w2632)) (null? (wrap-subst2108 w2632)) #f) x2631 (if (syntax-object?2088 x2631) (make-syntax-object2087 (syntax-object-expression2089 x2631) (join-wraps2123 w2632 (syntax-object-wrap2090 x2631)) (syntax-object-module2091 x2631)) (if (null? x2631) x2631 (make-syntax-object2087 x2631 w2632 defmod2633)))))) (bound-id-member?2131 (lambda (x2634 list2635) (if (not (null? list2635)) (let ((t2636 (bound-id=?2128 x2634 (car list2635)))) (if t2636 t2636 (bound-id-member?2131 x2634 (cdr list2635)))) #f))) (distinct-bound-ids?2130 (lambda (ids2637) (letrec ((distinct?2638 (lambda (ids2639) (let ((t2640 (null? ids2639))) (if t2640 t2640 (if (not (bound-id-member?2131 (car ids2639) (cdr ids2639))) (distinct?2638 (cdr ids2639)) #f)))))) (distinct?2638 ids2637)))) (valid-bound-ids?2129 (lambda (ids2641) (if (letrec ((all-ids?2642 (lambda (ids2643) (let ((t2644 (null? ids2643))) (if t2644 t2644 (if (id?2104 (car ids2643)) (all-ids?2642 (cdr ids2643)) #f)))))) (all-ids?2642 ids2641)) (distinct-bound-ids?2130 ids2641) #f))) (bound-id=?2128 (lambda (i2645 j2646) (if (if (syntax-object?2088 i2645) (syntax-object?2088 j2646) #f) (if (eq? (let ((e2647 (syntax-object-expression2089 i2645))) (if (annotation? e2647) (annotation-expression e2647) e2647)) (let ((e2648 (syntax-object-expression2089 j2646))) (if (annotation? e2648) (annotation-expression e2648) e2648))) (same-marks?2125 (wrap-marks2107 (syntax-object-wrap2090 i2645)) (wrap-marks2107 (syntax-object-wrap2090 j2646))) #f) (eq? (let ((e2649 i2645)) (if (annotation? e2649) (annotation-expression e2649) e2649)) (let ((e2650 j2646)) (if (annotation? e2650) (annotation-expression e2650) e2650)))))) (free-id=?2127 (lambda (i2651 j2652) (if (eq? (let ((x2653 i2651)) (let ((e2654 (if (syntax-object?2088 x2653) (syntax-object-expression2089 x2653) x2653))) (if (annotation? e2654) (annotation-expression e2654) e2654))) (let ((x2655 j2652)) (let ((e2656 (if (syntax-object?2088 x2655) (syntax-object-expression2089 x2655) x2655))) (if (annotation? e2656) (annotation-expression e2656) e2656)))) (eq? (id-var-name2126 i2651 (quote (()))) (id-var-name2126 j2652 (quote (())))) #f))) (id-var-name2126 (lambda (id2657 w2658) (letrec ((search-vector-rib2661 (lambda (sym2667 subst2668 marks2669 symnames2670 ribcage2671) (let ((n2672 (vector-length symnames2670))) (letrec ((f2673 (lambda (i2674) (if (fx=2065 i2674 n2672) (search2659 sym2667 (cdr subst2668) marks2669) (if (if (eq? (vector-ref symnames2670 i2674) sym2667) (same-marks?2125 marks2669 (vector-ref (ribcage-marks2114 ribcage2671) i2674)) #f) (values (vector-ref (ribcage-labels2115 ribcage2671) i2674) marks2669) (f2673 (fx+2063 i2674 1))))))) (f2673 0))))) (search-list-rib2660 (lambda (sym2675 subst2676 marks2677 symnames2678 ribcage2679) (letrec ((f2680 (lambda (symnames2681 i2682) (if (null? symnames2681) (search2659 sym2675 (cdr subst2676) marks2677) (if (if (eq? (car symnames2681) sym2675) (same-marks?2125 marks2677 (list-ref (ribcage-marks2114 ribcage2679) i2682)) #f) (values (list-ref (ribcage-labels2115 ribcage2679) i2682) marks2677) (f2680 (cdr symnames2681) (fx+2063 i2682 1))))))) (f2680 symnames2678 0)))) (search2659 (lambda (sym2683 subst2684 marks2685) (if (null? subst2684) (values #f marks2685) (let ((fst2686 (car subst2684))) (if (eq? fst2686 (quote shift)) (search2659 sym2683 (cdr subst2684) (cdr marks2685)) (let ((symnames2687 (ribcage-symnames2113 fst2686))) (if (vector? symnames2687) (search-vector-rib2661 sym2683 subst2684 marks2685 symnames2687 fst2686) (search-list-rib2660 sym2683 subst2684 marks2685 symnames2687 fst2686))))))))) (if (symbol? id2657) (let ((t2688 (call-with-values (lambda () (search2659 id2657 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2690 . ignore2689) x2690)))) (if t2688 t2688 id2657)) (if (syntax-object?2088 id2657) (let ((id2691 (let ((e2693 (syntax-object-expression2089 id2657))) (if (annotation? e2693) (annotation-expression e2693) e2693))) (w12692 (syntax-object-wrap2090 id2657))) (let ((marks2694 (join-marks2124 (wrap-marks2107 w2658) (wrap-marks2107 w12692)))) (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w2658) marks2694)) (lambda (new-id2695 marks2696) (let ((t2697 new-id2695)) (if t2697 t2697 (let ((t2698 (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w12692) marks2696)) (lambda (x2700 . ignore2699) x2700)))) (if t2698 t2698 id2691)))))))) (if (annotation? id2657) (let ((id2701 (let ((e2702 id2657)) (if (annotation? e2702) (annotation-expression e2702) e2702)))) (let ((t2703 (call-with-values (lambda () (search2659 id2701 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2705 . ignore2704) x2705)))) (if t2703 t2703 id2701))) (syntax-violation (quote id-var-name) "invalid id" id2657))))))) (same-marks?2125 (lambda (x2706 y2707) (let ((t2708 (eq? x2706 y2707))) (if t2708 t2708 (if (not (null? x2706)) (if (not (null? y2707)) (if (eq? (car x2706) (car y2707)) (same-marks?2125 (cdr x2706) (cdr y2707)) #f) #f) #f))))) (join-marks2124 (lambda (m12709 m22710) (smart-append2122 m12709 m22710))) (join-wraps2123 (lambda (w12711 w22712) (let ((m12713 (wrap-marks2107 w12711)) (s12714 (wrap-subst2108 w12711))) (if (null? m12713) (if (null? s12714) w22712 (make-wrap2106 (wrap-marks2107 w22712) (smart-append2122 s12714 (wrap-subst2108 w22712)))) (make-wrap2106 (smart-append2122 m12713 (wrap-marks2107 w22712)) (smart-append2122 s12714 (wrap-subst2108 w22712))))))) (smart-append2122 (lambda (m12715 m22716) (if (null? m22716) m12715 (append m12715 m22716)))) (make-binding-wrap2121 (lambda (ids2717 labels2718 w2719) (if (null? ids2717) w2719 (make-wrap2106 (wrap-marks2107 w2719) (cons (let ((labelvec2720 (list->vector labels2718))) (let ((n2721 (vector-length labelvec2720))) (let ((symnamevec2722 (make-vector n2721)) (marksvec2723 (make-vector n2721))) (begin (letrec ((f2724 (lambda (ids2725 i2726) (if (not (null? ids2725)) (call-with-values (lambda () (id-sym-name&marks2105 (car ids2725) w2719)) (lambda (symname2727 marks2728) (begin (vector-set! symnamevec2722 i2726 symname2727) (vector-set! marksvec2723 i2726 marks2728) (f2724 (cdr ids2725) (fx+2063 i2726 1))))) (if #f #f))))) (f2724 ids2717 0)) (make-ribcage2111 symnamevec2722 marksvec2723 labelvec2720))))) (wrap-subst2108 w2719)))))) (extend-ribcage!2120 (lambda (ribcage2729 id2730 label2731) (begin (set-ribcage-symnames!2116 ribcage2729 (cons (let ((e2732 (syntax-object-expression2089 id2730))) (if (annotation? e2732) (annotation-expression e2732) e2732)) (ribcage-symnames2113 ribcage2729))) (set-ribcage-marks!2117 ribcage2729 (cons (wrap-marks2107 (syntax-object-wrap2090 id2730)) (ribcage-marks2114 ribcage2729))) (set-ribcage-labels!2118 ribcage2729 (cons label2731 (ribcage-labels2115 ribcage2729)))))) (anti-mark2119 (lambda (w2733) (make-wrap2106 (cons #f (wrap-marks2107 w2733)) (cons (quote shift) (wrap-subst2108 w2733))))) (set-ribcage-labels!2118 (lambda (x2734 update2735) (vector-set! x2734 3 update2735))) (set-ribcage-marks!2117 (lambda (x2736 update2737) (vector-set! x2736 2 update2737))) (set-ribcage-symnames!2116 (lambda (x2738 update2739) (vector-set! x2738 1 update2739))) (ribcage-labels2115 (lambda (x2740) (vector-ref x2740 3))) (ribcage-marks2114 (lambda (x2741) (vector-ref x2741 2))) (ribcage-symnames2113 (lambda (x2742) (vector-ref x2742 1))) (ribcage?2112 (lambda (x2743) (if (vector? x2743) (if (= (vector-length x2743) 4) (eq? (vector-ref x2743 0) (quote ribcage)) #f) #f))) (make-ribcage2111 (lambda (symnames2744 marks2745 labels2746) (vector (quote ribcage) symnames2744 marks2745 labels2746))) (gen-labels2110 (lambda (ls2747) (if (null? ls2747) (quote ()) (cons (gen-label2109) (gen-labels2110 (cdr ls2747)))))) (gen-label2109 (lambda () (string #\i))) (wrap-subst2108 cdr) (wrap-marks2107 car) (make-wrap2106 cons) (id-sym-name&marks2105 (lambda (x2748 w2749) (if (syntax-object?2088 x2748) (values (let ((e2750 (syntax-object-expression2089 x2748))) (if (annotation? e2750) (annotation-expression e2750) e2750)) (join-marks2124 (wrap-marks2107 w2749) (wrap-marks2107 (syntax-object-wrap2090 x2748)))) (values (let ((e2751 x2748)) (if (annotation? e2751) (annotation-expression e2751) e2751)) (wrap-marks2107 w2749))))) (id?2104 (lambda (x2752) (if (symbol? x2752) #t (if (syntax-object?2088 x2752) (symbol? (let ((e2753 (syntax-object-expression2089 x2752))) (if (annotation? e2753) (annotation-expression e2753) e2753))) (if (annotation? x2752) (symbol? (annotation-expression x2752)) #f))))) (nonsymbol-id?2103 (lambda (x2754) (if (syntax-object?2088 x2754) (symbol? (let ((e2755 (syntax-object-expression2089 x2754))) (if (annotation? e2755) (annotation-expression e2755) e2755))) #f))) (global-extend2102 (lambda (type2756 sym2757 val2758) (put-global-definition-hook2069 sym2757 type2756 val2758))) (lookup2101 (lambda (x2759 r2760 mod2761) (let ((temp2762 (assq x2759 r2760))) (if temp2762 (cdr temp2762) (if (symbol? x2759) (let ((t2763 (get-global-definition-hook2070 x2759 mod2761))) (if t2763 t2763 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env2100 (lambda (r2764) (if (null? r2764) (quote ()) (let ((a2765 (car r2764))) (if (eq? (cadr a2765) (quote macro)) (cons a2765 (macros-only-env2100 (cdr r2764))) (macros-only-env2100 (cdr r2764))))))) (extend-var-env2099 (lambda (labels2766 vars2767 r2768) (if (null? labels2766) r2768 (extend-var-env2099 (cdr labels2766) (cdr vars2767) (cons (cons (car labels2766) (cons (quote lexical) (car vars2767))) r2768))))) (extend-env2098 (lambda (labels2769 bindings2770 r2771) (if (null? labels2769) r2771 (extend-env2098 (cdr labels2769) (cdr bindings2770) (cons (cons (car labels2769) (car bindings2770)) r2771))))) (binding-value2097 cdr) (binding-type2096 car) (source-annotation2095 (lambda (x2772) (if (annotation? x2772) (annotation-source x2772) (if (syntax-object?2088 x2772) (source-annotation2095 (syntax-object-expression2089 x2772)) #f)))) (set-syntax-object-module!2094 (lambda (x2773 update2774) (vector-set! x2773 3 update2774))) (set-syntax-object-wrap!2093 (lambda (x2775 update2776) (vector-set! x2775 2 update2776))) (set-syntax-object-expression!2092 (lambda (x2777 update2778) (vector-set! x2777 1 update2778))) (syntax-object-module2091 (lambda (x2779) (vector-ref x2779 3))) (syntax-object-wrap2090 (lambda (x2780) (vector-ref x2780 2))) (syntax-object-expression2089 (lambda (x2781) (vector-ref x2781 1))) (syntax-object?2088 (lambda (x2782) (if (vector? x2782) (if (= (vector-length x2782) 4) (eq? (vector-ref x2782 0) (quote syntax-object)) #f) #f))) (make-syntax-object2087 (lambda (expression2783 wrap2784 module2785) (vector (quote syntax-object) expression2783 wrap2784 module2785))) (build-letrec2086 (lambda (src2786 ids2787 vars2788 val-exps2789 body-exp2790) (if (null? vars2788) body-exp2790 (let ((atom-key2791 (fluid-ref *mode*2062))) (if (memv atom-key2791 (quote (c))) ((@ (language tree-il) make-letrec) src2786 ids2787 vars2788 val-exps2789 body-exp2790) (list (quote letrec) (map list vars2788 val-exps2789) body-exp2790)))))) (build-named-let2085 (lambda (src2792 ids2793 vars2794 val-exps2795 body-exp2796) (let ((f2797 (car vars2794)) (f-name2798 (car ids2793)) (vars2799 (cdr vars2794)) (ids2800 (cdr ids2793))) (let ((atom-key2801 (fluid-ref *mode*2062))) (if (memv atom-key2801 (quote (c))) ((@ (language tree-il) make-letrec) src2792 (list f-name2798) (list f2797) (list (build-lambda2080 src2792 ids2800 vars2799 #f body-exp2796)) (build-application2072 src2792 (build-lexical-reference2074 (quote fun) src2792 f-name2798 f2797) val-exps2795)) (list (quote let) f2797 (map list vars2799 val-exps2795) body-exp2796)))))) (build-let2084 (lambda (src2802 ids2803 vars2804 val-exps2805 body-exp2806) (if (null? vars2804) body-exp2806 (let ((atom-key2807 (fluid-ref *mode*2062))) (if (memv atom-key2807 (quote (c))) ((@ (language tree-il) make-let) src2802 ids2803 vars2804 val-exps2805 body-exp2806) (list (quote let) (map list vars2804 val-exps2805) body-exp2806)))))) (build-sequence2083 (lambda (src2808 exps2809) (if (null? (cdr exps2809)) (car exps2809) (let ((atom-key2810 (fluid-ref *mode*2062))) (if (memv atom-key2810 (quote (c))) ((@ (language tree-il) make-sequence) src2808 exps2809) (cons (quote begin) exps2809)))))) (build-data2082 (lambda (src2811 exp2812) (let ((atom-key2813 (fluid-ref *mode*2062))) (if (memv atom-key2813 (quote (c))) ((@ (language tree-il) make-const) src2811 exp2812) (if (if (self-evaluating? exp2812) (not (vector? exp2812)) #f) exp2812 (list (quote quote) exp2812)))))) (build-primref2081 (lambda (src2814 name2815) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2816 (fluid-ref *mode*2062))) (if (memv atom-key2816 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2814 name2815) name2815)) (let ((atom-key2817 (fluid-ref *mode*2062))) (if (memv atom-key2817 (quote (c))) ((@ (language tree-il) make-module-ref) src2814 (quote (guile)) name2815 #f) (list (quote @@) (quote (guile)) name2815)))))) (build-lambda2080 (lambda (src2818 ids2819 vars2820 docstring2821 exp2822) (let ((atom-key2823 (fluid-ref *mode*2062))) (if (memv atom-key2823 (quote (c))) ((@ (language tree-il) make-lambda) src2818 ids2819 vars2820 (if docstring2821 (list (cons (quote documentation) docstring2821)) (quote ())) exp2822) (cons (quote lambda) (cons vars2820 (append (if docstring2821 (list docstring2821) (quote ())) (list exp2822)))))))) (build-global-definition2079 (lambda (source2824 var2825 exp2826) (let ((atom-key2827 (fluid-ref *mode*2062))) (if (memv atom-key2827 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2824 var2825 exp2826) (list (quote define) var2825 exp2826))))) (build-global-assignment2078 (lambda (source2828 var2829 exp2830 mod2831) (analyze-variable2076 mod2831 var2829 (lambda (mod2832 var2833 public?2834) (let ((atom-key2835 (fluid-ref *mode*2062))) (if (memv atom-key2835 (quote (c))) ((@ (language tree-il) make-module-set) source2828 mod2832 var2833 public?2834 exp2830) (list (quote set!) (list (if public?2834 (quote @) (quote @@)) mod2832 var2833) exp2830)))) (lambda (var2836) (let ((atom-key2837 (fluid-ref *mode*2062))) (if (memv atom-key2837 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2828 var2836 exp2830) (list (quote set!) var2836 exp2830))))))) (build-global-reference2077 (lambda (source2838 var2839 mod2840) (analyze-variable2076 mod2840 var2839 (lambda (mod2841 var2842 public?2843) (let ((atom-key2844 (fluid-ref *mode*2062))) (if (memv atom-key2844 (quote (c))) ((@ (language tree-il) make-module-ref) source2838 mod2841 var2842 public?2843) (list (if public?2843 (quote @) (quote @@)) mod2841 var2842)))) (lambda (var2845) (let ((atom-key2846 (fluid-ref *mode*2062))) (if (memv atom-key2846 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2838 var2845) var2845)))))) (analyze-variable2076 (lambda (mod2847 var2848 modref-cont2849 bare-cont2850) (if (not mod2847) (bare-cont2850 var2848) (let ((kind2851 (car mod2847)) (mod2852 (cdr mod2847))) (if (memv kind2851 (quote (public))) (modref-cont2849 mod2852 var2848 #t) (if (memv kind2851 (quote (private))) (if (not (equal? mod2852 (module-name (current-module)))) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (if (memv kind2851 (quote (bare))) (bare-cont2850 var2848) (if (memv kind2851 (quote (hygiene))) (if (if (not (equal? mod2852 (module-name (current-module)))) (module-variable (resolve-module mod2852) var2848) #f) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (syntax-violation #f "bad module kind" var2848 mod2852))))))))) (build-lexical-assignment2075 (lambda (source2853 name2854 var2855 exp2856) (let ((atom-key2857 (fluid-ref *mode*2062))) (if (memv atom-key2857 (quote (c))) ((@ (language tree-il) make-lexical-set) source2853 name2854 var2855 exp2856) (list (quote set!) var2855 exp2856))))) (build-lexical-reference2074 (lambda (type2858 source2859 name2860 var2861) (let ((atom-key2862 (fluid-ref *mode*2062))) (if (memv atom-key2862 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2859 name2860 var2861) var2861)))) (build-conditional2073 (lambda (source2863 test-exp2864 then-exp2865 else-exp2866) (let ((atom-key2867 (fluid-ref *mode*2062))) (if (memv atom-key2867 (quote (c))) ((@ (language tree-il) make-conditional) source2863 test-exp2864 then-exp2865 else-exp2866) (list (quote if) test-exp2864 then-exp2865 else-exp2866))))) (build-application2072 (lambda (source2868 fun-exp2869 arg-exps2870) (let ((atom-key2871 (fluid-ref *mode*2062))) (if (memv atom-key2871 (quote (c))) ((@ (language tree-il) make-application) source2868 fun-exp2869 arg-exps2870) (cons fun-exp2869 arg-exps2870))))) (build-void2071 (lambda (source2872) (let ((atom-key2873 (fluid-ref *mode*2062))) (if (memv atom-key2873 (quote (c))) ((@ (language tree-il) make-void) source2872) (quote (if #f #f)))))) (get-global-definition-hook2070 (lambda (symbol2874 module2875) (begin (if (if (not module2875) (current-module) #f) (warn "module system is booted, we should have a module" symbol2874) (if #f #f)) (let ((v2876 (module-variable (if module2875 (resolve-module (cdr module2875)) (current-module)) symbol2874))) (if v2876 (if (variable-bound? v2876) (let ((val2877 (variable-ref v2876))) (if (macro? val2877) (if (syncase-macro-type val2877) (cons (syncase-macro-type val2877) (syncase-macro-binding val2877)) #f) #f)) #f) #f))))) (put-global-definition-hook2069 (lambda (symbol2878 type2879 val2880) (let ((existing2881 (let ((v2882 (module-variable (current-module) symbol2878))) (if v2882 (if (variable-bound? v2882) (let ((val2883 (variable-ref v2882))) (if (macro? val2883) (if (not (syncase-macro-type val2883)) val2883 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2878 (if existing2881 (make-extended-syncase-macro existing2881 type2879 val2880) (make-syncase-macro type2879 val2880)))))) (local-eval-hook2068 (lambda (x2884 mod2885) (primitive-eval (list noexpand2061 (let ((atom-key2886 (fluid-ref *mode*2062))) (if (memv atom-key2886 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2884) x2884)))))) (top-level-eval-hook2067 (lambda (x2887 mod2888) (primitive-eval (list noexpand2061 (let ((atom-key2889 (fluid-ref *mode*2062))) (if (memv atom-key2889 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2887) x2887)))))) (fx<2066 <) (fx=2065 =) (fx-2064 -) (fx+2063 +) (*mode*2062 (make-fluid)) (noexpand2061 "noexpand")) (begin (global-extend2102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend2102 (quote local-syntax) (quote let-syntax) #f) (global-extend2102 (quote core) (quote fluid-let-syntax) (lambda (e2890 r2891 w2892 s2893 mod2894) ((lambda (tmp2895) ((lambda (tmp2896) (if (if tmp2896 (apply (lambda (_2897 var2898 val2899 e12900 e22901) (valid-bound-ids?2129 var2898)) tmp2896) #f) (apply (lambda (_2903 var2904 val2905 e12906 e22907) (let ((names2908 (map (lambda (x2909) (id-var-name2126 x2909 w2892)) var2904))) (begin (for-each (lambda (id2911 n2912) (let ((atom-key2913 (binding-type2096 (lookup2101 n2912 r2891 mod2894)))) (if (memv atom-key2913 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2890 (source-wrap2133 id2911 w2892 s2893 mod2894)) (if #f #f)))) var2904 names2908) (chi-body2144 (cons e12906 e22907) (source-wrap2133 e2890 w2892 s2893 mod2894) (extend-env2098 names2908 (let ((trans-r2916 (macros-only-env2100 r2891))) (map (lambda (x2917) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2917 trans-r2916 w2892 mod2894) mod2894))) val2905)) r2891) w2892 mod2894)))) tmp2896) ((lambda (_2919) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap2133 e2890 w2892 s2893 mod2894))) tmp2895))) ($sc-dispatch tmp2895 (quote (any #(each (any any)) any . each-any))))) e2890))) (global-extend2102 (quote core) (quote quote) (lambda (e2920 r2921 w2922 s2923 mod2924) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 e2928) (build-data2082 s2923 (strip2151 e2928 w2922))) tmp2926) ((lambda (_2929) (syntax-violation (quote quote) "bad syntax" (source-wrap2133 e2920 w2922 s2923 mod2924))) tmp2925))) ($sc-dispatch tmp2925 (quote (any any))))) e2920))) (global-extend2102 (quote core) (quote syntax) (letrec ((regen2937 (lambda (x2938) (let ((atom-key2939 (car x2938))) (if (memv atom-key2939 (quote (ref))) (build-lexical-reference2074 (quote value) #f (cadr x2938) (cadr x2938)) (if (memv atom-key2939 (quote (primitive))) (build-primref2081 #f (cadr x2938)) (if (memv atom-key2939 (quote (quote))) (build-data2082 #f (cadr x2938)) (if (memv atom-key2939 (quote (lambda))) (build-lambda2080 #f (cadr x2938) (cadr x2938) #f (regen2937 (caddr x2938))) (if (memv atom-key2939 (quote (map))) (let ((ls2940 (map regen2937 (cdr x2938)))) (build-application2072 #f (build-primref2081 #f (quote map)) ls2940)) (build-application2072 #f (build-primref2081 #f (car x2938)) (map regen2937 (cdr x2938))))))))))) (gen-vector2936 (lambda (x2941) (if (eq? (car x2941) (quote list)) (cons (quote vector) (cdr x2941)) (if (eq? (car x2941) (quote quote)) (list (quote quote) (list->vector (cadr x2941))) (list (quote list->vector) x2941))))) (gen-append2935 (lambda (x2942 y2943) (if (equal? y2943 (quote (quote ()))) x2942 (list (quote append) x2942 y2943)))) (gen-cons2934 (lambda (x2944 y2945) (let ((atom-key2946 (car y2945))) (if (memv atom-key2946 (quote (quote))) (if (eq? (car x2944) (quote quote)) (list (quote quote) (cons (cadr x2944) (cadr y2945))) (if (eq? (cadr y2945) (quote ())) (list (quote list) x2944) (list (quote cons) x2944 y2945))) (if (memv atom-key2946 (quote (list))) (cons (quote list) (cons x2944 (cdr y2945))) (list (quote cons) x2944 y2945)))))) (gen-map2933 (lambda (e2947 map-env2948) (let ((formals2949 (map cdr map-env2948)) (actuals2950 (map (lambda (x2951) (list (quote ref) (car x2951))) map-env2948))) (if (eq? (car e2947) (quote ref)) (car actuals2950) (if (and-map (lambda (x2952) (if (eq? (car x2952) (quote ref)) (memq (cadr x2952) formals2949) #f)) (cdr e2947)) (cons (quote map) (cons (list (quote primitive) (car e2947)) (map (let ((r2953 (map cons formals2949 actuals2950))) (lambda (x2954) (cdr (assq (cadr x2954) r2953)))) (cdr e2947)))) (cons (quote map) (cons (list (quote lambda) formals2949 e2947) actuals2950))))))) (gen-mappend2932 (lambda (e2955 map-env2956) (list (quote apply) (quote (primitive append)) (gen-map2933 e2955 map-env2956)))) (gen-ref2931 (lambda (src2957 var2958 level2959 maps2960) (if (fx=2065 level2959 0) (values var2958 maps2960) (if (null? maps2960) (syntax-violation (quote syntax) "missing ellipsis" src2957) (call-with-values (lambda () (gen-ref2931 src2957 var2958 (fx-2064 level2959 1) (cdr maps2960))) (lambda (outer-var2961 outer-maps2962) (let ((b2963 (assq outer-var2961 (car maps2960)))) (if b2963 (values (cdr b2963) maps2960) (let ((inner-var2964 (gen-var2152 (quote tmp)))) (values inner-var2964 (cons (cons (cons outer-var2961 inner-var2964) (car maps2960)) outer-maps2962))))))))))) (gen-syntax2930 (lambda (src2965 e2966 r2967 maps2968 ellipsis?2969 mod2970) (if (id?2104 e2966) (let ((label2971 (id-var-name2126 e2966 (quote (()))))) (let ((b2972 (lookup2101 label2971 r2967 mod2970))) (if (eq? (binding-type2096 b2972) (quote syntax)) (call-with-values (lambda () (let ((var.lev2973 (binding-value2097 b2972))) (gen-ref2931 src2965 (car var.lev2973) (cdr var.lev2973) maps2968))) (lambda (var2974 maps2975) (values (list (quote ref) var2974) maps2975))) (if (ellipsis?2969 e2966) (syntax-violation (quote syntax) "misplaced ellipsis" src2965) (values (list (quote quote) e2966) maps2968))))) ((lambda (tmp2976) ((lambda (tmp2977) (if (if tmp2977 (apply (lambda (dots2978 e2979) (ellipsis?2969 dots2978)) tmp2977) #f) (apply (lambda (dots2980 e2981) (gen-syntax2930 src2965 e2981 r2967 maps2968 (lambda (x2982) #f) mod2970)) tmp2977) ((lambda (tmp2983) (if (if tmp2983 (apply (lambda (x2984 dots2985 y2986) (ellipsis?2969 dots2985)) tmp2983) #f) (apply (lambda (x2987 dots2988 y2989) (letrec ((f2990 (lambda (y2991 k2992) ((lambda (tmp2996) ((lambda (tmp2997) (if (if tmp2997 (apply (lambda (dots2998 y2999) (ellipsis?2969 dots2998)) tmp2997) #f) (apply (lambda (dots3000 y3001) (f2990 y3001 (lambda (maps3002) (call-with-values (lambda () (k2992 (cons (quote ()) maps3002))) (lambda (x3003 maps3004) (if (null? (car maps3004)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-mappend2932 x3003 (car maps3004)) (cdr maps3004)))))))) tmp2997) ((lambda (_3005) (call-with-values (lambda () (gen-syntax2930 src2965 y2991 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (y3006 maps3007) (call-with-values (lambda () (k2992 maps3007)) (lambda (x3008 maps3009) (values (gen-append2935 x3008 y3006) maps3009)))))) tmp2996))) ($sc-dispatch tmp2996 (quote (any . any))))) y2991)))) (f2990 y2989 (lambda (maps2993) (call-with-values (lambda () (gen-syntax2930 src2965 x2987 r2967 (cons (quote ()) maps2993) ellipsis?2969 mod2970)) (lambda (x2994 maps2995) (if (null? (car maps2995)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-map2933 x2994 (car maps2995)) (cdr maps2995))))))))) tmp2983) ((lambda (tmp3010) (if tmp3010 (apply (lambda (x3011 y3012) (call-with-values (lambda () (gen-syntax2930 src2965 x3011 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (x3013 maps3014) (call-with-values (lambda () (gen-syntax2930 src2965 y3012 r2967 maps3014 ellipsis?2969 mod2970)) (lambda (y3015 maps3016) (values (gen-cons2934 x3013 y3015) maps3016)))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (e13018 e23019) (call-with-values (lambda () (gen-syntax2930 src2965 (cons e13018 e23019) r2967 maps2968 ellipsis?2969 mod2970)) (lambda (e3021 maps3022) (values (gen-vector2936 e3021) maps3022)))) tmp3017) ((lambda (_3023) (values (list (quote quote) e2966) maps2968)) tmp2976))) ($sc-dispatch tmp2976 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2976 (quote (any . any)))))) ($sc-dispatch tmp2976 (quote (any any . any)))))) ($sc-dispatch tmp2976 (quote (any any))))) e2966))))) (lambda (e3024 r3025 w3026 s3027 mod3028) (let ((e3029 (source-wrap2133 e3024 w3026 s3027 mod3028))) ((lambda (tmp3030) ((lambda (tmp3031) (if tmp3031 (apply (lambda (_3032 x3033) (call-with-values (lambda () (gen-syntax2930 e3029 x3033 r3025 (quote ()) ellipsis?2149 mod3028)) (lambda (e3034 maps3035) (regen2937 e3034)))) tmp3031) ((lambda (_3036) (syntax-violation (quote syntax) "bad `syntax' form" e3029)) tmp3030))) ($sc-dispatch tmp3030 (quote (any any))))) e3029))))) (global-extend2102 (quote core) (quote lambda) (lambda (e3037 r3038 w3039 s3040 mod3041) ((lambda (tmp3042) ((lambda (tmp3043) (if tmp3043 (apply (lambda (_3044 c3045) (chi-lambda-clause2145 (source-wrap2133 e3037 w3039 s3040 mod3041) #f c3045 r3038 w3039 mod3041 (lambda (names3046 vars3047 docstring3048 body3049) (build-lambda2080 s3040 names3046 vars3047 docstring3048 body3049)))) tmp3043) (syntax-violation #f "source expression failed to match any pattern" tmp3042))) ($sc-dispatch tmp3042 (quote (any . any))))) e3037))) (global-extend2102 (quote core) (quote let) (letrec ((chi-let3050 (lambda (e3051 r3052 w3053 s3054 mod3055 constructor3056 ids3057 vals3058 exps3059) (if (not (valid-bound-ids?2129 ids3057)) (syntax-violation (quote let) "duplicate bound variable" e3051) (let ((labels3060 (gen-labels2110 ids3057)) (new-vars3061 (map gen-var2152 ids3057))) (let ((nw3062 (make-binding-wrap2121 ids3057 labels3060 w3053)) (nr3063 (extend-var-env2099 labels3060 new-vars3061 r3052))) (constructor3056 s3054 (map syntax->datum ids3057) new-vars3061 (map (lambda (x3064) (chi2140 x3064 r3052 w3053 mod3055)) vals3058) (chi-body2144 exps3059 (source-wrap2133 e3051 nw3062 s3054 mod3055) nr3063 nw3062 mod3055)))))))) (lambda (e3065 r3066 w3067 s3068 mod3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (_3072 id3073 val3074 e13075 e23076) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-let2084 id3073 val3074 (cons e13075 e23076))) tmp3071) ((lambda (tmp3080) (if (if tmp3080 (apply (lambda (_3081 f3082 id3083 val3084 e13085 e23086) (id?2104 f3082)) tmp3080) #f) (apply (lambda (_3087 f3088 id3089 val3090 e13091 e23092) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-named-let2085 (cons f3088 id3089) val3090 (cons e13091 e23092))) tmp3080) ((lambda (_3096) (syntax-violation (quote let) "bad let" (source-wrap2133 e3065 w3067 s3068 mod3069))) tmp3070))) ($sc-dispatch tmp3070 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3070 (quote (any #(each (any any)) any . each-any))))) e3065)))) (global-extend2102 (quote core) (quote letrec) (lambda (e3097 r3098 w3099 s3100 mod3101) ((lambda (tmp3102) ((lambda (tmp3103) (if tmp3103 (apply (lambda (_3104 id3105 val3106 e13107 e23108) (let ((ids3109 id3105)) (if (not (valid-bound-ids?2129 ids3109)) (syntax-violation (quote letrec) "duplicate bound variable" e3097) (let ((labels3111 (gen-labels2110 ids3109)) (new-vars3112 (map gen-var2152 ids3109))) (let ((w3113 (make-binding-wrap2121 ids3109 labels3111 w3099)) (r3114 (extend-var-env2099 labels3111 new-vars3112 r3098))) (build-letrec2086 s3100 (map syntax->datum ids3109) new-vars3112 (map (lambda (x3115) (chi2140 x3115 r3114 w3113 mod3101)) val3106) (chi-body2144 (cons e13107 e23108) (source-wrap2133 e3097 w3113 s3100 mod3101) r3114 w3113 mod3101))))))) tmp3103) ((lambda (_3118) (syntax-violation (quote letrec) "bad letrec" (source-wrap2133 e3097 w3099 s3100 mod3101))) tmp3102))) ($sc-dispatch tmp3102 (quote (any #(each (any any)) any . each-any))))) e3097))) (global-extend2102 (quote core) (quote set!) (lambda (e3119 r3120 w3121 s3122 mod3123) ((lambda (tmp3124) ((lambda (tmp3125) (if (if tmp3125 (apply (lambda (_3126 id3127 val3128) (id?2104 id3127)) tmp3125) #f) (apply (lambda (_3129 id3130 val3131) (let ((val3132 (chi2140 val3131 r3120 w3121 mod3123)) (n3133 (id-var-name2126 id3130 w3121))) (let ((b3134 (lookup2101 n3133 r3120 mod3123))) (let ((atom-key3135 (binding-type2096 b3134))) (if (memv atom-key3135 (quote (lexical))) (build-lexical-assignment2075 s3122 (syntax->datum id3130) (binding-value2097 b3134) val3132) (if (memv atom-key3135 (quote (global))) (build-global-assignment2078 s3122 n3133 val3132 mod3123) (if (memv atom-key3135 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap2132 id3130 w3121 mod3123)) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))))))))) tmp3125) ((lambda (tmp3136) (if tmp3136 (apply (lambda (_3137 head3138 tail3139 val3140) (call-with-values (lambda () (syntax-type2138 head3138 r3120 (quote (())) #f #f mod3123)) (lambda (type3141 value3142 ee3143 ww3144 ss3145 modmod3146) (if (memv type3141 (quote (module-ref))) (let ((val3147 (chi2140 val3140 r3120 w3121 mod3123))) (call-with-values (lambda () (value3142 (cons head3138 tail3139))) (lambda (id3149 mod3150) (build-global-assignment2078 s3122 id3149 val3147 mod3150)))) (build-application2072 s3122 (chi2140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head3138) r3120 w3121 mod3123) (map (lambda (e3151) (chi2140 e3151 r3120 w3121 mod3123)) (append tail3139 (list val3140)))))))) tmp3136) ((lambda (_3153) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))) tmp3124))) ($sc-dispatch tmp3124 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp3124 (quote (any any any))))) e3119))) (global-extend2102 (quote module-ref) (quote @) (lambda (e3154) ((lambda (tmp3155) ((lambda (tmp3156) (if (if tmp3156 (apply (lambda (_3157 mod3158 id3159) (if (and-map id?2104 mod3158) (id?2104 id3159) #f)) tmp3156) #f) (apply (lambda (_3161 mod3162 id3163) (values (syntax->datum id3163) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3162)))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any each-any any))))) e3154))) (global-extend2102 (quote module-ref) (quote @@) (lambda (e3165) ((lambda (tmp3166) ((lambda (tmp3167) (if (if tmp3167 (apply (lambda (_3168 mod3169 id3170) (if (and-map id?2104 mod3169) (id?2104 id3170) #f)) tmp3167) #f) (apply (lambda (_3172 mod3173 id3174) (values (syntax->datum id3174) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3173)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any each-any any))))) e3165))) (global-extend2102 (quote core) (quote if) (lambda (e3176 r3177 w3178 s3179 mod3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 test3184 then3185) (build-conditional2073 s3179 (chi2140 test3184 r3177 w3178 mod3180) (chi2140 then3185 r3177 w3178 mod3180) (build-void2071 #f))) tmp3182) ((lambda (tmp3186) (if tmp3186 (apply (lambda (_3187 test3188 then3189 else3190) (build-conditional2073 s3179 (chi2140 test3188 r3177 w3178 mod3180) (chi2140 then3189 r3177 w3178 mod3180) (chi2140 else3190 r3177 w3178 mod3180))) tmp3186) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any any any)))))) ($sc-dispatch tmp3181 (quote (any any any))))) e3176))) (global-extend2102 (quote begin) (quote begin) (quote ())) (global-extend2102 (quote define) (quote define) (quote ())) (global-extend2102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend2102 (quote eval-when) (quote eval-when) (quote ())) (global-extend2102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case3194 (lambda (x3195 keys3196 clauses3197 r3198 mod3199) (if (null? clauses3197) (build-application2072 #f (build-primref2081 #f (quote syntax-violation)) (list (build-data2082 #f #f) (build-data2082 #f "source expression failed to match any pattern") x3195)) ((lambda (tmp3200) ((lambda (tmp3201) (if tmp3201 (apply (lambda (pat3202 exp3203) (if (if (id?2104 pat3202) (and-map (lambda (x3204) (not (free-id=?2127 pat3202 x3204))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys3196)) #f) (let ((labels3205 (list (gen-label2109))) (var3206 (gen-var2152 pat3202))) (build-application2072 #f (build-lambda2080 #f (list (syntax->datum pat3202)) (list var3206) #f (chi2140 exp3203 (extend-env2098 labels3205 (list (cons (quote syntax) (cons var3206 0))) r3198) (make-binding-wrap2121 (list pat3202) labels3205 (quote (()))) mod3199)) (list x3195))) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3202 #t exp3203 mod3199))) tmp3201) ((lambda (tmp3207) (if tmp3207 (apply (lambda (pat3208 fender3209 exp3210) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3208 fender3209 exp3210 mod3199)) tmp3207) ((lambda (_3211) (syntax-violation (quote syntax-case) "invalid clause" (car clauses3197))) tmp3200))) ($sc-dispatch tmp3200 (quote (any any any)))))) ($sc-dispatch tmp3200 (quote (any any))))) (car clauses3197))))) (gen-clause3193 (lambda (x3212 keys3213 clauses3214 r3215 pat3216 fender3217 exp3218 mod3219) (call-with-values (lambda () (convert-pattern3191 pat3216 keys3213)) (lambda (p3220 pvars3221) (if (not (distinct-bound-ids?2130 (map car pvars3221))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat3216) (if (not (and-map (lambda (x3222) (not (ellipsis?2149 (car x3222)))) pvars3221)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat3216) (let ((y3223 (gen-var2152 (quote tmp)))) (build-application2072 #f (build-lambda2080 #f (list (quote tmp)) (list y3223) #f (let ((y3224 (build-lexical-reference2074 (quote value) #f (quote tmp) y3223))) (build-conditional2073 #f ((lambda (tmp3225) ((lambda (tmp3226) (if tmp3226 (apply (lambda () y3224) tmp3226) ((lambda (_3227) (build-conditional2073 #f y3224 (build-dispatch-call3192 pvars3221 fender3217 y3224 r3215 mod3219) (build-data2082 #f #f))) tmp3225))) ($sc-dispatch tmp3225 (quote #(atom #t))))) fender3217) (build-dispatch-call3192 pvars3221 exp3218 y3224 r3215 mod3219) (gen-syntax-case3194 x3212 keys3213 clauses3214 r3215 mod3219)))) (list (if (eq? p3220 (quote any)) (build-application2072 #f (build-primref2081 #f (quote list)) (list x3212)) (build-application2072 #f (build-primref2081 #f (quote $sc-dispatch)) (list x3212 (build-data2082 #f p3220))))))))))))) (build-dispatch-call3192 (lambda (pvars3228 exp3229 y3230 r3231 mod3232) (let ((ids3233 (map car pvars3228)) (levels3234 (map cdr pvars3228))) (let ((labels3235 (gen-labels2110 ids3233)) (new-vars3236 (map gen-var2152 ids3233))) (build-application2072 #f (build-primref2081 #f (quote apply)) (list (build-lambda2080 #f (map syntax->datum ids3233) new-vars3236 #f (chi2140 exp3229 (extend-env2098 labels3235 (map (lambda (var3237 level3238) (cons (quote syntax) (cons var3237 level3238))) new-vars3236 (map cdr pvars3228)) r3231) (make-binding-wrap2121 ids3233 labels3235 (quote (()))) mod3232)) y3230)))))) (convert-pattern3191 (lambda (pattern3239 keys3240) (letrec ((cvt3241 (lambda (p3242 n3243 ids3244) (if (id?2104 p3242) (if (bound-id-member?2131 p3242 keys3240) (values (vector (quote free-id) p3242) ids3244) (values (quote any) (cons (cons p3242 n3243) ids3244))) ((lambda (tmp3245) ((lambda (tmp3246) (if (if tmp3246 (apply (lambda (x3247 dots3248) (ellipsis?2149 dots3248)) tmp3246) #f) (apply (lambda (x3249 dots3250) (call-with-values (lambda () (cvt3241 x3249 (fx+2063 n3243 1) ids3244)) (lambda (p3251 ids3252) (values (if (eq? p3251 (quote any)) (quote each-any) (vector (quote each) p3251)) ids3252)))) tmp3246) ((lambda (tmp3253) (if tmp3253 (apply (lambda (x3254 y3255) (call-with-values (lambda () (cvt3241 y3255 n3243 ids3244)) (lambda (y3256 ids3257) (call-with-values (lambda () (cvt3241 x3254 n3243 ids3257)) (lambda (x3258 ids3259) (values (cons x3258 y3256) ids3259)))))) tmp3253) ((lambda (tmp3260) (if tmp3260 (apply (lambda () (values (quote ()) ids3244)) tmp3260) ((lambda (tmp3261) (if tmp3261 (apply (lambda (x3262) (call-with-values (lambda () (cvt3241 x3262 n3243 ids3244)) (lambda (p3264 ids3265) (values (vector (quote vector) p3264) ids3265)))) tmp3261) ((lambda (x3266) (values (vector (quote atom) (strip2151 p3242 (quote (())))) ids3244)) tmp3245))) ($sc-dispatch tmp3245 (quote #(vector each-any)))))) ($sc-dispatch tmp3245 (quote ()))))) ($sc-dispatch tmp3245 (quote (any . any)))))) ($sc-dispatch tmp3245 (quote (any any))))) p3242))))) (cvt3241 pattern3239 0 (quote ())))))) (lambda (e3267 r3268 w3269 s3270 mod3271) (let ((e3272 (source-wrap2133 e3267 w3269 s3270 mod3271))) ((lambda (tmp3273) ((lambda (tmp3274) (if tmp3274 (apply (lambda (_3275 val3276 key3277 m3278) (if (and-map (lambda (x3279) (if (id?2104 x3279) (not (ellipsis?2149 x3279)) #f)) key3277) (let ((x3281 (gen-var2152 (quote tmp)))) (build-application2072 s3270 (build-lambda2080 #f (list (quote tmp)) (list x3281) #f (gen-syntax-case3194 (build-lexical-reference2074 (quote value) #f (quote tmp) x3281) key3277 m3278 r3268 mod3271)) (list (chi2140 val3276 r3268 (quote (())) mod3271)))) (syntax-violation (quote syntax-case) "invalid literals list" e3272))) tmp3274) (syntax-violation #f "source expression failed to match any pattern" tmp3273))) ($sc-dispatch tmp3273 (quote (any any each-any . each-any))))) e3272))))) (set! sc-expand (lambda (x3285 . rest3284) (if (if (pair? x3285) (equal? (car x3285) noexpand2061) #f) (cadr x3285) (let ((m3286 (if (null? rest3284) (quote e) (car rest3284))) (esew3287 (if (let ((t3288 (null? rest3284))) (if t3288 t3288 (null? (cdr rest3284)))) (quote (eval)) (cadr rest3284)))) (with-fluid* *mode*2062 m3286 (lambda () (chi-top2139 x3285 (quote ()) (quote ((top))) m3286 esew3287 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x3289) (nonsymbol-id?2103 x3289))) (set! datum->syntax (lambda (id3290 datum3291) (make-syntax-object2087 datum3291 (syntax-object-wrap2090 id3290) #f))) (set! syntax->datum (lambda (x3292) (strip2151 x3292 (quote (()))))) (set! generate-temporaries (lambda (ls3293) (begin (let ((x3294 ls3293)) (if (not (list? x3294)) (syntax-violation (quote generate-temporaries) "invalid argument" x3294) (if #f #f))) (map (lambda (x3295) (wrap2132 (gensym) (quote ((top))) #f)) ls3293)))) (set! free-identifier=? (lambda (x3296 y3297) (begin (let ((x3298 x3296)) (if (not (nonsymbol-id?2103 x3298)) (syntax-violation (quote free-identifier=?) "invalid argument" x3298) (if #f #f))) (let ((x3299 y3297)) (if (not (nonsymbol-id?2103 x3299)) (syntax-violation (quote free-identifier=?) "invalid argument" x3299) (if #f #f))) (free-id=?2127 x3296 y3297)))) (set! bound-identifier=? (lambda (x3300 y3301) (begin (let ((x3302 x3300)) (if (not (nonsymbol-id?2103 x3302)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3302) (if #f #f))) (let ((x3303 y3301)) (if (not (nonsymbol-id?2103 x3303)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3303) (if #f #f))) (bound-id=?2128 x3300 y3301)))) (set! syntax-violation (lambda (who3307 message3306 form3305 . subform3304) (begin (let ((x3308 who3307)) (if (not ((lambda (x3309) (let ((t3310 (not x3309))) (if t3310 t3310 (let ((t3311 (string? x3309))) (if t3311 t3311 (symbol? x3309)))))) x3308)) (syntax-violation (quote syntax-violation) "invalid argument" x3308) (if #f #f))) (let ((x3312 message3306)) (if (not (string? x3312)) (syntax-violation (quote syntax-violation) "invalid argument" x3312) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who3307 "~a: " "") "~a " (if (null? subform3304) "in ~a" "in subform `~s' of `~s'")) (let ((tail3313 (cons message3306 (map (lambda (x3314) (strip2151 x3314 (quote (())))) (append subform3304 (list form3305)))))) (if who3307 (cons who3307 tail3313) tail3313)) #f)))) (letrec ((match3319 (lambda (e3320 p3321 w3322 r3323 mod3324) (if (not r3323) #f (if (eq? p3321 (quote any)) (cons (wrap2132 e3320 w3322 mod3324) r3323) (if (syntax-object?2088 e3320) (match*3318 (let ((e3325 (syntax-object-expression2089 e3320))) (if (annotation? e3325) (annotation-expression e3325) e3325)) p3321 (join-wraps2123 w3322 (syntax-object-wrap2090 e3320)) r3323 (syntax-object-module2091 e3320)) (match*3318 (let ((e3326 e3320)) (if (annotation? e3326) (annotation-expression e3326) e3326)) p3321 w3322 r3323 mod3324)))))) (match*3318 (lambda (e3327 p3328 w3329 r3330 mod3331) (if (null? p3328) (if (null? e3327) r3330 #f) (if (pair? p3328) (if (pair? e3327) (match3319 (car e3327) (car p3328) w3329 (match3319 (cdr e3327) (cdr p3328) w3329 r3330 mod3331) mod3331) #f) (if (eq? p3328 (quote each-any)) (let ((l3332 (match-each-any3316 e3327 w3329 mod3331))) (if l3332 (cons l3332 r3330) #f)) (let ((atom-key3333 (vector-ref p3328 0))) (if (memv atom-key3333 (quote (each))) (if (null? e3327) (match-empty3317 (vector-ref p3328 1) r3330) (let ((l3334 (match-each3315 e3327 (vector-ref p3328 1) w3329 mod3331))) (if l3334 (letrec ((collect3335 (lambda (l3336) (if (null? (car l3336)) r3330 (cons (map car l3336) (collect3335 (map cdr l3336))))))) (collect3335 l3334)) #f))) (if (memv atom-key3333 (quote (free-id))) (if (id?2104 e3327) (if (free-id=?2127 (wrap2132 e3327 w3329 mod3331) (vector-ref p3328 1)) r3330 #f) #f) (if (memv atom-key3333 (quote (atom))) (if (equal? (vector-ref p3328 1) (strip2151 e3327 w3329)) r3330 #f) (if (memv atom-key3333 (quote (vector))) (if (vector? e3327) (match3319 (vector->list e3327) (vector-ref p3328 1) w3329 r3330 mod3331) #f) (if #f #f))))))))))) (match-empty3317 (lambda (p3337 r3338) (if (null? p3337) r3338 (if (eq? p3337 (quote any)) (cons (quote ()) r3338) (if (pair? p3337) (match-empty3317 (car p3337) (match-empty3317 (cdr p3337) r3338)) (if (eq? p3337 (quote each-any)) (cons (quote ()) r3338) (let ((atom-key3339 (vector-ref p3337 0))) (if (memv atom-key3339 (quote (each))) (match-empty3317 (vector-ref p3337 1) r3338) (if (memv atom-key3339 (quote (free-id atom))) r3338 (if (memv atom-key3339 (quote (vector))) (match-empty3317 (vector-ref p3337 1) r3338) (if #f #f))))))))))) (match-each-any3316 (lambda (e3340 w3341 mod3342) (if (annotation? e3340) (match-each-any3316 (annotation-expression e3340) w3341 mod3342) (if (pair? e3340) (let ((l3343 (match-each-any3316 (cdr e3340) w3341 mod3342))) (if l3343 (cons (wrap2132 (car e3340) w3341 mod3342) l3343) #f)) (if (null? e3340) (quote ()) (if (syntax-object?2088 e3340) (match-each-any3316 (syntax-object-expression2089 e3340) (join-wraps2123 w3341 (syntax-object-wrap2090 e3340)) mod3342) #f)))))) (match-each3315 (lambda (e3344 p3345 w3346 mod3347) (if (annotation? e3344) (match-each3315 (annotation-expression e3344) p3345 w3346 mod3347) (if (pair? e3344) (let ((first3348 (match3319 (car e3344) p3345 w3346 (quote ()) mod3347))) (if first3348 (let ((rest3349 (match-each3315 (cdr e3344) p3345 w3346 mod3347))) (if rest3349 (cons first3348 rest3349) #f)) #f)) (if (null? e3344) (quote ()) (if (syntax-object?2088 e3344) (match-each3315 (syntax-object-expression2089 e3344) p3345 (join-wraps2123 w3346 (syntax-object-wrap2090 e3344)) (syntax-object-module2091 e3344)) #f))))))) (set! $sc-dispatch (lambda (e3350 p3351) (if (eq? p3351 (quote any)) (list e3350) (if (syntax-object?2088 e3350) (match*3318 (let ((e3352 (syntax-object-expression2089 e3350))) (if (annotation? e3352) (annotation-expression e3352) e3352)) p3351 (syntax-object-wrap2090 e3350) (quote ()) (syntax-object-module2091 e3350)) (match*3318 (let ((e3353 e3350)) (if (annotation? e3353) (annotation-expression e3353) e3353)) p3351 (quote (())) (quote ()) #f))))))))) (define with-syntax (make-syncase-macro (quote macro) (lambda (x3354) ((lambda (tmp3355) ((lambda (tmp3356) (if tmp3356 (apply (lambda (_3357 e13358 e23359) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13358 e23359))) tmp3356) ((lambda (tmp3361) (if tmp3361 (apply (lambda (_3362 out3363 in3364 e13365 e23366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3364 (quote ()) (list out3363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13365 e23366))))) tmp3361) ((lambda (tmp3368) (if tmp3368 (apply (lambda (_3369 out3370 in3371 e13372 e23373) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3371) (quote ()) (list out3370 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13372 e23373))))) tmp3368) (syntax-violation #f "source expression failed to match any pattern" tmp3355))) ($sc-dispatch tmp3355 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any () any . each-any))))) x3354)))) (define syntax-rules (make-syncase-macro (quote macro) (lambda (x3377) ((lambda (tmp3378) ((lambda (tmp3379) (if tmp3379 (apply (lambda (_3380 k3381 keyword3382 pattern3383 template3384) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k3381 (map (lambda (tmp3387 tmp3386) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3386) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3387))) template3384 pattern3383)))))) tmp3379) (syntax-violation #f "source expression failed to match any pattern" tmp3378))) ($sc-dispatch tmp3378 (quote (any each-any . #(each ((any . any) any))))))) x3377)))) (define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3388) ((lambda (tmp3389) ((lambda (tmp3390) (if (if tmp3390 (apply (lambda (let*3391 x3392 v3393 e13394 e23395) (and-map identifier? x3392)) tmp3390) #f) (apply (lambda (let*3397 x3398 v3399 e13400 e23401) (letrec ((f3402 (lambda (bindings3403) (if (null? bindings3403) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e13400 e23401))) ((lambda (tmp3407) ((lambda (tmp3408) (if tmp3408 (apply (lambda (body3409 binding3410) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding3410) body3409)) tmp3408) (syntax-violation #f "source expression failed to match any pattern" tmp3407))) ($sc-dispatch tmp3407 (quote (any any))))) (list (f3402 (cdr bindings3403)) (car bindings3403))))))) (f3402 (map list x3398 v3399)))) tmp3390) (syntax-violation #f "source expression failed to match any pattern" tmp3389))) ($sc-dispatch tmp3389 (quote (any #(each (any any)) any . each-any))))) x3388)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 1ad1ba60e..bc3937cc8 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -961,7 +961,10 @@ (list (build-application no-source (build-primref no-source 'module-ref) - (list (build-application no-source 'current-module '()) + (list (build-application + no-source + (build-primref no-source 'current-module) + '()) (build-data no-source name))) (build-data no-source 'macro) e)) @@ -2020,7 +2023,10 @@ (if (null? clauses) (build-application no-source (build-primref no-source 'syntax-violation) - (list #f "source expression failed to match any pattern" x)) + (list (build-data no-source #f) + (build-data no-source + "source expression failed to match any pattern") + x)) (syntax-case (car clauses) () ((pat exp) (if (and (id? (syntax pat)) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index e6b7d3bd3..4564fb933 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -47,10 +47,8 @@ #:version "0.5" #:reader read #:read-file read-file - #:compilers `( - (tree-il . ,compile-tree-il) - (ghil . ,compile-ghil) - ) + #:compilers `((tree-il . ,compile-tree-il) + (ghil . ,compile-ghil)) #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index f69c91b86..78e2d1e94 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -245,7 +245,7 @@ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-current-continuation) - (= (length args 1))) + (= (length args) 1)) (comp-push (car args)) (case context ((tail) (emit-code src (make-glil-call 'goto/cc 1))) From 5af166bda2f1d89525add147a9e3d2d6867d03a5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 12:46:23 +0200 Subject: [PATCH 113/375] don't allocate too many locals for expansions of `or' * module/language/tree-il/analyze.scm (analyze-lexicals): Add in a hack to avoid allocating more locals than necessary for expansions of `or'. Documented in the source. * test-suite/tests/tree-il.test: Add a test case. --- module/language/tree-il/analyze.scm | 56 +++++++++++++++++++++++------ test-suite/tests/tree-il.test | 37 +++++++++++++++++++ 2 files changed, 82 insertions(+), 11 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 55ca102f0..477f1fc2d 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -34,6 +34,21 @@ ;; (let (2 3 4) ...)) ;; etc. ;; +;; This algorithm has the problem that variables are only allocated +;; indices at the end of the binding path. If variables bound early in +;; the path are not used in later portions of the path, their indices +;; will not be recycled. This problem is particularly egregious in the +;; expansion of `or': +;; +;; (or x y z) +;; -> (let ((a x)) (if a a (let ((b y)) (if b b z)))) +;; +;; As you can see, the `a' binding is only used in the ephemeral `then' +;; clause of the first `if', but its index would be reserved for the +;; whole of the `or' expansion. So we have a hack for this specific +;; case. A proper solution would be some sort of liveness analysis, and +;; not our linear allocation algorithm. +;; ;; allocation: ;; sym -> (local . index) | (heap level . index) ;; lambda -> (nlocs . nexts) @@ -48,6 +63,8 @@ ;; when looking for closed-over vars. ;; heaps: sym -> lambda ;; allows us to heapify vars in an O(1) fashion + ;; refcounts: sym -> count + ;; allows us to detect the or-expansion an O(1) time (define (find-heap sym parent) ;; fixme: check displaced lexicals here? @@ -66,6 +83,7 @@ (step test) (step then) (step else)) (( name gensym) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) (if (and (not (memq gensym (hashq-ref bindings parent))) (not (hashq-ref heaps gensym))) (hashq-set! heaps gensym (find-heap gensym parent)))) @@ -158,17 +176,32 @@ (( vars vals exp) (let ((nmax (apply max (map recur vals)))) - (let lp ((vars vars) (n n)) - (if (null? vars) - (max nmax (allocate! exp level n)) - (let ((v (car vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n))) - (lp (cdr vars) (if binder n (1+ n))))))))) + (cond + ;; the `or' hack + ((and (conditional? exp) + (= (length vars) 1) + (let ((v (car vars))) + (and (not (hashq-ref heaps v)) + (= (hashq-ref refcounts v 0) 2) + (lexical-ref? (conditional-test exp)) + (eq? (lexical-ref-gensym (conditional-test exp)) v) + (lexical-ref? (conditional-then exp)) + (eq? (lexical-ref-gensym (conditional-then exp)) v)))) + (hashq-set! allocation (car vars) (cons 'stack n)) + ;; the 1+ for this var + (max nmax (1+ n) (allocate! (conditional-else exp) level n))) + (else + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! exp level n)) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n))) + (lp (cdr vars) (if binder n (1+ n))))))))))) (( vars vals exp) (let lp ((vars vars) (n n)) @@ -192,6 +225,7 @@ (define parents (make-hash-table)) (define bindings (make-hash-table)) (define heaps (make-hash-table)) + (define refcounts (make-hash-table)) (define allocation (make-hash-table)) (define heap-indexes (make-hash-table)) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 3150392ae..873051f03 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -376,3 +376,40 @@ (apply (primitive null?) (begin (const #f) (const 2))) (program 0 0 0 0 () (const 2) (call null? 1) (call return 1)))) + +;; FIXME: binding info for or-hacked locals might bork the disassembler, +;; and could be tightened in any case +(with-test-prefix "the or hack" + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical a b)))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (branch br-if-not ,l1) + (local ref 0) (call return 1) + (label ,l2) + (const 2) (bind (a local 0)) (local set 0) + (local ref 0) (call return 1) + (unbind) + (unbind)) + (eq? l1 l2)) + + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical x y)))) + (program 0 0 2 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (branch br-if-not ,l1) + (local ref 0) (call return 1) + (label ,l2) + (const 2) (bind (a local 1)) (local set 1) + (local ref 0) (call return 1) + (unbind) + (unbind)) + (eq? l1 l2))) From c11f46afe113f50e34af33ad3055b3da66e4b71f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 13:33:44 +0200 Subject: [PATCH 114/375] compile `list' and `vector' to their associated opcodes * module/language/glil/compile-assembly.scm (glil->assembly): Check the length when emitting calls to variable-argument stack instructions. Allow two-byte lengths -- allows e.g. calls to `list' with more than 256 arguments. * module/language/tree-il/compile-glil.scm: Add primcall associations for `list' and `vector', with any number of arguments. Necessary because syncase's quasiquote expansions will produce calls to `list' with many arguments. * module/language/tree-il/optimize.scm (*interesting-primitive-names*): Add `list' and `vector' to the set of primitives to resolve. --- module/language/glil/compile-assembly.scm | 7 ++++++- module/language/tree-il/compile-glil.scm | 9 ++++++--- module/language/tree-il/optimize.scm | 2 ++ 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 73b2cd132..4c92e0f5a 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -312,7 +312,12 @@ (error "Unknown instruction:" inst)) (let ((pops (instruction-pops inst))) (cond ((< pops 0) - (emit-code `((,inst ,nargs)))) + (case (instruction-length inst) + ((1) (emit-code `((,inst ,nargs)))) + ((2) (emit-code `((,inst ,(quotient nargs 256) + ,(modulo nargs 256))))) + (else (error "Unknown length for variable-arg instruction:" + inst (instruction-length inst))))) ((= pops nargs) (emit-code `((,inst)))) (else diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 78e2d1e94..17592d275 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -79,7 +79,9 @@ ((set-car! . 2) . set-car!) ((set-cdr! . 2) . set-cdr!) ((null? . 1) . null?) - ((list? . 1) . list?))) + ((list? . 1) . list?) + (list . list) + (vector . vector))) (define (make-label) (gensym ":L")) @@ -254,8 +256,9 @@ (emit-code src (make-glil-call 'drop 1))))) ((and (primitive-ref? proc) - (hash-ref *primcall-ops* - (cons (primitive-ref-name proc) (length args)))) + (or (hash-ref *primcall-ops* + (cons (primitive-ref-name proc) (length args))) + (hash-ref *primcall-ops* (primitive-ref-name proc)))) => (lambda (op) (for-each comp-push args) (emit-code src (make-glil-call op (length args))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 03193b256..57755ea5e 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -53,6 +53,8 @@ not pair? null? list? acons cons cons* + list vector + car cdr set-car! set-cdr! From ad9b8c451b82f74cf88c5a6207ed3ea72c86f93e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 13:59:42 +0200 Subject: [PATCH 115/375] fix @slot-ref / @slot-set! compilation * module/language/tree-il/compile-glil.scm: Add primcall compilers for @slot-ref and @slot-set. * module/language/tree-il/optimize.scm (add-interesting-primitive!): New export. Creates an association between a variable in the current module and a primitive name. * module/oop/goops.scm: Rework compiler hooks to work with tree-il and not ghil. --- module/language/tree-il/compile-glil.scm | 5 +++-- module/language/tree-il/optimize.scm | 15 +++++++------ module/oop/goops.scm | 27 +++--------------------- 3 files changed, 14 insertions(+), 33 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 17592d275..c1e4cd883 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -32,7 +32,6 @@ ;; ;; call-with-values -> mv-bind ;; compile-time-environment -;; GOOPS' @slot-ref, @slot-set ;; basic degenerate-case reduction ;; allocation: @@ -81,7 +80,9 @@ ((null? . 1) . null?) ((list? . 1) . list?) (list . list) - (vector . vector))) + (vector . vector) + ((@slot-ref . 2) . slot-ref) + ((@slot-set! . 3) . slot-set))) (define (make-label) (gensym ":L")) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 57755ea5e..c8c23c636 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -23,7 +23,7 @@ #:use-module (system base syntax) #:use-module (language tree-il) #:use-module (language tree-il inline) - #:export (optimize!)) + #:export (optimize! add-interesting-primitive!)) (define (env-module e) (if e (car e) (current-module))) @@ -65,12 +65,13 @@ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) -(define *interesting-primitive-vars* - (let ((h (make-hash-table))) - (for-each (lambda (x) - (hashq-set! h (module-variable the-root-module x) x)) - *interesting-primitive-names*) - h)) +(define (add-interesting-primitive! name) + (hashq-set! *interesting-primitive-vars* + (module-variable (current-module) name) name)) + +(define *interesting-primitive-vars* (make-hash-table)) + +(for-each add-interesting-primitive! *interesting-primitive-names*) (define (resolve-primitives! x mod) (post-order! diff --git a/module/oop/goops.scm b/module/oop/goops.scm index f84af33fc..d7220d470 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1061,31 +1061,10 @@ ;; the idea is to compile the index into the procedure, for fastest ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. -;; separate expression so that we affect the expansion of the subsequent -;; expression (eval-when (compile) - (use-modules ((language scheme compile-ghil) :select (define-scheme-translator)) - ((language ghil) :select (make-ghil-inline make-ghil-call)) - (system base pmatch))) - -(eval-when (compile) - ;; unfortunately, can't use define-inline because these are primitive - ;; syntaxen. - (define-scheme-translator @slot-ref - ((,obj ,index) (guard (integer? index) - (>= index 0) (< index max-fixnum)) - (make-ghil-inline #f #f 'slot-ref - (list (retrans obj) (retrans index)))) - (else - (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))) - - (define-scheme-translator @slot-set! - ((,obj ,index ,val) (guard (integer? index) - (>= index 0) (< index max-fixnum)) - (make-ghil-inline #f #f 'slot-set - (list (retrans obj) (retrans index) (retrans val)))) - (else - (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))) + (use-modules ((language tree-il optimize) :select (add-interesting-primitive!))) + (add-interesting-primitive! '@slot-ref) + (add-interesting-primitive! '@slot-set!)) (eval-when (eval load compile) (define num-standard-pre-cache 20)) From 9806a548fe1a9cca0f82ef4f2f08fbcba5eccfaa Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 17:28:59 +0200 Subject: [PATCH 116/375] Fix a bug in the (ice-9 match) test * testsuite/t-match.scm (matches?): Fix match invocation. As far as I can tell, although (ice-9 match) does advertise a => form of clauses, it requires that the end of the => be a symbol. For some reason this works in the interpreter: ((lambda () (begin => #t))) It's part of the expansion of matches?. It also worked in the old compiler. Thinking that maybe toplevel references could cause side effects, I made the new compiler actually ref =>, which brought this to light. --- testsuite/t-match.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testsuite/t-match.scm b/testsuite/t-match.scm index 4b85f30d3..ed56ae7ef 100644 --- a/testsuite/t-match.scm +++ b/testsuite/t-match.scm @@ -12,7 +12,7 @@ (define (matches? obj) ; (format #t "matches? ~a~%" obj) (match obj - (($ stuff) => #t) + (($ stuff) #t) ; (blurps #t) ("hello" #t) (else #f))) From 68623e8e7883077dbb26521fe6d9c185df3138ce Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 17:41:21 +0200 Subject: [PATCH 117/375] remove compile-time-environment * module/ice-9/boot-9.scm (guile-user): Move the `compile' autoload to the guile-user module. Remove reference to compile-time-environment. * module/language/scheme/compile-ghil.scm: * module/language/tree-il/compile-glil.scm: * module/language/tree-il/optimize.scm: * module/system/base/compile.scm: * test-suite/tests/compiler.test: Remove definition of and references to compile-time-environment. While I do think that recompilation based on a lexical environment can be useful, I think it needs to be implemented differently. So for now we've lost nothing if we take it away, as it doesn't work with syncase anyway. --- module/ice-9/boot-9.scm | 16 ++------- module/language/scheme/compile-ghil.scm | 10 ------ module/language/tree-il/compile-glil.scm | 1 - module/language/tree-il/optimize.scm | 1 - module/system/base/compile.scm | 9 +---- test-suite/tests/compiler.test | 43 +++--------------------- 6 files changed, 7 insertions(+), 73 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index cdd840f14..6666f80b4 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3007,19 +3007,6 @@ module '(ice-9 q) '(make-q q-length))}." (define load load-module) - - -;;; {Compiler interface} -;;; -;;; The full compiler interface can be found in (system). Here we put a -;;; few useful procedures into the global namespace. - -(module-autoload! the-scm-module - '(system base compile) - '(compile - compile-time-environment)) - - ;;; {Parameters} @@ -3448,6 +3435,7 @@ module '(ice-9 q) '(make-q q-length))}." ;; (module-eval-closure (current-module)))) ;; (deannotate/source-properties (sc-expand (annotate exp))))) -(define-module (guile-user)) +(define-module (guile-user) + #:autoload (system base compile) (compile)) ;;; boot-9.scm ends here diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 370488c05..8d8332c34 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -414,16 +414,6 @@ (,args (-> (values (map retrans args))))) -(define-scheme-translator compile-time-environment - ;; (compile-time-environment) - ;; => (MODULE LEXICALS . EXTERNALS) - (() - (-> (inline 'cons - (list (retrans '(current-module)) - (-> (inline 'cons - (list (-> (reified-env)) - (-> (inline 'externals '())))))))))) - (define (lookup-apply-transformer proc) (cond ((eq? proc values) (lambda (e l args) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index c1e4cd883..226b7d402 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -31,7 +31,6 @@ ;;; TODO: ;; ;; call-with-values -> mv-bind -;; compile-time-environment ;; basic degenerate-case reduction ;; allocation: diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index c8c23c636..4f177a979 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -46,7 +46,6 @@ call-with-values @call-with-values call-with-current-continuation @call-with-current-continuation values - ;; compile-time-environment eq? eqv? equal? = < > <= >= zero? + * - / 1- 1+ quotient remainder modulo diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 7d54947e3..d0ebde040 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -29,7 +29,7 @@ #:export (syntax-error *current-language* compiled-file-name compile-file compile-and-load - compile compile-time-environment + compile decompile) #:export-syntax (call-with-compile-error-catch)) @@ -152,13 +152,6 @@ (receive (x e new-cenv) ((car passes) x e opts) (lp (cdr passes) x e (if first? new-cenv cenv) #f))))) -(define (compile-time-environment) - "A special function known to the compiler that, when compiled, will -return a representation of the lexical environment in place at compile -time. Useful for supporting some forms of dynamic compilation. Returns -#f if called from the interpreter." - #f) - (define (find-language-joint from to) (let lp ((in (reverse (or (lookup-compilation-order from to) (error "no way to compile" from "to" to)))) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index d83167f34..7324d7795 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -18,45 +18,10 @@ (define-module (test-suite tests compiler) :use-module (test-suite lib) :use-module (test-suite guile-test) - :use-module (system vm program)) + :use-module (system base compile)) -(with-test-prefix "environments" +(with-test-prefix "basic" - (pass-if "compile-time-environment in evaluator" - (eq? (primitive-eval '(compile-time-environment)) #f)) - - (pass-if "compile-time-environment in compiler" - (equal? (compile '(compile-time-environment)) - (cons (current-module) - (cons '() '())))) - - (let ((env (compile - '(let ((x 0)) (set! x 1) (compile-time-environment))))) - (pass-if "compile-time-environment in compiler, heap-allocated var" - (equal? env - (cons (current-module) - (cons '((x . 0)) '(1))))) - - ;; fixme: compiling with #t or module - (pass-if "recompiling with environment" - (equal? ((compile '(lambda () x) #:env env)) - 1)) - - (pass-if "recompiling with environment/2" - (equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env)) - 2)) - - (pass-if "recompiling with environment/3" - (equal? ((compile '(lambda () x) #:env env)) - 2)) - ) - - (pass-if "compile environment is #f" - (equal? ((compile '(lambda () 10))) - 10)) - - (pass-if "compile environment is a module" - (equal? ((compile '(lambda () 10) #:env (current-module))) - 10)) - ) \ No newline at end of file + (pass-if "compile to value" + (equal? (compile 1) 1))) From 8bb0b3cc9d582c48ed6cb5d123168ffd27ac7cf8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 18:11:23 +0200 Subject: [PATCH 118/375] fix failing macro-as-parameter tests in eval.test * module/ice-9/psyntax.scm (chi-lambda-clause): Strip the docstring before passing it on to the continuation. * module/ice-9/psyntax-pp.scm: Regenerated. * test-suite/tests/eval.test (exception:failed-match): New exception, for syntax-case failed matches. ("evaluator"): Fix macro-as-parameter tests. They pass now :) --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 4 ++-- test-suite/tests/eval.test | 25 +++++++++++++++---------- 3 files changed, 28 insertions(+), 23 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 4476212f6..062b86022 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*2008 (lambda (f2048 first2047 . rest2046) (let ((t2049 (null? first2047))) (if t2049 t2049 (if (null? rest2046) (letrec ((andmap2050 (lambda (first2051) (let ((x2052 (car first2051)) (first2053 (cdr first2051))) (if (null? first2053) (f2048 x2052) (if (f2048 x2052) (andmap2050 first2053) #f)))))) (andmap2050 first2047)) (letrec ((andmap2054 (lambda (first2055 rest2056) (let ((x2057 (car first2055)) (xr2058 (map car rest2056)) (first2059 (cdr first2055)) (rest2060 (map cdr rest2056))) (if (null? first2059) (apply f2048 (cons x2057 xr2058)) (if (apply f2048 (cons x2057 xr2058)) (andmap2054 first2059 rest2060) #f)))))) (andmap2054 first2047 rest2046)))))))) (letrec ((lambda-var-list2153 (lambda (vars2282) (letrec ((lvl2283 (lambda (vars2284 ls2285 w2286) (if (pair? vars2284) (lvl2283 (cdr vars2284) (cons (wrap2132 (car vars2284) w2286 #f) ls2285) w2286) (if (id?2104 vars2284) (cons (wrap2132 vars2284 w2286 #f) ls2285) (if (null? vars2284) ls2285 (if (syntax-object?2088 vars2284) (lvl2283 (syntax-object-expression2089 vars2284) ls2285 (join-wraps2123 w2286 (syntax-object-wrap2090 vars2284))) (if (annotation? vars2284) (lvl2283 (annotation-expression vars2284) ls2285 w2286) (cons vars2284 ls2285))))))))) (lvl2283 vars2282 (quote ()) (quote (())))))) (gen-var2152 (lambda (id2287) (let ((id2288 (if (syntax-object?2088 id2287) (syntax-object-expression2089 id2287) id2287))) (if (annotation? id2288) (gensym (symbol->string (annotation-expression id2288))) (gensym (symbol->string id2288)))))) (strip2151 (lambda (x2289 w2290) (if (memq (quote top) (wrap-marks2107 w2290)) (if (let ((t2291 (annotation? x2289))) (if t2291 t2291 (if (pair? x2289) (annotation? (car x2289)) #f))) (strip-annotation2150 x2289 #f) x2289) (letrec ((f2292 (lambda (x2293) (if (syntax-object?2088 x2293) (strip2151 (syntax-object-expression2089 x2293) (syntax-object-wrap2090 x2293)) (if (pair? x2293) (let ((a2294 (f2292 (car x2293))) (d2295 (f2292 (cdr x2293)))) (if (if (eq? a2294 (car x2293)) (eq? d2295 (cdr x2293)) #f) x2293 (cons a2294 d2295))) (if (vector? x2293) (let ((old2296 (vector->list x2293))) (let ((new2297 (map f2292 old2296))) (if (and-map*2008 eq? old2296 new2297) x2293 (list->vector new2297)))) x2293)))))) (f2292 x2289))))) (strip-annotation2150 (lambda (x2298 parent2299) (if (pair? x2298) (let ((new2300 (cons #f #f))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2300) (if #f #f)) (set-car! new2300 (strip-annotation2150 (car x2298) #f)) (set-cdr! new2300 (strip-annotation2150 (cdr x2298) #f)) new2300)) (if (annotation? x2298) (let ((t2301 (annotation-stripped x2298))) (if t2301 t2301 (strip-annotation2150 (annotation-expression x2298) x2298))) (if (vector? x2298) (let ((new2302 (make-vector (vector-length x2298)))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2302) (if #f #f)) (letrec ((loop2303 (lambda (i2304) (unless (fx<2066 i2304 0) (vector-set! new2302 i2304 (strip-annotation2150 (vector-ref x2298 i2304) #f)) (loop2303 (fx-2064 i2304 1)))))) (loop2303 (- (vector-length x2298) 1))) new2302)) x2298))))) (ellipsis?2149 (lambda (x2305) (if (nonsymbol-id?2103 x2305) (free-id=?2127 x2305 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void2148 (lambda () (build-void2071 #f))) (eval-local-transformer2147 (lambda (expanded2306 mod2307) (let ((p2308 (local-eval-hook2068 expanded2306 mod2307))) (if (procedure? p2308) p2308 (syntax-violation #f "nonprocedure transformer" p2308))))) (chi-local-syntax2146 (lambda (rec?2309 e2310 r2311 w2312 s2313 mod2314 k2315) ((lambda (tmp2316) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 id2319 val2320 e12321 e22322) (let ((ids2323 id2319)) (if (not (valid-bound-ids?2129 ids2323)) (syntax-violation #f "duplicate bound keyword" e2310) (let ((labels2325 (gen-labels2110 ids2323))) (let ((new-w2326 (make-binding-wrap2121 ids2323 labels2325 w2312))) (k2315 (cons e12321 e22322) (extend-env2098 labels2325 (let ((w2328 (if rec?2309 new-w2326 w2312)) (trans-r2329 (macros-only-env2100 r2311))) (map (lambda (x2330) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2330 trans-r2329 w2328 mod2314) mod2314))) val2320)) r2311) new-w2326 s2313 mod2314)))))) tmp2317) ((lambda (_2332) (syntax-violation #f "bad local syntax definition" (source-wrap2133 e2310 w2312 s2313 mod2314))) tmp2316))) ($sc-dispatch tmp2316 (quote (any #(each (any any)) any . each-any))))) e2310))) (chi-lambda-clause2145 (lambda (e2333 docstring2334 c2335 r2336 w2337 mod2338 k2339) ((lambda (tmp2340) ((lambda (tmp2341) (if (if tmp2341 (apply (lambda (args2342 doc2343 e12344 e22345) (if (string? (syntax->datum doc2343)) (not docstring2334) #f)) tmp2341) #f) (apply (lambda (args2346 doc2347 e12348 e22349) (chi-lambda-clause2145 e2333 doc2347 (cons args2346 (cons e12348 e22349)) r2336 w2337 mod2338 k2339)) tmp2341) ((lambda (tmp2351) (if tmp2351 (apply (lambda (id2352 e12353 e22354) (let ((ids2355 id2352)) (if (not (valid-bound-ids?2129 ids2355)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2357 (gen-labels2110 ids2355)) (new-vars2358 (map gen-var2152 ids2355))) (k2339 (map syntax->datum ids2355) new-vars2358 docstring2334 (chi-body2144 (cons e12353 e22354) e2333 (extend-var-env2099 labels2357 new-vars2358 r2336) (make-binding-wrap2121 ids2355 labels2357 w2337) mod2338)))))) tmp2351) ((lambda (tmp2360) (if tmp2360 (apply (lambda (ids2361 e12362 e22363) (let ((old-ids2364 (lambda-var-list2153 ids2361))) (if (not (valid-bound-ids?2129 old-ids2364)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2365 (gen-labels2110 old-ids2364)) (new-vars2366 (map gen-var2152 old-ids2364))) (k2339 (letrec ((f2367 (lambda (ls12368 ls22369) (if (null? ls12368) (syntax->datum ls22369) (f2367 (cdr ls12368) (cons (syntax->datum (car ls12368)) ls22369)))))) (f2367 (cdr old-ids2364) (car old-ids2364))) (letrec ((f2370 (lambda (ls12371 ls22372) (if (null? ls12371) ls22372 (f2370 (cdr ls12371) (cons (car ls12371) ls22372)))))) (f2370 (cdr new-vars2366) (car new-vars2366))) docstring2334 (chi-body2144 (cons e12362 e22363) e2333 (extend-var-env2099 labels2365 new-vars2366 r2336) (make-binding-wrap2121 old-ids2364 labels2365 w2337) mod2338)))))) tmp2360) ((lambda (_2374) (syntax-violation (quote lambda) "bad lambda" e2333)) tmp2340))) ($sc-dispatch tmp2340 (quote (any any . each-any)))))) ($sc-dispatch tmp2340 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2340 (quote (any any any . each-any))))) c2335))) (chi-body2144 (lambda (body2375 outer-form2376 r2377 w2378 mod2379) (let ((r2380 (cons (quote ("placeholder" placeholder)) r2377))) (let ((ribcage2381 (make-ribcage2111 (quote ()) (quote ()) (quote ())))) (let ((w2382 (make-wrap2106 (wrap-marks2107 w2378) (cons ribcage2381 (wrap-subst2108 w2378))))) (letrec ((parse2383 (lambda (body2384 ids2385 labels2386 vars2387 vals2388 bindings2389) (if (null? body2384) (syntax-violation #f "no expressions in body" outer-form2376) (let ((e2391 (cdar body2384)) (er2392 (caar body2384))) (call-with-values (lambda () (syntax-type2138 e2391 er2392 (quote (())) #f ribcage2381 mod2379)) (lambda (type2393 value2394 e2395 w2396 s2397 mod2398) (if (memv type2393 (quote (define-form))) (let ((id2399 (wrap2132 value2394 w2396 mod2398)) (label2400 (gen-label2109))) (let ((var2401 (gen-var2152 id2399))) (begin (extend-ribcage!2120 ribcage2381 id2399 label2400) (parse2383 (cdr body2384) (cons id2399 ids2385) (cons label2400 labels2386) (cons var2401 vars2387) (cons (cons er2392 (wrap2132 e2395 w2396 mod2398)) vals2388) (cons (cons (quote lexical) var2401) bindings2389))))) (if (memv type2393 (quote (define-syntax-form))) (let ((id2402 (wrap2132 value2394 w2396 mod2398)) (label2403 (gen-label2109))) (begin (extend-ribcage!2120 ribcage2381 id2402 label2403) (parse2383 (cdr body2384) (cons id2402 ids2385) (cons label2403 labels2386) vars2387 vals2388 (cons (cons (quote macro) (cons er2392 (wrap2132 e2395 w2396 mod2398))) bindings2389)))) (if (memv type2393 (quote (begin-form))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 e12407) (parse2383 (letrec ((f2408 (lambda (forms2409) (if (null? forms2409) (cdr body2384) (cons (cons er2392 (wrap2132 (car forms2409) w2396 mod2398)) (f2408 (cdr forms2409))))))) (f2408 e12407)) ids2385 labels2386 vars2387 vals2388 bindings2389)) tmp2405) (syntax-violation #f "source expression failed to match any pattern" tmp2404))) ($sc-dispatch tmp2404 (quote (any . each-any))))) e2395) (if (memv type2393 (quote (local-syntax-form))) (chi-local-syntax2146 value2394 e2395 er2392 w2396 s2397 mod2398 (lambda (forms2411 er2412 w2413 s2414 mod2415) (parse2383 (letrec ((f2416 (lambda (forms2417) (if (null? forms2417) (cdr body2384) (cons (cons er2412 (wrap2132 (car forms2417) w2413 mod2415)) (f2416 (cdr forms2417))))))) (f2416 forms2411)) ids2385 labels2386 vars2387 vals2388 bindings2389))) (if (null? ids2385) (build-sequence2083 #f (map (lambda (x2418) (chi2140 (cdr x2418) (car x2418) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))) (begin (if (not (valid-bound-ids?2129 ids2385)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form2376) (if #f #f)) (letrec ((loop2419 (lambda (bs2420 er-cache2421 r-cache2422) (if (not (null? bs2420)) (let ((b2423 (car bs2420))) (if (eq? (car b2423) (quote macro)) (let ((er2424 (cadr b2423))) (let ((r-cache2425 (if (eq? er2424 er-cache2421) r-cache2422 (macros-only-env2100 er2424)))) (begin (set-cdr! b2423 (eval-local-transformer2147 (chi2140 (cddr b2423) r-cache2425 (quote (())) mod2398) mod2398)) (loop2419 (cdr bs2420) er2424 r-cache2425)))) (loop2419 (cdr bs2420) er-cache2421 r-cache2422))) (if #f #f))))) (loop2419 bindings2389 #f #f)) (set-cdr! r2380 (extend-env2098 labels2386 bindings2389 (cdr r2380))) (build-letrec2086 #f (map syntax->datum ids2385) vars2387 (map (lambda (x2426) (chi2140 (cdr x2426) (car x2426) (quote (())) mod2398)) vals2388) (build-sequence2083 #f (map (lambda (x2427) (chi2140 (cdr x2427) (car x2427) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))))))))))))))))) (parse2383 (map (lambda (x2390) (cons r2380 (wrap2132 x2390 w2382 mod2379))) body2375) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro2143 (lambda (p2428 e2429 r2430 w2431 rib2432 mod2433) (letrec ((rebuild-macro-output2434 (lambda (x2435 m2436) (if (pair? x2435) (cons (rebuild-macro-output2434 (car x2435) m2436) (rebuild-macro-output2434 (cdr x2435) m2436)) (if (syntax-object?2088 x2435) (let ((w2437 (syntax-object-wrap2090 x2435))) (let ((ms2438 (wrap-marks2107 w2437)) (s2439 (wrap-subst2108 w2437))) (if (if (pair? ms2438) (eq? (car ms2438) #f) #f) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cdr ms2438) (if rib2432 (cons rib2432 (cdr s2439)) (cdr s2439))) (syntax-object-module2091 x2435)) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cons m2436 ms2438) (if rib2432 (cons rib2432 (cons (quote shift) s2439)) (cons (quote shift) s2439))) (let ((pmod2440 (procedure-module p2428))) (if pmod2440 (cons (quote hygiene) (module-name pmod2440)) (quote (hygiene guile)))))))) (if (vector? x2435) (let ((n2441 (vector-length x2435))) (let ((v2442 (make-vector n2441))) (letrec ((loop2443 (lambda (i2444) (if (fx=2065 i2444 n2441) (begin (if #f #f (if #f #f)) v2442) (begin (vector-set! v2442 i2444 (rebuild-macro-output2434 (vector-ref x2435 i2444) m2436)) (loop2443 (fx+2063 i2444 1))))))) (loop2443 0)))) (if (symbol? x2435) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap2133 e2429 w2431 s mod2433) x2435) x2435))))))) (rebuild-macro-output2434 (p2428 (wrap2132 e2429 (anti-mark2119 w2431) mod2433)) (string #\m))))) (chi-application2142 (lambda (x2445 e2446 r2447 w2448 s2449 mod2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (e02453 e12454) (build-application2072 s2449 x2445 (map (lambda (e2455) (chi2140 e2455 r2447 w2448 mod2450)) e12454))) tmp2452) (syntax-violation #f "source expression failed to match any pattern" tmp2451))) ($sc-dispatch tmp2451 (quote (any . each-any))))) e2446))) (chi-expr2141 (lambda (type2457 value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (lexical))) (build-lexical-reference2074 (quote value) s2462 e2459 value2458) (if (memv type2457 (quote (core external-macro))) (value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (module-ref))) (call-with-values (lambda () (value2458 e2459)) (lambda (id2464 mod2465) (build-global-reference2077 s2462 id2464 mod2465))) (if (memv type2457 (quote (lexical-call))) (chi-application2142 (build-lexical-reference2074 (quote fun) (source-annotation2095 (car e2459)) (car e2459) value2458) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (global-call))) (chi-application2142 (build-global-reference2077 (source-annotation2095 (car e2459)) value2458 (if (syntax-object?2088 (car e2459)) (syntax-object-module2091 (car e2459)) mod2463)) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (constant))) (build-data2082 s2462 (strip2151 (source-wrap2133 e2459 w2461 s2462 mod2463) (quote (())))) (if (memv type2457 (quote (global))) (build-global-reference2077 s2462 value2458 mod2463) (if (memv type2457 (quote (call))) (chi-application2142 (chi2140 (car e2459) r2460 w2461 mod2463) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (begin-form))) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 e12469 e22470) (chi-sequence2134 (cons e12469 e22470) r2460 w2461 s2462 mod2463)) tmp2467) (syntax-violation #f "source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any any . each-any))))) e2459) (if (memv type2457 (quote (local-syntax-form))) (chi-local-syntax2146 value2458 e2459 r2460 w2461 s2462 mod2463 chi-sequence2134) (if (memv type2457 (quote (eval-when-form))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (_2474 x2475 e12476 e22477) (let ((when-list2478 (chi-when-list2137 e2459 x2475 w2461))) (if (memq (quote eval) when-list2478) (chi-sequence2134 (cons e12476 e22477) r2460 w2461 s2462 mod2463) (chi-void2148)))) tmp2473) (syntax-violation #f "source expression failed to match any pattern" tmp2472))) ($sc-dispatch tmp2472 (quote (any each-any any . each-any))))) e2459) (if (memv type2457 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e2459 (wrap2132 value2458 w2461 mod2463)) (if (memv type2457 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap2133 e2459 w2461 s2462 mod2463)) (if (memv type2457 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap2133 e2459 w2461 s2462 mod2463)) (syntax-violation #f "unexpected syntax" (source-wrap2133 e2459 w2461 s2462 mod2463)))))))))))))))))) (chi2140 (lambda (e2481 r2482 w2483 mod2484) (call-with-values (lambda () (syntax-type2138 e2481 r2482 w2483 #f #f mod2484)) (lambda (type2485 value2486 e2487 w2488 s2489 mod2490) (chi-expr2141 type2485 value2486 e2487 r2482 w2488 s2489 mod2490))))) (chi-top2139 (lambda (e2491 r2492 w2493 m2494 esew2495 mod2496) (call-with-values (lambda () (syntax-type2138 e2491 r2492 w2493 #f #f mod2496)) (lambda (type2504 value2505 e2506 w2507 s2508 mod2509) (if (memv type2504 (quote (begin-form))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (_2512) (chi-void2148)) tmp2511) ((lambda (tmp2513) (if tmp2513 (apply (lambda (_2514 e12515 e22516) (chi-top-sequence2135 (cons e12515 e22516) r2492 w2507 s2508 m2494 esew2495 mod2509)) tmp2513) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote (any any . each-any)))))) ($sc-dispatch tmp2510 (quote (any))))) e2506) (if (memv type2504 (quote (local-syntax-form))) (chi-local-syntax2146 value2505 e2506 r2492 w2507 s2508 mod2509 (lambda (body2518 r2519 w2520 s2521 mod2522) (chi-top-sequence2135 body2518 r2519 w2520 s2521 m2494 esew2495 mod2522))) (if (memv type2504 (quote (eval-when-form))) ((lambda (tmp2523) ((lambda (tmp2524) (if tmp2524 (apply (lambda (_2525 x2526 e12527 e22528) (let ((when-list2529 (chi-when-list2137 e2506 x2526 w2507)) (body2530 (cons e12527 e22528))) (if (eq? m2494 (quote e)) (if (memq (quote eval) when-list2529) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) (chi-void2148)) (if (memq (quote load) when-list2529) (if (let ((t2533 (memq (quote compile) when-list2529))) (if t2533 t2533 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c&e) (quote (compile load)) mod2509) (if (memq m2494 (quote (c c&e))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c) (quote (load)) mod2509) (chi-void2148))) (if (let ((t2534 (memq (quote compile) when-list2529))) (if t2534 t2534 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (begin (top-level-eval-hook2067 (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) mod2509) (chi-void2148)) (chi-void2148)))))) tmp2524) (syntax-violation #f "source expression failed to match any pattern" tmp2523))) ($sc-dispatch tmp2523 (quote (any each-any any . each-any))))) e2506) (if (memv type2504 (quote (define-syntax-form))) (let ((n2535 (id-var-name2126 value2505 w2507)) (r2536 (macros-only-env2100 r2492))) (if (memv m2494 (quote (c))) (if (memq (quote compile) esew2495) (let ((e2537 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2537 mod2509) (if (memq (quote load) esew2495) e2537 (chi-void2148)))) (if (memq (quote load) esew2495) (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) (chi-void2148))) (if (memv m2494 (quote (c&e))) (let ((e2538 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2538 mod2509) e2538)) (begin (if (memq (quote eval) esew2495) (top-level-eval-hook2067 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) mod2509) (if #f #f)) (chi-void2148))))) (if (memv type2504 (quote (define-form))) (let ((n2539 (id-var-name2126 value2505 w2507))) (let ((type2540 (binding-type2096 (lookup2101 n2539 r2492 mod2509)))) (if (memv type2540 (quote (global core macro module-ref))) (let ((x2541 (build-global-definition2079 s2508 n2539 (chi2140 e2506 r2492 w2507 mod2509)))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2541 mod2509) (if #f #f)) x2541)) (if (memv type2540 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e2506 (wrap2132 value2505 w2507 mod2509)) (syntax-violation #f "cannot define keyword at top level" e2506 (wrap2132 value2505 w2507 mod2509)))))) (let ((x2542 (chi-expr2141 type2504 value2505 e2506 r2492 w2507 s2508 mod2509))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2542 mod2509) (if #f #f)) x2542))))))))))) (syntax-type2138 (lambda (e2543 r2544 w2545 s2546 rib2547 mod2548) (if (symbol? e2543) (let ((n2549 (id-var-name2126 e2543 w2545))) (let ((b2550 (lookup2101 n2549 r2544 mod2548))) (let ((type2551 (binding-type2096 b2550))) (if (memv type2551 (quote (lexical))) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (global))) (values type2551 n2549 e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2550) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548))))))) (if (pair? e2543) (let ((first2552 (car e2543))) (if (id?2104 first2552) (let ((n2553 (id-var-name2126 first2552 w2545))) (let ((b2554 (lookup2101 n2553 r2544 (let ((t2555 (if (syntax-object?2088 first2552) (syntax-object-module2091 first2552) #f))) (if t2555 t2555 mod2548))))) (let ((type2556 (binding-type2096 b2554))) (if (memv type2556 (quote (lexical))) (values (quote lexical-call) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (global))) (values (quote global-call) n2553 e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2554) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (if (memv type2556 (quote (core external-macro module-ref))) (values type2556 (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (begin))) (values (quote begin-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (eval-when))) (values (quote eval-when-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (define))) ((lambda (tmp2557) ((lambda (tmp2558) (if (if tmp2558 (apply (lambda (_2559 name2560 val2561) (id?2104 name2560)) tmp2558) #f) (apply (lambda (_2562 name2563 val2564) (values (quote define-form) name2563 val2564 w2545 s2546 mod2548)) tmp2558) ((lambda (tmp2565) (if (if tmp2565 (apply (lambda (_2566 name2567 args2568 e12569 e22570) (if (id?2104 name2567) (valid-bound-ids?2129 (lambda-var-list2153 args2568)) #f)) tmp2565) #f) (apply (lambda (_2571 name2572 args2573 e12574 e22575) (values (quote define-form) (wrap2132 name2572 w2545 mod2548) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap2132 (cons args2573 (cons e12574 e22575)) w2545 mod2548)) (quote (())) s2546 mod2548)) tmp2565) ((lambda (tmp2577) (if (if tmp2577 (apply (lambda (_2578 name2579) (id?2104 name2579)) tmp2577) #f) (apply (lambda (_2580 name2581) (values (quote define-form) (wrap2132 name2581 w2545 mod2548) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2546 mod2548)) tmp2577) (syntax-violation #f "source expression failed to match any pattern" tmp2557))) ($sc-dispatch tmp2557 (quote (any any)))))) ($sc-dispatch tmp2557 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2557 (quote (any any any))))) e2543) (if (memv type2556 (quote (define-syntax))) ((lambda (tmp2582) ((lambda (tmp2583) (if (if tmp2583 (apply (lambda (_2584 name2585 val2586) (id?2104 name2585)) tmp2583) #f) (apply (lambda (_2587 name2588 val2589) (values (quote define-syntax-form) name2588 val2589 w2545 s2546 mod2548)) tmp2583) (syntax-violation #f "source expression failed to match any pattern" tmp2582))) ($sc-dispatch tmp2582 (quote (any any any))))) e2543) (values (quote call) #f e2543 w2545 s2546 mod2548))))))))))))) (values (quote call) #f e2543 w2545 s2546 mod2548))) (if (syntax-object?2088 e2543) (syntax-type2138 (syntax-object-expression2089 e2543) r2544 (join-wraps2123 w2545 (syntax-object-wrap2090 e2543)) #f rib2547 (let ((t2590 (syntax-object-module2091 e2543))) (if t2590 t2590 mod2548))) (if (annotation? e2543) (syntax-type2138 (annotation-expression e2543) r2544 w2545 (annotation-source e2543) rib2547 mod2548) (if (self-evaluating? e2543) (values (quote constant) #f e2543 w2545 s2546 mod2548) (values (quote other) #f e2543 w2545 s2546 mod2548)))))))) (chi-when-list2137 (lambda (e2591 when-list2592 w2593) (letrec ((f2594 (lambda (when-list2595 situations2596) (if (null? when-list2595) situations2596 (f2594 (cdr when-list2595) (cons (let ((x2597 (car when-list2595))) (if (free-id=?2127 x2597 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?2127 x2597 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?2127 x2597 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e2591 (wrap2132 x2597 w2593 #f)))))) situations2596)))))) (f2594 when-list2592 (quote ()))))) (chi-install-global2136 (lambda (name2598 e2599) (build-global-definition2079 #f name2598 (if (let ((v2600 (module-variable (current-module) name2598))) (if v2600 (if (variable-bound? v2600) (if (macro? (variable-ref v2600)) (not (eq? (macro-type (variable-ref v2600)) (quote syncase-macro))) #f) #f) #f)) (build-application2072 #f (build-primref2081 #f (quote make-extended-syncase-macro)) (list (build-application2072 #f (build-primref2081 #f (quote module-ref)) (list (build-application2072 #f (build-primref2081 #f (quote current-module)) (quote ())) (build-data2082 #f name2598))) (build-data2082 #f (quote macro)) e2599)) (build-application2072 #f (build-primref2081 #f (quote make-syncase-macro)) (list (build-data2082 #f (quote macro)) e2599)))))) (chi-top-sequence2135 (lambda (body2601 r2602 w2603 s2604 m2605 esew2606 mod2607) (build-sequence2083 s2604 (letrec ((dobody2608 (lambda (body2609 r2610 w2611 m2612 esew2613 mod2614) (if (null? body2609) (quote ()) (let ((first2615 (chi-top2139 (car body2609) r2610 w2611 m2612 esew2613 mod2614))) (cons first2615 (dobody2608 (cdr body2609) r2610 w2611 m2612 esew2613 mod2614))))))) (dobody2608 body2601 r2602 w2603 m2605 esew2606 mod2607))))) (chi-sequence2134 (lambda (body2616 r2617 w2618 s2619 mod2620) (build-sequence2083 s2619 (letrec ((dobody2621 (lambda (body2622 r2623 w2624 mod2625) (if (null? body2622) (quote ()) (let ((first2626 (chi2140 (car body2622) r2623 w2624 mod2625))) (cons first2626 (dobody2621 (cdr body2622) r2623 w2624 mod2625))))))) (dobody2621 body2616 r2617 w2618 mod2620))))) (source-wrap2133 (lambda (x2627 w2628 s2629 defmod2630) (wrap2132 (if s2629 (make-annotation x2627 s2629 #f) x2627) w2628 defmod2630))) (wrap2132 (lambda (x2631 w2632 defmod2633) (if (if (null? (wrap-marks2107 w2632)) (null? (wrap-subst2108 w2632)) #f) x2631 (if (syntax-object?2088 x2631) (make-syntax-object2087 (syntax-object-expression2089 x2631) (join-wraps2123 w2632 (syntax-object-wrap2090 x2631)) (syntax-object-module2091 x2631)) (if (null? x2631) x2631 (make-syntax-object2087 x2631 w2632 defmod2633)))))) (bound-id-member?2131 (lambda (x2634 list2635) (if (not (null? list2635)) (let ((t2636 (bound-id=?2128 x2634 (car list2635)))) (if t2636 t2636 (bound-id-member?2131 x2634 (cdr list2635)))) #f))) (distinct-bound-ids?2130 (lambda (ids2637) (letrec ((distinct?2638 (lambda (ids2639) (let ((t2640 (null? ids2639))) (if t2640 t2640 (if (not (bound-id-member?2131 (car ids2639) (cdr ids2639))) (distinct?2638 (cdr ids2639)) #f)))))) (distinct?2638 ids2637)))) (valid-bound-ids?2129 (lambda (ids2641) (if (letrec ((all-ids?2642 (lambda (ids2643) (let ((t2644 (null? ids2643))) (if t2644 t2644 (if (id?2104 (car ids2643)) (all-ids?2642 (cdr ids2643)) #f)))))) (all-ids?2642 ids2641)) (distinct-bound-ids?2130 ids2641) #f))) (bound-id=?2128 (lambda (i2645 j2646) (if (if (syntax-object?2088 i2645) (syntax-object?2088 j2646) #f) (if (eq? (let ((e2647 (syntax-object-expression2089 i2645))) (if (annotation? e2647) (annotation-expression e2647) e2647)) (let ((e2648 (syntax-object-expression2089 j2646))) (if (annotation? e2648) (annotation-expression e2648) e2648))) (same-marks?2125 (wrap-marks2107 (syntax-object-wrap2090 i2645)) (wrap-marks2107 (syntax-object-wrap2090 j2646))) #f) (eq? (let ((e2649 i2645)) (if (annotation? e2649) (annotation-expression e2649) e2649)) (let ((e2650 j2646)) (if (annotation? e2650) (annotation-expression e2650) e2650)))))) (free-id=?2127 (lambda (i2651 j2652) (if (eq? (let ((x2653 i2651)) (let ((e2654 (if (syntax-object?2088 x2653) (syntax-object-expression2089 x2653) x2653))) (if (annotation? e2654) (annotation-expression e2654) e2654))) (let ((x2655 j2652)) (let ((e2656 (if (syntax-object?2088 x2655) (syntax-object-expression2089 x2655) x2655))) (if (annotation? e2656) (annotation-expression e2656) e2656)))) (eq? (id-var-name2126 i2651 (quote (()))) (id-var-name2126 j2652 (quote (())))) #f))) (id-var-name2126 (lambda (id2657 w2658) (letrec ((search-vector-rib2661 (lambda (sym2667 subst2668 marks2669 symnames2670 ribcage2671) (let ((n2672 (vector-length symnames2670))) (letrec ((f2673 (lambda (i2674) (if (fx=2065 i2674 n2672) (search2659 sym2667 (cdr subst2668) marks2669) (if (if (eq? (vector-ref symnames2670 i2674) sym2667) (same-marks?2125 marks2669 (vector-ref (ribcage-marks2114 ribcage2671) i2674)) #f) (values (vector-ref (ribcage-labels2115 ribcage2671) i2674) marks2669) (f2673 (fx+2063 i2674 1))))))) (f2673 0))))) (search-list-rib2660 (lambda (sym2675 subst2676 marks2677 symnames2678 ribcage2679) (letrec ((f2680 (lambda (symnames2681 i2682) (if (null? symnames2681) (search2659 sym2675 (cdr subst2676) marks2677) (if (if (eq? (car symnames2681) sym2675) (same-marks?2125 marks2677 (list-ref (ribcage-marks2114 ribcage2679) i2682)) #f) (values (list-ref (ribcage-labels2115 ribcage2679) i2682) marks2677) (f2680 (cdr symnames2681) (fx+2063 i2682 1))))))) (f2680 symnames2678 0)))) (search2659 (lambda (sym2683 subst2684 marks2685) (if (null? subst2684) (values #f marks2685) (let ((fst2686 (car subst2684))) (if (eq? fst2686 (quote shift)) (search2659 sym2683 (cdr subst2684) (cdr marks2685)) (let ((symnames2687 (ribcage-symnames2113 fst2686))) (if (vector? symnames2687) (search-vector-rib2661 sym2683 subst2684 marks2685 symnames2687 fst2686) (search-list-rib2660 sym2683 subst2684 marks2685 symnames2687 fst2686))))))))) (if (symbol? id2657) (let ((t2688 (call-with-values (lambda () (search2659 id2657 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2690 . ignore2689) x2690)))) (if t2688 t2688 id2657)) (if (syntax-object?2088 id2657) (let ((id2691 (let ((e2693 (syntax-object-expression2089 id2657))) (if (annotation? e2693) (annotation-expression e2693) e2693))) (w12692 (syntax-object-wrap2090 id2657))) (let ((marks2694 (join-marks2124 (wrap-marks2107 w2658) (wrap-marks2107 w12692)))) (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w2658) marks2694)) (lambda (new-id2695 marks2696) (let ((t2697 new-id2695)) (if t2697 t2697 (let ((t2698 (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w12692) marks2696)) (lambda (x2700 . ignore2699) x2700)))) (if t2698 t2698 id2691)))))))) (if (annotation? id2657) (let ((id2701 (let ((e2702 id2657)) (if (annotation? e2702) (annotation-expression e2702) e2702)))) (let ((t2703 (call-with-values (lambda () (search2659 id2701 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2705 . ignore2704) x2705)))) (if t2703 t2703 id2701))) (syntax-violation (quote id-var-name) "invalid id" id2657))))))) (same-marks?2125 (lambda (x2706 y2707) (let ((t2708 (eq? x2706 y2707))) (if t2708 t2708 (if (not (null? x2706)) (if (not (null? y2707)) (if (eq? (car x2706) (car y2707)) (same-marks?2125 (cdr x2706) (cdr y2707)) #f) #f) #f))))) (join-marks2124 (lambda (m12709 m22710) (smart-append2122 m12709 m22710))) (join-wraps2123 (lambda (w12711 w22712) (let ((m12713 (wrap-marks2107 w12711)) (s12714 (wrap-subst2108 w12711))) (if (null? m12713) (if (null? s12714) w22712 (make-wrap2106 (wrap-marks2107 w22712) (smart-append2122 s12714 (wrap-subst2108 w22712)))) (make-wrap2106 (smart-append2122 m12713 (wrap-marks2107 w22712)) (smart-append2122 s12714 (wrap-subst2108 w22712))))))) (smart-append2122 (lambda (m12715 m22716) (if (null? m22716) m12715 (append m12715 m22716)))) (make-binding-wrap2121 (lambda (ids2717 labels2718 w2719) (if (null? ids2717) w2719 (make-wrap2106 (wrap-marks2107 w2719) (cons (let ((labelvec2720 (list->vector labels2718))) (let ((n2721 (vector-length labelvec2720))) (let ((symnamevec2722 (make-vector n2721)) (marksvec2723 (make-vector n2721))) (begin (letrec ((f2724 (lambda (ids2725 i2726) (if (not (null? ids2725)) (call-with-values (lambda () (id-sym-name&marks2105 (car ids2725) w2719)) (lambda (symname2727 marks2728) (begin (vector-set! symnamevec2722 i2726 symname2727) (vector-set! marksvec2723 i2726 marks2728) (f2724 (cdr ids2725) (fx+2063 i2726 1))))) (if #f #f))))) (f2724 ids2717 0)) (make-ribcage2111 symnamevec2722 marksvec2723 labelvec2720))))) (wrap-subst2108 w2719)))))) (extend-ribcage!2120 (lambda (ribcage2729 id2730 label2731) (begin (set-ribcage-symnames!2116 ribcage2729 (cons (let ((e2732 (syntax-object-expression2089 id2730))) (if (annotation? e2732) (annotation-expression e2732) e2732)) (ribcage-symnames2113 ribcage2729))) (set-ribcage-marks!2117 ribcage2729 (cons (wrap-marks2107 (syntax-object-wrap2090 id2730)) (ribcage-marks2114 ribcage2729))) (set-ribcage-labels!2118 ribcage2729 (cons label2731 (ribcage-labels2115 ribcage2729)))))) (anti-mark2119 (lambda (w2733) (make-wrap2106 (cons #f (wrap-marks2107 w2733)) (cons (quote shift) (wrap-subst2108 w2733))))) (set-ribcage-labels!2118 (lambda (x2734 update2735) (vector-set! x2734 3 update2735))) (set-ribcage-marks!2117 (lambda (x2736 update2737) (vector-set! x2736 2 update2737))) (set-ribcage-symnames!2116 (lambda (x2738 update2739) (vector-set! x2738 1 update2739))) (ribcage-labels2115 (lambda (x2740) (vector-ref x2740 3))) (ribcage-marks2114 (lambda (x2741) (vector-ref x2741 2))) (ribcage-symnames2113 (lambda (x2742) (vector-ref x2742 1))) (ribcage?2112 (lambda (x2743) (if (vector? x2743) (if (= (vector-length x2743) 4) (eq? (vector-ref x2743 0) (quote ribcage)) #f) #f))) (make-ribcage2111 (lambda (symnames2744 marks2745 labels2746) (vector (quote ribcage) symnames2744 marks2745 labels2746))) (gen-labels2110 (lambda (ls2747) (if (null? ls2747) (quote ()) (cons (gen-label2109) (gen-labels2110 (cdr ls2747)))))) (gen-label2109 (lambda () (string #\i))) (wrap-subst2108 cdr) (wrap-marks2107 car) (make-wrap2106 cons) (id-sym-name&marks2105 (lambda (x2748 w2749) (if (syntax-object?2088 x2748) (values (let ((e2750 (syntax-object-expression2089 x2748))) (if (annotation? e2750) (annotation-expression e2750) e2750)) (join-marks2124 (wrap-marks2107 w2749) (wrap-marks2107 (syntax-object-wrap2090 x2748)))) (values (let ((e2751 x2748)) (if (annotation? e2751) (annotation-expression e2751) e2751)) (wrap-marks2107 w2749))))) (id?2104 (lambda (x2752) (if (symbol? x2752) #t (if (syntax-object?2088 x2752) (symbol? (let ((e2753 (syntax-object-expression2089 x2752))) (if (annotation? e2753) (annotation-expression e2753) e2753))) (if (annotation? x2752) (symbol? (annotation-expression x2752)) #f))))) (nonsymbol-id?2103 (lambda (x2754) (if (syntax-object?2088 x2754) (symbol? (let ((e2755 (syntax-object-expression2089 x2754))) (if (annotation? e2755) (annotation-expression e2755) e2755))) #f))) (global-extend2102 (lambda (type2756 sym2757 val2758) (put-global-definition-hook2069 sym2757 type2756 val2758))) (lookup2101 (lambda (x2759 r2760 mod2761) (let ((temp2762 (assq x2759 r2760))) (if temp2762 (cdr temp2762) (if (symbol? x2759) (let ((t2763 (get-global-definition-hook2070 x2759 mod2761))) (if t2763 t2763 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env2100 (lambda (r2764) (if (null? r2764) (quote ()) (let ((a2765 (car r2764))) (if (eq? (cadr a2765) (quote macro)) (cons a2765 (macros-only-env2100 (cdr r2764))) (macros-only-env2100 (cdr r2764))))))) (extend-var-env2099 (lambda (labels2766 vars2767 r2768) (if (null? labels2766) r2768 (extend-var-env2099 (cdr labels2766) (cdr vars2767) (cons (cons (car labels2766) (cons (quote lexical) (car vars2767))) r2768))))) (extend-env2098 (lambda (labels2769 bindings2770 r2771) (if (null? labels2769) r2771 (extend-env2098 (cdr labels2769) (cdr bindings2770) (cons (cons (car labels2769) (car bindings2770)) r2771))))) (binding-value2097 cdr) (binding-type2096 car) (source-annotation2095 (lambda (x2772) (if (annotation? x2772) (annotation-source x2772) (if (syntax-object?2088 x2772) (source-annotation2095 (syntax-object-expression2089 x2772)) #f)))) (set-syntax-object-module!2094 (lambda (x2773 update2774) (vector-set! x2773 3 update2774))) (set-syntax-object-wrap!2093 (lambda (x2775 update2776) (vector-set! x2775 2 update2776))) (set-syntax-object-expression!2092 (lambda (x2777 update2778) (vector-set! x2777 1 update2778))) (syntax-object-module2091 (lambda (x2779) (vector-ref x2779 3))) (syntax-object-wrap2090 (lambda (x2780) (vector-ref x2780 2))) (syntax-object-expression2089 (lambda (x2781) (vector-ref x2781 1))) (syntax-object?2088 (lambda (x2782) (if (vector? x2782) (if (= (vector-length x2782) 4) (eq? (vector-ref x2782 0) (quote syntax-object)) #f) #f))) (make-syntax-object2087 (lambda (expression2783 wrap2784 module2785) (vector (quote syntax-object) expression2783 wrap2784 module2785))) (build-letrec2086 (lambda (src2786 ids2787 vars2788 val-exps2789 body-exp2790) (if (null? vars2788) body-exp2790 (let ((atom-key2791 (fluid-ref *mode*2062))) (if (memv atom-key2791 (quote (c))) ((@ (language tree-il) make-letrec) src2786 ids2787 vars2788 val-exps2789 body-exp2790) (list (quote letrec) (map list vars2788 val-exps2789) body-exp2790)))))) (build-named-let2085 (lambda (src2792 ids2793 vars2794 val-exps2795 body-exp2796) (let ((f2797 (car vars2794)) (f-name2798 (car ids2793)) (vars2799 (cdr vars2794)) (ids2800 (cdr ids2793))) (let ((atom-key2801 (fluid-ref *mode*2062))) (if (memv atom-key2801 (quote (c))) ((@ (language tree-il) make-letrec) src2792 (list f-name2798) (list f2797) (list (build-lambda2080 src2792 ids2800 vars2799 #f body-exp2796)) (build-application2072 src2792 (build-lexical-reference2074 (quote fun) src2792 f-name2798 f2797) val-exps2795)) (list (quote let) f2797 (map list vars2799 val-exps2795) body-exp2796)))))) (build-let2084 (lambda (src2802 ids2803 vars2804 val-exps2805 body-exp2806) (if (null? vars2804) body-exp2806 (let ((atom-key2807 (fluid-ref *mode*2062))) (if (memv atom-key2807 (quote (c))) ((@ (language tree-il) make-let) src2802 ids2803 vars2804 val-exps2805 body-exp2806) (list (quote let) (map list vars2804 val-exps2805) body-exp2806)))))) (build-sequence2083 (lambda (src2808 exps2809) (if (null? (cdr exps2809)) (car exps2809) (let ((atom-key2810 (fluid-ref *mode*2062))) (if (memv atom-key2810 (quote (c))) ((@ (language tree-il) make-sequence) src2808 exps2809) (cons (quote begin) exps2809)))))) (build-data2082 (lambda (src2811 exp2812) (let ((atom-key2813 (fluid-ref *mode*2062))) (if (memv atom-key2813 (quote (c))) ((@ (language tree-il) make-const) src2811 exp2812) (if (if (self-evaluating? exp2812) (not (vector? exp2812)) #f) exp2812 (list (quote quote) exp2812)))))) (build-primref2081 (lambda (src2814 name2815) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2816 (fluid-ref *mode*2062))) (if (memv atom-key2816 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2814 name2815) name2815)) (let ((atom-key2817 (fluid-ref *mode*2062))) (if (memv atom-key2817 (quote (c))) ((@ (language tree-il) make-module-ref) src2814 (quote (guile)) name2815 #f) (list (quote @@) (quote (guile)) name2815)))))) (build-lambda2080 (lambda (src2818 ids2819 vars2820 docstring2821 exp2822) (let ((atom-key2823 (fluid-ref *mode*2062))) (if (memv atom-key2823 (quote (c))) ((@ (language tree-il) make-lambda) src2818 ids2819 vars2820 (if docstring2821 (list (cons (quote documentation) docstring2821)) (quote ())) exp2822) (cons (quote lambda) (cons vars2820 (append (if docstring2821 (list docstring2821) (quote ())) (list exp2822)))))))) (build-global-definition2079 (lambda (source2824 var2825 exp2826) (let ((atom-key2827 (fluid-ref *mode*2062))) (if (memv atom-key2827 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2824 var2825 exp2826) (list (quote define) var2825 exp2826))))) (build-global-assignment2078 (lambda (source2828 var2829 exp2830 mod2831) (analyze-variable2076 mod2831 var2829 (lambda (mod2832 var2833 public?2834) (let ((atom-key2835 (fluid-ref *mode*2062))) (if (memv atom-key2835 (quote (c))) ((@ (language tree-il) make-module-set) source2828 mod2832 var2833 public?2834 exp2830) (list (quote set!) (list (if public?2834 (quote @) (quote @@)) mod2832 var2833) exp2830)))) (lambda (var2836) (let ((atom-key2837 (fluid-ref *mode*2062))) (if (memv atom-key2837 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2828 var2836 exp2830) (list (quote set!) var2836 exp2830))))))) (build-global-reference2077 (lambda (source2838 var2839 mod2840) (analyze-variable2076 mod2840 var2839 (lambda (mod2841 var2842 public?2843) (let ((atom-key2844 (fluid-ref *mode*2062))) (if (memv atom-key2844 (quote (c))) ((@ (language tree-il) make-module-ref) source2838 mod2841 var2842 public?2843) (list (if public?2843 (quote @) (quote @@)) mod2841 var2842)))) (lambda (var2845) (let ((atom-key2846 (fluid-ref *mode*2062))) (if (memv atom-key2846 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2838 var2845) var2845)))))) (analyze-variable2076 (lambda (mod2847 var2848 modref-cont2849 bare-cont2850) (if (not mod2847) (bare-cont2850 var2848) (let ((kind2851 (car mod2847)) (mod2852 (cdr mod2847))) (if (memv kind2851 (quote (public))) (modref-cont2849 mod2852 var2848 #t) (if (memv kind2851 (quote (private))) (if (not (equal? mod2852 (module-name (current-module)))) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (if (memv kind2851 (quote (bare))) (bare-cont2850 var2848) (if (memv kind2851 (quote (hygiene))) (if (if (not (equal? mod2852 (module-name (current-module)))) (module-variable (resolve-module mod2852) var2848) #f) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (syntax-violation #f "bad module kind" var2848 mod2852))))))))) (build-lexical-assignment2075 (lambda (source2853 name2854 var2855 exp2856) (let ((atom-key2857 (fluid-ref *mode*2062))) (if (memv atom-key2857 (quote (c))) ((@ (language tree-il) make-lexical-set) source2853 name2854 var2855 exp2856) (list (quote set!) var2855 exp2856))))) (build-lexical-reference2074 (lambda (type2858 source2859 name2860 var2861) (let ((atom-key2862 (fluid-ref *mode*2062))) (if (memv atom-key2862 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2859 name2860 var2861) var2861)))) (build-conditional2073 (lambda (source2863 test-exp2864 then-exp2865 else-exp2866) (let ((atom-key2867 (fluid-ref *mode*2062))) (if (memv atom-key2867 (quote (c))) ((@ (language tree-il) make-conditional) source2863 test-exp2864 then-exp2865 else-exp2866) (list (quote if) test-exp2864 then-exp2865 else-exp2866))))) (build-application2072 (lambda (source2868 fun-exp2869 arg-exps2870) (let ((atom-key2871 (fluid-ref *mode*2062))) (if (memv atom-key2871 (quote (c))) ((@ (language tree-il) make-application) source2868 fun-exp2869 arg-exps2870) (cons fun-exp2869 arg-exps2870))))) (build-void2071 (lambda (source2872) (let ((atom-key2873 (fluid-ref *mode*2062))) (if (memv atom-key2873 (quote (c))) ((@ (language tree-il) make-void) source2872) (quote (if #f #f)))))) (get-global-definition-hook2070 (lambda (symbol2874 module2875) (begin (if (if (not module2875) (current-module) #f) (warn "module system is booted, we should have a module" symbol2874) (if #f #f)) (let ((v2876 (module-variable (if module2875 (resolve-module (cdr module2875)) (current-module)) symbol2874))) (if v2876 (if (variable-bound? v2876) (let ((val2877 (variable-ref v2876))) (if (macro? val2877) (if (syncase-macro-type val2877) (cons (syncase-macro-type val2877) (syncase-macro-binding val2877)) #f) #f)) #f) #f))))) (put-global-definition-hook2069 (lambda (symbol2878 type2879 val2880) (let ((existing2881 (let ((v2882 (module-variable (current-module) symbol2878))) (if v2882 (if (variable-bound? v2882) (let ((val2883 (variable-ref v2882))) (if (macro? val2883) (if (not (syncase-macro-type val2883)) val2883 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2878 (if existing2881 (make-extended-syncase-macro existing2881 type2879 val2880) (make-syncase-macro type2879 val2880)))))) (local-eval-hook2068 (lambda (x2884 mod2885) (primitive-eval (list noexpand2061 (let ((atom-key2886 (fluid-ref *mode*2062))) (if (memv atom-key2886 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2884) x2884)))))) (top-level-eval-hook2067 (lambda (x2887 mod2888) (primitive-eval (list noexpand2061 (let ((atom-key2889 (fluid-ref *mode*2062))) (if (memv atom-key2889 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2887) x2887)))))) (fx<2066 <) (fx=2065 =) (fx-2064 -) (fx+2063 +) (*mode*2062 (make-fluid)) (noexpand2061 "noexpand")) (begin (global-extend2102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend2102 (quote local-syntax) (quote let-syntax) #f) (global-extend2102 (quote core) (quote fluid-let-syntax) (lambda (e2890 r2891 w2892 s2893 mod2894) ((lambda (tmp2895) ((lambda (tmp2896) (if (if tmp2896 (apply (lambda (_2897 var2898 val2899 e12900 e22901) (valid-bound-ids?2129 var2898)) tmp2896) #f) (apply (lambda (_2903 var2904 val2905 e12906 e22907) (let ((names2908 (map (lambda (x2909) (id-var-name2126 x2909 w2892)) var2904))) (begin (for-each (lambda (id2911 n2912) (let ((atom-key2913 (binding-type2096 (lookup2101 n2912 r2891 mod2894)))) (if (memv atom-key2913 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2890 (source-wrap2133 id2911 w2892 s2893 mod2894)) (if #f #f)))) var2904 names2908) (chi-body2144 (cons e12906 e22907) (source-wrap2133 e2890 w2892 s2893 mod2894) (extend-env2098 names2908 (let ((trans-r2916 (macros-only-env2100 r2891))) (map (lambda (x2917) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2917 trans-r2916 w2892 mod2894) mod2894))) val2905)) r2891) w2892 mod2894)))) tmp2896) ((lambda (_2919) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap2133 e2890 w2892 s2893 mod2894))) tmp2895))) ($sc-dispatch tmp2895 (quote (any #(each (any any)) any . each-any))))) e2890))) (global-extend2102 (quote core) (quote quote) (lambda (e2920 r2921 w2922 s2923 mod2924) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 e2928) (build-data2082 s2923 (strip2151 e2928 w2922))) tmp2926) ((lambda (_2929) (syntax-violation (quote quote) "bad syntax" (source-wrap2133 e2920 w2922 s2923 mod2924))) tmp2925))) ($sc-dispatch tmp2925 (quote (any any))))) e2920))) (global-extend2102 (quote core) (quote syntax) (letrec ((regen2937 (lambda (x2938) (let ((atom-key2939 (car x2938))) (if (memv atom-key2939 (quote (ref))) (build-lexical-reference2074 (quote value) #f (cadr x2938) (cadr x2938)) (if (memv atom-key2939 (quote (primitive))) (build-primref2081 #f (cadr x2938)) (if (memv atom-key2939 (quote (quote))) (build-data2082 #f (cadr x2938)) (if (memv atom-key2939 (quote (lambda))) (build-lambda2080 #f (cadr x2938) (cadr x2938) #f (regen2937 (caddr x2938))) (if (memv atom-key2939 (quote (map))) (let ((ls2940 (map regen2937 (cdr x2938)))) (build-application2072 #f (build-primref2081 #f (quote map)) ls2940)) (build-application2072 #f (build-primref2081 #f (car x2938)) (map regen2937 (cdr x2938))))))))))) (gen-vector2936 (lambda (x2941) (if (eq? (car x2941) (quote list)) (cons (quote vector) (cdr x2941)) (if (eq? (car x2941) (quote quote)) (list (quote quote) (list->vector (cadr x2941))) (list (quote list->vector) x2941))))) (gen-append2935 (lambda (x2942 y2943) (if (equal? y2943 (quote (quote ()))) x2942 (list (quote append) x2942 y2943)))) (gen-cons2934 (lambda (x2944 y2945) (let ((atom-key2946 (car y2945))) (if (memv atom-key2946 (quote (quote))) (if (eq? (car x2944) (quote quote)) (list (quote quote) (cons (cadr x2944) (cadr y2945))) (if (eq? (cadr y2945) (quote ())) (list (quote list) x2944) (list (quote cons) x2944 y2945))) (if (memv atom-key2946 (quote (list))) (cons (quote list) (cons x2944 (cdr y2945))) (list (quote cons) x2944 y2945)))))) (gen-map2933 (lambda (e2947 map-env2948) (let ((formals2949 (map cdr map-env2948)) (actuals2950 (map (lambda (x2951) (list (quote ref) (car x2951))) map-env2948))) (if (eq? (car e2947) (quote ref)) (car actuals2950) (if (and-map (lambda (x2952) (if (eq? (car x2952) (quote ref)) (memq (cadr x2952) formals2949) #f)) (cdr e2947)) (cons (quote map) (cons (list (quote primitive) (car e2947)) (map (let ((r2953 (map cons formals2949 actuals2950))) (lambda (x2954) (cdr (assq (cadr x2954) r2953)))) (cdr e2947)))) (cons (quote map) (cons (list (quote lambda) formals2949 e2947) actuals2950))))))) (gen-mappend2932 (lambda (e2955 map-env2956) (list (quote apply) (quote (primitive append)) (gen-map2933 e2955 map-env2956)))) (gen-ref2931 (lambda (src2957 var2958 level2959 maps2960) (if (fx=2065 level2959 0) (values var2958 maps2960) (if (null? maps2960) (syntax-violation (quote syntax) "missing ellipsis" src2957) (call-with-values (lambda () (gen-ref2931 src2957 var2958 (fx-2064 level2959 1) (cdr maps2960))) (lambda (outer-var2961 outer-maps2962) (let ((b2963 (assq outer-var2961 (car maps2960)))) (if b2963 (values (cdr b2963) maps2960) (let ((inner-var2964 (gen-var2152 (quote tmp)))) (values inner-var2964 (cons (cons (cons outer-var2961 inner-var2964) (car maps2960)) outer-maps2962))))))))))) (gen-syntax2930 (lambda (src2965 e2966 r2967 maps2968 ellipsis?2969 mod2970) (if (id?2104 e2966) (let ((label2971 (id-var-name2126 e2966 (quote (()))))) (let ((b2972 (lookup2101 label2971 r2967 mod2970))) (if (eq? (binding-type2096 b2972) (quote syntax)) (call-with-values (lambda () (let ((var.lev2973 (binding-value2097 b2972))) (gen-ref2931 src2965 (car var.lev2973) (cdr var.lev2973) maps2968))) (lambda (var2974 maps2975) (values (list (quote ref) var2974) maps2975))) (if (ellipsis?2969 e2966) (syntax-violation (quote syntax) "misplaced ellipsis" src2965) (values (list (quote quote) e2966) maps2968))))) ((lambda (tmp2976) ((lambda (tmp2977) (if (if tmp2977 (apply (lambda (dots2978 e2979) (ellipsis?2969 dots2978)) tmp2977) #f) (apply (lambda (dots2980 e2981) (gen-syntax2930 src2965 e2981 r2967 maps2968 (lambda (x2982) #f) mod2970)) tmp2977) ((lambda (tmp2983) (if (if tmp2983 (apply (lambda (x2984 dots2985 y2986) (ellipsis?2969 dots2985)) tmp2983) #f) (apply (lambda (x2987 dots2988 y2989) (letrec ((f2990 (lambda (y2991 k2992) ((lambda (tmp2996) ((lambda (tmp2997) (if (if tmp2997 (apply (lambda (dots2998 y2999) (ellipsis?2969 dots2998)) tmp2997) #f) (apply (lambda (dots3000 y3001) (f2990 y3001 (lambda (maps3002) (call-with-values (lambda () (k2992 (cons (quote ()) maps3002))) (lambda (x3003 maps3004) (if (null? (car maps3004)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-mappend2932 x3003 (car maps3004)) (cdr maps3004)))))))) tmp2997) ((lambda (_3005) (call-with-values (lambda () (gen-syntax2930 src2965 y2991 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (y3006 maps3007) (call-with-values (lambda () (k2992 maps3007)) (lambda (x3008 maps3009) (values (gen-append2935 x3008 y3006) maps3009)))))) tmp2996))) ($sc-dispatch tmp2996 (quote (any . any))))) y2991)))) (f2990 y2989 (lambda (maps2993) (call-with-values (lambda () (gen-syntax2930 src2965 x2987 r2967 (cons (quote ()) maps2993) ellipsis?2969 mod2970)) (lambda (x2994 maps2995) (if (null? (car maps2995)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-map2933 x2994 (car maps2995)) (cdr maps2995))))))))) tmp2983) ((lambda (tmp3010) (if tmp3010 (apply (lambda (x3011 y3012) (call-with-values (lambda () (gen-syntax2930 src2965 x3011 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (x3013 maps3014) (call-with-values (lambda () (gen-syntax2930 src2965 y3012 r2967 maps3014 ellipsis?2969 mod2970)) (lambda (y3015 maps3016) (values (gen-cons2934 x3013 y3015) maps3016)))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (e13018 e23019) (call-with-values (lambda () (gen-syntax2930 src2965 (cons e13018 e23019) r2967 maps2968 ellipsis?2969 mod2970)) (lambda (e3021 maps3022) (values (gen-vector2936 e3021) maps3022)))) tmp3017) ((lambda (_3023) (values (list (quote quote) e2966) maps2968)) tmp2976))) ($sc-dispatch tmp2976 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2976 (quote (any . any)))))) ($sc-dispatch tmp2976 (quote (any any . any)))))) ($sc-dispatch tmp2976 (quote (any any))))) e2966))))) (lambda (e3024 r3025 w3026 s3027 mod3028) (let ((e3029 (source-wrap2133 e3024 w3026 s3027 mod3028))) ((lambda (tmp3030) ((lambda (tmp3031) (if tmp3031 (apply (lambda (_3032 x3033) (call-with-values (lambda () (gen-syntax2930 e3029 x3033 r3025 (quote ()) ellipsis?2149 mod3028)) (lambda (e3034 maps3035) (regen2937 e3034)))) tmp3031) ((lambda (_3036) (syntax-violation (quote syntax) "bad `syntax' form" e3029)) tmp3030))) ($sc-dispatch tmp3030 (quote (any any))))) e3029))))) (global-extend2102 (quote core) (quote lambda) (lambda (e3037 r3038 w3039 s3040 mod3041) ((lambda (tmp3042) ((lambda (tmp3043) (if tmp3043 (apply (lambda (_3044 c3045) (chi-lambda-clause2145 (source-wrap2133 e3037 w3039 s3040 mod3041) #f c3045 r3038 w3039 mod3041 (lambda (names3046 vars3047 docstring3048 body3049) (build-lambda2080 s3040 names3046 vars3047 docstring3048 body3049)))) tmp3043) (syntax-violation #f "source expression failed to match any pattern" tmp3042))) ($sc-dispatch tmp3042 (quote (any . any))))) e3037))) (global-extend2102 (quote core) (quote let) (letrec ((chi-let3050 (lambda (e3051 r3052 w3053 s3054 mod3055 constructor3056 ids3057 vals3058 exps3059) (if (not (valid-bound-ids?2129 ids3057)) (syntax-violation (quote let) "duplicate bound variable" e3051) (let ((labels3060 (gen-labels2110 ids3057)) (new-vars3061 (map gen-var2152 ids3057))) (let ((nw3062 (make-binding-wrap2121 ids3057 labels3060 w3053)) (nr3063 (extend-var-env2099 labels3060 new-vars3061 r3052))) (constructor3056 s3054 (map syntax->datum ids3057) new-vars3061 (map (lambda (x3064) (chi2140 x3064 r3052 w3053 mod3055)) vals3058) (chi-body2144 exps3059 (source-wrap2133 e3051 nw3062 s3054 mod3055) nr3063 nw3062 mod3055)))))))) (lambda (e3065 r3066 w3067 s3068 mod3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (_3072 id3073 val3074 e13075 e23076) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-let2084 id3073 val3074 (cons e13075 e23076))) tmp3071) ((lambda (tmp3080) (if (if tmp3080 (apply (lambda (_3081 f3082 id3083 val3084 e13085 e23086) (id?2104 f3082)) tmp3080) #f) (apply (lambda (_3087 f3088 id3089 val3090 e13091 e23092) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-named-let2085 (cons f3088 id3089) val3090 (cons e13091 e23092))) tmp3080) ((lambda (_3096) (syntax-violation (quote let) "bad let" (source-wrap2133 e3065 w3067 s3068 mod3069))) tmp3070))) ($sc-dispatch tmp3070 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3070 (quote (any #(each (any any)) any . each-any))))) e3065)))) (global-extend2102 (quote core) (quote letrec) (lambda (e3097 r3098 w3099 s3100 mod3101) ((lambda (tmp3102) ((lambda (tmp3103) (if tmp3103 (apply (lambda (_3104 id3105 val3106 e13107 e23108) (let ((ids3109 id3105)) (if (not (valid-bound-ids?2129 ids3109)) (syntax-violation (quote letrec) "duplicate bound variable" e3097) (let ((labels3111 (gen-labels2110 ids3109)) (new-vars3112 (map gen-var2152 ids3109))) (let ((w3113 (make-binding-wrap2121 ids3109 labels3111 w3099)) (r3114 (extend-var-env2099 labels3111 new-vars3112 r3098))) (build-letrec2086 s3100 (map syntax->datum ids3109) new-vars3112 (map (lambda (x3115) (chi2140 x3115 r3114 w3113 mod3101)) val3106) (chi-body2144 (cons e13107 e23108) (source-wrap2133 e3097 w3113 s3100 mod3101) r3114 w3113 mod3101))))))) tmp3103) ((lambda (_3118) (syntax-violation (quote letrec) "bad letrec" (source-wrap2133 e3097 w3099 s3100 mod3101))) tmp3102))) ($sc-dispatch tmp3102 (quote (any #(each (any any)) any . each-any))))) e3097))) (global-extend2102 (quote core) (quote set!) (lambda (e3119 r3120 w3121 s3122 mod3123) ((lambda (tmp3124) ((lambda (tmp3125) (if (if tmp3125 (apply (lambda (_3126 id3127 val3128) (id?2104 id3127)) tmp3125) #f) (apply (lambda (_3129 id3130 val3131) (let ((val3132 (chi2140 val3131 r3120 w3121 mod3123)) (n3133 (id-var-name2126 id3130 w3121))) (let ((b3134 (lookup2101 n3133 r3120 mod3123))) (let ((atom-key3135 (binding-type2096 b3134))) (if (memv atom-key3135 (quote (lexical))) (build-lexical-assignment2075 s3122 (syntax->datum id3130) (binding-value2097 b3134) val3132) (if (memv atom-key3135 (quote (global))) (build-global-assignment2078 s3122 n3133 val3132 mod3123) (if (memv atom-key3135 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap2132 id3130 w3121 mod3123)) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))))))))) tmp3125) ((lambda (tmp3136) (if tmp3136 (apply (lambda (_3137 head3138 tail3139 val3140) (call-with-values (lambda () (syntax-type2138 head3138 r3120 (quote (())) #f #f mod3123)) (lambda (type3141 value3142 ee3143 ww3144 ss3145 modmod3146) (if (memv type3141 (quote (module-ref))) (let ((val3147 (chi2140 val3140 r3120 w3121 mod3123))) (call-with-values (lambda () (value3142 (cons head3138 tail3139))) (lambda (id3149 mod3150) (build-global-assignment2078 s3122 id3149 val3147 mod3150)))) (build-application2072 s3122 (chi2140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head3138) r3120 w3121 mod3123) (map (lambda (e3151) (chi2140 e3151 r3120 w3121 mod3123)) (append tail3139 (list val3140)))))))) tmp3136) ((lambda (_3153) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))) tmp3124))) ($sc-dispatch tmp3124 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp3124 (quote (any any any))))) e3119))) (global-extend2102 (quote module-ref) (quote @) (lambda (e3154) ((lambda (tmp3155) ((lambda (tmp3156) (if (if tmp3156 (apply (lambda (_3157 mod3158 id3159) (if (and-map id?2104 mod3158) (id?2104 id3159) #f)) tmp3156) #f) (apply (lambda (_3161 mod3162 id3163) (values (syntax->datum id3163) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3162)))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any each-any any))))) e3154))) (global-extend2102 (quote module-ref) (quote @@) (lambda (e3165) ((lambda (tmp3166) ((lambda (tmp3167) (if (if tmp3167 (apply (lambda (_3168 mod3169 id3170) (if (and-map id?2104 mod3169) (id?2104 id3170) #f)) tmp3167) #f) (apply (lambda (_3172 mod3173 id3174) (values (syntax->datum id3174) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3173)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any each-any any))))) e3165))) (global-extend2102 (quote core) (quote if) (lambda (e3176 r3177 w3178 s3179 mod3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 test3184 then3185) (build-conditional2073 s3179 (chi2140 test3184 r3177 w3178 mod3180) (chi2140 then3185 r3177 w3178 mod3180) (build-void2071 #f))) tmp3182) ((lambda (tmp3186) (if tmp3186 (apply (lambda (_3187 test3188 then3189 else3190) (build-conditional2073 s3179 (chi2140 test3188 r3177 w3178 mod3180) (chi2140 then3189 r3177 w3178 mod3180) (chi2140 else3190 r3177 w3178 mod3180))) tmp3186) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any any any)))))) ($sc-dispatch tmp3181 (quote (any any any))))) e3176))) (global-extend2102 (quote begin) (quote begin) (quote ())) (global-extend2102 (quote define) (quote define) (quote ())) (global-extend2102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend2102 (quote eval-when) (quote eval-when) (quote ())) (global-extend2102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case3194 (lambda (x3195 keys3196 clauses3197 r3198 mod3199) (if (null? clauses3197) (build-application2072 #f (build-primref2081 #f (quote syntax-violation)) (list (build-data2082 #f #f) (build-data2082 #f "source expression failed to match any pattern") x3195)) ((lambda (tmp3200) ((lambda (tmp3201) (if tmp3201 (apply (lambda (pat3202 exp3203) (if (if (id?2104 pat3202) (and-map (lambda (x3204) (not (free-id=?2127 pat3202 x3204))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys3196)) #f) (let ((labels3205 (list (gen-label2109))) (var3206 (gen-var2152 pat3202))) (build-application2072 #f (build-lambda2080 #f (list (syntax->datum pat3202)) (list var3206) #f (chi2140 exp3203 (extend-env2098 labels3205 (list (cons (quote syntax) (cons var3206 0))) r3198) (make-binding-wrap2121 (list pat3202) labels3205 (quote (()))) mod3199)) (list x3195))) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3202 #t exp3203 mod3199))) tmp3201) ((lambda (tmp3207) (if tmp3207 (apply (lambda (pat3208 fender3209 exp3210) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3208 fender3209 exp3210 mod3199)) tmp3207) ((lambda (_3211) (syntax-violation (quote syntax-case) "invalid clause" (car clauses3197))) tmp3200))) ($sc-dispatch tmp3200 (quote (any any any)))))) ($sc-dispatch tmp3200 (quote (any any))))) (car clauses3197))))) (gen-clause3193 (lambda (x3212 keys3213 clauses3214 r3215 pat3216 fender3217 exp3218 mod3219) (call-with-values (lambda () (convert-pattern3191 pat3216 keys3213)) (lambda (p3220 pvars3221) (if (not (distinct-bound-ids?2130 (map car pvars3221))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat3216) (if (not (and-map (lambda (x3222) (not (ellipsis?2149 (car x3222)))) pvars3221)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat3216) (let ((y3223 (gen-var2152 (quote tmp)))) (build-application2072 #f (build-lambda2080 #f (list (quote tmp)) (list y3223) #f (let ((y3224 (build-lexical-reference2074 (quote value) #f (quote tmp) y3223))) (build-conditional2073 #f ((lambda (tmp3225) ((lambda (tmp3226) (if tmp3226 (apply (lambda () y3224) tmp3226) ((lambda (_3227) (build-conditional2073 #f y3224 (build-dispatch-call3192 pvars3221 fender3217 y3224 r3215 mod3219) (build-data2082 #f #f))) tmp3225))) ($sc-dispatch tmp3225 (quote #(atom #t))))) fender3217) (build-dispatch-call3192 pvars3221 exp3218 y3224 r3215 mod3219) (gen-syntax-case3194 x3212 keys3213 clauses3214 r3215 mod3219)))) (list (if (eq? p3220 (quote any)) (build-application2072 #f (build-primref2081 #f (quote list)) (list x3212)) (build-application2072 #f (build-primref2081 #f (quote $sc-dispatch)) (list x3212 (build-data2082 #f p3220))))))))))))) (build-dispatch-call3192 (lambda (pvars3228 exp3229 y3230 r3231 mod3232) (let ((ids3233 (map car pvars3228)) (levels3234 (map cdr pvars3228))) (let ((labels3235 (gen-labels2110 ids3233)) (new-vars3236 (map gen-var2152 ids3233))) (build-application2072 #f (build-primref2081 #f (quote apply)) (list (build-lambda2080 #f (map syntax->datum ids3233) new-vars3236 #f (chi2140 exp3229 (extend-env2098 labels3235 (map (lambda (var3237 level3238) (cons (quote syntax) (cons var3237 level3238))) new-vars3236 (map cdr pvars3228)) r3231) (make-binding-wrap2121 ids3233 labels3235 (quote (()))) mod3232)) y3230)))))) (convert-pattern3191 (lambda (pattern3239 keys3240) (letrec ((cvt3241 (lambda (p3242 n3243 ids3244) (if (id?2104 p3242) (if (bound-id-member?2131 p3242 keys3240) (values (vector (quote free-id) p3242) ids3244) (values (quote any) (cons (cons p3242 n3243) ids3244))) ((lambda (tmp3245) ((lambda (tmp3246) (if (if tmp3246 (apply (lambda (x3247 dots3248) (ellipsis?2149 dots3248)) tmp3246) #f) (apply (lambda (x3249 dots3250) (call-with-values (lambda () (cvt3241 x3249 (fx+2063 n3243 1) ids3244)) (lambda (p3251 ids3252) (values (if (eq? p3251 (quote any)) (quote each-any) (vector (quote each) p3251)) ids3252)))) tmp3246) ((lambda (tmp3253) (if tmp3253 (apply (lambda (x3254 y3255) (call-with-values (lambda () (cvt3241 y3255 n3243 ids3244)) (lambda (y3256 ids3257) (call-with-values (lambda () (cvt3241 x3254 n3243 ids3257)) (lambda (x3258 ids3259) (values (cons x3258 y3256) ids3259)))))) tmp3253) ((lambda (tmp3260) (if tmp3260 (apply (lambda () (values (quote ()) ids3244)) tmp3260) ((lambda (tmp3261) (if tmp3261 (apply (lambda (x3262) (call-with-values (lambda () (cvt3241 x3262 n3243 ids3244)) (lambda (p3264 ids3265) (values (vector (quote vector) p3264) ids3265)))) tmp3261) ((lambda (x3266) (values (vector (quote atom) (strip2151 p3242 (quote (())))) ids3244)) tmp3245))) ($sc-dispatch tmp3245 (quote #(vector each-any)))))) ($sc-dispatch tmp3245 (quote ()))))) ($sc-dispatch tmp3245 (quote (any . any)))))) ($sc-dispatch tmp3245 (quote (any any))))) p3242))))) (cvt3241 pattern3239 0 (quote ())))))) (lambda (e3267 r3268 w3269 s3270 mod3271) (let ((e3272 (source-wrap2133 e3267 w3269 s3270 mod3271))) ((lambda (tmp3273) ((lambda (tmp3274) (if tmp3274 (apply (lambda (_3275 val3276 key3277 m3278) (if (and-map (lambda (x3279) (if (id?2104 x3279) (not (ellipsis?2149 x3279)) #f)) key3277) (let ((x3281 (gen-var2152 (quote tmp)))) (build-application2072 s3270 (build-lambda2080 #f (list (quote tmp)) (list x3281) #f (gen-syntax-case3194 (build-lexical-reference2074 (quote value) #f (quote tmp) x3281) key3277 m3278 r3268 mod3271)) (list (chi2140 val3276 r3268 (quote (())) mod3271)))) (syntax-violation (quote syntax-case) "invalid literals list" e3272))) tmp3274) (syntax-violation #f "source expression failed to match any pattern" tmp3273))) ($sc-dispatch tmp3273 (quote (any any each-any . each-any))))) e3272))))) (set! sc-expand (lambda (x3285 . rest3284) (if (if (pair? x3285) (equal? (car x3285) noexpand2061) #f) (cadr x3285) (let ((m3286 (if (null? rest3284) (quote e) (car rest3284))) (esew3287 (if (let ((t3288 (null? rest3284))) (if t3288 t3288 (null? (cdr rest3284)))) (quote (eval)) (cadr rest3284)))) (with-fluid* *mode*2062 m3286 (lambda () (chi-top2139 x3285 (quote ()) (quote ((top))) m3286 esew3287 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x3289) (nonsymbol-id?2103 x3289))) (set! datum->syntax (lambda (id3290 datum3291) (make-syntax-object2087 datum3291 (syntax-object-wrap2090 id3290) #f))) (set! syntax->datum (lambda (x3292) (strip2151 x3292 (quote (()))))) (set! generate-temporaries (lambda (ls3293) (begin (let ((x3294 ls3293)) (if (not (list? x3294)) (syntax-violation (quote generate-temporaries) "invalid argument" x3294) (if #f #f))) (map (lambda (x3295) (wrap2132 (gensym) (quote ((top))) #f)) ls3293)))) (set! free-identifier=? (lambda (x3296 y3297) (begin (let ((x3298 x3296)) (if (not (nonsymbol-id?2103 x3298)) (syntax-violation (quote free-identifier=?) "invalid argument" x3298) (if #f #f))) (let ((x3299 y3297)) (if (not (nonsymbol-id?2103 x3299)) (syntax-violation (quote free-identifier=?) "invalid argument" x3299) (if #f #f))) (free-id=?2127 x3296 y3297)))) (set! bound-identifier=? (lambda (x3300 y3301) (begin (let ((x3302 x3300)) (if (not (nonsymbol-id?2103 x3302)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3302) (if #f #f))) (let ((x3303 y3301)) (if (not (nonsymbol-id?2103 x3303)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3303) (if #f #f))) (bound-id=?2128 x3300 y3301)))) (set! syntax-violation (lambda (who3307 message3306 form3305 . subform3304) (begin (let ((x3308 who3307)) (if (not ((lambda (x3309) (let ((t3310 (not x3309))) (if t3310 t3310 (let ((t3311 (string? x3309))) (if t3311 t3311 (symbol? x3309)))))) x3308)) (syntax-violation (quote syntax-violation) "invalid argument" x3308) (if #f #f))) (let ((x3312 message3306)) (if (not (string? x3312)) (syntax-violation (quote syntax-violation) "invalid argument" x3312) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who3307 "~a: " "") "~a " (if (null? subform3304) "in ~a" "in subform `~s' of `~s'")) (let ((tail3313 (cons message3306 (map (lambda (x3314) (strip2151 x3314 (quote (())))) (append subform3304 (list form3305)))))) (if who3307 (cons who3307 tail3313) tail3313)) #f)))) (letrec ((match3319 (lambda (e3320 p3321 w3322 r3323 mod3324) (if (not r3323) #f (if (eq? p3321 (quote any)) (cons (wrap2132 e3320 w3322 mod3324) r3323) (if (syntax-object?2088 e3320) (match*3318 (let ((e3325 (syntax-object-expression2089 e3320))) (if (annotation? e3325) (annotation-expression e3325) e3325)) p3321 (join-wraps2123 w3322 (syntax-object-wrap2090 e3320)) r3323 (syntax-object-module2091 e3320)) (match*3318 (let ((e3326 e3320)) (if (annotation? e3326) (annotation-expression e3326) e3326)) p3321 w3322 r3323 mod3324)))))) (match*3318 (lambda (e3327 p3328 w3329 r3330 mod3331) (if (null? p3328) (if (null? e3327) r3330 #f) (if (pair? p3328) (if (pair? e3327) (match3319 (car e3327) (car p3328) w3329 (match3319 (cdr e3327) (cdr p3328) w3329 r3330 mod3331) mod3331) #f) (if (eq? p3328 (quote each-any)) (let ((l3332 (match-each-any3316 e3327 w3329 mod3331))) (if l3332 (cons l3332 r3330) #f)) (let ((atom-key3333 (vector-ref p3328 0))) (if (memv atom-key3333 (quote (each))) (if (null? e3327) (match-empty3317 (vector-ref p3328 1) r3330) (let ((l3334 (match-each3315 e3327 (vector-ref p3328 1) w3329 mod3331))) (if l3334 (letrec ((collect3335 (lambda (l3336) (if (null? (car l3336)) r3330 (cons (map car l3336) (collect3335 (map cdr l3336))))))) (collect3335 l3334)) #f))) (if (memv atom-key3333 (quote (free-id))) (if (id?2104 e3327) (if (free-id=?2127 (wrap2132 e3327 w3329 mod3331) (vector-ref p3328 1)) r3330 #f) #f) (if (memv atom-key3333 (quote (atom))) (if (equal? (vector-ref p3328 1) (strip2151 e3327 w3329)) r3330 #f) (if (memv atom-key3333 (quote (vector))) (if (vector? e3327) (match3319 (vector->list e3327) (vector-ref p3328 1) w3329 r3330 mod3331) #f) (if #f #f))))))))))) (match-empty3317 (lambda (p3337 r3338) (if (null? p3337) r3338 (if (eq? p3337 (quote any)) (cons (quote ()) r3338) (if (pair? p3337) (match-empty3317 (car p3337) (match-empty3317 (cdr p3337) r3338)) (if (eq? p3337 (quote each-any)) (cons (quote ()) r3338) (let ((atom-key3339 (vector-ref p3337 0))) (if (memv atom-key3339 (quote (each))) (match-empty3317 (vector-ref p3337 1) r3338) (if (memv atom-key3339 (quote (free-id atom))) r3338 (if (memv atom-key3339 (quote (vector))) (match-empty3317 (vector-ref p3337 1) r3338) (if #f #f))))))))))) (match-each-any3316 (lambda (e3340 w3341 mod3342) (if (annotation? e3340) (match-each-any3316 (annotation-expression e3340) w3341 mod3342) (if (pair? e3340) (let ((l3343 (match-each-any3316 (cdr e3340) w3341 mod3342))) (if l3343 (cons (wrap2132 (car e3340) w3341 mod3342) l3343) #f)) (if (null? e3340) (quote ()) (if (syntax-object?2088 e3340) (match-each-any3316 (syntax-object-expression2089 e3340) (join-wraps2123 w3341 (syntax-object-wrap2090 e3340)) mod3342) #f)))))) (match-each3315 (lambda (e3344 p3345 w3346 mod3347) (if (annotation? e3344) (match-each3315 (annotation-expression e3344) p3345 w3346 mod3347) (if (pair? e3344) (let ((first3348 (match3319 (car e3344) p3345 w3346 (quote ()) mod3347))) (if first3348 (let ((rest3349 (match-each3315 (cdr e3344) p3345 w3346 mod3347))) (if rest3349 (cons first3348 rest3349) #f)) #f)) (if (null? e3344) (quote ()) (if (syntax-object?2088 e3344) (match-each3315 (syntax-object-expression2089 e3344) p3345 (join-wraps2123 w3346 (syntax-object-wrap2090 e3344)) (syntax-object-module2091 e3344)) #f))))))) (set! $sc-dispatch (lambda (e3350 p3351) (if (eq? p3351 (quote any)) (list e3350) (if (syntax-object?2088 e3350) (match*3318 (let ((e3352 (syntax-object-expression2089 e3350))) (if (annotation? e3352) (annotation-expression e3352) e3352)) p3351 (syntax-object-wrap2090 e3350) (quote ()) (syntax-object-module2091 e3350)) (match*3318 (let ((e3353 e3350)) (if (annotation? e3353) (annotation-expression e3353) e3353)) p3351 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x3354) ((lambda (tmp3355) ((lambda (tmp3356) (if tmp3356 (apply (lambda (_3357 e13358 e23359) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13358 e23359))) tmp3356) ((lambda (tmp3361) (if tmp3361 (apply (lambda (_3362 out3363 in3364 e13365 e23366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3364 (quote ()) (list out3363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13365 e23366))))) tmp3361) ((lambda (tmp3368) (if tmp3368 (apply (lambda (_3369 out3370 in3371 e13372 e23373) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3371) (quote ()) (list out3370 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13372 e23373))))) tmp3368) (syntax-violation #f "source expression failed to match any pattern" tmp3355))) ($sc-dispatch tmp3355 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any () any . each-any))))) x3354)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3377) ((lambda (tmp3378) ((lambda (tmp3379) (if tmp3379 (apply (lambda (_3380 k3381 keyword3382 pattern3383 template3384) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k3381 (map (lambda (tmp3387 tmp3386) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3386) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3387))) template3384 pattern3383)))))) tmp3379) (syntax-violation #f "source expression failed to match any pattern" tmp3378))) ($sc-dispatch tmp3378 (quote (any each-any . #(each ((any . any) any))))))) x3377)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3388) ((lambda (tmp3389) ((lambda (tmp3390) (if (if tmp3390 (apply (lambda (let*3391 x3392 v3393 e13394 e23395) (and-map identifier? x3392)) tmp3390) #f) (apply (lambda (let*3397 x3398 v3399 e13400 e23401) (letrec ((f3402 (lambda (bindings3403) (if (null? bindings3403) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e13400 e23401))) ((lambda (tmp3407) ((lambda (tmp3408) (if tmp3408 (apply (lambda (body3409 binding3410) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding3410) body3409)) tmp3408) (syntax-violation #f "source expression failed to match any pattern" tmp3407))) ($sc-dispatch tmp3407 (quote (any any))))) (list (f3402 (cdr bindings3403)) (car bindings3403))))))) (f3402 (map list x3398 v3399)))) tmp3390) (syntax-violation #f "source expression failed to match any pattern" tmp3389))) ($sc-dispatch tmp3389 (quote (any #(each (any any)) any . each-any))))) x3388)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3411) ((lambda (tmp3412) ((lambda (tmp3413) (if tmp3413 (apply (lambda (_3414 var3415 init3416 step3417 e03418 e13419 c3420) ((lambda (tmp3421) ((lambda (tmp3422) (if tmp3422 (apply (lambda (step3423) ((lambda (tmp3424) ((lambda (tmp3425) (if tmp3425 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3425) ((lambda (tmp3430) (if tmp3430 (apply (lambda (e13431 e23432) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e13431 e23432)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3430) (syntax-violation #f "source expression failed to match any pattern" tmp3424))) ($sc-dispatch tmp3424 (quote (any . each-any)))))) ($sc-dispatch tmp3424 (quote ())))) e13419)) tmp3422) (syntax-violation #f "source expression failed to match any pattern" tmp3421))) ($sc-dispatch tmp3421 (quote each-any)))) (map (lambda (v3439 s3440) ((lambda (tmp3441) ((lambda (tmp3442) (if tmp3442 (apply (lambda () v3439) tmp3442) ((lambda (tmp3443) (if tmp3443 (apply (lambda (e3444) e3444) tmp3443) ((lambda (_3445) (syntax-violation (quote do) "bad step expression" orig-x3411 s3440)) tmp3441))) ($sc-dispatch tmp3441 (quote (any)))))) ($sc-dispatch tmp3441 (quote ())))) s3440)) var3415 step3417))) tmp3413) (syntax-violation #f "source expression failed to match any pattern" tmp3412))) ($sc-dispatch tmp3412 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3411)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3448 (lambda (x3452 y3453) ((lambda (tmp3454) ((lambda (tmp3455) (if tmp3455 (apply (lambda (x3456 y3457) ((lambda (tmp3458) ((lambda (tmp3459) (if tmp3459 (apply (lambda (dy3460) ((lambda (tmp3461) ((lambda (tmp3462) (if tmp3462 (apply (lambda (dx3463) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx3463 dy3460))) tmp3462) ((lambda (_3464) (if (null? dy3460) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457))) tmp3461))) ($sc-dispatch tmp3461 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x3456)) tmp3459) ((lambda (tmp3465) (if tmp3465 (apply (lambda (stuff3466) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x3456 stuff3466))) tmp3465) ((lambda (else3467) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457)) tmp3458))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y3457)) tmp3455) (syntax-violation #f "source expression failed to match any pattern" tmp3454))) ($sc-dispatch tmp3454 (quote (any any))))) (list x3452 y3453)))) (quasiappend3449 (lambda (x3468 y3469) ((lambda (tmp3470) ((lambda (tmp3471) (if tmp3471 (apply (lambda (x3472 y3473) ((lambda (tmp3474) ((lambda (tmp3475) (if tmp3475 (apply (lambda () x3472) tmp3475) ((lambda (_3476) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3472 y3473)) tmp3474))) ($sc-dispatch tmp3474 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y3473)) tmp3471) (syntax-violation #f "source expression failed to match any pattern" tmp3470))) ($sc-dispatch tmp3470 (quote (any any))))) (list x3468 y3469)))) (quasivector3450 (lambda (x3477) ((lambda (tmp3478) ((lambda (x3479) ((lambda (tmp3480) ((lambda (tmp3481) (if tmp3481 (apply (lambda (x3482) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x3482))) tmp3481) ((lambda (tmp3484) (if tmp3484 (apply (lambda (x3485) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3485)) tmp3484) ((lambda (_3487) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3479)) tmp3480))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x3479)) tmp3478)) x3477))) (quasi3451 (lambda (p3488 lev3489) ((lambda (tmp3490) ((lambda (tmp3491) (if tmp3491 (apply (lambda (p3492) (if (= lev3489 0) p3492 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3492) (- lev3489 1))))) tmp3491) ((lambda (tmp3493) (if tmp3493 (apply (lambda (p3494 q3495) (if (= lev3489 0) (quasiappend3449 p3494 (quasi3451 q3495 lev3489)) (quasicons3448 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3494) (- lev3489 1))) (quasi3451 q3495 lev3489)))) tmp3493) ((lambda (tmp3496) (if tmp3496 (apply (lambda (p3497) (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3497) (+ lev3489 1)))) tmp3496) ((lambda (tmp3498) (if tmp3498 (apply (lambda (p3499 q3500) (quasicons3448 (quasi3451 p3499 lev3489) (quasi3451 q3500 lev3489))) tmp3498) ((lambda (tmp3501) (if tmp3501 (apply (lambda (x3502) (quasivector3450 (quasi3451 x3502 lev3489))) tmp3501) ((lambda (p3504) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p3504)) tmp3490))) ($sc-dispatch tmp3490 (quote #(vector each-any)))))) ($sc-dispatch tmp3490 (quote (any . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp3490 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p3488)))) (lambda (x3505) ((lambda (tmp3506) ((lambda (tmp3507) (if tmp3507 (apply (lambda (_3508 e3509) (quasi3451 e3509 0)) tmp3507) (syntax-violation #f "source expression failed to match any pattern" tmp3506))) ($sc-dispatch tmp3506 (quote (any any))))) x3505))))) -(define include (make-syncase-macro (quote macro) (lambda (x3510) (letrec ((read-file3511 (lambda (fn3512 k3513) (let ((p3514 (open-input-file fn3512))) (letrec ((f3515 (lambda (x3516) (if (eof-object? x3516) (begin (close-input-port p3514) (quote ())) (cons (datum->syntax k3513 x3516) (f3515 (read p3514))))))) (f3515 (read p3514))))))) ((lambda (tmp3517) ((lambda (tmp3518) (if tmp3518 (apply (lambda (k3519 filename3520) (let ((fn3521 (syntax->datum filename3520))) ((lambda (tmp3522) ((lambda (tmp3523) (if tmp3523 (apply (lambda (exp3524) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp3524)) tmp3523) (syntax-violation #f "source expression failed to match any pattern" tmp3522))) ($sc-dispatch tmp3522 (quote each-any)))) (read-file3511 fn3521 k3519)))) tmp3518) (syntax-violation #f "source expression failed to match any pattern" tmp3517))) ($sc-dispatch tmp3517 (quote (any any))))) x3510))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x3526) ((lambda (tmp3527) ((lambda (tmp3528) (if tmp3528 (apply (lambda (_3529 e3530) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x3526)) tmp3528) (syntax-violation #f "source expression failed to match any pattern" tmp3527))) ($sc-dispatch tmp3527 (quote (any any))))) x3526)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3531) ((lambda (tmp3532) ((lambda (tmp3533) (if tmp3533 (apply (lambda (_3534 e3535) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x3531)) tmp3533) (syntax-violation #f "source expression failed to match any pattern" tmp3532))) ($sc-dispatch tmp3532 (quote (any any))))) x3531)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3536) ((lambda (tmp3537) ((lambda (tmp3538) (if tmp3538 (apply (lambda (_3539 e3540 m13541 m23542) ((lambda (tmp3543) ((lambda (body3544) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3540)) body3544)) tmp3543)) (letrec ((f3545 (lambda (clause3546 clauses3547) (if (null? clauses3547) ((lambda (tmp3549) ((lambda (tmp3550) (if tmp3550 (apply (lambda (e13551 e23552) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13551 e23552))) tmp3550) ((lambda (tmp3554) (if tmp3554 (apply (lambda (k3555 e13556 e23557) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3555)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13556 e23557)))) tmp3554) ((lambda (_3560) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3549))) ($sc-dispatch tmp3549 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3549 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause3546) ((lambda (tmp3561) ((lambda (rest3562) ((lambda (tmp3563) ((lambda (tmp3564) (if tmp3564 (apply (lambda (k3565 e13566 e23567) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3565)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13566 e23567)) rest3562)) tmp3564) ((lambda (_3570) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3563))) ($sc-dispatch tmp3563 (quote (each-any any . each-any))))) clause3546)) tmp3561)) (f3545 (car clauses3547) (cdr clauses3547))))))) (f3545 m13541 m23542)))) tmp3538) (syntax-violation #f "source expression failed to match any pattern" tmp3537))) ($sc-dispatch tmp3537 (quote (any any any . each-any))))) x3536)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3571) ((lambda (tmp3572) ((lambda (tmp3573) (if tmp3573 (apply (lambda (_3574 e3575) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3575)) (list (cons _3574 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e3575 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp3573) (syntax-violation #f "source expression failed to match any pattern" tmp3572))) ($sc-dispatch tmp3572 (quote (any any))))) x3571)))) +(letrec ((and-map*2008 (lambda (f2048 first2047 . rest2046) (let ((t2049 (null? first2047))) (if t2049 t2049 (if (null? rest2046) (letrec ((andmap2050 (lambda (first2051) (let ((x2052 (car first2051)) (first2053 (cdr first2051))) (if (null? first2053) (f2048 x2052) (if (f2048 x2052) (andmap2050 first2053) #f)))))) (andmap2050 first2047)) (letrec ((andmap2054 (lambda (first2055 rest2056) (let ((x2057 (car first2055)) (xr2058 (map car rest2056)) (first2059 (cdr first2055)) (rest2060 (map cdr rest2056))) (if (null? first2059) (apply f2048 (cons x2057 xr2058)) (if (apply f2048 (cons x2057 xr2058)) (andmap2054 first2059 rest2060) #f)))))) (andmap2054 first2047 rest2046)))))))) (letrec ((lambda-var-list2153 (lambda (vars2282) (letrec ((lvl2283 (lambda (vars2284 ls2285 w2286) (if (pair? vars2284) (lvl2283 (cdr vars2284) (cons (wrap2132 (car vars2284) w2286 #f) ls2285) w2286) (if (id?2104 vars2284) (cons (wrap2132 vars2284 w2286 #f) ls2285) (if (null? vars2284) ls2285 (if (syntax-object?2088 vars2284) (lvl2283 (syntax-object-expression2089 vars2284) ls2285 (join-wraps2123 w2286 (syntax-object-wrap2090 vars2284))) (if (annotation? vars2284) (lvl2283 (annotation-expression vars2284) ls2285 w2286) (cons vars2284 ls2285))))))))) (lvl2283 vars2282 (quote ()) (quote (())))))) (gen-var2152 (lambda (id2287) (let ((id2288 (if (syntax-object?2088 id2287) (syntax-object-expression2089 id2287) id2287))) (if (annotation? id2288) (gensym (symbol->string (annotation-expression id2288))) (gensym (symbol->string id2288)))))) (strip2151 (lambda (x2289 w2290) (if (memq (quote top) (wrap-marks2107 w2290)) (if (let ((t2291 (annotation? x2289))) (if t2291 t2291 (if (pair? x2289) (annotation? (car x2289)) #f))) (strip-annotation2150 x2289 #f) x2289) (letrec ((f2292 (lambda (x2293) (if (syntax-object?2088 x2293) (strip2151 (syntax-object-expression2089 x2293) (syntax-object-wrap2090 x2293)) (if (pair? x2293) (let ((a2294 (f2292 (car x2293))) (d2295 (f2292 (cdr x2293)))) (if (if (eq? a2294 (car x2293)) (eq? d2295 (cdr x2293)) #f) x2293 (cons a2294 d2295))) (if (vector? x2293) (let ((old2296 (vector->list x2293))) (let ((new2297 (map f2292 old2296))) (if (and-map*2008 eq? old2296 new2297) x2293 (list->vector new2297)))) x2293)))))) (f2292 x2289))))) (strip-annotation2150 (lambda (x2298 parent2299) (if (pair? x2298) (let ((new2300 (cons #f #f))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2300) (if #f #f)) (set-car! new2300 (strip-annotation2150 (car x2298) #f)) (set-cdr! new2300 (strip-annotation2150 (cdr x2298) #f)) new2300)) (if (annotation? x2298) (let ((t2301 (annotation-stripped x2298))) (if t2301 t2301 (strip-annotation2150 (annotation-expression x2298) x2298))) (if (vector? x2298) (let ((new2302 (make-vector (vector-length x2298)))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2302) (if #f #f)) (letrec ((loop2303 (lambda (i2304) (unless (fx<2066 i2304 0) (vector-set! new2302 i2304 (strip-annotation2150 (vector-ref x2298 i2304) #f)) (loop2303 (fx-2064 i2304 1)))))) (loop2303 (- (vector-length x2298) 1))) new2302)) x2298))))) (ellipsis?2149 (lambda (x2305) (if (nonsymbol-id?2103 x2305) (free-id=?2127 x2305 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void2148 (lambda () (build-void2071 #f))) (eval-local-transformer2147 (lambda (expanded2306 mod2307) (let ((p2308 (local-eval-hook2068 expanded2306 mod2307))) (if (procedure? p2308) p2308 (syntax-violation #f "nonprocedure transformer" p2308))))) (chi-local-syntax2146 (lambda (rec?2309 e2310 r2311 w2312 s2313 mod2314 k2315) ((lambda (tmp2316) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 id2319 val2320 e12321 e22322) (let ((ids2323 id2319)) (if (not (valid-bound-ids?2129 ids2323)) (syntax-violation #f "duplicate bound keyword" e2310) (let ((labels2325 (gen-labels2110 ids2323))) (let ((new-w2326 (make-binding-wrap2121 ids2323 labels2325 w2312))) (k2315 (cons e12321 e22322) (extend-env2098 labels2325 (let ((w2328 (if rec?2309 new-w2326 w2312)) (trans-r2329 (macros-only-env2100 r2311))) (map (lambda (x2330) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2330 trans-r2329 w2328 mod2314) mod2314))) val2320)) r2311) new-w2326 s2313 mod2314)))))) tmp2317) ((lambda (_2332) (syntax-violation #f "bad local syntax definition" (source-wrap2133 e2310 w2312 s2313 mod2314))) tmp2316))) ($sc-dispatch tmp2316 (quote (any #(each (any any)) any . each-any))))) e2310))) (chi-lambda-clause2145 (lambda (e2333 docstring2334 c2335 r2336 w2337 mod2338 k2339) ((lambda (tmp2340) ((lambda (tmp2341) (if (if tmp2341 (apply (lambda (args2342 doc2343 e12344 e22345) (if (string? (syntax->datum doc2343)) (not docstring2334) #f)) tmp2341) #f) (apply (lambda (args2346 doc2347 e12348 e22349) (chi-lambda-clause2145 e2333 doc2347 (cons args2346 (cons e12348 e22349)) r2336 w2337 mod2338 k2339)) tmp2341) ((lambda (tmp2351) (if tmp2351 (apply (lambda (id2352 e12353 e22354) (let ((ids2355 id2352)) (if (not (valid-bound-ids?2129 ids2355)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2357 (gen-labels2110 ids2355)) (new-vars2358 (map gen-var2152 ids2355))) (k2339 (map syntax->datum ids2355) new-vars2358 (if docstring2334 (syntax->datum docstring2334) #f) (chi-body2144 (cons e12353 e22354) e2333 (extend-var-env2099 labels2357 new-vars2358 r2336) (make-binding-wrap2121 ids2355 labels2357 w2337) mod2338)))))) tmp2351) ((lambda (tmp2360) (if tmp2360 (apply (lambda (ids2361 e12362 e22363) (let ((old-ids2364 (lambda-var-list2153 ids2361))) (if (not (valid-bound-ids?2129 old-ids2364)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2365 (gen-labels2110 old-ids2364)) (new-vars2366 (map gen-var2152 old-ids2364))) (k2339 (letrec ((f2367 (lambda (ls12368 ls22369) (if (null? ls12368) (syntax->datum ls22369) (f2367 (cdr ls12368) (cons (syntax->datum (car ls12368)) ls22369)))))) (f2367 (cdr old-ids2364) (car old-ids2364))) (letrec ((f2370 (lambda (ls12371 ls22372) (if (null? ls12371) ls22372 (f2370 (cdr ls12371) (cons (car ls12371) ls22372)))))) (f2370 (cdr new-vars2366) (car new-vars2366))) (if docstring2334 (syntax->datum docstring2334) #f) (chi-body2144 (cons e12362 e22363) e2333 (extend-var-env2099 labels2365 new-vars2366 r2336) (make-binding-wrap2121 old-ids2364 labels2365 w2337) mod2338)))))) tmp2360) ((lambda (_2374) (syntax-violation (quote lambda) "bad lambda" e2333)) tmp2340))) ($sc-dispatch tmp2340 (quote (any any . each-any)))))) ($sc-dispatch tmp2340 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2340 (quote (any any any . each-any))))) c2335))) (chi-body2144 (lambda (body2375 outer-form2376 r2377 w2378 mod2379) (let ((r2380 (cons (quote ("placeholder" placeholder)) r2377))) (let ((ribcage2381 (make-ribcage2111 (quote ()) (quote ()) (quote ())))) (let ((w2382 (make-wrap2106 (wrap-marks2107 w2378) (cons ribcage2381 (wrap-subst2108 w2378))))) (letrec ((parse2383 (lambda (body2384 ids2385 labels2386 vars2387 vals2388 bindings2389) (if (null? body2384) (syntax-violation #f "no expressions in body" outer-form2376) (let ((e2391 (cdar body2384)) (er2392 (caar body2384))) (call-with-values (lambda () (syntax-type2138 e2391 er2392 (quote (())) #f ribcage2381 mod2379)) (lambda (type2393 value2394 e2395 w2396 s2397 mod2398) (if (memv type2393 (quote (define-form))) (let ((id2399 (wrap2132 value2394 w2396 mod2398)) (label2400 (gen-label2109))) (let ((var2401 (gen-var2152 id2399))) (begin (extend-ribcage!2120 ribcage2381 id2399 label2400) (parse2383 (cdr body2384) (cons id2399 ids2385) (cons label2400 labels2386) (cons var2401 vars2387) (cons (cons er2392 (wrap2132 e2395 w2396 mod2398)) vals2388) (cons (cons (quote lexical) var2401) bindings2389))))) (if (memv type2393 (quote (define-syntax-form))) (let ((id2402 (wrap2132 value2394 w2396 mod2398)) (label2403 (gen-label2109))) (begin (extend-ribcage!2120 ribcage2381 id2402 label2403) (parse2383 (cdr body2384) (cons id2402 ids2385) (cons label2403 labels2386) vars2387 vals2388 (cons (cons (quote macro) (cons er2392 (wrap2132 e2395 w2396 mod2398))) bindings2389)))) (if (memv type2393 (quote (begin-form))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 e12407) (parse2383 (letrec ((f2408 (lambda (forms2409) (if (null? forms2409) (cdr body2384) (cons (cons er2392 (wrap2132 (car forms2409) w2396 mod2398)) (f2408 (cdr forms2409))))))) (f2408 e12407)) ids2385 labels2386 vars2387 vals2388 bindings2389)) tmp2405) (syntax-violation #f "Source expression failed to match any pattern" tmp2404))) ($sc-dispatch tmp2404 (quote (any . each-any))))) e2395) (if (memv type2393 (quote (local-syntax-form))) (chi-local-syntax2146 value2394 e2395 er2392 w2396 s2397 mod2398 (lambda (forms2411 er2412 w2413 s2414 mod2415) (parse2383 (letrec ((f2416 (lambda (forms2417) (if (null? forms2417) (cdr body2384) (cons (cons er2412 (wrap2132 (car forms2417) w2413 mod2415)) (f2416 (cdr forms2417))))))) (f2416 forms2411)) ids2385 labels2386 vars2387 vals2388 bindings2389))) (if (null? ids2385) (build-sequence2083 #f (map (lambda (x2418) (chi2140 (cdr x2418) (car x2418) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))) (begin (if (not (valid-bound-ids?2129 ids2385)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form2376) (if #f #f)) (letrec ((loop2419 (lambda (bs2420 er-cache2421 r-cache2422) (if (not (null? bs2420)) (let ((b2423 (car bs2420))) (if (eq? (car b2423) (quote macro)) (let ((er2424 (cadr b2423))) (let ((r-cache2425 (if (eq? er2424 er-cache2421) r-cache2422 (macros-only-env2100 er2424)))) (begin (set-cdr! b2423 (eval-local-transformer2147 (chi2140 (cddr b2423) r-cache2425 (quote (())) mod2398) mod2398)) (loop2419 (cdr bs2420) er2424 r-cache2425)))) (loop2419 (cdr bs2420) er-cache2421 r-cache2422))) (if #f #f))))) (loop2419 bindings2389 #f #f)) (set-cdr! r2380 (extend-env2098 labels2386 bindings2389 (cdr r2380))) (build-letrec2086 #f (map syntax->datum ids2385) vars2387 (map (lambda (x2426) (chi2140 (cdr x2426) (car x2426) (quote (())) mod2398)) vals2388) (build-sequence2083 #f (map (lambda (x2427) (chi2140 (cdr x2427) (car x2427) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))))))))))))))))) (parse2383 (map (lambda (x2390) (cons r2380 (wrap2132 x2390 w2382 mod2379))) body2375) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro2143 (lambda (p2428 e2429 r2430 w2431 rib2432 mod2433) (letrec ((rebuild-macro-output2434 (lambda (x2435 m2436) (if (pair? x2435) (cons (rebuild-macro-output2434 (car x2435) m2436) (rebuild-macro-output2434 (cdr x2435) m2436)) (if (syntax-object?2088 x2435) (let ((w2437 (syntax-object-wrap2090 x2435))) (let ((ms2438 (wrap-marks2107 w2437)) (s2439 (wrap-subst2108 w2437))) (if (if (pair? ms2438) (eq? (car ms2438) #f) #f) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cdr ms2438) (if rib2432 (cons rib2432 (cdr s2439)) (cdr s2439))) (syntax-object-module2091 x2435)) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cons m2436 ms2438) (if rib2432 (cons rib2432 (cons (quote shift) s2439)) (cons (quote shift) s2439))) (let ((pmod2440 (procedure-module p2428))) (if pmod2440 (cons (quote hygiene) (module-name pmod2440)) (quote (hygiene guile)))))))) (if (vector? x2435) (let ((n2441 (vector-length x2435))) (let ((v2442 (make-vector n2441))) (letrec ((loop2443 (lambda (i2444) (if (fx=2065 i2444 n2441) (begin (if #f #f (if #f #f)) v2442) (begin (vector-set! v2442 i2444 (rebuild-macro-output2434 (vector-ref x2435 i2444) m2436)) (loop2443 (fx+2063 i2444 1))))))) (loop2443 0)))) (if (symbol? x2435) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap2133 e2429 w2431 s mod2433) x2435) x2435))))))) (rebuild-macro-output2434 (p2428 (wrap2132 e2429 (anti-mark2119 w2431) mod2433)) (string #\m))))) (chi-application2142 (lambda (x2445 e2446 r2447 w2448 s2449 mod2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (e02453 e12454) (build-application2072 s2449 x2445 (map (lambda (e2455) (chi2140 e2455 r2447 w2448 mod2450)) e12454))) tmp2452) (syntax-violation #f "Source expression failed to match any pattern" tmp2451))) ($sc-dispatch tmp2451 (quote (any . each-any))))) e2446))) (chi-expr2141 (lambda (type2457 value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (lexical))) (build-lexical-reference2074 (quote value) s2462 e2459 value2458) (if (memv type2457 (quote (core external-macro))) (value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (module-ref))) (call-with-values (lambda () (value2458 e2459)) (lambda (id2464 mod2465) (build-global-reference2077 s2462 id2464 mod2465))) (if (memv type2457 (quote (lexical-call))) (chi-application2142 (build-lexical-reference2074 (quote fun) (source-annotation2095 (car e2459)) (car e2459) value2458) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (global-call))) (chi-application2142 (build-global-reference2077 (source-annotation2095 (car e2459)) value2458 (if (syntax-object?2088 (car e2459)) (syntax-object-module2091 (car e2459)) mod2463)) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (constant))) (build-data2082 s2462 (strip2151 (source-wrap2133 e2459 w2461 s2462 mod2463) (quote (())))) (if (memv type2457 (quote (global))) (build-global-reference2077 s2462 value2458 mod2463) (if (memv type2457 (quote (call))) (chi-application2142 (chi2140 (car e2459) r2460 w2461 mod2463) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (begin-form))) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 e12469 e22470) (chi-sequence2134 (cons e12469 e22470) r2460 w2461 s2462 mod2463)) tmp2467) (syntax-violation #f "Source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any any . each-any))))) e2459) (if (memv type2457 (quote (local-syntax-form))) (chi-local-syntax2146 value2458 e2459 r2460 w2461 s2462 mod2463 chi-sequence2134) (if (memv type2457 (quote (eval-when-form))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (_2474 x2475 e12476 e22477) (let ((when-list2478 (chi-when-list2137 e2459 x2475 w2461))) (if (memq (quote eval) when-list2478) (chi-sequence2134 (cons e12476 e22477) r2460 w2461 s2462 mod2463) (chi-void2148)))) tmp2473) (syntax-violation #f "Source expression failed to match any pattern" tmp2472))) ($sc-dispatch tmp2472 (quote (any each-any any . each-any))))) e2459) (if (memv type2457 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e2459 (wrap2132 value2458 w2461 mod2463)) (if (memv type2457 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap2133 e2459 w2461 s2462 mod2463)) (if (memv type2457 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap2133 e2459 w2461 s2462 mod2463)) (syntax-violation #f "unexpected syntax" (source-wrap2133 e2459 w2461 s2462 mod2463)))))))))))))))))) (chi2140 (lambda (e2481 r2482 w2483 mod2484) (call-with-values (lambda () (syntax-type2138 e2481 r2482 w2483 #f #f mod2484)) (lambda (type2485 value2486 e2487 w2488 s2489 mod2490) (chi-expr2141 type2485 value2486 e2487 r2482 w2488 s2489 mod2490))))) (chi-top2139 (lambda (e2491 r2492 w2493 m2494 esew2495 mod2496) (call-with-values (lambda () (syntax-type2138 e2491 r2492 w2493 #f #f mod2496)) (lambda (type2504 value2505 e2506 w2507 s2508 mod2509) (if (memv type2504 (quote (begin-form))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (_2512) (chi-void2148)) tmp2511) ((lambda (tmp2513) (if tmp2513 (apply (lambda (_2514 e12515 e22516) (chi-top-sequence2135 (cons e12515 e22516) r2492 w2507 s2508 m2494 esew2495 mod2509)) tmp2513) (syntax-violation #f "Source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote (any any . each-any)))))) ($sc-dispatch tmp2510 (quote (any))))) e2506) (if (memv type2504 (quote (local-syntax-form))) (chi-local-syntax2146 value2505 e2506 r2492 w2507 s2508 mod2509 (lambda (body2518 r2519 w2520 s2521 mod2522) (chi-top-sequence2135 body2518 r2519 w2520 s2521 m2494 esew2495 mod2522))) (if (memv type2504 (quote (eval-when-form))) ((lambda (tmp2523) ((lambda (tmp2524) (if tmp2524 (apply (lambda (_2525 x2526 e12527 e22528) (let ((when-list2529 (chi-when-list2137 e2506 x2526 w2507)) (body2530 (cons e12527 e22528))) (if (eq? m2494 (quote e)) (if (memq (quote eval) when-list2529) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) (chi-void2148)) (if (memq (quote load) when-list2529) (if (let ((t2533 (memq (quote compile) when-list2529))) (if t2533 t2533 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c&e) (quote (compile load)) mod2509) (if (memq m2494 (quote (c c&e))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c) (quote (load)) mod2509) (chi-void2148))) (if (let ((t2534 (memq (quote compile) when-list2529))) (if t2534 t2534 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (begin (top-level-eval-hook2067 (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) mod2509) (chi-void2148)) (chi-void2148)))))) tmp2524) (syntax-violation #f "Source expression failed to match any pattern" tmp2523))) ($sc-dispatch tmp2523 (quote (any each-any any . each-any))))) e2506) (if (memv type2504 (quote (define-syntax-form))) (let ((n2535 (id-var-name2126 value2505 w2507)) (r2536 (macros-only-env2100 r2492))) (if (memv m2494 (quote (c))) (if (memq (quote compile) esew2495) (let ((e2537 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2537 mod2509) (if (memq (quote load) esew2495) e2537 (chi-void2148)))) (if (memq (quote load) esew2495) (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) (chi-void2148))) (if (memv m2494 (quote (c&e))) (let ((e2538 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2538 mod2509) e2538)) (begin (if (memq (quote eval) esew2495) (top-level-eval-hook2067 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) mod2509) (if #f #f)) (chi-void2148))))) (if (memv type2504 (quote (define-form))) (let ((n2539 (id-var-name2126 value2505 w2507))) (let ((type2540 (binding-type2096 (lookup2101 n2539 r2492 mod2509)))) (if (memv type2540 (quote (global core macro module-ref))) (let ((x2541 (build-global-definition2079 s2508 n2539 (chi2140 e2506 r2492 w2507 mod2509)))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2541 mod2509) (if #f #f)) x2541)) (if (memv type2540 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e2506 (wrap2132 value2505 w2507 mod2509)) (syntax-violation #f "cannot define keyword at top level" e2506 (wrap2132 value2505 w2507 mod2509)))))) (let ((x2542 (chi-expr2141 type2504 value2505 e2506 r2492 w2507 s2508 mod2509))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2542 mod2509) (if #f #f)) x2542))))))))))) (syntax-type2138 (lambda (e2543 r2544 w2545 s2546 rib2547 mod2548) (if (symbol? e2543) (let ((n2549 (id-var-name2126 e2543 w2545))) (let ((b2550 (lookup2101 n2549 r2544 mod2548))) (let ((type2551 (binding-type2096 b2550))) (if (memv type2551 (quote (lexical))) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (global))) (values type2551 n2549 e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2550) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548))))))) (if (pair? e2543) (let ((first2552 (car e2543))) (if (id?2104 first2552) (let ((n2553 (id-var-name2126 first2552 w2545))) (let ((b2554 (lookup2101 n2553 r2544 (let ((t2555 (if (syntax-object?2088 first2552) (syntax-object-module2091 first2552) #f))) (if t2555 t2555 mod2548))))) (let ((type2556 (binding-type2096 b2554))) (if (memv type2556 (quote (lexical))) (values (quote lexical-call) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (global))) (values (quote global-call) n2553 e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2554) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (if (memv type2556 (quote (core external-macro module-ref))) (values type2556 (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (begin))) (values (quote begin-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (eval-when))) (values (quote eval-when-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (define))) ((lambda (tmp2557) ((lambda (tmp2558) (if (if tmp2558 (apply (lambda (_2559 name2560 val2561) (id?2104 name2560)) tmp2558) #f) (apply (lambda (_2562 name2563 val2564) (values (quote define-form) name2563 val2564 w2545 s2546 mod2548)) tmp2558) ((lambda (tmp2565) (if (if tmp2565 (apply (lambda (_2566 name2567 args2568 e12569 e22570) (if (id?2104 name2567) (valid-bound-ids?2129 (lambda-var-list2153 args2568)) #f)) tmp2565) #f) (apply (lambda (_2571 name2572 args2573 e12574 e22575) (values (quote define-form) (wrap2132 name2572 w2545 mod2548) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap2132 (cons args2573 (cons e12574 e22575)) w2545 mod2548)) (quote (())) s2546 mod2548)) tmp2565) ((lambda (tmp2577) (if (if tmp2577 (apply (lambda (_2578 name2579) (id?2104 name2579)) tmp2577) #f) (apply (lambda (_2580 name2581) (values (quote define-form) (wrap2132 name2581 w2545 mod2548) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2546 mod2548)) tmp2577) (syntax-violation #f "Source expression failed to match any pattern" tmp2557))) ($sc-dispatch tmp2557 (quote (any any)))))) ($sc-dispatch tmp2557 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2557 (quote (any any any))))) e2543) (if (memv type2556 (quote (define-syntax))) ((lambda (tmp2582) ((lambda (tmp2583) (if (if tmp2583 (apply (lambda (_2584 name2585 val2586) (id?2104 name2585)) tmp2583) #f) (apply (lambda (_2587 name2588 val2589) (values (quote define-syntax-form) name2588 val2589 w2545 s2546 mod2548)) tmp2583) (syntax-violation #f "Source expression failed to match any pattern" tmp2582))) ($sc-dispatch tmp2582 (quote (any any any))))) e2543) (values (quote call) #f e2543 w2545 s2546 mod2548))))))))))))) (values (quote call) #f e2543 w2545 s2546 mod2548))) (if (syntax-object?2088 e2543) (syntax-type2138 (syntax-object-expression2089 e2543) r2544 (join-wraps2123 w2545 (syntax-object-wrap2090 e2543)) #f rib2547 (let ((t2590 (syntax-object-module2091 e2543))) (if t2590 t2590 mod2548))) (if (annotation? e2543) (syntax-type2138 (annotation-expression e2543) r2544 w2545 (annotation-source e2543) rib2547 mod2548) (if (self-evaluating? e2543) (values (quote constant) #f e2543 w2545 s2546 mod2548) (values (quote other) #f e2543 w2545 s2546 mod2548)))))))) (chi-when-list2137 (lambda (e2591 when-list2592 w2593) (letrec ((f2594 (lambda (when-list2595 situations2596) (if (null? when-list2595) situations2596 (f2594 (cdr when-list2595) (cons (let ((x2597 (car when-list2595))) (if (free-id=?2127 x2597 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?2127 x2597 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?2127 x2597 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e2591 (wrap2132 x2597 w2593 #f)))))) situations2596)))))) (f2594 when-list2592 (quote ()))))) (chi-install-global2136 (lambda (name2598 e2599) (build-global-definition2079 #f name2598 (if (let ((v2600 (module-variable (current-module) name2598))) (if v2600 (if (variable-bound? v2600) (if (macro? (variable-ref v2600)) (not (eq? (macro-type (variable-ref v2600)) (quote syncase-macro))) #f) #f) #f)) (build-application2072 #f (build-primref2081 #f (quote make-extended-syncase-macro)) (list (build-application2072 #f (build-primref2081 #f (quote module-ref)) (list (build-application2072 #f (build-primref2081 #f (quote current-module)) (quote ())) (build-data2082 #f name2598))) (build-data2082 #f (quote macro)) e2599)) (build-application2072 #f (build-primref2081 #f (quote make-syncase-macro)) (list (build-data2082 #f (quote macro)) e2599)))))) (chi-top-sequence2135 (lambda (body2601 r2602 w2603 s2604 m2605 esew2606 mod2607) (build-sequence2083 s2604 (letrec ((dobody2608 (lambda (body2609 r2610 w2611 m2612 esew2613 mod2614) (if (null? body2609) (quote ()) (let ((first2615 (chi-top2139 (car body2609) r2610 w2611 m2612 esew2613 mod2614))) (cons first2615 (dobody2608 (cdr body2609) r2610 w2611 m2612 esew2613 mod2614))))))) (dobody2608 body2601 r2602 w2603 m2605 esew2606 mod2607))))) (chi-sequence2134 (lambda (body2616 r2617 w2618 s2619 mod2620) (build-sequence2083 s2619 (letrec ((dobody2621 (lambda (body2622 r2623 w2624 mod2625) (if (null? body2622) (quote ()) (let ((first2626 (chi2140 (car body2622) r2623 w2624 mod2625))) (cons first2626 (dobody2621 (cdr body2622) r2623 w2624 mod2625))))))) (dobody2621 body2616 r2617 w2618 mod2620))))) (source-wrap2133 (lambda (x2627 w2628 s2629 defmod2630) (wrap2132 (if s2629 (make-annotation x2627 s2629 #f) x2627) w2628 defmod2630))) (wrap2132 (lambda (x2631 w2632 defmod2633) (if (if (null? (wrap-marks2107 w2632)) (null? (wrap-subst2108 w2632)) #f) x2631 (if (syntax-object?2088 x2631) (make-syntax-object2087 (syntax-object-expression2089 x2631) (join-wraps2123 w2632 (syntax-object-wrap2090 x2631)) (syntax-object-module2091 x2631)) (if (null? x2631) x2631 (make-syntax-object2087 x2631 w2632 defmod2633)))))) (bound-id-member?2131 (lambda (x2634 list2635) (if (not (null? list2635)) (let ((t2636 (bound-id=?2128 x2634 (car list2635)))) (if t2636 t2636 (bound-id-member?2131 x2634 (cdr list2635)))) #f))) (distinct-bound-ids?2130 (lambda (ids2637) (letrec ((distinct?2638 (lambda (ids2639) (let ((t2640 (null? ids2639))) (if t2640 t2640 (if (not (bound-id-member?2131 (car ids2639) (cdr ids2639))) (distinct?2638 (cdr ids2639)) #f)))))) (distinct?2638 ids2637)))) (valid-bound-ids?2129 (lambda (ids2641) (if (letrec ((all-ids?2642 (lambda (ids2643) (let ((t2644 (null? ids2643))) (if t2644 t2644 (if (id?2104 (car ids2643)) (all-ids?2642 (cdr ids2643)) #f)))))) (all-ids?2642 ids2641)) (distinct-bound-ids?2130 ids2641) #f))) (bound-id=?2128 (lambda (i2645 j2646) (if (if (syntax-object?2088 i2645) (syntax-object?2088 j2646) #f) (if (eq? (let ((e2647 (syntax-object-expression2089 i2645))) (if (annotation? e2647) (annotation-expression e2647) e2647)) (let ((e2648 (syntax-object-expression2089 j2646))) (if (annotation? e2648) (annotation-expression e2648) e2648))) (same-marks?2125 (wrap-marks2107 (syntax-object-wrap2090 i2645)) (wrap-marks2107 (syntax-object-wrap2090 j2646))) #f) (eq? (let ((e2649 i2645)) (if (annotation? e2649) (annotation-expression e2649) e2649)) (let ((e2650 j2646)) (if (annotation? e2650) (annotation-expression e2650) e2650)))))) (free-id=?2127 (lambda (i2651 j2652) (if (eq? (let ((x2653 i2651)) (let ((e2654 (if (syntax-object?2088 x2653) (syntax-object-expression2089 x2653) x2653))) (if (annotation? e2654) (annotation-expression e2654) e2654))) (let ((x2655 j2652)) (let ((e2656 (if (syntax-object?2088 x2655) (syntax-object-expression2089 x2655) x2655))) (if (annotation? e2656) (annotation-expression e2656) e2656)))) (eq? (id-var-name2126 i2651 (quote (()))) (id-var-name2126 j2652 (quote (())))) #f))) (id-var-name2126 (lambda (id2657 w2658) (letrec ((search-vector-rib2661 (lambda (sym2667 subst2668 marks2669 symnames2670 ribcage2671) (let ((n2672 (vector-length symnames2670))) (letrec ((f2673 (lambda (i2674) (if (fx=2065 i2674 n2672) (search2659 sym2667 (cdr subst2668) marks2669) (if (if (eq? (vector-ref symnames2670 i2674) sym2667) (same-marks?2125 marks2669 (vector-ref (ribcage-marks2114 ribcage2671) i2674)) #f) (values (vector-ref (ribcage-labels2115 ribcage2671) i2674) marks2669) (f2673 (fx+2063 i2674 1))))))) (f2673 0))))) (search-list-rib2660 (lambda (sym2675 subst2676 marks2677 symnames2678 ribcage2679) (letrec ((f2680 (lambda (symnames2681 i2682) (if (null? symnames2681) (search2659 sym2675 (cdr subst2676) marks2677) (if (if (eq? (car symnames2681) sym2675) (same-marks?2125 marks2677 (list-ref (ribcage-marks2114 ribcage2679) i2682)) #f) (values (list-ref (ribcage-labels2115 ribcage2679) i2682) marks2677) (f2680 (cdr symnames2681) (fx+2063 i2682 1))))))) (f2680 symnames2678 0)))) (search2659 (lambda (sym2683 subst2684 marks2685) (if (null? subst2684) (values #f marks2685) (let ((fst2686 (car subst2684))) (if (eq? fst2686 (quote shift)) (search2659 sym2683 (cdr subst2684) (cdr marks2685)) (let ((symnames2687 (ribcage-symnames2113 fst2686))) (if (vector? symnames2687) (search-vector-rib2661 sym2683 subst2684 marks2685 symnames2687 fst2686) (search-list-rib2660 sym2683 subst2684 marks2685 symnames2687 fst2686))))))))) (if (symbol? id2657) (let ((t2688 (call-with-values (lambda () (search2659 id2657 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2690 . ignore2689) x2690)))) (if t2688 t2688 id2657)) (if (syntax-object?2088 id2657) (let ((id2691 (let ((e2693 (syntax-object-expression2089 id2657))) (if (annotation? e2693) (annotation-expression e2693) e2693))) (w12692 (syntax-object-wrap2090 id2657))) (let ((marks2694 (join-marks2124 (wrap-marks2107 w2658) (wrap-marks2107 w12692)))) (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w2658) marks2694)) (lambda (new-id2695 marks2696) (let ((t2697 new-id2695)) (if t2697 t2697 (let ((t2698 (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w12692) marks2696)) (lambda (x2700 . ignore2699) x2700)))) (if t2698 t2698 id2691)))))))) (if (annotation? id2657) (let ((id2701 (let ((e2702 id2657)) (if (annotation? e2702) (annotation-expression e2702) e2702)))) (let ((t2703 (call-with-values (lambda () (search2659 id2701 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2705 . ignore2704) x2705)))) (if t2703 t2703 id2701))) (syntax-violation (quote id-var-name) "invalid id" id2657))))))) (same-marks?2125 (lambda (x2706 y2707) (let ((t2708 (eq? x2706 y2707))) (if t2708 t2708 (if (not (null? x2706)) (if (not (null? y2707)) (if (eq? (car x2706) (car y2707)) (same-marks?2125 (cdr x2706) (cdr y2707)) #f) #f) #f))))) (join-marks2124 (lambda (m12709 m22710) (smart-append2122 m12709 m22710))) (join-wraps2123 (lambda (w12711 w22712) (let ((m12713 (wrap-marks2107 w12711)) (s12714 (wrap-subst2108 w12711))) (if (null? m12713) (if (null? s12714) w22712 (make-wrap2106 (wrap-marks2107 w22712) (smart-append2122 s12714 (wrap-subst2108 w22712)))) (make-wrap2106 (smart-append2122 m12713 (wrap-marks2107 w22712)) (smart-append2122 s12714 (wrap-subst2108 w22712))))))) (smart-append2122 (lambda (m12715 m22716) (if (null? m22716) m12715 (append m12715 m22716)))) (make-binding-wrap2121 (lambda (ids2717 labels2718 w2719) (if (null? ids2717) w2719 (make-wrap2106 (wrap-marks2107 w2719) (cons (let ((labelvec2720 (list->vector labels2718))) (let ((n2721 (vector-length labelvec2720))) (let ((symnamevec2722 (make-vector n2721)) (marksvec2723 (make-vector n2721))) (begin (letrec ((f2724 (lambda (ids2725 i2726) (if (not (null? ids2725)) (call-with-values (lambda () (id-sym-name&marks2105 (car ids2725) w2719)) (lambda (symname2727 marks2728) (begin (vector-set! symnamevec2722 i2726 symname2727) (vector-set! marksvec2723 i2726 marks2728) (f2724 (cdr ids2725) (fx+2063 i2726 1))))) (if #f #f))))) (f2724 ids2717 0)) (make-ribcage2111 symnamevec2722 marksvec2723 labelvec2720))))) (wrap-subst2108 w2719)))))) (extend-ribcage!2120 (lambda (ribcage2729 id2730 label2731) (begin (set-ribcage-symnames!2116 ribcage2729 (cons (let ((e2732 (syntax-object-expression2089 id2730))) (if (annotation? e2732) (annotation-expression e2732) e2732)) (ribcage-symnames2113 ribcage2729))) (set-ribcage-marks!2117 ribcage2729 (cons (wrap-marks2107 (syntax-object-wrap2090 id2730)) (ribcage-marks2114 ribcage2729))) (set-ribcage-labels!2118 ribcage2729 (cons label2731 (ribcage-labels2115 ribcage2729)))))) (anti-mark2119 (lambda (w2733) (make-wrap2106 (cons #f (wrap-marks2107 w2733)) (cons (quote shift) (wrap-subst2108 w2733))))) (set-ribcage-labels!2118 (lambda (x2734 update2735) (vector-set! x2734 3 update2735))) (set-ribcage-marks!2117 (lambda (x2736 update2737) (vector-set! x2736 2 update2737))) (set-ribcage-symnames!2116 (lambda (x2738 update2739) (vector-set! x2738 1 update2739))) (ribcage-labels2115 (lambda (x2740) (vector-ref x2740 3))) (ribcage-marks2114 (lambda (x2741) (vector-ref x2741 2))) (ribcage-symnames2113 (lambda (x2742) (vector-ref x2742 1))) (ribcage?2112 (lambda (x2743) (if (vector? x2743) (if (= (vector-length x2743) 4) (eq? (vector-ref x2743 0) (quote ribcage)) #f) #f))) (make-ribcage2111 (lambda (symnames2744 marks2745 labels2746) (vector (quote ribcage) symnames2744 marks2745 labels2746))) (gen-labels2110 (lambda (ls2747) (if (null? ls2747) (quote ()) (cons (gen-label2109) (gen-labels2110 (cdr ls2747)))))) (gen-label2109 (lambda () (string #\i))) (wrap-subst2108 cdr) (wrap-marks2107 car) (make-wrap2106 cons) (id-sym-name&marks2105 (lambda (x2748 w2749) (if (syntax-object?2088 x2748) (values (let ((e2750 (syntax-object-expression2089 x2748))) (if (annotation? e2750) (annotation-expression e2750) e2750)) (join-marks2124 (wrap-marks2107 w2749) (wrap-marks2107 (syntax-object-wrap2090 x2748)))) (values (let ((e2751 x2748)) (if (annotation? e2751) (annotation-expression e2751) e2751)) (wrap-marks2107 w2749))))) (id?2104 (lambda (x2752) (if (symbol? x2752) #t (if (syntax-object?2088 x2752) (symbol? (let ((e2753 (syntax-object-expression2089 x2752))) (if (annotation? e2753) (annotation-expression e2753) e2753))) (if (annotation? x2752) (symbol? (annotation-expression x2752)) #f))))) (nonsymbol-id?2103 (lambda (x2754) (if (syntax-object?2088 x2754) (symbol? (let ((e2755 (syntax-object-expression2089 x2754))) (if (annotation? e2755) (annotation-expression e2755) e2755))) #f))) (global-extend2102 (lambda (type2756 sym2757 val2758) (put-global-definition-hook2069 sym2757 type2756 val2758))) (lookup2101 (lambda (x2759 r2760 mod2761) (let ((temp2762 (assq x2759 r2760))) (if temp2762 (cdr temp2762) (if (symbol? x2759) (let ((t2763 (get-global-definition-hook2070 x2759 mod2761))) (if t2763 t2763 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env2100 (lambda (r2764) (if (null? r2764) (quote ()) (let ((a2765 (car r2764))) (if (eq? (cadr a2765) (quote macro)) (cons a2765 (macros-only-env2100 (cdr r2764))) (macros-only-env2100 (cdr r2764))))))) (extend-var-env2099 (lambda (labels2766 vars2767 r2768) (if (null? labels2766) r2768 (extend-var-env2099 (cdr labels2766) (cdr vars2767) (cons (cons (car labels2766) (cons (quote lexical) (car vars2767))) r2768))))) (extend-env2098 (lambda (labels2769 bindings2770 r2771) (if (null? labels2769) r2771 (extend-env2098 (cdr labels2769) (cdr bindings2770) (cons (cons (car labels2769) (car bindings2770)) r2771))))) (binding-value2097 cdr) (binding-type2096 car) (source-annotation2095 (lambda (x2772) (if (annotation? x2772) (annotation-source x2772) (if (syntax-object?2088 x2772) (source-annotation2095 (syntax-object-expression2089 x2772)) #f)))) (set-syntax-object-module!2094 (lambda (x2773 update2774) (vector-set! x2773 3 update2774))) (set-syntax-object-wrap!2093 (lambda (x2775 update2776) (vector-set! x2775 2 update2776))) (set-syntax-object-expression!2092 (lambda (x2777 update2778) (vector-set! x2777 1 update2778))) (syntax-object-module2091 (lambda (x2779) (vector-ref x2779 3))) (syntax-object-wrap2090 (lambda (x2780) (vector-ref x2780 2))) (syntax-object-expression2089 (lambda (x2781) (vector-ref x2781 1))) (syntax-object?2088 (lambda (x2782) (if (vector? x2782) (if (= (vector-length x2782) 4) (eq? (vector-ref x2782 0) (quote syntax-object)) #f) #f))) (make-syntax-object2087 (lambda (expression2783 wrap2784 module2785) (vector (quote syntax-object) expression2783 wrap2784 module2785))) (build-letrec2086 (lambda (src2786 ids2787 vars2788 val-exps2789 body-exp2790) (if (null? vars2788) body-exp2790 (let ((atom-key2791 (fluid-ref *mode*2062))) (if (memv atom-key2791 (quote (c))) ((@ (language tree-il) make-letrec) src2786 ids2787 vars2788 val-exps2789 body-exp2790) (list (quote letrec) (map list vars2788 val-exps2789) body-exp2790)))))) (build-named-let2085 (lambda (src2792 ids2793 vars2794 val-exps2795 body-exp2796) (let ((f2797 (car vars2794)) (f-name2798 (car ids2793)) (vars2799 (cdr vars2794)) (ids2800 (cdr ids2793))) (let ((atom-key2801 (fluid-ref *mode*2062))) (if (memv atom-key2801 (quote (c))) ((@ (language tree-il) make-letrec) src2792 (list f-name2798) (list f2797) (list (build-lambda2080 src2792 ids2800 vars2799 #f body-exp2796)) (build-application2072 src2792 (build-lexical-reference2074 (quote fun) src2792 f-name2798 f2797) val-exps2795)) (list (quote let) f2797 (map list vars2799 val-exps2795) body-exp2796)))))) (build-let2084 (lambda (src2802 ids2803 vars2804 val-exps2805 body-exp2806) (if (null? vars2804) body-exp2806 (let ((atom-key2807 (fluid-ref *mode*2062))) (if (memv atom-key2807 (quote (c))) ((@ (language tree-il) make-let) src2802 ids2803 vars2804 val-exps2805 body-exp2806) (list (quote let) (map list vars2804 val-exps2805) body-exp2806)))))) (build-sequence2083 (lambda (src2808 exps2809) (if (null? (cdr exps2809)) (car exps2809) (let ((atom-key2810 (fluid-ref *mode*2062))) (if (memv atom-key2810 (quote (c))) ((@ (language tree-il) make-sequence) src2808 exps2809) (cons (quote begin) exps2809)))))) (build-data2082 (lambda (src2811 exp2812) (let ((atom-key2813 (fluid-ref *mode*2062))) (if (memv atom-key2813 (quote (c))) ((@ (language tree-il) make-const) src2811 exp2812) (if (if (self-evaluating? exp2812) (not (vector? exp2812)) #f) exp2812 (list (quote quote) exp2812)))))) (build-primref2081 (lambda (src2814 name2815) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2816 (fluid-ref *mode*2062))) (if (memv atom-key2816 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2814 name2815) name2815)) (let ((atom-key2817 (fluid-ref *mode*2062))) (if (memv atom-key2817 (quote (c))) ((@ (language tree-il) make-module-ref) src2814 (quote (guile)) name2815 #f) (list (quote @@) (quote (guile)) name2815)))))) (build-lambda2080 (lambda (src2818 ids2819 vars2820 docstring2821 exp2822) (let ((atom-key2823 (fluid-ref *mode*2062))) (if (memv atom-key2823 (quote (c))) ((@ (language tree-il) make-lambda) src2818 ids2819 vars2820 (if docstring2821 (list (cons (quote documentation) docstring2821)) (quote ())) exp2822) (cons (quote lambda) (cons vars2820 (append (if docstring2821 (list docstring2821) (quote ())) (list exp2822)))))))) (build-global-definition2079 (lambda (source2824 var2825 exp2826) (let ((atom-key2827 (fluid-ref *mode*2062))) (if (memv atom-key2827 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2824 var2825 exp2826) (list (quote define) var2825 exp2826))))) (build-global-assignment2078 (lambda (source2828 var2829 exp2830 mod2831) (analyze-variable2076 mod2831 var2829 (lambda (mod2832 var2833 public?2834) (let ((atom-key2835 (fluid-ref *mode*2062))) (if (memv atom-key2835 (quote (c))) ((@ (language tree-il) make-module-set) source2828 mod2832 var2833 public?2834 exp2830) (list (quote set!) (list (if public?2834 (quote @) (quote @@)) mod2832 var2833) exp2830)))) (lambda (var2836) (let ((atom-key2837 (fluid-ref *mode*2062))) (if (memv atom-key2837 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2828 var2836 exp2830) (list (quote set!) var2836 exp2830))))))) (build-global-reference2077 (lambda (source2838 var2839 mod2840) (analyze-variable2076 mod2840 var2839 (lambda (mod2841 var2842 public?2843) (let ((atom-key2844 (fluid-ref *mode*2062))) (if (memv atom-key2844 (quote (c))) ((@ (language tree-il) make-module-ref) source2838 mod2841 var2842 public?2843) (list (if public?2843 (quote @) (quote @@)) mod2841 var2842)))) (lambda (var2845) (let ((atom-key2846 (fluid-ref *mode*2062))) (if (memv atom-key2846 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2838 var2845) var2845)))))) (analyze-variable2076 (lambda (mod2847 var2848 modref-cont2849 bare-cont2850) (if (not mod2847) (bare-cont2850 var2848) (let ((kind2851 (car mod2847)) (mod2852 (cdr mod2847))) (if (memv kind2851 (quote (public))) (modref-cont2849 mod2852 var2848 #t) (if (memv kind2851 (quote (private))) (if (not (equal? mod2852 (module-name (current-module)))) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (if (memv kind2851 (quote (bare))) (bare-cont2850 var2848) (if (memv kind2851 (quote (hygiene))) (if (if (not (equal? mod2852 (module-name (current-module)))) (module-variable (resolve-module mod2852) var2848) #f) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (syntax-violation #f "bad module kind" var2848 mod2852))))))))) (build-lexical-assignment2075 (lambda (source2853 name2854 var2855 exp2856) (let ((atom-key2857 (fluid-ref *mode*2062))) (if (memv atom-key2857 (quote (c))) ((@ (language tree-il) make-lexical-set) source2853 name2854 var2855 exp2856) (list (quote set!) var2855 exp2856))))) (build-lexical-reference2074 (lambda (type2858 source2859 name2860 var2861) (let ((atom-key2862 (fluid-ref *mode*2062))) (if (memv atom-key2862 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2859 name2860 var2861) var2861)))) (build-conditional2073 (lambda (source2863 test-exp2864 then-exp2865 else-exp2866) (let ((atom-key2867 (fluid-ref *mode*2062))) (if (memv atom-key2867 (quote (c))) ((@ (language tree-il) make-conditional) source2863 test-exp2864 then-exp2865 else-exp2866) (list (quote if) test-exp2864 then-exp2865 else-exp2866))))) (build-application2072 (lambda (source2868 fun-exp2869 arg-exps2870) (let ((atom-key2871 (fluid-ref *mode*2062))) (if (memv atom-key2871 (quote (c))) ((@ (language tree-il) make-application) source2868 fun-exp2869 arg-exps2870) (cons fun-exp2869 arg-exps2870))))) (build-void2071 (lambda (source2872) (let ((atom-key2873 (fluid-ref *mode*2062))) (if (memv atom-key2873 (quote (c))) ((@ (language tree-il) make-void) source2872) (quote (if #f #f)))))) (get-global-definition-hook2070 (lambda (symbol2874 module2875) (begin (if (if (not module2875) (current-module) #f) (warn "module system is booted, we should have a module" symbol2874) (if #f #f)) (let ((v2876 (module-variable (if module2875 (resolve-module (cdr module2875)) (current-module)) symbol2874))) (if v2876 (if (variable-bound? v2876) (let ((val2877 (variable-ref v2876))) (if (macro? val2877) (if (syncase-macro-type val2877) (cons (syncase-macro-type val2877) (syncase-macro-binding val2877)) #f) #f)) #f) #f))))) (put-global-definition-hook2069 (lambda (symbol2878 type2879 val2880) (let ((existing2881 (let ((v2882 (module-variable (current-module) symbol2878))) (if v2882 (if (variable-bound? v2882) (let ((val2883 (variable-ref v2882))) (if (macro? val2883) (if (not (syncase-macro-type val2883)) val2883 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2878 (if existing2881 (make-extended-syncase-macro existing2881 type2879 val2880) (make-syncase-macro type2879 val2880)))))) (local-eval-hook2068 (lambda (x2884 mod2885) (primitive-eval (list noexpand2061 (let ((atom-key2886 (fluid-ref *mode*2062))) (if (memv atom-key2886 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2884) x2884)))))) (top-level-eval-hook2067 (lambda (x2887 mod2888) (primitive-eval (list noexpand2061 (let ((atom-key2889 (fluid-ref *mode*2062))) (if (memv atom-key2889 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2887) x2887)))))) (fx<2066 <) (fx=2065 =) (fx-2064 -) (fx+2063 +) (*mode*2062 (make-fluid)) (noexpand2061 "noexpand")) (begin (global-extend2102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend2102 (quote local-syntax) (quote let-syntax) #f) (global-extend2102 (quote core) (quote fluid-let-syntax) (lambda (e2890 r2891 w2892 s2893 mod2894) ((lambda (tmp2895) ((lambda (tmp2896) (if (if tmp2896 (apply (lambda (_2897 var2898 val2899 e12900 e22901) (valid-bound-ids?2129 var2898)) tmp2896) #f) (apply (lambda (_2903 var2904 val2905 e12906 e22907) (let ((names2908 (map (lambda (x2909) (id-var-name2126 x2909 w2892)) var2904))) (begin (for-each (lambda (id2911 n2912) (let ((atom-key2913 (binding-type2096 (lookup2101 n2912 r2891 mod2894)))) (if (memv atom-key2913 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2890 (source-wrap2133 id2911 w2892 s2893 mod2894)) (if #f #f)))) var2904 names2908) (chi-body2144 (cons e12906 e22907) (source-wrap2133 e2890 w2892 s2893 mod2894) (extend-env2098 names2908 (let ((trans-r2916 (macros-only-env2100 r2891))) (map (lambda (x2917) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2917 trans-r2916 w2892 mod2894) mod2894))) val2905)) r2891) w2892 mod2894)))) tmp2896) ((lambda (_2919) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap2133 e2890 w2892 s2893 mod2894))) tmp2895))) ($sc-dispatch tmp2895 (quote (any #(each (any any)) any . each-any))))) e2890))) (global-extend2102 (quote core) (quote quote) (lambda (e2920 r2921 w2922 s2923 mod2924) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 e2928) (build-data2082 s2923 (strip2151 e2928 w2922))) tmp2926) ((lambda (_2929) (syntax-violation (quote quote) "bad syntax" (source-wrap2133 e2920 w2922 s2923 mod2924))) tmp2925))) ($sc-dispatch tmp2925 (quote (any any))))) e2920))) (global-extend2102 (quote core) (quote syntax) (letrec ((regen2937 (lambda (x2938) (let ((atom-key2939 (car x2938))) (if (memv atom-key2939 (quote (ref))) (build-lexical-reference2074 (quote value) #f (cadr x2938) (cadr x2938)) (if (memv atom-key2939 (quote (primitive))) (build-primref2081 #f (cadr x2938)) (if (memv atom-key2939 (quote (quote))) (build-data2082 #f (cadr x2938)) (if (memv atom-key2939 (quote (lambda))) (build-lambda2080 #f (cadr x2938) (cadr x2938) #f (regen2937 (caddr x2938))) (if (memv atom-key2939 (quote (map))) (let ((ls2940 (map regen2937 (cdr x2938)))) (build-application2072 #f (build-primref2081 #f (quote map)) ls2940)) (build-application2072 #f (build-primref2081 #f (car x2938)) (map regen2937 (cdr x2938))))))))))) (gen-vector2936 (lambda (x2941) (if (eq? (car x2941) (quote list)) (cons (quote vector) (cdr x2941)) (if (eq? (car x2941) (quote quote)) (list (quote quote) (list->vector (cadr x2941))) (list (quote list->vector) x2941))))) (gen-append2935 (lambda (x2942 y2943) (if (equal? y2943 (quote (quote ()))) x2942 (list (quote append) x2942 y2943)))) (gen-cons2934 (lambda (x2944 y2945) (let ((atom-key2946 (car y2945))) (if (memv atom-key2946 (quote (quote))) (if (eq? (car x2944) (quote quote)) (list (quote quote) (cons (cadr x2944) (cadr y2945))) (if (eq? (cadr y2945) (quote ())) (list (quote list) x2944) (list (quote cons) x2944 y2945))) (if (memv atom-key2946 (quote (list))) (cons (quote list) (cons x2944 (cdr y2945))) (list (quote cons) x2944 y2945)))))) (gen-map2933 (lambda (e2947 map-env2948) (let ((formals2949 (map cdr map-env2948)) (actuals2950 (map (lambda (x2951) (list (quote ref) (car x2951))) map-env2948))) (if (eq? (car e2947) (quote ref)) (car actuals2950) (if (and-map (lambda (x2952) (if (eq? (car x2952) (quote ref)) (memq (cadr x2952) formals2949) #f)) (cdr e2947)) (cons (quote map) (cons (list (quote primitive) (car e2947)) (map (let ((r2953 (map cons formals2949 actuals2950))) (lambda (x2954) (cdr (assq (cadr x2954) r2953)))) (cdr e2947)))) (cons (quote map) (cons (list (quote lambda) formals2949 e2947) actuals2950))))))) (gen-mappend2932 (lambda (e2955 map-env2956) (list (quote apply) (quote (primitive append)) (gen-map2933 e2955 map-env2956)))) (gen-ref2931 (lambda (src2957 var2958 level2959 maps2960) (if (fx=2065 level2959 0) (values var2958 maps2960) (if (null? maps2960) (syntax-violation (quote syntax) "missing ellipsis" src2957) (call-with-values (lambda () (gen-ref2931 src2957 var2958 (fx-2064 level2959 1) (cdr maps2960))) (lambda (outer-var2961 outer-maps2962) (let ((b2963 (assq outer-var2961 (car maps2960)))) (if b2963 (values (cdr b2963) maps2960) (let ((inner-var2964 (gen-var2152 (quote tmp)))) (values inner-var2964 (cons (cons (cons outer-var2961 inner-var2964) (car maps2960)) outer-maps2962))))))))))) (gen-syntax2930 (lambda (src2965 e2966 r2967 maps2968 ellipsis?2969 mod2970) (if (id?2104 e2966) (let ((label2971 (id-var-name2126 e2966 (quote (()))))) (let ((b2972 (lookup2101 label2971 r2967 mod2970))) (if (eq? (binding-type2096 b2972) (quote syntax)) (call-with-values (lambda () (let ((var.lev2973 (binding-value2097 b2972))) (gen-ref2931 src2965 (car var.lev2973) (cdr var.lev2973) maps2968))) (lambda (var2974 maps2975) (values (list (quote ref) var2974) maps2975))) (if (ellipsis?2969 e2966) (syntax-violation (quote syntax) "misplaced ellipsis" src2965) (values (list (quote quote) e2966) maps2968))))) ((lambda (tmp2976) ((lambda (tmp2977) (if (if tmp2977 (apply (lambda (dots2978 e2979) (ellipsis?2969 dots2978)) tmp2977) #f) (apply (lambda (dots2980 e2981) (gen-syntax2930 src2965 e2981 r2967 maps2968 (lambda (x2982) #f) mod2970)) tmp2977) ((lambda (tmp2983) (if (if tmp2983 (apply (lambda (x2984 dots2985 y2986) (ellipsis?2969 dots2985)) tmp2983) #f) (apply (lambda (x2987 dots2988 y2989) (letrec ((f2990 (lambda (y2991 k2992) ((lambda (tmp2996) ((lambda (tmp2997) (if (if tmp2997 (apply (lambda (dots2998 y2999) (ellipsis?2969 dots2998)) tmp2997) #f) (apply (lambda (dots3000 y3001) (f2990 y3001 (lambda (maps3002) (call-with-values (lambda () (k2992 (cons (quote ()) maps3002))) (lambda (x3003 maps3004) (if (null? (car maps3004)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-mappend2932 x3003 (car maps3004)) (cdr maps3004)))))))) tmp2997) ((lambda (_3005) (call-with-values (lambda () (gen-syntax2930 src2965 y2991 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (y3006 maps3007) (call-with-values (lambda () (k2992 maps3007)) (lambda (x3008 maps3009) (values (gen-append2935 x3008 y3006) maps3009)))))) tmp2996))) ($sc-dispatch tmp2996 (quote (any . any))))) y2991)))) (f2990 y2989 (lambda (maps2993) (call-with-values (lambda () (gen-syntax2930 src2965 x2987 r2967 (cons (quote ()) maps2993) ellipsis?2969 mod2970)) (lambda (x2994 maps2995) (if (null? (car maps2995)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-map2933 x2994 (car maps2995)) (cdr maps2995))))))))) tmp2983) ((lambda (tmp3010) (if tmp3010 (apply (lambda (x3011 y3012) (call-with-values (lambda () (gen-syntax2930 src2965 x3011 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (x3013 maps3014) (call-with-values (lambda () (gen-syntax2930 src2965 y3012 r2967 maps3014 ellipsis?2969 mod2970)) (lambda (y3015 maps3016) (values (gen-cons2934 x3013 y3015) maps3016)))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (e13018 e23019) (call-with-values (lambda () (gen-syntax2930 src2965 (cons e13018 e23019) r2967 maps2968 ellipsis?2969 mod2970)) (lambda (e3021 maps3022) (values (gen-vector2936 e3021) maps3022)))) tmp3017) ((lambda (_3023) (values (list (quote quote) e2966) maps2968)) tmp2976))) ($sc-dispatch tmp2976 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2976 (quote (any . any)))))) ($sc-dispatch tmp2976 (quote (any any . any)))))) ($sc-dispatch tmp2976 (quote (any any))))) e2966))))) (lambda (e3024 r3025 w3026 s3027 mod3028) (let ((e3029 (source-wrap2133 e3024 w3026 s3027 mod3028))) ((lambda (tmp3030) ((lambda (tmp3031) (if tmp3031 (apply (lambda (_3032 x3033) (call-with-values (lambda () (gen-syntax2930 e3029 x3033 r3025 (quote ()) ellipsis?2149 mod3028)) (lambda (e3034 maps3035) (regen2937 e3034)))) tmp3031) ((lambda (_3036) (syntax-violation (quote syntax) "bad `syntax' form" e3029)) tmp3030))) ($sc-dispatch tmp3030 (quote (any any))))) e3029))))) (global-extend2102 (quote core) (quote lambda) (lambda (e3037 r3038 w3039 s3040 mod3041) ((lambda (tmp3042) ((lambda (tmp3043) (if tmp3043 (apply (lambda (_3044 c3045) (chi-lambda-clause2145 (source-wrap2133 e3037 w3039 s3040 mod3041) #f c3045 r3038 w3039 mod3041 (lambda (names3046 vars3047 docstring3048 body3049) (build-lambda2080 s3040 names3046 vars3047 docstring3048 body3049)))) tmp3043) (syntax-violation #f "Source expression failed to match any pattern" tmp3042))) ($sc-dispatch tmp3042 (quote (any . any))))) e3037))) (global-extend2102 (quote core) (quote let) (letrec ((chi-let3050 (lambda (e3051 r3052 w3053 s3054 mod3055 constructor3056 ids3057 vals3058 exps3059) (if (not (valid-bound-ids?2129 ids3057)) (syntax-violation (quote let) "duplicate bound variable" e3051) (let ((labels3060 (gen-labels2110 ids3057)) (new-vars3061 (map gen-var2152 ids3057))) (let ((nw3062 (make-binding-wrap2121 ids3057 labels3060 w3053)) (nr3063 (extend-var-env2099 labels3060 new-vars3061 r3052))) (constructor3056 s3054 (map syntax->datum ids3057) new-vars3061 (map (lambda (x3064) (chi2140 x3064 r3052 w3053 mod3055)) vals3058) (chi-body2144 exps3059 (source-wrap2133 e3051 nw3062 s3054 mod3055) nr3063 nw3062 mod3055)))))))) (lambda (e3065 r3066 w3067 s3068 mod3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (_3072 id3073 val3074 e13075 e23076) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-let2084 id3073 val3074 (cons e13075 e23076))) tmp3071) ((lambda (tmp3080) (if (if tmp3080 (apply (lambda (_3081 f3082 id3083 val3084 e13085 e23086) (id?2104 f3082)) tmp3080) #f) (apply (lambda (_3087 f3088 id3089 val3090 e13091 e23092) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-named-let2085 (cons f3088 id3089) val3090 (cons e13091 e23092))) tmp3080) ((lambda (_3096) (syntax-violation (quote let) "bad let" (source-wrap2133 e3065 w3067 s3068 mod3069))) tmp3070))) ($sc-dispatch tmp3070 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3070 (quote (any #(each (any any)) any . each-any))))) e3065)))) (global-extend2102 (quote core) (quote letrec) (lambda (e3097 r3098 w3099 s3100 mod3101) ((lambda (tmp3102) ((lambda (tmp3103) (if tmp3103 (apply (lambda (_3104 id3105 val3106 e13107 e23108) (let ((ids3109 id3105)) (if (not (valid-bound-ids?2129 ids3109)) (syntax-violation (quote letrec) "duplicate bound variable" e3097) (let ((labels3111 (gen-labels2110 ids3109)) (new-vars3112 (map gen-var2152 ids3109))) (let ((w3113 (make-binding-wrap2121 ids3109 labels3111 w3099)) (r3114 (extend-var-env2099 labels3111 new-vars3112 r3098))) (build-letrec2086 s3100 (map syntax->datum ids3109) new-vars3112 (map (lambda (x3115) (chi2140 x3115 r3114 w3113 mod3101)) val3106) (chi-body2144 (cons e13107 e23108) (source-wrap2133 e3097 w3113 s3100 mod3101) r3114 w3113 mod3101))))))) tmp3103) ((lambda (_3118) (syntax-violation (quote letrec) "bad letrec" (source-wrap2133 e3097 w3099 s3100 mod3101))) tmp3102))) ($sc-dispatch tmp3102 (quote (any #(each (any any)) any . each-any))))) e3097))) (global-extend2102 (quote core) (quote set!) (lambda (e3119 r3120 w3121 s3122 mod3123) ((lambda (tmp3124) ((lambda (tmp3125) (if (if tmp3125 (apply (lambda (_3126 id3127 val3128) (id?2104 id3127)) tmp3125) #f) (apply (lambda (_3129 id3130 val3131) (let ((val3132 (chi2140 val3131 r3120 w3121 mod3123)) (n3133 (id-var-name2126 id3130 w3121))) (let ((b3134 (lookup2101 n3133 r3120 mod3123))) (let ((atom-key3135 (binding-type2096 b3134))) (if (memv atom-key3135 (quote (lexical))) (build-lexical-assignment2075 s3122 (syntax->datum id3130) (binding-value2097 b3134) val3132) (if (memv atom-key3135 (quote (global))) (build-global-assignment2078 s3122 n3133 val3132 mod3123) (if (memv atom-key3135 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap2132 id3130 w3121 mod3123)) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))))))))) tmp3125) ((lambda (tmp3136) (if tmp3136 (apply (lambda (_3137 head3138 tail3139 val3140) (call-with-values (lambda () (syntax-type2138 head3138 r3120 (quote (())) #f #f mod3123)) (lambda (type3141 value3142 ee3143 ww3144 ss3145 modmod3146) (if (memv type3141 (quote (module-ref))) (let ((val3147 (chi2140 val3140 r3120 w3121 mod3123))) (call-with-values (lambda () (value3142 (cons head3138 tail3139))) (lambda (id3149 mod3150) (build-global-assignment2078 s3122 id3149 val3147 mod3150)))) (build-application2072 s3122 (chi2140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head3138) r3120 w3121 mod3123) (map (lambda (e3151) (chi2140 e3151 r3120 w3121 mod3123)) (append tail3139 (list val3140)))))))) tmp3136) ((lambda (_3153) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))) tmp3124))) ($sc-dispatch tmp3124 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp3124 (quote (any any any))))) e3119))) (global-extend2102 (quote module-ref) (quote @) (lambda (e3154) ((lambda (tmp3155) ((lambda (tmp3156) (if (if tmp3156 (apply (lambda (_3157 mod3158 id3159) (if (and-map id?2104 mod3158) (id?2104 id3159) #f)) tmp3156) #f) (apply (lambda (_3161 mod3162 id3163) (values (syntax->datum id3163) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3162)))) tmp3156) (syntax-violation #f "Source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any each-any any))))) e3154))) (global-extend2102 (quote module-ref) (quote @@) (lambda (e3165) ((lambda (tmp3166) ((lambda (tmp3167) (if (if tmp3167 (apply (lambda (_3168 mod3169 id3170) (if (and-map id?2104 mod3169) (id?2104 id3170) #f)) tmp3167) #f) (apply (lambda (_3172 mod3173 id3174) (values (syntax->datum id3174) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3173)))) tmp3167) (syntax-violation #f "Source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any each-any any))))) e3165))) (global-extend2102 (quote core) (quote if) (lambda (e3176 r3177 w3178 s3179 mod3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 test3184 then3185) (build-conditional2073 s3179 (chi2140 test3184 r3177 w3178 mod3180) (chi2140 then3185 r3177 w3178 mod3180) (build-void2071 #f))) tmp3182) ((lambda (tmp3186) (if tmp3186 (apply (lambda (_3187 test3188 then3189 else3190) (build-conditional2073 s3179 (chi2140 test3188 r3177 w3178 mod3180) (chi2140 then3189 r3177 w3178 mod3180) (chi2140 else3190 r3177 w3178 mod3180))) tmp3186) (syntax-violation #f "Source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any any any)))))) ($sc-dispatch tmp3181 (quote (any any any))))) e3176))) (global-extend2102 (quote begin) (quote begin) (quote ())) (global-extend2102 (quote define) (quote define) (quote ())) (global-extend2102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend2102 (quote eval-when) (quote eval-when) (quote ())) (global-extend2102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case3194 (lambda (x3195 keys3196 clauses3197 r3198 mod3199) (if (null? clauses3197) (build-application2072 #f (build-primref2081 #f (quote syntax-violation)) (list (build-data2082 #f #f) (build-data2082 #f "source expression failed to match any pattern") x3195)) ((lambda (tmp3200) ((lambda (tmp3201) (if tmp3201 (apply (lambda (pat3202 exp3203) (if (if (id?2104 pat3202) (and-map (lambda (x3204) (not (free-id=?2127 pat3202 x3204))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys3196)) #f) (let ((labels3205 (list (gen-label2109))) (var3206 (gen-var2152 pat3202))) (build-application2072 #f (build-lambda2080 #f (list (syntax->datum pat3202)) (list var3206) #f (chi2140 exp3203 (extend-env2098 labels3205 (list (cons (quote syntax) (cons var3206 0))) r3198) (make-binding-wrap2121 (list pat3202) labels3205 (quote (()))) mod3199)) (list x3195))) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3202 #t exp3203 mod3199))) tmp3201) ((lambda (tmp3207) (if tmp3207 (apply (lambda (pat3208 fender3209 exp3210) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3208 fender3209 exp3210 mod3199)) tmp3207) ((lambda (_3211) (syntax-violation (quote syntax-case) "invalid clause" (car clauses3197))) tmp3200))) ($sc-dispatch tmp3200 (quote (any any any)))))) ($sc-dispatch tmp3200 (quote (any any))))) (car clauses3197))))) (gen-clause3193 (lambda (x3212 keys3213 clauses3214 r3215 pat3216 fender3217 exp3218 mod3219) (call-with-values (lambda () (convert-pattern3191 pat3216 keys3213)) (lambda (p3220 pvars3221) (if (not (distinct-bound-ids?2130 (map car pvars3221))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat3216) (if (not (and-map (lambda (x3222) (not (ellipsis?2149 (car x3222)))) pvars3221)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat3216) (let ((y3223 (gen-var2152 (quote tmp)))) (build-application2072 #f (build-lambda2080 #f (list (quote tmp)) (list y3223) #f (let ((y3224 (build-lexical-reference2074 (quote value) #f (quote tmp) y3223))) (build-conditional2073 #f ((lambda (tmp3225) ((lambda (tmp3226) (if tmp3226 (apply (lambda () y3224) tmp3226) ((lambda (_3227) (build-conditional2073 #f y3224 (build-dispatch-call3192 pvars3221 fender3217 y3224 r3215 mod3219) (build-data2082 #f #f))) tmp3225))) ($sc-dispatch tmp3225 (quote #(atom #t))))) fender3217) (build-dispatch-call3192 pvars3221 exp3218 y3224 r3215 mod3219) (gen-syntax-case3194 x3212 keys3213 clauses3214 r3215 mod3219)))) (list (if (eq? p3220 (quote any)) (build-application2072 #f (build-primref2081 #f (quote list)) (list x3212)) (build-application2072 #f (build-primref2081 #f (quote $sc-dispatch)) (list x3212 (build-data2082 #f p3220))))))))))))) (build-dispatch-call3192 (lambda (pvars3228 exp3229 y3230 r3231 mod3232) (let ((ids3233 (map car pvars3228)) (levels3234 (map cdr pvars3228))) (let ((labels3235 (gen-labels2110 ids3233)) (new-vars3236 (map gen-var2152 ids3233))) (build-application2072 #f (build-primref2081 #f (quote apply)) (list (build-lambda2080 #f (map syntax->datum ids3233) new-vars3236 #f (chi2140 exp3229 (extend-env2098 labels3235 (map (lambda (var3237 level3238) (cons (quote syntax) (cons var3237 level3238))) new-vars3236 (map cdr pvars3228)) r3231) (make-binding-wrap2121 ids3233 labels3235 (quote (()))) mod3232)) y3230)))))) (convert-pattern3191 (lambda (pattern3239 keys3240) (letrec ((cvt3241 (lambda (p3242 n3243 ids3244) (if (id?2104 p3242) (if (bound-id-member?2131 p3242 keys3240) (values (vector (quote free-id) p3242) ids3244) (values (quote any) (cons (cons p3242 n3243) ids3244))) ((lambda (tmp3245) ((lambda (tmp3246) (if (if tmp3246 (apply (lambda (x3247 dots3248) (ellipsis?2149 dots3248)) tmp3246) #f) (apply (lambda (x3249 dots3250) (call-with-values (lambda () (cvt3241 x3249 (fx+2063 n3243 1) ids3244)) (lambda (p3251 ids3252) (values (if (eq? p3251 (quote any)) (quote each-any) (vector (quote each) p3251)) ids3252)))) tmp3246) ((lambda (tmp3253) (if tmp3253 (apply (lambda (x3254 y3255) (call-with-values (lambda () (cvt3241 y3255 n3243 ids3244)) (lambda (y3256 ids3257) (call-with-values (lambda () (cvt3241 x3254 n3243 ids3257)) (lambda (x3258 ids3259) (values (cons x3258 y3256) ids3259)))))) tmp3253) ((lambda (tmp3260) (if tmp3260 (apply (lambda () (values (quote ()) ids3244)) tmp3260) ((lambda (tmp3261) (if tmp3261 (apply (lambda (x3262) (call-with-values (lambda () (cvt3241 x3262 n3243 ids3244)) (lambda (p3264 ids3265) (values (vector (quote vector) p3264) ids3265)))) tmp3261) ((lambda (x3266) (values (vector (quote atom) (strip2151 p3242 (quote (())))) ids3244)) tmp3245))) ($sc-dispatch tmp3245 (quote #(vector each-any)))))) ($sc-dispatch tmp3245 (quote ()))))) ($sc-dispatch tmp3245 (quote (any . any)))))) ($sc-dispatch tmp3245 (quote (any any))))) p3242))))) (cvt3241 pattern3239 0 (quote ())))))) (lambda (e3267 r3268 w3269 s3270 mod3271) (let ((e3272 (source-wrap2133 e3267 w3269 s3270 mod3271))) ((lambda (tmp3273) ((lambda (tmp3274) (if tmp3274 (apply (lambda (_3275 val3276 key3277 m3278) (if (and-map (lambda (x3279) (if (id?2104 x3279) (not (ellipsis?2149 x3279)) #f)) key3277) (let ((x3281 (gen-var2152 (quote tmp)))) (build-application2072 s3270 (build-lambda2080 #f (list (quote tmp)) (list x3281) #f (gen-syntax-case3194 (build-lexical-reference2074 (quote value) #f (quote tmp) x3281) key3277 m3278 r3268 mod3271)) (list (chi2140 val3276 r3268 (quote (())) mod3271)))) (syntax-violation (quote syntax-case) "invalid literals list" e3272))) tmp3274) (syntax-violation #f "Source expression failed to match any pattern" tmp3273))) ($sc-dispatch tmp3273 (quote (any any each-any . each-any))))) e3272))))) (set! sc-expand (lambda (x3285 . rest3284) (if (if (pair? x3285) (equal? (car x3285) noexpand2061) #f) (cadr x3285) (let ((m3286 (if (null? rest3284) (quote e) (car rest3284))) (esew3287 (if (let ((t3288 (null? rest3284))) (if t3288 t3288 (null? (cdr rest3284)))) (quote (eval)) (cadr rest3284)))) (with-fluid* *mode*2062 m3286 (lambda () (chi-top2139 x3285 (quote ()) (quote ((top))) m3286 esew3287 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x3289) (nonsymbol-id?2103 x3289))) (set! datum->syntax (lambda (id3290 datum3291) (make-syntax-object2087 datum3291 (syntax-object-wrap2090 id3290) #f))) (set! syntax->datum (lambda (x3292) (strip2151 x3292 (quote (()))))) (set! generate-temporaries (lambda (ls3293) (begin (let ((x3294 ls3293)) (if (not (list? x3294)) (syntax-violation (quote generate-temporaries) "invalid argument" x3294) (if #f #f))) (map (lambda (x3295) (wrap2132 (gensym) (quote ((top))) #f)) ls3293)))) (set! free-identifier=? (lambda (x3296 y3297) (begin (let ((x3298 x3296)) (if (not (nonsymbol-id?2103 x3298)) (syntax-violation (quote free-identifier=?) "invalid argument" x3298) (if #f #f))) (let ((x3299 y3297)) (if (not (nonsymbol-id?2103 x3299)) (syntax-violation (quote free-identifier=?) "invalid argument" x3299) (if #f #f))) (free-id=?2127 x3296 y3297)))) (set! bound-identifier=? (lambda (x3300 y3301) (begin (let ((x3302 x3300)) (if (not (nonsymbol-id?2103 x3302)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3302) (if #f #f))) (let ((x3303 y3301)) (if (not (nonsymbol-id?2103 x3303)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3303) (if #f #f))) (bound-id=?2128 x3300 y3301)))) (set! syntax-violation (lambda (who3307 message3306 form3305 . subform3304) (begin (let ((x3308 who3307)) (if (not ((lambda (x3309) (let ((t3310 (not x3309))) (if t3310 t3310 (let ((t3311 (string? x3309))) (if t3311 t3311 (symbol? x3309)))))) x3308)) (syntax-violation (quote syntax-violation) "invalid argument" x3308) (if #f #f))) (let ((x3312 message3306)) (if (not (string? x3312)) (syntax-violation (quote syntax-violation) "invalid argument" x3312) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who3307 "~a: " "") "~a " (if (null? subform3304) "in ~a" "in subform `~s' of `~s'")) (let ((tail3313 (cons message3306 (map (lambda (x3314) (strip2151 x3314 (quote (())))) (append subform3304 (list form3305)))))) (if who3307 (cons who3307 tail3313) tail3313)) #f)))) (letrec ((match3319 (lambda (e3320 p3321 w3322 r3323 mod3324) (if (not r3323) #f (if (eq? p3321 (quote any)) (cons (wrap2132 e3320 w3322 mod3324) r3323) (if (syntax-object?2088 e3320) (match*3318 (let ((e3325 (syntax-object-expression2089 e3320))) (if (annotation? e3325) (annotation-expression e3325) e3325)) p3321 (join-wraps2123 w3322 (syntax-object-wrap2090 e3320)) r3323 (syntax-object-module2091 e3320)) (match*3318 (let ((e3326 e3320)) (if (annotation? e3326) (annotation-expression e3326) e3326)) p3321 w3322 r3323 mod3324)))))) (match*3318 (lambda (e3327 p3328 w3329 r3330 mod3331) (if (null? p3328) (if (null? e3327) r3330 #f) (if (pair? p3328) (if (pair? e3327) (match3319 (car e3327) (car p3328) w3329 (match3319 (cdr e3327) (cdr p3328) w3329 r3330 mod3331) mod3331) #f) (if (eq? p3328 (quote each-any)) (let ((l3332 (match-each-any3316 e3327 w3329 mod3331))) (if l3332 (cons l3332 r3330) #f)) (let ((atom-key3333 (vector-ref p3328 0))) (if (memv atom-key3333 (quote (each))) (if (null? e3327) (match-empty3317 (vector-ref p3328 1) r3330) (let ((l3334 (match-each3315 e3327 (vector-ref p3328 1) w3329 mod3331))) (if l3334 (letrec ((collect3335 (lambda (l3336) (if (null? (car l3336)) r3330 (cons (map car l3336) (collect3335 (map cdr l3336))))))) (collect3335 l3334)) #f))) (if (memv atom-key3333 (quote (free-id))) (if (id?2104 e3327) (if (free-id=?2127 (wrap2132 e3327 w3329 mod3331) (vector-ref p3328 1)) r3330 #f) #f) (if (memv atom-key3333 (quote (atom))) (if (equal? (vector-ref p3328 1) (strip2151 e3327 w3329)) r3330 #f) (if (memv atom-key3333 (quote (vector))) (if (vector? e3327) (match3319 (vector->list e3327) (vector-ref p3328 1) w3329 r3330 mod3331) #f) (if #f #f))))))))))) (match-empty3317 (lambda (p3337 r3338) (if (null? p3337) r3338 (if (eq? p3337 (quote any)) (cons (quote ()) r3338) (if (pair? p3337) (match-empty3317 (car p3337) (match-empty3317 (cdr p3337) r3338)) (if (eq? p3337 (quote each-any)) (cons (quote ()) r3338) (let ((atom-key3339 (vector-ref p3337 0))) (if (memv atom-key3339 (quote (each))) (match-empty3317 (vector-ref p3337 1) r3338) (if (memv atom-key3339 (quote (free-id atom))) r3338 (if (memv atom-key3339 (quote (vector))) (match-empty3317 (vector-ref p3337 1) r3338) (if #f #f))))))))))) (match-each-any3316 (lambda (e3340 w3341 mod3342) (if (annotation? e3340) (match-each-any3316 (annotation-expression e3340) w3341 mod3342) (if (pair? e3340) (let ((l3343 (match-each-any3316 (cdr e3340) w3341 mod3342))) (if l3343 (cons (wrap2132 (car e3340) w3341 mod3342) l3343) #f)) (if (null? e3340) (quote ()) (if (syntax-object?2088 e3340) (match-each-any3316 (syntax-object-expression2089 e3340) (join-wraps2123 w3341 (syntax-object-wrap2090 e3340)) mod3342) #f)))))) (match-each3315 (lambda (e3344 p3345 w3346 mod3347) (if (annotation? e3344) (match-each3315 (annotation-expression e3344) p3345 w3346 mod3347) (if (pair? e3344) (let ((first3348 (match3319 (car e3344) p3345 w3346 (quote ()) mod3347))) (if first3348 (let ((rest3349 (match-each3315 (cdr e3344) p3345 w3346 mod3347))) (if rest3349 (cons first3348 rest3349) #f)) #f)) (if (null? e3344) (quote ()) (if (syntax-object?2088 e3344) (match-each3315 (syntax-object-expression2089 e3344) p3345 (join-wraps2123 w3346 (syntax-object-wrap2090 e3344)) (syntax-object-module2091 e3344)) #f))))))) (set! $sc-dispatch (lambda (e3350 p3351) (if (eq? p3351 (quote any)) (list e3350) (if (syntax-object?2088 e3350) (match*3318 (let ((e3352 (syntax-object-expression2089 e3350))) (if (annotation? e3352) (annotation-expression e3352) e3352)) p3351 (syntax-object-wrap2090 e3350) (quote ()) (syntax-object-module2091 e3350)) (match*3318 (let ((e3353 e3350)) (if (annotation? e3353) (annotation-expression e3353) e3353)) p3351 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x3354) ((lambda (tmp3355) ((lambda (tmp3356) (if tmp3356 (apply (lambda (_3357 e13358 e23359) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13358 e23359))) tmp3356) ((lambda (tmp3361) (if tmp3361 (apply (lambda (_3362 out3363 in3364 e13365 e23366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3364 (quote ()) (list out3363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13365 e23366))))) tmp3361) ((lambda (tmp3368) (if tmp3368 (apply (lambda (_3369 out3370 in3371 e13372 e23373) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3371) (quote ()) (list out3370 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13372 e23373))))) tmp3368) (syntax-violation #f "Source expression failed to match any pattern" tmp3355))) ($sc-dispatch tmp3355 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any () any . each-any))))) x3354)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3377) ((lambda (tmp3378) ((lambda (tmp3379) (if tmp3379 (apply (lambda (_3380 k3381 keyword3382 pattern3383 template3384) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k3381 (map (lambda (tmp3387 tmp3386) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3386) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3387))) template3384 pattern3383)))))) tmp3379) (syntax-violation #f "Source expression failed to match any pattern" tmp3378))) ($sc-dispatch tmp3378 (quote (any each-any . #(each ((any . any) any))))))) x3377)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3388) ((lambda (tmp3389) ((lambda (tmp3390) (if (if tmp3390 (apply (lambda (let*3391 x3392 v3393 e13394 e23395) (and-map identifier? x3392)) tmp3390) #f) (apply (lambda (let*3397 x3398 v3399 e13400 e23401) (letrec ((f3402 (lambda (bindings3403) (if (null? bindings3403) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e13400 e23401))) ((lambda (tmp3407) ((lambda (tmp3408) (if tmp3408 (apply (lambda (body3409 binding3410) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding3410) body3409)) tmp3408) (syntax-violation #f "Source expression failed to match any pattern" tmp3407))) ($sc-dispatch tmp3407 (quote (any any))))) (list (f3402 (cdr bindings3403)) (car bindings3403))))))) (f3402 (map list x3398 v3399)))) tmp3390) (syntax-violation #f "Source expression failed to match any pattern" tmp3389))) ($sc-dispatch tmp3389 (quote (any #(each (any any)) any . each-any))))) x3388)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3411) ((lambda (tmp3412) ((lambda (tmp3413) (if tmp3413 (apply (lambda (_3414 var3415 init3416 step3417 e03418 e13419 c3420) ((lambda (tmp3421) ((lambda (tmp3422) (if tmp3422 (apply (lambda (step3423) ((lambda (tmp3424) ((lambda (tmp3425) (if tmp3425 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3425) ((lambda (tmp3430) (if tmp3430 (apply (lambda (e13431 e23432) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e13431 e23432)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3430) (syntax-violation #f "Source expression failed to match any pattern" tmp3424))) ($sc-dispatch tmp3424 (quote (any . each-any)))))) ($sc-dispatch tmp3424 (quote ())))) e13419)) tmp3422) (syntax-violation #f "Source expression failed to match any pattern" tmp3421))) ($sc-dispatch tmp3421 (quote each-any)))) (map (lambda (v3439 s3440) ((lambda (tmp3441) ((lambda (tmp3442) (if tmp3442 (apply (lambda () v3439) tmp3442) ((lambda (tmp3443) (if tmp3443 (apply (lambda (e3444) e3444) tmp3443) ((lambda (_3445) (syntax-violation (quote do) "bad step expression" orig-x3411 s3440)) tmp3441))) ($sc-dispatch tmp3441 (quote (any)))))) ($sc-dispatch tmp3441 (quote ())))) s3440)) var3415 step3417))) tmp3413) (syntax-violation #f "Source expression failed to match any pattern" tmp3412))) ($sc-dispatch tmp3412 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3411)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3448 (lambda (x3452 y3453) ((lambda (tmp3454) ((lambda (tmp3455) (if tmp3455 (apply (lambda (x3456 y3457) ((lambda (tmp3458) ((lambda (tmp3459) (if tmp3459 (apply (lambda (dy3460) ((lambda (tmp3461) ((lambda (tmp3462) (if tmp3462 (apply (lambda (dx3463) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx3463 dy3460))) tmp3462) ((lambda (_3464) (if (null? dy3460) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457))) tmp3461))) ($sc-dispatch tmp3461 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x3456)) tmp3459) ((lambda (tmp3465) (if tmp3465 (apply (lambda (stuff3466) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x3456 stuff3466))) tmp3465) ((lambda (else3467) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457)) tmp3458))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y3457)) tmp3455) (syntax-violation #f "Source expression failed to match any pattern" tmp3454))) ($sc-dispatch tmp3454 (quote (any any))))) (list x3452 y3453)))) (quasiappend3449 (lambda (x3468 y3469) ((lambda (tmp3470) ((lambda (tmp3471) (if tmp3471 (apply (lambda (x3472 y3473) ((lambda (tmp3474) ((lambda (tmp3475) (if tmp3475 (apply (lambda () x3472) tmp3475) ((lambda (_3476) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3472 y3473)) tmp3474))) ($sc-dispatch tmp3474 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y3473)) tmp3471) (syntax-violation #f "Source expression failed to match any pattern" tmp3470))) ($sc-dispatch tmp3470 (quote (any any))))) (list x3468 y3469)))) (quasivector3450 (lambda (x3477) ((lambda (tmp3478) ((lambda (x3479) ((lambda (tmp3480) ((lambda (tmp3481) (if tmp3481 (apply (lambda (x3482) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x3482))) tmp3481) ((lambda (tmp3484) (if tmp3484 (apply (lambda (x3485) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3485)) tmp3484) ((lambda (_3487) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3479)) tmp3480))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x3479)) tmp3478)) x3477))) (quasi3451 (lambda (p3488 lev3489) ((lambda (tmp3490) ((lambda (tmp3491) (if tmp3491 (apply (lambda (p3492) (if (= lev3489 0) p3492 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3492) (- lev3489 1))))) tmp3491) ((lambda (tmp3493) (if tmp3493 (apply (lambda (p3494 q3495) (if (= lev3489 0) (quasiappend3449 p3494 (quasi3451 q3495 lev3489)) (quasicons3448 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3494) (- lev3489 1))) (quasi3451 q3495 lev3489)))) tmp3493) ((lambda (tmp3496) (if tmp3496 (apply (lambda (p3497) (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3497) (+ lev3489 1)))) tmp3496) ((lambda (tmp3498) (if tmp3498 (apply (lambda (p3499 q3500) (quasicons3448 (quasi3451 p3499 lev3489) (quasi3451 q3500 lev3489))) tmp3498) ((lambda (tmp3501) (if tmp3501 (apply (lambda (x3502) (quasivector3450 (quasi3451 x3502 lev3489))) tmp3501) ((lambda (p3504) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p3504)) tmp3490))) ($sc-dispatch tmp3490 (quote #(vector each-any)))))) ($sc-dispatch tmp3490 (quote (any . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp3490 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p3488)))) (lambda (x3505) ((lambda (tmp3506) ((lambda (tmp3507) (if tmp3507 (apply (lambda (_3508 e3509) (quasi3451 e3509 0)) tmp3507) (syntax-violation #f "Source expression failed to match any pattern" tmp3506))) ($sc-dispatch tmp3506 (quote (any any))))) x3505))))) +(define include (make-syncase-macro (quote macro) (lambda (x3510) (letrec ((read-file3511 (lambda (fn3512 k3513) (let ((p3514 (open-input-file fn3512))) (letrec ((f3515 (lambda (x3516) (if (eof-object? x3516) (begin (close-input-port p3514) (quote ())) (cons (datum->syntax k3513 x3516) (f3515 (read p3514))))))) (f3515 (read p3514))))))) ((lambda (tmp3517) ((lambda (tmp3518) (if tmp3518 (apply (lambda (k3519 filename3520) (let ((fn3521 (syntax->datum filename3520))) ((lambda (tmp3522) ((lambda (tmp3523) (if tmp3523 (apply (lambda (exp3524) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp3524)) tmp3523) (syntax-violation #f "Source expression failed to match any pattern" tmp3522))) ($sc-dispatch tmp3522 (quote each-any)))) (read-file3511 fn3521 k3519)))) tmp3518) (syntax-violation #f "Source expression failed to match any pattern" tmp3517))) ($sc-dispatch tmp3517 (quote (any any))))) x3510))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x3526) ((lambda (tmp3527) ((lambda (tmp3528) (if tmp3528 (apply (lambda (_3529 e3530) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x3526)) tmp3528) (syntax-violation #f "Source expression failed to match any pattern" tmp3527))) ($sc-dispatch tmp3527 (quote (any any))))) x3526)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3531) ((lambda (tmp3532) ((lambda (tmp3533) (if tmp3533 (apply (lambda (_3534 e3535) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x3531)) tmp3533) (syntax-violation #f "Source expression failed to match any pattern" tmp3532))) ($sc-dispatch tmp3532 (quote (any any))))) x3531)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3536) ((lambda (tmp3537) ((lambda (tmp3538) (if tmp3538 (apply (lambda (_3539 e3540 m13541 m23542) ((lambda (tmp3543) ((lambda (body3544) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3540)) body3544)) tmp3543)) (letrec ((f3545 (lambda (clause3546 clauses3547) (if (null? clauses3547) ((lambda (tmp3549) ((lambda (tmp3550) (if tmp3550 (apply (lambda (e13551 e23552) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13551 e23552))) tmp3550) ((lambda (tmp3554) (if tmp3554 (apply (lambda (k3555 e13556 e23557) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3555)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13556 e23557)))) tmp3554) ((lambda (_3560) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3549))) ($sc-dispatch tmp3549 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3549 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause3546) ((lambda (tmp3561) ((lambda (rest3562) ((lambda (tmp3563) ((lambda (tmp3564) (if tmp3564 (apply (lambda (k3565 e13566 e23567) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3565)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13566 e23567)) rest3562)) tmp3564) ((lambda (_3570) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3563))) ($sc-dispatch tmp3563 (quote (each-any any . each-any))))) clause3546)) tmp3561)) (f3545 (car clauses3547) (cdr clauses3547))))))) (f3545 m13541 m23542)))) tmp3538) (syntax-violation #f "Source expression failed to match any pattern" tmp3537))) ($sc-dispatch tmp3537 (quote (any any any . each-any))))) x3536)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3571) ((lambda (tmp3572) ((lambda (tmp3573) (if tmp3573 (apply (lambda (_3574 e3575) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3575)) (list (cons _3574 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e3575 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp3573) (syntax-violation #f "Source expression failed to match any pattern" tmp3572))) ($sc-dispatch tmp3572 (quote (any any))))) x3571)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index bc3937cc8..dc8e93e51 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1431,7 +1431,7 @@ (new-vars (map gen-var ids))) (k (map syntax->datum ids) new-vars - docstring + (and docstring (syntax->datum docstring)) (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) @@ -1451,7 +1451,7 @@ (if (null? ls1) ls2 (f (cdr ls1) (cons (car ls1) ls2)))) - docstring + (and docstring (syntax->datum docstring)) (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 7a22f0dff..e5ef34bb0 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -24,6 +24,9 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) +(define exception:failed-match + (cons 'syntax-error "failed to match any pattern")) + ;;; ;;; miscellaneous @@ -85,17 +88,19 @@ ;; Macros are accepted as function parameters. ;; Functions that 'apply' macros are rewritten!!! - (expect-fail-exception "macro as argument" - exception:wrong-type-arg - (let ((f (lambda (p a b) (p a b)))) - (f and #t #t))) + (pass-if-exception "macro as argument" + exception:failed-match + (primitive-eval + '(let ((f (lambda (p a b) (p a b)))) + (f and #t #t)))) - (expect-fail-exception "passing macro as parameter" - exception:wrong-type-arg - (let* ((f (lambda (p a b) (p a b))) - (foo (procedure-source f))) - (f and #t #t) - (equal? (procedure-source f) foo))) + (pass-if-exception "passing macro as parameter" + exception:failed-match + (primitive-eval + '(let* ((f (lambda (p a b) (p a b))) + (foo (procedure-source f))) + (f and #t #t) + (equal? (procedure-source f) foo)))) )) From 877f06c33829ac2a5ba263826454f880d5460ee8 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 20 May 2009 18:50:52 +0100 Subject: [PATCH 119/375] Fix `explicitely' typos, should be `explicitly' --- ANNOUNCE | 2 +- doc/maint/guile.texi | 2 +- doc/ref/api-data.texi | 2 +- doc/ref/api-init.texi | 2 +- doc/ref/api-memory.texi | 4 ++-- doc/ref/api-undocumented.texi | 2 +- doc/ref/libguile-concepts.texi | 2 +- libguile/async.c | 2 +- libguile/strings.c | 2 +- module/ice-9/deprecated.scm | 2 +- 10 files changed, 11 insertions(+), 11 deletions(-) diff --git a/ANNOUNCE b/ANNOUNCE index 89d8cbde4..bfbda7316 100644 --- a/ANNOUNCE +++ b/ANNOUNCE @@ -30,7 +30,7 @@ The NEWS file is quite long. Here are the most interesting entries: from threads that have not been created by Guile. * Mutexes and condition variables are now always fair. A recursive - mutex must be requested explicitely. + mutex must be requested explicitly. * The low-level thread API has been removed. diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index ac0833421..4ef4aab18 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -204,7 +204,7 @@ Execute all thunks from the asyncs of the list @var{list_of_a}. @deffn {Scheme Procedure} system-async thunk @deffnx {C Function} scm_system_async (thunk) This function is deprecated. You can use @var{thunk} directly -instead of explicitely creating an async object. +instead of explicitly creating an async object. @end deffn diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index e1db2a612..b529199db 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -331,7 +331,7 @@ integers. The motivation for this behavior is that the inexactness of a number should not be lost silently. If you want to allow inexact integers, -you can explicitely insert a call to @code{inexact->exact} or to its C +you can explicitly insert a call to @code{inexact->exact} or to its C equivalent @code{scm_inexact_to_exact}. (Only inexact integers will be converted by this call into exact integers; inexact non-integers will become exact fractions.) diff --git a/doc/ref/api-init.texi b/doc/ref/api-init.texi index 0e4e8b8b7..f9714c3b6 100644 --- a/doc/ref/api-init.texi +++ b/doc/ref/api-init.texi @@ -61,7 +61,7 @@ Arrange things so that all of the code in the current thread executes as if from within a call to @code{scm_with_guile}. That is, all functions called by the current thread can assume that @code{SCM} values on their stack frames are protected from the garbage collector (except when the -thread has explicitely left guile mode, of course). +thread has explicitly left guile mode, of course). When @code{scm_init_guile} is called from a thread that already has been in guile mode once, nothing happens. This behavior matters when you diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index 32d39982c..f492203f7 100644 --- a/doc/ref/api-memory.texi +++ b/doc/ref/api-memory.texi @@ -10,7 +10,7 @@ Guile uses a @emph{garbage collector} to manage most of its objects. While the garbage collector is designed to be mostly invisible, you -sometimes need to interact with it explicitely. +sometimes need to interact with it explicitly. See @ref{Garbage Collection} for a general discussion of how garbage collection relates to using Guile from C. @@ -201,7 +201,7 @@ below for a motivation. @deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what}) Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}. -Note that you need to explicitely pass the @var{size} parameter. This +Note that you need to explicitly pass the @var{size} parameter. This is done since it should normally be easy to provide this parameter (for memory that is associated with GC controlled objects) and this frees us from tracking this value in the GC itself, which will keep diff --git a/doc/ref/api-undocumented.texi b/doc/ref/api-undocumented.texi index 826b4d38b..ef1df19c5 100644 --- a/doc/ref/api-undocumented.texi +++ b/doc/ref/api-undocumented.texi @@ -257,7 +257,7 @@ otherwise return the first argument. @deffn {Scheme Procedure} system-async thunk @deffnx {C Function} scm_system_async (thunk) This function is deprecated. You can use @var{thunk} directly -instead of explicitely creating an async object. +instead of explicitly creating an async object. @end deffn diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi index 8979f0cd6..15d54f531 100644 --- a/doc/ref/libguile-concepts.texi +++ b/doc/ref/libguile-concepts.texi @@ -182,7 +182,7 @@ As explained above, the @code{SCM} type can represent all Scheme values. Some values fit entirely into a @code{SCM} value (such as small integers), but other values require additional storage in the heap (such as strings and vectors). This additional storage is managed -automatically by Guile. You don't need to explicitely deallocate it +automatically by Guile. You don't need to explicitly deallocate it when a @code{SCM} value is no longer used. Two things must be guaranteed so that Guile is able to manage the diff --git a/libguile/async.c b/libguile/async.c index bf03c48bd..4dc5ea475 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -179,7 +179,7 @@ scm_async_click () SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, (SCM thunk), "This function is deprecated. You can use @var{thunk} directly\n" - "instead of explicitely creating an async object.\n") + "instead of explicitly creating an async object.\n") #define FUNC_NAME s_scm_system_async { scm_c_issue_deprecation_warning diff --git a/libguile/strings.c b/libguile/strings.c index c13802664..012e08b6e 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1069,7 +1069,7 @@ scm_i_deprecated_string_chars (SCM str) "SCM_STRING_CHARS does not work with shared substrings.", SCM_EOL); - /* We explicitely test for read-only strings to produce a better + /* We explicitly test for read-only strings to produce a better error message. */ diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index f3b7cafe4..6f2c2258b 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -21,7 +21,7 @@ (define substring-move-right! substring-move!) ;; This method of dynamically linking Guile Extensions is deprecated. -;; Use `load-extension' explicitely from Scheme code instead. +;; Use `load-extension' explicitly from Scheme code instead. (define (split-c-module-name str) (let loop ((rev '()) From 88f2f7a12718492d175efdb1230d30256f1c4041 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 7 Sep 2008 16:29:05 +0100 Subject: [PATCH 120/375] Avoid "no duplicate" popen tests leaving zombie processes On the one hand we want the child process in these tests to exit. On the other, we don't want it to exit before the parent Guile code has tested the relevant condition (EOF in the first test, broken pipe in the second) - because these conditions would obviously be true if the child had already exited, and that's not what we're trying to test here. We're trying to test getting EOF and broken pipe while the child process is still alive. * test-suite/tests/popen.test (open-input-pipe:no duplicate): Add another pipe from parent to child, so that the child can finish by reading from this. Then the parent controls the child lifetime by writing to this pipe. * test-suite/tests/popen.test (open-output-pipe:no duplicate): Add another pipe from child to parent, and have the child finish by endlessly writing into this. Then the parent controls the child lifetime by closing its end of the pipe, causing a broken pipe in the child. --- test-suite/tests/popen.test | 108 +++++++++++++++++++++++++----------- 1 file changed, 77 insertions(+), 31 deletions(-) diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 1dd2bc78e..08bfa7cb4 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -73,20 +73,46 @@ (open-input-pipe "echo hello")))))) #t) + (pass-if "open-input-pipe process gets (current-input-port) as stdin" + (let* ((p2c (pipe)) + (port (with-input-from-port (car p2c) + (lambda () + (open-input-pipe "read && echo $REPLY"))))) + (display "hello\n" (cdr p2c)) + (force-output (cdr p2c)) + (let ((result (eq? (read port) 'hello))) + (close-port (cdr p2c)) + (close-pipe port) + result))) + ;; After the child closes stdout (which it indicates here by writing - ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 and - ;; earlier a duplicate of stdout existed in the child, meaning eof was not - ;; seen. + ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 + ;; and earlier a duplicate of stdout existed in the child, meaning + ;; eof was not seen. + ;; + ;; Note that the objective here is to test that the parent sees EOF + ;; while the child is still alive. (It is obvious that the parent + ;; must see EOF once the child has died.) The use of the `p2c' + ;; pipe, and `echo closed' and `read' in the child, allows us to be + ;; sure that we are testing what the parent sees at a point where + ;; the child has closed stdout but is still alive. (pass-if "no duplicate" - (let* ((pair (pipe)) - (port (with-error-to-port (cdr pair) + (let* ((c2p (pipe)) + (p2c (pipe)) + (port (with-error-to-port (cdr c2p) (lambda () - (open-input-pipe - "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999"))))) - (close-port (cdr pair)) ;; write side - (and (char? (read-char (car pair))) ;; wait for child to do its thing - (char-ready? port) - (eof-object? (read-char port)))))) + (with-input-from-port (car p2c) + (lambda () + (open-input-pipe + "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read"))))))) + (close-port (cdr c2p)) ;; write side + (let ((result (eof-object? (read-char port)))) + (display "hello!\n" (cdr p2c)) + (force-output (cdr p2c)) + (close-pipe port) + result))) + + ) ;; ;; open-output-pipe @@ -121,27 +147,47 @@ #t) ;; After the child closes stdin (which it indicates here by writing - ;; "closed" to stderr), the parent should see a broken pipe. We setup to - ;; see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 and earlier a - ;; duplicate of stdin existed in the child, preventing the broken pipe - ;; occurring. + ;; "closed" to stderr), the parent should see a broken pipe. We + ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 + ;; and earlier a duplicate of stdin existed in the child, preventing + ;; the broken pipe occurring. + ;; + ;; Note that the objective here is to test that the parent sees a + ;; broken pipe while the child is still alive. (It is obvious that + ;; the parent will see a broken pipe once the child has died.) The + ;; use of the `c2p' pipe, and the repeated `echo closed' in the + ;; child, allows us to be sure that we are testing what the parent + ;; sees at a point where the child has closed stdin but is still + ;; alive. + ;; + ;; Note that `with-epipe' must apply only to the parent and not to + ;; the child process; we rely on the child getting SIGPIPE, to + ;; terminate it (and avoid leaving a zombie). (pass-if "no duplicate" - (with-epipe - (lambda () - (let* ((pair (pipe)) - (port (with-error-to-port (cdr pair) - (lambda () - (open-output-pipe - "exec 0&2; exec 2>/dev/null; sleep 999"))))) - (close-port (cdr pair)) ;; write side - (and (char? (read-char (car pair))) ;; wait for child to do its thing - (catch 'system-error - (lambda () - (write-char #\x port) - (force-output port) - #f) - (lambda (key name fmt args errno-list) - (= (car errno-list) EPIPE))))))))) + (let* ((c2p (pipe)) + (port (with-error-to-port (cdr c2p) + (lambda () + (open-output-pipe + "exec 0&2; done"))))) + (close-port (cdr c2p)) ;; write side + (with-epipe + (lambda () + (let ((result + (and (char? (read-char (car c2p))) ;; wait for child to do its thing + (catch 'system-error + (lambda () + (write-char #\x port) + (force-output port) + #f) + (lambda (key name fmt args errno-list) + (= (car errno-list) EPIPE)))))) + ;; Now close our reading end of the pipe. This should give + ;; the child a broken pipe and so allow it to exit. + (close-port (car c2p)) + (close-pipe port) + result))))) + + ) ;; ;; close-pipe From f5851b8942b81ef1ed3eb9e153a4ae274260f176 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 21 Apr 2009 22:27:38 +0200 Subject: [PATCH 121/375] Update `NEWS' and `THANKS'. --- NEWS | 1 + THANKS | 1 + 2 files changed, 2 insertions(+) diff --git a/NEWS b/NEWS index de8e2c13d..831f2ec06 100644 --- a/NEWS +++ b/NEWS @@ -52,6 +52,7 @@ Changes in 1.8.7 (since 1.8.6) * Bugs fixed +** Fix compilation with `--disable-deprecated' ** Fix %fast-slot-ref/set!, to avoid possible segmentation fault ** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion ** Fix build problem when scm_t_timespec is different from struct timespec diff --git a/THANKS b/THANKS index d93837d3b..c347abc73 100644 --- a/THANKS +++ b/THANKS @@ -61,6 +61,7 @@ For fixes or providing information which led to a fix: René Köcher Matthias Köppe Matt Kraai + Daniel Kraft Miroslav Lichvar Jeff Long Marco Maggi From 452e13f3112f38c67d8652d284c8b96e0851c272 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 21 Apr 2009 22:34:54 +0200 Subject: [PATCH 122/375] Fix compilation of `gcc_os_dep.c' on Tru64. * libguile/gc_os_dep.c [OSF1](_end): Specify the type. (scm_get_stack_base): Suitably cast RESULT. Reported by Didier Godefroy . --- libguile/gc_os_dep.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c index d89f1cf10..7bc96447f 100644 --- a/libguile/gc_os_dep.c +++ b/libguile/gc_os_dep.c @@ -1127,7 +1127,7 @@ scm_get_stack_base () # ifdef OSF1 # define OS_TYPE "OSF1" # define DATASTART ((ptr_t) 0x140000000) - extern _end; + extern int _end; # define DATAEND ((ptr_t) &_end) # define HEURISTIC2 /* Normally HEURISTIC2 is too conervative, since */ @@ -1912,7 +1912,7 @@ void *scm_get_stack_base() # if STACK_GROWS_DOWN result = GC_find_limit((ptr_t)(&dummy), TRUE); # ifdef HEURISTIC2_LIMIT - if (result > HEURISTIC2_LIMIT + if ((ptr_t)result > HEURISTIC2_LIMIT && (ptr_t)(&dummy) < HEURISTIC2_LIMIT) { result = HEURISTIC2_LIMIT; } From 5e647d08e95de4245bdd75e94929b29e095b52f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 21 Apr 2009 22:37:45 +0200 Subject: [PATCH 123/375] Fix compilation of `numbers.c' on Tru64. * libguile/numbers.c (scm_c_make_polar): Don't use sincos(3) on non-GNU platforms. Reported by Didier Godefroy . --- libguile/numbers.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 52dfb73a8..37435b50b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -5352,7 +5352,12 @@ SCM scm_c_make_polar (double mag, double ang) { double s, c; -#if HAVE_SINCOS + + /* The sincos(3) function is undocumented an broken on Tru64. Thus we only + use it on Glibc-based systems that have it (it's a GNU extension). See + http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for + details. */ +#if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE) sincos (ang, &s, &c); #else s = sin (ang); From d0f452d16299e8dbf2258fd00fbb7303186e6bdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 22 Apr 2009 23:53:52 +0200 Subject: [PATCH 124/375] Remove extraneous semicolons from `test-conversion.c'. * test-suite/standalone/test-conversion.c: Remove extraneous semicolon following `DEF[SU]TST' invocations since that made Compaq C V6.5-011 (`cc' on Tru64 5.1b) bail out. --- test-suite/standalone/test-conversion.c | 44 ++++++++++++------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 92835f244..afaa2ecc4 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -680,31 +680,31 @@ test_8u (const char *str, scm_t_uintmax (*func) (SCM), const char *func_name, #define DEFSTST(f) static scm_t_intmax tst_##f (SCM x) { return f(x); } #define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); } -DEFSTST (scm_to_schar); -DEFUTST (scm_to_uchar); -DEFSTST (scm_to_char); -DEFSTST (scm_to_short); -DEFUTST (scm_to_ushort); -DEFSTST (scm_to_int); -DEFUTST (scm_to_uint); -DEFSTST (scm_to_long); -DEFUTST (scm_to_ulong); +DEFSTST (scm_to_schar) +DEFUTST (scm_to_uchar) +DEFSTST (scm_to_char) +DEFSTST (scm_to_short) +DEFUTST (scm_to_ushort) +DEFSTST (scm_to_int) +DEFUTST (scm_to_uint) +DEFSTST (scm_to_long) +DEFUTST (scm_to_ulong) #if SCM_SIZEOF_LONG_LONG != 0 -DEFSTST (scm_to_long_long); -DEFUTST (scm_to_ulong_long); +DEFSTST (scm_to_long_long) +DEFUTST (scm_to_ulong_long) #endif -DEFSTST (scm_to_ssize_t); -DEFUTST (scm_to_size_t); +DEFSTST (scm_to_ssize_t) +DEFUTST (scm_to_size_t) -DEFSTST (scm_to_int8); -DEFUTST (scm_to_uint8); -DEFSTST (scm_to_int16); -DEFUTST (scm_to_uint16); -DEFSTST (scm_to_int32); -DEFUTST (scm_to_uint32); +DEFSTST (scm_to_int8) +DEFUTST (scm_to_uint8) +DEFSTST (scm_to_int16) +DEFUTST (scm_to_uint16) +DEFSTST (scm_to_int32) +DEFUTST (scm_to_uint32) #ifdef SCM_HAVE_T_INT64 -DEFSTST (scm_to_int64); -DEFUTST (scm_to_uint64); +DEFSTST (scm_to_int64) +DEFUTST (scm_to_uint64) #endif #define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te) From ca329120627a0905c1aac805a52a59439f6c5482 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 23 Apr 2009 00:28:32 +0200 Subject: [PATCH 125/375] Work around the lack of hstrerror(3) declaration on Tru64. * configure.in: Look for the declaration of hstrerror(3). * libguile/net_db.c: Add hstrerror(3) declaration if `HAVE_DECL_HSTRERROR' is undefined. --- configure.in | 4 +++- libguile/net_db.c | 8 +++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/configure.in b/configure.in index 553d68814..466e4d875 100644 --- a/configure.in +++ b/configure.in @@ -734,10 +734,12 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime # sethostname - the function itself check because it's not in mingw, # the DECL is checked because Solaris 10 doens't have in any header # xlocale.h - needed on Darwin for the `locale_t' API +# hstrerror - on Tru64 5.1b the symbol is available in libc but the +# declaration isn't anywhere. # AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h xlocale.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) -AC_CHECK_DECLS([sethostname]) +AC_CHECK_DECLS([sethostname, hstrerror]) # crypt() may or may not be available, for instance in some countries there # are restrictions on cryptography. diff --git a/libguile/net_db.c b/libguile/net_db.c index deb8d381d..af6e3d5f4 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -1,5 +1,5 @@ /* "net_db.c" network database support - * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 Free Software Foundation, Inc. + * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -64,6 +64,12 @@ extern int h_errno; #endif +#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \ + && !defined __MINGW32__ && !defined __CYGWIN__ +/* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */ +extern const char *hstrerror (int); +#endif + SCM_SYMBOL (scm_host_not_found_key, "host-not-found"); From 5f380d71c3b1080d8f0e52610fa0b5efe09232c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 23 Apr 2009 22:24:32 +0200 Subject: [PATCH 126/375] Work around lack of cuserid(3) declaration on Tru64 5.1b. * configure.in: Check for a cuserid(3) declaration. * libguile/posix.c [HAVE_CUSERID][!HAVE_DECL_CUSERID]: Provide a declaration. --- configure.in | 4 +++- libguile/posix.c | 5 +++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/configure.in b/configure.in index 466e4d875..f06dab8bb 100644 --- a/configure.in +++ b/configure.in @@ -736,10 +736,12 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime # xlocale.h - needed on Darwin for the `locale_t' API # hstrerror - on Tru64 5.1b the symbol is available in libc but the # declaration isn't anywhere. +# cuserid - on Tru64 5.1b the declaration is documented to be available +# only with `_XOPEN_SOURCE' or some such. # AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h xlocale.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) -AC_CHECK_DECLS([sethostname, hstrerror]) +AC_CHECK_DECLS([sethostname, hstrerror, cuserid]) # crypt() may or may not be available, for instance in some countries there # are restrictions on cryptography. diff --git a/libguile/posix.c b/libguile/posix.c index 78fd295b5..ddbaeaacb 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1869,6 +1869,11 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, #endif /* HAVE_GETLOGIN */ #if HAVE_CUSERID + +# if !HAVE_DECL_CUSERID +extern char *cuserid (char *); +# endif + SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0, (void), "Return a string containing a user name associated with the\n" From 66818dbb710c83730310c15088f1784d61158f04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 23 Apr 2009 22:51:27 +0200 Subject: [PATCH 127/375] Use instead of when needed (e.g., Tru64 5.1b). * configure.in: Look for . * test-suite/standalone/test-round.c: Use if available. --- configure.in | 4 +++- test-suite/standalone/test-round.c | 5 ++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/configure.in b/configure.in index f06dab8bb..07c476686 100644 --- a/configure.in +++ b/configure.in @@ -621,6 +621,8 @@ AC_SUBST([SCM_I_GSC_HAVE_STRUCT_DIRENT64]) # Reasons for testing: # complex.h - new in C99 # fenv.h - available in C99, but not older systems +# machine/fpu.h - on Tru64 5.1b, the declaration of fesetround(3) is in +# this file instead of # process.h - mingw specific # langinfo.h, nl_types.h - SuS v2 # @@ -628,7 +630,7 @@ AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h proces regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \ sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \ sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \ -direct.h langinfo.h nl_types.h]) +direct.h langinfo.h nl_types.h machine/fpu.h]) # "complex double" is new in C99, and "complex" is only a keyword if # is included diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index 9725491c9..f9b40773b 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -25,6 +25,9 @@ #if HAVE_FENV_H #include +#elif defined HAVE_MACHINE_FPU_H +/* On Tru64 5.1b, the declaration of fesetround(3) is here. */ +# include #endif #include From e2e85d14065d0ec417570bf398dc19ab87ff366f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 23 Apr 2009 23:20:59 +0200 Subject: [PATCH 128/375] Don't use raw divisions by zero in `test-conversion.c'. * test-suite/standalone/test-conversion.c (ieee_init): New function. (guile_Inf, guile_NaN): New variables. (test_from_double, test_to_double): Use them. Divisions by zero made `cc' on Tru64 5.1b ("Compaq C V6.5-011") bail out and led to a floating point exception when compiled with GCC on the same platform. (main): Call `ieee_init ()'. --- test-suite/standalone/test-conversion.c | 56 ++++++++++++++++++++++--- 1 file changed, 51 insertions(+), 5 deletions(-) diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index afaa2ecc4..41f99d3bc 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -818,15 +818,60 @@ test_9 (double val, const char *result) } } +/* The `infinity' and `not-a-number' values. */ +static double guile_Inf, guile_NaN; + +/* Initialize GUILE_INF and GUILE_NAN. Taken from `guile_ieee_init ()' in + `libguile/numbers.c'. */ +static void +ieee_init (void) +{ +#ifdef INFINITY + /* C99 INFINITY, when available. + FIXME: The standard allows for INFINITY to be something that overflows + at compile time. We ought to have a configure test to check for that + before trying to use it. (But in practice we believe this is not a + problem on any system guile is likely to target.) */ + guile_Inf = INFINITY; +#elif HAVE_DINFINITY + /* OSF */ + extern unsigned int DINFINITY[2]; + guile_Inf = (*((double *) (DINFINITY))); +#else + double tmp = 1e+10; + guile_Inf = tmp; + for (;;) + { + guile_Inf *= 1e+10; + if (guile_Inf == tmp) + break; + tmp = guile_Inf; + } +#endif + +#ifdef NAN + /* C99 NAN, when available */ + guile_NaN = NAN; +#elif HAVE_DQNAN + { + /* OSF */ + extern unsigned int DQNAN[2]; + guile_NaN = (*((double *)(DQNAN))); + } +#else + guile_NaN = guile_Inf / guile_Inf; +#endif +} + static void test_from_double () { test_9 (12, "12.0"); test_9 (0.25, "0.25"); test_9 (0.1, "0.1"); - test_9 (1.0/0.0, "+inf.0"); - test_9 (-1.0/0.0, "-inf.0"); - test_9 (0.0/0.0, "+nan.0"); + test_9 (guile_Inf, "+inf.0"); + test_9 (-guile_Inf, "-inf.0"); + test_9 (guile_NaN, "+nan.0"); } typedef struct { @@ -880,8 +925,8 @@ test_to_double () test_10 ("12", 12.0, 0); test_10 ("0.25", 0.25, 0); test_10 ("1/4", 0.25, 0); - test_10 ("+inf.0", 1.0/0.0, 0); - test_10 ("-inf.0", -1.0/0.0, 0); + test_10 ("+inf.0", guile_Inf, 0); + test_10 ("-inf.0",-guile_Inf, 0); test_10 ("+1i", 0.0, 1); } @@ -1056,6 +1101,7 @@ tests (void *data, int argc, char **argv) int main (int argc, char *argv[]) { + ieee_init (); scm_boot_guile (argc, argv, tests, NULL); return 0; } From 1bcf79939201609e1cee667dd9bcd8c3c519385d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 24 Apr 2009 00:44:43 +0200 Subject: [PATCH 129/375] Update `NEWS'. --- NEWS | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS b/NEWS index 831f2ec06..64826e874 100644 --- a/NEWS +++ b/NEWS @@ -57,6 +57,7 @@ Changes in 1.8.7 (since 1.8.6) ** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion ** Fix build problem when scm_t_timespec is different from struct timespec ** Fix build when compiled with -Wundef -Werror +** More build fixes for `alphaev56-dec-osf5.1b' (Tru64) ** Allow @ macro to work with (ice-9 syncase) From 13ff47408fcda1fb57df97102bc0fe7730f37a9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 11 May 2009 22:13:29 +0200 Subject: [PATCH 130/375] Fix compilation of `test-round.c' on BSD. * test-suite/standalone/test-round.c (HAVE_MACHINE_FPU_H): Include when available. This fixes compilation on NetBSD. Reported by Greg Toxel. --- test-suite/standalone/test-round.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index f9b40773b..1340fffa7 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -26,7 +26,11 @@ #if HAVE_FENV_H #include #elif defined HAVE_MACHINE_FPU_H -/* On Tru64 5.1b, the declaration of fesetround(3) is here. */ +/* On Tru64 5.1b, the declaration of fesetround(3) is in . + On NetBSD, this header has to be included along with . */ +# ifdef HAVE_SYS_TYPES_H +# include +# endif # include #endif From 5c006c3f5183cda8ddd57c470df03ba0cd7cb492 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 21 May 2009 00:16:47 +0200 Subject: [PATCH 131/375] Update `NEWS' wrt. `branch_release-1-8'. --- NEWS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS b/NEWS index 64826e874..a303868f1 100644 --- a/NEWS +++ b/NEWS @@ -58,6 +58,8 @@ Changes in 1.8.7 (since 1.8.6) ** Fix build problem when scm_t_timespec is different from struct timespec ** Fix build when compiled with -Wundef -Werror ** More build fixes for `alphaev56-dec-osf5.1b' (Tru64) +** With GCC, always compile with `-mieee' on `alpha*' and `sh*' +** Better diagnose broken `(strftime "%z" ...)' in `time.test' (bug #24130) ** Allow @ macro to work with (ice-9 syncase) From 5d66005209f57878aea994c9109eb32bd9b9feab Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Fri, 24 Apr 2009 22:23:13 -0700 Subject: [PATCH 132/375] Symbols longer than 128 chars can cause an exception. Also, the terminating colon of long postfix keywords are not handled correctly. * test-suite/tests/reader.test ("read-options"): Add test for long postfix keywords. * libguile/read.c (scm_read_mixed_case_symbol): Fix exception on symbols are greater than 128 chars. Also, colons are not stripped from long postfix keywords. --- libguile/read.c | 15 ++++++++++++--- test-suite/tests/reader.test | 5 +++++ 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 47b80041e..61806f263 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -552,12 +552,21 @@ scm_read_mixed_case_symbol (int chr, SCM port) if (scm_is_pair (str)) { + size_t len; + str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); - result = scm_string_to_symbol (str); + len = scm_c_string_length (str); /* Per SRFI-88, `:' alone is an identifier, not a keyword. */ - if (postfix && ends_with_colon && (scm_c_string_length (result) > 1)) - result = scm_symbol_to_keyword (result); + if (postfix && ends_with_colon && (len > 1)) + { + /* Strip off colon. */ + str = scm_c_substring (str, 0, len-1); + result = scm_string_to_symbol (str); + result = scm_symbol_to_keyword (result); + } + else + result = scm_string_to_symbol (str); } else { diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index b068c716d..0b6f9a468 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -165,6 +165,11 @@ (with-read-options '(keywords postfix) (lambda () (read-string "keyword:"))))) + (pass-if "long postfix keywords" + (eq? #:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789 + (with-read-options '(keywords postfix) + (lambda () + (read-string "keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:"))))) (pass-if "`:' is not a postfix keyword (per SRFI-88)" (eq? ': (with-read-options '(keywords postfix) From fc76c08d872f816a075de0a9096006966f00a666 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 12 May 2009 00:12:18 +0200 Subject: [PATCH 133/375] Update `NEWS'. --- NEWS | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS b/NEWS index a303868f1..1785fe8d2 100644 --- a/NEWS +++ b/NEWS @@ -60,6 +60,7 @@ Changes in 1.8.7 (since 1.8.6) ** More build fixes for `alphaev56-dec-osf5.1b' (Tru64) ** With GCC, always compile with `-mieee' on `alpha*' and `sh*' ** Better diagnose broken `(strftime "%z" ...)' in `time.test' (bug #24130) +** Fix parsing of SRFI-88/postfix keywords longer than 128 characters ** Allow @ macro to work with (ice-9 syncase) From f240aacb412172f9c228653674b13d41279bebc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 21 May 2009 01:00:41 +0200 Subject: [PATCH 134/375] Add Gnulib portability modules; update Gnulib files. * m4/gnulib-cache.m4 (gl_MODULES): Add `flock' (provides flock(2) declaration and implementation), `fpieee' (fixes floating point behavior on Alpha and SH), `stdlib' (provides an unsetenv(3) declaration, among others), `putenv' (provides a putenv(3) declaration and implementation with the semantics we need). --- lib/Makefile.am | 193 ++++++++++++++- lib/config.charset | 46 +++- lib/flock.c | 222 +++++++++++++++++ lib/localcharset.c | 41 +++- lib/malloc.c | 57 +++++ lib/mbrtowc.c | 47 +++- lib/putenv.c | 132 +++++++++++ lib/stdint.in.h | 567 ++++++++++++++++++++++++++++++++++++++++++++ lib/stdlib.in.h | 383 ++++++++++++++++++++++++++++++ lib/strftime.c | 28 +-- lib/sys_file.in.h | 60 +++++ lib/unistd.in.h | 36 ++- lib/wchar.in.h | 26 +- m4/00gnulib.m4 | 30 +++ m4/alloca.m4 | 6 +- m4/codeset.m4 | 6 +- m4/extensions.m4 | 20 +- m4/flock.m4 | 26 ++ m4/fpieee.m4 | 52 ++++ m4/gnulib-cache.m4 | 6 +- m4/gnulib-common.m4 | 31 ++- m4/gnulib-comp.m4 | 28 +++ m4/include_next.m4 | 21 +- m4/inline.m4 | 6 +- m4/localcharset.m4 | 6 +- m4/locale-fr.m4 | 79 +++--- m4/locale-ja.m4 | 83 +++---- m4/locale-zh.m4 | 69 ++---- m4/longlong.m4 | 106 +++++++++ m4/malloc.m4 | 41 ++++ m4/mbrtowc.m4 | 85 +++++-- m4/mbstate_t.m4 | 10 +- m4/multiarch.m4 | 65 +++++ m4/putenv.m4 | 41 ++++ m4/stdbool.m4 | 4 +- m4/stdint.m4 | 472 ++++++++++++++++++++++++++++++++++++ m4/stdlib_h.m4 | 73 ++++++ m4/strcase.m4 | 10 +- m4/strftime.m4 | 8 +- m4/sys_file_h.m4 | 41 ++++ m4/tm_gmtoff.m4 | 6 +- m4/unistd_h.m4 | 6 +- m4/wchar.m4 | 51 ++-- m4/wint_t.m4 | 6 +- 44 files changed, 3048 insertions(+), 284 deletions(-) create mode 100644 lib/flock.c create mode 100644 lib/malloc.c create mode 100644 lib/putenv.c create mode 100644 lib/stdint.in.h create mode 100644 lib/stdlib.in.h create mode 100644 lib/sys_file.in.h create mode 100644 m4/00gnulib.m4 create mode 100644 m4/flock.m4 create mode 100644 m4/fpieee.m4 create mode 100644 m4/longlong.m4 create mode 100644 m4/malloc.m4 create mode 100644 m4/multiarch.m4 create mode 100644 m4/putenv.m4 create mode 100644 m4/stdint.m4 create mode 100644 m4/stdlib_h.m4 create mode 100644 m4/sys_file_h.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 309e94175..78693ea11 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions full-read full-write strcase strftime +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write putenv stdlib strcase strftime AUTOMAKE_OPTIONS = 1.5 gnits @@ -27,6 +27,7 @@ DISTCLEANFILES = MAINTAINERCLEANFILES = AM_CPPFLAGS = +AM_CFLAGS = noinst_LTLIBRARIES += libgnu.la @@ -73,7 +74,7 @@ EXTRA_DIST += alloca.in.h # The Automake-defined pkg* macros are appended, in the order # listed in the Automake 1.10a+ documentation. configmake.h: Makefile - rm -f $@-t $@ + rm -f $@-t { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ echo '#define PREFIX "$(prefix)"'; \ echo '#define EXEC_PREFIX "$(exec_prefix)"'; \ @@ -103,7 +104,12 @@ configmake.h: Makefile echo '#define PKGLIBDIR "$(pkglibdir)"'; \ echo '#define PKGLIBEXECDIR "$(pkglibexecdir)"'; \ } | sed '/""/d' > $@-t - mv $@-t $@ + if test -f $@ && cmp $@-t $@ > /dev/null; then \ + rm -f $@-t; \ + else \ + rm -f $@; mv $@-t $@; \ + fi + BUILT_SOURCES += configmake.h CLEANFILES += configmake.h configmake.h-t @@ -116,6 +122,15 @@ EXTRA_DIST += count-one-bits.h ## end gnulib module count-one-bits +## begin gnulib module flock + + +EXTRA_DIST += flock.c + +EXTRA_libgnu_la_SOURCES += flock.c + +## end gnulib module flock + ## begin gnulib module full-read libgnu_la_SOURCES += full-read.h full-read.c @@ -151,21 +166,37 @@ all-local: charset.alias ref-add.sed ref-del.sed charset_alias = $(DESTDIR)$(libdir)/charset.alias charset_tmp = $(DESTDIR)$(libdir)/charset.tmp -install-exec-local: all-local - test $(GLIBC21) != no || $(mkinstalldirs) $(DESTDIR)$(libdir) +install-exec-local: install-exec-localcharset +install-exec-localcharset: all-local + if test $(GLIBC21) = no; then \ + case '$(host_os)' in \ + darwin[56]*) \ + need_charset_alias=true ;; \ + darwin* | cygwin* | mingw* | pw32* | cegcc*) \ + need_charset_alias=false ;; \ + *) \ + need_charset_alias=true ;; \ + esac ; \ + else \ + need_charset_alias=false ; \ + fi ; \ + if $$need_charset_alias; then \ + $(mkinstalldirs) $(DESTDIR)$(libdir) ; \ + fi ; \ if test -f $(charset_alias); then \ sed -f ref-add.sed $(charset_alias) > $(charset_tmp) ; \ $(INSTALL_DATA) $(charset_tmp) $(charset_alias) ; \ rm -f $(charset_tmp) ; \ else \ - if test $(GLIBC21) = no; then \ + if $$need_charset_alias; then \ sed -f ref-add.sed charset.alias > $(charset_tmp) ; \ $(INSTALL_DATA) $(charset_tmp) $(charset_alias) ; \ rm -f $(charset_tmp) ; \ fi ; \ fi -uninstall-local: all-local +uninstall-local: uninstall-localcharset +uninstall-localcharset: all-local if test -f $(charset_alias); then \ sed -f ref-del.sed $(charset_alias) > $(charset_tmp); \ if grep '^# Packages using this file: $$' $(charset_tmp) \ @@ -194,6 +225,15 @@ EXTRA_DIST += config.charset ref-add.sin ref-del.sin ## end gnulib module localcharset +## begin gnulib module malloc-posix + + +EXTRA_DIST += malloc.c + +EXTRA_libgnu_la_SOURCES += malloc.c + +## end gnulib module malloc-posix + ## begin gnulib module mbrlen @@ -221,6 +261,15 @@ EXTRA_libgnu_la_SOURCES += mbsinit.c ## end gnulib module mbsinit +## begin gnulib module putenv + + +EXTRA_DIST += putenv.c + +EXTRA_libgnu_la_SOURCES += putenv.c + +## end gnulib module putenv + ## begin gnulib module safe-read @@ -257,6 +306,107 @@ EXTRA_DIST += stdbool.in.h ## end gnulib module stdbool +## begin gnulib module stdint + +BUILT_SOURCES += $(STDINT_H) + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +stdint.h: stdint.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + sed -e 's/@''HAVE_STDINT_H''@/$(HAVE_STDINT_H)/g' \ + -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_STDINT_H''@|$(NEXT_STDINT_H)|g' \ + -e 's/@''HAVE_SYS_TYPES_H''@/$(HAVE_SYS_TYPES_H)/g' \ + -e 's/@''HAVE_INTTYPES_H''@/$(HAVE_INTTYPES_H)/g' \ + -e 's/@''HAVE_SYS_INTTYPES_H''@/$(HAVE_SYS_INTTYPES_H)/g' \ + -e 's/@''HAVE_SYS_BITYPES_H''@/$(HAVE_SYS_BITYPES_H)/g' \ + -e 's/@''HAVE_LONG_LONG_INT''@/$(HAVE_LONG_LONG_INT)/g' \ + -e 's/@''HAVE_UNSIGNED_LONG_LONG_INT''@/$(HAVE_UNSIGNED_LONG_LONG_INT)/g' \ + -e 's/@''APPLE_UNIVERSAL_BUILD''@/$(APPLE_UNIVERSAL_BUILD)/g' \ + -e 's/@''BITSIZEOF_PTRDIFF_T''@/$(BITSIZEOF_PTRDIFF_T)/g' \ + -e 's/@''PTRDIFF_T_SUFFIX''@/$(PTRDIFF_T_SUFFIX)/g' \ + -e 's/@''BITSIZEOF_SIG_ATOMIC_T''@/$(BITSIZEOF_SIG_ATOMIC_T)/g' \ + -e 's/@''HAVE_SIGNED_SIG_ATOMIC_T''@/$(HAVE_SIGNED_SIG_ATOMIC_T)/g' \ + -e 's/@''SIG_ATOMIC_T_SUFFIX''@/$(SIG_ATOMIC_T_SUFFIX)/g' \ + -e 's/@''BITSIZEOF_SIZE_T''@/$(BITSIZEOF_SIZE_T)/g' \ + -e 's/@''SIZE_T_SUFFIX''@/$(SIZE_T_SUFFIX)/g' \ + -e 's/@''BITSIZEOF_WCHAR_T''@/$(BITSIZEOF_WCHAR_T)/g' \ + -e 's/@''HAVE_SIGNED_WCHAR_T''@/$(HAVE_SIGNED_WCHAR_T)/g' \ + -e 's/@''WCHAR_T_SUFFIX''@/$(WCHAR_T_SUFFIX)/g' \ + -e 's/@''BITSIZEOF_WINT_T''@/$(BITSIZEOF_WINT_T)/g' \ + -e 's/@''HAVE_SIGNED_WINT_T''@/$(HAVE_SIGNED_WINT_T)/g' \ + -e 's/@''WINT_T_SUFFIX''@/$(WINT_T_SUFFIX)/g' \ + < $(srcdir)/stdint.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += stdint.h stdint.h-t + +EXTRA_DIST += stdint.in.h + +## end gnulib module stdint + +## begin gnulib module stdlib + +BUILT_SOURCES += stdlib.h + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +stdlib.h: stdlib.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_STDLIB_H''@|$(NEXT_STDLIB_H)|g' \ + -e 's|@''HAVE_RANDOM_H''@|$(HAVE_RANDOM_H)|g' \ + -e 's|@''GNULIB_MALLOC_POSIX''@|$(GNULIB_MALLOC_POSIX)|g' \ + -e 's|@''GNULIB_REALLOC_POSIX''@|$(GNULIB_REALLOC_POSIX)|g' \ + -e 's|@''GNULIB_CALLOC_POSIX''@|$(GNULIB_CALLOC_POSIX)|g' \ + -e 's|@''GNULIB_ATOLL''@|$(GNULIB_ATOLL)|g' \ + -e 's|@''GNULIB_GETLOADAVG''@|$(GNULIB_GETLOADAVG)|g' \ + -e 's|@''GNULIB_GETSUBOPT''@|$(GNULIB_GETSUBOPT)|g' \ + -e 's|@''GNULIB_MKDTEMP''@|$(GNULIB_MKDTEMP)|g' \ + -e 's|@''GNULIB_MKSTEMP''@|$(GNULIB_MKSTEMP)|g' \ + -e 's|@''GNULIB_PUTENV''@|$(GNULIB_PUTENV)|g' \ + -e 's|@''GNULIB_RANDOM_R''@|$(GNULIB_RANDOM_R)|g' \ + -e 's|@''GNULIB_RPMATCH''@|$(GNULIB_RPMATCH)|g' \ + -e 's|@''GNULIB_SETENV''@|$(GNULIB_SETENV)|g' \ + -e 's|@''GNULIB_STRTOD''@|$(GNULIB_STRTOD)|g' \ + -e 's|@''GNULIB_STRTOLL''@|$(GNULIB_STRTOLL)|g' \ + -e 's|@''GNULIB_STRTOULL''@|$(GNULIB_STRTOULL)|g' \ + -e 's|@''GNULIB_UNSETENV''@|$(GNULIB_UNSETENV)|g' \ + -e 's|@''HAVE_ATOLL''@|$(HAVE_ATOLL)|g' \ + -e 's|@''HAVE_CALLOC_POSIX''@|$(HAVE_CALLOC_POSIX)|g' \ + -e 's|@''HAVE_GETSUBOPT''@|$(HAVE_GETSUBOPT)|g' \ + -e 's|@''HAVE_MALLOC_POSIX''@|$(HAVE_MALLOC_POSIX)|g' \ + -e 's|@''HAVE_MKDTEMP''@|$(HAVE_MKDTEMP)|g' \ + -e 's|@''HAVE_REALLOC_POSIX''@|$(HAVE_REALLOC_POSIX)|g' \ + -e 's|@''HAVE_RANDOM_R''@|$(HAVE_RANDOM_R)|g' \ + -e 's|@''HAVE_RPMATCH''@|$(HAVE_RPMATCH)|g' \ + -e 's|@''HAVE_SETENV''@|$(HAVE_SETENV)|g' \ + -e 's|@''HAVE_STRTOD''@|$(HAVE_STRTOD)|g' \ + -e 's|@''HAVE_STRTOLL''@|$(HAVE_STRTOLL)|g' \ + -e 's|@''HAVE_STRTOULL''@|$(HAVE_STRTOULL)|g' \ + -e 's|@''HAVE_STRUCT_RANDOM_DATA''@|$(HAVE_STRUCT_RANDOM_DATA)|g' \ + -e 's|@''HAVE_SYS_LOADAVG_H''@|$(HAVE_SYS_LOADAVG_H)|g' \ + -e 's|@''HAVE_UNSETENV''@|$(HAVE_UNSETENV)|g' \ + -e 's|@''HAVE_DECL_GETLOADAVG''@|$(HAVE_DECL_GETLOADAVG)|g' \ + -e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \ + -e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \ + -e 's|@''REPLACE_STRTOD''@|$(REPLACE_STRTOD)|g' \ + -e 's|@''VOID_UNSETENV''@|$(VOID_UNSETENV)|g' \ + -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \ + < $(srcdir)/stdlib.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += stdlib.h stdlib.h-t + +EXTRA_DIST += stdlib.in.h + +## end gnulib module stdlib + ## begin gnulib module strcase @@ -306,6 +456,32 @@ EXTRA_DIST += strings.in.h ## end gnulib module strings +## begin gnulib module sys_file + +BUILT_SOURCES += $(SYS_FILE_H) + +# We need the following in order to create when the system +# has one that is incomplete. +sys/file.h: sys_file.in.h + @MKDIR_P@ sys + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + sed -e 's/@''HAVE_SYS_FILE_H''@/$(HAVE_SYS_FILE_H)/g' \ + -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_SYS_FILE_H''@|$(NEXT_SYS_FILE_H)|g' \ + -e 's/@''HAVE_FLOCK''@/$(HAVE_FLOCK)/g' \ + -e 's/@''GNULIB_FLOCK''@/$(GNULIB_FLOCK)/g' \ + < $(srcdir)/sys_file.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += sys/file.h sys/file.h-t +MOSTLYCLEANDIRS += sys + +EXTRA_DIST += sys_file.in.h + +## end gnulib module sys_file + ## begin gnulib module time BUILT_SOURCES += time.h @@ -371,6 +547,7 @@ unistd.h: unistd.in.h -e 's|@''GNULIB_GETPAGESIZE''@|$(GNULIB_GETPAGESIZE)|g' \ -e 's|@''GNULIB_GETUSERSHELL''@|$(GNULIB_GETUSERSHELL)|g' \ -e 's|@''GNULIB_LCHOWN''@|$(GNULIB_LCHOWN)|g' \ + -e 's|@''GNULIB_LINK''@|$(GNULIB_LINK)|g' \ -e 's|@''GNULIB_LSEEK''@|$(GNULIB_LSEEK)|g' \ -e 's|@''GNULIB_READLINK''@|$(GNULIB_READLINK)|g' \ -e 's|@''GNULIB_SLEEP''@|$(GNULIB_SLEEP)|g' \ @@ -385,6 +562,7 @@ unistd.h: unistd.in.h -e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \ -e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \ -e 's|@''HAVE_GETUSERSHELL''@|$(HAVE_GETUSERSHELL)|g' \ + -e 's|@''HAVE_LINK''@|$(HAVE_LINK)|g' \ -e 's|@''HAVE_READLINK''@|$(HAVE_READLINK)|g' \ -e 's|@''HAVE_SLEEP''@|$(HAVE_SLEEP)|g' \ -e 's|@''HAVE_DECL_ENVIRON''@|$(HAVE_DECL_ENVIRON)|g' \ @@ -462,6 +640,7 @@ wchar.h: wchar.in.h -e 's|@''REPLACE_MBSNRTOWCS''@|$(REPLACE_MBSNRTOWCS)|g' \ -e 's|@''REPLACE_WCRTOMB''@|$(REPLACE_WCRTOMB)|g' \ -e 's|@''REPLACE_WCSRTOMBS''@|$(REPLACE_WCSRTOMBS)|g' \ + -e 's|@''REPLACE_WCSNRTOMBS''@|$(REPLACE_WCSNRTOMBS)|g' \ -e 's|@''REPLACE_WCWIDTH''@|$(REPLACE_WCWIDTH)|g' \ -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \ < $(srcdir)/wchar.in.h; \ diff --git a/lib/config.charset b/lib/config.charset index 50b4406b2..c1a7f5dbb 100755 --- a/lib/config.charset +++ b/lib/config.charset @@ -1,7 +1,7 @@ #! /bin/sh # Output a system dependent table of character encoding aliases. # -# Copyright (C) 2000-2004, 2006-2008 Free Software Foundation, Inc. +# Copyright (C) 2000-2004, 2006-2009 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by @@ -63,12 +63,13 @@ # CP922 aix # CP932 aix woe32 dos # CP943 aix -# CP949 osf woe32 dos +# CP949 osf darwin woe32 dos # CP950 woe32 dos # CP1046 aix # CP1124 aix # CP1125 dos # CP1129 aix +# CP1131 darwin # CP1250 woe32 # CP1251 glibc solaris netbsd openbsd darwin woe32 # CP1252 aix woe32 @@ -82,15 +83,17 @@ # EUC-KR Y glibc aix hpux irix osf solaris freebsd netbsd darwin # EUC-TW glibc aix hpux irix osf solaris netbsd # BIG5 Y glibc aix hpux osf solaris freebsd netbsd darwin -# BIG5-HKSCS glibc solaris -# GBK glibc aix osf solaris woe32 dos -# GB18030 glibc solaris netbsd +# BIG5-HKSCS glibc solaris darwin +# GBK glibc aix osf solaris darwin woe32 dos +# GB18030 glibc solaris netbsd darwin # SHIFT_JIS Y hpux osf solaris freebsd netbsd darwin # JOHAB glibc solaris woe32 # TIS-620 glibc aix hpux osf solaris # VISCII Y glibc # TCVN5712-1 glibc +# ARMSCII-8 glibc darwin # GEORGIAN-PS glibc +# PT154 glibc # HP-ROMAN8 hpux # HP-ARABIC8 hpux # HP-GREEK8 hpux @@ -449,7 +452,8 @@ case "$os" in echo "ko_KR.EUC EUC-KR" ;; darwin*) - # Darwin 7.5 has nl_langinfo(CODESET), but it is useless: + # Darwin 7.5 has nl_langinfo(CODESET), but sometimes its value is + # useless: # - It returns the empty string when LANG is set to a locale of the # form ll_CC, although ll_CC/LC_CTYPE is a symlink to an UTF-8 # LC_CTYPE file. @@ -476,6 +480,36 @@ case "$os" in # minimize the use of decomposed Unicode. Unfortunately, through the # Darwin file system, decomposed UTF-8 strings are leaked into user # space nevertheless. + # Then there are also the locales with encodings other than US-ASCII + # and UTF-8. These locales can be occasionally useful to users (e.g. + # when grepping through ISO-8859-1 encoded text files), when all their + # file names are in US-ASCII. + echo "ISO8859-1 ISO-8859-1" + echo "ISO8859-2 ISO-8859-2" + echo "ISO8859-4 ISO-8859-4" + echo "ISO8859-5 ISO-8859-5" + echo "ISO8859-7 ISO-8859-7" + echo "ISO8859-9 ISO-8859-9" + echo "ISO8859-13 ISO-8859-13" + echo "ISO8859-15 ISO-8859-15" + echo "KOI8-R KOI8-R" + echo "KOI8-U KOI8-U" + echo "CP866 CP866" + echo "CP949 CP949" + echo "CP1131 CP1131" + echo "CP1251 CP1251" + echo "eucCN GB2312" + echo "GB2312 GB2312" + echo "eucJP EUC-JP" + echo "eucKR EUC-KR" + echo "Big5 BIG5" + echo "Big5HKSCS BIG5-HKSCS" + echo "GBK GBK" + echo "GB18030 GB18030" + echo "SJIS SHIFT_JIS" + echo "ARMSCII-8 ARMSCII-8" + echo "PT154 PT154" + #echo "ISCII-DEV ?" echo "* UTF-8" ;; beos* | haiku*) diff --git a/lib/flock.c b/lib/flock.c new file mode 100644 index 000000000..2993432de --- /dev/null +++ b/lib/flock.c @@ -0,0 +1,222 @@ +/* Emulate flock on platforms that lack it, primarily Windows and MinGW. + + This is derived from sqlite3 sources. + http://www.sqlite.org/cvstrac/rlog?f=sqlite/src/os_win.c + http://www.sqlite.org/copyright.html + + Written by Richard W.M. Jones + + Copyright (C) 2008 Free Software Foundation, Inc. + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include +#include + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +/* _get_osfhandle */ +#include + +/* LockFileEx */ +#define WIN32_LEAN_AND_MEAN +#include + +#include + +/* Determine the current size of a file. Because the other braindead + * APIs we'll call need lower/upper 32 bit pairs, keep the file size + * like that too. + */ +static BOOL +file_size (HANDLE h, DWORD * lower, DWORD * upper) +{ + *lower = GetFileSize (h, upper); + return 1; +} + +/* LOCKFILE_FAIL_IMMEDIATELY is undefined on some Windows systems. */ +#ifndef LOCKFILE_FAIL_IMMEDIATELY +# define LOCKFILE_FAIL_IMMEDIATELY 1 +#endif + +/* Acquire a lock. */ +static BOOL +do_lock (HANDLE h, int non_blocking, int exclusive) +{ + BOOL res; + DWORD size_lower, size_upper; + OVERLAPPED ovlp; + int flags = 0; + + /* We're going to lock the whole file, so get the file size. */ + res = file_size (h, &size_lower, &size_upper); + if (!res) + return 0; + + /* Start offset is 0, and also zero the remaining members of this struct. */ + memset (&ovlp, 0, sizeof ovlp); + + if (non_blocking) + flags |= LOCKFILE_FAIL_IMMEDIATELY; + if (exclusive) + flags |= LOCKFILE_EXCLUSIVE_LOCK; + + return LockFileEx (h, flags, 0, size_lower, size_upper, &ovlp); +} + +/* Unlock reader or exclusive lock. */ +static BOOL +do_unlock (HANDLE h) +{ + int res; + DWORD size_lower, size_upper; + + res = file_size (h, &size_lower, &size_upper); + if (!res) + return 0; + + return UnlockFile (h, 0, 0, size_lower, size_upper); +} + +/* Now our BSD-like flock operation. */ +int +flock (int fd, int operation) +{ + HANDLE h = (HANDLE) _get_osfhandle (fd); + DWORD res; + int non_blocking; + + if (h == INVALID_HANDLE_VALUE) + { + errno = EBADF; + return -1; + } + + non_blocking = operation & LOCK_NB; + operation &= ~LOCK_NB; + + switch (operation) + { + case LOCK_SH: + res = do_lock (h, non_blocking, 0); + break; + case LOCK_EX: + res = do_lock (h, non_blocking, 1); + break; + case LOCK_UN: + res = do_unlock (h); + break; + default: + errno = EINVAL; + return -1; + } + + /* Map Windows errors into Unix errnos. As usual MSDN fails to + * document the permissible error codes. + */ + if (!res) + { + DWORD err = GetLastError (); + switch (err) + { + /* This means someone else is holding a lock. */ + case ERROR_LOCK_VIOLATION: + errno = EAGAIN; + break; + + /* Out of memory. */ + case ERROR_NOT_ENOUGH_MEMORY: + errno = ENOMEM; + break; + + case ERROR_BAD_COMMAND: + errno = EINVAL; + break; + + /* Unlikely to be other errors, but at least don't lose the + * error code. + */ + default: + errno = err; + } + + return -1; + } + + return 0; +} + +#else /* !Windows */ + +#ifdef HAVE_STRUCT_FLOCK_L_TYPE +/* We know how to implement flock in terms of fcntl. */ + +#ifdef HAVE_FCNTL_H +#include +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +#include +#include + +int +flock (int fd, int operation) +{ + int cmd, r; + struct flock fl; + + if (operation & LOCK_NB) + cmd = F_SETLK; + else + cmd = F_SETLKW; + operation &= ~LOCK_NB; + + memset (&fl, 0, sizeof fl); + fl.l_whence = SEEK_SET; + /* l_start & l_len are 0, which as a special case means "whole file". */ + + switch (operation) + { + case LOCK_SH: + fl.l_type = F_RDLCK; + break; + case LOCK_EX: + fl.l_type = F_WRLCK; + break; + case LOCK_UN: + fl.l_type = F_UNLCK; + break; + default: + errno = EINVAL; + return -1; + } + + r = fcntl (fd, cmd, &fl); + if (r == -1 && errno == EACCES) + errno = EAGAIN; + + return r; +} + +#else /* !HAVE_STRUCT_FLOCK_L_TYPE */ + +#error "This platform lacks flock function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib." + +#endif /* !HAVE_STRUCT_FLOCK_L_TYPE */ + +#endif /* !Windows */ diff --git a/lib/localcharset.c b/lib/localcharset.c index c3e393735..93da17077 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -1,6 +1,6 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2006, 2008 Free Software Foundation, Inc. + Copyright (C) 2000-2006, 2008-2009 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -28,6 +28,10 @@ #include #include +#if defined __APPLE__ && defined __MACH__ && HAVE_LANGINFO_CODESET +# define DARWIN7 /* Darwin 7 or newer, i.e. MacOS X 10.3 or newer */ +#endif + #if defined _WIN32 || defined __WIN32__ # define WIN32_NATIVE #endif @@ -112,7 +116,7 @@ get_charset_aliases (void) cp = charset_aliases; if (cp == NULL) { -#if !(defined VMS || defined WIN32_NATIVE || defined __CYGWIN__) +#if !(defined DARWIN7 || defined VMS || defined WIN32_NATIVE || defined __CYGWIN__) FILE *fp; const char *dir; const char *base = "charset.alias"; @@ -213,6 +217,39 @@ get_charset_aliases (void) #else +# if defined DARWIN7 + /* To avoid the trouble of installing a file that is shared by many + GNU packages -- many packaging systems have problems with this --, + simply inline the aliases here. */ + cp = "ISO8859-1" "\0" "ISO-8859-1" "\0" + "ISO8859-2" "\0" "ISO-8859-2" "\0" + "ISO8859-4" "\0" "ISO-8859-4" "\0" + "ISO8859-5" "\0" "ISO-8859-5" "\0" + "ISO8859-7" "\0" "ISO-8859-7" "\0" + "ISO8859-9" "\0" "ISO-8859-9" "\0" + "ISO8859-13" "\0" "ISO-8859-13" "\0" + "ISO8859-15" "\0" "ISO-8859-15" "\0" + "KOI8-R" "\0" "KOI8-R" "\0" + "KOI8-U" "\0" "KOI8-U" "\0" + "CP866" "\0" "CP866" "\0" + "CP949" "\0" "CP949" "\0" + "CP1131" "\0" "CP1131" "\0" + "CP1251" "\0" "CP1251" "\0" + "eucCN" "\0" "GB2312" "\0" + "GB2312" "\0" "GB2312" "\0" + "eucJP" "\0" "EUC-JP" "\0" + "eucKR" "\0" "EUC-KR" "\0" + "Big5" "\0" "BIG5" "\0" + "Big5HKSCS" "\0" "BIG5-HKSCS" "\0" + "GBK" "\0" "GBK" "\0" + "GB18030" "\0" "GB18030" "\0" + "SJIS" "\0" "SHIFT_JIS" "\0" + "ARMSCII-8" "\0" "ARMSCII-8" "\0" + "PT154" "\0" "PT154" "\0" + /*"ISCII-DEV" "\0" "?" "\0"*/ + "*" "\0" "UTF-8" "\0"; +# endif + # if defined VMS /* To avoid the troubles of an extra file charset.alias_vms in the sources of many GNU packages, simply inline the aliases here. */ diff --git a/lib/malloc.c b/lib/malloc.c new file mode 100644 index 000000000..9111c7a1e --- /dev/null +++ b/lib/malloc.c @@ -0,0 +1,57 @@ +/* malloc() function that is glibc compatible. + + Copyright (C) 1997, 1998, 2006, 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +/* written by Jim Meyering and Bruno Haible */ + +#include +/* Only the AC_FUNC_MALLOC macro defines 'malloc' already in config.h. */ +#ifdef malloc +# define NEED_MALLOC_GNU +# undef malloc +#endif + +/* Specification. */ +#include + +#include + +/* Call the system's malloc below. */ +#undef malloc + +/* Allocate an N-byte block of memory from the heap. + If N is zero, allocate a 1-byte block. */ + +void * +rpl_malloc (size_t n) +{ + void *result; + +#ifdef NEED_MALLOC_GNU + if (n == 0) + n = 1; +#endif + + result = malloc (n); + +#if !HAVE_MALLOC_POSIX + if (result == NULL) + errno = ENOMEM; +#endif + + return result; +} diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c index 17b3de53b..7b528e807 100644 --- a/lib/mbrtowc.c +++ b/lib/mbrtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 1999-2002, 2005-2008 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2005-2009 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify @@ -89,7 +89,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) return (size_t)(-1); } - /* Here 0 < m ≤ 4. */ + /* Here m > 0. */ # if __GLIBC__ /* Work around bug */ @@ -118,7 +118,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) lack mbrtowc(), we use the second approach. The possible encodings are: - 8-bit encodings, - - EUC-JP, EUC-KR, GB2312, EUC-TW, BIG5, SJIS, + - EUC-JP, EUC-KR, GB2312, EUC-TW, BIG5, GB18030, SJIS, - UTF-8. Use specialized code for each. */ if (m >= 4 || m >= MB_CUR_MAX) @@ -238,6 +238,39 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) } goto invalid; } + if (STREQ (encoding, "GB18030", 'G', 'B', '1', '8', '0', '3', '0', 0, 0)) + { + if (m == 1) + { + unsigned char c = (unsigned char) p[0]; + + if ((c >= 0x90 && c <= 0xe3) || (c >= 0xf8 && c <= 0xfe)) + goto incomplete; + } + else /* m == 2 || m == 3 */ + { + unsigned char c = (unsigned char) p[0]; + + if (c >= 0x90 && c <= 0xe3) + { + unsigned char c2 = (unsigned char) p[1]; + + if (c2 >= 0x30 && c2 <= 0x39) + { + if (m == 2) + goto incomplete; + else /* m == 3 */ + { + unsigned char c3 = (unsigned char) p[2]; + + if (c3 >= 0x81 && c3 <= 0xfe) + goto incomplete; + } + } + } + } + goto invalid; + } if (STREQ (encoding, "SJIS", 'S', 'J', 'I', 'S', 0, 0, 0, 0, 0)) { if (m == 1) @@ -258,10 +291,14 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) incomplete: { size_t k = nstate; - /* Here 0 < k < m < 4. */ + /* Here 0 <= k < m < 4. */ pstate[++k] = s[0]; if (k < m) - pstate[++k] = s[1]; + { + pstate[++k] = s[1]; + if (k < m) + pstate[++k] = s[2]; + } if (k != m) abort (); } diff --git a/lib/putenv.c b/lib/putenv.c new file mode 100644 index 000000000..53cc83912 --- /dev/null +++ b/lib/putenv.c @@ -0,0 +1,132 @@ +/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2008 + Free Software Foundation, Inc. + + NOTE: The canonical source of this file is maintained with the GNU C + Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published by the + Free Software Foundation; either version 3 of the License, or any + later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include + +#include + +/* Include errno.h *after* sys/types.h to work around header problems + on AIX 3.2.5. */ +#include +#ifndef __set_errno +# define __set_errno(ev) ((errno) = (ev)) +#endif + +#include +#include + +#if HAVE_GNU_LD +# define environ __environ +#else +extern char **environ; +#endif + +#if _LIBC +/* This lock protects against simultaneous modifications of `environ'. */ +# include +__libc_lock_define_initialized (static, envlock) +# define LOCK __libc_lock_lock (envlock) +# define UNLOCK __libc_lock_unlock (envlock) +#else +# define LOCK +# define UNLOCK +#endif + +static int +_unsetenv (const char *name) +{ + size_t len; + char **ep; + + if (name == NULL || *name == '\0' || strchr (name, '=') != NULL) + { + __set_errno (EINVAL); + return -1; + } + + len = strlen (name); + + LOCK; + + ep = environ; + while (*ep != NULL) + if (!strncmp (*ep, name, len) && (*ep)[len] == '=') + { + /* Found it. Remove this pointer by moving later ones back. */ + char **dp = ep; + + do + dp[0] = dp[1]; + while (*dp++); + /* Continue the loop in case NAME appears again. */ + } + else + ++ep; + + UNLOCK; + + return 0; +} + + +/* Put STRING, which is of the form "NAME=VALUE", in the environment. + If STRING contains no `=', then remove STRING from the environment. */ +int +putenv (char *string) +{ + const char *const name_end = strchr (string, '='); + register size_t size; + register char **ep; + + if (name_end == NULL) + { + /* Remove the variable from the environment. */ + return _unsetenv (string); + } + + size = 0; + for (ep = environ; *ep != NULL; ++ep) + if (!strncmp (*ep, string, name_end - string) && + (*ep)[name_end - string] == '=') + break; + else + ++size; + + if (*ep == NULL) + { + static char **last_environ = NULL; + char **new_environ = (char **) malloc ((size + 2) * sizeof (char *)); + if (new_environ == NULL) + return -1; + (void) memcpy ((void *) new_environ, (void *) environ, + size * sizeof (char *)); + new_environ[size] = (char *) string; + new_environ[size + 1] = NULL; + free (last_environ); + last_environ = new_environ; + environ = new_environ; + } + else + *ep = string; + + return 0; +} diff --git a/lib/stdint.in.h b/lib/stdint.in.h new file mode 100644 index 000000000..11a211763 --- /dev/null +++ b/lib/stdint.in.h @@ -0,0 +1,567 @@ +/* Copyright (C) 2001-2002, 2004-2009 Free Software Foundation, Inc. + Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood. + This file is part of gnulib. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +/* + * ISO C 99 for platforms that lack it. + * + */ + +#ifndef _GL_STDINT_H + +/* When including a system file that in turn includes , + use the system , not our substitute. This avoids + problems with (for example) VMS, whose includes + . */ +#define _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H + +/* Get those types that are already defined in other system include + files, so that we can "#define int8_t signed char" below without + worrying about a later system include file containing a "typedef + signed char int8_t;" that will get messed up by our macro. Our + macros should all be consistent with the system versions, except + for the "fast" types and macros, which we recommend against using + in public interfaces due to compiler differences. */ + +#if @HAVE_STDINT_H@ +# if defined __sgi && ! defined __c99 + /* Bypass IRIX's if in C89 mode, since it merely annoys users + with "This header file is to be used only for c99 mode compilations" + diagnostics. */ +# define __STDINT_H__ +# endif + /* Other systems may have an incomplete or buggy . + Include it before , since any "#include " + in would reinclude us, skipping our contents because + _GL_STDINT_H is defined. + The include_next requires a split double-inclusion guard. */ +# if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +# endif +# @INCLUDE_NEXT@ @NEXT_STDINT_H@ +#endif + +#if ! defined _GL_STDINT_H && ! defined _GL_JUST_INCLUDE_SYSTEM_STDINT_H +#define _GL_STDINT_H + +/* defines some of the stdint.h types as well, on glibc, + IRIX 6.5, and OpenBSD 3.8 (via ). + AIX 5.2 isn't needed and causes troubles. + MacOS X 10.4.6 includes (which is us), but + relies on the system definitions, so include + after @NEXT_STDINT_H@. */ +#if @HAVE_SYS_TYPES_H@ && ! defined _AIX +# include +#endif + +/* Get LONG_MIN, LONG_MAX, ULONG_MAX. */ +#include + +#if @HAVE_INTTYPES_H@ + /* In OpenBSD 3.8, includes , which defines + int{8,16,32,64}_t, uint{8,16,32,64}_t and __BIT_TYPES_DEFINED__. + also defines intptr_t and uintptr_t. */ +# include +#elif @HAVE_SYS_INTTYPES_H@ + /* Solaris 7 has the types except the *_fast*_t types, and + the macros except for *_FAST*_*, INTPTR_MIN, PTRDIFF_MIN, PTRDIFF_MAX. */ +# include +#endif + +#if @HAVE_SYS_BITYPES_H@ && ! defined __BIT_TYPES_DEFINED__ + /* Linux libc4 >= 4.6.7 and libc5 have a that defines + int{8,16,32,64}_t and __BIT_TYPES_DEFINED__. In libc5 >= 5.2.2 it is + included by . */ +# include +#endif + +#undef _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H + +/* Minimum and maximum values for a integer type under the usual assumption. + Return an unspecified value if BITS == 0, adding a check to pacify + picky compilers. */ + +#define _STDINT_MIN(signed, bits, zero) \ + ((signed) ? (- ((zero) + 1) << ((bits) ? (bits) - 1 : 0)) : (zero)) + +#define _STDINT_MAX(signed, bits, zero) \ + ((signed) \ + ? ~ _STDINT_MIN (signed, bits, zero) \ + : /* The expression for the unsigned case. The subtraction of (signed) \ + is a nop in the unsigned case and avoids "signed integer overflow" \ + warnings in the signed case. */ \ + ((((zero) + 1) << ((bits) ? (bits) - 1 - (signed) : 0)) - 1) * 2 + 1) + +/* 7.18.1.1. Exact-width integer types */ + +/* Here we assume a standard architecture where the hardware integer + types have 8, 16, 32, optionally 64 bits. */ + +#undef int8_t +#undef uint8_t +typedef signed char gl_int8_t; +typedef unsigned char gl_uint8_t; +#define int8_t gl_int8_t +#define uint8_t gl_uint8_t + +#undef int16_t +#undef uint16_t +typedef short int gl_int16_t; +typedef unsigned short int gl_uint16_t; +#define int16_t gl_int16_t +#define uint16_t gl_uint16_t + +#undef int32_t +#undef uint32_t +typedef int gl_int32_t; +typedef unsigned int gl_uint32_t; +#define int32_t gl_int32_t +#define uint32_t gl_uint32_t + +/* Do not undefine int64_t if gnulib is not being used with 64-bit + types, since otherwise it breaks platforms like Tandem/NSK. */ +#if LONG_MAX >> 31 >> 31 == 1 +# undef int64_t +typedef long int gl_int64_t; +# define int64_t gl_int64_t +# define GL_INT64_T +#elif defined _MSC_VER +# undef int64_t +typedef __int64 gl_int64_t; +# define int64_t gl_int64_t +# define GL_INT64_T +#elif @HAVE_LONG_LONG_INT@ +# undef int64_t +typedef long long int gl_int64_t; +# define int64_t gl_int64_t +# define GL_INT64_T +#endif + +#if ULONG_MAX >> 31 >> 31 >> 1 == 1 +# undef uint64_t +typedef unsigned long int gl_uint64_t; +# define uint64_t gl_uint64_t +# define GL_UINT64_T +#elif defined _MSC_VER +# undef uint64_t +typedef unsigned __int64 gl_uint64_t; +# define uint64_t gl_uint64_t +# define GL_UINT64_T +#elif @HAVE_UNSIGNED_LONG_LONG_INT@ +# undef uint64_t +typedef unsigned long long int gl_uint64_t; +# define uint64_t gl_uint64_t +# define GL_UINT64_T +#endif + +/* Avoid collision with Solaris 2.5.1 etc. */ +#define _UINT8_T +#define _UINT32_T +#define _UINT64_T + + +/* 7.18.1.2. Minimum-width integer types */ + +/* Here we assume a standard architecture where the hardware integer + types have 8, 16, 32, optionally 64 bits. Therefore the leastN_t types + are the same as the corresponding N_t types. */ + +#undef int_least8_t +#undef uint_least8_t +#undef int_least16_t +#undef uint_least16_t +#undef int_least32_t +#undef uint_least32_t +#undef int_least64_t +#undef uint_least64_t +#define int_least8_t int8_t +#define uint_least8_t uint8_t +#define int_least16_t int16_t +#define uint_least16_t uint16_t +#define int_least32_t int32_t +#define uint_least32_t uint32_t +#ifdef GL_INT64_T +# define int_least64_t int64_t +#endif +#ifdef GL_UINT64_T +# define uint_least64_t uint64_t +#endif + +/* 7.18.1.3. Fastest minimum-width integer types */ + +/* Note: Other substitutes may define these types differently. + It is not recommended to use these types in public header files. */ + +/* Here we assume a standard architecture where the hardware integer + types have 8, 16, 32, optionally 64 bits. Therefore the fastN_t types + are taken from the same list of types. Assume that 'long int' + is fast enough for all narrower integers. */ + +#undef int_fast8_t +#undef uint_fast8_t +#undef int_fast16_t +#undef uint_fast16_t +#undef int_fast32_t +#undef uint_fast32_t +#undef int_fast64_t +#undef uint_fast64_t +typedef long int gl_int_fast8_t; +typedef unsigned long int gl_uint_fast8_t; +typedef long int gl_int_fast16_t; +typedef unsigned long int gl_uint_fast16_t; +typedef long int gl_int_fast32_t; +typedef unsigned long int gl_uint_fast32_t; +#define int_fast8_t gl_int_fast8_t +#define uint_fast8_t gl_uint_fast8_t +#define int_fast16_t gl_int_fast16_t +#define uint_fast16_t gl_uint_fast16_t +#define int_fast32_t gl_int_fast32_t +#define uint_fast32_t gl_uint_fast32_t +#ifdef GL_INT64_T +# define int_fast64_t int64_t +#endif +#ifdef GL_UINT64_T +# define uint_fast64_t uint64_t +#endif + +/* 7.18.1.4. Integer types capable of holding object pointers */ + +#undef intptr_t +#undef uintptr_t +typedef long int gl_intptr_t; +typedef unsigned long int gl_uintptr_t; +#define intptr_t gl_intptr_t +#define uintptr_t gl_uintptr_t + +/* 7.18.1.5. Greatest-width integer types */ + +/* Note: These types are compiler dependent. It may be unwise to use them in + public header files. */ + +#undef intmax_t +#if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +typedef long long int gl_intmax_t; +# define intmax_t gl_intmax_t +#elif defined GL_INT64_T +# define intmax_t int64_t +#else +typedef long int gl_intmax_t; +# define intmax_t gl_intmax_t +#endif + +#undef uintmax_t +#if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +typedef unsigned long long int gl_uintmax_t; +# define uintmax_t gl_uintmax_t +#elif defined GL_UINT64_T +# define uintmax_t uint64_t +#else +typedef unsigned long int gl_uintmax_t; +# define uintmax_t gl_uintmax_t +#endif + +/* Verify that intmax_t and uintmax_t have the same size. Too much code + breaks if this is not the case. If this check fails, the reason is likely + to be found in the autoconf macros. */ +typedef int _verify_intmax_size[2 * (sizeof (intmax_t) == sizeof (uintmax_t)) - 1]; + +/* 7.18.2. Limits of specified-width integer types */ + +#if ! defined __cplusplus || defined __STDC_LIMIT_MACROS + +/* 7.18.2.1. Limits of exact-width integer types */ + +/* Here we assume a standard architecture where the hardware integer + types have 8, 16, 32, optionally 64 bits. */ + +#undef INT8_MIN +#undef INT8_MAX +#undef UINT8_MAX +#define INT8_MIN (~ INT8_MAX) +#define INT8_MAX 127 +#define UINT8_MAX 255 + +#undef INT16_MIN +#undef INT16_MAX +#undef UINT16_MAX +#define INT16_MIN (~ INT16_MAX) +#define INT16_MAX 32767 +#define UINT16_MAX 65535 + +#undef INT32_MIN +#undef INT32_MAX +#undef UINT32_MAX +#define INT32_MIN (~ INT32_MAX) +#define INT32_MAX 2147483647 +#define UINT32_MAX 4294967295U + +#undef INT64_MIN +#undef INT64_MAX +#ifdef GL_INT64_T +/* Prefer (- INTMAX_C (1) << 63) over (~ INT64_MAX) because SunPRO C 5.0 + evaluates the latter incorrectly in preprocessor expressions. */ +# define INT64_MIN (- INTMAX_C (1) << 63) +# define INT64_MAX INTMAX_C (9223372036854775807) +#endif + +#undef UINT64_MAX +#ifdef GL_UINT64_T +# define UINT64_MAX UINTMAX_C (18446744073709551615) +#endif + +/* 7.18.2.2. Limits of minimum-width integer types */ + +/* Here we assume a standard architecture where the hardware integer + types have 8, 16, 32, optionally 64 bits. Therefore the leastN_t types + are the same as the corresponding N_t types. */ + +#undef INT_LEAST8_MIN +#undef INT_LEAST8_MAX +#undef UINT_LEAST8_MAX +#define INT_LEAST8_MIN INT8_MIN +#define INT_LEAST8_MAX INT8_MAX +#define UINT_LEAST8_MAX UINT8_MAX + +#undef INT_LEAST16_MIN +#undef INT_LEAST16_MAX +#undef UINT_LEAST16_MAX +#define INT_LEAST16_MIN INT16_MIN +#define INT_LEAST16_MAX INT16_MAX +#define UINT_LEAST16_MAX UINT16_MAX + +#undef INT_LEAST32_MIN +#undef INT_LEAST32_MAX +#undef UINT_LEAST32_MAX +#define INT_LEAST32_MIN INT32_MIN +#define INT_LEAST32_MAX INT32_MAX +#define UINT_LEAST32_MAX UINT32_MAX + +#undef INT_LEAST64_MIN +#undef INT_LEAST64_MAX +#ifdef GL_INT64_T +# define INT_LEAST64_MIN INT64_MIN +# define INT_LEAST64_MAX INT64_MAX +#endif + +#undef UINT_LEAST64_MAX +#ifdef GL_UINT64_T +# define UINT_LEAST64_MAX UINT64_MAX +#endif + +/* 7.18.2.3. Limits of fastest minimum-width integer types */ + +/* Here we assume a standard architecture where the hardware integer + types have 8, 16, 32, optionally 64 bits. Therefore the fastN_t types + are taken from the same list of types. */ + +#undef INT_FAST8_MIN +#undef INT_FAST8_MAX +#undef UINT_FAST8_MAX +#define INT_FAST8_MIN LONG_MIN +#define INT_FAST8_MAX LONG_MAX +#define UINT_FAST8_MAX ULONG_MAX + +#undef INT_FAST16_MIN +#undef INT_FAST16_MAX +#undef UINT_FAST16_MAX +#define INT_FAST16_MIN LONG_MIN +#define INT_FAST16_MAX LONG_MAX +#define UINT_FAST16_MAX ULONG_MAX + +#undef INT_FAST32_MIN +#undef INT_FAST32_MAX +#undef UINT_FAST32_MAX +#define INT_FAST32_MIN LONG_MIN +#define INT_FAST32_MAX LONG_MAX +#define UINT_FAST32_MAX ULONG_MAX + +#undef INT_FAST64_MIN +#undef INT_FAST64_MAX +#ifdef GL_INT64_T +# define INT_FAST64_MIN INT64_MIN +# define INT_FAST64_MAX INT64_MAX +#endif + +#undef UINT_FAST64_MAX +#ifdef GL_UINT64_T +# define UINT_FAST64_MAX UINT64_MAX +#endif + +/* 7.18.2.4. Limits of integer types capable of holding object pointers */ + +#undef INTPTR_MIN +#undef INTPTR_MAX +#undef UINTPTR_MAX +#define INTPTR_MIN LONG_MIN +#define INTPTR_MAX LONG_MAX +#define UINTPTR_MAX ULONG_MAX + +/* 7.18.2.5. Limits of greatest-width integer types */ + +#undef INTMAX_MIN +#undef INTMAX_MAX +#ifdef INT64_MAX +# define INTMAX_MIN INT64_MIN +# define INTMAX_MAX INT64_MAX +#else +# define INTMAX_MIN INT32_MIN +# define INTMAX_MAX INT32_MAX +#endif + +#undef UINTMAX_MAX +#ifdef UINT64_MAX +# define UINTMAX_MAX UINT64_MAX +#else +# define UINTMAX_MAX UINT32_MAX +#endif + +/* 7.18.3. Limits of other integer types */ + +/* ptrdiff_t limits */ +#undef PTRDIFF_MIN +#undef PTRDIFF_MAX +#if @APPLE_UNIVERSAL_BUILD@ +# ifdef _LP64 +# define PTRDIFF_MIN _STDINT_MIN (1, 64, 0l) +# define PTRDIFF_MAX _STDINT_MAX (1, 64, 0l) +# else +# define PTRDIFF_MIN _STDINT_MIN (1, 32, 0) +# define PTRDIFF_MAX _STDINT_MAX (1, 32, 0) +# endif +#else +# define PTRDIFF_MIN \ + _STDINT_MIN (1, @BITSIZEOF_PTRDIFF_T@, 0@PTRDIFF_T_SUFFIX@) +# define PTRDIFF_MAX \ + _STDINT_MAX (1, @BITSIZEOF_PTRDIFF_T@, 0@PTRDIFF_T_SUFFIX@) +#endif + +/* sig_atomic_t limits */ +#undef SIG_ATOMIC_MIN +#undef SIG_ATOMIC_MAX +#define SIG_ATOMIC_MIN \ + _STDINT_MIN (@HAVE_SIGNED_SIG_ATOMIC_T@, @BITSIZEOF_SIG_ATOMIC_T@, \ + 0@SIG_ATOMIC_T_SUFFIX@) +#define SIG_ATOMIC_MAX \ + _STDINT_MAX (@HAVE_SIGNED_SIG_ATOMIC_T@, @BITSIZEOF_SIG_ATOMIC_T@, \ + 0@SIG_ATOMIC_T_SUFFIX@) + + +/* size_t limit */ +#undef SIZE_MAX +#if @APPLE_UNIVERSAL_BUILD@ +# ifdef _LP64 +# define SIZE_MAX _STDINT_MAX (0, 64, 0ul) +# else +# define SIZE_MAX _STDINT_MAX (0, 32, 0ul) +# endif +#else +# define SIZE_MAX _STDINT_MAX (0, @BITSIZEOF_SIZE_T@, 0@SIZE_T_SUFFIX@) +#endif + +/* wchar_t limits */ +/* Get WCHAR_MIN, WCHAR_MAX. + This include is not on the top, above, because on OSF/1 4.0 we have a sequence of nested + includes -> -> -> , and the latter includes + and assumes its types are already defined. */ +#if ! (defined WCHAR_MIN && defined WCHAR_MAX) +# define _GL_JUST_INCLUDE_SYSTEM_WCHAR_H +# include +# undef _GL_JUST_INCLUDE_SYSTEM_WCHAR_H +#endif +#undef WCHAR_MIN +#undef WCHAR_MAX +#define WCHAR_MIN \ + _STDINT_MIN (@HAVE_SIGNED_WCHAR_T@, @BITSIZEOF_WCHAR_T@, 0@WCHAR_T_SUFFIX@) +#define WCHAR_MAX \ + _STDINT_MAX (@HAVE_SIGNED_WCHAR_T@, @BITSIZEOF_WCHAR_T@, 0@WCHAR_T_SUFFIX@) + +/* wint_t limits */ +#undef WINT_MIN +#undef WINT_MAX +#define WINT_MIN \ + _STDINT_MIN (@HAVE_SIGNED_WINT_T@, @BITSIZEOF_WINT_T@, 0@WINT_T_SUFFIX@) +#define WINT_MAX \ + _STDINT_MAX (@HAVE_SIGNED_WINT_T@, @BITSIZEOF_WINT_T@, 0@WINT_T_SUFFIX@) + +#endif /* !defined __cplusplus || defined __STDC_LIMIT_MACROS */ + +/* 7.18.4. Macros for integer constants */ + +#if ! defined __cplusplus || defined __STDC_CONSTANT_MACROS + +/* 7.18.4.1. Macros for minimum-width integer constants */ +/* According to ISO C 99 Technical Corrigendum 1 */ + +/* Here we assume a standard architecture where the hardware integer + types have 8, 16, 32, optionally 64 bits, and int is 32 bits. */ + +#undef INT8_C +#undef UINT8_C +#define INT8_C(x) x +#define UINT8_C(x) x + +#undef INT16_C +#undef UINT16_C +#define INT16_C(x) x +#define UINT16_C(x) x + +#undef INT32_C +#undef UINT32_C +#define INT32_C(x) x +#define UINT32_C(x) x ## U + +#undef INT64_C +#undef UINT64_C +#if LONG_MAX >> 31 >> 31 == 1 +# define INT64_C(x) x##L +#elif defined _MSC_VER +# define INT64_C(x) x##i64 +#elif @HAVE_LONG_LONG_INT@ +# define INT64_C(x) x##LL +#endif +#if ULONG_MAX >> 31 >> 31 >> 1 == 1 +# define UINT64_C(x) x##UL +#elif defined _MSC_VER +# define UINT64_C(x) x##ui64 +#elif @HAVE_UNSIGNED_LONG_LONG_INT@ +# define UINT64_C(x) x##ULL +#endif + +/* 7.18.4.2. Macros for greatest-width integer constants */ + +#undef INTMAX_C +#if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +# define INTMAX_C(x) x##LL +#elif defined GL_INT64_T +# define INTMAX_C(x) INT64_C(x) +#else +# define INTMAX_C(x) x##L +#endif + +#undef UINTMAX_C +#if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +# define UINTMAX_C(x) x##ULL +#elif defined GL_UINT64_T +# define UINTMAX_C(x) UINT64_C(x) +#else +# define UINTMAX_C(x) x##UL +#endif + +#endif /* !defined __cplusplus || defined __STDC_CONSTANT_MACROS */ + +#endif /* _GL_STDINT_H */ +#endif /* !defined _GL_STDINT_H && !defined _GL_JUST_INCLUDE_SYSTEM_STDINT_H */ diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h new file mode 100644 index 000000000..23325b563 --- /dev/null +++ b/lib/stdlib.in.h @@ -0,0 +1,383 @@ +/* A GNU-like . + + Copyright (C) 1995, 2001-2004, 2006-2009 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +#if defined __need_malloc_and_calloc +/* Special invocation convention inside glibc header files. */ + +#@INCLUDE_NEXT@ @NEXT_STDLIB_H@ + +#else +/* Normal invocation convention. */ + +#ifndef _GL_STDLIB_H + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_STDLIB_H@ + +#ifndef _GL_STDLIB_H +#define _GL_STDLIB_H + + +/* Solaris declares getloadavg() in . */ +#if @GNULIB_GETLOADAVG@ && @HAVE_SYS_LOADAVG_H@ +# include +#endif + +/* OSF/1 5.1 declares 'struct random_data' in , which is included + from if _REENTRANT is defined. Include it always. */ +#if @HAVE_RANDOM_H@ +# include +#endif + +#if @GNULIB_RANDOM_R@ || !@HAVE_STRUCT_RANDOM_DATA@ +# include +#endif + +#if !@HAVE_STRUCT_RANDOM_DATA@ +struct random_data +{ + int32_t *fptr; /* Front pointer. */ + int32_t *rptr; /* Rear pointer. */ + int32_t *state; /* Array of state values. */ + int rand_type; /* Type of random number generator. */ + int rand_deg; /* Degree of random number generator. */ + int rand_sep; /* Distance between front and rear. */ + int32_t *end_ptr; /* Pointer behind state table. */ +}; +#endif + +/* The definition of GL_LINK_WARNING is copied here. */ + + +/* Some systems do not define EXIT_*, despite otherwise supporting C89. */ +#ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 +#endif +/* Tandem/NSK and other platforms that define EXIT_FAILURE as -1 interfere + with proper operation of xargs. */ +#ifndef EXIT_FAILURE +# define EXIT_FAILURE 1 +#elif EXIT_FAILURE != 1 +# undef EXIT_FAILURE +# define EXIT_FAILURE 1 +#endif + + +#ifdef __cplusplus +extern "C" { +#endif + + +#if @GNULIB_MALLOC_POSIX@ +# if !@HAVE_MALLOC_POSIX@ +# undef malloc +# define malloc rpl_malloc +extern void * malloc (size_t size); +# endif +#elif defined GNULIB_POSIXCHECK +# undef malloc +# define malloc(s) \ + (GL_LINK_WARNING ("malloc is not POSIX compliant everywhere - " \ + "use gnulib module malloc-posix for portability"), \ + malloc (s)) +#endif + + +#if @GNULIB_REALLOC_POSIX@ +# if !@HAVE_REALLOC_POSIX@ +# undef realloc +# define realloc rpl_realloc +extern void * realloc (void *ptr, size_t size); +# endif +#elif defined GNULIB_POSIXCHECK +# undef realloc +# define realloc(p,s) \ + (GL_LINK_WARNING ("realloc is not POSIX compliant everywhere - " \ + "use gnulib module realloc-posix for portability"), \ + realloc (p, s)) +#endif + + +#if @GNULIB_CALLOC_POSIX@ +# if !@HAVE_CALLOC_POSIX@ +# undef calloc +# define calloc rpl_calloc +extern void * calloc (size_t nmemb, size_t size); +# endif +#elif defined GNULIB_POSIXCHECK +# undef calloc +# define calloc(n,s) \ + (GL_LINK_WARNING ("calloc is not POSIX compliant everywhere - " \ + "use gnulib module calloc-posix for portability"), \ + calloc (n, s)) +#endif + + +#if @GNULIB_ATOLL@ +# if !@HAVE_ATOLL@ +/* Parse a signed decimal integer. + Returns the value of the integer. Errors are not detected. */ +extern long long atoll (const char *string); +# endif +#elif defined GNULIB_POSIXCHECK +# undef atoll +# define atoll(s) \ + (GL_LINK_WARNING ("atoll is unportable - " \ + "use gnulib module atoll for portability"), \ + atoll (s)) +#endif + + +#if @GNULIB_GETLOADAVG@ +# if !@HAVE_DECL_GETLOADAVG@ +/* Store max(NELEM,3) load average numbers in LOADAVG[]. + The three numbers are the load average of the last 1 minute, the last 5 + minutes, and the last 15 minutes, respectively. + LOADAVG is an array of NELEM numbers. */ +extern int getloadavg (double loadavg[], int nelem); +# endif +#elif defined GNULIB_POSIXCHECK +# undef getloadavg +# define getloadavg(l,n) \ + (GL_LINK_WARNING ("getloadavg is not portable - " \ + "use gnulib module getloadavg for portability"), \ + getloadavg (l, n)) +#endif + + +#if @GNULIB_GETSUBOPT@ +/* Assuming *OPTIONP is a comma separated list of elements of the form + "token" or "token=value", getsubopt parses the first of these elements. + If the first element refers to a "token" that is member of the given + NULL-terminated array of tokens: + - It replaces the comma with a NUL byte, updates *OPTIONP to point past + the first option and the comma, sets *VALUEP to the value of the + element (or NULL if it doesn't contain an "=" sign), + - It returns the index of the "token" in the given array of tokens. + Otherwise it returns -1, and *OPTIONP and *VALUEP are undefined. + For more details see the POSIX:2001 specification. + http://www.opengroup.org/susv3xsh/getsubopt.html */ +# if !@HAVE_GETSUBOPT@ +extern int getsubopt (char **optionp, char *const *tokens, char **valuep); +# endif +#elif defined GNULIB_POSIXCHECK +# undef getsubopt +# define getsubopt(o,t,v) \ + (GL_LINK_WARNING ("getsubopt is unportable - " \ + "use gnulib module getsubopt for portability"), \ + getsubopt (o, t, v)) +#endif + + +#if @GNULIB_MKDTEMP@ +# if !@HAVE_MKDTEMP@ +/* Create a unique temporary directory from TEMPLATE. + The last six characters of TEMPLATE must be "XXXXXX"; + they are replaced with a string that makes the directory name unique. + Returns TEMPLATE, or a null pointer if it cannot get a unique name. + The directory is created mode 700. */ +extern char * mkdtemp (char * /*template*/); +# endif +#elif defined GNULIB_POSIXCHECK +# undef mkdtemp +# define mkdtemp(t) \ + (GL_LINK_WARNING ("mkdtemp is unportable - " \ + "use gnulib module mkdtemp for portability"), \ + mkdtemp (t)) +#endif + + +#if @GNULIB_MKSTEMP@ +# if @REPLACE_MKSTEMP@ +/* Create a unique temporary file from TEMPLATE. + The last six characters of TEMPLATE must be "XXXXXX"; + they are replaced with a string that makes the file name unique. + The file is then created, ensuring it didn't exist before. + The file is created read-write (mask at least 0600 & ~umask), but it may be + world-readable and world-writable (mask 0666 & ~umask), depending on the + implementation. + Returns the open file descriptor if successful, otherwise -1 and errno + set. */ +# define mkstemp rpl_mkstemp +extern int mkstemp (char * /*template*/); +# else +/* On MacOS X 10.3, only declares mkstemp. */ +# include +# endif +#elif defined GNULIB_POSIXCHECK +# undef mkstemp +# define mkstemp(t) \ + (GL_LINK_WARNING ("mkstemp is unportable - " \ + "use gnulib module mkstemp for portability"), \ + mkstemp (t)) +#endif + + +#if @GNULIB_PUTENV@ +# if @REPLACE_PUTENV@ +# undef putenv +# define putenv rpl_putenv +extern int putenv (char *string); +# endif +#endif + + +#if @GNULIB_RANDOM_R@ +# if !@HAVE_RANDOM_R@ + +# ifndef RAND_MAX +# define RAND_MAX 2147483647 +# endif + +int srandom_r (unsigned int seed, struct random_data *rand_state); +int initstate_r (unsigned int seed, char *buf, size_t buf_size, + struct random_data *rand_state); +int setstate_r (char *arg_state, struct random_data *rand_state); +int random_r (struct random_data *buf, int32_t *result); +# endif +#elif defined GNULIB_POSIXCHECK +# undef random_r +# define random_r(b,r) \ + (GL_LINK_WARNING ("random_r is unportable - " \ + "use gnulib module random_r for portability"), \ + random_r (b,r)) +# undef initstate_r +# define initstate_r(s,b,sz,r) \ + (GL_LINK_WARNING ("initstate_r is unportable - " \ + "use gnulib module random_r for portability"), \ + initstate_r (s,b,sz,r)) +# undef srandom_r +# define srandom_r(s,r) \ + (GL_LINK_WARNING ("srandom_r is unportable - " \ + "use gnulib module random_r for portability"), \ + srandom_r (s,r)) +# undef setstate_r +# define setstate_r(a,r) \ + (GL_LINK_WARNING ("setstate_r is unportable - " \ + "use gnulib module random_r for portability"), \ + setstate_r (a,r)) +#endif + + +#if @GNULIB_RPMATCH@ +# if !@HAVE_RPMATCH@ +/* Test a user response to a question. + Return 1 if it is affirmative, 0 if it is negative, or -1 if not clear. */ +extern int rpmatch (const char *response); +# endif +#elif defined GNULIB_POSIXCHECK +# undef rpmatch +# define rpmatch(r) \ + (GL_LINK_WARNING ("rpmatch is unportable - " \ + "use gnulib module rpmatch for portability"), \ + rpmatch (r)) +#endif + + +#if @GNULIB_SETENV@ +# if !@HAVE_SETENV@ +/* Set NAME to VALUE in the environment. + If REPLACE is nonzero, overwrite an existing value. */ +extern int setenv (const char *name, const char *value, int replace); +# endif +#endif + + +#if @GNULIB_UNSETENV@ +# if @HAVE_UNSETENV@ +# if @VOID_UNSETENV@ +/* On some systems, unsetenv() returns void. + This is the case for MacOS X 10.3, FreeBSD 4.8, NetBSD 1.6, OpenBSD 3.4. */ +# define unsetenv(name) ((unsetenv)(name), 0) +# endif +# else +/* Remove the variable NAME from the environment. */ +extern int unsetenv (const char *name); +# endif +#endif + + +#if @GNULIB_STRTOD@ +# if @REPLACE_STRTOD@ +# define strtod rpl_strtod +# endif +# if !@HAVE_STRTOD@ || @REPLACE_STRTOD@ + /* Parse a double from STRING, updating ENDP if appropriate. */ +extern double strtod (const char *str, char **endp); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strtod +# define strtod(s, e) \ + (GL_LINK_WARNING ("strtod is unportable - " \ + "use gnulib module strtod for portability"), \ + strtod (s, e)) +#endif + + +#if @GNULIB_STRTOLL@ +# if !@HAVE_STRTOLL@ +/* Parse a signed integer whose textual representation starts at STRING. + The integer is expected to be in base BASE (2 <= BASE <= 36); if BASE == 0, + it may be decimal or octal (with prefix "0") or hexadecimal (with prefix + "0x"). + If ENDPTR is not NULL, the address of the first byte after the integer is + stored in *ENDPTR. + Upon overflow, the return value is LLONG_MAX or LLONG_MIN, and errno is set + to ERANGE. */ +extern long long strtoll (const char *string, char **endptr, int base); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strtoll +# define strtoll(s,e,b) \ + (GL_LINK_WARNING ("strtoll is unportable - " \ + "use gnulib module strtoll for portability"), \ + strtoll (s, e, b)) +#endif + + +#if @GNULIB_STRTOULL@ +# if !@HAVE_STRTOULL@ +/* Parse an unsigned integer whose textual representation starts at STRING. + The integer is expected to be in base BASE (2 <= BASE <= 36); if BASE == 0, + it may be decimal or octal (with prefix "0") or hexadecimal (with prefix + "0x"). + If ENDPTR is not NULL, the address of the first byte after the integer is + stored in *ENDPTR. + Upon overflow, the return value is ULLONG_MAX, and errno is set to + ERANGE. */ +extern unsigned long long strtoull (const char *string, char **endptr, int base); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strtoull +# define strtoull(s,e,b) \ + (GL_LINK_WARNING ("strtoull is unportable - " \ + "use gnulib module strtoull for portability"), \ + strtoull (s, e, b)) +#endif + + +#ifdef __cplusplus +} +#endif + +#endif /* _GL_STDLIB_H */ +#endif /* _GL_STDLIB_H */ +#endif diff --git a/lib/strftime.c b/lib/strftime.c index ac011d431..e3402237e 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991-1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007 Free Software +/* Copyright (C) 1991-1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. @@ -18,19 +18,18 @@ along with this program. If not, see . */ #ifdef _LIBC -# define HAVE_MBLEN 1 -# define HAVE_MBRLEN 1 # define HAVE_STRUCT_ERA_ENTRY 1 # define HAVE_TM_GMTOFF 1 # define HAVE_TM_ZONE 1 # define HAVE_TZNAME 1 # define HAVE_TZSET 1 -# define MULTIBYTE_IS_FORMAT_SAFE 1 # include "../locale/localeinfo.h" #else # include # if FPRINTFTIME # include "fprintftime.h" +# else +# include "strftime.h" # endif #endif @@ -44,10 +43,16 @@ extern char *tzname[]; /* Do multibyte processing if multibytes are supported, unless multibyte sequences are safe in formats. Multibyte sequences are safe if they cannot contain byte sequences that look like format - conversion specifications. The GNU C Library uses UTF8 multibyte - encoding, which is safe for formats, but strftime.c can be used - with other C libraries that use unsafe encodings. */ -#define DO_MULTIBYTE (HAVE_MBLEN && ! MULTIBYTE_IS_FORMAT_SAFE) + conversion specifications. The multibyte encodings used by the + C library on the various platforms (UTF-8, GB2312, GBK, CP936, + GB18030, EUC-TW, BIG5, BIG5-HKSCS, CP950, EUC-JP, EUC-KR, CP949, + SHIFT_JIS, CP932, JOHAB) are safe for formats, because the byte '%' + cannot occur in a multibyte character except in the first byte. + But this does not hold for the DEC-HANYU encoding used on OSF/1. */ +#if !defined __osf__ +# define MULTIBYTE_IS_FORMAT_SAFE 1 +#endif +#define DO_MULTIBYTE (! MULTIBYTE_IS_FORMAT_SAFE) #if DO_MULTIBYTE # include @@ -79,13 +84,6 @@ extern char *tzname[]; # define MEMCPY(d, s, n) memcpy (d, s, n) # define STRLEN(s) strlen (s) -# ifdef _LIBC -# define MEMPCPY(d, s, n) __mempcpy (d, s, n) -# else -# ifndef HAVE_MEMPCPY -# define MEMPCPY(d, s, n) ((void *) ((char *) memcpy (d, s, n) + (n))) -# endif -# endif #endif /* Shift A right by B bits portably, by dividing A by 2**B and diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h new file mode 100644 index 000000000..52ef46619 --- /dev/null +++ b/lib/sys_file.in.h @@ -0,0 +1,60 @@ +/* Provide a more complete sys/file.h. + + Copyright (C) 2007-2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +/* Written by Richard W.M. Jones. */ +#ifndef _GL_SYS_FILE_H + +# if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +# endif + +/* The include_next requires a split double-inclusion guard. */ +# if @HAVE_SYS_FILE_H@ +# @INCLUDE_NEXT@ @NEXT_SYS_FILE_H@ +# endif + +#ifndef _GL_SYS_FILE_H +#define _GL_SYS_FILE_H + + +#if @GNULIB_FLOCK@ +/* Apply or remove advisory locks on an open file. + Return 0 if successful, otherwise -1 and errno set. */ +# if !@HAVE_FLOCK@ +extern int flock (int fd, int operation); + +/* Operations for the 'flock' call (same as Linux kernel constants). */ +#define LOCK_SH 1 /* Shared lock. */ +#define LOCK_EX 2 /* Exclusive lock. */ +#define LOCK_UN 8 /* Unlock. */ + +/* Can be OR'd in to one of the above. */ +#define LOCK_NB 4 /* Don't block when locking. */ + +# endif +#elif defined GNULIB_POSIXCHECK +# undef flock +# define flock(fd,op) \ + (GL_LINK_WARNING ("flock is unportable - " \ + "use gnulib module flock for portability"), \ + flock ((fd), (op))) +#endif + + +#endif /* _GL_SYS_FILE_H */ +#endif /* _GL_SYS_FILE_H */ diff --git a/lib/unistd.in.h b/lib/unistd.in.h index d4b842a05..2e42c0b89 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2003-2008 Free Software Foundation, Inc. + Copyright (C) 2003-2009 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -29,7 +29,7 @@ #ifndef _GL_UNISTD_H #define _GL_UNISTD_H -/* mingw doesn't define the SEEK_* macros in . */ +/* mingw doesn't define the SEEK_* or *_FILENO macros in . */ #if !(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET) # include #endif @@ -87,6 +87,17 @@ /* The definition of GL_LINK_WARNING is copied here. */ +/* OS/2 EMX lacks these macros. */ +#ifndef STDIN_FILENO +# define STDIN_FILENO 0 +#endif +#ifndef STDOUT_FILENO +# define STDOUT_FILENO 1 +#endif +#ifndef STDERR_FILENO +# define STDERR_FILENO 2 +#endif + /* Declare overridden functions. */ #ifdef __cplusplus @@ -120,10 +131,6 @@ extern int chown (const char *file, uid_t uid, gid_t gid); #if @GNULIB_CLOSE@ -# if @UNISTD_H_HAVE_WINSOCK2_H@ -/* Need a gnulib internal function. */ -# define HAVE__GL_CLOSE_FD_MAYBE_SOCKET 1 -# endif # if @REPLACE_CLOSE@ /* Automatically included by modules that need a replacement for close. */ # undef close @@ -475,6 +482,23 @@ extern int lchown (char const *file, uid_t owner, gid_t group); #endif +#if @GNULIB_LINK@ +/* Create a new hard link for an existing file. + Return 0 if successful, otherwise -1 and errno set. + See POSIX:2001 specification + . */ +# if !@HAVE_LINK@ +extern int link (const char *path1, const char *path2); +# endif +#elif defined GNULIB_POSIXCHECK +# undef link +# define link(path1,path2) \ + (GL_LINK_WARNING ("link is unportable - " \ + "use gnulib module link for portability"), \ + link (path1, path2)) +#endif + + #if @GNULIB_LSEEK@ # if @REPLACE_LSEEK@ /* Set the offset of FD relative to SEEK_SET, SEEK_CUR, or SEEK_END. diff --git a/lib/wchar.in.h b/lib/wchar.in.h index 3425062ab..1f1f13098 100644 --- a/lib/wchar.in.h +++ b/lib/wchar.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that have issues. - Copyright (C) 2007-2008 Free Software Foundation, Inc. + Copyright (C) 2007-2009 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -30,8 +30,18 @@ @PRAGMA_SYSTEM_HEADER@ #endif -#ifdef __need_mbstate_t -/* Special invocation convention inside uClibc header files. */ +#if defined __need_mbstate_t || (defined __hpux && ((defined _INTTYPES_INCLUDED && !defined strtoimax) || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) || defined _GL_ALREADY_INCLUDING_WCHAR_H +/* Special invocation convention: + - Inside uClibc header files. + - On HP-UX 11.00 we have a sequence of nested includes + -> -> , and the latter includes , + once indirectly -> -> -> + and once directly. In both situations 'wint_t' is not yet defined, + therefore we cannot provide the function overrides; instead include only + the system's . + - On IRIX 6.5, similarly, we have an include -> , and + the latter includes . But here, we have no way to detect whether + is completely included or is still being included. */ #@INCLUDE_NEXT@ @NEXT_WCHAR_H@ @@ -40,6 +50,8 @@ #ifndef _GL_WCHAR_H +#define _GL_ALREADY_INCLUDING_WCHAR_H + /* Tru64 with Desktop Toolkit C has a bug: must be included before . BSD/OS 4.0.1 has a bug: , and must be @@ -55,6 +67,8 @@ # @INCLUDE_NEXT@ @NEXT_WCHAR_H@ #endif +#undef _GL_ALREADY_INCLUDING_WCHAR_H + #ifndef _GL_WCHAR_H #define _GL_WCHAR_H @@ -250,7 +264,11 @@ extern size_t wcsrtombs (char *dest, const wchar_t **srcp, size_t len, mbstate_t /* Convert a wide string to a string. */ #if @GNULIB_WCSNRTOMBS@ -# if !@HAVE_WCSNRTOMBS@ +# if @REPLACE_WCSNRTOMBS@ +# undef wcsnrtombs +# define wcsnrtombs rpl_wcsnrtombs +# endif +# if !@HAVE_WCSNRTOMBS@ || @REPLACE_WCSNRTOMBS@ extern size_t wcsnrtombs (char *dest, const wchar_t **srcp, size_t srclen, size_t len, mbstate_t *ps); # endif #elif defined GNULIB_POSIXCHECK diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 new file mode 100644 index 000000000..d4d04d153 --- /dev/null +++ b/m4/00gnulib.m4 @@ -0,0 +1,30 @@ +# 00gnulib.m4 serial 2 +dnl Copyright (C) 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl This file must be named something that sorts before all other +dnl gnulib-provided .m4 files. It is needed until such time as we can +dnl assume Autoconf 2.64, with its improved AC_DEFUN_ONCE semantics. + +# AC_DEFUN_ONCE([NAME], VALUE) +# ---------------------------- +# Define NAME to expand to VALUE on the first use (whether by direct +# expansion, or by AC_REQUIRE), and to nothing on all subsequent uses. +# Avoid bugs in AC_REQUIRE in Autoconf 2.63 and earlier. This +# definition is slower than the version in Autoconf 2.64, because it +# can only use interfaces that existed since 2.59; but it achieves the +# same effect. Quoting is necessary to avoid confusing Automake. +m4_version_prereq([2.63.263], [], +[m4_define([AC][_DEFUN_ONCE], + [AC][_DEFUN([$1], + [AC_REQUIRE([_gl_DEFUN_ONCE([$1])], + [m4_indir([_gl_DEFUN_ONCE([$1])])])])]dnl +[AC][_DEFUN([_gl_DEFUN_ONCE([$1])], [$2])])]) + +# gl_00GNULIB +# ----------- +# Witness macro that this file has been included. Needed to force +# Automake to include this file prior to all other gnulib .m4 files. +AC_DEFUN([gl_00GNULIB]) diff --git a/m4/alloca.m4 b/m4/alloca.m4 index 95f54a6d4..4b978e137 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,5 +1,5 @@ -# alloca.m4 serial 8 -dnl Copyright (C) 2002-2004, 2006, 2007 Free Software Foundation, Inc. +# alloca.m4 serial 9 +dnl Copyright (C) 2002-2004, 2006, 2007, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -26,7 +26,7 @@ AC_DEFUN([gl_FUNC_ALLOCA], ]) if test $gl_cv_rpl_alloca = yes; then dnl OK, alloca can be implemented through a compiler built-in. - AC_DEFINE([HAVE_ALLOCA], 1, + AC_DEFINE([HAVE_ALLOCA], [1], [Define to 1 if you have 'alloca' after including , a header that may be supplied by this distribution.]) ALLOCA_H=alloca.h diff --git a/m4/codeset.m4 b/m4/codeset.m4 index de4181d7d..413217bd4 100644 --- a/m4/codeset.m4 +++ b/m4/codeset.m4 @@ -1,5 +1,5 @@ -# codeset.m4 serial 3 (gettext-0.18) -dnl Copyright (C) 2000-2002, 2006, 2008 Free Software Foundation, Inc. +# codeset.m4 serial 4 (gettext-0.18) +dnl Copyright (C) 2000-2002, 2006, 2008, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -15,7 +15,7 @@ AC_DEFUN([AM_LANGINFO_CODESET], [am_cv_langinfo_codeset=no]) ]) if test $am_cv_langinfo_codeset = yes; then - AC_DEFINE([HAVE_LANGINFO_CODESET], 1, + AC_DEFINE([HAVE_LANGINFO_CODESET], [1], [Define if you have and nl_langinfo(CODESET).]) fi ]) diff --git a/m4/extensions.m4 b/m4/extensions.m4 index 611fcfdbc..ba6d5e190 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@ -1,7 +1,7 @@ -# serial 6 -*- Autoconf -*- +# serial 8 -*- Autoconf -*- # Enable extensions on systems that normally disable them. -# Copyright (C) 2003, 2006-2008 Free Software Foundation, Inc. +# Copyright (C) 2003, 2006-2009 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -20,7 +20,7 @@ # AC_DEFINE. The goal here is to define all known feature-enabling # macros, then, if reports of conflicts are made, disable macros that # cause problems on some platforms (such as __EXTENSIONS__). -AC_DEFUN([AC_USE_SYSTEM_EXTENSIONS], +AC_DEFUN_ONCE([AC_USE_SYSTEM_EXTENSIONS], [AC_BEFORE([$0], [AC_COMPILE_IFELSE])dnl AC_BEFORE([$0], [AC_RUN_IFELSE])dnl @@ -90,5 +90,15 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl # ------------------------ # Enable extensions on systems that normally disable them, # typically due to standards-conformance issues. -AC_DEFUN([gl_USE_SYSTEM_EXTENSIONS], - [AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])]) +AC_DEFUN_ONCE([gl_USE_SYSTEM_EXTENSIONS], +[ + dnl Require this macro before AC_USE_SYSTEM_EXTENSIONS. + dnl gnulib does not need it. But if it gets required by third-party macros + dnl after AC_USE_SYSTEM_EXTENSIONS is required, autoconf 2.62..2.63 emit a + dnl warning: "AC_COMPILE_IFELSE was called before AC_USE_SYSTEM_EXTENSIONS". + dnl Note: We can do this only for one of the macros AC_AIX, AC_GNU_SOURCE, + dnl AC_MINIX. If people still use AC_AIX or AC_MINIX, they are out of luck. + AC_REQUIRE([AC_GNU_SOURCE]) + + AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) +]) diff --git a/m4/flock.m4 b/m4/flock.m4 new file mode 100644 index 000000000..96475fc57 --- /dev/null +++ b/m4/flock.m4 @@ -0,0 +1,26 @@ +# flock.m4 serial 1 +dnl Copyright (C) 2008 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_FLOCK], +[ + AC_REQUIRE([gl_HEADER_SYS_FILE_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([flock]) + if test $ac_cv_func_flock = no; then + HAVE_FLOCK=0 + AC_LIBOBJ([flock]) + gl_PREREQ_FLOCK + fi +]) + +dnl Prerequisites of lib/flock.c. +AC_DEFUN([gl_PREREQ_FLOCK], +[ + AC_CHECK_FUNCS_ONCE([fcntl]) + AC_CHECK_HEADERS_ONCE([unistd.h fcntl.h]) + + dnl Do we have a POSIX fcntl lock implementation? + AC_CHECK_MEMBERS([struct flock.l_type],[],[],[[#include ]]) +]) diff --git a/m4/fpieee.m4 b/m4/fpieee.m4 new file mode 100644 index 000000000..9f4a92cb3 --- /dev/null +++ b/m4/fpieee.m4 @@ -0,0 +1,52 @@ +# fpieee.m4 serial 1 +dnl Copyright (C) 2007 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl IEEE 754 standardized three items: +dnl - The formats of single-float and double-float - nowadays commonly +dnl available as 'float' and 'double' in C and C++. +dnl No autoconf test needed. +dnl - The overflow and division by zero behaviour: The result are values +dnl '±Inf' and 'NaN', rather than exceptions as it was before. +dnl This file provides an autoconf macro for ensuring this behaviour of +dnl floating-point operations. +dnl - A set of conditions (overflow, underflow, inexact, etc.) which can +dnl be configured to trigger an exception. +dnl This cannot be done in a portable way: it depends on the compiler, +dnl libc, kernel, and CPU. No autoconf macro is provided for this. + +dnl Ensure non-trapping behaviour of floating-point overflow and +dnl floating-point division by zero. +dnl (For integer overflow, see gcc's -ftrapv option; for integer division by +dnl zero, see the autoconf macro in intdiv0.m4.) + +AC_DEFUN([gl_FP_IEEE], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) + # IEEE behaviour is the default on all CPUs except Alpha and SH + # (according to the test results of Bruno Haible's ieeefp/fenv_default.m4 + # and the GCC 4.1.2 manual). + case "$host_cpu" in + alpha*) + # On Alpha systems, a compiler option provides the behaviour. + # See the ieee(3) manual page, also available at + # + if test -n "$GCC"; then + # GCC has the option -mieee. + CPPFLAGS="$CPPFLAGS -mieee" + else + # Compaq (ex-DEC) C has the option -ieee. + CPPFLAGS="$CPPFLAGS -ieee" + fi + ;; + sh*) + if test -n "$GCC"; then + # GCC has the option -mieee. + CPPFLAGS="$CPPFLAGS -mieee" + fi + ;; + esac +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 5781d1d82..1122aa58d 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions full-read full-write strcase strftime +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write putenv stdlib strcase strftime # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -24,8 +24,12 @@ gl_MODULES([ autobuild count-one-bits extensions + flock + fpieee full-read full-write + putenv + stdlib strcase strftime ]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index c73db14cc..c8fda2033 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,5 +1,5 @@ -# gnulib-common.m4 serial 6 -dnl Copyright (C) 2007-2008 Free Software Foundation, Inc. +# gnulib-common.m4 serial 11 +dnl Copyright (C) 2007-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -8,6 +8,7 @@ dnl with or without modifications, as long as this notice is preserved. # is expanded unconditionally through gnulib-tool magic. AC_DEFUN([gl_COMMON], [ dnl Use AC_REQUIRE here, so that the code is expanded once only. + AC_REQUIRE([gl_00GNULIB]) AC_REQUIRE([gl_COMMON_BODY]) ]) AC_DEFUN([gl_COMMON_BODY], [ @@ -52,7 +53,7 @@ m4_ifndef([m4_foreach_w], # is a backport of autoconf-2.60's AC_PROG_MKDIR_P. # Remove this macro when we can assume autoconf >= 2.60. m4_ifdef([AC_PROG_MKDIR_P], [], [ - AC_DEFUN([AC_PROG_MKDIR_P], + AC_DEFUN_ONCE([AC_PROG_MKDIR_P], [AC_REQUIRE([AM_PROG_MKDIR_P])dnl defined by automake MKDIR_P='$(mkdir_p)' AC_SUBST([MKDIR_P])])]) @@ -63,7 +64,7 @@ m4_ifdef([AC_PROG_MKDIR_P], [], [ # works. # This definition can be removed once autoconf >= 2.62 can be assumed. AC_DEFUN([AC_C_RESTRICT], -[AC_CACHE_CHECK([for C/C++ restrict keyword], ac_cv_c_restrict, +[AC_CACHE_CHECK([for C/C++ restrict keyword], [ac_cv_c_restrict], [ac_cv_c_restrict=no # The order here caters to the fact that C++ does not require restrict. for ac_kw in __restrict __restrict__ _Restrict restrict; do @@ -99,3 +100,25 @@ AC_DEFUN([AC_C_RESTRICT], *) AC_DEFINE_UNQUOTED([restrict], [$ac_cv_c_restrict]) ;; esac ]) + +# gl_BIGENDIAN +# is like AC_C_BIGENDIAN, except that it can be AC_REQUIREd. +# Note that AC_REQUIRE([AC_C_BIGENDIAN]) does not work reliably because some +# macros invoke AC_C_BIGENDIAN with arguments. +AC_DEFUN([gl_BIGENDIAN], +[ + AC_C_BIGENDIAN +]) + +# gl_CACHE_VAL_SILENT(cache-id, command-to-set-it) +# is like AC_CACHE_VAL(cache-id, command-to-set-it), except that it does not +# output a spurious "(cached)" mark in the midst of other configure output. +# This macro should be used instead of AC_CACHE_VAL when it is not surrounded +# by an AC_MSG_CHECKING/AC_MSG_RESULT pair. +AC_DEFUN([gl_CACHE_VAL_SILENT], +[ + saved_as_echo_n="$as_echo_n" + as_echo_n=':' + AC_CACHE_VAL([$1], [$2]) + as_echo_n="$saved_as_echo_n" +]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 5e9ce99e8..186f30f7a 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -27,6 +27,7 @@ AC_DEFUN([gl_EARLY], AC_REQUIRE([AC_PROG_RANLIB]) AB_INIT AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_REQUIRE([gl_FP_IEEE]) ]) # This macro should be invoked from ./configure.in, in the section @@ -44,23 +45,34 @@ AC_DEFUN([gl_INIT], gl_source_base='lib' gl_FUNC_ALLOCA gl_COUNT_ONE_BITS + gl_FUNC_FLOCK + gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) gl_INLINE gl_LOCALCHARSET LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\"" AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) + gl_FUNC_MALLOC_POSIX + gl_STDLIB_MODULE_INDICATOR([malloc-posix]) gl_FUNC_MBRLEN gl_WCHAR_MODULE_INDICATOR([mbrlen]) gl_FUNC_MBRTOWC gl_WCHAR_MODULE_INDICATOR([mbrtowc]) gl_FUNC_MBSINIT gl_WCHAR_MODULE_INDICATOR([mbsinit]) + gl_MULTIARCH + gl_FUNC_PUTENV + gl_STDLIB_MODULE_INDICATOR([putenv]) gl_SAFE_READ gl_SAFE_WRITE gt_TYPE_SSIZE_T AM_STDBOOL_H + gl_STDINT_H + gl_STDLIB_H gl_STRCASE gl_FUNC_GNU_STRFTIME gl_HEADER_STRINGS_H + gl_HEADER_SYS_FILE_H + AC_PROG_MKDIR_P gl_HEADER_TIME_H gl_TIME_R gl_UNISTD_H @@ -199,15 +211,18 @@ AC_DEFUN([gl_FILE_LIST], [ lib/alloca.in.h lib/config.charset lib/count-one-bits.h + lib/flock.c lib/full-read.c lib/full-read.h lib/full-write.c lib/full-write.h lib/localcharset.c lib/localcharset.h + lib/malloc.c lib/mbrlen.c lib/mbrtowc.c lib/mbsinit.c + lib/putenv.c lib/ref-add.sin lib/ref-del.sin lib/safe-read.c @@ -215,23 +230,29 @@ AC_DEFUN([gl_FILE_LIST], [ lib/safe-write.c lib/safe-write.h lib/stdbool.in.h + lib/stdint.in.h + lib/stdlib.in.h lib/strcasecmp.c lib/streq.h lib/strftime.c lib/strftime.h lib/strings.in.h lib/strncasecmp.c + lib/sys_file.in.h lib/time.in.h lib/time_r.c lib/unistd.in.h lib/verify.h lib/wchar.in.h lib/write.c + m4/00gnulib.m4 m4/alloca.m4 m4/autobuild.m4 m4/codeset.m4 m4/count-one-bits.m4 m4/extensions.m4 + m4/flock.m4 + m4/fpieee.m4 m4/glibc21.m4 m4/gnulib-common.m4 m4/include_next.m4 @@ -240,17 +261,24 @@ AC_DEFUN([gl_FILE_LIST], [ m4/locale-fr.m4 m4/locale-ja.m4 m4/locale-zh.m4 + m4/longlong.m4 + m4/malloc.m4 m4/mbrlen.m4 m4/mbrtowc.m4 m4/mbsinit.m4 m4/mbstate_t.m4 + m4/multiarch.m4 + m4/putenv.m4 m4/safe-read.m4 m4/safe-write.m4 m4/ssize_t.m4 m4/stdbool.m4 + m4/stdint.m4 + m4/stdlib_h.m4 m4/strcase.m4 m4/strftime.m4 m4/strings_h.m4 + m4/sys_file_h.m4 m4/time_h.m4 m4/time_r.m4 m4/tm_gmtoff.m4 diff --git a/m4/include_next.m4 b/m4/include_next.m4 index 062753c58..d6101fe32 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,5 +1,5 @@ -# include_next.m4 serial 10 -dnl Copyright (C) 2006-2008 Free Software Foundation, Inc. +# include_next.m4 serial 12 +dnl Copyright (C) 2006-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -32,14 +32,15 @@ AC_DEFUN([gl_INCLUDE_NEXT], [gl_cv_have_include_next], [rm -rf conftestd1a conftestd1b conftestd2 mkdir conftestd1a conftestd1b conftestd2 - dnl The include of is because IBM C 9.0 on AIX 6.1 supports - dnl include_next when used as first preprocessor directive in a file, - dnl but not when preceded by another include directive. Additionally, - dnl with this same compiler, include_next is a no-op when used in a - dnl header file that was included by specifying its absolute file name. - dnl Despite these two bugs, include_next is used in the compiler's - dnl . By virtue of the second bug, we need to use include_next - dnl as well in this case. + dnl IBM C 9.0, 10.1 (original versions, prior to the 2009-01 updates) on + dnl AIX 6.1 support include_next when used as first preprocessor directive + dnl in a file, but not when preceded by another include directive. Check + dnl for this bug by including . + dnl Additionally, with this same compiler, include_next is a no-op when + dnl used in a header file that was included by specifying its absolute + dnl file name. Despite these two bugs, include_next is used in the + dnl compiler's . By virtue of the second bug, we need to use + dnl include_next as well in this case. cat < conftestd1a/conftest.h #define DEFINED_IN_CONFTESTD1 #include_next diff --git a/m4/inline.m4 b/m4/inline.m4 index a07076cd6..cee51099f 100644 --- a/m4/inline.m4 +++ b/m4/inline.m4 @@ -1,5 +1,5 @@ -# inline.m4 serial 3 -dnl Copyright (C) 2006 Free Software Foundation, Inc. +# inline.m4 serial 4 +dnl Copyright (C) 2006, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -32,7 +32,7 @@ AC_DEFUN([gl_INLINE], fi ]) if test $gl_cv_c_inline_effective = yes; then - AC_DEFINE([HAVE_INLINE], 1, + AC_DEFINE([HAVE_INLINE], [1], [Define to 1 if the compiler supports one of the keywords 'inline', '__inline__', '__inline' and effectively inlines functions marked as such.]) diff --git a/m4/localcharset.m4 b/m4/localcharset.m4 index b2b77338e..e9601041c 100644 --- a/m4/localcharset.m4 +++ b/m4/localcharset.m4 @@ -1,5 +1,5 @@ -# localcharset.m4 serial 5 -dnl Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc. +# localcharset.m4 serial 6 +dnl Copyright (C) 2002, 2004, 2006, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -8,7 +8,7 @@ AC_DEFUN([gl_LOCALCHARSET], [ dnl Prerequisites of lib/localcharset.c. AC_REQUIRE([AM_LANGINFO_CODESET]) - AC_CHECK_DECLS_ONCE(getc_unlocked) + AC_CHECK_DECLS_ONCE([getc_unlocked]) dnl Prerequisites of the lib/Makefile.am snippet. AC_REQUIRE([AC_CANONICAL_HOST]) diff --git a/m4/locale-fr.m4 b/m4/locale-fr.m4 index ac8a78d2c..653a5bc2b 100644 --- a/m4/locale-fr.m4 +++ b/m4/locale-fr.m4 @@ -1,5 +1,5 @@ -# locale-fr.m4 serial 9 -dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc. +# locale-fr.m4 serial 11 +dnl Copyright (C) 2003, 2005-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -11,26 +11,8 @@ AC_DEFUN([gt_LOCALE_FR], [ AC_REQUIRE([AC_CANONICAL_HOST]) AC_REQUIRE([AM_LANGINFO_CODESET]) - AC_CACHE_CHECK([for a traditional french locale], gt_cv_locale_fr, [ - macosx= -changequote(,)dnl - case "$host_os" in - darwin[56]*) ;; - darwin*) macosx=yes;; - esac -changequote([,])dnl - if test -n "$macosx"; then - # On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8 - # encodings, but the kernel does not support them. The documentation - # says: - # "... all code that calls BSD system routines should ensure - # that the const *char parameters of these routines are in UTF-8 - # encoding. All BSD system functions expect their string - # parameters to be in UTF-8 encoding and nothing else." - # See the comments in config.charset. Therefore we bypass the test. - gt_cv_locale_fr=none - else - AC_LANG_CONFTEST([AC_LANG_SOURCE([ + AC_CACHE_CHECK([for a traditional french locale], [gt_cv_locale_fr], [ + AC_LANG_CONFTEST([AC_LANG_SOURCE([ changequote(,)dnl #include #include @@ -75,42 +57,41 @@ int main () { return 0; } changequote([,])dnl - ])]) - if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then - # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because - # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the - # configure script would override the LC_ALL setting. Likewise for - # LC_CTYPE, which is also set at the beginning of the configure script. - # Test for the usual locale name. - if (LC_ALL=fr_FR LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_fr=fr_FR + ])]) + if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then + # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because + # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the + # configure script would override the LC_ALL setting. Likewise for + # LC_CTYPE, which is also set at the beginning of the configure script. + # Test for the usual locale name. + if (LC_ALL=fr_FR LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_fr=fr_FR + else + # Test for the locale name with explicit encoding suffix. + if (LC_ALL=fr_FR.ISO-8859-1 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_fr=fr_FR.ISO-8859-1 else - # Test for the locale name with explicit encoding suffix. - if (LC_ALL=fr_FR.ISO-8859-1 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_fr=fr_FR.ISO-8859-1 + # Test for the AIX, OSF/1, FreeBSD, NetBSD, OpenBSD locale name. + if (LC_ALL=fr_FR.ISO8859-1 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_fr=fr_FR.ISO8859-1 else - # Test for the AIX, OSF/1, FreeBSD, NetBSD, OpenBSD locale name. - if (LC_ALL=fr_FR.ISO8859-1 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_fr=fr_FR.ISO8859-1 + # Test for the HP-UX locale name. + if (LC_ALL=fr_FR.iso88591 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_fr=fr_FR.iso88591 else - # Test for the HP-UX locale name. - if (LC_ALL=fr_FR.iso88591 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_fr=fr_FR.iso88591 + # Test for the Solaris 7 locale name. + if (LC_ALL=fr LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_fr=fr else - # Test for the Solaris 7 locale name. - if (LC_ALL=fr LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_fr=fr - else - # None found. - gt_cv_locale_fr=none - fi + # None found. + gt_cv_locale_fr=none fi fi fi fi fi - rm -fr conftest* fi + rm -fr conftest* ]) LOCALE_FR=$gt_cv_locale_fr AC_SUBST([LOCALE_FR]) @@ -120,7 +101,7 @@ dnl Determine the name of a french locale with UTF-8 encoding. AC_DEFUN([gt_LOCALE_FR_UTF8], [ AC_REQUIRE([AM_LANGINFO_CODESET]) - AC_CACHE_CHECK([for a french Unicode locale], gt_cv_locale_fr_utf8, [ + AC_CACHE_CHECK([for a french Unicode locale], [gt_cv_locale_fr_utf8], [ AC_LANG_CONFTEST([AC_LANG_SOURCE([ changequote(,)dnl #include diff --git a/m4/locale-ja.m4 b/m4/locale-ja.m4 index c42064f72..936057647 100644 --- a/m4/locale-ja.m4 +++ b/m4/locale-ja.m4 @@ -1,5 +1,5 @@ -# locale-ja.m4 serial 5 -dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc. +# locale-ja.m4 serial 7 +dnl Copyright (C) 2003, 2005-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -11,26 +11,8 @@ AC_DEFUN([gt_LOCALE_JA], [ AC_REQUIRE([AC_CANONICAL_HOST]) AC_REQUIRE([AM_LANGINFO_CODESET]) - AC_CACHE_CHECK([for a traditional japanese locale], gt_cv_locale_ja, [ - macosx= -changequote(,)dnl - case "$host_os" in - darwin[56]*) ;; - darwin*) macosx=yes;; - esac -changequote([,])dnl - if test -n "$macosx"; then - # On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8 - # encodings, but the kernel does not support them. The documentation - # says: - # "... all code that calls BSD system routines should ensure - # that the const *char parameters of these routines are in UTF-8 - # encoding. All BSD system functions expect their string - # parameters to be in UTF-8 encoding and nothing else." - # See the comments in config.charset. Therefore we bypass the test. - gt_cv_locale_ja=none - else - AC_LANG_CONFTEST([AC_LANG_SOURCE([ + AC_CACHE_CHECK([for a traditional japanese locale], [gt_cv_locale_ja], [ + AC_LANG_CONFTEST([AC_LANG_SOURCE([ changequote(,)dnl #include #include @@ -79,47 +61,46 @@ int main () return 0; } changequote([,])dnl - ])]) - if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then - # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because - # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the - # configure script would override the LC_ALL setting. Likewise for - # LC_CTYPE, which is also set at the beginning of the configure script. - # Test for the AIX locale name. - if (LC_ALL=ja_JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_ja=ja_JP + ])]) + if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then + # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because + # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the + # configure script would override the LC_ALL setting. Likewise for + # LC_CTYPE, which is also set at the beginning of the configure script. + # Test for the AIX locale name. + if (LC_ALL=ja_JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_ja=ja_JP + else + # Test for the locale name with explicit encoding suffix. + if (LC_ALL=ja_JP.EUC-JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_ja=ja_JP.EUC-JP else - # Test for the locale name with explicit encoding suffix. - if (LC_ALL=ja_JP.EUC-JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_ja=ja_JP.EUC-JP + # Test for the HP-UX, OSF/1, NetBSD locale name. + if (LC_ALL=ja_JP.eucJP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_ja=ja_JP.eucJP else - # Test for the HP-UX, OSF/1, NetBSD locale name. - if (LC_ALL=ja_JP.eucJP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_ja=ja_JP.eucJP + # Test for the IRIX, FreeBSD locale name. + if (LC_ALL=ja_JP.EUC LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_ja=ja_JP.EUC else - # Test for the IRIX, FreeBSD locale name. - if (LC_ALL=ja_JP.EUC LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_ja=ja_JP.EUC + # Test for the Solaris 7 locale name. + if (LC_ALL=ja LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_ja=ja else - # Test for the Solaris 7 locale name. - if (LC_ALL=ja LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_ja=ja + # Special test for NetBSD 1.6. + if test -f /usr/share/locale/ja_JP.eucJP/LC_CTYPE; then + gt_cv_locale_ja=ja_JP.eucJP else - # Special test for NetBSD 1.6. - if test -f /usr/share/locale/ja_JP.eucJP/LC_CTYPE; then - gt_cv_locale_ja=ja_JP.eucJP - else - # None found. - gt_cv_locale_ja=none - fi + # None found. + gt_cv_locale_ja=none fi fi fi fi fi fi - rm -fr conftest* fi + rm -fr conftest* ]) LOCALE_JA=$gt_cv_locale_ja AC_SUBST([LOCALE_JA]) diff --git a/m4/locale-zh.m4 b/m4/locale-zh.m4 index 594f62a69..36a5f1dfb 100644 --- a/m4/locale-zh.m4 +++ b/m4/locale-zh.m4 @@ -1,5 +1,5 @@ -# locale-zh.m4 serial 4 -dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc. +# locale-zh.m4 serial 6 +dnl Copyright (C) 2003, 2005-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -11,26 +11,8 @@ AC_DEFUN([gt_LOCALE_ZH_CN], [ AC_REQUIRE([AC_CANONICAL_HOST]) AC_REQUIRE([AM_LANGINFO_CODESET]) - AC_CACHE_CHECK([for a transitional chinese locale], gt_cv_locale_zh_CN, [ - macosx= -changequote(,)dnl - case "$host_os" in - darwin[56]*) ;; - darwin*) macosx=yes;; - esac -changequote([,])dnl - if test -n "$macosx"; then - # On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8 - # encodings, but the kernel does not support them. The documentation - # says: - # "... all code that calls BSD system routines should ensure - # that the const *char parameters of these routines are in UTF-8 - # encoding. All BSD system functions expect their string - # parameters to be in UTF-8 encoding and nothing else." - # See the comments in config.charset. Therefore we bypass the test. - gt_cv_locale_zh_CN=none - else - AC_LANG_CONFTEST([AC_LANG_SOURCE([ + AC_CACHE_CHECK([for a transitional chinese locale], [gt_cv_locale_zh_CN], [ + AC_LANG_CONFTEST([AC_LANG_SOURCE([ changequote(,)dnl #include #include @@ -80,31 +62,30 @@ int main () return 0; } changequote([,])dnl - ])]) - if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then - # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because - # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the - # configure script would override the LC_ALL setting. Likewise for - # LC_CTYPE, which is also set at the beginning of the configure script. - # Test for the locale name without encoding suffix. - if (LC_ALL=zh_CN LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_zh_CN=zh_CN - else - # Test for the locale name with explicit encoding suffix. - if (LC_ALL=zh_CN.GB18030 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then - gt_cv_locale_zh_CN=zh_CN.GB18030 - else - # None found. - gt_cv_locale_zh_CN=none - fi - fi + ])]) + if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then + # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because + # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the + # configure script would override the LC_ALL setting. Likewise for + # LC_CTYPE, which is also set at the beginning of the configure script. + # Test for the locale name without encoding suffix. + if (LC_ALL=zh_CN LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_zh_CN=zh_CN else - # If there was a link error, due to mblen(), the system is so old that - # it certainly doesn't have a chinese locale. - gt_cv_locale_zh_CN=none + # Test for the locale name with explicit encoding suffix. + if (LC_ALL=zh_CN.GB18030 LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then + gt_cv_locale_zh_CN=zh_CN.GB18030 + else + # None found. + gt_cv_locale_zh_CN=none + fi fi - rm -fr conftest* + else + # If there was a link error, due to mblen(), the system is so old that + # it certainly doesn't have a chinese locale. + gt_cv_locale_zh_CN=none fi + rm -fr conftest* ]) LOCALE_ZH_CN=$gt_cv_locale_zh_CN AC_SUBST([LOCALE_ZH_CN]) diff --git a/m4/longlong.m4 b/m4/longlong.m4 new file mode 100644 index 000000000..eedc8d568 --- /dev/null +++ b/m4/longlong.m4 @@ -0,0 +1,106 @@ +# longlong.m4 serial 14 +dnl Copyright (C) 1999-2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Paul Eggert. + +# Define HAVE_LONG_LONG_INT if 'long long int' works. +# This fixes a bug in Autoconf 2.61, but can be removed once we +# assume 2.62 everywhere. + +# Note: If the type 'long long int' exists but is only 32 bits large +# (as on some very old compilers), HAVE_LONG_LONG_INT will not be +# defined. In this case you can treat 'long long int' like 'long int'. + +AC_DEFUN([AC_TYPE_LONG_LONG_INT], +[ + AC_CACHE_CHECK([for long long int], [ac_cv_type_long_long_int], + [AC_LINK_IFELSE( + [_AC_TYPE_LONG_LONG_SNIPPET], + [dnl This catches a bug in Tandem NonStop Kernel (OSS) cc -O circa 2004. + dnl If cross compiling, assume the bug isn't important, since + dnl nobody cross compiles for this platform as far as we know. + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [[@%:@include + @%:@ifndef LLONG_MAX + @%:@ define HALF \ + (1LL << (sizeof (long long int) * CHAR_BIT - 2)) + @%:@ define LLONG_MAX (HALF - 1 + HALF) + @%:@endif]], + [[long long int n = 1; + int i; + for (i = 0; ; i++) + { + long long int m = n << i; + if (m >> i != n) + return 1; + if (LLONG_MAX / 2 < m) + break; + } + return 0;]])], + [ac_cv_type_long_long_int=yes], + [ac_cv_type_long_long_int=no], + [ac_cv_type_long_long_int=yes])], + [ac_cv_type_long_long_int=no])]) + if test $ac_cv_type_long_long_int = yes; then + AC_DEFINE([HAVE_LONG_LONG_INT], [1], + [Define to 1 if the system has the type `long long int'.]) + fi +]) + +# Define HAVE_UNSIGNED_LONG_LONG_INT if 'unsigned long long int' works. +# This fixes a bug in Autoconf 2.61, but can be removed once we +# assume 2.62 everywhere. + +# Note: If the type 'unsigned long long int' exists but is only 32 bits +# large (as on some very old compilers), AC_TYPE_UNSIGNED_LONG_LONG_INT +# will not be defined. In this case you can treat 'unsigned long long int' +# like 'unsigned long int'. + +AC_DEFUN([AC_TYPE_UNSIGNED_LONG_LONG_INT], +[ + AC_CACHE_CHECK([for unsigned long long int], + [ac_cv_type_unsigned_long_long_int], + [AC_LINK_IFELSE( + [_AC_TYPE_LONG_LONG_SNIPPET], + [ac_cv_type_unsigned_long_long_int=yes], + [ac_cv_type_unsigned_long_long_int=no])]) + if test $ac_cv_type_unsigned_long_long_int = yes; then + AC_DEFINE([HAVE_UNSIGNED_LONG_LONG_INT], [1], + [Define to 1 if the system has the type `unsigned long long int'.]) + fi +]) + +# Expands to a C program that can be used to test for simultaneous support +# of 'long long' and 'unsigned long long'. We don't want to say that +# 'long long' is available if 'unsigned long long' is not, or vice versa, +# because too many programs rely on the symmetry between signed and unsigned +# integer types (excluding 'bool'). +AC_DEFUN([_AC_TYPE_LONG_LONG_SNIPPET], +[ + AC_LANG_PROGRAM( + [[/* For now, do not test the preprocessor; as of 2007 there are too many + implementations with broken preprocessors. Perhaps this can + be revisited in 2012. In the meantime, code should not expect + #if to work with literals wider than 32 bits. */ + /* Test literals. */ + long long int ll = 9223372036854775807ll; + long long int nll = -9223372036854775807LL; + unsigned long long int ull = 18446744073709551615ULL; + /* Test constant expressions. */ + typedef int a[((-9223372036854775807LL < 0 && 0 < 9223372036854775807ll) + ? 1 : -1)]; + typedef int b[(18446744073709551615ULL <= (unsigned long long int) -1 + ? 1 : -1)]; + int i = 63;]], + [[/* Test availability of runtime routines for shift and division. */ + long long int llmax = 9223372036854775807ll; + unsigned long long int ullmax = 18446744073709551615ull; + return ((ll << 63) | (ll >> 63) | (ll < i) | (ll > i) + | (llmax / ll) | (llmax % ll) + | (ull << 63) | (ull >> 63) | (ull << i) | (ull >> i) + | (ullmax / ull) | (ullmax % ull));]]) +]) diff --git a/m4/malloc.m4 b/m4/malloc.m4 new file mode 100644 index 000000000..807017166 --- /dev/null +++ b/m4/malloc.m4 @@ -0,0 +1,41 @@ +# malloc.m4 serial 9 +dnl Copyright (C) 2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +# gl_FUNC_MALLOC_POSIX +# -------------------- +# Test whether 'malloc' is POSIX compliant (sets errno to ENOMEM when it +# fails), and replace malloc if it is not. +AC_DEFUN([gl_FUNC_MALLOC_POSIX], +[ + AC_REQUIRE([gl_CHECK_MALLOC_POSIX]) + if test $gl_cv_func_malloc_posix = yes; then + HAVE_MALLOC_POSIX=1 + AC_DEFINE([HAVE_MALLOC_POSIX], [1], + [Define if the 'malloc' function is POSIX compliant.]) + else + AC_LIBOBJ([malloc]) + HAVE_MALLOC_POSIX=0 + fi + AC_SUBST([HAVE_MALLOC_POSIX]) +]) + +# Test whether malloc, realloc, calloc are POSIX compliant, +# Set gl_cv_func_malloc_posix to yes or no accordingly. +AC_DEFUN([gl_CHECK_MALLOC_POSIX], +[ + AC_CACHE_CHECK([whether malloc, realloc, calloc are POSIX compliant], + [gl_cv_func_malloc_posix], + [ + dnl It is too dangerous to try to allocate a large amount of memory: + dnl some systems go to their knees when you do that. So assume that + dnl all Unix implementations of the function are POSIX compliant. + AC_TRY_COMPILE([], + [#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + choke me + #endif + ], [gl_cv_func_malloc_posix=yes], [gl_cv_func_malloc_posix=no]) + ]) +]) diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4 index da0d426f0..11d7d23e7 100644 --- a/m4/mbrtowc.m4 +++ b/m4/mbrtowc.m4 @@ -1,5 +1,5 @@ -# mbrtowc.m4 serial 12 -dnl Copyright (C) 2001-2002, 2004-2005, 2008 Free Software Foundation, Inc. +# mbrtowc.m4 serial 15 +dnl Copyright (C) 2001-2002, 2004-2005, 2008, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -65,9 +65,15 @@ AC_DEFUN([gl_MBSTATE_T_BROKEN], AC_CHECK_FUNCS_ONCE([mbrtowc]) if test $ac_cv_func_mbsinit = yes && test $ac_cv_func_mbrtowc = yes; then gl_MBRTOWC_INCOMPLETE_STATE + gl_MBRTOWC_SANITYCHECK + REPLACE_MBSTATE_T=0 case "$gl_cv_func_mbrtowc_incomplete_state" in - *yes) REPLACE_MBSTATE_T=0 ;; - *) REPLACE_MBSTATE_T=1 ;; + *yes) ;; + *) REPLACE_MBSTATE_T=1 ;; + esac + case "$gl_cv_func_mbrtowc_sanitycheck" in + *yes) ;; + *) REPLACE_MBSTATE_T=1 ;; esac else REPLACE_MBSTATE_T=1 @@ -121,7 +127,58 @@ int main () }], [gl_cv_func_mbrtowc_incomplete_state=yes], [gl_cv_func_mbrtowc_incomplete_state=no], - []) + [:]) + fi + ]) +]) + +dnl Test whether mbrtowc works not worse than mbtowc. +dnl Result is gl_cv_func_mbrtowc_sanitycheck. + +AC_DEFUN([gl_MBRTOWC_SANITYCHECK], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([gt_LOCALE_ZH_CN]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether mbrtowc works as well as mbtowc], + [gl_cv_func_mbrtowc_sanitycheck], + [ + dnl Initial guess, used when cross-compiling or when no suitable locale + dnl is present. +changequote(,)dnl + case "$host_os" in + # Guess no on Solaris 8. + solaris2.8) gl_cv_func_mbrtowc_sanitycheck="guessing no" ;; + # Guess yes otherwise. + *) gl_cv_func_mbrtowc_sanitycheck="guessing yes" ;; + esac +changequote([,])dnl + if test $LOCALE_ZH_CN != none; then + AC_TRY_RUN([ +#include +#include +#include +int main () +{ + /* This fails on Solaris 8: + mbrtowc returns 2, and sets wc to 0x00F0. + mbtowc returns 4 (correct) and sets wc to 0x5EDC. */ + if (setlocale (LC_ALL, "$LOCALE_ZH_CN") != NULL) + { + char input[] = "B\250\271\201\060\211\070er"; /* "Büßer" */ + mbstate_t state; + wchar_t wc; + + memset (&state, '\0', sizeof (mbstate_t)); + if (mbrtowc (&wc, input + 3, 6, &state) != 4 + && mbtowc (&wc, input + 3, 6) == 4) + return 1; + } + return 0; +}], + [gl_cv_func_mbrtowc_sanitycheck=yes], + [gl_cv_func_mbrtowc_sanitycheck=no], + [:]) fi ]) ]) @@ -168,7 +225,7 @@ int main () return 1; } return 0; -}], [gl_cv_func_mbrtowc_null_arg=yes], [gl_cv_func_mbrtowc_null_arg=no], []) +}], [gl_cv_func_mbrtowc_null_arg=yes], [gl_cv_func_mbrtowc_null_arg=no], [:]) fi ]) ]) @@ -238,7 +295,7 @@ int main () }], [gl_cv_func_mbrtowc_retval=yes], [gl_cv_func_mbrtowc_retval=no], - []) + [:]) fi ]) ]) @@ -258,10 +315,10 @@ AC_DEFUN([gl_MBRTOWC_NUL_RETVAL], dnl is present. changequote(,)dnl case "$host_os" in - # Guess no on Solaris 9. - solaris2.9) gl_cv_func_mbrtowc_nul_retval="guessing no" ;; - # Guess yes otherwise. - *) gl_cv_func_mbrtowc_nul_retval="guessing yes" ;; + # Guess no on Solaris 8 and 9. + solaris2.[89]) gl_cv_func_mbrtowc_nul_retval="guessing no" ;; + # Guess yes otherwise. + *) gl_cv_func_mbrtowc_nul_retval="guessing yes" ;; esac changequote([,])dnl if test $LOCALE_ZH_CN != none; then @@ -271,7 +328,7 @@ changequote([,])dnl #include int main () { - /* This fails on Solaris 9. */ + /* This fails on Solaris 8 and 9. */ if (setlocale (LC_ALL, "$LOCALE_ZH_CN") != NULL) { mbstate_t state; @@ -285,7 +342,7 @@ int main () }], [gl_cv_func_mbrtowc_nul_retval=yes], [gl_cv_func_mbrtowc_nul_retval=no], - []) + [:]) fi ]) ]) @@ -318,7 +375,7 @@ AC_DEFUN([AC_FUNC_MBRTOWC], gl_cv_func_mbrtowc=yes, gl_cv_func_mbrtowc=no)]) if test $gl_cv_func_mbrtowc = yes; then - AC_DEFINE([HAVE_MBRTOWC], 1, + AC_DEFINE([HAVE_MBRTOWC], [1], [Define to 1 if mbrtowc and mbstate_t are properly declared.]) fi ]) diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4 index d2153d9bc..d4ec6f0fc 100644 --- a/m4/mbstate_t.m4 +++ b/m4/mbstate_t.m4 @@ -1,5 +1,5 @@ -# mbstate_t.m4 serial 11 -dnl Copyright (C) 2000-2002, 2008 Free Software Foundation, Inc. +# mbstate_t.m4 serial 12 +dnl Copyright (C) 2000-2002, 2008, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -16,7 +16,7 @@ AC_DEFUN([AC_TYPE_MBSTATE_T], [ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) dnl for HP-UX 11.11 - AC_CACHE_CHECK([for mbstate_t], ac_cv_type_mbstate_t, + AC_CACHE_CHECK([for mbstate_t], [ac_cv_type_mbstate_t], [AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [AC_INCLUDES_DEFAULT[ @@ -25,10 +25,10 @@ AC_DEFUN([AC_TYPE_MBSTATE_T], [ac_cv_type_mbstate_t=yes], [ac_cv_type_mbstate_t=no])]) if test $ac_cv_type_mbstate_t = yes; then - AC_DEFINE([HAVE_MBSTATE_T], 1, + AC_DEFINE([HAVE_MBSTATE_T], [1], [Define to 1 if declares mbstate_t.]) else - AC_DEFINE([mbstate_t], int, + AC_DEFINE([mbstate_t], [int], [Define to a type if does not define.]) fi ]) diff --git a/m4/multiarch.m4 b/m4/multiarch.m4 new file mode 100644 index 000000000..ec377bac8 --- /dev/null +++ b/m4/multiarch.m4 @@ -0,0 +1,65 @@ +# multiarch.m4 serial 5 +dnl Copyright (C) 2008, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +# Determine whether the compiler is or may be producing universal binaries. +# +# On MacOS X 10.5 and later systems, the user can create libraries and +# executables that work on multiple system types--known as "fat" or +# "universal" binaries--by specifying multiple '-arch' options to the +# compiler but only a single '-arch' option to the preprocessor. Like +# this: +# +# ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ +# CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ +# CPP="gcc -E" CXXCPP="g++ -E" +# +# Detect this situation and set the macro AA_APPLE_UNIVERSAL_BUILD at the +# beginning of config.h and set APPLE_UNIVERSAL_BUILD accordingly. + +AC_DEFUN_ONCE([gl_MULTIARCH], +[ + dnl Code similar to autoconf-2.63 AC_C_BIGENDIAN. + gl_cv_c_multiarch=no + AC_COMPILE_IFELSE( + [AC_LANG_SOURCE( + [[#ifndef __APPLE_CC__ + not a universal capable compiler + #endif + typedef int dummy; + ]])], + [ + dnl Check for potential -arch flags. It is not universal unless + dnl there are at least two -arch flags with different values. + arch= + prev= + for word in ${CC} ${CFLAGS} ${CPPFLAGS} ${LDFLAGS}; do + if test -n "$prev"; then + case $word in + i?86 | x86_64 | ppc | ppc64) + if test -z "$arch" || test "$arch" = "$word"; then + arch="$word" + else + gl_cv_c_multiarch=yes + fi + ;; + esac + prev= + else + if test "x$word" = "x-arch"; then + prev=arch + fi + fi + done + ]) + if test $gl_cv_c_multiarch = yes; then + AC_DEFINE([AA_APPLE_UNIVERSAL_BUILD], [1], + [Define if the compiler is building for multiple architectures of Apple platforms at once.]) + APPLE_UNIVERSAL_BUILD=1 + else + APPLE_UNIVERSAL_BUILD=0 + fi + AC_SUBST([APPLE_UNIVERSAL_BUILD]) +]) diff --git a/m4/putenv.m4 b/m4/putenv.m4 new file mode 100644 index 000000000..120f5a4a5 --- /dev/null +++ b/m4/putenv.m4 @@ -0,0 +1,41 @@ +# putenv.m4 serial 16 +dnl Copyright (C) 2002-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Jim Meyering. +dnl +dnl Check whether putenv ("FOO") removes FOO from the environment. +dnl The putenv in libc on at least SunOS 4.1.4 does *not* do that. + +AC_DEFUN([gl_FUNC_PUTENV], +[ + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + AC_CACHE_CHECK([for putenv compatible with GNU and SVID], + [gl_cv_func_svid_putenv], + [AC_RUN_IFELSE([AC_LANG_PROGRAM([AC_INCLUDES_DEFAULT],[[ + /* Put it in env. */ + if (putenv ("CONFTEST_putenv=val")) + return 1; + + /* Try to remove it. */ + if (putenv ("CONFTEST_putenv")) + return 1; + + /* Make sure it was deleted. */ + if (getenv ("CONFTEST_putenv") != 0) + return 1; + + return 0; + ]])], + gl_cv_func_svid_putenv=yes, + gl_cv_func_svid_putenv=no, + dnl When crosscompiling, assume putenv is broken. + gl_cv_func_svid_putenv=no) + ]) + if test $gl_cv_func_svid_putenv = no; then + REPLACE_PUTENV=1 + AC_LIBOBJ([putenv]) + fi +]) diff --git a/m4/stdbool.m4 b/m4/stdbool.m4 index 2204ecd98..57c804a80 100644 --- a/m4/stdbool.m4 +++ b/m4/stdbool.m4 @@ -1,6 +1,6 @@ # Check for stdbool.h that conforms to C99. -dnl Copyright (C) 2002-2006 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -111,5 +111,5 @@ AC_DEFUN([AC_HEADER_STDBOOL], [ac_cv_header_stdbool_h=no])]) AC_CHECK_TYPES([_Bool]) if test $ac_cv_header_stdbool_h = yes; then - AC_DEFINE(HAVE_STDBOOL_H, 1, [Define to 1 if stdbool.h conforms to C99.]) + AC_DEFINE([HAVE_STDBOOL_H], [1], [Define to 1 if stdbool.h conforms to C99.]) fi]) diff --git a/m4/stdint.m4 b/m4/stdint.m4 new file mode 100644 index 000000000..a2e8bdd62 --- /dev/null +++ b/m4/stdint.m4 @@ -0,0 +1,472 @@ +# stdint.m4 serial 34 +dnl Copyright (C) 2001-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Paul Eggert and Bruno Haible. +dnl Test whether is supported or must be substituted. + +AC_DEFUN([gl_STDINT_H], +[ + AC_PREREQ([2.59])dnl + + dnl Check for long long int and unsigned long long int. + AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) + if test $ac_cv_type_long_long_int = yes; then + HAVE_LONG_LONG_INT=1 + else + HAVE_LONG_LONG_INT=0 + fi + AC_SUBST([HAVE_LONG_LONG_INT]) + AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT]) + if test $ac_cv_type_unsigned_long_long_int = yes; then + HAVE_UNSIGNED_LONG_LONG_INT=1 + else + HAVE_UNSIGNED_LONG_LONG_INT=0 + fi + AC_SUBST([HAVE_UNSIGNED_LONG_LONG_INT]) + + dnl Check for . + dnl AC_INCLUDES_DEFAULT defines $ac_cv_header_inttypes_h. + if test $ac_cv_header_inttypes_h = yes; then + HAVE_INTTYPES_H=1 + else + HAVE_INTTYPES_H=0 + fi + AC_SUBST([HAVE_INTTYPES_H]) + + dnl Check for . + dnl AC_INCLUDES_DEFAULT defines $ac_cv_header_sys_types_h. + if test $ac_cv_header_sys_types_h = yes; then + HAVE_SYS_TYPES_H=1 + else + HAVE_SYS_TYPES_H=0 + fi + AC_SUBST([HAVE_SYS_TYPES_H]) + + gl_CHECK_NEXT_HEADERS([stdint.h]) + if test $ac_cv_header_stdint_h = yes; then + HAVE_STDINT_H=1 + else + HAVE_STDINT_H=0 + fi + AC_SUBST([HAVE_STDINT_H]) + + dnl Now see whether we need a substitute . + if test $ac_cv_header_stdint_h = yes; then + AC_CACHE_CHECK([whether stdint.h conforms to C99], + [gl_cv_header_working_stdint_h], + [gl_cv_header_working_stdint_h=no + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ +#define __STDC_LIMIT_MACROS 1 /* to make it work also in C++ mode */ +#define __STDC_CONSTANT_MACROS 1 /* to make it work also in C++ mode */ +#define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */ +#include +/* Dragonfly defines WCHAR_MIN, WCHAR_MAX only in . */ +#if !(defined WCHAR_MIN && defined WCHAR_MAX) +#error "WCHAR_MIN, WCHAR_MAX not defined in " +#endif +] +gl_STDINT_INCLUDES +[ +#ifdef INT8_MAX +int8_t a1 = INT8_MAX; +int8_t a1min = INT8_MIN; +#endif +#ifdef INT16_MAX +int16_t a2 = INT16_MAX; +int16_t a2min = INT16_MIN; +#endif +#ifdef INT32_MAX +int32_t a3 = INT32_MAX; +int32_t a3min = INT32_MIN; +#endif +#ifdef INT64_MAX +int64_t a4 = INT64_MAX; +int64_t a4min = INT64_MIN; +#endif +#ifdef UINT8_MAX +uint8_t b1 = UINT8_MAX; +#else +typedef int b1[(unsigned char) -1 != 255 ? 1 : -1]; +#endif +#ifdef UINT16_MAX +uint16_t b2 = UINT16_MAX; +#endif +#ifdef UINT32_MAX +uint32_t b3 = UINT32_MAX; +#endif +#ifdef UINT64_MAX +uint64_t b4 = UINT64_MAX; +#endif +int_least8_t c1 = INT8_C (0x7f); +int_least8_t c1max = INT_LEAST8_MAX; +int_least8_t c1min = INT_LEAST8_MIN; +int_least16_t c2 = INT16_C (0x7fff); +int_least16_t c2max = INT_LEAST16_MAX; +int_least16_t c2min = INT_LEAST16_MIN; +int_least32_t c3 = INT32_C (0x7fffffff); +int_least32_t c3max = INT_LEAST32_MAX; +int_least32_t c3min = INT_LEAST32_MIN; +int_least64_t c4 = INT64_C (0x7fffffffffffffff); +int_least64_t c4max = INT_LEAST64_MAX; +int_least64_t c4min = INT_LEAST64_MIN; +uint_least8_t d1 = UINT8_C (0xff); +uint_least8_t d1max = UINT_LEAST8_MAX; +uint_least16_t d2 = UINT16_C (0xffff); +uint_least16_t d2max = UINT_LEAST16_MAX; +uint_least32_t d3 = UINT32_C (0xffffffff); +uint_least32_t d3max = UINT_LEAST32_MAX; +uint_least64_t d4 = UINT64_C (0xffffffffffffffff); +uint_least64_t d4max = UINT_LEAST64_MAX; +int_fast8_t e1 = INT_FAST8_MAX; +int_fast8_t e1min = INT_FAST8_MIN; +int_fast16_t e2 = INT_FAST16_MAX; +int_fast16_t e2min = INT_FAST16_MIN; +int_fast32_t e3 = INT_FAST32_MAX; +int_fast32_t e3min = INT_FAST32_MIN; +int_fast64_t e4 = INT_FAST64_MAX; +int_fast64_t e4min = INT_FAST64_MIN; +uint_fast8_t f1 = UINT_FAST8_MAX; +uint_fast16_t f2 = UINT_FAST16_MAX; +uint_fast32_t f3 = UINT_FAST32_MAX; +uint_fast64_t f4 = UINT_FAST64_MAX; +#ifdef INTPTR_MAX +intptr_t g = INTPTR_MAX; +intptr_t gmin = INTPTR_MIN; +#endif +#ifdef UINTPTR_MAX +uintptr_t h = UINTPTR_MAX; +#endif +intmax_t i = INTMAX_MAX; +uintmax_t j = UINTMAX_MAX; + +#include /* for CHAR_BIT */ +#define TYPE_MINIMUM(t) \ + ((t) ((t) 0 < (t) -1 ? (t) 0 : ~ (t) 0 << (sizeof (t) * CHAR_BIT - 1))) +#define TYPE_MAXIMUM(t) \ + ((t) ((t) 0 < (t) -1 ? (t) -1 : ~ (~ (t) 0 << (sizeof (t) * CHAR_BIT - 1)))) +struct s { + int check_PTRDIFF: + PTRDIFF_MIN == TYPE_MINIMUM (ptrdiff_t) + && PTRDIFF_MAX == TYPE_MAXIMUM (ptrdiff_t) + ? 1 : -1; + /* Detect bug in FreeBSD 6.0 / ia64. */ + int check_SIG_ATOMIC: + SIG_ATOMIC_MIN == TYPE_MINIMUM (sig_atomic_t) + && SIG_ATOMIC_MAX == TYPE_MAXIMUM (sig_atomic_t) + ? 1 : -1; + int check_SIZE: SIZE_MAX == TYPE_MAXIMUM (size_t) ? 1 : -1; + int check_WCHAR: + WCHAR_MIN == TYPE_MINIMUM (wchar_t) + && WCHAR_MAX == TYPE_MAXIMUM (wchar_t) + ? 1 : -1; + /* Detect bug in mingw. */ + int check_WINT: + WINT_MIN == TYPE_MINIMUM (wint_t) + && WINT_MAX == TYPE_MAXIMUM (wint_t) + ? 1 : -1; + + /* Detect bugs in glibc 2.4 and Solaris 10 stdint.h, among others. */ + int check_UINT8_C: + (-1 < UINT8_C (0)) == (-1 < (uint_least8_t) 0) ? 1 : -1; + int check_UINT16_C: + (-1 < UINT16_C (0)) == (-1 < (uint_least16_t) 0) ? 1 : -1; + + /* Detect bugs in OpenBSD 3.9 stdint.h. */ +#ifdef UINT8_MAX + int check_uint8: (uint8_t) -1 == UINT8_MAX ? 1 : -1; +#endif +#ifdef UINT16_MAX + int check_uint16: (uint16_t) -1 == UINT16_MAX ? 1 : -1; +#endif +#ifdef UINT32_MAX + int check_uint32: (uint32_t) -1 == UINT32_MAX ? 1 : -1; +#endif +#ifdef UINT64_MAX + int check_uint64: (uint64_t) -1 == UINT64_MAX ? 1 : -1; +#endif + int check_uint_least8: (uint_least8_t) -1 == UINT_LEAST8_MAX ? 1 : -1; + int check_uint_least16: (uint_least16_t) -1 == UINT_LEAST16_MAX ? 1 : -1; + int check_uint_least32: (uint_least32_t) -1 == UINT_LEAST32_MAX ? 1 : -1; + int check_uint_least64: (uint_least64_t) -1 == UINT_LEAST64_MAX ? 1 : -1; + int check_uint_fast8: (uint_fast8_t) -1 == UINT_FAST8_MAX ? 1 : -1; + int check_uint_fast16: (uint_fast16_t) -1 == UINT_FAST16_MAX ? 1 : -1; + int check_uint_fast32: (uint_fast32_t) -1 == UINT_FAST32_MAX ? 1 : -1; + int check_uint_fast64: (uint_fast64_t) -1 == UINT_FAST64_MAX ? 1 : -1; + int check_uintptr: (uintptr_t) -1 == UINTPTR_MAX ? 1 : -1; + int check_uintmax: (uintmax_t) -1 == UINTMAX_MAX ? 1 : -1; + int check_size: (size_t) -1 == SIZE_MAX ? 1 : -1; +}; + ]])], + [dnl Determine whether the various *_MIN, *_MAX macros are usable + dnl in preprocessor expression. We could do it by compiling a test + dnl program for each of these macros. It is faster to run a program + dnl that inspects the macro expansion. + dnl This detects a bug on HP-UX 11.23/ia64. + AC_RUN_IFELSE([ + AC_LANG_PROGRAM([[ +#define __STDC_LIMIT_MACROS 1 /* to make it work also in C++ mode */ +#define __STDC_CONSTANT_MACROS 1 /* to make it work also in C++ mode */ +#define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */ +#include +] +gl_STDINT_INCLUDES +[ +#include +#include +#define MVAL(macro) MVAL1(macro) +#define MVAL1(expression) #expression +static const char *macro_values[] = + { +#ifdef INT8_MAX + MVAL (INT8_MAX), +#endif +#ifdef INT16_MAX + MVAL (INT16_MAX), +#endif +#ifdef INT32_MAX + MVAL (INT32_MAX), +#endif +#ifdef INT64_MAX + MVAL (INT64_MAX), +#endif +#ifdef UINT8_MAX + MVAL (UINT8_MAX), +#endif +#ifdef UINT16_MAX + MVAL (UINT16_MAX), +#endif +#ifdef UINT32_MAX + MVAL (UINT32_MAX), +#endif +#ifdef UINT64_MAX + MVAL (UINT64_MAX), +#endif + NULL + }; +]], [[ + const char **mv; + for (mv = macro_values; *mv != NULL; mv++) + { + const char *value = *mv; + /* Test whether it looks like a cast expression. */ + if (strncmp (value, "((unsigned int)"/*)*/, 15) == 0 + || strncmp (value, "((unsigned short)"/*)*/, 17) == 0 + || strncmp (value, "((unsigned char)"/*)*/, 16) == 0 + || strncmp (value, "((int)"/*)*/, 6) == 0 + || strncmp (value, "((signed short)"/*)*/, 15) == 0 + || strncmp (value, "((signed char)"/*)*/, 14) == 0) + return 1; + } + return 0; +]])], + [gl_cv_header_working_stdint_h=yes], + [], + [dnl When cross-compiling, assume it works. + gl_cv_header_working_stdint_h=yes + ]) + ]) + ]) + fi + if test "$gl_cv_header_working_stdint_h" = yes; then + STDINT_H= + else + dnl Check for , and for + dnl (used in Linux libc4 >= 4.6.7 and libc5). + AC_CHECK_HEADERS([sys/inttypes.h sys/bitypes.h]) + if test $ac_cv_header_sys_inttypes_h = yes; then + HAVE_SYS_INTTYPES_H=1 + else + HAVE_SYS_INTTYPES_H=0 + fi + AC_SUBST([HAVE_SYS_INTTYPES_H]) + if test $ac_cv_header_sys_bitypes_h = yes; then + HAVE_SYS_BITYPES_H=1 + else + HAVE_SYS_BITYPES_H=0 + fi + AC_SUBST([HAVE_SYS_BITYPES_H]) + + dnl Check for (missing in Linux uClibc when built without wide + dnl character support). + AC_CHECK_HEADERS_ONCE([wchar.h]) + + gl_STDINT_TYPE_PROPERTIES + STDINT_H=stdint.h + fi + AC_SUBST([STDINT_H]) +]) + +dnl gl_STDINT_BITSIZEOF(TYPES, INCLUDES) +dnl Determine the size of each of the given types in bits. +AC_DEFUN([gl_STDINT_BITSIZEOF], +[ + dnl Use a shell loop, to avoid bloating configure, and + dnl - extra AH_TEMPLATE calls, so that autoheader knows what to put into + dnl config.h.in, + dnl - extra AC_SUBST calls, so that the right substitutions are made. + m4_foreach_w([gltype], [$1], + [AH_TEMPLATE([BITSIZEOF_]translit(gltype,[abcdefghijklmnopqrstuvwxyz ],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]), + [Define to the number of bits in type ']gltype['.])]) + for gltype in $1 ; do + AC_CACHE_CHECK([for bit size of $gltype], [gl_cv_bitsizeof_${gltype}], + [AC_COMPUTE_INT([result], [sizeof ($gltype) * CHAR_BIT], + [$2 +#include ], [result=unknown]) + eval gl_cv_bitsizeof_${gltype}=\$result + ]) + eval result=\$gl_cv_bitsizeof_${gltype} + if test $result = unknown; then + dnl Use a nonempty default, because some compilers, such as IRIX 5 cc, + dnl do a syntax check even on unused #if conditions and give an error + dnl on valid C code like this: + dnl #if 0 + dnl # if > 32 + dnl # endif + dnl #endif + result=0 + fi + GLTYPE=`echo "$gltype" | tr 'abcdefghijklmnopqrstuvwxyz ' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'` + AC_DEFINE_UNQUOTED([BITSIZEOF_${GLTYPE}], [$result]) + eval BITSIZEOF_${GLTYPE}=\$result + done + m4_foreach_w([gltype], [$1], + [AC_SUBST([BITSIZEOF_]translit(gltype,[abcdefghijklmnopqrstuvwxyz ],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]))]) +]) + +dnl gl_CHECK_TYPES_SIGNED(TYPES, INCLUDES) +dnl Determine the signedness of each of the given types. +dnl Define HAVE_SIGNED_TYPE if type is signed. +AC_DEFUN([gl_CHECK_TYPES_SIGNED], +[ + dnl Use a shell loop, to avoid bloating configure, and + dnl - extra AH_TEMPLATE calls, so that autoheader knows what to put into + dnl config.h.in, + dnl - extra AC_SUBST calls, so that the right substitutions are made. + m4_foreach_w([gltype], [$1], + [AH_TEMPLATE([HAVE_SIGNED_]translit(gltype,[abcdefghijklmnopqrstuvwxyz ],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]), + [Define to 1 if ']gltype[' is a signed integer type.])]) + for gltype in $1 ; do + AC_CACHE_CHECK([whether $gltype is signed], [gl_cv_type_${gltype}_signed], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([$2[ + int verify[2 * (($gltype) -1 < ($gltype) 0) - 1];]])], + result=yes, result=no) + eval gl_cv_type_${gltype}_signed=\$result + ]) + eval result=\$gl_cv_type_${gltype}_signed + GLTYPE=`echo $gltype | tr 'abcdefghijklmnopqrstuvwxyz ' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'` + if test "$result" = yes; then + AC_DEFINE_UNQUOTED([HAVE_SIGNED_${GLTYPE}], [1]) + eval HAVE_SIGNED_${GLTYPE}=1 + else + eval HAVE_SIGNED_${GLTYPE}=0 + fi + done + m4_foreach_w([gltype], [$1], + [AC_SUBST([HAVE_SIGNED_]translit(gltype,[abcdefghijklmnopqrstuvwxyz ],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]))]) +]) + +dnl gl_INTEGER_TYPE_SUFFIX(TYPES, INCLUDES) +dnl Determine the suffix to use for integer constants of the given types. +dnl Define t_SUFFIX for each such type. +AC_DEFUN([gl_INTEGER_TYPE_SUFFIX], +[ + dnl Use a shell loop, to avoid bloating configure, and + dnl - extra AH_TEMPLATE calls, so that autoheader knows what to put into + dnl config.h.in, + dnl - extra AC_SUBST calls, so that the right substitutions are made. + m4_foreach_w([gltype], [$1], + [AH_TEMPLATE(translit(gltype,[abcdefghijklmnopqrstuvwxyz ],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_])[_SUFFIX], + [Define to l, ll, u, ul, ull, etc., as suitable for + constants of type ']gltype['.])]) + for gltype in $1 ; do + AC_CACHE_CHECK([for $gltype integer literal suffix], + [gl_cv_type_${gltype}_suffix], + [eval gl_cv_type_${gltype}_suffix=no + eval result=\$gl_cv_type_${gltype}_signed + if test "$result" = yes; then + glsufu= + else + glsufu=u + fi + for glsuf in "$glsufu" ${glsufu}l ${glsufu}ll ${glsufu}i64; do + case $glsuf in + '') gltype1='int';; + l) gltype1='long int';; + ll) gltype1='long long int';; + i64) gltype1='__int64';; + u) gltype1='unsigned int';; + ul) gltype1='unsigned long int';; + ull) gltype1='unsigned long long int';; + ui64)gltype1='unsigned __int64';; + esac + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([$2[ + extern $gltype foo; + extern $gltype1 foo;]])], + [eval gl_cv_type_${gltype}_suffix=\$glsuf]) + eval result=\$gl_cv_type_${gltype}_suffix + test "$result" != no && break + done]) + GLTYPE=`echo $gltype | tr 'abcdefghijklmnopqrstuvwxyz ' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'` + eval result=\$gl_cv_type_${gltype}_suffix + test "$result" = no && result= + eval ${GLTYPE}_SUFFIX=\$result + AC_DEFINE_UNQUOTED([${GLTYPE}_SUFFIX], [$result]) + done + m4_foreach_w([gltype], [$1], + [AC_SUBST(translit(gltype,[abcdefghijklmnopqrstuvwxyz ],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_])[_SUFFIX])]) +]) + +dnl gl_STDINT_INCLUDES +AC_DEFUN([gl_STDINT_INCLUDES], +[[ + /* BSD/OS 4.0.1 has a bug: , and must be + included before . */ + #include + #include + #if HAVE_WCHAR_H + # include + # include + # include + #endif +]]) + +dnl gl_STDINT_TYPE_PROPERTIES +dnl Compute HAVE_SIGNED_t, BITSIZEOF_t and t_SUFFIX, for all the types t +dnl of interest to stdint.in.h. +AC_DEFUN([gl_STDINT_TYPE_PROPERTIES], +[ + AC_REQUIRE([gl_MULTIARCH]) + if test $APPLE_UNIVERSAL_BUILD = 0; then + gl_STDINT_BITSIZEOF([ptrdiff_t size_t], + [gl_STDINT_INCLUDES]) + fi + gl_STDINT_BITSIZEOF([sig_atomic_t wchar_t wint_t], + [gl_STDINT_INCLUDES]) + gl_CHECK_TYPES_SIGNED([sig_atomic_t wchar_t wint_t], + [gl_STDINT_INCLUDES]) + gl_cv_type_ptrdiff_t_signed=yes + gl_cv_type_size_t_signed=no + if test $APPLE_UNIVERSAL_BUILD = 0; then + gl_INTEGER_TYPE_SUFFIX([ptrdiff_t size_t], + [gl_STDINT_INCLUDES]) + fi + gl_INTEGER_TYPE_SUFFIX([sig_atomic_t wchar_t wint_t], + [gl_STDINT_INCLUDES]) +]) + +dnl Autoconf >= 2.61 has AC_COMPUTE_INT built-in. +dnl Remove this when we can assume autoconf >= 2.61. +m4_ifdef([AC_COMPUTE_INT], [], [ + AC_DEFUN([AC_COMPUTE_INT], [_AC_COMPUTE_INT([$2],[$1],[$3],[$4])]) +]) + +# Hey Emacs! +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 new file mode 100644 index 000000000..b295f16b2 --- /dev/null +++ b/m4/stdlib_h.m4 @@ -0,0 +1,73 @@ +# stdlib_h.m4 serial 15 +dnl Copyright (C) 2007-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_STDLIB_H], +[ + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + gl_CHECK_NEXT_HEADERS([stdlib.h]) + AC_CHECK_HEADERS([random.h], [], [], [AC_INCLUDES_DEFAULT]) + if test $ac_cv_header_random_h = yes; then + HAVE_RANDOM_H=1 + else + HAVE_RANDOM_H=0 + fi + AC_SUBST([HAVE_RANDOM_H]) + AC_CHECK_TYPES([struct random_data], + [], [HAVE_STRUCT_RANDOM_DATA=0], + [[#include + #if HAVE_RANDOM_H + # include + #endif + ]]) +]) + +AC_DEFUN([gl_STDLIB_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1 +]) + +AC_DEFUN([gl_STDLIB_H_DEFAULTS], +[ + GNULIB_MALLOC_POSIX=0; AC_SUBST([GNULIB_MALLOC_POSIX]) + GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX]) + GNULIB_CALLOC_POSIX=0; AC_SUBST([GNULIB_CALLOC_POSIX]) + GNULIB_ATOLL=0; AC_SUBST([GNULIB_ATOLL]) + GNULIB_GETLOADAVG=0; AC_SUBST([GNULIB_GETLOADAVG]) + GNULIB_GETSUBOPT=0; AC_SUBST([GNULIB_GETSUBOPT]) + GNULIB_MKDTEMP=0; AC_SUBST([GNULIB_MKDTEMP]) + GNULIB_MKSTEMP=0; AC_SUBST([GNULIB_MKSTEMP]) + GNULIB_PUTENV=0; AC_SUBST([GNULIB_PUTENV]) + GNULIB_RANDOM_R=0; AC_SUBST([GNULIB_RANDOM_R]) + GNULIB_RPMATCH=0; AC_SUBST([GNULIB_RPMATCH]) + GNULIB_SETENV=0; AC_SUBST([GNULIB_SETENV]) + GNULIB_STRTOD=0; AC_SUBST([GNULIB_STRTOD]) + GNULIB_STRTOLL=0; AC_SUBST([GNULIB_STRTOLL]) + GNULIB_STRTOULL=0; AC_SUBST([GNULIB_STRTOULL]) + GNULIB_UNSETENV=0; AC_SUBST([GNULIB_UNSETENV]) + dnl Assume proper GNU behavior unless another module says otherwise. + HAVE_ATOLL=1; AC_SUBST([HAVE_ATOLL]) + HAVE_CALLOC_POSIX=1; AC_SUBST([HAVE_CALLOC_POSIX]) + HAVE_GETSUBOPT=1; AC_SUBST([HAVE_GETSUBOPT]) + HAVE_MALLOC_POSIX=1; AC_SUBST([HAVE_MALLOC_POSIX]) + HAVE_MKDTEMP=1; AC_SUBST([HAVE_MKDTEMP]) + HAVE_REALLOC_POSIX=1; AC_SUBST([HAVE_REALLOC_POSIX]) + HAVE_RANDOM_R=1; AC_SUBST([HAVE_RANDOM_R]) + HAVE_RPMATCH=1; AC_SUBST([HAVE_RPMATCH]) + HAVE_SETENV=1; AC_SUBST([HAVE_SETENV]) + HAVE_STRTOD=1; AC_SUBST([HAVE_STRTOD]) + HAVE_STRTOLL=1; AC_SUBST([HAVE_STRTOLL]) + HAVE_STRTOULL=1; AC_SUBST([HAVE_STRTOULL]) + HAVE_STRUCT_RANDOM_DATA=1; AC_SUBST([HAVE_STRUCT_RANDOM_DATA]) + HAVE_SYS_LOADAVG_H=0; AC_SUBST([HAVE_SYS_LOADAVG_H]) + HAVE_UNSETENV=1; AC_SUBST([HAVE_UNSETENV]) + HAVE_DECL_GETLOADAVG=1; AC_SUBST([HAVE_DECL_GETLOADAVG]) + REPLACE_MKSTEMP=0; AC_SUBST([REPLACE_MKSTEMP]) + REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV]) + REPLACE_STRTOD=0; AC_SUBST([REPLACE_STRTOD]) + VOID_UNSETENV=0; AC_SUBST([VOID_UNSETENV]) +]) diff --git a/m4/strcase.m4 b/m4/strcase.m4 index 79c525c11..0dfdb1a18 100644 --- a/m4/strcase.m4 +++ b/m4/strcase.m4 @@ -1,5 +1,5 @@ -# strcase.m4 serial 9 -dnl Copyright (C) 2002, 2005-2008 Free Software Foundation, Inc. +# strcase.m4 serial 10 +dnl Copyright (C) 2002, 2005-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -13,7 +13,7 @@ AC_DEFUN([gl_STRCASE], AC_DEFUN([gl_FUNC_STRCASECMP], [ AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS]) - AC_REPLACE_FUNCS(strcasecmp) + AC_REPLACE_FUNCS([strcasecmp]) if test $ac_cv_func_strcasecmp = no; then HAVE_STRCASECMP=0 gl_PREREQ_STRCASECMP @@ -23,11 +23,11 @@ AC_DEFUN([gl_FUNC_STRCASECMP], AC_DEFUN([gl_FUNC_STRNCASECMP], [ AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS]) - AC_REPLACE_FUNCS(strncasecmp) + AC_REPLACE_FUNCS([strncasecmp]) if test $ac_cv_func_strncasecmp = no; then gl_PREREQ_STRNCASECMP fi - AC_CHECK_DECLS(strncasecmp) + AC_CHECK_DECLS([strncasecmp]) if test $ac_cv_have_decl_strncasecmp = no; then HAVE_DECL_STRNCASECMP=0 fi diff --git a/m4/strftime.m4 b/m4/strftime.m4 index 70b537894..15a87708e 100644 --- a/m4/strftime.m4 +++ b/m4/strftime.m4 @@ -1,7 +1,7 @@ -#serial 29 +# serial 32 # Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, -# 2006, 2007 Free Software Foundation, Inc. +# 2006, 2007, 2009 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -25,8 +25,8 @@ AC_DEFUN([gl_FUNC_STRFTIME], AC_REQUIRE([AC_TYPE_MBSTATE_T]) AC_REQUIRE([gl_TM_GMTOFF]) - AC_CHECK_FUNCS_ONCE(mblen mbrlen mempcpy tzset) - AC_CHECK_HEADERS_ONCE(wchar.h) + AC_CHECK_FUNCS_ONCE([tzset]) + AC_CHECK_HEADERS_ONCE([wchar.h]) AC_DEFINE([my_strftime], [nstrftime], [Define to the name of the strftime replacement function.]) diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4 new file mode 100644 index 000000000..436c6fec1 --- /dev/null +++ b/m4/sys_file_h.m4 @@ -0,0 +1,41 @@ +# Configure a replacement for . + +# Copyright (C) 2008 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# Written by Richard W.M. Jones. + +AC_DEFUN([gl_HEADER_SYS_FILE_H], +[ + AC_REQUIRE([gl_HEADER_SYS_FILE_H_DEFAULTS]) + + dnl Only flock is defined in a working . If that + dnl function is already there, we don't want to do any substitution. + AC_CHECK_FUNCS_ONCE([flock]) + + gl_CHECK_NEXT_HEADERS([sys/file.h]) + SYS_FILE_H='sys/file.h' + AC_SUBST([SYS_FILE_H]) + + AC_CHECK_HEADERS_ONCE([sys/file.h]) + if test $ac_cv_header_sys_file_h = yes; then + HAVE_SYS_FILE_H=1 + else + HAVE_SYS_FILE_H=0 + fi + AC_SUBST([HAVE_SYS_FILE_H]) +]) + +AC_DEFUN([gl_HEADER_SYS_FILE_MODULE_INDICATOR], +[ + AC_REQUIRE([gl_HEADER_SYS_FILE_H_DEFAULTS]) + GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1 +]) + +AC_DEFUN([gl_HEADER_SYS_FILE_H_DEFAULTS], +[ + GNULIB_FLOCK=0; AC_SUBST([GNULIB_FLOCK]) + HAVE_FLOCK=1; AC_SUBST([HAVE_FLOCK]) +]) diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4 index cb0b3c884..911af0a40 100644 --- a/m4/tm_gmtoff.m4 +++ b/m4/tm_gmtoff.m4 @@ -1,5 +1,5 @@ -# tm_gmtoff.m4 serial 2 -dnl Copyright (C) 2002 Free Software Foundation, Inc. +# tm_gmtoff.m4 serial 3 +dnl Copyright (C) 2002, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -7,7 +7,7 @@ dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_TM_GMTOFF], [ AC_CHECK_MEMBER([struct tm.tm_gmtoff], - [AC_DEFINE(HAVE_TM_GMTOFF, 1, + [AC_DEFINE([HAVE_TM_GMTOFF], [1], [Define if struct tm has the tm_gmtoff member.])], , [#include ]) diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index 568527365..ff9a4ea0a 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,5 +1,5 @@ -# unistd_h.m4 serial 16 -dnl Copyright (C) 2006-2008 Free Software Foundation, Inc. +# unistd_h.m4 serial 17 +dnl Copyright (C) 2006-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -48,6 +48,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], GNULIB_GETPAGESIZE=0; AC_SUBST([GNULIB_GETPAGESIZE]) GNULIB_GETUSERSHELL=0; AC_SUBST([GNULIB_GETUSERSHELL]) GNULIB_LCHOWN=0; AC_SUBST([GNULIB_LCHOWN]) + GNULIB_LINK=0; AC_SUBST([GNULIB_LINK]) GNULIB_LSEEK=0; AC_SUBST([GNULIB_LSEEK]) GNULIB_READLINK=0; AC_SUBST([GNULIB_READLINK]) GNULIB_SLEEP=0; AC_SUBST([GNULIB_SLEEP]) @@ -63,6 +64,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], HAVE_GETHOSTNAME=1; AC_SUBST([HAVE_GETHOSTNAME]) HAVE_GETPAGESIZE=1; AC_SUBST([HAVE_GETPAGESIZE]) HAVE_GETUSERSHELL=1; AC_SUBST([HAVE_GETUSERSHELL]) + HAVE_LINK=1; AC_SUBST([HAVE_LINK]) HAVE_READLINK=1; AC_SUBST([HAVE_READLINK]) HAVE_SLEEP=1; AC_SUBST([HAVE_SLEEP]) HAVE_DECL_ENVIRON=1; AC_SUBST([HAVE_DECL_ENVIRON]) diff --git a/m4/wchar.m4 b/m4/wchar.m4 index ba8ee6ab7..2e52a82ac 100644 --- a/m4/wchar.m4 +++ b/m4/wchar.m4 @@ -1,13 +1,13 @@ dnl A placeholder for ISO C99 , for platforms that have issues. -dnl Copyright (C) 2007-2008 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. dnl Written by Eric Blake. -# wchar.m4 serial 22 +# wchar.m4 serial 23 AC_DEFUN([gl_WCHAR_H], [ @@ -73,27 +73,28 @@ AC_DEFUN([gl_WCHAR_H_DEFAULTS], GNULIB_WCSNRTOMBS=0; AC_SUBST([GNULIB_WCSNRTOMBS]) GNULIB_WCWIDTH=0; AC_SUBST([GNULIB_WCWIDTH]) dnl Assume proper GNU behavior unless another module says otherwise. - HAVE_BTOWC=1; AC_SUBST([HAVE_BTOWC]) - HAVE_MBSINIT=1; AC_SUBST([HAVE_MBSINIT]) - HAVE_MBRTOWC=1; AC_SUBST([HAVE_MBRTOWC]) - HAVE_MBRLEN=1; AC_SUBST([HAVE_MBRLEN]) - HAVE_MBSRTOWCS=1; AC_SUBST([HAVE_MBSRTOWCS]) - HAVE_MBSNRTOWCS=1; AC_SUBST([HAVE_MBSNRTOWCS]) - HAVE_WCRTOMB=1; AC_SUBST([HAVE_WCRTOMB]) - HAVE_WCSRTOMBS=1; AC_SUBST([HAVE_WCSRTOMBS]) - HAVE_WCSNRTOMBS=1; AC_SUBST([HAVE_WCSNRTOMBS]) - HAVE_DECL_WCTOB=1; AC_SUBST([HAVE_DECL_WCTOB]) - HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH]) - REPLACE_MBSTATE_T=0; AC_SUBST([REPLACE_MBSTATE_T]) - REPLACE_BTOWC=0; AC_SUBST([REPLACE_BTOWC]) - REPLACE_WCTOB=0; AC_SUBST([REPLACE_WCTOB]) - REPLACE_MBSINIT=0; AC_SUBST([REPLACE_MBSINIT]) - REPLACE_MBRTOWC=0; AC_SUBST([REPLACE_MBRTOWC]) - REPLACE_MBRLEN=0; AC_SUBST([REPLACE_MBRLEN]) - REPLACE_MBSRTOWCS=0; AC_SUBST([REPLACE_MBSRTOWCS]) - REPLACE_MBSNRTOWCS=0;AC_SUBST([REPLACE_MBSNRTOWCS]) - REPLACE_WCRTOMB=0; AC_SUBST([REPLACE_WCRTOMB]) - REPLACE_WCSRTOMBS=0; AC_SUBST([REPLACE_WCSRTOMBS]) - REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH]) - WCHAR_H=''; AC_SUBST([WCHAR_H]) + HAVE_BTOWC=1; AC_SUBST([HAVE_BTOWC]) + HAVE_MBSINIT=1; AC_SUBST([HAVE_MBSINIT]) + HAVE_MBRTOWC=1; AC_SUBST([HAVE_MBRTOWC]) + HAVE_MBRLEN=1; AC_SUBST([HAVE_MBRLEN]) + HAVE_MBSRTOWCS=1; AC_SUBST([HAVE_MBSRTOWCS]) + HAVE_MBSNRTOWCS=1; AC_SUBST([HAVE_MBSNRTOWCS]) + HAVE_WCRTOMB=1; AC_SUBST([HAVE_WCRTOMB]) + HAVE_WCSRTOMBS=1; AC_SUBST([HAVE_WCSRTOMBS]) + HAVE_WCSNRTOMBS=1; AC_SUBST([HAVE_WCSNRTOMBS]) + HAVE_DECL_WCTOB=1; AC_SUBST([HAVE_DECL_WCTOB]) + HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH]) + REPLACE_MBSTATE_T=0; AC_SUBST([REPLACE_MBSTATE_T]) + REPLACE_BTOWC=0; AC_SUBST([REPLACE_BTOWC]) + REPLACE_WCTOB=0; AC_SUBST([REPLACE_WCTOB]) + REPLACE_MBSINIT=0; AC_SUBST([REPLACE_MBSINIT]) + REPLACE_MBRTOWC=0; AC_SUBST([REPLACE_MBRTOWC]) + REPLACE_MBRLEN=0; AC_SUBST([REPLACE_MBRLEN]) + REPLACE_MBSRTOWCS=0; AC_SUBST([REPLACE_MBSRTOWCS]) + REPLACE_MBSNRTOWCS=0; AC_SUBST([REPLACE_MBSNRTOWCS]) + REPLACE_WCRTOMB=0; AC_SUBST([REPLACE_WCRTOMB]) + REPLACE_WCSRTOMBS=0; AC_SUBST([REPLACE_WCSRTOMBS]) + REPLACE_WCSNRTOMBS=0; AC_SUBST([REPLACE_WCSNRTOMBS]) + REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH]) + WCHAR_H=''; AC_SUBST([WCHAR_H]) ]) diff --git a/m4/wint_t.m4 b/m4/wint_t.m4 index 0026a1318..47a4363d7 100644 --- a/m4/wint_t.m4 +++ b/m4/wint_t.m4 @@ -1,5 +1,5 @@ -# wint_t.m4 serial 3 (gettext-0.18) -dnl Copyright (C) 2003, 2007-2008 Free Software Foundation, Inc. +# wint_t.m4 serial 4 (gettext-0.18) +dnl Copyright (C) 2003, 2007-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -23,6 +23,6 @@ AC_DEFUN([gt_TYPE_WINT_T], wint_t foo = (wchar_t)'\0';], , [gt_cv_c_wint_t=yes], [gt_cv_c_wint_t=no])]) if test $gt_cv_c_wint_t = yes; then - AC_DEFINE([HAVE_WINT_T], 1, [Define if you have the 'wint_t' type.]) + AC_DEFINE([HAVE_WINT_T], [1], [Define if you have the 'wint_t' type.]) fi ]) From 3731192f30158c0c70d243ddeae87693fa37a0e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 21 May 2009 01:17:00 +0200 Subject: [PATCH 135/375] Make use of Gnulib's `putenv' module. * libguile/posix.c: Include since the putenv(3) declaration is there (POSIX and Gnulib). (scm_putenv): Rely on Gnulib's `putenv' module. --- libguile/posix.c | 96 +++--------------------------------------------- 1 file changed, 6 insertions(+), 90 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index ddbaeaacb..5f9b6cf8e 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -21,6 +21,7 @@ # include #endif +#include #include #include @@ -1512,98 +1513,13 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, int rv; char *c_str = scm_to_locale_string (str); - if (strchr (c_str, '=') == NULL) - { - /* We want no "=" in the argument to mean remove the variable from the - environment, but not all putenv()s understand this, for example - FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit - painful. What unsetenv() exists, we use that, of course. + /* Leave C_STR in the environment. */ - Traditionally putenv("NAME") removes a variable, for example that's - what we have to do on Solaris 9 (it doesn't have an unsetenv). + /* Gnulib's `putenv' module honors the semantics described above. */ + rv = putenv (c_str); + if (rv < 0) + SCM_SYSERROR; - But on DOS and on that DOS overlay manager thing called W-whatever, - putenv("NAME=") must be used (it too doesn't have an unsetenv). - - Supposedly on AIX a putenv("NAME") could cause a segfault, but also - supposedly AIX 5.3 and up has unsetenv() available so should be ok - with the latter there. - - For the moment we hard code the DOS putenv("NAME=") style under - __MINGW32__ and do the traditional everywhere else. Such - system-name tests are bad, of course. It'd be possible to use a - configure test when doing a a native build. For example GNU R has - such a test (see R_PUTENV_AS_UNSETENV in - https://svn.r-project.org/R/trunk/m4/R.m4). But when cross - compiling there'd want to be a guess, one probably based on the - system name (ie. mingw or not), thus landing back in basically the - present hard-coded situation. Another possibility for a cross - build would be to try "NAME" then "NAME=" at runtime, if that's not - too much like overkill. */ - -#if HAVE_UNSETENV - /* when unsetenv() exists then we use it */ - unsetenv (c_str); - free (c_str); -#elif defined (__MINGW32__) - /* otherwise putenv("NAME=") on DOS */ - int e; - size_t len = strlen (c_str); - char *ptr = scm_malloc (len + 2); - strcpy (ptr, c_str); - strcpy (ptr+len, "="); - rv = putenv (ptr); - e = errno; free (ptr); free (c_str); errno = e; - if (rv < 0) - SCM_SYSERROR; -#else - /* otherwise traditional putenv("NAME") */ - rv = putenv (c_str); - if (rv < 0) - SCM_SYSERROR; -#endif - } - else - { -#ifdef __MINGW32__ - /* If str is "FOO=", ie. attempting to set an empty string, then - we need to see if it's been successful. On MINGW, "FOO=" - means remove FOO from the environment. As a workaround, we - set "FOO= ", ie. a space, and then modify the string returned - by getenv. It's not enough just to modify the string we set, - because MINGW putenv copies it. */ - - { - size_t len = strlen (c_str); - if (c_str[len-1] == '=') - { - char *ptr = scm_malloc (len+2); - strcpy (ptr, c_str); - strcpy (ptr+len, " "); - rv = putenv (ptr); - if (rv < 0) - { - int eno = errno; - free (c_str); - errno = eno; - SCM_SYSERROR; - } - /* truncate to just the name */ - c_str[len-1] = '\0'; - ptr = getenv (c_str); - if (ptr) - ptr[0] = '\0'; - return SCM_UNSPECIFIED; - } - } -#endif /* __MINGW32__ */ - - /* Leave c_str in the environment. */ - - rv = putenv (c_str); - if (rv < 0) - SCM_SYSERROR; - } return SCM_UNSPECIFIED; } #undef FUNC_NAME From 837b0ae0b5d530b0c254ebe331fb5ab1de3e7fe8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 21 May 2009 01:24:01 +0200 Subject: [PATCH 136/375] Make use of Gnulib's `flock' module. * libguile/posix.c: Always use , which is provided by Gnulib. (flock)[__MINGW32__]: Remove. (scm_flock): Compile unconditionally. Always use Gnulib's flock(2). --- libguile/posix.c | 72 +----------------------------------------------- 1 file changed, 1 insertion(+), 71 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 5f9b6cf8e..2799209d9 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -138,9 +138,7 @@ extern char ** environ; # include #endif -#if HAVE_SYS_FILE_H -# include -#endif +#include /* from Gnulib */ #if HAVE_CRT_EXTERNS_H #include /* for Darwin _NSGetEnviron */ @@ -1899,73 +1897,6 @@ SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0, #undef FUNC_NAME #endif /* HAVE_GETPASS */ -/* Wrapper function for flock() support under M$-Windows. */ -#ifdef __MINGW32__ -# include -# include -# include -# ifndef _LK_UNLCK - /* Current MinGW package fails to define this. *sigh* */ -# define _LK_UNLCK 0 -# endif -# define LOCK_EX 1 -# define LOCK_UN 2 -# define LOCK_SH 4 -# define LOCK_NB 8 - -static int flock (int fd, int operation) -{ - long pos, len; - int ret, err; - - /* Disable invalid arguments. */ - if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) || - ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) || - ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN))) - { - errno = EINVAL; - return -1; - } - - /* Determine mode of operation and discard unsupported ones. */ - if (operation == (LOCK_NB | LOCK_EX)) - operation = _LK_NBLCK; - else if (operation & LOCK_UN) - operation = _LK_UNLCK; - else if (operation == LOCK_EX) - operation = _LK_LOCK; - else - { - errno = EINVAL; - return -1; - } - - /* Save current file pointer and seek to beginning. */ - if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1) - return -1; - lseek (fd, 0L, SEEK_SET); - - /* Deadlock if necessary. */ - do - { - ret = _locking (fd, operation, len); - } - while (ret == -1 && errno == EDEADLOCK); - - /* Produce meaningful error message. */ - if (errno == EACCES && operation == _LK_NBLCK) - err = EDEADLOCK; - else - err = errno; - - /* Return to saved file position pointer. */ - lseek (fd, pos, SEEK_SET); - errno = err; - return ret; -} -#endif /* __MINGW32__ */ - -#if HAVE_FLOCK || defined (__MINGW32__) SCM_DEFINE (scm_flock, "flock", 2, 0, 0, (SCM file, SCM operation), "Apply or remove an advisory lock on an open file.\n" @@ -2009,7 +1940,6 @@ SCM_DEFINE (scm_flock, "flock", 2, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif /* HAVE_FLOCK */ #if HAVE_SETHOSTNAME SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0, From 47c8983f08157865a3937722c06acbbb3cbd7621 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 13:49:00 +0200 Subject: [PATCH 137/375] rewrite `method' as a hygienic macro to re-allow lexical specializers * module/oop/goops.scm (method): Reimplement as a hygienic macro. This seriously took me like 6 hours to figure out. Allows for lexical specializers: (let (( ...)) (define-method (foo (arg )) ...)). * module/oop/goops/compile.scm (next-method?, compile-make-procedure): Remove these, as `method' does it all now, hygienically. --- module/oop/goops.scm | 134 ++++++++++++++++++++++++++--------- module/oop/goops/compile.scm | 32 +-------- 2 files changed, 101 insertions(+), 65 deletions(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index d7220d470..8c980485f 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -477,41 +477,105 @@ (toplevel-define! 'name (make #:name 'name))) (add-method! name (method args body ...)))))) -(define-macro (method args . body) - (letrec ((specializers - (lambda (ls) - (cond ((null? ls) (list (list 'quote '()))) - ((pair? ls) (cons (if (pair? (car ls)) - (cadar ls) - ') - (specializers (cdr ls)))) - (else '())))) - (formals - (lambda (ls) - (if (pair? ls) - (cons (if (pair? (car ls)) (caar ls) (car ls)) - (formals (cdr ls))) - ls)))) - (let ((make-proc (compile-make-procedure (formals args) - (specializers args) - body))) - `(make - #:specializers (cons* ,@(specializers args)) - #:formals ',(formals args) - #:body ',body - #:make-procedure ,make-proc - #:procedure ,(and (not make-proc) - ;; that is to say: we set #:procedure if - ;; `compile-make-procedure' returned `#f', - ;; which is the case if `body' does not - ;; contain a call to `next-method' - `(lambda ,(formals args) - ,@(if (null? body) - ;; This used to be '((begin)), but - ;; guile's memoizer doesn't like - ;; (lambda args (begin)). - '((if #f #f)) - body))))))) +(define-syntax method + (lambda (x) + (define (compute-formals args) + (let lp ((ls args) (out '())) + (syntax-case ls () + (((f s) . rest) (lp (syntax rest) (cons (syntax f) out))) + ((f . rest) (identifier? (syntax f)) + (lp (syntax rest) (cons (syntax f) out))) + (() (reverse out)) + (tail (identifier? (syntax tail)) + (append (reverse out) (syntax tail)))))) + + (define (compute-specializers args) + (let lp ((ls args) (out '())) + (syntax-case ls () + (((f s) . rest) (lp (syntax rest) (cons (syntax s) out))) + ((f . rest) (lp (syntax rest) (cons (syntax ) out))) + (() (reverse (cons (syntax '()) out))) + (tail (reverse (cons (syntax ) out)))))) + + (define (find-free-id exp referent) + (syntax-case exp () + ((x . y) + (or (find-free-id (syntax x) referent) + (find-free-id (syntax y) referent))) + (x + (identifier? (syntax x)) + (let ((id (datum->syntax (syntax x) referent))) + (and (free-identifier=? (syntax x) id) id))) + (_ #f))) + + (define (compute-procedure formals body) + (syntax-case body () + ((body0 ...) + (with-syntax ((formals formals)) + (syntax (lambda formals body0 ...)))))) + + (define (->proper args) + (let lp ((ls args) (out '())) + (syntax-case ls () + ((x . xs) (lp (syntax xs) (cons (syntax x) out))) + (() (reverse out)) + (tail (reverse (cons (syntax tail) out)))))) + + (define (compute-make-procedure formals body next-method) + (syntax-case body () + ((body ...) + (with-syntax ((next-method next-method)) + (syntax-case formals () + ((formal ...) + (syntax + (lambda (real-next-method) + (lambda (formal ...) + (let ((next-method (lambda args + (if (null? args) + (real-next-method formal ...) + (apply real-next-method args))))) + body ...))))) + (formals + (with-syntax (((formal ...) (->proper (syntax formals)))) + (syntax + (lambda (real-next-method) + (lambda formals + (let ((next-method (lambda args + (if (null? args) + (apply real-next-method formal ...) + (apply real-next-method args))))) + body ...))))))))))) + + (define (compute-procedures formals body) + ;; So, our use of this is broken, because it operates on the + ;; pre-expansion source code. It's equivalent to just searching + ;; for referent in the datums. Ah well. + (let ((id (find-free-id body 'next-method))) + (if id + ;; return a make-procedure + (values (syntax #f) + (compute-make-procedure formals body id)) + (values (compute-procedure formals body) + (syntax #f))))) + + (syntax-case x () + ((_ args) (syntax (method args (if #f #f)))) + ((_ args body0 body1 ...) + (with-syntax ((formals (compute-formals (syntax args))) + ((specializer ...) (compute-specializers (syntax args)))) + (call-with-values + (lambda () + (compute-procedures (syntax formals) (syntax (body0 body1 ...)))) + (lambda (procedure make-procedure) + (with-syntax ((procedure procedure) + (make-procedure make-procedure)) + (syntax + (make + #:specializers (cons* specializer ...) + #:formals 'formals + #:body '(body0 body1 ...) + #:make-procedure make-procedure + #:procedure procedure)))))))))) ;;; ;;; {add-method!} diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm index 3962be4bc..e6b13c416 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -24,7 +24,7 @@ (define-module (oop goops compile) :use-module (oop goops) :use-module (oop goops util) - :export (compute-cmethod compile-make-procedure) + :export (compute-cmethod) :no-backtrace ) @@ -60,9 +60,7 @@ ;;; So, for the reader: there basic idea is that, given that the ;;; semantics of `next-method' depend on the concrete types being ;;; dispatched, why not compile a specific procedure to handle each type -;;; combination that we see at runtime. There are two compilation -;;; strategies implemented: one for the memoizer, and one for the VM -;;; compiler. +;;; combination that we see at runtime. ;;; ;;; In theory we can do much better than a bytecode compilation, because ;;; we know the *exact* types of the arguments. It's ideal for native @@ -71,32 +69,6 @@ ;;; I think this whole generic application mess would benefit from a ;;; strict MOP. -;;; Temporary solution---return #f if x doesn't refer to `next-method'. -(define (next-method? x) - (and (pair? x) - (or (eq? (car x) 'next-method) - (next-method? (car x)) - (next-method? (cdr x))))) - -;; Called by the `method' macro in goops.scm. -(define (compile-make-procedure formals specializers body) - (and (next-method? body) - (let ((next-method-sym (gensym " next-method")) - (args-sym (gensym))) - `(lambda (,next-method-sym) - (lambda ,formals - (let ((next-method (lambda ,args-sym - (if (null? ,args-sym) - ,(if (list? formals) - `(,next-method-sym ,@formals) - `(apply - ,next-method-sym - ,@(improper->proper formals))) - (apply ,next-method-sym ,args-sym))))) - ,@(if (null? body) - '((begin)) - body))))))) - (define (compile-method methods types) (let ((make-procedure (slot-ref (car methods) 'make-procedure))) (if make-procedure From d63927150aa22bb7e57125ed50e5ecbe11765fba Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 15:34:29 +0200 Subject: [PATCH 138/375] just parse method arguments once. * module/oop/goops.scm (method): Tweak to just run through the arguments once. Thanks to Eli Barzilay for the tip. --- module/oop/goops.scm | 38 ++++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 8c980485f..fd2d60058 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -479,23 +479,26 @@ (define-syntax method (lambda (x) - (define (compute-formals args) - (let lp ((ls args) (out '())) + (define (parse-args args) + (let lp ((ls args) (formals '()) (specializers '())) (syntax-case ls () - (((f s) . rest) (lp (syntax rest) (cons (syntax f) out))) - ((f . rest) (identifier? (syntax f)) - (lp (syntax rest) (cons (syntax f) out))) - (() (reverse out)) - (tail (identifier? (syntax tail)) - (append (reverse out) (syntax tail)))))) - - (define (compute-specializers args) - (let lp ((ls args) (out '())) - (syntax-case ls () - (((f s) . rest) (lp (syntax rest) (cons (syntax s) out))) - ((f . rest) (lp (syntax rest) (cons (syntax ) out))) - (() (reverse (cons (syntax '()) out))) - (tail (reverse (cons (syntax ) out)))))) + (((f s) . rest) + (and (identifier? (syntax f)) (identifier? (syntax s))) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax s) specializers))) + ((f . rest) + (identifier? (syntax f)) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax ) specializers))) + (() + (list (reverse formals) + (reverse (cons (syntax '()) specializers)))) + (tail + (identifier? (syntax tail)) + (list (append (reverse formals) (syntax tail)) + (reverse (cons (syntax ) specializers))))))) (define (find-free-id exp referent) (syntax-case exp () @@ -561,8 +564,7 @@ (syntax-case x () ((_ args) (syntax (method args (if #f #f)))) ((_ args body0 body1 ...) - (with-syntax ((formals (compute-formals (syntax args))) - ((specializer ...) (compute-specializers (syntax args)))) + (with-syntax (((formals (specializer ...)) (parse-args (syntax args)))) (call-with-values (lambda () (compute-procedures (syntax formals) (syntax (body0 body1 ...)))) From a48358b38fed9486cebf7f8338dc05adc770fc0f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 16:04:14 +0200 Subject: [PATCH 139/375] fix srfi-17.test * test-suite/tests/srfi-17.test (exception:bad-quote): Change the expected exception for (set! (quote foo) ...) errors. --- test-suite/tests/srfi-17.test | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index fbacb15a3..4841f2ef1 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -50,6 +50,9 @@ (define %some-variable #f) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) + (with-test-prefix "set!" (with-test-prefix "target is not procedure with setter" @@ -59,7 +62,7 @@ (set! (symbol->string 'x) 1)) (pass-if-exception "(set! '#f 1)" - exception:bad-variable + exception:bad-quote (eval '(set! '#f 1) (interaction-environment)))) (with-test-prefix "target uses macro" @@ -72,7 +75,7 @@ ;; The `(quote x)' below used to be memoized as an infinite list before ;; Guile 1.8.3. (pass-if-exception "(set! 'x 1)" - exception:bad-variable + exception:bad-quote (eval '(set! 'x 1) (interaction-environment))))) ;; From 30a5e062d022aafdb72cea648f3a4de0e72feb6d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 17:22:58 +0200 Subject: [PATCH 140/375] procedures in "drop" contexts can return unspecified values * module/language/tree-il/compile-glil.scm (flatten): For applications in "drop" context, allow the procedure to return unspecified values (including 0 values). * test-suite/tests/tree-il.test ("application"): Adapt test. * module/srfi/srfi-18.scm (wrap): Clarify. * test-suite/tests/srfi-18.test: Fix so that the expression importing srfi-18 is expanded before the tests. However the tests are still failing, something about 0-valued returns... --- module/language/tree-il/compile-glil.scm | 9 +++++++-- module/srfi/srfi-18.scm | 4 ++-- test-suite/tests/srfi-18.test | 9 +++++++-- test-suite/tests/tree-il.test | 8 +++++--- 4 files changed, 21 insertions(+), 9 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 226b7d402..d5073ed0f 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -272,8 +272,13 @@ (case context ((tail) (emit-code src (make-glil-call 'goto/args len))) ((push) (emit-code src (make-glil-call 'call len))) - ((drop) (emit-code src (make-glil-call 'call len)) - (emit-code src (make-glil-call 'drop 1)))))))) + ((drop) + (let ((MV (make-label))) + (emit-code src (make-glil-mv-call len MV)) + (emit-code #f (make-glil-const 1)) + (emit-label MV) + (emit-code #f (make-glil-mv-bind '() #f)) + (emit-code #f (make-glil-unbind))))))))) (( src test then else) ;; TEST diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 925ecb304..75f1088ab 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -249,8 +249,8 @@ (define (wrap thunk) (lambda (continuation) (with-exception-handler (lambda (obj) - (apply (current-exception-handler) (list obj)) - (apply continuation (list))) + ((current-exception-handler) obj) + (continuation)) thunk))) ;; A pass-thru to cancel-thread that first installs a handler that throws diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index fa309e6ce..3c7090643 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -21,8 +21,13 @@ (define-module (test-suite test-srfi-18) #:use-module (test-suite lib)) -(and (provided? 'threads) - (use-modules (srfi srfi-18)) +;; two expressions so that the srfi-18 import is in effect for expansion +;; of the rest +(if (provided? 'threads) + (use-modules (srfi srfi-18))) + +(and + (provided? 'threads) (with-test-prefix "current-thread" diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 873051f03..724ea7960 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -68,10 +68,12 @@ (assert-tree-il->glil (apply (toplevel foo) (const 1)) (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) - (assert-tree-il->glil + (assert-tree-il->glil/pmatch (begin (apply (toplevel foo) (const 1)) (void)) - (program 0 0 0 0 () (toplevel ref foo) (const 1) (call call 1) - (call drop 1) (void) (call return 1))) + (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) + (const 1) (label ,l2) (mv-bind () #f) (unbind) + (void) (call return 1)) + (eq? l1 l2)) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel bar))) (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) From 0f423f20aae6228431d3695e60ade937858110b8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 21:13:24 +0200 Subject: [PATCH 141/375] fix apply and call/cc in drop contexts * module/language/tree-il/compile-glil.scm (flatten): Actually apply only needs one arg after the proc. And shit, call/cc and apply in drop contexts also need to be able to return arbitrary numbers of values; work it by trampolining through their applicative (non-@) definitions. Also, simplify the single-valued drop case to avoid the truncate-values. * module/language/tree-il/inline.scm (call/cc): * module/language/tree-il/optimize.scm (*interesting-primitive-names*): Define call/cc as "interesting". Perhaps we should be hashing on value and not on variable. * test-suite/tests/tree-il.test ("application"): Fix up test for new, sleeker output. (Actually the GLIL is more verbose, but the assembly is better.) ("apply", "call/cc"): Add some more tests. --- module/language/tree-il/compile-glil.scm | 49 ++++++++++++++++-------- module/language/tree-il/inline.scm | 3 ++ module/language/tree-il/optimize.scm | 1 + test-suite/tests/tree-il.test | 46 +++++++++++++++++++++- 4 files changed, 82 insertions(+), 17 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index d5073ed0f..d476ddef9 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -184,7 +184,7 @@ (cond ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@apply) - (>= (length args) 2)) + (>= (length args) 1)) (let ((proc (car args)) (args (cdr args))) (cond @@ -200,13 +200,23 @@ (emit-code src (make-glil-call 'return/values* (length args)))))) (else - (comp-push proc) - (for-each comp-push args) (case context - ((drop) (emit-code src (make-glil-call 'apply (1+ (length args)))) - (emit-code src (make-glil-call 'drop 1))) - ((tail) (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) - ((push) (emit-code src (make-glil-call 'apply (1+ (length args)))))))))) + ((tail) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) + ((push) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'apply (1+ (length args))))) + ((drop) + ;; Well, shit. The proc might return any number of + ;; values (including 0), since it's in a drop context, + ;; yet apply does not create a MV continuation. So we + ;; mv-call out to our trampoline instead. + (comp-drop + (make-application src (make-primitive-ref #f 'apply) + (cons proc args))))))))) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) (not (eq? context 'push))) @@ -248,12 +258,19 @@ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-current-continuation) (= (length args) 1)) - (comp-push (car args)) (case context - ((tail) (emit-code src (make-glil-call 'goto/cc 1))) - ((push) (emit-code src (make-glil-call 'call/cc 1))) - ((drop) (emit-code src (make-glil-call 'call/cc 1)) - (emit-code src (make-glil-call 'drop 1))))) + ((tail) + (comp-push (car args)) + (emit-code src (make-glil-call 'goto/cc 1))) + ((push) + (comp-push (car args)) + (emit-code src (make-glil-call 'call/cc 1))) + ((drop) + ;; Crap. Just like `apply' in drop context. + (comp-drop + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args))))) ((and (primitive-ref? proc) (or (hash-ref *primcall-ops* @@ -273,12 +290,14 @@ ((tail) (emit-code src (make-glil-call 'goto/args len))) ((push) (emit-code src (make-glil-call 'call len))) ((drop) - (let ((MV (make-label))) + (let ((MV (make-label)) (POST (make-label))) (emit-code src (make-glil-mv-call len MV)) - (emit-code #f (make-glil-const 1)) + (emit-code #f (make-glil-call 'drop 1)) + (emit-branch #f 'br POST) (emit-label MV) (emit-code #f (make-glil-mv-bind '() #f)) - (emit-code #f (make-glil-unbind))))))))) + (emit-code #f (make-glil-unbind)) + (emit-label POST)))))))) (( src test then else) ;; TEST diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index d0fa74fab..5a8e2db30 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -147,4 +147,7 @@ (define-primitive-expander call-with-current-continuation (proc) (@call-with-current-continuation proc)) +(define-primitive-expander call/cc (proc) + (@call-with-current-continuation proc)) + (define-primitive-expander values (x) x) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 4f177a979..9ba384f4f 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -45,6 +45,7 @@ '(apply @apply call-with-values @call-with-values call-with-current-continuation @call-with-current-continuation + call/cc values eq? eqv? equal? = < > <= >= zero? diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 724ea7960..eb33ae77f 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -71,9 +71,11 @@ (assert-tree-il->glil/pmatch (begin (apply (toplevel foo) (const 1)) (void)) (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) - (const 1) (label ,l2) (mv-bind () #f) (unbind) + (call drop 1) (branch br ,l2) + (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) (void) (call return 1)) - (eq? l1 l2)) + (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel bar))) (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) @@ -415,3 +417,43 @@ (unbind) (unbind)) (eq? l1 l2))) + +(with-test-prefix "apply" + (assert-tree-il->glil + (apply (primitive @apply) (toplevel foo) (toplevel bar)) + (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) + (program 0 0 0 0 () + (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) + (program 0 0 0 0 () + (toplevel ref foo) + (toplevel ref bar) (toplevel ref baz) (call apply 2) + (call goto/args 1)))) + +(with-test-prefix "call/cc" + (assert-tree-il->glil + (apply (primitive @call-with-current-continuation) (toplevel foo)) + (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) + (program 0 0 0 0 () + (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) + (apply (toplevel @call-with-current-continuation) (toplevel bar))) + (program 0 0 0 0 () + (toplevel ref foo) + (toplevel ref bar) (call call/cc 1) + (call goto/args 1)))) + From 2032f3d1db09aa63de4ec060081a5bf9053f0d3c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 21:39:37 +0200 Subject: [PATCH 142/375] fix multiple values returning from srfi-18's `with-exception-handler' * module/srfi/srfi-18.scm (with-exception-handler): Hah! Fixed a scurrilous bug in which we assumed that the thunk returned one or more values. Hah. --- module/srfi/srfi-18.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 75f1088ab..dd92079be 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -151,8 +151,10 @@ (hashq-set! thread-exception-handlers ct hl) (handler obj)) (lambda () - (let ((r (thunk))) - (hashq-set! thread-exception-handlers ct hl) r)))))) + (call-with-values thunk + (lambda res + (hashq-set! thread-exception-handlers ct hl) + (apply values res)))))))) (define (current-exception-handler) (car (current-handler-stack))) From 40b36cfbbe4676f52bd4d6b45ae1642756642907 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 22:11:48 +0200 Subject: [PATCH 143/375] catch syntax errors in unquote and unquote-splicing * module/ice-9/psyntax.scm (quasiquote): Catch syntax errors in unquote and unquote-splicing. * module/ice-9/psytax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 10 ++++++++++ test-suite/tests/syntax.test | 11 ++++++++--- 3 files changed, 29 insertions(+), 14 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 062b86022..5b646d870 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*2008 (lambda (f2048 first2047 . rest2046) (let ((t2049 (null? first2047))) (if t2049 t2049 (if (null? rest2046) (letrec ((andmap2050 (lambda (first2051) (let ((x2052 (car first2051)) (first2053 (cdr first2051))) (if (null? first2053) (f2048 x2052) (if (f2048 x2052) (andmap2050 first2053) #f)))))) (andmap2050 first2047)) (letrec ((andmap2054 (lambda (first2055 rest2056) (let ((x2057 (car first2055)) (xr2058 (map car rest2056)) (first2059 (cdr first2055)) (rest2060 (map cdr rest2056))) (if (null? first2059) (apply f2048 (cons x2057 xr2058)) (if (apply f2048 (cons x2057 xr2058)) (andmap2054 first2059 rest2060) #f)))))) (andmap2054 first2047 rest2046)))))))) (letrec ((lambda-var-list2153 (lambda (vars2282) (letrec ((lvl2283 (lambda (vars2284 ls2285 w2286) (if (pair? vars2284) (lvl2283 (cdr vars2284) (cons (wrap2132 (car vars2284) w2286 #f) ls2285) w2286) (if (id?2104 vars2284) (cons (wrap2132 vars2284 w2286 #f) ls2285) (if (null? vars2284) ls2285 (if (syntax-object?2088 vars2284) (lvl2283 (syntax-object-expression2089 vars2284) ls2285 (join-wraps2123 w2286 (syntax-object-wrap2090 vars2284))) (if (annotation? vars2284) (lvl2283 (annotation-expression vars2284) ls2285 w2286) (cons vars2284 ls2285))))))))) (lvl2283 vars2282 (quote ()) (quote (())))))) (gen-var2152 (lambda (id2287) (let ((id2288 (if (syntax-object?2088 id2287) (syntax-object-expression2089 id2287) id2287))) (if (annotation? id2288) (gensym (symbol->string (annotation-expression id2288))) (gensym (symbol->string id2288)))))) (strip2151 (lambda (x2289 w2290) (if (memq (quote top) (wrap-marks2107 w2290)) (if (let ((t2291 (annotation? x2289))) (if t2291 t2291 (if (pair? x2289) (annotation? (car x2289)) #f))) (strip-annotation2150 x2289 #f) x2289) (letrec ((f2292 (lambda (x2293) (if (syntax-object?2088 x2293) (strip2151 (syntax-object-expression2089 x2293) (syntax-object-wrap2090 x2293)) (if (pair? x2293) (let ((a2294 (f2292 (car x2293))) (d2295 (f2292 (cdr x2293)))) (if (if (eq? a2294 (car x2293)) (eq? d2295 (cdr x2293)) #f) x2293 (cons a2294 d2295))) (if (vector? x2293) (let ((old2296 (vector->list x2293))) (let ((new2297 (map f2292 old2296))) (if (and-map*2008 eq? old2296 new2297) x2293 (list->vector new2297)))) x2293)))))) (f2292 x2289))))) (strip-annotation2150 (lambda (x2298 parent2299) (if (pair? x2298) (let ((new2300 (cons #f #f))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2300) (if #f #f)) (set-car! new2300 (strip-annotation2150 (car x2298) #f)) (set-cdr! new2300 (strip-annotation2150 (cdr x2298) #f)) new2300)) (if (annotation? x2298) (let ((t2301 (annotation-stripped x2298))) (if t2301 t2301 (strip-annotation2150 (annotation-expression x2298) x2298))) (if (vector? x2298) (let ((new2302 (make-vector (vector-length x2298)))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2302) (if #f #f)) (letrec ((loop2303 (lambda (i2304) (unless (fx<2066 i2304 0) (vector-set! new2302 i2304 (strip-annotation2150 (vector-ref x2298 i2304) #f)) (loop2303 (fx-2064 i2304 1)))))) (loop2303 (- (vector-length x2298) 1))) new2302)) x2298))))) (ellipsis?2149 (lambda (x2305) (if (nonsymbol-id?2103 x2305) (free-id=?2127 x2305 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void2148 (lambda () (build-void2071 #f))) (eval-local-transformer2147 (lambda (expanded2306 mod2307) (let ((p2308 (local-eval-hook2068 expanded2306 mod2307))) (if (procedure? p2308) p2308 (syntax-violation #f "nonprocedure transformer" p2308))))) (chi-local-syntax2146 (lambda (rec?2309 e2310 r2311 w2312 s2313 mod2314 k2315) ((lambda (tmp2316) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 id2319 val2320 e12321 e22322) (let ((ids2323 id2319)) (if (not (valid-bound-ids?2129 ids2323)) (syntax-violation #f "duplicate bound keyword" e2310) (let ((labels2325 (gen-labels2110 ids2323))) (let ((new-w2326 (make-binding-wrap2121 ids2323 labels2325 w2312))) (k2315 (cons e12321 e22322) (extend-env2098 labels2325 (let ((w2328 (if rec?2309 new-w2326 w2312)) (trans-r2329 (macros-only-env2100 r2311))) (map (lambda (x2330) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2330 trans-r2329 w2328 mod2314) mod2314))) val2320)) r2311) new-w2326 s2313 mod2314)))))) tmp2317) ((lambda (_2332) (syntax-violation #f "bad local syntax definition" (source-wrap2133 e2310 w2312 s2313 mod2314))) tmp2316))) ($sc-dispatch tmp2316 (quote (any #(each (any any)) any . each-any))))) e2310))) (chi-lambda-clause2145 (lambda (e2333 docstring2334 c2335 r2336 w2337 mod2338 k2339) ((lambda (tmp2340) ((lambda (tmp2341) (if (if tmp2341 (apply (lambda (args2342 doc2343 e12344 e22345) (if (string? (syntax->datum doc2343)) (not docstring2334) #f)) tmp2341) #f) (apply (lambda (args2346 doc2347 e12348 e22349) (chi-lambda-clause2145 e2333 doc2347 (cons args2346 (cons e12348 e22349)) r2336 w2337 mod2338 k2339)) tmp2341) ((lambda (tmp2351) (if tmp2351 (apply (lambda (id2352 e12353 e22354) (let ((ids2355 id2352)) (if (not (valid-bound-ids?2129 ids2355)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2357 (gen-labels2110 ids2355)) (new-vars2358 (map gen-var2152 ids2355))) (k2339 (map syntax->datum ids2355) new-vars2358 (if docstring2334 (syntax->datum docstring2334) #f) (chi-body2144 (cons e12353 e22354) e2333 (extend-var-env2099 labels2357 new-vars2358 r2336) (make-binding-wrap2121 ids2355 labels2357 w2337) mod2338)))))) tmp2351) ((lambda (tmp2360) (if tmp2360 (apply (lambda (ids2361 e12362 e22363) (let ((old-ids2364 (lambda-var-list2153 ids2361))) (if (not (valid-bound-ids?2129 old-ids2364)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2365 (gen-labels2110 old-ids2364)) (new-vars2366 (map gen-var2152 old-ids2364))) (k2339 (letrec ((f2367 (lambda (ls12368 ls22369) (if (null? ls12368) (syntax->datum ls22369) (f2367 (cdr ls12368) (cons (syntax->datum (car ls12368)) ls22369)))))) (f2367 (cdr old-ids2364) (car old-ids2364))) (letrec ((f2370 (lambda (ls12371 ls22372) (if (null? ls12371) ls22372 (f2370 (cdr ls12371) (cons (car ls12371) ls22372)))))) (f2370 (cdr new-vars2366) (car new-vars2366))) (if docstring2334 (syntax->datum docstring2334) #f) (chi-body2144 (cons e12362 e22363) e2333 (extend-var-env2099 labels2365 new-vars2366 r2336) (make-binding-wrap2121 old-ids2364 labels2365 w2337) mod2338)))))) tmp2360) ((lambda (_2374) (syntax-violation (quote lambda) "bad lambda" e2333)) tmp2340))) ($sc-dispatch tmp2340 (quote (any any . each-any)))))) ($sc-dispatch tmp2340 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2340 (quote (any any any . each-any))))) c2335))) (chi-body2144 (lambda (body2375 outer-form2376 r2377 w2378 mod2379) (let ((r2380 (cons (quote ("placeholder" placeholder)) r2377))) (let ((ribcage2381 (make-ribcage2111 (quote ()) (quote ()) (quote ())))) (let ((w2382 (make-wrap2106 (wrap-marks2107 w2378) (cons ribcage2381 (wrap-subst2108 w2378))))) (letrec ((parse2383 (lambda (body2384 ids2385 labels2386 vars2387 vals2388 bindings2389) (if (null? body2384) (syntax-violation #f "no expressions in body" outer-form2376) (let ((e2391 (cdar body2384)) (er2392 (caar body2384))) (call-with-values (lambda () (syntax-type2138 e2391 er2392 (quote (())) #f ribcage2381 mod2379)) (lambda (type2393 value2394 e2395 w2396 s2397 mod2398) (if (memv type2393 (quote (define-form))) (let ((id2399 (wrap2132 value2394 w2396 mod2398)) (label2400 (gen-label2109))) (let ((var2401 (gen-var2152 id2399))) (begin (extend-ribcage!2120 ribcage2381 id2399 label2400) (parse2383 (cdr body2384) (cons id2399 ids2385) (cons label2400 labels2386) (cons var2401 vars2387) (cons (cons er2392 (wrap2132 e2395 w2396 mod2398)) vals2388) (cons (cons (quote lexical) var2401) bindings2389))))) (if (memv type2393 (quote (define-syntax-form))) (let ((id2402 (wrap2132 value2394 w2396 mod2398)) (label2403 (gen-label2109))) (begin (extend-ribcage!2120 ribcage2381 id2402 label2403) (parse2383 (cdr body2384) (cons id2402 ids2385) (cons label2403 labels2386) vars2387 vals2388 (cons (cons (quote macro) (cons er2392 (wrap2132 e2395 w2396 mod2398))) bindings2389)))) (if (memv type2393 (quote (begin-form))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 e12407) (parse2383 (letrec ((f2408 (lambda (forms2409) (if (null? forms2409) (cdr body2384) (cons (cons er2392 (wrap2132 (car forms2409) w2396 mod2398)) (f2408 (cdr forms2409))))))) (f2408 e12407)) ids2385 labels2386 vars2387 vals2388 bindings2389)) tmp2405) (syntax-violation #f "Source expression failed to match any pattern" tmp2404))) ($sc-dispatch tmp2404 (quote (any . each-any))))) e2395) (if (memv type2393 (quote (local-syntax-form))) (chi-local-syntax2146 value2394 e2395 er2392 w2396 s2397 mod2398 (lambda (forms2411 er2412 w2413 s2414 mod2415) (parse2383 (letrec ((f2416 (lambda (forms2417) (if (null? forms2417) (cdr body2384) (cons (cons er2412 (wrap2132 (car forms2417) w2413 mod2415)) (f2416 (cdr forms2417))))))) (f2416 forms2411)) ids2385 labels2386 vars2387 vals2388 bindings2389))) (if (null? ids2385) (build-sequence2083 #f (map (lambda (x2418) (chi2140 (cdr x2418) (car x2418) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))) (begin (if (not (valid-bound-ids?2129 ids2385)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form2376) (if #f #f)) (letrec ((loop2419 (lambda (bs2420 er-cache2421 r-cache2422) (if (not (null? bs2420)) (let ((b2423 (car bs2420))) (if (eq? (car b2423) (quote macro)) (let ((er2424 (cadr b2423))) (let ((r-cache2425 (if (eq? er2424 er-cache2421) r-cache2422 (macros-only-env2100 er2424)))) (begin (set-cdr! b2423 (eval-local-transformer2147 (chi2140 (cddr b2423) r-cache2425 (quote (())) mod2398) mod2398)) (loop2419 (cdr bs2420) er2424 r-cache2425)))) (loop2419 (cdr bs2420) er-cache2421 r-cache2422))) (if #f #f))))) (loop2419 bindings2389 #f #f)) (set-cdr! r2380 (extend-env2098 labels2386 bindings2389 (cdr r2380))) (build-letrec2086 #f (map syntax->datum ids2385) vars2387 (map (lambda (x2426) (chi2140 (cdr x2426) (car x2426) (quote (())) mod2398)) vals2388) (build-sequence2083 #f (map (lambda (x2427) (chi2140 (cdr x2427) (car x2427) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))))))))))))))))) (parse2383 (map (lambda (x2390) (cons r2380 (wrap2132 x2390 w2382 mod2379))) body2375) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro2143 (lambda (p2428 e2429 r2430 w2431 rib2432 mod2433) (letrec ((rebuild-macro-output2434 (lambda (x2435 m2436) (if (pair? x2435) (cons (rebuild-macro-output2434 (car x2435) m2436) (rebuild-macro-output2434 (cdr x2435) m2436)) (if (syntax-object?2088 x2435) (let ((w2437 (syntax-object-wrap2090 x2435))) (let ((ms2438 (wrap-marks2107 w2437)) (s2439 (wrap-subst2108 w2437))) (if (if (pair? ms2438) (eq? (car ms2438) #f) #f) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cdr ms2438) (if rib2432 (cons rib2432 (cdr s2439)) (cdr s2439))) (syntax-object-module2091 x2435)) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cons m2436 ms2438) (if rib2432 (cons rib2432 (cons (quote shift) s2439)) (cons (quote shift) s2439))) (let ((pmod2440 (procedure-module p2428))) (if pmod2440 (cons (quote hygiene) (module-name pmod2440)) (quote (hygiene guile)))))))) (if (vector? x2435) (let ((n2441 (vector-length x2435))) (let ((v2442 (make-vector n2441))) (letrec ((loop2443 (lambda (i2444) (if (fx=2065 i2444 n2441) (begin (if #f #f (if #f #f)) v2442) (begin (vector-set! v2442 i2444 (rebuild-macro-output2434 (vector-ref x2435 i2444) m2436)) (loop2443 (fx+2063 i2444 1))))))) (loop2443 0)))) (if (symbol? x2435) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap2133 e2429 w2431 s mod2433) x2435) x2435))))))) (rebuild-macro-output2434 (p2428 (wrap2132 e2429 (anti-mark2119 w2431) mod2433)) (string #\m))))) (chi-application2142 (lambda (x2445 e2446 r2447 w2448 s2449 mod2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (e02453 e12454) (build-application2072 s2449 x2445 (map (lambda (e2455) (chi2140 e2455 r2447 w2448 mod2450)) e12454))) tmp2452) (syntax-violation #f "Source expression failed to match any pattern" tmp2451))) ($sc-dispatch tmp2451 (quote (any . each-any))))) e2446))) (chi-expr2141 (lambda (type2457 value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (lexical))) (build-lexical-reference2074 (quote value) s2462 e2459 value2458) (if (memv type2457 (quote (core external-macro))) (value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (module-ref))) (call-with-values (lambda () (value2458 e2459)) (lambda (id2464 mod2465) (build-global-reference2077 s2462 id2464 mod2465))) (if (memv type2457 (quote (lexical-call))) (chi-application2142 (build-lexical-reference2074 (quote fun) (source-annotation2095 (car e2459)) (car e2459) value2458) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (global-call))) (chi-application2142 (build-global-reference2077 (source-annotation2095 (car e2459)) value2458 (if (syntax-object?2088 (car e2459)) (syntax-object-module2091 (car e2459)) mod2463)) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (constant))) (build-data2082 s2462 (strip2151 (source-wrap2133 e2459 w2461 s2462 mod2463) (quote (())))) (if (memv type2457 (quote (global))) (build-global-reference2077 s2462 value2458 mod2463) (if (memv type2457 (quote (call))) (chi-application2142 (chi2140 (car e2459) r2460 w2461 mod2463) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (begin-form))) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 e12469 e22470) (chi-sequence2134 (cons e12469 e22470) r2460 w2461 s2462 mod2463)) tmp2467) (syntax-violation #f "Source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any any . each-any))))) e2459) (if (memv type2457 (quote (local-syntax-form))) (chi-local-syntax2146 value2458 e2459 r2460 w2461 s2462 mod2463 chi-sequence2134) (if (memv type2457 (quote (eval-when-form))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (_2474 x2475 e12476 e22477) (let ((when-list2478 (chi-when-list2137 e2459 x2475 w2461))) (if (memq (quote eval) when-list2478) (chi-sequence2134 (cons e12476 e22477) r2460 w2461 s2462 mod2463) (chi-void2148)))) tmp2473) (syntax-violation #f "Source expression failed to match any pattern" tmp2472))) ($sc-dispatch tmp2472 (quote (any each-any any . each-any))))) e2459) (if (memv type2457 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e2459 (wrap2132 value2458 w2461 mod2463)) (if (memv type2457 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap2133 e2459 w2461 s2462 mod2463)) (if (memv type2457 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap2133 e2459 w2461 s2462 mod2463)) (syntax-violation #f "unexpected syntax" (source-wrap2133 e2459 w2461 s2462 mod2463)))))))))))))))))) (chi2140 (lambda (e2481 r2482 w2483 mod2484) (call-with-values (lambda () (syntax-type2138 e2481 r2482 w2483 #f #f mod2484)) (lambda (type2485 value2486 e2487 w2488 s2489 mod2490) (chi-expr2141 type2485 value2486 e2487 r2482 w2488 s2489 mod2490))))) (chi-top2139 (lambda (e2491 r2492 w2493 m2494 esew2495 mod2496) (call-with-values (lambda () (syntax-type2138 e2491 r2492 w2493 #f #f mod2496)) (lambda (type2504 value2505 e2506 w2507 s2508 mod2509) (if (memv type2504 (quote (begin-form))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (_2512) (chi-void2148)) tmp2511) ((lambda (tmp2513) (if tmp2513 (apply (lambda (_2514 e12515 e22516) (chi-top-sequence2135 (cons e12515 e22516) r2492 w2507 s2508 m2494 esew2495 mod2509)) tmp2513) (syntax-violation #f "Source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote (any any . each-any)))))) ($sc-dispatch tmp2510 (quote (any))))) e2506) (if (memv type2504 (quote (local-syntax-form))) (chi-local-syntax2146 value2505 e2506 r2492 w2507 s2508 mod2509 (lambda (body2518 r2519 w2520 s2521 mod2522) (chi-top-sequence2135 body2518 r2519 w2520 s2521 m2494 esew2495 mod2522))) (if (memv type2504 (quote (eval-when-form))) ((lambda (tmp2523) ((lambda (tmp2524) (if tmp2524 (apply (lambda (_2525 x2526 e12527 e22528) (let ((when-list2529 (chi-when-list2137 e2506 x2526 w2507)) (body2530 (cons e12527 e22528))) (if (eq? m2494 (quote e)) (if (memq (quote eval) when-list2529) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) (chi-void2148)) (if (memq (quote load) when-list2529) (if (let ((t2533 (memq (quote compile) when-list2529))) (if t2533 t2533 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c&e) (quote (compile load)) mod2509) (if (memq m2494 (quote (c c&e))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c) (quote (load)) mod2509) (chi-void2148))) (if (let ((t2534 (memq (quote compile) when-list2529))) (if t2534 t2534 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (begin (top-level-eval-hook2067 (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) mod2509) (chi-void2148)) (chi-void2148)))))) tmp2524) (syntax-violation #f "Source expression failed to match any pattern" tmp2523))) ($sc-dispatch tmp2523 (quote (any each-any any . each-any))))) e2506) (if (memv type2504 (quote (define-syntax-form))) (let ((n2535 (id-var-name2126 value2505 w2507)) (r2536 (macros-only-env2100 r2492))) (if (memv m2494 (quote (c))) (if (memq (quote compile) esew2495) (let ((e2537 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2537 mod2509) (if (memq (quote load) esew2495) e2537 (chi-void2148)))) (if (memq (quote load) esew2495) (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) (chi-void2148))) (if (memv m2494 (quote (c&e))) (let ((e2538 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2538 mod2509) e2538)) (begin (if (memq (quote eval) esew2495) (top-level-eval-hook2067 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) mod2509) (if #f #f)) (chi-void2148))))) (if (memv type2504 (quote (define-form))) (let ((n2539 (id-var-name2126 value2505 w2507))) (let ((type2540 (binding-type2096 (lookup2101 n2539 r2492 mod2509)))) (if (memv type2540 (quote (global core macro module-ref))) (let ((x2541 (build-global-definition2079 s2508 n2539 (chi2140 e2506 r2492 w2507 mod2509)))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2541 mod2509) (if #f #f)) x2541)) (if (memv type2540 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e2506 (wrap2132 value2505 w2507 mod2509)) (syntax-violation #f "cannot define keyword at top level" e2506 (wrap2132 value2505 w2507 mod2509)))))) (let ((x2542 (chi-expr2141 type2504 value2505 e2506 r2492 w2507 s2508 mod2509))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2542 mod2509) (if #f #f)) x2542))))))))))) (syntax-type2138 (lambda (e2543 r2544 w2545 s2546 rib2547 mod2548) (if (symbol? e2543) (let ((n2549 (id-var-name2126 e2543 w2545))) (let ((b2550 (lookup2101 n2549 r2544 mod2548))) (let ((type2551 (binding-type2096 b2550))) (if (memv type2551 (quote (lexical))) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (global))) (values type2551 n2549 e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2550) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548))))))) (if (pair? e2543) (let ((first2552 (car e2543))) (if (id?2104 first2552) (let ((n2553 (id-var-name2126 first2552 w2545))) (let ((b2554 (lookup2101 n2553 r2544 (let ((t2555 (if (syntax-object?2088 first2552) (syntax-object-module2091 first2552) #f))) (if t2555 t2555 mod2548))))) (let ((type2556 (binding-type2096 b2554))) (if (memv type2556 (quote (lexical))) (values (quote lexical-call) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (global))) (values (quote global-call) n2553 e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2554) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (if (memv type2556 (quote (core external-macro module-ref))) (values type2556 (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (begin))) (values (quote begin-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (eval-when))) (values (quote eval-when-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (define))) ((lambda (tmp2557) ((lambda (tmp2558) (if (if tmp2558 (apply (lambda (_2559 name2560 val2561) (id?2104 name2560)) tmp2558) #f) (apply (lambda (_2562 name2563 val2564) (values (quote define-form) name2563 val2564 w2545 s2546 mod2548)) tmp2558) ((lambda (tmp2565) (if (if tmp2565 (apply (lambda (_2566 name2567 args2568 e12569 e22570) (if (id?2104 name2567) (valid-bound-ids?2129 (lambda-var-list2153 args2568)) #f)) tmp2565) #f) (apply (lambda (_2571 name2572 args2573 e12574 e22575) (values (quote define-form) (wrap2132 name2572 w2545 mod2548) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap2132 (cons args2573 (cons e12574 e22575)) w2545 mod2548)) (quote (())) s2546 mod2548)) tmp2565) ((lambda (tmp2577) (if (if tmp2577 (apply (lambda (_2578 name2579) (id?2104 name2579)) tmp2577) #f) (apply (lambda (_2580 name2581) (values (quote define-form) (wrap2132 name2581 w2545 mod2548) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2546 mod2548)) tmp2577) (syntax-violation #f "Source expression failed to match any pattern" tmp2557))) ($sc-dispatch tmp2557 (quote (any any)))))) ($sc-dispatch tmp2557 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2557 (quote (any any any))))) e2543) (if (memv type2556 (quote (define-syntax))) ((lambda (tmp2582) ((lambda (tmp2583) (if (if tmp2583 (apply (lambda (_2584 name2585 val2586) (id?2104 name2585)) tmp2583) #f) (apply (lambda (_2587 name2588 val2589) (values (quote define-syntax-form) name2588 val2589 w2545 s2546 mod2548)) tmp2583) (syntax-violation #f "Source expression failed to match any pattern" tmp2582))) ($sc-dispatch tmp2582 (quote (any any any))))) e2543) (values (quote call) #f e2543 w2545 s2546 mod2548))))))))))))) (values (quote call) #f e2543 w2545 s2546 mod2548))) (if (syntax-object?2088 e2543) (syntax-type2138 (syntax-object-expression2089 e2543) r2544 (join-wraps2123 w2545 (syntax-object-wrap2090 e2543)) #f rib2547 (let ((t2590 (syntax-object-module2091 e2543))) (if t2590 t2590 mod2548))) (if (annotation? e2543) (syntax-type2138 (annotation-expression e2543) r2544 w2545 (annotation-source e2543) rib2547 mod2548) (if (self-evaluating? e2543) (values (quote constant) #f e2543 w2545 s2546 mod2548) (values (quote other) #f e2543 w2545 s2546 mod2548)))))))) (chi-when-list2137 (lambda (e2591 when-list2592 w2593) (letrec ((f2594 (lambda (when-list2595 situations2596) (if (null? when-list2595) situations2596 (f2594 (cdr when-list2595) (cons (let ((x2597 (car when-list2595))) (if (free-id=?2127 x2597 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?2127 x2597 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?2127 x2597 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e2591 (wrap2132 x2597 w2593 #f)))))) situations2596)))))) (f2594 when-list2592 (quote ()))))) (chi-install-global2136 (lambda (name2598 e2599) (build-global-definition2079 #f name2598 (if (let ((v2600 (module-variable (current-module) name2598))) (if v2600 (if (variable-bound? v2600) (if (macro? (variable-ref v2600)) (not (eq? (macro-type (variable-ref v2600)) (quote syncase-macro))) #f) #f) #f)) (build-application2072 #f (build-primref2081 #f (quote make-extended-syncase-macro)) (list (build-application2072 #f (build-primref2081 #f (quote module-ref)) (list (build-application2072 #f (build-primref2081 #f (quote current-module)) (quote ())) (build-data2082 #f name2598))) (build-data2082 #f (quote macro)) e2599)) (build-application2072 #f (build-primref2081 #f (quote make-syncase-macro)) (list (build-data2082 #f (quote macro)) e2599)))))) (chi-top-sequence2135 (lambda (body2601 r2602 w2603 s2604 m2605 esew2606 mod2607) (build-sequence2083 s2604 (letrec ((dobody2608 (lambda (body2609 r2610 w2611 m2612 esew2613 mod2614) (if (null? body2609) (quote ()) (let ((first2615 (chi-top2139 (car body2609) r2610 w2611 m2612 esew2613 mod2614))) (cons first2615 (dobody2608 (cdr body2609) r2610 w2611 m2612 esew2613 mod2614))))))) (dobody2608 body2601 r2602 w2603 m2605 esew2606 mod2607))))) (chi-sequence2134 (lambda (body2616 r2617 w2618 s2619 mod2620) (build-sequence2083 s2619 (letrec ((dobody2621 (lambda (body2622 r2623 w2624 mod2625) (if (null? body2622) (quote ()) (let ((first2626 (chi2140 (car body2622) r2623 w2624 mod2625))) (cons first2626 (dobody2621 (cdr body2622) r2623 w2624 mod2625))))))) (dobody2621 body2616 r2617 w2618 mod2620))))) (source-wrap2133 (lambda (x2627 w2628 s2629 defmod2630) (wrap2132 (if s2629 (make-annotation x2627 s2629 #f) x2627) w2628 defmod2630))) (wrap2132 (lambda (x2631 w2632 defmod2633) (if (if (null? (wrap-marks2107 w2632)) (null? (wrap-subst2108 w2632)) #f) x2631 (if (syntax-object?2088 x2631) (make-syntax-object2087 (syntax-object-expression2089 x2631) (join-wraps2123 w2632 (syntax-object-wrap2090 x2631)) (syntax-object-module2091 x2631)) (if (null? x2631) x2631 (make-syntax-object2087 x2631 w2632 defmod2633)))))) (bound-id-member?2131 (lambda (x2634 list2635) (if (not (null? list2635)) (let ((t2636 (bound-id=?2128 x2634 (car list2635)))) (if t2636 t2636 (bound-id-member?2131 x2634 (cdr list2635)))) #f))) (distinct-bound-ids?2130 (lambda (ids2637) (letrec ((distinct?2638 (lambda (ids2639) (let ((t2640 (null? ids2639))) (if t2640 t2640 (if (not (bound-id-member?2131 (car ids2639) (cdr ids2639))) (distinct?2638 (cdr ids2639)) #f)))))) (distinct?2638 ids2637)))) (valid-bound-ids?2129 (lambda (ids2641) (if (letrec ((all-ids?2642 (lambda (ids2643) (let ((t2644 (null? ids2643))) (if t2644 t2644 (if (id?2104 (car ids2643)) (all-ids?2642 (cdr ids2643)) #f)))))) (all-ids?2642 ids2641)) (distinct-bound-ids?2130 ids2641) #f))) (bound-id=?2128 (lambda (i2645 j2646) (if (if (syntax-object?2088 i2645) (syntax-object?2088 j2646) #f) (if (eq? (let ((e2647 (syntax-object-expression2089 i2645))) (if (annotation? e2647) (annotation-expression e2647) e2647)) (let ((e2648 (syntax-object-expression2089 j2646))) (if (annotation? e2648) (annotation-expression e2648) e2648))) (same-marks?2125 (wrap-marks2107 (syntax-object-wrap2090 i2645)) (wrap-marks2107 (syntax-object-wrap2090 j2646))) #f) (eq? (let ((e2649 i2645)) (if (annotation? e2649) (annotation-expression e2649) e2649)) (let ((e2650 j2646)) (if (annotation? e2650) (annotation-expression e2650) e2650)))))) (free-id=?2127 (lambda (i2651 j2652) (if (eq? (let ((x2653 i2651)) (let ((e2654 (if (syntax-object?2088 x2653) (syntax-object-expression2089 x2653) x2653))) (if (annotation? e2654) (annotation-expression e2654) e2654))) (let ((x2655 j2652)) (let ((e2656 (if (syntax-object?2088 x2655) (syntax-object-expression2089 x2655) x2655))) (if (annotation? e2656) (annotation-expression e2656) e2656)))) (eq? (id-var-name2126 i2651 (quote (()))) (id-var-name2126 j2652 (quote (())))) #f))) (id-var-name2126 (lambda (id2657 w2658) (letrec ((search-vector-rib2661 (lambda (sym2667 subst2668 marks2669 symnames2670 ribcage2671) (let ((n2672 (vector-length symnames2670))) (letrec ((f2673 (lambda (i2674) (if (fx=2065 i2674 n2672) (search2659 sym2667 (cdr subst2668) marks2669) (if (if (eq? (vector-ref symnames2670 i2674) sym2667) (same-marks?2125 marks2669 (vector-ref (ribcage-marks2114 ribcage2671) i2674)) #f) (values (vector-ref (ribcage-labels2115 ribcage2671) i2674) marks2669) (f2673 (fx+2063 i2674 1))))))) (f2673 0))))) (search-list-rib2660 (lambda (sym2675 subst2676 marks2677 symnames2678 ribcage2679) (letrec ((f2680 (lambda (symnames2681 i2682) (if (null? symnames2681) (search2659 sym2675 (cdr subst2676) marks2677) (if (if (eq? (car symnames2681) sym2675) (same-marks?2125 marks2677 (list-ref (ribcage-marks2114 ribcage2679) i2682)) #f) (values (list-ref (ribcage-labels2115 ribcage2679) i2682) marks2677) (f2680 (cdr symnames2681) (fx+2063 i2682 1))))))) (f2680 symnames2678 0)))) (search2659 (lambda (sym2683 subst2684 marks2685) (if (null? subst2684) (values #f marks2685) (let ((fst2686 (car subst2684))) (if (eq? fst2686 (quote shift)) (search2659 sym2683 (cdr subst2684) (cdr marks2685)) (let ((symnames2687 (ribcage-symnames2113 fst2686))) (if (vector? symnames2687) (search-vector-rib2661 sym2683 subst2684 marks2685 symnames2687 fst2686) (search-list-rib2660 sym2683 subst2684 marks2685 symnames2687 fst2686))))))))) (if (symbol? id2657) (let ((t2688 (call-with-values (lambda () (search2659 id2657 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2690 . ignore2689) x2690)))) (if t2688 t2688 id2657)) (if (syntax-object?2088 id2657) (let ((id2691 (let ((e2693 (syntax-object-expression2089 id2657))) (if (annotation? e2693) (annotation-expression e2693) e2693))) (w12692 (syntax-object-wrap2090 id2657))) (let ((marks2694 (join-marks2124 (wrap-marks2107 w2658) (wrap-marks2107 w12692)))) (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w2658) marks2694)) (lambda (new-id2695 marks2696) (let ((t2697 new-id2695)) (if t2697 t2697 (let ((t2698 (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w12692) marks2696)) (lambda (x2700 . ignore2699) x2700)))) (if t2698 t2698 id2691)))))))) (if (annotation? id2657) (let ((id2701 (let ((e2702 id2657)) (if (annotation? e2702) (annotation-expression e2702) e2702)))) (let ((t2703 (call-with-values (lambda () (search2659 id2701 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2705 . ignore2704) x2705)))) (if t2703 t2703 id2701))) (syntax-violation (quote id-var-name) "invalid id" id2657))))))) (same-marks?2125 (lambda (x2706 y2707) (let ((t2708 (eq? x2706 y2707))) (if t2708 t2708 (if (not (null? x2706)) (if (not (null? y2707)) (if (eq? (car x2706) (car y2707)) (same-marks?2125 (cdr x2706) (cdr y2707)) #f) #f) #f))))) (join-marks2124 (lambda (m12709 m22710) (smart-append2122 m12709 m22710))) (join-wraps2123 (lambda (w12711 w22712) (let ((m12713 (wrap-marks2107 w12711)) (s12714 (wrap-subst2108 w12711))) (if (null? m12713) (if (null? s12714) w22712 (make-wrap2106 (wrap-marks2107 w22712) (smart-append2122 s12714 (wrap-subst2108 w22712)))) (make-wrap2106 (smart-append2122 m12713 (wrap-marks2107 w22712)) (smart-append2122 s12714 (wrap-subst2108 w22712))))))) (smart-append2122 (lambda (m12715 m22716) (if (null? m22716) m12715 (append m12715 m22716)))) (make-binding-wrap2121 (lambda (ids2717 labels2718 w2719) (if (null? ids2717) w2719 (make-wrap2106 (wrap-marks2107 w2719) (cons (let ((labelvec2720 (list->vector labels2718))) (let ((n2721 (vector-length labelvec2720))) (let ((symnamevec2722 (make-vector n2721)) (marksvec2723 (make-vector n2721))) (begin (letrec ((f2724 (lambda (ids2725 i2726) (if (not (null? ids2725)) (call-with-values (lambda () (id-sym-name&marks2105 (car ids2725) w2719)) (lambda (symname2727 marks2728) (begin (vector-set! symnamevec2722 i2726 symname2727) (vector-set! marksvec2723 i2726 marks2728) (f2724 (cdr ids2725) (fx+2063 i2726 1))))) (if #f #f))))) (f2724 ids2717 0)) (make-ribcage2111 symnamevec2722 marksvec2723 labelvec2720))))) (wrap-subst2108 w2719)))))) (extend-ribcage!2120 (lambda (ribcage2729 id2730 label2731) (begin (set-ribcage-symnames!2116 ribcage2729 (cons (let ((e2732 (syntax-object-expression2089 id2730))) (if (annotation? e2732) (annotation-expression e2732) e2732)) (ribcage-symnames2113 ribcage2729))) (set-ribcage-marks!2117 ribcage2729 (cons (wrap-marks2107 (syntax-object-wrap2090 id2730)) (ribcage-marks2114 ribcage2729))) (set-ribcage-labels!2118 ribcage2729 (cons label2731 (ribcage-labels2115 ribcage2729)))))) (anti-mark2119 (lambda (w2733) (make-wrap2106 (cons #f (wrap-marks2107 w2733)) (cons (quote shift) (wrap-subst2108 w2733))))) (set-ribcage-labels!2118 (lambda (x2734 update2735) (vector-set! x2734 3 update2735))) (set-ribcage-marks!2117 (lambda (x2736 update2737) (vector-set! x2736 2 update2737))) (set-ribcage-symnames!2116 (lambda (x2738 update2739) (vector-set! x2738 1 update2739))) (ribcage-labels2115 (lambda (x2740) (vector-ref x2740 3))) (ribcage-marks2114 (lambda (x2741) (vector-ref x2741 2))) (ribcage-symnames2113 (lambda (x2742) (vector-ref x2742 1))) (ribcage?2112 (lambda (x2743) (if (vector? x2743) (if (= (vector-length x2743) 4) (eq? (vector-ref x2743 0) (quote ribcage)) #f) #f))) (make-ribcage2111 (lambda (symnames2744 marks2745 labels2746) (vector (quote ribcage) symnames2744 marks2745 labels2746))) (gen-labels2110 (lambda (ls2747) (if (null? ls2747) (quote ()) (cons (gen-label2109) (gen-labels2110 (cdr ls2747)))))) (gen-label2109 (lambda () (string #\i))) (wrap-subst2108 cdr) (wrap-marks2107 car) (make-wrap2106 cons) (id-sym-name&marks2105 (lambda (x2748 w2749) (if (syntax-object?2088 x2748) (values (let ((e2750 (syntax-object-expression2089 x2748))) (if (annotation? e2750) (annotation-expression e2750) e2750)) (join-marks2124 (wrap-marks2107 w2749) (wrap-marks2107 (syntax-object-wrap2090 x2748)))) (values (let ((e2751 x2748)) (if (annotation? e2751) (annotation-expression e2751) e2751)) (wrap-marks2107 w2749))))) (id?2104 (lambda (x2752) (if (symbol? x2752) #t (if (syntax-object?2088 x2752) (symbol? (let ((e2753 (syntax-object-expression2089 x2752))) (if (annotation? e2753) (annotation-expression e2753) e2753))) (if (annotation? x2752) (symbol? (annotation-expression x2752)) #f))))) (nonsymbol-id?2103 (lambda (x2754) (if (syntax-object?2088 x2754) (symbol? (let ((e2755 (syntax-object-expression2089 x2754))) (if (annotation? e2755) (annotation-expression e2755) e2755))) #f))) (global-extend2102 (lambda (type2756 sym2757 val2758) (put-global-definition-hook2069 sym2757 type2756 val2758))) (lookup2101 (lambda (x2759 r2760 mod2761) (let ((temp2762 (assq x2759 r2760))) (if temp2762 (cdr temp2762) (if (symbol? x2759) (let ((t2763 (get-global-definition-hook2070 x2759 mod2761))) (if t2763 t2763 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env2100 (lambda (r2764) (if (null? r2764) (quote ()) (let ((a2765 (car r2764))) (if (eq? (cadr a2765) (quote macro)) (cons a2765 (macros-only-env2100 (cdr r2764))) (macros-only-env2100 (cdr r2764))))))) (extend-var-env2099 (lambda (labels2766 vars2767 r2768) (if (null? labels2766) r2768 (extend-var-env2099 (cdr labels2766) (cdr vars2767) (cons (cons (car labels2766) (cons (quote lexical) (car vars2767))) r2768))))) (extend-env2098 (lambda (labels2769 bindings2770 r2771) (if (null? labels2769) r2771 (extend-env2098 (cdr labels2769) (cdr bindings2770) (cons (cons (car labels2769) (car bindings2770)) r2771))))) (binding-value2097 cdr) (binding-type2096 car) (source-annotation2095 (lambda (x2772) (if (annotation? x2772) (annotation-source x2772) (if (syntax-object?2088 x2772) (source-annotation2095 (syntax-object-expression2089 x2772)) #f)))) (set-syntax-object-module!2094 (lambda (x2773 update2774) (vector-set! x2773 3 update2774))) (set-syntax-object-wrap!2093 (lambda (x2775 update2776) (vector-set! x2775 2 update2776))) (set-syntax-object-expression!2092 (lambda (x2777 update2778) (vector-set! x2777 1 update2778))) (syntax-object-module2091 (lambda (x2779) (vector-ref x2779 3))) (syntax-object-wrap2090 (lambda (x2780) (vector-ref x2780 2))) (syntax-object-expression2089 (lambda (x2781) (vector-ref x2781 1))) (syntax-object?2088 (lambda (x2782) (if (vector? x2782) (if (= (vector-length x2782) 4) (eq? (vector-ref x2782 0) (quote syntax-object)) #f) #f))) (make-syntax-object2087 (lambda (expression2783 wrap2784 module2785) (vector (quote syntax-object) expression2783 wrap2784 module2785))) (build-letrec2086 (lambda (src2786 ids2787 vars2788 val-exps2789 body-exp2790) (if (null? vars2788) body-exp2790 (let ((atom-key2791 (fluid-ref *mode*2062))) (if (memv atom-key2791 (quote (c))) ((@ (language tree-il) make-letrec) src2786 ids2787 vars2788 val-exps2789 body-exp2790) (list (quote letrec) (map list vars2788 val-exps2789) body-exp2790)))))) (build-named-let2085 (lambda (src2792 ids2793 vars2794 val-exps2795 body-exp2796) (let ((f2797 (car vars2794)) (f-name2798 (car ids2793)) (vars2799 (cdr vars2794)) (ids2800 (cdr ids2793))) (let ((atom-key2801 (fluid-ref *mode*2062))) (if (memv atom-key2801 (quote (c))) ((@ (language tree-il) make-letrec) src2792 (list f-name2798) (list f2797) (list (build-lambda2080 src2792 ids2800 vars2799 #f body-exp2796)) (build-application2072 src2792 (build-lexical-reference2074 (quote fun) src2792 f-name2798 f2797) val-exps2795)) (list (quote let) f2797 (map list vars2799 val-exps2795) body-exp2796)))))) (build-let2084 (lambda (src2802 ids2803 vars2804 val-exps2805 body-exp2806) (if (null? vars2804) body-exp2806 (let ((atom-key2807 (fluid-ref *mode*2062))) (if (memv atom-key2807 (quote (c))) ((@ (language tree-il) make-let) src2802 ids2803 vars2804 val-exps2805 body-exp2806) (list (quote let) (map list vars2804 val-exps2805) body-exp2806)))))) (build-sequence2083 (lambda (src2808 exps2809) (if (null? (cdr exps2809)) (car exps2809) (let ((atom-key2810 (fluid-ref *mode*2062))) (if (memv atom-key2810 (quote (c))) ((@ (language tree-il) make-sequence) src2808 exps2809) (cons (quote begin) exps2809)))))) (build-data2082 (lambda (src2811 exp2812) (let ((atom-key2813 (fluid-ref *mode*2062))) (if (memv atom-key2813 (quote (c))) ((@ (language tree-il) make-const) src2811 exp2812) (if (if (self-evaluating? exp2812) (not (vector? exp2812)) #f) exp2812 (list (quote quote) exp2812)))))) (build-primref2081 (lambda (src2814 name2815) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2816 (fluid-ref *mode*2062))) (if (memv atom-key2816 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2814 name2815) name2815)) (let ((atom-key2817 (fluid-ref *mode*2062))) (if (memv atom-key2817 (quote (c))) ((@ (language tree-il) make-module-ref) src2814 (quote (guile)) name2815 #f) (list (quote @@) (quote (guile)) name2815)))))) (build-lambda2080 (lambda (src2818 ids2819 vars2820 docstring2821 exp2822) (let ((atom-key2823 (fluid-ref *mode*2062))) (if (memv atom-key2823 (quote (c))) ((@ (language tree-il) make-lambda) src2818 ids2819 vars2820 (if docstring2821 (list (cons (quote documentation) docstring2821)) (quote ())) exp2822) (cons (quote lambda) (cons vars2820 (append (if docstring2821 (list docstring2821) (quote ())) (list exp2822)))))))) (build-global-definition2079 (lambda (source2824 var2825 exp2826) (let ((atom-key2827 (fluid-ref *mode*2062))) (if (memv atom-key2827 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2824 var2825 exp2826) (list (quote define) var2825 exp2826))))) (build-global-assignment2078 (lambda (source2828 var2829 exp2830 mod2831) (analyze-variable2076 mod2831 var2829 (lambda (mod2832 var2833 public?2834) (let ((atom-key2835 (fluid-ref *mode*2062))) (if (memv atom-key2835 (quote (c))) ((@ (language tree-il) make-module-set) source2828 mod2832 var2833 public?2834 exp2830) (list (quote set!) (list (if public?2834 (quote @) (quote @@)) mod2832 var2833) exp2830)))) (lambda (var2836) (let ((atom-key2837 (fluid-ref *mode*2062))) (if (memv atom-key2837 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2828 var2836 exp2830) (list (quote set!) var2836 exp2830))))))) (build-global-reference2077 (lambda (source2838 var2839 mod2840) (analyze-variable2076 mod2840 var2839 (lambda (mod2841 var2842 public?2843) (let ((atom-key2844 (fluid-ref *mode*2062))) (if (memv atom-key2844 (quote (c))) ((@ (language tree-il) make-module-ref) source2838 mod2841 var2842 public?2843) (list (if public?2843 (quote @) (quote @@)) mod2841 var2842)))) (lambda (var2845) (let ((atom-key2846 (fluid-ref *mode*2062))) (if (memv atom-key2846 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2838 var2845) var2845)))))) (analyze-variable2076 (lambda (mod2847 var2848 modref-cont2849 bare-cont2850) (if (not mod2847) (bare-cont2850 var2848) (let ((kind2851 (car mod2847)) (mod2852 (cdr mod2847))) (if (memv kind2851 (quote (public))) (modref-cont2849 mod2852 var2848 #t) (if (memv kind2851 (quote (private))) (if (not (equal? mod2852 (module-name (current-module)))) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (if (memv kind2851 (quote (bare))) (bare-cont2850 var2848) (if (memv kind2851 (quote (hygiene))) (if (if (not (equal? mod2852 (module-name (current-module)))) (module-variable (resolve-module mod2852) var2848) #f) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (syntax-violation #f "bad module kind" var2848 mod2852))))))))) (build-lexical-assignment2075 (lambda (source2853 name2854 var2855 exp2856) (let ((atom-key2857 (fluid-ref *mode*2062))) (if (memv atom-key2857 (quote (c))) ((@ (language tree-il) make-lexical-set) source2853 name2854 var2855 exp2856) (list (quote set!) var2855 exp2856))))) (build-lexical-reference2074 (lambda (type2858 source2859 name2860 var2861) (let ((atom-key2862 (fluid-ref *mode*2062))) (if (memv atom-key2862 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2859 name2860 var2861) var2861)))) (build-conditional2073 (lambda (source2863 test-exp2864 then-exp2865 else-exp2866) (let ((atom-key2867 (fluid-ref *mode*2062))) (if (memv atom-key2867 (quote (c))) ((@ (language tree-il) make-conditional) source2863 test-exp2864 then-exp2865 else-exp2866) (list (quote if) test-exp2864 then-exp2865 else-exp2866))))) (build-application2072 (lambda (source2868 fun-exp2869 arg-exps2870) (let ((atom-key2871 (fluid-ref *mode*2062))) (if (memv atom-key2871 (quote (c))) ((@ (language tree-il) make-application) source2868 fun-exp2869 arg-exps2870) (cons fun-exp2869 arg-exps2870))))) (build-void2071 (lambda (source2872) (let ((atom-key2873 (fluid-ref *mode*2062))) (if (memv atom-key2873 (quote (c))) ((@ (language tree-il) make-void) source2872) (quote (if #f #f)))))) (get-global-definition-hook2070 (lambda (symbol2874 module2875) (begin (if (if (not module2875) (current-module) #f) (warn "module system is booted, we should have a module" symbol2874) (if #f #f)) (let ((v2876 (module-variable (if module2875 (resolve-module (cdr module2875)) (current-module)) symbol2874))) (if v2876 (if (variable-bound? v2876) (let ((val2877 (variable-ref v2876))) (if (macro? val2877) (if (syncase-macro-type val2877) (cons (syncase-macro-type val2877) (syncase-macro-binding val2877)) #f) #f)) #f) #f))))) (put-global-definition-hook2069 (lambda (symbol2878 type2879 val2880) (let ((existing2881 (let ((v2882 (module-variable (current-module) symbol2878))) (if v2882 (if (variable-bound? v2882) (let ((val2883 (variable-ref v2882))) (if (macro? val2883) (if (not (syncase-macro-type val2883)) val2883 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2878 (if existing2881 (make-extended-syncase-macro existing2881 type2879 val2880) (make-syncase-macro type2879 val2880)))))) (local-eval-hook2068 (lambda (x2884 mod2885) (primitive-eval (list noexpand2061 (let ((atom-key2886 (fluid-ref *mode*2062))) (if (memv atom-key2886 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2884) x2884)))))) (top-level-eval-hook2067 (lambda (x2887 mod2888) (primitive-eval (list noexpand2061 (let ((atom-key2889 (fluid-ref *mode*2062))) (if (memv atom-key2889 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2887) x2887)))))) (fx<2066 <) (fx=2065 =) (fx-2064 -) (fx+2063 +) (*mode*2062 (make-fluid)) (noexpand2061 "noexpand")) (begin (global-extend2102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend2102 (quote local-syntax) (quote let-syntax) #f) (global-extend2102 (quote core) (quote fluid-let-syntax) (lambda (e2890 r2891 w2892 s2893 mod2894) ((lambda (tmp2895) ((lambda (tmp2896) (if (if tmp2896 (apply (lambda (_2897 var2898 val2899 e12900 e22901) (valid-bound-ids?2129 var2898)) tmp2896) #f) (apply (lambda (_2903 var2904 val2905 e12906 e22907) (let ((names2908 (map (lambda (x2909) (id-var-name2126 x2909 w2892)) var2904))) (begin (for-each (lambda (id2911 n2912) (let ((atom-key2913 (binding-type2096 (lookup2101 n2912 r2891 mod2894)))) (if (memv atom-key2913 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2890 (source-wrap2133 id2911 w2892 s2893 mod2894)) (if #f #f)))) var2904 names2908) (chi-body2144 (cons e12906 e22907) (source-wrap2133 e2890 w2892 s2893 mod2894) (extend-env2098 names2908 (let ((trans-r2916 (macros-only-env2100 r2891))) (map (lambda (x2917) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2917 trans-r2916 w2892 mod2894) mod2894))) val2905)) r2891) w2892 mod2894)))) tmp2896) ((lambda (_2919) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap2133 e2890 w2892 s2893 mod2894))) tmp2895))) ($sc-dispatch tmp2895 (quote (any #(each (any any)) any . each-any))))) e2890))) (global-extend2102 (quote core) (quote quote) (lambda (e2920 r2921 w2922 s2923 mod2924) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 e2928) (build-data2082 s2923 (strip2151 e2928 w2922))) tmp2926) ((lambda (_2929) (syntax-violation (quote quote) "bad syntax" (source-wrap2133 e2920 w2922 s2923 mod2924))) tmp2925))) ($sc-dispatch tmp2925 (quote (any any))))) e2920))) (global-extend2102 (quote core) (quote syntax) (letrec ((regen2937 (lambda (x2938) (let ((atom-key2939 (car x2938))) (if (memv atom-key2939 (quote (ref))) (build-lexical-reference2074 (quote value) #f (cadr x2938) (cadr x2938)) (if (memv atom-key2939 (quote (primitive))) (build-primref2081 #f (cadr x2938)) (if (memv atom-key2939 (quote (quote))) (build-data2082 #f (cadr x2938)) (if (memv atom-key2939 (quote (lambda))) (build-lambda2080 #f (cadr x2938) (cadr x2938) #f (regen2937 (caddr x2938))) (if (memv atom-key2939 (quote (map))) (let ((ls2940 (map regen2937 (cdr x2938)))) (build-application2072 #f (build-primref2081 #f (quote map)) ls2940)) (build-application2072 #f (build-primref2081 #f (car x2938)) (map regen2937 (cdr x2938))))))))))) (gen-vector2936 (lambda (x2941) (if (eq? (car x2941) (quote list)) (cons (quote vector) (cdr x2941)) (if (eq? (car x2941) (quote quote)) (list (quote quote) (list->vector (cadr x2941))) (list (quote list->vector) x2941))))) (gen-append2935 (lambda (x2942 y2943) (if (equal? y2943 (quote (quote ()))) x2942 (list (quote append) x2942 y2943)))) (gen-cons2934 (lambda (x2944 y2945) (let ((atom-key2946 (car y2945))) (if (memv atom-key2946 (quote (quote))) (if (eq? (car x2944) (quote quote)) (list (quote quote) (cons (cadr x2944) (cadr y2945))) (if (eq? (cadr y2945) (quote ())) (list (quote list) x2944) (list (quote cons) x2944 y2945))) (if (memv atom-key2946 (quote (list))) (cons (quote list) (cons x2944 (cdr y2945))) (list (quote cons) x2944 y2945)))))) (gen-map2933 (lambda (e2947 map-env2948) (let ((formals2949 (map cdr map-env2948)) (actuals2950 (map (lambda (x2951) (list (quote ref) (car x2951))) map-env2948))) (if (eq? (car e2947) (quote ref)) (car actuals2950) (if (and-map (lambda (x2952) (if (eq? (car x2952) (quote ref)) (memq (cadr x2952) formals2949) #f)) (cdr e2947)) (cons (quote map) (cons (list (quote primitive) (car e2947)) (map (let ((r2953 (map cons formals2949 actuals2950))) (lambda (x2954) (cdr (assq (cadr x2954) r2953)))) (cdr e2947)))) (cons (quote map) (cons (list (quote lambda) formals2949 e2947) actuals2950))))))) (gen-mappend2932 (lambda (e2955 map-env2956) (list (quote apply) (quote (primitive append)) (gen-map2933 e2955 map-env2956)))) (gen-ref2931 (lambda (src2957 var2958 level2959 maps2960) (if (fx=2065 level2959 0) (values var2958 maps2960) (if (null? maps2960) (syntax-violation (quote syntax) "missing ellipsis" src2957) (call-with-values (lambda () (gen-ref2931 src2957 var2958 (fx-2064 level2959 1) (cdr maps2960))) (lambda (outer-var2961 outer-maps2962) (let ((b2963 (assq outer-var2961 (car maps2960)))) (if b2963 (values (cdr b2963) maps2960) (let ((inner-var2964 (gen-var2152 (quote tmp)))) (values inner-var2964 (cons (cons (cons outer-var2961 inner-var2964) (car maps2960)) outer-maps2962))))))))))) (gen-syntax2930 (lambda (src2965 e2966 r2967 maps2968 ellipsis?2969 mod2970) (if (id?2104 e2966) (let ((label2971 (id-var-name2126 e2966 (quote (()))))) (let ((b2972 (lookup2101 label2971 r2967 mod2970))) (if (eq? (binding-type2096 b2972) (quote syntax)) (call-with-values (lambda () (let ((var.lev2973 (binding-value2097 b2972))) (gen-ref2931 src2965 (car var.lev2973) (cdr var.lev2973) maps2968))) (lambda (var2974 maps2975) (values (list (quote ref) var2974) maps2975))) (if (ellipsis?2969 e2966) (syntax-violation (quote syntax) "misplaced ellipsis" src2965) (values (list (quote quote) e2966) maps2968))))) ((lambda (tmp2976) ((lambda (tmp2977) (if (if tmp2977 (apply (lambda (dots2978 e2979) (ellipsis?2969 dots2978)) tmp2977) #f) (apply (lambda (dots2980 e2981) (gen-syntax2930 src2965 e2981 r2967 maps2968 (lambda (x2982) #f) mod2970)) tmp2977) ((lambda (tmp2983) (if (if tmp2983 (apply (lambda (x2984 dots2985 y2986) (ellipsis?2969 dots2985)) tmp2983) #f) (apply (lambda (x2987 dots2988 y2989) (letrec ((f2990 (lambda (y2991 k2992) ((lambda (tmp2996) ((lambda (tmp2997) (if (if tmp2997 (apply (lambda (dots2998 y2999) (ellipsis?2969 dots2998)) tmp2997) #f) (apply (lambda (dots3000 y3001) (f2990 y3001 (lambda (maps3002) (call-with-values (lambda () (k2992 (cons (quote ()) maps3002))) (lambda (x3003 maps3004) (if (null? (car maps3004)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-mappend2932 x3003 (car maps3004)) (cdr maps3004)))))))) tmp2997) ((lambda (_3005) (call-with-values (lambda () (gen-syntax2930 src2965 y2991 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (y3006 maps3007) (call-with-values (lambda () (k2992 maps3007)) (lambda (x3008 maps3009) (values (gen-append2935 x3008 y3006) maps3009)))))) tmp2996))) ($sc-dispatch tmp2996 (quote (any . any))))) y2991)))) (f2990 y2989 (lambda (maps2993) (call-with-values (lambda () (gen-syntax2930 src2965 x2987 r2967 (cons (quote ()) maps2993) ellipsis?2969 mod2970)) (lambda (x2994 maps2995) (if (null? (car maps2995)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-map2933 x2994 (car maps2995)) (cdr maps2995))))))))) tmp2983) ((lambda (tmp3010) (if tmp3010 (apply (lambda (x3011 y3012) (call-with-values (lambda () (gen-syntax2930 src2965 x3011 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (x3013 maps3014) (call-with-values (lambda () (gen-syntax2930 src2965 y3012 r2967 maps3014 ellipsis?2969 mod2970)) (lambda (y3015 maps3016) (values (gen-cons2934 x3013 y3015) maps3016)))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (e13018 e23019) (call-with-values (lambda () (gen-syntax2930 src2965 (cons e13018 e23019) r2967 maps2968 ellipsis?2969 mod2970)) (lambda (e3021 maps3022) (values (gen-vector2936 e3021) maps3022)))) tmp3017) ((lambda (_3023) (values (list (quote quote) e2966) maps2968)) tmp2976))) ($sc-dispatch tmp2976 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2976 (quote (any . any)))))) ($sc-dispatch tmp2976 (quote (any any . any)))))) ($sc-dispatch tmp2976 (quote (any any))))) e2966))))) (lambda (e3024 r3025 w3026 s3027 mod3028) (let ((e3029 (source-wrap2133 e3024 w3026 s3027 mod3028))) ((lambda (tmp3030) ((lambda (tmp3031) (if tmp3031 (apply (lambda (_3032 x3033) (call-with-values (lambda () (gen-syntax2930 e3029 x3033 r3025 (quote ()) ellipsis?2149 mod3028)) (lambda (e3034 maps3035) (regen2937 e3034)))) tmp3031) ((lambda (_3036) (syntax-violation (quote syntax) "bad `syntax' form" e3029)) tmp3030))) ($sc-dispatch tmp3030 (quote (any any))))) e3029))))) (global-extend2102 (quote core) (quote lambda) (lambda (e3037 r3038 w3039 s3040 mod3041) ((lambda (tmp3042) ((lambda (tmp3043) (if tmp3043 (apply (lambda (_3044 c3045) (chi-lambda-clause2145 (source-wrap2133 e3037 w3039 s3040 mod3041) #f c3045 r3038 w3039 mod3041 (lambda (names3046 vars3047 docstring3048 body3049) (build-lambda2080 s3040 names3046 vars3047 docstring3048 body3049)))) tmp3043) (syntax-violation #f "Source expression failed to match any pattern" tmp3042))) ($sc-dispatch tmp3042 (quote (any . any))))) e3037))) (global-extend2102 (quote core) (quote let) (letrec ((chi-let3050 (lambda (e3051 r3052 w3053 s3054 mod3055 constructor3056 ids3057 vals3058 exps3059) (if (not (valid-bound-ids?2129 ids3057)) (syntax-violation (quote let) "duplicate bound variable" e3051) (let ((labels3060 (gen-labels2110 ids3057)) (new-vars3061 (map gen-var2152 ids3057))) (let ((nw3062 (make-binding-wrap2121 ids3057 labels3060 w3053)) (nr3063 (extend-var-env2099 labels3060 new-vars3061 r3052))) (constructor3056 s3054 (map syntax->datum ids3057) new-vars3061 (map (lambda (x3064) (chi2140 x3064 r3052 w3053 mod3055)) vals3058) (chi-body2144 exps3059 (source-wrap2133 e3051 nw3062 s3054 mod3055) nr3063 nw3062 mod3055)))))))) (lambda (e3065 r3066 w3067 s3068 mod3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (_3072 id3073 val3074 e13075 e23076) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-let2084 id3073 val3074 (cons e13075 e23076))) tmp3071) ((lambda (tmp3080) (if (if tmp3080 (apply (lambda (_3081 f3082 id3083 val3084 e13085 e23086) (id?2104 f3082)) tmp3080) #f) (apply (lambda (_3087 f3088 id3089 val3090 e13091 e23092) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-named-let2085 (cons f3088 id3089) val3090 (cons e13091 e23092))) tmp3080) ((lambda (_3096) (syntax-violation (quote let) "bad let" (source-wrap2133 e3065 w3067 s3068 mod3069))) tmp3070))) ($sc-dispatch tmp3070 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3070 (quote (any #(each (any any)) any . each-any))))) e3065)))) (global-extend2102 (quote core) (quote letrec) (lambda (e3097 r3098 w3099 s3100 mod3101) ((lambda (tmp3102) ((lambda (tmp3103) (if tmp3103 (apply (lambda (_3104 id3105 val3106 e13107 e23108) (let ((ids3109 id3105)) (if (not (valid-bound-ids?2129 ids3109)) (syntax-violation (quote letrec) "duplicate bound variable" e3097) (let ((labels3111 (gen-labels2110 ids3109)) (new-vars3112 (map gen-var2152 ids3109))) (let ((w3113 (make-binding-wrap2121 ids3109 labels3111 w3099)) (r3114 (extend-var-env2099 labels3111 new-vars3112 r3098))) (build-letrec2086 s3100 (map syntax->datum ids3109) new-vars3112 (map (lambda (x3115) (chi2140 x3115 r3114 w3113 mod3101)) val3106) (chi-body2144 (cons e13107 e23108) (source-wrap2133 e3097 w3113 s3100 mod3101) r3114 w3113 mod3101))))))) tmp3103) ((lambda (_3118) (syntax-violation (quote letrec) "bad letrec" (source-wrap2133 e3097 w3099 s3100 mod3101))) tmp3102))) ($sc-dispatch tmp3102 (quote (any #(each (any any)) any . each-any))))) e3097))) (global-extend2102 (quote core) (quote set!) (lambda (e3119 r3120 w3121 s3122 mod3123) ((lambda (tmp3124) ((lambda (tmp3125) (if (if tmp3125 (apply (lambda (_3126 id3127 val3128) (id?2104 id3127)) tmp3125) #f) (apply (lambda (_3129 id3130 val3131) (let ((val3132 (chi2140 val3131 r3120 w3121 mod3123)) (n3133 (id-var-name2126 id3130 w3121))) (let ((b3134 (lookup2101 n3133 r3120 mod3123))) (let ((atom-key3135 (binding-type2096 b3134))) (if (memv atom-key3135 (quote (lexical))) (build-lexical-assignment2075 s3122 (syntax->datum id3130) (binding-value2097 b3134) val3132) (if (memv atom-key3135 (quote (global))) (build-global-assignment2078 s3122 n3133 val3132 mod3123) (if (memv atom-key3135 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap2132 id3130 w3121 mod3123)) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))))))))) tmp3125) ((lambda (tmp3136) (if tmp3136 (apply (lambda (_3137 head3138 tail3139 val3140) (call-with-values (lambda () (syntax-type2138 head3138 r3120 (quote (())) #f #f mod3123)) (lambda (type3141 value3142 ee3143 ww3144 ss3145 modmod3146) (if (memv type3141 (quote (module-ref))) (let ((val3147 (chi2140 val3140 r3120 w3121 mod3123))) (call-with-values (lambda () (value3142 (cons head3138 tail3139))) (lambda (id3149 mod3150) (build-global-assignment2078 s3122 id3149 val3147 mod3150)))) (build-application2072 s3122 (chi2140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head3138) r3120 w3121 mod3123) (map (lambda (e3151) (chi2140 e3151 r3120 w3121 mod3123)) (append tail3139 (list val3140)))))))) tmp3136) ((lambda (_3153) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))) tmp3124))) ($sc-dispatch tmp3124 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp3124 (quote (any any any))))) e3119))) (global-extend2102 (quote module-ref) (quote @) (lambda (e3154) ((lambda (tmp3155) ((lambda (tmp3156) (if (if tmp3156 (apply (lambda (_3157 mod3158 id3159) (if (and-map id?2104 mod3158) (id?2104 id3159) #f)) tmp3156) #f) (apply (lambda (_3161 mod3162 id3163) (values (syntax->datum id3163) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3162)))) tmp3156) (syntax-violation #f "Source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any each-any any))))) e3154))) (global-extend2102 (quote module-ref) (quote @@) (lambda (e3165) ((lambda (tmp3166) ((lambda (tmp3167) (if (if tmp3167 (apply (lambda (_3168 mod3169 id3170) (if (and-map id?2104 mod3169) (id?2104 id3170) #f)) tmp3167) #f) (apply (lambda (_3172 mod3173 id3174) (values (syntax->datum id3174) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3173)))) tmp3167) (syntax-violation #f "Source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any each-any any))))) e3165))) (global-extend2102 (quote core) (quote if) (lambda (e3176 r3177 w3178 s3179 mod3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 test3184 then3185) (build-conditional2073 s3179 (chi2140 test3184 r3177 w3178 mod3180) (chi2140 then3185 r3177 w3178 mod3180) (build-void2071 #f))) tmp3182) ((lambda (tmp3186) (if tmp3186 (apply (lambda (_3187 test3188 then3189 else3190) (build-conditional2073 s3179 (chi2140 test3188 r3177 w3178 mod3180) (chi2140 then3189 r3177 w3178 mod3180) (chi2140 else3190 r3177 w3178 mod3180))) tmp3186) (syntax-violation #f "Source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any any any)))))) ($sc-dispatch tmp3181 (quote (any any any))))) e3176))) (global-extend2102 (quote begin) (quote begin) (quote ())) (global-extend2102 (quote define) (quote define) (quote ())) (global-extend2102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend2102 (quote eval-when) (quote eval-when) (quote ())) (global-extend2102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case3194 (lambda (x3195 keys3196 clauses3197 r3198 mod3199) (if (null? clauses3197) (build-application2072 #f (build-primref2081 #f (quote syntax-violation)) (list (build-data2082 #f #f) (build-data2082 #f "source expression failed to match any pattern") x3195)) ((lambda (tmp3200) ((lambda (tmp3201) (if tmp3201 (apply (lambda (pat3202 exp3203) (if (if (id?2104 pat3202) (and-map (lambda (x3204) (not (free-id=?2127 pat3202 x3204))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys3196)) #f) (let ((labels3205 (list (gen-label2109))) (var3206 (gen-var2152 pat3202))) (build-application2072 #f (build-lambda2080 #f (list (syntax->datum pat3202)) (list var3206) #f (chi2140 exp3203 (extend-env2098 labels3205 (list (cons (quote syntax) (cons var3206 0))) r3198) (make-binding-wrap2121 (list pat3202) labels3205 (quote (()))) mod3199)) (list x3195))) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3202 #t exp3203 mod3199))) tmp3201) ((lambda (tmp3207) (if tmp3207 (apply (lambda (pat3208 fender3209 exp3210) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3208 fender3209 exp3210 mod3199)) tmp3207) ((lambda (_3211) (syntax-violation (quote syntax-case) "invalid clause" (car clauses3197))) tmp3200))) ($sc-dispatch tmp3200 (quote (any any any)))))) ($sc-dispatch tmp3200 (quote (any any))))) (car clauses3197))))) (gen-clause3193 (lambda (x3212 keys3213 clauses3214 r3215 pat3216 fender3217 exp3218 mod3219) (call-with-values (lambda () (convert-pattern3191 pat3216 keys3213)) (lambda (p3220 pvars3221) (if (not (distinct-bound-ids?2130 (map car pvars3221))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat3216) (if (not (and-map (lambda (x3222) (not (ellipsis?2149 (car x3222)))) pvars3221)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat3216) (let ((y3223 (gen-var2152 (quote tmp)))) (build-application2072 #f (build-lambda2080 #f (list (quote tmp)) (list y3223) #f (let ((y3224 (build-lexical-reference2074 (quote value) #f (quote tmp) y3223))) (build-conditional2073 #f ((lambda (tmp3225) ((lambda (tmp3226) (if tmp3226 (apply (lambda () y3224) tmp3226) ((lambda (_3227) (build-conditional2073 #f y3224 (build-dispatch-call3192 pvars3221 fender3217 y3224 r3215 mod3219) (build-data2082 #f #f))) tmp3225))) ($sc-dispatch tmp3225 (quote #(atom #t))))) fender3217) (build-dispatch-call3192 pvars3221 exp3218 y3224 r3215 mod3219) (gen-syntax-case3194 x3212 keys3213 clauses3214 r3215 mod3219)))) (list (if (eq? p3220 (quote any)) (build-application2072 #f (build-primref2081 #f (quote list)) (list x3212)) (build-application2072 #f (build-primref2081 #f (quote $sc-dispatch)) (list x3212 (build-data2082 #f p3220))))))))))))) (build-dispatch-call3192 (lambda (pvars3228 exp3229 y3230 r3231 mod3232) (let ((ids3233 (map car pvars3228)) (levels3234 (map cdr pvars3228))) (let ((labels3235 (gen-labels2110 ids3233)) (new-vars3236 (map gen-var2152 ids3233))) (build-application2072 #f (build-primref2081 #f (quote apply)) (list (build-lambda2080 #f (map syntax->datum ids3233) new-vars3236 #f (chi2140 exp3229 (extend-env2098 labels3235 (map (lambda (var3237 level3238) (cons (quote syntax) (cons var3237 level3238))) new-vars3236 (map cdr pvars3228)) r3231) (make-binding-wrap2121 ids3233 labels3235 (quote (()))) mod3232)) y3230)))))) (convert-pattern3191 (lambda (pattern3239 keys3240) (letrec ((cvt3241 (lambda (p3242 n3243 ids3244) (if (id?2104 p3242) (if (bound-id-member?2131 p3242 keys3240) (values (vector (quote free-id) p3242) ids3244) (values (quote any) (cons (cons p3242 n3243) ids3244))) ((lambda (tmp3245) ((lambda (tmp3246) (if (if tmp3246 (apply (lambda (x3247 dots3248) (ellipsis?2149 dots3248)) tmp3246) #f) (apply (lambda (x3249 dots3250) (call-with-values (lambda () (cvt3241 x3249 (fx+2063 n3243 1) ids3244)) (lambda (p3251 ids3252) (values (if (eq? p3251 (quote any)) (quote each-any) (vector (quote each) p3251)) ids3252)))) tmp3246) ((lambda (tmp3253) (if tmp3253 (apply (lambda (x3254 y3255) (call-with-values (lambda () (cvt3241 y3255 n3243 ids3244)) (lambda (y3256 ids3257) (call-with-values (lambda () (cvt3241 x3254 n3243 ids3257)) (lambda (x3258 ids3259) (values (cons x3258 y3256) ids3259)))))) tmp3253) ((lambda (tmp3260) (if tmp3260 (apply (lambda () (values (quote ()) ids3244)) tmp3260) ((lambda (tmp3261) (if tmp3261 (apply (lambda (x3262) (call-with-values (lambda () (cvt3241 x3262 n3243 ids3244)) (lambda (p3264 ids3265) (values (vector (quote vector) p3264) ids3265)))) tmp3261) ((lambda (x3266) (values (vector (quote atom) (strip2151 p3242 (quote (())))) ids3244)) tmp3245))) ($sc-dispatch tmp3245 (quote #(vector each-any)))))) ($sc-dispatch tmp3245 (quote ()))))) ($sc-dispatch tmp3245 (quote (any . any)))))) ($sc-dispatch tmp3245 (quote (any any))))) p3242))))) (cvt3241 pattern3239 0 (quote ())))))) (lambda (e3267 r3268 w3269 s3270 mod3271) (let ((e3272 (source-wrap2133 e3267 w3269 s3270 mod3271))) ((lambda (tmp3273) ((lambda (tmp3274) (if tmp3274 (apply (lambda (_3275 val3276 key3277 m3278) (if (and-map (lambda (x3279) (if (id?2104 x3279) (not (ellipsis?2149 x3279)) #f)) key3277) (let ((x3281 (gen-var2152 (quote tmp)))) (build-application2072 s3270 (build-lambda2080 #f (list (quote tmp)) (list x3281) #f (gen-syntax-case3194 (build-lexical-reference2074 (quote value) #f (quote tmp) x3281) key3277 m3278 r3268 mod3271)) (list (chi2140 val3276 r3268 (quote (())) mod3271)))) (syntax-violation (quote syntax-case) "invalid literals list" e3272))) tmp3274) (syntax-violation #f "Source expression failed to match any pattern" tmp3273))) ($sc-dispatch tmp3273 (quote (any any each-any . each-any))))) e3272))))) (set! sc-expand (lambda (x3285 . rest3284) (if (if (pair? x3285) (equal? (car x3285) noexpand2061) #f) (cadr x3285) (let ((m3286 (if (null? rest3284) (quote e) (car rest3284))) (esew3287 (if (let ((t3288 (null? rest3284))) (if t3288 t3288 (null? (cdr rest3284)))) (quote (eval)) (cadr rest3284)))) (with-fluid* *mode*2062 m3286 (lambda () (chi-top2139 x3285 (quote ()) (quote ((top))) m3286 esew3287 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x3289) (nonsymbol-id?2103 x3289))) (set! datum->syntax (lambda (id3290 datum3291) (make-syntax-object2087 datum3291 (syntax-object-wrap2090 id3290) #f))) (set! syntax->datum (lambda (x3292) (strip2151 x3292 (quote (()))))) (set! generate-temporaries (lambda (ls3293) (begin (let ((x3294 ls3293)) (if (not (list? x3294)) (syntax-violation (quote generate-temporaries) "invalid argument" x3294) (if #f #f))) (map (lambda (x3295) (wrap2132 (gensym) (quote ((top))) #f)) ls3293)))) (set! free-identifier=? (lambda (x3296 y3297) (begin (let ((x3298 x3296)) (if (not (nonsymbol-id?2103 x3298)) (syntax-violation (quote free-identifier=?) "invalid argument" x3298) (if #f #f))) (let ((x3299 y3297)) (if (not (nonsymbol-id?2103 x3299)) (syntax-violation (quote free-identifier=?) "invalid argument" x3299) (if #f #f))) (free-id=?2127 x3296 y3297)))) (set! bound-identifier=? (lambda (x3300 y3301) (begin (let ((x3302 x3300)) (if (not (nonsymbol-id?2103 x3302)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3302) (if #f #f))) (let ((x3303 y3301)) (if (not (nonsymbol-id?2103 x3303)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3303) (if #f #f))) (bound-id=?2128 x3300 y3301)))) (set! syntax-violation (lambda (who3307 message3306 form3305 . subform3304) (begin (let ((x3308 who3307)) (if (not ((lambda (x3309) (let ((t3310 (not x3309))) (if t3310 t3310 (let ((t3311 (string? x3309))) (if t3311 t3311 (symbol? x3309)))))) x3308)) (syntax-violation (quote syntax-violation) "invalid argument" x3308) (if #f #f))) (let ((x3312 message3306)) (if (not (string? x3312)) (syntax-violation (quote syntax-violation) "invalid argument" x3312) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who3307 "~a: " "") "~a " (if (null? subform3304) "in ~a" "in subform `~s' of `~s'")) (let ((tail3313 (cons message3306 (map (lambda (x3314) (strip2151 x3314 (quote (())))) (append subform3304 (list form3305)))))) (if who3307 (cons who3307 tail3313) tail3313)) #f)))) (letrec ((match3319 (lambda (e3320 p3321 w3322 r3323 mod3324) (if (not r3323) #f (if (eq? p3321 (quote any)) (cons (wrap2132 e3320 w3322 mod3324) r3323) (if (syntax-object?2088 e3320) (match*3318 (let ((e3325 (syntax-object-expression2089 e3320))) (if (annotation? e3325) (annotation-expression e3325) e3325)) p3321 (join-wraps2123 w3322 (syntax-object-wrap2090 e3320)) r3323 (syntax-object-module2091 e3320)) (match*3318 (let ((e3326 e3320)) (if (annotation? e3326) (annotation-expression e3326) e3326)) p3321 w3322 r3323 mod3324)))))) (match*3318 (lambda (e3327 p3328 w3329 r3330 mod3331) (if (null? p3328) (if (null? e3327) r3330 #f) (if (pair? p3328) (if (pair? e3327) (match3319 (car e3327) (car p3328) w3329 (match3319 (cdr e3327) (cdr p3328) w3329 r3330 mod3331) mod3331) #f) (if (eq? p3328 (quote each-any)) (let ((l3332 (match-each-any3316 e3327 w3329 mod3331))) (if l3332 (cons l3332 r3330) #f)) (let ((atom-key3333 (vector-ref p3328 0))) (if (memv atom-key3333 (quote (each))) (if (null? e3327) (match-empty3317 (vector-ref p3328 1) r3330) (let ((l3334 (match-each3315 e3327 (vector-ref p3328 1) w3329 mod3331))) (if l3334 (letrec ((collect3335 (lambda (l3336) (if (null? (car l3336)) r3330 (cons (map car l3336) (collect3335 (map cdr l3336))))))) (collect3335 l3334)) #f))) (if (memv atom-key3333 (quote (free-id))) (if (id?2104 e3327) (if (free-id=?2127 (wrap2132 e3327 w3329 mod3331) (vector-ref p3328 1)) r3330 #f) #f) (if (memv atom-key3333 (quote (atom))) (if (equal? (vector-ref p3328 1) (strip2151 e3327 w3329)) r3330 #f) (if (memv atom-key3333 (quote (vector))) (if (vector? e3327) (match3319 (vector->list e3327) (vector-ref p3328 1) w3329 r3330 mod3331) #f) (if #f #f))))))))))) (match-empty3317 (lambda (p3337 r3338) (if (null? p3337) r3338 (if (eq? p3337 (quote any)) (cons (quote ()) r3338) (if (pair? p3337) (match-empty3317 (car p3337) (match-empty3317 (cdr p3337) r3338)) (if (eq? p3337 (quote each-any)) (cons (quote ()) r3338) (let ((atom-key3339 (vector-ref p3337 0))) (if (memv atom-key3339 (quote (each))) (match-empty3317 (vector-ref p3337 1) r3338) (if (memv atom-key3339 (quote (free-id atom))) r3338 (if (memv atom-key3339 (quote (vector))) (match-empty3317 (vector-ref p3337 1) r3338) (if #f #f))))))))))) (match-each-any3316 (lambda (e3340 w3341 mod3342) (if (annotation? e3340) (match-each-any3316 (annotation-expression e3340) w3341 mod3342) (if (pair? e3340) (let ((l3343 (match-each-any3316 (cdr e3340) w3341 mod3342))) (if l3343 (cons (wrap2132 (car e3340) w3341 mod3342) l3343) #f)) (if (null? e3340) (quote ()) (if (syntax-object?2088 e3340) (match-each-any3316 (syntax-object-expression2089 e3340) (join-wraps2123 w3341 (syntax-object-wrap2090 e3340)) mod3342) #f)))))) (match-each3315 (lambda (e3344 p3345 w3346 mod3347) (if (annotation? e3344) (match-each3315 (annotation-expression e3344) p3345 w3346 mod3347) (if (pair? e3344) (let ((first3348 (match3319 (car e3344) p3345 w3346 (quote ()) mod3347))) (if first3348 (let ((rest3349 (match-each3315 (cdr e3344) p3345 w3346 mod3347))) (if rest3349 (cons first3348 rest3349) #f)) #f)) (if (null? e3344) (quote ()) (if (syntax-object?2088 e3344) (match-each3315 (syntax-object-expression2089 e3344) p3345 (join-wraps2123 w3346 (syntax-object-wrap2090 e3344)) (syntax-object-module2091 e3344)) #f))))))) (set! $sc-dispatch (lambda (e3350 p3351) (if (eq? p3351 (quote any)) (list e3350) (if (syntax-object?2088 e3350) (match*3318 (let ((e3352 (syntax-object-expression2089 e3350))) (if (annotation? e3352) (annotation-expression e3352) e3352)) p3351 (syntax-object-wrap2090 e3350) (quote ()) (syntax-object-module2091 e3350)) (match*3318 (let ((e3353 e3350)) (if (annotation? e3353) (annotation-expression e3353) e3353)) p3351 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x3354) ((lambda (tmp3355) ((lambda (tmp3356) (if tmp3356 (apply (lambda (_3357 e13358 e23359) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13358 e23359))) tmp3356) ((lambda (tmp3361) (if tmp3361 (apply (lambda (_3362 out3363 in3364 e13365 e23366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3364 (quote ()) (list out3363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13365 e23366))))) tmp3361) ((lambda (tmp3368) (if tmp3368 (apply (lambda (_3369 out3370 in3371 e13372 e23373) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in3371) (quote ()) (list out3370 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13372 e23373))))) tmp3368) (syntax-violation #f "Source expression failed to match any pattern" tmp3355))) ($sc-dispatch tmp3355 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any () any . each-any))))) x3354)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3377) ((lambda (tmp3378) ((lambda (tmp3379) (if tmp3379 (apply (lambda (_3380 k3381 keyword3382 pattern3383 template3384) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k3381 (map (lambda (tmp3387 tmp3386) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3386) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp3387))) template3384 pattern3383)))))) tmp3379) (syntax-violation #f "Source expression failed to match any pattern" tmp3378))) ($sc-dispatch tmp3378 (quote (any each-any . #(each ((any . any) any))))))) x3377)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3388) ((lambda (tmp3389) ((lambda (tmp3390) (if (if tmp3390 (apply (lambda (let*3391 x3392 v3393 e13394 e23395) (and-map identifier? x3392)) tmp3390) #f) (apply (lambda (let*3397 x3398 v3399 e13400 e23401) (letrec ((f3402 (lambda (bindings3403) (if (null? bindings3403) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e13400 e23401))) ((lambda (tmp3407) ((lambda (tmp3408) (if tmp3408 (apply (lambda (body3409 binding3410) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding3410) body3409)) tmp3408) (syntax-violation #f "Source expression failed to match any pattern" tmp3407))) ($sc-dispatch tmp3407 (quote (any any))))) (list (f3402 (cdr bindings3403)) (car bindings3403))))))) (f3402 (map list x3398 v3399)))) tmp3390) (syntax-violation #f "Source expression failed to match any pattern" tmp3389))) ($sc-dispatch tmp3389 (quote (any #(each (any any)) any . each-any))))) x3388)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3411) ((lambda (tmp3412) ((lambda (tmp3413) (if tmp3413 (apply (lambda (_3414 var3415 init3416 step3417 e03418 e13419 c3420) ((lambda (tmp3421) ((lambda (tmp3422) (if tmp3422 (apply (lambda (step3423) ((lambda (tmp3424) ((lambda (tmp3425) (if tmp3425 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3425) ((lambda (tmp3430) (if tmp3430 (apply (lambda (e13431 e23432) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var3415 init3416) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e03418 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e13431 e23432)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c3420 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step3423))))))) tmp3430) (syntax-violation #f "Source expression failed to match any pattern" tmp3424))) ($sc-dispatch tmp3424 (quote (any . each-any)))))) ($sc-dispatch tmp3424 (quote ())))) e13419)) tmp3422) (syntax-violation #f "Source expression failed to match any pattern" tmp3421))) ($sc-dispatch tmp3421 (quote each-any)))) (map (lambda (v3439 s3440) ((lambda (tmp3441) ((lambda (tmp3442) (if tmp3442 (apply (lambda () v3439) tmp3442) ((lambda (tmp3443) (if tmp3443 (apply (lambda (e3444) e3444) tmp3443) ((lambda (_3445) (syntax-violation (quote do) "bad step expression" orig-x3411 s3440)) tmp3441))) ($sc-dispatch tmp3441 (quote (any)))))) ($sc-dispatch tmp3441 (quote ())))) s3440)) var3415 step3417))) tmp3413) (syntax-violation #f "Source expression failed to match any pattern" tmp3412))) ($sc-dispatch tmp3412 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3411)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3448 (lambda (x3452 y3453) ((lambda (tmp3454) ((lambda (tmp3455) (if tmp3455 (apply (lambda (x3456 y3457) ((lambda (tmp3458) ((lambda (tmp3459) (if tmp3459 (apply (lambda (dy3460) ((lambda (tmp3461) ((lambda (tmp3462) (if tmp3462 (apply (lambda (dx3463) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx3463 dy3460))) tmp3462) ((lambda (_3464) (if (null? dy3460) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457))) tmp3461))) ($sc-dispatch tmp3461 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x3456)) tmp3459) ((lambda (tmp3465) (if tmp3465 (apply (lambda (stuff3466) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x3456 stuff3466))) tmp3465) ((lambda (else3467) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3456 y3457)) tmp3458))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp3458 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y3457)) tmp3455) (syntax-violation #f "Source expression failed to match any pattern" tmp3454))) ($sc-dispatch tmp3454 (quote (any any))))) (list x3452 y3453)))) (quasiappend3449 (lambda (x3468 y3469) ((lambda (tmp3470) ((lambda (tmp3471) (if tmp3471 (apply (lambda (x3472 y3473) ((lambda (tmp3474) ((lambda (tmp3475) (if tmp3475 (apply (lambda () x3472) tmp3475) ((lambda (_3476) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3472 y3473)) tmp3474))) ($sc-dispatch tmp3474 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y3473)) tmp3471) (syntax-violation #f "Source expression failed to match any pattern" tmp3470))) ($sc-dispatch tmp3470 (quote (any any))))) (list x3468 y3469)))) (quasivector3450 (lambda (x3477) ((lambda (tmp3478) ((lambda (x3479) ((lambda (tmp3480) ((lambda (tmp3481) (if tmp3481 (apply (lambda (x3482) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x3482))) tmp3481) ((lambda (tmp3484) (if tmp3484 (apply (lambda (x3485) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3485)) tmp3484) ((lambda (_3487) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x3479)) tmp3480))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp3480 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x3479)) tmp3478)) x3477))) (quasi3451 (lambda (p3488 lev3489) ((lambda (tmp3490) ((lambda (tmp3491) (if tmp3491 (apply (lambda (p3492) (if (= lev3489 0) p3492 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3492) (- lev3489 1))))) tmp3491) ((lambda (tmp3493) (if tmp3493 (apply (lambda (p3494 q3495) (if (= lev3489 0) (quasiappend3449 p3494 (quasi3451 q3495 lev3489)) (quasicons3448 (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3494) (- lev3489 1))) (quasi3451 q3495 lev3489)))) tmp3493) ((lambda (tmp3496) (if tmp3496 (apply (lambda (p3497) (quasicons3448 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi3451 (list p3497) (+ lev3489 1)))) tmp3496) ((lambda (tmp3498) (if tmp3498 (apply (lambda (p3499 q3500) (quasicons3448 (quasi3451 p3499 lev3489) (quasi3451 q3500 lev3489))) tmp3498) ((lambda (tmp3501) (if tmp3501 (apply (lambda (x3502) (quasivector3450 (quasi3451 x3502 lev3489))) tmp3501) ((lambda (p3504) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p3504)) tmp3490))) ($sc-dispatch tmp3490 (quote #(vector each-any)))))) ($sc-dispatch tmp3490 (quote (any . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp3490 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp3490 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p3488)))) (lambda (x3505) ((lambda (tmp3506) ((lambda (tmp3507) (if tmp3507 (apply (lambda (_3508 e3509) (quasi3451 e3509 0)) tmp3507) (syntax-violation #f "Source expression failed to match any pattern" tmp3506))) ($sc-dispatch tmp3506 (quote (any any))))) x3505))))) -(define include (make-syncase-macro (quote macro) (lambda (x3510) (letrec ((read-file3511 (lambda (fn3512 k3513) (let ((p3514 (open-input-file fn3512))) (letrec ((f3515 (lambda (x3516) (if (eof-object? x3516) (begin (close-input-port p3514) (quote ())) (cons (datum->syntax k3513 x3516) (f3515 (read p3514))))))) (f3515 (read p3514))))))) ((lambda (tmp3517) ((lambda (tmp3518) (if tmp3518 (apply (lambda (k3519 filename3520) (let ((fn3521 (syntax->datum filename3520))) ((lambda (tmp3522) ((lambda (tmp3523) (if tmp3523 (apply (lambda (exp3524) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp3524)) tmp3523) (syntax-violation #f "Source expression failed to match any pattern" tmp3522))) ($sc-dispatch tmp3522 (quote each-any)))) (read-file3511 fn3521 k3519)))) tmp3518) (syntax-violation #f "Source expression failed to match any pattern" tmp3517))) ($sc-dispatch tmp3517 (quote (any any))))) x3510))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x3526) ((lambda (tmp3527) ((lambda (tmp3528) (if tmp3528 (apply (lambda (_3529 e3530) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x3526)) tmp3528) (syntax-violation #f "Source expression failed to match any pattern" tmp3527))) ($sc-dispatch tmp3527 (quote (any any))))) x3526)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3531) ((lambda (tmp3532) ((lambda (tmp3533) (if tmp3533 (apply (lambda (_3534 e3535) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x3531)) tmp3533) (syntax-violation #f "Source expression failed to match any pattern" tmp3532))) ($sc-dispatch tmp3532 (quote (any any))))) x3531)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3536) ((lambda (tmp3537) ((lambda (tmp3538) (if tmp3538 (apply (lambda (_3539 e3540 m13541 m23542) ((lambda (tmp3543) ((lambda (body3544) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3540)) body3544)) tmp3543)) (letrec ((f3545 (lambda (clause3546 clauses3547) (if (null? clauses3547) ((lambda (tmp3549) ((lambda (tmp3550) (if tmp3550 (apply (lambda (e13551 e23552) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13551 e23552))) tmp3550) ((lambda (tmp3554) (if tmp3554 (apply (lambda (k3555 e13556 e23557) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3555)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13556 e23557)))) tmp3554) ((lambda (_3560) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3549))) ($sc-dispatch tmp3549 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3549 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause3546) ((lambda (tmp3561) ((lambda (rest3562) ((lambda (tmp3563) ((lambda (tmp3564) (if tmp3564 (apply (lambda (k3565 e13566 e23567) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k3565)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13566 e23567)) rest3562)) tmp3564) ((lambda (_3570) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3563))) ($sc-dispatch tmp3563 (quote (each-any any . each-any))))) clause3546)) tmp3561)) (f3545 (car clauses3547) (cdr clauses3547))))))) (f3545 m13541 m23542)))) tmp3538) (syntax-violation #f "Source expression failed to match any pattern" tmp3537))) ($sc-dispatch tmp3537 (quote (any any any . each-any))))) x3536)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3571) ((lambda (tmp3572) ((lambda (tmp3573) (if tmp3573 (apply (lambda (_3574 e3575) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3575)) (list (cons _3574 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e3575 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp3573) (syntax-violation #f "Source expression failed to match any pattern" tmp3572))) ($sc-dispatch tmp3572 (quote (any any))))) x3571)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars291) (letrec ((lvl292 (lambda (vars293 ls294 w295) (if (pair? vars293) (lvl292 (cdr vars293) (cons (wrap141 (car vars293) w295 #f) ls294) w295) (if (id?113 vars293) (cons (wrap141 vars293 w295 #f) ls294) (if (null? vars293) ls294 (if (syntax-object?97 vars293) (lvl292 (syntax-object-expression98 vars293) ls294 (join-wraps132 w295 (syntax-object-wrap99 vars293))) (if (annotation? vars293) (lvl292 (annotation-expression vars293) ls294 w295) (cons vars293 ls294))))))))) (lvl292 vars291 (quote ()) (quote (())))))) (gen-var161 (lambda (id296) (let ((id297 (if (syntax-object?97 id296) (syntax-object-expression98 id296) id296))) (if (annotation? id297) (gensym (symbol->string (annotation-expression id297))) (gensym (symbol->string id297)))))) (strip160 (lambda (x298 w299) (if (memq (quote top) (wrap-marks116 w299)) (if (let ((t300 (annotation? x298))) (if t300 t300 (if (pair? x298) (annotation? (car x298)) #f))) (strip-annotation159 x298 #f) x298) (letrec ((f301 (lambda (x302) (if (syntax-object?97 x302) (strip160 (syntax-object-expression98 x302) (syntax-object-wrap99 x302)) (if (pair? x302) (let ((a303 (f301 (car x302))) (d304 (f301 (cdr x302)))) (if (if (eq? a303 (car x302)) (eq? d304 (cdr x302)) #f) x302 (cons a303 d304))) (if (vector? x302) (let ((old305 (vector->list x302))) (let ((new306 (map f301 old305))) (if (and-map*17 eq? old305 new306) x302 (list->vector new306)))) x302)))))) (f301 x298))))) (strip-annotation159 (lambda (x307 parent308) (if (pair? x307) (let ((new309 (cons #f #f))) (begin (if parent308 (set-annotation-stripped! parent308 new309) (if #f #f)) (set-car! new309 (strip-annotation159 (car x307) #f)) (set-cdr! new309 (strip-annotation159 (cdr x307) #f)) new309)) (if (annotation? x307) (let ((t310 (annotation-stripped x307))) (if t310 t310 (strip-annotation159 (annotation-expression x307) x307))) (if (vector? x307) (let ((new311 (make-vector (vector-length x307)))) (begin (if parent308 (set-annotation-stripped! parent308 new311) (if #f #f)) (letrec ((loop312 (lambda (i313) (unless (fx<75 i313 0) (vector-set! new311 i313 (strip-annotation159 (vector-ref x307 i313) #f)) (loop312 (fx-73 i313 1)))))) (loop312 (- (vector-length x307) 1))) new311)) x307))))) (ellipsis?158 (lambda (x314) (if (nonsymbol-id?112 x314) (free-id=?136 x314 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void157 (lambda () (build-void80 #f))) (eval-local-transformer156 (lambda (expanded315 mod316) (let ((p317 (local-eval-hook77 expanded315 mod316))) (if (procedure? p317) p317 (syntax-violation #f "nonprocedure transformer" p317))))) (chi-local-syntax155 (lambda (rec?318 e319 r320 w321 s322 mod323 k324) ((lambda (tmp325) ((lambda (tmp326) (if tmp326 (apply (lambda (_327 id328 val329 e1330 e2331) (let ((ids332 id328)) (if (not (valid-bound-ids?138 ids332)) (syntax-violation #f "duplicate bound keyword" e319) (let ((labels334 (gen-labels119 ids332))) (let ((new-w335 (make-binding-wrap130 ids332 labels334 w321))) (k324 (cons e1330 e2331) (extend-env107 labels334 (let ((w337 (if rec?318 new-w335 w321)) (trans-r338 (macros-only-env109 r320))) (map (lambda (x339) (cons (quote macro) (eval-local-transformer156 (chi149 x339 trans-r338 w337 mod323) mod323))) val329)) r320) new-w335 s322 mod323)))))) tmp326) ((lambda (_341) (syntax-violation #f "bad local syntax definition" (source-wrap142 e319 w321 s322 mod323))) tmp325))) ($sc-dispatch tmp325 (quote (any #(each (any any)) any . each-any))))) e319))) (chi-lambda-clause154 (lambda (e342 docstring343 c344 r345 w346 mod347 k348) ((lambda (tmp349) ((lambda (tmp350) (if (if tmp350 (apply (lambda (args351 doc352 e1353 e2354) (if (string? (syntax->datum doc352)) (not docstring343) #f)) tmp350) #f) (apply (lambda (args355 doc356 e1357 e2358) (chi-lambda-clause154 e342 doc356 (cons args355 (cons e1357 e2358)) r345 w346 mod347 k348)) tmp350) ((lambda (tmp360) (if tmp360 (apply (lambda (id361 e1362 e2363) (let ((ids364 id361)) (if (not (valid-bound-ids?138 ids364)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels366 (gen-labels119 ids364)) (new-vars367 (map gen-var161 ids364))) (k348 (map syntax->datum ids364) new-vars367 (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1362 e2363) e342 (extend-var-env108 labels366 new-vars367 r345) (make-binding-wrap130 ids364 labels366 w346) mod347)))))) tmp360) ((lambda (tmp369) (if tmp369 (apply (lambda (ids370 e1371 e2372) (let ((old-ids373 (lambda-var-list162 ids370))) (if (not (valid-bound-ids?138 old-ids373)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels374 (gen-labels119 old-ids373)) (new-vars375 (map gen-var161 old-ids373))) (k348 (letrec ((f376 (lambda (ls1377 ls2378) (if (null? ls1377) (syntax->datum ls2378) (f376 (cdr ls1377) (cons (syntax->datum (car ls1377)) ls2378)))))) (f376 (cdr old-ids373) (car old-ids373))) (letrec ((f379 (lambda (ls1380 ls2381) (if (null? ls1380) ls2381 (f379 (cdr ls1380) (cons (car ls1380) ls2381)))))) (f379 (cdr new-vars375) (car new-vars375))) (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1371 e2372) e342 (extend-var-env108 labels374 new-vars375 r345) (make-binding-wrap130 old-ids373 labels374 w346) mod347)))))) tmp369) ((lambda (_383) (syntax-violation (quote lambda) "bad lambda" e342)) tmp349))) ($sc-dispatch tmp349 (quote (any any . each-any)))))) ($sc-dispatch tmp349 (quote (each-any any . each-any)))))) ($sc-dispatch tmp349 (quote (any any any . each-any))))) c344))) (chi-body153 (lambda (body384 outer-form385 r386 w387 mod388) (let ((r389 (cons (quote ("placeholder" placeholder)) r386))) (let ((ribcage390 (make-ribcage120 (quote ()) (quote ()) (quote ())))) (let ((w391 (make-wrap115 (wrap-marks116 w387) (cons ribcage390 (wrap-subst117 w387))))) (letrec ((parse392 (lambda (body393 ids394 labels395 vars396 vals397 bindings398) (if (null? body393) (syntax-violation #f "no expressions in body" outer-form385) (let ((e400 (cdar body393)) (er401 (caar body393))) (call-with-values (lambda () (syntax-type147 e400 er401 (quote (())) #f ribcage390 mod388)) (lambda (type402 value403 e404 w405 s406 mod407) (if (memv type402 (quote (define-form))) (let ((id408 (wrap141 value403 w405 mod407)) (label409 (gen-label118))) (let ((var410 (gen-var161 id408))) (begin (extend-ribcage!129 ribcage390 id408 label409) (parse392 (cdr body393) (cons id408 ids394) (cons label409 labels395) (cons var410 vars396) (cons (cons er401 (wrap141 e404 w405 mod407)) vals397) (cons (cons (quote lexical) var410) bindings398))))) (if (memv type402 (quote (define-syntax-form))) (let ((id411 (wrap141 value403 w405 mod407)) (label412 (gen-label118))) (begin (extend-ribcage!129 ribcage390 id411 label412) (parse392 (cdr body393) (cons id411 ids394) (cons label412 labels395) vars396 vals397 (cons (cons (quote macro) (cons er401 (wrap141 e404 w405 mod407))) bindings398)))) (if (memv type402 (quote (begin-form))) ((lambda (tmp413) ((lambda (tmp414) (if tmp414 (apply (lambda (_415 e1416) (parse392 (letrec ((f417 (lambda (forms418) (if (null? forms418) (cdr body393) (cons (cons er401 (wrap141 (car forms418) w405 mod407)) (f417 (cdr forms418))))))) (f417 e1416)) ids394 labels395 vars396 vals397 bindings398)) tmp414) (syntax-violation #f "source expression failed to match any pattern" tmp413))) ($sc-dispatch tmp413 (quote (any . each-any))))) e404) (if (memv type402 (quote (local-syntax-form))) (chi-local-syntax155 value403 e404 er401 w405 s406 mod407 (lambda (forms420 er421 w422 s423 mod424) (parse392 (letrec ((f425 (lambda (forms426) (if (null? forms426) (cdr body393) (cons (cons er421 (wrap141 (car forms426) w422 mod424)) (f425 (cdr forms426))))))) (f425 forms420)) ids394 labels395 vars396 vals397 bindings398))) (if (null? ids394) (build-sequence92 #f (map (lambda (x427) (chi149 (cdr x427) (car x427) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))) (begin (if (not (valid-bound-ids?138 ids394)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form385) (if #f #f)) (letrec ((loop428 (lambda (bs429 er-cache430 r-cache431) (if (not (null? bs429)) (let ((b432 (car bs429))) (if (eq? (car b432) (quote macro)) (let ((er433 (cadr b432))) (let ((r-cache434 (if (eq? er433 er-cache430) r-cache431 (macros-only-env109 er433)))) (begin (set-cdr! b432 (eval-local-transformer156 (chi149 (cddr b432) r-cache434 (quote (())) mod407) mod407)) (loop428 (cdr bs429) er433 r-cache434)))) (loop428 (cdr bs429) er-cache430 r-cache431))) (if #f #f))))) (loop428 bindings398 #f #f)) (set-cdr! r389 (extend-env107 labels395 bindings398 (cdr r389))) (build-letrec95 #f (map syntax->datum ids394) vars396 (map (lambda (x435) (chi149 (cdr x435) (car x435) (quote (())) mod407)) vals397) (build-sequence92 #f (map (lambda (x436) (chi149 (cdr x436) (car x436) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))))))))))))))))) (parse392 (map (lambda (x399) (cons r389 (wrap141 x399 w391 mod388))) body384) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro152 (lambda (p437 e438 r439 w440 rib441 mod442) (letrec ((rebuild-macro-output443 (lambda (x444 m445) (if (pair? x444) (cons (rebuild-macro-output443 (car x444) m445) (rebuild-macro-output443 (cdr x444) m445)) (if (syntax-object?97 x444) (let ((w446 (syntax-object-wrap99 x444))) (let ((ms447 (wrap-marks116 w446)) (s448 (wrap-subst117 w446))) (if (if (pair? ms447) (eq? (car ms447) #f) #f) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cdr ms447) (if rib441 (cons rib441 (cdr s448)) (cdr s448))) (syntax-object-module100 x444)) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cons m445 ms447) (if rib441 (cons rib441 (cons (quote shift) s448)) (cons (quote shift) s448))) (let ((pmod449 (procedure-module p437))) (if pmod449 (cons (quote hygiene) (module-name pmod449)) (quote (hygiene guile)))))))) (if (vector? x444) (let ((n450 (vector-length x444))) (let ((v451 (make-vector n450))) (letrec ((loop452 (lambda (i453) (if (fx=74 i453 n450) (begin (if #f #f (if #f #f)) v451) (begin (vector-set! v451 i453 (rebuild-macro-output443 (vector-ref x444 i453) m445)) (loop452 (fx+72 i453 1))))))) (loop452 0)))) (if (symbol? x444) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap142 e438 w440 s mod442) x444) x444))))))) (rebuild-macro-output443 (p437 (wrap141 e438 (anti-mark128 w440) mod442)) (string #\m))))) (chi-application151 (lambda (x454 e455 r456 w457 s458 mod459) ((lambda (tmp460) ((lambda (tmp461) (if tmp461 (apply (lambda (e0462 e1463) (build-application81 s458 x454 (map (lambda (e464) (chi149 e464 r456 w457 mod459)) e1463))) tmp461) (syntax-violation #f "source expression failed to match any pattern" tmp460))) ($sc-dispatch tmp460 (quote (any . each-any))))) e455))) (chi-expr150 (lambda (type466 value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (lexical))) (build-lexical-reference83 (quote value) s471 e468 value467) (if (memv type466 (quote (core external-macro))) (value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (module-ref))) (call-with-values (lambda () (value467 e468)) (lambda (id473 mod474) (build-global-reference86 s471 id473 mod474))) (if (memv type466 (quote (lexical-call))) (chi-application151 (build-lexical-reference83 (quote fun) (source-annotation104 (car e468)) (car e468) value467) e468 r469 w470 s471 mod472) (if (memv type466 (quote (global-call))) (chi-application151 (build-global-reference86 (source-annotation104 (car e468)) value467 (if (syntax-object?97 (car e468)) (syntax-object-module100 (car e468)) mod472)) e468 r469 w470 s471 mod472) (if (memv type466 (quote (constant))) (build-data91 s471 (strip160 (source-wrap142 e468 w470 s471 mod472) (quote (())))) (if (memv type466 (quote (global))) (build-global-reference86 s471 value467 mod472) (if (memv type466 (quote (call))) (chi-application151 (chi149 (car e468) r469 w470 mod472) e468 r469 w470 s471 mod472) (if (memv type466 (quote (begin-form))) ((lambda (tmp475) ((lambda (tmp476) (if tmp476 (apply (lambda (_477 e1478 e2479) (chi-sequence143 (cons e1478 e2479) r469 w470 s471 mod472)) tmp476) (syntax-violation #f "source expression failed to match any pattern" tmp475))) ($sc-dispatch tmp475 (quote (any any . each-any))))) e468) (if (memv type466 (quote (local-syntax-form))) (chi-local-syntax155 value467 e468 r469 w470 s471 mod472 chi-sequence143) (if (memv type466 (quote (eval-when-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 x484 e1485 e2486) (let ((when-list487 (chi-when-list146 e468 x484 w470))) (if (memq (quote eval) when-list487) (chi-sequence143 (cons e1485 e2486) r469 w470 s471 mod472) (chi-void157)))) tmp482) (syntax-violation #f "source expression failed to match any pattern" tmp481))) ($sc-dispatch tmp481 (quote (any each-any any . each-any))))) e468) (if (memv type466 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e468 (wrap141 value467 w470 mod472)) (if (memv type466 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap142 e468 w470 s471 mod472)) (if (memv type466 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap142 e468 w470 s471 mod472)) (syntax-violation #f "unexpected syntax" (source-wrap142 e468 w470 s471 mod472)))))))))))))))))) (chi149 (lambda (e490 r491 w492 mod493) (call-with-values (lambda () (syntax-type147 e490 r491 w492 #f #f mod493)) (lambda (type494 value495 e496 w497 s498 mod499) (chi-expr150 type494 value495 e496 r491 w497 s498 mod499))))) (chi-top148 (lambda (e500 r501 w502 m503 esew504 mod505) (call-with-values (lambda () (syntax-type147 e500 r501 w502 #f #f mod505)) (lambda (type513 value514 e515 w516 s517 mod518) (if (memv type513 (quote (begin-form))) ((lambda (tmp519) ((lambda (tmp520) (if tmp520 (apply (lambda (_521) (chi-void157)) tmp520) ((lambda (tmp522) (if tmp522 (apply (lambda (_523 e1524 e2525) (chi-top-sequence144 (cons e1524 e2525) r501 w516 s517 m503 esew504 mod518)) tmp522) (syntax-violation #f "source expression failed to match any pattern" tmp519))) ($sc-dispatch tmp519 (quote (any any . each-any)))))) ($sc-dispatch tmp519 (quote (any))))) e515) (if (memv type513 (quote (local-syntax-form))) (chi-local-syntax155 value514 e515 r501 w516 s517 mod518 (lambda (body527 r528 w529 s530 mod531) (chi-top-sequence144 body527 r528 w529 s530 m503 esew504 mod531))) (if (memv type513 (quote (eval-when-form))) ((lambda (tmp532) ((lambda (tmp533) (if tmp533 (apply (lambda (_534 x535 e1536 e2537) (let ((when-list538 (chi-when-list146 e515 x535 w516)) (body539 (cons e1536 e2537))) (if (eq? m503 (quote e)) (if (memq (quote eval) when-list538) (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) (chi-void157)) (if (memq (quote load) when-list538) (if (let ((t542 (memq (quote compile) when-list538))) (if t542 t542 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (chi-top-sequence144 body539 r501 w516 s517 (quote c&e) (quote (compile load)) mod518) (if (memq m503 (quote (c c&e))) (chi-top-sequence144 body539 r501 w516 s517 (quote c) (quote (load)) mod518) (chi-void157))) (if (let ((t543 (memq (quote compile) when-list538))) (if t543 t543 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (begin (top-level-eval-hook76 (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) mod518) (chi-void157)) (chi-void157)))))) tmp533) (syntax-violation #f "source expression failed to match any pattern" tmp532))) ($sc-dispatch tmp532 (quote (any each-any any . each-any))))) e515) (if (memv type513 (quote (define-syntax-form))) (let ((n544 (id-var-name135 value514 w516)) (r545 (macros-only-env109 r501))) (if (memv m503 (quote (c))) (if (memq (quote compile) esew504) (let ((e546 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e546 mod518) (if (memq (quote load) esew504) e546 (chi-void157)))) (if (memq (quote load) esew504) (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) (chi-void157))) (if (memv m503 (quote (c&e))) (let ((e547 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e547 mod518) e547)) (begin (if (memq (quote eval) esew504) (top-level-eval-hook76 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) mod518) (if #f #f)) (chi-void157))))) (if (memv type513 (quote (define-form))) (let ((n548 (id-var-name135 value514 w516))) (let ((type549 (binding-type105 (lookup110 n548 r501 mod518)))) (if (memv type549 (quote (global core macro module-ref))) (let ((x550 (build-global-definition88 s517 n548 (chi149 e515 r501 w516 mod518)))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x550 mod518) (if #f #f)) x550)) (if (memv type549 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e515 (wrap141 value514 w516 mod518)) (syntax-violation #f "cannot define keyword at top level" e515 (wrap141 value514 w516 mod518)))))) (let ((x551 (chi-expr150 type513 value514 e515 r501 w516 s517 mod518))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x551 mod518) (if #f #f)) x551))))))))))) (syntax-type147 (lambda (e552 r553 w554 s555 rib556 mod557) (if (symbol? e552) (let ((n558 (id-var-name135 e552 w554))) (let ((b559 (lookup110 n558 r553 mod557))) (let ((type560 (binding-type105 b559))) (if (memv type560 (quote (lexical))) (values type560 (binding-value106 b559) e552 w554 s555 mod557) (if (memv type560 (quote (global))) (values type560 n558 e552 w554 s555 mod557) (if (memv type560 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b559) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (values type560 (binding-value106 b559) e552 w554 s555 mod557))))))) (if (pair? e552) (let ((first561 (car e552))) (if (id?113 first561) (let ((n562 (id-var-name135 first561 w554))) (let ((b563 (lookup110 n562 r553 (let ((t564 (if (syntax-object?97 first561) (syntax-object-module100 first561) #f))) (if t564 t564 mod557))))) (let ((type565 (binding-type105 b563))) (if (memv type565 (quote (lexical))) (values (quote lexical-call) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (global))) (values (quote global-call) n562 e552 w554 s555 mod557) (if (memv type565 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b563) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (if (memv type565 (quote (core external-macro module-ref))) (values type565 (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (begin))) (values (quote begin-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (eval-when))) (values (quote eval-when-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?113 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555 mod557)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (if (id?113 name576) (valid-bound-ids?138 (lambda-var-list162 args577)) #f)) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap141 name581 w554 mod557) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap141 (cons args582 (cons e1583 e2584)) w554 mod557)) (quote (())) s555 mod557)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?113 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap141 name590 w554 mod557) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s555 mod557)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e552) (if (memv type565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?113 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555 mod557)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) #f e552 w554 s555 mod557))))))))))))) (values (quote call) #f e552 w554 s555 mod557))) (if (syntax-object?97 e552) (syntax-type147 (syntax-object-expression98 e552) r553 (join-wraps132 w554 (syntax-object-wrap99 e552)) #f rib556 (let ((t599 (syntax-object-module100 e552))) (if t599 t599 mod557))) (if (annotation? e552) (syntax-type147 (annotation-expression e552) r553 w554 (annotation-source e552) rib556 mod557) (if (self-evaluating? e552) (values (quote constant) #f e552 w554 s555 mod557) (values (quote other) #f e552 w554 s555 mod557)))))))) (chi-when-list146 (lambda (e600 when-list601 w602) (letrec ((f603 (lambda (when-list604 situations605) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (if (free-id=?136 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?136 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?136 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e600 (wrap141 x606 w602 #f)))))) situations605)))))) (f603 when-list601 (quote ()))))) (chi-install-global145 (lambda (name607 e608) (build-global-definition88 #f name607 (if (let ((v609 (module-variable (current-module) name607))) (if v609 (if (variable-bound? v609) (if (macro? (variable-ref v609)) (not (eq? (macro-type (variable-ref v609)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref90 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref90 #f (quote module-ref)) (list (build-application81 #f (build-primref90 #f (quote current-module)) (quote ())) (build-data91 #f name607))) (build-data91 #f (quote macro)) e608)) (build-application81 #f (build-primref90 #f (quote make-syncase-macro)) (list (build-data91 #f (quote macro)) e608)))))) (chi-top-sequence144 (lambda (body610 r611 w612 s613 m614 esew615 mod616) (build-sequence92 s613 (letrec ((dobody617 (lambda (body618 r619 w620 m621 esew622 mod623) (if (null? body618) (quote ()) (let ((first624 (chi-top148 (car body618) r619 w620 m621 esew622 mod623))) (cons first624 (dobody617 (cdr body618) r619 w620 m621 esew622 mod623))))))) (dobody617 body610 r611 w612 m614 esew615 mod616))))) (chi-sequence143 (lambda (body625 r626 w627 s628 mod629) (build-sequence92 s628 (letrec ((dobody630 (lambda (body631 r632 w633 mod634) (if (null? body631) (quote ()) (let ((first635 (chi149 (car body631) r632 w633 mod634))) (cons first635 (dobody630 (cdr body631) r632 w633 mod634))))))) (dobody630 body625 r626 w627 mod629))))) (source-wrap142 (lambda (x636 w637 s638 defmod639) (wrap141 (if s638 (make-annotation x636 s638 #f) x636) w637 defmod639))) (wrap141 (lambda (x640 w641 defmod642) (if (if (null? (wrap-marks116 w641)) (null? (wrap-subst117 w641)) #f) x640 (if (syntax-object?97 x640) (make-syntax-object96 (syntax-object-expression98 x640) (join-wraps132 w641 (syntax-object-wrap99 x640)) (syntax-object-module100 x640)) (if (null? x640) x640 (make-syntax-object96 x640 w641 defmod642)))))) (bound-id-member?140 (lambda (x643 list644) (if (not (null? list644)) (let ((t645 (bound-id=?137 x643 (car list644)))) (if t645 t645 (bound-id-member?140 x643 (cdr list644)))) #f))) (distinct-bound-ids?139 (lambda (ids646) (letrec ((distinct?647 (lambda (ids648) (let ((t649 (null? ids648))) (if t649 t649 (if (not (bound-id-member?140 (car ids648) (cdr ids648))) (distinct?647 (cdr ids648)) #f)))))) (distinct?647 ids646)))) (valid-bound-ids?138 (lambda (ids650) (if (letrec ((all-ids?651 (lambda (ids652) (let ((t653 (null? ids652))) (if t653 t653 (if (id?113 (car ids652)) (all-ids?651 (cdr ids652)) #f)))))) (all-ids?651 ids650)) (distinct-bound-ids?139 ids650) #f))) (bound-id=?137 (lambda (i654 j655) (if (if (syntax-object?97 i654) (syntax-object?97 j655) #f) (if (eq? (let ((e656 (syntax-object-expression98 i654))) (if (annotation? e656) (annotation-expression e656) e656)) (let ((e657 (syntax-object-expression98 j655))) (if (annotation? e657) (annotation-expression e657) e657))) (same-marks?134 (wrap-marks116 (syntax-object-wrap99 i654)) (wrap-marks116 (syntax-object-wrap99 j655))) #f) (eq? (let ((e658 i654)) (if (annotation? e658) (annotation-expression e658) e658)) (let ((e659 j655)) (if (annotation? e659) (annotation-expression e659) e659)))))) (free-id=?136 (lambda (i660 j661) (if (eq? (let ((x662 i660)) (let ((e663 (if (syntax-object?97 x662) (syntax-object-expression98 x662) x662))) (if (annotation? e663) (annotation-expression e663) e663))) (let ((x664 j661)) (let ((e665 (if (syntax-object?97 x664) (syntax-object-expression98 x664) x664))) (if (annotation? e665) (annotation-expression e665) e665)))) (eq? (id-var-name135 i660 (quote (()))) (id-var-name135 j661 (quote (())))) #f))) (id-var-name135 (lambda (id666 w667) (letrec ((search-vector-rib670 (lambda (sym676 subst677 marks678 symnames679 ribcage680) (let ((n681 (vector-length symnames679))) (letrec ((f682 (lambda (i683) (if (fx=74 i683 n681) (search668 sym676 (cdr subst677) marks678) (if (if (eq? (vector-ref symnames679 i683) sym676) (same-marks?134 marks678 (vector-ref (ribcage-marks123 ribcage680) i683)) #f) (values (vector-ref (ribcage-labels124 ribcage680) i683) marks678) (f682 (fx+72 i683 1))))))) (f682 0))))) (search-list-rib669 (lambda (sym684 subst685 marks686 symnames687 ribcage688) (letrec ((f689 (lambda (symnames690 i691) (if (null? symnames690) (search668 sym684 (cdr subst685) marks686) (if (if (eq? (car symnames690) sym684) (same-marks?134 marks686 (list-ref (ribcage-marks123 ribcage688) i691)) #f) (values (list-ref (ribcage-labels124 ribcage688) i691) marks686) (f689 (cdr symnames690) (fx+72 i691 1))))))) (f689 symnames687 0)))) (search668 (lambda (sym692 subst693 marks694) (if (null? subst693) (values #f marks694) (let ((fst695 (car subst693))) (if (eq? fst695 (quote shift)) (search668 sym692 (cdr subst693) (cdr marks694)) (let ((symnames696 (ribcage-symnames122 fst695))) (if (vector? symnames696) (search-vector-rib670 sym692 subst693 marks694 symnames696 fst695) (search-list-rib669 sym692 subst693 marks694 symnames696 fst695))))))))) (if (symbol? id666) (let ((t697 (call-with-values (lambda () (search668 id666 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x699 . ignore698) x699)))) (if t697 t697 id666)) (if (syntax-object?97 id666) (let ((id700 (let ((e702 (syntax-object-expression98 id666))) (if (annotation? e702) (annotation-expression e702) e702))) (w1701 (syntax-object-wrap99 id666))) (let ((marks703 (join-marks133 (wrap-marks116 w667) (wrap-marks116 w1701)))) (call-with-values (lambda () (search668 id700 (wrap-subst117 w667) marks703)) (lambda (new-id704 marks705) (let ((t706 new-id704)) (if t706 t706 (let ((t707 (call-with-values (lambda () (search668 id700 (wrap-subst117 w1701) marks705)) (lambda (x709 . ignore708) x709)))) (if t707 t707 id700)))))))) (if (annotation? id666) (let ((id710 (let ((e711 id666)) (if (annotation? e711) (annotation-expression e711) e711)))) (let ((t712 (call-with-values (lambda () (search668 id710 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x714 . ignore713) x714)))) (if t712 t712 id710))) (syntax-violation (quote id-var-name) "invalid id" id666))))))) (same-marks?134 (lambda (x715 y716) (let ((t717 (eq? x715 y716))) (if t717 t717 (if (not (null? x715)) (if (not (null? y716)) (if (eq? (car x715) (car y716)) (same-marks?134 (cdr x715) (cdr y716)) #f) #f) #f))))) (join-marks133 (lambda (m1718 m2719) (smart-append131 m1718 m2719))) (join-wraps132 (lambda (w1720 w2721) (let ((m1722 (wrap-marks116 w1720)) (s1723 (wrap-subst117 w1720))) (if (null? m1722) (if (null? s1723) w2721 (make-wrap115 (wrap-marks116 w2721) (smart-append131 s1723 (wrap-subst117 w2721)))) (make-wrap115 (smart-append131 m1722 (wrap-marks116 w2721)) (smart-append131 s1723 (wrap-subst117 w2721))))))) (smart-append131 (lambda (m1724 m2725) (if (null? m2725) m1724 (append m1724 m2725)))) (make-binding-wrap130 (lambda (ids726 labels727 w728) (if (null? ids726) w728 (make-wrap115 (wrap-marks116 w728) (cons (let ((labelvec729 (list->vector labels727))) (let ((n730 (vector-length labelvec729))) (let ((symnamevec731 (make-vector n730)) (marksvec732 (make-vector n730))) (begin (letrec ((f733 (lambda (ids734 i735) (if (not (null? ids734)) (call-with-values (lambda () (id-sym-name&marks114 (car ids734) w728)) (lambda (symname736 marks737) (begin (vector-set! symnamevec731 i735 symname736) (vector-set! marksvec732 i735 marks737) (f733 (cdr ids734) (fx+72 i735 1))))) (if #f #f))))) (f733 ids726 0)) (make-ribcage120 symnamevec731 marksvec732 labelvec729))))) (wrap-subst117 w728)))))) (extend-ribcage!129 (lambda (ribcage738 id739 label740) (begin (set-ribcage-symnames!125 ribcage738 (cons (let ((e741 (syntax-object-expression98 id739))) (if (annotation? e741) (annotation-expression e741) e741)) (ribcage-symnames122 ribcage738))) (set-ribcage-marks!126 ribcage738 (cons (wrap-marks116 (syntax-object-wrap99 id739)) (ribcage-marks123 ribcage738))) (set-ribcage-labels!127 ribcage738 (cons label740 (ribcage-labels124 ribcage738)))))) (anti-mark128 (lambda (w742) (make-wrap115 (cons #f (wrap-marks116 w742)) (cons (quote shift) (wrap-subst117 w742))))) (set-ribcage-labels!127 (lambda (x743 update744) (vector-set! x743 3 update744))) (set-ribcage-marks!126 (lambda (x745 update746) (vector-set! x745 2 update746))) (set-ribcage-symnames!125 (lambda (x747 update748) (vector-set! x747 1 update748))) (ribcage-labels124 (lambda (x749) (vector-ref x749 3))) (ribcage-marks123 (lambda (x750) (vector-ref x750 2))) (ribcage-symnames122 (lambda (x751) (vector-ref x751 1))) (ribcage?121 (lambda (x752) (if (vector? x752) (if (= (vector-length x752) 4) (eq? (vector-ref x752 0) (quote ribcage)) #f) #f))) (make-ribcage120 (lambda (symnames753 marks754 labels755) (vector (quote ribcage) symnames753 marks754 labels755))) (gen-labels119 (lambda (ls756) (if (null? ls756) (quote ()) (cons (gen-label118) (gen-labels119 (cdr ls756)))))) (gen-label118 (lambda () (string #\i))) (wrap-subst117 cdr) (wrap-marks116 car) (make-wrap115 cons) (id-sym-name&marks114 (lambda (x757 w758) (if (syntax-object?97 x757) (values (let ((e759 (syntax-object-expression98 x757))) (if (annotation? e759) (annotation-expression e759) e759)) (join-marks133 (wrap-marks116 w758) (wrap-marks116 (syntax-object-wrap99 x757)))) (values (let ((e760 x757)) (if (annotation? e760) (annotation-expression e760) e760)) (wrap-marks116 w758))))) (id?113 (lambda (x761) (if (symbol? x761) #t (if (syntax-object?97 x761) (symbol? (let ((e762 (syntax-object-expression98 x761))) (if (annotation? e762) (annotation-expression e762) e762))) (if (annotation? x761) (symbol? (annotation-expression x761)) #f))))) (nonsymbol-id?112 (lambda (x763) (if (syntax-object?97 x763) (symbol? (let ((e764 (syntax-object-expression98 x763))) (if (annotation? e764) (annotation-expression e764) e764))) #f))) (global-extend111 (lambda (type765 sym766 val767) (put-global-definition-hook78 sym766 type765 val767))) (lookup110 (lambda (x768 r769 mod770) (let ((temp771 (assq x768 r769))) (if temp771 (cdr temp771) (if (symbol? x768) (let ((t772 (get-global-definition-hook79 x768 mod770))) (if t772 t772 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env109 (lambda (r773) (if (null? r773) (quote ()) (let ((a774 (car r773))) (if (eq? (cadr a774) (quote macro)) (cons a774 (macros-only-env109 (cdr r773))) (macros-only-env109 (cdr r773))))))) (extend-var-env108 (lambda (labels775 vars776 r777) (if (null? labels775) r777 (extend-var-env108 (cdr labels775) (cdr vars776) (cons (cons (car labels775) (cons (quote lexical) (car vars776))) r777))))) (extend-env107 (lambda (labels778 bindings779 r780) (if (null? labels778) r780 (extend-env107 (cdr labels778) (cdr bindings779) (cons (cons (car labels778) (car bindings779)) r780))))) (binding-value106 cdr) (binding-type105 car) (source-annotation104 (lambda (x781) (if (annotation? x781) (annotation-source x781) (if (syntax-object?97 x781) (source-annotation104 (syntax-object-expression98 x781)) #f)))) (set-syntax-object-module!103 (lambda (x782 update783) (vector-set! x782 3 update783))) (set-syntax-object-wrap!102 (lambda (x784 update785) (vector-set! x784 2 update785))) (set-syntax-object-expression!101 (lambda (x786 update787) (vector-set! x786 1 update787))) (syntax-object-module100 (lambda (x788) (vector-ref x788 3))) (syntax-object-wrap99 (lambda (x789) (vector-ref x789 2))) (syntax-object-expression98 (lambda (x790) (vector-ref x790 1))) (syntax-object?97 (lambda (x791) (if (vector? x791) (if (= (vector-length x791) 4) (eq? (vector-ref x791 0) (quote syntax-object)) #f) #f))) (make-syntax-object96 (lambda (expression792 wrap793 module794) (vector (quote syntax-object) expression792 wrap793 module794))) (build-letrec95 (lambda (src795 ids796 vars797 val-exps798 body-exp799) (if (null? vars797) body-exp799 (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-letrec) src795 ids796 vars797 val-exps798 body-exp799) (list (quote letrec) (map list vars797 val-exps798) body-exp799)))))) (build-named-let94 (lambda (src801 ids802 vars803 val-exps804 body-exp805) (let ((f806 (car vars803)) (f-name807 (car ids802)) (vars808 (cdr vars803)) (ids809 (cdr ids802))) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-letrec) src801 (list f-name807) (list f806) (list (build-lambda89 src801 ids809 vars808 #f body-exp805)) (build-application81 src801 (build-lexical-reference83 (quote fun) src801 f-name807 f806) val-exps804)) (list (quote let) f806 (map list vars808 val-exps804) body-exp805)))))) (build-let93 (lambda (src811 ids812 vars813 val-exps814 body-exp815) (if (null? vars813) body-exp815 (let ((atom-key816 (fluid-ref *mode*71))) (if (memv atom-key816 (quote (c))) ((@ (language tree-il) make-let) src811 ids812 vars813 val-exps814 body-exp815) (list (quote let) (map list vars813 val-exps814) body-exp815)))))) (build-sequence92 (lambda (src817 exps818) (if (null? (cdr exps818)) (car exps818) (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) ((@ (language tree-il) make-sequence) src817 exps818) (cons (quote begin) exps818)))))) (build-data91 (lambda (src820 exp821) (let ((atom-key822 (fluid-ref *mode*71))) (if (memv atom-key822 (quote (c))) ((@ (language tree-il) make-const) src820 exp821) (if (if (self-evaluating? exp821) (not (vector? exp821)) #f) exp821 (list (quote quote) exp821)))))) (build-primref90 (lambda (src823 name824) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src823 name824) name824)) (let ((atom-key826 (fluid-ref *mode*71))) (if (memv atom-key826 (quote (c))) ((@ (language tree-il) make-module-ref) src823 (quote (guile)) name824 #f) (list (quote @@) (quote (guile)) name824)))))) (build-lambda89 (lambda (src827 ids828 vars829 docstring830 exp831) (let ((atom-key832 (fluid-ref *mode*71))) (if (memv atom-key832 (quote (c))) ((@ (language tree-il) make-lambda) src827 ids828 vars829 (if docstring830 (list (cons (quote documentation) docstring830)) (quote ())) exp831) (cons (quote lambda) (cons vars829 (append (if docstring830 (list docstring830) (quote ())) (list exp831)))))))) (build-global-definition88 (lambda (source833 var834 exp835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-define) source833 var834 exp835) (list (quote define) var834 exp835))))) (build-global-assignment87 (lambda (source837 var838 exp839 mod840) (analyze-variable85 mod840 var838 (lambda (mod841 var842 public?843) (let ((atom-key844 (fluid-ref *mode*71))) (if (memv atom-key844 (quote (c))) ((@ (language tree-il) make-module-set) source837 mod841 var842 public?843 exp839) (list (quote set!) (list (if public?843 (quote @) (quote @@)) mod841 var842) exp839)))) (lambda (var845) (let ((atom-key846 (fluid-ref *mode*71))) (if (memv atom-key846 (quote (c))) ((@ (language tree-il) make-toplevel-set) source837 var845 exp839) (list (quote set!) var845 exp839))))))) (build-global-reference86 (lambda (source847 var848 mod849) (analyze-variable85 mod849 var848 (lambda (mod850 var851 public?852) (let ((atom-key853 (fluid-ref *mode*71))) (if (memv atom-key853 (quote (c))) ((@ (language tree-il) make-module-ref) source847 mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851)))) (lambda (var854) (let ((atom-key855 (fluid-ref *mode*71))) (if (memv atom-key855 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source847 var854) var854)))))) (analyze-variable85 (lambda (mod856 var857 modref-cont858 bare-cont859) (if (not mod856) (bare-cont859 var857) (let ((kind860 (car mod856)) (mod861 (cdr mod856))) (if (memv kind860 (quote (public))) (modref-cont858 mod861 var857 #t) (if (memv kind860 (quote (private))) (if (not (equal? mod861 (module-name (current-module)))) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (if (memv kind860 (quote (bare))) (bare-cont859 var857) (if (memv kind860 (quote (hygiene))) (if (if (not (equal? mod861 (module-name (current-module)))) (module-variable (resolve-module mod861) var857) #f) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (syntax-violation #f "bad module kind" var857 mod861))))))))) (build-lexical-assignment84 (lambda (source862 name863 var864 exp865) (let ((atom-key866 (fluid-ref *mode*71))) (if (memv atom-key866 (quote (c))) ((@ (language tree-il) make-lexical-set) source862 name863 var864 exp865) (list (quote set!) var864 exp865))))) (build-lexical-reference83 (lambda (type867 source868 name869 var870) (let ((atom-key871 (fluid-ref *mode*71))) (if (memv atom-key871 (quote (c))) ((@ (language tree-il) make-lexical-ref) source868 name869 var870) var870)))) (build-conditional82 (lambda (source872 test-exp873 then-exp874 else-exp875) (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) make-conditional) source872 test-exp873 then-exp874 else-exp875) (list (quote if) test-exp873 then-exp874 else-exp875))))) (build-application81 (lambda (source877 fun-exp878 arg-exps879) (let ((atom-key880 (fluid-ref *mode*71))) (if (memv atom-key880 (quote (c))) ((@ (language tree-il) make-application) source877 fun-exp878 arg-exps879) (cons fun-exp878 arg-exps879))))) (build-void80 (lambda (source881) (let ((atom-key882 (fluid-ref *mode*71))) (if (memv atom-key882 (quote (c))) ((@ (language tree-il) make-void) source881) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol883 module884) (begin (if (if (not module884) (current-module) #f) (warn "module system is booted, we should have a module" symbol883) (if #f #f)) (let ((v885 (module-variable (if module884 (resolve-module (cdr module884)) (current-module)) symbol883))) (if v885 (if (variable-bound? v885) (let ((val886 (variable-ref v885))) (if (macro? val886) (if (syncase-macro-type val886) (cons (syncase-macro-type val886) (syncase-macro-binding val886)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol887 type888 val889) (let ((existing890 (let ((v891 (module-variable (current-module) symbol887))) (if v891 (if (variable-bound? v891) (let ((val892 (variable-ref v891))) (if (macro? val892) (if (not (syncase-macro-type val892)) val892 #f) #f)) #f) #f)))) (module-define! (current-module) symbol887 (if existing890 (make-extended-syncase-macro existing890 type888 val889) (make-syncase-macro type888 val889)))))) (local-eval-hook77 (lambda (x893 mod894) (primitive-eval (list noexpand70 (let ((atom-key895 (fluid-ref *mode*71))) (if (memv atom-key895 (quote (c))) ((@ (language tree-il) tree-il->scheme) x893) x893)))))) (top-level-eval-hook76 (lambda (x896 mod897) (primitive-eval (list noexpand70 (let ((atom-key898 (fluid-ref *mode*71))) (if (memv atom-key898 (quote (c))) ((@ (language tree-il) tree-il->scheme) x896) x896)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend111 (quote local-syntax) (quote letrec-syntax) #t) (global-extend111 (quote local-syntax) (quote let-syntax) #f) (global-extend111 (quote core) (quote fluid-let-syntax) (lambda (e899 r900 w901 s902 mod903) ((lambda (tmp904) ((lambda (tmp905) (if (if tmp905 (apply (lambda (_906 var907 val908 e1909 e2910) (valid-bound-ids?138 var907)) tmp905) #f) (apply (lambda (_912 var913 val914 e1915 e2916) (let ((names917 (map (lambda (x918) (id-var-name135 x918 w901)) var913))) (begin (for-each (lambda (id920 n921) (let ((atom-key922 (binding-type105 (lookup110 n921 r900 mod903)))) (if (memv atom-key922 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e899 (source-wrap142 id920 w901 s902 mod903)) (if #f #f)))) var913 names917) (chi-body153 (cons e1915 e2916) (source-wrap142 e899 w901 s902 mod903) (extend-env107 names917 (let ((trans-r925 (macros-only-env109 r900))) (map (lambda (x926) (cons (quote macro) (eval-local-transformer156 (chi149 x926 trans-r925 w901 mod903) mod903))) val914)) r900) w901 mod903)))) tmp905) ((lambda (_928) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap142 e899 w901 s902 mod903))) tmp904))) ($sc-dispatch tmp904 (quote (any #(each (any any)) any . each-any))))) e899))) (global-extend111 (quote core) (quote quote) (lambda (e929 r930 w931 s932 mod933) ((lambda (tmp934) ((lambda (tmp935) (if tmp935 (apply (lambda (_936 e937) (build-data91 s932 (strip160 e937 w931))) tmp935) ((lambda (_938) (syntax-violation (quote quote) "bad syntax" (source-wrap142 e929 w931 s932 mod933))) tmp934))) ($sc-dispatch tmp934 (quote (any any))))) e929))) (global-extend111 (quote core) (quote syntax) (letrec ((regen946 (lambda (x947) (let ((atom-key948 (car x947))) (if (memv atom-key948 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x947) (cadr x947)) (if (memv atom-key948 (quote (primitive))) (build-primref90 #f (cadr x947)) (if (memv atom-key948 (quote (quote))) (build-data91 #f (cadr x947)) (if (memv atom-key948 (quote (lambda))) (build-lambda89 #f (cadr x947) (cadr x947) #f (regen946 (caddr x947))) (if (memv atom-key948 (quote (map))) (let ((ls949 (map regen946 (cdr x947)))) (build-application81 #f (build-primref90 #f (quote map)) ls949)) (build-application81 #f (build-primref90 #f (car x947)) (map regen946 (cdr x947))))))))))) (gen-vector945 (lambda (x950) (if (eq? (car x950) (quote list)) (cons (quote vector) (cdr x950)) (if (eq? (car x950) (quote quote)) (list (quote quote) (list->vector (cadr x950))) (list (quote list->vector) x950))))) (gen-append944 (lambda (x951 y952) (if (equal? y952 (quote (quote ()))) x951 (list (quote append) x951 y952)))) (gen-cons943 (lambda (x953 y954) (let ((atom-key955 (car y954))) (if (memv atom-key955 (quote (quote))) (if (eq? (car x953) (quote quote)) (list (quote quote) (cons (cadr x953) (cadr y954))) (if (eq? (cadr y954) (quote ())) (list (quote list) x953) (list (quote cons) x953 y954))) (if (memv atom-key955 (quote (list))) (cons (quote list) (cons x953 (cdr y954))) (list (quote cons) x953 y954)))))) (gen-map942 (lambda (e956 map-env957) (let ((formals958 (map cdr map-env957)) (actuals959 (map (lambda (x960) (list (quote ref) (car x960))) map-env957))) (if (eq? (car e956) (quote ref)) (car actuals959) (if (and-map (lambda (x961) (if (eq? (car x961) (quote ref)) (memq (cadr x961) formals958) #f)) (cdr e956)) (cons (quote map) (cons (list (quote primitive) (car e956)) (map (let ((r962 (map cons formals958 actuals959))) (lambda (x963) (cdr (assq (cadr x963) r962)))) (cdr e956)))) (cons (quote map) (cons (list (quote lambda) formals958 e956) actuals959))))))) (gen-mappend941 (lambda (e964 map-env965) (list (quote apply) (quote (primitive append)) (gen-map942 e964 map-env965)))) (gen-ref940 (lambda (src966 var967 level968 maps969) (if (fx=74 level968 0) (values var967 maps969) (if (null? maps969) (syntax-violation (quote syntax) "missing ellipsis" src966) (call-with-values (lambda () (gen-ref940 src966 var967 (fx-73 level968 1) (cdr maps969))) (lambda (outer-var970 outer-maps971) (let ((b972 (assq outer-var970 (car maps969)))) (if b972 (values (cdr b972) maps969) (let ((inner-var973 (gen-var161 (quote tmp)))) (values inner-var973 (cons (cons (cons outer-var970 inner-var973) (car maps969)) outer-maps971))))))))))) (gen-syntax939 (lambda (src974 e975 r976 maps977 ellipsis?978 mod979) (if (id?113 e975) (let ((label980 (id-var-name135 e975 (quote (()))))) (let ((b981 (lookup110 label980 r976 mod979))) (if (eq? (binding-type105 b981) (quote syntax)) (call-with-values (lambda () (let ((var.lev982 (binding-value106 b981))) (gen-ref940 src974 (car var.lev982) (cdr var.lev982) maps977))) (lambda (var983 maps984) (values (list (quote ref) var983) maps984))) (if (ellipsis?978 e975) (syntax-violation (quote syntax) "misplaced ellipsis" src974) (values (list (quote quote) e975) maps977))))) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 e988) (ellipsis?978 dots987)) tmp986) #f) (apply (lambda (dots989 e990) (gen-syntax939 src974 e990 r976 maps977 (lambda (x991) #f) mod979)) tmp986) ((lambda (tmp992) (if (if tmp992 (apply (lambda (x993 dots994 y995) (ellipsis?978 dots994)) tmp992) #f) (apply (lambda (x996 dots997 y998) (letrec ((f999 (lambda (y1000 k1001) ((lambda (tmp1005) ((lambda (tmp1006) (if (if tmp1006 (apply (lambda (dots1007 y1008) (ellipsis?978 dots1007)) tmp1006) #f) (apply (lambda (dots1009 y1010) (f999 y1010 (lambda (maps1011) (call-with-values (lambda () (k1001 (cons (quote ()) maps1011))) (lambda (x1012 maps1013) (if (null? (car maps1013)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-mappend941 x1012 (car maps1013)) (cdr maps1013)))))))) tmp1006) ((lambda (_1014) (call-with-values (lambda () (gen-syntax939 src974 y1000 r976 maps977 ellipsis?978 mod979)) (lambda (y1015 maps1016) (call-with-values (lambda () (k1001 maps1016)) (lambda (x1017 maps1018) (values (gen-append944 x1017 y1015) maps1018)))))) tmp1005))) ($sc-dispatch tmp1005 (quote (any . any))))) y1000)))) (f999 y998 (lambda (maps1002) (call-with-values (lambda () (gen-syntax939 src974 x996 r976 (cons (quote ()) maps1002) ellipsis?978 mod979)) (lambda (x1003 maps1004) (if (null? (car maps1004)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-map942 x1003 (car maps1004)) (cdr maps1004))))))))) tmp992) ((lambda (tmp1019) (if tmp1019 (apply (lambda (x1020 y1021) (call-with-values (lambda () (gen-syntax939 src974 x1020 r976 maps977 ellipsis?978 mod979)) (lambda (x1022 maps1023) (call-with-values (lambda () (gen-syntax939 src974 y1021 r976 maps1023 ellipsis?978 mod979)) (lambda (y1024 maps1025) (values (gen-cons943 x1022 y1024) maps1025)))))) tmp1019) ((lambda (tmp1026) (if tmp1026 (apply (lambda (e11027 e21028) (call-with-values (lambda () (gen-syntax939 src974 (cons e11027 e21028) r976 maps977 ellipsis?978 mod979)) (lambda (e1030 maps1031) (values (gen-vector945 e1030) maps1031)))) tmp1026) ((lambda (_1032) (values (list (quote quote) e975) maps977)) tmp985))) ($sc-dispatch tmp985 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp985 (quote (any . any)))))) ($sc-dispatch tmp985 (quote (any any . any)))))) ($sc-dispatch tmp985 (quote (any any))))) e975))))) (lambda (e1033 r1034 w1035 s1036 mod1037) (let ((e1038 (source-wrap142 e1033 w1035 s1036 mod1037))) ((lambda (tmp1039) ((lambda (tmp1040) (if tmp1040 (apply (lambda (_1041 x1042) (call-with-values (lambda () (gen-syntax939 e1038 x1042 r1034 (quote ()) ellipsis?158 mod1037)) (lambda (e1043 maps1044) (regen946 e1043)))) tmp1040) ((lambda (_1045) (syntax-violation (quote syntax) "bad `syntax' form" e1038)) tmp1039))) ($sc-dispatch tmp1039 (quote (any any))))) e1038))))) (global-extend111 (quote core) (quote lambda) (lambda (e1046 r1047 w1048 s1049 mod1050) ((lambda (tmp1051) ((lambda (tmp1052) (if tmp1052 (apply (lambda (_1053 c1054) (chi-lambda-clause154 (source-wrap142 e1046 w1048 s1049 mod1050) #f c1054 r1047 w1048 mod1050 (lambda (names1055 vars1056 docstring1057 body1058) (build-lambda89 s1049 names1055 vars1056 docstring1057 body1058)))) tmp1052) (syntax-violation #f "source expression failed to match any pattern" tmp1051))) ($sc-dispatch tmp1051 (quote (any . any))))) e1046))) (global-extend111 (quote core) (quote let) (letrec ((chi-let1059 (lambda (e1060 r1061 w1062 s1063 mod1064 constructor1065 ids1066 vals1067 exps1068) (if (not (valid-bound-ids?138 ids1066)) (syntax-violation (quote let) "duplicate bound variable" e1060) (let ((labels1069 (gen-labels119 ids1066)) (new-vars1070 (map gen-var161 ids1066))) (let ((nw1071 (make-binding-wrap130 ids1066 labels1069 w1062)) (nr1072 (extend-var-env108 labels1069 new-vars1070 r1061))) (constructor1065 s1063 (map syntax->datum ids1066) new-vars1070 (map (lambda (x1073) (chi149 x1073 r1061 w1062 mod1064)) vals1067) (chi-body153 exps1068 (source-wrap142 e1060 nw1071 s1063 mod1064) nr1072 nw1071 mod1064)))))))) (lambda (e1074 r1075 w1076 s1077 mod1078) ((lambda (tmp1079) ((lambda (tmp1080) (if tmp1080 (apply (lambda (_1081 id1082 val1083 e11084 e21085) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-let93 id1082 val1083 (cons e11084 e21085))) tmp1080) ((lambda (tmp1089) (if (if tmp1089 (apply (lambda (_1090 f1091 id1092 val1093 e11094 e21095) (id?113 f1091)) tmp1089) #f) (apply (lambda (_1096 f1097 id1098 val1099 e11100 e21101) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-named-let94 (cons f1097 id1098) val1099 (cons e11100 e21101))) tmp1089) ((lambda (_1105) (syntax-violation (quote let) "bad let" (source-wrap142 e1074 w1076 s1077 mod1078))) tmp1079))) ($sc-dispatch tmp1079 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1079 (quote (any #(each (any any)) any . each-any))))) e1074)))) (global-extend111 (quote core) (quote letrec) (lambda (e1106 r1107 w1108 s1109 mod1110) ((lambda (tmp1111) ((lambda (tmp1112) (if tmp1112 (apply (lambda (_1113 id1114 val1115 e11116 e21117) (let ((ids1118 id1114)) (if (not (valid-bound-ids?138 ids1118)) (syntax-violation (quote letrec) "duplicate bound variable" e1106) (let ((labels1120 (gen-labels119 ids1118)) (new-vars1121 (map gen-var161 ids1118))) (let ((w1122 (make-binding-wrap130 ids1118 labels1120 w1108)) (r1123 (extend-var-env108 labels1120 new-vars1121 r1107))) (build-letrec95 s1109 (map syntax->datum ids1118) new-vars1121 (map (lambda (x1124) (chi149 x1124 r1123 w1122 mod1110)) val1115) (chi-body153 (cons e11116 e21117) (source-wrap142 e1106 w1122 s1109 mod1110) r1123 w1122 mod1110))))))) tmp1112) ((lambda (_1127) (syntax-violation (quote letrec) "bad letrec" (source-wrap142 e1106 w1108 s1109 mod1110))) tmp1111))) ($sc-dispatch tmp1111 (quote (any #(each (any any)) any . each-any))))) e1106))) (global-extend111 (quote core) (quote set!) (lambda (e1128 r1129 w1130 s1131 mod1132) ((lambda (tmp1133) ((lambda (tmp1134) (if (if tmp1134 (apply (lambda (_1135 id1136 val1137) (id?113 id1136)) tmp1134) #f) (apply (lambda (_1138 id1139 val1140) (let ((val1141 (chi149 val1140 r1129 w1130 mod1132)) (n1142 (id-var-name135 id1139 w1130))) (let ((b1143 (lookup110 n1142 r1129 mod1132))) (let ((atom-key1144 (binding-type105 b1143))) (if (memv atom-key1144 (quote (lexical))) (build-lexical-assignment84 s1131 (syntax->datum id1139) (binding-value106 b1143) val1141) (if (memv atom-key1144 (quote (global))) (build-global-assignment87 s1131 n1142 val1141 mod1132) (if (memv atom-key1144 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap141 id1139 w1130 mod1132)) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))))))))) tmp1134) ((lambda (tmp1145) (if tmp1145 (apply (lambda (_1146 head1147 tail1148 val1149) (call-with-values (lambda () (syntax-type147 head1147 r1129 (quote (())) #f #f mod1132)) (lambda (type1150 value1151 ee1152 ww1153 ss1154 modmod1155) (if (memv type1150 (quote (module-ref))) (let ((val1156 (chi149 val1149 r1129 w1130 mod1132))) (call-with-values (lambda () (value1151 (cons head1147 tail1148))) (lambda (id1158 mod1159) (build-global-assignment87 s1131 id1158 val1156 mod1159)))) (build-application81 s1131 (chi149 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1147) r1129 w1130 mod1132) (map (lambda (e1160) (chi149 e1160 r1129 w1130 mod1132)) (append tail1148 (list val1149)))))))) tmp1145) ((lambda (_1162) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))) tmp1133))) ($sc-dispatch tmp1133 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1133 (quote (any any any))))) e1128))) (global-extend111 (quote module-ref) (quote @) (lambda (e1163) ((lambda (tmp1164) ((lambda (tmp1165) (if (if tmp1165 (apply (lambda (_1166 mod1167 id1168) (if (and-map id?113 mod1167) (id?113 id1168) #f)) tmp1165) #f) (apply (lambda (_1170 mod1171 id1172) (values (syntax->datum id1172) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1171)))) tmp1165) (syntax-violation #f "source expression failed to match any pattern" tmp1164))) ($sc-dispatch tmp1164 (quote (any each-any any))))) e1163))) (global-extend111 (quote module-ref) (quote @@) (lambda (e1174) ((lambda (tmp1175) ((lambda (tmp1176) (if (if tmp1176 (apply (lambda (_1177 mod1178 id1179) (if (and-map id?113 mod1178) (id?113 id1179) #f)) tmp1176) #f) (apply (lambda (_1181 mod1182 id1183) (values (syntax->datum id1183) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1182)))) tmp1176) (syntax-violation #f "source expression failed to match any pattern" tmp1175))) ($sc-dispatch tmp1175 (quote (any each-any any))))) e1174))) (global-extend111 (quote core) (quote if) (lambda (e1185 r1186 w1187 s1188 mod1189) ((lambda (tmp1190) ((lambda (tmp1191) (if tmp1191 (apply (lambda (_1192 test1193 then1194) (build-conditional82 s1188 (chi149 test1193 r1186 w1187 mod1189) (chi149 then1194 r1186 w1187 mod1189) (build-void80 #f))) tmp1191) ((lambda (tmp1195) (if tmp1195 (apply (lambda (_1196 test1197 then1198 else1199) (build-conditional82 s1188 (chi149 test1197 r1186 w1187 mod1189) (chi149 then1198 r1186 w1187 mod1189) (chi149 else1199 r1186 w1187 mod1189))) tmp1195) (syntax-violation #f "source expression failed to match any pattern" tmp1190))) ($sc-dispatch tmp1190 (quote (any any any any)))))) ($sc-dispatch tmp1190 (quote (any any any))))) e1185))) (global-extend111 (quote begin) (quote begin) (quote ())) (global-extend111 (quote define) (quote define) (quote ())) (global-extend111 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend111 (quote eval-when) (quote eval-when) (quote ())) (global-extend111 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1203 (lambda (x1204 keys1205 clauses1206 r1207 mod1208) (if (null? clauses1206) (build-application81 #f (build-primref90 #f (quote syntax-violation)) (list (build-data91 #f #f) (build-data91 #f "source expression failed to match any pattern") x1204)) ((lambda (tmp1209) ((lambda (tmp1210) (if tmp1210 (apply (lambda (pat1211 exp1212) (if (if (id?113 pat1211) (and-map (lambda (x1213) (not (free-id=?136 pat1211 x1213))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1205)) #f) (let ((labels1214 (list (gen-label118))) (var1215 (gen-var161 pat1211))) (build-application81 #f (build-lambda89 #f (list (syntax->datum pat1211)) (list var1215) #f (chi149 exp1212 (extend-env107 labels1214 (list (cons (quote syntax) (cons var1215 0))) r1207) (make-binding-wrap130 (list pat1211) labels1214 (quote (()))) mod1208)) (list x1204))) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1211 #t exp1212 mod1208))) tmp1210) ((lambda (tmp1216) (if tmp1216 (apply (lambda (pat1217 fender1218 exp1219) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1217 fender1218 exp1219 mod1208)) tmp1216) ((lambda (_1220) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1206))) tmp1209))) ($sc-dispatch tmp1209 (quote (any any any)))))) ($sc-dispatch tmp1209 (quote (any any))))) (car clauses1206))))) (gen-clause1202 (lambda (x1221 keys1222 clauses1223 r1224 pat1225 fender1226 exp1227 mod1228) (call-with-values (lambda () (convert-pattern1200 pat1225 keys1222)) (lambda (p1229 pvars1230) (if (not (distinct-bound-ids?139 (map car pvars1230))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1225) (if (not (and-map (lambda (x1231) (not (ellipsis?158 (car x1231)))) pvars1230)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1225) (let ((y1232 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda89 #f (list (quote tmp)) (list y1232) #f (let ((y1233 (build-lexical-reference83 (quote value) #f (quote tmp) y1232))) (build-conditional82 #f ((lambda (tmp1234) ((lambda (tmp1235) (if tmp1235 (apply (lambda () y1233) tmp1235) ((lambda (_1236) (build-conditional82 #f y1233 (build-dispatch-call1201 pvars1230 fender1226 y1233 r1224 mod1228) (build-data91 #f #f))) tmp1234))) ($sc-dispatch tmp1234 (quote #(atom #t))))) fender1226) (build-dispatch-call1201 pvars1230 exp1227 y1233 r1224 mod1228) (gen-syntax-case1203 x1221 keys1222 clauses1223 r1224 mod1228)))) (list (if (eq? p1229 (quote any)) (build-application81 #f (build-primref90 #f (quote list)) (list x1221)) (build-application81 #f (build-primref90 #f (quote $sc-dispatch)) (list x1221 (build-data91 #f p1229))))))))))))) (build-dispatch-call1201 (lambda (pvars1237 exp1238 y1239 r1240 mod1241) (let ((ids1242 (map car pvars1237)) (levels1243 (map cdr pvars1237))) (let ((labels1244 (gen-labels119 ids1242)) (new-vars1245 (map gen-var161 ids1242))) (build-application81 #f (build-primref90 #f (quote apply)) (list (build-lambda89 #f (map syntax->datum ids1242) new-vars1245 #f (chi149 exp1238 (extend-env107 labels1244 (map (lambda (var1246 level1247) (cons (quote syntax) (cons var1246 level1247))) new-vars1245 (map cdr pvars1237)) r1240) (make-binding-wrap130 ids1242 labels1244 (quote (()))) mod1241)) y1239)))))) (convert-pattern1200 (lambda (pattern1248 keys1249) (letrec ((cvt1250 (lambda (p1251 n1252 ids1253) (if (id?113 p1251) (if (bound-id-member?140 p1251 keys1249) (values (vector (quote free-id) p1251) ids1253) (values (quote any) (cons (cons p1251 n1252) ids1253))) ((lambda (tmp1254) ((lambda (tmp1255) (if (if tmp1255 (apply (lambda (x1256 dots1257) (ellipsis?158 dots1257)) tmp1255) #f) (apply (lambda (x1258 dots1259) (call-with-values (lambda () (cvt1250 x1258 (fx+72 n1252 1) ids1253)) (lambda (p1260 ids1261) (values (if (eq? p1260 (quote any)) (quote each-any) (vector (quote each) p1260)) ids1261)))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda (x1263 y1264) (call-with-values (lambda () (cvt1250 y1264 n1252 ids1253)) (lambda (y1265 ids1266) (call-with-values (lambda () (cvt1250 x1263 n1252 ids1266)) (lambda (x1267 ids1268) (values (cons x1267 y1265) ids1268)))))) tmp1262) ((lambda (tmp1269) (if tmp1269 (apply (lambda () (values (quote ()) ids1253)) tmp1269) ((lambda (tmp1270) (if tmp1270 (apply (lambda (x1271) (call-with-values (lambda () (cvt1250 x1271 n1252 ids1253)) (lambda (p1273 ids1274) (values (vector (quote vector) p1273) ids1274)))) tmp1270) ((lambda (x1275) (values (vector (quote atom) (strip160 p1251 (quote (())))) ids1253)) tmp1254))) ($sc-dispatch tmp1254 (quote #(vector each-any)))))) ($sc-dispatch tmp1254 (quote ()))))) ($sc-dispatch tmp1254 (quote (any . any)))))) ($sc-dispatch tmp1254 (quote (any any))))) p1251))))) (cvt1250 pattern1248 0 (quote ())))))) (lambda (e1276 r1277 w1278 s1279 mod1280) (let ((e1281 (source-wrap142 e1276 w1278 s1279 mod1280))) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (_1284 val1285 key1286 m1287) (if (and-map (lambda (x1288) (if (id?113 x1288) (not (ellipsis?158 x1288)) #f)) key1286) (let ((x1290 (gen-var161 (quote tmp)))) (build-application81 s1279 (build-lambda89 #f (list (quote tmp)) (list x1290) #f (gen-syntax-case1203 (build-lexical-reference83 (quote value) #f (quote tmp) x1290) key1286 m1287 r1277 mod1280)) (list (chi149 val1285 r1277 (quote (())) mod1280)))) (syntax-violation (quote syntax-case) "invalid literals list" e1281))) tmp1283) (syntax-violation #f "source expression failed to match any pattern" tmp1282))) ($sc-dispatch tmp1282 (quote (any any each-any . each-any))))) e1281))))) (set! sc-expand (lambda (x1294 . rest1293) (if (if (pair? x1294) (equal? (car x1294) noexpand70) #f) (cadr x1294) (let ((m1295 (if (null? rest1293) (quote e) (car rest1293))) (esew1296 (if (let ((t1297 (null? rest1293))) (if t1297 t1297 (null? (cdr rest1293)))) (quote (eval)) (cadr rest1293)))) (with-fluid* *mode*71 m1295 (lambda () (chi-top148 x1294 (quote ()) (quote ((top))) m1295 esew1296 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1298) (nonsymbol-id?112 x1298))) (set! datum->syntax (lambda (id1299 datum1300) (make-syntax-object96 datum1300 (syntax-object-wrap99 id1299) #f))) (set! syntax->datum (lambda (x1301) (strip160 x1301 (quote (()))))) (set! generate-temporaries (lambda (ls1302) (begin (let ((x1303 ls1302)) (if (not (list? x1303)) (syntax-violation (quote generate-temporaries) "invalid argument" x1303) (if #f #f))) (map (lambda (x1304) (wrap141 (gensym) (quote ((top))) #f)) ls1302)))) (set! free-identifier=? (lambda (x1305 y1306) (begin (let ((x1307 x1305)) (if (not (nonsymbol-id?112 x1307)) (syntax-violation (quote free-identifier=?) "invalid argument" x1307) (if #f #f))) (let ((x1308 y1306)) (if (not (nonsymbol-id?112 x1308)) (syntax-violation (quote free-identifier=?) "invalid argument" x1308) (if #f #f))) (free-id=?136 x1305 y1306)))) (set! bound-identifier=? (lambda (x1309 y1310) (begin (let ((x1311 x1309)) (if (not (nonsymbol-id?112 x1311)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1311) (if #f #f))) (let ((x1312 y1310)) (if (not (nonsymbol-id?112 x1312)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1312) (if #f #f))) (bound-id=?137 x1309 y1310)))) (set! syntax-violation (lambda (who1316 message1315 form1314 . subform1313) (begin (let ((x1317 who1316)) (if (not ((lambda (x1318) (let ((t1319 (not x1318))) (if t1319 t1319 (let ((t1320 (string? x1318))) (if t1320 t1320 (symbol? x1318)))))) x1317)) (syntax-violation (quote syntax-violation) "invalid argument" x1317) (if #f #f))) (let ((x1321 message1315)) (if (not (string? x1321)) (syntax-violation (quote syntax-violation) "invalid argument" x1321) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1316 "~a: " "") "~a " (if (null? subform1313) "in ~a" "in subform `~s' of `~s'")) (let ((tail1322 (cons message1315 (map (lambda (x1323) (strip160 x1323 (quote (())))) (append subform1313 (list form1314)))))) (if who1316 (cons who1316 tail1322) tail1322)) #f)))) (letrec ((match1328 (lambda (e1329 p1330 w1331 r1332 mod1333) (if (not r1332) #f (if (eq? p1330 (quote any)) (cons (wrap141 e1329 w1331 mod1333) r1332) (if (syntax-object?97 e1329) (match*1327 (let ((e1334 (syntax-object-expression98 e1329))) (if (annotation? e1334) (annotation-expression e1334) e1334)) p1330 (join-wraps132 w1331 (syntax-object-wrap99 e1329)) r1332 (syntax-object-module100 e1329)) (match*1327 (let ((e1335 e1329)) (if (annotation? e1335) (annotation-expression e1335) e1335)) p1330 w1331 r1332 mod1333)))))) (match*1327 (lambda (e1336 p1337 w1338 r1339 mod1340) (if (null? p1337) (if (null? e1336) r1339 #f) (if (pair? p1337) (if (pair? e1336) (match1328 (car e1336) (car p1337) w1338 (match1328 (cdr e1336) (cdr p1337) w1338 r1339 mod1340) mod1340) #f) (if (eq? p1337 (quote each-any)) (let ((l1341 (match-each-any1325 e1336 w1338 mod1340))) (if l1341 (cons l1341 r1339) #f)) (let ((atom-key1342 (vector-ref p1337 0))) (if (memv atom-key1342 (quote (each))) (if (null? e1336) (match-empty1326 (vector-ref p1337 1) r1339) (let ((l1343 (match-each1324 e1336 (vector-ref p1337 1) w1338 mod1340))) (if l1343 (letrec ((collect1344 (lambda (l1345) (if (null? (car l1345)) r1339 (cons (map car l1345) (collect1344 (map cdr l1345))))))) (collect1344 l1343)) #f))) (if (memv atom-key1342 (quote (free-id))) (if (id?113 e1336) (if (free-id=?136 (wrap141 e1336 w1338 mod1340) (vector-ref p1337 1)) r1339 #f) #f) (if (memv atom-key1342 (quote (atom))) (if (equal? (vector-ref p1337 1) (strip160 e1336 w1338)) r1339 #f) (if (memv atom-key1342 (quote (vector))) (if (vector? e1336) (match1328 (vector->list e1336) (vector-ref p1337 1) w1338 r1339 mod1340) #f) (if #f #f))))))))))) (match-empty1326 (lambda (p1346 r1347) (if (null? p1346) r1347 (if (eq? p1346 (quote any)) (cons (quote ()) r1347) (if (pair? p1346) (match-empty1326 (car p1346) (match-empty1326 (cdr p1346) r1347)) (if (eq? p1346 (quote each-any)) (cons (quote ()) r1347) (let ((atom-key1348 (vector-ref p1346 0))) (if (memv atom-key1348 (quote (each))) (match-empty1326 (vector-ref p1346 1) r1347) (if (memv atom-key1348 (quote (free-id atom))) r1347 (if (memv atom-key1348 (quote (vector))) (match-empty1326 (vector-ref p1346 1) r1347) (if #f #f))))))))))) (match-each-any1325 (lambda (e1349 w1350 mod1351) (if (annotation? e1349) (match-each-any1325 (annotation-expression e1349) w1350 mod1351) (if (pair? e1349) (let ((l1352 (match-each-any1325 (cdr e1349) w1350 mod1351))) (if l1352 (cons (wrap141 (car e1349) w1350 mod1351) l1352) #f)) (if (null? e1349) (quote ()) (if (syntax-object?97 e1349) (match-each-any1325 (syntax-object-expression98 e1349) (join-wraps132 w1350 (syntax-object-wrap99 e1349)) mod1351) #f)))))) (match-each1324 (lambda (e1353 p1354 w1355 mod1356) (if (annotation? e1353) (match-each1324 (annotation-expression e1353) p1354 w1355 mod1356) (if (pair? e1353) (let ((first1357 (match1328 (car e1353) p1354 w1355 (quote ()) mod1356))) (if first1357 (let ((rest1358 (match-each1324 (cdr e1353) p1354 w1355 mod1356))) (if rest1358 (cons first1357 rest1358) #f)) #f)) (if (null? e1353) (quote ()) (if (syntax-object?97 e1353) (match-each1324 (syntax-object-expression98 e1353) p1354 (join-wraps132 w1355 (syntax-object-wrap99 e1353)) (syntax-object-module100 e1353)) #f))))))) (set! $sc-dispatch (lambda (e1359 p1360) (if (eq? p1360 (quote any)) (list e1359) (if (syntax-object?97 e1359) (match*1327 (let ((e1361 (syntax-object-expression98 e1359))) (if (annotation? e1361) (annotation-expression e1361) e1361)) p1360 (syntax-object-wrap99 e1359) (quote ()) (syntax-object-module100 e1359)) (match*1327 (let ((e1362 e1359)) (if (annotation? e1362) (annotation-expression e1362) e1362)) p1360 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1363) ((lambda (tmp1364) ((lambda (tmp1365) (if tmp1365 (apply (lambda (_1366 e11367 e21368) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11367 e21368))) tmp1365) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 out1372 in1373 e11374 e21375) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1373 (quote ()) (list out1372 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11374 e21375))))) tmp1370) ((lambda (tmp1377) (if tmp1377 (apply (lambda (_1378 out1379 in1380 e11381 e21382) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1380) (quote ()) (list out1379 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11381 e21382))))) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1364))) ($sc-dispatch tmp1364 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1364 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1364 (quote (any () any . each-any))))) x1363)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1386) ((lambda (tmp1387) ((lambda (tmp1388) (if tmp1388 (apply (lambda (_1389 k1390 keyword1391 pattern1392 template1393) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1390 (map (lambda (tmp1396 tmp1395) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1395) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1396))) template1393 pattern1392)))))) tmp1388) (syntax-violation #f "source expression failed to match any pattern" tmp1387))) ($sc-dispatch tmp1387 (quote (any each-any . #(each ((any . any) any))))))) x1386)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1397) ((lambda (tmp1398) ((lambda (tmp1399) (if (if tmp1399 (apply (lambda (let*1400 x1401 v1402 e11403 e21404) (and-map identifier? x1401)) tmp1399) #f) (apply (lambda (let*1406 x1407 v1408 e11409 e21410) (letrec ((f1411 (lambda (bindings1412) (if (null? bindings1412) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11409 e21410))) ((lambda (tmp1416) ((lambda (tmp1417) (if tmp1417 (apply (lambda (body1418 binding1419) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1419) body1418)) tmp1417) (syntax-violation #f "source expression failed to match any pattern" tmp1416))) ($sc-dispatch tmp1416 (quote (any any))))) (list (f1411 (cdr bindings1412)) (car bindings1412))))))) (f1411 (map list x1407 v1408)))) tmp1399) (syntax-violation #f "source expression failed to match any pattern" tmp1398))) ($sc-dispatch tmp1398 (quote (any #(each (any any)) any . each-any))))) x1397)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1420) ((lambda (tmp1421) ((lambda (tmp1422) (if tmp1422 (apply (lambda (_1423 var1424 init1425 step1426 e01427 e11428 c1429) ((lambda (tmp1430) ((lambda (tmp1431) (if tmp1431 (apply (lambda (step1432) ((lambda (tmp1433) ((lambda (tmp1434) (if tmp1434 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1424 init1425) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01427) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1429 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1432))))))) tmp1434) ((lambda (tmp1439) (if tmp1439 (apply (lambda (e11440 e21441) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1424 init1425) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01427 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11440 e21441)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1429 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1432))))))) tmp1439) (syntax-violation #f "source expression failed to match any pattern" tmp1433))) ($sc-dispatch tmp1433 (quote (any . each-any)))))) ($sc-dispatch tmp1433 (quote ())))) e11428)) tmp1431) (syntax-violation #f "source expression failed to match any pattern" tmp1430))) ($sc-dispatch tmp1430 (quote each-any)))) (map (lambda (v1448 s1449) ((lambda (tmp1450) ((lambda (tmp1451) (if tmp1451 (apply (lambda () v1448) tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda (e1453) e1453) tmp1452) ((lambda (_1454) (syntax-violation (quote do) "bad step expression" orig-x1420 s1449)) tmp1450))) ($sc-dispatch tmp1450 (quote (any)))))) ($sc-dispatch tmp1450 (quote ())))) s1449)) var1424 step1426))) tmp1422) (syntax-violation #f "source expression failed to match any pattern" tmp1421))) ($sc-dispatch tmp1421 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1420)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1457 (lambda (x1461 y1462) ((lambda (tmp1463) ((lambda (tmp1464) (if tmp1464 (apply (lambda (x1465 y1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda (dy1469) ((lambda (tmp1470) ((lambda (tmp1471) (if tmp1471 (apply (lambda (dx1472) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1472 dy1469))) tmp1471) ((lambda (_1473) (if (null? dy1469) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465 y1466))) tmp1470))) ($sc-dispatch tmp1470 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1465)) tmp1468) ((lambda (tmp1474) (if tmp1474 (apply (lambda (stuff1475) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1465 stuff1475))) tmp1474) ((lambda (else1476) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465 y1466)) tmp1467))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1466)) tmp1464) (syntax-violation #f "source expression failed to match any pattern" tmp1463))) ($sc-dispatch tmp1463 (quote (any any))))) (list x1461 y1462)))) (quasiappend1458 (lambda (x1477 y1478) ((lambda (tmp1479) ((lambda (tmp1480) (if tmp1480 (apply (lambda (x1481 y1482) ((lambda (tmp1483) ((lambda (tmp1484) (if tmp1484 (apply (lambda () x1481) tmp1484) ((lambda (_1485) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1481 y1482)) tmp1483))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1482)) tmp1480) (syntax-violation #f "source expression failed to match any pattern" tmp1479))) ($sc-dispatch tmp1479 (quote (any any))))) (list x1477 y1478)))) (quasivector1459 (lambda (x1486) ((lambda (tmp1487) ((lambda (x1488) ((lambda (tmp1489) ((lambda (tmp1490) (if tmp1490 (apply (lambda (x1491) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1491))) tmp1490) ((lambda (tmp1493) (if tmp1493 (apply (lambda (x1494) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1494)) tmp1493) ((lambda (_1496) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1488)) tmp1489))) ($sc-dispatch tmp1489 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1489 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1488)) tmp1487)) x1486))) (quasi1460 (lambda (p1497 lev1498) ((lambda (tmp1499) ((lambda (tmp1500) (if tmp1500 (apply (lambda (p1501) (if (= lev1498 0) p1501 (quasicons1457 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1460 (list p1501) (- lev1498 1))))) tmp1500) ((lambda (tmp1502) (if (if tmp1502 (apply (lambda (args1503) (= lev1498 0)) tmp1502) #f) (apply (lambda (args1504) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1497 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1504))) tmp1502) ((lambda (tmp1505) (if tmp1505 (apply (lambda (p1506 q1507) (if (= lev1498 0) (quasiappend1458 p1506 (quasi1460 q1507 lev1498)) (quasicons1457 (quasicons1457 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1460 (list p1506) (- lev1498 1))) (quasi1460 q1507 lev1498)))) tmp1505) ((lambda (tmp1508) (if (if tmp1508 (apply (lambda (args1509 q1510) (= lev1498 0)) tmp1508) #f) (apply (lambda (args1511 q1512) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1497 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1511))) tmp1508) ((lambda (tmp1513) (if tmp1513 (apply (lambda (p1514) (quasicons1457 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1460 (list p1514) (+ lev1498 1)))) tmp1513) ((lambda (tmp1515) (if tmp1515 (apply (lambda (p1516 q1517) (quasicons1457 (quasi1460 p1516 lev1498) (quasi1460 q1517 lev1498))) tmp1515) ((lambda (tmp1518) (if tmp1518 (apply (lambda (x1519) (quasivector1459 (quasi1460 x1519 lev1498))) tmp1518) ((lambda (p1521) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1521)) tmp1499))) ($sc-dispatch tmp1499 (quote #(vector each-any)))))) ($sc-dispatch tmp1499 (quote (any . any)))))) ($sc-dispatch tmp1499 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1499 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1499 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1499 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1499 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1497)))) (lambda (x1522) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (_1525 e1526) (quasi1460 e1526 0)) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote (any any))))) x1522))))) +(define include (make-syncase-macro (quote macro) (lambda (x1527) (letrec ((read-file1528 (lambda (fn1529 k1530) (let ((p1531 (open-input-file fn1529))) (letrec ((f1532 (lambda (x1533) (if (eof-object? x1533) (begin (close-input-port p1531) (quote ())) (cons (datum->syntax k1530 x1533) (f1532 (read p1531))))))) (f1532 (read p1531))))))) ((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (k1536 filename1537) (let ((fn1538 (syntax->datum filename1537))) ((lambda (tmp1539) ((lambda (tmp1540) (if tmp1540 (apply (lambda (exp1541) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1541)) tmp1540) (syntax-violation #f "source expression failed to match any pattern" tmp1539))) ($sc-dispatch tmp1539 (quote each-any)))) (read-file1528 fn1538 k1536)))) tmp1535) (syntax-violation #f "source expression failed to match any pattern" tmp1534))) ($sc-dispatch tmp1534 (quote (any any))))) x1527))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1543) ((lambda (tmp1544) ((lambda (tmp1545) (if tmp1545 (apply (lambda (_1546 e1547) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1543)) tmp1545) (syntax-violation #f "source expression failed to match any pattern" tmp1544))) ($sc-dispatch tmp1544 (quote (any any))))) x1543)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1548) ((lambda (tmp1549) ((lambda (tmp1550) (if tmp1550 (apply (lambda (_1551 e1552) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1548)) tmp1550) (syntax-violation #f "source expression failed to match any pattern" tmp1549))) ($sc-dispatch tmp1549 (quote (any any))))) x1548)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1553) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 e1557 m11558 m21559) ((lambda (tmp1560) ((lambda (body1561) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1557)) body1561)) tmp1560)) (letrec ((f1562 (lambda (clause1563 clauses1564) (if (null? clauses1564) ((lambda (tmp1566) ((lambda (tmp1567) (if tmp1567 (apply (lambda (e11568 e21569) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11568 e21569))) tmp1567) ((lambda (tmp1571) (if tmp1571 (apply (lambda (k1572 e11573 e21574) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1572)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11573 e21574)))) tmp1571) ((lambda (_1577) (syntax-violation (quote case) "bad clause" x1553 clause1563)) tmp1566))) ($sc-dispatch tmp1566 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1566 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1563) ((lambda (tmp1578) ((lambda (rest1579) ((lambda (tmp1580) ((lambda (tmp1581) (if tmp1581 (apply (lambda (k1582 e11583 e21584) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1582)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11583 e21584)) rest1579)) tmp1581) ((lambda (_1587) (syntax-violation (quote case) "bad clause" x1553 clause1563)) tmp1580))) ($sc-dispatch tmp1580 (quote (each-any any . each-any))))) clause1563)) tmp1578)) (f1562 (car clauses1564) (cdr clauses1564))))))) (f1562 m11558 m21559)))) tmp1555) (syntax-violation #f "source expression failed to match any pattern" tmp1554))) ($sc-dispatch tmp1554 (quote (any any any . each-any))))) x1553)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1588) ((lambda (tmp1589) ((lambda (tmp1590) (if tmp1590 (apply (lambda (_1591 e1592) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1592)) (list (cons _1591 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1592 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1590) (syntax-violation #f "source expression failed to match any pattern" tmp1589))) ($sc-dispatch tmp1589 (quote (any any))))) x1588)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index dc8e93e51..0ce74a790 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2355,12 +2355,22 @@ (syntax p) (quasicons (syntax (quote unquote)) (quasi (syntax (p)) (- lev 1))))) + ((unquote . args) + (= lev 0) + (syntax-violation 'unquote + "unquote takes exactly one argument" + p (syntax (unquote . args)))) (((unquote-splicing p) . q) (if (= lev 0) (quasiappend (syntax p) (quasi (syntax q) lev)) (quasicons (quasicons (syntax (quote unquote-splicing)) (quasi (syntax (p)) (- lev 1))) (quasi (syntax q) lev)))) + (((unquote-splicing . args) . q) + (= lev 0) + (syntax-violation 'unquote-splicing + "unquote-splicing takes exactly one argument" + p (syntax (unquote-splicing . args)))) ((quasiquote p) (quasicons (syntax (quote quasiquote)) (quasi (syntax (p)) (+ lev 1)))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 2f6eb2433..9176a3c4e 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -21,6 +21,11 @@ :use-module (test-suite lib)) +(define exception:generic-syncase-error + (cons 'syntax-error "Source expression failed to match")) +(define exception:unexpected-syntax + (cons 'syntax-error "unexpected syntax")) + (define exception:bad-expression (cons 'syntax-error "Bad expression")) @@ -67,13 +72,13 @@ (with-test-prefix "Bad argument list" (pass-if-exception "improper argument list of length 1" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo . 1)) (interaction-environment))) (pass-if-exception "improper argument list of length 2" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo 1 . 2)) (interaction-environment)))) @@ -88,7 +93,7 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" - exception:illegal-empty-combination + exception:unexpected-syntax (eval '() (interaction-environment))))) From 0260421208267eb202f9c9628cdaf39b531a5129 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 22:43:07 +0200 Subject: [PATCH 144/375] some work on syntax.test * module/language/tree-il.scm (tree-il->scheme): * module/ice-9/psyntax.scm (build-conditional): Attempt to not generate (if #f #f) as the second arm of an if, but it doesn't seem to be successful. * module/ice-9/psyntax-pp.scm (syntax-rules): Regenerate. * test-suite/tests/syntax.test (exception:unexpected-syntax): Change capitalization. ("unquote-splicing"): Update test. ("begin"): Add in second arms on these ifs, to avoid the strange though harmless expansion of `if'. (matches?): New helper macro. ("lambda"): Match on lexically bound symbols, as they will be alpha-renamed. --- module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 4 +++- module/language/tree-il.scm | 4 +++- test-suite/tests/syntax.test | 46 +++++++++++++++++++++++------------- 4 files changed, 37 insertions(+), 19 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 5b646d870..0fcd15cca 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,6 +1,6 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars291) (letrec ((lvl292 (lambda (vars293 ls294 w295) (if (pair? vars293) (lvl292 (cdr vars293) (cons (wrap141 (car vars293) w295 #f) ls294) w295) (if (id?113 vars293) (cons (wrap141 vars293 w295 #f) ls294) (if (null? vars293) ls294 (if (syntax-object?97 vars293) (lvl292 (syntax-object-expression98 vars293) ls294 (join-wraps132 w295 (syntax-object-wrap99 vars293))) (if (annotation? vars293) (lvl292 (annotation-expression vars293) ls294 w295) (cons vars293 ls294))))))))) (lvl292 vars291 (quote ()) (quote (())))))) (gen-var161 (lambda (id296) (let ((id297 (if (syntax-object?97 id296) (syntax-object-expression98 id296) id296))) (if (annotation? id297) (gensym (symbol->string (annotation-expression id297))) (gensym (symbol->string id297)))))) (strip160 (lambda (x298 w299) (if (memq (quote top) (wrap-marks116 w299)) (if (let ((t300 (annotation? x298))) (if t300 t300 (if (pair? x298) (annotation? (car x298)) #f))) (strip-annotation159 x298 #f) x298) (letrec ((f301 (lambda (x302) (if (syntax-object?97 x302) (strip160 (syntax-object-expression98 x302) (syntax-object-wrap99 x302)) (if (pair? x302) (let ((a303 (f301 (car x302))) (d304 (f301 (cdr x302)))) (if (if (eq? a303 (car x302)) (eq? d304 (cdr x302)) #f) x302 (cons a303 d304))) (if (vector? x302) (let ((old305 (vector->list x302))) (let ((new306 (map f301 old305))) (if (and-map*17 eq? old305 new306) x302 (list->vector new306)))) x302)))))) (f301 x298))))) (strip-annotation159 (lambda (x307 parent308) (if (pair? x307) (let ((new309 (cons #f #f))) (begin (if parent308 (set-annotation-stripped! parent308 new309) (if #f #f)) (set-car! new309 (strip-annotation159 (car x307) #f)) (set-cdr! new309 (strip-annotation159 (cdr x307) #f)) new309)) (if (annotation? x307) (let ((t310 (annotation-stripped x307))) (if t310 t310 (strip-annotation159 (annotation-expression x307) x307))) (if (vector? x307) (let ((new311 (make-vector (vector-length x307)))) (begin (if parent308 (set-annotation-stripped! parent308 new311) (if #f #f)) (letrec ((loop312 (lambda (i313) (unless (fx<75 i313 0) (vector-set! new311 i313 (strip-annotation159 (vector-ref x307 i313) #f)) (loop312 (fx-73 i313 1)))))) (loop312 (- (vector-length x307) 1))) new311)) x307))))) (ellipsis?158 (lambda (x314) (if (nonsymbol-id?112 x314) (free-id=?136 x314 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void157 (lambda () (build-void80 #f))) (eval-local-transformer156 (lambda (expanded315 mod316) (let ((p317 (local-eval-hook77 expanded315 mod316))) (if (procedure? p317) p317 (syntax-violation #f "nonprocedure transformer" p317))))) (chi-local-syntax155 (lambda (rec?318 e319 r320 w321 s322 mod323 k324) ((lambda (tmp325) ((lambda (tmp326) (if tmp326 (apply (lambda (_327 id328 val329 e1330 e2331) (let ((ids332 id328)) (if (not (valid-bound-ids?138 ids332)) (syntax-violation #f "duplicate bound keyword" e319) (let ((labels334 (gen-labels119 ids332))) (let ((new-w335 (make-binding-wrap130 ids332 labels334 w321))) (k324 (cons e1330 e2331) (extend-env107 labels334 (let ((w337 (if rec?318 new-w335 w321)) (trans-r338 (macros-only-env109 r320))) (map (lambda (x339) (cons (quote macro) (eval-local-transformer156 (chi149 x339 trans-r338 w337 mod323) mod323))) val329)) r320) new-w335 s322 mod323)))))) tmp326) ((lambda (_341) (syntax-violation #f "bad local syntax definition" (source-wrap142 e319 w321 s322 mod323))) tmp325))) ($sc-dispatch tmp325 (quote (any #(each (any any)) any . each-any))))) e319))) (chi-lambda-clause154 (lambda (e342 docstring343 c344 r345 w346 mod347 k348) ((lambda (tmp349) ((lambda (tmp350) (if (if tmp350 (apply (lambda (args351 doc352 e1353 e2354) (if (string? (syntax->datum doc352)) (not docstring343) #f)) tmp350) #f) (apply (lambda (args355 doc356 e1357 e2358) (chi-lambda-clause154 e342 doc356 (cons args355 (cons e1357 e2358)) r345 w346 mod347 k348)) tmp350) ((lambda (tmp360) (if tmp360 (apply (lambda (id361 e1362 e2363) (let ((ids364 id361)) (if (not (valid-bound-ids?138 ids364)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels366 (gen-labels119 ids364)) (new-vars367 (map gen-var161 ids364))) (k348 (map syntax->datum ids364) new-vars367 (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1362 e2363) e342 (extend-var-env108 labels366 new-vars367 r345) (make-binding-wrap130 ids364 labels366 w346) mod347)))))) tmp360) ((lambda (tmp369) (if tmp369 (apply (lambda (ids370 e1371 e2372) (let ((old-ids373 (lambda-var-list162 ids370))) (if (not (valid-bound-ids?138 old-ids373)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels374 (gen-labels119 old-ids373)) (new-vars375 (map gen-var161 old-ids373))) (k348 (letrec ((f376 (lambda (ls1377 ls2378) (if (null? ls1377) (syntax->datum ls2378) (f376 (cdr ls1377) (cons (syntax->datum (car ls1377)) ls2378)))))) (f376 (cdr old-ids373) (car old-ids373))) (letrec ((f379 (lambda (ls1380 ls2381) (if (null? ls1380) ls2381 (f379 (cdr ls1380) (cons (car ls1380) ls2381)))))) (f379 (cdr new-vars375) (car new-vars375))) (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1371 e2372) e342 (extend-var-env108 labels374 new-vars375 r345) (make-binding-wrap130 old-ids373 labels374 w346) mod347)))))) tmp369) ((lambda (_383) (syntax-violation (quote lambda) "bad lambda" e342)) tmp349))) ($sc-dispatch tmp349 (quote (any any . each-any)))))) ($sc-dispatch tmp349 (quote (each-any any . each-any)))))) ($sc-dispatch tmp349 (quote (any any any . each-any))))) c344))) (chi-body153 (lambda (body384 outer-form385 r386 w387 mod388) (let ((r389 (cons (quote ("placeholder" placeholder)) r386))) (let ((ribcage390 (make-ribcage120 (quote ()) (quote ()) (quote ())))) (let ((w391 (make-wrap115 (wrap-marks116 w387) (cons ribcage390 (wrap-subst117 w387))))) (letrec ((parse392 (lambda (body393 ids394 labels395 vars396 vals397 bindings398) (if (null? body393) (syntax-violation #f "no expressions in body" outer-form385) (let ((e400 (cdar body393)) (er401 (caar body393))) (call-with-values (lambda () (syntax-type147 e400 er401 (quote (())) #f ribcage390 mod388)) (lambda (type402 value403 e404 w405 s406 mod407) (if (memv type402 (quote (define-form))) (let ((id408 (wrap141 value403 w405 mod407)) (label409 (gen-label118))) (let ((var410 (gen-var161 id408))) (begin (extend-ribcage!129 ribcage390 id408 label409) (parse392 (cdr body393) (cons id408 ids394) (cons label409 labels395) (cons var410 vars396) (cons (cons er401 (wrap141 e404 w405 mod407)) vals397) (cons (cons (quote lexical) var410) bindings398))))) (if (memv type402 (quote (define-syntax-form))) (let ((id411 (wrap141 value403 w405 mod407)) (label412 (gen-label118))) (begin (extend-ribcage!129 ribcage390 id411 label412) (parse392 (cdr body393) (cons id411 ids394) (cons label412 labels395) vars396 vals397 (cons (cons (quote macro) (cons er401 (wrap141 e404 w405 mod407))) bindings398)))) (if (memv type402 (quote (begin-form))) ((lambda (tmp413) ((lambda (tmp414) (if tmp414 (apply (lambda (_415 e1416) (parse392 (letrec ((f417 (lambda (forms418) (if (null? forms418) (cdr body393) (cons (cons er401 (wrap141 (car forms418) w405 mod407)) (f417 (cdr forms418))))))) (f417 e1416)) ids394 labels395 vars396 vals397 bindings398)) tmp414) (syntax-violation #f "source expression failed to match any pattern" tmp413))) ($sc-dispatch tmp413 (quote (any . each-any))))) e404) (if (memv type402 (quote (local-syntax-form))) (chi-local-syntax155 value403 e404 er401 w405 s406 mod407 (lambda (forms420 er421 w422 s423 mod424) (parse392 (letrec ((f425 (lambda (forms426) (if (null? forms426) (cdr body393) (cons (cons er421 (wrap141 (car forms426) w422 mod424)) (f425 (cdr forms426))))))) (f425 forms420)) ids394 labels395 vars396 vals397 bindings398))) (if (null? ids394) (build-sequence92 #f (map (lambda (x427) (chi149 (cdr x427) (car x427) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))) (begin (if (not (valid-bound-ids?138 ids394)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form385) (if #f #f)) (letrec ((loop428 (lambda (bs429 er-cache430 r-cache431) (if (not (null? bs429)) (let ((b432 (car bs429))) (if (eq? (car b432) (quote macro)) (let ((er433 (cadr b432))) (let ((r-cache434 (if (eq? er433 er-cache430) r-cache431 (macros-only-env109 er433)))) (begin (set-cdr! b432 (eval-local-transformer156 (chi149 (cddr b432) r-cache434 (quote (())) mod407) mod407)) (loop428 (cdr bs429) er433 r-cache434)))) (loop428 (cdr bs429) er-cache430 r-cache431))) (if #f #f))))) (loop428 bindings398 #f #f)) (set-cdr! r389 (extend-env107 labels395 bindings398 (cdr r389))) (build-letrec95 #f (map syntax->datum ids394) vars396 (map (lambda (x435) (chi149 (cdr x435) (car x435) (quote (())) mod407)) vals397) (build-sequence92 #f (map (lambda (x436) (chi149 (cdr x436) (car x436) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))))))))))))))))) (parse392 (map (lambda (x399) (cons r389 (wrap141 x399 w391 mod388))) body384) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro152 (lambda (p437 e438 r439 w440 rib441 mod442) (letrec ((rebuild-macro-output443 (lambda (x444 m445) (if (pair? x444) (cons (rebuild-macro-output443 (car x444) m445) (rebuild-macro-output443 (cdr x444) m445)) (if (syntax-object?97 x444) (let ((w446 (syntax-object-wrap99 x444))) (let ((ms447 (wrap-marks116 w446)) (s448 (wrap-subst117 w446))) (if (if (pair? ms447) (eq? (car ms447) #f) #f) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cdr ms447) (if rib441 (cons rib441 (cdr s448)) (cdr s448))) (syntax-object-module100 x444)) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cons m445 ms447) (if rib441 (cons rib441 (cons (quote shift) s448)) (cons (quote shift) s448))) (let ((pmod449 (procedure-module p437))) (if pmod449 (cons (quote hygiene) (module-name pmod449)) (quote (hygiene guile)))))))) (if (vector? x444) (let ((n450 (vector-length x444))) (let ((v451 (make-vector n450))) (letrec ((loop452 (lambda (i453) (if (fx=74 i453 n450) (begin (if #f #f (if #f #f)) v451) (begin (vector-set! v451 i453 (rebuild-macro-output443 (vector-ref x444 i453) m445)) (loop452 (fx+72 i453 1))))))) (loop452 0)))) (if (symbol? x444) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap142 e438 w440 s mod442) x444) x444))))))) (rebuild-macro-output443 (p437 (wrap141 e438 (anti-mark128 w440) mod442)) (string #\m))))) (chi-application151 (lambda (x454 e455 r456 w457 s458 mod459) ((lambda (tmp460) ((lambda (tmp461) (if tmp461 (apply (lambda (e0462 e1463) (build-application81 s458 x454 (map (lambda (e464) (chi149 e464 r456 w457 mod459)) e1463))) tmp461) (syntax-violation #f "source expression failed to match any pattern" tmp460))) ($sc-dispatch tmp460 (quote (any . each-any))))) e455))) (chi-expr150 (lambda (type466 value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (lexical))) (build-lexical-reference83 (quote value) s471 e468 value467) (if (memv type466 (quote (core external-macro))) (value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (module-ref))) (call-with-values (lambda () (value467 e468)) (lambda (id473 mod474) (build-global-reference86 s471 id473 mod474))) (if (memv type466 (quote (lexical-call))) (chi-application151 (build-lexical-reference83 (quote fun) (source-annotation104 (car e468)) (car e468) value467) e468 r469 w470 s471 mod472) (if (memv type466 (quote (global-call))) (chi-application151 (build-global-reference86 (source-annotation104 (car e468)) value467 (if (syntax-object?97 (car e468)) (syntax-object-module100 (car e468)) mod472)) e468 r469 w470 s471 mod472) (if (memv type466 (quote (constant))) (build-data91 s471 (strip160 (source-wrap142 e468 w470 s471 mod472) (quote (())))) (if (memv type466 (quote (global))) (build-global-reference86 s471 value467 mod472) (if (memv type466 (quote (call))) (chi-application151 (chi149 (car e468) r469 w470 mod472) e468 r469 w470 s471 mod472) (if (memv type466 (quote (begin-form))) ((lambda (tmp475) ((lambda (tmp476) (if tmp476 (apply (lambda (_477 e1478 e2479) (chi-sequence143 (cons e1478 e2479) r469 w470 s471 mod472)) tmp476) (syntax-violation #f "source expression failed to match any pattern" tmp475))) ($sc-dispatch tmp475 (quote (any any . each-any))))) e468) (if (memv type466 (quote (local-syntax-form))) (chi-local-syntax155 value467 e468 r469 w470 s471 mod472 chi-sequence143) (if (memv type466 (quote (eval-when-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 x484 e1485 e2486) (let ((when-list487 (chi-when-list146 e468 x484 w470))) (if (memq (quote eval) when-list487) (chi-sequence143 (cons e1485 e2486) r469 w470 s471 mod472) (chi-void157)))) tmp482) (syntax-violation #f "source expression failed to match any pattern" tmp481))) ($sc-dispatch tmp481 (quote (any each-any any . each-any))))) e468) (if (memv type466 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e468 (wrap141 value467 w470 mod472)) (if (memv type466 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap142 e468 w470 s471 mod472)) (if (memv type466 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap142 e468 w470 s471 mod472)) (syntax-violation #f "unexpected syntax" (source-wrap142 e468 w470 s471 mod472)))))))))))))))))) (chi149 (lambda (e490 r491 w492 mod493) (call-with-values (lambda () (syntax-type147 e490 r491 w492 #f #f mod493)) (lambda (type494 value495 e496 w497 s498 mod499) (chi-expr150 type494 value495 e496 r491 w497 s498 mod499))))) (chi-top148 (lambda (e500 r501 w502 m503 esew504 mod505) (call-with-values (lambda () (syntax-type147 e500 r501 w502 #f #f mod505)) (lambda (type513 value514 e515 w516 s517 mod518) (if (memv type513 (quote (begin-form))) ((lambda (tmp519) ((lambda (tmp520) (if tmp520 (apply (lambda (_521) (chi-void157)) tmp520) ((lambda (tmp522) (if tmp522 (apply (lambda (_523 e1524 e2525) (chi-top-sequence144 (cons e1524 e2525) r501 w516 s517 m503 esew504 mod518)) tmp522) (syntax-violation #f "source expression failed to match any pattern" tmp519))) ($sc-dispatch tmp519 (quote (any any . each-any)))))) ($sc-dispatch tmp519 (quote (any))))) e515) (if (memv type513 (quote (local-syntax-form))) (chi-local-syntax155 value514 e515 r501 w516 s517 mod518 (lambda (body527 r528 w529 s530 mod531) (chi-top-sequence144 body527 r528 w529 s530 m503 esew504 mod531))) (if (memv type513 (quote (eval-when-form))) ((lambda (tmp532) ((lambda (tmp533) (if tmp533 (apply (lambda (_534 x535 e1536 e2537) (let ((when-list538 (chi-when-list146 e515 x535 w516)) (body539 (cons e1536 e2537))) (if (eq? m503 (quote e)) (if (memq (quote eval) when-list538) (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) (chi-void157)) (if (memq (quote load) when-list538) (if (let ((t542 (memq (quote compile) when-list538))) (if t542 t542 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (chi-top-sequence144 body539 r501 w516 s517 (quote c&e) (quote (compile load)) mod518) (if (memq m503 (quote (c c&e))) (chi-top-sequence144 body539 r501 w516 s517 (quote c) (quote (load)) mod518) (chi-void157))) (if (let ((t543 (memq (quote compile) when-list538))) (if t543 t543 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (begin (top-level-eval-hook76 (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) mod518) (chi-void157)) (chi-void157)))))) tmp533) (syntax-violation #f "source expression failed to match any pattern" tmp532))) ($sc-dispatch tmp532 (quote (any each-any any . each-any))))) e515) (if (memv type513 (quote (define-syntax-form))) (let ((n544 (id-var-name135 value514 w516)) (r545 (macros-only-env109 r501))) (if (memv m503 (quote (c))) (if (memq (quote compile) esew504) (let ((e546 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e546 mod518) (if (memq (quote load) esew504) e546 (chi-void157)))) (if (memq (quote load) esew504) (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) (chi-void157))) (if (memv m503 (quote (c&e))) (let ((e547 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e547 mod518) e547)) (begin (if (memq (quote eval) esew504) (top-level-eval-hook76 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) mod518) (if #f #f)) (chi-void157))))) (if (memv type513 (quote (define-form))) (let ((n548 (id-var-name135 value514 w516))) (let ((type549 (binding-type105 (lookup110 n548 r501 mod518)))) (if (memv type549 (quote (global core macro module-ref))) (let ((x550 (build-global-definition88 s517 n548 (chi149 e515 r501 w516 mod518)))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x550 mod518) (if #f #f)) x550)) (if (memv type549 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e515 (wrap141 value514 w516 mod518)) (syntax-violation #f "cannot define keyword at top level" e515 (wrap141 value514 w516 mod518)))))) (let ((x551 (chi-expr150 type513 value514 e515 r501 w516 s517 mod518))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x551 mod518) (if #f #f)) x551))))))))))) (syntax-type147 (lambda (e552 r553 w554 s555 rib556 mod557) (if (symbol? e552) (let ((n558 (id-var-name135 e552 w554))) (let ((b559 (lookup110 n558 r553 mod557))) (let ((type560 (binding-type105 b559))) (if (memv type560 (quote (lexical))) (values type560 (binding-value106 b559) e552 w554 s555 mod557) (if (memv type560 (quote (global))) (values type560 n558 e552 w554 s555 mod557) (if (memv type560 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b559) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (values type560 (binding-value106 b559) e552 w554 s555 mod557))))))) (if (pair? e552) (let ((first561 (car e552))) (if (id?113 first561) (let ((n562 (id-var-name135 first561 w554))) (let ((b563 (lookup110 n562 r553 (let ((t564 (if (syntax-object?97 first561) (syntax-object-module100 first561) #f))) (if t564 t564 mod557))))) (let ((type565 (binding-type105 b563))) (if (memv type565 (quote (lexical))) (values (quote lexical-call) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (global))) (values (quote global-call) n562 e552 w554 s555 mod557) (if (memv type565 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b563) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (if (memv type565 (quote (core external-macro module-ref))) (values type565 (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (begin))) (values (quote begin-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (eval-when))) (values (quote eval-when-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?113 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555 mod557)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (if (id?113 name576) (valid-bound-ids?138 (lambda-var-list162 args577)) #f)) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap141 name581 w554 mod557) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap141 (cons args582 (cons e1583 e2584)) w554 mod557)) (quote (())) s555 mod557)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?113 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap141 name590 w554 mod557) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s555 mod557)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e552) (if (memv type565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?113 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555 mod557)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) #f e552 w554 s555 mod557))))))))))))) (values (quote call) #f e552 w554 s555 mod557))) (if (syntax-object?97 e552) (syntax-type147 (syntax-object-expression98 e552) r553 (join-wraps132 w554 (syntax-object-wrap99 e552)) #f rib556 (let ((t599 (syntax-object-module100 e552))) (if t599 t599 mod557))) (if (annotation? e552) (syntax-type147 (annotation-expression e552) r553 w554 (annotation-source e552) rib556 mod557) (if (self-evaluating? e552) (values (quote constant) #f e552 w554 s555 mod557) (values (quote other) #f e552 w554 s555 mod557)))))))) (chi-when-list146 (lambda (e600 when-list601 w602) (letrec ((f603 (lambda (when-list604 situations605) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (if (free-id=?136 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?136 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?136 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e600 (wrap141 x606 w602 #f)))))) situations605)))))) (f603 when-list601 (quote ()))))) (chi-install-global145 (lambda (name607 e608) (build-global-definition88 #f name607 (if (let ((v609 (module-variable (current-module) name607))) (if v609 (if (variable-bound? v609) (if (macro? (variable-ref v609)) (not (eq? (macro-type (variable-ref v609)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref90 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref90 #f (quote module-ref)) (list (build-application81 #f (build-primref90 #f (quote current-module)) (quote ())) (build-data91 #f name607))) (build-data91 #f (quote macro)) e608)) (build-application81 #f (build-primref90 #f (quote make-syncase-macro)) (list (build-data91 #f (quote macro)) e608)))))) (chi-top-sequence144 (lambda (body610 r611 w612 s613 m614 esew615 mod616) (build-sequence92 s613 (letrec ((dobody617 (lambda (body618 r619 w620 m621 esew622 mod623) (if (null? body618) (quote ()) (let ((first624 (chi-top148 (car body618) r619 w620 m621 esew622 mod623))) (cons first624 (dobody617 (cdr body618) r619 w620 m621 esew622 mod623))))))) (dobody617 body610 r611 w612 m614 esew615 mod616))))) (chi-sequence143 (lambda (body625 r626 w627 s628 mod629) (build-sequence92 s628 (letrec ((dobody630 (lambda (body631 r632 w633 mod634) (if (null? body631) (quote ()) (let ((first635 (chi149 (car body631) r632 w633 mod634))) (cons first635 (dobody630 (cdr body631) r632 w633 mod634))))))) (dobody630 body625 r626 w627 mod629))))) (source-wrap142 (lambda (x636 w637 s638 defmod639) (wrap141 (if s638 (make-annotation x636 s638 #f) x636) w637 defmod639))) (wrap141 (lambda (x640 w641 defmod642) (if (if (null? (wrap-marks116 w641)) (null? (wrap-subst117 w641)) #f) x640 (if (syntax-object?97 x640) (make-syntax-object96 (syntax-object-expression98 x640) (join-wraps132 w641 (syntax-object-wrap99 x640)) (syntax-object-module100 x640)) (if (null? x640) x640 (make-syntax-object96 x640 w641 defmod642)))))) (bound-id-member?140 (lambda (x643 list644) (if (not (null? list644)) (let ((t645 (bound-id=?137 x643 (car list644)))) (if t645 t645 (bound-id-member?140 x643 (cdr list644)))) #f))) (distinct-bound-ids?139 (lambda (ids646) (letrec ((distinct?647 (lambda (ids648) (let ((t649 (null? ids648))) (if t649 t649 (if (not (bound-id-member?140 (car ids648) (cdr ids648))) (distinct?647 (cdr ids648)) #f)))))) (distinct?647 ids646)))) (valid-bound-ids?138 (lambda (ids650) (if (letrec ((all-ids?651 (lambda (ids652) (let ((t653 (null? ids652))) (if t653 t653 (if (id?113 (car ids652)) (all-ids?651 (cdr ids652)) #f)))))) (all-ids?651 ids650)) (distinct-bound-ids?139 ids650) #f))) (bound-id=?137 (lambda (i654 j655) (if (if (syntax-object?97 i654) (syntax-object?97 j655) #f) (if (eq? (let ((e656 (syntax-object-expression98 i654))) (if (annotation? e656) (annotation-expression e656) e656)) (let ((e657 (syntax-object-expression98 j655))) (if (annotation? e657) (annotation-expression e657) e657))) (same-marks?134 (wrap-marks116 (syntax-object-wrap99 i654)) (wrap-marks116 (syntax-object-wrap99 j655))) #f) (eq? (let ((e658 i654)) (if (annotation? e658) (annotation-expression e658) e658)) (let ((e659 j655)) (if (annotation? e659) (annotation-expression e659) e659)))))) (free-id=?136 (lambda (i660 j661) (if (eq? (let ((x662 i660)) (let ((e663 (if (syntax-object?97 x662) (syntax-object-expression98 x662) x662))) (if (annotation? e663) (annotation-expression e663) e663))) (let ((x664 j661)) (let ((e665 (if (syntax-object?97 x664) (syntax-object-expression98 x664) x664))) (if (annotation? e665) (annotation-expression e665) e665)))) (eq? (id-var-name135 i660 (quote (()))) (id-var-name135 j661 (quote (())))) #f))) (id-var-name135 (lambda (id666 w667) (letrec ((search-vector-rib670 (lambda (sym676 subst677 marks678 symnames679 ribcage680) (let ((n681 (vector-length symnames679))) (letrec ((f682 (lambda (i683) (if (fx=74 i683 n681) (search668 sym676 (cdr subst677) marks678) (if (if (eq? (vector-ref symnames679 i683) sym676) (same-marks?134 marks678 (vector-ref (ribcage-marks123 ribcage680) i683)) #f) (values (vector-ref (ribcage-labels124 ribcage680) i683) marks678) (f682 (fx+72 i683 1))))))) (f682 0))))) (search-list-rib669 (lambda (sym684 subst685 marks686 symnames687 ribcage688) (letrec ((f689 (lambda (symnames690 i691) (if (null? symnames690) (search668 sym684 (cdr subst685) marks686) (if (if (eq? (car symnames690) sym684) (same-marks?134 marks686 (list-ref (ribcage-marks123 ribcage688) i691)) #f) (values (list-ref (ribcage-labels124 ribcage688) i691) marks686) (f689 (cdr symnames690) (fx+72 i691 1))))))) (f689 symnames687 0)))) (search668 (lambda (sym692 subst693 marks694) (if (null? subst693) (values #f marks694) (let ((fst695 (car subst693))) (if (eq? fst695 (quote shift)) (search668 sym692 (cdr subst693) (cdr marks694)) (let ((symnames696 (ribcage-symnames122 fst695))) (if (vector? symnames696) (search-vector-rib670 sym692 subst693 marks694 symnames696 fst695) (search-list-rib669 sym692 subst693 marks694 symnames696 fst695))))))))) (if (symbol? id666) (let ((t697 (call-with-values (lambda () (search668 id666 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x699 . ignore698) x699)))) (if t697 t697 id666)) (if (syntax-object?97 id666) (let ((id700 (let ((e702 (syntax-object-expression98 id666))) (if (annotation? e702) (annotation-expression e702) e702))) (w1701 (syntax-object-wrap99 id666))) (let ((marks703 (join-marks133 (wrap-marks116 w667) (wrap-marks116 w1701)))) (call-with-values (lambda () (search668 id700 (wrap-subst117 w667) marks703)) (lambda (new-id704 marks705) (let ((t706 new-id704)) (if t706 t706 (let ((t707 (call-with-values (lambda () (search668 id700 (wrap-subst117 w1701) marks705)) (lambda (x709 . ignore708) x709)))) (if t707 t707 id700)))))))) (if (annotation? id666) (let ((id710 (let ((e711 id666)) (if (annotation? e711) (annotation-expression e711) e711)))) (let ((t712 (call-with-values (lambda () (search668 id710 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x714 . ignore713) x714)))) (if t712 t712 id710))) (syntax-violation (quote id-var-name) "invalid id" id666))))))) (same-marks?134 (lambda (x715 y716) (let ((t717 (eq? x715 y716))) (if t717 t717 (if (not (null? x715)) (if (not (null? y716)) (if (eq? (car x715) (car y716)) (same-marks?134 (cdr x715) (cdr y716)) #f) #f) #f))))) (join-marks133 (lambda (m1718 m2719) (smart-append131 m1718 m2719))) (join-wraps132 (lambda (w1720 w2721) (let ((m1722 (wrap-marks116 w1720)) (s1723 (wrap-subst117 w1720))) (if (null? m1722) (if (null? s1723) w2721 (make-wrap115 (wrap-marks116 w2721) (smart-append131 s1723 (wrap-subst117 w2721)))) (make-wrap115 (smart-append131 m1722 (wrap-marks116 w2721)) (smart-append131 s1723 (wrap-subst117 w2721))))))) (smart-append131 (lambda (m1724 m2725) (if (null? m2725) m1724 (append m1724 m2725)))) (make-binding-wrap130 (lambda (ids726 labels727 w728) (if (null? ids726) w728 (make-wrap115 (wrap-marks116 w728) (cons (let ((labelvec729 (list->vector labels727))) (let ((n730 (vector-length labelvec729))) (let ((symnamevec731 (make-vector n730)) (marksvec732 (make-vector n730))) (begin (letrec ((f733 (lambda (ids734 i735) (if (not (null? ids734)) (call-with-values (lambda () (id-sym-name&marks114 (car ids734) w728)) (lambda (symname736 marks737) (begin (vector-set! symnamevec731 i735 symname736) (vector-set! marksvec732 i735 marks737) (f733 (cdr ids734) (fx+72 i735 1))))) (if #f #f))))) (f733 ids726 0)) (make-ribcage120 symnamevec731 marksvec732 labelvec729))))) (wrap-subst117 w728)))))) (extend-ribcage!129 (lambda (ribcage738 id739 label740) (begin (set-ribcage-symnames!125 ribcage738 (cons (let ((e741 (syntax-object-expression98 id739))) (if (annotation? e741) (annotation-expression e741) e741)) (ribcage-symnames122 ribcage738))) (set-ribcage-marks!126 ribcage738 (cons (wrap-marks116 (syntax-object-wrap99 id739)) (ribcage-marks123 ribcage738))) (set-ribcage-labels!127 ribcage738 (cons label740 (ribcage-labels124 ribcage738)))))) (anti-mark128 (lambda (w742) (make-wrap115 (cons #f (wrap-marks116 w742)) (cons (quote shift) (wrap-subst117 w742))))) (set-ribcage-labels!127 (lambda (x743 update744) (vector-set! x743 3 update744))) (set-ribcage-marks!126 (lambda (x745 update746) (vector-set! x745 2 update746))) (set-ribcage-symnames!125 (lambda (x747 update748) (vector-set! x747 1 update748))) (ribcage-labels124 (lambda (x749) (vector-ref x749 3))) (ribcage-marks123 (lambda (x750) (vector-ref x750 2))) (ribcage-symnames122 (lambda (x751) (vector-ref x751 1))) (ribcage?121 (lambda (x752) (if (vector? x752) (if (= (vector-length x752) 4) (eq? (vector-ref x752 0) (quote ribcage)) #f) #f))) (make-ribcage120 (lambda (symnames753 marks754 labels755) (vector (quote ribcage) symnames753 marks754 labels755))) (gen-labels119 (lambda (ls756) (if (null? ls756) (quote ()) (cons (gen-label118) (gen-labels119 (cdr ls756)))))) (gen-label118 (lambda () (string #\i))) (wrap-subst117 cdr) (wrap-marks116 car) (make-wrap115 cons) (id-sym-name&marks114 (lambda (x757 w758) (if (syntax-object?97 x757) (values (let ((e759 (syntax-object-expression98 x757))) (if (annotation? e759) (annotation-expression e759) e759)) (join-marks133 (wrap-marks116 w758) (wrap-marks116 (syntax-object-wrap99 x757)))) (values (let ((e760 x757)) (if (annotation? e760) (annotation-expression e760) e760)) (wrap-marks116 w758))))) (id?113 (lambda (x761) (if (symbol? x761) #t (if (syntax-object?97 x761) (symbol? (let ((e762 (syntax-object-expression98 x761))) (if (annotation? e762) (annotation-expression e762) e762))) (if (annotation? x761) (symbol? (annotation-expression x761)) #f))))) (nonsymbol-id?112 (lambda (x763) (if (syntax-object?97 x763) (symbol? (let ((e764 (syntax-object-expression98 x763))) (if (annotation? e764) (annotation-expression e764) e764))) #f))) (global-extend111 (lambda (type765 sym766 val767) (put-global-definition-hook78 sym766 type765 val767))) (lookup110 (lambda (x768 r769 mod770) (let ((temp771 (assq x768 r769))) (if temp771 (cdr temp771) (if (symbol? x768) (let ((t772 (get-global-definition-hook79 x768 mod770))) (if t772 t772 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env109 (lambda (r773) (if (null? r773) (quote ()) (let ((a774 (car r773))) (if (eq? (cadr a774) (quote macro)) (cons a774 (macros-only-env109 (cdr r773))) (macros-only-env109 (cdr r773))))))) (extend-var-env108 (lambda (labels775 vars776 r777) (if (null? labels775) r777 (extend-var-env108 (cdr labels775) (cdr vars776) (cons (cons (car labels775) (cons (quote lexical) (car vars776))) r777))))) (extend-env107 (lambda (labels778 bindings779 r780) (if (null? labels778) r780 (extend-env107 (cdr labels778) (cdr bindings779) (cons (cons (car labels778) (car bindings779)) r780))))) (binding-value106 cdr) (binding-type105 car) (source-annotation104 (lambda (x781) (if (annotation? x781) (annotation-source x781) (if (syntax-object?97 x781) (source-annotation104 (syntax-object-expression98 x781)) #f)))) (set-syntax-object-module!103 (lambda (x782 update783) (vector-set! x782 3 update783))) (set-syntax-object-wrap!102 (lambda (x784 update785) (vector-set! x784 2 update785))) (set-syntax-object-expression!101 (lambda (x786 update787) (vector-set! x786 1 update787))) (syntax-object-module100 (lambda (x788) (vector-ref x788 3))) (syntax-object-wrap99 (lambda (x789) (vector-ref x789 2))) (syntax-object-expression98 (lambda (x790) (vector-ref x790 1))) (syntax-object?97 (lambda (x791) (if (vector? x791) (if (= (vector-length x791) 4) (eq? (vector-ref x791 0) (quote syntax-object)) #f) #f))) (make-syntax-object96 (lambda (expression792 wrap793 module794) (vector (quote syntax-object) expression792 wrap793 module794))) (build-letrec95 (lambda (src795 ids796 vars797 val-exps798 body-exp799) (if (null? vars797) body-exp799 (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-letrec) src795 ids796 vars797 val-exps798 body-exp799) (list (quote letrec) (map list vars797 val-exps798) body-exp799)))))) (build-named-let94 (lambda (src801 ids802 vars803 val-exps804 body-exp805) (let ((f806 (car vars803)) (f-name807 (car ids802)) (vars808 (cdr vars803)) (ids809 (cdr ids802))) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-letrec) src801 (list f-name807) (list f806) (list (build-lambda89 src801 ids809 vars808 #f body-exp805)) (build-application81 src801 (build-lexical-reference83 (quote fun) src801 f-name807 f806) val-exps804)) (list (quote let) f806 (map list vars808 val-exps804) body-exp805)))))) (build-let93 (lambda (src811 ids812 vars813 val-exps814 body-exp815) (if (null? vars813) body-exp815 (let ((atom-key816 (fluid-ref *mode*71))) (if (memv atom-key816 (quote (c))) ((@ (language tree-il) make-let) src811 ids812 vars813 val-exps814 body-exp815) (list (quote let) (map list vars813 val-exps814) body-exp815)))))) (build-sequence92 (lambda (src817 exps818) (if (null? (cdr exps818)) (car exps818) (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) ((@ (language tree-il) make-sequence) src817 exps818) (cons (quote begin) exps818)))))) (build-data91 (lambda (src820 exp821) (let ((atom-key822 (fluid-ref *mode*71))) (if (memv atom-key822 (quote (c))) ((@ (language tree-il) make-const) src820 exp821) (if (if (self-evaluating? exp821) (not (vector? exp821)) #f) exp821 (list (quote quote) exp821)))))) (build-primref90 (lambda (src823 name824) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src823 name824) name824)) (let ((atom-key826 (fluid-ref *mode*71))) (if (memv atom-key826 (quote (c))) ((@ (language tree-il) make-module-ref) src823 (quote (guile)) name824 #f) (list (quote @@) (quote (guile)) name824)))))) (build-lambda89 (lambda (src827 ids828 vars829 docstring830 exp831) (let ((atom-key832 (fluid-ref *mode*71))) (if (memv atom-key832 (quote (c))) ((@ (language tree-il) make-lambda) src827 ids828 vars829 (if docstring830 (list (cons (quote documentation) docstring830)) (quote ())) exp831) (cons (quote lambda) (cons vars829 (append (if docstring830 (list docstring830) (quote ())) (list exp831)))))))) (build-global-definition88 (lambda (source833 var834 exp835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-define) source833 var834 exp835) (list (quote define) var834 exp835))))) (build-global-assignment87 (lambda (source837 var838 exp839 mod840) (analyze-variable85 mod840 var838 (lambda (mod841 var842 public?843) (let ((atom-key844 (fluid-ref *mode*71))) (if (memv atom-key844 (quote (c))) ((@ (language tree-il) make-module-set) source837 mod841 var842 public?843 exp839) (list (quote set!) (list (if public?843 (quote @) (quote @@)) mod841 var842) exp839)))) (lambda (var845) (let ((atom-key846 (fluid-ref *mode*71))) (if (memv atom-key846 (quote (c))) ((@ (language tree-il) make-toplevel-set) source837 var845 exp839) (list (quote set!) var845 exp839))))))) (build-global-reference86 (lambda (source847 var848 mod849) (analyze-variable85 mod849 var848 (lambda (mod850 var851 public?852) (let ((atom-key853 (fluid-ref *mode*71))) (if (memv atom-key853 (quote (c))) ((@ (language tree-il) make-module-ref) source847 mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851)))) (lambda (var854) (let ((atom-key855 (fluid-ref *mode*71))) (if (memv atom-key855 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source847 var854) var854)))))) (analyze-variable85 (lambda (mod856 var857 modref-cont858 bare-cont859) (if (not mod856) (bare-cont859 var857) (let ((kind860 (car mod856)) (mod861 (cdr mod856))) (if (memv kind860 (quote (public))) (modref-cont858 mod861 var857 #t) (if (memv kind860 (quote (private))) (if (not (equal? mod861 (module-name (current-module)))) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (if (memv kind860 (quote (bare))) (bare-cont859 var857) (if (memv kind860 (quote (hygiene))) (if (if (not (equal? mod861 (module-name (current-module)))) (module-variable (resolve-module mod861) var857) #f) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (syntax-violation #f "bad module kind" var857 mod861))))))))) (build-lexical-assignment84 (lambda (source862 name863 var864 exp865) (let ((atom-key866 (fluid-ref *mode*71))) (if (memv atom-key866 (quote (c))) ((@ (language tree-il) make-lexical-set) source862 name863 var864 exp865) (list (quote set!) var864 exp865))))) (build-lexical-reference83 (lambda (type867 source868 name869 var870) (let ((atom-key871 (fluid-ref *mode*71))) (if (memv atom-key871 (quote (c))) ((@ (language tree-il) make-lexical-ref) source868 name869 var870) var870)))) (build-conditional82 (lambda (source872 test-exp873 then-exp874 else-exp875) (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) make-conditional) source872 test-exp873 then-exp874 else-exp875) (list (quote if) test-exp873 then-exp874 else-exp875))))) (build-application81 (lambda (source877 fun-exp878 arg-exps879) (let ((atom-key880 (fluid-ref *mode*71))) (if (memv atom-key880 (quote (c))) ((@ (language tree-il) make-application) source877 fun-exp878 arg-exps879) (cons fun-exp878 arg-exps879))))) (build-void80 (lambda (source881) (let ((atom-key882 (fluid-ref *mode*71))) (if (memv atom-key882 (quote (c))) ((@ (language tree-il) make-void) source881) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol883 module884) (begin (if (if (not module884) (current-module) #f) (warn "module system is booted, we should have a module" symbol883) (if #f #f)) (let ((v885 (module-variable (if module884 (resolve-module (cdr module884)) (current-module)) symbol883))) (if v885 (if (variable-bound? v885) (let ((val886 (variable-ref v885))) (if (macro? val886) (if (syncase-macro-type val886) (cons (syncase-macro-type val886) (syncase-macro-binding val886)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol887 type888 val889) (let ((existing890 (let ((v891 (module-variable (current-module) symbol887))) (if v891 (if (variable-bound? v891) (let ((val892 (variable-ref v891))) (if (macro? val892) (if (not (syncase-macro-type val892)) val892 #f) #f)) #f) #f)))) (module-define! (current-module) symbol887 (if existing890 (make-extended-syncase-macro existing890 type888 val889) (make-syncase-macro type888 val889)))))) (local-eval-hook77 (lambda (x893 mod894) (primitive-eval (list noexpand70 (let ((atom-key895 (fluid-ref *mode*71))) (if (memv atom-key895 (quote (c))) ((@ (language tree-il) tree-il->scheme) x893) x893)))))) (top-level-eval-hook76 (lambda (x896 mod897) (primitive-eval (list noexpand70 (let ((atom-key898 (fluid-ref *mode*71))) (if (memv atom-key898 (quote (c))) ((@ (language tree-il) tree-il->scheme) x896) x896)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend111 (quote local-syntax) (quote letrec-syntax) #t) (global-extend111 (quote local-syntax) (quote let-syntax) #f) (global-extend111 (quote core) (quote fluid-let-syntax) (lambda (e899 r900 w901 s902 mod903) ((lambda (tmp904) ((lambda (tmp905) (if (if tmp905 (apply (lambda (_906 var907 val908 e1909 e2910) (valid-bound-ids?138 var907)) tmp905) #f) (apply (lambda (_912 var913 val914 e1915 e2916) (let ((names917 (map (lambda (x918) (id-var-name135 x918 w901)) var913))) (begin (for-each (lambda (id920 n921) (let ((atom-key922 (binding-type105 (lookup110 n921 r900 mod903)))) (if (memv atom-key922 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e899 (source-wrap142 id920 w901 s902 mod903)) (if #f #f)))) var913 names917) (chi-body153 (cons e1915 e2916) (source-wrap142 e899 w901 s902 mod903) (extend-env107 names917 (let ((trans-r925 (macros-only-env109 r900))) (map (lambda (x926) (cons (quote macro) (eval-local-transformer156 (chi149 x926 trans-r925 w901 mod903) mod903))) val914)) r900) w901 mod903)))) tmp905) ((lambda (_928) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap142 e899 w901 s902 mod903))) tmp904))) ($sc-dispatch tmp904 (quote (any #(each (any any)) any . each-any))))) e899))) (global-extend111 (quote core) (quote quote) (lambda (e929 r930 w931 s932 mod933) ((lambda (tmp934) ((lambda (tmp935) (if tmp935 (apply (lambda (_936 e937) (build-data91 s932 (strip160 e937 w931))) tmp935) ((lambda (_938) (syntax-violation (quote quote) "bad syntax" (source-wrap142 e929 w931 s932 mod933))) tmp934))) ($sc-dispatch tmp934 (quote (any any))))) e929))) (global-extend111 (quote core) (quote syntax) (letrec ((regen946 (lambda (x947) (let ((atom-key948 (car x947))) (if (memv atom-key948 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x947) (cadr x947)) (if (memv atom-key948 (quote (primitive))) (build-primref90 #f (cadr x947)) (if (memv atom-key948 (quote (quote))) (build-data91 #f (cadr x947)) (if (memv atom-key948 (quote (lambda))) (build-lambda89 #f (cadr x947) (cadr x947) #f (regen946 (caddr x947))) (if (memv atom-key948 (quote (map))) (let ((ls949 (map regen946 (cdr x947)))) (build-application81 #f (build-primref90 #f (quote map)) ls949)) (build-application81 #f (build-primref90 #f (car x947)) (map regen946 (cdr x947))))))))))) (gen-vector945 (lambda (x950) (if (eq? (car x950) (quote list)) (cons (quote vector) (cdr x950)) (if (eq? (car x950) (quote quote)) (list (quote quote) (list->vector (cadr x950))) (list (quote list->vector) x950))))) (gen-append944 (lambda (x951 y952) (if (equal? y952 (quote (quote ()))) x951 (list (quote append) x951 y952)))) (gen-cons943 (lambda (x953 y954) (let ((atom-key955 (car y954))) (if (memv atom-key955 (quote (quote))) (if (eq? (car x953) (quote quote)) (list (quote quote) (cons (cadr x953) (cadr y954))) (if (eq? (cadr y954) (quote ())) (list (quote list) x953) (list (quote cons) x953 y954))) (if (memv atom-key955 (quote (list))) (cons (quote list) (cons x953 (cdr y954))) (list (quote cons) x953 y954)))))) (gen-map942 (lambda (e956 map-env957) (let ((formals958 (map cdr map-env957)) (actuals959 (map (lambda (x960) (list (quote ref) (car x960))) map-env957))) (if (eq? (car e956) (quote ref)) (car actuals959) (if (and-map (lambda (x961) (if (eq? (car x961) (quote ref)) (memq (cadr x961) formals958) #f)) (cdr e956)) (cons (quote map) (cons (list (quote primitive) (car e956)) (map (let ((r962 (map cons formals958 actuals959))) (lambda (x963) (cdr (assq (cadr x963) r962)))) (cdr e956)))) (cons (quote map) (cons (list (quote lambda) formals958 e956) actuals959))))))) (gen-mappend941 (lambda (e964 map-env965) (list (quote apply) (quote (primitive append)) (gen-map942 e964 map-env965)))) (gen-ref940 (lambda (src966 var967 level968 maps969) (if (fx=74 level968 0) (values var967 maps969) (if (null? maps969) (syntax-violation (quote syntax) "missing ellipsis" src966) (call-with-values (lambda () (gen-ref940 src966 var967 (fx-73 level968 1) (cdr maps969))) (lambda (outer-var970 outer-maps971) (let ((b972 (assq outer-var970 (car maps969)))) (if b972 (values (cdr b972) maps969) (let ((inner-var973 (gen-var161 (quote tmp)))) (values inner-var973 (cons (cons (cons outer-var970 inner-var973) (car maps969)) outer-maps971))))))))))) (gen-syntax939 (lambda (src974 e975 r976 maps977 ellipsis?978 mod979) (if (id?113 e975) (let ((label980 (id-var-name135 e975 (quote (()))))) (let ((b981 (lookup110 label980 r976 mod979))) (if (eq? (binding-type105 b981) (quote syntax)) (call-with-values (lambda () (let ((var.lev982 (binding-value106 b981))) (gen-ref940 src974 (car var.lev982) (cdr var.lev982) maps977))) (lambda (var983 maps984) (values (list (quote ref) var983) maps984))) (if (ellipsis?978 e975) (syntax-violation (quote syntax) "misplaced ellipsis" src974) (values (list (quote quote) e975) maps977))))) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 e988) (ellipsis?978 dots987)) tmp986) #f) (apply (lambda (dots989 e990) (gen-syntax939 src974 e990 r976 maps977 (lambda (x991) #f) mod979)) tmp986) ((lambda (tmp992) (if (if tmp992 (apply (lambda (x993 dots994 y995) (ellipsis?978 dots994)) tmp992) #f) (apply (lambda (x996 dots997 y998) (letrec ((f999 (lambda (y1000 k1001) ((lambda (tmp1005) ((lambda (tmp1006) (if (if tmp1006 (apply (lambda (dots1007 y1008) (ellipsis?978 dots1007)) tmp1006) #f) (apply (lambda (dots1009 y1010) (f999 y1010 (lambda (maps1011) (call-with-values (lambda () (k1001 (cons (quote ()) maps1011))) (lambda (x1012 maps1013) (if (null? (car maps1013)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-mappend941 x1012 (car maps1013)) (cdr maps1013)))))))) tmp1006) ((lambda (_1014) (call-with-values (lambda () (gen-syntax939 src974 y1000 r976 maps977 ellipsis?978 mod979)) (lambda (y1015 maps1016) (call-with-values (lambda () (k1001 maps1016)) (lambda (x1017 maps1018) (values (gen-append944 x1017 y1015) maps1018)))))) tmp1005))) ($sc-dispatch tmp1005 (quote (any . any))))) y1000)))) (f999 y998 (lambda (maps1002) (call-with-values (lambda () (gen-syntax939 src974 x996 r976 (cons (quote ()) maps1002) ellipsis?978 mod979)) (lambda (x1003 maps1004) (if (null? (car maps1004)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-map942 x1003 (car maps1004)) (cdr maps1004))))))))) tmp992) ((lambda (tmp1019) (if tmp1019 (apply (lambda (x1020 y1021) (call-with-values (lambda () (gen-syntax939 src974 x1020 r976 maps977 ellipsis?978 mod979)) (lambda (x1022 maps1023) (call-with-values (lambda () (gen-syntax939 src974 y1021 r976 maps1023 ellipsis?978 mod979)) (lambda (y1024 maps1025) (values (gen-cons943 x1022 y1024) maps1025)))))) tmp1019) ((lambda (tmp1026) (if tmp1026 (apply (lambda (e11027 e21028) (call-with-values (lambda () (gen-syntax939 src974 (cons e11027 e21028) r976 maps977 ellipsis?978 mod979)) (lambda (e1030 maps1031) (values (gen-vector945 e1030) maps1031)))) tmp1026) ((lambda (_1032) (values (list (quote quote) e975) maps977)) tmp985))) ($sc-dispatch tmp985 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp985 (quote (any . any)))))) ($sc-dispatch tmp985 (quote (any any . any)))))) ($sc-dispatch tmp985 (quote (any any))))) e975))))) (lambda (e1033 r1034 w1035 s1036 mod1037) (let ((e1038 (source-wrap142 e1033 w1035 s1036 mod1037))) ((lambda (tmp1039) ((lambda (tmp1040) (if tmp1040 (apply (lambda (_1041 x1042) (call-with-values (lambda () (gen-syntax939 e1038 x1042 r1034 (quote ()) ellipsis?158 mod1037)) (lambda (e1043 maps1044) (regen946 e1043)))) tmp1040) ((lambda (_1045) (syntax-violation (quote syntax) "bad `syntax' form" e1038)) tmp1039))) ($sc-dispatch tmp1039 (quote (any any))))) e1038))))) (global-extend111 (quote core) (quote lambda) (lambda (e1046 r1047 w1048 s1049 mod1050) ((lambda (tmp1051) ((lambda (tmp1052) (if tmp1052 (apply (lambda (_1053 c1054) (chi-lambda-clause154 (source-wrap142 e1046 w1048 s1049 mod1050) #f c1054 r1047 w1048 mod1050 (lambda (names1055 vars1056 docstring1057 body1058) (build-lambda89 s1049 names1055 vars1056 docstring1057 body1058)))) tmp1052) (syntax-violation #f "source expression failed to match any pattern" tmp1051))) ($sc-dispatch tmp1051 (quote (any . any))))) e1046))) (global-extend111 (quote core) (quote let) (letrec ((chi-let1059 (lambda (e1060 r1061 w1062 s1063 mod1064 constructor1065 ids1066 vals1067 exps1068) (if (not (valid-bound-ids?138 ids1066)) (syntax-violation (quote let) "duplicate bound variable" e1060) (let ((labels1069 (gen-labels119 ids1066)) (new-vars1070 (map gen-var161 ids1066))) (let ((nw1071 (make-binding-wrap130 ids1066 labels1069 w1062)) (nr1072 (extend-var-env108 labels1069 new-vars1070 r1061))) (constructor1065 s1063 (map syntax->datum ids1066) new-vars1070 (map (lambda (x1073) (chi149 x1073 r1061 w1062 mod1064)) vals1067) (chi-body153 exps1068 (source-wrap142 e1060 nw1071 s1063 mod1064) nr1072 nw1071 mod1064)))))))) (lambda (e1074 r1075 w1076 s1077 mod1078) ((lambda (tmp1079) ((lambda (tmp1080) (if tmp1080 (apply (lambda (_1081 id1082 val1083 e11084 e21085) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-let93 id1082 val1083 (cons e11084 e21085))) tmp1080) ((lambda (tmp1089) (if (if tmp1089 (apply (lambda (_1090 f1091 id1092 val1093 e11094 e21095) (id?113 f1091)) tmp1089) #f) (apply (lambda (_1096 f1097 id1098 val1099 e11100 e21101) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-named-let94 (cons f1097 id1098) val1099 (cons e11100 e21101))) tmp1089) ((lambda (_1105) (syntax-violation (quote let) "bad let" (source-wrap142 e1074 w1076 s1077 mod1078))) tmp1079))) ($sc-dispatch tmp1079 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1079 (quote (any #(each (any any)) any . each-any))))) e1074)))) (global-extend111 (quote core) (quote letrec) (lambda (e1106 r1107 w1108 s1109 mod1110) ((lambda (tmp1111) ((lambda (tmp1112) (if tmp1112 (apply (lambda (_1113 id1114 val1115 e11116 e21117) (let ((ids1118 id1114)) (if (not (valid-bound-ids?138 ids1118)) (syntax-violation (quote letrec) "duplicate bound variable" e1106) (let ((labels1120 (gen-labels119 ids1118)) (new-vars1121 (map gen-var161 ids1118))) (let ((w1122 (make-binding-wrap130 ids1118 labels1120 w1108)) (r1123 (extend-var-env108 labels1120 new-vars1121 r1107))) (build-letrec95 s1109 (map syntax->datum ids1118) new-vars1121 (map (lambda (x1124) (chi149 x1124 r1123 w1122 mod1110)) val1115) (chi-body153 (cons e11116 e21117) (source-wrap142 e1106 w1122 s1109 mod1110) r1123 w1122 mod1110))))))) tmp1112) ((lambda (_1127) (syntax-violation (quote letrec) "bad letrec" (source-wrap142 e1106 w1108 s1109 mod1110))) tmp1111))) ($sc-dispatch tmp1111 (quote (any #(each (any any)) any . each-any))))) e1106))) (global-extend111 (quote core) (quote set!) (lambda (e1128 r1129 w1130 s1131 mod1132) ((lambda (tmp1133) ((lambda (tmp1134) (if (if tmp1134 (apply (lambda (_1135 id1136 val1137) (id?113 id1136)) tmp1134) #f) (apply (lambda (_1138 id1139 val1140) (let ((val1141 (chi149 val1140 r1129 w1130 mod1132)) (n1142 (id-var-name135 id1139 w1130))) (let ((b1143 (lookup110 n1142 r1129 mod1132))) (let ((atom-key1144 (binding-type105 b1143))) (if (memv atom-key1144 (quote (lexical))) (build-lexical-assignment84 s1131 (syntax->datum id1139) (binding-value106 b1143) val1141) (if (memv atom-key1144 (quote (global))) (build-global-assignment87 s1131 n1142 val1141 mod1132) (if (memv atom-key1144 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap141 id1139 w1130 mod1132)) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))))))))) tmp1134) ((lambda (tmp1145) (if tmp1145 (apply (lambda (_1146 head1147 tail1148 val1149) (call-with-values (lambda () (syntax-type147 head1147 r1129 (quote (())) #f #f mod1132)) (lambda (type1150 value1151 ee1152 ww1153 ss1154 modmod1155) (if (memv type1150 (quote (module-ref))) (let ((val1156 (chi149 val1149 r1129 w1130 mod1132))) (call-with-values (lambda () (value1151 (cons head1147 tail1148))) (lambda (id1158 mod1159) (build-global-assignment87 s1131 id1158 val1156 mod1159)))) (build-application81 s1131 (chi149 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1147) r1129 w1130 mod1132) (map (lambda (e1160) (chi149 e1160 r1129 w1130 mod1132)) (append tail1148 (list val1149)))))))) tmp1145) ((lambda (_1162) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))) tmp1133))) ($sc-dispatch tmp1133 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1133 (quote (any any any))))) e1128))) (global-extend111 (quote module-ref) (quote @) (lambda (e1163) ((lambda (tmp1164) ((lambda (tmp1165) (if (if tmp1165 (apply (lambda (_1166 mod1167 id1168) (if (and-map id?113 mod1167) (id?113 id1168) #f)) tmp1165) #f) (apply (lambda (_1170 mod1171 id1172) (values (syntax->datum id1172) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1171)))) tmp1165) (syntax-violation #f "source expression failed to match any pattern" tmp1164))) ($sc-dispatch tmp1164 (quote (any each-any any))))) e1163))) (global-extend111 (quote module-ref) (quote @@) (lambda (e1174) ((lambda (tmp1175) ((lambda (tmp1176) (if (if tmp1176 (apply (lambda (_1177 mod1178 id1179) (if (and-map id?113 mod1178) (id?113 id1179) #f)) tmp1176) #f) (apply (lambda (_1181 mod1182 id1183) (values (syntax->datum id1183) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1182)))) tmp1176) (syntax-violation #f "source expression failed to match any pattern" tmp1175))) ($sc-dispatch tmp1175 (quote (any each-any any))))) e1174))) (global-extend111 (quote core) (quote if) (lambda (e1185 r1186 w1187 s1188 mod1189) ((lambda (tmp1190) ((lambda (tmp1191) (if tmp1191 (apply (lambda (_1192 test1193 then1194) (build-conditional82 s1188 (chi149 test1193 r1186 w1187 mod1189) (chi149 then1194 r1186 w1187 mod1189) (build-void80 #f))) tmp1191) ((lambda (tmp1195) (if tmp1195 (apply (lambda (_1196 test1197 then1198 else1199) (build-conditional82 s1188 (chi149 test1197 r1186 w1187 mod1189) (chi149 then1198 r1186 w1187 mod1189) (chi149 else1199 r1186 w1187 mod1189))) tmp1195) (syntax-violation #f "source expression failed to match any pattern" tmp1190))) ($sc-dispatch tmp1190 (quote (any any any any)))))) ($sc-dispatch tmp1190 (quote (any any any))))) e1185))) (global-extend111 (quote begin) (quote begin) (quote ())) (global-extend111 (quote define) (quote define) (quote ())) (global-extend111 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend111 (quote eval-when) (quote eval-when) (quote ())) (global-extend111 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1203 (lambda (x1204 keys1205 clauses1206 r1207 mod1208) (if (null? clauses1206) (build-application81 #f (build-primref90 #f (quote syntax-violation)) (list (build-data91 #f #f) (build-data91 #f "source expression failed to match any pattern") x1204)) ((lambda (tmp1209) ((lambda (tmp1210) (if tmp1210 (apply (lambda (pat1211 exp1212) (if (if (id?113 pat1211) (and-map (lambda (x1213) (not (free-id=?136 pat1211 x1213))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1205)) #f) (let ((labels1214 (list (gen-label118))) (var1215 (gen-var161 pat1211))) (build-application81 #f (build-lambda89 #f (list (syntax->datum pat1211)) (list var1215) #f (chi149 exp1212 (extend-env107 labels1214 (list (cons (quote syntax) (cons var1215 0))) r1207) (make-binding-wrap130 (list pat1211) labels1214 (quote (()))) mod1208)) (list x1204))) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1211 #t exp1212 mod1208))) tmp1210) ((lambda (tmp1216) (if tmp1216 (apply (lambda (pat1217 fender1218 exp1219) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1217 fender1218 exp1219 mod1208)) tmp1216) ((lambda (_1220) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1206))) tmp1209))) ($sc-dispatch tmp1209 (quote (any any any)))))) ($sc-dispatch tmp1209 (quote (any any))))) (car clauses1206))))) (gen-clause1202 (lambda (x1221 keys1222 clauses1223 r1224 pat1225 fender1226 exp1227 mod1228) (call-with-values (lambda () (convert-pattern1200 pat1225 keys1222)) (lambda (p1229 pvars1230) (if (not (distinct-bound-ids?139 (map car pvars1230))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1225) (if (not (and-map (lambda (x1231) (not (ellipsis?158 (car x1231)))) pvars1230)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1225) (let ((y1232 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda89 #f (list (quote tmp)) (list y1232) #f (let ((y1233 (build-lexical-reference83 (quote value) #f (quote tmp) y1232))) (build-conditional82 #f ((lambda (tmp1234) ((lambda (tmp1235) (if tmp1235 (apply (lambda () y1233) tmp1235) ((lambda (_1236) (build-conditional82 #f y1233 (build-dispatch-call1201 pvars1230 fender1226 y1233 r1224 mod1228) (build-data91 #f #f))) tmp1234))) ($sc-dispatch tmp1234 (quote #(atom #t))))) fender1226) (build-dispatch-call1201 pvars1230 exp1227 y1233 r1224 mod1228) (gen-syntax-case1203 x1221 keys1222 clauses1223 r1224 mod1228)))) (list (if (eq? p1229 (quote any)) (build-application81 #f (build-primref90 #f (quote list)) (list x1221)) (build-application81 #f (build-primref90 #f (quote $sc-dispatch)) (list x1221 (build-data91 #f p1229))))))))))))) (build-dispatch-call1201 (lambda (pvars1237 exp1238 y1239 r1240 mod1241) (let ((ids1242 (map car pvars1237)) (levels1243 (map cdr pvars1237))) (let ((labels1244 (gen-labels119 ids1242)) (new-vars1245 (map gen-var161 ids1242))) (build-application81 #f (build-primref90 #f (quote apply)) (list (build-lambda89 #f (map syntax->datum ids1242) new-vars1245 #f (chi149 exp1238 (extend-env107 labels1244 (map (lambda (var1246 level1247) (cons (quote syntax) (cons var1246 level1247))) new-vars1245 (map cdr pvars1237)) r1240) (make-binding-wrap130 ids1242 labels1244 (quote (()))) mod1241)) y1239)))))) (convert-pattern1200 (lambda (pattern1248 keys1249) (letrec ((cvt1250 (lambda (p1251 n1252 ids1253) (if (id?113 p1251) (if (bound-id-member?140 p1251 keys1249) (values (vector (quote free-id) p1251) ids1253) (values (quote any) (cons (cons p1251 n1252) ids1253))) ((lambda (tmp1254) ((lambda (tmp1255) (if (if tmp1255 (apply (lambda (x1256 dots1257) (ellipsis?158 dots1257)) tmp1255) #f) (apply (lambda (x1258 dots1259) (call-with-values (lambda () (cvt1250 x1258 (fx+72 n1252 1) ids1253)) (lambda (p1260 ids1261) (values (if (eq? p1260 (quote any)) (quote each-any) (vector (quote each) p1260)) ids1261)))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda (x1263 y1264) (call-with-values (lambda () (cvt1250 y1264 n1252 ids1253)) (lambda (y1265 ids1266) (call-with-values (lambda () (cvt1250 x1263 n1252 ids1266)) (lambda (x1267 ids1268) (values (cons x1267 y1265) ids1268)))))) tmp1262) ((lambda (tmp1269) (if tmp1269 (apply (lambda () (values (quote ()) ids1253)) tmp1269) ((lambda (tmp1270) (if tmp1270 (apply (lambda (x1271) (call-with-values (lambda () (cvt1250 x1271 n1252 ids1253)) (lambda (p1273 ids1274) (values (vector (quote vector) p1273) ids1274)))) tmp1270) ((lambda (x1275) (values (vector (quote atom) (strip160 p1251 (quote (())))) ids1253)) tmp1254))) ($sc-dispatch tmp1254 (quote #(vector each-any)))))) ($sc-dispatch tmp1254 (quote ()))))) ($sc-dispatch tmp1254 (quote (any . any)))))) ($sc-dispatch tmp1254 (quote (any any))))) p1251))))) (cvt1250 pattern1248 0 (quote ())))))) (lambda (e1276 r1277 w1278 s1279 mod1280) (let ((e1281 (source-wrap142 e1276 w1278 s1279 mod1280))) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (_1284 val1285 key1286 m1287) (if (and-map (lambda (x1288) (if (id?113 x1288) (not (ellipsis?158 x1288)) #f)) key1286) (let ((x1290 (gen-var161 (quote tmp)))) (build-application81 s1279 (build-lambda89 #f (list (quote tmp)) (list x1290) #f (gen-syntax-case1203 (build-lexical-reference83 (quote value) #f (quote tmp) x1290) key1286 m1287 r1277 mod1280)) (list (chi149 val1285 r1277 (quote (())) mod1280)))) (syntax-violation (quote syntax-case) "invalid literals list" e1281))) tmp1283) (syntax-violation #f "source expression failed to match any pattern" tmp1282))) ($sc-dispatch tmp1282 (quote (any any each-any . each-any))))) e1281))))) (set! sc-expand (lambda (x1294 . rest1293) (if (if (pair? x1294) (equal? (car x1294) noexpand70) #f) (cadr x1294) (let ((m1295 (if (null? rest1293) (quote e) (car rest1293))) (esew1296 (if (let ((t1297 (null? rest1293))) (if t1297 t1297 (null? (cdr rest1293)))) (quote (eval)) (cadr rest1293)))) (with-fluid* *mode*71 m1295 (lambda () (chi-top148 x1294 (quote ()) (quote ((top))) m1295 esew1296 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1298) (nonsymbol-id?112 x1298))) (set! datum->syntax (lambda (id1299 datum1300) (make-syntax-object96 datum1300 (syntax-object-wrap99 id1299) #f))) (set! syntax->datum (lambda (x1301) (strip160 x1301 (quote (()))))) (set! generate-temporaries (lambda (ls1302) (begin (let ((x1303 ls1302)) (if (not (list? x1303)) (syntax-violation (quote generate-temporaries) "invalid argument" x1303) (if #f #f))) (map (lambda (x1304) (wrap141 (gensym) (quote ((top))) #f)) ls1302)))) (set! free-identifier=? (lambda (x1305 y1306) (begin (let ((x1307 x1305)) (if (not (nonsymbol-id?112 x1307)) (syntax-violation (quote free-identifier=?) "invalid argument" x1307) (if #f #f))) (let ((x1308 y1306)) (if (not (nonsymbol-id?112 x1308)) (syntax-violation (quote free-identifier=?) "invalid argument" x1308) (if #f #f))) (free-id=?136 x1305 y1306)))) (set! bound-identifier=? (lambda (x1309 y1310) (begin (let ((x1311 x1309)) (if (not (nonsymbol-id?112 x1311)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1311) (if #f #f))) (let ((x1312 y1310)) (if (not (nonsymbol-id?112 x1312)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1312) (if #f #f))) (bound-id=?137 x1309 y1310)))) (set! syntax-violation (lambda (who1316 message1315 form1314 . subform1313) (begin (let ((x1317 who1316)) (if (not ((lambda (x1318) (let ((t1319 (not x1318))) (if t1319 t1319 (let ((t1320 (string? x1318))) (if t1320 t1320 (symbol? x1318)))))) x1317)) (syntax-violation (quote syntax-violation) "invalid argument" x1317) (if #f #f))) (let ((x1321 message1315)) (if (not (string? x1321)) (syntax-violation (quote syntax-violation) "invalid argument" x1321) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1316 "~a: " "") "~a " (if (null? subform1313) "in ~a" "in subform `~s' of `~s'")) (let ((tail1322 (cons message1315 (map (lambda (x1323) (strip160 x1323 (quote (())))) (append subform1313 (list form1314)))))) (if who1316 (cons who1316 tail1322) tail1322)) #f)))) (letrec ((match1328 (lambda (e1329 p1330 w1331 r1332 mod1333) (if (not r1332) #f (if (eq? p1330 (quote any)) (cons (wrap141 e1329 w1331 mod1333) r1332) (if (syntax-object?97 e1329) (match*1327 (let ((e1334 (syntax-object-expression98 e1329))) (if (annotation? e1334) (annotation-expression e1334) e1334)) p1330 (join-wraps132 w1331 (syntax-object-wrap99 e1329)) r1332 (syntax-object-module100 e1329)) (match*1327 (let ((e1335 e1329)) (if (annotation? e1335) (annotation-expression e1335) e1335)) p1330 w1331 r1332 mod1333)))))) (match*1327 (lambda (e1336 p1337 w1338 r1339 mod1340) (if (null? p1337) (if (null? e1336) r1339 #f) (if (pair? p1337) (if (pair? e1336) (match1328 (car e1336) (car p1337) w1338 (match1328 (cdr e1336) (cdr p1337) w1338 r1339 mod1340) mod1340) #f) (if (eq? p1337 (quote each-any)) (let ((l1341 (match-each-any1325 e1336 w1338 mod1340))) (if l1341 (cons l1341 r1339) #f)) (let ((atom-key1342 (vector-ref p1337 0))) (if (memv atom-key1342 (quote (each))) (if (null? e1336) (match-empty1326 (vector-ref p1337 1) r1339) (let ((l1343 (match-each1324 e1336 (vector-ref p1337 1) w1338 mod1340))) (if l1343 (letrec ((collect1344 (lambda (l1345) (if (null? (car l1345)) r1339 (cons (map car l1345) (collect1344 (map cdr l1345))))))) (collect1344 l1343)) #f))) (if (memv atom-key1342 (quote (free-id))) (if (id?113 e1336) (if (free-id=?136 (wrap141 e1336 w1338 mod1340) (vector-ref p1337 1)) r1339 #f) #f) (if (memv atom-key1342 (quote (atom))) (if (equal? (vector-ref p1337 1) (strip160 e1336 w1338)) r1339 #f) (if (memv atom-key1342 (quote (vector))) (if (vector? e1336) (match1328 (vector->list e1336) (vector-ref p1337 1) w1338 r1339 mod1340) #f) (if #f #f))))))))))) (match-empty1326 (lambda (p1346 r1347) (if (null? p1346) r1347 (if (eq? p1346 (quote any)) (cons (quote ()) r1347) (if (pair? p1346) (match-empty1326 (car p1346) (match-empty1326 (cdr p1346) r1347)) (if (eq? p1346 (quote each-any)) (cons (quote ()) r1347) (let ((atom-key1348 (vector-ref p1346 0))) (if (memv atom-key1348 (quote (each))) (match-empty1326 (vector-ref p1346 1) r1347) (if (memv atom-key1348 (quote (free-id atom))) r1347 (if (memv atom-key1348 (quote (vector))) (match-empty1326 (vector-ref p1346 1) r1347) (if #f #f))))))))))) (match-each-any1325 (lambda (e1349 w1350 mod1351) (if (annotation? e1349) (match-each-any1325 (annotation-expression e1349) w1350 mod1351) (if (pair? e1349) (let ((l1352 (match-each-any1325 (cdr e1349) w1350 mod1351))) (if l1352 (cons (wrap141 (car e1349) w1350 mod1351) l1352) #f)) (if (null? e1349) (quote ()) (if (syntax-object?97 e1349) (match-each-any1325 (syntax-object-expression98 e1349) (join-wraps132 w1350 (syntax-object-wrap99 e1349)) mod1351) #f)))))) (match-each1324 (lambda (e1353 p1354 w1355 mod1356) (if (annotation? e1353) (match-each1324 (annotation-expression e1353) p1354 w1355 mod1356) (if (pair? e1353) (let ((first1357 (match1328 (car e1353) p1354 w1355 (quote ()) mod1356))) (if first1357 (let ((rest1358 (match-each1324 (cdr e1353) p1354 w1355 mod1356))) (if rest1358 (cons first1357 rest1358) #f)) #f)) (if (null? e1353) (quote ()) (if (syntax-object?97 e1353) (match-each1324 (syntax-object-expression98 e1353) p1354 (join-wraps132 w1355 (syntax-object-wrap99 e1353)) (syntax-object-module100 e1353)) #f))))))) (set! $sc-dispatch (lambda (e1359 p1360) (if (eq? p1360 (quote any)) (list e1359) (if (syntax-object?97 e1359) (match*1327 (let ((e1361 (syntax-object-expression98 e1359))) (if (annotation? e1361) (annotation-expression e1361) e1361)) p1360 (syntax-object-wrap99 e1359) (quote ()) (syntax-object-module100 e1359)) (match*1327 (let ((e1362 e1359)) (if (annotation? e1362) (annotation-expression e1362) e1362)) p1360 (quote (())) (quote ()) #f))))))))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars291) (letrec ((lvl292 (lambda (vars293 ls294 w295) (if (pair? vars293) (lvl292 (cdr vars293) (cons (wrap141 (car vars293) w295 #f) ls294) w295) (if (id?113 vars293) (cons (wrap141 vars293 w295 #f) ls294) (if (null? vars293) ls294 (if (syntax-object?97 vars293) (lvl292 (syntax-object-expression98 vars293) ls294 (join-wraps132 w295 (syntax-object-wrap99 vars293))) (if (annotation? vars293) (lvl292 (annotation-expression vars293) ls294 w295) (cons vars293 ls294))))))))) (lvl292 vars291 (quote ()) (quote (())))))) (gen-var161 (lambda (id296) (let ((id297 (if (syntax-object?97 id296) (syntax-object-expression98 id296) id296))) (if (annotation? id297) (gensym (symbol->string (annotation-expression id297))) (gensym (symbol->string id297)))))) (strip160 (lambda (x298 w299) (if (memq (quote top) (wrap-marks116 w299)) (if (let ((t300 (annotation? x298))) (if t300 t300 (if (pair? x298) (annotation? (car x298)) #f))) (strip-annotation159 x298 #f) x298) (letrec ((f301 (lambda (x302) (if (syntax-object?97 x302) (strip160 (syntax-object-expression98 x302) (syntax-object-wrap99 x302)) (if (pair? x302) (let ((a303 (f301 (car x302))) (d304 (f301 (cdr x302)))) (if (if (eq? a303 (car x302)) (eq? d304 (cdr x302)) #f) x302 (cons a303 d304))) (if (vector? x302) (let ((old305 (vector->list x302))) (let ((new306 (map f301 old305))) (if (and-map*17 eq? old305 new306) x302 (list->vector new306)))) x302)))))) (f301 x298))))) (strip-annotation159 (lambda (x307 parent308) (if (pair? x307) (let ((new309 (cons #f #f))) (begin (if parent308 (set-annotation-stripped! parent308 new309)) (set-car! new309 (strip-annotation159 (car x307) #f)) (set-cdr! new309 (strip-annotation159 (cdr x307) #f)) new309)) (if (annotation? x307) (let ((t310 (annotation-stripped x307))) (if t310 t310 (strip-annotation159 (annotation-expression x307) x307))) (if (vector? x307) (let ((new311 (make-vector (vector-length x307)))) (begin (if parent308 (set-annotation-stripped! parent308 new311)) (letrec ((loop312 (lambda (i313) (unless (fx<75 i313 0) (vector-set! new311 i313 (strip-annotation159 (vector-ref x307 i313) #f)) (loop312 (fx-73 i313 1)))))) (loop312 (- (vector-length x307) 1))) new311)) x307))))) (ellipsis?158 (lambda (x314) (if (nonsymbol-id?112 x314) (free-id=?136 x314 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void157 (lambda () (build-void80 #f))) (eval-local-transformer156 (lambda (expanded315 mod316) (let ((p317 (local-eval-hook77 expanded315 mod316))) (if (procedure? p317) p317 (syntax-violation #f "nonprocedure transformer" p317))))) (chi-local-syntax155 (lambda (rec?318 e319 r320 w321 s322 mod323 k324) ((lambda (tmp325) ((lambda (tmp326) (if tmp326 (apply (lambda (_327 id328 val329 e1330 e2331) (let ((ids332 id328)) (if (not (valid-bound-ids?138 ids332)) (syntax-violation #f "duplicate bound keyword" e319) (let ((labels334 (gen-labels119 ids332))) (let ((new-w335 (make-binding-wrap130 ids332 labels334 w321))) (k324 (cons e1330 e2331) (extend-env107 labels334 (let ((w337 (if rec?318 new-w335 w321)) (trans-r338 (macros-only-env109 r320))) (map (lambda (x339) (cons (quote macro) (eval-local-transformer156 (chi149 x339 trans-r338 w337 mod323) mod323))) val329)) r320) new-w335 s322 mod323)))))) tmp326) ((lambda (_341) (syntax-violation #f "bad local syntax definition" (source-wrap142 e319 w321 s322 mod323))) tmp325))) ($sc-dispatch tmp325 (quote (any #(each (any any)) any . each-any))))) e319))) (chi-lambda-clause154 (lambda (e342 docstring343 c344 r345 w346 mod347 k348) ((lambda (tmp349) ((lambda (tmp350) (if (if tmp350 (apply (lambda (args351 doc352 e1353 e2354) (if (string? (syntax->datum doc352)) (not docstring343) #f)) tmp350) #f) (apply (lambda (args355 doc356 e1357 e2358) (chi-lambda-clause154 e342 doc356 (cons args355 (cons e1357 e2358)) r345 w346 mod347 k348)) tmp350) ((lambda (tmp360) (if tmp360 (apply (lambda (id361 e1362 e2363) (let ((ids364 id361)) (if (not (valid-bound-ids?138 ids364)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels366 (gen-labels119 ids364)) (new-vars367 (map gen-var161 ids364))) (k348 (map syntax->datum ids364) new-vars367 (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1362 e2363) e342 (extend-var-env108 labels366 new-vars367 r345) (make-binding-wrap130 ids364 labels366 w346) mod347)))))) tmp360) ((lambda (tmp369) (if tmp369 (apply (lambda (ids370 e1371 e2372) (let ((old-ids373 (lambda-var-list162 ids370))) (if (not (valid-bound-ids?138 old-ids373)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels374 (gen-labels119 old-ids373)) (new-vars375 (map gen-var161 old-ids373))) (k348 (letrec ((f376 (lambda (ls1377 ls2378) (if (null? ls1377) (syntax->datum ls2378) (f376 (cdr ls1377) (cons (syntax->datum (car ls1377)) ls2378)))))) (f376 (cdr old-ids373) (car old-ids373))) (letrec ((f379 (lambda (ls1380 ls2381) (if (null? ls1380) ls2381 (f379 (cdr ls1380) (cons (car ls1380) ls2381)))))) (f379 (cdr new-vars375) (car new-vars375))) (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1371 e2372) e342 (extend-var-env108 labels374 new-vars375 r345) (make-binding-wrap130 old-ids373 labels374 w346) mod347)))))) tmp369) ((lambda (_383) (syntax-violation (quote lambda) "bad lambda" e342)) tmp349))) ($sc-dispatch tmp349 (quote (any any . each-any)))))) ($sc-dispatch tmp349 (quote (each-any any . each-any)))))) ($sc-dispatch tmp349 (quote (any any any . each-any))))) c344))) (chi-body153 (lambda (body384 outer-form385 r386 w387 mod388) (let ((r389 (cons (quote ("placeholder" placeholder)) r386))) (let ((ribcage390 (make-ribcage120 (quote ()) (quote ()) (quote ())))) (let ((w391 (make-wrap115 (wrap-marks116 w387) (cons ribcage390 (wrap-subst117 w387))))) (letrec ((parse392 (lambda (body393 ids394 labels395 vars396 vals397 bindings398) (if (null? body393) (syntax-violation #f "no expressions in body" outer-form385) (let ((e400 (cdar body393)) (er401 (caar body393))) (call-with-values (lambda () (syntax-type147 e400 er401 (quote (())) #f ribcage390 mod388)) (lambda (type402 value403 e404 w405 s406 mod407) (if (memv type402 (quote (define-form))) (let ((id408 (wrap141 value403 w405 mod407)) (label409 (gen-label118))) (let ((var410 (gen-var161 id408))) (begin (extend-ribcage!129 ribcage390 id408 label409) (parse392 (cdr body393) (cons id408 ids394) (cons label409 labels395) (cons var410 vars396) (cons (cons er401 (wrap141 e404 w405 mod407)) vals397) (cons (cons (quote lexical) var410) bindings398))))) (if (memv type402 (quote (define-syntax-form))) (let ((id411 (wrap141 value403 w405 mod407)) (label412 (gen-label118))) (begin (extend-ribcage!129 ribcage390 id411 label412) (parse392 (cdr body393) (cons id411 ids394) (cons label412 labels395) vars396 vals397 (cons (cons (quote macro) (cons er401 (wrap141 e404 w405 mod407))) bindings398)))) (if (memv type402 (quote (begin-form))) ((lambda (tmp413) ((lambda (tmp414) (if tmp414 (apply (lambda (_415 e1416) (parse392 (letrec ((f417 (lambda (forms418) (if (null? forms418) (cdr body393) (cons (cons er401 (wrap141 (car forms418) w405 mod407)) (f417 (cdr forms418))))))) (f417 e1416)) ids394 labels395 vars396 vals397 bindings398)) tmp414) (syntax-violation #f "source expression failed to match any pattern" tmp413))) ($sc-dispatch tmp413 (quote (any . each-any))))) e404) (if (memv type402 (quote (local-syntax-form))) (chi-local-syntax155 value403 e404 er401 w405 s406 mod407 (lambda (forms420 er421 w422 s423 mod424) (parse392 (letrec ((f425 (lambda (forms426) (if (null? forms426) (cdr body393) (cons (cons er421 (wrap141 (car forms426) w422 mod424)) (f425 (cdr forms426))))))) (f425 forms420)) ids394 labels395 vars396 vals397 bindings398))) (if (null? ids394) (build-sequence92 #f (map (lambda (x427) (chi149 (cdr x427) (car x427) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))) (begin (if (not (valid-bound-ids?138 ids394)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form385)) (letrec ((loop428 (lambda (bs429 er-cache430 r-cache431) (if (not (null? bs429)) (let ((b432 (car bs429))) (if (eq? (car b432) (quote macro)) (let ((er433 (cadr b432))) (let ((r-cache434 (if (eq? er433 er-cache430) r-cache431 (macros-only-env109 er433)))) (begin (set-cdr! b432 (eval-local-transformer156 (chi149 (cddr b432) r-cache434 (quote (())) mod407) mod407)) (loop428 (cdr bs429) er433 r-cache434)))) (loop428 (cdr bs429) er-cache430 r-cache431))))))) (loop428 bindings398 #f #f)) (set-cdr! r389 (extend-env107 labels395 bindings398 (cdr r389))) (build-letrec95 #f (map syntax->datum ids394) vars396 (map (lambda (x435) (chi149 (cdr x435) (car x435) (quote (())) mod407)) vals397) (build-sequence92 #f (map (lambda (x436) (chi149 (cdr x436) (car x436) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))))))))))))))))) (parse392 (map (lambda (x399) (cons r389 (wrap141 x399 w391 mod388))) body384) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro152 (lambda (p437 e438 r439 w440 rib441 mod442) (letrec ((rebuild-macro-output443 (lambda (x444 m445) (if (pair? x444) (cons (rebuild-macro-output443 (car x444) m445) (rebuild-macro-output443 (cdr x444) m445)) (if (syntax-object?97 x444) (let ((w446 (syntax-object-wrap99 x444))) (let ((ms447 (wrap-marks116 w446)) (s448 (wrap-subst117 w446))) (if (if (pair? ms447) (eq? (car ms447) #f) #f) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cdr ms447) (if rib441 (cons rib441 (cdr s448)) (cdr s448))) (syntax-object-module100 x444)) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cons m445 ms447) (if rib441 (cons rib441 (cons (quote shift) s448)) (cons (quote shift) s448))) (let ((pmod449 (procedure-module p437))) (if pmod449 (cons (quote hygiene) (module-name pmod449)) (quote (hygiene guile)))))))) (if (vector? x444) (let ((n450 (vector-length x444))) (let ((v451 (make-vector n450))) (letrec ((loop452 (lambda (i453) (if (fx=74 i453 n450) (begin (if #f #f) v451) (begin (vector-set! v451 i453 (rebuild-macro-output443 (vector-ref x444 i453) m445)) (loop452 (fx+72 i453 1))))))) (loop452 0)))) (if (symbol? x444) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap142 e438 w440 s mod442) x444) x444))))))) (rebuild-macro-output443 (p437 (wrap141 e438 (anti-mark128 w440) mod442)) (string #\m))))) (chi-application151 (lambda (x454 e455 r456 w457 s458 mod459) ((lambda (tmp460) ((lambda (tmp461) (if tmp461 (apply (lambda (e0462 e1463) (build-application81 s458 x454 (map (lambda (e464) (chi149 e464 r456 w457 mod459)) e1463))) tmp461) (syntax-violation #f "source expression failed to match any pattern" tmp460))) ($sc-dispatch tmp460 (quote (any . each-any))))) e455))) (chi-expr150 (lambda (type466 value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (lexical))) (build-lexical-reference83 (quote value) s471 e468 value467) (if (memv type466 (quote (core external-macro))) (value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (module-ref))) (call-with-values (lambda () (value467 e468)) (lambda (id473 mod474) (build-global-reference86 s471 id473 mod474))) (if (memv type466 (quote (lexical-call))) (chi-application151 (build-lexical-reference83 (quote fun) (source-annotation104 (car e468)) (car e468) value467) e468 r469 w470 s471 mod472) (if (memv type466 (quote (global-call))) (chi-application151 (build-global-reference86 (source-annotation104 (car e468)) value467 (if (syntax-object?97 (car e468)) (syntax-object-module100 (car e468)) mod472)) e468 r469 w470 s471 mod472) (if (memv type466 (quote (constant))) (build-data91 s471 (strip160 (source-wrap142 e468 w470 s471 mod472) (quote (())))) (if (memv type466 (quote (global))) (build-global-reference86 s471 value467 mod472) (if (memv type466 (quote (call))) (chi-application151 (chi149 (car e468) r469 w470 mod472) e468 r469 w470 s471 mod472) (if (memv type466 (quote (begin-form))) ((lambda (tmp475) ((lambda (tmp476) (if tmp476 (apply (lambda (_477 e1478 e2479) (chi-sequence143 (cons e1478 e2479) r469 w470 s471 mod472)) tmp476) (syntax-violation #f "source expression failed to match any pattern" tmp475))) ($sc-dispatch tmp475 (quote (any any . each-any))))) e468) (if (memv type466 (quote (local-syntax-form))) (chi-local-syntax155 value467 e468 r469 w470 s471 mod472 chi-sequence143) (if (memv type466 (quote (eval-when-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 x484 e1485 e2486) (let ((when-list487 (chi-when-list146 e468 x484 w470))) (if (memq (quote eval) when-list487) (chi-sequence143 (cons e1485 e2486) r469 w470 s471 mod472) (chi-void157)))) tmp482) (syntax-violation #f "source expression failed to match any pattern" tmp481))) ($sc-dispatch tmp481 (quote (any each-any any . each-any))))) e468) (if (memv type466 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e468 (wrap141 value467 w470 mod472)) (if (memv type466 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap142 e468 w470 s471 mod472)) (if (memv type466 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap142 e468 w470 s471 mod472)) (syntax-violation #f "unexpected syntax" (source-wrap142 e468 w470 s471 mod472)))))))))))))))))) (chi149 (lambda (e490 r491 w492 mod493) (call-with-values (lambda () (syntax-type147 e490 r491 w492 #f #f mod493)) (lambda (type494 value495 e496 w497 s498 mod499) (chi-expr150 type494 value495 e496 r491 w497 s498 mod499))))) (chi-top148 (lambda (e500 r501 w502 m503 esew504 mod505) (call-with-values (lambda () (syntax-type147 e500 r501 w502 #f #f mod505)) (lambda (type513 value514 e515 w516 s517 mod518) (if (memv type513 (quote (begin-form))) ((lambda (tmp519) ((lambda (tmp520) (if tmp520 (apply (lambda (_521) (chi-void157)) tmp520) ((lambda (tmp522) (if tmp522 (apply (lambda (_523 e1524 e2525) (chi-top-sequence144 (cons e1524 e2525) r501 w516 s517 m503 esew504 mod518)) tmp522) (syntax-violation #f "source expression failed to match any pattern" tmp519))) ($sc-dispatch tmp519 (quote (any any . each-any)))))) ($sc-dispatch tmp519 (quote (any))))) e515) (if (memv type513 (quote (local-syntax-form))) (chi-local-syntax155 value514 e515 r501 w516 s517 mod518 (lambda (body527 r528 w529 s530 mod531) (chi-top-sequence144 body527 r528 w529 s530 m503 esew504 mod531))) (if (memv type513 (quote (eval-when-form))) ((lambda (tmp532) ((lambda (tmp533) (if tmp533 (apply (lambda (_534 x535 e1536 e2537) (let ((when-list538 (chi-when-list146 e515 x535 w516)) (body539 (cons e1536 e2537))) (if (eq? m503 (quote e)) (if (memq (quote eval) when-list538) (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) (chi-void157)) (if (memq (quote load) when-list538) (if (let ((t542 (memq (quote compile) when-list538))) (if t542 t542 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (chi-top-sequence144 body539 r501 w516 s517 (quote c&e) (quote (compile load)) mod518) (if (memq m503 (quote (c c&e))) (chi-top-sequence144 body539 r501 w516 s517 (quote c) (quote (load)) mod518) (chi-void157))) (if (let ((t543 (memq (quote compile) when-list538))) (if t543 t543 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (begin (top-level-eval-hook76 (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) mod518) (chi-void157)) (chi-void157)))))) tmp533) (syntax-violation #f "source expression failed to match any pattern" tmp532))) ($sc-dispatch tmp532 (quote (any each-any any . each-any))))) e515) (if (memv type513 (quote (define-syntax-form))) (let ((n544 (id-var-name135 value514 w516)) (r545 (macros-only-env109 r501))) (if (memv m503 (quote (c))) (if (memq (quote compile) esew504) (let ((e546 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e546 mod518) (if (memq (quote load) esew504) e546 (chi-void157)))) (if (memq (quote load) esew504) (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) (chi-void157))) (if (memv m503 (quote (c&e))) (let ((e547 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e547 mod518) e547)) (begin (if (memq (quote eval) esew504) (top-level-eval-hook76 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) mod518)) (chi-void157))))) (if (memv type513 (quote (define-form))) (let ((n548 (id-var-name135 value514 w516))) (let ((type549 (binding-type105 (lookup110 n548 r501 mod518)))) (if (memv type549 (quote (global core macro module-ref))) (let ((x550 (build-global-definition88 s517 n548 (chi149 e515 r501 w516 mod518)))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x550 mod518)) x550)) (if (memv type549 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e515 (wrap141 value514 w516 mod518)) (syntax-violation #f "cannot define keyword at top level" e515 (wrap141 value514 w516 mod518)))))) (let ((x551 (chi-expr150 type513 value514 e515 r501 w516 s517 mod518))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x551 mod518)) x551))))))))))) (syntax-type147 (lambda (e552 r553 w554 s555 rib556 mod557) (if (symbol? e552) (let ((n558 (id-var-name135 e552 w554))) (let ((b559 (lookup110 n558 r553 mod557))) (let ((type560 (binding-type105 b559))) (if (memv type560 (quote (lexical))) (values type560 (binding-value106 b559) e552 w554 s555 mod557) (if (memv type560 (quote (global))) (values type560 n558 e552 w554 s555 mod557) (if (memv type560 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b559) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (values type560 (binding-value106 b559) e552 w554 s555 mod557))))))) (if (pair? e552) (let ((first561 (car e552))) (if (id?113 first561) (let ((n562 (id-var-name135 first561 w554))) (let ((b563 (lookup110 n562 r553 (let ((t564 (if (syntax-object?97 first561) (syntax-object-module100 first561) #f))) (if t564 t564 mod557))))) (let ((type565 (binding-type105 b563))) (if (memv type565 (quote (lexical))) (values (quote lexical-call) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (global))) (values (quote global-call) n562 e552 w554 s555 mod557) (if (memv type565 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b563) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (if (memv type565 (quote (core external-macro module-ref))) (values type565 (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (begin))) (values (quote begin-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (eval-when))) (values (quote eval-when-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?113 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555 mod557)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (if (id?113 name576) (valid-bound-ids?138 (lambda-var-list162 args577)) #f)) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap141 name581 w554 mod557) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap141 (cons args582 (cons e1583 e2584)) w554 mod557)) (quote (())) s555 mod557)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?113 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap141 name590 w554 mod557) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s555 mod557)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e552) (if (memv type565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?113 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555 mod557)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) #f e552 w554 s555 mod557))))))))))))) (values (quote call) #f e552 w554 s555 mod557))) (if (syntax-object?97 e552) (syntax-type147 (syntax-object-expression98 e552) r553 (join-wraps132 w554 (syntax-object-wrap99 e552)) #f rib556 (let ((t599 (syntax-object-module100 e552))) (if t599 t599 mod557))) (if (annotation? e552) (syntax-type147 (annotation-expression e552) r553 w554 (annotation-source e552) rib556 mod557) (if (self-evaluating? e552) (values (quote constant) #f e552 w554 s555 mod557) (values (quote other) #f e552 w554 s555 mod557)))))))) (chi-when-list146 (lambda (e600 when-list601 w602) (letrec ((f603 (lambda (when-list604 situations605) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (if (free-id=?136 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?136 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?136 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e600 (wrap141 x606 w602 #f)))))) situations605)))))) (f603 when-list601 (quote ()))))) (chi-install-global145 (lambda (name607 e608) (build-global-definition88 #f name607 (if (let ((v609 (module-variable (current-module) name607))) (if v609 (if (variable-bound? v609) (if (macro? (variable-ref v609)) (not (eq? (macro-type (variable-ref v609)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref90 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref90 #f (quote module-ref)) (list (build-application81 #f (build-primref90 #f (quote current-module)) (quote ())) (build-data91 #f name607))) (build-data91 #f (quote macro)) e608)) (build-application81 #f (build-primref90 #f (quote make-syncase-macro)) (list (build-data91 #f (quote macro)) e608)))))) (chi-top-sequence144 (lambda (body610 r611 w612 s613 m614 esew615 mod616) (build-sequence92 s613 (letrec ((dobody617 (lambda (body618 r619 w620 m621 esew622 mod623) (if (null? body618) (quote ()) (let ((first624 (chi-top148 (car body618) r619 w620 m621 esew622 mod623))) (cons first624 (dobody617 (cdr body618) r619 w620 m621 esew622 mod623))))))) (dobody617 body610 r611 w612 m614 esew615 mod616))))) (chi-sequence143 (lambda (body625 r626 w627 s628 mod629) (build-sequence92 s628 (letrec ((dobody630 (lambda (body631 r632 w633 mod634) (if (null? body631) (quote ()) (let ((first635 (chi149 (car body631) r632 w633 mod634))) (cons first635 (dobody630 (cdr body631) r632 w633 mod634))))))) (dobody630 body625 r626 w627 mod629))))) (source-wrap142 (lambda (x636 w637 s638 defmod639) (wrap141 (if s638 (make-annotation x636 s638 #f) x636) w637 defmod639))) (wrap141 (lambda (x640 w641 defmod642) (if (if (null? (wrap-marks116 w641)) (null? (wrap-subst117 w641)) #f) x640 (if (syntax-object?97 x640) (make-syntax-object96 (syntax-object-expression98 x640) (join-wraps132 w641 (syntax-object-wrap99 x640)) (syntax-object-module100 x640)) (if (null? x640) x640 (make-syntax-object96 x640 w641 defmod642)))))) (bound-id-member?140 (lambda (x643 list644) (if (not (null? list644)) (let ((t645 (bound-id=?137 x643 (car list644)))) (if t645 t645 (bound-id-member?140 x643 (cdr list644)))) #f))) (distinct-bound-ids?139 (lambda (ids646) (letrec ((distinct?647 (lambda (ids648) (let ((t649 (null? ids648))) (if t649 t649 (if (not (bound-id-member?140 (car ids648) (cdr ids648))) (distinct?647 (cdr ids648)) #f)))))) (distinct?647 ids646)))) (valid-bound-ids?138 (lambda (ids650) (if (letrec ((all-ids?651 (lambda (ids652) (let ((t653 (null? ids652))) (if t653 t653 (if (id?113 (car ids652)) (all-ids?651 (cdr ids652)) #f)))))) (all-ids?651 ids650)) (distinct-bound-ids?139 ids650) #f))) (bound-id=?137 (lambda (i654 j655) (if (if (syntax-object?97 i654) (syntax-object?97 j655) #f) (if (eq? (let ((e656 (syntax-object-expression98 i654))) (if (annotation? e656) (annotation-expression e656) e656)) (let ((e657 (syntax-object-expression98 j655))) (if (annotation? e657) (annotation-expression e657) e657))) (same-marks?134 (wrap-marks116 (syntax-object-wrap99 i654)) (wrap-marks116 (syntax-object-wrap99 j655))) #f) (eq? (let ((e658 i654)) (if (annotation? e658) (annotation-expression e658) e658)) (let ((e659 j655)) (if (annotation? e659) (annotation-expression e659) e659)))))) (free-id=?136 (lambda (i660 j661) (if (eq? (let ((x662 i660)) (let ((e663 (if (syntax-object?97 x662) (syntax-object-expression98 x662) x662))) (if (annotation? e663) (annotation-expression e663) e663))) (let ((x664 j661)) (let ((e665 (if (syntax-object?97 x664) (syntax-object-expression98 x664) x664))) (if (annotation? e665) (annotation-expression e665) e665)))) (eq? (id-var-name135 i660 (quote (()))) (id-var-name135 j661 (quote (())))) #f))) (id-var-name135 (lambda (id666 w667) (letrec ((search-vector-rib670 (lambda (sym676 subst677 marks678 symnames679 ribcage680) (let ((n681 (vector-length symnames679))) (letrec ((f682 (lambda (i683) (if (fx=74 i683 n681) (search668 sym676 (cdr subst677) marks678) (if (if (eq? (vector-ref symnames679 i683) sym676) (same-marks?134 marks678 (vector-ref (ribcage-marks123 ribcage680) i683)) #f) (values (vector-ref (ribcage-labels124 ribcage680) i683) marks678) (f682 (fx+72 i683 1))))))) (f682 0))))) (search-list-rib669 (lambda (sym684 subst685 marks686 symnames687 ribcage688) (letrec ((f689 (lambda (symnames690 i691) (if (null? symnames690) (search668 sym684 (cdr subst685) marks686) (if (if (eq? (car symnames690) sym684) (same-marks?134 marks686 (list-ref (ribcage-marks123 ribcage688) i691)) #f) (values (list-ref (ribcage-labels124 ribcage688) i691) marks686) (f689 (cdr symnames690) (fx+72 i691 1))))))) (f689 symnames687 0)))) (search668 (lambda (sym692 subst693 marks694) (if (null? subst693) (values #f marks694) (let ((fst695 (car subst693))) (if (eq? fst695 (quote shift)) (search668 sym692 (cdr subst693) (cdr marks694)) (let ((symnames696 (ribcage-symnames122 fst695))) (if (vector? symnames696) (search-vector-rib670 sym692 subst693 marks694 symnames696 fst695) (search-list-rib669 sym692 subst693 marks694 symnames696 fst695))))))))) (if (symbol? id666) (let ((t697 (call-with-values (lambda () (search668 id666 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x699 . ignore698) x699)))) (if t697 t697 id666)) (if (syntax-object?97 id666) (let ((id700 (let ((e702 (syntax-object-expression98 id666))) (if (annotation? e702) (annotation-expression e702) e702))) (w1701 (syntax-object-wrap99 id666))) (let ((marks703 (join-marks133 (wrap-marks116 w667) (wrap-marks116 w1701)))) (call-with-values (lambda () (search668 id700 (wrap-subst117 w667) marks703)) (lambda (new-id704 marks705) (let ((t706 new-id704)) (if t706 t706 (let ((t707 (call-with-values (lambda () (search668 id700 (wrap-subst117 w1701) marks705)) (lambda (x709 . ignore708) x709)))) (if t707 t707 id700)))))))) (if (annotation? id666) (let ((id710 (let ((e711 id666)) (if (annotation? e711) (annotation-expression e711) e711)))) (let ((t712 (call-with-values (lambda () (search668 id710 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x714 . ignore713) x714)))) (if t712 t712 id710))) (syntax-violation (quote id-var-name) "invalid id" id666))))))) (same-marks?134 (lambda (x715 y716) (let ((t717 (eq? x715 y716))) (if t717 t717 (if (not (null? x715)) (if (not (null? y716)) (if (eq? (car x715) (car y716)) (same-marks?134 (cdr x715) (cdr y716)) #f) #f) #f))))) (join-marks133 (lambda (m1718 m2719) (smart-append131 m1718 m2719))) (join-wraps132 (lambda (w1720 w2721) (let ((m1722 (wrap-marks116 w1720)) (s1723 (wrap-subst117 w1720))) (if (null? m1722) (if (null? s1723) w2721 (make-wrap115 (wrap-marks116 w2721) (smart-append131 s1723 (wrap-subst117 w2721)))) (make-wrap115 (smart-append131 m1722 (wrap-marks116 w2721)) (smart-append131 s1723 (wrap-subst117 w2721))))))) (smart-append131 (lambda (m1724 m2725) (if (null? m2725) m1724 (append m1724 m2725)))) (make-binding-wrap130 (lambda (ids726 labels727 w728) (if (null? ids726) w728 (make-wrap115 (wrap-marks116 w728) (cons (let ((labelvec729 (list->vector labels727))) (let ((n730 (vector-length labelvec729))) (let ((symnamevec731 (make-vector n730)) (marksvec732 (make-vector n730))) (begin (letrec ((f733 (lambda (ids734 i735) (if (not (null? ids734)) (call-with-values (lambda () (id-sym-name&marks114 (car ids734) w728)) (lambda (symname736 marks737) (begin (vector-set! symnamevec731 i735 symname736) (vector-set! marksvec732 i735 marks737) (f733 (cdr ids734) (fx+72 i735 1))))))))) (f733 ids726 0)) (make-ribcage120 symnamevec731 marksvec732 labelvec729))))) (wrap-subst117 w728)))))) (extend-ribcage!129 (lambda (ribcage738 id739 label740) (begin (set-ribcage-symnames!125 ribcage738 (cons (let ((e741 (syntax-object-expression98 id739))) (if (annotation? e741) (annotation-expression e741) e741)) (ribcage-symnames122 ribcage738))) (set-ribcage-marks!126 ribcage738 (cons (wrap-marks116 (syntax-object-wrap99 id739)) (ribcage-marks123 ribcage738))) (set-ribcage-labels!127 ribcage738 (cons label740 (ribcage-labels124 ribcage738)))))) (anti-mark128 (lambda (w742) (make-wrap115 (cons #f (wrap-marks116 w742)) (cons (quote shift) (wrap-subst117 w742))))) (set-ribcage-labels!127 (lambda (x743 update744) (vector-set! x743 3 update744))) (set-ribcage-marks!126 (lambda (x745 update746) (vector-set! x745 2 update746))) (set-ribcage-symnames!125 (lambda (x747 update748) (vector-set! x747 1 update748))) (ribcage-labels124 (lambda (x749) (vector-ref x749 3))) (ribcage-marks123 (lambda (x750) (vector-ref x750 2))) (ribcage-symnames122 (lambda (x751) (vector-ref x751 1))) (ribcage?121 (lambda (x752) (if (vector? x752) (if (= (vector-length x752) 4) (eq? (vector-ref x752 0) (quote ribcage)) #f) #f))) (make-ribcage120 (lambda (symnames753 marks754 labels755) (vector (quote ribcage) symnames753 marks754 labels755))) (gen-labels119 (lambda (ls756) (if (null? ls756) (quote ()) (cons (gen-label118) (gen-labels119 (cdr ls756)))))) (gen-label118 (lambda () (string #\i))) (wrap-subst117 cdr) (wrap-marks116 car) (make-wrap115 cons) (id-sym-name&marks114 (lambda (x757 w758) (if (syntax-object?97 x757) (values (let ((e759 (syntax-object-expression98 x757))) (if (annotation? e759) (annotation-expression e759) e759)) (join-marks133 (wrap-marks116 w758) (wrap-marks116 (syntax-object-wrap99 x757)))) (values (let ((e760 x757)) (if (annotation? e760) (annotation-expression e760) e760)) (wrap-marks116 w758))))) (id?113 (lambda (x761) (if (symbol? x761) #t (if (syntax-object?97 x761) (symbol? (let ((e762 (syntax-object-expression98 x761))) (if (annotation? e762) (annotation-expression e762) e762))) (if (annotation? x761) (symbol? (annotation-expression x761)) #f))))) (nonsymbol-id?112 (lambda (x763) (if (syntax-object?97 x763) (symbol? (let ((e764 (syntax-object-expression98 x763))) (if (annotation? e764) (annotation-expression e764) e764))) #f))) (global-extend111 (lambda (type765 sym766 val767) (put-global-definition-hook78 sym766 type765 val767))) (lookup110 (lambda (x768 r769 mod770) (let ((temp771 (assq x768 r769))) (if temp771 (cdr temp771) (if (symbol? x768) (let ((t772 (get-global-definition-hook79 x768 mod770))) (if t772 t772 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env109 (lambda (r773) (if (null? r773) (quote ()) (let ((a774 (car r773))) (if (eq? (cadr a774) (quote macro)) (cons a774 (macros-only-env109 (cdr r773))) (macros-only-env109 (cdr r773))))))) (extend-var-env108 (lambda (labels775 vars776 r777) (if (null? labels775) r777 (extend-var-env108 (cdr labels775) (cdr vars776) (cons (cons (car labels775) (cons (quote lexical) (car vars776))) r777))))) (extend-env107 (lambda (labels778 bindings779 r780) (if (null? labels778) r780 (extend-env107 (cdr labels778) (cdr bindings779) (cons (cons (car labels778) (car bindings779)) r780))))) (binding-value106 cdr) (binding-type105 car) (source-annotation104 (lambda (x781) (if (annotation? x781) (annotation-source x781) (if (syntax-object?97 x781) (source-annotation104 (syntax-object-expression98 x781)) #f)))) (set-syntax-object-module!103 (lambda (x782 update783) (vector-set! x782 3 update783))) (set-syntax-object-wrap!102 (lambda (x784 update785) (vector-set! x784 2 update785))) (set-syntax-object-expression!101 (lambda (x786 update787) (vector-set! x786 1 update787))) (syntax-object-module100 (lambda (x788) (vector-ref x788 3))) (syntax-object-wrap99 (lambda (x789) (vector-ref x789 2))) (syntax-object-expression98 (lambda (x790) (vector-ref x790 1))) (syntax-object?97 (lambda (x791) (if (vector? x791) (if (= (vector-length x791) 4) (eq? (vector-ref x791 0) (quote syntax-object)) #f) #f))) (make-syntax-object96 (lambda (expression792 wrap793 module794) (vector (quote syntax-object) expression792 wrap793 module794))) (build-letrec95 (lambda (src795 ids796 vars797 val-exps798 body-exp799) (if (null? vars797) body-exp799 (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-letrec) src795 ids796 vars797 val-exps798 body-exp799) (list (quote letrec) (map list vars797 val-exps798) body-exp799)))))) (build-named-let94 (lambda (src801 ids802 vars803 val-exps804 body-exp805) (let ((f806 (car vars803)) (f-name807 (car ids802)) (vars808 (cdr vars803)) (ids809 (cdr ids802))) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-letrec) src801 (list f-name807) (list f806) (list (build-lambda89 src801 ids809 vars808 #f body-exp805)) (build-application81 src801 (build-lexical-reference83 (quote fun) src801 f-name807 f806) val-exps804)) (list (quote let) f806 (map list vars808 val-exps804) body-exp805)))))) (build-let93 (lambda (src811 ids812 vars813 val-exps814 body-exp815) (if (null? vars813) body-exp815 (let ((atom-key816 (fluid-ref *mode*71))) (if (memv atom-key816 (quote (c))) ((@ (language tree-il) make-let) src811 ids812 vars813 val-exps814 body-exp815) (list (quote let) (map list vars813 val-exps814) body-exp815)))))) (build-sequence92 (lambda (src817 exps818) (if (null? (cdr exps818)) (car exps818) (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) ((@ (language tree-il) make-sequence) src817 exps818) (cons (quote begin) exps818)))))) (build-data91 (lambda (src820 exp821) (let ((atom-key822 (fluid-ref *mode*71))) (if (memv atom-key822 (quote (c))) ((@ (language tree-il) make-const) src820 exp821) (if (if (self-evaluating? exp821) (not (vector? exp821)) #f) exp821 (list (quote quote) exp821)))))) (build-primref90 (lambda (src823 name824) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src823 name824) name824)) (let ((atom-key826 (fluid-ref *mode*71))) (if (memv atom-key826 (quote (c))) ((@ (language tree-il) make-module-ref) src823 (quote (guile)) name824 #f) (list (quote @@) (quote (guile)) name824)))))) (build-lambda89 (lambda (src827 ids828 vars829 docstring830 exp831) (let ((atom-key832 (fluid-ref *mode*71))) (if (memv atom-key832 (quote (c))) ((@ (language tree-il) make-lambda) src827 ids828 vars829 (if docstring830 (list (cons (quote documentation) docstring830)) (quote ())) exp831) (cons (quote lambda) (cons vars829 (append (if docstring830 (list docstring830) (quote ())) (list exp831)))))))) (build-global-definition88 (lambda (source833 var834 exp835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-define) source833 var834 exp835) (list (quote define) var834 exp835))))) (build-global-assignment87 (lambda (source837 var838 exp839 mod840) (analyze-variable85 mod840 var838 (lambda (mod841 var842 public?843) (let ((atom-key844 (fluid-ref *mode*71))) (if (memv atom-key844 (quote (c))) ((@ (language tree-il) make-module-set) source837 mod841 var842 public?843 exp839) (list (quote set!) (list (if public?843 (quote @) (quote @@)) mod841 var842) exp839)))) (lambda (var845) (let ((atom-key846 (fluid-ref *mode*71))) (if (memv atom-key846 (quote (c))) ((@ (language tree-il) make-toplevel-set) source837 var845 exp839) (list (quote set!) var845 exp839))))))) (build-global-reference86 (lambda (source847 var848 mod849) (analyze-variable85 mod849 var848 (lambda (mod850 var851 public?852) (let ((atom-key853 (fluid-ref *mode*71))) (if (memv atom-key853 (quote (c))) ((@ (language tree-il) make-module-ref) source847 mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851)))) (lambda (var854) (let ((atom-key855 (fluid-ref *mode*71))) (if (memv atom-key855 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source847 var854) var854)))))) (analyze-variable85 (lambda (mod856 var857 modref-cont858 bare-cont859) (if (not mod856) (bare-cont859 var857) (let ((kind860 (car mod856)) (mod861 (cdr mod856))) (if (memv kind860 (quote (public))) (modref-cont858 mod861 var857 #t) (if (memv kind860 (quote (private))) (if (not (equal? mod861 (module-name (current-module)))) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (if (memv kind860 (quote (bare))) (bare-cont859 var857) (if (memv kind860 (quote (hygiene))) (if (if (not (equal? mod861 (module-name (current-module)))) (module-variable (resolve-module mod861) var857) #f) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (syntax-violation #f "bad module kind" var857 mod861))))))))) (build-lexical-assignment84 (lambda (source862 name863 var864 exp865) (let ((atom-key866 (fluid-ref *mode*71))) (if (memv atom-key866 (quote (c))) ((@ (language tree-il) make-lexical-set) source862 name863 var864 exp865) (list (quote set!) var864 exp865))))) (build-lexical-reference83 (lambda (type867 source868 name869 var870) (let ((atom-key871 (fluid-ref *mode*71))) (if (memv atom-key871 (quote (c))) ((@ (language tree-il) make-lexical-ref) source868 name869 var870) var870)))) (build-conditional82 (lambda (source872 test-exp873 then-exp874 else-exp875) (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) make-conditional) source872 test-exp873 then-exp874 else-exp875) (if (equal? else-exp875 (quote (if #f #f))) (list (quote if) test-exp873 then-exp874) (list (quote if) test-exp873 then-exp874 else-exp875)))))) (build-application81 (lambda (source877 fun-exp878 arg-exps879) (let ((atom-key880 (fluid-ref *mode*71))) (if (memv atom-key880 (quote (c))) ((@ (language tree-il) make-application) source877 fun-exp878 arg-exps879) (cons fun-exp878 arg-exps879))))) (build-void80 (lambda (source881) (let ((atom-key882 (fluid-ref *mode*71))) (if (memv atom-key882 (quote (c))) ((@ (language tree-il) make-void) source881) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol883 module884) (begin (if (if (not module884) (current-module) #f) (warn "module system is booted, we should have a module" symbol883)) (let ((v885 (module-variable (if module884 (resolve-module (cdr module884)) (current-module)) symbol883))) (if v885 (if (variable-bound? v885) (let ((val886 (variable-ref v885))) (if (macro? val886) (if (syncase-macro-type val886) (cons (syncase-macro-type val886) (syncase-macro-binding val886)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol887 type888 val889) (let ((existing890 (let ((v891 (module-variable (current-module) symbol887))) (if v891 (if (variable-bound? v891) (let ((val892 (variable-ref v891))) (if (macro? val892) (if (not (syncase-macro-type val892)) val892 #f) #f)) #f) #f)))) (module-define! (current-module) symbol887 (if existing890 (make-extended-syncase-macro existing890 type888 val889) (make-syncase-macro type888 val889)))))) (local-eval-hook77 (lambda (x893 mod894) (primitive-eval (list noexpand70 (let ((atom-key895 (fluid-ref *mode*71))) (if (memv atom-key895 (quote (c))) ((@ (language tree-il) tree-il->scheme) x893) x893)))))) (top-level-eval-hook76 (lambda (x896 mod897) (primitive-eval (list noexpand70 (let ((atom-key898 (fluid-ref *mode*71))) (if (memv atom-key898 (quote (c))) ((@ (language tree-il) tree-il->scheme) x896) x896)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend111 (quote local-syntax) (quote letrec-syntax) #t) (global-extend111 (quote local-syntax) (quote let-syntax) #f) (global-extend111 (quote core) (quote fluid-let-syntax) (lambda (e899 r900 w901 s902 mod903) ((lambda (tmp904) ((lambda (tmp905) (if (if tmp905 (apply (lambda (_906 var907 val908 e1909 e2910) (valid-bound-ids?138 var907)) tmp905) #f) (apply (lambda (_912 var913 val914 e1915 e2916) (let ((names917 (map (lambda (x918) (id-var-name135 x918 w901)) var913))) (begin (for-each (lambda (id920 n921) (let ((atom-key922 (binding-type105 (lookup110 n921 r900 mod903)))) (if (memv atom-key922 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e899 (source-wrap142 id920 w901 s902 mod903))))) var913 names917) (chi-body153 (cons e1915 e2916) (source-wrap142 e899 w901 s902 mod903) (extend-env107 names917 (let ((trans-r925 (macros-only-env109 r900))) (map (lambda (x926) (cons (quote macro) (eval-local-transformer156 (chi149 x926 trans-r925 w901 mod903) mod903))) val914)) r900) w901 mod903)))) tmp905) ((lambda (_928) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap142 e899 w901 s902 mod903))) tmp904))) ($sc-dispatch tmp904 (quote (any #(each (any any)) any . each-any))))) e899))) (global-extend111 (quote core) (quote quote) (lambda (e929 r930 w931 s932 mod933) ((lambda (tmp934) ((lambda (tmp935) (if tmp935 (apply (lambda (_936 e937) (build-data91 s932 (strip160 e937 w931))) tmp935) ((lambda (_938) (syntax-violation (quote quote) "bad syntax" (source-wrap142 e929 w931 s932 mod933))) tmp934))) ($sc-dispatch tmp934 (quote (any any))))) e929))) (global-extend111 (quote core) (quote syntax) (letrec ((regen946 (lambda (x947) (let ((atom-key948 (car x947))) (if (memv atom-key948 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x947) (cadr x947)) (if (memv atom-key948 (quote (primitive))) (build-primref90 #f (cadr x947)) (if (memv atom-key948 (quote (quote))) (build-data91 #f (cadr x947)) (if (memv atom-key948 (quote (lambda))) (build-lambda89 #f (cadr x947) (cadr x947) #f (regen946 (caddr x947))) (if (memv atom-key948 (quote (map))) (let ((ls949 (map regen946 (cdr x947)))) (build-application81 #f (build-primref90 #f (quote map)) ls949)) (build-application81 #f (build-primref90 #f (car x947)) (map regen946 (cdr x947))))))))))) (gen-vector945 (lambda (x950) (if (eq? (car x950) (quote list)) (cons (quote vector) (cdr x950)) (if (eq? (car x950) (quote quote)) (list (quote quote) (list->vector (cadr x950))) (list (quote list->vector) x950))))) (gen-append944 (lambda (x951 y952) (if (equal? y952 (quote (quote ()))) x951 (list (quote append) x951 y952)))) (gen-cons943 (lambda (x953 y954) (let ((atom-key955 (car y954))) (if (memv atom-key955 (quote (quote))) (if (eq? (car x953) (quote quote)) (list (quote quote) (cons (cadr x953) (cadr y954))) (if (eq? (cadr y954) (quote ())) (list (quote list) x953) (list (quote cons) x953 y954))) (if (memv atom-key955 (quote (list))) (cons (quote list) (cons x953 (cdr y954))) (list (quote cons) x953 y954)))))) (gen-map942 (lambda (e956 map-env957) (let ((formals958 (map cdr map-env957)) (actuals959 (map (lambda (x960) (list (quote ref) (car x960))) map-env957))) (if (eq? (car e956) (quote ref)) (car actuals959) (if (and-map (lambda (x961) (if (eq? (car x961) (quote ref)) (memq (cadr x961) formals958) #f)) (cdr e956)) (cons (quote map) (cons (list (quote primitive) (car e956)) (map (let ((r962 (map cons formals958 actuals959))) (lambda (x963) (cdr (assq (cadr x963) r962)))) (cdr e956)))) (cons (quote map) (cons (list (quote lambda) formals958 e956) actuals959))))))) (gen-mappend941 (lambda (e964 map-env965) (list (quote apply) (quote (primitive append)) (gen-map942 e964 map-env965)))) (gen-ref940 (lambda (src966 var967 level968 maps969) (if (fx=74 level968 0) (values var967 maps969) (if (null? maps969) (syntax-violation (quote syntax) "missing ellipsis" src966) (call-with-values (lambda () (gen-ref940 src966 var967 (fx-73 level968 1) (cdr maps969))) (lambda (outer-var970 outer-maps971) (let ((b972 (assq outer-var970 (car maps969)))) (if b972 (values (cdr b972) maps969) (let ((inner-var973 (gen-var161 (quote tmp)))) (values inner-var973 (cons (cons (cons outer-var970 inner-var973) (car maps969)) outer-maps971))))))))))) (gen-syntax939 (lambda (src974 e975 r976 maps977 ellipsis?978 mod979) (if (id?113 e975) (let ((label980 (id-var-name135 e975 (quote (()))))) (let ((b981 (lookup110 label980 r976 mod979))) (if (eq? (binding-type105 b981) (quote syntax)) (call-with-values (lambda () (let ((var.lev982 (binding-value106 b981))) (gen-ref940 src974 (car var.lev982) (cdr var.lev982) maps977))) (lambda (var983 maps984) (values (list (quote ref) var983) maps984))) (if (ellipsis?978 e975) (syntax-violation (quote syntax) "misplaced ellipsis" src974) (values (list (quote quote) e975) maps977))))) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 e988) (ellipsis?978 dots987)) tmp986) #f) (apply (lambda (dots989 e990) (gen-syntax939 src974 e990 r976 maps977 (lambda (x991) #f) mod979)) tmp986) ((lambda (tmp992) (if (if tmp992 (apply (lambda (x993 dots994 y995) (ellipsis?978 dots994)) tmp992) #f) (apply (lambda (x996 dots997 y998) (letrec ((f999 (lambda (y1000 k1001) ((lambda (tmp1005) ((lambda (tmp1006) (if (if tmp1006 (apply (lambda (dots1007 y1008) (ellipsis?978 dots1007)) tmp1006) #f) (apply (lambda (dots1009 y1010) (f999 y1010 (lambda (maps1011) (call-with-values (lambda () (k1001 (cons (quote ()) maps1011))) (lambda (x1012 maps1013) (if (null? (car maps1013)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-mappend941 x1012 (car maps1013)) (cdr maps1013)))))))) tmp1006) ((lambda (_1014) (call-with-values (lambda () (gen-syntax939 src974 y1000 r976 maps977 ellipsis?978 mod979)) (lambda (y1015 maps1016) (call-with-values (lambda () (k1001 maps1016)) (lambda (x1017 maps1018) (values (gen-append944 x1017 y1015) maps1018)))))) tmp1005))) ($sc-dispatch tmp1005 (quote (any . any))))) y1000)))) (f999 y998 (lambda (maps1002) (call-with-values (lambda () (gen-syntax939 src974 x996 r976 (cons (quote ()) maps1002) ellipsis?978 mod979)) (lambda (x1003 maps1004) (if (null? (car maps1004)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-map942 x1003 (car maps1004)) (cdr maps1004))))))))) tmp992) ((lambda (tmp1019) (if tmp1019 (apply (lambda (x1020 y1021) (call-with-values (lambda () (gen-syntax939 src974 x1020 r976 maps977 ellipsis?978 mod979)) (lambda (x1022 maps1023) (call-with-values (lambda () (gen-syntax939 src974 y1021 r976 maps1023 ellipsis?978 mod979)) (lambda (y1024 maps1025) (values (gen-cons943 x1022 y1024) maps1025)))))) tmp1019) ((lambda (tmp1026) (if tmp1026 (apply (lambda (e11027 e21028) (call-with-values (lambda () (gen-syntax939 src974 (cons e11027 e21028) r976 maps977 ellipsis?978 mod979)) (lambda (e1030 maps1031) (values (gen-vector945 e1030) maps1031)))) tmp1026) ((lambda (_1032) (values (list (quote quote) e975) maps977)) tmp985))) ($sc-dispatch tmp985 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp985 (quote (any . any)))))) ($sc-dispatch tmp985 (quote (any any . any)))))) ($sc-dispatch tmp985 (quote (any any))))) e975))))) (lambda (e1033 r1034 w1035 s1036 mod1037) (let ((e1038 (source-wrap142 e1033 w1035 s1036 mod1037))) ((lambda (tmp1039) ((lambda (tmp1040) (if tmp1040 (apply (lambda (_1041 x1042) (call-with-values (lambda () (gen-syntax939 e1038 x1042 r1034 (quote ()) ellipsis?158 mod1037)) (lambda (e1043 maps1044) (regen946 e1043)))) tmp1040) ((lambda (_1045) (syntax-violation (quote syntax) "bad `syntax' form" e1038)) tmp1039))) ($sc-dispatch tmp1039 (quote (any any))))) e1038))))) (global-extend111 (quote core) (quote lambda) (lambda (e1046 r1047 w1048 s1049 mod1050) ((lambda (tmp1051) ((lambda (tmp1052) (if tmp1052 (apply (lambda (_1053 c1054) (chi-lambda-clause154 (source-wrap142 e1046 w1048 s1049 mod1050) #f c1054 r1047 w1048 mod1050 (lambda (names1055 vars1056 docstring1057 body1058) (build-lambda89 s1049 names1055 vars1056 docstring1057 body1058)))) tmp1052) (syntax-violation #f "source expression failed to match any pattern" tmp1051))) ($sc-dispatch tmp1051 (quote (any . any))))) e1046))) (global-extend111 (quote core) (quote let) (letrec ((chi-let1059 (lambda (e1060 r1061 w1062 s1063 mod1064 constructor1065 ids1066 vals1067 exps1068) (if (not (valid-bound-ids?138 ids1066)) (syntax-violation (quote let) "duplicate bound variable" e1060) (let ((labels1069 (gen-labels119 ids1066)) (new-vars1070 (map gen-var161 ids1066))) (let ((nw1071 (make-binding-wrap130 ids1066 labels1069 w1062)) (nr1072 (extend-var-env108 labels1069 new-vars1070 r1061))) (constructor1065 s1063 (map syntax->datum ids1066) new-vars1070 (map (lambda (x1073) (chi149 x1073 r1061 w1062 mod1064)) vals1067) (chi-body153 exps1068 (source-wrap142 e1060 nw1071 s1063 mod1064) nr1072 nw1071 mod1064)))))))) (lambda (e1074 r1075 w1076 s1077 mod1078) ((lambda (tmp1079) ((lambda (tmp1080) (if tmp1080 (apply (lambda (_1081 id1082 val1083 e11084 e21085) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-let93 id1082 val1083 (cons e11084 e21085))) tmp1080) ((lambda (tmp1089) (if (if tmp1089 (apply (lambda (_1090 f1091 id1092 val1093 e11094 e21095) (id?113 f1091)) tmp1089) #f) (apply (lambda (_1096 f1097 id1098 val1099 e11100 e21101) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-named-let94 (cons f1097 id1098) val1099 (cons e11100 e21101))) tmp1089) ((lambda (_1105) (syntax-violation (quote let) "bad let" (source-wrap142 e1074 w1076 s1077 mod1078))) tmp1079))) ($sc-dispatch tmp1079 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1079 (quote (any #(each (any any)) any . each-any))))) e1074)))) (global-extend111 (quote core) (quote letrec) (lambda (e1106 r1107 w1108 s1109 mod1110) ((lambda (tmp1111) ((lambda (tmp1112) (if tmp1112 (apply (lambda (_1113 id1114 val1115 e11116 e21117) (let ((ids1118 id1114)) (if (not (valid-bound-ids?138 ids1118)) (syntax-violation (quote letrec) "duplicate bound variable" e1106) (let ((labels1120 (gen-labels119 ids1118)) (new-vars1121 (map gen-var161 ids1118))) (let ((w1122 (make-binding-wrap130 ids1118 labels1120 w1108)) (r1123 (extend-var-env108 labels1120 new-vars1121 r1107))) (build-letrec95 s1109 (map syntax->datum ids1118) new-vars1121 (map (lambda (x1124) (chi149 x1124 r1123 w1122 mod1110)) val1115) (chi-body153 (cons e11116 e21117) (source-wrap142 e1106 w1122 s1109 mod1110) r1123 w1122 mod1110))))))) tmp1112) ((lambda (_1127) (syntax-violation (quote letrec) "bad letrec" (source-wrap142 e1106 w1108 s1109 mod1110))) tmp1111))) ($sc-dispatch tmp1111 (quote (any #(each (any any)) any . each-any))))) e1106))) (global-extend111 (quote core) (quote set!) (lambda (e1128 r1129 w1130 s1131 mod1132) ((lambda (tmp1133) ((lambda (tmp1134) (if (if tmp1134 (apply (lambda (_1135 id1136 val1137) (id?113 id1136)) tmp1134) #f) (apply (lambda (_1138 id1139 val1140) (let ((val1141 (chi149 val1140 r1129 w1130 mod1132)) (n1142 (id-var-name135 id1139 w1130))) (let ((b1143 (lookup110 n1142 r1129 mod1132))) (let ((atom-key1144 (binding-type105 b1143))) (if (memv atom-key1144 (quote (lexical))) (build-lexical-assignment84 s1131 (syntax->datum id1139) (binding-value106 b1143) val1141) (if (memv atom-key1144 (quote (global))) (build-global-assignment87 s1131 n1142 val1141 mod1132) (if (memv atom-key1144 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap141 id1139 w1130 mod1132)) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))))))))) tmp1134) ((lambda (tmp1145) (if tmp1145 (apply (lambda (_1146 head1147 tail1148 val1149) (call-with-values (lambda () (syntax-type147 head1147 r1129 (quote (())) #f #f mod1132)) (lambda (type1150 value1151 ee1152 ww1153 ss1154 modmod1155) (if (memv type1150 (quote (module-ref))) (let ((val1156 (chi149 val1149 r1129 w1130 mod1132))) (call-with-values (lambda () (value1151 (cons head1147 tail1148))) (lambda (id1158 mod1159) (build-global-assignment87 s1131 id1158 val1156 mod1159)))) (build-application81 s1131 (chi149 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1147) r1129 w1130 mod1132) (map (lambda (e1160) (chi149 e1160 r1129 w1130 mod1132)) (append tail1148 (list val1149)))))))) tmp1145) ((lambda (_1162) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))) tmp1133))) ($sc-dispatch tmp1133 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1133 (quote (any any any))))) e1128))) (global-extend111 (quote module-ref) (quote @) (lambda (e1163) ((lambda (tmp1164) ((lambda (tmp1165) (if (if tmp1165 (apply (lambda (_1166 mod1167 id1168) (if (and-map id?113 mod1167) (id?113 id1168) #f)) tmp1165) #f) (apply (lambda (_1170 mod1171 id1172) (values (syntax->datum id1172) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1171)))) tmp1165) (syntax-violation #f "source expression failed to match any pattern" tmp1164))) ($sc-dispatch tmp1164 (quote (any each-any any))))) e1163))) (global-extend111 (quote module-ref) (quote @@) (lambda (e1174) ((lambda (tmp1175) ((lambda (tmp1176) (if (if tmp1176 (apply (lambda (_1177 mod1178 id1179) (if (and-map id?113 mod1178) (id?113 id1179) #f)) tmp1176) #f) (apply (lambda (_1181 mod1182 id1183) (values (syntax->datum id1183) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1182)))) tmp1176) (syntax-violation #f "source expression failed to match any pattern" tmp1175))) ($sc-dispatch tmp1175 (quote (any each-any any))))) e1174))) (global-extend111 (quote core) (quote if) (lambda (e1185 r1186 w1187 s1188 mod1189) ((lambda (tmp1190) ((lambda (tmp1191) (if tmp1191 (apply (lambda (_1192 test1193 then1194) (build-conditional82 s1188 (chi149 test1193 r1186 w1187 mod1189) (chi149 then1194 r1186 w1187 mod1189) (build-void80 #f))) tmp1191) ((lambda (tmp1195) (if tmp1195 (apply (lambda (_1196 test1197 then1198 else1199) (build-conditional82 s1188 (chi149 test1197 r1186 w1187 mod1189) (chi149 then1198 r1186 w1187 mod1189) (chi149 else1199 r1186 w1187 mod1189))) tmp1195) (syntax-violation #f "source expression failed to match any pattern" tmp1190))) ($sc-dispatch tmp1190 (quote (any any any any)))))) ($sc-dispatch tmp1190 (quote (any any any))))) e1185))) (global-extend111 (quote begin) (quote begin) (quote ())) (global-extend111 (quote define) (quote define) (quote ())) (global-extend111 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend111 (quote eval-when) (quote eval-when) (quote ())) (global-extend111 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1203 (lambda (x1204 keys1205 clauses1206 r1207 mod1208) (if (null? clauses1206) (build-application81 #f (build-primref90 #f (quote syntax-violation)) (list (build-data91 #f #f) (build-data91 #f "source expression failed to match any pattern") x1204)) ((lambda (tmp1209) ((lambda (tmp1210) (if tmp1210 (apply (lambda (pat1211 exp1212) (if (if (id?113 pat1211) (and-map (lambda (x1213) (not (free-id=?136 pat1211 x1213))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1205)) #f) (let ((labels1214 (list (gen-label118))) (var1215 (gen-var161 pat1211))) (build-application81 #f (build-lambda89 #f (list (syntax->datum pat1211)) (list var1215) #f (chi149 exp1212 (extend-env107 labels1214 (list (cons (quote syntax) (cons var1215 0))) r1207) (make-binding-wrap130 (list pat1211) labels1214 (quote (()))) mod1208)) (list x1204))) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1211 #t exp1212 mod1208))) tmp1210) ((lambda (tmp1216) (if tmp1216 (apply (lambda (pat1217 fender1218 exp1219) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1217 fender1218 exp1219 mod1208)) tmp1216) ((lambda (_1220) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1206))) tmp1209))) ($sc-dispatch tmp1209 (quote (any any any)))))) ($sc-dispatch tmp1209 (quote (any any))))) (car clauses1206))))) (gen-clause1202 (lambda (x1221 keys1222 clauses1223 r1224 pat1225 fender1226 exp1227 mod1228) (call-with-values (lambda () (convert-pattern1200 pat1225 keys1222)) (lambda (p1229 pvars1230) (if (not (distinct-bound-ids?139 (map car pvars1230))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1225) (if (not (and-map (lambda (x1231) (not (ellipsis?158 (car x1231)))) pvars1230)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1225) (let ((y1232 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda89 #f (list (quote tmp)) (list y1232) #f (let ((y1233 (build-lexical-reference83 (quote value) #f (quote tmp) y1232))) (build-conditional82 #f ((lambda (tmp1234) ((lambda (tmp1235) (if tmp1235 (apply (lambda () y1233) tmp1235) ((lambda (_1236) (build-conditional82 #f y1233 (build-dispatch-call1201 pvars1230 fender1226 y1233 r1224 mod1228) (build-data91 #f #f))) tmp1234))) ($sc-dispatch tmp1234 (quote #(atom #t))))) fender1226) (build-dispatch-call1201 pvars1230 exp1227 y1233 r1224 mod1228) (gen-syntax-case1203 x1221 keys1222 clauses1223 r1224 mod1228)))) (list (if (eq? p1229 (quote any)) (build-application81 #f (build-primref90 #f (quote list)) (list x1221)) (build-application81 #f (build-primref90 #f (quote $sc-dispatch)) (list x1221 (build-data91 #f p1229))))))))))))) (build-dispatch-call1201 (lambda (pvars1237 exp1238 y1239 r1240 mod1241) (let ((ids1242 (map car pvars1237)) (levels1243 (map cdr pvars1237))) (let ((labels1244 (gen-labels119 ids1242)) (new-vars1245 (map gen-var161 ids1242))) (build-application81 #f (build-primref90 #f (quote apply)) (list (build-lambda89 #f (map syntax->datum ids1242) new-vars1245 #f (chi149 exp1238 (extend-env107 labels1244 (map (lambda (var1246 level1247) (cons (quote syntax) (cons var1246 level1247))) new-vars1245 (map cdr pvars1237)) r1240) (make-binding-wrap130 ids1242 labels1244 (quote (()))) mod1241)) y1239)))))) (convert-pattern1200 (lambda (pattern1248 keys1249) (letrec ((cvt1250 (lambda (p1251 n1252 ids1253) (if (id?113 p1251) (if (bound-id-member?140 p1251 keys1249) (values (vector (quote free-id) p1251) ids1253) (values (quote any) (cons (cons p1251 n1252) ids1253))) ((lambda (tmp1254) ((lambda (tmp1255) (if (if tmp1255 (apply (lambda (x1256 dots1257) (ellipsis?158 dots1257)) tmp1255) #f) (apply (lambda (x1258 dots1259) (call-with-values (lambda () (cvt1250 x1258 (fx+72 n1252 1) ids1253)) (lambda (p1260 ids1261) (values (if (eq? p1260 (quote any)) (quote each-any) (vector (quote each) p1260)) ids1261)))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda (x1263 y1264) (call-with-values (lambda () (cvt1250 y1264 n1252 ids1253)) (lambda (y1265 ids1266) (call-with-values (lambda () (cvt1250 x1263 n1252 ids1266)) (lambda (x1267 ids1268) (values (cons x1267 y1265) ids1268)))))) tmp1262) ((lambda (tmp1269) (if tmp1269 (apply (lambda () (values (quote ()) ids1253)) tmp1269) ((lambda (tmp1270) (if tmp1270 (apply (lambda (x1271) (call-with-values (lambda () (cvt1250 x1271 n1252 ids1253)) (lambda (p1273 ids1274) (values (vector (quote vector) p1273) ids1274)))) tmp1270) ((lambda (x1275) (values (vector (quote atom) (strip160 p1251 (quote (())))) ids1253)) tmp1254))) ($sc-dispatch tmp1254 (quote #(vector each-any)))))) ($sc-dispatch tmp1254 (quote ()))))) ($sc-dispatch tmp1254 (quote (any . any)))))) ($sc-dispatch tmp1254 (quote (any any))))) p1251))))) (cvt1250 pattern1248 0 (quote ())))))) (lambda (e1276 r1277 w1278 s1279 mod1280) (let ((e1281 (source-wrap142 e1276 w1278 s1279 mod1280))) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (_1284 val1285 key1286 m1287) (if (and-map (lambda (x1288) (if (id?113 x1288) (not (ellipsis?158 x1288)) #f)) key1286) (let ((x1290 (gen-var161 (quote tmp)))) (build-application81 s1279 (build-lambda89 #f (list (quote tmp)) (list x1290) #f (gen-syntax-case1203 (build-lexical-reference83 (quote value) #f (quote tmp) x1290) key1286 m1287 r1277 mod1280)) (list (chi149 val1285 r1277 (quote (())) mod1280)))) (syntax-violation (quote syntax-case) "invalid literals list" e1281))) tmp1283) (syntax-violation #f "source expression failed to match any pattern" tmp1282))) ($sc-dispatch tmp1282 (quote (any any each-any . each-any))))) e1281))))) (set! sc-expand (lambda (x1294 . rest1293) (if (if (pair? x1294) (equal? (car x1294) noexpand70) #f) (cadr x1294) (let ((m1295 (if (null? rest1293) (quote e) (car rest1293))) (esew1296 (if (let ((t1297 (null? rest1293))) (if t1297 t1297 (null? (cdr rest1293)))) (quote (eval)) (cadr rest1293)))) (with-fluid* *mode*71 m1295 (lambda () (chi-top148 x1294 (quote ()) (quote ((top))) m1295 esew1296 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1298) (nonsymbol-id?112 x1298))) (set! datum->syntax (lambda (id1299 datum1300) (make-syntax-object96 datum1300 (syntax-object-wrap99 id1299) #f))) (set! syntax->datum (lambda (x1301) (strip160 x1301 (quote (()))))) (set! generate-temporaries (lambda (ls1302) (begin (let ((x1303 ls1302)) (if (not (list? x1303)) (syntax-violation (quote generate-temporaries) "invalid argument" x1303))) (map (lambda (x1304) (wrap141 (gensym) (quote ((top))) #f)) ls1302)))) (set! free-identifier=? (lambda (x1305 y1306) (begin (let ((x1307 x1305)) (if (not (nonsymbol-id?112 x1307)) (syntax-violation (quote free-identifier=?) "invalid argument" x1307))) (let ((x1308 y1306)) (if (not (nonsymbol-id?112 x1308)) (syntax-violation (quote free-identifier=?) "invalid argument" x1308))) (free-id=?136 x1305 y1306)))) (set! bound-identifier=? (lambda (x1309 y1310) (begin (let ((x1311 x1309)) (if (not (nonsymbol-id?112 x1311)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1311))) (let ((x1312 y1310)) (if (not (nonsymbol-id?112 x1312)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1312))) (bound-id=?137 x1309 y1310)))) (set! syntax-violation (lambda (who1316 message1315 form1314 . subform1313) (begin (let ((x1317 who1316)) (if (not ((lambda (x1318) (let ((t1319 (not x1318))) (if t1319 t1319 (let ((t1320 (string? x1318))) (if t1320 t1320 (symbol? x1318)))))) x1317)) (syntax-violation (quote syntax-violation) "invalid argument" x1317))) (let ((x1321 message1315)) (if (not (string? x1321)) (syntax-violation (quote syntax-violation) "invalid argument" x1321))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1316 "~a: " "") "~a " (if (null? subform1313) "in ~a" "in subform `~s' of `~s'")) (let ((tail1322 (cons message1315 (map (lambda (x1323) (strip160 x1323 (quote (())))) (append subform1313 (list form1314)))))) (if who1316 (cons who1316 tail1322) tail1322)) #f)))) (letrec ((match1328 (lambda (e1329 p1330 w1331 r1332 mod1333) (if (not r1332) #f (if (eq? p1330 (quote any)) (cons (wrap141 e1329 w1331 mod1333) r1332) (if (syntax-object?97 e1329) (match*1327 (let ((e1334 (syntax-object-expression98 e1329))) (if (annotation? e1334) (annotation-expression e1334) e1334)) p1330 (join-wraps132 w1331 (syntax-object-wrap99 e1329)) r1332 (syntax-object-module100 e1329)) (match*1327 (let ((e1335 e1329)) (if (annotation? e1335) (annotation-expression e1335) e1335)) p1330 w1331 r1332 mod1333)))))) (match*1327 (lambda (e1336 p1337 w1338 r1339 mod1340) (if (null? p1337) (if (null? e1336) r1339 #f) (if (pair? p1337) (if (pair? e1336) (match1328 (car e1336) (car p1337) w1338 (match1328 (cdr e1336) (cdr p1337) w1338 r1339 mod1340) mod1340) #f) (if (eq? p1337 (quote each-any)) (let ((l1341 (match-each-any1325 e1336 w1338 mod1340))) (if l1341 (cons l1341 r1339) #f)) (let ((atom-key1342 (vector-ref p1337 0))) (if (memv atom-key1342 (quote (each))) (if (null? e1336) (match-empty1326 (vector-ref p1337 1) r1339) (let ((l1343 (match-each1324 e1336 (vector-ref p1337 1) w1338 mod1340))) (if l1343 (letrec ((collect1344 (lambda (l1345) (if (null? (car l1345)) r1339 (cons (map car l1345) (collect1344 (map cdr l1345))))))) (collect1344 l1343)) #f))) (if (memv atom-key1342 (quote (free-id))) (if (id?113 e1336) (if (free-id=?136 (wrap141 e1336 w1338 mod1340) (vector-ref p1337 1)) r1339 #f) #f) (if (memv atom-key1342 (quote (atom))) (if (equal? (vector-ref p1337 1) (strip160 e1336 w1338)) r1339 #f) (if (memv atom-key1342 (quote (vector))) (if (vector? e1336) (match1328 (vector->list e1336) (vector-ref p1337 1) w1338 r1339 mod1340) #f))))))))))) (match-empty1326 (lambda (p1346 r1347) (if (null? p1346) r1347 (if (eq? p1346 (quote any)) (cons (quote ()) r1347) (if (pair? p1346) (match-empty1326 (car p1346) (match-empty1326 (cdr p1346) r1347)) (if (eq? p1346 (quote each-any)) (cons (quote ()) r1347) (let ((atom-key1348 (vector-ref p1346 0))) (if (memv atom-key1348 (quote (each))) (match-empty1326 (vector-ref p1346 1) r1347) (if (memv atom-key1348 (quote (free-id atom))) r1347 (if (memv atom-key1348 (quote (vector))) (match-empty1326 (vector-ref p1346 1) r1347))))))))))) (match-each-any1325 (lambda (e1349 w1350 mod1351) (if (annotation? e1349) (match-each-any1325 (annotation-expression e1349) w1350 mod1351) (if (pair? e1349) (let ((l1352 (match-each-any1325 (cdr e1349) w1350 mod1351))) (if l1352 (cons (wrap141 (car e1349) w1350 mod1351) l1352) #f)) (if (null? e1349) (quote ()) (if (syntax-object?97 e1349) (match-each-any1325 (syntax-object-expression98 e1349) (join-wraps132 w1350 (syntax-object-wrap99 e1349)) mod1351) #f)))))) (match-each1324 (lambda (e1353 p1354 w1355 mod1356) (if (annotation? e1353) (match-each1324 (annotation-expression e1353) p1354 w1355 mod1356) (if (pair? e1353) (let ((first1357 (match1328 (car e1353) p1354 w1355 (quote ()) mod1356))) (if first1357 (let ((rest1358 (match-each1324 (cdr e1353) p1354 w1355 mod1356))) (if rest1358 (cons first1357 rest1358) #f)) #f)) (if (null? e1353) (quote ()) (if (syntax-object?97 e1353) (match-each1324 (syntax-object-expression98 e1353) p1354 (join-wraps132 w1355 (syntax-object-wrap99 e1353)) (syntax-object-module100 e1353)) #f))))))) (set! $sc-dispatch (lambda (e1359 p1360) (if (eq? p1360 (quote any)) (list e1359) (if (syntax-object?97 e1359) (match*1327 (let ((e1361 (syntax-object-expression98 e1359))) (if (annotation? e1361) (annotation-expression e1361) e1361)) p1360 (syntax-object-wrap99 e1359) (quote ()) (syntax-object-module100 e1359)) (match*1327 (let ((e1362 e1359)) (if (annotation? e1362) (annotation-expression e1362) e1362)) p1360 (quote (())) (quote ()) #f))))))))) (define with-syntax (make-syncase-macro (quote macro) (lambda (x1363) ((lambda (tmp1364) ((lambda (tmp1365) (if tmp1365 (apply (lambda (_1366 e11367 e21368) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11367 e21368))) tmp1365) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 out1372 in1373 e11374 e21375) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1373 (quote ()) (list out1372 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11374 e21375))))) tmp1370) ((lambda (tmp1377) (if tmp1377 (apply (lambda (_1378 out1379 in1380 e11381 e21382) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1380) (quote ()) (list out1379 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11381 e21382))))) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1364))) ($sc-dispatch tmp1364 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1364 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1364 (quote (any () any . each-any))))) x1363)))) (define syntax-rules (make-syncase-macro (quote macro) (lambda (x1386) ((lambda (tmp1387) ((lambda (tmp1388) (if tmp1388 (apply (lambda (_1389 k1390 keyword1391 pattern1392 template1393) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1390 (map (lambda (tmp1396 tmp1395) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1395) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1396))) template1393 pattern1392)))))) tmp1388) (syntax-violation #f "source expression failed to match any pattern" tmp1387))) ($sc-dispatch tmp1387 (quote (any each-any . #(each ((any . any) any))))))) x1386)))) (define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1397) ((lambda (tmp1398) ((lambda (tmp1399) (if (if tmp1399 (apply (lambda (let*1400 x1401 v1402 e11403 e21404) (and-map identifier? x1401)) tmp1399) #f) (apply (lambda (let*1406 x1407 v1408 e11409 e21410) (letrec ((f1411 (lambda (bindings1412) (if (null? bindings1412) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11409 e21410))) ((lambda (tmp1416) ((lambda (tmp1417) (if tmp1417 (apply (lambda (body1418 binding1419) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1419) body1418)) tmp1417) (syntax-violation #f "source expression failed to match any pattern" tmp1416))) ($sc-dispatch tmp1416 (quote (any any))))) (list (f1411 (cdr bindings1412)) (car bindings1412))))))) (f1411 (map list x1407 v1408)))) tmp1399) (syntax-violation #f "source expression failed to match any pattern" tmp1398))) ($sc-dispatch tmp1398 (quote (any #(each (any any)) any . each-any))))) x1397)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 0ce74a790..bbae73b3c 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -368,7 +368,9 @@ (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-conditional) source test-exp then-exp else-exp)) - (else `(if ,test-exp ,then-exp ,else-exp))))) + (else (if (equal? else-exp '(if #f #f)) + `(if ,test-exp ,then-exp) + `(if ,test-exp ,then-exp ,else-exp)))))) (define build-lexical-reference (lambda (type source name var) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index a89d8cfd6..a81947749 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -215,7 +215,9 @@ `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) (( test then else) - `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))) + (if (void? else) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) (( name) name) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 9176a3c4e..69c8fbf46 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -22,7 +22,7 @@ (define exception:generic-syncase-error - (cons 'syntax-error "Source expression failed to match")) + (cons 'syntax-error "source expression failed to match")) (define exception:unexpected-syntax (cons 'syntax-error "unexpected syntax")) @@ -111,8 +111,9 @@ (with-test-prefix "unquote-splicing" (pass-if-exception "extra arguments" - exception:missing/extra-expr - (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) + '(syntax-error . "unquote-splicing takes exactly one argument") + (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) + (interaction-environment))))) (with-test-prefix "begin" @@ -121,17 +122,21 @@ (with-test-prefix "unmemoization" + ;; FIXME. I have no idea why, but the expander is filling in (if #f + ;; #f) as the second arm of the if, if the second arm is missing. I + ;; thought I made it not do that. But in the meantime, let's adapt, + ;; since that's not what we're testing. + (pass-if "normal begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))) - (foo) ; make sure, memoization has been performed + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))) (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))) (pass-if "redundant nested begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))) + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))) (pass-if "redundant begin at start of body" (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized @@ -139,25 +144,34 @@ (equal? (procedure-source foo) '(lambda () (begin (+ 1) (+ 2))))))) - (expect-fail-exception "illegal (begin)" - exception:bad-body + (pass-if-exception "illegal (begin)" + exception:generic-syncase-error (eval '(begin (if #t (begin)) #t) (interaction-environment)))) +(define-syntax matches? + (syntax-rules (_) + ((_ (op arg ...) pat) (let ((x (op arg ...))) + (matches? x pat))) + ((_ x ()) (null? x)) + ((_ x (a . b)) (and (pair? x) + (matches? (car x) a) + (matches? (cdr x) b))) + ((_ x _) #t) + ((_ x pat) (equal? x 'pat)))) + (with-test-prefix "lambda" (with-test-prefix "unmemoization" (pass-if "normal lambda" (let ((foo (lambda () (lambda (x y) (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) (+ _ _)))))) (pass-if "lambda with documentation" (let ((foo (lambda () (lambda (x y) "docstring" (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) "docstring" (+ x y))))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) "docstring" (+ _ _))))))) (with-test-prefix "bad formals" From dc1eed52f71004bca74028d03ae35bbf569be709 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 12:08:50 +0200 Subject: [PATCH 145/375] residualize names into procedures. re-implement srfi-61. module naming foo. * module/ice-9/boot-9.scm (cond): Implement srfi-61; most of the code is from the SRFI itself. Yuk. (%print-module, make-modules-in, %app, (%app modules)) (module-name): Syncase needs to get at the names of modules, even at anonymous modules. So lazily assign gensyms as module names. Name %app as (%app), but since (%app modules) is at the top of the module hierarchy, name it (). * module/ice-9/psyntax.scm: When building tree-il, try to name lambdas in definitions and in lets. (let, letrec): Give more specific errors in a couple of cases. * module/ice-9/psyntax-pp.scm: Regenerated. * test-suite/tests/syntax.test: More work. Many exceptions have different messages than they used to, many more generic; we can roll this back to be faithful to the original strings, but it doesn't seem necessary to me. --- module/ice-9/boot-9.scm | 85 +++++++------ module/ice-9/psyntax-pp.scm | 22 ++-- module/ice-9/psyntax.scm | 41 +++++-- test-suite/tests/syntax.test | 224 ++++++++++++++++++----------------- 4 files changed, 208 insertions(+), 164 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 6666f80b4..fa05de6d1 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -222,31 +222,44 @@ ((_ x) x) ((_ x y ...) (let ((t x)) (if t t (or y ...)))))) +;; The "maybe-more" bits are something of a hack, so that we can support +;; SRFI-61. Rewrites into a standalone syntax-case macro would be +;; appreciated. (define-syntax cond - (syntax-rules (else =>) - ((cond (else result1 result2 ...)) - (begin result1 result2 ...)) - ((cond (test => result)) - (let ((temp test)) - (if temp (result temp)))) - ((cond (test => result) clause1 clause2 ...) - (let ((temp test)) - (if temp - (result temp) - (cond clause1 clause2 ...)))) - ((cond (test)) test) - ((cond (test) clause1 clause2 ...) - (let ((temp test)) - (if temp - temp - (cond clause1 clause2 ...)))) - ((cond (test result1 result2 ...)) - (if test (begin result1 result2 ...))) - ((cond (test result1 result2 ...) - clause1 clause2 ...) - (if test - (begin result1 result2 ...) - (cond clause1 clause2 ...))))) + (syntax-rules (=> else) + ((_ "maybe-more" test consequent) + (if test consequent)) + + ((_ "maybe-more" test consequent clause ...) + (if test consequent (cond clause ...))) + + ((_ (else else1 else2 ...)) + (begin else1 else2 ...)) + + ((_ (test => receiver) more-clause ...) + (let ((t test)) + (cond "maybe-more" t (receiver t) more-clause ...))) + + ((_ (generator guard => receiver) more-clause ...) + (call-with-values (lambda () generator) + (lambda t + (cond "maybe-more" + (apply guard t) (apply receiver t) more-clause ...)))) + + ((_ (test => receiver ...) more-clause ...) + (syntax-violation 'cond "wrong number of receiver expressions" + '(test => receiver ...))) + ((_ (generator guard => receiver ...) more-clause ...) + (syntax-violation 'cond "wrong number of receiver expressions" + '(generator guard => receiver ...))) + + ((_ (test) more-clause ...) + (let ((t test)) + (cond "maybe-more" t t more-clause ...))) + + ((_ (test body1 body2 ...) more-clause ...) + (cond "maybe-more" + test (begin body1 body2 ...) more-clause ...)))) (define-syntax case (syntax-rules (else) @@ -1233,11 +1246,8 @@ (define (%print-module mod port) ; unused args: depth length style table) (display "#<" port) (display (or (module-kind mod) "module") port) - (let ((name (module-name mod))) - (if name - (begin - (display " " port) - (display name port)))) + (display " " port) + (display (module-name mod) port) (display " " port) (display (number->string (object-address mod) 16) port) (display ">" port)) @@ -1902,7 +1912,7 @@ val (let ((m (make-module 31))) (set-module-kind! m 'directory) - (set-module-name! m (append (or (module-name module) '()) + (set-module-name! m (append (module-name module) (list (car name)))) (module-define! module (car name) m) m))) @@ -1956,17 +1966,26 @@ (define default-duplicate-binding-procedures #f) (define %app (make-module 31)) +(set-module-name! %app '(%app)) (define app %app) ;; for backwards compatability -(local-define '(%app modules) (make-module 31)) +(let ((m (make-module 31))) + (set-module-name! m '()) + (local-define '(%app modules) m)) (local-define '(%app modules guile) the-root-module) ;; This boots the module system. All bindings needed by modules.c ;; must have been defined by now. ;; (set-current-module the-root-module) -;; definition deferred for syncase's benefit -(define module-name (record-accessor module-type 'name)) +;; definition deferred for syncase's benefit. +(define module-name + (let ((accessor (record-accessor module-type 'name))) + (lambda (mod) + (or (accessor mod) + (begin + (set-module-name! mod (list (gensym))) + (accessor mod)))))) ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0fcd15cca..b5347f240 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars291) (letrec ((lvl292 (lambda (vars293 ls294 w295) (if (pair? vars293) (lvl292 (cdr vars293) (cons (wrap141 (car vars293) w295 #f) ls294) w295) (if (id?113 vars293) (cons (wrap141 vars293 w295 #f) ls294) (if (null? vars293) ls294 (if (syntax-object?97 vars293) (lvl292 (syntax-object-expression98 vars293) ls294 (join-wraps132 w295 (syntax-object-wrap99 vars293))) (if (annotation? vars293) (lvl292 (annotation-expression vars293) ls294 w295) (cons vars293 ls294))))))))) (lvl292 vars291 (quote ()) (quote (())))))) (gen-var161 (lambda (id296) (let ((id297 (if (syntax-object?97 id296) (syntax-object-expression98 id296) id296))) (if (annotation? id297) (gensym (symbol->string (annotation-expression id297))) (gensym (symbol->string id297)))))) (strip160 (lambda (x298 w299) (if (memq (quote top) (wrap-marks116 w299)) (if (let ((t300 (annotation? x298))) (if t300 t300 (if (pair? x298) (annotation? (car x298)) #f))) (strip-annotation159 x298 #f) x298) (letrec ((f301 (lambda (x302) (if (syntax-object?97 x302) (strip160 (syntax-object-expression98 x302) (syntax-object-wrap99 x302)) (if (pair? x302) (let ((a303 (f301 (car x302))) (d304 (f301 (cdr x302)))) (if (if (eq? a303 (car x302)) (eq? d304 (cdr x302)) #f) x302 (cons a303 d304))) (if (vector? x302) (let ((old305 (vector->list x302))) (let ((new306 (map f301 old305))) (if (and-map*17 eq? old305 new306) x302 (list->vector new306)))) x302)))))) (f301 x298))))) (strip-annotation159 (lambda (x307 parent308) (if (pair? x307) (let ((new309 (cons #f #f))) (begin (if parent308 (set-annotation-stripped! parent308 new309)) (set-car! new309 (strip-annotation159 (car x307) #f)) (set-cdr! new309 (strip-annotation159 (cdr x307) #f)) new309)) (if (annotation? x307) (let ((t310 (annotation-stripped x307))) (if t310 t310 (strip-annotation159 (annotation-expression x307) x307))) (if (vector? x307) (let ((new311 (make-vector (vector-length x307)))) (begin (if parent308 (set-annotation-stripped! parent308 new311)) (letrec ((loop312 (lambda (i313) (unless (fx<75 i313 0) (vector-set! new311 i313 (strip-annotation159 (vector-ref x307 i313) #f)) (loop312 (fx-73 i313 1)))))) (loop312 (- (vector-length x307) 1))) new311)) x307))))) (ellipsis?158 (lambda (x314) (if (nonsymbol-id?112 x314) (free-id=?136 x314 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void157 (lambda () (build-void80 #f))) (eval-local-transformer156 (lambda (expanded315 mod316) (let ((p317 (local-eval-hook77 expanded315 mod316))) (if (procedure? p317) p317 (syntax-violation #f "nonprocedure transformer" p317))))) (chi-local-syntax155 (lambda (rec?318 e319 r320 w321 s322 mod323 k324) ((lambda (tmp325) ((lambda (tmp326) (if tmp326 (apply (lambda (_327 id328 val329 e1330 e2331) (let ((ids332 id328)) (if (not (valid-bound-ids?138 ids332)) (syntax-violation #f "duplicate bound keyword" e319) (let ((labels334 (gen-labels119 ids332))) (let ((new-w335 (make-binding-wrap130 ids332 labels334 w321))) (k324 (cons e1330 e2331) (extend-env107 labels334 (let ((w337 (if rec?318 new-w335 w321)) (trans-r338 (macros-only-env109 r320))) (map (lambda (x339) (cons (quote macro) (eval-local-transformer156 (chi149 x339 trans-r338 w337 mod323) mod323))) val329)) r320) new-w335 s322 mod323)))))) tmp326) ((lambda (_341) (syntax-violation #f "bad local syntax definition" (source-wrap142 e319 w321 s322 mod323))) tmp325))) ($sc-dispatch tmp325 (quote (any #(each (any any)) any . each-any))))) e319))) (chi-lambda-clause154 (lambda (e342 docstring343 c344 r345 w346 mod347 k348) ((lambda (tmp349) ((lambda (tmp350) (if (if tmp350 (apply (lambda (args351 doc352 e1353 e2354) (if (string? (syntax->datum doc352)) (not docstring343) #f)) tmp350) #f) (apply (lambda (args355 doc356 e1357 e2358) (chi-lambda-clause154 e342 doc356 (cons args355 (cons e1357 e2358)) r345 w346 mod347 k348)) tmp350) ((lambda (tmp360) (if tmp360 (apply (lambda (id361 e1362 e2363) (let ((ids364 id361)) (if (not (valid-bound-ids?138 ids364)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels366 (gen-labels119 ids364)) (new-vars367 (map gen-var161 ids364))) (k348 (map syntax->datum ids364) new-vars367 (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1362 e2363) e342 (extend-var-env108 labels366 new-vars367 r345) (make-binding-wrap130 ids364 labels366 w346) mod347)))))) tmp360) ((lambda (tmp369) (if tmp369 (apply (lambda (ids370 e1371 e2372) (let ((old-ids373 (lambda-var-list162 ids370))) (if (not (valid-bound-ids?138 old-ids373)) (syntax-violation (quote lambda) "invalid parameter list" e342) (let ((labels374 (gen-labels119 old-ids373)) (new-vars375 (map gen-var161 old-ids373))) (k348 (letrec ((f376 (lambda (ls1377 ls2378) (if (null? ls1377) (syntax->datum ls2378) (f376 (cdr ls1377) (cons (syntax->datum (car ls1377)) ls2378)))))) (f376 (cdr old-ids373) (car old-ids373))) (letrec ((f379 (lambda (ls1380 ls2381) (if (null? ls1380) ls2381 (f379 (cdr ls1380) (cons (car ls1380) ls2381)))))) (f379 (cdr new-vars375) (car new-vars375))) (if docstring343 (syntax->datum docstring343) #f) (chi-body153 (cons e1371 e2372) e342 (extend-var-env108 labels374 new-vars375 r345) (make-binding-wrap130 old-ids373 labels374 w346) mod347)))))) tmp369) ((lambda (_383) (syntax-violation (quote lambda) "bad lambda" e342)) tmp349))) ($sc-dispatch tmp349 (quote (any any . each-any)))))) ($sc-dispatch tmp349 (quote (each-any any . each-any)))))) ($sc-dispatch tmp349 (quote (any any any . each-any))))) c344))) (chi-body153 (lambda (body384 outer-form385 r386 w387 mod388) (let ((r389 (cons (quote ("placeholder" placeholder)) r386))) (let ((ribcage390 (make-ribcage120 (quote ()) (quote ()) (quote ())))) (let ((w391 (make-wrap115 (wrap-marks116 w387) (cons ribcage390 (wrap-subst117 w387))))) (letrec ((parse392 (lambda (body393 ids394 labels395 vars396 vals397 bindings398) (if (null? body393) (syntax-violation #f "no expressions in body" outer-form385) (let ((e400 (cdar body393)) (er401 (caar body393))) (call-with-values (lambda () (syntax-type147 e400 er401 (quote (())) #f ribcage390 mod388)) (lambda (type402 value403 e404 w405 s406 mod407) (if (memv type402 (quote (define-form))) (let ((id408 (wrap141 value403 w405 mod407)) (label409 (gen-label118))) (let ((var410 (gen-var161 id408))) (begin (extend-ribcage!129 ribcage390 id408 label409) (parse392 (cdr body393) (cons id408 ids394) (cons label409 labels395) (cons var410 vars396) (cons (cons er401 (wrap141 e404 w405 mod407)) vals397) (cons (cons (quote lexical) var410) bindings398))))) (if (memv type402 (quote (define-syntax-form))) (let ((id411 (wrap141 value403 w405 mod407)) (label412 (gen-label118))) (begin (extend-ribcage!129 ribcage390 id411 label412) (parse392 (cdr body393) (cons id411 ids394) (cons label412 labels395) vars396 vals397 (cons (cons (quote macro) (cons er401 (wrap141 e404 w405 mod407))) bindings398)))) (if (memv type402 (quote (begin-form))) ((lambda (tmp413) ((lambda (tmp414) (if tmp414 (apply (lambda (_415 e1416) (parse392 (letrec ((f417 (lambda (forms418) (if (null? forms418) (cdr body393) (cons (cons er401 (wrap141 (car forms418) w405 mod407)) (f417 (cdr forms418))))))) (f417 e1416)) ids394 labels395 vars396 vals397 bindings398)) tmp414) (syntax-violation #f "source expression failed to match any pattern" tmp413))) ($sc-dispatch tmp413 (quote (any . each-any))))) e404) (if (memv type402 (quote (local-syntax-form))) (chi-local-syntax155 value403 e404 er401 w405 s406 mod407 (lambda (forms420 er421 w422 s423 mod424) (parse392 (letrec ((f425 (lambda (forms426) (if (null? forms426) (cdr body393) (cons (cons er421 (wrap141 (car forms426) w422 mod424)) (f425 (cdr forms426))))))) (f425 forms420)) ids394 labels395 vars396 vals397 bindings398))) (if (null? ids394) (build-sequence92 #f (map (lambda (x427) (chi149 (cdr x427) (car x427) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))) (begin (if (not (valid-bound-ids?138 ids394)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form385)) (letrec ((loop428 (lambda (bs429 er-cache430 r-cache431) (if (not (null? bs429)) (let ((b432 (car bs429))) (if (eq? (car b432) (quote macro)) (let ((er433 (cadr b432))) (let ((r-cache434 (if (eq? er433 er-cache430) r-cache431 (macros-only-env109 er433)))) (begin (set-cdr! b432 (eval-local-transformer156 (chi149 (cddr b432) r-cache434 (quote (())) mod407) mod407)) (loop428 (cdr bs429) er433 r-cache434)))) (loop428 (cdr bs429) er-cache430 r-cache431))))))) (loop428 bindings398 #f #f)) (set-cdr! r389 (extend-env107 labels395 bindings398 (cdr r389))) (build-letrec95 #f (map syntax->datum ids394) vars396 (map (lambda (x435) (chi149 (cdr x435) (car x435) (quote (())) mod407)) vals397) (build-sequence92 #f (map (lambda (x436) (chi149 (cdr x436) (car x436) (quote (())) mod407)) (cons (cons er401 (source-wrap142 e404 w405 s406 mod407)) (cdr body393)))))))))))))))))) (parse392 (map (lambda (x399) (cons r389 (wrap141 x399 w391 mod388))) body384) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro152 (lambda (p437 e438 r439 w440 rib441 mod442) (letrec ((rebuild-macro-output443 (lambda (x444 m445) (if (pair? x444) (cons (rebuild-macro-output443 (car x444) m445) (rebuild-macro-output443 (cdr x444) m445)) (if (syntax-object?97 x444) (let ((w446 (syntax-object-wrap99 x444))) (let ((ms447 (wrap-marks116 w446)) (s448 (wrap-subst117 w446))) (if (if (pair? ms447) (eq? (car ms447) #f) #f) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cdr ms447) (if rib441 (cons rib441 (cdr s448)) (cdr s448))) (syntax-object-module100 x444)) (make-syntax-object96 (syntax-object-expression98 x444) (make-wrap115 (cons m445 ms447) (if rib441 (cons rib441 (cons (quote shift) s448)) (cons (quote shift) s448))) (let ((pmod449 (procedure-module p437))) (if pmod449 (cons (quote hygiene) (module-name pmod449)) (quote (hygiene guile)))))))) (if (vector? x444) (let ((n450 (vector-length x444))) (let ((v451 (make-vector n450))) (letrec ((loop452 (lambda (i453) (if (fx=74 i453 n450) (begin (if #f #f) v451) (begin (vector-set! v451 i453 (rebuild-macro-output443 (vector-ref x444 i453) m445)) (loop452 (fx+72 i453 1))))))) (loop452 0)))) (if (symbol? x444) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap142 e438 w440 s mod442) x444) x444))))))) (rebuild-macro-output443 (p437 (wrap141 e438 (anti-mark128 w440) mod442)) (string #\m))))) (chi-application151 (lambda (x454 e455 r456 w457 s458 mod459) ((lambda (tmp460) ((lambda (tmp461) (if tmp461 (apply (lambda (e0462 e1463) (build-application81 s458 x454 (map (lambda (e464) (chi149 e464 r456 w457 mod459)) e1463))) tmp461) (syntax-violation #f "source expression failed to match any pattern" tmp460))) ($sc-dispatch tmp460 (quote (any . each-any))))) e455))) (chi-expr150 (lambda (type466 value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (lexical))) (build-lexical-reference83 (quote value) s471 e468 value467) (if (memv type466 (quote (core external-macro))) (value467 e468 r469 w470 s471 mod472) (if (memv type466 (quote (module-ref))) (call-with-values (lambda () (value467 e468)) (lambda (id473 mod474) (build-global-reference86 s471 id473 mod474))) (if (memv type466 (quote (lexical-call))) (chi-application151 (build-lexical-reference83 (quote fun) (source-annotation104 (car e468)) (car e468) value467) e468 r469 w470 s471 mod472) (if (memv type466 (quote (global-call))) (chi-application151 (build-global-reference86 (source-annotation104 (car e468)) value467 (if (syntax-object?97 (car e468)) (syntax-object-module100 (car e468)) mod472)) e468 r469 w470 s471 mod472) (if (memv type466 (quote (constant))) (build-data91 s471 (strip160 (source-wrap142 e468 w470 s471 mod472) (quote (())))) (if (memv type466 (quote (global))) (build-global-reference86 s471 value467 mod472) (if (memv type466 (quote (call))) (chi-application151 (chi149 (car e468) r469 w470 mod472) e468 r469 w470 s471 mod472) (if (memv type466 (quote (begin-form))) ((lambda (tmp475) ((lambda (tmp476) (if tmp476 (apply (lambda (_477 e1478 e2479) (chi-sequence143 (cons e1478 e2479) r469 w470 s471 mod472)) tmp476) (syntax-violation #f "source expression failed to match any pattern" tmp475))) ($sc-dispatch tmp475 (quote (any any . each-any))))) e468) (if (memv type466 (quote (local-syntax-form))) (chi-local-syntax155 value467 e468 r469 w470 s471 mod472 chi-sequence143) (if (memv type466 (quote (eval-when-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 x484 e1485 e2486) (let ((when-list487 (chi-when-list146 e468 x484 w470))) (if (memq (quote eval) when-list487) (chi-sequence143 (cons e1485 e2486) r469 w470 s471 mod472) (chi-void157)))) tmp482) (syntax-violation #f "source expression failed to match any pattern" tmp481))) ($sc-dispatch tmp481 (quote (any each-any any . each-any))))) e468) (if (memv type466 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e468 (wrap141 value467 w470 mod472)) (if (memv type466 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap142 e468 w470 s471 mod472)) (if (memv type466 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap142 e468 w470 s471 mod472)) (syntax-violation #f "unexpected syntax" (source-wrap142 e468 w470 s471 mod472)))))))))))))))))) (chi149 (lambda (e490 r491 w492 mod493) (call-with-values (lambda () (syntax-type147 e490 r491 w492 #f #f mod493)) (lambda (type494 value495 e496 w497 s498 mod499) (chi-expr150 type494 value495 e496 r491 w497 s498 mod499))))) (chi-top148 (lambda (e500 r501 w502 m503 esew504 mod505) (call-with-values (lambda () (syntax-type147 e500 r501 w502 #f #f mod505)) (lambda (type513 value514 e515 w516 s517 mod518) (if (memv type513 (quote (begin-form))) ((lambda (tmp519) ((lambda (tmp520) (if tmp520 (apply (lambda (_521) (chi-void157)) tmp520) ((lambda (tmp522) (if tmp522 (apply (lambda (_523 e1524 e2525) (chi-top-sequence144 (cons e1524 e2525) r501 w516 s517 m503 esew504 mod518)) tmp522) (syntax-violation #f "source expression failed to match any pattern" tmp519))) ($sc-dispatch tmp519 (quote (any any . each-any)))))) ($sc-dispatch tmp519 (quote (any))))) e515) (if (memv type513 (quote (local-syntax-form))) (chi-local-syntax155 value514 e515 r501 w516 s517 mod518 (lambda (body527 r528 w529 s530 mod531) (chi-top-sequence144 body527 r528 w529 s530 m503 esew504 mod531))) (if (memv type513 (quote (eval-when-form))) ((lambda (tmp532) ((lambda (tmp533) (if tmp533 (apply (lambda (_534 x535 e1536 e2537) (let ((when-list538 (chi-when-list146 e515 x535 w516)) (body539 (cons e1536 e2537))) (if (eq? m503 (quote e)) (if (memq (quote eval) when-list538) (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) (chi-void157)) (if (memq (quote load) when-list538) (if (let ((t542 (memq (quote compile) when-list538))) (if t542 t542 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (chi-top-sequence144 body539 r501 w516 s517 (quote c&e) (quote (compile load)) mod518) (if (memq m503 (quote (c c&e))) (chi-top-sequence144 body539 r501 w516 s517 (quote c) (quote (load)) mod518) (chi-void157))) (if (let ((t543 (memq (quote compile) when-list538))) (if t543 t543 (if (eq? m503 (quote c&e)) (memq (quote eval) when-list538) #f))) (begin (top-level-eval-hook76 (chi-top-sequence144 body539 r501 w516 s517 (quote e) (quote (eval)) mod518) mod518) (chi-void157)) (chi-void157)))))) tmp533) (syntax-violation #f "source expression failed to match any pattern" tmp532))) ($sc-dispatch tmp532 (quote (any each-any any . each-any))))) e515) (if (memv type513 (quote (define-syntax-form))) (let ((n544 (id-var-name135 value514 w516)) (r545 (macros-only-env109 r501))) (if (memv m503 (quote (c))) (if (memq (quote compile) esew504) (let ((e546 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e546 mod518) (if (memq (quote load) esew504) e546 (chi-void157)))) (if (memq (quote load) esew504) (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) (chi-void157))) (if (memv m503 (quote (c&e))) (let ((e547 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)))) (begin (top-level-eval-hook76 e547 mod518) e547)) (begin (if (memq (quote eval) esew504) (top-level-eval-hook76 (chi-install-global145 n544 (chi149 e515 r545 w516 mod518)) mod518)) (chi-void157))))) (if (memv type513 (quote (define-form))) (let ((n548 (id-var-name135 value514 w516))) (let ((type549 (binding-type105 (lookup110 n548 r501 mod518)))) (if (memv type549 (quote (global core macro module-ref))) (let ((x550 (build-global-definition88 s517 n548 (chi149 e515 r501 w516 mod518)))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x550 mod518)) x550)) (if (memv type549 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e515 (wrap141 value514 w516 mod518)) (syntax-violation #f "cannot define keyword at top level" e515 (wrap141 value514 w516 mod518)))))) (let ((x551 (chi-expr150 type513 value514 e515 r501 w516 s517 mod518))) (begin (if (eq? m503 (quote c&e)) (top-level-eval-hook76 x551 mod518)) x551))))))))))) (syntax-type147 (lambda (e552 r553 w554 s555 rib556 mod557) (if (symbol? e552) (let ((n558 (id-var-name135 e552 w554))) (let ((b559 (lookup110 n558 r553 mod557))) (let ((type560 (binding-type105 b559))) (if (memv type560 (quote (lexical))) (values type560 (binding-value106 b559) e552 w554 s555 mod557) (if (memv type560 (quote (global))) (values type560 n558 e552 w554 s555 mod557) (if (memv type560 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b559) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (values type560 (binding-value106 b559) e552 w554 s555 mod557))))))) (if (pair? e552) (let ((first561 (car e552))) (if (id?113 first561) (let ((n562 (id-var-name135 first561 w554))) (let ((b563 (lookup110 n562 r553 (let ((t564 (if (syntax-object?97 first561) (syntax-object-module100 first561) #f))) (if t564 t564 mod557))))) (let ((type565 (binding-type105 b563))) (if (memv type565 (quote (lexical))) (values (quote lexical-call) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (global))) (values (quote global-call) n562 e552 w554 s555 mod557) (if (memv type565 (quote (macro))) (syntax-type147 (chi-macro152 (binding-value106 b563) e552 r553 w554 rib556 mod557) r553 (quote (())) s555 rib556 mod557) (if (memv type565 (quote (core external-macro module-ref))) (values type565 (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value106 b563) e552 w554 s555 mod557) (if (memv type565 (quote (begin))) (values (quote begin-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (eval-when))) (values (quote eval-when-form) #f e552 w554 s555 mod557) (if (memv type565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?113 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555 mod557)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (if (id?113 name576) (valid-bound-ids?138 (lambda-var-list162 args577)) #f)) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap141 name581 w554 mod557) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap141 (cons args582 (cons e1583 e2584)) w554 mod557)) (quote (())) s555 mod557)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?113 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap141 name590 w554 mod557) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s555 mod557)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e552) (if (memv type565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?113 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555 mod557)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) #f e552 w554 s555 mod557))))))))))))) (values (quote call) #f e552 w554 s555 mod557))) (if (syntax-object?97 e552) (syntax-type147 (syntax-object-expression98 e552) r553 (join-wraps132 w554 (syntax-object-wrap99 e552)) #f rib556 (let ((t599 (syntax-object-module100 e552))) (if t599 t599 mod557))) (if (annotation? e552) (syntax-type147 (annotation-expression e552) r553 w554 (annotation-source e552) rib556 mod557) (if (self-evaluating? e552) (values (quote constant) #f e552 w554 s555 mod557) (values (quote other) #f e552 w554 s555 mod557)))))))) (chi-when-list146 (lambda (e600 when-list601 w602) (letrec ((f603 (lambda (when-list604 situations605) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (if (free-id=?136 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?136 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?136 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e600 (wrap141 x606 w602 #f)))))) situations605)))))) (f603 when-list601 (quote ()))))) (chi-install-global145 (lambda (name607 e608) (build-global-definition88 #f name607 (if (let ((v609 (module-variable (current-module) name607))) (if v609 (if (variable-bound? v609) (if (macro? (variable-ref v609)) (not (eq? (macro-type (variable-ref v609)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref90 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref90 #f (quote module-ref)) (list (build-application81 #f (build-primref90 #f (quote current-module)) (quote ())) (build-data91 #f name607))) (build-data91 #f (quote macro)) e608)) (build-application81 #f (build-primref90 #f (quote make-syncase-macro)) (list (build-data91 #f (quote macro)) e608)))))) (chi-top-sequence144 (lambda (body610 r611 w612 s613 m614 esew615 mod616) (build-sequence92 s613 (letrec ((dobody617 (lambda (body618 r619 w620 m621 esew622 mod623) (if (null? body618) (quote ()) (let ((first624 (chi-top148 (car body618) r619 w620 m621 esew622 mod623))) (cons first624 (dobody617 (cdr body618) r619 w620 m621 esew622 mod623))))))) (dobody617 body610 r611 w612 m614 esew615 mod616))))) (chi-sequence143 (lambda (body625 r626 w627 s628 mod629) (build-sequence92 s628 (letrec ((dobody630 (lambda (body631 r632 w633 mod634) (if (null? body631) (quote ()) (let ((first635 (chi149 (car body631) r632 w633 mod634))) (cons first635 (dobody630 (cdr body631) r632 w633 mod634))))))) (dobody630 body625 r626 w627 mod629))))) (source-wrap142 (lambda (x636 w637 s638 defmod639) (wrap141 (if s638 (make-annotation x636 s638 #f) x636) w637 defmod639))) (wrap141 (lambda (x640 w641 defmod642) (if (if (null? (wrap-marks116 w641)) (null? (wrap-subst117 w641)) #f) x640 (if (syntax-object?97 x640) (make-syntax-object96 (syntax-object-expression98 x640) (join-wraps132 w641 (syntax-object-wrap99 x640)) (syntax-object-module100 x640)) (if (null? x640) x640 (make-syntax-object96 x640 w641 defmod642)))))) (bound-id-member?140 (lambda (x643 list644) (if (not (null? list644)) (let ((t645 (bound-id=?137 x643 (car list644)))) (if t645 t645 (bound-id-member?140 x643 (cdr list644)))) #f))) (distinct-bound-ids?139 (lambda (ids646) (letrec ((distinct?647 (lambda (ids648) (let ((t649 (null? ids648))) (if t649 t649 (if (not (bound-id-member?140 (car ids648) (cdr ids648))) (distinct?647 (cdr ids648)) #f)))))) (distinct?647 ids646)))) (valid-bound-ids?138 (lambda (ids650) (if (letrec ((all-ids?651 (lambda (ids652) (let ((t653 (null? ids652))) (if t653 t653 (if (id?113 (car ids652)) (all-ids?651 (cdr ids652)) #f)))))) (all-ids?651 ids650)) (distinct-bound-ids?139 ids650) #f))) (bound-id=?137 (lambda (i654 j655) (if (if (syntax-object?97 i654) (syntax-object?97 j655) #f) (if (eq? (let ((e656 (syntax-object-expression98 i654))) (if (annotation? e656) (annotation-expression e656) e656)) (let ((e657 (syntax-object-expression98 j655))) (if (annotation? e657) (annotation-expression e657) e657))) (same-marks?134 (wrap-marks116 (syntax-object-wrap99 i654)) (wrap-marks116 (syntax-object-wrap99 j655))) #f) (eq? (let ((e658 i654)) (if (annotation? e658) (annotation-expression e658) e658)) (let ((e659 j655)) (if (annotation? e659) (annotation-expression e659) e659)))))) (free-id=?136 (lambda (i660 j661) (if (eq? (let ((x662 i660)) (let ((e663 (if (syntax-object?97 x662) (syntax-object-expression98 x662) x662))) (if (annotation? e663) (annotation-expression e663) e663))) (let ((x664 j661)) (let ((e665 (if (syntax-object?97 x664) (syntax-object-expression98 x664) x664))) (if (annotation? e665) (annotation-expression e665) e665)))) (eq? (id-var-name135 i660 (quote (()))) (id-var-name135 j661 (quote (())))) #f))) (id-var-name135 (lambda (id666 w667) (letrec ((search-vector-rib670 (lambda (sym676 subst677 marks678 symnames679 ribcage680) (let ((n681 (vector-length symnames679))) (letrec ((f682 (lambda (i683) (if (fx=74 i683 n681) (search668 sym676 (cdr subst677) marks678) (if (if (eq? (vector-ref symnames679 i683) sym676) (same-marks?134 marks678 (vector-ref (ribcage-marks123 ribcage680) i683)) #f) (values (vector-ref (ribcage-labels124 ribcage680) i683) marks678) (f682 (fx+72 i683 1))))))) (f682 0))))) (search-list-rib669 (lambda (sym684 subst685 marks686 symnames687 ribcage688) (letrec ((f689 (lambda (symnames690 i691) (if (null? symnames690) (search668 sym684 (cdr subst685) marks686) (if (if (eq? (car symnames690) sym684) (same-marks?134 marks686 (list-ref (ribcage-marks123 ribcage688) i691)) #f) (values (list-ref (ribcage-labels124 ribcage688) i691) marks686) (f689 (cdr symnames690) (fx+72 i691 1))))))) (f689 symnames687 0)))) (search668 (lambda (sym692 subst693 marks694) (if (null? subst693) (values #f marks694) (let ((fst695 (car subst693))) (if (eq? fst695 (quote shift)) (search668 sym692 (cdr subst693) (cdr marks694)) (let ((symnames696 (ribcage-symnames122 fst695))) (if (vector? symnames696) (search-vector-rib670 sym692 subst693 marks694 symnames696 fst695) (search-list-rib669 sym692 subst693 marks694 symnames696 fst695))))))))) (if (symbol? id666) (let ((t697 (call-with-values (lambda () (search668 id666 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x699 . ignore698) x699)))) (if t697 t697 id666)) (if (syntax-object?97 id666) (let ((id700 (let ((e702 (syntax-object-expression98 id666))) (if (annotation? e702) (annotation-expression e702) e702))) (w1701 (syntax-object-wrap99 id666))) (let ((marks703 (join-marks133 (wrap-marks116 w667) (wrap-marks116 w1701)))) (call-with-values (lambda () (search668 id700 (wrap-subst117 w667) marks703)) (lambda (new-id704 marks705) (let ((t706 new-id704)) (if t706 t706 (let ((t707 (call-with-values (lambda () (search668 id700 (wrap-subst117 w1701) marks705)) (lambda (x709 . ignore708) x709)))) (if t707 t707 id700)))))))) (if (annotation? id666) (let ((id710 (let ((e711 id666)) (if (annotation? e711) (annotation-expression e711) e711)))) (let ((t712 (call-with-values (lambda () (search668 id710 (wrap-subst117 w667) (wrap-marks116 w667))) (lambda (x714 . ignore713) x714)))) (if t712 t712 id710))) (syntax-violation (quote id-var-name) "invalid id" id666))))))) (same-marks?134 (lambda (x715 y716) (let ((t717 (eq? x715 y716))) (if t717 t717 (if (not (null? x715)) (if (not (null? y716)) (if (eq? (car x715) (car y716)) (same-marks?134 (cdr x715) (cdr y716)) #f) #f) #f))))) (join-marks133 (lambda (m1718 m2719) (smart-append131 m1718 m2719))) (join-wraps132 (lambda (w1720 w2721) (let ((m1722 (wrap-marks116 w1720)) (s1723 (wrap-subst117 w1720))) (if (null? m1722) (if (null? s1723) w2721 (make-wrap115 (wrap-marks116 w2721) (smart-append131 s1723 (wrap-subst117 w2721)))) (make-wrap115 (smart-append131 m1722 (wrap-marks116 w2721)) (smart-append131 s1723 (wrap-subst117 w2721))))))) (smart-append131 (lambda (m1724 m2725) (if (null? m2725) m1724 (append m1724 m2725)))) (make-binding-wrap130 (lambda (ids726 labels727 w728) (if (null? ids726) w728 (make-wrap115 (wrap-marks116 w728) (cons (let ((labelvec729 (list->vector labels727))) (let ((n730 (vector-length labelvec729))) (let ((symnamevec731 (make-vector n730)) (marksvec732 (make-vector n730))) (begin (letrec ((f733 (lambda (ids734 i735) (if (not (null? ids734)) (call-with-values (lambda () (id-sym-name&marks114 (car ids734) w728)) (lambda (symname736 marks737) (begin (vector-set! symnamevec731 i735 symname736) (vector-set! marksvec732 i735 marks737) (f733 (cdr ids734) (fx+72 i735 1))))))))) (f733 ids726 0)) (make-ribcage120 symnamevec731 marksvec732 labelvec729))))) (wrap-subst117 w728)))))) (extend-ribcage!129 (lambda (ribcage738 id739 label740) (begin (set-ribcage-symnames!125 ribcage738 (cons (let ((e741 (syntax-object-expression98 id739))) (if (annotation? e741) (annotation-expression e741) e741)) (ribcage-symnames122 ribcage738))) (set-ribcage-marks!126 ribcage738 (cons (wrap-marks116 (syntax-object-wrap99 id739)) (ribcage-marks123 ribcage738))) (set-ribcage-labels!127 ribcage738 (cons label740 (ribcage-labels124 ribcage738)))))) (anti-mark128 (lambda (w742) (make-wrap115 (cons #f (wrap-marks116 w742)) (cons (quote shift) (wrap-subst117 w742))))) (set-ribcage-labels!127 (lambda (x743 update744) (vector-set! x743 3 update744))) (set-ribcage-marks!126 (lambda (x745 update746) (vector-set! x745 2 update746))) (set-ribcage-symnames!125 (lambda (x747 update748) (vector-set! x747 1 update748))) (ribcage-labels124 (lambda (x749) (vector-ref x749 3))) (ribcage-marks123 (lambda (x750) (vector-ref x750 2))) (ribcage-symnames122 (lambda (x751) (vector-ref x751 1))) (ribcage?121 (lambda (x752) (if (vector? x752) (if (= (vector-length x752) 4) (eq? (vector-ref x752 0) (quote ribcage)) #f) #f))) (make-ribcage120 (lambda (symnames753 marks754 labels755) (vector (quote ribcage) symnames753 marks754 labels755))) (gen-labels119 (lambda (ls756) (if (null? ls756) (quote ()) (cons (gen-label118) (gen-labels119 (cdr ls756)))))) (gen-label118 (lambda () (string #\i))) (wrap-subst117 cdr) (wrap-marks116 car) (make-wrap115 cons) (id-sym-name&marks114 (lambda (x757 w758) (if (syntax-object?97 x757) (values (let ((e759 (syntax-object-expression98 x757))) (if (annotation? e759) (annotation-expression e759) e759)) (join-marks133 (wrap-marks116 w758) (wrap-marks116 (syntax-object-wrap99 x757)))) (values (let ((e760 x757)) (if (annotation? e760) (annotation-expression e760) e760)) (wrap-marks116 w758))))) (id?113 (lambda (x761) (if (symbol? x761) #t (if (syntax-object?97 x761) (symbol? (let ((e762 (syntax-object-expression98 x761))) (if (annotation? e762) (annotation-expression e762) e762))) (if (annotation? x761) (symbol? (annotation-expression x761)) #f))))) (nonsymbol-id?112 (lambda (x763) (if (syntax-object?97 x763) (symbol? (let ((e764 (syntax-object-expression98 x763))) (if (annotation? e764) (annotation-expression e764) e764))) #f))) (global-extend111 (lambda (type765 sym766 val767) (put-global-definition-hook78 sym766 type765 val767))) (lookup110 (lambda (x768 r769 mod770) (let ((temp771 (assq x768 r769))) (if temp771 (cdr temp771) (if (symbol? x768) (let ((t772 (get-global-definition-hook79 x768 mod770))) (if t772 t772 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env109 (lambda (r773) (if (null? r773) (quote ()) (let ((a774 (car r773))) (if (eq? (cadr a774) (quote macro)) (cons a774 (macros-only-env109 (cdr r773))) (macros-only-env109 (cdr r773))))))) (extend-var-env108 (lambda (labels775 vars776 r777) (if (null? labels775) r777 (extend-var-env108 (cdr labels775) (cdr vars776) (cons (cons (car labels775) (cons (quote lexical) (car vars776))) r777))))) (extend-env107 (lambda (labels778 bindings779 r780) (if (null? labels778) r780 (extend-env107 (cdr labels778) (cdr bindings779) (cons (cons (car labels778) (car bindings779)) r780))))) (binding-value106 cdr) (binding-type105 car) (source-annotation104 (lambda (x781) (if (annotation? x781) (annotation-source x781) (if (syntax-object?97 x781) (source-annotation104 (syntax-object-expression98 x781)) #f)))) (set-syntax-object-module!103 (lambda (x782 update783) (vector-set! x782 3 update783))) (set-syntax-object-wrap!102 (lambda (x784 update785) (vector-set! x784 2 update785))) (set-syntax-object-expression!101 (lambda (x786 update787) (vector-set! x786 1 update787))) (syntax-object-module100 (lambda (x788) (vector-ref x788 3))) (syntax-object-wrap99 (lambda (x789) (vector-ref x789 2))) (syntax-object-expression98 (lambda (x790) (vector-ref x790 1))) (syntax-object?97 (lambda (x791) (if (vector? x791) (if (= (vector-length x791) 4) (eq? (vector-ref x791 0) (quote syntax-object)) #f) #f))) (make-syntax-object96 (lambda (expression792 wrap793 module794) (vector (quote syntax-object) expression792 wrap793 module794))) (build-letrec95 (lambda (src795 ids796 vars797 val-exps798 body-exp799) (if (null? vars797) body-exp799 (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-letrec) src795 ids796 vars797 val-exps798 body-exp799) (list (quote letrec) (map list vars797 val-exps798) body-exp799)))))) (build-named-let94 (lambda (src801 ids802 vars803 val-exps804 body-exp805) (let ((f806 (car vars803)) (f-name807 (car ids802)) (vars808 (cdr vars803)) (ids809 (cdr ids802))) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-letrec) src801 (list f-name807) (list f806) (list (build-lambda89 src801 ids809 vars808 #f body-exp805)) (build-application81 src801 (build-lexical-reference83 (quote fun) src801 f-name807 f806) val-exps804)) (list (quote let) f806 (map list vars808 val-exps804) body-exp805)))))) (build-let93 (lambda (src811 ids812 vars813 val-exps814 body-exp815) (if (null? vars813) body-exp815 (let ((atom-key816 (fluid-ref *mode*71))) (if (memv atom-key816 (quote (c))) ((@ (language tree-il) make-let) src811 ids812 vars813 val-exps814 body-exp815) (list (quote let) (map list vars813 val-exps814) body-exp815)))))) (build-sequence92 (lambda (src817 exps818) (if (null? (cdr exps818)) (car exps818) (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) ((@ (language tree-il) make-sequence) src817 exps818) (cons (quote begin) exps818)))))) (build-data91 (lambda (src820 exp821) (let ((atom-key822 (fluid-ref *mode*71))) (if (memv atom-key822 (quote (c))) ((@ (language tree-il) make-const) src820 exp821) (if (if (self-evaluating? exp821) (not (vector? exp821)) #f) exp821 (list (quote quote) exp821)))))) (build-primref90 (lambda (src823 name824) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src823 name824) name824)) (let ((atom-key826 (fluid-ref *mode*71))) (if (memv atom-key826 (quote (c))) ((@ (language tree-il) make-module-ref) src823 (quote (guile)) name824 #f) (list (quote @@) (quote (guile)) name824)))))) (build-lambda89 (lambda (src827 ids828 vars829 docstring830 exp831) (let ((atom-key832 (fluid-ref *mode*71))) (if (memv atom-key832 (quote (c))) ((@ (language tree-il) make-lambda) src827 ids828 vars829 (if docstring830 (list (cons (quote documentation) docstring830)) (quote ())) exp831) (cons (quote lambda) (cons vars829 (append (if docstring830 (list docstring830) (quote ())) (list exp831)))))))) (build-global-definition88 (lambda (source833 var834 exp835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-define) source833 var834 exp835) (list (quote define) var834 exp835))))) (build-global-assignment87 (lambda (source837 var838 exp839 mod840) (analyze-variable85 mod840 var838 (lambda (mod841 var842 public?843) (let ((atom-key844 (fluid-ref *mode*71))) (if (memv atom-key844 (quote (c))) ((@ (language tree-il) make-module-set) source837 mod841 var842 public?843 exp839) (list (quote set!) (list (if public?843 (quote @) (quote @@)) mod841 var842) exp839)))) (lambda (var845) (let ((atom-key846 (fluid-ref *mode*71))) (if (memv atom-key846 (quote (c))) ((@ (language tree-il) make-toplevel-set) source837 var845 exp839) (list (quote set!) var845 exp839))))))) (build-global-reference86 (lambda (source847 var848 mod849) (analyze-variable85 mod849 var848 (lambda (mod850 var851 public?852) (let ((atom-key853 (fluid-ref *mode*71))) (if (memv atom-key853 (quote (c))) ((@ (language tree-il) make-module-ref) source847 mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851)))) (lambda (var854) (let ((atom-key855 (fluid-ref *mode*71))) (if (memv atom-key855 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source847 var854) var854)))))) (analyze-variable85 (lambda (mod856 var857 modref-cont858 bare-cont859) (if (not mod856) (bare-cont859 var857) (let ((kind860 (car mod856)) (mod861 (cdr mod856))) (if (memv kind860 (quote (public))) (modref-cont858 mod861 var857 #t) (if (memv kind860 (quote (private))) (if (not (equal? mod861 (module-name (current-module)))) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (if (memv kind860 (quote (bare))) (bare-cont859 var857) (if (memv kind860 (quote (hygiene))) (if (if (not (equal? mod861 (module-name (current-module)))) (module-variable (resolve-module mod861) var857) #f) (modref-cont858 mod861 var857 #f) (bare-cont859 var857)) (syntax-violation #f "bad module kind" var857 mod861))))))))) (build-lexical-assignment84 (lambda (source862 name863 var864 exp865) (let ((atom-key866 (fluid-ref *mode*71))) (if (memv atom-key866 (quote (c))) ((@ (language tree-il) make-lexical-set) source862 name863 var864 exp865) (list (quote set!) var864 exp865))))) (build-lexical-reference83 (lambda (type867 source868 name869 var870) (let ((atom-key871 (fluid-ref *mode*71))) (if (memv atom-key871 (quote (c))) ((@ (language tree-il) make-lexical-ref) source868 name869 var870) var870)))) (build-conditional82 (lambda (source872 test-exp873 then-exp874 else-exp875) (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) make-conditional) source872 test-exp873 then-exp874 else-exp875) (if (equal? else-exp875 (quote (if #f #f))) (list (quote if) test-exp873 then-exp874) (list (quote if) test-exp873 then-exp874 else-exp875)))))) (build-application81 (lambda (source877 fun-exp878 arg-exps879) (let ((atom-key880 (fluid-ref *mode*71))) (if (memv atom-key880 (quote (c))) ((@ (language tree-il) make-application) source877 fun-exp878 arg-exps879) (cons fun-exp878 arg-exps879))))) (build-void80 (lambda (source881) (let ((atom-key882 (fluid-ref *mode*71))) (if (memv atom-key882 (quote (c))) ((@ (language tree-il) make-void) source881) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol883 module884) (begin (if (if (not module884) (current-module) #f) (warn "module system is booted, we should have a module" symbol883)) (let ((v885 (module-variable (if module884 (resolve-module (cdr module884)) (current-module)) symbol883))) (if v885 (if (variable-bound? v885) (let ((val886 (variable-ref v885))) (if (macro? val886) (if (syncase-macro-type val886) (cons (syncase-macro-type val886) (syncase-macro-binding val886)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol887 type888 val889) (let ((existing890 (let ((v891 (module-variable (current-module) symbol887))) (if v891 (if (variable-bound? v891) (let ((val892 (variable-ref v891))) (if (macro? val892) (if (not (syncase-macro-type val892)) val892 #f) #f)) #f) #f)))) (module-define! (current-module) symbol887 (if existing890 (make-extended-syncase-macro existing890 type888 val889) (make-syncase-macro type888 val889)))))) (local-eval-hook77 (lambda (x893 mod894) (primitive-eval (list noexpand70 (let ((atom-key895 (fluid-ref *mode*71))) (if (memv atom-key895 (quote (c))) ((@ (language tree-il) tree-il->scheme) x893) x893)))))) (top-level-eval-hook76 (lambda (x896 mod897) (primitive-eval (list noexpand70 (let ((atom-key898 (fluid-ref *mode*71))) (if (memv atom-key898 (quote (c))) ((@ (language tree-il) tree-il->scheme) x896) x896)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend111 (quote local-syntax) (quote letrec-syntax) #t) (global-extend111 (quote local-syntax) (quote let-syntax) #f) (global-extend111 (quote core) (quote fluid-let-syntax) (lambda (e899 r900 w901 s902 mod903) ((lambda (tmp904) ((lambda (tmp905) (if (if tmp905 (apply (lambda (_906 var907 val908 e1909 e2910) (valid-bound-ids?138 var907)) tmp905) #f) (apply (lambda (_912 var913 val914 e1915 e2916) (let ((names917 (map (lambda (x918) (id-var-name135 x918 w901)) var913))) (begin (for-each (lambda (id920 n921) (let ((atom-key922 (binding-type105 (lookup110 n921 r900 mod903)))) (if (memv atom-key922 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e899 (source-wrap142 id920 w901 s902 mod903))))) var913 names917) (chi-body153 (cons e1915 e2916) (source-wrap142 e899 w901 s902 mod903) (extend-env107 names917 (let ((trans-r925 (macros-only-env109 r900))) (map (lambda (x926) (cons (quote macro) (eval-local-transformer156 (chi149 x926 trans-r925 w901 mod903) mod903))) val914)) r900) w901 mod903)))) tmp905) ((lambda (_928) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap142 e899 w901 s902 mod903))) tmp904))) ($sc-dispatch tmp904 (quote (any #(each (any any)) any . each-any))))) e899))) (global-extend111 (quote core) (quote quote) (lambda (e929 r930 w931 s932 mod933) ((lambda (tmp934) ((lambda (tmp935) (if tmp935 (apply (lambda (_936 e937) (build-data91 s932 (strip160 e937 w931))) tmp935) ((lambda (_938) (syntax-violation (quote quote) "bad syntax" (source-wrap142 e929 w931 s932 mod933))) tmp934))) ($sc-dispatch tmp934 (quote (any any))))) e929))) (global-extend111 (quote core) (quote syntax) (letrec ((regen946 (lambda (x947) (let ((atom-key948 (car x947))) (if (memv atom-key948 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x947) (cadr x947)) (if (memv atom-key948 (quote (primitive))) (build-primref90 #f (cadr x947)) (if (memv atom-key948 (quote (quote))) (build-data91 #f (cadr x947)) (if (memv atom-key948 (quote (lambda))) (build-lambda89 #f (cadr x947) (cadr x947) #f (regen946 (caddr x947))) (if (memv atom-key948 (quote (map))) (let ((ls949 (map regen946 (cdr x947)))) (build-application81 #f (build-primref90 #f (quote map)) ls949)) (build-application81 #f (build-primref90 #f (car x947)) (map regen946 (cdr x947))))))))))) (gen-vector945 (lambda (x950) (if (eq? (car x950) (quote list)) (cons (quote vector) (cdr x950)) (if (eq? (car x950) (quote quote)) (list (quote quote) (list->vector (cadr x950))) (list (quote list->vector) x950))))) (gen-append944 (lambda (x951 y952) (if (equal? y952 (quote (quote ()))) x951 (list (quote append) x951 y952)))) (gen-cons943 (lambda (x953 y954) (let ((atom-key955 (car y954))) (if (memv atom-key955 (quote (quote))) (if (eq? (car x953) (quote quote)) (list (quote quote) (cons (cadr x953) (cadr y954))) (if (eq? (cadr y954) (quote ())) (list (quote list) x953) (list (quote cons) x953 y954))) (if (memv atom-key955 (quote (list))) (cons (quote list) (cons x953 (cdr y954))) (list (quote cons) x953 y954)))))) (gen-map942 (lambda (e956 map-env957) (let ((formals958 (map cdr map-env957)) (actuals959 (map (lambda (x960) (list (quote ref) (car x960))) map-env957))) (if (eq? (car e956) (quote ref)) (car actuals959) (if (and-map (lambda (x961) (if (eq? (car x961) (quote ref)) (memq (cadr x961) formals958) #f)) (cdr e956)) (cons (quote map) (cons (list (quote primitive) (car e956)) (map (let ((r962 (map cons formals958 actuals959))) (lambda (x963) (cdr (assq (cadr x963) r962)))) (cdr e956)))) (cons (quote map) (cons (list (quote lambda) formals958 e956) actuals959))))))) (gen-mappend941 (lambda (e964 map-env965) (list (quote apply) (quote (primitive append)) (gen-map942 e964 map-env965)))) (gen-ref940 (lambda (src966 var967 level968 maps969) (if (fx=74 level968 0) (values var967 maps969) (if (null? maps969) (syntax-violation (quote syntax) "missing ellipsis" src966) (call-with-values (lambda () (gen-ref940 src966 var967 (fx-73 level968 1) (cdr maps969))) (lambda (outer-var970 outer-maps971) (let ((b972 (assq outer-var970 (car maps969)))) (if b972 (values (cdr b972) maps969) (let ((inner-var973 (gen-var161 (quote tmp)))) (values inner-var973 (cons (cons (cons outer-var970 inner-var973) (car maps969)) outer-maps971))))))))))) (gen-syntax939 (lambda (src974 e975 r976 maps977 ellipsis?978 mod979) (if (id?113 e975) (let ((label980 (id-var-name135 e975 (quote (()))))) (let ((b981 (lookup110 label980 r976 mod979))) (if (eq? (binding-type105 b981) (quote syntax)) (call-with-values (lambda () (let ((var.lev982 (binding-value106 b981))) (gen-ref940 src974 (car var.lev982) (cdr var.lev982) maps977))) (lambda (var983 maps984) (values (list (quote ref) var983) maps984))) (if (ellipsis?978 e975) (syntax-violation (quote syntax) "misplaced ellipsis" src974) (values (list (quote quote) e975) maps977))))) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 e988) (ellipsis?978 dots987)) tmp986) #f) (apply (lambda (dots989 e990) (gen-syntax939 src974 e990 r976 maps977 (lambda (x991) #f) mod979)) tmp986) ((lambda (tmp992) (if (if tmp992 (apply (lambda (x993 dots994 y995) (ellipsis?978 dots994)) tmp992) #f) (apply (lambda (x996 dots997 y998) (letrec ((f999 (lambda (y1000 k1001) ((lambda (tmp1005) ((lambda (tmp1006) (if (if tmp1006 (apply (lambda (dots1007 y1008) (ellipsis?978 dots1007)) tmp1006) #f) (apply (lambda (dots1009 y1010) (f999 y1010 (lambda (maps1011) (call-with-values (lambda () (k1001 (cons (quote ()) maps1011))) (lambda (x1012 maps1013) (if (null? (car maps1013)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-mappend941 x1012 (car maps1013)) (cdr maps1013)))))))) tmp1006) ((lambda (_1014) (call-with-values (lambda () (gen-syntax939 src974 y1000 r976 maps977 ellipsis?978 mod979)) (lambda (y1015 maps1016) (call-with-values (lambda () (k1001 maps1016)) (lambda (x1017 maps1018) (values (gen-append944 x1017 y1015) maps1018)))))) tmp1005))) ($sc-dispatch tmp1005 (quote (any . any))))) y1000)))) (f999 y998 (lambda (maps1002) (call-with-values (lambda () (gen-syntax939 src974 x996 r976 (cons (quote ()) maps1002) ellipsis?978 mod979)) (lambda (x1003 maps1004) (if (null? (car maps1004)) (syntax-violation (quote syntax) "extra ellipsis" src974) (values (gen-map942 x1003 (car maps1004)) (cdr maps1004))))))))) tmp992) ((lambda (tmp1019) (if tmp1019 (apply (lambda (x1020 y1021) (call-with-values (lambda () (gen-syntax939 src974 x1020 r976 maps977 ellipsis?978 mod979)) (lambda (x1022 maps1023) (call-with-values (lambda () (gen-syntax939 src974 y1021 r976 maps1023 ellipsis?978 mod979)) (lambda (y1024 maps1025) (values (gen-cons943 x1022 y1024) maps1025)))))) tmp1019) ((lambda (tmp1026) (if tmp1026 (apply (lambda (e11027 e21028) (call-with-values (lambda () (gen-syntax939 src974 (cons e11027 e21028) r976 maps977 ellipsis?978 mod979)) (lambda (e1030 maps1031) (values (gen-vector945 e1030) maps1031)))) tmp1026) ((lambda (_1032) (values (list (quote quote) e975) maps977)) tmp985))) ($sc-dispatch tmp985 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp985 (quote (any . any)))))) ($sc-dispatch tmp985 (quote (any any . any)))))) ($sc-dispatch tmp985 (quote (any any))))) e975))))) (lambda (e1033 r1034 w1035 s1036 mod1037) (let ((e1038 (source-wrap142 e1033 w1035 s1036 mod1037))) ((lambda (tmp1039) ((lambda (tmp1040) (if tmp1040 (apply (lambda (_1041 x1042) (call-with-values (lambda () (gen-syntax939 e1038 x1042 r1034 (quote ()) ellipsis?158 mod1037)) (lambda (e1043 maps1044) (regen946 e1043)))) tmp1040) ((lambda (_1045) (syntax-violation (quote syntax) "bad `syntax' form" e1038)) tmp1039))) ($sc-dispatch tmp1039 (quote (any any))))) e1038))))) (global-extend111 (quote core) (quote lambda) (lambda (e1046 r1047 w1048 s1049 mod1050) ((lambda (tmp1051) ((lambda (tmp1052) (if tmp1052 (apply (lambda (_1053 c1054) (chi-lambda-clause154 (source-wrap142 e1046 w1048 s1049 mod1050) #f c1054 r1047 w1048 mod1050 (lambda (names1055 vars1056 docstring1057 body1058) (build-lambda89 s1049 names1055 vars1056 docstring1057 body1058)))) tmp1052) (syntax-violation #f "source expression failed to match any pattern" tmp1051))) ($sc-dispatch tmp1051 (quote (any . any))))) e1046))) (global-extend111 (quote core) (quote let) (letrec ((chi-let1059 (lambda (e1060 r1061 w1062 s1063 mod1064 constructor1065 ids1066 vals1067 exps1068) (if (not (valid-bound-ids?138 ids1066)) (syntax-violation (quote let) "duplicate bound variable" e1060) (let ((labels1069 (gen-labels119 ids1066)) (new-vars1070 (map gen-var161 ids1066))) (let ((nw1071 (make-binding-wrap130 ids1066 labels1069 w1062)) (nr1072 (extend-var-env108 labels1069 new-vars1070 r1061))) (constructor1065 s1063 (map syntax->datum ids1066) new-vars1070 (map (lambda (x1073) (chi149 x1073 r1061 w1062 mod1064)) vals1067) (chi-body153 exps1068 (source-wrap142 e1060 nw1071 s1063 mod1064) nr1072 nw1071 mod1064)))))))) (lambda (e1074 r1075 w1076 s1077 mod1078) ((lambda (tmp1079) ((lambda (tmp1080) (if tmp1080 (apply (lambda (_1081 id1082 val1083 e11084 e21085) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-let93 id1082 val1083 (cons e11084 e21085))) tmp1080) ((lambda (tmp1089) (if (if tmp1089 (apply (lambda (_1090 f1091 id1092 val1093 e11094 e21095) (id?113 f1091)) tmp1089) #f) (apply (lambda (_1096 f1097 id1098 val1099 e11100 e21101) (chi-let1059 e1074 r1075 w1076 s1077 mod1078 build-named-let94 (cons f1097 id1098) val1099 (cons e11100 e21101))) tmp1089) ((lambda (_1105) (syntax-violation (quote let) "bad let" (source-wrap142 e1074 w1076 s1077 mod1078))) tmp1079))) ($sc-dispatch tmp1079 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1079 (quote (any #(each (any any)) any . each-any))))) e1074)))) (global-extend111 (quote core) (quote letrec) (lambda (e1106 r1107 w1108 s1109 mod1110) ((lambda (tmp1111) ((lambda (tmp1112) (if tmp1112 (apply (lambda (_1113 id1114 val1115 e11116 e21117) (let ((ids1118 id1114)) (if (not (valid-bound-ids?138 ids1118)) (syntax-violation (quote letrec) "duplicate bound variable" e1106) (let ((labels1120 (gen-labels119 ids1118)) (new-vars1121 (map gen-var161 ids1118))) (let ((w1122 (make-binding-wrap130 ids1118 labels1120 w1108)) (r1123 (extend-var-env108 labels1120 new-vars1121 r1107))) (build-letrec95 s1109 (map syntax->datum ids1118) new-vars1121 (map (lambda (x1124) (chi149 x1124 r1123 w1122 mod1110)) val1115) (chi-body153 (cons e11116 e21117) (source-wrap142 e1106 w1122 s1109 mod1110) r1123 w1122 mod1110))))))) tmp1112) ((lambda (_1127) (syntax-violation (quote letrec) "bad letrec" (source-wrap142 e1106 w1108 s1109 mod1110))) tmp1111))) ($sc-dispatch tmp1111 (quote (any #(each (any any)) any . each-any))))) e1106))) (global-extend111 (quote core) (quote set!) (lambda (e1128 r1129 w1130 s1131 mod1132) ((lambda (tmp1133) ((lambda (tmp1134) (if (if tmp1134 (apply (lambda (_1135 id1136 val1137) (id?113 id1136)) tmp1134) #f) (apply (lambda (_1138 id1139 val1140) (let ((val1141 (chi149 val1140 r1129 w1130 mod1132)) (n1142 (id-var-name135 id1139 w1130))) (let ((b1143 (lookup110 n1142 r1129 mod1132))) (let ((atom-key1144 (binding-type105 b1143))) (if (memv atom-key1144 (quote (lexical))) (build-lexical-assignment84 s1131 (syntax->datum id1139) (binding-value106 b1143) val1141) (if (memv atom-key1144 (quote (global))) (build-global-assignment87 s1131 n1142 val1141 mod1132) (if (memv atom-key1144 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap141 id1139 w1130 mod1132)) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))))))))) tmp1134) ((lambda (tmp1145) (if tmp1145 (apply (lambda (_1146 head1147 tail1148 val1149) (call-with-values (lambda () (syntax-type147 head1147 r1129 (quote (())) #f #f mod1132)) (lambda (type1150 value1151 ee1152 ww1153 ss1154 modmod1155) (if (memv type1150 (quote (module-ref))) (let ((val1156 (chi149 val1149 r1129 w1130 mod1132))) (call-with-values (lambda () (value1151 (cons head1147 tail1148))) (lambda (id1158 mod1159) (build-global-assignment87 s1131 id1158 val1156 mod1159)))) (build-application81 s1131 (chi149 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1147) r1129 w1130 mod1132) (map (lambda (e1160) (chi149 e1160 r1129 w1130 mod1132)) (append tail1148 (list val1149)))))))) tmp1145) ((lambda (_1162) (syntax-violation (quote set!) "bad set!" (source-wrap142 e1128 w1130 s1131 mod1132))) tmp1133))) ($sc-dispatch tmp1133 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1133 (quote (any any any))))) e1128))) (global-extend111 (quote module-ref) (quote @) (lambda (e1163) ((lambda (tmp1164) ((lambda (tmp1165) (if (if tmp1165 (apply (lambda (_1166 mod1167 id1168) (if (and-map id?113 mod1167) (id?113 id1168) #f)) tmp1165) #f) (apply (lambda (_1170 mod1171 id1172) (values (syntax->datum id1172) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1171)))) tmp1165) (syntax-violation #f "source expression failed to match any pattern" tmp1164))) ($sc-dispatch tmp1164 (quote (any each-any any))))) e1163))) (global-extend111 (quote module-ref) (quote @@) (lambda (e1174) ((lambda (tmp1175) ((lambda (tmp1176) (if (if tmp1176 (apply (lambda (_1177 mod1178 id1179) (if (and-map id?113 mod1178) (id?113 id1179) #f)) tmp1176) #f) (apply (lambda (_1181 mod1182 id1183) (values (syntax->datum id1183) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1182)))) tmp1176) (syntax-violation #f "source expression failed to match any pattern" tmp1175))) ($sc-dispatch tmp1175 (quote (any each-any any))))) e1174))) (global-extend111 (quote core) (quote if) (lambda (e1185 r1186 w1187 s1188 mod1189) ((lambda (tmp1190) ((lambda (tmp1191) (if tmp1191 (apply (lambda (_1192 test1193 then1194) (build-conditional82 s1188 (chi149 test1193 r1186 w1187 mod1189) (chi149 then1194 r1186 w1187 mod1189) (build-void80 #f))) tmp1191) ((lambda (tmp1195) (if tmp1195 (apply (lambda (_1196 test1197 then1198 else1199) (build-conditional82 s1188 (chi149 test1197 r1186 w1187 mod1189) (chi149 then1198 r1186 w1187 mod1189) (chi149 else1199 r1186 w1187 mod1189))) tmp1195) (syntax-violation #f "source expression failed to match any pattern" tmp1190))) ($sc-dispatch tmp1190 (quote (any any any any)))))) ($sc-dispatch tmp1190 (quote (any any any))))) e1185))) (global-extend111 (quote begin) (quote begin) (quote ())) (global-extend111 (quote define) (quote define) (quote ())) (global-extend111 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend111 (quote eval-when) (quote eval-when) (quote ())) (global-extend111 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1203 (lambda (x1204 keys1205 clauses1206 r1207 mod1208) (if (null? clauses1206) (build-application81 #f (build-primref90 #f (quote syntax-violation)) (list (build-data91 #f #f) (build-data91 #f "source expression failed to match any pattern") x1204)) ((lambda (tmp1209) ((lambda (tmp1210) (if tmp1210 (apply (lambda (pat1211 exp1212) (if (if (id?113 pat1211) (and-map (lambda (x1213) (not (free-id=?136 pat1211 x1213))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1205)) #f) (let ((labels1214 (list (gen-label118))) (var1215 (gen-var161 pat1211))) (build-application81 #f (build-lambda89 #f (list (syntax->datum pat1211)) (list var1215) #f (chi149 exp1212 (extend-env107 labels1214 (list (cons (quote syntax) (cons var1215 0))) r1207) (make-binding-wrap130 (list pat1211) labels1214 (quote (()))) mod1208)) (list x1204))) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1211 #t exp1212 mod1208))) tmp1210) ((lambda (tmp1216) (if tmp1216 (apply (lambda (pat1217 fender1218 exp1219) (gen-clause1202 x1204 keys1205 (cdr clauses1206) r1207 pat1217 fender1218 exp1219 mod1208)) tmp1216) ((lambda (_1220) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1206))) tmp1209))) ($sc-dispatch tmp1209 (quote (any any any)))))) ($sc-dispatch tmp1209 (quote (any any))))) (car clauses1206))))) (gen-clause1202 (lambda (x1221 keys1222 clauses1223 r1224 pat1225 fender1226 exp1227 mod1228) (call-with-values (lambda () (convert-pattern1200 pat1225 keys1222)) (lambda (p1229 pvars1230) (if (not (distinct-bound-ids?139 (map car pvars1230))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1225) (if (not (and-map (lambda (x1231) (not (ellipsis?158 (car x1231)))) pvars1230)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1225) (let ((y1232 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda89 #f (list (quote tmp)) (list y1232) #f (let ((y1233 (build-lexical-reference83 (quote value) #f (quote tmp) y1232))) (build-conditional82 #f ((lambda (tmp1234) ((lambda (tmp1235) (if tmp1235 (apply (lambda () y1233) tmp1235) ((lambda (_1236) (build-conditional82 #f y1233 (build-dispatch-call1201 pvars1230 fender1226 y1233 r1224 mod1228) (build-data91 #f #f))) tmp1234))) ($sc-dispatch tmp1234 (quote #(atom #t))))) fender1226) (build-dispatch-call1201 pvars1230 exp1227 y1233 r1224 mod1228) (gen-syntax-case1203 x1221 keys1222 clauses1223 r1224 mod1228)))) (list (if (eq? p1229 (quote any)) (build-application81 #f (build-primref90 #f (quote list)) (list x1221)) (build-application81 #f (build-primref90 #f (quote $sc-dispatch)) (list x1221 (build-data91 #f p1229))))))))))))) (build-dispatch-call1201 (lambda (pvars1237 exp1238 y1239 r1240 mod1241) (let ((ids1242 (map car pvars1237)) (levels1243 (map cdr pvars1237))) (let ((labels1244 (gen-labels119 ids1242)) (new-vars1245 (map gen-var161 ids1242))) (build-application81 #f (build-primref90 #f (quote apply)) (list (build-lambda89 #f (map syntax->datum ids1242) new-vars1245 #f (chi149 exp1238 (extend-env107 labels1244 (map (lambda (var1246 level1247) (cons (quote syntax) (cons var1246 level1247))) new-vars1245 (map cdr pvars1237)) r1240) (make-binding-wrap130 ids1242 labels1244 (quote (()))) mod1241)) y1239)))))) (convert-pattern1200 (lambda (pattern1248 keys1249) (letrec ((cvt1250 (lambda (p1251 n1252 ids1253) (if (id?113 p1251) (if (bound-id-member?140 p1251 keys1249) (values (vector (quote free-id) p1251) ids1253) (values (quote any) (cons (cons p1251 n1252) ids1253))) ((lambda (tmp1254) ((lambda (tmp1255) (if (if tmp1255 (apply (lambda (x1256 dots1257) (ellipsis?158 dots1257)) tmp1255) #f) (apply (lambda (x1258 dots1259) (call-with-values (lambda () (cvt1250 x1258 (fx+72 n1252 1) ids1253)) (lambda (p1260 ids1261) (values (if (eq? p1260 (quote any)) (quote each-any) (vector (quote each) p1260)) ids1261)))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda (x1263 y1264) (call-with-values (lambda () (cvt1250 y1264 n1252 ids1253)) (lambda (y1265 ids1266) (call-with-values (lambda () (cvt1250 x1263 n1252 ids1266)) (lambda (x1267 ids1268) (values (cons x1267 y1265) ids1268)))))) tmp1262) ((lambda (tmp1269) (if tmp1269 (apply (lambda () (values (quote ()) ids1253)) tmp1269) ((lambda (tmp1270) (if tmp1270 (apply (lambda (x1271) (call-with-values (lambda () (cvt1250 x1271 n1252 ids1253)) (lambda (p1273 ids1274) (values (vector (quote vector) p1273) ids1274)))) tmp1270) ((lambda (x1275) (values (vector (quote atom) (strip160 p1251 (quote (())))) ids1253)) tmp1254))) ($sc-dispatch tmp1254 (quote #(vector each-any)))))) ($sc-dispatch tmp1254 (quote ()))))) ($sc-dispatch tmp1254 (quote (any . any)))))) ($sc-dispatch tmp1254 (quote (any any))))) p1251))))) (cvt1250 pattern1248 0 (quote ())))))) (lambda (e1276 r1277 w1278 s1279 mod1280) (let ((e1281 (source-wrap142 e1276 w1278 s1279 mod1280))) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (_1284 val1285 key1286 m1287) (if (and-map (lambda (x1288) (if (id?113 x1288) (not (ellipsis?158 x1288)) #f)) key1286) (let ((x1290 (gen-var161 (quote tmp)))) (build-application81 s1279 (build-lambda89 #f (list (quote tmp)) (list x1290) #f (gen-syntax-case1203 (build-lexical-reference83 (quote value) #f (quote tmp) x1290) key1286 m1287 r1277 mod1280)) (list (chi149 val1285 r1277 (quote (())) mod1280)))) (syntax-violation (quote syntax-case) "invalid literals list" e1281))) tmp1283) (syntax-violation #f "source expression failed to match any pattern" tmp1282))) ($sc-dispatch tmp1282 (quote (any any each-any . each-any))))) e1281))))) (set! sc-expand (lambda (x1294 . rest1293) (if (if (pair? x1294) (equal? (car x1294) noexpand70) #f) (cadr x1294) (let ((m1295 (if (null? rest1293) (quote e) (car rest1293))) (esew1296 (if (let ((t1297 (null? rest1293))) (if t1297 t1297 (null? (cdr rest1293)))) (quote (eval)) (cadr rest1293)))) (with-fluid* *mode*71 m1295 (lambda () (chi-top148 x1294 (quote ()) (quote ((top))) m1295 esew1296 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1298) (nonsymbol-id?112 x1298))) (set! datum->syntax (lambda (id1299 datum1300) (make-syntax-object96 datum1300 (syntax-object-wrap99 id1299) #f))) (set! syntax->datum (lambda (x1301) (strip160 x1301 (quote (()))))) (set! generate-temporaries (lambda (ls1302) (begin (let ((x1303 ls1302)) (if (not (list? x1303)) (syntax-violation (quote generate-temporaries) "invalid argument" x1303))) (map (lambda (x1304) (wrap141 (gensym) (quote ((top))) #f)) ls1302)))) (set! free-identifier=? (lambda (x1305 y1306) (begin (let ((x1307 x1305)) (if (not (nonsymbol-id?112 x1307)) (syntax-violation (quote free-identifier=?) "invalid argument" x1307))) (let ((x1308 y1306)) (if (not (nonsymbol-id?112 x1308)) (syntax-violation (quote free-identifier=?) "invalid argument" x1308))) (free-id=?136 x1305 y1306)))) (set! bound-identifier=? (lambda (x1309 y1310) (begin (let ((x1311 x1309)) (if (not (nonsymbol-id?112 x1311)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1311))) (let ((x1312 y1310)) (if (not (nonsymbol-id?112 x1312)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1312))) (bound-id=?137 x1309 y1310)))) (set! syntax-violation (lambda (who1316 message1315 form1314 . subform1313) (begin (let ((x1317 who1316)) (if (not ((lambda (x1318) (let ((t1319 (not x1318))) (if t1319 t1319 (let ((t1320 (string? x1318))) (if t1320 t1320 (symbol? x1318)))))) x1317)) (syntax-violation (quote syntax-violation) "invalid argument" x1317))) (let ((x1321 message1315)) (if (not (string? x1321)) (syntax-violation (quote syntax-violation) "invalid argument" x1321))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1316 "~a: " "") "~a " (if (null? subform1313) "in ~a" "in subform `~s' of `~s'")) (let ((tail1322 (cons message1315 (map (lambda (x1323) (strip160 x1323 (quote (())))) (append subform1313 (list form1314)))))) (if who1316 (cons who1316 tail1322) tail1322)) #f)))) (letrec ((match1328 (lambda (e1329 p1330 w1331 r1332 mod1333) (if (not r1332) #f (if (eq? p1330 (quote any)) (cons (wrap141 e1329 w1331 mod1333) r1332) (if (syntax-object?97 e1329) (match*1327 (let ((e1334 (syntax-object-expression98 e1329))) (if (annotation? e1334) (annotation-expression e1334) e1334)) p1330 (join-wraps132 w1331 (syntax-object-wrap99 e1329)) r1332 (syntax-object-module100 e1329)) (match*1327 (let ((e1335 e1329)) (if (annotation? e1335) (annotation-expression e1335) e1335)) p1330 w1331 r1332 mod1333)))))) (match*1327 (lambda (e1336 p1337 w1338 r1339 mod1340) (if (null? p1337) (if (null? e1336) r1339 #f) (if (pair? p1337) (if (pair? e1336) (match1328 (car e1336) (car p1337) w1338 (match1328 (cdr e1336) (cdr p1337) w1338 r1339 mod1340) mod1340) #f) (if (eq? p1337 (quote each-any)) (let ((l1341 (match-each-any1325 e1336 w1338 mod1340))) (if l1341 (cons l1341 r1339) #f)) (let ((atom-key1342 (vector-ref p1337 0))) (if (memv atom-key1342 (quote (each))) (if (null? e1336) (match-empty1326 (vector-ref p1337 1) r1339) (let ((l1343 (match-each1324 e1336 (vector-ref p1337 1) w1338 mod1340))) (if l1343 (letrec ((collect1344 (lambda (l1345) (if (null? (car l1345)) r1339 (cons (map car l1345) (collect1344 (map cdr l1345))))))) (collect1344 l1343)) #f))) (if (memv atom-key1342 (quote (free-id))) (if (id?113 e1336) (if (free-id=?136 (wrap141 e1336 w1338 mod1340) (vector-ref p1337 1)) r1339 #f) #f) (if (memv atom-key1342 (quote (atom))) (if (equal? (vector-ref p1337 1) (strip160 e1336 w1338)) r1339 #f) (if (memv atom-key1342 (quote (vector))) (if (vector? e1336) (match1328 (vector->list e1336) (vector-ref p1337 1) w1338 r1339 mod1340) #f))))))))))) (match-empty1326 (lambda (p1346 r1347) (if (null? p1346) r1347 (if (eq? p1346 (quote any)) (cons (quote ()) r1347) (if (pair? p1346) (match-empty1326 (car p1346) (match-empty1326 (cdr p1346) r1347)) (if (eq? p1346 (quote each-any)) (cons (quote ()) r1347) (let ((atom-key1348 (vector-ref p1346 0))) (if (memv atom-key1348 (quote (each))) (match-empty1326 (vector-ref p1346 1) r1347) (if (memv atom-key1348 (quote (free-id atom))) r1347 (if (memv atom-key1348 (quote (vector))) (match-empty1326 (vector-ref p1346 1) r1347))))))))))) (match-each-any1325 (lambda (e1349 w1350 mod1351) (if (annotation? e1349) (match-each-any1325 (annotation-expression e1349) w1350 mod1351) (if (pair? e1349) (let ((l1352 (match-each-any1325 (cdr e1349) w1350 mod1351))) (if l1352 (cons (wrap141 (car e1349) w1350 mod1351) l1352) #f)) (if (null? e1349) (quote ()) (if (syntax-object?97 e1349) (match-each-any1325 (syntax-object-expression98 e1349) (join-wraps132 w1350 (syntax-object-wrap99 e1349)) mod1351) #f)))))) (match-each1324 (lambda (e1353 p1354 w1355 mod1356) (if (annotation? e1353) (match-each1324 (annotation-expression e1353) p1354 w1355 mod1356) (if (pair? e1353) (let ((first1357 (match1328 (car e1353) p1354 w1355 (quote ()) mod1356))) (if first1357 (let ((rest1358 (match-each1324 (cdr e1353) p1354 w1355 mod1356))) (if rest1358 (cons first1357 rest1358) #f)) #f)) (if (null? e1353) (quote ()) (if (syntax-object?97 e1353) (match-each1324 (syntax-object-expression98 e1353) p1354 (join-wraps132 w1355 (syntax-object-wrap99 e1353)) (syntax-object-module100 e1353)) #f))))))) (set! $sc-dispatch (lambda (e1359 p1360) (if (eq? p1360 (quote any)) (list e1359) (if (syntax-object?97 e1359) (match*1327 (let ((e1361 (syntax-object-expression98 e1359))) (if (annotation? e1361) (annotation-expression e1361) e1361)) p1360 (syntax-object-wrap99 e1359) (quote ()) (syntax-object-module100 e1359)) (match*1327 (let ((e1362 e1359)) (if (annotation? e1362) (annotation-expression e1362) e1362)) p1360 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1363) ((lambda (tmp1364) ((lambda (tmp1365) (if tmp1365 (apply (lambda (_1366 e11367 e21368) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11367 e21368))) tmp1365) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 out1372 in1373 e11374 e21375) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1373 (quote ()) (list out1372 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11374 e21375))))) tmp1370) ((lambda (tmp1377) (if tmp1377 (apply (lambda (_1378 out1379 in1380 e11381 e21382) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1380) (quote ()) (list out1379 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11381 e21382))))) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1364))) ($sc-dispatch tmp1364 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1364 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1364 (quote (any () any . each-any))))) x1363)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1386) ((lambda (tmp1387) ((lambda (tmp1388) (if tmp1388 (apply (lambda (_1389 k1390 keyword1391 pattern1392 template1393) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1390 (map (lambda (tmp1396 tmp1395) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1395) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1396))) template1393 pattern1392)))))) tmp1388) (syntax-violation #f "source expression failed to match any pattern" tmp1387))) ($sc-dispatch tmp1387 (quote (any each-any . #(each ((any . any) any))))))) x1386)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1397) ((lambda (tmp1398) ((lambda (tmp1399) (if (if tmp1399 (apply (lambda (let*1400 x1401 v1402 e11403 e21404) (and-map identifier? x1401)) tmp1399) #f) (apply (lambda (let*1406 x1407 v1408 e11409 e21410) (letrec ((f1411 (lambda (bindings1412) (if (null? bindings1412) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11409 e21410))) ((lambda (tmp1416) ((lambda (tmp1417) (if tmp1417 (apply (lambda (body1418 binding1419) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1419) body1418)) tmp1417) (syntax-violation #f "source expression failed to match any pattern" tmp1416))) ($sc-dispatch tmp1416 (quote (any any))))) (list (f1411 (cdr bindings1412)) (car bindings1412))))))) (f1411 (map list x1407 v1408)))) tmp1399) (syntax-violation #f "source expression failed to match any pattern" tmp1398))) ($sc-dispatch tmp1398 (quote (any #(each (any any)) any . each-any))))) x1397)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1420) ((lambda (tmp1421) ((lambda (tmp1422) (if tmp1422 (apply (lambda (_1423 var1424 init1425 step1426 e01427 e11428 c1429) ((lambda (tmp1430) ((lambda (tmp1431) (if tmp1431 (apply (lambda (step1432) ((lambda (tmp1433) ((lambda (tmp1434) (if tmp1434 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1424 init1425) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01427) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1429 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1432))))))) tmp1434) ((lambda (tmp1439) (if tmp1439 (apply (lambda (e11440 e21441) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1424 init1425) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01427 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11440 e21441)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1429 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1432))))))) tmp1439) (syntax-violation #f "source expression failed to match any pattern" tmp1433))) ($sc-dispatch tmp1433 (quote (any . each-any)))))) ($sc-dispatch tmp1433 (quote ())))) e11428)) tmp1431) (syntax-violation #f "source expression failed to match any pattern" tmp1430))) ($sc-dispatch tmp1430 (quote each-any)))) (map (lambda (v1448 s1449) ((lambda (tmp1450) ((lambda (tmp1451) (if tmp1451 (apply (lambda () v1448) tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda (e1453) e1453) tmp1452) ((lambda (_1454) (syntax-violation (quote do) "bad step expression" orig-x1420 s1449)) tmp1450))) ($sc-dispatch tmp1450 (quote (any)))))) ($sc-dispatch tmp1450 (quote ())))) s1449)) var1424 step1426))) tmp1422) (syntax-violation #f "source expression failed to match any pattern" tmp1421))) ($sc-dispatch tmp1421 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1420)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1457 (lambda (x1461 y1462) ((lambda (tmp1463) ((lambda (tmp1464) (if tmp1464 (apply (lambda (x1465 y1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda (dy1469) ((lambda (tmp1470) ((lambda (tmp1471) (if tmp1471 (apply (lambda (dx1472) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1472 dy1469))) tmp1471) ((lambda (_1473) (if (null? dy1469) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465 y1466))) tmp1470))) ($sc-dispatch tmp1470 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1465)) tmp1468) ((lambda (tmp1474) (if tmp1474 (apply (lambda (stuff1475) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1465 stuff1475))) tmp1474) ((lambda (else1476) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465 y1466)) tmp1467))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1466)) tmp1464) (syntax-violation #f "source expression failed to match any pattern" tmp1463))) ($sc-dispatch tmp1463 (quote (any any))))) (list x1461 y1462)))) (quasiappend1458 (lambda (x1477 y1478) ((lambda (tmp1479) ((lambda (tmp1480) (if tmp1480 (apply (lambda (x1481 y1482) ((lambda (tmp1483) ((lambda (tmp1484) (if tmp1484 (apply (lambda () x1481) tmp1484) ((lambda (_1485) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1481 y1482)) tmp1483))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1482)) tmp1480) (syntax-violation #f "source expression failed to match any pattern" tmp1479))) ($sc-dispatch tmp1479 (quote (any any))))) (list x1477 y1478)))) (quasivector1459 (lambda (x1486) ((lambda (tmp1487) ((lambda (x1488) ((lambda (tmp1489) ((lambda (tmp1490) (if tmp1490 (apply (lambda (x1491) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1491))) tmp1490) ((lambda (tmp1493) (if tmp1493 (apply (lambda (x1494) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1494)) tmp1493) ((lambda (_1496) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1488)) tmp1489))) ($sc-dispatch tmp1489 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1489 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1488)) tmp1487)) x1486))) (quasi1460 (lambda (p1497 lev1498) ((lambda (tmp1499) ((lambda (tmp1500) (if tmp1500 (apply (lambda (p1501) (if (= lev1498 0) p1501 (quasicons1457 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1460 (list p1501) (- lev1498 1))))) tmp1500) ((lambda (tmp1502) (if (if tmp1502 (apply (lambda (args1503) (= lev1498 0)) tmp1502) #f) (apply (lambda (args1504) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1497 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1504))) tmp1502) ((lambda (tmp1505) (if tmp1505 (apply (lambda (p1506 q1507) (if (= lev1498 0) (quasiappend1458 p1506 (quasi1460 q1507 lev1498)) (quasicons1457 (quasicons1457 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1460 (list p1506) (- lev1498 1))) (quasi1460 q1507 lev1498)))) tmp1505) ((lambda (tmp1508) (if (if tmp1508 (apply (lambda (args1509 q1510) (= lev1498 0)) tmp1508) #f) (apply (lambda (args1511 q1512) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1497 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1511))) tmp1508) ((lambda (tmp1513) (if tmp1513 (apply (lambda (p1514) (quasicons1457 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1460 (list p1514) (+ lev1498 1)))) tmp1513) ((lambda (tmp1515) (if tmp1515 (apply (lambda (p1516 q1517) (quasicons1457 (quasi1460 p1516 lev1498) (quasi1460 q1517 lev1498))) tmp1515) ((lambda (tmp1518) (if tmp1518 (apply (lambda (x1519) (quasivector1459 (quasi1460 x1519 lev1498))) tmp1518) ((lambda (p1521) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1521)) tmp1499))) ($sc-dispatch tmp1499 (quote #(vector each-any)))))) ($sc-dispatch tmp1499 (quote (any . any)))))) ($sc-dispatch tmp1499 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1499 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1499 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1499 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1499 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1497)))) (lambda (x1522) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (_1525 e1526) (quasi1460 e1526 0)) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote (any any))))) x1522))))) -(define include (make-syncase-macro (quote macro) (lambda (x1527) (letrec ((read-file1528 (lambda (fn1529 k1530) (let ((p1531 (open-input-file fn1529))) (letrec ((f1532 (lambda (x1533) (if (eof-object? x1533) (begin (close-input-port p1531) (quote ())) (cons (datum->syntax k1530 x1533) (f1532 (read p1531))))))) (f1532 (read p1531))))))) ((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (k1536 filename1537) (let ((fn1538 (syntax->datum filename1537))) ((lambda (tmp1539) ((lambda (tmp1540) (if tmp1540 (apply (lambda (exp1541) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1541)) tmp1540) (syntax-violation #f "source expression failed to match any pattern" tmp1539))) ($sc-dispatch tmp1539 (quote each-any)))) (read-file1528 fn1538 k1536)))) tmp1535) (syntax-violation #f "source expression failed to match any pattern" tmp1534))) ($sc-dispatch tmp1534 (quote (any any))))) x1527))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1543) ((lambda (tmp1544) ((lambda (tmp1545) (if tmp1545 (apply (lambda (_1546 e1547) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1543)) tmp1545) (syntax-violation #f "source expression failed to match any pattern" tmp1544))) ($sc-dispatch tmp1544 (quote (any any))))) x1543)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1548) ((lambda (tmp1549) ((lambda (tmp1550) (if tmp1550 (apply (lambda (_1551 e1552) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1548)) tmp1550) (syntax-violation #f "source expression failed to match any pattern" tmp1549))) ($sc-dispatch tmp1549 (quote (any any))))) x1548)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1553) ((lambda (tmp1554) ((lambda (tmp1555) (if tmp1555 (apply (lambda (_1556 e1557 m11558 m21559) ((lambda (tmp1560) ((lambda (body1561) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1557)) body1561)) tmp1560)) (letrec ((f1562 (lambda (clause1563 clauses1564) (if (null? clauses1564) ((lambda (tmp1566) ((lambda (tmp1567) (if tmp1567 (apply (lambda (e11568 e21569) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11568 e21569))) tmp1567) ((lambda (tmp1571) (if tmp1571 (apply (lambda (k1572 e11573 e21574) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1572)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11573 e21574)))) tmp1571) ((lambda (_1577) (syntax-violation (quote case) "bad clause" x1553 clause1563)) tmp1566))) ($sc-dispatch tmp1566 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1566 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1563) ((lambda (tmp1578) ((lambda (rest1579) ((lambda (tmp1580) ((lambda (tmp1581) (if tmp1581 (apply (lambda (k1582 e11583 e21584) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1582)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11583 e21584)) rest1579)) tmp1581) ((lambda (_1587) (syntax-violation (quote case) "bad clause" x1553 clause1563)) tmp1580))) ($sc-dispatch tmp1580 (quote (each-any any . each-any))))) clause1563)) tmp1578)) (f1562 (car clauses1564) (cdr clauses1564))))))) (f1562 m11558 m21559)))) tmp1555) (syntax-violation #f "source expression failed to match any pattern" tmp1554))) ($sc-dispatch tmp1554 (quote (any any any . each-any))))) x1553)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1588) ((lambda (tmp1589) ((lambda (tmp1590) (if tmp1590 (apply (lambda (_1591 e1592) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1592)) (list (cons _1591 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1592 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1590) (syntax-violation #f "source expression failed to match any pattern" tmp1589))) ($sc-dispatch tmp1589 (quote (any any))))) x1588)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list163 (lambda (vars292) (letrec ((lvl293 (lambda (vars294 ls295 w296) (if (pair? vars294) (lvl293 (cdr vars294) (cons (wrap142 (car vars294) w296 #f) ls295) w296) (if (id?114 vars294) (cons (wrap142 vars294 w296 #f) ls295) (if (null? vars294) ls295 (if (syntax-object?98 vars294) (lvl293 (syntax-object-expression99 vars294) ls295 (join-wraps133 w296 (syntax-object-wrap100 vars294))) (if (annotation? vars294) (lvl293 (annotation-expression vars294) ls295 w296) (cons vars294 ls295))))))))) (lvl293 vars292 (quote ()) (quote (())))))) (gen-var162 (lambda (id297) (let ((id298 (if (syntax-object?98 id297) (syntax-object-expression99 id297) id297))) (if (annotation? id298) (gensym (symbol->string (annotation-expression id298))) (gensym (symbol->string id298)))))) (strip161 (lambda (x299 w300) (if (memq (quote top) (wrap-marks117 w300)) (if (let ((t301 (annotation? x299))) (if t301 t301 (if (pair? x299) (annotation? (car x299)) #f))) (strip-annotation160 x299 #f) x299) (letrec ((f302 (lambda (x303) (if (syntax-object?98 x303) (strip161 (syntax-object-expression99 x303) (syntax-object-wrap100 x303)) (if (pair? x303) (let ((a304 (f302 (car x303))) (d305 (f302 (cdr x303)))) (if (if (eq? a304 (car x303)) (eq? d305 (cdr x303)) #f) x303 (cons a304 d305))) (if (vector? x303) (let ((old306 (vector->list x303))) (let ((new307 (map f302 old306))) (if (and-map*17 eq? old306 new307) x303 (list->vector new307)))) x303)))))) (f302 x299))))) (strip-annotation160 (lambda (x308 parent309) (if (pair? x308) (let ((new310 (cons #f #f))) (begin (if parent309 (set-annotation-stripped! parent309 new310)) (set-car! new310 (strip-annotation160 (car x308) #f)) (set-cdr! new310 (strip-annotation160 (cdr x308) #f)) new310)) (if (annotation? x308) (let ((t311 (annotation-stripped x308))) (if t311 t311 (strip-annotation160 (annotation-expression x308) x308))) (if (vector? x308) (let ((new312 (make-vector (vector-length x308)))) (begin (if parent309 (set-annotation-stripped! parent309 new312)) (letrec ((loop313 (lambda (i314) (unless (fx<75 i314 0) (vector-set! new312 i314 (strip-annotation160 (vector-ref x308 i314) #f)) (loop313 (fx-73 i314 1)))))) (loop313 (- (vector-length x308) 1))) new312)) x308))))) (ellipsis?159 (lambda (x315) (if (nonsymbol-id?113 x315) (free-id=?137 x315 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded316 mod317) (let ((p318 (local-eval-hook77 expanded316 mod317))) (if (procedure? p318) p318 (syntax-violation #f "nonprocedure transformer" p318))))) (chi-local-syntax156 (lambda (rec?319 e320 r321 w322 s323 mod324 k325) ((lambda (tmp326) ((lambda (tmp327) (if tmp327 (apply (lambda (_328 id329 val330 e1331 e2332) (let ((ids333 id329)) (if (not (valid-bound-ids?139 ids333)) (syntax-violation #f "duplicate bound keyword" e320) (let ((labels335 (gen-labels120 ids333))) (let ((new-w336 (make-binding-wrap131 ids333 labels335 w322))) (k325 (cons e1331 e2332) (extend-env108 labels335 (let ((w338 (if rec?319 new-w336 w322)) (trans-r339 (macros-only-env110 r321))) (map (lambda (x340) (cons (quote macro) (eval-local-transformer157 (chi150 x340 trans-r339 w338 mod324) mod324))) val330)) r321) new-w336 s323 mod324)))))) tmp327) ((lambda (_342) (syntax-violation #f "bad local syntax definition" (source-wrap143 e320 w322 s323 mod324))) tmp326))) ($sc-dispatch tmp326 (quote (any #(each (any any)) any . each-any))))) e320))) (chi-lambda-clause155 (lambda (e343 docstring344 c345 r346 w347 mod348 k349) ((lambda (tmp350) ((lambda (tmp351) (if (if tmp351 (apply (lambda (args352 doc353 e1354 e2355) (if (string? (syntax->datum doc353)) (not docstring344) #f)) tmp351) #f) (apply (lambda (args356 doc357 e1358 e2359) (chi-lambda-clause155 e343 doc357 (cons args356 (cons e1358 e2359)) r346 w347 mod348 k349)) tmp351) ((lambda (tmp361) (if tmp361 (apply (lambda (id362 e1363 e2364) (let ((ids365 id362)) (if (not (valid-bound-ids?139 ids365)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels367 (gen-labels120 ids365)) (new-vars368 (map gen-var162 ids365))) (k349 (map syntax->datum ids365) new-vars368 (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1363 e2364) e343 (extend-var-env109 labels367 new-vars368 r346) (make-binding-wrap131 ids365 labels367 w347) mod348)))))) tmp361) ((lambda (tmp370) (if tmp370 (apply (lambda (ids371 e1372 e2373) (let ((old-ids374 (lambda-var-list163 ids371))) (if (not (valid-bound-ids?139 old-ids374)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels375 (gen-labels120 old-ids374)) (new-vars376 (map gen-var162 old-ids374))) (k349 (letrec ((f377 (lambda (ls1378 ls2379) (if (null? ls1378) (syntax->datum ls2379) (f377 (cdr ls1378) (cons (syntax->datum (car ls1378)) ls2379)))))) (f377 (cdr old-ids374) (car old-ids374))) (letrec ((f380 (lambda (ls1381 ls2382) (if (null? ls1381) ls2382 (f380 (cdr ls1381) (cons (car ls1381) ls2382)))))) (f380 (cdr new-vars376) (car new-vars376))) (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1372 e2373) e343 (extend-var-env109 labels375 new-vars376 r346) (make-binding-wrap131 old-ids374 labels375 w347) mod348)))))) tmp370) ((lambda (_384) (syntax-violation (quote lambda) "bad lambda" e343)) tmp350))) ($sc-dispatch tmp350 (quote (any any . each-any)))))) ($sc-dispatch tmp350 (quote (each-any any . each-any)))))) ($sc-dispatch tmp350 (quote (any any any . each-any))))) c345))) (chi-body154 (lambda (body385 outer-form386 r387 w388 mod389) (let ((r390 (cons (quote ("placeholder" placeholder)) r387))) (let ((ribcage391 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w392 (make-wrap116 (wrap-marks117 w388) (cons ribcage391 (wrap-subst118 w388))))) (letrec ((parse393 (lambda (body394 ids395 labels396 vars397 vals398 bindings399) (if (null? body394) (syntax-violation #f "no expressions in body" outer-form386) (let ((e401 (cdar body394)) (er402 (caar body394))) (call-with-values (lambda () (syntax-type148 e401 er402 (quote (())) #f ribcage391 mod389)) (lambda (type403 value404 e405 w406 s407 mod408) (if (memv type403 (quote (define-form))) (let ((id409 (wrap142 value404 w406 mod408)) (label410 (gen-label119))) (let ((var411 (gen-var162 id409))) (begin (extend-ribcage!130 ribcage391 id409 label410) (parse393 (cdr body394) (cons id409 ids395) (cons label410 labels396) (cons var411 vars397) (cons (cons er402 (wrap142 e405 w406 mod408)) vals398) (cons (cons (quote lexical) var411) bindings399))))) (if (memv type403 (quote (define-syntax-form))) (let ((id412 (wrap142 value404 w406 mod408)) (label413 (gen-label119))) (begin (extend-ribcage!130 ribcage391 id412 label413) (parse393 (cdr body394) (cons id412 ids395) (cons label413 labels396) vars397 vals398 (cons (cons (quote macro) (cons er402 (wrap142 e405 w406 mod408))) bindings399)))) (if (memv type403 (quote (begin-form))) ((lambda (tmp414) ((lambda (tmp415) (if tmp415 (apply (lambda (_416 e1417) (parse393 (letrec ((f418 (lambda (forms419) (if (null? forms419) (cdr body394) (cons (cons er402 (wrap142 (car forms419) w406 mod408)) (f418 (cdr forms419))))))) (f418 e1417)) ids395 labels396 vars397 vals398 bindings399)) tmp415) (syntax-violation #f "source expression failed to match any pattern" tmp414))) ($sc-dispatch tmp414 (quote (any . each-any))))) e405) (if (memv type403 (quote (local-syntax-form))) (chi-local-syntax156 value404 e405 er402 w406 s407 mod408 (lambda (forms421 er422 w423 s424 mod425) (parse393 (letrec ((f426 (lambda (forms427) (if (null? forms427) (cdr body394) (cons (cons er422 (wrap142 (car forms427) w423 mod425)) (f426 (cdr forms427))))))) (f426 forms421)) ids395 labels396 vars397 vals398 bindings399))) (if (null? ids395) (build-sequence93 #f (map (lambda (x428) (chi150 (cdr x428) (car x428) (quote (())) mod408)) (cons (cons er402 (source-wrap143 e405 w406 s407 mod408)) (cdr body394)))) (begin (if (not (valid-bound-ids?139 ids395)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form386)) (letrec ((loop429 (lambda (bs430 er-cache431 r-cache432) (if (not (null? bs430)) (let ((b433 (car bs430))) (if (eq? (car b433) (quote macro)) (let ((er434 (cadr b433))) (let ((r-cache435 (if (eq? er434 er-cache431) r-cache432 (macros-only-env110 er434)))) (begin (set-cdr! b433 (eval-local-transformer157 (chi150 (cddr b433) r-cache435 (quote (())) mod408) mod408)) (loop429 (cdr bs430) er434 r-cache435)))) (loop429 (cdr bs430) er-cache431 r-cache432))))))) (loop429 bindings399 #f #f)) (set-cdr! r390 (extend-env108 labels396 bindings399 (cdr r390))) (build-letrec96 #f (map syntax->datum ids395) vars397 (map (lambda (x436) (chi150 (cdr x436) (car x436) (quote (())) mod408)) vals398) (build-sequence93 #f (map (lambda (x437) (chi150 (cdr x437) (car x437) (quote (())) mod408)) (cons (cons er402 (source-wrap143 e405 w406 s407 mod408)) (cdr body394)))))))))))))))))) (parse393 (map (lambda (x400) (cons r390 (wrap142 x400 w392 mod389))) body385) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p438 e439 r440 w441 rib442 mod443) (letrec ((rebuild-macro-output444 (lambda (x445 m446) (if (pair? x445) (cons (rebuild-macro-output444 (car x445) m446) (rebuild-macro-output444 (cdr x445) m446)) (if (syntax-object?98 x445) (let ((w447 (syntax-object-wrap100 x445))) (let ((ms448 (wrap-marks117 w447)) (s449 (wrap-subst118 w447))) (if (if (pair? ms448) (eq? (car ms448) #f) #f) (make-syntax-object97 (syntax-object-expression99 x445) (make-wrap116 (cdr ms448) (if rib442 (cons rib442 (cdr s449)) (cdr s449))) (syntax-object-module101 x445)) (make-syntax-object97 (syntax-object-expression99 x445) (make-wrap116 (cons m446 ms448) (if rib442 (cons rib442 (cons (quote shift) s449)) (cons (quote shift) s449))) (let ((pmod450 (procedure-module p438))) (if pmod450 (cons (quote hygiene) (module-name pmod450)) (quote (hygiene guile)))))))) (if (vector? x445) (let ((n451 (vector-length x445))) (let ((v452 (make-vector n451))) (letrec ((loop453 (lambda (i454) (if (fx=74 i454 n451) (begin (if #f #f) v452) (begin (vector-set! v452 i454 (rebuild-macro-output444 (vector-ref x445 i454) m446)) (loop453 (fx+72 i454 1))))))) (loop453 0)))) (if (symbol? x445) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e439 w441 s mod443) x445) x445))))))) (rebuild-macro-output444 (p438 (wrap142 e439 (anti-mark129 w441) mod443)) (string #\m))))) (chi-application152 (lambda (x455 e456 r457 w458 s459 mod460) ((lambda (tmp461) ((lambda (tmp462) (if tmp462 (apply (lambda (e0463 e1464) (build-application81 s459 x455 (map (lambda (e465) (chi150 e465 r457 w458 mod460)) e1464))) tmp462) (syntax-violation #f "source expression failed to match any pattern" tmp461))) ($sc-dispatch tmp461 (quote (any . each-any))))) e456))) (chi-expr151 (lambda (type467 value468 e469 r470 w471 s472 mod473) (if (memv type467 (quote (lexical))) (build-lexical-reference83 (quote value) s472 e469 value468) (if (memv type467 (quote (core external-macro))) (value468 e469 r470 w471 s472 mod473) (if (memv type467 (quote (module-ref))) (call-with-values (lambda () (value468 e469)) (lambda (id474 mod475) (build-global-reference86 s472 id474 mod475))) (if (memv type467 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e469)) (car e469) value468) e469 r470 w471 s472 mod473) (if (memv type467 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e469)) value468 (if (syntax-object?98 (car e469)) (syntax-object-module101 (car e469)) mod473)) e469 r470 w471 s472 mod473) (if (memv type467 (quote (constant))) (build-data92 s472 (strip161 (source-wrap143 e469 w471 s472 mod473) (quote (())))) (if (memv type467 (quote (global))) (build-global-reference86 s472 value468 mod473) (if (memv type467 (quote (call))) (chi-application152 (chi150 (car e469) r470 w471 mod473) e469 r470 w471 s472 mod473) (if (memv type467 (quote (begin-form))) ((lambda (tmp476) ((lambda (tmp477) (if tmp477 (apply (lambda (_478 e1479 e2480) (chi-sequence144 (cons e1479 e2480) r470 w471 s472 mod473)) tmp477) (syntax-violation #f "source expression failed to match any pattern" tmp476))) ($sc-dispatch tmp476 (quote (any any . each-any))))) e469) (if (memv type467 (quote (local-syntax-form))) (chi-local-syntax156 value468 e469 r470 w471 s472 mod473 chi-sequence144) (if (memv type467 (quote (eval-when-form))) ((lambda (tmp482) ((lambda (tmp483) (if tmp483 (apply (lambda (_484 x485 e1486 e2487) (let ((when-list488 (chi-when-list147 e469 x485 w471))) (if (memq (quote eval) when-list488) (chi-sequence144 (cons e1486 e2487) r470 w471 s472 mod473) (chi-void158)))) tmp483) (syntax-violation #f "source expression failed to match any pattern" tmp482))) ($sc-dispatch tmp482 (quote (any each-any any . each-any))))) e469) (if (memv type467 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e469 (wrap142 value468 w471 mod473)) (if (memv type467 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e469 w471 s472 mod473)) (if (memv type467 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e469 w471 s472 mod473)) (syntax-violation #f "unexpected syntax" (source-wrap143 e469 w471 s472 mod473)))))))))))))))))) (chi150 (lambda (e491 r492 w493 mod494) (call-with-values (lambda () (syntax-type148 e491 r492 w493 #f #f mod494)) (lambda (type495 value496 e497 w498 s499 mod500) (chi-expr151 type495 value496 e497 r492 w498 s499 mod500))))) (chi-top149 (lambda (e501 r502 w503 m504 esew505 mod506) (call-with-values (lambda () (syntax-type148 e501 r502 w503 #f #f mod506)) (lambda (type514 value515 e516 w517 s518 mod519) (if (memv type514 (quote (begin-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522) (chi-void158)) tmp521) ((lambda (tmp523) (if tmp523 (apply (lambda (_524 e1525 e2526) (chi-top-sequence145 (cons e1525 e2526) r502 w517 s518 m504 esew505 mod519)) tmp523) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any any . each-any)))))) ($sc-dispatch tmp520 (quote (any))))) e516) (if (memv type514 (quote (local-syntax-form))) (chi-local-syntax156 value515 e516 r502 w517 s518 mod519 (lambda (body528 r529 w530 s531 mod532) (chi-top-sequence145 body528 r529 w530 s531 m504 esew505 mod532))) (if (memv type514 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list147 e516 x536 w517)) (body540 (cons e1537 e2538))) (if (eq? m504 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence145 body540 r502 w517 s518 (quote e) (quote (eval)) mod519) (chi-void158)) (if (memq (quote load) when-list539) (if (let ((t543 (memq (quote compile) when-list539))) (if t543 t543 (if (eq? m504 (quote c&e)) (memq (quote eval) when-list539) #f))) (chi-top-sequence145 body540 r502 w517 s518 (quote c&e) (quote (compile load)) mod519) (if (memq m504 (quote (c c&e))) (chi-top-sequence145 body540 r502 w517 s518 (quote c) (quote (load)) mod519) (chi-void158))) (if (let ((t544 (memq (quote compile) when-list539))) (if t544 t544 (if (eq? m504 (quote c&e)) (memq (quote eval) when-list539) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body540 r502 w517 s518 (quote e) (quote (eval)) mod519) mod519) (chi-void158)) (chi-void158)))))) tmp534) (syntax-violation #f "source expression failed to match any pattern" tmp533))) ($sc-dispatch tmp533 (quote (any each-any any . each-any))))) e516) (if (memv type514 (quote (define-syntax-form))) (let ((n545 (id-var-name136 value515 w517)) (r546 (macros-only-env110 r502))) (if (memv m504 (quote (c))) (if (memq (quote compile) esew505) (let ((e547 (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)))) (begin (top-level-eval-hook76 e547 mod519) (if (memq (quote load) esew505) e547 (chi-void158)))) (if (memq (quote load) esew505) (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)) (chi-void158))) (if (memv m504 (quote (c&e))) (let ((e548 (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)))) (begin (top-level-eval-hook76 e548 mod519) e548)) (begin (if (memq (quote eval) esew505) (top-level-eval-hook76 (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)) mod519)) (chi-void158))))) (if (memv type514 (quote (define-form))) (let ((n549 (id-var-name136 value515 w517))) (let ((type550 (binding-type106 (lookup111 n549 r502 mod519)))) (if (memv type550 (quote (global core macro module-ref))) (let ((x551 (build-global-definition89 s518 n549 (chi150 e516 r502 w517 mod519)))) (begin (if (eq? m504 (quote c&e)) (top-level-eval-hook76 x551 mod519)) x551)) (if (memv type550 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e516 (wrap142 value515 w517 mod519)) (syntax-violation #f "cannot define keyword at top level" e516 (wrap142 value515 w517 mod519)))))) (let ((x552 (chi-expr151 type514 value515 e516 r502 w517 s518 mod519))) (begin (if (eq? m504 (quote c&e)) (top-level-eval-hook76 x552 mod519)) x552))))))))))) (syntax-type148 (lambda (e553 r554 w555 s556 rib557 mod558) (if (symbol? e553) (let ((n559 (id-var-name136 e553 w555))) (let ((b560 (lookup111 n559 r554 mod558))) (let ((type561 (binding-type106 b560))) (if (memv type561 (quote (lexical))) (values type561 (binding-value107 b560) e553 w555 s556 mod558) (if (memv type561 (quote (global))) (values type561 n559 e553 w555 s556 mod558) (if (memv type561 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b560) e553 r554 w555 rib557 mod558) r554 (quote (())) s556 rib557 mod558) (values type561 (binding-value107 b560) e553 w555 s556 mod558))))))) (if (pair? e553) (let ((first562 (car e553))) (if (id?114 first562) (let ((n563 (id-var-name136 first562 w555))) (let ((b564 (lookup111 n563 r554 (let ((t565 (if (syntax-object?98 first562) (syntax-object-module101 first562) #f))) (if t565 t565 mod558))))) (let ((type566 (binding-type106 b564))) (if (memv type566 (quote (lexical))) (values (quote lexical-call) (binding-value107 b564) e553 w555 s556 mod558) (if (memv type566 (quote (global))) (values (quote global-call) n563 e553 w555 s556 mod558) (if (memv type566 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b564) e553 r554 w555 rib557 mod558) r554 (quote (())) s556 rib557 mod558) (if (memv type566 (quote (core external-macro module-ref))) (values type566 (binding-value107 b564) e553 w555 s556 mod558) (if (memv type566 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value107 b564) e553 w555 s556 mod558) (if (memv type566 (quote (begin))) (values (quote begin-form) #f e553 w555 s556 mod558) (if (memv type566 (quote (eval-when))) (values (quote eval-when-form) #f e553 w555 s556 mod558) (if (memv type566 (quote (define))) ((lambda (tmp567) ((lambda (tmp568) (if (if tmp568 (apply (lambda (_569 name570 val571) (id?114 name570)) tmp568) #f) (apply (lambda (_572 name573 val574) (values (quote define-form) name573 val574 w555 s556 mod558)) tmp568) ((lambda (tmp575) (if (if tmp575 (apply (lambda (_576 name577 args578 e1579 e2580) (if (id?114 name577) (valid-bound-ids?139 (lambda-var-list163 args578)) #f)) tmp575) #f) (apply (lambda (_581 name582 args583 e1584 e2585) (values (quote define-form) (wrap142 name582 w555 mod558) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args583 (cons e1584 e2585)) w555 mod558)) (quote (())) s556 mod558)) tmp575) ((lambda (tmp587) (if (if tmp587 (apply (lambda (_588 name589) (id?114 name589)) tmp587) #f) (apply (lambda (_590 name591) (values (quote define-form) (wrap142 name591 w555 mod558) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s556 mod558)) tmp587) (syntax-violation #f "source expression failed to match any pattern" tmp567))) ($sc-dispatch tmp567 (quote (any any)))))) ($sc-dispatch tmp567 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp567 (quote (any any any))))) e553) (if (memv type566 (quote (define-syntax))) ((lambda (tmp592) ((lambda (tmp593) (if (if tmp593 (apply (lambda (_594 name595 val596) (id?114 name595)) tmp593) #f) (apply (lambda (_597 name598 val599) (values (quote define-syntax-form) name598 val599 w555 s556 mod558)) tmp593) (syntax-violation #f "source expression failed to match any pattern" tmp592))) ($sc-dispatch tmp592 (quote (any any any))))) e553) (values (quote call) #f e553 w555 s556 mod558))))))))))))) (values (quote call) #f e553 w555 s556 mod558))) (if (syntax-object?98 e553) (syntax-type148 (syntax-object-expression99 e553) r554 (join-wraps133 w555 (syntax-object-wrap100 e553)) #f rib557 (let ((t600 (syntax-object-module101 e553))) (if t600 t600 mod558))) (if (annotation? e553) (syntax-type148 (annotation-expression e553) r554 w555 (annotation-source e553) rib557 mod558) (if (self-evaluating? e553) (values (quote constant) #f e553 w555 s556 mod558) (values (quote other) #f e553 w555 s556 mod558)))))))) (chi-when-list147 (lambda (e601 when-list602 w603) (letrec ((f604 (lambda (when-list605 situations606) (if (null? when-list605) situations606 (f604 (cdr when-list605) (cons (let ((x607 (car when-list605))) (if (free-id=?137 x607 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x607 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x607 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e601 (wrap142 x607 w603 #f)))))) situations606)))))) (f604 when-list602 (quote ()))))) (chi-install-global146 (lambda (name608 e609) (build-global-definition89 #f name608 (if (let ((v610 (module-variable (current-module) name608))) (if v610 (if (variable-bound? v610) (if (macro? (variable-ref v610)) (not (eq? (macro-type (variable-ref v610)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name608))) (build-data92 #f (quote macro)) e609)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e609)))))) (chi-top-sequence145 (lambda (body611 r612 w613 s614 m615 esew616 mod617) (build-sequence93 s614 (letrec ((dobody618 (lambda (body619 r620 w621 m622 esew623 mod624) (if (null? body619) (quote ()) (let ((first625 (chi-top149 (car body619) r620 w621 m622 esew623 mod624))) (cons first625 (dobody618 (cdr body619) r620 w621 m622 esew623 mod624))))))) (dobody618 body611 r612 w613 m615 esew616 mod617))))) (chi-sequence144 (lambda (body626 r627 w628 s629 mod630) (build-sequence93 s629 (letrec ((dobody631 (lambda (body632 r633 w634 mod635) (if (null? body632) (quote ()) (let ((first636 (chi150 (car body632) r633 w634 mod635))) (cons first636 (dobody631 (cdr body632) r633 w634 mod635))))))) (dobody631 body626 r627 w628 mod630))))) (source-wrap143 (lambda (x637 w638 s639 defmod640) (wrap142 (if s639 (make-annotation x637 s639 #f) x637) w638 defmod640))) (wrap142 (lambda (x641 w642 defmod643) (if (if (null? (wrap-marks117 w642)) (null? (wrap-subst118 w642)) #f) x641 (if (syntax-object?98 x641) (make-syntax-object97 (syntax-object-expression99 x641) (join-wraps133 w642 (syntax-object-wrap100 x641)) (syntax-object-module101 x641)) (if (null? x641) x641 (make-syntax-object97 x641 w642 defmod643)))))) (bound-id-member?141 (lambda (x644 list645) (if (not (null? list645)) (let ((t646 (bound-id=?138 x644 (car list645)))) (if t646 t646 (bound-id-member?141 x644 (cdr list645)))) #f))) (distinct-bound-ids?140 (lambda (ids647) (letrec ((distinct?648 (lambda (ids649) (let ((t650 (null? ids649))) (if t650 t650 (if (not (bound-id-member?141 (car ids649) (cdr ids649))) (distinct?648 (cdr ids649)) #f)))))) (distinct?648 ids647)))) (valid-bound-ids?139 (lambda (ids651) (if (letrec ((all-ids?652 (lambda (ids653) (let ((t654 (null? ids653))) (if t654 t654 (if (id?114 (car ids653)) (all-ids?652 (cdr ids653)) #f)))))) (all-ids?652 ids651)) (distinct-bound-ids?140 ids651) #f))) (bound-id=?138 (lambda (i655 j656) (if (if (syntax-object?98 i655) (syntax-object?98 j656) #f) (if (eq? (let ((e657 (syntax-object-expression99 i655))) (if (annotation? e657) (annotation-expression e657) e657)) (let ((e658 (syntax-object-expression99 j656))) (if (annotation? e658) (annotation-expression e658) e658))) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i655)) (wrap-marks117 (syntax-object-wrap100 j656))) #f) (eq? (let ((e659 i655)) (if (annotation? e659) (annotation-expression e659) e659)) (let ((e660 j656)) (if (annotation? e660) (annotation-expression e660) e660)))))) (free-id=?137 (lambda (i661 j662) (if (eq? (let ((x663 i661)) (let ((e664 (if (syntax-object?98 x663) (syntax-object-expression99 x663) x663))) (if (annotation? e664) (annotation-expression e664) e664))) (let ((x665 j662)) (let ((e666 (if (syntax-object?98 x665) (syntax-object-expression99 x665) x665))) (if (annotation? e666) (annotation-expression e666) e666)))) (eq? (id-var-name136 i661 (quote (()))) (id-var-name136 j662 (quote (())))) #f))) (id-var-name136 (lambda (id667 w668) (letrec ((search-vector-rib671 (lambda (sym677 subst678 marks679 symnames680 ribcage681) (let ((n682 (vector-length symnames680))) (letrec ((f683 (lambda (i684) (if (fx=74 i684 n682) (search669 sym677 (cdr subst678) marks679) (if (if (eq? (vector-ref symnames680 i684) sym677) (same-marks?135 marks679 (vector-ref (ribcage-marks124 ribcage681) i684)) #f) (values (vector-ref (ribcage-labels125 ribcage681) i684) marks679) (f683 (fx+72 i684 1))))))) (f683 0))))) (search-list-rib670 (lambda (sym685 subst686 marks687 symnames688 ribcage689) (letrec ((f690 (lambda (symnames691 i692) (if (null? symnames691) (search669 sym685 (cdr subst686) marks687) (if (if (eq? (car symnames691) sym685) (same-marks?135 marks687 (list-ref (ribcage-marks124 ribcage689) i692)) #f) (values (list-ref (ribcage-labels125 ribcage689) i692) marks687) (f690 (cdr symnames691) (fx+72 i692 1))))))) (f690 symnames688 0)))) (search669 (lambda (sym693 subst694 marks695) (if (null? subst694) (values #f marks695) (let ((fst696 (car subst694))) (if (eq? fst696 (quote shift)) (search669 sym693 (cdr subst694) (cdr marks695)) (let ((symnames697 (ribcage-symnames123 fst696))) (if (vector? symnames697) (search-vector-rib671 sym693 subst694 marks695 symnames697 fst696) (search-list-rib670 sym693 subst694 marks695 symnames697 fst696))))))))) (if (symbol? id667) (let ((t698 (call-with-values (lambda () (search669 id667 (wrap-subst118 w668) (wrap-marks117 w668))) (lambda (x700 . ignore699) x700)))) (if t698 t698 id667)) (if (syntax-object?98 id667) (let ((id701 (let ((e703 (syntax-object-expression99 id667))) (if (annotation? e703) (annotation-expression e703) e703))) (w1702 (syntax-object-wrap100 id667))) (let ((marks704 (join-marks134 (wrap-marks117 w668) (wrap-marks117 w1702)))) (call-with-values (lambda () (search669 id701 (wrap-subst118 w668) marks704)) (lambda (new-id705 marks706) (let ((t707 new-id705)) (if t707 t707 (let ((t708 (call-with-values (lambda () (search669 id701 (wrap-subst118 w1702) marks706)) (lambda (x710 . ignore709) x710)))) (if t708 t708 id701)))))))) (if (annotation? id667) (let ((id711 (let ((e712 id667)) (if (annotation? e712) (annotation-expression e712) e712)))) (let ((t713 (call-with-values (lambda () (search669 id711 (wrap-subst118 w668) (wrap-marks117 w668))) (lambda (x715 . ignore714) x715)))) (if t713 t713 id711))) (syntax-violation (quote id-var-name) "invalid id" id667))))))) (same-marks?135 (lambda (x716 y717) (let ((t718 (eq? x716 y717))) (if t718 t718 (if (not (null? x716)) (if (not (null? y717)) (if (eq? (car x716) (car y717)) (same-marks?135 (cdr x716) (cdr y717)) #f) #f) #f))))) (join-marks134 (lambda (m1719 m2720) (smart-append132 m1719 m2720))) (join-wraps133 (lambda (w1721 w2722) (let ((m1723 (wrap-marks117 w1721)) (s1724 (wrap-subst118 w1721))) (if (null? m1723) (if (null? s1724) w2722 (make-wrap116 (wrap-marks117 w2722) (smart-append132 s1724 (wrap-subst118 w2722)))) (make-wrap116 (smart-append132 m1723 (wrap-marks117 w2722)) (smart-append132 s1724 (wrap-subst118 w2722))))))) (smart-append132 (lambda (m1725 m2726) (if (null? m2726) m1725 (append m1725 m2726)))) (make-binding-wrap131 (lambda (ids727 labels728 w729) (if (null? ids727) w729 (make-wrap116 (wrap-marks117 w729) (cons (let ((labelvec730 (list->vector labels728))) (let ((n731 (vector-length labelvec730))) (let ((symnamevec732 (make-vector n731)) (marksvec733 (make-vector n731))) (begin (letrec ((f734 (lambda (ids735 i736) (if (not (null? ids735)) (call-with-values (lambda () (id-sym-name&marks115 (car ids735) w729)) (lambda (symname737 marks738) (begin (vector-set! symnamevec732 i736 symname737) (vector-set! marksvec733 i736 marks738) (f734 (cdr ids735) (fx+72 i736 1))))))))) (f734 ids727 0)) (make-ribcage121 symnamevec732 marksvec733 labelvec730))))) (wrap-subst118 w729)))))) (extend-ribcage!130 (lambda (ribcage739 id740 label741) (begin (set-ribcage-symnames!126 ribcage739 (cons (let ((e742 (syntax-object-expression99 id740))) (if (annotation? e742) (annotation-expression e742) e742)) (ribcage-symnames123 ribcage739))) (set-ribcage-marks!127 ribcage739 (cons (wrap-marks117 (syntax-object-wrap100 id740)) (ribcage-marks124 ribcage739))) (set-ribcage-labels!128 ribcage739 (cons label741 (ribcage-labels125 ribcage739)))))) (anti-mark129 (lambda (w743) (make-wrap116 (cons #f (wrap-marks117 w743)) (cons (quote shift) (wrap-subst118 w743))))) (set-ribcage-labels!128 (lambda (x744 update745) (vector-set! x744 3 update745))) (set-ribcage-marks!127 (lambda (x746 update747) (vector-set! x746 2 update747))) (set-ribcage-symnames!126 (lambda (x748 update749) (vector-set! x748 1 update749))) (ribcage-labels125 (lambda (x750) (vector-ref x750 3))) (ribcage-marks124 (lambda (x751) (vector-ref x751 2))) (ribcage-symnames123 (lambda (x752) (vector-ref x752 1))) (ribcage?122 (lambda (x753) (if (vector? x753) (if (= (vector-length x753) 4) (eq? (vector-ref x753 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames754 marks755 labels756) (vector (quote ribcage) symnames754 marks755 labels756))) (gen-labels120 (lambda (ls757) (if (null? ls757) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls757)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x758 w759) (if (syntax-object?98 x758) (values (let ((e760 (syntax-object-expression99 x758))) (if (annotation? e760) (annotation-expression e760) e760)) (join-marks134 (wrap-marks117 w759) (wrap-marks117 (syntax-object-wrap100 x758)))) (values (let ((e761 x758)) (if (annotation? e761) (annotation-expression e761) e761)) (wrap-marks117 w759))))) (id?114 (lambda (x762) (if (symbol? x762) #t (if (syntax-object?98 x762) (symbol? (let ((e763 (syntax-object-expression99 x762))) (if (annotation? e763) (annotation-expression e763) e763))) (if (annotation? x762) (symbol? (annotation-expression x762)) #f))))) (nonsymbol-id?113 (lambda (x764) (if (syntax-object?98 x764) (symbol? (let ((e765 (syntax-object-expression99 x764))) (if (annotation? e765) (annotation-expression e765) e765))) #f))) (global-extend112 (lambda (type766 sym767 val768) (put-global-definition-hook78 sym767 type766 val768))) (lookup111 (lambda (x769 r770 mod771) (let ((t772 (assq x769 r770))) (if t772 (cdr t772) (if (symbol? x769) (let ((t773 (get-global-definition-hook79 x769 mod771))) (if t773 t773 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r774) (if (null? r774) (quote ()) (let ((a775 (car r774))) (if (eq? (cadr a775) (quote macro)) (cons a775 (macros-only-env110 (cdr r774))) (macros-only-env110 (cdr r774))))))) (extend-var-env109 (lambda (labels776 vars777 r778) (if (null? labels776) r778 (extend-var-env109 (cdr labels776) (cdr vars777) (cons (cons (car labels776) (cons (quote lexical) (car vars777))) r778))))) (extend-env108 (lambda (labels779 bindings780 r781) (if (null? labels779) r781 (extend-env108 (cdr labels779) (cdr bindings780) (cons (cons (car labels779) (car bindings780)) r781))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x782) (if (annotation? x782) (annotation-source x782) (if (syntax-object?98 x782) (source-annotation105 (syntax-object-expression99 x782)) #f)))) (set-syntax-object-module!104 (lambda (x783 update784) (vector-set! x783 3 update784))) (set-syntax-object-wrap!103 (lambda (x785 update786) (vector-set! x785 2 update786))) (set-syntax-object-expression!102 (lambda (x787 update788) (vector-set! x787 1 update788))) (syntax-object-module101 (lambda (x789) (vector-ref x789 3))) (syntax-object-wrap100 (lambda (x790) (vector-ref x790 2))) (syntax-object-expression99 (lambda (x791) (vector-ref x791 1))) (syntax-object?98 (lambda (x792) (if (vector? x792) (if (= (vector-length x792) 4) (eq? (vector-ref x792 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression793 wrap794 module795) (vector (quote syntax-object) expression793 wrap794 module795))) (build-letrec96 (lambda (src796 ids797 vars798 val-exps799 body-exp800) (if (null? vars798) body-exp800 (let ((atom-key801 (fluid-ref *mode*71))) (if (memv atom-key801 (quote (c))) (begin (for-each maybe-name-value!88 ids797 val-exps799) ((@ (language tree-il) make-letrec) src796 ids797 vars798 val-exps799 body-exp800)) (list (quote letrec) (map list vars798 val-exps799) body-exp800)))))) (build-named-let95 (lambda (src802 ids803 vars804 val-exps805 body-exp806) (let ((f807 (car vars804)) (f-name808 (car ids803)) (vars809 (cdr vars804)) (ids810 (cdr ids803))) (let ((atom-key811 (fluid-ref *mode*71))) (if (memv atom-key811 (quote (c))) (let ((proc812 (build-lambda90 src802 ids810 vars809 #f body-exp806))) (begin (maybe-name-value!88 f-name808 proc812) (for-each maybe-name-value!88 ids810 val-exps805) ((@ (language tree-il) make-letrec) src802 (list f-name808) (list f807) (list proc812) (build-application81 src802 (build-lexical-reference83 (quote fun) src802 f-name808 f807) val-exps805)))) (list (quote let) f807 (map list vars809 val-exps805) body-exp806)))))) (build-let94 (lambda (src813 ids814 vars815 val-exps816 body-exp817) (if (null? vars815) body-exp817 (let ((atom-key818 (fluid-ref *mode*71))) (if (memv atom-key818 (quote (c))) (begin (for-each maybe-name-value!88 ids814 val-exps816) ((@ (language tree-il) make-let) src813 ids814 vars815 val-exps816 body-exp817)) (list (quote let) (map list vars815 val-exps816) body-exp817)))))) (build-sequence93 (lambda (src819 exps820) (if (null? (cdr exps820)) (car exps820) (let ((atom-key821 (fluid-ref *mode*71))) (if (memv atom-key821 (quote (c))) ((@ (language tree-il) make-sequence) src819 exps820) (cons (quote begin) exps820)))))) (build-data92 (lambda (src822 exp823) (let ((atom-key824 (fluid-ref *mode*71))) (if (memv atom-key824 (quote (c))) ((@ (language tree-il) make-const) src822 exp823) (if (if (self-evaluating? exp823) (not (vector? exp823)) #f) exp823 (list (quote quote) exp823)))))) (build-primref91 (lambda (src825 name826) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key827 (fluid-ref *mode*71))) (if (memv atom-key827 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src825 name826) name826)) (let ((atom-key828 (fluid-ref *mode*71))) (if (memv atom-key828 (quote (c))) ((@ (language tree-il) make-module-ref) src825 (quote (guile)) name826 #f) (list (quote @@) (quote (guile)) name826)))))) (build-lambda90 (lambda (src829 ids830 vars831 docstring832 exp833) (let ((atom-key834 (fluid-ref *mode*71))) (if (memv atom-key834 (quote (c))) ((@ (language tree-il) make-lambda) src829 ids830 vars831 (if docstring832 (list (cons (quote documentation) docstring832)) (quote ())) exp833) (cons (quote lambda) (cons vars831 (append (if docstring832 (list docstring832) (quote ())) (list exp833)))))))) (build-global-definition89 (lambda (source835 var836 exp837) (let ((atom-key838 (fluid-ref *mode*71))) (if (memv atom-key838 (quote (c))) (begin (maybe-name-value!88 var836 exp837) ((@ (language tree-il) make-toplevel-define) source835 var836 exp837)) (list (quote define) var836 exp837))))) (maybe-name-value!88 (lambda (name839 val840) (if ((@ (language tree-il) lambda?) val840) (let ((meta841 ((@ (language tree-il) lambda-meta) val840))) (if (not (assq (quote name) meta841)) ((setter (@ (language tree-il) lambda-meta)) val840 (acons (quote name) name839 meta841))))))) (build-global-assignment87 (lambda (source842 var843 exp844 mod845) (analyze-variable85 mod845 var843 (lambda (mod846 var847 public?848) (let ((atom-key849 (fluid-ref *mode*71))) (if (memv atom-key849 (quote (c))) ((@ (language tree-il) make-module-set) source842 mod846 var847 public?848 exp844) (list (quote set!) (list (if public?848 (quote @) (quote @@)) mod846 var847) exp844)))) (lambda (var850) (let ((atom-key851 (fluid-ref *mode*71))) (if (memv atom-key851 (quote (c))) ((@ (language tree-il) make-toplevel-set) source842 var850 exp844) (list (quote set!) var850 exp844))))))) (build-global-reference86 (lambda (source852 var853 mod854) (analyze-variable85 mod854 var853 (lambda (mod855 var856 public?857) (let ((atom-key858 (fluid-ref *mode*71))) (if (memv atom-key858 (quote (c))) ((@ (language tree-il) make-module-ref) source852 mod855 var856 public?857) (list (if public?857 (quote @) (quote @@)) mod855 var856)))) (lambda (var859) (let ((atom-key860 (fluid-ref *mode*71))) (if (memv atom-key860 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source852 var859) var859)))))) (analyze-variable85 (lambda (mod861 var862 modref-cont863 bare-cont864) (if (not mod861) (bare-cont864 var862) (let ((kind865 (car mod861)) (mod866 (cdr mod861))) (if (memv kind865 (quote (public))) (modref-cont863 mod866 var862 #t) (if (memv kind865 (quote (private))) (if (not (equal? mod866 (module-name (current-module)))) (modref-cont863 mod866 var862 #f) (bare-cont864 var862)) (if (memv kind865 (quote (bare))) (bare-cont864 var862) (if (memv kind865 (quote (hygiene))) (if (if (not (equal? mod866 (module-name (current-module)))) (module-variable (resolve-module mod866) var862) #f) (modref-cont863 mod866 var862 #f) (bare-cont864 var862)) (syntax-violation #f "bad module kind" var862 mod866))))))))) (build-lexical-assignment84 (lambda (source867 name868 var869 exp870) (let ((atom-key871 (fluid-ref *mode*71))) (if (memv atom-key871 (quote (c))) ((@ (language tree-il) make-lexical-set) source867 name868 var869 exp870) (list (quote set!) var869 exp870))))) (build-lexical-reference83 (lambda (type872 source873 name874 var875) (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) make-lexical-ref) source873 name874 var875) var875)))) (build-conditional82 (lambda (source877 test-exp878 then-exp879 else-exp880) (let ((atom-key881 (fluid-ref *mode*71))) (if (memv atom-key881 (quote (c))) ((@ (language tree-il) make-conditional) source877 test-exp878 then-exp879 else-exp880) (if (equal? else-exp880 (quote (if #f #f))) (list (quote if) test-exp878 then-exp879) (list (quote if) test-exp878 then-exp879 else-exp880)))))) (build-application81 (lambda (source882 fun-exp883 arg-exps884) (let ((atom-key885 (fluid-ref *mode*71))) (if (memv atom-key885 (quote (c))) ((@ (language tree-il) make-application) source882 fun-exp883 arg-exps884) (cons fun-exp883 arg-exps884))))) (build-void80 (lambda (source886) (let ((atom-key887 (fluid-ref *mode*71))) (if (memv atom-key887 (quote (c))) ((@ (language tree-il) make-void) source886) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol888 module889) (begin (if (if (not module889) (current-module) #f) (warn "module system is booted, we should have a module" symbol888)) (let ((v890 (module-variable (if module889 (resolve-module (cdr module889)) (current-module)) symbol888))) (if v890 (if (variable-bound? v890) (let ((val891 (variable-ref v890))) (if (macro? val891) (if (syncase-macro-type val891) (cons (syncase-macro-type val891) (syncase-macro-binding val891)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol892 type893 val894) (let ((existing895 (let ((v896 (module-variable (current-module) symbol892))) (if v896 (if (variable-bound? v896) (let ((val897 (variable-ref v896))) (if (macro? val897) (if (not (syncase-macro-type val897)) val897 #f) #f)) #f) #f)))) (module-define! (current-module) symbol892 (if existing895 (make-extended-syncase-macro existing895 type893 val894) (make-syncase-macro type893 val894)))))) (local-eval-hook77 (lambda (x898 mod899) (primitive-eval (list noexpand70 (let ((atom-key900 (fluid-ref *mode*71))) (if (memv atom-key900 (quote (c))) ((@ (language tree-il) tree-il->scheme) x898) x898)))))) (top-level-eval-hook76 (lambda (x901 mod902) (primitive-eval (list noexpand70 (let ((atom-key903 (fluid-ref *mode*71))) (if (memv atom-key903 (quote (c))) ((@ (language tree-il) tree-il->scheme) x901) x901)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e904 r905 w906 s907 mod908) ((lambda (tmp909) ((lambda (tmp910) (if (if tmp910 (apply (lambda (_911 var912 val913 e1914 e2915) (valid-bound-ids?139 var912)) tmp910) #f) (apply (lambda (_917 var918 val919 e1920 e2921) (let ((names922 (map (lambda (x923) (id-var-name136 x923 w906)) var918))) (begin (for-each (lambda (id925 n926) (let ((atom-key927 (binding-type106 (lookup111 n926 r905 mod908)))) (if (memv atom-key927 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e904 (source-wrap143 id925 w906 s907 mod908))))) var918 names922) (chi-body154 (cons e1920 e2921) (source-wrap143 e904 w906 s907 mod908) (extend-env108 names922 (let ((trans-r930 (macros-only-env110 r905))) (map (lambda (x931) (cons (quote macro) (eval-local-transformer157 (chi150 x931 trans-r930 w906 mod908) mod908))) val919)) r905) w906 mod908)))) tmp910) ((lambda (_933) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e904 w906 s907 mod908))) tmp909))) ($sc-dispatch tmp909 (quote (any #(each (any any)) any . each-any))))) e904))) (global-extend112 (quote core) (quote quote) (lambda (e934 r935 w936 s937 mod938) ((lambda (tmp939) ((lambda (tmp940) (if tmp940 (apply (lambda (_941 e942) (build-data92 s937 (strip161 e942 w936))) tmp940) ((lambda (_943) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e934 w936 s937 mod938))) tmp939))) ($sc-dispatch tmp939 (quote (any any))))) e934))) (global-extend112 (quote core) (quote syntax) (letrec ((regen951 (lambda (x952) (let ((atom-key953 (car x952))) (if (memv atom-key953 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x952) (cadr x952)) (if (memv atom-key953 (quote (primitive))) (build-primref91 #f (cadr x952)) (if (memv atom-key953 (quote (quote))) (build-data92 #f (cadr x952)) (if (memv atom-key953 (quote (lambda))) (build-lambda90 #f (cadr x952) (cadr x952) #f (regen951 (caddr x952))) (if (memv atom-key953 (quote (map))) (let ((ls954 (map regen951 (cdr x952)))) (build-application81 #f (build-primref91 #f (quote map)) ls954)) (build-application81 #f (build-primref91 #f (car x952)) (map regen951 (cdr x952))))))))))) (gen-vector950 (lambda (x955) (if (eq? (car x955) (quote list)) (cons (quote vector) (cdr x955)) (if (eq? (car x955) (quote quote)) (list (quote quote) (list->vector (cadr x955))) (list (quote list->vector) x955))))) (gen-append949 (lambda (x956 y957) (if (equal? y957 (quote (quote ()))) x956 (list (quote append) x956 y957)))) (gen-cons948 (lambda (x958 y959) (let ((atom-key960 (car y959))) (if (memv atom-key960 (quote (quote))) (if (eq? (car x958) (quote quote)) (list (quote quote) (cons (cadr x958) (cadr y959))) (if (eq? (cadr y959) (quote ())) (list (quote list) x958) (list (quote cons) x958 y959))) (if (memv atom-key960 (quote (list))) (cons (quote list) (cons x958 (cdr y959))) (list (quote cons) x958 y959)))))) (gen-map947 (lambda (e961 map-env962) (let ((formals963 (map cdr map-env962)) (actuals964 (map (lambda (x965) (list (quote ref) (car x965))) map-env962))) (if (eq? (car e961) (quote ref)) (car actuals964) (if (and-map (lambda (x966) (if (eq? (car x966) (quote ref)) (memq (cadr x966) formals963) #f)) (cdr e961)) (cons (quote map) (cons (list (quote primitive) (car e961)) (map (let ((r967 (map cons formals963 actuals964))) (lambda (x968) (cdr (assq (cadr x968) r967)))) (cdr e961)))) (cons (quote map) (cons (list (quote lambda) formals963 e961) actuals964))))))) (gen-mappend946 (lambda (e969 map-env970) (list (quote apply) (quote (primitive append)) (gen-map947 e969 map-env970)))) (gen-ref945 (lambda (src971 var972 level973 maps974) (if (fx=74 level973 0) (values var972 maps974) (if (null? maps974) (syntax-violation (quote syntax) "missing ellipsis" src971) (call-with-values (lambda () (gen-ref945 src971 var972 (fx-73 level973 1) (cdr maps974))) (lambda (outer-var975 outer-maps976) (let ((b977 (assq outer-var975 (car maps974)))) (if b977 (values (cdr b977) maps974) (let ((inner-var978 (gen-var162 (quote tmp)))) (values inner-var978 (cons (cons (cons outer-var975 inner-var978) (car maps974)) outer-maps976))))))))))) (gen-syntax944 (lambda (src979 e980 r981 maps982 ellipsis?983 mod984) (if (id?114 e980) (let ((label985 (id-var-name136 e980 (quote (()))))) (let ((b986 (lookup111 label985 r981 mod984))) (if (eq? (binding-type106 b986) (quote syntax)) (call-with-values (lambda () (let ((var.lev987 (binding-value107 b986))) (gen-ref945 src979 (car var.lev987) (cdr var.lev987) maps982))) (lambda (var988 maps989) (values (list (quote ref) var988) maps989))) (if (ellipsis?983 e980) (syntax-violation (quote syntax) "misplaced ellipsis" src979) (values (list (quote quote) e980) maps982))))) ((lambda (tmp990) ((lambda (tmp991) (if (if tmp991 (apply (lambda (dots992 e993) (ellipsis?983 dots992)) tmp991) #f) (apply (lambda (dots994 e995) (gen-syntax944 src979 e995 r981 maps982 (lambda (x996) #f) mod984)) tmp991) ((lambda (tmp997) (if (if tmp997 (apply (lambda (x998 dots999 y1000) (ellipsis?983 dots999)) tmp997) #f) (apply (lambda (x1001 dots1002 y1003) (letrec ((f1004 (lambda (y1005 k1006) ((lambda (tmp1010) ((lambda (tmp1011) (if (if tmp1011 (apply (lambda (dots1012 y1013) (ellipsis?983 dots1012)) tmp1011) #f) (apply (lambda (dots1014 y1015) (f1004 y1015 (lambda (maps1016) (call-with-values (lambda () (k1006 (cons (quote ()) maps1016))) (lambda (x1017 maps1018) (if (null? (car maps1018)) (syntax-violation (quote syntax) "extra ellipsis" src979) (values (gen-mappend946 x1017 (car maps1018)) (cdr maps1018)))))))) tmp1011) ((lambda (_1019) (call-with-values (lambda () (gen-syntax944 src979 y1005 r981 maps982 ellipsis?983 mod984)) (lambda (y1020 maps1021) (call-with-values (lambda () (k1006 maps1021)) (lambda (x1022 maps1023) (values (gen-append949 x1022 y1020) maps1023)))))) tmp1010))) ($sc-dispatch tmp1010 (quote (any . any))))) y1005)))) (f1004 y1003 (lambda (maps1007) (call-with-values (lambda () (gen-syntax944 src979 x1001 r981 (cons (quote ()) maps1007) ellipsis?983 mod984)) (lambda (x1008 maps1009) (if (null? (car maps1009)) (syntax-violation (quote syntax) "extra ellipsis" src979) (values (gen-map947 x1008 (car maps1009)) (cdr maps1009))))))))) tmp997) ((lambda (tmp1024) (if tmp1024 (apply (lambda (x1025 y1026) (call-with-values (lambda () (gen-syntax944 src979 x1025 r981 maps982 ellipsis?983 mod984)) (lambda (x1027 maps1028) (call-with-values (lambda () (gen-syntax944 src979 y1026 r981 maps1028 ellipsis?983 mod984)) (lambda (y1029 maps1030) (values (gen-cons948 x1027 y1029) maps1030)))))) tmp1024) ((lambda (tmp1031) (if tmp1031 (apply (lambda (e11032 e21033) (call-with-values (lambda () (gen-syntax944 src979 (cons e11032 e21033) r981 maps982 ellipsis?983 mod984)) (lambda (e1035 maps1036) (values (gen-vector950 e1035) maps1036)))) tmp1031) ((lambda (_1037) (values (list (quote quote) e980) maps982)) tmp990))) ($sc-dispatch tmp990 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp990 (quote (any . any)))))) ($sc-dispatch tmp990 (quote (any any . any)))))) ($sc-dispatch tmp990 (quote (any any))))) e980))))) (lambda (e1038 r1039 w1040 s1041 mod1042) (let ((e1043 (source-wrap143 e1038 w1040 s1041 mod1042))) ((lambda (tmp1044) ((lambda (tmp1045) (if tmp1045 (apply (lambda (_1046 x1047) (call-with-values (lambda () (gen-syntax944 e1043 x1047 r1039 (quote ()) ellipsis?159 mod1042)) (lambda (e1048 maps1049) (regen951 e1048)))) tmp1045) ((lambda (_1050) (syntax-violation (quote syntax) "bad `syntax' form" e1043)) tmp1044))) ($sc-dispatch tmp1044 (quote (any any))))) e1043))))) (global-extend112 (quote core) (quote lambda) (lambda (e1051 r1052 w1053 s1054 mod1055) ((lambda (tmp1056) ((lambda (tmp1057) (if tmp1057 (apply (lambda (_1058 c1059) (chi-lambda-clause155 (source-wrap143 e1051 w1053 s1054 mod1055) #f c1059 r1052 w1053 mod1055 (lambda (names1060 vars1061 docstring1062 body1063) (build-lambda90 s1054 names1060 vars1061 docstring1062 body1063)))) tmp1057) (syntax-violation #f "source expression failed to match any pattern" tmp1056))) ($sc-dispatch tmp1056 (quote (any . any))))) e1051))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1064 (lambda (e1065 r1066 w1067 s1068 mod1069 constructor1070 ids1071 vals1072 exps1073) (if (not (valid-bound-ids?139 ids1071)) (syntax-violation (quote let) "duplicate bound variable" e1065) (let ((labels1074 (gen-labels120 ids1071)) (new-vars1075 (map gen-var162 ids1071))) (let ((nw1076 (make-binding-wrap131 ids1071 labels1074 w1067)) (nr1077 (extend-var-env109 labels1074 new-vars1075 r1066))) (constructor1070 s1068 (map syntax->datum ids1071) new-vars1075 (map (lambda (x1078) (chi150 x1078 r1066 w1067 mod1069)) vals1072) (chi-body154 exps1073 (source-wrap143 e1065 nw1076 s1068 mod1069) nr1077 nw1076 mod1069)))))))) (lambda (e1079 r1080 w1081 s1082 mod1083) ((lambda (tmp1084) ((lambda (tmp1085) (if (if tmp1085 (apply (lambda (_1086 id1087 val1088 e11089 e21090) (and-map id?114 id1087)) tmp1085) #f) (apply (lambda (_1092 id1093 val1094 e11095 e21096) (chi-let1064 e1079 r1080 w1081 s1082 mod1083 build-let94 id1093 val1094 (cons e11095 e21096))) tmp1085) ((lambda (tmp1100) (if (if tmp1100 (apply (lambda (_1101 f1102 id1103 val1104 e11105 e21106) (if (id?114 f1102) (and-map id?114 id1103) #f)) tmp1100) #f) (apply (lambda (_1108 f1109 id1110 val1111 e11112 e21113) (chi-let1064 e1079 r1080 w1081 s1082 mod1083 build-named-let95 (cons f1109 id1110) val1111 (cons e11112 e21113))) tmp1100) ((lambda (_1117) (syntax-violation (quote let) "bad let" (source-wrap143 e1079 w1081 s1082 mod1083))) tmp1084))) ($sc-dispatch tmp1084 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1084 (quote (any #(each (any any)) any . each-any))))) e1079)))) (global-extend112 (quote core) (quote letrec) (lambda (e1118 r1119 w1120 s1121 mod1122) ((lambda (tmp1123) ((lambda (tmp1124) (if (if tmp1124 (apply (lambda (_1125 id1126 val1127 e11128 e21129) (and-map id?114 id1126)) tmp1124) #f) (apply (lambda (_1131 id1132 val1133 e11134 e21135) (let ((ids1136 id1132)) (if (not (valid-bound-ids?139 ids1136)) (syntax-violation (quote letrec) "duplicate bound variable" e1118) (let ((labels1138 (gen-labels120 ids1136)) (new-vars1139 (map gen-var162 ids1136))) (let ((w1140 (make-binding-wrap131 ids1136 labels1138 w1120)) (r1141 (extend-var-env109 labels1138 new-vars1139 r1119))) (build-letrec96 s1121 (map syntax->datum ids1136) new-vars1139 (map (lambda (x1142) (chi150 x1142 r1141 w1140 mod1122)) val1133) (chi-body154 (cons e11134 e21135) (source-wrap143 e1118 w1140 s1121 mod1122) r1141 w1140 mod1122))))))) tmp1124) ((lambda (_1145) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1118 w1120 s1121 mod1122))) tmp1123))) ($sc-dispatch tmp1123 (quote (any #(each (any any)) any . each-any))))) e1118))) (global-extend112 (quote core) (quote set!) (lambda (e1146 r1147 w1148 s1149 mod1150) ((lambda (tmp1151) ((lambda (tmp1152) (if (if tmp1152 (apply (lambda (_1153 id1154 val1155) (id?114 id1154)) tmp1152) #f) (apply (lambda (_1156 id1157 val1158) (let ((val1159 (chi150 val1158 r1147 w1148 mod1150)) (n1160 (id-var-name136 id1157 w1148))) (let ((b1161 (lookup111 n1160 r1147 mod1150))) (let ((atom-key1162 (binding-type106 b1161))) (if (memv atom-key1162 (quote (lexical))) (build-lexical-assignment84 s1149 (syntax->datum id1157) (binding-value107 b1161) val1159) (if (memv atom-key1162 (quote (global))) (build-global-assignment87 s1149 n1160 val1159 mod1150) (if (memv atom-key1162 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1157 w1148 mod1150)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1146 w1148 s1149 mod1150))))))))) tmp1152) ((lambda (tmp1163) (if tmp1163 (apply (lambda (_1164 head1165 tail1166 val1167) (call-with-values (lambda () (syntax-type148 head1165 r1147 (quote (())) #f #f mod1150)) (lambda (type1168 value1169 ee1170 ww1171 ss1172 modmod1173) (if (memv type1168 (quote (module-ref))) (let ((val1174 (chi150 val1167 r1147 w1148 mod1150))) (call-with-values (lambda () (value1169 (cons head1165 tail1166))) (lambda (id1176 mod1177) (build-global-assignment87 s1149 id1176 val1174 mod1177)))) (build-application81 s1149 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1165) r1147 w1148 mod1150) (map (lambda (e1178) (chi150 e1178 r1147 w1148 mod1150)) (append tail1166 (list val1167)))))))) tmp1163) ((lambda (_1180) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1146 w1148 s1149 mod1150))) tmp1151))) ($sc-dispatch tmp1151 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1151 (quote (any any any))))) e1146))) (global-extend112 (quote module-ref) (quote @) (lambda (e1181) ((lambda (tmp1182) ((lambda (tmp1183) (if (if tmp1183 (apply (lambda (_1184 mod1185 id1186) (if (and-map id?114 mod1185) (id?114 id1186) #f)) tmp1183) #f) (apply (lambda (_1188 mod1189 id1190) (values (syntax->datum id1190) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1189)))) tmp1183) (syntax-violation #f "source expression failed to match any pattern" tmp1182))) ($sc-dispatch tmp1182 (quote (any each-any any))))) e1181))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1192) ((lambda (tmp1193) ((lambda (tmp1194) (if (if tmp1194 (apply (lambda (_1195 mod1196 id1197) (if (and-map id?114 mod1196) (id?114 id1197) #f)) tmp1194) #f) (apply (lambda (_1199 mod1200 id1201) (values (syntax->datum id1201) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1200)))) tmp1194) (syntax-violation #f "source expression failed to match any pattern" tmp1193))) ($sc-dispatch tmp1193 (quote (any each-any any))))) e1192))) (global-extend112 (quote core) (quote if) (lambda (e1203 r1204 w1205 s1206 mod1207) ((lambda (tmp1208) ((lambda (tmp1209) (if tmp1209 (apply (lambda (_1210 test1211 then1212) (build-conditional82 s1206 (chi150 test1211 r1204 w1205 mod1207) (chi150 then1212 r1204 w1205 mod1207) (build-void80 #f))) tmp1209) ((lambda (tmp1213) (if tmp1213 (apply (lambda (_1214 test1215 then1216 else1217) (build-conditional82 s1206 (chi150 test1215 r1204 w1205 mod1207) (chi150 then1216 r1204 w1205 mod1207) (chi150 else1217 r1204 w1205 mod1207))) tmp1213) (syntax-violation #f "source expression failed to match any pattern" tmp1208))) ($sc-dispatch tmp1208 (quote (any any any any)))))) ($sc-dispatch tmp1208 (quote (any any any))))) e1203))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1221 (lambda (x1222 keys1223 clauses1224 r1225 mod1226) (if (null? clauses1224) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1222)) ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda (pat1229 exp1230) (if (if (id?114 pat1229) (and-map (lambda (x1231) (not (free-id=?137 pat1229 x1231))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1223)) #f) (let ((labels1232 (list (gen-label119))) (var1233 (gen-var162 pat1229))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1229)) (list var1233) #f (chi150 exp1230 (extend-env108 labels1232 (list (cons (quote syntax) (cons var1233 0))) r1225) (make-binding-wrap131 (list pat1229) labels1232 (quote (()))) mod1226)) (list x1222))) (gen-clause1220 x1222 keys1223 (cdr clauses1224) r1225 pat1229 #t exp1230 mod1226))) tmp1228) ((lambda (tmp1234) (if tmp1234 (apply (lambda (pat1235 fender1236 exp1237) (gen-clause1220 x1222 keys1223 (cdr clauses1224) r1225 pat1235 fender1236 exp1237 mod1226)) tmp1234) ((lambda (_1238) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1224))) tmp1227))) ($sc-dispatch tmp1227 (quote (any any any)))))) ($sc-dispatch tmp1227 (quote (any any))))) (car clauses1224))))) (gen-clause1220 (lambda (x1239 keys1240 clauses1241 r1242 pat1243 fender1244 exp1245 mod1246) (call-with-values (lambda () (convert-pattern1218 pat1243 keys1240)) (lambda (p1247 pvars1248) (if (not (distinct-bound-ids?140 (map car pvars1248))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1243) (if (not (and-map (lambda (x1249) (not (ellipsis?159 (car x1249)))) pvars1248)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1243) (let ((y1250 (gen-var162 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1250) #f (let ((y1251 (build-lexical-reference83 (quote value) #f (quote tmp) y1250))) (build-conditional82 #f ((lambda (tmp1252) ((lambda (tmp1253) (if tmp1253 (apply (lambda () y1251) tmp1253) ((lambda (_1254) (build-conditional82 #f y1251 (build-dispatch-call1219 pvars1248 fender1244 y1251 r1242 mod1246) (build-data92 #f #f))) tmp1252))) ($sc-dispatch tmp1252 (quote #(atom #t))))) fender1244) (build-dispatch-call1219 pvars1248 exp1245 y1251 r1242 mod1246) (gen-syntax-case1221 x1239 keys1240 clauses1241 r1242 mod1246)))) (list (if (eq? p1247 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1239)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1239 (build-data92 #f p1247))))))))))))) (build-dispatch-call1219 (lambda (pvars1255 exp1256 y1257 r1258 mod1259) (let ((ids1260 (map car pvars1255)) (levels1261 (map cdr pvars1255))) (let ((labels1262 (gen-labels120 ids1260)) (new-vars1263 (map gen-var162 ids1260))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1260) new-vars1263 #f (chi150 exp1256 (extend-env108 labels1262 (map (lambda (var1264 level1265) (cons (quote syntax) (cons var1264 level1265))) new-vars1263 (map cdr pvars1255)) r1258) (make-binding-wrap131 ids1260 labels1262 (quote (()))) mod1259)) y1257)))))) (convert-pattern1218 (lambda (pattern1266 keys1267) (letrec ((cvt1268 (lambda (p1269 n1270 ids1271) (if (id?114 p1269) (if (bound-id-member?141 p1269 keys1267) (values (vector (quote free-id) p1269) ids1271) (values (quote any) (cons (cons p1269 n1270) ids1271))) ((lambda (tmp1272) ((lambda (tmp1273) (if (if tmp1273 (apply (lambda (x1274 dots1275) (ellipsis?159 dots1275)) tmp1273) #f) (apply (lambda (x1276 dots1277) (call-with-values (lambda () (cvt1268 x1276 (fx+72 n1270 1) ids1271)) (lambda (p1278 ids1279) (values (if (eq? p1278 (quote any)) (quote each-any) (vector (quote each) p1278)) ids1279)))) tmp1273) ((lambda (tmp1280) (if tmp1280 (apply (lambda (x1281 y1282) (call-with-values (lambda () (cvt1268 y1282 n1270 ids1271)) (lambda (y1283 ids1284) (call-with-values (lambda () (cvt1268 x1281 n1270 ids1284)) (lambda (x1285 ids1286) (values (cons x1285 y1283) ids1286)))))) tmp1280) ((lambda (tmp1287) (if tmp1287 (apply (lambda () (values (quote ()) ids1271)) tmp1287) ((lambda (tmp1288) (if tmp1288 (apply (lambda (x1289) (call-with-values (lambda () (cvt1268 x1289 n1270 ids1271)) (lambda (p1291 ids1292) (values (vector (quote vector) p1291) ids1292)))) tmp1288) ((lambda (x1293) (values (vector (quote atom) (strip161 p1269 (quote (())))) ids1271)) tmp1272))) ($sc-dispatch tmp1272 (quote #(vector each-any)))))) ($sc-dispatch tmp1272 (quote ()))))) ($sc-dispatch tmp1272 (quote (any . any)))))) ($sc-dispatch tmp1272 (quote (any any))))) p1269))))) (cvt1268 pattern1266 0 (quote ())))))) (lambda (e1294 r1295 w1296 s1297 mod1298) (let ((e1299 (source-wrap143 e1294 w1296 s1297 mod1298))) ((lambda (tmp1300) ((lambda (tmp1301) (if tmp1301 (apply (lambda (_1302 val1303 key1304 m1305) (if (and-map (lambda (x1306) (if (id?114 x1306) (not (ellipsis?159 x1306)) #f)) key1304) (let ((x1308 (gen-var162 (quote tmp)))) (build-application81 s1297 (build-lambda90 #f (list (quote tmp)) (list x1308) #f (gen-syntax-case1221 (build-lexical-reference83 (quote value) #f (quote tmp) x1308) key1304 m1305 r1295 mod1298)) (list (chi150 val1303 r1295 (quote (())) mod1298)))) (syntax-violation (quote syntax-case) "invalid literals list" e1299))) tmp1301) (syntax-violation #f "source expression failed to match any pattern" tmp1300))) ($sc-dispatch tmp1300 (quote (any any each-any . each-any))))) e1299))))) (set! sc-expand (lambda (x1312 . rest1311) (if (if (pair? x1312) (equal? (car x1312) noexpand70) #f) (cadr x1312) (let ((m1313 (if (null? rest1311) (quote e) (car rest1311))) (esew1314 (if (let ((t1315 (null? rest1311))) (if t1315 t1315 (null? (cdr rest1311)))) (quote (eval)) (cadr rest1311)))) (with-fluid* *mode*71 m1313 (lambda () (chi-top149 x1312 (quote ()) (quote ((top))) m1313 esew1314 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1316) (nonsymbol-id?113 x1316))) (set! datum->syntax (lambda (id1317 datum1318) (make-syntax-object97 datum1318 (syntax-object-wrap100 id1317) #f))) (set! syntax->datum (lambda (x1319) (strip161 x1319 (quote (()))))) (set! generate-temporaries (lambda (ls1320) (begin (let ((x1321 ls1320)) (if (not (list? x1321)) (syntax-violation (quote generate-temporaries) "invalid argument" x1321))) (map (lambda (x1322) (wrap142 (gensym) (quote ((top))) #f)) ls1320)))) (set! free-identifier=? (lambda (x1323 y1324) (begin (let ((x1325 x1323)) (if (not (nonsymbol-id?113 x1325)) (syntax-violation (quote free-identifier=?) "invalid argument" x1325))) (let ((x1326 y1324)) (if (not (nonsymbol-id?113 x1326)) (syntax-violation (quote free-identifier=?) "invalid argument" x1326))) (free-id=?137 x1323 y1324)))) (set! bound-identifier=? (lambda (x1327 y1328) (begin (let ((x1329 x1327)) (if (not (nonsymbol-id?113 x1329)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1329))) (let ((x1330 y1328)) (if (not (nonsymbol-id?113 x1330)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1330))) (bound-id=?138 x1327 y1328)))) (set! syntax-violation (lambda (who1334 message1333 form1332 . subform1331) (begin (let ((x1335 who1334)) (if (not ((lambda (x1336) (let ((t1337 (not x1336))) (if t1337 t1337 (let ((t1338 (string? x1336))) (if t1338 t1338 (symbol? x1336)))))) x1335)) (syntax-violation (quote syntax-violation) "invalid argument" x1335))) (let ((x1339 message1333)) (if (not (string? x1339)) (syntax-violation (quote syntax-violation) "invalid argument" x1339))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1334 "~a: " "") "~a " (if (null? subform1331) "in ~a" "in subform `~s' of `~s'")) (let ((tail1340 (cons message1333 (map (lambda (x1341) (strip161 x1341 (quote (())))) (append subform1331 (list form1332)))))) (if who1334 (cons who1334 tail1340) tail1340)) #f)))) (letrec ((match1346 (lambda (e1347 p1348 w1349 r1350 mod1351) (if (not r1350) #f (if (eq? p1348 (quote any)) (cons (wrap142 e1347 w1349 mod1351) r1350) (if (syntax-object?98 e1347) (match*1345 (let ((e1352 (syntax-object-expression99 e1347))) (if (annotation? e1352) (annotation-expression e1352) e1352)) p1348 (join-wraps133 w1349 (syntax-object-wrap100 e1347)) r1350 (syntax-object-module101 e1347)) (match*1345 (let ((e1353 e1347)) (if (annotation? e1353) (annotation-expression e1353) e1353)) p1348 w1349 r1350 mod1351)))))) (match*1345 (lambda (e1354 p1355 w1356 r1357 mod1358) (if (null? p1355) (if (null? e1354) r1357 #f) (if (pair? p1355) (if (pair? e1354) (match1346 (car e1354) (car p1355) w1356 (match1346 (cdr e1354) (cdr p1355) w1356 r1357 mod1358) mod1358) #f) (if (eq? p1355 (quote each-any)) (let ((l1359 (match-each-any1343 e1354 w1356 mod1358))) (if l1359 (cons l1359 r1357) #f)) (let ((atom-key1360 (vector-ref p1355 0))) (if (memv atom-key1360 (quote (each))) (if (null? e1354) (match-empty1344 (vector-ref p1355 1) r1357) (let ((l1361 (match-each1342 e1354 (vector-ref p1355 1) w1356 mod1358))) (if l1361 (letrec ((collect1362 (lambda (l1363) (if (null? (car l1363)) r1357 (cons (map car l1363) (collect1362 (map cdr l1363))))))) (collect1362 l1361)) #f))) (if (memv atom-key1360 (quote (free-id))) (if (id?114 e1354) (if (free-id=?137 (wrap142 e1354 w1356 mod1358) (vector-ref p1355 1)) r1357 #f) #f) (if (memv atom-key1360 (quote (atom))) (if (equal? (vector-ref p1355 1) (strip161 e1354 w1356)) r1357 #f) (if (memv atom-key1360 (quote (vector))) (if (vector? e1354) (match1346 (vector->list e1354) (vector-ref p1355 1) w1356 r1357 mod1358) #f))))))))))) (match-empty1344 (lambda (p1364 r1365) (if (null? p1364) r1365 (if (eq? p1364 (quote any)) (cons (quote ()) r1365) (if (pair? p1364) (match-empty1344 (car p1364) (match-empty1344 (cdr p1364) r1365)) (if (eq? p1364 (quote each-any)) (cons (quote ()) r1365) (let ((atom-key1366 (vector-ref p1364 0))) (if (memv atom-key1366 (quote (each))) (match-empty1344 (vector-ref p1364 1) r1365) (if (memv atom-key1366 (quote (free-id atom))) r1365 (if (memv atom-key1366 (quote (vector))) (match-empty1344 (vector-ref p1364 1) r1365))))))))))) (match-each-any1343 (lambda (e1367 w1368 mod1369) (if (annotation? e1367) (match-each-any1343 (annotation-expression e1367) w1368 mod1369) (if (pair? e1367) (let ((l1370 (match-each-any1343 (cdr e1367) w1368 mod1369))) (if l1370 (cons (wrap142 (car e1367) w1368 mod1369) l1370) #f)) (if (null? e1367) (quote ()) (if (syntax-object?98 e1367) (match-each-any1343 (syntax-object-expression99 e1367) (join-wraps133 w1368 (syntax-object-wrap100 e1367)) mod1369) #f)))))) (match-each1342 (lambda (e1371 p1372 w1373 mod1374) (if (annotation? e1371) (match-each1342 (annotation-expression e1371) p1372 w1373 mod1374) (if (pair? e1371) (let ((first1375 (match1346 (car e1371) p1372 w1373 (quote ()) mod1374))) (if first1375 (let ((rest1376 (match-each1342 (cdr e1371) p1372 w1373 mod1374))) (if rest1376 (cons first1375 rest1376) #f)) #f)) (if (null? e1371) (quote ()) (if (syntax-object?98 e1371) (match-each1342 (syntax-object-expression99 e1371) p1372 (join-wraps133 w1373 (syntax-object-wrap100 e1371)) (syntax-object-module101 e1371)) #f))))))) (set! $sc-dispatch (lambda (e1377 p1378) (if (eq? p1378 (quote any)) (list e1377) (if (syntax-object?98 e1377) (match*1345 (let ((e1379 (syntax-object-expression99 e1377))) (if (annotation? e1379) (annotation-expression e1379) e1379)) p1378 (syntax-object-wrap100 e1377) (quote ()) (syntax-object-module101 e1377)) (match*1345 (let ((e1380 e1377)) (if (annotation? e1380) (annotation-expression e1380) e1380)) p1378 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1381) ((lambda (tmp1382) ((lambda (tmp1383) (if tmp1383 (apply (lambda (_1384 e11385 e21386) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11385 e21386))) tmp1383) ((lambda (tmp1388) (if tmp1388 (apply (lambda (_1389 out1390 in1391 e11392 e21393) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1391 (quote ()) (list out1390 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11392 e21393))))) tmp1388) ((lambda (tmp1395) (if tmp1395 (apply (lambda (_1396 out1397 in1398 e11399 e21400) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1398) (quote ()) (list out1397 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11399 e21400))))) tmp1395) (syntax-violation #f "source expression failed to match any pattern" tmp1382))) ($sc-dispatch tmp1382 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1382 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1382 (quote (any () any . each-any))))) x1381)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1404) ((lambda (tmp1405) ((lambda (tmp1406) (if tmp1406 (apply (lambda (_1407 k1408 keyword1409 pattern1410 template1411) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1408 (map (lambda (tmp1414 tmp1413) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1413) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1414))) template1411 pattern1410)))))) tmp1406) (syntax-violation #f "source expression failed to match any pattern" tmp1405))) ($sc-dispatch tmp1405 (quote (any each-any . #(each ((any . any) any))))))) x1404)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1415) ((lambda (tmp1416) ((lambda (tmp1417) (if (if tmp1417 (apply (lambda (let*1418 x1419 v1420 e11421 e21422) (and-map identifier? x1419)) tmp1417) #f) (apply (lambda (let*1424 x1425 v1426 e11427 e21428) (letrec ((f1429 (lambda (bindings1430) (if (null? bindings1430) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11427 e21428))) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (body1436 binding1437) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1437) body1436)) tmp1435) (syntax-violation #f "source expression failed to match any pattern" tmp1434))) ($sc-dispatch tmp1434 (quote (any any))))) (list (f1429 (cdr bindings1430)) (car bindings1430))))))) (f1429 (map list x1425 v1426)))) tmp1417) (syntax-violation #f "source expression failed to match any pattern" tmp1416))) ($sc-dispatch tmp1416 (quote (any #(each (any any)) any . each-any))))) x1415)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1438) ((lambda (tmp1439) ((lambda (tmp1440) (if tmp1440 (apply (lambda (_1441 var1442 init1443 step1444 e01445 e11446 c1447) ((lambda (tmp1448) ((lambda (tmp1449) (if tmp1449 (apply (lambda (step1450) ((lambda (tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1442 init1443) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01445) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1447 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1450))))))) tmp1452) ((lambda (tmp1457) (if tmp1457 (apply (lambda (e11458 e21459) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1442 init1443) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01445 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11458 e21459)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1447 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1450))))))) tmp1457) (syntax-violation #f "source expression failed to match any pattern" tmp1451))) ($sc-dispatch tmp1451 (quote (any . each-any)))))) ($sc-dispatch tmp1451 (quote ())))) e11446)) tmp1449) (syntax-violation #f "source expression failed to match any pattern" tmp1448))) ($sc-dispatch tmp1448 (quote each-any)))) (map (lambda (v1466 s1467) ((lambda (tmp1468) ((lambda (tmp1469) (if tmp1469 (apply (lambda () v1466) tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda (e1471) e1471) tmp1470) ((lambda (_1472) (syntax-violation (quote do) "bad step expression" orig-x1438 s1467)) tmp1468))) ($sc-dispatch tmp1468 (quote (any)))))) ($sc-dispatch tmp1468 (quote ())))) s1467)) var1442 step1444))) tmp1440) (syntax-violation #f "source expression failed to match any pattern" tmp1439))) ($sc-dispatch tmp1439 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1438)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1475 (lambda (x1479 y1480) ((lambda (tmp1481) ((lambda (tmp1482) (if tmp1482 (apply (lambda (x1483 y1484) ((lambda (tmp1485) ((lambda (tmp1486) (if tmp1486 (apply (lambda (dy1487) ((lambda (tmp1488) ((lambda (tmp1489) (if tmp1489 (apply (lambda (dx1490) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1490 dy1487))) tmp1489) ((lambda (_1491) (if (null? dy1487) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483 y1484))) tmp1488))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1483)) tmp1486) ((lambda (tmp1492) (if tmp1492 (apply (lambda (stuff1493) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1483 stuff1493))) tmp1492) ((lambda (else1494) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483 y1484)) tmp1485))) ($sc-dispatch tmp1485 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1485 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1484)) tmp1482) (syntax-violation #f "source expression failed to match any pattern" tmp1481))) ($sc-dispatch tmp1481 (quote (any any))))) (list x1479 y1480)))) (quasiappend1476 (lambda (x1495 y1496) ((lambda (tmp1497) ((lambda (tmp1498) (if tmp1498 (apply (lambda (x1499 y1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda () x1499) tmp1502) ((lambda (_1503) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1499 y1500)) tmp1501))) ($sc-dispatch tmp1501 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1500)) tmp1498) (syntax-violation #f "source expression failed to match any pattern" tmp1497))) ($sc-dispatch tmp1497 (quote (any any))))) (list x1495 y1496)))) (quasivector1477 (lambda (x1504) ((lambda (tmp1505) ((lambda (x1506) ((lambda (tmp1507) ((lambda (tmp1508) (if tmp1508 (apply (lambda (x1509) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1509))) tmp1508) ((lambda (tmp1511) (if tmp1511 (apply (lambda (x1512) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1512)) tmp1511) ((lambda (_1514) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1506)) tmp1507))) ($sc-dispatch tmp1507 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1507 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1506)) tmp1505)) x1504))) (quasi1478 (lambda (p1515 lev1516) ((lambda (tmp1517) ((lambda (tmp1518) (if tmp1518 (apply (lambda (p1519) (if (= lev1516 0) p1519 (quasicons1475 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1478 (list p1519) (- lev1516 1))))) tmp1518) ((lambda (tmp1520) (if (if tmp1520 (apply (lambda (args1521) (= lev1516 0)) tmp1520) #f) (apply (lambda (args1522) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1515 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1522))) tmp1520) ((lambda (tmp1523) (if tmp1523 (apply (lambda (p1524 q1525) (if (= lev1516 0) (quasiappend1476 p1524 (quasi1478 q1525 lev1516)) (quasicons1475 (quasicons1475 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1478 (list p1524) (- lev1516 1))) (quasi1478 q1525 lev1516)))) tmp1523) ((lambda (tmp1526) (if (if tmp1526 (apply (lambda (args1527 q1528) (= lev1516 0)) tmp1526) #f) (apply (lambda (args1529 q1530) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1515 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1529))) tmp1526) ((lambda (tmp1531) (if tmp1531 (apply (lambda (p1532) (quasicons1475 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1478 (list p1532) (+ lev1516 1)))) tmp1531) ((lambda (tmp1533) (if tmp1533 (apply (lambda (p1534 q1535) (quasicons1475 (quasi1478 p1534 lev1516) (quasi1478 q1535 lev1516))) tmp1533) ((lambda (tmp1536) (if tmp1536 (apply (lambda (x1537) (quasivector1477 (quasi1478 x1537 lev1516))) tmp1536) ((lambda (p1539) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1539)) tmp1517))) ($sc-dispatch tmp1517 (quote #(vector each-any)))))) ($sc-dispatch tmp1517 (quote (any . any)))))) ($sc-dispatch tmp1517 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1517 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1517 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1517 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1517 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1515)))) (lambda (x1540) ((lambda (tmp1541) ((lambda (tmp1542) (if tmp1542 (apply (lambda (_1543 e1544) (quasi1478 e1544 0)) tmp1542) (syntax-violation #f "source expression failed to match any pattern" tmp1541))) ($sc-dispatch tmp1541 (quote (any any))))) x1540))))) +(define include (make-syncase-macro (quote macro) (lambda (x1545) (letrec ((read-file1546 (lambda (fn1547 k1548) (let ((p1549 (open-input-file fn1547))) (letrec ((f1550 (lambda (x1551) (if (eof-object? x1551) (begin (close-input-port p1549) (quote ())) (cons (datum->syntax k1548 x1551) (f1550 (read p1549))))))) (f1550 (read p1549))))))) ((lambda (tmp1552) ((lambda (tmp1553) (if tmp1553 (apply (lambda (k1554 filename1555) (let ((fn1556 (syntax->datum filename1555))) ((lambda (tmp1557) ((lambda (tmp1558) (if tmp1558 (apply (lambda (exp1559) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1559)) tmp1558) (syntax-violation #f "source expression failed to match any pattern" tmp1557))) ($sc-dispatch tmp1557 (quote each-any)))) (read-file1546 fn1556 k1554)))) tmp1553) (syntax-violation #f "source expression failed to match any pattern" tmp1552))) ($sc-dispatch tmp1552 (quote (any any))))) x1545))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1561) ((lambda (tmp1562) ((lambda (tmp1563) (if tmp1563 (apply (lambda (_1564 e1565) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1561)) tmp1563) (syntax-violation #f "source expression failed to match any pattern" tmp1562))) ($sc-dispatch tmp1562 (quote (any any))))) x1561)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1566) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569 e1570) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1566)) tmp1568) (syntax-violation #f "source expression failed to match any pattern" tmp1567))) ($sc-dispatch tmp1567 (quote (any any))))) x1566)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1571) ((lambda (tmp1572) ((lambda (tmp1573) (if tmp1573 (apply (lambda (_1574 e1575 m11576 m21577) ((lambda (tmp1578) ((lambda (body1579) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1575)) body1579)) tmp1578)) (letrec ((f1580 (lambda (clause1581 clauses1582) (if (null? clauses1582) ((lambda (tmp1584) ((lambda (tmp1585) (if tmp1585 (apply (lambda (e11586 e21587) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11586 e21587))) tmp1585) ((lambda (tmp1589) (if tmp1589 (apply (lambda (k1590 e11591 e21592) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1590)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11591 e21592)))) tmp1589) ((lambda (_1595) (syntax-violation (quote case) "bad clause" x1571 clause1581)) tmp1584))) ($sc-dispatch tmp1584 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1584 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1581) ((lambda (tmp1596) ((lambda (rest1597) ((lambda (tmp1598) ((lambda (tmp1599) (if tmp1599 (apply (lambda (k1600 e11601 e21602) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1600)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11601 e21602)) rest1597)) tmp1599) ((lambda (_1605) (syntax-violation (quote case) "bad clause" x1571 clause1581)) tmp1598))) ($sc-dispatch tmp1598 (quote (each-any any . each-any))))) clause1581)) tmp1596)) (f1580 (car clauses1582) (cdr clauses1582))))))) (f1580 m11576 m21577)))) tmp1573) (syntax-violation #f "source expression failed to match any pattern" tmp1572))) ($sc-dispatch tmp1572 (quote (any any any . each-any))))) x1571)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1606) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (_1609 e1610) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1610)) (list (cons _1609 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1610 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1608) (syntax-violation #f "source expression failed to match any pattern" tmp1607))) ($sc-dispatch tmp1607 (quote (any any))))) x1606)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index bbae73b3c..dcbc32a0d 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -435,10 +435,23 @@ ((c) ((@ (language tree-il) make-toplevel-set) source var exp)) (else `(set! ,var ,exp))))))) +;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz) +;; from working. Hack around it. +(define (maybe-name-value! name val) + (cond + (((@ (language tree-il) lambda?) val) + (let ((meta ((@ (language tree-il) lambda-meta) val))) + (if (not (assq 'name meta)) + ((setter (@ (language tree-il) lambda-meta)) + val + (acons 'name name meta))))))) + (define build-global-definition (lambda (source var exp) (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-toplevel-define) source var exp)) + ((c) + (maybe-name-value! var exp) + ((@ (language tree-il) make-toplevel-define) source var exp)) (else `(define ,var ,exp))))) (define build-lambda @@ -480,7 +493,9 @@ (if (null? vars) body-exp (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) (else `(let ,(map list vars val-exps) ,body-exp)))))) (define build-named-let @@ -490,12 +505,14 @@ (vars (cdr vars)) (ids (cdr ids))) (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-letrec) src - (list f-name) - (list f) - (list (build-lambda src ids vars #f body-exp)) - (build-application src (build-lexical-reference 'fun src f-name f) - val-exps))) + ((c) + (let ((proc (build-lambda src ids vars #f body-exp))) + (maybe-name-value! f-name proc) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src + (list f-name) (list f) (list proc) + (build-application src (build-lexical-reference 'fun src f-name f) + val-exps)))) (else `(let ,f ,(map list vars val-exps) ,body-exp)))))) (define build-letrec @@ -503,7 +520,9 @@ (if (null? vars) body-exp (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) (else `(letrec ,(map list vars val-exps) ,body-exp)))))) ;; FIXME: wingo: use make-lexical ? @@ -1819,13 +1838,14 @@ (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) + (and-map id? (syntax (id ...))) (chi-let e r w s mod build-let (syntax (id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) ((_ f ((id val) ...) e1 e2 ...) - (id? (syntax f)) + (and (id? (syntax f)) (and-map id? (syntax (id ...)))) (chi-let e r w s mod build-named-let (syntax (f id ...)) @@ -1838,6 +1858,7 @@ (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) + (and-map id? (syntax (id ...))) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) (syntax-violation 'letrec "duplicate bound variable" e) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 69c8fbf46..15f8602cf 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -40,16 +40,22 @@ (define exception:illegal-empty-combination (cons 'syntax-error "Illegal empty combination")) +(define exception:bad-lambda + '(syntax-error . "bad lambda")) +(define exception:bad-let + '(syntax-error . "bad let ")) +(define exception:bad-letrec + '(syntax-error . "bad letrec ")) (define exception:bad-bindings (cons 'syntax-error "Bad bindings")) (define exception:bad-binding (cons 'syntax-error "Bad binding")) (define exception:duplicate-binding - (cons 'syntax-error "Duplicate binding")) + (cons 'syntax-error "duplicate bound variable")) (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals - (cons 'syntax-error "Bad formals")) + '(syntax-error . "invalid parameter list")) (define exception:bad-formal (cons 'syntax-error "Bad formal")) (define exception:duplicate-formal @@ -176,17 +182,17 @@ (with-test-prefix "bad formals" (pass-if-exception "(lambda)" - exception:missing-expr + exception:bad-lambda (eval '(lambda) (interaction-environment))) (pass-if-exception "(lambda . \"foo\")" - exception:bad-expression + exception:bad-lambda (eval '(lambda . "foo") (interaction-environment))) (pass-if-exception "(lambda \"foo\")" - exception:missing-expr + exception:bad-lambda (eval '(lambda "foo") (interaction-environment))) @@ -196,22 +202,22 @@ (interaction-environment))) (pass-if-exception "(lambda (x 1) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x 1) 2) (interaction-environment))) (pass-if-exception "(lambda (1 x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (1 x) 2) (interaction-environment))) (pass-if-exception "(lambda (x \"a\") 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x "a") 2) (interaction-environment))) (pass-if-exception "(lambda (\"a\" x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda ("a" x) 2) (interaction-environment)))) @@ -219,20 +225,20 @@ ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x) 1) (interaction-environment))) ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x x) 1) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(lambda ())" - exception:missing-expr + exception:bad-lambda (eval '(lambda ()) (interaction-environment))))) @@ -242,9 +248,8 @@ (pass-if "normal let" (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -255,42 +260,42 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let)" - exception:missing-expr + exception:bad-let (eval '(let) (interaction-environment))) (pass-if-exception "(let 1)" - exception:missing-expr + exception:bad-let (eval '(let 1) (interaction-environment))) (pass-if-exception "(let (x))" - exception:missing-expr + exception:bad-let (eval '(let (x)) (interaction-environment))) (pass-if-exception "(let ((x)))" - exception:missing-expr + exception:bad-let (eval '(let ((x))) (interaction-environment))) (pass-if-exception "(let (x) 1)" - exception:bad-binding + exception:bad-let (eval '(let (x) 1) (interaction-environment))) (pass-if-exception "(let ((x)) 3)" - exception:bad-binding + exception:bad-let (eval '(let ((x)) 3) (interaction-environment))) (pass-if-exception "(let ((x 1) y) x)" - exception:bad-binding + exception:bad-let (eval '(let ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let ((1 2)) 3)" - exception:bad-variable + exception:bad-let (eval '(let ((1 2)) 3) (interaction-environment)))) @@ -304,12 +309,12 @@ (with-test-prefix "bad body" (pass-if-exception "(let ())" - exception:missing-expr + exception:bad-let (eval '(let ()) (interaction-environment))) (pass-if-exception "(let ((x 1)))" - exception:missing-expr + exception:bad-let (eval '(let ((x 1))) (interaction-environment))))) @@ -324,19 +329,19 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let x (y))" - exception:missing-expr + exception:bad-let (eval '(let x (y)) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let x ())" - exception:missing-expr + exception:bad-let (eval '(let x ()) (interaction-environment))) (pass-if-exception "(let x ((y 1)))" - exception:missing-expr + exception:bad-let (eval '(let x ((y 1))) (interaction-environment))))) @@ -346,19 +351,16 @@ (pass-if "normal let*" (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let* ((x 1) (y 2)) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _))))))) (pass-if "let* without bindings" (let ((foo (lambda () (let ((x 1) (y 2)) (let* () (and (= x 1) (= y 2))))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((x 1) (y 2)) - (let* () - (and (= x 1) (= y 2))))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) + (if (= _ 1) (= _ 2) #f))))))) (with-test-prefix "bindings" @@ -378,59 +380,59 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let*)" - exception:missing-expr + exception:generic-syncase-error (eval '(let*) (interaction-environment))) (pass-if-exception "(let* 1)" - exception:missing-expr + exception:generic-syncase-error (eval '(let* 1) (interaction-environment))) (pass-if-exception "(let* (x))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* (x)) (interaction-environment))) (pass-if-exception "(let* (x) 1)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* (x) 1) (interaction-environment))) (pass-if-exception "(let* ((x)) 3)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x)) 3) (interaction-environment))) (pass-if-exception "(let* ((x 1) y) x)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let* x ())" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x ()) (interaction-environment))) (pass-if-exception "(let* x (y))" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x (y)) (interaction-environment))) (pass-if-exception "(let* ((1 2)) 3)" - exception:bad-variable + exception:generic-syncase-error (eval '(let* ((1 2)) 3) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let* ())" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ()) (interaction-environment))) (pass-if-exception "(let* ((x 1)))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ((x 1))) (interaction-environment))))) @@ -440,9 +442,8 @@ (pass-if "normal letrec" (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (letrec ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (letrec ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -454,47 +455,47 @@ (with-test-prefix "bad bindings" (pass-if-exception "(letrec)" - exception:missing-expr + exception:bad-letrec (eval '(letrec) (interaction-environment))) (pass-if-exception "(letrec 1)" - exception:missing-expr + exception:bad-letrec (eval '(letrec 1) (interaction-environment))) (pass-if-exception "(letrec (x))" - exception:missing-expr + exception:bad-letrec (eval '(letrec (x)) (interaction-environment))) (pass-if-exception "(letrec (x) 1)" - exception:bad-binding + exception:bad-letrec (eval '(letrec (x) 1) (interaction-environment))) (pass-if-exception "(letrec ((x)) 3)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x)) 3) (interaction-environment))) (pass-if-exception "(letrec ((x 1) y) x)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x 1) y) x) (interaction-environment))) (pass-if-exception "(letrec x ())" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x ()) (interaction-environment))) (pass-if-exception "(letrec x (y))" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x (y)) (interaction-environment))) (pass-if-exception "(letrec ((1 2)) 3)" - exception:bad-variable + exception:bad-letrec (eval '(letrec ((1 2)) 3) (interaction-environment)))) @@ -508,12 +509,12 @@ (with-test-prefix "bad body" (pass-if-exception "(letrec ())" - exception:missing-expr + exception:bad-letrec (eval '(letrec ()) (interaction-environment))) (pass-if-exception "(letrec ((x 1)))" - exception:missing-expr + exception:bad-letrec (eval '(letrec ((x 1))) (interaction-environment))))) @@ -525,17 +526,17 @@ (let ((foo (lambda (x) (if x (+ 1) (+ 2))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (if x (+ 1) (+ 2)))))) + (matches? (procedure-source foo) + (lambda (_) (if _ (+ 1) (+ 2)))))) - (pass-if "if without else" + (expect-fail "if without else" (let ((foo (lambda (x) (if x (+ 1))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed (equal? (procedure-source foo) '(lambda (x) (if x (+ 1)))))) - (pass-if "if #f without else" + (expect-fail "if #f without else" (let ((foo (lambda () (if #f #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) @@ -544,12 +545,12 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(if)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if) (interaction-environment))) (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if 1 2 3 4) (interaction-environment))))) @@ -611,78 +612,77 @@ (eq? 'ok (cond (#t identity =>) (else #f))))) (pass-if-exception "missing recipient" - '(syntax-error . "Missing recipient") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity =>))) (pass-if-exception "extra recipient" - '(syntax-error . "Extra expression") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity => identity identity)))) (with-test-prefix "unmemoization" + ;; FIXME: the (if #f #f) is a hack! (pass-if "normal clauses" - (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed + (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz))))) (equal? (procedure-source foo) - '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))) + '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f))))))) (pass-if "else" (let ((foo (lambda () (cond (else 'bar))))) - (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (cond (else 'bar)))))) + '(lambda () 'bar)))) + ;; FIXME: the (if #f #f) is a hack! (pass-if "=>" (let ((foo (lambda () (cond (#t => identity))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (cond (#t => identity))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ #t)) + (if _ (identity _) (if #f #f)))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(cond)" - exception:missing-clauses + exception:generic-syncase-error (eval '(cond) (interaction-environment))) (pass-if-exception "(cond #t)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond #t) (interaction-environment))) (pass-if-exception "(cond 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1) (interaction-environment))) (pass-if-exception "(cond 1 2)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2) (interaction-environment))) (pass-if-exception "(cond 1 2 3)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3) (interaction-environment))) (pass-if-exception "(cond 1 2 3 4)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3 4) (interaction-environment))) (pass-if-exception "(cond ())" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond ()) (interaction-environment))) (pass-if-exception "(cond () 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond () 1) (interaction-environment))) (pass-if-exception "(cond (1) 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond (1) 1) (interaction-environment)))) @@ -700,7 +700,7 @@ (with-test-prefix "case is hygienic" (pass-if-exception "bound 'else is handled correctly" - exception:bad-case-labels + exception:generic-syncase-error (eval '(let ((else #f)) (case 1 (else #f))) (interaction-environment)))) @@ -708,79 +708,83 @@ (pass-if "normal clauses" (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '(2)) + 'baz + 'foobar)))))) (pass-if "empty labels" (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '()) + 'baz + 'foobar))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(case)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case) (interaction-environment))) (pass-if-exception "(case . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case . "foo") (interaction-environment))) (pass-if-exception "(case 1)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case 1) (interaction-environment))) (pass-if-exception "(case 1 . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 . "foo") (interaction-environment))) (pass-if-exception "(case 1 \"foo\")" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 "foo") (interaction-environment))) (pass-if-exception "(case 1 ())" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ()) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\"))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ("foo")) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\" \"bar\"))" - exception:bad-case-labels + exception:generic-syncase-error (eval '(case 1 ("foo" "bar")) (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 ((2) "bar") . "foo") (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") (else))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ((2) "bar") (else)) (interaction-environment))) (pass-if-exception "(case 1 (else #f) . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 (else #f) . "foo") (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:misplaced-else-clause + exception:generic-syncase-error (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) From 9ecac781bf3b33abca137c242ceaa7c49f604958 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 12:22:39 +0200 Subject: [PATCH 146/375] syntax.test is passing, yay * test-suite/tests/syntax.test ("top-level define"): Remove the test for currying, as we don't do that any more by default. It should be easy for the user to add in if she wants it, though. ("do"): Remove unmemoization tests, as sc-expand fully expands `do'. ("while"): Remove while tests in empty environments. They have been throwing 'unresolved, and the problem they seek to test is fully handled by hygiene anyway. And otherwise tweak expected exception strings, and everything passes! --- test-suite/tests/syntax.test | 111 +++++++++-------------------------- 1 file changed, 27 insertions(+), 84 deletions(-) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 15f8602cf..aa2e05127 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -34,7 +34,7 @@ (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:missing-body-expr - (cons 'syntax-error "Missing body expression")) + (cons 'syntax-error "no expressions in body")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) (define exception:illegal-empty-combination @@ -46,6 +46,10 @@ '(syntax-error . "bad let ")) (define exception:bad-letrec '(syntax-error . "bad letrec ")) +(define exception:bad-set! + '(syntax-error . "bad set!")) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) (define exception:bad-bindings (cons 'syntax-error "Bad bindings")) (define exception:bad-binding @@ -801,14 +805,6 @@ (eval '(define round round) m) (eq? (module-ref m 'round) round))) - (with-test-prefix "currying" - - (pass-if "(define ((foo)) #f)" - (eval '(begin - (define ((foo)) #t) - ((foo))) - (interaction-environment)))) - (with-test-prefix "unmemoization" (pass-if "definition unmemoized without prior execution" @@ -830,7 +826,7 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(define)" - exception:missing-expr + exception:generic-syncase-error (eval '(define) (interaction-environment))))) @@ -907,34 +903,10 @@ 'ok) (bar)) (foo) - (equal? + (matches? (procedure-source foo) - '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar))))) - (interaction-environment)))) - -(with-test-prefix "do" - - (with-test-prefix "unmemoization" - - (pass-if "normal case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i)))))) - - (pass-if "reduced case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here - ((> i 9) (+ i j)) - (identity i)))))))) + (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))) + (current-module)))) (with-test-prefix "set!" @@ -943,50 +915,50 @@ (pass-if "normal set!" (let ((foo (lambda (x) (set! x (+ 1 x))))) (foo 1) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (set! x (+ 1 x))))))) + (matches? (procedure-source foo) + (lambda (_) (set! _ (+ 1 _))))))) (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr + exception:bad-set! (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1 2 3) (interaction-environment)))) (with-test-prefix "bad variable" (pass-if-exception "(set! \"\" #t)" - exception:bad-variable + exception:bad-set! (eval '(set! "" #t) (interaction-environment))) (pass-if-exception "(set! 1 #t)" - exception:bad-variable + exception:bad-set! (eval '(set! 1 #t) (interaction-environment))) (pass-if-exception "(set! #t #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #t #f) (interaction-environment))) (pass-if-exception "(set! #f #t)" - exception:bad-variable + exception:bad-set! (eval '(set! #f #t) (interaction-environment))) (pass-if-exception "(set! #\\space #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #\space #f) (interaction-environment))))) @@ -995,12 +967,12 @@ (with-test-prefix "missing or extra expression" (pass-if-exception "(quote)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote) (interaction-environment))) (pass-if-exception "(quote a b)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote a b) (interaction-environment))))) @@ -1052,37 +1024,6 @@ (unreachable)) #t) - (with-test-prefix "in empty environment" - - ;; an environment with no bindings at all - (define empty-environment - (make-module 1)) - - ;; these tests are 'unresolved because to work with ice-9 syncase it was - ;; necessary to drop the unquote from `do' in the implementation, and - ;; unfortunately that makes `while' depend on its evaluation environment - - (pass-if "empty body" - (throw 'unresolved) - (eval `(,while #f) - empty-environment) - #t) - - (pass-if "initially false" - (throw 'unresolved) - (eval `(,while #f - #f) - empty-environment) - #t) - - (pass-if "iterating" - (throw 'unresolved) - (let ((cond (make-iterations-cond 3))) - (eval `(,while (,cond) - 123 456) - empty-environment)) - #t)) - (with-test-prefix "iterations" (do ((n 0 (1+ n))) ((> n 5)) @@ -1096,8 +1037,9 @@ (with-test-prefix "break" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (break 1))) + (eval '(while #t + (break 1)) + (interaction-environment))) (with-test-prefix "from cond" (pass-if "first" @@ -1168,8 +1110,9 @@ (with-test-prefix "continue" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (continue 1))) + (eval '(while #t + (continue 1)) + (interaction-environment))) (with-test-prefix "from cond" (do ((n 0 (1+ n))) From 7902c547130235438fa170d94c43e0c271adb71d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 12:45:49 +0200 Subject: [PATCH 147/375] fix expansion of (ice-9 threads) * module/ice-9/threads.scm: Move syntax definitions before the procedures that use them, and rewrite as hygienic macros since they are so much nicer that way. Fixes the thread tests. --- module/ice-9/threads.scm | 114 ++++++++++++++++++++------------------- 1 file changed, 58 insertions(+), 56 deletions(-) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index bd0f7b745..e07d766eb 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -32,21 +32,71 @@ ;;; Code: (define-module (ice-9 threads) - :export (par-map + :export (begin-thread + parallel + letpar + make-thread + with-mutex + monitor + + par-map par-for-each n-par-map n-par-for-each n-for-each-par-map - %thread-handler) - :export-syntax (begin-thread - parallel - letpar - make-thread - with-mutex - monitor)) + %thread-handler)) +;;; Macros first, so that the procedures expand correctly. + +(define-syntax begin-thread + (syntax-rules () + ((_ e0 e1 ...) + (call-with-new-thread + (lambda () e0 e1 ...) + %thread-handler)))) + +(define-syntax parallel + (lambda (x) + (syntax-case x () + ((_ e0 ...) + (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) + (syntax + (let ((tmp0 (begin-thread e0)) + ...) + (values (join-thread tmp0) ...)))))))) + +(define-syntax letpar + (syntax-rules () + ((_ ((v e) ...) b0 b1 ...) + (call-with-values + (lambda () (parallel e ...)) + (lambda (v ...) + b0 b1 ...))))) + +(define-syntax make-thread + (syntax-rules () + ((_ proc arg ...) + (call-with-new-thread + (lambda () (proc arg ...)) + %thread-handler)))) + +(define-syntax with-mutex + (syntax-rules () + ((_ m e0 e1 ...) + (let ((x m)) + (dynamic-wind + (lambda () (lock-mutex x)) + (lambda () (begin e0 e1 ...)) + (lambda () (unlock-mutex x))))))) + +(define-syntax monitor + (syntax-rules () + ((_ first rest ...) + (with-mutex (make-mutex) + first rest ...)))) + (define (par-mapper mapper) (lambda (proc . arglists) (mapper join-thread @@ -171,52 +221,4 @@ of applying P-PROC on ARGLISTS." ;;; Set system thread handler (define %thread-handler thread-handler) -; --- MACROS ------------------------------------------------------- - -(define-macro (begin-thread . forms) - (if (null? forms) - '(begin) - `(call-with-new-thread - (lambda () - ,@forms) - %thread-handler))) - -(define-macro (parallel . forms) - (cond ((null? forms) '(values)) - ((null? (cdr forms)) (car forms)) - (else - (let ((vars (map (lambda (f) - (make-symbol "f")) - forms))) - `((lambda ,vars - (values ,@(map (lambda (v) `(join-thread ,v)) vars))) - ,@(map (lambda (form) `(begin-thread ,form)) forms)))))) - -(define-macro (letpar bindings . body) - (cond ((or (null? bindings) (null? (cdr bindings))) - `(let ,bindings ,@body)) - (else - (let ((vars (map car bindings))) - `((lambda ,vars - ((lambda ,vars ,@body) - ,@(map (lambda (v) `(join-thread ,v)) vars))) - ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings)))))) - -(define-macro (make-thread proc . args) - `(call-with-new-thread - (lambda () - (,proc ,@args)) - %thread-handler)) - -(define-macro (with-mutex m . body) - `(dynamic-wind - (lambda () (lock-mutex ,m)) - (lambda () (begin ,@body)) - (lambda () (unlock-mutex ,m)))) - -(define-macro (monitor first . rest) - `(with-mutex ,(make-mutex) - (begin - ,first ,@rest))) - ;;; threads.scm ends here From e6b94431794ad5cffedfbdbe949789d04ef97761 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 12:48:45 +0200 Subject: [PATCH 148/375] fix bad call to make-glil-src * module/language/tree-il/compile-glil.scm (flatten-lambda): Fix bad call to make-glil-src, unfortunately not hit during production because psyntax doesn't yet understand source locations. --- module/language/tree-il/compile-glil.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index d476ddef9..1bd658787 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -129,7 +129,7 @@ ;; write bindings and source debugging info (emit-bindings #f ids vars allocation emit-code) (if (lambda-src x) - (emit-code (make-glil-src (lambda-src x)))) + (emit-code (make-glil-source (lambda-src x)))) ;; copy args to the heap if necessary (let lp ((in vars) (n 0)) From e0c90f9084914956d90db73b21ef2ab32d1a477a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 13:00:23 +0200 Subject: [PATCH 149/375] fix tree-il test to work if source info happens to be present * module/language/tree-il/compile-glil.scm (flatten-lambda): Fix source emission. * test-suite/tests/tree-il.test (strip-source): Strip source info on tree-il before compiling, so we don't get extraneous source info in the glil. Make check passes! --- module/language/tree-il/compile-glil.scm | 2 +- test-suite/tests/tree-il.test | 16 ++++++++++++---- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 1bd658787..94ace7e53 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -129,7 +129,7 @@ ;; write bindings and source debugging info (emit-bindings #f ids vars allocation emit-code) (if (lambda-src x) - (emit-code (make-glil-source (lambda-src x)))) + (emit-code #f (make-glil-source (lambda-src x)))) ;; copy args to the heap if necessary (let lp ((in vars) (n 0)) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index eb33ae77f..18b67d6c8 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -24,10 +24,19 @@ #:use-module (language tree-il) #:use-module (language glil)) +;; Of course, the GLIL that is emitted depends on the source info of the +;; input. Here we're not concerned about that, so we strip source +;; information from the incoming tree-il. + +(define (strip-source x) + (post-order! (lambda (x) (set! (tree-il-src x) #f)) + x)) + (define-syntax assert-scheme->glil (syntax-rules () ((_ in out) - (let ((tree-il (compile 'in #:from 'scheme #:to 'tree-il))) + (let ((tree-il (strip-source + (compile 'in #:from 'scheme #:to 'tree-il)))) (pass-if 'in (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) 'out)))))) @@ -36,7 +45,7 @@ (syntax-rules () ((_ in out) (pass-if 'in - (let ((tree-il (parse-tree-il 'in))) + (let ((tree-il (strip-source (parse-tree-il 'in)))) (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) 'out)))))) @@ -46,13 +55,12 @@ (let ((exp 'in)) (pass-if 'in (let ((glil (unparse-glil - (compile (parse-tree-il exp) + (compile (strip-source (parse-tree-il exp)) #:from 'tree-il #:to 'glil)))) (pmatch glil (pat (guard test ...) #t) (else #f)))))))) - (with-test-prefix "void" (assert-tree-il->glil (void) From 55ae815b62c5d4bf324351d64919bdb8d4070148 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 16:07:41 +0200 Subject: [PATCH 150/375] move things to (language tree-il primitives) * module/language/tree-il/optimize.scm: * module/language/tree-il/primitives.scm: Move primitive-related things to primitive.scm from inline.scm and optimize.scm. * module/Makefile.am: Update for inventory changes. --- module/Makefile.am | 2 +- module/language/tree-il/optimize.scm | 54 +----------------- .../tree-il/{inline.scm => primitives.scm} | 57 ++++++++++++++++++- 3 files changed, 58 insertions(+), 55 deletions(-) rename module/language/tree-il/{inline.scm => primitives.scm} (76%) diff --git a/module/Makefile.am b/module/Makefile.am index 22a95626d..35959e294 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -72,7 +72,7 @@ SCHEME_LANG_SOURCES = \ language/scheme/inline.scm TREE_IL_LANG_SOURCES = \ - language/tree-il/inline.scm \ + language/tree-il/primitives.scm \ language/tree-il/optimize.scm \ language/tree-il/analyze.scm \ language/tree-il/compile-glil.scm \ diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 9ba384f4f..3a02e021e 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -20,10 +20,9 @@ ;;; Code: (define-module (language tree-il optimize) - #:use-module (system base syntax) #:use-module (language tree-il) - #:use-module (language tree-il inline) - #:export (optimize! add-interesting-primitive!)) + #:use-module (language tree-il primitives) + #:export (optimize!)) (define (env-module e) (if e (car e) (current-module))) @@ -41,52 +40,3 @@ ;; * degenerate case optimizations ;; * "fixing letrec" -(define *interesting-primitive-names* - '(apply @apply - call-with-values @call-with-values - call-with-current-continuation @call-with-current-continuation - call/cc - values - eq? eqv? equal? - = < > <= >= zero? - + * - / 1- 1+ quotient remainder modulo - not - pair? null? list? acons cons cons* - - list vector - - car cdr - set-car! set-cdr! - - caar cadr cdar cddr - - caaar caadr cadar caddr cdaar cdadr cddar cdddr - - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) - -(define (add-interesting-primitive! name) - (hashq-set! *interesting-primitive-vars* - (module-variable (current-module) name) name)) - -(define *interesting-primitive-vars* (make-hash-table)) - -(for-each add-interesting-primitive! *interesting-primitive-names*) - -(define (resolve-primitives! x mod) - (post-order! - (lambda (x) - (record-case x - (( src name) - (and (hashq-ref *interesting-primitive-vars* - (module-variable mod name)) - (make-primitive-ref src name))) - (( src mod name public?) - ;; for the moment, we're disabling primitive resolution for - ;; public refs because resolve-interface can raise errors. - (let ((m (and (not public?) (resolve-module mod)))) - (and m (hashq-ref *interesting-primitive-vars* - (module-variable m name)) - (make-primitive-ref src name)))) - (else #f))) - x)) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/primitives.scm similarity index 76% rename from module/language/tree-il/inline.scm rename to module/language/tree-il/primitives.scm index 5a8e2db30..25fd8c79e 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/primitives.scm @@ -19,11 +19,64 @@ ;;; Code: -(define-module (language tree-il inline) +(define-module (language tree-il primitives) #:use-module (system base syntax) #:use-module (language tree-il) #:use-module (srfi srfi-16) - #:export (expand-primitives!)) + #:export (resolve-primitives! add-interesting-primitive! + expand-primitives!)) + +(define *interesting-primitive-names* + '(apply @apply + call-with-values @call-with-values + call-with-current-continuation @call-with-current-continuation + call/cc + values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + + list vector + + car cdr + set-car! set-cdr! + + caar cadr cdar cddr + + caaar caadr cadar caddr cdaar cdadr cddar cdddr + + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) + +(define (add-interesting-primitive! name) + (hashq-set! *interesting-primitive-vars* + (module-variable (current-module) name) name)) + +(define *interesting-primitive-vars* (make-hash-table)) + +(for-each add-interesting-primitive! *interesting-primitive-names*) + +(define (resolve-primitives! x mod) + (post-order! + (lambda (x) + (record-case x + (( src name) + (and (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (make-primitive-ref src name))) + (( src mod name public?) + ;; for the moment, we're disabling primitive resolution for + ;; public refs because resolve-interface can raise errors. + (let ((m (and (not public?) (resolve-module mod)))) + (and m (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (make-primitive-ref src name)))) + (else #f))) + x)) + + (define *primitive-expand-table* (make-hash-table)) From 39a2eca2ce7461108ddc595cb74a6bf47c456bd8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 19:26:58 +0200 Subject: [PATCH 151/375] fix problem naming internal definitions * module/ice-9/psyntax.scm (chi-body): Fix a problem introduced in dc1eed52f71, that internal syntax definitions were included in the id lis along with value definitions. Only showed up on a second bootstrap. Psyntax, how I love thee. * module/ice-9/psyntax-pp.scm --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 12 +++++++----- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index b5347f240..e0b545a76 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list163 (lambda (vars292) (letrec ((lvl293 (lambda (vars294 ls295 w296) (if (pair? vars294) (lvl293 (cdr vars294) (cons (wrap142 (car vars294) w296 #f) ls295) w296) (if (id?114 vars294) (cons (wrap142 vars294 w296 #f) ls295) (if (null? vars294) ls295 (if (syntax-object?98 vars294) (lvl293 (syntax-object-expression99 vars294) ls295 (join-wraps133 w296 (syntax-object-wrap100 vars294))) (if (annotation? vars294) (lvl293 (annotation-expression vars294) ls295 w296) (cons vars294 ls295))))))))) (lvl293 vars292 (quote ()) (quote (())))))) (gen-var162 (lambda (id297) (let ((id298 (if (syntax-object?98 id297) (syntax-object-expression99 id297) id297))) (if (annotation? id298) (gensym (symbol->string (annotation-expression id298))) (gensym (symbol->string id298)))))) (strip161 (lambda (x299 w300) (if (memq (quote top) (wrap-marks117 w300)) (if (let ((t301 (annotation? x299))) (if t301 t301 (if (pair? x299) (annotation? (car x299)) #f))) (strip-annotation160 x299 #f) x299) (letrec ((f302 (lambda (x303) (if (syntax-object?98 x303) (strip161 (syntax-object-expression99 x303) (syntax-object-wrap100 x303)) (if (pair? x303) (let ((a304 (f302 (car x303))) (d305 (f302 (cdr x303)))) (if (if (eq? a304 (car x303)) (eq? d305 (cdr x303)) #f) x303 (cons a304 d305))) (if (vector? x303) (let ((old306 (vector->list x303))) (let ((new307 (map f302 old306))) (if (and-map*17 eq? old306 new307) x303 (list->vector new307)))) x303)))))) (f302 x299))))) (strip-annotation160 (lambda (x308 parent309) (if (pair? x308) (let ((new310 (cons #f #f))) (begin (if parent309 (set-annotation-stripped! parent309 new310)) (set-car! new310 (strip-annotation160 (car x308) #f)) (set-cdr! new310 (strip-annotation160 (cdr x308) #f)) new310)) (if (annotation? x308) (let ((t311 (annotation-stripped x308))) (if t311 t311 (strip-annotation160 (annotation-expression x308) x308))) (if (vector? x308) (let ((new312 (make-vector (vector-length x308)))) (begin (if parent309 (set-annotation-stripped! parent309 new312)) (letrec ((loop313 (lambda (i314) (unless (fx<75 i314 0) (vector-set! new312 i314 (strip-annotation160 (vector-ref x308 i314) #f)) (loop313 (fx-73 i314 1)))))) (loop313 (- (vector-length x308) 1))) new312)) x308))))) (ellipsis?159 (lambda (x315) (if (nonsymbol-id?113 x315) (free-id=?137 x315 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded316 mod317) (let ((p318 (local-eval-hook77 expanded316 mod317))) (if (procedure? p318) p318 (syntax-violation #f "nonprocedure transformer" p318))))) (chi-local-syntax156 (lambda (rec?319 e320 r321 w322 s323 mod324 k325) ((lambda (tmp326) ((lambda (tmp327) (if tmp327 (apply (lambda (_328 id329 val330 e1331 e2332) (let ((ids333 id329)) (if (not (valid-bound-ids?139 ids333)) (syntax-violation #f "duplicate bound keyword" e320) (let ((labels335 (gen-labels120 ids333))) (let ((new-w336 (make-binding-wrap131 ids333 labels335 w322))) (k325 (cons e1331 e2332) (extend-env108 labels335 (let ((w338 (if rec?319 new-w336 w322)) (trans-r339 (macros-only-env110 r321))) (map (lambda (x340) (cons (quote macro) (eval-local-transformer157 (chi150 x340 trans-r339 w338 mod324) mod324))) val330)) r321) new-w336 s323 mod324)))))) tmp327) ((lambda (_342) (syntax-violation #f "bad local syntax definition" (source-wrap143 e320 w322 s323 mod324))) tmp326))) ($sc-dispatch tmp326 (quote (any #(each (any any)) any . each-any))))) e320))) (chi-lambda-clause155 (lambda (e343 docstring344 c345 r346 w347 mod348 k349) ((lambda (tmp350) ((lambda (tmp351) (if (if tmp351 (apply (lambda (args352 doc353 e1354 e2355) (if (string? (syntax->datum doc353)) (not docstring344) #f)) tmp351) #f) (apply (lambda (args356 doc357 e1358 e2359) (chi-lambda-clause155 e343 doc357 (cons args356 (cons e1358 e2359)) r346 w347 mod348 k349)) tmp351) ((lambda (tmp361) (if tmp361 (apply (lambda (id362 e1363 e2364) (let ((ids365 id362)) (if (not (valid-bound-ids?139 ids365)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels367 (gen-labels120 ids365)) (new-vars368 (map gen-var162 ids365))) (k349 (map syntax->datum ids365) new-vars368 (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1363 e2364) e343 (extend-var-env109 labels367 new-vars368 r346) (make-binding-wrap131 ids365 labels367 w347) mod348)))))) tmp361) ((lambda (tmp370) (if tmp370 (apply (lambda (ids371 e1372 e2373) (let ((old-ids374 (lambda-var-list163 ids371))) (if (not (valid-bound-ids?139 old-ids374)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels375 (gen-labels120 old-ids374)) (new-vars376 (map gen-var162 old-ids374))) (k349 (letrec ((f377 (lambda (ls1378 ls2379) (if (null? ls1378) (syntax->datum ls2379) (f377 (cdr ls1378) (cons (syntax->datum (car ls1378)) ls2379)))))) (f377 (cdr old-ids374) (car old-ids374))) (letrec ((f380 (lambda (ls1381 ls2382) (if (null? ls1381) ls2382 (f380 (cdr ls1381) (cons (car ls1381) ls2382)))))) (f380 (cdr new-vars376) (car new-vars376))) (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1372 e2373) e343 (extend-var-env109 labels375 new-vars376 r346) (make-binding-wrap131 old-ids374 labels375 w347) mod348)))))) tmp370) ((lambda (_384) (syntax-violation (quote lambda) "bad lambda" e343)) tmp350))) ($sc-dispatch tmp350 (quote (any any . each-any)))))) ($sc-dispatch tmp350 (quote (each-any any . each-any)))))) ($sc-dispatch tmp350 (quote (any any any . each-any))))) c345))) (chi-body154 (lambda (body385 outer-form386 r387 w388 mod389) (let ((r390 (cons (quote ("placeholder" placeholder)) r387))) (let ((ribcage391 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w392 (make-wrap116 (wrap-marks117 w388) (cons ribcage391 (wrap-subst118 w388))))) (letrec ((parse393 (lambda (body394 ids395 labels396 vars397 vals398 bindings399) (if (null? body394) (syntax-violation #f "no expressions in body" outer-form386) (let ((e401 (cdar body394)) (er402 (caar body394))) (call-with-values (lambda () (syntax-type148 e401 er402 (quote (())) #f ribcage391 mod389)) (lambda (type403 value404 e405 w406 s407 mod408) (if (memv type403 (quote (define-form))) (let ((id409 (wrap142 value404 w406 mod408)) (label410 (gen-label119))) (let ((var411 (gen-var162 id409))) (begin (extend-ribcage!130 ribcage391 id409 label410) (parse393 (cdr body394) (cons id409 ids395) (cons label410 labels396) (cons var411 vars397) (cons (cons er402 (wrap142 e405 w406 mod408)) vals398) (cons (cons (quote lexical) var411) bindings399))))) (if (memv type403 (quote (define-syntax-form))) (let ((id412 (wrap142 value404 w406 mod408)) (label413 (gen-label119))) (begin (extend-ribcage!130 ribcage391 id412 label413) (parse393 (cdr body394) (cons id412 ids395) (cons label413 labels396) vars397 vals398 (cons (cons (quote macro) (cons er402 (wrap142 e405 w406 mod408))) bindings399)))) (if (memv type403 (quote (begin-form))) ((lambda (tmp414) ((lambda (tmp415) (if tmp415 (apply (lambda (_416 e1417) (parse393 (letrec ((f418 (lambda (forms419) (if (null? forms419) (cdr body394) (cons (cons er402 (wrap142 (car forms419) w406 mod408)) (f418 (cdr forms419))))))) (f418 e1417)) ids395 labels396 vars397 vals398 bindings399)) tmp415) (syntax-violation #f "source expression failed to match any pattern" tmp414))) ($sc-dispatch tmp414 (quote (any . each-any))))) e405) (if (memv type403 (quote (local-syntax-form))) (chi-local-syntax156 value404 e405 er402 w406 s407 mod408 (lambda (forms421 er422 w423 s424 mod425) (parse393 (letrec ((f426 (lambda (forms427) (if (null? forms427) (cdr body394) (cons (cons er422 (wrap142 (car forms427) w423 mod425)) (f426 (cdr forms427))))))) (f426 forms421)) ids395 labels396 vars397 vals398 bindings399))) (if (null? ids395) (build-sequence93 #f (map (lambda (x428) (chi150 (cdr x428) (car x428) (quote (())) mod408)) (cons (cons er402 (source-wrap143 e405 w406 s407 mod408)) (cdr body394)))) (begin (if (not (valid-bound-ids?139 ids395)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form386)) (letrec ((loop429 (lambda (bs430 er-cache431 r-cache432) (if (not (null? bs430)) (let ((b433 (car bs430))) (if (eq? (car b433) (quote macro)) (let ((er434 (cadr b433))) (let ((r-cache435 (if (eq? er434 er-cache431) r-cache432 (macros-only-env110 er434)))) (begin (set-cdr! b433 (eval-local-transformer157 (chi150 (cddr b433) r-cache435 (quote (())) mod408) mod408)) (loop429 (cdr bs430) er434 r-cache435)))) (loop429 (cdr bs430) er-cache431 r-cache432))))))) (loop429 bindings399 #f #f)) (set-cdr! r390 (extend-env108 labels396 bindings399 (cdr r390))) (build-letrec96 #f (map syntax->datum ids395) vars397 (map (lambda (x436) (chi150 (cdr x436) (car x436) (quote (())) mod408)) vals398) (build-sequence93 #f (map (lambda (x437) (chi150 (cdr x437) (car x437) (quote (())) mod408)) (cons (cons er402 (source-wrap143 e405 w406 s407 mod408)) (cdr body394)))))))))))))))))) (parse393 (map (lambda (x400) (cons r390 (wrap142 x400 w392 mod389))) body385) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p438 e439 r440 w441 rib442 mod443) (letrec ((rebuild-macro-output444 (lambda (x445 m446) (if (pair? x445) (cons (rebuild-macro-output444 (car x445) m446) (rebuild-macro-output444 (cdr x445) m446)) (if (syntax-object?98 x445) (let ((w447 (syntax-object-wrap100 x445))) (let ((ms448 (wrap-marks117 w447)) (s449 (wrap-subst118 w447))) (if (if (pair? ms448) (eq? (car ms448) #f) #f) (make-syntax-object97 (syntax-object-expression99 x445) (make-wrap116 (cdr ms448) (if rib442 (cons rib442 (cdr s449)) (cdr s449))) (syntax-object-module101 x445)) (make-syntax-object97 (syntax-object-expression99 x445) (make-wrap116 (cons m446 ms448) (if rib442 (cons rib442 (cons (quote shift) s449)) (cons (quote shift) s449))) (let ((pmod450 (procedure-module p438))) (if pmod450 (cons (quote hygiene) (module-name pmod450)) (quote (hygiene guile)))))))) (if (vector? x445) (let ((n451 (vector-length x445))) (let ((v452 (make-vector n451))) (letrec ((loop453 (lambda (i454) (if (fx=74 i454 n451) (begin (if #f #f) v452) (begin (vector-set! v452 i454 (rebuild-macro-output444 (vector-ref x445 i454) m446)) (loop453 (fx+72 i454 1))))))) (loop453 0)))) (if (symbol? x445) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e439 w441 s mod443) x445) x445))))))) (rebuild-macro-output444 (p438 (wrap142 e439 (anti-mark129 w441) mod443)) (string #\m))))) (chi-application152 (lambda (x455 e456 r457 w458 s459 mod460) ((lambda (tmp461) ((lambda (tmp462) (if tmp462 (apply (lambda (e0463 e1464) (build-application81 s459 x455 (map (lambda (e465) (chi150 e465 r457 w458 mod460)) e1464))) tmp462) (syntax-violation #f "source expression failed to match any pattern" tmp461))) ($sc-dispatch tmp461 (quote (any . each-any))))) e456))) (chi-expr151 (lambda (type467 value468 e469 r470 w471 s472 mod473) (if (memv type467 (quote (lexical))) (build-lexical-reference83 (quote value) s472 e469 value468) (if (memv type467 (quote (core external-macro))) (value468 e469 r470 w471 s472 mod473) (if (memv type467 (quote (module-ref))) (call-with-values (lambda () (value468 e469)) (lambda (id474 mod475) (build-global-reference86 s472 id474 mod475))) (if (memv type467 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e469)) (car e469) value468) e469 r470 w471 s472 mod473) (if (memv type467 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e469)) value468 (if (syntax-object?98 (car e469)) (syntax-object-module101 (car e469)) mod473)) e469 r470 w471 s472 mod473) (if (memv type467 (quote (constant))) (build-data92 s472 (strip161 (source-wrap143 e469 w471 s472 mod473) (quote (())))) (if (memv type467 (quote (global))) (build-global-reference86 s472 value468 mod473) (if (memv type467 (quote (call))) (chi-application152 (chi150 (car e469) r470 w471 mod473) e469 r470 w471 s472 mod473) (if (memv type467 (quote (begin-form))) ((lambda (tmp476) ((lambda (tmp477) (if tmp477 (apply (lambda (_478 e1479 e2480) (chi-sequence144 (cons e1479 e2480) r470 w471 s472 mod473)) tmp477) (syntax-violation #f "source expression failed to match any pattern" tmp476))) ($sc-dispatch tmp476 (quote (any any . each-any))))) e469) (if (memv type467 (quote (local-syntax-form))) (chi-local-syntax156 value468 e469 r470 w471 s472 mod473 chi-sequence144) (if (memv type467 (quote (eval-when-form))) ((lambda (tmp482) ((lambda (tmp483) (if tmp483 (apply (lambda (_484 x485 e1486 e2487) (let ((when-list488 (chi-when-list147 e469 x485 w471))) (if (memq (quote eval) when-list488) (chi-sequence144 (cons e1486 e2487) r470 w471 s472 mod473) (chi-void158)))) tmp483) (syntax-violation #f "source expression failed to match any pattern" tmp482))) ($sc-dispatch tmp482 (quote (any each-any any . each-any))))) e469) (if (memv type467 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e469 (wrap142 value468 w471 mod473)) (if (memv type467 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e469 w471 s472 mod473)) (if (memv type467 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e469 w471 s472 mod473)) (syntax-violation #f "unexpected syntax" (source-wrap143 e469 w471 s472 mod473)))))))))))))))))) (chi150 (lambda (e491 r492 w493 mod494) (call-with-values (lambda () (syntax-type148 e491 r492 w493 #f #f mod494)) (lambda (type495 value496 e497 w498 s499 mod500) (chi-expr151 type495 value496 e497 r492 w498 s499 mod500))))) (chi-top149 (lambda (e501 r502 w503 m504 esew505 mod506) (call-with-values (lambda () (syntax-type148 e501 r502 w503 #f #f mod506)) (lambda (type514 value515 e516 w517 s518 mod519) (if (memv type514 (quote (begin-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522) (chi-void158)) tmp521) ((lambda (tmp523) (if tmp523 (apply (lambda (_524 e1525 e2526) (chi-top-sequence145 (cons e1525 e2526) r502 w517 s518 m504 esew505 mod519)) tmp523) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any any . each-any)))))) ($sc-dispatch tmp520 (quote (any))))) e516) (if (memv type514 (quote (local-syntax-form))) (chi-local-syntax156 value515 e516 r502 w517 s518 mod519 (lambda (body528 r529 w530 s531 mod532) (chi-top-sequence145 body528 r529 w530 s531 m504 esew505 mod532))) (if (memv type514 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list147 e516 x536 w517)) (body540 (cons e1537 e2538))) (if (eq? m504 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence145 body540 r502 w517 s518 (quote e) (quote (eval)) mod519) (chi-void158)) (if (memq (quote load) when-list539) (if (let ((t543 (memq (quote compile) when-list539))) (if t543 t543 (if (eq? m504 (quote c&e)) (memq (quote eval) when-list539) #f))) (chi-top-sequence145 body540 r502 w517 s518 (quote c&e) (quote (compile load)) mod519) (if (memq m504 (quote (c c&e))) (chi-top-sequence145 body540 r502 w517 s518 (quote c) (quote (load)) mod519) (chi-void158))) (if (let ((t544 (memq (quote compile) when-list539))) (if t544 t544 (if (eq? m504 (quote c&e)) (memq (quote eval) when-list539) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body540 r502 w517 s518 (quote e) (quote (eval)) mod519) mod519) (chi-void158)) (chi-void158)))))) tmp534) (syntax-violation #f "source expression failed to match any pattern" tmp533))) ($sc-dispatch tmp533 (quote (any each-any any . each-any))))) e516) (if (memv type514 (quote (define-syntax-form))) (let ((n545 (id-var-name136 value515 w517)) (r546 (macros-only-env110 r502))) (if (memv m504 (quote (c))) (if (memq (quote compile) esew505) (let ((e547 (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)))) (begin (top-level-eval-hook76 e547 mod519) (if (memq (quote load) esew505) e547 (chi-void158)))) (if (memq (quote load) esew505) (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)) (chi-void158))) (if (memv m504 (quote (c&e))) (let ((e548 (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)))) (begin (top-level-eval-hook76 e548 mod519) e548)) (begin (if (memq (quote eval) esew505) (top-level-eval-hook76 (chi-install-global146 n545 (chi150 e516 r546 w517 mod519)) mod519)) (chi-void158))))) (if (memv type514 (quote (define-form))) (let ((n549 (id-var-name136 value515 w517))) (let ((type550 (binding-type106 (lookup111 n549 r502 mod519)))) (if (memv type550 (quote (global core macro module-ref))) (let ((x551 (build-global-definition89 s518 n549 (chi150 e516 r502 w517 mod519)))) (begin (if (eq? m504 (quote c&e)) (top-level-eval-hook76 x551 mod519)) x551)) (if (memv type550 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e516 (wrap142 value515 w517 mod519)) (syntax-violation #f "cannot define keyword at top level" e516 (wrap142 value515 w517 mod519)))))) (let ((x552 (chi-expr151 type514 value515 e516 r502 w517 s518 mod519))) (begin (if (eq? m504 (quote c&e)) (top-level-eval-hook76 x552 mod519)) x552))))))))))) (syntax-type148 (lambda (e553 r554 w555 s556 rib557 mod558) (if (symbol? e553) (let ((n559 (id-var-name136 e553 w555))) (let ((b560 (lookup111 n559 r554 mod558))) (let ((type561 (binding-type106 b560))) (if (memv type561 (quote (lexical))) (values type561 (binding-value107 b560) e553 w555 s556 mod558) (if (memv type561 (quote (global))) (values type561 n559 e553 w555 s556 mod558) (if (memv type561 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b560) e553 r554 w555 rib557 mod558) r554 (quote (())) s556 rib557 mod558) (values type561 (binding-value107 b560) e553 w555 s556 mod558))))))) (if (pair? e553) (let ((first562 (car e553))) (if (id?114 first562) (let ((n563 (id-var-name136 first562 w555))) (let ((b564 (lookup111 n563 r554 (let ((t565 (if (syntax-object?98 first562) (syntax-object-module101 first562) #f))) (if t565 t565 mod558))))) (let ((type566 (binding-type106 b564))) (if (memv type566 (quote (lexical))) (values (quote lexical-call) (binding-value107 b564) e553 w555 s556 mod558) (if (memv type566 (quote (global))) (values (quote global-call) n563 e553 w555 s556 mod558) (if (memv type566 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b564) e553 r554 w555 rib557 mod558) r554 (quote (())) s556 rib557 mod558) (if (memv type566 (quote (core external-macro module-ref))) (values type566 (binding-value107 b564) e553 w555 s556 mod558) (if (memv type566 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value107 b564) e553 w555 s556 mod558) (if (memv type566 (quote (begin))) (values (quote begin-form) #f e553 w555 s556 mod558) (if (memv type566 (quote (eval-when))) (values (quote eval-when-form) #f e553 w555 s556 mod558) (if (memv type566 (quote (define))) ((lambda (tmp567) ((lambda (tmp568) (if (if tmp568 (apply (lambda (_569 name570 val571) (id?114 name570)) tmp568) #f) (apply (lambda (_572 name573 val574) (values (quote define-form) name573 val574 w555 s556 mod558)) tmp568) ((lambda (tmp575) (if (if tmp575 (apply (lambda (_576 name577 args578 e1579 e2580) (if (id?114 name577) (valid-bound-ids?139 (lambda-var-list163 args578)) #f)) tmp575) #f) (apply (lambda (_581 name582 args583 e1584 e2585) (values (quote define-form) (wrap142 name582 w555 mod558) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args583 (cons e1584 e2585)) w555 mod558)) (quote (())) s556 mod558)) tmp575) ((lambda (tmp587) (if (if tmp587 (apply (lambda (_588 name589) (id?114 name589)) tmp587) #f) (apply (lambda (_590 name591) (values (quote define-form) (wrap142 name591 w555 mod558) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s556 mod558)) tmp587) (syntax-violation #f "source expression failed to match any pattern" tmp567))) ($sc-dispatch tmp567 (quote (any any)))))) ($sc-dispatch tmp567 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp567 (quote (any any any))))) e553) (if (memv type566 (quote (define-syntax))) ((lambda (tmp592) ((lambda (tmp593) (if (if tmp593 (apply (lambda (_594 name595 val596) (id?114 name595)) tmp593) #f) (apply (lambda (_597 name598 val599) (values (quote define-syntax-form) name598 val599 w555 s556 mod558)) tmp593) (syntax-violation #f "source expression failed to match any pattern" tmp592))) ($sc-dispatch tmp592 (quote (any any any))))) e553) (values (quote call) #f e553 w555 s556 mod558))))))))))))) (values (quote call) #f e553 w555 s556 mod558))) (if (syntax-object?98 e553) (syntax-type148 (syntax-object-expression99 e553) r554 (join-wraps133 w555 (syntax-object-wrap100 e553)) #f rib557 (let ((t600 (syntax-object-module101 e553))) (if t600 t600 mod558))) (if (annotation? e553) (syntax-type148 (annotation-expression e553) r554 w555 (annotation-source e553) rib557 mod558) (if (self-evaluating? e553) (values (quote constant) #f e553 w555 s556 mod558) (values (quote other) #f e553 w555 s556 mod558)))))))) (chi-when-list147 (lambda (e601 when-list602 w603) (letrec ((f604 (lambda (when-list605 situations606) (if (null? when-list605) situations606 (f604 (cdr when-list605) (cons (let ((x607 (car when-list605))) (if (free-id=?137 x607 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x607 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x607 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e601 (wrap142 x607 w603 #f)))))) situations606)))))) (f604 when-list602 (quote ()))))) (chi-install-global146 (lambda (name608 e609) (build-global-definition89 #f name608 (if (let ((v610 (module-variable (current-module) name608))) (if v610 (if (variable-bound? v610) (if (macro? (variable-ref v610)) (not (eq? (macro-type (variable-ref v610)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name608))) (build-data92 #f (quote macro)) e609)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e609)))))) (chi-top-sequence145 (lambda (body611 r612 w613 s614 m615 esew616 mod617) (build-sequence93 s614 (letrec ((dobody618 (lambda (body619 r620 w621 m622 esew623 mod624) (if (null? body619) (quote ()) (let ((first625 (chi-top149 (car body619) r620 w621 m622 esew623 mod624))) (cons first625 (dobody618 (cdr body619) r620 w621 m622 esew623 mod624))))))) (dobody618 body611 r612 w613 m615 esew616 mod617))))) (chi-sequence144 (lambda (body626 r627 w628 s629 mod630) (build-sequence93 s629 (letrec ((dobody631 (lambda (body632 r633 w634 mod635) (if (null? body632) (quote ()) (let ((first636 (chi150 (car body632) r633 w634 mod635))) (cons first636 (dobody631 (cdr body632) r633 w634 mod635))))))) (dobody631 body626 r627 w628 mod630))))) (source-wrap143 (lambda (x637 w638 s639 defmod640) (wrap142 (if s639 (make-annotation x637 s639 #f) x637) w638 defmod640))) (wrap142 (lambda (x641 w642 defmod643) (if (if (null? (wrap-marks117 w642)) (null? (wrap-subst118 w642)) #f) x641 (if (syntax-object?98 x641) (make-syntax-object97 (syntax-object-expression99 x641) (join-wraps133 w642 (syntax-object-wrap100 x641)) (syntax-object-module101 x641)) (if (null? x641) x641 (make-syntax-object97 x641 w642 defmod643)))))) (bound-id-member?141 (lambda (x644 list645) (if (not (null? list645)) (let ((t646 (bound-id=?138 x644 (car list645)))) (if t646 t646 (bound-id-member?141 x644 (cdr list645)))) #f))) (distinct-bound-ids?140 (lambda (ids647) (letrec ((distinct?648 (lambda (ids649) (let ((t650 (null? ids649))) (if t650 t650 (if (not (bound-id-member?141 (car ids649) (cdr ids649))) (distinct?648 (cdr ids649)) #f)))))) (distinct?648 ids647)))) (valid-bound-ids?139 (lambda (ids651) (if (letrec ((all-ids?652 (lambda (ids653) (let ((t654 (null? ids653))) (if t654 t654 (if (id?114 (car ids653)) (all-ids?652 (cdr ids653)) #f)))))) (all-ids?652 ids651)) (distinct-bound-ids?140 ids651) #f))) (bound-id=?138 (lambda (i655 j656) (if (if (syntax-object?98 i655) (syntax-object?98 j656) #f) (if (eq? (let ((e657 (syntax-object-expression99 i655))) (if (annotation? e657) (annotation-expression e657) e657)) (let ((e658 (syntax-object-expression99 j656))) (if (annotation? e658) (annotation-expression e658) e658))) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i655)) (wrap-marks117 (syntax-object-wrap100 j656))) #f) (eq? (let ((e659 i655)) (if (annotation? e659) (annotation-expression e659) e659)) (let ((e660 j656)) (if (annotation? e660) (annotation-expression e660) e660)))))) (free-id=?137 (lambda (i661 j662) (if (eq? (let ((x663 i661)) (let ((e664 (if (syntax-object?98 x663) (syntax-object-expression99 x663) x663))) (if (annotation? e664) (annotation-expression e664) e664))) (let ((x665 j662)) (let ((e666 (if (syntax-object?98 x665) (syntax-object-expression99 x665) x665))) (if (annotation? e666) (annotation-expression e666) e666)))) (eq? (id-var-name136 i661 (quote (()))) (id-var-name136 j662 (quote (())))) #f))) (id-var-name136 (lambda (id667 w668) (letrec ((search-vector-rib671 (lambda (sym677 subst678 marks679 symnames680 ribcage681) (let ((n682 (vector-length symnames680))) (letrec ((f683 (lambda (i684) (if (fx=74 i684 n682) (search669 sym677 (cdr subst678) marks679) (if (if (eq? (vector-ref symnames680 i684) sym677) (same-marks?135 marks679 (vector-ref (ribcage-marks124 ribcage681) i684)) #f) (values (vector-ref (ribcage-labels125 ribcage681) i684) marks679) (f683 (fx+72 i684 1))))))) (f683 0))))) (search-list-rib670 (lambda (sym685 subst686 marks687 symnames688 ribcage689) (letrec ((f690 (lambda (symnames691 i692) (if (null? symnames691) (search669 sym685 (cdr subst686) marks687) (if (if (eq? (car symnames691) sym685) (same-marks?135 marks687 (list-ref (ribcage-marks124 ribcage689) i692)) #f) (values (list-ref (ribcage-labels125 ribcage689) i692) marks687) (f690 (cdr symnames691) (fx+72 i692 1))))))) (f690 symnames688 0)))) (search669 (lambda (sym693 subst694 marks695) (if (null? subst694) (values #f marks695) (let ((fst696 (car subst694))) (if (eq? fst696 (quote shift)) (search669 sym693 (cdr subst694) (cdr marks695)) (let ((symnames697 (ribcage-symnames123 fst696))) (if (vector? symnames697) (search-vector-rib671 sym693 subst694 marks695 symnames697 fst696) (search-list-rib670 sym693 subst694 marks695 symnames697 fst696))))))))) (if (symbol? id667) (let ((t698 (call-with-values (lambda () (search669 id667 (wrap-subst118 w668) (wrap-marks117 w668))) (lambda (x700 . ignore699) x700)))) (if t698 t698 id667)) (if (syntax-object?98 id667) (let ((id701 (let ((e703 (syntax-object-expression99 id667))) (if (annotation? e703) (annotation-expression e703) e703))) (w1702 (syntax-object-wrap100 id667))) (let ((marks704 (join-marks134 (wrap-marks117 w668) (wrap-marks117 w1702)))) (call-with-values (lambda () (search669 id701 (wrap-subst118 w668) marks704)) (lambda (new-id705 marks706) (let ((t707 new-id705)) (if t707 t707 (let ((t708 (call-with-values (lambda () (search669 id701 (wrap-subst118 w1702) marks706)) (lambda (x710 . ignore709) x710)))) (if t708 t708 id701)))))))) (if (annotation? id667) (let ((id711 (let ((e712 id667)) (if (annotation? e712) (annotation-expression e712) e712)))) (let ((t713 (call-with-values (lambda () (search669 id711 (wrap-subst118 w668) (wrap-marks117 w668))) (lambda (x715 . ignore714) x715)))) (if t713 t713 id711))) (syntax-violation (quote id-var-name) "invalid id" id667))))))) (same-marks?135 (lambda (x716 y717) (let ((t718 (eq? x716 y717))) (if t718 t718 (if (not (null? x716)) (if (not (null? y717)) (if (eq? (car x716) (car y717)) (same-marks?135 (cdr x716) (cdr y717)) #f) #f) #f))))) (join-marks134 (lambda (m1719 m2720) (smart-append132 m1719 m2720))) (join-wraps133 (lambda (w1721 w2722) (let ((m1723 (wrap-marks117 w1721)) (s1724 (wrap-subst118 w1721))) (if (null? m1723) (if (null? s1724) w2722 (make-wrap116 (wrap-marks117 w2722) (smart-append132 s1724 (wrap-subst118 w2722)))) (make-wrap116 (smart-append132 m1723 (wrap-marks117 w2722)) (smart-append132 s1724 (wrap-subst118 w2722))))))) (smart-append132 (lambda (m1725 m2726) (if (null? m2726) m1725 (append m1725 m2726)))) (make-binding-wrap131 (lambda (ids727 labels728 w729) (if (null? ids727) w729 (make-wrap116 (wrap-marks117 w729) (cons (let ((labelvec730 (list->vector labels728))) (let ((n731 (vector-length labelvec730))) (let ((symnamevec732 (make-vector n731)) (marksvec733 (make-vector n731))) (begin (letrec ((f734 (lambda (ids735 i736) (if (not (null? ids735)) (call-with-values (lambda () (id-sym-name&marks115 (car ids735) w729)) (lambda (symname737 marks738) (begin (vector-set! symnamevec732 i736 symname737) (vector-set! marksvec733 i736 marks738) (f734 (cdr ids735) (fx+72 i736 1))))))))) (f734 ids727 0)) (make-ribcage121 symnamevec732 marksvec733 labelvec730))))) (wrap-subst118 w729)))))) (extend-ribcage!130 (lambda (ribcage739 id740 label741) (begin (set-ribcage-symnames!126 ribcage739 (cons (let ((e742 (syntax-object-expression99 id740))) (if (annotation? e742) (annotation-expression e742) e742)) (ribcage-symnames123 ribcage739))) (set-ribcage-marks!127 ribcage739 (cons (wrap-marks117 (syntax-object-wrap100 id740)) (ribcage-marks124 ribcage739))) (set-ribcage-labels!128 ribcage739 (cons label741 (ribcage-labels125 ribcage739)))))) (anti-mark129 (lambda (w743) (make-wrap116 (cons #f (wrap-marks117 w743)) (cons (quote shift) (wrap-subst118 w743))))) (set-ribcage-labels!128 (lambda (x744 update745) (vector-set! x744 3 update745))) (set-ribcage-marks!127 (lambda (x746 update747) (vector-set! x746 2 update747))) (set-ribcage-symnames!126 (lambda (x748 update749) (vector-set! x748 1 update749))) (ribcage-labels125 (lambda (x750) (vector-ref x750 3))) (ribcage-marks124 (lambda (x751) (vector-ref x751 2))) (ribcage-symnames123 (lambda (x752) (vector-ref x752 1))) (ribcage?122 (lambda (x753) (if (vector? x753) (if (= (vector-length x753) 4) (eq? (vector-ref x753 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames754 marks755 labels756) (vector (quote ribcage) symnames754 marks755 labels756))) (gen-labels120 (lambda (ls757) (if (null? ls757) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls757)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x758 w759) (if (syntax-object?98 x758) (values (let ((e760 (syntax-object-expression99 x758))) (if (annotation? e760) (annotation-expression e760) e760)) (join-marks134 (wrap-marks117 w759) (wrap-marks117 (syntax-object-wrap100 x758)))) (values (let ((e761 x758)) (if (annotation? e761) (annotation-expression e761) e761)) (wrap-marks117 w759))))) (id?114 (lambda (x762) (if (symbol? x762) #t (if (syntax-object?98 x762) (symbol? (let ((e763 (syntax-object-expression99 x762))) (if (annotation? e763) (annotation-expression e763) e763))) (if (annotation? x762) (symbol? (annotation-expression x762)) #f))))) (nonsymbol-id?113 (lambda (x764) (if (syntax-object?98 x764) (symbol? (let ((e765 (syntax-object-expression99 x764))) (if (annotation? e765) (annotation-expression e765) e765))) #f))) (global-extend112 (lambda (type766 sym767 val768) (put-global-definition-hook78 sym767 type766 val768))) (lookup111 (lambda (x769 r770 mod771) (let ((t772 (assq x769 r770))) (if t772 (cdr t772) (if (symbol? x769) (let ((t773 (get-global-definition-hook79 x769 mod771))) (if t773 t773 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r774) (if (null? r774) (quote ()) (let ((a775 (car r774))) (if (eq? (cadr a775) (quote macro)) (cons a775 (macros-only-env110 (cdr r774))) (macros-only-env110 (cdr r774))))))) (extend-var-env109 (lambda (labels776 vars777 r778) (if (null? labels776) r778 (extend-var-env109 (cdr labels776) (cdr vars777) (cons (cons (car labels776) (cons (quote lexical) (car vars777))) r778))))) (extend-env108 (lambda (labels779 bindings780 r781) (if (null? labels779) r781 (extend-env108 (cdr labels779) (cdr bindings780) (cons (cons (car labels779) (car bindings780)) r781))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x782) (if (annotation? x782) (annotation-source x782) (if (syntax-object?98 x782) (source-annotation105 (syntax-object-expression99 x782)) #f)))) (set-syntax-object-module!104 (lambda (x783 update784) (vector-set! x783 3 update784))) (set-syntax-object-wrap!103 (lambda (x785 update786) (vector-set! x785 2 update786))) (set-syntax-object-expression!102 (lambda (x787 update788) (vector-set! x787 1 update788))) (syntax-object-module101 (lambda (x789) (vector-ref x789 3))) (syntax-object-wrap100 (lambda (x790) (vector-ref x790 2))) (syntax-object-expression99 (lambda (x791) (vector-ref x791 1))) (syntax-object?98 (lambda (x792) (if (vector? x792) (if (= (vector-length x792) 4) (eq? (vector-ref x792 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression793 wrap794 module795) (vector (quote syntax-object) expression793 wrap794 module795))) (build-letrec96 (lambda (src796 ids797 vars798 val-exps799 body-exp800) (if (null? vars798) body-exp800 (let ((atom-key801 (fluid-ref *mode*71))) (if (memv atom-key801 (quote (c))) (begin (for-each maybe-name-value!88 ids797 val-exps799) ((@ (language tree-il) make-letrec) src796 ids797 vars798 val-exps799 body-exp800)) (list (quote letrec) (map list vars798 val-exps799) body-exp800)))))) (build-named-let95 (lambda (src802 ids803 vars804 val-exps805 body-exp806) (let ((f807 (car vars804)) (f-name808 (car ids803)) (vars809 (cdr vars804)) (ids810 (cdr ids803))) (let ((atom-key811 (fluid-ref *mode*71))) (if (memv atom-key811 (quote (c))) (let ((proc812 (build-lambda90 src802 ids810 vars809 #f body-exp806))) (begin (maybe-name-value!88 f-name808 proc812) (for-each maybe-name-value!88 ids810 val-exps805) ((@ (language tree-il) make-letrec) src802 (list f-name808) (list f807) (list proc812) (build-application81 src802 (build-lexical-reference83 (quote fun) src802 f-name808 f807) val-exps805)))) (list (quote let) f807 (map list vars809 val-exps805) body-exp806)))))) (build-let94 (lambda (src813 ids814 vars815 val-exps816 body-exp817) (if (null? vars815) body-exp817 (let ((atom-key818 (fluid-ref *mode*71))) (if (memv atom-key818 (quote (c))) (begin (for-each maybe-name-value!88 ids814 val-exps816) ((@ (language tree-il) make-let) src813 ids814 vars815 val-exps816 body-exp817)) (list (quote let) (map list vars815 val-exps816) body-exp817)))))) (build-sequence93 (lambda (src819 exps820) (if (null? (cdr exps820)) (car exps820) (let ((atom-key821 (fluid-ref *mode*71))) (if (memv atom-key821 (quote (c))) ((@ (language tree-il) make-sequence) src819 exps820) (cons (quote begin) exps820)))))) (build-data92 (lambda (src822 exp823) (let ((atom-key824 (fluid-ref *mode*71))) (if (memv atom-key824 (quote (c))) ((@ (language tree-il) make-const) src822 exp823) (if (if (self-evaluating? exp823) (not (vector? exp823)) #f) exp823 (list (quote quote) exp823)))))) (build-primref91 (lambda (src825 name826) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key827 (fluid-ref *mode*71))) (if (memv atom-key827 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src825 name826) name826)) (let ((atom-key828 (fluid-ref *mode*71))) (if (memv atom-key828 (quote (c))) ((@ (language tree-il) make-module-ref) src825 (quote (guile)) name826 #f) (list (quote @@) (quote (guile)) name826)))))) (build-lambda90 (lambda (src829 ids830 vars831 docstring832 exp833) (let ((atom-key834 (fluid-ref *mode*71))) (if (memv atom-key834 (quote (c))) ((@ (language tree-il) make-lambda) src829 ids830 vars831 (if docstring832 (list (cons (quote documentation) docstring832)) (quote ())) exp833) (cons (quote lambda) (cons vars831 (append (if docstring832 (list docstring832) (quote ())) (list exp833)))))))) (build-global-definition89 (lambda (source835 var836 exp837) (let ((atom-key838 (fluid-ref *mode*71))) (if (memv atom-key838 (quote (c))) (begin (maybe-name-value!88 var836 exp837) ((@ (language tree-il) make-toplevel-define) source835 var836 exp837)) (list (quote define) var836 exp837))))) (maybe-name-value!88 (lambda (name839 val840) (if ((@ (language tree-il) lambda?) val840) (let ((meta841 ((@ (language tree-il) lambda-meta) val840))) (if (not (assq (quote name) meta841)) ((setter (@ (language tree-il) lambda-meta)) val840 (acons (quote name) name839 meta841))))))) (build-global-assignment87 (lambda (source842 var843 exp844 mod845) (analyze-variable85 mod845 var843 (lambda (mod846 var847 public?848) (let ((atom-key849 (fluid-ref *mode*71))) (if (memv atom-key849 (quote (c))) ((@ (language tree-il) make-module-set) source842 mod846 var847 public?848 exp844) (list (quote set!) (list (if public?848 (quote @) (quote @@)) mod846 var847) exp844)))) (lambda (var850) (let ((atom-key851 (fluid-ref *mode*71))) (if (memv atom-key851 (quote (c))) ((@ (language tree-il) make-toplevel-set) source842 var850 exp844) (list (quote set!) var850 exp844))))))) (build-global-reference86 (lambda (source852 var853 mod854) (analyze-variable85 mod854 var853 (lambda (mod855 var856 public?857) (let ((atom-key858 (fluid-ref *mode*71))) (if (memv atom-key858 (quote (c))) ((@ (language tree-il) make-module-ref) source852 mod855 var856 public?857) (list (if public?857 (quote @) (quote @@)) mod855 var856)))) (lambda (var859) (let ((atom-key860 (fluid-ref *mode*71))) (if (memv atom-key860 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source852 var859) var859)))))) (analyze-variable85 (lambda (mod861 var862 modref-cont863 bare-cont864) (if (not mod861) (bare-cont864 var862) (let ((kind865 (car mod861)) (mod866 (cdr mod861))) (if (memv kind865 (quote (public))) (modref-cont863 mod866 var862 #t) (if (memv kind865 (quote (private))) (if (not (equal? mod866 (module-name (current-module)))) (modref-cont863 mod866 var862 #f) (bare-cont864 var862)) (if (memv kind865 (quote (bare))) (bare-cont864 var862) (if (memv kind865 (quote (hygiene))) (if (if (not (equal? mod866 (module-name (current-module)))) (module-variable (resolve-module mod866) var862) #f) (modref-cont863 mod866 var862 #f) (bare-cont864 var862)) (syntax-violation #f "bad module kind" var862 mod866))))))))) (build-lexical-assignment84 (lambda (source867 name868 var869 exp870) (let ((atom-key871 (fluid-ref *mode*71))) (if (memv atom-key871 (quote (c))) ((@ (language tree-il) make-lexical-set) source867 name868 var869 exp870) (list (quote set!) var869 exp870))))) (build-lexical-reference83 (lambda (type872 source873 name874 var875) (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) make-lexical-ref) source873 name874 var875) var875)))) (build-conditional82 (lambda (source877 test-exp878 then-exp879 else-exp880) (let ((atom-key881 (fluid-ref *mode*71))) (if (memv atom-key881 (quote (c))) ((@ (language tree-il) make-conditional) source877 test-exp878 then-exp879 else-exp880) (if (equal? else-exp880 (quote (if #f #f))) (list (quote if) test-exp878 then-exp879) (list (quote if) test-exp878 then-exp879 else-exp880)))))) (build-application81 (lambda (source882 fun-exp883 arg-exps884) (let ((atom-key885 (fluid-ref *mode*71))) (if (memv atom-key885 (quote (c))) ((@ (language tree-il) make-application) source882 fun-exp883 arg-exps884) (cons fun-exp883 arg-exps884))))) (build-void80 (lambda (source886) (let ((atom-key887 (fluid-ref *mode*71))) (if (memv atom-key887 (quote (c))) ((@ (language tree-il) make-void) source886) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol888 module889) (begin (if (if (not module889) (current-module) #f) (warn "module system is booted, we should have a module" symbol888)) (let ((v890 (module-variable (if module889 (resolve-module (cdr module889)) (current-module)) symbol888))) (if v890 (if (variable-bound? v890) (let ((val891 (variable-ref v890))) (if (macro? val891) (if (syncase-macro-type val891) (cons (syncase-macro-type val891) (syncase-macro-binding val891)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol892 type893 val894) (let ((existing895 (let ((v896 (module-variable (current-module) symbol892))) (if v896 (if (variable-bound? v896) (let ((val897 (variable-ref v896))) (if (macro? val897) (if (not (syncase-macro-type val897)) val897 #f) #f)) #f) #f)))) (module-define! (current-module) symbol892 (if existing895 (make-extended-syncase-macro existing895 type893 val894) (make-syncase-macro type893 val894)))))) (local-eval-hook77 (lambda (x898 mod899) (primitive-eval (list noexpand70 (let ((atom-key900 (fluid-ref *mode*71))) (if (memv atom-key900 (quote (c))) ((@ (language tree-il) tree-il->scheme) x898) x898)))))) (top-level-eval-hook76 (lambda (x901 mod902) (primitive-eval (list noexpand70 (let ((atom-key903 (fluid-ref *mode*71))) (if (memv atom-key903 (quote (c))) ((@ (language tree-il) tree-il->scheme) x901) x901)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e904 r905 w906 s907 mod908) ((lambda (tmp909) ((lambda (tmp910) (if (if tmp910 (apply (lambda (_911 var912 val913 e1914 e2915) (valid-bound-ids?139 var912)) tmp910) #f) (apply (lambda (_917 var918 val919 e1920 e2921) (let ((names922 (map (lambda (x923) (id-var-name136 x923 w906)) var918))) (begin (for-each (lambda (id925 n926) (let ((atom-key927 (binding-type106 (lookup111 n926 r905 mod908)))) (if (memv atom-key927 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e904 (source-wrap143 id925 w906 s907 mod908))))) var918 names922) (chi-body154 (cons e1920 e2921) (source-wrap143 e904 w906 s907 mod908) (extend-env108 names922 (let ((trans-r930 (macros-only-env110 r905))) (map (lambda (x931) (cons (quote macro) (eval-local-transformer157 (chi150 x931 trans-r930 w906 mod908) mod908))) val919)) r905) w906 mod908)))) tmp910) ((lambda (_933) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e904 w906 s907 mod908))) tmp909))) ($sc-dispatch tmp909 (quote (any #(each (any any)) any . each-any))))) e904))) (global-extend112 (quote core) (quote quote) (lambda (e934 r935 w936 s937 mod938) ((lambda (tmp939) ((lambda (tmp940) (if tmp940 (apply (lambda (_941 e942) (build-data92 s937 (strip161 e942 w936))) tmp940) ((lambda (_943) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e934 w936 s937 mod938))) tmp939))) ($sc-dispatch tmp939 (quote (any any))))) e934))) (global-extend112 (quote core) (quote syntax) (letrec ((regen951 (lambda (x952) (let ((atom-key953 (car x952))) (if (memv atom-key953 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x952) (cadr x952)) (if (memv atom-key953 (quote (primitive))) (build-primref91 #f (cadr x952)) (if (memv atom-key953 (quote (quote))) (build-data92 #f (cadr x952)) (if (memv atom-key953 (quote (lambda))) (build-lambda90 #f (cadr x952) (cadr x952) #f (regen951 (caddr x952))) (if (memv atom-key953 (quote (map))) (let ((ls954 (map regen951 (cdr x952)))) (build-application81 #f (build-primref91 #f (quote map)) ls954)) (build-application81 #f (build-primref91 #f (car x952)) (map regen951 (cdr x952))))))))))) (gen-vector950 (lambda (x955) (if (eq? (car x955) (quote list)) (cons (quote vector) (cdr x955)) (if (eq? (car x955) (quote quote)) (list (quote quote) (list->vector (cadr x955))) (list (quote list->vector) x955))))) (gen-append949 (lambda (x956 y957) (if (equal? y957 (quote (quote ()))) x956 (list (quote append) x956 y957)))) (gen-cons948 (lambda (x958 y959) (let ((atom-key960 (car y959))) (if (memv atom-key960 (quote (quote))) (if (eq? (car x958) (quote quote)) (list (quote quote) (cons (cadr x958) (cadr y959))) (if (eq? (cadr y959) (quote ())) (list (quote list) x958) (list (quote cons) x958 y959))) (if (memv atom-key960 (quote (list))) (cons (quote list) (cons x958 (cdr y959))) (list (quote cons) x958 y959)))))) (gen-map947 (lambda (e961 map-env962) (let ((formals963 (map cdr map-env962)) (actuals964 (map (lambda (x965) (list (quote ref) (car x965))) map-env962))) (if (eq? (car e961) (quote ref)) (car actuals964) (if (and-map (lambda (x966) (if (eq? (car x966) (quote ref)) (memq (cadr x966) formals963) #f)) (cdr e961)) (cons (quote map) (cons (list (quote primitive) (car e961)) (map (let ((r967 (map cons formals963 actuals964))) (lambda (x968) (cdr (assq (cadr x968) r967)))) (cdr e961)))) (cons (quote map) (cons (list (quote lambda) formals963 e961) actuals964))))))) (gen-mappend946 (lambda (e969 map-env970) (list (quote apply) (quote (primitive append)) (gen-map947 e969 map-env970)))) (gen-ref945 (lambda (src971 var972 level973 maps974) (if (fx=74 level973 0) (values var972 maps974) (if (null? maps974) (syntax-violation (quote syntax) "missing ellipsis" src971) (call-with-values (lambda () (gen-ref945 src971 var972 (fx-73 level973 1) (cdr maps974))) (lambda (outer-var975 outer-maps976) (let ((b977 (assq outer-var975 (car maps974)))) (if b977 (values (cdr b977) maps974) (let ((inner-var978 (gen-var162 (quote tmp)))) (values inner-var978 (cons (cons (cons outer-var975 inner-var978) (car maps974)) outer-maps976))))))))))) (gen-syntax944 (lambda (src979 e980 r981 maps982 ellipsis?983 mod984) (if (id?114 e980) (let ((label985 (id-var-name136 e980 (quote (()))))) (let ((b986 (lookup111 label985 r981 mod984))) (if (eq? (binding-type106 b986) (quote syntax)) (call-with-values (lambda () (let ((var.lev987 (binding-value107 b986))) (gen-ref945 src979 (car var.lev987) (cdr var.lev987) maps982))) (lambda (var988 maps989) (values (list (quote ref) var988) maps989))) (if (ellipsis?983 e980) (syntax-violation (quote syntax) "misplaced ellipsis" src979) (values (list (quote quote) e980) maps982))))) ((lambda (tmp990) ((lambda (tmp991) (if (if tmp991 (apply (lambda (dots992 e993) (ellipsis?983 dots992)) tmp991) #f) (apply (lambda (dots994 e995) (gen-syntax944 src979 e995 r981 maps982 (lambda (x996) #f) mod984)) tmp991) ((lambda (tmp997) (if (if tmp997 (apply (lambda (x998 dots999 y1000) (ellipsis?983 dots999)) tmp997) #f) (apply (lambda (x1001 dots1002 y1003) (letrec ((f1004 (lambda (y1005 k1006) ((lambda (tmp1010) ((lambda (tmp1011) (if (if tmp1011 (apply (lambda (dots1012 y1013) (ellipsis?983 dots1012)) tmp1011) #f) (apply (lambda (dots1014 y1015) (f1004 y1015 (lambda (maps1016) (call-with-values (lambda () (k1006 (cons (quote ()) maps1016))) (lambda (x1017 maps1018) (if (null? (car maps1018)) (syntax-violation (quote syntax) "extra ellipsis" src979) (values (gen-mappend946 x1017 (car maps1018)) (cdr maps1018)))))))) tmp1011) ((lambda (_1019) (call-with-values (lambda () (gen-syntax944 src979 y1005 r981 maps982 ellipsis?983 mod984)) (lambda (y1020 maps1021) (call-with-values (lambda () (k1006 maps1021)) (lambda (x1022 maps1023) (values (gen-append949 x1022 y1020) maps1023)))))) tmp1010))) ($sc-dispatch tmp1010 (quote (any . any))))) y1005)))) (f1004 y1003 (lambda (maps1007) (call-with-values (lambda () (gen-syntax944 src979 x1001 r981 (cons (quote ()) maps1007) ellipsis?983 mod984)) (lambda (x1008 maps1009) (if (null? (car maps1009)) (syntax-violation (quote syntax) "extra ellipsis" src979) (values (gen-map947 x1008 (car maps1009)) (cdr maps1009))))))))) tmp997) ((lambda (tmp1024) (if tmp1024 (apply (lambda (x1025 y1026) (call-with-values (lambda () (gen-syntax944 src979 x1025 r981 maps982 ellipsis?983 mod984)) (lambda (x1027 maps1028) (call-with-values (lambda () (gen-syntax944 src979 y1026 r981 maps1028 ellipsis?983 mod984)) (lambda (y1029 maps1030) (values (gen-cons948 x1027 y1029) maps1030)))))) tmp1024) ((lambda (tmp1031) (if tmp1031 (apply (lambda (e11032 e21033) (call-with-values (lambda () (gen-syntax944 src979 (cons e11032 e21033) r981 maps982 ellipsis?983 mod984)) (lambda (e1035 maps1036) (values (gen-vector950 e1035) maps1036)))) tmp1031) ((lambda (_1037) (values (list (quote quote) e980) maps982)) tmp990))) ($sc-dispatch tmp990 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp990 (quote (any . any)))))) ($sc-dispatch tmp990 (quote (any any . any)))))) ($sc-dispatch tmp990 (quote (any any))))) e980))))) (lambda (e1038 r1039 w1040 s1041 mod1042) (let ((e1043 (source-wrap143 e1038 w1040 s1041 mod1042))) ((lambda (tmp1044) ((lambda (tmp1045) (if tmp1045 (apply (lambda (_1046 x1047) (call-with-values (lambda () (gen-syntax944 e1043 x1047 r1039 (quote ()) ellipsis?159 mod1042)) (lambda (e1048 maps1049) (regen951 e1048)))) tmp1045) ((lambda (_1050) (syntax-violation (quote syntax) "bad `syntax' form" e1043)) tmp1044))) ($sc-dispatch tmp1044 (quote (any any))))) e1043))))) (global-extend112 (quote core) (quote lambda) (lambda (e1051 r1052 w1053 s1054 mod1055) ((lambda (tmp1056) ((lambda (tmp1057) (if tmp1057 (apply (lambda (_1058 c1059) (chi-lambda-clause155 (source-wrap143 e1051 w1053 s1054 mod1055) #f c1059 r1052 w1053 mod1055 (lambda (names1060 vars1061 docstring1062 body1063) (build-lambda90 s1054 names1060 vars1061 docstring1062 body1063)))) tmp1057) (syntax-violation #f "source expression failed to match any pattern" tmp1056))) ($sc-dispatch tmp1056 (quote (any . any))))) e1051))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1064 (lambda (e1065 r1066 w1067 s1068 mod1069 constructor1070 ids1071 vals1072 exps1073) (if (not (valid-bound-ids?139 ids1071)) (syntax-violation (quote let) "duplicate bound variable" e1065) (let ((labels1074 (gen-labels120 ids1071)) (new-vars1075 (map gen-var162 ids1071))) (let ((nw1076 (make-binding-wrap131 ids1071 labels1074 w1067)) (nr1077 (extend-var-env109 labels1074 new-vars1075 r1066))) (constructor1070 s1068 (map syntax->datum ids1071) new-vars1075 (map (lambda (x1078) (chi150 x1078 r1066 w1067 mod1069)) vals1072) (chi-body154 exps1073 (source-wrap143 e1065 nw1076 s1068 mod1069) nr1077 nw1076 mod1069)))))))) (lambda (e1079 r1080 w1081 s1082 mod1083) ((lambda (tmp1084) ((lambda (tmp1085) (if (if tmp1085 (apply (lambda (_1086 id1087 val1088 e11089 e21090) (and-map id?114 id1087)) tmp1085) #f) (apply (lambda (_1092 id1093 val1094 e11095 e21096) (chi-let1064 e1079 r1080 w1081 s1082 mod1083 build-let94 id1093 val1094 (cons e11095 e21096))) tmp1085) ((lambda (tmp1100) (if (if tmp1100 (apply (lambda (_1101 f1102 id1103 val1104 e11105 e21106) (if (id?114 f1102) (and-map id?114 id1103) #f)) tmp1100) #f) (apply (lambda (_1108 f1109 id1110 val1111 e11112 e21113) (chi-let1064 e1079 r1080 w1081 s1082 mod1083 build-named-let95 (cons f1109 id1110) val1111 (cons e11112 e21113))) tmp1100) ((lambda (_1117) (syntax-violation (quote let) "bad let" (source-wrap143 e1079 w1081 s1082 mod1083))) tmp1084))) ($sc-dispatch tmp1084 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1084 (quote (any #(each (any any)) any . each-any))))) e1079)))) (global-extend112 (quote core) (quote letrec) (lambda (e1118 r1119 w1120 s1121 mod1122) ((lambda (tmp1123) ((lambda (tmp1124) (if (if tmp1124 (apply (lambda (_1125 id1126 val1127 e11128 e21129) (and-map id?114 id1126)) tmp1124) #f) (apply (lambda (_1131 id1132 val1133 e11134 e21135) (let ((ids1136 id1132)) (if (not (valid-bound-ids?139 ids1136)) (syntax-violation (quote letrec) "duplicate bound variable" e1118) (let ((labels1138 (gen-labels120 ids1136)) (new-vars1139 (map gen-var162 ids1136))) (let ((w1140 (make-binding-wrap131 ids1136 labels1138 w1120)) (r1141 (extend-var-env109 labels1138 new-vars1139 r1119))) (build-letrec96 s1121 (map syntax->datum ids1136) new-vars1139 (map (lambda (x1142) (chi150 x1142 r1141 w1140 mod1122)) val1133) (chi-body154 (cons e11134 e21135) (source-wrap143 e1118 w1140 s1121 mod1122) r1141 w1140 mod1122))))))) tmp1124) ((lambda (_1145) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1118 w1120 s1121 mod1122))) tmp1123))) ($sc-dispatch tmp1123 (quote (any #(each (any any)) any . each-any))))) e1118))) (global-extend112 (quote core) (quote set!) (lambda (e1146 r1147 w1148 s1149 mod1150) ((lambda (tmp1151) ((lambda (tmp1152) (if (if tmp1152 (apply (lambda (_1153 id1154 val1155) (id?114 id1154)) tmp1152) #f) (apply (lambda (_1156 id1157 val1158) (let ((val1159 (chi150 val1158 r1147 w1148 mod1150)) (n1160 (id-var-name136 id1157 w1148))) (let ((b1161 (lookup111 n1160 r1147 mod1150))) (let ((atom-key1162 (binding-type106 b1161))) (if (memv atom-key1162 (quote (lexical))) (build-lexical-assignment84 s1149 (syntax->datum id1157) (binding-value107 b1161) val1159) (if (memv atom-key1162 (quote (global))) (build-global-assignment87 s1149 n1160 val1159 mod1150) (if (memv atom-key1162 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1157 w1148 mod1150)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1146 w1148 s1149 mod1150))))))))) tmp1152) ((lambda (tmp1163) (if tmp1163 (apply (lambda (_1164 head1165 tail1166 val1167) (call-with-values (lambda () (syntax-type148 head1165 r1147 (quote (())) #f #f mod1150)) (lambda (type1168 value1169 ee1170 ww1171 ss1172 modmod1173) (if (memv type1168 (quote (module-ref))) (let ((val1174 (chi150 val1167 r1147 w1148 mod1150))) (call-with-values (lambda () (value1169 (cons head1165 tail1166))) (lambda (id1176 mod1177) (build-global-assignment87 s1149 id1176 val1174 mod1177)))) (build-application81 s1149 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1165) r1147 w1148 mod1150) (map (lambda (e1178) (chi150 e1178 r1147 w1148 mod1150)) (append tail1166 (list val1167)))))))) tmp1163) ((lambda (_1180) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1146 w1148 s1149 mod1150))) tmp1151))) ($sc-dispatch tmp1151 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1151 (quote (any any any))))) e1146))) (global-extend112 (quote module-ref) (quote @) (lambda (e1181) ((lambda (tmp1182) ((lambda (tmp1183) (if (if tmp1183 (apply (lambda (_1184 mod1185 id1186) (if (and-map id?114 mod1185) (id?114 id1186) #f)) tmp1183) #f) (apply (lambda (_1188 mod1189 id1190) (values (syntax->datum id1190) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1189)))) tmp1183) (syntax-violation #f "source expression failed to match any pattern" tmp1182))) ($sc-dispatch tmp1182 (quote (any each-any any))))) e1181))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1192) ((lambda (tmp1193) ((lambda (tmp1194) (if (if tmp1194 (apply (lambda (_1195 mod1196 id1197) (if (and-map id?114 mod1196) (id?114 id1197) #f)) tmp1194) #f) (apply (lambda (_1199 mod1200 id1201) (values (syntax->datum id1201) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1200)))) tmp1194) (syntax-violation #f "source expression failed to match any pattern" tmp1193))) ($sc-dispatch tmp1193 (quote (any each-any any))))) e1192))) (global-extend112 (quote core) (quote if) (lambda (e1203 r1204 w1205 s1206 mod1207) ((lambda (tmp1208) ((lambda (tmp1209) (if tmp1209 (apply (lambda (_1210 test1211 then1212) (build-conditional82 s1206 (chi150 test1211 r1204 w1205 mod1207) (chi150 then1212 r1204 w1205 mod1207) (build-void80 #f))) tmp1209) ((lambda (tmp1213) (if tmp1213 (apply (lambda (_1214 test1215 then1216 else1217) (build-conditional82 s1206 (chi150 test1215 r1204 w1205 mod1207) (chi150 then1216 r1204 w1205 mod1207) (chi150 else1217 r1204 w1205 mod1207))) tmp1213) (syntax-violation #f "source expression failed to match any pattern" tmp1208))) ($sc-dispatch tmp1208 (quote (any any any any)))))) ($sc-dispatch tmp1208 (quote (any any any))))) e1203))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1221 (lambda (x1222 keys1223 clauses1224 r1225 mod1226) (if (null? clauses1224) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1222)) ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda (pat1229 exp1230) (if (if (id?114 pat1229) (and-map (lambda (x1231) (not (free-id=?137 pat1229 x1231))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1223)) #f) (let ((labels1232 (list (gen-label119))) (var1233 (gen-var162 pat1229))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1229)) (list var1233) #f (chi150 exp1230 (extend-env108 labels1232 (list (cons (quote syntax) (cons var1233 0))) r1225) (make-binding-wrap131 (list pat1229) labels1232 (quote (()))) mod1226)) (list x1222))) (gen-clause1220 x1222 keys1223 (cdr clauses1224) r1225 pat1229 #t exp1230 mod1226))) tmp1228) ((lambda (tmp1234) (if tmp1234 (apply (lambda (pat1235 fender1236 exp1237) (gen-clause1220 x1222 keys1223 (cdr clauses1224) r1225 pat1235 fender1236 exp1237 mod1226)) tmp1234) ((lambda (_1238) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1224))) tmp1227))) ($sc-dispatch tmp1227 (quote (any any any)))))) ($sc-dispatch tmp1227 (quote (any any))))) (car clauses1224))))) (gen-clause1220 (lambda (x1239 keys1240 clauses1241 r1242 pat1243 fender1244 exp1245 mod1246) (call-with-values (lambda () (convert-pattern1218 pat1243 keys1240)) (lambda (p1247 pvars1248) (if (not (distinct-bound-ids?140 (map car pvars1248))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1243) (if (not (and-map (lambda (x1249) (not (ellipsis?159 (car x1249)))) pvars1248)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1243) (let ((y1250 (gen-var162 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1250) #f (let ((y1251 (build-lexical-reference83 (quote value) #f (quote tmp) y1250))) (build-conditional82 #f ((lambda (tmp1252) ((lambda (tmp1253) (if tmp1253 (apply (lambda () y1251) tmp1253) ((lambda (_1254) (build-conditional82 #f y1251 (build-dispatch-call1219 pvars1248 fender1244 y1251 r1242 mod1246) (build-data92 #f #f))) tmp1252))) ($sc-dispatch tmp1252 (quote #(atom #t))))) fender1244) (build-dispatch-call1219 pvars1248 exp1245 y1251 r1242 mod1246) (gen-syntax-case1221 x1239 keys1240 clauses1241 r1242 mod1246)))) (list (if (eq? p1247 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1239)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1239 (build-data92 #f p1247))))))))))))) (build-dispatch-call1219 (lambda (pvars1255 exp1256 y1257 r1258 mod1259) (let ((ids1260 (map car pvars1255)) (levels1261 (map cdr pvars1255))) (let ((labels1262 (gen-labels120 ids1260)) (new-vars1263 (map gen-var162 ids1260))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1260) new-vars1263 #f (chi150 exp1256 (extend-env108 labels1262 (map (lambda (var1264 level1265) (cons (quote syntax) (cons var1264 level1265))) new-vars1263 (map cdr pvars1255)) r1258) (make-binding-wrap131 ids1260 labels1262 (quote (()))) mod1259)) y1257)))))) (convert-pattern1218 (lambda (pattern1266 keys1267) (letrec ((cvt1268 (lambda (p1269 n1270 ids1271) (if (id?114 p1269) (if (bound-id-member?141 p1269 keys1267) (values (vector (quote free-id) p1269) ids1271) (values (quote any) (cons (cons p1269 n1270) ids1271))) ((lambda (tmp1272) ((lambda (tmp1273) (if (if tmp1273 (apply (lambda (x1274 dots1275) (ellipsis?159 dots1275)) tmp1273) #f) (apply (lambda (x1276 dots1277) (call-with-values (lambda () (cvt1268 x1276 (fx+72 n1270 1) ids1271)) (lambda (p1278 ids1279) (values (if (eq? p1278 (quote any)) (quote each-any) (vector (quote each) p1278)) ids1279)))) tmp1273) ((lambda (tmp1280) (if tmp1280 (apply (lambda (x1281 y1282) (call-with-values (lambda () (cvt1268 y1282 n1270 ids1271)) (lambda (y1283 ids1284) (call-with-values (lambda () (cvt1268 x1281 n1270 ids1284)) (lambda (x1285 ids1286) (values (cons x1285 y1283) ids1286)))))) tmp1280) ((lambda (tmp1287) (if tmp1287 (apply (lambda () (values (quote ()) ids1271)) tmp1287) ((lambda (tmp1288) (if tmp1288 (apply (lambda (x1289) (call-with-values (lambda () (cvt1268 x1289 n1270 ids1271)) (lambda (p1291 ids1292) (values (vector (quote vector) p1291) ids1292)))) tmp1288) ((lambda (x1293) (values (vector (quote atom) (strip161 p1269 (quote (())))) ids1271)) tmp1272))) ($sc-dispatch tmp1272 (quote #(vector each-any)))))) ($sc-dispatch tmp1272 (quote ()))))) ($sc-dispatch tmp1272 (quote (any . any)))))) ($sc-dispatch tmp1272 (quote (any any))))) p1269))))) (cvt1268 pattern1266 0 (quote ())))))) (lambda (e1294 r1295 w1296 s1297 mod1298) (let ((e1299 (source-wrap143 e1294 w1296 s1297 mod1298))) ((lambda (tmp1300) ((lambda (tmp1301) (if tmp1301 (apply (lambda (_1302 val1303 key1304 m1305) (if (and-map (lambda (x1306) (if (id?114 x1306) (not (ellipsis?159 x1306)) #f)) key1304) (let ((x1308 (gen-var162 (quote tmp)))) (build-application81 s1297 (build-lambda90 #f (list (quote tmp)) (list x1308) #f (gen-syntax-case1221 (build-lexical-reference83 (quote value) #f (quote tmp) x1308) key1304 m1305 r1295 mod1298)) (list (chi150 val1303 r1295 (quote (())) mod1298)))) (syntax-violation (quote syntax-case) "invalid literals list" e1299))) tmp1301) (syntax-violation #f "source expression failed to match any pattern" tmp1300))) ($sc-dispatch tmp1300 (quote (any any each-any . each-any))))) e1299))))) (set! sc-expand (lambda (x1312 . rest1311) (if (if (pair? x1312) (equal? (car x1312) noexpand70) #f) (cadr x1312) (let ((m1313 (if (null? rest1311) (quote e) (car rest1311))) (esew1314 (if (let ((t1315 (null? rest1311))) (if t1315 t1315 (null? (cdr rest1311)))) (quote (eval)) (cadr rest1311)))) (with-fluid* *mode*71 m1313 (lambda () (chi-top149 x1312 (quote ()) (quote ((top))) m1313 esew1314 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1316) (nonsymbol-id?113 x1316))) (set! datum->syntax (lambda (id1317 datum1318) (make-syntax-object97 datum1318 (syntax-object-wrap100 id1317) #f))) (set! syntax->datum (lambda (x1319) (strip161 x1319 (quote (()))))) (set! generate-temporaries (lambda (ls1320) (begin (let ((x1321 ls1320)) (if (not (list? x1321)) (syntax-violation (quote generate-temporaries) "invalid argument" x1321))) (map (lambda (x1322) (wrap142 (gensym) (quote ((top))) #f)) ls1320)))) (set! free-identifier=? (lambda (x1323 y1324) (begin (let ((x1325 x1323)) (if (not (nonsymbol-id?113 x1325)) (syntax-violation (quote free-identifier=?) "invalid argument" x1325))) (let ((x1326 y1324)) (if (not (nonsymbol-id?113 x1326)) (syntax-violation (quote free-identifier=?) "invalid argument" x1326))) (free-id=?137 x1323 y1324)))) (set! bound-identifier=? (lambda (x1327 y1328) (begin (let ((x1329 x1327)) (if (not (nonsymbol-id?113 x1329)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1329))) (let ((x1330 y1328)) (if (not (nonsymbol-id?113 x1330)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1330))) (bound-id=?138 x1327 y1328)))) (set! syntax-violation (lambda (who1334 message1333 form1332 . subform1331) (begin (let ((x1335 who1334)) (if (not ((lambda (x1336) (let ((t1337 (not x1336))) (if t1337 t1337 (let ((t1338 (string? x1336))) (if t1338 t1338 (symbol? x1336)))))) x1335)) (syntax-violation (quote syntax-violation) "invalid argument" x1335))) (let ((x1339 message1333)) (if (not (string? x1339)) (syntax-violation (quote syntax-violation) "invalid argument" x1339))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1334 "~a: " "") "~a " (if (null? subform1331) "in ~a" "in subform `~s' of `~s'")) (let ((tail1340 (cons message1333 (map (lambda (x1341) (strip161 x1341 (quote (())))) (append subform1331 (list form1332)))))) (if who1334 (cons who1334 tail1340) tail1340)) #f)))) (letrec ((match1346 (lambda (e1347 p1348 w1349 r1350 mod1351) (if (not r1350) #f (if (eq? p1348 (quote any)) (cons (wrap142 e1347 w1349 mod1351) r1350) (if (syntax-object?98 e1347) (match*1345 (let ((e1352 (syntax-object-expression99 e1347))) (if (annotation? e1352) (annotation-expression e1352) e1352)) p1348 (join-wraps133 w1349 (syntax-object-wrap100 e1347)) r1350 (syntax-object-module101 e1347)) (match*1345 (let ((e1353 e1347)) (if (annotation? e1353) (annotation-expression e1353) e1353)) p1348 w1349 r1350 mod1351)))))) (match*1345 (lambda (e1354 p1355 w1356 r1357 mod1358) (if (null? p1355) (if (null? e1354) r1357 #f) (if (pair? p1355) (if (pair? e1354) (match1346 (car e1354) (car p1355) w1356 (match1346 (cdr e1354) (cdr p1355) w1356 r1357 mod1358) mod1358) #f) (if (eq? p1355 (quote each-any)) (let ((l1359 (match-each-any1343 e1354 w1356 mod1358))) (if l1359 (cons l1359 r1357) #f)) (let ((atom-key1360 (vector-ref p1355 0))) (if (memv atom-key1360 (quote (each))) (if (null? e1354) (match-empty1344 (vector-ref p1355 1) r1357) (let ((l1361 (match-each1342 e1354 (vector-ref p1355 1) w1356 mod1358))) (if l1361 (letrec ((collect1362 (lambda (l1363) (if (null? (car l1363)) r1357 (cons (map car l1363) (collect1362 (map cdr l1363))))))) (collect1362 l1361)) #f))) (if (memv atom-key1360 (quote (free-id))) (if (id?114 e1354) (if (free-id=?137 (wrap142 e1354 w1356 mod1358) (vector-ref p1355 1)) r1357 #f) #f) (if (memv atom-key1360 (quote (atom))) (if (equal? (vector-ref p1355 1) (strip161 e1354 w1356)) r1357 #f) (if (memv atom-key1360 (quote (vector))) (if (vector? e1354) (match1346 (vector->list e1354) (vector-ref p1355 1) w1356 r1357 mod1358) #f))))))))))) (match-empty1344 (lambda (p1364 r1365) (if (null? p1364) r1365 (if (eq? p1364 (quote any)) (cons (quote ()) r1365) (if (pair? p1364) (match-empty1344 (car p1364) (match-empty1344 (cdr p1364) r1365)) (if (eq? p1364 (quote each-any)) (cons (quote ()) r1365) (let ((atom-key1366 (vector-ref p1364 0))) (if (memv atom-key1366 (quote (each))) (match-empty1344 (vector-ref p1364 1) r1365) (if (memv atom-key1366 (quote (free-id atom))) r1365 (if (memv atom-key1366 (quote (vector))) (match-empty1344 (vector-ref p1364 1) r1365))))))))))) (match-each-any1343 (lambda (e1367 w1368 mod1369) (if (annotation? e1367) (match-each-any1343 (annotation-expression e1367) w1368 mod1369) (if (pair? e1367) (let ((l1370 (match-each-any1343 (cdr e1367) w1368 mod1369))) (if l1370 (cons (wrap142 (car e1367) w1368 mod1369) l1370) #f)) (if (null? e1367) (quote ()) (if (syntax-object?98 e1367) (match-each-any1343 (syntax-object-expression99 e1367) (join-wraps133 w1368 (syntax-object-wrap100 e1367)) mod1369) #f)))))) (match-each1342 (lambda (e1371 p1372 w1373 mod1374) (if (annotation? e1371) (match-each1342 (annotation-expression e1371) p1372 w1373 mod1374) (if (pair? e1371) (let ((first1375 (match1346 (car e1371) p1372 w1373 (quote ()) mod1374))) (if first1375 (let ((rest1376 (match-each1342 (cdr e1371) p1372 w1373 mod1374))) (if rest1376 (cons first1375 rest1376) #f)) #f)) (if (null? e1371) (quote ()) (if (syntax-object?98 e1371) (match-each1342 (syntax-object-expression99 e1371) p1372 (join-wraps133 w1373 (syntax-object-wrap100 e1371)) (syntax-object-module101 e1371)) #f))))))) (set! $sc-dispatch (lambda (e1377 p1378) (if (eq? p1378 (quote any)) (list e1377) (if (syntax-object?98 e1377) (match*1345 (let ((e1379 (syntax-object-expression99 e1377))) (if (annotation? e1379) (annotation-expression e1379) e1379)) p1378 (syntax-object-wrap100 e1377) (quote ()) (syntax-object-module101 e1377)) (match*1345 (let ((e1380 e1377)) (if (annotation? e1380) (annotation-expression e1380) e1380)) p1378 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1381) ((lambda (tmp1382) ((lambda (tmp1383) (if tmp1383 (apply (lambda (_1384 e11385 e21386) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11385 e21386))) tmp1383) ((lambda (tmp1388) (if tmp1388 (apply (lambda (_1389 out1390 in1391 e11392 e21393) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1391 (quote ()) (list out1390 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11392 e21393))))) tmp1388) ((lambda (tmp1395) (if tmp1395 (apply (lambda (_1396 out1397 in1398 e11399 e21400) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1398) (quote ()) (list out1397 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11399 e21400))))) tmp1395) (syntax-violation #f "source expression failed to match any pattern" tmp1382))) ($sc-dispatch tmp1382 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1382 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1382 (quote (any () any . each-any))))) x1381)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1404) ((lambda (tmp1405) ((lambda (tmp1406) (if tmp1406 (apply (lambda (_1407 k1408 keyword1409 pattern1410 template1411) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1408 (map (lambda (tmp1414 tmp1413) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1413) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1414))) template1411 pattern1410)))))) tmp1406) (syntax-violation #f "source expression failed to match any pattern" tmp1405))) ($sc-dispatch tmp1405 (quote (any each-any . #(each ((any . any) any))))))) x1404)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1415) ((lambda (tmp1416) ((lambda (tmp1417) (if (if tmp1417 (apply (lambda (let*1418 x1419 v1420 e11421 e21422) (and-map identifier? x1419)) tmp1417) #f) (apply (lambda (let*1424 x1425 v1426 e11427 e21428) (letrec ((f1429 (lambda (bindings1430) (if (null? bindings1430) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11427 e21428))) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (body1436 binding1437) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1437) body1436)) tmp1435) (syntax-violation #f "source expression failed to match any pattern" tmp1434))) ($sc-dispatch tmp1434 (quote (any any))))) (list (f1429 (cdr bindings1430)) (car bindings1430))))))) (f1429 (map list x1425 v1426)))) tmp1417) (syntax-violation #f "source expression failed to match any pattern" tmp1416))) ($sc-dispatch tmp1416 (quote (any #(each (any any)) any . each-any))))) x1415)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1438) ((lambda (tmp1439) ((lambda (tmp1440) (if tmp1440 (apply (lambda (_1441 var1442 init1443 step1444 e01445 e11446 c1447) ((lambda (tmp1448) ((lambda (tmp1449) (if tmp1449 (apply (lambda (step1450) ((lambda (tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1442 init1443) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01445) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1447 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1450))))))) tmp1452) ((lambda (tmp1457) (if tmp1457 (apply (lambda (e11458 e21459) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1442 init1443) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01445 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11458 e21459)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1447 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1450))))))) tmp1457) (syntax-violation #f "source expression failed to match any pattern" tmp1451))) ($sc-dispatch tmp1451 (quote (any . each-any)))))) ($sc-dispatch tmp1451 (quote ())))) e11446)) tmp1449) (syntax-violation #f "source expression failed to match any pattern" tmp1448))) ($sc-dispatch tmp1448 (quote each-any)))) (map (lambda (v1466 s1467) ((lambda (tmp1468) ((lambda (tmp1469) (if tmp1469 (apply (lambda () v1466) tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda (e1471) e1471) tmp1470) ((lambda (_1472) (syntax-violation (quote do) "bad step expression" orig-x1438 s1467)) tmp1468))) ($sc-dispatch tmp1468 (quote (any)))))) ($sc-dispatch tmp1468 (quote ())))) s1467)) var1442 step1444))) tmp1440) (syntax-violation #f "source expression failed to match any pattern" tmp1439))) ($sc-dispatch tmp1439 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1438)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1475 (lambda (x1479 y1480) ((lambda (tmp1481) ((lambda (tmp1482) (if tmp1482 (apply (lambda (x1483 y1484) ((lambda (tmp1485) ((lambda (tmp1486) (if tmp1486 (apply (lambda (dy1487) ((lambda (tmp1488) ((lambda (tmp1489) (if tmp1489 (apply (lambda (dx1490) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1490 dy1487))) tmp1489) ((lambda (_1491) (if (null? dy1487) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483 y1484))) tmp1488))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1483)) tmp1486) ((lambda (tmp1492) (if tmp1492 (apply (lambda (stuff1493) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1483 stuff1493))) tmp1492) ((lambda (else1494) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483 y1484)) tmp1485))) ($sc-dispatch tmp1485 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1485 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1484)) tmp1482) (syntax-violation #f "source expression failed to match any pattern" tmp1481))) ($sc-dispatch tmp1481 (quote (any any))))) (list x1479 y1480)))) (quasiappend1476 (lambda (x1495 y1496) ((lambda (tmp1497) ((lambda (tmp1498) (if tmp1498 (apply (lambda (x1499 y1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda () x1499) tmp1502) ((lambda (_1503) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1499 y1500)) tmp1501))) ($sc-dispatch tmp1501 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1500)) tmp1498) (syntax-violation #f "source expression failed to match any pattern" tmp1497))) ($sc-dispatch tmp1497 (quote (any any))))) (list x1495 y1496)))) (quasivector1477 (lambda (x1504) ((lambda (tmp1505) ((lambda (x1506) ((lambda (tmp1507) ((lambda (tmp1508) (if tmp1508 (apply (lambda (x1509) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1509))) tmp1508) ((lambda (tmp1511) (if tmp1511 (apply (lambda (x1512) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1512)) tmp1511) ((lambda (_1514) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1506)) tmp1507))) ($sc-dispatch tmp1507 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1507 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1506)) tmp1505)) x1504))) (quasi1478 (lambda (p1515 lev1516) ((lambda (tmp1517) ((lambda (tmp1518) (if tmp1518 (apply (lambda (p1519) (if (= lev1516 0) p1519 (quasicons1475 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1478 (list p1519) (- lev1516 1))))) tmp1518) ((lambda (tmp1520) (if (if tmp1520 (apply (lambda (args1521) (= lev1516 0)) tmp1520) #f) (apply (lambda (args1522) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1515 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1522))) tmp1520) ((lambda (tmp1523) (if tmp1523 (apply (lambda (p1524 q1525) (if (= lev1516 0) (quasiappend1476 p1524 (quasi1478 q1525 lev1516)) (quasicons1475 (quasicons1475 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1478 (list p1524) (- lev1516 1))) (quasi1478 q1525 lev1516)))) tmp1523) ((lambda (tmp1526) (if (if tmp1526 (apply (lambda (args1527 q1528) (= lev1516 0)) tmp1526) #f) (apply (lambda (args1529 q1530) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1515 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1529))) tmp1526) ((lambda (tmp1531) (if tmp1531 (apply (lambda (p1532) (quasicons1475 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1478 (list p1532) (+ lev1516 1)))) tmp1531) ((lambda (tmp1533) (if tmp1533 (apply (lambda (p1534 q1535) (quasicons1475 (quasi1478 p1534 lev1516) (quasi1478 q1535 lev1516))) tmp1533) ((lambda (tmp1536) (if tmp1536 (apply (lambda (x1537) (quasivector1477 (quasi1478 x1537 lev1516))) tmp1536) ((lambda (p1539) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1539)) tmp1517))) ($sc-dispatch tmp1517 (quote #(vector each-any)))))) ($sc-dispatch tmp1517 (quote (any . any)))))) ($sc-dispatch tmp1517 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1517 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1517 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1517 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1517 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1515)))) (lambda (x1540) ((lambda (tmp1541) ((lambda (tmp1542) (if tmp1542 (apply (lambda (_1543 e1544) (quasi1478 e1544 0)) tmp1542) (syntax-violation #f "source expression failed to match any pattern" tmp1541))) ($sc-dispatch tmp1541 (quote (any any))))) x1540))))) -(define include (make-syncase-macro (quote macro) (lambda (x1545) (letrec ((read-file1546 (lambda (fn1547 k1548) (let ((p1549 (open-input-file fn1547))) (letrec ((f1550 (lambda (x1551) (if (eof-object? x1551) (begin (close-input-port p1549) (quote ())) (cons (datum->syntax k1548 x1551) (f1550 (read p1549))))))) (f1550 (read p1549))))))) ((lambda (tmp1552) ((lambda (tmp1553) (if tmp1553 (apply (lambda (k1554 filename1555) (let ((fn1556 (syntax->datum filename1555))) ((lambda (tmp1557) ((lambda (tmp1558) (if tmp1558 (apply (lambda (exp1559) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1559)) tmp1558) (syntax-violation #f "source expression failed to match any pattern" tmp1557))) ($sc-dispatch tmp1557 (quote each-any)))) (read-file1546 fn1556 k1554)))) tmp1553) (syntax-violation #f "source expression failed to match any pattern" tmp1552))) ($sc-dispatch tmp1552 (quote (any any))))) x1545))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1561) ((lambda (tmp1562) ((lambda (tmp1563) (if tmp1563 (apply (lambda (_1564 e1565) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1561)) tmp1563) (syntax-violation #f "source expression failed to match any pattern" tmp1562))) ($sc-dispatch tmp1562 (quote (any any))))) x1561)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1566) ((lambda (tmp1567) ((lambda (tmp1568) (if tmp1568 (apply (lambda (_1569 e1570) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1566)) tmp1568) (syntax-violation #f "source expression failed to match any pattern" tmp1567))) ($sc-dispatch tmp1567 (quote (any any))))) x1566)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1571) ((lambda (tmp1572) ((lambda (tmp1573) (if tmp1573 (apply (lambda (_1574 e1575 m11576 m21577) ((lambda (tmp1578) ((lambda (body1579) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1575)) body1579)) tmp1578)) (letrec ((f1580 (lambda (clause1581 clauses1582) (if (null? clauses1582) ((lambda (tmp1584) ((lambda (tmp1585) (if tmp1585 (apply (lambda (e11586 e21587) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11586 e21587))) tmp1585) ((lambda (tmp1589) (if tmp1589 (apply (lambda (k1590 e11591 e21592) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1590)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11591 e21592)))) tmp1589) ((lambda (_1595) (syntax-violation (quote case) "bad clause" x1571 clause1581)) tmp1584))) ($sc-dispatch tmp1584 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1584 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1581) ((lambda (tmp1596) ((lambda (rest1597) ((lambda (tmp1598) ((lambda (tmp1599) (if tmp1599 (apply (lambda (k1600 e11601 e21602) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1600)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11601 e21602)) rest1597)) tmp1599) ((lambda (_1605) (syntax-violation (quote case) "bad clause" x1571 clause1581)) tmp1598))) ($sc-dispatch tmp1598 (quote (each-any any . each-any))))) clause1581)) tmp1596)) (f1580 (car clauses1582) (cdr clauses1582))))))) (f1580 m11576 m21577)))) tmp1573) (syntax-violation #f "source expression failed to match any pattern" tmp1572))) ($sc-dispatch tmp1572 (quote (any any any . each-any))))) x1571)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1606) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (_1609 e1610) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1610)) (list (cons _1609 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1610 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1608) (syntax-violation #f "source expression failed to match any pattern" tmp1607))) ($sc-dispatch tmp1607 (quote (any any))))) x1606)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list163 (lambda (vars292) (letrec ((lvl293 (lambda (vars294 ls295 w296) (if (pair? vars294) (lvl293 (cdr vars294) (cons (wrap142 (car vars294) w296 #f) ls295) w296) (if (id?114 vars294) (cons (wrap142 vars294 w296 #f) ls295) (if (null? vars294) ls295 (if (syntax-object?98 vars294) (lvl293 (syntax-object-expression99 vars294) ls295 (join-wraps133 w296 (syntax-object-wrap100 vars294))) (if (annotation? vars294) (lvl293 (annotation-expression vars294) ls295 w296) (cons vars294 ls295))))))))) (lvl293 vars292 (quote ()) (quote (())))))) (gen-var162 (lambda (id297) (let ((id298 (if (syntax-object?98 id297) (syntax-object-expression99 id297) id297))) (if (annotation? id298) (gensym (symbol->string (annotation-expression id298))) (gensym (symbol->string id298)))))) (strip161 (lambda (x299 w300) (if (memq (quote top) (wrap-marks117 w300)) (if (let ((t301 (annotation? x299))) (if t301 t301 (if (pair? x299) (annotation? (car x299)) #f))) (strip-annotation160 x299 #f) x299) (letrec ((f302 (lambda (x303) (if (syntax-object?98 x303) (strip161 (syntax-object-expression99 x303) (syntax-object-wrap100 x303)) (if (pair? x303) (let ((a304 (f302 (car x303))) (d305 (f302 (cdr x303)))) (if (if (eq? a304 (car x303)) (eq? d305 (cdr x303)) #f) x303 (cons a304 d305))) (if (vector? x303) (let ((old306 (vector->list x303))) (let ((new307 (map f302 old306))) (if (and-map*17 eq? old306 new307) x303 (list->vector new307)))) x303)))))) (f302 x299))))) (strip-annotation160 (lambda (x308 parent309) (if (pair? x308) (let ((new310 (cons #f #f))) (begin (if parent309 (set-annotation-stripped! parent309 new310)) (set-car! new310 (strip-annotation160 (car x308) #f)) (set-cdr! new310 (strip-annotation160 (cdr x308) #f)) new310)) (if (annotation? x308) (let ((t311 (annotation-stripped x308))) (if t311 t311 (strip-annotation160 (annotation-expression x308) x308))) (if (vector? x308) (let ((new312 (make-vector (vector-length x308)))) (begin (if parent309 (set-annotation-stripped! parent309 new312)) (letrec ((loop313 (lambda (i314) (unless (fx<75 i314 0) (vector-set! new312 i314 (strip-annotation160 (vector-ref x308 i314) #f)) (loop313 (fx-73 i314 1)))))) (loop313 (- (vector-length x308) 1))) new312)) x308))))) (ellipsis?159 (lambda (x315) (if (nonsymbol-id?113 x315) (free-id=?137 x315 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded316 mod317) (let ((p318 (local-eval-hook77 expanded316 mod317))) (if (procedure? p318) p318 (syntax-violation #f "nonprocedure transformer" p318))))) (chi-local-syntax156 (lambda (rec?319 e320 r321 w322 s323 mod324 k325) ((lambda (tmp326) ((lambda (tmp327) (if tmp327 (apply (lambda (_328 id329 val330 e1331 e2332) (let ((ids333 id329)) (if (not (valid-bound-ids?139 ids333)) (syntax-violation #f "duplicate bound keyword" e320) (let ((labels335 (gen-labels120 ids333))) (let ((new-w336 (make-binding-wrap131 ids333 labels335 w322))) (k325 (cons e1331 e2332) (extend-env108 labels335 (let ((w338 (if rec?319 new-w336 w322)) (trans-r339 (macros-only-env110 r321))) (map (lambda (x340) (cons (quote macro) (eval-local-transformer157 (chi150 x340 trans-r339 w338 mod324) mod324))) val330)) r321) new-w336 s323 mod324)))))) tmp327) ((lambda (_342) (syntax-violation #f "bad local syntax definition" (source-wrap143 e320 w322 s323 mod324))) tmp326))) ($sc-dispatch tmp326 (quote (any #(each (any any)) any . each-any))))) e320))) (chi-lambda-clause155 (lambda (e343 docstring344 c345 r346 w347 mod348 k349) ((lambda (tmp350) ((lambda (tmp351) (if (if tmp351 (apply (lambda (args352 doc353 e1354 e2355) (if (string? (syntax->datum doc353)) (not docstring344) #f)) tmp351) #f) (apply (lambda (args356 doc357 e1358 e2359) (chi-lambda-clause155 e343 doc357 (cons args356 (cons e1358 e2359)) r346 w347 mod348 k349)) tmp351) ((lambda (tmp361) (if tmp361 (apply (lambda (id362 e1363 e2364) (let ((ids365 id362)) (if (not (valid-bound-ids?139 ids365)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels367 (gen-labels120 ids365)) (new-vars368 (map gen-var162 ids365))) (k349 (map syntax->datum ids365) new-vars368 (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1363 e2364) e343 (extend-var-env109 labels367 new-vars368 r346) (make-binding-wrap131 ids365 labels367 w347) mod348)))))) tmp361) ((lambda (tmp370) (if tmp370 (apply (lambda (ids371 e1372 e2373) (let ((old-ids374 (lambda-var-list163 ids371))) (if (not (valid-bound-ids?139 old-ids374)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels375 (gen-labels120 old-ids374)) (new-vars376 (map gen-var162 old-ids374))) (k349 (letrec ((f377 (lambda (ls1378 ls2379) (if (null? ls1378) (syntax->datum ls2379) (f377 (cdr ls1378) (cons (syntax->datum (car ls1378)) ls2379)))))) (f377 (cdr old-ids374) (car old-ids374))) (letrec ((f380 (lambda (ls1381 ls2382) (if (null? ls1381) ls2382 (f380 (cdr ls1381) (cons (car ls1381) ls2382)))))) (f380 (cdr new-vars376) (car new-vars376))) (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1372 e2373) e343 (extend-var-env109 labels375 new-vars376 r346) (make-binding-wrap131 old-ids374 labels375 w347) mod348)))))) tmp370) ((lambda (_384) (syntax-violation (quote lambda) "bad lambda" e343)) tmp350))) ($sc-dispatch tmp350 (quote (any any . each-any)))))) ($sc-dispatch tmp350 (quote (each-any any . each-any)))))) ($sc-dispatch tmp350 (quote (any any any . each-any))))) c345))) (chi-body154 (lambda (body385 outer-form386 r387 w388 mod389) (let ((r390 (cons (quote ("placeholder" placeholder)) r387))) (let ((ribcage391 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w392 (make-wrap116 (wrap-marks117 w388) (cons ribcage391 (wrap-subst118 w388))))) (letrec ((parse393 (lambda (body394 ids395 labels396 var-ids397 vars398 vals399 bindings400) (if (null? body394) (syntax-violation #f "no expressions in body" outer-form386) (let ((e402 (cdar body394)) (er403 (caar body394))) (call-with-values (lambda () (syntax-type148 e402 er403 (quote (())) #f ribcage391 mod389)) (lambda (type404 value405 e406 w407 s408 mod409) (if (memv type404 (quote (define-form))) (let ((id410 (wrap142 value405 w407 mod409)) (label411 (gen-label119))) (let ((var412 (gen-var162 id410))) (begin (extend-ribcage!130 ribcage391 id410 label411) (parse393 (cdr body394) (cons id410 ids395) (cons label411 labels396) (cons id410 var-ids397) (cons var412 vars398) (cons (cons er403 (wrap142 e406 w407 mod409)) vals399) (cons (cons (quote lexical) var412) bindings400))))) (if (memv type404 (quote (define-syntax-form))) (let ((id413 (wrap142 value405 w407 mod409)) (label414 (gen-label119))) (begin (extend-ribcage!130 ribcage391 id413 label414) (parse393 (cdr body394) (cons id413 ids395) (cons label414 labels396) var-ids397 vars398 vals399 (cons (cons (quote macro) (cons er403 (wrap142 e406 w407 mod409))) bindings400)))) (if (memv type404 (quote (begin-form))) ((lambda (tmp415) ((lambda (tmp416) (if tmp416 (apply (lambda (_417 e1418) (parse393 (letrec ((f419 (lambda (forms420) (if (null? forms420) (cdr body394) (cons (cons er403 (wrap142 (car forms420) w407 mod409)) (f419 (cdr forms420))))))) (f419 e1418)) ids395 labels396 var-ids397 vars398 vals399 bindings400)) tmp416) (syntax-violation #f "source expression failed to match any pattern" tmp415))) ($sc-dispatch tmp415 (quote (any . each-any))))) e406) (if (memv type404 (quote (local-syntax-form))) (chi-local-syntax156 value405 e406 er403 w407 s408 mod409 (lambda (forms422 er423 w424 s425 mod426) (parse393 (letrec ((f427 (lambda (forms428) (if (null? forms428) (cdr body394) (cons (cons er423 (wrap142 (car forms428) w424 mod426)) (f427 (cdr forms428))))))) (f427 forms422)) ids395 labels396 var-ids397 vars398 vals399 bindings400))) (if (null? ids395) (build-sequence93 #f (map (lambda (x429) (chi150 (cdr x429) (car x429) (quote (())) mod409)) (cons (cons er403 (source-wrap143 e406 w407 s408 mod409)) (cdr body394)))) (begin (if (not (valid-bound-ids?139 ids395)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form386)) (letrec ((loop430 (lambda (bs431 er-cache432 r-cache433) (if (not (null? bs431)) (let ((b434 (car bs431))) (if (eq? (car b434) (quote macro)) (let ((er435 (cadr b434))) (let ((r-cache436 (if (eq? er435 er-cache432) r-cache433 (macros-only-env110 er435)))) (begin (set-cdr! b434 (eval-local-transformer157 (chi150 (cddr b434) r-cache436 (quote (())) mod409) mod409)) (loop430 (cdr bs431) er435 r-cache436)))) (loop430 (cdr bs431) er-cache432 r-cache433))))))) (loop430 bindings400 #f #f)) (set-cdr! r390 (extend-env108 labels396 bindings400 (cdr r390))) (build-letrec96 #f (map syntax->datum var-ids397) vars398 (map (lambda (x437) (chi150 (cdr x437) (car x437) (quote (())) mod409)) vals399) (build-sequence93 #f (map (lambda (x438) (chi150 (cdr x438) (car x438) (quote (())) mod409)) (cons (cons er403 (source-wrap143 e406 w407 s408 mod409)) (cdr body394)))))))))))))))))) (parse393 (map (lambda (x401) (cons r390 (wrap142 x401 w392 mod389))) body385) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p439 e440 r441 w442 rib443 mod444) (letrec ((rebuild-macro-output445 (lambda (x446 m447) (if (pair? x446) (cons (rebuild-macro-output445 (car x446) m447) (rebuild-macro-output445 (cdr x446) m447)) (if (syntax-object?98 x446) (let ((w448 (syntax-object-wrap100 x446))) (let ((ms449 (wrap-marks117 w448)) (s450 (wrap-subst118 w448))) (if (if (pair? ms449) (eq? (car ms449) #f) #f) (make-syntax-object97 (syntax-object-expression99 x446) (make-wrap116 (cdr ms449) (if rib443 (cons rib443 (cdr s450)) (cdr s450))) (syntax-object-module101 x446)) (make-syntax-object97 (syntax-object-expression99 x446) (make-wrap116 (cons m447 ms449) (if rib443 (cons rib443 (cons (quote shift) s450)) (cons (quote shift) s450))) (let ((pmod451 (procedure-module p439))) (if pmod451 (cons (quote hygiene) (module-name pmod451)) (quote (hygiene guile)))))))) (if (vector? x446) (let ((n452 (vector-length x446))) (let ((v453 (make-vector n452))) (letrec ((loop454 (lambda (i455) (if (fx=74 i455 n452) (begin (if #f #f) v453) (begin (vector-set! v453 i455 (rebuild-macro-output445 (vector-ref x446 i455) m447)) (loop454 (fx+72 i455 1))))))) (loop454 0)))) (if (symbol? x446) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e440 w442 s mod444) x446) x446))))))) (rebuild-macro-output445 (p439 (wrap142 e440 (anti-mark129 w442) mod444)) (string #\m))))) (chi-application152 (lambda (x456 e457 r458 w459 s460 mod461) ((lambda (tmp462) ((lambda (tmp463) (if tmp463 (apply (lambda (e0464 e1465) (build-application81 s460 x456 (map (lambda (e466) (chi150 e466 r458 w459 mod461)) e1465))) tmp463) (syntax-violation #f "source expression failed to match any pattern" tmp462))) ($sc-dispatch tmp462 (quote (any . each-any))))) e457))) (chi-expr151 (lambda (type468 value469 e470 r471 w472 s473 mod474) (if (memv type468 (quote (lexical))) (build-lexical-reference83 (quote value) s473 e470 value469) (if (memv type468 (quote (core external-macro))) (value469 e470 r471 w472 s473 mod474) (if (memv type468 (quote (module-ref))) (call-with-values (lambda () (value469 e470)) (lambda (id475 mod476) (build-global-reference86 s473 id475 mod476))) (if (memv type468 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e470)) (car e470) value469) e470 r471 w472 s473 mod474) (if (memv type468 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e470)) value469 (if (syntax-object?98 (car e470)) (syntax-object-module101 (car e470)) mod474)) e470 r471 w472 s473 mod474) (if (memv type468 (quote (constant))) (build-data92 s473 (strip161 (source-wrap143 e470 w472 s473 mod474) (quote (())))) (if (memv type468 (quote (global))) (build-global-reference86 s473 value469 mod474) (if (memv type468 (quote (call))) (chi-application152 (chi150 (car e470) r471 w472 mod474) e470 r471 w472 s473 mod474) (if (memv type468 (quote (begin-form))) ((lambda (tmp477) ((lambda (tmp478) (if tmp478 (apply (lambda (_479 e1480 e2481) (chi-sequence144 (cons e1480 e2481) r471 w472 s473 mod474)) tmp478) (syntax-violation #f "source expression failed to match any pattern" tmp477))) ($sc-dispatch tmp477 (quote (any any . each-any))))) e470) (if (memv type468 (quote (local-syntax-form))) (chi-local-syntax156 value469 e470 r471 w472 s473 mod474 chi-sequence144) (if (memv type468 (quote (eval-when-form))) ((lambda (tmp483) ((lambda (tmp484) (if tmp484 (apply (lambda (_485 x486 e1487 e2488) (let ((when-list489 (chi-when-list147 e470 x486 w472))) (if (memq (quote eval) when-list489) (chi-sequence144 (cons e1487 e2488) r471 w472 s473 mod474) (chi-void158)))) tmp484) (syntax-violation #f "source expression failed to match any pattern" tmp483))) ($sc-dispatch tmp483 (quote (any each-any any . each-any))))) e470) (if (memv type468 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e470 (wrap142 value469 w472 mod474)) (if (memv type468 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e470 w472 s473 mod474)) (if (memv type468 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e470 w472 s473 mod474)) (syntax-violation #f "unexpected syntax" (source-wrap143 e470 w472 s473 mod474)))))))))))))))))) (chi150 (lambda (e492 r493 w494 mod495) (call-with-values (lambda () (syntax-type148 e492 r493 w494 #f #f mod495)) (lambda (type496 value497 e498 w499 s500 mod501) (chi-expr151 type496 value497 e498 r493 w499 s500 mod501))))) (chi-top149 (lambda (e502 r503 w504 m505 esew506 mod507) (call-with-values (lambda () (syntax-type148 e502 r503 w504 #f #f mod507)) (lambda (type515 value516 e517 w518 s519 mod520) (if (memv type515 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void158)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence145 (cons e1526 e2527) r503 w518 s519 m505 esew506 mod520)) tmp524) (syntax-violation #f "source expression failed to match any pattern" tmp521))) ($sc-dispatch tmp521 (quote (any any . each-any)))))) ($sc-dispatch tmp521 (quote (any))))) e517) (if (memv type515 (quote (local-syntax-form))) (chi-local-syntax156 value516 e517 r503 w518 s519 mod520 (lambda (body529 r530 w531 s532 mod533) (chi-top-sequence145 body529 r530 w531 s532 m505 esew506 mod533))) (if (memv type515 (quote (eval-when-form))) ((lambda (tmp534) ((lambda (tmp535) (if tmp535 (apply (lambda (_536 x537 e1538 e2539) (let ((when-list540 (chi-when-list147 e517 x537 w518)) (body541 (cons e1538 e2539))) (if (eq? m505 (quote e)) (if (memq (quote eval) when-list540) (chi-top-sequence145 body541 r503 w518 s519 (quote e) (quote (eval)) mod520) (chi-void158)) (if (memq (quote load) when-list540) (if (let ((t544 (memq (quote compile) when-list540))) (if t544 t544 (if (eq? m505 (quote c&e)) (memq (quote eval) when-list540) #f))) (chi-top-sequence145 body541 r503 w518 s519 (quote c&e) (quote (compile load)) mod520) (if (memq m505 (quote (c c&e))) (chi-top-sequence145 body541 r503 w518 s519 (quote c) (quote (load)) mod520) (chi-void158))) (if (let ((t545 (memq (quote compile) when-list540))) (if t545 t545 (if (eq? m505 (quote c&e)) (memq (quote eval) when-list540) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body541 r503 w518 s519 (quote e) (quote (eval)) mod520) mod520) (chi-void158)) (chi-void158)))))) tmp535) (syntax-violation #f "source expression failed to match any pattern" tmp534))) ($sc-dispatch tmp534 (quote (any each-any any . each-any))))) e517) (if (memv type515 (quote (define-syntax-form))) (let ((n546 (id-var-name136 value516 w518)) (r547 (macros-only-env110 r503))) (if (memv m505 (quote (c))) (if (memq (quote compile) esew506) (let ((e548 (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)))) (begin (top-level-eval-hook76 e548 mod520) (if (memq (quote load) esew506) e548 (chi-void158)))) (if (memq (quote load) esew506) (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)) (chi-void158))) (if (memv m505 (quote (c&e))) (let ((e549 (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)))) (begin (top-level-eval-hook76 e549 mod520) e549)) (begin (if (memq (quote eval) esew506) (top-level-eval-hook76 (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)) mod520)) (chi-void158))))) (if (memv type515 (quote (define-form))) (let ((n550 (id-var-name136 value516 w518))) (let ((type551 (binding-type106 (lookup111 n550 r503 mod520)))) (if (memv type551 (quote (global core macro module-ref))) (let ((x552 (build-global-definition89 s519 n550 (chi150 e517 r503 w518 mod520)))) (begin (if (eq? m505 (quote c&e)) (top-level-eval-hook76 x552 mod520)) x552)) (if (memv type551 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e517 (wrap142 value516 w518 mod520)) (syntax-violation #f "cannot define keyword at top level" e517 (wrap142 value516 w518 mod520)))))) (let ((x553 (chi-expr151 type515 value516 e517 r503 w518 s519 mod520))) (begin (if (eq? m505 (quote c&e)) (top-level-eval-hook76 x553 mod520)) x553))))))))))) (syntax-type148 (lambda (e554 r555 w556 s557 rib558 mod559) (if (symbol? e554) (let ((n560 (id-var-name136 e554 w556))) (let ((b561 (lookup111 n560 r555 mod559))) (let ((type562 (binding-type106 b561))) (if (memv type562 (quote (lexical))) (values type562 (binding-value107 b561) e554 w556 s557 mod559) (if (memv type562 (quote (global))) (values type562 n560 e554 w556 s557 mod559) (if (memv type562 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b561) e554 r555 w556 rib558 mod559) r555 (quote (())) s557 rib558 mod559) (values type562 (binding-value107 b561) e554 w556 s557 mod559))))))) (if (pair? e554) (let ((first563 (car e554))) (if (id?114 first563) (let ((n564 (id-var-name136 first563 w556))) (let ((b565 (lookup111 n564 r555 (let ((t566 (if (syntax-object?98 first563) (syntax-object-module101 first563) #f))) (if t566 t566 mod559))))) (let ((type567 (binding-type106 b565))) (if (memv type567 (quote (lexical))) (values (quote lexical-call) (binding-value107 b565) e554 w556 s557 mod559) (if (memv type567 (quote (global))) (values (quote global-call) n564 e554 w556 s557 mod559) (if (memv type567 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b565) e554 r555 w556 rib558 mod559) r555 (quote (())) s557 rib558 mod559) (if (memv type567 (quote (core external-macro module-ref))) (values type567 (binding-value107 b565) e554 w556 s557 mod559) (if (memv type567 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value107 b565) e554 w556 s557 mod559) (if (memv type567 (quote (begin))) (values (quote begin-form) #f e554 w556 s557 mod559) (if (memv type567 (quote (eval-when))) (values (quote eval-when-form) #f e554 w556 s557 mod559) (if (memv type567 (quote (define))) ((lambda (tmp568) ((lambda (tmp569) (if (if tmp569 (apply (lambda (_570 name571 val572) (id?114 name571)) tmp569) #f) (apply (lambda (_573 name574 val575) (values (quote define-form) name574 val575 w556 s557 mod559)) tmp569) ((lambda (tmp576) (if (if tmp576 (apply (lambda (_577 name578 args579 e1580 e2581) (if (id?114 name578) (valid-bound-ids?139 (lambda-var-list163 args579)) #f)) tmp576) #f) (apply (lambda (_582 name583 args584 e1585 e2586) (values (quote define-form) (wrap142 name583 w556 mod559) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args584 (cons e1585 e2586)) w556 mod559)) (quote (())) s557 mod559)) tmp576) ((lambda (tmp588) (if (if tmp588 (apply (lambda (_589 name590) (id?114 name590)) tmp588) #f) (apply (lambda (_591 name592) (values (quote define-form) (wrap142 name592 w556 mod559) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s557 mod559)) tmp588) (syntax-violation #f "source expression failed to match any pattern" tmp568))) ($sc-dispatch tmp568 (quote (any any)))))) ($sc-dispatch tmp568 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp568 (quote (any any any))))) e554) (if (memv type567 (quote (define-syntax))) ((lambda (tmp593) ((lambda (tmp594) (if (if tmp594 (apply (lambda (_595 name596 val597) (id?114 name596)) tmp594) #f) (apply (lambda (_598 name599 val600) (values (quote define-syntax-form) name599 val600 w556 s557 mod559)) tmp594) (syntax-violation #f "source expression failed to match any pattern" tmp593))) ($sc-dispatch tmp593 (quote (any any any))))) e554) (values (quote call) #f e554 w556 s557 mod559))))))))))))) (values (quote call) #f e554 w556 s557 mod559))) (if (syntax-object?98 e554) (syntax-type148 (syntax-object-expression99 e554) r555 (join-wraps133 w556 (syntax-object-wrap100 e554)) #f rib558 (let ((t601 (syntax-object-module101 e554))) (if t601 t601 mod559))) (if (annotation? e554) (syntax-type148 (annotation-expression e554) r555 w556 (annotation-source e554) rib558 mod559) (if (self-evaluating? e554) (values (quote constant) #f e554 w556 s557 mod559) (values (quote other) #f e554 w556 s557 mod559)))))))) (chi-when-list147 (lambda (e602 when-list603 w604) (letrec ((f605 (lambda (when-list606 situations607) (if (null? when-list606) situations607 (f605 (cdr when-list606) (cons (let ((x608 (car when-list606))) (if (free-id=?137 x608 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x608 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x608 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e602 (wrap142 x608 w604 #f)))))) situations607)))))) (f605 when-list603 (quote ()))))) (chi-install-global146 (lambda (name609 e610) (build-global-definition89 #f name609 (if (let ((v611 (module-variable (current-module) name609))) (if v611 (if (variable-bound? v611) (if (macro? (variable-ref v611)) (not (eq? (macro-type (variable-ref v611)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name609))) (build-data92 #f (quote macro)) e610)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e610)))))) (chi-top-sequence145 (lambda (body612 r613 w614 s615 m616 esew617 mod618) (build-sequence93 s615 (letrec ((dobody619 (lambda (body620 r621 w622 m623 esew624 mod625) (if (null? body620) (quote ()) (let ((first626 (chi-top149 (car body620) r621 w622 m623 esew624 mod625))) (cons first626 (dobody619 (cdr body620) r621 w622 m623 esew624 mod625))))))) (dobody619 body612 r613 w614 m616 esew617 mod618))))) (chi-sequence144 (lambda (body627 r628 w629 s630 mod631) (build-sequence93 s630 (letrec ((dobody632 (lambda (body633 r634 w635 mod636) (if (null? body633) (quote ()) (let ((first637 (chi150 (car body633) r634 w635 mod636))) (cons first637 (dobody632 (cdr body633) r634 w635 mod636))))))) (dobody632 body627 r628 w629 mod631))))) (source-wrap143 (lambda (x638 w639 s640 defmod641) (wrap142 (if s640 (make-annotation x638 s640 #f) x638) w639 defmod641))) (wrap142 (lambda (x642 w643 defmod644) (if (if (null? (wrap-marks117 w643)) (null? (wrap-subst118 w643)) #f) x642 (if (syntax-object?98 x642) (make-syntax-object97 (syntax-object-expression99 x642) (join-wraps133 w643 (syntax-object-wrap100 x642)) (syntax-object-module101 x642)) (if (null? x642) x642 (make-syntax-object97 x642 w643 defmod644)))))) (bound-id-member?141 (lambda (x645 list646) (if (not (null? list646)) (let ((t647 (bound-id=?138 x645 (car list646)))) (if t647 t647 (bound-id-member?141 x645 (cdr list646)))) #f))) (distinct-bound-ids?140 (lambda (ids648) (letrec ((distinct?649 (lambda (ids650) (let ((t651 (null? ids650))) (if t651 t651 (if (not (bound-id-member?141 (car ids650) (cdr ids650))) (distinct?649 (cdr ids650)) #f)))))) (distinct?649 ids648)))) (valid-bound-ids?139 (lambda (ids652) (if (letrec ((all-ids?653 (lambda (ids654) (let ((t655 (null? ids654))) (if t655 t655 (if (id?114 (car ids654)) (all-ids?653 (cdr ids654)) #f)))))) (all-ids?653 ids652)) (distinct-bound-ids?140 ids652) #f))) (bound-id=?138 (lambda (i656 j657) (if (if (syntax-object?98 i656) (syntax-object?98 j657) #f) (if (eq? (let ((e658 (syntax-object-expression99 i656))) (if (annotation? e658) (annotation-expression e658) e658)) (let ((e659 (syntax-object-expression99 j657))) (if (annotation? e659) (annotation-expression e659) e659))) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i656)) (wrap-marks117 (syntax-object-wrap100 j657))) #f) (eq? (let ((e660 i656)) (if (annotation? e660) (annotation-expression e660) e660)) (let ((e661 j657)) (if (annotation? e661) (annotation-expression e661) e661)))))) (free-id=?137 (lambda (i662 j663) (if (eq? (let ((x664 i662)) (let ((e665 (if (syntax-object?98 x664) (syntax-object-expression99 x664) x664))) (if (annotation? e665) (annotation-expression e665) e665))) (let ((x666 j663)) (let ((e667 (if (syntax-object?98 x666) (syntax-object-expression99 x666) x666))) (if (annotation? e667) (annotation-expression e667) e667)))) (eq? (id-var-name136 i662 (quote (()))) (id-var-name136 j663 (quote (())))) #f))) (id-var-name136 (lambda (id668 w669) (letrec ((search-vector-rib672 (lambda (sym678 subst679 marks680 symnames681 ribcage682) (let ((n683 (vector-length symnames681))) (letrec ((f684 (lambda (i685) (if (fx=74 i685 n683) (search670 sym678 (cdr subst679) marks680) (if (if (eq? (vector-ref symnames681 i685) sym678) (same-marks?135 marks680 (vector-ref (ribcage-marks124 ribcage682) i685)) #f) (values (vector-ref (ribcage-labels125 ribcage682) i685) marks680) (f684 (fx+72 i685 1))))))) (f684 0))))) (search-list-rib671 (lambda (sym686 subst687 marks688 symnames689 ribcage690) (letrec ((f691 (lambda (symnames692 i693) (if (null? symnames692) (search670 sym686 (cdr subst687) marks688) (if (if (eq? (car symnames692) sym686) (same-marks?135 marks688 (list-ref (ribcage-marks124 ribcage690) i693)) #f) (values (list-ref (ribcage-labels125 ribcage690) i693) marks688) (f691 (cdr symnames692) (fx+72 i693 1))))))) (f691 symnames689 0)))) (search670 (lambda (sym694 subst695 marks696) (if (null? subst695) (values #f marks696) (let ((fst697 (car subst695))) (if (eq? fst697 (quote shift)) (search670 sym694 (cdr subst695) (cdr marks696)) (let ((symnames698 (ribcage-symnames123 fst697))) (if (vector? symnames698) (search-vector-rib672 sym694 subst695 marks696 symnames698 fst697) (search-list-rib671 sym694 subst695 marks696 symnames698 fst697))))))))) (if (symbol? id668) (let ((t699 (call-with-values (lambda () (search670 id668 (wrap-subst118 w669) (wrap-marks117 w669))) (lambda (x701 . ignore700) x701)))) (if t699 t699 id668)) (if (syntax-object?98 id668) (let ((id702 (let ((e704 (syntax-object-expression99 id668))) (if (annotation? e704) (annotation-expression e704) e704))) (w1703 (syntax-object-wrap100 id668))) (let ((marks705 (join-marks134 (wrap-marks117 w669) (wrap-marks117 w1703)))) (call-with-values (lambda () (search670 id702 (wrap-subst118 w669) marks705)) (lambda (new-id706 marks707) (let ((t708 new-id706)) (if t708 t708 (let ((t709 (call-with-values (lambda () (search670 id702 (wrap-subst118 w1703) marks707)) (lambda (x711 . ignore710) x711)))) (if t709 t709 id702)))))))) (if (annotation? id668) (let ((id712 (let ((e713 id668)) (if (annotation? e713) (annotation-expression e713) e713)))) (let ((t714 (call-with-values (lambda () (search670 id712 (wrap-subst118 w669) (wrap-marks117 w669))) (lambda (x716 . ignore715) x716)))) (if t714 t714 id712))) (syntax-violation (quote id-var-name) "invalid id" id668))))))) (same-marks?135 (lambda (x717 y718) (let ((t719 (eq? x717 y718))) (if t719 t719 (if (not (null? x717)) (if (not (null? y718)) (if (eq? (car x717) (car y718)) (same-marks?135 (cdr x717) (cdr y718)) #f) #f) #f))))) (join-marks134 (lambda (m1720 m2721) (smart-append132 m1720 m2721))) (join-wraps133 (lambda (w1722 w2723) (let ((m1724 (wrap-marks117 w1722)) (s1725 (wrap-subst118 w1722))) (if (null? m1724) (if (null? s1725) w2723 (make-wrap116 (wrap-marks117 w2723) (smart-append132 s1725 (wrap-subst118 w2723)))) (make-wrap116 (smart-append132 m1724 (wrap-marks117 w2723)) (smart-append132 s1725 (wrap-subst118 w2723))))))) (smart-append132 (lambda (m1726 m2727) (if (null? m2727) m1726 (append m1726 m2727)))) (make-binding-wrap131 (lambda (ids728 labels729 w730) (if (null? ids728) w730 (make-wrap116 (wrap-marks117 w730) (cons (let ((labelvec731 (list->vector labels729))) (let ((n732 (vector-length labelvec731))) (let ((symnamevec733 (make-vector n732)) (marksvec734 (make-vector n732))) (begin (letrec ((f735 (lambda (ids736 i737) (if (not (null? ids736)) (call-with-values (lambda () (id-sym-name&marks115 (car ids736) w730)) (lambda (symname738 marks739) (begin (vector-set! symnamevec733 i737 symname738) (vector-set! marksvec734 i737 marks739) (f735 (cdr ids736) (fx+72 i737 1))))))))) (f735 ids728 0)) (make-ribcage121 symnamevec733 marksvec734 labelvec731))))) (wrap-subst118 w730)))))) (extend-ribcage!130 (lambda (ribcage740 id741 label742) (begin (set-ribcage-symnames!126 ribcage740 (cons (let ((e743 (syntax-object-expression99 id741))) (if (annotation? e743) (annotation-expression e743) e743)) (ribcage-symnames123 ribcage740))) (set-ribcage-marks!127 ribcage740 (cons (wrap-marks117 (syntax-object-wrap100 id741)) (ribcage-marks124 ribcage740))) (set-ribcage-labels!128 ribcage740 (cons label742 (ribcage-labels125 ribcage740)))))) (anti-mark129 (lambda (w744) (make-wrap116 (cons #f (wrap-marks117 w744)) (cons (quote shift) (wrap-subst118 w744))))) (set-ribcage-labels!128 (lambda (x745 update746) (vector-set! x745 3 update746))) (set-ribcage-marks!127 (lambda (x747 update748) (vector-set! x747 2 update748))) (set-ribcage-symnames!126 (lambda (x749 update750) (vector-set! x749 1 update750))) (ribcage-labels125 (lambda (x751) (vector-ref x751 3))) (ribcage-marks124 (lambda (x752) (vector-ref x752 2))) (ribcage-symnames123 (lambda (x753) (vector-ref x753 1))) (ribcage?122 (lambda (x754) (if (vector? x754) (if (= (vector-length x754) 4) (eq? (vector-ref x754 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames755 marks756 labels757) (vector (quote ribcage) symnames755 marks756 labels757))) (gen-labels120 (lambda (ls758) (if (null? ls758) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls758)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x759 w760) (if (syntax-object?98 x759) (values (let ((e761 (syntax-object-expression99 x759))) (if (annotation? e761) (annotation-expression e761) e761)) (join-marks134 (wrap-marks117 w760) (wrap-marks117 (syntax-object-wrap100 x759)))) (values (let ((e762 x759)) (if (annotation? e762) (annotation-expression e762) e762)) (wrap-marks117 w760))))) (id?114 (lambda (x763) (if (symbol? x763) #t (if (syntax-object?98 x763) (symbol? (let ((e764 (syntax-object-expression99 x763))) (if (annotation? e764) (annotation-expression e764) e764))) (if (annotation? x763) (symbol? (annotation-expression x763)) #f))))) (nonsymbol-id?113 (lambda (x765) (if (syntax-object?98 x765) (symbol? (let ((e766 (syntax-object-expression99 x765))) (if (annotation? e766) (annotation-expression e766) e766))) #f))) (global-extend112 (lambda (type767 sym768 val769) (put-global-definition-hook78 sym768 type767 val769))) (lookup111 (lambda (x770 r771 mod772) (let ((t773 (assq x770 r771))) (if t773 (cdr t773) (if (symbol? x770) (let ((t774 (get-global-definition-hook79 x770 mod772))) (if t774 t774 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r775) (if (null? r775) (quote ()) (let ((a776 (car r775))) (if (eq? (cadr a776) (quote macro)) (cons a776 (macros-only-env110 (cdr r775))) (macros-only-env110 (cdr r775))))))) (extend-var-env109 (lambda (labels777 vars778 r779) (if (null? labels777) r779 (extend-var-env109 (cdr labels777) (cdr vars778) (cons (cons (car labels777) (cons (quote lexical) (car vars778))) r779))))) (extend-env108 (lambda (labels780 bindings781 r782) (if (null? labels780) r782 (extend-env108 (cdr labels780) (cdr bindings781) (cons (cons (car labels780) (car bindings781)) r782))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x783) (if (annotation? x783) (annotation-source x783) (if (syntax-object?98 x783) (source-annotation105 (syntax-object-expression99 x783)) #f)))) (set-syntax-object-module!104 (lambda (x784 update785) (vector-set! x784 3 update785))) (set-syntax-object-wrap!103 (lambda (x786 update787) (vector-set! x786 2 update787))) (set-syntax-object-expression!102 (lambda (x788 update789) (vector-set! x788 1 update789))) (syntax-object-module101 (lambda (x790) (vector-ref x790 3))) (syntax-object-wrap100 (lambda (x791) (vector-ref x791 2))) (syntax-object-expression99 (lambda (x792) (vector-ref x792 1))) (syntax-object?98 (lambda (x793) (if (vector? x793) (if (= (vector-length x793) 4) (eq? (vector-ref x793 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression794 wrap795 module796) (vector (quote syntax-object) expression794 wrap795 module796))) (build-letrec96 (lambda (src797 ids798 vars799 val-exps800 body-exp801) (if (null? vars799) body-exp801 (let ((atom-key802 (fluid-ref *mode*71))) (if (memv atom-key802 (quote (c))) (begin (for-each maybe-name-value!88 ids798 val-exps800) ((@ (language tree-il) make-letrec) src797 ids798 vars799 val-exps800 body-exp801)) (list (quote letrec) (map list vars799 val-exps800) body-exp801)))))) (build-named-let95 (lambda (src803 ids804 vars805 val-exps806 body-exp807) (let ((f808 (car vars805)) (f-name809 (car ids804)) (vars810 (cdr vars805)) (ids811 (cdr ids804))) (let ((atom-key812 (fluid-ref *mode*71))) (if (memv atom-key812 (quote (c))) (let ((proc813 (build-lambda90 src803 ids811 vars810 #f body-exp807))) (begin (maybe-name-value!88 f-name809 proc813) (for-each maybe-name-value!88 ids811 val-exps806) ((@ (language tree-il) make-letrec) src803 (list f-name809) (list f808) (list proc813) (build-application81 src803 (build-lexical-reference83 (quote fun) src803 f-name809 f808) val-exps806)))) (list (quote let) f808 (map list vars810 val-exps806) body-exp807)))))) (build-let94 (lambda (src814 ids815 vars816 val-exps817 body-exp818) (if (null? vars816) body-exp818 (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) (begin (for-each maybe-name-value!88 ids815 val-exps817) ((@ (language tree-il) make-let) src814 ids815 vars816 val-exps817 body-exp818)) (list (quote let) (map list vars816 val-exps817) body-exp818)))))) (build-sequence93 (lambda (src820 exps821) (if (null? (cdr exps821)) (car exps821) (let ((atom-key822 (fluid-ref *mode*71))) (if (memv atom-key822 (quote (c))) ((@ (language tree-il) make-sequence) src820 exps821) (cons (quote begin) exps821)))))) (build-data92 (lambda (src823 exp824) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-const) src823 exp824) (if (if (self-evaluating? exp824) (not (vector? exp824)) #f) exp824 (list (quote quote) exp824)))))) (build-primref91 (lambda (src826 name827) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key828 (fluid-ref *mode*71))) (if (memv atom-key828 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src826 name827) name827)) (let ((atom-key829 (fluid-ref *mode*71))) (if (memv atom-key829 (quote (c))) ((@ (language tree-il) make-module-ref) src826 (quote (guile)) name827 #f) (list (quote @@) (quote (guile)) name827)))))) (build-lambda90 (lambda (src830 ids831 vars832 docstring833 exp834) (let ((atom-key835 (fluid-ref *mode*71))) (if (memv atom-key835 (quote (c))) ((@ (language tree-il) make-lambda) src830 ids831 vars832 (if docstring833 (list (cons (quote documentation) docstring833)) (quote ())) exp834) (cons (quote lambda) (cons vars832 (append (if docstring833 (list docstring833) (quote ())) (list exp834)))))))) (build-global-definition89 (lambda (source836 var837 exp838) (let ((atom-key839 (fluid-ref *mode*71))) (if (memv atom-key839 (quote (c))) (begin (maybe-name-value!88 var837 exp838) ((@ (language tree-il) make-toplevel-define) source836 var837 exp838)) (list (quote define) var837 exp838))))) (maybe-name-value!88 (lambda (name840 val841) (if ((@ (language tree-il) lambda?) val841) (let ((meta842 ((@ (language tree-il) lambda-meta) val841))) (if (not (assq (quote name) meta842)) ((setter (@ (language tree-il) lambda-meta)) val841 (acons (quote name) name840 meta842))))))) (build-global-assignment87 (lambda (source843 var844 exp845 mod846) (analyze-variable85 mod846 var844 (lambda (mod847 var848 public?849) (let ((atom-key850 (fluid-ref *mode*71))) (if (memv atom-key850 (quote (c))) ((@ (language tree-il) make-module-set) source843 mod847 var848 public?849 exp845) (list (quote set!) (list (if public?849 (quote @) (quote @@)) mod847 var848) exp845)))) (lambda (var851) (let ((atom-key852 (fluid-ref *mode*71))) (if (memv atom-key852 (quote (c))) ((@ (language tree-il) make-toplevel-set) source843 var851 exp845) (list (quote set!) var851 exp845))))))) (build-global-reference86 (lambda (source853 var854 mod855) (analyze-variable85 mod855 var854 (lambda (mod856 var857 public?858) (let ((atom-key859 (fluid-ref *mode*71))) (if (memv atom-key859 (quote (c))) ((@ (language tree-il) make-module-ref) source853 mod856 var857 public?858) (list (if public?858 (quote @) (quote @@)) mod856 var857)))) (lambda (var860) (let ((atom-key861 (fluid-ref *mode*71))) (if (memv atom-key861 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source853 var860) var860)))))) (analyze-variable85 (lambda (mod862 var863 modref-cont864 bare-cont865) (if (not mod862) (bare-cont865 var863) (let ((kind866 (car mod862)) (mod867 (cdr mod862))) (if (memv kind866 (quote (public))) (modref-cont864 mod867 var863 #t) (if (memv kind866 (quote (private))) (if (not (equal? mod867 (module-name (current-module)))) (modref-cont864 mod867 var863 #f) (bare-cont865 var863)) (if (memv kind866 (quote (bare))) (bare-cont865 var863) (if (memv kind866 (quote (hygiene))) (if (if (not (equal? mod867 (module-name (current-module)))) (module-variable (resolve-module mod867) var863) #f) (modref-cont864 mod867 var863 #f) (bare-cont865 var863)) (syntax-violation #f "bad module kind" var863 mod867))))))))) (build-lexical-assignment84 (lambda (source868 name869 var870 exp871) (let ((atom-key872 (fluid-ref *mode*71))) (if (memv atom-key872 (quote (c))) ((@ (language tree-il) make-lexical-set) source868 name869 var870 exp871) (list (quote set!) var870 exp871))))) (build-lexical-reference83 (lambda (type873 source874 name875 var876) (let ((atom-key877 (fluid-ref *mode*71))) (if (memv atom-key877 (quote (c))) ((@ (language tree-il) make-lexical-ref) source874 name875 var876) var876)))) (build-conditional82 (lambda (source878 test-exp879 then-exp880 else-exp881) (let ((atom-key882 (fluid-ref *mode*71))) (if (memv atom-key882 (quote (c))) ((@ (language tree-il) make-conditional) source878 test-exp879 then-exp880 else-exp881) (if (equal? else-exp881 (quote (if #f #f))) (list (quote if) test-exp879 then-exp880) (list (quote if) test-exp879 then-exp880 else-exp881)))))) (build-application81 (lambda (source883 fun-exp884 arg-exps885) (let ((atom-key886 (fluid-ref *mode*71))) (if (memv atom-key886 (quote (c))) ((@ (language tree-il) make-application) source883 fun-exp884 arg-exps885) (cons fun-exp884 arg-exps885))))) (build-void80 (lambda (source887) (let ((atom-key888 (fluid-ref *mode*71))) (if (memv atom-key888 (quote (c))) ((@ (language tree-il) make-void) source887) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol889 module890) (begin (if (if (not module890) (current-module) #f) (warn "module system is booted, we should have a module" symbol889)) (let ((v891 (module-variable (if module890 (resolve-module (cdr module890)) (current-module)) symbol889))) (if v891 (if (variable-bound? v891) (let ((val892 (variable-ref v891))) (if (macro? val892) (if (syncase-macro-type val892) (cons (syncase-macro-type val892) (syncase-macro-binding val892)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol893 type894 val895) (let ((existing896 (let ((v897 (module-variable (current-module) symbol893))) (if v897 (if (variable-bound? v897) (let ((val898 (variable-ref v897))) (if (macro? val898) (if (not (syncase-macro-type val898)) val898 #f) #f)) #f) #f)))) (module-define! (current-module) symbol893 (if existing896 (make-extended-syncase-macro existing896 type894 val895) (make-syncase-macro type894 val895)))))) (local-eval-hook77 (lambda (x899 mod900) (primitive-eval (list noexpand70 (let ((atom-key901 (fluid-ref *mode*71))) (if (memv atom-key901 (quote (c))) ((@ (language tree-il) tree-il->scheme) x899) x899)))))) (top-level-eval-hook76 (lambda (x902 mod903) (primitive-eval (list noexpand70 (let ((atom-key904 (fluid-ref *mode*71))) (if (memv atom-key904 (quote (c))) ((@ (language tree-il) tree-il->scheme) x902) x902)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e905 r906 w907 s908 mod909) ((lambda (tmp910) ((lambda (tmp911) (if (if tmp911 (apply (lambda (_912 var913 val914 e1915 e2916) (valid-bound-ids?139 var913)) tmp911) #f) (apply (lambda (_918 var919 val920 e1921 e2922) (let ((names923 (map (lambda (x924) (id-var-name136 x924 w907)) var919))) (begin (for-each (lambda (id926 n927) (let ((atom-key928 (binding-type106 (lookup111 n927 r906 mod909)))) (if (memv atom-key928 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e905 (source-wrap143 id926 w907 s908 mod909))))) var919 names923) (chi-body154 (cons e1921 e2922) (source-wrap143 e905 w907 s908 mod909) (extend-env108 names923 (let ((trans-r931 (macros-only-env110 r906))) (map (lambda (x932) (cons (quote macro) (eval-local-transformer157 (chi150 x932 trans-r931 w907 mod909) mod909))) val920)) r906) w907 mod909)))) tmp911) ((lambda (_934) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e905 w907 s908 mod909))) tmp910))) ($sc-dispatch tmp910 (quote (any #(each (any any)) any . each-any))))) e905))) (global-extend112 (quote core) (quote quote) (lambda (e935 r936 w937 s938 mod939) ((lambda (tmp940) ((lambda (tmp941) (if tmp941 (apply (lambda (_942 e943) (build-data92 s938 (strip161 e943 w937))) tmp941) ((lambda (_944) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e935 w937 s938 mod939))) tmp940))) ($sc-dispatch tmp940 (quote (any any))))) e935))) (global-extend112 (quote core) (quote syntax) (letrec ((regen952 (lambda (x953) (let ((atom-key954 (car x953))) (if (memv atom-key954 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x953) (cadr x953)) (if (memv atom-key954 (quote (primitive))) (build-primref91 #f (cadr x953)) (if (memv atom-key954 (quote (quote))) (build-data92 #f (cadr x953)) (if (memv atom-key954 (quote (lambda))) (build-lambda90 #f (cadr x953) (cadr x953) #f (regen952 (caddr x953))) (if (memv atom-key954 (quote (map))) (let ((ls955 (map regen952 (cdr x953)))) (build-application81 #f (build-primref91 #f (quote map)) ls955)) (build-application81 #f (build-primref91 #f (car x953)) (map regen952 (cdr x953))))))))))) (gen-vector951 (lambda (x956) (if (eq? (car x956) (quote list)) (cons (quote vector) (cdr x956)) (if (eq? (car x956) (quote quote)) (list (quote quote) (list->vector (cadr x956))) (list (quote list->vector) x956))))) (gen-append950 (lambda (x957 y958) (if (equal? y958 (quote (quote ()))) x957 (list (quote append) x957 y958)))) (gen-cons949 (lambda (x959 y960) (let ((atom-key961 (car y960))) (if (memv atom-key961 (quote (quote))) (if (eq? (car x959) (quote quote)) (list (quote quote) (cons (cadr x959) (cadr y960))) (if (eq? (cadr y960) (quote ())) (list (quote list) x959) (list (quote cons) x959 y960))) (if (memv atom-key961 (quote (list))) (cons (quote list) (cons x959 (cdr y960))) (list (quote cons) x959 y960)))))) (gen-map948 (lambda (e962 map-env963) (let ((formals964 (map cdr map-env963)) (actuals965 (map (lambda (x966) (list (quote ref) (car x966))) map-env963))) (if (eq? (car e962) (quote ref)) (car actuals965) (if (and-map (lambda (x967) (if (eq? (car x967) (quote ref)) (memq (cadr x967) formals964) #f)) (cdr e962)) (cons (quote map) (cons (list (quote primitive) (car e962)) (map (let ((r968 (map cons formals964 actuals965))) (lambda (x969) (cdr (assq (cadr x969) r968)))) (cdr e962)))) (cons (quote map) (cons (list (quote lambda) formals964 e962) actuals965))))))) (gen-mappend947 (lambda (e970 map-env971) (list (quote apply) (quote (primitive append)) (gen-map948 e970 map-env971)))) (gen-ref946 (lambda (src972 var973 level974 maps975) (if (fx=74 level974 0) (values var973 maps975) (if (null? maps975) (syntax-violation (quote syntax) "missing ellipsis" src972) (call-with-values (lambda () (gen-ref946 src972 var973 (fx-73 level974 1) (cdr maps975))) (lambda (outer-var976 outer-maps977) (let ((b978 (assq outer-var976 (car maps975)))) (if b978 (values (cdr b978) maps975) (let ((inner-var979 (gen-var162 (quote tmp)))) (values inner-var979 (cons (cons (cons outer-var976 inner-var979) (car maps975)) outer-maps977))))))))))) (gen-syntax945 (lambda (src980 e981 r982 maps983 ellipsis?984 mod985) (if (id?114 e981) (let ((label986 (id-var-name136 e981 (quote (()))))) (let ((b987 (lookup111 label986 r982 mod985))) (if (eq? (binding-type106 b987) (quote syntax)) (call-with-values (lambda () (let ((var.lev988 (binding-value107 b987))) (gen-ref946 src980 (car var.lev988) (cdr var.lev988) maps983))) (lambda (var989 maps990) (values (list (quote ref) var989) maps990))) (if (ellipsis?984 e981) (syntax-violation (quote syntax) "misplaced ellipsis" src980) (values (list (quote quote) e981) maps983))))) ((lambda (tmp991) ((lambda (tmp992) (if (if tmp992 (apply (lambda (dots993 e994) (ellipsis?984 dots993)) tmp992) #f) (apply (lambda (dots995 e996) (gen-syntax945 src980 e996 r982 maps983 (lambda (x997) #f) mod985)) tmp992) ((lambda (tmp998) (if (if tmp998 (apply (lambda (x999 dots1000 y1001) (ellipsis?984 dots1000)) tmp998) #f) (apply (lambda (x1002 dots1003 y1004) (letrec ((f1005 (lambda (y1006 k1007) ((lambda (tmp1011) ((lambda (tmp1012) (if (if tmp1012 (apply (lambda (dots1013 y1014) (ellipsis?984 dots1013)) tmp1012) #f) (apply (lambda (dots1015 y1016) (f1005 y1016 (lambda (maps1017) (call-with-values (lambda () (k1007 (cons (quote ()) maps1017))) (lambda (x1018 maps1019) (if (null? (car maps1019)) (syntax-violation (quote syntax) "extra ellipsis" src980) (values (gen-mappend947 x1018 (car maps1019)) (cdr maps1019)))))))) tmp1012) ((lambda (_1020) (call-with-values (lambda () (gen-syntax945 src980 y1006 r982 maps983 ellipsis?984 mod985)) (lambda (y1021 maps1022) (call-with-values (lambda () (k1007 maps1022)) (lambda (x1023 maps1024) (values (gen-append950 x1023 y1021) maps1024)))))) tmp1011))) ($sc-dispatch tmp1011 (quote (any . any))))) y1006)))) (f1005 y1004 (lambda (maps1008) (call-with-values (lambda () (gen-syntax945 src980 x1002 r982 (cons (quote ()) maps1008) ellipsis?984 mod985)) (lambda (x1009 maps1010) (if (null? (car maps1010)) (syntax-violation (quote syntax) "extra ellipsis" src980) (values (gen-map948 x1009 (car maps1010)) (cdr maps1010))))))))) tmp998) ((lambda (tmp1025) (if tmp1025 (apply (lambda (x1026 y1027) (call-with-values (lambda () (gen-syntax945 src980 x1026 r982 maps983 ellipsis?984 mod985)) (lambda (x1028 maps1029) (call-with-values (lambda () (gen-syntax945 src980 y1027 r982 maps1029 ellipsis?984 mod985)) (lambda (y1030 maps1031) (values (gen-cons949 x1028 y1030) maps1031)))))) tmp1025) ((lambda (tmp1032) (if tmp1032 (apply (lambda (e11033 e21034) (call-with-values (lambda () (gen-syntax945 src980 (cons e11033 e21034) r982 maps983 ellipsis?984 mod985)) (lambda (e1036 maps1037) (values (gen-vector951 e1036) maps1037)))) tmp1032) ((lambda (_1038) (values (list (quote quote) e981) maps983)) tmp991))) ($sc-dispatch tmp991 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp991 (quote (any . any)))))) ($sc-dispatch tmp991 (quote (any any . any)))))) ($sc-dispatch tmp991 (quote (any any))))) e981))))) (lambda (e1039 r1040 w1041 s1042 mod1043) (let ((e1044 (source-wrap143 e1039 w1041 s1042 mod1043))) ((lambda (tmp1045) ((lambda (tmp1046) (if tmp1046 (apply (lambda (_1047 x1048) (call-with-values (lambda () (gen-syntax945 e1044 x1048 r1040 (quote ()) ellipsis?159 mod1043)) (lambda (e1049 maps1050) (regen952 e1049)))) tmp1046) ((lambda (_1051) (syntax-violation (quote syntax) "bad `syntax' form" e1044)) tmp1045))) ($sc-dispatch tmp1045 (quote (any any))))) e1044))))) (global-extend112 (quote core) (quote lambda) (lambda (e1052 r1053 w1054 s1055 mod1056) ((lambda (tmp1057) ((lambda (tmp1058) (if tmp1058 (apply (lambda (_1059 c1060) (chi-lambda-clause155 (source-wrap143 e1052 w1054 s1055 mod1056) #f c1060 r1053 w1054 mod1056 (lambda (names1061 vars1062 docstring1063 body1064) (build-lambda90 s1055 names1061 vars1062 docstring1063 body1064)))) tmp1058) (syntax-violation #f "source expression failed to match any pattern" tmp1057))) ($sc-dispatch tmp1057 (quote (any . any))))) e1052))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1065 (lambda (e1066 r1067 w1068 s1069 mod1070 constructor1071 ids1072 vals1073 exps1074) (if (not (valid-bound-ids?139 ids1072)) (syntax-violation (quote let) "duplicate bound variable" e1066) (let ((labels1075 (gen-labels120 ids1072)) (new-vars1076 (map gen-var162 ids1072))) (let ((nw1077 (make-binding-wrap131 ids1072 labels1075 w1068)) (nr1078 (extend-var-env109 labels1075 new-vars1076 r1067))) (constructor1071 s1069 (map syntax->datum ids1072) new-vars1076 (map (lambda (x1079) (chi150 x1079 r1067 w1068 mod1070)) vals1073) (chi-body154 exps1074 (source-wrap143 e1066 nw1077 s1069 mod1070) nr1078 nw1077 mod1070)))))))) (lambda (e1080 r1081 w1082 s1083 mod1084) ((lambda (tmp1085) ((lambda (tmp1086) (if (if tmp1086 (apply (lambda (_1087 id1088 val1089 e11090 e21091) (and-map id?114 id1088)) tmp1086) #f) (apply (lambda (_1093 id1094 val1095 e11096 e21097) (chi-let1065 e1080 r1081 w1082 s1083 mod1084 build-let94 id1094 val1095 (cons e11096 e21097))) tmp1086) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (_1102 f1103 id1104 val1105 e11106 e21107) (if (id?114 f1103) (and-map id?114 id1104) #f)) tmp1101) #f) (apply (lambda (_1109 f1110 id1111 val1112 e11113 e21114) (chi-let1065 e1080 r1081 w1082 s1083 mod1084 build-named-let95 (cons f1110 id1111) val1112 (cons e11113 e21114))) tmp1101) ((lambda (_1118) (syntax-violation (quote let) "bad let" (source-wrap143 e1080 w1082 s1083 mod1084))) tmp1085))) ($sc-dispatch tmp1085 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1085 (quote (any #(each (any any)) any . each-any))))) e1080)))) (global-extend112 (quote core) (quote letrec) (lambda (e1119 r1120 w1121 s1122 mod1123) ((lambda (tmp1124) ((lambda (tmp1125) (if (if tmp1125 (apply (lambda (_1126 id1127 val1128 e11129 e21130) (and-map id?114 id1127)) tmp1125) #f) (apply (lambda (_1132 id1133 val1134 e11135 e21136) (let ((ids1137 id1133)) (if (not (valid-bound-ids?139 ids1137)) (syntax-violation (quote letrec) "duplicate bound variable" e1119) (let ((labels1139 (gen-labels120 ids1137)) (new-vars1140 (map gen-var162 ids1137))) (let ((w1141 (make-binding-wrap131 ids1137 labels1139 w1121)) (r1142 (extend-var-env109 labels1139 new-vars1140 r1120))) (build-letrec96 s1122 (map syntax->datum ids1137) new-vars1140 (map (lambda (x1143) (chi150 x1143 r1142 w1141 mod1123)) val1134) (chi-body154 (cons e11135 e21136) (source-wrap143 e1119 w1141 s1122 mod1123) r1142 w1141 mod1123))))))) tmp1125) ((lambda (_1146) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1119 w1121 s1122 mod1123))) tmp1124))) ($sc-dispatch tmp1124 (quote (any #(each (any any)) any . each-any))))) e1119))) (global-extend112 (quote core) (quote set!) (lambda (e1147 r1148 w1149 s1150 mod1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 id1155 val1156) (id?114 id1155)) tmp1153) #f) (apply (lambda (_1157 id1158 val1159) (let ((val1160 (chi150 val1159 r1148 w1149 mod1151)) (n1161 (id-var-name136 id1158 w1149))) (let ((b1162 (lookup111 n1161 r1148 mod1151))) (let ((atom-key1163 (binding-type106 b1162))) (if (memv atom-key1163 (quote (lexical))) (build-lexical-assignment84 s1150 (syntax->datum id1158) (binding-value107 b1162) val1160) (if (memv atom-key1163 (quote (global))) (build-global-assignment87 s1150 n1161 val1160 mod1151) (if (memv atom-key1163 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1158 w1149 mod1151)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1147 w1149 s1150 mod1151))))))))) tmp1153) ((lambda (tmp1164) (if tmp1164 (apply (lambda (_1165 head1166 tail1167 val1168) (call-with-values (lambda () (syntax-type148 head1166 r1148 (quote (())) #f #f mod1151)) (lambda (type1169 value1170 ee1171 ww1172 ss1173 modmod1174) (if (memv type1169 (quote (module-ref))) (let ((val1175 (chi150 val1168 r1148 w1149 mod1151))) (call-with-values (lambda () (value1170 (cons head1166 tail1167))) (lambda (id1177 mod1178) (build-global-assignment87 s1150 id1177 val1175 mod1178)))) (build-application81 s1150 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1166) r1148 w1149 mod1151) (map (lambda (e1179) (chi150 e1179 r1148 w1149 mod1151)) (append tail1167 (list val1168)))))))) tmp1164) ((lambda (_1181) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1147 w1149 s1150 mod1151))) tmp1152))) ($sc-dispatch tmp1152 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1152 (quote (any any any))))) e1147))) (global-extend112 (quote module-ref) (quote @) (lambda (e1182) ((lambda (tmp1183) ((lambda (tmp1184) (if (if tmp1184 (apply (lambda (_1185 mod1186 id1187) (if (and-map id?114 mod1186) (id?114 id1187) #f)) tmp1184) #f) (apply (lambda (_1189 mod1190 id1191) (values (syntax->datum id1191) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1190)))) tmp1184) (syntax-violation #f "source expression failed to match any pattern" tmp1183))) ($sc-dispatch tmp1183 (quote (any each-any any))))) e1182))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1193) ((lambda (tmp1194) ((lambda (tmp1195) (if (if tmp1195 (apply (lambda (_1196 mod1197 id1198) (if (and-map id?114 mod1197) (id?114 id1198) #f)) tmp1195) #f) (apply (lambda (_1200 mod1201 id1202) (values (syntax->datum id1202) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1201)))) tmp1195) (syntax-violation #f "source expression failed to match any pattern" tmp1194))) ($sc-dispatch tmp1194 (quote (any each-any any))))) e1193))) (global-extend112 (quote core) (quote if) (lambda (e1204 r1205 w1206 s1207 mod1208) ((lambda (tmp1209) ((lambda (tmp1210) (if tmp1210 (apply (lambda (_1211 test1212 then1213) (build-conditional82 s1207 (chi150 test1212 r1205 w1206 mod1208) (chi150 then1213 r1205 w1206 mod1208) (build-void80 #f))) tmp1210) ((lambda (tmp1214) (if tmp1214 (apply (lambda (_1215 test1216 then1217 else1218) (build-conditional82 s1207 (chi150 test1216 r1205 w1206 mod1208) (chi150 then1217 r1205 w1206 mod1208) (chi150 else1218 r1205 w1206 mod1208))) tmp1214) (syntax-violation #f "source expression failed to match any pattern" tmp1209))) ($sc-dispatch tmp1209 (quote (any any any any)))))) ($sc-dispatch tmp1209 (quote (any any any))))) e1204))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1222 (lambda (x1223 keys1224 clauses1225 r1226 mod1227) (if (null? clauses1225) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1223)) ((lambda (tmp1228) ((lambda (tmp1229) (if tmp1229 (apply (lambda (pat1230 exp1231) (if (if (id?114 pat1230) (and-map (lambda (x1232) (not (free-id=?137 pat1230 x1232))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1224)) #f) (let ((labels1233 (list (gen-label119))) (var1234 (gen-var162 pat1230))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1230)) (list var1234) #f (chi150 exp1231 (extend-env108 labels1233 (list (cons (quote syntax) (cons var1234 0))) r1226) (make-binding-wrap131 (list pat1230) labels1233 (quote (()))) mod1227)) (list x1223))) (gen-clause1221 x1223 keys1224 (cdr clauses1225) r1226 pat1230 #t exp1231 mod1227))) tmp1229) ((lambda (tmp1235) (if tmp1235 (apply (lambda (pat1236 fender1237 exp1238) (gen-clause1221 x1223 keys1224 (cdr clauses1225) r1226 pat1236 fender1237 exp1238 mod1227)) tmp1235) ((lambda (_1239) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1225))) tmp1228))) ($sc-dispatch tmp1228 (quote (any any any)))))) ($sc-dispatch tmp1228 (quote (any any))))) (car clauses1225))))) (gen-clause1221 (lambda (x1240 keys1241 clauses1242 r1243 pat1244 fender1245 exp1246 mod1247) (call-with-values (lambda () (convert-pattern1219 pat1244 keys1241)) (lambda (p1248 pvars1249) (if (not (distinct-bound-ids?140 (map car pvars1249))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1244) (if (not (and-map (lambda (x1250) (not (ellipsis?159 (car x1250)))) pvars1249)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1244) (let ((y1251 (gen-var162 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1251) #f (let ((y1252 (build-lexical-reference83 (quote value) #f (quote tmp) y1251))) (build-conditional82 #f ((lambda (tmp1253) ((lambda (tmp1254) (if tmp1254 (apply (lambda () y1252) tmp1254) ((lambda (_1255) (build-conditional82 #f y1252 (build-dispatch-call1220 pvars1249 fender1245 y1252 r1243 mod1247) (build-data92 #f #f))) tmp1253))) ($sc-dispatch tmp1253 (quote #(atom #t))))) fender1245) (build-dispatch-call1220 pvars1249 exp1246 y1252 r1243 mod1247) (gen-syntax-case1222 x1240 keys1241 clauses1242 r1243 mod1247)))) (list (if (eq? p1248 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1240)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1240 (build-data92 #f p1248))))))))))))) (build-dispatch-call1220 (lambda (pvars1256 exp1257 y1258 r1259 mod1260) (let ((ids1261 (map car pvars1256)) (levels1262 (map cdr pvars1256))) (let ((labels1263 (gen-labels120 ids1261)) (new-vars1264 (map gen-var162 ids1261))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1261) new-vars1264 #f (chi150 exp1257 (extend-env108 labels1263 (map (lambda (var1265 level1266) (cons (quote syntax) (cons var1265 level1266))) new-vars1264 (map cdr pvars1256)) r1259) (make-binding-wrap131 ids1261 labels1263 (quote (()))) mod1260)) y1258)))))) (convert-pattern1219 (lambda (pattern1267 keys1268) (letrec ((cvt1269 (lambda (p1270 n1271 ids1272) (if (id?114 p1270) (if (bound-id-member?141 p1270 keys1268) (values (vector (quote free-id) p1270) ids1272) (values (quote any) (cons (cons p1270 n1271) ids1272))) ((lambda (tmp1273) ((lambda (tmp1274) (if (if tmp1274 (apply (lambda (x1275 dots1276) (ellipsis?159 dots1276)) tmp1274) #f) (apply (lambda (x1277 dots1278) (call-with-values (lambda () (cvt1269 x1277 (fx+72 n1271 1) ids1272)) (lambda (p1279 ids1280) (values (if (eq? p1279 (quote any)) (quote each-any) (vector (quote each) p1279)) ids1280)))) tmp1274) ((lambda (tmp1281) (if tmp1281 (apply (lambda (x1282 y1283) (call-with-values (lambda () (cvt1269 y1283 n1271 ids1272)) (lambda (y1284 ids1285) (call-with-values (lambda () (cvt1269 x1282 n1271 ids1285)) (lambda (x1286 ids1287) (values (cons x1286 y1284) ids1287)))))) tmp1281) ((lambda (tmp1288) (if tmp1288 (apply (lambda () (values (quote ()) ids1272)) tmp1288) ((lambda (tmp1289) (if tmp1289 (apply (lambda (x1290) (call-with-values (lambda () (cvt1269 x1290 n1271 ids1272)) (lambda (p1292 ids1293) (values (vector (quote vector) p1292) ids1293)))) tmp1289) ((lambda (x1294) (values (vector (quote atom) (strip161 p1270 (quote (())))) ids1272)) tmp1273))) ($sc-dispatch tmp1273 (quote #(vector each-any)))))) ($sc-dispatch tmp1273 (quote ()))))) ($sc-dispatch tmp1273 (quote (any . any)))))) ($sc-dispatch tmp1273 (quote (any any))))) p1270))))) (cvt1269 pattern1267 0 (quote ())))))) (lambda (e1295 r1296 w1297 s1298 mod1299) (let ((e1300 (source-wrap143 e1295 w1297 s1298 mod1299))) ((lambda (tmp1301) ((lambda (tmp1302) (if tmp1302 (apply (lambda (_1303 val1304 key1305 m1306) (if (and-map (lambda (x1307) (if (id?114 x1307) (not (ellipsis?159 x1307)) #f)) key1305) (let ((x1309 (gen-var162 (quote tmp)))) (build-application81 s1298 (build-lambda90 #f (list (quote tmp)) (list x1309) #f (gen-syntax-case1222 (build-lexical-reference83 (quote value) #f (quote tmp) x1309) key1305 m1306 r1296 mod1299)) (list (chi150 val1304 r1296 (quote (())) mod1299)))) (syntax-violation (quote syntax-case) "invalid literals list" e1300))) tmp1302) (syntax-violation #f "source expression failed to match any pattern" tmp1301))) ($sc-dispatch tmp1301 (quote (any any each-any . each-any))))) e1300))))) (set! sc-expand (lambda (x1313 . rest1312) (if (if (pair? x1313) (equal? (car x1313) noexpand70) #f) (cadr x1313) (let ((m1314 (if (null? rest1312) (quote e) (car rest1312))) (esew1315 (if (let ((t1316 (null? rest1312))) (if t1316 t1316 (null? (cdr rest1312)))) (quote (eval)) (cadr rest1312)))) (with-fluid* *mode*71 m1314 (lambda () (chi-top149 x1313 (quote ()) (quote ((top))) m1314 esew1315 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1317) (nonsymbol-id?113 x1317))) (set! datum->syntax (lambda (id1318 datum1319) (make-syntax-object97 datum1319 (syntax-object-wrap100 id1318) #f))) (set! syntax->datum (lambda (x1320) (strip161 x1320 (quote (()))))) (set! generate-temporaries (lambda (ls1321) (begin (let ((x1322 ls1321)) (if (not (list? x1322)) (syntax-violation (quote generate-temporaries) "invalid argument" x1322))) (map (lambda (x1323) (wrap142 (gensym) (quote ((top))) #f)) ls1321)))) (set! free-identifier=? (lambda (x1324 y1325) (begin (let ((x1326 x1324)) (if (not (nonsymbol-id?113 x1326)) (syntax-violation (quote free-identifier=?) "invalid argument" x1326))) (let ((x1327 y1325)) (if (not (nonsymbol-id?113 x1327)) (syntax-violation (quote free-identifier=?) "invalid argument" x1327))) (free-id=?137 x1324 y1325)))) (set! bound-identifier=? (lambda (x1328 y1329) (begin (let ((x1330 x1328)) (if (not (nonsymbol-id?113 x1330)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1330))) (let ((x1331 y1329)) (if (not (nonsymbol-id?113 x1331)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1331))) (bound-id=?138 x1328 y1329)))) (set! syntax-violation (lambda (who1335 message1334 form1333 . subform1332) (begin (let ((x1336 who1335)) (if (not ((lambda (x1337) (let ((t1338 (not x1337))) (if t1338 t1338 (let ((t1339 (string? x1337))) (if t1339 t1339 (symbol? x1337)))))) x1336)) (syntax-violation (quote syntax-violation) "invalid argument" x1336))) (let ((x1340 message1334)) (if (not (string? x1340)) (syntax-violation (quote syntax-violation) "invalid argument" x1340))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1335 "~a: " "") "~a " (if (null? subform1332) "in ~a" "in subform `~s' of `~s'")) (let ((tail1341 (cons message1334 (map (lambda (x1342) (strip161 x1342 (quote (())))) (append subform1332 (list form1333)))))) (if who1335 (cons who1335 tail1341) tail1341)) #f)))) (letrec ((match1347 (lambda (e1348 p1349 w1350 r1351 mod1352) (if (not r1351) #f (if (eq? p1349 (quote any)) (cons (wrap142 e1348 w1350 mod1352) r1351) (if (syntax-object?98 e1348) (match*1346 (let ((e1353 (syntax-object-expression99 e1348))) (if (annotation? e1353) (annotation-expression e1353) e1353)) p1349 (join-wraps133 w1350 (syntax-object-wrap100 e1348)) r1351 (syntax-object-module101 e1348)) (match*1346 (let ((e1354 e1348)) (if (annotation? e1354) (annotation-expression e1354) e1354)) p1349 w1350 r1351 mod1352)))))) (match*1346 (lambda (e1355 p1356 w1357 r1358 mod1359) (if (null? p1356) (if (null? e1355) r1358 #f) (if (pair? p1356) (if (pair? e1355) (match1347 (car e1355) (car p1356) w1357 (match1347 (cdr e1355) (cdr p1356) w1357 r1358 mod1359) mod1359) #f) (if (eq? p1356 (quote each-any)) (let ((l1360 (match-each-any1344 e1355 w1357 mod1359))) (if l1360 (cons l1360 r1358) #f)) (let ((atom-key1361 (vector-ref p1356 0))) (if (memv atom-key1361 (quote (each))) (if (null? e1355) (match-empty1345 (vector-ref p1356 1) r1358) (let ((l1362 (match-each1343 e1355 (vector-ref p1356 1) w1357 mod1359))) (if l1362 (letrec ((collect1363 (lambda (l1364) (if (null? (car l1364)) r1358 (cons (map car l1364) (collect1363 (map cdr l1364))))))) (collect1363 l1362)) #f))) (if (memv atom-key1361 (quote (free-id))) (if (id?114 e1355) (if (free-id=?137 (wrap142 e1355 w1357 mod1359) (vector-ref p1356 1)) r1358 #f) #f) (if (memv atom-key1361 (quote (atom))) (if (equal? (vector-ref p1356 1) (strip161 e1355 w1357)) r1358 #f) (if (memv atom-key1361 (quote (vector))) (if (vector? e1355) (match1347 (vector->list e1355) (vector-ref p1356 1) w1357 r1358 mod1359) #f))))))))))) (match-empty1345 (lambda (p1365 r1366) (if (null? p1365) r1366 (if (eq? p1365 (quote any)) (cons (quote ()) r1366) (if (pair? p1365) (match-empty1345 (car p1365) (match-empty1345 (cdr p1365) r1366)) (if (eq? p1365 (quote each-any)) (cons (quote ()) r1366) (let ((atom-key1367 (vector-ref p1365 0))) (if (memv atom-key1367 (quote (each))) (match-empty1345 (vector-ref p1365 1) r1366) (if (memv atom-key1367 (quote (free-id atom))) r1366 (if (memv atom-key1367 (quote (vector))) (match-empty1345 (vector-ref p1365 1) r1366))))))))))) (match-each-any1344 (lambda (e1368 w1369 mod1370) (if (annotation? e1368) (match-each-any1344 (annotation-expression e1368) w1369 mod1370) (if (pair? e1368) (let ((l1371 (match-each-any1344 (cdr e1368) w1369 mod1370))) (if l1371 (cons (wrap142 (car e1368) w1369 mod1370) l1371) #f)) (if (null? e1368) (quote ()) (if (syntax-object?98 e1368) (match-each-any1344 (syntax-object-expression99 e1368) (join-wraps133 w1369 (syntax-object-wrap100 e1368)) mod1370) #f)))))) (match-each1343 (lambda (e1372 p1373 w1374 mod1375) (if (annotation? e1372) (match-each1343 (annotation-expression e1372) p1373 w1374 mod1375) (if (pair? e1372) (let ((first1376 (match1347 (car e1372) p1373 w1374 (quote ()) mod1375))) (if first1376 (let ((rest1377 (match-each1343 (cdr e1372) p1373 w1374 mod1375))) (if rest1377 (cons first1376 rest1377) #f)) #f)) (if (null? e1372) (quote ()) (if (syntax-object?98 e1372) (match-each1343 (syntax-object-expression99 e1372) p1373 (join-wraps133 w1374 (syntax-object-wrap100 e1372)) (syntax-object-module101 e1372)) #f))))))) (set! $sc-dispatch (lambda (e1378 p1379) (if (eq? p1379 (quote any)) (list e1378) (if (syntax-object?98 e1378) (match*1346 (let ((e1380 (syntax-object-expression99 e1378))) (if (annotation? e1380) (annotation-expression e1380) e1380)) p1379 (syntax-object-wrap100 e1378) (quote ()) (syntax-object-module101 e1378)) (match*1346 (let ((e1381 e1378)) (if (annotation? e1381) (annotation-expression e1381) e1381)) p1379 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1382) ((lambda (tmp1383) ((lambda (tmp1384) (if tmp1384 (apply (lambda (_1385 e11386 e21387) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11386 e21387))) tmp1384) ((lambda (tmp1389) (if tmp1389 (apply (lambda (_1390 out1391 in1392 e11393 e21394) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1392 (quote ()) (list out1391 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11393 e21394))))) tmp1389) ((lambda (tmp1396) (if tmp1396 (apply (lambda (_1397 out1398 in1399 e11400 e21401) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1399) (quote ()) (list out1398 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11400 e21401))))) tmp1396) (syntax-violation #f "source expression failed to match any pattern" tmp1383))) ($sc-dispatch tmp1383 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1383 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1383 (quote (any () any . each-any))))) x1382)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1405) ((lambda (tmp1406) ((lambda (tmp1407) (if tmp1407 (apply (lambda (_1408 k1409 keyword1410 pattern1411 template1412) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1409 (map (lambda (tmp1415 tmp1414) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1414) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1415))) template1412 pattern1411)))))) tmp1407) (syntax-violation #f "source expression failed to match any pattern" tmp1406))) ($sc-dispatch tmp1406 (quote (any each-any . #(each ((any . any) any))))))) x1405)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1416) ((lambda (tmp1417) ((lambda (tmp1418) (if (if tmp1418 (apply (lambda (let*1419 x1420 v1421 e11422 e21423) (and-map identifier? x1420)) tmp1418) #f) (apply (lambda (let*1425 x1426 v1427 e11428 e21429) (letrec ((f1430 (lambda (bindings1431) (if (null? bindings1431) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11428 e21429))) ((lambda (tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (body1437 binding1438) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1438) body1437)) tmp1436) (syntax-violation #f "source expression failed to match any pattern" tmp1435))) ($sc-dispatch tmp1435 (quote (any any))))) (list (f1430 (cdr bindings1431)) (car bindings1431))))))) (f1430 (map list x1426 v1427)))) tmp1418) (syntax-violation #f "source expression failed to match any pattern" tmp1417))) ($sc-dispatch tmp1417 (quote (any #(each (any any)) any . each-any))))) x1416)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1439) ((lambda (tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (_1442 var1443 init1444 step1445 e01446 e11447 c1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (step1451) ((lambda (tmp1452) ((lambda (tmp1453) (if tmp1453 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1443 init1444) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01446) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1448 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1451))))))) tmp1453) ((lambda (tmp1458) (if tmp1458 (apply (lambda (e11459 e21460) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1443 init1444) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01446 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11459 e21460)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1448 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1451))))))) tmp1458) (syntax-violation #f "source expression failed to match any pattern" tmp1452))) ($sc-dispatch tmp1452 (quote (any . each-any)))))) ($sc-dispatch tmp1452 (quote ())))) e11447)) tmp1450) (syntax-violation #f "source expression failed to match any pattern" tmp1449))) ($sc-dispatch tmp1449 (quote each-any)))) (map (lambda (v1467 s1468) ((lambda (tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda () v1467) tmp1470) ((lambda (tmp1471) (if tmp1471 (apply (lambda (e1472) e1472) tmp1471) ((lambda (_1473) (syntax-violation (quote do) "bad step expression" orig-x1439 s1468)) tmp1469))) ($sc-dispatch tmp1469 (quote (any)))))) ($sc-dispatch tmp1469 (quote ())))) s1468)) var1443 step1445))) tmp1441) (syntax-violation #f "source expression failed to match any pattern" tmp1440))) ($sc-dispatch tmp1440 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1439)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1476 (lambda (x1480 y1481) ((lambda (tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (x1484 y1485) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (dy1488) ((lambda (tmp1489) ((lambda (tmp1490) (if tmp1490 (apply (lambda (dx1491) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1491 dy1488))) tmp1490) ((lambda (_1492) (if (null? dy1488) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1484) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1484 y1485))) tmp1489))) ($sc-dispatch tmp1489 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1484)) tmp1487) ((lambda (tmp1493) (if tmp1493 (apply (lambda (stuff1494) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1484 stuff1494))) tmp1493) ((lambda (else1495) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1484 y1485)) tmp1486))) ($sc-dispatch tmp1486 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1486 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1485)) tmp1483) (syntax-violation #f "source expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote (any any))))) (list x1480 y1481)))) (quasiappend1477 (lambda (x1496 y1497) ((lambda (tmp1498) ((lambda (tmp1499) (if tmp1499 (apply (lambda (x1500 y1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda () x1500) tmp1503) ((lambda (_1504) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1500 y1501)) tmp1502))) ($sc-dispatch tmp1502 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1501)) tmp1499) (syntax-violation #f "source expression failed to match any pattern" tmp1498))) ($sc-dispatch tmp1498 (quote (any any))))) (list x1496 y1497)))) (quasivector1478 (lambda (x1505) ((lambda (tmp1506) ((lambda (x1507) ((lambda (tmp1508) ((lambda (tmp1509) (if tmp1509 (apply (lambda (x1510) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1510))) tmp1509) ((lambda (tmp1512) (if tmp1512 (apply (lambda (x1513) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1513)) tmp1512) ((lambda (_1515) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1507)) tmp1508))) ($sc-dispatch tmp1508 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1508 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1507)) tmp1506)) x1505))) (quasi1479 (lambda (p1516 lev1517) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (p1520) (if (= lev1517 0) p1520 (quasicons1476 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1479 (list p1520) (- lev1517 1))))) tmp1519) ((lambda (tmp1521) (if (if tmp1521 (apply (lambda (args1522) (= lev1517 0)) tmp1521) #f) (apply (lambda (args1523) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1516 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1523))) tmp1521) ((lambda (tmp1524) (if tmp1524 (apply (lambda (p1525 q1526) (if (= lev1517 0) (quasiappend1477 p1525 (quasi1479 q1526 lev1517)) (quasicons1476 (quasicons1476 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1479 (list p1525) (- lev1517 1))) (quasi1479 q1526 lev1517)))) tmp1524) ((lambda (tmp1527) (if (if tmp1527 (apply (lambda (args1528 q1529) (= lev1517 0)) tmp1527) #f) (apply (lambda (args1530 q1531) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1516 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1530))) tmp1527) ((lambda (tmp1532) (if tmp1532 (apply (lambda (p1533) (quasicons1476 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1479 (list p1533) (+ lev1517 1)))) tmp1532) ((lambda (tmp1534) (if tmp1534 (apply (lambda (p1535 q1536) (quasicons1476 (quasi1479 p1535 lev1517) (quasi1479 q1536 lev1517))) tmp1534) ((lambda (tmp1537) (if tmp1537 (apply (lambda (x1538) (quasivector1478 (quasi1479 x1538 lev1517))) tmp1537) ((lambda (p1540) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1540)) tmp1518))) ($sc-dispatch tmp1518 (quote #(vector each-any)))))) ($sc-dispatch tmp1518 (quote (any . any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1518 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1518 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1516)))) (lambda (x1541) ((lambda (tmp1542) ((lambda (tmp1543) (if tmp1543 (apply (lambda (_1544 e1545) (quasi1479 e1545 0)) tmp1543) (syntax-violation #f "source expression failed to match any pattern" tmp1542))) ($sc-dispatch tmp1542 (quote (any any))))) x1541))))) +(define include (make-syncase-macro (quote macro) (lambda (x1546) (letrec ((read-file1547 (lambda (fn1548 k1549) (let ((p1550 (open-input-file fn1548))) (letrec ((f1551 (lambda (x1552) (if (eof-object? x1552) (begin (close-input-port p1550) (quote ())) (cons (datum->syntax k1549 x1552) (f1551 (read p1550))))))) (f1551 (read p1550))))))) ((lambda (tmp1553) ((lambda (tmp1554) (if tmp1554 (apply (lambda (k1555 filename1556) (let ((fn1557 (syntax->datum filename1556))) ((lambda (tmp1558) ((lambda (tmp1559) (if tmp1559 (apply (lambda (exp1560) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1560)) tmp1559) (syntax-violation #f "source expression failed to match any pattern" tmp1558))) ($sc-dispatch tmp1558 (quote each-any)))) (read-file1547 fn1557 k1555)))) tmp1554) (syntax-violation #f "source expression failed to match any pattern" tmp1553))) ($sc-dispatch tmp1553 (quote (any any))))) x1546))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1562) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565 e1566) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1562)) tmp1564) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any))))) x1562)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply (lambda (_1570 e1571) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1567)) tmp1569) (syntax-violation #f "source expression failed to match any pattern" tmp1568))) ($sc-dispatch tmp1568 (quote (any any))))) x1567)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1572) ((lambda (tmp1573) ((lambda (tmp1574) (if tmp1574 (apply (lambda (_1575 e1576 m11577 m21578) ((lambda (tmp1579) ((lambda (body1580) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1576)) body1580)) tmp1579)) (letrec ((f1581 (lambda (clause1582 clauses1583) (if (null? clauses1583) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (e11587 e21588) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11587 e21588))) tmp1586) ((lambda (tmp1590) (if tmp1590 (apply (lambda (k1591 e11592 e21593) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1591)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11592 e21593)))) tmp1590) ((lambda (_1596) (syntax-violation (quote case) "bad clause" x1572 clause1582)) tmp1585))) ($sc-dispatch tmp1585 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1582) ((lambda (tmp1597) ((lambda (rest1598) ((lambda (tmp1599) ((lambda (tmp1600) (if tmp1600 (apply (lambda (k1601 e11602 e21603) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1601)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11602 e21603)) rest1598)) tmp1600) ((lambda (_1606) (syntax-violation (quote case) "bad clause" x1572 clause1582)) tmp1599))) ($sc-dispatch tmp1599 (quote (each-any any . each-any))))) clause1582)) tmp1597)) (f1581 (car clauses1583) (cdr clauses1583))))))) (f1581 m11577 m21578)))) tmp1574) (syntax-violation #f "source expression failed to match any pattern" tmp1573))) ($sc-dispatch tmp1573 (quote (any any any . each-any))))) x1572)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1607) ((lambda (tmp1608) ((lambda (tmp1609) (if tmp1609 (apply (lambda (_1610 e1611) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1611)) (list (cons _1610 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1611 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1609) (syntax-violation #f "source expression failed to match any pattern" tmp1608))) ($sc-dispatch tmp1608 (quote (any any))))) x1607)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index dcbc32a0d..735f56423 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1356,7 +1356,8 @@ (ribcage (make-empty-ribcage)) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) - (ids '()) (labels '()) (vars '()) (vals '()) (bindings '())) + (ids '()) (labels '()) + (var-ids '()) (vars '()) (vals '()) (bindings '())) (if (null? body) (syntax-violation #f "no expressions in body" outer-form) (let ((e (cdar body)) (er (caar body))) @@ -1370,6 +1371,7 @@ (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) + (cons id var-ids) (cons var vars) (cons (cons er (wrap e w mod)) vals) (cons (make-binding 'lexical var) bindings))))) ((define-syntax-form) @@ -1377,7 +1379,7 @@ (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) - vars vals + var-ids vars vals (cons (make-binding 'macro (cons er (wrap e w mod))) bindings)))) ((begin-form) @@ -1388,7 +1390,7 @@ (cdr body) (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids labels vars vals bindings)))) + ids labels var-ids vars vals bindings)))) ((local-syntax-form) (chi-local-syntax value e er w s mod (lambda (forms er w s mod) @@ -1397,7 +1399,7 @@ (cdr body) (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids labels vars vals bindings)))) + ids labels var-ids vars vals bindings)))) (else ; found a non-definition (if (null? ids) (build-sequence no-source @@ -1427,7 +1429,7 @@ (loop (cdr bs) er-cache r-cache))))) (set-cdr! r (extend-env labels bindings (cdr r))) (build-letrec no-source - (map syntax->datum ids) + (map syntax->datum var-ids) vars (map (lambda (x) (chi (cdr x) (car x) empty-wrap mod)) From b40d023067b54f1085f194c521c2d046fceb9444 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 19:48:14 +0200 Subject: [PATCH 152/375] remove annotations in psyntax in favor of guile's source properties * module/ice-9/psyntax.scm: Remove references to annotation objects, we're just going to try and use Guile's source properties now. It works until `syntax' reconstructs output, at which point it seems we lose it. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 22 ++-- module/ice-9/psyntax.scm | 200 ++++++++++++++---------------------- 2 files changed, 86 insertions(+), 136 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index e0b545a76..b1646fe9d 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list163 (lambda (vars292) (letrec ((lvl293 (lambda (vars294 ls295 w296) (if (pair? vars294) (lvl293 (cdr vars294) (cons (wrap142 (car vars294) w296 #f) ls295) w296) (if (id?114 vars294) (cons (wrap142 vars294 w296 #f) ls295) (if (null? vars294) ls295 (if (syntax-object?98 vars294) (lvl293 (syntax-object-expression99 vars294) ls295 (join-wraps133 w296 (syntax-object-wrap100 vars294))) (if (annotation? vars294) (lvl293 (annotation-expression vars294) ls295 w296) (cons vars294 ls295))))))))) (lvl293 vars292 (quote ()) (quote (())))))) (gen-var162 (lambda (id297) (let ((id298 (if (syntax-object?98 id297) (syntax-object-expression99 id297) id297))) (if (annotation? id298) (gensym (symbol->string (annotation-expression id298))) (gensym (symbol->string id298)))))) (strip161 (lambda (x299 w300) (if (memq (quote top) (wrap-marks117 w300)) (if (let ((t301 (annotation? x299))) (if t301 t301 (if (pair? x299) (annotation? (car x299)) #f))) (strip-annotation160 x299 #f) x299) (letrec ((f302 (lambda (x303) (if (syntax-object?98 x303) (strip161 (syntax-object-expression99 x303) (syntax-object-wrap100 x303)) (if (pair? x303) (let ((a304 (f302 (car x303))) (d305 (f302 (cdr x303)))) (if (if (eq? a304 (car x303)) (eq? d305 (cdr x303)) #f) x303 (cons a304 d305))) (if (vector? x303) (let ((old306 (vector->list x303))) (let ((new307 (map f302 old306))) (if (and-map*17 eq? old306 new307) x303 (list->vector new307)))) x303)))))) (f302 x299))))) (strip-annotation160 (lambda (x308 parent309) (if (pair? x308) (let ((new310 (cons #f #f))) (begin (if parent309 (set-annotation-stripped! parent309 new310)) (set-car! new310 (strip-annotation160 (car x308) #f)) (set-cdr! new310 (strip-annotation160 (cdr x308) #f)) new310)) (if (annotation? x308) (let ((t311 (annotation-stripped x308))) (if t311 t311 (strip-annotation160 (annotation-expression x308) x308))) (if (vector? x308) (let ((new312 (make-vector (vector-length x308)))) (begin (if parent309 (set-annotation-stripped! parent309 new312)) (letrec ((loop313 (lambda (i314) (unless (fx<75 i314 0) (vector-set! new312 i314 (strip-annotation160 (vector-ref x308 i314) #f)) (loop313 (fx-73 i314 1)))))) (loop313 (- (vector-length x308) 1))) new312)) x308))))) (ellipsis?159 (lambda (x315) (if (nonsymbol-id?113 x315) (free-id=?137 x315 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded316 mod317) (let ((p318 (local-eval-hook77 expanded316 mod317))) (if (procedure? p318) p318 (syntax-violation #f "nonprocedure transformer" p318))))) (chi-local-syntax156 (lambda (rec?319 e320 r321 w322 s323 mod324 k325) ((lambda (tmp326) ((lambda (tmp327) (if tmp327 (apply (lambda (_328 id329 val330 e1331 e2332) (let ((ids333 id329)) (if (not (valid-bound-ids?139 ids333)) (syntax-violation #f "duplicate bound keyword" e320) (let ((labels335 (gen-labels120 ids333))) (let ((new-w336 (make-binding-wrap131 ids333 labels335 w322))) (k325 (cons e1331 e2332) (extend-env108 labels335 (let ((w338 (if rec?319 new-w336 w322)) (trans-r339 (macros-only-env110 r321))) (map (lambda (x340) (cons (quote macro) (eval-local-transformer157 (chi150 x340 trans-r339 w338 mod324) mod324))) val330)) r321) new-w336 s323 mod324)))))) tmp327) ((lambda (_342) (syntax-violation #f "bad local syntax definition" (source-wrap143 e320 w322 s323 mod324))) tmp326))) ($sc-dispatch tmp326 (quote (any #(each (any any)) any . each-any))))) e320))) (chi-lambda-clause155 (lambda (e343 docstring344 c345 r346 w347 mod348 k349) ((lambda (tmp350) ((lambda (tmp351) (if (if tmp351 (apply (lambda (args352 doc353 e1354 e2355) (if (string? (syntax->datum doc353)) (not docstring344) #f)) tmp351) #f) (apply (lambda (args356 doc357 e1358 e2359) (chi-lambda-clause155 e343 doc357 (cons args356 (cons e1358 e2359)) r346 w347 mod348 k349)) tmp351) ((lambda (tmp361) (if tmp361 (apply (lambda (id362 e1363 e2364) (let ((ids365 id362)) (if (not (valid-bound-ids?139 ids365)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels367 (gen-labels120 ids365)) (new-vars368 (map gen-var162 ids365))) (k349 (map syntax->datum ids365) new-vars368 (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1363 e2364) e343 (extend-var-env109 labels367 new-vars368 r346) (make-binding-wrap131 ids365 labels367 w347) mod348)))))) tmp361) ((lambda (tmp370) (if tmp370 (apply (lambda (ids371 e1372 e2373) (let ((old-ids374 (lambda-var-list163 ids371))) (if (not (valid-bound-ids?139 old-ids374)) (syntax-violation (quote lambda) "invalid parameter list" e343) (let ((labels375 (gen-labels120 old-ids374)) (new-vars376 (map gen-var162 old-ids374))) (k349 (letrec ((f377 (lambda (ls1378 ls2379) (if (null? ls1378) (syntax->datum ls2379) (f377 (cdr ls1378) (cons (syntax->datum (car ls1378)) ls2379)))))) (f377 (cdr old-ids374) (car old-ids374))) (letrec ((f380 (lambda (ls1381 ls2382) (if (null? ls1381) ls2382 (f380 (cdr ls1381) (cons (car ls1381) ls2382)))))) (f380 (cdr new-vars376) (car new-vars376))) (if docstring344 (syntax->datum docstring344) #f) (chi-body154 (cons e1372 e2373) e343 (extend-var-env109 labels375 new-vars376 r346) (make-binding-wrap131 old-ids374 labels375 w347) mod348)))))) tmp370) ((lambda (_384) (syntax-violation (quote lambda) "bad lambda" e343)) tmp350))) ($sc-dispatch tmp350 (quote (any any . each-any)))))) ($sc-dispatch tmp350 (quote (each-any any . each-any)))))) ($sc-dispatch tmp350 (quote (any any any . each-any))))) c345))) (chi-body154 (lambda (body385 outer-form386 r387 w388 mod389) (let ((r390 (cons (quote ("placeholder" placeholder)) r387))) (let ((ribcage391 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w392 (make-wrap116 (wrap-marks117 w388) (cons ribcage391 (wrap-subst118 w388))))) (letrec ((parse393 (lambda (body394 ids395 labels396 var-ids397 vars398 vals399 bindings400) (if (null? body394) (syntax-violation #f "no expressions in body" outer-form386) (let ((e402 (cdar body394)) (er403 (caar body394))) (call-with-values (lambda () (syntax-type148 e402 er403 (quote (())) #f ribcage391 mod389)) (lambda (type404 value405 e406 w407 s408 mod409) (if (memv type404 (quote (define-form))) (let ((id410 (wrap142 value405 w407 mod409)) (label411 (gen-label119))) (let ((var412 (gen-var162 id410))) (begin (extend-ribcage!130 ribcage391 id410 label411) (parse393 (cdr body394) (cons id410 ids395) (cons label411 labels396) (cons id410 var-ids397) (cons var412 vars398) (cons (cons er403 (wrap142 e406 w407 mod409)) vals399) (cons (cons (quote lexical) var412) bindings400))))) (if (memv type404 (quote (define-syntax-form))) (let ((id413 (wrap142 value405 w407 mod409)) (label414 (gen-label119))) (begin (extend-ribcage!130 ribcage391 id413 label414) (parse393 (cdr body394) (cons id413 ids395) (cons label414 labels396) var-ids397 vars398 vals399 (cons (cons (quote macro) (cons er403 (wrap142 e406 w407 mod409))) bindings400)))) (if (memv type404 (quote (begin-form))) ((lambda (tmp415) ((lambda (tmp416) (if tmp416 (apply (lambda (_417 e1418) (parse393 (letrec ((f419 (lambda (forms420) (if (null? forms420) (cdr body394) (cons (cons er403 (wrap142 (car forms420) w407 mod409)) (f419 (cdr forms420))))))) (f419 e1418)) ids395 labels396 var-ids397 vars398 vals399 bindings400)) tmp416) (syntax-violation #f "source expression failed to match any pattern" tmp415))) ($sc-dispatch tmp415 (quote (any . each-any))))) e406) (if (memv type404 (quote (local-syntax-form))) (chi-local-syntax156 value405 e406 er403 w407 s408 mod409 (lambda (forms422 er423 w424 s425 mod426) (parse393 (letrec ((f427 (lambda (forms428) (if (null? forms428) (cdr body394) (cons (cons er423 (wrap142 (car forms428) w424 mod426)) (f427 (cdr forms428))))))) (f427 forms422)) ids395 labels396 var-ids397 vars398 vals399 bindings400))) (if (null? ids395) (build-sequence93 #f (map (lambda (x429) (chi150 (cdr x429) (car x429) (quote (())) mod409)) (cons (cons er403 (source-wrap143 e406 w407 s408 mod409)) (cdr body394)))) (begin (if (not (valid-bound-ids?139 ids395)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form386)) (letrec ((loop430 (lambda (bs431 er-cache432 r-cache433) (if (not (null? bs431)) (let ((b434 (car bs431))) (if (eq? (car b434) (quote macro)) (let ((er435 (cadr b434))) (let ((r-cache436 (if (eq? er435 er-cache432) r-cache433 (macros-only-env110 er435)))) (begin (set-cdr! b434 (eval-local-transformer157 (chi150 (cddr b434) r-cache436 (quote (())) mod409) mod409)) (loop430 (cdr bs431) er435 r-cache436)))) (loop430 (cdr bs431) er-cache432 r-cache433))))))) (loop430 bindings400 #f #f)) (set-cdr! r390 (extend-env108 labels396 bindings400 (cdr r390))) (build-letrec96 #f (map syntax->datum var-ids397) vars398 (map (lambda (x437) (chi150 (cdr x437) (car x437) (quote (())) mod409)) vals399) (build-sequence93 #f (map (lambda (x438) (chi150 (cdr x438) (car x438) (quote (())) mod409)) (cons (cons er403 (source-wrap143 e406 w407 s408 mod409)) (cdr body394)))))))))))))))))) (parse393 (map (lambda (x401) (cons r390 (wrap142 x401 w392 mod389))) body385) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p439 e440 r441 w442 rib443 mod444) (letrec ((rebuild-macro-output445 (lambda (x446 m447) (if (pair? x446) (cons (rebuild-macro-output445 (car x446) m447) (rebuild-macro-output445 (cdr x446) m447)) (if (syntax-object?98 x446) (let ((w448 (syntax-object-wrap100 x446))) (let ((ms449 (wrap-marks117 w448)) (s450 (wrap-subst118 w448))) (if (if (pair? ms449) (eq? (car ms449) #f) #f) (make-syntax-object97 (syntax-object-expression99 x446) (make-wrap116 (cdr ms449) (if rib443 (cons rib443 (cdr s450)) (cdr s450))) (syntax-object-module101 x446)) (make-syntax-object97 (syntax-object-expression99 x446) (make-wrap116 (cons m447 ms449) (if rib443 (cons rib443 (cons (quote shift) s450)) (cons (quote shift) s450))) (let ((pmod451 (procedure-module p439))) (if pmod451 (cons (quote hygiene) (module-name pmod451)) (quote (hygiene guile)))))))) (if (vector? x446) (let ((n452 (vector-length x446))) (let ((v453 (make-vector n452))) (letrec ((loop454 (lambda (i455) (if (fx=74 i455 n452) (begin (if #f #f) v453) (begin (vector-set! v453 i455 (rebuild-macro-output445 (vector-ref x446 i455) m447)) (loop454 (fx+72 i455 1))))))) (loop454 0)))) (if (symbol? x446) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e440 w442 s mod444) x446) x446))))))) (rebuild-macro-output445 (p439 (wrap142 e440 (anti-mark129 w442) mod444)) (string #\m))))) (chi-application152 (lambda (x456 e457 r458 w459 s460 mod461) ((lambda (tmp462) ((lambda (tmp463) (if tmp463 (apply (lambda (e0464 e1465) (build-application81 s460 x456 (map (lambda (e466) (chi150 e466 r458 w459 mod461)) e1465))) tmp463) (syntax-violation #f "source expression failed to match any pattern" tmp462))) ($sc-dispatch tmp462 (quote (any . each-any))))) e457))) (chi-expr151 (lambda (type468 value469 e470 r471 w472 s473 mod474) (if (memv type468 (quote (lexical))) (build-lexical-reference83 (quote value) s473 e470 value469) (if (memv type468 (quote (core external-macro))) (value469 e470 r471 w472 s473 mod474) (if (memv type468 (quote (module-ref))) (call-with-values (lambda () (value469 e470)) (lambda (id475 mod476) (build-global-reference86 s473 id475 mod476))) (if (memv type468 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e470)) (car e470) value469) e470 r471 w472 s473 mod474) (if (memv type468 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e470)) value469 (if (syntax-object?98 (car e470)) (syntax-object-module101 (car e470)) mod474)) e470 r471 w472 s473 mod474) (if (memv type468 (quote (constant))) (build-data92 s473 (strip161 (source-wrap143 e470 w472 s473 mod474) (quote (())))) (if (memv type468 (quote (global))) (build-global-reference86 s473 value469 mod474) (if (memv type468 (quote (call))) (chi-application152 (chi150 (car e470) r471 w472 mod474) e470 r471 w472 s473 mod474) (if (memv type468 (quote (begin-form))) ((lambda (tmp477) ((lambda (tmp478) (if tmp478 (apply (lambda (_479 e1480 e2481) (chi-sequence144 (cons e1480 e2481) r471 w472 s473 mod474)) tmp478) (syntax-violation #f "source expression failed to match any pattern" tmp477))) ($sc-dispatch tmp477 (quote (any any . each-any))))) e470) (if (memv type468 (quote (local-syntax-form))) (chi-local-syntax156 value469 e470 r471 w472 s473 mod474 chi-sequence144) (if (memv type468 (quote (eval-when-form))) ((lambda (tmp483) ((lambda (tmp484) (if tmp484 (apply (lambda (_485 x486 e1487 e2488) (let ((when-list489 (chi-when-list147 e470 x486 w472))) (if (memq (quote eval) when-list489) (chi-sequence144 (cons e1487 e2488) r471 w472 s473 mod474) (chi-void158)))) tmp484) (syntax-violation #f "source expression failed to match any pattern" tmp483))) ($sc-dispatch tmp483 (quote (any each-any any . each-any))))) e470) (if (memv type468 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e470 (wrap142 value469 w472 mod474)) (if (memv type468 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e470 w472 s473 mod474)) (if (memv type468 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e470 w472 s473 mod474)) (syntax-violation #f "unexpected syntax" (source-wrap143 e470 w472 s473 mod474)))))))))))))))))) (chi150 (lambda (e492 r493 w494 mod495) (call-with-values (lambda () (syntax-type148 e492 r493 w494 #f #f mod495)) (lambda (type496 value497 e498 w499 s500 mod501) (chi-expr151 type496 value497 e498 r493 w499 s500 mod501))))) (chi-top149 (lambda (e502 r503 w504 m505 esew506 mod507) (call-with-values (lambda () (syntax-type148 e502 r503 w504 #f #f mod507)) (lambda (type515 value516 e517 w518 s519 mod520) (if (memv type515 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void158)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence145 (cons e1526 e2527) r503 w518 s519 m505 esew506 mod520)) tmp524) (syntax-violation #f "source expression failed to match any pattern" tmp521))) ($sc-dispatch tmp521 (quote (any any . each-any)))))) ($sc-dispatch tmp521 (quote (any))))) e517) (if (memv type515 (quote (local-syntax-form))) (chi-local-syntax156 value516 e517 r503 w518 s519 mod520 (lambda (body529 r530 w531 s532 mod533) (chi-top-sequence145 body529 r530 w531 s532 m505 esew506 mod533))) (if (memv type515 (quote (eval-when-form))) ((lambda (tmp534) ((lambda (tmp535) (if tmp535 (apply (lambda (_536 x537 e1538 e2539) (let ((when-list540 (chi-when-list147 e517 x537 w518)) (body541 (cons e1538 e2539))) (if (eq? m505 (quote e)) (if (memq (quote eval) when-list540) (chi-top-sequence145 body541 r503 w518 s519 (quote e) (quote (eval)) mod520) (chi-void158)) (if (memq (quote load) when-list540) (if (let ((t544 (memq (quote compile) when-list540))) (if t544 t544 (if (eq? m505 (quote c&e)) (memq (quote eval) when-list540) #f))) (chi-top-sequence145 body541 r503 w518 s519 (quote c&e) (quote (compile load)) mod520) (if (memq m505 (quote (c c&e))) (chi-top-sequence145 body541 r503 w518 s519 (quote c) (quote (load)) mod520) (chi-void158))) (if (let ((t545 (memq (quote compile) when-list540))) (if t545 t545 (if (eq? m505 (quote c&e)) (memq (quote eval) when-list540) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body541 r503 w518 s519 (quote e) (quote (eval)) mod520) mod520) (chi-void158)) (chi-void158)))))) tmp535) (syntax-violation #f "source expression failed to match any pattern" tmp534))) ($sc-dispatch tmp534 (quote (any each-any any . each-any))))) e517) (if (memv type515 (quote (define-syntax-form))) (let ((n546 (id-var-name136 value516 w518)) (r547 (macros-only-env110 r503))) (if (memv m505 (quote (c))) (if (memq (quote compile) esew506) (let ((e548 (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)))) (begin (top-level-eval-hook76 e548 mod520) (if (memq (quote load) esew506) e548 (chi-void158)))) (if (memq (quote load) esew506) (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)) (chi-void158))) (if (memv m505 (quote (c&e))) (let ((e549 (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)))) (begin (top-level-eval-hook76 e549 mod520) e549)) (begin (if (memq (quote eval) esew506) (top-level-eval-hook76 (chi-install-global146 n546 (chi150 e517 r547 w518 mod520)) mod520)) (chi-void158))))) (if (memv type515 (quote (define-form))) (let ((n550 (id-var-name136 value516 w518))) (let ((type551 (binding-type106 (lookup111 n550 r503 mod520)))) (if (memv type551 (quote (global core macro module-ref))) (let ((x552 (build-global-definition89 s519 n550 (chi150 e517 r503 w518 mod520)))) (begin (if (eq? m505 (quote c&e)) (top-level-eval-hook76 x552 mod520)) x552)) (if (memv type551 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e517 (wrap142 value516 w518 mod520)) (syntax-violation #f "cannot define keyword at top level" e517 (wrap142 value516 w518 mod520)))))) (let ((x553 (chi-expr151 type515 value516 e517 r503 w518 s519 mod520))) (begin (if (eq? m505 (quote c&e)) (top-level-eval-hook76 x553 mod520)) x553))))))))))) (syntax-type148 (lambda (e554 r555 w556 s557 rib558 mod559) (if (symbol? e554) (let ((n560 (id-var-name136 e554 w556))) (let ((b561 (lookup111 n560 r555 mod559))) (let ((type562 (binding-type106 b561))) (if (memv type562 (quote (lexical))) (values type562 (binding-value107 b561) e554 w556 s557 mod559) (if (memv type562 (quote (global))) (values type562 n560 e554 w556 s557 mod559) (if (memv type562 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b561) e554 r555 w556 rib558 mod559) r555 (quote (())) s557 rib558 mod559) (values type562 (binding-value107 b561) e554 w556 s557 mod559))))))) (if (pair? e554) (let ((first563 (car e554))) (if (id?114 first563) (let ((n564 (id-var-name136 first563 w556))) (let ((b565 (lookup111 n564 r555 (let ((t566 (if (syntax-object?98 first563) (syntax-object-module101 first563) #f))) (if t566 t566 mod559))))) (let ((type567 (binding-type106 b565))) (if (memv type567 (quote (lexical))) (values (quote lexical-call) (binding-value107 b565) e554 w556 s557 mod559) (if (memv type567 (quote (global))) (values (quote global-call) n564 e554 w556 s557 mod559) (if (memv type567 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b565) e554 r555 w556 rib558 mod559) r555 (quote (())) s557 rib558 mod559) (if (memv type567 (quote (core external-macro module-ref))) (values type567 (binding-value107 b565) e554 w556 s557 mod559) (if (memv type567 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value107 b565) e554 w556 s557 mod559) (if (memv type567 (quote (begin))) (values (quote begin-form) #f e554 w556 s557 mod559) (if (memv type567 (quote (eval-when))) (values (quote eval-when-form) #f e554 w556 s557 mod559) (if (memv type567 (quote (define))) ((lambda (tmp568) ((lambda (tmp569) (if (if tmp569 (apply (lambda (_570 name571 val572) (id?114 name571)) tmp569) #f) (apply (lambda (_573 name574 val575) (values (quote define-form) name574 val575 w556 s557 mod559)) tmp569) ((lambda (tmp576) (if (if tmp576 (apply (lambda (_577 name578 args579 e1580 e2581) (if (id?114 name578) (valid-bound-ids?139 (lambda-var-list163 args579)) #f)) tmp576) #f) (apply (lambda (_582 name583 args584 e1585 e2586) (values (quote define-form) (wrap142 name583 w556 mod559) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args584 (cons e1585 e2586)) w556 mod559)) (quote (())) s557 mod559)) tmp576) ((lambda (tmp588) (if (if tmp588 (apply (lambda (_589 name590) (id?114 name590)) tmp588) #f) (apply (lambda (_591 name592) (values (quote define-form) (wrap142 name592 w556 mod559) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s557 mod559)) tmp588) (syntax-violation #f "source expression failed to match any pattern" tmp568))) ($sc-dispatch tmp568 (quote (any any)))))) ($sc-dispatch tmp568 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp568 (quote (any any any))))) e554) (if (memv type567 (quote (define-syntax))) ((lambda (tmp593) ((lambda (tmp594) (if (if tmp594 (apply (lambda (_595 name596 val597) (id?114 name596)) tmp594) #f) (apply (lambda (_598 name599 val600) (values (quote define-syntax-form) name599 val600 w556 s557 mod559)) tmp594) (syntax-violation #f "source expression failed to match any pattern" tmp593))) ($sc-dispatch tmp593 (quote (any any any))))) e554) (values (quote call) #f e554 w556 s557 mod559))))))))))))) (values (quote call) #f e554 w556 s557 mod559))) (if (syntax-object?98 e554) (syntax-type148 (syntax-object-expression99 e554) r555 (join-wraps133 w556 (syntax-object-wrap100 e554)) #f rib558 (let ((t601 (syntax-object-module101 e554))) (if t601 t601 mod559))) (if (annotation? e554) (syntax-type148 (annotation-expression e554) r555 w556 (annotation-source e554) rib558 mod559) (if (self-evaluating? e554) (values (quote constant) #f e554 w556 s557 mod559) (values (quote other) #f e554 w556 s557 mod559)))))))) (chi-when-list147 (lambda (e602 when-list603 w604) (letrec ((f605 (lambda (when-list606 situations607) (if (null? when-list606) situations607 (f605 (cdr when-list606) (cons (let ((x608 (car when-list606))) (if (free-id=?137 x608 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x608 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x608 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e602 (wrap142 x608 w604 #f)))))) situations607)))))) (f605 when-list603 (quote ()))))) (chi-install-global146 (lambda (name609 e610) (build-global-definition89 #f name609 (if (let ((v611 (module-variable (current-module) name609))) (if v611 (if (variable-bound? v611) (if (macro? (variable-ref v611)) (not (eq? (macro-type (variable-ref v611)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name609))) (build-data92 #f (quote macro)) e610)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e610)))))) (chi-top-sequence145 (lambda (body612 r613 w614 s615 m616 esew617 mod618) (build-sequence93 s615 (letrec ((dobody619 (lambda (body620 r621 w622 m623 esew624 mod625) (if (null? body620) (quote ()) (let ((first626 (chi-top149 (car body620) r621 w622 m623 esew624 mod625))) (cons first626 (dobody619 (cdr body620) r621 w622 m623 esew624 mod625))))))) (dobody619 body612 r613 w614 m616 esew617 mod618))))) (chi-sequence144 (lambda (body627 r628 w629 s630 mod631) (build-sequence93 s630 (letrec ((dobody632 (lambda (body633 r634 w635 mod636) (if (null? body633) (quote ()) (let ((first637 (chi150 (car body633) r634 w635 mod636))) (cons first637 (dobody632 (cdr body633) r634 w635 mod636))))))) (dobody632 body627 r628 w629 mod631))))) (source-wrap143 (lambda (x638 w639 s640 defmod641) (wrap142 (if s640 (make-annotation x638 s640 #f) x638) w639 defmod641))) (wrap142 (lambda (x642 w643 defmod644) (if (if (null? (wrap-marks117 w643)) (null? (wrap-subst118 w643)) #f) x642 (if (syntax-object?98 x642) (make-syntax-object97 (syntax-object-expression99 x642) (join-wraps133 w643 (syntax-object-wrap100 x642)) (syntax-object-module101 x642)) (if (null? x642) x642 (make-syntax-object97 x642 w643 defmod644)))))) (bound-id-member?141 (lambda (x645 list646) (if (not (null? list646)) (let ((t647 (bound-id=?138 x645 (car list646)))) (if t647 t647 (bound-id-member?141 x645 (cdr list646)))) #f))) (distinct-bound-ids?140 (lambda (ids648) (letrec ((distinct?649 (lambda (ids650) (let ((t651 (null? ids650))) (if t651 t651 (if (not (bound-id-member?141 (car ids650) (cdr ids650))) (distinct?649 (cdr ids650)) #f)))))) (distinct?649 ids648)))) (valid-bound-ids?139 (lambda (ids652) (if (letrec ((all-ids?653 (lambda (ids654) (let ((t655 (null? ids654))) (if t655 t655 (if (id?114 (car ids654)) (all-ids?653 (cdr ids654)) #f)))))) (all-ids?653 ids652)) (distinct-bound-ids?140 ids652) #f))) (bound-id=?138 (lambda (i656 j657) (if (if (syntax-object?98 i656) (syntax-object?98 j657) #f) (if (eq? (let ((e658 (syntax-object-expression99 i656))) (if (annotation? e658) (annotation-expression e658) e658)) (let ((e659 (syntax-object-expression99 j657))) (if (annotation? e659) (annotation-expression e659) e659))) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i656)) (wrap-marks117 (syntax-object-wrap100 j657))) #f) (eq? (let ((e660 i656)) (if (annotation? e660) (annotation-expression e660) e660)) (let ((e661 j657)) (if (annotation? e661) (annotation-expression e661) e661)))))) (free-id=?137 (lambda (i662 j663) (if (eq? (let ((x664 i662)) (let ((e665 (if (syntax-object?98 x664) (syntax-object-expression99 x664) x664))) (if (annotation? e665) (annotation-expression e665) e665))) (let ((x666 j663)) (let ((e667 (if (syntax-object?98 x666) (syntax-object-expression99 x666) x666))) (if (annotation? e667) (annotation-expression e667) e667)))) (eq? (id-var-name136 i662 (quote (()))) (id-var-name136 j663 (quote (())))) #f))) (id-var-name136 (lambda (id668 w669) (letrec ((search-vector-rib672 (lambda (sym678 subst679 marks680 symnames681 ribcage682) (let ((n683 (vector-length symnames681))) (letrec ((f684 (lambda (i685) (if (fx=74 i685 n683) (search670 sym678 (cdr subst679) marks680) (if (if (eq? (vector-ref symnames681 i685) sym678) (same-marks?135 marks680 (vector-ref (ribcage-marks124 ribcage682) i685)) #f) (values (vector-ref (ribcage-labels125 ribcage682) i685) marks680) (f684 (fx+72 i685 1))))))) (f684 0))))) (search-list-rib671 (lambda (sym686 subst687 marks688 symnames689 ribcage690) (letrec ((f691 (lambda (symnames692 i693) (if (null? symnames692) (search670 sym686 (cdr subst687) marks688) (if (if (eq? (car symnames692) sym686) (same-marks?135 marks688 (list-ref (ribcage-marks124 ribcage690) i693)) #f) (values (list-ref (ribcage-labels125 ribcage690) i693) marks688) (f691 (cdr symnames692) (fx+72 i693 1))))))) (f691 symnames689 0)))) (search670 (lambda (sym694 subst695 marks696) (if (null? subst695) (values #f marks696) (let ((fst697 (car subst695))) (if (eq? fst697 (quote shift)) (search670 sym694 (cdr subst695) (cdr marks696)) (let ((symnames698 (ribcage-symnames123 fst697))) (if (vector? symnames698) (search-vector-rib672 sym694 subst695 marks696 symnames698 fst697) (search-list-rib671 sym694 subst695 marks696 symnames698 fst697))))))))) (if (symbol? id668) (let ((t699 (call-with-values (lambda () (search670 id668 (wrap-subst118 w669) (wrap-marks117 w669))) (lambda (x701 . ignore700) x701)))) (if t699 t699 id668)) (if (syntax-object?98 id668) (let ((id702 (let ((e704 (syntax-object-expression99 id668))) (if (annotation? e704) (annotation-expression e704) e704))) (w1703 (syntax-object-wrap100 id668))) (let ((marks705 (join-marks134 (wrap-marks117 w669) (wrap-marks117 w1703)))) (call-with-values (lambda () (search670 id702 (wrap-subst118 w669) marks705)) (lambda (new-id706 marks707) (let ((t708 new-id706)) (if t708 t708 (let ((t709 (call-with-values (lambda () (search670 id702 (wrap-subst118 w1703) marks707)) (lambda (x711 . ignore710) x711)))) (if t709 t709 id702)))))))) (if (annotation? id668) (let ((id712 (let ((e713 id668)) (if (annotation? e713) (annotation-expression e713) e713)))) (let ((t714 (call-with-values (lambda () (search670 id712 (wrap-subst118 w669) (wrap-marks117 w669))) (lambda (x716 . ignore715) x716)))) (if t714 t714 id712))) (syntax-violation (quote id-var-name) "invalid id" id668))))))) (same-marks?135 (lambda (x717 y718) (let ((t719 (eq? x717 y718))) (if t719 t719 (if (not (null? x717)) (if (not (null? y718)) (if (eq? (car x717) (car y718)) (same-marks?135 (cdr x717) (cdr y718)) #f) #f) #f))))) (join-marks134 (lambda (m1720 m2721) (smart-append132 m1720 m2721))) (join-wraps133 (lambda (w1722 w2723) (let ((m1724 (wrap-marks117 w1722)) (s1725 (wrap-subst118 w1722))) (if (null? m1724) (if (null? s1725) w2723 (make-wrap116 (wrap-marks117 w2723) (smart-append132 s1725 (wrap-subst118 w2723)))) (make-wrap116 (smart-append132 m1724 (wrap-marks117 w2723)) (smart-append132 s1725 (wrap-subst118 w2723))))))) (smart-append132 (lambda (m1726 m2727) (if (null? m2727) m1726 (append m1726 m2727)))) (make-binding-wrap131 (lambda (ids728 labels729 w730) (if (null? ids728) w730 (make-wrap116 (wrap-marks117 w730) (cons (let ((labelvec731 (list->vector labels729))) (let ((n732 (vector-length labelvec731))) (let ((symnamevec733 (make-vector n732)) (marksvec734 (make-vector n732))) (begin (letrec ((f735 (lambda (ids736 i737) (if (not (null? ids736)) (call-with-values (lambda () (id-sym-name&marks115 (car ids736) w730)) (lambda (symname738 marks739) (begin (vector-set! symnamevec733 i737 symname738) (vector-set! marksvec734 i737 marks739) (f735 (cdr ids736) (fx+72 i737 1))))))))) (f735 ids728 0)) (make-ribcage121 symnamevec733 marksvec734 labelvec731))))) (wrap-subst118 w730)))))) (extend-ribcage!130 (lambda (ribcage740 id741 label742) (begin (set-ribcage-symnames!126 ribcage740 (cons (let ((e743 (syntax-object-expression99 id741))) (if (annotation? e743) (annotation-expression e743) e743)) (ribcage-symnames123 ribcage740))) (set-ribcage-marks!127 ribcage740 (cons (wrap-marks117 (syntax-object-wrap100 id741)) (ribcage-marks124 ribcage740))) (set-ribcage-labels!128 ribcage740 (cons label742 (ribcage-labels125 ribcage740)))))) (anti-mark129 (lambda (w744) (make-wrap116 (cons #f (wrap-marks117 w744)) (cons (quote shift) (wrap-subst118 w744))))) (set-ribcage-labels!128 (lambda (x745 update746) (vector-set! x745 3 update746))) (set-ribcage-marks!127 (lambda (x747 update748) (vector-set! x747 2 update748))) (set-ribcage-symnames!126 (lambda (x749 update750) (vector-set! x749 1 update750))) (ribcage-labels125 (lambda (x751) (vector-ref x751 3))) (ribcage-marks124 (lambda (x752) (vector-ref x752 2))) (ribcage-symnames123 (lambda (x753) (vector-ref x753 1))) (ribcage?122 (lambda (x754) (if (vector? x754) (if (= (vector-length x754) 4) (eq? (vector-ref x754 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames755 marks756 labels757) (vector (quote ribcage) symnames755 marks756 labels757))) (gen-labels120 (lambda (ls758) (if (null? ls758) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls758)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x759 w760) (if (syntax-object?98 x759) (values (let ((e761 (syntax-object-expression99 x759))) (if (annotation? e761) (annotation-expression e761) e761)) (join-marks134 (wrap-marks117 w760) (wrap-marks117 (syntax-object-wrap100 x759)))) (values (let ((e762 x759)) (if (annotation? e762) (annotation-expression e762) e762)) (wrap-marks117 w760))))) (id?114 (lambda (x763) (if (symbol? x763) #t (if (syntax-object?98 x763) (symbol? (let ((e764 (syntax-object-expression99 x763))) (if (annotation? e764) (annotation-expression e764) e764))) (if (annotation? x763) (symbol? (annotation-expression x763)) #f))))) (nonsymbol-id?113 (lambda (x765) (if (syntax-object?98 x765) (symbol? (let ((e766 (syntax-object-expression99 x765))) (if (annotation? e766) (annotation-expression e766) e766))) #f))) (global-extend112 (lambda (type767 sym768 val769) (put-global-definition-hook78 sym768 type767 val769))) (lookup111 (lambda (x770 r771 mod772) (let ((t773 (assq x770 r771))) (if t773 (cdr t773) (if (symbol? x770) (let ((t774 (get-global-definition-hook79 x770 mod772))) (if t774 t774 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r775) (if (null? r775) (quote ()) (let ((a776 (car r775))) (if (eq? (cadr a776) (quote macro)) (cons a776 (macros-only-env110 (cdr r775))) (macros-only-env110 (cdr r775))))))) (extend-var-env109 (lambda (labels777 vars778 r779) (if (null? labels777) r779 (extend-var-env109 (cdr labels777) (cdr vars778) (cons (cons (car labels777) (cons (quote lexical) (car vars778))) r779))))) (extend-env108 (lambda (labels780 bindings781 r782) (if (null? labels780) r782 (extend-env108 (cdr labels780) (cdr bindings781) (cons (cons (car labels780) (car bindings781)) r782))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x783) (if (annotation? x783) (annotation-source x783) (if (syntax-object?98 x783) (source-annotation105 (syntax-object-expression99 x783)) #f)))) (set-syntax-object-module!104 (lambda (x784 update785) (vector-set! x784 3 update785))) (set-syntax-object-wrap!103 (lambda (x786 update787) (vector-set! x786 2 update787))) (set-syntax-object-expression!102 (lambda (x788 update789) (vector-set! x788 1 update789))) (syntax-object-module101 (lambda (x790) (vector-ref x790 3))) (syntax-object-wrap100 (lambda (x791) (vector-ref x791 2))) (syntax-object-expression99 (lambda (x792) (vector-ref x792 1))) (syntax-object?98 (lambda (x793) (if (vector? x793) (if (= (vector-length x793) 4) (eq? (vector-ref x793 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression794 wrap795 module796) (vector (quote syntax-object) expression794 wrap795 module796))) (build-letrec96 (lambda (src797 ids798 vars799 val-exps800 body-exp801) (if (null? vars799) body-exp801 (let ((atom-key802 (fluid-ref *mode*71))) (if (memv atom-key802 (quote (c))) (begin (for-each maybe-name-value!88 ids798 val-exps800) ((@ (language tree-il) make-letrec) src797 ids798 vars799 val-exps800 body-exp801)) (list (quote letrec) (map list vars799 val-exps800) body-exp801)))))) (build-named-let95 (lambda (src803 ids804 vars805 val-exps806 body-exp807) (let ((f808 (car vars805)) (f-name809 (car ids804)) (vars810 (cdr vars805)) (ids811 (cdr ids804))) (let ((atom-key812 (fluid-ref *mode*71))) (if (memv atom-key812 (quote (c))) (let ((proc813 (build-lambda90 src803 ids811 vars810 #f body-exp807))) (begin (maybe-name-value!88 f-name809 proc813) (for-each maybe-name-value!88 ids811 val-exps806) ((@ (language tree-il) make-letrec) src803 (list f-name809) (list f808) (list proc813) (build-application81 src803 (build-lexical-reference83 (quote fun) src803 f-name809 f808) val-exps806)))) (list (quote let) f808 (map list vars810 val-exps806) body-exp807)))))) (build-let94 (lambda (src814 ids815 vars816 val-exps817 body-exp818) (if (null? vars816) body-exp818 (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) (begin (for-each maybe-name-value!88 ids815 val-exps817) ((@ (language tree-il) make-let) src814 ids815 vars816 val-exps817 body-exp818)) (list (quote let) (map list vars816 val-exps817) body-exp818)))))) (build-sequence93 (lambda (src820 exps821) (if (null? (cdr exps821)) (car exps821) (let ((atom-key822 (fluid-ref *mode*71))) (if (memv atom-key822 (quote (c))) ((@ (language tree-il) make-sequence) src820 exps821) (cons (quote begin) exps821)))))) (build-data92 (lambda (src823 exp824) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-const) src823 exp824) (if (if (self-evaluating? exp824) (not (vector? exp824)) #f) exp824 (list (quote quote) exp824)))))) (build-primref91 (lambda (src826 name827) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key828 (fluid-ref *mode*71))) (if (memv atom-key828 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src826 name827) name827)) (let ((atom-key829 (fluid-ref *mode*71))) (if (memv atom-key829 (quote (c))) ((@ (language tree-il) make-module-ref) src826 (quote (guile)) name827 #f) (list (quote @@) (quote (guile)) name827)))))) (build-lambda90 (lambda (src830 ids831 vars832 docstring833 exp834) (let ((atom-key835 (fluid-ref *mode*71))) (if (memv atom-key835 (quote (c))) ((@ (language tree-il) make-lambda) src830 ids831 vars832 (if docstring833 (list (cons (quote documentation) docstring833)) (quote ())) exp834) (cons (quote lambda) (cons vars832 (append (if docstring833 (list docstring833) (quote ())) (list exp834)))))))) (build-global-definition89 (lambda (source836 var837 exp838) (let ((atom-key839 (fluid-ref *mode*71))) (if (memv atom-key839 (quote (c))) (begin (maybe-name-value!88 var837 exp838) ((@ (language tree-il) make-toplevel-define) source836 var837 exp838)) (list (quote define) var837 exp838))))) (maybe-name-value!88 (lambda (name840 val841) (if ((@ (language tree-il) lambda?) val841) (let ((meta842 ((@ (language tree-il) lambda-meta) val841))) (if (not (assq (quote name) meta842)) ((setter (@ (language tree-il) lambda-meta)) val841 (acons (quote name) name840 meta842))))))) (build-global-assignment87 (lambda (source843 var844 exp845 mod846) (analyze-variable85 mod846 var844 (lambda (mod847 var848 public?849) (let ((atom-key850 (fluid-ref *mode*71))) (if (memv atom-key850 (quote (c))) ((@ (language tree-il) make-module-set) source843 mod847 var848 public?849 exp845) (list (quote set!) (list (if public?849 (quote @) (quote @@)) mod847 var848) exp845)))) (lambda (var851) (let ((atom-key852 (fluid-ref *mode*71))) (if (memv atom-key852 (quote (c))) ((@ (language tree-il) make-toplevel-set) source843 var851 exp845) (list (quote set!) var851 exp845))))))) (build-global-reference86 (lambda (source853 var854 mod855) (analyze-variable85 mod855 var854 (lambda (mod856 var857 public?858) (let ((atom-key859 (fluid-ref *mode*71))) (if (memv atom-key859 (quote (c))) ((@ (language tree-il) make-module-ref) source853 mod856 var857 public?858) (list (if public?858 (quote @) (quote @@)) mod856 var857)))) (lambda (var860) (let ((atom-key861 (fluid-ref *mode*71))) (if (memv atom-key861 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source853 var860) var860)))))) (analyze-variable85 (lambda (mod862 var863 modref-cont864 bare-cont865) (if (not mod862) (bare-cont865 var863) (let ((kind866 (car mod862)) (mod867 (cdr mod862))) (if (memv kind866 (quote (public))) (modref-cont864 mod867 var863 #t) (if (memv kind866 (quote (private))) (if (not (equal? mod867 (module-name (current-module)))) (modref-cont864 mod867 var863 #f) (bare-cont865 var863)) (if (memv kind866 (quote (bare))) (bare-cont865 var863) (if (memv kind866 (quote (hygiene))) (if (if (not (equal? mod867 (module-name (current-module)))) (module-variable (resolve-module mod867) var863) #f) (modref-cont864 mod867 var863 #f) (bare-cont865 var863)) (syntax-violation #f "bad module kind" var863 mod867))))))))) (build-lexical-assignment84 (lambda (source868 name869 var870 exp871) (let ((atom-key872 (fluid-ref *mode*71))) (if (memv atom-key872 (quote (c))) ((@ (language tree-il) make-lexical-set) source868 name869 var870 exp871) (list (quote set!) var870 exp871))))) (build-lexical-reference83 (lambda (type873 source874 name875 var876) (let ((atom-key877 (fluid-ref *mode*71))) (if (memv atom-key877 (quote (c))) ((@ (language tree-il) make-lexical-ref) source874 name875 var876) var876)))) (build-conditional82 (lambda (source878 test-exp879 then-exp880 else-exp881) (let ((atom-key882 (fluid-ref *mode*71))) (if (memv atom-key882 (quote (c))) ((@ (language tree-il) make-conditional) source878 test-exp879 then-exp880 else-exp881) (if (equal? else-exp881 (quote (if #f #f))) (list (quote if) test-exp879 then-exp880) (list (quote if) test-exp879 then-exp880 else-exp881)))))) (build-application81 (lambda (source883 fun-exp884 arg-exps885) (let ((atom-key886 (fluid-ref *mode*71))) (if (memv atom-key886 (quote (c))) ((@ (language tree-il) make-application) source883 fun-exp884 arg-exps885) (cons fun-exp884 arg-exps885))))) (build-void80 (lambda (source887) (let ((atom-key888 (fluid-ref *mode*71))) (if (memv atom-key888 (quote (c))) ((@ (language tree-il) make-void) source887) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol889 module890) (begin (if (if (not module890) (current-module) #f) (warn "module system is booted, we should have a module" symbol889)) (let ((v891 (module-variable (if module890 (resolve-module (cdr module890)) (current-module)) symbol889))) (if v891 (if (variable-bound? v891) (let ((val892 (variable-ref v891))) (if (macro? val892) (if (syncase-macro-type val892) (cons (syncase-macro-type val892) (syncase-macro-binding val892)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol893 type894 val895) (let ((existing896 (let ((v897 (module-variable (current-module) symbol893))) (if v897 (if (variable-bound? v897) (let ((val898 (variable-ref v897))) (if (macro? val898) (if (not (syncase-macro-type val898)) val898 #f) #f)) #f) #f)))) (module-define! (current-module) symbol893 (if existing896 (make-extended-syncase-macro existing896 type894 val895) (make-syncase-macro type894 val895)))))) (local-eval-hook77 (lambda (x899 mod900) (primitive-eval (list noexpand70 (let ((atom-key901 (fluid-ref *mode*71))) (if (memv atom-key901 (quote (c))) ((@ (language tree-il) tree-il->scheme) x899) x899)))))) (top-level-eval-hook76 (lambda (x902 mod903) (primitive-eval (list noexpand70 (let ((atom-key904 (fluid-ref *mode*71))) (if (memv atom-key904 (quote (c))) ((@ (language tree-il) tree-il->scheme) x902) x902)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e905 r906 w907 s908 mod909) ((lambda (tmp910) ((lambda (tmp911) (if (if tmp911 (apply (lambda (_912 var913 val914 e1915 e2916) (valid-bound-ids?139 var913)) tmp911) #f) (apply (lambda (_918 var919 val920 e1921 e2922) (let ((names923 (map (lambda (x924) (id-var-name136 x924 w907)) var919))) (begin (for-each (lambda (id926 n927) (let ((atom-key928 (binding-type106 (lookup111 n927 r906 mod909)))) (if (memv atom-key928 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e905 (source-wrap143 id926 w907 s908 mod909))))) var919 names923) (chi-body154 (cons e1921 e2922) (source-wrap143 e905 w907 s908 mod909) (extend-env108 names923 (let ((trans-r931 (macros-only-env110 r906))) (map (lambda (x932) (cons (quote macro) (eval-local-transformer157 (chi150 x932 trans-r931 w907 mod909) mod909))) val920)) r906) w907 mod909)))) tmp911) ((lambda (_934) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e905 w907 s908 mod909))) tmp910))) ($sc-dispatch tmp910 (quote (any #(each (any any)) any . each-any))))) e905))) (global-extend112 (quote core) (quote quote) (lambda (e935 r936 w937 s938 mod939) ((lambda (tmp940) ((lambda (tmp941) (if tmp941 (apply (lambda (_942 e943) (build-data92 s938 (strip161 e943 w937))) tmp941) ((lambda (_944) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e935 w937 s938 mod939))) tmp940))) ($sc-dispatch tmp940 (quote (any any))))) e935))) (global-extend112 (quote core) (quote syntax) (letrec ((regen952 (lambda (x953) (let ((atom-key954 (car x953))) (if (memv atom-key954 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x953) (cadr x953)) (if (memv atom-key954 (quote (primitive))) (build-primref91 #f (cadr x953)) (if (memv atom-key954 (quote (quote))) (build-data92 #f (cadr x953)) (if (memv atom-key954 (quote (lambda))) (build-lambda90 #f (cadr x953) (cadr x953) #f (regen952 (caddr x953))) (if (memv atom-key954 (quote (map))) (let ((ls955 (map regen952 (cdr x953)))) (build-application81 #f (build-primref91 #f (quote map)) ls955)) (build-application81 #f (build-primref91 #f (car x953)) (map regen952 (cdr x953))))))))))) (gen-vector951 (lambda (x956) (if (eq? (car x956) (quote list)) (cons (quote vector) (cdr x956)) (if (eq? (car x956) (quote quote)) (list (quote quote) (list->vector (cadr x956))) (list (quote list->vector) x956))))) (gen-append950 (lambda (x957 y958) (if (equal? y958 (quote (quote ()))) x957 (list (quote append) x957 y958)))) (gen-cons949 (lambda (x959 y960) (let ((atom-key961 (car y960))) (if (memv atom-key961 (quote (quote))) (if (eq? (car x959) (quote quote)) (list (quote quote) (cons (cadr x959) (cadr y960))) (if (eq? (cadr y960) (quote ())) (list (quote list) x959) (list (quote cons) x959 y960))) (if (memv atom-key961 (quote (list))) (cons (quote list) (cons x959 (cdr y960))) (list (quote cons) x959 y960)))))) (gen-map948 (lambda (e962 map-env963) (let ((formals964 (map cdr map-env963)) (actuals965 (map (lambda (x966) (list (quote ref) (car x966))) map-env963))) (if (eq? (car e962) (quote ref)) (car actuals965) (if (and-map (lambda (x967) (if (eq? (car x967) (quote ref)) (memq (cadr x967) formals964) #f)) (cdr e962)) (cons (quote map) (cons (list (quote primitive) (car e962)) (map (let ((r968 (map cons formals964 actuals965))) (lambda (x969) (cdr (assq (cadr x969) r968)))) (cdr e962)))) (cons (quote map) (cons (list (quote lambda) formals964 e962) actuals965))))))) (gen-mappend947 (lambda (e970 map-env971) (list (quote apply) (quote (primitive append)) (gen-map948 e970 map-env971)))) (gen-ref946 (lambda (src972 var973 level974 maps975) (if (fx=74 level974 0) (values var973 maps975) (if (null? maps975) (syntax-violation (quote syntax) "missing ellipsis" src972) (call-with-values (lambda () (gen-ref946 src972 var973 (fx-73 level974 1) (cdr maps975))) (lambda (outer-var976 outer-maps977) (let ((b978 (assq outer-var976 (car maps975)))) (if b978 (values (cdr b978) maps975) (let ((inner-var979 (gen-var162 (quote tmp)))) (values inner-var979 (cons (cons (cons outer-var976 inner-var979) (car maps975)) outer-maps977))))))))))) (gen-syntax945 (lambda (src980 e981 r982 maps983 ellipsis?984 mod985) (if (id?114 e981) (let ((label986 (id-var-name136 e981 (quote (()))))) (let ((b987 (lookup111 label986 r982 mod985))) (if (eq? (binding-type106 b987) (quote syntax)) (call-with-values (lambda () (let ((var.lev988 (binding-value107 b987))) (gen-ref946 src980 (car var.lev988) (cdr var.lev988) maps983))) (lambda (var989 maps990) (values (list (quote ref) var989) maps990))) (if (ellipsis?984 e981) (syntax-violation (quote syntax) "misplaced ellipsis" src980) (values (list (quote quote) e981) maps983))))) ((lambda (tmp991) ((lambda (tmp992) (if (if tmp992 (apply (lambda (dots993 e994) (ellipsis?984 dots993)) tmp992) #f) (apply (lambda (dots995 e996) (gen-syntax945 src980 e996 r982 maps983 (lambda (x997) #f) mod985)) tmp992) ((lambda (tmp998) (if (if tmp998 (apply (lambda (x999 dots1000 y1001) (ellipsis?984 dots1000)) tmp998) #f) (apply (lambda (x1002 dots1003 y1004) (letrec ((f1005 (lambda (y1006 k1007) ((lambda (tmp1011) ((lambda (tmp1012) (if (if tmp1012 (apply (lambda (dots1013 y1014) (ellipsis?984 dots1013)) tmp1012) #f) (apply (lambda (dots1015 y1016) (f1005 y1016 (lambda (maps1017) (call-with-values (lambda () (k1007 (cons (quote ()) maps1017))) (lambda (x1018 maps1019) (if (null? (car maps1019)) (syntax-violation (quote syntax) "extra ellipsis" src980) (values (gen-mappend947 x1018 (car maps1019)) (cdr maps1019)))))))) tmp1012) ((lambda (_1020) (call-with-values (lambda () (gen-syntax945 src980 y1006 r982 maps983 ellipsis?984 mod985)) (lambda (y1021 maps1022) (call-with-values (lambda () (k1007 maps1022)) (lambda (x1023 maps1024) (values (gen-append950 x1023 y1021) maps1024)))))) tmp1011))) ($sc-dispatch tmp1011 (quote (any . any))))) y1006)))) (f1005 y1004 (lambda (maps1008) (call-with-values (lambda () (gen-syntax945 src980 x1002 r982 (cons (quote ()) maps1008) ellipsis?984 mod985)) (lambda (x1009 maps1010) (if (null? (car maps1010)) (syntax-violation (quote syntax) "extra ellipsis" src980) (values (gen-map948 x1009 (car maps1010)) (cdr maps1010))))))))) tmp998) ((lambda (tmp1025) (if tmp1025 (apply (lambda (x1026 y1027) (call-with-values (lambda () (gen-syntax945 src980 x1026 r982 maps983 ellipsis?984 mod985)) (lambda (x1028 maps1029) (call-with-values (lambda () (gen-syntax945 src980 y1027 r982 maps1029 ellipsis?984 mod985)) (lambda (y1030 maps1031) (values (gen-cons949 x1028 y1030) maps1031)))))) tmp1025) ((lambda (tmp1032) (if tmp1032 (apply (lambda (e11033 e21034) (call-with-values (lambda () (gen-syntax945 src980 (cons e11033 e21034) r982 maps983 ellipsis?984 mod985)) (lambda (e1036 maps1037) (values (gen-vector951 e1036) maps1037)))) tmp1032) ((lambda (_1038) (values (list (quote quote) e981) maps983)) tmp991))) ($sc-dispatch tmp991 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp991 (quote (any . any)))))) ($sc-dispatch tmp991 (quote (any any . any)))))) ($sc-dispatch tmp991 (quote (any any))))) e981))))) (lambda (e1039 r1040 w1041 s1042 mod1043) (let ((e1044 (source-wrap143 e1039 w1041 s1042 mod1043))) ((lambda (tmp1045) ((lambda (tmp1046) (if tmp1046 (apply (lambda (_1047 x1048) (call-with-values (lambda () (gen-syntax945 e1044 x1048 r1040 (quote ()) ellipsis?159 mod1043)) (lambda (e1049 maps1050) (regen952 e1049)))) tmp1046) ((lambda (_1051) (syntax-violation (quote syntax) "bad `syntax' form" e1044)) tmp1045))) ($sc-dispatch tmp1045 (quote (any any))))) e1044))))) (global-extend112 (quote core) (quote lambda) (lambda (e1052 r1053 w1054 s1055 mod1056) ((lambda (tmp1057) ((lambda (tmp1058) (if tmp1058 (apply (lambda (_1059 c1060) (chi-lambda-clause155 (source-wrap143 e1052 w1054 s1055 mod1056) #f c1060 r1053 w1054 mod1056 (lambda (names1061 vars1062 docstring1063 body1064) (build-lambda90 s1055 names1061 vars1062 docstring1063 body1064)))) tmp1058) (syntax-violation #f "source expression failed to match any pattern" tmp1057))) ($sc-dispatch tmp1057 (quote (any . any))))) e1052))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1065 (lambda (e1066 r1067 w1068 s1069 mod1070 constructor1071 ids1072 vals1073 exps1074) (if (not (valid-bound-ids?139 ids1072)) (syntax-violation (quote let) "duplicate bound variable" e1066) (let ((labels1075 (gen-labels120 ids1072)) (new-vars1076 (map gen-var162 ids1072))) (let ((nw1077 (make-binding-wrap131 ids1072 labels1075 w1068)) (nr1078 (extend-var-env109 labels1075 new-vars1076 r1067))) (constructor1071 s1069 (map syntax->datum ids1072) new-vars1076 (map (lambda (x1079) (chi150 x1079 r1067 w1068 mod1070)) vals1073) (chi-body154 exps1074 (source-wrap143 e1066 nw1077 s1069 mod1070) nr1078 nw1077 mod1070)))))))) (lambda (e1080 r1081 w1082 s1083 mod1084) ((lambda (tmp1085) ((lambda (tmp1086) (if (if tmp1086 (apply (lambda (_1087 id1088 val1089 e11090 e21091) (and-map id?114 id1088)) tmp1086) #f) (apply (lambda (_1093 id1094 val1095 e11096 e21097) (chi-let1065 e1080 r1081 w1082 s1083 mod1084 build-let94 id1094 val1095 (cons e11096 e21097))) tmp1086) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (_1102 f1103 id1104 val1105 e11106 e21107) (if (id?114 f1103) (and-map id?114 id1104) #f)) tmp1101) #f) (apply (lambda (_1109 f1110 id1111 val1112 e11113 e21114) (chi-let1065 e1080 r1081 w1082 s1083 mod1084 build-named-let95 (cons f1110 id1111) val1112 (cons e11113 e21114))) tmp1101) ((lambda (_1118) (syntax-violation (quote let) "bad let" (source-wrap143 e1080 w1082 s1083 mod1084))) tmp1085))) ($sc-dispatch tmp1085 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1085 (quote (any #(each (any any)) any . each-any))))) e1080)))) (global-extend112 (quote core) (quote letrec) (lambda (e1119 r1120 w1121 s1122 mod1123) ((lambda (tmp1124) ((lambda (tmp1125) (if (if tmp1125 (apply (lambda (_1126 id1127 val1128 e11129 e21130) (and-map id?114 id1127)) tmp1125) #f) (apply (lambda (_1132 id1133 val1134 e11135 e21136) (let ((ids1137 id1133)) (if (not (valid-bound-ids?139 ids1137)) (syntax-violation (quote letrec) "duplicate bound variable" e1119) (let ((labels1139 (gen-labels120 ids1137)) (new-vars1140 (map gen-var162 ids1137))) (let ((w1141 (make-binding-wrap131 ids1137 labels1139 w1121)) (r1142 (extend-var-env109 labels1139 new-vars1140 r1120))) (build-letrec96 s1122 (map syntax->datum ids1137) new-vars1140 (map (lambda (x1143) (chi150 x1143 r1142 w1141 mod1123)) val1134) (chi-body154 (cons e11135 e21136) (source-wrap143 e1119 w1141 s1122 mod1123) r1142 w1141 mod1123))))))) tmp1125) ((lambda (_1146) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1119 w1121 s1122 mod1123))) tmp1124))) ($sc-dispatch tmp1124 (quote (any #(each (any any)) any . each-any))))) e1119))) (global-extend112 (quote core) (quote set!) (lambda (e1147 r1148 w1149 s1150 mod1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 id1155 val1156) (id?114 id1155)) tmp1153) #f) (apply (lambda (_1157 id1158 val1159) (let ((val1160 (chi150 val1159 r1148 w1149 mod1151)) (n1161 (id-var-name136 id1158 w1149))) (let ((b1162 (lookup111 n1161 r1148 mod1151))) (let ((atom-key1163 (binding-type106 b1162))) (if (memv atom-key1163 (quote (lexical))) (build-lexical-assignment84 s1150 (syntax->datum id1158) (binding-value107 b1162) val1160) (if (memv atom-key1163 (quote (global))) (build-global-assignment87 s1150 n1161 val1160 mod1151) (if (memv atom-key1163 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1158 w1149 mod1151)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1147 w1149 s1150 mod1151))))))))) tmp1153) ((lambda (tmp1164) (if tmp1164 (apply (lambda (_1165 head1166 tail1167 val1168) (call-with-values (lambda () (syntax-type148 head1166 r1148 (quote (())) #f #f mod1151)) (lambda (type1169 value1170 ee1171 ww1172 ss1173 modmod1174) (if (memv type1169 (quote (module-ref))) (let ((val1175 (chi150 val1168 r1148 w1149 mod1151))) (call-with-values (lambda () (value1170 (cons head1166 tail1167))) (lambda (id1177 mod1178) (build-global-assignment87 s1150 id1177 val1175 mod1178)))) (build-application81 s1150 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1166) r1148 w1149 mod1151) (map (lambda (e1179) (chi150 e1179 r1148 w1149 mod1151)) (append tail1167 (list val1168)))))))) tmp1164) ((lambda (_1181) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1147 w1149 s1150 mod1151))) tmp1152))) ($sc-dispatch tmp1152 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1152 (quote (any any any))))) e1147))) (global-extend112 (quote module-ref) (quote @) (lambda (e1182) ((lambda (tmp1183) ((lambda (tmp1184) (if (if tmp1184 (apply (lambda (_1185 mod1186 id1187) (if (and-map id?114 mod1186) (id?114 id1187) #f)) tmp1184) #f) (apply (lambda (_1189 mod1190 id1191) (values (syntax->datum id1191) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1190)))) tmp1184) (syntax-violation #f "source expression failed to match any pattern" tmp1183))) ($sc-dispatch tmp1183 (quote (any each-any any))))) e1182))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1193) ((lambda (tmp1194) ((lambda (tmp1195) (if (if tmp1195 (apply (lambda (_1196 mod1197 id1198) (if (and-map id?114 mod1197) (id?114 id1198) #f)) tmp1195) #f) (apply (lambda (_1200 mod1201 id1202) (values (syntax->datum id1202) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1201)))) tmp1195) (syntax-violation #f "source expression failed to match any pattern" tmp1194))) ($sc-dispatch tmp1194 (quote (any each-any any))))) e1193))) (global-extend112 (quote core) (quote if) (lambda (e1204 r1205 w1206 s1207 mod1208) ((lambda (tmp1209) ((lambda (tmp1210) (if tmp1210 (apply (lambda (_1211 test1212 then1213) (build-conditional82 s1207 (chi150 test1212 r1205 w1206 mod1208) (chi150 then1213 r1205 w1206 mod1208) (build-void80 #f))) tmp1210) ((lambda (tmp1214) (if tmp1214 (apply (lambda (_1215 test1216 then1217 else1218) (build-conditional82 s1207 (chi150 test1216 r1205 w1206 mod1208) (chi150 then1217 r1205 w1206 mod1208) (chi150 else1218 r1205 w1206 mod1208))) tmp1214) (syntax-violation #f "source expression failed to match any pattern" tmp1209))) ($sc-dispatch tmp1209 (quote (any any any any)))))) ($sc-dispatch tmp1209 (quote (any any any))))) e1204))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1222 (lambda (x1223 keys1224 clauses1225 r1226 mod1227) (if (null? clauses1225) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1223)) ((lambda (tmp1228) ((lambda (tmp1229) (if tmp1229 (apply (lambda (pat1230 exp1231) (if (if (id?114 pat1230) (and-map (lambda (x1232) (not (free-id=?137 pat1230 x1232))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1224)) #f) (let ((labels1233 (list (gen-label119))) (var1234 (gen-var162 pat1230))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1230)) (list var1234) #f (chi150 exp1231 (extend-env108 labels1233 (list (cons (quote syntax) (cons var1234 0))) r1226) (make-binding-wrap131 (list pat1230) labels1233 (quote (()))) mod1227)) (list x1223))) (gen-clause1221 x1223 keys1224 (cdr clauses1225) r1226 pat1230 #t exp1231 mod1227))) tmp1229) ((lambda (tmp1235) (if tmp1235 (apply (lambda (pat1236 fender1237 exp1238) (gen-clause1221 x1223 keys1224 (cdr clauses1225) r1226 pat1236 fender1237 exp1238 mod1227)) tmp1235) ((lambda (_1239) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1225))) tmp1228))) ($sc-dispatch tmp1228 (quote (any any any)))))) ($sc-dispatch tmp1228 (quote (any any))))) (car clauses1225))))) (gen-clause1221 (lambda (x1240 keys1241 clauses1242 r1243 pat1244 fender1245 exp1246 mod1247) (call-with-values (lambda () (convert-pattern1219 pat1244 keys1241)) (lambda (p1248 pvars1249) (if (not (distinct-bound-ids?140 (map car pvars1249))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1244) (if (not (and-map (lambda (x1250) (not (ellipsis?159 (car x1250)))) pvars1249)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1244) (let ((y1251 (gen-var162 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1251) #f (let ((y1252 (build-lexical-reference83 (quote value) #f (quote tmp) y1251))) (build-conditional82 #f ((lambda (tmp1253) ((lambda (tmp1254) (if tmp1254 (apply (lambda () y1252) tmp1254) ((lambda (_1255) (build-conditional82 #f y1252 (build-dispatch-call1220 pvars1249 fender1245 y1252 r1243 mod1247) (build-data92 #f #f))) tmp1253))) ($sc-dispatch tmp1253 (quote #(atom #t))))) fender1245) (build-dispatch-call1220 pvars1249 exp1246 y1252 r1243 mod1247) (gen-syntax-case1222 x1240 keys1241 clauses1242 r1243 mod1247)))) (list (if (eq? p1248 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1240)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1240 (build-data92 #f p1248))))))))))))) (build-dispatch-call1220 (lambda (pvars1256 exp1257 y1258 r1259 mod1260) (let ((ids1261 (map car pvars1256)) (levels1262 (map cdr pvars1256))) (let ((labels1263 (gen-labels120 ids1261)) (new-vars1264 (map gen-var162 ids1261))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1261) new-vars1264 #f (chi150 exp1257 (extend-env108 labels1263 (map (lambda (var1265 level1266) (cons (quote syntax) (cons var1265 level1266))) new-vars1264 (map cdr pvars1256)) r1259) (make-binding-wrap131 ids1261 labels1263 (quote (()))) mod1260)) y1258)))))) (convert-pattern1219 (lambda (pattern1267 keys1268) (letrec ((cvt1269 (lambda (p1270 n1271 ids1272) (if (id?114 p1270) (if (bound-id-member?141 p1270 keys1268) (values (vector (quote free-id) p1270) ids1272) (values (quote any) (cons (cons p1270 n1271) ids1272))) ((lambda (tmp1273) ((lambda (tmp1274) (if (if tmp1274 (apply (lambda (x1275 dots1276) (ellipsis?159 dots1276)) tmp1274) #f) (apply (lambda (x1277 dots1278) (call-with-values (lambda () (cvt1269 x1277 (fx+72 n1271 1) ids1272)) (lambda (p1279 ids1280) (values (if (eq? p1279 (quote any)) (quote each-any) (vector (quote each) p1279)) ids1280)))) tmp1274) ((lambda (tmp1281) (if tmp1281 (apply (lambda (x1282 y1283) (call-with-values (lambda () (cvt1269 y1283 n1271 ids1272)) (lambda (y1284 ids1285) (call-with-values (lambda () (cvt1269 x1282 n1271 ids1285)) (lambda (x1286 ids1287) (values (cons x1286 y1284) ids1287)))))) tmp1281) ((lambda (tmp1288) (if tmp1288 (apply (lambda () (values (quote ()) ids1272)) tmp1288) ((lambda (tmp1289) (if tmp1289 (apply (lambda (x1290) (call-with-values (lambda () (cvt1269 x1290 n1271 ids1272)) (lambda (p1292 ids1293) (values (vector (quote vector) p1292) ids1293)))) tmp1289) ((lambda (x1294) (values (vector (quote atom) (strip161 p1270 (quote (())))) ids1272)) tmp1273))) ($sc-dispatch tmp1273 (quote #(vector each-any)))))) ($sc-dispatch tmp1273 (quote ()))))) ($sc-dispatch tmp1273 (quote (any . any)))))) ($sc-dispatch tmp1273 (quote (any any))))) p1270))))) (cvt1269 pattern1267 0 (quote ())))))) (lambda (e1295 r1296 w1297 s1298 mod1299) (let ((e1300 (source-wrap143 e1295 w1297 s1298 mod1299))) ((lambda (tmp1301) ((lambda (tmp1302) (if tmp1302 (apply (lambda (_1303 val1304 key1305 m1306) (if (and-map (lambda (x1307) (if (id?114 x1307) (not (ellipsis?159 x1307)) #f)) key1305) (let ((x1309 (gen-var162 (quote tmp)))) (build-application81 s1298 (build-lambda90 #f (list (quote tmp)) (list x1309) #f (gen-syntax-case1222 (build-lexical-reference83 (quote value) #f (quote tmp) x1309) key1305 m1306 r1296 mod1299)) (list (chi150 val1304 r1296 (quote (())) mod1299)))) (syntax-violation (quote syntax-case) "invalid literals list" e1300))) tmp1302) (syntax-violation #f "source expression failed to match any pattern" tmp1301))) ($sc-dispatch tmp1301 (quote (any any each-any . each-any))))) e1300))))) (set! sc-expand (lambda (x1313 . rest1312) (if (if (pair? x1313) (equal? (car x1313) noexpand70) #f) (cadr x1313) (let ((m1314 (if (null? rest1312) (quote e) (car rest1312))) (esew1315 (if (let ((t1316 (null? rest1312))) (if t1316 t1316 (null? (cdr rest1312)))) (quote (eval)) (cadr rest1312)))) (with-fluid* *mode*71 m1314 (lambda () (chi-top149 x1313 (quote ()) (quote ((top))) m1314 esew1315 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1317) (nonsymbol-id?113 x1317))) (set! datum->syntax (lambda (id1318 datum1319) (make-syntax-object97 datum1319 (syntax-object-wrap100 id1318) #f))) (set! syntax->datum (lambda (x1320) (strip161 x1320 (quote (()))))) (set! generate-temporaries (lambda (ls1321) (begin (let ((x1322 ls1321)) (if (not (list? x1322)) (syntax-violation (quote generate-temporaries) "invalid argument" x1322))) (map (lambda (x1323) (wrap142 (gensym) (quote ((top))) #f)) ls1321)))) (set! free-identifier=? (lambda (x1324 y1325) (begin (let ((x1326 x1324)) (if (not (nonsymbol-id?113 x1326)) (syntax-violation (quote free-identifier=?) "invalid argument" x1326))) (let ((x1327 y1325)) (if (not (nonsymbol-id?113 x1327)) (syntax-violation (quote free-identifier=?) "invalid argument" x1327))) (free-id=?137 x1324 y1325)))) (set! bound-identifier=? (lambda (x1328 y1329) (begin (let ((x1330 x1328)) (if (not (nonsymbol-id?113 x1330)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1330))) (let ((x1331 y1329)) (if (not (nonsymbol-id?113 x1331)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1331))) (bound-id=?138 x1328 y1329)))) (set! syntax-violation (lambda (who1335 message1334 form1333 . subform1332) (begin (let ((x1336 who1335)) (if (not ((lambda (x1337) (let ((t1338 (not x1337))) (if t1338 t1338 (let ((t1339 (string? x1337))) (if t1339 t1339 (symbol? x1337)))))) x1336)) (syntax-violation (quote syntax-violation) "invalid argument" x1336))) (let ((x1340 message1334)) (if (not (string? x1340)) (syntax-violation (quote syntax-violation) "invalid argument" x1340))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1335 "~a: " "") "~a " (if (null? subform1332) "in ~a" "in subform `~s' of `~s'")) (let ((tail1341 (cons message1334 (map (lambda (x1342) (strip161 x1342 (quote (())))) (append subform1332 (list form1333)))))) (if who1335 (cons who1335 tail1341) tail1341)) #f)))) (letrec ((match1347 (lambda (e1348 p1349 w1350 r1351 mod1352) (if (not r1351) #f (if (eq? p1349 (quote any)) (cons (wrap142 e1348 w1350 mod1352) r1351) (if (syntax-object?98 e1348) (match*1346 (let ((e1353 (syntax-object-expression99 e1348))) (if (annotation? e1353) (annotation-expression e1353) e1353)) p1349 (join-wraps133 w1350 (syntax-object-wrap100 e1348)) r1351 (syntax-object-module101 e1348)) (match*1346 (let ((e1354 e1348)) (if (annotation? e1354) (annotation-expression e1354) e1354)) p1349 w1350 r1351 mod1352)))))) (match*1346 (lambda (e1355 p1356 w1357 r1358 mod1359) (if (null? p1356) (if (null? e1355) r1358 #f) (if (pair? p1356) (if (pair? e1355) (match1347 (car e1355) (car p1356) w1357 (match1347 (cdr e1355) (cdr p1356) w1357 r1358 mod1359) mod1359) #f) (if (eq? p1356 (quote each-any)) (let ((l1360 (match-each-any1344 e1355 w1357 mod1359))) (if l1360 (cons l1360 r1358) #f)) (let ((atom-key1361 (vector-ref p1356 0))) (if (memv atom-key1361 (quote (each))) (if (null? e1355) (match-empty1345 (vector-ref p1356 1) r1358) (let ((l1362 (match-each1343 e1355 (vector-ref p1356 1) w1357 mod1359))) (if l1362 (letrec ((collect1363 (lambda (l1364) (if (null? (car l1364)) r1358 (cons (map car l1364) (collect1363 (map cdr l1364))))))) (collect1363 l1362)) #f))) (if (memv atom-key1361 (quote (free-id))) (if (id?114 e1355) (if (free-id=?137 (wrap142 e1355 w1357 mod1359) (vector-ref p1356 1)) r1358 #f) #f) (if (memv atom-key1361 (quote (atom))) (if (equal? (vector-ref p1356 1) (strip161 e1355 w1357)) r1358 #f) (if (memv atom-key1361 (quote (vector))) (if (vector? e1355) (match1347 (vector->list e1355) (vector-ref p1356 1) w1357 r1358 mod1359) #f))))))))))) (match-empty1345 (lambda (p1365 r1366) (if (null? p1365) r1366 (if (eq? p1365 (quote any)) (cons (quote ()) r1366) (if (pair? p1365) (match-empty1345 (car p1365) (match-empty1345 (cdr p1365) r1366)) (if (eq? p1365 (quote each-any)) (cons (quote ()) r1366) (let ((atom-key1367 (vector-ref p1365 0))) (if (memv atom-key1367 (quote (each))) (match-empty1345 (vector-ref p1365 1) r1366) (if (memv atom-key1367 (quote (free-id atom))) r1366 (if (memv atom-key1367 (quote (vector))) (match-empty1345 (vector-ref p1365 1) r1366))))))))))) (match-each-any1344 (lambda (e1368 w1369 mod1370) (if (annotation? e1368) (match-each-any1344 (annotation-expression e1368) w1369 mod1370) (if (pair? e1368) (let ((l1371 (match-each-any1344 (cdr e1368) w1369 mod1370))) (if l1371 (cons (wrap142 (car e1368) w1369 mod1370) l1371) #f)) (if (null? e1368) (quote ()) (if (syntax-object?98 e1368) (match-each-any1344 (syntax-object-expression99 e1368) (join-wraps133 w1369 (syntax-object-wrap100 e1368)) mod1370) #f)))))) (match-each1343 (lambda (e1372 p1373 w1374 mod1375) (if (annotation? e1372) (match-each1343 (annotation-expression e1372) p1373 w1374 mod1375) (if (pair? e1372) (let ((first1376 (match1347 (car e1372) p1373 w1374 (quote ()) mod1375))) (if first1376 (let ((rest1377 (match-each1343 (cdr e1372) p1373 w1374 mod1375))) (if rest1377 (cons first1376 rest1377) #f)) #f)) (if (null? e1372) (quote ()) (if (syntax-object?98 e1372) (match-each1343 (syntax-object-expression99 e1372) p1373 (join-wraps133 w1374 (syntax-object-wrap100 e1372)) (syntax-object-module101 e1372)) #f))))))) (set! $sc-dispatch (lambda (e1378 p1379) (if (eq? p1379 (quote any)) (list e1378) (if (syntax-object?98 e1378) (match*1346 (let ((e1380 (syntax-object-expression99 e1378))) (if (annotation? e1380) (annotation-expression e1380) e1380)) p1379 (syntax-object-wrap100 e1378) (quote ()) (syntax-object-module101 e1378)) (match*1346 (let ((e1381 e1378)) (if (annotation? e1381) (annotation-expression e1381) e1381)) p1379 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1382) ((lambda (tmp1383) ((lambda (tmp1384) (if tmp1384 (apply (lambda (_1385 e11386 e21387) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11386 e21387))) tmp1384) ((lambda (tmp1389) (if tmp1389 (apply (lambda (_1390 out1391 in1392 e11393 e21394) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1392 (quote ()) (list out1391 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11393 e21394))))) tmp1389) ((lambda (tmp1396) (if tmp1396 (apply (lambda (_1397 out1398 in1399 e11400 e21401) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1399) (quote ()) (list out1398 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11400 e21401))))) tmp1396) (syntax-violation #f "source expression failed to match any pattern" tmp1383))) ($sc-dispatch tmp1383 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1383 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1383 (quote (any () any . each-any))))) x1382)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1405) ((lambda (tmp1406) ((lambda (tmp1407) (if tmp1407 (apply (lambda (_1408 k1409 keyword1410 pattern1411 template1412) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1409 (map (lambda (tmp1415 tmp1414) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1414) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1415))) template1412 pattern1411)))))) tmp1407) (syntax-violation #f "source expression failed to match any pattern" tmp1406))) ($sc-dispatch tmp1406 (quote (any each-any . #(each ((any . any) any))))))) x1405)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1416) ((lambda (tmp1417) ((lambda (tmp1418) (if (if tmp1418 (apply (lambda (let*1419 x1420 v1421 e11422 e21423) (and-map identifier? x1420)) tmp1418) #f) (apply (lambda (let*1425 x1426 v1427 e11428 e21429) (letrec ((f1430 (lambda (bindings1431) (if (null? bindings1431) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11428 e21429))) ((lambda (tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (body1437 binding1438) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1438) body1437)) tmp1436) (syntax-violation #f "source expression failed to match any pattern" tmp1435))) ($sc-dispatch tmp1435 (quote (any any))))) (list (f1430 (cdr bindings1431)) (car bindings1431))))))) (f1430 (map list x1426 v1427)))) tmp1418) (syntax-violation #f "source expression failed to match any pattern" tmp1417))) ($sc-dispatch tmp1417 (quote (any #(each (any any)) any . each-any))))) x1416)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1439) ((lambda (tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (_1442 var1443 init1444 step1445 e01446 e11447 c1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (step1451) ((lambda (tmp1452) ((lambda (tmp1453) (if tmp1453 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1443 init1444) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01446) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1448 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1451))))))) tmp1453) ((lambda (tmp1458) (if tmp1458 (apply (lambda (e11459 e21460) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1443 init1444) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01446 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11459 e21460)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1448 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1451))))))) tmp1458) (syntax-violation #f "source expression failed to match any pattern" tmp1452))) ($sc-dispatch tmp1452 (quote (any . each-any)))))) ($sc-dispatch tmp1452 (quote ())))) e11447)) tmp1450) (syntax-violation #f "source expression failed to match any pattern" tmp1449))) ($sc-dispatch tmp1449 (quote each-any)))) (map (lambda (v1467 s1468) ((lambda (tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda () v1467) tmp1470) ((lambda (tmp1471) (if tmp1471 (apply (lambda (e1472) e1472) tmp1471) ((lambda (_1473) (syntax-violation (quote do) "bad step expression" orig-x1439 s1468)) tmp1469))) ($sc-dispatch tmp1469 (quote (any)))))) ($sc-dispatch tmp1469 (quote ())))) s1468)) var1443 step1445))) tmp1441) (syntax-violation #f "source expression failed to match any pattern" tmp1440))) ($sc-dispatch tmp1440 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1439)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1476 (lambda (x1480 y1481) ((lambda (tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (x1484 y1485) ((lambda (tmp1486) ((lambda (tmp1487) (if tmp1487 (apply (lambda (dy1488) ((lambda (tmp1489) ((lambda (tmp1490) (if tmp1490 (apply (lambda (dx1491) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1491 dy1488))) tmp1490) ((lambda (_1492) (if (null? dy1488) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1484) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1484 y1485))) tmp1489))) ($sc-dispatch tmp1489 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1484)) tmp1487) ((lambda (tmp1493) (if tmp1493 (apply (lambda (stuff1494) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1484 stuff1494))) tmp1493) ((lambda (else1495) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1484 y1485)) tmp1486))) ($sc-dispatch tmp1486 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1486 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1485)) tmp1483) (syntax-violation #f "source expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote (any any))))) (list x1480 y1481)))) (quasiappend1477 (lambda (x1496 y1497) ((lambda (tmp1498) ((lambda (tmp1499) (if tmp1499 (apply (lambda (x1500 y1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda () x1500) tmp1503) ((lambda (_1504) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1500 y1501)) tmp1502))) ($sc-dispatch tmp1502 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1501)) tmp1499) (syntax-violation #f "source expression failed to match any pattern" tmp1498))) ($sc-dispatch tmp1498 (quote (any any))))) (list x1496 y1497)))) (quasivector1478 (lambda (x1505) ((lambda (tmp1506) ((lambda (x1507) ((lambda (tmp1508) ((lambda (tmp1509) (if tmp1509 (apply (lambda (x1510) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1510))) tmp1509) ((lambda (tmp1512) (if tmp1512 (apply (lambda (x1513) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1513)) tmp1512) ((lambda (_1515) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1507)) tmp1508))) ($sc-dispatch tmp1508 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1508 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1507)) tmp1506)) x1505))) (quasi1479 (lambda (p1516 lev1517) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (p1520) (if (= lev1517 0) p1520 (quasicons1476 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1479 (list p1520) (- lev1517 1))))) tmp1519) ((lambda (tmp1521) (if (if tmp1521 (apply (lambda (args1522) (= lev1517 0)) tmp1521) #f) (apply (lambda (args1523) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1516 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1523))) tmp1521) ((lambda (tmp1524) (if tmp1524 (apply (lambda (p1525 q1526) (if (= lev1517 0) (quasiappend1477 p1525 (quasi1479 q1526 lev1517)) (quasicons1476 (quasicons1476 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1479 (list p1525) (- lev1517 1))) (quasi1479 q1526 lev1517)))) tmp1524) ((lambda (tmp1527) (if (if tmp1527 (apply (lambda (args1528 q1529) (= lev1517 0)) tmp1527) #f) (apply (lambda (args1530 q1531) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1516 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1530))) tmp1527) ((lambda (tmp1532) (if tmp1532 (apply (lambda (p1533) (quasicons1476 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1479 (list p1533) (+ lev1517 1)))) tmp1532) ((lambda (tmp1534) (if tmp1534 (apply (lambda (p1535 q1536) (quasicons1476 (quasi1479 p1535 lev1517) (quasi1479 q1536 lev1517))) tmp1534) ((lambda (tmp1537) (if tmp1537 (apply (lambda (x1538) (quasivector1478 (quasi1479 x1538 lev1517))) tmp1537) ((lambda (p1540) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1540)) tmp1518))) ($sc-dispatch tmp1518 (quote #(vector each-any)))))) ($sc-dispatch tmp1518 (quote (any . any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1518 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1518 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1518 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1516)))) (lambda (x1541) ((lambda (tmp1542) ((lambda (tmp1543) (if tmp1543 (apply (lambda (_1544 e1545) (quasi1479 e1545 0)) tmp1543) (syntax-violation #f "source expression failed to match any pattern" tmp1542))) ($sc-dispatch tmp1542 (quote (any any))))) x1541))))) -(define include (make-syncase-macro (quote macro) (lambda (x1546) (letrec ((read-file1547 (lambda (fn1548 k1549) (let ((p1550 (open-input-file fn1548))) (letrec ((f1551 (lambda (x1552) (if (eof-object? x1552) (begin (close-input-port p1550) (quote ())) (cons (datum->syntax k1549 x1552) (f1551 (read p1550))))))) (f1551 (read p1550))))))) ((lambda (tmp1553) ((lambda (tmp1554) (if tmp1554 (apply (lambda (k1555 filename1556) (let ((fn1557 (syntax->datum filename1556))) ((lambda (tmp1558) ((lambda (tmp1559) (if tmp1559 (apply (lambda (exp1560) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1560)) tmp1559) (syntax-violation #f "source expression failed to match any pattern" tmp1558))) ($sc-dispatch tmp1558 (quote each-any)))) (read-file1547 fn1557 k1555)))) tmp1554) (syntax-violation #f "source expression failed to match any pattern" tmp1553))) ($sc-dispatch tmp1553 (quote (any any))))) x1546))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1562) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565 e1566) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1562)) tmp1564) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any))))) x1562)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply (lambda (_1570 e1571) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1567)) tmp1569) (syntax-violation #f "source expression failed to match any pattern" tmp1568))) ($sc-dispatch tmp1568 (quote (any any))))) x1567)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1572) ((lambda (tmp1573) ((lambda (tmp1574) (if tmp1574 (apply (lambda (_1575 e1576 m11577 m21578) ((lambda (tmp1579) ((lambda (body1580) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1576)) body1580)) tmp1579)) (letrec ((f1581 (lambda (clause1582 clauses1583) (if (null? clauses1583) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (e11587 e21588) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11587 e21588))) tmp1586) ((lambda (tmp1590) (if tmp1590 (apply (lambda (k1591 e11592 e21593) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1591)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11592 e21593)))) tmp1590) ((lambda (_1596) (syntax-violation (quote case) "bad clause" x1572 clause1582)) tmp1585))) ($sc-dispatch tmp1585 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1582) ((lambda (tmp1597) ((lambda (rest1598) ((lambda (tmp1599) ((lambda (tmp1600) (if tmp1600 (apply (lambda (k1601 e11602 e21603) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1601)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11602 e21603)) rest1598)) tmp1600) ((lambda (_1606) (syntax-violation (quote case) "bad clause" x1572 clause1582)) tmp1599))) ($sc-dispatch tmp1599 (quote (each-any any . each-any))))) clause1582)) tmp1597)) (f1581 (car clauses1583) (cdr clauses1583))))))) (f1581 m11577 m21578)))) tmp1574) (syntax-violation #f "source expression failed to match any pattern" tmp1573))) ($sc-dispatch tmp1573 (quote (any any any . each-any))))) x1572)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1607) ((lambda (tmp1608) ((lambda (tmp1609) (if tmp1609 (apply (lambda (_1610 e1611) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1611)) (list (cons _1610 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1611 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1609) (syntax-violation #f "source expression failed to match any pattern" tmp1608))) ($sc-dispatch tmp1608 (quote (any any))))) x1607)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars286) (letrec ((lvl287 (lambda (vars288 ls289 w290) (if (pair? vars288) (lvl287 (cdr vars288) (cons (wrap142 (car vars288) w290 #f) ls289) w290) (if (id?114 vars288) (cons (wrap142 vars288 w290 #f) ls289) (if (null? vars288) ls289 (if (syntax-object?98 vars288) (lvl287 (syntax-object-expression99 vars288) ls289 (join-wraps133 w290 (syntax-object-wrap100 vars288))) (cons vars288 ls289)))))))) (lvl287 vars286 (quote ()) (quote (())))))) (gen-var161 (lambda (id291) (let ((id292 (if (syntax-object?98 id291) (syntax-object-expression99 id291) id291))) (gensym (symbol->string id292))))) (strip160 (lambda (x293 w294) (if (memq (quote top) (wrap-marks117 w294)) x293 (letrec ((f295 (lambda (x296) (if (syntax-object?98 x296) (strip160 (syntax-object-expression99 x296) (syntax-object-wrap100 x296)) (if (pair? x296) (let ((a297 (f295 (car x296))) (d298 (f295 (cdr x296)))) (if (if (eq? a297 (car x296)) (eq? d298 (cdr x296)) #f) x296 (cons a297 d298))) (if (vector? x296) (let ((old299 (vector->list x296))) (let ((new300 (map f295 old299))) (if (and-map*17 eq? old299 new300) x296 (list->vector new300)))) x296)))))) (f295 x293))))) (ellipsis?159 (lambda (x301) (if (nonsymbol-id?113 x301) (free-id=?137 x301 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded302 mod303) (let ((p304 (local-eval-hook77 expanded302 mod303))) (if (procedure? p304) p304 (syntax-violation #f "nonprocedure transformer" p304))))) (chi-local-syntax156 (lambda (rec?305 e306 r307 w308 s309 mod310 k311) ((lambda (tmp312) ((lambda (tmp313) (if tmp313 (apply (lambda (_314 id315 val316 e1317 e2318) (let ((ids319 id315)) (if (not (valid-bound-ids?139 ids319)) (syntax-violation #f "duplicate bound keyword" e306) (let ((labels321 (gen-labels120 ids319))) (let ((new-w322 (make-binding-wrap131 ids319 labels321 w308))) (k311 (cons e1317 e2318) (extend-env108 labels321 (let ((w324 (if rec?305 new-w322 w308)) (trans-r325 (macros-only-env110 r307))) (map (lambda (x326) (cons (quote macro) (eval-local-transformer157 (chi150 x326 trans-r325 w324 mod310) mod310))) val316)) r307) new-w322 s309 mod310)))))) tmp313) ((lambda (_328) (syntax-violation #f "bad local syntax definition" (source-wrap143 e306 w308 s309 mod310))) tmp312))) ($sc-dispatch tmp312 (quote (any #(each (any any)) any . each-any))))) e306))) (chi-lambda-clause155 (lambda (e329 docstring330 c331 r332 w333 mod334 k335) ((lambda (tmp336) ((lambda (tmp337) (if (if tmp337 (apply (lambda (args338 doc339 e1340 e2341) (if (string? (syntax->datum doc339)) (not docstring330) #f)) tmp337) #f) (apply (lambda (args342 doc343 e1344 e2345) (chi-lambda-clause155 e329 doc343 (cons args342 (cons e1344 e2345)) r332 w333 mod334 k335)) tmp337) ((lambda (tmp347) (if tmp347 (apply (lambda (id348 e1349 e2350) (let ((ids351 id348)) (if (not (valid-bound-ids?139 ids351)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels353 (gen-labels120 ids351)) (new-vars354 (map gen-var161 ids351))) (k335 (map syntax->datum ids351) new-vars354 (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1349 e2350) e329 (extend-var-env109 labels353 new-vars354 r332) (make-binding-wrap131 ids351 labels353 w333) mod334)))))) tmp347) ((lambda (tmp356) (if tmp356 (apply (lambda (ids357 e1358 e2359) (let ((old-ids360 (lambda-var-list162 ids357))) (if (not (valid-bound-ids?139 old-ids360)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels361 (gen-labels120 old-ids360)) (new-vars362 (map gen-var161 old-ids360))) (k335 (letrec ((f363 (lambda (ls1364 ls2365) (if (null? ls1364) (syntax->datum ls2365) (f363 (cdr ls1364) (cons (syntax->datum (car ls1364)) ls2365)))))) (f363 (cdr old-ids360) (car old-ids360))) (letrec ((f366 (lambda (ls1367 ls2368) (if (null? ls1367) ls2368 (f366 (cdr ls1367) (cons (car ls1367) ls2368)))))) (f366 (cdr new-vars362) (car new-vars362))) (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1358 e2359) e329 (extend-var-env109 labels361 new-vars362 r332) (make-binding-wrap131 old-ids360 labels361 w333) mod334)))))) tmp356) ((lambda (_370) (syntax-violation (quote lambda) "bad lambda" e329)) tmp336))) ($sc-dispatch tmp336 (quote (any any . each-any)))))) ($sc-dispatch tmp336 (quote (each-any any . each-any)))))) ($sc-dispatch tmp336 (quote (any any any . each-any))))) c331))) (chi-body154 (lambda (body371 outer-form372 r373 w374 mod375) (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) (let ((ribcage377 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w378 (make-wrap116 (wrap-marks117 w374) (cons ribcage377 (wrap-subst118 w374))))) (letrec ((parse379 (lambda (body380 ids381 labels382 var-ids383 vars384 vals385 bindings386) (if (null? body380) (syntax-violation #f "no expressions in body" outer-form372) (let ((e388 (cdar body380)) (er389 (caar body380))) (call-with-values (lambda () (syntax-type148 e388 er389 (quote (())) (source-annotation105 e388) ribcage377 mod375)) (lambda (type390 value391 e392 w393 s394 mod395) (if (memv type390 (quote (define-form))) (let ((id396 (wrap142 value391 w393 mod395)) (label397 (gen-label119))) (let ((var398 (gen-var161 id396))) (begin (extend-ribcage!130 ribcage377 id396 label397) (parse379 (cdr body380) (cons id396 ids381) (cons label397 labels382) (cons id396 var-ids383) (cons var398 vars384) (cons (cons er389 (wrap142 e392 w393 mod395)) vals385) (cons (cons (quote lexical) var398) bindings386))))) (if (memv type390 (quote (define-syntax-form))) (let ((id399 (wrap142 value391 w393 mod395)) (label400 (gen-label119))) (begin (extend-ribcage!130 ribcage377 id399 label400) (parse379 (cdr body380) (cons id399 ids381) (cons label400 labels382) var-ids383 vars384 vals385 (cons (cons (quote macro) (cons er389 (wrap142 e392 w393 mod395))) bindings386)))) (if (memv type390 (quote (begin-form))) ((lambda (tmp401) ((lambda (tmp402) (if tmp402 (apply (lambda (_403 e1404) (parse379 (letrec ((f405 (lambda (forms406) (if (null? forms406) (cdr body380) (cons (cons er389 (wrap142 (car forms406) w393 mod395)) (f405 (cdr forms406))))))) (f405 e1404)) ids381 labels382 var-ids383 vars384 vals385 bindings386)) tmp402) (syntax-violation #f "source expression failed to match any pattern" tmp401))) ($sc-dispatch tmp401 (quote (any . each-any))))) e392) (if (memv type390 (quote (local-syntax-form))) (chi-local-syntax156 value391 e392 er389 w393 s394 mod395 (lambda (forms408 er409 w410 s411 mod412) (parse379 (letrec ((f413 (lambda (forms414) (if (null? forms414) (cdr body380) (cons (cons er409 (wrap142 (car forms414) w410 mod412)) (f413 (cdr forms414))))))) (f413 forms408)) ids381 labels382 var-ids383 vars384 vals385 bindings386))) (if (null? ids381) (build-sequence93 #f (map (lambda (x415) (chi150 (cdr x415) (car x415) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))) (begin (if (not (valid-bound-ids?139 ids381)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form372)) (letrec ((loop416 (lambda (bs417 er-cache418 r-cache419) (if (not (null? bs417)) (let ((b420 (car bs417))) (if (eq? (car b420) (quote macro)) (let ((er421 (cadr b420))) (let ((r-cache422 (if (eq? er421 er-cache418) r-cache419 (macros-only-env110 er421)))) (begin (set-cdr! b420 (eval-local-transformer157 (chi150 (cddr b420) r-cache422 (quote (())) mod395) mod395)) (loop416 (cdr bs417) er421 r-cache422)))) (loop416 (cdr bs417) er-cache418 r-cache419))))))) (loop416 bindings386 #f #f)) (set-cdr! r376 (extend-env108 labels382 bindings386 (cdr r376))) (build-letrec96 #f (map syntax->datum var-ids383) vars384 (map (lambda (x423) (chi150 (cdr x423) (car x423) (quote (())) mod395)) vals385) (build-sequence93 #f (map (lambda (x424) (chi150 (cdr x424) (car x424) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))))))))))))))))) (parse379 (map (lambda (x387) (cons r376 (wrap142 x387 w378 mod375))) body371) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p425 e426 r427 w428 rib429 mod430) (letrec ((rebuild-macro-output431 (lambda (x432 m433) (if (pair? x432) (cons (rebuild-macro-output431 (car x432) m433) (rebuild-macro-output431 (cdr x432) m433)) (if (syntax-object?98 x432) (let ((w434 (syntax-object-wrap100 x432))) (let ((ms435 (wrap-marks117 w434)) (s436 (wrap-subst118 w434))) (if (if (pair? ms435) (eq? (car ms435) #f) #f) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cdr ms435) (if rib429 (cons rib429 (cdr s436)) (cdr s436))) (syntax-object-module101 x432)) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cons m433 ms435) (if rib429 (cons rib429 (cons (quote shift) s436)) (cons (quote shift) s436))) (let ((pmod437 (procedure-module p425))) (if pmod437 (cons (quote hygiene) (module-name pmod437)) (quote (hygiene guile)))))))) (if (vector? x432) (let ((n438 (vector-length x432))) (let ((v439 (make-vector n438))) (letrec ((loop440 (lambda (i441) (if (fx=74 i441 n438) (begin (if #f #f) v439) (begin (vector-set! v439 i441 (rebuild-macro-output431 (vector-ref x432 i441) m433)) (loop440 (fx+72 i441 1))))))) (loop440 0)))) (if (symbol? x432) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e426 w428 s mod430) x432) x432))))))) (rebuild-macro-output431 (p425 (wrap142 e426 (anti-mark129 w428) mod430)) (string #\m))))) (chi-application152 (lambda (x442 e443 r444 w445 s446 mod447) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (e0450 e1451) (build-application81 s446 x442 (map (lambda (e452) (chi150 e452 r444 w445 mod447)) e1451))) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e443))) (chi-expr151 (lambda (type454 value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (lexical))) (build-lexical-reference83 (quote value) s459 e456 value455) (if (memv type454 (quote (core external-macro))) (value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (module-ref))) (call-with-values (lambda () (value455 e456)) (lambda (id461 mod462) (build-global-reference86 s459 id461 mod462))) (if (memv type454 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e456)) (car e456) value455) e456 r457 w458 s459 mod460) (if (memv type454 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e456)) value455 (if (syntax-object?98 (car e456)) (syntax-object-module101 (car e456)) mod460)) e456 r457 w458 s459 mod460) (if (memv type454 (quote (constant))) (build-data92 s459 (strip160 (source-wrap143 e456 w458 s459 mod460) (quote (())))) (if (memv type454 (quote (global))) (build-global-reference86 s459 value455 mod460) (if (memv type454 (quote (call))) (chi-application152 (chi150 (car e456) r457 w458 mod460) e456 r457 w458 s459 mod460) (if (memv type454 (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466 e2467) (chi-sequence144 (cons e1466 e2467) r457 w458 s459 mod460)) tmp464) (syntax-violation #f "source expression failed to match any pattern" tmp463))) ($sc-dispatch tmp463 (quote (any any . each-any))))) e456) (if (memv type454 (quote (local-syntax-form))) (chi-local-syntax156 value455 e456 r457 w458 s459 mod460 chi-sequence144) (if (memv type454 (quote (eval-when-form))) ((lambda (tmp469) ((lambda (tmp470) (if tmp470 (apply (lambda (_471 x472 e1473 e2474) (let ((when-list475 (chi-when-list147 e456 x472 w458))) (if (memq (quote eval) when-list475) (chi-sequence144 (cons e1473 e2474) r457 w458 s459 mod460) (chi-void158)))) tmp470) (syntax-violation #f "source expression failed to match any pattern" tmp469))) ($sc-dispatch tmp469 (quote (any each-any any . each-any))))) e456) (if (memv type454 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e456 (wrap142 value455 w458 mod460)) (if (memv type454 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e456 w458 s459 mod460)) (if (memv type454 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e456 w458 s459 mod460)) (syntax-violation #f "unexpected syntax" (source-wrap143 e456 w458 s459 mod460)))))))))))))))))) (chi150 (lambda (e478 r479 w480 mod481) (call-with-values (lambda () (syntax-type148 e478 r479 w480 (source-annotation105 e478) #f mod481)) (lambda (type482 value483 e484 w485 s486 mod487) (chi-expr151 type482 value483 e484 r479 w485 s486 mod487))))) (chi-top149 (lambda (e488 r489 w490 m491 esew492 mod493) (call-with-values (lambda () (syntax-type148 e488 r489 w490 (source-annotation105 e488) #f mod493)) (lambda (type501 value502 e503 w504 s505 mod506) (if (memv type501 (quote (begin-form))) ((lambda (tmp507) ((lambda (tmp508) (if tmp508 (apply (lambda (_509) (chi-void158)) tmp508) ((lambda (tmp510) (if tmp510 (apply (lambda (_511 e1512 e2513) (chi-top-sequence145 (cons e1512 e2513) r489 w504 s505 m491 esew492 mod506)) tmp510) (syntax-violation #f "source expression failed to match any pattern" tmp507))) ($sc-dispatch tmp507 (quote (any any . each-any)))))) ($sc-dispatch tmp507 (quote (any))))) e503) (if (memv type501 (quote (local-syntax-form))) (chi-local-syntax156 value502 e503 r489 w504 s505 mod506 (lambda (body515 r516 w517 s518 mod519) (chi-top-sequence145 body515 r516 w517 s518 m491 esew492 mod519))) (if (memv type501 (quote (eval-when-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 x523 e1524 e2525) (let ((when-list526 (chi-when-list147 e503 x523 w504)) (body527 (cons e1524 e2525))) (if (eq? m491 (quote e)) (if (memq (quote eval) when-list526) (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) (chi-void158)) (if (memq (quote load) when-list526) (if (let ((t530 (memq (quote compile) when-list526))) (if t530 t530 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (chi-top-sequence145 body527 r489 w504 s505 (quote c&e) (quote (compile load)) mod506) (if (memq m491 (quote (c c&e))) (chi-top-sequence145 body527 r489 w504 s505 (quote c) (quote (load)) mod506) (chi-void158))) (if (let ((t531 (memq (quote compile) when-list526))) (if t531 t531 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) mod506) (chi-void158)) (chi-void158)))))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any each-any any . each-any))))) e503) (if (memv type501 (quote (define-syntax-form))) (let ((n532 (id-var-name136 value502 w504)) (r533 (macros-only-env110 r489))) (if (memv m491 (quote (c))) (if (memq (quote compile) esew492) (let ((e534 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e534 mod506) (if (memq (quote load) esew492) e534 (chi-void158)))) (if (memq (quote load) esew492) (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) (chi-void158))) (if (memv m491 (quote (c&e))) (let ((e535 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e535 mod506) e535)) (begin (if (memq (quote eval) esew492) (top-level-eval-hook76 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) mod506)) (chi-void158))))) (if (memv type501 (quote (define-form))) (let ((n536 (id-var-name136 value502 w504))) (let ((type537 (binding-type106 (lookup111 n536 r489 mod506)))) (if (memv type537 (quote (global core macro module-ref))) (let ((x538 (build-global-definition89 s505 n536 (chi150 e503 r489 w504 mod506)))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x538 mod506)) x538)) (if (memv type537 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e503 (wrap142 value502 w504 mod506)) (syntax-violation #f "cannot define keyword at top level" e503 (wrap142 value502 w504 mod506)))))) (let ((x539 (chi-expr151 type501 value502 e503 r489 w504 s505 mod506))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x539 mod506)) x539))))))))))) (syntax-type148 (lambda (e540 r541 w542 s543 rib544 mod545) (if (symbol? e540) (let ((n546 (id-var-name136 e540 w542))) (let ((b547 (lookup111 n546 r541 mod545))) (let ((type548 (binding-type106 b547))) (if (memv type548 (quote (lexical))) (values type548 (binding-value107 b547) e540 w542 s543 mod545) (if (memv type548 (quote (global))) (values type548 n546 e540 w542 s543 mod545) (if (memv type548 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b547) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545) (values type548 (binding-value107 b547) e540 w542 s543 mod545))))))) (if (pair? e540) (let ((first549 (car e540))) (if (id?114 first549) (let ((n550 (id-var-name136 first549 w542))) (let ((b551 (lookup111 n550 r541 (let ((t552 (if (syntax-object?98 first549) (syntax-object-module101 first549) #f))) (if t552 t552 mod545))))) (let ((type553 (binding-type106 b551))) (if (memv type553 (quote (lexical))) (values (quote lexical-call) (binding-value107 b551) e540 w542 s543 mod545) (if (memv type553 (quote (global))) (values (quote global-call) n550 e540 w542 s543 mod545) (if (memv type553 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b551) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545) (if (memv type553 (quote (core external-macro module-ref))) (values type553 (binding-value107 b551) e540 w542 s543 mod545) (if (memv type553 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value107 b551) e540 w542 s543 mod545) (if (memv type553 (quote (begin))) (values (quote begin-form) #f e540 w542 s543 mod545) (if (memv type553 (quote (eval-when))) (values (quote eval-when-form) #f e540 w542 s543 mod545) (if (memv type553 (quote (define))) ((lambda (tmp554) ((lambda (tmp555) (if (if tmp555 (apply (lambda (_556 name557 val558) (id?114 name557)) tmp555) #f) (apply (lambda (_559 name560 val561) (values (quote define-form) name560 val561 w542 s543 mod545)) tmp555) ((lambda (tmp562) (if (if tmp562 (apply (lambda (_563 name564 args565 e1566 e2567) (if (id?114 name564) (valid-bound-ids?139 (lambda-var-list162 args565)) #f)) tmp562) #f) (apply (lambda (_568 name569 args570 e1571 e2572) (values (quote define-form) (wrap142 name569 w542 mod545) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args570 (cons e1571 e2572)) w542 mod545)) (quote (())) s543 mod545)) tmp562) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576) (id?114 name576)) tmp574) #f) (apply (lambda (_577 name578) (values (quote define-form) (wrap142 name578 w542 mod545) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s543 mod545)) tmp574) (syntax-violation #f "source expression failed to match any pattern" tmp554))) ($sc-dispatch tmp554 (quote (any any)))))) ($sc-dispatch tmp554 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp554 (quote (any any any))))) e540) (if (memv type553 (quote (define-syntax))) ((lambda (tmp579) ((lambda (tmp580) (if (if tmp580 (apply (lambda (_581 name582 val583) (id?114 name582)) tmp580) #f) (apply (lambda (_584 name585 val586) (values (quote define-syntax-form) name585 val586 w542 s543 mod545)) tmp580) (syntax-violation #f "source expression failed to match any pattern" tmp579))) ($sc-dispatch tmp579 (quote (any any any))))) e540) (values (quote call) #f e540 w542 s543 mod545))))))))))))) (values (quote call) #f e540 w542 s543 mod545))) (if (syntax-object?98 e540) (syntax-type148 (syntax-object-expression99 e540) r541 (join-wraps133 w542 (syntax-object-wrap100 e540)) #f rib544 (let ((t587 (syntax-object-module101 e540))) (if t587 t587 mod545))) (if (self-evaluating? e540) (values (quote constant) #f e540 w542 s543 mod545) (values (quote other) #f e540 w542 s543 mod545))))))) (chi-when-list147 (lambda (e588 when-list589 w590) (letrec ((f591 (lambda (when-list592 situations593) (if (null? when-list592) situations593 (f591 (cdr when-list592) (cons (let ((x594 (car when-list592))) (if (free-id=?137 x594 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x594 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x594 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e588 (wrap142 x594 w590 #f)))))) situations593)))))) (f591 when-list589 (quote ()))))) (chi-install-global146 (lambda (name595 e596) (build-global-definition89 #f name595 (if (let ((v597 (module-variable (current-module) name595))) (if v597 (if (variable-bound? v597) (if (macro? (variable-ref v597)) (not (eq? (macro-type (variable-ref v597)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name595))) (build-data92 #f (quote macro)) e596)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e596)))))) (chi-top-sequence145 (lambda (body598 r599 w600 s601 m602 esew603 mod604) (build-sequence93 s601 (letrec ((dobody605 (lambda (body606 r607 w608 m609 esew610 mod611) (if (null? body606) (quote ()) (let ((first612 (chi-top149 (car body606) r607 w608 m609 esew610 mod611))) (cons first612 (dobody605 (cdr body606) r607 w608 m609 esew610 mod611))))))) (dobody605 body598 r599 w600 m602 esew603 mod604))))) (chi-sequence144 (lambda (body613 r614 w615 s616 mod617) (build-sequence93 s616 (letrec ((dobody618 (lambda (body619 r620 w621 mod622) (if (null? body619) (quote ()) (let ((first623 (chi150 (car body619) r620 w621 mod622))) (cons first623 (dobody618 (cdr body619) r620 w621 mod622))))))) (dobody618 body613 r614 w615 mod617))))) (source-wrap143 (lambda (x624 w625 s626 defmod627) (wrap142 (if s626 (begin (if (not (pair? x624)) (error "bad source-wrap!!!" x624 s626)) (set-source-properties! x624 s626) x624) x624) w625 defmod627))) (wrap142 (lambda (x628 w629 defmod630) (if (if (null? (wrap-marks117 w629)) (null? (wrap-subst118 w629)) #f) x628 (if (syntax-object?98 x628) (make-syntax-object97 (syntax-object-expression99 x628) (join-wraps133 w629 (syntax-object-wrap100 x628)) (syntax-object-module101 x628)) (if (null? x628) x628 (make-syntax-object97 x628 w629 defmod630)))))) (bound-id-member?141 (lambda (x631 list632) (if (not (null? list632)) (let ((t633 (bound-id=?138 x631 (car list632)))) (if t633 t633 (bound-id-member?141 x631 (cdr list632)))) #f))) (distinct-bound-ids?140 (lambda (ids634) (letrec ((distinct?635 (lambda (ids636) (let ((t637 (null? ids636))) (if t637 t637 (if (not (bound-id-member?141 (car ids636) (cdr ids636))) (distinct?635 (cdr ids636)) #f)))))) (distinct?635 ids634)))) (valid-bound-ids?139 (lambda (ids638) (if (letrec ((all-ids?639 (lambda (ids640) (let ((t641 (null? ids640))) (if t641 t641 (if (id?114 (car ids640)) (all-ids?639 (cdr ids640)) #f)))))) (all-ids?639 ids638)) (distinct-bound-ids?140 ids638) #f))) (bound-id=?138 (lambda (i642 j643) (if (if (syntax-object?98 i642) (syntax-object?98 j643) #f) (if (eq? (syntax-object-expression99 i642) (syntax-object-expression99 j643)) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i642)) (wrap-marks117 (syntax-object-wrap100 j643))) #f) (eq? i642 j643)))) (free-id=?137 (lambda (i644 j645) (if (eq? (let ((x646 i644)) (if (syntax-object?98 x646) (syntax-object-expression99 x646) x646)) (let ((x647 j645)) (if (syntax-object?98 x647) (syntax-object-expression99 x647) x647))) (eq? (id-var-name136 i644 (quote (()))) (id-var-name136 j645 (quote (())))) #f))) (id-var-name136 (lambda (id648 w649) (letrec ((search-vector-rib652 (lambda (sym658 subst659 marks660 symnames661 ribcage662) (let ((n663 (vector-length symnames661))) (letrec ((f664 (lambda (i665) (if (fx=74 i665 n663) (search650 sym658 (cdr subst659) marks660) (if (if (eq? (vector-ref symnames661 i665) sym658) (same-marks?135 marks660 (vector-ref (ribcage-marks124 ribcage662) i665)) #f) (values (vector-ref (ribcage-labels125 ribcage662) i665) marks660) (f664 (fx+72 i665 1))))))) (f664 0))))) (search-list-rib651 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (letrec ((f671 (lambda (symnames672 i673) (if (null? symnames672) (search650 sym666 (cdr subst667) marks668) (if (if (eq? (car symnames672) sym666) (same-marks?135 marks668 (list-ref (ribcage-marks124 ribcage670) i673)) #f) (values (list-ref (ribcage-labels125 ribcage670) i673) marks668) (f671 (cdr symnames672) (fx+72 i673 1))))))) (f671 symnames669 0)))) (search650 (lambda (sym674 subst675 marks676) (if (null? subst675) (values #f marks676) (let ((fst677 (car subst675))) (if (eq? fst677 (quote shift)) (search650 sym674 (cdr subst675) (cdr marks676)) (let ((symnames678 (ribcage-symnames123 fst677))) (if (vector? symnames678) (search-vector-rib652 sym674 subst675 marks676 symnames678 fst677) (search-list-rib651 sym674 subst675 marks676 symnames678 fst677))))))))) (if (symbol? id648) (let ((t679 (call-with-values (lambda () (search650 id648 (wrap-subst118 w649) (wrap-marks117 w649))) (lambda (x681 . ignore680) x681)))) (if t679 t679 id648)) (if (syntax-object?98 id648) (let ((id682 (syntax-object-expression99 id648)) (w1683 (syntax-object-wrap100 id648))) (let ((marks684 (join-marks134 (wrap-marks117 w649) (wrap-marks117 w1683)))) (call-with-values (lambda () (search650 id682 (wrap-subst118 w649) marks684)) (lambda (new-id685 marks686) (let ((t687 new-id685)) (if t687 t687 (let ((t688 (call-with-values (lambda () (search650 id682 (wrap-subst118 w1683) marks686)) (lambda (x690 . ignore689) x690)))) (if t688 t688 id682)))))))) (syntax-violation (quote id-var-name) "invalid id" id648)))))) (same-marks?135 (lambda (x691 y692) (let ((t693 (eq? x691 y692))) (if t693 t693 (if (not (null? x691)) (if (not (null? y692)) (if (eq? (car x691) (car y692)) (same-marks?135 (cdr x691) (cdr y692)) #f) #f) #f))))) (join-marks134 (lambda (m1694 m2695) (smart-append132 m1694 m2695))) (join-wraps133 (lambda (w1696 w2697) (let ((m1698 (wrap-marks117 w1696)) (s1699 (wrap-subst118 w1696))) (if (null? m1698) (if (null? s1699) w2697 (make-wrap116 (wrap-marks117 w2697) (smart-append132 s1699 (wrap-subst118 w2697)))) (make-wrap116 (smart-append132 m1698 (wrap-marks117 w2697)) (smart-append132 s1699 (wrap-subst118 w2697))))))) (smart-append132 (lambda (m1700 m2701) (if (null? m2701) m1700 (append m1700 m2701)))) (make-binding-wrap131 (lambda (ids702 labels703 w704) (if (null? ids702) w704 (make-wrap116 (wrap-marks117 w704) (cons (let ((labelvec705 (list->vector labels703))) (let ((n706 (vector-length labelvec705))) (let ((symnamevec707 (make-vector n706)) (marksvec708 (make-vector n706))) (begin (letrec ((f709 (lambda (ids710 i711) (if (not (null? ids710)) (call-with-values (lambda () (id-sym-name&marks115 (car ids710) w704)) (lambda (symname712 marks713) (begin (vector-set! symnamevec707 i711 symname712) (vector-set! marksvec708 i711 marks713) (f709 (cdr ids710) (fx+72 i711 1))))))))) (f709 ids702 0)) (make-ribcage121 symnamevec707 marksvec708 labelvec705))))) (wrap-subst118 w704)))))) (extend-ribcage!130 (lambda (ribcage714 id715 label716) (begin (set-ribcage-symnames!126 ribcage714 (cons (syntax-object-expression99 id715) (ribcage-symnames123 ribcage714))) (set-ribcage-marks!127 ribcage714 (cons (wrap-marks117 (syntax-object-wrap100 id715)) (ribcage-marks124 ribcage714))) (set-ribcage-labels!128 ribcage714 (cons label716 (ribcage-labels125 ribcage714)))))) (anti-mark129 (lambda (w717) (make-wrap116 (cons #f (wrap-marks117 w717)) (cons (quote shift) (wrap-subst118 w717))))) (set-ribcage-labels!128 (lambda (x718 update719) (vector-set! x718 3 update719))) (set-ribcage-marks!127 (lambda (x720 update721) (vector-set! x720 2 update721))) (set-ribcage-symnames!126 (lambda (x722 update723) (vector-set! x722 1 update723))) (ribcage-labels125 (lambda (x724) (vector-ref x724 3))) (ribcage-marks124 (lambda (x725) (vector-ref x725 2))) (ribcage-symnames123 (lambda (x726) (vector-ref x726 1))) (ribcage?122 (lambda (x727) (if (vector? x727) (if (= (vector-length x727) 4) (eq? (vector-ref x727 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames728 marks729 labels730) (vector (quote ribcage) symnames728 marks729 labels730))) (gen-labels120 (lambda (ls731) (if (null? ls731) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls731)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x732 w733) (if (syntax-object?98 x732) (values (syntax-object-expression99 x732) (join-marks134 (wrap-marks117 w733) (wrap-marks117 (syntax-object-wrap100 x732)))) (values x732 (wrap-marks117 w733))))) (id?114 (lambda (x734) (if (symbol? x734) #t (if (syntax-object?98 x734) (symbol? (syntax-object-expression99 x734)) #f)))) (nonsymbol-id?113 (lambda (x735) (if (syntax-object?98 x735) (symbol? (syntax-object-expression99 x735)) #f))) (global-extend112 (lambda (type736 sym737 val738) (put-global-definition-hook78 sym737 type736 val738))) (lookup111 (lambda (x739 r740 mod741) (let ((t742 (assq x739 r740))) (if t742 (cdr t742) (if (symbol? x739) (let ((t743 (get-global-definition-hook79 x739 mod741))) (if t743 t743 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r744) (if (null? r744) (quote ()) (let ((a745 (car r744))) (if (eq? (cadr a745) (quote macro)) (cons a745 (macros-only-env110 (cdr r744))) (macros-only-env110 (cdr r744))))))) (extend-var-env109 (lambda (labels746 vars747 r748) (if (null? labels746) r748 (extend-var-env109 (cdr labels746) (cdr vars747) (cons (cons (car labels746) (cons (quote lexical) (car vars747))) r748))))) (extend-env108 (lambda (labels749 bindings750 r751) (if (null? labels749) r751 (extend-env108 (cdr labels749) (cdr bindings750) (cons (cons (car labels749) (car bindings750)) r751))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x752) (if (syntax-object?98 x752) (source-annotation105 (syntax-object-expression99 x752)) (if (pair? x752) (source-properties x752) #f)))) (set-syntax-object-module!104 (lambda (x753 update754) (vector-set! x753 3 update754))) (set-syntax-object-wrap!103 (lambda (x755 update756) (vector-set! x755 2 update756))) (set-syntax-object-expression!102 (lambda (x757 update758) (vector-set! x757 1 update758))) (syntax-object-module101 (lambda (x759) (vector-ref x759 3))) (syntax-object-wrap100 (lambda (x760) (vector-ref x760 2))) (syntax-object-expression99 (lambda (x761) (vector-ref x761 1))) (syntax-object?98 (lambda (x762) (if (vector? x762) (if (= (vector-length x762) 4) (eq? (vector-ref x762 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression763 wrap764 module765) (vector (quote syntax-object) expression763 wrap764 module765))) (build-letrec96 (lambda (src766 ids767 vars768 val-exps769 body-exp770) (if (null? vars768) body-exp770 (let ((atom-key771 (fluid-ref *mode*71))) (if (memv atom-key771 (quote (c))) (begin (for-each maybe-name-value!88 ids767 val-exps769) ((@ (language tree-il) make-letrec) src766 ids767 vars768 val-exps769 body-exp770)) (list (quote letrec) (map list vars768 val-exps769) body-exp770)))))) (build-named-let95 (lambda (src772 ids773 vars774 val-exps775 body-exp776) (let ((f777 (car vars774)) (f-name778 (car ids773)) (vars779 (cdr vars774)) (ids780 (cdr ids773))) (let ((atom-key781 (fluid-ref *mode*71))) (if (memv atom-key781 (quote (c))) (let ((proc782 (build-lambda90 src772 ids780 vars779 #f body-exp776))) (begin (maybe-name-value!88 f-name778 proc782) (for-each maybe-name-value!88 ids780 val-exps775) ((@ (language tree-il) make-letrec) src772 (list f-name778) (list f777) (list proc782) (build-application81 src772 (build-lexical-reference83 (quote fun) src772 f-name778 f777) val-exps775)))) (list (quote let) f777 (map list vars779 val-exps775) body-exp776)))))) (build-let94 (lambda (src783 ids784 vars785 val-exps786 body-exp787) (if (null? vars785) body-exp787 (let ((atom-key788 (fluid-ref *mode*71))) (if (memv atom-key788 (quote (c))) (begin (for-each maybe-name-value!88 ids784 val-exps786) ((@ (language tree-il) make-let) src783 ids784 vars785 val-exps786 body-exp787)) (list (quote let) (map list vars785 val-exps786) body-exp787)))))) (build-sequence93 (lambda (src789 exps790) (if (null? (cdr exps790)) (car exps790) (let ((atom-key791 (fluid-ref *mode*71))) (if (memv atom-key791 (quote (c))) ((@ (language tree-il) make-sequence) src789 exps790) (cons (quote begin) exps790)))))) (build-data92 (lambda (src792 exp793) (let ((atom-key794 (fluid-ref *mode*71))) (if (memv atom-key794 (quote (c))) ((@ (language tree-il) make-const) src792 exp793) (if (if (self-evaluating? exp793) (not (vector? exp793)) #f) exp793 (list (quote quote) exp793)))))) (build-primref91 (lambda (src795 name796) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key797 (fluid-ref *mode*71))) (if (memv atom-key797 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src795 name796) name796)) (let ((atom-key798 (fluid-ref *mode*71))) (if (memv atom-key798 (quote (c))) ((@ (language tree-il) make-module-ref) src795 (quote (guile)) name796 #f) (list (quote @@) (quote (guile)) name796)))))) (build-lambda90 (lambda (src799 ids800 vars801 docstring802 exp803) (let ((atom-key804 (fluid-ref *mode*71))) (if (memv atom-key804 (quote (c))) ((@ (language tree-il) make-lambda) src799 ids800 vars801 (if docstring802 (list (cons (quote documentation) docstring802)) (quote ())) exp803) (cons (quote lambda) (cons vars801 (append (if docstring802 (list docstring802) (quote ())) (list exp803)))))))) (build-global-definition89 (lambda (source805 var806 exp807) (let ((atom-key808 (fluid-ref *mode*71))) (if (memv atom-key808 (quote (c))) (begin (maybe-name-value!88 var806 exp807) ((@ (language tree-il) make-toplevel-define) source805 var806 exp807)) (list (quote define) var806 exp807))))) (maybe-name-value!88 (lambda (name809 val810) (if ((@ (language tree-il) lambda?) val810) (let ((meta811 ((@ (language tree-il) lambda-meta) val810))) (if (not (assq (quote name) meta811)) ((setter (@ (language tree-il) lambda-meta)) val810 (acons (quote name) name809 meta811))))))) (build-global-assignment87 (lambda (source812 var813 exp814 mod815) (analyze-variable85 mod815 var813 (lambda (mod816 var817 public?818) (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) ((@ (language tree-il) make-module-set) source812 mod816 var817 public?818 exp814) (list (quote set!) (list (if public?818 (quote @) (quote @@)) mod816 var817) exp814)))) (lambda (var820) (let ((atom-key821 (fluid-ref *mode*71))) (if (memv atom-key821 (quote (c))) ((@ (language tree-il) make-toplevel-set) source812 var820 exp814) (list (quote set!) var820 exp814))))))) (build-global-reference86 (lambda (source822 var823 mod824) (analyze-variable85 mod824 var823 (lambda (mod825 var826 public?827) (let ((atom-key828 (fluid-ref *mode*71))) (if (memv atom-key828 (quote (c))) ((@ (language tree-il) make-module-ref) source822 mod825 var826 public?827) (list (if public?827 (quote @) (quote @@)) mod825 var826)))) (lambda (var829) (let ((atom-key830 (fluid-ref *mode*71))) (if (memv atom-key830 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source822 var829) var829)))))) (analyze-variable85 (lambda (mod831 var832 modref-cont833 bare-cont834) (if (not mod831) (bare-cont834 var832) (let ((kind835 (car mod831)) (mod836 (cdr mod831))) (if (memv kind835 (quote (public))) (modref-cont833 mod836 var832 #t) (if (memv kind835 (quote (private))) (if (not (equal? mod836 (module-name (current-module)))) (modref-cont833 mod836 var832 #f) (bare-cont834 var832)) (if (memv kind835 (quote (bare))) (bare-cont834 var832) (if (memv kind835 (quote (hygiene))) (if (if (not (equal? mod836 (module-name (current-module)))) (module-variable (resolve-module mod836) var832) #f) (modref-cont833 mod836 var832 #f) (bare-cont834 var832)) (syntax-violation #f "bad module kind" var832 mod836))))))))) (build-lexical-assignment84 (lambda (source837 name838 var839 exp840) (let ((atom-key841 (fluid-ref *mode*71))) (if (memv atom-key841 (quote (c))) ((@ (language tree-il) make-lexical-set) source837 name838 var839 exp840) (list (quote set!) var839 exp840))))) (build-lexical-reference83 (lambda (type842 source843 name844 var845) (let ((atom-key846 (fluid-ref *mode*71))) (if (memv atom-key846 (quote (c))) ((@ (language tree-il) make-lexical-ref) source843 name844 var845) var845)))) (build-conditional82 (lambda (source847 test-exp848 then-exp849 else-exp850) (let ((atom-key851 (fluid-ref *mode*71))) (if (memv atom-key851 (quote (c))) ((@ (language tree-il) make-conditional) source847 test-exp848 then-exp849 else-exp850) (if (equal? else-exp850 (quote (if #f #f))) (list (quote if) test-exp848 then-exp849) (list (quote if) test-exp848 then-exp849 else-exp850)))))) (build-application81 (lambda (source852 fun-exp853 arg-exps854) (let ((atom-key855 (fluid-ref *mode*71))) (if (memv atom-key855 (quote (c))) ((@ (language tree-il) make-application) source852 fun-exp853 arg-exps854) (cons fun-exp853 arg-exps854))))) (build-void80 (lambda (source856) (let ((atom-key857 (fluid-ref *mode*71))) (if (memv atom-key857 (quote (c))) ((@ (language tree-il) make-void) source856) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol858 module859) (begin (if (if (not module859) (current-module) #f) (warn "module system is booted, we should have a module" symbol858)) (let ((v860 (module-variable (if module859 (resolve-module (cdr module859)) (current-module)) symbol858))) (if v860 (if (variable-bound? v860) (let ((val861 (variable-ref v860))) (if (macro? val861) (if (syncase-macro-type val861) (cons (syncase-macro-type val861) (syncase-macro-binding val861)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol862 type863 val864) (let ((existing865 (let ((v866 (module-variable (current-module) symbol862))) (if v866 (if (variable-bound? v866) (let ((val867 (variable-ref v866))) (if (macro? val867) (if (not (syncase-macro-type val867)) val867 #f) #f)) #f) #f)))) (module-define! (current-module) symbol862 (if existing865 (make-extended-syncase-macro existing865 type863 val864) (make-syncase-macro type863 val864)))))) (local-eval-hook77 (lambda (x868 mod869) (primitive-eval (list noexpand70 (let ((atom-key870 (fluid-ref *mode*71))) (if (memv atom-key870 (quote (c))) ((@ (language tree-il) tree-il->scheme) x868) x868)))))) (top-level-eval-hook76 (lambda (x871 mod872) (primitive-eval (list noexpand70 (let ((atom-key873 (fluid-ref *mode*71))) (if (memv atom-key873 (quote (c))) ((@ (language tree-il) tree-il->scheme) x871) x871)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e874 r875 w876 s877 mod878) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (_881 var882 val883 e1884 e2885) (valid-bound-ids?139 var882)) tmp880) #f) (apply (lambda (_887 var888 val889 e1890 e2891) (let ((names892 (map (lambda (x893) (id-var-name136 x893 w876)) var888))) (begin (for-each (lambda (id895 n896) (let ((atom-key897 (binding-type106 (lookup111 n896 r875 mod878)))) (if (memv atom-key897 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e874 (source-wrap143 id895 w876 s877 mod878))))) var888 names892) (chi-body154 (cons e1890 e2891) (source-wrap143 e874 w876 s877 mod878) (extend-env108 names892 (let ((trans-r900 (macros-only-env110 r875))) (map (lambda (x901) (cons (quote macro) (eval-local-transformer157 (chi150 x901 trans-r900 w876 mod878) mod878))) val889)) r875) w876 mod878)))) tmp880) ((lambda (_903) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e874 w876 s877 mod878))) tmp879))) ($sc-dispatch tmp879 (quote (any #(each (any any)) any . each-any))))) e874))) (global-extend112 (quote core) (quote quote) (lambda (e904 r905 w906 s907 mod908) ((lambda (tmp909) ((lambda (tmp910) (if tmp910 (apply (lambda (_911 e912) (build-data92 s907 (strip160 e912 w906))) tmp910) ((lambda (_913) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e904 w906 s907 mod908))) tmp909))) ($sc-dispatch tmp909 (quote (any any))))) e904))) (global-extend112 (quote core) (quote syntax) (letrec ((regen921 (lambda (x922) (let ((atom-key923 (car x922))) (if (memv atom-key923 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x922) (cadr x922)) (if (memv atom-key923 (quote (primitive))) (build-primref91 #f (cadr x922)) (if (memv atom-key923 (quote (quote))) (build-data92 #f (cadr x922)) (if (memv atom-key923 (quote (lambda))) (build-lambda90 #f (cadr x922) (cadr x922) #f (regen921 (caddr x922))) (if (memv atom-key923 (quote (map))) (let ((ls924 (map regen921 (cdr x922)))) (build-application81 #f (build-primref91 #f (quote map)) ls924)) (build-application81 #f (build-primref91 #f (car x922)) (map regen921 (cdr x922))))))))))) (gen-vector920 (lambda (x925) (if (eq? (car x925) (quote list)) (cons (quote vector) (cdr x925)) (if (eq? (car x925) (quote quote)) (list (quote quote) (list->vector (cadr x925))) (list (quote list->vector) x925))))) (gen-append919 (lambda (x926 y927) (if (equal? y927 (quote (quote ()))) x926 (list (quote append) x926 y927)))) (gen-cons918 (lambda (x928 y929) (let ((atom-key930 (car y929))) (if (memv atom-key930 (quote (quote))) (if (eq? (car x928) (quote quote)) (list (quote quote) (cons (cadr x928) (cadr y929))) (if (eq? (cadr y929) (quote ())) (list (quote list) x928) (list (quote cons) x928 y929))) (if (memv atom-key930 (quote (list))) (cons (quote list) (cons x928 (cdr y929))) (list (quote cons) x928 y929)))))) (gen-map917 (lambda (e931 map-env932) (let ((formals933 (map cdr map-env932)) (actuals934 (map (lambda (x935) (list (quote ref) (car x935))) map-env932))) (if (eq? (car e931) (quote ref)) (car actuals934) (if (and-map (lambda (x936) (if (eq? (car x936) (quote ref)) (memq (cadr x936) formals933) #f)) (cdr e931)) (cons (quote map) (cons (list (quote primitive) (car e931)) (map (let ((r937 (map cons formals933 actuals934))) (lambda (x938) (cdr (assq (cadr x938) r937)))) (cdr e931)))) (cons (quote map) (cons (list (quote lambda) formals933 e931) actuals934))))))) (gen-mappend916 (lambda (e939 map-env940) (list (quote apply) (quote (primitive append)) (gen-map917 e939 map-env940)))) (gen-ref915 (lambda (src941 var942 level943 maps944) (if (fx=74 level943 0) (values var942 maps944) (if (null? maps944) (syntax-violation (quote syntax) "missing ellipsis" src941) (call-with-values (lambda () (gen-ref915 src941 var942 (fx-73 level943 1) (cdr maps944))) (lambda (outer-var945 outer-maps946) (let ((b947 (assq outer-var945 (car maps944)))) (if b947 (values (cdr b947) maps944) (let ((inner-var948 (gen-var161 (quote tmp)))) (values inner-var948 (cons (cons (cons outer-var945 inner-var948) (car maps944)) outer-maps946))))))))))) (gen-syntax914 (lambda (src949 e950 r951 maps952 ellipsis?953 mod954) (if (id?114 e950) (let ((label955 (id-var-name136 e950 (quote (()))))) (let ((b956 (lookup111 label955 r951 mod954))) (if (eq? (binding-type106 b956) (quote syntax)) (call-with-values (lambda () (let ((var.lev957 (binding-value107 b956))) (gen-ref915 src949 (car var.lev957) (cdr var.lev957) maps952))) (lambda (var958 maps959) (values (list (quote ref) var958) maps959))) (if (ellipsis?953 e950) (syntax-violation (quote syntax) "misplaced ellipsis" src949) (values (list (quote quote) e950) maps952))))) ((lambda (tmp960) ((lambda (tmp961) (if (if tmp961 (apply (lambda (dots962 e963) (ellipsis?953 dots962)) tmp961) #f) (apply (lambda (dots964 e965) (gen-syntax914 src949 e965 r951 maps952 (lambda (x966) #f) mod954)) tmp961) ((lambda (tmp967) (if (if tmp967 (apply (lambda (x968 dots969 y970) (ellipsis?953 dots969)) tmp967) #f) (apply (lambda (x971 dots972 y973) (letrec ((f974 (lambda (y975 k976) ((lambda (tmp980) ((lambda (tmp981) (if (if tmp981 (apply (lambda (dots982 y983) (ellipsis?953 dots982)) tmp981) #f) (apply (lambda (dots984 y985) (f974 y985 (lambda (maps986) (call-with-values (lambda () (k976 (cons (quote ()) maps986))) (lambda (x987 maps988) (if (null? (car maps988)) (syntax-violation (quote syntax) "extra ellipsis" src949) (values (gen-mappend916 x987 (car maps988)) (cdr maps988)))))))) tmp981) ((lambda (_989) (call-with-values (lambda () (gen-syntax914 src949 y975 r951 maps952 ellipsis?953 mod954)) (lambda (y990 maps991) (call-with-values (lambda () (k976 maps991)) (lambda (x992 maps993) (values (gen-append919 x992 y990) maps993)))))) tmp980))) ($sc-dispatch tmp980 (quote (any . any))))) y975)))) (f974 y973 (lambda (maps977) (call-with-values (lambda () (gen-syntax914 src949 x971 r951 (cons (quote ()) maps977) ellipsis?953 mod954)) (lambda (x978 maps979) (if (null? (car maps979)) (syntax-violation (quote syntax) "extra ellipsis" src949) (values (gen-map917 x978 (car maps979)) (cdr maps979))))))))) tmp967) ((lambda (tmp994) (if tmp994 (apply (lambda (x995 y996) (call-with-values (lambda () (gen-syntax914 src949 x995 r951 maps952 ellipsis?953 mod954)) (lambda (x997 maps998) (call-with-values (lambda () (gen-syntax914 src949 y996 r951 maps998 ellipsis?953 mod954)) (lambda (y999 maps1000) (values (gen-cons918 x997 y999) maps1000)))))) tmp994) ((lambda (tmp1001) (if tmp1001 (apply (lambda (e11002 e21003) (call-with-values (lambda () (gen-syntax914 src949 (cons e11002 e21003) r951 maps952 ellipsis?953 mod954)) (lambda (e1005 maps1006) (values (gen-vector920 e1005) maps1006)))) tmp1001) ((lambda (_1007) (values (list (quote quote) e950) maps952)) tmp960))) ($sc-dispatch tmp960 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp960 (quote (any . any)))))) ($sc-dispatch tmp960 (quote (any any . any)))))) ($sc-dispatch tmp960 (quote (any any))))) e950))))) (lambda (e1008 r1009 w1010 s1011 mod1012) (let ((e1013 (source-wrap143 e1008 w1010 s1011 mod1012))) ((lambda (tmp1014) ((lambda (tmp1015) (if tmp1015 (apply (lambda (_1016 x1017) (call-with-values (lambda () (gen-syntax914 e1013 x1017 r1009 (quote ()) ellipsis?159 mod1012)) (lambda (e1018 maps1019) (regen921 e1018)))) tmp1015) ((lambda (_1020) (syntax-violation (quote syntax) "bad `syntax' form" e1013)) tmp1014))) ($sc-dispatch tmp1014 (quote (any any))))) e1013))))) (global-extend112 (quote core) (quote lambda) (lambda (e1021 r1022 w1023 s1024 mod1025) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda (_1028 c1029) (chi-lambda-clause155 (source-wrap143 e1021 w1023 s1024 mod1025) #f c1029 r1022 w1023 mod1025 (lambda (names1030 vars1031 docstring1032 body1033) (build-lambda90 s1024 names1030 vars1031 docstring1032 body1033)))) tmp1027) (syntax-violation #f "source expression failed to match any pattern" tmp1026))) ($sc-dispatch tmp1026 (quote (any . any))))) e1021))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1034 (lambda (e1035 r1036 w1037 s1038 mod1039 constructor1040 ids1041 vals1042 exps1043) (if (not (valid-bound-ids?139 ids1041)) (syntax-violation (quote let) "duplicate bound variable" e1035) (let ((labels1044 (gen-labels120 ids1041)) (new-vars1045 (map gen-var161 ids1041))) (let ((nw1046 (make-binding-wrap131 ids1041 labels1044 w1037)) (nr1047 (extend-var-env109 labels1044 new-vars1045 r1036))) (constructor1040 s1038 (map syntax->datum ids1041) new-vars1045 (map (lambda (x1048) (chi150 x1048 r1036 w1037 mod1039)) vals1042) (chi-body154 exps1043 (source-wrap143 e1035 nw1046 s1038 mod1039) nr1047 nw1046 mod1039)))))))) (lambda (e1049 r1050 w1051 s1052 mod1053) ((lambda (tmp1054) ((lambda (tmp1055) (if (if tmp1055 (apply (lambda (_1056 id1057 val1058 e11059 e21060) (and-map id?114 id1057)) tmp1055) #f) (apply (lambda (_1062 id1063 val1064 e11065 e21066) (chi-let1034 e1049 r1050 w1051 s1052 mod1053 build-let94 id1063 val1064 (cons e11065 e21066))) tmp1055) ((lambda (tmp1070) (if (if tmp1070 (apply (lambda (_1071 f1072 id1073 val1074 e11075 e21076) (if (id?114 f1072) (and-map id?114 id1073) #f)) tmp1070) #f) (apply (lambda (_1078 f1079 id1080 val1081 e11082 e21083) (chi-let1034 e1049 r1050 w1051 s1052 mod1053 build-named-let95 (cons f1079 id1080) val1081 (cons e11082 e21083))) tmp1070) ((lambda (_1087) (syntax-violation (quote let) "bad let" (source-wrap143 e1049 w1051 s1052 mod1053))) tmp1054))) ($sc-dispatch tmp1054 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1054 (quote (any #(each (any any)) any . each-any))))) e1049)))) (global-extend112 (quote core) (quote letrec) (lambda (e1088 r1089 w1090 s1091 mod1092) ((lambda (tmp1093) ((lambda (tmp1094) (if (if tmp1094 (apply (lambda (_1095 id1096 val1097 e11098 e21099) (and-map id?114 id1096)) tmp1094) #f) (apply (lambda (_1101 id1102 val1103 e11104 e21105) (let ((ids1106 id1102)) (if (not (valid-bound-ids?139 ids1106)) (syntax-violation (quote letrec) "duplicate bound variable" e1088) (let ((labels1108 (gen-labels120 ids1106)) (new-vars1109 (map gen-var161 ids1106))) (let ((w1110 (make-binding-wrap131 ids1106 labels1108 w1090)) (r1111 (extend-var-env109 labels1108 new-vars1109 r1089))) (build-letrec96 s1091 (map syntax->datum ids1106) new-vars1109 (map (lambda (x1112) (chi150 x1112 r1111 w1110 mod1092)) val1103) (chi-body154 (cons e11104 e21105) (source-wrap143 e1088 w1110 s1091 mod1092) r1111 w1110 mod1092))))))) tmp1094) ((lambda (_1115) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1088 w1090 s1091 mod1092))) tmp1093))) ($sc-dispatch tmp1093 (quote (any #(each (any any)) any . each-any))))) e1088))) (global-extend112 (quote core) (quote set!) (lambda (e1116 r1117 w1118 s1119 mod1120) ((lambda (tmp1121) ((lambda (tmp1122) (if (if tmp1122 (apply (lambda (_1123 id1124 val1125) (id?114 id1124)) tmp1122) #f) (apply (lambda (_1126 id1127 val1128) (let ((val1129 (chi150 val1128 r1117 w1118 mod1120)) (n1130 (id-var-name136 id1127 w1118))) (let ((b1131 (lookup111 n1130 r1117 mod1120))) (let ((atom-key1132 (binding-type106 b1131))) (if (memv atom-key1132 (quote (lexical))) (build-lexical-assignment84 s1119 (syntax->datum id1127) (binding-value107 b1131) val1129) (if (memv atom-key1132 (quote (global))) (build-global-assignment87 s1119 n1130 val1129 mod1120) (if (memv atom-key1132 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1127 w1118 mod1120)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1116 w1118 s1119 mod1120))))))))) tmp1122) ((lambda (tmp1133) (if tmp1133 (apply (lambda (_1134 head1135 tail1136 val1137) (call-with-values (lambda () (syntax-type148 head1135 r1117 (quote (())) #f #f mod1120)) (lambda (type1138 value1139 ee1140 ww1141 ss1142 modmod1143) (if (memv type1138 (quote (module-ref))) (let ((val1144 (chi150 val1137 r1117 w1118 mod1120))) (call-with-values (lambda () (value1139 (cons head1135 tail1136))) (lambda (id1146 mod1147) (build-global-assignment87 s1119 id1146 val1144 mod1147)))) (build-application81 s1119 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1135) r1117 w1118 mod1120) (map (lambda (e1148) (chi150 e1148 r1117 w1118 mod1120)) (append tail1136 (list val1137)))))))) tmp1133) ((lambda (_1150) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1116 w1118 s1119 mod1120))) tmp1121))) ($sc-dispatch tmp1121 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1121 (quote (any any any))))) e1116))) (global-extend112 (quote module-ref) (quote @) (lambda (e1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 mod1155 id1156) (if (and-map id?114 mod1155) (id?114 id1156) #f)) tmp1153) #f) (apply (lambda (_1158 mod1159 id1160) (values (syntax->datum id1160) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1159)))) tmp1153) (syntax-violation #f "source expression failed to match any pattern" tmp1152))) ($sc-dispatch tmp1152 (quote (any each-any any))))) e1151))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1162) ((lambda (tmp1163) ((lambda (tmp1164) (if (if tmp1164 (apply (lambda (_1165 mod1166 id1167) (if (and-map id?114 mod1166) (id?114 id1167) #f)) tmp1164) #f) (apply (lambda (_1169 mod1170 id1171) (values (syntax->datum id1171) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1170)))) tmp1164) (syntax-violation #f "source expression failed to match any pattern" tmp1163))) ($sc-dispatch tmp1163 (quote (any each-any any))))) e1162))) (global-extend112 (quote core) (quote if) (lambda (e1173 r1174 w1175 s1176 mod1177) ((lambda (tmp1178) ((lambda (tmp1179) (if tmp1179 (apply (lambda (_1180 test1181 then1182) (build-conditional82 s1176 (chi150 test1181 r1174 w1175 mod1177) (chi150 then1182 r1174 w1175 mod1177) (build-void80 #f))) tmp1179) ((lambda (tmp1183) (if tmp1183 (apply (lambda (_1184 test1185 then1186 else1187) (build-conditional82 s1176 (chi150 test1185 r1174 w1175 mod1177) (chi150 then1186 r1174 w1175 mod1177) (chi150 else1187 r1174 w1175 mod1177))) tmp1183) (syntax-violation #f "source expression failed to match any pattern" tmp1178))) ($sc-dispatch tmp1178 (quote (any any any any)))))) ($sc-dispatch tmp1178 (quote (any any any))))) e1173))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1191 (lambda (x1192 keys1193 clauses1194 r1195 mod1196) (if (null? clauses1194) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1192)) ((lambda (tmp1197) ((lambda (tmp1198) (if tmp1198 (apply (lambda (pat1199 exp1200) (if (if (id?114 pat1199) (and-map (lambda (x1201) (not (free-id=?137 pat1199 x1201))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1193)) #f) (let ((labels1202 (list (gen-label119))) (var1203 (gen-var161 pat1199))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1199)) (list var1203) #f (chi150 exp1200 (extend-env108 labels1202 (list (cons (quote syntax) (cons var1203 0))) r1195) (make-binding-wrap131 (list pat1199) labels1202 (quote (()))) mod1196)) (list x1192))) (gen-clause1190 x1192 keys1193 (cdr clauses1194) r1195 pat1199 #t exp1200 mod1196))) tmp1198) ((lambda (tmp1204) (if tmp1204 (apply (lambda (pat1205 fender1206 exp1207) (gen-clause1190 x1192 keys1193 (cdr clauses1194) r1195 pat1205 fender1206 exp1207 mod1196)) tmp1204) ((lambda (_1208) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1194))) tmp1197))) ($sc-dispatch tmp1197 (quote (any any any)))))) ($sc-dispatch tmp1197 (quote (any any))))) (car clauses1194))))) (gen-clause1190 (lambda (x1209 keys1210 clauses1211 r1212 pat1213 fender1214 exp1215 mod1216) (call-with-values (lambda () (convert-pattern1188 pat1213 keys1210)) (lambda (p1217 pvars1218) (if (not (distinct-bound-ids?140 (map car pvars1218))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1213) (if (not (and-map (lambda (x1219) (not (ellipsis?159 (car x1219)))) pvars1218)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1213) (let ((y1220 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1220) #f (let ((y1221 (build-lexical-reference83 (quote value) #f (quote tmp) y1220))) (build-conditional82 #f ((lambda (tmp1222) ((lambda (tmp1223) (if tmp1223 (apply (lambda () y1221) tmp1223) ((lambda (_1224) (build-conditional82 #f y1221 (build-dispatch-call1189 pvars1218 fender1214 y1221 r1212 mod1216) (build-data92 #f #f))) tmp1222))) ($sc-dispatch tmp1222 (quote #(atom #t))))) fender1214) (build-dispatch-call1189 pvars1218 exp1215 y1221 r1212 mod1216) (gen-syntax-case1191 x1209 keys1210 clauses1211 r1212 mod1216)))) (list (if (eq? p1217 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1209)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1209 (build-data92 #f p1217))))))))))))) (build-dispatch-call1189 (lambda (pvars1225 exp1226 y1227 r1228 mod1229) (let ((ids1230 (map car pvars1225)) (levels1231 (map cdr pvars1225))) (let ((labels1232 (gen-labels120 ids1230)) (new-vars1233 (map gen-var161 ids1230))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1230) new-vars1233 #f (chi150 exp1226 (extend-env108 labels1232 (map (lambda (var1234 level1235) (cons (quote syntax) (cons var1234 level1235))) new-vars1233 (map cdr pvars1225)) r1228) (make-binding-wrap131 ids1230 labels1232 (quote (()))) mod1229)) y1227)))))) (convert-pattern1188 (lambda (pattern1236 keys1237) (letrec ((cvt1238 (lambda (p1239 n1240 ids1241) (if (id?114 p1239) (if (bound-id-member?141 p1239 keys1237) (values (vector (quote free-id) p1239) ids1241) (values (quote any) (cons (cons p1239 n1240) ids1241))) ((lambda (tmp1242) ((lambda (tmp1243) (if (if tmp1243 (apply (lambda (x1244 dots1245) (ellipsis?159 dots1245)) tmp1243) #f) (apply (lambda (x1246 dots1247) (call-with-values (lambda () (cvt1238 x1246 (fx+72 n1240 1) ids1241)) (lambda (p1248 ids1249) (values (if (eq? p1248 (quote any)) (quote each-any) (vector (quote each) p1248)) ids1249)))) tmp1243) ((lambda (tmp1250) (if tmp1250 (apply (lambda (x1251 y1252) (call-with-values (lambda () (cvt1238 y1252 n1240 ids1241)) (lambda (y1253 ids1254) (call-with-values (lambda () (cvt1238 x1251 n1240 ids1254)) (lambda (x1255 ids1256) (values (cons x1255 y1253) ids1256)))))) tmp1250) ((lambda (tmp1257) (if tmp1257 (apply (lambda () (values (quote ()) ids1241)) tmp1257) ((lambda (tmp1258) (if tmp1258 (apply (lambda (x1259) (call-with-values (lambda () (cvt1238 x1259 n1240 ids1241)) (lambda (p1261 ids1262) (values (vector (quote vector) p1261) ids1262)))) tmp1258) ((lambda (x1263) (values (vector (quote atom) (strip160 p1239 (quote (())))) ids1241)) tmp1242))) ($sc-dispatch tmp1242 (quote #(vector each-any)))))) ($sc-dispatch tmp1242 (quote ()))))) ($sc-dispatch tmp1242 (quote (any . any)))))) ($sc-dispatch tmp1242 (quote (any any))))) p1239))))) (cvt1238 pattern1236 0 (quote ())))))) (lambda (e1264 r1265 w1266 s1267 mod1268) (let ((e1269 (source-wrap143 e1264 w1266 s1267 mod1268))) ((lambda (tmp1270) ((lambda (tmp1271) (if tmp1271 (apply (lambda (_1272 val1273 key1274 m1275) (if (and-map (lambda (x1276) (if (id?114 x1276) (not (ellipsis?159 x1276)) #f)) key1274) (let ((x1278 (gen-var161 (quote tmp)))) (build-application81 s1267 (build-lambda90 #f (list (quote tmp)) (list x1278) #f (gen-syntax-case1191 (build-lexical-reference83 (quote value) #f (quote tmp) x1278) key1274 m1275 r1265 mod1268)) (list (chi150 val1273 r1265 (quote (())) mod1268)))) (syntax-violation (quote syntax-case) "invalid literals list" e1269))) tmp1271) (syntax-violation #f "source expression failed to match any pattern" tmp1270))) ($sc-dispatch tmp1270 (quote (any any each-any . each-any))))) e1269))))) (set! sc-expand (lambda (x1282 . rest1281) (if (if (pair? x1282) (equal? (car x1282) noexpand70) #f) (cadr x1282) (let ((m1283 (if (null? rest1281) (quote e) (car rest1281))) (esew1284 (if (let ((t1285 (null? rest1281))) (if t1285 t1285 (null? (cdr rest1281)))) (quote (eval)) (cadr rest1281)))) (with-fluid* *mode*71 m1283 (lambda () (chi-top149 x1282 (quote ()) (quote ((top))) m1283 esew1284 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1286) (nonsymbol-id?113 x1286))) (set! datum->syntax (lambda (id1287 datum1288) (make-syntax-object97 datum1288 (syntax-object-wrap100 id1287) #f))) (set! syntax->datum (lambda (x1289) (strip160 x1289 (quote (()))))) (set! generate-temporaries (lambda (ls1290) (begin (let ((x1291 ls1290)) (if (not (list? x1291)) (syntax-violation (quote generate-temporaries) "invalid argument" x1291))) (map (lambda (x1292) (wrap142 (gensym) (quote ((top))) #f)) ls1290)))) (set! free-identifier=? (lambda (x1293 y1294) (begin (let ((x1295 x1293)) (if (not (nonsymbol-id?113 x1295)) (syntax-violation (quote free-identifier=?) "invalid argument" x1295))) (let ((x1296 y1294)) (if (not (nonsymbol-id?113 x1296)) (syntax-violation (quote free-identifier=?) "invalid argument" x1296))) (free-id=?137 x1293 y1294)))) (set! bound-identifier=? (lambda (x1297 y1298) (begin (let ((x1299 x1297)) (if (not (nonsymbol-id?113 x1299)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1299))) (let ((x1300 y1298)) (if (not (nonsymbol-id?113 x1300)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1300))) (bound-id=?138 x1297 y1298)))) (set! syntax-violation (lambda (who1304 message1303 form1302 . subform1301) (begin (let ((x1305 who1304)) (if (not ((lambda (x1306) (let ((t1307 (not x1306))) (if t1307 t1307 (let ((t1308 (string? x1306))) (if t1308 t1308 (symbol? x1306)))))) x1305)) (syntax-violation (quote syntax-violation) "invalid argument" x1305))) (let ((x1309 message1303)) (if (not (string? x1309)) (syntax-violation (quote syntax-violation) "invalid argument" x1309))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1304 "~a: " "") "~a " (if (null? subform1301) "in ~a" "in subform `~s' of `~s'")) (let ((tail1310 (cons message1303 (map (lambda (x1311) (strip160 x1311 (quote (())))) (append subform1301 (list form1302)))))) (if who1304 (cons who1304 tail1310) tail1310)) #f)))) (letrec ((match1316 (lambda (e1317 p1318 w1319 r1320 mod1321) (if (not r1320) #f (if (eq? p1318 (quote any)) (cons (wrap142 e1317 w1319 mod1321) r1320) (if (syntax-object?98 e1317) (match*1315 (syntax-object-expression99 e1317) p1318 (join-wraps133 w1319 (syntax-object-wrap100 e1317)) r1320 (syntax-object-module101 e1317)) (match*1315 e1317 p1318 w1319 r1320 mod1321)))))) (match*1315 (lambda (e1322 p1323 w1324 r1325 mod1326) (if (null? p1323) (if (null? e1322) r1325 #f) (if (pair? p1323) (if (pair? e1322) (match1316 (car e1322) (car p1323) w1324 (match1316 (cdr e1322) (cdr p1323) w1324 r1325 mod1326) mod1326) #f) (if (eq? p1323 (quote each-any)) (let ((l1327 (match-each-any1313 e1322 w1324 mod1326))) (if l1327 (cons l1327 r1325) #f)) (let ((atom-key1328 (vector-ref p1323 0))) (if (memv atom-key1328 (quote (each))) (if (null? e1322) (match-empty1314 (vector-ref p1323 1) r1325) (let ((l1329 (match-each1312 e1322 (vector-ref p1323 1) w1324 mod1326))) (if l1329 (letrec ((collect1330 (lambda (l1331) (if (null? (car l1331)) r1325 (cons (map car l1331) (collect1330 (map cdr l1331))))))) (collect1330 l1329)) #f))) (if (memv atom-key1328 (quote (free-id))) (if (id?114 e1322) (if (free-id=?137 (wrap142 e1322 w1324 mod1326) (vector-ref p1323 1)) r1325 #f) #f) (if (memv atom-key1328 (quote (atom))) (if (equal? (vector-ref p1323 1) (strip160 e1322 w1324)) r1325 #f) (if (memv atom-key1328 (quote (vector))) (if (vector? e1322) (match1316 (vector->list e1322) (vector-ref p1323 1) w1324 r1325 mod1326) #f))))))))))) (match-empty1314 (lambda (p1332 r1333) (if (null? p1332) r1333 (if (eq? p1332 (quote any)) (cons (quote ()) r1333) (if (pair? p1332) (match-empty1314 (car p1332) (match-empty1314 (cdr p1332) r1333)) (if (eq? p1332 (quote each-any)) (cons (quote ()) r1333) (let ((atom-key1334 (vector-ref p1332 0))) (if (memv atom-key1334 (quote (each))) (match-empty1314 (vector-ref p1332 1) r1333) (if (memv atom-key1334 (quote (free-id atom))) r1333 (if (memv atom-key1334 (quote (vector))) (match-empty1314 (vector-ref p1332 1) r1333))))))))))) (match-each-any1313 (lambda (e1335 w1336 mod1337) (if (pair? e1335) (let ((l1338 (match-each-any1313 (cdr e1335) w1336 mod1337))) (if l1338 (cons (wrap142 (car e1335) w1336 mod1337) l1338) #f)) (if (null? e1335) (quote ()) (if (syntax-object?98 e1335) (match-each-any1313 (syntax-object-expression99 e1335) (join-wraps133 w1336 (syntax-object-wrap100 e1335)) mod1337) #f))))) (match-each1312 (lambda (e1339 p1340 w1341 mod1342) (if (pair? e1339) (let ((first1343 (match1316 (car e1339) p1340 w1341 (quote ()) mod1342))) (if first1343 (let ((rest1344 (match-each1312 (cdr e1339) p1340 w1341 mod1342))) (if rest1344 (cons first1343 rest1344) #f)) #f)) (if (null? e1339) (quote ()) (if (syntax-object?98 e1339) (match-each1312 (syntax-object-expression99 e1339) p1340 (join-wraps133 w1341 (syntax-object-wrap100 e1339)) (syntax-object-module101 e1339)) #f)))))) (set! $sc-dispatch (lambda (e1345 p1346) (if (eq? p1346 (quote any)) (list e1345) (if (syntax-object?98 e1345) (match*1315 (syntax-object-expression99 e1345) p1346 (syntax-object-wrap100 e1345) (quote ()) (syntax-object-module101 e1345)) (match*1315 e1345 p1346 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1347) ((lambda (tmp1348) ((lambda (tmp1349) (if tmp1349 (apply (lambda (_1350 e11351 e21352) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11351 e21352))) tmp1349) ((lambda (tmp1354) (if tmp1354 (apply (lambda (_1355 out1356 in1357 e11358 e21359) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1357 (quote ()) (list out1356 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11358 e21359))))) tmp1354) ((lambda (tmp1361) (if tmp1361 (apply (lambda (_1362 out1363 in1364 e11365 e21366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1364) (quote ()) (list out1363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11365 e21366))))) tmp1361) (syntax-violation #f "source expression failed to match any pattern" tmp1348))) ($sc-dispatch tmp1348 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1348 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1348 (quote (any () any . each-any))))) x1347)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1370) ((lambda (tmp1371) ((lambda (tmp1372) (if tmp1372 (apply (lambda (_1373 k1374 keyword1375 pattern1376 template1377) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1374 (map (lambda (tmp1380 tmp1379) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1379) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1380))) template1377 pattern1376)))))) tmp1372) (syntax-violation #f "source expression failed to match any pattern" tmp1371))) ($sc-dispatch tmp1371 (quote (any each-any . #(each ((any . any) any))))))) x1370)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1381) ((lambda (tmp1382) ((lambda (tmp1383) (if (if tmp1383 (apply (lambda (let*1384 x1385 v1386 e11387 e21388) (and-map identifier? x1385)) tmp1383) #f) (apply (lambda (let*1390 x1391 v1392 e11393 e21394) (letrec ((f1395 (lambda (bindings1396) (if (null? bindings1396) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11393 e21394))) ((lambda (tmp1400) ((lambda (tmp1401) (if tmp1401 (apply (lambda (body1402 binding1403) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1403) body1402)) tmp1401) (syntax-violation #f "source expression failed to match any pattern" tmp1400))) ($sc-dispatch tmp1400 (quote (any any))))) (list (f1395 (cdr bindings1396)) (car bindings1396))))))) (f1395 (map list x1391 v1392)))) tmp1383) (syntax-violation #f "source expression failed to match any pattern" tmp1382))) ($sc-dispatch tmp1382 (quote (any #(each (any any)) any . each-any))))) x1381)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1404) ((lambda (tmp1405) ((lambda (tmp1406) (if tmp1406 (apply (lambda (_1407 var1408 init1409 step1410 e01411 e11412 c1413) ((lambda (tmp1414) ((lambda (tmp1415) (if tmp1415 (apply (lambda (step1416) ((lambda (tmp1417) ((lambda (tmp1418) (if tmp1418 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1408 init1409) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01411) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1416))))))) tmp1418) ((lambda (tmp1423) (if tmp1423 (apply (lambda (e11424 e21425) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1408 init1409) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01411 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11424 e21425)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1416))))))) tmp1423) (syntax-violation #f "source expression failed to match any pattern" tmp1417))) ($sc-dispatch tmp1417 (quote (any . each-any)))))) ($sc-dispatch tmp1417 (quote ())))) e11412)) tmp1415) (syntax-violation #f "source expression failed to match any pattern" tmp1414))) ($sc-dispatch tmp1414 (quote each-any)))) (map (lambda (v1432 s1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda () v1432) tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (e1437) e1437) tmp1436) ((lambda (_1438) (syntax-violation (quote do) "bad step expression" orig-x1404 s1433)) tmp1434))) ($sc-dispatch tmp1434 (quote (any)))))) ($sc-dispatch tmp1434 (quote ())))) s1433)) var1408 step1410))) tmp1406) (syntax-violation #f "source expression failed to match any pattern" tmp1405))) ($sc-dispatch tmp1405 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1404)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1441 (lambda (x1445 y1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (x1449 y1450) ((lambda (tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda (dy1453) ((lambda (tmp1454) ((lambda (tmp1455) (if tmp1455 (apply (lambda (dx1456) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1456 dy1453))) tmp1455) ((lambda (_1457) (if (null? dy1453) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449 y1450))) tmp1454))) ($sc-dispatch tmp1454 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1449)) tmp1452) ((lambda (tmp1458) (if tmp1458 (apply (lambda (stuff1459) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1449 stuff1459))) tmp1458) ((lambda (else1460) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449 y1450)) tmp1451))) ($sc-dispatch tmp1451 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1451 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1450)) tmp1448) (syntax-violation #f "source expression failed to match any pattern" tmp1447))) ($sc-dispatch tmp1447 (quote (any any))))) (list x1445 y1446)))) (quasiappend1442 (lambda (x1461 y1462) ((lambda (tmp1463) ((lambda (tmp1464) (if tmp1464 (apply (lambda (x1465 y1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda () x1465) tmp1468) ((lambda (_1469) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465 y1466)) tmp1467))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1466)) tmp1464) (syntax-violation #f "source expression failed to match any pattern" tmp1463))) ($sc-dispatch tmp1463 (quote (any any))))) (list x1461 y1462)))) (quasivector1443 (lambda (x1470) ((lambda (tmp1471) ((lambda (x1472) ((lambda (tmp1473) ((lambda (tmp1474) (if tmp1474 (apply (lambda (x1475) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1475))) tmp1474) ((lambda (tmp1477) (if tmp1477 (apply (lambda (x1478) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1478)) tmp1477) ((lambda (_1480) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1472)) tmp1473))) ($sc-dispatch tmp1473 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1473 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1472)) tmp1471)) x1470))) (quasi1444 (lambda (p1481 lev1482) ((lambda (tmp1483) ((lambda (tmp1484) (if tmp1484 (apply (lambda (p1485) (if (= lev1482 0) p1485 (quasicons1441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1444 (list p1485) (- lev1482 1))))) tmp1484) ((lambda (tmp1486) (if (if tmp1486 (apply (lambda (args1487) (= lev1482 0)) tmp1486) #f) (apply (lambda (args1488) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1481 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1488))) tmp1486) ((lambda (tmp1489) (if tmp1489 (apply (lambda (p1490 q1491) (if (= lev1482 0) (quasiappend1442 p1490 (quasi1444 q1491 lev1482)) (quasicons1441 (quasicons1441 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1444 (list p1490) (- lev1482 1))) (quasi1444 q1491 lev1482)))) tmp1489) ((lambda (tmp1492) (if (if tmp1492 (apply (lambda (args1493 q1494) (= lev1482 0)) tmp1492) #f) (apply (lambda (args1495 q1496) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1481 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1495))) tmp1492) ((lambda (tmp1497) (if tmp1497 (apply (lambda (p1498) (quasicons1441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1444 (list p1498) (+ lev1482 1)))) tmp1497) ((lambda (tmp1499) (if tmp1499 (apply (lambda (p1500 q1501) (quasicons1441 (quasi1444 p1500 lev1482) (quasi1444 q1501 lev1482))) tmp1499) ((lambda (tmp1502) (if tmp1502 (apply (lambda (x1503) (quasivector1443 (quasi1444 x1503 lev1482))) tmp1502) ((lambda (p1505) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1505)) tmp1483))) ($sc-dispatch tmp1483 (quote #(vector each-any)))))) ($sc-dispatch tmp1483 (quote (any . any)))))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1483 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1483 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1481)))) (lambda (x1506) ((lambda (tmp1507) ((lambda (tmp1508) (if tmp1508 (apply (lambda (_1509 e1510) (quasi1444 e1510 0)) tmp1508) (syntax-violation #f "source expression failed to match any pattern" tmp1507))) ($sc-dispatch tmp1507 (quote (any any))))) x1506))))) +(define include (make-syncase-macro (quote macro) (lambda (x1511) (letrec ((read-file1512 (lambda (fn1513 k1514) (let ((p1515 (open-input-file fn1513))) (letrec ((f1516 (lambda (x1517) (if (eof-object? x1517) (begin (close-input-port p1515) (quote ())) (cons (datum->syntax k1514 x1517) (f1516 (read p1515))))))) (f1516 (read p1515))))))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (k1520 filename1521) (let ((fn1522 (syntax->datum filename1521))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (exp1525) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1525)) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote each-any)))) (read-file1512 fn1522 k1520)))) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any))))) x1511))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1527) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (_1530 e1531) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1527)) tmp1529) (syntax-violation #f "source expression failed to match any pattern" tmp1528))) ($sc-dispatch tmp1528 (quote (any any))))) x1527)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (_1535 e1536) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1532)) tmp1534) (syntax-violation #f "source expression failed to match any pattern" tmp1533))) ($sc-dispatch tmp1533 (quote (any any))))) x1532)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1537) ((lambda (tmp1538) ((lambda (tmp1539) (if tmp1539 (apply (lambda (_1540 e1541 m11542 m21543) ((lambda (tmp1544) ((lambda (body1545) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1541)) body1545)) tmp1544)) (letrec ((f1546 (lambda (clause1547 clauses1548) (if (null? clauses1548) ((lambda (tmp1550) ((lambda (tmp1551) (if tmp1551 (apply (lambda (e11552 e21553) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11552 e21553))) tmp1551) ((lambda (tmp1555) (if tmp1555 (apply (lambda (k1556 e11557 e21558) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1556)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11557 e21558)))) tmp1555) ((lambda (_1561) (syntax-violation (quote case) "bad clause" x1537 clause1547)) tmp1550))) ($sc-dispatch tmp1550 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1550 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1547) ((lambda (tmp1562) ((lambda (rest1563) ((lambda (tmp1564) ((lambda (tmp1565) (if tmp1565 (apply (lambda (k1566 e11567 e21568) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1566)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11567 e21568)) rest1563)) tmp1565) ((lambda (_1571) (syntax-violation (quote case) "bad clause" x1537 clause1547)) tmp1564))) ($sc-dispatch tmp1564 (quote (each-any any . each-any))))) clause1547)) tmp1562)) (f1546 (car clauses1548) (cdr clauses1548))))))) (f1546 m11542 m21543)))) tmp1539) (syntax-violation #f "source expression failed to match any pattern" tmp1538))) ($sc-dispatch tmp1538 (quote (any any any . each-any))))) x1537)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1572) ((lambda (tmp1573) ((lambda (tmp1574) (if tmp1574 (apply (lambda (_1575 e1576) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1576)) (list (cons _1575 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1576 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1574) (syntax-violation #f "source expression failed to match any pattern" tmp1573))) ($sc-dispatch tmp1573 (quote (any any))))) x1572)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 735f56423..0398815d1 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -191,19 +191,6 @@ ;;; The implementation of generate-temporaries assumes that it is possible ;;; to generate globally unique symbols (gensyms). -;;; The input to sc-expand may contain "annotations" describing, e.g., the -;;; source file and character position from where each object was read if -;;; it was read from a file. These annotations are handled properly by -;;; sc-expand only if the annotation? hook (see hooks below) is implemented -;;; properly and the operators make-annotation, annotation-expression, -;;; annotation-source, annotation-stripped, and set-annotation-stripped! -;;; are supplied. If annotations are supplied, the proper annotation -;;; source is passed to the various output constructors, allowing -;;; implementations to accurately correlate source and expanded code. -;;; Contact one of the authors for details if you wish to make use of -;;; this feature. - - ;;; Bootstrapping: @@ -532,22 +519,15 @@ (define-structure (syntax-object expression wrap module)) -(define-syntax unannotate - (syntax-rules () - ((_ x) - (let ((e x)) - (if (annotation? e) - (annotation-expression e) - e))))) - (define-syntax no-source (identifier-syntax #f)) (define source-annotation (lambda (x) (cond - ((annotation? x) (annotation-source x)) - ((syntax-object? x) (source-annotation (syntax-object-expression x))) - (else no-source)))) + ((syntax-object? x) + (source-annotation (syntax-object-expression x))) + ((pair? x) (source-properties x)) + (else #f)))) (define-syntax arg-check (syntax-rules () @@ -674,29 +654,30 @@ (define nonsymbol-id? (lambda (x) (and (syntax-object? x) - (symbol? (unannotate (syntax-object-expression x)))))) + (symbol? (syntax-object-expression x))))) (define id? (lambda (x) (cond ((symbol? x) #t) - ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x)))) - ((annotation? x) (symbol? (annotation-expression x))) + ((syntax-object? x) (symbol? (syntax-object-expression x))) (else #f)))) (define-syntax id-sym-name (syntax-rules () ((_ e) (let ((x e)) - (unannotate (if (syntax-object? x) (syntax-object-expression x) x)))))) + (if (syntax-object? x) + (syntax-object-expression x) + x))))) (define id-sym-name&marks (lambda (x w) (if (syntax-object? x) (values - (unannotate (syntax-object-expression x)) - (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) - (values (unannotate x) (wrap-marks w))))) + (syntax-object-expression x) + (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) + (values x (wrap-marks w))))) ;;; syntax object wraps @@ -762,7 +743,7 @@ ; must receive ids with complete wraps (lambda (ribcage id label) (set-ribcage-symnames! ribcage - (cons (unannotate (syntax-object-expression id)) + (cons (syntax-object-expression id) (ribcage-symnames ribcage))) (set-ribcage-marks! ribcage (cons (wrap-marks (syntax-object-wrap id)) @@ -862,7 +843,7 @@ ((symbol? id) (or (first (search id (wrap-subst w) (wrap-marks w))) id)) ((syntax-object? id) - (let ((id (unannotate (syntax-object-expression id))) + (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) (call-with-values (lambda () (search id (wrap-subst w) marks)) @@ -870,9 +851,6 @@ (or new-id (first (search id (wrap-subst w1) marks)) id)))))) - ((annotation? id) - (let ((id (unannotate id))) - (or (first (search id (wrap-subst w) (wrap-marks w))) id))) (else (syntax-violation 'id-var-name "invalid id" id))))) ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y) @@ -890,11 +868,11 @@ (define bound-id=? (lambda (i j) (if (and (syntax-object? i) (syntax-object? j)) - (and (eq? (unannotate (syntax-object-expression i)) - (unannotate (syntax-object-expression j))) + (and (eq? (syntax-object-expression i) + (syntax-object-expression j)) (same-marks? (wrap-marks (syntax-object-wrap i)) (wrap-marks (syntax-object-wrap j)))) - (eq? (unannotate i) (unannotate j))))) + (eq? i j)))) ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids @@ -944,7 +922,15 @@ (define source-wrap (lambda (x w s defmod) - (wrap (if s (make-annotation x s #f) x) w defmod))) + (wrap (if s + (begin + (if (not (pair? x)) + (error "bad source-wrap!!!" x s)) + (set-source-properties! x s) + x) + x) + w + defmod))) ;;; expanding @@ -1117,8 +1103,6 @@ r (join-wraps w (syntax-object-wrap e)) no-source rib (or (syntax-object-module e) mod))) - ((annotation? e) - (syntax-type (annotation-expression e) r w (annotation-source e) rib mod)) ((self-evaluating? e) (values 'constant #f e w s mod)) (else (values 'other #f e w s mod))))) @@ -1131,7 +1115,7 @@ (if (eq? m 'c&e) (top-level-eval-hook x mod)) x)))) (call-with-values - (lambda () (syntax-type e r w no-source #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod)) (lambda (type value e w s mod) (case type ((begin-form) @@ -1207,7 +1191,7 @@ (define chi (lambda (e r w mod) (call-with-values - (lambda () (syntax-type e r w no-source #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod)) (lambda (type value e w s mod) (chi-expr type value e r w s mod))))) @@ -1362,7 +1346,7 @@ (syntax-violation #f "no expressions in body" outer-form) (let ((e (cdar body)) (er (caar body))) (call-with-values - (lambda () (syntax-type e er empty-wrap no-source ribcage mod)) + (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod)) (lambda (type value e w s mod) (case type ((define-form) @@ -1527,32 +1511,8 @@ ;;; data -;;; strips all annotations from potentially circular reader output - -(define strip-annotation - (lambda (x parent) - (cond - ((pair? x) - (let ((new (cons #f #f))) - (if parent (set-annotation-stripped! parent new)) - (set-car! new (strip-annotation (car x) #f)) - (set-cdr! new (strip-annotation (cdr x) #f)) - new)) - ((annotation? x) - (or (annotation-stripped x) - (strip-annotation (annotation-expression x) x))) - ((vector? x) - (let ((new (make-vector (vector-length x)))) - (if parent (set-annotation-stripped! parent new)) - (let loop ((i (- (vector-length x) 1))) - (unless (fx< i 0) - (vector-set! new i (strip-annotation (vector-ref x i) #f)) - (loop (fx- i 1)))) - new)) - (else x)))) - -;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly -;;; on an annotation, strips the annotation as well. +;;; strips syntax-objects down to top-wrap +;;; ;;; since only the head of a list is annotated by the reader, not each pair ;;; in the spine, we also check for pairs whose cars are annotated in case ;;; we've been passed the cdr of an annotated list @@ -1560,32 +1520,28 @@ (define strip (lambda (x w) (if (top-marked? w) - (if (or (annotation? x) (and (pair? x) (annotation? (car x)))) - (strip-annotation x #f) - x) + x (let f ((x x)) (cond - ((syntax-object? x) - (strip (syntax-object-expression x) (syntax-object-wrap x))) - ((pair? x) - (let ((a (f (car x))) (d (f (cdr x)))) - (if (and (eq? a (car x)) (eq? d (cdr x))) - x - (cons a d)))) - ((vector? x) - (let ((old (vector->list x))) - (let ((new (map f old))) - (if (and-map* eq? old new) x (list->vector new))))) - (else x)))))) + ((syntax-object? x) + (strip (syntax-object-expression x) (syntax-object-wrap x))) + ((pair? x) + (let ((a (f (car x))) (d (f (cdr x)))) + (if (and (eq? a (car x)) (eq? d (cdr x))) + x + (cons a d)))) + ((vector? x) + (let ((old (vector->list x))) + (let ((new (map f old))) + (if (and-map* eq? old new) x (list->vector new))))) + (else x)))))) ;;; lexical variables (define gen-var (lambda (id) (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (if (annotation? id) - (build-lexical-var (annotation-source id) (annotation-expression id)) - (build-lexical-var no-source id))))) + (build-lexical-var no-source id)))) (define lambda-var-list (lambda (vars) @@ -1598,8 +1554,6 @@ (lvl (syntax-object-expression vars) ls (join-wraps w (syntax-object-wrap vars)))) - ((annotation? vars) - (lvl (annotation-expression vars) ls w)) ; include anything else to be caught by subsequent error ; checking (else (cons vars ls)))))) @@ -2193,35 +2147,31 @@ (define match-each (lambda (e p w mod) (cond - ((annotation? e) - (match-each (annotation-expression e) p w mod)) - ((pair? e) - (let ((first (match (car e) p w '() mod))) - (and first - (let ((rest (match-each (cdr e) p w mod))) - (and rest (cons first rest)))))) - ((null? e) '()) - ((syntax-object? e) - (match-each (syntax-object-expression e) - p - (join-wraps w (syntax-object-wrap e)) - (syntax-object-module e))) - (else #f)))) + ((pair? e) + (let ((first (match (car e) p w '() mod))) + (and first + (let ((rest (match-each (cdr e) p w mod))) + (and rest (cons first rest)))))) + ((null? e) '()) + ((syntax-object? e) + (match-each (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + (syntax-object-module e))) + (else #f)))) (define match-each-any (lambda (e w mod) (cond - ((annotation? e) - (match-each-any (annotation-expression e) w mod)) - ((pair? e) - (let ((l (match-each-any (cdr e) w mod))) - (and l (cons (wrap (car e) w mod) l)))) - ((null? e) '()) - ((syntax-object? e) - (match-each-any (syntax-object-expression e) - (join-wraps w (syntax-object-wrap e)) - mod)) - (else #f)))) + ((pair? e) + (let ((l (match-each-any (cdr e) w mod))) + (and l (cons (wrap (car e) w mod) l)))) + ((null? e) '()) + ((syntax-object? e) + (match-each-any (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)) + mod)) + (else #f)))) (define match-empty (lambda (p r) @@ -2270,21 +2220,21 @@ ((eq? p 'any) (cons (wrap e w mod) r)) ((syntax-object? e) (match* - (unannotate (syntax-object-expression e)) - p - (join-wraps w (syntax-object-wrap e)) - r - (syntax-object-module e))) - (else (match* (unannotate e) p w r mod))))) + (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + r + (syntax-object-module e))) + (else (match* e p w r mod))))) (set! $sc-dispatch (lambda (e p) (cond ((eq? p 'any) (list e)) ((syntax-object? e) - (match* (unannotate (syntax-object-expression e)) - p (syntax-object-wrap e) '() (syntax-object-module e))) - (else (match* (unannotate e) p empty-wrap '() #f))))) + (match* (syntax-object-expression e) + p (syntax-object-wrap e) '() (syntax-object-module e))) + (else (match* e p empty-wrap '() #f))))) )) ) From 0e7b72a8fefc27d67623b11659372b7ac37b7a58 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 21:12:42 +0200 Subject: [PATCH 153/375] source location tracking in psyntax, booya! * module/ice-9/psyntax.scm (source-annotation): Return #f if source-properties returns null. (source-wrap): Rework a bit. (syntax-type): Don't throw away source info for wrapped expressions. Can has source location info, fools! (chi-body): Correctly propagate source info for body subforms. (syntax): Remove special case for map, it doesn't apply (ahem) for Guile. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 28 +++++++++------------------- 2 files changed, 20 insertions(+), 30 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index b1646fe9d..f33f49286 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars286) (letrec ((lvl287 (lambda (vars288 ls289 w290) (if (pair? vars288) (lvl287 (cdr vars288) (cons (wrap142 (car vars288) w290 #f) ls289) w290) (if (id?114 vars288) (cons (wrap142 vars288 w290 #f) ls289) (if (null? vars288) ls289 (if (syntax-object?98 vars288) (lvl287 (syntax-object-expression99 vars288) ls289 (join-wraps133 w290 (syntax-object-wrap100 vars288))) (cons vars288 ls289)))))))) (lvl287 vars286 (quote ()) (quote (())))))) (gen-var161 (lambda (id291) (let ((id292 (if (syntax-object?98 id291) (syntax-object-expression99 id291) id291))) (gensym (symbol->string id292))))) (strip160 (lambda (x293 w294) (if (memq (quote top) (wrap-marks117 w294)) x293 (letrec ((f295 (lambda (x296) (if (syntax-object?98 x296) (strip160 (syntax-object-expression99 x296) (syntax-object-wrap100 x296)) (if (pair? x296) (let ((a297 (f295 (car x296))) (d298 (f295 (cdr x296)))) (if (if (eq? a297 (car x296)) (eq? d298 (cdr x296)) #f) x296 (cons a297 d298))) (if (vector? x296) (let ((old299 (vector->list x296))) (let ((new300 (map f295 old299))) (if (and-map*17 eq? old299 new300) x296 (list->vector new300)))) x296)))))) (f295 x293))))) (ellipsis?159 (lambda (x301) (if (nonsymbol-id?113 x301) (free-id=?137 x301 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded302 mod303) (let ((p304 (local-eval-hook77 expanded302 mod303))) (if (procedure? p304) p304 (syntax-violation #f "nonprocedure transformer" p304))))) (chi-local-syntax156 (lambda (rec?305 e306 r307 w308 s309 mod310 k311) ((lambda (tmp312) ((lambda (tmp313) (if tmp313 (apply (lambda (_314 id315 val316 e1317 e2318) (let ((ids319 id315)) (if (not (valid-bound-ids?139 ids319)) (syntax-violation #f "duplicate bound keyword" e306) (let ((labels321 (gen-labels120 ids319))) (let ((new-w322 (make-binding-wrap131 ids319 labels321 w308))) (k311 (cons e1317 e2318) (extend-env108 labels321 (let ((w324 (if rec?305 new-w322 w308)) (trans-r325 (macros-only-env110 r307))) (map (lambda (x326) (cons (quote macro) (eval-local-transformer157 (chi150 x326 trans-r325 w324 mod310) mod310))) val316)) r307) new-w322 s309 mod310)))))) tmp313) ((lambda (_328) (syntax-violation #f "bad local syntax definition" (source-wrap143 e306 w308 s309 mod310))) tmp312))) ($sc-dispatch tmp312 (quote (any #(each (any any)) any . each-any))))) e306))) (chi-lambda-clause155 (lambda (e329 docstring330 c331 r332 w333 mod334 k335) ((lambda (tmp336) ((lambda (tmp337) (if (if tmp337 (apply (lambda (args338 doc339 e1340 e2341) (if (string? (syntax->datum doc339)) (not docstring330) #f)) tmp337) #f) (apply (lambda (args342 doc343 e1344 e2345) (chi-lambda-clause155 e329 doc343 (cons args342 (cons e1344 e2345)) r332 w333 mod334 k335)) tmp337) ((lambda (tmp347) (if tmp347 (apply (lambda (id348 e1349 e2350) (let ((ids351 id348)) (if (not (valid-bound-ids?139 ids351)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels353 (gen-labels120 ids351)) (new-vars354 (map gen-var161 ids351))) (k335 (map syntax->datum ids351) new-vars354 (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1349 e2350) e329 (extend-var-env109 labels353 new-vars354 r332) (make-binding-wrap131 ids351 labels353 w333) mod334)))))) tmp347) ((lambda (tmp356) (if tmp356 (apply (lambda (ids357 e1358 e2359) (let ((old-ids360 (lambda-var-list162 ids357))) (if (not (valid-bound-ids?139 old-ids360)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels361 (gen-labels120 old-ids360)) (new-vars362 (map gen-var161 old-ids360))) (k335 (letrec ((f363 (lambda (ls1364 ls2365) (if (null? ls1364) (syntax->datum ls2365) (f363 (cdr ls1364) (cons (syntax->datum (car ls1364)) ls2365)))))) (f363 (cdr old-ids360) (car old-ids360))) (letrec ((f366 (lambda (ls1367 ls2368) (if (null? ls1367) ls2368 (f366 (cdr ls1367) (cons (car ls1367) ls2368)))))) (f366 (cdr new-vars362) (car new-vars362))) (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1358 e2359) e329 (extend-var-env109 labels361 new-vars362 r332) (make-binding-wrap131 old-ids360 labels361 w333) mod334)))))) tmp356) ((lambda (_370) (syntax-violation (quote lambda) "bad lambda" e329)) tmp336))) ($sc-dispatch tmp336 (quote (any any . each-any)))))) ($sc-dispatch tmp336 (quote (each-any any . each-any)))))) ($sc-dispatch tmp336 (quote (any any any . each-any))))) c331))) (chi-body154 (lambda (body371 outer-form372 r373 w374 mod375) (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) (let ((ribcage377 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w378 (make-wrap116 (wrap-marks117 w374) (cons ribcage377 (wrap-subst118 w374))))) (letrec ((parse379 (lambda (body380 ids381 labels382 var-ids383 vars384 vals385 bindings386) (if (null? body380) (syntax-violation #f "no expressions in body" outer-form372) (let ((e388 (cdar body380)) (er389 (caar body380))) (call-with-values (lambda () (syntax-type148 e388 er389 (quote (())) (source-annotation105 e388) ribcage377 mod375)) (lambda (type390 value391 e392 w393 s394 mod395) (if (memv type390 (quote (define-form))) (let ((id396 (wrap142 value391 w393 mod395)) (label397 (gen-label119))) (let ((var398 (gen-var161 id396))) (begin (extend-ribcage!130 ribcage377 id396 label397) (parse379 (cdr body380) (cons id396 ids381) (cons label397 labels382) (cons id396 var-ids383) (cons var398 vars384) (cons (cons er389 (wrap142 e392 w393 mod395)) vals385) (cons (cons (quote lexical) var398) bindings386))))) (if (memv type390 (quote (define-syntax-form))) (let ((id399 (wrap142 value391 w393 mod395)) (label400 (gen-label119))) (begin (extend-ribcage!130 ribcage377 id399 label400) (parse379 (cdr body380) (cons id399 ids381) (cons label400 labels382) var-ids383 vars384 vals385 (cons (cons (quote macro) (cons er389 (wrap142 e392 w393 mod395))) bindings386)))) (if (memv type390 (quote (begin-form))) ((lambda (tmp401) ((lambda (tmp402) (if tmp402 (apply (lambda (_403 e1404) (parse379 (letrec ((f405 (lambda (forms406) (if (null? forms406) (cdr body380) (cons (cons er389 (wrap142 (car forms406) w393 mod395)) (f405 (cdr forms406))))))) (f405 e1404)) ids381 labels382 var-ids383 vars384 vals385 bindings386)) tmp402) (syntax-violation #f "source expression failed to match any pattern" tmp401))) ($sc-dispatch tmp401 (quote (any . each-any))))) e392) (if (memv type390 (quote (local-syntax-form))) (chi-local-syntax156 value391 e392 er389 w393 s394 mod395 (lambda (forms408 er409 w410 s411 mod412) (parse379 (letrec ((f413 (lambda (forms414) (if (null? forms414) (cdr body380) (cons (cons er409 (wrap142 (car forms414) w410 mod412)) (f413 (cdr forms414))))))) (f413 forms408)) ids381 labels382 var-ids383 vars384 vals385 bindings386))) (if (null? ids381) (build-sequence93 #f (map (lambda (x415) (chi150 (cdr x415) (car x415) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))) (begin (if (not (valid-bound-ids?139 ids381)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form372)) (letrec ((loop416 (lambda (bs417 er-cache418 r-cache419) (if (not (null? bs417)) (let ((b420 (car bs417))) (if (eq? (car b420) (quote macro)) (let ((er421 (cadr b420))) (let ((r-cache422 (if (eq? er421 er-cache418) r-cache419 (macros-only-env110 er421)))) (begin (set-cdr! b420 (eval-local-transformer157 (chi150 (cddr b420) r-cache422 (quote (())) mod395) mod395)) (loop416 (cdr bs417) er421 r-cache422)))) (loop416 (cdr bs417) er-cache418 r-cache419))))))) (loop416 bindings386 #f #f)) (set-cdr! r376 (extend-env108 labels382 bindings386 (cdr r376))) (build-letrec96 #f (map syntax->datum var-ids383) vars384 (map (lambda (x423) (chi150 (cdr x423) (car x423) (quote (())) mod395)) vals385) (build-sequence93 #f (map (lambda (x424) (chi150 (cdr x424) (car x424) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))))))))))))))))) (parse379 (map (lambda (x387) (cons r376 (wrap142 x387 w378 mod375))) body371) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p425 e426 r427 w428 rib429 mod430) (letrec ((rebuild-macro-output431 (lambda (x432 m433) (if (pair? x432) (cons (rebuild-macro-output431 (car x432) m433) (rebuild-macro-output431 (cdr x432) m433)) (if (syntax-object?98 x432) (let ((w434 (syntax-object-wrap100 x432))) (let ((ms435 (wrap-marks117 w434)) (s436 (wrap-subst118 w434))) (if (if (pair? ms435) (eq? (car ms435) #f) #f) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cdr ms435) (if rib429 (cons rib429 (cdr s436)) (cdr s436))) (syntax-object-module101 x432)) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cons m433 ms435) (if rib429 (cons rib429 (cons (quote shift) s436)) (cons (quote shift) s436))) (let ((pmod437 (procedure-module p425))) (if pmod437 (cons (quote hygiene) (module-name pmod437)) (quote (hygiene guile)))))))) (if (vector? x432) (let ((n438 (vector-length x432))) (let ((v439 (make-vector n438))) (letrec ((loop440 (lambda (i441) (if (fx=74 i441 n438) (begin (if #f #f) v439) (begin (vector-set! v439 i441 (rebuild-macro-output431 (vector-ref x432 i441) m433)) (loop440 (fx+72 i441 1))))))) (loop440 0)))) (if (symbol? x432) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e426 w428 s mod430) x432) x432))))))) (rebuild-macro-output431 (p425 (wrap142 e426 (anti-mark129 w428) mod430)) (string #\m))))) (chi-application152 (lambda (x442 e443 r444 w445 s446 mod447) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (e0450 e1451) (build-application81 s446 x442 (map (lambda (e452) (chi150 e452 r444 w445 mod447)) e1451))) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e443))) (chi-expr151 (lambda (type454 value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (lexical))) (build-lexical-reference83 (quote value) s459 e456 value455) (if (memv type454 (quote (core external-macro))) (value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (module-ref))) (call-with-values (lambda () (value455 e456)) (lambda (id461 mod462) (build-global-reference86 s459 id461 mod462))) (if (memv type454 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e456)) (car e456) value455) e456 r457 w458 s459 mod460) (if (memv type454 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e456)) value455 (if (syntax-object?98 (car e456)) (syntax-object-module101 (car e456)) mod460)) e456 r457 w458 s459 mod460) (if (memv type454 (quote (constant))) (build-data92 s459 (strip160 (source-wrap143 e456 w458 s459 mod460) (quote (())))) (if (memv type454 (quote (global))) (build-global-reference86 s459 value455 mod460) (if (memv type454 (quote (call))) (chi-application152 (chi150 (car e456) r457 w458 mod460) e456 r457 w458 s459 mod460) (if (memv type454 (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466 e2467) (chi-sequence144 (cons e1466 e2467) r457 w458 s459 mod460)) tmp464) (syntax-violation #f "source expression failed to match any pattern" tmp463))) ($sc-dispatch tmp463 (quote (any any . each-any))))) e456) (if (memv type454 (quote (local-syntax-form))) (chi-local-syntax156 value455 e456 r457 w458 s459 mod460 chi-sequence144) (if (memv type454 (quote (eval-when-form))) ((lambda (tmp469) ((lambda (tmp470) (if tmp470 (apply (lambda (_471 x472 e1473 e2474) (let ((when-list475 (chi-when-list147 e456 x472 w458))) (if (memq (quote eval) when-list475) (chi-sequence144 (cons e1473 e2474) r457 w458 s459 mod460) (chi-void158)))) tmp470) (syntax-violation #f "source expression failed to match any pattern" tmp469))) ($sc-dispatch tmp469 (quote (any each-any any . each-any))))) e456) (if (memv type454 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e456 (wrap142 value455 w458 mod460)) (if (memv type454 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e456 w458 s459 mod460)) (if (memv type454 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e456 w458 s459 mod460)) (syntax-violation #f "unexpected syntax" (source-wrap143 e456 w458 s459 mod460)))))))))))))))))) (chi150 (lambda (e478 r479 w480 mod481) (call-with-values (lambda () (syntax-type148 e478 r479 w480 (source-annotation105 e478) #f mod481)) (lambda (type482 value483 e484 w485 s486 mod487) (chi-expr151 type482 value483 e484 r479 w485 s486 mod487))))) (chi-top149 (lambda (e488 r489 w490 m491 esew492 mod493) (call-with-values (lambda () (syntax-type148 e488 r489 w490 (source-annotation105 e488) #f mod493)) (lambda (type501 value502 e503 w504 s505 mod506) (if (memv type501 (quote (begin-form))) ((lambda (tmp507) ((lambda (tmp508) (if tmp508 (apply (lambda (_509) (chi-void158)) tmp508) ((lambda (tmp510) (if tmp510 (apply (lambda (_511 e1512 e2513) (chi-top-sequence145 (cons e1512 e2513) r489 w504 s505 m491 esew492 mod506)) tmp510) (syntax-violation #f "source expression failed to match any pattern" tmp507))) ($sc-dispatch tmp507 (quote (any any . each-any)))))) ($sc-dispatch tmp507 (quote (any))))) e503) (if (memv type501 (quote (local-syntax-form))) (chi-local-syntax156 value502 e503 r489 w504 s505 mod506 (lambda (body515 r516 w517 s518 mod519) (chi-top-sequence145 body515 r516 w517 s518 m491 esew492 mod519))) (if (memv type501 (quote (eval-when-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 x523 e1524 e2525) (let ((when-list526 (chi-when-list147 e503 x523 w504)) (body527 (cons e1524 e2525))) (if (eq? m491 (quote e)) (if (memq (quote eval) when-list526) (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) (chi-void158)) (if (memq (quote load) when-list526) (if (let ((t530 (memq (quote compile) when-list526))) (if t530 t530 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (chi-top-sequence145 body527 r489 w504 s505 (quote c&e) (quote (compile load)) mod506) (if (memq m491 (quote (c c&e))) (chi-top-sequence145 body527 r489 w504 s505 (quote c) (quote (load)) mod506) (chi-void158))) (if (let ((t531 (memq (quote compile) when-list526))) (if t531 t531 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) mod506) (chi-void158)) (chi-void158)))))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any each-any any . each-any))))) e503) (if (memv type501 (quote (define-syntax-form))) (let ((n532 (id-var-name136 value502 w504)) (r533 (macros-only-env110 r489))) (if (memv m491 (quote (c))) (if (memq (quote compile) esew492) (let ((e534 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e534 mod506) (if (memq (quote load) esew492) e534 (chi-void158)))) (if (memq (quote load) esew492) (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) (chi-void158))) (if (memv m491 (quote (c&e))) (let ((e535 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e535 mod506) e535)) (begin (if (memq (quote eval) esew492) (top-level-eval-hook76 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) mod506)) (chi-void158))))) (if (memv type501 (quote (define-form))) (let ((n536 (id-var-name136 value502 w504))) (let ((type537 (binding-type106 (lookup111 n536 r489 mod506)))) (if (memv type537 (quote (global core macro module-ref))) (let ((x538 (build-global-definition89 s505 n536 (chi150 e503 r489 w504 mod506)))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x538 mod506)) x538)) (if (memv type537 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e503 (wrap142 value502 w504 mod506)) (syntax-violation #f "cannot define keyword at top level" e503 (wrap142 value502 w504 mod506)))))) (let ((x539 (chi-expr151 type501 value502 e503 r489 w504 s505 mod506))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x539 mod506)) x539))))))))))) (syntax-type148 (lambda (e540 r541 w542 s543 rib544 mod545) (if (symbol? e540) (let ((n546 (id-var-name136 e540 w542))) (let ((b547 (lookup111 n546 r541 mod545))) (let ((type548 (binding-type106 b547))) (if (memv type548 (quote (lexical))) (values type548 (binding-value107 b547) e540 w542 s543 mod545) (if (memv type548 (quote (global))) (values type548 n546 e540 w542 s543 mod545) (if (memv type548 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b547) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545) (values type548 (binding-value107 b547) e540 w542 s543 mod545))))))) (if (pair? e540) (let ((first549 (car e540))) (if (id?114 first549) (let ((n550 (id-var-name136 first549 w542))) (let ((b551 (lookup111 n550 r541 (let ((t552 (if (syntax-object?98 first549) (syntax-object-module101 first549) #f))) (if t552 t552 mod545))))) (let ((type553 (binding-type106 b551))) (if (memv type553 (quote (lexical))) (values (quote lexical-call) (binding-value107 b551) e540 w542 s543 mod545) (if (memv type553 (quote (global))) (values (quote global-call) n550 e540 w542 s543 mod545) (if (memv type553 (quote (macro))) (syntax-type148 (chi-macro153 (binding-value107 b551) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545) (if (memv type553 (quote (core external-macro module-ref))) (values type553 (binding-value107 b551) e540 w542 s543 mod545) (if (memv type553 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value107 b551) e540 w542 s543 mod545) (if (memv type553 (quote (begin))) (values (quote begin-form) #f e540 w542 s543 mod545) (if (memv type553 (quote (eval-when))) (values (quote eval-when-form) #f e540 w542 s543 mod545) (if (memv type553 (quote (define))) ((lambda (tmp554) ((lambda (tmp555) (if (if tmp555 (apply (lambda (_556 name557 val558) (id?114 name557)) tmp555) #f) (apply (lambda (_559 name560 val561) (values (quote define-form) name560 val561 w542 s543 mod545)) tmp555) ((lambda (tmp562) (if (if tmp562 (apply (lambda (_563 name564 args565 e1566 e2567) (if (id?114 name564) (valid-bound-ids?139 (lambda-var-list162 args565)) #f)) tmp562) #f) (apply (lambda (_568 name569 args570 e1571 e2572) (values (quote define-form) (wrap142 name569 w542 mod545) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args570 (cons e1571 e2572)) w542 mod545)) (quote (())) s543 mod545)) tmp562) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576) (id?114 name576)) tmp574) #f) (apply (lambda (_577 name578) (values (quote define-form) (wrap142 name578 w542 mod545) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s543 mod545)) tmp574) (syntax-violation #f "source expression failed to match any pattern" tmp554))) ($sc-dispatch tmp554 (quote (any any)))))) ($sc-dispatch tmp554 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp554 (quote (any any any))))) e540) (if (memv type553 (quote (define-syntax))) ((lambda (tmp579) ((lambda (tmp580) (if (if tmp580 (apply (lambda (_581 name582 val583) (id?114 name582)) tmp580) #f) (apply (lambda (_584 name585 val586) (values (quote define-syntax-form) name585 val586 w542 s543 mod545)) tmp580) (syntax-violation #f "source expression failed to match any pattern" tmp579))) ($sc-dispatch tmp579 (quote (any any any))))) e540) (values (quote call) #f e540 w542 s543 mod545))))))))))))) (values (quote call) #f e540 w542 s543 mod545))) (if (syntax-object?98 e540) (syntax-type148 (syntax-object-expression99 e540) r541 (join-wraps133 w542 (syntax-object-wrap100 e540)) #f rib544 (let ((t587 (syntax-object-module101 e540))) (if t587 t587 mod545))) (if (self-evaluating? e540) (values (quote constant) #f e540 w542 s543 mod545) (values (quote other) #f e540 w542 s543 mod545))))))) (chi-when-list147 (lambda (e588 when-list589 w590) (letrec ((f591 (lambda (when-list592 situations593) (if (null? when-list592) situations593 (f591 (cdr when-list592) (cons (let ((x594 (car when-list592))) (if (free-id=?137 x594 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x594 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x594 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e588 (wrap142 x594 w590 #f)))))) situations593)))))) (f591 when-list589 (quote ()))))) (chi-install-global146 (lambda (name595 e596) (build-global-definition89 #f name595 (if (let ((v597 (module-variable (current-module) name595))) (if v597 (if (variable-bound? v597) (if (macro? (variable-ref v597)) (not (eq? (macro-type (variable-ref v597)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name595))) (build-data92 #f (quote macro)) e596)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e596)))))) (chi-top-sequence145 (lambda (body598 r599 w600 s601 m602 esew603 mod604) (build-sequence93 s601 (letrec ((dobody605 (lambda (body606 r607 w608 m609 esew610 mod611) (if (null? body606) (quote ()) (let ((first612 (chi-top149 (car body606) r607 w608 m609 esew610 mod611))) (cons first612 (dobody605 (cdr body606) r607 w608 m609 esew610 mod611))))))) (dobody605 body598 r599 w600 m602 esew603 mod604))))) (chi-sequence144 (lambda (body613 r614 w615 s616 mod617) (build-sequence93 s616 (letrec ((dobody618 (lambda (body619 r620 w621 mod622) (if (null? body619) (quote ()) (let ((first623 (chi150 (car body619) r620 w621 mod622))) (cons first623 (dobody618 (cdr body619) r620 w621 mod622))))))) (dobody618 body613 r614 w615 mod617))))) (source-wrap143 (lambda (x624 w625 s626 defmod627) (wrap142 (if s626 (begin (if (not (pair? x624)) (error "bad source-wrap!!!" x624 s626)) (set-source-properties! x624 s626) x624) x624) w625 defmod627))) (wrap142 (lambda (x628 w629 defmod630) (if (if (null? (wrap-marks117 w629)) (null? (wrap-subst118 w629)) #f) x628 (if (syntax-object?98 x628) (make-syntax-object97 (syntax-object-expression99 x628) (join-wraps133 w629 (syntax-object-wrap100 x628)) (syntax-object-module101 x628)) (if (null? x628) x628 (make-syntax-object97 x628 w629 defmod630)))))) (bound-id-member?141 (lambda (x631 list632) (if (not (null? list632)) (let ((t633 (bound-id=?138 x631 (car list632)))) (if t633 t633 (bound-id-member?141 x631 (cdr list632)))) #f))) (distinct-bound-ids?140 (lambda (ids634) (letrec ((distinct?635 (lambda (ids636) (let ((t637 (null? ids636))) (if t637 t637 (if (not (bound-id-member?141 (car ids636) (cdr ids636))) (distinct?635 (cdr ids636)) #f)))))) (distinct?635 ids634)))) (valid-bound-ids?139 (lambda (ids638) (if (letrec ((all-ids?639 (lambda (ids640) (let ((t641 (null? ids640))) (if t641 t641 (if (id?114 (car ids640)) (all-ids?639 (cdr ids640)) #f)))))) (all-ids?639 ids638)) (distinct-bound-ids?140 ids638) #f))) (bound-id=?138 (lambda (i642 j643) (if (if (syntax-object?98 i642) (syntax-object?98 j643) #f) (if (eq? (syntax-object-expression99 i642) (syntax-object-expression99 j643)) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i642)) (wrap-marks117 (syntax-object-wrap100 j643))) #f) (eq? i642 j643)))) (free-id=?137 (lambda (i644 j645) (if (eq? (let ((x646 i644)) (if (syntax-object?98 x646) (syntax-object-expression99 x646) x646)) (let ((x647 j645)) (if (syntax-object?98 x647) (syntax-object-expression99 x647) x647))) (eq? (id-var-name136 i644 (quote (()))) (id-var-name136 j645 (quote (())))) #f))) (id-var-name136 (lambda (id648 w649) (letrec ((search-vector-rib652 (lambda (sym658 subst659 marks660 symnames661 ribcage662) (let ((n663 (vector-length symnames661))) (letrec ((f664 (lambda (i665) (if (fx=74 i665 n663) (search650 sym658 (cdr subst659) marks660) (if (if (eq? (vector-ref symnames661 i665) sym658) (same-marks?135 marks660 (vector-ref (ribcage-marks124 ribcage662) i665)) #f) (values (vector-ref (ribcage-labels125 ribcage662) i665) marks660) (f664 (fx+72 i665 1))))))) (f664 0))))) (search-list-rib651 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (letrec ((f671 (lambda (symnames672 i673) (if (null? symnames672) (search650 sym666 (cdr subst667) marks668) (if (if (eq? (car symnames672) sym666) (same-marks?135 marks668 (list-ref (ribcage-marks124 ribcage670) i673)) #f) (values (list-ref (ribcage-labels125 ribcage670) i673) marks668) (f671 (cdr symnames672) (fx+72 i673 1))))))) (f671 symnames669 0)))) (search650 (lambda (sym674 subst675 marks676) (if (null? subst675) (values #f marks676) (let ((fst677 (car subst675))) (if (eq? fst677 (quote shift)) (search650 sym674 (cdr subst675) (cdr marks676)) (let ((symnames678 (ribcage-symnames123 fst677))) (if (vector? symnames678) (search-vector-rib652 sym674 subst675 marks676 symnames678 fst677) (search-list-rib651 sym674 subst675 marks676 symnames678 fst677))))))))) (if (symbol? id648) (let ((t679 (call-with-values (lambda () (search650 id648 (wrap-subst118 w649) (wrap-marks117 w649))) (lambda (x681 . ignore680) x681)))) (if t679 t679 id648)) (if (syntax-object?98 id648) (let ((id682 (syntax-object-expression99 id648)) (w1683 (syntax-object-wrap100 id648))) (let ((marks684 (join-marks134 (wrap-marks117 w649) (wrap-marks117 w1683)))) (call-with-values (lambda () (search650 id682 (wrap-subst118 w649) marks684)) (lambda (new-id685 marks686) (let ((t687 new-id685)) (if t687 t687 (let ((t688 (call-with-values (lambda () (search650 id682 (wrap-subst118 w1683) marks686)) (lambda (x690 . ignore689) x690)))) (if t688 t688 id682)))))))) (syntax-violation (quote id-var-name) "invalid id" id648)))))) (same-marks?135 (lambda (x691 y692) (let ((t693 (eq? x691 y692))) (if t693 t693 (if (not (null? x691)) (if (not (null? y692)) (if (eq? (car x691) (car y692)) (same-marks?135 (cdr x691) (cdr y692)) #f) #f) #f))))) (join-marks134 (lambda (m1694 m2695) (smart-append132 m1694 m2695))) (join-wraps133 (lambda (w1696 w2697) (let ((m1698 (wrap-marks117 w1696)) (s1699 (wrap-subst118 w1696))) (if (null? m1698) (if (null? s1699) w2697 (make-wrap116 (wrap-marks117 w2697) (smart-append132 s1699 (wrap-subst118 w2697)))) (make-wrap116 (smart-append132 m1698 (wrap-marks117 w2697)) (smart-append132 s1699 (wrap-subst118 w2697))))))) (smart-append132 (lambda (m1700 m2701) (if (null? m2701) m1700 (append m1700 m2701)))) (make-binding-wrap131 (lambda (ids702 labels703 w704) (if (null? ids702) w704 (make-wrap116 (wrap-marks117 w704) (cons (let ((labelvec705 (list->vector labels703))) (let ((n706 (vector-length labelvec705))) (let ((symnamevec707 (make-vector n706)) (marksvec708 (make-vector n706))) (begin (letrec ((f709 (lambda (ids710 i711) (if (not (null? ids710)) (call-with-values (lambda () (id-sym-name&marks115 (car ids710) w704)) (lambda (symname712 marks713) (begin (vector-set! symnamevec707 i711 symname712) (vector-set! marksvec708 i711 marks713) (f709 (cdr ids710) (fx+72 i711 1))))))))) (f709 ids702 0)) (make-ribcage121 symnamevec707 marksvec708 labelvec705))))) (wrap-subst118 w704)))))) (extend-ribcage!130 (lambda (ribcage714 id715 label716) (begin (set-ribcage-symnames!126 ribcage714 (cons (syntax-object-expression99 id715) (ribcage-symnames123 ribcage714))) (set-ribcage-marks!127 ribcage714 (cons (wrap-marks117 (syntax-object-wrap100 id715)) (ribcage-marks124 ribcage714))) (set-ribcage-labels!128 ribcage714 (cons label716 (ribcage-labels125 ribcage714)))))) (anti-mark129 (lambda (w717) (make-wrap116 (cons #f (wrap-marks117 w717)) (cons (quote shift) (wrap-subst118 w717))))) (set-ribcage-labels!128 (lambda (x718 update719) (vector-set! x718 3 update719))) (set-ribcage-marks!127 (lambda (x720 update721) (vector-set! x720 2 update721))) (set-ribcage-symnames!126 (lambda (x722 update723) (vector-set! x722 1 update723))) (ribcage-labels125 (lambda (x724) (vector-ref x724 3))) (ribcage-marks124 (lambda (x725) (vector-ref x725 2))) (ribcage-symnames123 (lambda (x726) (vector-ref x726 1))) (ribcage?122 (lambda (x727) (if (vector? x727) (if (= (vector-length x727) 4) (eq? (vector-ref x727 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames728 marks729 labels730) (vector (quote ribcage) symnames728 marks729 labels730))) (gen-labels120 (lambda (ls731) (if (null? ls731) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls731)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x732 w733) (if (syntax-object?98 x732) (values (syntax-object-expression99 x732) (join-marks134 (wrap-marks117 w733) (wrap-marks117 (syntax-object-wrap100 x732)))) (values x732 (wrap-marks117 w733))))) (id?114 (lambda (x734) (if (symbol? x734) #t (if (syntax-object?98 x734) (symbol? (syntax-object-expression99 x734)) #f)))) (nonsymbol-id?113 (lambda (x735) (if (syntax-object?98 x735) (symbol? (syntax-object-expression99 x735)) #f))) (global-extend112 (lambda (type736 sym737 val738) (put-global-definition-hook78 sym737 type736 val738))) (lookup111 (lambda (x739 r740 mod741) (let ((t742 (assq x739 r740))) (if t742 (cdr t742) (if (symbol? x739) (let ((t743 (get-global-definition-hook79 x739 mod741))) (if t743 t743 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r744) (if (null? r744) (quote ()) (let ((a745 (car r744))) (if (eq? (cadr a745) (quote macro)) (cons a745 (macros-only-env110 (cdr r744))) (macros-only-env110 (cdr r744))))))) (extend-var-env109 (lambda (labels746 vars747 r748) (if (null? labels746) r748 (extend-var-env109 (cdr labels746) (cdr vars747) (cons (cons (car labels746) (cons (quote lexical) (car vars747))) r748))))) (extend-env108 (lambda (labels749 bindings750 r751) (if (null? labels749) r751 (extend-env108 (cdr labels749) (cdr bindings750) (cons (cons (car labels749) (car bindings750)) r751))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x752) (if (syntax-object?98 x752) (source-annotation105 (syntax-object-expression99 x752)) (if (pair? x752) (source-properties x752) #f)))) (set-syntax-object-module!104 (lambda (x753 update754) (vector-set! x753 3 update754))) (set-syntax-object-wrap!103 (lambda (x755 update756) (vector-set! x755 2 update756))) (set-syntax-object-expression!102 (lambda (x757 update758) (vector-set! x757 1 update758))) (syntax-object-module101 (lambda (x759) (vector-ref x759 3))) (syntax-object-wrap100 (lambda (x760) (vector-ref x760 2))) (syntax-object-expression99 (lambda (x761) (vector-ref x761 1))) (syntax-object?98 (lambda (x762) (if (vector? x762) (if (= (vector-length x762) 4) (eq? (vector-ref x762 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression763 wrap764 module765) (vector (quote syntax-object) expression763 wrap764 module765))) (build-letrec96 (lambda (src766 ids767 vars768 val-exps769 body-exp770) (if (null? vars768) body-exp770 (let ((atom-key771 (fluid-ref *mode*71))) (if (memv atom-key771 (quote (c))) (begin (for-each maybe-name-value!88 ids767 val-exps769) ((@ (language tree-il) make-letrec) src766 ids767 vars768 val-exps769 body-exp770)) (list (quote letrec) (map list vars768 val-exps769) body-exp770)))))) (build-named-let95 (lambda (src772 ids773 vars774 val-exps775 body-exp776) (let ((f777 (car vars774)) (f-name778 (car ids773)) (vars779 (cdr vars774)) (ids780 (cdr ids773))) (let ((atom-key781 (fluid-ref *mode*71))) (if (memv atom-key781 (quote (c))) (let ((proc782 (build-lambda90 src772 ids780 vars779 #f body-exp776))) (begin (maybe-name-value!88 f-name778 proc782) (for-each maybe-name-value!88 ids780 val-exps775) ((@ (language tree-il) make-letrec) src772 (list f-name778) (list f777) (list proc782) (build-application81 src772 (build-lexical-reference83 (quote fun) src772 f-name778 f777) val-exps775)))) (list (quote let) f777 (map list vars779 val-exps775) body-exp776)))))) (build-let94 (lambda (src783 ids784 vars785 val-exps786 body-exp787) (if (null? vars785) body-exp787 (let ((atom-key788 (fluid-ref *mode*71))) (if (memv atom-key788 (quote (c))) (begin (for-each maybe-name-value!88 ids784 val-exps786) ((@ (language tree-il) make-let) src783 ids784 vars785 val-exps786 body-exp787)) (list (quote let) (map list vars785 val-exps786) body-exp787)))))) (build-sequence93 (lambda (src789 exps790) (if (null? (cdr exps790)) (car exps790) (let ((atom-key791 (fluid-ref *mode*71))) (if (memv atom-key791 (quote (c))) ((@ (language tree-il) make-sequence) src789 exps790) (cons (quote begin) exps790)))))) (build-data92 (lambda (src792 exp793) (let ((atom-key794 (fluid-ref *mode*71))) (if (memv atom-key794 (quote (c))) ((@ (language tree-il) make-const) src792 exp793) (if (if (self-evaluating? exp793) (not (vector? exp793)) #f) exp793 (list (quote quote) exp793)))))) (build-primref91 (lambda (src795 name796) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key797 (fluid-ref *mode*71))) (if (memv atom-key797 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src795 name796) name796)) (let ((atom-key798 (fluid-ref *mode*71))) (if (memv atom-key798 (quote (c))) ((@ (language tree-il) make-module-ref) src795 (quote (guile)) name796 #f) (list (quote @@) (quote (guile)) name796)))))) (build-lambda90 (lambda (src799 ids800 vars801 docstring802 exp803) (let ((atom-key804 (fluid-ref *mode*71))) (if (memv atom-key804 (quote (c))) ((@ (language tree-il) make-lambda) src799 ids800 vars801 (if docstring802 (list (cons (quote documentation) docstring802)) (quote ())) exp803) (cons (quote lambda) (cons vars801 (append (if docstring802 (list docstring802) (quote ())) (list exp803)))))))) (build-global-definition89 (lambda (source805 var806 exp807) (let ((atom-key808 (fluid-ref *mode*71))) (if (memv atom-key808 (quote (c))) (begin (maybe-name-value!88 var806 exp807) ((@ (language tree-il) make-toplevel-define) source805 var806 exp807)) (list (quote define) var806 exp807))))) (maybe-name-value!88 (lambda (name809 val810) (if ((@ (language tree-il) lambda?) val810) (let ((meta811 ((@ (language tree-il) lambda-meta) val810))) (if (not (assq (quote name) meta811)) ((setter (@ (language tree-il) lambda-meta)) val810 (acons (quote name) name809 meta811))))))) (build-global-assignment87 (lambda (source812 var813 exp814 mod815) (analyze-variable85 mod815 var813 (lambda (mod816 var817 public?818) (let ((atom-key819 (fluid-ref *mode*71))) (if (memv atom-key819 (quote (c))) ((@ (language tree-il) make-module-set) source812 mod816 var817 public?818 exp814) (list (quote set!) (list (if public?818 (quote @) (quote @@)) mod816 var817) exp814)))) (lambda (var820) (let ((atom-key821 (fluid-ref *mode*71))) (if (memv atom-key821 (quote (c))) ((@ (language tree-il) make-toplevel-set) source812 var820 exp814) (list (quote set!) var820 exp814))))))) (build-global-reference86 (lambda (source822 var823 mod824) (analyze-variable85 mod824 var823 (lambda (mod825 var826 public?827) (let ((atom-key828 (fluid-ref *mode*71))) (if (memv atom-key828 (quote (c))) ((@ (language tree-il) make-module-ref) source822 mod825 var826 public?827) (list (if public?827 (quote @) (quote @@)) mod825 var826)))) (lambda (var829) (let ((atom-key830 (fluid-ref *mode*71))) (if (memv atom-key830 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source822 var829) var829)))))) (analyze-variable85 (lambda (mod831 var832 modref-cont833 bare-cont834) (if (not mod831) (bare-cont834 var832) (let ((kind835 (car mod831)) (mod836 (cdr mod831))) (if (memv kind835 (quote (public))) (modref-cont833 mod836 var832 #t) (if (memv kind835 (quote (private))) (if (not (equal? mod836 (module-name (current-module)))) (modref-cont833 mod836 var832 #f) (bare-cont834 var832)) (if (memv kind835 (quote (bare))) (bare-cont834 var832) (if (memv kind835 (quote (hygiene))) (if (if (not (equal? mod836 (module-name (current-module)))) (module-variable (resolve-module mod836) var832) #f) (modref-cont833 mod836 var832 #f) (bare-cont834 var832)) (syntax-violation #f "bad module kind" var832 mod836))))))))) (build-lexical-assignment84 (lambda (source837 name838 var839 exp840) (let ((atom-key841 (fluid-ref *mode*71))) (if (memv atom-key841 (quote (c))) ((@ (language tree-il) make-lexical-set) source837 name838 var839 exp840) (list (quote set!) var839 exp840))))) (build-lexical-reference83 (lambda (type842 source843 name844 var845) (let ((atom-key846 (fluid-ref *mode*71))) (if (memv atom-key846 (quote (c))) ((@ (language tree-il) make-lexical-ref) source843 name844 var845) var845)))) (build-conditional82 (lambda (source847 test-exp848 then-exp849 else-exp850) (let ((atom-key851 (fluid-ref *mode*71))) (if (memv atom-key851 (quote (c))) ((@ (language tree-il) make-conditional) source847 test-exp848 then-exp849 else-exp850) (if (equal? else-exp850 (quote (if #f #f))) (list (quote if) test-exp848 then-exp849) (list (quote if) test-exp848 then-exp849 else-exp850)))))) (build-application81 (lambda (source852 fun-exp853 arg-exps854) (let ((atom-key855 (fluid-ref *mode*71))) (if (memv atom-key855 (quote (c))) ((@ (language tree-il) make-application) source852 fun-exp853 arg-exps854) (cons fun-exp853 arg-exps854))))) (build-void80 (lambda (source856) (let ((atom-key857 (fluid-ref *mode*71))) (if (memv atom-key857 (quote (c))) ((@ (language tree-il) make-void) source856) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol858 module859) (begin (if (if (not module859) (current-module) #f) (warn "module system is booted, we should have a module" symbol858)) (let ((v860 (module-variable (if module859 (resolve-module (cdr module859)) (current-module)) symbol858))) (if v860 (if (variable-bound? v860) (let ((val861 (variable-ref v860))) (if (macro? val861) (if (syncase-macro-type val861) (cons (syncase-macro-type val861) (syncase-macro-binding val861)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol862 type863 val864) (let ((existing865 (let ((v866 (module-variable (current-module) symbol862))) (if v866 (if (variable-bound? v866) (let ((val867 (variable-ref v866))) (if (macro? val867) (if (not (syncase-macro-type val867)) val867 #f) #f)) #f) #f)))) (module-define! (current-module) symbol862 (if existing865 (make-extended-syncase-macro existing865 type863 val864) (make-syncase-macro type863 val864)))))) (local-eval-hook77 (lambda (x868 mod869) (primitive-eval (list noexpand70 (let ((atom-key870 (fluid-ref *mode*71))) (if (memv atom-key870 (quote (c))) ((@ (language tree-il) tree-il->scheme) x868) x868)))))) (top-level-eval-hook76 (lambda (x871 mod872) (primitive-eval (list noexpand70 (let ((atom-key873 (fluid-ref *mode*71))) (if (memv atom-key873 (quote (c))) ((@ (language tree-il) tree-il->scheme) x871) x871)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e874 r875 w876 s877 mod878) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (_881 var882 val883 e1884 e2885) (valid-bound-ids?139 var882)) tmp880) #f) (apply (lambda (_887 var888 val889 e1890 e2891) (let ((names892 (map (lambda (x893) (id-var-name136 x893 w876)) var888))) (begin (for-each (lambda (id895 n896) (let ((atom-key897 (binding-type106 (lookup111 n896 r875 mod878)))) (if (memv atom-key897 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e874 (source-wrap143 id895 w876 s877 mod878))))) var888 names892) (chi-body154 (cons e1890 e2891) (source-wrap143 e874 w876 s877 mod878) (extend-env108 names892 (let ((trans-r900 (macros-only-env110 r875))) (map (lambda (x901) (cons (quote macro) (eval-local-transformer157 (chi150 x901 trans-r900 w876 mod878) mod878))) val889)) r875) w876 mod878)))) tmp880) ((lambda (_903) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e874 w876 s877 mod878))) tmp879))) ($sc-dispatch tmp879 (quote (any #(each (any any)) any . each-any))))) e874))) (global-extend112 (quote core) (quote quote) (lambda (e904 r905 w906 s907 mod908) ((lambda (tmp909) ((lambda (tmp910) (if tmp910 (apply (lambda (_911 e912) (build-data92 s907 (strip160 e912 w906))) tmp910) ((lambda (_913) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e904 w906 s907 mod908))) tmp909))) ($sc-dispatch tmp909 (quote (any any))))) e904))) (global-extend112 (quote core) (quote syntax) (letrec ((regen921 (lambda (x922) (let ((atom-key923 (car x922))) (if (memv atom-key923 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x922) (cadr x922)) (if (memv atom-key923 (quote (primitive))) (build-primref91 #f (cadr x922)) (if (memv atom-key923 (quote (quote))) (build-data92 #f (cadr x922)) (if (memv atom-key923 (quote (lambda))) (build-lambda90 #f (cadr x922) (cadr x922) #f (regen921 (caddr x922))) (if (memv atom-key923 (quote (map))) (let ((ls924 (map regen921 (cdr x922)))) (build-application81 #f (build-primref91 #f (quote map)) ls924)) (build-application81 #f (build-primref91 #f (car x922)) (map regen921 (cdr x922))))))))))) (gen-vector920 (lambda (x925) (if (eq? (car x925) (quote list)) (cons (quote vector) (cdr x925)) (if (eq? (car x925) (quote quote)) (list (quote quote) (list->vector (cadr x925))) (list (quote list->vector) x925))))) (gen-append919 (lambda (x926 y927) (if (equal? y927 (quote (quote ()))) x926 (list (quote append) x926 y927)))) (gen-cons918 (lambda (x928 y929) (let ((atom-key930 (car y929))) (if (memv atom-key930 (quote (quote))) (if (eq? (car x928) (quote quote)) (list (quote quote) (cons (cadr x928) (cadr y929))) (if (eq? (cadr y929) (quote ())) (list (quote list) x928) (list (quote cons) x928 y929))) (if (memv atom-key930 (quote (list))) (cons (quote list) (cons x928 (cdr y929))) (list (quote cons) x928 y929)))))) (gen-map917 (lambda (e931 map-env932) (let ((formals933 (map cdr map-env932)) (actuals934 (map (lambda (x935) (list (quote ref) (car x935))) map-env932))) (if (eq? (car e931) (quote ref)) (car actuals934) (if (and-map (lambda (x936) (if (eq? (car x936) (quote ref)) (memq (cadr x936) formals933) #f)) (cdr e931)) (cons (quote map) (cons (list (quote primitive) (car e931)) (map (let ((r937 (map cons formals933 actuals934))) (lambda (x938) (cdr (assq (cadr x938) r937)))) (cdr e931)))) (cons (quote map) (cons (list (quote lambda) formals933 e931) actuals934))))))) (gen-mappend916 (lambda (e939 map-env940) (list (quote apply) (quote (primitive append)) (gen-map917 e939 map-env940)))) (gen-ref915 (lambda (src941 var942 level943 maps944) (if (fx=74 level943 0) (values var942 maps944) (if (null? maps944) (syntax-violation (quote syntax) "missing ellipsis" src941) (call-with-values (lambda () (gen-ref915 src941 var942 (fx-73 level943 1) (cdr maps944))) (lambda (outer-var945 outer-maps946) (let ((b947 (assq outer-var945 (car maps944)))) (if b947 (values (cdr b947) maps944) (let ((inner-var948 (gen-var161 (quote tmp)))) (values inner-var948 (cons (cons (cons outer-var945 inner-var948) (car maps944)) outer-maps946))))))))))) (gen-syntax914 (lambda (src949 e950 r951 maps952 ellipsis?953 mod954) (if (id?114 e950) (let ((label955 (id-var-name136 e950 (quote (()))))) (let ((b956 (lookup111 label955 r951 mod954))) (if (eq? (binding-type106 b956) (quote syntax)) (call-with-values (lambda () (let ((var.lev957 (binding-value107 b956))) (gen-ref915 src949 (car var.lev957) (cdr var.lev957) maps952))) (lambda (var958 maps959) (values (list (quote ref) var958) maps959))) (if (ellipsis?953 e950) (syntax-violation (quote syntax) "misplaced ellipsis" src949) (values (list (quote quote) e950) maps952))))) ((lambda (tmp960) ((lambda (tmp961) (if (if tmp961 (apply (lambda (dots962 e963) (ellipsis?953 dots962)) tmp961) #f) (apply (lambda (dots964 e965) (gen-syntax914 src949 e965 r951 maps952 (lambda (x966) #f) mod954)) tmp961) ((lambda (tmp967) (if (if tmp967 (apply (lambda (x968 dots969 y970) (ellipsis?953 dots969)) tmp967) #f) (apply (lambda (x971 dots972 y973) (letrec ((f974 (lambda (y975 k976) ((lambda (tmp980) ((lambda (tmp981) (if (if tmp981 (apply (lambda (dots982 y983) (ellipsis?953 dots982)) tmp981) #f) (apply (lambda (dots984 y985) (f974 y985 (lambda (maps986) (call-with-values (lambda () (k976 (cons (quote ()) maps986))) (lambda (x987 maps988) (if (null? (car maps988)) (syntax-violation (quote syntax) "extra ellipsis" src949) (values (gen-mappend916 x987 (car maps988)) (cdr maps988)))))))) tmp981) ((lambda (_989) (call-with-values (lambda () (gen-syntax914 src949 y975 r951 maps952 ellipsis?953 mod954)) (lambda (y990 maps991) (call-with-values (lambda () (k976 maps991)) (lambda (x992 maps993) (values (gen-append919 x992 y990) maps993)))))) tmp980))) ($sc-dispatch tmp980 (quote (any . any))))) y975)))) (f974 y973 (lambda (maps977) (call-with-values (lambda () (gen-syntax914 src949 x971 r951 (cons (quote ()) maps977) ellipsis?953 mod954)) (lambda (x978 maps979) (if (null? (car maps979)) (syntax-violation (quote syntax) "extra ellipsis" src949) (values (gen-map917 x978 (car maps979)) (cdr maps979))))))))) tmp967) ((lambda (tmp994) (if tmp994 (apply (lambda (x995 y996) (call-with-values (lambda () (gen-syntax914 src949 x995 r951 maps952 ellipsis?953 mod954)) (lambda (x997 maps998) (call-with-values (lambda () (gen-syntax914 src949 y996 r951 maps998 ellipsis?953 mod954)) (lambda (y999 maps1000) (values (gen-cons918 x997 y999) maps1000)))))) tmp994) ((lambda (tmp1001) (if tmp1001 (apply (lambda (e11002 e21003) (call-with-values (lambda () (gen-syntax914 src949 (cons e11002 e21003) r951 maps952 ellipsis?953 mod954)) (lambda (e1005 maps1006) (values (gen-vector920 e1005) maps1006)))) tmp1001) ((lambda (_1007) (values (list (quote quote) e950) maps952)) tmp960))) ($sc-dispatch tmp960 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp960 (quote (any . any)))))) ($sc-dispatch tmp960 (quote (any any . any)))))) ($sc-dispatch tmp960 (quote (any any))))) e950))))) (lambda (e1008 r1009 w1010 s1011 mod1012) (let ((e1013 (source-wrap143 e1008 w1010 s1011 mod1012))) ((lambda (tmp1014) ((lambda (tmp1015) (if tmp1015 (apply (lambda (_1016 x1017) (call-with-values (lambda () (gen-syntax914 e1013 x1017 r1009 (quote ()) ellipsis?159 mod1012)) (lambda (e1018 maps1019) (regen921 e1018)))) tmp1015) ((lambda (_1020) (syntax-violation (quote syntax) "bad `syntax' form" e1013)) tmp1014))) ($sc-dispatch tmp1014 (quote (any any))))) e1013))))) (global-extend112 (quote core) (quote lambda) (lambda (e1021 r1022 w1023 s1024 mod1025) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda (_1028 c1029) (chi-lambda-clause155 (source-wrap143 e1021 w1023 s1024 mod1025) #f c1029 r1022 w1023 mod1025 (lambda (names1030 vars1031 docstring1032 body1033) (build-lambda90 s1024 names1030 vars1031 docstring1032 body1033)))) tmp1027) (syntax-violation #f "source expression failed to match any pattern" tmp1026))) ($sc-dispatch tmp1026 (quote (any . any))))) e1021))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1034 (lambda (e1035 r1036 w1037 s1038 mod1039 constructor1040 ids1041 vals1042 exps1043) (if (not (valid-bound-ids?139 ids1041)) (syntax-violation (quote let) "duplicate bound variable" e1035) (let ((labels1044 (gen-labels120 ids1041)) (new-vars1045 (map gen-var161 ids1041))) (let ((nw1046 (make-binding-wrap131 ids1041 labels1044 w1037)) (nr1047 (extend-var-env109 labels1044 new-vars1045 r1036))) (constructor1040 s1038 (map syntax->datum ids1041) new-vars1045 (map (lambda (x1048) (chi150 x1048 r1036 w1037 mod1039)) vals1042) (chi-body154 exps1043 (source-wrap143 e1035 nw1046 s1038 mod1039) nr1047 nw1046 mod1039)))))))) (lambda (e1049 r1050 w1051 s1052 mod1053) ((lambda (tmp1054) ((lambda (tmp1055) (if (if tmp1055 (apply (lambda (_1056 id1057 val1058 e11059 e21060) (and-map id?114 id1057)) tmp1055) #f) (apply (lambda (_1062 id1063 val1064 e11065 e21066) (chi-let1034 e1049 r1050 w1051 s1052 mod1053 build-let94 id1063 val1064 (cons e11065 e21066))) tmp1055) ((lambda (tmp1070) (if (if tmp1070 (apply (lambda (_1071 f1072 id1073 val1074 e11075 e21076) (if (id?114 f1072) (and-map id?114 id1073) #f)) tmp1070) #f) (apply (lambda (_1078 f1079 id1080 val1081 e11082 e21083) (chi-let1034 e1049 r1050 w1051 s1052 mod1053 build-named-let95 (cons f1079 id1080) val1081 (cons e11082 e21083))) tmp1070) ((lambda (_1087) (syntax-violation (quote let) "bad let" (source-wrap143 e1049 w1051 s1052 mod1053))) tmp1054))) ($sc-dispatch tmp1054 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1054 (quote (any #(each (any any)) any . each-any))))) e1049)))) (global-extend112 (quote core) (quote letrec) (lambda (e1088 r1089 w1090 s1091 mod1092) ((lambda (tmp1093) ((lambda (tmp1094) (if (if tmp1094 (apply (lambda (_1095 id1096 val1097 e11098 e21099) (and-map id?114 id1096)) tmp1094) #f) (apply (lambda (_1101 id1102 val1103 e11104 e21105) (let ((ids1106 id1102)) (if (not (valid-bound-ids?139 ids1106)) (syntax-violation (quote letrec) "duplicate bound variable" e1088) (let ((labels1108 (gen-labels120 ids1106)) (new-vars1109 (map gen-var161 ids1106))) (let ((w1110 (make-binding-wrap131 ids1106 labels1108 w1090)) (r1111 (extend-var-env109 labels1108 new-vars1109 r1089))) (build-letrec96 s1091 (map syntax->datum ids1106) new-vars1109 (map (lambda (x1112) (chi150 x1112 r1111 w1110 mod1092)) val1103) (chi-body154 (cons e11104 e21105) (source-wrap143 e1088 w1110 s1091 mod1092) r1111 w1110 mod1092))))))) tmp1094) ((lambda (_1115) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1088 w1090 s1091 mod1092))) tmp1093))) ($sc-dispatch tmp1093 (quote (any #(each (any any)) any . each-any))))) e1088))) (global-extend112 (quote core) (quote set!) (lambda (e1116 r1117 w1118 s1119 mod1120) ((lambda (tmp1121) ((lambda (tmp1122) (if (if tmp1122 (apply (lambda (_1123 id1124 val1125) (id?114 id1124)) tmp1122) #f) (apply (lambda (_1126 id1127 val1128) (let ((val1129 (chi150 val1128 r1117 w1118 mod1120)) (n1130 (id-var-name136 id1127 w1118))) (let ((b1131 (lookup111 n1130 r1117 mod1120))) (let ((atom-key1132 (binding-type106 b1131))) (if (memv atom-key1132 (quote (lexical))) (build-lexical-assignment84 s1119 (syntax->datum id1127) (binding-value107 b1131) val1129) (if (memv atom-key1132 (quote (global))) (build-global-assignment87 s1119 n1130 val1129 mod1120) (if (memv atom-key1132 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1127 w1118 mod1120)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1116 w1118 s1119 mod1120))))))))) tmp1122) ((lambda (tmp1133) (if tmp1133 (apply (lambda (_1134 head1135 tail1136 val1137) (call-with-values (lambda () (syntax-type148 head1135 r1117 (quote (())) #f #f mod1120)) (lambda (type1138 value1139 ee1140 ww1141 ss1142 modmod1143) (if (memv type1138 (quote (module-ref))) (let ((val1144 (chi150 val1137 r1117 w1118 mod1120))) (call-with-values (lambda () (value1139 (cons head1135 tail1136))) (lambda (id1146 mod1147) (build-global-assignment87 s1119 id1146 val1144 mod1147)))) (build-application81 s1119 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1135) r1117 w1118 mod1120) (map (lambda (e1148) (chi150 e1148 r1117 w1118 mod1120)) (append tail1136 (list val1137)))))))) tmp1133) ((lambda (_1150) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1116 w1118 s1119 mod1120))) tmp1121))) ($sc-dispatch tmp1121 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1121 (quote (any any any))))) e1116))) (global-extend112 (quote module-ref) (quote @) (lambda (e1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 mod1155 id1156) (if (and-map id?114 mod1155) (id?114 id1156) #f)) tmp1153) #f) (apply (lambda (_1158 mod1159 id1160) (values (syntax->datum id1160) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1159)))) tmp1153) (syntax-violation #f "source expression failed to match any pattern" tmp1152))) ($sc-dispatch tmp1152 (quote (any each-any any))))) e1151))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1162) ((lambda (tmp1163) ((lambda (tmp1164) (if (if tmp1164 (apply (lambda (_1165 mod1166 id1167) (if (and-map id?114 mod1166) (id?114 id1167) #f)) tmp1164) #f) (apply (lambda (_1169 mod1170 id1171) (values (syntax->datum id1171) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1170)))) tmp1164) (syntax-violation #f "source expression failed to match any pattern" tmp1163))) ($sc-dispatch tmp1163 (quote (any each-any any))))) e1162))) (global-extend112 (quote core) (quote if) (lambda (e1173 r1174 w1175 s1176 mod1177) ((lambda (tmp1178) ((lambda (tmp1179) (if tmp1179 (apply (lambda (_1180 test1181 then1182) (build-conditional82 s1176 (chi150 test1181 r1174 w1175 mod1177) (chi150 then1182 r1174 w1175 mod1177) (build-void80 #f))) tmp1179) ((lambda (tmp1183) (if tmp1183 (apply (lambda (_1184 test1185 then1186 else1187) (build-conditional82 s1176 (chi150 test1185 r1174 w1175 mod1177) (chi150 then1186 r1174 w1175 mod1177) (chi150 else1187 r1174 w1175 mod1177))) tmp1183) (syntax-violation #f "source expression failed to match any pattern" tmp1178))) ($sc-dispatch tmp1178 (quote (any any any any)))))) ($sc-dispatch tmp1178 (quote (any any any))))) e1173))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1191 (lambda (x1192 keys1193 clauses1194 r1195 mod1196) (if (null? clauses1194) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1192)) ((lambda (tmp1197) ((lambda (tmp1198) (if tmp1198 (apply (lambda (pat1199 exp1200) (if (if (id?114 pat1199) (and-map (lambda (x1201) (not (free-id=?137 pat1199 x1201))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1193)) #f) (let ((labels1202 (list (gen-label119))) (var1203 (gen-var161 pat1199))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1199)) (list var1203) #f (chi150 exp1200 (extend-env108 labels1202 (list (cons (quote syntax) (cons var1203 0))) r1195) (make-binding-wrap131 (list pat1199) labels1202 (quote (()))) mod1196)) (list x1192))) (gen-clause1190 x1192 keys1193 (cdr clauses1194) r1195 pat1199 #t exp1200 mod1196))) tmp1198) ((lambda (tmp1204) (if tmp1204 (apply (lambda (pat1205 fender1206 exp1207) (gen-clause1190 x1192 keys1193 (cdr clauses1194) r1195 pat1205 fender1206 exp1207 mod1196)) tmp1204) ((lambda (_1208) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1194))) tmp1197))) ($sc-dispatch tmp1197 (quote (any any any)))))) ($sc-dispatch tmp1197 (quote (any any))))) (car clauses1194))))) (gen-clause1190 (lambda (x1209 keys1210 clauses1211 r1212 pat1213 fender1214 exp1215 mod1216) (call-with-values (lambda () (convert-pattern1188 pat1213 keys1210)) (lambda (p1217 pvars1218) (if (not (distinct-bound-ids?140 (map car pvars1218))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1213) (if (not (and-map (lambda (x1219) (not (ellipsis?159 (car x1219)))) pvars1218)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1213) (let ((y1220 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1220) #f (let ((y1221 (build-lexical-reference83 (quote value) #f (quote tmp) y1220))) (build-conditional82 #f ((lambda (tmp1222) ((lambda (tmp1223) (if tmp1223 (apply (lambda () y1221) tmp1223) ((lambda (_1224) (build-conditional82 #f y1221 (build-dispatch-call1189 pvars1218 fender1214 y1221 r1212 mod1216) (build-data92 #f #f))) tmp1222))) ($sc-dispatch tmp1222 (quote #(atom #t))))) fender1214) (build-dispatch-call1189 pvars1218 exp1215 y1221 r1212 mod1216) (gen-syntax-case1191 x1209 keys1210 clauses1211 r1212 mod1216)))) (list (if (eq? p1217 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1209)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1209 (build-data92 #f p1217))))))))))))) (build-dispatch-call1189 (lambda (pvars1225 exp1226 y1227 r1228 mod1229) (let ((ids1230 (map car pvars1225)) (levels1231 (map cdr pvars1225))) (let ((labels1232 (gen-labels120 ids1230)) (new-vars1233 (map gen-var161 ids1230))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1230) new-vars1233 #f (chi150 exp1226 (extend-env108 labels1232 (map (lambda (var1234 level1235) (cons (quote syntax) (cons var1234 level1235))) new-vars1233 (map cdr pvars1225)) r1228) (make-binding-wrap131 ids1230 labels1232 (quote (()))) mod1229)) y1227)))))) (convert-pattern1188 (lambda (pattern1236 keys1237) (letrec ((cvt1238 (lambda (p1239 n1240 ids1241) (if (id?114 p1239) (if (bound-id-member?141 p1239 keys1237) (values (vector (quote free-id) p1239) ids1241) (values (quote any) (cons (cons p1239 n1240) ids1241))) ((lambda (tmp1242) ((lambda (tmp1243) (if (if tmp1243 (apply (lambda (x1244 dots1245) (ellipsis?159 dots1245)) tmp1243) #f) (apply (lambda (x1246 dots1247) (call-with-values (lambda () (cvt1238 x1246 (fx+72 n1240 1) ids1241)) (lambda (p1248 ids1249) (values (if (eq? p1248 (quote any)) (quote each-any) (vector (quote each) p1248)) ids1249)))) tmp1243) ((lambda (tmp1250) (if tmp1250 (apply (lambda (x1251 y1252) (call-with-values (lambda () (cvt1238 y1252 n1240 ids1241)) (lambda (y1253 ids1254) (call-with-values (lambda () (cvt1238 x1251 n1240 ids1254)) (lambda (x1255 ids1256) (values (cons x1255 y1253) ids1256)))))) tmp1250) ((lambda (tmp1257) (if tmp1257 (apply (lambda () (values (quote ()) ids1241)) tmp1257) ((lambda (tmp1258) (if tmp1258 (apply (lambda (x1259) (call-with-values (lambda () (cvt1238 x1259 n1240 ids1241)) (lambda (p1261 ids1262) (values (vector (quote vector) p1261) ids1262)))) tmp1258) ((lambda (x1263) (values (vector (quote atom) (strip160 p1239 (quote (())))) ids1241)) tmp1242))) ($sc-dispatch tmp1242 (quote #(vector each-any)))))) ($sc-dispatch tmp1242 (quote ()))))) ($sc-dispatch tmp1242 (quote (any . any)))))) ($sc-dispatch tmp1242 (quote (any any))))) p1239))))) (cvt1238 pattern1236 0 (quote ())))))) (lambda (e1264 r1265 w1266 s1267 mod1268) (let ((e1269 (source-wrap143 e1264 w1266 s1267 mod1268))) ((lambda (tmp1270) ((lambda (tmp1271) (if tmp1271 (apply (lambda (_1272 val1273 key1274 m1275) (if (and-map (lambda (x1276) (if (id?114 x1276) (not (ellipsis?159 x1276)) #f)) key1274) (let ((x1278 (gen-var161 (quote tmp)))) (build-application81 s1267 (build-lambda90 #f (list (quote tmp)) (list x1278) #f (gen-syntax-case1191 (build-lexical-reference83 (quote value) #f (quote tmp) x1278) key1274 m1275 r1265 mod1268)) (list (chi150 val1273 r1265 (quote (())) mod1268)))) (syntax-violation (quote syntax-case) "invalid literals list" e1269))) tmp1271) (syntax-violation #f "source expression failed to match any pattern" tmp1270))) ($sc-dispatch tmp1270 (quote (any any each-any . each-any))))) e1269))))) (set! sc-expand (lambda (x1282 . rest1281) (if (if (pair? x1282) (equal? (car x1282) noexpand70) #f) (cadr x1282) (let ((m1283 (if (null? rest1281) (quote e) (car rest1281))) (esew1284 (if (let ((t1285 (null? rest1281))) (if t1285 t1285 (null? (cdr rest1281)))) (quote (eval)) (cadr rest1281)))) (with-fluid* *mode*71 m1283 (lambda () (chi-top149 x1282 (quote ()) (quote ((top))) m1283 esew1284 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1286) (nonsymbol-id?113 x1286))) (set! datum->syntax (lambda (id1287 datum1288) (make-syntax-object97 datum1288 (syntax-object-wrap100 id1287) #f))) (set! syntax->datum (lambda (x1289) (strip160 x1289 (quote (()))))) (set! generate-temporaries (lambda (ls1290) (begin (let ((x1291 ls1290)) (if (not (list? x1291)) (syntax-violation (quote generate-temporaries) "invalid argument" x1291))) (map (lambda (x1292) (wrap142 (gensym) (quote ((top))) #f)) ls1290)))) (set! free-identifier=? (lambda (x1293 y1294) (begin (let ((x1295 x1293)) (if (not (nonsymbol-id?113 x1295)) (syntax-violation (quote free-identifier=?) "invalid argument" x1295))) (let ((x1296 y1294)) (if (not (nonsymbol-id?113 x1296)) (syntax-violation (quote free-identifier=?) "invalid argument" x1296))) (free-id=?137 x1293 y1294)))) (set! bound-identifier=? (lambda (x1297 y1298) (begin (let ((x1299 x1297)) (if (not (nonsymbol-id?113 x1299)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1299))) (let ((x1300 y1298)) (if (not (nonsymbol-id?113 x1300)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1300))) (bound-id=?138 x1297 y1298)))) (set! syntax-violation (lambda (who1304 message1303 form1302 . subform1301) (begin (let ((x1305 who1304)) (if (not ((lambda (x1306) (let ((t1307 (not x1306))) (if t1307 t1307 (let ((t1308 (string? x1306))) (if t1308 t1308 (symbol? x1306)))))) x1305)) (syntax-violation (quote syntax-violation) "invalid argument" x1305))) (let ((x1309 message1303)) (if (not (string? x1309)) (syntax-violation (quote syntax-violation) "invalid argument" x1309))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1304 "~a: " "") "~a " (if (null? subform1301) "in ~a" "in subform `~s' of `~s'")) (let ((tail1310 (cons message1303 (map (lambda (x1311) (strip160 x1311 (quote (())))) (append subform1301 (list form1302)))))) (if who1304 (cons who1304 tail1310) tail1310)) #f)))) (letrec ((match1316 (lambda (e1317 p1318 w1319 r1320 mod1321) (if (not r1320) #f (if (eq? p1318 (quote any)) (cons (wrap142 e1317 w1319 mod1321) r1320) (if (syntax-object?98 e1317) (match*1315 (syntax-object-expression99 e1317) p1318 (join-wraps133 w1319 (syntax-object-wrap100 e1317)) r1320 (syntax-object-module101 e1317)) (match*1315 e1317 p1318 w1319 r1320 mod1321)))))) (match*1315 (lambda (e1322 p1323 w1324 r1325 mod1326) (if (null? p1323) (if (null? e1322) r1325 #f) (if (pair? p1323) (if (pair? e1322) (match1316 (car e1322) (car p1323) w1324 (match1316 (cdr e1322) (cdr p1323) w1324 r1325 mod1326) mod1326) #f) (if (eq? p1323 (quote each-any)) (let ((l1327 (match-each-any1313 e1322 w1324 mod1326))) (if l1327 (cons l1327 r1325) #f)) (let ((atom-key1328 (vector-ref p1323 0))) (if (memv atom-key1328 (quote (each))) (if (null? e1322) (match-empty1314 (vector-ref p1323 1) r1325) (let ((l1329 (match-each1312 e1322 (vector-ref p1323 1) w1324 mod1326))) (if l1329 (letrec ((collect1330 (lambda (l1331) (if (null? (car l1331)) r1325 (cons (map car l1331) (collect1330 (map cdr l1331))))))) (collect1330 l1329)) #f))) (if (memv atom-key1328 (quote (free-id))) (if (id?114 e1322) (if (free-id=?137 (wrap142 e1322 w1324 mod1326) (vector-ref p1323 1)) r1325 #f) #f) (if (memv atom-key1328 (quote (atom))) (if (equal? (vector-ref p1323 1) (strip160 e1322 w1324)) r1325 #f) (if (memv atom-key1328 (quote (vector))) (if (vector? e1322) (match1316 (vector->list e1322) (vector-ref p1323 1) w1324 r1325 mod1326) #f))))))))))) (match-empty1314 (lambda (p1332 r1333) (if (null? p1332) r1333 (if (eq? p1332 (quote any)) (cons (quote ()) r1333) (if (pair? p1332) (match-empty1314 (car p1332) (match-empty1314 (cdr p1332) r1333)) (if (eq? p1332 (quote each-any)) (cons (quote ()) r1333) (let ((atom-key1334 (vector-ref p1332 0))) (if (memv atom-key1334 (quote (each))) (match-empty1314 (vector-ref p1332 1) r1333) (if (memv atom-key1334 (quote (free-id atom))) r1333 (if (memv atom-key1334 (quote (vector))) (match-empty1314 (vector-ref p1332 1) r1333))))))))))) (match-each-any1313 (lambda (e1335 w1336 mod1337) (if (pair? e1335) (let ((l1338 (match-each-any1313 (cdr e1335) w1336 mod1337))) (if l1338 (cons (wrap142 (car e1335) w1336 mod1337) l1338) #f)) (if (null? e1335) (quote ()) (if (syntax-object?98 e1335) (match-each-any1313 (syntax-object-expression99 e1335) (join-wraps133 w1336 (syntax-object-wrap100 e1335)) mod1337) #f))))) (match-each1312 (lambda (e1339 p1340 w1341 mod1342) (if (pair? e1339) (let ((first1343 (match1316 (car e1339) p1340 w1341 (quote ()) mod1342))) (if first1343 (let ((rest1344 (match-each1312 (cdr e1339) p1340 w1341 mod1342))) (if rest1344 (cons first1343 rest1344) #f)) #f)) (if (null? e1339) (quote ()) (if (syntax-object?98 e1339) (match-each1312 (syntax-object-expression99 e1339) p1340 (join-wraps133 w1341 (syntax-object-wrap100 e1339)) (syntax-object-module101 e1339)) #f)))))) (set! $sc-dispatch (lambda (e1345 p1346) (if (eq? p1346 (quote any)) (list e1345) (if (syntax-object?98 e1345) (match*1315 (syntax-object-expression99 e1345) p1346 (syntax-object-wrap100 e1345) (quote ()) (syntax-object-module101 e1345)) (match*1315 e1345 p1346 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1347) ((lambda (tmp1348) ((lambda (tmp1349) (if tmp1349 (apply (lambda (_1350 e11351 e21352) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11351 e21352))) tmp1349) ((lambda (tmp1354) (if tmp1354 (apply (lambda (_1355 out1356 in1357 e11358 e21359) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1357 (quote ()) (list out1356 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11358 e21359))))) tmp1354) ((lambda (tmp1361) (if tmp1361 (apply (lambda (_1362 out1363 in1364 e11365 e21366) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1364) (quote ()) (list out1363 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11365 e21366))))) tmp1361) (syntax-violation #f "source expression failed to match any pattern" tmp1348))) ($sc-dispatch tmp1348 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1348 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1348 (quote (any () any . each-any))))) x1347)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1370) ((lambda (tmp1371) ((lambda (tmp1372) (if tmp1372 (apply (lambda (_1373 k1374 keyword1375 pattern1376 template1377) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1374 (map (lambda (tmp1380 tmp1379) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1379) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1380))) template1377 pattern1376)))))) tmp1372) (syntax-violation #f "source expression failed to match any pattern" tmp1371))) ($sc-dispatch tmp1371 (quote (any each-any . #(each ((any . any) any))))))) x1370)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1381) ((lambda (tmp1382) ((lambda (tmp1383) (if (if tmp1383 (apply (lambda (let*1384 x1385 v1386 e11387 e21388) (and-map identifier? x1385)) tmp1383) #f) (apply (lambda (let*1390 x1391 v1392 e11393 e21394) (letrec ((f1395 (lambda (bindings1396) (if (null? bindings1396) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11393 e21394))) ((lambda (tmp1400) ((lambda (tmp1401) (if tmp1401 (apply (lambda (body1402 binding1403) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1403) body1402)) tmp1401) (syntax-violation #f "source expression failed to match any pattern" tmp1400))) ($sc-dispatch tmp1400 (quote (any any))))) (list (f1395 (cdr bindings1396)) (car bindings1396))))))) (f1395 (map list x1391 v1392)))) tmp1383) (syntax-violation #f "source expression failed to match any pattern" tmp1382))) ($sc-dispatch tmp1382 (quote (any #(each (any any)) any . each-any))))) x1381)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1404) ((lambda (tmp1405) ((lambda (tmp1406) (if tmp1406 (apply (lambda (_1407 var1408 init1409 step1410 e01411 e11412 c1413) ((lambda (tmp1414) ((lambda (tmp1415) (if tmp1415 (apply (lambda (step1416) ((lambda (tmp1417) ((lambda (tmp1418) (if tmp1418 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1408 init1409) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01411) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1416))))))) tmp1418) ((lambda (tmp1423) (if tmp1423 (apply (lambda (e11424 e21425) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1408 init1409) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01411 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11424 e21425)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1413 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1416))))))) tmp1423) (syntax-violation #f "source expression failed to match any pattern" tmp1417))) ($sc-dispatch tmp1417 (quote (any . each-any)))))) ($sc-dispatch tmp1417 (quote ())))) e11412)) tmp1415) (syntax-violation #f "source expression failed to match any pattern" tmp1414))) ($sc-dispatch tmp1414 (quote each-any)))) (map (lambda (v1432 s1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda () v1432) tmp1435) ((lambda (tmp1436) (if tmp1436 (apply (lambda (e1437) e1437) tmp1436) ((lambda (_1438) (syntax-violation (quote do) "bad step expression" orig-x1404 s1433)) tmp1434))) ($sc-dispatch tmp1434 (quote (any)))))) ($sc-dispatch tmp1434 (quote ())))) s1433)) var1408 step1410))) tmp1406) (syntax-violation #f "source expression failed to match any pattern" tmp1405))) ($sc-dispatch tmp1405 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1404)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1441 (lambda (x1445 y1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda (x1449 y1450) ((lambda (tmp1451) ((lambda (tmp1452) (if tmp1452 (apply (lambda (dy1453) ((lambda (tmp1454) ((lambda (tmp1455) (if tmp1455 (apply (lambda (dx1456) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1456 dy1453))) tmp1455) ((lambda (_1457) (if (null? dy1453) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449 y1450))) tmp1454))) ($sc-dispatch tmp1454 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1449)) tmp1452) ((lambda (tmp1458) (if tmp1458 (apply (lambda (stuff1459) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1449 stuff1459))) tmp1458) ((lambda (else1460) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1449 y1450)) tmp1451))) ($sc-dispatch tmp1451 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1451 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1450)) tmp1448) (syntax-violation #f "source expression failed to match any pattern" tmp1447))) ($sc-dispatch tmp1447 (quote (any any))))) (list x1445 y1446)))) (quasiappend1442 (lambda (x1461 y1462) ((lambda (tmp1463) ((lambda (tmp1464) (if tmp1464 (apply (lambda (x1465 y1466) ((lambda (tmp1467) ((lambda (tmp1468) (if tmp1468 (apply (lambda () x1465) tmp1468) ((lambda (_1469) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1465 y1466)) tmp1467))) ($sc-dispatch tmp1467 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1466)) tmp1464) (syntax-violation #f "source expression failed to match any pattern" tmp1463))) ($sc-dispatch tmp1463 (quote (any any))))) (list x1461 y1462)))) (quasivector1443 (lambda (x1470) ((lambda (tmp1471) ((lambda (x1472) ((lambda (tmp1473) ((lambda (tmp1474) (if tmp1474 (apply (lambda (x1475) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1475))) tmp1474) ((lambda (tmp1477) (if tmp1477 (apply (lambda (x1478) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1478)) tmp1477) ((lambda (_1480) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1472)) tmp1473))) ($sc-dispatch tmp1473 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1473 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1472)) tmp1471)) x1470))) (quasi1444 (lambda (p1481 lev1482) ((lambda (tmp1483) ((lambda (tmp1484) (if tmp1484 (apply (lambda (p1485) (if (= lev1482 0) p1485 (quasicons1441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1444 (list p1485) (- lev1482 1))))) tmp1484) ((lambda (tmp1486) (if (if tmp1486 (apply (lambda (args1487) (= lev1482 0)) tmp1486) #f) (apply (lambda (args1488) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1481 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1488))) tmp1486) ((lambda (tmp1489) (if tmp1489 (apply (lambda (p1490 q1491) (if (= lev1482 0) (quasiappend1442 p1490 (quasi1444 q1491 lev1482)) (quasicons1441 (quasicons1441 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1444 (list p1490) (- lev1482 1))) (quasi1444 q1491 lev1482)))) tmp1489) ((lambda (tmp1492) (if (if tmp1492 (apply (lambda (args1493 q1494) (= lev1482 0)) tmp1492) #f) (apply (lambda (args1495 q1496) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1481 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1495))) tmp1492) ((lambda (tmp1497) (if tmp1497 (apply (lambda (p1498) (quasicons1441 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1444 (list p1498) (+ lev1482 1)))) tmp1497) ((lambda (tmp1499) (if tmp1499 (apply (lambda (p1500 q1501) (quasicons1441 (quasi1444 p1500 lev1482) (quasi1444 q1501 lev1482))) tmp1499) ((lambda (tmp1502) (if tmp1502 (apply (lambda (x1503) (quasivector1443 (quasi1444 x1503 lev1482))) tmp1502) ((lambda (p1505) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1505)) tmp1483))) ($sc-dispatch tmp1483 (quote #(vector each-any)))))) ($sc-dispatch tmp1483 (quote (any . any)))))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1483 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1483 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1483 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1481)))) (lambda (x1506) ((lambda (tmp1507) ((lambda (tmp1508) (if tmp1508 (apply (lambda (_1509 e1510) (quasi1444 e1510 0)) tmp1508) (syntax-violation #f "source expression failed to match any pattern" tmp1507))) ($sc-dispatch tmp1507 (quote (any any))))) x1506))))) -(define include (make-syncase-macro (quote macro) (lambda (x1511) (letrec ((read-file1512 (lambda (fn1513 k1514) (let ((p1515 (open-input-file fn1513))) (letrec ((f1516 (lambda (x1517) (if (eof-object? x1517) (begin (close-input-port p1515) (quote ())) (cons (datum->syntax k1514 x1517) (f1516 (read p1515))))))) (f1516 (read p1515))))))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (k1520 filename1521) (let ((fn1522 (syntax->datum filename1521))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (exp1525) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1525)) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote each-any)))) (read-file1512 fn1522 k1520)))) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any))))) x1511))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1527) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (_1530 e1531) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1527)) tmp1529) (syntax-violation #f "source expression failed to match any pattern" tmp1528))) ($sc-dispatch tmp1528 (quote (any any))))) x1527)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (_1535 e1536) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1532)) tmp1534) (syntax-violation #f "source expression failed to match any pattern" tmp1533))) ($sc-dispatch tmp1533 (quote (any any))))) x1532)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1537) ((lambda (tmp1538) ((lambda (tmp1539) (if tmp1539 (apply (lambda (_1540 e1541 m11542 m21543) ((lambda (tmp1544) ((lambda (body1545) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1541)) body1545)) tmp1544)) (letrec ((f1546 (lambda (clause1547 clauses1548) (if (null? clauses1548) ((lambda (tmp1550) ((lambda (tmp1551) (if tmp1551 (apply (lambda (e11552 e21553) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11552 e21553))) tmp1551) ((lambda (tmp1555) (if tmp1555 (apply (lambda (k1556 e11557 e21558) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1556)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11557 e21558)))) tmp1555) ((lambda (_1561) (syntax-violation (quote case) "bad clause" x1537 clause1547)) tmp1550))) ($sc-dispatch tmp1550 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1550 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1547) ((lambda (tmp1562) ((lambda (rest1563) ((lambda (tmp1564) ((lambda (tmp1565) (if tmp1565 (apply (lambda (k1566 e11567 e21568) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1566)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11567 e21568)) rest1563)) tmp1565) ((lambda (_1571) (syntax-violation (quote case) "bad clause" x1537 clause1547)) tmp1564))) ($sc-dispatch tmp1564 (quote (each-any any . each-any))))) clause1547)) tmp1562)) (f1546 (car clauses1548) (cdr clauses1548))))))) (f1546 m11542 m21543)))) tmp1539) (syntax-violation #f "source expression failed to match any pattern" tmp1538))) ($sc-dispatch tmp1538 (quote (any any any . each-any))))) x1537)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1572) ((lambda (tmp1573) ((lambda (tmp1574) (if tmp1574 (apply (lambda (_1575 e1576) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1576)) (list (cons _1575 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1576 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1574) (syntax-violation #f "source expression failed to match any pattern" tmp1573))) ($sc-dispatch tmp1573 (quote (any any))))) x1572)))) +(letrec ((and-map*151 (lambda (f191 first190 . rest189) (let ((t192 (null? first190))) (if t192 t192 (if (null? rest189) (letrec ((andmap193 (lambda (first194) (let ((x195 (car first194)) (first196 (cdr first194))) (if (null? first196) (f191 x195) (if (f191 x195) (andmap193 first196) #f)))))) (andmap193 first190)) (letrec ((andmap197 (lambda (first198 rest199) (let ((x200 (car first198)) (xr201 (map car rest199)) (first202 (cdr first198)) (rest203 (map cdr rest199))) (if (null? first202) (apply f191 (cons x200 xr201)) (if (apply f191 (cons x200 xr201)) (andmap197 first202 rest203) #f)))))) (andmap197 first190 rest189)))))))) (letrec ((lambda-var-list296 (lambda (vars420) (letrec ((lvl421 (lambda (vars422 ls423 w424) (if (pair? vars422) (lvl421 (cdr vars422) (cons (wrap276 (car vars422) w424 #f) ls423) w424) (if (id?248 vars422) (cons (wrap276 vars422 w424 #f) ls423) (if (null? vars422) ls423 (if (syntax-object?232 vars422) (lvl421 (syntax-object-expression233 vars422) ls423 (join-wraps267 w424 (syntax-object-wrap234 vars422))) (cons vars422 ls423)))))))) (lvl421 vars420 (quote ()) (quote (())))))) (gen-var295 (lambda (id425) (let ((id426 (if (syntax-object?232 id425) (syntax-object-expression233 id425) id425))) (gensym (symbol->string id426))))) (strip294 (lambda (x427 w428) (if (memq (quote top) (wrap-marks251 w428)) x427 (letrec ((f429 (lambda (x430) (if (syntax-object?232 x430) (strip294 (syntax-object-expression233 x430) (syntax-object-wrap234 x430)) (if (pair? x430) (let ((a431 (f429 (car x430))) (d432 (f429 (cdr x430)))) (if (if (eq? a431 (car x430)) (eq? d432 (cdr x430)) #f) x430 (cons a431 d432))) (if (vector? x430) (let ((old433 (vector->list x430))) (let ((new434 (map f429 old433))) (if (and-map*151 eq? old433 new434) x430 (list->vector new434)))) x430)))))) (f429 x427))))) (ellipsis?293 (lambda (x435) (if (nonsymbol-id?247 x435) (free-id=?271 x435 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void292 (lambda () (build-void214 #f))) (eval-local-transformer291 (lambda (expanded436 mod437) (let ((p438 (local-eval-hook211 expanded436 mod437))) (if (procedure? p438) p438 (syntax-violation #f "nonprocedure transformer" p438))))) (chi-local-syntax290 (lambda (rec?439 e440 r441 w442 s443 mod444 k445) ((lambda (tmp446) ((lambda (tmp447) (if tmp447 (apply (lambda (_448 id449 val450 e1451 e2452) (let ((ids453 id449)) (if (not (valid-bound-ids?273 ids453)) (syntax-violation #f "duplicate bound keyword" e440) (let ((labels455 (gen-labels254 ids453))) (let ((new-w456 (make-binding-wrap265 ids453 labels455 w442))) (k445 (cons e1451 e2452) (extend-env242 labels455 (let ((w458 (if rec?439 new-w456 w442)) (trans-r459 (macros-only-env244 r441))) (map (lambda (x460) (cons (quote macro) (eval-local-transformer291 (chi284 x460 trans-r459 w458 mod444) mod444))) val450)) r441) new-w456 s443 mod444)))))) tmp447) ((lambda (_462) (syntax-violation #f "bad local syntax definition" (source-wrap277 e440 w442 s443 mod444))) tmp446))) ($sc-dispatch tmp446 (quote (any #(each (any any)) any . each-any))))) e440))) (chi-lambda-clause289 (lambda (e463 docstring464 c465 r466 w467 mod468 k469) ((lambda (tmp470) ((lambda (tmp471) (if (if tmp471 (apply (lambda (args472 doc473 e1474 e2475) (if (string? (syntax->datum doc473)) (not docstring464) #f)) tmp471) #f) (apply (lambda (args476 doc477 e1478 e2479) (chi-lambda-clause289 e463 doc477 (cons args476 (cons e1478 e2479)) r466 w467 mod468 k469)) tmp471) ((lambda (tmp481) (if tmp481 (apply (lambda (id482 e1483 e2484) (let ((ids485 id482)) (if (not (valid-bound-ids?273 ids485)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels487 (gen-labels254 ids485)) (new-vars488 (map gen-var295 ids485))) (k469 (map syntax->datum ids485) new-vars488 (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1483 e2484) e463 (extend-var-env243 labels487 new-vars488 r466) (make-binding-wrap265 ids485 labels487 w467) mod468)))))) tmp481) ((lambda (tmp490) (if tmp490 (apply (lambda (ids491 e1492 e2493) (let ((old-ids494 (lambda-var-list296 ids491))) (if (not (valid-bound-ids?273 old-ids494)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels495 (gen-labels254 old-ids494)) (new-vars496 (map gen-var295 old-ids494))) (k469 (letrec ((f497 (lambda (ls1498 ls2499) (if (null? ls1498) (syntax->datum ls2499) (f497 (cdr ls1498) (cons (syntax->datum (car ls1498)) ls2499)))))) (f497 (cdr old-ids494) (car old-ids494))) (letrec ((f500 (lambda (ls1501 ls2502) (if (null? ls1501) ls2502 (f500 (cdr ls1501) (cons (car ls1501) ls2502)))))) (f500 (cdr new-vars496) (car new-vars496))) (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1492 e2493) e463 (extend-var-env243 labels495 new-vars496 r466) (make-binding-wrap265 old-ids494 labels495 w467) mod468)))))) tmp490) ((lambda (_504) (syntax-violation (quote lambda) "bad lambda" e463)) tmp470))) ($sc-dispatch tmp470 (quote (any any . each-any)))))) ($sc-dispatch tmp470 (quote (each-any any . each-any)))))) ($sc-dispatch tmp470 (quote (any any any . each-any))))) c465))) (chi-body288 (lambda (body505 outer-form506 r507 w508 mod509) (let ((r510 (cons (quote ("placeholder" placeholder)) r507))) (let ((ribcage511 (make-ribcage255 (quote ()) (quote ()) (quote ())))) (let ((w512 (make-wrap250 (wrap-marks251 w508) (cons ribcage511 (wrap-subst252 w508))))) (letrec ((parse513 (lambda (body514 ids515 labels516 var-ids517 vars518 vals519 bindings520) (if (null? body514) (syntax-violation #f "no expressions in body" outer-form506) (let ((e522 (cdar body514)) (er523 (caar body514))) (call-with-values (lambda () (syntax-type282 e522 er523 (quote (())) (source-annotation239 er523) ribcage511 mod509)) (lambda (type524 value525 e526 w527 s528 mod529) (if (memv type524 (quote (define-form))) (let ((id530 (wrap276 value525 w527 mod529)) (label531 (gen-label253))) (let ((var532 (gen-var295 id530))) (begin (extend-ribcage!264 ribcage511 id530 label531) (parse513 (cdr body514) (cons id530 ids515) (cons label531 labels516) (cons id530 var-ids517) (cons var532 vars518) (cons (cons er523 (wrap276 e526 w527 mod529)) vals519) (cons (cons (quote lexical) var532) bindings520))))) (if (memv type524 (quote (define-syntax-form))) (let ((id533 (wrap276 value525 w527 mod529)) (label534 (gen-label253))) (begin (extend-ribcage!264 ribcage511 id533 label534) (parse513 (cdr body514) (cons id533 ids515) (cons label534 labels516) var-ids517 vars518 vals519 (cons (cons (quote macro) (cons er523 (wrap276 e526 w527 mod529))) bindings520)))) (if (memv type524 (quote (begin-form))) ((lambda (tmp535) ((lambda (tmp536) (if tmp536 (apply (lambda (_537 e1538) (parse513 (letrec ((f539 (lambda (forms540) (if (null? forms540) (cdr body514) (cons (cons er523 (wrap276 (car forms540) w527 mod529)) (f539 (cdr forms540))))))) (f539 e1538)) ids515 labels516 var-ids517 vars518 vals519 bindings520)) tmp536) (syntax-violation #f "source expression failed to match any pattern" tmp535))) ($sc-dispatch tmp535 (quote (any . each-any))))) e526) (if (memv type524 (quote (local-syntax-form))) (chi-local-syntax290 value525 e526 er523 w527 s528 mod529 (lambda (forms542 er543 w544 s545 mod546) (parse513 (letrec ((f547 (lambda (forms548) (if (null? forms548) (cdr body514) (cons (cons er543 (wrap276 (car forms548) w544 mod546)) (f547 (cdr forms548))))))) (f547 forms542)) ids515 labels516 var-ids517 vars518 vals519 bindings520))) (if (null? ids515) (build-sequence227 #f (map (lambda (x549) (chi284 (cdr x549) (car x549) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))) (begin (if (not (valid-bound-ids?273 ids515)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form506)) (letrec ((loop550 (lambda (bs551 er-cache552 r-cache553) (if (not (null? bs551)) (let ((b554 (car bs551))) (if (eq? (car b554) (quote macro)) (let ((er555 (cadr b554))) (let ((r-cache556 (if (eq? er555 er-cache552) r-cache553 (macros-only-env244 er555)))) (begin (set-cdr! b554 (eval-local-transformer291 (chi284 (cddr b554) r-cache556 (quote (())) mod529) mod529)) (loop550 (cdr bs551) er555 r-cache556)))) (loop550 (cdr bs551) er-cache552 r-cache553))))))) (loop550 bindings520 #f #f)) (set-cdr! r510 (extend-env242 labels516 bindings520 (cdr r510))) (build-letrec230 #f (map syntax->datum var-ids517) vars518 (map (lambda (x557) (chi284 (cdr x557) (car x557) (quote (())) mod529)) vals519) (build-sequence227 #f (map (lambda (x558) (chi284 (cdr x558) (car x558) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))))))))))))))))) (parse513 (map (lambda (x521) (cons r510 (wrap276 x521 w512 mod509))) body505) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro287 (lambda (p559 e560 r561 w562 rib563 mod564) (letrec ((rebuild-macro-output565 (lambda (x566 m567) (if (pair? x566) (cons (rebuild-macro-output565 (car x566) m567) (rebuild-macro-output565 (cdr x566) m567)) (if (syntax-object?232 x566) (let ((w568 (syntax-object-wrap234 x566))) (let ((ms569 (wrap-marks251 w568)) (s570 (wrap-subst252 w568))) (if (if (pair? ms569) (eq? (car ms569) #f) #f) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cdr ms569) (if rib563 (cons rib563 (cdr s570)) (cdr s570))) (syntax-object-module235 x566)) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cons m567 ms569) (if rib563 (cons rib563 (cons (quote shift) s570)) (cons (quote shift) s570))) (let ((pmod571 (procedure-module p559))) (if pmod571 (cons (quote hygiene) (module-name pmod571)) (quote (hygiene guile)))))))) (if (vector? x566) (let ((n572 (vector-length x566))) (let ((v573 (make-vector n572))) (letrec ((loop574 (lambda (i575) (if (fx=208 i575 n572) (begin (if #f #f) v573) (begin (vector-set! v573 i575 (rebuild-macro-output565 (vector-ref x566 i575) m567)) (loop574 (fx+206 i575 1))))))) (loop574 0)))) (if (symbol? x566) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap277 e560 w562 s mod564) x566) x566))))))) (rebuild-macro-output565 (p559 (wrap276 e560 (anti-mark263 w562) mod564)) (string #\m))))) (chi-application286 (lambda (x576 e577 r578 w579 s580 mod581) ((lambda (tmp582) ((lambda (tmp583) (if tmp583 (apply (lambda (e0584 e1585) (build-application215 s580 x576 (map (lambda (e586) (chi284 e586 r578 w579 mod581)) e1585))) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp582))) ($sc-dispatch tmp582 (quote (any . each-any))))) e577))) (chi-expr285 (lambda (type588 value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (lexical))) (build-lexical-reference217 (quote value) s593 e590 value589) (if (memv type588 (quote (core external-macro))) (value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (module-ref))) (call-with-values (lambda () (value589 e590)) (lambda (id595 mod596) (build-global-reference220 s593 id595 mod596))) (if (memv type588 (quote (lexical-call))) (chi-application286 (build-lexical-reference217 (quote fun) (source-annotation239 (car e590)) (car e590) value589) e590 r591 w592 s593 mod594) (if (memv type588 (quote (global-call))) (chi-application286 (build-global-reference220 (source-annotation239 (car e590)) value589 (if (syntax-object?232 (car e590)) (syntax-object-module235 (car e590)) mod594)) e590 r591 w592 s593 mod594) (if (memv type588 (quote (constant))) (build-data226 s593 (strip294 (source-wrap277 e590 w592 s593 mod594) (quote (())))) (if (memv type588 (quote (global))) (build-global-reference220 s593 value589 mod594) (if (memv type588 (quote (call))) (chi-application286 (chi284 (car e590) r591 w592 mod594) e590 r591 w592 s593 mod594) (if (memv type588 (quote (begin-form))) ((lambda (tmp597) ((lambda (tmp598) (if tmp598 (apply (lambda (_599 e1600 e2601) (chi-sequence278 (cons e1600 e2601) r591 w592 s593 mod594)) tmp598) (syntax-violation #f "source expression failed to match any pattern" tmp597))) ($sc-dispatch tmp597 (quote (any any . each-any))))) e590) (if (memv type588 (quote (local-syntax-form))) (chi-local-syntax290 value589 e590 r591 w592 s593 mod594 chi-sequence278) (if (memv type588 (quote (eval-when-form))) ((lambda (tmp603) ((lambda (tmp604) (if tmp604 (apply (lambda (_605 x606 e1607 e2608) (let ((when-list609 (chi-when-list281 e590 x606 w592))) (if (memq (quote eval) when-list609) (chi-sequence278 (cons e1607 e2608) r591 w592 s593 mod594) (chi-void292)))) tmp604) (syntax-violation #f "source expression failed to match any pattern" tmp603))) ($sc-dispatch tmp603 (quote (any each-any any . each-any))))) e590) (if (memv type588 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e590 (wrap276 value589 w592 mod594)) (if (memv type588 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap277 e590 w592 s593 mod594)) (if (memv type588 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap277 e590 w592 s593 mod594)) (syntax-violation #f "unexpected syntax" (source-wrap277 e590 w592 s593 mod594)))))))))))))))))) (chi284 (lambda (e612 r613 w614 mod615) (call-with-values (lambda () (syntax-type282 e612 r613 w614 (source-annotation239 e612) #f mod615)) (lambda (type616 value617 e618 w619 s620 mod621) (chi-expr285 type616 value617 e618 r613 w619 s620 mod621))))) (chi-top283 (lambda (e622 r623 w624 m625 esew626 mod627) (call-with-values (lambda () (syntax-type282 e622 r623 w624 (source-annotation239 e622) #f mod627)) (lambda (type635 value636 e637 w638 s639 mod640) (if (memv type635 (quote (begin-form))) ((lambda (tmp641) ((lambda (tmp642) (if tmp642 (apply (lambda (_643) (chi-void292)) tmp642) ((lambda (tmp644) (if tmp644 (apply (lambda (_645 e1646 e2647) (chi-top-sequence279 (cons e1646 e2647) r623 w638 s639 m625 esew626 mod640)) tmp644) (syntax-violation #f "source expression failed to match any pattern" tmp641))) ($sc-dispatch tmp641 (quote (any any . each-any)))))) ($sc-dispatch tmp641 (quote (any))))) e637) (if (memv type635 (quote (local-syntax-form))) (chi-local-syntax290 value636 e637 r623 w638 s639 mod640 (lambda (body649 r650 w651 s652 mod653) (chi-top-sequence279 body649 r650 w651 s652 m625 esew626 mod653))) (if (memv type635 (quote (eval-when-form))) ((lambda (tmp654) ((lambda (tmp655) (if tmp655 (apply (lambda (_656 x657 e1658 e2659) (let ((when-list660 (chi-when-list281 e637 x657 w638)) (body661 (cons e1658 e2659))) (if (eq? m625 (quote e)) (if (memq (quote eval) when-list660) (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) (chi-void292)) (if (memq (quote load) when-list660) (if (let ((t664 (memq (quote compile) when-list660))) (if t664 t664 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (chi-top-sequence279 body661 r623 w638 s639 (quote c&e) (quote (compile load)) mod640) (if (memq m625 (quote (c c&e))) (chi-top-sequence279 body661 r623 w638 s639 (quote c) (quote (load)) mod640) (chi-void292))) (if (let ((t665 (memq (quote compile) when-list660))) (if t665 t665 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (begin (top-level-eval-hook210 (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) mod640) (chi-void292)) (chi-void292)))))) tmp655) (syntax-violation #f "source expression failed to match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any each-any any . each-any))))) e637) (if (memv type635 (quote (define-syntax-form))) (let ((n666 (id-var-name270 value636 w638)) (r667 (macros-only-env244 r623))) (if (memv m625 (quote (c))) (if (memq (quote compile) esew626) (let ((e668 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e668 mod640) (if (memq (quote load) esew626) e668 (chi-void292)))) (if (memq (quote load) esew626) (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) (chi-void292))) (if (memv m625 (quote (c&e))) (let ((e669 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e669 mod640) e669)) (begin (if (memq (quote eval) esew626) (top-level-eval-hook210 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) mod640)) (chi-void292))))) (if (memv type635 (quote (define-form))) (let ((n670 (id-var-name270 value636 w638))) (let ((type671 (binding-type240 (lookup245 n670 r623 mod640)))) (if (memv type671 (quote (global core macro module-ref))) (let ((x672 (build-global-definition223 s639 n670 (chi284 e637 r623 w638 mod640)))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x672 mod640)) x672)) (if (memv type671 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e637 (wrap276 value636 w638 mod640)) (syntax-violation #f "cannot define keyword at top level" e637 (wrap276 value636 w638 mod640)))))) (let ((x673 (chi-expr285 type635 value636 e637 r623 w638 s639 mod640))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x673 mod640)) x673))))))))))) (syntax-type282 (lambda (e674 r675 w676 s677 rib678 mod679) (if (symbol? e674) (let ((n680 (id-var-name270 e674 w676))) (let ((b681 (lookup245 n680 r675 mod679))) (let ((type682 (binding-type240 b681))) (if (memv type682 (quote (lexical))) (values type682 (binding-value241 b681) e674 w676 s677 mod679) (if (memv type682 (quote (global))) (values type682 n680 e674 w676 s677 mod679) (if (memv type682 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b681) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (values type682 (binding-value241 b681) e674 w676 s677 mod679))))))) (if (pair? e674) (let ((first683 (car e674))) (if (id?248 first683) (let ((n684 (id-var-name270 first683 w676))) (let ((b685 (lookup245 n684 r675 (let ((t686 (if (syntax-object?232 first683) (syntax-object-module235 first683) #f))) (if t686 t686 mod679))))) (let ((type687 (binding-type240 b685))) (if (memv type687 (quote (lexical))) (values (quote lexical-call) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (global))) (values (quote global-call) n684 e674 w676 s677 mod679) (if (memv type687 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b685) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (if (memv type687 (quote (core external-macro module-ref))) (values type687 (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (begin))) (values (quote begin-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (eval-when))) (values (quote eval-when-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (define))) ((lambda (tmp688) ((lambda (tmp689) (if (if tmp689 (apply (lambda (_690 name691 val692) (id?248 name691)) tmp689) #f) (apply (lambda (_693 name694 val695) (values (quote define-form) name694 val695 w676 s677 mod679)) tmp689) ((lambda (tmp696) (if (if tmp696 (apply (lambda (_697 name698 args699 e1700 e2701) (if (id?248 name698) (valid-bound-ids?273 (lambda-var-list296 args699)) #f)) tmp696) #f) (apply (lambda (_702 name703 args704 e1705 e2706) (values (quote define-form) (wrap276 name703 w676 mod679) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap276 (cons args704 (cons e1705 e2706)) w676 mod679)) (quote (())) s677 mod679)) tmp696) ((lambda (tmp708) (if (if tmp708 (apply (lambda (_709 name710) (id?248 name710)) tmp708) #f) (apply (lambda (_711 name712) (values (quote define-form) (wrap276 name712 w676 mod679) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s677 mod679)) tmp708) (syntax-violation #f "source expression failed to match any pattern" tmp688))) ($sc-dispatch tmp688 (quote (any any)))))) ($sc-dispatch tmp688 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp688 (quote (any any any))))) e674) (if (memv type687 (quote (define-syntax))) ((lambda (tmp713) ((lambda (tmp714) (if (if tmp714 (apply (lambda (_715 name716 val717) (id?248 name716)) tmp714) #f) (apply (lambda (_718 name719 val720) (values (quote define-syntax-form) name719 val720 w676 s677 mod679)) tmp714) (syntax-violation #f "source expression failed to match any pattern" tmp713))) ($sc-dispatch tmp713 (quote (any any any))))) e674) (values (quote call) #f e674 w676 s677 mod679))))))))))))) (values (quote call) #f e674 w676 s677 mod679))) (if (syntax-object?232 e674) (syntax-type282 (syntax-object-expression233 e674) r675 (join-wraps267 w676 (syntax-object-wrap234 e674)) s677 rib678 (let ((t721 (syntax-object-module235 e674))) (if t721 t721 mod679))) (if (self-evaluating? e674) (values (quote constant) #f e674 w676 s677 mod679) (values (quote other) #f e674 w676 s677 mod679))))))) (chi-when-list281 (lambda (e722 when-list723 w724) (letrec ((f725 (lambda (when-list726 situations727) (if (null? when-list726) situations727 (f725 (cdr when-list726) (cons (let ((x728 (car when-list726))) (if (free-id=?271 x728 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?271 x728 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?271 x728 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e722 (wrap276 x728 w724 #f)))))) situations727)))))) (f725 when-list723 (quote ()))))) (chi-install-global280 (lambda (name729 e730) (build-global-definition223 #f name729 (if (let ((v731 (module-variable (current-module) name729))) (if v731 (if (variable-bound? v731) (if (macro? (variable-ref v731)) (not (eq? (macro-type (variable-ref v731)) (quote syncase-macro))) #f) #f) #f)) (build-application215 #f (build-primref225 #f (quote make-extended-syncase-macro)) (list (build-application215 #f (build-primref225 #f (quote module-ref)) (list (build-application215 #f (build-primref225 #f (quote current-module)) (quote ())) (build-data226 #f name729))) (build-data226 #f (quote macro)) e730)) (build-application215 #f (build-primref225 #f (quote make-syncase-macro)) (list (build-data226 #f (quote macro)) e730)))))) (chi-top-sequence279 (lambda (body732 r733 w734 s735 m736 esew737 mod738) (build-sequence227 s735 (letrec ((dobody739 (lambda (body740 r741 w742 m743 esew744 mod745) (if (null? body740) (quote ()) (let ((first746 (chi-top283 (car body740) r741 w742 m743 esew744 mod745))) (cons first746 (dobody739 (cdr body740) r741 w742 m743 esew744 mod745))))))) (dobody739 body732 r733 w734 m736 esew737 mod738))))) (chi-sequence278 (lambda (body747 r748 w749 s750 mod751) (build-sequence227 s750 (letrec ((dobody752 (lambda (body753 r754 w755 mod756) (if (null? body753) (quote ()) (let ((first757 (chi284 (car body753) r754 w755 mod756))) (cons first757 (dobody752 (cdr body753) r754 w755 mod756))))))) (dobody752 body747 r748 w749 mod751))))) (source-wrap277 (lambda (x758 w759 s760 defmod761) (begin (if (if s760 (pair? x758) #f) (set-source-properties! x758 s760)) (wrap276 x758 w759 defmod761)))) (wrap276 (lambda (x762 w763 defmod764) (if (if (null? (wrap-marks251 w763)) (null? (wrap-subst252 w763)) #f) x762 (if (syntax-object?232 x762) (make-syntax-object231 (syntax-object-expression233 x762) (join-wraps267 w763 (syntax-object-wrap234 x762)) (syntax-object-module235 x762)) (if (null? x762) x762 (make-syntax-object231 x762 w763 defmod764)))))) (bound-id-member?275 (lambda (x765 list766) (if (not (null? list766)) (let ((t767 (bound-id=?272 x765 (car list766)))) (if t767 t767 (bound-id-member?275 x765 (cdr list766)))) #f))) (distinct-bound-ids?274 (lambda (ids768) (letrec ((distinct?769 (lambda (ids770) (let ((t771 (null? ids770))) (if t771 t771 (if (not (bound-id-member?275 (car ids770) (cdr ids770))) (distinct?769 (cdr ids770)) #f)))))) (distinct?769 ids768)))) (valid-bound-ids?273 (lambda (ids772) (if (letrec ((all-ids?773 (lambda (ids774) (let ((t775 (null? ids774))) (if t775 t775 (if (id?248 (car ids774)) (all-ids?773 (cdr ids774)) #f)))))) (all-ids?773 ids772)) (distinct-bound-ids?274 ids772) #f))) (bound-id=?272 (lambda (i776 j777) (if (if (syntax-object?232 i776) (syntax-object?232 j777) #f) (if (eq? (syntax-object-expression233 i776) (syntax-object-expression233 j777)) (same-marks?269 (wrap-marks251 (syntax-object-wrap234 i776)) (wrap-marks251 (syntax-object-wrap234 j777))) #f) (eq? i776 j777)))) (free-id=?271 (lambda (i778 j779) (if (eq? (let ((x780 i778)) (if (syntax-object?232 x780) (syntax-object-expression233 x780) x780)) (let ((x781 j779)) (if (syntax-object?232 x781) (syntax-object-expression233 x781) x781))) (eq? (id-var-name270 i778 (quote (()))) (id-var-name270 j779 (quote (())))) #f))) (id-var-name270 (lambda (id782 w783) (letrec ((search-vector-rib786 (lambda (sym792 subst793 marks794 symnames795 ribcage796) (let ((n797 (vector-length symnames795))) (letrec ((f798 (lambda (i799) (if (fx=208 i799 n797) (search784 sym792 (cdr subst793) marks794) (if (if (eq? (vector-ref symnames795 i799) sym792) (same-marks?269 marks794 (vector-ref (ribcage-marks258 ribcage796) i799)) #f) (values (vector-ref (ribcage-labels259 ribcage796) i799) marks794) (f798 (fx+206 i799 1))))))) (f798 0))))) (search-list-rib785 (lambda (sym800 subst801 marks802 symnames803 ribcage804) (letrec ((f805 (lambda (symnames806 i807) (if (null? symnames806) (search784 sym800 (cdr subst801) marks802) (if (if (eq? (car symnames806) sym800) (same-marks?269 marks802 (list-ref (ribcage-marks258 ribcage804) i807)) #f) (values (list-ref (ribcage-labels259 ribcage804) i807) marks802) (f805 (cdr symnames806) (fx+206 i807 1))))))) (f805 symnames803 0)))) (search784 (lambda (sym808 subst809 marks810) (if (null? subst809) (values #f marks810) (let ((fst811 (car subst809))) (if (eq? fst811 (quote shift)) (search784 sym808 (cdr subst809) (cdr marks810)) (let ((symnames812 (ribcage-symnames257 fst811))) (if (vector? symnames812) (search-vector-rib786 sym808 subst809 marks810 symnames812 fst811) (search-list-rib785 sym808 subst809 marks810 symnames812 fst811))))))))) (if (symbol? id782) (let ((t813 (call-with-values (lambda () (search784 id782 (wrap-subst252 w783) (wrap-marks251 w783))) (lambda (x815 . ignore814) x815)))) (if t813 t813 id782)) (if (syntax-object?232 id782) (let ((id816 (syntax-object-expression233 id782)) (w1817 (syntax-object-wrap234 id782))) (let ((marks818 (join-marks268 (wrap-marks251 w783) (wrap-marks251 w1817)))) (call-with-values (lambda () (search784 id816 (wrap-subst252 w783) marks818)) (lambda (new-id819 marks820) (let ((t821 new-id819)) (if t821 t821 (let ((t822 (call-with-values (lambda () (search784 id816 (wrap-subst252 w1817) marks820)) (lambda (x824 . ignore823) x824)))) (if t822 t822 id816)))))))) (syntax-violation (quote id-var-name) "invalid id" id782)))))) (same-marks?269 (lambda (x825 y826) (let ((t827 (eq? x825 y826))) (if t827 t827 (if (not (null? x825)) (if (not (null? y826)) (if (eq? (car x825) (car y826)) (same-marks?269 (cdr x825) (cdr y826)) #f) #f) #f))))) (join-marks268 (lambda (m1828 m2829) (smart-append266 m1828 m2829))) (join-wraps267 (lambda (w1830 w2831) (let ((m1832 (wrap-marks251 w1830)) (s1833 (wrap-subst252 w1830))) (if (null? m1832) (if (null? s1833) w2831 (make-wrap250 (wrap-marks251 w2831) (smart-append266 s1833 (wrap-subst252 w2831)))) (make-wrap250 (smart-append266 m1832 (wrap-marks251 w2831)) (smart-append266 s1833 (wrap-subst252 w2831))))))) (smart-append266 (lambda (m1834 m2835) (if (null? m2835) m1834 (append m1834 m2835)))) (make-binding-wrap265 (lambda (ids836 labels837 w838) (if (null? ids836) w838 (make-wrap250 (wrap-marks251 w838) (cons (let ((labelvec839 (list->vector labels837))) (let ((n840 (vector-length labelvec839))) (let ((symnamevec841 (make-vector n840)) (marksvec842 (make-vector n840))) (begin (letrec ((f843 (lambda (ids844 i845) (if (not (null? ids844)) (call-with-values (lambda () (id-sym-name&marks249 (car ids844) w838)) (lambda (symname846 marks847) (begin (vector-set! symnamevec841 i845 symname846) (vector-set! marksvec842 i845 marks847) (f843 (cdr ids844) (fx+206 i845 1))))))))) (f843 ids836 0)) (make-ribcage255 symnamevec841 marksvec842 labelvec839))))) (wrap-subst252 w838)))))) (extend-ribcage!264 (lambda (ribcage848 id849 label850) (begin (set-ribcage-symnames!260 ribcage848 (cons (syntax-object-expression233 id849) (ribcage-symnames257 ribcage848))) (set-ribcage-marks!261 ribcage848 (cons (wrap-marks251 (syntax-object-wrap234 id849)) (ribcage-marks258 ribcage848))) (set-ribcage-labels!262 ribcage848 (cons label850 (ribcage-labels259 ribcage848)))))) (anti-mark263 (lambda (w851) (make-wrap250 (cons #f (wrap-marks251 w851)) (cons (quote shift) (wrap-subst252 w851))))) (set-ribcage-labels!262 (lambda (x852 update853) (vector-set! x852 3 update853))) (set-ribcage-marks!261 (lambda (x854 update855) (vector-set! x854 2 update855))) (set-ribcage-symnames!260 (lambda (x856 update857) (vector-set! x856 1 update857))) (ribcage-labels259 (lambda (x858) (vector-ref x858 3))) (ribcage-marks258 (lambda (x859) (vector-ref x859 2))) (ribcage-symnames257 (lambda (x860) (vector-ref x860 1))) (ribcage?256 (lambda (x861) (if (vector? x861) (if (= (vector-length x861) 4) (eq? (vector-ref x861 0) (quote ribcage)) #f) #f))) (make-ribcage255 (lambda (symnames862 marks863 labels864) (vector (quote ribcage) symnames862 marks863 labels864))) (gen-labels254 (lambda (ls865) (if (null? ls865) (quote ()) (cons (gen-label253) (gen-labels254 (cdr ls865)))))) (gen-label253 (lambda () (string #\i))) (wrap-subst252 cdr) (wrap-marks251 car) (make-wrap250 cons) (id-sym-name&marks249 (lambda (x866 w867) (if (syntax-object?232 x866) (values (syntax-object-expression233 x866) (join-marks268 (wrap-marks251 w867) (wrap-marks251 (syntax-object-wrap234 x866)))) (values x866 (wrap-marks251 w867))))) (id?248 (lambda (x868) (if (symbol? x868) #t (if (syntax-object?232 x868) (symbol? (syntax-object-expression233 x868)) #f)))) (nonsymbol-id?247 (lambda (x869) (if (syntax-object?232 x869) (symbol? (syntax-object-expression233 x869)) #f))) (global-extend246 (lambda (type870 sym871 val872) (put-global-definition-hook212 sym871 type870 val872))) (lookup245 (lambda (x873 r874 mod875) (let ((t876 (assq x873 r874))) (if t876 (cdr t876) (if (symbol? x873) (let ((t877 (get-global-definition-hook213 x873 mod875))) (if t877 t877 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env244 (lambda (r878) (if (null? r878) (quote ()) (let ((a879 (car r878))) (if (eq? (cadr a879) (quote macro)) (cons a879 (macros-only-env244 (cdr r878))) (macros-only-env244 (cdr r878))))))) (extend-var-env243 (lambda (labels880 vars881 r882) (if (null? labels880) r882 (extend-var-env243 (cdr labels880) (cdr vars881) (cons (cons (car labels880) (cons (quote lexical) (car vars881))) r882))))) (extend-env242 (lambda (labels883 bindings884 r885) (if (null? labels883) r885 (extend-env242 (cdr labels883) (cdr bindings884) (cons (cons (car labels883) (car bindings884)) r885))))) (binding-value241 cdr) (binding-type240 car) (source-annotation239 (lambda (x886) (if (syntax-object?232 x886) (source-annotation239 (syntax-object-expression233 x886)) (if (pair? x886) (let ((props887 (source-properties x886))) (if (pair? props887) props887 #f)) #f)))) (set-syntax-object-module!238 (lambda (x888 update889) (vector-set! x888 3 update889))) (set-syntax-object-wrap!237 (lambda (x890 update891) (vector-set! x890 2 update891))) (set-syntax-object-expression!236 (lambda (x892 update893) (vector-set! x892 1 update893))) (syntax-object-module235 (lambda (x894) (vector-ref x894 3))) (syntax-object-wrap234 (lambda (x895) (vector-ref x895 2))) (syntax-object-expression233 (lambda (x896) (vector-ref x896 1))) (syntax-object?232 (lambda (x897) (if (vector? x897) (if (= (vector-length x897) 4) (eq? (vector-ref x897 0) (quote syntax-object)) #f) #f))) (make-syntax-object231 (lambda (expression898 wrap899 module900) (vector (quote syntax-object) expression898 wrap899 module900))) (build-letrec230 (lambda (src901 ids902 vars903 val-exps904 body-exp905) (if (null? vars903) body-exp905 (let ((atom-key906 (fluid-ref *mode*205))) (if (memv atom-key906 (quote (c))) (begin (for-each maybe-name-value!222 ids902 val-exps904) ((@ (language tree-il) make-letrec) src901 ids902 vars903 val-exps904 body-exp905)) (list (quote letrec) (map list vars903 val-exps904) body-exp905)))))) (build-named-let229 (lambda (src907 ids908 vars909 val-exps910 body-exp911) (let ((f912 (car vars909)) (f-name913 (car ids908)) (vars914 (cdr vars909)) (ids915 (cdr ids908))) (let ((atom-key916 (fluid-ref *mode*205))) (if (memv atom-key916 (quote (c))) (let ((proc917 (build-lambda224 src907 ids915 vars914 #f body-exp911))) (begin (maybe-name-value!222 f-name913 proc917) (for-each maybe-name-value!222 ids915 val-exps910) ((@ (language tree-il) make-letrec) src907 (list f-name913) (list f912) (list proc917) (build-application215 src907 (build-lexical-reference217 (quote fun) src907 f-name913 f912) val-exps910)))) (list (quote let) f912 (map list vars914 val-exps910) body-exp911)))))) (build-let228 (lambda (src918 ids919 vars920 val-exps921 body-exp922) (if (null? vars920) body-exp922 (let ((atom-key923 (fluid-ref *mode*205))) (if (memv atom-key923 (quote (c))) (begin (for-each maybe-name-value!222 ids919 val-exps921) ((@ (language tree-il) make-let) src918 ids919 vars920 val-exps921 body-exp922)) (list (quote let) (map list vars920 val-exps921) body-exp922)))))) (build-sequence227 (lambda (src924 exps925) (if (null? (cdr exps925)) (car exps925) (let ((atom-key926 (fluid-ref *mode*205))) (if (memv atom-key926 (quote (c))) ((@ (language tree-il) make-sequence) src924 exps925) (cons (quote begin) exps925)))))) (build-data226 (lambda (src927 exp928) (let ((atom-key929 (fluid-ref *mode*205))) (if (memv atom-key929 (quote (c))) ((@ (language tree-il) make-const) src927 exp928) (if (if (self-evaluating? exp928) (not (vector? exp928)) #f) exp928 (list (quote quote) exp928)))))) (build-primref225 (lambda (src930 name931) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key932 (fluid-ref *mode*205))) (if (memv atom-key932 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src930 name931) name931)) (let ((atom-key933 (fluid-ref *mode*205))) (if (memv atom-key933 (quote (c))) ((@ (language tree-il) make-module-ref) src930 (quote (guile)) name931 #f) (list (quote @@) (quote (guile)) name931)))))) (build-lambda224 (lambda (src934 ids935 vars936 docstring937 exp938) (let ((atom-key939 (fluid-ref *mode*205))) (if (memv atom-key939 (quote (c))) ((@ (language tree-il) make-lambda) src934 ids935 vars936 (if docstring937 (list (cons (quote documentation) docstring937)) (quote ())) exp938) (cons (quote lambda) (cons vars936 (append (if docstring937 (list docstring937) (quote ())) (list exp938)))))))) (build-global-definition223 (lambda (source940 var941 exp942) (let ((atom-key943 (fluid-ref *mode*205))) (if (memv atom-key943 (quote (c))) (begin (maybe-name-value!222 var941 exp942) ((@ (language tree-il) make-toplevel-define) source940 var941 exp942)) (list (quote define) var941 exp942))))) (maybe-name-value!222 (lambda (name944 val945) (if ((@ (language tree-il) lambda?) val945) (let ((meta946 ((@ (language tree-il) lambda-meta) val945))) (if (not (assq (quote name) meta946)) ((setter (@ (language tree-il) lambda-meta)) val945 (acons (quote name) name944 meta946))))))) (build-global-assignment221 (lambda (source947 var948 exp949 mod950) (analyze-variable219 mod950 var948 (lambda (mod951 var952 public?953) (let ((atom-key954 (fluid-ref *mode*205))) (if (memv atom-key954 (quote (c))) ((@ (language tree-il) make-module-set) source947 mod951 var952 public?953 exp949) (list (quote set!) (list (if public?953 (quote @) (quote @@)) mod951 var952) exp949)))) (lambda (var955) (let ((atom-key956 (fluid-ref *mode*205))) (if (memv atom-key956 (quote (c))) ((@ (language tree-il) make-toplevel-set) source947 var955 exp949) (list (quote set!) var955 exp949))))))) (build-global-reference220 (lambda (source957 var958 mod959) (analyze-variable219 mod959 var958 (lambda (mod960 var961 public?962) (let ((atom-key963 (fluid-ref *mode*205))) (if (memv atom-key963 (quote (c))) ((@ (language tree-il) make-module-ref) source957 mod960 var961 public?962) (list (if public?962 (quote @) (quote @@)) mod960 var961)))) (lambda (var964) (let ((atom-key965 (fluid-ref *mode*205))) (if (memv atom-key965 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source957 var964) var964)))))) (analyze-variable219 (lambda (mod966 var967 modref-cont968 bare-cont969) (if (not mod966) (bare-cont969 var967) (let ((kind970 (car mod966)) (mod971 (cdr mod966))) (if (memv kind970 (quote (public))) (modref-cont968 mod971 var967 #t) (if (memv kind970 (quote (private))) (if (not (equal? mod971 (module-name (current-module)))) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (if (memv kind970 (quote (bare))) (bare-cont969 var967) (if (memv kind970 (quote (hygiene))) (if (if (not (equal? mod971 (module-name (current-module)))) (module-variable (resolve-module mod971) var967) #f) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (syntax-violation #f "bad module kind" var967 mod971))))))))) (build-lexical-assignment218 (lambda (source972 name973 var974 exp975) (let ((atom-key976 (fluid-ref *mode*205))) (if (memv atom-key976 (quote (c))) ((@ (language tree-il) make-lexical-set) source972 name973 var974 exp975) (list (quote set!) var974 exp975))))) (build-lexical-reference217 (lambda (type977 source978 name979 var980) (let ((atom-key981 (fluid-ref *mode*205))) (if (memv atom-key981 (quote (c))) ((@ (language tree-il) make-lexical-ref) source978 name979 var980) var980)))) (build-conditional216 (lambda (source982 test-exp983 then-exp984 else-exp985) (let ((atom-key986 (fluid-ref *mode*205))) (if (memv atom-key986 (quote (c))) ((@ (language tree-il) make-conditional) source982 test-exp983 then-exp984 else-exp985) (if (equal? else-exp985 (quote (if #f #f))) (list (quote if) test-exp983 then-exp984) (list (quote if) test-exp983 then-exp984 else-exp985)))))) (build-application215 (lambda (source987 fun-exp988 arg-exps989) (let ((atom-key990 (fluid-ref *mode*205))) (if (memv atom-key990 (quote (c))) ((@ (language tree-il) make-application) source987 fun-exp988 arg-exps989) (cons fun-exp988 arg-exps989))))) (build-void214 (lambda (source991) (let ((atom-key992 (fluid-ref *mode*205))) (if (memv atom-key992 (quote (c))) ((@ (language tree-il) make-void) source991) (quote (if #f #f)))))) (get-global-definition-hook213 (lambda (symbol993 module994) (begin (if (if (not module994) (current-module) #f) (warn "module system is booted, we should have a module" symbol993)) (let ((v995 (module-variable (if module994 (resolve-module (cdr module994)) (current-module)) symbol993))) (if v995 (if (variable-bound? v995) (let ((val996 (variable-ref v995))) (if (macro? val996) (if (syncase-macro-type val996) (cons (syncase-macro-type val996) (syncase-macro-binding val996)) #f) #f)) #f) #f))))) (put-global-definition-hook212 (lambda (symbol997 type998 val999) (let ((existing1000 (let ((v1001 (module-variable (current-module) symbol997))) (if v1001 (if (variable-bound? v1001) (let ((val1002 (variable-ref v1001))) (if (macro? val1002) (if (not (syncase-macro-type val1002)) val1002 #f) #f)) #f) #f)))) (module-define! (current-module) symbol997 (if existing1000 (make-extended-syncase-macro existing1000 type998 val999) (make-syncase-macro type998 val999)))))) (local-eval-hook211 (lambda (x1003 mod1004) (primitive-eval (list noexpand204 (let ((atom-key1005 (fluid-ref *mode*205))) (if (memv atom-key1005 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1003) x1003)))))) (top-level-eval-hook210 (lambda (x1006 mod1007) (primitive-eval (list noexpand204 (let ((atom-key1008 (fluid-ref *mode*205))) (if (memv atom-key1008 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1006) x1006)))))) (fx<209 <) (fx=208 =) (fx-207 -) (fx+206 +) (*mode*205 (make-fluid)) (noexpand204 "noexpand")) (begin (global-extend246 (quote local-syntax) (quote letrec-syntax) #t) (global-extend246 (quote local-syntax) (quote let-syntax) #f) (global-extend246 (quote core) (quote fluid-let-syntax) (lambda (e1009 r1010 w1011 s1012 mod1013) ((lambda (tmp1014) ((lambda (tmp1015) (if (if tmp1015 (apply (lambda (_1016 var1017 val1018 e11019 e21020) (valid-bound-ids?273 var1017)) tmp1015) #f) (apply (lambda (_1022 var1023 val1024 e11025 e21026) (let ((names1027 (map (lambda (x1028) (id-var-name270 x1028 w1011)) var1023))) (begin (for-each (lambda (id1030 n1031) (let ((atom-key1032 (binding-type240 (lookup245 n1031 r1010 mod1013)))) (if (memv atom-key1032 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1009 (source-wrap277 id1030 w1011 s1012 mod1013))))) var1023 names1027) (chi-body288 (cons e11025 e21026) (source-wrap277 e1009 w1011 s1012 mod1013) (extend-env242 names1027 (let ((trans-r1035 (macros-only-env244 r1010))) (map (lambda (x1036) (cons (quote macro) (eval-local-transformer291 (chi284 x1036 trans-r1035 w1011 mod1013) mod1013))) val1024)) r1010) w1011 mod1013)))) tmp1015) ((lambda (_1038) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap277 e1009 w1011 s1012 mod1013))) tmp1014))) ($sc-dispatch tmp1014 (quote (any #(each (any any)) any . each-any))))) e1009))) (global-extend246 (quote core) (quote quote) (lambda (e1039 r1040 w1041 s1042 mod1043) ((lambda (tmp1044) ((lambda (tmp1045) (if tmp1045 (apply (lambda (_1046 e1047) (build-data226 s1042 (strip294 e1047 w1041))) tmp1045) ((lambda (_1048) (syntax-violation (quote quote) "bad syntax" (source-wrap277 e1039 w1041 s1042 mod1043))) tmp1044))) ($sc-dispatch tmp1044 (quote (any any))))) e1039))) (global-extend246 (quote core) (quote syntax) (letrec ((regen1056 (lambda (x1057) (let ((atom-key1058 (car x1057))) (if (memv atom-key1058 (quote (ref))) (build-lexical-reference217 (quote value) #f (cadr x1057) (cadr x1057)) (if (memv atom-key1058 (quote (primitive))) (build-primref225 #f (cadr x1057)) (if (memv atom-key1058 (quote (quote))) (build-data226 #f (cadr x1057)) (if (memv atom-key1058 (quote (lambda))) (build-lambda224 #f (cadr x1057) (cadr x1057) #f (regen1056 (caddr x1057))) (build-application215 #f (build-primref225 #f (car x1057)) (map regen1056 (cdr x1057)))))))))) (gen-vector1055 (lambda (x1059) (if (eq? (car x1059) (quote list)) (cons (quote vector) (cdr x1059)) (if (eq? (car x1059) (quote quote)) (list (quote quote) (list->vector (cadr x1059))) (list (quote list->vector) x1059))))) (gen-append1054 (lambda (x1060 y1061) (if (equal? y1061 (quote (quote ()))) x1060 (list (quote append) x1060 y1061)))) (gen-cons1053 (lambda (x1062 y1063) (let ((atom-key1064 (car y1063))) (if (memv atom-key1064 (quote (quote))) (if (eq? (car x1062) (quote quote)) (list (quote quote) (cons (cadr x1062) (cadr y1063))) (if (eq? (cadr y1063) (quote ())) (list (quote list) x1062) (list (quote cons) x1062 y1063))) (if (memv atom-key1064 (quote (list))) (cons (quote list) (cons x1062 (cdr y1063))) (list (quote cons) x1062 y1063)))))) (gen-map1052 (lambda (e1065 map-env1066) (let ((formals1067 (map cdr map-env1066)) (actuals1068 (map (lambda (x1069) (list (quote ref) (car x1069))) map-env1066))) (if (eq? (car e1065) (quote ref)) (car actuals1068) (if (and-map (lambda (x1070) (if (eq? (car x1070) (quote ref)) (memq (cadr x1070) formals1067) #f)) (cdr e1065)) (cons (quote map) (cons (list (quote primitive) (car e1065)) (map (let ((r1071 (map cons formals1067 actuals1068))) (lambda (x1072) (cdr (assq (cadr x1072) r1071)))) (cdr e1065)))) (cons (quote map) (cons (list (quote lambda) formals1067 e1065) actuals1068))))))) (gen-mappend1051 (lambda (e1073 map-env1074) (list (quote apply) (quote (primitive append)) (gen-map1052 e1073 map-env1074)))) (gen-ref1050 (lambda (src1075 var1076 level1077 maps1078) (if (fx=208 level1077 0) (values var1076 maps1078) (if (null? maps1078) (syntax-violation (quote syntax) "missing ellipsis" src1075) (call-with-values (lambda () (gen-ref1050 src1075 var1076 (fx-207 level1077 1) (cdr maps1078))) (lambda (outer-var1079 outer-maps1080) (let ((b1081 (assq outer-var1079 (car maps1078)))) (if b1081 (values (cdr b1081) maps1078) (let ((inner-var1082 (gen-var295 (quote tmp)))) (values inner-var1082 (cons (cons (cons outer-var1079 inner-var1082) (car maps1078)) outer-maps1080))))))))))) (gen-syntax1049 (lambda (src1083 e1084 r1085 maps1086 ellipsis?1087 mod1088) (if (id?248 e1084) (let ((label1089 (id-var-name270 e1084 (quote (()))))) (let ((b1090 (lookup245 label1089 r1085 mod1088))) (if (eq? (binding-type240 b1090) (quote syntax)) (call-with-values (lambda () (let ((var.lev1091 (binding-value241 b1090))) (gen-ref1050 src1083 (car var.lev1091) (cdr var.lev1091) maps1086))) (lambda (var1092 maps1093) (values (list (quote ref) var1092) maps1093))) (if (ellipsis?1087 e1084) (syntax-violation (quote syntax) "misplaced ellipsis" src1083) (values (list (quote quote) e1084) maps1086))))) ((lambda (tmp1094) ((lambda (tmp1095) (if (if tmp1095 (apply (lambda (dots1096 e1097) (ellipsis?1087 dots1096)) tmp1095) #f) (apply (lambda (dots1098 e1099) (gen-syntax1049 src1083 e1099 r1085 maps1086 (lambda (x1100) #f) mod1088)) tmp1095) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (x1102 dots1103 y1104) (ellipsis?1087 dots1103)) tmp1101) #f) (apply (lambda (x1105 dots1106 y1107) (letrec ((f1108 (lambda (y1109 k1110) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (dots1116 y1117) (ellipsis?1087 dots1116)) tmp1115) #f) (apply (lambda (dots1118 y1119) (f1108 y1119 (lambda (maps1120) (call-with-values (lambda () (k1110 (cons (quote ()) maps1120))) (lambda (x1121 maps1122) (if (null? (car maps1122)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-mappend1051 x1121 (car maps1122)) (cdr maps1122)))))))) tmp1115) ((lambda (_1123) (call-with-values (lambda () (gen-syntax1049 src1083 y1109 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (y1124 maps1125) (call-with-values (lambda () (k1110 maps1125)) (lambda (x1126 maps1127) (values (gen-append1054 x1126 y1124) maps1127)))))) tmp1114))) ($sc-dispatch tmp1114 (quote (any . any))))) y1109)))) (f1108 y1107 (lambda (maps1111) (call-with-values (lambda () (gen-syntax1049 src1083 x1105 r1085 (cons (quote ()) maps1111) ellipsis?1087 mod1088)) (lambda (x1112 maps1113) (if (null? (car maps1113)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-map1052 x1112 (car maps1113)) (cdr maps1113))))))))) tmp1101) ((lambda (tmp1128) (if tmp1128 (apply (lambda (x1129 y1130) (call-with-values (lambda () (gen-syntax1049 src1083 x1129 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (x1131 maps1132) (call-with-values (lambda () (gen-syntax1049 src1083 y1130 r1085 maps1132 ellipsis?1087 mod1088)) (lambda (y1133 maps1134) (values (gen-cons1053 x1131 y1133) maps1134)))))) tmp1128) ((lambda (tmp1135) (if tmp1135 (apply (lambda (e11136 e21137) (call-with-values (lambda () (gen-syntax1049 src1083 (cons e11136 e21137) r1085 maps1086 ellipsis?1087 mod1088)) (lambda (e1139 maps1140) (values (gen-vector1055 e1139) maps1140)))) tmp1135) ((lambda (_1141) (values (list (quote quote) e1084) maps1086)) tmp1094))) ($sc-dispatch tmp1094 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1094 (quote (any . any)))))) ($sc-dispatch tmp1094 (quote (any any . any)))))) ($sc-dispatch tmp1094 (quote (any any))))) e1084))))) (lambda (e1142 r1143 w1144 s1145 mod1146) (let ((e1147 (source-wrap277 e1142 w1144 s1145 mod1146))) ((lambda (tmp1148) ((lambda (tmp1149) (if tmp1149 (apply (lambda (_1150 x1151) (call-with-values (lambda () (gen-syntax1049 e1147 x1151 r1143 (quote ()) ellipsis?293 mod1146)) (lambda (e1152 maps1153) (regen1056 e1152)))) tmp1149) ((lambda (_1154) (syntax-violation (quote syntax) "bad `syntax' form" e1147)) tmp1148))) ($sc-dispatch tmp1148 (quote (any any))))) e1147))))) (global-extend246 (quote core) (quote lambda) (lambda (e1155 r1156 w1157 s1158 mod1159) ((lambda (tmp1160) ((lambda (tmp1161) (if tmp1161 (apply (lambda (_1162 c1163) (chi-lambda-clause289 (source-wrap277 e1155 w1157 s1158 mod1159) #f c1163 r1156 w1157 mod1159 (lambda (names1164 vars1165 docstring1166 body1167) (build-lambda224 s1158 names1164 vars1165 docstring1166 body1167)))) tmp1161) (syntax-violation #f "source expression failed to match any pattern" tmp1160))) ($sc-dispatch tmp1160 (quote (any . any))))) e1155))) (global-extend246 (quote core) (quote let) (letrec ((chi-let1168 (lambda (e1169 r1170 w1171 s1172 mod1173 constructor1174 ids1175 vals1176 exps1177) (if (not (valid-bound-ids?273 ids1175)) (syntax-violation (quote let) "duplicate bound variable" e1169) (let ((labels1178 (gen-labels254 ids1175)) (new-vars1179 (map gen-var295 ids1175))) (let ((nw1180 (make-binding-wrap265 ids1175 labels1178 w1171)) (nr1181 (extend-var-env243 labels1178 new-vars1179 r1170))) (constructor1174 s1172 (map syntax->datum ids1175) new-vars1179 (map (lambda (x1182) (chi284 x1182 r1170 w1171 mod1173)) vals1176) (chi-body288 exps1177 (source-wrap277 e1169 nw1180 s1172 mod1173) nr1181 nw1180 mod1173)))))))) (lambda (e1183 r1184 w1185 s1186 mod1187) ((lambda (tmp1188) ((lambda (tmp1189) (if (if tmp1189 (apply (lambda (_1190 id1191 val1192 e11193 e21194) (and-map id?248 id1191)) tmp1189) #f) (apply (lambda (_1196 id1197 val1198 e11199 e21200) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-let228 id1197 val1198 (cons e11199 e21200))) tmp1189) ((lambda (tmp1204) (if (if tmp1204 (apply (lambda (_1205 f1206 id1207 val1208 e11209 e21210) (if (id?248 f1206) (and-map id?248 id1207) #f)) tmp1204) #f) (apply (lambda (_1212 f1213 id1214 val1215 e11216 e21217) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-named-let229 (cons f1213 id1214) val1215 (cons e11216 e21217))) tmp1204) ((lambda (_1221) (syntax-violation (quote let) "bad let" (source-wrap277 e1183 w1185 s1186 mod1187))) tmp1188))) ($sc-dispatch tmp1188 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1188 (quote (any #(each (any any)) any . each-any))))) e1183)))) (global-extend246 (quote core) (quote letrec) (lambda (e1222 r1223 w1224 s1225 mod1226) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (_1229 id1230 val1231 e11232 e21233) (and-map id?248 id1230)) tmp1228) #f) (apply (lambda (_1235 id1236 val1237 e11238 e21239) (let ((ids1240 id1236)) (if (not (valid-bound-ids?273 ids1240)) (syntax-violation (quote letrec) "duplicate bound variable" e1222) (let ((labels1242 (gen-labels254 ids1240)) (new-vars1243 (map gen-var295 ids1240))) (let ((w1244 (make-binding-wrap265 ids1240 labels1242 w1224)) (r1245 (extend-var-env243 labels1242 new-vars1243 r1223))) (build-letrec230 s1225 (map syntax->datum ids1240) new-vars1243 (map (lambda (x1246) (chi284 x1246 r1245 w1244 mod1226)) val1237) (chi-body288 (cons e11238 e21239) (source-wrap277 e1222 w1244 s1225 mod1226) r1245 w1244 mod1226))))))) tmp1228) ((lambda (_1249) (syntax-violation (quote letrec) "bad letrec" (source-wrap277 e1222 w1224 s1225 mod1226))) tmp1227))) ($sc-dispatch tmp1227 (quote (any #(each (any any)) any . each-any))))) e1222))) (global-extend246 (quote core) (quote set!) (lambda (e1250 r1251 w1252 s1253 mod1254) ((lambda (tmp1255) ((lambda (tmp1256) (if (if tmp1256 (apply (lambda (_1257 id1258 val1259) (id?248 id1258)) tmp1256) #f) (apply (lambda (_1260 id1261 val1262) (let ((val1263 (chi284 val1262 r1251 w1252 mod1254)) (n1264 (id-var-name270 id1261 w1252))) (let ((b1265 (lookup245 n1264 r1251 mod1254))) (let ((atom-key1266 (binding-type240 b1265))) (if (memv atom-key1266 (quote (lexical))) (build-lexical-assignment218 s1253 (syntax->datum id1261) (binding-value241 b1265) val1263) (if (memv atom-key1266 (quote (global))) (build-global-assignment221 s1253 n1264 val1263 mod1254) (if (memv atom-key1266 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap276 id1261 w1252 mod1254)) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))))))))) tmp1256) ((lambda (tmp1267) (if tmp1267 (apply (lambda (_1268 head1269 tail1270 val1271) (call-with-values (lambda () (syntax-type282 head1269 r1251 (quote (())) #f #f mod1254)) (lambda (type1272 value1273 ee1274 ww1275 ss1276 modmod1277) (if (memv type1272 (quote (module-ref))) (let ((val1278 (chi284 val1271 r1251 w1252 mod1254))) (call-with-values (lambda () (value1273 (cons head1269 tail1270))) (lambda (id1280 mod1281) (build-global-assignment221 s1253 id1280 val1278 mod1281)))) (build-application215 s1253 (chi284 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1269) r1251 w1252 mod1254) (map (lambda (e1282) (chi284 e1282 r1251 w1252 mod1254)) (append tail1270 (list val1271)))))))) tmp1267) ((lambda (_1284) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))) tmp1255))) ($sc-dispatch tmp1255 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1255 (quote (any any any))))) e1250))) (global-extend246 (quote module-ref) (quote @) (lambda (e1285) ((lambda (tmp1286) ((lambda (tmp1287) (if (if tmp1287 (apply (lambda (_1288 mod1289 id1290) (if (and-map id?248 mod1289) (id?248 id1290) #f)) tmp1287) #f) (apply (lambda (_1292 mod1293 id1294) (values (syntax->datum id1294) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1293)))) tmp1287) (syntax-violation #f "source expression failed to match any pattern" tmp1286))) ($sc-dispatch tmp1286 (quote (any each-any any))))) e1285))) (global-extend246 (quote module-ref) (quote @@) (lambda (e1296) ((lambda (tmp1297) ((lambda (tmp1298) (if (if tmp1298 (apply (lambda (_1299 mod1300 id1301) (if (and-map id?248 mod1300) (id?248 id1301) #f)) tmp1298) #f) (apply (lambda (_1303 mod1304 id1305) (values (syntax->datum id1305) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1304)))) tmp1298) (syntax-violation #f "source expression failed to match any pattern" tmp1297))) ($sc-dispatch tmp1297 (quote (any each-any any))))) e1296))) (global-extend246 (quote core) (quote if) (lambda (e1307 r1308 w1309 s1310 mod1311) ((lambda (tmp1312) ((lambda (tmp1313) (if tmp1313 (apply (lambda (_1314 test1315 then1316) (build-conditional216 s1310 (chi284 test1315 r1308 w1309 mod1311) (chi284 then1316 r1308 w1309 mod1311) (build-void214 #f))) tmp1313) ((lambda (tmp1317) (if tmp1317 (apply (lambda (_1318 test1319 then1320 else1321) (build-conditional216 s1310 (chi284 test1319 r1308 w1309 mod1311) (chi284 then1320 r1308 w1309 mod1311) (chi284 else1321 r1308 w1309 mod1311))) tmp1317) (syntax-violation #f "source expression failed to match any pattern" tmp1312))) ($sc-dispatch tmp1312 (quote (any any any any)))))) ($sc-dispatch tmp1312 (quote (any any any))))) e1307))) (global-extend246 (quote begin) (quote begin) (quote ())) (global-extend246 (quote define) (quote define) (quote ())) (global-extend246 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend246 (quote eval-when) (quote eval-when) (quote ())) (global-extend246 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1325 (lambda (x1326 keys1327 clauses1328 r1329 mod1330) (if (null? clauses1328) (build-application215 #f (build-primref225 #f (quote syntax-violation)) (list (build-data226 #f #f) (build-data226 #f "source expression failed to match any pattern") x1326)) ((lambda (tmp1331) ((lambda (tmp1332) (if tmp1332 (apply (lambda (pat1333 exp1334) (if (if (id?248 pat1333) (and-map (lambda (x1335) (not (free-id=?271 pat1333 x1335))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1327)) #f) (let ((labels1336 (list (gen-label253))) (var1337 (gen-var295 pat1333))) (build-application215 #f (build-lambda224 #f (list (syntax->datum pat1333)) (list var1337) #f (chi284 exp1334 (extend-env242 labels1336 (list (cons (quote syntax) (cons var1337 0))) r1329) (make-binding-wrap265 (list pat1333) labels1336 (quote (()))) mod1330)) (list x1326))) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1333 #t exp1334 mod1330))) tmp1332) ((lambda (tmp1338) (if tmp1338 (apply (lambda (pat1339 fender1340 exp1341) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1339 fender1340 exp1341 mod1330)) tmp1338) ((lambda (_1342) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1328))) tmp1331))) ($sc-dispatch tmp1331 (quote (any any any)))))) ($sc-dispatch tmp1331 (quote (any any))))) (car clauses1328))))) (gen-clause1324 (lambda (x1343 keys1344 clauses1345 r1346 pat1347 fender1348 exp1349 mod1350) (call-with-values (lambda () (convert-pattern1322 pat1347 keys1344)) (lambda (p1351 pvars1352) (if (not (distinct-bound-ids?274 (map car pvars1352))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1347) (if (not (and-map (lambda (x1353) (not (ellipsis?293 (car x1353)))) pvars1352)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1347) (let ((y1354 (gen-var295 (quote tmp)))) (build-application215 #f (build-lambda224 #f (list (quote tmp)) (list y1354) #f (let ((y1355 (build-lexical-reference217 (quote value) #f (quote tmp) y1354))) (build-conditional216 #f ((lambda (tmp1356) ((lambda (tmp1357) (if tmp1357 (apply (lambda () y1355) tmp1357) ((lambda (_1358) (build-conditional216 #f y1355 (build-dispatch-call1323 pvars1352 fender1348 y1355 r1346 mod1350) (build-data226 #f #f))) tmp1356))) ($sc-dispatch tmp1356 (quote #(atom #t))))) fender1348) (build-dispatch-call1323 pvars1352 exp1349 y1355 r1346 mod1350) (gen-syntax-case1325 x1343 keys1344 clauses1345 r1346 mod1350)))) (list (if (eq? p1351 (quote any)) (build-application215 #f (build-primref225 #f (quote list)) (list x1343)) (build-application215 #f (build-primref225 #f (quote $sc-dispatch)) (list x1343 (build-data226 #f p1351))))))))))))) (build-dispatch-call1323 (lambda (pvars1359 exp1360 y1361 r1362 mod1363) (let ((ids1364 (map car pvars1359)) (levels1365 (map cdr pvars1359))) (let ((labels1366 (gen-labels254 ids1364)) (new-vars1367 (map gen-var295 ids1364))) (build-application215 #f (build-primref225 #f (quote apply)) (list (build-lambda224 #f (map syntax->datum ids1364) new-vars1367 #f (chi284 exp1360 (extend-env242 labels1366 (map (lambda (var1368 level1369) (cons (quote syntax) (cons var1368 level1369))) new-vars1367 (map cdr pvars1359)) r1362) (make-binding-wrap265 ids1364 labels1366 (quote (()))) mod1363)) y1361)))))) (convert-pattern1322 (lambda (pattern1370 keys1371) (letrec ((cvt1372 (lambda (p1373 n1374 ids1375) (if (id?248 p1373) (if (bound-id-member?275 p1373 keys1371) (values (vector (quote free-id) p1373) ids1375) (values (quote any) (cons (cons p1373 n1374) ids1375))) ((lambda (tmp1376) ((lambda (tmp1377) (if (if tmp1377 (apply (lambda (x1378 dots1379) (ellipsis?293 dots1379)) tmp1377) #f) (apply (lambda (x1380 dots1381) (call-with-values (lambda () (cvt1372 x1380 (fx+206 n1374 1) ids1375)) (lambda (p1382 ids1383) (values (if (eq? p1382 (quote any)) (quote each-any) (vector (quote each) p1382)) ids1383)))) tmp1377) ((lambda (tmp1384) (if tmp1384 (apply (lambda (x1385 y1386) (call-with-values (lambda () (cvt1372 y1386 n1374 ids1375)) (lambda (y1387 ids1388) (call-with-values (lambda () (cvt1372 x1385 n1374 ids1388)) (lambda (x1389 ids1390) (values (cons x1389 y1387) ids1390)))))) tmp1384) ((lambda (tmp1391) (if tmp1391 (apply (lambda () (values (quote ()) ids1375)) tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (x1393) (call-with-values (lambda () (cvt1372 x1393 n1374 ids1375)) (lambda (p1395 ids1396) (values (vector (quote vector) p1395) ids1396)))) tmp1392) ((lambda (x1397) (values (vector (quote atom) (strip294 p1373 (quote (())))) ids1375)) tmp1376))) ($sc-dispatch tmp1376 (quote #(vector each-any)))))) ($sc-dispatch tmp1376 (quote ()))))) ($sc-dispatch tmp1376 (quote (any . any)))))) ($sc-dispatch tmp1376 (quote (any any))))) p1373))))) (cvt1372 pattern1370 0 (quote ())))))) (lambda (e1398 r1399 w1400 s1401 mod1402) (let ((e1403 (source-wrap277 e1398 w1400 s1401 mod1402))) ((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (_1406 val1407 key1408 m1409) (if (and-map (lambda (x1410) (if (id?248 x1410) (not (ellipsis?293 x1410)) #f)) key1408) (let ((x1412 (gen-var295 (quote tmp)))) (build-application215 s1401 (build-lambda224 #f (list (quote tmp)) (list x1412) #f (gen-syntax-case1325 (build-lexical-reference217 (quote value) #f (quote tmp) x1412) key1408 m1409 r1399 mod1402)) (list (chi284 val1407 r1399 (quote (())) mod1402)))) (syntax-violation (quote syntax-case) "invalid literals list" e1403))) tmp1405) (syntax-violation #f "source expression failed to match any pattern" tmp1404))) ($sc-dispatch tmp1404 (quote (any any each-any . each-any))))) e1403))))) (set! sc-expand (lambda (x1416 . rest1415) (if (if (pair? x1416) (equal? (car x1416) noexpand204) #f) (cadr x1416) (let ((m1417 (if (null? rest1415) (quote e) (car rest1415))) (esew1418 (if (let ((t1419 (null? rest1415))) (if t1419 t1419 (null? (cdr rest1415)))) (quote (eval)) (cadr rest1415)))) (with-fluid* *mode*205 m1417 (lambda () (chi-top283 x1416 (quote ()) (quote ((top))) m1417 esew1418 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1420) (nonsymbol-id?247 x1420))) (set! datum->syntax (lambda (id1421 datum1422) (make-syntax-object231 datum1422 (syntax-object-wrap234 id1421) #f))) (set! syntax->datum (lambda (x1423) (strip294 x1423 (quote (()))))) (set! generate-temporaries (lambda (ls1424) (begin (let ((x1425 ls1424)) (if (not (list? x1425)) (syntax-violation (quote generate-temporaries) "invalid argument" x1425))) (map (lambda (x1426) (wrap276 (gensym) (quote ((top))) #f)) ls1424)))) (set! free-identifier=? (lambda (x1427 y1428) (begin (let ((x1429 x1427)) (if (not (nonsymbol-id?247 x1429)) (syntax-violation (quote free-identifier=?) "invalid argument" x1429))) (let ((x1430 y1428)) (if (not (nonsymbol-id?247 x1430)) (syntax-violation (quote free-identifier=?) "invalid argument" x1430))) (free-id=?271 x1427 y1428)))) (set! bound-identifier=? (lambda (x1431 y1432) (begin (let ((x1433 x1431)) (if (not (nonsymbol-id?247 x1433)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1433))) (let ((x1434 y1432)) (if (not (nonsymbol-id?247 x1434)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1434))) (bound-id=?272 x1431 y1432)))) (set! syntax-violation (lambda (who1438 message1437 form1436 . subform1435) (begin (let ((x1439 who1438)) (if (not ((lambda (x1440) (let ((t1441 (not x1440))) (if t1441 t1441 (let ((t1442 (string? x1440))) (if t1442 t1442 (symbol? x1440)))))) x1439)) (syntax-violation (quote syntax-violation) "invalid argument" x1439))) (let ((x1443 message1437)) (if (not (string? x1443)) (syntax-violation (quote syntax-violation) "invalid argument" x1443))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1438 "~a: " "") "~a " (if (null? subform1435) "in ~a" "in subform `~s' of `~s'")) (let ((tail1444 (cons message1437 (map (lambda (x1445) (strip294 x1445 (quote (())))) (append subform1435 (list form1436)))))) (if who1438 (cons who1438 tail1444) tail1444)) #f)))) (letrec ((match1450 (lambda (e1451 p1452 w1453 r1454 mod1455) (if (not r1454) #f (if (eq? p1452 (quote any)) (cons (wrap276 e1451 w1453 mod1455) r1454) (if (syntax-object?232 e1451) (match*1449 (syntax-object-expression233 e1451) p1452 (join-wraps267 w1453 (syntax-object-wrap234 e1451)) r1454 (syntax-object-module235 e1451)) (match*1449 e1451 p1452 w1453 r1454 mod1455)))))) (match*1449 (lambda (e1456 p1457 w1458 r1459 mod1460) (if (null? p1457) (if (null? e1456) r1459 #f) (if (pair? p1457) (if (pair? e1456) (match1450 (car e1456) (car p1457) w1458 (match1450 (cdr e1456) (cdr p1457) w1458 r1459 mod1460) mod1460) #f) (if (eq? p1457 (quote each-any)) (let ((l1461 (match-each-any1447 e1456 w1458 mod1460))) (if l1461 (cons l1461 r1459) #f)) (let ((atom-key1462 (vector-ref p1457 0))) (if (memv atom-key1462 (quote (each))) (if (null? e1456) (match-empty1448 (vector-ref p1457 1) r1459) (let ((l1463 (match-each1446 e1456 (vector-ref p1457 1) w1458 mod1460))) (if l1463 (letrec ((collect1464 (lambda (l1465) (if (null? (car l1465)) r1459 (cons (map car l1465) (collect1464 (map cdr l1465))))))) (collect1464 l1463)) #f))) (if (memv atom-key1462 (quote (free-id))) (if (id?248 e1456) (if (free-id=?271 (wrap276 e1456 w1458 mod1460) (vector-ref p1457 1)) r1459 #f) #f) (if (memv atom-key1462 (quote (atom))) (if (equal? (vector-ref p1457 1) (strip294 e1456 w1458)) r1459 #f) (if (memv atom-key1462 (quote (vector))) (if (vector? e1456) (match1450 (vector->list e1456) (vector-ref p1457 1) w1458 r1459 mod1460) #f))))))))))) (match-empty1448 (lambda (p1466 r1467) (if (null? p1466) r1467 (if (eq? p1466 (quote any)) (cons (quote ()) r1467) (if (pair? p1466) (match-empty1448 (car p1466) (match-empty1448 (cdr p1466) r1467)) (if (eq? p1466 (quote each-any)) (cons (quote ()) r1467) (let ((atom-key1468 (vector-ref p1466 0))) (if (memv atom-key1468 (quote (each))) (match-empty1448 (vector-ref p1466 1) r1467) (if (memv atom-key1468 (quote (free-id atom))) r1467 (if (memv atom-key1468 (quote (vector))) (match-empty1448 (vector-ref p1466 1) r1467))))))))))) (match-each-any1447 (lambda (e1469 w1470 mod1471) (if (pair? e1469) (let ((l1472 (match-each-any1447 (cdr e1469) w1470 mod1471))) (if l1472 (cons (wrap276 (car e1469) w1470 mod1471) l1472) #f)) (if (null? e1469) (quote ()) (if (syntax-object?232 e1469) (match-each-any1447 (syntax-object-expression233 e1469) (join-wraps267 w1470 (syntax-object-wrap234 e1469)) mod1471) #f))))) (match-each1446 (lambda (e1473 p1474 w1475 mod1476) (if (pair? e1473) (let ((first1477 (match1450 (car e1473) p1474 w1475 (quote ()) mod1476))) (if first1477 (let ((rest1478 (match-each1446 (cdr e1473) p1474 w1475 mod1476))) (if rest1478 (cons first1477 rest1478) #f)) #f)) (if (null? e1473) (quote ()) (if (syntax-object?232 e1473) (match-each1446 (syntax-object-expression233 e1473) p1474 (join-wraps267 w1475 (syntax-object-wrap234 e1473)) (syntax-object-module235 e1473)) #f)))))) (set! $sc-dispatch (lambda (e1479 p1480) (if (eq? p1480 (quote any)) (list e1479) (if (syntax-object?232 e1479) (match*1449 (syntax-object-expression233 e1479) p1480 (syntax-object-wrap234 e1479) (quote ()) (syntax-object-module235 e1479)) (match*1449 e1479 p1480 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1481) ((lambda (tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (_1484 e11485 e21486) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11485 e21486))) tmp1483) ((lambda (tmp1488) (if tmp1488 (apply (lambda (_1489 out1490 in1491 e11492 e21493) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1491 (quote ()) (list out1490 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11492 e21493))))) tmp1488) ((lambda (tmp1495) (if tmp1495 (apply (lambda (_1496 out1497 in1498 e11499 e21500) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1498) (quote ()) (list out1497 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11499 e21500))))) tmp1495) (syntax-violation #f "source expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any () any . each-any))))) x1481)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 k1508 keyword1509 pattern1510 template1511) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1508 (map (lambda (tmp1514 tmp1513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1514))) template1511 pattern1510)))))) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any each-any . #(each ((any . any) any))))))) x1504)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if (if tmp1517 (apply (lambda (let*1518 x1519 v1520 e11521 e21522) (and-map identifier? x1519)) tmp1517) #f) (apply (lambda (let*1524 x1525 v1526 e11527 e21528) (letrec ((f1529 (lambda (bindings1530) (if (null? bindings1530) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11527 e21528))) ((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (body1536 binding1537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1537) body1536)) tmp1535) (syntax-violation #f "source expression failed to match any pattern" tmp1534))) ($sc-dispatch tmp1534 (quote (any any))))) (list (f1529 (cdr bindings1530)) (car bindings1530))))))) (f1529 (map list x1525 v1526)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any #(each (any any)) any . each-any))))) x1515)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1538) ((lambda (tmp1539) ((lambda (tmp1540) (if tmp1540 (apply (lambda (_1541 var1542 init1543 step1544 e01545 e11546 c1547) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (step1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1552) ((lambda (tmp1557) (if tmp1557 (apply (lambda (e11558 e21559) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11558 e21559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1557) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any . each-any)))))) ($sc-dispatch tmp1551 (quote ())))) e11546)) tmp1549) (syntax-violation #f "source expression failed to match any pattern" tmp1548))) ($sc-dispatch tmp1548 (quote each-any)))) (map (lambda (v1566 s1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply (lambda () v1566) tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (e1571) e1571) tmp1570) ((lambda (_1572) (syntax-violation (quote do) "bad step expression" orig-x1538 s1567)) tmp1568))) ($sc-dispatch tmp1568 (quote (any)))))) ($sc-dispatch tmp1568 (quote ())))) s1567)) var1542 step1544))) tmp1540) (syntax-violation #f "source expression failed to match any pattern" tmp1539))) ($sc-dispatch tmp1539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1538)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1575 (lambda (x1579 y1580) ((lambda (tmp1581) ((lambda (tmp1582) (if tmp1582 (apply (lambda (x1583 y1584) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (dy1587) ((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (dx1590) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1590 dy1587))) tmp1589) ((lambda (_1591) (if (null? dy1587) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584))) tmp1588))) ($sc-dispatch tmp1588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1583)) tmp1586) ((lambda (tmp1592) (if tmp1592 (apply (lambda (stuff1593) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1583 stuff1593))) tmp1592) ((lambda (else1594) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584)) tmp1585))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1584)) tmp1582) (syntax-violation #f "source expression failed to match any pattern" tmp1581))) ($sc-dispatch tmp1581 (quote (any any))))) (list x1579 y1580)))) (quasiappend1576 (lambda (x1595 y1596) ((lambda (tmp1597) ((lambda (tmp1598) (if tmp1598 (apply (lambda (x1599 y1600) ((lambda (tmp1601) ((lambda (tmp1602) (if tmp1602 (apply (lambda () x1599) tmp1602) ((lambda (_1603) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1599 y1600)) tmp1601))) ($sc-dispatch tmp1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1600)) tmp1598) (syntax-violation #f "source expression failed to match any pattern" tmp1597))) ($sc-dispatch tmp1597 (quote (any any))))) (list x1595 y1596)))) (quasivector1577 (lambda (x1604) ((lambda (tmp1605) ((lambda (x1606) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (x1609) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1609))) tmp1608) ((lambda (tmp1611) (if tmp1611 (apply (lambda (x1612) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1612)) tmp1611) ((lambda (_1614) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1606)) tmp1607))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1606)) tmp1605)) x1604))) (quasi1578 (lambda (p1615 lev1616) ((lambda (tmp1617) ((lambda (tmp1618) (if tmp1618 (apply (lambda (p1619) (if (= lev1616 0) p1619 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1619) (- lev1616 1))))) tmp1618) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (args1621) (= lev1616 0)) tmp1620) #f) (apply (lambda (args1622) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1615 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1622))) tmp1620) ((lambda (tmp1623) (if tmp1623 (apply (lambda (p1624 q1625) (if (= lev1616 0) (quasiappend1576 p1624 (quasi1578 q1625 lev1616)) (quasicons1575 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1624) (- lev1616 1))) (quasi1578 q1625 lev1616)))) tmp1623) ((lambda (tmp1626) (if (if tmp1626 (apply (lambda (args1627 q1628) (= lev1616 0)) tmp1626) #f) (apply (lambda (args1629 q1630) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1615 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1629))) tmp1626) ((lambda (tmp1631) (if tmp1631 (apply (lambda (p1632) (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1632) (+ lev1616 1)))) tmp1631) ((lambda (tmp1633) (if tmp1633 (apply (lambda (p1634 q1635) (quasicons1575 (quasi1578 p1634 lev1616) (quasi1578 q1635 lev1616))) tmp1633) ((lambda (tmp1636) (if tmp1636 (apply (lambda (x1637) (quasivector1577 (quasi1578 x1637 lev1616))) tmp1636) ((lambda (p1639) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1639)) tmp1617))) ($sc-dispatch tmp1617 (quote #(vector each-any)))))) ($sc-dispatch tmp1617 (quote (any . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1615)))) (lambda (x1640) ((lambda (tmp1641) ((lambda (tmp1642) (if tmp1642 (apply (lambda (_1643 e1644) (quasi1578 e1644 0)) tmp1642) (syntax-violation #f "source expression failed to match any pattern" tmp1641))) ($sc-dispatch tmp1641 (quote (any any))))) x1640))))) +(define include (make-syncase-macro (quote macro) (lambda (x1645) (letrec ((read-file1646 (lambda (fn1647 k1648) (let ((p1649 (open-input-file fn1647))) (letrec ((f1650 (lambda (x1651) (if (eof-object? x1651) (begin (close-input-port p1649) (quote ())) (cons (datum->syntax k1648 x1651) (f1650 (read p1649))))))) (f1650 (read p1649))))))) ((lambda (tmp1652) ((lambda (tmp1653) (if tmp1653 (apply (lambda (k1654 filename1655) (let ((fn1656 (syntax->datum filename1655))) ((lambda (tmp1657) ((lambda (tmp1658) (if tmp1658 (apply (lambda (exp1659) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1659)) tmp1658) (syntax-violation #f "source expression failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote each-any)))) (read-file1646 fn1656 k1654)))) tmp1653) (syntax-violation #f "source expression failed to match any pattern" tmp1652))) ($sc-dispatch tmp1652 (quote (any any))))) x1645))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1661) ((lambda (tmp1662) ((lambda (tmp1663) (if tmp1663 (apply (lambda (_1664 e1665) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1661)) tmp1663) (syntax-violation #f "source expression failed to match any pattern" tmp1662))) ($sc-dispatch tmp1662 (quote (any any))))) x1661)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1666) ((lambda (tmp1667) ((lambda (tmp1668) (if tmp1668 (apply (lambda (_1669 e1670) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1666)) tmp1668) (syntax-violation #f "source expression failed to match any pattern" tmp1667))) ($sc-dispatch tmp1667 (quote (any any))))) x1666)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1671) ((lambda (tmp1672) ((lambda (tmp1673) (if tmp1673 (apply (lambda (_1674 e1675 m11676 m21677) ((lambda (tmp1678) ((lambda (body1679) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1675)) body1679)) tmp1678)) (letrec ((f1680 (lambda (clause1681 clauses1682) (if (null? clauses1682) ((lambda (tmp1684) ((lambda (tmp1685) (if tmp1685 (apply (lambda (e11686 e21687) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11686 e21687))) tmp1685) ((lambda (tmp1689) (if tmp1689 (apply (lambda (k1690 e11691 e21692) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1690)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11691 e21692)))) tmp1689) ((lambda (_1695) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1684))) ($sc-dispatch tmp1684 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1684 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1681) ((lambda (tmp1696) ((lambda (rest1697) ((lambda (tmp1698) ((lambda (tmp1699) (if tmp1699 (apply (lambda (k1700 e11701 e21702) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1700)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11701 e21702)) rest1697)) tmp1699) ((lambda (_1705) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1698))) ($sc-dispatch tmp1698 (quote (each-any any . each-any))))) clause1681)) tmp1696)) (f1680 (car clauses1682) (cdr clauses1682))))))) (f1680 m11676 m21677)))) tmp1673) (syntax-violation #f "source expression failed to match any pattern" tmp1672))) ($sc-dispatch tmp1672 (quote (any any any . each-any))))) x1671)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1706) ((lambda (tmp1707) ((lambda (tmp1708) (if tmp1708 (apply (lambda (_1709 e1710) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1710)) (list (cons _1709 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1710 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1708) (syntax-violation #f "source expression failed to match any pattern" tmp1707))) ($sc-dispatch tmp1707 (quote (any any))))) x1706)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 0398815d1..c2668c0c4 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -526,7 +526,10 @@ (cond ((syntax-object? x) (source-annotation (syntax-object-expression x))) - ((pair? x) (source-properties x)) + ((pair? x) (let ((props (source-properties x))) + (if (pair? props) + props + #f))) (else #f)))) (define-syntax arg-check @@ -922,15 +925,9 @@ (define source-wrap (lambda (x w s defmod) - (wrap (if s - (begin - (if (not (pair? x)) - (error "bad source-wrap!!!" x s)) - (set-source-properties! x s) - x) - x) - w - defmod))) + (if (and s (pair? x)) + (set-source-properties! x s)) + (wrap x w defmod))) ;;; expanding @@ -1098,11 +1095,10 @@ (values 'call #f e w s mod)))) (values 'call #f e w s mod)))) ((syntax-object? e) - ;; s can't be valid source if we've unwrapped (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) - no-source rib (or (syntax-object-module e) mod))) + s rib (or (syntax-object-module e) mod))) ((self-evaluating? e) (values 'constant #f e w s mod)) (else (values 'other #f e w s mod))))) @@ -1346,7 +1342,7 @@ (syntax-violation #f "no expressions in body" outer-form) (let ((e (cdar body)) (er (caar body))) (call-with-values - (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod)) + (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod)) (lambda (type value e w s mod) (case type ((define-form) @@ -1747,12 +1743,6 @@ ((primitive) (build-primref no-source (cadr x))) ((quote) (build-data no-source (cadr x))) ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x)))) - ((map) (let ((ls (map regen (cdr x)))) - (build-application no-source - ;; this check used to be here, not sure what for: - ;; (if (fx= (length ls) 2) - (build-primref no-source 'map) - ls))) (else (build-application no-source (build-primref no-source (car x)) (map regen (cdr x))))))) From a755136ba8469fdccbcac956b4f5d8c6f4ec2a4e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 May 2009 21:14:48 +0200 Subject: [PATCH 154/375] fix (oop goops) compilation for (language tree-il primitives) * module/oop/goops.scm (compile): Whoop-dee, fix up (oop goops) for (language tree-il primitives) change. --- module/oop/goops.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index fd2d60058..6e3b15009 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1128,7 +1128,7 @@ ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. (eval-when (compile) - (use-modules ((language tree-il optimize) :select (add-interesting-primitive!))) + (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) (add-interesting-primitive! '@slot-ref) (add-interesting-primitive! '@slot-set!)) From de784acd87b8d567fb6433d8f531a7f28b91d635 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 22 May 2009 23:44:43 +0200 Subject: [PATCH 155/375] Rewrite SRFI-35 macros using `syntax-rules'. * module/srfi/srfi-35.scm: Use `(ice-9 syncase)'. (define-condition-type, condition): Rewritten using `syntax-rules'. (compound-condition, condition-instantiation): New helper internal macros. Thanks to Andy Wingo for his help! --- module/srfi/srfi-35.scm | 65 +++++++++++++++++++++-------------------- 1 file changed, 34 insertions(+), 31 deletions(-) diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm index 203546625..d7e6a4da0 100644 --- a/module/srfi/srfi-35.scm +++ b/module/srfi/srfi-35.scm @@ -1,6 +1,6 @@ ;;; srfi-35.scm --- Conditions -;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -28,6 +28,7 @@ (define-module (srfi srfi-35) #:use-module (srfi srfi-1) + #:use-module (ice-9 syncase) #:export (make-condition-type condition-type? make-condition condition? condition-has-type? condition-ref make-compound-condition extract-condition @@ -274,37 +275,39 @@ by C." ;;; Syntax. ;;; -(define-macro (define-condition-type name parent pred . field-specs) - `(begin - (define ,name - (make-condition-type ',name ,parent - ',(map car field-specs))) - (define (,pred c) - (condition-has-type? c ,name)) - ,@(map (lambda (field-spec) - (let ((field-name (car field-spec)) - (accessor (cadr field-spec))) - `(define (,accessor c) - (condition-ref c ',field-name)))) - field-specs))) +(define-syntax define-condition-type + (syntax-rules () + ((_ name parent pred (field-name field-accessor) ...) + (begin + (define name + (make-condition-type 'name parent '(field-name ...))) + (define (pred c) + (condition-has-type? c name)) + (define (field-accessor c) + (condition-ref c 'field-name)) + ...)))) -(define-macro (condition . type-field-bindings) - (cond ((null? type-field-bindings) - (error "`condition' syntax error" type-field-bindings)) - (else - ;; the poor man's hygienic macro - (let ((mc (gensym "mc")) - (mcct (gensym "mcct"))) - `(let ((,mc (@ (srfi srfi-35) make-condition)) - (,mcct (@@ (srfi srfi-35) make-compound-condition-type))) - (,mc (,mcct 'compound (list ,@(map car type-field-bindings))) - ,@(append-map (lambda (type-field-binding) - (append-map (lambda (field+value) - (let ((f (car field+value)) - (v (cadr field+value))) - `(',f ,v))) - (cdr type-field-binding))) - type-field-bindings))))))) +(define-syntax compound-condition + ;; Create a compound condition using `make-compound-condition-type'. + (syntax-rules () + ((_ (type ...) (field ...)) + (condition ((make-compound-condition-type '%compound `(,type ...)) + field ...))))) + +(define-syntax condition-instantiation + ;; Build the `(make-condition type ...)' call. + (syntax-rules () + ((_ type (out ...)) + (make-condition type out ...)) + ((_ type (out ...) (field-name field-value) rest ...) + (condition-instantiation type (out ... 'field-name field-value) rest ...)))) + +(define-syntax condition + (syntax-rules () + ((_ (type field ...)) + (condition-instantiation type () field ...)) + ((_ (type field ...) ...) + (compound-condition (type ...) (field ... ...))))) ;;; From 81fd3152992c8ef62e1ec036f5a39443c8f8d0aa Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 24 May 2009 13:09:01 +0200 Subject: [PATCH 156/375] update docs, clean up VM vestiges, macro docs, fix (/ a b c) * doc/ref/api-procedures.texi (Compiled Procedures): Fix for API changes. * doc/ref/compiler.texi (Compiling to the Virtual Machine): Replace GHIL docs with Tree-IL docs. Update the bits about the Scheme compiler to talk about Tree-IL and the expander instead of GHIL. Remove . Add placeholder sections for assembly and bytecode. * doc/ref/vm.texi: Update examples with what currently happens. Reword some things. Fix a couple errors. * libguile/vm-i-system.c (externals): Remove this instruction, it's not used. * module/ice-9/documentation.scm (object-documentation): If the object is a macro, try to return documentation on the macro transformer. * module/language/assembly/disassemble.scm (disassemble-load-program): Fix problem in which we skipped the first element of the object vector, because of changes to procedure layouts a few months ago. * module/language/scheme/spec.scm (read-file): Remove read-file definition. * module/language/tree-il.scm: Reorder exports. Remove , it was a compat shim to something that was never released. Fix `location'. * module/language/tree-il/primitives.scm (/): Fix expander for more than two args to /. * module/system/base/compile.scm (read-file-in): Remove unused definition. * module/system/base/language.scm (system): Remove language-read-file. * module/language/ecmascript/spec.scm (ecmascript): Remove read-file definition. --- doc/ref/api-procedures.texi | 28 +- doc/ref/compiler.texi | 521 ++++++++++------------- doc/ref/vm.texi | 164 +++---- libguile/vm-i-system.c | 6 - module/ice-9/documentation.scm | 2 + module/language/assembly/disassemble.scm | 2 +- module/language/ecmascript/spec.scm | 1 - module/language/scheme/spec.scm | 7 - module/language/tree-il.scm | 31 +- module/language/tree-il/primitives.scm | 2 +- module/system/base/compile.scm | 5 - module/system/base/language.scm | 3 +- 12 files changed, 317 insertions(+), 455 deletions(-) diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index e3cf25823..484f2e86f 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -162,18 +162,10 @@ appropriate module first, though: Returns @code{#t} iff @var{obj} is a compiled procedure. @end deffn -@deffn {Scheme Procedure} program-bytecode program -@deffnx {C Function} scm_program_bytecode (program) -Returns the object code associated with this program, as a -@code{u8vector}. -@end deffn - -@deffn {Scheme Procedure} program-base program -@deffnx {C Function} scm_program_base (program) -Returns the address in memory corresponding to the start of -@var{program}'s object code, as an integer. This is useful mostly when -you map the value of an instruction pointer from the VM to actual -instructions. +@deffn {Scheme Procedure} program-objcode program +@deffnx {C Function} scm_program_objcode (program) +Returns the object code associated with this program. @xref{Object +Code}, for more information. @end deffn @deffn {Scheme Procedure} program-objects program @@ -184,9 +176,9 @@ vector. @xref{VM Programs}, for more information. @deffn {Scheme Procedure} program-module program @deffnx {C Function} scm_program_module (program) -Returns the module that was current when this program was created. -Free variables in this program are looked up with respect to this -module. +Returns the module that was current when this program was created. Can +return @code{#f} if the compiler could determine that this information +was unnecessary. @end deffn @deffn {Scheme Procedure} program-external program @@ -250,9 +242,9 @@ REPL. The only tricky bit is that @var{extp} is a boolean, declaring whether the binding is heap-allocated or not. @xref{VM Concepts}, for more information. -Note that bindings information are stored in a program as part of its -metadata thunk, so including them in the generated object code does -not impose a runtime performance penalty. +Note that bindings information is stored in a program as part of its +metadata thunk, so including it in the generated object code does not +impose a runtime performance penalty. @end deffn @deffn {Scheme Procedure} program-sources program diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 27d8f79c8..e4a4f18d1 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -22,8 +22,10 @@ know how to compile your .scm file. @menu * Compiler Tower:: * The Scheme Compiler:: -* GHIL:: +* Tree-IL:: * GLIL:: +* Assembly:: +* Bytecode:: * Object Code:: * Extending the Compiler:: @end menu @@ -52,7 +54,7 @@ They are registered with the @code{define-language} form. @deffn {Scheme Syntax} define-language @ name title version reader printer @ -[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f] +[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] Define a language. This syntax defines a @code{#} object, bound to @var{name} @@ -62,17 +64,15 @@ for Scheme: @example (define-language scheme - #:title "Guile Scheme" - #:version "0.5" - #:reader read - #:read-file read-file - #:compilers `((,ghil . ,compile-ghil)) - #:evaluator (lambda (x module) (primitive-eval x)) - #:printer write) + #:title "Guile Scheme" + #:version "0.5" + #:reader read + #:compilers `((tree-il . ,compile-tree-il) + (ghil . ,compile-ghil)) + #:decompilers `((tree-il . ,decompile-tree-il)) + #:evaluator (lambda (x module) (primitive-eval x)) + #:printer write) @end example - -In this example, from @code{(language scheme spec)}, @code{read-file} -reads expressions from a port and wraps them in a @code{begin} block. @end deffn The interesting thing about having languages defined this way is that @@ -85,12 +85,12 @@ Guile Scheme interpreter 0.5 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> +tree-il@@(guile-user)> @end example Languages can be looked up by name, as they were above. @@ -128,8 +128,10 @@ The normal tower of languages when compiling Scheme goes like this: @itemize @item Scheme, which we know and love -@item Guile High Intermediate Language (GHIL) +@item Tree Intermediate Language (Tree-IL) @item Guile Low Intermediate Language (GLIL) +@item Assembly +@item Bytecode @item Object code @end itemize @@ -137,8 +139,14 @@ Object code may be serialized to disk directly, though it has a cookie and version prepended to the front. But when compiling Scheme at run time, you want a Scheme value, e.g. a compiled procedure. For this reason, so as not to break the abstraction, Guile defines a fake -language, @code{value}. Compiling to @code{value} loads the object -code into a procedure, and wakes the sleeping giant. +language at the bottom of the tower: + +@itemize +@item Value +@end itemize + +Compiling to @code{value} loads the object code into a procedure, and +wakes the sleeping giant. Perhaps this strangeness can be explained by example: @code{compile-file} defaults to compiling to object code, because it @@ -156,340 +164,254 @@ different worlds indefinitely, as shown by the following quine: @node The Scheme Compiler @subsection The Scheme Compiler -The job of the Scheme compiler is to expand all macros and to resolve -all symbols to lexical variables. Its target language, GHIL, is fairly -close to Scheme itself, so this process is not very complicated. +The job of the Scheme compiler is to expand all macros and all of +Scheme to its most primitive expressions. The definition of +``primitive'' is given by the inventory of constructs provided by +Tree-IL, the target language of the Scheme compiler: procedure +applications, conditionals, lexical references, etc. This is described +more fully in the next section. -The Scheme compiler is driven by a table of @dfn{translators}, -declared with the @code{define-scheme-translator} form, defined in the -module, @code{(language scheme compile-ghil)}. +The tricky and amusing thing about the Scheme-to-Tree-IL compiler is +that it is completely implemented by the macro expander. Since the +macro expander has to run over all of the source code already in order +to expand macros, it might as well do the analysis at the same time, +producing Tree-IL expressions directly. -@deffn {Scheme Syntax} define-scheme-translator head clause1 clause2... -The best documentation of this form is probably an example. Here is -the translator for @code{if}: +Because this compiler is actually the macro expander, it is +extensible. Any macro which the user writes becomes part of the +compiler. -@example -(define-scheme-translator if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) - ((,test ,then ,else) - (make-ghil-if e l (retrans test) (retrans then) (retrans else)))) -@end example +The Scheme-to-Tree-IL expander may be invoked using the generic +@code{compile} procedure: -The match syntax is from the @code{pmatch} macro, defined in -@code{(system base pmatch)}. The result of a clause should be a valid -GHIL value. If no clause matches, a syntax error is signalled. +@lisp +(compile '(+ 1 2) #:from 'scheme #:to 'tree-il) +@result{} + #< src: #f + proc: #< src: #f name: +> + args: (#< src: #f exp: 1> + #< src: #f exp: 2>)> +@end lisp -In the body of the clauses, the following bindings are introduced: -@itemize -@item @code{e}, the current environment -@item @code{l}, the current source location (or @code{#f}) -@item @code{retrans}, a procedure that may be called to compile -subexpressions -@end itemize +Or, since Tree-IL is so close to Scheme, it is often useful to expand +Scheme to Tree-IL, then translate back to Scheme. For that reason the +expander provides two interfaces. The former is equivalent to calling +@code{(sc-expand '(+ 1 2) 'c)}, where the @code{'c} is for +``compile''. With @code{'e} (the default), the result is translated +back to Scheme: -Note that translators are looked up by @emph{value}, not by name. That -is to say, the translator is keyed under the @emph{value} of -@code{if}, which normally prints as @code{#}. -@end deffn +@lisp +(sc-expand '(+ 1 2)) +@result{} (+ 1 2) +(sc-expand '(let ((x 10)) (* x x))) +@result{} (let ((x84 10)) (* x84 x84)) +@end lisp -Users can extend the compiler by defining new translators. -Additionally, some forms can be inlined directly to -instructions -- @xref{Inlined Scheme Instructions}, for a list. The -actual inliners are defined in @code{(language scheme inline)}: +The second example shows that as part of its job, the macro expander +renames lexically-bound variables. The original names are preserved +when compiling to Tree-IL, but can't be represented in Scheme: a +lexical binding only has one name. It is for this reason that the +@emph{native} output of the expander is @emph{not} Scheme. There's too +much information we would lose if we translated to Scheme directly: +lexical variable names, source locations, and module hygiene. -@deffn {Scheme Syntax} define-inline head arity1 result1 arity2 result2... -Defines an inliner for @code{head}. As in -@code{define-scheme-translator}, inliners are keyed by value and not -by name. +Note however that @code{sc-expand} does not have the same signature as +@code{compile-tree-il}. @code{compile-tree-il} is a small wrapper +around @code{sc-expand}, to make it conform to the general form of +compiler procedures in Guile's language tower. -Expressions are matched on their arities. For example: +Compiler procedures take two arguments, an expression and an +environment. They return three values: the compiled expression, the +corresponding environment for the target language, and a +``continuation environment''. The compiled expression and environment +will serve as input to the next language's compiler. The +``continuation environment'' can be used to compile another expression +from the same source language within the same module. -@example -(define-inline eq? - (x y) (eq? x y)) -@end example +For example, you might compile the expression, @code{(define-module +(foo))}. This will result in a Tree-IL expression and environment. But +if you compiled a second expression, you would want to take into +account the compile-time effect of compiling the previous expression, +which puts the user in the @code{(foo)} module. That is purpose of the +``continuation environment''; you would pass it as the environment +when compiling the subsequent expression. -This inlines calls to the Scheme procedure, @code{eq?}, to the -instruction @code{eq?}. - -A more complicated example would be: - -@example -(define-inline + - () 0 - (x) x - (x y) (add x y) - (x y . rest) (add x (+ y . rest))) -@end example -@end deffn - -Compilers take two arguments, an expression and an environment, and -return two values as well: an expression in the target language, and -an environment suitable for the target language. The format of the -environment is language-dependent. - -For Scheme, an environment may be one of three things: +For Scheme, an environment may be one of two things: @itemize @item @code{#f}, in which case compilation is performed in the context -of the current module; -@item a module, which specifies the context of the compilation; or -@item a @dfn{compile environment}, which specifies lexical variables -as well. +of the current module; or +@item a module, which specifies the context of the compilation. @end itemize -The format of a compile environment for scheme is @code{(@var{module} -@var{lexicals} . @var{externals})}, though users are strongly -discouraged from constructing these environments themselves. Instead, -if you need this functionality -- as in GOOPS' dynamic method compiler --- capture an environment with @code{compile-time-environment}, then -pass that environment to @code{compile}. +@node Tree-IL +@subsection Tree-IL -@deffn {Scheme Procedure} compile-time-environment -A special function known to the compiler that, when compiled, will -return a representation of the lexical environment in place at compile -time. Useful for supporting some forms of dynamic compilation. Returns -@code{#f} if called from the interpreter. -@end deffn - -@node GHIL -@subsection GHIL - -Guile High Intermediate Language (GHIL) is a structured intermediate +Tree Intermediate Language (Tree-IL) is a structured intermediate language that is close in expressive power to Scheme. It is an expanded, pre-analyzed Scheme. -GHIL is ``structured'' in the sense that its representation is based -on records, not S-expressions. This gives a rigidity to the language -that ensures that compiling to a lower-level language only requires a -limited set of transformations. Practically speaking, consider the -GHIL type, @code{}, which has fields named @code{env}, -@code{loc}, and @code{exp}. Instances of this type are records created -via @code{make-ghil-quote}, and whose fields are accessed as -@code{ghil-quote-env}, @code{ghil-quote-loc}, and -@code{ghil-quote-exp}. There is also a predicate, @code{ghil-quote?}. -@xref{Records}, for more information on records. +Tree-IL is ``structured'' in the sense that its representation is +based on records, not S-expressions. This gives a rigidity to the +language that ensures that compiling to a lower-level language only +requires a limited set of transformations. Practically speaking, +consider the Tree-IL type, @code{}, which has two fields, +@code{src} and @code{exp}. Instances of this type are records created +via @code{make-const}, and whose fields are accessed as +@code{const-src}, and @code{const-exp}. There is also a predicate, +@code{const?}. @xref{Records}, for more information on records. -Expressions of GHIL name their environments explicitly, and all -variables are referenced by identity in addition to by name. -@code{(language ghil)} defines a number of routines to deal explicitly -with variables and environments: +@c alpha renaming -@deftp {Scheme Variable} [table='()] -A toplevel environment. The @var{table} holds all toplevel variables -that have been resolved in this environment. -@end deftp -@deftp {Scheme Variable} parent [table='()] [variables='()] -A lexical environment. @var{parent} will be the enclosing lexical -environment, or a toplevel environment. @var{table} holds an alist -mapping symbols to variables bound in this environment, while -@var{variables} holds a cumulative list of all variables ever defined -in this environment. +All Tree-IL types have a @code{src} slot, which holds source location +information for the expression. This information, if present, will be +residualized into the compiled object code, allowing backtraces to +show source information. The format of @code{src} is the same as that +returned by Guile's @code{source-properties} function. @xref{Source +Properties}, for more information. -Lexical environments correspond to procedures. Bindings introduced -e.g. by Scheme's @code{let} add to the bindings in a lexical -environment. An example of a case in which a variable might be in -@var{variables} but not in @var{table} would be a variable that is in -the same procedure, but is out of scope. -@end deftp -@deftp {Scheme Variable} env name kind [index=#f] -A variable. @var{kind} is one of @code{argument}, @code{local}, -@code{external}, @code{toplevel}, @code{public}, or @code{private}; -see the procedures below for more information. @var{index} is used in -compilation. -@end deftp - -@deffn {Scheme Procedure} ghil-var-is-bound? env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it or @code{#f} if none is found. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-ref! env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it. If the symbol was not bound, return a new toplevel -variable. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-set! env sym -Like @code{ghil-var-for-ref!}, except that the returned variable will -be marked as @code{external}. @xref{Variables and the VM}. -@end deffn -@deffn {Scheme Procedure} ghil-var-define! toplevel-env sym -Return an existing or new toplevel variable named @var{sym}. -@var{toplevel-env} must be a toplevel environment. -@end deffn -@deffn {Scheme Procedure} ghil-var-at-module! env modname sym interface? -Return a variable that will be resolved at run-time with respect to a -specific module named @var{modname}. If @var{interface?} is true, the -variable will be of type @code{public}, otherwise @code{private}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-environment env syms func -Bind @var{syms} to fresh variables within a new lexical environment -whose parent is @var{env}, and call @var{func} as @code{(@var{func} -@var{new-env} @var{new-vars})}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-bindings env syms func -Like @code{call-with-ghil-environment}, except the existing -environment @var{env} is re-used. For that reason, @var{func} is -invoked as @code{(@var{func} @var{new-vars})} -@end deffn - -In the aforementioned @code{} type, the @var{env} slot -holds a pointer to the environment in which the expression occurs. The -@var{loc} slot holds source location information, so that errors -corresponding to this expression can be mapped back to the initial -expression in the higher-level language, e.g. Scheme. @xref{Compiled -Procedures}, for more information on source location objects. - -GHIL also has a declarative serialization format, which makes writing -and reading it a tractable problem for the human mind. Since all GHIL -language constructs contain @code{env} and @code{loc} pointers, they -are left out of the serialization. (Serializing @code{env} structures -would be difficult, as they are often circular.) What is left is the -type of expression, and the remaining slots defined in the expression -type. - -For example, an S-expression representation of the @code{} -expression would be: +Although Tree-IL objects are represented internally using records, +there is also an equivalent S-expression external representation for +each kind of Tree-IL. For example, an the S-expression representation +of @code{#} expression would be: @example -(quote 3) +(const 3) @end example -It's deceptively like Scheme. The general rule is, for a type defined -as @code{ env loc @var{slot1} @var{slot2}...}, the -S-expression representation will be @code{(@var{foo} @var{slot1} -@var{slot2}...)}. Users may program with this format directly at the -REPL: +Users may program with this format directly at the REPL: @example -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10)) +tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10)) @result{} 42 @end example -For convenience, some slots are serialized as rest arguments; those -are noted below. The other caveat is that variables are serialized as -their names only, and not their identities. +The @code{src} fields are left out of the external representation. -@deftp {Scheme Variable} env loc -The unspecified value. +@deftp {Scheme Variable} src +@deftpx {External Representation} (void) +An empty expression. In practice, equivalent to Scheme's @code{(if #f +#f)}. @end deftp -@deftp {Scheme Variable} env loc exp -A quoted expression. +@deftp {Scheme Variable} src exp +@deftpx {External Representation} (const @var{exp}) +A constant. +@end deftp +@deftp {Scheme Variable} src name +@deftpx {External Representation} (primitive @var{name}) +A reference to a ``primitive''. A primitive is a procedure that, when +compiled, may be open-coded. For example, @code{cons} is usually +recognized as a primitive, so that it compiles down to a single +instruction. -Note that unlike in Scheme, there are no self-quoting expressions; all -constants must come from @code{quote} expressions. +Compilation of Tree-IL usually begins with a pass that resolves some +@code{} and @code{} expressions to +@code{} expressions. The actual compilation pass +has special cases for applications of certain primitives, like +@code{apply} or @code{cons}. @end deftp -@deftp {Scheme Variable} env loc exp -A quasiquoted expression. The expression is treated as a constant, -except for embedded @code{unquote} and @code{unquote-splicing} forms. +@deftp {Scheme Variable} src name gensym +@deftpx {External Representation} (lexical @var{name} @var{gensym}) +A reference to a lexically-bound variable. The @var{name} is the +original name of the variable in the source program. @var{gensym} is a +unique identifier for this variable. @end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote}; only valid within a quasiquote. +@deftp {Scheme Variable} src name gensym exp +@deftpx {External Representation} (set! (lexical @var{name} @var{gensym}) @var{exp}) +Sets a lexically-bound variable. @end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote-splicing}; only valid within a quasiquote. +@deftp {Scheme Variable} src mod name public? +@deftpx {External Representation} (@@ @var{mod} @var{name}) +@deftpx {External Representation} (@@@@ @var{mod} @var{name}) +A reference to a variable in a specific module. @var{mod} should be +the name of the module, e.g. @code{(guile-user)}. + +If @var{public?} is true, the variable named @var{name} will be looked +up in @var{mod}'s public interface, and serialized with @code{@@}; +otherwise it will be looked up among the module's private bindings, +and is serialized with @code{@@@@}. @end deftp -@deftp {Scheme Variable} env loc var -A variable reference. Note that for purposes of serialization, -@var{var} is serialized as its name, as a symbol. +@deftp {Scheme Variable} src mod name public? exp +@deftpx {External Representation} (set! (@@ @var{mod} @var{name}) @var{exp}) +@deftpx {External Representation} (set! (@@@@ @var{mod} @var{name}) @var{exp}) +Sets a variable in a specific module. @end deftp -@deftp {Scheme Variable} env loc var val -A variable mutation. @var{var} is serialized as a symbol. +@deftp {Scheme Variable} src name +@deftpx {External Representation} (toplevel @var{name}) +References a variable from the current procedure's module. @end deftp -@deftp {Scheme Variable} env loc var val -A toplevel variable definition. See @code{ghil-var-define!}. +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (set! (toplevel @var{name}) @var{exp}) +Sets a variable in the current procedure's module. @end deftp -@deftp {Scheme Variable} env loc test then else +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (define (toplevel @var{name}) @var{exp}) +Defines a new top-level variable in the current procedure's module. +@end deftp +@deftp {Scheme Variable} src test then else +@deftpx {External Representation} (if @var{test} @var{then} @var{else}) A conditional. Note that @var{else} is not optional. @end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{and}. -@end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{or}. -@end deftp -@deftp {Scheme Variable} env loc . body -Like Scheme's @code{begin}. -@end deftp -@deftp {Scheme Variable} env loc vars exprs . body -Like a deconstructed @code{let}: each element of @var{vars} will be -bound to the corresponding GHIL expression in @var{exprs}. - -Note that for purposes of the serialization format, @var{exprs} are -evaluated before the new bindings are added to the environment. For -@code{letrec} semantics, there also exists a @code{bindrec} parse -flavor. This is useful for writing GHIL at the REPL, but the -serializer does not currently have the cleverness needed to determine -whether a @code{} has @code{let} or @code{letrec} -semantics, and thus only serializes @code{} as @code{bind}. -@end deftp -@deftp {Scheme Variable} env loc vars rest producer . body -Like Scheme's @code{receive} -- binds the values returned by -applying @code{producer}, which should be a thunk, to the -@code{lambda}-like bindings described by @var{vars} and @var{rest}. -@end deftp -@deftp {Scheme Variable} env loc vars rest meta . body -A closure. @var{vars} is the argument list, serialized as a list of -symbols. @var{rest} is a boolean, which is @code{#t} iff the last -argument is a rest argument. @var{meta} is an association list of -properties. The actual @var{body} should be a list of GHIL -expressions. -@end deftp -@deftp {Scheme Variable} env loc proc . args +@deftp {Scheme Variable} src proc args +@deftpx {External Representation} (apply @var{proc} . @var{args}) A procedure call. @end deftp -@deftp {Scheme Variable} env loc producer consumer -Like Scheme's @code{call-with-values}. +@deftp {Scheme Variable} src exps +@deftpx {External Representation} (begin . @var{exps}) +Like Scheme's @code{begin}. @end deftp -@deftp {Scheme Variable} env loc op . args -An inlined VM instruction. @var{op} should be the instruction name as -a symbol, and @var{args} should be its arguments, as GHIL expressions. +@deftp {Scheme Variable} src names vars meta body +@deftpx {External Representation} (lambda @var{names} @var{vars} @var{meta} @var{body}) +A closure. @var{names} is original binding form, as given in the +source code, which may be an improper list. @var{vars} are gensyms +corresponding to the @var{names}. @var{meta} is an association list of +properties. The actual @var{body} is a single Tree-IL expression. @end deftp -@deftp {Scheme Variable} env loc . values -Like Scheme's @code{values}. +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (let @var{names} @var{vars} @var{vals} @var{exp}) +Lexical binding, like Scheme's @code{let}. @var{names} are the +original binding names, @var{vars} are gensyms corresponding to the +@var{names}, and @var{vals} are Tree-IL expressions for the values. +@var{exp} is a single Tree-IL expression. @end deftp -@deftp {Scheme Variable} env loc . values -@var{values} are as in the Scheme expression, @code{(apply values . -@var{vals})}. -@end deftp -@deftp {Scheme Variable} env loc -Produces, at run-time, a reification of the environment at compile -time. Used in the implementation of Scheme's -@code{compile-time-environment}. +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (letrec @var{names} @var{vars} @var{vals} @var{exp}) +A version of @code{} that creates recursive bindings, like +Scheme's @code{letrec}. @end deftp -GHIL implements a compiler to GLIL that recursively traverses GHIL -expressions, writing out GLIL expressions into a linear list. The -compiler also keeps some state as to whether the current expression is -in tail context, and whether its value will be used in future -computations. This state allows the compiler not to emit code for -constant expressions that will not be used (e.g. docstrings), and to -perform tail calls when in tail position. +@c FIXME -- need to revive this one +@c @deftp {Scheme Variable} src vars rest producer . body +@c Like Scheme's @code{receive} -- binds the values returned by +@c applying @code{producer}, which should be a thunk, to the +@c @code{lambda}-like bindings described by @var{vars} and @var{rest}. +@c @end deftp -Just as the Scheme to GHIL compiler introduced new hidden state---the -environment---the GHIL to GLIL compiler introduces more state, the -stack. While not represented explicitly, the stack is present in the -compilation of each GHIL expression: compiling a GHIL expression -should leave the run-time value stack in the same state. For example, -if the intermediate value stack has two elements before evaluating an -@code{if} expression, it should have two elements after that -expression. +Tree-IL implements a compiler to GLIL that recursively traverses +Tree-IL expressions, writing out GLIL expressions into a linear list. +The compiler also keeps some state as to whether the current +expression is in tail context, and whether its value will be used in +future computations. This state allows the compiler not to emit code +for constant expressions that will not be used (e.g. docstrings), and +to perform tail calls when in tail position. + +In the future, there will be a pass at the beginning of the +Tree-IL->GLIL compilation step to perform inlining, copy propagation, +dead code elimination, and constant folding. Interested readers are encouraged to read the implementation in -@code{(language ghil compile-glil)} for more details. +@code{(language tree-il compile-glil)} for more details. @node GLIL @subsection GLIL Guile Low Intermediate Language (GLIL) is a structured intermediate -language whose expressions closely mirror the functionality of Guile's -VM instruction set. +language whose expressions more closely approximate Guile's VM +instruction set. Its expression types are defined in @code{(language glil)}, and as with GHIL, some of its fields parse as rest arguments. @@ -544,14 +466,11 @@ Pushes a constant value onto the stack. @var{obj} must be a number, string, symbol, keyword, boolean, character, or a pair or vector or list thereof, or the empty list. @end deftp -@deftp {Scheme Variable} op index -Accesses an argument on the stack. If @var{op} is @code{ref}, the -argument is pushed onto the stack; if it is @code{set}, the argument -is set from the top value on the stack, which is popped off. -@end deftp @deftp {Scheme Variable} op index -Like @code{}, but for local variables. @xref{Stack -Layout}, for more information. +Accesses a lexically variable from the stack. If @var{op} is +@code{ref}, the value is pushed onto the stack; if it is @code{set}, +the variable is set from the top value on the stack, which is popped +off. @xref{Stack Layout}, for more information. @end deftp @deftp {Scheme Variable} op depth index Accesses a heap-allocated variable, addressed by @var{depth}, the nth @@ -607,6 +526,12 @@ Just as in all of Guile's compilers, an environment is passed to the GLIL-to-object code compiler, and one is returned as well, along with the object code. +@node Assembly +@subsection Assembly + +@node Bytecode +@subsection Bytecode + @node Object Code @subsection Object Code diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 042645200..ae87fbae2 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -111,7 +111,7 @@ The registers that a VM has are as follows: In other architectures, the instruction pointer is sometimes called the ``program counter'' (pc). This set of registers is pretty typical for stack machines; their exact meanings in the context of Guile's VM -is described in the next section. +are described in the next section. A virtual machine executes by loading a compiled procedure, and executing the object code associated with that procedure. Of course, @@ -119,14 +119,17 @@ that procedure may call other procedures, tail-call others, ad infinitum---indeed, within a guile whose modules have all been compiled to object code, one might never leave the virtual machine. -@c wingo: I wish the following were true, but currently we just use -@c the one engine. This kind of thing is possible tho. +@c wingo: The following is true, but I don't know in what context to +@c describe it. A documentation FIXME. @c A VM may have one of three engines: reckless, regular, or debugging. @c Reckless engine is fastest but dangerous. Regular engine is normally @c fail-safe and reasonably fast. Debugging engine is safest and @c functional but very slow. +@c (Actually we have just a regular and a debugging engine; normally +@c we use the latter, it's almost as fast as the ``regular'' engine.) + @node Stack Layout @subsection Stack Layout @@ -174,7 +177,7 @@ The structure of the fixed part of an application frame is as follows: In the above drawing, the stack grows upward. The intermediate values stored in the application of this frame are stored above @code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the -@code{struct scm_program*} data associated with the program at +@code{struct scm_objcode} data associated with the program at @code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the compiled procedure, which will be discussed later. @@ -226,7 +229,7 @@ programs are implemented, @xref{VM Programs}. @node Variables and the VM @subsection Variables and the VM -Let's think about the following Scheme code as an example: +Consider the following Scheme code as an example: @example (define (foo a) @@ -236,22 +239,15 @@ Let's think about the following Scheme code as an example: Within the lambda expression, "foo" is a top-level variable, "a" is a lexically captured variable, and "b" is a local variable. -That is to say: @code{b} may safely be allocated on the stack, as -there is no enclosed procedure that references it, nor is it ever -mutated. +@code{b} may safely be allocated on the stack, as there is no enclosed +procedure that references it, nor is it ever mutated. @code{a}, on the other hand, is referenced by an enclosed procedure, that of the lambda. Thus it must be allocated on the heap, as it may (and will) outlive the dynamic extent of the invocation of @code{foo}. -@code{foo} is a toplevel variable, as mandated by Scheme's semantics: - -@example - (define proc (foo 'bar)) ; assuming prev. definition of @code{foo} - (define foo 42) ; redefinition - (proc 'baz) - @result{} (42 bar baz) -@end example +@code{foo} is a top-level variable, because it names the procedure +@code{foo}, which is here defined at the top-level. Note that variables that are mutated (via @code{set!}) must be allocated on the heap, even if they are local variables. This is @@ -276,6 +272,7 @@ You can pick apart these pieces with the accessors in @code{(system vm program)}. @xref{Compiled Procedures}, for a full API reference. @cindex object table +@cindex object array The object array of a compiled procedure, also known as the @dfn{object table}, holds all Scheme objects whose values are known not to change across invocations of the procedure: constant strings, @@ -293,31 +290,27 @@ instruction, which uses the object vector, and are almost as fast as local variable references. We can see how these concepts tie together by disassembling the -@code{foo} function to see what is going on: +@code{foo} function we defined earlier to see what is going on: @smallexample scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b))) scheme@@(guile-user)> ,x foo Disassembly of #: -Bytecode: - 0 (local-ref 0) ;; `a' (arg) 2 (external-set 0) ;; `a' (arg) - 4 (object-ref 0) ;; # - 6 (make-closure) at (unknown file):0:16 + 4 (object-ref 1) ;; #:0:16 (b)> + 6 (make-closure) 7 (return) ---------------------------------------- -Disassembly of #: +Disassembly of #:0:16 (b)>: -Bytecode: - - 0 (toplevel-ref 0) ;; `list' - 2 (toplevel-ref 1) ;; `foo' - 4 (external-ref 0) ;; (closure variable) - 6 (local-ref 0) ;; `b' (arg) - 8 (goto/args 3) at (unknown file):0:28 + 0 (toplevel-ref 1) ;; `foo' + 2 (external-ref 0) ;; (closure variable) + 4 (local-ref 0) ;; `b' (arg) + 6 (list 0 3) ;; 3 elements at (unknown file):0:28 + 9 (return) @end smallexample At @code{ip} 0 and 2, we do the copy from argument to heap for @@ -336,8 +329,9 @@ Control Instructions}, for more details. Then we see a reference to an external variable, corresponding to @code{a}. The disassembler doesn't have enough information to give a name to that variable, so it just marks it as being a ``closure -variable''. Finally we see the reference to @code{b}, then a tail call -(@code{goto/args}) with three arguments. +variable''. Finally we see the reference to @code{b}, then the +@code{list} opcode, an inline implementation of the @code{list} scheme +routine. @node Instruction Set @subsection Instruction Set @@ -365,7 +359,8 @@ their own test-and-branch instructions: @end example In addition, some Scheme primitives have their own inline -implementations, e.g. @code{cons}. +implementations, e.g. @code{cons}, and @code{list}, as we saw in the +previous section. So Guile's instruction set is a @emph{complete} instruction set, in that it provides the instructions that are suited to the problem, and @@ -421,12 +416,6 @@ efficient in the future via addressing by frame and index. Currently, external variables are all consed onto a list, which results in O(N) lookup time. -@deffn Instruction externals -Pushes the current list of external variables onto the stack. This -instruction is used in the implementation of -@code{compile-time-environment}. @xref{The Scheme Compiler}. -@end deffn - @deffn Instruction toplevel-ref index Push the value of the toplevel binding whose location is stored in at position @var{index} in the object table. @@ -440,11 +429,11 @@ created. Alternately, the lookup may be performed relative to a particular module, determined at compile-time (e.g. via @code{@@} or @code{@@@@}). In that case, the cell in the object table holds a list: -@code{(@var{modname} @var{sym} @var{interface?})}. The symbol -@var{sym} will be looked up in the module named @var{modname} (a list -of symbols). The lookup will be performed against the module's public -interface, unless @var{interface?} is @code{#f}, which it is for -example when compiling @code{@@@@}. +@code{(@var{modname} @var{sym} @var{public?})}. The symbol @var{sym} +will be looked up in the module named @var{modname} (a list of +symbols). The lookup will be performed against the module's public +interface, unless @var{public?} is @code{#f}, which it is for example +when compiling @code{@@@@}. In any case, if the symbol is unbound, an error is signalled. Otherwise the initial form is replaced with the looked-up variable, an @@ -550,8 +539,9 @@ may be encoded in 1, 2, or 4 bytes. @deffn Instruction load-integer length @deffnx Instruction load-unsigned-integer length -Load a 32-bit integer (respectively unsigned integer) from the -instruction stream. +Load a 32-bit integer or unsigned integer from the instruction stream. +The bytes of the integer are read in order of decreasing significance +(i.e., big-endian). @end deffn @deffn Instruction load-number length Load an arbitrary number from the instruction stream. The number is @@ -573,43 +563,23 @@ the current toplevel environment, creating the binding if necessary. Push the variable corresponding to the binding. @end deffn -@deffn Instruction load-program length +@deffn Instruction load-program Load bytecode from the instruction stream, and push a compiled -procedure. This instruction pops the following values from the stack: +procedure. -@itemize -@item Optionally, a thunk, which when called should return metadata -associated with this program---for example its name, the names of its -arguments, its documentation string, debugging information, etc. +This instruction pops one value from the stack: the program's object +table, as a vector, or @code{#f} in the case that the program has no +object table. A program that does not reference toplevel bindings and +does not use @code{object-ref} does not need an object table. -Normally, this thunk its itself a compiled procedure (with no -metadata). Metadata is represented this way so that the initial load -of a procedure is fast: the VM just mmap's the thunk and goes. The -symbols and pairs associated with the metadata are only created if the -user asks for them. - -For information on the format of the thunk's return value, -@xref{Compiled Procedures}. -@item Optionally, the program's object table, as a vector. - -A program that does not reference toplevel bindings and does not use -@code{object-ref} does not need an object table. -@item Finally, either one immediate integer or four immediate integers -representing the arity of the program. - -In the four-fixnum case, the values are respectively the number of -arguments taken by the function (@var{nargs}), the number of @dfn{rest -arguments} (@var{nrest}, 0 or 1), the number of local variables -(@var{nlocs}) and the number of external variables (@var{nexts}) -(@pxref{Environment Control Instructions}). - -The common single-fixnum case represents all of these values within a -16-bit bitmask. -@end itemize +This instruction is unlike the rest of the loading instructions, +because instead of parsing its data, it directly maps the instruction +stream onto a C structure, @code{struct scm_objcode}. @xref{Object +Code}, for more information. The resulting compiled procedure will not have any ``external'' -variables captured, so it will be loaded only once but may be used -many times to create closures. +variables captured, so it may be loaded only once but used many times +to create closures. @end deffn Finally, while this instruction is not strictly a ``loading'' @@ -620,7 +590,10 @@ here: Pop the program object from the stack, capture the current set of ``external'' variables, and assign those external variables to a copy of the program. Push the new program object, which shares state with -the original program. Also captures the current module. +the original program. + +At the time of this writing, the space overhead of closures is 4 words +per closure. @end deffn @node Procedural Instructions @@ -640,22 +613,24 @@ set to the returned value. @deffn Instruction call nargs Call the procedure located at @code{sp[-nargs]} with the @var{nargs} -arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}. +arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}. + +For compiled procedures, this instruction sets up a new stack frame, +as described in @ref{Stack Layout}, and then dispatches to the first +instruction in the called procedure, relying on the called procedure +to return one value to the newly-created continuation. Because the new +frame pointer will point to sp[-nargs + 1], the arguments don't have +to be shuffled around -- they are already in place. For non-compiled procedures (continuations, primitives, and interpreted procedures), @code{call} will pop the procedure and arguments off the stack, and push the result of calling @code{scm_apply}. - -For compiled procedures, this instruction sets up a new stack frame, -as described in @ref{Stack Layout}, and then dispatches to the first -instruction in the called procedure, relying on the called procedure -to return one value to the newly-created continuation. @end deffn @deffn Instruction goto/args nargs Like @code{call}, but reusing the current continuation. This -instruction implements tail calling as required by RnRS. +instruction implements tail calls as required by RnRS. For compiled procedures, that means that @code{goto/args} reuses the current frame instead of building a new one. The @code{goto/*} @@ -726,14 +701,14 @@ values. This is an optimization for the common @code{(apply values @deffn Instruction truncate-values nbinds nrest Used in multiple-value continuations, this instruction takes the -values that are on the stack (including the number-of-value marker) +values that are on the stack (including the number-of-values marker) and truncates them for a binding construct. For example, a call to @code{(receive (x y . z) (foo) ...)} would, logically speaking, pop off the values returned from @code{(foo)} and push them as three values, corresponding to @code{x}, @code{y}, and @code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would -be 1 (to indicate that one of the bindings was a rest arguments). +be 1 (to indicate that one of the bindings was a rest argument). Signals an error if there is an insufficient number of values. @end deffn @@ -779,12 +754,14 @@ Push @var{value}, an 8-bit character, onto the stack. @deffn Instruction list n Pops off the top @var{n} values off of the stack, consing them up into a list, then pushes that list on the stack. What was the topmost value -will be the last element in the list. +will be the last element in the list. @var{n} is a two-byte value, +most significant byte first. @end deffn @deffn Instruction vector n Create and fill a vector with the top @var{n} values from the stack, -popping off those values and pushing on the resulting vector. +popping off those values and pushing on the resulting vector. @var{n} +is a two-byte value, like in @code{vector}. @end deffn @deffn Instruction mark @@ -850,9 +827,8 @@ Pushes ``the unspecified value'' onto the stack. @subsubsection Inlined Scheme Instructions The Scheme compiler can recognize the application of standard Scheme -procedures, or unbound variables that look like they are bound to -standard Scheme procedures. It tries to inline these small operations -to avoid the overhead of creating new stack frames. +procedures. It tries to inline these small operations to avoid the +overhead of creating new stack frames. Since most of these operations are historically implemented as C primitives, not inlining them would entail constantly calling out from @@ -876,12 +852,12 @@ stream. @deffnx Instruction eqv? x y @deffnx Instruction equal? x y @deffnx Instruction pair? x y -@deffnx Instruction list? x y +@deffnx Instruction list? x @deffnx Instruction set-car! pair x @deffnx Instruction set-cdr! pair x @deffnx Instruction slot-ref struct n @deffnx Instruction slot-set struct n x -@deffnx Instruction cons x +@deffnx Instruction cons x y @deffnx Instruction car x @deffnx Instruction cdr x Inlined implementations of their Scheme equivalents. diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index a6cb66dbc..42f2b1973 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -410,12 +410,6 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1) -{ - PUSH (external); - NEXT; -} - /* * branch and jump diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index 234cd064c..92d31cabc 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -198,6 +198,8 @@ OBJECT can be a procedure, macro or any object that has its (object-property object 'documentation) (and (program? object) (program-documentation object)) + (and (macro? object) + (object-documentation (macro-transformer object))) (and (procedure? object) (not (closure? object)) (procedure-name object) diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index 2752934f9..df6199977 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -82,7 +82,7 @@ (if (program? x) (begin (display "----------------------------------------\n") (disassemble x)))) - (cddr (vector->list objs)))))) + (cdr (vector->list objs)))))) (else (error "bad load-program form" asm)))) diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm index 550a0b734..0112af5a4 100644 --- a/module/language/ecmascript/spec.scm +++ b/module/language/ecmascript/spec.scm @@ -33,7 +33,6 @@ #:title "Guile ECMAScript" #:version "3.0" #:reader (lambda () (read-ecmascript/1 (current-input-port))) - #:read-file read-ecmascript #:compilers `((ghil . ,compile-ghil)) ;; a pretty-printer would be interesting. #:printer write diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 4564fb933..cec2693aa 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -32,12 +32,6 @@ (read-enable 'positions) -(define (read-file port) - (do ((x (read port) (read port)) - (l '() (cons x l))) - ((eof-object? x) - (cons 'begin (reverse! l))))) - ;;; ;;; Language definition ;;; @@ -46,7 +40,6 @@ #:title "Guile Scheme" #:version "0.5" #:reader read - #:read-file read-file #:compilers `((tree-il . ,compile-tree-il) (ghil . ,compile-ghil)) #:decompilers `((tree-il . ,decompile-tree-il)) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index a81947749..335031182 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -21,12 +21,8 @@ #:use-module (system base syntax) #:export (tree-il-src - make-lexical - lexical-name lexical-gensym - void? make-void void-src - application? make-application application-src application-proc application-args - conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + const? make-const const-src const-exp primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp @@ -35,9 +31,10 @@ toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp - lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body - const? make-const const-src const-exp + conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + application? make-application application-src application-proc application-args sequence? make-sequence sequence-src sequence-exps + lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body let? make-let let-src let-names let-vars let-vals let-exp letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp @@ -50,8 +47,7 @@ (define-type ( #:common-slots (src)) () - ( proc args) - ( test then else) + ( exp) ( name) ( name gensym) ( name gensym exp) @@ -60,28 +56,19 @@ ( name) ( name exp) ( name exp) - ( names vars meta body) - ( exp) + ( test then else) + ( proc args) ( exps) + ( names vars meta body) ( names vars vals exp) ( names vars vals exp)) -(define ) -(define lexical? lexical-ref?) -(define make-lexical make-lexical-ref) -(define lexical-name lexical-ref-name) -(define lexical-gensym lexical-ref-gensym) - -;; FIXME: use this in psyntax (define (location x) (and (pair? x) (let ((props (source-properties x))) - (and (not (null? props)) - (vector (assq-ref props 'line) - (assq-ref props 'column) - (assq-ref props 'filename)))))) + (and (pair? props) props)))) (define (parse-tree-il exp) (let ((loc (location exp)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 25fd8c79e..51bbfeae9 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -152,7 +152,7 @@ (define-primitive-expander / (x) (/ 1 x) - (x y z . rest) (div x (* y z . rest))) + (x y z . rest) (/ x (* y z . rest))) (define-primitive-expander caar (x) (car (car x))) (define-primitive-expander cadr (x) (car (cdr x))) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index d0ebde040..74fb59852 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -135,11 +135,6 @@ ;;; Compiler interface ;;; -(define (read-file-in file lang) - (call-with-input-file file - (or (language-read-file lang) - (error "language has no #:read-file" lang)))) - (define (compile-passes from to opts) (map cdr (or (lookup-compilation-order from to) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 649137c4d..8ae4d9667 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -23,7 +23,7 @@ #:use-module (system base syntax) #:export (define-language language? lookup-language make-language language-name language-title language-version language-reader - language-printer language-parser language-read-file + language-printer language-parser language-compilers language-decompilers language-evaluator language-joiner @@ -42,7 +42,6 @@ reader printer (parser #f) - (read-file #f) (compilers '()) (decompilers '()) (evaluator #f) From 73643339527d27a09d62424428b67417ca627bf5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 25 May 2009 22:45:42 +0200 Subject: [PATCH 157/375] update docs -- sections on assembly and objcode * doc/ref/api-procedures.texi: * doc/ref/compiler.texi: * doc/ref/vm.texi: Update the docs some more. --- doc/ref/api-procedures.texi | 4 +- doc/ref/compiler.texi | 190 +++++++++++++++++++++++++++++------- doc/ref/vm.texi | 4 +- 3 files changed, 160 insertions(+), 38 deletions(-) diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index 484f2e86f..8098b4ffb 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -164,8 +164,8 @@ Returns @code{#t} iff @var{obj} is a compiled procedure. @deffn {Scheme Procedure} program-objcode program @deffnx {C Function} scm_program_objcode (program) -Returns the object code associated with this program. @xref{Object -Code}, for more information. +Returns the object code associated with this program. @xref{Bytecode +and Objcode}, for more information. @end deffn @deffn {Scheme Procedure} program-objects program diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index e4a4f18d1..0d68abfc6 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -25,8 +25,7 @@ know how to compile your .scm file. * Tree-IL:: * GLIL:: * Assembly:: -* Bytecode:: -* Object Code:: +* Bytecode and Objcode:: * Extending the Compiler:: @end menu @@ -132,13 +131,13 @@ The normal tower of languages when compiling Scheme goes like this: @item Guile Low Intermediate Language (GLIL) @item Assembly @item Bytecode -@item Object code +@item Objcode @end itemize Object code may be serialized to disk directly, though it has a cookie -and version prepended to the front. But when compiling Scheme at -run time, you want a Scheme value, e.g. a compiled procedure. For this -reason, so as not to break the abstraction, Guile defines a fake +and version prepended to the front. But when compiling Scheme at run +time, you want a Scheme value: for example, a compiled procedure. For +this reason, so as not to break the abstraction, Guile defines a fake language at the bottom of the tower: @itemize @@ -421,8 +420,8 @@ A unit of code that at run-time will correspond to a compiled procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts} collectively define the program's arity; see @ref{Compiled Procedures}, for more information. @var{meta} should be an alist of -properties, as in @code{}. @var{body} is a list of GLIL -expressions. +properties, as in Tree IL's @code{}. @var{body} is a list of +GLIL expressions. @end deftp @deftp {Scheme Variable} . vars An advisory expression that notes a liveness extent for a set of @@ -456,18 +455,20 @@ offset within a VM program. @end deftp @deftp {Scheme Variable} loc Records source information for the preceding expression. @var{loc} -should be a vector, @code{#(@var{line} @var{column} @var{filename})}. +should be an association list of containing @code{line} @code{column}, +and @code{filename} keys, e.g. as returned by +@code{source-properties}. @end deftp @deftp {Scheme Variable} Pushes the unspecified value on the stack. @end deftp @deftp {Scheme Variable} obj Pushes a constant value onto the stack. @var{obj} must be a number, -string, symbol, keyword, boolean, character, or a pair or vector or -list thereof, or the empty list. +string, symbol, keyword, boolean, character, the empty list, or a pair +or vector of constants. @end deftp @deftp {Scheme Variable} op index -Accesses a lexically variable from the stack. If @var{op} is +Accesses a lexically bound variable from the stack. If @var{op} is @code{ref}, the value is pushed onto the stack; if it is @code{set}, the variable is set from the top value on the stack, which is popped off. @xref{Stack Layout}, for more information. @@ -482,8 +483,8 @@ Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set}, or @code{define}. @end deftp @deftp {Scheme Variable} op mod name public? -Accesses a variable within a specific module. See -@code{ghil-var-at-module!}, for more information. +Accesses a variable within a specific module. See Tree-IL's +@code{}, for more information. @end deftp @deftp {Scheme Variable} label Creates a new label. @var{label} can be any Scheme value, and should @@ -529,26 +530,140 @@ the object code. @node Assembly @subsection Assembly -@node Bytecode -@subsection Bytecode +Assembly is an S-expression-based, human-readable representation of +the actual bytecodes that will be emitted for the VM. As such, it is a +useful intermediate language both for compilation and for +decompilation. -@node Object Code -@subsection Object Code +Besides the fact that it is not a record-based language, assembly +differs from GLIL in four main ways: -Object code is the serialization of the raw instruction stream of a -program, ready for interpretation by the VM. Procedures related to -object code are defined in the @code{(system vm objcode)} module. +@itemize +@item Labels have been resolved to byte offsets in the program. +@item Constants inside procedures have either been expressed as inline +instructions, and possibly cached in object arrays. +@item Procedures with metadata (source location information, liveness +extents, procedure names, generic properties, etc) have had their +metadata serialized out to thunks. +@item All expressions correspond directly to VM instructions -- i.e., +there is no @code{} which can be a ref or a set. +@end itemize + +Assembly is isomorphic to the bytecode that it compiles to. You can +compile to bytecode, then decompile back to assembly, and you have the +same assembly code. + +The general form of assembly instructions is the following: + +@lisp +(@var{inst} @var{arg} ...) +@end lisp + +The @var{inst} names a VM instruction, and its @var{arg}s will be +embedded in the instruction stream. The easiest way to see assembly is +to play around with it at the REPL, as can be seen in this annotated +example: + +@example +scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly) +(load-program 0 0 0 0 + () ; Labels + 60 ; Length + #f ; Metadata + (make-false) ; object table for the returned lambda + (nop) + (nop) ; Alignment. Since assembly has already resolved its labels + (nop) ; to offsets, and programs must be 8-byte aligned since their + (nop) ; object code is mmap'd directly to structures, assembly + (nop) ; has to have the alignment embedded in it. + (nop) + (load-program 1 0 0 0 + () + 6 + ; This is the metadata thunk for the returned procedure. + (load-program 0 0 0 0 () 21 #f + (load-symbol "x") ; Name and liveness extent for @code{x}. + (make-false) + (make-int8:0) ; Some instruction+arg combinations + (make-int8:0) ; have abbreviations. + (make-int8 6) + (list 0 5) + (list 0 1) + (make-eol) + (list 0 2) + (return)) + ; And here, the actual code. + (local-ref 0) + (local-ref 0) + (add) + (return)) + ; Return our new procedure. + (return)) +@end example + +Of course you can switch the REPL to assembly and enter in assembly +S-expressions directly, like with other languages, though it is more +difficult, given that the length fields have to be correct. + +@node Bytecode and Objcode +@subsection Bytecode and Objcode + +Finally, the raw bytes. There are actually two different ``languages'' +here, corresponding to two different ways to represent the bytes. + +``Bytecode'' represents code as uniform byte vectors, useful for +structuring and destructuring code on the Scheme level. Bytecode is +the next step down from assembly: + +@example +scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly) +@result{} (load-program 0 0 0 0 () 6 #f + (make-int8 32) (make-int8 10) (add) (return)) +scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode) +@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48) +@end example + +``Objcode'' is bytecode, but mapped directly to a C structure, +@code{struct scm_objcode}: + +@example +struct scm_objcode @{ + scm_t_uint8 nargs; + scm_t_uint8 nrest; + scm_t_uint8 nlocs; + scm_t_uint8 nexts; + scm_t_uint32 len; + scm_t_uint32 metalen; + scm_t_uint8 base[0]; +@}; +@end example + +As one might imagine, objcode imposes a minimum length on the +bytecode. Also, the multibyte fields are in native endianness, which +makes objcode (and bytecode) system-dependent. Indeed, in the short +example above, all but the last 5 bytes were the program's header. + +Objcode also has a couple of important efficiency hacks. First, +objcode may be mapped directly from disk, allowing compiled code to be +loaded quickly, often from the system's disk cache, and shared among +multiple processes. Secondly, objcode may be embedded in other +objcode, allowing procedures to have the text of other procedures +inlined into their bodies, without the need for separate allocation of +the code. Of course, the objcode object itself does need to be +allocated. + +Procedures related to objcode are defined in the @code{(system vm +objcode)} module. @deffn {Scheme Procedure} objcode? obj @deffnx {C Function} scm_objcode_p (obj) Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise. @end deffn -@deffn {Scheme Procedure} bytecode->objcode bytecode nlocs nexts -@deffnx {C Function} scm_bytecode_to_objcode (bytecode, nlocs, nexts) +@deffn {Scheme Procedure} bytecode->objcode bytecode +@deffnx {C Function} scm_bytecode_to_objcode (bytecode,) Makes a bytecode object from @var{bytecode}, which should be a -@code{u8vector}. @var{nlocs} and @var{nexts} denote the number of -stack and heap variables to reserve when this objcode is executed. +@code{u8vector}. @end deffn @deffn {Scheme Variable} load-objcode file @@ -556,21 +671,28 @@ stack and heap variables to reserve when this objcode is executed. Load object code from a file named @var{file}. The file will be mapped into memory via @code{mmap}, so this is a very fast operation. -On disk, object code has an eight-byte cookie prepended to it, so that -we will not execute arbitrary garbage. In addition, two more bytes are -reserved for @var{nlocs} and @var{nexts}. +On disk, object code has an eight-byte cookie prepended to it, to +prevent accidental loading of arbitrary garbage. +@end deffn + +@deffn {Scheme Variable} write-objcode objcode file +@deffnx {C Function} scm_write_objcode (objcode) +Write object code out to a file, prepending the eight-byte cookie. @end deffn @deffn {Scheme Variable} objcode->u8vector objcode @deffnx {C Function} scm_objcode_to_u8vector (objcode) -Copy object code out to a @code{u8vector} for analysis by Scheme. The -ten-byte header is included. +Copy object code out to a @code{u8vector} for analysis by Scheme. @end deffn -@deffn {Scheme Variable} objcode->program objcode [external='()] -@deffnx {C Function} scm_objcode_to_program (objcode, external) +The following procedure is actually in @code{(system vm program)}, but +we'll mention it here: + +@deffn {Scheme Variable} make-program objcode objtable [external='()] +@deffnx {C Function} scm_make_program (objcode, objtable, external) Load up object code into a Scheme program. The resulting program will -be a thunk that captures closure variables from @var{external}. +have @var{objtable} as its object table, which should be a vector or +@code{#f}, and will capture the closure variables from @var{external}. @end deffn Object code from a file may be disassembled at the REPL via the @@ -614,7 +736,7 @@ fruit, running programs of interest under a system-level profiler and determining which improvements would give the most bang for the buck. There are many well-known efficiency hacks in the literature: Dybvig's letrec optimization, individual boxing of heap-allocated values (and -then store the boxes on the stack directory), optimized case-lambda +then store the boxes on the stack directly), optimized case-lambda expressions, stack underflow and overflow handlers, etc. Highly recommended papers: Dybvig's HOCS, Ghuloum's compiler paper. diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index ae87fbae2..49b420c50 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -574,8 +574,8 @@ does not use @code{object-ref} does not need an object table. This instruction is unlike the rest of the loading instructions, because instead of parsing its data, it directly maps the instruction -stream onto a C structure, @code{struct scm_objcode}. @xref{Object -Code}, for more information. +stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode +and Objcode}, for more information. The resulting compiled procedure will not have any ``external'' variables captured, so it may be loaded only once but used many times From 9d07bb7276d1be078c5933645897694035ecdcfe Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 16:03:37 +0200 Subject: [PATCH 158/375] distcheck fix, fix (ice-9 time) * lang/Makefile.am (elisp_sources): Add elisp/expand.scm. * module/ice-9/time.scm (time): Fix for new macro expander. Ew. --- lang/Makefile.am | 1 + module/ice-9/time.scm | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/lang/Makefile.am b/lang/Makefile.am index 6dc2e2902..97c440d75 100644 --- a/lang/Makefile.am +++ b/lang/Makefile.am @@ -28,6 +28,7 @@ elisp_sources = \ elisp/example.el \ elisp/interface.scm \ elisp/transform.scm \ + elisp/expand.scm \ elisp/variables.scm \ \ elisp/primitives/buffers.scm \ diff --git a/module/ice-9/time.scm b/module/ice-9/time.scm index a7045969f..86ebcbff1 100644 --- a/module/ice-9/time.scm +++ b/module/ice-9/time.scm @@ -53,6 +53,6 @@ result)) (define-macro (time exp) - `(,time-proc (lambda () ,exp))) + `((@@ (ice-9 time) time-proc) (lambda () ,exp))) ;;; time.scm ends here From d9a9e18205f4da1486a70dbd5690b8fdc593cb10 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 17:45:48 +0200 Subject: [PATCH 159/375] gnulib-tool --import lib-symbol-visibility --- lib/Makefile.am | 12 ++++++++++- m4/gnulib-cache.m4 | 3 ++- m4/gnulib-comp.m4 | 2 ++ m4/include_next.m4 | 32 +++++++++++++++++++++------- m4/visibility.m4 | 52 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 91 insertions(+), 10 deletions(-) create mode 100644 m4/visibility.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 78693ea11..8f431c2b1 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write putenv stdlib strcase strftime +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime AUTOMAKE_OPTIONS = 1.5 gnits @@ -143,6 +143,16 @@ libgnu_la_SOURCES += full-write.h full-write.c ## end gnulib module full-write +## begin gnulib module lib-symbol-visibility + +# The value of $(CFLAG_VISIBILITY) needs to be added to the CFLAGS for the +# compilation of all sources that make up the library. This line here does it +# only for the gnulib part of it. The developer is responsible for adding +# $(CFLAG_VISIBILITY) to the Makefile.ams of the other portions of the library. +AM_CFLAGS += $(CFLAG_VISIBILITY) + +## end gnulib module lib-symbol-visibility + ## begin gnulib module link-warning LINK_WARNING_H=$(top_srcdir)/build-aux/link-warning.h diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 1122aa58d..fd6c4fe91 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write putenv stdlib strcase strftime +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -28,6 +28,7 @@ gl_MODULES([ fpieee full-read full-write + lib-symbol-visibility putenv stdlib strcase diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 186f30f7a..77100fa1b 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -48,6 +48,7 @@ AC_DEFUN([gl_INIT], gl_FUNC_FLOCK gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) gl_INLINE + gl_VISIBILITY gl_LOCALCHARSET LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\"" AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) @@ -283,6 +284,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/time_r.m4 m4/tm_gmtoff.m4 m4/unistd_h.m4 + m4/visibility.m4 m4/wchar.m4 m4/wint_t.m4 m4/write.m4 diff --git a/m4/include_next.m4 b/m4/include_next.m4 index d6101fe32..5e22ded93 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,4 +1,4 @@ -# include_next.m4 serial 12 +# include_next.m4 serial 14 dnl Copyright (C) 2006-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -104,8 +104,14 @@ EOF # For each arg foo.h, if #include_next works, define NEXT_FOO_H to be # ''; otherwise define it to be # '"///usr/include/foo.h"', or whatever other absolute file name is suitable. +# Also, if #include_next works as first preprocessing directive in a file, +# define NEXT_AS_FIRST_DIRECTIVE_FOO_H to be ''; otherwise define it to +# be +# '"///usr/include/foo.h"', or whatever other absolute file name is suitable. # That way, a header file with the following line: # #@INCLUDE_NEXT@ @NEXT_FOO_H@ +# or +# #@INCLUDE_NEXT_AS_FIRST_DIRECTIVE@ @NEXT_AS_FIRST_DIRECTIVE_FOO_H@ # behaves (after sed substitution) as if it contained # #include_next # even if the compiler does not support include_next. @@ -123,15 +129,15 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS], m4_foreach_w([gl_HEADER_NAME], [$1], [AS_VAR_PUSHDEF([gl_next_header], - [gl_cv_next_]m4_quote(m4_defn([gl_HEADER_NAME]))) + [gl_cv_next_]m4_defn([gl_HEADER_NAME])) if test $gl_cv_have_include_next = yes; then AS_VAR_SET([gl_next_header], ['<'gl_HEADER_NAME'>']) else AC_CACHE_CHECK( - [absolute name of <]m4_quote(m4_defn([gl_HEADER_NAME]))[>], - m4_quote(m4_defn([gl_next_header])), + [absolute name of <]m4_defn([gl_HEADER_NAME])[>], + m4_defn([gl_next_header]), [AS_VAR_PUSHDEF([gl_header_exists], - [ac_cv_header_]m4_quote(m4_defn([gl_HEADER_NAME]))) + [ac_cv_header_]m4_defn([gl_HEADER_NAME])) if test AS_VAR_GET(gl_header_exists) = yes; then AC_LANG_CONFTEST( [AC_LANG_SOURCE( @@ -153,8 +159,8 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS], dnl so use subshell. AS_VAR_SET([gl_next_header], ['"'`(eval "$gl_absname_cpp conftest.$ac_ext") 2>&AS_MESSAGE_LOG_FD | - sed -n '\#/]m4_quote(m4_defn([gl_HEADER_NAME]))[#{ - s#.*"\(.*/]m4_quote(m4_defn([gl_HEADER_NAME]))[\)".*#\1# + sed -n '\#/]m4_defn([gl_HEADER_NAME])[#{ + s#.*"\(.*/]m4_defn([gl_HEADER_NAME])[\)".*#\1# s#^/[^/]#//&# p q @@ -165,7 +171,17 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS], AS_VAR_POPDEF([gl_header_exists])]) fi AC_SUBST( - AS_TR_CPP([NEXT_]m4_quote(m4_defn([gl_HEADER_NAME]))), + AS_TR_CPP([NEXT_]m4_defn([gl_HEADER_NAME])), [AS_VAR_GET([gl_next_header])]) + if test $gl_cv_have_include_next = yes || test $gl_cv_have_include_next = buggy; then + # INCLUDE_NEXT_AS_FIRST_DIRECTIVE='include_next' + gl_next_as_first_directive='<'gl_HEADER_NAME'>' + else + # INCLUDE_NEXT_AS_FIRST_DIRECTIVE='include' + gl_next_as_first_directive=AS_VAR_GET([gl_next_header]) + fi + AC_SUBST( + AS_TR_CPP([NEXT_AS_FIRST_DIRECTIVE_]m4_defn([gl_HEADER_NAME])), + [$gl_next_as_first_directive]) AS_VAR_POPDEF([gl_next_header])]) ]) diff --git a/m4/visibility.m4 b/m4/visibility.m4 new file mode 100644 index 000000000..70bca5643 --- /dev/null +++ b/m4/visibility.m4 @@ -0,0 +1,52 @@ +# visibility.m4 serial 2 (gettext-0.18) +dnl Copyright (C) 2005, 2008 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Bruno Haible. + +dnl Tests whether the compiler supports the command-line option +dnl -fvisibility=hidden and the function and variable attributes +dnl __attribute__((__visibility__("hidden"))) and +dnl __attribute__((__visibility__("default"))). +dnl Does *not* test for __visibility__("protected") - which has tricky +dnl semantics (see the 'vismain' test in glibc) and does not exist e.g. on +dnl MacOS X. +dnl Does *not* test for __visibility__("internal") - which has processor +dnl dependent semantics. +dnl Does *not* test for #pragma GCC visibility push(hidden) - which is +dnl "really only recommended for legacy code". +dnl Set the variable CFLAG_VISIBILITY. +dnl Defines and sets the variable HAVE_VISIBILITY. + +AC_DEFUN([gl_VISIBILITY], +[ + AC_REQUIRE([AC_PROG_CC]) + CFLAG_VISIBILITY= + HAVE_VISIBILITY=0 + if test -n "$GCC"; then + AC_MSG_CHECKING([for simple visibility declarations]) + AC_CACHE_VAL([gl_cv_cc_visibility], [ + gl_save_CFLAGS="$CFLAGS" + CFLAGS="$CFLAGS -fvisibility=hidden" + AC_TRY_COMPILE( + [extern __attribute__((__visibility__("hidden"))) int hiddenvar; + extern __attribute__((__visibility__("default"))) int exportedvar; + extern __attribute__((__visibility__("hidden"))) int hiddenfunc (void); + extern __attribute__((__visibility__("default"))) int exportedfunc (void);], + [], + [gl_cv_cc_visibility=yes], + [gl_cv_cc_visibility=no]) + CFLAGS="$gl_save_CFLAGS"]) + AC_MSG_RESULT([$gl_cv_cc_visibility]) + if test $gl_cv_cc_visibility = yes; then + CFLAG_VISIBILITY="-fvisibility=hidden" + HAVE_VISIBILITY=1 + fi + fi + AC_SUBST([CFLAG_VISIBILITY]) + AC_SUBST([HAVE_VISIBILITY]) + AC_DEFINE_UNQUOTED([HAVE_VISIBILITY], [$HAVE_VISIBILITY], + [Define to 1 or 0, depending whether the compiler supports simple visibility declarations.]) +]) From 442f3f20ddd33b43743ea181d95024c10622df52 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 17:39:58 +0200 Subject: [PATCH 160/375] symbols are now hidden unless explicitly exported by SCM_API * libguile/__scm.h (SCM_API, SCM_INTERNAL): Take the reverse strategy: symbols will be hidden by default, and only exported with SCM_API. In addition to working on Mac OS, it has the several nice efficiency benefits on Linux, and unifies codepaths with Win32. * libguile/Makefile.am: Define BUILDING_LIBGUILE when building Guile. --- libguile/Makefile.am | 4 ++-- libguile/__scm.h | 24 +++++++++++------------- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 369b24951..63f2ef2bf 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -32,10 +32,10 @@ DEFAULT_INCLUDES = ## Check for headers in $(srcdir)/.., so that #include ## will find MUMBLE.h in this dir when we're ## building. Also look for Gnulib headers in `lib'. -AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \ +AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \ -I$(top_srcdir)/lib -I$(top_builddir)/lib -AM_CFLAGS = $(GCC_CFLAGS) +AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY) ## The Gnulib Libtool archive. gnulib_library = $(top_builddir)/lib/libgnu.la diff --git a/libguile/__scm.h b/libguile/__scm.h index 3672b1c09..07d7b4d3d 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -98,13 +98,10 @@ #define SCM_UNLIKELY(_expr) SCM_EXPECT ((_expr), 0) /* The SCM_INTERNAL macro makes it possible to explicitly declare a function - * as having "internal" linkage. */ -#if (defined __GNUC__) && \ - ((__GNUC__ >= 4) || (__GNUC__ == 3 && __GNUC_MINOR__ == 3)) -# define SCM_INTERNAL extern __attribute__ ((__visibility__ ("internal"))) -#else -# define SCM_INTERNAL extern -#endif + * as having "internal" linkage. However our current tack on this problem is + * to use GCC 4's -fvisibility=hidden, making functions internal by default, + * and then SCM_API marks them for export. */ +#define SCM_INTERNAL extern @@ -154,13 +151,14 @@ /* SCM_API is a macro prepended to all function and data definitions - which should be exported or imported in the resulting dynamic link - library (DLL) in the Win32 port. */ + which should be exported from libguile. */ -#if defined (SCM_IMPORT) -# define SCM_API __declspec (dllimport) extern -#elif defined (SCM_EXPORT) || defined (DLL_EXPORT) -# define SCM_API __declspec (dllexport) extern +#if BUILDING_LIBGUILE && HAVE_VISIBILITY +# define SCM_API extern __attribute__((__visibility__("default"))) +#elif BUILDING_LIBGUILE && defined _MSC_VER +# define SCM_API __declspec(dllexport) extern +#elif defined _MSC_VER +# define SCM_API __declspec(dllimport) extern #else # define SCM_API extern #endif From b579617b2db0e83f620c5b856dcc320cea9d6d1f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 18:06:21 +0200 Subject: [PATCH 161/375] gnulib-tool --import environ; rely on gnulib for environ definitions * libguile/posix.c: * libguile/stime.c: Remove environ definition, gnulib provides it now. --- lib/Makefile.am | 2 +- libguile/posix.c | 13 ------------- libguile/stime.c | 13 ------------- m4/environ.m4 | 36 ++++++++++++++++++++++++++++++++++++ m4/gnulib-cache.m4 | 3 ++- m4/gnulib-comp.m4 | 3 +++ 6 files changed, 42 insertions(+), 28 deletions(-) create mode 100644 m4/environ.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 8f431c2b1..f321b0b16 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits environ extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime AUTOMAKE_OPTIONS = 1.5 gnits diff --git a/libguile/posix.c b/libguile/posix.c index 2799209d9..5e6f05fb7 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -101,8 +101,6 @@ extern char *ttyname(); #include -extern char ** environ; - #ifdef HAVE_GRP_H #include #endif @@ -140,10 +138,6 @@ extern char ** environ; #include /* from Gnulib */ -#if HAVE_CRT_EXTERNS_H -#include /* for Darwin _NSGetEnviron */ -#endif - /* Some Unix systems don't define these. CPP hair is dangerous, but this seems safe enough... */ #ifndef R_OK @@ -196,13 +190,6 @@ int sethostname (char *name, size_t namelen); -/* On Apple Darwin in a shared library there's no "environ" to access - directly, instead the address of that variable must be obtained with - _NSGetEnviron(). */ -#if HAVE__NSGETENVIRON && defined (PIC) -#define environ (*_NSGetEnviron()) -#endif - /* Two often used patterns diff --git a/libguile/stime.c b/libguile/stime.c index 34c8a98fa..5384783e3 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -77,10 +77,6 @@ # include #endif -#if HAVE_CRT_EXTERNS_H -#include /* for Darwin _NSGetEnviron */ -#endif - #ifndef tzname /* For SGI. */ extern char *tzname[]; /* RS6000 and others reject char **tzname. */ #endif @@ -98,15 +94,6 @@ extern char *strptime (); # define timet long #endif -extern char ** environ; - -/* On Apple Darwin in a shared library there's no "environ" to access - directly, instead the address of that variable must be obtained with - _NSGetEnviron(). */ -#if HAVE__NSGETENVIRON && defined (PIC) -#define environ (*_NSGetEnviron()) -#endif - #ifdef HAVE_TIMES static diff --git a/m4/environ.m4 b/m4/environ.m4 new file mode 100644 index 000000000..b17bb60a7 --- /dev/null +++ b/m4/environ.m4 @@ -0,0 +1,36 @@ +# environ.m4 serial 2 +dnl Copyright (C) 2001-2004, 2006-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_ENVIRON], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + dnl Persuade glibc to declare environ. + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + gt_CHECK_VAR_DECL([#include ], environ) + if test $gt_cv_var_environ_declaration != yes; then + HAVE_DECL_ENVIRON=0 + fi +]) + +# Check if a variable is properly declared. +# gt_CHECK_VAR_DECL(includes,variable) +AC_DEFUN([gt_CHECK_VAR_DECL], +[ + define([gt_cv_var], [gt_cv_var_]$2[_declaration]) + AC_MSG_CHECKING([if $2 is properly declared]) + AC_CACHE_VAL([gt_cv_var], [ + AC_TRY_COMPILE([$1 + extern struct { int foo; } $2;], + [$2.foo = 1;], + gt_cv_var=no, + gt_cv_var=yes)]) + AC_MSG_RESULT([$gt_cv_var]) + if test $gt_cv_var = yes; then + AC_DEFINE([HAVE_]translit($2, [a-z], [A-Z])[_DECL], 1, + [Define if you have the declaration of $2.]) + fi + undefine([gt_cv_var]) +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index fd6c4fe91..c7cfb83dd 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits environ extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -23,6 +23,7 @@ gl_MODULES([ alloca-opt autobuild count-one-bits + environ extensions flock fpieee diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 77100fa1b..b6d10a862 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -45,6 +45,8 @@ AC_DEFUN([gl_INIT], gl_source_base='lib' gl_FUNC_ALLOCA gl_COUNT_ONE_BITS + gl_ENVIRON + gl_UNISTD_MODULE_INDICATOR([environ]) gl_FUNC_FLOCK gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) gl_INLINE @@ -251,6 +253,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/autobuild.m4 m4/codeset.m4 m4/count-one-bits.m4 + m4/environ.m4 m4/extensions.m4 m4/flock.m4 m4/fpieee.m4 From 1351c2dba5ce54aeeae41cb2322ad39cd29510b0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 21:47:45 +0200 Subject: [PATCH 162/375] fix backtraces with compiled boot-9 * module/ice-9/boot-9.scm (default-pre-unwind-handler): Since we were tail-called by pre-unwind-handler-dispatch, we can't use pre-unwind-handler-dispatch as a narrowing argument. Instead just narrow by one frame. (pre-unwind-handler-dispatch): Deprecate. (error-catching-loop): Remove crack comment and code, and just use default-pre-unwind-handler as our pre-unwind handler. * module/ice-9/stack-catch.scm (stack-catch): * module/system/repl/repl.scm (call-with-backtrace): Use default-pre-unwind-handler directly. --- module/ice-9/boot-9.scm | 17 +++++------------ module/ice-9/stack-catch.scm | 2 +- module/system/repl/repl.scm | 2 +- 3 files changed, 7 insertions(+), 14 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index fa05de6d1..26ce1a905 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2443,11 +2443,12 @@ module '(ice-9 q) '(make-q q-length))}." (define (set-repl-prompt! v) (set! scm-repl-prompt v)) (define (default-pre-unwind-handler key . args) - (save-stack pre-unwind-handler-dispatch) + (save-stack 1) (apply throw key args)) -(define (pre-unwind-handler-dispatch key . args) - (apply default-pre-unwind-handler key args)) +(begin-deprecated + (define (pre-unwind-handler-dispatch key . args) + (apply default-pre-unwind-handler key args))) (define abort-hook (make-hook)) @@ -2524,15 +2525,7 @@ module '(ice-9 q) '(make-q q-length))}." (else (apply bad-throw key args))))))) - ;; Note that having just `pre-unwind-handler-dispatch' - ;; here is connected with the mechanism that - ;; produces a nice backtrace upon error. If, for - ;; example, this is replaced with (lambda args - ;; (apply pre-unwind-handler-dispatch args)), the stack - ;; cutting (in save-stack) goes wrong and ends up - ;; saving no stack at all, so there is no - ;; backtrace. - pre-unwind-handler-dispatch))) + default-pre-unwind-handler))) (if next (loop next) status))) (set! set-batch-mode?! (lambda (arg) diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm index 2f4b3d145..a54267617 100644 --- a/module/ice-9/stack-catch.scm +++ b/module/ice-9/stack-catch.scm @@ -40,4 +40,4 @@ this call to @code{catch}." (catch key thunk handler - pre-unwind-handler-dispatch)) + default-pre-unwind-handler)) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index ebf2b93d4..0a06e3dd0 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -89,7 +89,7 @@ (catch #t (lambda () (%start-stack #t thunk)) default-catch-handler - pre-unwind-handler-dispatch)) + default-pre-unwind-handler)) (define-macro (with-backtrace form) `(call-with-backtrace (lambda () ,form))) From 560b9c256d9cd5f80dead6ddb0d747a21c6c003a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 22:23:44 +0200 Subject: [PATCH 163/375] adjust VM copyright notices to LGPL, use SCM_INTERNAL/API properly * libguile/frames.c: * libguile/frames.h: * libguile/instructions.c: * libguile/instructions.h: * libguile/objcodes.c: * libguile/objcodes.h: * libguile/programs.c: * libguile/programs.h: * libguile/vm-bootstrap.h: * libguile/vm-engine.c: * libguile/vm-engine.h: * libguile/vm-expand.h: * libguile/vm-i-scheme.c: * libguile/vm.c: * libguile/vm.h: Update to use SCM_API and SCM_INTERNAL correctly. Adjust copyright to be the same as the copyright of Guile itself, which should be fine given that the FSF holds the whole thing. --- libguile/frames.c | 49 +++++------------- libguile/frames.h | 80 +++++++++++------------------ libguile/instructions.c | 50 ++++++------------- libguile/instructions.h | 66 ++++++++---------------- libguile/objcodes.c | 49 +++++------------- libguile/objcodes.h | 66 ++++++++---------------- libguile/programs.c | 49 +++++------------- libguile/programs.h | 86 ++++++++++++-------------------- libguile/vm-bootstrap.h | 50 +++++-------------- libguile/vm-engine.c | 48 +++++------------- libguile/vm-engine.h | 48 +++++------------- libguile/vm-expand.h | 48 +++++------------- libguile/vm-i-scheme.c | 48 +++++------------- libguile/vm.c | 49 +++++------------- libguile/vm.h | 108 ++++++++++++++++------------------------ 15 files changed, 270 insertions(+), 624 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index f53cade95..c08fd3134 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include @@ -45,6 +21,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" diff --git a/libguile/frames.h b/libguile/frames.h index 836763700..d74476ac8 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_FRAMES_H_ #define _SCM_FRAMES_H_ @@ -97,7 +73,7 @@ * Heap frames */ -extern scm_t_bits scm_tc16_vm_frame; +SCM_API scm_t_bits scm_tc16_vm_frame; struct scm_vm_frame { @@ -118,24 +94,24 @@ struct scm_vm_frame #define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) /* FIXME rename scm_byte_t */ -extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, +SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, scm_byte_t *ip, scm_t_ptrdiff offset); -extern SCM scm_vm_frame_p (SCM obj); -extern SCM scm_vm_frame_program (SCM frame); -extern SCM scm_vm_frame_arguments (SCM frame); -extern SCM scm_vm_frame_source (SCM frame); -extern SCM scm_vm_frame_local_ref (SCM frame, SCM index); -extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); -extern SCM scm_vm_frame_return_address (SCM frame); -extern SCM scm_vm_frame_mv_return_address (SCM frame); -extern SCM scm_vm_frame_dynamic_link (SCM frame); -extern SCM scm_vm_frame_external_link (SCM frame); -extern SCM scm_vm_frame_stack (SCM frame); +SCM_API SCM scm_vm_frame_p (SCM obj); +SCM_API SCM scm_vm_frame_program (SCM frame); +SCM_API SCM scm_vm_frame_arguments (SCM frame); +SCM_API SCM scm_vm_frame_source (SCM frame); +SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index); +SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); +SCM_API SCM scm_vm_frame_return_address (SCM frame); +SCM_API SCM scm_vm_frame_mv_return_address (SCM frame); +SCM_API SCM scm_vm_frame_dynamic_link (SCM frame); +SCM_API SCM scm_vm_frame_external_link (SCM frame); +SCM_API SCM scm_vm_frame_stack (SCM frame); -extern SCM scm_c_vm_frame_prev (SCM frame); +SCM_API SCM scm_c_vm_frame_prev (SCM frame); -extern void scm_bootstrap_frames (void); -extern void scm_init_frames (void); +SCM_INTERNAL void scm_bootstrap_frames (void); +SCM_INTERNAL void scm_init_frames (void); #endif /* _SCM_FRAMES_H_ */ diff --git a/libguile/instructions.c b/libguile/instructions.c index 4f504f0a2..f0f52e422 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -1,49 +1,27 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include #endif #include + +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" diff --git a/libguile/instructions.h b/libguile/instructions.h index 4968671b5..f4f45b371 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_INSTRUCTIONS_H_ #define _SCM_INSTRUCTIONS_H_ @@ -57,16 +33,16 @@ enum scm_opcode { scm_op_last = SCM_VM_NUM_INSTRUCTIONS }; -extern SCM scm_instruction_list (void); -extern SCM scm_instruction_p (SCM obj); -extern SCM scm_instruction_length (SCM inst); -extern SCM scm_instruction_pops (SCM inst); -extern SCM scm_instruction_pushes (SCM inst); -extern SCM scm_instruction_to_opcode (SCM inst); -extern SCM scm_opcode_to_instruction (SCM op); +SCM_API SCM scm_instruction_list (void); +SCM_API SCM scm_instruction_p (SCM obj); +SCM_API SCM scm_instruction_length (SCM inst); +SCM_API SCM scm_instruction_pops (SCM inst); +SCM_API SCM scm_instruction_pushes (SCM inst); +SCM_API SCM scm_instruction_to_opcode (SCM inst); +SCM_API SCM scm_opcode_to_instruction (SCM op); -extern void scm_bootstrap_instructions (void); -extern void scm_init_instructions (void); +SCM_INTERNAL void scm_bootstrap_instructions (void); +SCM_INTERNAL void scm_init_instructions (void); #endif /* _SCM_INSTRUCTIONS_H_ */ diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 8bc203dda..6a0a11b29 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include @@ -51,6 +27,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "programs.h" #include "objcodes.h" diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 222691668..acd43a600 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_OBJCODES_H_ #define _SCM_OBJCODES_H_ @@ -60,7 +36,7 @@ struct scm_objcode { #define SCM_F_OBJCODE_IS_U8VECTOR (1<<1) #define SCM_F_OBJCODE_IS_SLICE (1<<2) -extern scm_t_bits scm_tc16_objcode; +SCM_API scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x)) #define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x)) @@ -80,15 +56,15 @@ extern scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE) SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr); -extern SCM scm_load_objcode (SCM file); -extern SCM scm_objcode_p (SCM obj); -extern SCM scm_objcode_meta (SCM objcode); -extern SCM scm_bytecode_to_objcode (SCM bytecode); -extern SCM scm_objcode_to_bytecode (SCM objcode); -extern SCM scm_write_objcode (SCM objcode, SCM port); +SCM_API SCM scm_load_objcode (SCM file); +SCM_API SCM scm_objcode_p (SCM obj); +SCM_API SCM scm_objcode_meta (SCM objcode); +SCM_API SCM scm_bytecode_to_objcode (SCM bytecode); +SCM_API SCM scm_objcode_to_bytecode (SCM objcode); +SCM_API SCM scm_write_objcode (SCM objcode, SCM port); -extern void scm_bootstrap_objcodes (void); -extern void scm_init_objcodes (void); +SCM_INTERNAL void scm_bootstrap_objcodes (void); +SCM_INTERNAL void scm_init_objcodes (void); #endif /* _SCM_OBJCODES_H_ */ diff --git a/libguile/programs.c b/libguile/programs.c index 8e8982994..68e0b8541 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,49 +1,26 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include #endif #include +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" #include "modules.h" diff --git a/libguile/programs.h b/libguile/programs.h index 68a6936a2..ae819ef85 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_PROGRAMS_H_ #define _SCM_PROGRAMS_H_ @@ -51,7 +27,7 @@ typedef unsigned char scm_byte_t; -extern scm_t_bits scm_tc16_program; +SCM_API scm_t_bits scm_tc16_program; #define SCM_F_PROGRAM_IS_BOOT (1<<0) @@ -63,27 +39,27 @@ extern scm_t_bits scm_tc16_program; #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT) -extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); -extern SCM scm_program_p (SCM obj); -extern SCM scm_program_base (SCM program); -extern SCM scm_program_arity (SCM program); -extern SCM scm_program_meta (SCM program); -extern SCM scm_program_bindings (SCM program); -extern SCM scm_program_sources (SCM program); -extern SCM scm_program_source (SCM program, SCM ip); -extern SCM scm_program_properties (SCM program); -extern SCM scm_program_name (SCM program); -extern SCM scm_program_objects (SCM program); -extern SCM scm_program_module (SCM program); -extern SCM scm_program_external (SCM program); -extern SCM scm_program_external_set_x (SCM program, SCM external); -extern SCM scm_program_objcode (SCM program); +SCM_API SCM scm_program_p (SCM obj); +SCM_API SCM scm_program_base (SCM program); +SCM_API SCM scm_program_arity (SCM program); +SCM_API SCM scm_program_meta (SCM program); +SCM_API SCM scm_program_bindings (SCM program); +SCM_API SCM scm_program_sources (SCM program); +SCM_API SCM scm_program_source (SCM program, SCM ip); +SCM_API SCM scm_program_properties (SCM program); +SCM_API SCM scm_program_name (SCM program); +SCM_API SCM scm_program_objects (SCM program); +SCM_API SCM scm_program_module (SCM program); +SCM_API SCM scm_program_external (SCM program); +SCM_API SCM scm_program_external_set_x (SCM program, SCM external); +SCM_API SCM scm_program_objcode (SCM program); -extern SCM scm_c_program_source (SCM program, size_t ip); +SCM_API SCM scm_c_program_source (SCM program, size_t ip); -extern void scm_bootstrap_programs (void); -extern void scm_init_programs (void); +SCM_INTERNAL void scm_bootstrap_programs (void); +SCM_INTERNAL void scm_init_programs (void); #endif /* _SCM_PROGRAMS_H_ */ diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h index beecf0fc2..587766a67 100644 --- a/libguile/vm-bootstrap.h +++ b/libguile/vm-bootstrap.h @@ -1,48 +1,24 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library 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. + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_VM_BOOTSTRAP_H_ #define _SCM_VM_BOOTSTRAP_H_ -extern void scm_bootstrap_vm (void); +SCM_INTERNAL void scm_bootstrap_vm (void); #endif /* _SCM_VM_BOOTSTRAP_H_ */ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 45251fd70..f43f8c7fe 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ /* This file is included in vm.c multiple times */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index fbd2c6c75..8c919f630 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ /* This file is included in vm_engine.c */ diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h index 7ad2b9da8..02dfbc4d0 100644 --- a/libguile/vm-expand.h +++ b/libguile/vm-expand.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef VM_LABEL #define VM_LABEL(tag) l_##tag diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 4af60265e..38dea32b9 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ /* This file is included in vm_engine.c */ diff --git a/libguile/vm.c b/libguile/vm.c index 38d085c99..081a691ff 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include @@ -46,6 +22,7 @@ #include #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" #include "instructions.h" diff --git a/libguile/vm.h b/libguile/vm.h index 5c38f9ffa..2f2b617ce 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library 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. + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_VM_H_ #define _SCM_VM_H_ @@ -78,37 +54,37 @@ struct scm_vm { SCM trace_frame; /* a frame being traced */ }; -extern SCM scm_the_vm_fluid; +SCM_API SCM scm_the_vm_fluid; #define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x) #define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm)) #define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P) -extern SCM scm_the_vm (); -extern SCM scm_make_vm (void); -extern SCM scm_vm_apply (SCM vm, SCM program, SCM args); -extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); -extern SCM scm_vm_option_ref (SCM vm, SCM key); -extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); +SCM_API SCM scm_the_vm (); +SCM_API SCM scm_make_vm (void); +SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args); +SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); +SCM_API SCM scm_vm_option_ref (SCM vm, SCM key); +SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); -extern SCM scm_vm_version (void); -extern SCM scm_the_vm (void); -extern SCM scm_vm_p (SCM obj); -extern SCM scm_vm_ip (SCM vm); -extern SCM scm_vm_sp (SCM vm); -extern SCM scm_vm_fp (SCM vm); -extern SCM scm_vm_boot_hook (SCM vm); -extern SCM scm_vm_halt_hook (SCM vm); -extern SCM scm_vm_next_hook (SCM vm); -extern SCM scm_vm_break_hook (SCM vm); -extern SCM scm_vm_enter_hook (SCM vm); -extern SCM scm_vm_apply_hook (SCM vm); -extern SCM scm_vm_exit_hook (SCM vm); -extern SCM scm_vm_return_hook (SCM vm); -extern SCM scm_vm_option (SCM vm, SCM key); -extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); -extern SCM scm_vm_stats (SCM vm); -extern SCM scm_vm_trace_frame (SCM vm); +SCM_API SCM scm_vm_version (void); +SCM_API SCM scm_the_vm (void); +SCM_API SCM scm_vm_p (SCM obj); +SCM_API SCM scm_vm_ip (SCM vm); +SCM_API SCM scm_vm_sp (SCM vm); +SCM_API SCM scm_vm_fp (SCM vm); +SCM_API SCM scm_vm_boot_hook (SCM vm); +SCM_API SCM scm_vm_halt_hook (SCM vm); +SCM_API SCM scm_vm_next_hook (SCM vm); +SCM_API SCM scm_vm_break_hook (SCM vm); +SCM_API SCM scm_vm_enter_hook (SCM vm); +SCM_API SCM scm_vm_apply_hook (SCM vm); +SCM_API SCM scm_vm_exit_hook (SCM vm); +SCM_API SCM scm_vm_return_hook (SCM vm); +SCM_API SCM scm_vm_option (SCM vm, SCM key); +SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); +SCM_API SCM scm_vm_stats (SCM vm); +SCM_API SCM scm_vm_trace_frame (SCM vm); struct scm_vm_cont { scm_byte_t *ip; @@ -119,16 +95,16 @@ struct scm_vm_cont { scm_t_ptrdiff reloc; }; -extern scm_t_bits scm_tc16_vm_cont; +SCM_API scm_t_bits scm_tc16_vm_cont; #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) #define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT)) -extern SCM scm_vm_capture_continuations (void); -extern void scm_vm_reinstate_continuations (SCM conts); +SCM_API SCM scm_vm_capture_continuations (void); +SCM_API void scm_vm_reinstate_continuations (SCM conts); -extern SCM scm_load_compiled_with_vm (SCM file); +SCM_API SCM scm_load_compiled_with_vm (SCM file); -extern void scm_init_vm (void); +SCM_INTERNAL void scm_init_vm (void); #endif /* _SCM_VM_H_ */ From 4201062de5e4f2eb7b2207a3c09e02a12b9bda50 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 23 May 2009 17:55:58 +0100 Subject: [PATCH 164/375] Fix wait-condition-variable so that it doesn't leave asyncs blocked * libguile/threads.c (fat_mutex_unlock): Unblock asyncs when breaking out of loop. * test-suite/tests/threads.test (asyncs-still-working?): New function, to test if asyncs are working (i.e. unblocked). Use this throughout threads.test, in particular before and after the "timed locking succeeds if mutex unlocked within timeout" test. --- libguile/threads.c | 1 + test-suite/tests/threads.test | 43 +++++++++++++++++++++++++++++++++-- 2 files changed, 42 insertions(+), 2 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index bb874e230..947e59546 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1491,6 +1491,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, { if (relock) scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner); + t->block_asyncs--; break; } diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index caace7fd4..62048eaba 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -21,6 +21,20 @@ :use-module (ice-9 threads) :use-module (test-suite lib)) +(define (asyncs-still-working?) + (let ((a #f)) + (system-async-mark (lambda () + (set! a #t))) + ;; The point of the following (equal? ...) is to go through + ;; primitive code (scm_equal_p) that includes a SCM_TICK call and + ;; hence gives system asyncs a chance to run. Of course the + ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the + ;; near future we may be using the VM instead of the traditional + ;; compiler, and then we will still want asyncs-still-working? to + ;; work. (The VM should probably have SCM_TICK calls too, but + ;; let's not rely on that here.) + (equal? '(a b c) '(a b c)) + a)) (if (provided? 'threads) (begin @@ -101,6 +115,9 @@ (with-test-prefix "n-for-each-par-map" + (pass-if "asyncs are still working 2" + (asyncs-still-working?)) + (pass-if "0 in limit 10" (n-for-each-par-map 10 noop noop '()) #t) @@ -143,12 +160,18 @@ (with-test-prefix "lock-mutex" + (pass-if "asyncs are still working 3" + (asyncs-still-working?)) + (pass-if "timed locking fails if timeout exceeded" (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (lock-mutex m (+ (current-time) 1))))) (not (join-thread t))))) + (pass-if "asyncs are still working 6" + (asyncs-still-working?)) + (pass-if "timed locking succeeds if mutex unlocked within timeout" (let* ((m (make-mutex)) (c (make-condition-variable)) @@ -164,7 +187,12 @@ (unlock-mutex cm) (sleep 1) (unlock-mutex m) - (join-thread t))))) + (join-thread t)))) + + (pass-if "asyncs are still working 7" + (asyncs-still-working?)) + + ) ;; ;; timed mutex unlocking @@ -172,12 +200,18 @@ (with-test-prefix "unlock-mutex" + (pass-if "asyncs are still working 5" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #f if timeout exceeded" (let ((m (make-mutex)) (c (make-condition-variable))) (lock-mutex m) (not (unlock-mutex m c (current-time))))) + (pass-if "asyncs are still working 4" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #t if condition signaled" (let ((m1 (make-mutex)) (m2 (make-mutex)) @@ -226,7 +260,12 @@ (pass-if "timed joining succeeds if thread exits within timeout" (let ((t (begin-thread (begin (sleep 1) #t)))) - (join-thread t (+ (current-time) 2))))) + (join-thread t (+ (current-time) 2)))) + + (pass-if "asyncs are still working 1" + (asyncs-still-working?)) + + ) ;; ;; thread cancellation From 21346c4f5e30910e3950c40bc267bb4249973240 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 20 May 2009 21:55:35 +0100 Subject: [PATCH 165/375] Remove possible deadlock in scm_join_thread_timed * libguile/threads.c (scm_join_thread_timed): Recheck t->exited before looping round to call block_self again, in case thread t has now exited. * test-suite/tests/threads.test ("don't hang when joined thread terminates in SCM_TICK"): New test. --- libguile/threads.c | 10 ++++++++++ test-suite/tests/threads.test | 26 +++++++++++++++++++++++++- 2 files changed, 35 insertions(+), 1 deletion(-) diff --git a/libguile/threads.c b/libguile/threads.c index 947e59546..d63c6197e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1161,6 +1161,16 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0, scm_i_pthread_mutex_unlock (&t->admin_mutex); SCM_TICK; scm_i_scm_pthread_mutex_lock (&t->admin_mutex); + + /* Check for exit again, since we just released and + reacquired the admin mutex, before the next block_self + call (which would block forever if t has already + exited). */ + if (t->exited) + { + res = t->result; + break; + } } } diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 62048eaba..6400d2dd8 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -265,7 +265,31 @@ (pass-if "asyncs are still working 1" (asyncs-still-working?)) - ) + ;; scm_join_thread_timed has a SCM_TICK in the middle of it, + ;; to allow asyncs to run (including signal delivery). We + ;; used to have a bug whereby if the joined thread terminated + ;; at the same time as the joining thread is in this SCM_TICK, + ;; scm_join_thread_timed would not notice and would hang + ;; forever. So in this test we are setting up the following + ;; sequence of events. + ;; T=0 other thread is created and starts running + ;; T=2 main thread sets up an async that will sleep for 10 seconds + ;; T=2 main thread calls join-thread, which will... + ;; T=2 ...call the async, which starts sleeping + ;; T=5 other thread finishes its work and terminates + ;; T=7 async completes, main thread continues inside join-thread. + (pass-if "don't hang when joined thread terminates in SCM_TICK" + (let ((other-thread (make-thread sleep 5))) + (letrec ((delay-count 10) + (aproc (lambda () + (set! delay-count (- delay-count 1)) + (if (zero? delay-count) + (sleep 5) + (system-async-mark aproc))))) + (sleep 2) + (system-async-mark aproc) + (join-thread other-thread))) + #t)) ;; ;; thread cancellation From 34f3d47df9311852ba7eab6f8d1c36535c3774dd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 May 2009 14:49:33 +0200 Subject: [PATCH 166/375] add reader support for #; #` #' #, and #,@. fix bug in compile-and-load. * libguile/read.c (flush_ws, scm_read_commented_expression) (scm_read_sharp): Add support for commenting out expressions with #;. (scm_read_syntax, scm_read_sharp): Add support for #', #`, #, and #,@. * module/ice-9/boot-9.scm: Remove #' read-hash extension, which actually didn't do anything at all. It's been there since 1997, but no Guile code I've ever seen uses it, and it conflicts with #'x => (syntax x) from modern Scheme. * module/system/base/compile.scm (compile-and-load): Whoops, fix a number of bugs here. --- libguile/read.c | 83 ++++++++++++++++++++++++++++++++++ module/ice-9/boot-9.scm | 3 -- module/system/base/compile.scm | 6 +-- 3 files changed, 86 insertions(+), 6 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 47b80041e..a4db2ab41 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -182,6 +182,7 @@ static SCM *scm_read_hash_procedures; /* Read an SCSH block comment. */ static inline SCM scm_read_scsh_block_comment (int chr, SCM port); +static SCM scm_read_commented_expression (int chr, SCM port); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Return zero if the whole token fits in BUF, non-zero otherwise. */ @@ -257,6 +258,9 @@ flush_ws (SCM port, const char *eoferr) case '!': scm_read_scsh_block_comment (c, port); break; + case ';': + scm_read_commented_expression (c, port); + break; default: scm_ungetc (c, port); return '#'; @@ -691,6 +695,65 @@ scm_read_quote (int chr, SCM port) return p; } +SCM_SYMBOL (sym_syntax, "syntax"); +SCM_SYMBOL (sym_quasisyntax, "quasisyntax"); +SCM_SYMBOL (sym_unsyntax, "unsyntax"); +SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing"); + +static SCM +scm_read_syntax (int chr, SCM port) +{ + SCM p; + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 1; + + switch (chr) + { + case '`': + p = sym_quasisyntax; + break; + + case '\'': + p = sym_syntax; + break; + + case ',': + { + int c; + + c = scm_getc (port); + if ('@' == c) + p = sym_unsyntax_splicing; + else + { + scm_ungetc (c, port); + p = sym_unsyntax; + } + break; + } + + default: + fprintf (stderr, "%s: unhandled syntax character (%i)\n", + "scm_read_syntax", chr); + abort (); + } + + p = scm_cons2 (p, scm_read_expression (port), SCM_EOL); + if (SCM_RECORD_POSITIONS_P) + scm_whash_insert (scm_source_whash, p, + scm_make_srcprops (line, column, + SCM_FILENAME (port), + SCM_COPY_SOURCE_P + ? (scm_cons2 (SCM_CAR (p), + SCM_CAR (SCM_CDR (p)), + SCM_EOL)) + : SCM_UNDEFINED, + SCM_EOL)); + + + return p; +} + static inline SCM scm_read_semicolon_comment (int chr, SCM port) { @@ -853,6 +916,20 @@ scm_read_scsh_block_comment (int chr, SCM port) return SCM_UNSPECIFIED; } +static SCM +scm_read_commented_expression (int chr, SCM port) +{ + int c; + + c = flush_ws (port, (char *) NULL); + if (EOF == c) + scm_i_input_error ("read_commented_expression", port, + "no expression after #; comment", SCM_EOL); + scm_ungetc (c, port); + scm_read_expression (port); + return SCM_UNSPECIFIED; +} + static SCM scm_read_extended_symbol (int chr, SCM port) { @@ -1014,6 +1091,12 @@ scm_read_sharp (int chr, SCM port) return (scm_read_extended_symbol (chr, port)); case '!': return (scm_read_scsh_block_comment (chr, port)); + case ';': + return (scm_read_commented_expression (chr, port)); + case '`': + case '\'': + case ',': + return (scm_read_syntax (chr, port)); default: result = scm_read_sharp_extension (chr, port); if (scm_is_eq (result, SCM_UNSPECIFIED)) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 26ce1a905..44066312a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -961,9 +961,6 @@ ;;; Reader code for various "#c" forms. ;;; -(read-hash-extend #\' (lambda (c port) - (read port))) - (define read-eval? (make-fluid)) (fluid-set! read-eval? #f) (read-hash-extend #\. diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 74fb59852..f6522f735 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -107,9 +107,9 @@ port))) comp)) -(define* (compile-and-load file #:key (to 'value) (opts '())) - (read-and-compile (open-input-port file) - #:from lang #:to to #:opts opts)) +(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) + (read-and-compile (open-input-file file) + #:from from #:to to #:opts opts)) (define (compiled-file-name file) (let ((base (basename file)) From 6ed0c41a2d621c485a0b0e1b39535fd5a1e9bd20 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 May 2009 14:59:47 +0200 Subject: [PATCH 167/375] add reader tests for #; * test-suite/tests/reader.test ("#;"): Add reader tests for #;. --- test-suite/tests/reader.test | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index b068c716d..bd9ba2155 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -35,6 +35,8 @@ (cons 'read-error "end of file in string constant$")) (define exception:illegal-escape (cons 'read-error "illegal character in escape sequence: .*$")) +(define exception:missing-expression + (cons 'read-error "no expression after #;")) (define (read-string s) @@ -189,3 +191,24 @@ (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 0))))) +(with-test-prefix "#;" + (for-each + (lambda (pair) + (pass-if (car pair) + (equal? (with-input-from-string (car pair) read) (cdr pair)))) + + '(("#;foo 10". 10) + ("#;(10 20 30) foo" . foo) + ("#; (10 20 30) foo" . foo) + ("#;\n10\n20" . 20))) + + (pass-if "#;foo" + (eof-object? (with-input-from-string "#;foo" read))) + + (pass-if-exception "#;" + exception:missing-expression + (with-input-from-string "#;" read)) + (pass-if-exception "#;(" + exception:eof + (with-input-from-string "#;(" read))) + From e3c5df539640a36eb1493f581087d54a4714f337 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 May 2009 15:01:30 +0200 Subject: [PATCH 168/375] add tests for #' etc * test-suite/tests/reader.test ("#'"): Add tests for the hash-syntax reader macros. --- test-suite/tests/reader.test | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index bd9ba2155..5e95a7a31 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -212,3 +212,15 @@ exception:eof (with-input-from-string "#;(" read))) +(with-test-prefix "#'" + (for-each + (lambda (pair) + (pass-if (car pair) + (equal? (with-input-from-string (car pair) read) (cdr pair)))) + + '(("#'foo". (syntax foo)) + ("#`foo" . (quasisyntax foo)) + ("#,foo" . (unsyntax foo)) + ("#,@foo" . (unsyntax-splicing foo))))) + + From 24d56127bb0f07bcb477e2c73ccc3cac0c51ee73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 27 May 2009 16:50:40 +0200 Subject: [PATCH 169/375] Use GNU libunistring and Gnulib modules needed by R6RS bytevectors and ports. * m4/gnulib-cache.m4 (gl_MODULES): Add `byteswap', `iconv_open-utf', `libunistring', `striconveh', and `string'. --- build-aux/config.rpath | 24 +- lib/Makefile.am | 239 +++++- lib/byteswap.in.h | 44 + lib/c-ctype.c | 396 +++++++++ lib/c-ctype.h | 295 +++++++ lib/c-strcase.h | 55 ++ lib/c-strcasecmp.c | 57 ++ lib/c-strcaseeq.h | 184 +++++ lib/c-strncasecmp.c | 57 ++ lib/iconv.c | 450 +++++++++++ lib/iconv.in.h | 71 ++ lib/iconv_close.c | 47 ++ lib/iconv_open-aix.gperf | 44 + lib/iconv_open-hpux.gperf | 56 ++ lib/iconv_open-irix.gperf | 31 + lib/iconv_open-osf.gperf | 50 ++ lib/iconv_open.c | 172 ++++ lib/iconveh.h | 41 + lib/striconveh.c | 1251 +++++++++++++++++++++++++++++ lib/striconveh.h | 120 +++ lib/string.in.h | 605 ++++++++++++++ lib/unistr.h | 681 ++++++++++++++++ lib/unistr/u8-mbtouc-aux.c | 158 ++++ lib/unistr/u8-mbtouc-unsafe-aux.c | 168 ++++ lib/unistr/u8-mbtouc-unsafe.c | 179 +++++ lib/unistr/u8-mbtouc.c | 168 ++++ lib/unistr/u8-mbtoucr.c | 285 +++++++ lib/unistr/u8-prev.c | 93 +++ lib/unistr/u8-uctomb-aux.c | 69 ++ lib/unistr/u8-uctomb.c | 88 ++ lib/unitypes.h | 26 + m4/byteswap.m4 | 18 + m4/gnulib-cache.m4 | 7 +- m4/gnulib-comp.m4 | 55 ++ m4/iconv.m4 | 180 +++++ m4/iconv_h.m4 | 34 + m4/iconv_open.m4 | 237 ++++++ m4/lib-ld.m4 | 110 +++ m4/lib-link.m4 | 761 ++++++++++++++++++ m4/lib-prefix.m4 | 224 ++++++ m4/libunistring.m4 | 37 + m4/string_h.m4 | 92 +++ 42 files changed, 7947 insertions(+), 12 deletions(-) create mode 100644 lib/byteswap.in.h create mode 100644 lib/c-ctype.c create mode 100644 lib/c-ctype.h create mode 100644 lib/c-strcase.h create mode 100644 lib/c-strcasecmp.c create mode 100644 lib/c-strcaseeq.h create mode 100644 lib/c-strncasecmp.c create mode 100644 lib/iconv.c create mode 100644 lib/iconv.in.h create mode 100644 lib/iconv_close.c create mode 100644 lib/iconv_open-aix.gperf create mode 100644 lib/iconv_open-hpux.gperf create mode 100644 lib/iconv_open-irix.gperf create mode 100644 lib/iconv_open-osf.gperf create mode 100644 lib/iconv_open.c create mode 100644 lib/iconveh.h create mode 100644 lib/striconveh.c create mode 100644 lib/striconveh.h create mode 100644 lib/string.in.h create mode 100644 lib/unistr.h create mode 100644 lib/unistr/u8-mbtouc-aux.c create mode 100644 lib/unistr/u8-mbtouc-unsafe-aux.c create mode 100644 lib/unistr/u8-mbtouc-unsafe.c create mode 100644 lib/unistr/u8-mbtouc.c create mode 100644 lib/unistr/u8-mbtoucr.c create mode 100644 lib/unistr/u8-prev.c create mode 100644 lib/unistr/u8-uctomb-aux.c create mode 100644 lib/unistr/u8-uctomb.c create mode 100644 lib/unitypes.h create mode 100644 m4/byteswap.m4 create mode 100644 m4/iconv.m4 create mode 100644 m4/iconv_h.m4 create mode 100644 m4/iconv_open.m4 create mode 100644 m4/lib-ld.m4 create mode 100644 m4/lib-link.m4 create mode 100644 m4/lib-prefix.m4 create mode 100644 m4/libunistring.m4 create mode 100644 m4/string_h.m4 diff --git a/build-aux/config.rpath b/build-aux/config.rpath index 35f959b87..85c2f209b 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -47,7 +47,7 @@ for cc_temp in $CC""; do done cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'` -# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC. +# Code taken from libtool.m4's _LT_COMPILER_PIC. wl= if test "$GCC" = yes; then @@ -64,7 +64,7 @@ else ;; esac ;; - mingw* | cygwin* | pw32* | os2*) + mingw* | cygwin* | pw32* | os2* | cegcc*) ;; hpux9* | hpux10* | hpux11*) wl='-Wl,' @@ -76,7 +76,13 @@ else ;; linux* | k*bsd*-gnu) case $cc_basename in - icc* | ecc*) + ecc*) + wl='-Wl,' + ;; + icc* | ifort*) + wl='-Wl,' + ;; + lf95*) wl='-Wl,' ;; pgcc | pgf77 | pgf90) @@ -124,7 +130,7 @@ else esac fi -# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS. +# Code taken from libtool.m4's _LT_LINKER_SHLIBS. hardcode_libdir_flag_spec= hardcode_libdir_separator= @@ -132,7 +138,7 @@ hardcode_direct=no hardcode_minus_L=no case "$host_os" in - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) # FIXME: the MSVC++ port hasn't been tested in a loooong time # When not using gcc, we currently assume that we are using # Microsoft Visual C++. @@ -182,7 +188,7 @@ if test "$with_gnu_ld" = yes; then ld_shlibs=no fi ;; - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) # hardcode_libdir_flag_spec is actually meaningless, as there is # no search path for DLLs. hardcode_libdir_flag_spec='-L$libdir' @@ -326,7 +332,7 @@ else ;; bsdi[45]*) ;; - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) # When not using gcc, we currently assume that we are using # Microsoft Visual C++. # hardcode_libdir_flag_spec is actually meaningless, as there is @@ -494,7 +500,7 @@ else fi # Check dynamic linker characteristics -# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER. +# Code taken from libtool.m4's _LT_SYS_DYNAMIC_LINKER. # Unlike libtool.m4, here we don't care about _all_ names of the library, but # only about the one the linker finds when passed -lNAME. This is the last # element of library_names_spec in libtool.m4, or possibly two of them if the @@ -517,7 +523,7 @@ case "$host_os" in bsdi[45]*) library_names_spec='$libname$shrext' ;; - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) shrext=.dll library_names_spec='$libname.dll.a $libname.lib' ;; diff --git a/lib/Makefile.am b/lib/Makefile.am index f321b0b16..6f2f5c5fa 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,9 +9,9 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits environ extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string -AUTOMAKE_OPTIONS = 1.5 gnits +AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects SUBDIRS = noinst_HEADERS = @@ -54,6 +54,42 @@ EXTRA_DIST += alloca.in.h ## end gnulib module alloca-opt +## begin gnulib module byteswap + +BUILT_SOURCES += $(BYTESWAP_H) + +# We need the following in order to create when the system +# doesn't have one. +byteswap.h: byteswap.in.h + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + cat $(srcdir)/byteswap.in.h; \ + } > $@-t + mv -f $@-t $@ +MOSTLYCLEANFILES += byteswap.h byteswap.h-t + +EXTRA_DIST += byteswap.in.h + +## end gnulib module byteswap + +## begin gnulib module c-ctype + +libgnu_la_SOURCES += c-ctype.h c-ctype.c + +## end gnulib module c-ctype + +## begin gnulib module c-strcase + +libgnu_la_SOURCES += c-strcase.h c-strcasecmp.c c-strncasecmp.c + +## end gnulib module c-strcase + +## begin gnulib module c-strcaseeq + + +EXTRA_DIST += c-strcaseeq.h + +## end gnulib module c-strcaseeq + ## begin gnulib module configmake # Retrieve values of the variables through 'configure' followed by @@ -143,6 +179,72 @@ libgnu_la_SOURCES += full-write.h full-write.c ## end gnulib module full-write +## begin gnulib module gperf + +GPERF = gperf + +## end gnulib module gperf + +## begin gnulib module havelib + + +EXTRA_DIST += $(top_srcdir)/build-aux/config.rpath + +## end gnulib module havelib + +## begin gnulib module iconv_open + +BUILT_SOURCES += $(ICONV_H) + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +iconv.h: iconv.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_ICONV_H''@|$(NEXT_ICONV_H)|g' \ + -e 's|@''ICONV_CONST''@|$(ICONV_CONST)|g' \ + -e 's|@''REPLACE_ICONV''@|$(REPLACE_ICONV)|g' \ + -e 's|@''REPLACE_ICONV_OPEN''@|$(REPLACE_ICONV_OPEN)|g' \ + -e 's|@''REPLACE_ICONV_UTF''@|$(REPLACE_ICONV_UTF)|g' \ + < $(srcdir)/iconv.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += iconv.h iconv.h-t + +iconv_open-aix.h: iconv_open-aix.gperf + $(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf > $(srcdir)/iconv_open-aix.h-t + mv $(srcdir)/iconv_open-aix.h-t $(srcdir)/iconv_open-aix.h +iconv_open-hpux.h: iconv_open-hpux.gperf + $(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf > $(srcdir)/iconv_open-hpux.h-t + mv $(srcdir)/iconv_open-hpux.h-t $(srcdir)/iconv_open-hpux.h +iconv_open-irix.h: iconv_open-irix.gperf + $(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf > $(srcdir)/iconv_open-irix.h-t + mv $(srcdir)/iconv_open-irix.h-t $(srcdir)/iconv_open-irix.h +iconv_open-osf.h: iconv_open-osf.gperf + $(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t + mv $(srcdir)/iconv_open-osf.h-t $(srcdir)/iconv_open-osf.h +BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h +MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t iconv_open-irix.h-t iconv_open-osf.h-t +MAINTAINERCLEANFILES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h +EXTRA_DIST += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h + +EXTRA_DIST += iconv.in.h iconv_open-aix.gperf iconv_open-hpux.gperf iconv_open-irix.gperf iconv_open-osf.gperf iconv_open.c + +EXTRA_libgnu_la_SOURCES += iconv_open.c + +## end gnulib module iconv_open + +## begin gnulib module iconv_open-utf + + +EXTRA_DIST += iconv.c iconv_close.c + +EXTRA_libgnu_la_SOURCES += iconv.c iconv_close.c + +## end gnulib module iconv_open-utf + ## begin gnulib module lib-symbol-visibility # The value of $(CFLAG_VISIBILITY) needs to be added to the CFLAGS for the @@ -442,6 +544,95 @@ EXTRA_libgnu_la_SOURCES += strftime.c ## end gnulib module strftime +## begin gnulib module striconveh + +libgnu_la_SOURCES += striconveh.h striconveh.c +if GL_COND_LIBTOOL +libgnu_la_LDFLAGS += $(LTLIBICONV) +endif + +EXTRA_DIST += iconveh.h + +## end gnulib module striconveh + +## begin gnulib module string + +BUILT_SOURCES += string.h + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +string.h: string.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_STRING_H''@|$(NEXT_STRING_H)|g' \ + -e 's|@''GNULIB_MBSLEN''@|$(GNULIB_MBSLEN)|g' \ + -e 's|@''GNULIB_MBSNLEN''@|$(GNULIB_MBSNLEN)|g' \ + -e 's|@''GNULIB_MBSCHR''@|$(GNULIB_MBSCHR)|g' \ + -e 's|@''GNULIB_MBSRCHR''@|$(GNULIB_MBSRCHR)|g' \ + -e 's|@''GNULIB_MBSSTR''@|$(GNULIB_MBSSTR)|g' \ + -e 's|@''GNULIB_MBSCASECMP''@|$(GNULIB_MBSCASECMP)|g' \ + -e 's|@''GNULIB_MBSNCASECMP''@|$(GNULIB_MBSNCASECMP)|g' \ + -e 's|@''GNULIB_MBSPCASECMP''@|$(GNULIB_MBSPCASECMP)|g' \ + -e 's|@''GNULIB_MBSCASESTR''@|$(GNULIB_MBSCASESTR)|g' \ + -e 's|@''GNULIB_MBSCSPN''@|$(GNULIB_MBSCSPN)|g' \ + -e 's|@''GNULIB_MBSPBRK''@|$(GNULIB_MBSPBRK)|g' \ + -e 's|@''GNULIB_MBSSPN''@|$(GNULIB_MBSSPN)|g' \ + -e 's|@''GNULIB_MBSSEP''@|$(GNULIB_MBSSEP)|g' \ + -e 's|@''GNULIB_MBSTOK_R''@|$(GNULIB_MBSTOK_R)|g' \ + -e 's|@''GNULIB_MEMMEM''@|$(GNULIB_MEMMEM)|g' \ + -e 's|@''GNULIB_MEMPCPY''@|$(GNULIB_MEMPCPY)|g' \ + -e 's|@''GNULIB_MEMRCHR''@|$(GNULIB_MEMRCHR)|g' \ + -e 's|@''GNULIB_RAWMEMCHR''@|$(GNULIB_RAWMEMCHR)|g' \ + -e 's|@''GNULIB_STPCPY''@|$(GNULIB_STPCPY)|g' \ + -e 's|@''GNULIB_STPNCPY''@|$(GNULIB_STPNCPY)|g' \ + -e 's|@''GNULIB_STRCHRNUL''@|$(GNULIB_STRCHRNUL)|g' \ + -e 's|@''GNULIB_STRDUP''@|$(GNULIB_STRDUP)|g' \ + -e 's|@''GNULIB_STRNDUP''@|$(GNULIB_STRNDUP)|g' \ + -e 's|@''GNULIB_STRNLEN''@|$(GNULIB_STRNLEN)|g' \ + -e 's|@''GNULIB_STRPBRK''@|$(GNULIB_STRPBRK)|g' \ + -e 's|@''GNULIB_STRSEP''@|$(GNULIB_STRSEP)|g' \ + -e 's|@''GNULIB_STRSTR''@|$(GNULIB_STRSTR)|g' \ + -e 's|@''GNULIB_STRCASESTR''@|$(GNULIB_STRCASESTR)|g' \ + -e 's|@''GNULIB_STRTOK_R''@|$(GNULIB_STRTOK_R)|g' \ + -e 's|@''GNULIB_STRERROR''@|$(GNULIB_STRERROR)|g' \ + -e 's|@''GNULIB_STRSIGNAL''@|$(GNULIB_STRSIGNAL)|g' \ + -e 's|@''GNULIB_STRVERSCMP''@|$(GNULIB_STRVERSCMP)|g' \ + -e 's|@''HAVE_DECL_MEMMEM''@|$(HAVE_DECL_MEMMEM)|g' \ + -e 's|@''HAVE_MEMPCPY''@|$(HAVE_MEMPCPY)|g' \ + -e 's|@''HAVE_DECL_MEMRCHR''@|$(HAVE_DECL_MEMRCHR)|g' \ + -e 's|@''HAVE_RAWMEMCHR''@|$(HAVE_RAWMEMCHR)|g' \ + -e 's|@''HAVE_STPCPY''@|$(HAVE_STPCPY)|g' \ + -e 's|@''HAVE_STPNCPY''@|$(HAVE_STPNCPY)|g' \ + -e 's|@''HAVE_STRCHRNUL''@|$(HAVE_STRCHRNUL)|g' \ + -e 's|@''HAVE_DECL_STRDUP''@|$(HAVE_DECL_STRDUP)|g' \ + -e 's|@''HAVE_STRNDUP''@|$(HAVE_STRNDUP)|g' \ + -e 's|@''HAVE_DECL_STRNDUP''@|$(HAVE_DECL_STRNDUP)|g' \ + -e 's|@''HAVE_DECL_STRNLEN''@|$(HAVE_DECL_STRNLEN)|g' \ + -e 's|@''HAVE_STRPBRK''@|$(HAVE_STRPBRK)|g' \ + -e 's|@''HAVE_STRSEP''@|$(HAVE_STRSEP)|g' \ + -e 's|@''HAVE_STRCASESTR''@|$(HAVE_STRCASESTR)|g' \ + -e 's|@''HAVE_DECL_STRTOK_R''@|$(HAVE_DECL_STRTOK_R)|g' \ + -e 's|@''HAVE_DECL_STRERROR''@|$(HAVE_DECL_STRERROR)|g' \ + -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \ + -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \ + -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ + -e 's|@''REPLACE_STRCASESTR''@|$(REPLACE_STRCASESTR)|g' \ + -e 's|@''REPLACE_STRDUP''@|$(REPLACE_STRDUP)|g' \ + -e 's|@''REPLACE_STRSTR''@|$(REPLACE_STRSTR)|g' \ + -e 's|@''REPLACE_STRERROR''@|$(REPLACE_STRERROR)|g' \ + -e 's|@''REPLACE_STRSIGNAL''@|$(REPLACE_STRSIGNAL)|g' \ + -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \ + < $(srcdir)/string.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += string.h string.h-t + +EXTRA_DIST += string.in.h + +## end gnulib module string + ## begin gnulib module strings BUILT_SOURCES += strings.h @@ -598,6 +789,50 @@ EXTRA_DIST += unistd.in.h ## end gnulib module unistd +## begin gnulib module unistr/base + + +EXTRA_DIST += unistr.h + +## end gnulib module unistr/base + +## begin gnulib module unistr/u8-mbtouc + +libgnu_la_SOURCES += unistr/u8-mbtouc.c unistr/u8-mbtouc-aux.c + +## end gnulib module unistr/u8-mbtouc + +## begin gnulib module unistr/u8-mbtouc-unsafe + +libgnu_la_SOURCES += unistr/u8-mbtouc-unsafe.c unistr/u8-mbtouc-unsafe-aux.c + +## end gnulib module unistr/u8-mbtouc-unsafe + +## begin gnulib module unistr/u8-mbtoucr + +libgnu_la_SOURCES += unistr/u8-mbtoucr.c + +## end gnulib module unistr/u8-mbtoucr + +## begin gnulib module unistr/u8-prev + +libgnu_la_SOURCES += unistr/u8-prev.c + +## end gnulib module unistr/u8-prev + +## begin gnulib module unistr/u8-uctomb + +libgnu_la_SOURCES += unistr/u8-uctomb.c unistr/u8-uctomb-aux.c + +## end gnulib module unistr/u8-uctomb + +## begin gnulib module unitypes + + +EXTRA_DIST += unitypes.h + +## end gnulib module unitypes + ## begin gnulib module verify libgnu_la_SOURCES += verify.h diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h new file mode 100644 index 000000000..f03463db6 --- /dev/null +++ b/lib/byteswap.in.h @@ -0,0 +1,44 @@ +/* byteswap.h - Byte swapping + Copyright (C) 2005, 2007 Free Software Foundation, Inc. + Written by Oskar Liljeblad , 2005. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef _GL_BYTESWAP_H +#define _GL_BYTESWAP_H + +/* Given an unsigned 16-bit argument X, return the value corresponding to + X with reversed byte order. */ +#define bswap_16(x) ((((x) & 0x00FF) << 8) | \ + (((x) & 0xFF00) >> 8)) + +/* Given an unsigned 32-bit argument X, return the value corresponding to + X with reversed byte order. */ +#define bswap_32(x) ((((x) & 0x000000FF) << 24) | \ + (((x) & 0x0000FF00) << 8) | \ + (((x) & 0x00FF0000) >> 8) | \ + (((x) & 0xFF000000) >> 24)) + +/* Given an unsigned 64-bit argument X, return the value corresponding to + X with reversed byte order. */ +#define bswap_64(x) ((((x) & 0x00000000000000FFULL) << 56) | \ + (((x) & 0x000000000000FF00ULL) << 40) | \ + (((x) & 0x0000000000FF0000ULL) << 24) | \ + (((x) & 0x00000000FF000000ULL) << 8) | \ + (((x) & 0x000000FF00000000ULL) >> 8) | \ + (((x) & 0x0000FF0000000000ULL) >> 24) | \ + (((x) & 0x00FF000000000000ULL) >> 40) | \ + (((x) & 0xFF00000000000000ULL) >> 56)) + +#endif /* _GL_BYTESWAP_H */ diff --git a/lib/c-ctype.c b/lib/c-ctype.c new file mode 100644 index 000000000..e36a51340 --- /dev/null +++ b/lib/c-ctype.c @@ -0,0 +1,396 @@ +/* Character handling in C locale. + + Copyright 2000-2003, 2006 Free Software Foundation, Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with this program; if not, write to the Free Software Foundation, +Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#define NO_C_CTYPE_MACROS +#include "c-ctype.h" + +/* The function isascii is not locale dependent. Its use in EBCDIC is + questionable. */ +bool +c_isascii (int c) +{ + return (c >= 0x00 && c <= 0x7f); +} + +bool +c_isalnum (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z')); +#else + return ((c >= '0' && c <= '9') + || (c >= 'A' && c <= 'Z') + || (c >= 'a' && c <= 'z')); +#endif +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isalpha (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'); +#else + return ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')); +#endif +#else + switch (c) + { + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isblank (int c) +{ + return (c == ' ' || c == '\t'); +} + +bool +c_iscntrl (int c) +{ +#if C_CTYPE_ASCII + return ((c & ~0x1f) == 0 || c == 0x7f); +#else + switch (c) + { + case ' ': case '!': case '"': case '#': case '$': case '%': + case '&': case '\'': case '(': case ')': case '*': case '+': + case ',': case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 0; + default: + return 1; + } +#endif +} + +bool +c_isdigit (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS + return (c >= '0' && c <= '9'); +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + return 1; + default: + return 0; + } +#endif +} + +bool +c_islower (int c) +{ +#if C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'a' && c <= 'z'); +#else + switch (c) + { + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isgraph (int c) +{ +#if C_CTYPE_ASCII + return (c >= '!' && c <= '~'); +#else + switch (c) + { + case '!': case '"': case '#': case '$': case '%': case '&': + case '\'': case '(': case ')': case '*': case '+': case ',': + case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isprint (int c) +{ +#if C_CTYPE_ASCII + return (c >= ' ' && c <= '~'); +#else + switch (c) + { + case ' ': case '!': case '"': case '#': case '$': case '%': + case '&': case '\'': case '(': case ')': case '*': case '+': + case ',': case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_ispunct (int c) +{ +#if C_CTYPE_ASCII + return ((c >= '!' && c <= '~') + && !((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'))); +#else + switch (c) + { + case '!': case '"': case '#': case '$': case '%': case '&': + case '\'': case '(': case ')': case '*': case '+': case ',': + case '-': case '.': case '/': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case '[': case '\\': case ']': case '^': case '_': case '`': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isspace (int c) +{ + return (c == ' ' || c == '\t' + || c == '\n' || c == '\v' || c == '\f' || c == '\r'); +} + +bool +c_isupper (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE + return (c >= 'A' && c <= 'Z'); +#else + switch (c) + { + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isxdigit (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'F')); +#else + return ((c >= '0' && c <= '9') + || (c >= 'A' && c <= 'F') + || (c >= 'a' && c <= 'f')); +#endif +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + return 1; + default: + return 0; + } +#endif +} + +int +c_tolower (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c); +#else + switch (c) + { + case 'A': return 'a'; + case 'B': return 'b'; + case 'C': return 'c'; + case 'D': return 'd'; + case 'E': return 'e'; + case 'F': return 'f'; + case 'G': return 'g'; + case 'H': return 'h'; + case 'I': return 'i'; + case 'J': return 'j'; + case 'K': return 'k'; + case 'L': return 'l'; + case 'M': return 'm'; + case 'N': return 'n'; + case 'O': return 'o'; + case 'P': return 'p'; + case 'Q': return 'q'; + case 'R': return 'r'; + case 'S': return 's'; + case 'T': return 't'; + case 'U': return 'u'; + case 'V': return 'v'; + case 'W': return 'w'; + case 'X': return 'x'; + case 'Y': return 'y'; + case 'Z': return 'z'; + default: return c; + } +#endif +} + +int +c_toupper (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c); +#else + switch (c) + { + case 'a': return 'A'; + case 'b': return 'B'; + case 'c': return 'C'; + case 'd': return 'D'; + case 'e': return 'E'; + case 'f': return 'F'; + case 'g': return 'G'; + case 'h': return 'H'; + case 'i': return 'I'; + case 'j': return 'J'; + case 'k': return 'K'; + case 'l': return 'L'; + case 'm': return 'M'; + case 'n': return 'N'; + case 'o': return 'O'; + case 'p': return 'P'; + case 'q': return 'Q'; + case 'r': return 'R'; + case 's': return 'S'; + case 't': return 'T'; + case 'u': return 'U'; + case 'v': return 'V'; + case 'w': return 'W'; + case 'x': return 'X'; + case 'y': return 'Y'; + case 'z': return 'Z'; + default: return c; + } +#endif +} diff --git a/lib/c-ctype.h b/lib/c-ctype.h new file mode 100644 index 000000000..d7b067e83 --- /dev/null +++ b/lib/c-ctype.h @@ -0,0 +1,295 @@ +/* Character handling in C locale. + + These functions work like the corresponding functions in , + except that they have the C (POSIX) locale hardwired, whereas the + functions' behaviour depends on the current locale set via + setlocale. + + Copyright (C) 2000-2003, 2006, 2008 Free Software Foundation, Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with this program; if not, write to the Free Software Foundation, +Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef C_CTYPE_H +#define C_CTYPE_H + +#include + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* The functions defined in this file assume the "C" locale and a character + set without diacritics (ASCII-US or EBCDIC-US or something like that). + Even if the "C" locale on a particular system is an extension of the ASCII + character set (like on BeOS, where it is UTF-8, or on AmigaOS, where it + is ISO-8859-1), the functions in this file recognize only the ASCII + characters. */ + + +/* Check whether the ASCII optimizations apply. */ + +/* ANSI C89 (and ISO C99 5.2.1.3 too) already guarantees that + '0', '1', ..., '9' have consecutive integer values. */ +#define C_CTYPE_CONSECUTIVE_DIGITS 1 + +#if ('A' <= 'Z') \ + && ('A' + 1 == 'B') && ('B' + 1 == 'C') && ('C' + 1 == 'D') \ + && ('D' + 1 == 'E') && ('E' + 1 == 'F') && ('F' + 1 == 'G') \ + && ('G' + 1 == 'H') && ('H' + 1 == 'I') && ('I' + 1 == 'J') \ + && ('J' + 1 == 'K') && ('K' + 1 == 'L') && ('L' + 1 == 'M') \ + && ('M' + 1 == 'N') && ('N' + 1 == 'O') && ('O' + 1 == 'P') \ + && ('P' + 1 == 'Q') && ('Q' + 1 == 'R') && ('R' + 1 == 'S') \ + && ('S' + 1 == 'T') && ('T' + 1 == 'U') && ('U' + 1 == 'V') \ + && ('V' + 1 == 'W') && ('W' + 1 == 'X') && ('X' + 1 == 'Y') \ + && ('Y' + 1 == 'Z') +#define C_CTYPE_CONSECUTIVE_UPPERCASE 1 +#endif + +#if ('a' <= 'z') \ + && ('a' + 1 == 'b') && ('b' + 1 == 'c') && ('c' + 1 == 'd') \ + && ('d' + 1 == 'e') && ('e' + 1 == 'f') && ('f' + 1 == 'g') \ + && ('g' + 1 == 'h') && ('h' + 1 == 'i') && ('i' + 1 == 'j') \ + && ('j' + 1 == 'k') && ('k' + 1 == 'l') && ('l' + 1 == 'm') \ + && ('m' + 1 == 'n') && ('n' + 1 == 'o') && ('o' + 1 == 'p') \ + && ('p' + 1 == 'q') && ('q' + 1 == 'r') && ('r' + 1 == 's') \ + && ('s' + 1 == 't') && ('t' + 1 == 'u') && ('u' + 1 == 'v') \ + && ('v' + 1 == 'w') && ('w' + 1 == 'x') && ('x' + 1 == 'y') \ + && ('y' + 1 == 'z') +#define C_CTYPE_CONSECUTIVE_LOWERCASE 1 +#endif + +#if (' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ + && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ + && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ + && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \ + && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \ + && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \ + && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \ + && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \ + && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \ + && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \ + && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \ + && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \ + && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \ + && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \ + && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \ + && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \ + && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \ + && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \ + && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \ + && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \ + && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \ + && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \ + && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126) +/* The character set is ASCII or one of its variants or extensions, not EBCDIC. + Testing the value of '\n' and '\r' is not relevant. */ +#define C_CTYPE_ASCII 1 +#endif + + +/* Function declarations. */ + +/* Unlike the functions in , which require an argument in the range + of the 'unsigned char' type, the functions here operate on values that are + in the 'unsigned char' range or in the 'char' range. In other words, + when you have a 'char' value, you need to cast it before using it as + argument to a function: + + const char *s = ...; + if (isalpha ((unsigned char) *s)) ... + + but you don't need to cast it for the functions defined in this file: + + const char *s = ...; + if (c_isalpha (*s)) ... + */ + +extern bool c_isascii (int c); /* not locale dependent */ + +extern bool c_isalnum (int c); +extern bool c_isalpha (int c); +extern bool c_isblank (int c); +extern bool c_iscntrl (int c); +extern bool c_isdigit (int c); +extern bool c_islower (int c); +extern bool c_isgraph (int c); +extern bool c_isprint (int c); +extern bool c_ispunct (int c); +extern bool c_isspace (int c); +extern bool c_isupper (int c); +extern bool c_isxdigit (int c); + +extern int c_tolower (int c); +extern int c_toupper (int c); + + +#if defined __GNUC__ && defined __OPTIMIZE__ && !defined __OPTIMIZE_SIZE__ && !defined NO_C_CTYPE_MACROS + +/* ASCII optimizations. */ + +#undef c_isascii +#define c_isascii(c) \ + ({ int __c = (c); \ + (__c >= 0x00 && __c <= 0x7f); \ + }) + +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII +#undef c_isalnum +#define c_isalnum(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z')); \ + }) +#else +#undef c_isalnum +#define c_isalnum(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || (__c >= 'A' && __c <= 'Z') \ + || (__c >= 'a' && __c <= 'z')); \ + }) +#endif +#endif + +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII +#undef c_isalpha +#define c_isalpha(c) \ + ({ int __c = (c); \ + ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z'); \ + }) +#else +#undef c_isalpha +#define c_isalpha(c) \ + ({ int __c = (c); \ + ((__c >= 'A' && __c <= 'Z') || (__c >= 'a' && __c <= 'z')); \ + }) +#endif +#endif + +#undef c_isblank +#define c_isblank(c) \ + ({ int __c = (c); \ + (__c == ' ' || __c == '\t'); \ + }) + +#if C_CTYPE_ASCII +#undef c_iscntrl +#define c_iscntrl(c) \ + ({ int __c = (c); \ + ((__c & ~0x1f) == 0 || __c == 0x7f); \ + }) +#endif + +#if C_CTYPE_CONSECUTIVE_DIGITS +#undef c_isdigit +#define c_isdigit(c) \ + ({ int __c = (c); \ + (__c >= '0' && __c <= '9'); \ + }) +#endif + +#if C_CTYPE_CONSECUTIVE_LOWERCASE +#undef c_islower +#define c_islower(c) \ + ({ int __c = (c); \ + (__c >= 'a' && __c <= 'z'); \ + }) +#endif + +#if C_CTYPE_ASCII +#undef c_isgraph +#define c_isgraph(c) \ + ({ int __c = (c); \ + (__c >= '!' && __c <= '~'); \ + }) +#endif + +#if C_CTYPE_ASCII +#undef c_isprint +#define c_isprint(c) \ + ({ int __c = (c); \ + (__c >= ' ' && __c <= '~'); \ + }) +#endif + +#if C_CTYPE_ASCII +#undef c_ispunct +#define c_ispunct(c) \ + ({ int _c = (c); \ + (c_isgraph (_c) && ! c_isalnum (_c)); \ + }) +#endif + +#undef c_isspace +#define c_isspace(c) \ + ({ int __c = (c); \ + (__c == ' ' || __c == '\t' \ + || __c == '\n' || __c == '\v' || __c == '\f' || __c == '\r'); \ + }) + +#if C_CTYPE_CONSECUTIVE_UPPERCASE +#undef c_isupper +#define c_isupper(c) \ + ({ int __c = (c); \ + (__c >= 'A' && __c <= 'Z'); \ + }) +#endif + +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII +#undef c_isxdigit +#define c_isxdigit(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'F')); \ + }) +#else +#undef c_isxdigit +#define c_isxdigit(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || (__c >= 'A' && __c <= 'F') \ + || (__c >= 'a' && __c <= 'f')); \ + }) +#endif +#endif + +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#undef c_tolower +#define c_tolower(c) \ + ({ int __c = (c); \ + (__c >= 'A' && __c <= 'Z' ? __c - 'A' + 'a' : __c); \ + }) +#undef c_toupper +#define c_toupper(c) \ + ({ int __c = (c); \ + (__c >= 'a' && __c <= 'z' ? __c - 'a' + 'A' : __c); \ + }) +#endif + +#endif /* optimizing for speed */ + + +#ifdef __cplusplus +} +#endif + +#endif /* C_CTYPE_H */ diff --git a/lib/c-strcase.h b/lib/c-strcase.h new file mode 100644 index 000000000..714a3c623 --- /dev/null +++ b/lib/c-strcase.h @@ -0,0 +1,55 @@ +/* Case-insensitive string comparison functions in C locale. + Copyright (C) 1995-1996, 2001, 2003, 2005 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef C_STRCASE_H +#define C_STRCASE_H + +#include + + +/* The functions defined in this file assume the "C" locale and a character + set without diacritics (ASCII-US or EBCDIC-US or something like that). + Even if the "C" locale on a particular system is an extension of the ASCII + character set (like on BeOS, where it is UTF-8, or on AmigaOS, where it + is ISO-8859-1), the functions in this file recognize only the ASCII + characters. More precisely, one of the string arguments must be an ASCII + string; the other one can also contain non-ASCII characters (but then + the comparison result will be nonzero). */ + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Compare strings S1 and S2, ignoring case, returning less than, equal to or + greater than zero if S1 is lexicographically less than, equal to or greater + than S2. */ +extern int c_strcasecmp (const char *s1, const char *s2); + +/* Compare no more than N characters of strings S1 and S2, ignoring case, + returning less than, equal to or greater than zero if S1 is + lexicographically less than, equal to or greater than S2. */ +extern int c_strncasecmp (const char *s1, const char *s2, size_t n); + + +#ifdef __cplusplus +} +#endif + + +#endif /* C_STRCASE_H */ diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c new file mode 100644 index 000000000..a52389883 --- /dev/null +++ b/lib/c-strcasecmp.c @@ -0,0 +1,57 @@ +/* c-strcasecmp.c -- case insensitive string comparator in C locale + Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include "c-strcase.h" + +#include + +#include "c-ctype.h" + +int +c_strcasecmp (const char *s1, const char *s2) +{ + register const unsigned char *p1 = (const unsigned char *) s1; + register const unsigned char *p2 = (const unsigned char *) s2; + unsigned char c1, c2; + + if (p1 == p2) + return 0; + + do + { + c1 = c_tolower (*p1); + c2 = c_tolower (*p2); + + if (c1 == '\0') + break; + + ++p1; + ++p2; + } + while (c1 == c2); + + if (UCHAR_MAX <= INT_MAX) + return c1 - c2; + else + /* On machines where 'char' and 'int' are types of the same size, the + difference of two 'unsigned char' values - including the sign bit - + doesn't fit in an 'int'. */ + return (c1 > c2 ? 1 : c1 < c2 ? -1 : 0); +} diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h new file mode 100644 index 000000000..cd29b66c7 --- /dev/null +++ b/lib/c-strcaseeq.h @@ -0,0 +1,184 @@ +/* Optimized case-insensitive string comparison in C locale. + Copyright (C) 2001-2002, 2007 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Written by Bruno Haible . */ + +#include "c-strcase.h" +#include "c-ctype.h" + +/* STRCASEEQ allows to optimize string comparison with a small literal string. + STRCASEEQ (s, "UTF-8", 'U','T','F','-','8',0,0,0,0) + is semantically equivalent to + c_strcasecmp (s, "UTF-8") == 0 + just faster. */ + +/* Help GCC to generate good code for string comparisons with + immediate strings. */ +#if defined (__GNUC__) && defined (__OPTIMIZE__) + +/* Case insensitive comparison of ASCII characters. */ +# if C_CTYPE_ASCII +# define CASEEQ(other,upper) \ + (c_isupper (upper) ? ((other) & ~0x20) == (upper) : (other) == (upper)) +# elif C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +# define CASEEQ(other,upper) \ + (c_isupper (upper) ? (other) == (upper) || (other) == (upper) - 'A' + 'a' : (other) == (upper)) +# else +# define CASEEQ(other,upper) \ + (c_toupper (other) == (upper)) +# endif + +static inline int +strcaseeq9 (const char *s1, const char *s2) +{ + return c_strcasecmp (s1 + 9, s2 + 9) == 0; +} + +static inline int +strcaseeq8 (const char *s1, const char *s2, char s28) +{ + if (CASEEQ (s1[8], s28)) + { + if (s28 == 0) + return 1; + else + return strcaseeq9 (s1, s2); + } + else + return 0; +} + +static inline int +strcaseeq7 (const char *s1, const char *s2, char s27, char s28) +{ + if (CASEEQ (s1[7], s27)) + { + if (s27 == 0) + return 1; + else + return strcaseeq8 (s1, s2, s28); + } + else + return 0; +} + +static inline int +strcaseeq6 (const char *s1, const char *s2, char s26, char s27, char s28) +{ + if (CASEEQ (s1[6], s26)) + { + if (s26 == 0) + return 1; + else + return strcaseeq7 (s1, s2, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq5 (const char *s1, const char *s2, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[5], s25)) + { + if (s25 == 0) + return 1; + else + return strcaseeq6 (s1, s2, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq4 (const char *s1, const char *s2, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[4], s24)) + { + if (s24 == 0) + return 1; + else + return strcaseeq5 (s1, s2, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq3 (const char *s1, const char *s2, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[3], s23)) + { + if (s23 == 0) + return 1; + else + return strcaseeq4 (s1, s2, s24, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq2 (const char *s1, const char *s2, char s22, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[2], s22)) + { + if (s22 == 0) + return 1; + else + return strcaseeq3 (s1, s2, s23, s24, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq1 (const char *s1, const char *s2, char s21, char s22, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[1], s21)) + { + if (s21 == 0) + return 1; + else + return strcaseeq2 (s1, s2, s22, s23, s24, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq0 (const char *s1, const char *s2, char s20, char s21, char s22, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[0], s20)) + { + if (s20 == 0) + return 1; + else + return strcaseeq1 (s1, s2, s21, s22, s23, s24, s25, s26, s27, s28); + } + else + return 0; +} + +#define STRCASEEQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \ + strcaseeq0 (s1, s2, s20, s21, s22, s23, s24, s25, s26, s27, s28) + +#else + +#define STRCASEEQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \ + (c_strcasecmp (s1, s2) == 0) + +#endif diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c new file mode 100644 index 000000000..c1496ca41 --- /dev/null +++ b/lib/c-strncasecmp.c @@ -0,0 +1,57 @@ +/* c-strncasecmp.c -- case insensitive string comparator in C locale + Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include "c-strcase.h" + +#include + +#include "c-ctype.h" + +int +c_strncasecmp (const char *s1, const char *s2, size_t n) +{ + register const unsigned char *p1 = (const unsigned char *) s1; + register const unsigned char *p2 = (const unsigned char *) s2; + unsigned char c1, c2; + + if (p1 == p2 || n == 0) + return 0; + + do + { + c1 = c_tolower (*p1); + c2 = c_tolower (*p2); + + if (--n == 0 || c1 == '\0') + break; + + ++p1; + ++p2; + } + while (c1 == c2); + + if (UCHAR_MAX <= INT_MAX) + return c1 - c2; + else + /* On machines where 'char' and 'int' are types of the same size, the + difference of two 'unsigned char' values - including the sign bit - + doesn't fit in an 'int'. */ + return (c1 > c2 ? 1 : c1 < c2 ? -1 : 0); +} diff --git a/lib/iconv.c b/lib/iconv.c new file mode 100644 index 000000000..56a84c456 --- /dev/null +++ b/lib/iconv.c @@ -0,0 +1,450 @@ +/* Character set conversion. + Copyright (C) 1999-2001, 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include + +#include + +#if REPLACE_ICONV_UTF +# include +# include +# include +# include "unistr.h" +# ifndef uintptr_t +# define uintptr_t unsigned long +# endif +#endif + +#if REPLACE_ICONV_UTF + +/* UTF-{16,32}{BE,LE} converters taken from GNU libiconv 1.11. */ + +/* Return code if invalid. (xxx_mbtowc) */ +# define RET_ILSEQ -1 +/* Return code if no bytes were read. (xxx_mbtowc) */ +# define RET_TOOFEW -2 + +/* Return code if invalid. (xxx_wctomb) */ +# define RET_ILUNI -1 +/* Return code if output buffer is too small. (xxx_wctomb, xxx_reset) */ +# define RET_TOOSMALL -2 + +/* + * UTF-16BE + */ + +/* Specification: RFC 2781 */ + +static int +utf16be_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 2) + { + ucs4_t wc = (s[0] << 8) + s[1]; + if (wc >= 0xd800 && wc < 0xdc00) + { + if (n >= 4) + { + ucs4_t wc2 = (s[2] << 8) + s[3]; + if (!(wc2 >= 0xdc00 && wc2 < 0xe000)) + return RET_ILSEQ; + *pwc = 0x10000 + ((wc - 0xd800) << 10) + (wc2 - 0xdc00); + return 4; + } + } + else if (wc >= 0xdc00 && wc < 0xe000) + { + return RET_ILSEQ; + } + else + { + *pwc = wc; + return 2; + } + } + return RET_TOOFEW; +} + +static int +utf16be_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (!(wc >= 0xd800 && wc < 0xe000)) + { + if (wc < 0x10000) + { + if (n >= 2) + { + r[0] = (unsigned char) (wc >> 8); + r[1] = (unsigned char) wc; + return 2; + } + else + return RET_TOOSMALL; + } + else if (wc < 0x110000) + { + if (n >= 4) + { + ucs4_t wc1 = 0xd800 + ((wc - 0x10000) >> 10); + ucs4_t wc2 = 0xdc00 + ((wc - 0x10000) & 0x3ff); + r[0] = (unsigned char) (wc1 >> 8); + r[1] = (unsigned char) wc1; + r[2] = (unsigned char) (wc2 >> 8); + r[3] = (unsigned char) wc2; + return 4; + } + else + return RET_TOOSMALL; + } + } + return RET_ILUNI; +} + +/* + * UTF-16LE + */ + +/* Specification: RFC 2781 */ + +static int +utf16le_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 2) + { + ucs4_t wc = s[0] + (s[1] << 8); + if (wc >= 0xd800 && wc < 0xdc00) + { + if (n >= 4) + { + ucs4_t wc2 = s[2] + (s[3] << 8); + if (!(wc2 >= 0xdc00 && wc2 < 0xe000)) + return RET_ILSEQ; + *pwc = 0x10000 + ((wc - 0xd800) << 10) + (wc2 - 0xdc00); + return 4; + } + } + else if (wc >= 0xdc00 && wc < 0xe000) + { + return RET_ILSEQ; + } + else + { + *pwc = wc; + return 2; + } + } + return RET_TOOFEW; +} + +static int +utf16le_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (!(wc >= 0xd800 && wc < 0xe000)) + { + if (wc < 0x10000) + { + if (n >= 2) + { + r[0] = (unsigned char) wc; + r[1] = (unsigned char) (wc >> 8); + return 2; + } + else + return RET_TOOSMALL; + } + else if (wc < 0x110000) + { + if (n >= 4) + { + ucs4_t wc1 = 0xd800 + ((wc - 0x10000) >> 10); + ucs4_t wc2 = 0xdc00 + ((wc - 0x10000) & 0x3ff); + r[0] = (unsigned char) wc1; + r[1] = (unsigned char) (wc1 >> 8); + r[2] = (unsigned char) wc2; + r[3] = (unsigned char) (wc2 >> 8); + return 4; + } + else + return RET_TOOSMALL; + } + } + return RET_ILUNI; +} + +/* + * UTF-32BE + */ + +/* Specification: Unicode 3.1 Standard Annex #19 */ + +static int +utf32be_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 4) + { + ucs4_t wc = (s[0] << 24) + (s[1] << 16) + (s[2] << 8) + s[3]; + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + *pwc = wc; + return 4; + } + else + return RET_ILSEQ; + } + return RET_TOOFEW; +} + +static int +utf32be_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + if (n >= 4) + { + r[0] = 0; + r[1] = (unsigned char) (wc >> 16); + r[2] = (unsigned char) (wc >> 8); + r[3] = (unsigned char) wc; + return 4; + } + else + return RET_TOOSMALL; + } + return RET_ILUNI; +} + +/* + * UTF-32LE + */ + +/* Specification: Unicode 3.1 Standard Annex #19 */ + +static int +utf32le_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 4) + { + ucs4_t wc = s[0] + (s[1] << 8) + (s[2] << 16) + (s[3] << 24); + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + *pwc = wc; + return 4; + } + else + return RET_ILSEQ; + } + return RET_TOOFEW; +} + +static int +utf32le_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + if (n >= 4) + { + r[0] = (unsigned char) wc; + r[1] = (unsigned char) (wc >> 8); + r[2] = (unsigned char) (wc >> 16); + r[3] = 0; + return 4; + } + else + return RET_TOOSMALL; + } + return RET_ILUNI; +} + +#endif + +size_t +rpl_iconv (iconv_t cd, + ICONV_CONST char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft) +#undef iconv +{ +#if REPLACE_ICONV_UTF + switch ((uintptr_t) cd) + { + { + int (*xxx_wctomb) (unsigned char *, ucs4_t, size_t); + + case (uintptr_t) _ICONV_UTF8_UTF16BE: + xxx_wctomb = utf16be_wctomb; + goto loop_from_utf8; + case (uintptr_t) _ICONV_UTF8_UTF16LE: + xxx_wctomb = utf16le_wctomb; + goto loop_from_utf8; + case (uintptr_t) _ICONV_UTF8_UTF32BE: + xxx_wctomb = utf32be_wctomb; + goto loop_from_utf8; + case (uintptr_t) _ICONV_UTF8_UTF32LE: + xxx_wctomb = utf32le_wctomb; + goto loop_from_utf8; + + loop_from_utf8: + if (inbuf == NULL || *inbuf == NULL) + return 0; + { + ICONV_CONST char *inptr = *inbuf; + size_t inleft = *inbytesleft; + char *outptr = *outbuf; + size_t outleft = *outbytesleft; + size_t res = 0; + while (inleft > 0) + { + ucs4_t uc; + int m = u8_mbtoucr (&uc, (const uint8_t *) inptr, inleft); + if (m <= 0) + { + if (m == -1) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (m == -2) + { + errno = EINVAL; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + int n = xxx_wctomb ((uint8_t *) outptr, uc, outleft); + if (n < 0) + { + if (n == RET_ILUNI) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (n == RET_TOOSMALL) + { + errno = E2BIG; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + inptr += m; + inleft -= m; + outptr += n; + outleft -= n; + } + } + } + *inbuf = inptr; + *inbytesleft = inleft; + *outbuf = outptr; + *outbytesleft = outleft; + return res; + } + } + + { + int (*xxx_mbtowc) (ucs4_t *, const unsigned char *, size_t); + + case (uintptr_t) _ICONV_UTF16BE_UTF8: + xxx_mbtowc = utf16be_mbtowc; + goto loop_to_utf8; + case (uintptr_t) _ICONV_UTF16LE_UTF8: + xxx_mbtowc = utf16le_mbtowc; + goto loop_to_utf8; + case (uintptr_t) _ICONV_UTF32BE_UTF8: + xxx_mbtowc = utf32be_mbtowc; + goto loop_to_utf8; + case (uintptr_t) _ICONV_UTF32LE_UTF8: + xxx_mbtowc = utf32le_mbtowc; + goto loop_to_utf8; + + loop_to_utf8: + if (inbuf == NULL || *inbuf == NULL) + return 0; + { + ICONV_CONST char *inptr = *inbuf; + size_t inleft = *inbytesleft; + char *outptr = *outbuf; + size_t outleft = *outbytesleft; + size_t res = 0; + while (inleft > 0) + { + ucs4_t uc; + int m = xxx_mbtowc (&uc, (const uint8_t *) inptr, inleft); + if (m <= 0) + { + if (m == RET_ILSEQ) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (m == RET_TOOFEW) + { + errno = EINVAL; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + int n = u8_uctomb ((uint8_t *) outptr, uc, outleft); + if (n < 0) + { + if (n == -1) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (n == -2) + { + errno = E2BIG; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + inptr += m; + inleft -= m; + outptr += n; + outleft -= n; + } + } + } + *inbuf = inptr; + *inbytesleft = inleft; + *outbuf = outptr; + *outbytesleft = outleft; + return res; + } + } + } +#endif + return iconv (cd, inbuf, inbytesleft, outbuf, outbytesleft); +} diff --git a/lib/iconv.in.h b/lib/iconv.in.h new file mode 100644 index 000000000..915dce2e7 --- /dev/null +++ b/lib/iconv.in.h @@ -0,0 +1,71 @@ +/* A GNU-like . + + Copyright (C) 2007-2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _GL_ICONV_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_ICONV_H@ + +#ifndef _GL_ICONV_H +#define _GL_ICONV_H + +#ifdef __cplusplus +extern "C" { +#endif + + +#if @REPLACE_ICONV_OPEN@ +/* An iconv_open wrapper that supports the IANA standardized encoding names + ("ISO-8859-1" etc.) as far as possible. */ +# define iconv_open rpl_iconv_open +extern iconv_t iconv_open (const char *tocode, const char *fromcode); +#endif + +#if @REPLACE_ICONV_UTF@ +/* Special constants for supporting UTF-{16,32}{BE,LE} encodings. + Not public. */ +# define _ICONV_UTF8_UTF16BE (iconv_t)(-161) +# define _ICONV_UTF8_UTF16LE (iconv_t)(-162) +# define _ICONV_UTF8_UTF32BE (iconv_t)(-163) +# define _ICONV_UTF8_UTF32LE (iconv_t)(-164) +# define _ICONV_UTF16BE_UTF8 (iconv_t)(-165) +# define _ICONV_UTF16LE_UTF8 (iconv_t)(-166) +# define _ICONV_UTF32BE_UTF8 (iconv_t)(-167) +# define _ICONV_UTF32LE_UTF8 (iconv_t)(-168) +#endif + +#if @REPLACE_ICONV@ +# define iconv rpl_iconv +extern size_t iconv (iconv_t cd, + @ICONV_CONST@ char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft); +# define iconv_close rpl_iconv_close +extern int iconv_close (iconv_t cd); +#endif + + +#ifdef __cplusplus +} +#endif + +#endif /* _GL_ICONV_H */ +#endif /* _GL_ICONV_H */ diff --git a/lib/iconv_close.c b/lib/iconv_close.c new file mode 100644 index 000000000..3680412a0 --- /dev/null +++ b/lib/iconv_close.c @@ -0,0 +1,47 @@ +/* Character set conversion. + Copyright (C) 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include + +#include +#ifndef uintptr_t +# define uintptr_t unsigned long +#endif + +int +rpl_iconv_close (iconv_t cd) +#undef iconv_close +{ +#if REPLACE_ICONV_UTF + switch ((uintptr_t) cd) + { + case (uintptr_t) _ICONV_UTF8_UTF16BE: + case (uintptr_t) _ICONV_UTF8_UTF16LE: + case (uintptr_t) _ICONV_UTF8_UTF32BE: + case (uintptr_t) _ICONV_UTF8_UTF32LE: + case (uintptr_t) _ICONV_UTF16BE_UTF8: + case (uintptr_t) _ICONV_UTF16LE_UTF8: + case (uintptr_t) _ICONV_UTF32BE_UTF8: + case (uintptr_t) _ICONV_UTF32LE_UTF8: + return 0; + } +#endif + return iconv_close (cd); +} diff --git a/lib/iconv_open-aix.gperf b/lib/iconv_open-aix.gperf new file mode 100644 index 000000000..6782b9956 --- /dev/null +++ b/lib/iconv_open-aix.gperf @@ -0,0 +1,44 @@ +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On AIX 5.1, look in /usr/lib/nls/loc/uconvTable. +ISO-8859-1, "ISO8859-1" +ISO-8859-2, "ISO8859-2" +ISO-8859-3, "ISO8859-3" +ISO-8859-4, "ISO8859-4" +ISO-8859-5, "ISO8859-5" +ISO-8859-6, "ISO8859-6" +ISO-8859-7, "ISO8859-7" +ISO-8859-8, "ISO8859-8" +ISO-8859-9, "ISO8859-9" +ISO-8859-15, "ISO8859-15" +CP437, "IBM-437" +CP850, "IBM-850" +CP852, "IBM-852" +CP856, "IBM-856" +CP857, "IBM-857" +CP861, "IBM-861" +CP865, "IBM-865" +CP869, "IBM-869" +ISO-8859-13, "IBM-921" +CP922, "IBM-922" +CP932, "IBM-932" +CP943, "IBM-943" +CP1046, "IBM-1046" +CP1124, "IBM-1124" +CP1125, "IBM-1125" +CP1129, "IBM-1129" +CP1252, "IBM-1252" +GB2312, "IBM-eucCN" +EUC-JP, "IBM-eucJP" +EUC-KR, "IBM-eucKR" +EUC-TW, "IBM-eucTW" +BIG5, "big5" diff --git a/lib/iconv_open-hpux.gperf b/lib/iconv_open-hpux.gperf new file mode 100644 index 000000000..5a35c83e1 --- /dev/null +++ b/lib/iconv_open-hpux.gperf @@ -0,0 +1,56 @@ +struct mapping { int standard_name; const char vendor_name[9 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On HP-UX 11.11, look in /usr/lib/nls/iconv. +ISO-8859-1, "iso88591" +ISO-8859-2, "iso88592" +ISO-8859-5, "iso88595" +ISO-8859-6, "iso88596" +ISO-8859-7, "iso88597" +ISO-8859-8, "iso88598" +ISO-8859-9, "iso88599" +ISO-8859-15, "iso885915" +CP437, "cp437" +CP775, "cp775" +CP850, "cp850" +CP852, "cp852" +CP855, "cp855" +CP857, "cp857" +CP861, "cp861" +CP862, "cp862" +CP864, "cp864" +CP865, "cp865" +CP866, "cp866" +CP869, "cp869" +CP874, "cp874" +CP1250, "cp1250" +CP1251, "cp1251" +CP1252, "cp1252" +CP1253, "cp1253" +CP1254, "cp1254" +CP1255, "cp1255" +CP1256, "cp1256" +CP1257, "cp1257" +CP1258, "cp1258" +HP-ROMAN8, "roman8" +HP-ARABIC8, "arabic8" +HP-GREEK8, "greek8" +HP-HEBREW8, "hebrew8" +HP-TURKISH8, "turkish8" +HP-KANA8, "kana8" +TIS-620, "tis620" +GB2312, "hp15CN" +EUC-JP, "eucJP" +EUC-KR, "eucKR" +EUC-TW, "eucTW" +BIG5, "big5" +SHIFT_JIS, "sjis" +UTF-8, "utf8" diff --git a/lib/iconv_open-irix.gperf b/lib/iconv_open-irix.gperf new file mode 100644 index 000000000..3672a8013 --- /dev/null +++ b/lib/iconv_open-irix.gperf @@ -0,0 +1,31 @@ +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On IRIX 6.5, look in /usr/lib/iconv and /usr/lib/international/encodings. +ISO-8859-1, "ISO8859-1" +ISO-8859-2, "ISO8859-2" +ISO-8859-3, "ISO8859-3" +ISO-8859-4, "ISO8859-4" +ISO-8859-5, "ISO8859-5" +ISO-8859-6, "ISO8859-6" +ISO-8859-7, "ISO8859-7" +ISO-8859-8, "ISO8859-8" +ISO-8859-9, "ISO8859-9" +ISO-8859-15, "ISO8859-15" +KOI8-R, "KOI8" +CP855, "DOS855" +CP1251, "WIN1251" +GB2312, "eucCN" +EUC-JP, "eucJP" +EUC-KR, "eucKR" +EUC-TW, "eucTW" +SHIFT_JIS, "sjis" +TIS-620, "TIS620" diff --git a/lib/iconv_open-osf.gperf b/lib/iconv_open-osf.gperf new file mode 100644 index 000000000..f468ff609 --- /dev/null +++ b/lib/iconv_open-osf.gperf @@ -0,0 +1,50 @@ +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On OSF/1 5.1, look in /usr/lib/nls/loc/iconv. +ISO-8859-1, "ISO8859-1" +ISO-8859-2, "ISO8859-2" +ISO-8859-3, "ISO8859-3" +ISO-8859-4, "ISO8859-4" +ISO-8859-5, "ISO8859-5" +ISO-8859-6, "ISO8859-6" +ISO-8859-7, "ISO8859-7" +ISO-8859-8, "ISO8859-8" +ISO-8859-9, "ISO8859-9" +ISO-8859-15, "ISO8859-15" +CP437, "cp437" +CP775, "cp775" +CP850, "cp850" +CP852, "cp852" +CP855, "cp855" +CP857, "cp857" +CP861, "cp861" +CP862, "cp862" +CP865, "cp865" +CP866, "cp866" +CP869, "cp869" +CP874, "cp874" +CP949, "KSC5601" +CP1250, "cp1250" +CP1251, "cp1251" +CP1252, "cp1252" +CP1253, "cp1253" +CP1254, "cp1254" +CP1255, "cp1255" +CP1256, "cp1256" +CP1257, "cp1257" +CP1258, "cp1258" +EUC-JP, "eucJP" +EUC-KR, "eucKR" +EUC-TW, "eucTW" +BIG5, "big5" +SHIFT_JIS, "SJIS" +TIS-620, "TACTIS" diff --git a/lib/iconv_open.c b/lib/iconv_open.c new file mode 100644 index 000000000..3d873acd6 --- /dev/null +++ b/lib/iconv_open.c @@ -0,0 +1,172 @@ +/* Character set conversion. + Copyright (C) 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include + +#include +#include +#include "c-ctype.h" +#include "c-strcase.h" + +#define SIZEOF(a) (sizeof(a) / sizeof(a[0])) + +/* Namespace cleanliness. */ +#define mapping_lookup rpl_iconv_open_mapping_lookup + +/* The macro ICONV_FLAVOR is defined to one of these or undefined. */ + +#define ICONV_FLAVOR_AIX "iconv_open-aix.h" +#define ICONV_FLAVOR_HPUX "iconv_open-hpux.h" +#define ICONV_FLAVOR_IRIX "iconv_open-irix.h" +#define ICONV_FLAVOR_OSF "iconv_open-osf.h" + +#ifdef ICONV_FLAVOR +# include ICONV_FLAVOR +#endif + +iconv_t +rpl_iconv_open (const char *tocode, const char *fromcode) +#undef iconv_open +{ + char fromcode_upper[32]; + char tocode_upper[32]; + char *fromcode_upper_end; + char *tocode_upper_end; + +#if REPLACE_ICONV_UTF + /* Special handling of conversion between UTF-8 and UTF-{16,32}{BE,LE}. + Do this here, before calling the real iconv_open(), because OSF/1 5.1 + iconv() to these encoding inserts a BOM, which is wrong. + We do not need to handle conversion between arbitrary encodings and + UTF-{16,32}{BE,LE}, because the 'striconveh' module implements two-step + conversion throough UTF-8. + The _ICONV_* constants are chosen to be disjoint from any iconv_t + returned by the system's iconv_open() functions. Recall that iconv_t + is a scalar type. */ + if (c_toupper (fromcode[0]) == 'U' + && c_toupper (fromcode[1]) == 'T' + && c_toupper (fromcode[2]) == 'F' + && fromcode[3] == '-') + { + if (c_toupper (tocode[0]) == 'U' + && c_toupper (tocode[1]) == 'T' + && c_toupper (tocode[2]) == 'F' + && tocode[3] == '-') + { + if (strcmp (fromcode + 4, "8") == 0) + { + if (c_strcasecmp (tocode + 4, "16BE") == 0) + return _ICONV_UTF8_UTF16BE; + if (c_strcasecmp (tocode + 4, "16LE") == 0) + return _ICONV_UTF8_UTF16LE; + if (c_strcasecmp (tocode + 4, "32BE") == 0) + return _ICONV_UTF8_UTF32BE; + if (c_strcasecmp (tocode + 4, "32LE") == 0) + return _ICONV_UTF8_UTF32LE; + } + else if (strcmp (tocode + 4, "8") == 0) + { + if (c_strcasecmp (fromcode + 4, "16BE") == 0) + return _ICONV_UTF16BE_UTF8; + if (c_strcasecmp (fromcode + 4, "16LE") == 0) + return _ICONV_UTF16LE_UTF8; + if (c_strcasecmp (fromcode + 4, "32BE") == 0) + return _ICONV_UTF32BE_UTF8; + if (c_strcasecmp (fromcode + 4, "32LE") == 0) + return _ICONV_UTF32LE_UTF8; + } + } + } +#endif + + /* Do *not* add special support for 8-bit encodings like ASCII or ISO-8859-1 + here. This would lead to programs that work in some locales (such as the + "C" or "en_US" locales) but do not work in East Asian locales. It is + better if programmers make their programs depend on GNU libiconv (except + on glibc systems), e.g. by using the AM_ICONV macro and documenting the + dependency in an INSTALL or DEPENDENCIES file. */ + + /* Try with the original names first. + This covers the case when fromcode or tocode is a lowercase encoding name + that is understood by the system's iconv_open but not listed in our + mappings table. */ + { + iconv_t cd = iconv_open (tocode, fromcode); + if (cd != (iconv_t)(-1)) + return cd; + } + + /* Convert the encodings to upper case, because + 1. in the arguments of iconv_open() on AIX, HP-UX, and OSF/1 the case + matters, + 2. it makes searching in the table faster. */ + { + const char *p = fromcode; + char *q = fromcode_upper; + while ((*q = c_toupper (*p)) != '\0') + { + p++; + q++; + if (q == &fromcode_upper[SIZEOF (fromcode_upper)]) + { + errno = EINVAL; + return (iconv_t)(-1); + } + } + fromcode_upper_end = q; + } + + { + const char *p = tocode; + char *q = tocode_upper; + while ((*q = c_toupper (*p)) != '\0') + { + p++; + q++; + if (q == &tocode_upper[SIZEOF (tocode_upper)]) + { + errno = EINVAL; + return (iconv_t)(-1); + } + } + tocode_upper_end = q; + } + +#ifdef ICONV_FLAVOR + /* Apply the mappings. */ + { + const struct mapping *m = + mapping_lookup (fromcode_upper, fromcode_upper_end - fromcode_upper); + + fromcode = (m != NULL ? m->vendor_name : fromcode_upper); + } + { + const struct mapping *m = + mapping_lookup (tocode_upper, tocode_upper_end - tocode_upper); + + tocode = (m != NULL ? m->vendor_name : tocode_upper); + } +#else + fromcode = fromcode_upper; + tocode = tocode_upper; +#endif + + return iconv_open (tocode, fromcode); +} diff --git a/lib/iconveh.h b/lib/iconveh.h new file mode 100644 index 000000000..06cda52e8 --- /dev/null +++ b/lib/iconveh.h @@ -0,0 +1,41 @@ +/* Character set conversion handler type. + Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef _ICONVEH_H +#define _ICONVEH_H + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Handling of unconvertible characters. */ +enum iconv_ilseq_handler +{ + iconveh_error, /* return and set errno = EILSEQ */ + iconveh_question_mark, /* use one '?' per unconvertible character */ + iconveh_escape_sequence /* use escape sequence \uxxxx or \Uxxxxxxxx */ +}; + + +#ifdef __cplusplus +} +#endif + + +#endif /* _ICONVEH_H */ diff --git a/lib/striconveh.c b/lib/striconveh.c new file mode 100644 index 000000000..b39a01f19 --- /dev/null +++ b/lib/striconveh.c @@ -0,0 +1,1251 @@ +/* Character set conversion with error handling. + Copyright (C) 2001-2008 Free Software Foundation, Inc. + Written by Bruno Haible and Simon Josefsson. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include "striconveh.h" + +#include +#include +#include +#include + +#if HAVE_ICONV +# include +# include "unistr.h" +#endif + +#include "c-strcase.h" +#include "c-strcaseeq.h" + +#ifndef SIZE_MAX +# define SIZE_MAX ((size_t) -1) +#endif + + +#if HAVE_ICONV + +/* The caller must provide CD, CD1, CD2, not just CD, because when a conversion + error occurs, we may have to determine the Unicode representation of the + inconvertible character. */ + +/* iconv_carefully is like iconv, except that it stops as soon as it encounters + a conversion error, and it returns in *INCREMENTED a boolean telling whether + it has incremented the input pointers past the error location. */ +# if !defined _LIBICONV_VERSION && !defined __GLIBC__ +/* Irix iconv() inserts a NUL byte if it cannot convert. + NetBSD iconv() inserts a question mark if it cannot convert. + Only GNU libiconv and GNU libc are known to prefer to fail rather + than doing a lossy conversion. */ +static size_t +iconv_carefully (iconv_t cd, + const char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft, + bool *incremented) +{ + const char *inptr = *inbuf; + const char *inptr_end = inptr + *inbytesleft; + char *outptr = *outbuf; + size_t outsize = *outbytesleft; + const char *inptr_before; + size_t res; + + do + { + size_t insize; + + inptr_before = inptr; + res = (size_t)(-1); + + for (insize = 1; inptr + insize <= inptr_end; insize++) + { + res = iconv (cd, + (ICONV_CONST char **) &inptr, &insize, + &outptr, &outsize); + if (!(res == (size_t)(-1) && errno == EINVAL)) + break; + /* iconv can eat up a shift sequence but give EINVAL while attempting + to convert the first character. E.g. libiconv does this. */ + if (inptr > inptr_before) + { + res = 0; + break; + } + } + + if (res == 0) + { + *outbuf = outptr; + *outbytesleft = outsize; + } + } + while (res == 0 && inptr < inptr_end); + + *inbuf = inptr; + *inbytesleft = inptr_end - inptr; + if (res != (size_t)(-1) && res > 0) + { + /* iconv() has already incremented INPTR. We cannot go back to a + previous INPTR, otherwise the state inside CD would become invalid, + if FROM_CODESET is a stateful encoding. So, tell the caller that + *INBUF has already been incremented. */ + *incremented = (inptr > inptr_before); + errno = EILSEQ; + return (size_t)(-1); + } + else + { + *incremented = false; + return res; + } +} +# else +# define iconv_carefully(cd, inbuf, inbytesleft, outbuf, outbytesleft, incremented) \ + (*(incremented) = false, \ + iconv (cd, (ICONV_CONST char **) (inbuf), inbytesleft, outbuf, outbytesleft)) +# endif + +/* iconv_carefully_1 is like iconv_carefully, except that it stops after + converting one character or one shift sequence. */ +static size_t +iconv_carefully_1 (iconv_t cd, + const char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft, + bool *incremented) +{ + const char *inptr_before = *inbuf; + const char *inptr = inptr_before; + const char *inptr_end = inptr_before + *inbytesleft; + char *outptr = *outbuf; + size_t outsize = *outbytesleft; + size_t res = (size_t)(-1); + size_t insize; + + for (insize = 1; inptr_before + insize <= inptr_end; insize++) + { + inptr = inptr_before; + res = iconv (cd, + (ICONV_CONST char **) &inptr, &insize, + &outptr, &outsize); + if (!(res == (size_t)(-1) && errno == EINVAL)) + break; + /* iconv can eat up a shift sequence but give EINVAL while attempting + to convert the first character. E.g. libiconv does this. */ + if (inptr > inptr_before) + { + res = 0; + break; + } + } + + *inbuf = inptr; + *inbytesleft = inptr_end - inptr; +# if !defined _LIBICONV_VERSION && !defined __GLIBC__ + /* Irix iconv() inserts a NUL byte if it cannot convert. + NetBSD iconv() inserts a question mark if it cannot convert. + Only GNU libiconv and GNU libc are known to prefer to fail rather + than doing a lossy conversion. */ + if (res != (size_t)(-1) && res > 0) + { + /* iconv() has already incremented INPTR. We cannot go back to a + previous INPTR, otherwise the state inside CD would become invalid, + if FROM_CODESET is a stateful encoding. So, tell the caller that + *INBUF has already been incremented. */ + *incremented = (inptr > inptr_before); + errno = EILSEQ; + return (size_t)(-1); + } +# endif + + if (res != (size_t)(-1)) + { + *outbuf = outptr; + *outbytesleft = outsize; + } + *incremented = false; + return res; +} + +/* utf8conv_carefully is like iconv, except that + - it converts from UTF-8 to UTF-8, + - it stops as soon as it encounters a conversion error, and it returns + in *INCREMENTED a boolean telling whether it has incremented the input + pointers past the error location, + - if one_character_only is true, it stops after converting one + character. */ +static size_t +utf8conv_carefully (bool one_character_only, + const char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft, + bool *incremented) +{ + const char *inptr = *inbuf; + size_t insize = *inbytesleft; + char *outptr = *outbuf; + size_t outsize = *outbytesleft; + size_t res; + + res = 0; + do + { + ucs4_t uc; + int n; + int m; + + n = u8_mbtoucr (&uc, (const uint8_t *) inptr, insize); + if (n < 0) + { + errno = (n == -2 ? EINVAL : EILSEQ); + n = u8_mbtouc (&uc, (const uint8_t *) inptr, insize); + inptr += n; + insize -= n; + res = (size_t)(-1); + *incremented = true; + break; + } + if (outsize == 0) + { + errno = E2BIG; + res = (size_t)(-1); + *incremented = false; + break; + } + m = u8_uctomb ((uint8_t *) outptr, uc, outsize); + if (m == -2) + { + errno = E2BIG; + res = (size_t)(-1); + *incremented = false; + break; + } + inptr += n; + insize -= n; + if (m == -1) + { + errno = EILSEQ; + res = (size_t)(-1); + *incremented = true; + break; + } + outptr += m; + outsize -= m; + } + while (!one_character_only && insize > 0); + + *inbuf = inptr; + *inbytesleft = insize; + *outbuf = outptr; + *outbytesleft = outsize; + return res; +} + +static int +mem_cd_iconveh_internal (const char *src, size_t srclen, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler, + size_t extra_alloc, + size_t *offsets, + char **resultp, size_t *lengthp) +{ + /* When a conversion error occurs, we cannot start using CD1 and CD2 at + this point: FROM_CODESET may be a stateful encoding like ISO-2022-KR. + Instead, we have to start afresh from the beginning of SRC. */ + /* Use a temporary buffer, so that for small strings, a single malloc() + call will be sufficient. */ +# define tmpbufsize 4096 + /* The alignment is needed when converting e.g. to glibc's WCHAR_T or + libiconv's UCS-4-INTERNAL encoding. */ + union { unsigned int align; char buf[tmpbufsize]; } tmp; +# define tmpbuf tmp.buf + + char *initial_result; + char *result; + size_t allocated; + size_t length; + size_t last_length = (size_t)(-1); /* only needed if offsets != NULL */ + + if (*resultp != NULL && *lengthp >= sizeof (tmpbuf)) + { + initial_result = *resultp; + allocated = *lengthp; + } + else + { + initial_result = tmpbuf; + allocated = sizeof (tmpbuf); + } + result = initial_result; + + /* Test whether a direct conversion is possible at all. */ + if (cd == (iconv_t)(-1)) + goto indirectly; + + if (offsets != NULL) + { + size_t i; + + for (i = 0; i < srclen; i++) + offsets[i] = (size_t)(-1); + + last_length = (size_t)(-1); + } + length = 0; + + /* First, try a direct conversion, and see whether a conversion error + occurs at all. */ + { + const char *inptr = src; + size_t insize = srclen; + + /* Avoid glibc-2.1 bug and Solaris 2.7-2.9 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) || defined __sun) + /* Set to the initial state. */ + iconv (cd, NULL, NULL, NULL, NULL); +# endif + + while (insize > 0) + { + char *outptr = result + length; + size_t outsize = allocated - extra_alloc - length; + bool incremented; + size_t res; + bool grow; + + if (offsets != NULL) + { + if (length != last_length) /* ensure that offset[] be increasing */ + { + offsets[inptr - src] = length; + last_length = length; + } + res = iconv_carefully_1 (cd, + &inptr, &insize, + &outptr, &outsize, + &incremented); + } + else + /* Use iconv_carefully instead of iconv here, because: + - If TO_CODESET is UTF-8, we can do the error handling in this + loop, no need for a second loop, + - With iconv() implementations other than GNU libiconv and GNU + libc, if we use iconv() in a big swoop, checking for an E2BIG + return, we lose the number of irreversible conversions. */ + res = iconv_carefully (cd, + &inptr, &insize, + &outptr, &outsize, + &incremented); + + length = outptr - result; + grow = (length + extra_alloc > allocated / 2); + if (res == (size_t)(-1)) + { + if (errno == E2BIG) + grow = true; + else if (errno == EINVAL) + break; + else if (errno == EILSEQ && handler != iconveh_error) + { + if (cd2 == (iconv_t)(-1)) + { + /* TO_CODESET is UTF-8. */ + /* Error handling can produce up to 1 byte of output. */ + if (length + 1 + extra_alloc > allocated) + { + char *memory; + + allocated = 2 * allocated; + if (length + 1 + extra_alloc > allocated) + abort (); + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + grow = false; + } + /* The input is invalid in FROM_CODESET. Eat up one byte + and emit a question mark. */ + if (!incremented) + { + if (insize == 0) + abort (); + inptr++; + insize--; + } + result[length] = '?'; + length++; + } + else + goto indirectly; + } + else + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + if (insize == 0) + break; + if (grow) + { + char *memory; + + allocated = 2 * allocated; + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + } + } + } + + /* Now get the conversion state back to the initial state. + But avoid glibc-2.1 bug and Solaris 2.7 bug. */ +#if defined _LIBICONV_VERSION \ + || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun) + for (;;) + { + char *outptr = result + length; + size_t outsize = allocated - extra_alloc - length; + size_t res; + + res = iconv (cd, NULL, NULL, &outptr, &outsize); + length = outptr - result; + if (res == (size_t)(-1)) + { + if (errno == E2BIG) + { + char *memory; + + allocated = 2 * allocated; + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + } + else + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + else + break; + } +#endif + + /* The direct conversion succeeded. */ + goto done; + + indirectly: + /* The direct conversion failed. + Use a conversion through UTF-8. */ + if (offsets != NULL) + { + size_t i; + + for (i = 0; i < srclen; i++) + offsets[i] = (size_t)(-1); + + last_length = (size_t)(-1); + } + length = 0; + { + const bool slowly = (offsets != NULL || handler == iconveh_error); +# define utf8bufsize 4096 /* may also be smaller or larger than tmpbufsize */ + char utf8buf[utf8bufsize + 1]; + size_t utf8len = 0; + const char *in1ptr = src; + size_t in1size = srclen; + bool do_final_flush1 = true; + bool do_final_flush2 = true; + + /* Avoid glibc-2.1 bug and Solaris 2.7-2.9 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) || defined __sun) + /* Set to the initial state. */ + if (cd1 != (iconv_t)(-1)) + iconv (cd1, NULL, NULL, NULL, NULL); + if (cd2 != (iconv_t)(-1)) + iconv (cd2, NULL, NULL, NULL, NULL); +# endif + + while (in1size > 0 || do_final_flush1 || utf8len > 0 || do_final_flush2) + { + char *out1ptr = utf8buf + utf8len; + size_t out1size = utf8bufsize - utf8len; + bool incremented1; + size_t res1; + int errno1; + + /* Conversion step 1: from FROM_CODESET to UTF-8. */ + if (in1size > 0) + { + if (offsets != NULL + && length != last_length) /* ensure that offset[] be increasing */ + { + offsets[in1ptr - src] = length; + last_length = length; + } + if (cd1 != (iconv_t)(-1)) + { + if (slowly) + res1 = iconv_carefully_1 (cd1, + &in1ptr, &in1size, + &out1ptr, &out1size, + &incremented1); + else + res1 = iconv_carefully (cd1, + &in1ptr, &in1size, + &out1ptr, &out1size, + &incremented1); + } + else + { + /* FROM_CODESET is UTF-8. */ + res1 = utf8conv_carefully (slowly, + &in1ptr, &in1size, + &out1ptr, &out1size, + &incremented1); + } + } + else if (do_final_flush1) + { + /* Now get the conversion state of CD1 back to the initial state. + But avoid glibc-2.1 bug and Solaris 2.7 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun) + if (cd1 != (iconv_t)(-1)) + res1 = iconv (cd1, NULL, NULL, &out1ptr, &out1size); + else +# endif + res1 = 0; + do_final_flush1 = false; + incremented1 = true; + } + else + { + res1 = 0; + incremented1 = true; + } + if (res1 == (size_t)(-1) + && !(errno == E2BIG || errno == EINVAL || errno == EILSEQ)) + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + if (res1 == (size_t)(-1) + && errno == EILSEQ && handler != iconveh_error) + { + /* The input is invalid in FROM_CODESET. Eat up one byte and + emit a question mark. Room for the question mark was allocated + at the end of utf8buf. */ + if (!incremented1) + { + if (in1size == 0) + abort (); + in1ptr++; + in1size--; + } + utf8buf[utf8len++] = '?'; + } + errno1 = errno; + utf8len = out1ptr - utf8buf; + + if (offsets != NULL + || in1size == 0 + || utf8len > utf8bufsize / 2 + || (res1 == (size_t)(-1) && errno1 == E2BIG)) + { + /* Conversion step 2: from UTF-8 to TO_CODESET. */ + const char *in2ptr = utf8buf; + size_t in2size = utf8len; + + while (in2size > 0 + || (in1size == 0 && !do_final_flush1 && do_final_flush2)) + { + char *out2ptr = result + length; + size_t out2size = allocated - extra_alloc - length; + bool incremented2; + size_t res2; + bool grow; + + if (in2size > 0) + { + if (cd2 != (iconv_t)(-1)) + res2 = iconv_carefully (cd2, + &in2ptr, &in2size, + &out2ptr, &out2size, + &incremented2); + else + /* TO_CODESET is UTF-8. */ + res2 = utf8conv_carefully (false, + &in2ptr, &in2size, + &out2ptr, &out2size, + &incremented2); + } + else /* in1size == 0 && !do_final_flush1 + && in2size == 0 && do_final_flush2 */ + { + /* Now get the conversion state of CD1 back to the initial + state. But avoid glibc-2.1 bug and Solaris 2.7 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun) + if (cd2 != (iconv_t)(-1)) + res2 = iconv (cd2, NULL, NULL, &out2ptr, &out2size); + else +# endif + res2 = 0; + do_final_flush2 = false; + incremented2 = true; + } + + length = out2ptr - result; + grow = (length + extra_alloc > allocated / 2); + if (res2 == (size_t)(-1)) + { + if (errno == E2BIG) + grow = true; + else if (errno == EINVAL) + break; + else if (errno == EILSEQ && handler != iconveh_error) + { + /* Error handling can produce up to 10 bytes of ASCII + output. But TO_CODESET may be UCS-2, UTF-16 or + UCS-4, so use CD2 here as well. */ + char scratchbuf[10]; + size_t scratchlen; + ucs4_t uc; + const char *inptr; + size_t insize; + size_t res; + + if (incremented2) + { + if (u8_prev (&uc, (const uint8_t *) in2ptr, + (const uint8_t *) utf8buf) + == NULL) + abort (); + } + else + { + int n; + if (in2size == 0) + abort (); + n = u8_mbtouc_unsafe (&uc, (const uint8_t *) in2ptr, + in2size); + in2ptr += n; + in2size -= n; + } + + if (handler == iconveh_escape_sequence) + { + static char hex[16] = "0123456789ABCDEF"; + scratchlen = 0; + scratchbuf[scratchlen++] = '\\'; + if (uc < 0x10000) + scratchbuf[scratchlen++] = 'u'; + else + { + scratchbuf[scratchlen++] = 'U'; + scratchbuf[scratchlen++] = hex[(uc>>28) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>24) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>20) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>16) & 15]; + } + scratchbuf[scratchlen++] = hex[(uc>>12) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>8) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>4) & 15]; + scratchbuf[scratchlen++] = hex[uc & 15]; + } + else + { + scratchbuf[0] = '?'; + scratchlen = 1; + } + + inptr = scratchbuf; + insize = scratchlen; + if (cd2 != (iconv_t)(-1)) + res = iconv (cd2, + (ICONV_CONST char **) &inptr, &insize, + &out2ptr, &out2size); + else + { + /* TO_CODESET is UTF-8. */ + if (out2size >= insize) + { + memcpy (out2ptr, inptr, insize); + out2ptr += insize; + out2size -= insize; + inptr += insize; + insize = 0; + res = 0; + } + else + { + errno = E2BIG; + res = (size_t)(-1); + } + } + length = out2ptr - result; + if (res == (size_t)(-1) && errno == E2BIG) + { + char *memory; + + allocated = 2 * allocated; + if (length + 1 + extra_alloc > allocated) + abort (); + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + grow = false; + + out2ptr = result + length; + out2size = allocated - extra_alloc - length; + if (cd2 != (iconv_t)(-1)) + res = iconv (cd2, + (ICONV_CONST char **) &inptr, + &insize, + &out2ptr, &out2size); + else + { + /* TO_CODESET is UTF-8. */ + if (!(out2size >= insize)) + abort (); + memcpy (out2ptr, inptr, insize); + out2ptr += insize; + out2size -= insize; + inptr += insize; + insize = 0; + res = 0; + } + length = out2ptr - result; + } +# if !defined _LIBICONV_VERSION && !defined __GLIBC__ + /* Irix iconv() inserts a NUL byte if it cannot convert. + NetBSD iconv() inserts a question mark if it cannot + convert. + Only GNU libiconv and GNU libc are known to prefer + to fail rather than doing a lossy conversion. */ + if (res != (size_t)(-1) && res > 0) + { + errno = EILSEQ; + res = (size_t)(-1); + } +# endif + if (res == (size_t)(-1)) + { + /* Failure converting the ASCII replacement. */ + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + else + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + if (!(in2size > 0 + || (in1size == 0 && !do_final_flush1 && do_final_flush2))) + break; + if (grow) + { + char *memory; + + allocated = 2 * allocated; + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + } + } + + /* Move the remaining bytes to the beginning of utf8buf. */ + if (in2size > 0) + memmove (utf8buf, in2ptr, in2size); + utf8len = in2size; + } + + if (res1 == (size_t)(-1)) + { + if (errno1 == EINVAL) + in1size = 0; + else if (errno1 == EILSEQ) + { + if (result != initial_result) + free (result); + errno = errno1; + return -1; + } + } + } +# undef utf8bufsize + } + + done: + /* Now the final memory allocation. */ + if (result == tmpbuf) + { + size_t memsize = length + extra_alloc; + char *memory; + + memory = (char *) malloc (memsize > 0 ? memsize : 1); + if (memory != NULL) + { + memcpy (memory, tmpbuf, length); + result = memory; + } + else + { + errno = ENOMEM; + return -1; + } + } + else if (result != *resultp && length + extra_alloc < allocated) + { + /* Shrink the allocated memory if possible. */ + size_t memsize = length + extra_alloc; + char *memory; + + memory = (char *) realloc (result, memsize > 0 ? memsize : 1); + if (memory != NULL) + result = memory; + } + *resultp = result; + *lengthp = length; + return 0; +# undef tmpbuf +# undef tmpbufsize +} + +int +mem_cd_iconveh (const char *src, size_t srclen, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp) +{ + return mem_cd_iconveh_internal (src, srclen, cd, cd1, cd2, handler, 0, + offsets, resultp, lengthp); +} + +char * +str_cd_iconveh (const char *src, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler) +{ + /* For most encodings, a trailing NUL byte in the input will be converted + to a trailing NUL byte in the output. But not for UTF-7. So that this + function is usable for UTF-7, we have to exclude the NUL byte from the + conversion and add it by hand afterwards. */ + char *result = NULL; + size_t length = 0; + int retval = mem_cd_iconveh_internal (src, strlen (src), + cd, cd1, cd2, handler, 1, NULL, + &result, &length); + + if (retval < 0) + { + if (result != NULL) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return NULL; + } + + /* Add the terminating NUL byte. */ + result[length] = '\0'; + + return result; +} + +#endif + +int +mem_iconveh (const char *src, size_t srclen, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp) +{ + if (srclen == 0) + { + /* Nothing to convert. */ + *lengthp = 0; + return 0; + } + else if (offsets == NULL && c_strcasecmp (from_codeset, to_codeset) == 0) + { + char *result; + + if (*resultp != NULL && *lengthp >= srclen) + result = *resultp; + else + { + result = (char *) malloc (srclen); + if (result == NULL) + { + errno = ENOMEM; + return -1; + } + } + memcpy (result, src, srclen); + *resultp = result; + *lengthp = srclen; + return 0; + } + else + { +#if HAVE_ICONV + iconv_t cd; + iconv_t cd1; + iconv_t cd2; + char *result; + size_t length; + int retval; + + /* Avoid glibc-2.1 bug with EUC-KR. */ +# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined _LIBICONV_VERSION + if (c_strcasecmp (from_codeset, "EUC-KR") == 0 + || c_strcasecmp (to_codeset, "EUC-KR") == 0) + { + errno = EINVAL; + return -1; + } +# endif + + cd = iconv_open (to_codeset, from_codeset); + + if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)) + cd1 = (iconv_t)(-1); + else + { + cd1 = iconv_open ("UTF-8", from_codeset); + if (cd1 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return -1; + } + } + + if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0) +# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 || _LIBICONV_VERSION >= 0x0105 + || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0 +# endif + ) + cd2 = (iconv_t)(-1); + else + { + cd2 = iconv_open (to_codeset, "UTF-8"); + if (cd2 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return -1; + } + } + + result = *resultp; + length = *lengthp; + retval = mem_cd_iconveh (src, srclen, cd, cd1, cd2, handler, offsets, + &result, &length); + + if (retval < 0) + { + /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */ + int saved_errno = errno; + if (cd2 != (iconv_t)(-1)) + iconv_close (cd2); + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + } + else + { + if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0) + { + /* Return -1, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + if (result != *resultp && result != NULL) + free (result); + errno = saved_errno; + return -1; + } + if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0) + { + /* Return -1, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + if (result != *resultp && result != NULL) + free (result); + errno = saved_errno; + return -1; + } + if (cd != (iconv_t)(-1) && iconv_close (cd) < 0) + { + /* Return -1, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (result != *resultp && result != NULL) + free (result); + errno = saved_errno; + return -1; + } + *resultp = result; + *lengthp = length; + } + return retval; +#else + /* This is a different error code than if iconv_open existed but didn't + support from_codeset and to_codeset, so that the caller can emit + an error message such as + "iconv() is not supported. Installing GNU libiconv and + then reinstalling this package would fix this." */ + errno = ENOSYS; + return -1; +#endif + } +} + +char * +str_iconveh (const char *src, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler) +{ + if (*src == '\0' || c_strcasecmp (from_codeset, to_codeset) == 0) + { + char *result = strdup (src); + + if (result == NULL) + errno = ENOMEM; + return result; + } + else + { +#if HAVE_ICONV + iconv_t cd; + iconv_t cd1; + iconv_t cd2; + char *result; + + /* Avoid glibc-2.1 bug with EUC-KR. */ +# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined _LIBICONV_VERSION + if (c_strcasecmp (from_codeset, "EUC-KR") == 0 + || c_strcasecmp (to_codeset, "EUC-KR") == 0) + { + errno = EINVAL; + return NULL; + } +# endif + + cd = iconv_open (to_codeset, from_codeset); + + if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)) + cd1 = (iconv_t)(-1); + else + { + cd1 = iconv_open ("UTF-8", from_codeset); + if (cd1 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return NULL; + } + } + + if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0) +# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 || _LIBICONV_VERSION >= 0x0105 + || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0 +# endif + ) + cd2 = (iconv_t)(-1); + else + { + cd2 = iconv_open (to_codeset, "UTF-8"); + if (cd2 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return NULL; + } + } + + result = str_cd_iconveh (src, cd, cd1, cd2, handler); + + if (result == NULL) + { + /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */ + int saved_errno = errno; + if (cd2 != (iconv_t)(-1)) + iconv_close (cd2); + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + } + else + { + if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0) + { + /* Return NULL, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + free (result); + errno = saved_errno; + return NULL; + } + if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0) + { + /* Return NULL, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + free (result); + errno = saved_errno; + return NULL; + } + if (cd != (iconv_t)(-1) && iconv_close (cd) < 0) + { + /* Return NULL, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + free (result); + errno = saved_errno; + return NULL; + } + } + return result; +#else + /* This is a different error code than if iconv_open existed but didn't + support from_codeset and to_codeset, so that the caller can emit + an error message such as + "iconv() is not supported. Installing GNU libiconv and + then reinstalling this package would fix this." */ + errno = ENOSYS; + return NULL; +#endif + } +} diff --git a/lib/striconveh.h b/lib/striconveh.h new file mode 100644 index 000000000..98b4d0c5e --- /dev/null +++ b/lib/striconveh.h @@ -0,0 +1,120 @@ +/* Character set conversion with error handling. + Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible and Simon Josefsson. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef _STRICONVEH_H +#define _STRICONVEH_H + +#include +#if HAVE_ICONV +#include +#endif + +#include "iconveh.h" + + +#ifdef __cplusplus +extern "C" { +#endif + + +#if HAVE_ICONV + +/* Convert an entire string from one encoding to another, using iconv. + The original string is at [SRC,...,SRC+SRCLEN-1]. + CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if + the system does not support a direct conversion from FROMCODE to TOCODE. + CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or + (iconv_t)(-1) if FROM_CODESET is UTF-8). + CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1) + if TO_CODESET is UTF-8). + If OFFSETS is not NULL, it should point to an array of SRCLEN integers; this + array is filled with offsets into the result, i.e. the character starting + at SRC[i] corresponds to the character starting at (*RESULTP)[OFFSETS[i]], + and other offsets are set to (size_t)(-1). + *RESULTP and *LENGTH should initially be a scratch buffer and its size, + or *RESULTP can initially be NULL. + May erase the contents of the memory at *RESULTP. + Return value: 0 if successful, otherwise -1 and errno set. + If successful: The resulting string is stored in *RESULTP and its length + in *LENGTHP. *RESULTP is set to a freshly allocated memory block, or is + unchanged if no dynamic memory allocation was necessary. */ +extern int + mem_cd_iconveh (const char *src, size_t srclen, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp); + +/* Convert an entire string from one encoding to another, using iconv. + The original string is the NUL-terminated string starting at SRC. + CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if + the system does not support a direct conversion from FROMCODE to TOCODE. + Both the "from" and the "to" encoding must use a single NUL byte at the end + of the string (i.e. not UCS-2, UCS-4, UTF-16, UTF-32). + CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or + (iconv_t)(-1) if FROM_CODESET is UTF-8). + CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1) + if TO_CODESET is UTF-8). + Allocate a malloced memory block for the result. + Return value: the freshly allocated resulting NUL-terminated string if + successful, otherwise NULL and errno set. */ +extern char * + str_cd_iconveh (const char *src, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler); + +#endif + +/* Convert an entire string from one encoding to another, using iconv. + The original string is at [SRC,...,SRC+SRCLEN-1]. + If OFFSETS is not NULL, it should point to an array of SRCLEN integers; this + array is filled with offsets into the result, i.e. the character starting + at SRC[i] corresponds to the character starting at (*RESULTP)[OFFSETS[i]], + and other offsets are set to (size_t)(-1). + *RESULTP and *LENGTH should initially be a scratch buffer and its size, + or *RESULTP can initially be NULL. + May erase the contents of the memory at *RESULTP. + Return value: 0 if successful, otherwise -1 and errno set. + If successful: The resulting string is stored in *RESULTP and its length + in *LENGTHP. *RESULTP is set to a freshly allocated memory block, or is + unchanged if no dynamic memory allocation was necessary. */ +extern int + mem_iconveh (const char *src, size_t srclen, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp); + +/* Convert an entire string from one encoding to another, using iconv. + The original string is the NUL-terminated string starting at SRC. + Both the "from" and the "to" encoding must use a single NUL byte at the + end of the string (i.e. not UCS-2, UCS-4, UTF-16, UTF-32). + Allocate a malloced memory block for the result. + Return value: the freshly allocated resulting NUL-terminated string if + successful, otherwise NULL and errno set. */ +extern char * + str_iconveh (const char *src, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler); + + +#ifdef __cplusplus +} +#endif + + +#endif /* _STRICONVEH_H */ diff --git a/lib/string.in.h b/lib/string.in.h new file mode 100644 index 000000000..ca029d7c0 --- /dev/null +++ b/lib/string.in.h @@ -0,0 +1,605 @@ +/* A GNU-like . + + Copyright (C) 1995-1996, 2001-2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _GL_STRING_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_STRING_H@ + +#ifndef _GL_STRING_H +#define _GL_STRING_H + + +#ifndef __attribute__ +/* This feature is available in gcc versions 2.5 and later. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5) +# define __attribute__(Spec) /* empty */ +# endif +/* The attribute __pure__ was added in gcc 2.96. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96) +# define __pure__ /* empty */ +# endif +#endif + + +/* The definition of GL_LINK_WARNING is copied here. */ + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Return the first occurrence of NEEDLE in HAYSTACK. */ +#if @GNULIB_MEMMEM@ +# if @REPLACE_MEMMEM@ +# define memmem rpl_memmem +# endif +# if ! @HAVE_DECL_MEMMEM@ || @REPLACE_MEMMEM@ +extern void *memmem (void const *__haystack, size_t __haystack_len, + void const *__needle, size_t __needle_len) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef memmem +# define memmem(a,al,b,bl) \ + (GL_LINK_WARNING ("memmem is unportable and often quadratic - " \ + "use gnulib module memmem-simple for portability, " \ + "and module memmem for speed" ), \ + memmem (a, al, b, bl)) +#endif + +/* Copy N bytes of SRC to DEST, return pointer to bytes after the + last written byte. */ +#if @GNULIB_MEMPCPY@ +# if ! @HAVE_MEMPCPY@ +extern void *mempcpy (void *restrict __dest, void const *restrict __src, + size_t __n); +# endif +#elif defined GNULIB_POSIXCHECK +# undef mempcpy +# define mempcpy(a,b,n) \ + (GL_LINK_WARNING ("mempcpy is unportable - " \ + "use gnulib module mempcpy for portability"), \ + mempcpy (a, b, n)) +#endif + +/* Search backwards through a block for a byte (specified as an int). */ +#if @GNULIB_MEMRCHR@ +# if ! @HAVE_DECL_MEMRCHR@ +extern void *memrchr (void const *, int, size_t) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef memrchr +# define memrchr(a,b,c) \ + (GL_LINK_WARNING ("memrchr is unportable - " \ + "use gnulib module memrchr for portability"), \ + memrchr (a, b, c)) +#endif + +/* Find the first occurrence of C in S. More efficient than + memchr(S,C,N), at the expense of undefined behavior if C does not + occur within N bytes. */ +#if @GNULIB_RAWMEMCHR@ +# if ! @HAVE_RAWMEMCHR@ +extern void *rawmemchr (void const *__s, int __c_in) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef rawmemchr +# define rawmemchr(a,b) \ + (GL_LINK_WARNING ("rawmemchr is unportable - " \ + "use gnulib module rawmemchr for portability"), \ + rawmemchr (a, b)) +#endif + +/* Copy SRC to DST, returning the address of the terminating '\0' in DST. */ +#if @GNULIB_STPCPY@ +# if ! @HAVE_STPCPY@ +extern char *stpcpy (char *restrict __dst, char const *restrict __src); +# endif +#elif defined GNULIB_POSIXCHECK +# undef stpcpy +# define stpcpy(a,b) \ + (GL_LINK_WARNING ("stpcpy is unportable - " \ + "use gnulib module stpcpy for portability"), \ + stpcpy (a, b)) +#endif + +/* Copy no more than N bytes of SRC to DST, returning a pointer past the + last non-NUL byte written into DST. */ +#if @GNULIB_STPNCPY@ +# if ! @HAVE_STPNCPY@ +# define stpncpy gnu_stpncpy +extern char *stpncpy (char *restrict __dst, char const *restrict __src, + size_t __n); +# endif +#elif defined GNULIB_POSIXCHECK +# undef stpncpy +# define stpncpy(a,b,n) \ + (GL_LINK_WARNING ("stpncpy is unportable - " \ + "use gnulib module stpncpy for portability"), \ + stpncpy (a, b, n)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strchr() does not work with multibyte strings if the locale encoding is + GB18030 and the character to be searched is a digit. */ +# undef strchr +# define strchr(s,c) \ + (GL_LINK_WARNING ("strchr cannot work correctly on character strings " \ + "in some multibyte locales - " \ + "use mbschr if you care about internationalization"), \ + strchr (s, c)) +#endif + +/* Find the first occurrence of C in S or the final NUL byte. */ +#if @GNULIB_STRCHRNUL@ +# if ! @HAVE_STRCHRNUL@ +extern char *strchrnul (char const *__s, int __c_in) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strchrnul +# define strchrnul(a,b) \ + (GL_LINK_WARNING ("strchrnul is unportable - " \ + "use gnulib module strchrnul for portability"), \ + strchrnul (a, b)) +#endif + +/* Duplicate S, returning an identical malloc'd string. */ +#if @GNULIB_STRDUP@ +# if @REPLACE_STRDUP@ +# undef strdup +# define strdup rpl_strdup +# endif +# if !(@HAVE_DECL_STRDUP@ || defined strdup) || @REPLACE_STRDUP@ +extern char *strdup (char const *__s); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strdup +# define strdup(a) \ + (GL_LINK_WARNING ("strdup is unportable - " \ + "use gnulib module strdup for portability"), \ + strdup (a)) +#endif + +/* Return a newly allocated copy of at most N bytes of STRING. */ +#if @GNULIB_STRNDUP@ +# if ! @HAVE_STRNDUP@ +# undef strndup +# define strndup rpl_strndup +# endif +# if ! @HAVE_STRNDUP@ || ! @HAVE_DECL_STRNDUP@ +extern char *strndup (char const *__string, size_t __n); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strndup +# define strndup(a,n) \ + (GL_LINK_WARNING ("strndup is unportable - " \ + "use gnulib module strndup for portability"), \ + strndup (a, n)) +#endif + +/* Find the length (number of bytes) of STRING, but scan at most + MAXLEN bytes. If no '\0' terminator is found in that many bytes, + return MAXLEN. */ +#if @GNULIB_STRNLEN@ +# if ! @HAVE_DECL_STRNLEN@ +extern size_t strnlen (char const *__string, size_t __maxlen) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strnlen +# define strnlen(a,n) \ + (GL_LINK_WARNING ("strnlen is unportable - " \ + "use gnulib module strnlen for portability"), \ + strnlen (a, n)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strcspn() assumes the second argument is a list of single-byte characters. + Even in this simple case, it does not work with multibyte strings if the + locale encoding is GB18030 and one of the characters to be searched is a + digit. */ +# undef strcspn +# define strcspn(s,a) \ + (GL_LINK_WARNING ("strcspn cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbscspn if you care about internationalization"), \ + strcspn (s, a)) +#endif + +/* Find the first occurrence in S of any character in ACCEPT. */ +#if @GNULIB_STRPBRK@ +# if ! @HAVE_STRPBRK@ +extern char *strpbrk (char const *__s, char const *__accept) + __attribute__ ((__pure__)); +# endif +# if defined GNULIB_POSIXCHECK +/* strpbrk() assumes the second argument is a list of single-byte characters. + Even in this simple case, it does not work with multibyte strings if the + locale encoding is GB18030 and one of the characters to be searched is a + digit. */ +# undef strpbrk +# define strpbrk(s,a) \ + (GL_LINK_WARNING ("strpbrk cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbspbrk if you care about internationalization"), \ + strpbrk (s, a)) +# endif +#elif defined GNULIB_POSIXCHECK +# undef strpbrk +# define strpbrk(s,a) \ + (GL_LINK_WARNING ("strpbrk is unportable - " \ + "use gnulib module strpbrk for portability"), \ + strpbrk (s, a)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strspn() assumes the second argument is a list of single-byte characters. + Even in this simple case, it cannot work with multibyte strings. */ +# undef strspn +# define strspn(s,a) \ + (GL_LINK_WARNING ("strspn cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbsspn if you care about internationalization"), \ + strspn (s, a)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strrchr() does not work with multibyte strings if the locale encoding is + GB18030 and the character to be searched is a digit. */ +# undef strrchr +# define strrchr(s,c) \ + (GL_LINK_WARNING ("strrchr cannot work correctly on character strings " \ + "in some multibyte locales - " \ + "use mbsrchr if you care about internationalization"), \ + strrchr (s, c)) +#endif + +/* Search the next delimiter (char listed in DELIM) starting at *STRINGP. + If one is found, overwrite it with a NUL, and advance *STRINGP + to point to the next char after it. Otherwise, set *STRINGP to NULL. + If *STRINGP was already NULL, nothing happens. + Return the old value of *STRINGP. + + This is a variant of strtok() that is multithread-safe and supports + empty fields. + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + Caveat: It doesn't work with multibyte strings unless all of the delimiter + characters are ASCII characters < 0x30. + + See also strtok_r(). */ +#if @GNULIB_STRSEP@ +# if ! @HAVE_STRSEP@ +extern char *strsep (char **restrict __stringp, char const *restrict __delim); +# endif +# if defined GNULIB_POSIXCHECK +# undef strsep +# define strsep(s,d) \ + (GL_LINK_WARNING ("strsep cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbssep if you care about internationalization"), \ + strsep (s, d)) +# endif +#elif defined GNULIB_POSIXCHECK +# undef strsep +# define strsep(s,d) \ + (GL_LINK_WARNING ("strsep is unportable - " \ + "use gnulib module strsep for portability"), \ + strsep (s, d)) +#endif + +#if @GNULIB_STRSTR@ +# if @REPLACE_STRSTR@ +# define strstr rpl_strstr +char *strstr (const char *haystack, const char *needle) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +/* strstr() does not work with multibyte strings if the locale encoding is + different from UTF-8: + POSIX says that it operates on "strings", and "string" in POSIX is defined + as a sequence of bytes, not of characters. */ +# undef strstr +# define strstr(a,b) \ + (GL_LINK_WARNING ("strstr is quadratic on many systems, and cannot " \ + "work correctly on character strings in most " \ + "multibyte locales - " \ + "use mbsstr if you care about internationalization, " \ + "or use strstr if you care about speed"), \ + strstr (a, b)) +#endif + +/* Find the first occurrence of NEEDLE in HAYSTACK, using case-insensitive + comparison. */ +#if @GNULIB_STRCASESTR@ +# if @REPLACE_STRCASESTR@ +# define strcasestr rpl_strcasestr +# endif +# if ! @HAVE_STRCASESTR@ || @REPLACE_STRCASESTR@ +extern char *strcasestr (const char *haystack, const char *needle) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +/* strcasestr() does not work with multibyte strings: + It is a glibc extension, and glibc implements it only for unibyte + locales. */ +# undef strcasestr +# define strcasestr(a,b) \ + (GL_LINK_WARNING ("strcasestr does work correctly on character strings " \ + "in multibyte locales - " \ + "use mbscasestr if you care about " \ + "internationalization, or use c-strcasestr if you want " \ + "a locale independent function"), \ + strcasestr (a, b)) +#endif + +/* Parse S into tokens separated by characters in DELIM. + If S is NULL, the saved pointer in SAVE_PTR is used as + the next starting point. For example: + char s[] = "-abc-=-def"; + char *sp; + x = strtok_r(s, "-", &sp); // x = "abc", sp = "=-def" + x = strtok_r(NULL, "-=", &sp); // x = "def", sp = NULL + x = strtok_r(NULL, "=", &sp); // x = NULL + // s = "abc\0-def\0" + + This is a variant of strtok() that is multithread-safe. + + For the POSIX documentation for this function, see: + http://www.opengroup.org/susv3xsh/strtok.html + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + Caveat: It doesn't work with multibyte strings unless all of the delimiter + characters are ASCII characters < 0x30. + + See also strsep(). */ +#if @GNULIB_STRTOK_R@ +# if ! @HAVE_DECL_STRTOK_R@ +extern char *strtok_r (char *restrict s, char const *restrict delim, + char **restrict save_ptr); +# endif +# if defined GNULIB_POSIXCHECK +# undef strtok_r +# define strtok_r(s,d,p) \ + (GL_LINK_WARNING ("strtok_r cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbstok_r if you care about internationalization"), \ + strtok_r (s, d, p)) +# endif +#elif defined GNULIB_POSIXCHECK +# undef strtok_r +# define strtok_r(s,d,p) \ + (GL_LINK_WARNING ("strtok_r is unportable - " \ + "use gnulib module strtok_r for portability"), \ + strtok_r (s, d, p)) +#endif + + +/* The following functions are not specified by POSIX. They are gnulib + extensions. */ + +#if @GNULIB_MBSLEN@ +/* Return the number of multibyte characters in the character string STRING. + This considers multibyte characters, unlike strlen, which counts bytes. */ +extern size_t mbslen (const char *string); +#endif + +#if @GNULIB_MBSNLEN@ +/* Return the number of multibyte characters in the character string starting + at STRING and ending at STRING + LEN. */ +extern size_t mbsnlen (const char *string, size_t len); +#endif + +#if @GNULIB_MBSCHR@ +/* Locate the first single-byte character C in the character string STRING, + and return a pointer to it. Return NULL if C is not found in STRING. + Unlike strchr(), this function works correctly in multibyte locales with + encodings such as GB18030. */ +# define mbschr rpl_mbschr /* avoid collision with HP-UX function */ +extern char * mbschr (const char *string, int c); +#endif + +#if @GNULIB_MBSRCHR@ +/* Locate the last single-byte character C in the character string STRING, + and return a pointer to it. Return NULL if C is not found in STRING. + Unlike strrchr(), this function works correctly in multibyte locales with + encodings such as GB18030. */ +# define mbsrchr rpl_mbsrchr /* avoid collision with HP-UX function */ +extern char * mbsrchr (const char *string, int c); +#endif + +#if @GNULIB_MBSSTR@ +/* Find the first occurrence of the character string NEEDLE in the character + string HAYSTACK. Return NULL if NEEDLE is not found in HAYSTACK. + Unlike strstr(), this function works correctly in multibyte locales with + encodings different from UTF-8. */ +extern char * mbsstr (const char *haystack, const char *needle); +#endif + +#if @GNULIB_MBSCASECMP@ +/* Compare the character strings S1 and S2, ignoring case, returning less than, + equal to or greater than zero if S1 is lexicographically less than, equal to + or greater than S2. + Note: This function may, in multibyte locales, return 0 for strings of + different lengths! + Unlike strcasecmp(), this function works correctly in multibyte locales. */ +extern int mbscasecmp (const char *s1, const char *s2); +#endif + +#if @GNULIB_MBSNCASECMP@ +/* Compare the initial segment of the character string S1 consisting of at most + N characters with the initial segment of the character string S2 consisting + of at most N characters, ignoring case, returning less than, equal to or + greater than zero if the initial segment of S1 is lexicographically less + than, equal to or greater than the initial segment of S2. + Note: This function may, in multibyte locales, return 0 for initial segments + of different lengths! + Unlike strncasecmp(), this function works correctly in multibyte locales. + But beware that N is not a byte count but a character count! */ +extern int mbsncasecmp (const char *s1, const char *s2, size_t n); +#endif + +#if @GNULIB_MBSPCASECMP@ +/* Compare the initial segment of the character string STRING consisting of + at most mbslen (PREFIX) characters with the character string PREFIX, + ignoring case, returning less than, equal to or greater than zero if this + initial segment is lexicographically less than, equal to or greater than + PREFIX. + Note: This function may, in multibyte locales, return 0 if STRING is of + smaller length than PREFIX! + Unlike strncasecmp(), this function works correctly in multibyte + locales. */ +extern char * mbspcasecmp (const char *string, const char *prefix); +#endif + +#if @GNULIB_MBSCASESTR@ +/* Find the first occurrence of the character string NEEDLE in the character + string HAYSTACK, using case-insensitive comparison. + Note: This function may, in multibyte locales, return success even if + strlen (haystack) < strlen (needle) ! + Unlike strcasestr(), this function works correctly in multibyte locales. */ +extern char * mbscasestr (const char *haystack, const char *needle); +#endif + +#if @GNULIB_MBSCSPN@ +/* Find the first occurrence in the character string STRING of any character + in the character string ACCEPT. Return the number of bytes from the + beginning of the string to this occurrence, or to the end of the string + if none exists. + Unlike strcspn(), this function works correctly in multibyte locales. */ +extern size_t mbscspn (const char *string, const char *accept); +#endif + +#if @GNULIB_MBSPBRK@ +/* Find the first occurrence in the character string STRING of any character + in the character string ACCEPT. Return the pointer to it, or NULL if none + exists. + Unlike strpbrk(), this function works correctly in multibyte locales. */ +# define mbspbrk rpl_mbspbrk /* avoid collision with HP-UX function */ +extern char * mbspbrk (const char *string, const char *accept); +#endif + +#if @GNULIB_MBSSPN@ +/* Find the first occurrence in the character string STRING of any character + not in the character string REJECT. Return the number of bytes from the + beginning of the string to this occurrence, or to the end of the string + if none exists. + Unlike strspn(), this function works correctly in multibyte locales. */ +extern size_t mbsspn (const char *string, const char *reject); +#endif + +#if @GNULIB_MBSSEP@ +/* Search the next delimiter (multibyte character listed in the character + string DELIM) starting at the character string *STRINGP. + If one is found, overwrite it with a NUL, and advance *STRINGP to point + to the next multibyte character after it. Otherwise, set *STRINGP to NULL. + If *STRINGP was already NULL, nothing happens. + Return the old value of *STRINGP. + + This is a variant of mbstok_r() that supports empty fields. + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + + See also mbstok_r(). */ +extern char * mbssep (char **stringp, const char *delim); +#endif + +#if @GNULIB_MBSTOK_R@ +/* Parse the character string STRING into tokens separated by characters in + the character string DELIM. + If STRING is NULL, the saved pointer in SAVE_PTR is used as + the next starting point. For example: + char s[] = "-abc-=-def"; + char *sp; + x = mbstok_r(s, "-", &sp); // x = "abc", sp = "=-def" + x = mbstok_r(NULL, "-=", &sp); // x = "def", sp = NULL + x = mbstok_r(NULL, "=", &sp); // x = NULL + // s = "abc\0-def\0" + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + + See also mbssep(). */ +extern char * mbstok_r (char *string, const char *delim, char **save_ptr); +#endif + +/* Map any int, typically from errno, into an error message. */ +#if @GNULIB_STRERROR@ +# if @REPLACE_STRERROR@ +# undef strerror +# define strerror rpl_strerror +extern char *strerror (int); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strerror +# define strerror(e) \ + (GL_LINK_WARNING ("strerror is unportable - " \ + "use gnulib module strerror to guarantee non-NULL result"), \ + strerror (e)) +#endif + +#if @GNULIB_STRSIGNAL@ +# if @REPLACE_STRSIGNAL@ +# define strsignal rpl_strsignal +# endif +# if ! @HAVE_DECL_STRSIGNAL@ || @REPLACE_STRSIGNAL@ +extern char *strsignal (int __sig); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strsignal +# define strsignal(a) \ + (GL_LINK_WARNING ("strsignal is unportable - " \ + "use gnulib module strsignal for portability"), \ + strsignal (a)) +#endif + +#if @GNULIB_STRVERSCMP@ +# if !@HAVE_STRVERSCMP@ +extern int strverscmp (const char *, const char *); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strverscmp +# define strverscmp(a, b) \ + (GL_LINK_WARNING ("strverscmp is unportable - " \ + "use gnulib module strverscmp for portability"), \ + strverscmp (a, b)) +#endif + + +#ifdef __cplusplus +} +#endif + +#endif /* _GL_STRING_H */ +#endif /* _GL_STRING_H */ diff --git a/lib/unistr.h b/lib/unistr.h new file mode 100644 index 000000000..83ff13411 --- /dev/null +++ b/lib/unistr.h @@ -0,0 +1,681 @@ +/* Elementary Unicode string functions. + Copyright (C) 2001-2002, 2005-2009 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef _UNISTR_H +#define _UNISTR_H + +#include "unitypes.h" + +/* Get bool. */ +#include + +/* Get size_t. */ +#include + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Conventions: + + All functions prefixed with u8_ operate on UTF-8 encoded strings. + Their unit is an uint8_t (1 byte). + + All functions prefixed with u16_ operate on UTF-16 encoded strings. + Their unit is an uint16_t (a 2-byte word). + + All functions prefixed with u32_ operate on UCS-4 encoded strings. + Their unit is an uint32_t (a 4-byte word). + + All argument pairs (s, n) denote a Unicode string s[0..n-1] with exactly + n units. + + All arguments starting with "str" and the arguments of functions starting + with u8_str/u16_str/u32_str denote a NUL terminated string, i.e. a string + which terminates at the first NUL unit. This termination unit is + considered part of the string for all memory allocation purposes, but + is not considered part of the string for all other logical purposes. + + Functions returning a string result take a (resultbuf, lengthp) argument + pair. If resultbuf is not NULL and the result fits into *lengthp units, + it is put in resultbuf, and resultbuf is returned. Otherwise, a freshly + allocated string is returned. In both cases, *lengthp is set to the + length (number of units) of the returned string. In case of error, + NULL is returned and errno is set. */ + + +/* Elementary string checks. */ + +/* Check whether an UTF-8 string is well-formed. + Return NULL if valid, or a pointer to the first invalid unit otherwise. */ +extern const uint8_t * + u8_check (const uint8_t *s, size_t n); + +/* Check whether an UTF-16 string is well-formed. + Return NULL if valid, or a pointer to the first invalid unit otherwise. */ +extern const uint16_t * + u16_check (const uint16_t *s, size_t n); + +/* Check whether an UCS-4 string is well-formed. + Return NULL if valid, or a pointer to the first invalid unit otherwise. */ +extern const uint32_t * + u32_check (const uint32_t *s, size_t n); + + +/* Elementary string conversions. */ + +/* Convert an UTF-8 string to an UTF-16 string. */ +extern uint16_t * + u8_to_u16 (const uint8_t *s, size_t n, uint16_t *resultbuf, + size_t *lengthp); + +/* Convert an UTF-8 string to an UCS-4 string. */ +extern uint32_t * + u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, + size_t *lengthp); + +/* Convert an UTF-16 string to an UTF-8 string. */ +extern uint8_t * + u16_to_u8 (const uint16_t *s, size_t n, uint8_t *resultbuf, + size_t *lengthp); + +/* Convert an UTF-16 string to an UCS-4 string. */ +extern uint32_t * + u16_to_u32 (const uint16_t *s, size_t n, uint32_t *resultbuf, + size_t *lengthp); + +/* Convert an UCS-4 string to an UTF-8 string. */ +extern uint8_t * + u32_to_u8 (const uint32_t *s, size_t n, uint8_t *resultbuf, + size_t *lengthp); + +/* Convert an UCS-4 string to an UTF-16 string. */ +extern uint16_t * + u32_to_u16 (const uint32_t *s, size_t n, uint16_t *resultbuf, + size_t *lengthp); + + +/* Elementary string functions. */ + +/* Return the length (number of units) of the first character in S, which is + no longer than N. Return 0 if it is the NUL character. Return -1 upon + failure. */ +/* Similar to mblen(), except that s must not be NULL. */ +extern int + u8_mblen (const uint8_t *s, size_t n); +extern int + u16_mblen (const uint16_t *s, size_t n); +extern int + u32_mblen (const uint32_t *s, size_t n); + +/* Return the length (number of units) of the first character in S, putting + its 'ucs4_t' representation in *PUC. Upon failure, *PUC is set to 0xfffd, + and an appropriate number of units is returned. + The number of available units, N, must be > 0. */ +/* Similar to mbtowc(), except that puc and s must not be NULL, n must be > 0, + and the NUL character is not treated specially. */ +/* The variants with _safe suffix are safe, even if the library is compiled + without --enable-safety. */ + +#ifdef GNULIB_UNISTR_U8_MBTOUC_UNSAFE +# if !HAVE_INLINE +extern int + u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n); +# else +extern int + u8_mbtouc_unsafe_aux (ucs4_t *puc, const uint8_t *s, size_t n); +static inline int +u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else + return u8_mbtouc_unsafe_aux (puc, s, n); +} +# endif +#endif + +#ifdef GNULIB_UNISTR_U16_MBTOUC_UNSAFE +# if !HAVE_INLINE +extern int + u16_mbtouc_unsafe (ucs4_t *puc, const uint16_t *s, size_t n); +# else +extern int + u16_mbtouc_unsafe_aux (ucs4_t *puc, const uint16_t *s, size_t n); +static inline int +u16_mbtouc_unsafe (ucs4_t *puc, const uint16_t *s, size_t n) +{ + uint16_t c = *s; + + if (c < 0xd800 || c >= 0xe000) + { + *puc = c; + return 1; + } + else + return u16_mbtouc_unsafe_aux (puc, s, n); +} +# endif +#endif + +#ifdef GNULIB_UNISTR_U32_MBTOUC_UNSAFE +# if !HAVE_INLINE +extern int + u32_mbtouc_unsafe (ucs4_t *puc, const uint32_t *s, size_t n); +# else +static inline int +u32_mbtouc_unsafe (ucs4_t *puc, const uint32_t *s, size_t n _UNUSED_PARAMETER_) +{ + uint32_t c = *s; + +# if CONFIG_UNICODE_SAFETY + if (c < 0xd800 || (c >= 0xe000 && c < 0x110000)) +# endif + *puc = c; +# if CONFIG_UNICODE_SAFETY + else + /* invalid multibyte character */ + *puc = 0xfffd; +# endif + return 1; +} +# endif +#endif + +#ifdef GNULIB_UNISTR_U8_MBTOUC +# if !HAVE_INLINE +extern int + u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n); +# else +extern int + u8_mbtouc_aux (ucs4_t *puc, const uint8_t *s, size_t n); +static inline int +u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else + return u8_mbtouc_aux (puc, s, n); +} +# endif +#endif + +#ifdef GNULIB_UNISTR_U16_MBTOUC +# if !HAVE_INLINE +extern int + u16_mbtouc (ucs4_t *puc, const uint16_t *s, size_t n); +# else +extern int + u16_mbtouc_aux (ucs4_t *puc, const uint16_t *s, size_t n); +static inline int +u16_mbtouc (ucs4_t *puc, const uint16_t *s, size_t n) +{ + uint16_t c = *s; + + if (c < 0xd800 || c >= 0xe000) + { + *puc = c; + return 1; + } + else + return u16_mbtouc_aux (puc, s, n); +} +# endif +#endif + +#ifdef GNULIB_UNISTR_U32_MBTOUC +# if !HAVE_INLINE +extern int + u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n); +# else +static inline int +u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n _UNUSED_PARAMETER_) +{ + uint32_t c = *s; + + if (c < 0xd800 || (c >= 0xe000 && c < 0x110000)) + *puc = c; + else + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; +} +# endif +#endif + +/* Return the length (number of units) of the first character in S, putting + its 'ucs4_t' representation in *PUC. Upon failure, *PUC is set to 0xfffd, + and -1 is returned for an invalid sequence of units, -2 is returned for an + incomplete sequence of units. + The number of available units, N, must be > 0. */ +/* Similar to u*_mbtouc(), except that the return value gives more details + about the failure, similar to mbrtowc(). */ + +#ifdef GNULIB_UNISTR_U8_MBTOUCR +extern int + u8_mbtoucr (ucs4_t *puc, const uint8_t *s, size_t n); +#endif + +#ifdef GNULIB_UNISTR_U16_MBTOUCR +extern int + u16_mbtoucr (ucs4_t *puc, const uint16_t *s, size_t n); +#endif + +#ifdef GNULIB_UNISTR_U32_MBTOUCR +extern int + u32_mbtoucr (ucs4_t *puc, const uint32_t *s, size_t n); +#endif + +/* Put the multibyte character represented by UC in S, returning its + length. Return -1 upon failure, -2 if the number of available units, N, + is too small. The latter case cannot occur if N >= 6/2/1, respectively. */ +/* Similar to wctomb(), except that s must not be NULL, and the argument n + must be specified. */ + +#ifdef GNULIB_UNISTR_U8_UCTOMB +/* Auxiliary function, also used by u8_chr, u8_strchr, u8_strrchr. */ +extern int + u8_uctomb_aux (uint8_t *s, ucs4_t uc, int n); +# if !HAVE_INLINE +extern int + u8_uctomb (uint8_t *s, ucs4_t uc, int n); +# else +static inline int +u8_uctomb (uint8_t *s, ucs4_t uc, int n) +{ + if (uc < 0x80 && n > 0) + { + s[0] = uc; + return 1; + } + else + return u8_uctomb_aux (s, uc, n); +} +# endif +#endif + +#ifdef GNULIB_UNISTR_U16_UCTOMB +/* Auxiliary function, also used by u16_chr, u16_strchr, u16_strrchr. */ +extern int + u16_uctomb_aux (uint16_t *s, ucs4_t uc, int n); +# if !HAVE_INLINE +extern int + u16_uctomb (uint16_t *s, ucs4_t uc, int n); +# else +static inline int +u16_uctomb (uint16_t *s, ucs4_t uc, int n) +{ + if (uc < 0xd800 && n > 0) + { + s[0] = uc; + return 1; + } + else + return u16_uctomb_aux (s, uc, n); +} +# endif +#endif + +#ifdef GNULIB_UNISTR_U32_UCTOMB +# if !HAVE_INLINE +extern int + u32_uctomb (uint32_t *s, ucs4_t uc, int n); +# else +static inline int +u32_uctomb (uint32_t *s, ucs4_t uc, int n) +{ + if (uc < 0xd800 || (uc >= 0xe000 && uc < 0x110000)) + { + if (n > 0) + { + *s = uc; + return 1; + } + else + return -2; + } + else + return -1; +} +# endif +#endif + +/* Copy N units from SRC to DEST. */ +/* Similar to memcpy(). */ +extern uint8_t * + u8_cpy (uint8_t *dest, const uint8_t *src, size_t n); +extern uint16_t * + u16_cpy (uint16_t *dest, const uint16_t *src, size_t n); +extern uint32_t * + u32_cpy (uint32_t *dest, const uint32_t *src, size_t n); + +/* Copy N units from SRC to DEST, guaranteeing correct behavior for + overlapping memory areas. */ +/* Similar to memmove(). */ +extern uint8_t * + u8_move (uint8_t *dest, const uint8_t *src, size_t n); +extern uint16_t * + u16_move (uint16_t *dest, const uint16_t *src, size_t n); +extern uint32_t * + u32_move (uint32_t *dest, const uint32_t *src, size_t n); + +/* Set the first N characters of S to UC. UC should be a character that + occupies only 1 unit. */ +/* Similar to memset(). */ +extern uint8_t * + u8_set (uint8_t *s, ucs4_t uc, size_t n); +extern uint16_t * + u16_set (uint16_t *s, ucs4_t uc, size_t n); +extern uint32_t * + u32_set (uint32_t *s, ucs4_t uc, size_t n); + +/* Compare S1 and S2, each of length N. */ +/* Similar to memcmp(). */ +extern int + u8_cmp (const uint8_t *s1, const uint8_t *s2, size_t n); +extern int + u16_cmp (const uint16_t *s1, const uint16_t *s2, size_t n); +extern int + u32_cmp (const uint32_t *s1, const uint32_t *s2, size_t n); + +/* Compare S1 and S2. */ +/* Similar to the gnulib function memcmp2(). */ +extern int + u8_cmp2 (const uint8_t *s1, size_t n1, const uint8_t *s2, size_t n2); +extern int + u16_cmp2 (const uint16_t *s1, size_t n1, const uint16_t *s2, size_t n2); +extern int + u32_cmp2 (const uint32_t *s1, size_t n1, const uint32_t *s2, size_t n2); + +/* Search the string at S for UC. */ +/* Similar to memchr(). */ +extern uint8_t * + u8_chr (const uint8_t *s, size_t n, ucs4_t uc); +extern uint16_t * + u16_chr (const uint16_t *s, size_t n, ucs4_t uc); +extern uint32_t * + u32_chr (const uint32_t *s, size_t n, ucs4_t uc); + +/* Count the number of Unicode characters in the N units from S. */ +/* Similar to mbsnlen(). */ +extern size_t + u8_mbsnlen (const uint8_t *s, size_t n); +extern size_t + u16_mbsnlen (const uint16_t *s, size_t n); +extern size_t + u32_mbsnlen (const uint32_t *s, size_t n); + +/* Elementary string functions with memory allocation. */ + +/* Make a freshly allocated copy of S, of length N. */ +extern uint8_t * + u8_cpy_alloc (const uint8_t *s, size_t n); +extern uint16_t * + u16_cpy_alloc (const uint16_t *s, size_t n); +extern uint32_t * + u32_cpy_alloc (const uint32_t *s, size_t n); + +/* Elementary string functions on NUL terminated strings. */ + +/* Return the length (number of units) of the first character in S. + Return 0 if it is the NUL character. Return -1 upon failure. */ +extern int + u8_strmblen (const uint8_t *s); +extern int + u16_strmblen (const uint16_t *s); +extern int + u32_strmblen (const uint32_t *s); + +/* Return the length (number of units) of the first character in S, putting + its 'ucs4_t' representation in *PUC. Return 0 if it is the NUL + character. Return -1 upon failure. */ +extern int + u8_strmbtouc (ucs4_t *puc, const uint8_t *s); +extern int + u16_strmbtouc (ucs4_t *puc, const uint16_t *s); +extern int + u32_strmbtouc (ucs4_t *puc, const uint32_t *s); + +/* Forward iteration step. Advances the pointer past the next character, + or returns NULL if the end of the string has been reached. Puts the + character's 'ucs4_t' representation in *PUC. */ +extern const uint8_t * + u8_next (ucs4_t *puc, const uint8_t *s); +extern const uint16_t * + u16_next (ucs4_t *puc, const uint16_t *s); +extern const uint32_t * + u32_next (ucs4_t *puc, const uint32_t *s); + +/* Backward iteration step. Advances the pointer to point to the previous + character, or returns NULL if the beginning of the string had been reached. + Puts the character's 'ucs4_t' representation in *PUC. */ +extern const uint8_t * + u8_prev (ucs4_t *puc, const uint8_t *s, const uint8_t *start); +extern const uint16_t * + u16_prev (ucs4_t *puc, const uint16_t *s, const uint16_t *start); +extern const uint32_t * + u32_prev (ucs4_t *puc, const uint32_t *s, const uint32_t *start); + +/* Return the number of units in S. */ +/* Similar to strlen(), wcslen(). */ +extern size_t + u8_strlen (const uint8_t *s); +extern size_t + u16_strlen (const uint16_t *s); +extern size_t + u32_strlen (const uint32_t *s); + +/* Return the number of units in S, but at most MAXLEN. */ +/* Similar to strnlen(), wcsnlen(). */ +extern size_t + u8_strnlen (const uint8_t *s, size_t maxlen); +extern size_t + u16_strnlen (const uint16_t *s, size_t maxlen); +extern size_t + u32_strnlen (const uint32_t *s, size_t maxlen); + +/* Copy SRC to DEST. */ +/* Similar to strcpy(), wcscpy(). */ +extern uint8_t * + u8_strcpy (uint8_t *dest, const uint8_t *src); +extern uint16_t * + u16_strcpy (uint16_t *dest, const uint16_t *src); +extern uint32_t * + u32_strcpy (uint32_t *dest, const uint32_t *src); + +/* Copy SRC to DEST, returning the address of the terminating NUL in DEST. */ +/* Similar to stpcpy(). */ +extern uint8_t * + u8_stpcpy (uint8_t *dest, const uint8_t *src); +extern uint16_t * + u16_stpcpy (uint16_t *dest, const uint16_t *src); +extern uint32_t * + u32_stpcpy (uint32_t *dest, const uint32_t *src); + +/* Copy no more than N units of SRC to DEST. */ +/* Similar to strncpy(), wcsncpy(). */ +extern uint8_t * + u8_strncpy (uint8_t *dest, const uint8_t *src, size_t n); +extern uint16_t * + u16_strncpy (uint16_t *dest, const uint16_t *src, size_t n); +extern uint32_t * + u32_strncpy (uint32_t *dest, const uint32_t *src, size_t n); + +/* Copy no more than N units of SRC to DEST, returning the address of + the last unit written into DEST. */ +/* Similar to stpncpy(). */ +extern uint8_t * + u8_stpncpy (uint8_t *dest, const uint8_t *src, size_t n); +extern uint16_t * + u16_stpncpy (uint16_t *dest, const uint16_t *src, size_t n); +extern uint32_t * + u32_stpncpy (uint32_t *dest, const uint32_t *src, size_t n); + +/* Append SRC onto DEST. */ +/* Similar to strcat(), wcscat(). */ +extern uint8_t * + u8_strcat (uint8_t *dest, const uint8_t *src); +extern uint16_t * + u16_strcat (uint16_t *dest, const uint16_t *src); +extern uint32_t * + u32_strcat (uint32_t *dest, const uint32_t *src); + +/* Append no more than N units of SRC onto DEST. */ +/* Similar to strncat(), wcsncat(). */ +extern uint8_t * + u8_strncat (uint8_t *dest, const uint8_t *src, size_t n); +extern uint16_t * + u16_strncat (uint16_t *dest, const uint16_t *src, size_t n); +extern uint32_t * + u32_strncat (uint32_t *dest, const uint32_t *src, size_t n); + +/* Compare S1 and S2. */ +/* Similar to strcmp(), wcscmp(). */ +extern int + u8_strcmp (const uint8_t *s1, const uint8_t *s2); +extern int + u16_strcmp (const uint16_t *s1, const uint16_t *s2); +extern int + u32_strcmp (const uint32_t *s1, const uint32_t *s2); + +/* Compare S1 and S2 using the collation rules of the current locale. + Return -1 if S1 < S2, 0 if S1 = S2, 1 if S1 > S2. + Upon failure, set errno and return any value. */ +/* Similar to strcoll(), wcscoll(). */ +extern int + u8_strcoll (const uint8_t *s1, const uint8_t *s2); +extern int + u16_strcoll (const uint16_t *s1, const uint16_t *s2); +extern int + u32_strcoll (const uint32_t *s1, const uint32_t *s2); + +/* Compare no more than N units of S1 and S2. */ +/* Similar to strncmp(), wcsncmp(). */ +extern int + u8_strncmp (const uint8_t *s1, const uint8_t *s2, size_t n); +extern int + u16_strncmp (const uint16_t *s1, const uint16_t *s2, size_t n); +extern int + u32_strncmp (const uint32_t *s1, const uint32_t *s2, size_t n); + +/* Duplicate S, returning an identical malloc'd string. */ +/* Similar to strdup(), wcsdup(). */ +extern uint8_t * + u8_strdup (const uint8_t *s); +extern uint16_t * + u16_strdup (const uint16_t *s); +extern uint32_t * + u32_strdup (const uint32_t *s); + +/* Find the first occurrence of UC in STR. */ +/* Similar to strchr(), wcschr(). */ +extern uint8_t * + u8_strchr (const uint8_t *str, ucs4_t uc); +extern uint16_t * + u16_strchr (const uint16_t *str, ucs4_t uc); +extern uint32_t * + u32_strchr (const uint32_t *str, ucs4_t uc); + +/* Find the last occurrence of UC in STR. */ +/* Similar to strrchr(), wcsrchr(). */ +extern uint8_t * + u8_strrchr (const uint8_t *str, ucs4_t uc); +extern uint16_t * + u16_strrchr (const uint16_t *str, ucs4_t uc); +extern uint32_t * + u32_strrchr (const uint32_t *str, ucs4_t uc); + +/* Return the length of the initial segment of STR which consists entirely + of Unicode characters not in REJECT. */ +/* Similar to strcspn(), wcscspn(). */ +extern size_t + u8_strcspn (const uint8_t *str, const uint8_t *reject); +extern size_t + u16_strcspn (const uint16_t *str, const uint16_t *reject); +extern size_t + u32_strcspn (const uint32_t *str, const uint32_t *reject); + +/* Return the length of the initial segment of STR which consists entirely + of Unicode characters in ACCEPT. */ +/* Similar to strspn(), wcsspn(). */ +extern size_t + u8_strspn (const uint8_t *str, const uint8_t *accept); +extern size_t + u16_strspn (const uint16_t *str, const uint16_t *accept); +extern size_t + u32_strspn (const uint32_t *str, const uint32_t *accept); + +/* Find the first occurrence in STR of any character in ACCEPT. */ +/* Similar to strpbrk(), wcspbrk(). */ +extern uint8_t * + u8_strpbrk (const uint8_t *str, const uint8_t *accept); +extern uint16_t * + u16_strpbrk (const uint16_t *str, const uint16_t *accept); +extern uint32_t * + u32_strpbrk (const uint32_t *str, const uint32_t *accept); + +/* Find the first occurrence of NEEDLE in HAYSTACK. */ +/* Similar to strstr(), wcsstr(). */ +extern uint8_t * + u8_strstr (const uint8_t *haystack, const uint8_t *needle); +extern uint16_t * + u16_strstr (const uint16_t *haystack, const uint16_t *needle); +extern uint32_t * + u32_strstr (const uint32_t *haystack, const uint32_t *needle); + +/* Test whether STR starts with PREFIX. */ +extern bool + u8_startswith (const uint8_t *str, const uint8_t *prefix); +extern bool + u16_startswith (const uint16_t *str, const uint16_t *prefix); +extern bool + u32_startswith (const uint32_t *str, const uint32_t *prefix); + +/* Test whether STR ends with SUFFIX. */ +extern bool + u8_endswith (const uint8_t *str, const uint8_t *suffix); +extern bool + u16_endswith (const uint16_t *str, const uint16_t *suffix); +extern bool + u32_endswith (const uint32_t *str, const uint32_t *suffix); + +/* Divide STR into tokens separated by characters in DELIM. + This interface is actually more similar to wcstok than to strtok. */ +/* Similar to strtok_r(), wcstok(). */ +extern uint8_t * + u8_strtok (uint8_t *str, const uint8_t *delim, uint8_t **ptr); +extern uint16_t * + u16_strtok (uint16_t *str, const uint16_t *delim, uint16_t **ptr); +extern uint32_t * + u32_strtok (uint32_t *str, const uint32_t *delim, uint32_t **ptr); + + +#ifdef __cplusplus +} +#endif + +#endif /* _UNISTR_H */ diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c new file mode 100644 index 000000000..53d02bf0d --- /dev/null +++ b/lib/unistr/u8-mbtouc-aux.c @@ -0,0 +1,158 @@ +/* Conversion UTF-8 to UCS-4. + Copyright (C) 2001-2002, 2006-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible , 2001. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include "unistr.h" + +#if defined IN_LIBUNISTRING || HAVE_INLINE + +int +u8_mbtouc_aux (ucs4_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) +#if 1 + && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) +#endif + ) + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (c >= 0xf9 || s[1] >= 0x88)) + { + *puc = ((unsigned int) (c & 0x03) << 24) + | ((unsigned int) (s[1] ^ 0x80) << 18) + | ((unsigned int) (s[2] ^ 0x80) << 12) + | ((unsigned int) (s[3] ^ 0x80) << 6) + | (unsigned int) (s[4] ^ 0x80); + return 5; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (c >= 0xfd || s[1] >= 0x84)) + { + *puc = ((unsigned int) (c & 0x01) << 30) + | ((unsigned int) (s[1] ^ 0x80) << 24) + | ((unsigned int) (s[2] ^ 0x80) << 18) + | ((unsigned int) (s[3] ^ 0x80) << 12) + | ((unsigned int) (s[4] ^ 0x80) << 6) + | (unsigned int) (s[5] ^ 0x80); + return 6; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#endif + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; +} + +#endif diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c b/lib/unistr/u8-mbtouc-unsafe-aux.c new file mode 100644 index 000000000..43e4a360f --- /dev/null +++ b/lib/unistr/u8-mbtouc-unsafe-aux.c @@ -0,0 +1,168 @@ +/* Conversion UTF-8 to UCS-4. + Copyright (C) 2001-2002, 2006-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible , 2001. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include "unistr.h" + +#if defined IN_LIBUNISTRING || HAVE_INLINE + +int +u8_mbtouc_unsafe_aux (ucs4_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40) +#endif + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) +#endif + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) +#if 1 + && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) +#endif + ) +#endif + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (c >= 0xf9 || s[1] >= 0x88)) +#endif + { + *puc = ((unsigned int) (c & 0x03) << 24) + | ((unsigned int) (s[1] ^ 0x80) << 18) + | ((unsigned int) (s[2] ^ 0x80) << 12) + | ((unsigned int) (s[3] ^ 0x80) << 6) + | (unsigned int) (s[4] ^ 0x80); + return 5; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (c >= 0xfd || s[1] >= 0x84)) +#endif + { + *puc = ((unsigned int) (c & 0x01) << 30) + | ((unsigned int) (s[1] ^ 0x80) << 24) + | ((unsigned int) (s[2] ^ 0x80) << 18) + | ((unsigned int) (s[3] ^ 0x80) << 12) + | ((unsigned int) (s[4] ^ 0x80) << 6) + | (unsigned int) (s[5] ^ 0x80); + return 6; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#endif + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; +} + +#endif diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c new file mode 100644 index 000000000..466156967 --- /dev/null +++ b/lib/unistr/u8-mbtouc-unsafe.c @@ -0,0 +1,179 @@ +/* Look at first character in UTF-8 string. + Copyright (C) 1999-2002, 2006-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible , 2001. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +#if defined IN_LIBUNISTRING +/* Tell unistr.h to declare u8_mbtouc_unsafe as 'extern', not + 'static inline'. */ +# include "unistring-notinline.h" +#endif + +/* Specification. */ +#include "unistr.h" + +#if !HAVE_INLINE + +int +u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40) +#endif + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) +#endif + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) +#if 1 + && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) +#endif + ) +#endif + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (c >= 0xf9 || s[1] >= 0x88)) +#endif + { + *puc = ((unsigned int) (c & 0x03) << 24) + | ((unsigned int) (s[1] ^ 0x80) << 18) + | ((unsigned int) (s[2] ^ 0x80) << 12) + | ((unsigned int) (s[3] ^ 0x80) << 6) + | (unsigned int) (s[4] ^ 0x80); + return 5; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (c >= 0xfd || s[1] >= 0x84)) +#endif + { + *puc = ((unsigned int) (c & 0x01) << 30) + | ((unsigned int) (s[1] ^ 0x80) << 24) + | ((unsigned int) (s[2] ^ 0x80) << 18) + | ((unsigned int) (s[3] ^ 0x80) << 12) + | ((unsigned int) (s[4] ^ 0x80) << 6) + | (unsigned int) (s[5] ^ 0x80); + return 6; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#endif + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; +} + +#endif diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c new file mode 100644 index 000000000..ff624f17d --- /dev/null +++ b/lib/unistr/u8-mbtouc.c @@ -0,0 +1,168 @@ +/* Look at first character in UTF-8 string. + Copyright (C) 1999-2002, 2006-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible , 2001. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +#if defined IN_LIBUNISTRING +/* Tell unistr.h to declare u8_mbtouc as 'extern', not 'static inline'. */ +# include "unistring-notinline.h" +#endif + +/* Specification. */ +#include "unistr.h" + +#if !HAVE_INLINE + +int +u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) +#if 1 + && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) +#endif + ) + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (c >= 0xf9 || s[1] >= 0x88)) + { + *puc = ((unsigned int) (c & 0x03) << 24) + | ((unsigned int) (s[1] ^ 0x80) << 18) + | ((unsigned int) (s[2] ^ 0x80) << 12) + | ((unsigned int) (s[3] ^ 0x80) << 6) + | (unsigned int) (s[4] ^ 0x80); + return 5; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (c >= 0xfd || s[1] >= 0x84)) + { + *puc = ((unsigned int) (c & 0x01) << 30) + | ((unsigned int) (s[1] ^ 0x80) << 24) + | ((unsigned int) (s[2] ^ 0x80) << 18) + | ((unsigned int) (s[3] ^ 0x80) << 12) + | ((unsigned int) (s[4] ^ 0x80) << 6) + | (unsigned int) (s[5] ^ 0x80); + return 6; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#endif + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; +} + +#endif diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c new file mode 100644 index 000000000..dd8335247 --- /dev/null +++ b/lib/unistr/u8-mbtoucr.c @@ -0,0 +1,285 @@ +/* Look at first character in UTF-8 string, returning an error code. + Copyright (C) 1999-2002, 2006-2007 Free Software Foundation, Inc. + Written by Bruno Haible , 2001. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include "unistr.h" + +int +u8_mbtoucr (ucs4_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + else if (c < 0xf0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + else if (c < 0xf8) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) +#if 1 + && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) +#endif + ) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + if (n >= 4) + { + if ((s[3] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf9 || s[1] >= 0x88)) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + if (n >= 4) + { + if ((s[3] ^ 0x80) < 0x40) + { + if (n >= 5) + { + if ((s[4] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x03) << 24) + | ((unsigned int) (s[1] ^ 0x80) << 18) + | ((unsigned int) (s[2] ^ 0x80) << 12) + | ((unsigned int) (s[3] ^ 0x80) << 6) + | (unsigned int) (s[4] ^ 0x80); + return 5; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + else if (c < 0xfe) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xfd || s[1] >= 0x84)) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + if (n >= 4) + { + if ((s[3] ^ 0x80) < 0x40) + { + if (n >= 5) + { + if ((s[4] ^ 0x80) < 0x40) + { + if (n >= 6) + { + if ((s[5] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x01) << 30) + | ((unsigned int) (s[1] ^ 0x80) << 24) + | ((unsigned int) (s[2] ^ 0x80) << 18) + | ((unsigned int) (s[3] ^ 0x80) << 12) + | ((unsigned int) (s[4] ^ 0x80) << 6) + | (unsigned int) (s[5] ^ 0x80); + return 6; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } +#endif + } + /* invalid multibyte character */ + *puc = 0xfffd; + return -1; +} diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c new file mode 100644 index 000000000..245d22ff0 --- /dev/null +++ b/lib/unistr/u8-prev.c @@ -0,0 +1,93 @@ +/* Iterate over previous character in UTF-8 string. + Copyright (C) 2002, 2006-2007 Free Software Foundation, Inc. + Written by Bruno Haible , 2002. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include "unistr.h" + +const uint8_t * +u8_prev (ucs4_t *puc, const uint8_t *s, const uint8_t *start) +{ + /* Keep in sync with unistr.h and utf8-ucs4.c. */ + if (s != start) + { + uint8_t c_1 = s[-1]; + + if (c_1 < 0x80) + { + *puc = c_1; + return s - 1; + } +#if CONFIG_UNICODE_SAFETY + if ((c_1 ^ 0x80) < 0x40) +#endif + if (s - 1 != start) + { + uint8_t c_2 = s[-2]; + + if (c_2 >= 0xc2 && c_2 < 0xe0) + { + *puc = ((unsigned int) (c_2 & 0x1f) << 6) + | (unsigned int) (c_1 ^ 0x80); + return s - 2; + } +#if CONFIG_UNICODE_SAFETY + if ((c_2 ^ 0x80) < 0x40) +#endif + if (s - 2 != start) + { + uint8_t c_3 = s[-3]; + + if (c_3 >= 0xe0 && c_3 < 0xf0 +#if CONFIG_UNICODE_SAFETY + && (c_3 >= 0xe1 || c_2 >= 0xa0) + && (c_3 != 0xed || c_2 < 0xa0) +#endif + ) + { + *puc = ((unsigned int) (c_3 & 0x0f) << 12) + | ((unsigned int) (c_2 ^ 0x80) << 6) + | (unsigned int) (c_1 ^ 0x80); + return s - 3; + } +#if CONFIG_UNICODE_SAFETY + if ((c_3 ^ 0x80) < 0x40) +#endif + if (s - 3 != start) + { + uint8_t c_4 = s[-4]; + + if (c_4 >= 0xf0 && c_4 < 0xf8 +#if CONFIG_UNICODE_SAFETY + && (c_4 >= 0xf1 || c_3 >= 0x90) + && (c_4 < 0xf4 || (c_4 == 0xf4 && c_3 < 0x90)) +#endif + ) + { + *puc = ((unsigned int) (c_4 & 0x07) << 18) + | ((unsigned int) (c_3 ^ 0x80) << 12) + | ((unsigned int) (c_2 ^ 0x80) << 6) + | (unsigned int) (c_1 ^ 0x80); + return s - 4; + } + } + } + } + } + return NULL; +} diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c new file mode 100644 index 000000000..c42fa5015 --- /dev/null +++ b/lib/unistr/u8-uctomb-aux.c @@ -0,0 +1,69 @@ +/* Conversion UCS-4 to UTF-8. + Copyright (C) 2002, 2006-2007 Free Software Foundation, Inc. + Written by Bruno Haible , 2002. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include "unistr.h" + +int +u8_uctomb_aux (uint8_t *s, ucs4_t uc, int n) +{ + int count; + + if (uc < 0x80) + /* The case n >= 1 is already handled by the caller. */ + return -2; + else if (uc < 0x800) + count = 2; + else if (uc < 0x10000) + { + if (uc < 0xd800 || uc >= 0xe000) + count = 3; + else + return -1; + } +#if 0 + else if (uc < 0x200000) + count = 4; + else if (uc < 0x4000000) + count = 5; + else if (uc <= 0x7fffffff) + count = 6; +#else + else if (uc < 0x110000) + count = 4; +#endif + else + return -1; + + if (n < count) + return -2; + + switch (count) /* note: code falls through cases! */ + { +#if 0 + case 6: s[5] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x4000000; + case 5: s[4] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x200000; +#endif + case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000; + case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800; + case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0; + /*case 1:*/ s[0] = uc; + } + return count; +} diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c new file mode 100644 index 000000000..33921669e --- /dev/null +++ b/lib/unistr/u8-uctomb.c @@ -0,0 +1,88 @@ +/* Store a character in UTF-8 string. + Copyright (C) 2002, 2005-2006, 2009 Free Software Foundation, Inc. + Written by Bruno Haible , 2002. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +#if defined IN_LIBUNISTRING +/* Tell unistr.h to declare u8_uctomb as 'extern', not 'static inline'. */ +# include "unistring-notinline.h" +#endif + +/* Specification. */ +#include "unistr.h" + +#if !HAVE_INLINE + +int +u8_uctomb (uint8_t *s, ucs4_t uc, int n) +{ + if (uc < 0x80) + { + if (n > 0) + { + s[0] = uc; + return 1; + } + /* else return -2, below. */ + } + else + { + int count; + + if (uc < 0x800) + count = 2; + else if (uc < 0x10000) + { + if (uc < 0xd800 || uc >= 0xe000) + count = 3; + else + return -1; + } +#if 0 + else if (uc < 0x200000) + count = 4; + else if (uc < 0x4000000) + count = 5; + else if (uc <= 0x7fffffff) + count = 6; +#else + else if (uc < 0x110000) + count = 4; +#endif + else + return -1; + + if (n >= count) + { + switch (count) /* note: code falls through cases! */ + { +#if 0 + case 6: s[5] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x4000000; + case 5: s[4] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x200000; +#endif + case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000; + case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800; + case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0; + /*case 1:*/ s[0] = uc; + } + return count; + } + } + return -2; +} + +#endif diff --git a/lib/unitypes.h b/lib/unitypes.h new file mode 100644 index 000000000..fe8d87735 --- /dev/null +++ b/lib/unitypes.h @@ -0,0 +1,26 @@ +/* Elementary types for the GNU UniString library. + Copyright (C) 2002, 2005-2006 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef _UNITYPES_H +#define _UNITYPES_H + +/* Get uint8_t, uint16_t, uint32_t. */ +#include + +/* Type representing a Unicode character. */ +typedef uint32_t ucs4_t; + +#endif /* _UNITYPES_H */ diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 new file mode 100644 index 000000000..ad13f2286 --- /dev/null +++ b/m4/byteswap.m4 @@ -0,0 +1,18 @@ +# byteswap.m4 serial 3 +dnl Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl Written by Oskar Liljeblad. + +AC_DEFUN([gl_BYTESWAP], +[ + dnl Prerequisites of lib/byteswap.in.h. + AC_CHECK_HEADERS([byteswap.h], [ + BYTESWAP_H='' + ], [ + BYTESWAP_H='byteswap.h' + ]) + AC_SUBST([BYTESWAP_H]) +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index c7cfb83dd..0fbe11969 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,13 +15,14 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits environ extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) gl_MODULES([ alloca-opt autobuild + byteswap count-one-bits environ extensions @@ -29,11 +30,15 @@ gl_MODULES([ fpieee full-read full-write + iconv_open-utf lib-symbol-visibility + libunistring putenv stdlib strcase strftime + striconveh + string ]) gl_AVOID([]) gl_SOURCE_BASE([lib]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index b6d10a862..8f775107e 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -25,6 +25,7 @@ AC_DEFUN([gl_EARLY], m4_pattern_allow([^gl_LIBOBJS$])dnl a variable m4_pattern_allow([^gl_LTLIBOBJS$])dnl a variable AC_REQUIRE([AC_PROG_RANLIB]) + AC_REQUIRE([AM_PROG_CC_C_O]) AB_INIT AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_REQUIRE([gl_FP_IEEE]) @@ -44,13 +45,19 @@ AC_DEFUN([gl_INIT], gl_COMMON gl_source_base='lib' gl_FUNC_ALLOCA + gl_BYTESWAP gl_COUNT_ONE_BITS gl_ENVIRON gl_UNISTD_MODULE_INDICATOR([environ]) gl_FUNC_FLOCK gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) + AM_ICONV + gl_ICONV_H + gl_FUNC_ICONV_OPEN + gl_FUNC_ICONV_OPEN_UTF gl_INLINE gl_VISIBILITY + gl_LIBUNISTRING gl_LOCALCHARSET LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\"" AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) @@ -73,12 +80,21 @@ AC_DEFUN([gl_INIT], gl_STDLIB_H gl_STRCASE gl_FUNC_GNU_STRFTIME + if test $gl_cond_libtool = false; then + gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV" + gl_libdeps="$gl_libdeps $LIBICONV" + fi + gl_HEADER_STRING_H gl_HEADER_STRINGS_H gl_HEADER_SYS_FILE_H AC_PROG_MKDIR_P gl_HEADER_TIME_H gl_TIME_R gl_UNISTD_H + gl_MODULE_INDICATOR([unistr/u8-mbtouc]) + gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) + gl_MODULE_INDICATOR([unistr/u8-mbtoucr]) + gl_MODULE_INDICATOR([unistr/u8-uctomb]) gl_WCHAR_H gl_FUNC_WRITE gl_UNISTD_MODULE_INDICATOR([write]) @@ -210,8 +226,16 @@ AC_DEFUN([gltests_LIBSOURCES], [ # This macro records the list of files which have been installed by # gnulib-tool and may be removed by future gnulib-tool invocations. AC_DEFUN([gl_FILE_LIST], [ + build-aux/config.rpath build-aux/link-warning.h lib/alloca.in.h + lib/byteswap.in.h + lib/c-ctype.c + lib/c-ctype.h + lib/c-strcase.h + lib/c-strcasecmp.c + lib/c-strcaseeq.h + lib/c-strncasecmp.c lib/config.charset lib/count-one-bits.h lib/flock.c @@ -219,6 +243,15 @@ AC_DEFUN([gl_FILE_LIST], [ lib/full-read.h lib/full-write.c lib/full-write.h + lib/iconv.c + lib/iconv.in.h + lib/iconv_close.c + lib/iconv_open-aix.gperf + lib/iconv_open-hpux.gperf + lib/iconv_open-irix.gperf + lib/iconv_open-osf.gperf + lib/iconv_open.c + lib/iconveh.h lib/localcharset.c lib/localcharset.h lib/malloc.c @@ -239,18 +272,32 @@ AC_DEFUN([gl_FILE_LIST], [ lib/streq.h lib/strftime.c lib/strftime.h + lib/striconveh.c + lib/striconveh.h + lib/string.in.h lib/strings.in.h lib/strncasecmp.c lib/sys_file.in.h lib/time.in.h lib/time_r.c lib/unistd.in.h + lib/unistr.h + lib/unistr/u8-mbtouc-aux.c + lib/unistr/u8-mbtouc-unsafe-aux.c + lib/unistr/u8-mbtouc-unsafe.c + lib/unistr/u8-mbtouc.c + lib/unistr/u8-mbtoucr.c + lib/unistr/u8-prev.c + lib/unistr/u8-uctomb-aux.c + lib/unistr/u8-uctomb.c + lib/unitypes.h lib/verify.h lib/wchar.in.h lib/write.c m4/00gnulib.m4 m4/alloca.m4 m4/autobuild.m4 + m4/byteswap.m4 m4/codeset.m4 m4/count-one-bits.m4 m4/environ.m4 @@ -259,8 +306,15 @@ AC_DEFUN([gl_FILE_LIST], [ m4/fpieee.m4 m4/glibc21.m4 m4/gnulib-common.m4 + m4/iconv.m4 + m4/iconv_h.m4 + m4/iconv_open.m4 m4/include_next.m4 m4/inline.m4 + m4/lib-ld.m4 + m4/lib-link.m4 + m4/lib-prefix.m4 + m4/libunistring.m4 m4/localcharset.m4 m4/locale-fr.m4 m4/locale-ja.m4 @@ -281,6 +335,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/stdlib_h.m4 m4/strcase.m4 m4/strftime.m4 + m4/string_h.m4 m4/strings_h.m4 m4/sys_file_h.m4 m4/time_h.m4 diff --git a/m4/iconv.m4 b/m4/iconv.m4 new file mode 100644 index 000000000..3cc626829 --- /dev/null +++ b/m4/iconv.m4 @@ -0,0 +1,180 @@ +# iconv.m4 serial AM7 (gettext-0.18) +dnl Copyright (C) 2000-2002, 2007-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Bruno Haible. + +AC_DEFUN([AM_ICONV_LINKFLAGS_BODY], +[ + dnl Prerequisites of AC_LIB_LINKFLAGS_BODY. + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + AC_REQUIRE([AC_LIB_RPATH]) + + dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV + dnl accordingly. + AC_LIB_LINKFLAGS_BODY([iconv]) +]) + +AC_DEFUN([AM_ICONV_LINK], +[ + dnl Some systems have iconv in libc, some have it in libiconv (OSF/1 and + dnl those with the standalone portable GNU libiconv installed). + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + + dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV + dnl accordingly. + AC_REQUIRE([AM_ICONV_LINKFLAGS_BODY]) + + dnl Add $INCICONV to CPPFLAGS before performing the following checks, + dnl because if the user has installed libiconv and not disabled its use + dnl via --without-libiconv-prefix, he wants to use it. The first + dnl AC_TRY_LINK will then fail, the second AC_TRY_LINK will succeed. + am_save_CPPFLAGS="$CPPFLAGS" + AC_LIB_APPENDTOVAR([CPPFLAGS], [$INCICONV]) + + AC_CACHE_CHECK([for iconv], [am_cv_func_iconv], [ + am_cv_func_iconv="no, consider installing GNU libiconv" + am_cv_lib_iconv=no + AC_TRY_LINK([#include +#include ], + [iconv_t cd = iconv_open("",""); + iconv(cd,NULL,NULL,NULL,NULL); + iconv_close(cd);], + [am_cv_func_iconv=yes]) + if test "$am_cv_func_iconv" != yes; then + am_save_LIBS="$LIBS" + LIBS="$LIBS $LIBICONV" + AC_TRY_LINK([#include +#include ], + [iconv_t cd = iconv_open("",""); + iconv(cd,NULL,NULL,NULL,NULL); + iconv_close(cd);], + [am_cv_lib_iconv=yes] + [am_cv_func_iconv=yes]) + LIBS="$am_save_LIBS" + fi + ]) + if test "$am_cv_func_iconv" = yes; then + AC_CACHE_CHECK([for working iconv], [am_cv_func_iconv_works], [ + dnl This tests against bugs in AIX 5.1 and HP-UX 11.11. + am_save_LIBS="$LIBS" + if test $am_cv_lib_iconv = yes; then + LIBS="$LIBS $LIBICONV" + fi + AC_TRY_RUN([ +#include +#include +int main () +{ + /* Test against AIX 5.1 bug: Failures are not distinguishable from successful + returns. */ + { + iconv_t cd_utf8_to_88591 = iconv_open ("ISO8859-1", "UTF-8"); + if (cd_utf8_to_88591 != (iconv_t)(-1)) + { + static const char input[] = "\342\202\254"; /* EURO SIGN */ + char buf[10]; + const char *inptr = input; + size_t inbytesleft = strlen (input); + char *outptr = buf; + size_t outbytesleft = sizeof (buf); + size_t res = iconv (cd_utf8_to_88591, + (char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + if (res == 0) + return 1; + } + } +#if 0 /* This bug could be worked around by the caller. */ + /* Test against HP-UX 11.11 bug: Positive return value instead of 0. */ + { + iconv_t cd_88591_to_utf8 = iconv_open ("utf8", "iso88591"); + if (cd_88591_to_utf8 != (iconv_t)(-1)) + { + static const char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337"; + char buf[50]; + const char *inptr = input; + size_t inbytesleft = strlen (input); + char *outptr = buf; + size_t outbytesleft = sizeof (buf); + size_t res = iconv (cd_88591_to_utf8, + (char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + if ((int)res > 0) + return 1; + } + } +#endif + /* Test against HP-UX 11.11 bug: No converter from EUC-JP to UTF-8 is + provided. */ + if (/* Try standardized names. */ + iconv_open ("UTF-8", "EUC-JP") == (iconv_t)(-1) + /* Try IRIX, OSF/1 names. */ + && iconv_open ("UTF-8", "eucJP") == (iconv_t)(-1) + /* Try AIX names. */ + && iconv_open ("UTF-8", "IBM-eucJP") == (iconv_t)(-1) + /* Try HP-UX names. */ + && iconv_open ("utf8", "eucJP") == (iconv_t)(-1)) + return 1; + return 0; +}], [am_cv_func_iconv_works=yes], [am_cv_func_iconv_works=no], + [case "$host_os" in + aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; + *) am_cv_func_iconv_works="guessing yes" ;; + esac]) + LIBS="$am_save_LIBS" + ]) + case "$am_cv_func_iconv_works" in + *no) am_func_iconv=no am_cv_lib_iconv=no ;; + *) am_func_iconv=yes ;; + esac + else + am_func_iconv=no am_cv_lib_iconv=no + fi + if test "$am_func_iconv" = yes; then + AC_DEFINE([HAVE_ICONV], [1], + [Define if you have the iconv() function and it works.]) + fi + if test "$am_cv_lib_iconv" = yes; then + AC_MSG_CHECKING([how to link with libiconv]) + AC_MSG_RESULT([$LIBICONV]) + else + dnl If $LIBICONV didn't lead to a usable library, we don't need $INCICONV + dnl either. + CPPFLAGS="$am_save_CPPFLAGS" + LIBICONV= + LTLIBICONV= + fi + AC_SUBST([LIBICONV]) + AC_SUBST([LTLIBICONV]) +]) + +AC_DEFUN([AM_ICONV], +[ + AM_ICONV_LINK + if test "$am_cv_func_iconv" = yes; then + AC_MSG_CHECKING([for iconv declaration]) + AC_CACHE_VAL([am_cv_proto_iconv], [ + AC_TRY_COMPILE([ +#include +#include +extern +#ifdef __cplusplus +"C" +#endif +#if defined(__STDC__) || defined(__cplusplus) +size_t iconv (iconv_t cd, char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft); +#else +size_t iconv(); +#endif +], [], [am_cv_proto_iconv_arg1=""], [am_cv_proto_iconv_arg1="const"]) + am_cv_proto_iconv="extern size_t iconv (iconv_t cd, $am_cv_proto_iconv_arg1 char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft);"]) + am_cv_proto_iconv=`echo "[$]am_cv_proto_iconv" | tr -s ' ' | sed -e 's/( /(/'` + AC_MSG_RESULT([${ac_t:- + }$am_cv_proto_iconv]) + AC_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1], + [Define as const if the declaration of iconv() needs const.]) + fi +]) diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4 new file mode 100644 index 000000000..bc05b0551 --- /dev/null +++ b/m4/iconv_h.m4 @@ -0,0 +1,34 @@ +# iconv_h.m4 serial 4 +dnl Copyright (C) 2007-2008 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_ICONV_H], +[ + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + gl_CHECK_NEXT_HEADERS([iconv.h]) +]) + +dnl Unconditionally enables the replacement of . +AC_DEFUN([gl_REPLACE_ICONV_H], +[ + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + ICONV_H='iconv.h' +]) + +AC_DEFUN([gl_ICONV_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1 +]) + +AC_DEFUN([gl_ICONV_H_DEFAULTS], +[ + dnl Assume proper GNU behavior unless another module says otherwise. + REPLACE_ICONV=0; AC_SUBST([REPLACE_ICONV]) + REPLACE_ICONV_OPEN=0; AC_SUBST([REPLACE_ICONV_OPEN]) + REPLACE_ICONV_UTF=0; AC_SUBST([REPLACE_ICONV_UTF]) + ICONV_H=''; AC_SUBST([ICONV_H]) +]) diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4 new file mode 100644 index 000000000..c7b948e90 --- /dev/null +++ b/m4/iconv_open.m4 @@ -0,0 +1,237 @@ +# iconv_open.m4 serial 5 +dnl Copyright (C) 2007-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_ICONV_OPEN], +[ + AC_REQUIRE([AM_ICONV]) + AC_REQUIRE([AC_CANONICAL_HOST]) + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + if test "$am_cv_func_iconv" = yes; then + dnl Test whether iconv_open accepts standardized encoding names. + dnl We know that GNU libiconv and GNU libc do. + AC_EGREP_CPP([gnu_iconv], [ + #include + #if defined _LIBICONV_VERSION || defined __GLIBC__ + gnu_iconv + #endif + ], [gl_func_iconv_gnu=yes], [gl_func_iconv_gnu=no]) + if test $gl_func_iconv_gnu = no; then + iconv_flavor= + case "$host_os" in + aix*) iconv_flavor=ICONV_FLAVOR_AIX ;; + irix*) iconv_flavor=ICONV_FLAVOR_IRIX ;; + hpux*) iconv_flavor=ICONV_FLAVOR_HPUX ;; + osf*) iconv_flavor=ICONV_FLAVOR_OSF ;; + esac + if test -n "$iconv_flavor"; then + AC_DEFINE_UNQUOTED([ICONV_FLAVOR], [$iconv_flavor], + [Define to a symbolic name denoting the flavor of iconv_open() + implementation.]) + gl_REPLACE_ICONV_OPEN + fi + fi + fi +]) + +AC_DEFUN([gl_REPLACE_ICONV_OPEN], +[ + gl_REPLACE_ICONV_H + REPLACE_ICONV_OPEN=1 + AC_LIBOBJ([iconv_open]) +]) + +AC_DEFUN([gl_FUNC_ICONV_OPEN_UTF], +[ + AC_REQUIRE([gl_FUNC_ICONV_OPEN]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + if test "$am_cv_func_iconv" = yes; then + if test -n "$am_cv_proto_iconv_arg1"; then + ICONV_CONST="const" + else + ICONV_CONST= + fi + AC_SUBST([ICONV_CONST]) + AC_CACHE_CHECK([whether iconv supports conversion between UTF-8 and UTF-{16,32}{BE,LE}], + [gl_cv_func_iconv_supports_utf], + [ + save_LIBS="$LIBS" + LIBS="$LIBS $LIBICONV" + AC_TRY_RUN([ +#include +#include +#include +#include +#include +#define ASSERT(expr) if (!(expr)) return 1; +int main () +{ + /* Test conversion from UTF-8 to UTF-16BE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "\000J\000a\000p\000a\000n\000e\000s\000e\000 \000(\145\345\147\054\212\236\000)\000 \000[\330\065\335\015\330\065\335\036\330\065\335\055\000]"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-16BE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-8 to UTF-16LE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "J\000a\000p\000a\000n\000e\000s\000e\000 \000(\000\345\145\054\147\236\212)\000 \000[\000\065\330\015\335\065\330\036\335\065\330\055\335]\000"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-16LE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-8 to UTF-32BE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "\000\000\000J\000\000\000a\000\000\000p\000\000\000a\000\000\000n\000\000\000e\000\000\000s\000\000\000e\000\000\000 \000\000\000(\000\000\145\345\000\000\147\054\000\000\212\236\000\000\000)\000\000\000 \000\000\000[\000\001\325\015\000\001\325\036\000\001\325\055\000\000\000]"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-32BE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-8 to UTF-32LE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "J\000\000\000a\000\000\000p\000\000\000a\000\000\000n\000\000\000e\000\000\000s\000\000\000e\000\000\000 \000\000\000(\000\000\000\345\145\000\000\054\147\000\000\236\212\000\000)\000\000\000 \000\000\000[\000\000\000\015\325\001\000\036\325\001\000\055\325\001\000]\000\000\000"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-32LE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-16BE to UTF-8 with no errors. + This test fails on NetBSD 3.0. */ + { + static const char input[] = + "\000J\000a\000p\000a\000n\000e\000s\000e\000 \000(\145\345\147\054\212\236\000)\000 \000[\330\065\335\015\330\065\335\036\330\065\335\055\000]"; + static const char expected[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-8", "UTF-16BE"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + return 0; +}], [gl_cv_func_iconv_supports_utf=yes], [gl_cv_func_iconv_supports_utf=no], + [ + dnl We know that GNU libiconv, GNU libc, and Solaris >= 9 do. + dnl OSF/1 5.1 has these encodings, but inserts a BOM in the "to" + dnl direction. + gl_cv_func_iconv_supports_utf=no + if test $gl_func_iconv_gnu = yes; then + gl_cv_func_iconv_supports_utf=yes + else +changequote(,)dnl + case "$host_os" in + solaris2.9 | solaris2.1[0-9]) gl_cv_func_iconv_supports_utf=yes ;; + esac +changequote([,])dnl + fi + ]) + LIBS="$save_LIBS" + ]) + if test $gl_cv_func_iconv_supports_utf = no; then + REPLACE_ICONV_UTF=1 + AC_DEFINE([REPLACE_ICONV_UTF], [1], + [Define if the iconv() functions are enhanced to handle the UTF-{16,32}{BE,LE} encodings.]) + REPLACE_ICONV=1 + gl_REPLACE_ICONV_OPEN + AC_LIBOBJ([iconv]) + AC_LIBOBJ([iconv_close]) + fi + fi +]) diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4 new file mode 100644 index 000000000..e4863f2c9 --- /dev/null +++ b/m4/lib-ld.m4 @@ -0,0 +1,110 @@ +# lib-ld.m4 serial 4 (gettext-0.18) +dnl Copyright (C) 1996-2003, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl Subroutines of libtool.m4, +dnl with replacements s/AC_/AC_LIB/ and s/lt_cv/acl_cv/ to avoid collision +dnl with libtool.m4. + +dnl From libtool-1.4. Sets the variable with_gnu_ld to yes or no. +AC_DEFUN([AC_LIB_PROG_LD_GNU], +[AC_CACHE_CHECK([if the linker ($LD) is GNU ld], [acl_cv_prog_gnu_ld], +[# I'd rather use --version here, but apparently some GNU ld's only accept -v. +case `$LD -v 2>&1 conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi +ac_prog=ld +if test "$GCC" = yes; then + # Check if gcc -print-prog-name=ld gives a path. + AC_MSG_CHECKING([for ld used by GCC]) + case $host in + *-*-mingw*) + # gcc leaves a trailing carriage return which upsets mingw + ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; + *) + ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; + esac + case $ac_prog in + # Accept absolute paths. + [[\\/]* | [A-Za-z]:[\\/]*)] + [re_direlt='/[^/][^/]*/\.\./'] + # Canonicalize the path of ld + ac_prog=`echo $ac_prog| sed 's%\\\\%/%g'` + while echo $ac_prog | grep "$re_direlt" > /dev/null 2>&1; do + ac_prog=`echo $ac_prog| sed "s%$re_direlt%/%"` + done + test -z "$LD" && LD="$ac_prog" + ;; + "") + # If it fails, then pretend we aren't using GCC. + ac_prog=ld + ;; + *) + # If it is relative, then search for the first ld in PATH. + with_gnu_ld=unknown + ;; + esac +elif test "$with_gnu_ld" = yes; then + AC_MSG_CHECKING([for GNU ld]) +else + AC_MSG_CHECKING([for non-GNU ld]) +fi +AC_CACHE_VAL([acl_cv_path_LD], +[if test -z "$LD"; then + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}${PATH_SEPARATOR-:}" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then + acl_cv_path_LD="$ac_dir/$ac_prog" + # Check to see if the program is GNU ld. I'd rather use --version, + # but apparently some GNU ld's only accept -v. + # Break only if it was the GNU/non-GNU ld that we prefer. + case `"$acl_cv_path_LD" -v 2>&1 < /dev/null` in + *GNU* | *'with BFD'*) + test "$with_gnu_ld" != no && break ;; + *) + test "$with_gnu_ld" != yes && break ;; + esac + fi + done + IFS="$ac_save_ifs" +else + acl_cv_path_LD="$LD" # Let the user override the test with a path. +fi]) +LD="$acl_cv_path_LD" +if test -n "$LD"; then + AC_MSG_RESULT([$LD]) +else + AC_MSG_RESULT([no]) +fi +test -z "$LD" && AC_MSG_ERROR([no acceptable ld found in \$PATH]) +AC_LIB_PROG_LD_GNU +]) diff --git a/m4/lib-link.m4 b/m4/lib-link.m4 new file mode 100644 index 000000000..21442033c --- /dev/null +++ b/m4/lib-link.m4 @@ -0,0 +1,761 @@ +# lib-link.m4 serial 19 (gettext-0.18) +dnl Copyright (C) 2001-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Bruno Haible. + +AC_PREREQ([2.54]) + +dnl AC_LIB_LINKFLAGS(name [, dependencies]) searches for libname and +dnl the libraries corresponding to explicit and implicit dependencies. +dnl Sets and AC_SUBSTs the LIB${NAME} and LTLIB${NAME} variables and +dnl augments the CPPFLAGS variable. +dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname +dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem. +AC_DEFUN([AC_LIB_LINKFLAGS], +[ + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + AC_REQUIRE([AC_LIB_RPATH]) + pushdef([Name],[translit([$1],[./-], [___])]) + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + AC_CACHE_CHECK([how to link with lib[]$1], [ac_cv_lib[]Name[]_libs], [ + AC_LIB_LINKFLAGS_BODY([$1], [$2]) + ac_cv_lib[]Name[]_libs="$LIB[]NAME" + ac_cv_lib[]Name[]_ltlibs="$LTLIB[]NAME" + ac_cv_lib[]Name[]_cppflags="$INC[]NAME" + ac_cv_lib[]Name[]_prefix="$LIB[]NAME[]_PREFIX" + ]) + LIB[]NAME="$ac_cv_lib[]Name[]_libs" + LTLIB[]NAME="$ac_cv_lib[]Name[]_ltlibs" + INC[]NAME="$ac_cv_lib[]Name[]_cppflags" + LIB[]NAME[]_PREFIX="$ac_cv_lib[]Name[]_prefix" + AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME) + AC_SUBST([LIB]NAME) + AC_SUBST([LTLIB]NAME) + AC_SUBST([LIB]NAME[_PREFIX]) + dnl Also set HAVE_LIB[]NAME so that AC_LIB_HAVE_LINKFLAGS can reuse the + dnl results of this search when this library appears as a dependency. + HAVE_LIB[]NAME=yes + popdef([NAME]) + popdef([Name]) +]) + +dnl AC_LIB_HAVE_LINKFLAGS(name, dependencies, includes, testcode, [missing-message]) +dnl searches for libname and the libraries corresponding to explicit and +dnl implicit dependencies, together with the specified include files and +dnl the ability to compile and link the specified testcode. The missing-message +dnl defaults to 'no' and may contain additional hints for the user. +dnl If found, it sets and AC_SUBSTs HAVE_LIB${NAME}=yes and the LIB${NAME} +dnl and LTLIB${NAME} variables and augments the CPPFLAGS variable, and +dnl #defines HAVE_LIB${NAME} to 1. Otherwise, it sets and AC_SUBSTs +dnl HAVE_LIB${NAME}=no and LIB${NAME} and LTLIB${NAME} to empty. +dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname +dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem. +AC_DEFUN([AC_LIB_HAVE_LINKFLAGS], +[ + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + AC_REQUIRE([AC_LIB_RPATH]) + pushdef([Name],[translit([$1],[./-], [___])]) + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + + dnl Search for lib[]Name and define LIB[]NAME, LTLIB[]NAME and INC[]NAME + dnl accordingly. + AC_LIB_LINKFLAGS_BODY([$1], [$2]) + + dnl Add $INC[]NAME to CPPFLAGS before performing the following checks, + dnl because if the user has installed lib[]Name and not disabled its use + dnl via --without-lib[]Name-prefix, he wants to use it. + ac_save_CPPFLAGS="$CPPFLAGS" + AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME) + + AC_CACHE_CHECK([for lib[]$1], [ac_cv_lib[]Name], [ + ac_save_LIBS="$LIBS" + LIBS="$LIBS $LIB[]NAME" + AC_TRY_LINK([$3], [$4], + [ac_cv_lib[]Name=yes], + [ac_cv_lib[]Name='m4_if([$5], [], [no], [[$5]])']) + LIBS="$ac_save_LIBS" + ]) + if test "$ac_cv_lib[]Name" = yes; then + HAVE_LIB[]NAME=yes + AC_DEFINE([HAVE_LIB]NAME, 1, [Define if you have the lib[]$1 library.]) + AC_MSG_CHECKING([how to link with lib[]$1]) + AC_MSG_RESULT([$LIB[]NAME]) + else + HAVE_LIB[]NAME=no + dnl If $LIB[]NAME didn't lead to a usable library, we don't need + dnl $INC[]NAME either. + CPPFLAGS="$ac_save_CPPFLAGS" + LIB[]NAME= + LTLIB[]NAME= + LIB[]NAME[]_PREFIX= + fi + AC_SUBST([HAVE_LIB]NAME) + AC_SUBST([LIB]NAME) + AC_SUBST([LTLIB]NAME) + AC_SUBST([LIB]NAME[_PREFIX]) + popdef([NAME]) + popdef([Name]) +]) + +dnl Determine the platform dependent parameters needed to use rpath: +dnl acl_libext, +dnl acl_shlibext, +dnl acl_hardcode_libdir_flag_spec, +dnl acl_hardcode_libdir_separator, +dnl acl_hardcode_direct, +dnl acl_hardcode_minus_L. +AC_DEFUN([AC_LIB_RPATH], +[ + dnl Tell automake >= 1.10 to complain if config.rpath is missing. + m4_ifdef([AC_REQUIRE_AUX_FILE], [AC_REQUIRE_AUX_FILE([config.rpath])]) + AC_REQUIRE([AC_PROG_CC]) dnl we use $CC, $GCC, $LDFLAGS + AC_REQUIRE([AC_LIB_PROG_LD]) dnl we use $LD, $with_gnu_ld + AC_REQUIRE([AC_CANONICAL_HOST]) dnl we use $host + AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT]) dnl we use $ac_aux_dir + AC_CACHE_CHECK([for shared library run path origin], [acl_cv_rpath], [ + CC="$CC" GCC="$GCC" LDFLAGS="$LDFLAGS" LD="$LD" with_gnu_ld="$with_gnu_ld" \ + ${CONFIG_SHELL-/bin/sh} "$ac_aux_dir/config.rpath" "$host" > conftest.sh + . ./conftest.sh + rm -f ./conftest.sh + acl_cv_rpath=done + ]) + wl="$acl_cv_wl" + acl_libext="$acl_cv_libext" + acl_shlibext="$acl_cv_shlibext" + acl_libname_spec="$acl_cv_libname_spec" + acl_library_names_spec="$acl_cv_library_names_spec" + acl_hardcode_libdir_flag_spec="$acl_cv_hardcode_libdir_flag_spec" + acl_hardcode_libdir_separator="$acl_cv_hardcode_libdir_separator" + acl_hardcode_direct="$acl_cv_hardcode_direct" + acl_hardcode_minus_L="$acl_cv_hardcode_minus_L" + dnl Determine whether the user wants rpath handling at all. + AC_ARG_ENABLE([rpath], + [ --disable-rpath do not hardcode runtime library paths], + :, enable_rpath=yes) +]) + +dnl AC_LIB_FROMPACKAGE(name, package) +dnl declares that libname comes from the given package. The configure file +dnl will then not have a --with-libname-prefix option but a +dnl --with-package-prefix option. Several libraries can come from the same +dnl package. This declaration must occur before an AC_LIB_LINKFLAGS or similar +dnl macro call that searches for libname. +AC_DEFUN([AC_LIB_FROMPACKAGE], +[ + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + define([acl_frompackage_]NAME, [$2]) + popdef([NAME]) + pushdef([PACK],[$2]) + pushdef([PACKUP],[translit(PACK,[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + define([acl_libsinpackage_]PACKUP, + m4_ifdef([acl_libsinpackage_]PACKUP, [acl_libsinpackage_]PACKUP[[, ]],)[lib$1]) + popdef([PACKUP]) + popdef([PACK]) +]) + +dnl AC_LIB_LINKFLAGS_BODY(name [, dependencies]) searches for libname and +dnl the libraries corresponding to explicit and implicit dependencies. +dnl Sets the LIB${NAME}, LTLIB${NAME} and INC${NAME} variables. +dnl Also, sets the LIB${NAME}_PREFIX variable to nonempty if libname was found +dnl in ${LIB${NAME}_PREFIX}/$acl_libdirstem. +AC_DEFUN([AC_LIB_LINKFLAGS_BODY], +[ + AC_REQUIRE([AC_LIB_PREPARE_MULTILIB]) + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + pushdef([PACK],[m4_ifdef([acl_frompackage_]NAME, [acl_frompackage_]NAME, lib[$1])]) + pushdef([PACKUP],[translit(PACK,[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + pushdef([PACKLIBS],[m4_ifdef([acl_frompackage_]NAME, [acl_libsinpackage_]PACKUP, lib[$1])]) + dnl Autoconf >= 2.61 supports dots in --with options. + pushdef([P_A_C_K],[m4_if(m4_version_compare(m4_defn([m4_PACKAGE_VERSION]),[2.61]),[-1],[translit(PACK,[.],[_])],PACK)]) + dnl By default, look in $includedir and $libdir. + use_additional=yes + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + AC_ARG_WITH(P_A_C_K[-prefix], +[[ --with-]]P_A_C_K[[-prefix[=DIR] search for ]PACKLIBS[ in DIR/include and DIR/lib + --without-]]P_A_C_K[[-prefix don't search for ]PACKLIBS[ in includedir and libdir]], +[ + if test "X$withval" = "Xno"; then + use_additional=no + else + if test "X$withval" = "X"; then + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + else + additional_includedir="$withval/include" + additional_libdir="$withval/$acl_libdirstem" + if test "$acl_libdirstem2" != "$acl_libdirstem" \ + && ! test -d "$withval/$acl_libdirstem"; then + additional_libdir="$withval/$acl_libdirstem2" + fi + fi + fi +]) + dnl Search the library and its dependencies in $additional_libdir and + dnl $LDFLAGS. Using breadth-first-seach. + LIB[]NAME= + LTLIB[]NAME= + INC[]NAME= + LIB[]NAME[]_PREFIX= + rpathdirs= + ltrpathdirs= + names_already_handled= + names_next_round='$1 $2' + while test -n "$names_next_round"; do + names_this_round="$names_next_round" + names_next_round= + for name in $names_this_round; do + already_handled= + for n in $names_already_handled; do + if test "$n" = "$name"; then + already_handled=yes + break + fi + done + if test -z "$already_handled"; then + names_already_handled="$names_already_handled $name" + dnl See if it was already located by an earlier AC_LIB_LINKFLAGS + dnl or AC_LIB_HAVE_LINKFLAGS call. + uppername=`echo "$name" | sed -e 'y|abcdefghijklmnopqrstuvwxyz./-|ABCDEFGHIJKLMNOPQRSTUVWXYZ___|'` + eval value=\"\$HAVE_LIB$uppername\" + if test -n "$value"; then + if test "$value" = yes; then + eval value=\"\$LIB$uppername\" + test -z "$value" || LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$value" + eval value=\"\$LTLIB$uppername\" + test -z "$value" || LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }$value" + else + dnl An earlier call to AC_LIB_HAVE_LINKFLAGS has determined + dnl that this library doesn't exist. So just drop it. + : + fi + else + dnl Search the library lib$name in $additional_libdir and $LDFLAGS + dnl and the already constructed $LIBNAME/$LTLIBNAME. + found_dir= + found_la= + found_so= + found_a= + eval libname=\"$acl_libname_spec\" # typically: libname=lib$name + if test -n "$acl_shlibext"; then + shrext=".$acl_shlibext" # typically: shrext=.so + else + shrext= + fi + if test $use_additional = yes; then + dir="$additional_libdir" + dnl The same code as in the loop below: + dnl First look for a shared library. + if test -n "$acl_shlibext"; then + if test -f "$dir/$libname$shrext"; then + found_dir="$dir" + found_so="$dir/$libname$shrext" + else + if test "$acl_library_names_spec" = '$libname$shrext$versuffix'; then + ver=`(cd "$dir" && \ + for f in "$libname$shrext".*; do echo "$f"; done \ + | sed -e "s,^$libname$shrext\\\\.,," \ + | sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4 -k5,5 \ + | sed 1q ) 2>/dev/null` + if test -n "$ver" && test -f "$dir/$libname$shrext.$ver"; then + found_dir="$dir" + found_so="$dir/$libname$shrext.$ver" + fi + else + eval library_names=\"$acl_library_names_spec\" + for f in $library_names; do + if test -f "$dir/$f"; then + found_dir="$dir" + found_so="$dir/$f" + break + fi + done + fi + fi + fi + dnl Then look for a static library. + if test "X$found_dir" = "X"; then + if test -f "$dir/$libname.$acl_libext"; then + found_dir="$dir" + found_a="$dir/$libname.$acl_libext" + fi + fi + if test "X$found_dir" != "X"; then + if test -f "$dir/$libname.la"; then + found_la="$dir/$libname.la" + fi + fi + fi + if test "X$found_dir" = "X"; then + for x in $LDFLAGS $LTLIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + case "$x" in + -L*) + dir=`echo "X$x" | sed -e 's/^X-L//'` + dnl First look for a shared library. + if test -n "$acl_shlibext"; then + if test -f "$dir/$libname$shrext"; then + found_dir="$dir" + found_so="$dir/$libname$shrext" + else + if test "$acl_library_names_spec" = '$libname$shrext$versuffix'; then + ver=`(cd "$dir" && \ + for f in "$libname$shrext".*; do echo "$f"; done \ + | sed -e "s,^$libname$shrext\\\\.,," \ + | sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4 -k5,5 \ + | sed 1q ) 2>/dev/null` + if test -n "$ver" && test -f "$dir/$libname$shrext.$ver"; then + found_dir="$dir" + found_so="$dir/$libname$shrext.$ver" + fi + else + eval library_names=\"$acl_library_names_spec\" + for f in $library_names; do + if test -f "$dir/$f"; then + found_dir="$dir" + found_so="$dir/$f" + break + fi + done + fi + fi + fi + dnl Then look for a static library. + if test "X$found_dir" = "X"; then + if test -f "$dir/$libname.$acl_libext"; then + found_dir="$dir" + found_a="$dir/$libname.$acl_libext" + fi + fi + if test "X$found_dir" != "X"; then + if test -f "$dir/$libname.la"; then + found_la="$dir/$libname.la" + fi + fi + ;; + esac + if test "X$found_dir" != "X"; then + break + fi + done + fi + if test "X$found_dir" != "X"; then + dnl Found the library. + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-L$found_dir -l$name" + if test "X$found_so" != "X"; then + dnl Linking with a shared library. We attempt to hardcode its + dnl directory into the executable's runpath, unless it's the + dnl standard /usr/lib. + if test "$enable_rpath" = no \ + || test "X$found_dir" = "X/usr/$acl_libdirstem" \ + || test "X$found_dir" = "X/usr/$acl_libdirstem2"; then + dnl No hardcoding is needed. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + else + dnl Use an explicit option to hardcode DIR into the resulting + dnl binary. + dnl Potentially add DIR to ltrpathdirs. + dnl The ltrpathdirs will be appended to $LTLIBNAME at the end. + haveit= + for x in $ltrpathdirs; do + if test "X$x" = "X$found_dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + ltrpathdirs="$ltrpathdirs $found_dir" + fi + dnl The hardcoding into $LIBNAME is system dependent. + if test "$acl_hardcode_direct" = yes; then + dnl Using DIR/libNAME.so during linking hardcodes DIR into the + dnl resulting binary. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + else + if test -n "$acl_hardcode_libdir_flag_spec" && test "$acl_hardcode_minus_L" = no; then + dnl Use an explicit option to hardcode DIR into the resulting + dnl binary. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + dnl Potentially add DIR to rpathdirs. + dnl The rpathdirs will be appended to $LIBNAME at the end. + haveit= + for x in $rpathdirs; do + if test "X$x" = "X$found_dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + rpathdirs="$rpathdirs $found_dir" + fi + else + dnl Rely on "-L$found_dir". + dnl But don't add it if it's already contained in the LDFLAGS + dnl or the already constructed $LIBNAME + haveit= + for x in $LDFLAGS $LIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$found_dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir" + fi + if test "$acl_hardcode_minus_L" != no; then + dnl FIXME: Not sure whether we should use + dnl "-L$found_dir -l$name" or "-L$found_dir $found_so" + dnl here. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + else + dnl We cannot use $acl_hardcode_runpath_var and LD_RUN_PATH + dnl here, because this doesn't fit in flags passed to the + dnl compiler. So give up. No hardcoding. This affects only + dnl very old systems. + dnl FIXME: Not sure whether we should use + dnl "-L$found_dir -l$name" or "-L$found_dir $found_so" + dnl here. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name" + fi + fi + fi + fi + else + if test "X$found_a" != "X"; then + dnl Linking with a static library. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_a" + else + dnl We shouldn't come here, but anyway it's good to have a + dnl fallback. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir -l$name" + fi + fi + dnl Assume the include files are nearby. + additional_includedir= + case "$found_dir" in + */$acl_libdirstem | */$acl_libdirstem/) + basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e "s,/$acl_libdirstem/"'*$,,'` + if test "$name" = '$1'; then + LIB[]NAME[]_PREFIX="$basedir" + fi + additional_includedir="$basedir/include" + ;; + */$acl_libdirstem2 | */$acl_libdirstem2/) + basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e "s,/$acl_libdirstem2/"'*$,,'` + if test "$name" = '$1'; then + LIB[]NAME[]_PREFIX="$basedir" + fi + additional_includedir="$basedir/include" + ;; + esac + if test "X$additional_includedir" != "X"; then + dnl Potentially add $additional_includedir to $INCNAME. + dnl But don't add it + dnl 1. if it's the standard /usr/include, + dnl 2. if it's /usr/local/include and we are using GCC on Linux, + dnl 3. if it's already present in $CPPFLAGS or the already + dnl constructed $INCNAME, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_includedir" != "X/usr/include"; then + haveit= + if test "X$additional_includedir" = "X/usr/local/include"; then + if test -n "$GCC"; then + case $host_os in + linux* | gnu* | k*bsd*-gnu) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + for x in $CPPFLAGS $INC[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-I$additional_includedir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test -d "$additional_includedir"; then + dnl Really add $additional_includedir to $INCNAME. + INC[]NAME="${INC[]NAME}${INC[]NAME:+ }-I$additional_includedir" + fi + fi + fi + fi + fi + dnl Look for dependencies. + if test -n "$found_la"; then + dnl Read the .la file. It defines the variables + dnl dlname, library_names, old_library, dependency_libs, current, + dnl age, revision, installed, dlopen, dlpreopen, libdir. + save_libdir="$libdir" + case "$found_la" in + */* | *\\*) . "$found_la" ;; + *) . "./$found_la" ;; + esac + libdir="$save_libdir" + dnl We use only dependency_libs. + for dep in $dependency_libs; do + case "$dep" in + -L*) + additional_libdir=`echo "X$dep" | sed -e 's/^X-L//'` + dnl Potentially add $additional_libdir to $LIBNAME and $LTLIBNAME. + dnl But don't add it + dnl 1. if it's the standard /usr/lib, + dnl 2. if it's /usr/local/lib and we are using GCC on Linux, + dnl 3. if it's already present in $LDFLAGS or the already + dnl constructed $LIBNAME, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_libdir" != "X/usr/$acl_libdirstem" \ + && test "X$additional_libdir" != "X/usr/$acl_libdirstem2"; then + haveit= + if test "X$additional_libdir" = "X/usr/local/$acl_libdirstem" \ + || test "X$additional_libdir" = "X/usr/local/$acl_libdirstem2"; then + if test -n "$GCC"; then + case $host_os in + linux* | gnu* | k*bsd*-gnu) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + haveit= + for x in $LDFLAGS $LIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$additional_libdir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test -d "$additional_libdir"; then + dnl Really add $additional_libdir to $LIBNAME. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$additional_libdir" + fi + fi + haveit= + for x in $LDFLAGS $LTLIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$additional_libdir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test -d "$additional_libdir"; then + dnl Really add $additional_libdir to $LTLIBNAME. + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-L$additional_libdir" + fi + fi + fi + fi + ;; + -R*) + dir=`echo "X$dep" | sed -e 's/^X-R//'` + if test "$enable_rpath" != no; then + dnl Potentially add DIR to rpathdirs. + dnl The rpathdirs will be appended to $LIBNAME at the end. + haveit= + for x in $rpathdirs; do + if test "X$x" = "X$dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + rpathdirs="$rpathdirs $dir" + fi + dnl Potentially add DIR to ltrpathdirs. + dnl The ltrpathdirs will be appended to $LTLIBNAME at the end. + haveit= + for x in $ltrpathdirs; do + if test "X$x" = "X$dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + ltrpathdirs="$ltrpathdirs $dir" + fi + fi + ;; + -l*) + dnl Handle this in the next round. + names_next_round="$names_next_round "`echo "X$dep" | sed -e 's/^X-l//'` + ;; + *.la) + dnl Handle this in the next round. Throw away the .la's + dnl directory; it is already contained in a preceding -L + dnl option. + names_next_round="$names_next_round "`echo "X$dep" | sed -e 's,^X.*/,,' -e 's,^lib,,' -e 's,\.la$,,'` + ;; + *) + dnl Most likely an immediate library name. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$dep" + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }$dep" + ;; + esac + done + fi + else + dnl Didn't find the library; assume it is in the system directories + dnl known to the linker and runtime loader. (All the system + dnl directories known to the linker should also be known to the + dnl runtime loader, otherwise the system is severely misconfigured.) + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name" + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-l$name" + fi + fi + fi + done + done + if test "X$rpathdirs" != "X"; then + if test -n "$acl_hardcode_libdir_separator"; then + dnl Weird platform: only the last -rpath option counts, the user must + dnl pass all path elements in one option. We can arrange that for a + dnl single library, but not when more than one $LIBNAMEs are used. + alldirs= + for found_dir in $rpathdirs; do + alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$found_dir" + done + dnl Note: acl_hardcode_libdir_flag_spec uses $libdir and $wl. + acl_save_libdir="$libdir" + libdir="$alldirs" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag" + else + dnl The -rpath options are cumulative. + for found_dir in $rpathdirs; do + acl_save_libdir="$libdir" + libdir="$found_dir" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag" + done + fi + fi + if test "X$ltrpathdirs" != "X"; then + dnl When using libtool, the option that works for both libraries and + dnl executables is -R. The -R options are cumulative. + for found_dir in $ltrpathdirs; do + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-R$found_dir" + done + fi + popdef([P_A_C_K]) + popdef([PACKLIBS]) + popdef([PACKUP]) + popdef([PACK]) + popdef([NAME]) +]) + +dnl AC_LIB_APPENDTOVAR(VAR, CONTENTS) appends the elements of CONTENTS to VAR, +dnl unless already present in VAR. +dnl Works only for CPPFLAGS, not for LIB* variables because that sometimes +dnl contains two or three consecutive elements that belong together. +AC_DEFUN([AC_LIB_APPENDTOVAR], +[ + for element in [$2]; do + haveit= + for x in $[$1]; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X$element"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + [$1]="${[$1]}${[$1]:+ }$element" + fi + done +]) + +dnl For those cases where a variable contains several -L and -l options +dnl referring to unknown libraries and directories, this macro determines the +dnl necessary additional linker options for the runtime path. +dnl AC_LIB_LINKFLAGS_FROM_LIBS([LDADDVAR], [LIBSVALUE], [USE-LIBTOOL]) +dnl sets LDADDVAR to linker options needed together with LIBSVALUE. +dnl If USE-LIBTOOL evaluates to non-empty, linking with libtool is assumed, +dnl otherwise linking without libtool is assumed. +AC_DEFUN([AC_LIB_LINKFLAGS_FROM_LIBS], +[ + AC_REQUIRE([AC_LIB_RPATH]) + AC_REQUIRE([AC_LIB_PREPARE_MULTILIB]) + $1= + if test "$enable_rpath" != no; then + if test -n "$acl_hardcode_libdir_flag_spec" && test "$acl_hardcode_minus_L" = no; then + dnl Use an explicit option to hardcode directories into the resulting + dnl binary. + rpathdirs= + next= + for opt in $2; do + if test -n "$next"; then + dir="$next" + dnl No need to hardcode the standard /usr/lib. + if test "X$dir" != "X/usr/$acl_libdirstem" \ + && test "X$dir" != "X/usr/$acl_libdirstem2"; then + rpathdirs="$rpathdirs $dir" + fi + next= + else + case $opt in + -L) next=yes ;; + -L*) dir=`echo "X$opt" | sed -e 's,^X-L,,'` + dnl No need to hardcode the standard /usr/lib. + if test "X$dir" != "X/usr/$acl_libdirstem" \ + && test "X$dir" != "X/usr/$acl_libdirstem2"; then + rpathdirs="$rpathdirs $dir" + fi + next= ;; + *) next= ;; + esac + fi + done + if test "X$rpathdirs" != "X"; then + if test -n ""$3""; then + dnl libtool is used for linking. Use -R options. + for dir in $rpathdirs; do + $1="${$1}${$1:+ }-R$dir" + done + else + dnl The linker is used for linking directly. + if test -n "$acl_hardcode_libdir_separator"; then + dnl Weird platform: only the last -rpath option counts, the user + dnl must pass all path elements in one option. + alldirs= + for dir in $rpathdirs; do + alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$dir" + done + acl_save_libdir="$libdir" + libdir="$alldirs" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + $1="$flag" + else + dnl The -rpath options are cumulative. + for dir in $rpathdirs; do + acl_save_libdir="$libdir" + libdir="$dir" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + $1="${$1}${$1:+ }$flag" + done + fi + fi + fi + fi + fi + AC_SUBST([$1]) +]) diff --git a/m4/lib-prefix.m4 b/m4/lib-prefix.m4 new file mode 100644 index 000000000..4b7ee3358 --- /dev/null +++ b/m4/lib-prefix.m4 @@ -0,0 +1,224 @@ +# lib-prefix.m4 serial 7 (gettext-0.18) +dnl Copyright (C) 2001-2005, 2008-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Bruno Haible. + +dnl AC_LIB_ARG_WITH is synonymous to AC_ARG_WITH in autoconf-2.13, and +dnl similar to AC_ARG_WITH in autoconf 2.52...2.57 except that is doesn't +dnl require excessive bracketing. +ifdef([AC_HELP_STRING], +[AC_DEFUN([AC_LIB_ARG_WITH], [AC_ARG_WITH([$1],[[$2]],[$3],[$4])])], +[AC_DEFUN([AC_][LIB_ARG_WITH], [AC_ARG_WITH([$1],[$2],[$3],[$4])])]) + +dnl AC_LIB_PREFIX adds to the CPPFLAGS and LDFLAGS the flags that are needed +dnl to access previously installed libraries. The basic assumption is that +dnl a user will want packages to use other packages he previously installed +dnl with the same --prefix option. +dnl This macro is not needed if only AC_LIB_LINKFLAGS is used to locate +dnl libraries, but is otherwise very convenient. +AC_DEFUN([AC_LIB_PREFIX], +[ + AC_BEFORE([$0], [AC_LIB_LINKFLAGS]) + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) + AC_REQUIRE([AC_LIB_PREPARE_MULTILIB]) + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + dnl By default, look in $includedir and $libdir. + use_additional=yes + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + AC_LIB_ARG_WITH([lib-prefix], +[ --with-lib-prefix[=DIR] search for libraries in DIR/include and DIR/lib + --without-lib-prefix don't search for libraries in includedir and libdir], +[ + if test "X$withval" = "Xno"; then + use_additional=no + else + if test "X$withval" = "X"; then + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + else + additional_includedir="$withval/include" + additional_libdir="$withval/$acl_libdirstem" + fi + fi +]) + if test $use_additional = yes; then + dnl Potentially add $additional_includedir to $CPPFLAGS. + dnl But don't add it + dnl 1. if it's the standard /usr/include, + dnl 2. if it's already present in $CPPFLAGS, + dnl 3. if it's /usr/local/include and we are using GCC on Linux, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_includedir" != "X/usr/include"; then + haveit= + for x in $CPPFLAGS; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-I$additional_includedir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test "X$additional_includedir" = "X/usr/local/include"; then + if test -n "$GCC"; then + case $host_os in + linux* | gnu* | k*bsd*-gnu) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + if test -d "$additional_includedir"; then + dnl Really add $additional_includedir to $CPPFLAGS. + CPPFLAGS="${CPPFLAGS}${CPPFLAGS:+ }-I$additional_includedir" + fi + fi + fi + fi + dnl Potentially add $additional_libdir to $LDFLAGS. + dnl But don't add it + dnl 1. if it's the standard /usr/lib, + dnl 2. if it's already present in $LDFLAGS, + dnl 3. if it's /usr/local/lib and we are using GCC on Linux, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_libdir" != "X/usr/$acl_libdirstem"; then + haveit= + for x in $LDFLAGS; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$additional_libdir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test "X$additional_libdir" = "X/usr/local/$acl_libdirstem"; then + if test -n "$GCC"; then + case $host_os in + linux*) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + if test -d "$additional_libdir"; then + dnl Really add $additional_libdir to $LDFLAGS. + LDFLAGS="${LDFLAGS}${LDFLAGS:+ }-L$additional_libdir" + fi + fi + fi + fi + fi +]) + +dnl AC_LIB_PREPARE_PREFIX creates variables acl_final_prefix, +dnl acl_final_exec_prefix, containing the values to which $prefix and +dnl $exec_prefix will expand at the end of the configure script. +AC_DEFUN([AC_LIB_PREPARE_PREFIX], +[ + dnl Unfortunately, prefix and exec_prefix get only finally determined + dnl at the end of configure. + if test "X$prefix" = "XNONE"; then + acl_final_prefix="$ac_default_prefix" + else + acl_final_prefix="$prefix" + fi + if test "X$exec_prefix" = "XNONE"; then + acl_final_exec_prefix='${prefix}' + else + acl_final_exec_prefix="$exec_prefix" + fi + acl_save_prefix="$prefix" + prefix="$acl_final_prefix" + eval acl_final_exec_prefix=\"$acl_final_exec_prefix\" + prefix="$acl_save_prefix" +]) + +dnl AC_LIB_WITH_FINAL_PREFIX([statement]) evaluates statement, with the +dnl variables prefix and exec_prefix bound to the values they will have +dnl at the end of the configure script. +AC_DEFUN([AC_LIB_WITH_FINAL_PREFIX], +[ + acl_save_prefix="$prefix" + prefix="$acl_final_prefix" + acl_save_exec_prefix="$exec_prefix" + exec_prefix="$acl_final_exec_prefix" + $1 + exec_prefix="$acl_save_exec_prefix" + prefix="$acl_save_prefix" +]) + +dnl AC_LIB_PREPARE_MULTILIB creates +dnl - a variable acl_libdirstem, containing the basename of the libdir, either +dnl "lib" or "lib64" or "lib/64", +dnl - a variable acl_libdirstem2, as a secondary possible value for +dnl acl_libdirstem, either the same as acl_libdirstem or "lib/sparcv9" or +dnl "lib/amd64". +AC_DEFUN([AC_LIB_PREPARE_MULTILIB], +[ + dnl There is no formal standard regarding lib and lib64. + dnl On glibc systems, the current practice is that on a system supporting + dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under + dnl $prefix/lib64 and 32-bit libraries go under $prefix/lib. We determine + dnl the compiler's default mode by looking at the compiler's library search + dnl path. If at least one of its elements ends in /lib64 or points to a + dnl directory whose absolute pathname ends in /lib64, we assume a 64-bit ABI. + dnl Otherwise we use the default, namely "lib". + dnl On Solaris systems, the current practice is that on a system supporting + dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under + dnl $prefix/lib/64 (which is a symlink to either $prefix/lib/sparcv9 or + dnl $prefix/lib/amd64) and 32-bit libraries go under $prefix/lib. + AC_REQUIRE([AC_CANONICAL_HOST]) + acl_libdirstem=lib + acl_libdirstem2= + case "$host_os" in + solaris*) + dnl See Solaris 10 Software Developer Collection > Solaris 64-bit Developer's Guide > The Development Environment + dnl . + dnl "Portable Makefiles should refer to any library directories using the 64 symbolic link." + dnl But we want to recognize the sparcv9 or amd64 subdirectory also if the + dnl symlink is missing, so we set acl_libdirstem2 too. + AC_CACHE_CHECK([for 64-bit host], [gl_cv_solaris_64bit], + [AC_EGREP_CPP([sixtyfour bits], [ +#ifdef _LP64 +sixtyfour bits +#endif + ], [gl_cv_solaris_64bit=yes], [gl_cv_solaris_64bit=no]) + ]) + if test $gl_cv_solaris_64bit = yes; then + acl_libdirstem=lib/64 + case "$host_cpu" in + sparc*) acl_libdirstem2=lib/sparcv9 ;; + i*86 | x86_64) acl_libdirstem2=lib/amd64 ;; + esac + fi + ;; + *) + searchpath=`(LC_ALL=C $CC -print-search-dirs) 2>/dev/null | sed -n -e 's,^libraries: ,,p' | sed -e 's,^=,,'` + if test -n "$searchpath"; then + acl_save_IFS="${IFS= }"; IFS=":" + for searchdir in $searchpath; do + if test -d "$searchdir"; then + case "$searchdir" in + */lib64/ | */lib64 ) acl_libdirstem=lib64 ;; + */../ | */.. ) + # Better ignore directories of this form. They are misleading. + ;; + *) searchdir=`cd "$searchdir" && pwd` + case "$searchdir" in + */lib64 ) acl_libdirstem=lib64 ;; + esac ;; + esac + fi + done + IFS="$acl_save_IFS" + fi + ;; + esac + test -n "$acl_libdirstem2" || acl_libdirstem2="$acl_libdirstem" +]) diff --git a/m4/libunistring.m4 b/m4/libunistring.m4 new file mode 100644 index 000000000..52ff06b61 --- /dev/null +++ b/m4/libunistring.m4 @@ -0,0 +1,37 @@ +# libunistring.m4 serial 1 +dnl Copyright (C) 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl gl_LIBUNISTRING +dnl Searches for an installed libunistring. +dnl If found, it sets and AC_SUBSTs HAVE_LIBUNISTRING=yes and the LIBUNISTRING +dnl and LTLIBUNISTRING variables and augments the CPPFLAGS variable, and +dnl #defines HAVE_LIBUNISTRING to 1. Otherwise, it sets and AC_SUBSTs +dnl HAVE_LIBUNISTRING=no and LIBUNINSTRING and LTLIBUNISTRING to empty. + +AC_DEFUN([gl_LIBUNISTRING], +[ + dnl First, try to link without -liconv. libunistring often depends on + dnl libiconv, but we don't know (and often don't need to know) where + dnl libiconv is installed. + AC_LIB_HAVE_LINKFLAGS([unistring], [], + [#include ], [u8_strconv_from_locale((char*)0);], + [no, consider installing GNU libunistring]) + if test "$ac_cv_libunistring" != yes; then + dnl Second try, with -liconv. + AC_REQUIRE([AM_ICONV]) + if test -n "$LIBICONV"; then + glus_save_LIBS="$LIBS" + LIBS="$LIBS $LIBICONV" + AC_LIB_HAVE_LINKFLAGS([unistring], [], + [#include ], [u8_strconv_from_locale((char*)0);], + [no, consider installing GNU libunistring]) + if test -n "$LIBUNISTRING"; then + LIBUNISTRING="$LIBUNISTRING $LIBICONV" + fi + LIBS="$glus_save_LIBS" + fi + fi +]) diff --git a/m4/string_h.m4 b/m4/string_h.m4 new file mode 100644 index 000000000..2d5553c37 --- /dev/null +++ b/m4/string_h.m4 @@ -0,0 +1,92 @@ +# Configure a GNU-like replacement for . + +# Copyright (C) 2007, 2008 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# serial 6 + +# Written by Paul Eggert. + +AC_DEFUN([gl_HEADER_STRING_H], +[ + dnl Use AC_REQUIRE here, so that the default behavior below is expanded + dnl once only, before all statements that occur in other macros. + AC_REQUIRE([gl_HEADER_STRING_H_BODY]) +]) + +AC_DEFUN([gl_HEADER_STRING_H_BODY], +[ + AC_REQUIRE([AC_C_RESTRICT]) + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + gl_CHECK_NEXT_HEADERS([string.h]) +]) + +AC_DEFUN([gl_STRING_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1 +]) + +AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS], +[ + GNULIB_MEMMEM=0; AC_SUBST([GNULIB_MEMMEM]) + GNULIB_MEMPCPY=0; AC_SUBST([GNULIB_MEMPCPY]) + GNULIB_MEMRCHR=0; AC_SUBST([GNULIB_MEMRCHR]) + GNULIB_RAWMEMCHR=0; AC_SUBST([GNULIB_RAWMEMCHR]) + GNULIB_STPCPY=0; AC_SUBST([GNULIB_STPCPY]) + GNULIB_STPNCPY=0; AC_SUBST([GNULIB_STPNCPY]) + GNULIB_STRCHRNUL=0; AC_SUBST([GNULIB_STRCHRNUL]) + GNULIB_STRDUP=0; AC_SUBST([GNULIB_STRDUP]) + GNULIB_STRNDUP=0; AC_SUBST([GNULIB_STRNDUP]) + GNULIB_STRNLEN=0; AC_SUBST([GNULIB_STRNLEN]) + GNULIB_STRPBRK=0; AC_SUBST([GNULIB_STRPBRK]) + GNULIB_STRSEP=0; AC_SUBST([GNULIB_STRSEP]) + GNULIB_STRSTR=0; AC_SUBST([GNULIB_STRSTR]) + GNULIB_STRCASESTR=0; AC_SUBST([GNULIB_STRCASESTR]) + GNULIB_STRTOK_R=0; AC_SUBST([GNULIB_STRTOK_R]) + GNULIB_MBSLEN=0; AC_SUBST([GNULIB_MBSLEN]) + GNULIB_MBSNLEN=0; AC_SUBST([GNULIB_MBSNLEN]) + GNULIB_MBSCHR=0; AC_SUBST([GNULIB_MBSCHR]) + GNULIB_MBSRCHR=0; AC_SUBST([GNULIB_MBSRCHR]) + GNULIB_MBSSTR=0; AC_SUBST([GNULIB_MBSSTR]) + GNULIB_MBSCASECMP=0; AC_SUBST([GNULIB_MBSCASECMP]) + GNULIB_MBSNCASECMP=0; AC_SUBST([GNULIB_MBSNCASECMP]) + GNULIB_MBSPCASECMP=0; AC_SUBST([GNULIB_MBSPCASECMP]) + GNULIB_MBSCASESTR=0; AC_SUBST([GNULIB_MBSCASESTR]) + GNULIB_MBSCSPN=0; AC_SUBST([GNULIB_MBSCSPN]) + GNULIB_MBSPBRK=0; AC_SUBST([GNULIB_MBSPBRK]) + GNULIB_MBSSPN=0; AC_SUBST([GNULIB_MBSSPN]) + GNULIB_MBSSEP=0; AC_SUBST([GNULIB_MBSSEP]) + GNULIB_MBSTOK_R=0; AC_SUBST([GNULIB_MBSTOK_R]) + GNULIB_STRERROR=0; AC_SUBST([GNULIB_STRERROR]) + GNULIB_STRSIGNAL=0; AC_SUBST([GNULIB_STRSIGNAL]) + GNULIB_STRVERSCMP=0; AC_SUBST([GNULIB_STRVERSCMP]) + dnl Assume proper GNU behavior unless another module says otherwise. + HAVE_DECL_MEMMEM=1; AC_SUBST([HAVE_DECL_MEMMEM]) + HAVE_MEMPCPY=1; AC_SUBST([HAVE_MEMPCPY]) + HAVE_DECL_MEMRCHR=1; AC_SUBST([HAVE_DECL_MEMRCHR]) + HAVE_RAWMEMCHR=1; AC_SUBST([HAVE_RAWMEMCHR]) + HAVE_STPCPY=1; AC_SUBST([HAVE_STPCPY]) + HAVE_STPNCPY=1; AC_SUBST([HAVE_STPNCPY]) + HAVE_STRCHRNUL=1; AC_SUBST([HAVE_STRCHRNUL]) + HAVE_DECL_STRDUP=1; AC_SUBST([HAVE_DECL_STRDUP]) + HAVE_STRNDUP=1; AC_SUBST([HAVE_STRNDUP]) + HAVE_DECL_STRNDUP=1; AC_SUBST([HAVE_DECL_STRNDUP]) + HAVE_DECL_STRNLEN=1; AC_SUBST([HAVE_DECL_STRNLEN]) + HAVE_STRPBRK=1; AC_SUBST([HAVE_STRPBRK]) + HAVE_STRSEP=1; AC_SUBST([HAVE_STRSEP]) + HAVE_STRCASESTR=1; AC_SUBST([HAVE_STRCASESTR]) + HAVE_DECL_STRTOK_R=1; AC_SUBST([HAVE_DECL_STRTOK_R]) + HAVE_DECL_STRERROR=1; AC_SUBST([HAVE_DECL_STRERROR]) + HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL]) + HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP]) + REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) + REPLACE_STRDUP=0; AC_SUBST([REPLACE_STRDUP]) + REPLACE_STRSTR=0; AC_SUBST([REPLACE_STRSTR]) + REPLACE_STRCASESTR=0; AC_SUBST([REPLACE_STRCASESTR]) + REPLACE_STRERROR=0; AC_SUBST([REPLACE_STRERROR]) + REPLACE_STRSIGNAL=0; AC_SUBST([REPLACE_STRSIGNAL]) +]) From 1ee2c72eafaae5f91f4c899bc4b4853af5c16f28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 27 May 2009 18:18:07 +0200 Subject: [PATCH 170/375] Import R6RS bytevectors and I/O ports from Guile-R6RS-Libs 0.2. * README: Document dependency on GNU libunistring. * benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add `benchmark/bytevectors.bm'. * configure.in: Make sure we have libunistring; update $LIBS. * libguile.h: Include "bytevectors.h" and "r6rs-ports.h". * libguile/Makefile.am (libguile_la_SOURCES): Add `bytevectors.c' and `r6rs-ports.c' (DOT_X_FILES): Add `bytevectors.x' and `r6rs-ports.x'. (DOT_DOC_FILES): Add `bytevectors.doc' and `r6rs-ports.doc'. (noinst_HEADERS): Add `ieee-754.h'. (modinclude_HEADERS): Add `bytevectors.h' and `r6rs-ports.h' * libguile/validate.h (SCM_VALIDATE_BYTEVECTOR): New macro. * module/Makefile.am (SOURCES): Add $(RNRS_SOURCES). (RNRS_SOURCES): New variable. * test-suite/Makefile.am (SCM_TESTS): Add `bytevectors.test' and `r6rs-ports.test'. --- README | 6 + benchmark-suite/Makefile.am | 1 + benchmark-suite/benchmarks/bytevectors.bm | 99 ++ configure.in | 7 + libguile.h | 4 +- libguile/Makefile.am | 26 +- libguile/bytevectors.c | 1978 +++++++++++++++++++++ libguile/bytevectors.h | 133 ++ libguile/ieee-754.h | 90 + libguile/r6rs-ports.c | 1118 ++++++++++++ libguile/r6rs-ports.h | 43 + libguile/validate.h | 5 +- module/Makefile.am | 7 +- module/rnrs/bytevector.scm | 84 + module/rnrs/io/ports.scm | 111 ++ test-suite/Makefile.am | 2 + test-suite/tests/bytevectors.test | 531 ++++++ test-suite/tests/r6rs-ports.test | 455 +++++ 18 files changed, 4688 insertions(+), 12 deletions(-) create mode 100644 benchmark-suite/benchmarks/bytevectors.bm create mode 100644 libguile/bytevectors.c create mode 100644 libguile/bytevectors.h create mode 100644 libguile/ieee-754.h create mode 100644 libguile/r6rs-ports.c create mode 100644 libguile/r6rs-ports.h create mode 100644 module/rnrs/bytevector.scm create mode 100644 module/rnrs/io/ports.scm create mode 100644 test-suite/tests/bytevectors.test create mode 100644 test-suite/tests/r6rs-ports.test diff --git a/README b/README index 9993fcfaf..4950229df 100644 --- a/README +++ b/README @@ -61,6 +61,12 @@ Guile requires the following external packages: libltdl is used for loading extensions at run-time. It is available from http://www.gnu.org/software/libtool/ + - GNU libunistring + + libunistring is used for Unicode string operations, such as the + `utf*->string' procedures. It is available from + http://www.gnu.org/software/libunistring/ . + Special Instructions For Some Systems ===================================== diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index e65e8bcb2..dcadd5869 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -1,4 +1,5 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \ + benchmarks/bytevectors.bm \ benchmarks/continuations.bm \ benchmarks/if.bm \ benchmarks/logand.bm \ diff --git a/benchmark-suite/benchmarks/bytevectors.bm b/benchmark-suite/benchmarks/bytevectors.bm new file mode 100644 index 000000000..9547a71df --- /dev/null +++ b/benchmark-suite/benchmarks/bytevectors.bm @@ -0,0 +1,99 @@ +;;; -*- mode: scheme; coding: latin-1; -*- +;;; R6RS Byte Vectors. +;;; +;;; Copyright 2009 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks bytevector) + :use-module (rnrs bytevector) + :use-module (srfi srfi-4) + :use-module (benchmark-suite lib)) + +(define bv (make-bytevector 16384)) + +(define %native-endianness + (native-endianness)) + +(define %foreign-endianness + (if (eq? (native-endianness) (endianness little)) + (endianness big) + (endianness little))) + +(define u8v (make-u8vector 16384)) +(define u16v (make-u16vector 8192)) +(define u32v (make-u32vector 4196)) +(define u64v (make-u64vector 2048)) + + +(with-benchmark-prefix "ref/set!" + + (benchmark "bytevector-u8-ref" 1000000 + (bytevector-u8-ref bv 0)) + + (benchmark "bytevector-u16-ref (foreign)" 1000000 + (bytevector-u16-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u16-ref (native)" 1000000 + (bytevector-u16-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u16-native-ref" 1000000 + (bytevector-u16-native-ref bv 0)) + + (benchmark "bytevector-u32-ref (foreign)" 1000000 + (bytevector-u32-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u32-ref (native)" 1000000 + (bytevector-u32-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u32-native-ref" 1000000 + (bytevector-u32-native-ref bv 0)) + + (benchmark "bytevector-u64-ref (foreign)" 1000000 + (bytevector-u64-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u64-ref (native)" 1000000 + (bytevector-u64-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u64-native-ref" 1000000 + (bytevector-u16-native-ref bv 0))) + + +(with-benchmark-prefix "lists" + + (benchmark "bytevector->u8-list" 2000 + (bytevector->u8-list bv)) + + (benchmark "bytevector->uint-list 16-bit" 2000 + (bytevector->uint-list bv (native-endianness) 2)) + + (benchmark "bytevector->uint-list 64-bit" 2000 + (bytevector->uint-list bv (native-endianness) 8))) + + +(with-benchmark-prefix "SRFI-4" ;; for comparison + + (benchmark "u8vector-ref" 1000000 + (u8vector-ref u8v 0)) + + (benchmark "u16vector-ref" 1000000 + (u16vector-ref u16v 0)) + + (benchmark "u32vector-ref" 1000000 + (u32vector-ref u32v 0)) + + (benchmark "u64vector-ref" 1000000 + (u64vector-ref u64v 0))) diff --git a/configure.in b/configure.in index 07c476686..6568e524f 100644 --- a/configure.in +++ b/configure.in @@ -836,6 +836,13 @@ AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [], [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])]) +dnl GNU libunistring tests. +if test "x$LTLIBUNISTRING" != "x"; then + LIBS="$LTLIBUNISTRING $LIBS" +else + AC_MSG_ERROR([GNU libunistring is required, please install it.]) +fi + dnl i18n tests #AC_CHECK_HEADERS([libintl.h]) #AC_CHECK_FUNCS(gettext) diff --git a/libguile.h b/libguile.h index 40122dfa2..6a6d232f9 100644 --- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #ifndef SCM_LIBGUILE_H #define SCM_LIBGUILE_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -32,6 +32,7 @@ extern "C" { #include "libguile/arbiters.h" #include "libguile/async.h" #include "libguile/boolean.h" +#include "libguile/bytevectors.h" #include "libguile/chars.h" #include "libguile/continuations.h" #include "libguile/dynl.h" @@ -75,6 +76,7 @@ extern "C" { #include "libguile/procprop.h" #include "libguile/properties.h" #include "libguile/procs.h" +#include "libguile/r6rs-ports.h" #include "libguile/ramap.h" #include "libguile/random.h" #include "libguile/read.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 63f2ef2bf..fcf197a54 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -106,7 +106,8 @@ guile_LDFLAGS = $(GUILE_CFLAGS) libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS) libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c convert.c debug.c deprecation.c \ + bytevectors.c chars.c continuations.c \ + convert.c debug.c deprecation.c \ deprecated.c discouraged.c dynwind.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \ @@ -115,7 +116,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ guardians.c hash.c hashtab.c hooks.c init.c inline.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ - print.c procprop.c procs.c properties.c random.c rdelim.c read.c \ + print.c procprop.c procs.c properties.c \ + r6rs-ports.c random.c rdelim.c read.c \ root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \ stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \ strorder.c strports.c struct.c symbols.c threads.c null-threads.c \ @@ -134,7 +136,8 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \ -module -L$(builddir) -lguile \ -version-info @LIBGUILE_I18N_INTERFACE@ -DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ +DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \ + bytevectors.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ dynl.x dynwind.x eq.x error.x eval.x evalext.x \ extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \ @@ -143,7 +146,8 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \ - properties.x random.x rdelim.x read.x root.x rw.x scmsigs.x \ + properties.x r6rs-ports.x random.x rdelim.x \ + read.x root.x rw.x scmsigs.x \ script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \ stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \ strports.x struct.x symbols.x threads.x throw.x values.x \ @@ -155,7 +159,8 @@ DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ - boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \ + boolean.doc bytevectors.doc chars.doc \ + continuations.doc debug.doc deprecation.doc \ deprecated.doc discouraged.doc dynl.doc dynwind.doc \ eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ @@ -165,7 +170,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \ list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \ objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \ - procprop.doc procs.doc properties.doc random.doc rdelim.doc \ + procprop.doc procs.doc properties.doc r6rs-ports.doc \ + random.doc rdelim.doc \ read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \ smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \ strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \ @@ -204,7 +210,7 @@ install-exec-hook: ## working. noinst_HEADERS = convert.i.c \ conv-integer.i.c conv-uinteger.i.c \ - eval.i.c \ + eval.i.c ieee-754.h \ srfi-4.i.c \ quicksort.i.c \ win32-uname.h win32-dirent.h win32-socket.h \ @@ -223,7 +229,8 @@ pkginclude_HEADERS = # These are headers visible as . modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ - boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \ + boolean.h bytevectors.h chars.h continuations.h convert.h \ + debug.h debug-malloc.h \ deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ eq.h error.h eval.h evalext.h extensions.h \ feature.h filesys.h fluids.h fports.h futures.h gc.h \ @@ -232,7 +239,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \ keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \ - posix.h regex-posix.h print.h procprop.h procs.h properties.h \ + posix.h r6rs-ports.h regex-posix.h print.h \ + procprop.h procs.h properties.h \ random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \ script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \ stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \ diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c new file mode 100644 index 000000000..4c3a353a1 --- /dev/null +++ b/libguile/bytevectors.c @@ -0,0 +1,1978 @@ +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include + +#include "libguile/_scm.h" +#include "libguile/bytevectors.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/ieee-754.h" + +#include +#include +#include + +#ifdef HAVE_LIMITS_H +# include +#else +/* Assuming 32-bit longs. */ +# define ULONG_MAX 4294967295UL +#endif + +#include + + + +/* Utilities. */ + +/* Convenience macros. These are used by the various templates (macros) that + are parameterized by integer signedness. */ +#define INT8_T_signed scm_t_int8 +#define INT8_T_unsigned scm_t_uint8 +#define INT16_T_signed scm_t_int16 +#define INT16_T_unsigned scm_t_uint16 +#define INT32_T_signed scm_t_int32 +#define INT32_T_unsigned scm_t_uint32 +#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L)) +#define is_unsigned_int8(_x) ((_x) <= 255UL) +#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L)) +#define is_unsigned_int16(_x) ((_x) <= 65535UL) +#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L)) +#define is_unsigned_int32(_x) ((_x) <= 4294967295UL) +#define SIGNEDNESS_signed 1 +#define SIGNEDNESS_unsigned 0 + +#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign +#define INT_SWAP(_size) bswap_ ## _size +#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size +#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign + + +#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \ + unsigned c_len, c_index; \ + _sign char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_uint (index); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \ + scm_out_of_range (FUNC_NAME, index); + +/* Template for fixed-size integer access (only 8, 16 or 32-bit). */ +#define INTEGER_REF(_len, _sign) \ + SCM result; \ + \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + { \ + INT_TYPE (_len, _sign) c_result; \ + \ + memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ + if (!scm_is_eq (endianness, native_endianness)) \ + c_result = INT_SWAP (_len) (c_result); \ + \ + result = SCM_I_MAKINUM (c_result); \ + } \ + \ + return result; + +/* Template for fixed-size integer access using the native endianness. */ +#define INTEGER_NATIVE_REF(_len, _sign) \ + SCM result; \ + \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + { \ + INT_TYPE (_len, _sign) c_result; \ + \ + memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ + result = SCM_I_MAKINUM (c_result); \ + } \ + \ + return result; + +/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */ +#define INTEGER_SET(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + { \ + _sign long c_value; \ + INT_TYPE (_len, _sign) c_value_short; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + scm_wrong_type_arg (FUNC_NAME, 3, value); \ + \ + c_value = SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short = (INT_TYPE (_len, _sign)) c_value; \ + if (!scm_is_eq (endianness, native_endianness)) \ + c_value_short = INT_SWAP (_len) (c_value_short); \ + \ + memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ + } \ + \ + return SCM_UNSPECIFIED; + +/* Template for fixed-size integer modification using the native + endianness. */ +#define INTEGER_NATIVE_SET(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + { \ + _sign long c_value; \ + INT_TYPE (_len, _sign) c_value_short; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + scm_wrong_type_arg (FUNC_NAME, 3, value); \ + \ + c_value = SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short = (INT_TYPE (_len, _sign)) c_value; \ + \ + memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ + } \ + \ + return SCM_UNSPECIFIED; + + + +/* Bytevector type. */ + +SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0); + +#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \ + SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len)) +#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \ + SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf)) + +/* The empty bytevector. */ +SCM scm_null_bytevector = SCM_UNSPECIFIED; + + +static inline SCM +make_bytevector_from_buffer (unsigned len, signed char *contents) +{ + /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */ + SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents); +} + +static inline SCM +make_bytevector (unsigned len) +{ + SCM bv; + + if (SCM_UNLIKELY (len == 0)) + bv = scm_null_bytevector; + else + { + signed char *contents = NULL; + + if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)) + contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR); + + bv = make_bytevector_from_buffer (len, contents); + } + + return bv; +} + +/* Return a new bytevector of size LEN octets. */ +SCM +scm_c_make_bytevector (unsigned len) +{ + return (make_bytevector (len)); +} + +/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to + by CONTENTS must have been allocated using `scm_gc_malloc ()'. */ +SCM +scm_c_take_bytevector (signed char *contents, unsigned len) +{ + SCM bv; + + if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))) + { + /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */ + signed char *c_bv; + + bv = make_bytevector (len); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + memcpy (c_bv, contents, len); + scm_gc_free (contents, len, SCM_GC_BYTEVECTOR); + } + else + bv = make_bytevector_from_buffer (len, contents); + + return bv; +} + +/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current + size) and return BV. */ +SCM +scm_i_shrink_bytevector (SCM bv, unsigned c_new_len) +{ + if (!SCM_BYTEVECTOR_INLINE_P (bv)) + { + unsigned c_len; + signed char *c_bv, *c_new_bv; + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len); + + if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len)) + { + /* Copy to the in-line buffer and free the current buffer. */ + c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv); + memcpy (c_new_bv, c_bv, c_new_len); + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + /* Resize the existing buffer. */ + c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len, + SCM_GC_BYTEVECTOR); + SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv); + } + } + + return bv; +} + +SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, + bv, port, pstate) +{ + unsigned c_len, i; + unsigned char *c_bv; + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + scm_puts ("#vu8(", port); + for (i = 0; i < c_len; i++) + { + if (i > 0) + scm_putc (' ', port); + + scm_uintprint (c_bv[i], 10, port); + } + + scm_putc (')', port); + + /* Make GCC think we use it. */ + scm_remember_upto_here ((SCM) pstate); + + return 1; +} + +SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv) +{ + + if (!SCM_BYTEVECTOR_INLINE_P (bv)) + { + unsigned c_len; + signed char *c_bv; + + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + + return 0; +} + + + +/* General operations. */ + +SCM_SYMBOL (scm_sym_big, "big"); +SCM_SYMBOL (scm_sym_little, "little"); + +SCM scm_endianness_big, scm_endianness_little; + +/* Host endianness (a symbol). */ +static SCM native_endianness = SCM_UNSPECIFIED; + +/* Byte-swapping. */ +#ifndef bswap_24 +# define bswap_24(_x) \ + ((((_x) & 0xff0000) >> 16) | \ + (((_x) & 0x00ff00)) | \ + (((_x) & 0x0000ff) << 16)) +#endif + + +SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0, + (void), + "Return a symbol denoting the machine's native endianness.") +#define FUNC_NAME s_scm_native_endianness +{ + return native_endianness; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0, + (SCM obj), + "Return true if @var{obj} is a bytevector.") +#define FUNC_NAME s_scm_bytevector_p +{ + return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector, + obj))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0, + (SCM len, SCM fill), + "Return a newly allocated bytevector of @var{len} bytes, " + "optionally filled with @var{fill}.") +#define FUNC_NAME s_scm_make_bytevector +{ + SCM bv; + unsigned c_len; + signed char c_fill = '\0'; + + SCM_VALIDATE_UINT_COPY (1, len, c_len); + if (fill != SCM_UNDEFINED) + { + int value; + + value = scm_to_int (fill); + if (SCM_UNLIKELY ((value < -128) || (value > 255))) + scm_out_of_range (FUNC_NAME, fill); + c_fill = (signed char) value; + } + + bv = make_bytevector (c_len); + if (fill != SCM_UNDEFINED) + { + unsigned i; + signed char *contents; + + contents = SCM_BYTEVECTOR_CONTENTS (bv); + for (i = 0; i < c_len; i++) + contents[i] = c_fill; + } + + return bv; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0, + (SCM bv), + "Return the length (in bytes) of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_length +{ + SCM_VALIDATE_BYTEVECTOR (1, bv); + + return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0, + (SCM bv1, SCM bv2), + "Return is @var{bv1} equals to @var{bv2}---i.e., if they " + "have the same length and contents.") +#define FUNC_NAME s_scm_bytevector_eq_p +{ + SCM result = SCM_BOOL_F; + unsigned c_len1, c_len2; + + SCM_VALIDATE_BYTEVECTOR (1, bv1); + SCM_VALIDATE_BYTEVECTOR (2, bv2); + + c_len1 = SCM_BYTEVECTOR_LENGTH (bv1); + c_len2 = SCM_BYTEVECTOR_LENGTH (bv2); + + if (c_len1 == c_len2) + { + signed char *c_bv1, *c_bv2; + + c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1); + c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2); + + result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1)); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0, + (SCM bv, SCM fill), + "Fill bytevector @var{bv} with @var{fill}, a byte.") +#define FUNC_NAME s_scm_bytevector_fill_x +{ + unsigned c_len, i; + signed char *c_bv, c_fill; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + c_fill = scm_to_int8 (fill); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + for (i = 0; i < c_len; i++) + c_bv[i] = c_fill; + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0, + (SCM source, SCM source_start, SCM target, SCM target_start, + SCM len), + "Copy @var{len} bytes from @var{source} into @var{target}, " + "starting reading from @var{source_start} (a positive index " + "within @var{source}) and start writing at " + "@var{target_start}.") +#define FUNC_NAME s_scm_bytevector_copy_x +{ + unsigned c_len, c_source_len, c_target_len; + unsigned c_source_start, c_target_start; + signed char *c_source, *c_target; + + SCM_VALIDATE_BYTEVECTOR (1, source); + SCM_VALIDATE_BYTEVECTOR (3, target); + + c_len = scm_to_uint (len); + c_source_start = scm_to_uint (source_start); + c_target_start = scm_to_uint (target_start); + + c_source = SCM_BYTEVECTOR_CONTENTS (source); + c_target = SCM_BYTEVECTOR_CONTENTS (target); + c_source_len = SCM_BYTEVECTOR_LENGTH (source); + c_target_len = SCM_BYTEVECTOR_LENGTH (target); + + if (SCM_UNLIKELY (c_source_start + c_len > c_source_len)) + scm_out_of_range (FUNC_NAME, source_start); + if (SCM_UNLIKELY (c_target_start + c_len > c_target_len)) + scm_out_of_range (FUNC_NAME, target_start); + + memcpy (c_target + c_target_start, + c_source + c_source_start, + c_len); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0, + (SCM bv), + "Return a newly allocated copy of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_copy +{ + SCM copy; + unsigned c_len; + signed char *c_bv, *c_copy; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + copy = make_bytevector (c_len); + c_copy = SCM_BYTEVECTOR_CONTENTS (copy); + memcpy (c_copy, c_bv, c_len); + + return copy; +} +#undef FUNC_NAME + + +/* Operations on bytes and octets. */ + +SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0, + (SCM bv, SCM index), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_ref +{ + INTEGER_NATIVE_REF (8, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0, + (SCM bv, SCM index), + "Return the byte located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_s8_ref +{ + INTEGER_NATIVE_REF (8, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_set_x +{ + INTEGER_NATIVE_SET (8, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_set_x +{ + INTEGER_NATIVE_SET (8, signed); +} +#undef FUNC_NAME + +#undef OCTET_ACCESSOR_PROLOGUE + + +SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0, + (SCM bv), + "Return a newly allocated list of octets containing the " + "contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_u8_list +{ + SCM lst, pair; + unsigned c_len, i; + unsigned char *c_bv; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED); + for (i = 0, pair = lst; + i < c_len; + i++, pair = SCM_CDR (pair)) + { + SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i])); + } + + return lst; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0, + (SCM lst), + "Turn @var{lst}, a list of octets, into a bytevector.") +#define FUNC_NAME s_scm_u8_list_to_bytevector +{ + SCM bv, item; + long c_len, i; + unsigned char *c_bv; + + SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); + + bv = make_bytevector (c_len); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + for (i = 0; i < c_len; lst = SCM_CDR (lst), i++) + { + item = SCM_CAR (lst); + + if (SCM_LIKELY (SCM_I_INUMP (item))) + { + long c_item; + + c_item = SCM_I_INUM (item); + if (SCM_LIKELY ((c_item >= 0) && (c_item < 256))) + c_bv[i] = (unsigned char) c_item; + else + goto type_error; + } + else + goto type_error; + } + + return bv; + + type_error: + scm_wrong_type_arg (FUNC_NAME, 1, item); + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +/* Compute the two's complement of VALUE (a positive integer) on SIZE octets + using (2^(SIZE * 8) - VALUE). */ +static inline void +twos_complement (mpz_t value, size_t size) +{ + unsigned long bit_count; + + /* We expect BIT_COUNT to fit in a unsigned long thanks to the range + checking on SIZE performed earlier. */ + bit_count = (unsigned long) size << 3UL; + + if (SCM_LIKELY (bit_count < sizeof (unsigned long))) + mpz_ui_sub (value, 1UL << bit_count, value); + else + { + mpz_t max; + + mpz_init (max); + mpz_ui_pow_ui (max, 2, bit_count); + mpz_sub (value, max, value); + mpz_clear (max); + } +} + +static inline SCM +bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p, + SCM endianness) +{ + SCM result; + mpz_t c_mpz; + int c_endianness, negative_p = 0; + + if (signed_p) + { + if (scm_is_eq (endianness, scm_sym_big)) + negative_p = c_bv[0] & 0x80; + else + negative_p = c_bv[c_size - 1] & 0x80; + } + + c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + + mpz_init (c_mpz); + mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */, + c_size /* word is C_SIZE-byte long */, + c_endianness, + 0 /* nails */, c_bv); + + if (signed_p && negative_p) + { + twos_complement (c_mpz, c_size); + mpz_neg (c_mpz, c_mpz); + } + + result = scm_from_mpz (c_mpz); + mpz_clear (c_mpz); /* FIXME: Needed? */ + + return result; +} + +static inline int +bytevector_large_set (char *c_bv, size_t c_size, int signed_p, + SCM value, SCM endianness) +{ + mpz_t c_mpz; + int c_endianness, c_sign, err = 0; + + c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + + mpz_init (c_mpz); + scm_to_mpz (value, c_mpz); + + c_sign = mpz_sgn (c_mpz); + if (c_sign < 0) + { + if (SCM_LIKELY (signed_p)) + { + mpz_neg (c_mpz, c_mpz); + twos_complement (c_mpz, c_size); + } + else + { + err = -1; + goto finish; + } + } + + if (c_sign == 0) + /* Zero. */ + memset (c_bv, 0, c_size); + else + { + size_t word_count, value_size; + + value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size); + if (SCM_UNLIKELY (value_size > c_size)) + { + err = -2; + goto finish; + } + + + mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */, + c_size, c_endianness, + 0 /* nails */, c_mpz); + if (SCM_UNLIKELY (word_count != 1)) + /* Shouldn't happen since we already checked with VALUE_SIZE. */ + abort (); + } + + finish: + mpz_clear (c_mpz); + + return err; +} + +#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \ + unsigned long c_len, c_index, c_size; \ + char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_ulong (index); \ + c_size = scm_to_ulong (size); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + /* C_SIZE must have its 3 higher bits set to zero so that \ + multiplying it by 8 yields a number that fits in an \ + unsigned long. */ \ + if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \ + scm_out_of_range (FUNC_NAME, size); \ + if (SCM_UNLIKELY (c_index + c_size > c_len)) \ + scm_out_of_range (FUNC_NAME, index); + + +/* Template of an integer reference function. */ +#define GENERIC_INTEGER_REF(_sign) \ + SCM result; \ + \ + if (c_size < 3) \ + { \ + int swap; \ + _sign int value; \ + \ + swap = !scm_is_eq (endianness, native_endianness); \ + switch (c_size) \ + { \ + case 1: \ + { \ + _sign char c_value8; \ + memcpy (&c_value8, c_bv, 1); \ + value = c_value8; \ + } \ + break; \ + case 2: \ + { \ + INT_TYPE (16, _sign) c_value16; \ + memcpy (&c_value16, c_bv, 2); \ + if (swap) \ + value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \ + else \ + value = c_value16; \ + } \ + break; \ + default: \ + abort (); \ + } \ + \ + result = SCM_I_MAKINUM ((_sign int) value); \ + } \ + else \ + result = bytevector_large_ref ((char *) c_bv, \ + c_size, SIGNEDNESS (_sign), \ + endianness); \ + \ + return result; + +static inline SCM +bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness) +{ + GENERIC_INTEGER_REF (signed); +} + +static inline SCM +bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness) +{ + GENERIC_INTEGER_REF (unsigned); +} + + +/* Template of an integer assignment function. */ +#define GENERIC_INTEGER_SET(_sign) \ + if (c_size < 3) \ + { \ + _sign int c_value; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + goto range_error; \ + \ + c_value = SCM_I_INUM (value); \ + switch (c_size) \ + { \ + case 1: \ + if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \ + { \ + _sign char c_value8; \ + c_value8 = (_sign char) c_value; \ + memcpy (c_bv, &c_value8, 1); \ + } \ + else \ + goto range_error; \ + break; \ + \ + case 2: \ + if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \ + { \ + int swap; \ + INT_TYPE (16, _sign) c_value16; \ + \ + swap = !scm_is_eq (endianness, native_endianness); \ + \ + if (swap) \ + c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \ + else \ + c_value16 = c_value; \ + \ + memcpy (c_bv, &c_value16, 2); \ + } \ + else \ + goto range_error; \ + break; \ + \ + default: \ + abort (); \ + } \ + } \ + else \ + { \ + int err; \ + \ + err = bytevector_large_set (c_bv, c_size, \ + SIGNEDNESS (_sign), \ + value, endianness); \ + if (err) \ + goto range_error; \ + } \ + \ + return; \ + \ + range_error: \ + scm_out_of_range (FUNC_NAME, value); \ + return; + +static inline void +bytevector_signed_set (char *c_bv, size_t c_size, + SCM value, SCM endianness, + const char *func_name) +#define FUNC_NAME func_name +{ + GENERIC_INTEGER_SET (signed); +} +#undef FUNC_NAME + +static inline void +bytevector_unsigned_set (char *c_bv, size_t c_size, + SCM value, SCM endianness, + const char *func_name) +#define FUNC_NAME func_name +{ + GENERIC_INTEGER_SET (unsigned); +} +#undef FUNC_NAME + +#undef GENERIC_INTEGER_SET +#undef GENERIC_INTEGER_REF + + +SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0, + (SCM bv, SCM index, SCM endianness, SCM size), + "Return the @var{size}-octet long unsigned integer at index " + "@var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_uint_ref +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + + return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0, + (SCM bv, SCM index, SCM endianness, SCM size), + "Return the @var{size}-octet long unsigned integer at index " + "@var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_sint_ref +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + + return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness, SCM size), + "Set the @var{size}-octet long unsigned integer at @var{index} " + "to @var{value}.") +#define FUNC_NAME s_scm_bytevector_uint_set_x +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + + bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness, + FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness, SCM size), + "Set the @var{size}-octet long signed integer at @var{index} " + "to @var{value}.") +#define FUNC_NAME s_scm_bytevector_sint_set_x +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + + bytevector_signed_set (&c_bv[c_index], c_size, value, endianness, + FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* Operations on integers of arbitrary size. */ + +#define INTEGERS_TO_LIST(_sign) \ + SCM lst, pair; \ + size_t i, c_len, c_size; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + c_size = scm_to_uint (size); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + if (SCM_UNLIKELY (c_len == 0)) \ + lst = SCM_EOL; \ + else if (SCM_UNLIKELY (c_len < c_size)) \ + scm_out_of_range (FUNC_NAME, size); \ + else \ + { \ + const char *c_bv; \ + \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + lst = scm_make_list (scm_from_uint (c_len / c_size), \ + SCM_UNSPECIFIED); \ + for (i = 0, pair = lst; \ + i <= c_len - c_size; \ + i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \ + { \ + SCM_SETCAR (pair, \ + bytevector_ ## _sign ## _ref (c_bv, c_size, \ + endianness)); \ + } \ + } \ + \ + return lst; + +SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list", + 3, 0, 0, + (SCM bv, SCM endianness, SCM size), + "Return a list of signed integers of @var{size} octets " + "representing the contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_sint_list +{ + INTEGERS_TO_LIST (signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list", + 3, 0, 0, + (SCM bv, SCM endianness, SCM size), + "Return a list of unsigned integers of @var{size} octets " + "representing the contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_uint_list +{ + INTEGERS_TO_LIST (unsigned); +} +#undef FUNC_NAME + +#undef INTEGER_TO_LIST + + +#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \ + SCM bv; \ + long c_len; \ + size_t c_size; \ + char *c_bv, *c_bv_ptr; \ + \ + SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + c_size = scm_to_uint (size); \ + \ + if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \ + scm_out_of_range (FUNC_NAME, size); \ + \ + bv = make_bytevector (c_len * c_size); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + for (c_bv_ptr = c_bv; \ + !scm_is_null (lst); \ + lst = SCM_CDR (lst), c_bv_ptr += c_size) \ + { \ + bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \ + SCM_CAR (lst), endianness, \ + FUNC_NAME); \ + } \ + \ + return bv; + + +SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector", + 3, 0, 0, + (SCM lst, SCM endianness, SCM size), + "Return a bytevector containing the unsigned integers " + "listed in @var{lst} and encoded on @var{size} octets " + "according to @var{endianness}.") +#define FUNC_NAME s_scm_uint_list_to_bytevector +{ + INTEGER_LIST_TO_BYTEVECTOR (unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector", + 3, 0, 0, + (SCM lst, SCM endianness, SCM size), + "Return a bytevector containing the signed integers " + "listed in @var{lst} and encoded on @var{size} octets " + "according to @var{endianness}.") +#define FUNC_NAME s_scm_sint_list_to_bytevector +{ + INTEGER_LIST_TO_BYTEVECTOR (signed); +} +#undef FUNC_NAME + +#undef INTEGER_LIST_TO_BYTEVECTOR + + + +/* Operations on 16-bit integers. */ + +SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u16_ref +{ + INTEGER_REF (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 16-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s16_ref +{ + INTEGER_REF (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u16_native_ref +{ + INTEGER_NATIVE_REF (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s16_native_ref +{ + INTEGER_NATIVE_REF (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u16_set_x +{ + INTEGER_SET (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s16_set_x +{ + INTEGER_SET (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u16_native_set_x +{ + INTEGER_NATIVE_SET (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s16_native_set_x +{ + INTEGER_NATIVE_SET (16, signed); +} +#undef FUNC_NAME + + + +/* Operations on 32-bit integers. */ + +/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold + arbitrary 32-bit integers. Thus we fall back to using the + `large_{ref,set}' variants on 32-bit machines. */ + +#define LARGE_INTEGER_REF(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), endianness)); + +#define LARGE_INTEGER_SET(_len, _sign) \ + int err; \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (4, endianness); \ + \ + err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), value, endianness); \ + if (SCM_UNLIKELY (err)) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + return SCM_UNSPECIFIED; + +#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ + return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), native_endianness)); + +#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \ + int err; \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), value, \ + native_endianness); \ + if (SCM_UNLIKELY (err)) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + return SCM_UNSPECIFIED; + + +SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u32_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_REF (32, unsigned); +#else + LARGE_INTEGER_REF (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 32-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s32_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_REF (32, signed); +#else + LARGE_INTEGER_REF (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u32_native_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_REF (32, unsigned); +#else + LARGE_INTEGER_NATIVE_REF (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s32_native_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_REF (32, signed); +#else + LARGE_INTEGER_NATIVE_REF (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u32_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_SET (32, unsigned); +#else + LARGE_INTEGER_SET (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s32_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_SET (32, signed); +#else + LARGE_INTEGER_SET (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u32_native_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_SET (32, unsigned); +#else + LARGE_INTEGER_NATIVE_SET (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s32_native_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_SET (32, signed); +#else + LARGE_INTEGER_NATIVE_SET (32, signed); +#endif +} +#undef FUNC_NAME + + + +/* Operations on 64-bit integers. */ + +/* For 64-bit integers, we use only the `large_{ref,set}' variant. */ + +SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u64_ref +{ + LARGE_INTEGER_REF (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 64-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s64_ref +{ + LARGE_INTEGER_REF (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u64_native_ref +{ + LARGE_INTEGER_NATIVE_REF (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s64_native_ref +{ + LARGE_INTEGER_NATIVE_REF (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u64_set_x +{ + LARGE_INTEGER_SET (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s64_set_x +{ + LARGE_INTEGER_SET (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u64_native_set_x +{ + LARGE_INTEGER_NATIVE_SET (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s64_native_set_x +{ + LARGE_INTEGER_NATIVE_SET (64, signed); +} +#undef FUNC_NAME + + + +/* Operations on IEEE-754 numbers. */ + +/* There are two possible word endians, visible in glibc's . + However, in R6RS, when the endianness is `little', little endian is + assumed for both the byte order and the word order. This is clear from + Section 2.1 of R6RS-lib (in response to + http://www.r6rs.org/formal-comments/comment-187.txt). */ + + +/* Convert to/from a floating-point number with different endianness. This + method is probably not the most efficient but it should be portable. */ + +static inline void +float_to_foreign_endianness (union scm_ieee754_float *target, + float source) +{ + union scm_ieee754_float src; + + src.f = source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_endian.negative = src.big_endian.negative; + target->little_endian.exponent = src.big_endian.exponent; + target->little_endian.mantissa = src.big_endian.mantissa; +#else + target->big_endian.negative = src.little_endian.negative; + target->big_endian.exponent = src.little_endian.exponent; + target->big_endian.mantissa = src.little_endian.mantissa; +#endif +} + +static inline float +float_from_foreign_endianness (const union scm_ieee754_float *source) +{ + union scm_ieee754_float result; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + result.big_endian.negative = source->little_endian.negative; + result.big_endian.exponent = source->little_endian.exponent; + result.big_endian.mantissa = source->little_endian.mantissa; +#else + result.little_endian.negative = source->big_endian.negative; + result.little_endian.exponent = source->big_endian.exponent; + result.little_endian.mantissa = source->big_endian.mantissa; +#endif + + return (result.f); +} + +static inline void +double_to_foreign_endianness (union scm_ieee754_double *target, + double source) +{ + union scm_ieee754_double src; + + src.d = source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_little_endian.negative = src.big_endian.negative; + target->little_little_endian.exponent = src.big_endian.exponent; + target->little_little_endian.mantissa0 = src.big_endian.mantissa0; + target->little_little_endian.mantissa1 = src.big_endian.mantissa1; +#else + target->big_endian.negative = src.little_little_endian.negative; + target->big_endian.exponent = src.little_little_endian.exponent; + target->big_endian.mantissa0 = src.little_little_endian.mantissa0; + target->big_endian.mantissa1 = src.little_little_endian.mantissa1; +#endif +} + +static inline double +double_from_foreign_endianness (const union scm_ieee754_double *source) +{ + union scm_ieee754_double result; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + result.big_endian.negative = source->little_little_endian.negative; + result.big_endian.exponent = source->little_little_endian.exponent; + result.big_endian.mantissa0 = source->little_little_endian.mantissa0; + result.big_endian.mantissa1 = source->little_little_endian.mantissa1; +#else + result.little_little_endian.negative = source->big_endian.negative; + result.little_little_endian.exponent = source->big_endian.exponent; + result.little_little_endian.mantissa0 = source->big_endian.mantissa0; + result.little_little_endian.mantissa1 = source->big_endian.mantissa1; +#endif + + return (result.d); +} + +/* Template macros to abstract over doubles and floats. + XXX: Guile can only convert to/from doubles. */ +#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type +#define IEEE754_TO_SCM(_c_type) scm_from_double +#define IEEE754_FROM_SCM(_c_type) scm_to_double +#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \ + _c_type ## _from_foreign_endianness +#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \ + _c_type ## _to_foreign_endianness + + +/* Templace getters and setters. */ + +#define IEEE754_ACCESSOR_PROLOGUE(_type) \ + INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed); + +#define IEEE754_REF(_type) \ + _type c_result; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + if (scm_is_eq (endianness, native_endianness)) \ + memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ + else \ + { \ + IEEE754_UNION (_type) c_raw; \ + \ + memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \ + c_result = \ + IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \ + } \ + \ + return (IEEE754_TO_SCM (_type) (c_result)); + +#define IEEE754_NATIVE_REF(_type) \ + _type c_result; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + \ + memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ + return (IEEE754_TO_SCM (_type) (c_result)); + +#define IEEE754_SET(_type) \ + _type c_value; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_REAL (3, value); \ + SCM_VALIDATE_SYMBOL (4, endianness); \ + c_value = IEEE754_FROM_SCM (_type) (value); \ + \ + if (scm_is_eq (endianness, native_endianness)) \ + memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \ + else \ + { \ + IEEE754_UNION (_type) c_raw; \ + \ + IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \ + memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \ + } \ + \ + return SCM_UNSPECIFIED; + +#define IEEE754_NATIVE_SET(_type) \ + _type c_value; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_REAL (3, value); \ + c_value = IEEE754_FROM_SCM (_type) (value); \ + \ + memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \ + return SCM_UNSPECIFIED; + + +/* Single precision. */ + +SCM_DEFINE (scm_bytevector_ieee_single_ref, + "bytevector-ieee-single-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the IEEE-754 single from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_ieee_single_ref +{ + IEEE754_REF (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_native_ref, + "bytevector-ieee-single-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the IEEE-754 single from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref +{ + IEEE754_NATIVE_REF (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_set_x, + "bytevector-ieee-single-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store real @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_ieee_single_set_x +{ + IEEE754_SET (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_native_set_x, + "bytevector-ieee-single-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the real @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x +{ + IEEE754_NATIVE_SET (float); +} +#undef FUNC_NAME + + +/* Double precision. */ + +SCM_DEFINE (scm_bytevector_ieee_double_ref, + "bytevector-ieee-double-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the IEEE-754 double from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_ieee_double_ref +{ + IEEE754_REF (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_native_ref, + "bytevector-ieee-double-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the IEEE-754 double from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref +{ + IEEE754_NATIVE_REF (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_set_x, + "bytevector-ieee-double-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store real @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_ieee_double_set_x +{ + IEEE754_SET (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_native_set_x, + "bytevector-ieee-double-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the real @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x +{ + IEEE754_NATIVE_SET (double); +} +#undef FUNC_NAME + + +#undef IEEE754_UNION +#undef IEEE754_TO_SCM +#undef IEEE754_FROM_SCM +#undef IEEE754_FROM_FOREIGN_ENDIANNESS +#undef IEEE754_TO_FOREIGN_ENDIANNESS +#undef IEEE754_REF +#undef IEEE754_NATIVE_REF +#undef IEEE754_SET +#undef IEEE754_NATIVE_SET + + +/* Operations on strings. */ + + +/* Produce a function that returns the length of a UTF-encoded string. */ +#define UTF_STRLEN_FUNCTION(_utf_width) \ +static inline size_t \ +utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \ +{ \ + size_t len = 0; \ + const uint ## _utf_width ## _t *ptr; \ + for (ptr = str; \ + *ptr != 0; \ + ptr++) \ + { \ + len++; \ + } \ + \ + return (len * ((_utf_width) / 8)); \ +} + +UTF_STRLEN_FUNCTION (8) + + +/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */ +#define UTF_STRLEN(_utf_width, _str) \ + utf ## _utf_width ## _strlen (_str) + +/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and + ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the + encoding name). */ +static inline void +utf_encoding_name (char *name, size_t utf_width, SCM endianness) +{ + strcpy (name, "UTF-"); + strcat (name, ((utf_width == 8) + ? "8" + : ((utf_width == 16) + ? "16" + : ((utf_width == 32) + ? "32" + : "??")))); + strcat (name, + ((scm_is_eq (endianness, scm_sym_big)) + ? "BE" + : ((scm_is_eq (endianness, scm_sym_little)) + ? "LE" + : "unknown"))); +} + +/* Maximum length of a UTF encoding name. */ +#define MAX_UTF_ENCODING_NAME_LEN 16 + +/* Produce the body of a `string->utf' function. */ +#define STRING_TO_UTF(_utf_width) \ + SCM utf; \ + int err; \ + char *c_str; \ + char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \ + char *c_utf = NULL, *c_locale; \ + size_t c_strlen, c_raw_strlen, c_utf_len = 0; \ + \ + SCM_VALIDATE_STRING (1, str); \ + if (endianness == SCM_UNDEFINED) \ + endianness = scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_strlen = scm_c_string_length (str); \ + c_raw_strlen = c_strlen * ((_utf_width) / 8); \ + do \ + { \ + c_str = (char *) alloca (c_raw_strlen + 1); \ + c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \ + } \ + while (c_raw_strlen > c_strlen); \ + c_str[c_raw_strlen] = '\0'; \ + \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err = mem_iconveh (c_str, c_raw_strlen, \ + c_locale, c_utf_name, \ + iconveh_question_mark, NULL, \ + &c_utf, &c_utf_len); \ + if (SCM_UNLIKELY (err)) \ + scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \ + scm_list_1 (str), err); \ + else \ + /* C_UTF is null-terminated. */ \ + utf = scm_c_take_bytevector ((signed char *) c_utf, \ + c_utf_len); \ + \ + return (utf); + + + +SCM_DEFINE (scm_string_to_utf8, "string->utf8", + 1, 0, 0, + (SCM str), + "Return a newly allocated bytevector that contains the UTF-8 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf8 +{ + SCM utf; + char *c_str; + uint8_t *c_utf; + size_t c_strlen, c_raw_strlen; + + SCM_VALIDATE_STRING (1, str); + + c_strlen = scm_c_string_length (str); + c_raw_strlen = c_strlen; + do + { + c_str = (char *) alloca (c_raw_strlen + 1); + c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); + } + while (c_raw_strlen > c_strlen); + c_str[c_raw_strlen] = '\0'; + + c_utf = u8_strconv_from_locale (c_str); + if (SCM_UNLIKELY (c_utf == NULL)) + scm_syserror (FUNC_NAME); + else + /* C_UTF is null-terminated. */ + utf = scm_c_take_bytevector ((signed char *) c_utf, + UTF_STRLEN (8, c_utf)); + + return (utf); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_to_utf16, "string->utf16", + 1, 1, 0, + (SCM str, SCM endianness), + "Return a newly allocated bytevector that contains the UTF-16 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf16 +{ + STRING_TO_UTF (16); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_to_utf32, "string->utf32", + 1, 1, 0, + (SCM str, SCM endianness), + "Return a newly allocated bytevector that contains the UTF-32 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf32 +{ + STRING_TO_UTF (32); +} +#undef FUNC_NAME + + +/* Produce the body of a function that converts a UTF-encoded bytevector to a + string. */ +#define UTF_TO_STRING(_utf_width) \ + SCM str = SCM_BOOL_F; \ + int err; \ + char *c_str = NULL, *c_locale; \ + char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \ + const char *c_utf; \ + size_t c_strlen = 0, c_utf_len; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, utf); \ + if (endianness == SCM_UNDEFINED) \ + endianness = scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \ + c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err = mem_iconveh (c_utf, c_utf_len, \ + c_utf_name, c_locale, \ + iconveh_question_mark, NULL, \ + &c_str, &c_strlen); \ + if (SCM_UNLIKELY (err)) \ + scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \ + scm_list_1 (utf), err); \ + else \ + /* C_STR is null-terminated. */ \ + str = scm_take_locale_stringn (c_str, c_strlen); \ + \ + return (str); + + +SCM_DEFINE (scm_utf8_to_string, "utf8->string", + 1, 0, 0, + (SCM utf), + "Return a newly allocate string that contains from the UTF-8-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf8_to_string +{ + SCM str; + int err; + char *c_str = NULL, *c_locale; + const char *c_utf; + size_t c_utf_len, c_strlen = 0; + + SCM_VALIDATE_BYTEVECTOR (1, utf); + + c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); + + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); + strcpy (c_locale, locale_charset ()); + + c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); + err = mem_iconveh (c_utf, c_utf_len, + "UTF-8", c_locale, + iconveh_question_mark, NULL, + &c_str, &c_strlen); + if (SCM_UNLIKELY (err)) + scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", + scm_list_1 (utf), err); + else + /* C_STR is null-terminated. */ + str = scm_take_locale_stringn (c_str, c_strlen); + + return (str); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_utf16_to_string, "utf16->string", + 1, 1, 0, + (SCM utf, SCM endianness), + "Return a newly allocate string that contains from the UTF-16-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf16_to_string +{ + UTF_TO_STRING (16); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_utf32_to_string, "utf32->string", + 1, 1, 0, + (SCM utf, SCM endianness), + "Return a newly allocate string that contains from the UTF-32-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf32_to_string +{ + UTF_TO_STRING (32); +} +#undef FUNC_NAME + + + +/* Initialization. */ + +void +scm_init_bytevectors (void) +{ +#include "libguile/bytevectors.x" + +#ifdef WORDS_BIGENDIAN + native_endianness = scm_sym_big; +#else + native_endianness = scm_sym_little; +#endif + + scm_endianness_big = scm_sym_big; + scm_endianness_little = scm_sym_little; + + scm_null_bytevector = + scm_gc_protect_object (make_bytevector_from_buffer (0, NULL)); +} diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h new file mode 100644 index 000000000..98c38aca2 --- /dev/null +++ b/libguile/bytevectors.h @@ -0,0 +1,133 @@ +#ifndef SCM_BYTEVECTORS_H +#define SCM_BYTEVECTORS_H + +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + + + +#include "libguile/__scm.h" + + +/* R6RS bytevectors. */ + +#define SCM_BYTEVECTOR_LENGTH(_bv) \ + ((unsigned) SCM_SMOB_DATA (_bv)) +#define SCM_BYTEVECTOR_CONTENTS(_bv) \ + (SCM_BYTEVECTOR_INLINE_P (_bv) \ + ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \ + : (signed char *) SCM_SMOB_DATA_2 (_bv)) + + +SCM_API SCM scm_endianness_big; +SCM_API SCM scm_endianness_little; + +SCM_API SCM scm_make_bytevector (SCM, SCM); +SCM_API SCM scm_c_make_bytevector (unsigned); +SCM_API SCM scm_native_endianness (void); +SCM_API SCM scm_bytevector_p (SCM); +SCM_API SCM scm_bytevector_length (SCM); +SCM_API SCM scm_bytevector_eq_p (SCM, SCM); +SCM_API SCM scm_bytevector_fill_x (SCM, SCM); +SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_copy (SCM); + +SCM_API SCM scm_bytevector_to_u8_list (SCM); +SCM_API SCM scm_u8_list_to_bytevector (SCM); +SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM); +SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM); + +SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u8_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s8_ref (SCM, SCM); +SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_string_to_utf8 (SCM); +SCM_API SCM scm_string_to_utf16 (SCM, SCM); +SCM_API SCM scm_string_to_utf32 (SCM, SCM); +SCM_API SCM scm_utf8_to_string (SCM); +SCM_API SCM scm_utf16_to_string (SCM, SCM); +SCM_API SCM scm_utf32_to_string (SCM, SCM); + + + +/* Internal API. */ + +/* The threshold (in octets) under which bytevectors are stored "in-line", + i.e., without allocating memory beside the SMOB itself (a double cell). + This optimization is necessary since small bytevectors are expected to be + common. */ +#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM)) +#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \ + ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD) +#define SCM_BYTEVECTOR_INLINE_P(_bv) \ + (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv))) + +/* Hint that is passed to `scm_gc_malloc ()' and friends. */ +#define SCM_GC_BYTEVECTOR "bytevector" + +SCM_API void scm_init_bytevectors (void); + +SCM_INTERNAL scm_t_bits scm_tc16_bytevector; +SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, unsigned); + +#define scm_c_shrink_bytevector(_bv, _len) \ + (SCM_BYTEVECTOR_INLINE_P (_bv) \ + ? (_bv) \ + : scm_i_shrink_bytevector ((_bv), (_len))) + +SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, unsigned); +SCM_INTERNAL SCM scm_null_bytevector; + +#endif /* SCM_BYTEVECTORS_H */ diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h new file mode 100644 index 000000000..e345efaae --- /dev/null +++ b/libguile/ieee-754.h @@ -0,0 +1,90 @@ +/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + The GNU C Library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307 USA. */ + +#ifndef SCM_IEEE_754_H +#define SCM_IEEE_754_H 1 + +/* Based on glibc's and modified by Ludovic Courtès to include + all possible IEEE-754 double-precision representations. */ + + +/* IEEE 754 simple-precision format (32-bit). */ + +union scm_ieee754_float + { + float f; + + struct + { + unsigned int negative:1; + unsigned int exponent:8; + unsigned int mantissa:23; + } big_endian; + + struct + { + unsigned int mantissa:23; + unsigned int exponent:8; + unsigned int negative:1; + } little_endian; + }; + + + +/* IEEE 754 double-precision format (64-bit). */ + +union scm_ieee754_double + { + double d; + + struct + { + /* Big endian. */ + + unsigned int negative:1; + unsigned int exponent:11; + /* Together these comprise the mantissa. */ + unsigned int mantissa0:20; + unsigned int mantissa1:32; + } big_endian; + + struct + { + /* Both byte order and word order are little endian. */ + + /* Together these comprise the mantissa. */ + unsigned int mantissa1:32; + unsigned int mantissa0:20; + unsigned int exponent:11; + unsigned int negative:1; + } little_little_endian; + + struct + { + /* Byte order is little endian but word order is big endian. Not + sure this is very wide spread. */ + unsigned int mantissa0:20; + unsigned int exponent:11; + unsigned int negative:1; + unsigned int mantissa1:32; + } little_big_endian; + + }; + + +#endif /* SCM_IEEE_754_H */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c new file mode 100644 index 000000000..a07636fce --- /dev/null +++ b/libguile/r6rs-ports.c @@ -0,0 +1,1118 @@ +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#ifdef HAVE_UNISTD_H +# include +#endif + +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/bytevectors.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/r6rs-ports.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/values.h" +#include "libguile/vectors.h" + + + +/* Unimplemented features. */ + + +/* Transoders are currently not implemented since Guile 1.8 is not + Unicode-capable. Thus, most of the code here assumes the use of the + binary transcoder. */ +static inline void +transcoders_not_implemented (void) +{ + fprintf (stderr, "%s: warning: transcoders not implemented\n", + PACKAGE_NAME); +} + + +/* End-of-file object. */ + +SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, + (void), + "Return the end-of-file object.") +#define FUNC_NAME s_scm_eof_object +{ + return (SCM_EOF_VAL); +} +#undef FUNC_NAME + + +/* Input ports. */ + +#ifndef MIN +# define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + +/* Bytevector input ports or "bip" for short. */ +static scm_t_bits bytevector_input_port_type = 0; + +static inline SCM +make_bip (SCM bv) +{ + SCM port; + char *c_bv; + unsigned c_len; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + + port = scm_new_port_table_entry (bytevector_input_port_type); + + /* Prevent BV from being GC'd. */ + SCM_SETSTREAM (port, SCM_UNPACK (bv)); + + /* Have the port directly access the bytevector. */ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + c_port = SCM_PTAB_ENTRY (port); + c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; + c_port->read_end = (unsigned char *) c_bv + c_len; + c_port->read_buf_size = c_len; + + /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ + SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits); + + return port; +} + +static SCM +bip_mark (SCM port) +{ + /* Mark the underlying bytevector. */ + return (SCM_PACK (SCM_STREAM (port))); +} + +static int +bip_fill_input (SCM port) +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + if (c_port->read_pos >= c_port->read_end) + result = EOF; + else + result = (int) *c_port->read_pos; + + return result; +} + +static off_t +bip_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "bip_seek" +{ + off_t c_result = 0; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + switch (whence) + { + case SEEK_CUR: + offset += c_port->read_pos - c_port->read_buf; + /* Fall through. */ + + case SEEK_SET: + if (c_port->read_buf + offset < c_port->read_end) + { + c_port->read_pos = c_port->read_buf + offset; + c_result = offset; + } + else + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + break; + + case SEEK_END: + if (c_port->read_end - offset >= c_port->read_buf) + { + c_port->read_pos = c_port->read_end - offset; + c_result = c_port->read_pos - c_port->read_buf; + } + else + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + break; + + default: + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "invalid `seek' parameter"); + } + + return c_result; +} +#undef FUNC_NAME + + +/* Instantiate the bytevector input port type. */ +static inline void +initialize_bytevector_input_ports (void) +{ + bytevector_input_port_type = + scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input, + NULL); + + scm_set_port_mark (bytevector_input_port_type, bip_mark); + scm_set_port_seek (bytevector_input_port_type, bip_seek); +} + + +SCM_DEFINE (scm_open_bytevector_input_port, + "open-bytevector-input-port", 1, 1, 0, + (SCM bv, SCM transcoder), + "Return an input port whose contents are drawn from " + "bytevector @var{bv}.") +#define FUNC_NAME s_scm_open_bytevector_input_port +{ + SCM_VALIDATE_BYTEVECTOR (1, bv); + if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) + transcoders_not_implemented (); + + return (make_bip (bv)); +} +#undef FUNC_NAME + + +/* Custom binary ports. The following routines are shared by input and + output custom binary ports. */ + +#define SCM_CBP_GET_POSITION_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1) +#define SCM_CBP_SET_POSITION_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2) +#define SCM_CBP_CLOSE_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) + +static SCM +cbp_mark (SCM port) +{ + /* Mark the underlying method and object vector. */ + return (SCM_PACK (SCM_STREAM (port))); +} + +static off_t +cbp_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "cbp_seek" +{ + SCM result; + off_t c_result = 0; + + switch (whence) + { + case SEEK_CUR: + { + SCM get_position_proc; + + get_position_proc = SCM_CBP_GET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (get_position_proc))) + result = scm_call_0 (get_position_proc); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `port-position'"); + + offset += scm_to_int (result); + /* Fall through. */ + } + + case SEEK_SET: + { + SCM set_position_proc; + + set_position_proc = SCM_CBP_SET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (set_position_proc))) + result = scm_call_1 (set_position_proc, scm_from_int (offset)); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `set-port-position!'"); + + /* Assuming setting the position succeeded. */ + c_result = offset; + break; + } + + default: + /* `SEEK_END' cannot be supported. */ + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary ports do not " + "support `SEEK_END'"); + } + + return c_result; +} +#undef FUNC_NAME + +static int +cbp_close (SCM port) +{ + SCM close_proc; + + close_proc = SCM_CBP_CLOSE_PROC (port); + if (scm_is_true (close_proc)) + /* Invoke the `close' thunk. */ + scm_call_0 (close_proc); + + return 1; +} + + +/* Custom binary input port ("cbip" for short). */ + +static scm_t_bits custom_binary_input_port_type = 0; + +/* Size of the buffer embedded in custom binary input ports. */ +#define CBIP_BUFFER_SIZE 4096 + +/* Return the bytevector associated with PORT. */ +#define SCM_CBIP_BYTEVECTOR(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4) + +/* Return the various procedures of PORT. */ +#define SCM_CBIP_READ_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbip (SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + SCM port, bv, method_vector; + char *c_bv; + unsigned c_len; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + + /* Use a bytevector as the underlying buffer. */ + c_len = CBIP_BUFFER_SIZE; + bv = scm_c_make_bytevector (c_len); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + /* Store the various methods and bytevector in a vector. */ + method_vector = scm_c_make_vector (5, SCM_BOOL_F); + SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv); + SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + + port = scm_new_port_table_entry (custom_binary_input_port_type); + + /* Attach it the method vector. */ + SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); + + /* Have the port directly access the buffer (bytevector). */ + c_port = SCM_PTAB_ENTRY (port); + c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; + c_port->read_end = (unsigned char *) c_bv; + c_port->read_buf_size = c_len; + + /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ + SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits); + + return port; +} + +static int +cbip_fill_input (SCM port) +#define FUNC_NAME "cbip_fill_input" +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + again: + if (c_port->read_pos >= c_port->read_end) + { + /* Invoke the user's `read!' procedure. */ + unsigned c_octets; + SCM bv, read_proc, octets; + + /* Use the bytevector associated with PORT as the buffer passed to the + `read!' procedure, thereby avoiding additional allocations. */ + bv = SCM_CBIP_BYTEVECTOR (port); + read_proc = SCM_CBIP_READ_PROC (port); + + /* The assumption here is that C_PORT's internal buffer wasn't changed + behind our back. */ + assert (c_port->read_buf == + (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); + assert ((unsigned) c_port->read_buf_size + == SCM_BYTEVECTOR_LENGTH (bv)); + + octets = scm_call_3 (read_proc, bv, SCM_INUM0, + SCM_I_MAKINUM (CBIP_BUFFER_SIZE)); + c_octets = scm_to_uint (octets); + + c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_port->read_end = (unsigned char *) c_port->read_pos + c_octets; + + if (c_octets > 0) + goto again; + else + result = EOF; + } + else + result = (int) *c_port->read_pos; + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_input_port, + "make-custom-binary-input-port", 5, 0, 0, + (SCM id, SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary input port whose input is drained " + "by invoking @var{read_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_input_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, read_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + if (!scm_is_false (close_proc)) + SCM_VALIDATE_PROC (5, close_proc); + + return (make_cbip (read_proc, get_position_proc, set_position_proc, + close_proc)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary input port type. */ +static inline void +initialize_custom_binary_input_ports (void) +{ + custom_binary_input_port_type = + scm_make_port_type ("r6rs-custom-binary-input-port", + cbip_fill_input, NULL); + + scm_set_port_mark (custom_binary_input_port_type, cbp_mark); + scm_set_port_seek (custom_binary_input_port_type, cbp_seek); + scm_set_port_close (custom_binary_input_port_type, cbp_close); +} + + + +/* Binary input. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT + +SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0, + (SCM port), + "Read an octet from @var{port}, a binary input port, " + "blocking as necessary.") +#define FUNC_NAME s_scm_get_u8 +{ + SCM result; + int c_result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_result = scm_getc (port); + if (c_result == EOF) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM ((unsigned char) c_result); + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0, + (SCM port), + "Like @code{get-u8} but does not update @var{port} to " + "point past the octet.") +#define FUNC_NAME s_scm_lookahead_u8 +{ + SCM result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + result = scm_peek_char (port); + if (SCM_CHARP (result)) + result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result)); + else + result = SCM_EOF_VAL; + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, + (SCM port, SCM count), + "Read @var{count} octets from @var{port}, blocking as " + "necessary and return a bytevector containing the octets " + "read. If fewer bytes are available, a bytevector smaller " + "than @var{count} is returned.") +#define FUNC_NAME s_scm_get_bytevector_n +{ + SCM result; + char *c_bv; + unsigned c_count; + size_t c_read; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + c_count = scm_to_uint (count); + + result = scm_c_make_bytevector (c_count); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result); + + if (SCM_LIKELY (c_count > 0)) + /* XXX: `scm_c_read ()' does not update the port position. */ + c_read = scm_c_read (port, c_bv, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = scm_null_bytevector; + } + else + { + if (c_read < c_count) + result = scm_c_shrink_bytevector (result, c_read); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Read @var{count} bytes from @var{port} and store them " + "in @var{bv} starting at index @var{start}. Return either " + "the number of bytes actually read or the end-of-file " + "object.") +#define FUNC_NAME s_scm_get_bytevector_n_x +{ + SCM result; + char *c_bv; + unsigned c_start, c_count, c_len; + size_t c_read; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + c_start = scm_to_uint (start); + c_count = scm_to_uint (count); + + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + if (SCM_UNLIKELY (c_start + c_count > c_len)) + scm_out_of_range (FUNC_NAME, count); + + if (SCM_LIKELY (c_count > 0)) + c_read = scm_c_read (port, c_bv + c_start, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM (0); + } + else + result = scm_from_size_t (c_read); + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, + (SCM port), + "Read from @var{port}, blocking as necessary, until data " + "are available or and end-of-file is reached. Return either " + "a new bytevector containing the data read or the " + "end-of-file object.") +#define FUNC_NAME s_scm_get_bytevector_some +{ + /* Read at least one byte, unless the end-of-file is already reached, and + read while characters are available (buffered). */ + + SCM result; + char *c_bv; + unsigned c_len; + size_t c_total; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_len = 4096; + c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_total = 0; + + do + { + int c_chr; + + if (c_total + 1 > c_len) + { + /* Grow the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_len *= 2; + } + + /* We can't use `scm_c_read ()' since it blocks. */ + c_chr = scm_getc (port); + if (c_chr != EOF) + { + c_bv[c_total] = (char) c_chr; + c_total++; + } + } + while ((scm_is_true (scm_char_ready_p (port))) + && (!SCM_EOF_OBJECT_P (scm_peek_char (port)))); + + if (c_total == 0) + { + result = SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len = (unsigned) c_total; + } + + result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, + (SCM port), + "Read from @var{port}, blocking as necessary, until " + "the end-of-file is reached. Return either " + "a new bytevector containing the data read or the " + "end-of-file object (if no data were available).") +#define FUNC_NAME s_scm_get_bytevector_all +{ + SCM result; + char *c_bv; + unsigned c_len, c_count; + size_t c_read, c_total; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_len = c_count = 4096; + c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_total = c_read = 0; + + do + { + if (c_total + c_read > c_len) + { + /* Grow the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_count = c_len; + c_len *= 2; + } + + /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is + reached. */ + c_read = scm_c_read (port, c_bv + c_total, c_count); + c_total += c_read, c_count -= c_read; + } + while (!SCM_EOF_OBJECT_P (scm_peek_char (port))); + + if (c_total == 0) + { + result = SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len = (unsigned) c_total; + } + + result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + + + +/* Binary output. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT + + +SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0, + (SCM port, SCM octet), + "Write @var{octet} to binary port @var{port}.") +#define FUNC_NAME s_scm_put_u8 +{ + scm_t_uint8 c_octet; + + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + c_octet = scm_to_uint8 (octet); + + scm_putc ((char) c_octet, port); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Write the contents of @var{bv} to @var{port}, optionally " + "starting at index @var{start} and limiting to @var{count} " + "octets.") +#define FUNC_NAME s_scm_put_bytevector +{ + char *c_bv; + unsigned c_start, c_count, c_len; + + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + if (start != SCM_UNDEFINED) + { + c_start = scm_to_uint (start); + + if (count != SCM_UNDEFINED) + { + c_count = scm_to_uint (count); + if (SCM_UNLIKELY (c_start + c_count > c_len)) + scm_out_of_range (FUNC_NAME, count); + } + else + { + if (SCM_UNLIKELY (c_start >= c_len)) + scm_out_of_range (FUNC_NAME, start); + else + c_count = c_len - c_start; + } + } + else + c_start = 0, c_count = c_len; + + scm_c_write (port, c_bv + c_start, c_count); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* Bytevector output port ("bop" for short). */ + +/* Implementation of "bops". + + Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to + it. The procedure returned along with the output port is actually an + applicable SMOB. The SMOB holds a reference to the port. When applied, + the SMOB swallows the port's internal buffer, turning it into a + bytevector, and resets it. + + XXX: Access to a bop's internal buffer is not thread-safe. */ + +static scm_t_bits bytevector_output_port_type = 0; + +SCM_SMOB (bytevector_output_port_procedure, + "r6rs-bytevector-output-port-procedure", + 0); + +#define SCM_GC_BOP "r6rs-bytevector-output-port" +#define SCM_BOP_BUFFER_INITIAL_SIZE 4096 + +/* Representation of a bop's internal buffer. */ +typedef struct +{ + size_t total_len; + size_t len; + size_t pos; + char *buffer; +} scm_t_bop_buffer; + + +/* Accessing a bop's buffer. */ +#define SCM_BOP_BUFFER(_port) \ + ((scm_t_bop_buffer *) SCM_STREAM (_port)) +#define SCM_SET_BOP_BUFFER(_port, _buf) \ + (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf))) + + +static inline void +bop_buffer_init (scm_t_bop_buffer *buf) +{ + buf->total_len = buf->len = buf->pos = 0; + buf->buffer = NULL; +} + +static inline void +bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size) +{ + char *new_buf; + size_t new_size; + + for (new_size = buf->total_len + ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE; + new_size < min_size; + new_size *= 2); + + if (buf->buffer) + new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, + new_size, SCM_GC_BOP); + else + new_buf = scm_gc_malloc (new_size, SCM_GC_BOP); + + buf->buffer = new_buf; + buf->total_len = new_size; +} + +static inline SCM +make_bop (void) +{ + SCM port, bop_proc; + scm_t_port *c_port; + scm_t_bop_buffer *buf; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + + port = scm_new_port_table_entry (bytevector_output_port_type); + + buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP); + bop_buffer_init (buf); + + c_port = SCM_PTAB_ENTRY (port); + c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; + c_port->write_buf_size = 0; + + SCM_SET_BOP_BUFFER (port, buf); + + /* Mark PORT as open and writable. */ + SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits); + + /* Make the bop procedure. */ + SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, + SCM_PACK (port)); + + return (scm_values (scm_list_2 (port, bop_proc))); +} + +static size_t +bop_free (SCM port) +{ + /* The port itself is necessarily freed _after_ the bop proc, since the bop + proc holds a reference to it. Thus we can safely free the internal + buffer when the bop becomes unreferenced. */ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + if (buf->buffer) + scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP); + + scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP); + + return 0; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +bop_write (SCM port, const void *data, size_t size) +{ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + + if (buf->pos + size > buf->total_len) + bop_buffer_grow (buf, buf->pos + size); + + memcpy (buf->buffer + buf->pos, data, size); + buf->pos += size; + buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; +} + +static off_t +bop_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "bop_seek" +{ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + switch (whence) + { + case SEEK_CUR: + offset += (off_t) buf->pos; + /* Fall through. */ + + case SEEK_SET: + if (offset < 0 || (unsigned) offset > buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = offset; + break; + + case SEEK_END: + if (offset < 0 || (unsigned) offset >= buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = buf->len - (offset + 1); + break; + + default: + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "invalid `seek' parameter"); + } + + return buf->pos; +} +#undef FUNC_NAME + +/* Fetch data from a bop. */ +SCM_SMOB_APPLY (bytevector_output_port_procedure, + bop_proc_apply, 0, 0, 0, (SCM bop_proc)) +{ + SCM port, bv; + scm_t_bop_buffer *buf, result_buf; + + port = SCM_PACK (SCM_SMOB_DATA (bop_proc)); + buf = SCM_BOP_BUFFER (port); + + result_buf = *buf; + bop_buffer_init (buf); + + if (result_buf.len == 0) + bv = scm_c_take_bytevector (NULL, 0); + else + { + if (result_buf.total_len > result_buf.len) + /* Shrink the buffer. */ + result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer, + result_buf.total_len, + result_buf.len, + SCM_GC_BOP); + + bv = scm_c_take_bytevector ((signed char *) result_buf.buffer, + result_buf.len); + } + + return bv; +} + +SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark, + bop_proc) +{ + /* Mark the port associated with BOP_PROC. */ + return (SCM_PACK (SCM_SMOB_DATA (bop_proc))); +} + + +SCM_DEFINE (scm_open_bytevector_output_port, + "open-bytevector-output-port", 0, 1, 0, + (SCM transcoder), + "Return two values: an output port and a procedure. The latter " + "should be called with zero arguments to obtain a bytevector " + "containing the data accumulated by the port.") +#define FUNC_NAME s_scm_open_bytevector_output_port +{ + if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) + transcoders_not_implemented (); + + return (make_bop ()); +} +#undef FUNC_NAME + +static inline void +initialize_bytevector_output_ports (void) +{ + bytevector_output_port_type = + scm_make_port_type ("r6rs-bytevector-output-port", + NULL, bop_write); + + scm_set_port_seek (bytevector_output_port_type, bop_seek); + scm_set_port_free (bytevector_output_port_type, bop_free); +} + + +/* Custom binary output port ("cbop" for short). */ + +static scm_t_bits custom_binary_output_port_type; + +/* Return the various procedures of PORT. */ +#define SCM_CBOP_WRITE_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbop (SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + SCM port, method_vector; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + + /* Store the various methods and bytevector in a vector. */ + method_vector = scm_c_make_vector (4, SCM_BOOL_F); + SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + + port = scm_new_port_table_entry (custom_binary_output_port_type); + + /* Attach it the method vector. */ + SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); + + /* Have the port directly access the buffer (bytevector). */ + c_port = SCM_PTAB_ENTRY (port); + c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; + c_port->write_buf_size = c_port->read_buf_size = 0; + + /* Mark PORT as open, writable and unbuffered. */ + SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits); + + return port; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +cbop_write (SCM port, const void *data, size_t size) +#define FUNC_NAME "cbop_write" +{ + long int c_result; + size_t c_written; + SCM bv, write_proc, result; + + /* XXX: Allocating a new bytevector at each `write' call is inefficient, + but necessary since (1) we don't control the lifetime of the buffer + pointed to by DATA, and (2) the `write!' procedure could capture the + bytevector it is passed. */ + bv = scm_c_make_bytevector (size); + memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); + + write_proc = SCM_CBOP_WRITE_PROC (port); + + /* Since the `write' procedure of Guile's ports has type `void', it must + try hard to write exactly SIZE bytes, regardless of how many bytes the + sink can handle. */ + for (c_written = 0; + c_written < size; + c_written += c_result) + { + result = scm_call_3 (write_proc, bv, + scm_from_size_t (c_written), + scm_from_size_t (size - c_written)); + + c_result = scm_to_long (result); + if (SCM_UNLIKELY (c_result < 0 + || (size_t) c_result > (size - c_written))) + scm_wrong_type_arg_msg (FUNC_NAME, 0, result, + "R6RS custom binary output port `write!' " + "returned a incorrect integer"); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_output_port, + "make-custom-binary-output-port", 5, 0, 0, + (SCM id, SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary output port whose output is drained " + "by invoking @var{write_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_output_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, write_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + if (!scm_is_false (close_proc)) + SCM_VALIDATE_PROC (5, close_proc); + + return (make_cbop (write_proc, get_position_proc, set_position_proc, + close_proc)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary output port type. */ +static inline void +initialize_custom_binary_output_ports (void) +{ + custom_binary_output_port_type = + scm_make_port_type ("r6rs-custom-binary-output-port", + NULL, cbop_write); + + scm_set_port_mark (custom_binary_output_port_type, cbp_mark); + scm_set_port_seek (custom_binary_output_port_type, cbp_seek); + scm_set_port_close (custom_binary_output_port_type, cbp_close); +} + + +/* Initialization. */ + +void +scm_init_r6rs_ports (void) +{ +#include "r6rs-ports.x" + + initialize_bytevector_input_ports (); + initialize_custom_binary_input_ports (); + initialize_bytevector_output_ports (); + initialize_custom_binary_output_ports (); +} diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h new file mode 100644 index 000000000..e29d96200 --- /dev/null +++ b/libguile/r6rs-ports.h @@ -0,0 +1,43 @@ +#ifndef SCM_R6RS_PORTS_H +#define SCM_R6RS_PORTS_H + +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + + + +#include "libguile/__scm.h" + +/* R6RS I/O Ports. */ + +SCM_API SCM scm_eof_object (void); +SCM_API SCM scm_open_bytevector_input_port (SCM, SCM); +SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_u8 (SCM); +SCM_API SCM scm_lookahead_u8 (SCM); +SCM_API SCM scm_get_bytevector_n (SCM, SCM); +SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_bytevector_some (SCM); +SCM_API SCM scm_get_bytevector_all (SCM); +SCM_API SCM scm_put_u8 (SCM, SCM); +SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); +SCM_API SCM scm_open_bytevector_output_port (SCM); +SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); + +SCM_API void scm_init_r6rs_ports (void); + +#endif /* SCM_R6RS_PORTS_H */ diff --git a/libguile/validate.h b/libguile/validate.h index e05b7dd83..c362c02f3 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -3,7 +3,7 @@ #ifndef SCM_VALIDATE_H #define SCM_VALIDATE_H -/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -150,6 +150,9 @@ cvar = scm_to_bool (flag); \ } while (0) +#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \ + SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector) + #define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character") #define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \ diff --git a/module/Makefile.am b/module/Makefile.am index 95dc75ac2..d149bb64a 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -31,7 +31,7 @@ modpath = # putting these core modules first. SOURCES = \ - ice-9/psyntax-pp.scm \ + ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ \ @@ -53,6 +53,7 @@ SOURCES = \ \ $(ICE_9_SOURCES) \ $(SRFI_SOURCES) \ + $(RNRS_SOURCES) \ $(OOP_SOURCES) \ \ $(SCRIPTS_SOURCES) @@ -209,6 +210,10 @@ SRFI_SOURCES = \ srfi/srfi-69.scm \ srfi/srfi-88.scm +RNRS_SOURCES = \ + rnrs/bytevector.scm \ + rnrs/io/ports.scm + EXTRA_DIST += scripts/ChangeLog-2008 EXTRA_DIST += scripts/README diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm new file mode 100644 index 000000000..793cbc020 --- /dev/null +++ b/module/rnrs/bytevector.scm @@ -0,0 +1,84 @@ +;;;; bytevector.scm --- R6RS bytevector API + +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès + +;;; Commentary: +;;; +;;; A "bytevector" is a raw bit string. This module provides procedures to +;;; manipulate bytevectors and interpret their contents in a number of ways: +;;; bytevector contents can be accessed as signed or unsigned integer of +;;; various sizes and endianness, as IEEE-754 floating point numbers, or as +;;; strings. It is a useful tool to decode binary data. +;;; +;;; Code: + +(define-module (rnrs bytevector) + :export-syntax (endianness) + :export (native-endianness bytevector? + make-bytevector bytevector-length bytevector=? bytevector-fill! + bytevector-copy! bytevector-copy bytevector-u8-ref + bytevector-s8-ref + bytevector-u8-set! bytevector-s8-set! bytevector->u8-list + u8-list->bytevector + bytevector-uint-ref bytevector-uint-set! + bytevector-sint-ref bytevector-sint-set! + bytevector->sint-list bytevector->uint-list + uint-list->bytevector sint-list->bytevector + + bytevector-u16-ref bytevector-s16-ref + bytevector-u16-set! bytevector-s16-set! + bytevector-u16-native-ref bytevector-s16-native-ref + bytevector-u16-native-set! bytevector-s16-native-set! + + bytevector-u32-ref bytevector-s32-ref + bytevector-u32-set! bytevector-s32-set! + bytevector-u32-native-ref bytevector-s32-native-ref + bytevector-u32-native-set! bytevector-s32-native-set! + + bytevector-u64-ref bytevector-s64-ref + bytevector-u64-set! bytevector-s64-set! + bytevector-u64-native-ref bytevector-s64-native-ref + bytevector-u64-native-set! bytevector-s64-native-set! + + bytevector-ieee-single-ref + bytevector-ieee-single-set! + bytevector-ieee-single-native-ref + bytevector-ieee-single-native-set! + + bytevector-ieee-double-ref + bytevector-ieee-double-set! + bytevector-ieee-double-native-ref + bytevector-ieee-double-native-set! + + string->utf8 string->utf16 string->utf32 + utf8->string utf16->string utf32->string)) + + +(load-extension "libguile" "scm_init_bytevectors") + +(define-macro (endianness sym) + (if (memq sym '(big little)) + `(quote ,sym) + (error "unsupported endianness" sym))) + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; bytevector.scm ends here diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm new file mode 100644 index 000000000..73843ee55 --- /dev/null +++ b/module/rnrs/io/ports.scm @@ -0,0 +1,111 @@ +;;;; ports.scm --- R6RS port API + +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès + +;;; Commentary: +;;; +;;; The I/O port API of the R6RS is provided by this module. In many areas +;;; it complements or refines Guile's own historical port API. For instance, +;;; it allows for binary I/O with bytevectors. +;;; +;;; Code: + +(define-module (rnrs io ports) + :re-export (eof-object? port? input-port? output-port?) + :export (eof-object + + ;; input & output ports + port-transcoder binary-port? transcoded-port + port-position set-port-position! + port-has-port-position? port-has-set-port-position!? + call-with-port + + ;; input ports + open-bytevector-input-port + make-custom-binary-input-port + + ;; binary input + get-u8 lookahead-u8 + get-bytevector-n get-bytevector-n! + get-bytevector-some get-bytevector-all + + ;; output ports + open-bytevector-output-port + make-custom-binary-output-port + + ;; binary output + put-u8 put-bytevector)) + +(load-extension "libguile" "scm_init_r6rs_ports") + + + +;;; +;;; Input and output ports. +;;; + +(define (port-transcoder port) + (error "port transcoders are not supported" port)) + +(define (binary-port? port) + ;; So far, we don't support transcoders other than the binary transcoder. + #t) + +(define (transcoded-port port) + (error "port transcoders are not supported" port)) + +(define (port-position port) + "Return the offset (an integer) indicating where the next octet will be +read from/written to in @var{port}." + + ;; FIXME: We should raise an `&assertion' error when not supported. + (seek port 0 SEEK_CUR)) + +(define (set-port-position! port offset) + "Set the position where the next octet will be read from/written to +@var{port}." + + ;; FIXME: We should raise an `&assertion' error when not supported. + (seek port offset SEEK_SET)) + +(define (port-has-port-position? port) + "Return @code{#t} is @var{port} supports @code{port-position}." + (and (false-if-exception (port-position port)) #t)) + +(define (port-has-set-port-position!? port) + "Return @code{#t} is @var{port} supports @code{set-port-position!}." + (and (false-if-exception (set-port-position! port (port-position port))) + #t)) + +(define (call-with-port port proc) + "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of +@var{proc}. Return the return values of @var{proc}." + (dynamic-wind + (lambda () + #t) + (lambda () + (proc port)) + (lambda () + (close-port port)))) + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; ports.scm ends here diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3854d4ab1..0b986d4a2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \ tests/arbiters.test \ tests/asm-to-bytecode.test \ tests/bit-operations.test \ + tests/bytevectors.test \ tests/c-api.test \ tests/chars.test \ tests/common-list.test \ @@ -62,6 +63,7 @@ SCM_TESTS = tests/alist.test \ tests/q.test \ tests/r4rs.test \ tests/r5rs_pitfall.test \ + tests/r6rs-ports.test \ tests/ramap.test \ tests/reader.test \ tests/receive.test \ diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test new file mode 100644 index 000000000..b2ae65c1f --- /dev/null +++ b/test-suite/tests/bytevectors.test @@ -0,0 +1,531 @@ +;;;; bytevectors.test --- Exercise the R6RS bytevector API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-bytevector) + :use-module (test-suite lib) + :use-module (rnrs bytevector)) + +;;; Some of the tests in here are examples taken from the R6RS Standard +;;; Libraries document. + + +(with-test-prefix "2.2 General Operations" + + (pass-if "native-endianness" + (not (not (memq (native-endianness) '(big little))))) + + (pass-if "make-bytevector" + (and (bytevector? (make-bytevector 20)) + (bytevector? (make-bytevector 20 3)))) + + (pass-if "bytevector-length" + (= (bytevector-length (make-bytevector 20)) 20)) + + (pass-if "bytevector=?" + (and (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 7)) + (not (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 0)))))) + + +(with-test-prefix "2.3 Operations on Bytes and Octets" + + (pass-if "bytevector-{u8,s8}-ref" + (equal? '(-127 129 -1 255) + (let ((b1 (make-bytevector 16 -127)) + (b2 (make-bytevector 16 255))) + (list (bytevector-s8-ref b1 0) + (bytevector-u8-ref b1 0) + (bytevector-s8-ref b2 0) + (bytevector-u8-ref b2 0))))) + + (pass-if "bytevector-{u8,s8}-set!" + (equal? '(-126 130 -10 246) + (let ((b (make-bytevector 16 -127))) + + (bytevector-s8-set! b 0 -126) + (bytevector-u8-set! b 1 246) + + (list (bytevector-s8-ref b 0) + (bytevector-u8-ref b 0) + (bytevector-s8-ref b 1) + (bytevector-u8-ref b 1))))) + + (pass-if "bytevector->u8-list" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list + (let ((b (make-bytevector 6))) + (for-each (lambda (i v) + (bytevector-u8-set! b i v)) + (iota 6) + lst) + b))))) + + (pass-if "u8-list->bytevector" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list (u8-list->bytevector lst))))) + + (pass-if "bytevector-uint-{ref,set!} [small]" + (let ((b (make-bytevector 15))) + (bytevector-uint-set! b 0 #x1234 + (endianness little) 2) + (equal? (bytevector-uint-ref b 0 (endianness big) 2) + #x3412))) + + (pass-if "bytevector-uint-set! [large]" + (let ((b (make-bytevector 16))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector->u8-list b) + '(253 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 255)))) + + (pass-if "bytevector-uint-{ref,set!} [large]" + (let ((b (make-bytevector 120))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-uint-ref b 0 (endianness little) 16) + #xfffffffffffffffffffffffffffffffd))) + + (pass-if "bytevector-sint-ref [small]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-sint-ref b 0 (endianness big) 2) + (bytevector-sint-ref b 1 (endianness little) 2) + -16))) + + (pass-if "bytevector-sint-ref [large]" + (let ((b (make-bytevector 50))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-sint-ref b 0 (endianness little) 16) + -3))) + + (pass-if "bytevector-sint-set! [small]" + (let ((b (make-bytevector 3))) + (bytevector-sint-set! b 0 -16 (endianness big) 2) + (bytevector-sint-set! b 1 -16 (endianness little) 2) + (equal? (bytevector->u8-list b) + '(#xff #xf0 #xff))))) + + +(with-test-prefix "2.4 Operations on Integers of Arbitrary Size" + + (pass-if "bytevector->sint-list" + (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (equal? (bytevector->sint-list b (endianness little) 2) + '(513 -253 513 513)))) + + (pass-if "bytevector->uint-list" + (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1)))) + (equal? (bytevector->uint-list b (endianness big) 2) + '(513 65283 513 513)))) + + (pass-if "bytevector->uint-list [empty]" + (let ((b (make-bytevector 0))) + (null? (bytevector->uint-list b (endianness big) 2)))) + + (pass-if-exception "bytevector->sint-list [out-of-range]" + exception:out-of-range + (bytevector->sint-list (make-bytevector 6) (endianness little) 8)) + + (pass-if "bytevector->sint-list [off-by-one]" + (equal? (bytevector->sint-list (make-bytevector 31 #xff) + (endianness little) 8) + '(-1 -1 -1))) + + (pass-if "{sint,uint}-list->bytevector" + (let ((b1 (sint-list->bytevector '(513 -253 513 513) + (endianness little) 2)) + (b2 (uint-list->bytevector '(513 65283 513 513) + (endianness little) 2)) + (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (and (bytevector=? b1 b2) + (bytevector=? b2 b3)))) + + (pass-if "sint-list->bytevector [limits]" + (bytevector=? (sint-list->bytevector '(-32768 32767) + (endianness big) 2) + (let ((bv (make-bytevector 4))) + (bytevector-u8-set! bv 0 #x80) + (bytevector-u8-set! bv 1 #x00) + (bytevector-u8-set! bv 2 #x7f) + (bytevector-u8-set! bv 3 #xff) + bv))) + + (pass-if-exception "sint-list->bytevector [out-of-range]" + exception:out-of-range + (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big) + 2)) + + (pass-if-exception "uint-list->bytevector [out-of-range]" + exception:out-of-range + (uint-list->bytevector '(0 -1) (endianness big) 2))) + + +(with-test-prefix "2.5 Operations on 16-Bit Integers" + + (pass-if "bytevector-u16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u16-ref b 14 (endianness little)) + #xfdff) + (equal? (bytevector-u16-ref b 14 (endianness big)) + #xfffd)))) + + (pass-if "bytevector-s16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s16-ref b 14 (endianness little)) + -513) + (equal? (bytevector-s16-ref b 14 (endianness big)) + -3)))) + + (pass-if "bytevector-s16-ref [unaligned]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -16))) + + (pass-if "bytevector-{u16,s16}-ref" + (let ((b (make-bytevector 2))) + (bytevector-u16-set! b 0 44444 (endianness little)) + (and (equal? (bytevector-u16-ref b 0 (endianness little)) + 44444) + (equal? (bytevector-s16-ref b 0 (endianness little)) + (- 44444 65536))))) + + (pass-if "bytevector-native-{u16,s16}-{ref,set!}" + (let ((b (make-bytevector 2))) + (bytevector-u16-native-set! b 0 44444) + (and (equal? (bytevector-u16-native-ref b 0) + 44444) + (equal? (bytevector-s16-native-ref b 0) + (- 44444 65536))))) + + (pass-if "bytevector-s16-{ref,set!} [unaligned]" + (let ((b (make-bytevector 3))) + (bytevector-s16-set! b 1 -77 (endianness little)) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -77)))) + + +(with-test-prefix "2.6 Operations on 32-bit Integers" + + (pass-if "bytevector-u32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u32-ref b 12 (endianness little)) + #xfdffffff) + (equal? (bytevector-u32-ref b 12 (endianness big)) + #xfffffffd)))) + + (pass-if "bytevector-s32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s32-ref b 12 (endianness little)) + -33554433) + (equal? (bytevector-s32-ref b 12 (endianness big)) + -3)))) + + (pass-if "bytevector-{u32,s32}-ref" + (let ((b (make-bytevector 4))) + (bytevector-u32-set! b 0 2222222222 (endianness little)) + (and (equal? (bytevector-u32-ref b 0 (endianness little)) + 2222222222) + (equal? (bytevector-s32-ref b 0 (endianness little)) + (- 2222222222 (expt 2 32)))))) + + (pass-if "bytevector-{u32,s32}-native-{ref,set!}" + (let ((b (make-bytevector 4))) + (bytevector-u32-native-set! b 0 2222222222) + (and (equal? (bytevector-u32-native-ref b 0) + 2222222222) + (equal? (bytevector-s32-native-ref b 0) + (- 2222222222 (expt 2 32))))))) + + +(with-test-prefix "2.7 Operations on 64-bit Integers" + + (pass-if "bytevector-u64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u64-ref b 8 (endianness little)) + #xfdffffffffffffff) + (equal? (bytevector-u64-ref b 8 (endianness big)) + #xfffffffffffffffd)))) + + (pass-if "bytevector-s64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s64-ref b 8 (endianness little)) + -144115188075855873) + (equal? (bytevector-s64-ref b 8 (endianness big)) + -3)))) + + (pass-if "bytevector-{u64,s64}-ref" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-set! b 0 big (endianness little)) + (and (equal? (bytevector-u64-ref b 0 (endianness little)) + big) + (equal? (bytevector-s64-ref b 0 (endianness little)) + (- big (expt 2 64)))))) + + (pass-if "bytevector-{u64,s64}-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-native-set! b 0 big) + (and (equal? (bytevector-u64-native-ref b 0) + big) + (equal? (bytevector-s64-native-ref b 0) + (- big (expt 2 64)))))) + + (pass-if "ref/set! with zero" + (let ((b (make-bytevector 8))) + (bytevector-s64-set! b 0 -1 (endianness big)) + (bytevector-u64-set! b 0 0 (endianness big)) + (= 0 (bytevector-u64-ref b 0 (endianness big)))))) + + +(with-test-prefix "2.8 Operations on IEEE-754 Representations" + + (pass-if "bytevector-ieee-single-native-{ref,set!}" + (let ((b (make-bytevector 4)) + (number 3.00)) + (bytevector-ieee-single-native-set! b 0 number) + (equal? (bytevector-ieee-single-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-single-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-single-set! b 0 number (endianness little)) + (bytevector-ieee-single-set! b 4 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 0 (endianness little)) + (bytevector-ieee-single-ref b 4 (endianness big))))) + + (pass-if "bytevector-ieee-single-{ref,set!} [unaligned]" + (let ((b (make-bytevector 9)) + (number 3.14)) + (bytevector-ieee-single-set! b 1 number (endianness little)) + (bytevector-ieee-single-set! b 5 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 1 (endianness little)) + (bytevector-ieee-single-ref b 5 (endianness big))))) + + (pass-if "bytevector-ieee-double-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-double-native-set! b 0 number) + (equal? (bytevector-ieee-double-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-double-{ref,set!}" + (let ((b (make-bytevector 16)) + (number 3.14)) + (bytevector-ieee-double-set! b 0 number (endianness little)) + (bytevector-ieee-double-set! b 8 number (endianness big)) + (equal? (bytevector-ieee-double-ref b 0 (endianness little)) + (bytevector-ieee-double-ref b 8 (endianness big)))))) + + +(define (with-locale locale thunk) + ;; Run THUNK under LOCALE. + (let ((original-locale (setlocale LC_ALL))) + (catch 'system-error + (lambda () + (setlocale LC_ALL locale)) + (lambda (key . args) + (throw 'unresolved))) + + (dynamic-wind + (lambda () + #t) + thunk + (lambda () + (setlocale LC_ALL original-locale))))) + +(define (with-latin1-locale thunk) + ;; Try out several ISO-8859-1 locales and run THUNK under the one that + ;; works (if any). + (define %locales + (map (lambda (name) + (string-append name ".ISO-8859-1")) + '("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))) + + (let loop ((locales %locales)) + (if (null? locales) + (throw 'unresolved) + (catch 'unresolved + (lambda () + (with-locale (car locales) thunk)) + (lambda (key . args) + (loop (cdr locales))))))) + + +;; Default to the C locale for the following tests. +(setlocale LC_ALL "C") + + +(with-test-prefix "2.9 Operations on Strings" + + (pass-if "string->utf8" + (let* ((str "hello, world") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (string-length str)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "string->utf8 [latin-1]" + (with-latin1-locale + (lambda () + (let* ((str "hé, ça va bien ?") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (+ 2 (string-length str)))))))) + + (pass-if "string->utf16" + (let* ((str "hello, world") + (utf16 (string->utf16 str))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness big) 2)))))) + + (pass-if "string->utf16 [little]" + (let* ((str "hello, world") + (utf16 (string->utf16 str (endianness little)))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness little) 2)))))) + + + (pass-if "string->utf32" + (let* ((str "hello, world") + (utf32 (string->utf32 str))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness big) 4)))))) + + (pass-if "string->utf32 [little]" + (let* ((str "hello, world") + (utf32 (string->utf32 str (endianness little)))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness little) 4)))))) + + (pass-if "utf8->string" + (let* ((utf8 (u8-list->bytevector (map char->integer + (string->list "hello, world")))) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (bytevector-length utf8)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "utf8->string [latin-1]" + (with-latin1-locale + (lambda () + (let* ((utf8 (string->utf8 "hé, ça va bien ?")) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (- (bytevector-length utf8) 2))))))) + + (pass-if "utf16->string" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 2)) + (str (utf16->string utf16))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness big) + 2)))))) + + (pass-if "utf16->string [little]" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 2)) + (str (utf16->string utf16 (endianness little)))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness little) + 2)))))) + (pass-if "utf32->string" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 4)) + (str (utf32->string utf32))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness big) + 4)))))) + + (pass-if "utf32->string [little]" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 4)) + (str (utf32->string utf32 (endianness little)))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness little) + 4))))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test new file mode 100644 index 000000000..204f37144 --- /dev/null +++ b/test-suite/tests/r6rs-ports.test @@ -0,0 +1,455 @@ +;;;; r6rs-ports.test --- Exercise the R6RS I/O port API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-io-ports) + :use-module (test-suite lib) + :use-module (srfi srfi-1) + :use-module (srfi srfi-11) + :use-module (rnrs io ports) + :use-module (rnrs bytevector)) + +;;; All these tests assume Guile 1.8's port system, where characters are +;;; treated as octets. + + +(with-test-prefix "7.2.5 End-of-File Object" + + (pass-if "eof-object" + (and (eqv? (eof-object) (eof-object)) + (eq? (eof-object) (eof-object))))) + + +(with-test-prefix "7.2.8 Binary Input" + + (pass-if "get-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "lookahead-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (lookahead-u8 port)) + (not (eof-object? port)) + (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "get-bytevector-n [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 4))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n [long]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 256))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU Guile")))))) + + (pass-if-exception "get-bytevector-n with closed port" + exception:wrong-type-arg + + (let ((port (%make-void-port "r"))) + + (close-port port) + (get-bytevector-n port 3))) + + (pass-if "get-bytevector-n! [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (make-bytevector 4)) + (read (get-bytevector-n! port bv 0 4))) + (and (equal? read 4) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n! [long]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (make-bytevector 256)) + (read (get-bytevector-n! port bv 0 256))) + (and (equal? read (string-length str)) + (equal? (map (lambda (i) + (bytevector-u8-ref bv i)) + (iota read)) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [simple]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [only-some]" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read. + (- 4 (modulo index 5)))) + "r")) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (= index 4) + (= (bytevector-length bv) index) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-all" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (let ((cont? #f)) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read and then + ;; starts again. + (let ((a (if cont? + (- (string-length str) index) + (- 4 (modulo index 5))))) + (if (= 0 a) (set! cont? #t)) + a)))) + "r")) + (bv (get-bytevector-all port))) + (and (bytevector? bv) + (= index (string-length str)) + (= (bytevector-length bv) (string-length str)) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str))))))) + + +(define (make-soft-output-port) + (let* ((bv (make-bytevector 1024)) + (read-index 0) + (write-index 0) + (write-char (lambda (chr) + (bytevector-u8-set! bv write-index + (char->integer chr)) + (set! write-index (+ 1 write-index))))) + (make-soft-port + (vector write-char + (lambda (str) ;; write-string + (for-each write-char (string->list str))) + (lambda () #t) ;; flush-output + (lambda () ;; read-char + (if (>= read-index (bytevector-length bv)) + (eof-object) + (let ((c (bytevector-u8-ref bv read-index))) + (set! read-index (+ read-index 1)) + (integer->char c)))) + (lambda () #t)) ;; close-port + "rw"))) + +(with-test-prefix "7.2.11 Binary Output" + + (pass-if "put-u8" + (let ((port (make-soft-output-port))) + (put-u8 port 77) + (equal? (get-u8 port) 77))) + + (pass-if "put-bytevector [2 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256))) + (put-bytevector port bv) + (equal? (bytevector->u8-list bv) + (bytevector->u8-list + (get-bytevector-n port (bytevector-length bv)))))) + + (pass-if "put-bytevector [3 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10)) + (put-bytevector port bv start) + (equal? (drop (bytevector->u8-list bv) start) + (bytevector->u8-list + (get-bytevector-n port (- (bytevector-length bv) start)))))) + + (pass-if "put-bytevector [4 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10) + (count 77)) + (put-bytevector port bv start count) + (equal? (take (drop (bytevector->u8-list bv) start) count) + (bytevector->u8-list + (get-bytevector-n port count))))) + + (pass-if-exception "put-bytevector with closed port" + exception:wrong-type-arg + + (let* ((bv (make-bytevector 4)) + (port (%make-void-port "w"))) + + (close-port port) + (put-bytevector port bv)))) + + +(with-test-prefix "7.2.7 Input Ports" + + ;; This section appears here so that it can use the binary input + ;; primitives. + + (pass-if "open-bytevector-input-port [1 arg]" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv)) + (read-to-string + (lambda (port) + (let loop ((chr (read-char port)) + (result '())) + (if (eof-object? chr) + (apply string (reverse! result)) + (loop (read-char port) + (cons chr result))))))) + + (equal? (read-to-string port) str))) + + (pass-if-exception "bytevector-input-port is read-only" + exception:wrong-type-arg + + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #f))) + + (write "hello" port))) + + (pass-if "bytevector input port supports seeking" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if-exception "make-custom-binary-input-port [wrong-num-args]" + exception:wrong-num-args + + ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully + ;; optional. + (make-custom-binary-input-port "port" (lambda args #t))) + + (pass-if "make-custom-binary-input-port" + (let* ((source (make-bytevector 7777)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + + (bytevector=? (get-bytevector-all port) source))) + + (pass-if "custom binary input port does not support `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + (not (or (port-has-port-position? port) + (port-has-set-port-position!? port))))) + + (pass-if "custom binary input port supports `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (get-pos (lambda () + (port-position source))) + (set-pos! (lambda (pos) + (set-port-position! source pos))) + (port (make-custom-binary-input-port "the port" read! + get-pos set-pos! #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if "custom binary input port `close-proc' is called" + (let* ((closed? #f) + (read! (lambda (bv start count) 0)) + (get-pos (lambda () 0)) + (set-pos! (lambda (pos) #f)) + (close! (lambda () (set! closed? #t))) + (port (make-custom-binary-input-port "the port" read! + get-pos set-pos! + close!))) + + (close-port port) + closed?))) + + +(with-test-prefix "8.2.10 Output ports" + + (pass-if "open-bytevector-output-port" + (let-values (((port get-content) + (open-bytevector-output-port #f))) + (let ((source (make-bytevector 7777))) + (put-bytevector port source) + (and (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "open-bytevector-output-port [put-u8]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (put-u8 port 77) + (and (bytevector=? (get-content) (make-bytevector 1 77)) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "open-bytevector-output-port [display]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (display "hello" port) + (and (bytevector=? (get-content) (string->utf8 "hello")) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "bytevector output port supports `port-position'" + (let-values (((port get-content) + (open-bytevector-output-port))) + (let ((source (make-bytevector 7777)) + (overwrite (make-bytevector 33))) + (and (port-has-port-position? port) + (port-has-set-port-position!? port) + (begin + (put-bytevector port source) + (= (bytevector-length source) + (port-position port))) + (begin + (set-port-position! port 10) + (= 10 (port-position port))) + (begin + (put-bytevector port overwrite) + (bytevector-copy! overwrite 0 source 10 + (bytevector-length overwrite)) + (= (port-position port) + (+ 10 (bytevector-length overwrite)))) + (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "make-custom-binary-output" + (let ((port (make-custom-binary-output-port "cbop" + (lambda (x y z) 0) + #f #f #f))) + (and (output-port? port) + (binary-port? port) + (not (port-has-port-position? port)) + (not (port-has-set-port-position!? port))))) + + (pass-if "make-custom-binary-output-port [partial writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (bytevector-u8-set! sink sink-pos u8) + (set! sink-pos (+ 1 sink-pos)) + 1)))) + (port (make-custom-binary-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if "make-custom-binary-output-port [full writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (begin + (bytevector-copy! bv start + sink sink-pos + count) + (set! sink-pos (+ sink-pos count)) + count)))) + (port (make-custom-binary-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: From 922d417bf4a7c4eb7d956d340161ad6407545ae7 Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Thu, 28 May 2009 18:15:05 -0400 Subject: [PATCH 171/375] Implementation of SRFI-98 (An interface to access environment variables). * NEWS: Add SRFI-98 to 1.8.7 features. * doc/ref/srfi-modules.text (SRFI-98): Documentation for SRFI-98. * module/srfi/srfi-98.scm: New file. SRFI-98 implementation. * test-suite/tests/srfi-98.test: New file. SRFI-98 unit tests. --- NEWS | 4 ++++ doc/ref/srfi-modules.texi | 20 ++++++++++++++++ module/srfi/srfi-98.scm | 44 +++++++++++++++++++++++++++++++++++ test-suite/tests/srfi-98.test | 38 ++++++++++++++++++++++++++++++ 4 files changed, 106 insertions(+) create mode 100644 module/srfi/srfi-98.scm create mode 100644 test-suite/tests/srfi-98.test diff --git a/NEWS b/NEWS index 1785fe8d2..9aca5d912 100644 --- a/NEWS +++ b/NEWS @@ -50,6 +50,10 @@ simplifies code and reduces both the storage and run-time overhead. Changes in 1.8.7 (since 1.8.6) +* New modules (see the manual for details) + +** `(srfi srfi-98)', an interface to access environment variables + * Bugs fixed ** Fix compilation with `--disable-deprecated' diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 1fa50b209..7c107e710 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -47,6 +47,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-61:: A more general `cond' clause * SRFI-69:: Basic hash tables. * SRFI-88:: Keyword objects. +* SRFI-98:: Accessing environment variables. @end menu @@ -3608,6 +3609,25 @@ Return the keyword object whose name is @var{str}. @end example @end deffn +@node SRFI-98 +@subsection SRFI-98 Accessing environment variables. +@cindex SRFI-98 +@cindex environment variables + +This is a portable wrapper around Guile's built-in support for +interacting with the current environment, @xref{Runtime Environment}. + +@deffn {Scheme Procedure} get-environment-variable name +Returns a string containing the value of the environment variable +given by the string @code{name}, or @code{#f} if the named +environment variable is not found. This is equivalent to +@code{(getenv name)}. +@end deffn + +@deffn {Scheme Procedure} get-environment-variables +Returns the names and values of all the environment variables as an +association list in which both the keys and the values are strings. +@end deffn @c srfi-modules.texi ends here diff --git a/module/srfi/srfi-98.scm b/module/srfi/srfi-98.scm new file mode 100644 index 000000000..924a20578 --- /dev/null +++ b/module/srfi/srfi-98.scm @@ -0,0 +1,44 @@ +;;; srfi-98.scm --- An interface to access environment variables + +;; Copyright (C) 2009 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2.1 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Julian Graham +;;; Date: 2009-05-26 + +;;; Commentary: + +;; This is an implementation of SRFI-98 (An interface to access environment +;; variables). +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-98) + :use-module (srfi srfi-1) + :export (get-environment-variable + get-environment-variables)) + +(cond-expand-provide (current-module) '(srfi-98)) + +(define get-environment-variable getenv) +(define (get-environment-variables) + (define (string->alist-entry str) + (let ((pvt (string-index str #\=)) + (len (string-length str))) + (and pvt (cons (substring str 0 pvt) (substring str (+ pvt 1) len))))) + (filter-map string->alist-entry (environ))) diff --git a/test-suite/tests/srfi-98.test b/test-suite/tests/srfi-98.test new file mode 100644 index 000000000..3fbb1ef03 --- /dev/null +++ b/test-suite/tests/srfi-98.test @@ -0,0 +1,38 @@ +;;;; srfi-98.test --- Test suite for Guile's SRFI-98 functions. -*- scheme -*- +;;;; +;;;; Copyright 2009 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA + +(define-module (test-srfi-98) + #:use-module (srfi srfi-98) + #:use-module (test-suite lib)) + +(with-test-prefix "get-environment-variable" + (pass-if "get-environment-variable retrieves binding" + (putenv "foo=bar") + (equal? (get-environment-variable "foo") "bar")) + + (pass-if "get-environment-variable #f on unbound name" + (unsetenv "foo") + (not (get-environment-variable "foo")))) + +(with-test-prefix "get-environment-variables" + + (pass-if "get-environment-variables contains binding" + (putenv "foo=bar") + (equal? (assoc-ref (get-environment-variables) "foo") "bar"))) + From 5b197db838ae12aae948eef92d79d1f37548bac4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 2 Jun 2009 22:18:02 +0200 Subject: [PATCH 172/375] separate the load-compiled path from the load path * libguile/Makefile.am (libpath.h): Add definitions for SCM_CCACHE_DIR and SCM_EFFECTIVE_VERSION. These are private, the header is not installed. Add ccachedir to build-info. Rework some other build-info definitions. * libguile/load.c (scm_loc_load_compiled_path): New global, corresponding to the new environment variable, GUILE_LOAD_COMPILED_PATH. Compiled files will now be searched for in this path, and only in this path. (scm_init_load_path): Init the load-compiled path too. We initialize it with $pkglibdir/guile/$effective_version/ccache, and also with $HOME/.guile-ccache/$effective_version/. This will respect the libdir/datadir difference, and it is a preparation for automatic compilation support. (scm_primitive_load_path): Search only the GUILE_LOAD_COMPILED_PATH for compiled files. (scm_init_load): Cache scm_loc_load_compiled_path. --- libguile/Makefile.am | 9 ++++++--- libguile/load.c | 48 ++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 52 insertions(+), 5 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index fcf197a54..b9e8e2bf0 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -286,6 +286,8 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status @echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.tmp @echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)"'>>libpath.tmp @echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.tmp + @echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp + @echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp @echo '#define SCM_BUILD_INFO { \' >> libpath.tmp @echo ' { "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp @echo ' { "top_srcdir", "@top_srcdir_absolute@" }, \' >> libpath.tmp @@ -299,12 +301,13 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status @echo ' { "sharedstatedir", "@sharedstatedir@" }, \' >> libpath.tmp @echo ' { "localstatedir", "@localstatedir@" }, \' >> libpath.tmp @echo ' { "libdir", "@libdir@" }, \' >> libpath.tmp + @echo ' { "ccachedir", SCM_CCACHE_DIR }, \' >> libpath.tmp @echo ' { "infodir", "@infodir@" }, \' >> libpath.tmp @echo ' { "mandir", "@mandir@" }, \' >> libpath.tmp @echo ' { "includedir", "@includedir@" }, \' >> libpath.tmp - @echo ' { "pkgdatadir", "$(datadir)/@PACKAGE@" }, \' >> libpath.tmp - @echo ' { "pkglibdir", "$(libdir)/@PACKAGE@" }, \' >> libpath.tmp - @echo ' { "pkgincludedir", "$(includedir)/@PACKAGE@" }, \' \ + @echo ' { "pkgdatadir", "@pkgdatadir@" }, \' >> libpath.tmp + @echo ' { "pkglibdir", "@pkglibdir@" }, \' >> libpath.tmp + @echo ' { "pkgincludedir", "@pkgincludedir@" }, \' \ >> libpath.tmp @echo ' { "guileversion", "@GUILE_VERSION@" }, \' >> libpath.tmp @echo ' { "libguileinterface", "@LIBGUILE_INTERFACE@" }, \' \ diff --git a/libguile/load.c b/libguile/load.c index 1b5b24f35..f41e269e3 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -53,6 +53,10 @@ #include #endif /* HAVE_UNISTD_H */ +#ifdef HAVE_PWD_H +#include +#endif /* HAVE_PWD_H */ + #ifndef R_OK #define R_OK 4 #endif @@ -174,7 +178,8 @@ static SCM *scm_loc_load_path; /* List of extensions we try adding to the filenames. */ static SCM *scm_loc_load_extensions; -/* Like %load-extensions, but for compiled files. */ +/* Like %load-path and %load-extensions, but for compiled files. */ +static SCM *scm_loc_load_compiled_path; static SCM *scm_loc_load_compiled_extensions; @@ -209,6 +214,7 @@ scm_init_load_path () { char *env; SCM path = SCM_EOL; + SCM cpath = SCM_EOL; #ifdef SCM_LIBRARY_DIR env = getenv ("GUILE_SYSTEM_PATH"); @@ -222,13 +228,48 @@ scm_init_load_path () path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR), scm_from_locale_string (SCM_LIBRARY_DIR), scm_from_locale_string (SCM_PKGDATA_DIR)); + + env = getenv ("GUILE_SYSTEM_COMPILED_PATH"); + if (env && strcmp (env, "") == 0) + /* like above */ + ; + else if (env) + cpath = scm_parse_path (scm_from_locale_string (env), cpath); + else + { + char *home; + + home = getenv ("HOME"); +#ifdef HAVE_GETPWENT + if (!home) + { + struct passwd *pwd; + pwd = getpwuid (getuid ()); + if (pwd) + home = pwd->pw_dir; + } +#endif /* HAVE_GETPWENT */ + if (home) + { char buf[1024]; + snprintf (buf, sizeof(buf), + "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home); + cpath = scm_cons (scm_from_locale_string (buf), cpath); + } + + cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath); + } #endif /* SCM_LIBRARY_DIR */ env = getenv ("GUILE_LOAD_PATH"); if (env) path = scm_parse_path (scm_from_locale_string (env), path); + env = getenv ("GUILE_LOAD_COMPILED_PATH"); + if (env) + cpath = scm_parse_path (scm_from_locale_string (env), cpath); + *scm_loc_load_path = path; + *scm_loc_load_compiled_path = cpath; } SCM scm_listofnullstr; @@ -519,7 +560,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM full_filename, compiled_filename; full_filename = scm_sys_search_load_path (filename); - compiled_filename = scm_search_path (*scm_loc_load_path, + compiled_filename = scm_search_path (*scm_loc_load_compiled_path, filename, *scm_loc_load_compiled_extensions, SCM_BOOL_T); @@ -529,6 +570,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, scm_list_1 (filename)); if (scm_is_false (compiled_filename)) + /* FIXME: autocompile here */ return scm_primitive_load (full_filename); if (scm_is_false (full_filename)) @@ -600,6 +642,8 @@ scm_init_load () = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", scm_list_2 (scm_from_locale_string (".scm"), scm_nullstr))); + scm_loc_load_compiled_path + = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-path", SCM_EOL)); scm_loc_load_compiled_extensions = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-extensions", scm_list_1 (scm_from_locale_string (".go")))); From fcb6f5ff3332a3a4b3de7d735757f7d3db4ddff5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 2 Jun 2009 22:20:21 +0200 Subject: [PATCH 173/375] add exception-on-error optional arg to `stat' in scheme * libguile/filesys.h: * libguile/filesys.c (scm_stat): Add optional arg, exception-on-error, which if #f (not the default) will just return #f instead of raising an exception if the stat fails. --- libguile/filesys.c | 32 +++++++++++++++++++++----------- libguile/filesys.h | 2 +- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index ec33328b1..4799dd4b1 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -580,17 +580,23 @@ static int fstat_Win32 (int fdes, struct stat *buf) } #endif /* __MINGW32__ */ -SCM_DEFINE (scm_stat, "stat", 1, 0, 0, - (SCM object), +SCM_DEFINE (scm_stat, "stat", 1, 1, 0, + (SCM object, SCM exception_on_error), "Return an object containing various information about the file\n" "determined by @var{obj}. @var{obj} can be a string containing\n" "a file name or a port or integer file descriptor which is open\n" "on a file (in which case @code{fstat} is used as the underlying\n" "system call).\n" "\n" - "The object returned by @code{stat} can be passed as a single\n" - "parameter to the following procedures, all of which return\n" - "integers:\n" + "If the optional @var{exception_on_error} argument is true, which\n" + "is the default, an exception will be raised if the underlying\n" + "system call returns an error, for example if the file is not\n" + "found or is not readable. Otherwise, an error will cause\n" + "@code{stat} to return @code{#f}." + "\n" + "The object returned by a successful call to @code{stat} can be\n" + "passed as a single parameter to the following procedures, all of\n" + "which return integers:\n" "\n" "@table @code\n" "@item stat:dev\n" @@ -678,12 +684,16 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, if (rv == -1) { - int en = errno; - - SCM_SYSERROR_MSG ("~A: ~S", - scm_list_2 (scm_strerror (scm_from_int (en)), - object), - en); + if (SCM_UNBNDP (exception_on_error) || scm_is_true (exception_on_error)) + { + int en = errno; + SCM_SYSERROR_MSG ("~A: ~S", + scm_list_2 (scm_strerror (scm_from_int (en)), + object), + en); + } + else + return SCM_BOOL_F; } return scm_stat2scm (&stat_temp); } diff --git a/libguile/filesys.h b/libguile/filesys.h index a38a5b594..cf0a6acf2 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -42,7 +42,7 @@ SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode); SCM_API SCM scm_open (SCM path, SCM flags, SCM mode); SCM_API SCM scm_close (SCM fd_or_port); SCM_API SCM scm_close_fdes (SCM fd); -SCM_API SCM scm_stat (SCM object); +SCM_API SCM scm_stat (SCM object, SCM exception_on_error); SCM_API SCM scm_link (SCM oldpath, SCM newpath); SCM_API SCM scm_rename (SCM oldname, SCM newname); SCM_API SCM scm_delete_file (SCM str); From d1e47c6e6c9698cd8623d370db0056176aa42bd9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 2 Jun 2009 22:37:24 +0200 Subject: [PATCH 174/375] update uninstalled-env.in for load-compiled path separation * meta/uninstalled-env.in: Update to set GUILE_LOAD_COMPILED_PATH and GUILE_SYSTEM_COMPILED_PATH. --- meta/uninstalled-env.in | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index d5c7949f5..b15237c4b 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -66,9 +66,26 @@ else fi export GUILE_LOAD_PATH +if [ x"$GUILE_LOAD_COMPILED_PATH" = x ] +then + GUILE_LOAD_COMPILED_PATH="${top_builddir}/guile-readline:${top_builddir}:${top_builddir}/module" +else + for d in "${top_builddir}" "${top_builddir}/guile-readline" \ + "${top_builddir}/module" + do + # This hair prevents double inclusion. + # The ":" prevents prefix aliasing. + case x"$GUILE_LOAD_COMPILED_PATH" in + x*${d}:*) ;; + *) GUILE_LOAD_COMPILED_PATH="${d}:$GUILE_LOAD_COMPILED_PATH" ;; + esac + done +fi +export GUILE_LOAD_COMPILED_PATH + # Don't look in installed dirs for guile modules -if ( env | grep -v -q -E '^GUILE_SYSTEM_PATH=' ); then - export GUILE_SYSTEM_PATH= +if ( env | grep -v -q -E '^GUILE_SYSTEM_COMPILED_PATH=' ); then + export GUILE_SYSTEM_COMPILED_PATH= fi # handle LTDL_LIBRARY_PATH (no clobber) From 727c259ac5c9a5415a0dac2ddbbc74193906caeb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 2 Jun 2009 22:39:30 +0200 Subject: [PATCH 175/375] file-exists? doesn't cause a throw, simpler try-module-autoload * module/ice-9/boot-9.scm (file-exists?): Change to use the stat interface that doesn't throw exceptions. (try-module-autoload): Simplify to take advantage of the fact that primitive-load-path does the right thing with regards to loading compiled files if they are available. --- module/ice-9/boot-9.scm | 23 +++++------------------ 1 file changed, 5 insertions(+), 18 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 44066312a..5f365b484 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -611,12 +611,10 @@ (primitive-load-path "ice-9/networking")) ;; For reference, Emacs file-exists-p uses stat in this same way. -;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in -;; C where all that's needed is to inspect the return from stat(). (define file-exists? (if (provided? 'posix) (lambda (str) - (->bool (false-if-exception (stat str)))) + (->bool (stat str #f))) (lambda (str) (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ)) (lambda args #f)))) @@ -2278,21 +2276,10 @@ module '(ice-9 q) '(make-q q-length))}." (dynamic-wind (lambda () (autoload-in-progress! dir-hint name)) (lambda () - (let ((file (in-vicinity dir-hint name))) - (let ((compiled (and load-compiled - (%search-load-path - (string-append file ".go")))) - (source (%search-load-path file))) - (cond ((and source - (or (not compiled) - (< (stat:mtime (stat compiled)) - (stat:mtime (stat source))))) - (if compiled - (warn "source file" source "newer than" compiled)) - (with-fluid* current-reader #f - (lambda () (load-file primitive-load source)))) - (compiled - (load-file load-compiled compiled)))))) + (with-fluid* current-reader #f + (lambda () + (load-file primitive-load-path + (in-vicinity dir-hint name))))) (lambda () (set-autoloaded! dir-hint name didit))) didit)))) From 4c9c9b9b9822658ee32a9561f56ac3b9d87b0fee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 2 Jun 2009 22:49:39 +0200 Subject: [PATCH 176/375] install .go files under $libdir, not $datadir * am/guilec: Install .go files to $(pkglibdir)/$GUILE_EFFECTIVE_VERSION/ccache. --- am/guilec | 4 +- module/system/base/compile.scm | 104 +++++++++++++++++++++++++++++---- 2 files changed, 96 insertions(+), 12 deletions(-) diff --git a/am/guilec b/am/guilec index f8690d305..37f56bd40 100644 --- a/am/guilec +++ b/am/guilec @@ -2,7 +2,9 @@ GOBJECTS = $(SOURCES:%.scm=%.go) moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath) -nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS) +nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath) +ccache_DATA = $(GOBJECTS) EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) CLEANFILES = $(GOBJECTS) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index f6522f735..f995d908f 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -29,6 +29,7 @@ #:export (syntax-error *current-language* compiled-file-name compile-file compile-and-load + load-ensuring-compiled compile decompile) #:export-syntax (call-with-compile-error-catch)) @@ -92,6 +93,12 @@ x (lookup-language x))) +(define (ensure-directory dir) + (or (file-exists? dir) + (begin + (ensure-directory (dirname dir)) + (mkdir dir)))) + (define* (compile-file file #:key (output-file #f) (env #f) @@ -100,6 +107,7 @@ (opts '())) (let ((comp (or output-file (compiled-file-name file))) (in (open-input-file file))) + (ensure-directory (dirname comp)) (call-with-output-file/atomic comp (lambda (port) ((language-printer (ensure-language to)) @@ -111,7 +119,55 @@ (read-and-compile (open-input-file file) #:from from #:to to #:opts opts)) -(define (compiled-file-name file) +(define* (load-ensuring-compiled source #:key (from 'scheme) + (to 'value) (opts '())) + (let ((compiled (compiled-file-name source #:readable #t))) + (load-compiled + (if (and compiled + (>= (stat:mtime (stat compiled)) (stat:mtime (stat source)))) + compiled + (let ((to-compile (compiled-file-name source #:writable #t))) + (if compiled + (warn "source file" source "newer than" compiled)) + (if (and compiled + (not (string-equal? compiled to-compile)) + (file-exists? to-compile) + (>= (stat:mtime (stat to-compile)) + (stat:mtime (stat compiled)))) + (warn "using local compiled copy" to-compile) + (begin + (format (current-error-port) ";;; Compiling ~s\n" source) + (compile-file source #:output-file to-compile) + (format (current-error-port) ";;; Success: ~s\n" to-compile))) + to-compile))))) + +(define (ensure-fallback-path) + (let ((home (or (getenv "HOME") + (false-if-exception + (passwd:dir (getpwuid (getuid))))))) + (and home + (let ((cache (in-vicinity home ".guile-ccache"))) + (cond + ((and (access? cache (logior W_OK X_OK)) + (file-is-directory? cache)) + cache) + ((not (file-exists? cache)) + (and (false-if-exception (mkdir cache)) + cache)) + (else #f)))))) + +(define load-compiled-path + (let ((fallback-path #f)) + (lambda () + (if (not fallback-path) + (let ((cache-path (ensure-fallback-path))) + (set! fallback-path + (if cache-path + (list cache-path) + '())))) + (append %load-path fallback-path)))) + +(define* (compiled-file-name file #:key (writable #f) (readable #f)) (let ((base (basename file)) (cext (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) @@ -119,16 +175,42 @@ %load-compiled-extensions) ".go") (else (car %load-compiled-extensions))))) - (let lp ((exts %load-extensions)) - (cond ((null? exts) (string-append file cext)) - ((string-null? (car exts)) (lp (cdr exts))) - ((string-suffix? (car exts) base) - (string-append - (dirname file) "/" - (substring base 0 - (- (string-length base) (string-length (car exts)))) - cext)) - (else (lp (cdr exts))))))) + (define (strip-source-extension base) + (let lp ((exts %load-extensions)) + (cond ((null? exts) (string-append file cext)) + ((string-null? (car exts)) (lp (cdr exts))) + ((string-suffix? (car exts) base) + (substring source 0 + (- (string-length source) + (string-length (car exts))))) + (else (lp (cdr exts)))))) + (define (strip-path file paths) + (let lp ((paths paths)) + (cond ((null? paths) file) + ((string-prefix? (car paths) file) + (substring file (1+ (string-length (car paths))))) + (else (lp (cdr paths)))))) + (let ((sibling (string-append (strip-source-extension file) cext))) + (cond + (writable + ;; either put it right beside the original file, or in our + ;; ccache. other things wind up not making sense. + (cond + ((or (not (file-exists? sibling)) (access? sibling W_OK)) + sibling) + ((ensure-fallback-path) + => (lambda (p) + (string-append p "/" (strip-path sibling)))) + (else #f))) + (readable + (if (access? sibling R_OK) + sibling + (search-path (load-compiled-path) + (strip-path (strip-source-extension file)) + %load-compiled-extensions #t))) + (else + sibling))))) + ;;; From f3130a2ecf218f3709de13c10c54e8586fe0aef2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jun 2009 09:02:48 +0200 Subject: [PATCH 177/375] compiled-file-name tries to put the .go in the %load-compiled-path * module/system/base/compile.scm (ensure-writable-dir): Rename from ensure-directory. (dsu-sort): Helper, does a decorate / sort / undecorate. (compiled-file-name): Refactor to only return a writable filename. The readable case is handled by load.c now, and the other case was silly. Hopefully it will do the right thing. (load-ensuring-compiled): Remove, load.c will call out to compile-file if necessary. (ensure-fallback-path): Remove, load.c will add the ~/.guile-ccache dir to the load-compiled path, which will prompt its creation if necessary. --- module/system/base/compile.scm | 155 ++++++++++++--------------------- 1 file changed, 57 insertions(+), 98 deletions(-) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index f995d908f..d5933edad 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -29,7 +29,6 @@ #:export (syntax-error *current-language* compiled-file-name compile-file compile-and-load - load-ensuring-compiled compile decompile) #:export-syntax (call-with-compile-error-catch)) @@ -93,12 +92,65 @@ x (lookup-language x))) -(define (ensure-directory dir) - (or (file-exists? dir) +;; Throws an exception if `dir' is not writable. The double-stat is OK, +;; as this is only used during compilation. +(define (ensure-writable-dir dir) + (if (file-exists? dir) + (if (access? dir W_OK) + #t + (error "directory not writable" dir)) (begin - (ensure-directory (dirname dir)) + (ensure-writable-dir (dirname dir)) (mkdir dir)))) +(define (dsu-sort list key less) + (map cdr + (stable-sort (map (lambda (x) (cons (key x) x)) list) + (lambda (x y) (less (car x) (car y)))))) + +(define (compiled-file-name file) + (let ((cext (cond ((or (null? %load-compiled-extensions) + (string-null? (car %load-compiled-extensions))) + (warn "invalid %load-compiled-extensions" + %load-compiled-extensions) + ".go") + (else (car %load-compiled-extensions))))) + (define (strip-source-extension path) + (let lp ((exts %load-extensions)) + (cond ((null? exts) file) + ((string-null? (car exts)) (lp (cdr exts))) + ((string-suffix? (car exts) path) + (substring path 0 + (- (string-length path) + (string-length (car exts))))) + (else (lp (cdr exts)))))) + ;; there is some trickery here. if no %load-compiled-path is a + ;; prefix of `file', the stability of the sort makes us end up + ;; trying to write first to last dir in the path, which is usually + ;; the $HOME ccache dir. + (let lp ((paths (dsu-sort (reverse %load-compiled-path) + (lambda (x) + (if (string-prefix? x file) + (string-length x) + 0)) + >))) + (if (null? paths) + (error "no writable path when compiling" file) + (let ((rpath (in-vicinity + (car paths) + (string-append + (strip-source-extension + (if (string-prefix? (car paths) file) + (substring file (1+ (string-length (car paths)))) + (substring file 1))) + cext)))) + (if (and (false-if-exception + (ensure-writable-dir (dirname rpath))) + (or (not (file-exists? rpath)) + (access? rpath W_OK))) + rpath + (lp (cdr paths)))))))) + (define* (compile-file file #:key (output-file #f) (env #f) @@ -107,7 +159,7 @@ (opts '())) (let ((comp (or output-file (compiled-file-name file))) (in (open-input-file file))) - (ensure-directory (dirname comp)) + (ensure-writable-dir (dirname comp)) (call-with-output-file/atomic comp (lambda (port) ((language-printer (ensure-language to)) @@ -119,99 +171,6 @@ (read-and-compile (open-input-file file) #:from from #:to to #:opts opts)) -(define* (load-ensuring-compiled source #:key (from 'scheme) - (to 'value) (opts '())) - (let ((compiled (compiled-file-name source #:readable #t))) - (load-compiled - (if (and compiled - (>= (stat:mtime (stat compiled)) (stat:mtime (stat source)))) - compiled - (let ((to-compile (compiled-file-name source #:writable #t))) - (if compiled - (warn "source file" source "newer than" compiled)) - (if (and compiled - (not (string-equal? compiled to-compile)) - (file-exists? to-compile) - (>= (stat:mtime (stat to-compile)) - (stat:mtime (stat compiled)))) - (warn "using local compiled copy" to-compile) - (begin - (format (current-error-port) ";;; Compiling ~s\n" source) - (compile-file source #:output-file to-compile) - (format (current-error-port) ";;; Success: ~s\n" to-compile))) - to-compile))))) - -(define (ensure-fallback-path) - (let ((home (or (getenv "HOME") - (false-if-exception - (passwd:dir (getpwuid (getuid))))))) - (and home - (let ((cache (in-vicinity home ".guile-ccache"))) - (cond - ((and (access? cache (logior W_OK X_OK)) - (file-is-directory? cache)) - cache) - ((not (file-exists? cache)) - (and (false-if-exception (mkdir cache)) - cache)) - (else #f)))))) - -(define load-compiled-path - (let ((fallback-path #f)) - (lambda () - (if (not fallback-path) - (let ((cache-path (ensure-fallback-path))) - (set! fallback-path - (if cache-path - (list cache-path) - '())))) - (append %load-path fallback-path)))) - -(define* (compiled-file-name file #:key (writable #f) (readable #f)) - (let ((base (basename file)) - (cext (cond ((or (null? %load-compiled-extensions) - (string-null? (car %load-compiled-extensions))) - (warn "invalid %load-compiled-extensions" - %load-compiled-extensions) - ".go") - (else (car %load-compiled-extensions))))) - (define (strip-source-extension base) - (let lp ((exts %load-extensions)) - (cond ((null? exts) (string-append file cext)) - ((string-null? (car exts)) (lp (cdr exts))) - ((string-suffix? (car exts) base) - (substring source 0 - (- (string-length source) - (string-length (car exts))))) - (else (lp (cdr exts)))))) - (define (strip-path file paths) - (let lp ((paths paths)) - (cond ((null? paths) file) - ((string-prefix? (car paths) file) - (substring file (1+ (string-length (car paths))))) - (else (lp (cdr paths)))))) - (let ((sibling (string-append (strip-source-extension file) cext))) - (cond - (writable - ;; either put it right beside the original file, or in our - ;; ccache. other things wind up not making sense. - (cond - ((or (not (file-exists? sibling)) (access? sibling W_OK)) - sibling) - ((ensure-fallback-path) - => (lambda (p) - (string-append p "/" (strip-path sibling)))) - (else #f))) - (readable - (if (access? sibling R_OK) - sibling - (search-path (load-compiled-path) - (strip-path (strip-source-extension file)) - %load-compiled-extensions #t))) - (else - sibling))))) - - ;;; ;;; Compiler interface From 1d022387c8f2615cc94a27109db9b9e02d7d7831 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jun 2009 09:24:35 +0200 Subject: [PATCH 178/375] refactors to load.c to support auto-compilation * libguile/load.c (compiled_is_newer): Factored out of scm_primitive_load_path. (scm_try_autocompile): New stub, for autocompiling. Currently just returns false. (scm_primitive_load_path): Refactor, and call out to scm_try_autocompile if the .go is missing or not fresh. --- libguile/load.c | 77 +++++++++++++++++++++++++++++-------------------- 1 file changed, 45 insertions(+), 32 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index f41e269e3..5dcbe9cbb 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -549,6 +549,43 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, #undef FUNC_NAME +static int +compiled_is_newer (SCM full_filename, SCM compiled_filename) +{ + char *source, *compiled; + struct stat stat_source, stat_compiled; + int res; + + source = scm_to_locale_string (full_filename); + compiled = scm_to_locale_string (compiled_filename); + + if (stat (source, &stat_source) == 0 + && stat (compiled, &stat_compiled) == 0 + && stat_source.st_mtime <= stat_compiled.st_mtime) + { + res = 1; + } + else + { + scm_puts (";;; note: source file ", scm_current_error_port ()); + scm_puts (source, scm_current_error_port ()); + scm_puts (" newer than compiled ", scm_current_error_port ()); + scm_puts (compiled, scm_current_error_port ()); + scm_puts ("\n", scm_current_error_port ()); + res = 0; + + } + free (source); + free (compiled); + return res; +} + +static SCM +scm_try_autocompile (SCM source) +{ + return SCM_BOOL_F; +} + SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, (SCM filename), "Search @var{%load-path} for the file named @var{filename} and\n" @@ -569,40 +606,16 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM_MISC_ERROR ("Unable to find file ~S in load path", scm_list_1 (filename)); - if (scm_is_false (compiled_filename)) - /* FIXME: autocompile here */ - return scm_primitive_load (full_filename); - - if (scm_is_false (full_filename)) + if (scm_is_false (full_filename) + || (scm_is_true (compiled_filename) + && compiled_is_newer (full_filename, compiled_filename))) return scm_load_compiled_with_vm (compiled_filename); - { - char *source, *compiled; - struct stat stat_source, stat_compiled; - - source = scm_to_locale_string (full_filename); - compiled = scm_to_locale_string (compiled_filename); - - if (stat (source, &stat_source) == 0 - && stat (compiled, &stat_compiled) == 0 - && stat_source.st_mtime <= stat_compiled.st_mtime) - { - free (source); - free (compiled); - return scm_load_compiled_with_vm (compiled_filename); - } - else - { - scm_puts (";;; note: source file ", scm_current_error_port ()); - scm_puts (source, scm_current_error_port ()); - scm_puts (" newer than compiled ", scm_current_error_port ()); - scm_puts (compiled, scm_current_error_port ()); - scm_puts ("\n", scm_current_error_port ()); - free (source); - free (compiled); - return scm_primitive_load (full_filename); - } - } + compiled_filename = scm_try_autocompile (full_filename); + if (scm_is_true (compiled_filename)) + return scm_load_compiled_with_vm (compiled_filename); + else + return scm_primitive_load (full_filename); } #undef FUNC_NAME From 0fb81f95b0222c5ba49efd3e36cf797df54c0863 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jun 2009 09:48:16 +0200 Subject: [PATCH 179/375] add exception_on_error optional arg to primitive-load-path * libguile/init.c (scm_load_startup_files): Use scm_c_primitive_load_path. * libguile/load.c (scm_primitive_load_path): Add an optional arg, exception_on_error, which if #f will cause primitive-load-path to just return #f if no file is found. This is to help out the semantics of try-module-autoload. We can't just catch misc-error, because loading the file could raise any exception. (scm_c_primitive_load_path): Add the extra arg to scm_primitive_load_path. * libguile/load.h: Adapt scm_primitive_load_path prototype. * module/ice-9/boot-9.scm (try-module-autoload): Refactor slightly to be clearer. --- libguile/init.c | 2 +- libguile/load.c | 23 +++++++++++++++++------ libguile/load.h | 2 +- module/ice-9/boot-9.scm | 9 ++++----- 4 files changed, 23 insertions(+), 13 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index dbc7f8706..c72aeff4c 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -282,7 +282,7 @@ scm_load_startup_files () /* Load Ice-9. */ if (!scm_ice_9_already_loaded) { - scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9")); + scm_c_primitive_load_path ("ice-9/boot-9"); /* Load the init.scm file. */ if (scm_is_true (init_path)) diff --git a/libguile/load.c b/libguile/load.c index 5dcbe9cbb..6b5d1a528 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -586,16 +586,21 @@ scm_try_autocompile (SCM source) return SCM_BOOL_F; } -SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, - (SCM filename), +SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, + (SCM filename, SCM exception_on_not_found), "Search @var{%load-path} for the file named @var{filename} and\n" "load it into the top-level environment. If @var{filename} is a\n" "relative pathname and is not found in the list of search paths,\n" - "an error is signalled.") + "an error is signalled, unless the optional argument\n" + "@var{exception_on_not_found} is @code{#f}, in which case\n" + "@code{#f} is returned instead.") #define FUNC_NAME s_scm_primitive_load_path { SCM full_filename, compiled_filename; + if (SCM_UNBNDP (exception_on_not_found)) + exception_on_not_found = SCM_BOOL_T; + full_filename = scm_sys_search_load_path (filename); compiled_filename = scm_search_path (*scm_loc_load_compiled_path, filename, @@ -603,8 +608,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM_BOOL_T); if (scm_is_false (full_filename) && scm_is_false (compiled_filename)) - SCM_MISC_ERROR ("Unable to find file ~S in load path", - scm_list_1 (filename)); + { + if (scm_is_true (exception_on_not_found)) + SCM_MISC_ERROR ("Unable to find file ~S in load path", + scm_list_1 (filename)); + else + return SCM_BOOL_F; + } if (scm_is_false (full_filename) || (scm_is_true (compiled_filename) @@ -622,7 +632,8 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM scm_c_primitive_load_path (const char *filename) { - return scm_primitive_load_path (scm_from_locale_string (filename)); + return scm_primitive_load_path (scm_from_locale_string (filename), + SCM_BOOL_T); } diff --git a/libguile/load.h b/libguile/load.h index 87f336e1e..021987329 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -33,7 +33,7 @@ SCM_API SCM scm_sys_library_dir (void); SCM_API SCM scm_sys_site_dir (void); SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts, SCM require_exts); SCM_API SCM scm_sys_search_load_path (SCM filename); -SCM_API SCM scm_primitive_load_path (SCM filename); +SCM_API SCM scm_primitive_load_path (SCM filename, SCM exception_on_not_found); SCM_API SCM scm_c_primitive_load_path (const char *filename); SCM_INTERNAL void scm_init_load_path (void); SCM_INTERNAL void scm_init_load (void); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5f365b484..bb66ccfb6 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2270,16 +2270,15 @@ module '(ice-9 q) '(make-q q-length))}." (resolve-module dir-hint-module-name #f) (and (not (autoload-done-or-in-progress? dir-hint name)) (let ((didit #f)) - (define (load-file proc file) - (save-module-excursion (lambda () (proc file))) - (set! didit #t)) (dynamic-wind (lambda () (autoload-in-progress! dir-hint name)) (lambda () (with-fluid* current-reader #f (lambda () - (load-file primitive-load-path - (in-vicinity dir-hint name))))) + (save-module-excursion + (lambda () + (primitive-load-path (in-vicinity dir-hint name) #f) + (set! didit #t)))))) (lambda () (set-autoloaded! dir-hint name didit))) didit)))) From ee001750269b34179a90aa5c0dc90bd0ffdb8869 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jun 2009 18:22:39 +0200 Subject: [PATCH 180/375] implement autocompilation * am/guilec (.scm.go): Set GUILE_AUTO_COMPILE=0 when compiling individual files, and remove the mkdir -p as compile-file takes care of that now. * libguile/load.c (do_try_autocompile, autocompile_catch_handler) (scm_try_autocompile, scm_init_load): Implement autocompilation. * libguile/script.c (scm_shell_usage, scm_compile_shell_switches): Add --autocompile / --no-autocompile command-line options, and support for the GUILE_AUTO_COMPILE environment variable, defaulting to autocompilation enabled. --- am/guilec | 3 +-- libguile/load.c | 62 ++++++++++++++++++++++++++++++++++++++++++++++- libguile/script.c | 30 +++++++++++++++++++++++ 3 files changed, 92 insertions(+), 3 deletions(-) diff --git a/am/guilec b/am/guilec index 37f56bd40..796e259c3 100644 --- a/am/guilec +++ b/am/guilec @@ -11,5 +11,4 @@ CLEANFILES = $(GOBJECTS) SUFFIXES = .scm .go .scm.go: - $(MKDIR_P) `dirname $@` - $(top_builddir)/meta/uninstalled-env guile-tools compile -o "$@" "$<" + GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guile-tools compile -o "$@" "$<" diff --git a/libguile/load.c b/libguile/load.c index 6b5d1a528..19f22a321 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -182,6 +182,8 @@ static SCM *scm_loc_load_extensions; static SCM *scm_loc_load_compiled_path; static SCM *scm_loc_load_compiled_extensions; +/* Whether we should try to auto-compile. */ +static SCM *scm_loc_load_should_autocompile; SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, (SCM path, SCM tail), @@ -580,10 +582,65 @@ compiled_is_newer (SCM full_filename, SCM compiled_filename) return res; } +static SCM +do_try_autocompile (void *data) +{ + SCM source = PTR2SCM (data); + SCM comp_mod, compile_file, res; + + scm_puts (";;; compiling ", scm_current_error_port ()); + scm_display (source, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + + comp_mod = scm_c_resolve_module ("system base compile"); + compile_file = scm_c_module_lookup (comp_mod, "compile-file"); + res = scm_call_1 (scm_variable_ref (compile_file), source); + + scm_puts (";;; compiled ", scm_current_error_port ()); + scm_display (res, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + + return res; +} + +static SCM +autocompile_catch_handler (void *data, SCM tag, SCM throw_args) +{ + SCM source = PTR2SCM (data); + scm_puts (";;; WARNING: compilation of ", scm_current_error_port ()); + scm_display (source, scm_current_error_port ()); + scm_puts (" failed\n", scm_current_error_port ()); + scm_puts (";;; key ", scm_current_error_port ()); + scm_write (tag, scm_current_error_port ()); + scm_puts (", throw args ", scm_current_error_port ()); + scm_write (throw_args, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + return SCM_BOOL_F; +} + static SCM scm_try_autocompile (SCM source) { - return SCM_BOOL_F; + static int message_shown = 0; + + if (scm_is_false (*scm_loc_load_should_autocompile)) + return SCM_BOOL_F; + + if (!message_shown) + { + scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n" + ";;; or pass the --no-autocompile argument to disable\n", + scm_current_error_port ()); + message_shown = 1; + } + + /* fixme: wrap in a `catch' */ + return scm_c_catch (SCM_BOOL_T, + do_try_autocompile, + SCM2PTR (source), + autocompile_catch_handler, + SCM2PTR (source), + NULL, NULL); } SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, @@ -673,6 +730,9 @@ scm_init_load () scm_list_1 (scm_from_locale_string (".go")))); scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); + scm_loc_load_should_autocompile + = SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F)); + the_reader = scm_make_fluid (); the_reader_fluid_num = SCM_FLUID_NUM (the_reader); SCM_FAST_FLUID_SET_X (the_reader_fluid_num, SCM_BOOL_F); diff --git a/libguile/script.c b/libguile/script.c index 14691c738..c61e85a8d 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -29,6 +29,7 @@ #include "libguile/eval.h" #include "libguile/feature.h" #include "libguile/load.h" +#include "libguile/private-gc.h" /* scm_getenv_int */ #include "libguile/read.h" #include "libguile/script.h" #include "libguile/strings.h" @@ -376,6 +377,10 @@ scm_shell_usage (int fatal, char *message) " --no-debug start with normal evaluator\n" " Default is to enable debugging for interactive\n" " use, but not for `-s' and `-c'.\n" + " --autocompile compile source files automatically\n" + " --no-autocompile disable automatic source file compilation\n" + " Default is to enable autocompilation of source\n" + " files.\n" " -q inhibit loading of user init file\n" " --emacs enable Emacs protocol (experimental)\n" " --use-srfi=LS load SRFI modules for the SRFIs in LS,\n" @@ -404,6 +409,7 @@ SCM_SYMBOL (sym_quit, "quit"); SCM_SYMBOL (sym_use_srfis, "use-srfis"); SCM_SYMBOL (sym_load_path, "%load-path"); SCM_SYMBOL (sym_set_x, "set!"); +SCM_SYMBOL (sym_sys_load_should_autocompile, "%load-should-autocompile"); SCM_SYMBOL (sym_cons, "cons"); SCM_SYMBOL (sym_at, "@"); SCM_SYMBOL (sym_atat, "@@"); @@ -448,6 +454,8 @@ scm_compile_shell_switches (int argc, char **argv) int use_emacs_interface = 0; int turn_on_debugging = 0; int dont_turn_on_debugging = 0; + int turn_on_autocompile = 0; + int dont_turn_on_autocompile = 0; int i; char *argv0 = guile; @@ -584,6 +592,18 @@ scm_compile_shell_switches (int argc, char **argv) turn_on_debugging = 0; } + else if (! strcmp (argv[i], "--autocompile")) + { + turn_on_autocompile = 1; + dont_turn_on_autocompile = 0; + } + + else if (! strcmp (argv[i], "--no-autocompile")) + { + dont_turn_on_autocompile = 1; + turn_on_autocompile = 0; + } + else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */ use_emacs_interface = 1; @@ -701,6 +721,16 @@ scm_compile_shell_switches (int argc, char **argv) tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail); } + /* If GUILE_AUTO_COMPILE is not set and no args are given, default to + autocompilation. */ + if (turn_on_autocompile || (scm_getenv_int ("GUILE_AUTO_COMPILE", 1) + && !dont_turn_on_autocompile)) + { + tail = scm_cons (scm_list_3 (sym_set_x, sym_sys_load_should_autocompile, + SCM_BOOL_T), + tail); + } + /* If debugging was requested, or we are interactive and debugging was not explicitly turned off, turn on debugging. */ if (turn_on_debugging || (interactive && !dont_turn_on_debugging)) From 6fd367e742f42421d81362a6ee8b51bb7b35a9ab Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jun 2009 23:20:44 +0200 Subject: [PATCH 181/375] tweaks to autocompile code * libguile/load.c (compiled_is_newer): Tweak diagnostic output. (do_try_autocompile, autocompile_catch_handler, scm_try_autocompile): Rework to compute the name of the compiled file in advance. If the computed name is different from the found .go file and is fresh, use it directly. Fixes the case where /usr/lib/.../foo.go is out of date but the user doesn't have permissions to recompile, so we use the user's local compile cache instead if it's fresh. (scm_primitive_load): Pass the found .go file as well to scm_try_autocompile. --- libguile/load.c | 49 ++++++++++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 13 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 19f22a321..ac9cc7dad 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -571,7 +571,7 @@ compiled_is_newer (SCM full_filename, SCM compiled_filename) { scm_puts (";;; note: source file ", scm_current_error_port ()); scm_puts (source, scm_current_error_port ()); - scm_puts (" newer than compiled ", scm_current_error_port ()); + scm_puts ("\n;;; newer than compiled ", scm_current_error_port ()); scm_puts (compiled, scm_current_error_port ()); scm_puts ("\n", scm_current_error_port ()); res = 0; @@ -582,19 +582,22 @@ compiled_is_newer (SCM full_filename, SCM compiled_filename) return res; } +SCM_KEYWORD (k_output_file, "output-file"); + static SCM do_try_autocompile (void *data) { - SCM source = PTR2SCM (data); + SCM pair = PTR2SCM (data); SCM comp_mod, compile_file, res; scm_puts (";;; compiling ", scm_current_error_port ()); - scm_display (source, scm_current_error_port ()); + scm_display (scm_car (pair), scm_current_error_port ()); scm_newline (scm_current_error_port ()); comp_mod = scm_c_resolve_module ("system base compile"); compile_file = scm_c_module_lookup (comp_mod, "compile-file"); - res = scm_call_1 (scm_variable_ref (compile_file), source); + res = scm_call_3 (scm_variable_ref (compile_file), scm_car (pair), + k_output_file, scm_cdr (pair)); scm_puts (";;; compiled ", scm_current_error_port ()); scm_display (res, scm_current_error_port ()); @@ -606,10 +609,12 @@ do_try_autocompile (void *data) static SCM autocompile_catch_handler (void *data, SCM tag, SCM throw_args) { - SCM source = PTR2SCM (data); + SCM pair = PTR2SCM (data); scm_puts (";;; WARNING: compilation of ", scm_current_error_port ()); - scm_display (source, scm_current_error_port ()); - scm_puts (" failed\n", scm_current_error_port ()); + scm_display (scm_car (pair), scm_current_error_port ()); + scm_puts ("\n;;; to ", scm_current_error_port ()); + scm_display (scm_cdr (pair), scm_current_error_port ()); + scm_puts (" failed:\n", scm_current_error_port ()); scm_puts (";;; key ", scm_current_error_port ()); scm_write (tag, scm_current_error_port ()); scm_puts (", throw args ", scm_current_error_port ()); @@ -619,9 +624,10 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args) } static SCM -scm_try_autocompile (SCM source) +scm_try_autocompile (SCM source, SCM stale_compiled) { static int message_shown = 0; + SCM comp_mod, compiled_file_name, new_compiled, pair; if (scm_is_false (*scm_loc_load_should_autocompile)) return SCM_BOOL_F; @@ -629,17 +635,34 @@ scm_try_autocompile (SCM source) if (!message_shown) { scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n" - ";;; or pass the --no-autocompile argument to disable\n", + ";;; or pass the --no-autocompile argument to disable.\n", scm_current_error_port ()); message_shown = 1; } - /* fixme: wrap in a `catch' */ + comp_mod = scm_c_resolve_module ("system base compile"); + compiled_file_name = scm_c_module_lookup (comp_mod, "compiled-file-name"); + new_compiled = scm_call_1 (scm_variable_ref (compiled_file_name), source); + + if (scm_is_false (new_compiled)) + return SCM_BOOL_F; + else if (!scm_is_true (scm_equal_p (new_compiled, stale_compiled)) + && scm_is_true (scm_stat (new_compiled, SCM_BOOL_F)) + && compiled_is_newer (source, new_compiled)) + { + scm_puts (";;; found compiled file elsewhere: ", + scm_current_error_port ()); + scm_display (new_compiled, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + return new_compiled; + } + + pair = scm_cons (source, new_compiled); return scm_c_catch (SCM_BOOL_T, do_try_autocompile, - SCM2PTR (source), + SCM2PTR (pair), autocompile_catch_handler, - SCM2PTR (source), + SCM2PTR (pair), NULL, NULL); } @@ -678,7 +701,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, && compiled_is_newer (full_filename, compiled_filename))) return scm_load_compiled_with_vm (compiled_filename); - compiled_filename = scm_try_autocompile (full_filename); + compiled_filename = scm_try_autocompile (full_filename, compiled_filename); if (scm_is_true (compiled_filename)) return scm_load_compiled_with_vm (compiled_filename); else From c2521a212417b095475148e321daaf6e59ef5b3d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jun 2009 23:59:58 +0200 Subject: [PATCH 182/375] fix error autocompiling parts of the compiler; make check works * libguile/load.c (scm_try_autocompile): Punt if compiled-file-name does not resolve, which would indicate that the file in question is part of the compiler itself. * test-suite/tests/elisp.test: Today I was an evil one -- disable autocompilation for the elisp tests, as they are meant only for the memoizer's eyes. Hopefully Daniel will fix this :-) --- libguile/load.c | 14 +++++++++++++- test-suite/tests/elisp.test | 4 ++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/libguile/load.c b/libguile/load.c index ac9cc7dad..4e127d68c 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -641,7 +641,19 @@ scm_try_autocompile (SCM source, SCM stale_compiled) } comp_mod = scm_c_resolve_module ("system base compile"); - compiled_file_name = scm_c_module_lookup (comp_mod, "compiled-file-name"); + compiled_file_name = + scm_module_variable (comp_mod, + scm_from_locale_symbol ("compiled-file-name")); + + if (scm_is_false (compiled_file_name)) + { + scm_puts (";;; it seems ", scm_current_error_port ()); + scm_display (source, scm_current_error_port ()); + scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n", + scm_current_error_port ()); + return SCM_BOOL_F; + } + new_compiled = scm_call_1 (scm_variable_ref (compiled_file_name), source); if (scm_is_false (new_compiled)) diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index eaf6dbbff..9e0997087 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -23,6 +23,9 @@ (if *old-stack-level* (debug-set! stack (* 2 *old-stack-level*))) +(define *old-%load-should-autocompile* %load-should-autocompile) +(set! %load-should-autocompile #f) + ;;; ;;; elisp ;;; @@ -350,6 +353,7 @@ )) +(set! %load-should-autocompile *old-%load-should-autocompile*) (debug-set! stack *old-stack-level*) ;;; elisp.test ends here From e27f640a6fa0af403e37d5c9a8651e03932465a4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 4 Jun 2009 12:47:47 +0200 Subject: [PATCH 183/375] turn off autocompilation when snarfing * libguile/Makefile.am (snarf2checkedtexi): Turn off autocompilation when snarfing. --- libguile/Makefile.am | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index b9e8e2bf0..46bc998af 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -337,10 +337,8 @@ error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -include $(top_srcdir)/am/pre-inst-guile - alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) -snarf2checkedtexi = $(top_builddir)/meta/uninstalled-env guile-tools snarf-check-and-output-texi +snarf2checkedtexi = GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guile-tools snarf-check-and-output-texi dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi) guile.texi: $(alldotdocfiles) guile$(EXEEXT) From a46b7f14afa3308f48b1f2dd5e13381138af87e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 4 Jun 2009 12:53:34 +0200 Subject: [PATCH 184/375] fix .go installation * am/guilec (nobase_ccache_DATA): Fix .go installation. --- am/guilec | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/am/guilec b/am/guilec index 796e259c3..d081e1fbe 100644 --- a/am/guilec +++ b/am/guilec @@ -4,7 +4,7 @@ GOBJECTS = $(SOURCES:%.scm=%.go) moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath) nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath) -ccache_DATA = $(GOBJECTS) +nobase_ccache_DATA = $(GOBJECTS) EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) CLEANFILES = $(GOBJECTS) From b193d904bb9e8c1f8aa8b4a985b03aa59c4e6a21 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 4 Jun 2009 23:11:55 +0200 Subject: [PATCH 185/375] propagate timestamps to installed .scm and .go files * am/guilec: Propagate timestamps of .scm and .go files on to their installed variants. Helps the is-the-.go-file-stale? code do its job. --- am/guilec | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/am/guilec b/am/guilec index d081e1fbe..ce0711b74 100644 --- a/am/guilec +++ b/am/guilec @@ -9,6 +9,25 @@ EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) CLEANFILES = $(GOBJECTS) +# Well, shit. We can't have install changing timestamps, can we? But +# install_sh doesn't know how to preserve timestamps. Soooo, fondle +# automake to make things happen. +install-data-hook: + @$(am__vpath_adj_setup) \ + list='$(nobase_mod_DATA)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + $(am__vpath_adj) \ + echo " touch -r '$$d$$p' '$(DESTDIR)$(moddir)/$$f'"; \ + touch -r "$$d$$p" "$(DESTDIR)$(moddir)/$$f"; \ + done + @$(am__vpath_adj_setup) \ + list='$(nobase_ccache_DATA)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + $(am__vpath_adj) \ + echo " touch -r '$$d$$p' '$(DESTDIR)$(ccachedir)/$$f'"; \ + touch -r "$$d$$p" "$(DESTDIR)$(ccachedir)/$$f"; \ + done + SUFFIXES = .scm .go .scm.go: GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guile-tools compile -o "$@" "$<" From 5ea401bffe2ea60545338a48767f4c75d48642c7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 01:20:19 +0200 Subject: [PATCH 186/375] further autocompilation tweaks * module/system/base/compile.scm (compiled-file-name): * libguile/load.c (scm_init_load_path, scm_try_autocompile) (scm_primitive_load_path): Rework so that we search for .go files in the load-compiled path and in the fallback path, but we only autocompile to the fallback path. Should produce a more desirable experience. --- libguile/load.c | 78 +++++++++++++++++++--------------- module/system/base/compile.scm | 74 ++++++++++++++------------------ 2 files changed, 76 insertions(+), 76 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 4e127d68c..f54015bc5 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -185,6 +185,9 @@ static SCM *scm_loc_load_compiled_extensions; /* Whether we should try to auto-compile. */ static SCM *scm_loc_load_should_autocompile; +/* The fallback path for autocompilation */ +static SCM *scm_loc_compile_fallback_path; + SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, (SCM path, SCM tail), "Parse @var{path}, which is expected to be a colon-separated\n" @@ -239,6 +242,10 @@ scm_init_load_path () cpath = scm_parse_path (scm_from_locale_string (env), cpath); else { + /* the idea: if GUILE_SYSTEM_COMPILED_PATH is set, then it seems we're working + against an uninstalled Guile, in which case we shouldn't be autocompiling, + otherwise offer up the user's home directory as penance for not having + up-to-date .go files. */ char *home; home = getenv ("HOME"); @@ -255,9 +262,9 @@ scm_init_load_path () { char buf[1024]; snprintf (buf, sizeof(buf), "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home); - cpath = scm_cons (scm_from_locale_string (buf), cpath); + *scm_loc_compile_fallback_path = scm_from_locale_string (buf); } - + cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath); } #endif /* SCM_LIBRARY_DIR */ @@ -624,10 +631,10 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args) } static SCM -scm_try_autocompile (SCM source, SCM stale_compiled) +scm_try_autocompile (SCM source, SCM compiled) { static int message_shown = 0; - SCM comp_mod, compiled_file_name, new_compiled, pair; + SCM pair; if (scm_is_false (*scm_loc_load_should_autocompile)) return SCM_BOOL_F; @@ -640,36 +647,7 @@ scm_try_autocompile (SCM source, SCM stale_compiled) message_shown = 1; } - comp_mod = scm_c_resolve_module ("system base compile"); - compiled_file_name = - scm_module_variable (comp_mod, - scm_from_locale_symbol ("compiled-file-name")); - - if (scm_is_false (compiled_file_name)) - { - scm_puts (";;; it seems ", scm_current_error_port ()); - scm_display (source, scm_current_error_port ()); - scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n", - scm_current_error_port ()); - return SCM_BOOL_F; - } - - new_compiled = scm_call_1 (scm_variable_ref (compiled_file_name), source); - - if (scm_is_false (new_compiled)) - return SCM_BOOL_F; - else if (!scm_is_true (scm_equal_p (new_compiled, stale_compiled)) - && scm_is_true (scm_stat (new_compiled, SCM_BOOL_F)) - && compiled_is_newer (source, new_compiled)) - { - scm_puts (";;; found compiled file elsewhere: ", - scm_current_error_port ()); - scm_display (new_compiled, scm_current_error_port ()); - scm_newline (scm_current_error_port ()); - return new_compiled; - } - - pair = scm_cons (source, new_compiled); + pair = scm_cons (source, compiled); return scm_c_catch (SCM_BOOL_T, do_try_autocompile, SCM2PTR (pair), @@ -699,6 +677,31 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, *scm_loc_load_compiled_extensions, SCM_BOOL_T); + if (scm_is_false (compiled_filename) + && scm_is_true (full_filename) + && scm_is_true (*scm_loc_compile_fallback_path)) + { + SCM comp_mod, compiled_file_name; + + comp_mod = scm_c_resolve_module ("system base compile"); + compiled_file_name = + scm_module_variable (comp_mod, + scm_from_locale_symbol ("compiled-file-name")); + + if (scm_is_false (compiled_file_name)) + { + scm_puts (";;; it seems ", scm_current_error_port ()); + scm_display (full_filename, scm_current_error_port ()); + scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n", + scm_current_error_port ()); + return SCM_BOOL_F; + } + + /* very confusing var names ... */ + compiled_filename = scm_call_1 (scm_variable_ref (compiled_file_name), + full_filename); + } + if (scm_is_false (full_filename) && scm_is_false (compiled_filename)) { if (scm_is_true (exception_on_not_found)) @@ -713,7 +716,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, && compiled_is_newer (full_filename, compiled_filename))) return scm_load_compiled_with_vm (compiled_filename); - compiled_filename = scm_try_autocompile (full_filename, compiled_filename); + if (scm_is_true (compiled_filename)) + compiled_filename = scm_try_autocompile (full_filename, compiled_filename); + if (scm_is_true (compiled_filename)) return scm_load_compiled_with_vm (compiled_filename); else @@ -765,6 +770,9 @@ scm_init_load () scm_list_1 (scm_from_locale_string (".go")))); scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); + scm_loc_compile_fallback_path + = SCM_VARIABLE_LOC (scm_c_define ("%compile-fallback-path", SCM_BOOL_F)); + scm_loc_load_should_autocompile = SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F)); diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index d5933edad..77a3fe1b5 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -108,48 +108,40 @@ (stable-sort (map (lambda (x) (cons (key x) x)) list) (lambda (x y) (less (car x) (car y)))))) +;;; This function is among the trickiest I've ever written. I tried many +;;; variants. In the end, simple is best, of course. +;;; +;;; After turning this around a number of times, it seems that the the +;;; desired behavior is that .go files should exist in a path, for +;;; searching. That is orthogonal to this function. For writing .go +;;; files, either you know where they should go, in which case you pass +;;; the path directly, assuming they will end up in the path, as in the +;;; srcdir != builddir case; or you don't know, in which case this +;;; function is called, and we just put them in your own ccache dir in +;;; ~/.guile-ccache. (define (compiled-file-name file) - (let ((cext (cond ((or (null? %load-compiled-extensions) - (string-null? (car %load-compiled-extensions))) - (warn "invalid %load-compiled-extensions" - %load-compiled-extensions) - ".go") - (else (car %load-compiled-extensions))))) - (define (strip-source-extension path) - (let lp ((exts %load-extensions)) - (cond ((null? exts) file) - ((string-null? (car exts)) (lp (cdr exts))) - ((string-suffix? (car exts) path) - (substring path 0 - (- (string-length path) - (string-length (car exts))))) - (else (lp (cdr exts)))))) - ;; there is some trickery here. if no %load-compiled-path is a - ;; prefix of `file', the stability of the sort makes us end up - ;; trying to write first to last dir in the path, which is usually - ;; the $HOME ccache dir. - (let lp ((paths (dsu-sort (reverse %load-compiled-path) - (lambda (x) - (if (string-prefix? x file) - (string-length x) - 0)) - >))) - (if (null? paths) - (error "no writable path when compiling" file) - (let ((rpath (in-vicinity - (car paths) - (string-append - (strip-source-extension - (if (string-prefix? (car paths) file) - (substring file (1+ (string-length (car paths)))) - (substring file 1))) - cext)))) - (if (and (false-if-exception - (ensure-writable-dir (dirname rpath))) - (or (not (file-exists? rpath)) - (access? rpath W_OK))) - rpath - (lp (cdr paths)))))))) + (define (strip-source-extension path) + (let lp ((exts %load-extensions)) + (cond ((null? exts) file) + ((string-null? (car exts)) (lp (cdr exts))) + ((string-suffix? (car exts) path) + (substring path 0 + (- (string-length path) + (string-length (car exts))))) + (else (lp (cdr exts)))))) + (define (compiled-extension) + (cond ((or (null? %load-compiled-extensions) + (string-null? (car %load-compiled-extensions))) + (warn "invalid %load-compiled-extensions" + %load-compiled-extensions) + ".go") + (else (car %load-compiled-extensions)))) + (and %compile-fallback-path + (let ((f (string-append %compile-fallback-path "/" + (strip-source-extension file) + (compiled-extension)))) + (and (false-if-exception (ensure-writable-dir (dirname f))) + f)))) (define* (compile-file file #:key (output-file #f) From 3c997c4ba9862b9f9bd19aac3d6ac866b2b42a77 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 10:06:39 +0200 Subject: [PATCH 187/375] simplify autocompilation some more * libguile/load.c (scm_init_load_path): Set the fallback path even if GUILE_SYSTEM_COMPILED_PATH is set. Now that we store full paths in the autocompiled files, and the path contains the effective Guile version, there's no danger of accidental collisions. (do_try_autocompile, autocompile_catch_handler, scm_try_autocompile): Simplify again -- since there's only one place we put autocompiled files, and compile-file finds it itself, there's no need to pass along the compiled file path. (scm_primitive_load_path): Don't call out to compiled-file-name to get the fallback path, as we might not be autocompiling, and besides that we need to check if the file exists at all. * module/system/base/compile.scm (compiled-file-name): Simplify again. The auto-compiled path is just fallback path + full source path + .go. --- libguile/load.c | 140 +++++++++++++++------------------ module/system/base/compile.scm | 23 ++---- 2 files changed, 71 insertions(+), 92 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index f54015bc5..9746c14a1 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -241,34 +241,31 @@ scm_init_load_path () else if (env) cpath = scm_parse_path (scm_from_locale_string (env), cpath); else - { - /* the idea: if GUILE_SYSTEM_COMPILED_PATH is set, then it seems we're working - against an uninstalled Guile, in which case we shouldn't be autocompiling, - otherwise offer up the user's home directory as penance for not having - up-to-date .go files. */ - char *home; + cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath); - home = getenv ("HOME"); -#ifdef HAVE_GETPWENT - if (!home) - { - struct passwd *pwd; - pwd = getpwuid (getuid ()); - if (pwd) - home = pwd->pw_dir; - } -#endif /* HAVE_GETPWENT */ - if (home) - { char buf[1024]; - snprintf (buf, sizeof(buf), - "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home); - *scm_loc_compile_fallback_path = scm_from_locale_string (buf); - } - - cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath); - } #endif /* SCM_LIBRARY_DIR */ + { + char *home; + + home = getenv ("HOME"); +#ifdef HAVE_GETPWENT + if (!home) + { + struct passwd *pwd; + pwd = getpwuid (getuid ()); + if (pwd) + home = pwd->pw_dir; + } +#endif /* HAVE_GETPWENT */ + if (home) + { char buf[1024]; + snprintf (buf, sizeof(buf), + "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home); + *scm_loc_compile_fallback_path = scm_from_locale_string (buf); + } + } + env = getenv ("GUILE_LOAD_PATH"); if (env) path = scm_parse_path (scm_from_locale_string (env), path); @@ -582,45 +579,50 @@ compiled_is_newer (SCM full_filename, SCM compiled_filename) scm_puts (compiled, scm_current_error_port ()); scm_puts ("\n", scm_current_error_port ()); res = 0; - } + free (source); free (compiled); return res; } -SCM_KEYWORD (k_output_file, "output-file"); - static SCM do_try_autocompile (void *data) { - SCM pair = PTR2SCM (data); - SCM comp_mod, compile_file, res; + SCM source = PTR2SCM (data); + SCM comp_mod, compile_file; scm_puts (";;; compiling ", scm_current_error_port ()); - scm_display (scm_car (pair), scm_current_error_port ()); + scm_display (source, scm_current_error_port ()); scm_newline (scm_current_error_port ()); comp_mod = scm_c_resolve_module ("system base compile"); compile_file = scm_c_module_lookup (comp_mod, "compile-file"); - res = scm_call_3 (scm_variable_ref (compile_file), scm_car (pair), - k_output_file, scm_cdr (pair)); - scm_puts (";;; compiled ", scm_current_error_port ()); - scm_display (res, scm_current_error_port ()); - scm_newline (scm_current_error_port ()); - - return res; + if (scm_is_true (compile_file)) + { + SCM res = scm_call_1 (scm_variable_ref (compile_file), source); + scm_puts (";;; compiled ", scm_current_error_port ()); + scm_display (res, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + return res; + } + else + { + scm_puts (";;; it seems ", scm_current_error_port ()); + scm_display (source, scm_current_error_port ()); + scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n", + scm_current_error_port ()); + return SCM_BOOL_F; + } } static SCM autocompile_catch_handler (void *data, SCM tag, SCM throw_args) { - SCM pair = PTR2SCM (data); + SCM source = PTR2SCM (data); scm_puts (";;; WARNING: compilation of ", scm_current_error_port ()); - scm_display (scm_car (pair), scm_current_error_port ()); - scm_puts ("\n;;; to ", scm_current_error_port ()); - scm_display (scm_cdr (pair), scm_current_error_port ()); + scm_display (source, scm_current_error_port ()); scm_puts (" failed:\n", scm_current_error_port ()); scm_puts (";;; key ", scm_current_error_port ()); scm_write (tag, scm_current_error_port ()); @@ -631,10 +633,9 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args) } static SCM -scm_try_autocompile (SCM source, SCM compiled) +scm_try_autocompile (SCM source) { static int message_shown = 0; - SCM pair; if (scm_is_false (*scm_loc_load_should_autocompile)) return SCM_BOOL_F; @@ -647,12 +648,11 @@ scm_try_autocompile (SCM source, SCM compiled) message_shown = 1; } - pair = scm_cons (source, compiled); return scm_c_catch (SCM_BOOL_T, do_try_autocompile, - SCM2PTR (pair), + SCM2PTR (source), autocompile_catch_handler, - SCM2PTR (pair), + SCM2PTR (source), NULL, NULL); } @@ -676,30 +676,19 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, filename, *scm_loc_load_compiled_extensions, SCM_BOOL_T); - + if (scm_is_false (compiled_filename) && scm_is_true (full_filename) - && scm_is_true (*scm_loc_compile_fallback_path)) + && scm_is_true (*scm_loc_compile_fallback_path) + && scm_is_pair (*scm_loc_load_compiled_extensions) + && scm_is_string (scm_car (*scm_loc_load_compiled_extensions))) { - SCM comp_mod, compiled_file_name; - - comp_mod = scm_c_resolve_module ("system base compile"); - compiled_file_name = - scm_module_variable (comp_mod, - scm_from_locale_symbol ("compiled-file-name")); - - if (scm_is_false (compiled_file_name)) - { - scm_puts (";;; it seems ", scm_current_error_port ()); - scm_display (full_filename, scm_current_error_port ()); - scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n", - scm_current_error_port ()); - return SCM_BOOL_F; - } - - /* very confusing var names ... */ - compiled_filename = scm_call_1 (scm_variable_ref (compiled_file_name), - full_filename); + SCM fallback = scm_string_append + (scm_list_3 (*scm_loc_compile_fallback_path, + full_filename, + scm_car (*scm_loc_load_compiled_extensions))); + if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))) + compiled_filename = fallback; } if (scm_is_false (full_filename) && scm_is_false (compiled_filename)) @@ -715,14 +704,15 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, || (scm_is_true (compiled_filename) && compiled_is_newer (full_filename, compiled_filename))) return scm_load_compiled_with_vm (compiled_filename); + else + { + SCM freshly_compiled = scm_try_autocompile (full_filename); - if (scm_is_true (compiled_filename)) - compiled_filename = scm_try_autocompile (full_filename, compiled_filename); - - if (scm_is_true (compiled_filename)) - return scm_load_compiled_with_vm (compiled_filename); - else - return scm_primitive_load (full_filename); + if (scm_is_true (freshly_compiled)) + return scm_load_compiled_with_vm (freshly_compiled); + else + return scm_primitive_load (full_filename); + } } #undef FUNC_NAME diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 77a3fe1b5..b0c20cfff 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -114,21 +114,11 @@ ;;; After turning this around a number of times, it seems that the the ;;; desired behavior is that .go files should exist in a path, for ;;; searching. That is orthogonal to this function. For writing .go -;;; files, either you know where they should go, in which case you pass -;;; the path directly, assuming they will end up in the path, as in the -;;; srcdir != builddir case; or you don't know, in which case this -;;; function is called, and we just put them in your own ccache dir in -;;; ~/.guile-ccache. +;;; files, either you know where they should go, in which case you tell +;;; compile-file explicitly, as in the srcdir != builddir case; or you +;;; don't know, in which case this function is called, and we just put +;;; them in your own ccache dir in ~/.guile-ccache. (define (compiled-file-name file) - (define (strip-source-extension path) - (let lp ((exts %load-extensions)) - (cond ((null? exts) file) - ((string-null? (car exts)) (lp (cdr exts))) - ((string-suffix? (car exts) path) - (substring path 0 - (- (string-length path) - (string-length (car exts))))) - (else (lp (cdr exts)))))) (define (compiled-extension) (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) @@ -137,9 +127,8 @@ ".go") (else (car %load-compiled-extensions)))) (and %compile-fallback-path - (let ((f (string-append %compile-fallback-path "/" - (strip-source-extension file) - (compiled-extension)))) + (let ((f (string-append + %compile-fallback-path "/" file (compiled-extension)))) (and (false-if-exception (ensure-writable-dir (dirname f))) f)))) From 628132c5acfb804e798a6a240a0333587831f837 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 10:24:35 +0200 Subject: [PATCH 188/375] final (?) tweaks to the autocompile code * libguile/load.c (do_try_autocompile): Use module_variable, not module_lookup, when resolving compile-file, so we get #f instead of an exception if the compiler is in the process of being loaded. (scm_primitive_load_path): In what I hope is the last patch to this code, recheck the fallback path if we found a stale installed .go file. --- libguile/load.c | 46 +++++++++++++++++++++++++++++++++++++--------- 1 file changed, 37 insertions(+), 9 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 9746c14a1..6c2cd92be 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -597,7 +597,8 @@ do_try_autocompile (void *data) scm_newline (scm_current_error_port ()); comp_mod = scm_c_resolve_module ("system base compile"); - compile_file = scm_c_module_lookup (comp_mod, "compile-file"); + compile_file = scm_module_variable + (comp_mod, scm_from_locale_symbol ("compile-file")); if (scm_is_true (compile_file)) { @@ -667,6 +668,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, #define FUNC_NAME s_scm_primitive_load_path { SCM full_filename, compiled_filename; + int compiled_is_fallback = 0; if (SCM_UNBNDP (exception_on_not_found)) exception_on_not_found = SCM_BOOL_T; @@ -688,7 +690,10 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, full_filename, scm_car (*scm_loc_load_compiled_extensions))); if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))) - compiled_filename = fallback; + { + compiled_filename = fallback; + compiled_is_fallback = 1; + } } if (scm_is_false (full_filename) && scm_is_false (compiled_filename)) @@ -704,15 +709,38 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, || (scm_is_true (compiled_filename) && compiled_is_newer (full_filename, compiled_filename))) return scm_load_compiled_with_vm (compiled_filename); - else - { - SCM freshly_compiled = scm_try_autocompile (full_filename); - if (scm_is_true (freshly_compiled)) - return scm_load_compiled_with_vm (freshly_compiled); - else - return scm_primitive_load (full_filename); + /* Perhaps there was the installed .go that was stale, but our fallback is + fresh. Let's try that. Duplicating code, but perhaps that's OK. */ + + if (!compiled_is_fallback + && scm_is_true (*scm_loc_compile_fallback_path) + && scm_is_pair (*scm_loc_load_compiled_extensions) + && scm_is_string (scm_car (*scm_loc_load_compiled_extensions))) + { + SCM fallback = scm_string_append + (scm_list_3 (*scm_loc_compile_fallback_path, + full_filename, + scm_car (*scm_loc_load_compiled_extensions))); + if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)) + && compiled_is_newer (full_filename, fallback)) + { + scm_puts (";;; found fresh local cache at ", scm_current_error_port ()); + scm_display (fallback, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + return scm_load_compiled_with_vm (compiled_filename); + } } + + /* Otherwise, we bottom out here. */ + { + SCM freshly_compiled = scm_try_autocompile (full_filename); + + if (scm_is_true (freshly_compiled)) + return scm_load_compiled_with_vm (freshly_compiled); + else + return scm_primitive_load (full_filename); + } } #undef FUNC_NAME From 822aacbcf4167a860c3d6bca2692ef88f5f6ef3e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 10:32:52 +0200 Subject: [PATCH 189/375] compile and install srfi-98. * module/Makefile.am (SRFI_SOURCES): Add SRFI-98. --- module/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/Makefile.am b/module/Makefile.am index 9d9a839a1..bcc4864e5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -211,7 +211,8 @@ SRFI_SOURCES = \ srfi/srfi-39.scm \ srfi/srfi-60.scm \ srfi/srfi-69.scm \ - srfi/srfi-88.scm + srfi/srfi-88.scm \ + srfi/srfi-98.scm RNRS_SOURCES = \ rnrs/bytevector.scm \ From 535fb833b34dfc3cc11a679d39390b06fd7e9180 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 10:51:21 +0200 Subject: [PATCH 190/375] stamp .go with timestamp of .scm; a fresh go has same mtime of .scm * libguile/load.c (compiled_is_fresh): Rename from compiled_is_newer. Check that the mtines of the .go and .scm match exactly, so we don't get fooled by rsync-like modifications of the filesystem. * module/system/base/compile.scm (call-with-output-file/atomic): Add optional arg, a reference file. If present we utime the output file to match the source file, before the rename. (compile-file): Stamp the .go file with the timestamp of the .scm. --- libguile/load.c | 8 ++++---- module/system/base/compile.scm | 8 ++++++-- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 6c2cd92be..9656359e5 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -556,7 +556,7 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, static int -compiled_is_newer (SCM full_filename, SCM compiled_filename) +compiled_is_fresh (SCM full_filename, SCM compiled_filename) { char *source, *compiled; struct stat stat_source, stat_compiled; @@ -567,7 +567,7 @@ compiled_is_newer (SCM full_filename, SCM compiled_filename) if (stat (source, &stat_source) == 0 && stat (compiled, &stat_compiled) == 0 - && stat_source.st_mtime <= stat_compiled.st_mtime) + && stat_source.st_mtime == stat_compiled.st_mtime) { res = 1; } @@ -707,7 +707,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, if (scm_is_false (full_filename) || (scm_is_true (compiled_filename) - && compiled_is_newer (full_filename, compiled_filename))) + && compiled_is_fresh (full_filename, compiled_filename))) return scm_load_compiled_with_vm (compiled_filename); /* Perhaps there was the installed .go that was stale, but our fallback is @@ -723,7 +723,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0, full_filename, scm_car (*scm_loc_load_compiled_extensions))); if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)) - && compiled_is_newer (full_filename, fallback)) + && compiled_is_fresh (full_filename, fallback)) { scm_puts (";;; found fresh local cache at ", scm_current_error_port ()); scm_display (fallback, scm_current_error_port ()); diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index b0c20cfff..9f0ff2f3d 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -73,7 +73,7 @@ thunk (lambda () #t)))) -(define (call-with-output-file/atomic filename proc) +(define* (call-with-output-file/atomic filename proc #:optional reference) (let* ((template (string-append filename ".XXXXXX")) (tmp (mkstemp! template))) (call-once @@ -83,6 +83,9 @@ (proc tmp) (chmod tmp (logand #o0666 (lognot (umask)))) (close-port tmp) + (if reference + (let ((st (stat reference))) + (utime template (stat:atime st) (stat:mtime st)))) (rename-file template filename)) (lambda args (delete-file template))))))) @@ -145,7 +148,8 @@ (lambda (port) ((language-printer (ensure-language to)) (read-and-compile in #:env env #:from from #:to to #:opts opts) - port))) + port)) + file) comp)) (define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) From 42193dac5800fe6a63d392c8b9ebb7f9257725e2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 10:56:34 +0200 Subject: [PATCH 191/375] add gperf-generated files to git * lib/iconv_open-osf.h: * lib/iconv_open-aix.h: * lib/iconv_open-hpux.h: * lib/iconv_open-irix.h: Add to git. Should remove build-time dep on gperf; we'll see if this causes problems. --- lib/iconv_open-aix.h | 256 ++++++++++++++++++++++++++++++++++++ lib/iconv_open-hpux.h | 299 ++++++++++++++++++++++++++++++++++++++++++ lib/iconv_open-irix.h | 199 ++++++++++++++++++++++++++++ lib/iconv_open-osf.h | 278 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 1032 insertions(+) create mode 100644 lib/iconv_open-aix.h create mode 100644 lib/iconv_open-hpux.h create mode 100644 lib/iconv_open-irix.h create mode 100644 lib/iconv_open-osf.h diff --git a/lib/iconv_open-aix.h b/lib/iconv_open-aix.h new file mode 100644 index 000000000..0ffc3fef1 --- /dev/null +++ b/lib/iconv_open-aix.h @@ -0,0 +1,256 @@ +/* ANSI-C code produced by gperf version 3.0.3 */ +/* Command-line: gperf -m 10 ./iconv_open-aix.gperf */ +/* Computed positions: -k'4,$' */ + +#if !((' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ + && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ + && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ + && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \ + && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \ + && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \ + && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \ + && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \ + && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \ + && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \ + && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \ + && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \ + && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \ + && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \ + && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \ + && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \ + && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \ + && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \ + && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \ + && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \ + && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \ + && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \ + && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126)) +/* The character set is not based on ISO-646. */ +#error "gperf generated tables don't work with this execution character set. Please report a bug to ." +#endif + +#line 1 "./iconv_open-aix.gperf" +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; + +#define TOTAL_KEYWORDS 32 +#define MIN_WORD_LENGTH 4 +#define MAX_WORD_LENGTH 11 +#define MIN_HASH_VALUE 6 +#define MAX_HASH_VALUE 44 +/* maximum key range = 39, duplicates = 0 */ + +#ifdef __GNUC__ +__inline +#else +#ifdef __cplusplus +inline +#endif +#endif +static unsigned int +mapping_hash (register const char *str, register unsigned int len) +{ + static const unsigned char asso_values[] = + { + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 0, 4, 25, + 0, 11, 24, 9, 17, 3, 14, 21, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 3, 45, 1, 45, 45, 45, 45, 0, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45 + }; + return len + asso_values[(unsigned char)str[3]+2] + asso_values[(unsigned char)str[len - 1]]; +} + +struct stringpool_t + { + char stringpool_str6[sizeof("EUC-TW")]; + char stringpool_str7[sizeof("EUC-KR")]; + char stringpool_str8[sizeof("CP852")]; + char stringpool_str9[sizeof("EUC-JP")]; + char stringpool_str10[sizeof("ISO-8859-2")]; + char stringpool_str11[sizeof("CP857")]; + char stringpool_str12[sizeof("CP850")]; + char stringpool_str13[sizeof("ISO-8859-7")]; + char stringpool_str14[sizeof("CP932")]; + char stringpool_str15[sizeof("GB2312")]; + char stringpool_str16[sizeof("BIG5")]; + char stringpool_str17[sizeof("CP437")]; + char stringpool_str19[sizeof("ISO-8859-5")]; + char stringpool_str20[sizeof("ISO-8859-15")]; + char stringpool_str21[sizeof("ISO-8859-3")]; + char stringpool_str22[sizeof("ISO-8859-13")]; + char stringpool_str23[sizeof("CP1046")]; + char stringpool_str24[sizeof("ISO-8859-8")]; + char stringpool_str25[sizeof("CP856")]; + char stringpool_str26[sizeof("CP1125")]; + char stringpool_str27[sizeof("ISO-8859-6")]; + char stringpool_str28[sizeof("CP865")]; + char stringpool_str29[sizeof("CP922")]; + char stringpool_str30[sizeof("CP1252")]; + char stringpool_str31[sizeof("ISO-8859-9")]; + char stringpool_str33[sizeof("CP943")]; + char stringpool_str34[sizeof("ISO-8859-4")]; + char stringpool_str35[sizeof("ISO-8859-1")]; + char stringpool_str38[sizeof("CP1129")]; + char stringpool_str40[sizeof("CP869")]; + char stringpool_str41[sizeof("CP1124")]; + char stringpool_str44[sizeof("CP861")]; + }; +static const struct stringpool_t stringpool_contents = + { + "EUC-TW", + "EUC-KR", + "CP852", + "EUC-JP", + "ISO-8859-2", + "CP857", + "CP850", + "ISO-8859-7", + "CP932", + "GB2312", + "BIG5", + "CP437", + "ISO-8859-5", + "ISO-8859-15", + "ISO-8859-3", + "ISO-8859-13", + "CP1046", + "ISO-8859-8", + "CP856", + "CP1125", + "ISO-8859-6", + "CP865", + "CP922", + "CP1252", + "ISO-8859-9", + "CP943", + "ISO-8859-4", + "ISO-8859-1", + "CP1129", + "CP869", + "CP1124", + "CP861" + }; +#define stringpool ((const char *) &stringpool_contents) + +static const struct mapping mappings[] = + { + {-1}, {-1}, {-1}, {-1}, {-1}, {-1}, +#line 43 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str6, "IBM-eucTW"}, +#line 42 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str7, "IBM-eucKR"}, +#line 25 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str8, "IBM-852"}, +#line 41 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str9, "IBM-eucJP"}, +#line 14 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str10, "ISO8859-2"}, +#line 27 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str11, "IBM-857"}, +#line 24 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str12, "IBM-850"}, +#line 19 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str13, "ISO8859-7"}, +#line 33 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str14, "IBM-932"}, +#line 40 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str15, "IBM-eucCN"}, +#line 44 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str16, "big5"}, +#line 23 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str17, "IBM-437"}, + {-1}, +#line 17 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str19, "ISO8859-5"}, +#line 22 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str20, "ISO8859-15"}, +#line 15 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str21, "ISO8859-3"}, +#line 31 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str22, "IBM-921"}, +#line 35 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str23, "IBM-1046"}, +#line 20 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str24, "ISO8859-8"}, +#line 26 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str25, "IBM-856"}, +#line 37 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str26, "IBM-1125"}, +#line 18 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str27, "ISO8859-6"}, +#line 29 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str28, "IBM-865"}, +#line 32 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str29, "IBM-922"}, +#line 39 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str30, "IBM-1252"}, +#line 21 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str31, "ISO8859-9"}, + {-1}, +#line 34 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str33, "IBM-943"}, +#line 16 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str34, "ISO8859-4"}, +#line 13 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str35, "ISO8859-1"}, + {-1}, {-1}, +#line 38 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str38, "IBM-1129"}, + {-1}, +#line 30 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str40, "IBM-869"}, +#line 36 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str41, "IBM-1124"}, + {-1}, {-1}, +#line 28 "./iconv_open-aix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str44, "IBM-861"} + }; + +#ifdef __GNUC__ +__inline +#ifdef __GNUC_STDC_INLINE__ +__attribute__ ((__gnu_inline__)) +#endif +#endif +const struct mapping * +mapping_lookup (register const char *str, register unsigned int len) +{ + if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH) + { + register int key = mapping_hash (str, len); + + if (key <= MAX_HASH_VALUE && key >= 0) + { + register int o = mappings[key].standard_name; + if (o >= 0) + { + register const char *s = o + stringpool; + + if (*str == *s && !strcmp (str + 1, s + 1)) + return &mappings[key]; + } + } + } + return 0; +} diff --git a/lib/iconv_open-hpux.h b/lib/iconv_open-hpux.h new file mode 100644 index 000000000..8f9f0a9ad --- /dev/null +++ b/lib/iconv_open-hpux.h @@ -0,0 +1,299 @@ +/* ANSI-C code produced by gperf version 3.0.3 */ +/* Command-line: gperf -m 10 ./iconv_open-hpux.gperf */ +/* Computed positions: -k'4,$' */ + +#if !((' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ + && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ + && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ + && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \ + && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \ + && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \ + && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \ + && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \ + && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \ + && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \ + && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \ + && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \ + && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \ + && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \ + && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \ + && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \ + && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \ + && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \ + && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \ + && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \ + && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \ + && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \ + && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126)) +/* The character set is not based on ISO-646. */ +#error "gperf generated tables don't work with this execution character set. Please report a bug to ." +#endif + +#line 1 "./iconv_open-hpux.gperf" +struct mapping { int standard_name; const char vendor_name[9 + 1]; }; + +#define TOTAL_KEYWORDS 44 +#define MIN_WORD_LENGTH 4 +#define MAX_WORD_LENGTH 11 +#define MIN_HASH_VALUE 6 +#define MAX_HASH_VALUE 49 +/* maximum key range = 44, duplicates = 0 */ + +#ifdef __GNUC__ +__inline +#else +#ifdef __cplusplus +inline +#endif +#endif +static unsigned int +mapping_hash (register const char *str, register unsigned int len) +{ + static const unsigned char asso_values[] = + { + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 1, 2, + 24, 43, 5, 10, 0, 13, 32, 3, 19, 18, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 5, + 50, 50, 50, 50, 14, 5, 0, 50, 50, 0, + 27, 50, 12, 14, 50, 50, 0, 5, 2, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50 + }; + return len + asso_values[(unsigned char)str[3]+4] + asso_values[(unsigned char)str[len - 1]]; +} + +struct stringpool_t + { + char stringpool_str6[sizeof("CP1256")]; + char stringpool_str7[sizeof("CP1250")]; + char stringpool_str8[sizeof("CP1251")]; + char stringpool_str9[sizeof("CP850")]; + char stringpool_str10[sizeof("TIS-620")]; + char stringpool_str11[sizeof("CP1254")]; + char stringpool_str12[sizeof("ISO-8859-6")]; + char stringpool_str13[sizeof("EUC-TW")]; + char stringpool_str14[sizeof("ISO-8859-1")]; + char stringpool_str15[sizeof("ISO-8859-9")]; + char stringpool_str16[sizeof("CP1255")]; + char stringpool_str17[sizeof("BIG5")]; + char stringpool_str18[sizeof("CP855")]; + char stringpool_str19[sizeof("CP1257")]; + char stringpool_str20[sizeof("EUC-KR")]; + char stringpool_str21[sizeof("CP857")]; + char stringpool_str22[sizeof("ISO-8859-5")]; + char stringpool_str23[sizeof("ISO-8859-15")]; + char stringpool_str24[sizeof("CP866")]; + char stringpool_str25[sizeof("ISO-8859-7")]; + char stringpool_str26[sizeof("CP861")]; + char stringpool_str27[sizeof("CP869")]; + char stringpool_str28[sizeof("CP874")]; + char stringpool_str29[sizeof("CP864")]; + char stringpool_str30[sizeof("CP1252")]; + char stringpool_str31[sizeof("CP437")]; + char stringpool_str32[sizeof("CP852")]; + char stringpool_str33[sizeof("CP775")]; + char stringpool_str34[sizeof("CP865")]; + char stringpool_str35[sizeof("EUC-JP")]; + char stringpool_str36[sizeof("ISO-8859-2")]; + char stringpool_str37[sizeof("SHIFT_JIS")]; + char stringpool_str38[sizeof("CP1258")]; + char stringpool_str39[sizeof("UTF-8")]; + char stringpool_str40[sizeof("HP-KANA8")]; + char stringpool_str41[sizeof("HP-ROMAN8")]; + char stringpool_str42[sizeof("HP-HEBREW8")]; + char stringpool_str43[sizeof("GB2312")]; + char stringpool_str44[sizeof("ISO-8859-8")]; + char stringpool_str45[sizeof("HP-TURKISH8")]; + char stringpool_str46[sizeof("HP-GREEK8")]; + char stringpool_str47[sizeof("HP-ARABIC8")]; + char stringpool_str48[sizeof("CP862")]; + char stringpool_str49[sizeof("CP1253")]; + }; +static const struct stringpool_t stringpool_contents = + { + "CP1256", + "CP1250", + "CP1251", + "CP850", + "TIS-620", + "CP1254", + "ISO-8859-6", + "EUC-TW", + "ISO-8859-1", + "ISO-8859-9", + "CP1255", + "BIG5", + "CP855", + "CP1257", + "EUC-KR", + "CP857", + "ISO-8859-5", + "ISO-8859-15", + "CP866", + "ISO-8859-7", + "CP861", + "CP869", + "CP874", + "CP864", + "CP1252", + "CP437", + "CP852", + "CP775", + "CP865", + "EUC-JP", + "ISO-8859-2", + "SHIFT_JIS", + "CP1258", + "UTF-8", + "HP-KANA8", + "HP-ROMAN8", + "HP-HEBREW8", + "GB2312", + "ISO-8859-8", + "HP-TURKISH8", + "HP-GREEK8", + "HP-ARABIC8", + "CP862", + "CP1253" + }; +#define stringpool ((const char *) &stringpool_contents) + +static const struct mapping mappings[] = + { + {-1}, {-1}, {-1}, {-1}, {-1}, {-1}, +#line 40 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str6, "cp1256"}, +#line 34 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str7, "cp1250"}, +#line 35 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str8, "cp1251"}, +#line 23 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str9, "cp850"}, +#line 49 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str10, "tis620"}, +#line 38 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str11, "cp1254"}, +#line 16 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str12, "iso88596"}, +#line 53 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str13, "eucTW"}, +#line 13 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str14, "iso88591"}, +#line 19 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str15, "iso88599"}, +#line 39 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str16, "cp1255"}, +#line 54 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str17, "big5"}, +#line 25 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str18, "cp855"}, +#line 41 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str19, "cp1257"}, +#line 52 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str20, "eucKR"}, +#line 26 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str21, "cp857"}, +#line 15 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str22, "iso88595"}, +#line 20 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str23, "iso885915"}, +#line 31 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str24, "cp866"}, +#line 17 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str25, "iso88597"}, +#line 27 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str26, "cp861"}, +#line 32 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str27, "cp869"}, +#line 33 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str28, "cp874"}, +#line 29 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str29, "cp864"}, +#line 36 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str30, "cp1252"}, +#line 21 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str31, "cp437"}, +#line 24 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str32, "cp852"}, +#line 22 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str33, "cp775"}, +#line 30 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str34, "cp865"}, +#line 51 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str35, "eucJP"}, +#line 14 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str36, "iso88592"}, +#line 55 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str37, "sjis"}, +#line 42 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str38, "cp1258"}, +#line 56 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str39, "utf8"}, +#line 48 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str40, "kana8"}, +#line 43 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str41, "roman8"}, +#line 46 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str42, "hebrew8"}, +#line 50 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str43, "hp15CN"}, +#line 18 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str44, "iso88598"}, +#line 47 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str45, "turkish8"}, +#line 45 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str46, "greek8"}, +#line 44 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str47, "arabic8"}, +#line 28 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str48, "cp862"}, +#line 37 "./iconv_open-hpux.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str49, "cp1253"} + }; + +#ifdef __GNUC__ +__inline +#ifdef __GNUC_STDC_INLINE__ +__attribute__ ((__gnu_inline__)) +#endif +#endif +const struct mapping * +mapping_lookup (register const char *str, register unsigned int len) +{ + if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH) + { + register int key = mapping_hash (str, len); + + if (key <= MAX_HASH_VALUE && key >= 0) + { + register int o = mappings[key].standard_name; + if (o >= 0) + { + register const char *s = o + stringpool; + + if (*str == *s && !strcmp (str + 1, s + 1)) + return &mappings[key]; + } + } + } + return 0; +} diff --git a/lib/iconv_open-irix.h b/lib/iconv_open-irix.h new file mode 100644 index 000000000..520582e52 --- /dev/null +++ b/lib/iconv_open-irix.h @@ -0,0 +1,199 @@ +/* ANSI-C code produced by gperf version 3.0.3 */ +/* Command-line: gperf -m 10 ./iconv_open-irix.gperf */ +/* Computed positions: -k'1,$' */ + +#if !((' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ + && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ + && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ + && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \ + && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \ + && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \ + && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \ + && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \ + && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \ + && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \ + && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \ + && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \ + && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \ + && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \ + && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \ + && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \ + && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \ + && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \ + && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \ + && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \ + && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \ + && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \ + && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126)) +/* The character set is not based on ISO-646. */ +#error "gperf generated tables don't work with this execution character set. Please report a bug to ." +#endif + +#line 1 "./iconv_open-irix.gperf" +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; + +#define TOTAL_KEYWORDS 19 +#define MIN_WORD_LENGTH 5 +#define MAX_WORD_LENGTH 11 +#define MIN_HASH_VALUE 5 +#define MAX_HASH_VALUE 23 +/* maximum key range = 19, duplicates = 0 */ + +#ifdef __GNUC__ +__inline +#else +#ifdef __cplusplus +inline +#endif +#endif +static unsigned int +mapping_hash (register const char *str, register unsigned int len) +{ + static const unsigned char asso_values[] = + { + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 8, 2, + 5, 12, 11, 0, 10, 9, 8, 7, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 0, 24, 0, + 24, 5, 24, 0, 24, 7, 24, 24, 24, 24, + 7, 24, 1, 0, 8, 24, 24, 0, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24 + }; + return len + asso_values[(unsigned char)str[len - 1]] + asso_values[(unsigned char)str[0]]; +} + +struct stringpool_t + { + char stringpool_str5[sizeof("CP855")]; + char stringpool_str6[sizeof("EUC-TW")]; + char stringpool_str7[sizeof("EUC-KR")]; + char stringpool_str8[sizeof("CP1251")]; + char stringpool_str9[sizeof("SHIFT_JIS")]; + char stringpool_str10[sizeof("ISO-8859-5")]; + char stringpool_str11[sizeof("ISO-8859-15")]; + char stringpool_str12[sizeof("ISO-8859-1")]; + char stringpool_str13[sizeof("EUC-JP")]; + char stringpool_str14[sizeof("KOI8-R")]; + char stringpool_str15[sizeof("ISO-8859-2")]; + char stringpool_str16[sizeof("GB2312")]; + char stringpool_str17[sizeof("ISO-8859-9")]; + char stringpool_str18[sizeof("ISO-8859-8")]; + char stringpool_str19[sizeof("ISO-8859-7")]; + char stringpool_str20[sizeof("ISO-8859-6")]; + char stringpool_str21[sizeof("ISO-8859-4")]; + char stringpool_str22[sizeof("ISO-8859-3")]; + char stringpool_str23[sizeof("TIS-620")]; + }; +static const struct stringpool_t stringpool_contents = + { + "CP855", + "EUC-TW", + "EUC-KR", + "CP1251", + "SHIFT_JIS", + "ISO-8859-5", + "ISO-8859-15", + "ISO-8859-1", + "EUC-JP", + "KOI8-R", + "ISO-8859-2", + "GB2312", + "ISO-8859-9", + "ISO-8859-8", + "ISO-8859-7", + "ISO-8859-6", + "ISO-8859-4", + "ISO-8859-3", + "TIS-620" + }; +#define stringpool ((const char *) &stringpool_contents) + +static const struct mapping mappings[] = + { + {-1}, {-1}, {-1}, {-1}, {-1}, +#line 24 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str5, "DOS855"}, +#line 29 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str6, "eucTW"}, +#line 28 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str7, "eucKR"}, +#line 25 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str8, "WIN1251"}, +#line 30 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str9, "sjis"}, +#line 17 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str10, "ISO8859-5"}, +#line 22 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str11, "ISO8859-15"}, +#line 13 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str12, "ISO8859-1"}, +#line 27 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str13, "eucJP"}, +#line 23 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str14, "KOI8"}, +#line 14 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str15, "ISO8859-2"}, +#line 26 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str16, "eucCN"}, +#line 21 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str17, "ISO8859-9"}, +#line 20 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str18, "ISO8859-8"}, +#line 19 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str19, "ISO8859-7"}, +#line 18 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str20, "ISO8859-6"}, +#line 16 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str21, "ISO8859-4"}, +#line 15 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str22, "ISO8859-3"}, +#line 31 "./iconv_open-irix.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str23, "TIS620"} + }; + +#ifdef __GNUC__ +__inline +#ifdef __GNUC_STDC_INLINE__ +__attribute__ ((__gnu_inline__)) +#endif +#endif +const struct mapping * +mapping_lookup (register const char *str, register unsigned int len) +{ + if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH) + { + register int key = mapping_hash (str, len); + + if (key <= MAX_HASH_VALUE && key >= 0) + { + register int o = mappings[key].standard_name; + if (o >= 0) + { + register const char *s = o + stringpool; + + if (*str == *s && !strcmp (str + 1, s + 1)) + return &mappings[key]; + } + } + } + return 0; +} diff --git a/lib/iconv_open-osf.h b/lib/iconv_open-osf.h new file mode 100644 index 000000000..85e4c0f8f --- /dev/null +++ b/lib/iconv_open-osf.h @@ -0,0 +1,278 @@ +/* ANSI-C code produced by gperf version 3.0.3 */ +/* Command-line: gperf -m 10 ./iconv_open-osf.gperf */ +/* Computed positions: -k'4,$' */ + +#if !((' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ + && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ + && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ + && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \ + && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \ + && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \ + && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \ + && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \ + && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \ + && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \ + && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \ + && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \ + && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \ + && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \ + && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \ + && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \ + && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \ + && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \ + && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \ + && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \ + && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \ + && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \ + && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126)) +/* The character set is not based on ISO-646. */ +#error "gperf generated tables don't work with this execution character set. Please report a bug to ." +#endif + +#line 1 "./iconv_open-osf.gperf" +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; + +#define TOTAL_KEYWORDS 38 +#define MIN_WORD_LENGTH 4 +#define MAX_WORD_LENGTH 11 +#define MIN_HASH_VALUE 6 +#define MAX_HASH_VALUE 47 +/* maximum key range = 42, duplicates = 0 */ + +#ifdef __GNUC__ +__inline +#else +#ifdef __cplusplus +inline +#endif +#endif +static unsigned int +mapping_hash (register const char *str, register unsigned int len) +{ + static const unsigned char asso_values[] = + { + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 2, 29, + 24, 34, 31, 0, 15, 14, 10, 13, 2, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 7, 48, 48, 48, 48, 48, 48, + 11, 48, 2, 7, 48, 48, 48, 1, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, + 48, 48, 48, 48, 48, 48, 48, 48, 48 + }; + return len + asso_values[(unsigned char)str[3]+3] + asso_values[(unsigned char)str[len - 1]]; +} + +struct stringpool_t + { + char stringpool_str6[sizeof("CP1255")]; + char stringpool_str7[sizeof("CP775")]; + char stringpool_str8[sizeof("CP1250")]; + char stringpool_str9[sizeof("EUC-TW")]; + char stringpool_str10[sizeof("EUC-KR")]; + char stringpool_str11[sizeof("TIS-620")]; + char stringpool_str12[sizeof("ISO-8859-5")]; + char stringpool_str13[sizeof("ISO-8859-15")]; + char stringpool_str14[sizeof("BIG5")]; + char stringpool_str15[sizeof("CP855")]; + char stringpool_str16[sizeof("CP1258")]; + char stringpool_str17[sizeof("CP850")]; + char stringpool_str18[sizeof("CP865")]; + char stringpool_str19[sizeof("EUC-JP")]; + char stringpool_str20[sizeof("CP1257")]; + char stringpool_str21[sizeof("CP1256")]; + char stringpool_str22[sizeof("ISO-8859-8")]; + char stringpool_str23[sizeof("SHIFT_JIS")]; + char stringpool_str25[sizeof("ISO-8859-9")]; + char stringpool_str26[sizeof("ISO-8859-7")]; + char stringpool_str27[sizeof("ISO-8859-6")]; + char stringpool_str29[sizeof("CP857")]; + char stringpool_str30[sizeof("CP1252")]; + char stringpool_str31[sizeof("CP869")]; + char stringpool_str32[sizeof("CP949")]; + char stringpool_str33[sizeof("CP866")]; + char stringpool_str34[sizeof("CP437")]; + char stringpool_str35[sizeof("CP1251")]; + char stringpool_str36[sizeof("ISO-8859-2")]; + char stringpool_str37[sizeof("CP1254")]; + char stringpool_str38[sizeof("CP874")]; + char stringpool_str39[sizeof("CP852")]; + char stringpool_str40[sizeof("CP1253")]; + char stringpool_str41[sizeof("ISO-8859-1")]; + char stringpool_str42[sizeof("CP862")]; + char stringpool_str43[sizeof("ISO-8859-4")]; + char stringpool_str46[sizeof("ISO-8859-3")]; + char stringpool_str47[sizeof("CP861")]; + }; +static const struct stringpool_t stringpool_contents = + { + "CP1255", + "CP775", + "CP1250", + "EUC-TW", + "EUC-KR", + "TIS-620", + "ISO-8859-5", + "ISO-8859-15", + "BIG5", + "CP855", + "CP1258", + "CP850", + "CP865", + "EUC-JP", + "CP1257", + "CP1256", + "ISO-8859-8", + "SHIFT_JIS", + "ISO-8859-9", + "ISO-8859-7", + "ISO-8859-6", + "CP857", + "CP1252", + "CP869", + "CP949", + "CP866", + "CP437", + "CP1251", + "ISO-8859-2", + "CP1254", + "CP874", + "CP852", + "CP1253", + "ISO-8859-1", + "CP862", + "ISO-8859-4", + "ISO-8859-3", + "CP861" + }; +#define stringpool ((const char *) &stringpool_contents) + +static const struct mapping mappings[] = + { + {-1}, {-1}, {-1}, {-1}, {-1}, {-1}, +#line 41 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str6, "cp1255"}, +#line 24 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str7, "cp775"}, +#line 36 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str8, "cp1250"}, +#line 47 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str9, "eucTW"}, +#line 46 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str10, "eucKR"}, +#line 50 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str11, "TACTIS"}, +#line 17 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str12, "ISO8859-5"}, +#line 22 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str13, "ISO8859-15"}, +#line 48 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str14, "big5"}, +#line 27 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str15, "cp855"}, +#line 44 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str16, "cp1258"}, +#line 25 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str17, "cp850"}, +#line 31 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str18, "cp865"}, +#line 45 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str19, "eucJP"}, +#line 43 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str20, "cp1257"}, +#line 42 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str21, "cp1256"}, +#line 20 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str22, "ISO8859-8"}, +#line 49 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str23, "SJIS"}, + {-1}, +#line 21 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str25, "ISO8859-9"}, +#line 19 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str26, "ISO8859-7"}, +#line 18 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str27, "ISO8859-6"}, + {-1}, +#line 28 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str29, "cp857"}, +#line 38 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str30, "cp1252"}, +#line 33 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str31, "cp869"}, +#line 35 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str32, "KSC5601"}, +#line 32 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str33, "cp866"}, +#line 23 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str34, "cp437"}, +#line 37 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str35, "cp1251"}, +#line 14 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str36, "ISO8859-2"}, +#line 40 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str37, "cp1254"}, +#line 34 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str38, "cp874"}, +#line 26 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str39, "cp852"}, +#line 39 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str40, "cp1253"}, +#line 13 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str41, "ISO8859-1"}, +#line 30 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str42, "cp862"}, +#line 16 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str43, "ISO8859-4"}, + {-1}, {-1}, +#line 15 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str46, "ISO8859-3"}, +#line 29 "./iconv_open-osf.gperf" + {(int)(long)&((struct stringpool_t *)0)->stringpool_str47, "cp861"} + }; + +#ifdef __GNUC__ +__inline +#ifdef __GNUC_STDC_INLINE__ +__attribute__ ((__gnu_inline__)) +#endif +#endif +const struct mapping * +mapping_lookup (register const char *str, register unsigned int len) +{ + if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH) + { + register int key = mapping_hash (str, len); + + if (key <= MAX_HASH_VALUE && key >= 0) + { + register int o = mappings[key].standard_name; + if (o >= 0) + { + register const char *s = o + stringpool; + + if (*str == *s && !strcmp (str + 1, s + 1)) + return &mappings[key]; + } + } + } + return 0; +} From b7393ea123eb0f27d99ba1c38bd944f78b90eb42 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 11:47:19 +0200 Subject: [PATCH 192/375] refactoring for toplevel-ref, toplevel-set, link-now * libguile/vm-i-system.c (toplevel-ref, toplevel-set) * libguile/vm-i-loader.c (link-now): * libguile/vm.c (resolve_variable): Factor out common code to a static method. The compiler can still inline it, so it shouldn't have a significant performance effect. * libguile/vm-engine.c (vm_error_no_such_module): Remove now-unused label. --- libguile/vm-engine.c | 4 --- libguile/vm-i-loader.c | 24 +------------- libguile/vm-i-system.c | 73 ++---------------------------------------- libguile/vm.c | 37 +++++++++++++++++++++ 4 files changed, 40 insertions(+), 98 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index f43f8c7fe..34764c659 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -212,10 +212,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) finish_args = SCM_EOL; goto vm_error; - vm_error_no_such_module: - err_msg = scm_from_locale_string ("VM: No such module: ~A"); - goto vm_error; - #if VM_CHECK_IP vm_error_invalid_address: err_msg = scm_from_locale_string ("VM: Invalid program address"); diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 515001d61..b231d392f 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -124,29 +124,7 @@ VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1) SCM what; POP (what); SYNC_REGISTER (); - if (SCM_LIKELY (SCM_SYMBOLP (what))) - { - PUSH (scm_lookup (what)); /* might longjmp */ - } - else - { - SCM mod; - /* compilation of @ or @@ - `what' is a three-element list: (MODNAME SYM INTERFACE?) - INTERFACE? is #t if we compiled @ or #f if we compiled @@ - */ - mod = scm_resolve_module (SCM_CAR (what)); - if (scm_is_true (SCM_CADDR (what))) - mod = scm_module_public_interface (mod); - if (SCM_FALSEP (mod)) - { - finish_args = scm_list_1 (SCM_CAR (what)); - goto vm_error_no_such_module; - } - /* might longjmp */ - PUSH (scm_module_lookup (mod, SCM_CADR (what))); - } - + PUSH (resolve_variable (what, scm_current_module ())); NEXT; } diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 42f2b1973..32b772afa 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -278,47 +278,12 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) if (!SCM_VARIABLEP (what)) { SYNC_REGISTER (); - if (SCM_LIKELY (SCM_SYMBOLP (what))) - { - SCM mod = SCM_EOL; - if (SCM_LIKELY (scm_module_system_booted_p - && scm_is_true ((mod = scm_program_module (program))))) - /* might longjmp */ - what = scm_module_lookup (mod, what); - else - { - SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); - if (scm_is_false (v)) - SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what)); - else - what = v; - } - } - else - { - SCM mod; - /* compilation of @ or @@ - `what' is a three-element list: (MODNAME SYM INTERFACE?) - INTERFACE? is #t if we compiled @ or #f if we compiled @@ - */ - mod = scm_resolve_module (SCM_CAR (what)); - if (scm_is_true (SCM_CADDR (what))) - mod = scm_module_public_interface (mod); - if (SCM_FALSEP (mod)) - { - finish_args = scm_list_1 (mod); - goto vm_error_no_such_module; - } - /* might longjmp */ - what = scm_module_lookup (mod, SCM_CADR (what)); - } - + what = resolve_variable (what, scm_program_module (program)); if (!VARIABLE_BOUNDP (what)) { finish_args = scm_list_1 (what); goto vm_error_unbound; } - OBJECT_SET (objnum, what); } @@ -367,41 +332,7 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) if (!SCM_VARIABLEP (what)) { SYNC_BEFORE_GC (); - if (SCM_LIKELY (SCM_SYMBOLP (what))) - { - SCM mod = SCM_EOL; - if (SCM_LIKELY (scm_module_system_booted_p - && scm_is_true ((mod = scm_program_module (program))))) - /* might longjmp */ - what = scm_module_lookup (mod, what); - else - { - SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); - if (scm_is_false (v)) - SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what)); - else - what = v; - } - } - else - { - SCM mod; - /* compilation of @ or @@ - `what' is a three-element list: (MODNAME SYM INTERFACE?) - INTERFACE? is #t if we compiled @ or #f if we compiled @@ - */ - mod = scm_resolve_module (SCM_CAR (what)); - if (scm_is_true (SCM_CADDR (what))) - mod = scm_module_public_interface (mod); - if (SCM_FALSEP (mod)) - { - finish_args = scm_list_1 (what); - goto vm_error_no_such_module; - } - /* might longjmp */ - what = scm_module_lookup (mod, SCM_CADR (what)); - } - + what = resolve_variable (what, scm_program_module (program)); OBJECT_SET (objnum, what); } diff --git a/libguile/vm.c b/libguile/vm.c index 081a691ff..f708b2108 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -267,6 +267,43 @@ vm_make_boot_program (long nargs) * VM */ +static SCM +resolve_variable (SCM what, SCM program_module) +{ + if (SCM_LIKELY (SCM_SYMBOLP (what))) + { + if (SCM_LIKELY (scm_module_system_booted_p + && scm_is_true (program_module))) + /* might longjmp */ + return scm_module_lookup (program_module, what); + else + { + SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + if (scm_is_false (v)) + scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what)); + else + return v; + } + } + else + { + SCM mod; + /* compilation of @ or @@ + `what' is a three-element list: (MODNAME SYM INTERFACE?) + INTERFACE? is #t if we compiled @ or #f if we compiled @@ + */ + mod = scm_resolve_module (SCM_CAR (what)); + if (scm_is_true (SCM_CADDR (what))) + mod = scm_module_public_interface (mod); + if (SCM_FALSEP (mod)) + scm_misc_error (NULL, "no such module: ~S", + scm_list_1 (SCM_CAR (what))); + /* might longjmp */ + return scm_module_lookup (mod, SCM_CADR (what)); + } +} + + #define VM_DEFAULT_STACK_SIZE (16 * 1024) #define VM_NAME vm_regular_engine From 5e89cd13c077de1419cab140590f76f92a457807 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 11:47:34 +0200 Subject: [PATCH 193/375] disable autocompilation when running guile-tools compile * module/scripts/compile.scm (compile): Disable autocompilation when running guile-tools compile. --- module/scripts/compile.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index f0294b5d6..84d235b8a 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -111,10 +111,13 @@ Compile each Guile source file FILE into a Guile object. -f, --from=LANG specify a source language other than `scheme' -t, --to=LANG specify a target language other than `objcode' +Note that autocompilation will be turned off. + Report bugs to .~%") (exit 0))) (set! %load-path (append load-path %load-path)) + (set! %load-should-autocompile #f) (if (and output-file (or (null? input-files) From a9b0f876c12bbbca9bdf1890eb014a30f004d9f8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 12:08:02 +0200 Subject: [PATCH 194/375] add long-object-ref, long-toplevel-ref, long-toplevel-set * libguile/vm-i-system.c (long-object-ref, long-toplevel-ref) (long-toplevel-set): Add new instructions, for accessing the object table with a 16-bit offset. HTMLprag defines a test program that has more than 256 constants, necessitating this addition. * doc/ref/vm.texi: Mention the new instructions. * module/language/glil/compile-assembly.scm: Emit long refs for object tables bigger than 256 entries. --- doc/ref/vm.texi | 14 ++++-- libguile/vm-i-system.c | 56 +++++++++++++++++++++++ module/language/glil/compile-assembly.scm | 24 ++++++++-- 3 files changed, 86 insertions(+), 8 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 49b420c50..8d7778c1c 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -417,6 +417,7 @@ external variables are all consed onto a list, which results in O(N) lookup time. @deffn Instruction toplevel-ref index +@deffnx Instruction long-toplevel-ref index Push the value of the toplevel binding whose location is stored in at position @var{index} in the object table. @@ -441,14 +442,19 @@ in-place mutation of the object table. This mechanism provides for lazy variable resolution, and an important cached fast-path once the variable has been successfully resolved. +The ``long'' variant has a 16-bit index instead of an 8-bit index, +with the most significant byte first. + This instruction pushes the value of the variable onto the stack. @end deffn -@deffn Instruction toplevel-ref index +@deffn Instruction toplevel-set index +@deffnx Instruction long-toplevel-set index Pop a value off the stack, and set it as the value of the toplevel variable stored at @var{index} in the object table. If the variable has not yet been looked up, we do the lookup as in -@code{toplevel-ref}. +@code{toplevel-ref}. The ``long'' variant has a 16-bit index instead +of an 8-bit index. @end deffn @deffn Instruction link-now @@ -471,7 +477,9 @@ the variable to the value. @end deffn @deffn Instruction object-ref n -Push @var{n}th value from the current program's object vector. +@deffnx Instruction long-object-ref n +Push @var{n}th value from the current program's object vector. The +``long'' variant has a 16-bit index instead of an 8-bit index. @end deffn @node Branch Instructions diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 32b772afa..36ff5bde8 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1062,6 +1062,62 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1) NEXT; } +VM_DEFINE_INSTRUCTION (52, long_object_ref, "long-object-ref", 2, 0, 1) +{ + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + PUSH (OBJECT_REF (objnum)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (53, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) +{ + SCM what; + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_REGISTER (); + what = resolve_variable (what, scm_program_module (program)); + if (!VARIABLE_BOUNDP (what)) + { + finish_args = scm_list_1 (what); + goto vm_error_unbound; + } + OBJECT_SET (objnum, what); + } + + PUSH (VARIABLE_REF (what)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (54, long_toplevel_set, "long-toplevel-set", 2, 1, 0) +{ + SCM what; + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_BEFORE_GC (); + what = resolve_variable (what, scm_program_module (program)); + OBJECT_SET (objnum, what); + } + + VARIABLE_SET (what, *sp); + DROP (); + NEXT; +} + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 4c92e0f5a..1fb10c146 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -186,7 +186,11 @@ (receive (i object-alist) (object-index-and-alist (make-subprogram table prog) object-alist) - (emit-code/object `((object-ref ,i) ,@closure) + (emit-code/object `(,(if (< i 256) + `(object-ref ,i) + `(long-object-ref ,(quotient i 256) + ,(modulo i 256))) + ,@closure) object-alist))) (else ;; otherwise emit a load directly @@ -234,7 +238,10 @@ (else (receive (i object-alist) (object-index-and-alist obj object-alist) - (emit-code/object `((object-ref ,i)) + (emit-code/object (if (< i 256) + `((object-ref ,i)) + `((long-object-ref ,(quotient i 256) + ,(modulo i 256)))) object-alist))))) (( op index) @@ -264,9 +271,16 @@ (receive (i object-alist) (object-index-and-alist (make-variable-cache-cell name) object-alist) - (emit-code/object (case op - ((ref) `((toplevel-ref ,i))) - ((set) `((toplevel-set ,i)))) + (emit-code/object (if (< i 256) + `((,(case op + ((ref) 'toplevel-ref) + ((set) 'toplevel-set)) + ,i)) + `((,(case op + ((ref) 'long-toplevel-ref) + ((set) 'long-toplevel-set)) + ,(quotient i 256) + ,(modulo i 256)))) object-alist))))) ((define) (emit-code `((define ,(symbol->string name)) From 782a82eed13abb64393f7acad92758ae191ce509 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 5 Jun 2009 16:31:38 +0200 Subject: [PATCH 195/375] add ability to compile uniform arrays * module/rnrs/bytevector.scm (rnrs): * libguile/bytevectors.h: * libguile/bytevectors.c (scm_uniform_array_to_bytevector): New function. * libguile/unif.h: * libguile/unif.c (scm_from_contiguous_typed_array): New function. * libguile/vm-i-loader.c (load-array): New instruction, for loading byte data into uniform vectors. Currently it copies out the data, though in the future we could avoid that. * module/language/assembly.scm (align-code): New exported function, aligns code on some boundary. (align-program): Use align-code. * module/language/assembly/compile-bytecode.scm (write-bytecode): Support the load-array instruction. * module/language/glil/compile-assembly.scm (dump-object): Dump uniform arrays. Neat :) --- libguile/bytevectors.c | 33 +++++++++++++ libguile/bytevectors.h | 2 + libguile/unif.c | 47 +++++++++++++++++++ libguile/unif.h | 3 ++ libguile/vm-i-loader.c | 14 ++++++ module/language/assembly.scm | 20 +++++--- module/language/assembly/compile-bytecode.scm | 6 +++ module/language/glil/compile-assembly.scm | 11 +++++ module/rnrs/bytevector.scm | 5 +- 9 files changed, 132 insertions(+), 9 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 4c3a353a1..ced1b082f 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -29,6 +29,8 @@ #include "libguile/strings.h" #include "libguile/validate.h" #include "libguile/ieee-754.h" +#include "libguile/unif.h" +#include "libguile/srfi-4.h" #include #include @@ -511,6 +513,37 @@ SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector", + 1, 0, 0, (SCM array), + "Return a newly allocated bytevector whose contents\n" + "will be copied from the uniform array @var{array}.") +#define FUNC_NAME s_scm_uniform_array_to_bytevector +{ + SCM contents, ret; + size_t len; + scm_t_array_handle h; + const void *base; + size_t sz; + + contents = scm_array_contents (array, SCM_BOOL_T); + if (scm_is_false (contents)) + scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array"); + + scm_array_get_handle (contents, &h); + + base = scm_array_handle_uniform_elements (&h); + len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1); + sz = scm_array_handle_uniform_element_size (&h); + + ret = make_bytevector (len * sz); + memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz); + + scm_array_handle_release (&h); + + return ret; +} +#undef FUNC_NAME + /* Operations on bytes and octets. */ diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index 98c38aca2..b01116ce6 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -46,6 +46,8 @@ SCM_API SCM scm_bytevector_fill_x (SCM, SCM); SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM); SCM_API SCM scm_bytevector_copy (SCM); +SCM_API SCM scm_uniform_array_to_bytevector (SCM); + SCM_API SCM scm_bytevector_to_u8_list (SCM); SCM_API SCM scm_u8_list_to_bytevector (SCM); SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM); diff --git a/libguile/unif.c b/libguile/unif.c index daf085007..4013f29b8 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -770,6 +770,53 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, } #undef FUNC_NAME +SCM +scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, + size_t byte_len) +#define FUNC_NAME "scm_from_contiguous_typed_array" +{ + size_t k, rlen = 1; + scm_t_array_dim *s; + creator_proc *creator; + SCM ra; + scm_t_array_handle h; + void *base; + size_t sz; + + creator = type_to_creator (type); + ra = scm_i_shap2ra (bounds); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); + s = SCM_I_ARRAY_DIMS (ra); + k = SCM_I_ARRAY_NDIM (ra); + + while (k--) + { + s[k].inc = rlen; + SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); + rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; + } + SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED); + + + scm_array_get_handle (ra, &h); + base = scm_array_handle_uniform_writable_elements (&h); + sz = scm_array_handle_uniform_element_size (&h); + scm_array_handle_release (&h); + + if (byte_len % sz) + SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL); + if (byte_len / sz != rlen) + SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); + + memcpy (base, bytes, byte_len); + + if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) + if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + return SCM_I_ARRAY_V (ra); + return ra; +} +#undef FUNC_NAME + SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, (SCM fill, SCM bounds), "Create and return an array.") diff --git a/libguile/unif.h b/libguile/unif.h index a09bfc921..1d01f807d 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -45,6 +45,9 @@ SCM_API SCM scm_array_p (SCM v, SCM prot); SCM_API SCM scm_typed_array_p (SCM v, SCM type); SCM_API SCM scm_make_array (SCM fill, SCM bounds); SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds); +SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds, + const void *bytes, + size_t byte_len); SCM_API SCM scm_array_rank (SCM ra); SCM_API size_t scm_c_array_rank (SCM ra); SCM_API SCM scm_array_dimensions (SCM ra); diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index b231d392f..50569e01a 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -15,6 +15,7 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +/* FIXME! Need to check that the fetch is within the current program */ /* This file is included in vm_engine.c */ @@ -143,6 +144,19 @@ VM_DEFINE_LOADER (67, define, "define") NEXT; } +VM_DEFINE_LOADER (68, load_array, "load-array") +{ + SCM type, shape; + size_t len; + FETCH_LENGTH (len); + POP (shape); + POP (type); + SYNC_REGISTER (); + PUSH (scm_from_contiguous_typed_array (type, shape, ip, len)); + ip += len; + NEXT; +} + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 28dde1e1a..3ffbf11f1 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -20,11 +20,12 @@ ;;; Code: (define-module (language assembly) + #:use-module (rnrs bytevector) #:use-module (system base pmatch) #:use-module (system vm instruction) #:use-module ((srfi srfi-1) #:select (fold)) #:export (byte-length - addr+ align-program + addr+ align-program align-code assembly-pack assembly-unpack object->assembly assembly->object)) @@ -50,6 +51,8 @@ (+ 1 *len-len* (string-length str))) ((load-keyword ,str) (+ 1 *len-len* (string-length str))) + ((load-array ,bv) + (+ 1 *len-len* (bytevector-length bv))) ((define ,str) (+ 1 *len-len* (string-length str))) ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code) @@ -66,13 +69,16 @@ addr code)) -(define (align-program prog addr) - `(,@(make-list (modulo (- *program-alignment* - (modulo (1+ addr) *program-alignment*)) - ;; plus the one for the load-program inst itself - *program-alignment*) + +(define (align-code code addr alignment header-len) + `(,@(make-list (modulo (- alignment + (modulo (+ addr header-len) alignment)) + alignment) '(nop)) - ,prog)) + ,code)) + +(define (align-program prog addr) + (align-code prog addr *program-alignment* 1)) ;;; ;;; Code compress/decompression diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 00a324c31..e4458a992 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -24,6 +24,7 @@ #:use-module (language assembly) #:use-module (system vm instruction) #:use-module (srfi srfi-4) + #:use-module (rnrs bytevector) #:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((system vm objcode) #:select (byte-order)) #:export (compile-bytecode write-bytecode)) @@ -72,6 +73,10 @@ (define (write-loader str) (write-loader-len (string-length str)) (write-string str)) + (define (write-bytevector bv) + (write-loader-len (bytevector-length bv)) + ;; Ew! + (for-each write-byte (bytevector->u8-list bv))) (define (write-break label) (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2)))) @@ -113,6 +118,7 @@ ((load-string ,str) (write-loader str)) ((load-symbol ,str) (write-loader str)) ((load-keyword ,str) (write-loader str)) + ((load-array ,bv) (write-bytevector bv)) ((define ,str) (write-loader str)) ((br ,l) (write-break l)) ((br-if ,l) (write-break l)) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 1fb10c146..dcdbc5133 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -28,6 +28,7 @@ #:use-module ((system vm program) #:select (make-binding)) #:use-module (ice-9 receive) #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (rnrs bytevector) #:export (compile-assembly)) ;; Variable cache cells go in the object table, and serialize as their @@ -393,6 +394,16 @@ (let ((code (dump-object (vector-ref x i) addr))) (dump-objects (1+ i) (cons code codes) (addr+ addr code))))))) + ((and (array? x) (symbol? (array-type x))) + (let* ((type (dump-object (array-type x) addr)) + (shape (dump-object (array-shape x) (addr+ addr type)))) + `(,@type + ,@shape + ,@(align-code + `(load-array ,(uniform-array->bytevector x)) + (addr+ (addr+ addr type) shape) + 8 + 4)))) (else (error "assemble: unrecognized object" x)))) diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm index 793cbc020..7728a1581 100644 --- a/module/rnrs/bytevector.scm +++ b/module/rnrs/bytevector.scm @@ -32,8 +32,9 @@ :export-syntax (endianness) :export (native-endianness bytevector? make-bytevector bytevector-length bytevector=? bytevector-fill! - bytevector-copy! bytevector-copy bytevector-u8-ref - bytevector-s8-ref + bytevector-copy! bytevector-copy + uniform-array->bytevector + bytevector-u8-ref bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! bytevector->u8-list u8-list->bytevector bytevector-uint-ref bytevector-uint-set! From cabf1b31a3a2c0bdb3a936ceda86491999b262b1 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 5 Jun 2009 22:54:45 +0100 Subject: [PATCH 196/375] Fix `Mismatching FUNC_NAME' warning from guile-func-name-check * libguile/bytevectors.c (FUNC_NAME): Change to match function name. --- libguile/bytevectors.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index ced1b082f..1de4db065 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -577,7 +577,7 @@ SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0, SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0, (SCM bv, SCM index, SCM value), "Return the octet located at @var{index} in @var{bv}.") -#define FUNC_NAME s_scm_bytevector_u8_set_x +#define FUNC_NAME s_scm_bytevector_s8_set_x { INTEGER_NATIVE_SET (8, signed); } From 8a8d0ca2fdc202ffef620fd7d8961a4d43ea9c95 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 5 Jun 2009 00:06:16 +0100 Subject: [PATCH 197/375] State and explain dependency on libtool 2.2 * HACKING: Updated to recommend libtool 2.2 and anti-recommend libtool 1.5.26. --- HACKING | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/HACKING b/HACKING index f6d518531..ffe04a80d 100644 --- a/HACKING +++ b/HACKING @@ -59,8 +59,9 @@ Automake --- a system for automatically generating Makefiles that libtool --- a system for managing the zillion hairy options needed on various systems to produce shared libraries. Available in - "ftp://ftp.gnu.org/pub/gnu/libtool". Version 1.5.26 (or - later) is needed for correct AIX support. + "ftp://ftp.gnu.org/pub/gnu/libtool". Version 2.2 (or + later) is recommended (for correct AIX support, and correct + interaction with the Gnulib module for using libunistring). gettext --- a system for rigging a program so that it can output its messages in the local tongue. Guile presently only exports @@ -88,6 +89,10 @@ have been known to cause problems, and a short description of the problem. - autoreconf from autoconf prior to 2.59 will run gettextize, which will mess up the Guile tree. +- libtool 1.5.26 does not know that it should remove the -R options + that the Gnulib libunistring and havelib modules generate (because + gcc doesn't actually support -R). + - (add here.) From a23c940b717413139d294d4f5c443b8d165f42a9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 6 Jun 2009 00:29:05 +0200 Subject: [PATCH 198/375] support ((@ ...) ...) where the car is a macro * module/ice-9/psyntax.scm (syntax-type): Remove `external-macro', not used any more. Take an extra arg, `for-car?', indicating that we're checking on the type of a form in the car position. In the case that the expression is a pair, do a full recursion on the car, which allows us to catch the fact that the car of the following form is a macro: ((@ (ice-9 optargs) let-optional) ...) and thus the form itself should be macroexpanded. But, since we want to distingush `lambda' from `(lambda ...)', just as we have global and global-call, we have core to the new `core-form'. (chi-top, chi, chi-expr, chi-body, set!): Adapt to changes to syntax-type. --- module/ice-9/psyntax-pp.scm | 22 +++--- module/ice-9/psyntax.scm | 136 +++++++++++++++++++----------------- 2 files changed, 83 insertions(+), 75 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index f33f49286..0043cbbd3 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*151 (lambda (f191 first190 . rest189) (let ((t192 (null? first190))) (if t192 t192 (if (null? rest189) (letrec ((andmap193 (lambda (first194) (let ((x195 (car first194)) (first196 (cdr first194))) (if (null? first196) (f191 x195) (if (f191 x195) (andmap193 first196) #f)))))) (andmap193 first190)) (letrec ((andmap197 (lambda (first198 rest199) (let ((x200 (car first198)) (xr201 (map car rest199)) (first202 (cdr first198)) (rest203 (map cdr rest199))) (if (null? first202) (apply f191 (cons x200 xr201)) (if (apply f191 (cons x200 xr201)) (andmap197 first202 rest203) #f)))))) (andmap197 first190 rest189)))))))) (letrec ((lambda-var-list296 (lambda (vars420) (letrec ((lvl421 (lambda (vars422 ls423 w424) (if (pair? vars422) (lvl421 (cdr vars422) (cons (wrap276 (car vars422) w424 #f) ls423) w424) (if (id?248 vars422) (cons (wrap276 vars422 w424 #f) ls423) (if (null? vars422) ls423 (if (syntax-object?232 vars422) (lvl421 (syntax-object-expression233 vars422) ls423 (join-wraps267 w424 (syntax-object-wrap234 vars422))) (cons vars422 ls423)))))))) (lvl421 vars420 (quote ()) (quote (())))))) (gen-var295 (lambda (id425) (let ((id426 (if (syntax-object?232 id425) (syntax-object-expression233 id425) id425))) (gensym (symbol->string id426))))) (strip294 (lambda (x427 w428) (if (memq (quote top) (wrap-marks251 w428)) x427 (letrec ((f429 (lambda (x430) (if (syntax-object?232 x430) (strip294 (syntax-object-expression233 x430) (syntax-object-wrap234 x430)) (if (pair? x430) (let ((a431 (f429 (car x430))) (d432 (f429 (cdr x430)))) (if (if (eq? a431 (car x430)) (eq? d432 (cdr x430)) #f) x430 (cons a431 d432))) (if (vector? x430) (let ((old433 (vector->list x430))) (let ((new434 (map f429 old433))) (if (and-map*151 eq? old433 new434) x430 (list->vector new434)))) x430)))))) (f429 x427))))) (ellipsis?293 (lambda (x435) (if (nonsymbol-id?247 x435) (free-id=?271 x435 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void292 (lambda () (build-void214 #f))) (eval-local-transformer291 (lambda (expanded436 mod437) (let ((p438 (local-eval-hook211 expanded436 mod437))) (if (procedure? p438) p438 (syntax-violation #f "nonprocedure transformer" p438))))) (chi-local-syntax290 (lambda (rec?439 e440 r441 w442 s443 mod444 k445) ((lambda (tmp446) ((lambda (tmp447) (if tmp447 (apply (lambda (_448 id449 val450 e1451 e2452) (let ((ids453 id449)) (if (not (valid-bound-ids?273 ids453)) (syntax-violation #f "duplicate bound keyword" e440) (let ((labels455 (gen-labels254 ids453))) (let ((new-w456 (make-binding-wrap265 ids453 labels455 w442))) (k445 (cons e1451 e2452) (extend-env242 labels455 (let ((w458 (if rec?439 new-w456 w442)) (trans-r459 (macros-only-env244 r441))) (map (lambda (x460) (cons (quote macro) (eval-local-transformer291 (chi284 x460 trans-r459 w458 mod444) mod444))) val450)) r441) new-w456 s443 mod444)))))) tmp447) ((lambda (_462) (syntax-violation #f "bad local syntax definition" (source-wrap277 e440 w442 s443 mod444))) tmp446))) ($sc-dispatch tmp446 (quote (any #(each (any any)) any . each-any))))) e440))) (chi-lambda-clause289 (lambda (e463 docstring464 c465 r466 w467 mod468 k469) ((lambda (tmp470) ((lambda (tmp471) (if (if tmp471 (apply (lambda (args472 doc473 e1474 e2475) (if (string? (syntax->datum doc473)) (not docstring464) #f)) tmp471) #f) (apply (lambda (args476 doc477 e1478 e2479) (chi-lambda-clause289 e463 doc477 (cons args476 (cons e1478 e2479)) r466 w467 mod468 k469)) tmp471) ((lambda (tmp481) (if tmp481 (apply (lambda (id482 e1483 e2484) (let ((ids485 id482)) (if (not (valid-bound-ids?273 ids485)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels487 (gen-labels254 ids485)) (new-vars488 (map gen-var295 ids485))) (k469 (map syntax->datum ids485) new-vars488 (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1483 e2484) e463 (extend-var-env243 labels487 new-vars488 r466) (make-binding-wrap265 ids485 labels487 w467) mod468)))))) tmp481) ((lambda (tmp490) (if tmp490 (apply (lambda (ids491 e1492 e2493) (let ((old-ids494 (lambda-var-list296 ids491))) (if (not (valid-bound-ids?273 old-ids494)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels495 (gen-labels254 old-ids494)) (new-vars496 (map gen-var295 old-ids494))) (k469 (letrec ((f497 (lambda (ls1498 ls2499) (if (null? ls1498) (syntax->datum ls2499) (f497 (cdr ls1498) (cons (syntax->datum (car ls1498)) ls2499)))))) (f497 (cdr old-ids494) (car old-ids494))) (letrec ((f500 (lambda (ls1501 ls2502) (if (null? ls1501) ls2502 (f500 (cdr ls1501) (cons (car ls1501) ls2502)))))) (f500 (cdr new-vars496) (car new-vars496))) (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1492 e2493) e463 (extend-var-env243 labels495 new-vars496 r466) (make-binding-wrap265 old-ids494 labels495 w467) mod468)))))) tmp490) ((lambda (_504) (syntax-violation (quote lambda) "bad lambda" e463)) tmp470))) ($sc-dispatch tmp470 (quote (any any . each-any)))))) ($sc-dispatch tmp470 (quote (each-any any . each-any)))))) ($sc-dispatch tmp470 (quote (any any any . each-any))))) c465))) (chi-body288 (lambda (body505 outer-form506 r507 w508 mod509) (let ((r510 (cons (quote ("placeholder" placeholder)) r507))) (let ((ribcage511 (make-ribcage255 (quote ()) (quote ()) (quote ())))) (let ((w512 (make-wrap250 (wrap-marks251 w508) (cons ribcage511 (wrap-subst252 w508))))) (letrec ((parse513 (lambda (body514 ids515 labels516 var-ids517 vars518 vals519 bindings520) (if (null? body514) (syntax-violation #f "no expressions in body" outer-form506) (let ((e522 (cdar body514)) (er523 (caar body514))) (call-with-values (lambda () (syntax-type282 e522 er523 (quote (())) (source-annotation239 er523) ribcage511 mod509)) (lambda (type524 value525 e526 w527 s528 mod529) (if (memv type524 (quote (define-form))) (let ((id530 (wrap276 value525 w527 mod529)) (label531 (gen-label253))) (let ((var532 (gen-var295 id530))) (begin (extend-ribcage!264 ribcage511 id530 label531) (parse513 (cdr body514) (cons id530 ids515) (cons label531 labels516) (cons id530 var-ids517) (cons var532 vars518) (cons (cons er523 (wrap276 e526 w527 mod529)) vals519) (cons (cons (quote lexical) var532) bindings520))))) (if (memv type524 (quote (define-syntax-form))) (let ((id533 (wrap276 value525 w527 mod529)) (label534 (gen-label253))) (begin (extend-ribcage!264 ribcage511 id533 label534) (parse513 (cdr body514) (cons id533 ids515) (cons label534 labels516) var-ids517 vars518 vals519 (cons (cons (quote macro) (cons er523 (wrap276 e526 w527 mod529))) bindings520)))) (if (memv type524 (quote (begin-form))) ((lambda (tmp535) ((lambda (tmp536) (if tmp536 (apply (lambda (_537 e1538) (parse513 (letrec ((f539 (lambda (forms540) (if (null? forms540) (cdr body514) (cons (cons er523 (wrap276 (car forms540) w527 mod529)) (f539 (cdr forms540))))))) (f539 e1538)) ids515 labels516 var-ids517 vars518 vals519 bindings520)) tmp536) (syntax-violation #f "source expression failed to match any pattern" tmp535))) ($sc-dispatch tmp535 (quote (any . each-any))))) e526) (if (memv type524 (quote (local-syntax-form))) (chi-local-syntax290 value525 e526 er523 w527 s528 mod529 (lambda (forms542 er543 w544 s545 mod546) (parse513 (letrec ((f547 (lambda (forms548) (if (null? forms548) (cdr body514) (cons (cons er543 (wrap276 (car forms548) w544 mod546)) (f547 (cdr forms548))))))) (f547 forms542)) ids515 labels516 var-ids517 vars518 vals519 bindings520))) (if (null? ids515) (build-sequence227 #f (map (lambda (x549) (chi284 (cdr x549) (car x549) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))) (begin (if (not (valid-bound-ids?273 ids515)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form506)) (letrec ((loop550 (lambda (bs551 er-cache552 r-cache553) (if (not (null? bs551)) (let ((b554 (car bs551))) (if (eq? (car b554) (quote macro)) (let ((er555 (cadr b554))) (let ((r-cache556 (if (eq? er555 er-cache552) r-cache553 (macros-only-env244 er555)))) (begin (set-cdr! b554 (eval-local-transformer291 (chi284 (cddr b554) r-cache556 (quote (())) mod529) mod529)) (loop550 (cdr bs551) er555 r-cache556)))) (loop550 (cdr bs551) er-cache552 r-cache553))))))) (loop550 bindings520 #f #f)) (set-cdr! r510 (extend-env242 labels516 bindings520 (cdr r510))) (build-letrec230 #f (map syntax->datum var-ids517) vars518 (map (lambda (x557) (chi284 (cdr x557) (car x557) (quote (())) mod529)) vals519) (build-sequence227 #f (map (lambda (x558) (chi284 (cdr x558) (car x558) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))))))))))))))))) (parse513 (map (lambda (x521) (cons r510 (wrap276 x521 w512 mod509))) body505) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro287 (lambda (p559 e560 r561 w562 rib563 mod564) (letrec ((rebuild-macro-output565 (lambda (x566 m567) (if (pair? x566) (cons (rebuild-macro-output565 (car x566) m567) (rebuild-macro-output565 (cdr x566) m567)) (if (syntax-object?232 x566) (let ((w568 (syntax-object-wrap234 x566))) (let ((ms569 (wrap-marks251 w568)) (s570 (wrap-subst252 w568))) (if (if (pair? ms569) (eq? (car ms569) #f) #f) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cdr ms569) (if rib563 (cons rib563 (cdr s570)) (cdr s570))) (syntax-object-module235 x566)) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cons m567 ms569) (if rib563 (cons rib563 (cons (quote shift) s570)) (cons (quote shift) s570))) (let ((pmod571 (procedure-module p559))) (if pmod571 (cons (quote hygiene) (module-name pmod571)) (quote (hygiene guile)))))))) (if (vector? x566) (let ((n572 (vector-length x566))) (let ((v573 (make-vector n572))) (letrec ((loop574 (lambda (i575) (if (fx=208 i575 n572) (begin (if #f #f) v573) (begin (vector-set! v573 i575 (rebuild-macro-output565 (vector-ref x566 i575) m567)) (loop574 (fx+206 i575 1))))))) (loop574 0)))) (if (symbol? x566) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap277 e560 w562 s mod564) x566) x566))))))) (rebuild-macro-output565 (p559 (wrap276 e560 (anti-mark263 w562) mod564)) (string #\m))))) (chi-application286 (lambda (x576 e577 r578 w579 s580 mod581) ((lambda (tmp582) ((lambda (tmp583) (if tmp583 (apply (lambda (e0584 e1585) (build-application215 s580 x576 (map (lambda (e586) (chi284 e586 r578 w579 mod581)) e1585))) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp582))) ($sc-dispatch tmp582 (quote (any . each-any))))) e577))) (chi-expr285 (lambda (type588 value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (lexical))) (build-lexical-reference217 (quote value) s593 e590 value589) (if (memv type588 (quote (core external-macro))) (value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (module-ref))) (call-with-values (lambda () (value589 e590)) (lambda (id595 mod596) (build-global-reference220 s593 id595 mod596))) (if (memv type588 (quote (lexical-call))) (chi-application286 (build-lexical-reference217 (quote fun) (source-annotation239 (car e590)) (car e590) value589) e590 r591 w592 s593 mod594) (if (memv type588 (quote (global-call))) (chi-application286 (build-global-reference220 (source-annotation239 (car e590)) value589 (if (syntax-object?232 (car e590)) (syntax-object-module235 (car e590)) mod594)) e590 r591 w592 s593 mod594) (if (memv type588 (quote (constant))) (build-data226 s593 (strip294 (source-wrap277 e590 w592 s593 mod594) (quote (())))) (if (memv type588 (quote (global))) (build-global-reference220 s593 value589 mod594) (if (memv type588 (quote (call))) (chi-application286 (chi284 (car e590) r591 w592 mod594) e590 r591 w592 s593 mod594) (if (memv type588 (quote (begin-form))) ((lambda (tmp597) ((lambda (tmp598) (if tmp598 (apply (lambda (_599 e1600 e2601) (chi-sequence278 (cons e1600 e2601) r591 w592 s593 mod594)) tmp598) (syntax-violation #f "source expression failed to match any pattern" tmp597))) ($sc-dispatch tmp597 (quote (any any . each-any))))) e590) (if (memv type588 (quote (local-syntax-form))) (chi-local-syntax290 value589 e590 r591 w592 s593 mod594 chi-sequence278) (if (memv type588 (quote (eval-when-form))) ((lambda (tmp603) ((lambda (tmp604) (if tmp604 (apply (lambda (_605 x606 e1607 e2608) (let ((when-list609 (chi-when-list281 e590 x606 w592))) (if (memq (quote eval) when-list609) (chi-sequence278 (cons e1607 e2608) r591 w592 s593 mod594) (chi-void292)))) tmp604) (syntax-violation #f "source expression failed to match any pattern" tmp603))) ($sc-dispatch tmp603 (quote (any each-any any . each-any))))) e590) (if (memv type588 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e590 (wrap276 value589 w592 mod594)) (if (memv type588 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap277 e590 w592 s593 mod594)) (if (memv type588 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap277 e590 w592 s593 mod594)) (syntax-violation #f "unexpected syntax" (source-wrap277 e590 w592 s593 mod594)))))))))))))))))) (chi284 (lambda (e612 r613 w614 mod615) (call-with-values (lambda () (syntax-type282 e612 r613 w614 (source-annotation239 e612) #f mod615)) (lambda (type616 value617 e618 w619 s620 mod621) (chi-expr285 type616 value617 e618 r613 w619 s620 mod621))))) (chi-top283 (lambda (e622 r623 w624 m625 esew626 mod627) (call-with-values (lambda () (syntax-type282 e622 r623 w624 (source-annotation239 e622) #f mod627)) (lambda (type635 value636 e637 w638 s639 mod640) (if (memv type635 (quote (begin-form))) ((lambda (tmp641) ((lambda (tmp642) (if tmp642 (apply (lambda (_643) (chi-void292)) tmp642) ((lambda (tmp644) (if tmp644 (apply (lambda (_645 e1646 e2647) (chi-top-sequence279 (cons e1646 e2647) r623 w638 s639 m625 esew626 mod640)) tmp644) (syntax-violation #f "source expression failed to match any pattern" tmp641))) ($sc-dispatch tmp641 (quote (any any . each-any)))))) ($sc-dispatch tmp641 (quote (any))))) e637) (if (memv type635 (quote (local-syntax-form))) (chi-local-syntax290 value636 e637 r623 w638 s639 mod640 (lambda (body649 r650 w651 s652 mod653) (chi-top-sequence279 body649 r650 w651 s652 m625 esew626 mod653))) (if (memv type635 (quote (eval-when-form))) ((lambda (tmp654) ((lambda (tmp655) (if tmp655 (apply (lambda (_656 x657 e1658 e2659) (let ((when-list660 (chi-when-list281 e637 x657 w638)) (body661 (cons e1658 e2659))) (if (eq? m625 (quote e)) (if (memq (quote eval) when-list660) (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) (chi-void292)) (if (memq (quote load) when-list660) (if (let ((t664 (memq (quote compile) when-list660))) (if t664 t664 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (chi-top-sequence279 body661 r623 w638 s639 (quote c&e) (quote (compile load)) mod640) (if (memq m625 (quote (c c&e))) (chi-top-sequence279 body661 r623 w638 s639 (quote c) (quote (load)) mod640) (chi-void292))) (if (let ((t665 (memq (quote compile) when-list660))) (if t665 t665 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (begin (top-level-eval-hook210 (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) mod640) (chi-void292)) (chi-void292)))))) tmp655) (syntax-violation #f "source expression failed to match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any each-any any . each-any))))) e637) (if (memv type635 (quote (define-syntax-form))) (let ((n666 (id-var-name270 value636 w638)) (r667 (macros-only-env244 r623))) (if (memv m625 (quote (c))) (if (memq (quote compile) esew626) (let ((e668 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e668 mod640) (if (memq (quote load) esew626) e668 (chi-void292)))) (if (memq (quote load) esew626) (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) (chi-void292))) (if (memv m625 (quote (c&e))) (let ((e669 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e669 mod640) e669)) (begin (if (memq (quote eval) esew626) (top-level-eval-hook210 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) mod640)) (chi-void292))))) (if (memv type635 (quote (define-form))) (let ((n670 (id-var-name270 value636 w638))) (let ((type671 (binding-type240 (lookup245 n670 r623 mod640)))) (if (memv type671 (quote (global core macro module-ref))) (let ((x672 (build-global-definition223 s639 n670 (chi284 e637 r623 w638 mod640)))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x672 mod640)) x672)) (if (memv type671 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e637 (wrap276 value636 w638 mod640)) (syntax-violation #f "cannot define keyword at top level" e637 (wrap276 value636 w638 mod640)))))) (let ((x673 (chi-expr285 type635 value636 e637 r623 w638 s639 mod640))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x673 mod640)) x673))))))))))) (syntax-type282 (lambda (e674 r675 w676 s677 rib678 mod679) (if (symbol? e674) (let ((n680 (id-var-name270 e674 w676))) (let ((b681 (lookup245 n680 r675 mod679))) (let ((type682 (binding-type240 b681))) (if (memv type682 (quote (lexical))) (values type682 (binding-value241 b681) e674 w676 s677 mod679) (if (memv type682 (quote (global))) (values type682 n680 e674 w676 s677 mod679) (if (memv type682 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b681) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (values type682 (binding-value241 b681) e674 w676 s677 mod679))))))) (if (pair? e674) (let ((first683 (car e674))) (if (id?248 first683) (let ((n684 (id-var-name270 first683 w676))) (let ((b685 (lookup245 n684 r675 (let ((t686 (if (syntax-object?232 first683) (syntax-object-module235 first683) #f))) (if t686 t686 mod679))))) (let ((type687 (binding-type240 b685))) (if (memv type687 (quote (lexical))) (values (quote lexical-call) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (global))) (values (quote global-call) n684 e674 w676 s677 mod679) (if (memv type687 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b685) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (if (memv type687 (quote (core external-macro module-ref))) (values type687 (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (begin))) (values (quote begin-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (eval-when))) (values (quote eval-when-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (define))) ((lambda (tmp688) ((lambda (tmp689) (if (if tmp689 (apply (lambda (_690 name691 val692) (id?248 name691)) tmp689) #f) (apply (lambda (_693 name694 val695) (values (quote define-form) name694 val695 w676 s677 mod679)) tmp689) ((lambda (tmp696) (if (if tmp696 (apply (lambda (_697 name698 args699 e1700 e2701) (if (id?248 name698) (valid-bound-ids?273 (lambda-var-list296 args699)) #f)) tmp696) #f) (apply (lambda (_702 name703 args704 e1705 e2706) (values (quote define-form) (wrap276 name703 w676 mod679) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap276 (cons args704 (cons e1705 e2706)) w676 mod679)) (quote (())) s677 mod679)) tmp696) ((lambda (tmp708) (if (if tmp708 (apply (lambda (_709 name710) (id?248 name710)) tmp708) #f) (apply (lambda (_711 name712) (values (quote define-form) (wrap276 name712 w676 mod679) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s677 mod679)) tmp708) (syntax-violation #f "source expression failed to match any pattern" tmp688))) ($sc-dispatch tmp688 (quote (any any)))))) ($sc-dispatch tmp688 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp688 (quote (any any any))))) e674) (if (memv type687 (quote (define-syntax))) ((lambda (tmp713) ((lambda (tmp714) (if (if tmp714 (apply (lambda (_715 name716 val717) (id?248 name716)) tmp714) #f) (apply (lambda (_718 name719 val720) (values (quote define-syntax-form) name719 val720 w676 s677 mod679)) tmp714) (syntax-violation #f "source expression failed to match any pattern" tmp713))) ($sc-dispatch tmp713 (quote (any any any))))) e674) (values (quote call) #f e674 w676 s677 mod679))))))))))))) (values (quote call) #f e674 w676 s677 mod679))) (if (syntax-object?232 e674) (syntax-type282 (syntax-object-expression233 e674) r675 (join-wraps267 w676 (syntax-object-wrap234 e674)) s677 rib678 (let ((t721 (syntax-object-module235 e674))) (if t721 t721 mod679))) (if (self-evaluating? e674) (values (quote constant) #f e674 w676 s677 mod679) (values (quote other) #f e674 w676 s677 mod679))))))) (chi-when-list281 (lambda (e722 when-list723 w724) (letrec ((f725 (lambda (when-list726 situations727) (if (null? when-list726) situations727 (f725 (cdr when-list726) (cons (let ((x728 (car when-list726))) (if (free-id=?271 x728 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?271 x728 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?271 x728 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e722 (wrap276 x728 w724 #f)))))) situations727)))))) (f725 when-list723 (quote ()))))) (chi-install-global280 (lambda (name729 e730) (build-global-definition223 #f name729 (if (let ((v731 (module-variable (current-module) name729))) (if v731 (if (variable-bound? v731) (if (macro? (variable-ref v731)) (not (eq? (macro-type (variable-ref v731)) (quote syncase-macro))) #f) #f) #f)) (build-application215 #f (build-primref225 #f (quote make-extended-syncase-macro)) (list (build-application215 #f (build-primref225 #f (quote module-ref)) (list (build-application215 #f (build-primref225 #f (quote current-module)) (quote ())) (build-data226 #f name729))) (build-data226 #f (quote macro)) e730)) (build-application215 #f (build-primref225 #f (quote make-syncase-macro)) (list (build-data226 #f (quote macro)) e730)))))) (chi-top-sequence279 (lambda (body732 r733 w734 s735 m736 esew737 mod738) (build-sequence227 s735 (letrec ((dobody739 (lambda (body740 r741 w742 m743 esew744 mod745) (if (null? body740) (quote ()) (let ((first746 (chi-top283 (car body740) r741 w742 m743 esew744 mod745))) (cons first746 (dobody739 (cdr body740) r741 w742 m743 esew744 mod745))))))) (dobody739 body732 r733 w734 m736 esew737 mod738))))) (chi-sequence278 (lambda (body747 r748 w749 s750 mod751) (build-sequence227 s750 (letrec ((dobody752 (lambda (body753 r754 w755 mod756) (if (null? body753) (quote ()) (let ((first757 (chi284 (car body753) r754 w755 mod756))) (cons first757 (dobody752 (cdr body753) r754 w755 mod756))))))) (dobody752 body747 r748 w749 mod751))))) (source-wrap277 (lambda (x758 w759 s760 defmod761) (begin (if (if s760 (pair? x758) #f) (set-source-properties! x758 s760)) (wrap276 x758 w759 defmod761)))) (wrap276 (lambda (x762 w763 defmod764) (if (if (null? (wrap-marks251 w763)) (null? (wrap-subst252 w763)) #f) x762 (if (syntax-object?232 x762) (make-syntax-object231 (syntax-object-expression233 x762) (join-wraps267 w763 (syntax-object-wrap234 x762)) (syntax-object-module235 x762)) (if (null? x762) x762 (make-syntax-object231 x762 w763 defmod764)))))) (bound-id-member?275 (lambda (x765 list766) (if (not (null? list766)) (let ((t767 (bound-id=?272 x765 (car list766)))) (if t767 t767 (bound-id-member?275 x765 (cdr list766)))) #f))) (distinct-bound-ids?274 (lambda (ids768) (letrec ((distinct?769 (lambda (ids770) (let ((t771 (null? ids770))) (if t771 t771 (if (not (bound-id-member?275 (car ids770) (cdr ids770))) (distinct?769 (cdr ids770)) #f)))))) (distinct?769 ids768)))) (valid-bound-ids?273 (lambda (ids772) (if (letrec ((all-ids?773 (lambda (ids774) (let ((t775 (null? ids774))) (if t775 t775 (if (id?248 (car ids774)) (all-ids?773 (cdr ids774)) #f)))))) (all-ids?773 ids772)) (distinct-bound-ids?274 ids772) #f))) (bound-id=?272 (lambda (i776 j777) (if (if (syntax-object?232 i776) (syntax-object?232 j777) #f) (if (eq? (syntax-object-expression233 i776) (syntax-object-expression233 j777)) (same-marks?269 (wrap-marks251 (syntax-object-wrap234 i776)) (wrap-marks251 (syntax-object-wrap234 j777))) #f) (eq? i776 j777)))) (free-id=?271 (lambda (i778 j779) (if (eq? (let ((x780 i778)) (if (syntax-object?232 x780) (syntax-object-expression233 x780) x780)) (let ((x781 j779)) (if (syntax-object?232 x781) (syntax-object-expression233 x781) x781))) (eq? (id-var-name270 i778 (quote (()))) (id-var-name270 j779 (quote (())))) #f))) (id-var-name270 (lambda (id782 w783) (letrec ((search-vector-rib786 (lambda (sym792 subst793 marks794 symnames795 ribcage796) (let ((n797 (vector-length symnames795))) (letrec ((f798 (lambda (i799) (if (fx=208 i799 n797) (search784 sym792 (cdr subst793) marks794) (if (if (eq? (vector-ref symnames795 i799) sym792) (same-marks?269 marks794 (vector-ref (ribcage-marks258 ribcage796) i799)) #f) (values (vector-ref (ribcage-labels259 ribcage796) i799) marks794) (f798 (fx+206 i799 1))))))) (f798 0))))) (search-list-rib785 (lambda (sym800 subst801 marks802 symnames803 ribcage804) (letrec ((f805 (lambda (symnames806 i807) (if (null? symnames806) (search784 sym800 (cdr subst801) marks802) (if (if (eq? (car symnames806) sym800) (same-marks?269 marks802 (list-ref (ribcage-marks258 ribcage804) i807)) #f) (values (list-ref (ribcage-labels259 ribcage804) i807) marks802) (f805 (cdr symnames806) (fx+206 i807 1))))))) (f805 symnames803 0)))) (search784 (lambda (sym808 subst809 marks810) (if (null? subst809) (values #f marks810) (let ((fst811 (car subst809))) (if (eq? fst811 (quote shift)) (search784 sym808 (cdr subst809) (cdr marks810)) (let ((symnames812 (ribcage-symnames257 fst811))) (if (vector? symnames812) (search-vector-rib786 sym808 subst809 marks810 symnames812 fst811) (search-list-rib785 sym808 subst809 marks810 symnames812 fst811))))))))) (if (symbol? id782) (let ((t813 (call-with-values (lambda () (search784 id782 (wrap-subst252 w783) (wrap-marks251 w783))) (lambda (x815 . ignore814) x815)))) (if t813 t813 id782)) (if (syntax-object?232 id782) (let ((id816 (syntax-object-expression233 id782)) (w1817 (syntax-object-wrap234 id782))) (let ((marks818 (join-marks268 (wrap-marks251 w783) (wrap-marks251 w1817)))) (call-with-values (lambda () (search784 id816 (wrap-subst252 w783) marks818)) (lambda (new-id819 marks820) (let ((t821 new-id819)) (if t821 t821 (let ((t822 (call-with-values (lambda () (search784 id816 (wrap-subst252 w1817) marks820)) (lambda (x824 . ignore823) x824)))) (if t822 t822 id816)))))))) (syntax-violation (quote id-var-name) "invalid id" id782)))))) (same-marks?269 (lambda (x825 y826) (let ((t827 (eq? x825 y826))) (if t827 t827 (if (not (null? x825)) (if (not (null? y826)) (if (eq? (car x825) (car y826)) (same-marks?269 (cdr x825) (cdr y826)) #f) #f) #f))))) (join-marks268 (lambda (m1828 m2829) (smart-append266 m1828 m2829))) (join-wraps267 (lambda (w1830 w2831) (let ((m1832 (wrap-marks251 w1830)) (s1833 (wrap-subst252 w1830))) (if (null? m1832) (if (null? s1833) w2831 (make-wrap250 (wrap-marks251 w2831) (smart-append266 s1833 (wrap-subst252 w2831)))) (make-wrap250 (smart-append266 m1832 (wrap-marks251 w2831)) (smart-append266 s1833 (wrap-subst252 w2831))))))) (smart-append266 (lambda (m1834 m2835) (if (null? m2835) m1834 (append m1834 m2835)))) (make-binding-wrap265 (lambda (ids836 labels837 w838) (if (null? ids836) w838 (make-wrap250 (wrap-marks251 w838) (cons (let ((labelvec839 (list->vector labels837))) (let ((n840 (vector-length labelvec839))) (let ((symnamevec841 (make-vector n840)) (marksvec842 (make-vector n840))) (begin (letrec ((f843 (lambda (ids844 i845) (if (not (null? ids844)) (call-with-values (lambda () (id-sym-name&marks249 (car ids844) w838)) (lambda (symname846 marks847) (begin (vector-set! symnamevec841 i845 symname846) (vector-set! marksvec842 i845 marks847) (f843 (cdr ids844) (fx+206 i845 1))))))))) (f843 ids836 0)) (make-ribcage255 symnamevec841 marksvec842 labelvec839))))) (wrap-subst252 w838)))))) (extend-ribcage!264 (lambda (ribcage848 id849 label850) (begin (set-ribcage-symnames!260 ribcage848 (cons (syntax-object-expression233 id849) (ribcage-symnames257 ribcage848))) (set-ribcage-marks!261 ribcage848 (cons (wrap-marks251 (syntax-object-wrap234 id849)) (ribcage-marks258 ribcage848))) (set-ribcage-labels!262 ribcage848 (cons label850 (ribcage-labels259 ribcage848)))))) (anti-mark263 (lambda (w851) (make-wrap250 (cons #f (wrap-marks251 w851)) (cons (quote shift) (wrap-subst252 w851))))) (set-ribcage-labels!262 (lambda (x852 update853) (vector-set! x852 3 update853))) (set-ribcage-marks!261 (lambda (x854 update855) (vector-set! x854 2 update855))) (set-ribcage-symnames!260 (lambda (x856 update857) (vector-set! x856 1 update857))) (ribcage-labels259 (lambda (x858) (vector-ref x858 3))) (ribcage-marks258 (lambda (x859) (vector-ref x859 2))) (ribcage-symnames257 (lambda (x860) (vector-ref x860 1))) (ribcage?256 (lambda (x861) (if (vector? x861) (if (= (vector-length x861) 4) (eq? (vector-ref x861 0) (quote ribcage)) #f) #f))) (make-ribcage255 (lambda (symnames862 marks863 labels864) (vector (quote ribcage) symnames862 marks863 labels864))) (gen-labels254 (lambda (ls865) (if (null? ls865) (quote ()) (cons (gen-label253) (gen-labels254 (cdr ls865)))))) (gen-label253 (lambda () (string #\i))) (wrap-subst252 cdr) (wrap-marks251 car) (make-wrap250 cons) (id-sym-name&marks249 (lambda (x866 w867) (if (syntax-object?232 x866) (values (syntax-object-expression233 x866) (join-marks268 (wrap-marks251 w867) (wrap-marks251 (syntax-object-wrap234 x866)))) (values x866 (wrap-marks251 w867))))) (id?248 (lambda (x868) (if (symbol? x868) #t (if (syntax-object?232 x868) (symbol? (syntax-object-expression233 x868)) #f)))) (nonsymbol-id?247 (lambda (x869) (if (syntax-object?232 x869) (symbol? (syntax-object-expression233 x869)) #f))) (global-extend246 (lambda (type870 sym871 val872) (put-global-definition-hook212 sym871 type870 val872))) (lookup245 (lambda (x873 r874 mod875) (let ((t876 (assq x873 r874))) (if t876 (cdr t876) (if (symbol? x873) (let ((t877 (get-global-definition-hook213 x873 mod875))) (if t877 t877 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env244 (lambda (r878) (if (null? r878) (quote ()) (let ((a879 (car r878))) (if (eq? (cadr a879) (quote macro)) (cons a879 (macros-only-env244 (cdr r878))) (macros-only-env244 (cdr r878))))))) (extend-var-env243 (lambda (labels880 vars881 r882) (if (null? labels880) r882 (extend-var-env243 (cdr labels880) (cdr vars881) (cons (cons (car labels880) (cons (quote lexical) (car vars881))) r882))))) (extend-env242 (lambda (labels883 bindings884 r885) (if (null? labels883) r885 (extend-env242 (cdr labels883) (cdr bindings884) (cons (cons (car labels883) (car bindings884)) r885))))) (binding-value241 cdr) (binding-type240 car) (source-annotation239 (lambda (x886) (if (syntax-object?232 x886) (source-annotation239 (syntax-object-expression233 x886)) (if (pair? x886) (let ((props887 (source-properties x886))) (if (pair? props887) props887 #f)) #f)))) (set-syntax-object-module!238 (lambda (x888 update889) (vector-set! x888 3 update889))) (set-syntax-object-wrap!237 (lambda (x890 update891) (vector-set! x890 2 update891))) (set-syntax-object-expression!236 (lambda (x892 update893) (vector-set! x892 1 update893))) (syntax-object-module235 (lambda (x894) (vector-ref x894 3))) (syntax-object-wrap234 (lambda (x895) (vector-ref x895 2))) (syntax-object-expression233 (lambda (x896) (vector-ref x896 1))) (syntax-object?232 (lambda (x897) (if (vector? x897) (if (= (vector-length x897) 4) (eq? (vector-ref x897 0) (quote syntax-object)) #f) #f))) (make-syntax-object231 (lambda (expression898 wrap899 module900) (vector (quote syntax-object) expression898 wrap899 module900))) (build-letrec230 (lambda (src901 ids902 vars903 val-exps904 body-exp905) (if (null? vars903) body-exp905 (let ((atom-key906 (fluid-ref *mode*205))) (if (memv atom-key906 (quote (c))) (begin (for-each maybe-name-value!222 ids902 val-exps904) ((@ (language tree-il) make-letrec) src901 ids902 vars903 val-exps904 body-exp905)) (list (quote letrec) (map list vars903 val-exps904) body-exp905)))))) (build-named-let229 (lambda (src907 ids908 vars909 val-exps910 body-exp911) (let ((f912 (car vars909)) (f-name913 (car ids908)) (vars914 (cdr vars909)) (ids915 (cdr ids908))) (let ((atom-key916 (fluid-ref *mode*205))) (if (memv atom-key916 (quote (c))) (let ((proc917 (build-lambda224 src907 ids915 vars914 #f body-exp911))) (begin (maybe-name-value!222 f-name913 proc917) (for-each maybe-name-value!222 ids915 val-exps910) ((@ (language tree-il) make-letrec) src907 (list f-name913) (list f912) (list proc917) (build-application215 src907 (build-lexical-reference217 (quote fun) src907 f-name913 f912) val-exps910)))) (list (quote let) f912 (map list vars914 val-exps910) body-exp911)))))) (build-let228 (lambda (src918 ids919 vars920 val-exps921 body-exp922) (if (null? vars920) body-exp922 (let ((atom-key923 (fluid-ref *mode*205))) (if (memv atom-key923 (quote (c))) (begin (for-each maybe-name-value!222 ids919 val-exps921) ((@ (language tree-il) make-let) src918 ids919 vars920 val-exps921 body-exp922)) (list (quote let) (map list vars920 val-exps921) body-exp922)))))) (build-sequence227 (lambda (src924 exps925) (if (null? (cdr exps925)) (car exps925) (let ((atom-key926 (fluid-ref *mode*205))) (if (memv atom-key926 (quote (c))) ((@ (language tree-il) make-sequence) src924 exps925) (cons (quote begin) exps925)))))) (build-data226 (lambda (src927 exp928) (let ((atom-key929 (fluid-ref *mode*205))) (if (memv atom-key929 (quote (c))) ((@ (language tree-il) make-const) src927 exp928) (if (if (self-evaluating? exp928) (not (vector? exp928)) #f) exp928 (list (quote quote) exp928)))))) (build-primref225 (lambda (src930 name931) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key932 (fluid-ref *mode*205))) (if (memv atom-key932 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src930 name931) name931)) (let ((atom-key933 (fluid-ref *mode*205))) (if (memv atom-key933 (quote (c))) ((@ (language tree-il) make-module-ref) src930 (quote (guile)) name931 #f) (list (quote @@) (quote (guile)) name931)))))) (build-lambda224 (lambda (src934 ids935 vars936 docstring937 exp938) (let ((atom-key939 (fluid-ref *mode*205))) (if (memv atom-key939 (quote (c))) ((@ (language tree-il) make-lambda) src934 ids935 vars936 (if docstring937 (list (cons (quote documentation) docstring937)) (quote ())) exp938) (cons (quote lambda) (cons vars936 (append (if docstring937 (list docstring937) (quote ())) (list exp938)))))))) (build-global-definition223 (lambda (source940 var941 exp942) (let ((atom-key943 (fluid-ref *mode*205))) (if (memv atom-key943 (quote (c))) (begin (maybe-name-value!222 var941 exp942) ((@ (language tree-il) make-toplevel-define) source940 var941 exp942)) (list (quote define) var941 exp942))))) (maybe-name-value!222 (lambda (name944 val945) (if ((@ (language tree-il) lambda?) val945) (let ((meta946 ((@ (language tree-il) lambda-meta) val945))) (if (not (assq (quote name) meta946)) ((setter (@ (language tree-il) lambda-meta)) val945 (acons (quote name) name944 meta946))))))) (build-global-assignment221 (lambda (source947 var948 exp949 mod950) (analyze-variable219 mod950 var948 (lambda (mod951 var952 public?953) (let ((atom-key954 (fluid-ref *mode*205))) (if (memv atom-key954 (quote (c))) ((@ (language tree-il) make-module-set) source947 mod951 var952 public?953 exp949) (list (quote set!) (list (if public?953 (quote @) (quote @@)) mod951 var952) exp949)))) (lambda (var955) (let ((atom-key956 (fluid-ref *mode*205))) (if (memv atom-key956 (quote (c))) ((@ (language tree-il) make-toplevel-set) source947 var955 exp949) (list (quote set!) var955 exp949))))))) (build-global-reference220 (lambda (source957 var958 mod959) (analyze-variable219 mod959 var958 (lambda (mod960 var961 public?962) (let ((atom-key963 (fluid-ref *mode*205))) (if (memv atom-key963 (quote (c))) ((@ (language tree-il) make-module-ref) source957 mod960 var961 public?962) (list (if public?962 (quote @) (quote @@)) mod960 var961)))) (lambda (var964) (let ((atom-key965 (fluid-ref *mode*205))) (if (memv atom-key965 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source957 var964) var964)))))) (analyze-variable219 (lambda (mod966 var967 modref-cont968 bare-cont969) (if (not mod966) (bare-cont969 var967) (let ((kind970 (car mod966)) (mod971 (cdr mod966))) (if (memv kind970 (quote (public))) (modref-cont968 mod971 var967 #t) (if (memv kind970 (quote (private))) (if (not (equal? mod971 (module-name (current-module)))) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (if (memv kind970 (quote (bare))) (bare-cont969 var967) (if (memv kind970 (quote (hygiene))) (if (if (not (equal? mod971 (module-name (current-module)))) (module-variable (resolve-module mod971) var967) #f) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (syntax-violation #f "bad module kind" var967 mod971))))))))) (build-lexical-assignment218 (lambda (source972 name973 var974 exp975) (let ((atom-key976 (fluid-ref *mode*205))) (if (memv atom-key976 (quote (c))) ((@ (language tree-il) make-lexical-set) source972 name973 var974 exp975) (list (quote set!) var974 exp975))))) (build-lexical-reference217 (lambda (type977 source978 name979 var980) (let ((atom-key981 (fluid-ref *mode*205))) (if (memv atom-key981 (quote (c))) ((@ (language tree-il) make-lexical-ref) source978 name979 var980) var980)))) (build-conditional216 (lambda (source982 test-exp983 then-exp984 else-exp985) (let ((atom-key986 (fluid-ref *mode*205))) (if (memv atom-key986 (quote (c))) ((@ (language tree-il) make-conditional) source982 test-exp983 then-exp984 else-exp985) (if (equal? else-exp985 (quote (if #f #f))) (list (quote if) test-exp983 then-exp984) (list (quote if) test-exp983 then-exp984 else-exp985)))))) (build-application215 (lambda (source987 fun-exp988 arg-exps989) (let ((atom-key990 (fluid-ref *mode*205))) (if (memv atom-key990 (quote (c))) ((@ (language tree-il) make-application) source987 fun-exp988 arg-exps989) (cons fun-exp988 arg-exps989))))) (build-void214 (lambda (source991) (let ((atom-key992 (fluid-ref *mode*205))) (if (memv atom-key992 (quote (c))) ((@ (language tree-il) make-void) source991) (quote (if #f #f)))))) (get-global-definition-hook213 (lambda (symbol993 module994) (begin (if (if (not module994) (current-module) #f) (warn "module system is booted, we should have a module" symbol993)) (let ((v995 (module-variable (if module994 (resolve-module (cdr module994)) (current-module)) symbol993))) (if v995 (if (variable-bound? v995) (let ((val996 (variable-ref v995))) (if (macro? val996) (if (syncase-macro-type val996) (cons (syncase-macro-type val996) (syncase-macro-binding val996)) #f) #f)) #f) #f))))) (put-global-definition-hook212 (lambda (symbol997 type998 val999) (let ((existing1000 (let ((v1001 (module-variable (current-module) symbol997))) (if v1001 (if (variable-bound? v1001) (let ((val1002 (variable-ref v1001))) (if (macro? val1002) (if (not (syncase-macro-type val1002)) val1002 #f) #f)) #f) #f)))) (module-define! (current-module) symbol997 (if existing1000 (make-extended-syncase-macro existing1000 type998 val999) (make-syncase-macro type998 val999)))))) (local-eval-hook211 (lambda (x1003 mod1004) (primitive-eval (list noexpand204 (let ((atom-key1005 (fluid-ref *mode*205))) (if (memv atom-key1005 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1003) x1003)))))) (top-level-eval-hook210 (lambda (x1006 mod1007) (primitive-eval (list noexpand204 (let ((atom-key1008 (fluid-ref *mode*205))) (if (memv atom-key1008 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1006) x1006)))))) (fx<209 <) (fx=208 =) (fx-207 -) (fx+206 +) (*mode*205 (make-fluid)) (noexpand204 "noexpand")) (begin (global-extend246 (quote local-syntax) (quote letrec-syntax) #t) (global-extend246 (quote local-syntax) (quote let-syntax) #f) (global-extend246 (quote core) (quote fluid-let-syntax) (lambda (e1009 r1010 w1011 s1012 mod1013) ((lambda (tmp1014) ((lambda (tmp1015) (if (if tmp1015 (apply (lambda (_1016 var1017 val1018 e11019 e21020) (valid-bound-ids?273 var1017)) tmp1015) #f) (apply (lambda (_1022 var1023 val1024 e11025 e21026) (let ((names1027 (map (lambda (x1028) (id-var-name270 x1028 w1011)) var1023))) (begin (for-each (lambda (id1030 n1031) (let ((atom-key1032 (binding-type240 (lookup245 n1031 r1010 mod1013)))) (if (memv atom-key1032 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1009 (source-wrap277 id1030 w1011 s1012 mod1013))))) var1023 names1027) (chi-body288 (cons e11025 e21026) (source-wrap277 e1009 w1011 s1012 mod1013) (extend-env242 names1027 (let ((trans-r1035 (macros-only-env244 r1010))) (map (lambda (x1036) (cons (quote macro) (eval-local-transformer291 (chi284 x1036 trans-r1035 w1011 mod1013) mod1013))) val1024)) r1010) w1011 mod1013)))) tmp1015) ((lambda (_1038) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap277 e1009 w1011 s1012 mod1013))) tmp1014))) ($sc-dispatch tmp1014 (quote (any #(each (any any)) any . each-any))))) e1009))) (global-extend246 (quote core) (quote quote) (lambda (e1039 r1040 w1041 s1042 mod1043) ((lambda (tmp1044) ((lambda (tmp1045) (if tmp1045 (apply (lambda (_1046 e1047) (build-data226 s1042 (strip294 e1047 w1041))) tmp1045) ((lambda (_1048) (syntax-violation (quote quote) "bad syntax" (source-wrap277 e1039 w1041 s1042 mod1043))) tmp1044))) ($sc-dispatch tmp1044 (quote (any any))))) e1039))) (global-extend246 (quote core) (quote syntax) (letrec ((regen1056 (lambda (x1057) (let ((atom-key1058 (car x1057))) (if (memv atom-key1058 (quote (ref))) (build-lexical-reference217 (quote value) #f (cadr x1057) (cadr x1057)) (if (memv atom-key1058 (quote (primitive))) (build-primref225 #f (cadr x1057)) (if (memv atom-key1058 (quote (quote))) (build-data226 #f (cadr x1057)) (if (memv atom-key1058 (quote (lambda))) (build-lambda224 #f (cadr x1057) (cadr x1057) #f (regen1056 (caddr x1057))) (build-application215 #f (build-primref225 #f (car x1057)) (map regen1056 (cdr x1057)))))))))) (gen-vector1055 (lambda (x1059) (if (eq? (car x1059) (quote list)) (cons (quote vector) (cdr x1059)) (if (eq? (car x1059) (quote quote)) (list (quote quote) (list->vector (cadr x1059))) (list (quote list->vector) x1059))))) (gen-append1054 (lambda (x1060 y1061) (if (equal? y1061 (quote (quote ()))) x1060 (list (quote append) x1060 y1061)))) (gen-cons1053 (lambda (x1062 y1063) (let ((atom-key1064 (car y1063))) (if (memv atom-key1064 (quote (quote))) (if (eq? (car x1062) (quote quote)) (list (quote quote) (cons (cadr x1062) (cadr y1063))) (if (eq? (cadr y1063) (quote ())) (list (quote list) x1062) (list (quote cons) x1062 y1063))) (if (memv atom-key1064 (quote (list))) (cons (quote list) (cons x1062 (cdr y1063))) (list (quote cons) x1062 y1063)))))) (gen-map1052 (lambda (e1065 map-env1066) (let ((formals1067 (map cdr map-env1066)) (actuals1068 (map (lambda (x1069) (list (quote ref) (car x1069))) map-env1066))) (if (eq? (car e1065) (quote ref)) (car actuals1068) (if (and-map (lambda (x1070) (if (eq? (car x1070) (quote ref)) (memq (cadr x1070) formals1067) #f)) (cdr e1065)) (cons (quote map) (cons (list (quote primitive) (car e1065)) (map (let ((r1071 (map cons formals1067 actuals1068))) (lambda (x1072) (cdr (assq (cadr x1072) r1071)))) (cdr e1065)))) (cons (quote map) (cons (list (quote lambda) formals1067 e1065) actuals1068))))))) (gen-mappend1051 (lambda (e1073 map-env1074) (list (quote apply) (quote (primitive append)) (gen-map1052 e1073 map-env1074)))) (gen-ref1050 (lambda (src1075 var1076 level1077 maps1078) (if (fx=208 level1077 0) (values var1076 maps1078) (if (null? maps1078) (syntax-violation (quote syntax) "missing ellipsis" src1075) (call-with-values (lambda () (gen-ref1050 src1075 var1076 (fx-207 level1077 1) (cdr maps1078))) (lambda (outer-var1079 outer-maps1080) (let ((b1081 (assq outer-var1079 (car maps1078)))) (if b1081 (values (cdr b1081) maps1078) (let ((inner-var1082 (gen-var295 (quote tmp)))) (values inner-var1082 (cons (cons (cons outer-var1079 inner-var1082) (car maps1078)) outer-maps1080))))))))))) (gen-syntax1049 (lambda (src1083 e1084 r1085 maps1086 ellipsis?1087 mod1088) (if (id?248 e1084) (let ((label1089 (id-var-name270 e1084 (quote (()))))) (let ((b1090 (lookup245 label1089 r1085 mod1088))) (if (eq? (binding-type240 b1090) (quote syntax)) (call-with-values (lambda () (let ((var.lev1091 (binding-value241 b1090))) (gen-ref1050 src1083 (car var.lev1091) (cdr var.lev1091) maps1086))) (lambda (var1092 maps1093) (values (list (quote ref) var1092) maps1093))) (if (ellipsis?1087 e1084) (syntax-violation (quote syntax) "misplaced ellipsis" src1083) (values (list (quote quote) e1084) maps1086))))) ((lambda (tmp1094) ((lambda (tmp1095) (if (if tmp1095 (apply (lambda (dots1096 e1097) (ellipsis?1087 dots1096)) tmp1095) #f) (apply (lambda (dots1098 e1099) (gen-syntax1049 src1083 e1099 r1085 maps1086 (lambda (x1100) #f) mod1088)) tmp1095) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (x1102 dots1103 y1104) (ellipsis?1087 dots1103)) tmp1101) #f) (apply (lambda (x1105 dots1106 y1107) (letrec ((f1108 (lambda (y1109 k1110) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (dots1116 y1117) (ellipsis?1087 dots1116)) tmp1115) #f) (apply (lambda (dots1118 y1119) (f1108 y1119 (lambda (maps1120) (call-with-values (lambda () (k1110 (cons (quote ()) maps1120))) (lambda (x1121 maps1122) (if (null? (car maps1122)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-mappend1051 x1121 (car maps1122)) (cdr maps1122)))))))) tmp1115) ((lambda (_1123) (call-with-values (lambda () (gen-syntax1049 src1083 y1109 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (y1124 maps1125) (call-with-values (lambda () (k1110 maps1125)) (lambda (x1126 maps1127) (values (gen-append1054 x1126 y1124) maps1127)))))) tmp1114))) ($sc-dispatch tmp1114 (quote (any . any))))) y1109)))) (f1108 y1107 (lambda (maps1111) (call-with-values (lambda () (gen-syntax1049 src1083 x1105 r1085 (cons (quote ()) maps1111) ellipsis?1087 mod1088)) (lambda (x1112 maps1113) (if (null? (car maps1113)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-map1052 x1112 (car maps1113)) (cdr maps1113))))))))) tmp1101) ((lambda (tmp1128) (if tmp1128 (apply (lambda (x1129 y1130) (call-with-values (lambda () (gen-syntax1049 src1083 x1129 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (x1131 maps1132) (call-with-values (lambda () (gen-syntax1049 src1083 y1130 r1085 maps1132 ellipsis?1087 mod1088)) (lambda (y1133 maps1134) (values (gen-cons1053 x1131 y1133) maps1134)))))) tmp1128) ((lambda (tmp1135) (if tmp1135 (apply (lambda (e11136 e21137) (call-with-values (lambda () (gen-syntax1049 src1083 (cons e11136 e21137) r1085 maps1086 ellipsis?1087 mod1088)) (lambda (e1139 maps1140) (values (gen-vector1055 e1139) maps1140)))) tmp1135) ((lambda (_1141) (values (list (quote quote) e1084) maps1086)) tmp1094))) ($sc-dispatch tmp1094 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1094 (quote (any . any)))))) ($sc-dispatch tmp1094 (quote (any any . any)))))) ($sc-dispatch tmp1094 (quote (any any))))) e1084))))) (lambda (e1142 r1143 w1144 s1145 mod1146) (let ((e1147 (source-wrap277 e1142 w1144 s1145 mod1146))) ((lambda (tmp1148) ((lambda (tmp1149) (if tmp1149 (apply (lambda (_1150 x1151) (call-with-values (lambda () (gen-syntax1049 e1147 x1151 r1143 (quote ()) ellipsis?293 mod1146)) (lambda (e1152 maps1153) (regen1056 e1152)))) tmp1149) ((lambda (_1154) (syntax-violation (quote syntax) "bad `syntax' form" e1147)) tmp1148))) ($sc-dispatch tmp1148 (quote (any any))))) e1147))))) (global-extend246 (quote core) (quote lambda) (lambda (e1155 r1156 w1157 s1158 mod1159) ((lambda (tmp1160) ((lambda (tmp1161) (if tmp1161 (apply (lambda (_1162 c1163) (chi-lambda-clause289 (source-wrap277 e1155 w1157 s1158 mod1159) #f c1163 r1156 w1157 mod1159 (lambda (names1164 vars1165 docstring1166 body1167) (build-lambda224 s1158 names1164 vars1165 docstring1166 body1167)))) tmp1161) (syntax-violation #f "source expression failed to match any pattern" tmp1160))) ($sc-dispatch tmp1160 (quote (any . any))))) e1155))) (global-extend246 (quote core) (quote let) (letrec ((chi-let1168 (lambda (e1169 r1170 w1171 s1172 mod1173 constructor1174 ids1175 vals1176 exps1177) (if (not (valid-bound-ids?273 ids1175)) (syntax-violation (quote let) "duplicate bound variable" e1169) (let ((labels1178 (gen-labels254 ids1175)) (new-vars1179 (map gen-var295 ids1175))) (let ((nw1180 (make-binding-wrap265 ids1175 labels1178 w1171)) (nr1181 (extend-var-env243 labels1178 new-vars1179 r1170))) (constructor1174 s1172 (map syntax->datum ids1175) new-vars1179 (map (lambda (x1182) (chi284 x1182 r1170 w1171 mod1173)) vals1176) (chi-body288 exps1177 (source-wrap277 e1169 nw1180 s1172 mod1173) nr1181 nw1180 mod1173)))))))) (lambda (e1183 r1184 w1185 s1186 mod1187) ((lambda (tmp1188) ((lambda (tmp1189) (if (if tmp1189 (apply (lambda (_1190 id1191 val1192 e11193 e21194) (and-map id?248 id1191)) tmp1189) #f) (apply (lambda (_1196 id1197 val1198 e11199 e21200) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-let228 id1197 val1198 (cons e11199 e21200))) tmp1189) ((lambda (tmp1204) (if (if tmp1204 (apply (lambda (_1205 f1206 id1207 val1208 e11209 e21210) (if (id?248 f1206) (and-map id?248 id1207) #f)) tmp1204) #f) (apply (lambda (_1212 f1213 id1214 val1215 e11216 e21217) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-named-let229 (cons f1213 id1214) val1215 (cons e11216 e21217))) tmp1204) ((lambda (_1221) (syntax-violation (quote let) "bad let" (source-wrap277 e1183 w1185 s1186 mod1187))) tmp1188))) ($sc-dispatch tmp1188 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1188 (quote (any #(each (any any)) any . each-any))))) e1183)))) (global-extend246 (quote core) (quote letrec) (lambda (e1222 r1223 w1224 s1225 mod1226) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (_1229 id1230 val1231 e11232 e21233) (and-map id?248 id1230)) tmp1228) #f) (apply (lambda (_1235 id1236 val1237 e11238 e21239) (let ((ids1240 id1236)) (if (not (valid-bound-ids?273 ids1240)) (syntax-violation (quote letrec) "duplicate bound variable" e1222) (let ((labels1242 (gen-labels254 ids1240)) (new-vars1243 (map gen-var295 ids1240))) (let ((w1244 (make-binding-wrap265 ids1240 labels1242 w1224)) (r1245 (extend-var-env243 labels1242 new-vars1243 r1223))) (build-letrec230 s1225 (map syntax->datum ids1240) new-vars1243 (map (lambda (x1246) (chi284 x1246 r1245 w1244 mod1226)) val1237) (chi-body288 (cons e11238 e21239) (source-wrap277 e1222 w1244 s1225 mod1226) r1245 w1244 mod1226))))))) tmp1228) ((lambda (_1249) (syntax-violation (quote letrec) "bad letrec" (source-wrap277 e1222 w1224 s1225 mod1226))) tmp1227))) ($sc-dispatch tmp1227 (quote (any #(each (any any)) any . each-any))))) e1222))) (global-extend246 (quote core) (quote set!) (lambda (e1250 r1251 w1252 s1253 mod1254) ((lambda (tmp1255) ((lambda (tmp1256) (if (if tmp1256 (apply (lambda (_1257 id1258 val1259) (id?248 id1258)) tmp1256) #f) (apply (lambda (_1260 id1261 val1262) (let ((val1263 (chi284 val1262 r1251 w1252 mod1254)) (n1264 (id-var-name270 id1261 w1252))) (let ((b1265 (lookup245 n1264 r1251 mod1254))) (let ((atom-key1266 (binding-type240 b1265))) (if (memv atom-key1266 (quote (lexical))) (build-lexical-assignment218 s1253 (syntax->datum id1261) (binding-value241 b1265) val1263) (if (memv atom-key1266 (quote (global))) (build-global-assignment221 s1253 n1264 val1263 mod1254) (if (memv atom-key1266 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap276 id1261 w1252 mod1254)) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))))))))) tmp1256) ((lambda (tmp1267) (if tmp1267 (apply (lambda (_1268 head1269 tail1270 val1271) (call-with-values (lambda () (syntax-type282 head1269 r1251 (quote (())) #f #f mod1254)) (lambda (type1272 value1273 ee1274 ww1275 ss1276 modmod1277) (if (memv type1272 (quote (module-ref))) (let ((val1278 (chi284 val1271 r1251 w1252 mod1254))) (call-with-values (lambda () (value1273 (cons head1269 tail1270))) (lambda (id1280 mod1281) (build-global-assignment221 s1253 id1280 val1278 mod1281)))) (build-application215 s1253 (chi284 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1269) r1251 w1252 mod1254) (map (lambda (e1282) (chi284 e1282 r1251 w1252 mod1254)) (append tail1270 (list val1271)))))))) tmp1267) ((lambda (_1284) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))) tmp1255))) ($sc-dispatch tmp1255 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1255 (quote (any any any))))) e1250))) (global-extend246 (quote module-ref) (quote @) (lambda (e1285) ((lambda (tmp1286) ((lambda (tmp1287) (if (if tmp1287 (apply (lambda (_1288 mod1289 id1290) (if (and-map id?248 mod1289) (id?248 id1290) #f)) tmp1287) #f) (apply (lambda (_1292 mod1293 id1294) (values (syntax->datum id1294) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1293)))) tmp1287) (syntax-violation #f "source expression failed to match any pattern" tmp1286))) ($sc-dispatch tmp1286 (quote (any each-any any))))) e1285))) (global-extend246 (quote module-ref) (quote @@) (lambda (e1296) ((lambda (tmp1297) ((lambda (tmp1298) (if (if tmp1298 (apply (lambda (_1299 mod1300 id1301) (if (and-map id?248 mod1300) (id?248 id1301) #f)) tmp1298) #f) (apply (lambda (_1303 mod1304 id1305) (values (syntax->datum id1305) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1304)))) tmp1298) (syntax-violation #f "source expression failed to match any pattern" tmp1297))) ($sc-dispatch tmp1297 (quote (any each-any any))))) e1296))) (global-extend246 (quote core) (quote if) (lambda (e1307 r1308 w1309 s1310 mod1311) ((lambda (tmp1312) ((lambda (tmp1313) (if tmp1313 (apply (lambda (_1314 test1315 then1316) (build-conditional216 s1310 (chi284 test1315 r1308 w1309 mod1311) (chi284 then1316 r1308 w1309 mod1311) (build-void214 #f))) tmp1313) ((lambda (tmp1317) (if tmp1317 (apply (lambda (_1318 test1319 then1320 else1321) (build-conditional216 s1310 (chi284 test1319 r1308 w1309 mod1311) (chi284 then1320 r1308 w1309 mod1311) (chi284 else1321 r1308 w1309 mod1311))) tmp1317) (syntax-violation #f "source expression failed to match any pattern" tmp1312))) ($sc-dispatch tmp1312 (quote (any any any any)))))) ($sc-dispatch tmp1312 (quote (any any any))))) e1307))) (global-extend246 (quote begin) (quote begin) (quote ())) (global-extend246 (quote define) (quote define) (quote ())) (global-extend246 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend246 (quote eval-when) (quote eval-when) (quote ())) (global-extend246 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1325 (lambda (x1326 keys1327 clauses1328 r1329 mod1330) (if (null? clauses1328) (build-application215 #f (build-primref225 #f (quote syntax-violation)) (list (build-data226 #f #f) (build-data226 #f "source expression failed to match any pattern") x1326)) ((lambda (tmp1331) ((lambda (tmp1332) (if tmp1332 (apply (lambda (pat1333 exp1334) (if (if (id?248 pat1333) (and-map (lambda (x1335) (not (free-id=?271 pat1333 x1335))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1327)) #f) (let ((labels1336 (list (gen-label253))) (var1337 (gen-var295 pat1333))) (build-application215 #f (build-lambda224 #f (list (syntax->datum pat1333)) (list var1337) #f (chi284 exp1334 (extend-env242 labels1336 (list (cons (quote syntax) (cons var1337 0))) r1329) (make-binding-wrap265 (list pat1333) labels1336 (quote (()))) mod1330)) (list x1326))) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1333 #t exp1334 mod1330))) tmp1332) ((lambda (tmp1338) (if tmp1338 (apply (lambda (pat1339 fender1340 exp1341) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1339 fender1340 exp1341 mod1330)) tmp1338) ((lambda (_1342) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1328))) tmp1331))) ($sc-dispatch tmp1331 (quote (any any any)))))) ($sc-dispatch tmp1331 (quote (any any))))) (car clauses1328))))) (gen-clause1324 (lambda (x1343 keys1344 clauses1345 r1346 pat1347 fender1348 exp1349 mod1350) (call-with-values (lambda () (convert-pattern1322 pat1347 keys1344)) (lambda (p1351 pvars1352) (if (not (distinct-bound-ids?274 (map car pvars1352))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1347) (if (not (and-map (lambda (x1353) (not (ellipsis?293 (car x1353)))) pvars1352)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1347) (let ((y1354 (gen-var295 (quote tmp)))) (build-application215 #f (build-lambda224 #f (list (quote tmp)) (list y1354) #f (let ((y1355 (build-lexical-reference217 (quote value) #f (quote tmp) y1354))) (build-conditional216 #f ((lambda (tmp1356) ((lambda (tmp1357) (if tmp1357 (apply (lambda () y1355) tmp1357) ((lambda (_1358) (build-conditional216 #f y1355 (build-dispatch-call1323 pvars1352 fender1348 y1355 r1346 mod1350) (build-data226 #f #f))) tmp1356))) ($sc-dispatch tmp1356 (quote #(atom #t))))) fender1348) (build-dispatch-call1323 pvars1352 exp1349 y1355 r1346 mod1350) (gen-syntax-case1325 x1343 keys1344 clauses1345 r1346 mod1350)))) (list (if (eq? p1351 (quote any)) (build-application215 #f (build-primref225 #f (quote list)) (list x1343)) (build-application215 #f (build-primref225 #f (quote $sc-dispatch)) (list x1343 (build-data226 #f p1351))))))))))))) (build-dispatch-call1323 (lambda (pvars1359 exp1360 y1361 r1362 mod1363) (let ((ids1364 (map car pvars1359)) (levels1365 (map cdr pvars1359))) (let ((labels1366 (gen-labels254 ids1364)) (new-vars1367 (map gen-var295 ids1364))) (build-application215 #f (build-primref225 #f (quote apply)) (list (build-lambda224 #f (map syntax->datum ids1364) new-vars1367 #f (chi284 exp1360 (extend-env242 labels1366 (map (lambda (var1368 level1369) (cons (quote syntax) (cons var1368 level1369))) new-vars1367 (map cdr pvars1359)) r1362) (make-binding-wrap265 ids1364 labels1366 (quote (()))) mod1363)) y1361)))))) (convert-pattern1322 (lambda (pattern1370 keys1371) (letrec ((cvt1372 (lambda (p1373 n1374 ids1375) (if (id?248 p1373) (if (bound-id-member?275 p1373 keys1371) (values (vector (quote free-id) p1373) ids1375) (values (quote any) (cons (cons p1373 n1374) ids1375))) ((lambda (tmp1376) ((lambda (tmp1377) (if (if tmp1377 (apply (lambda (x1378 dots1379) (ellipsis?293 dots1379)) tmp1377) #f) (apply (lambda (x1380 dots1381) (call-with-values (lambda () (cvt1372 x1380 (fx+206 n1374 1) ids1375)) (lambda (p1382 ids1383) (values (if (eq? p1382 (quote any)) (quote each-any) (vector (quote each) p1382)) ids1383)))) tmp1377) ((lambda (tmp1384) (if tmp1384 (apply (lambda (x1385 y1386) (call-with-values (lambda () (cvt1372 y1386 n1374 ids1375)) (lambda (y1387 ids1388) (call-with-values (lambda () (cvt1372 x1385 n1374 ids1388)) (lambda (x1389 ids1390) (values (cons x1389 y1387) ids1390)))))) tmp1384) ((lambda (tmp1391) (if tmp1391 (apply (lambda () (values (quote ()) ids1375)) tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (x1393) (call-with-values (lambda () (cvt1372 x1393 n1374 ids1375)) (lambda (p1395 ids1396) (values (vector (quote vector) p1395) ids1396)))) tmp1392) ((lambda (x1397) (values (vector (quote atom) (strip294 p1373 (quote (())))) ids1375)) tmp1376))) ($sc-dispatch tmp1376 (quote #(vector each-any)))))) ($sc-dispatch tmp1376 (quote ()))))) ($sc-dispatch tmp1376 (quote (any . any)))))) ($sc-dispatch tmp1376 (quote (any any))))) p1373))))) (cvt1372 pattern1370 0 (quote ())))))) (lambda (e1398 r1399 w1400 s1401 mod1402) (let ((e1403 (source-wrap277 e1398 w1400 s1401 mod1402))) ((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (_1406 val1407 key1408 m1409) (if (and-map (lambda (x1410) (if (id?248 x1410) (not (ellipsis?293 x1410)) #f)) key1408) (let ((x1412 (gen-var295 (quote tmp)))) (build-application215 s1401 (build-lambda224 #f (list (quote tmp)) (list x1412) #f (gen-syntax-case1325 (build-lexical-reference217 (quote value) #f (quote tmp) x1412) key1408 m1409 r1399 mod1402)) (list (chi284 val1407 r1399 (quote (())) mod1402)))) (syntax-violation (quote syntax-case) "invalid literals list" e1403))) tmp1405) (syntax-violation #f "source expression failed to match any pattern" tmp1404))) ($sc-dispatch tmp1404 (quote (any any each-any . each-any))))) e1403))))) (set! sc-expand (lambda (x1416 . rest1415) (if (if (pair? x1416) (equal? (car x1416) noexpand204) #f) (cadr x1416) (let ((m1417 (if (null? rest1415) (quote e) (car rest1415))) (esew1418 (if (let ((t1419 (null? rest1415))) (if t1419 t1419 (null? (cdr rest1415)))) (quote (eval)) (cadr rest1415)))) (with-fluid* *mode*205 m1417 (lambda () (chi-top283 x1416 (quote ()) (quote ((top))) m1417 esew1418 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1420) (nonsymbol-id?247 x1420))) (set! datum->syntax (lambda (id1421 datum1422) (make-syntax-object231 datum1422 (syntax-object-wrap234 id1421) #f))) (set! syntax->datum (lambda (x1423) (strip294 x1423 (quote (()))))) (set! generate-temporaries (lambda (ls1424) (begin (let ((x1425 ls1424)) (if (not (list? x1425)) (syntax-violation (quote generate-temporaries) "invalid argument" x1425))) (map (lambda (x1426) (wrap276 (gensym) (quote ((top))) #f)) ls1424)))) (set! free-identifier=? (lambda (x1427 y1428) (begin (let ((x1429 x1427)) (if (not (nonsymbol-id?247 x1429)) (syntax-violation (quote free-identifier=?) "invalid argument" x1429))) (let ((x1430 y1428)) (if (not (nonsymbol-id?247 x1430)) (syntax-violation (quote free-identifier=?) "invalid argument" x1430))) (free-id=?271 x1427 y1428)))) (set! bound-identifier=? (lambda (x1431 y1432) (begin (let ((x1433 x1431)) (if (not (nonsymbol-id?247 x1433)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1433))) (let ((x1434 y1432)) (if (not (nonsymbol-id?247 x1434)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1434))) (bound-id=?272 x1431 y1432)))) (set! syntax-violation (lambda (who1438 message1437 form1436 . subform1435) (begin (let ((x1439 who1438)) (if (not ((lambda (x1440) (let ((t1441 (not x1440))) (if t1441 t1441 (let ((t1442 (string? x1440))) (if t1442 t1442 (symbol? x1440)))))) x1439)) (syntax-violation (quote syntax-violation) "invalid argument" x1439))) (let ((x1443 message1437)) (if (not (string? x1443)) (syntax-violation (quote syntax-violation) "invalid argument" x1443))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1438 "~a: " "") "~a " (if (null? subform1435) "in ~a" "in subform `~s' of `~s'")) (let ((tail1444 (cons message1437 (map (lambda (x1445) (strip294 x1445 (quote (())))) (append subform1435 (list form1436)))))) (if who1438 (cons who1438 tail1444) tail1444)) #f)))) (letrec ((match1450 (lambda (e1451 p1452 w1453 r1454 mod1455) (if (not r1454) #f (if (eq? p1452 (quote any)) (cons (wrap276 e1451 w1453 mod1455) r1454) (if (syntax-object?232 e1451) (match*1449 (syntax-object-expression233 e1451) p1452 (join-wraps267 w1453 (syntax-object-wrap234 e1451)) r1454 (syntax-object-module235 e1451)) (match*1449 e1451 p1452 w1453 r1454 mod1455)))))) (match*1449 (lambda (e1456 p1457 w1458 r1459 mod1460) (if (null? p1457) (if (null? e1456) r1459 #f) (if (pair? p1457) (if (pair? e1456) (match1450 (car e1456) (car p1457) w1458 (match1450 (cdr e1456) (cdr p1457) w1458 r1459 mod1460) mod1460) #f) (if (eq? p1457 (quote each-any)) (let ((l1461 (match-each-any1447 e1456 w1458 mod1460))) (if l1461 (cons l1461 r1459) #f)) (let ((atom-key1462 (vector-ref p1457 0))) (if (memv atom-key1462 (quote (each))) (if (null? e1456) (match-empty1448 (vector-ref p1457 1) r1459) (let ((l1463 (match-each1446 e1456 (vector-ref p1457 1) w1458 mod1460))) (if l1463 (letrec ((collect1464 (lambda (l1465) (if (null? (car l1465)) r1459 (cons (map car l1465) (collect1464 (map cdr l1465))))))) (collect1464 l1463)) #f))) (if (memv atom-key1462 (quote (free-id))) (if (id?248 e1456) (if (free-id=?271 (wrap276 e1456 w1458 mod1460) (vector-ref p1457 1)) r1459 #f) #f) (if (memv atom-key1462 (quote (atom))) (if (equal? (vector-ref p1457 1) (strip294 e1456 w1458)) r1459 #f) (if (memv atom-key1462 (quote (vector))) (if (vector? e1456) (match1450 (vector->list e1456) (vector-ref p1457 1) w1458 r1459 mod1460) #f))))))))))) (match-empty1448 (lambda (p1466 r1467) (if (null? p1466) r1467 (if (eq? p1466 (quote any)) (cons (quote ()) r1467) (if (pair? p1466) (match-empty1448 (car p1466) (match-empty1448 (cdr p1466) r1467)) (if (eq? p1466 (quote each-any)) (cons (quote ()) r1467) (let ((atom-key1468 (vector-ref p1466 0))) (if (memv atom-key1468 (quote (each))) (match-empty1448 (vector-ref p1466 1) r1467) (if (memv atom-key1468 (quote (free-id atom))) r1467 (if (memv atom-key1468 (quote (vector))) (match-empty1448 (vector-ref p1466 1) r1467))))))))))) (match-each-any1447 (lambda (e1469 w1470 mod1471) (if (pair? e1469) (let ((l1472 (match-each-any1447 (cdr e1469) w1470 mod1471))) (if l1472 (cons (wrap276 (car e1469) w1470 mod1471) l1472) #f)) (if (null? e1469) (quote ()) (if (syntax-object?232 e1469) (match-each-any1447 (syntax-object-expression233 e1469) (join-wraps267 w1470 (syntax-object-wrap234 e1469)) mod1471) #f))))) (match-each1446 (lambda (e1473 p1474 w1475 mod1476) (if (pair? e1473) (let ((first1477 (match1450 (car e1473) p1474 w1475 (quote ()) mod1476))) (if first1477 (let ((rest1478 (match-each1446 (cdr e1473) p1474 w1475 mod1476))) (if rest1478 (cons first1477 rest1478) #f)) #f)) (if (null? e1473) (quote ()) (if (syntax-object?232 e1473) (match-each1446 (syntax-object-expression233 e1473) p1474 (join-wraps267 w1475 (syntax-object-wrap234 e1473)) (syntax-object-module235 e1473)) #f)))))) (set! $sc-dispatch (lambda (e1479 p1480) (if (eq? p1480 (quote any)) (list e1479) (if (syntax-object?232 e1479) (match*1449 (syntax-object-expression233 e1479) p1480 (syntax-object-wrap234 e1479) (quote ()) (syntax-object-module235 e1479)) (match*1449 e1479 p1480 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1481) ((lambda (tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (_1484 e11485 e21486) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11485 e21486))) tmp1483) ((lambda (tmp1488) (if tmp1488 (apply (lambda (_1489 out1490 in1491 e11492 e21493) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1491 (quote ()) (list out1490 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11492 e21493))))) tmp1488) ((lambda (tmp1495) (if tmp1495 (apply (lambda (_1496 out1497 in1498 e11499 e21500) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1498) (quote ()) (list out1497 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11499 e21500))))) tmp1495) (syntax-violation #f "source expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any () any . each-any))))) x1481)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 k1508 keyword1509 pattern1510 template1511) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1508 (map (lambda (tmp1514 tmp1513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1514))) template1511 pattern1510)))))) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any each-any . #(each ((any . any) any))))))) x1504)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if (if tmp1517 (apply (lambda (let*1518 x1519 v1520 e11521 e21522) (and-map identifier? x1519)) tmp1517) #f) (apply (lambda (let*1524 x1525 v1526 e11527 e21528) (letrec ((f1529 (lambda (bindings1530) (if (null? bindings1530) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11527 e21528))) ((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (body1536 binding1537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1537) body1536)) tmp1535) (syntax-violation #f "source expression failed to match any pattern" tmp1534))) ($sc-dispatch tmp1534 (quote (any any))))) (list (f1529 (cdr bindings1530)) (car bindings1530))))))) (f1529 (map list x1525 v1526)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any #(each (any any)) any . each-any))))) x1515)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1538) ((lambda (tmp1539) ((lambda (tmp1540) (if tmp1540 (apply (lambda (_1541 var1542 init1543 step1544 e01545 e11546 c1547) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (step1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1552) ((lambda (tmp1557) (if tmp1557 (apply (lambda (e11558 e21559) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11558 e21559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1557) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any . each-any)))))) ($sc-dispatch tmp1551 (quote ())))) e11546)) tmp1549) (syntax-violation #f "source expression failed to match any pattern" tmp1548))) ($sc-dispatch tmp1548 (quote each-any)))) (map (lambda (v1566 s1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply (lambda () v1566) tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (e1571) e1571) tmp1570) ((lambda (_1572) (syntax-violation (quote do) "bad step expression" orig-x1538 s1567)) tmp1568))) ($sc-dispatch tmp1568 (quote (any)))))) ($sc-dispatch tmp1568 (quote ())))) s1567)) var1542 step1544))) tmp1540) (syntax-violation #f "source expression failed to match any pattern" tmp1539))) ($sc-dispatch tmp1539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1538)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1575 (lambda (x1579 y1580) ((lambda (tmp1581) ((lambda (tmp1582) (if tmp1582 (apply (lambda (x1583 y1584) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (dy1587) ((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (dx1590) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1590 dy1587))) tmp1589) ((lambda (_1591) (if (null? dy1587) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584))) tmp1588))) ($sc-dispatch tmp1588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1583)) tmp1586) ((lambda (tmp1592) (if tmp1592 (apply (lambda (stuff1593) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1583 stuff1593))) tmp1592) ((lambda (else1594) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584)) tmp1585))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1584)) tmp1582) (syntax-violation #f "source expression failed to match any pattern" tmp1581))) ($sc-dispatch tmp1581 (quote (any any))))) (list x1579 y1580)))) (quasiappend1576 (lambda (x1595 y1596) ((lambda (tmp1597) ((lambda (tmp1598) (if tmp1598 (apply (lambda (x1599 y1600) ((lambda (tmp1601) ((lambda (tmp1602) (if tmp1602 (apply (lambda () x1599) tmp1602) ((lambda (_1603) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1599 y1600)) tmp1601))) ($sc-dispatch tmp1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1600)) tmp1598) (syntax-violation #f "source expression failed to match any pattern" tmp1597))) ($sc-dispatch tmp1597 (quote (any any))))) (list x1595 y1596)))) (quasivector1577 (lambda (x1604) ((lambda (tmp1605) ((lambda (x1606) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (x1609) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1609))) tmp1608) ((lambda (tmp1611) (if tmp1611 (apply (lambda (x1612) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1612)) tmp1611) ((lambda (_1614) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1606)) tmp1607))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1606)) tmp1605)) x1604))) (quasi1578 (lambda (p1615 lev1616) ((lambda (tmp1617) ((lambda (tmp1618) (if tmp1618 (apply (lambda (p1619) (if (= lev1616 0) p1619 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1619) (- lev1616 1))))) tmp1618) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (args1621) (= lev1616 0)) tmp1620) #f) (apply (lambda (args1622) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1615 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1622))) tmp1620) ((lambda (tmp1623) (if tmp1623 (apply (lambda (p1624 q1625) (if (= lev1616 0) (quasiappend1576 p1624 (quasi1578 q1625 lev1616)) (quasicons1575 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1624) (- lev1616 1))) (quasi1578 q1625 lev1616)))) tmp1623) ((lambda (tmp1626) (if (if tmp1626 (apply (lambda (args1627 q1628) (= lev1616 0)) tmp1626) #f) (apply (lambda (args1629 q1630) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1615 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1629))) tmp1626) ((lambda (tmp1631) (if tmp1631 (apply (lambda (p1632) (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1632) (+ lev1616 1)))) tmp1631) ((lambda (tmp1633) (if tmp1633 (apply (lambda (p1634 q1635) (quasicons1575 (quasi1578 p1634 lev1616) (quasi1578 q1635 lev1616))) tmp1633) ((lambda (tmp1636) (if tmp1636 (apply (lambda (x1637) (quasivector1577 (quasi1578 x1637 lev1616))) tmp1636) ((lambda (p1639) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1639)) tmp1617))) ($sc-dispatch tmp1617 (quote #(vector each-any)))))) ($sc-dispatch tmp1617 (quote (any . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1615)))) (lambda (x1640) ((lambda (tmp1641) ((lambda (tmp1642) (if tmp1642 (apply (lambda (_1643 e1644) (quasi1578 e1644 0)) tmp1642) (syntax-violation #f "source expression failed to match any pattern" tmp1641))) ($sc-dispatch tmp1641 (quote (any any))))) x1640))))) -(define include (make-syncase-macro (quote macro) (lambda (x1645) (letrec ((read-file1646 (lambda (fn1647 k1648) (let ((p1649 (open-input-file fn1647))) (letrec ((f1650 (lambda (x1651) (if (eof-object? x1651) (begin (close-input-port p1649) (quote ())) (cons (datum->syntax k1648 x1651) (f1650 (read p1649))))))) (f1650 (read p1649))))))) ((lambda (tmp1652) ((lambda (tmp1653) (if tmp1653 (apply (lambda (k1654 filename1655) (let ((fn1656 (syntax->datum filename1655))) ((lambda (tmp1657) ((lambda (tmp1658) (if tmp1658 (apply (lambda (exp1659) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1659)) tmp1658) (syntax-violation #f "source expression failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote each-any)))) (read-file1646 fn1656 k1654)))) tmp1653) (syntax-violation #f "source expression failed to match any pattern" tmp1652))) ($sc-dispatch tmp1652 (quote (any any))))) x1645))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1661) ((lambda (tmp1662) ((lambda (tmp1663) (if tmp1663 (apply (lambda (_1664 e1665) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1661)) tmp1663) (syntax-violation #f "source expression failed to match any pattern" tmp1662))) ($sc-dispatch tmp1662 (quote (any any))))) x1661)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1666) ((lambda (tmp1667) ((lambda (tmp1668) (if tmp1668 (apply (lambda (_1669 e1670) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1666)) tmp1668) (syntax-violation #f "source expression failed to match any pattern" tmp1667))) ($sc-dispatch tmp1667 (quote (any any))))) x1666)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1671) ((lambda (tmp1672) ((lambda (tmp1673) (if tmp1673 (apply (lambda (_1674 e1675 m11676 m21677) ((lambda (tmp1678) ((lambda (body1679) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1675)) body1679)) tmp1678)) (letrec ((f1680 (lambda (clause1681 clauses1682) (if (null? clauses1682) ((lambda (tmp1684) ((lambda (tmp1685) (if tmp1685 (apply (lambda (e11686 e21687) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11686 e21687))) tmp1685) ((lambda (tmp1689) (if tmp1689 (apply (lambda (k1690 e11691 e21692) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1690)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11691 e21692)))) tmp1689) ((lambda (_1695) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1684))) ($sc-dispatch tmp1684 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1684 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1681) ((lambda (tmp1696) ((lambda (rest1697) ((lambda (tmp1698) ((lambda (tmp1699) (if tmp1699 (apply (lambda (k1700 e11701 e21702) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1700)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11701 e21702)) rest1697)) tmp1699) ((lambda (_1705) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1698))) ($sc-dispatch tmp1698 (quote (each-any any . each-any))))) clause1681)) tmp1696)) (f1680 (car clauses1682) (cdr clauses1682))))))) (f1680 m11676 m21677)))) tmp1673) (syntax-violation #f "source expression failed to match any pattern" tmp1672))) ($sc-dispatch tmp1672 (quote (any any any . each-any))))) x1671)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1706) ((lambda (tmp1707) ((lambda (tmp1708) (if tmp1708 (apply (lambda (_1709 e1710) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1710)) (list (cons _1709 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1710 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1708) (syntax-violation #f "source expression failed to match any pattern" tmp1707))) ($sc-dispatch tmp1707 (quote (any any))))) x1706)))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars286) (letrec ((lvl287 (lambda (vars288 ls289 w290) (if (pair? vars288) (lvl287 (cdr vars288) (cons (wrap142 (car vars288) w290 #f) ls289) w290) (if (id?114 vars288) (cons (wrap142 vars288 w290 #f) ls289) (if (null? vars288) ls289 (if (syntax-object?98 vars288) (lvl287 (syntax-object-expression99 vars288) ls289 (join-wraps133 w290 (syntax-object-wrap100 vars288))) (cons vars288 ls289)))))))) (lvl287 vars286 (quote ()) (quote (())))))) (gen-var161 (lambda (id291) (let ((id292 (if (syntax-object?98 id291) (syntax-object-expression99 id291) id291))) (gensym (symbol->string id292))))) (strip160 (lambda (x293 w294) (if (memq (quote top) (wrap-marks117 w294)) x293 (letrec ((f295 (lambda (x296) (if (syntax-object?98 x296) (strip160 (syntax-object-expression99 x296) (syntax-object-wrap100 x296)) (if (pair? x296) (let ((a297 (f295 (car x296))) (d298 (f295 (cdr x296)))) (if (if (eq? a297 (car x296)) (eq? d298 (cdr x296)) #f) x296 (cons a297 d298))) (if (vector? x296) (let ((old299 (vector->list x296))) (let ((new300 (map f295 old299))) (if (and-map*17 eq? old299 new300) x296 (list->vector new300)))) x296)))))) (f295 x293))))) (ellipsis?159 (lambda (x301) (if (nonsymbol-id?113 x301) (free-id=?137 x301 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded302 mod303) (let ((p304 (local-eval-hook77 expanded302 mod303))) (if (procedure? p304) p304 (syntax-violation #f "nonprocedure transformer" p304))))) (chi-local-syntax156 (lambda (rec?305 e306 r307 w308 s309 mod310 k311) ((lambda (tmp312) ((lambda (tmp313) (if tmp313 (apply (lambda (_314 id315 val316 e1317 e2318) (let ((ids319 id315)) (if (not (valid-bound-ids?139 ids319)) (syntax-violation #f "duplicate bound keyword" e306) (let ((labels321 (gen-labels120 ids319))) (let ((new-w322 (make-binding-wrap131 ids319 labels321 w308))) (k311 (cons e1317 e2318) (extend-env108 labels321 (let ((w324 (if rec?305 new-w322 w308)) (trans-r325 (macros-only-env110 r307))) (map (lambda (x326) (cons (quote macro) (eval-local-transformer157 (chi150 x326 trans-r325 w324 mod310) mod310))) val316)) r307) new-w322 s309 mod310)))))) tmp313) ((lambda (_328) (syntax-violation #f "bad local syntax definition" (source-wrap143 e306 w308 s309 mod310))) tmp312))) ($sc-dispatch tmp312 (quote (any #(each (any any)) any . each-any))))) e306))) (chi-lambda-clause155 (lambda (e329 docstring330 c331 r332 w333 mod334 k335) ((lambda (tmp336) ((lambda (tmp337) (if (if tmp337 (apply (lambda (args338 doc339 e1340 e2341) (if (string? (syntax->datum doc339)) (not docstring330) #f)) tmp337) #f) (apply (lambda (args342 doc343 e1344 e2345) (chi-lambda-clause155 e329 doc343 (cons args342 (cons e1344 e2345)) r332 w333 mod334 k335)) tmp337) ((lambda (tmp347) (if tmp347 (apply (lambda (id348 e1349 e2350) (let ((ids351 id348)) (if (not (valid-bound-ids?139 ids351)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels353 (gen-labels120 ids351)) (new-vars354 (map gen-var161 ids351))) (k335 (map syntax->datum ids351) new-vars354 (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1349 e2350) e329 (extend-var-env109 labels353 new-vars354 r332) (make-binding-wrap131 ids351 labels353 w333) mod334)))))) tmp347) ((lambda (tmp356) (if tmp356 (apply (lambda (ids357 e1358 e2359) (let ((old-ids360 (lambda-var-list162 ids357))) (if (not (valid-bound-ids?139 old-ids360)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels361 (gen-labels120 old-ids360)) (new-vars362 (map gen-var161 old-ids360))) (k335 (letrec ((f363 (lambda (ls1364 ls2365) (if (null? ls1364) (syntax->datum ls2365) (f363 (cdr ls1364) (cons (syntax->datum (car ls1364)) ls2365)))))) (f363 (cdr old-ids360) (car old-ids360))) (letrec ((f366 (lambda (ls1367 ls2368) (if (null? ls1367) ls2368 (f366 (cdr ls1367) (cons (car ls1367) ls2368)))))) (f366 (cdr new-vars362) (car new-vars362))) (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1358 e2359) e329 (extend-var-env109 labels361 new-vars362 r332) (make-binding-wrap131 old-ids360 labels361 w333) mod334)))))) tmp356) ((lambda (_370) (syntax-violation (quote lambda) "bad lambda" e329)) tmp336))) ($sc-dispatch tmp336 (quote (any any . each-any)))))) ($sc-dispatch tmp336 (quote (each-any any . each-any)))))) ($sc-dispatch tmp336 (quote (any any any . each-any))))) c331))) (chi-body154 (lambda (body371 outer-form372 r373 w374 mod375) (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) (let ((ribcage377 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w378 (make-wrap116 (wrap-marks117 w374) (cons ribcage377 (wrap-subst118 w374))))) (letrec ((parse379 (lambda (body380 ids381 labels382 var-ids383 vars384 vals385 bindings386) (if (null? body380) (syntax-violation #f "no expressions in body" outer-form372) (let ((e388 (cdar body380)) (er389 (caar body380))) (call-with-values (lambda () (syntax-type148 e388 er389 (quote (())) (source-annotation105 er389) ribcage377 mod375 #f)) (lambda (type390 value391 e392 w393 s394 mod395) (if (memv type390 (quote (define-form))) (let ((id396 (wrap142 value391 w393 mod395)) (label397 (gen-label119))) (let ((var398 (gen-var161 id396))) (begin (extend-ribcage!130 ribcage377 id396 label397) (parse379 (cdr body380) (cons id396 ids381) (cons label397 labels382) (cons id396 var-ids383) (cons var398 vars384) (cons (cons er389 (wrap142 e392 w393 mod395)) vals385) (cons (cons (quote lexical) var398) bindings386))))) (if (memv type390 (quote (define-syntax-form))) (let ((id399 (wrap142 value391 w393 mod395)) (label400 (gen-label119))) (begin (extend-ribcage!130 ribcage377 id399 label400) (parse379 (cdr body380) (cons id399 ids381) (cons label400 labels382) var-ids383 vars384 vals385 (cons (cons (quote macro) (cons er389 (wrap142 e392 w393 mod395))) bindings386)))) (if (memv type390 (quote (begin-form))) ((lambda (tmp401) ((lambda (tmp402) (if tmp402 (apply (lambda (_403 e1404) (parse379 (letrec ((f405 (lambda (forms406) (if (null? forms406) (cdr body380) (cons (cons er389 (wrap142 (car forms406) w393 mod395)) (f405 (cdr forms406))))))) (f405 e1404)) ids381 labels382 var-ids383 vars384 vals385 bindings386)) tmp402) (syntax-violation #f "source expression failed to match any pattern" tmp401))) ($sc-dispatch tmp401 (quote (any . each-any))))) e392) (if (memv type390 (quote (local-syntax-form))) (chi-local-syntax156 value391 e392 er389 w393 s394 mod395 (lambda (forms408 er409 w410 s411 mod412) (parse379 (letrec ((f413 (lambda (forms414) (if (null? forms414) (cdr body380) (cons (cons er409 (wrap142 (car forms414) w410 mod412)) (f413 (cdr forms414))))))) (f413 forms408)) ids381 labels382 var-ids383 vars384 vals385 bindings386))) (if (null? ids381) (build-sequence93 #f (map (lambda (x415) (chi150 (cdr x415) (car x415) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))) (begin (if (not (valid-bound-ids?139 ids381)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form372)) (letrec ((loop416 (lambda (bs417 er-cache418 r-cache419) (if (not (null? bs417)) (let ((b420 (car bs417))) (if (eq? (car b420) (quote macro)) (let ((er421 (cadr b420))) (let ((r-cache422 (if (eq? er421 er-cache418) r-cache419 (macros-only-env110 er421)))) (begin (set-cdr! b420 (eval-local-transformer157 (chi150 (cddr b420) r-cache422 (quote (())) mod395) mod395)) (loop416 (cdr bs417) er421 r-cache422)))) (loop416 (cdr bs417) er-cache418 r-cache419))))))) (loop416 bindings386 #f #f)) (set-cdr! r376 (extend-env108 labels382 bindings386 (cdr r376))) (build-letrec96 #f (map syntax->datum var-ids383) vars384 (map (lambda (x423) (chi150 (cdr x423) (car x423) (quote (())) mod395)) vals385) (build-sequence93 #f (map (lambda (x424) (chi150 (cdr x424) (car x424) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))))))))))))))))) (parse379 (map (lambda (x387) (cons r376 (wrap142 x387 w378 mod375))) body371) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p425 e426 r427 w428 rib429 mod430) (letrec ((rebuild-macro-output431 (lambda (x432 m433) (if (pair? x432) (cons (rebuild-macro-output431 (car x432) m433) (rebuild-macro-output431 (cdr x432) m433)) (if (syntax-object?98 x432) (let ((w434 (syntax-object-wrap100 x432))) (let ((ms435 (wrap-marks117 w434)) (s436 (wrap-subst118 w434))) (if (if (pair? ms435) (eq? (car ms435) #f) #f) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cdr ms435) (if rib429 (cons rib429 (cdr s436)) (cdr s436))) (syntax-object-module101 x432)) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cons m433 ms435) (if rib429 (cons rib429 (cons (quote shift) s436)) (cons (quote shift) s436))) (let ((pmod437 (procedure-module p425))) (if pmod437 (cons (quote hygiene) (module-name pmod437)) (quote (hygiene guile)))))))) (if (vector? x432) (let ((n438 (vector-length x432))) (let ((v439 (make-vector n438))) (letrec ((loop440 (lambda (i441) (if (fx=74 i441 n438) (begin (if #f #f) v439) (begin (vector-set! v439 i441 (rebuild-macro-output431 (vector-ref x432 i441) m433)) (loop440 (fx+72 i441 1))))))) (loop440 0)))) (if (symbol? x432) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e426 w428 s mod430) x432) x432))))))) (rebuild-macro-output431 (p425 (wrap142 e426 (anti-mark129 w428) mod430)) (string #\m))))) (chi-application152 (lambda (x442 e443 r444 w445 s446 mod447) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (e0450 e1451) (build-application81 s446 x442 (map (lambda (e452) (chi150 e452 r444 w445 mod447)) e1451))) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e443))) (chi-expr151 (lambda (type454 value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (lexical))) (build-lexical-reference83 (quote value) s459 e456 value455) (if (memv type454 (quote (core core-form))) (value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (module-ref))) (call-with-values (lambda () (value455 e456)) (lambda (id461 mod462) (build-global-reference86 s459 id461 mod462))) (if (memv type454 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e456)) (car e456) value455) e456 r457 w458 s459 mod460) (if (memv type454 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e456)) (if (syntax-object?98 value455) (syntax-object-expression99 value455) value455) (if (syntax-object?98 value455) (syntax-object-module101 value455) mod460)) e456 r457 w458 s459 mod460) (if (memv type454 (quote (constant))) (build-data92 s459 (strip160 (source-wrap143 e456 w458 s459 mod460) (quote (())))) (if (memv type454 (quote (global))) (build-global-reference86 s459 value455 mod460) (if (memv type454 (quote (call))) (chi-application152 (chi150 (car e456) r457 w458 mod460) e456 r457 w458 s459 mod460) (if (memv type454 (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466 e2467) (chi-sequence144 (cons e1466 e2467) r457 w458 s459 mod460)) tmp464) (syntax-violation #f "source expression failed to match any pattern" tmp463))) ($sc-dispatch tmp463 (quote (any any . each-any))))) e456) (if (memv type454 (quote (local-syntax-form))) (chi-local-syntax156 value455 e456 r457 w458 s459 mod460 chi-sequence144) (if (memv type454 (quote (eval-when-form))) ((lambda (tmp469) ((lambda (tmp470) (if tmp470 (apply (lambda (_471 x472 e1473 e2474) (let ((when-list475 (chi-when-list147 e456 x472 w458))) (if (memq (quote eval) when-list475) (chi-sequence144 (cons e1473 e2474) r457 w458 s459 mod460) (chi-void158)))) tmp470) (syntax-violation #f "source expression failed to match any pattern" tmp469))) ($sc-dispatch tmp469 (quote (any each-any any . each-any))))) e456) (if (memv type454 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e456 (wrap142 value455 w458 mod460)) (if (memv type454 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e456 w458 s459 mod460)) (if (memv type454 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e456 w458 s459 mod460)) (syntax-violation #f "unexpected syntax" (source-wrap143 e456 w458 s459 mod460)))))))))))))))))) (chi150 (lambda (e478 r479 w480 mod481) (call-with-values (lambda () (syntax-type148 e478 r479 w480 (source-annotation105 e478) #f mod481 #f)) (lambda (type482 value483 e484 w485 s486 mod487) (chi-expr151 type482 value483 e484 r479 w485 s486 mod487))))) (chi-top149 (lambda (e488 r489 w490 m491 esew492 mod493) (call-with-values (lambda () (syntax-type148 e488 r489 w490 (source-annotation105 e488) #f mod493 #f)) (lambda (type501 value502 e503 w504 s505 mod506) (if (memv type501 (quote (begin-form))) ((lambda (tmp507) ((lambda (tmp508) (if tmp508 (apply (lambda (_509) (chi-void158)) tmp508) ((lambda (tmp510) (if tmp510 (apply (lambda (_511 e1512 e2513) (chi-top-sequence145 (cons e1512 e2513) r489 w504 s505 m491 esew492 mod506)) tmp510) (syntax-violation #f "source expression failed to match any pattern" tmp507))) ($sc-dispatch tmp507 (quote (any any . each-any)))))) ($sc-dispatch tmp507 (quote (any))))) e503) (if (memv type501 (quote (local-syntax-form))) (chi-local-syntax156 value502 e503 r489 w504 s505 mod506 (lambda (body515 r516 w517 s518 mod519) (chi-top-sequence145 body515 r516 w517 s518 m491 esew492 mod519))) (if (memv type501 (quote (eval-when-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 x523 e1524 e2525) (let ((when-list526 (chi-when-list147 e503 x523 w504)) (body527 (cons e1524 e2525))) (if (eq? m491 (quote e)) (if (memq (quote eval) when-list526) (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) (chi-void158)) (if (memq (quote load) when-list526) (if (let ((t530 (memq (quote compile) when-list526))) (if t530 t530 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (chi-top-sequence145 body527 r489 w504 s505 (quote c&e) (quote (compile load)) mod506) (if (memq m491 (quote (c c&e))) (chi-top-sequence145 body527 r489 w504 s505 (quote c) (quote (load)) mod506) (chi-void158))) (if (let ((t531 (memq (quote compile) when-list526))) (if t531 t531 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) mod506) (chi-void158)) (chi-void158)))))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any each-any any . each-any))))) e503) (if (memv type501 (quote (define-syntax-form))) (let ((n532 (id-var-name136 value502 w504)) (r533 (macros-only-env110 r489))) (if (memv m491 (quote (c))) (if (memq (quote compile) esew492) (let ((e534 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e534 mod506) (if (memq (quote load) esew492) e534 (chi-void158)))) (if (memq (quote load) esew492) (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) (chi-void158))) (if (memv m491 (quote (c&e))) (let ((e535 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e535 mod506) e535)) (begin (if (memq (quote eval) esew492) (top-level-eval-hook76 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) mod506)) (chi-void158))))) (if (memv type501 (quote (define-form))) (let ((n536 (id-var-name136 value502 w504))) (let ((type537 (binding-type106 (lookup111 n536 r489 mod506)))) (if (memv type537 (quote (global core macro module-ref))) (let ((x538 (build-global-definition89 s505 n536 (chi150 e503 r489 w504 mod506)))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x538 mod506)) x538)) (if (memv type537 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e503 (wrap142 value502 w504 mod506)) (syntax-violation #f "cannot define keyword at top level" e503 (wrap142 value502 w504 mod506)))))) (let ((x539 (chi-expr151 type501 value502 e503 r489 w504 s505 mod506))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x539 mod506)) x539))))))))))) (syntax-type148 (lambda (e540 r541 w542 s543 rib544 mod545 for-car?546) (if (symbol? e540) (let ((n547 (id-var-name136 e540 w542))) (let ((b548 (lookup111 n547 r541 mod545))) (let ((type549 (binding-type106 b548))) (if (memv type549 (quote (lexical))) (values type549 (binding-value107 b548) e540 w542 s543 mod545) (if (memv type549 (quote (global))) (values type549 n547 e540 w542 s543 mod545) (if (memv type549 (quote (macro))) (if for-car?546 (values type549 (binding-value107 b548) e540 w542 s543 mod545) (syntax-type148 (chi-macro153 (binding-value107 b548) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 #f)) (values type549 (binding-value107 b548) e540 w542 s543 mod545))))))) (if (pair? e540) (let ((first550 (car e540))) (call-with-values (lambda () (syntax-type148 first550 r541 w542 s543 rib544 mod545 #t)) (lambda (ftype551 fval552 fe553 fw554 fs555 fmod556) (if (memv ftype551 (quote (lexical))) (values (quote lexical-call) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (global))) (values (quote global-call) (make-syntax-object97 fval552 w542 fmod556) e540 w542 s543 mod545) (if (memv ftype551 (quote (macro))) (syntax-type148 (chi-macro153 fval552 e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 for-car?546) (if (memv ftype551 (quote (module-ref))) (call-with-values (lambda () (fval552 e540)) (lambda (sym557 mod558) (syntax-type148 sym557 r541 w542 s543 rib544 mod558 for-car?546))) (if (memv ftype551 (quote (core))) (values (quote core-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (local-syntax))) (values (quote local-syntax-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (begin))) (values (quote begin-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (eval-when))) (values (quote eval-when-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (define))) ((lambda (tmp559) ((lambda (tmp560) (if (if tmp560 (apply (lambda (_561 name562 val563) (id?114 name562)) tmp560) #f) (apply (lambda (_564 name565 val566) (values (quote define-form) name565 val566 w542 s543 mod545)) tmp560) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 args570 e1571 e2572) (if (id?114 name569) (valid-bound-ids?139 (lambda-var-list162 args570)) #f)) tmp567) #f) (apply (lambda (_573 name574 args575 e1576 e2577) (values (quote define-form) (wrap142 name574 w542 mod545) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args575 (cons e1576 e2577)) w542 mod545)) (quote (())) s543 mod545)) tmp567) ((lambda (tmp579) (if (if tmp579 (apply (lambda (_580 name581) (id?114 name581)) tmp579) #f) (apply (lambda (_582 name583) (values (quote define-form) (wrap142 name583 w542 mod545) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s543 mod545)) tmp579) (syntax-violation #f "source expression failed to match any pattern" tmp559))) ($sc-dispatch tmp559 (quote (any any)))))) ($sc-dispatch tmp559 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp559 (quote (any any any))))) e540) (if (memv ftype551 (quote (define-syntax))) ((lambda (tmp584) ((lambda (tmp585) (if (if tmp585 (apply (lambda (_586 name587 val588) (id?114 name587)) tmp585) #f) (apply (lambda (_589 name590 val591) (values (quote define-syntax-form) name590 val591 w542 s543 mod545)) tmp585) (syntax-violation #f "source expression failed to match any pattern" tmp584))) ($sc-dispatch tmp584 (quote (any any any))))) e540) (values (quote call) #f e540 w542 s543 mod545)))))))))))))) (if (syntax-object?98 e540) (syntax-type148 (syntax-object-expression99 e540) r541 (join-wraps133 w542 (syntax-object-wrap100 e540)) s543 rib544 (let ((t592 (syntax-object-module101 e540))) (if t592 t592 mod545)) for-car?546) (if (self-evaluating? e540) (values (quote constant) #f e540 w542 s543 mod545) (values (quote other) #f e540 w542 s543 mod545))))))) (chi-when-list147 (lambda (e593 when-list594 w595) (letrec ((f596 (lambda (when-list597 situations598) (if (null? when-list597) situations598 (f596 (cdr when-list597) (cons (let ((x599 (car when-list597))) (if (free-id=?137 x599 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x599 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x599 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e593 (wrap142 x599 w595 #f)))))) situations598)))))) (f596 when-list594 (quote ()))))) (chi-install-global146 (lambda (name600 e601) (build-global-definition89 #f name600 (if (let ((v602 (module-variable (current-module) name600))) (if v602 (if (variable-bound? v602) (if (macro? (variable-ref v602)) (not (eq? (macro-type (variable-ref v602)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name600))) (build-data92 #f (quote macro)) e601)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e601)))))) (chi-top-sequence145 (lambda (body603 r604 w605 s606 m607 esew608 mod609) (build-sequence93 s606 (letrec ((dobody610 (lambda (body611 r612 w613 m614 esew615 mod616) (if (null? body611) (quote ()) (let ((first617 (chi-top149 (car body611) r612 w613 m614 esew615 mod616))) (cons first617 (dobody610 (cdr body611) r612 w613 m614 esew615 mod616))))))) (dobody610 body603 r604 w605 m607 esew608 mod609))))) (chi-sequence144 (lambda (body618 r619 w620 s621 mod622) (build-sequence93 s621 (letrec ((dobody623 (lambda (body624 r625 w626 mod627) (if (null? body624) (quote ()) (let ((first628 (chi150 (car body624) r625 w626 mod627))) (cons first628 (dobody623 (cdr body624) r625 w626 mod627))))))) (dobody623 body618 r619 w620 mod622))))) (source-wrap143 (lambda (x629 w630 s631 defmod632) (begin (if (if s631 (pair? x629) #f) (set-source-properties! x629 s631)) (wrap142 x629 w630 defmod632)))) (wrap142 (lambda (x633 w634 defmod635) (if (if (null? (wrap-marks117 w634)) (null? (wrap-subst118 w634)) #f) x633 (if (syntax-object?98 x633) (make-syntax-object97 (syntax-object-expression99 x633) (join-wraps133 w634 (syntax-object-wrap100 x633)) (syntax-object-module101 x633)) (if (null? x633) x633 (make-syntax-object97 x633 w634 defmod635)))))) (bound-id-member?141 (lambda (x636 list637) (if (not (null? list637)) (let ((t638 (bound-id=?138 x636 (car list637)))) (if t638 t638 (bound-id-member?141 x636 (cdr list637)))) #f))) (distinct-bound-ids?140 (lambda (ids639) (letrec ((distinct?640 (lambda (ids641) (let ((t642 (null? ids641))) (if t642 t642 (if (not (bound-id-member?141 (car ids641) (cdr ids641))) (distinct?640 (cdr ids641)) #f)))))) (distinct?640 ids639)))) (valid-bound-ids?139 (lambda (ids643) (if (letrec ((all-ids?644 (lambda (ids645) (let ((t646 (null? ids645))) (if t646 t646 (if (id?114 (car ids645)) (all-ids?644 (cdr ids645)) #f)))))) (all-ids?644 ids643)) (distinct-bound-ids?140 ids643) #f))) (bound-id=?138 (lambda (i647 j648) (if (if (syntax-object?98 i647) (syntax-object?98 j648) #f) (if (eq? (syntax-object-expression99 i647) (syntax-object-expression99 j648)) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i647)) (wrap-marks117 (syntax-object-wrap100 j648))) #f) (eq? i647 j648)))) (free-id=?137 (lambda (i649 j650) (if (eq? (let ((x651 i649)) (if (syntax-object?98 x651) (syntax-object-expression99 x651) x651)) (let ((x652 j650)) (if (syntax-object?98 x652) (syntax-object-expression99 x652) x652))) (eq? (id-var-name136 i649 (quote (()))) (id-var-name136 j650 (quote (())))) #f))) (id-var-name136 (lambda (id653 w654) (letrec ((search-vector-rib657 (lambda (sym663 subst664 marks665 symnames666 ribcage667) (let ((n668 (vector-length symnames666))) (letrec ((f669 (lambda (i670) (if (fx=74 i670 n668) (search655 sym663 (cdr subst664) marks665) (if (if (eq? (vector-ref symnames666 i670) sym663) (same-marks?135 marks665 (vector-ref (ribcage-marks124 ribcage667) i670)) #f) (values (vector-ref (ribcage-labels125 ribcage667) i670) marks665) (f669 (fx+72 i670 1))))))) (f669 0))))) (search-list-rib656 (lambda (sym671 subst672 marks673 symnames674 ribcage675) (letrec ((f676 (lambda (symnames677 i678) (if (null? symnames677) (search655 sym671 (cdr subst672) marks673) (if (if (eq? (car symnames677) sym671) (same-marks?135 marks673 (list-ref (ribcage-marks124 ribcage675) i678)) #f) (values (list-ref (ribcage-labels125 ribcage675) i678) marks673) (f676 (cdr symnames677) (fx+72 i678 1))))))) (f676 symnames674 0)))) (search655 (lambda (sym679 subst680 marks681) (if (null? subst680) (values #f marks681) (let ((fst682 (car subst680))) (if (eq? fst682 (quote shift)) (search655 sym679 (cdr subst680) (cdr marks681)) (let ((symnames683 (ribcage-symnames123 fst682))) (if (vector? symnames683) (search-vector-rib657 sym679 subst680 marks681 symnames683 fst682) (search-list-rib656 sym679 subst680 marks681 symnames683 fst682))))))))) (if (symbol? id653) (let ((t684 (call-with-values (lambda () (search655 id653 (wrap-subst118 w654) (wrap-marks117 w654))) (lambda (x686 . ignore685) x686)))) (if t684 t684 id653)) (if (syntax-object?98 id653) (let ((id687 (syntax-object-expression99 id653)) (w1688 (syntax-object-wrap100 id653))) (let ((marks689 (join-marks134 (wrap-marks117 w654) (wrap-marks117 w1688)))) (call-with-values (lambda () (search655 id687 (wrap-subst118 w654) marks689)) (lambda (new-id690 marks691) (let ((t692 new-id690)) (if t692 t692 (let ((t693 (call-with-values (lambda () (search655 id687 (wrap-subst118 w1688) marks691)) (lambda (x695 . ignore694) x695)))) (if t693 t693 id687)))))))) (syntax-violation (quote id-var-name) "invalid id" id653)))))) (same-marks?135 (lambda (x696 y697) (let ((t698 (eq? x696 y697))) (if t698 t698 (if (not (null? x696)) (if (not (null? y697)) (if (eq? (car x696) (car y697)) (same-marks?135 (cdr x696) (cdr y697)) #f) #f) #f))))) (join-marks134 (lambda (m1699 m2700) (smart-append132 m1699 m2700))) (join-wraps133 (lambda (w1701 w2702) (let ((m1703 (wrap-marks117 w1701)) (s1704 (wrap-subst118 w1701))) (if (null? m1703) (if (null? s1704) w2702 (make-wrap116 (wrap-marks117 w2702) (smart-append132 s1704 (wrap-subst118 w2702)))) (make-wrap116 (smart-append132 m1703 (wrap-marks117 w2702)) (smart-append132 s1704 (wrap-subst118 w2702))))))) (smart-append132 (lambda (m1705 m2706) (if (null? m2706) m1705 (append m1705 m2706)))) (make-binding-wrap131 (lambda (ids707 labels708 w709) (if (null? ids707) w709 (make-wrap116 (wrap-marks117 w709) (cons (let ((labelvec710 (list->vector labels708))) (let ((n711 (vector-length labelvec710))) (let ((symnamevec712 (make-vector n711)) (marksvec713 (make-vector n711))) (begin (letrec ((f714 (lambda (ids715 i716) (if (not (null? ids715)) (call-with-values (lambda () (id-sym-name&marks115 (car ids715) w709)) (lambda (symname717 marks718) (begin (vector-set! symnamevec712 i716 symname717) (vector-set! marksvec713 i716 marks718) (f714 (cdr ids715) (fx+72 i716 1))))))))) (f714 ids707 0)) (make-ribcage121 symnamevec712 marksvec713 labelvec710))))) (wrap-subst118 w709)))))) (extend-ribcage!130 (lambda (ribcage719 id720 label721) (begin (set-ribcage-symnames!126 ribcage719 (cons (syntax-object-expression99 id720) (ribcage-symnames123 ribcage719))) (set-ribcage-marks!127 ribcage719 (cons (wrap-marks117 (syntax-object-wrap100 id720)) (ribcage-marks124 ribcage719))) (set-ribcage-labels!128 ribcage719 (cons label721 (ribcage-labels125 ribcage719)))))) (anti-mark129 (lambda (w722) (make-wrap116 (cons #f (wrap-marks117 w722)) (cons (quote shift) (wrap-subst118 w722))))) (set-ribcage-labels!128 (lambda (x723 update724) (vector-set! x723 3 update724))) (set-ribcage-marks!127 (lambda (x725 update726) (vector-set! x725 2 update726))) (set-ribcage-symnames!126 (lambda (x727 update728) (vector-set! x727 1 update728))) (ribcage-labels125 (lambda (x729) (vector-ref x729 3))) (ribcage-marks124 (lambda (x730) (vector-ref x730 2))) (ribcage-symnames123 (lambda (x731) (vector-ref x731 1))) (ribcage?122 (lambda (x732) (if (vector? x732) (if (= (vector-length x732) 4) (eq? (vector-ref x732 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames733 marks734 labels735) (vector (quote ribcage) symnames733 marks734 labels735))) (gen-labels120 (lambda (ls736) (if (null? ls736) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls736)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x737 w738) (if (syntax-object?98 x737) (values (syntax-object-expression99 x737) (join-marks134 (wrap-marks117 w738) (wrap-marks117 (syntax-object-wrap100 x737)))) (values x737 (wrap-marks117 w738))))) (id?114 (lambda (x739) (if (symbol? x739) #t (if (syntax-object?98 x739) (symbol? (syntax-object-expression99 x739)) #f)))) (nonsymbol-id?113 (lambda (x740) (if (syntax-object?98 x740) (symbol? (syntax-object-expression99 x740)) #f))) (global-extend112 (lambda (type741 sym742 val743) (put-global-definition-hook78 sym742 type741 val743))) (lookup111 (lambda (x744 r745 mod746) (let ((t747 (assq x744 r745))) (if t747 (cdr t747) (if (symbol? x744) (let ((t748 (get-global-definition-hook79 x744 mod746))) (if t748 t748 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r749) (if (null? r749) (quote ()) (let ((a750 (car r749))) (if (eq? (cadr a750) (quote macro)) (cons a750 (macros-only-env110 (cdr r749))) (macros-only-env110 (cdr r749))))))) (extend-var-env109 (lambda (labels751 vars752 r753) (if (null? labels751) r753 (extend-var-env109 (cdr labels751) (cdr vars752) (cons (cons (car labels751) (cons (quote lexical) (car vars752))) r753))))) (extend-env108 (lambda (labels754 bindings755 r756) (if (null? labels754) r756 (extend-env108 (cdr labels754) (cdr bindings755) (cons (cons (car labels754) (car bindings755)) r756))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x757) (if (syntax-object?98 x757) (source-annotation105 (syntax-object-expression99 x757)) (if (pair? x757) (let ((props758 (source-properties x757))) (if (pair? props758) props758 #f)) #f)))) (set-syntax-object-module!104 (lambda (x759 update760) (vector-set! x759 3 update760))) (set-syntax-object-wrap!103 (lambda (x761 update762) (vector-set! x761 2 update762))) (set-syntax-object-expression!102 (lambda (x763 update764) (vector-set! x763 1 update764))) (syntax-object-module101 (lambda (x765) (vector-ref x765 3))) (syntax-object-wrap100 (lambda (x766) (vector-ref x766 2))) (syntax-object-expression99 (lambda (x767) (vector-ref x767 1))) (syntax-object?98 (lambda (x768) (if (vector? x768) (if (= (vector-length x768) 4) (eq? (vector-ref x768 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression769 wrap770 module771) (vector (quote syntax-object) expression769 wrap770 module771))) (build-letrec96 (lambda (src772 ids773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (let ((atom-key777 (fluid-ref *mode*71))) (if (memv atom-key777 (quote (c))) (begin (for-each maybe-name-value!88 ids773 val-exps775) ((@ (language tree-il) make-letrec) src772 ids773 vars774 val-exps775 body-exp776)) (list (quote letrec) (map list vars774 val-exps775) body-exp776)))))) (build-named-let95 (lambda (src778 ids779 vars780 val-exps781 body-exp782) (let ((f783 (car vars780)) (f-name784 (car ids779)) (vars785 (cdr vars780)) (ids786 (cdr ids779))) (let ((atom-key787 (fluid-ref *mode*71))) (if (memv atom-key787 (quote (c))) (let ((proc788 (build-lambda90 src778 ids786 vars785 #f body-exp782))) (begin (maybe-name-value!88 f-name784 proc788) (for-each maybe-name-value!88 ids786 val-exps781) ((@ (language tree-il) make-letrec) src778 (list f-name784) (list f783) (list proc788) (build-application81 src778 (build-lexical-reference83 (quote fun) src778 f-name784 f783) val-exps781)))) (list (quote let) f783 (map list vars785 val-exps781) body-exp782)))))) (build-let94 (lambda (src789 ids790 vars791 val-exps792 body-exp793) (if (null? vars791) body-exp793 (let ((atom-key794 (fluid-ref *mode*71))) (if (memv atom-key794 (quote (c))) (begin (for-each maybe-name-value!88 ids790 val-exps792) ((@ (language tree-il) make-let) src789 ids790 vars791 val-exps792 body-exp793)) (list (quote let) (map list vars791 val-exps792) body-exp793)))))) (build-sequence93 (lambda (src795 exps796) (if (null? (cdr exps796)) (car exps796) (let ((atom-key797 (fluid-ref *mode*71))) (if (memv atom-key797 (quote (c))) ((@ (language tree-il) make-sequence) src795 exps796) (cons (quote begin) exps796)))))) (build-data92 (lambda (src798 exp799) (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-const) src798 exp799) (if (if (self-evaluating? exp799) (not (vector? exp799)) #f) exp799 (list (quote quote) exp799)))))) (build-primref91 (lambda (src801 name802) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key803 (fluid-ref *mode*71))) (if (memv atom-key803 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src801 name802) name802)) (let ((atom-key804 (fluid-ref *mode*71))) (if (memv atom-key804 (quote (c))) ((@ (language tree-il) make-module-ref) src801 (quote (guile)) name802 #f) (list (quote @@) (quote (guile)) name802)))))) (build-lambda90 (lambda (src805 ids806 vars807 docstring808 exp809) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-lambda) src805 ids806 vars807 (if docstring808 (list (cons (quote documentation) docstring808)) (quote ())) exp809) (cons (quote lambda) (cons vars807 (append (if docstring808 (list docstring808) (quote ())) (list exp809)))))))) (build-global-definition89 (lambda (source811 var812 exp813) (let ((atom-key814 (fluid-ref *mode*71))) (if (memv atom-key814 (quote (c))) (begin (maybe-name-value!88 var812 exp813) ((@ (language tree-il) make-toplevel-define) source811 var812 exp813)) (list (quote define) var812 exp813))))) (maybe-name-value!88 (lambda (name815 val816) (if ((@ (language tree-il) lambda?) val816) (let ((meta817 ((@ (language tree-il) lambda-meta) val816))) (if (not (assq (quote name) meta817)) ((setter (@ (language tree-il) lambda-meta)) val816 (acons (quote name) name815 meta817))))))) (build-global-assignment87 (lambda (source818 var819 exp820 mod821) (analyze-variable85 mod821 var819 (lambda (mod822 var823 public?824) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-module-set) source818 mod822 var823 public?824 exp820) (list (quote set!) (list (if public?824 (quote @) (quote @@)) mod822 var823) exp820)))) (lambda (var826) (let ((atom-key827 (fluid-ref *mode*71))) (if (memv atom-key827 (quote (c))) ((@ (language tree-il) make-toplevel-set) source818 var826 exp820) (list (quote set!) var826 exp820))))))) (build-global-reference86 (lambda (source828 var829 mod830) (analyze-variable85 mod830 var829 (lambda (mod831 var832 public?833) (let ((atom-key834 (fluid-ref *mode*71))) (if (memv atom-key834 (quote (c))) ((@ (language tree-il) make-module-ref) source828 mod831 var832 public?833) (list (if public?833 (quote @) (quote @@)) mod831 var832)))) (lambda (var835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source828 var835) var835)))))) (analyze-variable85 (lambda (mod837 var838 modref-cont839 bare-cont840) (if (not mod837) (bare-cont840 var838) (let ((kind841 (car mod837)) (mod842 (cdr mod837))) (if (memv kind841 (quote (public))) (modref-cont839 mod842 var838 #t) (if (memv kind841 (quote (private))) (if (not (equal? mod842 (module-name (current-module)))) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (if (memv kind841 (quote (bare))) (bare-cont840 var838) (if (memv kind841 (quote (hygiene))) (if (if (not (equal? mod842 (module-name (current-module)))) (module-variable (resolve-module mod842) var838) #f) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (syntax-violation #f "bad module kind" var838 mod842))))))))) (build-lexical-assignment84 (lambda (source843 name844 var845 exp846) (let ((atom-key847 (fluid-ref *mode*71))) (if (memv atom-key847 (quote (c))) ((@ (language tree-il) make-lexical-set) source843 name844 var845 exp846) (list (quote set!) var845 exp846))))) (build-lexical-reference83 (lambda (type848 source849 name850 var851) (let ((atom-key852 (fluid-ref *mode*71))) (if (memv atom-key852 (quote (c))) ((@ (language tree-il) make-lexical-ref) source849 name850 var851) var851)))) (build-conditional82 (lambda (source853 test-exp854 then-exp855 else-exp856) (let ((atom-key857 (fluid-ref *mode*71))) (if (memv atom-key857 (quote (c))) ((@ (language tree-il) make-conditional) source853 test-exp854 then-exp855 else-exp856) (if (equal? else-exp856 (quote (if #f #f))) (list (quote if) test-exp854 then-exp855) (list (quote if) test-exp854 then-exp855 else-exp856)))))) (build-application81 (lambda (source858 fun-exp859 arg-exps860) (let ((atom-key861 (fluid-ref *mode*71))) (if (memv atom-key861 (quote (c))) ((@ (language tree-il) make-application) source858 fun-exp859 arg-exps860) (cons fun-exp859 arg-exps860))))) (build-void80 (lambda (source862) (let ((atom-key863 (fluid-ref *mode*71))) (if (memv atom-key863 (quote (c))) ((@ (language tree-il) make-void) source862) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol864 module865) (begin (if (if (not module865) (current-module) #f) (warn "module system is booted, we should have a module" symbol864)) (let ((v866 (module-variable (if module865 (resolve-module (cdr module865)) (current-module)) symbol864))) (if v866 (if (variable-bound? v866) (let ((val867 (variable-ref v866))) (if (macro? val867) (if (syncase-macro-type val867) (cons (syncase-macro-type val867) (syncase-macro-binding val867)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol868 type869 val870) (let ((existing871 (let ((v872 (module-variable (current-module) symbol868))) (if v872 (if (variable-bound? v872) (let ((val873 (variable-ref v872))) (if (macro? val873) (if (not (syncase-macro-type val873)) val873 #f) #f)) #f) #f)))) (module-define! (current-module) symbol868 (if existing871 (make-extended-syncase-macro existing871 type869 val870) (make-syncase-macro type869 val870)))))) (local-eval-hook77 (lambda (x874 mod875) (primitive-eval (list noexpand70 (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) tree-il->scheme) x874) x874)))))) (top-level-eval-hook76 (lambda (x877 mod878) (primitive-eval (list noexpand70 (let ((atom-key879 (fluid-ref *mode*71))) (if (memv atom-key879 (quote (c))) ((@ (language tree-il) tree-il->scheme) x877) x877)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e880 r881 w882 s883 mod884) ((lambda (tmp885) ((lambda (tmp886) (if (if tmp886 (apply (lambda (_887 var888 val889 e1890 e2891) (valid-bound-ids?139 var888)) tmp886) #f) (apply (lambda (_893 var894 val895 e1896 e2897) (let ((names898 (map (lambda (x899) (id-var-name136 x899 w882)) var894))) (begin (for-each (lambda (id901 n902) (let ((atom-key903 (binding-type106 (lookup111 n902 r881 mod884)))) (if (memv atom-key903 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e880 (source-wrap143 id901 w882 s883 mod884))))) var894 names898) (chi-body154 (cons e1896 e2897) (source-wrap143 e880 w882 s883 mod884) (extend-env108 names898 (let ((trans-r906 (macros-only-env110 r881))) (map (lambda (x907) (cons (quote macro) (eval-local-transformer157 (chi150 x907 trans-r906 w882 mod884) mod884))) val895)) r881) w882 mod884)))) tmp886) ((lambda (_909) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e880 w882 s883 mod884))) tmp885))) ($sc-dispatch tmp885 (quote (any #(each (any any)) any . each-any))))) e880))) (global-extend112 (quote core) (quote quote) (lambda (e910 r911 w912 s913 mod914) ((lambda (tmp915) ((lambda (tmp916) (if tmp916 (apply (lambda (_917 e918) (build-data92 s913 (strip160 e918 w912))) tmp916) ((lambda (_919) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e910 w912 s913 mod914))) tmp915))) ($sc-dispatch tmp915 (quote (any any))))) e910))) (global-extend112 (quote core) (quote syntax) (letrec ((regen927 (lambda (x928) (let ((atom-key929 (car x928))) (if (memv atom-key929 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x928) (cadr x928)) (if (memv atom-key929 (quote (primitive))) (build-primref91 #f (cadr x928)) (if (memv atom-key929 (quote (quote))) (build-data92 #f (cadr x928)) (if (memv atom-key929 (quote (lambda))) (build-lambda90 #f (cadr x928) (cadr x928) #f (regen927 (caddr x928))) (build-application81 #f (build-primref91 #f (car x928)) (map regen927 (cdr x928)))))))))) (gen-vector926 (lambda (x930) (if (eq? (car x930) (quote list)) (cons (quote vector) (cdr x930)) (if (eq? (car x930) (quote quote)) (list (quote quote) (list->vector (cadr x930))) (list (quote list->vector) x930))))) (gen-append925 (lambda (x931 y932) (if (equal? y932 (quote (quote ()))) x931 (list (quote append) x931 y932)))) (gen-cons924 (lambda (x933 y934) (let ((atom-key935 (car y934))) (if (memv atom-key935 (quote (quote))) (if (eq? (car x933) (quote quote)) (list (quote quote) (cons (cadr x933) (cadr y934))) (if (eq? (cadr y934) (quote ())) (list (quote list) x933) (list (quote cons) x933 y934))) (if (memv atom-key935 (quote (list))) (cons (quote list) (cons x933 (cdr y934))) (list (quote cons) x933 y934)))))) (gen-map923 (lambda (e936 map-env937) (let ((formals938 (map cdr map-env937)) (actuals939 (map (lambda (x940) (list (quote ref) (car x940))) map-env937))) (if (eq? (car e936) (quote ref)) (car actuals939) (if (and-map (lambda (x941) (if (eq? (car x941) (quote ref)) (memq (cadr x941) formals938) #f)) (cdr e936)) (cons (quote map) (cons (list (quote primitive) (car e936)) (map (let ((r942 (map cons formals938 actuals939))) (lambda (x943) (cdr (assq (cadr x943) r942)))) (cdr e936)))) (cons (quote map) (cons (list (quote lambda) formals938 e936) actuals939))))))) (gen-mappend922 (lambda (e944 map-env945) (list (quote apply) (quote (primitive append)) (gen-map923 e944 map-env945)))) (gen-ref921 (lambda (src946 var947 level948 maps949) (if (fx=74 level948 0) (values var947 maps949) (if (null? maps949) (syntax-violation (quote syntax) "missing ellipsis" src946) (call-with-values (lambda () (gen-ref921 src946 var947 (fx-73 level948 1) (cdr maps949))) (lambda (outer-var950 outer-maps951) (let ((b952 (assq outer-var950 (car maps949)))) (if b952 (values (cdr b952) maps949) (let ((inner-var953 (gen-var161 (quote tmp)))) (values inner-var953 (cons (cons (cons outer-var950 inner-var953) (car maps949)) outer-maps951))))))))))) (gen-syntax920 (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) (if (id?114 e955) (let ((label960 (id-var-name136 e955 (quote (()))))) (let ((b961 (lookup111 label960 r956 mod959))) (if (eq? (binding-type106 b961) (quote syntax)) (call-with-values (lambda () (let ((var.lev962 (binding-value107 b961))) (gen-ref921 src954 (car var.lev962) (cdr var.lev962) maps957))) (lambda (var963 maps964) (values (list (quote ref) var963) maps964))) (if (ellipsis?958 e955) (syntax-violation (quote syntax) "misplaced ellipsis" src954) (values (list (quote quote) e955) maps957))))) ((lambda (tmp965) ((lambda (tmp966) (if (if tmp966 (apply (lambda (dots967 e968) (ellipsis?958 dots967)) tmp966) #f) (apply (lambda (dots969 e970) (gen-syntax920 src954 e970 r956 maps957 (lambda (x971) #f) mod959)) tmp966) ((lambda (tmp972) (if (if tmp972 (apply (lambda (x973 dots974 y975) (ellipsis?958 dots974)) tmp972) #f) (apply (lambda (x976 dots977 y978) (letrec ((f979 (lambda (y980 k981) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 y988) (ellipsis?958 dots987)) tmp986) #f) (apply (lambda (dots989 y990) (f979 y990 (lambda (maps991) (call-with-values (lambda () (k981 (cons (quote ()) maps991))) (lambda (x992 maps993) (if (null? (car maps993)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-mappend922 x992 (car maps993)) (cdr maps993)))))))) tmp986) ((lambda (_994) (call-with-values (lambda () (gen-syntax920 src954 y980 r956 maps957 ellipsis?958 mod959)) (lambda (y995 maps996) (call-with-values (lambda () (k981 maps996)) (lambda (x997 maps998) (values (gen-append925 x997 y995) maps998)))))) tmp985))) ($sc-dispatch tmp985 (quote (any . any))))) y980)))) (f979 y978 (lambda (maps982) (call-with-values (lambda () (gen-syntax920 src954 x976 r956 (cons (quote ()) maps982) ellipsis?958 mod959)) (lambda (x983 maps984) (if (null? (car maps984)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-map923 x983 (car maps984)) (cdr maps984))))))))) tmp972) ((lambda (tmp999) (if tmp999 (apply (lambda (x1000 y1001) (call-with-values (lambda () (gen-syntax920 src954 x1000 r956 maps957 ellipsis?958 mod959)) (lambda (x1002 maps1003) (call-with-values (lambda () (gen-syntax920 src954 y1001 r956 maps1003 ellipsis?958 mod959)) (lambda (y1004 maps1005) (values (gen-cons924 x1002 y1004) maps1005)))))) tmp999) ((lambda (tmp1006) (if tmp1006 (apply (lambda (e11007 e21008) (call-with-values (lambda () (gen-syntax920 src954 (cons e11007 e21008) r956 maps957 ellipsis?958 mod959)) (lambda (e1010 maps1011) (values (gen-vector926 e1010) maps1011)))) tmp1006) ((lambda (_1012) (values (list (quote quote) e955) maps957)) tmp965))) ($sc-dispatch tmp965 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp965 (quote (any . any)))))) ($sc-dispatch tmp965 (quote (any any . any)))))) ($sc-dispatch tmp965 (quote (any any))))) e955))))) (lambda (e1013 r1014 w1015 s1016 mod1017) (let ((e1018 (source-wrap143 e1013 w1015 s1016 mod1017))) ((lambda (tmp1019) ((lambda (tmp1020) (if tmp1020 (apply (lambda (_1021 x1022) (call-with-values (lambda () (gen-syntax920 e1018 x1022 r1014 (quote ()) ellipsis?159 mod1017)) (lambda (e1023 maps1024) (regen927 e1023)))) tmp1020) ((lambda (_1025) (syntax-violation (quote syntax) "bad `syntax' form" e1018)) tmp1019))) ($sc-dispatch tmp1019 (quote (any any))))) e1018))))) (global-extend112 (quote core) (quote lambda) (lambda (e1026 r1027 w1028 s1029 mod1030) ((lambda (tmp1031) ((lambda (tmp1032) (if tmp1032 (apply (lambda (_1033 c1034) (chi-lambda-clause155 (source-wrap143 e1026 w1028 s1029 mod1030) #f c1034 r1027 w1028 mod1030 (lambda (names1035 vars1036 docstring1037 body1038) (build-lambda90 s1029 names1035 vars1036 docstring1037 body1038)))) tmp1032) (syntax-violation #f "source expression failed to match any pattern" tmp1031))) ($sc-dispatch tmp1031 (quote (any . any))))) e1026))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1039 (lambda (e1040 r1041 w1042 s1043 mod1044 constructor1045 ids1046 vals1047 exps1048) (if (not (valid-bound-ids?139 ids1046)) (syntax-violation (quote let) "duplicate bound variable" e1040) (let ((labels1049 (gen-labels120 ids1046)) (new-vars1050 (map gen-var161 ids1046))) (let ((nw1051 (make-binding-wrap131 ids1046 labels1049 w1042)) (nr1052 (extend-var-env109 labels1049 new-vars1050 r1041))) (constructor1045 s1043 (map syntax->datum ids1046) new-vars1050 (map (lambda (x1053) (chi150 x1053 r1041 w1042 mod1044)) vals1047) (chi-body154 exps1048 (source-wrap143 e1040 nw1051 s1043 mod1044) nr1052 nw1051 mod1044)))))))) (lambda (e1054 r1055 w1056 s1057 mod1058) ((lambda (tmp1059) ((lambda (tmp1060) (if (if tmp1060 (apply (lambda (_1061 id1062 val1063 e11064 e21065) (and-map id?114 id1062)) tmp1060) #f) (apply (lambda (_1067 id1068 val1069 e11070 e21071) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-let94 id1068 val1069 (cons e11070 e21071))) tmp1060) ((lambda (tmp1075) (if (if tmp1075 (apply (lambda (_1076 f1077 id1078 val1079 e11080 e21081) (if (id?114 f1077) (and-map id?114 id1078) #f)) tmp1075) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-named-let95 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1075) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap143 e1054 w1056 s1057 mod1058))) tmp1059))) ($sc-dispatch tmp1059 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1059 (quote (any #(each (any any)) any . each-any))))) e1054)))) (global-extend112 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (and-map id?114 id1101)) tmp1099) #f) (apply (lambda (_1106 id1107 val1108 e11109 e21110) (let ((ids1111 id1107)) (if (not (valid-bound-ids?139 ids1111)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1113 (gen-labels120 ids1111)) (new-vars1114 (map gen-var161 ids1111))) (let ((w1115 (make-binding-wrap131 ids1111 labels1113 w1095)) (r1116 (extend-var-env109 labels1113 new-vars1114 r1094))) (build-letrec96 s1096 (map syntax->datum ids1111) new-vars1114 (map (lambda (x1117) (chi150 x1117 r1116 w1115 mod1097)) val1108) (chi-body154 (cons e11109 e21110) (source-wrap143 e1093 w1115 s1096 mod1097) r1116 w1115 mod1097))))))) tmp1099) ((lambda (_1120) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend112 (quote core) (quote set!) (lambda (e1121 r1122 w1123 s1124 mod1125) ((lambda (tmp1126) ((lambda (tmp1127) (if (if tmp1127 (apply (lambda (_1128 id1129 val1130) (id?114 id1129)) tmp1127) #f) (apply (lambda (_1131 id1132 val1133) (let ((val1134 (chi150 val1133 r1122 w1123 mod1125)) (n1135 (id-var-name136 id1132 w1123))) (let ((b1136 (lookup111 n1135 r1122 mod1125))) (let ((atom-key1137 (binding-type106 b1136))) (if (memv atom-key1137 (quote (lexical))) (build-lexical-assignment84 s1124 (syntax->datum id1132) (binding-value107 b1136) val1134) (if (memv atom-key1137 (quote (global))) (build-global-assignment87 s1124 n1135 val1134 mod1125) (if (memv atom-key1137 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1132 w1123 mod1125)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))))))))) tmp1127) ((lambda (tmp1138) (if tmp1138 (apply (lambda (_1139 head1140 tail1141 val1142) (call-with-values (lambda () (syntax-type148 head1140 r1122 (quote (())) #f #f mod1125 #t)) (lambda (type1143 value1144 ee1145 ww1146 ss1147 modmod1148) (if (memv type1143 (quote (module-ref))) (let ((val1149 (chi150 val1142 r1122 w1123 mod1125))) (call-with-values (lambda () (value1144 (cons head1140 tail1141))) (lambda (id1151 mod1152) (build-global-assignment87 s1124 id1151 val1149 mod1152)))) (build-application81 s1124 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1140) r1122 w1123 mod1125) (map (lambda (e1153) (chi150 e1153 r1122 w1123 mod1125)) (append tail1141 (list val1142)))))))) tmp1138) ((lambda (_1155) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))) tmp1126))) ($sc-dispatch tmp1126 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1126 (quote (any any any))))) e1121))) (global-extend112 (quote module-ref) (quote @) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (if (and-map id?114 mod1160) (id?114 id1161) #f)) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1167) ((lambda (tmp1168) ((lambda (tmp1169) (if (if tmp1169 (apply (lambda (_1170 mod1171 id1172) (if (and-map id?114 mod1171) (id?114 id1172) #f)) tmp1169) #f) (apply (lambda (_1174 mod1175 id1176) (values (syntax->datum id1176) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1175)))) tmp1169) (syntax-violation #f "source expression failed to match any pattern" tmp1168))) ($sc-dispatch tmp1168 (quote (any each-any any))))) e1167))) (global-extend112 (quote core) (quote if) (lambda (e1178 r1179 w1180 s1181 mod1182) ((lambda (tmp1183) ((lambda (tmp1184) (if tmp1184 (apply (lambda (_1185 test1186 then1187) (build-conditional82 s1181 (chi150 test1186 r1179 w1180 mod1182) (chi150 then1187 r1179 w1180 mod1182) (build-void80 #f))) tmp1184) ((lambda (tmp1188) (if tmp1188 (apply (lambda (_1189 test1190 then1191 else1192) (build-conditional82 s1181 (chi150 test1190 r1179 w1180 mod1182) (chi150 then1191 r1179 w1180 mod1182) (chi150 else1192 r1179 w1180 mod1182))) tmp1188) (syntax-violation #f "source expression failed to match any pattern" tmp1183))) ($sc-dispatch tmp1183 (quote (any any any any)))))) ($sc-dispatch tmp1183 (quote (any any any))))) e1178))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1196 (lambda (x1197 keys1198 clauses1199 r1200 mod1201) (if (null? clauses1199) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1197)) ((lambda (tmp1202) ((lambda (tmp1203) (if tmp1203 (apply (lambda (pat1204 exp1205) (if (if (id?114 pat1204) (and-map (lambda (x1206) (not (free-id=?137 pat1204 x1206))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1198)) #f) (let ((labels1207 (list (gen-label119))) (var1208 (gen-var161 pat1204))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1204)) (list var1208) #f (chi150 exp1205 (extend-env108 labels1207 (list (cons (quote syntax) (cons var1208 0))) r1200) (make-binding-wrap131 (list pat1204) labels1207 (quote (()))) mod1201)) (list x1197))) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1204 #t exp1205 mod1201))) tmp1203) ((lambda (tmp1209) (if tmp1209 (apply (lambda (pat1210 fender1211 exp1212) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1210 fender1211 exp1212 mod1201)) tmp1209) ((lambda (_1213) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1199))) tmp1202))) ($sc-dispatch tmp1202 (quote (any any any)))))) ($sc-dispatch tmp1202 (quote (any any))))) (car clauses1199))))) (gen-clause1195 (lambda (x1214 keys1215 clauses1216 r1217 pat1218 fender1219 exp1220 mod1221) (call-with-values (lambda () (convert-pattern1193 pat1218 keys1215)) (lambda (p1222 pvars1223) (if (not (distinct-bound-ids?140 (map car pvars1223))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1218) (if (not (and-map (lambda (x1224) (not (ellipsis?159 (car x1224)))) pvars1223)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1218) (let ((y1225 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1225) #f (let ((y1226 (build-lexical-reference83 (quote value) #f (quote tmp) y1225))) (build-conditional82 #f ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda () y1226) tmp1228) ((lambda (_1229) (build-conditional82 #f y1226 (build-dispatch-call1194 pvars1223 fender1219 y1226 r1217 mod1221) (build-data92 #f #f))) tmp1227))) ($sc-dispatch tmp1227 (quote #(atom #t))))) fender1219) (build-dispatch-call1194 pvars1223 exp1220 y1226 r1217 mod1221) (gen-syntax-case1196 x1214 keys1215 clauses1216 r1217 mod1221)))) (list (if (eq? p1222 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1214)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1214 (build-data92 #f p1222))))))))))))) (build-dispatch-call1194 (lambda (pvars1230 exp1231 y1232 r1233 mod1234) (let ((ids1235 (map car pvars1230)) (levels1236 (map cdr pvars1230))) (let ((labels1237 (gen-labels120 ids1235)) (new-vars1238 (map gen-var161 ids1235))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1235) new-vars1238 #f (chi150 exp1231 (extend-env108 labels1237 (map (lambda (var1239 level1240) (cons (quote syntax) (cons var1239 level1240))) new-vars1238 (map cdr pvars1230)) r1233) (make-binding-wrap131 ids1235 labels1237 (quote (()))) mod1234)) y1232)))))) (convert-pattern1193 (lambda (pattern1241 keys1242) (letrec ((cvt1243 (lambda (p1244 n1245 ids1246) (if (id?114 p1244) (if (bound-id-member?141 p1244 keys1242) (values (vector (quote free-id) p1244) ids1246) (values (quote any) (cons (cons p1244 n1245) ids1246))) ((lambda (tmp1247) ((lambda (tmp1248) (if (if tmp1248 (apply (lambda (x1249 dots1250) (ellipsis?159 dots1250)) tmp1248) #f) (apply (lambda (x1251 dots1252) (call-with-values (lambda () (cvt1243 x1251 (fx+72 n1245 1) ids1246)) (lambda (p1253 ids1254) (values (if (eq? p1253 (quote any)) (quote each-any) (vector (quote each) p1253)) ids1254)))) tmp1248) ((lambda (tmp1255) (if tmp1255 (apply (lambda (x1256 y1257) (call-with-values (lambda () (cvt1243 y1257 n1245 ids1246)) (lambda (y1258 ids1259) (call-with-values (lambda () (cvt1243 x1256 n1245 ids1259)) (lambda (x1260 ids1261) (values (cons x1260 y1258) ids1261)))))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda () (values (quote ()) ids1246)) tmp1262) ((lambda (tmp1263) (if tmp1263 (apply (lambda (x1264) (call-with-values (lambda () (cvt1243 x1264 n1245 ids1246)) (lambda (p1266 ids1267) (values (vector (quote vector) p1266) ids1267)))) tmp1263) ((lambda (x1268) (values (vector (quote atom) (strip160 p1244 (quote (())))) ids1246)) tmp1247))) ($sc-dispatch tmp1247 (quote #(vector each-any)))))) ($sc-dispatch tmp1247 (quote ()))))) ($sc-dispatch tmp1247 (quote (any . any)))))) ($sc-dispatch tmp1247 (quote (any any))))) p1244))))) (cvt1243 pattern1241 0 (quote ())))))) (lambda (e1269 r1270 w1271 s1272 mod1273) (let ((e1274 (source-wrap143 e1269 w1271 s1272 mod1273))) ((lambda (tmp1275) ((lambda (tmp1276) (if tmp1276 (apply (lambda (_1277 val1278 key1279 m1280) (if (and-map (lambda (x1281) (if (id?114 x1281) (not (ellipsis?159 x1281)) #f)) key1279) (let ((x1283 (gen-var161 (quote tmp)))) (build-application81 s1272 (build-lambda90 #f (list (quote tmp)) (list x1283) #f (gen-syntax-case1196 (build-lexical-reference83 (quote value) #f (quote tmp) x1283) key1279 m1280 r1270 mod1273)) (list (chi150 val1278 r1270 (quote (())) mod1273)))) (syntax-violation (quote syntax-case) "invalid literals list" e1274))) tmp1276) (syntax-violation #f "source expression failed to match any pattern" tmp1275))) ($sc-dispatch tmp1275 (quote (any any each-any . each-any))))) e1274))))) (set! sc-expand (lambda (x1287 . rest1286) (if (if (pair? x1287) (equal? (car x1287) noexpand70) #f) (cadr x1287) (let ((m1288 (if (null? rest1286) (quote e) (car rest1286))) (esew1289 (if (let ((t1290 (null? rest1286))) (if t1290 t1290 (null? (cdr rest1286)))) (quote (eval)) (cadr rest1286)))) (with-fluid* *mode*71 m1288 (lambda () (chi-top149 x1287 (quote ()) (quote ((top))) m1288 esew1289 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1291) (nonsymbol-id?113 x1291))) (set! datum->syntax (lambda (id1292 datum1293) (make-syntax-object97 datum1293 (syntax-object-wrap100 id1292) #f))) (set! syntax->datum (lambda (x1294) (strip160 x1294 (quote (()))))) (set! generate-temporaries (lambda (ls1295) (begin (let ((x1296 ls1295)) (if (not (list? x1296)) (syntax-violation (quote generate-temporaries) "invalid argument" x1296))) (map (lambda (x1297) (wrap142 (gensym) (quote ((top))) #f)) ls1295)))) (set! free-identifier=? (lambda (x1298 y1299) (begin (let ((x1300 x1298)) (if (not (nonsymbol-id?113 x1300)) (syntax-violation (quote free-identifier=?) "invalid argument" x1300))) (let ((x1301 y1299)) (if (not (nonsymbol-id?113 x1301)) (syntax-violation (quote free-identifier=?) "invalid argument" x1301))) (free-id=?137 x1298 y1299)))) (set! bound-identifier=? (lambda (x1302 y1303) (begin (let ((x1304 x1302)) (if (not (nonsymbol-id?113 x1304)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1304))) (let ((x1305 y1303)) (if (not (nonsymbol-id?113 x1305)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1305))) (bound-id=?138 x1302 y1303)))) (set! syntax-violation (lambda (who1309 message1308 form1307 . subform1306) (begin (let ((x1310 who1309)) (if (not ((lambda (x1311) (let ((t1312 (not x1311))) (if t1312 t1312 (let ((t1313 (string? x1311))) (if t1313 t1313 (symbol? x1311)))))) x1310)) (syntax-violation (quote syntax-violation) "invalid argument" x1310))) (let ((x1314 message1308)) (if (not (string? x1314)) (syntax-violation (quote syntax-violation) "invalid argument" x1314))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1309 "~a: " "") "~a " (if (null? subform1306) "in ~a" "in subform `~s' of `~s'")) (let ((tail1315 (cons message1308 (map (lambda (x1316) (strip160 x1316 (quote (())))) (append subform1306 (list form1307)))))) (if who1309 (cons who1309 tail1315) tail1315)) #f)))) (letrec ((match1321 (lambda (e1322 p1323 w1324 r1325 mod1326) (if (not r1325) #f (if (eq? p1323 (quote any)) (cons (wrap142 e1322 w1324 mod1326) r1325) (if (syntax-object?98 e1322) (match*1320 (syntax-object-expression99 e1322) p1323 (join-wraps133 w1324 (syntax-object-wrap100 e1322)) r1325 (syntax-object-module101 e1322)) (match*1320 e1322 p1323 w1324 r1325 mod1326)))))) (match*1320 (lambda (e1327 p1328 w1329 r1330 mod1331) (if (null? p1328) (if (null? e1327) r1330 #f) (if (pair? p1328) (if (pair? e1327) (match1321 (car e1327) (car p1328) w1329 (match1321 (cdr e1327) (cdr p1328) w1329 r1330 mod1331) mod1331) #f) (if (eq? p1328 (quote each-any)) (let ((l1332 (match-each-any1318 e1327 w1329 mod1331))) (if l1332 (cons l1332 r1330) #f)) (let ((atom-key1333 (vector-ref p1328 0))) (if (memv atom-key1333 (quote (each))) (if (null? e1327) (match-empty1319 (vector-ref p1328 1) r1330) (let ((l1334 (match-each1317 e1327 (vector-ref p1328 1) w1329 mod1331))) (if l1334 (letrec ((collect1335 (lambda (l1336) (if (null? (car l1336)) r1330 (cons (map car l1336) (collect1335 (map cdr l1336))))))) (collect1335 l1334)) #f))) (if (memv atom-key1333 (quote (free-id))) (if (id?114 e1327) (if (free-id=?137 (wrap142 e1327 w1329 mod1331) (vector-ref p1328 1)) r1330 #f) #f) (if (memv atom-key1333 (quote (atom))) (if (equal? (vector-ref p1328 1) (strip160 e1327 w1329)) r1330 #f) (if (memv atom-key1333 (quote (vector))) (if (vector? e1327) (match1321 (vector->list e1327) (vector-ref p1328 1) w1329 r1330 mod1331) #f))))))))))) (match-empty1319 (lambda (p1337 r1338) (if (null? p1337) r1338 (if (eq? p1337 (quote any)) (cons (quote ()) r1338) (if (pair? p1337) (match-empty1319 (car p1337) (match-empty1319 (cdr p1337) r1338)) (if (eq? p1337 (quote each-any)) (cons (quote ()) r1338) (let ((atom-key1339 (vector-ref p1337 0))) (if (memv atom-key1339 (quote (each))) (match-empty1319 (vector-ref p1337 1) r1338) (if (memv atom-key1339 (quote (free-id atom))) r1338 (if (memv atom-key1339 (quote (vector))) (match-empty1319 (vector-ref p1337 1) r1338))))))))))) (match-each-any1318 (lambda (e1340 w1341 mod1342) (if (pair? e1340) (let ((l1343 (match-each-any1318 (cdr e1340) w1341 mod1342))) (if l1343 (cons (wrap142 (car e1340) w1341 mod1342) l1343) #f)) (if (null? e1340) (quote ()) (if (syntax-object?98 e1340) (match-each-any1318 (syntax-object-expression99 e1340) (join-wraps133 w1341 (syntax-object-wrap100 e1340)) mod1342) #f))))) (match-each1317 (lambda (e1344 p1345 w1346 mod1347) (if (pair? e1344) (let ((first1348 (match1321 (car e1344) p1345 w1346 (quote ()) mod1347))) (if first1348 (let ((rest1349 (match-each1317 (cdr e1344) p1345 w1346 mod1347))) (if rest1349 (cons first1348 rest1349) #f)) #f)) (if (null? e1344) (quote ()) (if (syntax-object?98 e1344) (match-each1317 (syntax-object-expression99 e1344) p1345 (join-wraps133 w1346 (syntax-object-wrap100 e1344)) (syntax-object-module101 e1344)) #f)))))) (set! $sc-dispatch (lambda (e1350 p1351) (if (eq? p1351 (quote any)) (list e1350) (if (syntax-object?98 e1350) (match*1320 (syntax-object-expression99 e1350) p1351 (syntax-object-wrap100 e1350) (quote ()) (syntax-object-module101 e1350)) (match*1320 e1350 p1351 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1352) ((lambda (tmp1353) ((lambda (tmp1354) (if tmp1354 (apply (lambda (_1355 e11356 e21357) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11356 e21357))) tmp1354) ((lambda (tmp1359) (if tmp1359 (apply (lambda (_1360 out1361 in1362 e11363 e21364) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1362 (quote ()) (list out1361 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11363 e21364))))) tmp1359) ((lambda (tmp1366) (if tmp1366 (apply (lambda (_1367 out1368 in1369 e11370 e21371) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1369) (quote ()) (list out1368 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11370 e21371))))) tmp1366) (syntax-violation #f "source expression failed to match any pattern" tmp1353))) ($sc-dispatch tmp1353 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1353 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1353 (quote (any () any . each-any))))) x1352)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1375) ((lambda (tmp1376) ((lambda (tmp1377) (if tmp1377 (apply (lambda (_1378 k1379 keyword1380 pattern1381 template1382) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1379 (map (lambda (tmp1385 tmp1384) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1384) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1385))) template1382 pattern1381)))))) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1376))) ($sc-dispatch tmp1376 (quote (any each-any . #(each ((any . any) any))))))) x1375)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1386) ((lambda (tmp1387) ((lambda (tmp1388) (if (if tmp1388 (apply (lambda (let*1389 x1390 v1391 e11392 e21393) (and-map identifier? x1390)) tmp1388) #f) (apply (lambda (let*1395 x1396 v1397 e11398 e21399) (letrec ((f1400 (lambda (bindings1401) (if (null? bindings1401) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11398 e21399))) ((lambda (tmp1405) ((lambda (tmp1406) (if tmp1406 (apply (lambda (body1407 binding1408) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1408) body1407)) tmp1406) (syntax-violation #f "source expression failed to match any pattern" tmp1405))) ($sc-dispatch tmp1405 (quote (any any))))) (list (f1400 (cdr bindings1401)) (car bindings1401))))))) (f1400 (map list x1396 v1397)))) tmp1388) (syntax-violation #f "source expression failed to match any pattern" tmp1387))) ($sc-dispatch tmp1387 (quote (any #(each (any any)) any . each-any))))) x1386)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1409) ((lambda (tmp1410) ((lambda (tmp1411) (if tmp1411 (apply (lambda (_1412 var1413 init1414 step1415 e01416 e11417 c1418) ((lambda (tmp1419) ((lambda (tmp1420) (if tmp1420 (apply (lambda (step1421) ((lambda (tmp1422) ((lambda (tmp1423) (if tmp1423 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1413 init1414) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01416) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1418 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1421))))))) tmp1423) ((lambda (tmp1428) (if tmp1428 (apply (lambda (e11429 e21430) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1413 init1414) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01416 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11429 e21430)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1418 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1421))))))) tmp1428) (syntax-violation #f "source expression failed to match any pattern" tmp1422))) ($sc-dispatch tmp1422 (quote (any . each-any)))))) ($sc-dispatch tmp1422 (quote ())))) e11417)) tmp1420) (syntax-violation #f "source expression failed to match any pattern" tmp1419))) ($sc-dispatch tmp1419 (quote each-any)))) (map (lambda (v1437 s1438) ((lambda (tmp1439) ((lambda (tmp1440) (if tmp1440 (apply (lambda () v1437) tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (e1442) e1442) tmp1441) ((lambda (_1443) (syntax-violation (quote do) "bad step expression" orig-x1409 s1438)) tmp1439))) ($sc-dispatch tmp1439 (quote (any)))))) ($sc-dispatch tmp1439 (quote ())))) s1438)) var1413 step1415))) tmp1411) (syntax-violation #f "source expression failed to match any pattern" tmp1410))) ($sc-dispatch tmp1410 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1409)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1446 (lambda (x1450 y1451) ((lambda (tmp1452) ((lambda (tmp1453) (if tmp1453 (apply (lambda (x1454 y1455) ((lambda (tmp1456) ((lambda (tmp1457) (if tmp1457 (apply (lambda (dy1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (dx1461) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1461 dy1458))) tmp1460) ((lambda (_1462) (if (null? dy1458) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454 y1455))) tmp1459))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1454)) tmp1457) ((lambda (tmp1463) (if tmp1463 (apply (lambda (stuff1464) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1454 stuff1464))) tmp1463) ((lambda (else1465) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454 y1455)) tmp1456))) ($sc-dispatch tmp1456 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1456 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1455)) tmp1453) (syntax-violation #f "source expression failed to match any pattern" tmp1452))) ($sc-dispatch tmp1452 (quote (any any))))) (list x1450 y1451)))) (quasiappend1447 (lambda (x1466 y1467) ((lambda (tmp1468) ((lambda (tmp1469) (if tmp1469 (apply (lambda (x1470 y1471) ((lambda (tmp1472) ((lambda (tmp1473) (if tmp1473 (apply (lambda () x1470) tmp1473) ((lambda (_1474) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1470 y1471)) tmp1472))) ($sc-dispatch tmp1472 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1471)) tmp1469) (syntax-violation #f "source expression failed to match any pattern" tmp1468))) ($sc-dispatch tmp1468 (quote (any any))))) (list x1466 y1467)))) (quasivector1448 (lambda (x1475) ((lambda (tmp1476) ((lambda (x1477) ((lambda (tmp1478) ((lambda (tmp1479) (if tmp1479 (apply (lambda (x1480) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1480))) tmp1479) ((lambda (tmp1482) (if tmp1482 (apply (lambda (x1483) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483)) tmp1482) ((lambda (_1485) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1477)) tmp1478))) ($sc-dispatch tmp1478 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1478 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1477)) tmp1476)) x1475))) (quasi1449 (lambda (p1486 lev1487) ((lambda (tmp1488) ((lambda (tmp1489) (if tmp1489 (apply (lambda (p1490) (if (= lev1487 0) p1490 (quasicons1446 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1449 (list p1490) (- lev1487 1))))) tmp1489) ((lambda (tmp1491) (if (if tmp1491 (apply (lambda (args1492) (= lev1487 0)) tmp1491) #f) (apply (lambda (args1493) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1486 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1493))) tmp1491) ((lambda (tmp1494) (if tmp1494 (apply (lambda (p1495 q1496) (if (= lev1487 0) (quasiappend1447 p1495 (quasi1449 q1496 lev1487)) (quasicons1446 (quasicons1446 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1449 (list p1495) (- lev1487 1))) (quasi1449 q1496 lev1487)))) tmp1494) ((lambda (tmp1497) (if (if tmp1497 (apply (lambda (args1498 q1499) (= lev1487 0)) tmp1497) #f) (apply (lambda (args1500 q1501) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1486 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1500))) tmp1497) ((lambda (tmp1502) (if tmp1502 (apply (lambda (p1503) (quasicons1446 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1449 (list p1503) (+ lev1487 1)))) tmp1502) ((lambda (tmp1504) (if tmp1504 (apply (lambda (p1505 q1506) (quasicons1446 (quasi1449 p1505 lev1487) (quasi1449 q1506 lev1487))) tmp1504) ((lambda (tmp1507) (if tmp1507 (apply (lambda (x1508) (quasivector1448 (quasi1449 x1508 lev1487))) tmp1507) ((lambda (p1510) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1510)) tmp1488))) ($sc-dispatch tmp1488 (quote #(vector each-any)))))) ($sc-dispatch tmp1488 (quote (any . any)))))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1488 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1488 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1486)))) (lambda (x1511) ((lambda (tmp1512) ((lambda (tmp1513) (if tmp1513 (apply (lambda (_1514 e1515) (quasi1449 e1515 0)) tmp1513) (syntax-violation #f "source expression failed to match any pattern" tmp1512))) ($sc-dispatch tmp1512 (quote (any any))))) x1511))))) +(define include (make-syncase-macro (quote macro) (lambda (x1516) (letrec ((read-file1517 (lambda (fn1518 k1519) (let ((p1520 (open-input-file fn1518))) (letrec ((f1521 (lambda (x1522) (if (eof-object? x1522) (begin (close-input-port p1520) (quote ())) (cons (datum->syntax k1519 x1522) (f1521 (read p1520))))))) (f1521 (read p1520))))))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (k1525 filename1526) (let ((fn1527 (syntax->datum filename1526))) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (exp1530) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1530)) tmp1529) (syntax-violation #f "source expression failed to match any pattern" tmp1528))) ($sc-dispatch tmp1528 (quote each-any)))) (read-file1517 fn1527 k1525)))) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote (any any))))) x1516))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (_1535 e1536) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1532)) tmp1534) (syntax-violation #f "source expression failed to match any pattern" tmp1533))) ($sc-dispatch tmp1533 (quote (any any))))) x1532)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1537) ((lambda (tmp1538) ((lambda (tmp1539) (if tmp1539 (apply (lambda (_1540 e1541) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1537)) tmp1539) (syntax-violation #f "source expression failed to match any pattern" tmp1538))) ($sc-dispatch tmp1538 (quote (any any))))) x1537)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1542) ((lambda (tmp1543) ((lambda (tmp1544) (if tmp1544 (apply (lambda (_1545 e1546 m11547 m21548) ((lambda (tmp1549) ((lambda (body1550) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1546)) body1550)) tmp1549)) (letrec ((f1551 (lambda (clause1552 clauses1553) (if (null? clauses1553) ((lambda (tmp1555) ((lambda (tmp1556) (if tmp1556 (apply (lambda (e11557 e21558) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11557 e21558))) tmp1556) ((lambda (tmp1560) (if tmp1560 (apply (lambda (k1561 e11562 e21563) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1561)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11562 e21563)))) tmp1560) ((lambda (_1566) (syntax-violation (quote case) "bad clause" x1542 clause1552)) tmp1555))) ($sc-dispatch tmp1555 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1555 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1552) ((lambda (tmp1567) ((lambda (rest1568) ((lambda (tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (k1571 e11572 e21573) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1571)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11572 e21573)) rest1568)) tmp1570) ((lambda (_1576) (syntax-violation (quote case) "bad clause" x1542 clause1552)) tmp1569))) ($sc-dispatch tmp1569 (quote (each-any any . each-any))))) clause1552)) tmp1567)) (f1551 (car clauses1553) (cdr clauses1553))))))) (f1551 m11547 m21548)))) tmp1544) (syntax-violation #f "source expression failed to match any pattern" tmp1543))) ($sc-dispatch tmp1543 (quote (any any any . each-any))))) x1542)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1577) ((lambda (tmp1578) ((lambda (tmp1579) (if tmp1579 (apply (lambda (_1580 e1581) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1581)) (list (cons _1580 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1581 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1579) (syntax-violation #f "source expression failed to match any pattern" tmp1578))) ($sc-dispatch tmp1578 (quote (any any))))) x1577)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index c2668c0c4..f18b626e3 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -560,7 +560,6 @@ ;;; ::= (macro . ) macros ;;; (core . ) core forms -;;; (external-macro . ) external-macro ;;; (module-ref . ) @ or @@ ;;; (begin) begin ;;; (define) define @@ -999,9 +998,9 @@ ;;; ;;; type value explanation ;;; ------------------------------------------------------------------- -;;; core procedure core form (including singleton) -;;; external-macro procedure external macro -;;; module-ref procedure @ or @@ form +;;; core procedure core singleton +;;; core-form procedure core form +;;; module-ref procedure @ or @@ singleton ;;; lexical name lexical variable reference ;;; global name global variable reference ;;; begin none begin keyword @@ -1031,7 +1030,7 @@ ;;; forms, although perhaps this should be done by the consumer. (define syntax-type - (lambda (e r w s rib mod) + (lambda (e r w s rib mod for-car?) (cond ((symbol? e) (let* ((n (id-var-name e w)) @@ -1041,64 +1040,70 @@ ((lexical) (values type (binding-value b) e w s mod)) ((global) (values type n e w s mod)) ((macro) - (syntax-type (chi-macro (binding-value b) e r w rib mod) - r empty-wrap s rib mod)) + (if for-car? + (values type (binding-value b) e w s mod) + (syntax-type (chi-macro (binding-value b) e r w rib mod) + r empty-wrap s rib mod #f))) (else (values type (binding-value b) e w s mod))))) ((pair? e) (let ((first (car e))) - (if (id? first) - (let* ((n (id-var-name first w)) - (b (lookup n r (or (and (syntax-object? first) - (syntax-object-module first)) - mod))) - (type (binding-type b))) - (case type - ((lexical) - (values 'lexical-call (binding-value b) e w s mod)) - ((global) - (values 'global-call n e w s mod)) - ((macro) - (syntax-type (chi-macro (binding-value b) e r w rib mod) - r empty-wrap s rib mod)) - ((core external-macro module-ref) - (values type (binding-value b) e w s mod)) - ((local-syntax) - (values 'local-syntax-form (binding-value b) e w s mod)) - ((begin) - (values 'begin-form #f e w s mod)) - ((eval-when) - (values 'eval-when-form #f e w s mod)) - ((define) - (syntax-case e () - ((_ name val) - (id? (syntax name)) - (values 'define-form (syntax name) (syntax val) w s mod)) - ((_ (name . args) e1 e2 ...) - (and (id? (syntax name)) - (valid-bound-ids? (lambda-var-list (syntax args)))) - ; need lambda here... - (values 'define-form (wrap (syntax name) w mod) - (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) - empty-wrap s mod)) - ((_ name) - (id? (syntax name)) - (values 'define-form (wrap (syntax name) w mod) - (syntax (if #f #f)) - empty-wrap s mod)))) - ((define-syntax) - (syntax-case e () - ((_ name val) - (id? (syntax name)) - (values 'define-syntax-form (syntax name) - (syntax val) w s mod)))) - (else - (values 'call #f e w s mod)))) - (values 'call #f e w s mod)))) + (call-with-values + (lambda () (syntax-type first r w s rib mod #t)) + (lambda (ftype fval fe fw fs fmod) + (case ftype + ((lexical) + (values 'lexical-call fval e w s mod)) + ((global) + ;; If we got here via an (@@ ...) expansion, we need to + ;; make sure the fmod information is propagated back + ;; correctly -- hence this consing. + (values 'global-call (make-syntax-object fval w fmod) + e w s mod)) + ((macro) + (syntax-type (chi-macro fval e r w rib mod) + r empty-wrap s rib mod for-car?)) + ((module-ref) + (call-with-values (lambda () (fval e)) + (lambda (sym mod) + (syntax-type sym r w s rib mod for-car?)))) + ((core) + (values 'core-form fval e w s mod)) + ((local-syntax) + (values 'local-syntax-form fval e w s mod)) + ((begin) + (values 'begin-form #f e w s mod)) + ((eval-when) + (values 'eval-when-form #f e w s mod)) + ((define) + (syntax-case e () + ((_ name val) + (id? (syntax name)) + (values 'define-form (syntax name) (syntax val) w s mod)) + ((_ (name . args) e1 e2 ...) + (and (id? (syntax name)) + (valid-bound-ids? (lambda-var-list (syntax args)))) + ; need lambda here... + (values 'define-form (wrap (syntax name) w mod) + (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) + empty-wrap s mod)) + ((_ name) + (id? (syntax name)) + (values 'define-form (wrap (syntax name) w mod) + (syntax (if #f #f)) + empty-wrap s mod)))) + ((define-syntax) + (syntax-case e () + ((_ name val) + (id? (syntax name)) + (values 'define-syntax-form (syntax name) + (syntax val) w s mod)))) + (else + (values 'call #f e w s mod))))))) ((syntax-object? e) (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) - s rib (or (syntax-object-module e) mod))) + s rib (or (syntax-object-module e) mod) for-car?)) ((self-evaluating? e) (values 'constant #f e w s mod)) (else (values 'other #f e w s mod))))) @@ -1111,7 +1116,7 @@ (if (eq? m 'c&e) (top-level-eval-hook x mod)) x)))) (call-with-values - (lambda () (syntax-type e r w (source-annotation e) #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) (lambda (type value e w s mod) (case type ((begin-form) @@ -1187,7 +1192,7 @@ (define chi (lambda (e r w mod) (call-with-values - (lambda () (syntax-type e r w (source-annotation e) #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) (lambda (type value e w s mod) (chi-expr type value e r w s mod))))) @@ -1196,7 +1201,7 @@ (case type ((lexical) (build-lexical-reference 'value s e value)) - ((core external-macro) + ((core core-form) ;; apply transformer (value e r w s mod)) ((module-ref) @@ -1210,9 +1215,12 @@ e r w s mod)) ((global-call) (chi-application - (build-global-reference (source-annotation (car e)) value - (if (syntax-object? (car e)) - (syntax-object-module (car e)) + (build-global-reference (source-annotation (car e)) + (if (syntax-object? value) + (syntax-object-expression value) + value) + (if (syntax-object? value) + (syntax-object-module value) mod)) e r w s mod)) ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) @@ -1342,7 +1350,7 @@ (syntax-violation #f "no expressions in body" outer-form) (let ((e (cdar body)) (er (caar body))) (call-with-values - (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod)) + (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f)) (lambda (type value e w s mod) (case type ((define-form) @@ -1843,7 +1851,7 @@ (source-wrap e w s mod))))))) ((_ (head tail ...) val) (call-with-values - (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod)) + (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod #t)) (lambda (type value ee ww ss modmod) (case type ((module-ref) From 12798872ff39e27dbcf90675c3d3554ae27df750 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 6 Jun 2009 00:08:30 +0100 Subject: [PATCH 199/375] Fix popen.test on NetBSD and Ubuntu Jaunty, where sh is not Bash Thanks to Greg Troxel for reporting, and Barry Fishman for the explanation and fix. * test-suite/tests/popen.test ("open-input-pipe"): Use shell function `read' with an explicit argument, as apparently not all shells support read with no argument. --- THANKS | 1 + test-suite/tests/popen.test | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index c347abc73..e3cf1e37c 100644 --- a/THANKS +++ b/THANKS @@ -37,6 +37,7 @@ For fixes or providing information which led to a fix: John W Eaton Clinton Ebadi David Fang + Barry Fishman Charles Gagnon Peter Gavin Eric Gillespie, Jr diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 08bfa7cb4..9cc68f21c 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -77,7 +77,7 @@ (let* ((p2c (pipe)) (port (with-input-from-port (car p2c) (lambda () - (open-input-pipe "read && echo $REPLY"))))) + (open-input-pipe "read line && echo $line"))))) (display "hello\n" (cdr p2c)) (force-output (cdr p2c)) (let ((result (eq? (read port) 'hello))) From 4bcc952d4500d484cc43df47e2f7d64e5bc14ff3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 6 Jun 2009 14:07:29 +0200 Subject: [PATCH 200/375] fix bug in goops' method cache with rest args * module/oop/goops/compile.scm (code-table-lookup): Fix a tricky little bug! * test-suite/tests/goops.test ("the method cache"): Add a wee test. --- module/oop/goops/compile.scm | 11 ++++++----- test-suite/tests/goops.test | 13 +++++++++++++ 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm index e6b13c416..732c1bccd 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -34,11 +34,12 @@ (define code-table-lookup (letrec ((check-entry (lambda (entry types) - (if (null? types) - (and (not (struct? (car entry))) - entry) - (and (eq? (car entry) (car types)) - (check-entry (cdr entry) (cdr types))))))) + (cond + ((not (pair? entry)) (and (null? types) entry)) + ((null? types) #f) + (else + (and (eq? (car entry) (car types)) + (check-entry (cdr entry) (cdr types)))))))) (lambda (code-table types) (cond ((null? code-table) #f) ((check-entry (car code-table) types)) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 2317228e4..7cdc396aa 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -261,6 +261,19 @@ (method-more-specific? m1 m2 '())) (current-module)))) +(with-test-prefix "the method cache" + (pass-if "defining a method with a rest arg" + (let ((m (current-module))) + (eval '(define-method (foo bar . baz) + (cons bar baz)) + m) + (eval '(foo 1) + m) + (eval '(foo 1 2) + m) + (eval '(equal? (foo 1 2) '(1 2)) + m)))) + (with-test-prefix "defining accessors" (with-test-prefix "define-accessor" From 586cfdecfa4021e725287a02b57624418e597354 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 6 Jun 2009 15:45:00 +0200 Subject: [PATCH 201/375] new instructions: make-int64, make-uint64 * doc/ref/vm.texi (Loading Instructions): Remove references to load-integer and load-unsigned-integer -- they're still in the VM but will be removed at some point. (Data Control Instructions): Add make-int64 and make-uint64. * libguile/vm-i-loader.c (load-unsigned-integer): Allow 8-byte values. But this instruction is on its way out, yo. * libguile/vm-i-system.c (make-int64, make-uint64): New instructions. * module/language/assembly.scm (object->assembly): Write out make-int64 and make-uint64 instructions, using bytevectors to do the endianness conversion. (assembly->object): And pretty-print them back, for disassembly. * module/language/glil/compile-assembly.scm: Don't generate load-integer / load-unsigned-integer instructions. --- doc/ref/vm.texi | 19 ++++++++------ libguile/vm-i-loader.c | 6 ++--- libguile/vm-i-system.c | 30 +++++++++++++++++++++++ module/language/assembly.scm | 20 +++++++++++++++ module/language/glil/compile-assembly.scm | 8 ------ 5 files changed, 65 insertions(+), 18 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 8d7778c1c..fa655238f 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -543,14 +543,8 @@ the instruction pointer to the next VM instruction. All of these loading instructions have a @code{length} parameter, indicating the size of the embedded data, in bytes. The length itself -may be encoded in 1, 2, or 4 bytes. +is encoded in 3 bytes. -@deffn Instruction load-integer length -@deffnx Instruction load-unsigned-integer length -Load a 32-bit integer or unsigned integer from the instruction stream. -The bytes of the integer are read in order of decreasing significance -(i.e., big-endian). -@end deffn @deffn Instruction load-number length Load an arbitrary number from the instruction stream. The number is embedded in the stream as a string. @@ -743,6 +737,17 @@ Push the immediate value @code{1} onto the stack. Push @var{value}, a 16-bit integer, onto the stack. @end deffn +@deffn Instruction make-uint64 value +Push @var{value}, an unsigned 64-bit integer, onto the stack. The +value is encoded in 8 bytes, most significant byte first (big-endian). +@end deffn + +@deffn Instruction make-int64 value +Push @var{value}, a signed 64-bit integer, onto the stack. The value +is encoded in 8 bytes, most significant byte first (big-endian), in +twos-complement arithmetic. +@end deffn + @deffn Instruction make-false Push @code{#f} onto the stack. @end deffn diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 50569e01a..e5bb35e6e 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -24,13 +24,13 @@ VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer") size_t len; FETCH_LENGTH (len); - if (SCM_LIKELY (len <= 4)) + if (SCM_LIKELY (len <= 8)) { - unsigned int val = 0; + scm_t_uint64 val = 0; while (len-- > 0) val = (val << 8U) + FETCH (); SYNC_REGISTER (); - PUSH (scm_from_uint (val)); + PUSH (scm_from_uint64 (val)); NEXT; } else diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 36ff5bde8..6b130e7e1 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -138,6 +138,36 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1) +{ + scm_t_uint64 v = 0; + v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + PUSH (scm_from_int64 ((scm_t_int64) v)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1) +{ + scm_t_uint64 v = 0; + v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + PUSH (scm_from_uint64 (v)); + NEXT; +} + VM_DEFINE_INSTRUCTION (14, make_char8, "make-char8", 1, 0, 1) { PUSH (SCM_MAKE_CHAR (FETCH ())); diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 3ffbf11f1..3f72cf6aa 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -114,6 +114,16 @@ ((and (<= -32768 x) (< x 32768)) (let ((n (if (< x 0) (+ x 65536) x))) `(make-int16 ,(quotient n 256) ,(modulo n 256)))) + ((and (<= 0 x #xffffffffffffffff)) + `(make-uint64 ,@(bytevector->u8-list + (let ((bv (make-bytevector 8))) + (bytevector-u64-set! bv 0 x (endianness big)) + bv)))) + ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff)) + `(make-int64 ,@(bytevector->u8-list + (let ((bv (make-bytevector 8))) + (bytevector-s64-set! bv 0 x (endianness big)) + bv)))) (else #f))) ((char? x) `(make-char8 ,(char->integer x))) (else #f))) @@ -128,6 +138,16 @@ ((make-int16 ,n1 ,n2) (let ((n (+ (* n1 256) n2))) (if (< n 32768) n (- n 65536)))) + ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) + (bytevector-u64-ref + (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) + 0 + (endianness big))) + ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) + (bytevector-s64-ref + (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) + 0 + (endianness big))) ((make-char8 ,n) (integer->char n)) ((load-string ,s) s) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index dcdbc5133..96c6383c0 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -352,14 +352,6 @@ `(,@(subprogram-table x) ,@(align-program (subprogram-prog x) (addr+ addr (subprogram-table x))))) - ((and (integer? x) (exact? x)) - (let ((str (do ((n x (quotient n 256)) - (l '() (cons (modulo n 256) l))) - ((= n 0) - (list->string (map integer->char l)))))) - (if (< x 0) - `((load-integer ,str)) - `((load-unsigned-integer ,str))))) ((number? x) `((load-number ,(number->string x)))) ((string? x) From c0ee32452f4babfc99526ed35d1f80d128d8658b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 7 Jun 2009 00:53:31 +0200 Subject: [PATCH 202/375] fix incorrect inlining of + when + is locally redefined * libguile/vm-i-scheme.c (FUNC2): Use a signed value for the intermediate result here. Not sure what the effect is, though. * module/ice-9/psyntax.scm (chi-top): Toplevel definitions ensure that variables are defined in the current module. Fixes the specific case of guile-lib's md5.scm, which redefines + -- this code is needed so that we don't incorrectly open-code +. * module/language/tree-il/primitives.scm (resolve-primitives!): I think there were some cases in which vars and names would not resolve properly here. Fix those. --- libguile/vm-i-scheme.c | 2 +- module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 3 +++ module/language/tree-il/primitives.scm | 13 +++++++------ 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 38dea32b9..3742135a6 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -197,7 +197,7 @@ VM_DEFINE_FUNCTION (99, ge, "ge?", 2) ARGS2 (x, y); \ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ { \ - scm_t_bits n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\ + scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\ if (SCM_FIXABLE (n)) \ RETURN (SCM_I_MAKINUM (n)); \ } \ diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0043cbbd3..267d54dd5 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,6 +1,6 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars286) (letrec ((lvl287 (lambda (vars288 ls289 w290) (if (pair? vars288) (lvl287 (cdr vars288) (cons (wrap142 (car vars288) w290 #f) ls289) w290) (if (id?114 vars288) (cons (wrap142 vars288 w290 #f) ls289) (if (null? vars288) ls289 (if (syntax-object?98 vars288) (lvl287 (syntax-object-expression99 vars288) ls289 (join-wraps133 w290 (syntax-object-wrap100 vars288))) (cons vars288 ls289)))))))) (lvl287 vars286 (quote ()) (quote (())))))) (gen-var161 (lambda (id291) (let ((id292 (if (syntax-object?98 id291) (syntax-object-expression99 id291) id291))) (gensym (symbol->string id292))))) (strip160 (lambda (x293 w294) (if (memq (quote top) (wrap-marks117 w294)) x293 (letrec ((f295 (lambda (x296) (if (syntax-object?98 x296) (strip160 (syntax-object-expression99 x296) (syntax-object-wrap100 x296)) (if (pair? x296) (let ((a297 (f295 (car x296))) (d298 (f295 (cdr x296)))) (if (if (eq? a297 (car x296)) (eq? d298 (cdr x296)) #f) x296 (cons a297 d298))) (if (vector? x296) (let ((old299 (vector->list x296))) (let ((new300 (map f295 old299))) (if (and-map*17 eq? old299 new300) x296 (list->vector new300)))) x296)))))) (f295 x293))))) (ellipsis?159 (lambda (x301) (if (nonsymbol-id?113 x301) (free-id=?137 x301 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded302 mod303) (let ((p304 (local-eval-hook77 expanded302 mod303))) (if (procedure? p304) p304 (syntax-violation #f "nonprocedure transformer" p304))))) (chi-local-syntax156 (lambda (rec?305 e306 r307 w308 s309 mod310 k311) ((lambda (tmp312) ((lambda (tmp313) (if tmp313 (apply (lambda (_314 id315 val316 e1317 e2318) (let ((ids319 id315)) (if (not (valid-bound-ids?139 ids319)) (syntax-violation #f "duplicate bound keyword" e306) (let ((labels321 (gen-labels120 ids319))) (let ((new-w322 (make-binding-wrap131 ids319 labels321 w308))) (k311 (cons e1317 e2318) (extend-env108 labels321 (let ((w324 (if rec?305 new-w322 w308)) (trans-r325 (macros-only-env110 r307))) (map (lambda (x326) (cons (quote macro) (eval-local-transformer157 (chi150 x326 trans-r325 w324 mod310) mod310))) val316)) r307) new-w322 s309 mod310)))))) tmp313) ((lambda (_328) (syntax-violation #f "bad local syntax definition" (source-wrap143 e306 w308 s309 mod310))) tmp312))) ($sc-dispatch tmp312 (quote (any #(each (any any)) any . each-any))))) e306))) (chi-lambda-clause155 (lambda (e329 docstring330 c331 r332 w333 mod334 k335) ((lambda (tmp336) ((lambda (tmp337) (if (if tmp337 (apply (lambda (args338 doc339 e1340 e2341) (if (string? (syntax->datum doc339)) (not docstring330) #f)) tmp337) #f) (apply (lambda (args342 doc343 e1344 e2345) (chi-lambda-clause155 e329 doc343 (cons args342 (cons e1344 e2345)) r332 w333 mod334 k335)) tmp337) ((lambda (tmp347) (if tmp347 (apply (lambda (id348 e1349 e2350) (let ((ids351 id348)) (if (not (valid-bound-ids?139 ids351)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels353 (gen-labels120 ids351)) (new-vars354 (map gen-var161 ids351))) (k335 (map syntax->datum ids351) new-vars354 (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1349 e2350) e329 (extend-var-env109 labels353 new-vars354 r332) (make-binding-wrap131 ids351 labels353 w333) mod334)))))) tmp347) ((lambda (tmp356) (if tmp356 (apply (lambda (ids357 e1358 e2359) (let ((old-ids360 (lambda-var-list162 ids357))) (if (not (valid-bound-ids?139 old-ids360)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels361 (gen-labels120 old-ids360)) (new-vars362 (map gen-var161 old-ids360))) (k335 (letrec ((f363 (lambda (ls1364 ls2365) (if (null? ls1364) (syntax->datum ls2365) (f363 (cdr ls1364) (cons (syntax->datum (car ls1364)) ls2365)))))) (f363 (cdr old-ids360) (car old-ids360))) (letrec ((f366 (lambda (ls1367 ls2368) (if (null? ls1367) ls2368 (f366 (cdr ls1367) (cons (car ls1367) ls2368)))))) (f366 (cdr new-vars362) (car new-vars362))) (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1358 e2359) e329 (extend-var-env109 labels361 new-vars362 r332) (make-binding-wrap131 old-ids360 labels361 w333) mod334)))))) tmp356) ((lambda (_370) (syntax-violation (quote lambda) "bad lambda" e329)) tmp336))) ($sc-dispatch tmp336 (quote (any any . each-any)))))) ($sc-dispatch tmp336 (quote (each-any any . each-any)))))) ($sc-dispatch tmp336 (quote (any any any . each-any))))) c331))) (chi-body154 (lambda (body371 outer-form372 r373 w374 mod375) (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) (let ((ribcage377 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w378 (make-wrap116 (wrap-marks117 w374) (cons ribcage377 (wrap-subst118 w374))))) (letrec ((parse379 (lambda (body380 ids381 labels382 var-ids383 vars384 vals385 bindings386) (if (null? body380) (syntax-violation #f "no expressions in body" outer-form372) (let ((e388 (cdar body380)) (er389 (caar body380))) (call-with-values (lambda () (syntax-type148 e388 er389 (quote (())) (source-annotation105 er389) ribcage377 mod375 #f)) (lambda (type390 value391 e392 w393 s394 mod395) (if (memv type390 (quote (define-form))) (let ((id396 (wrap142 value391 w393 mod395)) (label397 (gen-label119))) (let ((var398 (gen-var161 id396))) (begin (extend-ribcage!130 ribcage377 id396 label397) (parse379 (cdr body380) (cons id396 ids381) (cons label397 labels382) (cons id396 var-ids383) (cons var398 vars384) (cons (cons er389 (wrap142 e392 w393 mod395)) vals385) (cons (cons (quote lexical) var398) bindings386))))) (if (memv type390 (quote (define-syntax-form))) (let ((id399 (wrap142 value391 w393 mod395)) (label400 (gen-label119))) (begin (extend-ribcage!130 ribcage377 id399 label400) (parse379 (cdr body380) (cons id399 ids381) (cons label400 labels382) var-ids383 vars384 vals385 (cons (cons (quote macro) (cons er389 (wrap142 e392 w393 mod395))) bindings386)))) (if (memv type390 (quote (begin-form))) ((lambda (tmp401) ((lambda (tmp402) (if tmp402 (apply (lambda (_403 e1404) (parse379 (letrec ((f405 (lambda (forms406) (if (null? forms406) (cdr body380) (cons (cons er389 (wrap142 (car forms406) w393 mod395)) (f405 (cdr forms406))))))) (f405 e1404)) ids381 labels382 var-ids383 vars384 vals385 bindings386)) tmp402) (syntax-violation #f "source expression failed to match any pattern" tmp401))) ($sc-dispatch tmp401 (quote (any . each-any))))) e392) (if (memv type390 (quote (local-syntax-form))) (chi-local-syntax156 value391 e392 er389 w393 s394 mod395 (lambda (forms408 er409 w410 s411 mod412) (parse379 (letrec ((f413 (lambda (forms414) (if (null? forms414) (cdr body380) (cons (cons er409 (wrap142 (car forms414) w410 mod412)) (f413 (cdr forms414))))))) (f413 forms408)) ids381 labels382 var-ids383 vars384 vals385 bindings386))) (if (null? ids381) (build-sequence93 #f (map (lambda (x415) (chi150 (cdr x415) (car x415) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))) (begin (if (not (valid-bound-ids?139 ids381)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form372)) (letrec ((loop416 (lambda (bs417 er-cache418 r-cache419) (if (not (null? bs417)) (let ((b420 (car bs417))) (if (eq? (car b420) (quote macro)) (let ((er421 (cadr b420))) (let ((r-cache422 (if (eq? er421 er-cache418) r-cache419 (macros-only-env110 er421)))) (begin (set-cdr! b420 (eval-local-transformer157 (chi150 (cddr b420) r-cache422 (quote (())) mod395) mod395)) (loop416 (cdr bs417) er421 r-cache422)))) (loop416 (cdr bs417) er-cache418 r-cache419))))))) (loop416 bindings386 #f #f)) (set-cdr! r376 (extend-env108 labels382 bindings386 (cdr r376))) (build-letrec96 #f (map syntax->datum var-ids383) vars384 (map (lambda (x423) (chi150 (cdr x423) (car x423) (quote (())) mod395)) vals385) (build-sequence93 #f (map (lambda (x424) (chi150 (cdr x424) (car x424) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))))))))))))))))) (parse379 (map (lambda (x387) (cons r376 (wrap142 x387 w378 mod375))) body371) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p425 e426 r427 w428 rib429 mod430) (letrec ((rebuild-macro-output431 (lambda (x432 m433) (if (pair? x432) (cons (rebuild-macro-output431 (car x432) m433) (rebuild-macro-output431 (cdr x432) m433)) (if (syntax-object?98 x432) (let ((w434 (syntax-object-wrap100 x432))) (let ((ms435 (wrap-marks117 w434)) (s436 (wrap-subst118 w434))) (if (if (pair? ms435) (eq? (car ms435) #f) #f) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cdr ms435) (if rib429 (cons rib429 (cdr s436)) (cdr s436))) (syntax-object-module101 x432)) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cons m433 ms435) (if rib429 (cons rib429 (cons (quote shift) s436)) (cons (quote shift) s436))) (let ((pmod437 (procedure-module p425))) (if pmod437 (cons (quote hygiene) (module-name pmod437)) (quote (hygiene guile)))))))) (if (vector? x432) (let ((n438 (vector-length x432))) (let ((v439 (make-vector n438))) (letrec ((loop440 (lambda (i441) (if (fx=74 i441 n438) (begin (if #f #f) v439) (begin (vector-set! v439 i441 (rebuild-macro-output431 (vector-ref x432 i441) m433)) (loop440 (fx+72 i441 1))))))) (loop440 0)))) (if (symbol? x432) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e426 w428 s mod430) x432) x432))))))) (rebuild-macro-output431 (p425 (wrap142 e426 (anti-mark129 w428) mod430)) (string #\m))))) (chi-application152 (lambda (x442 e443 r444 w445 s446 mod447) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (e0450 e1451) (build-application81 s446 x442 (map (lambda (e452) (chi150 e452 r444 w445 mod447)) e1451))) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e443))) (chi-expr151 (lambda (type454 value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (lexical))) (build-lexical-reference83 (quote value) s459 e456 value455) (if (memv type454 (quote (core core-form))) (value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (module-ref))) (call-with-values (lambda () (value455 e456)) (lambda (id461 mod462) (build-global-reference86 s459 id461 mod462))) (if (memv type454 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e456)) (car e456) value455) e456 r457 w458 s459 mod460) (if (memv type454 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e456)) (if (syntax-object?98 value455) (syntax-object-expression99 value455) value455) (if (syntax-object?98 value455) (syntax-object-module101 value455) mod460)) e456 r457 w458 s459 mod460) (if (memv type454 (quote (constant))) (build-data92 s459 (strip160 (source-wrap143 e456 w458 s459 mod460) (quote (())))) (if (memv type454 (quote (global))) (build-global-reference86 s459 value455 mod460) (if (memv type454 (quote (call))) (chi-application152 (chi150 (car e456) r457 w458 mod460) e456 r457 w458 s459 mod460) (if (memv type454 (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466 e2467) (chi-sequence144 (cons e1466 e2467) r457 w458 s459 mod460)) tmp464) (syntax-violation #f "source expression failed to match any pattern" tmp463))) ($sc-dispatch tmp463 (quote (any any . each-any))))) e456) (if (memv type454 (quote (local-syntax-form))) (chi-local-syntax156 value455 e456 r457 w458 s459 mod460 chi-sequence144) (if (memv type454 (quote (eval-when-form))) ((lambda (tmp469) ((lambda (tmp470) (if tmp470 (apply (lambda (_471 x472 e1473 e2474) (let ((when-list475 (chi-when-list147 e456 x472 w458))) (if (memq (quote eval) when-list475) (chi-sequence144 (cons e1473 e2474) r457 w458 s459 mod460) (chi-void158)))) tmp470) (syntax-violation #f "source expression failed to match any pattern" tmp469))) ($sc-dispatch tmp469 (quote (any each-any any . each-any))))) e456) (if (memv type454 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e456 (wrap142 value455 w458 mod460)) (if (memv type454 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e456 w458 s459 mod460)) (if (memv type454 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e456 w458 s459 mod460)) (syntax-violation #f "unexpected syntax" (source-wrap143 e456 w458 s459 mod460)))))))))))))))))) (chi150 (lambda (e478 r479 w480 mod481) (call-with-values (lambda () (syntax-type148 e478 r479 w480 (source-annotation105 e478) #f mod481 #f)) (lambda (type482 value483 e484 w485 s486 mod487) (chi-expr151 type482 value483 e484 r479 w485 s486 mod487))))) (chi-top149 (lambda (e488 r489 w490 m491 esew492 mod493) (call-with-values (lambda () (syntax-type148 e488 r489 w490 (source-annotation105 e488) #f mod493 #f)) (lambda (type501 value502 e503 w504 s505 mod506) (if (memv type501 (quote (begin-form))) ((lambda (tmp507) ((lambda (tmp508) (if tmp508 (apply (lambda (_509) (chi-void158)) tmp508) ((lambda (tmp510) (if tmp510 (apply (lambda (_511 e1512 e2513) (chi-top-sequence145 (cons e1512 e2513) r489 w504 s505 m491 esew492 mod506)) tmp510) (syntax-violation #f "source expression failed to match any pattern" tmp507))) ($sc-dispatch tmp507 (quote (any any . each-any)))))) ($sc-dispatch tmp507 (quote (any))))) e503) (if (memv type501 (quote (local-syntax-form))) (chi-local-syntax156 value502 e503 r489 w504 s505 mod506 (lambda (body515 r516 w517 s518 mod519) (chi-top-sequence145 body515 r516 w517 s518 m491 esew492 mod519))) (if (memv type501 (quote (eval-when-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 x523 e1524 e2525) (let ((when-list526 (chi-when-list147 e503 x523 w504)) (body527 (cons e1524 e2525))) (if (eq? m491 (quote e)) (if (memq (quote eval) when-list526) (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) (chi-void158)) (if (memq (quote load) when-list526) (if (let ((t530 (memq (quote compile) when-list526))) (if t530 t530 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (chi-top-sequence145 body527 r489 w504 s505 (quote c&e) (quote (compile load)) mod506) (if (memq m491 (quote (c c&e))) (chi-top-sequence145 body527 r489 w504 s505 (quote c) (quote (load)) mod506) (chi-void158))) (if (let ((t531 (memq (quote compile) when-list526))) (if t531 t531 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) mod506) (chi-void158)) (chi-void158)))))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any each-any any . each-any))))) e503) (if (memv type501 (quote (define-syntax-form))) (let ((n532 (id-var-name136 value502 w504)) (r533 (macros-only-env110 r489))) (if (memv m491 (quote (c))) (if (memq (quote compile) esew492) (let ((e534 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e534 mod506) (if (memq (quote load) esew492) e534 (chi-void158)))) (if (memq (quote load) esew492) (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) (chi-void158))) (if (memv m491 (quote (c&e))) (let ((e535 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e535 mod506) e535)) (begin (if (memq (quote eval) esew492) (top-level-eval-hook76 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) mod506)) (chi-void158))))) (if (memv type501 (quote (define-form))) (let ((n536 (id-var-name136 value502 w504))) (let ((type537 (binding-type106 (lookup111 n536 r489 mod506)))) (if (memv type537 (quote (global core macro module-ref))) (let ((x538 (build-global-definition89 s505 n536 (chi150 e503 r489 w504 mod506)))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x538 mod506)) x538)) (if (memv type537 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e503 (wrap142 value502 w504 mod506)) (syntax-violation #f "cannot define keyword at top level" e503 (wrap142 value502 w504 mod506)))))) (let ((x539 (chi-expr151 type501 value502 e503 r489 w504 s505 mod506))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x539 mod506)) x539))))))))))) (syntax-type148 (lambda (e540 r541 w542 s543 rib544 mod545 for-car?546) (if (symbol? e540) (let ((n547 (id-var-name136 e540 w542))) (let ((b548 (lookup111 n547 r541 mod545))) (let ((type549 (binding-type106 b548))) (if (memv type549 (quote (lexical))) (values type549 (binding-value107 b548) e540 w542 s543 mod545) (if (memv type549 (quote (global))) (values type549 n547 e540 w542 s543 mod545) (if (memv type549 (quote (macro))) (if for-car?546 (values type549 (binding-value107 b548) e540 w542 s543 mod545) (syntax-type148 (chi-macro153 (binding-value107 b548) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 #f)) (values type549 (binding-value107 b548) e540 w542 s543 mod545))))))) (if (pair? e540) (let ((first550 (car e540))) (call-with-values (lambda () (syntax-type148 first550 r541 w542 s543 rib544 mod545 #t)) (lambda (ftype551 fval552 fe553 fw554 fs555 fmod556) (if (memv ftype551 (quote (lexical))) (values (quote lexical-call) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (global))) (values (quote global-call) (make-syntax-object97 fval552 w542 fmod556) e540 w542 s543 mod545) (if (memv ftype551 (quote (macro))) (syntax-type148 (chi-macro153 fval552 e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 for-car?546) (if (memv ftype551 (quote (module-ref))) (call-with-values (lambda () (fval552 e540)) (lambda (sym557 mod558) (syntax-type148 sym557 r541 w542 s543 rib544 mod558 for-car?546))) (if (memv ftype551 (quote (core))) (values (quote core-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (local-syntax))) (values (quote local-syntax-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (begin))) (values (quote begin-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (eval-when))) (values (quote eval-when-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (define))) ((lambda (tmp559) ((lambda (tmp560) (if (if tmp560 (apply (lambda (_561 name562 val563) (id?114 name562)) tmp560) #f) (apply (lambda (_564 name565 val566) (values (quote define-form) name565 val566 w542 s543 mod545)) tmp560) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 args570 e1571 e2572) (if (id?114 name569) (valid-bound-ids?139 (lambda-var-list162 args570)) #f)) tmp567) #f) (apply (lambda (_573 name574 args575 e1576 e2577) (values (quote define-form) (wrap142 name574 w542 mod545) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args575 (cons e1576 e2577)) w542 mod545)) (quote (())) s543 mod545)) tmp567) ((lambda (tmp579) (if (if tmp579 (apply (lambda (_580 name581) (id?114 name581)) tmp579) #f) (apply (lambda (_582 name583) (values (quote define-form) (wrap142 name583 w542 mod545) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s543 mod545)) tmp579) (syntax-violation #f "source expression failed to match any pattern" tmp559))) ($sc-dispatch tmp559 (quote (any any)))))) ($sc-dispatch tmp559 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp559 (quote (any any any))))) e540) (if (memv ftype551 (quote (define-syntax))) ((lambda (tmp584) ((lambda (tmp585) (if (if tmp585 (apply (lambda (_586 name587 val588) (id?114 name587)) tmp585) #f) (apply (lambda (_589 name590 val591) (values (quote define-syntax-form) name590 val591 w542 s543 mod545)) tmp585) (syntax-violation #f "source expression failed to match any pattern" tmp584))) ($sc-dispatch tmp584 (quote (any any any))))) e540) (values (quote call) #f e540 w542 s543 mod545)))))))))))))) (if (syntax-object?98 e540) (syntax-type148 (syntax-object-expression99 e540) r541 (join-wraps133 w542 (syntax-object-wrap100 e540)) s543 rib544 (let ((t592 (syntax-object-module101 e540))) (if t592 t592 mod545)) for-car?546) (if (self-evaluating? e540) (values (quote constant) #f e540 w542 s543 mod545) (values (quote other) #f e540 w542 s543 mod545))))))) (chi-when-list147 (lambda (e593 when-list594 w595) (letrec ((f596 (lambda (when-list597 situations598) (if (null? when-list597) situations598 (f596 (cdr when-list597) (cons (let ((x599 (car when-list597))) (if (free-id=?137 x599 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x599 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x599 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e593 (wrap142 x599 w595 #f)))))) situations598)))))) (f596 when-list594 (quote ()))))) (chi-install-global146 (lambda (name600 e601) (build-global-definition89 #f name600 (if (let ((v602 (module-variable (current-module) name600))) (if v602 (if (variable-bound? v602) (if (macro? (variable-ref v602)) (not (eq? (macro-type (variable-ref v602)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name600))) (build-data92 #f (quote macro)) e601)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e601)))))) (chi-top-sequence145 (lambda (body603 r604 w605 s606 m607 esew608 mod609) (build-sequence93 s606 (letrec ((dobody610 (lambda (body611 r612 w613 m614 esew615 mod616) (if (null? body611) (quote ()) (let ((first617 (chi-top149 (car body611) r612 w613 m614 esew615 mod616))) (cons first617 (dobody610 (cdr body611) r612 w613 m614 esew615 mod616))))))) (dobody610 body603 r604 w605 m607 esew608 mod609))))) (chi-sequence144 (lambda (body618 r619 w620 s621 mod622) (build-sequence93 s621 (letrec ((dobody623 (lambda (body624 r625 w626 mod627) (if (null? body624) (quote ()) (let ((first628 (chi150 (car body624) r625 w626 mod627))) (cons first628 (dobody623 (cdr body624) r625 w626 mod627))))))) (dobody623 body618 r619 w620 mod622))))) (source-wrap143 (lambda (x629 w630 s631 defmod632) (begin (if (if s631 (pair? x629) #f) (set-source-properties! x629 s631)) (wrap142 x629 w630 defmod632)))) (wrap142 (lambda (x633 w634 defmod635) (if (if (null? (wrap-marks117 w634)) (null? (wrap-subst118 w634)) #f) x633 (if (syntax-object?98 x633) (make-syntax-object97 (syntax-object-expression99 x633) (join-wraps133 w634 (syntax-object-wrap100 x633)) (syntax-object-module101 x633)) (if (null? x633) x633 (make-syntax-object97 x633 w634 defmod635)))))) (bound-id-member?141 (lambda (x636 list637) (if (not (null? list637)) (let ((t638 (bound-id=?138 x636 (car list637)))) (if t638 t638 (bound-id-member?141 x636 (cdr list637)))) #f))) (distinct-bound-ids?140 (lambda (ids639) (letrec ((distinct?640 (lambda (ids641) (let ((t642 (null? ids641))) (if t642 t642 (if (not (bound-id-member?141 (car ids641) (cdr ids641))) (distinct?640 (cdr ids641)) #f)))))) (distinct?640 ids639)))) (valid-bound-ids?139 (lambda (ids643) (if (letrec ((all-ids?644 (lambda (ids645) (let ((t646 (null? ids645))) (if t646 t646 (if (id?114 (car ids645)) (all-ids?644 (cdr ids645)) #f)))))) (all-ids?644 ids643)) (distinct-bound-ids?140 ids643) #f))) (bound-id=?138 (lambda (i647 j648) (if (if (syntax-object?98 i647) (syntax-object?98 j648) #f) (if (eq? (syntax-object-expression99 i647) (syntax-object-expression99 j648)) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i647)) (wrap-marks117 (syntax-object-wrap100 j648))) #f) (eq? i647 j648)))) (free-id=?137 (lambda (i649 j650) (if (eq? (let ((x651 i649)) (if (syntax-object?98 x651) (syntax-object-expression99 x651) x651)) (let ((x652 j650)) (if (syntax-object?98 x652) (syntax-object-expression99 x652) x652))) (eq? (id-var-name136 i649 (quote (()))) (id-var-name136 j650 (quote (())))) #f))) (id-var-name136 (lambda (id653 w654) (letrec ((search-vector-rib657 (lambda (sym663 subst664 marks665 symnames666 ribcage667) (let ((n668 (vector-length symnames666))) (letrec ((f669 (lambda (i670) (if (fx=74 i670 n668) (search655 sym663 (cdr subst664) marks665) (if (if (eq? (vector-ref symnames666 i670) sym663) (same-marks?135 marks665 (vector-ref (ribcage-marks124 ribcage667) i670)) #f) (values (vector-ref (ribcage-labels125 ribcage667) i670) marks665) (f669 (fx+72 i670 1))))))) (f669 0))))) (search-list-rib656 (lambda (sym671 subst672 marks673 symnames674 ribcage675) (letrec ((f676 (lambda (symnames677 i678) (if (null? symnames677) (search655 sym671 (cdr subst672) marks673) (if (if (eq? (car symnames677) sym671) (same-marks?135 marks673 (list-ref (ribcage-marks124 ribcage675) i678)) #f) (values (list-ref (ribcage-labels125 ribcage675) i678) marks673) (f676 (cdr symnames677) (fx+72 i678 1))))))) (f676 symnames674 0)))) (search655 (lambda (sym679 subst680 marks681) (if (null? subst680) (values #f marks681) (let ((fst682 (car subst680))) (if (eq? fst682 (quote shift)) (search655 sym679 (cdr subst680) (cdr marks681)) (let ((symnames683 (ribcage-symnames123 fst682))) (if (vector? symnames683) (search-vector-rib657 sym679 subst680 marks681 symnames683 fst682) (search-list-rib656 sym679 subst680 marks681 symnames683 fst682))))))))) (if (symbol? id653) (let ((t684 (call-with-values (lambda () (search655 id653 (wrap-subst118 w654) (wrap-marks117 w654))) (lambda (x686 . ignore685) x686)))) (if t684 t684 id653)) (if (syntax-object?98 id653) (let ((id687 (syntax-object-expression99 id653)) (w1688 (syntax-object-wrap100 id653))) (let ((marks689 (join-marks134 (wrap-marks117 w654) (wrap-marks117 w1688)))) (call-with-values (lambda () (search655 id687 (wrap-subst118 w654) marks689)) (lambda (new-id690 marks691) (let ((t692 new-id690)) (if t692 t692 (let ((t693 (call-with-values (lambda () (search655 id687 (wrap-subst118 w1688) marks691)) (lambda (x695 . ignore694) x695)))) (if t693 t693 id687)))))))) (syntax-violation (quote id-var-name) "invalid id" id653)))))) (same-marks?135 (lambda (x696 y697) (let ((t698 (eq? x696 y697))) (if t698 t698 (if (not (null? x696)) (if (not (null? y697)) (if (eq? (car x696) (car y697)) (same-marks?135 (cdr x696) (cdr y697)) #f) #f) #f))))) (join-marks134 (lambda (m1699 m2700) (smart-append132 m1699 m2700))) (join-wraps133 (lambda (w1701 w2702) (let ((m1703 (wrap-marks117 w1701)) (s1704 (wrap-subst118 w1701))) (if (null? m1703) (if (null? s1704) w2702 (make-wrap116 (wrap-marks117 w2702) (smart-append132 s1704 (wrap-subst118 w2702)))) (make-wrap116 (smart-append132 m1703 (wrap-marks117 w2702)) (smart-append132 s1704 (wrap-subst118 w2702))))))) (smart-append132 (lambda (m1705 m2706) (if (null? m2706) m1705 (append m1705 m2706)))) (make-binding-wrap131 (lambda (ids707 labels708 w709) (if (null? ids707) w709 (make-wrap116 (wrap-marks117 w709) (cons (let ((labelvec710 (list->vector labels708))) (let ((n711 (vector-length labelvec710))) (let ((symnamevec712 (make-vector n711)) (marksvec713 (make-vector n711))) (begin (letrec ((f714 (lambda (ids715 i716) (if (not (null? ids715)) (call-with-values (lambda () (id-sym-name&marks115 (car ids715) w709)) (lambda (symname717 marks718) (begin (vector-set! symnamevec712 i716 symname717) (vector-set! marksvec713 i716 marks718) (f714 (cdr ids715) (fx+72 i716 1))))))))) (f714 ids707 0)) (make-ribcage121 symnamevec712 marksvec713 labelvec710))))) (wrap-subst118 w709)))))) (extend-ribcage!130 (lambda (ribcage719 id720 label721) (begin (set-ribcage-symnames!126 ribcage719 (cons (syntax-object-expression99 id720) (ribcage-symnames123 ribcage719))) (set-ribcage-marks!127 ribcage719 (cons (wrap-marks117 (syntax-object-wrap100 id720)) (ribcage-marks124 ribcage719))) (set-ribcage-labels!128 ribcage719 (cons label721 (ribcage-labels125 ribcage719)))))) (anti-mark129 (lambda (w722) (make-wrap116 (cons #f (wrap-marks117 w722)) (cons (quote shift) (wrap-subst118 w722))))) (set-ribcage-labels!128 (lambda (x723 update724) (vector-set! x723 3 update724))) (set-ribcage-marks!127 (lambda (x725 update726) (vector-set! x725 2 update726))) (set-ribcage-symnames!126 (lambda (x727 update728) (vector-set! x727 1 update728))) (ribcage-labels125 (lambda (x729) (vector-ref x729 3))) (ribcage-marks124 (lambda (x730) (vector-ref x730 2))) (ribcage-symnames123 (lambda (x731) (vector-ref x731 1))) (ribcage?122 (lambda (x732) (if (vector? x732) (if (= (vector-length x732) 4) (eq? (vector-ref x732 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames733 marks734 labels735) (vector (quote ribcage) symnames733 marks734 labels735))) (gen-labels120 (lambda (ls736) (if (null? ls736) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls736)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x737 w738) (if (syntax-object?98 x737) (values (syntax-object-expression99 x737) (join-marks134 (wrap-marks117 w738) (wrap-marks117 (syntax-object-wrap100 x737)))) (values x737 (wrap-marks117 w738))))) (id?114 (lambda (x739) (if (symbol? x739) #t (if (syntax-object?98 x739) (symbol? (syntax-object-expression99 x739)) #f)))) (nonsymbol-id?113 (lambda (x740) (if (syntax-object?98 x740) (symbol? (syntax-object-expression99 x740)) #f))) (global-extend112 (lambda (type741 sym742 val743) (put-global-definition-hook78 sym742 type741 val743))) (lookup111 (lambda (x744 r745 mod746) (let ((t747 (assq x744 r745))) (if t747 (cdr t747) (if (symbol? x744) (let ((t748 (get-global-definition-hook79 x744 mod746))) (if t748 t748 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r749) (if (null? r749) (quote ()) (let ((a750 (car r749))) (if (eq? (cadr a750) (quote macro)) (cons a750 (macros-only-env110 (cdr r749))) (macros-only-env110 (cdr r749))))))) (extend-var-env109 (lambda (labels751 vars752 r753) (if (null? labels751) r753 (extend-var-env109 (cdr labels751) (cdr vars752) (cons (cons (car labels751) (cons (quote lexical) (car vars752))) r753))))) (extend-env108 (lambda (labels754 bindings755 r756) (if (null? labels754) r756 (extend-env108 (cdr labels754) (cdr bindings755) (cons (cons (car labels754) (car bindings755)) r756))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x757) (if (syntax-object?98 x757) (source-annotation105 (syntax-object-expression99 x757)) (if (pair? x757) (let ((props758 (source-properties x757))) (if (pair? props758) props758 #f)) #f)))) (set-syntax-object-module!104 (lambda (x759 update760) (vector-set! x759 3 update760))) (set-syntax-object-wrap!103 (lambda (x761 update762) (vector-set! x761 2 update762))) (set-syntax-object-expression!102 (lambda (x763 update764) (vector-set! x763 1 update764))) (syntax-object-module101 (lambda (x765) (vector-ref x765 3))) (syntax-object-wrap100 (lambda (x766) (vector-ref x766 2))) (syntax-object-expression99 (lambda (x767) (vector-ref x767 1))) (syntax-object?98 (lambda (x768) (if (vector? x768) (if (= (vector-length x768) 4) (eq? (vector-ref x768 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression769 wrap770 module771) (vector (quote syntax-object) expression769 wrap770 module771))) (build-letrec96 (lambda (src772 ids773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (let ((atom-key777 (fluid-ref *mode*71))) (if (memv atom-key777 (quote (c))) (begin (for-each maybe-name-value!88 ids773 val-exps775) ((@ (language tree-il) make-letrec) src772 ids773 vars774 val-exps775 body-exp776)) (list (quote letrec) (map list vars774 val-exps775) body-exp776)))))) (build-named-let95 (lambda (src778 ids779 vars780 val-exps781 body-exp782) (let ((f783 (car vars780)) (f-name784 (car ids779)) (vars785 (cdr vars780)) (ids786 (cdr ids779))) (let ((atom-key787 (fluid-ref *mode*71))) (if (memv atom-key787 (quote (c))) (let ((proc788 (build-lambda90 src778 ids786 vars785 #f body-exp782))) (begin (maybe-name-value!88 f-name784 proc788) (for-each maybe-name-value!88 ids786 val-exps781) ((@ (language tree-il) make-letrec) src778 (list f-name784) (list f783) (list proc788) (build-application81 src778 (build-lexical-reference83 (quote fun) src778 f-name784 f783) val-exps781)))) (list (quote let) f783 (map list vars785 val-exps781) body-exp782)))))) (build-let94 (lambda (src789 ids790 vars791 val-exps792 body-exp793) (if (null? vars791) body-exp793 (let ((atom-key794 (fluid-ref *mode*71))) (if (memv atom-key794 (quote (c))) (begin (for-each maybe-name-value!88 ids790 val-exps792) ((@ (language tree-il) make-let) src789 ids790 vars791 val-exps792 body-exp793)) (list (quote let) (map list vars791 val-exps792) body-exp793)))))) (build-sequence93 (lambda (src795 exps796) (if (null? (cdr exps796)) (car exps796) (let ((atom-key797 (fluid-ref *mode*71))) (if (memv atom-key797 (quote (c))) ((@ (language tree-il) make-sequence) src795 exps796) (cons (quote begin) exps796)))))) (build-data92 (lambda (src798 exp799) (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-const) src798 exp799) (if (if (self-evaluating? exp799) (not (vector? exp799)) #f) exp799 (list (quote quote) exp799)))))) (build-primref91 (lambda (src801 name802) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key803 (fluid-ref *mode*71))) (if (memv atom-key803 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src801 name802) name802)) (let ((atom-key804 (fluid-ref *mode*71))) (if (memv atom-key804 (quote (c))) ((@ (language tree-il) make-module-ref) src801 (quote (guile)) name802 #f) (list (quote @@) (quote (guile)) name802)))))) (build-lambda90 (lambda (src805 ids806 vars807 docstring808 exp809) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-lambda) src805 ids806 vars807 (if docstring808 (list (cons (quote documentation) docstring808)) (quote ())) exp809) (cons (quote lambda) (cons vars807 (append (if docstring808 (list docstring808) (quote ())) (list exp809)))))))) (build-global-definition89 (lambda (source811 var812 exp813) (let ((atom-key814 (fluid-ref *mode*71))) (if (memv atom-key814 (quote (c))) (begin (maybe-name-value!88 var812 exp813) ((@ (language tree-il) make-toplevel-define) source811 var812 exp813)) (list (quote define) var812 exp813))))) (maybe-name-value!88 (lambda (name815 val816) (if ((@ (language tree-il) lambda?) val816) (let ((meta817 ((@ (language tree-il) lambda-meta) val816))) (if (not (assq (quote name) meta817)) ((setter (@ (language tree-il) lambda-meta)) val816 (acons (quote name) name815 meta817))))))) (build-global-assignment87 (lambda (source818 var819 exp820 mod821) (analyze-variable85 mod821 var819 (lambda (mod822 var823 public?824) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-module-set) source818 mod822 var823 public?824 exp820) (list (quote set!) (list (if public?824 (quote @) (quote @@)) mod822 var823) exp820)))) (lambda (var826) (let ((atom-key827 (fluid-ref *mode*71))) (if (memv atom-key827 (quote (c))) ((@ (language tree-il) make-toplevel-set) source818 var826 exp820) (list (quote set!) var826 exp820))))))) (build-global-reference86 (lambda (source828 var829 mod830) (analyze-variable85 mod830 var829 (lambda (mod831 var832 public?833) (let ((atom-key834 (fluid-ref *mode*71))) (if (memv atom-key834 (quote (c))) ((@ (language tree-il) make-module-ref) source828 mod831 var832 public?833) (list (if public?833 (quote @) (quote @@)) mod831 var832)))) (lambda (var835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source828 var835) var835)))))) (analyze-variable85 (lambda (mod837 var838 modref-cont839 bare-cont840) (if (not mod837) (bare-cont840 var838) (let ((kind841 (car mod837)) (mod842 (cdr mod837))) (if (memv kind841 (quote (public))) (modref-cont839 mod842 var838 #t) (if (memv kind841 (quote (private))) (if (not (equal? mod842 (module-name (current-module)))) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (if (memv kind841 (quote (bare))) (bare-cont840 var838) (if (memv kind841 (quote (hygiene))) (if (if (not (equal? mod842 (module-name (current-module)))) (module-variable (resolve-module mod842) var838) #f) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (syntax-violation #f "bad module kind" var838 mod842))))))))) (build-lexical-assignment84 (lambda (source843 name844 var845 exp846) (let ((atom-key847 (fluid-ref *mode*71))) (if (memv atom-key847 (quote (c))) ((@ (language tree-il) make-lexical-set) source843 name844 var845 exp846) (list (quote set!) var845 exp846))))) (build-lexical-reference83 (lambda (type848 source849 name850 var851) (let ((atom-key852 (fluid-ref *mode*71))) (if (memv atom-key852 (quote (c))) ((@ (language tree-il) make-lexical-ref) source849 name850 var851) var851)))) (build-conditional82 (lambda (source853 test-exp854 then-exp855 else-exp856) (let ((atom-key857 (fluid-ref *mode*71))) (if (memv atom-key857 (quote (c))) ((@ (language tree-il) make-conditional) source853 test-exp854 then-exp855 else-exp856) (if (equal? else-exp856 (quote (if #f #f))) (list (quote if) test-exp854 then-exp855) (list (quote if) test-exp854 then-exp855 else-exp856)))))) (build-application81 (lambda (source858 fun-exp859 arg-exps860) (let ((atom-key861 (fluid-ref *mode*71))) (if (memv atom-key861 (quote (c))) ((@ (language tree-il) make-application) source858 fun-exp859 arg-exps860) (cons fun-exp859 arg-exps860))))) (build-void80 (lambda (source862) (let ((atom-key863 (fluid-ref *mode*71))) (if (memv atom-key863 (quote (c))) ((@ (language tree-il) make-void) source862) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol864 module865) (begin (if (if (not module865) (current-module) #f) (warn "module system is booted, we should have a module" symbol864)) (let ((v866 (module-variable (if module865 (resolve-module (cdr module865)) (current-module)) symbol864))) (if v866 (if (variable-bound? v866) (let ((val867 (variable-ref v866))) (if (macro? val867) (if (syncase-macro-type val867) (cons (syncase-macro-type val867) (syncase-macro-binding val867)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol868 type869 val870) (let ((existing871 (let ((v872 (module-variable (current-module) symbol868))) (if v872 (if (variable-bound? v872) (let ((val873 (variable-ref v872))) (if (macro? val873) (if (not (syncase-macro-type val873)) val873 #f) #f)) #f) #f)))) (module-define! (current-module) symbol868 (if existing871 (make-extended-syncase-macro existing871 type869 val870) (make-syncase-macro type869 val870)))))) (local-eval-hook77 (lambda (x874 mod875) (primitive-eval (list noexpand70 (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) tree-il->scheme) x874) x874)))))) (top-level-eval-hook76 (lambda (x877 mod878) (primitive-eval (list noexpand70 (let ((atom-key879 (fluid-ref *mode*71))) (if (memv atom-key879 (quote (c))) ((@ (language tree-il) tree-il->scheme) x877) x877)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e880 r881 w882 s883 mod884) ((lambda (tmp885) ((lambda (tmp886) (if (if tmp886 (apply (lambda (_887 var888 val889 e1890 e2891) (valid-bound-ids?139 var888)) tmp886) #f) (apply (lambda (_893 var894 val895 e1896 e2897) (let ((names898 (map (lambda (x899) (id-var-name136 x899 w882)) var894))) (begin (for-each (lambda (id901 n902) (let ((atom-key903 (binding-type106 (lookup111 n902 r881 mod884)))) (if (memv atom-key903 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e880 (source-wrap143 id901 w882 s883 mod884))))) var894 names898) (chi-body154 (cons e1896 e2897) (source-wrap143 e880 w882 s883 mod884) (extend-env108 names898 (let ((trans-r906 (macros-only-env110 r881))) (map (lambda (x907) (cons (quote macro) (eval-local-transformer157 (chi150 x907 trans-r906 w882 mod884) mod884))) val895)) r881) w882 mod884)))) tmp886) ((lambda (_909) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e880 w882 s883 mod884))) tmp885))) ($sc-dispatch tmp885 (quote (any #(each (any any)) any . each-any))))) e880))) (global-extend112 (quote core) (quote quote) (lambda (e910 r911 w912 s913 mod914) ((lambda (tmp915) ((lambda (tmp916) (if tmp916 (apply (lambda (_917 e918) (build-data92 s913 (strip160 e918 w912))) tmp916) ((lambda (_919) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e910 w912 s913 mod914))) tmp915))) ($sc-dispatch tmp915 (quote (any any))))) e910))) (global-extend112 (quote core) (quote syntax) (letrec ((regen927 (lambda (x928) (let ((atom-key929 (car x928))) (if (memv atom-key929 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x928) (cadr x928)) (if (memv atom-key929 (quote (primitive))) (build-primref91 #f (cadr x928)) (if (memv atom-key929 (quote (quote))) (build-data92 #f (cadr x928)) (if (memv atom-key929 (quote (lambda))) (build-lambda90 #f (cadr x928) (cadr x928) #f (regen927 (caddr x928))) (build-application81 #f (build-primref91 #f (car x928)) (map regen927 (cdr x928)))))))))) (gen-vector926 (lambda (x930) (if (eq? (car x930) (quote list)) (cons (quote vector) (cdr x930)) (if (eq? (car x930) (quote quote)) (list (quote quote) (list->vector (cadr x930))) (list (quote list->vector) x930))))) (gen-append925 (lambda (x931 y932) (if (equal? y932 (quote (quote ()))) x931 (list (quote append) x931 y932)))) (gen-cons924 (lambda (x933 y934) (let ((atom-key935 (car y934))) (if (memv atom-key935 (quote (quote))) (if (eq? (car x933) (quote quote)) (list (quote quote) (cons (cadr x933) (cadr y934))) (if (eq? (cadr y934) (quote ())) (list (quote list) x933) (list (quote cons) x933 y934))) (if (memv atom-key935 (quote (list))) (cons (quote list) (cons x933 (cdr y934))) (list (quote cons) x933 y934)))))) (gen-map923 (lambda (e936 map-env937) (let ((formals938 (map cdr map-env937)) (actuals939 (map (lambda (x940) (list (quote ref) (car x940))) map-env937))) (if (eq? (car e936) (quote ref)) (car actuals939) (if (and-map (lambda (x941) (if (eq? (car x941) (quote ref)) (memq (cadr x941) formals938) #f)) (cdr e936)) (cons (quote map) (cons (list (quote primitive) (car e936)) (map (let ((r942 (map cons formals938 actuals939))) (lambda (x943) (cdr (assq (cadr x943) r942)))) (cdr e936)))) (cons (quote map) (cons (list (quote lambda) formals938 e936) actuals939))))))) (gen-mappend922 (lambda (e944 map-env945) (list (quote apply) (quote (primitive append)) (gen-map923 e944 map-env945)))) (gen-ref921 (lambda (src946 var947 level948 maps949) (if (fx=74 level948 0) (values var947 maps949) (if (null? maps949) (syntax-violation (quote syntax) "missing ellipsis" src946) (call-with-values (lambda () (gen-ref921 src946 var947 (fx-73 level948 1) (cdr maps949))) (lambda (outer-var950 outer-maps951) (let ((b952 (assq outer-var950 (car maps949)))) (if b952 (values (cdr b952) maps949) (let ((inner-var953 (gen-var161 (quote tmp)))) (values inner-var953 (cons (cons (cons outer-var950 inner-var953) (car maps949)) outer-maps951))))))))))) (gen-syntax920 (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) (if (id?114 e955) (let ((label960 (id-var-name136 e955 (quote (()))))) (let ((b961 (lookup111 label960 r956 mod959))) (if (eq? (binding-type106 b961) (quote syntax)) (call-with-values (lambda () (let ((var.lev962 (binding-value107 b961))) (gen-ref921 src954 (car var.lev962) (cdr var.lev962) maps957))) (lambda (var963 maps964) (values (list (quote ref) var963) maps964))) (if (ellipsis?958 e955) (syntax-violation (quote syntax) "misplaced ellipsis" src954) (values (list (quote quote) e955) maps957))))) ((lambda (tmp965) ((lambda (tmp966) (if (if tmp966 (apply (lambda (dots967 e968) (ellipsis?958 dots967)) tmp966) #f) (apply (lambda (dots969 e970) (gen-syntax920 src954 e970 r956 maps957 (lambda (x971) #f) mod959)) tmp966) ((lambda (tmp972) (if (if tmp972 (apply (lambda (x973 dots974 y975) (ellipsis?958 dots974)) tmp972) #f) (apply (lambda (x976 dots977 y978) (letrec ((f979 (lambda (y980 k981) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 y988) (ellipsis?958 dots987)) tmp986) #f) (apply (lambda (dots989 y990) (f979 y990 (lambda (maps991) (call-with-values (lambda () (k981 (cons (quote ()) maps991))) (lambda (x992 maps993) (if (null? (car maps993)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-mappend922 x992 (car maps993)) (cdr maps993)))))))) tmp986) ((lambda (_994) (call-with-values (lambda () (gen-syntax920 src954 y980 r956 maps957 ellipsis?958 mod959)) (lambda (y995 maps996) (call-with-values (lambda () (k981 maps996)) (lambda (x997 maps998) (values (gen-append925 x997 y995) maps998)))))) tmp985))) ($sc-dispatch tmp985 (quote (any . any))))) y980)))) (f979 y978 (lambda (maps982) (call-with-values (lambda () (gen-syntax920 src954 x976 r956 (cons (quote ()) maps982) ellipsis?958 mod959)) (lambda (x983 maps984) (if (null? (car maps984)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-map923 x983 (car maps984)) (cdr maps984))))))))) tmp972) ((lambda (tmp999) (if tmp999 (apply (lambda (x1000 y1001) (call-with-values (lambda () (gen-syntax920 src954 x1000 r956 maps957 ellipsis?958 mod959)) (lambda (x1002 maps1003) (call-with-values (lambda () (gen-syntax920 src954 y1001 r956 maps1003 ellipsis?958 mod959)) (lambda (y1004 maps1005) (values (gen-cons924 x1002 y1004) maps1005)))))) tmp999) ((lambda (tmp1006) (if tmp1006 (apply (lambda (e11007 e21008) (call-with-values (lambda () (gen-syntax920 src954 (cons e11007 e21008) r956 maps957 ellipsis?958 mod959)) (lambda (e1010 maps1011) (values (gen-vector926 e1010) maps1011)))) tmp1006) ((lambda (_1012) (values (list (quote quote) e955) maps957)) tmp965))) ($sc-dispatch tmp965 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp965 (quote (any . any)))))) ($sc-dispatch tmp965 (quote (any any . any)))))) ($sc-dispatch tmp965 (quote (any any))))) e955))))) (lambda (e1013 r1014 w1015 s1016 mod1017) (let ((e1018 (source-wrap143 e1013 w1015 s1016 mod1017))) ((lambda (tmp1019) ((lambda (tmp1020) (if tmp1020 (apply (lambda (_1021 x1022) (call-with-values (lambda () (gen-syntax920 e1018 x1022 r1014 (quote ()) ellipsis?159 mod1017)) (lambda (e1023 maps1024) (regen927 e1023)))) tmp1020) ((lambda (_1025) (syntax-violation (quote syntax) "bad `syntax' form" e1018)) tmp1019))) ($sc-dispatch tmp1019 (quote (any any))))) e1018))))) (global-extend112 (quote core) (quote lambda) (lambda (e1026 r1027 w1028 s1029 mod1030) ((lambda (tmp1031) ((lambda (tmp1032) (if tmp1032 (apply (lambda (_1033 c1034) (chi-lambda-clause155 (source-wrap143 e1026 w1028 s1029 mod1030) #f c1034 r1027 w1028 mod1030 (lambda (names1035 vars1036 docstring1037 body1038) (build-lambda90 s1029 names1035 vars1036 docstring1037 body1038)))) tmp1032) (syntax-violation #f "source expression failed to match any pattern" tmp1031))) ($sc-dispatch tmp1031 (quote (any . any))))) e1026))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1039 (lambda (e1040 r1041 w1042 s1043 mod1044 constructor1045 ids1046 vals1047 exps1048) (if (not (valid-bound-ids?139 ids1046)) (syntax-violation (quote let) "duplicate bound variable" e1040) (let ((labels1049 (gen-labels120 ids1046)) (new-vars1050 (map gen-var161 ids1046))) (let ((nw1051 (make-binding-wrap131 ids1046 labels1049 w1042)) (nr1052 (extend-var-env109 labels1049 new-vars1050 r1041))) (constructor1045 s1043 (map syntax->datum ids1046) new-vars1050 (map (lambda (x1053) (chi150 x1053 r1041 w1042 mod1044)) vals1047) (chi-body154 exps1048 (source-wrap143 e1040 nw1051 s1043 mod1044) nr1052 nw1051 mod1044)))))))) (lambda (e1054 r1055 w1056 s1057 mod1058) ((lambda (tmp1059) ((lambda (tmp1060) (if (if tmp1060 (apply (lambda (_1061 id1062 val1063 e11064 e21065) (and-map id?114 id1062)) tmp1060) #f) (apply (lambda (_1067 id1068 val1069 e11070 e21071) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-let94 id1068 val1069 (cons e11070 e21071))) tmp1060) ((lambda (tmp1075) (if (if tmp1075 (apply (lambda (_1076 f1077 id1078 val1079 e11080 e21081) (if (id?114 f1077) (and-map id?114 id1078) #f)) tmp1075) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-named-let95 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1075) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap143 e1054 w1056 s1057 mod1058))) tmp1059))) ($sc-dispatch tmp1059 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1059 (quote (any #(each (any any)) any . each-any))))) e1054)))) (global-extend112 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (and-map id?114 id1101)) tmp1099) #f) (apply (lambda (_1106 id1107 val1108 e11109 e21110) (let ((ids1111 id1107)) (if (not (valid-bound-ids?139 ids1111)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1113 (gen-labels120 ids1111)) (new-vars1114 (map gen-var161 ids1111))) (let ((w1115 (make-binding-wrap131 ids1111 labels1113 w1095)) (r1116 (extend-var-env109 labels1113 new-vars1114 r1094))) (build-letrec96 s1096 (map syntax->datum ids1111) new-vars1114 (map (lambda (x1117) (chi150 x1117 r1116 w1115 mod1097)) val1108) (chi-body154 (cons e11109 e21110) (source-wrap143 e1093 w1115 s1096 mod1097) r1116 w1115 mod1097))))))) tmp1099) ((lambda (_1120) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend112 (quote core) (quote set!) (lambda (e1121 r1122 w1123 s1124 mod1125) ((lambda (tmp1126) ((lambda (tmp1127) (if (if tmp1127 (apply (lambda (_1128 id1129 val1130) (id?114 id1129)) tmp1127) #f) (apply (lambda (_1131 id1132 val1133) (let ((val1134 (chi150 val1133 r1122 w1123 mod1125)) (n1135 (id-var-name136 id1132 w1123))) (let ((b1136 (lookup111 n1135 r1122 mod1125))) (let ((atom-key1137 (binding-type106 b1136))) (if (memv atom-key1137 (quote (lexical))) (build-lexical-assignment84 s1124 (syntax->datum id1132) (binding-value107 b1136) val1134) (if (memv atom-key1137 (quote (global))) (build-global-assignment87 s1124 n1135 val1134 mod1125) (if (memv atom-key1137 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1132 w1123 mod1125)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))))))))) tmp1127) ((lambda (tmp1138) (if tmp1138 (apply (lambda (_1139 head1140 tail1141 val1142) (call-with-values (lambda () (syntax-type148 head1140 r1122 (quote (())) #f #f mod1125 #t)) (lambda (type1143 value1144 ee1145 ww1146 ss1147 modmod1148) (if (memv type1143 (quote (module-ref))) (let ((val1149 (chi150 val1142 r1122 w1123 mod1125))) (call-with-values (lambda () (value1144 (cons head1140 tail1141))) (lambda (id1151 mod1152) (build-global-assignment87 s1124 id1151 val1149 mod1152)))) (build-application81 s1124 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1140) r1122 w1123 mod1125) (map (lambda (e1153) (chi150 e1153 r1122 w1123 mod1125)) (append tail1141 (list val1142)))))))) tmp1138) ((lambda (_1155) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))) tmp1126))) ($sc-dispatch tmp1126 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1126 (quote (any any any))))) e1121))) (global-extend112 (quote module-ref) (quote @) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (if (and-map id?114 mod1160) (id?114 id1161) #f)) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1167) ((lambda (tmp1168) ((lambda (tmp1169) (if (if tmp1169 (apply (lambda (_1170 mod1171 id1172) (if (and-map id?114 mod1171) (id?114 id1172) #f)) tmp1169) #f) (apply (lambda (_1174 mod1175 id1176) (values (syntax->datum id1176) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1175)))) tmp1169) (syntax-violation #f "source expression failed to match any pattern" tmp1168))) ($sc-dispatch tmp1168 (quote (any each-any any))))) e1167))) (global-extend112 (quote core) (quote if) (lambda (e1178 r1179 w1180 s1181 mod1182) ((lambda (tmp1183) ((lambda (tmp1184) (if tmp1184 (apply (lambda (_1185 test1186 then1187) (build-conditional82 s1181 (chi150 test1186 r1179 w1180 mod1182) (chi150 then1187 r1179 w1180 mod1182) (build-void80 #f))) tmp1184) ((lambda (tmp1188) (if tmp1188 (apply (lambda (_1189 test1190 then1191 else1192) (build-conditional82 s1181 (chi150 test1190 r1179 w1180 mod1182) (chi150 then1191 r1179 w1180 mod1182) (chi150 else1192 r1179 w1180 mod1182))) tmp1188) (syntax-violation #f "source expression failed to match any pattern" tmp1183))) ($sc-dispatch tmp1183 (quote (any any any any)))))) ($sc-dispatch tmp1183 (quote (any any any))))) e1178))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1196 (lambda (x1197 keys1198 clauses1199 r1200 mod1201) (if (null? clauses1199) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1197)) ((lambda (tmp1202) ((lambda (tmp1203) (if tmp1203 (apply (lambda (pat1204 exp1205) (if (if (id?114 pat1204) (and-map (lambda (x1206) (not (free-id=?137 pat1204 x1206))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1198)) #f) (let ((labels1207 (list (gen-label119))) (var1208 (gen-var161 pat1204))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1204)) (list var1208) #f (chi150 exp1205 (extend-env108 labels1207 (list (cons (quote syntax) (cons var1208 0))) r1200) (make-binding-wrap131 (list pat1204) labels1207 (quote (()))) mod1201)) (list x1197))) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1204 #t exp1205 mod1201))) tmp1203) ((lambda (tmp1209) (if tmp1209 (apply (lambda (pat1210 fender1211 exp1212) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1210 fender1211 exp1212 mod1201)) tmp1209) ((lambda (_1213) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1199))) tmp1202))) ($sc-dispatch tmp1202 (quote (any any any)))))) ($sc-dispatch tmp1202 (quote (any any))))) (car clauses1199))))) (gen-clause1195 (lambda (x1214 keys1215 clauses1216 r1217 pat1218 fender1219 exp1220 mod1221) (call-with-values (lambda () (convert-pattern1193 pat1218 keys1215)) (lambda (p1222 pvars1223) (if (not (distinct-bound-ids?140 (map car pvars1223))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1218) (if (not (and-map (lambda (x1224) (not (ellipsis?159 (car x1224)))) pvars1223)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1218) (let ((y1225 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1225) #f (let ((y1226 (build-lexical-reference83 (quote value) #f (quote tmp) y1225))) (build-conditional82 #f ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda () y1226) tmp1228) ((lambda (_1229) (build-conditional82 #f y1226 (build-dispatch-call1194 pvars1223 fender1219 y1226 r1217 mod1221) (build-data92 #f #f))) tmp1227))) ($sc-dispatch tmp1227 (quote #(atom #t))))) fender1219) (build-dispatch-call1194 pvars1223 exp1220 y1226 r1217 mod1221) (gen-syntax-case1196 x1214 keys1215 clauses1216 r1217 mod1221)))) (list (if (eq? p1222 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1214)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1214 (build-data92 #f p1222))))))))))))) (build-dispatch-call1194 (lambda (pvars1230 exp1231 y1232 r1233 mod1234) (let ((ids1235 (map car pvars1230)) (levels1236 (map cdr pvars1230))) (let ((labels1237 (gen-labels120 ids1235)) (new-vars1238 (map gen-var161 ids1235))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1235) new-vars1238 #f (chi150 exp1231 (extend-env108 labels1237 (map (lambda (var1239 level1240) (cons (quote syntax) (cons var1239 level1240))) new-vars1238 (map cdr pvars1230)) r1233) (make-binding-wrap131 ids1235 labels1237 (quote (()))) mod1234)) y1232)))))) (convert-pattern1193 (lambda (pattern1241 keys1242) (letrec ((cvt1243 (lambda (p1244 n1245 ids1246) (if (id?114 p1244) (if (bound-id-member?141 p1244 keys1242) (values (vector (quote free-id) p1244) ids1246) (values (quote any) (cons (cons p1244 n1245) ids1246))) ((lambda (tmp1247) ((lambda (tmp1248) (if (if tmp1248 (apply (lambda (x1249 dots1250) (ellipsis?159 dots1250)) tmp1248) #f) (apply (lambda (x1251 dots1252) (call-with-values (lambda () (cvt1243 x1251 (fx+72 n1245 1) ids1246)) (lambda (p1253 ids1254) (values (if (eq? p1253 (quote any)) (quote each-any) (vector (quote each) p1253)) ids1254)))) tmp1248) ((lambda (tmp1255) (if tmp1255 (apply (lambda (x1256 y1257) (call-with-values (lambda () (cvt1243 y1257 n1245 ids1246)) (lambda (y1258 ids1259) (call-with-values (lambda () (cvt1243 x1256 n1245 ids1259)) (lambda (x1260 ids1261) (values (cons x1260 y1258) ids1261)))))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda () (values (quote ()) ids1246)) tmp1262) ((lambda (tmp1263) (if tmp1263 (apply (lambda (x1264) (call-with-values (lambda () (cvt1243 x1264 n1245 ids1246)) (lambda (p1266 ids1267) (values (vector (quote vector) p1266) ids1267)))) tmp1263) ((lambda (x1268) (values (vector (quote atom) (strip160 p1244 (quote (())))) ids1246)) tmp1247))) ($sc-dispatch tmp1247 (quote #(vector each-any)))))) ($sc-dispatch tmp1247 (quote ()))))) ($sc-dispatch tmp1247 (quote (any . any)))))) ($sc-dispatch tmp1247 (quote (any any))))) p1244))))) (cvt1243 pattern1241 0 (quote ())))))) (lambda (e1269 r1270 w1271 s1272 mod1273) (let ((e1274 (source-wrap143 e1269 w1271 s1272 mod1273))) ((lambda (tmp1275) ((lambda (tmp1276) (if tmp1276 (apply (lambda (_1277 val1278 key1279 m1280) (if (and-map (lambda (x1281) (if (id?114 x1281) (not (ellipsis?159 x1281)) #f)) key1279) (let ((x1283 (gen-var161 (quote tmp)))) (build-application81 s1272 (build-lambda90 #f (list (quote tmp)) (list x1283) #f (gen-syntax-case1196 (build-lexical-reference83 (quote value) #f (quote tmp) x1283) key1279 m1280 r1270 mod1273)) (list (chi150 val1278 r1270 (quote (())) mod1273)))) (syntax-violation (quote syntax-case) "invalid literals list" e1274))) tmp1276) (syntax-violation #f "source expression failed to match any pattern" tmp1275))) ($sc-dispatch tmp1275 (quote (any any each-any . each-any))))) e1274))))) (set! sc-expand (lambda (x1287 . rest1286) (if (if (pair? x1287) (equal? (car x1287) noexpand70) #f) (cadr x1287) (let ((m1288 (if (null? rest1286) (quote e) (car rest1286))) (esew1289 (if (let ((t1290 (null? rest1286))) (if t1290 t1290 (null? (cdr rest1286)))) (quote (eval)) (cadr rest1286)))) (with-fluid* *mode*71 m1288 (lambda () (chi-top149 x1287 (quote ()) (quote ((top))) m1288 esew1289 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1291) (nonsymbol-id?113 x1291))) (set! datum->syntax (lambda (id1292 datum1293) (make-syntax-object97 datum1293 (syntax-object-wrap100 id1292) #f))) (set! syntax->datum (lambda (x1294) (strip160 x1294 (quote (()))))) (set! generate-temporaries (lambda (ls1295) (begin (let ((x1296 ls1295)) (if (not (list? x1296)) (syntax-violation (quote generate-temporaries) "invalid argument" x1296))) (map (lambda (x1297) (wrap142 (gensym) (quote ((top))) #f)) ls1295)))) (set! free-identifier=? (lambda (x1298 y1299) (begin (let ((x1300 x1298)) (if (not (nonsymbol-id?113 x1300)) (syntax-violation (quote free-identifier=?) "invalid argument" x1300))) (let ((x1301 y1299)) (if (not (nonsymbol-id?113 x1301)) (syntax-violation (quote free-identifier=?) "invalid argument" x1301))) (free-id=?137 x1298 y1299)))) (set! bound-identifier=? (lambda (x1302 y1303) (begin (let ((x1304 x1302)) (if (not (nonsymbol-id?113 x1304)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1304))) (let ((x1305 y1303)) (if (not (nonsymbol-id?113 x1305)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1305))) (bound-id=?138 x1302 y1303)))) (set! syntax-violation (lambda (who1309 message1308 form1307 . subform1306) (begin (let ((x1310 who1309)) (if (not ((lambda (x1311) (let ((t1312 (not x1311))) (if t1312 t1312 (let ((t1313 (string? x1311))) (if t1313 t1313 (symbol? x1311)))))) x1310)) (syntax-violation (quote syntax-violation) "invalid argument" x1310))) (let ((x1314 message1308)) (if (not (string? x1314)) (syntax-violation (quote syntax-violation) "invalid argument" x1314))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1309 "~a: " "") "~a " (if (null? subform1306) "in ~a" "in subform `~s' of `~s'")) (let ((tail1315 (cons message1308 (map (lambda (x1316) (strip160 x1316 (quote (())))) (append subform1306 (list form1307)))))) (if who1309 (cons who1309 tail1315) tail1315)) #f)))) (letrec ((match1321 (lambda (e1322 p1323 w1324 r1325 mod1326) (if (not r1325) #f (if (eq? p1323 (quote any)) (cons (wrap142 e1322 w1324 mod1326) r1325) (if (syntax-object?98 e1322) (match*1320 (syntax-object-expression99 e1322) p1323 (join-wraps133 w1324 (syntax-object-wrap100 e1322)) r1325 (syntax-object-module101 e1322)) (match*1320 e1322 p1323 w1324 r1325 mod1326)))))) (match*1320 (lambda (e1327 p1328 w1329 r1330 mod1331) (if (null? p1328) (if (null? e1327) r1330 #f) (if (pair? p1328) (if (pair? e1327) (match1321 (car e1327) (car p1328) w1329 (match1321 (cdr e1327) (cdr p1328) w1329 r1330 mod1331) mod1331) #f) (if (eq? p1328 (quote each-any)) (let ((l1332 (match-each-any1318 e1327 w1329 mod1331))) (if l1332 (cons l1332 r1330) #f)) (let ((atom-key1333 (vector-ref p1328 0))) (if (memv atom-key1333 (quote (each))) (if (null? e1327) (match-empty1319 (vector-ref p1328 1) r1330) (let ((l1334 (match-each1317 e1327 (vector-ref p1328 1) w1329 mod1331))) (if l1334 (letrec ((collect1335 (lambda (l1336) (if (null? (car l1336)) r1330 (cons (map car l1336) (collect1335 (map cdr l1336))))))) (collect1335 l1334)) #f))) (if (memv atom-key1333 (quote (free-id))) (if (id?114 e1327) (if (free-id=?137 (wrap142 e1327 w1329 mod1331) (vector-ref p1328 1)) r1330 #f) #f) (if (memv atom-key1333 (quote (atom))) (if (equal? (vector-ref p1328 1) (strip160 e1327 w1329)) r1330 #f) (if (memv atom-key1333 (quote (vector))) (if (vector? e1327) (match1321 (vector->list e1327) (vector-ref p1328 1) w1329 r1330 mod1331) #f))))))))))) (match-empty1319 (lambda (p1337 r1338) (if (null? p1337) r1338 (if (eq? p1337 (quote any)) (cons (quote ()) r1338) (if (pair? p1337) (match-empty1319 (car p1337) (match-empty1319 (cdr p1337) r1338)) (if (eq? p1337 (quote each-any)) (cons (quote ()) r1338) (let ((atom-key1339 (vector-ref p1337 0))) (if (memv atom-key1339 (quote (each))) (match-empty1319 (vector-ref p1337 1) r1338) (if (memv atom-key1339 (quote (free-id atom))) r1338 (if (memv atom-key1339 (quote (vector))) (match-empty1319 (vector-ref p1337 1) r1338))))))))))) (match-each-any1318 (lambda (e1340 w1341 mod1342) (if (pair? e1340) (let ((l1343 (match-each-any1318 (cdr e1340) w1341 mod1342))) (if l1343 (cons (wrap142 (car e1340) w1341 mod1342) l1343) #f)) (if (null? e1340) (quote ()) (if (syntax-object?98 e1340) (match-each-any1318 (syntax-object-expression99 e1340) (join-wraps133 w1341 (syntax-object-wrap100 e1340)) mod1342) #f))))) (match-each1317 (lambda (e1344 p1345 w1346 mod1347) (if (pair? e1344) (let ((first1348 (match1321 (car e1344) p1345 w1346 (quote ()) mod1347))) (if first1348 (let ((rest1349 (match-each1317 (cdr e1344) p1345 w1346 mod1347))) (if rest1349 (cons first1348 rest1349) #f)) #f)) (if (null? e1344) (quote ()) (if (syntax-object?98 e1344) (match-each1317 (syntax-object-expression99 e1344) p1345 (join-wraps133 w1346 (syntax-object-wrap100 e1344)) (syntax-object-module101 e1344)) #f)))))) (set! $sc-dispatch (lambda (e1350 p1351) (if (eq? p1351 (quote any)) (list e1350) (if (syntax-object?98 e1350) (match*1320 (syntax-object-expression99 e1350) p1351 (syntax-object-wrap100 e1350) (quote ()) (syntax-object-module101 e1350)) (match*1320 e1350 p1351 (quote (())) (quote ()) #f))))))))) +(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars286) (letrec ((lvl287 (lambda (vars288 ls289 w290) (if (pair? vars288) (lvl287 (cdr vars288) (cons (wrap142 (car vars288) w290 #f) ls289) w290) (if (id?114 vars288) (cons (wrap142 vars288 w290 #f) ls289) (if (null? vars288) ls289 (if (syntax-object?98 vars288) (lvl287 (syntax-object-expression99 vars288) ls289 (join-wraps133 w290 (syntax-object-wrap100 vars288))) (cons vars288 ls289)))))))) (lvl287 vars286 (quote ()) (quote (())))))) (gen-var161 (lambda (id291) (let ((id292 (if (syntax-object?98 id291) (syntax-object-expression99 id291) id291))) (gensym (symbol->string id292))))) (strip160 (lambda (x293 w294) (if (memq (quote top) (wrap-marks117 w294)) x293 (letrec ((f295 (lambda (x296) (if (syntax-object?98 x296) (strip160 (syntax-object-expression99 x296) (syntax-object-wrap100 x296)) (if (pair? x296) (let ((a297 (f295 (car x296))) (d298 (f295 (cdr x296)))) (if (if (eq? a297 (car x296)) (eq? d298 (cdr x296)) #f) x296 (cons a297 d298))) (if (vector? x296) (let ((old299 (vector->list x296))) (let ((new300 (map f295 old299))) (if (and-map*17 eq? old299 new300) x296 (list->vector new300)))) x296)))))) (f295 x293))))) (ellipsis?159 (lambda (x301) (if (nonsymbol-id?113 x301) (free-id=?137 x301 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded302 mod303) (let ((p304 (local-eval-hook77 expanded302 mod303))) (if (procedure? p304) p304 (syntax-violation #f "nonprocedure transformer" p304))))) (chi-local-syntax156 (lambda (rec?305 e306 r307 w308 s309 mod310 k311) ((lambda (tmp312) ((lambda (tmp313) (if tmp313 (apply (lambda (_314 id315 val316 e1317 e2318) (let ((ids319 id315)) (if (not (valid-bound-ids?139 ids319)) (syntax-violation #f "duplicate bound keyword" e306) (let ((labels321 (gen-labels120 ids319))) (let ((new-w322 (make-binding-wrap131 ids319 labels321 w308))) (k311 (cons e1317 e2318) (extend-env108 labels321 (let ((w324 (if rec?305 new-w322 w308)) (trans-r325 (macros-only-env110 r307))) (map (lambda (x326) (cons (quote macro) (eval-local-transformer157 (chi150 x326 trans-r325 w324 mod310) mod310))) val316)) r307) new-w322 s309 mod310)))))) tmp313) ((lambda (_328) (syntax-violation #f "bad local syntax definition" (source-wrap143 e306 w308 s309 mod310))) tmp312))) ($sc-dispatch tmp312 (quote (any #(each (any any)) any . each-any))))) e306))) (chi-lambda-clause155 (lambda (e329 docstring330 c331 r332 w333 mod334 k335) ((lambda (tmp336) ((lambda (tmp337) (if (if tmp337 (apply (lambda (args338 doc339 e1340 e2341) (if (string? (syntax->datum doc339)) (not docstring330) #f)) tmp337) #f) (apply (lambda (args342 doc343 e1344 e2345) (chi-lambda-clause155 e329 doc343 (cons args342 (cons e1344 e2345)) r332 w333 mod334 k335)) tmp337) ((lambda (tmp347) (if tmp347 (apply (lambda (id348 e1349 e2350) (let ((ids351 id348)) (if (not (valid-bound-ids?139 ids351)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels353 (gen-labels120 ids351)) (new-vars354 (map gen-var161 ids351))) (k335 (map syntax->datum ids351) new-vars354 (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1349 e2350) e329 (extend-var-env109 labels353 new-vars354 r332) (make-binding-wrap131 ids351 labels353 w333) mod334)))))) tmp347) ((lambda (tmp356) (if tmp356 (apply (lambda (ids357 e1358 e2359) (let ((old-ids360 (lambda-var-list162 ids357))) (if (not (valid-bound-ids?139 old-ids360)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels361 (gen-labels120 old-ids360)) (new-vars362 (map gen-var161 old-ids360))) (k335 (letrec ((f363 (lambda (ls1364 ls2365) (if (null? ls1364) (syntax->datum ls2365) (f363 (cdr ls1364) (cons (syntax->datum (car ls1364)) ls2365)))))) (f363 (cdr old-ids360) (car old-ids360))) (letrec ((f366 (lambda (ls1367 ls2368) (if (null? ls1367) ls2368 (f366 (cdr ls1367) (cons (car ls1367) ls2368)))))) (f366 (cdr new-vars362) (car new-vars362))) (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1358 e2359) e329 (extend-var-env109 labels361 new-vars362 r332) (make-binding-wrap131 old-ids360 labels361 w333) mod334)))))) tmp356) ((lambda (_370) (syntax-violation (quote lambda) "bad lambda" e329)) tmp336))) ($sc-dispatch tmp336 (quote (any any . each-any)))))) ($sc-dispatch tmp336 (quote (each-any any . each-any)))))) ($sc-dispatch tmp336 (quote (any any any . each-any))))) c331))) (chi-body154 (lambda (body371 outer-form372 r373 w374 mod375) (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) (let ((ribcage377 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w378 (make-wrap116 (wrap-marks117 w374) (cons ribcage377 (wrap-subst118 w374))))) (letrec ((parse379 (lambda (body380 ids381 labels382 var-ids383 vars384 vals385 bindings386) (if (null? body380) (syntax-violation #f "no expressions in body" outer-form372) (let ((e388 (cdar body380)) (er389 (caar body380))) (call-with-values (lambda () (syntax-type148 e388 er389 (quote (())) (source-annotation105 er389) ribcage377 mod375 #f)) (lambda (type390 value391 e392 w393 s394 mod395) (if (memv type390 (quote (define-form))) (let ((id396 (wrap142 value391 w393 mod395)) (label397 (gen-label119))) (let ((var398 (gen-var161 id396))) (begin (extend-ribcage!130 ribcage377 id396 label397) (parse379 (cdr body380) (cons id396 ids381) (cons label397 labels382) (cons id396 var-ids383) (cons var398 vars384) (cons (cons er389 (wrap142 e392 w393 mod395)) vals385) (cons (cons (quote lexical) var398) bindings386))))) (if (memv type390 (quote (define-syntax-form))) (let ((id399 (wrap142 value391 w393 mod395)) (label400 (gen-label119))) (begin (extend-ribcage!130 ribcage377 id399 label400) (parse379 (cdr body380) (cons id399 ids381) (cons label400 labels382) var-ids383 vars384 vals385 (cons (cons (quote macro) (cons er389 (wrap142 e392 w393 mod395))) bindings386)))) (if (memv type390 (quote (begin-form))) ((lambda (tmp401) ((lambda (tmp402) (if tmp402 (apply (lambda (_403 e1404) (parse379 (letrec ((f405 (lambda (forms406) (if (null? forms406) (cdr body380) (cons (cons er389 (wrap142 (car forms406) w393 mod395)) (f405 (cdr forms406))))))) (f405 e1404)) ids381 labels382 var-ids383 vars384 vals385 bindings386)) tmp402) (syntax-violation #f "source expression failed to match any pattern" tmp401))) ($sc-dispatch tmp401 (quote (any . each-any))))) e392) (if (memv type390 (quote (local-syntax-form))) (chi-local-syntax156 value391 e392 er389 w393 s394 mod395 (lambda (forms408 er409 w410 s411 mod412) (parse379 (letrec ((f413 (lambda (forms414) (if (null? forms414) (cdr body380) (cons (cons er409 (wrap142 (car forms414) w410 mod412)) (f413 (cdr forms414))))))) (f413 forms408)) ids381 labels382 var-ids383 vars384 vals385 bindings386))) (if (null? ids381) (build-sequence93 #f (map (lambda (x415) (chi150 (cdr x415) (car x415) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))) (begin (if (not (valid-bound-ids?139 ids381)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form372)) (letrec ((loop416 (lambda (bs417 er-cache418 r-cache419) (if (not (null? bs417)) (let ((b420 (car bs417))) (if (eq? (car b420) (quote macro)) (let ((er421 (cadr b420))) (let ((r-cache422 (if (eq? er421 er-cache418) r-cache419 (macros-only-env110 er421)))) (begin (set-cdr! b420 (eval-local-transformer157 (chi150 (cddr b420) r-cache422 (quote (())) mod395) mod395)) (loop416 (cdr bs417) er421 r-cache422)))) (loop416 (cdr bs417) er-cache418 r-cache419))))))) (loop416 bindings386 #f #f)) (set-cdr! r376 (extend-env108 labels382 bindings386 (cdr r376))) (build-letrec96 #f (map syntax->datum var-ids383) vars384 (map (lambda (x423) (chi150 (cdr x423) (car x423) (quote (())) mod395)) vals385) (build-sequence93 #f (map (lambda (x424) (chi150 (cdr x424) (car x424) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))))))))))))))))) (parse379 (map (lambda (x387) (cons r376 (wrap142 x387 w378 mod375))) body371) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p425 e426 r427 w428 rib429 mod430) (letrec ((rebuild-macro-output431 (lambda (x432 m433) (if (pair? x432) (cons (rebuild-macro-output431 (car x432) m433) (rebuild-macro-output431 (cdr x432) m433)) (if (syntax-object?98 x432) (let ((w434 (syntax-object-wrap100 x432))) (let ((ms435 (wrap-marks117 w434)) (s436 (wrap-subst118 w434))) (if (if (pair? ms435) (eq? (car ms435) #f) #f) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cdr ms435) (if rib429 (cons rib429 (cdr s436)) (cdr s436))) (syntax-object-module101 x432)) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cons m433 ms435) (if rib429 (cons rib429 (cons (quote shift) s436)) (cons (quote shift) s436))) (let ((pmod437 (procedure-module p425))) (if pmod437 (cons (quote hygiene) (module-name pmod437)) (quote (hygiene guile)))))))) (if (vector? x432) (let ((n438 (vector-length x432))) (let ((v439 (make-vector n438))) (letrec ((loop440 (lambda (i441) (if (fx=74 i441 n438) (begin (if #f #f) v439) (begin (vector-set! v439 i441 (rebuild-macro-output431 (vector-ref x432 i441) m433)) (loop440 (fx+72 i441 1))))))) (loop440 0)))) (if (symbol? x432) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e426 w428 s mod430) x432) x432))))))) (rebuild-macro-output431 (p425 (wrap142 e426 (anti-mark129 w428) mod430)) (string #\m))))) (chi-application152 (lambda (x442 e443 r444 w445 s446 mod447) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (e0450 e1451) (build-application81 s446 x442 (map (lambda (e452) (chi150 e452 r444 w445 mod447)) e1451))) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e443))) (chi-expr151 (lambda (type454 value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (lexical))) (build-lexical-reference83 (quote value) s459 e456 value455) (if (memv type454 (quote (core core-form))) (value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (module-ref))) (call-with-values (lambda () (value455 e456)) (lambda (id461 mod462) (build-global-reference86 s459 id461 mod462))) (if (memv type454 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e456)) (car e456) value455) e456 r457 w458 s459 mod460) (if (memv type454 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e456)) (if (syntax-object?98 value455) (syntax-object-expression99 value455) value455) (if (syntax-object?98 value455) (syntax-object-module101 value455) mod460)) e456 r457 w458 s459 mod460) (if (memv type454 (quote (constant))) (build-data92 s459 (strip160 (source-wrap143 e456 w458 s459 mod460) (quote (())))) (if (memv type454 (quote (global))) (build-global-reference86 s459 value455 mod460) (if (memv type454 (quote (call))) (chi-application152 (chi150 (car e456) r457 w458 mod460) e456 r457 w458 s459 mod460) (if (memv type454 (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466 e2467) (chi-sequence144 (cons e1466 e2467) r457 w458 s459 mod460)) tmp464) (syntax-violation #f "source expression failed to match any pattern" tmp463))) ($sc-dispatch tmp463 (quote (any any . each-any))))) e456) (if (memv type454 (quote (local-syntax-form))) (chi-local-syntax156 value455 e456 r457 w458 s459 mod460 chi-sequence144) (if (memv type454 (quote (eval-when-form))) ((lambda (tmp469) ((lambda (tmp470) (if tmp470 (apply (lambda (_471 x472 e1473 e2474) (let ((when-list475 (chi-when-list147 e456 x472 w458))) (if (memq (quote eval) when-list475) (chi-sequence144 (cons e1473 e2474) r457 w458 s459 mod460) (chi-void158)))) tmp470) (syntax-violation #f "source expression failed to match any pattern" tmp469))) ($sc-dispatch tmp469 (quote (any each-any any . each-any))))) e456) (if (memv type454 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e456 (wrap142 value455 w458 mod460)) (if (memv type454 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e456 w458 s459 mod460)) (if (memv type454 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e456 w458 s459 mod460)) (syntax-violation #f "unexpected syntax" (source-wrap143 e456 w458 s459 mod460)))))))))))))))))) (chi150 (lambda (e478 r479 w480 mod481) (call-with-values (lambda () (syntax-type148 e478 r479 w480 (source-annotation105 e478) #f mod481 #f)) (lambda (type482 value483 e484 w485 s486 mod487) (chi-expr151 type482 value483 e484 r479 w485 s486 mod487))))) (chi-top149 (lambda (e488 r489 w490 m491 esew492 mod493) (call-with-values (lambda () (syntax-type148 e488 r489 w490 (source-annotation105 e488) #f mod493 #f)) (lambda (type501 value502 e503 w504 s505 mod506) (if (memv type501 (quote (begin-form))) ((lambda (tmp507) ((lambda (tmp508) (if tmp508 (apply (lambda (_509) (chi-void158)) tmp508) ((lambda (tmp510) (if tmp510 (apply (lambda (_511 e1512 e2513) (chi-top-sequence145 (cons e1512 e2513) r489 w504 s505 m491 esew492 mod506)) tmp510) (syntax-violation #f "source expression failed to match any pattern" tmp507))) ($sc-dispatch tmp507 (quote (any any . each-any)))))) ($sc-dispatch tmp507 (quote (any))))) e503) (if (memv type501 (quote (local-syntax-form))) (chi-local-syntax156 value502 e503 r489 w504 s505 mod506 (lambda (body515 r516 w517 s518 mod519) (chi-top-sequence145 body515 r516 w517 s518 m491 esew492 mod519))) (if (memv type501 (quote (eval-when-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 x523 e1524 e2525) (let ((when-list526 (chi-when-list147 e503 x523 w504)) (body527 (cons e1524 e2525))) (if (eq? m491 (quote e)) (if (memq (quote eval) when-list526) (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) (chi-void158)) (if (memq (quote load) when-list526) (if (let ((t530 (memq (quote compile) when-list526))) (if t530 t530 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (chi-top-sequence145 body527 r489 w504 s505 (quote c&e) (quote (compile load)) mod506) (if (memq m491 (quote (c c&e))) (chi-top-sequence145 body527 r489 w504 s505 (quote c) (quote (load)) mod506) (chi-void158))) (if (let ((t531 (memq (quote compile) when-list526))) (if t531 t531 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) mod506) (chi-void158)) (chi-void158)))))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any each-any any . each-any))))) e503) (if (memv type501 (quote (define-syntax-form))) (let ((n532 (id-var-name136 value502 w504)) (r533 (macros-only-env110 r489))) (if (memv m491 (quote (c))) (if (memq (quote compile) esew492) (let ((e534 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e534 mod506) (if (memq (quote load) esew492) e534 (chi-void158)))) (if (memq (quote load) esew492) (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) (chi-void158))) (if (memv m491 (quote (c&e))) (let ((e535 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e535 mod506) e535)) (begin (if (memq (quote eval) esew492) (top-level-eval-hook76 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) mod506)) (chi-void158))))) (if (memv type501 (quote (define-form))) (let ((n536 (id-var-name136 value502 w504))) (let ((type537 (binding-type106 (lookup111 n536 r489 mod506)))) (if (memv type537 (quote (global core macro module-ref))) (begin (if (not (module-local-variable (current-module) n536)) (module-define! (current-module) n536 #f)) (let ((x538 (build-global-definition89 s505 n536 (chi150 e503 r489 w504 mod506)))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x538 mod506)) x538))) (if (memv type537 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e503 (wrap142 value502 w504 mod506)) (syntax-violation #f "cannot define keyword at top level" e503 (wrap142 value502 w504 mod506)))))) (let ((x539 (chi-expr151 type501 value502 e503 r489 w504 s505 mod506))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x539 mod506)) x539))))))))))) (syntax-type148 (lambda (e540 r541 w542 s543 rib544 mod545 for-car?546) (if (symbol? e540) (let ((n547 (id-var-name136 e540 w542))) (let ((b548 (lookup111 n547 r541 mod545))) (let ((type549 (binding-type106 b548))) (if (memv type549 (quote (lexical))) (values type549 (binding-value107 b548) e540 w542 s543 mod545) (if (memv type549 (quote (global))) (values type549 n547 e540 w542 s543 mod545) (if (memv type549 (quote (macro))) (if for-car?546 (values type549 (binding-value107 b548) e540 w542 s543 mod545) (syntax-type148 (chi-macro153 (binding-value107 b548) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 #f)) (values type549 (binding-value107 b548) e540 w542 s543 mod545))))))) (if (pair? e540) (let ((first550 (car e540))) (call-with-values (lambda () (syntax-type148 first550 r541 w542 s543 rib544 mod545 #t)) (lambda (ftype551 fval552 fe553 fw554 fs555 fmod556) (if (memv ftype551 (quote (lexical))) (values (quote lexical-call) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (global))) (values (quote global-call) (make-syntax-object97 fval552 w542 fmod556) e540 w542 s543 mod545) (if (memv ftype551 (quote (macro))) (syntax-type148 (chi-macro153 fval552 e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 for-car?546) (if (memv ftype551 (quote (module-ref))) (call-with-values (lambda () (fval552 e540)) (lambda (sym557 mod558) (syntax-type148 sym557 r541 w542 s543 rib544 mod558 for-car?546))) (if (memv ftype551 (quote (core))) (values (quote core-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (local-syntax))) (values (quote local-syntax-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (begin))) (values (quote begin-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (eval-when))) (values (quote eval-when-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (define))) ((lambda (tmp559) ((lambda (tmp560) (if (if tmp560 (apply (lambda (_561 name562 val563) (id?114 name562)) tmp560) #f) (apply (lambda (_564 name565 val566) (values (quote define-form) name565 val566 w542 s543 mod545)) tmp560) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 args570 e1571 e2572) (if (id?114 name569) (valid-bound-ids?139 (lambda-var-list162 args570)) #f)) tmp567) #f) (apply (lambda (_573 name574 args575 e1576 e2577) (values (quote define-form) (wrap142 name574 w542 mod545) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args575 (cons e1576 e2577)) w542 mod545)) (quote (())) s543 mod545)) tmp567) ((lambda (tmp579) (if (if tmp579 (apply (lambda (_580 name581) (id?114 name581)) tmp579) #f) (apply (lambda (_582 name583) (values (quote define-form) (wrap142 name583 w542 mod545) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s543 mod545)) tmp579) (syntax-violation #f "source expression failed to match any pattern" tmp559))) ($sc-dispatch tmp559 (quote (any any)))))) ($sc-dispatch tmp559 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp559 (quote (any any any))))) e540) (if (memv ftype551 (quote (define-syntax))) ((lambda (tmp584) ((lambda (tmp585) (if (if tmp585 (apply (lambda (_586 name587 val588) (id?114 name587)) tmp585) #f) (apply (lambda (_589 name590 val591) (values (quote define-syntax-form) name590 val591 w542 s543 mod545)) tmp585) (syntax-violation #f "source expression failed to match any pattern" tmp584))) ($sc-dispatch tmp584 (quote (any any any))))) e540) (values (quote call) #f e540 w542 s543 mod545)))))))))))))) (if (syntax-object?98 e540) (syntax-type148 (syntax-object-expression99 e540) r541 (join-wraps133 w542 (syntax-object-wrap100 e540)) s543 rib544 (let ((t592 (syntax-object-module101 e540))) (if t592 t592 mod545)) for-car?546) (if (self-evaluating? e540) (values (quote constant) #f e540 w542 s543 mod545) (values (quote other) #f e540 w542 s543 mod545))))))) (chi-when-list147 (lambda (e593 when-list594 w595) (letrec ((f596 (lambda (when-list597 situations598) (if (null? when-list597) situations598 (f596 (cdr when-list597) (cons (let ((x599 (car when-list597))) (if (free-id=?137 x599 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x599 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x599 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e593 (wrap142 x599 w595 #f)))))) situations598)))))) (f596 when-list594 (quote ()))))) (chi-install-global146 (lambda (name600 e601) (build-global-definition89 #f name600 (if (let ((v602 (module-variable (current-module) name600))) (if v602 (if (variable-bound? v602) (if (macro? (variable-ref v602)) (not (eq? (macro-type (variable-ref v602)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name600))) (build-data92 #f (quote macro)) e601)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e601)))))) (chi-top-sequence145 (lambda (body603 r604 w605 s606 m607 esew608 mod609) (build-sequence93 s606 (letrec ((dobody610 (lambda (body611 r612 w613 m614 esew615 mod616) (if (null? body611) (quote ()) (let ((first617 (chi-top149 (car body611) r612 w613 m614 esew615 mod616))) (cons first617 (dobody610 (cdr body611) r612 w613 m614 esew615 mod616))))))) (dobody610 body603 r604 w605 m607 esew608 mod609))))) (chi-sequence144 (lambda (body618 r619 w620 s621 mod622) (build-sequence93 s621 (letrec ((dobody623 (lambda (body624 r625 w626 mod627) (if (null? body624) (quote ()) (let ((first628 (chi150 (car body624) r625 w626 mod627))) (cons first628 (dobody623 (cdr body624) r625 w626 mod627))))))) (dobody623 body618 r619 w620 mod622))))) (source-wrap143 (lambda (x629 w630 s631 defmod632) (begin (if (if s631 (pair? x629) #f) (set-source-properties! x629 s631)) (wrap142 x629 w630 defmod632)))) (wrap142 (lambda (x633 w634 defmod635) (if (if (null? (wrap-marks117 w634)) (null? (wrap-subst118 w634)) #f) x633 (if (syntax-object?98 x633) (make-syntax-object97 (syntax-object-expression99 x633) (join-wraps133 w634 (syntax-object-wrap100 x633)) (syntax-object-module101 x633)) (if (null? x633) x633 (make-syntax-object97 x633 w634 defmod635)))))) (bound-id-member?141 (lambda (x636 list637) (if (not (null? list637)) (let ((t638 (bound-id=?138 x636 (car list637)))) (if t638 t638 (bound-id-member?141 x636 (cdr list637)))) #f))) (distinct-bound-ids?140 (lambda (ids639) (letrec ((distinct?640 (lambda (ids641) (let ((t642 (null? ids641))) (if t642 t642 (if (not (bound-id-member?141 (car ids641) (cdr ids641))) (distinct?640 (cdr ids641)) #f)))))) (distinct?640 ids639)))) (valid-bound-ids?139 (lambda (ids643) (if (letrec ((all-ids?644 (lambda (ids645) (let ((t646 (null? ids645))) (if t646 t646 (if (id?114 (car ids645)) (all-ids?644 (cdr ids645)) #f)))))) (all-ids?644 ids643)) (distinct-bound-ids?140 ids643) #f))) (bound-id=?138 (lambda (i647 j648) (if (if (syntax-object?98 i647) (syntax-object?98 j648) #f) (if (eq? (syntax-object-expression99 i647) (syntax-object-expression99 j648)) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i647)) (wrap-marks117 (syntax-object-wrap100 j648))) #f) (eq? i647 j648)))) (free-id=?137 (lambda (i649 j650) (if (eq? (let ((x651 i649)) (if (syntax-object?98 x651) (syntax-object-expression99 x651) x651)) (let ((x652 j650)) (if (syntax-object?98 x652) (syntax-object-expression99 x652) x652))) (eq? (id-var-name136 i649 (quote (()))) (id-var-name136 j650 (quote (())))) #f))) (id-var-name136 (lambda (id653 w654) (letrec ((search-vector-rib657 (lambda (sym663 subst664 marks665 symnames666 ribcage667) (let ((n668 (vector-length symnames666))) (letrec ((f669 (lambda (i670) (if (fx=74 i670 n668) (search655 sym663 (cdr subst664) marks665) (if (if (eq? (vector-ref symnames666 i670) sym663) (same-marks?135 marks665 (vector-ref (ribcage-marks124 ribcage667) i670)) #f) (values (vector-ref (ribcage-labels125 ribcage667) i670) marks665) (f669 (fx+72 i670 1))))))) (f669 0))))) (search-list-rib656 (lambda (sym671 subst672 marks673 symnames674 ribcage675) (letrec ((f676 (lambda (symnames677 i678) (if (null? symnames677) (search655 sym671 (cdr subst672) marks673) (if (if (eq? (car symnames677) sym671) (same-marks?135 marks673 (list-ref (ribcage-marks124 ribcage675) i678)) #f) (values (list-ref (ribcage-labels125 ribcage675) i678) marks673) (f676 (cdr symnames677) (fx+72 i678 1))))))) (f676 symnames674 0)))) (search655 (lambda (sym679 subst680 marks681) (if (null? subst680) (values #f marks681) (let ((fst682 (car subst680))) (if (eq? fst682 (quote shift)) (search655 sym679 (cdr subst680) (cdr marks681)) (let ((symnames683 (ribcage-symnames123 fst682))) (if (vector? symnames683) (search-vector-rib657 sym679 subst680 marks681 symnames683 fst682) (search-list-rib656 sym679 subst680 marks681 symnames683 fst682))))))))) (if (symbol? id653) (let ((t684 (call-with-values (lambda () (search655 id653 (wrap-subst118 w654) (wrap-marks117 w654))) (lambda (x686 . ignore685) x686)))) (if t684 t684 id653)) (if (syntax-object?98 id653) (let ((id687 (syntax-object-expression99 id653)) (w1688 (syntax-object-wrap100 id653))) (let ((marks689 (join-marks134 (wrap-marks117 w654) (wrap-marks117 w1688)))) (call-with-values (lambda () (search655 id687 (wrap-subst118 w654) marks689)) (lambda (new-id690 marks691) (let ((t692 new-id690)) (if t692 t692 (let ((t693 (call-with-values (lambda () (search655 id687 (wrap-subst118 w1688) marks691)) (lambda (x695 . ignore694) x695)))) (if t693 t693 id687)))))))) (syntax-violation (quote id-var-name) "invalid id" id653)))))) (same-marks?135 (lambda (x696 y697) (let ((t698 (eq? x696 y697))) (if t698 t698 (if (not (null? x696)) (if (not (null? y697)) (if (eq? (car x696) (car y697)) (same-marks?135 (cdr x696) (cdr y697)) #f) #f) #f))))) (join-marks134 (lambda (m1699 m2700) (smart-append132 m1699 m2700))) (join-wraps133 (lambda (w1701 w2702) (let ((m1703 (wrap-marks117 w1701)) (s1704 (wrap-subst118 w1701))) (if (null? m1703) (if (null? s1704) w2702 (make-wrap116 (wrap-marks117 w2702) (smart-append132 s1704 (wrap-subst118 w2702)))) (make-wrap116 (smart-append132 m1703 (wrap-marks117 w2702)) (smart-append132 s1704 (wrap-subst118 w2702))))))) (smart-append132 (lambda (m1705 m2706) (if (null? m2706) m1705 (append m1705 m2706)))) (make-binding-wrap131 (lambda (ids707 labels708 w709) (if (null? ids707) w709 (make-wrap116 (wrap-marks117 w709) (cons (let ((labelvec710 (list->vector labels708))) (let ((n711 (vector-length labelvec710))) (let ((symnamevec712 (make-vector n711)) (marksvec713 (make-vector n711))) (begin (letrec ((f714 (lambda (ids715 i716) (if (not (null? ids715)) (call-with-values (lambda () (id-sym-name&marks115 (car ids715) w709)) (lambda (symname717 marks718) (begin (vector-set! symnamevec712 i716 symname717) (vector-set! marksvec713 i716 marks718) (f714 (cdr ids715) (fx+72 i716 1))))))))) (f714 ids707 0)) (make-ribcage121 symnamevec712 marksvec713 labelvec710))))) (wrap-subst118 w709)))))) (extend-ribcage!130 (lambda (ribcage719 id720 label721) (begin (set-ribcage-symnames!126 ribcage719 (cons (syntax-object-expression99 id720) (ribcage-symnames123 ribcage719))) (set-ribcage-marks!127 ribcage719 (cons (wrap-marks117 (syntax-object-wrap100 id720)) (ribcage-marks124 ribcage719))) (set-ribcage-labels!128 ribcage719 (cons label721 (ribcage-labels125 ribcage719)))))) (anti-mark129 (lambda (w722) (make-wrap116 (cons #f (wrap-marks117 w722)) (cons (quote shift) (wrap-subst118 w722))))) (set-ribcage-labels!128 (lambda (x723 update724) (vector-set! x723 3 update724))) (set-ribcage-marks!127 (lambda (x725 update726) (vector-set! x725 2 update726))) (set-ribcage-symnames!126 (lambda (x727 update728) (vector-set! x727 1 update728))) (ribcage-labels125 (lambda (x729) (vector-ref x729 3))) (ribcage-marks124 (lambda (x730) (vector-ref x730 2))) (ribcage-symnames123 (lambda (x731) (vector-ref x731 1))) (ribcage?122 (lambda (x732) (if (vector? x732) (if (= (vector-length x732) 4) (eq? (vector-ref x732 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames733 marks734 labels735) (vector (quote ribcage) symnames733 marks734 labels735))) (gen-labels120 (lambda (ls736) (if (null? ls736) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls736)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x737 w738) (if (syntax-object?98 x737) (values (syntax-object-expression99 x737) (join-marks134 (wrap-marks117 w738) (wrap-marks117 (syntax-object-wrap100 x737)))) (values x737 (wrap-marks117 w738))))) (id?114 (lambda (x739) (if (symbol? x739) #t (if (syntax-object?98 x739) (symbol? (syntax-object-expression99 x739)) #f)))) (nonsymbol-id?113 (lambda (x740) (if (syntax-object?98 x740) (symbol? (syntax-object-expression99 x740)) #f))) (global-extend112 (lambda (type741 sym742 val743) (put-global-definition-hook78 sym742 type741 val743))) (lookup111 (lambda (x744 r745 mod746) (let ((t747 (assq x744 r745))) (if t747 (cdr t747) (if (symbol? x744) (let ((t748 (get-global-definition-hook79 x744 mod746))) (if t748 t748 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r749) (if (null? r749) (quote ()) (let ((a750 (car r749))) (if (eq? (cadr a750) (quote macro)) (cons a750 (macros-only-env110 (cdr r749))) (macros-only-env110 (cdr r749))))))) (extend-var-env109 (lambda (labels751 vars752 r753) (if (null? labels751) r753 (extend-var-env109 (cdr labels751) (cdr vars752) (cons (cons (car labels751) (cons (quote lexical) (car vars752))) r753))))) (extend-env108 (lambda (labels754 bindings755 r756) (if (null? labels754) r756 (extend-env108 (cdr labels754) (cdr bindings755) (cons (cons (car labels754) (car bindings755)) r756))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x757) (if (syntax-object?98 x757) (source-annotation105 (syntax-object-expression99 x757)) (if (pair? x757) (let ((props758 (source-properties x757))) (if (pair? props758) props758 #f)) #f)))) (set-syntax-object-module!104 (lambda (x759 update760) (vector-set! x759 3 update760))) (set-syntax-object-wrap!103 (lambda (x761 update762) (vector-set! x761 2 update762))) (set-syntax-object-expression!102 (lambda (x763 update764) (vector-set! x763 1 update764))) (syntax-object-module101 (lambda (x765) (vector-ref x765 3))) (syntax-object-wrap100 (lambda (x766) (vector-ref x766 2))) (syntax-object-expression99 (lambda (x767) (vector-ref x767 1))) (syntax-object?98 (lambda (x768) (if (vector? x768) (if (= (vector-length x768) 4) (eq? (vector-ref x768 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression769 wrap770 module771) (vector (quote syntax-object) expression769 wrap770 module771))) (build-letrec96 (lambda (src772 ids773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (let ((atom-key777 (fluid-ref *mode*71))) (if (memv atom-key777 (quote (c))) (begin (for-each maybe-name-value!88 ids773 val-exps775) ((@ (language tree-il) make-letrec) src772 ids773 vars774 val-exps775 body-exp776)) (list (quote letrec) (map list vars774 val-exps775) body-exp776)))))) (build-named-let95 (lambda (src778 ids779 vars780 val-exps781 body-exp782) (let ((f783 (car vars780)) (f-name784 (car ids779)) (vars785 (cdr vars780)) (ids786 (cdr ids779))) (let ((atom-key787 (fluid-ref *mode*71))) (if (memv atom-key787 (quote (c))) (let ((proc788 (build-lambda90 src778 ids786 vars785 #f body-exp782))) (begin (maybe-name-value!88 f-name784 proc788) (for-each maybe-name-value!88 ids786 val-exps781) ((@ (language tree-il) make-letrec) src778 (list f-name784) (list f783) (list proc788) (build-application81 src778 (build-lexical-reference83 (quote fun) src778 f-name784 f783) val-exps781)))) (list (quote let) f783 (map list vars785 val-exps781) body-exp782)))))) (build-let94 (lambda (src789 ids790 vars791 val-exps792 body-exp793) (if (null? vars791) body-exp793 (let ((atom-key794 (fluid-ref *mode*71))) (if (memv atom-key794 (quote (c))) (begin (for-each maybe-name-value!88 ids790 val-exps792) ((@ (language tree-il) make-let) src789 ids790 vars791 val-exps792 body-exp793)) (list (quote let) (map list vars791 val-exps792) body-exp793)))))) (build-sequence93 (lambda (src795 exps796) (if (null? (cdr exps796)) (car exps796) (let ((atom-key797 (fluid-ref *mode*71))) (if (memv atom-key797 (quote (c))) ((@ (language tree-il) make-sequence) src795 exps796) (cons (quote begin) exps796)))))) (build-data92 (lambda (src798 exp799) (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-const) src798 exp799) (if (if (self-evaluating? exp799) (not (vector? exp799)) #f) exp799 (list (quote quote) exp799)))))) (build-primref91 (lambda (src801 name802) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key803 (fluid-ref *mode*71))) (if (memv atom-key803 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src801 name802) name802)) (let ((atom-key804 (fluid-ref *mode*71))) (if (memv atom-key804 (quote (c))) ((@ (language tree-il) make-module-ref) src801 (quote (guile)) name802 #f) (list (quote @@) (quote (guile)) name802)))))) (build-lambda90 (lambda (src805 ids806 vars807 docstring808 exp809) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-lambda) src805 ids806 vars807 (if docstring808 (list (cons (quote documentation) docstring808)) (quote ())) exp809) (cons (quote lambda) (cons vars807 (append (if docstring808 (list docstring808) (quote ())) (list exp809)))))))) (build-global-definition89 (lambda (source811 var812 exp813) (let ((atom-key814 (fluid-ref *mode*71))) (if (memv atom-key814 (quote (c))) (begin (maybe-name-value!88 var812 exp813) ((@ (language tree-il) make-toplevel-define) source811 var812 exp813)) (list (quote define) var812 exp813))))) (maybe-name-value!88 (lambda (name815 val816) (if ((@ (language tree-il) lambda?) val816) (let ((meta817 ((@ (language tree-il) lambda-meta) val816))) (if (not (assq (quote name) meta817)) ((setter (@ (language tree-il) lambda-meta)) val816 (acons (quote name) name815 meta817))))))) (build-global-assignment87 (lambda (source818 var819 exp820 mod821) (analyze-variable85 mod821 var819 (lambda (mod822 var823 public?824) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-module-set) source818 mod822 var823 public?824 exp820) (list (quote set!) (list (if public?824 (quote @) (quote @@)) mod822 var823) exp820)))) (lambda (var826) (let ((atom-key827 (fluid-ref *mode*71))) (if (memv atom-key827 (quote (c))) ((@ (language tree-il) make-toplevel-set) source818 var826 exp820) (list (quote set!) var826 exp820))))))) (build-global-reference86 (lambda (source828 var829 mod830) (analyze-variable85 mod830 var829 (lambda (mod831 var832 public?833) (let ((atom-key834 (fluid-ref *mode*71))) (if (memv atom-key834 (quote (c))) ((@ (language tree-il) make-module-ref) source828 mod831 var832 public?833) (list (if public?833 (quote @) (quote @@)) mod831 var832)))) (lambda (var835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source828 var835) var835)))))) (analyze-variable85 (lambda (mod837 var838 modref-cont839 bare-cont840) (if (not mod837) (bare-cont840 var838) (let ((kind841 (car mod837)) (mod842 (cdr mod837))) (if (memv kind841 (quote (public))) (modref-cont839 mod842 var838 #t) (if (memv kind841 (quote (private))) (if (not (equal? mod842 (module-name (current-module)))) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (if (memv kind841 (quote (bare))) (bare-cont840 var838) (if (memv kind841 (quote (hygiene))) (if (if (not (equal? mod842 (module-name (current-module)))) (module-variable (resolve-module mod842) var838) #f) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (syntax-violation #f "bad module kind" var838 mod842))))))))) (build-lexical-assignment84 (lambda (source843 name844 var845 exp846) (let ((atom-key847 (fluid-ref *mode*71))) (if (memv atom-key847 (quote (c))) ((@ (language tree-il) make-lexical-set) source843 name844 var845 exp846) (list (quote set!) var845 exp846))))) (build-lexical-reference83 (lambda (type848 source849 name850 var851) (let ((atom-key852 (fluid-ref *mode*71))) (if (memv atom-key852 (quote (c))) ((@ (language tree-il) make-lexical-ref) source849 name850 var851) var851)))) (build-conditional82 (lambda (source853 test-exp854 then-exp855 else-exp856) (let ((atom-key857 (fluid-ref *mode*71))) (if (memv atom-key857 (quote (c))) ((@ (language tree-il) make-conditional) source853 test-exp854 then-exp855 else-exp856) (if (equal? else-exp856 (quote (if #f #f))) (list (quote if) test-exp854 then-exp855) (list (quote if) test-exp854 then-exp855 else-exp856)))))) (build-application81 (lambda (source858 fun-exp859 arg-exps860) (let ((atom-key861 (fluid-ref *mode*71))) (if (memv atom-key861 (quote (c))) ((@ (language tree-il) make-application) source858 fun-exp859 arg-exps860) (cons fun-exp859 arg-exps860))))) (build-void80 (lambda (source862) (let ((atom-key863 (fluid-ref *mode*71))) (if (memv atom-key863 (quote (c))) ((@ (language tree-il) make-void) source862) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol864 module865) (begin (if (if (not module865) (current-module) #f) (warn "module system is booted, we should have a module" symbol864)) (let ((v866 (module-variable (if module865 (resolve-module (cdr module865)) (current-module)) symbol864))) (if v866 (if (variable-bound? v866) (let ((val867 (variable-ref v866))) (if (macro? val867) (if (syncase-macro-type val867) (cons (syncase-macro-type val867) (syncase-macro-binding val867)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol868 type869 val870) (let ((existing871 (let ((v872 (module-variable (current-module) symbol868))) (if v872 (if (variable-bound? v872) (let ((val873 (variable-ref v872))) (if (macro? val873) (if (not (syncase-macro-type val873)) val873 #f) #f)) #f) #f)))) (module-define! (current-module) symbol868 (if existing871 (make-extended-syncase-macro existing871 type869 val870) (make-syncase-macro type869 val870)))))) (local-eval-hook77 (lambda (x874 mod875) (primitive-eval (list noexpand70 (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) tree-il->scheme) x874) x874)))))) (top-level-eval-hook76 (lambda (x877 mod878) (primitive-eval (list noexpand70 (let ((atom-key879 (fluid-ref *mode*71))) (if (memv atom-key879 (quote (c))) ((@ (language tree-il) tree-il->scheme) x877) x877)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e880 r881 w882 s883 mod884) ((lambda (tmp885) ((lambda (tmp886) (if (if tmp886 (apply (lambda (_887 var888 val889 e1890 e2891) (valid-bound-ids?139 var888)) tmp886) #f) (apply (lambda (_893 var894 val895 e1896 e2897) (let ((names898 (map (lambda (x899) (id-var-name136 x899 w882)) var894))) (begin (for-each (lambda (id901 n902) (let ((atom-key903 (binding-type106 (lookup111 n902 r881 mod884)))) (if (memv atom-key903 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e880 (source-wrap143 id901 w882 s883 mod884))))) var894 names898) (chi-body154 (cons e1896 e2897) (source-wrap143 e880 w882 s883 mod884) (extend-env108 names898 (let ((trans-r906 (macros-only-env110 r881))) (map (lambda (x907) (cons (quote macro) (eval-local-transformer157 (chi150 x907 trans-r906 w882 mod884) mod884))) val895)) r881) w882 mod884)))) tmp886) ((lambda (_909) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e880 w882 s883 mod884))) tmp885))) ($sc-dispatch tmp885 (quote (any #(each (any any)) any . each-any))))) e880))) (global-extend112 (quote core) (quote quote) (lambda (e910 r911 w912 s913 mod914) ((lambda (tmp915) ((lambda (tmp916) (if tmp916 (apply (lambda (_917 e918) (build-data92 s913 (strip160 e918 w912))) tmp916) ((lambda (_919) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e910 w912 s913 mod914))) tmp915))) ($sc-dispatch tmp915 (quote (any any))))) e910))) (global-extend112 (quote core) (quote syntax) (letrec ((regen927 (lambda (x928) (let ((atom-key929 (car x928))) (if (memv atom-key929 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x928) (cadr x928)) (if (memv atom-key929 (quote (primitive))) (build-primref91 #f (cadr x928)) (if (memv atom-key929 (quote (quote))) (build-data92 #f (cadr x928)) (if (memv atom-key929 (quote (lambda))) (build-lambda90 #f (cadr x928) (cadr x928) #f (regen927 (caddr x928))) (build-application81 #f (build-primref91 #f (car x928)) (map regen927 (cdr x928)))))))))) (gen-vector926 (lambda (x930) (if (eq? (car x930) (quote list)) (cons (quote vector) (cdr x930)) (if (eq? (car x930) (quote quote)) (list (quote quote) (list->vector (cadr x930))) (list (quote list->vector) x930))))) (gen-append925 (lambda (x931 y932) (if (equal? y932 (quote (quote ()))) x931 (list (quote append) x931 y932)))) (gen-cons924 (lambda (x933 y934) (let ((atom-key935 (car y934))) (if (memv atom-key935 (quote (quote))) (if (eq? (car x933) (quote quote)) (list (quote quote) (cons (cadr x933) (cadr y934))) (if (eq? (cadr y934) (quote ())) (list (quote list) x933) (list (quote cons) x933 y934))) (if (memv atom-key935 (quote (list))) (cons (quote list) (cons x933 (cdr y934))) (list (quote cons) x933 y934)))))) (gen-map923 (lambda (e936 map-env937) (let ((formals938 (map cdr map-env937)) (actuals939 (map (lambda (x940) (list (quote ref) (car x940))) map-env937))) (if (eq? (car e936) (quote ref)) (car actuals939) (if (and-map (lambda (x941) (if (eq? (car x941) (quote ref)) (memq (cadr x941) formals938) #f)) (cdr e936)) (cons (quote map) (cons (list (quote primitive) (car e936)) (map (let ((r942 (map cons formals938 actuals939))) (lambda (x943) (cdr (assq (cadr x943) r942)))) (cdr e936)))) (cons (quote map) (cons (list (quote lambda) formals938 e936) actuals939))))))) (gen-mappend922 (lambda (e944 map-env945) (list (quote apply) (quote (primitive append)) (gen-map923 e944 map-env945)))) (gen-ref921 (lambda (src946 var947 level948 maps949) (if (fx=74 level948 0) (values var947 maps949) (if (null? maps949) (syntax-violation (quote syntax) "missing ellipsis" src946) (call-with-values (lambda () (gen-ref921 src946 var947 (fx-73 level948 1) (cdr maps949))) (lambda (outer-var950 outer-maps951) (let ((b952 (assq outer-var950 (car maps949)))) (if b952 (values (cdr b952) maps949) (let ((inner-var953 (gen-var161 (quote tmp)))) (values inner-var953 (cons (cons (cons outer-var950 inner-var953) (car maps949)) outer-maps951))))))))))) (gen-syntax920 (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) (if (id?114 e955) (let ((label960 (id-var-name136 e955 (quote (()))))) (let ((b961 (lookup111 label960 r956 mod959))) (if (eq? (binding-type106 b961) (quote syntax)) (call-with-values (lambda () (let ((var.lev962 (binding-value107 b961))) (gen-ref921 src954 (car var.lev962) (cdr var.lev962) maps957))) (lambda (var963 maps964) (values (list (quote ref) var963) maps964))) (if (ellipsis?958 e955) (syntax-violation (quote syntax) "misplaced ellipsis" src954) (values (list (quote quote) e955) maps957))))) ((lambda (tmp965) ((lambda (tmp966) (if (if tmp966 (apply (lambda (dots967 e968) (ellipsis?958 dots967)) tmp966) #f) (apply (lambda (dots969 e970) (gen-syntax920 src954 e970 r956 maps957 (lambda (x971) #f) mod959)) tmp966) ((lambda (tmp972) (if (if tmp972 (apply (lambda (x973 dots974 y975) (ellipsis?958 dots974)) tmp972) #f) (apply (lambda (x976 dots977 y978) (letrec ((f979 (lambda (y980 k981) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 y988) (ellipsis?958 dots987)) tmp986) #f) (apply (lambda (dots989 y990) (f979 y990 (lambda (maps991) (call-with-values (lambda () (k981 (cons (quote ()) maps991))) (lambda (x992 maps993) (if (null? (car maps993)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-mappend922 x992 (car maps993)) (cdr maps993)))))))) tmp986) ((lambda (_994) (call-with-values (lambda () (gen-syntax920 src954 y980 r956 maps957 ellipsis?958 mod959)) (lambda (y995 maps996) (call-with-values (lambda () (k981 maps996)) (lambda (x997 maps998) (values (gen-append925 x997 y995) maps998)))))) tmp985))) ($sc-dispatch tmp985 (quote (any . any))))) y980)))) (f979 y978 (lambda (maps982) (call-with-values (lambda () (gen-syntax920 src954 x976 r956 (cons (quote ()) maps982) ellipsis?958 mod959)) (lambda (x983 maps984) (if (null? (car maps984)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-map923 x983 (car maps984)) (cdr maps984))))))))) tmp972) ((lambda (tmp999) (if tmp999 (apply (lambda (x1000 y1001) (call-with-values (lambda () (gen-syntax920 src954 x1000 r956 maps957 ellipsis?958 mod959)) (lambda (x1002 maps1003) (call-with-values (lambda () (gen-syntax920 src954 y1001 r956 maps1003 ellipsis?958 mod959)) (lambda (y1004 maps1005) (values (gen-cons924 x1002 y1004) maps1005)))))) tmp999) ((lambda (tmp1006) (if tmp1006 (apply (lambda (e11007 e21008) (call-with-values (lambda () (gen-syntax920 src954 (cons e11007 e21008) r956 maps957 ellipsis?958 mod959)) (lambda (e1010 maps1011) (values (gen-vector926 e1010) maps1011)))) tmp1006) ((lambda (_1012) (values (list (quote quote) e955) maps957)) tmp965))) ($sc-dispatch tmp965 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp965 (quote (any . any)))))) ($sc-dispatch tmp965 (quote (any any . any)))))) ($sc-dispatch tmp965 (quote (any any))))) e955))))) (lambda (e1013 r1014 w1015 s1016 mod1017) (let ((e1018 (source-wrap143 e1013 w1015 s1016 mod1017))) ((lambda (tmp1019) ((lambda (tmp1020) (if tmp1020 (apply (lambda (_1021 x1022) (call-with-values (lambda () (gen-syntax920 e1018 x1022 r1014 (quote ()) ellipsis?159 mod1017)) (lambda (e1023 maps1024) (regen927 e1023)))) tmp1020) ((lambda (_1025) (syntax-violation (quote syntax) "bad `syntax' form" e1018)) tmp1019))) ($sc-dispatch tmp1019 (quote (any any))))) e1018))))) (global-extend112 (quote core) (quote lambda) (lambda (e1026 r1027 w1028 s1029 mod1030) ((lambda (tmp1031) ((lambda (tmp1032) (if tmp1032 (apply (lambda (_1033 c1034) (chi-lambda-clause155 (source-wrap143 e1026 w1028 s1029 mod1030) #f c1034 r1027 w1028 mod1030 (lambda (names1035 vars1036 docstring1037 body1038) (build-lambda90 s1029 names1035 vars1036 docstring1037 body1038)))) tmp1032) (syntax-violation #f "source expression failed to match any pattern" tmp1031))) ($sc-dispatch tmp1031 (quote (any . any))))) e1026))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1039 (lambda (e1040 r1041 w1042 s1043 mod1044 constructor1045 ids1046 vals1047 exps1048) (if (not (valid-bound-ids?139 ids1046)) (syntax-violation (quote let) "duplicate bound variable" e1040) (let ((labels1049 (gen-labels120 ids1046)) (new-vars1050 (map gen-var161 ids1046))) (let ((nw1051 (make-binding-wrap131 ids1046 labels1049 w1042)) (nr1052 (extend-var-env109 labels1049 new-vars1050 r1041))) (constructor1045 s1043 (map syntax->datum ids1046) new-vars1050 (map (lambda (x1053) (chi150 x1053 r1041 w1042 mod1044)) vals1047) (chi-body154 exps1048 (source-wrap143 e1040 nw1051 s1043 mod1044) nr1052 nw1051 mod1044)))))))) (lambda (e1054 r1055 w1056 s1057 mod1058) ((lambda (tmp1059) ((lambda (tmp1060) (if (if tmp1060 (apply (lambda (_1061 id1062 val1063 e11064 e21065) (and-map id?114 id1062)) tmp1060) #f) (apply (lambda (_1067 id1068 val1069 e11070 e21071) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-let94 id1068 val1069 (cons e11070 e21071))) tmp1060) ((lambda (tmp1075) (if (if tmp1075 (apply (lambda (_1076 f1077 id1078 val1079 e11080 e21081) (if (id?114 f1077) (and-map id?114 id1078) #f)) tmp1075) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-named-let95 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1075) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap143 e1054 w1056 s1057 mod1058))) tmp1059))) ($sc-dispatch tmp1059 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1059 (quote (any #(each (any any)) any . each-any))))) e1054)))) (global-extend112 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (and-map id?114 id1101)) tmp1099) #f) (apply (lambda (_1106 id1107 val1108 e11109 e21110) (let ((ids1111 id1107)) (if (not (valid-bound-ids?139 ids1111)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1113 (gen-labels120 ids1111)) (new-vars1114 (map gen-var161 ids1111))) (let ((w1115 (make-binding-wrap131 ids1111 labels1113 w1095)) (r1116 (extend-var-env109 labels1113 new-vars1114 r1094))) (build-letrec96 s1096 (map syntax->datum ids1111) new-vars1114 (map (lambda (x1117) (chi150 x1117 r1116 w1115 mod1097)) val1108) (chi-body154 (cons e11109 e21110) (source-wrap143 e1093 w1115 s1096 mod1097) r1116 w1115 mod1097))))))) tmp1099) ((lambda (_1120) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend112 (quote core) (quote set!) (lambda (e1121 r1122 w1123 s1124 mod1125) ((lambda (tmp1126) ((lambda (tmp1127) (if (if tmp1127 (apply (lambda (_1128 id1129 val1130) (id?114 id1129)) tmp1127) #f) (apply (lambda (_1131 id1132 val1133) (let ((val1134 (chi150 val1133 r1122 w1123 mod1125)) (n1135 (id-var-name136 id1132 w1123))) (let ((b1136 (lookup111 n1135 r1122 mod1125))) (let ((atom-key1137 (binding-type106 b1136))) (if (memv atom-key1137 (quote (lexical))) (build-lexical-assignment84 s1124 (syntax->datum id1132) (binding-value107 b1136) val1134) (if (memv atom-key1137 (quote (global))) (build-global-assignment87 s1124 n1135 val1134 mod1125) (if (memv atom-key1137 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1132 w1123 mod1125)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))))))))) tmp1127) ((lambda (tmp1138) (if tmp1138 (apply (lambda (_1139 head1140 tail1141 val1142) (call-with-values (lambda () (syntax-type148 head1140 r1122 (quote (())) #f #f mod1125 #t)) (lambda (type1143 value1144 ee1145 ww1146 ss1147 modmod1148) (if (memv type1143 (quote (module-ref))) (let ((val1149 (chi150 val1142 r1122 w1123 mod1125))) (call-with-values (lambda () (value1144 (cons head1140 tail1141))) (lambda (id1151 mod1152) (build-global-assignment87 s1124 id1151 val1149 mod1152)))) (build-application81 s1124 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1140) r1122 w1123 mod1125) (map (lambda (e1153) (chi150 e1153 r1122 w1123 mod1125)) (append tail1141 (list val1142)))))))) tmp1138) ((lambda (_1155) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))) tmp1126))) ($sc-dispatch tmp1126 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1126 (quote (any any any))))) e1121))) (global-extend112 (quote module-ref) (quote @) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (if (and-map id?114 mod1160) (id?114 id1161) #f)) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1167) ((lambda (tmp1168) ((lambda (tmp1169) (if (if tmp1169 (apply (lambda (_1170 mod1171 id1172) (if (and-map id?114 mod1171) (id?114 id1172) #f)) tmp1169) #f) (apply (lambda (_1174 mod1175 id1176) (values (syntax->datum id1176) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1175)))) tmp1169) (syntax-violation #f "source expression failed to match any pattern" tmp1168))) ($sc-dispatch tmp1168 (quote (any each-any any))))) e1167))) (global-extend112 (quote core) (quote if) (lambda (e1178 r1179 w1180 s1181 mod1182) ((lambda (tmp1183) ((lambda (tmp1184) (if tmp1184 (apply (lambda (_1185 test1186 then1187) (build-conditional82 s1181 (chi150 test1186 r1179 w1180 mod1182) (chi150 then1187 r1179 w1180 mod1182) (build-void80 #f))) tmp1184) ((lambda (tmp1188) (if tmp1188 (apply (lambda (_1189 test1190 then1191 else1192) (build-conditional82 s1181 (chi150 test1190 r1179 w1180 mod1182) (chi150 then1191 r1179 w1180 mod1182) (chi150 else1192 r1179 w1180 mod1182))) tmp1188) (syntax-violation #f "source expression failed to match any pattern" tmp1183))) ($sc-dispatch tmp1183 (quote (any any any any)))))) ($sc-dispatch tmp1183 (quote (any any any))))) e1178))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1196 (lambda (x1197 keys1198 clauses1199 r1200 mod1201) (if (null? clauses1199) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1197)) ((lambda (tmp1202) ((lambda (tmp1203) (if tmp1203 (apply (lambda (pat1204 exp1205) (if (if (id?114 pat1204) (and-map (lambda (x1206) (not (free-id=?137 pat1204 x1206))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1198)) #f) (let ((labels1207 (list (gen-label119))) (var1208 (gen-var161 pat1204))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1204)) (list var1208) #f (chi150 exp1205 (extend-env108 labels1207 (list (cons (quote syntax) (cons var1208 0))) r1200) (make-binding-wrap131 (list pat1204) labels1207 (quote (()))) mod1201)) (list x1197))) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1204 #t exp1205 mod1201))) tmp1203) ((lambda (tmp1209) (if tmp1209 (apply (lambda (pat1210 fender1211 exp1212) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1210 fender1211 exp1212 mod1201)) tmp1209) ((lambda (_1213) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1199))) tmp1202))) ($sc-dispatch tmp1202 (quote (any any any)))))) ($sc-dispatch tmp1202 (quote (any any))))) (car clauses1199))))) (gen-clause1195 (lambda (x1214 keys1215 clauses1216 r1217 pat1218 fender1219 exp1220 mod1221) (call-with-values (lambda () (convert-pattern1193 pat1218 keys1215)) (lambda (p1222 pvars1223) (if (not (distinct-bound-ids?140 (map car pvars1223))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1218) (if (not (and-map (lambda (x1224) (not (ellipsis?159 (car x1224)))) pvars1223)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1218) (let ((y1225 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1225) #f (let ((y1226 (build-lexical-reference83 (quote value) #f (quote tmp) y1225))) (build-conditional82 #f ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda () y1226) tmp1228) ((lambda (_1229) (build-conditional82 #f y1226 (build-dispatch-call1194 pvars1223 fender1219 y1226 r1217 mod1221) (build-data92 #f #f))) tmp1227))) ($sc-dispatch tmp1227 (quote #(atom #t))))) fender1219) (build-dispatch-call1194 pvars1223 exp1220 y1226 r1217 mod1221) (gen-syntax-case1196 x1214 keys1215 clauses1216 r1217 mod1221)))) (list (if (eq? p1222 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1214)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1214 (build-data92 #f p1222))))))))))))) (build-dispatch-call1194 (lambda (pvars1230 exp1231 y1232 r1233 mod1234) (let ((ids1235 (map car pvars1230)) (levels1236 (map cdr pvars1230))) (let ((labels1237 (gen-labels120 ids1235)) (new-vars1238 (map gen-var161 ids1235))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1235) new-vars1238 #f (chi150 exp1231 (extend-env108 labels1237 (map (lambda (var1239 level1240) (cons (quote syntax) (cons var1239 level1240))) new-vars1238 (map cdr pvars1230)) r1233) (make-binding-wrap131 ids1235 labels1237 (quote (()))) mod1234)) y1232)))))) (convert-pattern1193 (lambda (pattern1241 keys1242) (letrec ((cvt1243 (lambda (p1244 n1245 ids1246) (if (id?114 p1244) (if (bound-id-member?141 p1244 keys1242) (values (vector (quote free-id) p1244) ids1246) (values (quote any) (cons (cons p1244 n1245) ids1246))) ((lambda (tmp1247) ((lambda (tmp1248) (if (if tmp1248 (apply (lambda (x1249 dots1250) (ellipsis?159 dots1250)) tmp1248) #f) (apply (lambda (x1251 dots1252) (call-with-values (lambda () (cvt1243 x1251 (fx+72 n1245 1) ids1246)) (lambda (p1253 ids1254) (values (if (eq? p1253 (quote any)) (quote each-any) (vector (quote each) p1253)) ids1254)))) tmp1248) ((lambda (tmp1255) (if tmp1255 (apply (lambda (x1256 y1257) (call-with-values (lambda () (cvt1243 y1257 n1245 ids1246)) (lambda (y1258 ids1259) (call-with-values (lambda () (cvt1243 x1256 n1245 ids1259)) (lambda (x1260 ids1261) (values (cons x1260 y1258) ids1261)))))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda () (values (quote ()) ids1246)) tmp1262) ((lambda (tmp1263) (if tmp1263 (apply (lambda (x1264) (call-with-values (lambda () (cvt1243 x1264 n1245 ids1246)) (lambda (p1266 ids1267) (values (vector (quote vector) p1266) ids1267)))) tmp1263) ((lambda (x1268) (values (vector (quote atom) (strip160 p1244 (quote (())))) ids1246)) tmp1247))) ($sc-dispatch tmp1247 (quote #(vector each-any)))))) ($sc-dispatch tmp1247 (quote ()))))) ($sc-dispatch tmp1247 (quote (any . any)))))) ($sc-dispatch tmp1247 (quote (any any))))) p1244))))) (cvt1243 pattern1241 0 (quote ())))))) (lambda (e1269 r1270 w1271 s1272 mod1273) (let ((e1274 (source-wrap143 e1269 w1271 s1272 mod1273))) ((lambda (tmp1275) ((lambda (tmp1276) (if tmp1276 (apply (lambda (_1277 val1278 key1279 m1280) (if (and-map (lambda (x1281) (if (id?114 x1281) (not (ellipsis?159 x1281)) #f)) key1279) (let ((x1283 (gen-var161 (quote tmp)))) (build-application81 s1272 (build-lambda90 #f (list (quote tmp)) (list x1283) #f (gen-syntax-case1196 (build-lexical-reference83 (quote value) #f (quote tmp) x1283) key1279 m1280 r1270 mod1273)) (list (chi150 val1278 r1270 (quote (())) mod1273)))) (syntax-violation (quote syntax-case) "invalid literals list" e1274))) tmp1276) (syntax-violation #f "source expression failed to match any pattern" tmp1275))) ($sc-dispatch tmp1275 (quote (any any each-any . each-any))))) e1274))))) (set! sc-expand (lambda (x1287 . rest1286) (if (if (pair? x1287) (equal? (car x1287) noexpand70) #f) (cadr x1287) (let ((m1288 (if (null? rest1286) (quote e) (car rest1286))) (esew1289 (if (let ((t1290 (null? rest1286))) (if t1290 t1290 (null? (cdr rest1286)))) (quote (eval)) (cadr rest1286)))) (with-fluid* *mode*71 m1288 (lambda () (chi-top149 x1287 (quote ()) (quote ((top))) m1288 esew1289 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1291) (nonsymbol-id?113 x1291))) (set! datum->syntax (lambda (id1292 datum1293) (make-syntax-object97 datum1293 (syntax-object-wrap100 id1292) #f))) (set! syntax->datum (lambda (x1294) (strip160 x1294 (quote (()))))) (set! generate-temporaries (lambda (ls1295) (begin (let ((x1296 ls1295)) (if (not (list? x1296)) (syntax-violation (quote generate-temporaries) "invalid argument" x1296))) (map (lambda (x1297) (wrap142 (gensym) (quote ((top))) #f)) ls1295)))) (set! free-identifier=? (lambda (x1298 y1299) (begin (let ((x1300 x1298)) (if (not (nonsymbol-id?113 x1300)) (syntax-violation (quote free-identifier=?) "invalid argument" x1300))) (let ((x1301 y1299)) (if (not (nonsymbol-id?113 x1301)) (syntax-violation (quote free-identifier=?) "invalid argument" x1301))) (free-id=?137 x1298 y1299)))) (set! bound-identifier=? (lambda (x1302 y1303) (begin (let ((x1304 x1302)) (if (not (nonsymbol-id?113 x1304)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1304))) (let ((x1305 y1303)) (if (not (nonsymbol-id?113 x1305)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1305))) (bound-id=?138 x1302 y1303)))) (set! syntax-violation (lambda (who1309 message1308 form1307 . subform1306) (begin (let ((x1310 who1309)) (if (not ((lambda (x1311) (let ((t1312 (not x1311))) (if t1312 t1312 (let ((t1313 (string? x1311))) (if t1313 t1313 (symbol? x1311)))))) x1310)) (syntax-violation (quote syntax-violation) "invalid argument" x1310))) (let ((x1314 message1308)) (if (not (string? x1314)) (syntax-violation (quote syntax-violation) "invalid argument" x1314))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1309 "~a: " "") "~a " (if (null? subform1306) "in ~a" "in subform `~s' of `~s'")) (let ((tail1315 (cons message1308 (map (lambda (x1316) (strip160 x1316 (quote (())))) (append subform1306 (list form1307)))))) (if who1309 (cons who1309 tail1315) tail1315)) #f)))) (letrec ((match1321 (lambda (e1322 p1323 w1324 r1325 mod1326) (if (not r1325) #f (if (eq? p1323 (quote any)) (cons (wrap142 e1322 w1324 mod1326) r1325) (if (syntax-object?98 e1322) (match*1320 (syntax-object-expression99 e1322) p1323 (join-wraps133 w1324 (syntax-object-wrap100 e1322)) r1325 (syntax-object-module101 e1322)) (match*1320 e1322 p1323 w1324 r1325 mod1326)))))) (match*1320 (lambda (e1327 p1328 w1329 r1330 mod1331) (if (null? p1328) (if (null? e1327) r1330 #f) (if (pair? p1328) (if (pair? e1327) (match1321 (car e1327) (car p1328) w1329 (match1321 (cdr e1327) (cdr p1328) w1329 r1330 mod1331) mod1331) #f) (if (eq? p1328 (quote each-any)) (let ((l1332 (match-each-any1318 e1327 w1329 mod1331))) (if l1332 (cons l1332 r1330) #f)) (let ((atom-key1333 (vector-ref p1328 0))) (if (memv atom-key1333 (quote (each))) (if (null? e1327) (match-empty1319 (vector-ref p1328 1) r1330) (let ((l1334 (match-each1317 e1327 (vector-ref p1328 1) w1329 mod1331))) (if l1334 (letrec ((collect1335 (lambda (l1336) (if (null? (car l1336)) r1330 (cons (map car l1336) (collect1335 (map cdr l1336))))))) (collect1335 l1334)) #f))) (if (memv atom-key1333 (quote (free-id))) (if (id?114 e1327) (if (free-id=?137 (wrap142 e1327 w1329 mod1331) (vector-ref p1328 1)) r1330 #f) #f) (if (memv atom-key1333 (quote (atom))) (if (equal? (vector-ref p1328 1) (strip160 e1327 w1329)) r1330 #f) (if (memv atom-key1333 (quote (vector))) (if (vector? e1327) (match1321 (vector->list e1327) (vector-ref p1328 1) w1329 r1330 mod1331) #f))))))))))) (match-empty1319 (lambda (p1337 r1338) (if (null? p1337) r1338 (if (eq? p1337 (quote any)) (cons (quote ()) r1338) (if (pair? p1337) (match-empty1319 (car p1337) (match-empty1319 (cdr p1337) r1338)) (if (eq? p1337 (quote each-any)) (cons (quote ()) r1338) (let ((atom-key1339 (vector-ref p1337 0))) (if (memv atom-key1339 (quote (each))) (match-empty1319 (vector-ref p1337 1) r1338) (if (memv atom-key1339 (quote (free-id atom))) r1338 (if (memv atom-key1339 (quote (vector))) (match-empty1319 (vector-ref p1337 1) r1338))))))))))) (match-each-any1318 (lambda (e1340 w1341 mod1342) (if (pair? e1340) (let ((l1343 (match-each-any1318 (cdr e1340) w1341 mod1342))) (if l1343 (cons (wrap142 (car e1340) w1341 mod1342) l1343) #f)) (if (null? e1340) (quote ()) (if (syntax-object?98 e1340) (match-each-any1318 (syntax-object-expression99 e1340) (join-wraps133 w1341 (syntax-object-wrap100 e1340)) mod1342) #f))))) (match-each1317 (lambda (e1344 p1345 w1346 mod1347) (if (pair? e1344) (let ((first1348 (match1321 (car e1344) p1345 w1346 (quote ()) mod1347))) (if first1348 (let ((rest1349 (match-each1317 (cdr e1344) p1345 w1346 mod1347))) (if rest1349 (cons first1348 rest1349) #f)) #f)) (if (null? e1344) (quote ()) (if (syntax-object?98 e1344) (match-each1317 (syntax-object-expression99 e1344) p1345 (join-wraps133 w1346 (syntax-object-wrap100 e1344)) (syntax-object-module101 e1344)) #f)))))) (set! $sc-dispatch (lambda (e1350 p1351) (if (eq? p1351 (quote any)) (list e1350) (if (syntax-object?98 e1350) (match*1320 (syntax-object-expression99 e1350) p1351 (syntax-object-wrap100 e1350) (quote ()) (syntax-object-module101 e1350)) (match*1320 e1350 p1351 (quote (())) (quote ()) #f))))))))) (define with-syntax (make-syncase-macro (quote macro) (lambda (x1352) ((lambda (tmp1353) ((lambda (tmp1354) (if tmp1354 (apply (lambda (_1355 e11356 e21357) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11356 e21357))) tmp1354) ((lambda (tmp1359) (if tmp1359 (apply (lambda (_1360 out1361 in1362 e11363 e21364) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1362 (quote ()) (list out1361 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11363 e21364))))) tmp1359) ((lambda (tmp1366) (if tmp1366 (apply (lambda (_1367 out1368 in1369 e11370 e21371) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1369) (quote ()) (list out1368 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11370 e21371))))) tmp1366) (syntax-violation #f "source expression failed to match any pattern" tmp1353))) ($sc-dispatch tmp1353 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1353 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1353 (quote (any () any . each-any))))) x1352)))) (define syntax-rules (make-syncase-macro (quote macro) (lambda (x1375) ((lambda (tmp1376) ((lambda (tmp1377) (if tmp1377 (apply (lambda (_1378 k1379 keyword1380 pattern1381 template1382) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1379 (map (lambda (tmp1385 tmp1384) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1384) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1385))) template1382 pattern1381)))))) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1376))) ($sc-dispatch tmp1376 (quote (any each-any . #(each ((any . any) any))))))) x1375)))) (define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1386) ((lambda (tmp1387) ((lambda (tmp1388) (if (if tmp1388 (apply (lambda (let*1389 x1390 v1391 e11392 e21393) (and-map identifier? x1390)) tmp1388) #f) (apply (lambda (let*1395 x1396 v1397 e11398 e21399) (letrec ((f1400 (lambda (bindings1401) (if (null? bindings1401) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11398 e21399))) ((lambda (tmp1405) ((lambda (tmp1406) (if tmp1406 (apply (lambda (body1407 binding1408) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1408) body1407)) tmp1406) (syntax-violation #f "source expression failed to match any pattern" tmp1405))) ($sc-dispatch tmp1405 (quote (any any))))) (list (f1400 (cdr bindings1401)) (car bindings1401))))))) (f1400 (map list x1396 v1397)))) tmp1388) (syntax-violation #f "source expression failed to match any pattern" tmp1387))) ($sc-dispatch tmp1387 (quote (any #(each (any any)) any . each-any))))) x1386)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index f18b626e3..194c21150 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1178,6 +1178,9 @@ (type (binding-type (lookup n r mod)))) (case type ((global core macro module-ref) + ;; affect compile-time environment + (if (not (module-local-variable (current-module) n)) + (module-define! (current-module) n #f)) (eval-if-c&e m (build-global-definition s n (chi e r w mod)) mod)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 51bbfeae9..6ce538490 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -63,16 +63,17 @@ (lambda (x) (record-case x (( src name) - (and (hashq-ref *interesting-primitive-vars* - (module-variable mod name)) - (make-primitive-ref src name))) + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (lambda (name) (make-primitive-ref src name)))) (( src mod name public?) ;; for the moment, we're disabling primitive resolution for ;; public refs because resolve-interface can raise errors. (let ((m (and (not public?) (resolve-module mod)))) - (and m (hashq-ref *interesting-primitive-vars* - (module-variable m name)) - (make-primitive-ref src name)))) + (and m + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (lambda (name) (make-primitive-ref src name)))))) (else #f))) x)) From f4aa8d53a07168d15f737164c37da02056948d2b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 8 Jun 2009 00:38:49 +0200 Subject: [PATCH 203/375] call-with-values can make fewer closures * module/language/tree-il.scm: Rename let-exp and letrec-exp to let-body and letrec-body. Add , a one-expression let-values that should avoid the needless creation of two closures in many common multiple-value cases. We'll need to add an optimization pass to the compiler to produce this form, though, as well as rewriting lambdas into lets, etc. I added this form instead of adding more special cases to the call-with-values compile code because it's a useful intermediate form -- it will allow the optimizer to perform constant folding across more code. * module/language/tree-il.scm (parse-tree-il, unparse-tree-il) (tree-il->scheme, post-order!, pre-order!): Adapt to let/letrec body renaming, and let-values. * module/language/tree-il/analyze.scm (analyze-lexicals): Adapt for renaming, and add cases for let-values. * module/language/tree-il/compile-glil.scm (flatten): Add a new context, `vals', used by let-values code for the values producer. Code that produces multiple values can then jump to the let-values MV return address directly, instead of trampolining into a procedure. Add code to compile let-values. --- module/language/tree-il.scm | 235 +++++++++++------------ module/language/tree-il/analyze.scm | 52 +++-- module/language/tree-il/compile-glil.scm | 131 +++++++++---- 3 files changed, 245 insertions(+), 173 deletions(-) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 335031182..971892020 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -35,9 +35,10 @@ application? make-application application-src application-proc application-args sequence? make-sequence sequence-src sequence-exps lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body - let? make-let let-src let-names let-vars let-vals let-exp - letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp - + let? make-let let-src let-names let-vars let-vals let-body + letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body + let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body + parse-tree-il unparse-tree-il tree-il->scheme @@ -60,8 +61,9 @@ ( proc args) ( exps) ( names vars meta body) - ( names vars vals exp) - ( names vars vals exp)) + ( names vars vals body) + ( names vars vals body) + ( names vars exp body)) @@ -128,11 +130,14 @@ ((begin . ,exps) (make-sequence loc (map retrans exps))) - ((let ,names ,vars ,vals ,exp) - (make-let loc names vars (map retrans vals) (retrans exp))) + ((let ,names ,vars ,vals ,body) + (make-let loc names vars (map retrans vals) (retrans body))) - ((letrec ,names ,vars ,vals ,exp) - (make-letrec loc names vars (map retrans vals) (retrans exp))) + ((letrec ,names ,vars ,vals ,body) + (make-letrec loc names vars (map retrans vals) (retrans body))) + + ((let-values ,names ,vars ,exp ,body) + (make-let-values loc names vars (retrans exp) (retrans body))) (else (error "unrecognized tree-il" exp))))) @@ -181,140 +186,120 @@ (( exps) `(begin ,@(map unparse-tree-il exps))) - (( names vars vals exp) - `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))) + (( names vars vals body) + `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) - (( names vars vals exp) - `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))))) + (( names vars vals body) + `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + + (( names vars exp body) + `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) (define (tree-il->scheme e) - (cond ((list? e) - (map tree-il->scheme e)) - ((pair? e) - (cons (tree-il->scheme (car e)) - (tree-il->scheme (cdr e)))) - ((record? e) - (record-case e - (() - '(if #f #f)) + (record-case e + (() + '(if #f #f)) - (( proc args) - `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) + (( proc args) + `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) - (( test then else) - (if (void? else) - `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) - `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) + (( test then else) + (if (void? else) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) - (( name) - name) - - (( name gensym) - gensym) - - (( name gensym exp) - `(set! ,gensym ,(tree-il->scheme exp))) - - (( mod name public?) - `(,(if public? '@ '@@) ,mod ,name)) - - (( mod name public? exp) - `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) - - (( name) - name) - - (( name exp) - `(set! ,name ,(tree-il->scheme exp))) - - (( name exp) - `(define ,name ,(tree-il->scheme exp))) - - (( vars meta body) - `(lambda ,vars - ,@(cond ((assq-ref meta 'documentation) => list) (else '())) - ,(tree-il->scheme body))) - - (( exp) - (if (and (self-evaluating? exp) (not (vector? exp))) - exp - (list 'quote exp))) - - (( exps) - `(begin ,@(map tree-il->scheme exps))) - - (( vars vals exp) - `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))) - - (( vars vals exp) - `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))))) - (else e))) + (( name) + name) + + (( name gensym) + gensym) + + (( name gensym exp) + `(set! ,gensym ,(tree-il->scheme exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) + + (( name) + name) + + (( name exp) + `(set! ,name ,(tree-il->scheme exp))) + + (( name exp) + `(define ,name ,(tree-il->scheme exp))) + + (( vars meta body) + `(lambda ,vars + ,@(cond ((assq-ref meta 'documentation) => list) (else '())) + ,(tree-il->scheme body))) + + (( exp) + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))) + + (( exps) + `(begin ,@(map tree-il->scheme exps))) + + (( vars vals body) + `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + + (( vars vals body) + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + + (( vars exp body) + `(call-with-values (lambda () ,(tree-il->scheme exp)) + (lambda ,vars ,(tree-il->scheme body)))))) (define (post-order! f x) (let lp ((x x)) (record-case x - (() - (or (f x) x)) - (( proc args) (set! (application-proc x) (lp proc)) - (set! (application-args x) (map lp args)) - (or (f x) x)) + (set! (application-args x) (map lp args))) (( test then else) (set! (conditional-test x) (lp test)) (set! (conditional-then x) (lp then)) - (set! (conditional-else x) (lp else)) - (or (f x) x)) - - (( name) - (or (f x) x)) - - (( name gensym) - (or (f x) x)) - + (set! (conditional-else x) (lp else))) + (( name gensym exp) - (set! (lexical-set-exp x) (lp exp)) - (or (f x) x)) - - (( mod name public?) - (or (f x) x)) - + (set! (lexical-set-exp x) (lp exp))) + (( mod name public? exp) - (set! (module-set-exp x) (lp exp)) - (or (f x) x)) - - (( name) - (or (f x) x)) - + (set! (module-set-exp x) (lp exp))) + (( name exp) - (set! (toplevel-set-exp x) (lp exp)) - (or (f x) x)) - + (set! (toplevel-set-exp x) (lp exp))) + (( name exp) - (set! (toplevel-define-exp x) (lp exp)) - (or (f x) x)) - + (set! (toplevel-define-exp x) (lp exp))) + (( vars meta body) - (set! (lambda-body x) (lp body)) - (or (f x) x)) - - (( exp) - (or (f x) x)) - + (set! (lambda-body x) (lp body))) + (( exps) - (set! (sequence-exps x) (map lp exps)) - (or (f x) x)) - - (( vars vals exp) + (set! (sequence-exps x) (map lp exps))) + + (( vars vals body) (set! (let-vals x) (map lp vals)) - (set! (let-exp x) (lp exp)) - (or (f x) x)) - - (( vars vals exp) + (set! (let-body x) (lp body))) + + (( vars vals body) (set! (letrec-vals x) (map lp vals)) - (set! (letrec-exp x) (lp exp)) - (or (f x) x))))) + (set! (letrec-body x) (lp body))) + + (( vars exp body) + (set! (let-values-exp x) (lp exp)) + (set! (let-values-body x) (lp body))) + + (else #f)) + + (or (f x) x))) (define (pre-order! f x) (let lp ((x x)) @@ -347,13 +332,17 @@ (( exps) (set! (sequence-exps x) (map lp exps))) - (( vars vals exp) + (( vars vals body) (set! (let-vals x) (map lp vals)) - (set! (let-exp x) (lp exp))) + (set! (let-body x) (lp body))) - (( vars vals exp) + (( vars vals body) (set! (letrec-vals x) (map lp vals)) - (set! (letrec-exp x) (lp exp))) + (set! (letrec-body x) (lp body))) + + (( vars exp body) + (set! (let-values-exp x) (lp exp)) + (set! (let-values-body x) (lp body))) (else #f)) x))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 477f1fc2d..90843f75a 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -116,17 +116,26 @@ (recur body x) (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) - (( vars vals exp) + (( vars vals body) (for-each step vals) (hashq-set! bindings parent (append (reverse vars) (hashq-ref bindings parent))) - (step exp)) + (step body)) - (( vars vals exp) + (( vars vals body) (hashq-set! bindings parent (append (reverse vars) (hashq-ref bindings parent))) (for-each step vals) - (step exp)) + (step body)) + + (( vars exp body) + (hashq-set! bindings parent + (let lp ((out (hashq-ref bindings parent)) (in vars)) + (if (pair? in) + (lp (cons (car in) out) (cdr in)) + (if (null? in) out (cons in out))))) + (step exp) + (step body)) (else #f))) @@ -174,26 +183,26 @@ (lp (if (pair? vars) (cdr vars) '()) (1+ n))))) n) - (( vars vals exp) + (( vars vals body) (let ((nmax (apply max (map recur vals)))) (cond ;; the `or' hack - ((and (conditional? exp) + ((and (conditional? body) (= (length vars) 1) (let ((v (car vars))) (and (not (hashq-ref heaps v)) (= (hashq-ref refcounts v 0) 2) - (lexical-ref? (conditional-test exp)) - (eq? (lexical-ref-gensym (conditional-test exp)) v) - (lexical-ref? (conditional-then exp)) - (eq? (lexical-ref-gensym (conditional-then exp)) v)))) + (lexical-ref? (conditional-test body)) + (eq? (lexical-ref-gensym (conditional-test body)) v) + (lexical-ref? (conditional-then body)) + (eq? (lexical-ref-gensym (conditional-then body)) v)))) (hashq-set! allocation (car vars) (cons 'stack n)) ;; the 1+ for this var - (max nmax (1+ n) (allocate! (conditional-else exp) level n))) + (max nmax (1+ n) (allocate! (conditional-else body) level n))) (else (let lp ((vars vars) (n n)) (if (null? vars) - (max nmax (allocate! exp level n)) + (max nmax (allocate! body level n)) (let ((v (car vars))) (let ((binder (hashq-ref heaps v))) (hashq-set! @@ -203,14 +212,14 @@ (cons 'stack n))) (lp (cdr vars) (if binder n (1+ n))))))))))) - (( vars vals exp) + (( vars vals body) (let lp ((vars vars) (n n)) (if (null? vars) (let ((nmax (apply max (map (lambda (x) (allocate! x level n)) vals)))) - (max nmax (allocate! exp level n))) + (max nmax (allocate! body level n))) (let ((v (car vars))) (let ((binder (hashq-ref heaps v))) (hashq-set! @@ -220,6 +229,21 @@ (cons 'stack n))) (lp (cdr vars) (if binder n (1+ n)))))))) + (( vars exp body) + (let ((nmax (recur exp))) + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! body level n)) + (let ((v (if (pair? vars) (car vars) vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n))) + (lp (if (pair? vars) (cdr vars) '()) + (if binder n (1+ n))))))))) + (else n))) (define parents (make-hash-table)) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 94ace7e53..78a841dd2 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -150,22 +150,24 @@ (define (emit-branch src inst label) (emit-code src (make-glil-branch inst label))) - (let comp ((x x) (context 'tail)) - (define (comp-tail tree) (comp tree context)) - (define (comp-push tree) (comp tree 'push)) - (define (comp-drop tree) (comp tree 'drop)) + ;; LMVRA == "let-values MV return address" + (let comp ((x x) (context 'tail) (LMVRA #f)) + (define (comp-tail tree) (comp tree context LMVRA)) + (define (comp-push tree) (comp tree 'push #f)) + (define (comp-drop tree) (comp tree 'drop #f)) + (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA)) (record-case x (() (case context - ((push) (emit-code #f (make-glil-void))) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) (emit-code #f (make-glil-call 'return 1))))) (( src exp) (case context - ((push) (emit-code src (make-glil-const exp))) + ((push vals) (emit-code src (make-glil-const exp))) ((tail) (emit-code src (make-glil-const exp)) (emit-code #f (make-glil-call 'return 1))))) @@ -189,7 +191,7 @@ (args (cdr args))) (cond ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) - (not (eq? context 'push))) + (not (eq? context 'push)) (not (eq? context 'vals))) ;; tail: (lambda () (apply values '(1 2))) ;; drop: (lambda () (apply values '(1 2)) 3) ;; push: (lambda () (list (apply values '(10 12)) 1)) @@ -209,6 +211,11 @@ (comp-push proc) (for-each comp-push args) (emit-code src (make-glil-call 'apply (1+ (length args))))) + ((vals) + (comp-vals + (make-application src (make-primitive-ref #f 'apply) + (cons proc args)) + LMVRA)) ((drop) ;; Well, shit. The proc might return any number of ;; values (including 0), since it's in a drop context, @@ -223,11 +230,17 @@ ;; tail: (lambda () (values '(1 2))) ;; drop: (lambda () (values '(1 2)) 3) ;; push: (lambda () (list (values '(10 12)) 1)) + ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) (case context ((drop) (for-each comp-drop args)) + ((vals) + (for-each comp-push args) + (emit-code #f (make-glil-const (length args))) + (emit-branch src 'br LMVRA)) ((tail) (for-each comp-push args) (emit-code src (make-glil-call 'return/values (length args)))))) + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-values) (= (length args) 2)) @@ -238,22 +251,30 @@ ;; goto POST ;; MV: [tail-]call/nargs ;; POST: (maybe-drop) - (let ((MV (make-label)) (POST (make-label)) - (producer (car args)) (consumer (cadr args))) - (comp-push consumer) - (comp-push producer) - (emit-code src (make-glil-mv-call 0 MV)) - (case context - ((tail) (emit-code src (make-glil-call 'goto/args 1))) - (else (emit-code src (make-glil-call 'call 1)) - (emit-branch #f 'br POST))) - (emit-label MV) - (case context - ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) - (else (emit-code src (make-glil-call 'call/nargs 0)) - (emit-label POST) - (if (eq? context 'drop) - (emit-code #f (make-glil-call 'drop 1))))))) + (case context + ((vals) + ;; Fall back. + (comp-vals + (make-application src (make-primitive-ref #f 'call-with-values) + args) + LMVRA)) + (else + (let ((MV (make-label)) (POST (make-label)) + (producer (car args)) (consumer (cadr args))) + (comp-push consumer) + (comp-push producer) + (emit-code src (make-glil-mv-call 0 MV)) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args 1))) + (else (emit-code src (make-glil-call 'call 1)) + (emit-branch #f 'br POST))) + (emit-label MV) + (case context + ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) + (else (emit-code src (make-glil-call 'call/nargs 0)) + (emit-label POST) + (if (eq? context 'drop) + (emit-code #f (make-glil-call 'drop 1))))))))) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-current-continuation) @@ -262,6 +283,12 @@ ((tail) (comp-push (car args)) (emit-code src (make-glil-call 'goto/cc 1))) + ((vals) + (comp-vals + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args) + LMVRA)) ((push) (comp-push (car args)) (emit-code src (make-glil-call 'call/cc 1))) @@ -282,6 +309,7 @@ (case context ((tail) (emit-code #f (make-glil-call 'return 1))) ((drop) (emit-code #f (make-glil-call 'drop 1)))))) + (else (comp-push proc) (for-each comp-push args) @@ -289,6 +317,7 @@ (case context ((tail) (emit-code src (make-glil-call 'goto/args len))) ((push) (emit-code src (make-glil-call 'call len))) + ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA))) ((drop) (let ((MV (make-label)) (POST (make-label))) (emit-code src (make-glil-mv-call len MV)) @@ -322,7 +351,7 @@ ((eq? (module-variable (fluid-ref *comp-module*) name) (module-variable the-root-module name)) (case context - ((push) + ((push vals) (emit-code src (make-glil-toplevel 'ref name))) ((tail) (emit-code src (make-glil-toplevel 'ref name)) @@ -330,7 +359,7 @@ (else (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) (case context - ((push) + ((push vals) (emit-code src (make-glil-module 'ref '(guile) name #f))) ((tail) (emit-code src (make-glil-module 'ref '(guile) name #f)) @@ -338,7 +367,7 @@ (( src name gensym) (case context - ((push tail) + ((push vals tail) (let ((loc (hashq-ref allocation gensym))) (case (car loc) ((stack) @@ -361,7 +390,7 @@ 'set (- level (cadr loc)) (cddr loc)))) (else (error "badness" x loc)))) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -377,7 +406,7 @@ (comp-push exp) (emit-code src (make-glil-module 'set mod name public?)) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -393,7 +422,7 @@ (comp-push exp) (emit-code src (make-glil-toplevel 'set name)) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -403,7 +432,7 @@ (comp-push exp) (emit-code src (make-glil-toplevel 'define name)) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -411,13 +440,13 @@ (() (case context - ((push) + ((push vals) (emit-code #f (flatten-lambda x level allocation))) ((tail) (emit-code #f (flatten-lambda x level allocation)) (emit-code #f (make-glil-call 'return 1))))) - (( src names vars vals exp) + (( src names vars vals body) (for-each comp-push vals) (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) @@ -429,10 +458,10 @@ (emit-code src (make-glil-external 'set 0 (cddr loc)))) (else (error "badness" x loc))))) (reverse vars)) - (comp-tail exp) + (comp-tail body) (emit-code #f (make-glil-unbind))) - (( src names vars vals exp) + (( src names vars vals body) (for-each comp-push vals) (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) @@ -444,5 +473,35 @@ (emit-code src (make-glil-external 'set 0 (cddr loc)))) (else (error "badness" x loc))))) (reverse vars)) - (comp-tail exp) - (emit-code #f (make-glil-unbind)))))) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + + (( src names vars exp body) + (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) + (cond + ((pair? inames) + (lp (cons (car inames) names) (cons (car ivars) vars) + (cdr inames) (cdr ivars) #f)) + ((not (null? inames)) + (lp (cons inames names) (cons ivars vars) '() '() #t)) + (else + (let ((names (reverse! names)) + (vars (reverse! vars)) + (MV (make-label))) + (comp-vals exp MV) + (emit-code #f (make-glil-const 1)) + (emit-label MV) + (emit-code src (make-glil-mv-bind + (vars->bind-list names vars allocation) + rest?)) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind)))))))))) From 55dce020bdde1ffc690a0e91fab7d0f5713195b4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 8 Jun 2009 01:04:16 +0200 Subject: [PATCH 204/375] fix bootstrapping after last night's psyntax patch * module/Makefile.am (ice-9/psyntax-pp.scm): Don't try autocompiling when making psyntax-pp.scm. * module/ice-9/psyntax-pp.scm: Regenerated. * module/ice-9/psyntax.scm (chi-top): Only affect the compile-time environment if modules have booted. --- module/Makefile.am | 2 +- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 5 +++-- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/module/Makefile.am b/module/Makefile.am index bcc4864e5..ca7785212 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -62,7 +62,7 @@ EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008 # GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm include $(top_srcdir)/am/pre-inst-guile ice-9/psyntax-pp.scm: ice-9/psyntax.scm - $(preinstguile) -s $(srcdir)/ice-9/compile-psyntax.scm \ + $(preinstguile) --no-autocompile -s $(srcdir)/ice-9/compile-psyntax.scm \ $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm SCHEME_LANG_SOURCES = \ diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 267d54dd5..3a4dfde38 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (let ((t58 (null? first56))) (if t58 t58 (if (null? rest55) (letrec ((andmap59 (lambda (first60) (let ((x61 (car first60)) (first62 (cdr first60))) (if (null? first62) (f57 x61) (if (f57 x61) (andmap59 first62) #f)))))) (andmap59 first56)) (letrec ((andmap63 (lambda (first64 rest65) (let ((x66 (car first64)) (xr67 (map car rest65)) (first68 (cdr first64)) (rest69 (map cdr rest65))) (if (null? first68) (apply f57 (cons x66 xr67)) (if (apply f57 (cons x66 xr67)) (andmap63 first68 rest69) #f)))))) (andmap63 first56 rest55)))))))) (letrec ((lambda-var-list162 (lambda (vars286) (letrec ((lvl287 (lambda (vars288 ls289 w290) (if (pair? vars288) (lvl287 (cdr vars288) (cons (wrap142 (car vars288) w290 #f) ls289) w290) (if (id?114 vars288) (cons (wrap142 vars288 w290 #f) ls289) (if (null? vars288) ls289 (if (syntax-object?98 vars288) (lvl287 (syntax-object-expression99 vars288) ls289 (join-wraps133 w290 (syntax-object-wrap100 vars288))) (cons vars288 ls289)))))))) (lvl287 vars286 (quote ()) (quote (())))))) (gen-var161 (lambda (id291) (let ((id292 (if (syntax-object?98 id291) (syntax-object-expression99 id291) id291))) (gensym (symbol->string id292))))) (strip160 (lambda (x293 w294) (if (memq (quote top) (wrap-marks117 w294)) x293 (letrec ((f295 (lambda (x296) (if (syntax-object?98 x296) (strip160 (syntax-object-expression99 x296) (syntax-object-wrap100 x296)) (if (pair? x296) (let ((a297 (f295 (car x296))) (d298 (f295 (cdr x296)))) (if (if (eq? a297 (car x296)) (eq? d298 (cdr x296)) #f) x296 (cons a297 d298))) (if (vector? x296) (let ((old299 (vector->list x296))) (let ((new300 (map f295 old299))) (if (and-map*17 eq? old299 new300) x296 (list->vector new300)))) x296)))))) (f295 x293))))) (ellipsis?159 (lambda (x301) (if (nonsymbol-id?113 x301) (free-id=?137 x301 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void158 (lambda () (build-void80 #f))) (eval-local-transformer157 (lambda (expanded302 mod303) (let ((p304 (local-eval-hook77 expanded302 mod303))) (if (procedure? p304) p304 (syntax-violation #f "nonprocedure transformer" p304))))) (chi-local-syntax156 (lambda (rec?305 e306 r307 w308 s309 mod310 k311) ((lambda (tmp312) ((lambda (tmp313) (if tmp313 (apply (lambda (_314 id315 val316 e1317 e2318) (let ((ids319 id315)) (if (not (valid-bound-ids?139 ids319)) (syntax-violation #f "duplicate bound keyword" e306) (let ((labels321 (gen-labels120 ids319))) (let ((new-w322 (make-binding-wrap131 ids319 labels321 w308))) (k311 (cons e1317 e2318) (extend-env108 labels321 (let ((w324 (if rec?305 new-w322 w308)) (trans-r325 (macros-only-env110 r307))) (map (lambda (x326) (cons (quote macro) (eval-local-transformer157 (chi150 x326 trans-r325 w324 mod310) mod310))) val316)) r307) new-w322 s309 mod310)))))) tmp313) ((lambda (_328) (syntax-violation #f "bad local syntax definition" (source-wrap143 e306 w308 s309 mod310))) tmp312))) ($sc-dispatch tmp312 (quote (any #(each (any any)) any . each-any))))) e306))) (chi-lambda-clause155 (lambda (e329 docstring330 c331 r332 w333 mod334 k335) ((lambda (tmp336) ((lambda (tmp337) (if (if tmp337 (apply (lambda (args338 doc339 e1340 e2341) (if (string? (syntax->datum doc339)) (not docstring330) #f)) tmp337) #f) (apply (lambda (args342 doc343 e1344 e2345) (chi-lambda-clause155 e329 doc343 (cons args342 (cons e1344 e2345)) r332 w333 mod334 k335)) tmp337) ((lambda (tmp347) (if tmp347 (apply (lambda (id348 e1349 e2350) (let ((ids351 id348)) (if (not (valid-bound-ids?139 ids351)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels353 (gen-labels120 ids351)) (new-vars354 (map gen-var161 ids351))) (k335 (map syntax->datum ids351) new-vars354 (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1349 e2350) e329 (extend-var-env109 labels353 new-vars354 r332) (make-binding-wrap131 ids351 labels353 w333) mod334)))))) tmp347) ((lambda (tmp356) (if tmp356 (apply (lambda (ids357 e1358 e2359) (let ((old-ids360 (lambda-var-list162 ids357))) (if (not (valid-bound-ids?139 old-ids360)) (syntax-violation (quote lambda) "invalid parameter list" e329) (let ((labels361 (gen-labels120 old-ids360)) (new-vars362 (map gen-var161 old-ids360))) (k335 (letrec ((f363 (lambda (ls1364 ls2365) (if (null? ls1364) (syntax->datum ls2365) (f363 (cdr ls1364) (cons (syntax->datum (car ls1364)) ls2365)))))) (f363 (cdr old-ids360) (car old-ids360))) (letrec ((f366 (lambda (ls1367 ls2368) (if (null? ls1367) ls2368 (f366 (cdr ls1367) (cons (car ls1367) ls2368)))))) (f366 (cdr new-vars362) (car new-vars362))) (if docstring330 (syntax->datum docstring330) #f) (chi-body154 (cons e1358 e2359) e329 (extend-var-env109 labels361 new-vars362 r332) (make-binding-wrap131 old-ids360 labels361 w333) mod334)))))) tmp356) ((lambda (_370) (syntax-violation (quote lambda) "bad lambda" e329)) tmp336))) ($sc-dispatch tmp336 (quote (any any . each-any)))))) ($sc-dispatch tmp336 (quote (each-any any . each-any)))))) ($sc-dispatch tmp336 (quote (any any any . each-any))))) c331))) (chi-body154 (lambda (body371 outer-form372 r373 w374 mod375) (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) (let ((ribcage377 (make-ribcage121 (quote ()) (quote ()) (quote ())))) (let ((w378 (make-wrap116 (wrap-marks117 w374) (cons ribcage377 (wrap-subst118 w374))))) (letrec ((parse379 (lambda (body380 ids381 labels382 var-ids383 vars384 vals385 bindings386) (if (null? body380) (syntax-violation #f "no expressions in body" outer-form372) (let ((e388 (cdar body380)) (er389 (caar body380))) (call-with-values (lambda () (syntax-type148 e388 er389 (quote (())) (source-annotation105 er389) ribcage377 mod375 #f)) (lambda (type390 value391 e392 w393 s394 mod395) (if (memv type390 (quote (define-form))) (let ((id396 (wrap142 value391 w393 mod395)) (label397 (gen-label119))) (let ((var398 (gen-var161 id396))) (begin (extend-ribcage!130 ribcage377 id396 label397) (parse379 (cdr body380) (cons id396 ids381) (cons label397 labels382) (cons id396 var-ids383) (cons var398 vars384) (cons (cons er389 (wrap142 e392 w393 mod395)) vals385) (cons (cons (quote lexical) var398) bindings386))))) (if (memv type390 (quote (define-syntax-form))) (let ((id399 (wrap142 value391 w393 mod395)) (label400 (gen-label119))) (begin (extend-ribcage!130 ribcage377 id399 label400) (parse379 (cdr body380) (cons id399 ids381) (cons label400 labels382) var-ids383 vars384 vals385 (cons (cons (quote macro) (cons er389 (wrap142 e392 w393 mod395))) bindings386)))) (if (memv type390 (quote (begin-form))) ((lambda (tmp401) ((lambda (tmp402) (if tmp402 (apply (lambda (_403 e1404) (parse379 (letrec ((f405 (lambda (forms406) (if (null? forms406) (cdr body380) (cons (cons er389 (wrap142 (car forms406) w393 mod395)) (f405 (cdr forms406))))))) (f405 e1404)) ids381 labels382 var-ids383 vars384 vals385 bindings386)) tmp402) (syntax-violation #f "source expression failed to match any pattern" tmp401))) ($sc-dispatch tmp401 (quote (any . each-any))))) e392) (if (memv type390 (quote (local-syntax-form))) (chi-local-syntax156 value391 e392 er389 w393 s394 mod395 (lambda (forms408 er409 w410 s411 mod412) (parse379 (letrec ((f413 (lambda (forms414) (if (null? forms414) (cdr body380) (cons (cons er409 (wrap142 (car forms414) w410 mod412)) (f413 (cdr forms414))))))) (f413 forms408)) ids381 labels382 var-ids383 vars384 vals385 bindings386))) (if (null? ids381) (build-sequence93 #f (map (lambda (x415) (chi150 (cdr x415) (car x415) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))) (begin (if (not (valid-bound-ids?139 ids381)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form372)) (letrec ((loop416 (lambda (bs417 er-cache418 r-cache419) (if (not (null? bs417)) (let ((b420 (car bs417))) (if (eq? (car b420) (quote macro)) (let ((er421 (cadr b420))) (let ((r-cache422 (if (eq? er421 er-cache418) r-cache419 (macros-only-env110 er421)))) (begin (set-cdr! b420 (eval-local-transformer157 (chi150 (cddr b420) r-cache422 (quote (())) mod395) mod395)) (loop416 (cdr bs417) er421 r-cache422)))) (loop416 (cdr bs417) er-cache418 r-cache419))))))) (loop416 bindings386 #f #f)) (set-cdr! r376 (extend-env108 labels382 bindings386 (cdr r376))) (build-letrec96 #f (map syntax->datum var-ids383) vars384 (map (lambda (x423) (chi150 (cdr x423) (car x423) (quote (())) mod395)) vals385) (build-sequence93 #f (map (lambda (x424) (chi150 (cdr x424) (car x424) (quote (())) mod395)) (cons (cons er389 (source-wrap143 e392 w393 s394 mod395)) (cdr body380)))))))))))))))))) (parse379 (map (lambda (x387) (cons r376 (wrap142 x387 w378 mod375))) body371) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro153 (lambda (p425 e426 r427 w428 rib429 mod430) (letrec ((rebuild-macro-output431 (lambda (x432 m433) (if (pair? x432) (cons (rebuild-macro-output431 (car x432) m433) (rebuild-macro-output431 (cdr x432) m433)) (if (syntax-object?98 x432) (let ((w434 (syntax-object-wrap100 x432))) (let ((ms435 (wrap-marks117 w434)) (s436 (wrap-subst118 w434))) (if (if (pair? ms435) (eq? (car ms435) #f) #f) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cdr ms435) (if rib429 (cons rib429 (cdr s436)) (cdr s436))) (syntax-object-module101 x432)) (make-syntax-object97 (syntax-object-expression99 x432) (make-wrap116 (cons m433 ms435) (if rib429 (cons rib429 (cons (quote shift) s436)) (cons (quote shift) s436))) (let ((pmod437 (procedure-module p425))) (if pmod437 (cons (quote hygiene) (module-name pmod437)) (quote (hygiene guile)))))))) (if (vector? x432) (let ((n438 (vector-length x432))) (let ((v439 (make-vector n438))) (letrec ((loop440 (lambda (i441) (if (fx=74 i441 n438) (begin (if #f #f) v439) (begin (vector-set! v439 i441 (rebuild-macro-output431 (vector-ref x432 i441) m433)) (loop440 (fx+72 i441 1))))))) (loop440 0)))) (if (symbol? x432) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap143 e426 w428 s mod430) x432) x432))))))) (rebuild-macro-output431 (p425 (wrap142 e426 (anti-mark129 w428) mod430)) (string #\m))))) (chi-application152 (lambda (x442 e443 r444 w445 s446 mod447) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (e0450 e1451) (build-application81 s446 x442 (map (lambda (e452) (chi150 e452 r444 w445 mod447)) e1451))) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e443))) (chi-expr151 (lambda (type454 value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (lexical))) (build-lexical-reference83 (quote value) s459 e456 value455) (if (memv type454 (quote (core core-form))) (value455 e456 r457 w458 s459 mod460) (if (memv type454 (quote (module-ref))) (call-with-values (lambda () (value455 e456)) (lambda (id461 mod462) (build-global-reference86 s459 id461 mod462))) (if (memv type454 (quote (lexical-call))) (chi-application152 (build-lexical-reference83 (quote fun) (source-annotation105 (car e456)) (car e456) value455) e456 r457 w458 s459 mod460) (if (memv type454 (quote (global-call))) (chi-application152 (build-global-reference86 (source-annotation105 (car e456)) (if (syntax-object?98 value455) (syntax-object-expression99 value455) value455) (if (syntax-object?98 value455) (syntax-object-module101 value455) mod460)) e456 r457 w458 s459 mod460) (if (memv type454 (quote (constant))) (build-data92 s459 (strip160 (source-wrap143 e456 w458 s459 mod460) (quote (())))) (if (memv type454 (quote (global))) (build-global-reference86 s459 value455 mod460) (if (memv type454 (quote (call))) (chi-application152 (chi150 (car e456) r457 w458 mod460) e456 r457 w458 s459 mod460) (if (memv type454 (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466 e2467) (chi-sequence144 (cons e1466 e2467) r457 w458 s459 mod460)) tmp464) (syntax-violation #f "source expression failed to match any pattern" tmp463))) ($sc-dispatch tmp463 (quote (any any . each-any))))) e456) (if (memv type454 (quote (local-syntax-form))) (chi-local-syntax156 value455 e456 r457 w458 s459 mod460 chi-sequence144) (if (memv type454 (quote (eval-when-form))) ((lambda (tmp469) ((lambda (tmp470) (if tmp470 (apply (lambda (_471 x472 e1473 e2474) (let ((when-list475 (chi-when-list147 e456 x472 w458))) (if (memq (quote eval) when-list475) (chi-sequence144 (cons e1473 e2474) r457 w458 s459 mod460) (chi-void158)))) tmp470) (syntax-violation #f "source expression failed to match any pattern" tmp469))) ($sc-dispatch tmp469 (quote (any each-any any . each-any))))) e456) (if (memv type454 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e456 (wrap142 value455 w458 mod460)) (if (memv type454 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap143 e456 w458 s459 mod460)) (if (memv type454 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap143 e456 w458 s459 mod460)) (syntax-violation #f "unexpected syntax" (source-wrap143 e456 w458 s459 mod460)))))))))))))))))) (chi150 (lambda (e478 r479 w480 mod481) (call-with-values (lambda () (syntax-type148 e478 r479 w480 (source-annotation105 e478) #f mod481 #f)) (lambda (type482 value483 e484 w485 s486 mod487) (chi-expr151 type482 value483 e484 r479 w485 s486 mod487))))) (chi-top149 (lambda (e488 r489 w490 m491 esew492 mod493) (call-with-values (lambda () (syntax-type148 e488 r489 w490 (source-annotation105 e488) #f mod493 #f)) (lambda (type501 value502 e503 w504 s505 mod506) (if (memv type501 (quote (begin-form))) ((lambda (tmp507) ((lambda (tmp508) (if tmp508 (apply (lambda (_509) (chi-void158)) tmp508) ((lambda (tmp510) (if tmp510 (apply (lambda (_511 e1512 e2513) (chi-top-sequence145 (cons e1512 e2513) r489 w504 s505 m491 esew492 mod506)) tmp510) (syntax-violation #f "source expression failed to match any pattern" tmp507))) ($sc-dispatch tmp507 (quote (any any . each-any)))))) ($sc-dispatch tmp507 (quote (any))))) e503) (if (memv type501 (quote (local-syntax-form))) (chi-local-syntax156 value502 e503 r489 w504 s505 mod506 (lambda (body515 r516 w517 s518 mod519) (chi-top-sequence145 body515 r516 w517 s518 m491 esew492 mod519))) (if (memv type501 (quote (eval-when-form))) ((lambda (tmp520) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 x523 e1524 e2525) (let ((when-list526 (chi-when-list147 e503 x523 w504)) (body527 (cons e1524 e2525))) (if (eq? m491 (quote e)) (if (memq (quote eval) when-list526) (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) (chi-void158)) (if (memq (quote load) when-list526) (if (let ((t530 (memq (quote compile) when-list526))) (if t530 t530 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (chi-top-sequence145 body527 r489 w504 s505 (quote c&e) (quote (compile load)) mod506) (if (memq m491 (quote (c c&e))) (chi-top-sequence145 body527 r489 w504 s505 (quote c) (quote (load)) mod506) (chi-void158))) (if (let ((t531 (memq (quote compile) when-list526))) (if t531 t531 (if (eq? m491 (quote c&e)) (memq (quote eval) when-list526) #f))) (begin (top-level-eval-hook76 (chi-top-sequence145 body527 r489 w504 s505 (quote e) (quote (eval)) mod506) mod506) (chi-void158)) (chi-void158)))))) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp520))) ($sc-dispatch tmp520 (quote (any each-any any . each-any))))) e503) (if (memv type501 (quote (define-syntax-form))) (let ((n532 (id-var-name136 value502 w504)) (r533 (macros-only-env110 r489))) (if (memv m491 (quote (c))) (if (memq (quote compile) esew492) (let ((e534 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e534 mod506) (if (memq (quote load) esew492) e534 (chi-void158)))) (if (memq (quote load) esew492) (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) (chi-void158))) (if (memv m491 (quote (c&e))) (let ((e535 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)))) (begin (top-level-eval-hook76 e535 mod506) e535)) (begin (if (memq (quote eval) esew492) (top-level-eval-hook76 (chi-install-global146 n532 (chi150 e503 r533 w504 mod506)) mod506)) (chi-void158))))) (if (memv type501 (quote (define-form))) (let ((n536 (id-var-name136 value502 w504))) (let ((type537 (binding-type106 (lookup111 n536 r489 mod506)))) (if (memv type537 (quote (global core macro module-ref))) (begin (if (not (module-local-variable (current-module) n536)) (module-define! (current-module) n536 #f)) (let ((x538 (build-global-definition89 s505 n536 (chi150 e503 r489 w504 mod506)))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x538 mod506)) x538))) (if (memv type537 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e503 (wrap142 value502 w504 mod506)) (syntax-violation #f "cannot define keyword at top level" e503 (wrap142 value502 w504 mod506)))))) (let ((x539 (chi-expr151 type501 value502 e503 r489 w504 s505 mod506))) (begin (if (eq? m491 (quote c&e)) (top-level-eval-hook76 x539 mod506)) x539))))))))))) (syntax-type148 (lambda (e540 r541 w542 s543 rib544 mod545 for-car?546) (if (symbol? e540) (let ((n547 (id-var-name136 e540 w542))) (let ((b548 (lookup111 n547 r541 mod545))) (let ((type549 (binding-type106 b548))) (if (memv type549 (quote (lexical))) (values type549 (binding-value107 b548) e540 w542 s543 mod545) (if (memv type549 (quote (global))) (values type549 n547 e540 w542 s543 mod545) (if (memv type549 (quote (macro))) (if for-car?546 (values type549 (binding-value107 b548) e540 w542 s543 mod545) (syntax-type148 (chi-macro153 (binding-value107 b548) e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 #f)) (values type549 (binding-value107 b548) e540 w542 s543 mod545))))))) (if (pair? e540) (let ((first550 (car e540))) (call-with-values (lambda () (syntax-type148 first550 r541 w542 s543 rib544 mod545 #t)) (lambda (ftype551 fval552 fe553 fw554 fs555 fmod556) (if (memv ftype551 (quote (lexical))) (values (quote lexical-call) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (global))) (values (quote global-call) (make-syntax-object97 fval552 w542 fmod556) e540 w542 s543 mod545) (if (memv ftype551 (quote (macro))) (syntax-type148 (chi-macro153 fval552 e540 r541 w542 rib544 mod545) r541 (quote (())) s543 rib544 mod545 for-car?546) (if (memv ftype551 (quote (module-ref))) (call-with-values (lambda () (fval552 e540)) (lambda (sym557 mod558) (syntax-type148 sym557 r541 w542 s543 rib544 mod558 for-car?546))) (if (memv ftype551 (quote (core))) (values (quote core-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (local-syntax))) (values (quote local-syntax-form) fval552 e540 w542 s543 mod545) (if (memv ftype551 (quote (begin))) (values (quote begin-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (eval-when))) (values (quote eval-when-form) #f e540 w542 s543 mod545) (if (memv ftype551 (quote (define))) ((lambda (tmp559) ((lambda (tmp560) (if (if tmp560 (apply (lambda (_561 name562 val563) (id?114 name562)) tmp560) #f) (apply (lambda (_564 name565 val566) (values (quote define-form) name565 val566 w542 s543 mod545)) tmp560) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 args570 e1571 e2572) (if (id?114 name569) (valid-bound-ids?139 (lambda-var-list162 args570)) #f)) tmp567) #f) (apply (lambda (_573 name574 args575 e1576 e2577) (values (quote define-form) (wrap142 name574 w542 mod545) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap142 (cons args575 (cons e1576 e2577)) w542 mod545)) (quote (())) s543 mod545)) tmp567) ((lambda (tmp579) (if (if tmp579 (apply (lambda (_580 name581) (id?114 name581)) tmp579) #f) (apply (lambda (_582 name583) (values (quote define-form) (wrap142 name583 w542 mod545) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s543 mod545)) tmp579) (syntax-violation #f "source expression failed to match any pattern" tmp559))) ($sc-dispatch tmp559 (quote (any any)))))) ($sc-dispatch tmp559 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp559 (quote (any any any))))) e540) (if (memv ftype551 (quote (define-syntax))) ((lambda (tmp584) ((lambda (tmp585) (if (if tmp585 (apply (lambda (_586 name587 val588) (id?114 name587)) tmp585) #f) (apply (lambda (_589 name590 val591) (values (quote define-syntax-form) name590 val591 w542 s543 mod545)) tmp585) (syntax-violation #f "source expression failed to match any pattern" tmp584))) ($sc-dispatch tmp584 (quote (any any any))))) e540) (values (quote call) #f e540 w542 s543 mod545)))))))))))))) (if (syntax-object?98 e540) (syntax-type148 (syntax-object-expression99 e540) r541 (join-wraps133 w542 (syntax-object-wrap100 e540)) s543 rib544 (let ((t592 (syntax-object-module101 e540))) (if t592 t592 mod545)) for-car?546) (if (self-evaluating? e540) (values (quote constant) #f e540 w542 s543 mod545) (values (quote other) #f e540 w542 s543 mod545))))))) (chi-when-list147 (lambda (e593 when-list594 w595) (letrec ((f596 (lambda (when-list597 situations598) (if (null? when-list597) situations598 (f596 (cdr when-list597) (cons (let ((x599 (car when-list597))) (if (free-id=?137 x599 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?137 x599 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?137 x599 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e593 (wrap142 x599 w595 #f)))))) situations598)))))) (f596 when-list594 (quote ()))))) (chi-install-global146 (lambda (name600 e601) (build-global-definition89 #f name600 (if (let ((v602 (module-variable (current-module) name600))) (if v602 (if (variable-bound? v602) (if (macro? (variable-ref v602)) (not (eq? (macro-type (variable-ref v602)) (quote syncase-macro))) #f) #f) #f)) (build-application81 #f (build-primref91 #f (quote make-extended-syncase-macro)) (list (build-application81 #f (build-primref91 #f (quote module-ref)) (list (build-application81 #f (build-primref91 #f (quote current-module)) (quote ())) (build-data92 #f name600))) (build-data92 #f (quote macro)) e601)) (build-application81 #f (build-primref91 #f (quote make-syncase-macro)) (list (build-data92 #f (quote macro)) e601)))))) (chi-top-sequence145 (lambda (body603 r604 w605 s606 m607 esew608 mod609) (build-sequence93 s606 (letrec ((dobody610 (lambda (body611 r612 w613 m614 esew615 mod616) (if (null? body611) (quote ()) (let ((first617 (chi-top149 (car body611) r612 w613 m614 esew615 mod616))) (cons first617 (dobody610 (cdr body611) r612 w613 m614 esew615 mod616))))))) (dobody610 body603 r604 w605 m607 esew608 mod609))))) (chi-sequence144 (lambda (body618 r619 w620 s621 mod622) (build-sequence93 s621 (letrec ((dobody623 (lambda (body624 r625 w626 mod627) (if (null? body624) (quote ()) (let ((first628 (chi150 (car body624) r625 w626 mod627))) (cons first628 (dobody623 (cdr body624) r625 w626 mod627))))))) (dobody623 body618 r619 w620 mod622))))) (source-wrap143 (lambda (x629 w630 s631 defmod632) (begin (if (if s631 (pair? x629) #f) (set-source-properties! x629 s631)) (wrap142 x629 w630 defmod632)))) (wrap142 (lambda (x633 w634 defmod635) (if (if (null? (wrap-marks117 w634)) (null? (wrap-subst118 w634)) #f) x633 (if (syntax-object?98 x633) (make-syntax-object97 (syntax-object-expression99 x633) (join-wraps133 w634 (syntax-object-wrap100 x633)) (syntax-object-module101 x633)) (if (null? x633) x633 (make-syntax-object97 x633 w634 defmod635)))))) (bound-id-member?141 (lambda (x636 list637) (if (not (null? list637)) (let ((t638 (bound-id=?138 x636 (car list637)))) (if t638 t638 (bound-id-member?141 x636 (cdr list637)))) #f))) (distinct-bound-ids?140 (lambda (ids639) (letrec ((distinct?640 (lambda (ids641) (let ((t642 (null? ids641))) (if t642 t642 (if (not (bound-id-member?141 (car ids641) (cdr ids641))) (distinct?640 (cdr ids641)) #f)))))) (distinct?640 ids639)))) (valid-bound-ids?139 (lambda (ids643) (if (letrec ((all-ids?644 (lambda (ids645) (let ((t646 (null? ids645))) (if t646 t646 (if (id?114 (car ids645)) (all-ids?644 (cdr ids645)) #f)))))) (all-ids?644 ids643)) (distinct-bound-ids?140 ids643) #f))) (bound-id=?138 (lambda (i647 j648) (if (if (syntax-object?98 i647) (syntax-object?98 j648) #f) (if (eq? (syntax-object-expression99 i647) (syntax-object-expression99 j648)) (same-marks?135 (wrap-marks117 (syntax-object-wrap100 i647)) (wrap-marks117 (syntax-object-wrap100 j648))) #f) (eq? i647 j648)))) (free-id=?137 (lambda (i649 j650) (if (eq? (let ((x651 i649)) (if (syntax-object?98 x651) (syntax-object-expression99 x651) x651)) (let ((x652 j650)) (if (syntax-object?98 x652) (syntax-object-expression99 x652) x652))) (eq? (id-var-name136 i649 (quote (()))) (id-var-name136 j650 (quote (())))) #f))) (id-var-name136 (lambda (id653 w654) (letrec ((search-vector-rib657 (lambda (sym663 subst664 marks665 symnames666 ribcage667) (let ((n668 (vector-length symnames666))) (letrec ((f669 (lambda (i670) (if (fx=74 i670 n668) (search655 sym663 (cdr subst664) marks665) (if (if (eq? (vector-ref symnames666 i670) sym663) (same-marks?135 marks665 (vector-ref (ribcage-marks124 ribcage667) i670)) #f) (values (vector-ref (ribcage-labels125 ribcage667) i670) marks665) (f669 (fx+72 i670 1))))))) (f669 0))))) (search-list-rib656 (lambda (sym671 subst672 marks673 symnames674 ribcage675) (letrec ((f676 (lambda (symnames677 i678) (if (null? symnames677) (search655 sym671 (cdr subst672) marks673) (if (if (eq? (car symnames677) sym671) (same-marks?135 marks673 (list-ref (ribcage-marks124 ribcage675) i678)) #f) (values (list-ref (ribcage-labels125 ribcage675) i678) marks673) (f676 (cdr symnames677) (fx+72 i678 1))))))) (f676 symnames674 0)))) (search655 (lambda (sym679 subst680 marks681) (if (null? subst680) (values #f marks681) (let ((fst682 (car subst680))) (if (eq? fst682 (quote shift)) (search655 sym679 (cdr subst680) (cdr marks681)) (let ((symnames683 (ribcage-symnames123 fst682))) (if (vector? symnames683) (search-vector-rib657 sym679 subst680 marks681 symnames683 fst682) (search-list-rib656 sym679 subst680 marks681 symnames683 fst682))))))))) (if (symbol? id653) (let ((t684 (call-with-values (lambda () (search655 id653 (wrap-subst118 w654) (wrap-marks117 w654))) (lambda (x686 . ignore685) x686)))) (if t684 t684 id653)) (if (syntax-object?98 id653) (let ((id687 (syntax-object-expression99 id653)) (w1688 (syntax-object-wrap100 id653))) (let ((marks689 (join-marks134 (wrap-marks117 w654) (wrap-marks117 w1688)))) (call-with-values (lambda () (search655 id687 (wrap-subst118 w654) marks689)) (lambda (new-id690 marks691) (let ((t692 new-id690)) (if t692 t692 (let ((t693 (call-with-values (lambda () (search655 id687 (wrap-subst118 w1688) marks691)) (lambda (x695 . ignore694) x695)))) (if t693 t693 id687)))))))) (syntax-violation (quote id-var-name) "invalid id" id653)))))) (same-marks?135 (lambda (x696 y697) (let ((t698 (eq? x696 y697))) (if t698 t698 (if (not (null? x696)) (if (not (null? y697)) (if (eq? (car x696) (car y697)) (same-marks?135 (cdr x696) (cdr y697)) #f) #f) #f))))) (join-marks134 (lambda (m1699 m2700) (smart-append132 m1699 m2700))) (join-wraps133 (lambda (w1701 w2702) (let ((m1703 (wrap-marks117 w1701)) (s1704 (wrap-subst118 w1701))) (if (null? m1703) (if (null? s1704) w2702 (make-wrap116 (wrap-marks117 w2702) (smart-append132 s1704 (wrap-subst118 w2702)))) (make-wrap116 (smart-append132 m1703 (wrap-marks117 w2702)) (smart-append132 s1704 (wrap-subst118 w2702))))))) (smart-append132 (lambda (m1705 m2706) (if (null? m2706) m1705 (append m1705 m2706)))) (make-binding-wrap131 (lambda (ids707 labels708 w709) (if (null? ids707) w709 (make-wrap116 (wrap-marks117 w709) (cons (let ((labelvec710 (list->vector labels708))) (let ((n711 (vector-length labelvec710))) (let ((symnamevec712 (make-vector n711)) (marksvec713 (make-vector n711))) (begin (letrec ((f714 (lambda (ids715 i716) (if (not (null? ids715)) (call-with-values (lambda () (id-sym-name&marks115 (car ids715) w709)) (lambda (symname717 marks718) (begin (vector-set! symnamevec712 i716 symname717) (vector-set! marksvec713 i716 marks718) (f714 (cdr ids715) (fx+72 i716 1))))))))) (f714 ids707 0)) (make-ribcage121 symnamevec712 marksvec713 labelvec710))))) (wrap-subst118 w709)))))) (extend-ribcage!130 (lambda (ribcage719 id720 label721) (begin (set-ribcage-symnames!126 ribcage719 (cons (syntax-object-expression99 id720) (ribcage-symnames123 ribcage719))) (set-ribcage-marks!127 ribcage719 (cons (wrap-marks117 (syntax-object-wrap100 id720)) (ribcage-marks124 ribcage719))) (set-ribcage-labels!128 ribcage719 (cons label721 (ribcage-labels125 ribcage719)))))) (anti-mark129 (lambda (w722) (make-wrap116 (cons #f (wrap-marks117 w722)) (cons (quote shift) (wrap-subst118 w722))))) (set-ribcage-labels!128 (lambda (x723 update724) (vector-set! x723 3 update724))) (set-ribcage-marks!127 (lambda (x725 update726) (vector-set! x725 2 update726))) (set-ribcage-symnames!126 (lambda (x727 update728) (vector-set! x727 1 update728))) (ribcage-labels125 (lambda (x729) (vector-ref x729 3))) (ribcage-marks124 (lambda (x730) (vector-ref x730 2))) (ribcage-symnames123 (lambda (x731) (vector-ref x731 1))) (ribcage?122 (lambda (x732) (if (vector? x732) (if (= (vector-length x732) 4) (eq? (vector-ref x732 0) (quote ribcage)) #f) #f))) (make-ribcage121 (lambda (symnames733 marks734 labels735) (vector (quote ribcage) symnames733 marks734 labels735))) (gen-labels120 (lambda (ls736) (if (null? ls736) (quote ()) (cons (gen-label119) (gen-labels120 (cdr ls736)))))) (gen-label119 (lambda () (string #\i))) (wrap-subst118 cdr) (wrap-marks117 car) (make-wrap116 cons) (id-sym-name&marks115 (lambda (x737 w738) (if (syntax-object?98 x737) (values (syntax-object-expression99 x737) (join-marks134 (wrap-marks117 w738) (wrap-marks117 (syntax-object-wrap100 x737)))) (values x737 (wrap-marks117 w738))))) (id?114 (lambda (x739) (if (symbol? x739) #t (if (syntax-object?98 x739) (symbol? (syntax-object-expression99 x739)) #f)))) (nonsymbol-id?113 (lambda (x740) (if (syntax-object?98 x740) (symbol? (syntax-object-expression99 x740)) #f))) (global-extend112 (lambda (type741 sym742 val743) (put-global-definition-hook78 sym742 type741 val743))) (lookup111 (lambda (x744 r745 mod746) (let ((t747 (assq x744 r745))) (if t747 (cdr t747) (if (symbol? x744) (let ((t748 (get-global-definition-hook79 x744 mod746))) (if t748 t748 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env110 (lambda (r749) (if (null? r749) (quote ()) (let ((a750 (car r749))) (if (eq? (cadr a750) (quote macro)) (cons a750 (macros-only-env110 (cdr r749))) (macros-only-env110 (cdr r749))))))) (extend-var-env109 (lambda (labels751 vars752 r753) (if (null? labels751) r753 (extend-var-env109 (cdr labels751) (cdr vars752) (cons (cons (car labels751) (cons (quote lexical) (car vars752))) r753))))) (extend-env108 (lambda (labels754 bindings755 r756) (if (null? labels754) r756 (extend-env108 (cdr labels754) (cdr bindings755) (cons (cons (car labels754) (car bindings755)) r756))))) (binding-value107 cdr) (binding-type106 car) (source-annotation105 (lambda (x757) (if (syntax-object?98 x757) (source-annotation105 (syntax-object-expression99 x757)) (if (pair? x757) (let ((props758 (source-properties x757))) (if (pair? props758) props758 #f)) #f)))) (set-syntax-object-module!104 (lambda (x759 update760) (vector-set! x759 3 update760))) (set-syntax-object-wrap!103 (lambda (x761 update762) (vector-set! x761 2 update762))) (set-syntax-object-expression!102 (lambda (x763 update764) (vector-set! x763 1 update764))) (syntax-object-module101 (lambda (x765) (vector-ref x765 3))) (syntax-object-wrap100 (lambda (x766) (vector-ref x766 2))) (syntax-object-expression99 (lambda (x767) (vector-ref x767 1))) (syntax-object?98 (lambda (x768) (if (vector? x768) (if (= (vector-length x768) 4) (eq? (vector-ref x768 0) (quote syntax-object)) #f) #f))) (make-syntax-object97 (lambda (expression769 wrap770 module771) (vector (quote syntax-object) expression769 wrap770 module771))) (build-letrec96 (lambda (src772 ids773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (let ((atom-key777 (fluid-ref *mode*71))) (if (memv atom-key777 (quote (c))) (begin (for-each maybe-name-value!88 ids773 val-exps775) ((@ (language tree-il) make-letrec) src772 ids773 vars774 val-exps775 body-exp776)) (list (quote letrec) (map list vars774 val-exps775) body-exp776)))))) (build-named-let95 (lambda (src778 ids779 vars780 val-exps781 body-exp782) (let ((f783 (car vars780)) (f-name784 (car ids779)) (vars785 (cdr vars780)) (ids786 (cdr ids779))) (let ((atom-key787 (fluid-ref *mode*71))) (if (memv atom-key787 (quote (c))) (let ((proc788 (build-lambda90 src778 ids786 vars785 #f body-exp782))) (begin (maybe-name-value!88 f-name784 proc788) (for-each maybe-name-value!88 ids786 val-exps781) ((@ (language tree-il) make-letrec) src778 (list f-name784) (list f783) (list proc788) (build-application81 src778 (build-lexical-reference83 (quote fun) src778 f-name784 f783) val-exps781)))) (list (quote let) f783 (map list vars785 val-exps781) body-exp782)))))) (build-let94 (lambda (src789 ids790 vars791 val-exps792 body-exp793) (if (null? vars791) body-exp793 (let ((atom-key794 (fluid-ref *mode*71))) (if (memv atom-key794 (quote (c))) (begin (for-each maybe-name-value!88 ids790 val-exps792) ((@ (language tree-il) make-let) src789 ids790 vars791 val-exps792 body-exp793)) (list (quote let) (map list vars791 val-exps792) body-exp793)))))) (build-sequence93 (lambda (src795 exps796) (if (null? (cdr exps796)) (car exps796) (let ((atom-key797 (fluid-ref *mode*71))) (if (memv atom-key797 (quote (c))) ((@ (language tree-il) make-sequence) src795 exps796) (cons (quote begin) exps796)))))) (build-data92 (lambda (src798 exp799) (let ((atom-key800 (fluid-ref *mode*71))) (if (memv atom-key800 (quote (c))) ((@ (language tree-il) make-const) src798 exp799) (if (if (self-evaluating? exp799) (not (vector? exp799)) #f) exp799 (list (quote quote) exp799)))))) (build-primref91 (lambda (src801 name802) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key803 (fluid-ref *mode*71))) (if (memv atom-key803 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src801 name802) name802)) (let ((atom-key804 (fluid-ref *mode*71))) (if (memv atom-key804 (quote (c))) ((@ (language tree-il) make-module-ref) src801 (quote (guile)) name802 #f) (list (quote @@) (quote (guile)) name802)))))) (build-lambda90 (lambda (src805 ids806 vars807 docstring808 exp809) (let ((atom-key810 (fluid-ref *mode*71))) (if (memv atom-key810 (quote (c))) ((@ (language tree-il) make-lambda) src805 ids806 vars807 (if docstring808 (list (cons (quote documentation) docstring808)) (quote ())) exp809) (cons (quote lambda) (cons vars807 (append (if docstring808 (list docstring808) (quote ())) (list exp809)))))))) (build-global-definition89 (lambda (source811 var812 exp813) (let ((atom-key814 (fluid-ref *mode*71))) (if (memv atom-key814 (quote (c))) (begin (maybe-name-value!88 var812 exp813) ((@ (language tree-il) make-toplevel-define) source811 var812 exp813)) (list (quote define) var812 exp813))))) (maybe-name-value!88 (lambda (name815 val816) (if ((@ (language tree-il) lambda?) val816) (let ((meta817 ((@ (language tree-il) lambda-meta) val816))) (if (not (assq (quote name) meta817)) ((setter (@ (language tree-il) lambda-meta)) val816 (acons (quote name) name815 meta817))))))) (build-global-assignment87 (lambda (source818 var819 exp820 mod821) (analyze-variable85 mod821 var819 (lambda (mod822 var823 public?824) (let ((atom-key825 (fluid-ref *mode*71))) (if (memv atom-key825 (quote (c))) ((@ (language tree-il) make-module-set) source818 mod822 var823 public?824 exp820) (list (quote set!) (list (if public?824 (quote @) (quote @@)) mod822 var823) exp820)))) (lambda (var826) (let ((atom-key827 (fluid-ref *mode*71))) (if (memv atom-key827 (quote (c))) ((@ (language tree-il) make-toplevel-set) source818 var826 exp820) (list (quote set!) var826 exp820))))))) (build-global-reference86 (lambda (source828 var829 mod830) (analyze-variable85 mod830 var829 (lambda (mod831 var832 public?833) (let ((atom-key834 (fluid-ref *mode*71))) (if (memv atom-key834 (quote (c))) ((@ (language tree-il) make-module-ref) source828 mod831 var832 public?833) (list (if public?833 (quote @) (quote @@)) mod831 var832)))) (lambda (var835) (let ((atom-key836 (fluid-ref *mode*71))) (if (memv atom-key836 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source828 var835) var835)))))) (analyze-variable85 (lambda (mod837 var838 modref-cont839 bare-cont840) (if (not mod837) (bare-cont840 var838) (let ((kind841 (car mod837)) (mod842 (cdr mod837))) (if (memv kind841 (quote (public))) (modref-cont839 mod842 var838 #t) (if (memv kind841 (quote (private))) (if (not (equal? mod842 (module-name (current-module)))) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (if (memv kind841 (quote (bare))) (bare-cont840 var838) (if (memv kind841 (quote (hygiene))) (if (if (not (equal? mod842 (module-name (current-module)))) (module-variable (resolve-module mod842) var838) #f) (modref-cont839 mod842 var838 #f) (bare-cont840 var838)) (syntax-violation #f "bad module kind" var838 mod842))))))))) (build-lexical-assignment84 (lambda (source843 name844 var845 exp846) (let ((atom-key847 (fluid-ref *mode*71))) (if (memv atom-key847 (quote (c))) ((@ (language tree-il) make-lexical-set) source843 name844 var845 exp846) (list (quote set!) var845 exp846))))) (build-lexical-reference83 (lambda (type848 source849 name850 var851) (let ((atom-key852 (fluid-ref *mode*71))) (if (memv atom-key852 (quote (c))) ((@ (language tree-il) make-lexical-ref) source849 name850 var851) var851)))) (build-conditional82 (lambda (source853 test-exp854 then-exp855 else-exp856) (let ((atom-key857 (fluid-ref *mode*71))) (if (memv atom-key857 (quote (c))) ((@ (language tree-il) make-conditional) source853 test-exp854 then-exp855 else-exp856) (if (equal? else-exp856 (quote (if #f #f))) (list (quote if) test-exp854 then-exp855) (list (quote if) test-exp854 then-exp855 else-exp856)))))) (build-application81 (lambda (source858 fun-exp859 arg-exps860) (let ((atom-key861 (fluid-ref *mode*71))) (if (memv atom-key861 (quote (c))) ((@ (language tree-il) make-application) source858 fun-exp859 arg-exps860) (cons fun-exp859 arg-exps860))))) (build-void80 (lambda (source862) (let ((atom-key863 (fluid-ref *mode*71))) (if (memv atom-key863 (quote (c))) ((@ (language tree-il) make-void) source862) (quote (if #f #f)))))) (get-global-definition-hook79 (lambda (symbol864 module865) (begin (if (if (not module865) (current-module) #f) (warn "module system is booted, we should have a module" symbol864)) (let ((v866 (module-variable (if module865 (resolve-module (cdr module865)) (current-module)) symbol864))) (if v866 (if (variable-bound? v866) (let ((val867 (variable-ref v866))) (if (macro? val867) (if (syncase-macro-type val867) (cons (syncase-macro-type val867) (syncase-macro-binding val867)) #f) #f)) #f) #f))))) (put-global-definition-hook78 (lambda (symbol868 type869 val870) (let ((existing871 (let ((v872 (module-variable (current-module) symbol868))) (if v872 (if (variable-bound? v872) (let ((val873 (variable-ref v872))) (if (macro? val873) (if (not (syncase-macro-type val873)) val873 #f) #f)) #f) #f)))) (module-define! (current-module) symbol868 (if existing871 (make-extended-syncase-macro existing871 type869 val870) (make-syncase-macro type869 val870)))))) (local-eval-hook77 (lambda (x874 mod875) (primitive-eval (list noexpand70 (let ((atom-key876 (fluid-ref *mode*71))) (if (memv atom-key876 (quote (c))) ((@ (language tree-il) tree-il->scheme) x874) x874)))))) (top-level-eval-hook76 (lambda (x877 mod878) (primitive-eval (list noexpand70 (let ((atom-key879 (fluid-ref *mode*71))) (if (memv atom-key879 (quote (c))) ((@ (language tree-il) tree-il->scheme) x877) x877)))))) (fx<75 <) (fx=74 =) (fx-73 -) (fx+72 +) (*mode*71 (make-fluid)) (noexpand70 "noexpand")) (begin (global-extend112 (quote local-syntax) (quote letrec-syntax) #t) (global-extend112 (quote local-syntax) (quote let-syntax) #f) (global-extend112 (quote core) (quote fluid-let-syntax) (lambda (e880 r881 w882 s883 mod884) ((lambda (tmp885) ((lambda (tmp886) (if (if tmp886 (apply (lambda (_887 var888 val889 e1890 e2891) (valid-bound-ids?139 var888)) tmp886) #f) (apply (lambda (_893 var894 val895 e1896 e2897) (let ((names898 (map (lambda (x899) (id-var-name136 x899 w882)) var894))) (begin (for-each (lambda (id901 n902) (let ((atom-key903 (binding-type106 (lookup111 n902 r881 mod884)))) (if (memv atom-key903 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e880 (source-wrap143 id901 w882 s883 mod884))))) var894 names898) (chi-body154 (cons e1896 e2897) (source-wrap143 e880 w882 s883 mod884) (extend-env108 names898 (let ((trans-r906 (macros-only-env110 r881))) (map (lambda (x907) (cons (quote macro) (eval-local-transformer157 (chi150 x907 trans-r906 w882 mod884) mod884))) val895)) r881) w882 mod884)))) tmp886) ((lambda (_909) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap143 e880 w882 s883 mod884))) tmp885))) ($sc-dispatch tmp885 (quote (any #(each (any any)) any . each-any))))) e880))) (global-extend112 (quote core) (quote quote) (lambda (e910 r911 w912 s913 mod914) ((lambda (tmp915) ((lambda (tmp916) (if tmp916 (apply (lambda (_917 e918) (build-data92 s913 (strip160 e918 w912))) tmp916) ((lambda (_919) (syntax-violation (quote quote) "bad syntax" (source-wrap143 e910 w912 s913 mod914))) tmp915))) ($sc-dispatch tmp915 (quote (any any))))) e910))) (global-extend112 (quote core) (quote syntax) (letrec ((regen927 (lambda (x928) (let ((atom-key929 (car x928))) (if (memv atom-key929 (quote (ref))) (build-lexical-reference83 (quote value) #f (cadr x928) (cadr x928)) (if (memv atom-key929 (quote (primitive))) (build-primref91 #f (cadr x928)) (if (memv atom-key929 (quote (quote))) (build-data92 #f (cadr x928)) (if (memv atom-key929 (quote (lambda))) (build-lambda90 #f (cadr x928) (cadr x928) #f (regen927 (caddr x928))) (build-application81 #f (build-primref91 #f (car x928)) (map regen927 (cdr x928)))))))))) (gen-vector926 (lambda (x930) (if (eq? (car x930) (quote list)) (cons (quote vector) (cdr x930)) (if (eq? (car x930) (quote quote)) (list (quote quote) (list->vector (cadr x930))) (list (quote list->vector) x930))))) (gen-append925 (lambda (x931 y932) (if (equal? y932 (quote (quote ()))) x931 (list (quote append) x931 y932)))) (gen-cons924 (lambda (x933 y934) (let ((atom-key935 (car y934))) (if (memv atom-key935 (quote (quote))) (if (eq? (car x933) (quote quote)) (list (quote quote) (cons (cadr x933) (cadr y934))) (if (eq? (cadr y934) (quote ())) (list (quote list) x933) (list (quote cons) x933 y934))) (if (memv atom-key935 (quote (list))) (cons (quote list) (cons x933 (cdr y934))) (list (quote cons) x933 y934)))))) (gen-map923 (lambda (e936 map-env937) (let ((formals938 (map cdr map-env937)) (actuals939 (map (lambda (x940) (list (quote ref) (car x940))) map-env937))) (if (eq? (car e936) (quote ref)) (car actuals939) (if (and-map (lambda (x941) (if (eq? (car x941) (quote ref)) (memq (cadr x941) formals938) #f)) (cdr e936)) (cons (quote map) (cons (list (quote primitive) (car e936)) (map (let ((r942 (map cons formals938 actuals939))) (lambda (x943) (cdr (assq (cadr x943) r942)))) (cdr e936)))) (cons (quote map) (cons (list (quote lambda) formals938 e936) actuals939))))))) (gen-mappend922 (lambda (e944 map-env945) (list (quote apply) (quote (primitive append)) (gen-map923 e944 map-env945)))) (gen-ref921 (lambda (src946 var947 level948 maps949) (if (fx=74 level948 0) (values var947 maps949) (if (null? maps949) (syntax-violation (quote syntax) "missing ellipsis" src946) (call-with-values (lambda () (gen-ref921 src946 var947 (fx-73 level948 1) (cdr maps949))) (lambda (outer-var950 outer-maps951) (let ((b952 (assq outer-var950 (car maps949)))) (if b952 (values (cdr b952) maps949) (let ((inner-var953 (gen-var161 (quote tmp)))) (values inner-var953 (cons (cons (cons outer-var950 inner-var953) (car maps949)) outer-maps951))))))))))) (gen-syntax920 (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) (if (id?114 e955) (let ((label960 (id-var-name136 e955 (quote (()))))) (let ((b961 (lookup111 label960 r956 mod959))) (if (eq? (binding-type106 b961) (quote syntax)) (call-with-values (lambda () (let ((var.lev962 (binding-value107 b961))) (gen-ref921 src954 (car var.lev962) (cdr var.lev962) maps957))) (lambda (var963 maps964) (values (list (quote ref) var963) maps964))) (if (ellipsis?958 e955) (syntax-violation (quote syntax) "misplaced ellipsis" src954) (values (list (quote quote) e955) maps957))))) ((lambda (tmp965) ((lambda (tmp966) (if (if tmp966 (apply (lambda (dots967 e968) (ellipsis?958 dots967)) tmp966) #f) (apply (lambda (dots969 e970) (gen-syntax920 src954 e970 r956 maps957 (lambda (x971) #f) mod959)) tmp966) ((lambda (tmp972) (if (if tmp972 (apply (lambda (x973 dots974 y975) (ellipsis?958 dots974)) tmp972) #f) (apply (lambda (x976 dots977 y978) (letrec ((f979 (lambda (y980 k981) ((lambda (tmp985) ((lambda (tmp986) (if (if tmp986 (apply (lambda (dots987 y988) (ellipsis?958 dots987)) tmp986) #f) (apply (lambda (dots989 y990) (f979 y990 (lambda (maps991) (call-with-values (lambda () (k981 (cons (quote ()) maps991))) (lambda (x992 maps993) (if (null? (car maps993)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-mappend922 x992 (car maps993)) (cdr maps993)))))))) tmp986) ((lambda (_994) (call-with-values (lambda () (gen-syntax920 src954 y980 r956 maps957 ellipsis?958 mod959)) (lambda (y995 maps996) (call-with-values (lambda () (k981 maps996)) (lambda (x997 maps998) (values (gen-append925 x997 y995) maps998)))))) tmp985))) ($sc-dispatch tmp985 (quote (any . any))))) y980)))) (f979 y978 (lambda (maps982) (call-with-values (lambda () (gen-syntax920 src954 x976 r956 (cons (quote ()) maps982) ellipsis?958 mod959)) (lambda (x983 maps984) (if (null? (car maps984)) (syntax-violation (quote syntax) "extra ellipsis" src954) (values (gen-map923 x983 (car maps984)) (cdr maps984))))))))) tmp972) ((lambda (tmp999) (if tmp999 (apply (lambda (x1000 y1001) (call-with-values (lambda () (gen-syntax920 src954 x1000 r956 maps957 ellipsis?958 mod959)) (lambda (x1002 maps1003) (call-with-values (lambda () (gen-syntax920 src954 y1001 r956 maps1003 ellipsis?958 mod959)) (lambda (y1004 maps1005) (values (gen-cons924 x1002 y1004) maps1005)))))) tmp999) ((lambda (tmp1006) (if tmp1006 (apply (lambda (e11007 e21008) (call-with-values (lambda () (gen-syntax920 src954 (cons e11007 e21008) r956 maps957 ellipsis?958 mod959)) (lambda (e1010 maps1011) (values (gen-vector926 e1010) maps1011)))) tmp1006) ((lambda (_1012) (values (list (quote quote) e955) maps957)) tmp965))) ($sc-dispatch tmp965 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp965 (quote (any . any)))))) ($sc-dispatch tmp965 (quote (any any . any)))))) ($sc-dispatch tmp965 (quote (any any))))) e955))))) (lambda (e1013 r1014 w1015 s1016 mod1017) (let ((e1018 (source-wrap143 e1013 w1015 s1016 mod1017))) ((lambda (tmp1019) ((lambda (tmp1020) (if tmp1020 (apply (lambda (_1021 x1022) (call-with-values (lambda () (gen-syntax920 e1018 x1022 r1014 (quote ()) ellipsis?159 mod1017)) (lambda (e1023 maps1024) (regen927 e1023)))) tmp1020) ((lambda (_1025) (syntax-violation (quote syntax) "bad `syntax' form" e1018)) tmp1019))) ($sc-dispatch tmp1019 (quote (any any))))) e1018))))) (global-extend112 (quote core) (quote lambda) (lambda (e1026 r1027 w1028 s1029 mod1030) ((lambda (tmp1031) ((lambda (tmp1032) (if tmp1032 (apply (lambda (_1033 c1034) (chi-lambda-clause155 (source-wrap143 e1026 w1028 s1029 mod1030) #f c1034 r1027 w1028 mod1030 (lambda (names1035 vars1036 docstring1037 body1038) (build-lambda90 s1029 names1035 vars1036 docstring1037 body1038)))) tmp1032) (syntax-violation #f "source expression failed to match any pattern" tmp1031))) ($sc-dispatch tmp1031 (quote (any . any))))) e1026))) (global-extend112 (quote core) (quote let) (letrec ((chi-let1039 (lambda (e1040 r1041 w1042 s1043 mod1044 constructor1045 ids1046 vals1047 exps1048) (if (not (valid-bound-ids?139 ids1046)) (syntax-violation (quote let) "duplicate bound variable" e1040) (let ((labels1049 (gen-labels120 ids1046)) (new-vars1050 (map gen-var161 ids1046))) (let ((nw1051 (make-binding-wrap131 ids1046 labels1049 w1042)) (nr1052 (extend-var-env109 labels1049 new-vars1050 r1041))) (constructor1045 s1043 (map syntax->datum ids1046) new-vars1050 (map (lambda (x1053) (chi150 x1053 r1041 w1042 mod1044)) vals1047) (chi-body154 exps1048 (source-wrap143 e1040 nw1051 s1043 mod1044) nr1052 nw1051 mod1044)))))))) (lambda (e1054 r1055 w1056 s1057 mod1058) ((lambda (tmp1059) ((lambda (tmp1060) (if (if tmp1060 (apply (lambda (_1061 id1062 val1063 e11064 e21065) (and-map id?114 id1062)) tmp1060) #f) (apply (lambda (_1067 id1068 val1069 e11070 e21071) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-let94 id1068 val1069 (cons e11070 e21071))) tmp1060) ((lambda (tmp1075) (if (if tmp1075 (apply (lambda (_1076 f1077 id1078 val1079 e11080 e21081) (if (id?114 f1077) (and-map id?114 id1078) #f)) tmp1075) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1039 e1054 r1055 w1056 s1057 mod1058 build-named-let95 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1075) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap143 e1054 w1056 s1057 mod1058))) tmp1059))) ($sc-dispatch tmp1059 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1059 (quote (any #(each (any any)) any . each-any))))) e1054)))) (global-extend112 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (and-map id?114 id1101)) tmp1099) #f) (apply (lambda (_1106 id1107 val1108 e11109 e21110) (let ((ids1111 id1107)) (if (not (valid-bound-ids?139 ids1111)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1113 (gen-labels120 ids1111)) (new-vars1114 (map gen-var161 ids1111))) (let ((w1115 (make-binding-wrap131 ids1111 labels1113 w1095)) (r1116 (extend-var-env109 labels1113 new-vars1114 r1094))) (build-letrec96 s1096 (map syntax->datum ids1111) new-vars1114 (map (lambda (x1117) (chi150 x1117 r1116 w1115 mod1097)) val1108) (chi-body154 (cons e11109 e21110) (source-wrap143 e1093 w1115 s1096 mod1097) r1116 w1115 mod1097))))))) tmp1099) ((lambda (_1120) (syntax-violation (quote letrec) "bad letrec" (source-wrap143 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend112 (quote core) (quote set!) (lambda (e1121 r1122 w1123 s1124 mod1125) ((lambda (tmp1126) ((lambda (tmp1127) (if (if tmp1127 (apply (lambda (_1128 id1129 val1130) (id?114 id1129)) tmp1127) #f) (apply (lambda (_1131 id1132 val1133) (let ((val1134 (chi150 val1133 r1122 w1123 mod1125)) (n1135 (id-var-name136 id1132 w1123))) (let ((b1136 (lookup111 n1135 r1122 mod1125))) (let ((atom-key1137 (binding-type106 b1136))) (if (memv atom-key1137 (quote (lexical))) (build-lexical-assignment84 s1124 (syntax->datum id1132) (binding-value107 b1136) val1134) (if (memv atom-key1137 (quote (global))) (build-global-assignment87 s1124 n1135 val1134 mod1125) (if (memv atom-key1137 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap142 id1132 w1123 mod1125)) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))))))))) tmp1127) ((lambda (tmp1138) (if tmp1138 (apply (lambda (_1139 head1140 tail1141 val1142) (call-with-values (lambda () (syntax-type148 head1140 r1122 (quote (())) #f #f mod1125 #t)) (lambda (type1143 value1144 ee1145 ww1146 ss1147 modmod1148) (if (memv type1143 (quote (module-ref))) (let ((val1149 (chi150 val1142 r1122 w1123 mod1125))) (call-with-values (lambda () (value1144 (cons head1140 tail1141))) (lambda (id1151 mod1152) (build-global-assignment87 s1124 id1151 val1149 mod1152)))) (build-application81 s1124 (chi150 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1140) r1122 w1123 mod1125) (map (lambda (e1153) (chi150 e1153 r1122 w1123 mod1125)) (append tail1141 (list val1142)))))))) tmp1138) ((lambda (_1155) (syntax-violation (quote set!) "bad set!" (source-wrap143 e1121 w1123 s1124 mod1125))) tmp1126))) ($sc-dispatch tmp1126 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1126 (quote (any any any))))) e1121))) (global-extend112 (quote module-ref) (quote @) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (if (and-map id?114 mod1160) (id?114 id1161) #f)) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend112 (quote module-ref) (quote @@) (lambda (e1167) ((lambda (tmp1168) ((lambda (tmp1169) (if (if tmp1169 (apply (lambda (_1170 mod1171 id1172) (if (and-map id?114 mod1171) (id?114 id1172) #f)) tmp1169) #f) (apply (lambda (_1174 mod1175 id1176) (values (syntax->datum id1176) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1175)))) tmp1169) (syntax-violation #f "source expression failed to match any pattern" tmp1168))) ($sc-dispatch tmp1168 (quote (any each-any any))))) e1167))) (global-extend112 (quote core) (quote if) (lambda (e1178 r1179 w1180 s1181 mod1182) ((lambda (tmp1183) ((lambda (tmp1184) (if tmp1184 (apply (lambda (_1185 test1186 then1187) (build-conditional82 s1181 (chi150 test1186 r1179 w1180 mod1182) (chi150 then1187 r1179 w1180 mod1182) (build-void80 #f))) tmp1184) ((lambda (tmp1188) (if tmp1188 (apply (lambda (_1189 test1190 then1191 else1192) (build-conditional82 s1181 (chi150 test1190 r1179 w1180 mod1182) (chi150 then1191 r1179 w1180 mod1182) (chi150 else1192 r1179 w1180 mod1182))) tmp1188) (syntax-violation #f "source expression failed to match any pattern" tmp1183))) ($sc-dispatch tmp1183 (quote (any any any any)))))) ($sc-dispatch tmp1183 (quote (any any any))))) e1178))) (global-extend112 (quote begin) (quote begin) (quote ())) (global-extend112 (quote define) (quote define) (quote ())) (global-extend112 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend112 (quote eval-when) (quote eval-when) (quote ())) (global-extend112 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1196 (lambda (x1197 keys1198 clauses1199 r1200 mod1201) (if (null? clauses1199) (build-application81 #f (build-primref91 #f (quote syntax-violation)) (list (build-data92 #f #f) (build-data92 #f "source expression failed to match any pattern") x1197)) ((lambda (tmp1202) ((lambda (tmp1203) (if tmp1203 (apply (lambda (pat1204 exp1205) (if (if (id?114 pat1204) (and-map (lambda (x1206) (not (free-id=?137 pat1204 x1206))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1198)) #f) (let ((labels1207 (list (gen-label119))) (var1208 (gen-var161 pat1204))) (build-application81 #f (build-lambda90 #f (list (syntax->datum pat1204)) (list var1208) #f (chi150 exp1205 (extend-env108 labels1207 (list (cons (quote syntax) (cons var1208 0))) r1200) (make-binding-wrap131 (list pat1204) labels1207 (quote (()))) mod1201)) (list x1197))) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1204 #t exp1205 mod1201))) tmp1203) ((lambda (tmp1209) (if tmp1209 (apply (lambda (pat1210 fender1211 exp1212) (gen-clause1195 x1197 keys1198 (cdr clauses1199) r1200 pat1210 fender1211 exp1212 mod1201)) tmp1209) ((lambda (_1213) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1199))) tmp1202))) ($sc-dispatch tmp1202 (quote (any any any)))))) ($sc-dispatch tmp1202 (quote (any any))))) (car clauses1199))))) (gen-clause1195 (lambda (x1214 keys1215 clauses1216 r1217 pat1218 fender1219 exp1220 mod1221) (call-with-values (lambda () (convert-pattern1193 pat1218 keys1215)) (lambda (p1222 pvars1223) (if (not (distinct-bound-ids?140 (map car pvars1223))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1218) (if (not (and-map (lambda (x1224) (not (ellipsis?159 (car x1224)))) pvars1223)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1218) (let ((y1225 (gen-var161 (quote tmp)))) (build-application81 #f (build-lambda90 #f (list (quote tmp)) (list y1225) #f (let ((y1226 (build-lexical-reference83 (quote value) #f (quote tmp) y1225))) (build-conditional82 #f ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda () y1226) tmp1228) ((lambda (_1229) (build-conditional82 #f y1226 (build-dispatch-call1194 pvars1223 fender1219 y1226 r1217 mod1221) (build-data92 #f #f))) tmp1227))) ($sc-dispatch tmp1227 (quote #(atom #t))))) fender1219) (build-dispatch-call1194 pvars1223 exp1220 y1226 r1217 mod1221) (gen-syntax-case1196 x1214 keys1215 clauses1216 r1217 mod1221)))) (list (if (eq? p1222 (quote any)) (build-application81 #f (build-primref91 #f (quote list)) (list x1214)) (build-application81 #f (build-primref91 #f (quote $sc-dispatch)) (list x1214 (build-data92 #f p1222))))))))))))) (build-dispatch-call1194 (lambda (pvars1230 exp1231 y1232 r1233 mod1234) (let ((ids1235 (map car pvars1230)) (levels1236 (map cdr pvars1230))) (let ((labels1237 (gen-labels120 ids1235)) (new-vars1238 (map gen-var161 ids1235))) (build-application81 #f (build-primref91 #f (quote apply)) (list (build-lambda90 #f (map syntax->datum ids1235) new-vars1238 #f (chi150 exp1231 (extend-env108 labels1237 (map (lambda (var1239 level1240) (cons (quote syntax) (cons var1239 level1240))) new-vars1238 (map cdr pvars1230)) r1233) (make-binding-wrap131 ids1235 labels1237 (quote (()))) mod1234)) y1232)))))) (convert-pattern1193 (lambda (pattern1241 keys1242) (letrec ((cvt1243 (lambda (p1244 n1245 ids1246) (if (id?114 p1244) (if (bound-id-member?141 p1244 keys1242) (values (vector (quote free-id) p1244) ids1246) (values (quote any) (cons (cons p1244 n1245) ids1246))) ((lambda (tmp1247) ((lambda (tmp1248) (if (if tmp1248 (apply (lambda (x1249 dots1250) (ellipsis?159 dots1250)) tmp1248) #f) (apply (lambda (x1251 dots1252) (call-with-values (lambda () (cvt1243 x1251 (fx+72 n1245 1) ids1246)) (lambda (p1253 ids1254) (values (if (eq? p1253 (quote any)) (quote each-any) (vector (quote each) p1253)) ids1254)))) tmp1248) ((lambda (tmp1255) (if tmp1255 (apply (lambda (x1256 y1257) (call-with-values (lambda () (cvt1243 y1257 n1245 ids1246)) (lambda (y1258 ids1259) (call-with-values (lambda () (cvt1243 x1256 n1245 ids1259)) (lambda (x1260 ids1261) (values (cons x1260 y1258) ids1261)))))) tmp1255) ((lambda (tmp1262) (if tmp1262 (apply (lambda () (values (quote ()) ids1246)) tmp1262) ((lambda (tmp1263) (if tmp1263 (apply (lambda (x1264) (call-with-values (lambda () (cvt1243 x1264 n1245 ids1246)) (lambda (p1266 ids1267) (values (vector (quote vector) p1266) ids1267)))) tmp1263) ((lambda (x1268) (values (vector (quote atom) (strip160 p1244 (quote (())))) ids1246)) tmp1247))) ($sc-dispatch tmp1247 (quote #(vector each-any)))))) ($sc-dispatch tmp1247 (quote ()))))) ($sc-dispatch tmp1247 (quote (any . any)))))) ($sc-dispatch tmp1247 (quote (any any))))) p1244))))) (cvt1243 pattern1241 0 (quote ())))))) (lambda (e1269 r1270 w1271 s1272 mod1273) (let ((e1274 (source-wrap143 e1269 w1271 s1272 mod1273))) ((lambda (tmp1275) ((lambda (tmp1276) (if tmp1276 (apply (lambda (_1277 val1278 key1279 m1280) (if (and-map (lambda (x1281) (if (id?114 x1281) (not (ellipsis?159 x1281)) #f)) key1279) (let ((x1283 (gen-var161 (quote tmp)))) (build-application81 s1272 (build-lambda90 #f (list (quote tmp)) (list x1283) #f (gen-syntax-case1196 (build-lexical-reference83 (quote value) #f (quote tmp) x1283) key1279 m1280 r1270 mod1273)) (list (chi150 val1278 r1270 (quote (())) mod1273)))) (syntax-violation (quote syntax-case) "invalid literals list" e1274))) tmp1276) (syntax-violation #f "source expression failed to match any pattern" tmp1275))) ($sc-dispatch tmp1275 (quote (any any each-any . each-any))))) e1274))))) (set! sc-expand (lambda (x1287 . rest1286) (if (if (pair? x1287) (equal? (car x1287) noexpand70) #f) (cadr x1287) (let ((m1288 (if (null? rest1286) (quote e) (car rest1286))) (esew1289 (if (let ((t1290 (null? rest1286))) (if t1290 t1290 (null? (cdr rest1286)))) (quote (eval)) (cadr rest1286)))) (with-fluid* *mode*71 m1288 (lambda () (chi-top149 x1287 (quote ()) (quote ((top))) m1288 esew1289 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1291) (nonsymbol-id?113 x1291))) (set! datum->syntax (lambda (id1292 datum1293) (make-syntax-object97 datum1293 (syntax-object-wrap100 id1292) #f))) (set! syntax->datum (lambda (x1294) (strip160 x1294 (quote (()))))) (set! generate-temporaries (lambda (ls1295) (begin (let ((x1296 ls1295)) (if (not (list? x1296)) (syntax-violation (quote generate-temporaries) "invalid argument" x1296))) (map (lambda (x1297) (wrap142 (gensym) (quote ((top))) #f)) ls1295)))) (set! free-identifier=? (lambda (x1298 y1299) (begin (let ((x1300 x1298)) (if (not (nonsymbol-id?113 x1300)) (syntax-violation (quote free-identifier=?) "invalid argument" x1300))) (let ((x1301 y1299)) (if (not (nonsymbol-id?113 x1301)) (syntax-violation (quote free-identifier=?) "invalid argument" x1301))) (free-id=?137 x1298 y1299)))) (set! bound-identifier=? (lambda (x1302 y1303) (begin (let ((x1304 x1302)) (if (not (nonsymbol-id?113 x1304)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1304))) (let ((x1305 y1303)) (if (not (nonsymbol-id?113 x1305)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1305))) (bound-id=?138 x1302 y1303)))) (set! syntax-violation (lambda (who1309 message1308 form1307 . subform1306) (begin (let ((x1310 who1309)) (if (not ((lambda (x1311) (let ((t1312 (not x1311))) (if t1312 t1312 (let ((t1313 (string? x1311))) (if t1313 t1313 (symbol? x1311)))))) x1310)) (syntax-violation (quote syntax-violation) "invalid argument" x1310))) (let ((x1314 message1308)) (if (not (string? x1314)) (syntax-violation (quote syntax-violation) "invalid argument" x1314))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1309 "~a: " "") "~a " (if (null? subform1306) "in ~a" "in subform `~s' of `~s'")) (let ((tail1315 (cons message1308 (map (lambda (x1316) (strip160 x1316 (quote (())))) (append subform1306 (list form1307)))))) (if who1309 (cons who1309 tail1315) tail1315)) #f)))) (letrec ((match1321 (lambda (e1322 p1323 w1324 r1325 mod1326) (if (not r1325) #f (if (eq? p1323 (quote any)) (cons (wrap142 e1322 w1324 mod1326) r1325) (if (syntax-object?98 e1322) (match*1320 (syntax-object-expression99 e1322) p1323 (join-wraps133 w1324 (syntax-object-wrap100 e1322)) r1325 (syntax-object-module101 e1322)) (match*1320 e1322 p1323 w1324 r1325 mod1326)))))) (match*1320 (lambda (e1327 p1328 w1329 r1330 mod1331) (if (null? p1328) (if (null? e1327) r1330 #f) (if (pair? p1328) (if (pair? e1327) (match1321 (car e1327) (car p1328) w1329 (match1321 (cdr e1327) (cdr p1328) w1329 r1330 mod1331) mod1331) #f) (if (eq? p1328 (quote each-any)) (let ((l1332 (match-each-any1318 e1327 w1329 mod1331))) (if l1332 (cons l1332 r1330) #f)) (let ((atom-key1333 (vector-ref p1328 0))) (if (memv atom-key1333 (quote (each))) (if (null? e1327) (match-empty1319 (vector-ref p1328 1) r1330) (let ((l1334 (match-each1317 e1327 (vector-ref p1328 1) w1329 mod1331))) (if l1334 (letrec ((collect1335 (lambda (l1336) (if (null? (car l1336)) r1330 (cons (map car l1336) (collect1335 (map cdr l1336))))))) (collect1335 l1334)) #f))) (if (memv atom-key1333 (quote (free-id))) (if (id?114 e1327) (if (free-id=?137 (wrap142 e1327 w1329 mod1331) (vector-ref p1328 1)) r1330 #f) #f) (if (memv atom-key1333 (quote (atom))) (if (equal? (vector-ref p1328 1) (strip160 e1327 w1329)) r1330 #f) (if (memv atom-key1333 (quote (vector))) (if (vector? e1327) (match1321 (vector->list e1327) (vector-ref p1328 1) w1329 r1330 mod1331) #f))))))))))) (match-empty1319 (lambda (p1337 r1338) (if (null? p1337) r1338 (if (eq? p1337 (quote any)) (cons (quote ()) r1338) (if (pair? p1337) (match-empty1319 (car p1337) (match-empty1319 (cdr p1337) r1338)) (if (eq? p1337 (quote each-any)) (cons (quote ()) r1338) (let ((atom-key1339 (vector-ref p1337 0))) (if (memv atom-key1339 (quote (each))) (match-empty1319 (vector-ref p1337 1) r1338) (if (memv atom-key1339 (quote (free-id atom))) r1338 (if (memv atom-key1339 (quote (vector))) (match-empty1319 (vector-ref p1337 1) r1338))))))))))) (match-each-any1318 (lambda (e1340 w1341 mod1342) (if (pair? e1340) (let ((l1343 (match-each-any1318 (cdr e1340) w1341 mod1342))) (if l1343 (cons (wrap142 (car e1340) w1341 mod1342) l1343) #f)) (if (null? e1340) (quote ()) (if (syntax-object?98 e1340) (match-each-any1318 (syntax-object-expression99 e1340) (join-wraps133 w1341 (syntax-object-wrap100 e1340)) mod1342) #f))))) (match-each1317 (lambda (e1344 p1345 w1346 mod1347) (if (pair? e1344) (let ((first1348 (match1321 (car e1344) p1345 w1346 (quote ()) mod1347))) (if first1348 (let ((rest1349 (match-each1317 (cdr e1344) p1345 w1346 mod1347))) (if rest1349 (cons first1348 rest1349) #f)) #f)) (if (null? e1344) (quote ()) (if (syntax-object?98 e1344) (match-each1317 (syntax-object-expression99 e1344) p1345 (join-wraps133 w1346 (syntax-object-wrap100 e1344)) (syntax-object-module101 e1344)) #f)))))) (set! $sc-dispatch (lambda (e1350 p1351) (if (eq? p1351 (quote any)) (list e1350) (if (syntax-object?98 e1350) (match*1320 (syntax-object-expression99 e1350) p1351 (syntax-object-wrap100 e1350) (quote ()) (syntax-object-module101 e1350)) (match*1320 e1350 p1351 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1352) ((lambda (tmp1353) ((lambda (tmp1354) (if tmp1354 (apply (lambda (_1355 e11356 e21357) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11356 e21357))) tmp1354) ((lambda (tmp1359) (if tmp1359 (apply (lambda (_1360 out1361 in1362 e11363 e21364) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1362 (quote ()) (list out1361 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11363 e21364))))) tmp1359) ((lambda (tmp1366) (if tmp1366 (apply (lambda (_1367 out1368 in1369 e11370 e21371) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1369) (quote ()) (list out1368 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11370 e21371))))) tmp1366) (syntax-violation #f "source expression failed to match any pattern" tmp1353))) ($sc-dispatch tmp1353 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1353 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1353 (quote (any () any . each-any))))) x1352)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1375) ((lambda (tmp1376) ((lambda (tmp1377) (if tmp1377 (apply (lambda (_1378 k1379 keyword1380 pattern1381 template1382) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1379 (map (lambda (tmp1385 tmp1384) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1384) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1385))) template1382 pattern1381)))))) tmp1377) (syntax-violation #f "source expression failed to match any pattern" tmp1376))) ($sc-dispatch tmp1376 (quote (any each-any . #(each ((any . any) any))))))) x1375)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1386) ((lambda (tmp1387) ((lambda (tmp1388) (if (if tmp1388 (apply (lambda (let*1389 x1390 v1391 e11392 e21393) (and-map identifier? x1390)) tmp1388) #f) (apply (lambda (let*1395 x1396 v1397 e11398 e21399) (letrec ((f1400 (lambda (bindings1401) (if (null? bindings1401) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11398 e21399))) ((lambda (tmp1405) ((lambda (tmp1406) (if tmp1406 (apply (lambda (body1407 binding1408) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1408) body1407)) tmp1406) (syntax-violation #f "source expression failed to match any pattern" tmp1405))) ($sc-dispatch tmp1405 (quote (any any))))) (list (f1400 (cdr bindings1401)) (car bindings1401))))))) (f1400 (map list x1396 v1397)))) tmp1388) (syntax-violation #f "source expression failed to match any pattern" tmp1387))) ($sc-dispatch tmp1387 (quote (any #(each (any any)) any . each-any))))) x1386)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1409) ((lambda (tmp1410) ((lambda (tmp1411) (if tmp1411 (apply (lambda (_1412 var1413 init1414 step1415 e01416 e11417 c1418) ((lambda (tmp1419) ((lambda (tmp1420) (if tmp1420 (apply (lambda (step1421) ((lambda (tmp1422) ((lambda (tmp1423) (if tmp1423 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1413 init1414) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01416) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1418 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1421))))))) tmp1423) ((lambda (tmp1428) (if tmp1428 (apply (lambda (e11429 e21430) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1413 init1414) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01416 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11429 e21430)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1418 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1421))))))) tmp1428) (syntax-violation #f "source expression failed to match any pattern" tmp1422))) ($sc-dispatch tmp1422 (quote (any . each-any)))))) ($sc-dispatch tmp1422 (quote ())))) e11417)) tmp1420) (syntax-violation #f "source expression failed to match any pattern" tmp1419))) ($sc-dispatch tmp1419 (quote each-any)))) (map (lambda (v1437 s1438) ((lambda (tmp1439) ((lambda (tmp1440) (if tmp1440 (apply (lambda () v1437) tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (e1442) e1442) tmp1441) ((lambda (_1443) (syntax-violation (quote do) "bad step expression" orig-x1409 s1438)) tmp1439))) ($sc-dispatch tmp1439 (quote (any)))))) ($sc-dispatch tmp1439 (quote ())))) s1438)) var1413 step1415))) tmp1411) (syntax-violation #f "source expression failed to match any pattern" tmp1410))) ($sc-dispatch tmp1410 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1409)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1446 (lambda (x1450 y1451) ((lambda (tmp1452) ((lambda (tmp1453) (if tmp1453 (apply (lambda (x1454 y1455) ((lambda (tmp1456) ((lambda (tmp1457) (if tmp1457 (apply (lambda (dy1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (dx1461) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1461 dy1458))) tmp1460) ((lambda (_1462) (if (null? dy1458) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454 y1455))) tmp1459))) ($sc-dispatch tmp1459 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1454)) tmp1457) ((lambda (tmp1463) (if tmp1463 (apply (lambda (stuff1464) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1454 stuff1464))) tmp1463) ((lambda (else1465) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1454 y1455)) tmp1456))) ($sc-dispatch tmp1456 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1456 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1455)) tmp1453) (syntax-violation #f "source expression failed to match any pattern" tmp1452))) ($sc-dispatch tmp1452 (quote (any any))))) (list x1450 y1451)))) (quasiappend1447 (lambda (x1466 y1467) ((lambda (tmp1468) ((lambda (tmp1469) (if tmp1469 (apply (lambda (x1470 y1471) ((lambda (tmp1472) ((lambda (tmp1473) (if tmp1473 (apply (lambda () x1470) tmp1473) ((lambda (_1474) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1470 y1471)) tmp1472))) ($sc-dispatch tmp1472 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1471)) tmp1469) (syntax-violation #f "source expression failed to match any pattern" tmp1468))) ($sc-dispatch tmp1468 (quote (any any))))) (list x1466 y1467)))) (quasivector1448 (lambda (x1475) ((lambda (tmp1476) ((lambda (x1477) ((lambda (tmp1478) ((lambda (tmp1479) (if tmp1479 (apply (lambda (x1480) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1480))) tmp1479) ((lambda (tmp1482) (if tmp1482 (apply (lambda (x1483) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1483)) tmp1482) ((lambda (_1485) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1477)) tmp1478))) ($sc-dispatch tmp1478 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1478 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1477)) tmp1476)) x1475))) (quasi1449 (lambda (p1486 lev1487) ((lambda (tmp1488) ((lambda (tmp1489) (if tmp1489 (apply (lambda (p1490) (if (= lev1487 0) p1490 (quasicons1446 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1449 (list p1490) (- lev1487 1))))) tmp1489) ((lambda (tmp1491) (if (if tmp1491 (apply (lambda (args1492) (= lev1487 0)) tmp1491) #f) (apply (lambda (args1493) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1486 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1493))) tmp1491) ((lambda (tmp1494) (if tmp1494 (apply (lambda (p1495 q1496) (if (= lev1487 0) (quasiappend1447 p1495 (quasi1449 q1496 lev1487)) (quasicons1446 (quasicons1446 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1449 (list p1495) (- lev1487 1))) (quasi1449 q1496 lev1487)))) tmp1494) ((lambda (tmp1497) (if (if tmp1497 (apply (lambda (args1498 q1499) (= lev1487 0)) tmp1497) #f) (apply (lambda (args1500 q1501) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1486 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1500))) tmp1497) ((lambda (tmp1502) (if tmp1502 (apply (lambda (p1503) (quasicons1446 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1449 (list p1503) (+ lev1487 1)))) tmp1502) ((lambda (tmp1504) (if tmp1504 (apply (lambda (p1505 q1506) (quasicons1446 (quasi1449 p1505 lev1487) (quasi1449 q1506 lev1487))) tmp1504) ((lambda (tmp1507) (if tmp1507 (apply (lambda (x1508) (quasivector1448 (quasi1449 x1508 lev1487))) tmp1507) ((lambda (p1510) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1510)) tmp1488))) ($sc-dispatch tmp1488 (quote #(vector each-any)))))) ($sc-dispatch tmp1488 (quote (any . any)))))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1488 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1488 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1488 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1486)))) (lambda (x1511) ((lambda (tmp1512) ((lambda (tmp1513) (if tmp1513 (apply (lambda (_1514 e1515) (quasi1449 e1515 0)) tmp1513) (syntax-violation #f "source expression failed to match any pattern" tmp1512))) ($sc-dispatch tmp1512 (quote (any any))))) x1511))))) -(define include (make-syncase-macro (quote macro) (lambda (x1516) (letrec ((read-file1517 (lambda (fn1518 k1519) (let ((p1520 (open-input-file fn1518))) (letrec ((f1521 (lambda (x1522) (if (eof-object? x1522) (begin (close-input-port p1520) (quote ())) (cons (datum->syntax k1519 x1522) (f1521 (read p1520))))))) (f1521 (read p1520))))))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (k1525 filename1526) (let ((fn1527 (syntax->datum filename1526))) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (exp1530) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1530)) tmp1529) (syntax-violation #f "source expression failed to match any pattern" tmp1528))) ($sc-dispatch tmp1528 (quote each-any)))) (read-file1517 fn1527 k1525)))) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote (any any))))) x1516))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1532) ((lambda (tmp1533) ((lambda (tmp1534) (if tmp1534 (apply (lambda (_1535 e1536) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1532)) tmp1534) (syntax-violation #f "source expression failed to match any pattern" tmp1533))) ($sc-dispatch tmp1533 (quote (any any))))) x1532)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1537) ((lambda (tmp1538) ((lambda (tmp1539) (if tmp1539 (apply (lambda (_1540 e1541) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1537)) tmp1539) (syntax-violation #f "source expression failed to match any pattern" tmp1538))) ($sc-dispatch tmp1538 (quote (any any))))) x1537)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1542) ((lambda (tmp1543) ((lambda (tmp1544) (if tmp1544 (apply (lambda (_1545 e1546 m11547 m21548) ((lambda (tmp1549) ((lambda (body1550) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1546)) body1550)) tmp1549)) (letrec ((f1551 (lambda (clause1552 clauses1553) (if (null? clauses1553) ((lambda (tmp1555) ((lambda (tmp1556) (if tmp1556 (apply (lambda (e11557 e21558) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11557 e21558))) tmp1556) ((lambda (tmp1560) (if tmp1560 (apply (lambda (k1561 e11562 e21563) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1561)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11562 e21563)))) tmp1560) ((lambda (_1566) (syntax-violation (quote case) "bad clause" x1542 clause1552)) tmp1555))) ($sc-dispatch tmp1555 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1555 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1552) ((lambda (tmp1567) ((lambda (rest1568) ((lambda (tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (k1571 e11572 e21573) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1571)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11572 e21573)) rest1568)) tmp1570) ((lambda (_1576) (syntax-violation (quote case) "bad clause" x1542 clause1552)) tmp1569))) ($sc-dispatch tmp1569 (quote (each-any any . each-any))))) clause1552)) tmp1567)) (f1551 (car clauses1553) (cdr clauses1553))))))) (f1551 m11547 m21548)))) tmp1544) (syntax-violation #f "source expression failed to match any pattern" tmp1543))) ($sc-dispatch tmp1543 (quote (any any any . each-any))))) x1542)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1577) ((lambda (tmp1578) ((lambda (tmp1579) (if tmp1579 (apply (lambda (_1580 e1581) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1581)) (list (cons _1580 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1581 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1579) (syntax-violation #f "source expression failed to match any pattern" tmp1578))) ($sc-dispatch tmp1578 (quote (any any))))) x1577)))) +(letrec ((and-map*1328 (lambda (f1368 first1367 . rest1366) (let ((t1369 (null? first1367))) (if t1369 t1369 (if (null? rest1366) (letrec ((andmap1370 (lambda (first1371) (let ((x1372 (car first1371)) (first1373 (cdr first1371))) (if (null? first1373) (f1368 x1372) (if (f1368 x1372) (andmap1370 first1373) #f)))))) (andmap1370 first1367)) (letrec ((andmap1374 (lambda (first1375 rest1376) (let ((x1377 (car first1375)) (xr1378 (map car rest1376)) (first1379 (cdr first1375)) (rest1380 (map cdr rest1376))) (if (null? first1379) (apply f1368 (cons x1377 xr1378)) (if (apply f1368 (cons x1377 xr1378)) (andmap1374 first1379 rest1380) #f)))))) (andmap1374 first1367 rest1366)))))))) (letrec ((lambda-var-list1473 (lambda (vars1597) (letrec ((lvl1598 (lambda (vars1599 ls1600 w1601) (if (pair? vars1599) (lvl1598 (cdr vars1599) (cons (wrap1453 (car vars1599) w1601 #f) ls1600) w1601) (if (id?1425 vars1599) (cons (wrap1453 vars1599 w1601 #f) ls1600) (if (null? vars1599) ls1600 (if (syntax-object?1409 vars1599) (lvl1598 (syntax-object-expression1410 vars1599) ls1600 (join-wraps1444 w1601 (syntax-object-wrap1411 vars1599))) (cons vars1599 ls1600)))))))) (lvl1598 vars1597 (quote ()) (quote (())))))) (gen-var1472 (lambda (id1602) (let ((id1603 (if (syntax-object?1409 id1602) (syntax-object-expression1410 id1602) id1602))) (gensym (symbol->string id1603))))) (strip1471 (lambda (x1604 w1605) (if (memq (quote top) (wrap-marks1428 w1605)) x1604 (letrec ((f1606 (lambda (x1607) (if (syntax-object?1409 x1607) (strip1471 (syntax-object-expression1410 x1607) (syntax-object-wrap1411 x1607)) (if (pair? x1607) (let ((a1608 (f1606 (car x1607))) (d1609 (f1606 (cdr x1607)))) (if (if (eq? a1608 (car x1607)) (eq? d1609 (cdr x1607)) #f) x1607 (cons a1608 d1609))) (if (vector? x1607) (let ((old1610 (vector->list x1607))) (let ((new1611 (map f1606 old1610))) (if (and-map*1328 eq? old1610 new1611) x1607 (list->vector new1611)))) x1607)))))) (f1606 x1604))))) (ellipsis?1470 (lambda (x1612) (if (nonsymbol-id?1424 x1612) (free-id=?1448 x1612 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void1469 (lambda () (build-void1391 #f))) (eval-local-transformer1468 (lambda (expanded1613 mod1614) (let ((p1615 (local-eval-hook1388 expanded1613 mod1614))) (if (procedure? p1615) p1615 (syntax-violation #f "nonprocedure transformer" p1615))))) (chi-local-syntax1467 (lambda (rec?1616 e1617 r1618 w1619 s1620 mod1621 k1622) ((lambda (tmp1623) ((lambda (tmp1624) (if tmp1624 (apply (lambda (_1625 id1626 val1627 e11628 e21629) (let ((ids1630 id1626)) (if (not (valid-bound-ids?1450 ids1630)) (syntax-violation #f "duplicate bound keyword" e1617) (let ((labels1632 (gen-labels1431 ids1630))) (let ((new-w1633 (make-binding-wrap1442 ids1630 labels1632 w1619))) (k1622 (cons e11628 e21629) (extend-env1419 labels1632 (let ((w1635 (if rec?1616 new-w1633 w1619)) (trans-r1636 (macros-only-env1421 r1618))) (map (lambda (x1637) (cons (quote macro) (eval-local-transformer1468 (chi1461 x1637 trans-r1636 w1635 mod1621) mod1621))) val1627)) r1618) new-w1633 s1620 mod1621)))))) tmp1624) ((lambda (_1639) (syntax-violation #f "bad local syntax definition" (source-wrap1454 e1617 w1619 s1620 mod1621))) tmp1623))) ($sc-dispatch tmp1623 (quote (any #(each (any any)) any . each-any))))) e1617))) (chi-lambda-clause1466 (lambda (e1640 docstring1641 c1642 r1643 w1644 mod1645 k1646) ((lambda (tmp1647) ((lambda (tmp1648) (if (if tmp1648 (apply (lambda (args1649 doc1650 e11651 e21652) (if (string? (syntax->datum doc1650)) (not docstring1641) #f)) tmp1648) #f) (apply (lambda (args1653 doc1654 e11655 e21656) (chi-lambda-clause1466 e1640 doc1654 (cons args1653 (cons e11655 e21656)) r1643 w1644 mod1645 k1646)) tmp1648) ((lambda (tmp1658) (if tmp1658 (apply (lambda (id1659 e11660 e21661) (let ((ids1662 id1659)) (if (not (valid-bound-ids?1450 ids1662)) (syntax-violation (quote lambda) "invalid parameter list" e1640) (let ((labels1664 (gen-labels1431 ids1662)) (new-vars1665 (map gen-var1472 ids1662))) (k1646 (map syntax->datum ids1662) new-vars1665 (if docstring1641 (syntax->datum docstring1641) #f) (chi-body1465 (cons e11660 e21661) e1640 (extend-var-env1420 labels1664 new-vars1665 r1643) (make-binding-wrap1442 ids1662 labels1664 w1644) mod1645)))))) tmp1658) ((lambda (tmp1667) (if tmp1667 (apply (lambda (ids1668 e11669 e21670) (let ((old-ids1671 (lambda-var-list1473 ids1668))) (if (not (valid-bound-ids?1450 old-ids1671)) (syntax-violation (quote lambda) "invalid parameter list" e1640) (let ((labels1672 (gen-labels1431 old-ids1671)) (new-vars1673 (map gen-var1472 old-ids1671))) (k1646 (letrec ((f1674 (lambda (ls11675 ls21676) (if (null? ls11675) (syntax->datum ls21676) (f1674 (cdr ls11675) (cons (syntax->datum (car ls11675)) ls21676)))))) (f1674 (cdr old-ids1671) (car old-ids1671))) (letrec ((f1677 (lambda (ls11678 ls21679) (if (null? ls11678) ls21679 (f1677 (cdr ls11678) (cons (car ls11678) ls21679)))))) (f1677 (cdr new-vars1673) (car new-vars1673))) (if docstring1641 (syntax->datum docstring1641) #f) (chi-body1465 (cons e11669 e21670) e1640 (extend-var-env1420 labels1672 new-vars1673 r1643) (make-binding-wrap1442 old-ids1671 labels1672 w1644) mod1645)))))) tmp1667) ((lambda (_1681) (syntax-violation (quote lambda) "bad lambda" e1640)) tmp1647))) ($sc-dispatch tmp1647 (quote (any any . each-any)))))) ($sc-dispatch tmp1647 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1647 (quote (any any any . each-any))))) c1642))) (chi-body1465 (lambda (body1682 outer-form1683 r1684 w1685 mod1686) (let ((r1687 (cons (quote ("placeholder" placeholder)) r1684))) (let ((ribcage1688 (make-ribcage1432 (quote ()) (quote ()) (quote ())))) (let ((w1689 (make-wrap1427 (wrap-marks1428 w1685) (cons ribcage1688 (wrap-subst1429 w1685))))) (letrec ((parse1690 (lambda (body1691 ids1692 labels1693 var-ids1694 vars1695 vals1696 bindings1697) (if (null? body1691) (syntax-violation #f "no expressions in body" outer-form1683) (let ((e1699 (cdar body1691)) (er1700 (caar body1691))) (call-with-values (lambda () (syntax-type1459 e1699 er1700 (quote (())) (source-annotation1416 er1700) ribcage1688 mod1686 #f)) (lambda (type1701 value1702 e1703 w1704 s1705 mod1706) (if (memv type1701 (quote (define-form))) (let ((id1707 (wrap1453 value1702 w1704 mod1706)) (label1708 (gen-label1430))) (let ((var1709 (gen-var1472 id1707))) (begin (extend-ribcage!1441 ribcage1688 id1707 label1708) (parse1690 (cdr body1691) (cons id1707 ids1692) (cons label1708 labels1693) (cons id1707 var-ids1694) (cons var1709 vars1695) (cons (cons er1700 (wrap1453 e1703 w1704 mod1706)) vals1696) (cons (cons (quote lexical) var1709) bindings1697))))) (if (memv type1701 (quote (define-syntax-form))) (let ((id1710 (wrap1453 value1702 w1704 mod1706)) (label1711 (gen-label1430))) (begin (extend-ribcage!1441 ribcage1688 id1710 label1711) (parse1690 (cdr body1691) (cons id1710 ids1692) (cons label1711 labels1693) var-ids1694 vars1695 vals1696 (cons (cons (quote macro) (cons er1700 (wrap1453 e1703 w1704 mod1706))) bindings1697)))) (if (memv type1701 (quote (begin-form))) ((lambda (tmp1712) ((lambda (tmp1713) (if tmp1713 (apply (lambda (_1714 e11715) (parse1690 (letrec ((f1716 (lambda (forms1717) (if (null? forms1717) (cdr body1691) (cons (cons er1700 (wrap1453 (car forms1717) w1704 mod1706)) (f1716 (cdr forms1717))))))) (f1716 e11715)) ids1692 labels1693 var-ids1694 vars1695 vals1696 bindings1697)) tmp1713) (syntax-violation #f "source expression failed to match any pattern" tmp1712))) ($sc-dispatch tmp1712 (quote (any . each-any))))) e1703) (if (memv type1701 (quote (local-syntax-form))) (chi-local-syntax1467 value1702 e1703 er1700 w1704 s1705 mod1706 (lambda (forms1719 er1720 w1721 s1722 mod1723) (parse1690 (letrec ((f1724 (lambda (forms1725) (if (null? forms1725) (cdr body1691) (cons (cons er1720 (wrap1453 (car forms1725) w1721 mod1723)) (f1724 (cdr forms1725))))))) (f1724 forms1719)) ids1692 labels1693 var-ids1694 vars1695 vals1696 bindings1697))) (if (null? ids1692) (build-sequence1404 #f (map (lambda (x1726) (chi1461 (cdr x1726) (car x1726) (quote (())) mod1706)) (cons (cons er1700 (source-wrap1454 e1703 w1704 s1705 mod1706)) (cdr body1691)))) (begin (if (not (valid-bound-ids?1450 ids1692)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1683)) (letrec ((loop1727 (lambda (bs1728 er-cache1729 r-cache1730) (if (not (null? bs1728)) (let ((b1731 (car bs1728))) (if (eq? (car b1731) (quote macro)) (let ((er1732 (cadr b1731))) (let ((r-cache1733 (if (eq? er1732 er-cache1729) r-cache1730 (macros-only-env1421 er1732)))) (begin (set-cdr! b1731 (eval-local-transformer1468 (chi1461 (cddr b1731) r-cache1733 (quote (())) mod1706) mod1706)) (loop1727 (cdr bs1728) er1732 r-cache1733)))) (loop1727 (cdr bs1728) er-cache1729 r-cache1730))))))) (loop1727 bindings1697 #f #f)) (set-cdr! r1687 (extend-env1419 labels1693 bindings1697 (cdr r1687))) (build-letrec1407 #f (map syntax->datum var-ids1694) vars1695 (map (lambda (x1734) (chi1461 (cdr x1734) (car x1734) (quote (())) mod1706)) vals1696) (build-sequence1404 #f (map (lambda (x1735) (chi1461 (cdr x1735) (car x1735) (quote (())) mod1706)) (cons (cons er1700 (source-wrap1454 e1703 w1704 s1705 mod1706)) (cdr body1691)))))))))))))))))) (parse1690 (map (lambda (x1698) (cons r1687 (wrap1453 x1698 w1689 mod1686))) body1682) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro1464 (lambda (p1736 e1737 r1738 w1739 rib1740 mod1741) (letrec ((rebuild-macro-output1742 (lambda (x1743 m1744) (if (pair? x1743) (cons (rebuild-macro-output1742 (car x1743) m1744) (rebuild-macro-output1742 (cdr x1743) m1744)) (if (syntax-object?1409 x1743) (let ((w1745 (syntax-object-wrap1411 x1743))) (let ((ms1746 (wrap-marks1428 w1745)) (s1747 (wrap-subst1429 w1745))) (if (if (pair? ms1746) (eq? (car ms1746) #f) #f) (make-syntax-object1408 (syntax-object-expression1410 x1743) (make-wrap1427 (cdr ms1746) (if rib1740 (cons rib1740 (cdr s1747)) (cdr s1747))) (syntax-object-module1412 x1743)) (make-syntax-object1408 (syntax-object-expression1410 x1743) (make-wrap1427 (cons m1744 ms1746) (if rib1740 (cons rib1740 (cons (quote shift) s1747)) (cons (quote shift) s1747))) (let ((pmod1748 (procedure-module p1736))) (if pmod1748 (cons (quote hygiene) (module-name pmod1748)) (quote (hygiene guile)))))))) (if (vector? x1743) (let ((n1749 (vector-length x1743))) (let ((v1750 (make-vector n1749))) (letrec ((loop1751 (lambda (i1752) (if (fx=1385 i1752 n1749) (begin (if #f #f) v1750) (begin (vector-set! v1750 i1752 (rebuild-macro-output1742 (vector-ref x1743 i1752) m1744)) (loop1751 (fx+1383 i1752 1))))))) (loop1751 0)))) (if (symbol? x1743) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1454 e1737 w1739 s mod1741) x1743) x1743))))))) (rebuild-macro-output1742 (p1736 (wrap1453 e1737 (anti-mark1440 w1739) mod1741)) (string #\m))))) (chi-application1463 (lambda (x1753 e1754 r1755 w1756 s1757 mod1758) ((lambda (tmp1759) ((lambda (tmp1760) (if tmp1760 (apply (lambda (e01761 e11762) (build-application1392 s1757 x1753 (map (lambda (e1763) (chi1461 e1763 r1755 w1756 mod1758)) e11762))) tmp1760) (syntax-violation #f "source expression failed to match any pattern" tmp1759))) ($sc-dispatch tmp1759 (quote (any . each-any))))) e1754))) (chi-expr1462 (lambda (type1765 value1766 e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (lexical))) (build-lexical-reference1394 (quote value) s1770 e1767 value1766) (if (memv type1765 (quote (core core-form))) (value1766 e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (module-ref))) (call-with-values (lambda () (value1766 e1767)) (lambda (id1772 mod1773) (build-global-reference1397 s1770 id1772 mod1773))) (if (memv type1765 (quote (lexical-call))) (chi-application1463 (build-lexical-reference1394 (quote fun) (source-annotation1416 (car e1767)) (car e1767) value1766) e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (global-call))) (chi-application1463 (build-global-reference1397 (source-annotation1416 (car e1767)) (if (syntax-object?1409 value1766) (syntax-object-expression1410 value1766) value1766) (if (syntax-object?1409 value1766) (syntax-object-module1412 value1766) mod1771)) e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (constant))) (build-data1403 s1770 (strip1471 (source-wrap1454 e1767 w1769 s1770 mod1771) (quote (())))) (if (memv type1765 (quote (global))) (build-global-reference1397 s1770 value1766 mod1771) (if (memv type1765 (quote (call))) (chi-application1463 (chi1461 (car e1767) r1768 w1769 mod1771) e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (begin-form))) ((lambda (tmp1774) ((lambda (tmp1775) (if tmp1775 (apply (lambda (_1776 e11777 e21778) (chi-sequence1455 (cons e11777 e21778) r1768 w1769 s1770 mod1771)) tmp1775) (syntax-violation #f "source expression failed to match any pattern" tmp1774))) ($sc-dispatch tmp1774 (quote (any any . each-any))))) e1767) (if (memv type1765 (quote (local-syntax-form))) (chi-local-syntax1467 value1766 e1767 r1768 w1769 s1770 mod1771 chi-sequence1455) (if (memv type1765 (quote (eval-when-form))) ((lambda (tmp1780) ((lambda (tmp1781) (if tmp1781 (apply (lambda (_1782 x1783 e11784 e21785) (let ((when-list1786 (chi-when-list1458 e1767 x1783 w1769))) (if (memq (quote eval) when-list1786) (chi-sequence1455 (cons e11784 e21785) r1768 w1769 s1770 mod1771) (chi-void1469)))) tmp1781) (syntax-violation #f "source expression failed to match any pattern" tmp1780))) ($sc-dispatch tmp1780 (quote (any each-any any . each-any))))) e1767) (if (memv type1765 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1767 (wrap1453 value1766 w1769 mod1771)) (if (memv type1765 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1454 e1767 w1769 s1770 mod1771)) (if (memv type1765 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1454 e1767 w1769 s1770 mod1771)) (syntax-violation #f "unexpected syntax" (source-wrap1454 e1767 w1769 s1770 mod1771)))))))))))))))))) (chi1461 (lambda (e1789 r1790 w1791 mod1792) (call-with-values (lambda () (syntax-type1459 e1789 r1790 w1791 (source-annotation1416 e1789) #f mod1792 #f)) (lambda (type1793 value1794 e1795 w1796 s1797 mod1798) (chi-expr1462 type1793 value1794 e1795 r1790 w1796 s1797 mod1798))))) (chi-top1460 (lambda (e1799 r1800 w1801 m1802 esew1803 mod1804) (call-with-values (lambda () (syntax-type1459 e1799 r1800 w1801 (source-annotation1416 e1799) #f mod1804 #f)) (lambda (type1812 value1813 e1814 w1815 s1816 mod1817) (if (memv type1812 (quote (begin-form))) ((lambda (tmp1818) ((lambda (tmp1819) (if tmp1819 (apply (lambda (_1820) (chi-void1469)) tmp1819) ((lambda (tmp1821) (if tmp1821 (apply (lambda (_1822 e11823 e21824) (chi-top-sequence1456 (cons e11823 e21824) r1800 w1815 s1816 m1802 esew1803 mod1817)) tmp1821) (syntax-violation #f "source expression failed to match any pattern" tmp1818))) ($sc-dispatch tmp1818 (quote (any any . each-any)))))) ($sc-dispatch tmp1818 (quote (any))))) e1814) (if (memv type1812 (quote (local-syntax-form))) (chi-local-syntax1467 value1813 e1814 r1800 w1815 s1816 mod1817 (lambda (body1826 r1827 w1828 s1829 mod1830) (chi-top-sequence1456 body1826 r1827 w1828 s1829 m1802 esew1803 mod1830))) (if (memv type1812 (quote (eval-when-form))) ((lambda (tmp1831) ((lambda (tmp1832) (if tmp1832 (apply (lambda (_1833 x1834 e11835 e21836) (let ((when-list1837 (chi-when-list1458 e1814 x1834 w1815)) (body1838 (cons e11835 e21836))) (if (eq? m1802 (quote e)) (if (memq (quote eval) when-list1837) (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote e) (quote (eval)) mod1817) (chi-void1469)) (if (memq (quote load) when-list1837) (if (let ((t1841 (memq (quote compile) when-list1837))) (if t1841 t1841 (if (eq? m1802 (quote c&e)) (memq (quote eval) when-list1837) #f))) (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote c&e) (quote (compile load)) mod1817) (if (memq m1802 (quote (c c&e))) (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote c) (quote (load)) mod1817) (chi-void1469))) (if (let ((t1842 (memq (quote compile) when-list1837))) (if t1842 t1842 (if (eq? m1802 (quote c&e)) (memq (quote eval) when-list1837) #f))) (begin (top-level-eval-hook1387 (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote e) (quote (eval)) mod1817) mod1817) (chi-void1469)) (chi-void1469)))))) tmp1832) (syntax-violation #f "source expression failed to match any pattern" tmp1831))) ($sc-dispatch tmp1831 (quote (any each-any any . each-any))))) e1814) (if (memv type1812 (quote (define-syntax-form))) (let ((n1843 (id-var-name1447 value1813 w1815)) (r1844 (macros-only-env1421 r1800))) (if (memv m1802 (quote (c))) (if (memq (quote compile) esew1803) (let ((e1845 (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)))) (begin (top-level-eval-hook1387 e1845 mod1817) (if (memq (quote load) esew1803) e1845 (chi-void1469)))) (if (memq (quote load) esew1803) (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)) (chi-void1469))) (if (memv m1802 (quote (c&e))) (let ((e1846 (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)))) (begin (top-level-eval-hook1387 e1846 mod1817) e1846)) (begin (if (memq (quote eval) esew1803) (top-level-eval-hook1387 (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)) mod1817)) (chi-void1469))))) (if (memv type1812 (quote (define-form))) (let ((n1847 (id-var-name1447 value1813 w1815))) (let ((type1848 (binding-type1417 (lookup1422 n1847 r1800 mod1817)))) (if (memv type1848 (quote (global core macro module-ref))) (begin (if (if (not (module-local-variable (current-module) n1847)) (current-module) #f) (module-define! (current-module) n1847 #f)) (let ((x1849 (build-global-definition1400 s1816 n1847 (chi1461 e1814 r1800 w1815 mod1817)))) (begin (if (eq? m1802 (quote c&e)) (top-level-eval-hook1387 x1849 mod1817)) x1849))) (if (memv type1848 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1814 (wrap1453 value1813 w1815 mod1817)) (syntax-violation #f "cannot define keyword at top level" e1814 (wrap1453 value1813 w1815 mod1817)))))) (let ((x1850 (chi-expr1462 type1812 value1813 e1814 r1800 w1815 s1816 mod1817))) (begin (if (eq? m1802 (quote c&e)) (top-level-eval-hook1387 x1850 mod1817)) x1850))))))))))) (syntax-type1459 (lambda (e1851 r1852 w1853 s1854 rib1855 mod1856 for-car?1857) (if (symbol? e1851) (let ((n1858 (id-var-name1447 e1851 w1853))) (let ((b1859 (lookup1422 n1858 r1852 mod1856))) (let ((type1860 (binding-type1417 b1859))) (if (memv type1860 (quote (lexical))) (values type1860 (binding-value1418 b1859) e1851 w1853 s1854 mod1856) (if (memv type1860 (quote (global))) (values type1860 n1858 e1851 w1853 s1854 mod1856) (if (memv type1860 (quote (macro))) (if for-car?1857 (values type1860 (binding-value1418 b1859) e1851 w1853 s1854 mod1856) (syntax-type1459 (chi-macro1464 (binding-value1418 b1859) e1851 r1852 w1853 rib1855 mod1856) r1852 (quote (())) s1854 rib1855 mod1856 #f)) (values type1860 (binding-value1418 b1859) e1851 w1853 s1854 mod1856))))))) (if (pair? e1851) (let ((first1861 (car e1851))) (call-with-values (lambda () (syntax-type1459 first1861 r1852 w1853 s1854 rib1855 mod1856 #t)) (lambda (ftype1862 fval1863 fe1864 fw1865 fs1866 fmod1867) (if (memv ftype1862 (quote (lexical))) (values (quote lexical-call) fval1863 e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (global))) (values (quote global-call) (make-syntax-object1408 fval1863 w1853 fmod1867) e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (macro))) (syntax-type1459 (chi-macro1464 fval1863 e1851 r1852 w1853 rib1855 mod1856) r1852 (quote (())) s1854 rib1855 mod1856 for-car?1857) (if (memv ftype1862 (quote (module-ref))) (call-with-values (lambda () (fval1863 e1851)) (lambda (sym1868 mod1869) (syntax-type1459 sym1868 r1852 w1853 s1854 rib1855 mod1869 for-car?1857))) (if (memv ftype1862 (quote (core))) (values (quote core-form) fval1863 e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (local-syntax))) (values (quote local-syntax-form) fval1863 e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (begin))) (values (quote begin-form) #f e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (eval-when))) (values (quote eval-when-form) #f e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (define))) ((lambda (tmp1870) ((lambda (tmp1871) (if (if tmp1871 (apply (lambda (_1872 name1873 val1874) (id?1425 name1873)) tmp1871) #f) (apply (lambda (_1875 name1876 val1877) (values (quote define-form) name1876 val1877 w1853 s1854 mod1856)) tmp1871) ((lambda (tmp1878) (if (if tmp1878 (apply (lambda (_1879 name1880 args1881 e11882 e21883) (if (id?1425 name1880) (valid-bound-ids?1450 (lambda-var-list1473 args1881)) #f)) tmp1878) #f) (apply (lambda (_1884 name1885 args1886 e11887 e21888) (values (quote define-form) (wrap1453 name1885 w1853 mod1856) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1453 (cons args1886 (cons e11887 e21888)) w1853 mod1856)) (quote (())) s1854 mod1856)) tmp1878) ((lambda (tmp1890) (if (if tmp1890 (apply (lambda (_1891 name1892) (id?1425 name1892)) tmp1890) #f) (apply (lambda (_1893 name1894) (values (quote define-form) (wrap1453 name1894 w1853 mod1856) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1854 mod1856)) tmp1890) (syntax-violation #f "source expression failed to match any pattern" tmp1870))) ($sc-dispatch tmp1870 (quote (any any)))))) ($sc-dispatch tmp1870 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1870 (quote (any any any))))) e1851) (if (memv ftype1862 (quote (define-syntax))) ((lambda (tmp1895) ((lambda (tmp1896) (if (if tmp1896 (apply (lambda (_1897 name1898 val1899) (id?1425 name1898)) tmp1896) #f) (apply (lambda (_1900 name1901 val1902) (values (quote define-syntax-form) name1901 val1902 w1853 s1854 mod1856)) tmp1896) (syntax-violation #f "source expression failed to match any pattern" tmp1895))) ($sc-dispatch tmp1895 (quote (any any any))))) e1851) (values (quote call) #f e1851 w1853 s1854 mod1856)))))))))))))) (if (syntax-object?1409 e1851) (syntax-type1459 (syntax-object-expression1410 e1851) r1852 (join-wraps1444 w1853 (syntax-object-wrap1411 e1851)) s1854 rib1855 (let ((t1903 (syntax-object-module1412 e1851))) (if t1903 t1903 mod1856)) for-car?1857) (if (self-evaluating? e1851) (values (quote constant) #f e1851 w1853 s1854 mod1856) (values (quote other) #f e1851 w1853 s1854 mod1856))))))) (chi-when-list1458 (lambda (e1904 when-list1905 w1906) (letrec ((f1907 (lambda (when-list1908 situations1909) (if (null? when-list1908) situations1909 (f1907 (cdr when-list1908) (cons (let ((x1910 (car when-list1908))) (if (free-id=?1448 x1910 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?1448 x1910 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?1448 x1910 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e1904 (wrap1453 x1910 w1906 #f)))))) situations1909)))))) (f1907 when-list1905 (quote ()))))) (chi-install-global1457 (lambda (name1911 e1912) (build-global-definition1400 #f name1911 (if (let ((v1913 (module-variable (current-module) name1911))) (if v1913 (if (variable-bound? v1913) (if (macro? (variable-ref v1913)) (not (eq? (macro-type (variable-ref v1913)) (quote syncase-macro))) #f) #f) #f)) (build-application1392 #f (build-primref1402 #f (quote make-extended-syncase-macro)) (list (build-application1392 #f (build-primref1402 #f (quote module-ref)) (list (build-application1392 #f (build-primref1402 #f (quote current-module)) (quote ())) (build-data1403 #f name1911))) (build-data1403 #f (quote macro)) e1912)) (build-application1392 #f (build-primref1402 #f (quote make-syncase-macro)) (list (build-data1403 #f (quote macro)) e1912)))))) (chi-top-sequence1456 (lambda (body1914 r1915 w1916 s1917 m1918 esew1919 mod1920) (build-sequence1404 s1917 (letrec ((dobody1921 (lambda (body1922 r1923 w1924 m1925 esew1926 mod1927) (if (null? body1922) (quote ()) (let ((first1928 (chi-top1460 (car body1922) r1923 w1924 m1925 esew1926 mod1927))) (cons first1928 (dobody1921 (cdr body1922) r1923 w1924 m1925 esew1926 mod1927))))))) (dobody1921 body1914 r1915 w1916 m1918 esew1919 mod1920))))) (chi-sequence1455 (lambda (body1929 r1930 w1931 s1932 mod1933) (build-sequence1404 s1932 (letrec ((dobody1934 (lambda (body1935 r1936 w1937 mod1938) (if (null? body1935) (quote ()) (let ((first1939 (chi1461 (car body1935) r1936 w1937 mod1938))) (cons first1939 (dobody1934 (cdr body1935) r1936 w1937 mod1938))))))) (dobody1934 body1929 r1930 w1931 mod1933))))) (source-wrap1454 (lambda (x1940 w1941 s1942 defmod1943) (begin (if (if s1942 (pair? x1940) #f) (set-source-properties! x1940 s1942)) (wrap1453 x1940 w1941 defmod1943)))) (wrap1453 (lambda (x1944 w1945 defmod1946) (if (if (null? (wrap-marks1428 w1945)) (null? (wrap-subst1429 w1945)) #f) x1944 (if (syntax-object?1409 x1944) (make-syntax-object1408 (syntax-object-expression1410 x1944) (join-wraps1444 w1945 (syntax-object-wrap1411 x1944)) (syntax-object-module1412 x1944)) (if (null? x1944) x1944 (make-syntax-object1408 x1944 w1945 defmod1946)))))) (bound-id-member?1452 (lambda (x1947 list1948) (if (not (null? list1948)) (let ((t1949 (bound-id=?1449 x1947 (car list1948)))) (if t1949 t1949 (bound-id-member?1452 x1947 (cdr list1948)))) #f))) (distinct-bound-ids?1451 (lambda (ids1950) (letrec ((distinct?1951 (lambda (ids1952) (let ((t1953 (null? ids1952))) (if t1953 t1953 (if (not (bound-id-member?1452 (car ids1952) (cdr ids1952))) (distinct?1951 (cdr ids1952)) #f)))))) (distinct?1951 ids1950)))) (valid-bound-ids?1450 (lambda (ids1954) (if (letrec ((all-ids?1955 (lambda (ids1956) (let ((t1957 (null? ids1956))) (if t1957 t1957 (if (id?1425 (car ids1956)) (all-ids?1955 (cdr ids1956)) #f)))))) (all-ids?1955 ids1954)) (distinct-bound-ids?1451 ids1954) #f))) (bound-id=?1449 (lambda (i1958 j1959) (if (if (syntax-object?1409 i1958) (syntax-object?1409 j1959) #f) (if (eq? (syntax-object-expression1410 i1958) (syntax-object-expression1410 j1959)) (same-marks?1446 (wrap-marks1428 (syntax-object-wrap1411 i1958)) (wrap-marks1428 (syntax-object-wrap1411 j1959))) #f) (eq? i1958 j1959)))) (free-id=?1448 (lambda (i1960 j1961) (if (eq? (let ((x1962 i1960)) (if (syntax-object?1409 x1962) (syntax-object-expression1410 x1962) x1962)) (let ((x1963 j1961)) (if (syntax-object?1409 x1963) (syntax-object-expression1410 x1963) x1963))) (eq? (id-var-name1447 i1960 (quote (()))) (id-var-name1447 j1961 (quote (())))) #f))) (id-var-name1447 (lambda (id1964 w1965) (letrec ((search-vector-rib1968 (lambda (sym1974 subst1975 marks1976 symnames1977 ribcage1978) (let ((n1979 (vector-length symnames1977))) (letrec ((f1980 (lambda (i1981) (if (fx=1385 i1981 n1979) (search1966 sym1974 (cdr subst1975) marks1976) (if (if (eq? (vector-ref symnames1977 i1981) sym1974) (same-marks?1446 marks1976 (vector-ref (ribcage-marks1435 ribcage1978) i1981)) #f) (values (vector-ref (ribcage-labels1436 ribcage1978) i1981) marks1976) (f1980 (fx+1383 i1981 1))))))) (f1980 0))))) (search-list-rib1967 (lambda (sym1982 subst1983 marks1984 symnames1985 ribcage1986) (letrec ((f1987 (lambda (symnames1988 i1989) (if (null? symnames1988) (search1966 sym1982 (cdr subst1983) marks1984) (if (if (eq? (car symnames1988) sym1982) (same-marks?1446 marks1984 (list-ref (ribcage-marks1435 ribcage1986) i1989)) #f) (values (list-ref (ribcage-labels1436 ribcage1986) i1989) marks1984) (f1987 (cdr symnames1988) (fx+1383 i1989 1))))))) (f1987 symnames1985 0)))) (search1966 (lambda (sym1990 subst1991 marks1992) (if (null? subst1991) (values #f marks1992) (let ((fst1993 (car subst1991))) (if (eq? fst1993 (quote shift)) (search1966 sym1990 (cdr subst1991) (cdr marks1992)) (let ((symnames1994 (ribcage-symnames1434 fst1993))) (if (vector? symnames1994) (search-vector-rib1968 sym1990 subst1991 marks1992 symnames1994 fst1993) (search-list-rib1967 sym1990 subst1991 marks1992 symnames1994 fst1993))))))))) (if (symbol? id1964) (let ((t1995 (call-with-values (lambda () (search1966 id1964 (wrap-subst1429 w1965) (wrap-marks1428 w1965))) (lambda (x1997 . ignore1996) x1997)))) (if t1995 t1995 id1964)) (if (syntax-object?1409 id1964) (let ((id1998 (syntax-object-expression1410 id1964)) (w11999 (syntax-object-wrap1411 id1964))) (let ((marks2000 (join-marks1445 (wrap-marks1428 w1965) (wrap-marks1428 w11999)))) (call-with-values (lambda () (search1966 id1998 (wrap-subst1429 w1965) marks2000)) (lambda (new-id2001 marks2002) (let ((t2003 new-id2001)) (if t2003 t2003 (let ((t2004 (call-with-values (lambda () (search1966 id1998 (wrap-subst1429 w11999) marks2002)) (lambda (x2006 . ignore2005) x2006)))) (if t2004 t2004 id1998)))))))) (syntax-violation (quote id-var-name) "invalid id" id1964)))))) (same-marks?1446 (lambda (x2007 y2008) (let ((t2009 (eq? x2007 y2008))) (if t2009 t2009 (if (not (null? x2007)) (if (not (null? y2008)) (if (eq? (car x2007) (car y2008)) (same-marks?1446 (cdr x2007) (cdr y2008)) #f) #f) #f))))) (join-marks1445 (lambda (m12010 m22011) (smart-append1443 m12010 m22011))) (join-wraps1444 (lambda (w12012 w22013) (let ((m12014 (wrap-marks1428 w12012)) (s12015 (wrap-subst1429 w12012))) (if (null? m12014) (if (null? s12015) w22013 (make-wrap1427 (wrap-marks1428 w22013) (smart-append1443 s12015 (wrap-subst1429 w22013)))) (make-wrap1427 (smart-append1443 m12014 (wrap-marks1428 w22013)) (smart-append1443 s12015 (wrap-subst1429 w22013))))))) (smart-append1443 (lambda (m12016 m22017) (if (null? m22017) m12016 (append m12016 m22017)))) (make-binding-wrap1442 (lambda (ids2018 labels2019 w2020) (if (null? ids2018) w2020 (make-wrap1427 (wrap-marks1428 w2020) (cons (let ((labelvec2021 (list->vector labels2019))) (let ((n2022 (vector-length labelvec2021))) (let ((symnamevec2023 (make-vector n2022)) (marksvec2024 (make-vector n2022))) (begin (letrec ((f2025 (lambda (ids2026 i2027) (if (not (null? ids2026)) (call-with-values (lambda () (id-sym-name&marks1426 (car ids2026) w2020)) (lambda (symname2028 marks2029) (begin (vector-set! symnamevec2023 i2027 symname2028) (vector-set! marksvec2024 i2027 marks2029) (f2025 (cdr ids2026) (fx+1383 i2027 1))))))))) (f2025 ids2018 0)) (make-ribcage1432 symnamevec2023 marksvec2024 labelvec2021))))) (wrap-subst1429 w2020)))))) (extend-ribcage!1441 (lambda (ribcage2030 id2031 label2032) (begin (set-ribcage-symnames!1437 ribcage2030 (cons (syntax-object-expression1410 id2031) (ribcage-symnames1434 ribcage2030))) (set-ribcage-marks!1438 ribcage2030 (cons (wrap-marks1428 (syntax-object-wrap1411 id2031)) (ribcage-marks1435 ribcage2030))) (set-ribcage-labels!1439 ribcage2030 (cons label2032 (ribcage-labels1436 ribcage2030)))))) (anti-mark1440 (lambda (w2033) (make-wrap1427 (cons #f (wrap-marks1428 w2033)) (cons (quote shift) (wrap-subst1429 w2033))))) (set-ribcage-labels!1439 (lambda (x2034 update2035) (vector-set! x2034 3 update2035))) (set-ribcage-marks!1438 (lambda (x2036 update2037) (vector-set! x2036 2 update2037))) (set-ribcage-symnames!1437 (lambda (x2038 update2039) (vector-set! x2038 1 update2039))) (ribcage-labels1436 (lambda (x2040) (vector-ref x2040 3))) (ribcage-marks1435 (lambda (x2041) (vector-ref x2041 2))) (ribcage-symnames1434 (lambda (x2042) (vector-ref x2042 1))) (ribcage?1433 (lambda (x2043) (if (vector? x2043) (if (= (vector-length x2043) 4) (eq? (vector-ref x2043 0) (quote ribcage)) #f) #f))) (make-ribcage1432 (lambda (symnames2044 marks2045 labels2046) (vector (quote ribcage) symnames2044 marks2045 labels2046))) (gen-labels1431 (lambda (ls2047) (if (null? ls2047) (quote ()) (cons (gen-label1430) (gen-labels1431 (cdr ls2047)))))) (gen-label1430 (lambda () (string #\i))) (wrap-subst1429 cdr) (wrap-marks1428 car) (make-wrap1427 cons) (id-sym-name&marks1426 (lambda (x2048 w2049) (if (syntax-object?1409 x2048) (values (syntax-object-expression1410 x2048) (join-marks1445 (wrap-marks1428 w2049) (wrap-marks1428 (syntax-object-wrap1411 x2048)))) (values x2048 (wrap-marks1428 w2049))))) (id?1425 (lambda (x2050) (if (symbol? x2050) #t (if (syntax-object?1409 x2050) (symbol? (syntax-object-expression1410 x2050)) #f)))) (nonsymbol-id?1424 (lambda (x2051) (if (syntax-object?1409 x2051) (symbol? (syntax-object-expression1410 x2051)) #f))) (global-extend1423 (lambda (type2052 sym2053 val2054) (put-global-definition-hook1389 sym2053 type2052 val2054))) (lookup1422 (lambda (x2055 r2056 mod2057) (let ((t2058 (assq x2055 r2056))) (if t2058 (cdr t2058) (if (symbol? x2055) (let ((t2059 (get-global-definition-hook1390 x2055 mod2057))) (if t2059 t2059 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env1421 (lambda (r2060) (if (null? r2060) (quote ()) (let ((a2061 (car r2060))) (if (eq? (cadr a2061) (quote macro)) (cons a2061 (macros-only-env1421 (cdr r2060))) (macros-only-env1421 (cdr r2060))))))) (extend-var-env1420 (lambda (labels2062 vars2063 r2064) (if (null? labels2062) r2064 (extend-var-env1420 (cdr labels2062) (cdr vars2063) (cons (cons (car labels2062) (cons (quote lexical) (car vars2063))) r2064))))) (extend-env1419 (lambda (labels2065 bindings2066 r2067) (if (null? labels2065) r2067 (extend-env1419 (cdr labels2065) (cdr bindings2066) (cons (cons (car labels2065) (car bindings2066)) r2067))))) (binding-value1418 cdr) (binding-type1417 car) (source-annotation1416 (lambda (x2068) (if (syntax-object?1409 x2068) (source-annotation1416 (syntax-object-expression1410 x2068)) (if (pair? x2068) (let ((props2069 (source-properties x2068))) (if (pair? props2069) props2069 #f)) #f)))) (set-syntax-object-module!1415 (lambda (x2070 update2071) (vector-set! x2070 3 update2071))) (set-syntax-object-wrap!1414 (lambda (x2072 update2073) (vector-set! x2072 2 update2073))) (set-syntax-object-expression!1413 (lambda (x2074 update2075) (vector-set! x2074 1 update2075))) (syntax-object-module1412 (lambda (x2076) (vector-ref x2076 3))) (syntax-object-wrap1411 (lambda (x2077) (vector-ref x2077 2))) (syntax-object-expression1410 (lambda (x2078) (vector-ref x2078 1))) (syntax-object?1409 (lambda (x2079) (if (vector? x2079) (if (= (vector-length x2079) 4) (eq? (vector-ref x2079 0) (quote syntax-object)) #f) #f))) (make-syntax-object1408 (lambda (expression2080 wrap2081 module2082) (vector (quote syntax-object) expression2080 wrap2081 module2082))) (build-letrec1407 (lambda (src2083 ids2084 vars2085 val-exps2086 body-exp2087) (if (null? vars2085) body-exp2087 (let ((atom-key2088 (fluid-ref *mode*1382))) (if (memv atom-key2088 (quote (c))) (begin (for-each maybe-name-value!1399 ids2084 val-exps2086) ((@ (language tree-il) make-letrec) src2083 ids2084 vars2085 val-exps2086 body-exp2087)) (list (quote letrec) (map list vars2085 val-exps2086) body-exp2087)))))) (build-named-let1406 (lambda (src2089 ids2090 vars2091 val-exps2092 body-exp2093) (let ((f2094 (car vars2091)) (f-name2095 (car ids2090)) (vars2096 (cdr vars2091)) (ids2097 (cdr ids2090))) (let ((atom-key2098 (fluid-ref *mode*1382))) (if (memv atom-key2098 (quote (c))) (let ((proc2099 (build-lambda1401 src2089 ids2097 vars2096 #f body-exp2093))) (begin (maybe-name-value!1399 f-name2095 proc2099) (for-each maybe-name-value!1399 ids2097 val-exps2092) ((@ (language tree-il) make-letrec) src2089 (list f-name2095) (list f2094) (list proc2099) (build-application1392 src2089 (build-lexical-reference1394 (quote fun) src2089 f-name2095 f2094) val-exps2092)))) (list (quote let) f2094 (map list vars2096 val-exps2092) body-exp2093)))))) (build-let1405 (lambda (src2100 ids2101 vars2102 val-exps2103 body-exp2104) (if (null? vars2102) body-exp2104 (let ((atom-key2105 (fluid-ref *mode*1382))) (if (memv atom-key2105 (quote (c))) (begin (for-each maybe-name-value!1399 ids2101 val-exps2103) ((@ (language tree-il) make-let) src2100 ids2101 vars2102 val-exps2103 body-exp2104)) (list (quote let) (map list vars2102 val-exps2103) body-exp2104)))))) (build-sequence1404 (lambda (src2106 exps2107) (if (null? (cdr exps2107)) (car exps2107) (let ((atom-key2108 (fluid-ref *mode*1382))) (if (memv atom-key2108 (quote (c))) ((@ (language tree-il) make-sequence) src2106 exps2107) (cons (quote begin) exps2107)))))) (build-data1403 (lambda (src2109 exp2110) (let ((atom-key2111 (fluid-ref *mode*1382))) (if (memv atom-key2111 (quote (c))) ((@ (language tree-il) make-const) src2109 exp2110) (if (if (self-evaluating? exp2110) (not (vector? exp2110)) #f) exp2110 (list (quote quote) exp2110)))))) (build-primref1402 (lambda (src2112 name2113) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2114 (fluid-ref *mode*1382))) (if (memv atom-key2114 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2112 name2113) name2113)) (let ((atom-key2115 (fluid-ref *mode*1382))) (if (memv atom-key2115 (quote (c))) ((@ (language tree-il) make-module-ref) src2112 (quote (guile)) name2113 #f) (list (quote @@) (quote (guile)) name2113)))))) (build-lambda1401 (lambda (src2116 ids2117 vars2118 docstring2119 exp2120) (let ((atom-key2121 (fluid-ref *mode*1382))) (if (memv atom-key2121 (quote (c))) ((@ (language tree-il) make-lambda) src2116 ids2117 vars2118 (if docstring2119 (list (cons (quote documentation) docstring2119)) (quote ())) exp2120) (cons (quote lambda) (cons vars2118 (append (if docstring2119 (list docstring2119) (quote ())) (list exp2120)))))))) (build-global-definition1400 (lambda (source2122 var2123 exp2124) (let ((atom-key2125 (fluid-ref *mode*1382))) (if (memv atom-key2125 (quote (c))) (begin (maybe-name-value!1399 var2123 exp2124) ((@ (language tree-il) make-toplevel-define) source2122 var2123 exp2124)) (list (quote define) var2123 exp2124))))) (maybe-name-value!1399 (lambda (name2126 val2127) (if ((@ (language tree-il) lambda?) val2127) (let ((meta2128 ((@ (language tree-il) lambda-meta) val2127))) (if (not (assq (quote name) meta2128)) ((setter (@ (language tree-il) lambda-meta)) val2127 (acons (quote name) name2126 meta2128))))))) (build-global-assignment1398 (lambda (source2129 var2130 exp2131 mod2132) (analyze-variable1396 mod2132 var2130 (lambda (mod2133 var2134 public?2135) (let ((atom-key2136 (fluid-ref *mode*1382))) (if (memv atom-key2136 (quote (c))) ((@ (language tree-il) make-module-set) source2129 mod2133 var2134 public?2135 exp2131) (list (quote set!) (list (if public?2135 (quote @) (quote @@)) mod2133 var2134) exp2131)))) (lambda (var2137) (let ((atom-key2138 (fluid-ref *mode*1382))) (if (memv atom-key2138 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2129 var2137 exp2131) (list (quote set!) var2137 exp2131))))))) (build-global-reference1397 (lambda (source2139 var2140 mod2141) (analyze-variable1396 mod2141 var2140 (lambda (mod2142 var2143 public?2144) (let ((atom-key2145 (fluid-ref *mode*1382))) (if (memv atom-key2145 (quote (c))) ((@ (language tree-il) make-module-ref) source2139 mod2142 var2143 public?2144) (list (if public?2144 (quote @) (quote @@)) mod2142 var2143)))) (lambda (var2146) (let ((atom-key2147 (fluid-ref *mode*1382))) (if (memv atom-key2147 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2139 var2146) var2146)))))) (analyze-variable1396 (lambda (mod2148 var2149 modref-cont2150 bare-cont2151) (if (not mod2148) (bare-cont2151 var2149) (let ((kind2152 (car mod2148)) (mod2153 (cdr mod2148))) (if (memv kind2152 (quote (public))) (modref-cont2150 mod2153 var2149 #t) (if (memv kind2152 (quote (private))) (if (not (equal? mod2153 (module-name (current-module)))) (modref-cont2150 mod2153 var2149 #f) (bare-cont2151 var2149)) (if (memv kind2152 (quote (bare))) (bare-cont2151 var2149) (if (memv kind2152 (quote (hygiene))) (if (if (not (equal? mod2153 (module-name (current-module)))) (module-variable (resolve-module mod2153) var2149) #f) (modref-cont2150 mod2153 var2149 #f) (bare-cont2151 var2149)) (syntax-violation #f "bad module kind" var2149 mod2153))))))))) (build-lexical-assignment1395 (lambda (source2154 name2155 var2156 exp2157) (let ((atom-key2158 (fluid-ref *mode*1382))) (if (memv atom-key2158 (quote (c))) ((@ (language tree-il) make-lexical-set) source2154 name2155 var2156 exp2157) (list (quote set!) var2156 exp2157))))) (build-lexical-reference1394 (lambda (type2159 source2160 name2161 var2162) (let ((atom-key2163 (fluid-ref *mode*1382))) (if (memv atom-key2163 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2160 name2161 var2162) var2162)))) (build-conditional1393 (lambda (source2164 test-exp2165 then-exp2166 else-exp2167) (let ((atom-key2168 (fluid-ref *mode*1382))) (if (memv atom-key2168 (quote (c))) ((@ (language tree-il) make-conditional) source2164 test-exp2165 then-exp2166 else-exp2167) (if (equal? else-exp2167 (quote (if #f #f))) (list (quote if) test-exp2165 then-exp2166) (list (quote if) test-exp2165 then-exp2166 else-exp2167)))))) (build-application1392 (lambda (source2169 fun-exp2170 arg-exps2171) (let ((atom-key2172 (fluid-ref *mode*1382))) (if (memv atom-key2172 (quote (c))) ((@ (language tree-il) make-application) source2169 fun-exp2170 arg-exps2171) (cons fun-exp2170 arg-exps2171))))) (build-void1391 (lambda (source2173) (let ((atom-key2174 (fluid-ref *mode*1382))) (if (memv atom-key2174 (quote (c))) ((@ (language tree-il) make-void) source2173) (quote (if #f #f)))))) (get-global-definition-hook1390 (lambda (symbol2175 module2176) (begin (if (if (not module2176) (current-module) #f) (warn "module system is booted, we should have a module" symbol2175)) (let ((v2177 (module-variable (if module2176 (resolve-module (cdr module2176)) (current-module)) symbol2175))) (if v2177 (if (variable-bound? v2177) (let ((val2178 (variable-ref v2177))) (if (macro? val2178) (if (syncase-macro-type val2178) (cons (syncase-macro-type val2178) (syncase-macro-binding val2178)) #f) #f)) #f) #f))))) (put-global-definition-hook1389 (lambda (symbol2179 type2180 val2181) (let ((existing2182 (let ((v2183 (module-variable (current-module) symbol2179))) (if v2183 (if (variable-bound? v2183) (let ((val2184 (variable-ref v2183))) (if (macro? val2184) (if (not (syncase-macro-type val2184)) val2184 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2179 (if existing2182 (make-extended-syncase-macro existing2182 type2180 val2181) (make-syncase-macro type2180 val2181)))))) (local-eval-hook1388 (lambda (x2185 mod2186) (primitive-eval (list noexpand1381 (let ((atom-key2187 (fluid-ref *mode*1382))) (if (memv atom-key2187 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2185) x2185)))))) (top-level-eval-hook1387 (lambda (x2188 mod2189) (primitive-eval (list noexpand1381 (let ((atom-key2190 (fluid-ref *mode*1382))) (if (memv atom-key2190 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2188) x2188)))))) (fx<1386 <) (fx=1385 =) (fx-1384 -) (fx+1383 +) (*mode*1382 (make-fluid)) (noexpand1381 "noexpand")) (begin (global-extend1423 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1423 (quote local-syntax) (quote let-syntax) #f) (global-extend1423 (quote core) (quote fluid-let-syntax) (lambda (e2191 r2192 w2193 s2194 mod2195) ((lambda (tmp2196) ((lambda (tmp2197) (if (if tmp2197 (apply (lambda (_2198 var2199 val2200 e12201 e22202) (valid-bound-ids?1450 var2199)) tmp2197) #f) (apply (lambda (_2204 var2205 val2206 e12207 e22208) (let ((names2209 (map (lambda (x2210) (id-var-name1447 x2210 w2193)) var2205))) (begin (for-each (lambda (id2212 n2213) (let ((atom-key2214 (binding-type1417 (lookup1422 n2213 r2192 mod2195)))) (if (memv atom-key2214 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2191 (source-wrap1454 id2212 w2193 s2194 mod2195))))) var2205 names2209) (chi-body1465 (cons e12207 e22208) (source-wrap1454 e2191 w2193 s2194 mod2195) (extend-env1419 names2209 (let ((trans-r2217 (macros-only-env1421 r2192))) (map (lambda (x2218) (cons (quote macro) (eval-local-transformer1468 (chi1461 x2218 trans-r2217 w2193 mod2195) mod2195))) val2206)) r2192) w2193 mod2195)))) tmp2197) ((lambda (_2220) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1454 e2191 w2193 s2194 mod2195))) tmp2196))) ($sc-dispatch tmp2196 (quote (any #(each (any any)) any . each-any))))) e2191))) (global-extend1423 (quote core) (quote quote) (lambda (e2221 r2222 w2223 s2224 mod2225) ((lambda (tmp2226) ((lambda (tmp2227) (if tmp2227 (apply (lambda (_2228 e2229) (build-data1403 s2224 (strip1471 e2229 w2223))) tmp2227) ((lambda (_2230) (syntax-violation (quote quote) "bad syntax" (source-wrap1454 e2221 w2223 s2224 mod2225))) tmp2226))) ($sc-dispatch tmp2226 (quote (any any))))) e2221))) (global-extend1423 (quote core) (quote syntax) (letrec ((regen2238 (lambda (x2239) (let ((atom-key2240 (car x2239))) (if (memv atom-key2240 (quote (ref))) (build-lexical-reference1394 (quote value) #f (cadr x2239) (cadr x2239)) (if (memv atom-key2240 (quote (primitive))) (build-primref1402 #f (cadr x2239)) (if (memv atom-key2240 (quote (quote))) (build-data1403 #f (cadr x2239)) (if (memv atom-key2240 (quote (lambda))) (build-lambda1401 #f (cadr x2239) (cadr x2239) #f (regen2238 (caddr x2239))) (build-application1392 #f (build-primref1402 #f (car x2239)) (map regen2238 (cdr x2239)))))))))) (gen-vector2237 (lambda (x2241) (if (eq? (car x2241) (quote list)) (cons (quote vector) (cdr x2241)) (if (eq? (car x2241) (quote quote)) (list (quote quote) (list->vector (cadr x2241))) (list (quote list->vector) x2241))))) (gen-append2236 (lambda (x2242 y2243) (if (equal? y2243 (quote (quote ()))) x2242 (list (quote append) x2242 y2243)))) (gen-cons2235 (lambda (x2244 y2245) (let ((atom-key2246 (car y2245))) (if (memv atom-key2246 (quote (quote))) (if (eq? (car x2244) (quote quote)) (list (quote quote) (cons (cadr x2244) (cadr y2245))) (if (eq? (cadr y2245) (quote ())) (list (quote list) x2244) (list (quote cons) x2244 y2245))) (if (memv atom-key2246 (quote (list))) (cons (quote list) (cons x2244 (cdr y2245))) (list (quote cons) x2244 y2245)))))) (gen-map2234 (lambda (e2247 map-env2248) (let ((formals2249 (map cdr map-env2248)) (actuals2250 (map (lambda (x2251) (list (quote ref) (car x2251))) map-env2248))) (if (eq? (car e2247) (quote ref)) (car actuals2250) (if (and-map (lambda (x2252) (if (eq? (car x2252) (quote ref)) (memq (cadr x2252) formals2249) #f)) (cdr e2247)) (cons (quote map) (cons (list (quote primitive) (car e2247)) (map (let ((r2253 (map cons formals2249 actuals2250))) (lambda (x2254) (cdr (assq (cadr x2254) r2253)))) (cdr e2247)))) (cons (quote map) (cons (list (quote lambda) formals2249 e2247) actuals2250))))))) (gen-mappend2233 (lambda (e2255 map-env2256) (list (quote apply) (quote (primitive append)) (gen-map2234 e2255 map-env2256)))) (gen-ref2232 (lambda (src2257 var2258 level2259 maps2260) (if (fx=1385 level2259 0) (values var2258 maps2260) (if (null? maps2260) (syntax-violation (quote syntax) "missing ellipsis" src2257) (call-with-values (lambda () (gen-ref2232 src2257 var2258 (fx-1384 level2259 1) (cdr maps2260))) (lambda (outer-var2261 outer-maps2262) (let ((b2263 (assq outer-var2261 (car maps2260)))) (if b2263 (values (cdr b2263) maps2260) (let ((inner-var2264 (gen-var1472 (quote tmp)))) (values inner-var2264 (cons (cons (cons outer-var2261 inner-var2264) (car maps2260)) outer-maps2262))))))))))) (gen-syntax2231 (lambda (src2265 e2266 r2267 maps2268 ellipsis?2269 mod2270) (if (id?1425 e2266) (let ((label2271 (id-var-name1447 e2266 (quote (()))))) (let ((b2272 (lookup1422 label2271 r2267 mod2270))) (if (eq? (binding-type1417 b2272) (quote syntax)) (call-with-values (lambda () (let ((var.lev2273 (binding-value1418 b2272))) (gen-ref2232 src2265 (car var.lev2273) (cdr var.lev2273) maps2268))) (lambda (var2274 maps2275) (values (list (quote ref) var2274) maps2275))) (if (ellipsis?2269 e2266) (syntax-violation (quote syntax) "misplaced ellipsis" src2265) (values (list (quote quote) e2266) maps2268))))) ((lambda (tmp2276) ((lambda (tmp2277) (if (if tmp2277 (apply (lambda (dots2278 e2279) (ellipsis?2269 dots2278)) tmp2277) #f) (apply (lambda (dots2280 e2281) (gen-syntax2231 src2265 e2281 r2267 maps2268 (lambda (x2282) #f) mod2270)) tmp2277) ((lambda (tmp2283) (if (if tmp2283 (apply (lambda (x2284 dots2285 y2286) (ellipsis?2269 dots2285)) tmp2283) #f) (apply (lambda (x2287 dots2288 y2289) (letrec ((f2290 (lambda (y2291 k2292) ((lambda (tmp2296) ((lambda (tmp2297) (if (if tmp2297 (apply (lambda (dots2298 y2299) (ellipsis?2269 dots2298)) tmp2297) #f) (apply (lambda (dots2300 y2301) (f2290 y2301 (lambda (maps2302) (call-with-values (lambda () (k2292 (cons (quote ()) maps2302))) (lambda (x2303 maps2304) (if (null? (car maps2304)) (syntax-violation (quote syntax) "extra ellipsis" src2265) (values (gen-mappend2233 x2303 (car maps2304)) (cdr maps2304)))))))) tmp2297) ((lambda (_2305) (call-with-values (lambda () (gen-syntax2231 src2265 y2291 r2267 maps2268 ellipsis?2269 mod2270)) (lambda (y2306 maps2307) (call-with-values (lambda () (k2292 maps2307)) (lambda (x2308 maps2309) (values (gen-append2236 x2308 y2306) maps2309)))))) tmp2296))) ($sc-dispatch tmp2296 (quote (any . any))))) y2291)))) (f2290 y2289 (lambda (maps2293) (call-with-values (lambda () (gen-syntax2231 src2265 x2287 r2267 (cons (quote ()) maps2293) ellipsis?2269 mod2270)) (lambda (x2294 maps2295) (if (null? (car maps2295)) (syntax-violation (quote syntax) "extra ellipsis" src2265) (values (gen-map2234 x2294 (car maps2295)) (cdr maps2295))))))))) tmp2283) ((lambda (tmp2310) (if tmp2310 (apply (lambda (x2311 y2312) (call-with-values (lambda () (gen-syntax2231 src2265 x2311 r2267 maps2268 ellipsis?2269 mod2270)) (lambda (x2313 maps2314) (call-with-values (lambda () (gen-syntax2231 src2265 y2312 r2267 maps2314 ellipsis?2269 mod2270)) (lambda (y2315 maps2316) (values (gen-cons2235 x2313 y2315) maps2316)))))) tmp2310) ((lambda (tmp2317) (if tmp2317 (apply (lambda (e12318 e22319) (call-with-values (lambda () (gen-syntax2231 src2265 (cons e12318 e22319) r2267 maps2268 ellipsis?2269 mod2270)) (lambda (e2321 maps2322) (values (gen-vector2237 e2321) maps2322)))) tmp2317) ((lambda (_2323) (values (list (quote quote) e2266) maps2268)) tmp2276))) ($sc-dispatch tmp2276 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2276 (quote (any . any)))))) ($sc-dispatch tmp2276 (quote (any any . any)))))) ($sc-dispatch tmp2276 (quote (any any))))) e2266))))) (lambda (e2324 r2325 w2326 s2327 mod2328) (let ((e2329 (source-wrap1454 e2324 w2326 s2327 mod2328))) ((lambda (tmp2330) ((lambda (tmp2331) (if tmp2331 (apply (lambda (_2332 x2333) (call-with-values (lambda () (gen-syntax2231 e2329 x2333 r2325 (quote ()) ellipsis?1470 mod2328)) (lambda (e2334 maps2335) (regen2238 e2334)))) tmp2331) ((lambda (_2336) (syntax-violation (quote syntax) "bad `syntax' form" e2329)) tmp2330))) ($sc-dispatch tmp2330 (quote (any any))))) e2329))))) (global-extend1423 (quote core) (quote lambda) (lambda (e2337 r2338 w2339 s2340 mod2341) ((lambda (tmp2342) ((lambda (tmp2343) (if tmp2343 (apply (lambda (_2344 c2345) (chi-lambda-clause1466 (source-wrap1454 e2337 w2339 s2340 mod2341) #f c2345 r2338 w2339 mod2341 (lambda (names2346 vars2347 docstring2348 body2349) (build-lambda1401 s2340 names2346 vars2347 docstring2348 body2349)))) tmp2343) (syntax-violation #f "source expression failed to match any pattern" tmp2342))) ($sc-dispatch tmp2342 (quote (any . any))))) e2337))) (global-extend1423 (quote core) (quote let) (letrec ((chi-let2350 (lambda (e2351 r2352 w2353 s2354 mod2355 constructor2356 ids2357 vals2358 exps2359) (if (not (valid-bound-ids?1450 ids2357)) (syntax-violation (quote let) "duplicate bound variable" e2351) (let ((labels2360 (gen-labels1431 ids2357)) (new-vars2361 (map gen-var1472 ids2357))) (let ((nw2362 (make-binding-wrap1442 ids2357 labels2360 w2353)) (nr2363 (extend-var-env1420 labels2360 new-vars2361 r2352))) (constructor2356 s2354 (map syntax->datum ids2357) new-vars2361 (map (lambda (x2364) (chi1461 x2364 r2352 w2353 mod2355)) vals2358) (chi-body1465 exps2359 (source-wrap1454 e2351 nw2362 s2354 mod2355) nr2363 nw2362 mod2355)))))))) (lambda (e2365 r2366 w2367 s2368 mod2369) ((lambda (tmp2370) ((lambda (tmp2371) (if (if tmp2371 (apply (lambda (_2372 id2373 val2374 e12375 e22376) (and-map id?1425 id2373)) tmp2371) #f) (apply (lambda (_2378 id2379 val2380 e12381 e22382) (chi-let2350 e2365 r2366 w2367 s2368 mod2369 build-let1405 id2379 val2380 (cons e12381 e22382))) tmp2371) ((lambda (tmp2386) (if (if tmp2386 (apply (lambda (_2387 f2388 id2389 val2390 e12391 e22392) (if (id?1425 f2388) (and-map id?1425 id2389) #f)) tmp2386) #f) (apply (lambda (_2394 f2395 id2396 val2397 e12398 e22399) (chi-let2350 e2365 r2366 w2367 s2368 mod2369 build-named-let1406 (cons f2395 id2396) val2397 (cons e12398 e22399))) tmp2386) ((lambda (_2403) (syntax-violation (quote let) "bad let" (source-wrap1454 e2365 w2367 s2368 mod2369))) tmp2370))) ($sc-dispatch tmp2370 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2370 (quote (any #(each (any any)) any . each-any))))) e2365)))) (global-extend1423 (quote core) (quote letrec) (lambda (e2404 r2405 w2406 s2407 mod2408) ((lambda (tmp2409) ((lambda (tmp2410) (if (if tmp2410 (apply (lambda (_2411 id2412 val2413 e12414 e22415) (and-map id?1425 id2412)) tmp2410) #f) (apply (lambda (_2417 id2418 val2419 e12420 e22421) (let ((ids2422 id2418)) (if (not (valid-bound-ids?1450 ids2422)) (syntax-violation (quote letrec) "duplicate bound variable" e2404) (let ((labels2424 (gen-labels1431 ids2422)) (new-vars2425 (map gen-var1472 ids2422))) (let ((w2426 (make-binding-wrap1442 ids2422 labels2424 w2406)) (r2427 (extend-var-env1420 labels2424 new-vars2425 r2405))) (build-letrec1407 s2407 (map syntax->datum ids2422) new-vars2425 (map (lambda (x2428) (chi1461 x2428 r2427 w2426 mod2408)) val2419) (chi-body1465 (cons e12420 e22421) (source-wrap1454 e2404 w2426 s2407 mod2408) r2427 w2426 mod2408))))))) tmp2410) ((lambda (_2431) (syntax-violation (quote letrec) "bad letrec" (source-wrap1454 e2404 w2406 s2407 mod2408))) tmp2409))) ($sc-dispatch tmp2409 (quote (any #(each (any any)) any . each-any))))) e2404))) (global-extend1423 (quote core) (quote set!) (lambda (e2432 r2433 w2434 s2435 mod2436) ((lambda (tmp2437) ((lambda (tmp2438) (if (if tmp2438 (apply (lambda (_2439 id2440 val2441) (id?1425 id2440)) tmp2438) #f) (apply (lambda (_2442 id2443 val2444) (let ((val2445 (chi1461 val2444 r2433 w2434 mod2436)) (n2446 (id-var-name1447 id2443 w2434))) (let ((b2447 (lookup1422 n2446 r2433 mod2436))) (let ((atom-key2448 (binding-type1417 b2447))) (if (memv atom-key2448 (quote (lexical))) (build-lexical-assignment1395 s2435 (syntax->datum id2443) (binding-value1418 b2447) val2445) (if (memv atom-key2448 (quote (global))) (build-global-assignment1398 s2435 n2446 val2445 mod2436) (if (memv atom-key2448 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1453 id2443 w2434 mod2436)) (syntax-violation (quote set!) "bad set!" (source-wrap1454 e2432 w2434 s2435 mod2436))))))))) tmp2438) ((lambda (tmp2449) (if tmp2449 (apply (lambda (_2450 head2451 tail2452 val2453) (call-with-values (lambda () (syntax-type1459 head2451 r2433 (quote (())) #f #f mod2436 #t)) (lambda (type2454 value2455 ee2456 ww2457 ss2458 modmod2459) (if (memv type2454 (quote (module-ref))) (let ((val2460 (chi1461 val2453 r2433 w2434 mod2436))) (call-with-values (lambda () (value2455 (cons head2451 tail2452))) (lambda (id2462 mod2463) (build-global-assignment1398 s2435 id2462 val2460 mod2463)))) (build-application1392 s2435 (chi1461 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2451) r2433 w2434 mod2436) (map (lambda (e2464) (chi1461 e2464 r2433 w2434 mod2436)) (append tail2452 (list val2453)))))))) tmp2449) ((lambda (_2466) (syntax-violation (quote set!) "bad set!" (source-wrap1454 e2432 w2434 s2435 mod2436))) tmp2437))) ($sc-dispatch tmp2437 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2437 (quote (any any any))))) e2432))) (global-extend1423 (quote module-ref) (quote @) (lambda (e2467) ((lambda (tmp2468) ((lambda (tmp2469) (if (if tmp2469 (apply (lambda (_2470 mod2471 id2472) (if (and-map id?1425 mod2471) (id?1425 id2472) #f)) tmp2469) #f) (apply (lambda (_2474 mod2475 id2476) (values (syntax->datum id2476) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2475)))) tmp2469) (syntax-violation #f "source expression failed to match any pattern" tmp2468))) ($sc-dispatch tmp2468 (quote (any each-any any))))) e2467))) (global-extend1423 (quote module-ref) (quote @@) (lambda (e2478) ((lambda (tmp2479) ((lambda (tmp2480) (if (if tmp2480 (apply (lambda (_2481 mod2482 id2483) (if (and-map id?1425 mod2482) (id?1425 id2483) #f)) tmp2480) #f) (apply (lambda (_2485 mod2486 id2487) (values (syntax->datum id2487) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2486)))) tmp2480) (syntax-violation #f "source expression failed to match any pattern" tmp2479))) ($sc-dispatch tmp2479 (quote (any each-any any))))) e2478))) (global-extend1423 (quote core) (quote if) (lambda (e2489 r2490 w2491 s2492 mod2493) ((lambda (tmp2494) ((lambda (tmp2495) (if tmp2495 (apply (lambda (_2496 test2497 then2498) (build-conditional1393 s2492 (chi1461 test2497 r2490 w2491 mod2493) (chi1461 then2498 r2490 w2491 mod2493) (build-void1391 #f))) tmp2495) ((lambda (tmp2499) (if tmp2499 (apply (lambda (_2500 test2501 then2502 else2503) (build-conditional1393 s2492 (chi1461 test2501 r2490 w2491 mod2493) (chi1461 then2502 r2490 w2491 mod2493) (chi1461 else2503 r2490 w2491 mod2493))) tmp2499) (syntax-violation #f "source expression failed to match any pattern" tmp2494))) ($sc-dispatch tmp2494 (quote (any any any any)))))) ($sc-dispatch tmp2494 (quote (any any any))))) e2489))) (global-extend1423 (quote begin) (quote begin) (quote ())) (global-extend1423 (quote define) (quote define) (quote ())) (global-extend1423 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1423 (quote eval-when) (quote eval-when) (quote ())) (global-extend1423 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2507 (lambda (x2508 keys2509 clauses2510 r2511 mod2512) (if (null? clauses2510) (build-application1392 #f (build-primref1402 #f (quote syntax-violation)) (list (build-data1403 #f #f) (build-data1403 #f "source expression failed to match any pattern") x2508)) ((lambda (tmp2513) ((lambda (tmp2514) (if tmp2514 (apply (lambda (pat2515 exp2516) (if (if (id?1425 pat2515) (and-map (lambda (x2517) (not (free-id=?1448 pat2515 x2517))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2509)) #f) (let ((labels2518 (list (gen-label1430))) (var2519 (gen-var1472 pat2515))) (build-application1392 #f (build-lambda1401 #f (list (syntax->datum pat2515)) (list var2519) #f (chi1461 exp2516 (extend-env1419 labels2518 (list (cons (quote syntax) (cons var2519 0))) r2511) (make-binding-wrap1442 (list pat2515) labels2518 (quote (()))) mod2512)) (list x2508))) (gen-clause2506 x2508 keys2509 (cdr clauses2510) r2511 pat2515 #t exp2516 mod2512))) tmp2514) ((lambda (tmp2520) (if tmp2520 (apply (lambda (pat2521 fender2522 exp2523) (gen-clause2506 x2508 keys2509 (cdr clauses2510) r2511 pat2521 fender2522 exp2523 mod2512)) tmp2520) ((lambda (_2524) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2510))) tmp2513))) ($sc-dispatch tmp2513 (quote (any any any)))))) ($sc-dispatch tmp2513 (quote (any any))))) (car clauses2510))))) (gen-clause2506 (lambda (x2525 keys2526 clauses2527 r2528 pat2529 fender2530 exp2531 mod2532) (call-with-values (lambda () (convert-pattern2504 pat2529 keys2526)) (lambda (p2533 pvars2534) (if (not (distinct-bound-ids?1451 (map car pvars2534))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2529) (if (not (and-map (lambda (x2535) (not (ellipsis?1470 (car x2535)))) pvars2534)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2529) (let ((y2536 (gen-var1472 (quote tmp)))) (build-application1392 #f (build-lambda1401 #f (list (quote tmp)) (list y2536) #f (let ((y2537 (build-lexical-reference1394 (quote value) #f (quote tmp) y2536))) (build-conditional1393 #f ((lambda (tmp2538) ((lambda (tmp2539) (if tmp2539 (apply (lambda () y2537) tmp2539) ((lambda (_2540) (build-conditional1393 #f y2537 (build-dispatch-call2505 pvars2534 fender2530 y2537 r2528 mod2532) (build-data1403 #f #f))) tmp2538))) ($sc-dispatch tmp2538 (quote #(atom #t))))) fender2530) (build-dispatch-call2505 pvars2534 exp2531 y2537 r2528 mod2532) (gen-syntax-case2507 x2525 keys2526 clauses2527 r2528 mod2532)))) (list (if (eq? p2533 (quote any)) (build-application1392 #f (build-primref1402 #f (quote list)) (list x2525)) (build-application1392 #f (build-primref1402 #f (quote $sc-dispatch)) (list x2525 (build-data1403 #f p2533))))))))))))) (build-dispatch-call2505 (lambda (pvars2541 exp2542 y2543 r2544 mod2545) (let ((ids2546 (map car pvars2541)) (levels2547 (map cdr pvars2541))) (let ((labels2548 (gen-labels1431 ids2546)) (new-vars2549 (map gen-var1472 ids2546))) (build-application1392 #f (build-primref1402 #f (quote apply)) (list (build-lambda1401 #f (map syntax->datum ids2546) new-vars2549 #f (chi1461 exp2542 (extend-env1419 labels2548 (map (lambda (var2550 level2551) (cons (quote syntax) (cons var2550 level2551))) new-vars2549 (map cdr pvars2541)) r2544) (make-binding-wrap1442 ids2546 labels2548 (quote (()))) mod2545)) y2543)))))) (convert-pattern2504 (lambda (pattern2552 keys2553) (letrec ((cvt2554 (lambda (p2555 n2556 ids2557) (if (id?1425 p2555) (if (bound-id-member?1452 p2555 keys2553) (values (vector (quote free-id) p2555) ids2557) (values (quote any) (cons (cons p2555 n2556) ids2557))) ((lambda (tmp2558) ((lambda (tmp2559) (if (if tmp2559 (apply (lambda (x2560 dots2561) (ellipsis?1470 dots2561)) tmp2559) #f) (apply (lambda (x2562 dots2563) (call-with-values (lambda () (cvt2554 x2562 (fx+1383 n2556 1) ids2557)) (lambda (p2564 ids2565) (values (if (eq? p2564 (quote any)) (quote each-any) (vector (quote each) p2564)) ids2565)))) tmp2559) ((lambda (tmp2566) (if tmp2566 (apply (lambda (x2567 y2568) (call-with-values (lambda () (cvt2554 y2568 n2556 ids2557)) (lambda (y2569 ids2570) (call-with-values (lambda () (cvt2554 x2567 n2556 ids2570)) (lambda (x2571 ids2572) (values (cons x2571 y2569) ids2572)))))) tmp2566) ((lambda (tmp2573) (if tmp2573 (apply (lambda () (values (quote ()) ids2557)) tmp2573) ((lambda (tmp2574) (if tmp2574 (apply (lambda (x2575) (call-with-values (lambda () (cvt2554 x2575 n2556 ids2557)) (lambda (p2577 ids2578) (values (vector (quote vector) p2577) ids2578)))) tmp2574) ((lambda (x2579) (values (vector (quote atom) (strip1471 p2555 (quote (())))) ids2557)) tmp2558))) ($sc-dispatch tmp2558 (quote #(vector each-any)))))) ($sc-dispatch tmp2558 (quote ()))))) ($sc-dispatch tmp2558 (quote (any . any)))))) ($sc-dispatch tmp2558 (quote (any any))))) p2555))))) (cvt2554 pattern2552 0 (quote ())))))) (lambda (e2580 r2581 w2582 s2583 mod2584) (let ((e2585 (source-wrap1454 e2580 w2582 s2583 mod2584))) ((lambda (tmp2586) ((lambda (tmp2587) (if tmp2587 (apply (lambda (_2588 val2589 key2590 m2591) (if (and-map (lambda (x2592) (if (id?1425 x2592) (not (ellipsis?1470 x2592)) #f)) key2590) (let ((x2594 (gen-var1472 (quote tmp)))) (build-application1392 s2583 (build-lambda1401 #f (list (quote tmp)) (list x2594) #f (gen-syntax-case2507 (build-lexical-reference1394 (quote value) #f (quote tmp) x2594) key2590 m2591 r2581 mod2584)) (list (chi1461 val2589 r2581 (quote (())) mod2584)))) (syntax-violation (quote syntax-case) "invalid literals list" e2585))) tmp2587) (syntax-violation #f "source expression failed to match any pattern" tmp2586))) ($sc-dispatch tmp2586 (quote (any any each-any . each-any))))) e2585))))) (set! sc-expand (lambda (x2598 . rest2597) (if (if (pair? x2598) (equal? (car x2598) noexpand1381) #f) (cadr x2598) (let ((m2599 (if (null? rest2597) (quote e) (car rest2597))) (esew2600 (if (let ((t2601 (null? rest2597))) (if t2601 t2601 (null? (cdr rest2597)))) (quote (eval)) (cadr rest2597)))) (with-fluid* *mode*1382 m2599 (lambda () (chi-top1460 x2598 (quote ()) (quote ((top))) m2599 esew2600 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x2602) (nonsymbol-id?1424 x2602))) (set! datum->syntax (lambda (id2603 datum2604) (make-syntax-object1408 datum2604 (syntax-object-wrap1411 id2603) #f))) (set! syntax->datum (lambda (x2605) (strip1471 x2605 (quote (()))))) (set! generate-temporaries (lambda (ls2606) (begin (let ((x2607 ls2606)) (if (not (list? x2607)) (syntax-violation (quote generate-temporaries) "invalid argument" x2607))) (map (lambda (x2608) (wrap1453 (gensym) (quote ((top))) #f)) ls2606)))) (set! free-identifier=? (lambda (x2609 y2610) (begin (let ((x2611 x2609)) (if (not (nonsymbol-id?1424 x2611)) (syntax-violation (quote free-identifier=?) "invalid argument" x2611))) (let ((x2612 y2610)) (if (not (nonsymbol-id?1424 x2612)) (syntax-violation (quote free-identifier=?) "invalid argument" x2612))) (free-id=?1448 x2609 y2610)))) (set! bound-identifier=? (lambda (x2613 y2614) (begin (let ((x2615 x2613)) (if (not (nonsymbol-id?1424 x2615)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2615))) (let ((x2616 y2614)) (if (not (nonsymbol-id?1424 x2616)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2616))) (bound-id=?1449 x2613 y2614)))) (set! syntax-violation (lambda (who2620 message2619 form2618 . subform2617) (begin (let ((x2621 who2620)) (if (not ((lambda (x2622) (let ((t2623 (not x2622))) (if t2623 t2623 (let ((t2624 (string? x2622))) (if t2624 t2624 (symbol? x2622)))))) x2621)) (syntax-violation (quote syntax-violation) "invalid argument" x2621))) (let ((x2625 message2619)) (if (not (string? x2625)) (syntax-violation (quote syntax-violation) "invalid argument" x2625))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2620 "~a: " "") "~a " (if (null? subform2617) "in ~a" "in subform `~s' of `~s'")) (let ((tail2626 (cons message2619 (map (lambda (x2627) (strip1471 x2627 (quote (())))) (append subform2617 (list form2618)))))) (if who2620 (cons who2620 tail2626) tail2626)) #f)))) (letrec ((match2632 (lambda (e2633 p2634 w2635 r2636 mod2637) (if (not r2636) #f (if (eq? p2634 (quote any)) (cons (wrap1453 e2633 w2635 mod2637) r2636) (if (syntax-object?1409 e2633) (match*2631 (syntax-object-expression1410 e2633) p2634 (join-wraps1444 w2635 (syntax-object-wrap1411 e2633)) r2636 (syntax-object-module1412 e2633)) (match*2631 e2633 p2634 w2635 r2636 mod2637)))))) (match*2631 (lambda (e2638 p2639 w2640 r2641 mod2642) (if (null? p2639) (if (null? e2638) r2641 #f) (if (pair? p2639) (if (pair? e2638) (match2632 (car e2638) (car p2639) w2640 (match2632 (cdr e2638) (cdr p2639) w2640 r2641 mod2642) mod2642) #f) (if (eq? p2639 (quote each-any)) (let ((l2643 (match-each-any2629 e2638 w2640 mod2642))) (if l2643 (cons l2643 r2641) #f)) (let ((atom-key2644 (vector-ref p2639 0))) (if (memv atom-key2644 (quote (each))) (if (null? e2638) (match-empty2630 (vector-ref p2639 1) r2641) (let ((l2645 (match-each2628 e2638 (vector-ref p2639 1) w2640 mod2642))) (if l2645 (letrec ((collect2646 (lambda (l2647) (if (null? (car l2647)) r2641 (cons (map car l2647) (collect2646 (map cdr l2647))))))) (collect2646 l2645)) #f))) (if (memv atom-key2644 (quote (free-id))) (if (id?1425 e2638) (if (free-id=?1448 (wrap1453 e2638 w2640 mod2642) (vector-ref p2639 1)) r2641 #f) #f) (if (memv atom-key2644 (quote (atom))) (if (equal? (vector-ref p2639 1) (strip1471 e2638 w2640)) r2641 #f) (if (memv atom-key2644 (quote (vector))) (if (vector? e2638) (match2632 (vector->list e2638) (vector-ref p2639 1) w2640 r2641 mod2642) #f))))))))))) (match-empty2630 (lambda (p2648 r2649) (if (null? p2648) r2649 (if (eq? p2648 (quote any)) (cons (quote ()) r2649) (if (pair? p2648) (match-empty2630 (car p2648) (match-empty2630 (cdr p2648) r2649)) (if (eq? p2648 (quote each-any)) (cons (quote ()) r2649) (let ((atom-key2650 (vector-ref p2648 0))) (if (memv atom-key2650 (quote (each))) (match-empty2630 (vector-ref p2648 1) r2649) (if (memv atom-key2650 (quote (free-id atom))) r2649 (if (memv atom-key2650 (quote (vector))) (match-empty2630 (vector-ref p2648 1) r2649))))))))))) (match-each-any2629 (lambda (e2651 w2652 mod2653) (if (pair? e2651) (let ((l2654 (match-each-any2629 (cdr e2651) w2652 mod2653))) (if l2654 (cons (wrap1453 (car e2651) w2652 mod2653) l2654) #f)) (if (null? e2651) (quote ()) (if (syntax-object?1409 e2651) (match-each-any2629 (syntax-object-expression1410 e2651) (join-wraps1444 w2652 (syntax-object-wrap1411 e2651)) mod2653) #f))))) (match-each2628 (lambda (e2655 p2656 w2657 mod2658) (if (pair? e2655) (let ((first2659 (match2632 (car e2655) p2656 w2657 (quote ()) mod2658))) (if first2659 (let ((rest2660 (match-each2628 (cdr e2655) p2656 w2657 mod2658))) (if rest2660 (cons first2659 rest2660) #f)) #f)) (if (null? e2655) (quote ()) (if (syntax-object?1409 e2655) (match-each2628 (syntax-object-expression1410 e2655) p2656 (join-wraps1444 w2657 (syntax-object-wrap1411 e2655)) (syntax-object-module1412 e2655)) #f)))))) (set! $sc-dispatch (lambda (e2661 p2662) (if (eq? p2662 (quote any)) (list e2661) (if (syntax-object?1409 e2661) (match*2631 (syntax-object-expression1410 e2661) p2662 (syntax-object-wrap1411 e2661) (quote ()) (syntax-object-module1412 e2661)) (match*2631 e2661 p2662 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2663) ((lambda (tmp2664) ((lambda (tmp2665) (if tmp2665 (apply (lambda (_2666 e12667 e22668) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12667 e22668))) tmp2665) ((lambda (tmp2670) (if tmp2670 (apply (lambda (_2671 out2672 in2673 e12674 e22675) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2673 (quote ()) (list out2672 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12674 e22675))))) tmp2670) ((lambda (tmp2677) (if tmp2677 (apply (lambda (_2678 out2679 in2680 e12681 e22682) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2680) (quote ()) (list out2679 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12681 e22682))))) tmp2677) (syntax-violation #f "source expression failed to match any pattern" tmp2664))) ($sc-dispatch tmp2664 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2664 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2664 (quote (any () any . each-any))))) x2663)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2686) ((lambda (tmp2687) ((lambda (tmp2688) (if tmp2688 (apply (lambda (_2689 k2690 keyword2691 pattern2692 template2693) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2690 (map (lambda (tmp2696 tmp2695) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2695) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2696))) template2693 pattern2692)))))) tmp2688) (syntax-violation #f "source expression failed to match any pattern" tmp2687))) ($sc-dispatch tmp2687 (quote (any each-any . #(each ((any . any) any))))))) x2686)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2697) ((lambda (tmp2698) ((lambda (tmp2699) (if (if tmp2699 (apply (lambda (let*2700 x2701 v2702 e12703 e22704) (and-map identifier? x2701)) tmp2699) #f) (apply (lambda (let*2706 x2707 v2708 e12709 e22710) (letrec ((f2711 (lambda (bindings2712) (if (null? bindings2712) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12709 e22710))) ((lambda (tmp2716) ((lambda (tmp2717) (if tmp2717 (apply (lambda (body2718 binding2719) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2719) body2718)) tmp2717) (syntax-violation #f "source expression failed to match any pattern" tmp2716))) ($sc-dispatch tmp2716 (quote (any any))))) (list (f2711 (cdr bindings2712)) (car bindings2712))))))) (f2711 (map list x2707 v2708)))) tmp2699) (syntax-violation #f "source expression failed to match any pattern" tmp2698))) ($sc-dispatch tmp2698 (quote (any #(each (any any)) any . each-any))))) x2697)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2720) ((lambda (tmp2721) ((lambda (tmp2722) (if tmp2722 (apply (lambda (_2723 var2724 init2725 step2726 e02727 e12728 c2729) ((lambda (tmp2730) ((lambda (tmp2731) (if tmp2731 (apply (lambda (step2732) ((lambda (tmp2733) ((lambda (tmp2734) (if tmp2734 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2724 init2725) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02727) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2729 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2732))))))) tmp2734) ((lambda (tmp2739) (if tmp2739 (apply (lambda (e12740 e22741) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2724 init2725) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02727 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12740 e22741)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2729 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2732))))))) tmp2739) (syntax-violation #f "source expression failed to match any pattern" tmp2733))) ($sc-dispatch tmp2733 (quote (any . each-any)))))) ($sc-dispatch tmp2733 (quote ())))) e12728)) tmp2731) (syntax-violation #f "source expression failed to match any pattern" tmp2730))) ($sc-dispatch tmp2730 (quote each-any)))) (map (lambda (v2748 s2749) ((lambda (tmp2750) ((lambda (tmp2751) (if tmp2751 (apply (lambda () v2748) tmp2751) ((lambda (tmp2752) (if tmp2752 (apply (lambda (e2753) e2753) tmp2752) ((lambda (_2754) (syntax-violation (quote do) "bad step expression" orig-x2720 s2749)) tmp2750))) ($sc-dispatch tmp2750 (quote (any)))))) ($sc-dispatch tmp2750 (quote ())))) s2749)) var2724 step2726))) tmp2722) (syntax-violation #f "source expression failed to match any pattern" tmp2721))) ($sc-dispatch tmp2721 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2720)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2757 (lambda (x2761 y2762) ((lambda (tmp2763) ((lambda (tmp2764) (if tmp2764 (apply (lambda (x2765 y2766) ((lambda (tmp2767) ((lambda (tmp2768) (if tmp2768 (apply (lambda (dy2769) ((lambda (tmp2770) ((lambda (tmp2771) (if tmp2771 (apply (lambda (dx2772) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2772 dy2769))) tmp2771) ((lambda (_2773) (if (null? dy2769) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2765) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2765 y2766))) tmp2770))) ($sc-dispatch tmp2770 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2765)) tmp2768) ((lambda (tmp2774) (if tmp2774 (apply (lambda (stuff2775) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2765 stuff2775))) tmp2774) ((lambda (else2776) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2765 y2766)) tmp2767))) ($sc-dispatch tmp2767 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2767 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2766)) tmp2764) (syntax-violation #f "source expression failed to match any pattern" tmp2763))) ($sc-dispatch tmp2763 (quote (any any))))) (list x2761 y2762)))) (quasiappend2758 (lambda (x2777 y2778) ((lambda (tmp2779) ((lambda (tmp2780) (if tmp2780 (apply (lambda (x2781 y2782) ((lambda (tmp2783) ((lambda (tmp2784) (if tmp2784 (apply (lambda () x2781) tmp2784) ((lambda (_2785) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2781 y2782)) tmp2783))) ($sc-dispatch tmp2783 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2782)) tmp2780) (syntax-violation #f "source expression failed to match any pattern" tmp2779))) ($sc-dispatch tmp2779 (quote (any any))))) (list x2777 y2778)))) (quasivector2759 (lambda (x2786) ((lambda (tmp2787) ((lambda (x2788) ((lambda (tmp2789) ((lambda (tmp2790) (if tmp2790 (apply (lambda (x2791) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2791))) tmp2790) ((lambda (tmp2793) (if tmp2793 (apply (lambda (x2794) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2794)) tmp2793) ((lambda (_2796) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2788)) tmp2789))) ($sc-dispatch tmp2789 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2789 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2788)) tmp2787)) x2786))) (quasi2760 (lambda (p2797 lev2798) ((lambda (tmp2799) ((lambda (tmp2800) (if tmp2800 (apply (lambda (p2801) (if (= lev2798 0) p2801 (quasicons2757 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2760 (list p2801) (- lev2798 1))))) tmp2800) ((lambda (tmp2802) (if (if tmp2802 (apply (lambda (args2803) (= lev2798 0)) tmp2802) #f) (apply (lambda (args2804) (syntax-violation (quote unquote) "unquote takes exactly one argument" p2797 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args2804))) tmp2802) ((lambda (tmp2805) (if tmp2805 (apply (lambda (p2806 q2807) (if (= lev2798 0) (quasiappend2758 p2806 (quasi2760 q2807 lev2798)) (quasicons2757 (quasicons2757 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2760 (list p2806) (- lev2798 1))) (quasi2760 q2807 lev2798)))) tmp2805) ((lambda (tmp2808) (if (if tmp2808 (apply (lambda (args2809 q2810) (= lev2798 0)) tmp2808) #f) (apply (lambda (args2811 q2812) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p2797 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args2811))) tmp2808) ((lambda (tmp2813) (if tmp2813 (apply (lambda (p2814) (quasicons2757 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2760 (list p2814) (+ lev2798 1)))) tmp2813) ((lambda (tmp2815) (if tmp2815 (apply (lambda (p2816 q2817) (quasicons2757 (quasi2760 p2816 lev2798) (quasi2760 q2817 lev2798))) tmp2815) ((lambda (tmp2818) (if tmp2818 (apply (lambda (x2819) (quasivector2759 (quasi2760 x2819 lev2798))) tmp2818) ((lambda (p2821) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2821)) tmp2799))) ($sc-dispatch tmp2799 (quote #(vector each-any)))))) ($sc-dispatch tmp2799 (quote (any . any)))))) ($sc-dispatch tmp2799 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2799 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp2799 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2799 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2799 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2797)))) (lambda (x2822) ((lambda (tmp2823) ((lambda (tmp2824) (if tmp2824 (apply (lambda (_2825 e2826) (quasi2760 e2826 0)) tmp2824) (syntax-violation #f "source expression failed to match any pattern" tmp2823))) ($sc-dispatch tmp2823 (quote (any any))))) x2822))))) +(define include (make-syncase-macro (quote macro) (lambda (x2827) (letrec ((read-file2828 (lambda (fn2829 k2830) (let ((p2831 (open-input-file fn2829))) (letrec ((f2832 (lambda (x2833) (if (eof-object? x2833) (begin (close-input-port p2831) (quote ())) (cons (datum->syntax k2830 x2833) (f2832 (read p2831))))))) (f2832 (read p2831))))))) ((lambda (tmp2834) ((lambda (tmp2835) (if tmp2835 (apply (lambda (k2836 filename2837) (let ((fn2838 (syntax->datum filename2837))) ((lambda (tmp2839) ((lambda (tmp2840) (if tmp2840 (apply (lambda (exp2841) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2841)) tmp2840) (syntax-violation #f "source expression failed to match any pattern" tmp2839))) ($sc-dispatch tmp2839 (quote each-any)))) (read-file2828 fn2838 k2836)))) tmp2835) (syntax-violation #f "source expression failed to match any pattern" tmp2834))) ($sc-dispatch tmp2834 (quote (any any))))) x2827))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2843) ((lambda (tmp2844) ((lambda (tmp2845) (if tmp2845 (apply (lambda (_2846 e2847) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2843)) tmp2845) (syntax-violation #f "source expression failed to match any pattern" tmp2844))) ($sc-dispatch tmp2844 (quote (any any))))) x2843)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2848) ((lambda (tmp2849) ((lambda (tmp2850) (if tmp2850 (apply (lambda (_2851 e2852) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2848)) tmp2850) (syntax-violation #f "source expression failed to match any pattern" tmp2849))) ($sc-dispatch tmp2849 (quote (any any))))) x2848)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2853) ((lambda (tmp2854) ((lambda (tmp2855) (if tmp2855 (apply (lambda (_2856 e2857 m12858 m22859) ((lambda (tmp2860) ((lambda (body2861) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2857)) body2861)) tmp2860)) (letrec ((f2862 (lambda (clause2863 clauses2864) (if (null? clauses2864) ((lambda (tmp2866) ((lambda (tmp2867) (if tmp2867 (apply (lambda (e12868 e22869) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12868 e22869))) tmp2867) ((lambda (tmp2871) (if tmp2871 (apply (lambda (k2872 e12873 e22874) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2872)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12873 e22874)))) tmp2871) ((lambda (_2877) (syntax-violation (quote case) "bad clause" x2853 clause2863)) tmp2866))) ($sc-dispatch tmp2866 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2866 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2863) ((lambda (tmp2878) ((lambda (rest2879) ((lambda (tmp2880) ((lambda (tmp2881) (if tmp2881 (apply (lambda (k2882 e12883 e22884) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2882)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12883 e22884)) rest2879)) tmp2881) ((lambda (_2887) (syntax-violation (quote case) "bad clause" x2853 clause2863)) tmp2880))) ($sc-dispatch tmp2880 (quote (each-any any . each-any))))) clause2863)) tmp2878)) (f2862 (car clauses2864) (cdr clauses2864))))))) (f2862 m12858 m22859)))) tmp2855) (syntax-violation #f "source expression failed to match any pattern" tmp2854))) ($sc-dispatch tmp2854 (quote (any any any . each-any))))) x2853)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2888) ((lambda (tmp2889) ((lambda (tmp2890) (if tmp2890 (apply (lambda (_2891 e2892) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2892)) (list (cons _2891 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2892 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2890) (syntax-violation #f "source expression failed to match any pattern" tmp2889))) ($sc-dispatch tmp2889 (quote (any any))))) x2888)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 194c21150..e1352d8c5 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1178,8 +1178,9 @@ (type (binding-type (lookup n r mod)))) (case type ((global core macro module-ref) - ;; affect compile-time environment - (if (not (module-local-variable (current-module) n)) + ;; affect compile-time environment (once we have booted) + (if (and (not (module-local-variable (current-module) n)) + (current-module)) (module-define! (current-module) n #f)) (eval-if-c&e m (build-global-definition s n (chi e r w mod)) From 8dd42d3bc977b306d38afa5be3465210a9b30266 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 8 Jun 2009 11:44:51 +0200 Subject: [PATCH 205/375] don't autocompile snarfing m4 docs * doc/ref/Makefile.am (autoconf-macros.texi): Yet another place we shouldn't autocompile. --- doc/ref/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 368b82321..9d73e5da8 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -90,7 +90,7 @@ include $(top_srcdir)/am/pre-inst-guile autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/meta/guile.m4 - $(top_builddir)/meta/uninstalled-env guile-tools \ + GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guile-tools \ snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \ > $(srcdir)/$@ From 65dd9e3846326ff80915c69ef781888181890802 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 8 Jun 2009 22:24:15 +0200 Subject: [PATCH 206/375] pretty-print psyntax-pp.scm * module/ice-9/compile-psyntax.scm: Pretty-print psyntax-pp.scm, given that we are going to compile it anyway. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/compile-psyntax.scm | 8 +- module/ice-9/psyntax-pp.scm | 11220 ++++++++++++++++++++++++++++- 2 files changed, 11213 insertions(+), 15 deletions(-) diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 2b8eec0d2..8b53267fe 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,4 +1,4 @@ -(use-modules (language tree-il)) +(use-modules (language tree-il) (ice-9 pretty-print)) (let ((source (list-ref (command-line) 1)) (target (list-ref (command-line) 2))) (let ((in (open-input-file source)) @@ -12,9 +12,9 @@ (close-port out) (close-port in)) (begin - (write (tree-il->scheme - (sc-expand x 'c '(compile load eval))) - out) + (pretty-print (tree-il->scheme + (sc-expand x 'c '(compile load eval))) + out) (newline out) (loop (read in)))))) (system (format #f "mv -f ~s.tmp ~s" target target))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 3a4dfde38..a6e35b098 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,11211 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*1328 (lambda (f1368 first1367 . rest1366) (let ((t1369 (null? first1367))) (if t1369 t1369 (if (null? rest1366) (letrec ((andmap1370 (lambda (first1371) (let ((x1372 (car first1371)) (first1373 (cdr first1371))) (if (null? first1373) (f1368 x1372) (if (f1368 x1372) (andmap1370 first1373) #f)))))) (andmap1370 first1367)) (letrec ((andmap1374 (lambda (first1375 rest1376) (let ((x1377 (car first1375)) (xr1378 (map car rest1376)) (first1379 (cdr first1375)) (rest1380 (map cdr rest1376))) (if (null? first1379) (apply f1368 (cons x1377 xr1378)) (if (apply f1368 (cons x1377 xr1378)) (andmap1374 first1379 rest1380) #f)))))) (andmap1374 first1367 rest1366)))))))) (letrec ((lambda-var-list1473 (lambda (vars1597) (letrec ((lvl1598 (lambda (vars1599 ls1600 w1601) (if (pair? vars1599) (lvl1598 (cdr vars1599) (cons (wrap1453 (car vars1599) w1601 #f) ls1600) w1601) (if (id?1425 vars1599) (cons (wrap1453 vars1599 w1601 #f) ls1600) (if (null? vars1599) ls1600 (if (syntax-object?1409 vars1599) (lvl1598 (syntax-object-expression1410 vars1599) ls1600 (join-wraps1444 w1601 (syntax-object-wrap1411 vars1599))) (cons vars1599 ls1600)))))))) (lvl1598 vars1597 (quote ()) (quote (())))))) (gen-var1472 (lambda (id1602) (let ((id1603 (if (syntax-object?1409 id1602) (syntax-object-expression1410 id1602) id1602))) (gensym (symbol->string id1603))))) (strip1471 (lambda (x1604 w1605) (if (memq (quote top) (wrap-marks1428 w1605)) x1604 (letrec ((f1606 (lambda (x1607) (if (syntax-object?1409 x1607) (strip1471 (syntax-object-expression1410 x1607) (syntax-object-wrap1411 x1607)) (if (pair? x1607) (let ((a1608 (f1606 (car x1607))) (d1609 (f1606 (cdr x1607)))) (if (if (eq? a1608 (car x1607)) (eq? d1609 (cdr x1607)) #f) x1607 (cons a1608 d1609))) (if (vector? x1607) (let ((old1610 (vector->list x1607))) (let ((new1611 (map f1606 old1610))) (if (and-map*1328 eq? old1610 new1611) x1607 (list->vector new1611)))) x1607)))))) (f1606 x1604))))) (ellipsis?1470 (lambda (x1612) (if (nonsymbol-id?1424 x1612) (free-id=?1448 x1612 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void1469 (lambda () (build-void1391 #f))) (eval-local-transformer1468 (lambda (expanded1613 mod1614) (let ((p1615 (local-eval-hook1388 expanded1613 mod1614))) (if (procedure? p1615) p1615 (syntax-violation #f "nonprocedure transformer" p1615))))) (chi-local-syntax1467 (lambda (rec?1616 e1617 r1618 w1619 s1620 mod1621 k1622) ((lambda (tmp1623) ((lambda (tmp1624) (if tmp1624 (apply (lambda (_1625 id1626 val1627 e11628 e21629) (let ((ids1630 id1626)) (if (not (valid-bound-ids?1450 ids1630)) (syntax-violation #f "duplicate bound keyword" e1617) (let ((labels1632 (gen-labels1431 ids1630))) (let ((new-w1633 (make-binding-wrap1442 ids1630 labels1632 w1619))) (k1622 (cons e11628 e21629) (extend-env1419 labels1632 (let ((w1635 (if rec?1616 new-w1633 w1619)) (trans-r1636 (macros-only-env1421 r1618))) (map (lambda (x1637) (cons (quote macro) (eval-local-transformer1468 (chi1461 x1637 trans-r1636 w1635 mod1621) mod1621))) val1627)) r1618) new-w1633 s1620 mod1621)))))) tmp1624) ((lambda (_1639) (syntax-violation #f "bad local syntax definition" (source-wrap1454 e1617 w1619 s1620 mod1621))) tmp1623))) ($sc-dispatch tmp1623 (quote (any #(each (any any)) any . each-any))))) e1617))) (chi-lambda-clause1466 (lambda (e1640 docstring1641 c1642 r1643 w1644 mod1645 k1646) ((lambda (tmp1647) ((lambda (tmp1648) (if (if tmp1648 (apply (lambda (args1649 doc1650 e11651 e21652) (if (string? (syntax->datum doc1650)) (not docstring1641) #f)) tmp1648) #f) (apply (lambda (args1653 doc1654 e11655 e21656) (chi-lambda-clause1466 e1640 doc1654 (cons args1653 (cons e11655 e21656)) r1643 w1644 mod1645 k1646)) tmp1648) ((lambda (tmp1658) (if tmp1658 (apply (lambda (id1659 e11660 e21661) (let ((ids1662 id1659)) (if (not (valid-bound-ids?1450 ids1662)) (syntax-violation (quote lambda) "invalid parameter list" e1640) (let ((labels1664 (gen-labels1431 ids1662)) (new-vars1665 (map gen-var1472 ids1662))) (k1646 (map syntax->datum ids1662) new-vars1665 (if docstring1641 (syntax->datum docstring1641) #f) (chi-body1465 (cons e11660 e21661) e1640 (extend-var-env1420 labels1664 new-vars1665 r1643) (make-binding-wrap1442 ids1662 labels1664 w1644) mod1645)))))) tmp1658) ((lambda (tmp1667) (if tmp1667 (apply (lambda (ids1668 e11669 e21670) (let ((old-ids1671 (lambda-var-list1473 ids1668))) (if (not (valid-bound-ids?1450 old-ids1671)) (syntax-violation (quote lambda) "invalid parameter list" e1640) (let ((labels1672 (gen-labels1431 old-ids1671)) (new-vars1673 (map gen-var1472 old-ids1671))) (k1646 (letrec ((f1674 (lambda (ls11675 ls21676) (if (null? ls11675) (syntax->datum ls21676) (f1674 (cdr ls11675) (cons (syntax->datum (car ls11675)) ls21676)))))) (f1674 (cdr old-ids1671) (car old-ids1671))) (letrec ((f1677 (lambda (ls11678 ls21679) (if (null? ls11678) ls21679 (f1677 (cdr ls11678) (cons (car ls11678) ls21679)))))) (f1677 (cdr new-vars1673) (car new-vars1673))) (if docstring1641 (syntax->datum docstring1641) #f) (chi-body1465 (cons e11669 e21670) e1640 (extend-var-env1420 labels1672 new-vars1673 r1643) (make-binding-wrap1442 old-ids1671 labels1672 w1644) mod1645)))))) tmp1667) ((lambda (_1681) (syntax-violation (quote lambda) "bad lambda" e1640)) tmp1647))) ($sc-dispatch tmp1647 (quote (any any . each-any)))))) ($sc-dispatch tmp1647 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1647 (quote (any any any . each-any))))) c1642))) (chi-body1465 (lambda (body1682 outer-form1683 r1684 w1685 mod1686) (let ((r1687 (cons (quote ("placeholder" placeholder)) r1684))) (let ((ribcage1688 (make-ribcage1432 (quote ()) (quote ()) (quote ())))) (let ((w1689 (make-wrap1427 (wrap-marks1428 w1685) (cons ribcage1688 (wrap-subst1429 w1685))))) (letrec ((parse1690 (lambda (body1691 ids1692 labels1693 var-ids1694 vars1695 vals1696 bindings1697) (if (null? body1691) (syntax-violation #f "no expressions in body" outer-form1683) (let ((e1699 (cdar body1691)) (er1700 (caar body1691))) (call-with-values (lambda () (syntax-type1459 e1699 er1700 (quote (())) (source-annotation1416 er1700) ribcage1688 mod1686 #f)) (lambda (type1701 value1702 e1703 w1704 s1705 mod1706) (if (memv type1701 (quote (define-form))) (let ((id1707 (wrap1453 value1702 w1704 mod1706)) (label1708 (gen-label1430))) (let ((var1709 (gen-var1472 id1707))) (begin (extend-ribcage!1441 ribcage1688 id1707 label1708) (parse1690 (cdr body1691) (cons id1707 ids1692) (cons label1708 labels1693) (cons id1707 var-ids1694) (cons var1709 vars1695) (cons (cons er1700 (wrap1453 e1703 w1704 mod1706)) vals1696) (cons (cons (quote lexical) var1709) bindings1697))))) (if (memv type1701 (quote (define-syntax-form))) (let ((id1710 (wrap1453 value1702 w1704 mod1706)) (label1711 (gen-label1430))) (begin (extend-ribcage!1441 ribcage1688 id1710 label1711) (parse1690 (cdr body1691) (cons id1710 ids1692) (cons label1711 labels1693) var-ids1694 vars1695 vals1696 (cons (cons (quote macro) (cons er1700 (wrap1453 e1703 w1704 mod1706))) bindings1697)))) (if (memv type1701 (quote (begin-form))) ((lambda (tmp1712) ((lambda (tmp1713) (if tmp1713 (apply (lambda (_1714 e11715) (parse1690 (letrec ((f1716 (lambda (forms1717) (if (null? forms1717) (cdr body1691) (cons (cons er1700 (wrap1453 (car forms1717) w1704 mod1706)) (f1716 (cdr forms1717))))))) (f1716 e11715)) ids1692 labels1693 var-ids1694 vars1695 vals1696 bindings1697)) tmp1713) (syntax-violation #f "source expression failed to match any pattern" tmp1712))) ($sc-dispatch tmp1712 (quote (any . each-any))))) e1703) (if (memv type1701 (quote (local-syntax-form))) (chi-local-syntax1467 value1702 e1703 er1700 w1704 s1705 mod1706 (lambda (forms1719 er1720 w1721 s1722 mod1723) (parse1690 (letrec ((f1724 (lambda (forms1725) (if (null? forms1725) (cdr body1691) (cons (cons er1720 (wrap1453 (car forms1725) w1721 mod1723)) (f1724 (cdr forms1725))))))) (f1724 forms1719)) ids1692 labels1693 var-ids1694 vars1695 vals1696 bindings1697))) (if (null? ids1692) (build-sequence1404 #f (map (lambda (x1726) (chi1461 (cdr x1726) (car x1726) (quote (())) mod1706)) (cons (cons er1700 (source-wrap1454 e1703 w1704 s1705 mod1706)) (cdr body1691)))) (begin (if (not (valid-bound-ids?1450 ids1692)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1683)) (letrec ((loop1727 (lambda (bs1728 er-cache1729 r-cache1730) (if (not (null? bs1728)) (let ((b1731 (car bs1728))) (if (eq? (car b1731) (quote macro)) (let ((er1732 (cadr b1731))) (let ((r-cache1733 (if (eq? er1732 er-cache1729) r-cache1730 (macros-only-env1421 er1732)))) (begin (set-cdr! b1731 (eval-local-transformer1468 (chi1461 (cddr b1731) r-cache1733 (quote (())) mod1706) mod1706)) (loop1727 (cdr bs1728) er1732 r-cache1733)))) (loop1727 (cdr bs1728) er-cache1729 r-cache1730))))))) (loop1727 bindings1697 #f #f)) (set-cdr! r1687 (extend-env1419 labels1693 bindings1697 (cdr r1687))) (build-letrec1407 #f (map syntax->datum var-ids1694) vars1695 (map (lambda (x1734) (chi1461 (cdr x1734) (car x1734) (quote (())) mod1706)) vals1696) (build-sequence1404 #f (map (lambda (x1735) (chi1461 (cdr x1735) (car x1735) (quote (())) mod1706)) (cons (cons er1700 (source-wrap1454 e1703 w1704 s1705 mod1706)) (cdr body1691)))))))))))))))))) (parse1690 (map (lambda (x1698) (cons r1687 (wrap1453 x1698 w1689 mod1686))) body1682) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro1464 (lambda (p1736 e1737 r1738 w1739 rib1740 mod1741) (letrec ((rebuild-macro-output1742 (lambda (x1743 m1744) (if (pair? x1743) (cons (rebuild-macro-output1742 (car x1743) m1744) (rebuild-macro-output1742 (cdr x1743) m1744)) (if (syntax-object?1409 x1743) (let ((w1745 (syntax-object-wrap1411 x1743))) (let ((ms1746 (wrap-marks1428 w1745)) (s1747 (wrap-subst1429 w1745))) (if (if (pair? ms1746) (eq? (car ms1746) #f) #f) (make-syntax-object1408 (syntax-object-expression1410 x1743) (make-wrap1427 (cdr ms1746) (if rib1740 (cons rib1740 (cdr s1747)) (cdr s1747))) (syntax-object-module1412 x1743)) (make-syntax-object1408 (syntax-object-expression1410 x1743) (make-wrap1427 (cons m1744 ms1746) (if rib1740 (cons rib1740 (cons (quote shift) s1747)) (cons (quote shift) s1747))) (let ((pmod1748 (procedure-module p1736))) (if pmod1748 (cons (quote hygiene) (module-name pmod1748)) (quote (hygiene guile)))))))) (if (vector? x1743) (let ((n1749 (vector-length x1743))) (let ((v1750 (make-vector n1749))) (letrec ((loop1751 (lambda (i1752) (if (fx=1385 i1752 n1749) (begin (if #f #f) v1750) (begin (vector-set! v1750 i1752 (rebuild-macro-output1742 (vector-ref x1743 i1752) m1744)) (loop1751 (fx+1383 i1752 1))))))) (loop1751 0)))) (if (symbol? x1743) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1454 e1737 w1739 s mod1741) x1743) x1743))))))) (rebuild-macro-output1742 (p1736 (wrap1453 e1737 (anti-mark1440 w1739) mod1741)) (string #\m))))) (chi-application1463 (lambda (x1753 e1754 r1755 w1756 s1757 mod1758) ((lambda (tmp1759) ((lambda (tmp1760) (if tmp1760 (apply (lambda (e01761 e11762) (build-application1392 s1757 x1753 (map (lambda (e1763) (chi1461 e1763 r1755 w1756 mod1758)) e11762))) tmp1760) (syntax-violation #f "source expression failed to match any pattern" tmp1759))) ($sc-dispatch tmp1759 (quote (any . each-any))))) e1754))) (chi-expr1462 (lambda (type1765 value1766 e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (lexical))) (build-lexical-reference1394 (quote value) s1770 e1767 value1766) (if (memv type1765 (quote (core core-form))) (value1766 e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (module-ref))) (call-with-values (lambda () (value1766 e1767)) (lambda (id1772 mod1773) (build-global-reference1397 s1770 id1772 mod1773))) (if (memv type1765 (quote (lexical-call))) (chi-application1463 (build-lexical-reference1394 (quote fun) (source-annotation1416 (car e1767)) (car e1767) value1766) e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (global-call))) (chi-application1463 (build-global-reference1397 (source-annotation1416 (car e1767)) (if (syntax-object?1409 value1766) (syntax-object-expression1410 value1766) value1766) (if (syntax-object?1409 value1766) (syntax-object-module1412 value1766) mod1771)) e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (constant))) (build-data1403 s1770 (strip1471 (source-wrap1454 e1767 w1769 s1770 mod1771) (quote (())))) (if (memv type1765 (quote (global))) (build-global-reference1397 s1770 value1766 mod1771) (if (memv type1765 (quote (call))) (chi-application1463 (chi1461 (car e1767) r1768 w1769 mod1771) e1767 r1768 w1769 s1770 mod1771) (if (memv type1765 (quote (begin-form))) ((lambda (tmp1774) ((lambda (tmp1775) (if tmp1775 (apply (lambda (_1776 e11777 e21778) (chi-sequence1455 (cons e11777 e21778) r1768 w1769 s1770 mod1771)) tmp1775) (syntax-violation #f "source expression failed to match any pattern" tmp1774))) ($sc-dispatch tmp1774 (quote (any any . each-any))))) e1767) (if (memv type1765 (quote (local-syntax-form))) (chi-local-syntax1467 value1766 e1767 r1768 w1769 s1770 mod1771 chi-sequence1455) (if (memv type1765 (quote (eval-when-form))) ((lambda (tmp1780) ((lambda (tmp1781) (if tmp1781 (apply (lambda (_1782 x1783 e11784 e21785) (let ((when-list1786 (chi-when-list1458 e1767 x1783 w1769))) (if (memq (quote eval) when-list1786) (chi-sequence1455 (cons e11784 e21785) r1768 w1769 s1770 mod1771) (chi-void1469)))) tmp1781) (syntax-violation #f "source expression failed to match any pattern" tmp1780))) ($sc-dispatch tmp1780 (quote (any each-any any . each-any))))) e1767) (if (memv type1765 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1767 (wrap1453 value1766 w1769 mod1771)) (if (memv type1765 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1454 e1767 w1769 s1770 mod1771)) (if (memv type1765 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1454 e1767 w1769 s1770 mod1771)) (syntax-violation #f "unexpected syntax" (source-wrap1454 e1767 w1769 s1770 mod1771)))))))))))))))))) (chi1461 (lambda (e1789 r1790 w1791 mod1792) (call-with-values (lambda () (syntax-type1459 e1789 r1790 w1791 (source-annotation1416 e1789) #f mod1792 #f)) (lambda (type1793 value1794 e1795 w1796 s1797 mod1798) (chi-expr1462 type1793 value1794 e1795 r1790 w1796 s1797 mod1798))))) (chi-top1460 (lambda (e1799 r1800 w1801 m1802 esew1803 mod1804) (call-with-values (lambda () (syntax-type1459 e1799 r1800 w1801 (source-annotation1416 e1799) #f mod1804 #f)) (lambda (type1812 value1813 e1814 w1815 s1816 mod1817) (if (memv type1812 (quote (begin-form))) ((lambda (tmp1818) ((lambda (tmp1819) (if tmp1819 (apply (lambda (_1820) (chi-void1469)) tmp1819) ((lambda (tmp1821) (if tmp1821 (apply (lambda (_1822 e11823 e21824) (chi-top-sequence1456 (cons e11823 e21824) r1800 w1815 s1816 m1802 esew1803 mod1817)) tmp1821) (syntax-violation #f "source expression failed to match any pattern" tmp1818))) ($sc-dispatch tmp1818 (quote (any any . each-any)))))) ($sc-dispatch tmp1818 (quote (any))))) e1814) (if (memv type1812 (quote (local-syntax-form))) (chi-local-syntax1467 value1813 e1814 r1800 w1815 s1816 mod1817 (lambda (body1826 r1827 w1828 s1829 mod1830) (chi-top-sequence1456 body1826 r1827 w1828 s1829 m1802 esew1803 mod1830))) (if (memv type1812 (quote (eval-when-form))) ((lambda (tmp1831) ((lambda (tmp1832) (if tmp1832 (apply (lambda (_1833 x1834 e11835 e21836) (let ((when-list1837 (chi-when-list1458 e1814 x1834 w1815)) (body1838 (cons e11835 e21836))) (if (eq? m1802 (quote e)) (if (memq (quote eval) when-list1837) (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote e) (quote (eval)) mod1817) (chi-void1469)) (if (memq (quote load) when-list1837) (if (let ((t1841 (memq (quote compile) when-list1837))) (if t1841 t1841 (if (eq? m1802 (quote c&e)) (memq (quote eval) when-list1837) #f))) (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote c&e) (quote (compile load)) mod1817) (if (memq m1802 (quote (c c&e))) (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote c) (quote (load)) mod1817) (chi-void1469))) (if (let ((t1842 (memq (quote compile) when-list1837))) (if t1842 t1842 (if (eq? m1802 (quote c&e)) (memq (quote eval) when-list1837) #f))) (begin (top-level-eval-hook1387 (chi-top-sequence1456 body1838 r1800 w1815 s1816 (quote e) (quote (eval)) mod1817) mod1817) (chi-void1469)) (chi-void1469)))))) tmp1832) (syntax-violation #f "source expression failed to match any pattern" tmp1831))) ($sc-dispatch tmp1831 (quote (any each-any any . each-any))))) e1814) (if (memv type1812 (quote (define-syntax-form))) (let ((n1843 (id-var-name1447 value1813 w1815)) (r1844 (macros-only-env1421 r1800))) (if (memv m1802 (quote (c))) (if (memq (quote compile) esew1803) (let ((e1845 (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)))) (begin (top-level-eval-hook1387 e1845 mod1817) (if (memq (quote load) esew1803) e1845 (chi-void1469)))) (if (memq (quote load) esew1803) (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)) (chi-void1469))) (if (memv m1802 (quote (c&e))) (let ((e1846 (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)))) (begin (top-level-eval-hook1387 e1846 mod1817) e1846)) (begin (if (memq (quote eval) esew1803) (top-level-eval-hook1387 (chi-install-global1457 n1843 (chi1461 e1814 r1844 w1815 mod1817)) mod1817)) (chi-void1469))))) (if (memv type1812 (quote (define-form))) (let ((n1847 (id-var-name1447 value1813 w1815))) (let ((type1848 (binding-type1417 (lookup1422 n1847 r1800 mod1817)))) (if (memv type1848 (quote (global core macro module-ref))) (begin (if (if (not (module-local-variable (current-module) n1847)) (current-module) #f) (module-define! (current-module) n1847 #f)) (let ((x1849 (build-global-definition1400 s1816 n1847 (chi1461 e1814 r1800 w1815 mod1817)))) (begin (if (eq? m1802 (quote c&e)) (top-level-eval-hook1387 x1849 mod1817)) x1849))) (if (memv type1848 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1814 (wrap1453 value1813 w1815 mod1817)) (syntax-violation #f "cannot define keyword at top level" e1814 (wrap1453 value1813 w1815 mod1817)))))) (let ((x1850 (chi-expr1462 type1812 value1813 e1814 r1800 w1815 s1816 mod1817))) (begin (if (eq? m1802 (quote c&e)) (top-level-eval-hook1387 x1850 mod1817)) x1850))))))))))) (syntax-type1459 (lambda (e1851 r1852 w1853 s1854 rib1855 mod1856 for-car?1857) (if (symbol? e1851) (let ((n1858 (id-var-name1447 e1851 w1853))) (let ((b1859 (lookup1422 n1858 r1852 mod1856))) (let ((type1860 (binding-type1417 b1859))) (if (memv type1860 (quote (lexical))) (values type1860 (binding-value1418 b1859) e1851 w1853 s1854 mod1856) (if (memv type1860 (quote (global))) (values type1860 n1858 e1851 w1853 s1854 mod1856) (if (memv type1860 (quote (macro))) (if for-car?1857 (values type1860 (binding-value1418 b1859) e1851 w1853 s1854 mod1856) (syntax-type1459 (chi-macro1464 (binding-value1418 b1859) e1851 r1852 w1853 rib1855 mod1856) r1852 (quote (())) s1854 rib1855 mod1856 #f)) (values type1860 (binding-value1418 b1859) e1851 w1853 s1854 mod1856))))))) (if (pair? e1851) (let ((first1861 (car e1851))) (call-with-values (lambda () (syntax-type1459 first1861 r1852 w1853 s1854 rib1855 mod1856 #t)) (lambda (ftype1862 fval1863 fe1864 fw1865 fs1866 fmod1867) (if (memv ftype1862 (quote (lexical))) (values (quote lexical-call) fval1863 e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (global))) (values (quote global-call) (make-syntax-object1408 fval1863 w1853 fmod1867) e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (macro))) (syntax-type1459 (chi-macro1464 fval1863 e1851 r1852 w1853 rib1855 mod1856) r1852 (quote (())) s1854 rib1855 mod1856 for-car?1857) (if (memv ftype1862 (quote (module-ref))) (call-with-values (lambda () (fval1863 e1851)) (lambda (sym1868 mod1869) (syntax-type1459 sym1868 r1852 w1853 s1854 rib1855 mod1869 for-car?1857))) (if (memv ftype1862 (quote (core))) (values (quote core-form) fval1863 e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (local-syntax))) (values (quote local-syntax-form) fval1863 e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (begin))) (values (quote begin-form) #f e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (eval-when))) (values (quote eval-when-form) #f e1851 w1853 s1854 mod1856) (if (memv ftype1862 (quote (define))) ((lambda (tmp1870) ((lambda (tmp1871) (if (if tmp1871 (apply (lambda (_1872 name1873 val1874) (id?1425 name1873)) tmp1871) #f) (apply (lambda (_1875 name1876 val1877) (values (quote define-form) name1876 val1877 w1853 s1854 mod1856)) tmp1871) ((lambda (tmp1878) (if (if tmp1878 (apply (lambda (_1879 name1880 args1881 e11882 e21883) (if (id?1425 name1880) (valid-bound-ids?1450 (lambda-var-list1473 args1881)) #f)) tmp1878) #f) (apply (lambda (_1884 name1885 args1886 e11887 e21888) (values (quote define-form) (wrap1453 name1885 w1853 mod1856) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap1453 (cons args1886 (cons e11887 e21888)) w1853 mod1856)) (quote (())) s1854 mod1856)) tmp1878) ((lambda (tmp1890) (if (if tmp1890 (apply (lambda (_1891 name1892) (id?1425 name1892)) tmp1890) #f) (apply (lambda (_1893 name1894) (values (quote define-form) (wrap1453 name1894 w1853 mod1856) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ftype fval fe fw fs fmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod for-car?) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s1854 mod1856)) tmp1890) (syntax-violation #f "source expression failed to match any pattern" tmp1870))) ($sc-dispatch tmp1870 (quote (any any)))))) ($sc-dispatch tmp1870 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1870 (quote (any any any))))) e1851) (if (memv ftype1862 (quote (define-syntax))) ((lambda (tmp1895) ((lambda (tmp1896) (if (if tmp1896 (apply (lambda (_1897 name1898 val1899) (id?1425 name1898)) tmp1896) #f) (apply (lambda (_1900 name1901 val1902) (values (quote define-syntax-form) name1901 val1902 w1853 s1854 mod1856)) tmp1896) (syntax-violation #f "source expression failed to match any pattern" tmp1895))) ($sc-dispatch tmp1895 (quote (any any any))))) e1851) (values (quote call) #f e1851 w1853 s1854 mod1856)))))))))))))) (if (syntax-object?1409 e1851) (syntax-type1459 (syntax-object-expression1410 e1851) r1852 (join-wraps1444 w1853 (syntax-object-wrap1411 e1851)) s1854 rib1855 (let ((t1903 (syntax-object-module1412 e1851))) (if t1903 t1903 mod1856)) for-car?1857) (if (self-evaluating? e1851) (values (quote constant) #f e1851 w1853 s1854 mod1856) (values (quote other) #f e1851 w1853 s1854 mod1856))))))) (chi-when-list1458 (lambda (e1904 when-list1905 w1906) (letrec ((f1907 (lambda (when-list1908 situations1909) (if (null? when-list1908) situations1909 (f1907 (cdr when-list1908) (cons (let ((x1910 (car when-list1908))) (if (free-id=?1448 x1910 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?1448 x1910 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?1448 x1910 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e1904 (wrap1453 x1910 w1906 #f)))))) situations1909)))))) (f1907 when-list1905 (quote ()))))) (chi-install-global1457 (lambda (name1911 e1912) (build-global-definition1400 #f name1911 (if (let ((v1913 (module-variable (current-module) name1911))) (if v1913 (if (variable-bound? v1913) (if (macro? (variable-ref v1913)) (not (eq? (macro-type (variable-ref v1913)) (quote syncase-macro))) #f) #f) #f)) (build-application1392 #f (build-primref1402 #f (quote make-extended-syncase-macro)) (list (build-application1392 #f (build-primref1402 #f (quote module-ref)) (list (build-application1392 #f (build-primref1402 #f (quote current-module)) (quote ())) (build-data1403 #f name1911))) (build-data1403 #f (quote macro)) e1912)) (build-application1392 #f (build-primref1402 #f (quote make-syncase-macro)) (list (build-data1403 #f (quote macro)) e1912)))))) (chi-top-sequence1456 (lambda (body1914 r1915 w1916 s1917 m1918 esew1919 mod1920) (build-sequence1404 s1917 (letrec ((dobody1921 (lambda (body1922 r1923 w1924 m1925 esew1926 mod1927) (if (null? body1922) (quote ()) (let ((first1928 (chi-top1460 (car body1922) r1923 w1924 m1925 esew1926 mod1927))) (cons first1928 (dobody1921 (cdr body1922) r1923 w1924 m1925 esew1926 mod1927))))))) (dobody1921 body1914 r1915 w1916 m1918 esew1919 mod1920))))) (chi-sequence1455 (lambda (body1929 r1930 w1931 s1932 mod1933) (build-sequence1404 s1932 (letrec ((dobody1934 (lambda (body1935 r1936 w1937 mod1938) (if (null? body1935) (quote ()) (let ((first1939 (chi1461 (car body1935) r1936 w1937 mod1938))) (cons first1939 (dobody1934 (cdr body1935) r1936 w1937 mod1938))))))) (dobody1934 body1929 r1930 w1931 mod1933))))) (source-wrap1454 (lambda (x1940 w1941 s1942 defmod1943) (begin (if (if s1942 (pair? x1940) #f) (set-source-properties! x1940 s1942)) (wrap1453 x1940 w1941 defmod1943)))) (wrap1453 (lambda (x1944 w1945 defmod1946) (if (if (null? (wrap-marks1428 w1945)) (null? (wrap-subst1429 w1945)) #f) x1944 (if (syntax-object?1409 x1944) (make-syntax-object1408 (syntax-object-expression1410 x1944) (join-wraps1444 w1945 (syntax-object-wrap1411 x1944)) (syntax-object-module1412 x1944)) (if (null? x1944) x1944 (make-syntax-object1408 x1944 w1945 defmod1946)))))) (bound-id-member?1452 (lambda (x1947 list1948) (if (not (null? list1948)) (let ((t1949 (bound-id=?1449 x1947 (car list1948)))) (if t1949 t1949 (bound-id-member?1452 x1947 (cdr list1948)))) #f))) (distinct-bound-ids?1451 (lambda (ids1950) (letrec ((distinct?1951 (lambda (ids1952) (let ((t1953 (null? ids1952))) (if t1953 t1953 (if (not (bound-id-member?1452 (car ids1952) (cdr ids1952))) (distinct?1951 (cdr ids1952)) #f)))))) (distinct?1951 ids1950)))) (valid-bound-ids?1450 (lambda (ids1954) (if (letrec ((all-ids?1955 (lambda (ids1956) (let ((t1957 (null? ids1956))) (if t1957 t1957 (if (id?1425 (car ids1956)) (all-ids?1955 (cdr ids1956)) #f)))))) (all-ids?1955 ids1954)) (distinct-bound-ids?1451 ids1954) #f))) (bound-id=?1449 (lambda (i1958 j1959) (if (if (syntax-object?1409 i1958) (syntax-object?1409 j1959) #f) (if (eq? (syntax-object-expression1410 i1958) (syntax-object-expression1410 j1959)) (same-marks?1446 (wrap-marks1428 (syntax-object-wrap1411 i1958)) (wrap-marks1428 (syntax-object-wrap1411 j1959))) #f) (eq? i1958 j1959)))) (free-id=?1448 (lambda (i1960 j1961) (if (eq? (let ((x1962 i1960)) (if (syntax-object?1409 x1962) (syntax-object-expression1410 x1962) x1962)) (let ((x1963 j1961)) (if (syntax-object?1409 x1963) (syntax-object-expression1410 x1963) x1963))) (eq? (id-var-name1447 i1960 (quote (()))) (id-var-name1447 j1961 (quote (())))) #f))) (id-var-name1447 (lambda (id1964 w1965) (letrec ((search-vector-rib1968 (lambda (sym1974 subst1975 marks1976 symnames1977 ribcage1978) (let ((n1979 (vector-length symnames1977))) (letrec ((f1980 (lambda (i1981) (if (fx=1385 i1981 n1979) (search1966 sym1974 (cdr subst1975) marks1976) (if (if (eq? (vector-ref symnames1977 i1981) sym1974) (same-marks?1446 marks1976 (vector-ref (ribcage-marks1435 ribcage1978) i1981)) #f) (values (vector-ref (ribcage-labels1436 ribcage1978) i1981) marks1976) (f1980 (fx+1383 i1981 1))))))) (f1980 0))))) (search-list-rib1967 (lambda (sym1982 subst1983 marks1984 symnames1985 ribcage1986) (letrec ((f1987 (lambda (symnames1988 i1989) (if (null? symnames1988) (search1966 sym1982 (cdr subst1983) marks1984) (if (if (eq? (car symnames1988) sym1982) (same-marks?1446 marks1984 (list-ref (ribcage-marks1435 ribcage1986) i1989)) #f) (values (list-ref (ribcage-labels1436 ribcage1986) i1989) marks1984) (f1987 (cdr symnames1988) (fx+1383 i1989 1))))))) (f1987 symnames1985 0)))) (search1966 (lambda (sym1990 subst1991 marks1992) (if (null? subst1991) (values #f marks1992) (let ((fst1993 (car subst1991))) (if (eq? fst1993 (quote shift)) (search1966 sym1990 (cdr subst1991) (cdr marks1992)) (let ((symnames1994 (ribcage-symnames1434 fst1993))) (if (vector? symnames1994) (search-vector-rib1968 sym1990 subst1991 marks1992 symnames1994 fst1993) (search-list-rib1967 sym1990 subst1991 marks1992 symnames1994 fst1993))))))))) (if (symbol? id1964) (let ((t1995 (call-with-values (lambda () (search1966 id1964 (wrap-subst1429 w1965) (wrap-marks1428 w1965))) (lambda (x1997 . ignore1996) x1997)))) (if t1995 t1995 id1964)) (if (syntax-object?1409 id1964) (let ((id1998 (syntax-object-expression1410 id1964)) (w11999 (syntax-object-wrap1411 id1964))) (let ((marks2000 (join-marks1445 (wrap-marks1428 w1965) (wrap-marks1428 w11999)))) (call-with-values (lambda () (search1966 id1998 (wrap-subst1429 w1965) marks2000)) (lambda (new-id2001 marks2002) (let ((t2003 new-id2001)) (if t2003 t2003 (let ((t2004 (call-with-values (lambda () (search1966 id1998 (wrap-subst1429 w11999) marks2002)) (lambda (x2006 . ignore2005) x2006)))) (if t2004 t2004 id1998)))))))) (syntax-violation (quote id-var-name) "invalid id" id1964)))))) (same-marks?1446 (lambda (x2007 y2008) (let ((t2009 (eq? x2007 y2008))) (if t2009 t2009 (if (not (null? x2007)) (if (not (null? y2008)) (if (eq? (car x2007) (car y2008)) (same-marks?1446 (cdr x2007) (cdr y2008)) #f) #f) #f))))) (join-marks1445 (lambda (m12010 m22011) (smart-append1443 m12010 m22011))) (join-wraps1444 (lambda (w12012 w22013) (let ((m12014 (wrap-marks1428 w12012)) (s12015 (wrap-subst1429 w12012))) (if (null? m12014) (if (null? s12015) w22013 (make-wrap1427 (wrap-marks1428 w22013) (smart-append1443 s12015 (wrap-subst1429 w22013)))) (make-wrap1427 (smart-append1443 m12014 (wrap-marks1428 w22013)) (smart-append1443 s12015 (wrap-subst1429 w22013))))))) (smart-append1443 (lambda (m12016 m22017) (if (null? m22017) m12016 (append m12016 m22017)))) (make-binding-wrap1442 (lambda (ids2018 labels2019 w2020) (if (null? ids2018) w2020 (make-wrap1427 (wrap-marks1428 w2020) (cons (let ((labelvec2021 (list->vector labels2019))) (let ((n2022 (vector-length labelvec2021))) (let ((symnamevec2023 (make-vector n2022)) (marksvec2024 (make-vector n2022))) (begin (letrec ((f2025 (lambda (ids2026 i2027) (if (not (null? ids2026)) (call-with-values (lambda () (id-sym-name&marks1426 (car ids2026) w2020)) (lambda (symname2028 marks2029) (begin (vector-set! symnamevec2023 i2027 symname2028) (vector-set! marksvec2024 i2027 marks2029) (f2025 (cdr ids2026) (fx+1383 i2027 1))))))))) (f2025 ids2018 0)) (make-ribcage1432 symnamevec2023 marksvec2024 labelvec2021))))) (wrap-subst1429 w2020)))))) (extend-ribcage!1441 (lambda (ribcage2030 id2031 label2032) (begin (set-ribcage-symnames!1437 ribcage2030 (cons (syntax-object-expression1410 id2031) (ribcage-symnames1434 ribcage2030))) (set-ribcage-marks!1438 ribcage2030 (cons (wrap-marks1428 (syntax-object-wrap1411 id2031)) (ribcage-marks1435 ribcage2030))) (set-ribcage-labels!1439 ribcage2030 (cons label2032 (ribcage-labels1436 ribcage2030)))))) (anti-mark1440 (lambda (w2033) (make-wrap1427 (cons #f (wrap-marks1428 w2033)) (cons (quote shift) (wrap-subst1429 w2033))))) (set-ribcage-labels!1439 (lambda (x2034 update2035) (vector-set! x2034 3 update2035))) (set-ribcage-marks!1438 (lambda (x2036 update2037) (vector-set! x2036 2 update2037))) (set-ribcage-symnames!1437 (lambda (x2038 update2039) (vector-set! x2038 1 update2039))) (ribcage-labels1436 (lambda (x2040) (vector-ref x2040 3))) (ribcage-marks1435 (lambda (x2041) (vector-ref x2041 2))) (ribcage-symnames1434 (lambda (x2042) (vector-ref x2042 1))) (ribcage?1433 (lambda (x2043) (if (vector? x2043) (if (= (vector-length x2043) 4) (eq? (vector-ref x2043 0) (quote ribcage)) #f) #f))) (make-ribcage1432 (lambda (symnames2044 marks2045 labels2046) (vector (quote ribcage) symnames2044 marks2045 labels2046))) (gen-labels1431 (lambda (ls2047) (if (null? ls2047) (quote ()) (cons (gen-label1430) (gen-labels1431 (cdr ls2047)))))) (gen-label1430 (lambda () (string #\i))) (wrap-subst1429 cdr) (wrap-marks1428 car) (make-wrap1427 cons) (id-sym-name&marks1426 (lambda (x2048 w2049) (if (syntax-object?1409 x2048) (values (syntax-object-expression1410 x2048) (join-marks1445 (wrap-marks1428 w2049) (wrap-marks1428 (syntax-object-wrap1411 x2048)))) (values x2048 (wrap-marks1428 w2049))))) (id?1425 (lambda (x2050) (if (symbol? x2050) #t (if (syntax-object?1409 x2050) (symbol? (syntax-object-expression1410 x2050)) #f)))) (nonsymbol-id?1424 (lambda (x2051) (if (syntax-object?1409 x2051) (symbol? (syntax-object-expression1410 x2051)) #f))) (global-extend1423 (lambda (type2052 sym2053 val2054) (put-global-definition-hook1389 sym2053 type2052 val2054))) (lookup1422 (lambda (x2055 r2056 mod2057) (let ((t2058 (assq x2055 r2056))) (if t2058 (cdr t2058) (if (symbol? x2055) (let ((t2059 (get-global-definition-hook1390 x2055 mod2057))) (if t2059 t2059 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env1421 (lambda (r2060) (if (null? r2060) (quote ()) (let ((a2061 (car r2060))) (if (eq? (cadr a2061) (quote macro)) (cons a2061 (macros-only-env1421 (cdr r2060))) (macros-only-env1421 (cdr r2060))))))) (extend-var-env1420 (lambda (labels2062 vars2063 r2064) (if (null? labels2062) r2064 (extend-var-env1420 (cdr labels2062) (cdr vars2063) (cons (cons (car labels2062) (cons (quote lexical) (car vars2063))) r2064))))) (extend-env1419 (lambda (labels2065 bindings2066 r2067) (if (null? labels2065) r2067 (extend-env1419 (cdr labels2065) (cdr bindings2066) (cons (cons (car labels2065) (car bindings2066)) r2067))))) (binding-value1418 cdr) (binding-type1417 car) (source-annotation1416 (lambda (x2068) (if (syntax-object?1409 x2068) (source-annotation1416 (syntax-object-expression1410 x2068)) (if (pair? x2068) (let ((props2069 (source-properties x2068))) (if (pair? props2069) props2069 #f)) #f)))) (set-syntax-object-module!1415 (lambda (x2070 update2071) (vector-set! x2070 3 update2071))) (set-syntax-object-wrap!1414 (lambda (x2072 update2073) (vector-set! x2072 2 update2073))) (set-syntax-object-expression!1413 (lambda (x2074 update2075) (vector-set! x2074 1 update2075))) (syntax-object-module1412 (lambda (x2076) (vector-ref x2076 3))) (syntax-object-wrap1411 (lambda (x2077) (vector-ref x2077 2))) (syntax-object-expression1410 (lambda (x2078) (vector-ref x2078 1))) (syntax-object?1409 (lambda (x2079) (if (vector? x2079) (if (= (vector-length x2079) 4) (eq? (vector-ref x2079 0) (quote syntax-object)) #f) #f))) (make-syntax-object1408 (lambda (expression2080 wrap2081 module2082) (vector (quote syntax-object) expression2080 wrap2081 module2082))) (build-letrec1407 (lambda (src2083 ids2084 vars2085 val-exps2086 body-exp2087) (if (null? vars2085) body-exp2087 (let ((atom-key2088 (fluid-ref *mode*1382))) (if (memv atom-key2088 (quote (c))) (begin (for-each maybe-name-value!1399 ids2084 val-exps2086) ((@ (language tree-il) make-letrec) src2083 ids2084 vars2085 val-exps2086 body-exp2087)) (list (quote letrec) (map list vars2085 val-exps2086) body-exp2087)))))) (build-named-let1406 (lambda (src2089 ids2090 vars2091 val-exps2092 body-exp2093) (let ((f2094 (car vars2091)) (f-name2095 (car ids2090)) (vars2096 (cdr vars2091)) (ids2097 (cdr ids2090))) (let ((atom-key2098 (fluid-ref *mode*1382))) (if (memv atom-key2098 (quote (c))) (let ((proc2099 (build-lambda1401 src2089 ids2097 vars2096 #f body-exp2093))) (begin (maybe-name-value!1399 f-name2095 proc2099) (for-each maybe-name-value!1399 ids2097 val-exps2092) ((@ (language tree-il) make-letrec) src2089 (list f-name2095) (list f2094) (list proc2099) (build-application1392 src2089 (build-lexical-reference1394 (quote fun) src2089 f-name2095 f2094) val-exps2092)))) (list (quote let) f2094 (map list vars2096 val-exps2092) body-exp2093)))))) (build-let1405 (lambda (src2100 ids2101 vars2102 val-exps2103 body-exp2104) (if (null? vars2102) body-exp2104 (let ((atom-key2105 (fluid-ref *mode*1382))) (if (memv atom-key2105 (quote (c))) (begin (for-each maybe-name-value!1399 ids2101 val-exps2103) ((@ (language tree-il) make-let) src2100 ids2101 vars2102 val-exps2103 body-exp2104)) (list (quote let) (map list vars2102 val-exps2103) body-exp2104)))))) (build-sequence1404 (lambda (src2106 exps2107) (if (null? (cdr exps2107)) (car exps2107) (let ((atom-key2108 (fluid-ref *mode*1382))) (if (memv atom-key2108 (quote (c))) ((@ (language tree-il) make-sequence) src2106 exps2107) (cons (quote begin) exps2107)))))) (build-data1403 (lambda (src2109 exp2110) (let ((atom-key2111 (fluid-ref *mode*1382))) (if (memv atom-key2111 (quote (c))) ((@ (language tree-il) make-const) src2109 exp2110) (if (if (self-evaluating? exp2110) (not (vector? exp2110)) #f) exp2110 (list (quote quote) exp2110)))))) (build-primref1402 (lambda (src2112 name2113) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2114 (fluid-ref *mode*1382))) (if (memv atom-key2114 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2112 name2113) name2113)) (let ((atom-key2115 (fluid-ref *mode*1382))) (if (memv atom-key2115 (quote (c))) ((@ (language tree-il) make-module-ref) src2112 (quote (guile)) name2113 #f) (list (quote @@) (quote (guile)) name2113)))))) (build-lambda1401 (lambda (src2116 ids2117 vars2118 docstring2119 exp2120) (let ((atom-key2121 (fluid-ref *mode*1382))) (if (memv atom-key2121 (quote (c))) ((@ (language tree-il) make-lambda) src2116 ids2117 vars2118 (if docstring2119 (list (cons (quote documentation) docstring2119)) (quote ())) exp2120) (cons (quote lambda) (cons vars2118 (append (if docstring2119 (list docstring2119) (quote ())) (list exp2120)))))))) (build-global-definition1400 (lambda (source2122 var2123 exp2124) (let ((atom-key2125 (fluid-ref *mode*1382))) (if (memv atom-key2125 (quote (c))) (begin (maybe-name-value!1399 var2123 exp2124) ((@ (language tree-il) make-toplevel-define) source2122 var2123 exp2124)) (list (quote define) var2123 exp2124))))) (maybe-name-value!1399 (lambda (name2126 val2127) (if ((@ (language tree-il) lambda?) val2127) (let ((meta2128 ((@ (language tree-il) lambda-meta) val2127))) (if (not (assq (quote name) meta2128)) ((setter (@ (language tree-il) lambda-meta)) val2127 (acons (quote name) name2126 meta2128))))))) (build-global-assignment1398 (lambda (source2129 var2130 exp2131 mod2132) (analyze-variable1396 mod2132 var2130 (lambda (mod2133 var2134 public?2135) (let ((atom-key2136 (fluid-ref *mode*1382))) (if (memv atom-key2136 (quote (c))) ((@ (language tree-il) make-module-set) source2129 mod2133 var2134 public?2135 exp2131) (list (quote set!) (list (if public?2135 (quote @) (quote @@)) mod2133 var2134) exp2131)))) (lambda (var2137) (let ((atom-key2138 (fluid-ref *mode*1382))) (if (memv atom-key2138 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2129 var2137 exp2131) (list (quote set!) var2137 exp2131))))))) (build-global-reference1397 (lambda (source2139 var2140 mod2141) (analyze-variable1396 mod2141 var2140 (lambda (mod2142 var2143 public?2144) (let ((atom-key2145 (fluid-ref *mode*1382))) (if (memv atom-key2145 (quote (c))) ((@ (language tree-il) make-module-ref) source2139 mod2142 var2143 public?2144) (list (if public?2144 (quote @) (quote @@)) mod2142 var2143)))) (lambda (var2146) (let ((atom-key2147 (fluid-ref *mode*1382))) (if (memv atom-key2147 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2139 var2146) var2146)))))) (analyze-variable1396 (lambda (mod2148 var2149 modref-cont2150 bare-cont2151) (if (not mod2148) (bare-cont2151 var2149) (let ((kind2152 (car mod2148)) (mod2153 (cdr mod2148))) (if (memv kind2152 (quote (public))) (modref-cont2150 mod2153 var2149 #t) (if (memv kind2152 (quote (private))) (if (not (equal? mod2153 (module-name (current-module)))) (modref-cont2150 mod2153 var2149 #f) (bare-cont2151 var2149)) (if (memv kind2152 (quote (bare))) (bare-cont2151 var2149) (if (memv kind2152 (quote (hygiene))) (if (if (not (equal? mod2153 (module-name (current-module)))) (module-variable (resolve-module mod2153) var2149) #f) (modref-cont2150 mod2153 var2149 #f) (bare-cont2151 var2149)) (syntax-violation #f "bad module kind" var2149 mod2153))))))))) (build-lexical-assignment1395 (lambda (source2154 name2155 var2156 exp2157) (let ((atom-key2158 (fluid-ref *mode*1382))) (if (memv atom-key2158 (quote (c))) ((@ (language tree-il) make-lexical-set) source2154 name2155 var2156 exp2157) (list (quote set!) var2156 exp2157))))) (build-lexical-reference1394 (lambda (type2159 source2160 name2161 var2162) (let ((atom-key2163 (fluid-ref *mode*1382))) (if (memv atom-key2163 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2160 name2161 var2162) var2162)))) (build-conditional1393 (lambda (source2164 test-exp2165 then-exp2166 else-exp2167) (let ((atom-key2168 (fluid-ref *mode*1382))) (if (memv atom-key2168 (quote (c))) ((@ (language tree-il) make-conditional) source2164 test-exp2165 then-exp2166 else-exp2167) (if (equal? else-exp2167 (quote (if #f #f))) (list (quote if) test-exp2165 then-exp2166) (list (quote if) test-exp2165 then-exp2166 else-exp2167)))))) (build-application1392 (lambda (source2169 fun-exp2170 arg-exps2171) (let ((atom-key2172 (fluid-ref *mode*1382))) (if (memv atom-key2172 (quote (c))) ((@ (language tree-il) make-application) source2169 fun-exp2170 arg-exps2171) (cons fun-exp2170 arg-exps2171))))) (build-void1391 (lambda (source2173) (let ((atom-key2174 (fluid-ref *mode*1382))) (if (memv atom-key2174 (quote (c))) ((@ (language tree-il) make-void) source2173) (quote (if #f #f)))))) (get-global-definition-hook1390 (lambda (symbol2175 module2176) (begin (if (if (not module2176) (current-module) #f) (warn "module system is booted, we should have a module" symbol2175)) (let ((v2177 (module-variable (if module2176 (resolve-module (cdr module2176)) (current-module)) symbol2175))) (if v2177 (if (variable-bound? v2177) (let ((val2178 (variable-ref v2177))) (if (macro? val2178) (if (syncase-macro-type val2178) (cons (syncase-macro-type val2178) (syncase-macro-binding val2178)) #f) #f)) #f) #f))))) (put-global-definition-hook1389 (lambda (symbol2179 type2180 val2181) (let ((existing2182 (let ((v2183 (module-variable (current-module) symbol2179))) (if v2183 (if (variable-bound? v2183) (let ((val2184 (variable-ref v2183))) (if (macro? val2184) (if (not (syncase-macro-type val2184)) val2184 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2179 (if existing2182 (make-extended-syncase-macro existing2182 type2180 val2181) (make-syncase-macro type2180 val2181)))))) (local-eval-hook1388 (lambda (x2185 mod2186) (primitive-eval (list noexpand1381 (let ((atom-key2187 (fluid-ref *mode*1382))) (if (memv atom-key2187 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2185) x2185)))))) (top-level-eval-hook1387 (lambda (x2188 mod2189) (primitive-eval (list noexpand1381 (let ((atom-key2190 (fluid-ref *mode*1382))) (if (memv atom-key2190 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2188) x2188)))))) (fx<1386 <) (fx=1385 =) (fx-1384 -) (fx+1383 +) (*mode*1382 (make-fluid)) (noexpand1381 "noexpand")) (begin (global-extend1423 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1423 (quote local-syntax) (quote let-syntax) #f) (global-extend1423 (quote core) (quote fluid-let-syntax) (lambda (e2191 r2192 w2193 s2194 mod2195) ((lambda (tmp2196) ((lambda (tmp2197) (if (if tmp2197 (apply (lambda (_2198 var2199 val2200 e12201 e22202) (valid-bound-ids?1450 var2199)) tmp2197) #f) (apply (lambda (_2204 var2205 val2206 e12207 e22208) (let ((names2209 (map (lambda (x2210) (id-var-name1447 x2210 w2193)) var2205))) (begin (for-each (lambda (id2212 n2213) (let ((atom-key2214 (binding-type1417 (lookup1422 n2213 r2192 mod2195)))) (if (memv atom-key2214 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2191 (source-wrap1454 id2212 w2193 s2194 mod2195))))) var2205 names2209) (chi-body1465 (cons e12207 e22208) (source-wrap1454 e2191 w2193 s2194 mod2195) (extend-env1419 names2209 (let ((trans-r2217 (macros-only-env1421 r2192))) (map (lambda (x2218) (cons (quote macro) (eval-local-transformer1468 (chi1461 x2218 trans-r2217 w2193 mod2195) mod2195))) val2206)) r2192) w2193 mod2195)))) tmp2197) ((lambda (_2220) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1454 e2191 w2193 s2194 mod2195))) tmp2196))) ($sc-dispatch tmp2196 (quote (any #(each (any any)) any . each-any))))) e2191))) (global-extend1423 (quote core) (quote quote) (lambda (e2221 r2222 w2223 s2224 mod2225) ((lambda (tmp2226) ((lambda (tmp2227) (if tmp2227 (apply (lambda (_2228 e2229) (build-data1403 s2224 (strip1471 e2229 w2223))) tmp2227) ((lambda (_2230) (syntax-violation (quote quote) "bad syntax" (source-wrap1454 e2221 w2223 s2224 mod2225))) tmp2226))) ($sc-dispatch tmp2226 (quote (any any))))) e2221))) (global-extend1423 (quote core) (quote syntax) (letrec ((regen2238 (lambda (x2239) (let ((atom-key2240 (car x2239))) (if (memv atom-key2240 (quote (ref))) (build-lexical-reference1394 (quote value) #f (cadr x2239) (cadr x2239)) (if (memv atom-key2240 (quote (primitive))) (build-primref1402 #f (cadr x2239)) (if (memv atom-key2240 (quote (quote))) (build-data1403 #f (cadr x2239)) (if (memv atom-key2240 (quote (lambda))) (build-lambda1401 #f (cadr x2239) (cadr x2239) #f (regen2238 (caddr x2239))) (build-application1392 #f (build-primref1402 #f (car x2239)) (map regen2238 (cdr x2239)))))))))) (gen-vector2237 (lambda (x2241) (if (eq? (car x2241) (quote list)) (cons (quote vector) (cdr x2241)) (if (eq? (car x2241) (quote quote)) (list (quote quote) (list->vector (cadr x2241))) (list (quote list->vector) x2241))))) (gen-append2236 (lambda (x2242 y2243) (if (equal? y2243 (quote (quote ()))) x2242 (list (quote append) x2242 y2243)))) (gen-cons2235 (lambda (x2244 y2245) (let ((atom-key2246 (car y2245))) (if (memv atom-key2246 (quote (quote))) (if (eq? (car x2244) (quote quote)) (list (quote quote) (cons (cadr x2244) (cadr y2245))) (if (eq? (cadr y2245) (quote ())) (list (quote list) x2244) (list (quote cons) x2244 y2245))) (if (memv atom-key2246 (quote (list))) (cons (quote list) (cons x2244 (cdr y2245))) (list (quote cons) x2244 y2245)))))) (gen-map2234 (lambda (e2247 map-env2248) (let ((formals2249 (map cdr map-env2248)) (actuals2250 (map (lambda (x2251) (list (quote ref) (car x2251))) map-env2248))) (if (eq? (car e2247) (quote ref)) (car actuals2250) (if (and-map (lambda (x2252) (if (eq? (car x2252) (quote ref)) (memq (cadr x2252) formals2249) #f)) (cdr e2247)) (cons (quote map) (cons (list (quote primitive) (car e2247)) (map (let ((r2253 (map cons formals2249 actuals2250))) (lambda (x2254) (cdr (assq (cadr x2254) r2253)))) (cdr e2247)))) (cons (quote map) (cons (list (quote lambda) formals2249 e2247) actuals2250))))))) (gen-mappend2233 (lambda (e2255 map-env2256) (list (quote apply) (quote (primitive append)) (gen-map2234 e2255 map-env2256)))) (gen-ref2232 (lambda (src2257 var2258 level2259 maps2260) (if (fx=1385 level2259 0) (values var2258 maps2260) (if (null? maps2260) (syntax-violation (quote syntax) "missing ellipsis" src2257) (call-with-values (lambda () (gen-ref2232 src2257 var2258 (fx-1384 level2259 1) (cdr maps2260))) (lambda (outer-var2261 outer-maps2262) (let ((b2263 (assq outer-var2261 (car maps2260)))) (if b2263 (values (cdr b2263) maps2260) (let ((inner-var2264 (gen-var1472 (quote tmp)))) (values inner-var2264 (cons (cons (cons outer-var2261 inner-var2264) (car maps2260)) outer-maps2262))))))))))) (gen-syntax2231 (lambda (src2265 e2266 r2267 maps2268 ellipsis?2269 mod2270) (if (id?1425 e2266) (let ((label2271 (id-var-name1447 e2266 (quote (()))))) (let ((b2272 (lookup1422 label2271 r2267 mod2270))) (if (eq? (binding-type1417 b2272) (quote syntax)) (call-with-values (lambda () (let ((var.lev2273 (binding-value1418 b2272))) (gen-ref2232 src2265 (car var.lev2273) (cdr var.lev2273) maps2268))) (lambda (var2274 maps2275) (values (list (quote ref) var2274) maps2275))) (if (ellipsis?2269 e2266) (syntax-violation (quote syntax) "misplaced ellipsis" src2265) (values (list (quote quote) e2266) maps2268))))) ((lambda (tmp2276) ((lambda (tmp2277) (if (if tmp2277 (apply (lambda (dots2278 e2279) (ellipsis?2269 dots2278)) tmp2277) #f) (apply (lambda (dots2280 e2281) (gen-syntax2231 src2265 e2281 r2267 maps2268 (lambda (x2282) #f) mod2270)) tmp2277) ((lambda (tmp2283) (if (if tmp2283 (apply (lambda (x2284 dots2285 y2286) (ellipsis?2269 dots2285)) tmp2283) #f) (apply (lambda (x2287 dots2288 y2289) (letrec ((f2290 (lambda (y2291 k2292) ((lambda (tmp2296) ((lambda (tmp2297) (if (if tmp2297 (apply (lambda (dots2298 y2299) (ellipsis?2269 dots2298)) tmp2297) #f) (apply (lambda (dots2300 y2301) (f2290 y2301 (lambda (maps2302) (call-with-values (lambda () (k2292 (cons (quote ()) maps2302))) (lambda (x2303 maps2304) (if (null? (car maps2304)) (syntax-violation (quote syntax) "extra ellipsis" src2265) (values (gen-mappend2233 x2303 (car maps2304)) (cdr maps2304)))))))) tmp2297) ((lambda (_2305) (call-with-values (lambda () (gen-syntax2231 src2265 y2291 r2267 maps2268 ellipsis?2269 mod2270)) (lambda (y2306 maps2307) (call-with-values (lambda () (k2292 maps2307)) (lambda (x2308 maps2309) (values (gen-append2236 x2308 y2306) maps2309)))))) tmp2296))) ($sc-dispatch tmp2296 (quote (any . any))))) y2291)))) (f2290 y2289 (lambda (maps2293) (call-with-values (lambda () (gen-syntax2231 src2265 x2287 r2267 (cons (quote ()) maps2293) ellipsis?2269 mod2270)) (lambda (x2294 maps2295) (if (null? (car maps2295)) (syntax-violation (quote syntax) "extra ellipsis" src2265) (values (gen-map2234 x2294 (car maps2295)) (cdr maps2295))))))))) tmp2283) ((lambda (tmp2310) (if tmp2310 (apply (lambda (x2311 y2312) (call-with-values (lambda () (gen-syntax2231 src2265 x2311 r2267 maps2268 ellipsis?2269 mod2270)) (lambda (x2313 maps2314) (call-with-values (lambda () (gen-syntax2231 src2265 y2312 r2267 maps2314 ellipsis?2269 mod2270)) (lambda (y2315 maps2316) (values (gen-cons2235 x2313 y2315) maps2316)))))) tmp2310) ((lambda (tmp2317) (if tmp2317 (apply (lambda (e12318 e22319) (call-with-values (lambda () (gen-syntax2231 src2265 (cons e12318 e22319) r2267 maps2268 ellipsis?2269 mod2270)) (lambda (e2321 maps2322) (values (gen-vector2237 e2321) maps2322)))) tmp2317) ((lambda (_2323) (values (list (quote quote) e2266) maps2268)) tmp2276))) ($sc-dispatch tmp2276 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2276 (quote (any . any)))))) ($sc-dispatch tmp2276 (quote (any any . any)))))) ($sc-dispatch tmp2276 (quote (any any))))) e2266))))) (lambda (e2324 r2325 w2326 s2327 mod2328) (let ((e2329 (source-wrap1454 e2324 w2326 s2327 mod2328))) ((lambda (tmp2330) ((lambda (tmp2331) (if tmp2331 (apply (lambda (_2332 x2333) (call-with-values (lambda () (gen-syntax2231 e2329 x2333 r2325 (quote ()) ellipsis?1470 mod2328)) (lambda (e2334 maps2335) (regen2238 e2334)))) tmp2331) ((lambda (_2336) (syntax-violation (quote syntax) "bad `syntax' form" e2329)) tmp2330))) ($sc-dispatch tmp2330 (quote (any any))))) e2329))))) (global-extend1423 (quote core) (quote lambda) (lambda (e2337 r2338 w2339 s2340 mod2341) ((lambda (tmp2342) ((lambda (tmp2343) (if tmp2343 (apply (lambda (_2344 c2345) (chi-lambda-clause1466 (source-wrap1454 e2337 w2339 s2340 mod2341) #f c2345 r2338 w2339 mod2341 (lambda (names2346 vars2347 docstring2348 body2349) (build-lambda1401 s2340 names2346 vars2347 docstring2348 body2349)))) tmp2343) (syntax-violation #f "source expression failed to match any pattern" tmp2342))) ($sc-dispatch tmp2342 (quote (any . any))))) e2337))) (global-extend1423 (quote core) (quote let) (letrec ((chi-let2350 (lambda (e2351 r2352 w2353 s2354 mod2355 constructor2356 ids2357 vals2358 exps2359) (if (not (valid-bound-ids?1450 ids2357)) (syntax-violation (quote let) "duplicate bound variable" e2351) (let ((labels2360 (gen-labels1431 ids2357)) (new-vars2361 (map gen-var1472 ids2357))) (let ((nw2362 (make-binding-wrap1442 ids2357 labels2360 w2353)) (nr2363 (extend-var-env1420 labels2360 new-vars2361 r2352))) (constructor2356 s2354 (map syntax->datum ids2357) new-vars2361 (map (lambda (x2364) (chi1461 x2364 r2352 w2353 mod2355)) vals2358) (chi-body1465 exps2359 (source-wrap1454 e2351 nw2362 s2354 mod2355) nr2363 nw2362 mod2355)))))))) (lambda (e2365 r2366 w2367 s2368 mod2369) ((lambda (tmp2370) ((lambda (tmp2371) (if (if tmp2371 (apply (lambda (_2372 id2373 val2374 e12375 e22376) (and-map id?1425 id2373)) tmp2371) #f) (apply (lambda (_2378 id2379 val2380 e12381 e22382) (chi-let2350 e2365 r2366 w2367 s2368 mod2369 build-let1405 id2379 val2380 (cons e12381 e22382))) tmp2371) ((lambda (tmp2386) (if (if tmp2386 (apply (lambda (_2387 f2388 id2389 val2390 e12391 e22392) (if (id?1425 f2388) (and-map id?1425 id2389) #f)) tmp2386) #f) (apply (lambda (_2394 f2395 id2396 val2397 e12398 e22399) (chi-let2350 e2365 r2366 w2367 s2368 mod2369 build-named-let1406 (cons f2395 id2396) val2397 (cons e12398 e22399))) tmp2386) ((lambda (_2403) (syntax-violation (quote let) "bad let" (source-wrap1454 e2365 w2367 s2368 mod2369))) tmp2370))) ($sc-dispatch tmp2370 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2370 (quote (any #(each (any any)) any . each-any))))) e2365)))) (global-extend1423 (quote core) (quote letrec) (lambda (e2404 r2405 w2406 s2407 mod2408) ((lambda (tmp2409) ((lambda (tmp2410) (if (if tmp2410 (apply (lambda (_2411 id2412 val2413 e12414 e22415) (and-map id?1425 id2412)) tmp2410) #f) (apply (lambda (_2417 id2418 val2419 e12420 e22421) (let ((ids2422 id2418)) (if (not (valid-bound-ids?1450 ids2422)) (syntax-violation (quote letrec) "duplicate bound variable" e2404) (let ((labels2424 (gen-labels1431 ids2422)) (new-vars2425 (map gen-var1472 ids2422))) (let ((w2426 (make-binding-wrap1442 ids2422 labels2424 w2406)) (r2427 (extend-var-env1420 labels2424 new-vars2425 r2405))) (build-letrec1407 s2407 (map syntax->datum ids2422) new-vars2425 (map (lambda (x2428) (chi1461 x2428 r2427 w2426 mod2408)) val2419) (chi-body1465 (cons e12420 e22421) (source-wrap1454 e2404 w2426 s2407 mod2408) r2427 w2426 mod2408))))))) tmp2410) ((lambda (_2431) (syntax-violation (quote letrec) "bad letrec" (source-wrap1454 e2404 w2406 s2407 mod2408))) tmp2409))) ($sc-dispatch tmp2409 (quote (any #(each (any any)) any . each-any))))) e2404))) (global-extend1423 (quote core) (quote set!) (lambda (e2432 r2433 w2434 s2435 mod2436) ((lambda (tmp2437) ((lambda (tmp2438) (if (if tmp2438 (apply (lambda (_2439 id2440 val2441) (id?1425 id2440)) tmp2438) #f) (apply (lambda (_2442 id2443 val2444) (let ((val2445 (chi1461 val2444 r2433 w2434 mod2436)) (n2446 (id-var-name1447 id2443 w2434))) (let ((b2447 (lookup1422 n2446 r2433 mod2436))) (let ((atom-key2448 (binding-type1417 b2447))) (if (memv atom-key2448 (quote (lexical))) (build-lexical-assignment1395 s2435 (syntax->datum id2443) (binding-value1418 b2447) val2445) (if (memv atom-key2448 (quote (global))) (build-global-assignment1398 s2435 n2446 val2445 mod2436) (if (memv atom-key2448 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1453 id2443 w2434 mod2436)) (syntax-violation (quote set!) "bad set!" (source-wrap1454 e2432 w2434 s2435 mod2436))))))))) tmp2438) ((lambda (tmp2449) (if tmp2449 (apply (lambda (_2450 head2451 tail2452 val2453) (call-with-values (lambda () (syntax-type1459 head2451 r2433 (quote (())) #f #f mod2436 #t)) (lambda (type2454 value2455 ee2456 ww2457 ss2458 modmod2459) (if (memv type2454 (quote (module-ref))) (let ((val2460 (chi1461 val2453 r2433 w2434 mod2436))) (call-with-values (lambda () (value2455 (cons head2451 tail2452))) (lambda (id2462 mod2463) (build-global-assignment1398 s2435 id2462 val2460 mod2463)))) (build-application1392 s2435 (chi1461 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head2451) r2433 w2434 mod2436) (map (lambda (e2464) (chi1461 e2464 r2433 w2434 mod2436)) (append tail2452 (list val2453)))))))) tmp2449) ((lambda (_2466) (syntax-violation (quote set!) "bad set!" (source-wrap1454 e2432 w2434 s2435 mod2436))) tmp2437))) ($sc-dispatch tmp2437 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2437 (quote (any any any))))) e2432))) (global-extend1423 (quote module-ref) (quote @) (lambda (e2467) ((lambda (tmp2468) ((lambda (tmp2469) (if (if tmp2469 (apply (lambda (_2470 mod2471 id2472) (if (and-map id?1425 mod2471) (id?1425 id2472) #f)) tmp2469) #f) (apply (lambda (_2474 mod2475 id2476) (values (syntax->datum id2476) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2475)))) tmp2469) (syntax-violation #f "source expression failed to match any pattern" tmp2468))) ($sc-dispatch tmp2468 (quote (any each-any any))))) e2467))) (global-extend1423 (quote module-ref) (quote @@) (lambda (e2478) ((lambda (tmp2479) ((lambda (tmp2480) (if (if tmp2480 (apply (lambda (_2481 mod2482 id2483) (if (and-map id?1425 mod2482) (id?1425 id2483) #f)) tmp2480) #f) (apply (lambda (_2485 mod2486 id2487) (values (syntax->datum id2487) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod2486)))) tmp2480) (syntax-violation #f "source expression failed to match any pattern" tmp2479))) ($sc-dispatch tmp2479 (quote (any each-any any))))) e2478))) (global-extend1423 (quote core) (quote if) (lambda (e2489 r2490 w2491 s2492 mod2493) ((lambda (tmp2494) ((lambda (tmp2495) (if tmp2495 (apply (lambda (_2496 test2497 then2498) (build-conditional1393 s2492 (chi1461 test2497 r2490 w2491 mod2493) (chi1461 then2498 r2490 w2491 mod2493) (build-void1391 #f))) tmp2495) ((lambda (tmp2499) (if tmp2499 (apply (lambda (_2500 test2501 then2502 else2503) (build-conditional1393 s2492 (chi1461 test2501 r2490 w2491 mod2493) (chi1461 then2502 r2490 w2491 mod2493) (chi1461 else2503 r2490 w2491 mod2493))) tmp2499) (syntax-violation #f "source expression failed to match any pattern" tmp2494))) ($sc-dispatch tmp2494 (quote (any any any any)))))) ($sc-dispatch tmp2494 (quote (any any any))))) e2489))) (global-extend1423 (quote begin) (quote begin) (quote ())) (global-extend1423 (quote define) (quote define) (quote ())) (global-extend1423 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1423 (quote eval-when) (quote eval-when) (quote ())) (global-extend1423 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2507 (lambda (x2508 keys2509 clauses2510 r2511 mod2512) (if (null? clauses2510) (build-application1392 #f (build-primref1402 #f (quote syntax-violation)) (list (build-data1403 #f #f) (build-data1403 #f "source expression failed to match any pattern") x2508)) ((lambda (tmp2513) ((lambda (tmp2514) (if tmp2514 (apply (lambda (pat2515 exp2516) (if (if (id?1425 pat2515) (and-map (lambda (x2517) (not (free-id=?1448 pat2515 x2517))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys2509)) #f) (let ((labels2518 (list (gen-label1430))) (var2519 (gen-var1472 pat2515))) (build-application1392 #f (build-lambda1401 #f (list (syntax->datum pat2515)) (list var2519) #f (chi1461 exp2516 (extend-env1419 labels2518 (list (cons (quote syntax) (cons var2519 0))) r2511) (make-binding-wrap1442 (list pat2515) labels2518 (quote (()))) mod2512)) (list x2508))) (gen-clause2506 x2508 keys2509 (cdr clauses2510) r2511 pat2515 #t exp2516 mod2512))) tmp2514) ((lambda (tmp2520) (if tmp2520 (apply (lambda (pat2521 fender2522 exp2523) (gen-clause2506 x2508 keys2509 (cdr clauses2510) r2511 pat2521 fender2522 exp2523 mod2512)) tmp2520) ((lambda (_2524) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2510))) tmp2513))) ($sc-dispatch tmp2513 (quote (any any any)))))) ($sc-dispatch tmp2513 (quote (any any))))) (car clauses2510))))) (gen-clause2506 (lambda (x2525 keys2526 clauses2527 r2528 pat2529 fender2530 exp2531 mod2532) (call-with-values (lambda () (convert-pattern2504 pat2529 keys2526)) (lambda (p2533 pvars2534) (if (not (distinct-bound-ids?1451 (map car pvars2534))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2529) (if (not (and-map (lambda (x2535) (not (ellipsis?1470 (car x2535)))) pvars2534)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2529) (let ((y2536 (gen-var1472 (quote tmp)))) (build-application1392 #f (build-lambda1401 #f (list (quote tmp)) (list y2536) #f (let ((y2537 (build-lexical-reference1394 (quote value) #f (quote tmp) y2536))) (build-conditional1393 #f ((lambda (tmp2538) ((lambda (tmp2539) (if tmp2539 (apply (lambda () y2537) tmp2539) ((lambda (_2540) (build-conditional1393 #f y2537 (build-dispatch-call2505 pvars2534 fender2530 y2537 r2528 mod2532) (build-data1403 #f #f))) tmp2538))) ($sc-dispatch tmp2538 (quote #(atom #t))))) fender2530) (build-dispatch-call2505 pvars2534 exp2531 y2537 r2528 mod2532) (gen-syntax-case2507 x2525 keys2526 clauses2527 r2528 mod2532)))) (list (if (eq? p2533 (quote any)) (build-application1392 #f (build-primref1402 #f (quote list)) (list x2525)) (build-application1392 #f (build-primref1402 #f (quote $sc-dispatch)) (list x2525 (build-data1403 #f p2533))))))))))))) (build-dispatch-call2505 (lambda (pvars2541 exp2542 y2543 r2544 mod2545) (let ((ids2546 (map car pvars2541)) (levels2547 (map cdr pvars2541))) (let ((labels2548 (gen-labels1431 ids2546)) (new-vars2549 (map gen-var1472 ids2546))) (build-application1392 #f (build-primref1402 #f (quote apply)) (list (build-lambda1401 #f (map syntax->datum ids2546) new-vars2549 #f (chi1461 exp2542 (extend-env1419 labels2548 (map (lambda (var2550 level2551) (cons (quote syntax) (cons var2550 level2551))) new-vars2549 (map cdr pvars2541)) r2544) (make-binding-wrap1442 ids2546 labels2548 (quote (()))) mod2545)) y2543)))))) (convert-pattern2504 (lambda (pattern2552 keys2553) (letrec ((cvt2554 (lambda (p2555 n2556 ids2557) (if (id?1425 p2555) (if (bound-id-member?1452 p2555 keys2553) (values (vector (quote free-id) p2555) ids2557) (values (quote any) (cons (cons p2555 n2556) ids2557))) ((lambda (tmp2558) ((lambda (tmp2559) (if (if tmp2559 (apply (lambda (x2560 dots2561) (ellipsis?1470 dots2561)) tmp2559) #f) (apply (lambda (x2562 dots2563) (call-with-values (lambda () (cvt2554 x2562 (fx+1383 n2556 1) ids2557)) (lambda (p2564 ids2565) (values (if (eq? p2564 (quote any)) (quote each-any) (vector (quote each) p2564)) ids2565)))) tmp2559) ((lambda (tmp2566) (if tmp2566 (apply (lambda (x2567 y2568) (call-with-values (lambda () (cvt2554 y2568 n2556 ids2557)) (lambda (y2569 ids2570) (call-with-values (lambda () (cvt2554 x2567 n2556 ids2570)) (lambda (x2571 ids2572) (values (cons x2571 y2569) ids2572)))))) tmp2566) ((lambda (tmp2573) (if tmp2573 (apply (lambda () (values (quote ()) ids2557)) tmp2573) ((lambda (tmp2574) (if tmp2574 (apply (lambda (x2575) (call-with-values (lambda () (cvt2554 x2575 n2556 ids2557)) (lambda (p2577 ids2578) (values (vector (quote vector) p2577) ids2578)))) tmp2574) ((lambda (x2579) (values (vector (quote atom) (strip1471 p2555 (quote (())))) ids2557)) tmp2558))) ($sc-dispatch tmp2558 (quote #(vector each-any)))))) ($sc-dispatch tmp2558 (quote ()))))) ($sc-dispatch tmp2558 (quote (any . any)))))) ($sc-dispatch tmp2558 (quote (any any))))) p2555))))) (cvt2554 pattern2552 0 (quote ())))))) (lambda (e2580 r2581 w2582 s2583 mod2584) (let ((e2585 (source-wrap1454 e2580 w2582 s2583 mod2584))) ((lambda (tmp2586) ((lambda (tmp2587) (if tmp2587 (apply (lambda (_2588 val2589 key2590 m2591) (if (and-map (lambda (x2592) (if (id?1425 x2592) (not (ellipsis?1470 x2592)) #f)) key2590) (let ((x2594 (gen-var1472 (quote tmp)))) (build-application1392 s2583 (build-lambda1401 #f (list (quote tmp)) (list x2594) #f (gen-syntax-case2507 (build-lexical-reference1394 (quote value) #f (quote tmp) x2594) key2590 m2591 r2581 mod2584)) (list (chi1461 val2589 r2581 (quote (())) mod2584)))) (syntax-violation (quote syntax-case) "invalid literals list" e2585))) tmp2587) (syntax-violation #f "source expression failed to match any pattern" tmp2586))) ($sc-dispatch tmp2586 (quote (any any each-any . each-any))))) e2585))))) (set! sc-expand (lambda (x2598 . rest2597) (if (if (pair? x2598) (equal? (car x2598) noexpand1381) #f) (cadr x2598) (let ((m2599 (if (null? rest2597) (quote e) (car rest2597))) (esew2600 (if (let ((t2601 (null? rest2597))) (if t2601 t2601 (null? (cdr rest2597)))) (quote (eval)) (cadr rest2597)))) (with-fluid* *mode*1382 m2599 (lambda () (chi-top1460 x2598 (quote ()) (quote ((top))) m2599 esew2600 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x2602) (nonsymbol-id?1424 x2602))) (set! datum->syntax (lambda (id2603 datum2604) (make-syntax-object1408 datum2604 (syntax-object-wrap1411 id2603) #f))) (set! syntax->datum (lambda (x2605) (strip1471 x2605 (quote (()))))) (set! generate-temporaries (lambda (ls2606) (begin (let ((x2607 ls2606)) (if (not (list? x2607)) (syntax-violation (quote generate-temporaries) "invalid argument" x2607))) (map (lambda (x2608) (wrap1453 (gensym) (quote ((top))) #f)) ls2606)))) (set! free-identifier=? (lambda (x2609 y2610) (begin (let ((x2611 x2609)) (if (not (nonsymbol-id?1424 x2611)) (syntax-violation (quote free-identifier=?) "invalid argument" x2611))) (let ((x2612 y2610)) (if (not (nonsymbol-id?1424 x2612)) (syntax-violation (quote free-identifier=?) "invalid argument" x2612))) (free-id=?1448 x2609 y2610)))) (set! bound-identifier=? (lambda (x2613 y2614) (begin (let ((x2615 x2613)) (if (not (nonsymbol-id?1424 x2615)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2615))) (let ((x2616 y2614)) (if (not (nonsymbol-id?1424 x2616)) (syntax-violation (quote bound-identifier=?) "invalid argument" x2616))) (bound-id=?1449 x2613 y2614)))) (set! syntax-violation (lambda (who2620 message2619 form2618 . subform2617) (begin (let ((x2621 who2620)) (if (not ((lambda (x2622) (let ((t2623 (not x2622))) (if t2623 t2623 (let ((t2624 (string? x2622))) (if t2624 t2624 (symbol? x2622)))))) x2621)) (syntax-violation (quote syntax-violation) "invalid argument" x2621))) (let ((x2625 message2619)) (if (not (string? x2625)) (syntax-violation (quote syntax-violation) "invalid argument" x2625))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2620 "~a: " "") "~a " (if (null? subform2617) "in ~a" "in subform `~s' of `~s'")) (let ((tail2626 (cons message2619 (map (lambda (x2627) (strip1471 x2627 (quote (())))) (append subform2617 (list form2618)))))) (if who2620 (cons who2620 tail2626) tail2626)) #f)))) (letrec ((match2632 (lambda (e2633 p2634 w2635 r2636 mod2637) (if (not r2636) #f (if (eq? p2634 (quote any)) (cons (wrap1453 e2633 w2635 mod2637) r2636) (if (syntax-object?1409 e2633) (match*2631 (syntax-object-expression1410 e2633) p2634 (join-wraps1444 w2635 (syntax-object-wrap1411 e2633)) r2636 (syntax-object-module1412 e2633)) (match*2631 e2633 p2634 w2635 r2636 mod2637)))))) (match*2631 (lambda (e2638 p2639 w2640 r2641 mod2642) (if (null? p2639) (if (null? e2638) r2641 #f) (if (pair? p2639) (if (pair? e2638) (match2632 (car e2638) (car p2639) w2640 (match2632 (cdr e2638) (cdr p2639) w2640 r2641 mod2642) mod2642) #f) (if (eq? p2639 (quote each-any)) (let ((l2643 (match-each-any2629 e2638 w2640 mod2642))) (if l2643 (cons l2643 r2641) #f)) (let ((atom-key2644 (vector-ref p2639 0))) (if (memv atom-key2644 (quote (each))) (if (null? e2638) (match-empty2630 (vector-ref p2639 1) r2641) (let ((l2645 (match-each2628 e2638 (vector-ref p2639 1) w2640 mod2642))) (if l2645 (letrec ((collect2646 (lambda (l2647) (if (null? (car l2647)) r2641 (cons (map car l2647) (collect2646 (map cdr l2647))))))) (collect2646 l2645)) #f))) (if (memv atom-key2644 (quote (free-id))) (if (id?1425 e2638) (if (free-id=?1448 (wrap1453 e2638 w2640 mod2642) (vector-ref p2639 1)) r2641 #f) #f) (if (memv atom-key2644 (quote (atom))) (if (equal? (vector-ref p2639 1) (strip1471 e2638 w2640)) r2641 #f) (if (memv atom-key2644 (quote (vector))) (if (vector? e2638) (match2632 (vector->list e2638) (vector-ref p2639 1) w2640 r2641 mod2642) #f))))))))))) (match-empty2630 (lambda (p2648 r2649) (if (null? p2648) r2649 (if (eq? p2648 (quote any)) (cons (quote ()) r2649) (if (pair? p2648) (match-empty2630 (car p2648) (match-empty2630 (cdr p2648) r2649)) (if (eq? p2648 (quote each-any)) (cons (quote ()) r2649) (let ((atom-key2650 (vector-ref p2648 0))) (if (memv atom-key2650 (quote (each))) (match-empty2630 (vector-ref p2648 1) r2649) (if (memv atom-key2650 (quote (free-id atom))) r2649 (if (memv atom-key2650 (quote (vector))) (match-empty2630 (vector-ref p2648 1) r2649))))))))))) (match-each-any2629 (lambda (e2651 w2652 mod2653) (if (pair? e2651) (let ((l2654 (match-each-any2629 (cdr e2651) w2652 mod2653))) (if l2654 (cons (wrap1453 (car e2651) w2652 mod2653) l2654) #f)) (if (null? e2651) (quote ()) (if (syntax-object?1409 e2651) (match-each-any2629 (syntax-object-expression1410 e2651) (join-wraps1444 w2652 (syntax-object-wrap1411 e2651)) mod2653) #f))))) (match-each2628 (lambda (e2655 p2656 w2657 mod2658) (if (pair? e2655) (let ((first2659 (match2632 (car e2655) p2656 w2657 (quote ()) mod2658))) (if first2659 (let ((rest2660 (match-each2628 (cdr e2655) p2656 w2657 mod2658))) (if rest2660 (cons first2659 rest2660) #f)) #f)) (if (null? e2655) (quote ()) (if (syntax-object?1409 e2655) (match-each2628 (syntax-object-expression1410 e2655) p2656 (join-wraps1444 w2657 (syntax-object-wrap1411 e2655)) (syntax-object-module1412 e2655)) #f)))))) (set! $sc-dispatch (lambda (e2661 p2662) (if (eq? p2662 (quote any)) (list e2661) (if (syntax-object?1409 e2661) (match*2631 (syntax-object-expression1410 e2661) p2662 (syntax-object-wrap1411 e2661) (quote ()) (syntax-object-module1412 e2661)) (match*2631 e2661 p2662 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x2663) ((lambda (tmp2664) ((lambda (tmp2665) (if tmp2665 (apply (lambda (_2666 e12667 e22668) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12667 e22668))) tmp2665) ((lambda (tmp2670) (if tmp2670 (apply (lambda (_2671 out2672 in2673 e12674 e22675) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2673 (quote ()) (list out2672 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12674 e22675))))) tmp2670) ((lambda (tmp2677) (if tmp2677 (apply (lambda (_2678 out2679 in2680 e12681 e22682) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in2680) (quote ()) (list out2679 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12681 e22682))))) tmp2677) (syntax-violation #f "source expression failed to match any pattern" tmp2664))) ($sc-dispatch tmp2664 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2664 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2664 (quote (any () any . each-any))))) x2663)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2686) ((lambda (tmp2687) ((lambda (tmp2688) (if tmp2688 (apply (lambda (_2689 k2690 keyword2691 pattern2692 template2693) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k2690 (map (lambda (tmp2696 tmp2695) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2695) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp2696))) template2693 pattern2692)))))) tmp2688) (syntax-violation #f "source expression failed to match any pattern" tmp2687))) ($sc-dispatch tmp2687 (quote (any each-any . #(each ((any . any) any))))))) x2686)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2697) ((lambda (tmp2698) ((lambda (tmp2699) (if (if tmp2699 (apply (lambda (let*2700 x2701 v2702 e12703 e22704) (and-map identifier? x2701)) tmp2699) #f) (apply (lambda (let*2706 x2707 v2708 e12709 e22710) (letrec ((f2711 (lambda (bindings2712) (if (null? bindings2712) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e12709 e22710))) ((lambda (tmp2716) ((lambda (tmp2717) (if tmp2717 (apply (lambda (body2718 binding2719) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2719) body2718)) tmp2717) (syntax-violation #f "source expression failed to match any pattern" tmp2716))) ($sc-dispatch tmp2716 (quote (any any))))) (list (f2711 (cdr bindings2712)) (car bindings2712))))))) (f2711 (map list x2707 v2708)))) tmp2699) (syntax-violation #f "source expression failed to match any pattern" tmp2698))) ($sc-dispatch tmp2698 (quote (any #(each (any any)) any . each-any))))) x2697)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2720) ((lambda (tmp2721) ((lambda (tmp2722) (if tmp2722 (apply (lambda (_2723 var2724 init2725 step2726 e02727 e12728 c2729) ((lambda (tmp2730) ((lambda (tmp2731) (if tmp2731 (apply (lambda (step2732) ((lambda (tmp2733) ((lambda (tmp2734) (if tmp2734 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2724 init2725) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02727) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2729 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2732))))))) tmp2734) ((lambda (tmp2739) (if tmp2739 (apply (lambda (e12740 e22741) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2724 init2725) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02727 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e12740 e22741)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2729 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step2732))))))) tmp2739) (syntax-violation #f "source expression failed to match any pattern" tmp2733))) ($sc-dispatch tmp2733 (quote (any . each-any)))))) ($sc-dispatch tmp2733 (quote ())))) e12728)) tmp2731) (syntax-violation #f "source expression failed to match any pattern" tmp2730))) ($sc-dispatch tmp2730 (quote each-any)))) (map (lambda (v2748 s2749) ((lambda (tmp2750) ((lambda (tmp2751) (if tmp2751 (apply (lambda () v2748) tmp2751) ((lambda (tmp2752) (if tmp2752 (apply (lambda (e2753) e2753) tmp2752) ((lambda (_2754) (syntax-violation (quote do) "bad step expression" orig-x2720 s2749)) tmp2750))) ($sc-dispatch tmp2750 (quote (any)))))) ($sc-dispatch tmp2750 (quote ())))) s2749)) var2724 step2726))) tmp2722) (syntax-violation #f "source expression failed to match any pattern" tmp2721))) ($sc-dispatch tmp2721 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2720)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2757 (lambda (x2761 y2762) ((lambda (tmp2763) ((lambda (tmp2764) (if tmp2764 (apply (lambda (x2765 y2766) ((lambda (tmp2767) ((lambda (tmp2768) (if tmp2768 (apply (lambda (dy2769) ((lambda (tmp2770) ((lambda (tmp2771) (if tmp2771 (apply (lambda (dx2772) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2772 dy2769))) tmp2771) ((lambda (_2773) (if (null? dy2769) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2765) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2765 y2766))) tmp2770))) ($sc-dispatch tmp2770 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2765)) tmp2768) ((lambda (tmp2774) (if tmp2774 (apply (lambda (stuff2775) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x2765 stuff2775))) tmp2774) ((lambda (else2776) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2765 y2766)) tmp2767))) ($sc-dispatch tmp2767 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2767 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2766)) tmp2764) (syntax-violation #f "source expression failed to match any pattern" tmp2763))) ($sc-dispatch tmp2763 (quote (any any))))) (list x2761 y2762)))) (quasiappend2758 (lambda (x2777 y2778) ((lambda (tmp2779) ((lambda (tmp2780) (if tmp2780 (apply (lambda (x2781 y2782) ((lambda (tmp2783) ((lambda (tmp2784) (if tmp2784 (apply (lambda () x2781) tmp2784) ((lambda (_2785) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2781 y2782)) tmp2783))) ($sc-dispatch tmp2783 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y2782)) tmp2780) (syntax-violation #f "source expression failed to match any pattern" tmp2779))) ($sc-dispatch tmp2779 (quote (any any))))) (list x2777 y2778)))) (quasivector2759 (lambda (x2786) ((lambda (tmp2787) ((lambda (x2788) ((lambda (tmp2789) ((lambda (tmp2790) (if tmp2790 (apply (lambda (x2791) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2791))) tmp2790) ((lambda (tmp2793) (if tmp2793 (apply (lambda (x2794) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2794)) tmp2793) ((lambda (_2796) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2788)) tmp2789))) ($sc-dispatch tmp2789 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2789 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x2788)) tmp2787)) x2786))) (quasi2760 (lambda (p2797 lev2798) ((lambda (tmp2799) ((lambda (tmp2800) (if tmp2800 (apply (lambda (p2801) (if (= lev2798 0) p2801 (quasicons2757 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2760 (list p2801) (- lev2798 1))))) tmp2800) ((lambda (tmp2802) (if (if tmp2802 (apply (lambda (args2803) (= lev2798 0)) tmp2802) #f) (apply (lambda (args2804) (syntax-violation (quote unquote) "unquote takes exactly one argument" p2797 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args2804))) tmp2802) ((lambda (tmp2805) (if tmp2805 (apply (lambda (p2806 q2807) (if (= lev2798 0) (quasiappend2758 p2806 (quasi2760 q2807 lev2798)) (quasicons2757 (quasicons2757 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2760 (list p2806) (- lev2798 1))) (quasi2760 q2807 lev2798)))) tmp2805) ((lambda (tmp2808) (if (if tmp2808 (apply (lambda (args2809 q2810) (= lev2798 0)) tmp2808) #f) (apply (lambda (args2811 q2812) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p2797 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args2811))) tmp2808) ((lambda (tmp2813) (if tmp2813 (apply (lambda (p2814) (quasicons2757 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2760 (list p2814) (+ lev2798 1)))) tmp2813) ((lambda (tmp2815) (if tmp2815 (apply (lambda (p2816 q2817) (quasicons2757 (quasi2760 p2816 lev2798) (quasi2760 q2817 lev2798))) tmp2815) ((lambda (tmp2818) (if tmp2818 (apply (lambda (x2819) (quasivector2759 (quasi2760 x2819 lev2798))) tmp2818) ((lambda (p2821) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p2821)) tmp2799))) ($sc-dispatch tmp2799 (quote #(vector each-any)))))) ($sc-dispatch tmp2799 (quote (any . any)))))) ($sc-dispatch tmp2799 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2799 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp2799 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2799 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2799 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p2797)))) (lambda (x2822) ((lambda (tmp2823) ((lambda (tmp2824) (if tmp2824 (apply (lambda (_2825 e2826) (quasi2760 e2826 0)) tmp2824) (syntax-violation #f "source expression failed to match any pattern" tmp2823))) ($sc-dispatch tmp2823 (quote (any any))))) x2822))))) -(define include (make-syncase-macro (quote macro) (lambda (x2827) (letrec ((read-file2828 (lambda (fn2829 k2830) (let ((p2831 (open-input-file fn2829))) (letrec ((f2832 (lambda (x2833) (if (eof-object? x2833) (begin (close-input-port p2831) (quote ())) (cons (datum->syntax k2830 x2833) (f2832 (read p2831))))))) (f2832 (read p2831))))))) ((lambda (tmp2834) ((lambda (tmp2835) (if tmp2835 (apply (lambda (k2836 filename2837) (let ((fn2838 (syntax->datum filename2837))) ((lambda (tmp2839) ((lambda (tmp2840) (if tmp2840 (apply (lambda (exp2841) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2841)) tmp2840) (syntax-violation #f "source expression failed to match any pattern" tmp2839))) ($sc-dispatch tmp2839 (quote each-any)))) (read-file2828 fn2838 k2836)))) tmp2835) (syntax-violation #f "source expression failed to match any pattern" tmp2834))) ($sc-dispatch tmp2834 (quote (any any))))) x2827))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x2843) ((lambda (tmp2844) ((lambda (tmp2845) (if tmp2845 (apply (lambda (_2846 e2847) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x2843)) tmp2845) (syntax-violation #f "source expression failed to match any pattern" tmp2844))) ($sc-dispatch tmp2844 (quote (any any))))) x2843)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2848) ((lambda (tmp2849) ((lambda (tmp2850) (if tmp2850 (apply (lambda (_2851 e2852) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x2848)) tmp2850) (syntax-violation #f "source expression failed to match any pattern" tmp2849))) ($sc-dispatch tmp2849 (quote (any any))))) x2848)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2853) ((lambda (tmp2854) ((lambda (tmp2855) (if tmp2855 (apply (lambda (_2856 e2857 m12858 m22859) ((lambda (tmp2860) ((lambda (body2861) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2857)) body2861)) tmp2860)) (letrec ((f2862 (lambda (clause2863 clauses2864) (if (null? clauses2864) ((lambda (tmp2866) ((lambda (tmp2867) (if tmp2867 (apply (lambda (e12868 e22869) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12868 e22869))) tmp2867) ((lambda (tmp2871) (if tmp2871 (apply (lambda (k2872 e12873 e22874) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2872)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12873 e22874)))) tmp2871) ((lambda (_2877) (syntax-violation (quote case) "bad clause" x2853 clause2863)) tmp2866))) ($sc-dispatch tmp2866 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2866 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause2863) ((lambda (tmp2878) ((lambda (rest2879) ((lambda (tmp2880) ((lambda (tmp2881) (if tmp2881 (apply (lambda (k2882 e12883 e22884) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k2882)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12883 e22884)) rest2879)) tmp2881) ((lambda (_2887) (syntax-violation (quote case) "bad clause" x2853 clause2863)) tmp2880))) ($sc-dispatch tmp2880 (quote (each-any any . each-any))))) clause2863)) tmp2878)) (f2862 (car clauses2864) (cdr clauses2864))))))) (f2862 m12858 m22859)))) tmp2855) (syntax-violation #f "source expression failed to match any pattern" tmp2854))) ($sc-dispatch tmp2854 (quote (any any any . each-any))))) x2853)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2888) ((lambda (tmp2889) ((lambda (tmp2890) (if tmp2890 (apply (lambda (_2891 e2892) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2892)) (list (cons _2891 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2892 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2890) (syntax-violation #f "source expression failed to match any pattern" tmp2889))) ($sc-dispatch tmp2889 (quote (any any))))) x2888)))) + +(letrec ((and-map*17 + (lambda (f57 first56 . rest55) + (let ((t58 (null? first56))) + (if t58 + t58 + (if (null? rest55) + (letrec ((andmap59 + (lambda (first60) + (let ((x61 (car first60)) + (first62 (cdr first60))) + (if (null? first62) + (f57 x61) + (if (f57 x61) (andmap59 first62) #f)))))) + (andmap59 first56)) + (letrec ((andmap63 + (lambda (first64 rest65) + (let ((x66 (car first64)) + (xr67 (map car rest65)) + (first68 (cdr first64)) + (rest69 (map cdr rest65))) + (if (null? first68) + (apply f57 (cons x66 xr67)) + (if (apply f57 (cons x66 xr67)) + (andmap63 first68 rest69) + #f)))))) + (andmap63 first56 rest55)))))))) + (letrec ((lambda-var-list162 + (lambda (vars286) + (letrec ((lvl287 + (lambda (vars288 ls289 w290) + (if (pair? vars288) + (lvl287 + (cdr vars288) + (cons (wrap142 (car vars288) w290 #f) ls289) + w290) + (if (id?114 vars288) + (cons (wrap142 vars288 w290 #f) ls289) + (if (null? vars288) + ls289 + (if (syntax-object?98 vars288) + (lvl287 + (syntax-object-expression99 vars288) + ls289 + (join-wraps133 + w290 + (syntax-object-wrap100 vars288))) + (cons vars288 ls289)))))))) + (lvl287 vars286 (quote ()) (quote (())))))) + (gen-var161 + (lambda (id291) + (let ((id292 (if (syntax-object?98 id291) + (syntax-object-expression99 id291) + id291))) + (gensym (symbol->string id292))))) + (strip160 + (lambda (x293 w294) + (if (memq (quote top) (wrap-marks117 w294)) + x293 + (letrec ((f295 (lambda (x296) + (if (syntax-object?98 x296) + (strip160 + (syntax-object-expression99 x296) + (syntax-object-wrap100 x296)) + (if (pair? x296) + (let ((a297 (f295 (car x296))) + (d298 (f295 (cdr x296)))) + (if (if (eq? a297 (car x296)) + (eq? d298 (cdr x296)) + #f) + x296 + (cons a297 d298))) + (if (vector? x296) + (let ((old299 (vector->list x296))) + (let ((new300 (map f295 old299))) + (if (and-map*17 eq? old299 new300) + x296 + (list->vector new300)))) + x296)))))) + (f295 x293))))) + (ellipsis?159 + (lambda (x301) + (if (nonsymbol-id?113 x301) + (free-id=?137 + x301 + '#(syntax-object + ... + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + #f))) + (chi-void158 (lambda () (build-void80 #f))) + (eval-local-transformer157 + (lambda (expanded302 mod303) + (let ((p304 (local-eval-hook77 expanded302 mod303))) + (if (procedure? p304) + p304 + (syntax-violation + #f + "nonprocedure transformer" + p304))))) + (chi-local-syntax156 + (lambda (rec?305 e306 r307 w308 s309 mod310 k311) + ((lambda (tmp312) + ((lambda (tmp313) + (if tmp313 + (apply (lambda (_314 id315 val316 e1317 e2318) + (let ((ids319 id315)) + (if (not (valid-bound-ids?139 ids319)) + (syntax-violation + #f + "duplicate bound keyword" + e306) + (let ((labels321 (gen-labels120 ids319))) + (let ((new-w322 + (make-binding-wrap131 + ids319 + labels321 + w308))) + (k311 (cons e1317 e2318) + (extend-env108 + labels321 + (let ((w324 (if rec?305 + new-w322 + w308)) + (trans-r325 + (macros-only-env110 + r307))) + (map (lambda (x326) + (cons 'macro + (eval-local-transformer157 + (chi150 + x326 + trans-r325 + w324 + mod310) + mod310))) + val316)) + r307) + new-w322 + s309 + mod310)))))) + tmp313) + ((lambda (_328) + (syntax-violation + #f + "bad local syntax definition" + (source-wrap143 e306 w308 s309 mod310))) + tmp312))) + ($sc-dispatch + tmp312 + '(any #(each (any any)) any . each-any)))) + e306))) + (chi-lambda-clause155 + (lambda (e329 docstring330 c331 r332 w333 mod334 k335) + ((lambda (tmp336) + ((lambda (tmp337) + (if (if tmp337 + (apply (lambda (args338 doc339 e1340 e2341) + (if (string? (syntax->datum doc339)) + (not docstring330) + #f)) + tmp337) + #f) + (apply (lambda (args342 doc343 e1344 e2345) + (chi-lambda-clause155 + e329 + doc343 + (cons args342 (cons e1344 e2345)) + r332 + w333 + mod334 + k335)) + tmp337) + ((lambda (tmp347) + (if tmp347 + (apply (lambda (id348 e1349 e2350) + (let ((ids351 id348)) + (if (not (valid-bound-ids?139 ids351)) + (syntax-violation + 'lambda + "invalid parameter list" + e329) + (let ((labels353 + (gen-labels120 ids351)) + (new-vars354 + (map gen-var161 ids351))) + (k335 (map syntax->datum ids351) + new-vars354 + (if docstring330 + (syntax->datum docstring330) + #f) + (chi-body154 + (cons e1349 e2350) + e329 + (extend-var-env109 + labels353 + new-vars354 + r332) + (make-binding-wrap131 + ids351 + labels353 + w333) + mod334)))))) + tmp347) + ((lambda (tmp356) + (if tmp356 + (apply (lambda (ids357 e1358 e2359) + (let ((old-ids360 + (lambda-var-list162 ids357))) + (if (not (valid-bound-ids?139 + old-ids360)) + (syntax-violation + 'lambda + "invalid parameter list" + e329) + (let ((labels361 + (gen-labels120 + old-ids360)) + (new-vars362 + (map gen-var161 + old-ids360))) + (k335 (letrec ((f363 (lambda (ls1364 + ls2365) + (if (null? ls1364) + (syntax->datum + ls2365) + (f363 (cdr ls1364) + (cons (syntax->datum + (car ls1364)) + ls2365)))))) + (f363 (cdr old-ids360) + (car old-ids360))) + (letrec ((f366 (lambda (ls1367 + ls2368) + (if (null? ls1367) + ls2368 + (f366 (cdr ls1367) + (cons (car ls1367) + ls2368)))))) + (f366 (cdr new-vars362) + (car new-vars362))) + (if docstring330 + (syntax->datum + docstring330) + #f) + (chi-body154 + (cons e1358 e2359) + e329 + (extend-var-env109 + labels361 + new-vars362 + r332) + (make-binding-wrap131 + old-ids360 + labels361 + w333) + mod334)))))) + tmp356) + ((lambda (_370) + (syntax-violation + 'lambda + "bad lambda" + e329)) + tmp336))) + ($sc-dispatch + tmp336 + '(any any . each-any))))) + ($sc-dispatch + tmp336 + '(each-any any . each-any))))) + ($sc-dispatch + tmp336 + '(any any any . each-any)))) + c331))) + (chi-body154 + (lambda (body371 outer-form372 r373 w374 mod375) + (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) + (let ((ribcage377 + (make-ribcage121 + '() + '() + '()))) + (let ((w378 (make-wrap116 + (wrap-marks117 w374) + (cons ribcage377 (wrap-subst118 w374))))) + (letrec ((parse379 + (lambda (body380 + ids381 + labels382 + var-ids383 + vars384 + vals385 + bindings386) + (if (null? body380) + (syntax-violation + #f + "no expressions in body" + outer-form372) + (let ((e388 (cdar body380)) + (er389 (caar body380))) + (call-with-values + (lambda () + (syntax-type148 + e388 + er389 + '(()) + (source-annotation105 er389) + ribcage377 + mod375 + #f)) + (lambda (type390 + value391 + e392 + w393 + s394 + mod395) + (if (memv type390 + '(define-form)) + (let ((id396 (wrap142 + value391 + w393 + mod395)) + (label397 (gen-label119))) + (let ((var398 + (gen-var161 id396))) + (begin + (extend-ribcage!130 + ribcage377 + id396 + label397) + (parse379 + (cdr body380) + (cons id396 ids381) + (cons label397 labels382) + (cons id396 var-ids383) + (cons var398 vars384) + (cons (cons er389 + (wrap142 + e392 + w393 + mod395)) + vals385) + (cons (cons 'lexical + var398) + bindings386))))) + (if (memv type390 + '(define-syntax-form)) + (let ((id399 (wrap142 + value391 + w393 + mod395)) + (label400 (gen-label119))) + (begin + (extend-ribcage!130 + ribcage377 + id399 + label400) + (parse379 + (cdr body380) + (cons id399 ids381) + (cons label400 labels382) + var-ids383 + vars384 + vals385 + (cons (cons 'macro + (cons er389 + (wrap142 + e392 + w393 + mod395))) + bindings386)))) + (if (memv type390 + '(begin-form)) + ((lambda (tmp401) + ((lambda (tmp402) + (if tmp402 + (apply (lambda (_403 + e1404) + (parse379 + (letrec ((f405 (lambda (forms406) + (if (null? forms406) + (cdr body380) + (cons (cons er389 + (wrap142 + (car forms406) + w393 + mod395)) + (f405 (cdr forms406))))))) + (f405 e1404)) + ids381 + labels382 + var-ids383 + vars384 + vals385 + bindings386)) + tmp402) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp401))) + ($sc-dispatch + tmp401 + '(any . each-any)))) + e392) + (if (memv type390 + '(local-syntax-form)) + (chi-local-syntax156 + value391 + e392 + er389 + w393 + s394 + mod395 + (lambda (forms408 + er409 + w410 + s411 + mod412) + (parse379 + (letrec ((f413 (lambda (forms414) + (if (null? forms414) + (cdr body380) + (cons (cons er409 + (wrap142 + (car forms414) + w410 + mod412)) + (f413 (cdr forms414))))))) + (f413 forms408)) + ids381 + labels382 + var-ids383 + vars384 + vals385 + bindings386))) + (if (null? ids381) + (build-sequence93 + #f + (map (lambda (x415) + (chi150 + (cdr x415) + (car x415) + '(()) + mod395)) + (cons (cons er389 + (source-wrap143 + e392 + w393 + s394 + mod395)) + (cdr body380)))) + (begin + (if (not (valid-bound-ids?139 + ids381)) + (syntax-violation + #f + "invalid or duplicate identifier in definition" + outer-form372)) + (letrec ((loop416 + (lambda (bs417 + er-cache418 + r-cache419) + (if (not (null? bs417)) + (let ((b420 (car bs417))) + (if (eq? (car b420) + 'macro) + (let ((er421 (cadr b420))) + (let ((r-cache422 + (if (eq? er421 + er-cache418) + r-cache419 + (macros-only-env110 + er421)))) + (begin + (set-cdr! + b420 + (eval-local-transformer157 + (chi150 + (cddr b420) + r-cache422 + '(()) + mod395) + mod395)) + (loop416 + (cdr bs417) + er421 + r-cache422)))) + (loop416 + (cdr bs417) + er-cache418 + r-cache419))))))) + (loop416 + bindings386 + #f + #f)) + (set-cdr! + r376 + (extend-env108 + labels382 + bindings386 + (cdr r376))) + (build-letrec96 + #f + (map syntax->datum + var-ids383) + vars384 + (map (lambda (x423) + (chi150 + (cdr x423) + (car x423) + '(()) + mod395)) + vals385) + (build-sequence93 + #f + (map (lambda (x424) + (chi150 + (cdr x424) + (car x424) + '(()) + mod395)) + (cons (cons er389 + (source-wrap143 + e392 + w393 + s394 + mod395)) + (cdr body380)))))))))))))))))) + (parse379 + (map (lambda (x387) + (cons r376 (wrap142 x387 w378 mod375))) + body371) + '() + '() + '() + '() + '() + '()))))))) + (chi-macro153 + (lambda (p425 e426 r427 w428 rib429 mod430) + (letrec ((rebuild-macro-output431 + (lambda (x432 m433) + (if (pair? x432) + (cons (rebuild-macro-output431 (car x432) m433) + (rebuild-macro-output431 (cdr x432) m433)) + (if (syntax-object?98 x432) + (let ((w434 (syntax-object-wrap100 x432))) + (let ((ms435 (wrap-marks117 w434)) + (s436 (wrap-subst118 w434))) + (if (if (pair? ms435) + (eq? (car ms435) #f) + #f) + (make-syntax-object97 + (syntax-object-expression99 x432) + (make-wrap116 + (cdr ms435) + (if rib429 + (cons rib429 (cdr s436)) + (cdr s436))) + (syntax-object-module101 x432)) + (make-syntax-object97 + (syntax-object-expression99 x432) + (make-wrap116 + (cons m433 ms435) + (if rib429 + (cons rib429 + (cons (quote shift) s436)) + (cons (quote shift) s436))) + (let ((pmod437 + (procedure-module p425))) + (if pmod437 + (cons 'hygiene + (module-name pmod437)) + '(hygiene guile))))))) + (if (vector? x432) + (let ((n438 (vector-length x432))) + (let ((v439 (make-vector n438))) + (letrec ((loop440 + (lambda (i441) + (if (fx=74 i441 n438) + (begin (if #f #f) v439) + (begin + (vector-set! + v439 + i441 + (rebuild-macro-output431 + (vector-ref + x432 + i441) + m433)) + (loop440 + (fx+72 i441 1))))))) + (loop440 0)))) + (if (symbol? x432) + (syntax-violation + #f + "encountered raw symbol in macro output" + (source-wrap143 e426 w428 s mod430) + x432) + x432))))))) + (rebuild-macro-output431 + (p425 (wrap142 e426 (anti-mark129 w428) mod430)) + (string #\m))))) + (chi-application152 + (lambda (x442 e443 r444 w445 s446 mod447) + ((lambda (tmp448) + ((lambda (tmp449) + (if tmp449 + (apply (lambda (e0450 e1451) + (build-application81 + s446 + x442 + (map (lambda (e452) + (chi150 e452 r444 w445 mod447)) + e1451))) + tmp449) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp448))) + ($sc-dispatch tmp448 (quote (any . each-any))))) + e443))) + (chi-expr151 + (lambda (type454 value455 e456 r457 w458 s459 mod460) + (if (memv type454 (quote (lexical))) + (build-lexical-reference83 + 'value + s459 + e456 + value455) + (if (memv type454 (quote (core core-form))) + (value455 e456 r457 w458 s459 mod460) + (if (memv type454 (quote (module-ref))) + (call-with-values + (lambda () (value455 e456)) + (lambda (id461 mod462) + (build-global-reference86 s459 id461 mod462))) + (if (memv type454 (quote (lexical-call))) + (chi-application152 + (build-lexical-reference83 + 'fun + (source-annotation105 (car e456)) + (car e456) + value455) + e456 + r457 + w458 + s459 + mod460) + (if (memv type454 (quote (global-call))) + (chi-application152 + (build-global-reference86 + (source-annotation105 (car e456)) + (if (syntax-object?98 value455) + (syntax-object-expression99 value455) + value455) + (if (syntax-object?98 value455) + (syntax-object-module101 value455) + mod460)) + e456 + r457 + w458 + s459 + mod460) + (if (memv type454 (quote (constant))) + (build-data92 + s459 + (strip160 + (source-wrap143 e456 w458 s459 mod460) + '(()))) + (if (memv type454 (quote (global))) + (build-global-reference86 s459 value455 mod460) + (if (memv type454 (quote (call))) + (chi-application152 + (chi150 (car e456) r457 w458 mod460) + e456 + r457 + w458 + s459 + mod460) + (if (memv type454 (quote (begin-form))) + ((lambda (tmp463) + ((lambda (tmp464) + (if tmp464 + (apply (lambda (_465 e1466 e2467) + (chi-sequence144 + (cons e1466 e2467) + r457 + w458 + s459 + mod460)) + tmp464) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp463))) + ($sc-dispatch + tmp463 + '(any any . each-any)))) + e456) + (if (memv type454 (quote (local-syntax-form))) + (chi-local-syntax156 + value455 + e456 + r457 + w458 + s459 + mod460 + chi-sequence144) + (if (memv type454 (quote (eval-when-form))) + ((lambda (tmp469) + ((lambda (tmp470) + (if tmp470 + (apply (lambda (_471 + x472 + e1473 + e2474) + (let ((when-list475 + (chi-when-list147 + e456 + x472 + w458))) + (if (memq 'eval + when-list475) + (chi-sequence144 + (cons e1473 e2474) + r457 + w458 + s459 + mod460) + (chi-void158)))) + tmp470) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp469))) + ($sc-dispatch + tmp469 + '(any each-any any . each-any)))) + e456) + (if (memv type454 + '(define-form + define-syntax-form)) + (syntax-violation + #f + "definition in expression context" + e456 + (wrap142 value455 w458 mod460)) + (if (memv type454 (quote (syntax))) + (syntax-violation + #f + "reference to pattern variable outside syntax form" + (source-wrap143 + e456 + w458 + s459 + mod460)) + (if (memv type454 + '(displaced-lexical)) + (syntax-violation + #f + "reference to identifier outside its scope" + (source-wrap143 + e456 + w458 + s459 + mod460)) + (syntax-violation + #f + "unexpected syntax" + (source-wrap143 + e456 + w458 + s459 + mod460)))))))))))))))))) + (chi150 + (lambda (e478 r479 w480 mod481) + (call-with-values + (lambda () + (syntax-type148 + e478 + r479 + w480 + (source-annotation105 e478) + #f + mod481 + #f)) + (lambda (type482 value483 e484 w485 s486 mod487) + (chi-expr151 + type482 + value483 + e484 + r479 + w485 + s486 + mod487))))) + (chi-top149 + (lambda (e488 r489 w490 m491 esew492 mod493) + (call-with-values + (lambda () + (syntax-type148 + e488 + r489 + w490 + (source-annotation105 e488) + #f + mod493 + #f)) + (lambda (type501 value502 e503 w504 s505 mod506) + (if (memv type501 (quote (begin-form))) + ((lambda (tmp507) + ((lambda (tmp508) + (if tmp508 + (apply (lambda (_509) (chi-void158)) tmp508) + ((lambda (tmp510) + (if tmp510 + (apply (lambda (_511 e1512 e2513) + (chi-top-sequence145 + (cons e1512 e2513) + r489 + w504 + s505 + m491 + esew492 + mod506)) + tmp510) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp507))) + ($sc-dispatch + tmp507 + '(any any . each-any))))) + ($sc-dispatch tmp507 (quote (any))))) + e503) + (if (memv type501 (quote (local-syntax-form))) + (chi-local-syntax156 + value502 + e503 + r489 + w504 + s505 + mod506 + (lambda (body515 r516 w517 s518 mod519) + (chi-top-sequence145 + body515 + r516 + w517 + s518 + m491 + esew492 + mod519))) + (if (memv type501 (quote (eval-when-form))) + ((lambda (tmp520) + ((lambda (tmp521) + (if tmp521 + (apply (lambda (_522 x523 e1524 e2525) + (let ((when-list526 + (chi-when-list147 + e503 + x523 + w504)) + (body527 (cons e1524 e2525))) + (if (eq? m491 (quote e)) + (if (memq 'eval + when-list526) + (chi-top-sequence145 + body527 + r489 + w504 + s505 + 'e + '(eval) + mod506) + (chi-void158)) + (if (memq 'load + when-list526) + (if (let ((t530 (memq 'compile + when-list526))) + (if t530 + t530 + (if (eq? m491 + 'c&e) + (memq 'eval + when-list526) + #f))) + (chi-top-sequence145 + body527 + r489 + w504 + s505 + 'c&e + '(compile load) + mod506) + (if (memq m491 + '(c c&e)) + (chi-top-sequence145 + body527 + r489 + w504 + s505 + 'c + '(load) + mod506) + (chi-void158))) + (if (let ((t531 (memq 'compile + when-list526))) + (if t531 + t531 + (if (eq? m491 + 'c&e) + (memq 'eval + when-list526) + #f))) + (begin + (top-level-eval-hook76 + (chi-top-sequence145 + body527 + r489 + w504 + s505 + 'e + '(eval) + mod506) + mod506) + (chi-void158)) + (chi-void158)))))) + tmp521) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp520))) + ($sc-dispatch + tmp520 + '(any each-any any . each-any)))) + e503) + (if (memv type501 (quote (define-syntax-form))) + (let ((n532 (id-var-name136 value502 w504)) + (r533 (macros-only-env110 r489))) + (if (memv m491 (quote (c))) + (if (memq (quote compile) esew492) + (let ((e534 (chi-install-global146 + n532 + (chi150 + e503 + r533 + w504 + mod506)))) + (begin + (top-level-eval-hook76 e534 mod506) + (if (memq (quote load) esew492) + e534 + (chi-void158)))) + (if (memq (quote load) esew492) + (chi-install-global146 + n532 + (chi150 e503 r533 w504 mod506)) + (chi-void158))) + (if (memv m491 (quote (c&e))) + (let ((e535 (chi-install-global146 + n532 + (chi150 + e503 + r533 + w504 + mod506)))) + (begin + (top-level-eval-hook76 e535 mod506) + e535)) + (begin + (if (memq (quote eval) esew492) + (top-level-eval-hook76 + (chi-install-global146 + n532 + (chi150 e503 r533 w504 mod506)) + mod506)) + (chi-void158))))) + (if (memv type501 (quote (define-form))) + (let ((n536 (id-var-name136 value502 w504))) + (let ((type537 + (binding-type106 + (lookup111 n536 r489 mod506)))) + (if (memv type537 + '(global core macro module-ref)) + (begin + (if (if (not (module-local-variable + (current-module) + n536)) + (current-module) + #f) + (module-define! + (current-module) + n536 + #f)) + (let ((x538 (build-global-definition89 + s505 + n536 + (chi150 + e503 + r489 + w504 + mod506)))) + (begin + (if (eq? m491 (quote c&e)) + (top-level-eval-hook76 x538 mod506)) + x538))) + (if (memv type537 + '(displaced-lexical)) + (syntax-violation + #f + "identifier out of context" + e503 + (wrap142 value502 w504 mod506)) + (syntax-violation + #f + "cannot define keyword at top level" + e503 + (wrap142 value502 w504 mod506)))))) + (let ((x539 (chi-expr151 + type501 + value502 + e503 + r489 + w504 + s505 + mod506))) + (begin + (if (eq? m491 (quote c&e)) + (top-level-eval-hook76 x539 mod506)) + x539))))))))))) + (syntax-type148 + (lambda (e540 r541 w542 s543 rib544 mod545 for-car?546) + (if (symbol? e540) + (let ((n547 (id-var-name136 e540 w542))) + (let ((b548 (lookup111 n547 r541 mod545))) + (let ((type549 (binding-type106 b548))) + (if (memv type549 (quote (lexical))) + (values + type549 + (binding-value107 b548) + e540 + w542 + s543 + mod545) + (if (memv type549 (quote (global))) + (values type549 n547 e540 w542 s543 mod545) + (if (memv type549 (quote (macro))) + (if for-car?546 + (values + type549 + (binding-value107 b548) + e540 + w542 + s543 + mod545) + (syntax-type148 + (chi-macro153 + (binding-value107 b548) + e540 + r541 + w542 + rib544 + mod545) + r541 + '(()) + s543 + rib544 + mod545 + #f)) + (values + type549 + (binding-value107 b548) + e540 + w542 + s543 + mod545))))))) + (if (pair? e540) + (let ((first550 (car e540))) + (call-with-values + (lambda () + (syntax-type148 + first550 + r541 + w542 + s543 + rib544 + mod545 + #t)) + (lambda (ftype551 fval552 fe553 fw554 fs555 fmod556) + (if (memv ftype551 (quote (lexical))) + (values + 'lexical-call + fval552 + e540 + w542 + s543 + mod545) + (if (memv ftype551 (quote (global))) + (values + 'global-call + (make-syntax-object97 fval552 w542 fmod556) + e540 + w542 + s543 + mod545) + (if (memv ftype551 (quote (macro))) + (syntax-type148 + (chi-macro153 + fval552 + e540 + r541 + w542 + rib544 + mod545) + r541 + '(()) + s543 + rib544 + mod545 + for-car?546) + (if (memv ftype551 (quote (module-ref))) + (call-with-values + (lambda () (fval552 e540)) + (lambda (sym557 mod558) + (syntax-type148 + sym557 + r541 + w542 + s543 + rib544 + mod558 + for-car?546))) + (if (memv ftype551 (quote (core))) + (values + 'core-form + fval552 + e540 + w542 + s543 + mod545) + (if (memv ftype551 (quote (local-syntax))) + (values + 'local-syntax-form + fval552 + e540 + w542 + s543 + mod545) + (if (memv ftype551 (quote (begin))) + (values + 'begin-form + #f + e540 + w542 + s543 + mod545) + (if (memv ftype551 (quote (eval-when))) + (values + 'eval-when-form + #f + e540 + w542 + s543 + mod545) + (if (memv ftype551 (quote (define))) + ((lambda (tmp559) + ((lambda (tmp560) + (if (if tmp560 + (apply (lambda (_561 + name562 + val563) + (id?114 + name562)) + tmp560) + #f) + (apply (lambda (_564 + name565 + val566) + (values + 'define-form + name565 + val566 + w542 + s543 + mod545)) + tmp560) + ((lambda (tmp567) + (if (if tmp567 + (apply (lambda (_568 + name569 + args570 + e1571 + e2572) + (if (id?114 + name569) + (valid-bound-ids?139 + (lambda-var-list162 + args570)) + #f)) + tmp567) + #f) + (apply (lambda (_573 + name574 + args575 + e1576 + e2577) + (values + 'define-form + (wrap142 + name574 + w542 + mod545) + (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ + name + args + e1 + e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(ftype + fval + fe + fw + fs + fmod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(first) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib + mod + for-car?) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) + (top)) + ("i" + "i"))) + (hygiene + guile)) + (wrap142 + (cons args575 + (cons e1576 + e2577)) + w542 + mod545)) + '(()) + s543 + mod545)) + tmp567) + ((lambda (tmp579) + (if (if tmp579 + (apply (lambda (_580 + name581) + (id?114 + name581)) + tmp579) + #f) + (apply (lambda (_582 + name583) + (values + 'define-form + (wrap142 + name583 + w542 + mod545) + '(#(syntax-object + if + ((top) + #(ribcage + #(_ + name) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(ftype + fval + fe + fw + fs + fmod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(first) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib + mod + for-car?) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) + (top)) + ("i" + "i"))) + (hygiene + guile)) + #(syntax-object + #f + ((top) + #(ribcage + #(_ + name) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(ftype + fval + fe + fw + fs + fmod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(first) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib + mod + for-car?) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) + (top)) + ("i" + "i"))) + (hygiene + guile)) + #(syntax-object + #f + ((top) + #(ribcage + #(_ + name) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(ftype + fval + fe + fw + fs + fmod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(first) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib + mod + for-car?) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) + (top)) + ("i" + "i"))) + (hygiene + guile))) + '(()) + s543 + mod545)) + tmp579) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp559))) + ($sc-dispatch + tmp559 + '(any any))))) + ($sc-dispatch + tmp559 + '(any (any . any) + any + . + each-any))))) + ($sc-dispatch + tmp559 + '(any any any)))) + e540) + (if (memv ftype551 + '(define-syntax)) + ((lambda (tmp584) + ((lambda (tmp585) + (if (if tmp585 + (apply (lambda (_586 + name587 + val588) + (id?114 + name587)) + tmp585) + #f) + (apply (lambda (_589 + name590 + val591) + (values + 'define-syntax-form + name590 + val591 + w542 + s543 + mod545)) + tmp585) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp584))) + ($sc-dispatch + tmp584 + '(any any any)))) + e540) + (values + 'call + #f + e540 + w542 + s543 + mod545)))))))))))))) + (if (syntax-object?98 e540) + (syntax-type148 + (syntax-object-expression99 e540) + r541 + (join-wraps133 w542 (syntax-object-wrap100 e540)) + s543 + rib544 + (let ((t592 (syntax-object-module101 e540))) + (if t592 t592 mod545)) + for-car?546) + (if (self-evaluating? e540) + (values + 'constant + #f + e540 + w542 + s543 + mod545) + (values (quote other) #f e540 w542 s543 mod545))))))) + (chi-when-list147 + (lambda (e593 when-list594 w595) + (letrec ((f596 (lambda (when-list597 situations598) + (if (null? when-list597) + situations598 + (f596 (cdr when-list597) + (cons (let ((x599 (car when-list597))) + (if (free-id=?137 + x599 + '#(syntax-object + compile + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(f + when-list + situations) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + 'compile + (if (free-id=?137 + x599 + '#(syntax-object + load + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(f + when-list + situations) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + 'load + (if (free-id=?137 + x599 + '#(syntax-object + eval + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + when-list + situations) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(e + when-list + w) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + 'eval + (syntax-violation + 'eval-when + "invalid situation" + e593 + (wrap142 + x599 + w595 + #f)))))) + situations598)))))) + (f596 when-list594 (quote ()))))) + (chi-install-global146 + (lambda (name600 e601) + (build-global-definition89 + #f + name600 + (if (let ((v602 (module-variable (current-module) name600))) + (if v602 + (if (variable-bound? v602) + (if (macro? (variable-ref v602)) + (not (eq? (macro-type (variable-ref v602)) + 'syncase-macro)) + #f) + #f) + #f)) + (build-application81 + #f + (build-primref91 + #f + 'make-extended-syncase-macro) + (list (build-application81 + #f + (build-primref91 #f (quote module-ref)) + (list (build-application81 + #f + (build-primref91 + #f + 'current-module) + '()) + (build-data92 #f name600))) + (build-data92 #f (quote macro)) + e601)) + (build-application81 + #f + (build-primref91 #f (quote make-syncase-macro)) + (list (build-data92 #f (quote macro)) e601)))))) + (chi-top-sequence145 + (lambda (body603 r604 w605 s606 m607 esew608 mod609) + (build-sequence93 + s606 + (letrec ((dobody610 + (lambda (body611 r612 w613 m614 esew615 mod616) + (if (null? body611) + '() + (let ((first617 + (chi-top149 + (car body611) + r612 + w613 + m614 + esew615 + mod616))) + (cons first617 + (dobody610 + (cdr body611) + r612 + w613 + m614 + esew615 + mod616))))))) + (dobody610 body603 r604 w605 m607 esew608 mod609))))) + (chi-sequence144 + (lambda (body618 r619 w620 s621 mod622) + (build-sequence93 + s621 + (letrec ((dobody623 + (lambda (body624 r625 w626 mod627) + (if (null? body624) + '() + (let ((first628 + (chi150 + (car body624) + r625 + w626 + mod627))) + (cons first628 + (dobody623 + (cdr body624) + r625 + w626 + mod627))))))) + (dobody623 body618 r619 w620 mod622))))) + (source-wrap143 + (lambda (x629 w630 s631 defmod632) + (begin + (if (if s631 (pair? x629) #f) + (set-source-properties! x629 s631)) + (wrap142 x629 w630 defmod632)))) + (wrap142 + (lambda (x633 w634 defmod635) + (if (if (null? (wrap-marks117 w634)) + (null? (wrap-subst118 w634)) + #f) + x633 + (if (syntax-object?98 x633) + (make-syntax-object97 + (syntax-object-expression99 x633) + (join-wraps133 w634 (syntax-object-wrap100 x633)) + (syntax-object-module101 x633)) + (if (null? x633) + x633 + (make-syntax-object97 x633 w634 defmod635)))))) + (bound-id-member?141 + (lambda (x636 list637) + (if (not (null? list637)) + (let ((t638 (bound-id=?138 x636 (car list637)))) + (if t638 + t638 + (bound-id-member?141 x636 (cdr list637)))) + #f))) + (distinct-bound-ids?140 + (lambda (ids639) + (letrec ((distinct?640 + (lambda (ids641) + (let ((t642 (null? ids641))) + (if t642 + t642 + (if (not (bound-id-member?141 + (car ids641) + (cdr ids641))) + (distinct?640 (cdr ids641)) + #f)))))) + (distinct?640 ids639)))) + (valid-bound-ids?139 + (lambda (ids643) + (if (letrec ((all-ids?644 + (lambda (ids645) + (let ((t646 (null? ids645))) + (if t646 + t646 + (if (id?114 (car ids645)) + (all-ids?644 (cdr ids645)) + #f)))))) + (all-ids?644 ids643)) + (distinct-bound-ids?140 ids643) + #f))) + (bound-id=?138 + (lambda (i647 j648) + (if (if (syntax-object?98 i647) + (syntax-object?98 j648) + #f) + (if (eq? (syntax-object-expression99 i647) + (syntax-object-expression99 j648)) + (same-marks?135 + (wrap-marks117 (syntax-object-wrap100 i647)) + (wrap-marks117 (syntax-object-wrap100 j648))) + #f) + (eq? i647 j648)))) + (free-id=?137 + (lambda (i649 j650) + (if (eq? (let ((x651 i649)) + (if (syntax-object?98 x651) + (syntax-object-expression99 x651) + x651)) + (let ((x652 j650)) + (if (syntax-object?98 x652) + (syntax-object-expression99 x652) + x652))) + (eq? (id-var-name136 i649 (quote (()))) + (id-var-name136 j650 (quote (())))) + #f))) + (id-var-name136 + (lambda (id653 w654) + (letrec ((search-vector-rib657 + (lambda (sym663 + subst664 + marks665 + symnames666 + ribcage667) + (let ((n668 (vector-length symnames666))) + (letrec ((f669 (lambda (i670) + (if (fx=74 i670 n668) + (search655 + sym663 + (cdr subst664) + marks665) + (if (if (eq? (vector-ref + symnames666 + i670) + sym663) + (same-marks?135 + marks665 + (vector-ref + (ribcage-marks124 + ribcage667) + i670)) + #f) + (values + (vector-ref + (ribcage-labels125 + ribcage667) + i670) + marks665) + (f669 (fx+72 i670 1))))))) + (f669 0))))) + (search-list-rib656 + (lambda (sym671 + subst672 + marks673 + symnames674 + ribcage675) + (letrec ((f676 (lambda (symnames677 i678) + (if (null? symnames677) + (search655 + sym671 + (cdr subst672) + marks673) + (if (if (eq? (car symnames677) + sym671) + (same-marks?135 + marks673 + (list-ref + (ribcage-marks124 + ribcage675) + i678)) + #f) + (values + (list-ref + (ribcage-labels125 + ribcage675) + i678) + marks673) + (f676 (cdr symnames677) + (fx+72 i678 1))))))) + (f676 symnames674 0)))) + (search655 + (lambda (sym679 subst680 marks681) + (if (null? subst680) + (values #f marks681) + (let ((fst682 (car subst680))) + (if (eq? fst682 (quote shift)) + (search655 + sym679 + (cdr subst680) + (cdr marks681)) + (let ((symnames683 + (ribcage-symnames123 fst682))) + (if (vector? symnames683) + (search-vector-rib657 + sym679 + subst680 + marks681 + symnames683 + fst682) + (search-list-rib656 + sym679 + subst680 + marks681 + symnames683 + fst682))))))))) + (if (symbol? id653) + (let ((t684 (call-with-values + (lambda () + (search655 + id653 + (wrap-subst118 w654) + (wrap-marks117 w654))) + (lambda (x686 . ignore685) x686)))) + (if t684 t684 id653)) + (if (syntax-object?98 id653) + (let ((id687 (syntax-object-expression99 id653)) + (w1688 (syntax-object-wrap100 id653))) + (let ((marks689 + (join-marks134 + (wrap-marks117 w654) + (wrap-marks117 w1688)))) + (call-with-values + (lambda () + (search655 id687 (wrap-subst118 w654) marks689)) + (lambda (new-id690 marks691) + (let ((t692 new-id690)) + (if t692 + t692 + (let ((t693 (call-with-values + (lambda () + (search655 + id687 + (wrap-subst118 w1688) + marks691)) + (lambda (x695 . ignore694) + x695)))) + (if t693 t693 id687)))))))) + (syntax-violation + 'id-var-name + "invalid id" + id653)))))) + (same-marks?135 + (lambda (x696 y697) + (let ((t698 (eq? x696 y697))) + (if t698 + t698 + (if (not (null? x696)) + (if (not (null? y697)) + (if (eq? (car x696) (car y697)) + (same-marks?135 (cdr x696) (cdr y697)) + #f) + #f) + #f))))) + (join-marks134 + (lambda (m1699 m2700) + (smart-append132 m1699 m2700))) + (join-wraps133 + (lambda (w1701 w2702) + (let ((m1703 (wrap-marks117 w1701)) + (s1704 (wrap-subst118 w1701))) + (if (null? m1703) + (if (null? s1704) + w2702 + (make-wrap116 + (wrap-marks117 w2702) + (smart-append132 s1704 (wrap-subst118 w2702)))) + (make-wrap116 + (smart-append132 m1703 (wrap-marks117 w2702)) + (smart-append132 s1704 (wrap-subst118 w2702))))))) + (smart-append132 + (lambda (m1705 m2706) + (if (null? m2706) m1705 (append m1705 m2706)))) + (make-binding-wrap131 + (lambda (ids707 labels708 w709) + (if (null? ids707) + w709 + (make-wrap116 + (wrap-marks117 w709) + (cons (let ((labelvec710 (list->vector labels708))) + (let ((n711 (vector-length labelvec710))) + (let ((symnamevec712 (make-vector n711)) + (marksvec713 (make-vector n711))) + (begin + (letrec ((f714 (lambda (ids715 i716) + (if (not (null? ids715)) + (call-with-values + (lambda () + (id-sym-name&marks115 + (car ids715) + w709)) + (lambda (symname717 + marks718) + (begin + (vector-set! + symnamevec712 + i716 + symname717) + (vector-set! + marksvec713 + i716 + marks718) + (f714 (cdr ids715) + (fx+72 i716 + 1))))))))) + (f714 ids707 0)) + (make-ribcage121 + symnamevec712 + marksvec713 + labelvec710))))) + (wrap-subst118 w709)))))) + (extend-ribcage!130 + (lambda (ribcage719 id720 label721) + (begin + (set-ribcage-symnames!126 + ribcage719 + (cons (syntax-object-expression99 id720) + (ribcage-symnames123 ribcage719))) + (set-ribcage-marks!127 + ribcage719 + (cons (wrap-marks117 (syntax-object-wrap100 id720)) + (ribcage-marks124 ribcage719))) + (set-ribcage-labels!128 + ribcage719 + (cons label721 (ribcage-labels125 ribcage719)))))) + (anti-mark129 + (lambda (w722) + (make-wrap116 + (cons #f (wrap-marks117 w722)) + (cons (quote shift) (wrap-subst118 w722))))) + (set-ribcage-labels!128 + (lambda (x723 update724) + (vector-set! x723 3 update724))) + (set-ribcage-marks!127 + (lambda (x725 update726) + (vector-set! x725 2 update726))) + (set-ribcage-symnames!126 + (lambda (x727 update728) + (vector-set! x727 1 update728))) + (ribcage-labels125 + (lambda (x729) (vector-ref x729 3))) + (ribcage-marks124 + (lambda (x730) (vector-ref x730 2))) + (ribcage-symnames123 + (lambda (x731) (vector-ref x731 1))) + (ribcage?122 + (lambda (x732) + (if (vector? x732) + (if (= (vector-length x732) 4) + (eq? (vector-ref x732 0) (quote ribcage)) + #f) + #f))) + (make-ribcage121 + (lambda (symnames733 marks734 labels735) + (vector + 'ribcage + symnames733 + marks734 + labels735))) + (gen-labels120 + (lambda (ls736) + (if (null? ls736) + '() + (cons (gen-label119) (gen-labels120 (cdr ls736)))))) + (gen-label119 (lambda () (string #\i))) + (wrap-subst118 cdr) + (wrap-marks117 car) + (make-wrap116 cons) + (id-sym-name&marks115 + (lambda (x737 w738) + (if (syntax-object?98 x737) + (values + (syntax-object-expression99 x737) + (join-marks134 + (wrap-marks117 w738) + (wrap-marks117 (syntax-object-wrap100 x737)))) + (values x737 (wrap-marks117 w738))))) + (id?114 + (lambda (x739) + (if (symbol? x739) + #t + (if (syntax-object?98 x739) + (symbol? (syntax-object-expression99 x739)) + #f)))) + (nonsymbol-id?113 + (lambda (x740) + (if (syntax-object?98 x740) + (symbol? (syntax-object-expression99 x740)) + #f))) + (global-extend112 + (lambda (type741 sym742 val743) + (put-global-definition-hook78 + sym742 + type741 + val743))) + (lookup111 + (lambda (x744 r745 mod746) + (let ((t747 (assq x744 r745))) + (if t747 + (cdr t747) + (if (symbol? x744) + (let ((t748 (get-global-definition-hook79 x744 mod746))) + (if t748 t748 (quote (global)))) + '(displaced-lexical)))))) + (macros-only-env110 + (lambda (r749) + (if (null? r749) + '() + (let ((a750 (car r749))) + (if (eq? (cadr a750) (quote macro)) + (cons a750 (macros-only-env110 (cdr r749))) + (macros-only-env110 (cdr r749))))))) + (extend-var-env109 + (lambda (labels751 vars752 r753) + (if (null? labels751) + r753 + (extend-var-env109 + (cdr labels751) + (cdr vars752) + (cons (cons (car labels751) + (cons (quote lexical) (car vars752))) + r753))))) + (extend-env108 + (lambda (labels754 bindings755 r756) + (if (null? labels754) + r756 + (extend-env108 + (cdr labels754) + (cdr bindings755) + (cons (cons (car labels754) (car bindings755)) + r756))))) + (binding-value107 cdr) + (binding-type106 car) + (source-annotation105 + (lambda (x757) + (if (syntax-object?98 x757) + (source-annotation105 + (syntax-object-expression99 x757)) + (if (pair? x757) + (let ((props758 (source-properties x757))) + (if (pair? props758) props758 #f)) + #f)))) + (set-syntax-object-module!104 + (lambda (x759 update760) + (vector-set! x759 3 update760))) + (set-syntax-object-wrap!103 + (lambda (x761 update762) + (vector-set! x761 2 update762))) + (set-syntax-object-expression!102 + (lambda (x763 update764) + (vector-set! x763 1 update764))) + (syntax-object-module101 + (lambda (x765) (vector-ref x765 3))) + (syntax-object-wrap100 + (lambda (x766) (vector-ref x766 2))) + (syntax-object-expression99 + (lambda (x767) (vector-ref x767 1))) + (syntax-object?98 + (lambda (x768) + (if (vector? x768) + (if (= (vector-length x768) 4) + (eq? (vector-ref x768 0) (quote syntax-object)) + #f) + #f))) + (make-syntax-object97 + (lambda (expression769 wrap770 module771) + (vector + 'syntax-object + expression769 + wrap770 + module771))) + (build-letrec96 + (lambda (src772 ids773 vars774 val-exps775 body-exp776) + (if (null? vars774) + body-exp776 + (let ((atom-key777 (fluid-ref *mode*71))) + (if (memv atom-key777 (quote (c))) + (begin + (for-each maybe-name-value!88 ids773 val-exps775) + ((@ (language tree-il) make-letrec) + src772 + ids773 + vars774 + val-exps775 + body-exp776)) + (list 'letrec + (map list vars774 val-exps775) + body-exp776)))))) + (build-named-let95 + (lambda (src778 ids779 vars780 val-exps781 body-exp782) + (let ((f783 (car vars780)) + (f-name784 (car ids779)) + (vars785 (cdr vars780)) + (ids786 (cdr ids779))) + (let ((atom-key787 (fluid-ref *mode*71))) + (if (memv atom-key787 (quote (c))) + (let ((proc788 + (build-lambda90 + src778 + ids786 + vars785 + #f + body-exp782))) + (begin + (maybe-name-value!88 f-name784 proc788) + (for-each maybe-name-value!88 ids786 val-exps781) + ((@ (language tree-il) make-letrec) + src778 + (list f-name784) + (list f783) + (list proc788) + (build-application81 + src778 + (build-lexical-reference83 + 'fun + src778 + f-name784 + f783) + val-exps781)))) + (list 'let + f783 + (map list vars785 val-exps781) + body-exp782)))))) + (build-let94 + (lambda (src789 ids790 vars791 val-exps792 body-exp793) + (if (null? vars791) + body-exp793 + (let ((atom-key794 (fluid-ref *mode*71))) + (if (memv atom-key794 (quote (c))) + (begin + (for-each maybe-name-value!88 ids790 val-exps792) + ((@ (language tree-il) make-let) + src789 + ids790 + vars791 + val-exps792 + body-exp793)) + (list 'let + (map list vars791 val-exps792) + body-exp793)))))) + (build-sequence93 + (lambda (src795 exps796) + (if (null? (cdr exps796)) + (car exps796) + (let ((atom-key797 (fluid-ref *mode*71))) + (if (memv atom-key797 (quote (c))) + ((@ (language tree-il) make-sequence) + src795 + exps796) + (cons (quote begin) exps796)))))) + (build-data92 + (lambda (src798 exp799) + (let ((atom-key800 (fluid-ref *mode*71))) + (if (memv atom-key800 (quote (c))) + ((@ (language tree-il) make-const) src798 exp799) + (if (if (self-evaluating? exp799) + (not (vector? exp799)) + #f) + exp799 + (list (quote quote) exp799)))))) + (build-primref91 + (lambda (src801 name802) + (if (equal? + (module-name (current-module)) + '(guile)) + (let ((atom-key803 (fluid-ref *mode*71))) + (if (memv atom-key803 (quote (c))) + ((@ (language tree-il) make-toplevel-ref) + src801 + name802) + name802)) + (let ((atom-key804 (fluid-ref *mode*71))) + (if (memv atom-key804 (quote (c))) + ((@ (language tree-il) make-module-ref) + src801 + '(guile) + name802 + #f) + (list (quote @@) (quote (guile)) name802)))))) + (build-lambda90 + (lambda (src805 ids806 vars807 docstring808 exp809) + (let ((atom-key810 (fluid-ref *mode*71))) + (if (memv atom-key810 (quote (c))) + ((@ (language tree-il) make-lambda) + src805 + ids806 + vars807 + (if docstring808 + (list (cons (quote documentation) docstring808)) + '()) + exp809) + (cons 'lambda + (cons vars807 + (append + (if docstring808 + (list docstring808) + '()) + (list exp809)))))))) + (build-global-definition89 + (lambda (source811 var812 exp813) + (let ((atom-key814 (fluid-ref *mode*71))) + (if (memv atom-key814 (quote (c))) + (begin + (maybe-name-value!88 var812 exp813) + ((@ (language tree-il) make-toplevel-define) + source811 + var812 + exp813)) + (list (quote define) var812 exp813))))) + (maybe-name-value!88 + (lambda (name815 val816) + (if ((@ (language tree-il) lambda?) val816) + (let ((meta817 + ((@ (language tree-il) lambda-meta) val816))) + (if (not (assq (quote name) meta817)) + ((setter (@ (language tree-il) lambda-meta)) + val816 + (acons (quote name) name815 meta817))))))) + (build-global-assignment87 + (lambda (source818 var819 exp820 mod821) + (analyze-variable85 + mod821 + var819 + (lambda (mod822 var823 public?824) + (let ((atom-key825 (fluid-ref *mode*71))) + (if (memv atom-key825 (quote (c))) + ((@ (language tree-il) make-module-set) + source818 + mod822 + var823 + public?824 + exp820) + (list 'set! + (list (if public?824 (quote @) (quote @@)) + mod822 + var823) + exp820)))) + (lambda (var826) + (let ((atom-key827 (fluid-ref *mode*71))) + (if (memv atom-key827 (quote (c))) + ((@ (language tree-il) make-toplevel-set) + source818 + var826 + exp820) + (list (quote set!) var826 exp820))))))) + (build-global-reference86 + (lambda (source828 var829 mod830) + (analyze-variable85 + mod830 + var829 + (lambda (mod831 var832 public?833) + (let ((atom-key834 (fluid-ref *mode*71))) + (if (memv atom-key834 (quote (c))) + ((@ (language tree-il) make-module-ref) + source828 + mod831 + var832 + public?833) + (list (if public?833 (quote @) (quote @@)) + mod831 + var832)))) + (lambda (var835) + (let ((atom-key836 (fluid-ref *mode*71))) + (if (memv atom-key836 (quote (c))) + ((@ (language tree-il) make-toplevel-ref) + source828 + var835) + var835)))))) + (analyze-variable85 + (lambda (mod837 var838 modref-cont839 bare-cont840) + (if (not mod837) + (bare-cont840 var838) + (let ((kind841 (car mod837)) (mod842 (cdr mod837))) + (if (memv kind841 (quote (public))) + (modref-cont839 mod842 var838 #t) + (if (memv kind841 (quote (private))) + (if (not (equal? mod842 (module-name (current-module)))) + (modref-cont839 mod842 var838 #f) + (bare-cont840 var838)) + (if (memv kind841 (quote (bare))) + (bare-cont840 var838) + (if (memv kind841 (quote (hygiene))) + (if (if (not (equal? + mod842 + (module-name (current-module)))) + (module-variable + (resolve-module mod842) + var838) + #f) + (modref-cont839 mod842 var838 #f) + (bare-cont840 var838)) + (syntax-violation + #f + "bad module kind" + var838 + mod842))))))))) + (build-lexical-assignment84 + (lambda (source843 name844 var845 exp846) + (let ((atom-key847 (fluid-ref *mode*71))) + (if (memv atom-key847 (quote (c))) + ((@ (language tree-il) make-lexical-set) + source843 + name844 + var845 + exp846) + (list (quote set!) var845 exp846))))) + (build-lexical-reference83 + (lambda (type848 source849 name850 var851) + (let ((atom-key852 (fluid-ref *mode*71))) + (if (memv atom-key852 (quote (c))) + ((@ (language tree-il) make-lexical-ref) + source849 + name850 + var851) + var851)))) + (build-conditional82 + (lambda (source853 test-exp854 then-exp855 else-exp856) + (let ((atom-key857 (fluid-ref *mode*71))) + (if (memv atom-key857 (quote (c))) + ((@ (language tree-il) make-conditional) + source853 + test-exp854 + then-exp855 + else-exp856) + (if (equal? else-exp856 (quote (if #f #f))) + (list (quote if) test-exp854 then-exp855) + (list 'if + test-exp854 + then-exp855 + else-exp856)))))) + (build-application81 + (lambda (source858 fun-exp859 arg-exps860) + (let ((atom-key861 (fluid-ref *mode*71))) + (if (memv atom-key861 (quote (c))) + ((@ (language tree-il) make-application) + source858 + fun-exp859 + arg-exps860) + (cons fun-exp859 arg-exps860))))) + (build-void80 + (lambda (source862) + (let ((atom-key863 (fluid-ref *mode*71))) + (if (memv atom-key863 (quote (c))) + ((@ (language tree-il) make-void) source862) + '(if #f #f))))) + (get-global-definition-hook79 + (lambda (symbol864 module865) + (begin + (if (if (not module865) (current-module) #f) + (warn "module system is booted, we should have a module" + symbol864)) + (let ((v866 (module-variable + (if module865 + (resolve-module (cdr module865)) + (current-module)) + symbol864))) + (if v866 + (if (variable-bound? v866) + (let ((val867 (variable-ref v866))) + (if (macro? val867) + (if (syncase-macro-type val867) + (cons (syncase-macro-type val867) + (syncase-macro-binding val867)) + #f) + #f)) + #f) + #f))))) + (put-global-definition-hook78 + (lambda (symbol868 type869 val870) + (let ((existing871 + (let ((v872 (module-variable + (current-module) + symbol868))) + (if v872 + (if (variable-bound? v872) + (let ((val873 (variable-ref v872))) + (if (macro? val873) + (if (not (syncase-macro-type val873)) + val873 + #f) + #f)) + #f) + #f)))) + (module-define! + (current-module) + symbol868 + (if existing871 + (make-extended-syncase-macro + existing871 + type869 + val870) + (make-syncase-macro type869 val870)))))) + (local-eval-hook77 + (lambda (x874 mod875) + (primitive-eval + (list noexpand70 + (let ((atom-key876 (fluid-ref *mode*71))) + (if (memv atom-key876 (quote (c))) + ((@ (language tree-il) tree-il->scheme) x874) + x874)))))) + (top-level-eval-hook76 + (lambda (x877 mod878) + (primitive-eval + (list noexpand70 + (let ((atom-key879 (fluid-ref *mode*71))) + (if (memv atom-key879 (quote (c))) + ((@ (language tree-il) tree-il->scheme) x877) + x877)))))) + (fx<75 <) + (fx=74 =) + (fx-73 -) + (fx+72 +) + (*mode*71 (make-fluid)) + (noexpand70 "noexpand")) + (begin + (global-extend112 + 'local-syntax + 'letrec-syntax + #t) + (global-extend112 + 'local-syntax + 'let-syntax + #f) + (global-extend112 + 'core + 'fluid-let-syntax + (lambda (e880 r881 w882 s883 mod884) + ((lambda (tmp885) + ((lambda (tmp886) + (if (if tmp886 + (apply (lambda (_887 var888 val889 e1890 e2891) + (valid-bound-ids?139 var888)) + tmp886) + #f) + (apply (lambda (_893 var894 val895 e1896 e2897) + (let ((names898 + (map (lambda (x899) + (id-var-name136 x899 w882)) + var894))) + (begin + (for-each + (lambda (id901 n902) + (let ((atom-key903 + (binding-type106 + (lookup111 n902 r881 mod884)))) + (if (memv atom-key903 + '(displaced-lexical)) + (syntax-violation + 'fluid-let-syntax + "identifier out of context" + e880 + (source-wrap143 + id901 + w882 + s883 + mod884))))) + var894 + names898) + (chi-body154 + (cons e1896 e2897) + (source-wrap143 e880 w882 s883 mod884) + (extend-env108 + names898 + (let ((trans-r906 + (macros-only-env110 r881))) + (map (lambda (x907) + (cons 'macro + (eval-local-transformer157 + (chi150 + x907 + trans-r906 + w882 + mod884) + mod884))) + val895)) + r881) + w882 + mod884)))) + tmp886) + ((lambda (_909) + (syntax-violation + 'fluid-let-syntax + "bad syntax" + (source-wrap143 e880 w882 s883 mod884))) + tmp885))) + ($sc-dispatch + tmp885 + '(any #(each (any any)) any . each-any)))) + e880))) + (global-extend112 + 'core + 'quote + (lambda (e910 r911 w912 s913 mod914) + ((lambda (tmp915) + ((lambda (tmp916) + (if tmp916 + (apply (lambda (_917 e918) + (build-data92 s913 (strip160 e918 w912))) + tmp916) + ((lambda (_919) + (syntax-violation + 'quote + "bad syntax" + (source-wrap143 e910 w912 s913 mod914))) + tmp915))) + ($sc-dispatch tmp915 (quote (any any))))) + e910))) + (global-extend112 + 'core + 'syntax + (letrec ((regen927 + (lambda (x928) + (let ((atom-key929 (car x928))) + (if (memv atom-key929 (quote (ref))) + (build-lexical-reference83 + 'value + #f + (cadr x928) + (cadr x928)) + (if (memv atom-key929 (quote (primitive))) + (build-primref91 #f (cadr x928)) + (if (memv atom-key929 (quote (quote))) + (build-data92 #f (cadr x928)) + (if (memv atom-key929 (quote (lambda))) + (build-lambda90 + #f + (cadr x928) + (cadr x928) + #f + (regen927 (caddr x928))) + (build-application81 + #f + (build-primref91 #f (car x928)) + (map regen927 (cdr x928)))))))))) + (gen-vector926 + (lambda (x930) + (if (eq? (car x930) (quote list)) + (cons (quote vector) (cdr x930)) + (if (eq? (car x930) (quote quote)) + (list (quote quote) (list->vector (cadr x930))) + (list (quote list->vector) x930))))) + (gen-append925 + (lambda (x931 y932) + (if (equal? y932 (quote (quote ()))) + x931 + (list (quote append) x931 y932)))) + (gen-cons924 + (lambda (x933 y934) + (let ((atom-key935 (car y934))) + (if (memv atom-key935 (quote (quote))) + (if (eq? (car x933) (quote quote)) + (list 'quote + (cons (cadr x933) (cadr y934))) + (if (eq? (cadr y934) (quote ())) + (list (quote list) x933) + (list (quote cons) x933 y934))) + (if (memv atom-key935 (quote (list))) + (cons (quote list) (cons x933 (cdr y934))) + (list (quote cons) x933 y934)))))) + (gen-map923 + (lambda (e936 map-env937) + (let ((formals938 (map cdr map-env937)) + (actuals939 + (map (lambda (x940) (list (quote ref) (car x940))) + map-env937))) + (if (eq? (car e936) (quote ref)) + (car actuals939) + (if (and-map + (lambda (x941) + (if (eq? (car x941) (quote ref)) + (memq (cadr x941) formals938) + #f)) + (cdr e936)) + (cons 'map + (cons (list (quote primitive) (car e936)) + (map (let ((r942 (map cons + formals938 + actuals939))) + (lambda (x943) + (cdr (assq (cadr x943) r942)))) + (cdr e936)))) + (cons 'map + (cons (list (quote lambda) formals938 e936) + actuals939))))))) + (gen-mappend922 + (lambda (e944 map-env945) + (list 'apply + '(primitive append) + (gen-map923 e944 map-env945)))) + (gen-ref921 + (lambda (src946 var947 level948 maps949) + (if (fx=74 level948 0) + (values var947 maps949) + (if (null? maps949) + (syntax-violation + 'syntax + "missing ellipsis" + src946) + (call-with-values + (lambda () + (gen-ref921 + src946 + var947 + (fx-73 level948 1) + (cdr maps949))) + (lambda (outer-var950 outer-maps951) + (let ((b952 (assq outer-var950 (car maps949)))) + (if b952 + (values (cdr b952) maps949) + (let ((inner-var953 (gen-var161 (quote tmp)))) + (values + inner-var953 + (cons (cons (cons outer-var950 + inner-var953) + (car maps949)) + outer-maps951))))))))))) + (gen-syntax920 + (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) + (if (id?114 e955) + (let ((label960 (id-var-name136 e955 (quote (()))))) + (let ((b961 (lookup111 label960 r956 mod959))) + (if (eq? (binding-type106 b961) (quote syntax)) + (call-with-values + (lambda () + (let ((var.lev962 (binding-value107 b961))) + (gen-ref921 + src954 + (car var.lev962) + (cdr var.lev962) + maps957))) + (lambda (var963 maps964) + (values (list (quote ref) var963) maps964))) + (if (ellipsis?958 e955) + (syntax-violation + 'syntax + "misplaced ellipsis" + src954) + (values (list (quote quote) e955) maps957))))) + ((lambda (tmp965) + ((lambda (tmp966) + (if (if tmp966 + (apply (lambda (dots967 e968) + (ellipsis?958 dots967)) + tmp966) + #f) + (apply (lambda (dots969 e970) + (gen-syntax920 + src954 + e970 + r956 + maps957 + (lambda (x971) #f) + mod959)) + tmp966) + ((lambda (tmp972) + (if (if tmp972 + (apply (lambda (x973 dots974 y975) + (ellipsis?958 dots974)) + tmp972) + #f) + (apply (lambda (x976 dots977 y978) + (letrec ((f979 (lambda (y980 k981) + ((lambda (tmp985) + ((lambda (tmp986) + (if (if tmp986 + (apply (lambda (dots987 + y988) + (ellipsis?958 + dots987)) + tmp986) + #f) + (apply (lambda (dots989 + y990) + (f979 y990 + (lambda (maps991) + (call-with-values + (lambda () + (k981 (cons '() + maps991))) + (lambda (x992 + maps993) + (if (null? (car maps993)) + (syntax-violation + 'syntax + "extra ellipsis" + src954) + (values + (gen-mappend922 + x992 + (car maps993)) + (cdr maps993)))))))) + tmp986) + ((lambda (_994) + (call-with-values + (lambda () + (gen-syntax920 + src954 + y980 + r956 + maps957 + ellipsis?958 + mod959)) + (lambda (y995 + maps996) + (call-with-values + (lambda () + (k981 maps996)) + (lambda (x997 + maps998) + (values + (gen-append925 + x997 + y995) + maps998)))))) + tmp985))) + ($sc-dispatch + tmp985 + '(any . + any)))) + y980)))) + (f979 y978 + (lambda (maps982) + (call-with-values + (lambda () + (gen-syntax920 + src954 + x976 + r956 + (cons '() + maps982) + ellipsis?958 + mod959)) + (lambda (x983 maps984) + (if (null? (car maps984)) + (syntax-violation + 'syntax + "extra ellipsis" + src954) + (values + (gen-map923 + x983 + (car maps984)) + (cdr maps984))))))))) + tmp972) + ((lambda (tmp999) + (if tmp999 + (apply (lambda (x1000 y1001) + (call-with-values + (lambda () + (gen-syntax920 + src954 + x1000 + r956 + maps957 + ellipsis?958 + mod959)) + (lambda (x1002 maps1003) + (call-with-values + (lambda () + (gen-syntax920 + src954 + y1001 + r956 + maps1003 + ellipsis?958 + mod959)) + (lambda (y1004 + maps1005) + (values + (gen-cons924 + x1002 + y1004) + maps1005)))))) + tmp999) + ((lambda (tmp1006) + (if tmp1006 + (apply (lambda (e11007 e21008) + (call-with-values + (lambda () + (gen-syntax920 + src954 + (cons e11007 + e21008) + r956 + maps957 + ellipsis?958 + mod959)) + (lambda (e1010 + maps1011) + (values + (gen-vector926 + e1010) + maps1011)))) + tmp1006) + ((lambda (_1012) + (values + (list (quote quote) e955) + maps957)) + tmp965))) + ($sc-dispatch + tmp965 + '#(vector (any . each-any)))))) + ($sc-dispatch + tmp965 + '(any . any))))) + ($sc-dispatch + tmp965 + '(any any . any))))) + ($sc-dispatch tmp965 (quote (any any))))) + e955))))) + (lambda (e1013 r1014 w1015 s1016 mod1017) + (let ((e1018 (source-wrap143 e1013 w1015 s1016 mod1017))) + ((lambda (tmp1019) + ((lambda (tmp1020) + (if tmp1020 + (apply (lambda (_1021 x1022) + (call-with-values + (lambda () + (gen-syntax920 + e1018 + x1022 + r1014 + '() + ellipsis?159 + mod1017)) + (lambda (e1023 maps1024) (regen927 e1023)))) + tmp1020) + ((lambda (_1025) + (syntax-violation + 'syntax + "bad `syntax' form" + e1018)) + tmp1019))) + ($sc-dispatch tmp1019 (quote (any any))))) + e1018))))) + (global-extend112 + 'core + 'lambda + (lambda (e1026 r1027 w1028 s1029 mod1030) + ((lambda (tmp1031) + ((lambda (tmp1032) + (if tmp1032 + (apply (lambda (_1033 c1034) + (chi-lambda-clause155 + (source-wrap143 e1026 w1028 s1029 mod1030) + #f + c1034 + r1027 + w1028 + mod1030 + (lambda (names1035 + vars1036 + docstring1037 + body1038) + (build-lambda90 + s1029 + names1035 + vars1036 + docstring1037 + body1038)))) + tmp1032) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1031))) + ($sc-dispatch tmp1031 (quote (any . any))))) + e1026))) + (global-extend112 + 'core + 'let + (letrec ((chi-let1039 + (lambda (e1040 + r1041 + w1042 + s1043 + mod1044 + constructor1045 + ids1046 + vals1047 + exps1048) + (if (not (valid-bound-ids?139 ids1046)) + (syntax-violation + 'let + "duplicate bound variable" + e1040) + (let ((labels1049 (gen-labels120 ids1046)) + (new-vars1050 (map gen-var161 ids1046))) + (let ((nw1051 + (make-binding-wrap131 + ids1046 + labels1049 + w1042)) + (nr1052 + (extend-var-env109 + labels1049 + new-vars1050 + r1041))) + (constructor1045 + s1043 + (map syntax->datum ids1046) + new-vars1050 + (map (lambda (x1053) + (chi150 x1053 r1041 w1042 mod1044)) + vals1047) + (chi-body154 + exps1048 + (source-wrap143 e1040 nw1051 s1043 mod1044) + nr1052 + nw1051 + mod1044)))))))) + (lambda (e1054 r1055 w1056 s1057 mod1058) + ((lambda (tmp1059) + ((lambda (tmp1060) + (if (if tmp1060 + (apply (lambda (_1061 id1062 val1063 e11064 e21065) + (and-map id?114 id1062)) + tmp1060) + #f) + (apply (lambda (_1067 id1068 val1069 e11070 e21071) + (chi-let1039 + e1054 + r1055 + w1056 + s1057 + mod1058 + build-let94 + id1068 + val1069 + (cons e11070 e21071))) + tmp1060) + ((lambda (tmp1075) + (if (if tmp1075 + (apply (lambda (_1076 + f1077 + id1078 + val1079 + e11080 + e21081) + (if (id?114 f1077) + (and-map id?114 id1078) + #f)) + tmp1075) + #f) + (apply (lambda (_1083 + f1084 + id1085 + val1086 + e11087 + e21088) + (chi-let1039 + e1054 + r1055 + w1056 + s1057 + mod1058 + build-named-let95 + (cons f1084 id1085) + val1086 + (cons e11087 e21088))) + tmp1075) + ((lambda (_1092) + (syntax-violation + 'let + "bad let" + (source-wrap143 e1054 w1056 s1057 mod1058))) + tmp1059))) + ($sc-dispatch + tmp1059 + '(any any #(each (any any)) any . each-any))))) + ($sc-dispatch + tmp1059 + '(any #(each (any any)) any . each-any)))) + e1054)))) + (global-extend112 + 'core + 'letrec + (lambda (e1093 r1094 w1095 s1096 mod1097) + ((lambda (tmp1098) + ((lambda (tmp1099) + (if (if tmp1099 + (apply (lambda (_1100 id1101 val1102 e11103 e21104) + (and-map id?114 id1101)) + tmp1099) + #f) + (apply (lambda (_1106 id1107 val1108 e11109 e21110) + (let ((ids1111 id1107)) + (if (not (valid-bound-ids?139 ids1111)) + (syntax-violation + 'letrec + "duplicate bound variable" + e1093) + (let ((labels1113 (gen-labels120 ids1111)) + (new-vars1114 (map gen-var161 ids1111))) + (let ((w1115 (make-binding-wrap131 + ids1111 + labels1113 + w1095)) + (r1116 (extend-var-env109 + labels1113 + new-vars1114 + r1094))) + (build-letrec96 + s1096 + (map syntax->datum ids1111) + new-vars1114 + (map (lambda (x1117) + (chi150 x1117 r1116 w1115 mod1097)) + val1108) + (chi-body154 + (cons e11109 e21110) + (source-wrap143 + e1093 + w1115 + s1096 + mod1097) + r1116 + w1115 + mod1097))))))) + tmp1099) + ((lambda (_1120) + (syntax-violation + 'letrec + "bad letrec" + (source-wrap143 e1093 w1095 s1096 mod1097))) + tmp1098))) + ($sc-dispatch + tmp1098 + '(any #(each (any any)) any . each-any)))) + e1093))) + (global-extend112 + 'core + 'set! + (lambda (e1121 r1122 w1123 s1124 mod1125) + ((lambda (tmp1126) + ((lambda (tmp1127) + (if (if tmp1127 + (apply (lambda (_1128 id1129 val1130) (id?114 id1129)) + tmp1127) + #f) + (apply (lambda (_1131 id1132 val1133) + (let ((val1134 (chi150 val1133 r1122 w1123 mod1125)) + (n1135 (id-var-name136 id1132 w1123))) + (let ((b1136 (lookup111 n1135 r1122 mod1125))) + (let ((atom-key1137 (binding-type106 b1136))) + (if (memv atom-key1137 (quote (lexical))) + (build-lexical-assignment84 + s1124 + (syntax->datum id1132) + (binding-value107 b1136) + val1134) + (if (memv atom-key1137 (quote (global))) + (build-global-assignment87 + s1124 + n1135 + val1134 + mod1125) + (if (memv atom-key1137 + '(displaced-lexical)) + (syntax-violation + 'set! + "identifier out of context" + (wrap142 id1132 w1123 mod1125)) + (syntax-violation + 'set! + "bad set!" + (source-wrap143 + e1121 + w1123 + s1124 + mod1125))))))))) + tmp1127) + ((lambda (tmp1138) + (if tmp1138 + (apply (lambda (_1139 head1140 tail1141 val1142) + (call-with-values + (lambda () + (syntax-type148 + head1140 + r1122 + '(()) + #f + #f + mod1125 + #t)) + (lambda (type1143 + value1144 + ee1145 + ww1146 + ss1147 + modmod1148) + (if (memv type1143 (quote (module-ref))) + (let ((val1149 + (chi150 + val1142 + r1122 + w1123 + mod1125))) + (call-with-values + (lambda () + (value1144 + (cons head1140 tail1141))) + (lambda (id1151 mod1152) + (build-global-assignment87 + s1124 + id1151 + val1149 + mod1152)))) + (build-application81 + s1124 + (chi150 + (list '#(syntax-object + setter + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(type + value + ee + ww + ss + modmod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + #(_ head tail val) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e r w s mod) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile)) + head1140) + r1122 + w1123 + mod1125) + (map (lambda (e1153) + (chi150 + e1153 + r1122 + w1123 + mod1125)) + (append + tail1141 + (list val1142)))))))) + tmp1138) + ((lambda (_1155) + (syntax-violation + 'set! + "bad set!" + (source-wrap143 e1121 w1123 s1124 mod1125))) + tmp1126))) + ($sc-dispatch + tmp1126 + '(any (any . each-any) any))))) + ($sc-dispatch tmp1126 (quote (any any any))))) + e1121))) + (global-extend112 + 'module-ref + '@ + (lambda (e1156) + ((lambda (tmp1157) + ((lambda (tmp1158) + (if (if tmp1158 + (apply (lambda (_1159 mod1160 id1161) + (if (and-map id?114 mod1160) + (id?114 id1161) + #f)) + tmp1158) + #f) + (apply (lambda (_1163 mod1164 id1165) + (values + (syntax->datum id1165) + (syntax->datum + (cons '#(syntax-object + public + ((top) + #(ribcage + #(_ mod id) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(e) #((top)) #("i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile)) + mod1164)))) + tmp1158) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1157))) + ($sc-dispatch tmp1157 (quote (any each-any any))))) + e1156))) + (global-extend112 + 'module-ref + '@@ + (lambda (e1167) + ((lambda (tmp1168) + ((lambda (tmp1169) + (if (if tmp1169 + (apply (lambda (_1170 mod1171 id1172) + (if (and-map id?114 mod1171) + (id?114 id1172) + #f)) + tmp1169) + #f) + (apply (lambda (_1174 mod1175 id1176) + (values + (syntax->datum id1176) + (syntax->datum + (cons '#(syntax-object + private + ((top) + #(ribcage + #(_ mod id) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(e) #((top)) #("i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile)) + mod1175)))) + tmp1169) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1168))) + ($sc-dispatch tmp1168 (quote (any each-any any))))) + e1167))) + (global-extend112 + 'core + 'if + (lambda (e1178 r1179 w1180 s1181 mod1182) + ((lambda (tmp1183) + ((lambda (tmp1184) + (if tmp1184 + (apply (lambda (_1185 test1186 then1187) + (build-conditional82 + s1181 + (chi150 test1186 r1179 w1180 mod1182) + (chi150 then1187 r1179 w1180 mod1182) + (build-void80 #f))) + tmp1184) + ((lambda (tmp1188) + (if tmp1188 + (apply (lambda (_1189 test1190 then1191 else1192) + (build-conditional82 + s1181 + (chi150 test1190 r1179 w1180 mod1182) + (chi150 then1191 r1179 w1180 mod1182) + (chi150 else1192 r1179 w1180 mod1182))) + tmp1188) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1183))) + ($sc-dispatch tmp1183 (quote (any any any any)))))) + ($sc-dispatch tmp1183 (quote (any any any))))) + e1178))) + (global-extend112 + 'begin + 'begin + '()) + (global-extend112 + 'define + 'define + '()) + (global-extend112 + 'define-syntax + 'define-syntax + '()) + (global-extend112 + 'eval-when + 'eval-when + '()) + (global-extend112 + 'core + 'syntax-case + (letrec ((gen-syntax-case1196 + (lambda (x1197 keys1198 clauses1199 r1200 mod1201) + (if (null? clauses1199) + (build-application81 + #f + (build-primref91 #f (quote syntax-violation)) + (list (build-data92 #f #f) + (build-data92 + #f + "source expression failed to match any pattern") + x1197)) + ((lambda (tmp1202) + ((lambda (tmp1203) + (if tmp1203 + (apply (lambda (pat1204 exp1205) + (if (if (id?114 pat1204) + (and-map + (lambda (x1206) + (not (free-id=?137 + pat1204 + x1206))) + (cons '#(syntax-object + ... + ((top) + #(ribcage + #(pat exp) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x + keys + clauses + r + mod) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + (gen-syntax-case + gen-clause + build-dispatch-call + convert-pattern) + ((top) + (top) + (top) + (top)) + ("i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile)) + keys1198)) + #f) + (let ((labels1207 + (list (gen-label119))) + (var1208 (gen-var161 pat1204))) + (build-application81 + #f + (build-lambda90 + #f + (list (syntax->datum pat1204)) + (list var1208) + #f + (chi150 + exp1205 + (extend-env108 + labels1207 + (list (cons 'syntax + (cons var1208 + 0))) + r1200) + (make-binding-wrap131 + (list pat1204) + labels1207 + '(())) + mod1201)) + (list x1197))) + (gen-clause1195 + x1197 + keys1198 + (cdr clauses1199) + r1200 + pat1204 + #t + exp1205 + mod1201))) + tmp1203) + ((lambda (tmp1209) + (if tmp1209 + (apply (lambda (pat1210 fender1211 exp1212) + (gen-clause1195 + x1197 + keys1198 + (cdr clauses1199) + r1200 + pat1210 + fender1211 + exp1212 + mod1201)) + tmp1209) + ((lambda (_1213) + (syntax-violation + 'syntax-case + "invalid clause" + (car clauses1199))) + tmp1202))) + ($sc-dispatch tmp1202 (quote (any any any)))))) + ($sc-dispatch tmp1202 (quote (any any))))) + (car clauses1199))))) + (gen-clause1195 + (lambda (x1214 + keys1215 + clauses1216 + r1217 + pat1218 + fender1219 + exp1220 + mod1221) + (call-with-values + (lambda () + (convert-pattern1193 pat1218 keys1215)) + (lambda (p1222 pvars1223) + (if (not (distinct-bound-ids?140 (map car pvars1223))) + (syntax-violation + 'syntax-case + "duplicate pattern variable" + pat1218) + (if (not (and-map + (lambda (x1224) + (not (ellipsis?159 (car x1224)))) + pvars1223)) + (syntax-violation + 'syntax-case + "misplaced ellipsis" + pat1218) + (let ((y1225 (gen-var161 (quote tmp)))) + (build-application81 + #f + (build-lambda90 + #f + (list (quote tmp)) + (list y1225) + #f + (let ((y1226 (build-lexical-reference83 + 'value + #f + 'tmp + y1225))) + (build-conditional82 + #f + ((lambda (tmp1227) + ((lambda (tmp1228) + (if tmp1228 + (apply (lambda () y1226) + tmp1228) + ((lambda (_1229) + (build-conditional82 + #f + y1226 + (build-dispatch-call1194 + pvars1223 + fender1219 + y1226 + r1217 + mod1221) + (build-data92 #f #f))) + tmp1227))) + ($sc-dispatch + tmp1227 + '#(atom #t)))) + fender1219) + (build-dispatch-call1194 + pvars1223 + exp1220 + y1226 + r1217 + mod1221) + (gen-syntax-case1196 + x1214 + keys1215 + clauses1216 + r1217 + mod1221)))) + (list (if (eq? p1222 (quote any)) + (build-application81 + #f + (build-primref91 #f (quote list)) + (list x1214)) + (build-application81 + #f + (build-primref91 + #f + '$sc-dispatch) + (list x1214 + (build-data92 + #f + p1222))))))))))))) + (build-dispatch-call1194 + (lambda (pvars1230 exp1231 y1232 r1233 mod1234) + (let ((ids1235 (map car pvars1230)) + (levels1236 (map cdr pvars1230))) + (let ((labels1237 (gen-labels120 ids1235)) + (new-vars1238 (map gen-var161 ids1235))) + (build-application81 + #f + (build-primref91 #f (quote apply)) + (list (build-lambda90 + #f + (map syntax->datum ids1235) + new-vars1238 + #f + (chi150 + exp1231 + (extend-env108 + labels1237 + (map (lambda (var1239 level1240) + (cons 'syntax + (cons var1239 level1240))) + new-vars1238 + (map cdr pvars1230)) + r1233) + (make-binding-wrap131 + ids1235 + labels1237 + '(())) + mod1234)) + y1232)))))) + (convert-pattern1193 + (lambda (pattern1241 keys1242) + (letrec ((cvt1243 + (lambda (p1244 n1245 ids1246) + (if (id?114 p1244) + (if (bound-id-member?141 p1244 keys1242) + (values + (vector (quote free-id) p1244) + ids1246) + (values + 'any + (cons (cons p1244 n1245) ids1246))) + ((lambda (tmp1247) + ((lambda (tmp1248) + (if (if tmp1248 + (apply (lambda (x1249 dots1250) + (ellipsis?159 + dots1250)) + tmp1248) + #f) + (apply (lambda (x1251 dots1252) + (call-with-values + (lambda () + (cvt1243 + x1251 + (fx+72 n1245 1) + ids1246)) + (lambda (p1253 ids1254) + (values + (if (eq? p1253 + 'any) + 'each-any + (vector + 'each + p1253)) + ids1254)))) + tmp1248) + ((lambda (tmp1255) + (if tmp1255 + (apply (lambda (x1256 y1257) + (call-with-values + (lambda () + (cvt1243 + y1257 + n1245 + ids1246)) + (lambda (y1258 + ids1259) + (call-with-values + (lambda () + (cvt1243 + x1256 + n1245 + ids1259)) + (lambda (x1260 + ids1261) + (values + (cons x1260 + y1258) + ids1261)))))) + tmp1255) + ((lambda (tmp1262) + (if tmp1262 + (apply (lambda () + (values + '() + ids1246)) + tmp1262) + ((lambda (tmp1263) + (if tmp1263 + (apply (lambda (x1264) + (call-with-values + (lambda () + (cvt1243 + x1264 + n1245 + ids1246)) + (lambda (p1266 + ids1267) + (values + (vector + 'vector + p1266) + ids1267)))) + tmp1263) + ((lambda (x1268) + (values + (vector + 'atom + (strip160 + p1244 + '(()))) + ids1246)) + tmp1247))) + ($sc-dispatch + tmp1247 + '#(vector + each-any))))) + ($sc-dispatch + tmp1247 + '())))) + ($sc-dispatch + tmp1247 + '(any . any))))) + ($sc-dispatch + tmp1247 + '(any any)))) + p1244))))) + (cvt1243 pattern1241 0 (quote ())))))) + (lambda (e1269 r1270 w1271 s1272 mod1273) + (let ((e1274 (source-wrap143 e1269 w1271 s1272 mod1273))) + ((lambda (tmp1275) + ((lambda (tmp1276) + (if tmp1276 + (apply (lambda (_1277 val1278 key1279 m1280) + (if (and-map + (lambda (x1281) + (if (id?114 x1281) + (not (ellipsis?159 x1281)) + #f)) + key1279) + (let ((x1283 (gen-var161 (quote tmp)))) + (build-application81 + s1272 + (build-lambda90 + #f + (list (quote tmp)) + (list x1283) + #f + (gen-syntax-case1196 + (build-lexical-reference83 + 'value + #f + 'tmp + x1283) + key1279 + m1280 + r1270 + mod1273)) + (list (chi150 + val1278 + r1270 + '(()) + mod1273)))) + (syntax-violation + 'syntax-case + "invalid literals list" + e1274))) + tmp1276) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1275))) + ($sc-dispatch + tmp1275 + '(any any each-any . each-any)))) + e1274))))) + (set! sc-expand + (lambda (x1287 . rest1286) + (if (if (pair? x1287) + (equal? (car x1287) noexpand70) + #f) + (cadr x1287) + (let ((m1288 (if (null? rest1286) (quote e) (car rest1286))) + (esew1289 + (if (let ((t1290 (null? rest1286))) + (if t1290 t1290 (null? (cdr rest1286)))) + '(eval) + (cadr rest1286)))) + (with-fluid* + *mode*71 + m1288 + (lambda () + (chi-top149 + x1287 + '() + '((top)) + m1288 + esew1289 + (cons 'hygiene + (module-name (current-module)))))))))) + (set! identifier? + (lambda (x1291) (nonsymbol-id?113 x1291))) + (set! datum->syntax + (lambda (id1292 datum1293) + (make-syntax-object97 + datum1293 + (syntax-object-wrap100 id1292) + #f))) + (set! syntax->datum + (lambda (x1294) (strip160 x1294 (quote (()))))) + (set! generate-temporaries + (lambda (ls1295) + (begin + (let ((x1296 ls1295)) + (if (not (list? x1296)) + (syntax-violation + 'generate-temporaries + "invalid argument" + x1296))) + (map (lambda (x1297) + (wrap142 (gensym) (quote ((top))) #f)) + ls1295)))) + (set! free-identifier=? + (lambda (x1298 y1299) + (begin + (let ((x1300 x1298)) + (if (not (nonsymbol-id?113 x1300)) + (syntax-violation + 'free-identifier=? + "invalid argument" + x1300))) + (let ((x1301 y1299)) + (if (not (nonsymbol-id?113 x1301)) + (syntax-violation + 'free-identifier=? + "invalid argument" + x1301))) + (free-id=?137 x1298 y1299)))) + (set! bound-identifier=? + (lambda (x1302 y1303) + (begin + (let ((x1304 x1302)) + (if (not (nonsymbol-id?113 x1304)) + (syntax-violation + 'bound-identifier=? + "invalid argument" + x1304))) + (let ((x1305 y1303)) + (if (not (nonsymbol-id?113 x1305)) + (syntax-violation + 'bound-identifier=? + "invalid argument" + x1305))) + (bound-id=?138 x1302 y1303)))) + (set! syntax-violation + (lambda (who1309 message1308 form1307 . subform1306) + (begin + (let ((x1310 who1309)) + (if (not ((lambda (x1311) + (let ((t1312 (not x1311))) + (if t1312 + t1312 + (let ((t1313 (string? x1311))) + (if t1313 t1313 (symbol? x1311)))))) + x1310)) + (syntax-violation + 'syntax-violation + "invalid argument" + x1310))) + (let ((x1314 message1308)) + (if (not (string? x1314)) + (syntax-violation + 'syntax-violation + "invalid argument" + x1314))) + (scm-error + 'syntax-error + 'sc-expand + (string-append + (if who1309 "~a: " "") + "~a " + (if (null? subform1306) + "in ~a" + "in subform `~s' of `~s'")) + (let ((tail1315 + (cons message1308 + (map (lambda (x1316) (strip160 x1316 (quote (())))) + (append subform1306 (list form1307)))))) + (if who1309 (cons who1309 tail1315) tail1315)) + #f)))) + (letrec ((match1321 + (lambda (e1322 p1323 w1324 r1325 mod1326) + (if (not r1325) + #f + (if (eq? p1323 (quote any)) + (cons (wrap142 e1322 w1324 mod1326) r1325) + (if (syntax-object?98 e1322) + (match*1320 + (syntax-object-expression99 e1322) + p1323 + (join-wraps133 + w1324 + (syntax-object-wrap100 e1322)) + r1325 + (syntax-object-module101 e1322)) + (match*1320 e1322 p1323 w1324 r1325 mod1326)))))) + (match*1320 + (lambda (e1327 p1328 w1329 r1330 mod1331) + (if (null? p1328) + (if (null? e1327) r1330 #f) + (if (pair? p1328) + (if (pair? e1327) + (match1321 + (car e1327) + (car p1328) + w1329 + (match1321 + (cdr e1327) + (cdr p1328) + w1329 + r1330 + mod1331) + mod1331) + #f) + (if (eq? p1328 (quote each-any)) + (let ((l1332 (match-each-any1318 + e1327 + w1329 + mod1331))) + (if l1332 (cons l1332 r1330) #f)) + (let ((atom-key1333 (vector-ref p1328 0))) + (if (memv atom-key1333 (quote (each))) + (if (null? e1327) + (match-empty1319 (vector-ref p1328 1) r1330) + (let ((l1334 (match-each1317 + e1327 + (vector-ref p1328 1) + w1329 + mod1331))) + (if l1334 + (letrec ((collect1335 + (lambda (l1336) + (if (null? (car l1336)) + r1330 + (cons (map car l1336) + (collect1335 + (map cdr l1336))))))) + (collect1335 l1334)) + #f))) + (if (memv atom-key1333 (quote (free-id))) + (if (id?114 e1327) + (if (free-id=?137 + (wrap142 e1327 w1329 mod1331) + (vector-ref p1328 1)) + r1330 + #f) + #f) + (if (memv atom-key1333 (quote (atom))) + (if (equal? + (vector-ref p1328 1) + (strip160 e1327 w1329)) + r1330 + #f) + (if (memv atom-key1333 (quote (vector))) + (if (vector? e1327) + (match1321 + (vector->list e1327) + (vector-ref p1328 1) + w1329 + r1330 + mod1331) + #f))))))))))) + (match-empty1319 + (lambda (p1337 r1338) + (if (null? p1337) + r1338 + (if (eq? p1337 (quote any)) + (cons (quote ()) r1338) + (if (pair? p1337) + (match-empty1319 + (car p1337) + (match-empty1319 (cdr p1337) r1338)) + (if (eq? p1337 (quote each-any)) + (cons (quote ()) r1338) + (let ((atom-key1339 (vector-ref p1337 0))) + (if (memv atom-key1339 (quote (each))) + (match-empty1319 (vector-ref p1337 1) r1338) + (if (memv atom-key1339 (quote (free-id atom))) + r1338 + (if (memv atom-key1339 (quote (vector))) + (match-empty1319 + (vector-ref p1337 1) + r1338))))))))))) + (match-each-any1318 + (lambda (e1340 w1341 mod1342) + (if (pair? e1340) + (let ((l1343 (match-each-any1318 + (cdr e1340) + w1341 + mod1342))) + (if l1343 + (cons (wrap142 (car e1340) w1341 mod1342) l1343) + #f)) + (if (null? e1340) + '() + (if (syntax-object?98 e1340) + (match-each-any1318 + (syntax-object-expression99 e1340) + (join-wraps133 + w1341 + (syntax-object-wrap100 e1340)) + mod1342) + #f))))) + (match-each1317 + (lambda (e1344 p1345 w1346 mod1347) + (if (pair? e1344) + (let ((first1348 + (match1321 + (car e1344) + p1345 + w1346 + '() + mod1347))) + (if first1348 + (let ((rest1349 + (match-each1317 + (cdr e1344) + p1345 + w1346 + mod1347))) + (if rest1349 (cons first1348 rest1349) #f)) + #f)) + (if (null? e1344) + '() + (if (syntax-object?98 e1344) + (match-each1317 + (syntax-object-expression99 e1344) + p1345 + (join-wraps133 + w1346 + (syntax-object-wrap100 e1344)) + (syntax-object-module101 e1344)) + #f)))))) + (set! $sc-dispatch + (lambda (e1350 p1351) + (if (eq? p1351 (quote any)) + (list e1350) + (if (syntax-object?98 e1350) + (match*1320 + (syntax-object-expression99 e1350) + p1351 + (syntax-object-wrap100 e1350) + '() + (syntax-object-module101 e1350)) + (match*1320 + e1350 + p1351 + '(()) + '() + #f))))))))) + +(define with-syntax + (make-syncase-macro + 'macro + (lambda (x1352) + ((lambda (tmp1353) + ((lambda (tmp1354) + (if tmp1354 + (apply (lambda (_1355 e11356 e21357) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ e1 e2) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + (cons e11356 e21357))) + tmp1354) + ((lambda (tmp1359) + (if tmp1359 + (apply (lambda (_1360 out1361 in1362 e11363 e21364) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + in1362 + '() + (list out1361 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + (cons e11363 e21364))))) + tmp1359) + ((lambda (tmp1366) + (if tmp1366 + (apply (lambda (_1367 out1368 in1369 e11370 e21371) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + in1369) + '() + (list out1368 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + (cons e11370 e21371))))) + tmp1366) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1353))) + ($sc-dispatch + tmp1353 + '(any #(each (any any)) any . each-any))))) + ($sc-dispatch + tmp1353 + '(any ((any any)) any . each-any))))) + ($sc-dispatch + tmp1353 + '(any () any . each-any)))) + x1352)))) + +(define syntax-rules + (make-syncase-macro + 'macro + (lambda (x1375) + ((lambda (tmp1376) + ((lambda (tmp1377) + (if tmp1377 + (apply (lambda (_1378 + k1379 + keyword1380 + pattern1381 + template1382) + (list '#(syntax-object + lambda + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + '(#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile))) + (cons '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + (cons '#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + (cons k1379 + (map (lambda (tmp1385 tmp1384) + (list (cons '#(syntax-object + dummy + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + tmp1384) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + tmp1385))) + template1382 + pattern1381)))))) + tmp1377) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1376))) + ($sc-dispatch + tmp1376 + '(any each-any . #(each ((any . any) any)))))) + x1375)))) + +(define let* + (make-extended-syncase-macro + (module-ref (current-module) (quote let*)) + 'macro + (lambda (x1386) + ((lambda (tmp1387) + ((lambda (tmp1388) + (if (if tmp1388 + (apply (lambda (let*1389 x1390 v1391 e11392 e21393) + (and-map identifier? x1390)) + tmp1388) + #f) + (apply (lambda (let*1395 x1396 v1397 e11398 e21399) + (letrec ((f1400 (lambda (bindings1401) + (if (null? bindings1401) + (cons '#(syntax-object + let + ((top) + #(ribcage () () ()) + #(ribcage + #(f bindings) + #((top) (top)) + #("i" "i")) + #(ribcage + #(let* x v e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + (cons '() + (cons e11398 e21399))) + ((lambda (tmp1405) + ((lambda (tmp1406) + (if tmp1406 + (apply (lambda (body1407 + binding1408) + (list '#(syntax-object + let + ((top) + #(ribcage + #(body + binding) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + bindings) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(let* + x + v + e1 + e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list binding1408) + body1407)) + tmp1406) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1405))) + ($sc-dispatch + tmp1405 + '(any any)))) + (list (f1400 (cdr bindings1401)) + (car bindings1401))))))) + (f1400 (map list x1396 v1397)))) + tmp1388) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1387))) + ($sc-dispatch + tmp1387 + '(any #(each (any any)) any . each-any)))) + x1386)))) + +(define do + (make-extended-syncase-macro + (module-ref (current-module) (quote do)) + 'macro + (lambda (orig-x1409) + ((lambda (tmp1410) + ((lambda (tmp1411) + (if tmp1411 + (apply (lambda (_1412 + var1413 + init1414 + step1415 + e01416 + e11417 + c1418) + ((lambda (tmp1419) + ((lambda (tmp1420) + (if tmp1420 + (apply (lambda (step1421) + ((lambda (tmp1422) + ((lambda (tmp1423) + (if tmp1423 + (apply (lambda () + (list '#(syntax-object + let + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + (map list + var1413 + init1414) + (list '#(syntax-object + if + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + (list '#(syntax-object + not + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + e01416) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + (append + c1418 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + step1421))))))) + tmp1423) + ((lambda (tmp1428) + (if tmp1428 + (apply (lambda (e11429 + e21430) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + (map list + var1413 + init1414) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + e01416 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + (cons e11429 + e21430)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + (append + c1418 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i"))) + (hygiene + guile)) + step1421))))))) + tmp1428) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1422))) + ($sc-dispatch + tmp1422 + '(any . each-any))))) + ($sc-dispatch tmp1422 (quote ())))) + e11417)) + tmp1420) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1419))) + ($sc-dispatch tmp1419 (quote each-any)))) + (map (lambda (v1437 s1438) + ((lambda (tmp1439) + ((lambda (tmp1440) + (if tmp1440 + (apply (lambda () v1437) tmp1440) + ((lambda (tmp1441) + (if tmp1441 + (apply (lambda (e1442) e1442) + tmp1441) + ((lambda (_1443) + (syntax-violation + 'do + "bad step expression" + orig-x1409 + s1438)) + tmp1439))) + ($sc-dispatch tmp1439 (quote (any)))))) + ($sc-dispatch tmp1439 (quote ())))) + s1438)) + var1413 + step1415))) + tmp1411) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1410))) + ($sc-dispatch + tmp1410 + '(any #(each (any any . any)) + (any . each-any) + . + each-any)))) + orig-x1409)))) + +(define quasiquote + (make-extended-syncase-macro + (module-ref (current-module) (quote quasiquote)) + 'macro + (letrec ((quasicons1446 + (lambda (x1450 y1451) + ((lambda (tmp1452) + ((lambda (tmp1453) + (if tmp1453 + (apply (lambda (x1454 y1455) + ((lambda (tmp1456) + ((lambda (tmp1457) + (if tmp1457 + (apply (lambda (dy1458) + ((lambda (tmp1459) + ((lambda (tmp1460) + (if tmp1460 + (apply (lambda (dx1461) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(dx) + #((top)) + #("i")) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene + guile)) + (cons dx1461 + dy1458))) + tmp1460) + ((lambda (_1462) + (if (null? dy1458) + (list '#(syntax-object + list + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene + guile)) + x1454) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene + guile)) + x1454 + y1455))) + tmp1459))) + ($sc-dispatch + tmp1459 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage + #(dy) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) + (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene + guile))) + any)))) + x1454)) + tmp1457) + ((lambda (tmp1463) + (if tmp1463 + (apply (lambda (stuff1464) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(stuff) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) + (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene + guile)) + (cons x1454 + stuff1464))) + tmp1463) + ((lambda (else1465) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(else) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene guile)) + x1454 + y1455)) + tmp1456))) + ($sc-dispatch + tmp1456 + '(#(free-id + #(syntax-object + list + ((top) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + . + any))))) + ($sc-dispatch + tmp1456 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + any)))) + y1455)) + tmp1453) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1452))) + ($sc-dispatch tmp1452 (quote (any any))))) + (list x1450 y1451)))) + (quasiappend1447 + (lambda (x1466 y1467) + ((lambda (tmp1468) + ((lambda (tmp1469) + (if tmp1469 + (apply (lambda (x1470 y1471) + ((lambda (tmp1472) + ((lambda (tmp1473) + (if tmp1473 + (apply (lambda () x1470) tmp1473) + ((lambda (_1474) + (list '#(syntax-object + append + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (hygiene guile)) + x1470 + y1471)) + tmp1472))) + ($sc-dispatch + tmp1472 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + ())))) + y1471)) + tmp1469) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1468))) + ($sc-dispatch tmp1468 (quote (any any))))) + (list x1466 y1467)))) + (quasivector1448 + (lambda (x1475) + ((lambda (tmp1476) + ((lambda (x1477) + ((lambda (tmp1478) + ((lambda (tmp1479) + (if tmp1479 + (apply (lambda (x1480) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile)) + (list->vector x1480))) + tmp1479) + ((lambda (tmp1482) + (if tmp1482 + (apply (lambda (x1483) + (cons '#(syntax-object + vector + ((top) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (hygiene guile)) + x1483)) + tmp1482) + ((lambda (_1485) + (list '#(syntax-object + list->vector + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile)) + x1477)) + tmp1478))) + ($sc-dispatch + tmp1478 + '(#(free-id + #(syntax-object + list + ((top) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + . + each-any))))) + ($sc-dispatch + tmp1478 + '(#(free-id + #(syntax-object + quote + ((top) + #(ribcage #(x) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + each-any)))) + x1477)) + tmp1476)) + x1475))) + (quasi1449 + (lambda (p1486 lev1487) + ((lambda (tmp1488) + ((lambda (tmp1489) + (if tmp1489 + (apply (lambda (p1490) + (if (= lev1487 0) + p1490 + (quasicons1446 + '(#(syntax-object + quote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile)) + #(syntax-object + unquote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + (quasi1449 (list p1490) (- lev1487 1))))) + tmp1489) + ((lambda (tmp1491) + (if (if tmp1491 + (apply (lambda (args1492) (= lev1487 0)) + tmp1491) + #f) + (apply (lambda (args1493) + (syntax-violation + 'unquote + "unquote takes exactly one argument" + p1486 + (cons '#(syntax-object + unquote + ((top) + #(ribcage + #(args) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile)) + args1493))) + tmp1491) + ((lambda (tmp1494) + (if tmp1494 + (apply (lambda (p1495 q1496) + (if (= lev1487 0) + (quasiappend1447 + p1495 + (quasi1449 q1496 lev1487)) + (quasicons1446 + (quasicons1446 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (hygiene guile)) + #(syntax-object + unquote-splicing + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + (quasi1449 + (list p1495) + (- lev1487 1))) + (quasi1449 q1496 lev1487)))) + tmp1494) + ((lambda (tmp1497) + (if (if tmp1497 + (apply (lambda (args1498 q1499) + (= lev1487 0)) + tmp1497) + #f) + (apply (lambda (args1500 q1501) + (syntax-violation + 'unquote-splicing + "unquote-splicing takes exactly one argument" + p1486 + (cons '#(syntax-object + unquote-splicing + ((top) + #(ribcage + #(args q) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene guile)) + args1500))) + tmp1497) + ((lambda (tmp1502) + (if tmp1502 + (apply (lambda (p1503) + (quasicons1446 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene guile)) + #(syntax-object + quasiquote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene guile))) + (quasi1449 + (list p1503) + (+ lev1487 1)))) + tmp1502) + ((lambda (tmp1504) + (if tmp1504 + (apply (lambda (p1505 q1506) + (quasicons1446 + (quasi1449 + p1505 + lev1487) + (quasi1449 + q1506 + lev1487))) + tmp1504) + ((lambda (tmp1507) + (if tmp1507 + (apply (lambda (x1508) + (quasivector1448 + (quasi1449 + x1508 + lev1487))) + tmp1507) + ((lambda (p1510) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(p lev) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i"))) + (hygiene + guile)) + p1510)) + tmp1488))) + ($sc-dispatch + tmp1488 + '#(vector each-any))))) + ($sc-dispatch + tmp1488 + '(any . any))))) + ($sc-dispatch + tmp1488 + '(#(free-id + #(syntax-object + quasiquote + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + any))))) + ($sc-dispatch + tmp1488 + '((#(free-id + #(syntax-object + unquote-splicing + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + . + any) + . + any))))) + ($sc-dispatch + tmp1488 + '((#(free-id + #(syntax-object + unquote-splicing + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons + quasiappend + quasivector + quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + any) + . + any))))) + ($sc-dispatch + tmp1488 + '(#(free-id + #(syntax-object + unquote + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(quasicons quasiappend quasivector quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + . + any))))) + ($sc-dispatch + tmp1488 + '(#(free-id + #(syntax-object + unquote + ((top) + #(ribcage () () ()) + #(ribcage #(p lev) #((top) (top)) #("i" "i")) + #(ribcage + #(quasicons quasiappend quasivector quasi) + #((top) (top) (top) (top)) + #("i" "i" "i" "i"))) + (hygiene guile))) + any)))) + p1486)))) + (lambda (x1511) + ((lambda (tmp1512) + ((lambda (tmp1513) + (if tmp1513 + (apply (lambda (_1514 e1515) (quasi1449 e1515 0)) + tmp1513) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1512))) + ($sc-dispatch tmp1512 (quote (any any))))) + x1511))))) + +(define include + (make-syncase-macro + 'macro + (lambda (x1516) + (letrec ((read-file1517 + (lambda (fn1518 k1519) + (let ((p1520 (open-input-file fn1518))) + (letrec ((f1521 (lambda (x1522) + (if (eof-object? x1522) + (begin + (close-input-port p1520) + '()) + (cons (datum->syntax k1519 x1522) + (f1521 (read p1520))))))) + (f1521 (read p1520))))))) + ((lambda (tmp1523) + ((lambda (tmp1524) + (if tmp1524 + (apply (lambda (k1525 filename1526) + (let ((fn1527 (syntax->datum filename1526))) + ((lambda (tmp1528) + ((lambda (tmp1529) + (if tmp1529 + (apply (lambda (exp1530) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(exp) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(fn) + #((top)) + #("i")) + #(ribcage + #(k filename) + #((top) (top)) + #("i" "i")) + #(ribcage + (read-file) + ((top)) + ("i")) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + exp1530)) + tmp1529) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1528))) + ($sc-dispatch tmp1528 (quote each-any)))) + (read-file1517 fn1527 k1525)))) + tmp1524) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1523))) + ($sc-dispatch tmp1523 (quote (any any))))) + x1516))))) + +(define unquote + (make-syncase-macro + 'macro + (lambda (x1532) + ((lambda (tmp1533) + ((lambda (tmp1534) + (if tmp1534 + (apply (lambda (_1535 e1536) + (syntax-violation + 'unquote + "expression not valid outside of quasiquote" + x1532)) + tmp1534) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1533))) + ($sc-dispatch tmp1533 (quote (any any))))) + x1532)))) + +(define unquote-splicing + (make-syncase-macro + 'macro + (lambda (x1537) + ((lambda (tmp1538) + ((lambda (tmp1539) + (if tmp1539 + (apply (lambda (_1540 e1541) + (syntax-violation + 'unquote-splicing + "expression not valid outside of quasiquote" + x1537)) + tmp1539) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1538))) + ($sc-dispatch tmp1538 (quote (any any))))) + x1537)))) + +(define case + (make-extended-syncase-macro + (module-ref (current-module) (quote case)) + 'macro + (lambda (x1542) + ((lambda (tmp1543) + ((lambda (tmp1544) + (if tmp1544 + (apply (lambda (_1545 e1546 m11547 m21548) + ((lambda (tmp1549) + ((lambda (body1550) + (list '#(syntax-object + let + ((top) + #(ribcage #(body) #((top)) #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(body) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + e1546)) + body1550)) + tmp1549)) + (letrec ((f1551 (lambda (clause1552 clauses1553) + (if (null? clauses1553) + ((lambda (tmp1555) + ((lambda (tmp1556) + (if tmp1556 + (apply (lambda (e11557 + e21558) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (cons e11557 + e21558))) + tmp1556) + ((lambda (tmp1560) + (if tmp1560 + (apply (lambda (k1561 + e11562 + e21563) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + k1561)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (cons e11562 + e21563)))) + tmp1560) + ((lambda (_1566) + (syntax-violation + 'case + "bad clause" + x1542 + clause1552)) + tmp1555))) + ($sc-dispatch + tmp1555 + '(each-any + any + . + each-any))))) + ($sc-dispatch + tmp1555 + '(#(free-id + #(syntax-object + else + ((top) + #(ribcage () () ()) + #(ribcage + #(f clause clauses) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile))) + any + . + each-any)))) + clause1552) + ((lambda (tmp1567) + ((lambda (rest1568) + ((lambda (tmp1569) + ((lambda (tmp1570) + (if tmp1570 + (apply (lambda (k1571 + e11572 + e21573) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + k1571)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (cons e11572 + e21573)) + rest1568)) + tmp1570) + ((lambda (_1576) + (syntax-violation + 'case + "bad clause" + x1542 + clause1552)) + tmp1569))) + ($sc-dispatch + tmp1569 + '(each-any + any + . + each-any)))) + clause1552)) + tmp1567)) + (f1551 (car clauses1553) + (cdr clauses1553))))))) + (f1551 m11547 m21548)))) + tmp1544) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1543))) + ($sc-dispatch + tmp1543 + '(any any any . each-any)))) + x1542)))) + +(define identifier-syntax + (make-syncase-macro + 'macro + (lambda (x1577) + ((lambda (tmp1578) + ((lambda (tmp1579) + (if tmp1579 + (apply (lambda (_1580 e1581) + (list '#(syntax-object + lambda + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + '(#(syntax-object + x + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile))) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + '#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + '() + (list '#(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + '(#(syntax-object + identifier? + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + (#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)) + #(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i"))) + (hygiene guile)))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + e1581)) + (list (cons _1580 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + (cons e1581 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile))))))))) + tmp1579) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp1578))) + ($sc-dispatch tmp1578 (quote (any any))))) + x1577)))) + From ac4d09b1647f84453175aabcf8fde7807a3b5cf9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 8 Jun 2009 22:43:28 +0200 Subject: [PATCH 207/375] a start to changing VM scheme copyrights * module/language/tree-il/primitives.scm: Change copyright to LGPLv2.1. Others will follow. --- module/language/tree-il/primitives.scm | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 6ce538490..8960c2802 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,21 +1,20 @@ -;;; GHIL macros +;;; open-coding primitive procedures -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2.1 of the License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, +;; This library 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. +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: From 8f9b968329797a6a228bb18f5dddfa7444c97ff5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 9 Jun 2009 23:42:05 +0200 Subject: [PATCH 208/375] some attempts to solve the ecmascript stack overflow problem * module/language/ecmascript/compile-ghil.scm (comp): Just use pmatch, not ormatch. Now with syncase running over everything, it doesn't matter. * module/ice-9/boot-9.scm (false-if-exception): Avoid saving stacks inside false-if-exception. There's probably a more general solution to this, though. Fixes getting bogus backtraces sometimes. * module/Makefile.am (ECMASCRIPT_LANG_SOURCES): Reorder things so that spec comes last. --- module/Makefile.am | 4 ++-- module/ice-9/boot-9.scm | 8 ++++++-- module/language/ecmascript/compile-ghil.scm | 13 +------------ 3 files changed, 9 insertions(+), 16 deletions(-) diff --git a/module/Makefile.am b/module/Makefile.am index ca7785212..3358441b1 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -105,12 +105,12 @@ ECMASCRIPT_LANG_SOURCES = \ language/ecmascript/parse-lalr.scm \ language/ecmascript/tokenize.scm \ language/ecmascript/parse.scm \ - language/ecmascript/spec.scm \ language/ecmascript/impl.scm \ language/ecmascript/base.scm \ language/ecmascript/function.scm \ language/ecmascript/array.scm \ - language/ecmascript/compile-ghil.scm + language/ecmascript/compile-ghil.scm \ + language/ecmascript/spec.scm SCRIPTS_SOURCES = \ scripts/PROGRAM.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index bb66ccfb6..a2600491b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -382,8 +382,12 @@ (define (apply-to-args args fn) (apply fn args)) (defmacro false-if-exception (expr) - `(catch #t (lambda () ,expr) - (lambda args #f))) + `(catch #t + (lambda () + ;; avoid saving backtraces inside false-if-exception + (with-fluid* the-last-stack (fluid-ref the-last-stack) + (lambda () ,expr))) + (lambda args #f))) diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm index 92d71ec16..6e4779120 100644 --- a/module/language/ecmascript/compile-ghil.scm +++ b/module/language/ecmascript/compile-ghil.scm @@ -50,17 +50,6 @@ (and (not (null? props)) props)))) -;; The purpose, you ask? To avoid non-tail recursion when expanding a -;; long pmatch sequence. -(define-macro (ormatch x . clauses) - (let ((X (gensym))) - `(let ((,X ,x)) - (or ,@(map (lambda (c) - (if (eq? (car c) 'else) - `(begin . ,(cdr c)) - `(pmatch ,X ,c (else #f)))) - clauses))))) - (define (comp x e) (let ((l (location x))) (define (let1 what proc) @@ -74,7 +63,7 @@ (-> (bind vars (list what) (-> (begin (list (proc (car vars)) (-> (ref (car vars))))))))))) - (ormatch x + (pmatch x (null ;; FIXME, null doesn't have much relation to EOL... (-> (quote '()))) From 9ea12179fffffa8e1ba12cde4a10c35504a80012 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 10 Jun 2009 00:03:52 +0200 Subject: [PATCH 209/375] fix debug-options * module/ice-9/boot-9.scm (define-option-interface): Fix (debug-options 'full), along with other options. Thanks to Mark Weaver for the tip. * THANKS: Update, though many more names need to be added. --- THANKS | 2 ++ module/ice-9/boot-9.scm | 14 +++++++------- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/THANKS b/THANKS index e3cf1e37c..748605c1a 100644 --- a/THANKS +++ b/THANKS @@ -93,6 +93,7 @@ For fixes or providing information which led to a fix: Scott Shedden Alex Shinn Daniel Skarda + Dale Smith Cesar Strauss Rainer Tammer Richard Todd @@ -108,6 +109,7 @@ For fixes or providing information which led to a fix: Andreas Vögele Michael Talbot-Wilson Michael Tuexen + Mark H. Weaver Jon Wilson Andy Wingo Keith Wright diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index a2600491b..78b194aa3 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2324,9 +2324,9 @@ module '(ice-9 q) '(make-q q-length))}." ;;; (defmacro define-option-interface (option-group) - (let* ((option-name car) - (option-value cadr) - (option-documentation caddr) + (let* ((option-name 'car) + (option-value 'cadr) + (option-documentation 'caddr) ;; Below follow the macros defining the run-time option interfaces. @@ -2337,15 +2337,15 @@ module '(ice-9 q) '(make-q q-length))}." (,interface (car args)) (,interface)) (else (for-each (lambda (option) - (display (option-name option)) + (display (,option-name option)) (if (< (string-length - (symbol->string (option-name option))) + (symbol->string (,option-name option))) 8) (display #\tab)) (display #\tab) - (display (option-value option)) + (display (,option-value option)) (display #\tab) - (display (option-documentation option)) + (display (,option-documentation option)) (newline)) (,interface #t))))))) From de3d1fc9884ae587862ed119700fcc59c1452407 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 10 Jun 2009 10:51:02 +0200 Subject: [PATCH 210/375] bump default stack limit to 160000 words * libguile/eval.c (scm_debug_opts): Up the default stack limit by a factor of 4. Psyntax expansions currently bounce back and forth between the VM and the interpreter, due to `map'. (Hopefully that won't be the case in the future, when have map in scheme, and we get an inliner.) Anyway when expanding a big nested expression, as for example in (language ecmascript compile-ghil) -- the pmatch code ends up being super-nested -- we can consume loads o stack. So given that on desktop machines, where rlimit is likely to be unset, default rlimits are around 8 or 10 MB or so, let's bump up our default limit to 640KB (on 32-bit). Should be enough for anyone. See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for more info. Thanks to Mark H. Weaver for the diagnosis! --- libguile/eval.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 05af5a1c5..574ab4740 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3028,8 +3028,19 @@ scm_t_option scm_debug_opts[] = { { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." }, { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." }, { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, + /* This default stack limit will be overridden by debug.c:init_stack_limit(), + if we have getrlimit() and the stack limit is not INFINITY. But it is still + important, as some systems have both the soft and the hard limits set to + INFINITY; in that case we fall back to this value. - { SCM_OPTION_INTEGER, "stack", 40000, "Stack size limit (measured in words; 0 = no check)." }, + The situation is aggravated by certain compilers, which can consume + "beaucoup de stack", as they say in France. + + See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for + more discussion. This setting is 640 KB on 32-bit arches (should be enough + for anyone!) or a whoppin' 1280 KB on 64-bit arches. + */ + { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." }, { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers " "in backtraces when not `#f'. A value of `base' " From 76e834686ede4d55739556af60c80ff66145d74c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 10 Jun 2009 10:53:00 +0200 Subject: [PATCH 211/375] fix defmacro*, defmacro*-public * module/ice-9/boot-9.scm (define-private): Remove apocyphal comment. The FIXME would really be to remove `define-private', though... * module/ice-9/optargs.scm (defmacro*, defmacro*-public): Fix these macros. Thanks to Dale Smith for the report. --- module/ice-9/boot-9.scm | 2 -- module/ice-9/optargs.scm | 12 ++++-------- 2 files changed, 4 insertions(+), 10 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 78b194aa3..3d77093c0 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2931,8 +2931,6 @@ module '(ice-9 q) '(make-q q-length))}." (process-use-modules (list (list ,@(compile-interface-spec spec)))) *unspecified*)) -;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed -;; as soon as guile supports hygienic macros. (define-syntax define-private (syntax-rules () ((_ foo bar) diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm index 4dea92fd7..975703c2d 100644 --- a/module/ice-9/optargs.scm +++ b/module/ice-9/optargs.scm @@ -410,15 +410,11 @@ ;; (defmacro* transmorgify (a #:optional b) (defmacro defmacro* (NAME ARGLIST . BODY) - (defmacro*-guts 'define NAME ARGLIST BODY)) + `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY))) (defmacro defmacro*-public (NAME ARGLIST . BODY) - (defmacro*-guts 'define-public NAME ARGLIST BODY)) - -;; The guts of defmacro* and defmacro*-public -(define (defmacro*-guts DT NAME ARGLIST BODY) - `(,DT ,NAME - (,(lambda (transformer) (defmacro:transformer transformer)) - (lambda* ,ARGLIST ,@BODY)))) + `(begin + (defmacro* ,NAME ,ARGLIST ,@BODY) + (export-syntax ,NAME))) ;;; optargs.scm ends here From dffd0672faf3db4fa46042e447e62dff22a9e4e9 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 11 Jun 2009 23:24:34 +0100 Subject: [PATCH 212/375] Note Andy as a contributor --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index 748605c1a..c0349fc08 100644 --- a/THANKS +++ b/THANKS @@ -13,6 +13,7 @@ Contributors since the last release: Kevin Ryde Bill Schottstaedt Richard Todd + Andy Wingo Sponsors since the last release: From 62e9a9b704524edfad98dd84ac5a11abd48d0b27 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 12 Jun 2009 23:04:48 +0100 Subject: [PATCH 213/375] Fix `make distcheck' * libguile/r6rs-ports.c (scm_init_r6rs_ports): Add libguile/ to included .x file name. --- libguile/r6rs-ports.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index a07636fce..d2c02ff40 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1109,7 +1109,7 @@ initialize_custom_binary_output_ports (void) void scm_init_r6rs_ports (void) { -#include "r6rs-ports.x" +#include "libguile/r6rs-ports.x" initialize_bytevector_input_ports (); initialize_custom_binary_input_ports (); From f856c2b6d77633366f154cb38cd4edb384b4892d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 13 Jun 2009 10:45:45 +0100 Subject: [PATCH 214/375] Fix for make distcheck * examples/Makefile.am (AM_CFLAGS, AM_LIBS): Set PATH so that guile-config can find guile. --- examples/Makefile.am | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/Makefile.am b/examples/Makefile.am index 873f34ce0..e514bd4a9 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -38,8 +38,8 @@ EXTRA_DIST = README ChangeLog-2008 check.test \ \ safe/README safe/safe safe/untrusted.scm safe/evil.scm -AM_CFLAGS = `PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config compile` -AM_LIBS = `PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config link` +AM_CFLAGS = `PATH=$(bindir):$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config compile` +AM_LIBS = `PATH=$(bindir):$$PATH PKG_CONFIG_PATH=$(libdir)/pkgconfig $(bindir)/guile-config link` box/box: box/box.o From 39b94fee4304d56babf5bd62e10c5786a79f4389 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 14 Jun 2009 17:58:15 +0100 Subject: [PATCH 215/375] Provide easier configure options for GMP and readline This patch uses the AC_LIB_LINKFLAGS macro, provided by Gnulib's havelib module, to provide --with-gmp-prefix and --with-readline-prefix configure options. Many thanks to Bruno Haible for suggesting and explaining this to me. * configure.in (top level): Add AC_LIB_LINKFLAGS(gmp). * guile-readline/configure.in (AC_CONFIG_AUX_DIR): Change to ../build-aux, to share the main build-aux directory and so avoid having to distribute multiple copies of config.rpath. (top level): Add AC_LIB_LINKFLAGS(readline). * lib/Makefile.am, m4/gnulib-cache.m4: Regenerated by gnulib-tool for new import of the `havelib' module. --- configure.in | 1 + guile-readline/configure.in | 3 ++- lib/Makefile.am | 2 +- m4/gnulib-cache.m4 | 3 ++- 4 files changed, 6 insertions(+), 3 deletions(-) diff --git a/configure.in b/configure.in index 6568e524f..480263d66 100644 --- a/configure.in +++ b/configure.in @@ -827,6 +827,7 @@ fi dnl GMP tests +AC_LIB_LINKFLAGS(gmp) AC_CHECK_LIB([gmp], [__gmpz_init], , [AC_MSG_ERROR([GNU MP not found, see README])]) diff --git a/guile-readline/configure.in b/guile-readline/configure.in index 9098a31e6..d05356618 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -7,7 +7,7 @@ AC_INIT(guile-readline, ]), [bug-guile@gnu.org]) -AC_CONFIG_AUX_DIR([.]) +AC_CONFIG_AUX_DIR([../build-aux]) AC_CONFIG_SRCDIR(readline.c) AM_CONFIG_HEADER([guile-readline-config.h]) AM_INIT_AUTOMAKE([foreign no-define]) @@ -38,6 +38,7 @@ for termlib in ncurses curses termcap terminfo termlib ; do [LIBS="-l${termlib} $LIBS"; break]) done +AC_LIB_LINKFLAGS(readline) AC_CHECK_LIB(readline, readline) if test $ac_cv_lib_readline_readline = no; then AC_MSG_WARN([libreadline was not found on your system.]) diff --git a/lib/Makefile.am b/lib/Makefile.am index 6f2f5c5fa..704c2bcaa 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 0fbe11969..a45029493 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -30,6 +30,7 @@ gl_MODULES([ fpieee full-read full-write + havelib iconv_open-utf lib-symbol-visibility libunistring From 5aaccd35a24eb67d5c489bda4e1e5faf1b22744e Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 14 Jun 2009 18:07:01 +0100 Subject: [PATCH 216/375] Add Tex and texinfo output and auxiliary suffixes to .gitignore --- .gitignore | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/.gitignore b/.gitignore index 0b2ff7cf2..ec59e5e70 100644 --- a/.gitignore +++ b/.gitignore @@ -75,3 +75,19 @@ cscope.out cscope.files *.log INSTALL +*.aux +*.cp +*.cps +*.dvi +*.fn +*.fns +*.ky +*.pg +*.toc +*.tp +*.vr +*.tps +*.vrs +*.pgs +*.rn +*.rns From a89cafc0562942680db63fe8ddf89f466ba2f7af Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 14 Jun 2009 18:41:50 +0100 Subject: [PATCH 217/375] Update README on using libraries in non-standard locations * README: Update instructions on using libraries in non-standard locations. Also change expected next stable release number from 1.10.0 to 2.0.0. --- README | 50 ++++++++++++++++++++++++++++++++------------------ 1 file changed, 32 insertions(+), 18 deletions(-) diff --git a/README b/README index 4950229df..563d1a663 100644 --- a/README +++ b/README @@ -14,7 +14,7 @@ Guile versions with an odd middle number, i.e. 1.9.* are unstable development versions. Even middle numbers indicate stable versions. This has been the case since the 1.3.* series. -The next stable release will likely be version 1.10.0. +The next stable release will likely be version 2.0.0. Please send bug reports to bug-guile@gnu.org. @@ -27,24 +27,38 @@ Generic instructions for configuring and compiling Guile can be found in the INSTALL file. Guile specific information and configure options can be found below, including instructions for installing SLIB. -Guile requires a few external packages and can optionally use a number -of external packages such as `readline' when they are available. -Guile expects to be able to find these packages in the default -compiler setup, it does not try to make any special arrangements -itself. For example, for the `readline' package, Guile expects to be -able to find the include file , without passing -any special `-I' options to the compiler. +Guile depends on the following external libraries. +- libgmp +- libiconv +- libintl +- libltdl +- libunistring +It will also use the libreadline library if it is available. For each +of these there is a corresponding --with-XXX-prefix option that you +can use when invoking ./configure, if you have these libraries +installed in a location other than the standard places (/usr and +/usr/local). -If you installed an external package, and you used the --prefix -installation option to install it somewhere else than /usr/local, you -must arrange for your compiler to find it by default. If that -compiler is gcc, one convenient way of making such arrangements is to -use the --with-local-prefix option during installation, naming the -same directory as you used in the --prefix option of the package. In -particular, it is not good enough to use the same --prefix option when -you install gcc and the package; you need to use the ---with-local-prefix option as well. See the gcc documentation for -more details. +These options are provided by the Gnulib `havelib' module, and details +of how they work are documented in `Searching for Libraries' in the +Gnulib manual (http://www.gnu.org/software/gnulib/manual). The extent +to which they work on a given OS depends on whether that OS supports +encoding full library path names in executables (aka `rpath'). Also +note that using these options, and hence hardcoding full library path +names (where that is supported), makes it impossible to later move the +built executables and libraries to an installation location other than +the one that was specified at build time. + +Another possible approach is to set CPPFLAGS and LDFLAGS before +running configure, so that they include -I options for all the +non-standard places where you have installed header files and -L +options for all the non-standard places where you have installed +libraries. This will allow configure and make to find those headers +and libraries during the build. The locations found will not be +hardcoded into the build executables and libraries, so with this +approach you will probably also need to set LD_LIBRARY_PATH +correspondingly, to allow Guile to find the necessary libraries again +at runtime. Required External Packages ================================================ From 53befeb700c31dec58cec2c8f6f34535541a2f39 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 17 Jun 2009 00:22:09 +0100 Subject: [PATCH 218/375] Change Guile license to LGPLv3+ (Not quite finished, the following will be done tomorrow. module/srfi/*.scm module/rnrs/*.scm module/scripts/*.scm testsuite/*.scm guile-readline/* ) --- COPYING | 674 ++++++++++++++++++ COPYING.LESSER | 619 ++++------------ LICENSE | 2 +- Makefile.am | 18 +- NEWS | 6 + README | 1 + am/Makefile.am | 16 +- am/maintainer-dirs | 10 +- am/pre-inst-guile | 10 +- benchmark-suite/benchmarks/bytevectors.bm | 15 +- benchmark-suite/benchmarks/read.bm | 18 +- benchmark-suite/benchmarks/subr.bm | 18 +- .../benchmarks/uniform-vector-read.bm | 18 +- benchmark-suite/guile-benchmark | 18 +- benchmark-suite/lib.scm | 18 +- configure.in | 24 +- doc/Makefile.am | 16 +- doc/example-smob/image-type.c | 24 +- doc/example-smob/myguile.c | 24 +- doc/goops/Makefile.am | 20 +- doc/groupings.alist | 22 +- doc/maint/docstring.el | 26 +- doc/oldfmt.c | 21 +- doc/r5rs/Makefile.am | 20 +- doc/ref/Makefile.am | 16 +- doc/ref/intro.texi | 12 +- doc/ref/preface.texi | 6 +- doc/tutorial/Makefile.am | 20 +- emacs/Makefile.am | 16 +- emacs/gds-scheme.el | 3 +- emacs/gds-server.el | 3 +- emacs/gds.el | 3 +- emacs/gud-guile.el | 28 +- emacs/guile-c.el | 28 +- emacs/guile-emacs.scm | 28 +- emacs/guile-scheme.el | 28 +- emacs/guile.el | 28 +- emacs/multistring.el | 30 +- emacs/patch.el | 28 +- emacs/ppexpand.el | 30 +- emacs/update-changelog.el | 28 +- examples/Makefile.am | 20 +- examples/box-dynamic-module/box.c | 24 +- examples/box-dynamic/box.c | 24 +- examples/box-module/box.c | 24 +- examples/box/box.c | 24 +- examples/compat/compat.h | 9 +- gc-benchmarks/gc-profile.scm | 18 +- gc-benchmarks/run-benchmark.scm | 18 +- lang/Makefile.am | 20 +- libguile.h | 13 +- libguile/Makefile.am | 16 +- libguile/__scm.h | 13 +- libguile/_scm.h | 13 +- libguile/alist.c | 13 +- libguile/alist.h | 13 +- libguile/arbiters.c | 13 +- libguile/arbiters.h | 13 +- libguile/async.c | 13 +- libguile/async.h | 13 +- libguile/backtrace.c | 13 +- libguile/backtrace.h | 13 +- libguile/boolean.c | 13 +- libguile/boolean.h | 13 +- libguile/bytevectors.c | 13 +- libguile/bytevectors.h | 13 +- libguile/chars.c | 13 +- libguile/chars.h | 13 +- libguile/continuations.c | 13 +- libguile/continuations.h | 13 +- libguile/convert.c | 13 +- libguile/convert.h | 13 +- libguile/debug-malloc.c | 13 +- libguile/debug-malloc.h | 13 +- libguile/debug.c | 13 +- libguile/debug.h | 13 +- libguile/deprecated.c | 13 +- libguile/deprecated.h | 13 +- libguile/deprecation.c | 16 +- libguile/deprecation.h | 13 +- libguile/discouraged.c | 13 +- libguile/discouraged.h | 13 +- libguile/dynl.c | 13 +- libguile/dynl.h | 13 +- libguile/dynwind.c | 13 +- libguile/dynwind.h | 13 +- libguile/environments.c | 13 +- libguile/environments.h | 13 +- libguile/eq.c | 13 +- libguile/eq.h | 13 +- libguile/error.c | 13 +- libguile/error.h | 13 +- libguile/eval.c | 13 +- libguile/eval.h | 13 +- libguile/eval.i.c | 13 +- libguile/evalext.c | 13 +- libguile/evalext.h | 13 +- libguile/extensions.c | 13 +- libguile/extensions.h | 13 +- libguile/feature.c | 13 +- libguile/feature.h | 13 +- libguile/filesys.c | 13 +- libguile/filesys.h | 13 +- libguile/fluids.c | 13 +- libguile/fluids.h | 13 +- libguile/fports.c | 13 +- libguile/fports.h | 13 +- libguile/frames.c | 13 +- libguile/frames.h | 13 +- libguile/futures.c | 13 +- libguile/futures.h | 13 +- libguile/gc-card.c | 13 +- libguile/gc-freelist.c | 13 +- libguile/gc-malloc.c | 13 +- libguile/gc-mark.c | 13 +- libguile/gc-segment-table.c | 13 +- libguile/gc-segment.c | 13 +- libguile/gc.c | 13 +- libguile/gc.h | 13 +- libguile/gdb_interface.h | 27 +- libguile/gdbint.c | 13 +- libguile/gdbint.h | 13 +- libguile/gettext.c | 13 +- libguile/gettext.h | 13 +- libguile/goops.c | 13 +- libguile/goops.h | 13 +- libguile/gsubr.c | 13 +- libguile/gsubr.h | 13 +- libguile/guardians.c | 13 +- libguile/guardians.h | 13 +- libguile/guile-doc-snarf.in | 26 +- libguile/guile-func-name-check.in | 22 +- libguile/guile-snarf-docs.in | 22 +- libguile/guile-snarf.awk.in | 22 +- libguile/guile-snarf.in | 26 +- libguile/guile.c | 13 +- libguile/hash.c | 13 +- libguile/hash.h | 13 +- libguile/hashtab.c | 13 +- libguile/hashtab.h | 13 +- libguile/hooks.c | 13 +- libguile/hooks.h | 13 +- libguile/i18n.c | 13 +- libguile/i18n.h | 13 +- libguile/init.c | 13 +- libguile/init.h | 13 +- libguile/inline.c | 13 +- libguile/inline.h | 13 +- libguile/instructions.c | 13 +- libguile/instructions.h | 13 +- libguile/ioext.c | 13 +- libguile/ioext.h | 13 +- libguile/iselect.h | 13 +- libguile/keywords.c | 13 +- libguile/keywords.h | 13 +- libguile/lang.c | 13 +- libguile/lang.h | 13 +- libguile/list.c | 13 +- libguile/list.h | 13 +- libguile/load.c | 13 +- libguile/load.h | 13 +- libguile/locale-categories.h | 13 +- libguile/macros.c | 13 +- libguile/macros.h | 13 +- libguile/mallocs.c | 13 +- libguile/mallocs.h | 13 +- libguile/modules.c | 13 +- libguile/modules.h | 13 +- libguile/net_db.c | 13 +- libguile/net_db.h | 13 +- libguile/null-threads.c | 13 +- libguile/null-threads.h | 13 +- libguile/numbers.c | 13 +- libguile/numbers.h | 13 +- libguile/objcodes.c | 13 +- libguile/objcodes.h | 17 +- libguile/objects.c | 13 +- libguile/objects.h | 13 +- libguile/objprop.c | 13 +- libguile/objprop.h | 13 +- libguile/options.c | 13 +- libguile/options.h | 13 +- libguile/pairs.c | 13 +- libguile/pairs.h | 13 +- libguile/ports.c | 13 +- libguile/ports.h | 13 +- libguile/posix.c | 13 +- libguile/posix.h | 13 +- libguile/print.c | 13 +- libguile/print.h | 13 +- libguile/private-gc.h | 13 +- libguile/private-options.h | 13 +- libguile/procprop.c | 13 +- libguile/procprop.h | 13 +- libguile/procs.c | 13 +- libguile/procs.h | 13 +- libguile/programs.c | 13 +- libguile/programs.h | 13 +- libguile/properties.c | 13 +- libguile/properties.h | 13 +- libguile/pthread-threads.h | 13 +- libguile/putenv.c | 13 +- libguile/r6rs-ports.c | 13 +- libguile/r6rs-ports.h | 13 +- libguile/ramap.c | 13 +- libguile/ramap.h | 13 +- libguile/random.c | 13 +- libguile/random.h | 13 +- libguile/rdelim.c | 13 +- libguile/rdelim.h | 13 +- libguile/read.c | 13 +- libguile/read.h | 13 +- libguile/regex-posix.c | 13 +- libguile/regex-posix.h | 13 +- libguile/root.c | 13 +- libguile/root.h | 13 +- libguile/rw.c | 13 +- libguile/rw.h | 13 +- libguile/scmconfig.h.top | 13 +- libguile/scmsigs.c | 13 +- libguile/scmsigs.h | 13 +- libguile/script.c | 13 +- libguile/script.h | 13 +- libguile/simpos.c | 13 +- libguile/simpos.h | 13 +- libguile/smob.c | 13 +- libguile/smob.h | 13 +- libguile/snarf.h | 13 +- libguile/socket.c | 13 +- libguile/socket.h | 13 +- libguile/sort.c | 13 +- libguile/sort.h | 13 +- libguile/srcprop.c | 13 +- libguile/srcprop.h | 13 +- libguile/srfi-13.c | 13 +- libguile/srfi-13.h | 13 +- libguile/srfi-14.c | 13 +- libguile/srfi-14.h | 13 +- libguile/srfi-4.c | 13 +- libguile/srfi-4.h | 13 +- libguile/stackchk.c | 13 +- libguile/stackchk.h | 13 +- libguile/stacks.c | 13 +- libguile/stacks.h | 13 +- libguile/stime.c | 13 +- libguile/stime.h | 13 +- libguile/strerror.c | 27 +- libguile/strings.c | 13 +- libguile/strings.h | 13 +- libguile/strorder.c | 13 +- libguile/strorder.h | 13 +- libguile/strports.c | 13 +- libguile/strports.h | 13 +- libguile/struct.c | 13 +- libguile/struct.h | 13 +- libguile/symbols.c | 13 +- libguile/symbols.h | 13 +- libguile/tags.h | 13 +- libguile/threads.c | 13 +- libguile/threads.h | 13 +- libguile/throw.c | 13 +- libguile/throw.h | 13 +- libguile/unif.c | 13 +- libguile/unif.h | 13 +- libguile/validate.h | 13 +- libguile/values.c | 13 +- libguile/values.h | 13 +- libguile/variable.c | 13 +- libguile/variable.h | 13 +- libguile/vectors.c | 13 +- libguile/vectors.h | 13 +- libguile/version.c | 13 +- libguile/version.h.in | 13 +- libguile/vm-bootstrap.h | 13 +- libguile/vm-engine.c | 13 +- libguile/vm-engine.h | 13 +- libguile/vm-expand.h | 13 +- libguile/vm-i-loader.c | 13 +- libguile/vm-i-scheme.c | 13 +- libguile/vm-i-system.c | 13 +- libguile/vm.c | 13 +- libguile/vm.h | 13 +- libguile/vports.c | 13 +- libguile/vports.h | 13 +- libguile/weaks.c | 13 +- libguile/weaks.h | 13 +- libguile/win32-dirent.c | 13 +- libguile/win32-dirent.h | 13 +- libguile/win32-socket.c | 13 +- libguile/win32-socket.h | 13 +- libguile/win32-uname.c | 13 +- libguile/win32-uname.h | 13 +- meta/Makefile.am | 16 +- meta/gdb-uninstalled-guile.in | 16 +- meta/guile-config | 7 +- meta/guile-tools | 7 +- meta/guile.in | 16 +- meta/guile.m4 | 9 +- meta/uninstalled-env.in | 11 +- module/Makefile.am | 16 +- module/ice-9/and-let-star.scm | 2 +- module/ice-9/arrays.scm | 21 +- module/ice-9/boot-9.scm | 2 +- module/ice-9/buffered-input.scm | 2 +- module/ice-9/calling.scm | 2 +- module/ice-9/channel.scm | 26 +- module/ice-9/common-list.scm | 2 +- module/ice-9/debug.scm | 2 +- module/ice-9/debugger.scm | 26 +- module/ice-9/debugger/command-loop.scm | 26 +- module/ice-9/debugger/commands.scm | 26 +- module/ice-9/debugger/state.scm | 26 +- module/ice-9/debugger/trc.scm | 26 +- module/ice-9/debugging/breakpoints.scm | 26 +- module/ice-9/debugging/steps.scm | 26 +- module/ice-9/debugging/trace.scm | 26 +- module/ice-9/debugging/traps.scm | 26 +- module/ice-9/debugging/trc.scm | 26 +- module/ice-9/deprecated.scm | 2 +- module/ice-9/documentation.scm | 2 +- module/ice-9/emacs.scm | 2 +- module/ice-9/expect.scm | 2 +- module/ice-9/ftw.scm | 2 +- module/ice-9/gap-buffer.scm | 26 +- module/ice-9/gds-server.scm | 26 +- module/ice-9/getopt-long.scm | 26 +- module/ice-9/hcons.scm | 2 +- module/ice-9/history.scm | 2 +- module/ice-9/i18n.scm | 6 +- module/ice-9/lineio.scm | 2 +- module/ice-9/list.scm | 26 +- module/ice-9/ls.scm | 2 +- module/ice-9/mapping.scm | 2 +- module/ice-9/match.scm | 2 +- module/ice-9/networking.scm | 2 +- module/ice-9/null.scm | 2 +- module/ice-9/occam-channel.scm | 26 +- module/ice-9/optargs.scm | 2 +- module/ice-9/poe.scm | 2 +- module/ice-9/popen.scm | 2 +- module/ice-9/posix.scm | 2 +- module/ice-9/pretty-print.scm | 2 +- module/ice-9/psyntax.scm | 2 +- module/ice-9/q.scm | 2 +- module/ice-9/r4rs.scm | 2 +- module/ice-9/r5rs.scm | 2 +- module/ice-9/rdelim.scm | 2 +- module/ice-9/receive.scm | 26 +- module/ice-9/regex.scm | 2 +- module/ice-9/runq.scm | 2 +- module/ice-9/rw.scm | 2 +- module/ice-9/safe-r5rs.scm | 2 +- module/ice-9/safe.scm | 2 +- module/ice-9/serialize.scm | 2 +- module/ice-9/session.scm | 2 +- module/ice-9/slib.scm | 6 +- module/ice-9/stack-catch.scm | 2 +- module/ice-9/streams.scm | 2 +- module/ice-9/string-fun.scm | 2 +- module/ice-9/syncase.scm | 2 +- module/ice-9/test.scm | 26 +- module/ice-9/threads.scm | 2 +- module/ice-9/time.scm | 2 +- module/ice-9/weak-vector.scm | 2 +- module/language/assembly.scm | 27 +- module/language/assembly/compile-bytecode.scm | 27 +- .../language/assembly/decompile-bytecode.scm | 27 +- module/language/assembly/disassemble.scm | 27 +- module/language/assembly/spec.scm | 27 +- module/language/bytecode/spec.scm | 27 +- module/language/ecmascript/array.scm | 27 +- module/language/ecmascript/base.scm | 27 +- module/language/ecmascript/compile-ghil.scm | 27 +- module/language/ecmascript/function.scm | 27 +- module/language/ecmascript/impl.scm | 27 +- module/language/ecmascript/parse-lalr.scm | 25 +- module/language/ecmascript/parse.scm | 27 +- module/language/ecmascript/spec.scm | 27 +- module/language/ecmascript/tokenize.scm | 27 +- module/language/elisp/spec.scm | 27 +- module/language/ghil.scm | 27 +- module/language/ghil/compile-glil.scm | 27 +- module/language/ghil/spec.scm | 27 +- module/language/glil.scm | 27 +- module/language/glil/compile-assembly.scm | 27 +- module/language/glil/decompile-assembly.scm | 27 +- module/language/glil/spec.scm | 27 +- module/language/objcode.scm | 27 +- module/language/objcode/spec.scm | 27 +- module/language/r5rs/core.il | 27 +- module/language/r5rs/expand.scm | 27 +- module/language/r5rs/null.il | 27 +- module/language/r5rs/spec.scm | 27 +- module/language/scheme/compile-ghil.scm | 27 +- module/language/scheme/compile-tree-il.scm | 27 +- module/language/scheme/decompile-tree-il.scm | 27 +- module/language/scheme/inline.scm | 27 +- module/language/scheme/spec.scm | 27 +- module/language/tree-il.scm | 2 +- module/language/tree-il/analyze.scm | 27 +- module/language/tree-il/compile-glil.scm | 27 +- module/language/tree-il/optimize.scm | 27 +- module/language/tree-il/primitives.scm | 26 +- module/language/tree-il/spec.scm | 27 +- module/language/value/spec.scm | 27 +- module/oop/goops.scm | 2 +- module/oop/goops/accessors.scm | 21 +- module/oop/goops/active-slot.scm | 2 +- module/oop/goops/compile.scm | 2 +- module/oop/goops/composite-slot.scm | 2 +- module/oop/goops/describe.scm | 2 +- module/oop/goops/dispatch.scm | 2 +- module/oop/goops/internal.scm | 2 +- module/oop/goops/save.scm | 2 +- module/oop/goops/simple.scm | 2 +- module/oop/goops/stklos.scm | 2 +- module/oop/goops/util.scm | 2 +- module/srfi/Makefile.am | 20 +- qt/Makefile.am | 20 +- qt/md/Makefile.am | 20 +- qt/time/Makefile.am | 20 +- srfi/Makefile.am | 16 +- srfi/srfi-1.c | 13 +- srfi/srfi-1.h | 13 +- srfi/srfi-13.c | 13 +- srfi/srfi-13.h | 13 +- srfi/srfi-14.c | 13 +- srfi/srfi-14.h | 13 +- srfi/srfi-4.c | 13 +- srfi/srfi-4.h | 13 +- srfi/srfi-60.c | 13 +- srfi/srfi-60.h | 13 +- test-suite/Makefile.am | 24 +- test-suite/guile-test | 18 +- test-suite/lib.scm | 18 +- test-suite/standalone/Makefile.am | 24 +- test-suite/standalone/test-asmobs-lib.c | 13 +- test-suite/standalone/test-conversion.c | 13 +- test-suite/standalone/test-extensions-lib.c | 13 +- test-suite/standalone/test-fast-slot-ref.in | 21 +- test-suite/standalone/test-list.c | 13 +- test-suite/standalone/test-num2integral.c | 13 +- test-suite/standalone/test-round.c | 13 +- test-suite/standalone/test-scm-c-read.c | 13 +- .../standalone/test-scm-take-locale-symbol.c | 13 +- test-suite/standalone/test-scm-with-guile.c | 13 +- test-suite/standalone/test-unwind.c | 13 +- test-suite/standalone/test-use-srfi.in | 21 +- .../standalone/test-with-guile-module.c | 13 +- test-suite/tests/alist.test | 2 +- test-suite/tests/and-let-star.test | 25 +- test-suite/tests/arbiters.test | 2 +- test-suite/tests/asm-to-bytecode.test | 2 +- test-suite/tests/bit-operations.test | 2 +- test-suite/tests/bytevectors.test | 6 +- test-suite/tests/c-api.test | 21 +- test-suite/tests/chars.test | 28 +- test-suite/tests/common-list.test | 2 +- test-suite/tests/compiler.test | 2 +- test-suite/tests/continuations.test | 21 +- test-suite/tests/dynamic-scope.test | 21 +- test-suite/tests/elisp.test | 2 +- test-suite/tests/environments.test | 2 +- test-suite/tests/eval.test | 2 +- test-suite/tests/exceptions.test | 2 +- test-suite/tests/filesys.test | 2 +- test-suite/tests/format.test | 21 +- test-suite/tests/fractions.test | 23 +- test-suite/tests/ftw.test | 2 +- test-suite/tests/gc.test | 2 +- test-suite/tests/getopt-long.test | 25 +- test-suite/tests/goops.test | 21 +- test-suite/tests/guardians.test | 21 +- test-suite/tests/hash.test | 2 +- test-suite/tests/hooks.test | 2 +- test-suite/tests/i18n.test | 6 +- test-suite/tests/import.test | 2 +- test-suite/tests/interp.test | 21 +- test-suite/tests/list.test | 2 +- test-suite/tests/load.test | 21 +- test-suite/tests/modules.test | 6 +- test-suite/tests/multilingual.nottest | 21 +- test-suite/tests/numbers.test | 2 +- test-suite/tests/optargs.test | 21 +- test-suite/tests/options.test | 21 +- test-suite/tests/pairs.test | 21 +- test-suite/tests/poe.test | 2 +- test-suite/tests/popen.test | 2 +- test-suite/tests/ports.test | 21 +- test-suite/tests/posix.test | 25 +- test-suite/tests/procprop.test | 25 +- test-suite/tests/q.test | 2 +- test-suite/tests/r4rs.test | 2 +- test-suite/tests/r5rs_pitfall.test | 2 +- test-suite/tests/r6rs-ports.test | 6 +- test-suite/tests/ramap.test | 2 +- test-suite/tests/reader.test | 6 +- test-suite/tests/receive.test | 25 +- test-suite/tests/regexp.test | 21 +- test-suite/tests/socket.test | 2 +- test-suite/tests/sort.test | 21 +- test-suite/tests/srcprop.test | 2 +- test-suite/tests/srfi-1.test | 25 +- test-suite/tests/srfi-10.test | 21 +- test-suite/tests/srfi-11.test | 25 +- test-suite/tests/srfi-13.test | 25 +- test-suite/tests/srfi-14.test | 21 +- test-suite/tests/srfi-17.test | 21 +- test-suite/tests/srfi-18.test | 21 +- test-suite/tests/srfi-19.test | 25 +- test-suite/tests/srfi-31.test | 2 +- test-suite/tests/srfi-34.test | 25 +- test-suite/tests/srfi-35.test | 25 +- test-suite/tests/srfi-37.test | 25 +- test-suite/tests/srfi-39.test | 21 +- test-suite/tests/srfi-4.test | 21 +- test-suite/tests/srfi-6.test | 25 +- test-suite/tests/srfi-60.test | 25 +- test-suite/tests/srfi-69.test | 25 +- test-suite/tests/srfi-88.test | 25 +- test-suite/tests/srfi-9.test | 21 +- test-suite/tests/srfi-98.test | 25 +- test-suite/tests/streams.test | 21 +- test-suite/tests/strings.test | 21 +- test-suite/tests/structs.test | 25 +- test-suite/tests/symbols.test | 21 +- test-suite/tests/syncase.test | 21 +- test-suite/tests/syntax.test | 21 +- test-suite/tests/threads.test | 25 +- test-suite/tests/time.test | 21 +- test-suite/tests/tree-il.test | 6 +- test-suite/tests/unif.test | 2 +- test-suite/tests/vectors.test | 21 +- test-suite/tests/version.test | 21 +- test-suite/tests/weaks.test | 2 +- 535 files changed, 4735 insertions(+), 4228 deletions(-) create mode 100644 COPYING diff --git a/COPYING b/COPYING new file mode 100644 index 000000000..94a9ed024 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/COPYING.LESSER b/COPYING.LESSER index 8add30ad5..cca7fc278 100644 --- a/COPYING.LESSER +++ b/COPYING.LESSER @@ -1,504 +1,165 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 2.1, February 1999 + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 - Copyright (C) 1991, 1999 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. -[This is the first released version of the Lesser GPL. It also counts - as the successor of the GNU Library Public License, version 2, hence - the version number 2.1.] - Preamble + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. + 0. Additional Definitions. - This license, the Lesser General Public License, applies to some -specially designated software packages--typically libraries--of the -Free Software Foundation and other authors who decide to use it. You -can use it too, but we suggest you first think carefully about whether -this license or the ordinary General Public License is the better -strategy to use in any particular case, based on the explanations below. + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. - When we speak of free software, we are referring to freedom of use, -not price. Our General Public Licenses are designed to make sure that -you have the freedom to distribute copies of free software (and charge -for this service if you wish); that you receive source code or can get -it if you want it; that you can change the software and use pieces of -it in new free programs; and that you are informed that you can do -these things. + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. - To protect your rights, we need to make restrictions that forbid -distributors to deny you these rights or to ask you to surrender these -rights. These restrictions translate to certain responsibilities for -you if you distribute copies of the library or if you modify it. + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link other code with the library, you must provide -complete object files to the recipients, so that they can relink them -with the library after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". - We protect your rights with a two-step method: (1) we copyright the -library, and (2) we offer you this license, which gives you legal -permission to copy, distribute and/or modify the library. + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. - To protect each distributor, we want to make it very clear that -there is no warranty for the free library. Also, if the library is -modified by someone else and passed on, the recipients should know -that what they have is not the original version, so that the original -author's reputation will not be affected by problems that might be -introduced by others. - - Finally, software patents pose a constant threat to the existence of -any free program. We wish to make sure that a company cannot -effectively restrict the users of a free program by obtaining a -restrictive license from a patent holder. Therefore, we insist that -any patent license obtained for a version of the library must be -consistent with the full freedom of use specified in this license. + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. - Most GNU software, including some libraries, is covered by the -ordinary GNU General Public License. This license, the GNU Lesser -General Public License, applies to certain designated libraries, and -is quite different from the ordinary General Public License. We use -this license for certain libraries in order to permit linking those -libraries into non-free programs. + 1. Exception to Section 3 of the GNU GPL. - When a program is linked with a library, whether statically or using -a shared library, the combination of the two is legally speaking a -combined work, a derivative of the original library. The ordinary -General Public License therefore permits such linking only if the -entire combination fits its criteria of freedom. The Lesser General -Public License permits more lax criteria for linking other code with -the library. + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. - We call this license the "Lesser" General Public License because it -does Less to protect the user's freedom than the ordinary General -Public License. It also provides other free software developers Less -of an advantage over competing non-free programs. These disadvantages -are the reason we use the ordinary General Public License for many -libraries. However, the Lesser license provides advantages in certain -special circumstances. + 2. Conveying Modified Versions. - For example, on rare occasions, there may be a special need to -encourage the widest possible use of a certain library, so that it becomes -a de-facto standard. To achieve this, non-free programs must be -allowed to use the library. A more frequent case is that a free -library does the same job as widely used non-free libraries. In this -case, there is little to gain by limiting the free library to free -software only, so we use the Lesser General Public License. + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: - In other cases, permission to use a particular library in non-free -programs enables a greater number of people to use a large body of -free software. For example, permission to use the GNU C Library in -non-free programs enables many more people to use the whole GNU -operating system, as well as its variant, the GNU/Linux operating -system. + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or - Although the Lesser General Public License is Less protective of the -users' freedom, it does ensure that the user of a program that is -linked with the Library has the freedom and the wherewithal to run -that program using a modified version of the Library. + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, whereas the latter must -be combined with the library in order to run. - - GNU LESSER GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + 3. Object Code Incorporating Material from Library Header Files. - 0. This License Agreement applies to any software library or other -program which contains a notice placed by the copyright holder or -other authorized party saying it may be distributed under the terms of -this Lesser General Public License (also called "this License"). -Each licensee is addressed as "you". + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) + b) Accompany the object code with a copy of the GNU GPL and this license + document. - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. + 4. Combined Works. - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also combine or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (1) uses at run time a - copy of the library already present on the user's computer system, - rather than copying library functions into the executable, and (2) - will operate properly with a modified version of the library, if - the user installs one, as long as the modified version is - interface-compatible with the version that the work was made with. - - c) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - d) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - e) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the materials to be distributed need not include anything that is -normally distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties with -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Lesser General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. It is -safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library 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 - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! - - diff --git a/LICENSE b/LICENSE index 213e34ae8..3961579b8 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ Guile is covered under the terms of the GNU Lesser General Public -License, version 2.1. See COPYING.LESSER. +License, version 3 or later. See COPYING.LESSER and COPYING. diff --git a/Makefile.am b/Makefile.am index a82143b78..a7a793792 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,23 +1,23 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, 2008 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA # want automake 1.10 or higher so that AM_GNU_GETTEXT can tell automake that # config.rpath is needed diff --git a/NEWS b/NEWS index 9aca5d912..747c93119 100644 --- a/NEWS +++ b/NEWS @@ -14,6 +14,12 @@ Changes in 1.9.0: * Changes to the distribution +** Guile's license is now LGPLv3+ + +In other words the GNU Lesser General Public License, version 3 or +later (at the discretion of each person that chooses to redistribute +part of Guile). + ** Guile now uses Gnulib as a portability aid * Changes to the stand-alone interpreter diff --git a/README b/README index 563d1a663..1f71b8afe 100644 --- a/README +++ b/README @@ -323,6 +323,7 @@ About This Distribution ============================================== Interesting files include: - LICENSE, which contains the exact terms of the Guile license. +- COPYING.LESSER, which contains the terms of the GNU Lesser General Public License. - COPYING, which contains the terms of the GNU General Public License. - INSTALL, which contains general instructions for building/installing Guile. - NEWS, which describes user-visible changes since the last release of Guile. diff --git a/am/Makefile.am b/am/Makefile.am index 2c49adb09..d1b7eccc7 100644 --- a/am/Makefile.am +++ b/am/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/am/maintainer-dirs b/am/maintainer-dirs index c64268de9..f1b741be7 100644 --- a/am/maintainer-dirs +++ b/am/maintainer-dirs @@ -5,17 +5,17 @@ ## This file is part of GUILE. ## ## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## it under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, write ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA diff --git a/am/pre-inst-guile b/am/pre-inst-guile index 353908dfb..7993d1531 100644 --- a/am/pre-inst-guile +++ b/am/pre-inst-guile @@ -5,17 +5,17 @@ ## This file is part of GUILE. ## ## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## it under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, write ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA diff --git a/benchmark-suite/benchmarks/bytevectors.bm b/benchmark-suite/benchmarks/bytevectors.bm index 9547a71df..a686a08c9 100644 --- a/benchmark-suite/benchmarks/bytevectors.bm +++ b/benchmark-suite/benchmarks/bytevectors.bm @@ -4,19 +4,20 @@ ;;; Copyright 2009 Ludovic Courtès ;;; ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +;;; GNU Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (benchmarks bytevector) :use-module (rnrs bytevector) diff --git a/benchmark-suite/benchmarks/read.bm b/benchmark-suite/benchmarks/read.bm index cb876b5ad..f11ca687a 100644 --- a/benchmark-suite/benchmarks/read.bm +++ b/benchmark-suite/benchmarks/read.bm @@ -2,20 +2,20 @@ ;;; ;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +;;; GNU Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;; Boston, MA 02110-1301 USA +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (benchmarks read) :use-module (benchmark-suite lib)) diff --git a/benchmark-suite/benchmarks/subr.bm b/benchmark-suite/benchmarks/subr.bm index 9c87a9921..ea0045650 100644 --- a/benchmark-suite/benchmarks/subr.bm +++ b/benchmark-suite/benchmarks/subr.bm @@ -2,20 +2,20 @@ ;;; ;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +;;; GNU Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;; Boston, MA 02110-1301 USA +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (benchmarks subrs) :use-module (benchmark-suite lib)) diff --git a/benchmark-suite/benchmarks/uniform-vector-read.bm b/benchmark-suite/benchmarks/uniform-vector-read.bm index d288f0b44..d188b2b86 100644 --- a/benchmark-suite/benchmarks/uniform-vector-read.bm +++ b/benchmark-suite/benchmarks/uniform-vector-read.bm @@ -2,20 +2,20 @@ ;;; ;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +;;; GNU Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;; Boston, MA 02110-1301 USA +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (benchmarks uniform-vector-read) :use-module (benchmark-suite lib) diff --git a/benchmark-suite/guile-benchmark b/benchmark-suite/guile-benchmark index c4c6f23de..41cae06a1 100755 --- a/benchmark-suite/guile-benchmark +++ b/benchmark-suite/guile-benchmark @@ -7,20 +7,20 @@ ;;;; ;;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3, or (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. +;;;; GNU Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this software; see the file COPYING.LESSER. +;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin +;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Usage: [guile -e main -s] guile-benchmark [OPTIONS] [BENCHMARK ...] diff --git a/benchmark-suite/lib.scm b/benchmark-suite/lib.scm index 65491d735..65253c5ff 100644 --- a/benchmark-suite/lib.scm +++ b/benchmark-suite/lib.scm @@ -1,20 +1,20 @@ ;;;; benchmark-suite/lib.scm --- generic support for benchmarking ;;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3, or (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. +;;;; GNU Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this software; see the file COPYING.LESSER. +;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin +;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (benchmark-suite lib) :export ( diff --git a/configure.in b/configure.in index 480263d66..1c4cf5f8b 100644 --- a/configure.in +++ b/configure.in @@ -8,20 +8,20 @@ Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, This file is part of GUILE -GUILE is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your -option) any later version. +GUILE is free software; you can redistribute it and/or modify it under +the terms of the GNU Lesser General Public License as published by the +Free Software Foundation; either version 3, or (at your option) any +later version. -GUILE 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. +GUILE 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 Lesser General Public +License for more details. -You should have received a copy of the GNU General Public License -along with GUILE; see the file COPYING. If not, write to the -Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -Boston, MA 02110-1301, USA. +You should have received a copy of the GNU Lesser General Public +License along with GUILE; see the file COPYING.LESSER. If not, write +to the Free Software Foundation, Inc., 51 Franklin Street, Fifth +Floor, Boston, MA 02110-1301, USA. ]]) diff --git a/doc/Makefile.am b/doc/Makefile.am index f4e0718d6..712ece34a 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/doc/example-smob/image-type.c b/doc/example-smob/image-type.c index 68ecded9d..8dd998a50 100644 --- a/doc/example-smob/image-type.c +++ b/doc/example-smob/image-type.c @@ -2,20 +2,20 @@ * * Copyright (C) 1998, 2000, 2004, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3, or + * (at your option) any later version. * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301 USA + * You should have received a copy of the GNU Lesser General Public + * License along with this software; see the file COPYING.LESSER. If + * not, write to the Free Software Foundation, Inc., 51 Franklin + * Street, Fifth Floor, Boston, MA 02110-1301 USA */ #include diff --git a/doc/example-smob/myguile.c b/doc/example-smob/myguile.c index 9df3cf31b..30200dd03 100644 --- a/doc/example-smob/myguile.c +++ b/doc/example-smob/myguile.c @@ -2,20 +2,20 @@ * * Copyright (C) 1998, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3, or + * (at your option) any later version. * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301 USA + * You should have received a copy of the GNU Lesser General Public + * License along with this software; see the file COPYING.LESSER. If + * not, write to the Free Software Foundation, Inc., 51 Franklin + * Street, Fifth Floor, Boston, MA 02110-1301 USA */ #include diff --git a/doc/goops/Makefile.am b/doc/goops/Makefile.am index 03794c4de..49bfb29b9 100644 --- a/doc/goops/Makefile.am +++ b/doc/goops/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/doc/groupings.alist b/doc/groupings.alist index ed5bb1fca..a1748196f 100644 --- a/doc/groupings.alist +++ b/doc/groupings.alist @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Commentary: diff --git a/doc/maint/docstring.el b/doc/maint/docstring.el index 2b5639eb6..ef271930f 100644 --- a/doc/maint/docstring.el +++ b/doc/maint/docstring.el @@ -2,22 +2,22 @@ ;;; ;;; Copyright (C) 2001, 2004 Neil Jerram ;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. +;;; This file is not part of GUILE, but the same permissions apply. ;;; -;;; GNU Emacs is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. +;;; GUILE is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. ;;; -;;; GNU Emacs 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. +;;; GUILE 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 +;;; Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Emacs; see the file COPYING. If not, write to the -;;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;; Boston, MA 02110-1301, USA. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with GUILE; see the file COPYING.LESSER. If not, +;;; write to the Free Software Foundation, Inc., 51 Franklin Street, +;;; Fifth Floor, Boston, MA 02110-1301, USA. ;;; Commentary: diff --git a/doc/oldfmt.c b/doc/oldfmt.c index fc82ba92a..f60afeddd 100644 --- a/doc/oldfmt.c +++ b/doc/oldfmt.c @@ -1,18 +1,19 @@ /* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc. * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * License along with this software; see the file COPYING.LESSER. If + * not, write to the Free Software Foundation, Inc., 51 Franklin + * Street, Fifth Floor, Boston, MA 02110-1301 USA */ diff --git a/doc/r5rs/Makefile.am b/doc/r5rs/Makefile.am index 4af0c951a..c64e4ffb1 100644 --- a/doc/r5rs/Makefile.am +++ b/doc/r5rs/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 9d73e5da8..abf42edfe 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi index a31fe30f8..b0c4c1263 100644 --- a/doc/ref/intro.texi +++ b/doc/ref/intro.texi @@ -470,12 +470,12 @@ You can get the version number by invoking the command @example $ guile --version -Guile 1.4.1 -Copyright (c) 1995, 1996, 1997, 2000, 2006 Free Software Foundation -Guile may be distributed under the terms of the GNU General Public License; -certain other uses are permitted as well. For details, see the file -`COPYING', which is included in the Guile distribution. -There is no warranty, to the extent permitted by law. +Guile 1.9.0 +Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation +Guile may be distributed under the terms of the GNU Lesser General +Public Licence. For details, see the files `COPYING.LESSER' and +`COPYING', which are included in the Guile distribution. There is no +warranty, to the extent permitted by law. @end example @item diff --git a/doc/ref/preface.texi b/doc/ref/preface.texi index d6de77440..7fa85811b 100644 --- a/doc/ref/preface.texi +++ b/doc/ref/preface.texi @@ -159,12 +159,12 @@ person would want to do. @itemize @bullet @item The Guile library (libguile) and supporting files are published under -the terms of the GNU Lesser General Public License version 2.1. See -the file @file{COPYING.LIB}. +the terms of the GNU Lesser General Public License version 3 or later. +See the files @file{COPYING.LESSER} and @file{COPYING}. @item The Guile readline module is published under the terms of the GNU -General Public License version 2. See the file @file{COPYING}. +General Public License version 3 or later. See the file @file{COPYING}. @item The manual you're now reading is published under the terms of the GNU diff --git a/doc/tutorial/Makefile.am b/doc/tutorial/Makefile.am index f49220da7..d359c4fed 100644 --- a/doc/tutorial/Makefile.am +++ b/doc/tutorial/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/emacs/Makefile.am b/emacs/Makefile.am index ad7a5c939..e18f30bf1 100644 --- a/emacs/Makefile.am +++ b/emacs/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index b8a161b37..54c75a787 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -5,8 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later -;;;; version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/emacs/gds-server.el b/emacs/gds-server.el index 86defc07b..d4fe997c2 100644 --- a/emacs/gds-server.el +++ b/emacs/gds-server.el @@ -5,8 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later -;;;; version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/emacs/gds.el b/emacs/gds.el index 7a1486d8d..a9450d065 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -5,8 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later -;;;; version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/emacs/gud-guile.el b/emacs/gud-guile.el index bd1b0ff26..5d295268f 100644 --- a/emacs/gud-guile.el +++ b/emacs/gud-guile.el @@ -2,20 +2,20 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Author: Thien-Thi Nguyen ;;; Version: 1 diff --git a/emacs/guile-c.el b/emacs/guile-c.el index b23ddd30f..1ccfd4dbc 100644 --- a/emacs/guile-c.el +++ b/emacs/guile-c.el @@ -2,20 +2,20 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Commentary: diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm index 000d0cc2e..4d99002b6 100644 --- a/emacs/guile-emacs.scm +++ b/emacs/guile-emacs.scm @@ -2,20 +2,20 @@ ;; Copyright (C) 2001 Keisuke Nishida -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Code: diff --git a/emacs/guile-scheme.el b/emacs/guile-scheme.el index a6d8b1f19..5e112a0dc 100644 --- a/emacs/guile-scheme.el +++ b/emacs/guile-scheme.el @@ -2,20 +2,20 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Commentary: diff --git a/emacs/guile.el b/emacs/guile.el index e85c81c29..25a9b9b8e 100644 --- a/emacs/guile.el +++ b/emacs/guile.el @@ -2,20 +2,20 @@ ;; Copyright (C) 2001 Keisuke Nishida -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Code: diff --git a/emacs/multistring.el b/emacs/multistring.el index ca17a8469..df8419542 100644 --- a/emacs/multistring.el +++ b/emacs/multistring.el @@ -2,22 +2,20 @@ ;; Copyright (C) 2000, 2006 Free Software Foundation, Inc. -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Author: Mikael Djurfeldt diff --git a/emacs/patch.el b/emacs/patch.el index 6bcb0876f..2fd20f579 100644 --- a/emacs/patch.el +++ b/emacs/patch.el @@ -2,20 +2,20 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Author: Thien-Thi Nguyen ;;; Version: 1 diff --git a/emacs/ppexpand.el b/emacs/ppexpand.el index 7ec3b1c45..f6c18765c 100644 --- a/emacs/ppexpand.el +++ b/emacs/ppexpand.el @@ -2,22 +2,20 @@ ;; Copyright (C) 2000, 2006 Free Software Foundation, Inc. -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Author: Mikael Djurfeldt diff --git a/emacs/update-changelog.el b/emacs/update-changelog.el index e0c0a4b11..c8dfa93a2 100644 --- a/emacs/update-changelog.el +++ b/emacs/update-changelog.el @@ -2,20 +2,20 @@ ;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;;; 02111-1307 USA ;;; Commentary: diff --git a/examples/Makefile.am b/examples/Makefile.am index e514bd4a9..afe869dba 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA EXTRA_DIST = README ChangeLog-2008 check.test \ \ diff --git a/examples/box-dynamic-module/box.c b/examples/box-dynamic-module/box.c index 7d6e2ce5d..e180565eb 100644 --- a/examples/box-dynamic-module/box.c +++ b/examples/box-dynamic-module/box.c @@ -2,20 +2,20 @@ * * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3, or + * (at your option) any later version. * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301 USA + * You should have received a copy of the GNU Lesser General Public + * License along with this software; see the file COPYING.LESSER. If + * not, write to the Free Software Foundation, Inc., 51 Franklin + * Street, Fifth Floor, Boston, MA 02110-1301 USA */ /* Include all needed declarations. */ diff --git a/examples/box-dynamic/box.c b/examples/box-dynamic/box.c index bb9529650..e96c011ab 100644 --- a/examples/box-dynamic/box.c +++ b/examples/box-dynamic/box.c @@ -2,20 +2,20 @@ * * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3, or + * (at your option) any later version. * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301 USA + * You should have received a copy of the GNU Lesser General Public + * License along with this software; see the file COPYING.LESSER. If + * not, write to the Free Software Foundation, Inc., 51 Franklin + * Street, Fifth Floor, Boston, MA 02110-1301 USA */ /* Include all needed declarations. */ diff --git a/examples/box-module/box.c b/examples/box-module/box.c index b589b262f..b69377e38 100644 --- a/examples/box-module/box.c +++ b/examples/box-module/box.c @@ -2,20 +2,20 @@ * * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3, or + * (at your option) any later version. * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301 USA + * You should have received a copy of the GNU Lesser General Public + * License along with this software; see the file COPYING.LESSER. If + * not, write to the Free Software Foundation, Inc., 51 Franklin + * Street, Fifth Floor, Boston, MA 02110-1301 USA */ /* Include all needed declarations. */ diff --git a/examples/box/box.c b/examples/box/box.c index e36d650b3..0662c3d12 100644 --- a/examples/box/box.c +++ b/examples/box/box.c @@ -2,20 +2,20 @@ * * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3, or + * (at your option) any later version. * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301 USA + * You should have received a copy of the GNU Lesser General Public + * License along with this software; see the file COPYING.LESSER. If + * not, write to the Free Software Foundation, Inc., 51 Franklin + * Street, Fifth Floor, Boston, MA 02110-1301 USA */ /* Include all needed declarations. */ diff --git a/examples/compat/compat.h b/examples/compat/compat.h index 5ed11eff9..67f1b9bd0 100644 --- a/examples/compat/compat.h +++ b/examples/compat/compat.h @@ -5,9 +5,9 @@ /* Copyright (C) 2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -16,7 +16,8 @@ * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/gc-benchmarks/gc-profile.scm b/gc-benchmarks/gc-profile.scm index 002bfc595..3365832a0 100755 --- a/gc-benchmarks/gc-profile.scm +++ b/gc-benchmarks/gc-profile.scm @@ -5,20 +5,20 @@ exec ${GUILE-guile} --no-debug -q -l "$0" \ !# ;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +;;; GNU Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;; Boston, MA 02110-1301 USA +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (ice-9 format) (ice-9 rdelim) diff --git a/gc-benchmarks/run-benchmark.scm b/gc-benchmarks/run-benchmark.scm index a50fb48c2..915143f1d 100755 --- a/gc-benchmarks/run-benchmark.scm +++ b/gc-benchmarks/run-benchmark.scm @@ -6,20 +6,20 @@ exec ${GUILE-guile} -q -l "$0" \ !# ;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3, or +;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +;;; GNU Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;; Boston, MA 02110-1301 USA +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (ice-9 rdelim) (ice-9 popen) diff --git a/lang/Makefile.am b/lang/Makefile.am index 97c440d75..adbe4d43c 100644 --- a/lang/Makefile.am +++ b/lang/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/libguile.h b/libguile.h index 6a6d232f9..7b5649b8f 100644 --- a/libguile.h +++ b/libguile.h @@ -4,18 +4,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 46bc998af..8c9c598bf 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/libguile/__scm.h b/libguile/__scm.h index 07d7b4d3d..29b371d16 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/_scm.h b/libguile/_scm.h index e40f29bb0..1a0a98603 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/alist.c b/libguile/alist.c index ca55b082c..919bd224e 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/alist.h b/libguile/alist.h index 76cccba2b..77c565608 100644 --- a/libguile/alist.h +++ b/libguile/alist.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/arbiters.c b/libguile/arbiters.c index a341ed6db..cc68c85c4 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/arbiters.h b/libguile/arbiters.h index 7a7dfd3fa..214e92a34 100644 --- a/libguile/arbiters.h +++ b/libguile/arbiters.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/async.c b/libguile/async.c index 4dc5ea475..d3fb0121b 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/async.h b/libguile/async.h index c01bde031..427d9b4c8 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/backtrace.c b/libguile/backtrace.c index a8afcdf34..83579055f 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -2,18 +2,19 @@ * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/backtrace.h b/libguile/backtrace.h index e11cb85de..c0651667c 100644 --- a/libguile/backtrace.h +++ b/libguile/backtrace.h @@ -6,18 +6,19 @@ /* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/boolean.c b/libguile/boolean.c index 4b06e04e2..d79bf7979 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/boolean.h b/libguile/boolean.h index 1388c2fdc..5a8379713 100644 --- a/libguile/boolean.h +++ b/libguile/boolean.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 1de4db065..0846d9120 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -1,18 +1,19 @@ /* Copyright (C) 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index b01116ce6..4b1b60660 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -4,18 +4,19 @@ /* Copyright (C) 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/chars.c b/libguile/chars.c index 909e11d57..ca47c0d82 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/chars.h b/libguile/chars.h index 97c611af4..88dde4bd9 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/continuations.c b/libguile/continuations.c index dc1456985..f85647684 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/continuations.h b/libguile/continuations.h index e5fd91f2e..08eec8f54 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/convert.c b/libguile/convert.c index 700deaa87..d87d72464 100644 --- a/libguile/convert.c +++ b/libguile/convert.c @@ -1,18 +1,19 @@ /* Copyright (C) 2002, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/convert.h b/libguile/convert.h index f834a6b1d..6ce7c2274 100644 --- a/libguile/convert.h +++ b/libguile/convert.h @@ -6,18 +6,19 @@ /* Copyright (C) 2002, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index 4d04df5db..fa3612de2 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -1,18 +1,19 @@ /* Copyright (C) 2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/debug-malloc.h b/libguile/debug-malloc.h index 1aa5221c6..7830adbac 100644 --- a/libguile/debug-malloc.h +++ b/libguile/debug-malloc.h @@ -6,18 +6,19 @@ /* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/debug.c b/libguile/debug.c index 5042fbb73..6e148ab32 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -2,18 +2,19 @@ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/debug.h b/libguile/debug.h index 4d16fd83a..20febdb71 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -7,18 +7,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 979de84e1..57a2f0657 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -5,18 +5,19 @@ /* Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 9a0862c3e..5b443c761 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -8,18 +8,19 @@ /* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #include "libguile/__scm.h" diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 780e246f0..af8b93610 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ @@ -171,4 +172,5 @@ scm_init_deprecation () /* Local Variables: c-file-style: "gnu" - End: */ + End: + */ diff --git a/libguile/deprecation.h b/libguile/deprecation.h index 9752d9b16..06027c694 100644 --- a/libguile/deprecation.h +++ b/libguile/deprecation.h @@ -6,18 +6,19 @@ /* Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/discouraged.c b/libguile/discouraged.c index 9efd92a00..357cac875 100644 --- a/libguile/discouraged.c +++ b/libguile/discouraged.c @@ -5,18 +5,19 @@ /* Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/discouraged.h b/libguile/discouraged.h index 6e537bf1e..1be05f0bc 100644 --- a/libguile/discouraged.h +++ b/libguile/discouraged.h @@ -16,18 +16,19 @@ /* Copyright (C) 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #include "libguile/__scm.h" diff --git a/libguile/dynl.c b/libguile/dynl.c index b2f0fb9ed..9ac4d4f53 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -4,18 +4,19 @@ * 2003, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/dynl.h b/libguile/dynl.h index 72dc92ea4..eb318ae98 100644 --- a/libguile/dynl.h +++ b/libguile/dynl.h @@ -6,18 +6,19 @@ /* Copyright (C) 1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 999ba23e0..a45c5b5a3 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/dynwind.h b/libguile/dynwind.h index dd39dae5a..b178bc429 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/environments.c b/libguile/environments.c index b81527eef..fae936a6e 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -1,18 +1,19 @@ /* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/environments.h b/libguile/environments.h index 10d42a704..5680662b5 100644 --- a/libguile/environments.h +++ b/libguile/environments.h @@ -6,18 +6,19 @@ /* Copyright (C) 1999,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/eq.c b/libguile/eq.c index b54a7043a..255c381a0 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/eq.h b/libguile/eq.h index af6959fe8..1aeb1c496 100644 --- a/libguile/eq.h +++ b/libguile/eq.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/error.c b/libguile/error.c index e18db9e82..eb513a74a 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/error.h b/libguile/error.h index 042fb4d14..c777a7f44 100644 --- a/libguile/error.h +++ b/libguile/error.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/eval.c b/libguile/eval.c index 574ab4740..a2e11eeaa 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2,18 +2,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/eval.h b/libguile/eval.h index b017f2e02..0d4223837 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -7,18 +7,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 573a7b5fb..37fb7c787 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -4,18 +4,19 @@ * Copyright (C) 2002, 03, 04, 05, 06, 07, 09 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #undef RETURN diff --git a/libguile/evalext.c b/libguile/evalext.c index 5ca78066d..56f74e213 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,18 +1,19 @@ /* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/evalext.h b/libguile/evalext.h index a6a4a9fdc..fc3f1e617 100644 --- a/libguile/evalext.h +++ b/libguile/evalext.h @@ -6,18 +6,19 @@ /* Copyright (C) 1998,1999,2000, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/extensions.c b/libguile/extensions.c index 29cb58cbe..54351dd9c 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/extensions.h b/libguile/extensions.h index 260567e51..765f9bee1 100644 --- a/libguile/extensions.h +++ b/libguile/extensions.h @@ -6,18 +6,19 @@ /* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/feature.c b/libguile/feature.c index 8283cd6f5..9ef4b658e 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/feature.h b/libguile/feature.h index 8c6371e94..d373bc773 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/filesys.c b/libguile/filesys.c index 4799dd4b1..b49d488f1 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,18 +1,19 @@ /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/filesys.h b/libguile/filesys.h index cf0a6acf2..3e5c83e76 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/fluids.c b/libguile/fluids.c index 4311a4967..bcd04c43d 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -1,18 +1,19 @@ /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/fluids.h b/libguile/fluids.h index c48a8c332..cf424fa6e 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -6,18 +6,19 @@ /* Copyright (C) 1996,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/fports.c b/libguile/fports.c index fd825c852..de788c928 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/fports.h b/libguile/fports.h index c737b1eaa..2687504bb 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/frames.c b/libguile/frames.c index c08fd3134..76552f54f 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/libguile/frames.h b/libguile/frames.h index d74476ac8..99623fb16 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef _SCM_FRAMES_H_ diff --git a/libguile/futures.c b/libguile/futures.c index 5b1a3fb7e..ad70f7fab 100644 --- a/libguile/futures.c +++ b/libguile/futures.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/futures.h b/libguile/futures.h index 95916f33b..5d7712e1a 100644 --- a/libguile/futures.h +++ b/libguile/futures.h @@ -6,18 +6,19 @@ /* Copyright (C) 2002, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gc-card.c b/libguile/gc-card.c index 0629da078..85520f8e4 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c index 4dd77aa0d..54a10e7b2 100644 --- a/libguile/gc-freelist.c +++ b/libguile/gc-freelist.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index cdc985e37..d6973d3ac 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c index 88bea8052..84714507b 100644 --- a/libguile/gc-mark.c +++ b/libguile/gc-mark.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gc-segment-table.c b/libguile/gc-segment-table.c index 3e92c8c5c..75d109c85 100644 --- a/libguile/gc-segment-table.c +++ b/libguile/gc-segment-table.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/gc-segment.c b/libguile/gc-segment.c index 4f98cbcde..7a937e6de 100644 --- a/libguile/gc-segment.c +++ b/libguile/gc-segment.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/gc.c b/libguile/gc.c index ce8c8af73..b7a3bf091 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* #define DEBUGINFO */ diff --git a/libguile/gc.h b/libguile/gc.h index 58ac77241..8db76e310 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h index 5be4d0786..2278fc2c2 100644 --- a/libguile/gdb_interface.h +++ b/libguile/gdb_interface.h @@ -5,19 +5,20 @@ /* Simple interpreter interface for GDB, the GNU debugger. Copyright (C) 1996, 2000, 2001, 2006 Free Software Foundation - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library 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 - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA The author can be reached at djurfeldt@nada.kth.se Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c index b9c25c9cd..0f74ce116 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -3,18 +3,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/gdbint.h b/libguile/gdbint.h index 64b9559c9..d7c6cf31e 100644 --- a/libguile/gdbint.h +++ b/libguile/gdbint.h @@ -6,18 +6,19 @@ /* Copyright (C) 1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gettext.c b/libguile/gettext.c index e74f9f351..2ae3ae5e4 100644 --- a/libguile/gettext.c +++ b/libguile/gettext.c @@ -1,18 +1,19 @@ /* Copyright (C) 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gettext.h b/libguile/gettext.h index 8a13307d5..d4576bd6a 100644 --- a/libguile/gettext.h +++ b/libguile/gettext.h @@ -6,18 +6,19 @@ /* Copyright (C) 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #include "libguile/__scm.h" diff --git a/libguile/goops.c b/libguile/goops.c index b623212ad..f552b9e29 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2,18 +2,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/goops.h b/libguile/goops.h index d43d73642..8d138237a 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -6,18 +6,19 @@ /* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 5e5b4c10e..0fee71a2c 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 65680a02c..298181b15 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/guardians.c b/libguile/guardians.c index e2af7840d..f7bbb4b02 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -1,18 +1,19 @@ /* Copyright (C) 1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/guardians.h b/libguile/guardians.h index 295092edf..a23026d6c 100644 --- a/libguile/guardians.h +++ b/libguile/guardians.h @@ -6,18 +6,19 @@ /* Copyright (C) 1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/guile-doc-snarf.in b/libguile/guile-doc-snarf.in index 49be29185..a787d5a46 100755 --- a/libguile/guile-doc-snarf.in +++ b/libguile/guile-doc-snarf.in @@ -4,19 +4,19 @@ # Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2, or (at your option) -# any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -# Boston, MA 02110-1301 USA +# it under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or (at +# your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this software; see the file COPYING.LESSER. If +# not, write to the Free Software Foundation, Inc., 51 Franklin +# Street, Fifth Floor, Boston, MA 02110-1301 USA fullfilename=$1 diff --git a/libguile/guile-func-name-check.in b/libguile/guile-func-name-check.in index 7f0114e0b..8b4924e91 100644 --- a/libguile/guile-func-name-check.in +++ b/libguile/guile-func-name-check.in @@ -3,19 +3,19 @@ # Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2, or (at your option) -# any later version. +# it under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or (at +# your option) any later version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. # -# You should have received a copy of the GNU General Public License -# along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -# Boston, MA 02110-1301 USA +# You should have received a copy of the GNU Lesser General Public +# License along with this software; see the file COPYING.LESSER. If +# not, write to the Free Software Foundation, Inc., 51 Franklin +# Street, Fifth Floor, Boston, MA 02110-1301 USA # # Written by Greg J. Badros, # 11-Jan-2000 diff --git a/libguile/guile-snarf-docs.in b/libguile/guile-snarf-docs.in index 9cba3dc56..1e57f2624 100755 --- a/libguile/guile-snarf-docs.in +++ b/libguile/guile-snarf-docs.in @@ -4,19 +4,19 @@ # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2, or (at your option) -# any later version. +# it under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or (at +# your option) any later version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. # -# You should have received a copy of the GNU General Public License -# along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -# Boston, MA 02110-1301 USA +# You should have received a copy of the GNU Lesser General Public +# License along with this software; see the file COPYING.LESSER. If +# not, write to the Free Software Foundation, Inc., 51 Franklin +# Street, Fifth Floor, Boston, MA 02110-1301 USA bindir=`dirname $0` diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in index be3b1236d..8a720a002 100644 --- a/libguile/guile-snarf.awk.in +++ b/libguile/guile-snarf.awk.in @@ -1,19 +1,19 @@ # Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2, or (at your option) -# any later version. +# it under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or (at +# your option) any later version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. # -# You should have received a copy of the GNU General Public License -# along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -# Boston, MA 02110-1301 USA +# You should have received a copy of the GNU Lesser General Public +# License along with this software; see the file COPYING.LESSER. If +# not, write to the Free Software Foundation, Inc., 51 Franklin +# Street, Fifth Floor, Boston, MA 02110-1301 USA # # Written by Greg J. Badros, # 12-Dec-1999 diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index 617bad822..6a72dd5d5 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -4,19 +4,19 @@ # Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2, or (at your option) -# any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -# Boston, MA 02110-1301 USA +# it under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or (at +# your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this software; see the file COPYING.LESSER. If +# not, write to the Free Software Foundation, Inc., 51 Franklin +# Street, Fifth Floor, Boston, MA 02110-1301 USA # Commentary: diff --git a/libguile/guile.c b/libguile/guile.c index c8341c24f..6da547b75 100644 --- a/libguile/guile.c +++ b/libguile/guile.c @@ -1,18 +1,19 @@ /* Copyright (C) 1996,1997,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This is the 'main' function for the `guile' executable. It is not diff --git a/libguile/hash.c b/libguile/hash.c index 7a49de6b4..d2fe17706 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/hash.h b/libguile/hash.h index bbf9b2562..789595b42 100644 --- a/libguile/hash.h +++ b/libguile/hash.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 79e635fc4..e3a6c431c 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 4220b8668..13100f0a4 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/hooks.c b/libguile/hooks.c index 5ca8580df..d6b8981d5 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/hooks.h b/libguile/hooks.h index 49ea55350..15b57fabb 100644 --- a/libguile/hooks.h +++ b/libguile/hooks.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/i18n.c b/libguile/i18n.c index 8cacf5f8d..7dcfa5a1e 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,18 +1,19 @@ /* Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/i18n.h b/libguile/i18n.h index 57f1654a3..df2970b4e 100644 --- a/libguile/i18n.h +++ b/libguile/i18n.h @@ -6,18 +6,19 @@ /* Copyright (C) 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #include "libguile/__scm.h" diff --git a/libguile/init.c b/libguile/init.c index c72aeff4c..2b500ac3a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/init.h b/libguile/init.h index 3ae27d8cc..7cfae76d5 100644 --- a/libguile/init.h +++ b/libguile/init.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/inline.c b/libguile/inline.c index a0c25003f..79728ff13 100644 --- a/libguile/inline.c +++ b/libguile/inline.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/inline.h b/libguile/inline.h index 6fbde7910..cb908581d 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -6,18 +6,19 @@ /* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This file is for inline functions. On platforms that don't support diff --git a/libguile/instructions.c b/libguile/instructions.c index f0f52e422..a67684e71 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/libguile/instructions.h b/libguile/instructions.h index f4f45b371..c9fe6e995 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef _SCM_INSTRUCTIONS_H_ diff --git a/libguile/ioext.c b/libguile/ioext.c index b542664eb..6b0c9b88c 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/ioext.h b/libguile/ioext.h index 18289ea3c..1b7b93aaf 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/iselect.h b/libguile/iselect.h index 5a4b30da6..760d959d8 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -6,18 +6,19 @@ /* Copyright (C) 1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/keywords.c b/libguile/keywords.c index 0f9f13e9b..ee4c3ff42 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/keywords.h b/libguile/keywords.h index a80e31bff..bfffe5923 100644 --- a/libguile/keywords.h +++ b/libguile/keywords.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/lang.c b/libguile/lang.c index 7f3986cec..85da68034 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -1,18 +1,19 @@ /* Copyright (C) 1999, 2000, 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/lang.h b/libguile/lang.h index 991e9ca76..47128de57 100644 --- a/libguile/lang.h +++ b/libguile/lang.h @@ -6,18 +6,19 @@ /* Copyright (C) 1998, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/list.c b/libguile/list.c index 07b96f5a7..70f527755 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -2,18 +2,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/list.h b/libguile/list.h index 733432d76..427dcb84d 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -7,18 +7,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/load.c b/libguile/load.c index 9656359e5..d8139e657 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/load.h b/libguile/load.h index 021987329..d5bc1b066 100644 --- a/libguile/load.h +++ b/libguile/load.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/locale-categories.h b/libguile/locale-categories.h index cbe9684a3..26b030dc5 100644 --- a/libguile/locale-categories.h +++ b/libguile/locale-categories.h @@ -1,18 +1,19 @@ /* Copyright (C) 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* A list of all available locale categories, not including `ALL'. */ diff --git a/libguile/macros.c b/libguile/macros.c index ca3e83e29..a6a4c3eb6 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/macros.h b/libguile/macros.h index 5e3d64a55..8ff41c4a4 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -6,18 +6,19 @@ /* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/mallocs.c b/libguile/mallocs.c index c11a51fac..296b3126b 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -2,18 +2,19 @@ * Copyright (C) 1995,1997,1998,2000,2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/mallocs.h b/libguile/mallocs.h index f711ddb94..9c797e9f8 100644 --- a/libguile/mallocs.h +++ b/libguile/mallocs.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/modules.c b/libguile/modules.c index 689510ce6..ecd136d2b 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -1,18 +1,19 @@ /* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/modules.h b/libguile/modules.h index 3cd090476..8108ac3e1 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -6,18 +6,19 @@ /* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/net_db.c b/libguile/net_db.c index af6e3d5f4..4307091f7 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -2,18 +2,19 @@ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/net_db.h b/libguile/net_db.h index df1f03067..4b6327f27 100644 --- a/libguile/net_db.h +++ b/libguile/net_db.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/null-threads.c b/libguile/null-threads.c index 814017564..28eff2c61 100644 --- a/libguile/null-threads.c +++ b/libguile/null-threads.c @@ -1,18 +1,19 @@ /* Copyright (C) 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/null-threads.h b/libguile/null-threads.h index 5a61dbf50..ec83ab798 100644 --- a/libguile/null-threads.h +++ b/libguile/null-threads.h @@ -6,18 +6,19 @@ /* Copyright (C) 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 37435b50b..83b3f7cb1 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5,18 +5,19 @@ * * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/numbers.h b/libguile/numbers.h index e139dac7b..5bad4478b 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 6a0a11b29..f8da2d51d 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/libguile/objcodes.h b/libguile/objcodes.h index acd43a600..21e4add89 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef _SCM_OBJCODES_H_ diff --git a/libguile/objects.c b/libguile/objects.c index e68ed37ef..e82fb9d51 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/objects.h b/libguile/objects.h index 9b2a0ed5a..914a7ea74 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -6,18 +6,19 @@ /* Copyright (C) 1996,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/objprop.c b/libguile/objprop.c index 8e9486f54..6dd1da631 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/objprop.h b/libguile/objprop.h index 7e5365a74..f9a2e945d 100644 --- a/libguile/objprop.h +++ b/libguile/objprop.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/options.c b/libguile/options.c index cc3d452e6..ee7001a8c 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/options.h b/libguile/options.h index 4facdce01..8ea960b3c 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/pairs.c b/libguile/pairs.c index cb2d64260..aaaeb110f 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/pairs.h b/libguile/pairs.h index 61af24efe..a6d44d289 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/ports.c b/libguile/ports.c index 1f49708c8..248e0a49c 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/ports.h b/libguile/ports.h index cb9d9d2d5..64a0a89c7 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/posix.c b/libguile/posix.c index 5e6f05fb7..dafc5e996 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/posix.h b/libguile/posix.h index 6d282e0bf..4d057643c 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/print.c b/libguile/print.c index fa4cb1e28..3992bc45b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/print.h b/libguile/print.h index 8974a7554..d817a6fc3 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/private-gc.h b/libguile/private-gc.h index 125ef3a23..ac22de58b 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -4,18 +4,19 @@ * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef PRIVATE_GC diff --git a/libguile/private-options.h b/libguile/private-options.h index eeaf0c17b..ffb699bee 100644 --- a/libguile/private-options.h +++ b/libguile/private-options.h @@ -7,18 +7,19 @@ * Copyright (C) 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef PRIVATE_OPTIONS diff --git a/libguile/procprop.c b/libguile/procprop.c index db16834c5..df96eaad4 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/procprop.h b/libguile/procprop.h index bf27dba0a..04cd38442 100644 --- a/libguile/procprop.h +++ b/libguile/procprop.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/procs.c b/libguile/procs.c index b3a0d3215..3eb9c247a 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/procs.h b/libguile/procs.h index b7ab61497..84e0c6978 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/programs.c b/libguile/programs.c index 68e0b8541..892b6770f 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/libguile/programs.h b/libguile/programs.h index ae819ef85..16a15500f 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef _SCM_PROGRAMS_H_ diff --git a/libguile/properties.c b/libguile/properties.c index 321dc9ec4..60ff2ff65 100644 --- a/libguile/properties.c +++ b/libguile/properties.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/properties.h b/libguile/properties.h index 54feb01d9..efeaf3a59 100644 --- a/libguile/properties.h +++ b/libguile/properties.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index 608a00b85..d5d838b4a 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -6,18 +6,19 @@ /* Copyright (C) 2002, 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/putenv.c b/libguile/putenv.c index 0ff33592a..cdc05dd7e 100644 --- a/libguile/putenv.c +++ b/libguile/putenv.c @@ -1,18 +1,19 @@ /* Copyright (C) 1991, 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc. * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index d2c02ff40..f10afe6d5 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,18 +1,19 @@ /* Copyright (C) 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h index e29d96200..5e1707a88 100644 --- a/libguile/r6rs-ports.h +++ b/libguile/r6rs-ports.h @@ -4,18 +4,19 @@ /* Copyright (C) 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/ramap.c b/libguile/ramap.c index 1bc4fdd38..e141c18b7 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1,18 +1,19 @@ /* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/ramap.h b/libguile/ramap.h index 9d870389a..d6cb19166 100644 --- a/libguile/ramap.h +++ b/libguile/ramap.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/random.c b/libguile/random.c index 8d2ff03b5..d7a1ffb11 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,17 +1,18 @@ /* Copyright (C) 1999,2000,2001, 2003, 2005, 2006 Free Software Foundation, Inc. * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/random.h b/libguile/random.h index ae44092ab..6cf404f8d 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -6,18 +6,19 @@ /* Copyright (C) 1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/rdelim.c b/libguile/rdelim.c index c9cc0164d..04a0944f4 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/rdelim.h b/libguile/rdelim.h index 17efb4fe5..2e401e4fe 100644 --- a/libguile/rdelim.h +++ b/libguile/rdelim.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/read.c b/libguile/read.c index 3493ba03f..6fafc43ba 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2,18 +2,19 @@ * Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/read.h b/libguile/read.h index 4253622da..20d3f4bf7 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 008917a86..a95cfb82e 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -1,18 +1,19 @@ /* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/regex-posix.h b/libguile/regex-posix.h index 2863b0562..8060fe3b7 100644 --- a/libguile/regex-posix.h +++ b/libguile/regex-posix.h @@ -6,18 +6,19 @@ /* Copyright (C) 1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/root.c b/libguile/root.c index 0d4ab29e5..83960b5d8 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/root.h b/libguile/root.h index 11f6b4f3a..cbf710d90 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -6,18 +6,19 @@ /* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/rw.c b/libguile/rw.c index 3e814740a..f6d314275 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/rw.h b/libguile/rw.h index b526051fc..d54f1b3ef 100644 --- a/libguile/rw.h +++ b/libguile/rw.h @@ -6,18 +6,19 @@ /* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/scmconfig.h.top b/libguile/scmconfig.h.top index dfc7ba99c..b84660b6c 100644 --- a/libguile/scmconfig.h.top +++ b/libguile/scmconfig.h.top @@ -1,16 +1,17 @@ /* Copyright (C) 2003, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index eb7cec67b..258710e51 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h index bcbf825d4..fce372849 100644 --- a/libguile/scmsigs.h +++ b/libguile/scmsigs.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000, 2002, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/script.c b/libguile/script.c index c61e85a8d..8c4e8ef55 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,17 +1,18 @@ /* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* "script.c" argv tricks for `#!' scripts. diff --git a/libguile/script.h b/libguile/script.h index 6c02f8d8d..7e3828aa3 100644 --- a/libguile/script.h +++ b/libguile/script.h @@ -6,18 +6,19 @@ /* Copyright (C) 1997,1998,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/simpos.c b/libguile/simpos.c index 402e4dc88..60a592235 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -2,18 +2,19 @@ * Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/simpos.h b/libguile/simpos.h index 6df8bb1d2..b391a28d8 100644 --- a/libguile/simpos.h +++ b/libguile/simpos.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/smob.c b/libguile/smob.c index 899197901..2d7a9701e 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/smob.h b/libguile/smob.h index 7aab3e74f..b712f8692 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/snarf.h b/libguile/snarf.h index 5c2f18774..03a3edd47 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/socket.c b/libguile/socket.c index f34b6d49d..553a1a185 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1,18 +1,19 @@ /* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/socket.h b/libguile/socket.h index 133dbf7c6..fcddd780d 100644 --- a/libguile/socket.h +++ b/libguile/socket.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/sort.c b/libguile/sort.c index 2a7317663..644526eac 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -1,17 +1,18 @@ /* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/sort.h b/libguile/sort.h index 51f292a5c..3ae86c2f3 100644 --- a/libguile/sort.h +++ b/libguile/sort.h @@ -6,18 +6,19 @@ /* Copyright (C) 1999,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 055ae32d3..efa0b7f30 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008 Free Software Foundation * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/srcprop.h b/libguile/srcprop.h index a467aa34e..2a27e0409 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index c8ca78027..f3863d355 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/srfi-13.h b/libguile/srfi-13.h index f8221ddc6..478a55d64 100644 --- a/libguile/srfi-13.h +++ b/libguile/srfi-13.h @@ -6,18 +6,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index 908e0c8ff..3b4a5ff7f 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h index ea8027aac..54e0d329c 100644 --- a/libguile/srfi-14.h +++ b/libguile/srfi-14.h @@ -6,18 +6,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index b0e052ac3..ac31fdc10 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 3c340d91e..a1a9bafc0 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -5,18 +5,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/stackchk.c b/libguile/stackchk.c index a53e67629..b14a71259 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/stackchk.h b/libguile/stackchk.h index 8681f5d46..6aa0fec18 100644 --- a/libguile/stackchk.h +++ b/libguile/stackchk.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/stacks.c b/libguile/stacks.c index 69fb3406a..45566cafa 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -2,18 +2,19 @@ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/stacks.h b/libguile/stacks.h index 53633bc14..20735eff5 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/stime.c b/libguile/stime.c index 5384783e3..a6843377b 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/stime.h b/libguile/stime.h index c64c60ea9..8b70cee62 100644 --- a/libguile/stime.h +++ b/libguile/stime.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/strerror.c b/libguile/strerror.c index c2f20f0c2..0e0e94ee8 100644 --- a/libguile/strerror.c +++ b/libguile/strerror.c @@ -1,19 +1,20 @@ /* Turning errno values into English error messages. Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 2000, 2001, 2006 Free Software Foundation, Inc. - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library 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 - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public License + as published by the Free Software Foundation; either version 3 of + the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + 02110-1301 USA */ char * diff --git a/libguile/strings.c b/libguile/strings.c index 012e08b6e..4e21f3e28 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/strings.h b/libguile/strings.h index ca5f52cd2..9e028d82e 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/strorder.c b/libguile/strorder.c index d3ccfcb06..e0a218389 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/strorder.h b/libguile/strorder.h index 17118634e..2c004e48a 100644 --- a/libguile/strorder.h +++ b/libguile/strorder.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/strports.c b/libguile/strports.c index bc3fd7014..3f8a22e7d 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/strports.h b/libguile/strports.h index 58ca71f57..3129c03e2 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/struct.c b/libguile/struct.c index cae0f31d0..9cb165e2f 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,18 +1,19 @@ /* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/struct.h b/libguile/struct.h index 10c0d65c3..d53e59d95 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/symbols.c b/libguile/symbols.c index e208e5a6a..c0ba2a8b4 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/symbols.h b/libguile/symbols.h index c2dc18363..e4bc33391 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/tags.h b/libguile/tags.h index 2f30369d9..329453341 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -7,18 +7,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/threads.c b/libguile/threads.c index d63c6197e..9589336c1 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/threads.h b/libguile/threads.h index 5542ac30e..32b0ea66a 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -6,18 +6,19 @@ /* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/throw.c b/libguile/throw.c index e0dda27cf..b48bea1d1 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/throw.h b/libguile/throw.h index 3cd557285..1ed6ba6b1 100644 --- a/libguile/throw.h +++ b/libguile/throw.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/unif.c b/libguile/unif.c index 4013f29b8..d393e8a1a 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/unif.h b/libguile/unif.h index 1d01f807d..91d26c861 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/validate.h b/libguile/validate.h index c362c02f3..b48bec758 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -6,18 +6,19 @@ /* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* Written by Greg J. Badros , Dec-1999 */ diff --git a/libguile/values.c b/libguile/values.c index e766edba1..81fdcf851 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -1,18 +1,19 @@ /* Copyright (C) 2000, 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/values.h b/libguile/values.h index f05ce9f8f..0750aecdc 100644 --- a/libguile/values.h +++ b/libguile/values.h @@ -6,18 +6,19 @@ /* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/variable.c b/libguile/variable.c index 6c39b30ac..a97444c0b 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/variable.h b/libguile/variable.h index 3f6398b9c..8faced4ec 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/vectors.c b/libguile/vectors.c index eeb856995..ae0fc319f 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/vectors.h b/libguile/vectors.h index 28a576c5c..902e15a63 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/version.c b/libguile/version.c index 99c649b00..3d5dc1976 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996, 1999, 2000, 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/version.h.in b/libguile/version.h.in index b565efd96..394bbdb86 100644 --- a/libguile/version.h.in +++ b/libguile/version.h.in @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h index 587766a67..7ba1a93ba 100644 --- a/libguile/vm-bootstrap.h +++ b/libguile/vm-bootstrap.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef _SCM_VM_BOOTSTRAP_H_ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 34764c659..978d4079b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This file is included in vm.c multiple times */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 8c919f630..c98dfdd78 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This file is included in vm_engine.c */ diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h index 02dfbc4d0..787223d07 100644 --- a/libguile/vm-expand.h +++ b/libguile/vm-expand.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef VM_LABEL diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index e5bb35e6e..86d0fc443 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* FIXME! Need to check that the fetch is within the current program */ diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 3742135a6..02139c073 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This file is included in vm_engine.c */ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 6b130e7e1..d55d6e218 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/vm.c b/libguile/vm.c index f708b2108..514ff8d4e 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/libguile/vm.h b/libguile/vm.h index 2f2b617ce..b079c7aa0 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -1,18 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef _SCM_VM_H_ diff --git a/libguile/vports.c b/libguile/vports.c index 564f0e73f..cea11c61d 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/vports.h b/libguile/vports.h index 365303bc1..ae64dd438 100644 --- a/libguile/vports.h +++ b/libguile/vports.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/weaks.c b/libguile/weaks.c index 1d58b5dd3..64aa536b8 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/weaks.h b/libguile/weaks.h index 34c44a97a..46afd830c 100644 --- a/libguile/weaks.h +++ b/libguile/weaks.h @@ -6,18 +6,19 @@ /* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/win32-dirent.c b/libguile/win32-dirent.c index cd7e8bac6..de170c70b 100644 --- a/libguile/win32-dirent.c +++ b/libguile/win32-dirent.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/win32-dirent.h b/libguile/win32-dirent.h index 30bc118ea..578db49b9 100644 --- a/libguile/win32-dirent.h +++ b/libguile/win32-dirent.h @@ -6,18 +6,19 @@ /* Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* Directory stream type. diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c index 54f80a764..e845d886a 100644 --- a/libguile/win32-socket.c +++ b/libguile/win32-socket.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/libguile/win32-socket.h b/libguile/win32-socket.h index 51856051d..4ab9b942a 100644 --- a/libguile/win32-socket.h +++ b/libguile/win32-socket.h @@ -6,18 +6,19 @@ /* Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #include "libguile/__scm.h" diff --git a/libguile/win32-uname.c b/libguile/win32-uname.c index d4d737f49..5349f1410 100644 --- a/libguile/win32-uname.c +++ b/libguile/win32-uname.c @@ -1,18 +1,19 @@ /* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/libguile/win32-uname.h b/libguile/win32-uname.h index 8593dc7d9..4b7498133 100644 --- a/libguile/win32-uname.h +++ b/libguile/win32-uname.h @@ -6,18 +6,19 @@ /* Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #define _UTSNAME_LENGTH 65 diff --git a/meta/Makefile.am b/meta/Makefile.am index 7f655e535..e047038aa 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -5,20 +5,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA bin_SCRIPTS=guile-config guile-tools EXTRA_DIST= $(bin_SCRIPTS) \ diff --git a/meta/gdb-uninstalled-guile.in b/meta/gdb-uninstalled-guile.in index aa33e0799..1151dbc3a 100644 --- a/meta/gdb-uninstalled-guile.in +++ b/meta/gdb-uninstalled-guile.in @@ -4,20 +4,20 @@ # # This file is part of GUILE. # -# GUILE is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as -# published by the Free Software Foundation; either version 2, or +# GUILE is free software; you can redistribute it and/or modify it +# under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or # (at your option) any later version. # # GUILE 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. +# GNU Lesser General Public License for more details. # -# You should have received a copy of the GNU General Public -# License along with GUILE; see the file COPYING. If not, write -# to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -# Floor, Boston, MA 02110-1301 USA +# You should have received a copy of the GNU Lesser General Public +# License along with GUILE; see the file COPYING.LESSER. If not, +# write to the Free Software Foundation, Inc., 51 Franklin Street, +# Fifth Floor, Boston, MA 02110-1301 USA # Commentary: diff --git a/meta/guile-config b/meta/guile-config index 815414a38..7304ae2a8 100755 --- a/meta/guile-config +++ b/meta/guile-config @@ -9,7 +9,7 @@ exec guile -e main -s $0 "$@" ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -17,8 +17,9 @@ exec guile -e main -s $0 "$@" ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA ;;; This script has been deprecated. Just use pkg-config. diff --git a/meta/guile-tools b/meta/guile-tools index 6fb93c13a..3024726f7 100755 --- a/meta/guile-tools +++ b/meta/guile-tools @@ -11,7 +11,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,8 +19,9 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA (define-module (guile-tools)) diff --git a/meta/guile.in b/meta/guile.in index d7bc893e6..ab1fe3706 100644 --- a/meta/guile.in +++ b/meta/guile.in @@ -4,20 +4,20 @@ # # This file is part of GUILE. # -# GUILE is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as -# published by the Free Software Foundation; either version 2, or +# GUILE is free software; you can redistribute it and/or modify it +# under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or # (at your option) any later version. # # GUILE 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. +# GNU Lesser General Public License for more details. # -# You should have received a copy of the GNU General Public -# License along with GUILE; see the file COPYING. If not, write -# to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -# Floor, Boston, MA 02110-1301 USA +# You should have received a copy of the GNU Lesser General Public +# License along with GUILE; see the file COPYING.LESSER. If not, +# write to the Free Software Foundation, Inc., 51 Franklin Street, +# Fifth Floor, Boston, MA 02110-1301 USA # Commentary: diff --git a/meta/guile.m4 b/meta/guile.m4 index 1e30d508a..5ba725f51 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -3,9 +3,9 @@ ## Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc. ## ## This library is free software; you can redistribute it and/or -## modify it under the terms of the GNU Lesser General Public -## License as published by the Free Software Foundation; either -## version 2.1 of the License, or (at your option) any later version. +## modify it under the terms of the GNU Lesser General Public License +## as published by the Free Software Foundation; either version 3 of +## the License, or (at your option) any later version. ## ## This library is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -14,7 +14,8 @@ ## ## You should have received a copy of the GNU Lesser General Public ## License along with this library; if not, write to the Free Software -## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +## 02110-1301 USA # serial 9 diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index b15237c4b..8ee690ccf 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -4,10 +4,10 @@ # # This file is part of GUILE. # -# This script is free software; you can redistribute it and/or -# modify it under the terms of the GNU Lesser General Public -# License as published by the Free Software Foundation; either -# version 2.1 of the License, or (at your option) any later version. +# This script is free software; you can redistribute it and/or modify +# it under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3 of the +# License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -16,7 +16,8 @@ # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 USA # NOTE: If you update this file, please update uninstalled.in as # well, if appropriate. diff --git a/module/Makefile.am b/module/Makefile.am index 3358441b1..2df0232fb 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA include $(top_srcdir)/am/guilec diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm index b8cb2a679..bfd597b1e 100644 --- a/module/ice-9/and-let-star.scm +++ b/module/ice-9/and-let-star.scm @@ -6,7 +6,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm index 7ddcc8ab8..f7f9e5eed 100644 --- a/module/ice-9/arrays.scm +++ b/module/ice-9/arrays.scm @@ -2,20 +2,19 @@ ;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; (define (array-shape a) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 3d77093c0..ed561d2ff 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -6,7 +6,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/buffered-input.scm b/module/ice-9/buffered-input.scm index 11530e897..05e9255c0 100644 --- a/module/ice-9/buffered-input.scm +++ b/module/ice-9/buffered-input.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/calling.scm b/module/ice-9/calling.scm index 07f7a7805..f66bba27e 100644 --- a/module/ice-9/calling.scm +++ b/module/ice-9/calling.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/channel.scm b/module/ice-9/channel.scm index 8cbb00190..b9d470044 100644 --- a/module/ice-9/channel.scm +++ b/module/ice-9/channel.scm @@ -2,19 +2,19 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Commentary: diff --git a/module/ice-9/common-list.scm b/module/ice-9/common-list.scm index 7d62bc319..ea1b0f3de 100644 --- a/module/ice-9/common-list.scm +++ b/module/ice-9/common-list.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/debug.scm b/module/ice-9/debug.scm index 0e751590d..1fd5b66da 100644 --- a/module/ice-9/debug.scm +++ b/module/ice-9/debug.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/debugger.scm b/module/ice-9/debugger.scm index 3dddd9030..06f7ed230 100644 --- a/module/ice-9/debugger.scm +++ b/module/ice-9/debugger.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 1999, 2001, 2002, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugger) #:use-module (ice-9 debugger command-loop) diff --git a/module/ice-9/debugger/command-loop.scm b/module/ice-9/debugger/command-loop.scm index 62a08ea65..c6628271c 100644 --- a/module/ice-9/debugger/command-loop.scm +++ b/module/ice-9/debugger/command-loop.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 1999, 2001, 2002, 2003, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugger command-loop) #:use-module ((ice-9 debugger commands) :prefix debugger:) diff --git a/module/ice-9/debugger/commands.scm b/module/ice-9/debugger/commands.scm index ef6f79026..c254ce9e2 100644 --- a/module/ice-9/debugger/commands.scm +++ b/module/ice-9/debugger/commands.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugger commands) #:use-module (ice-9 debug) diff --git a/module/ice-9/debugger/state.scm b/module/ice-9/debugger/state.scm index 11b8ebbf0..0bda0fad5 100644 --- a/module/ice-9/debugger/state.scm +++ b/module/ice-9/debugger/state.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugger state) #:export (make-state diff --git a/module/ice-9/debugger/trc.scm b/module/ice-9/debugger/trc.scm index 49af2747d..3e7e2f359 100644 --- a/module/ice-9/debugger/trc.scm +++ b/module/ice-9/debugger/trc.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugger trc) #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port)) diff --git a/module/ice-9/debugging/breakpoints.scm b/module/ice-9/debugging/breakpoints.scm index 132746f17..c839409ef 100644 --- a/module/ice-9/debugging/breakpoints.scm +++ b/module/ice-9/debugging/breakpoints.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2005 Neil Jerram ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; This module provides a practical interface for setting and ;;; manipulating breakpoints. diff --git a/module/ice-9/debugging/steps.scm b/module/ice-9/debugging/steps.scm index fedbc6a32..cd328bd7d 100644 --- a/module/ice-9/debugging/steps.scm +++ b/module/ice-9/debugging/steps.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugging steps) #:use-module (ice-9 debugging traps) diff --git a/module/ice-9/debugging/trace.scm b/module/ice-9/debugging/trace.scm index ad3015ddf..55b1f3965 100644 --- a/module/ice-9/debugging/trace.scm +++ b/module/ice-9/debugging/trace.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2002 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugging trace) #:use-module (ice-9 debug) diff --git a/module/ice-9/debugging/traps.scm b/module/ice-9/debugging/traps.scm index ae1673688..e13011e99 100755 --- a/module/ice-9/debugging/traps.scm +++ b/module/ice-9/debugging/traps.scm @@ -3,19 +3,19 @@ ;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc. ;;; Copyright (C) 2005 Neil Jerram ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; This module provides an abstraction around Guile's low level trap ;;; handler interface; its aim is to make the low level trap mechanism diff --git a/module/ice-9/debugging/trc.scm b/module/ice-9/debugging/trc.scm index 9e95d7e5c..face227d6 100644 --- a/module/ice-9/debugging/trc.scm +++ b/module/ice-9/debugging/trc.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 debugging trc) #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port)) diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 6f2c2258b..53fc741c8 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index 92d31cabc..bbd6713f6 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/emacs.scm b/module/ice-9/emacs.scm index 12d8228ee..88035862f 100644 --- a/module/ice-9/emacs.scm +++ b/module/ice-9/emacs.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/expect.scm b/module/ice-9/expect.scm index a024e91e8..ffc2e1742 100644 --- a/module/ice-9/expect.scm +++ b/module/ice-9/expect.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 23f341521..ce2fb165e 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/gap-buffer.scm b/module/ice-9/gap-buffer.scm index b6162e802..4533bb539 100644 --- a/module/ice-9/gap-buffer.scm +++ b/module/ice-9/gap-buffer.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; ;;; Author: Thien-Thi Nguyen diff --git a/module/ice-9/gds-server.scm b/module/ice-9/gds-server.scm index f59758729..b64e41161 100644 --- a/module/ice-9/gds-server.scm +++ b/module/ice-9/gds-server.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2003 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 gds-server) #:export (run-server)) diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm index b16328ba8..891a2e3b3 100644 --- a/module/ice-9/getopt-long.scm +++ b/module/ice-9/getopt-long.scm @@ -1,18 +1,18 @@ ;;; Copyright (C) 1998, 2001, 2006, 2009 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen) diff --git a/module/ice-9/hcons.scm b/module/ice-9/hcons.scm index 6323506d2..7275cf476 100644 --- a/module/ice-9/hcons.scm +++ b/module/ice-9/hcons.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/history.scm b/module/ice-9/history.scm index 921a25741..e9097c2cc 100644 --- a/module/ice-9/history.scm +++ b/module/ice-9/history.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index f33a9f258..dd14e6754 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -5,13 +5,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/module/ice-9/lineio.scm b/module/ice-9/lineio.scm index f122268df..055eb6eb4 100644 --- a/module/ice-9/lineio.scm +++ b/module/ice-9/lineio.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/list.scm b/module/ice-9/list.scm index af83d1742..1b898a368 100644 --- a/module/ice-9/list.scm +++ b/module/ice-9/list.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 list) :export (rassoc rassv rassq)) diff --git a/module/ice-9/ls.scm b/module/ice-9/ls.scm index e848be32a..f729d58ce 100644 --- a/module/ice-9/ls.scm +++ b/module/ice-9/ls.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/mapping.scm b/module/ice-9/mapping.scm index c4ef4fe99..2907a8d89 100644 --- a/module/ice-9/mapping.scm +++ b/module/ice-9/mapping.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm index baa4d5aad..d7589239e 100644 --- a/module/ice-9/match.scm +++ b/module/ice-9/match.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/networking.scm b/module/ice-9/networking.scm index 9a30fc5b6..7e84f0969 100644 --- a/module/ice-9/networking.scm +++ b/module/ice-9/networking.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/null.scm b/module/ice-9/null.scm index 3f9f5b0a5..58b271e31 100644 --- a/module/ice-9/null.scm +++ b/module/ice-9/null.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/occam-channel.scm b/module/ice-9/occam-channel.scm index e04ecac5b..ea1154b52 100644 --- a/module/ice-9/occam-channel.scm +++ b/module/ice-9/occam-channel.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 occam-channel) #:use-module (oop goops) diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm index 975703c2d..3093e15a4 100644 --- a/module/ice-9/optargs.scm +++ b/module/ice-9/optargs.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/poe.scm b/module/ice-9/poe.scm index fe963db08..e7b6e3a75 100644 --- a/module/ice-9/poe.scm +++ b/module/ice-9/poe.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index 275faaa0c..1a1892851 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/posix.scm b/module/ice-9/posix.scm index dd1a12690..a1be33c19 100644 --- a/module/ice-9/posix.scm +++ b/module/ice-9/posix.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index bef76ddcb..0ce6a8003 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index e1352d8c5..5f5e86b0f 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/q.scm b/module/ice-9/q.scm index 0c12d7f40..4dc5d4953 100644 --- a/module/ice-9/q.scm +++ b/module/ice-9/q.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm index 7b1c11cc1..c23f31af1 100644 --- a/module/ice-9/r4rs.scm +++ b/module/ice-9/r4rs.scm @@ -6,7 +6,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/r5rs.scm b/module/ice-9/r5rs.scm index 2b40515d3..c867f9a3c 100644 --- a/module/ice-9/r5rs.scm +++ b/module/ice-9/r5rs.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/rdelim.scm b/module/ice-9/rdelim.scm index d21d45c38..71aae3c8b 100644 --- a/module/ice-9/rdelim.scm +++ b/module/ice-9/rdelim.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/receive.scm b/module/ice-9/receive.scm index 693dfe3f4..d550c6f36 100644 --- a/module/ice-9/receive.scm +++ b/module/ice-9/receive.scm @@ -2,19 +2,19 @@ ;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc. ;;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 receive) :export (receive) diff --git a/module/ice-9/regex.scm b/module/ice-9/regex.scm index 61937d04f..2327bfe17 100644 --- a/module/ice-9/regex.scm +++ b/module/ice-9/regex.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/runq.scm b/module/ice-9/runq.scm index eb1e2203f..c14eb8967 100644 --- a/module/ice-9/runq.scm +++ b/module/ice-9/runq.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/rw.scm b/module/ice-9/rw.scm index 2731e889a..b76282a47 100644 --- a/module/ice-9/rw.scm +++ b/module/ice-9/rw.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/safe-r5rs.scm b/module/ice-9/safe-r5rs.scm index 13a44d23d..f728533cb 100644 --- a/module/ice-9/safe-r5rs.scm +++ b/module/ice-9/safe-r5rs.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/safe.scm b/module/ice-9/safe.scm index 15b77990a..1ce8f9ed9 100644 --- a/module/ice-9/safe.scm +++ b/module/ice-9/safe.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/serialize.scm b/module/ice-9/serialize.scm index 3c70f4421..008a70a9e 100644 --- a/module/ice-9/serialize.scm +++ b/module/ice-9/serialize.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm index aaa4f0761..1f3ec2795 100644 --- a/module/ice-9/session.scm +++ b/module/ice-9/session.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/slib.scm b/module/ice-9/slib.scm index a2b526562..78c734e2a 100644 --- a/module/ice-9/slib.scm +++ b/module/ice-9/slib.scm @@ -5,13 +5,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm index a54267617..f7b207535 100644 --- a/module/ice-9/stack-catch.scm +++ b/module/ice-9/stack-catch.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/streams.scm b/module/ice-9/streams.scm index 317d47245..e0a17d488 100644 --- a/module/ice-9/streams.scm +++ b/module/ice-9/streams.scm @@ -6,7 +6,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/string-fun.scm b/module/ice-9/string-fun.scm index d8ba21f75..c27ff847f 100644 --- a/module/ice-9/string-fun.scm +++ b/module/ice-9/string-fun.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index 22391a8c8..210a23280 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/test.scm b/module/ice-9/test.scm index bed39b621..f6080e4cf 100644 --- a/module/ice-9/test.scm +++ b/module/ice-9/test.scm @@ -1,18 +1,18 @@ ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2006 Free Software Foundation, Inc. ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; "test.scm" Test correctness of scheme implementations. ;;; Author: Aubrey Jaffer diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index e07d766eb..292d3c27a 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/time.scm b/module/ice-9/time.scm index 86ebcbff1..0fad8dfca 100644 --- a/module/ice-9/time.scm +++ b/module/ice-9/time.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/ice-9/weak-vector.scm b/module/ice-9/weak-vector.scm index 92d40d840..09e2e0a8d 100644 --- a/module/ice-9/weak-vector.scm +++ b/module/ice-9/weak-vector.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 3f72cf6aa..3a0b3873e 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index e4458a992..73ed620d6 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index e65b2cbaa..2ad3bc6a4 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index df6199977..0a35050b3 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm index c12808e0c..286c80511 100644 --- a/module/language/assembly/spec.scm +++ b/module/language/assembly/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm index dff724a63..184565b04 100644 --- a/module/language/bytecode/spec.scm +++ b/module/language/bytecode/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/array.scm b/module/language/ecmascript/array.scm index a9f499a22..e9fc3c6f4 100644 --- a/module/language/ecmascript/array.scm +++ b/module/language/ecmascript/array.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm index 1463d358b..1d031fcde 100644 --- a/module/language/ecmascript/base.scm +++ b/module/language/ecmascript/base.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm index 6e4779120..ab04ba80c 100644 --- a/module/language/ecmascript/compile-ghil.scm +++ b/module/language/ecmascript/compile-ghil.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/function.scm b/module/language/ecmascript/function.scm index 1e2d726ca..710c5cb1c 100644 --- a/module/language/ecmascript/function.scm +++ b/module/language/ecmascript/function.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/impl.scm b/module/language/ecmascript/impl.scm index be4c751cb..27c077aed 100644 --- a/module/language/ecmascript/impl.scm +++ b/module/language/ecmascript/impl.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/parse-lalr.scm b/module/language/ecmascript/parse-lalr.scm index 6378d087c..b702511ca 100644 --- a/module/language/ecmascript/parse-lalr.scm +++ b/module/language/ecmascript/parse-lalr.scm @@ -2,18 +2,19 @@ ;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc. ;; Copyright (C) 1996-2002 Dominique Boucher -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;; ---------------------------------------------------------------------- ;; diff --git a/module/language/ecmascript/parse.scm b/module/language/ecmascript/parse.scm index 169c992fd..ce731a736 100644 --- a/module/language/ecmascript/parse.scm +++ b/module/language/ecmascript/parse.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm index 0112af5a4..6e9470f38 100644 --- a/module/language/ecmascript/spec.scm +++ b/module/language/ecmascript/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm index 2beda23b7..63f180b14 100644 --- a/module/language/ecmascript/tokenize.scm +++ b/module/language/ecmascript/tokenize.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm index a35c44112..617e4e3c5 100644 --- a/module/language/elisp/spec.scm +++ b/module/language/elisp/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ghil.scm b/module/language/ghil.scm index 273d0aa20..84cc83de5 100644 --- a/module/language/ghil.scm +++ b/module/language/ghil.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm index 02187be05..47e15c797 100644 --- a/module/language/ghil/compile-glil.scm +++ b/module/language/ghil/compile-glil.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm index c9d38aa69..f2bc19b61 100644 --- a/module/language/ghil/spec.scm +++ b/module/language/ghil/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/glil.scm b/module/language/glil.scm index 625760eaa..38b915f9e 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 96c6383c0..0b92a4e7d 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index a47bd80b2..502ef8034 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm index dbe379e70..d5291a211 100644 --- a/module/language/glil/spec.scm +++ b/module/language/glil/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/objcode.scm b/module/language/objcode.scm index aea546c66..d8bcda879 100644 --- a/module/language/objcode.scm +++ b/module/language/objcode.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm index c60829974..76c1cbcb9 100644 --- a/module/language/objcode/spec.scm +++ b/module/language/objcode/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/r5rs/core.il b/module/language/r5rs/core.il index ad40fcc1a..c614a6fe2 100644 --- a/module/language/r5rs/core.il +++ b/module/language/r5rs/core.il @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm index 45b722717..e8910ae1b 100644 --- a/module/language/r5rs/expand.scm +++ b/module/language/r5rs/expand.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/r5rs/null.il b/module/language/r5rs/null.il index efdc5f398..a290025de 100644 --- a/module/language/r5rs/null.il +++ b/module/language/r5rs/null.il @@ -2,19 +2,18 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/r5rs/spec.scm b/module/language/r5rs/spec.scm index b5d19e6d4..67f8d74cf 100644 --- a/module/language/r5rs/spec.scm +++ b/module/language/r5rs/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 8d8332c34..dc03af6cf 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm index 4635abc8a..4ac33d77e 100644 --- a/module/language/scheme/compile-tree-il.scm +++ b/module/language/scheme/compile-tree-il.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm index c4903d87f..9243f4e6a 100644 --- a/module/language/scheme/decompile-tree-il.scm +++ b/module/language/scheme/decompile-tree-il.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001,2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/scheme/inline.scm b/module/language/scheme/inline.scm index 462fe7f2f..b178b2adc 100644 --- a/module/language/scheme/inline.scm +++ b/module/language/scheme/inline.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index cec2693aa..21aa023a5 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 971892020..da483b3cc 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 90843f75a..976807718 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 78a841dd2..6dade3592 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 3a02e021e..ac16a9e39 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 8960c2802..7daae0c62 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -2,19 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm index c1f098230..2d24f7bf6 100644 --- a/module/language/tree-il/spec.scm +++ b/module/language/tree-il/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/language/value/spec.scm b/module/language/value/spec.scm index 51f5e6c66..aebba8c8d 100644 --- a/module/language/value/spec.scm +++ b/module/language/value/spec.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 6e3b15009..c1754da3e 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/accessors.scm b/module/oop/goops/accessors.scm index a7baa5c62..5b05d3b15 100644 --- a/module/oop/goops/accessors.scm +++ b/module/oop/goops/accessors.scm @@ -1,19 +1,18 @@ ;;;; Copyright (C) 1999, 2000, 2005, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; diff --git a/module/oop/goops/active-slot.scm b/module/oop/goops/active-slot.scm index e6b409ad0..5cd2afe10 100644 --- a/module/oop/goops/active-slot.scm +++ b/module/oop/goops/active-slot.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm index 732c1bccd..5db406cd0 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/composite-slot.scm b/module/oop/goops/composite-slot.scm index 9bf5cf8f8..b3f8cc038 100644 --- a/module/oop/goops/composite-slot.scm +++ b/module/oop/goops/composite-slot.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm index 184fef214..fa7bc466c 100644 --- a/module/oop/goops/describe.scm +++ b/module/oop/goops/describe.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index ed9f3077e..0dd169d59 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/internal.scm b/module/oop/goops/internal.scm index d996805e4..15919d44b 100644 --- a/module/oop/goops/internal.scm +++ b/module/oop/goops/internal.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm index 2aedd7698..0c7d71a2d 100644 --- a/module/oop/goops/save.scm +++ b/module/oop/goops/save.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm index c0cb76fbb..bc5405a8d 100644 --- a/module/oop/goops/simple.scm +++ b/module/oop/goops/simple.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm index ef943cf96..835969f13 100644 --- a/module/oop/goops/stklos.scm +++ b/module/oop/goops/stklos.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/oop/goops/util.scm b/module/oop/goops/util.scm index b6276aa37..69bb898bf 100644 --- a/module/oop/goops/util.scm +++ b/module/oop/goops/util.scm @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/Makefile.am b/module/srfi/Makefile.am index 0fc926e40..7cbac6630 100644 --- a/module/srfi/Makefile.am +++ b/module/srfi/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/qt/Makefile.am b/qt/Makefile.am index fc9951d30..8a15fb6ff 100644 --- a/qt/Makefile.am +++ b/qt/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/qt/md/Makefile.am b/qt/md/Makefile.am index 7500dc66c..e5b29e96e 100644 --- a/qt/md/Makefile.am +++ b/qt/md/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/qt/time/Makefile.am b/qt/time/Makefile.am index 735620330..bdce61f38 100644 --- a/qt/time/Makefile.am +++ b/qt/time/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. -## +## ## GUILE 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 GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 02fa12b04..648603007 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index dc218ab04..02f46fca0 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -4,18 +4,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index 936586697..5797579cc 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -5,18 +5,19 @@ * Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index dd5ce9b15..61a960e5d 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-13.h b/srfi/srfi-13.h index 8007d565b..a110ffd6d 100644 --- a/srfi/srfi-13.h +++ b/srfi/srfi-13.h @@ -6,18 +6,19 @@ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 1a7297b82..9f6ad8bc0 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index b1f4ae726..a793159c5 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -5,18 +5,19 @@ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c index f40c6b319..9b32b61a9 100644 --- a/srfi/srfi-4.c +++ b/srfi/srfi-4.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This file is now empty since all its procedures are now in the diff --git a/srfi/srfi-4.h b/srfi/srfi-4.h index 079219ace..0439675da 100644 --- a/srfi/srfi-4.h +++ b/srfi/srfi-4.h @@ -5,18 +5,19 @@ * Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-60.c b/srfi/srfi-60.c index 7d89ca039..989898f9c 100644 --- a/srfi/srfi-60.c +++ b/srfi/srfi-60.c @@ -3,18 +3,19 @@ * Copyright (C) 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/srfi/srfi-60.h b/srfi/srfi-60.h index 030b32525..47a8cf766 100644 --- a/srfi/srfi-60.h +++ b/srfi/srfi-60.h @@ -3,18 +3,19 @@ * Copyright (C) 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 8ac209339..7bfef16c9 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or +## (at your option) any later version. ## -## GUILE 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. +## GUILE 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 Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA SUBDIRS = standalone diff --git a/test-suite/guile-test b/test-suite/guile-test index 1e1c70a77..65b0533c8 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -7,20 +7,20 @@ ;;;; ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3, or (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. +;;;; GNU Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this software; see the file COPYING.LESSER. +;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin +;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...] diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 3f09ce48a..0a01a2756 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,20 +1,20 @@ ;;;; test-suite/lib.scm --- generic support for testing ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3, or (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. +;;;; GNU Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this software; see the file COPYING.LESSER. +;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin +;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite lib) :use-module (ice-9 stack-catch) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 9bfd801d8..37b9cb5e6 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or -## (at your option) any later version. +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or +## (at your option) any later version. ## -## GUILE 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. +## GUILE 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 Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA # initializations so we can use += below. diff --git a/test-suite/standalone/test-asmobs-lib.c b/test-suite/standalone/test-asmobs-lib.c index b85f923cd..c88556ab2 100644 --- a/test-suite/standalone/test-asmobs-lib.c +++ b/test-suite/standalone/test-asmobs-lib.c @@ -1,18 +1,19 @@ /* Copyright (C) 1999,2000,2001,2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef HAVE_CONFIG_H diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 41f99d3bc..0dfa80a23 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -1,18 +1,19 @@ /* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/test-suite/standalone/test-extensions-lib.c b/test-suite/standalone/test-extensions-lib.c index 25b3a38a9..7c8678895 100644 --- a/test-suite/standalone/test-extensions-lib.c +++ b/test-suite/standalone/test-extensions-lib.c @@ -1,18 +1,19 @@ /* Copyright (C) 1999,2000,2001,2003, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef HAVE_CONFIG_H diff --git a/test-suite/standalone/test-fast-slot-ref.in b/test-suite/standalone/test-fast-slot-ref.in index 774cfe269..e0708ab9d 100644 --- a/test-suite/standalone/test-fast-slot-ref.in +++ b/test-suite/standalone/test-fast-slot-ref.in @@ -2,19 +2,20 @@ # Copyright (C) 2006 Free Software Foundation, Inc. # -# This library is free software; you can redistribute it and/or modify it -# under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 2.1 of the License, or (at -# your option) any later version. +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public License +# as published by the Free Software Foundation; either version 3 of +# the License, or (at your option) any later version. # # This library 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 Lesser General Public -# License for more details. +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. # -# You should have received a copy of the GNU Lesser General Public License -# along with this library; if not, write to the Free Software Foundation, -# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 USA # Test for %fast-slot-ref, which was previously implemented such that # an out-of-range slot index could escape being properly detected, and diff --git a/test-suite/standalone/test-list.c b/test-suite/standalone/test-list.c index 02634f676..824463447 100644 --- a/test-suite/standalone/test-list.c +++ b/test-suite/standalone/test-list.c @@ -3,18 +3,19 @@ /* Copyright (C) 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef HAVE_CONFIG_H diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c index 1e8a016d5..8b69b071d 100644 --- a/test-suite/standalone/test-num2integral.c +++ b/test-suite/standalone/test-num2integral.c @@ -1,18 +1,19 @@ /* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef HAVE_CONFIG_H diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c index 1340fffa7..862e7d0fd 100644 --- a/test-suite/standalone/test-round.c +++ b/test-suite/standalone/test-round.c @@ -1,18 +1,19 @@ /* Copyright (C) 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/test-suite/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c index 1b4caa1c7..4111cd0f5 100644 --- a/test-suite/standalone/test-scm-c-read.c +++ b/test-suite/standalone/test-scm-c-read.c @@ -1,18 +1,19 @@ /* Copyright (C) 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* Exercise `scm_c_read ()' and the port type API. Verify assumptions that diff --git a/test-suite/standalone/test-scm-take-locale-symbol.c b/test-suite/standalone/test-scm-take-locale-symbol.c index 715f7f984..808068fbf 100644 --- a/test-suite/standalone/test-scm-take-locale-symbol.c +++ b/test-suite/standalone/test-scm-take-locale-symbol.c @@ -1,18 +1,19 @@ /* Copyright (C) 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* Exercise `scm_take_locale_symbol ()', making sure it returns an interned diff --git a/test-suite/standalone/test-scm-with-guile.c b/test-suite/standalone/test-scm-with-guile.c index 7fe16b351..a78458e6c 100644 --- a/test-suite/standalone/test-scm-with-guile.c +++ b/test-suite/standalone/test-scm-with-guile.c @@ -1,18 +1,19 @@ /* Copyright (C) 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/test-suite/standalone/test-unwind.c b/test-suite/standalone/test-unwind.c index 472887abe..2b0291dd5 100644 --- a/test-suite/standalone/test-unwind.c +++ b/test-suite/standalone/test-unwind.c @@ -1,18 +1,19 @@ /* Copyright (C) 2004, 2005, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #if HAVE_CONFIG_H diff --git a/test-suite/standalone/test-use-srfi.in b/test-suite/standalone/test-use-srfi.in index 7186b5a24..ab9d5cd5e 100755 --- a/test-suite/standalone/test-use-srfi.in +++ b/test-suite/standalone/test-use-srfi.in @@ -2,19 +2,20 @@ # Copyright (C) 2006 Free Software Foundation, Inc. # -# This library is free software; you can redistribute it and/or modify it -# under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 2.1 of the License, or (at -# your option) any later version. +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public License +# as published by the Free Software Foundation; either version 3 of +# the License, or (at your option) any later version. # # This library 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 Lesser General Public -# License for more details. +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. # -# You should have received a copy of the GNU Lesser General Public License -# along with this library; if not, write to the Free Software Foundation, -# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 USA # Test that two srfi numbers on the command line work. diff --git a/test-suite/standalone/test-with-guile-module.c b/test-suite/standalone/test-with-guile-module.c index babc22b22..154f4f23f 100644 --- a/test-suite/standalone/test-with-guile-module.c +++ b/test-suite/standalone/test-with-guile-module.c @@ -1,18 +1,19 @@ /* Copyright (C) 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifndef HAVE_CONFIG_H diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index a9e9b0d24..699c10ef4 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/and-let-star.test b/test-suite/tests/and-let-star.test index 0f74934f7..150600c34 100644 --- a/test-suite/tests/and-let-star.test +++ b/test-suite/tests/and-let-star.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-and-let-star) #:use-module (test-suite lib) diff --git a/test-suite/tests/arbiters.test b/test-suite/tests/arbiters.test index 7591f02f0..36dc7edbd 100644 --- a/test-suite/tests/arbiters.test +++ b/test-suite/tests/arbiters.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 2af3152ff..1c2a5994b 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -3,7 +3,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index 8e35257b3..8815dc65b 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index b2ae65c1f..c7697b13c 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -6,13 +6,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/test-suite/tests/c-api.test b/test-suite/tests/c-api.test index 4a165d4cb..7c1b3bbd1 100644 --- a/test-suite/tests/c-api.test +++ b/test-suite/tests/c-api.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define srcdir (cdr (assq 'srcdir %guile-build-info))) diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index f14c832dd..cff9532dd 100644 --- a/test-suite/tests/chars.test +++ b/test-suite/tests/chars.test @@ -3,27 +3,19 @@ ;;;; ;;;; Copyright (C) 2000, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA - - -(use-modules (test-suite lib)) - -(define exception:wrong-type-to-apply - (cons 'misc-error "^Wrong type to apply:")) - +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (with-test-prefix "basic char handling" diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test index c6f659b1e..dae806844 100644 --- a/test-suite/tests/common-list.test +++ b/test-suite/tests/common-list.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 7324d7795..1252c2881 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/continuations.test b/test-suite/tests/continuations.test index 7d76b762b..20a7a5ac1 100644 --- a/test-suite/tests/continuations.test +++ b/test-suite/tests/continuations.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-continuations) :use-module (test-suite lib)) diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test index d7a06a411..77be3b480 100644 --- a/test-suite/tests/dynamic-scope.test +++ b/test-suite/tests/dynamic-scope.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-dynamic-scope) :use-module (test-suite lib)) diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 9e0997087..fd028dac6 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index 646efc56a..61ced3596 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index e5ef34bb0..47d7ca99f 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 4a9c1cb55..c2ec5f48d 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index b9913c2f2..a6bfb6eb5 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index cc3b6684b..04b31f138 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-format) #:use-module (test-suite lib) diff --git a/test-suite/tests/fractions.test b/test-suite/tests/fractions.test index 0e1a4d6c1..3ee1347d8 100644 --- a/test-suite/tests/fractions.test +++ b/test-suite/tests/fractions.test @@ -1,17 +1,18 @@ ;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License version 2 as -;;;; published by the Free Software Foundation; see file GNU-GPL. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software Foundation, -;;;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Based in part on code from GNU CLISP, Copyright (C) 1993 Michael Stoll diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index c0cbb92cd..847fb9ff4 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index badf2b79c..5c485abe8 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index fe4a8872b..2c6f41515 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (test-suite lib) (ice-9 getopt-long) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 7cdc396aa..c060d12a6 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-goops) #:use-module (test-suite lib) diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test index d60f638b7..b675f02f5 100644 --- a/test-suite/tests/guardians.test +++ b/test-suite/tests/guardians.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; These tests make some questionable assumptions. ;;; - They assume that a GC will find all dead objects, so they diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index ccfd24ece..d2bde481c 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test index f8ed39919..68c724704 100644 --- a/test-suite/tests/hooks.test +++ b/test-suite/tests/hooks.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 78d7e54fb..c4777c21c 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -6,13 +6,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/test-suite/tests/import.test b/test-suite/tests/import.test index 4c4be02b2..1f2d26445 100644 --- a/test-suite/tests/import.test +++ b/test-suite/tests/import.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test index a091515b9..5f3e2aaf7 100644 --- a/test-suite/tests/interp.test +++ b/test-suite/tests/interp.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (pass-if "Internal defines 1" (letrec ((foo (lambda (arg) diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 7dc0ef0f8..d7b7801c9 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index a71a34716..59f9dbb61 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-load) :use-module (test-suite lib) diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index 43e35d8b7..696c35ca2 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -5,13 +5,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/test-suite/tests/multilingual.nottest b/test-suite/tests/multilingual.nottest index 46a3ee2d3..cc911a108 100644 --- a/test-suite/tests/multilingual.nottest +++ b/test-suite/tests/multilingual.nottest @@ -4,20 +4,19 @@ ;;;; ;;;; Copyright (C) 1999, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (test-suite lib)) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 32627ed8c..57e2f9b28 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 040b68ba4..5929ce909 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-optargs) :use-module (test-suite lib) diff --git a/test-suite/tests/options.test b/test-suite/tests/options.test index f2f87143b..a795109ce 100644 --- a/test-suite/tests/options.test +++ b/test-suite/tests/options.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (test-suite lib)) diff --git a/test-suite/tests/pairs.test b/test-suite/tests/pairs.test index af2f3e275..a317307b2 100644 --- a/test-suite/tests/pairs.test +++ b/test-suite/tests/pairs.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (test-suite lib)) diff --git a/test-suite/tests/poe.test b/test-suite/tests/poe.test index 6c7625602..707dc0272 100644 --- a/test-suite/tests/poe.test +++ b/test-suite/tests/poe.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 9cc68f21c..0a20cff7a 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index f1ba80be0..67df5b979 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-ports) :use-module (test-suite lib) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index e93d1689f..06b70baa0 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2003, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-posix) :use-module (test-suite lib)) diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test index 40e89c792..5768e1a64 100644 --- a/test-suite/tests/procprop.test +++ b/test-suite/tests/procprop.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-procpop) :use-module (test-suite lib)) diff --git a/test-suite/tests/q.test b/test-suite/tests/q.test index 5c24e5202..03f1bebe9 100644 --- a/test-suite/tests/q.test +++ b/test-suite/tests/q.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index e47364c66..e26fdada3 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test index 1357345b2..0bae630b5 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/test-suite/tests/r5rs_pitfall.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 204f37144..829258f87 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -6,13 +6,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test index d923bc1f2..948a77870 100644 --- a/test-suite/tests/ramap.test +++ b/test-suite/tests/ramap.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index bd34e4db0..0eb851508 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -6,13 +6,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/test-suite/tests/receive.test b/test-suite/tests/receive.test index 4b55bdf9f..3fb4abe20 100644 --- a/test-suite/tests/receive.test +++ b/test-suite/tests/receive.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-receive) #:use-module (test-suite lib) diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 15f77a34c..730839970 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-regexp) #:use-module (test-suite lib) diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test index 4bfc41557..7626ceebf 100644 --- a/test-suite/tests/socket.test +++ b/test-suite/tests/socket.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test index a49c04857..292836d88 100644 --- a/test-suite/tests/sort.test +++ b/test-suite/tests/sort.test @@ -1,20 +1,19 @@ ;;;; sort.test --- tests Guile's sort functions -*- scheme -*- ;;;; Copyright (C) 2003, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (test-suite lib)) diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test index 5bfe68080..8ec298960 100644 --- a/test-suite/tests/srcprop.test +++ b/test-suite/tests/srcprop.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 4f2838744..c163e7b69 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2003, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-1) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-10.test b/test-suite/tests/srfi-10.test index 248c04ff7..ab3cb884e 100644 --- a/test-suite/tests/srfi-10.test +++ b/test-suite/tests/srfi-10.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (srfi srfi-10)) diff --git a/test-suite/tests/srfi-11.test b/test-suite/tests/srfi-11.test index ec2ed86c8..40563dc18 100644 --- a/test-suite/tests/srfi-11.test +++ b/test-suite/tests/srfi-11.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-11) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index 89759d0d3..9dbf5bf40 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-strings) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test index fc6307149..8c678cdd5 100644 --- a/test-suite/tests/srfi-14.test +++ b/test-suite/tests/srfi-14.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-14) :use-module (srfi srfi-14) diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index 4841f2ef1..d9e0054ba 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2001, 2003, 2005, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-17) :use-module (test-suite lib) diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index 3c7090643..b769ce1a2 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-18) #:use-module (test-suite lib)) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 259a88a4e..f48ce6286 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;; SRFI-19 overrides current-date, so we have to do the test in a ;; separate module, or later tests will fail. diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index b23d3e20f..6d65ce2bc 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/srfi-34.test b/test-suite/tests/srfi-34.test index 2195d9471..17864b642 100644 --- a/test-suite/tests/srfi-34.test +++ b/test-suite/tests/srfi-34.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-34) :duplicates (last) ;; avoid warning about srfi-34 replacing `raise' diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test index 83efd61d9..24ee60248 100644 --- a/test-suite/tests/srfi-35.test +++ b/test-suite/tests/srfi-35.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-35) :use-module (test-suite lib) diff --git a/test-suite/tests/srfi-37.test b/test-suite/tests/srfi-37.test index d7745876d..1f739c5c5 100644 --- a/test-suite/tests/srfi-37.test +++ b/test-suite/tests/srfi-37.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-37) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-39.test b/test-suite/tests/srfi-39.test index 277a3c60d..0153e58b4 100644 --- a/test-suite/tests/srfi-39.test +++ b/test-suite/tests/srfi-39.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-39) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test index ee773a3f9..8a9d53a61 100644 --- a/test-suite/tests/srfi-4.test +++ b/test-suite/tests/srfi-4.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (srfi srfi-4) (test-suite lib)) diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test index 217fc9f78..68fc70dff 100644 --- a/test-suite/tests/srfi-6.test +++ b/test-suite/tests/srfi-6.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (test-suite lib)) diff --git a/test-suite/tests/srfi-60.test b/test-suite/tests/srfi-60.test index fff89f1ca..940934f3e 100644 --- a/test-suite/tests/srfi-60.test +++ b/test-suite/tests/srfi-60.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2005, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-60) #:duplicates (last) ;; avoid warning about srfi-60 replacing `bit-count' diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test index 1d240d28c..e99b76c6d 100644 --- a/test-suite/tests/srfi-69.test +++ b/test-suite/tests/srfi-69.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-69) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-88.test b/test-suite/tests/srfi-88.test index 63f40cc40..b879941b2 100644 --- a/test-suite/tests/srfi-88.test +++ b/test-suite/tests/srfi-88.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-88) :use-module (test-suite lib) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index c212ea6aa..f8cb0b491 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-numbers) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-98.test b/test-suite/tests/srfi-98.test index 3fbb1ef03..ac0d5178e 100644 --- a/test-suite/tests/srfi-98.test +++ b/test-suite/tests/srfi-98.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-98) #:use-module (srfi srfi-98) diff --git a/test-suite/tests/streams.test b/test-suite/tests/streams.test index 92277c19c..780021c7e 100644 --- a/test-suite/tests/streams.test +++ b/test-suite/tests/streams.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-streams) :use-module (test-suite lib) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 51f163254..ffc6955ca 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-strings) #:use-module (test-suite lib)) diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test index 127115eb2..e114abb1a 100644 --- a/test-suite/tests/structs.test +++ b/test-suite/tests/structs.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-structs) :use-module (test-suite lib)) diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test index 3fe3402f8..5be2743b2 100644 --- a/test-suite/tests/symbols.test +++ b/test-suite/tests/symbols.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-symbols) #:use-module (test-suite lib) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index c681fc381..4cd93369a 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;; These tests are in a module so that the syntax transformer does not ;; affect code outside of this file. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index aa2e05127..0593ea6a6 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-syntax) :use-module (test-suite lib)) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 6400d2dd8..26efe8580 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-threads) :use-module (ice-9 threads) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index d5639eb68..38a49d384 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-time) #:use-module (test-suite lib) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 18b67d6c8..ec410b52b 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -6,13 +6,13 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; version 3 of the License, or (at your option) any later version. +;;;; ;;;; This library 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 ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 576a9286c..61dbeb89e 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test index 738a0828a..22434bfc6 100644 --- a/test-suite/tests/vectors.test +++ b/test-suite/tests/vectors.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite vectors) :use-module (test-suite lib)) diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test index b2a491950..5b7acc93d 100644 --- a/test-suite/tests/version.test +++ b/test-suite/tests/version.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library 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. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (test-suite lib)) diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test index 7bb77b07c..b469887c2 100644 --- a/test-suite/tests/weaks.test +++ b/test-suite/tests/weaks.test @@ -4,7 +4,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of From 1b34e26a20aedd43ac5d6e87f5be7d10e1bb4f5f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 17 Jun 2009 21:34:38 +0100 Subject: [PATCH 219/375] Reinstate lines removed by mistake from chars.test --- test-suite/tests/chars.test | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index cff9532dd..b52b384c5 100644 --- a/test-suite/tests/chars.test +++ b/test-suite/tests/chars.test @@ -17,6 +17,12 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +(use-modules (test-suite lib)) + +(define exception:wrong-type-to-apply + (cons 'misc-error "^Wrong type to apply:")) + + (with-test-prefix "basic char handling" (with-test-prefix "evaluator" From 83ba2d3750ea105d8193fcb1b7162539160cf91c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 17 Jun 2009 22:30:26 +0100 Subject: [PATCH 220/375] Complete changing license to LGPLv3+ (Still guile-readline to do, but that will all be GPLv3+.) --- module/rnrs/bytevector.scm | 2 +- module/rnrs/io/ports.scm | 2 +- module/scripts/PROGRAM.scm | 14 +++++++------- module/scripts/api-diff.scm | 14 +++++++------- module/scripts/autofrisk.scm | 14 +++++++------- module/scripts/compile.scm | 14 +++++++------- module/scripts/disassemble.scm | 14 +++++++------- module/scripts/display-commentary.scm | 14 +++++++------- module/scripts/doc-snarf.scm | 14 +++++++------- module/scripts/frisk.scm | 14 +++++++------- module/scripts/generate-autoload.scm | 14 +++++++------- module/scripts/lint.scm | 14 +++++++------- module/scripts/punify.scm | 14 +++++++------- module/scripts/read-rfc822.scm | 14 +++++++------- module/scripts/read-scheme-source.scm | 14 +++++++------- module/scripts/read-text-outline.scm | 14 +++++++------- module/scripts/scan-api.scm | 14 +++++++------- module/scripts/snarf-check-and-output-texi.scm | 14 +++++++------- module/scripts/snarf-guile-m4-docs.scm | 14 +++++++------- module/scripts/summarize-guile-TODO.scm | 14 +++++++------- module/scripts/use2dot.scm | 14 +++++++------- module/srfi/srfi-1.scm | 2 +- module/srfi/srfi-10.scm | 2 +- module/srfi/srfi-11.scm | 2 +- module/srfi/srfi-13.scm | 2 +- module/srfi/srfi-14.scm | 2 +- module/srfi/srfi-16.scm | 2 +- module/srfi/srfi-17.scm | 2 +- module/srfi/srfi-18.scm | 2 +- module/srfi/srfi-19.scm | 2 +- module/srfi/srfi-2.scm | 2 +- module/srfi/srfi-26.scm | 2 +- module/srfi/srfi-31.scm | 2 +- module/srfi/srfi-34.scm | 2 +- module/srfi/srfi-35.scm | 2 +- module/srfi/srfi-37.scm | 2 +- module/srfi/srfi-39.scm | 2 +- module/srfi/srfi-4.scm | 2 +- module/srfi/srfi-6.scm | 2 +- module/srfi/srfi-60.scm | 2 +- module/srfi/srfi-69.scm | 2 +- module/srfi/srfi-8.scm | 2 +- module/srfi/srfi-88.scm | 2 +- module/srfi/srfi-9.scm | 2 +- module/srfi/srfi-98.scm | 2 +- testsuite/run-vm-tests.scm | 12 ++++++------ 46 files changed, 165 insertions(+), 165 deletions(-) diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm index 7728a1581..32929c698 100644 --- a/module/rnrs/bytevector.scm +++ b/module/rnrs/bytevector.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 73843ee55..d1b96b31a 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -5,7 +5,7 @@ ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 of the License, or (at your option) any later version. +;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/scripts/PROGRAM.scm b/module/scripts/PROGRAM.scm index af1a583bb..56e5cf334 100644 --- a/module/scripts/PROGRAM.scm +++ b/module/scripts/PROGRAM.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: J.R.Hacker diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm index de750e14a..b842b03ff 100644 --- a/module/scripts/api-diff.scm +++ b/module/scripts/api-diff.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm index e280be4d9..e29ccc992 100644 --- a/module/scripts/autofrisk.scm +++ b/module/scripts/autofrisk.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 84d235b8a..311e35bad 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -3,19 +3,19 @@ ;; Copyright 2005,2008,2009 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Ludovic Courtès ;;; Author: Andy Wingo diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm index 46ef0c744..f074615fb 100644 --- a/module/scripts/disassemble.scm +++ b/module/scripts/disassemble.scm @@ -3,19 +3,19 @@ ;; Copyright 2005,2008 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Ludovic Courtès ;;; Author: Andy Wingo diff --git a/module/scripts/display-commentary.scm b/module/scripts/display-commentary.scm index fd1ffd004..5bd249ce9 100644 --- a/module/scripts/display-commentary.scm +++ b/module/scripts/display-commentary.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm index 4ceddc152..b5665b973 100644 --- a/module/scripts/doc-snarf.scm +++ b/module/scripts/doc-snarf.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Martin Grabmueller diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm index 374bb4e3c..0cf50d6a8 100644 --- a/module/scripts/frisk.scm +++ b/module/scripts/frisk.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/generate-autoload.scm b/module/scripts/generate-autoload.scm index 10f158c98..781931015 100644 --- a/module/scripts/generate-autoload.scm +++ b/module/scripts/generate-autoload.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/lint.scm b/module/scripts/lint.scm index 2ee9b7863..b4a7f530a 100644 --- a/module/scripts/lint.scm +++ b/module/scripts/lint.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Neil Jerram diff --git a/module/scripts/punify.scm b/module/scripts/punify.scm index 098c4b935..1627722d3 100644 --- a/module/scripts/punify.scm +++ b/module/scripts/punify.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm index ed3aced7d..c0a54f28c 100644 --- a/module/scripts/read-rfc822.scm +++ b/module/scripts/read-rfc822.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/read-scheme-source.scm b/module/scripts/read-scheme-source.scm index c593d64e3..b48a88f9b 100644 --- a/module/scripts/read-scheme-source.scm +++ b/module/scripts/read-scheme-source.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm index 579fb6934..64221fbe1 100644 --- a/module/scripts/read-text-outline.scm +++ b/module/scripts/read-text-outline.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm index ceaac43d4..9236f8742 100644 --- a/module/scripts/scan-api.scm +++ b/module/scripts/scan-api.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm index 049d08411..0e7efae47 100644 --- a/module/scripts/snarf-check-and-output-texi.scm +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Michael Livshin diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm index 11fb82b3d..05c305ebd 100644 --- a/module/scripts/snarf-guile-m4-docs.scm +++ b/module/scripts/snarf-guile-m4-docs.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm index bf4f14535..a67c92ede 100644 --- a/module/scripts/summarize-guile-TODO.scm +++ b/module/scripts/summarize-guile-TODO.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/scripts/use2dot.scm b/module/scripts/use2dot.scm index bf1fdbddb..ab97afbc7 100644 --- a/module/scripts/use2dot.scm +++ b/module/scripts/use2dot.scm @@ -3,19 +3,19 @@ ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301 USA +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. If +;; not, write to the Free Software Foundation, Inc., 51 Franklin +;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Author: Thien-Thi Nguyen diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 7c55d9923..db21122b9 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-10.scm b/module/srfi/srfi-10.scm index 8e7181a3b..533d9f769 100644 --- a/module/srfi/srfi-10.scm +++ b/module/srfi/srfi-10.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index afa1730f1..c8422eeaf 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-13.scm b/module/srfi/srfi-13.scm index 1036a0f47..a2d64cba3 100644 --- a/module/srfi/srfi-13.scm +++ b/module/srfi/srfi-13.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-14.scm b/module/srfi/srfi-14.scm index 100b43b8e..ecc21e52e 100644 --- a/module/srfi/srfi-14.scm +++ b/module/srfi/srfi-14.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-16.scm b/module/srfi/srfi-16.scm index 0b213fde7..dc3c70920 100644 --- a/module/srfi/srfi-16.scm +++ b/module/srfi/srfi-16.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-17.scm b/module/srfi/srfi-17.scm index c9cb2abfe..a14c5c33b 100644 --- a/module/srfi/srfi-17.scm +++ b/module/srfi/srfi-17.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index dd92079be..26acb6300 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 29c604fcd..b91824976 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-2.scm b/module/srfi/srfi-2.scm index 0dfe38305..c09323fbb 100644 --- a/module/srfi/srfi-2.scm +++ b/module/srfi/srfi-2.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-26.scm b/module/srfi/srfi-26.scm index 410d2e2f8..324a5dc37 100644 --- a/module/srfi/srfi-26.scm +++ b/module/srfi/srfi-26.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm index 54c2f9fd4..4238dc269 100644 --- a/module/srfi/srfi-31.scm +++ b/module/srfi/srfi-31.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm index 18a2fda1c..7fb9d1dd6 100644 --- a/module/srfi/srfi-34.scm +++ b/module/srfi/srfi-34.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm index d7e6a4da0..873b08b13 100644 --- a/module/srfi/srfi-35.scm +++ b/module/srfi/srfi-35.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm index 5e6d512a2..565b44cb9 100644 --- a/module/srfi/srfi-37.scm +++ b/module/srfi/srfi-37.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm index 87154d6df..61e67b820 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm index f30e83952..b133f2106 100644 --- a/module/srfi/srfi-4.scm +++ b/module/srfi/srfi-4.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm index 1e455bb5c..098b586cc 100644 --- a/module/srfi/srfi-6.scm +++ b/module/srfi/srfi-6.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-60.scm b/module/srfi/srfi-60.scm index 177f97681..c9eb60f8b 100644 --- a/module/srfi/srfi-60.scm +++ b/module/srfi/srfi-60.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm index d26393576..0d835d09b 100644 --- a/module/srfi/srfi-69.scm +++ b/module/srfi/srfi-69.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-8.scm b/module/srfi/srfi-8.scm index c15cbe9c0..ced123894 100644 --- a/module/srfi/srfi-8.scm +++ b/module/srfi/srfi-8.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-88.scm b/module/srfi/srfi-88.scm index ebde81d0b..0fec19ee1 100644 --- a/module/srfi/srfi-88.scm +++ b/module/srfi/srfi-88.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index 59d23bf53..c64be5e51 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/module/srfi/srfi-98.scm b/module/srfi/srfi-98.scm index 924a20578..944f40261 100644 --- a/module/srfi/srfi-98.scm +++ b/module/srfi/srfi-98.scm @@ -5,7 +5,7 @@ ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm index 1485fc1e6..c6c7a5dfe 100644 --- a/testsuite/run-vm-tests.scm +++ b/testsuite/run-vm-tests.scm @@ -3,17 +3,17 @@ ;;; Copyright 2005 Ludovic Courtès ;;; ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 3 of +;;; the License, or (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +;;; GNU Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License +;;; You should have received a copy of the GNU Lesser General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA From b82a8b48507f67b6dbffdd048dc088e084d1413e Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 17 Jun 2009 22:35:30 +0100 Subject: [PATCH 221/375] Change guile-readline license to GPLv3+ --- guile-readline/Makefile.am | 20 ++++++++++---------- guile-readline/ice-9/Makefile.am | 20 ++++++++++---------- guile-readline/ice-9/readline.scm | 2 +- guile-readline/readline.c | 2 +- guile-readline/readline.h | 2 +- 5 files changed, 23 insertions(+), 23 deletions(-) diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index 94e6f9741..9df82bcb1 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -2,20 +2,20 @@ ## ## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. ## -## This file is part of GUILE. +## This file is part of guile-readline. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## guile-readline 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 3, or ## (at your option) any later version. ## -## GUILE 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. +## guile-readline 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 GUILE; see the file COPYING. If not, write +## You should have received a copy of the GNU General Public License +## along with guile-readline; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA diff --git a/guile-readline/ice-9/Makefile.am b/guile-readline/ice-9/Makefile.am index d1e7c8270..ffa767e99 100644 --- a/guile-readline/ice-9/Makefile.am +++ b/guile-readline/ice-9/Makefile.am @@ -2,20 +2,20 @@ ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. ## -## This file is part of GUILE. +## This file is part of guile-readline. ## -## GUILE is free software; you can redistribute it and/or modify -## it under the terms of the GNU General Public License as -## published by the Free Software Foundation; either version 2, or +## guile-readline 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 3, or ## (at your option) any later version. ## -## GUILE 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. +## guile-readline 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 GUILE; see the file COPYING. If not, write +## You should have received a copy of the GNU General Public License +## along with guile-readline; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index 19dda94db..96af69e2f 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -4,7 +4,7 @@ ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; the Free Software Foundation; either version 3, or (at your option) ;;;; any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 58599cacc..84ae62260 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -4,7 +4,7 @@ * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) + * the Free Software Foundation; either version 3, or (at your option) * any later version. * * This program is distributed in the hope that it will be useful, diff --git a/guile-readline/readline.h b/guile-readline/readline.h index 6242c5642..2bf5f8000 100644 --- a/guile-readline/readline.h +++ b/guile-readline/readline.h @@ -5,7 +5,7 @@ * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) + * the Free Software Foundation; either version 3, or (at your option) * any later version. * * This program is distributed in the hope that it will be useful, From fa1804e94394d92b9999eaee769653ed423474b3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 18 Jun 2009 23:02:51 +0200 Subject: [PATCH 222/375] update NEWS, THANKS * NEWS: Update, but only partially. I wanted to push out this incomplete, not yet organized draft for review, if anyone had comments. I'll pick it up tomorrow morning. * THANKS: Add Juhani, whose last name changed? --- NEWS | 458 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-- THANKS | 1 + 2 files changed, 449 insertions(+), 10 deletions(-) diff --git a/NEWS b/NEWS index 747c93119..303caea93 100644 --- a/NEWS +++ b/NEWS @@ -5,7 +5,454 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. -Changes in 1.9.0: +Changes in 1.9.1 (changes since the 1.8.x series): + +** The stack limit is now initialized from the environment. + +If getrlimit(2) is available and a stack limit is set, Guile will set +its stack limit to 80% of the rlimit. Otherwise the limit is 160000 +words, a four-fold increase from the earlier default limit. + +** Fix bad interaction between `false-if-exception' and stack-call. + +Exceptions thrown by `false-if-exception' were erronously causing the +stack to be saved, causing later errors to show the incorrectly-saved +backtrace. This has been fixed. + +** Files loaded with primitive-load-path will now be compiled + automatically. + +If a compiled .go file corresponding to a .scm file is not found or is +not fresh, the .scm file will be compiled on the fly, and the resulting +.go file stored away. An advisory note will be printed on the console. + +Note that this mechanism depends on preservation of the .scm and .go +modification times; if the .scm or .go files are moved after +installation, care should be taken to preserve their original +timestamps. + +Autocompiled files will be stored in the user's ~/.guile-ccache +directory, which will be created if needed. This is analogous to +ccache's behavior for C files. + +To inhibit autocompilation, set the GUILE_AUTO_COMPILE environment +variable to 0, or pass --no-autocompile on the Guile command line. + +** New environment variables: GUILE_LOAD_COMPILED_PATH, + GUILE_SYSTEM_LOAD_COMPILED_PATH + +GUILE_LOAD_COMPILED_PATH is for compiled files what GUILE_LOAD_PATH is +for source files. It is a different path, however, because compiled +files are architecture-specific. GUILE_SYSTEM_LOAD_COMPILED_PATH is like +GUILE_SYSTEM_PATH. + +** New global variables: %load-compiled-path, %load-compiled-extensions + +These are analogous to %load-path and %load-extensions. + +** New installation directory: $(pkglibdir)/1.9/ccache + +If $(libdir) is /usr/lib, for example, Guile will install its .go files +to /usr/lib/guile/1.9/ccache. These files are architecture-specific. + +** scm_primitive_load_path has additional argument, exception_on_error + +** scm_stat has additional argument, exception_on_error + +** New entry into %guile-build-info: `ccachedir' + +Probably should be removed? + +** New reader macros: #' #` #, #,@ + +These macros translate, respectively, to `syntax', `quasisyntax', +`unsyntax', and `unsyntax-splicing'. See the R6RS for more information. +These reader macros may be overridden by `read-hash-extend'. + +** Incompatible change to #' + +Guile did have a #' hash-extension, by default, which just returned the +subsequent datum: #'foo => foo. In the unlikely event that anyone +actually used this, this behavior may be reinstated via the +`read-hash-extend' mechanism. + +** Scheme expresssions may be commented out with #; + +#; comments out an entire expression. See the R6RS for more information. + +** make-stack with a tail-called procedural narrowing argument no longer + works (with compiled procedures) + +It used to be the case that a captured stack could be narrowed to select +calls only up to or from a certain procedure, even if that procedure +already tail-called another procedure. This was because the debug +information from the original procedure was kept on the stack. + +Now with the new compiler, the stack only contains active frames from +the current continuation. A narrow to a procedure that is not in the +stack will result in an empty stack. To fix this, narrow to a procedure +that is active in the current continuation, or narrow to a specific +number of stack frames. + +** backtraces through compiled procedures only show procedures that are + active in the current continuation + +Similarly to the previous issue, backtraces in compiled code may be +different from backtraces in interpreted code. There are no semantic +differences, however. Please mail bug-guile@gnu.org if you see any +deficiencies with Guile's backtraces. + +** syntax-rules and syntax-case macros now propagate source information + through to the expanded code + +This should result in better backtraces. + +** The currying behavior of `define' has been removed. + +Before, `(define ((f a) b) (* a b))' would translate to + + (define f (lambda (a) (lambda (b) (* a b)))) + +Now a syntax error is signalled, as this syntax is not supported by +default. If there is sufficient demand, this syntax can be supported +again by default. + +** All modules have names now + +Before, you could have anonymous modules: modules without names. Now, +because of hygiene and macros, all modules have names. If a module was +created without a name, the first time `module-name' is called on it, a +fresh name will be lazily generated for it. + +** Many syntax errors have different texts now + +Syntax errors still throw to the `syntax-error' key, but the arguments +are often different now. Perhaps in the future, Guile will switch to +using standard srfi-35 conditions. + +** Returning multiple values to compiled code will silently truncate the + values to the expected number + +For example, the interpreter would raise an error evaluating the form, +`(+ (values 1 2) (values 3 4))', because it would see the operands as +being two compound "values" objects, to which `+' does not apply. + +The compiler, on the other hand, receives multiple values on the stack, +not as a compound object. Given that it must check the number of values +anyway, if too many values are provided for a continuation, it chooses +to truncate those values, effectively evaluating `(+ 1 3)' instead. + +The idea is that the semantics that the compiler implements is more +intuitive, and the use of the interpreter will fade out with time. +This behavior is allowed both by the R5RS and the R6RS. + +** Multiple values in compiled code are not represented by compound + objects + +This change may manifest itself in the following situation: + + (let ((val (foo))) (do-something) val) + +In the interpreter, if `foo' returns multiple values, multiple values +are produced from the `let' expression. In the compiler, those values +are truncated to the first value, and that first value is returned. In +the compiler, if `foo' returns no values, an error will be raised, while +the interpreter would proceed. + +Both of these behaviors are allowed by R5RS and R6RS. The compiler's +behavior is more correct, however. If you wish to preserve a potentially +multiply-valued return, you will need to set up a multiple-value +continuation, using `call-with-values'. + +** Defmacros are now implemented in terms of syntax-case. + +The practical ramification of this is that the `defmacro?' predicate has +been removed, along with `defmacro-transformer', `macro-table', +`xformer-table', `assert-defmacro?!', `set-defmacro-transformer!' and +`defmacro:transformer'. This is because defmacros are simply macros. If +any of these procedures provided useful facilities to you, we encourage +you to contact the Guile developers. + +** psyntax is now the default expander + +Scheme code is now expanded by default by the psyntax hygienic macro +expander. Expansion is performed completely before compilation or +interpretation. + +Notably, syntax errors will be signalled before interpretation begins. +In the past, many syntax errors were only detected at runtime if the +code in question was memoized. + +As part of its expansion, psyntax renames all lexically-bound +identifiers. Original identifier names are preserved and given to the +compiler, but the interpreter will see the renamed variables, e.g., +`x432' instead of `x'. + +Note that the psyntax that Guile uses is a fork, as Guile already had +modules before incompatible modules were added to psyntax -- about 10 +years ago! Thus there are surely a number of bugs that have been fixed +in psyntax since then. If you find one, please notify bug-guile@gnu.org. + +** syntax-rules and syntax-case are available by default. + +There is no longer any need to import the `(ice-9 syncase)' module +(which is now deprecated). The expander may be invoked directly via +`sc-expand', though it is normally searched for via the current module +transformer. + +Also, the helper routines for syntax-case are available in the default +environment as well: `syntax->datum', `datum->syntax', +`bound-identifier=?', `free-identifier=?', `generate-temporaries', +`identifier?', and `syntax-violation'. See the R6RS for documentation. + +** Lexical bindings introduced by hygienic macros may not be referenced + by nonhygienic macros. + +If a lexical binding is introduced by a hygienic macro, it may not be +referenced by a nonhygienic macro. For example, this works: + + (let () + (define-macro (bind-x val body) + `(let ((x ,val)) ,body)) + (define-macro (ref x) + x) + (bind-x 10 (ref x))) + +But this does not: + + (let () + (define-syntax bind-x + (syntax-rules () + ((_ val body) (let ((x val)) body)))) + (define-macro (ref x) + x) + (bind-x 10 (ref x))) + +It is not normal to run into this situation with existing code. However, +as code is ported over from defmacros to syntax-case, it is possible to +run into situations like this. In the future, Guile will probably port +its `while' macro to syntax-case, which makes this issue one to know +about. + +** Macros may no longer be referenced as first-class values. + +In the past, you could evaluate e.g. `if', and get its macro value. Now, +expanding this form raises a syntax error. + +Macros still /exist/ as first-class values, but they must be +/referenced/ via the module system, e.g. `(module-ref (current-module) +'if)'. + +This decision may be revisited before the 2.0 release. Feedback welcome +to guile-devel@gnu.org (subscription required) or bug-guile@gnu.org (no +subscription required). + +** New macro type: syncase-macro + +XXX Need to decide whether to document this for 2.0, probably should: +make-syncase-macro, make-extended-syncase-macro, macro-type, +syncase-macro-type, syncase-macro-binding + +** `(ice-9 syncase)' has been deprecated. + +As syntax-case is available by default, importing `(ice-9 syncase)' has +no effect, and will trigger a deprecation warning. + +** Fix bug in `module-bound?'. + +`module-bound?' was returning true if a module did have a local +variable, but one that was unbound, but another imported module bound +the variable. This was an error, and was fixed. + +** BUG: Automatic compilation will be attempted when it shouldn't. + +For example, the old (lang elisp) modules are meant to be interpreted, +not compiled. This bug will be fixed before 2.0. FIXME 2.0: Should say +something here about module-transformer called for compile. + +** Defmacros may now have docstrings. + +Indeed, any macro may have a docstring. `object-documentation' from +`(ice-9 documentation)' may be used to retrieve the docstring, once you +have a macro value -- but see the above note about first-class macros. +Docstrings are associated with the syntax transformer procedures. + +** `eval-case' has been deprecated, and replaced by `eval-when'. + +The semantics of `eval-when' are easier to understand. It is still +missing documentation, however. + +** Guile is now more strict about prohibiting definitions in expression + contexts. + +Although previous versions of Guile accepted it, the following +expression is not valid, in R5RS or R6RS: + + (if test (define foo 'bar) (define foo 'baz)) + +In this specific case, it would be better to do: + + (define foo (if test 'bar 'baz)) + +It is certainly possible to circumvent this resriction with e.g. +`(module-define! (current-module) 'foo 'baz)'. We would appreciate +feedback about this change (a consequence of using psyntax as the +default expander), and may choose to revisit this situation before 2.0 +in response to user feedback. + +** Defmacros must now produce valid Scheme expressions. + +It used to be that defmacros could unquote in Scheme values, as a way of +supporting partial evaluation, and avoiding some hygiene issues. For +example: + + (define (helper x) ...) + (define-macro (foo bar) + `(,helper ,bar)) + +Assuming this macro is in the `(baz)' module, the direct translation of +this code would be: + + (define (helper x) ...) + (define-macro (foo bar) + `((@@ (baz) helper) ,bar)) + +Of course, one could just use a hygienic macro instead: + + (define-syntax foo + (syntax-rules () + ((_ bar) (helper bar)))) + +** Guile's psyntax now supports docstrings and internal definitions. + +The following Scheme is not strictly legal: + + (define (foo) + "bar" + (define (baz) ...) + (baz)) + +However its intent is fairly clear. Guile interprets "bar" to be the +docstring of `foo', and the definition of `baz' is still in definition +context. + +** Macros need to be defined before their first use. + +It used to be that with lazy memoization, this might work: + + (define (foo x) + (ref x)) + (define-macro (ref x) x) + (foo 1) => 1 + +But now, the body of `foo' is interpreted to mean a call to the toplevel +`ref' function, instead of a macro expansion. The solution is to define +macros before code that uses them. + +** Functions needed by macros at expand-time need to be present at + expand-time. + +For example, this code will work at the REPL: + + (define (double-helper x) (* x x)) + (define-macro (double-literal x) (double-helper x)) + (double-literal 2) => 4 + +But it will not work when a file is compiled, because the definition of +`double-helper' is not present at expand-time. The solution is to wrap +the definition of `double-helper' in `eval-when': + + (eval-when (load compile eval) + (define (double-helper x) (* x x))) + (define-macro (double-literal x) (double-helper x)) + (double-literal 2) => 4 + +See the (currently missing) documentation for eval-when for more +information. + +** New variable, %pre-modules-transformer + +Need to document this one some more. + +** Temporarily removed functions: `macroexpand', `macroexpand-1' + +`macroexpand' will be added back before 2.0. It is unclear how to +implement `macroexpand-1' with syntax-case, though PLT Scheme does prove +that it is possible. + +** New module: (rnrs bytevector) + +See the R6RS for more information. + +** New dependency: GNU libunistring. + + +FIXME bytevectors. + +FIXME unistring. + +more robust threading support. + +syncase knows about @/@@ + +macros and hygiene and modules + +eval-closure-module? what? + +procedure-module / scm_procedure_module + +guile-config info sitedir change -- 922d369 + +guile-config and pkg-config + +(system xref), procedure-callers, procedure-callees, can work as +variables get redefined + +getrlimit and setrlimit wrappers + +FIXME: getrlimit crazy namespaces... + +add method-formals + +BUG? procedure-property 'arity on compiled procedures will be wrong + +BUG: SCM_SNAME -> SCM_SUBR_NAME + +(ice-9 session): +add-value-help-handler! remove-value-help-handler! +add-name-help-handler! remove-name-help-handler! +export module-commentary +procedure-arguments + +procedure->memoizing-macro, procedure->syntax totally superdeprecated? + +FIXME: update copyrights + +ecmascript support? + +new repl... + +guile-tools compile, guile-tools disassemble (does that work?) + +BUG: stack walks to see number of frames, then fills those frames. +sometimes those numbers differ, warning to console, a test case would be +nice. + +FIXME: dance disassembly bug + +srfi-18 + + has formals, body slots; (make-procedure & procedure ?) + +FIXME: rewrite while + +removed (the-environment) + +new function: scm_module_public_interface + +BUG: help at guile prompt + +new procedure, make-promise * New modules (see the manual for details) @@ -20,8 +467,6 @@ In other words the GNU Lesser General Public License, version 3 or later (at the discretion of each person that chooses to redistribute part of Guile). -** Guile now uses Gnulib as a portability aid - * Changes to the stand-alone interpreter * Changes to Scheme functions and syntax @@ -46,13 +491,6 @@ application code. ** Functions for handling `scm_option' now no longer require an argument indicating length of the `scm_t_option' array. -** Primitive procedures (aka. "subrs") are now stored in double cells -This removes the subr table and simplifies the code. - -** Primitive procedures with more than 3 arguments (aka. "gsubrs") are -no longer implemented using the "compiled closure" mechanism. This -simplifies code and reduces both the storage and run-time overhead. - Changes in 1.8.7 (since 1.8.6) diff --git a/THANKS b/THANKS index c0349fc08..90ccd8797 100644 --- a/THANKS +++ b/THANKS @@ -85,6 +85,7 @@ For fixes or providing information which led to a fix: David Pirotte Carlos Pita Ken Raeburn + Juhani Rantanen Andreas Rottmann Hugh Sasse Werner Scheinast From b242715b288b8f076d1617668e77f1ef44dfeeb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 28 May 2009 23:57:31 +0200 Subject: [PATCH 223/375] Import documentation for the R6RS bytevector and port APIs. * doc/ref/api-compound.texi (Uniform Numeric Vectors): Add xref to the bytevector API. * doc/ref/api-data.texi (Bytevectors): New node. * doc/ref/api-io.texi (R6RS I/O Ports): New node. --- doc/ref/api-compound.texi | 8 +- doc/ref/api-data.texi | 397 +++++++++++++++++++++++++++++++++++++- doc/ref/api-io.texi | 266 ++++++++++++++++++++++++- 3 files changed, 668 insertions(+), 3 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index f3fe9584a..2811ee4f2 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2009 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1405,6 +1405,12 @@ C}), but returns a pointer to the elements of a uniform numeric vector of the indicated kind. @end deftypefn +Uniform numeric vectors can be written to and read from input/output +ports using the procedures listed below. However, bytevectors may often +be more convenient for binary input/output since they provide more +flexibility in the interpretation of raw byte sequences +(@pxref{Bytevectors}). + @deffn {Scheme Procedure} uniform-vector-read! uvec [port_or_fd [start [end]]] @deffnx {C Function} scm_uniform_vector_read_x (uvec, port_or_fd, start, end) Fill the elements of @var{uvec} by reading diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index b529199db..8dbad385b 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -45,6 +45,7 @@ For the documentation of such @dfn{compound} data types, see * Characters:: Single characters. * Character Sets:: Sets of characters. * Strings:: Sequences of characters. +* Bytevectors:: Sequences of bytes. * Regular Expressions:: Pattern matching and substitution. * Symbols:: Symbols. * Keywords:: Self-quoting, customizable display keywords. @@ -3746,6 +3747,400 @@ is larger than @var{max_len}, only @var{max_len} bytes have been stored and you probably need to try again with a larger buffer. @end deftypefn +@node Bytevectors +@subsection Bytevectors + +@cindex bytevector +@cindex R6RS + +A @dfn{bytevector} is a raw bit string. The @code{(rnrs bytevector)} +module provides the programming interface specified by the +@uref{http://www.r6rs.org/, Revised Report^6 on the Algorithmic Language +Scheme (R6RS)}. It contains procedures to manipulate bytevectors and +interpret their contents in a number of ways: bytevector contents can be +accessed as signed or unsigned integer of various sizes and endianness, +as IEEE-754 floating point numbers, or as strings. It is a useful tool +to encode and decode binary data. + +The R6RS (Section 4.3.4) specifies an external representation for +bytevectors, whereby the octets (integers in the range 0--255) contained +in the bytevector are represented as a list prefixed by @code{#vu8}: + +@lisp +#vu8(1 53 204) +@end lisp + +denotes a 3-byte bytevector containing the octets 1, 53, and 204. Like +string literals, booleans, etc., bytevectors are ``self-quoting'', i.e., +they do not need to be quoted: + +@lisp +#vu8(1 53 204) +@result{} #vu8(1 53 204) +@end lisp + +Bytevectors can be used with the binary input/output primitives of the +R6RS (@pxref{R6RS I/O Ports}). + +@menu +* Bytevector Endianness:: Dealing with byte order. +* Bytevector Manipulation:: Creating, copying, manipulating bytevectors. +* Bytevectors as Integers:: Interpreting bytes as integers. +* Bytevectors and Integer Lists:: Converting to/from an integer list. +* Bytevectors as Floats:: Interpreting bytes as real numbers. +* Bytevectors as Strings:: Interpreting bytes as Unicode strings. +@end menu + +@node Bytevector Endianness +@subsubsection Endianness + +@cindex endianness +@cindex byte order +@cindex word order + +Some of the following procedures take an @var{endianness} parameter. +The @dfn{endianness} is defined is defined as the order of bytes in +multi-byte numbers: numbers encoded in @dfn{big endian} have their most +significant bytes written first, whereas numbers encoded in @dfn{little +endian} have their least significant bytes first@footnote{Big and little +endian are the most common ``endiannesses'' but others exist. For +instance, the GNU MP library allows @dfn{word order} to be specified +independently of @dfn{byte order} (@pxref{Integer Import and Export,,, +gmp, The GNU Multiple Precision Arithmetic Library Manual}).} Little +endian is the native endianness of the IA32 architecture and its +derivatives, while big endian is native to SPARC and PowerPC, among +others. The @code{native-endianness} procedure returns the native +endianness of the machine it runs on. + +@deffn {Scheme Procedure} native-endianness +@deffnx {C Function} scm_native_endianness () +Return a value denoting the native endianness of the host machine. +@end deffn + +@deffn {Scheme Macro} endianness symbol +Return an object denoting the endianness specified by @var{symbol}. If +@var{symbol} is neither @code{big} nor @code{little} then a compile-time +error is raised. +@end deffn + +@defvr {C Variable} scm_endianness_big +@defvrx {C Variable} scm_endianness_little +The objects denoting big (resp. little) endianness. +@end defvr + + +@node Bytevector Manipulation +@subsubsection Manipulating Bytevectors + +Bytevectors can be created, copied, and analyzed with the following +procedures. + +@deffn {Scheme Procedure} make-bytevector len [fill] +@deffnx {C Function} scm_make_bytevector (len, fill) +@deffnx {C Function} scm_c_make_bytevector (unsigned len) +Return a new bytevector of @var{len} bytes. Optionally, if @var{fill} +is given, fill it with @var{fill}; @var{fill} must be an 8-bit signed +integer, i.e., in the range [-128,127]. +@end deffn + +@deffn {Scheme Procedure} bytevector? obj +@deffnx {C Function} scm_bytevector_p (obj) +Return true if @var{obj} is a bytevector. +@end deffn + +@deffn {Scheme Procedure} bytevector-length bv +@deffnx {C Function} scm_bytevector_length (bv) +Return the length in bytes of bytevector @var{bv}. +@end deffn + +@deffn {Scheme Procedure} bytevector=? bv1 bv2 +@deffnx {C Function} scm_bytevector_eq_p (bv1, bv2) +Return is @var{bv1} equals to @var{bv2}---i.e., if they have the same +length and contents. +@end deffn + +@deffn {Scheme Procedure} bytevector-fill! bv fill +@deffnx {C Function} scm_bytevector_fill_x (bv, fill) +Fill bytevector @var{bv} with @var{fill}, a byte. +@end deffn + +@deffn {Scheme Procedure} bytevector-copy! source source-start target target-start len +@deffnx {C Function} scm_bytevector_copy_x (source, source_start, target, target_start, len) +Copy @var{len} bytes from @var{source} into @var{target}, starting +reading from @var{source-start} (a positive index within @var{source}) +and start writing at @var{target-start}. +@end deffn + +@deffn {Scheme Procedure} bytevector-copy bv +@deffnx {C Function} scm_bytevector_copy (bv) +Return a newly allocated copy of @var{bv}. +@end deffn + +Low-level C macros are available. They do not perform any +type-checking; as such they should be used with care. + +@deftypefn {C Macro} size_t SCM_BYTEVECTOR_LENGTH (bv) +Return the length in bytes of bytevector @var{bv}. +@end deftypefn + +@deftypefn {C Macro} {signed char *} SCM_BYTEVECTOR_CONTENTS (bv) +Return a pointer to the contents of bytevector @var{bv}. +@end deftypefn + + +@node Bytevectors as Integers +@subsubsection Interpreting Bytevector Contents as Integers + +The contents of a bytevector can be interpreted as a sequence of +integers of any given size, sign, and endianness. + +@lisp +(let ((bv (make-bytevector 4))) + (bytevector-u8-set! bv 0 #x12) + (bytevector-u8-set! bv 1 #x34) + (bytevector-u8-set! bv 2 #x56) + (bytevector-u8-set! bv 3 #x78) + + (map (lambda (number) + (number->string number 16)) + (list (bytevector-u8-ref bv 0) + (bytevector-u16-ref bv 0 (endianness big)) + (bytevector-u32-ref bv 0 (endianness little))))) + +@result{} ("12" "1234" "78563412") +@end lisp + +The most generic procedures to interpret bytevector contents as integers +are described below. + +@deffn {Scheme Procedure} bytevector-uint-ref bv index endianness size +@deffnx {Scheme Procedure} bytevector-sint-ref bv index endianness size +@deffnx {C Function} scm_bytevector_uint_ref (bv, index, endianness, size) +@deffnx {C Function} scm_bytevector_sint_ref (bv, index, endianness, size) +Return the @var{size}-byte long unsigned (resp. signed) integer at +index @var{index} in @var{bv}, decoded according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-uint-set! bv index value endianness size +@deffnx {Scheme Procedure} bytevector-sint-set! bv index value endianness size +@deffnx {C Function} scm_bytevector_uint_set_x (bv, index, value, endianness, size) +@deffnx {C Function} scm_bytevector_sint_set_x (bv, index, value, endianness, size) +Set the @var{size}-byte long unsigned (resp. signed) integer at +@var{index} to @var{value}, encoded according to @var{endianness}. +@end deffn + +The following procedures are similar to the ones above, but specialized +to a given integer size: + +@deffn {Scheme Procedure} bytevector-u8-ref bv index +@deffnx {Scheme Procedure} bytevector-s8-ref bv index +@deffnx {Scheme Procedure} bytevector-u16-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-s16-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-u32-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-s32-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-u64-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-s64-ref bv index endianness +@deffnx {C Function} scm_bytevector_u8_ref (bv, index) +@deffnx {C Function} scm_bytevector_s8_ref (bv, index) +@deffnx {C Function} scm_bytevector_u16_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_s16_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_u32_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_s32_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_u64_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_s64_ref (bv, index, endianness) +Return the unsigned @var{n}-bit (signed) integer (where @var{n} is 8, +16, 32 or 64) from @var{bv} at @var{index}, decoded according to +@var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-u8-set! bv index value +@deffnx {Scheme Procedure} bytevector-s8-set! bv index value +@deffnx {Scheme Procedure} bytevector-u16-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-s16-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-u32-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-s32-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-u64-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-s64-set! bv index value endianness +@deffnx {C Function} scm_bytevector_u8_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s8_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_u16_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_s16_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_u32_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_s32_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_u64_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_s64_set_x (bv, index, value, endianness) +Store @var{value} as an @var{n}-bit (signed) integer (where @var{n} is +8, 16, 32 or 64) in @var{bv} at @var{index}, encoded according to +@var{endianness}. +@end deffn + +Finally, a variant specialized for the host's endianness is available +for each of these functions (with the exception of the @code{u8} +accessors, for obvious reasons): + +@deffn {Scheme Procedure} bytevector-u16-native-ref bv index +@deffnx {Scheme Procedure} bytevector-s16-native-ref bv index +@deffnx {Scheme Procedure} bytevector-u32-native-ref bv index +@deffnx {Scheme Procedure} bytevector-s32-native-ref bv index +@deffnx {Scheme Procedure} bytevector-u64-native-ref bv index +@deffnx {Scheme Procedure} bytevector-s64-native-ref bv index +@deffnx {C Function} scm_bytevector_u16_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_s16_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_u32_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_s32_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_u64_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_s64_native_ref (bv, index) +Return the unsigned @var{n}-bit (signed) integer (where @var{n} is 8, +16, 32 or 64) from @var{bv} at @var{index}, decoded according to the +host's native endianness. +@end deffn + +@deffn {Scheme Procedure} bytevector-u16-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-s16-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-u32-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-s32-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-u64-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-s64-native-set! bv index value +@deffnx {C Function} scm_bytevector_u16_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s16_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_u32_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s32_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_u64_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s64_native_set_x (bv, index, value) +Store @var{value} as an @var{n}-bit (signed) integer (where @var{n} is +8, 16, 32 or 64) in @var{bv} at @var{index}, encoded according to the +host's native endianness. +@end deffn + + +@node Bytevectors and Integer Lists +@subsubsection Converting Bytevectors to/from Integer Lists + +Bytevector contents can readily be converted to/from lists of signed or +unsigned integers: + +@lisp +(bytevector->sint-list (u8-list->bytevector (make-list 4 255)) + (endianness little) 2) +@result{} (-1 -1) +@end lisp + +@deffn {Scheme Procedure} bytevector->u8-list bv +@deffnx {C Function} scm_bytevector_to_u8_list (bv) +Return a newly allocated list of unsigned 8-bit integers from the +contents of @var{bv}. +@end deffn + +@deffn {Scheme Procedure} u8-list->bytevector lst +@deffnx {C Function} scm_u8_list_to_bytevector (lst) +Return a newly allocated bytevector consisting of the unsigned 8-bit +integers listed in @var{lst}. +@end deffn + +@deffn {Scheme Procedure} bytevector->uint-list bv endianness size +@deffnx {Scheme Procedure} bytevector->sint-list bv endianness size +@deffnx {C Function} scm_bytevector_to_uint_list (bv, endianness, size) +@deffnx {C Function} scm_bytevector_to_sint_list (bv, endianness, size) +Return a list of unsigned (resp. signed) integers of @var{size} bytes +representing the contents of @var{bv}, decoded according to +@var{endianness}. +@end deffn + +@deffn {Scheme Procedure} uint-list->bytevector lst endianness size +@deffnx {Scheme Procedure} sint-list->bytevector lst endianness size +@deffnx {C Function} scm_uint_list_to_bytevector (lst, endianness, size) +@deffnx {C Function} scm_sint_list_to_bytevector (lst, endianness, size) +Return a new bytevector containing the unsigned (resp. signed) integers +listed in @var{lst} and encoded on @var{size} bytes according to +@var{endianness}. +@end deffn + +@node Bytevectors as Floats +@subsubsection Interpreting Bytevector Contents as Floating Point Numbers + +@cindex IEEE-754 floating point numbers + +Bytevector contents can also be accessed as IEEE-754 single- or +double-precision floating point numbers (respectively 32 and 64-bit +long) using the procedures described here. + +@deffn {Scheme Procedure} bytevector-ieee-single-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-ieee-double-ref bv index endianness +@deffnx {C Function} scm_bytevector_ieee_single_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_ieee_double_ref (bv, index, endianness) +Return the IEEE-754 single-precision floating point number from @var{bv} +at @var{index} according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-ieee-single-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-ieee-double-set! bv index value endianness +@deffnx {C Function} scm_bytevector_ieee_single_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_ieee_double_set_x (bv, index, value, endianness) +Store real number @var{value} in @var{bv} at @var{index} according to +@var{endianness}. +@end deffn + +Specialized procedures are also available: + +@deffn {Scheme Procedure} bytevector-ieee-single-native-ref bv index +@deffnx {Scheme Procedure} bytevector-ieee-double-native-ref bv index +@deffnx {C Function} scm_bytevector_ieee_single_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_ieee_double_native_ref (bv, index) +Return the IEEE-754 single-precision floating point number from @var{bv} +at @var{index} according to the host's native endianness. +@end deffn + +@deffn {Scheme Procedure} bytevector-ieee-single-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-ieee-double-native-set! bv index value +@deffnx {C Function} scm_bytevector_ieee_single_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_ieee_double_native_set_x (bv, index, value) +Store real number @var{value} in @var{bv} at @var{index} according to +the host's native endianness. +@end deffn + + +@node Bytevectors as Strings +@subsubsection Interpreting Bytevector Contents as Unicode Strings + +@cindex Unicode string encoding + +Bytevector contents can also be interpreted as Unicode strings encoded +in one of the most commonly available encoding formats@footnote{Guile +1.8 does @emph{not} support Unicode strings. Therefore, the procedures +described here assume that Guile strings are internally encoded +according to the current locale. For instance, if @code{$LC_CTYPE} is +@code{fr_FR.ISO-8859-1}, then @code{string->utf-8} @i{et al.} will +assume that Guile strings are Latin-1-encoded.}. + +@lisp +(utf8->string (u8-list->bytevector '(99 97 102 101))) +@result{} "cafe" + +(string->utf8 "caf@'e") ;; SMALL LATIN LETTER E WITH ACUTE ACCENT +@result{} #vu8(99 97 102 195 169) +@end lisp + +@deffn {Scheme Procedure} string->utf8 str +@deffnx {Scheme Procedure} string->utf16 str +@deffnx {Scheme Procedure} string->utf32 str +@deffnx {C Function} scm_string_to_utf8 (str) +@deffnx {C Function} scm_string_to_utf16 (str) +@deffnx {C Function} scm_string_to_utf32 (str) +Return a newly allocated bytevector that contains the UTF-8, UTF-16, or +UTF-32 (aka. UCS-4) encoding of @var{str}. +@end deffn + +@deffn {Scheme Procedure} utf8->string utf +@deffnx {Scheme Procedure} utf16->string utf +@deffnx {Scheme Procedure} utf32->string utf +@deffnx {C Function} scm_utf8_to_string (utf) +@deffnx {C Function} scm_utf16_to_string (utf) +@deffnx {C Function} scm_utf32_to_string (utf) +Return a newly allocated string that contains from the UTF-8-, UTF-16-, +or UTF-32-decoded contents of bytevector @var{utf}. +@end deffn + + @node Regular Expressions @subsection Regular Expressions @tpindex Regular expressions diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index f69d07ede..12c19b7dc 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -18,6 +18,7 @@ * Block Reading and Writing:: Reading and writing blocks of text. * Default Ports:: Defaults for input, output and errors. * Port Types:: Types of port and how to make them. +* R6RS I/O Ports:: The R6RS port API. * I/O Extensions:: Using and extending ports in C. @end menu @@ -1023,6 +1024,269 @@ documentation for @code{open-file} in @ref{File Ports}. @end deffn +@node R6RS I/O Ports +@subsection R6RS I/O Ports + +@cindex R6RS +@cindex R6RS ports + +The I/O port API of the @uref{http://www.r6rs.org/, Revised Report^6 on +the Algorithmic Language Scheme (R6RS)} is provided by the @code{(rnrs +io ports)} module. It provides features, such as binary I/O and Unicode +string I/O, that complement or refine Guile's historical port API +presented above (@pxref{Input and Output}). + +@c FIXME: Update description when implemented. +@emph{Note}: The implementation of this R6RS API is currently far from +complete, notably due to the lack of support for Unicode I/O and strings. + +@menu +* R6RS End-of-File:: The end-of-file object. +* R6RS Port Manipulation:: Manipulating R6RS ports. +* R6RS Binary Input:: Binary input. +* R6RS Binary Output:: Binary output. +@end menu + +@node R6RS End-of-File +@subsubsection The End-of-File Object + +@cindex EOF +@cindex end-of-file + +R5RS' @code{eof-object?} procedure is provided by the @code{(rnrs io +ports)} module: + +@deffn {Scheme Procedure} eof-object? obj +@deffnx {C Function} scm_eof_object_p (obj) +Return true if @var{obj} is the end-of-file (EOF) object. +@end deffn + +In addition, the following procedure is provided: + +@deffn {Scheme Procedure} eof-object +@deffnx {C Function} scm_eof_object () +Return the end-of-file (EOF) object. + +@lisp +(eof-object? (eof-object)) +@result{} #t +@end lisp +@end deffn + + +@node R6RS Port Manipulation +@subsubsection Port Manipulation + +The procedures listed below operate on any kind of R6RS I/O port. + +@deffn {Scheme Procedure} port-position port +If @var{port} supports it (see below), return the offset (an integer) +indicating where the next octet will be read from/written to in +@var{port}. If @var{port} does not support this operation, an error +condition is raised. + +This is similar to Guile's @code{seek} procedure with the +@code{SEEK_CUR} argument (@pxref{Random Access}). +@end deffn + +@deffn {Scheme Procedure} port-has-port-position? port +Return @code{#t} is @var{port} supports @code{port-position}. +@end deffn + +@deffn {Scheme Procedure} set-port-position! port offset +If @var{port} supports it (see below), set the position where the next +octet will be read from/written to @var{port} to @var{offset} (an +integer). If @var{port} does not support this operation, an error +condition is raised. + +This is similar to Guile's @code{seek} procedure with the +@code{SEEK_SET} argument (@pxref{Random Access}). +@end deffn + +@deffn {Scheme Procedure} port-has-set-port-position!? port +Return @code{#t} is @var{port} supports @code{set-port-position!}. +@end deffn + +@deffn {Scheme Procedure} call-with-port port proc +Call @var{proc}, passing it @var{port} and closing @var{port} upon exit +of @var{proc}. Return the return values of @var{proc}. +@end deffn + + +@node R6RS Binary Input +@subsubsection Binary Input + +@cindex binary input + +R6RS binary input ports can be created with the procedures described +below. + +@deffn {Scheme Procedure} open-bytevector-input-port bv [transcoder] +@deffnx {C Function} scm_open_bytevector_input_port (bv, transcoder) +Return an input port whose contents are drawn from bytevector @var{bv} +(@pxref{Bytevectors}). + +@c FIXME: Update description when implemented. +The @var{transcoder} argument is currently not supported. +@end deffn + +@cindex custom binary input ports + +@deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close +@deffnx {C Function} scm_make_custom_binary_input_port (id, read!, get-position, set-position!, close) +Return a new custom binary input port@footnote{This is similar in spirit +to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a +string) whose input is drained by invoking @var{read!} and passing it a +bytevector, an index where bytes should be written, and the number of +bytes to read. The @code{read!} procedure must return an integer +indicating the number of bytes read, or @code{0} to indicate the +end-of-file. + +Optionally, if @var{get-position} is not @code{#f}, it must be a thunk +that will be called when @var{port-position} is invoked on the custom +binary port and should return an integer indicating the position within +the underlying data stream; if @var{get-position} was not supplied, the +returned port does not support @var{port-position}. + +Likewise, if @var{set-position!} is not @code{#f}, it should be a +one-argument procedure. When @var{set-port-position!} is invoked on the +custom binary input port, @var{set-position!} is passed an integer +indicating the position of the next byte is to read. + +Finally, if @var{close} is not @code{#f}, it must be a thunk. It is +invoked when the custom binary input port is closed. + +Using a custom binary input port, the @code{open-bytevector-input-port} +procedure could be implemented as follows: + +@lisp +(define (open-bytevector-input-port source) + (define position 0) + (define length (bytevector-length source)) + + (define (read! bv start count) + (let ((count (min count (- length position)))) + (bytevector-copy! source position + bv start count) + (set! position (+ position count)) + count)) + + (define (get-position) position) + + (define (set-position! new-position) + (set! position new-position)) + + (make-custom-binary-input-port "the port" read! + get-position + set-position!)) + +(read (open-bytevector-input-port (string->utf8 "hello"))) +@result{} hello +@end lisp +@end deffn + +@cindex binary input +Binary input is achieved using the procedures below: + +@deffn {Scheme Procedure} get-u8 port +@deffnx {C Function} scm_get_u8 (port) +Return an octet read from @var{port}, a binary input port, blocking as +necessary, or the end-of-file object. +@end deffn + +@deffn {Scheme Procedure} lookahead-u8 port +@deffnx {C Function} scm_lookahead_u8 (port) +Like @code{get-u8} but does not update @var{port}'s position to point +past the octet. +@end deffn + +@deffn {Scheme Procedure} get-bytevector-n port count +@deffnx {C Function} scm_get_bytevector_n (port, count) +Read @var{count} octets from @var{port}, blocking as necessary and +return a bytevector containing the octets read. If fewer bytes are +available, a bytevector smaller than @var{count} is returned. +@end deffn + +@deffn {Scheme Procedure} get-bytevector-n! port bv start count +@deffnx {C Function} scm_get_bytevector_n_x (port, bv, start, count) +Read @var{count} bytes from @var{port} and store them in @var{bv} +starting at index @var{start}. Return either the number of bytes +actually read or the end-of-file object. +@end deffn + +@deffn {Scheme Procedure} get-bytevector-some port +@deffnx {C Function} scm_get_bytevector_some (port) +Read from @var{port}, blocking as necessary, until data are available or +and end-of-file is reached. Return either a new bytevector containing +the data read or the end-of-file object. +@end deffn + +@deffn {Scheme Procedure} get-bytevector-all port +@deffnx {C Function} scm_get_bytevector_all (port) +Read from @var{port}, blocking as necessary, until the end-of-file is +reached. Return either a new bytevector containing the data read or the +end-of-file object (if no data were available). +@end deffn + +@node R6RS Binary Output +@subsubsection Binary Output + +Binary output ports can be created with the procedures below. + +@deffn {Scheme Procedure} open-bytevector-output-port [transcoder] +@deffnx {C Function} scm_open_bytevector_output_port (transcoder) +Return two values: a binary output port and a procedure. The latter +should be called with zero arguments to obtain a bytevector containing +the data accumulated by the port, as illustrated below. + +@lisp +(call-with-values + (lambda () + (open-bytevector-output-port)) + (lambda (port get-bytevector) + (display "hello" port) + (get-bytevector))) + +@result{} #vu8(104 101 108 108 111) +@end lisp + +@c FIXME: Update description when implemented. +The @var{transcoder} argument is currently not supported. +@end deffn + +@cindex custom binary output ports + +@deffn {Scheme Procedure} make-custom-binary-output-port id write! get-position set-position! close +@deffnx {C Function} scm_make_custom_binary_output_port (id, write!, get-position, set-position!, close) +Return a new custom binary output port named @var{id} (a string) whose +output is sunk by invoking @var{write!} and passing it a bytevector, an +index where bytes should be read from this bytevector, and the number of +bytes to be ``written''. The @code{write!} procedure must return an +integer indicating the number of bytes actually written; when it is +passed @code{0} as the number of bytes to write, it should behave as +though an end-of-file was sent to the byte sink. + +The other arguments are as for @code{make-custom-binary-input-port} +(@pxref{R6RS Binary Input, @code{make-custom-binary-input-port}}). +@end deffn + +@cindex binary output +Writing to a binary output port can be done using the following +procedures: + +@deffn {Scheme Procedure} put-u8 port octet +@deffnx {C Function} scm_put_u8 (port, octet) +Write @var{octet}, an integer in the 0--255 range, to @var{port}, a +binary output port. +@end deffn + +@deffn {Scheme Procedure} put-bytevector port bv [start [count]] +@deffnx {C Function} scm_put_bytevector (port, bv, start, count) +Write the contents of @var{bv} to @var{port}, optionally starting at +index @var{start} and limiting to @var{count} octets. +@end deffn + + @node I/O Extensions @subsection Using and Extending Ports in C From 55bf8cb7af47cde26e6a70dae056752c8265508d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 00:10:21 +0200 Subject: [PATCH 224/375] Fix `equal?' on bytevectors. * libguile/bytevectors.c (bytevector_equal_p): New function. * test-suite/tests/bytevectors.test ("2.3 Operations on Bytes and Octets")["equal?"]: New test. --- libguile/bytevectors.c | 5 +++++ test-suite/tests/bytevectors.test | 7 ++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 0846d9120..2484a64a4 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -300,6 +300,11 @@ SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, return 1; } +SCM_SMOB_EQUALP (scm_tc16_bytevector, bytevector_equal_p, bv1, bv2) +{ + return scm_bytevector_eq_p (bv1, bv2); +} + SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv) { diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index c7697b13c..95d6c403a 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -123,7 +123,12 @@ (bytevector-sint-set! b 0 -16 (endianness big) 2) (bytevector-sint-set! b 1 -16 (endianness little) 2) (equal? (bytevector->u8-list b) - '(#xff #xf0 #xff))))) + '(#xff #xf0 #xff)))) + + (pass-if "equal?" + (let ((bv1 (u8-list->bytevector (iota 123))) + (bv2 (u8-list->bytevector (iota 123)))) + (equal? bv1 bv2)))) (with-test-prefix "2.4 Operations on Integers of Arbitrary Size" From 0ba0b3848913ca871235ad4b2f8ef184bf8f552b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 00:47:11 +0200 Subject: [PATCH 225/375] Implement R6RS bytevector read syntax. * libguile/read.c (scm_read_bytevector): New function. (scm_read_sharp): Add `v' case for bytevectors. * test-suite/lib.scm (exception:read-error): New variable. * test-suite/tests/bytevectors.test ("Datum Syntax"): New test set. --- libguile/read.c | 29 ++++++++++++++++- test-suite/lib.scm | 5 ++- test-suite/tests/bytevectors.test | 54 +++++++++++++++++++++++++++++++ 3 files changed, 86 insertions(+), 2 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 6fafc43ba..bd028ea52 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008 Free Software +/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008, 2009 Free Software * Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -29,6 +29,7 @@ #include #include "libguile/_scm.h" +#include "libguile/bytevectors.h" #include "libguile/chars.h" #include "libguile/eval.h" #include "libguile/unif.h" @@ -882,6 +883,30 @@ scm_read_srfi4_vector (int chr, SCM port) return scm_i_read_array (port, chr); } +static SCM +scm_read_bytevector (int chr, SCM port) +{ + chr = scm_getc (port); + if (chr != 'u') + goto syntax; + + chr = scm_getc (port); + if (chr != '8') + goto syntax; + + chr = scm_getc (port); + if (chr != '(') + goto syntax; + + return scm_u8_list_to_bytevector (scm_read_sexp (chr, port)); + + syntax: + scm_i_input_error ("read_bytevector", port, + "invalid bytevector prefix", + SCM_MAKE_CHAR (chr)); + return SCM_UNSPECIFIED; +} + static SCM scm_read_guile_bit_vector (int chr, SCM port) { @@ -1050,6 +1075,8 @@ scm_read_sharp (int chr, SCM port) case 'f': /* This one may return either a boolean or an SRFI-4 vector. */ return (scm_read_srfi4_vector (chr, port)); + case 'v': + return (scm_read_bytevector (chr, port)); case '*': return (scm_read_guile_bit_vector (chr, port)); case 't': diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 0a01a2756..8190d1fd0 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,5 +1,5 @@ ;;;; test-suite/lib.scm --- generic support for testing -;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -32,6 +32,7 @@ exception:system-error exception:miscellaneous-error exception:string-contains-nul + exception:read-error ;; Reporting passes and failures. run-test @@ -265,6 +266,8 @@ (cons 'system-error ".*")) (define exception:miscellaneous-error (cons 'misc-error "^.*")) +(define exception:read-error + (cons 'read-error "^.*$")) ;; as per throw in scm_to_locale_stringn() (define exception:string-contains-nul diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 95d6c403a..342f08a24 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -530,6 +530,60 @@ 4))))))) + +(with-test-prefix "Datum Syntax" + + (pass-if "empty" + (equal? (with-input-from-string "#vu8()" read) + (make-bytevector 0))) + + (pass-if "simple" + (equal? (with-input-from-string "#vu8(1 2 3 4 5)" read) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if ">127" + (equal? (with-input-from-string "#vu8(0 255 127 128)" read) + (u8-list->bytevector '(0 255 127 128)))) + + (pass-if "self-evaluating" + (equal? (eval (with-input-from-string "#vu8(1 2 3 4 5)" read) + (current-module)) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if "quoted" + (equal? (eval (with-input-from-string "'#vu8(1 2 3 4 5)" read) + (current-module)) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if "literal simple" + (equal? #vu8(1 2 3 4 5) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if "literal >127" + (equal? #vu8(0 255 127 128) + (u8-list->bytevector '(0 255 127 128)))) + + (pass-if "literal quoted" + (equal? '#vu8(1 2 3 4 5) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if-exception "incorrect prefix" + exception:read-error + (with-input-from-string "#vi8(1 2 3)" read)) + + (pass-if-exception "extraneous space" + exception:read-error + (with-input-from-string "#vu8 (1 2 3)" read)) + + (pass-if-exception "negative integers" + exception:wrong-type-arg + (with-input-from-string "#vu8(-1 -2 -3)" read)) + + (pass-if-exception "out-of-range integers" + exception:wrong-type-arg + (with-input-from-string "#vu8(0 256)" read))) + + ;;; Local Variables: ;;; coding: latin-1 ;;; mode: scheme From 81e002fcb90c99ac2840dcde81f286772b1fb1a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 02:14:22 +0200 Subject: [PATCH 226/375] Fix the REPL's `,compile' command. * module/system/repl/command.scm (compile): Use `guile:disassemble' instead of the former `disassemble-objcode'. --- module/system/repl/command.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 47f1a9aa2..e6b492996 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -266,7 +266,7 @@ Generate compiled code. -O Enable optimization -D Add debug information" (let ((x (apply repl-compile repl (repl-parse repl form) opts))) - (cond ((objcode? x) (disassemble-objcode x)) + (cond ((objcode? x) (guile:disassemble x)) (else (repl-print repl x))))) (define guile:compile-file compile-file) From 159399850de811f23e45d439aecf452b0137d847 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 02:35:57 +0200 Subject: [PATCH 227/375] Fix decompilation of the `load-array' instruction. This allows, e.g., ",c #u8(1 2 3)" at the REPL to actually work instead of failing to decode `load-array'. * module/language/assembly/decompile-bytecode.scm (decode-bytecode): Account for the `load-array' instruction, which is followed by a bytevector instead of a string. We should find a more elegant way to do that. --- .../language/assembly/decompile-bytecode.scm | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index 2ad3bc6a4..fdf27ec62 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -22,6 +22,7 @@ #:use-module (system vm instruction) #:use-module (system base pmatch) #:use-module (srfi srfi-4) + #:use-module (rnrs bytevector) #:use-module (language assembly) #:export (decompile-bytecode)) @@ -97,14 +98,24 @@ ((eq? inst 'load-program) (decode-load-program pop)) ((< (instruction-length inst) 0) - (let* ((len (let* ((a (pop)) (b (pop)) (c (pop))) + (let* ((make-sequence + (if (eq? inst 'load-array) + make-bytevector + make-string)) + (sequence-set! + (if (eq? inst 'load-array) + bytevector-u8-set! + (lambda (str pos value) + (string-set! str pos (integer->char value))))) + + (len (let* ((a (pop)) (b (pop)) (c (pop))) (+ (ash a 16) (ash b 8) c))) - (str (make-string len))) + (seq (make-sequence len))) (let lp ((i 0)) (if (= i len) - `(,inst ,str) + `(,inst ,seq) (begin - (string-set! str i (integer->char (pop))) + (sequence-set! seq i (pop)) (lp (1+ i))))))) (else ;; fixed length From 96b73e84bbb6d88c73a99bf46450642d79612be0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2009 11:19:34 +0200 Subject: [PATCH 228/375] another draft of NEWS * NEWS: Another draft. --- NEWS | 513 ++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 276 insertions(+), 237 deletions(-) diff --git a/NEWS b/NEWS index 303caea93..141855591 100644 --- a/NEWS +++ b/NEWS @@ -5,7 +5,21 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. -Changes in 1.9.1 (changes since the 1.8.x series): +Changes in 1.9.0 (changes since the 1.8.x series): + +* New modules (see the manual for details) + +** `(srfi srfi-18)', more sophisticated multithreading support +** `(ice-9 i18n)', internationalization support +** `(rnrs bytevector)', the R6RS bytevector API +** `(system xref)', a cross-referencing facility (FIXME undocumented) + +* Changes to the stand-alone interpreter + +** Guile now can compile Scheme to bytecode for a custom virtual machine. + +Compiled code loads much faster than Scheme source code, and runs around +3 or 4 times as fast, generating much less garbage in the process. ** The stack limit is now initialized from the environment. @@ -13,11 +27,31 @@ If getrlimit(2) is available and a stack limit is set, Guile will set its stack limit to 80% of the rlimit. Otherwise the limit is 160000 words, a four-fold increase from the earlier default limit. -** Fix bad interaction between `false-if-exception' and stack-call. +** New environment variables: GUILE_LOAD_COMPILED_PATH, + GUILE_SYSTEM_LOAD_COMPILED_PATH -Exceptions thrown by `false-if-exception' were erronously causing the -stack to be saved, causing later errors to show the incorrectly-saved -backtrace. This has been fixed. +GUILE_LOAD_COMPILED_PATH is for compiled files what GUILE_LOAD_PATH is +for source files. It is a different path, however, because compiled +files are architecture-specific. GUILE_SYSTEM_LOAD_COMPILED_PATH is like +GUILE_SYSTEM_PATH. + +** New read-eval-print loop (REPL) implementation + +Running Guile with no arguments drops the user into the new REPL. While +it is self-documenting to an extent, the new REPL has not yet been +documented in the manual. This will be fixed before 2.0. + +** New `guile-tools' commands: `compile', `disassemble' + +Pass the --help command-line option to these commands for more +information. + +* Changes to Scheme functions and syntax + +** Procedure removed: `the-environment' + +This procedure was part of the interpreter's execution model, and does +not apply to the compiler. ** Files loaded with primitive-load-path will now be compiled automatically. @@ -38,30 +72,191 @@ ccache's behavior for C files. To inhibit autocompilation, set the GUILE_AUTO_COMPILE environment variable to 0, or pass --no-autocompile on the Guile command line. -** New environment variables: GUILE_LOAD_COMPILED_PATH, - GUILE_SYSTEM_LOAD_COMPILED_PATH +Note that there is currently a bug here: automatic compilation will +sometimes be attempted when it shouldn't. -GUILE_LOAD_COMPILED_PATH is for compiled files what GUILE_LOAD_PATH is -for source files. It is a different path, however, because compiled -files are architecture-specific. GUILE_SYSTEM_LOAD_COMPILED_PATH is like -GUILE_SYSTEM_PATH. +For example, the old (lang elisp) modules are meant to be interpreted, +not compiled. This bug will be fixed before 2.0. FIXME 2.0: Should say +something here about module-transformer called for compile. -** New global variables: %load-compiled-path, %load-compiled-extensions +** New POSIX procedures: `getrlimit' and `setrlimit' -These are analogous to %load-path and %load-extensions. +Note however that the interface of these functions is likely to change +in the next prerelease. -** New installation directory: $(pkglibdir)/1.9/ccache +** New procedure in `(oops goops)': `method-formals' -If $(libdir) is /usr/lib, for example, Guile will install its .go files -to /usr/lib/guile/1.9/ccache. These files are architecture-specific. +** BUG: (procedure-property func 'arity) does not work on compiled + procedures -** scm_primitive_load_path has additional argument, exception_on_error +This will be fixed one way or another before 2.0. -** scm_stat has additional argument, exception_on_error +** New procedures in (ice-9 session): `add-value-help-handler!', + `remove-value-help-handler!', `add-name-help-handler!' + `remove-name-help-handler!', `procedure-arguments', -** New entry into %guile-build-info: `ccachedir' +The value and name help handlers provide some minimal extensibility to +the help interface. Guile-lib's `(texinfo reflection)' uses them, for +example, to make stexinfo help documentation available. See those +procedures' docstrings for more information. -Probably should be removed? +`procedure-arguments' describes the arguments that a procedure can take, +combining arity and formals. For example: + + (procedure-arguments resolve-interface) + => ((required . (name)) (rest . args)) + +Additionally, `module-commentary' is now publically exported from +`(ice-9 session). + +** Deprecated: `procedure->memoizing-macro', `procedure->syntax' + +These procedures will not work with syncase expansion, and indeed are +not used in the normal course of Guile. They are still used by the old +Emacs Lisp support, however. + +** New language: ECMAScript + +Guile now ships with one other high-level language supported, +ECMAScript. The goal is to support all of version 3.1 of the standard, +but not all of the libraries are there yet. This support is not yet +documented; ask on the mailing list if you are interested. + +** Defmacros may now have docstrings. + +Indeed, any macro may have a docstring. `object-documentation' from +`(ice-9 documentation)' may be used to retrieve the docstring, once you +have a macro value -- but see the above note about first-class macros. +Docstrings are associated with the syntax transformer procedures. + +** The psyntax expander now knows how to interpret the @ and @@ special + forms. + +** The psyntax expander is now hygienic with respect to modules. + +Free variables in a macro are scoped in the module that the macro was +defined in, not in the module the macro is used in. For example, code +like this works now: + + (define-module (foo) #:export (bar)) + (define (helper x) ...) + (define-syntax bar + (syntax-rules () ((_ x) (helper x)))) + + (define-module (baz) #:use-module (foo)) + (bar qux) + +It used to be you had to export `helper' from `(foo)' as well. +Thankfully, this has been fixed. + +** New function, `procedure-module' + +While useful on its own, `procedure-module' is used by psyntax on syntax +transformers to determine the module in which to scope introduced +identifiers. + +** `eval-case' has been deprecated, and replaced by `eval-when'. + +The semantics of `eval-when' are easier to understand. It is still +missing documentation, however. + +** Guile is now more strict about prohibiting definitions in expression + contexts. + +Although previous versions of Guile accepted it, the following +expression is not valid, in R5RS or R6RS: + + (if test (define foo 'bar) (define foo 'baz)) + +In this specific case, it would be better to do: + + (define foo (if test 'bar 'baz)) + +It is certainly possible to circumvent this resriction with e.g. +`(module-define! (current-module) 'foo 'baz)'. We would appreciate +feedback about this change (a consequence of using psyntax as the +default expander), and may choose to revisit this situation before 2.0 +in response to user feedback. + +** Defmacros must now produce valid Scheme expressions. + +It used to be that defmacros could unquote in Scheme values, as a way of +supporting partial evaluation, and avoiding some hygiene issues. For +example: + + (define (helper x) ...) + (define-macro (foo bar) + `(,helper ,bar)) + +Assuming this macro is in the `(baz)' module, the direct translation of +this code would be: + + (define (helper x) ...) + (define-macro (foo bar) + `((@@ (baz) helper) ,bar)) + +Of course, one could just use a hygienic macro instead: + + (define-syntax foo + (syntax-rules () + ((_ bar) (helper bar)))) + +** Guile's psyntax now supports docstrings and internal definitions. + +The following Scheme is not strictly legal: + + (define (foo) + "bar" + (define (baz) ...) + (baz)) + +However its intent is fairly clear. Guile interprets "bar" to be the +docstring of `foo', and the definition of `baz' is still in definition +context. + +** Macros need to be defined before their first use. + +It used to be that with lazy memoization, this might work: + + (define (foo x) + (ref x)) + (define-macro (ref x) x) + (foo 1) => 1 + +But now, the body of `foo' is interpreted to mean a call to the toplevel +`ref' function, instead of a macro expansion. The solution is to define +macros before code that uses them. + +** Functions needed by macros at expand-time need to be present at + expand-time. + +For example, this code will work at the REPL: + + (define (double-helper x) (* x x)) + (define-macro (double-literal x) (double-helper x)) + (double-literal 2) => 4 + +But it will not work when a file is compiled, because the definition of +`double-helper' is not present at expand-time. The solution is to wrap +the definition of `double-helper' in `eval-when': + + (eval-when (load compile eval) + (define (double-helper x) (* x x))) + (define-macro (double-literal x) (double-helper x)) + (double-literal 2) => 4 + +See the (currently missing) documentation for eval-when for more +information. + +** New variable, %pre-modules-transformer + +Need to document this one some more. + +** Temporarily removed functions: `macroexpand', `macroexpand-1' + +`macroexpand' will be added back before 2.0. It is unclear how to +implement `macroexpand-1' with syntax-case, though PLT Scheme does prove +that it is possible. ** New reader macros: #' #` #, #,@ @@ -253,223 +448,6 @@ XXX Need to decide whether to document this for 2.0, probably should: make-syncase-macro, make-extended-syncase-macro, macro-type, syncase-macro-type, syncase-macro-binding -** `(ice-9 syncase)' has been deprecated. - -As syntax-case is available by default, importing `(ice-9 syncase)' has -no effect, and will trigger a deprecation warning. - -** Fix bug in `module-bound?'. - -`module-bound?' was returning true if a module did have a local -variable, but one that was unbound, but another imported module bound -the variable. This was an error, and was fixed. - -** BUG: Automatic compilation will be attempted when it shouldn't. - -For example, the old (lang elisp) modules are meant to be interpreted, -not compiled. This bug will be fixed before 2.0. FIXME 2.0: Should say -something here about module-transformer called for compile. - -** Defmacros may now have docstrings. - -Indeed, any macro may have a docstring. `object-documentation' from -`(ice-9 documentation)' may be used to retrieve the docstring, once you -have a macro value -- but see the above note about first-class macros. -Docstrings are associated with the syntax transformer procedures. - -** `eval-case' has been deprecated, and replaced by `eval-when'. - -The semantics of `eval-when' are easier to understand. It is still -missing documentation, however. - -** Guile is now more strict about prohibiting definitions in expression - contexts. - -Although previous versions of Guile accepted it, the following -expression is not valid, in R5RS or R6RS: - - (if test (define foo 'bar) (define foo 'baz)) - -In this specific case, it would be better to do: - - (define foo (if test 'bar 'baz)) - -It is certainly possible to circumvent this resriction with e.g. -`(module-define! (current-module) 'foo 'baz)'. We would appreciate -feedback about this change (a consequence of using psyntax as the -default expander), and may choose to revisit this situation before 2.0 -in response to user feedback. - -** Defmacros must now produce valid Scheme expressions. - -It used to be that defmacros could unquote in Scheme values, as a way of -supporting partial evaluation, and avoiding some hygiene issues. For -example: - - (define (helper x) ...) - (define-macro (foo bar) - `(,helper ,bar)) - -Assuming this macro is in the `(baz)' module, the direct translation of -this code would be: - - (define (helper x) ...) - (define-macro (foo bar) - `((@@ (baz) helper) ,bar)) - -Of course, one could just use a hygienic macro instead: - - (define-syntax foo - (syntax-rules () - ((_ bar) (helper bar)))) - -** Guile's psyntax now supports docstrings and internal definitions. - -The following Scheme is not strictly legal: - - (define (foo) - "bar" - (define (baz) ...) - (baz)) - -However its intent is fairly clear. Guile interprets "bar" to be the -docstring of `foo', and the definition of `baz' is still in definition -context. - -** Macros need to be defined before their first use. - -It used to be that with lazy memoization, this might work: - - (define (foo x) - (ref x)) - (define-macro (ref x) x) - (foo 1) => 1 - -But now, the body of `foo' is interpreted to mean a call to the toplevel -`ref' function, instead of a macro expansion. The solution is to define -macros before code that uses them. - -** Functions needed by macros at expand-time need to be present at - expand-time. - -For example, this code will work at the REPL: - - (define (double-helper x) (* x x)) - (define-macro (double-literal x) (double-helper x)) - (double-literal 2) => 4 - -But it will not work when a file is compiled, because the definition of -`double-helper' is not present at expand-time. The solution is to wrap -the definition of `double-helper' in `eval-when': - - (eval-when (load compile eval) - (define (double-helper x) (* x x))) - (define-macro (double-literal x) (double-helper x)) - (double-literal 2) => 4 - -See the (currently missing) documentation for eval-when for more -information. - -** New variable, %pre-modules-transformer - -Need to document this one some more. - -** Temporarily removed functions: `macroexpand', `macroexpand-1' - -`macroexpand' will be added back before 2.0. It is unclear how to -implement `macroexpand-1' with syntax-case, though PLT Scheme does prove -that it is possible. - -** New module: (rnrs bytevector) - -See the R6RS for more information. - -** New dependency: GNU libunistring. - - -FIXME bytevectors. - -FIXME unistring. - -more robust threading support. - -syncase knows about @/@@ - -macros and hygiene and modules - -eval-closure-module? what? - -procedure-module / scm_procedure_module - -guile-config info sitedir change -- 922d369 - -guile-config and pkg-config - -(system xref), procedure-callers, procedure-callees, can work as -variables get redefined - -getrlimit and setrlimit wrappers - -FIXME: getrlimit crazy namespaces... - -add method-formals - -BUG? procedure-property 'arity on compiled procedures will be wrong - -BUG: SCM_SNAME -> SCM_SUBR_NAME - -(ice-9 session): -add-value-help-handler! remove-value-help-handler! -add-name-help-handler! remove-name-help-handler! -export module-commentary -procedure-arguments - -procedure->memoizing-macro, procedure->syntax totally superdeprecated? - -FIXME: update copyrights - -ecmascript support? - -new repl... - -guile-tools compile, guile-tools disassemble (does that work?) - -BUG: stack walks to see number of frames, then fills those frames. -sometimes those numbers differ, warning to console, a test case would be -nice. - -FIXME: dance disassembly bug - -srfi-18 - - has formals, body slots; (make-procedure & procedure ?) - -FIXME: rewrite while - -removed (the-environment) - -new function: scm_module_public_interface - -BUG: help at guile prompt - -new procedure, make-promise - -* New modules (see the manual for details) - -** `(srfi srfi-18)', multithreading support -** The `(ice-9 i18n)' module provides internationalization support - -* Changes to the distribution - -** Guile's license is now LGPLv3+ - -In other words the GNU Lesser General Public License, version 3 or -later (at the discretion of each person that chooses to redistribute -part of Guile). - -* Changes to the stand-alone interpreter -* Changes to Scheme functions and syntax - ** A new 'memoize-symbol evaluator trap has been added. This trap can be used for efficiently implementing a Scheme code coverage. @@ -479,6 +457,33 @@ This slightly improves program startup times. ** New thread cancellation and thread cleanup API See `cancel-thread', `set-thread-cleanup!', and `thread-cleanup'. +** Fix bad interaction between `false-if-exception' and stack-call. + +Exceptions thrown by `false-if-exception' were erronously causing the +stack to be saved, causing later errors to show the incorrectly-saved +backtrace. This has been fixed. + +** New global variables: %load-compiled-path, %load-compiled-extensions + +These are analogous to %load-path and %load-extensions. + +** New procedure, `make-promise' + +`(make-promise (lambda () foo))' is equivalent to `(delay foo)'. + +** New entry into %guile-build-info: `ccachedir' + +** Fix bug in `module-bound?'. + +`module-bound?' was returning true if a module did have a local +variable, but one that was unbound, but another imported module bound +the variable. This was an error, and was fixed. + +** `(ice-9 syncase)' has been deprecated. + +As syntax-case is available by default, importing `(ice-9 syncase)' has +no effect, and will trigger a deprecation warning. + * Changes to the C interface ** The GH interface (deprecated in version 1.6, 2001) was removed. @@ -491,6 +496,40 @@ application code. ** Functions for handling `scm_option' now no longer require an argument indicating length of the `scm_t_option' array. +** scm_primitive_load_path has additional argument, exception_on_error + +** New C function: scm_module_public_interface + +This procedure corresponds to Scheme's `module-public-interface'. + +** scm_stat has additional argument, exception_on_error + +* Changes to the distribution + +** Guile's license is now LGPLv3+ + +In other words the GNU Lesser General Public License, version 3 or +later (at the discretion of each person that chooses to redistribute +part of Guile). + +** `guile-config' will be deprecated in favor of `pkg-config' + +`guile-config' has been rewritten to get its information from +pkg-config, so this should be a transparent change. Note however that +guile.m4 has yet to be modified to call pkg-config instead of +guile-config. + +** New installation directory: $(pkglibdir)/1.9/ccache + +If $(libdir) is /usr/lib, for example, Guile will install its .go files +to /usr/lib/guile/1.9/ccache. These files are architecture-specific. + +** New dependency: GNU libunistring. + +See http://www.gnu.org/software/libunistring/. We hope to merge in +Unicode support in the next prerelease. + + Changes in 1.8.7 (since 1.8.6) From ce471ab8b083a345af0f49e08f51f22dbfe58efe Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2009 11:20:34 +0200 Subject: [PATCH 229/375] rename SCM_SNAME to SCM_SUBR_NAME * libguile/procs.h: Rename SCM_SNAME to SCM_SUBR_NAME. * libguile/debug.c: * libguile/eval.c: * libguile/eval.i.c: * libguile/goops.c: * libguile/gsubr.c: * libguile/print.c: * libguile/procs.c: Update callers. --- libguile/debug.c | 2 +- libguile/eval.c | 2 +- libguile/eval.i.c | 4 ++-- libguile/goops.c | 4 ++-- libguile/gsubr.c | 14 +++++++------- libguile/print.c | 2 +- libguile/procs.c | 6 +++--- libguile/procs.h | 2 +- 8 files changed, 18 insertions(+), 18 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index 6e148ab32..71278c5e4 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -309,7 +309,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, SCM_VALIDATE_PROC (1, proc); switch (SCM_TYP7 (proc)) { case scm_tcs_subrs: - return SCM_SNAME (proc); + return SCM_SUBR_NAME (proc); default: { SCM name = scm_procedure_property (proc, scm_sym_name); diff --git a/libguile/eval.c b/libguile/eval.c index a2e11eeaa..f7f3f27df 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3397,7 +3397,7 @@ call_dsubr_1 (SCM proc, SCM arg1) return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); + SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc))); } static SCM diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 37fb7c787..99aa265de 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -1238,7 +1238,7 @@ dispatch: } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, - scm_i_symbol_chars (SCM_SNAME (proc))); + scm_i_symbol_chars (SCM_SUBR_NAME (proc))); case scm_tc7_cxr: RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); case scm_tc7_rpsubr: @@ -1765,7 +1765,7 @@ tail: RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); + SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc))); case scm_tc7_cxr: if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args))) scm_wrong_num_args (proc); diff --git a/libguile/goops.c b/libguile/goops.c index f552b9e29..1548472cb 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1862,7 +1862,7 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 *SCM_SUBR_GENERIC (subr) = scm_make (scm_list_3 (scm_class_generic, k_name, - SCM_SNAME (subr))); + SCM_SUBR_NAME (subr))); subrs = SCM_CDR (subrs); } return SCM_UNSPECIFIED; @@ -1905,7 +1905,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension) gf = *SCM_SUBR_GENERIC (extended); gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), gf, - SCM_SNAME (extension)); + SCM_SUBR_NAME (extension)); SCM_SET_SUBR_GENERIC (extension, gext); } else diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 0fee71a2c..3b7315565 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -94,7 +94,7 @@ create_gsubr (int define, const char *name, } if (define) - scm_define (SCM_SNAME (subr), subr); + scm_define (SCM_SUBR_NAME (subr), subr); return subr; } @@ -149,7 +149,7 @@ create_gsubr_with_generic (int define, subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf); create_subr: if (define) - scm_define (SCM_SNAME (subr), subr); + scm_define (SCM_SUBR_NAME (subr), subr); return subr; default: ; @@ -196,7 +196,7 @@ gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv) if (SCM_UNLIKELY (argc != argc_max)) /* We expect the exact argument count. */ - scm_wrong_num_args (SCM_SNAME (proc)); + scm_wrong_num_args (SCM_SUBR_NAME (proc)); fcn = SCM_SUBRF (proc); @@ -229,7 +229,7 @@ gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv) return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9]); default: - scm_misc_error ((char *) SCM_SNAME (proc), + scm_misc_error ((char *) SCM_SUBR_NAME (proc), "gsubr invocation with more than 10 arguments not implemented", SCM_EOL); } @@ -258,7 +258,7 @@ scm_i_gsubr_apply (SCM proc, SCM arg, ...) argv[argc] = arg; if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type))) - scm_wrong_num_args (SCM_SNAME (proc)); + scm_wrong_num_args (SCM_SUBR_NAME (proc)); /* Fill in optional arguments that were not passed. */ while (argc < argc_max) @@ -296,7 +296,7 @@ scm_i_gsubr_apply_list (SCM self, SCM args) for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { if (scm_is_null (args)) - scm_wrong_num_args (SCM_SNAME (self)); + scm_wrong_num_args (SCM_SUBR_NAME (self)); v[i] = SCM_CAR(args); args = SCM_CDR(args); } @@ -311,7 +311,7 @@ scm_i_gsubr_apply_list (SCM self, SCM args) if (SCM_GSUBR_REST(typ)) v[i] = args; else if (!scm_is_null (args)) - scm_wrong_num_args (SCM_SNAME (self)); + scm_wrong_num_args (SCM_SUBR_NAME (self)); return gsubr_apply_raw (self, n, v); } diff --git a/libguile/print.c b/libguile/print.c index 3992bc45b..6c44d59db 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -655,7 +655,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) ? "#', port); break; diff --git a/libguile/procs.c b/libguile/procs.c index 3eb9c247a..93e35ab6c 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -66,7 +66,7 @@ SCM scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) { SCM subr = scm_c_make_subr (name, type, fcn); - scm_define (SCM_SNAME (subr), subr); + scm_define (SCM_SUBR_NAME (subr), subr); return subr; } @@ -93,7 +93,7 @@ scm_c_define_subr_with_generic (const char *name, long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); - scm_define (SCM_SNAME (subr), subr); + scm_define (SCM_SUBR_NAME (subr), subr); return subr; } @@ -237,7 +237,7 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, lookup */ switch (SCM_TYP7 (procedure)) { case scm_tcs_subrs: - name = SCM_SNAME (procedure); + name = SCM_SUBR_NAME (procedure); break; default: name = scm_procedure_property (procedure, scm_sym_name); diff --git a/libguile/procs.h b/libguile/procs.h index 84e0c6978..ed4ac200a 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -32,7 +32,7 @@ */ #define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x)) -#define SCM_SNAME(x) (SCM_SUBR_META_INFO (x) [0]) +#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0]) #define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) #define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) #define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x)) From 5b55e29320449c8c68112129e1cadbfa7944af11 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2009 12:32:01 +0200 Subject: [PATCH 230/375] generate changelogs at dist time * Makefile.am: Add rule to make a ChangeLog at dist-time. The rule comes from coreutils. * build-aux/gitlog-to-changelog: New helper script, from gnulib. --- Makefile.am | 12 +++ build-aux/gitlog-to-changelog | 183 ++++++++++++++++++++++++++++++++++ 2 files changed, 195 insertions(+) create mode 100755 build-aux/gitlog-to-changelog diff --git a/Makefile.am b/Makefile.am index a7a793792..c0fd8c337 100644 --- a/Makefile.am +++ b/Makefile.am @@ -40,4 +40,16 @@ ACLOCAL_AMFLAGS = -I m4 DISTCLEANFILES = check-guile.log +dist-hook: gen-ChangeLog + +gen_start_rev = 61db429e251bfd2f75cb4632972e0238056eb24b +.PHONY: gen-ChangeLog +gen-ChangeLog: + if test -d .git; then \ + $(top_srcdir)/build-aux/gitlog-to-changelog \ + $(gen_start_rev)..HEAD > $(distdir)/cl-t; \ + rm -f $(distdir)/ChangeLog; \ + mv $(distdir)/cl-t $(distdir)/ChangeLog; \ + fi + # Makefile.am ends here diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog new file mode 100755 index 000000000..1cc53eb7c --- /dev/null +++ b/build-aux/gitlog-to-changelog @@ -0,0 +1,183 @@ +#!/usr/bin/perl +# Convert git log output to ChangeLog format. + +my $VERSION = '2009-06-04 08:53'; # UTC +# The definition above must lie within the first 8 lines in order +# for the Emacs time-stamp write hook (at end) to update it. +# If you change this file with Emacs, please let the write hook +# do its job. Otherwise, update this string manually. + +# Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# Written by Jim Meyering + +use strict; +use warnings; +use Getopt::Long; +use POSIX qw(strftime); + +(my $ME = $0) =~ s|.*/||; + +# use File::Coda; # http://meyering.net/code/Coda/ +END { + defined fileno STDOUT or return; + close STDOUT and return; + warn "$ME: failed to close standard output: $!\n"; + $? ||= 1; +} + +sub usage ($) +{ + my ($exit_code) = @_; + my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR); + if ($exit_code != 0) + { + print $STREAM "Try `$ME --help' for more information.\n"; + } + else + { + print $STREAM < ChangeLog + $ME -- -n 5 foo > last-5-commits-to-branch-foo + +EOF + } + exit $exit_code; +} + +# If the string $S is a well-behaved file name, simply return it. +# If it contains white space, quotes, etc., quote it, and return the new string. +sub shell_quote($) +{ + my ($s) = @_; + if ($s =~ m![^\w+/.,-]!) + { + # Convert each single quote to '\'' + $s =~ s/\'/\'\\\'\'/g; + # Then single quote the string. + $s = "'$s'"; + } + return $s; +} + +sub quoted_cmd(@) +{ + return join (' ', map {shell_quote $_} @_); +} + +{ + my $since_date = '1970-01-01 UTC'; + GetOptions + ( + help => sub { usage 0 }, + version => sub { print "$ME version $VERSION\n"; exit }, + 'since=s' => \$since_date, + ) or usage 1; + + my @cmd = (qw (git log --log-size), "--since=$since_date", + '--pretty=format:%ct %an <%ae>%n%n%s%n%b%n', @ARGV); + open PIPE, '-|', @cmd + or die ("$ME: failed to run `". quoted_cmd (@cmd) ."': $!\n" + . "(Is your Git too old? Version 1.5.1 or later is required.)\n"); + + my $prev_date_line = ''; + while (1) + { + defined (my $in = ) + or last; + $in =~ /^log size (\d+)$/ + or die "$ME:$.: Invalid line (expected log size):\n$in"; + my $log_nbytes = $1; + + my $log; + my $n_read = read PIPE, $log, $log_nbytes; + $n_read == $log_nbytes + or die "$ME:$.: unexpected EOF\n"; + + my @line = split "\n", $log; + my $author_line = shift @line; + defined $author_line + or die "$ME:$.: unexpected EOF\n"; + $author_line =~ /^(\d+) (.*>)$/ + or die "$ME:$.: Invalid line " + . "(expected date/author/email):\n$author_line\n"; + + my $date_line = sprintf "%s $2\n", strftime ("%F", localtime ($1)); + # If this line would be the same as the previous date/name/email + # line, then arrange not to print it. + if ($date_line ne $prev_date_line) + { + $prev_date_line eq '' + or print "\n"; + print $date_line; + } + $prev_date_line = $date_line; + + # Omit "Signed-off-by..." lines. + @line = grep !/^Signed-off-by: .*>$/, @line; + + # If there were any lines + if (@line == 0) + { + warn "$ME: warning: empty commit message:\n $date_line\n"; + } + else + { + # Remove leading and trailing blank lines. + while ($line[0] =~ /^\s*$/) { shift @line; } + while ($line[$#line] =~ /^\s*$/) { pop @line; } + + # Prefix each non-empty line with a TAB. + @line = map { length $_ ? "\t$_" : '' } @line; + + print "\n", join ("\n", @line), "\n"; + } + + defined ($in = ) + or last; + $in ne "\n" + and die "$ME:$.: unexpected line:\n$in"; + } + + close PIPE + or die "$ME: error closing pipe from " . quoted_cmd (@cmd) . "\n"; + # FIXME-someday: include $PROCESS_STATUS in the diagnostic +} + +# Local Variables: +# indent-tabs-mode: nil +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "my $VERSION = '" +# time-stamp-format: "%:y-%02m-%02d %02H:%02M" +# time-stamp-time-zone: "UTC" +# time-stamp-end: "'; # UTC" +# End: From ffca4c2203d85bc4d9e348d77053d21112e665af Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2009 13:01:11 +0200 Subject: [PATCH 231/375] gnulib-tool --import canonicalize-lgpl --- lib/Makefile.am | 37 +++- lib/canonicalize-lgpl.c | 362 ++++++++++++++++++++++++++++++++++++++++ lib/canonicalize.h | 52 ++++++ lib/malloca.c | 137 +++++++++++++++ lib/malloca.h | 134 +++++++++++++++ lib/malloca.valgrind | 7 + lib/pathmax.h | 47 ++++++ lib/readlink.c | 49 ++++++ lib/string.in.h | 17 +- m4/canonicalize-lgpl.m4 | 35 ++++ m4/eealloc.m4 | 32 ++++ m4/gnulib-cache.m4 | 3 +- m4/gnulib-comp.m4 | 18 ++ m4/malloca.m4 | 14 ++ m4/pathmax.m4 | 12 ++ m4/readlink.m4 | 29 ++++ m4/string_h.m4 | 6 +- 17 files changed, 986 insertions(+), 5 deletions(-) create mode 100644 lib/canonicalize-lgpl.c create mode 100644 lib/canonicalize.h create mode 100644 lib/malloca.c create mode 100644 lib/malloca.h create mode 100644 lib/malloca.valgrind create mode 100644 lib/pathmax.h create mode 100644 lib/readlink.c create mode 100644 m4/canonicalize-lgpl.m4 create mode 100644 m4/eealloc.m4 create mode 100644 m4/malloca.m4 create mode 100644 m4/pathmax.m4 create mode 100644 m4/readlink.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 704c2bcaa..f488fa188 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -90,6 +90,15 @@ EXTRA_DIST += c-strcaseeq.h ## end gnulib module c-strcaseeq +## begin gnulib module canonicalize-lgpl + + +EXTRA_DIST += canonicalize-lgpl.c canonicalize.h + +EXTRA_libgnu_la_SOURCES += canonicalize-lgpl.c + +## end gnulib module canonicalize-lgpl + ## begin gnulib module configmake # Retrieve values of the variables through 'configure' followed by @@ -346,6 +355,14 @@ EXTRA_libgnu_la_SOURCES += malloc.c ## end gnulib module malloc-posix +## begin gnulib module malloca + +libgnu_la_SOURCES += malloca.c + +EXTRA_DIST += malloca.h malloca.valgrind + +## end gnulib module malloca + ## begin gnulib module mbrlen @@ -373,6 +390,13 @@ EXTRA_libgnu_la_SOURCES += mbsinit.c ## end gnulib module mbsinit +## begin gnulib module pathmax + + +EXTRA_DIST += pathmax.h + +## end gnulib module pathmax + ## begin gnulib module putenv @@ -382,6 +406,15 @@ EXTRA_libgnu_la_SOURCES += putenv.c ## end gnulib module putenv +## begin gnulib module readlink + + +EXTRA_DIST += readlink.c + +EXTRA_libgnu_la_SOURCES += readlink.c + +## end gnulib module readlink + ## begin gnulib module safe-read @@ -581,6 +614,7 @@ string.h: string.in.h -e 's|@''GNULIB_MBSSPN''@|$(GNULIB_MBSSPN)|g' \ -e 's|@''GNULIB_MBSSEP''@|$(GNULIB_MBSSEP)|g' \ -e 's|@''GNULIB_MBSTOK_R''@|$(GNULIB_MBSTOK_R)|g' \ + -e 's|@''GNULIB_MEMCHR''@|$(GNULIB_MEMCHR)|g' \ -e 's|@''GNULIB_MEMMEM''@|$(GNULIB_MEMMEM)|g' \ -e 's|@''GNULIB_MEMPCPY''@|$(GNULIB_MEMPCPY)|g' \ -e 's|@''GNULIB_MEMRCHR''@|$(GNULIB_MEMRCHR)|g' \ @@ -617,6 +651,7 @@ string.h: string.in.h -e 's|@''HAVE_DECL_STRERROR''@|$(HAVE_DECL_STRERROR)|g' \ -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \ -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \ + -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \ -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ -e 's|@''REPLACE_STRCASESTR''@|$(REPLACE_STRCASESTR)|g' \ -e 's|@''REPLACE_STRDUP''@|$(REPLACE_STRDUP)|g' \ diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c new file mode 100644 index 000000000..8bc24680f --- /dev/null +++ b/lib/canonicalize-lgpl.c @@ -0,0 +1,362 @@ +/* Return the canonical absolute name of a given file. + Copyright (C) 1996-2003, 2005-2008 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Avoid a clash of our rpl_realpath() function with the prototype in + on Solaris 2.5.1. */ +#undef realpath + +#if !HAVE_CANONICALIZE_FILE_NAME || defined _LIBC + +#include + +/* Specification. */ +#include "canonicalize.h" + +#include +#include +#include + +#if HAVE_UNISTD_H || defined _LIBC +# include +#endif + +#include + +#if HAVE_SYS_PARAM_H || defined _LIBC +# include +#endif +#ifndef MAXSYMLINKS +# define MAXSYMLINKS 20 +#endif + +#include + +#include +#ifndef _LIBC +# define __set_errno(e) errno = (e) +# ifndef ENAMETOOLONG +# define ENAMETOOLONG EINVAL +# endif +#endif + +#ifdef _LIBC +# include +#else +# define SHLIB_COMPAT(lib, introduced, obsoleted) 0 +# define versioned_symbol(lib, local, symbol, version) +# define compat_symbol(lib, local, symbol, version) +# define weak_alias(local, symbol) +# define __canonicalize_file_name canonicalize_file_name +# define __realpath rpl_realpath +# include "pathmax.h" +# include "malloca.h" +# if HAVE_GETCWD +# ifdef VMS + /* We want the directory in Unix syntax, not in VMS syntax. */ +# define __getcwd(buf, max) getcwd (buf, max, 0) +# else +# define __getcwd getcwd +# endif +# else +# define __getcwd(buf, max) getwd (buf) +# endif +# define __readlink readlink + /* On systems without symbolic links, call stat() instead of lstat(). */ +# if !defined S_ISLNK && !HAVE_READLINK +# define lstat stat +# endif +#endif + +/* Return the canonical absolute name of file NAME. A canonical name + does not contain any `.', `..' components nor any repeated path + separators ('/') or symlinks. All path components must exist. If + RESOLVED is null, the result is malloc'd; otherwise, if the + canonical name is PATH_MAX chars or more, returns null with `errno' + set to ENAMETOOLONG; if the name fits in fewer than PATH_MAX chars, + returns the name in RESOLVED. If the name cannot be resolved and + RESOLVED is non-NULL, it contains the path of the first component + that cannot be resolved. If the path can be resolved, RESOLVED + holds the same value as the value returned. */ + +char * +__realpath (const char *name, char *resolved) +{ + char *rpath, *dest, *extra_buf = NULL; + const char *start, *end, *rpath_limit; + long int path_max; +#if HAVE_READLINK + int num_links = 0; +#endif + + if (name == NULL) + { + /* As per Single Unix Specification V2 we must return an error if + either parameter is a null pointer. We extend this to allow + the RESOLVED parameter to be NULL in case the we are expected to + allocate the room for the return value. */ + __set_errno (EINVAL); + return NULL; + } + + if (name[0] == '\0') + { + /* As per Single Unix Specification V2 we must return an error if + the name argument points to an empty string. */ + __set_errno (ENOENT); + return NULL; + } + +#ifdef PATH_MAX + path_max = PATH_MAX; +#else + path_max = pathconf (name, _PC_PATH_MAX); + if (path_max <= 0) + path_max = 1024; +#endif + + if (resolved == NULL) + { + rpath = malloc (path_max); + if (rpath == NULL) + { + /* It's easier to set errno to ENOMEM than to rely on the + 'malloc-posix' gnulib module. */ + errno = ENOMEM; + return NULL; + } + } + else + rpath = resolved; + rpath_limit = rpath + path_max; + + if (name[0] != '/') + { + if (!__getcwd (rpath, path_max)) + { + rpath[0] = '\0'; + goto error; + } + dest = strchr (rpath, '\0'); + } + else + { + rpath[0] = '/'; + dest = rpath + 1; + } + + for (start = end = name; *start; start = end) + { +#ifdef _LIBC + struct stat64 st; +#else + struct stat st; +#endif + + /* Skip sequence of multiple path-separators. */ + while (*start == '/') + ++start; + + /* Find end of path component. */ + for (end = start; *end && *end != '/'; ++end) + /* Nothing. */; + + if (end - start == 0) + break; + else if (end - start == 1 && start[0] == '.') + /* nothing */; + else if (end - start == 2 && start[0] == '.' && start[1] == '.') + { + /* Back up to previous component, ignore if at root already. */ + if (dest > rpath + 1) + while ((--dest)[-1] != '/'); + } + else + { + size_t new_size; + + if (dest[-1] != '/') + *dest++ = '/'; + + if (dest + (end - start) >= rpath_limit) + { + ptrdiff_t dest_offset = dest - rpath; + char *new_rpath; + + if (resolved) + { + __set_errno (ENAMETOOLONG); + if (dest > rpath + 1) + dest--; + *dest = '\0'; + goto error; + } + new_size = rpath_limit - rpath; + if (end - start + 1 > path_max) + new_size += end - start + 1; + else + new_size += path_max; + new_rpath = (char *) realloc (rpath, new_size); + if (new_rpath == NULL) + { + /* It's easier to set errno to ENOMEM than to rely on the + 'realloc-posix' gnulib module. */ + errno = ENOMEM; + goto error; + } + rpath = new_rpath; + rpath_limit = rpath + new_size; + + dest = rpath + dest_offset; + } + +#ifdef _LIBC + dest = __mempcpy (dest, start, end - start); +#else + memcpy (dest, start, end - start); + dest += end - start; +#endif + *dest = '\0'; + +#ifdef _LIBC + if (__lxstat64 (_STAT_VER, rpath, &st) < 0) +#else + if (lstat (rpath, &st) < 0) +#endif + goto error; + +#if HAVE_READLINK + if (S_ISLNK (st.st_mode)) + { + char *buf; + size_t len; + int n; + + if (++num_links > MAXSYMLINKS) + { + __set_errno (ELOOP); + goto error; + } + + buf = malloca (path_max); + if (!buf) + { + errno = ENOMEM; + goto error; + } + + n = __readlink (rpath, buf, path_max - 1); + if (n < 0) + { + int saved_errno = errno; + freea (buf); + errno = saved_errno; + goto error; + } + buf[n] = '\0'; + + if (!extra_buf) + { + extra_buf = malloca (path_max); + if (!extra_buf) + { + freea (buf); + errno = ENOMEM; + goto error; + } + } + + len = strlen (end); + if ((long int) (n + len) >= path_max) + { + freea (buf); + __set_errno (ENAMETOOLONG); + goto error; + } + + /* Careful here, end may be a pointer into extra_buf... */ + memmove (&extra_buf[n], end, len + 1); + name = end = memcpy (extra_buf, buf, n); + + if (buf[0] == '/') + dest = rpath + 1; /* It's an absolute symlink */ + else + /* Back up to previous component, ignore if at root already: */ + if (dest > rpath + 1) + while ((--dest)[-1] != '/'); + } +#endif + } + } + if (dest > rpath + 1 && dest[-1] == '/') + --dest; + *dest = '\0'; + + if (extra_buf) + freea (extra_buf); + + return resolved ? memcpy (resolved, rpath, dest - rpath + 1) : rpath; + +error: + { + int saved_errno = errno; + if (extra_buf) + freea (extra_buf); + if (resolved) + strcpy (resolved, rpath); + else + free (rpath); + errno = saved_errno; + } + return NULL; +} +#ifdef _LIBC +versioned_symbol (libc, __realpath, realpath, GLIBC_2_3); +#endif + + +#if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3) +char * +__old_realpath (const char *name, char *resolved) +{ + if (resolved == NULL) + { + __set_errno (EINVAL); + return NULL; + } + + return __realpath (name, resolved); +} +compat_symbol (libc, __old_realpath, realpath, GLIBC_2_0); +#endif + + +char * +__canonicalize_file_name (const char *name) +{ + return __realpath (name, NULL); +} +weak_alias (__canonicalize_file_name, canonicalize_file_name) + +#else + +/* This declaration is solely to ensure that after preprocessing + this file is never empty. */ +typedef int dummy; + +#endif diff --git a/lib/canonicalize.h b/lib/canonicalize.h new file mode 100644 index 000000000..184cf1637 --- /dev/null +++ b/lib/canonicalize.h @@ -0,0 +1,52 @@ +/* Return the canonical absolute name of a given file. + Copyright (C) 1996-2007 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef CANONICALIZE_H_ +# define CANONICALIZE_H_ + +# if GNULIB_CANONICALIZE +enum canonicalize_mode_t + { + /* All components must exist. */ + CAN_EXISTING = 0, + + /* All components excluding last one must exist. */ + CAN_ALL_BUT_LAST = 1, + + /* No requirements on components existence. */ + CAN_MISSING = 2 + }; +typedef enum canonicalize_mode_t canonicalize_mode_t; + +/* Return a malloc'd string containing the canonical absolute name of + the named file. This acts like canonicalize_file_name, except that + whether components must exist depends on the canonicalize_mode_t + argument. */ +char *canonicalize_filename_mode (const char *, canonicalize_mode_t); +# endif + +# if HAVE_DECL_CANONICALIZE_FILE_NAME +# include +# else +/* Return a malloc'd string containing the canonical absolute name of + the named file. If any file name component does not exist or is a + symlink to a nonexistent file, return NULL. A canonical name does + not contain any `.', `..' components nor any repeated file name + separators ('/') or symlinks. */ +char *canonicalize_file_name (const char *); +# endif + +#endif /* !CANONICALIZE_H_ */ diff --git a/lib/malloca.c b/lib/malloca.c new file mode 100644 index 000000000..7905e6152 --- /dev/null +++ b/lib/malloca.c @@ -0,0 +1,137 @@ +/* Safe automatic memory allocation. + Copyright (C) 2003, 2006-2007 Free Software Foundation, Inc. + Written by Bruno Haible , 2003. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include "malloca.h" + +/* The speed critical point in this file is freea() applied to an alloca() + result: it must be fast, to match the speed of alloca(). The speed of + mmalloca() and freea() in the other case are not critical, because they + are only invoked for big memory sizes. */ + +#if HAVE_ALLOCA + +/* Store the mmalloca() results in a hash table. This is needed to reliably + distinguish a mmalloca() result and an alloca() result. + + Although it is possible that the same pointer is returned by alloca() and + by mmalloca() at different times in the same application, it does not lead + to a bug in freea(), because: + - Before a pointer returned by alloca() can point into malloc()ed memory, + the function must return, and once this has happened the programmer must + not call freea() on it anyway. + - Before a pointer returned by mmalloca() can point into the stack, it + must be freed. The only function that can free it is freea(), and + when freea() frees it, it also removes it from the hash table. */ + +#define MAGIC_NUMBER 0x1415fb4a +#define MAGIC_SIZE sizeof (int) +/* This is how the header info would look like without any alignment + considerations. */ +struct preliminary_header { void *next; char room[MAGIC_SIZE]; }; +/* But the header's size must be a multiple of sa_alignment_max. */ +#define HEADER_SIZE \ + (((sizeof (struct preliminary_header) + sa_alignment_max - 1) / sa_alignment_max) * sa_alignment_max) +struct header { void *next; char room[HEADER_SIZE - sizeof (struct preliminary_header) + MAGIC_SIZE]; }; +/* Verify that HEADER_SIZE == sizeof (struct header). */ +typedef int verify1[2 * (HEADER_SIZE == sizeof (struct header)) - 1]; +/* We make the hash table quite big, so that during lookups the probability + of empty hash buckets is quite high. There is no need to make the hash + table resizable, because when the hash table gets filled so much that the + lookup becomes slow, it means that the application has memory leaks. */ +#define HASH_TABLE_SIZE 257 +static void * mmalloca_results[HASH_TABLE_SIZE]; + +#endif + +void * +mmalloca (size_t n) +{ +#if HAVE_ALLOCA + /* Allocate one more word, that serves as an indicator for malloc()ed + memory, so that freea() of an alloca() result is fast. */ + size_t nplus = n + HEADER_SIZE; + + if (nplus >= n) + { + char *p = (char *) malloc (nplus); + + if (p != NULL) + { + size_t slot; + + p += HEADER_SIZE; + + /* Put a magic number into the indicator word. */ + ((int *) p)[-1] = MAGIC_NUMBER; + + /* Enter p into the hash table. */ + slot = (unsigned long) p % HASH_TABLE_SIZE; + ((struct header *) (p - HEADER_SIZE))->next = mmalloca_results[slot]; + mmalloca_results[slot] = p; + + return p; + } + } + /* Out of memory. */ + return NULL; +#else +# if !MALLOC_0_IS_NONNULL + if (n == 0) + n = 1; +# endif + return malloc (n); +#endif +} + +#if HAVE_ALLOCA +void +freea (void *p) +{ + /* mmalloca() may have returned NULL. */ + if (p != NULL) + { + /* Attempt to quickly distinguish the mmalloca() result - which has + a magic indicator word - and the alloca() result - which has an + uninitialized indicator word. It is for this test that sa_increment + additional bytes are allocated in the alloca() case. */ + if (((int *) p)[-1] == MAGIC_NUMBER) + { + /* Looks like a mmalloca() result. To see whether it really is one, + perform a lookup in the hash table. */ + size_t slot = (unsigned long) p % HASH_TABLE_SIZE; + void **chain = &mmalloca_results[slot]; + for (; *chain != NULL;) + { + if (*chain == p) + { + /* Found it. Remove it from the hash table and free it. */ + char *p_begin = (char *) p - HEADER_SIZE; + *chain = ((struct header *) p_begin)->next; + free (p_begin); + return; + } + chain = &((struct header *) ((char *) *chain - HEADER_SIZE))->next; + } + } + /* At this point, we know it was not a mmalloca() result. */ + } +} +#endif diff --git a/lib/malloca.h b/lib/malloca.h new file mode 100644 index 000000000..7d92b0af5 --- /dev/null +++ b/lib/malloca.h @@ -0,0 +1,134 @@ +/* Safe automatic memory allocation. + Copyright (C) 2003-2007 Free Software Foundation, Inc. + Written by Bruno Haible , 2003. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _MALLOCA_H +#define _MALLOCA_H + +#include +#include +#include + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* safe_alloca(N) is equivalent to alloca(N) when it is safe to call + alloca(N); otherwise it returns NULL. It either returns N bytes of + memory allocated on the stack, that lasts until the function returns, + or NULL. + Use of safe_alloca should be avoided: + - inside arguments of function calls - undefined behaviour, + - in inline functions - the allocation may actually last until the + calling function returns. +*/ +#if HAVE_ALLOCA +/* The OS usually guarantees only one guard page at the bottom of the stack, + and a page size can be as small as 4096 bytes. So we cannot safely + allocate anything larger than 4096 bytes. Also care for the possibility + of a few compiler-allocated temporary stack slots. + This must be a macro, not an inline function. */ +# define safe_alloca(N) ((N) < 4032 ? alloca (N) : NULL) +#else +# define safe_alloca(N) ((void) (N), NULL) +#endif + +/* malloca(N) is a safe variant of alloca(N). It allocates N bytes of + memory allocated on the stack, that must be freed using freea() before + the function returns. Upon failure, it returns NULL. */ +#if HAVE_ALLOCA +# define malloca(N) \ + ((N) < 4032 - sa_increment \ + ? (void *) ((char *) alloca ((N) + sa_increment) + sa_increment) \ + : mmalloca (N)) +#else +# define malloca(N) \ + mmalloca (N) +#endif +extern void * mmalloca (size_t n); + +/* Free a block of memory allocated through malloca(). */ +#if HAVE_ALLOCA +extern void freea (void *p); +#else +# define freea free +#endif + +/* nmalloca(N,S) is an overflow-safe variant of malloca (N * S). + It allocates an array of N objects, each with S bytes of memory, + on the stack. S must be positive and N must be nonnegative. + The array must be freed using freea() before the function returns. */ +#if 1 +/* Cf. the definition of xalloc_oversized. */ +# define nmalloca(n, s) \ + ((n) > (size_t) (sizeof (ptrdiff_t) <= sizeof (size_t) ? -1 : -2) / (s) \ + ? NULL \ + : malloca ((n) * (s))) +#else +extern void * nmalloca (size_t n, size_t s); +#endif + + +#ifdef __cplusplus +} +#endif + + +/* ------------------- Auxiliary, non-public definitions ------------------- */ + +/* Determine the alignment of a type at compile time. */ +#if defined __GNUC__ +# define sa_alignof __alignof__ +#elif defined __cplusplus + template struct sa_alignof_helper { char __slot1; type __slot2; }; +# define sa_alignof(type) offsetof (sa_alignof_helper, __slot2) +#elif defined __hpux + /* Work around a HP-UX 10.20 cc bug with enums constants defined as offsetof + values. */ +# define sa_alignof(type) (sizeof (type) <= 4 ? 4 : 8) +#elif defined _AIX + /* Work around an AIX 3.2.5 xlc bug with enums constants defined as offsetof + values. */ +# define sa_alignof(type) (sizeof (type) <= 4 ? 4 : 8) +#else +# define sa_alignof(type) offsetof (struct { char __slot1; type __slot2; }, __slot2) +#endif + +enum +{ +/* The desired alignment of memory allocations is the maximum alignment + among all elementary types. */ + sa_alignment_long = sa_alignof (long), + sa_alignment_double = sa_alignof (double), +#if HAVE_LONG_LONG_INT + sa_alignment_longlong = sa_alignof (long long), +#endif + sa_alignment_longdouble = sa_alignof (long double), + sa_alignment_max = ((sa_alignment_long - 1) | (sa_alignment_double - 1) +#if HAVE_LONG_LONG_INT + | (sa_alignment_longlong - 1) +#endif + | (sa_alignment_longdouble - 1) + ) + 1, +/* The increment that guarantees room for a magic word must be >= sizeof (int) + and a multiple of sa_alignment_max. */ + sa_increment = ((sizeof (int) + sa_alignment_max - 1) / sa_alignment_max) * sa_alignment_max +}; + +#endif /* _MALLOCA_H */ diff --git a/lib/malloca.valgrind b/lib/malloca.valgrind new file mode 100644 index 000000000..52f0a50f5 --- /dev/null +++ b/lib/malloca.valgrind @@ -0,0 +1,7 @@ +# Suppress a valgrind message about use of uninitialized memory in freea(). +# This use is OK because it provides only a speedup. +{ + freea + Memcheck:Cond + fun:freea +} diff --git a/lib/pathmax.h b/lib/pathmax.h new file mode 100644 index 000000000..a5d433560 --- /dev/null +++ b/lib/pathmax.h @@ -0,0 +1,47 @@ +/* Define PATH_MAX somehow. Requires sys/types.h. + Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _PATHMAX_H +# define _PATHMAX_H + +# include + +# include + +# ifndef _POSIX_PATH_MAX +# define _POSIX_PATH_MAX 256 +# endif + +# if !defined PATH_MAX && defined _PC_PATH_MAX && defined HAVE_PATHCONF +# define PATH_MAX (pathconf ("/", _PC_PATH_MAX) < 1 ? 1024 \ + : pathconf ("/", _PC_PATH_MAX)) +# endif + +/* Don't include sys/param.h if it already has been. */ +# if defined HAVE_SYS_PARAM_H && !defined PATH_MAX && !defined MAXPATHLEN +# include +# endif + +# if !defined PATH_MAX && defined MAXPATHLEN +# define PATH_MAX MAXPATHLEN +# endif + +# ifndef PATH_MAX +# define PATH_MAX _POSIX_PATH_MAX +# endif + +#endif /* _PATHMAX_H */ diff --git a/lib/readlink.c b/lib/readlink.c new file mode 100644 index 000000000..c9f49f815 --- /dev/null +++ b/lib/readlink.c @@ -0,0 +1,49 @@ +/* Stub for readlink(). + Copyright (C) 2003-2007 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include + +#include +#include +#include +#include + +#if !HAVE_READLINK + +/* readlink() substitute for systems that don't have a readlink() function, + such as DJGPP 2.03 and mingw32. */ + +/* The official POSIX return type of readlink() is ssize_t, but since here + we have no declaration in a public header file, we use 'int' as return + type. */ + +int +readlink (const char *path, char *buf, size_t bufsize) +{ + struct stat statbuf; + + /* In general we should use lstat() here, not stat(). But on platforms + without symbolic links lstat() - if it exists - would be equivalent to + stat(), therefore we can use stat(). This saves us a configure check. */ + if (stat (path, &statbuf) >= 0) + errno = EINVAL; + return -1; +} + +#endif diff --git a/lib/string.in.h b/lib/string.in.h index ca029d7c0..fe1142562 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995-1996, 2001-2008 Free Software Foundation, Inc. + Copyright (C) 1995-1996, 2001-2009 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -49,6 +49,21 @@ extern "C" { #endif +/* Return the first instance of C within N bytes of S, or NULL. */ +#if @GNULIB_MEMCHR@ +# if @REPLACE_MEMCHR@ +# define memchr rpl_memchr +extern void *memchr (void const *__s, int __c, size_t __n) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef memchr +# define memchr(s,c,n) \ + (GL_LINK_WARNING ("memchr has platform-specific bugs - " \ + "use gnulib module memchr for portability" ), \ + memchr (s, c, n)) +#endif + /* Return the first occurrence of NEEDLE in HAYSTACK. */ #if @GNULIB_MEMMEM@ # if @REPLACE_MEMMEM@ diff --git a/m4/canonicalize-lgpl.m4 b/m4/canonicalize-lgpl.m4 new file mode 100644 index 000000000..3a8ee2f95 --- /dev/null +++ b/m4/canonicalize-lgpl.m4 @@ -0,0 +1,35 @@ +# canonicalize-lgpl.m4 serial 5 +dnl Copyright (C) 2003, 2006-2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_CANONICALIZE_LGPL], +[ + dnl Do this replacement check manually because the file name is shorter + dnl than the function name. + AC_CHECK_DECLS_ONCE([canonicalize_file_name]) + AC_CHECK_FUNCS_ONCE([canonicalize_file_name]) + if test $ac_cv_func_canonicalize_file_name = no; then + AC_LIBOBJ([canonicalize-lgpl]) + AC_DEFINE([realpath], [rpl_realpath], + [Define to a replacement function name for realpath().]) + gl_PREREQ_CANONICALIZE_LGPL + fi +]) + +# Like gl_CANONICALIZE_LGPL, except prepare for separate compilation +# (no AC_LIBOBJ). +AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE], +[ + AC_CHECK_DECLS_ONCE([canonicalize_file_name]) + AC_CHECK_FUNCS_ONCE([canonicalize_file_name]) + gl_PREREQ_CANONICALIZE_LGPL +]) + +# Prerequisites of lib/canonicalize-lgpl.c. +AC_DEFUN([gl_PREREQ_CANONICALIZE_LGPL], +[ + AC_CHECK_HEADERS_ONCE([sys/param.h unistd.h]) + AC_CHECK_FUNCS_ONCE([getcwd readlink]) +]) diff --git a/m4/eealloc.m4 b/m4/eealloc.m4 new file mode 100644 index 000000000..3c9c0b52a --- /dev/null +++ b/m4/eealloc.m4 @@ -0,0 +1,32 @@ +# eealloc.m4 serial 2 +dnl Copyright (C) 2003, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_EEALLOC], +[ + AC_REQUIRE([gl_EEMALLOC]) + AC_REQUIRE([gl_EEREALLOC]) + AC_REQUIRE([AC_C_INLINE]) +]) + +AC_DEFUN([gl_EEMALLOC], +[ + _AC_FUNC_MALLOC_IF( + [gl_cv_func_malloc_0_nonnull=1], + [gl_cv_func_malloc_0_nonnull=0]) + AC_DEFINE_UNQUOTED([MALLOC_0_IS_NONNULL], [$gl_cv_func_malloc_0_nonnull], + [If malloc(0) is != NULL, define this to 1. Otherwise define this + to 0.]) +]) + +AC_DEFUN([gl_EEREALLOC], +[ + _AC_FUNC_REALLOC_IF( + [gl_cv_func_realloc_0_nonnull=1], + [gl_cv_func_realloc_0_nonnull=0]) + AC_DEFINE_UNQUOTED([REALLOC_0_IS_NONNULL], [$gl_cv_func_realloc_0_nonnull], + [If realloc(NULL,0) is != NULL, define this to 1. Otherwise define this + to 0.]) +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index a45029493..e70283f41 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -23,6 +23,7 @@ gl_MODULES([ alloca-opt autobuild byteswap + canonicalize-lgpl count-one-bits environ extensions diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 8f775107e..ef0534ef8 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -46,6 +46,8 @@ AC_DEFUN([gl_INIT], gl_source_base='lib' gl_FUNC_ALLOCA gl_BYTESWAP + gl_CANONICALIZE_LGPL + gl_MODULE_INDICATOR([canonicalize-lgpl]) gl_COUNT_ONE_BITS gl_ENVIRON gl_UNISTD_MODULE_INDICATOR([environ]) @@ -63,6 +65,7 @@ AC_DEFUN([gl_INIT], AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) gl_FUNC_MALLOC_POSIX gl_STDLIB_MODULE_INDICATOR([malloc-posix]) + gl_MALLOCA gl_FUNC_MBRLEN gl_WCHAR_MODULE_INDICATOR([mbrlen]) gl_FUNC_MBRTOWC @@ -70,8 +73,11 @@ AC_DEFUN([gl_INIT], gl_FUNC_MBSINIT gl_WCHAR_MODULE_INDICATOR([mbsinit]) gl_MULTIARCH + gl_PATHMAX gl_FUNC_PUTENV gl_STDLIB_MODULE_INDICATOR([putenv]) + gl_FUNC_READLINK + gl_UNISTD_MODULE_INDICATOR([readlink]) gl_SAFE_READ gl_SAFE_WRITE gt_TYPE_SSIZE_T @@ -236,6 +242,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/c-strcasecmp.c lib/c-strcaseeq.h lib/c-strncasecmp.c + lib/canonicalize-lgpl.c + lib/canonicalize.h lib/config.charset lib/count-one-bits.h lib/flock.c @@ -255,10 +263,15 @@ AC_DEFUN([gl_FILE_LIST], [ lib/localcharset.c lib/localcharset.h lib/malloc.c + lib/malloca.c + lib/malloca.h + lib/malloca.valgrind lib/mbrlen.c lib/mbrtowc.c lib/mbsinit.c + lib/pathmax.h lib/putenv.c + lib/readlink.c lib/ref-add.sin lib/ref-del.sin lib/safe-read.c @@ -298,8 +311,10 @@ AC_DEFUN([gl_FILE_LIST], [ m4/alloca.m4 m4/autobuild.m4 m4/byteswap.m4 + m4/canonicalize-lgpl.m4 m4/codeset.m4 m4/count-one-bits.m4 + m4/eealloc.m4 m4/environ.m4 m4/extensions.m4 m4/flock.m4 @@ -321,12 +336,15 @@ AC_DEFUN([gl_FILE_LIST], [ m4/locale-zh.m4 m4/longlong.m4 m4/malloc.m4 + m4/malloca.m4 m4/mbrlen.m4 m4/mbrtowc.m4 m4/mbsinit.m4 m4/mbstate_t.m4 m4/multiarch.m4 + m4/pathmax.m4 m4/putenv.m4 + m4/readlink.m4 m4/safe-read.m4 m4/safe-write.m4 m4/ssize_t.m4 diff --git a/m4/malloca.m4 b/m4/malloca.m4 new file mode 100644 index 000000000..2841ae83a --- /dev/null +++ b/m4/malloca.m4 @@ -0,0 +1,14 @@ +# malloca.m4 serial 1 +dnl Copyright (C) 2003-2004, 2006-2007 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_MALLOCA], +[ + dnl Use the autoconf tests for alloca(), but not the AC_SUBSTed variables + dnl @ALLOCA@ and @LTALLOCA@. + dnl gl_FUNC_ALLOCA dnl Already brought in by the module dependencies. + AC_REQUIRE([gl_EEMALLOC]) + AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) +]) diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 new file mode 100644 index 000000000..465180161 --- /dev/null +++ b/m4/pathmax.m4 @@ -0,0 +1,12 @@ +# pathmax.m4 serial 8 +dnl Copyright (C) 2002, 2003, 2005, 2006, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_PATHMAX], +[ + dnl Prerequisites of lib/pathmax.h. + AC_CHECK_FUNCS_ONCE([pathconf]) + AC_CHECK_HEADERS_ONCE([sys/param.h]) +]) diff --git a/m4/readlink.m4 b/m4/readlink.m4 new file mode 100644 index 000000000..ff3f1f587 --- /dev/null +++ b/m4/readlink.m4 @@ -0,0 +1,29 @@ +# readlink.m4 serial 5 +dnl Copyright (C) 2003, 2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_READLINK], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([readlink]) + if test $ac_cv_func_readlink = no; then + HAVE_READLINK=0 + AC_LIBOBJ([readlink]) + gl_PREREQ_READLINK + fi +]) + +# Like gl_FUNC_READLINK, except prepare for separate compilation (no AC_LIBOBJ). +AC_DEFUN([gl_FUNC_READLINK_SEPARATE], +[ + AC_CHECK_FUNCS_ONCE([readlink]) + gl_PREREQ_READLINK +]) + +# Prerequisites of lib/readlink.c. +AC_DEFUN([gl_PREREQ_READLINK], +[ + : +]) diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 2d5553c37..11f09c8b8 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -1,11 +1,11 @@ # Configure a GNU-like replacement for . -# Copyright (C) 2007, 2008 Free Software Foundation, Inc. +# Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. -# serial 6 +# serial 7 # Written by Paul Eggert. @@ -32,6 +32,7 @@ AC_DEFUN([gl_STRING_MODULE_INDICATOR], AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS], [ + GNULIB_MEMCHR=0; AC_SUBST([GNULIB_MEMCHR]) GNULIB_MEMMEM=0; AC_SUBST([GNULIB_MEMMEM]) GNULIB_MEMPCPY=0; AC_SUBST([GNULIB_MEMPCPY]) GNULIB_MEMRCHR=0; AC_SUBST([GNULIB_MEMRCHR]) @@ -83,6 +84,7 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS], HAVE_DECL_STRERROR=1; AC_SUBST([HAVE_DECL_STRERROR]) HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL]) HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP]) + REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR]) REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) REPLACE_STRDUP=0; AC_SUBST([REPLACE_STRDUP]) REPLACE_STRSTR=0; AC_SUBST([REPLACE_STRSTR]) From 25b82b3485e9e44d8d6268d3774b0b81d0d501b2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2009 14:26:47 +0200 Subject: [PATCH 232/375] new function: canonicalize-path. use when autocompiling * libguile/filesys.h: * libguile/filesys.c (scm_canonicalize_path): New function, canonicalize-path. * module/system/base/compile.scm (compiled-file-name): Canonicalize the filename so that compiling e.g. ../foo.scm doesn't compile to ~/.guile-ccache/1.9/../foo.scm. --- libguile/filesys.c | 22 ++++++++++++++++++++++ libguile/filesys.h | 1 + module/system/base/compile.scm | 3 ++- 3 files changed, 25 insertions(+), 1 deletion(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index b49d488f1..a2db6996f 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -30,6 +30,7 @@ #endif #include +#include #include #include @@ -1661,6 +1662,27 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_canonicalize_path, "canonicalize-path", 1, 0, 0, + (SCM path), + "Return the canonical path of @var{path}. A canonical path has\n" + "no @code{.} or @code{..} components, nor any repeated path\n" + "separators (@code{/}) nor symlinks.\n\n" + "Raises an error if any component of @var{path} does not exist.") +#define FUNC_NAME s_scm_canonicalize_path +{ char *str, *canon; + + SCM_VALIDATE_STRING (1, path); + + str = scm_to_locale_string (path); + canon = canonicalize_file_name (str); + free (str); + + if (canon) + return scm_take_locale_string (canon); + else + SCM_SYSERROR; +} +#undef FUNC_NAME diff --git a/libguile/filesys.h b/libguile/filesys.h index 3e5c83e76..b9a6ca8a6 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -65,6 +65,7 @@ SCM_API SCM scm_lstat (SCM str); SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile); SCM_API SCM scm_dirname (SCM filename); SCM_API SCM scm_basename (SCM filename, SCM suffix); +SCM_API SCM scm_canonicalize_path (SCM path); SCM_INTERNAL void scm_init_filesys (void); diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 9f0ff2f3d..dfe8823be 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -131,7 +131,8 @@ (else (car %load-compiled-extensions)))) (and %compile-fallback-path (let ((f (string-append - %compile-fallback-path "/" file (compiled-extension)))) + %compile-fallback-path "/" (canonicalize-path file) + (compiled-extension)))) (and (false-if-exception (ensure-writable-dir (dirname f))) f)))) From b57501c3b7afa0378e3142cc415cfd02a374a77e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2009 14:27:56 +0200 Subject: [PATCH 233/375] don't autocompile at installcheck * examples/Makefile.am: Don't autocompile our tests at installcheck time. --- examples/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/Makefile.am b/examples/Makefile.am index afe869dba..5de528a21 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -81,6 +81,7 @@ installcheck: box/box box-module/box libbox.la libbox-module.la LTDL_LIBRARY_PATH="$(builddir):$$LTDL_LIBRARY_PATH" \ GUILE_LOAD_PATH="$(abs_top_srcdir):$$GUILE_LOAD_PATH" \ PATH="$(bindir):$$PATH" \ + GUILE_AUTO_COMPILE=0 \ srcdir="$(srcdir)" \ $(srcdir)/check.test From 8141fc3b4633993fe37fef19a81a823cf727b90b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 21:54:51 +0200 Subject: [PATCH 234/375] Fix "guile-tools disassemble". * module/scripts/disassemble.scm (disassemble): Accept a variable number of arguments. Invoke the right `disassemble' procedure. --- module/scripts/disassemble.scm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm index f074615fb..8907f6d08 100644 --- a/module/scripts/disassemble.scm +++ b/module/scripts/disassemble.scm @@ -1,6 +1,6 @@ ;;; Disassemble --- Disassemble .go files into something human-readable -;; Copyright 2005,2008 Free Software Foundation, Inc. +;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -17,7 +17,7 @@ ;; not, write to the Free Software Foundation, Inc., 51 Franklin ;; Street, Fifth Floor, Boston, MA 02110-1301 USA -;;; Author: Ludovic Courtès +;;; Author: Ludovic Courtès ;;; Author: Andy Wingo ;;; Commentary: @@ -28,12 +28,13 @@ (define-module (scripts disassemble) #:use-module (system vm objcode) - #:use-module (language assembly disassemble) + #:use-module ((language assembly disassemble) + #:renamer (symbol-prefix-proc 'asm:)) #:export (disassemble)) -(define (disassemble args) +(define (disassemble . files) (for-each (lambda (file) - (disassemble (load-objcode file))) - (cdr args))) + (asm:disassemble (load-objcode file))) + files)) (define main disassemble) From 93617170fa8dc30378ee09b1c24827975f895406 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 21:55:53 +0200 Subject: [PATCH 235/375] Slightly improve `NEWS'. --- NEWS | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/NEWS b/NEWS index 141855591..5175a0900 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,7 @@ Changes in 1.9.0 (changes since the 1.8.x series): ** `(srfi srfi-18)', more sophisticated multithreading support ** `(ice-9 i18n)', internationalization support ** `(rnrs bytevector)', the R6RS bytevector API +** `(rnrs io ports)', a subset of the R6RS I/O port API ** `(system xref)', a cross-referencing facility (FIXME undocumented) * Changes to the stand-alone interpreter @@ -43,7 +44,7 @@ documented in the manual. This will be fixed before 2.0. ** New `guile-tools' commands: `compile', `disassemble' -Pass the --help command-line option to these commands for more +Pass the `--help' command-line option to these commands for more information. * Changes to Scheme functions and syntax @@ -53,7 +54,7 @@ information. This procedure was part of the interpreter's execution model, and does not apply to the compiler. -** Files loaded with primitive-load-path will now be compiled +** Files loaded with `primitive-load-path' will now be compiled automatically. If a compiled .go file corresponding to a .scm file is not found or is @@ -273,9 +274,10 @@ actually used this, this behavior may be reinstated via the ** Scheme expresssions may be commented out with #; -#; comments out an entire expression. See the R6RS for more information. +#; comments out an entire expression. See SRFI-62 or the R6RS for more +information. -** make-stack with a tail-called procedural narrowing argument no longer +** `make-stack' with a tail-called procedural narrowing argument no longer works (with compiled procedures) It used to be the case that a captured stack could be narrowed to select @@ -308,7 +310,7 @@ Before, `(define ((f a) b) (* a b))' would translate to (define f (lambda (a) (lambda (b) (* a b)))) -Now a syntax error is signalled, as this syntax is not supported by +Now a syntax error is signaled, as this syntax is not supported by default. If there is sufficient demand, this syntax can be supported again by default. @@ -323,7 +325,7 @@ fresh name will be lazily generated for it. Syntax errors still throw to the `syntax-error' key, but the arguments are often different now. Perhaps in the future, Guile will switch to -using standard srfi-35 conditions. +using standard SRFI-35 conditions. ** Returning multiple values to compiled code will silently truncate the values to the expected number @@ -448,13 +450,17 @@ XXX Need to decide whether to document this for 2.0, probably should: make-syncase-macro, make-extended-syncase-macro, macro-type, syncase-macro-type, syncase-macro-binding -** A new 'memoize-symbol evaluator trap has been added. This trap can -be used for efficiently implementing a Scheme code coverage. +** A new `memoize-symbol' evaluator trap has been added. + +This trap can be used for efficiently implementing a Scheme code +coverage. ** Duplicate bindings among used modules are resolved lazily. + This slightly improves program startup times. ** New thread cancellation and thread cleanup API + See `cancel-thread', `set-thread-cleanup!', and `thread-cleanup'. ** Fix bad interaction between `false-if-exception' and stack-call. @@ -502,7 +508,8 @@ indicating length of the `scm_t_option' array. This procedure corresponds to Scheme's `module-public-interface'. -** scm_stat has additional argument, exception_on_error +** `scm_stat' has an additional argument, `exception_on_error' +** `scm_primitive_load_path' has an additional argument `exception_on_not_found' * Changes to the distribution @@ -515,7 +522,7 @@ part of Guile). ** `guile-config' will be deprecated in favor of `pkg-config' `guile-config' has been rewritten to get its information from -pkg-config, so this should be a transparent change. Note however that +`pkg-config', so this should be a transparent change. Note however that guile.m4 has yet to be modified to call pkg-config instead of guile-config. From 23044464c2e26649329b422380a6850d53eec725 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 22:01:56 +0200 Subject: [PATCH 236/375] Fix copyright year and authorship of `guile-tools'. --- meta/guile-tools | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/meta/guile-tools b/meta/guile-tools index 3024726f7..0c66c7200 100755 --- a/meta/guile-tools +++ b/meta/guile-tools @@ -4,9 +4,9 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" !# ;;;; guile-tools --- running scripts bundled with Guile -;;;; Jim Blandy --- September 1997 +;;;; Andy Wingo --- April 2009 ;;;; -;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. +;;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public From f4bf64b4d422bb093a3e857380d99e4f08b9c8af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2009 22:46:07 +0200 Subject: [PATCH 237/375] Make `cond-expand' compilable. * module/ice-9/boot-9.scm (cond-expand): Changed into a `define-macro' macro. --- module/ice-9/boot-9.scm | 123 ++++++++++++++++++++-------------------- 1 file changed, 60 insertions(+), 63 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ed561d2ff..36a463ad3 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3192,69 +3192,66 @@ module '(ice-9 q) '(make-q q-length))}." (append (hashq-ref %cond-expand-table mod '()) features))))) -(define cond-expand - (procedure->memoizing-macro - (lambda (exp env) - (let ((clauses (cdr exp)) - (syntax-error (lambda (cl) - (error "invalid clause in `cond-expand'" cl)))) - (letrec - ((test-clause - (lambda (clause) - (cond - ((symbol? clause) - (or (memq clause %cond-expand-features) - (let lp ((uses (module-uses (env-module env)))) - (if (pair? uses) - (or (memq clause - (hashq-ref %cond-expand-table - (car uses) '())) - (lp (cdr uses))) - #f)))) - ((pair? clause) - (cond - ((eq? 'and (car clause)) - (let lp ((l (cdr clause))) - (cond ((null? l) - #t) - ((pair? l) - (and (test-clause (car l)) (lp (cdr l)))) - (else - (syntax-error clause))))) - ((eq? 'or (car clause)) - (let lp ((l (cdr clause))) - (cond ((null? l) - #f) - ((pair? l) - (or (test-clause (car l)) (lp (cdr l)))) - (else - (syntax-error clause))))) - ((eq? 'not (car clause)) - (cond ((not (pair? (cdr clause))) - (syntax-error clause)) - ((pair? (cddr clause)) - ((syntax-error clause)))) - (not (test-clause (cadr clause)))) - (else - (syntax-error clause)))) - (else - (syntax-error clause)))))) - (let lp ((c clauses)) - (cond - ((null? c) - (error "Unfulfilled `cond-expand'")) - ((not (pair? c)) - (syntax-error c)) - ((not (pair? (car c))) - (syntax-error (car c))) - ((test-clause (caar c)) - `(begin ,@(cdar c))) - ((eq? (caar c) 'else) - (if (pair? (cdr c)) - (syntax-error c)) - `(begin ,@(cdar c))) - (else - (lp (cdr c)))))))))) +(define-macro (cond-expand . clauses) + (let ((syntax-error (lambda (cl) + (error "invalid clause in `cond-expand'" cl)))) + (letrec + ((test-clause + (lambda (clause) + (cond + ((symbol? clause) + (or (memq clause %cond-expand-features) + (let lp ((uses (module-uses (current-module)))) + (if (pair? uses) + (or (memq clause + (hashq-ref %cond-expand-table + (car uses) '())) + (lp (cdr uses))) + #f)))) + ((pair? clause) + (cond + ((eq? 'and (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #t) + ((pair? l) + (and (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'or (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #f) + ((pair? l) + (or (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'not (car clause)) + (cond ((not (pair? (cdr clause))) + (syntax-error clause)) + ((pair? (cddr clause)) + ((syntax-error clause)))) + (not (test-clause (cadr clause)))) + (else + (syntax-error clause)))) + (else + (syntax-error clause)))))) + (let lp ((c clauses)) + (cond + ((null? c) + (error "Unfulfilled `cond-expand'")) + ((not (pair? c)) + (syntax-error c)) + ((not (pair? (car c))) + (syntax-error (car c))) + ((test-clause (caar c)) + `(begin ,@(cdar c))) + ((eq? (caar c) 'else) + (if (pair? (cdr c)) + (syntax-error c)) + `(begin ,@(cdar c))) + (else + (lp (cdr c)))))))) ;; This procedure gets called from the startup code with a list of ;; numbers, which are the numbers of the SRFIs to be loaded on startup. From fc5b616b5816a425863fd06c50f41513c31693f8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 20 Jun 2009 10:47:37 +0200 Subject: [PATCH 238/375] source information for the interpreter * module/ice-9/psyntax.scm: Try to propagate source information when generating output for the interpreter. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 7787 ++++++++++++++++++----------------- module/ice-9/psyntax.scm | 63 +- 2 files changed, 4050 insertions(+), 3800 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index a6e35b098..e2a3d60e3 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,90 +1,97 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 - (lambda (f57 first56 . rest55) - (let ((t58 (null? first56))) - (if t58 - t58 - (if (null? rest55) - (letrec ((andmap59 - (lambda (first60) - (let ((x61 (car first60)) - (first62 (cdr first60))) - (if (null? first62) - (f57 x61) - (if (f57 x61) (andmap59 first62) #f)))))) - (andmap59 first56)) - (letrec ((andmap63 - (lambda (first64 rest65) - (let ((x66 (car first64)) - (xr67 (map car rest65)) - (first68 (cdr first64)) - (rest69 (map cdr rest65))) - (if (null? first68) - (apply f57 (cons x66 xr67)) - (if (apply f57 (cons x66 xr67)) - (andmap63 first68 rest69) +(letrec ((and-map*2378 + (lambda (f2418 first2417 . rest2416) + (let ((t2419 (null? first2417))) + (if t2419 + t2419 + (if (null? rest2416) + (letrec ((andmap2420 + (lambda (first2421) + (let ((x2422 (car first2421)) + (first2423 (cdr first2421))) + (if (null? first2423) + (f2418 x2422) + (if (f2418 x2422) + (andmap2420 first2423) #f)))))) - (andmap63 first56 rest55)))))))) - (letrec ((lambda-var-list162 - (lambda (vars286) - (letrec ((lvl287 - (lambda (vars288 ls289 w290) - (if (pair? vars288) - (lvl287 - (cdr vars288) - (cons (wrap142 (car vars288) w290 #f) ls289) - w290) - (if (id?114 vars288) - (cons (wrap142 vars288 w290 #f) ls289) - (if (null? vars288) - ls289 - (if (syntax-object?98 vars288) - (lvl287 - (syntax-object-expression99 vars288) - ls289 - (join-wraps133 - w290 - (syntax-object-wrap100 vars288))) - (cons vars288 ls289)))))))) - (lvl287 vars286 (quote ()) (quote (())))))) - (gen-var161 - (lambda (id291) - (let ((id292 (if (syntax-object?98 id291) - (syntax-object-expression99 id291) - id291))) - (gensym (symbol->string id292))))) - (strip160 - (lambda (x293 w294) - (if (memq (quote top) (wrap-marks117 w294)) - x293 - (letrec ((f295 (lambda (x296) - (if (syntax-object?98 x296) - (strip160 - (syntax-object-expression99 x296) - (syntax-object-wrap100 x296)) - (if (pair? x296) - (let ((a297 (f295 (car x296))) - (d298 (f295 (cdr x296)))) - (if (if (eq? a297 (car x296)) - (eq? d298 (cdr x296)) - #f) - x296 - (cons a297 d298))) - (if (vector? x296) - (let ((old299 (vector->list x296))) - (let ((new300 (map f295 old299))) - (if (and-map*17 eq? old299 new300) - x296 - (list->vector new300)))) - x296)))))) - (f295 x293))))) - (ellipsis?159 - (lambda (x301) - (if (nonsymbol-id?113 x301) - (free-id=?137 - x301 + (andmap2420 first2417)) + (letrec ((andmap2424 + (lambda (first2425 rest2426) + (let ((x2427 (car first2425)) + (xr2428 (map car rest2426)) + (first2429 (cdr first2425)) + (rest2430 (map cdr rest2426))) + (if (null? first2429) + (apply f2418 (cons x2427 xr2428)) + (if (apply f2418 (cons x2427 xr2428)) + (andmap2424 first2429 rest2430) + #f)))))) + (andmap2424 first2417 rest2416)))))))) + (letrec ((lambda-var-list2524 + (lambda (vars2648) + (letrec ((lvl2649 + (lambda (vars2650 ls2651 w2652) + (if (pair? vars2650) + (lvl2649 + (cdr vars2650) + (cons (wrap2504 (car vars2650) w2652 #f) + ls2651) + w2652) + (if (id?2476 vars2650) + (cons (wrap2504 vars2650 w2652 #f) ls2651) + (if (null? vars2650) + ls2651 + (if (syntax-object?2460 vars2650) + (lvl2649 + (syntax-object-expression2461 vars2650) + ls2651 + (join-wraps2495 + w2652 + (syntax-object-wrap2462 vars2650))) + (cons vars2650 ls2651)))))))) + (lvl2649 vars2648 (quote ()) (quote (())))))) + (gen-var2523 + (lambda (id2653) + (let ((id2654 + (if (syntax-object?2460 id2653) + (syntax-object-expression2461 id2653) + id2653))) + (gensym (symbol->string id2654))))) + (strip2522 + (lambda (x2655 w2656) + (if (memq (quote top) (wrap-marks2479 w2656)) + x2655 + (letrec ((f2657 (lambda (x2658) + (if (syntax-object?2460 x2658) + (strip2522 + (syntax-object-expression2461 x2658) + (syntax-object-wrap2462 x2658)) + (if (pair? x2658) + (let ((a2659 (f2657 (car x2658))) + (d2660 (f2657 (cdr x2658)))) + (if (if (eq? a2659 (car x2658)) + (eq? d2660 (cdr x2658)) + #f) + x2658 + (cons a2659 d2660))) + (if (vector? x2658) + (let ((old2661 (vector->list x2658))) + (let ((new2662 (map f2657 old2661))) + (if (and-map*2378 + eq? + old2661 + new2662) + x2658 + (list->vector new2662)))) + x2658)))))) + (f2657 x2655))))) + (ellipsis?2521 + (lambda (x2663) + (if (nonsymbol-id?2475 x2663) + (free-id=?2499 + x2663 '#(syntax-object ... ((top) @@ -192,6 +199,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -313,6 +321,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -424,6 +433,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure and-map*) @@ -431,1128 +441,1172 @@ ("i" "i"))) (hygiene guile))) #f))) - (chi-void158 (lambda () (build-void80 #f))) - (eval-local-transformer157 - (lambda (expanded302 mod303) - (let ((p304 (local-eval-hook77 expanded302 mod303))) - (if (procedure? p304) - p304 + (chi-void2520 (lambda () (build-void2442 #f))) + (eval-local-transformer2519 + (lambda (expanded2664 mod2665) + (let ((p2666 (local-eval-hook2438 expanded2664 mod2665))) + (if (procedure? p2666) + p2666 (syntax-violation #f "nonprocedure transformer" - p304))))) - (chi-local-syntax156 - (lambda (rec?305 e306 r307 w308 s309 mod310 k311) - ((lambda (tmp312) - ((lambda (tmp313) - (if tmp313 - (apply (lambda (_314 id315 val316 e1317 e2318) - (let ((ids319 id315)) - (if (not (valid-bound-ids?139 ids319)) + p2666))))) + (chi-local-syntax2518 + (lambda (rec?2667 e2668 r2669 w2670 s2671 mod2672 k2673) + ((lambda (tmp2674) + ((lambda (tmp2675) + (if tmp2675 + (apply (lambda (_2676 id2677 val2678 e12679 e22680) + (let ((ids2681 id2677)) + (if (not (valid-bound-ids?2501 ids2681)) (syntax-violation #f "duplicate bound keyword" - e306) - (let ((labels321 (gen-labels120 ids319))) - (let ((new-w322 - (make-binding-wrap131 - ids319 - labels321 - w308))) - (k311 (cons e1317 e2318) - (extend-env108 - labels321 - (let ((w324 (if rec?305 - new-w322 - w308)) - (trans-r325 - (macros-only-env110 - r307))) - (map (lambda (x326) - (cons 'macro - (eval-local-transformer157 - (chi150 - x326 - trans-r325 - w324 - mod310) - mod310))) - val316)) - r307) - new-w322 - s309 - mod310)))))) - tmp313) - ((lambda (_328) + e2668) + (let ((labels2683 + (gen-labels2482 ids2681))) + (let ((new-w2684 + (make-binding-wrap2493 + ids2681 + labels2683 + w2670))) + (k2673 (cons e12679 e22680) + (extend-env2470 + labels2683 + (let ((w2686 (if rec?2667 + new-w2684 + w2670)) + (trans-r2687 + (macros-only-env2472 + r2669))) + (map (lambda (x2688) + (cons 'macro + (eval-local-transformer2519 + (chi2512 + x2688 + trans-r2687 + w2686 + mod2672) + mod2672))) + val2678)) + r2669) + new-w2684 + s2671 + mod2672)))))) + tmp2675) + ((lambda (_2690) (syntax-violation #f "bad local syntax definition" - (source-wrap143 e306 w308 s309 mod310))) - tmp312))) + (source-wrap2505 e2668 w2670 s2671 mod2672))) + tmp2674))) ($sc-dispatch - tmp312 + tmp2674 '(any #(each (any any)) any . each-any)))) - e306))) - (chi-lambda-clause155 - (lambda (e329 docstring330 c331 r332 w333 mod334 k335) - ((lambda (tmp336) - ((lambda (tmp337) - (if (if tmp337 - (apply (lambda (args338 doc339 e1340 e2341) - (if (string? (syntax->datum doc339)) - (not docstring330) + e2668))) + (chi-lambda-clause2517 + (lambda (e2691 + docstring2692 + c2693 + r2694 + w2695 + mod2696 + k2697) + ((lambda (tmp2698) + ((lambda (tmp2699) + (if (if tmp2699 + (apply (lambda (args2700 doc2701 e12702 e22703) + (if (string? (syntax->datum doc2701)) + (not docstring2692) #f)) - tmp337) + tmp2699) #f) - (apply (lambda (args342 doc343 e1344 e2345) - (chi-lambda-clause155 - e329 - doc343 - (cons args342 (cons e1344 e2345)) - r332 - w333 - mod334 - k335)) - tmp337) - ((lambda (tmp347) - (if tmp347 - (apply (lambda (id348 e1349 e2350) - (let ((ids351 id348)) - (if (not (valid-bound-ids?139 ids351)) + (apply (lambda (args2704 doc2705 e12706 e22707) + (chi-lambda-clause2517 + e2691 + doc2705 + (cons args2704 (cons e12706 e22707)) + r2694 + w2695 + mod2696 + k2697)) + tmp2699) + ((lambda (tmp2709) + (if tmp2709 + (apply (lambda (id2710 e12711 e22712) + (let ((ids2713 id2710)) + (if (not (valid-bound-ids?2501 ids2713)) (syntax-violation 'lambda "invalid parameter list" - e329) - (let ((labels353 - (gen-labels120 ids351)) - (new-vars354 - (map gen-var161 ids351))) - (k335 (map syntax->datum ids351) - new-vars354 - (if docstring330 - (syntax->datum docstring330) - #f) - (chi-body154 - (cons e1349 e2350) - e329 - (extend-var-env109 - labels353 - new-vars354 - r332) - (make-binding-wrap131 - ids351 - labels353 - w333) - mod334)))))) - tmp347) - ((lambda (tmp356) - (if tmp356 - (apply (lambda (ids357 e1358 e2359) - (let ((old-ids360 - (lambda-var-list162 ids357))) - (if (not (valid-bound-ids?139 - old-ids360)) + e2691) + (let ((labels2715 + (gen-labels2482 ids2713)) + (new-vars2716 + (map gen-var2523 ids2713))) + (k2697 (map syntax->datum ids2713) + new-vars2716 + (if docstring2692 + (syntax->datum + docstring2692) + #f) + (chi-body2516 + (cons e12711 e22712) + e2691 + (extend-var-env2471 + labels2715 + new-vars2716 + r2694) + (make-binding-wrap2493 + ids2713 + labels2715 + w2695) + mod2696)))))) + tmp2709) + ((lambda (tmp2718) + (if tmp2718 + (apply (lambda (ids2719 e12720 e22721) + (let ((old-ids2722 + (lambda-var-list2524 + ids2719))) + (if (not (valid-bound-ids?2501 + old-ids2722)) (syntax-violation 'lambda "invalid parameter list" - e329) - (let ((labels361 - (gen-labels120 - old-ids360)) - (new-vars362 - (map gen-var161 - old-ids360))) - (k335 (letrec ((f363 (lambda (ls1364 - ls2365) - (if (null? ls1364) - (syntax->datum - ls2365) - (f363 (cdr ls1364) - (cons (syntax->datum - (car ls1364)) - ls2365)))))) - (f363 (cdr old-ids360) - (car old-ids360))) - (letrec ((f366 (lambda (ls1367 - ls2368) - (if (null? ls1367) - ls2368 - (f366 (cdr ls1367) - (cons (car ls1367) - ls2368)))))) - (f366 (cdr new-vars362) - (car new-vars362))) - (if docstring330 - (syntax->datum - docstring330) - #f) - (chi-body154 - (cons e1358 e2359) - e329 - (extend-var-env109 - labels361 - new-vars362 - r332) - (make-binding-wrap131 - old-ids360 - labels361 - w333) - mod334)))))) - tmp356) - ((lambda (_370) + e2691) + (let ((labels2723 + (gen-labels2482 + old-ids2722)) + (new-vars2724 + (map gen-var2523 + old-ids2722))) + (k2697 (letrec ((f2725 (lambda (ls12726 + ls22727) + (if (null? ls12726) + (syntax->datum + ls22727) + (f2725 (cdr ls12726) + (cons (syntax->datum + (car ls12726)) + ls22727)))))) + (f2725 (cdr old-ids2722) + (car old-ids2722))) + (letrec ((f2728 (lambda (ls12729 + ls22730) + (if (null? ls12729) + ls22730 + (f2728 (cdr ls12729) + (cons (car ls12729) + ls22730)))))) + (f2728 (cdr new-vars2724) + (car new-vars2724))) + (if docstring2692 + (syntax->datum + docstring2692) + #f) + (chi-body2516 + (cons e12720 e22721) + e2691 + (extend-var-env2471 + labels2723 + new-vars2724 + r2694) + (make-binding-wrap2493 + old-ids2722 + labels2723 + w2695) + mod2696)))))) + tmp2718) + ((lambda (_2732) (syntax-violation 'lambda "bad lambda" - e329)) - tmp336))) + e2691)) + tmp2698))) ($sc-dispatch - tmp336 + tmp2698 '(any any . each-any))))) ($sc-dispatch - tmp336 + tmp2698 '(each-any any . each-any))))) ($sc-dispatch - tmp336 + tmp2698 '(any any any . each-any)))) - c331))) - (chi-body154 - (lambda (body371 outer-form372 r373 w374 mod375) - (let ((r376 (cons (quote ("placeholder" placeholder)) r373))) - (let ((ribcage377 - (make-ribcage121 + c2693))) + (chi-body2516 + (lambda (body2733 outer-form2734 r2735 w2736 mod2737) + (let ((r2738 (cons (quote ("placeholder" placeholder)) r2735))) + (let ((ribcage2739 + (make-ribcage2483 '() '() '()))) - (let ((w378 (make-wrap116 - (wrap-marks117 w374) - (cons ribcage377 (wrap-subst118 w374))))) - (letrec ((parse379 - (lambda (body380 - ids381 - labels382 - var-ids383 - vars384 - vals385 - bindings386) - (if (null? body380) + (let ((w2740 (make-wrap2478 + (wrap-marks2479 w2736) + (cons ribcage2739 (wrap-subst2480 w2736))))) + (letrec ((parse2741 + (lambda (body2742 + ids2743 + labels2744 + var-ids2745 + vars2746 + vals2747 + bindings2748) + (if (null? body2742) (syntax-violation #f "no expressions in body" - outer-form372) - (let ((e388 (cdar body380)) - (er389 (caar body380))) + outer-form2734) + (let ((e2750 (cdar body2742)) + (er2751 (caar body2742))) (call-with-values (lambda () - (syntax-type148 - e388 - er389 + (syntax-type2510 + e2750 + er2751 '(()) - (source-annotation105 er389) - ribcage377 - mod375 + (source-annotation2467 er2751) + ribcage2739 + mod2737 #f)) - (lambda (type390 - value391 - e392 - w393 - s394 - mod395) - (if (memv type390 + (lambda (type2752 + value2753 + e2754 + w2755 + s2756 + mod2757) + (if (memv type2752 '(define-form)) - (let ((id396 (wrap142 - value391 - w393 - mod395)) - (label397 (gen-label119))) - (let ((var398 - (gen-var161 id396))) + (let ((id2758 + (wrap2504 + value2753 + w2755 + mod2757)) + (label2759 (gen-label2481))) + (let ((var2760 + (gen-var2523 id2758))) (begin - (extend-ribcage!130 - ribcage377 - id396 - label397) - (parse379 - (cdr body380) - (cons id396 ids381) - (cons label397 labels382) - (cons id396 var-ids383) - (cons var398 vars384) - (cons (cons er389 - (wrap142 - e392 - w393 - mod395)) - vals385) + (extend-ribcage!2492 + ribcage2739 + id2758 + label2759) + (parse2741 + (cdr body2742) + (cons id2758 ids2743) + (cons label2759 labels2744) + (cons id2758 var-ids2745) + (cons var2760 vars2746) + (cons (cons er2751 + (wrap2504 + e2754 + w2755 + mod2757)) + vals2747) (cons (cons 'lexical - var398) - bindings386))))) - (if (memv type390 + var2760) + bindings2748))))) + (if (memv type2752 '(define-syntax-form)) - (let ((id399 (wrap142 - value391 - w393 - mod395)) - (label400 (gen-label119))) + (let ((id2761 + (wrap2504 + value2753 + w2755 + mod2757)) + (label2762 + (gen-label2481))) (begin - (extend-ribcage!130 - ribcage377 - id399 - label400) - (parse379 - (cdr body380) - (cons id399 ids381) - (cons label400 labels382) - var-ids383 - vars384 - vals385 + (extend-ribcage!2492 + ribcage2739 + id2761 + label2762) + (parse2741 + (cdr body2742) + (cons id2761 ids2743) + (cons label2762 labels2744) + var-ids2745 + vars2746 + vals2747 (cons (cons 'macro - (cons er389 - (wrap142 - e392 - w393 - mod395))) - bindings386)))) - (if (memv type390 + (cons er2751 + (wrap2504 + e2754 + w2755 + mod2757))) + bindings2748)))) + (if (memv type2752 '(begin-form)) - ((lambda (tmp401) - ((lambda (tmp402) - (if tmp402 - (apply (lambda (_403 - e1404) - (parse379 - (letrec ((f405 (lambda (forms406) - (if (null? forms406) - (cdr body380) - (cons (cons er389 - (wrap142 - (car forms406) - w393 - mod395)) - (f405 (cdr forms406))))))) - (f405 e1404)) - ids381 - labels382 - var-ids383 - vars384 - vals385 - bindings386)) - tmp402) + ((lambda (tmp2763) + ((lambda (tmp2764) + (if tmp2764 + (apply (lambda (_2765 + e12766) + (parse2741 + (letrec ((f2767 (lambda (forms2768) + (if (null? forms2768) + (cdr body2742) + (cons (cons er2751 + (wrap2504 + (car forms2768) + w2755 + mod2757)) + (f2767 (cdr forms2768))))))) + (f2767 e12766)) + ids2743 + labels2744 + var-ids2745 + vars2746 + vals2747 + bindings2748)) + tmp2764) (syntax-violation #f "source expression failed to match any pattern" - tmp401))) + tmp2763))) ($sc-dispatch - tmp401 + tmp2763 '(any . each-any)))) - e392) - (if (memv type390 + e2754) + (if (memv type2752 '(local-syntax-form)) - (chi-local-syntax156 - value391 - e392 - er389 - w393 - s394 - mod395 - (lambda (forms408 - er409 - w410 - s411 - mod412) - (parse379 - (letrec ((f413 (lambda (forms414) - (if (null? forms414) - (cdr body380) - (cons (cons er409 - (wrap142 - (car forms414) - w410 - mod412)) - (f413 (cdr forms414))))))) - (f413 forms408)) - ids381 - labels382 - var-ids383 - vars384 - vals385 - bindings386))) - (if (null? ids381) - (build-sequence93 + (chi-local-syntax2518 + value2753 + e2754 + er2751 + w2755 + s2756 + mod2757 + (lambda (forms2770 + er2771 + w2772 + s2773 + mod2774) + (parse2741 + (letrec ((f2775 (lambda (forms2776) + (if (null? forms2776) + (cdr body2742) + (cons (cons er2771 + (wrap2504 + (car forms2776) + w2772 + mod2774)) + (f2775 (cdr forms2776))))))) + (f2775 forms2770)) + ids2743 + labels2744 + var-ids2745 + vars2746 + vals2747 + bindings2748))) + (if (null? ids2743) + (build-sequence2455 #f - (map (lambda (x415) - (chi150 - (cdr x415) - (car x415) + (map (lambda (x2777) + (chi2512 + (cdr x2777) + (car x2777) '(()) - mod395)) - (cons (cons er389 - (source-wrap143 - e392 - w393 - s394 - mod395)) - (cdr body380)))) + mod2757)) + (cons (cons er2751 + (source-wrap2505 + e2754 + w2755 + s2756 + mod2757)) + (cdr body2742)))) (begin - (if (not (valid-bound-ids?139 - ids381)) + (if (not (valid-bound-ids?2501 + ids2743)) (syntax-violation #f "invalid or duplicate identifier in definition" - outer-form372)) - (letrec ((loop416 - (lambda (bs417 - er-cache418 - r-cache419) - (if (not (null? bs417)) - (let ((b420 (car bs417))) - (if (eq? (car b420) + outer-form2734)) + (letrec ((loop2778 + (lambda (bs2779 + er-cache2780 + r-cache2781) + (if (not (null? bs2779)) + (let ((b2782 (car bs2779))) + (if (eq? (car b2782) 'macro) - (let ((er421 (cadr b420))) - (let ((r-cache422 - (if (eq? er421 - er-cache418) - r-cache419 - (macros-only-env110 - er421)))) + (let ((er2783 + (cadr b2782))) + (let ((r-cache2784 + (if (eq? er2783 + er-cache2780) + r-cache2781 + (macros-only-env2472 + er2783)))) (begin (set-cdr! - b420 - (eval-local-transformer157 - (chi150 - (cddr b420) - r-cache422 + b2782 + (eval-local-transformer2519 + (chi2512 + (cddr b2782) + r-cache2784 '(()) - mod395) - mod395)) - (loop416 - (cdr bs417) - er421 - r-cache422)))) - (loop416 - (cdr bs417) - er-cache418 - r-cache419))))))) - (loop416 - bindings386 + mod2757) + mod2757)) + (loop2778 + (cdr bs2779) + er2783 + r-cache2784)))) + (loop2778 + (cdr bs2779) + er-cache2780 + r-cache2781))))))) + (loop2778 + bindings2748 #f #f)) (set-cdr! - r376 - (extend-env108 - labels382 - bindings386 - (cdr r376))) - (build-letrec96 + r2738 + (extend-env2470 + labels2744 + bindings2748 + (cdr r2738))) + (build-letrec2458 #f (map syntax->datum - var-ids383) - vars384 - (map (lambda (x423) - (chi150 - (cdr x423) - (car x423) + var-ids2745) + vars2746 + (map (lambda (x2785) + (chi2512 + (cdr x2785) + (car x2785) '(()) - mod395)) - vals385) - (build-sequence93 + mod2757)) + vals2747) + (build-sequence2455 #f - (map (lambda (x424) - (chi150 - (cdr x424) - (car x424) + (map (lambda (x2786) + (chi2512 + (cdr x2786) + (car x2786) '(()) - mod395)) - (cons (cons er389 - (source-wrap143 - e392 - w393 - s394 - mod395)) - (cdr body380)))))))))))))))))) - (parse379 - (map (lambda (x387) - (cons r376 (wrap142 x387 w378 mod375))) - body371) + mod2757)) + (cons (cons er2751 + (source-wrap2505 + e2754 + w2755 + s2756 + mod2757)) + (cdr body2742)))))))))))))))))) + (parse2741 + (map (lambda (x2749) + (cons r2738 (wrap2504 x2749 w2740 mod2737))) + body2733) '() '() '() '() '() '()))))))) - (chi-macro153 - (lambda (p425 e426 r427 w428 rib429 mod430) - (letrec ((rebuild-macro-output431 - (lambda (x432 m433) - (if (pair? x432) - (cons (rebuild-macro-output431 (car x432) m433) - (rebuild-macro-output431 (cdr x432) m433)) - (if (syntax-object?98 x432) - (let ((w434 (syntax-object-wrap100 x432))) - (let ((ms435 (wrap-marks117 w434)) - (s436 (wrap-subst118 w434))) - (if (if (pair? ms435) - (eq? (car ms435) #f) + (chi-macro2515 + (lambda (p2787 e2788 r2789 w2790 rib2791 mod2792) + (letrec ((rebuild-macro-output2793 + (lambda (x2794 m2795) + (if (pair? x2794) + (cons (rebuild-macro-output2793 + (car x2794) + m2795) + (rebuild-macro-output2793 + (cdr x2794) + m2795)) + (if (syntax-object?2460 x2794) + (let ((w2796 (syntax-object-wrap2462 x2794))) + (let ((ms2797 (wrap-marks2479 w2796)) + (s2798 (wrap-subst2480 w2796))) + (if (if (pair? ms2797) + (eq? (car ms2797) #f) #f) - (make-syntax-object97 - (syntax-object-expression99 x432) - (make-wrap116 - (cdr ms435) - (if rib429 - (cons rib429 (cdr s436)) - (cdr s436))) - (syntax-object-module101 x432)) - (make-syntax-object97 - (syntax-object-expression99 x432) - (make-wrap116 - (cons m433 ms435) - (if rib429 - (cons rib429 - (cons (quote shift) s436)) - (cons (quote shift) s436))) - (let ((pmod437 - (procedure-module p425))) - (if pmod437 + (make-syntax-object2459 + (syntax-object-expression2461 x2794) + (make-wrap2478 + (cdr ms2797) + (if rib2791 + (cons rib2791 (cdr s2798)) + (cdr s2798))) + (syntax-object-module2463 x2794)) + (make-syntax-object2459 + (syntax-object-expression2461 x2794) + (make-wrap2478 + (cons m2795 ms2797) + (if rib2791 + (cons rib2791 + (cons (quote shift) s2798)) + (cons (quote shift) s2798))) + (let ((pmod2799 + (procedure-module p2787))) + (if pmod2799 (cons 'hygiene - (module-name pmod437)) + (module-name pmod2799)) '(hygiene guile))))))) - (if (vector? x432) - (let ((n438 (vector-length x432))) - (let ((v439 (make-vector n438))) - (letrec ((loop440 - (lambda (i441) - (if (fx=74 i441 n438) - (begin (if #f #f) v439) + (if (vector? x2794) + (let ((n2800 (vector-length x2794))) + (let ((v2801 (make-vector n2800))) + (letrec ((loop2802 + (lambda (i2803) + (if (fx=2435 i2803 n2800) + (begin (if #f #f) v2801) (begin (vector-set! - v439 - i441 - (rebuild-macro-output431 + v2801 + i2803 + (rebuild-macro-output2793 (vector-ref - x432 - i441) - m433)) - (loop440 - (fx+72 i441 1))))))) - (loop440 0)))) - (if (symbol? x432) + x2794 + i2803) + m2795)) + (loop2802 + (fx+2433 + i2803 + 1))))))) + (loop2802 0)))) + (if (symbol? x2794) (syntax-violation #f "encountered raw symbol in macro output" - (source-wrap143 e426 w428 s mod430) - x432) - x432))))))) - (rebuild-macro-output431 - (p425 (wrap142 e426 (anti-mark129 w428) mod430)) + (source-wrap2505 e2788 w2790 s mod2792) + x2794) + x2794))))))) + (rebuild-macro-output2793 + (p2787 (wrap2504 e2788 (anti-mark2491 w2790) mod2792)) (string #\m))))) - (chi-application152 - (lambda (x442 e443 r444 w445 s446 mod447) - ((lambda (tmp448) - ((lambda (tmp449) - (if tmp449 - (apply (lambda (e0450 e1451) - (build-application81 - s446 - x442 - (map (lambda (e452) - (chi150 e452 r444 w445 mod447)) - e1451))) - tmp449) + (chi-application2514 + (lambda (x2804 e2805 r2806 w2807 s2808 mod2809) + ((lambda (tmp2810) + ((lambda (tmp2811) + (if tmp2811 + (apply (lambda (e02812 e12813) + (build-application2443 + s2808 + x2804 + (map (lambda (e2814) + (chi2512 e2814 r2806 w2807 mod2809)) + e12813))) + tmp2811) (syntax-violation #f "source expression failed to match any pattern" - tmp448))) - ($sc-dispatch tmp448 (quote (any . each-any))))) - e443))) - (chi-expr151 - (lambda (type454 value455 e456 r457 w458 s459 mod460) - (if (memv type454 (quote (lexical))) - (build-lexical-reference83 + tmp2810))) + ($sc-dispatch tmp2810 (quote (any . each-any))))) + e2805))) + (chi-expr2513 + (lambda (type2816 + value2817 + e2818 + r2819 + w2820 + s2821 + mod2822) + (if (memv type2816 (quote (lexical))) + (build-lexical-reference2445 'value - s459 - e456 - value455) - (if (memv type454 (quote (core core-form))) - (value455 e456 r457 w458 s459 mod460) - (if (memv type454 (quote (module-ref))) + s2821 + e2818 + value2817) + (if (memv type2816 (quote (core core-form))) + (value2817 e2818 r2819 w2820 s2821 mod2822) + (if (memv type2816 (quote (module-ref))) (call-with-values - (lambda () (value455 e456)) - (lambda (id461 mod462) - (build-global-reference86 s459 id461 mod462))) - (if (memv type454 (quote (lexical-call))) - (chi-application152 - (build-lexical-reference83 + (lambda () (value2817 e2818)) + (lambda (id2823 mod2824) + (build-global-reference2448 s2821 id2823 mod2824))) + (if (memv type2816 (quote (lexical-call))) + (chi-application2514 + (build-lexical-reference2445 'fun - (source-annotation105 (car e456)) - (car e456) - value455) - e456 - r457 - w458 - s459 - mod460) - (if (memv type454 (quote (global-call))) - (chi-application152 - (build-global-reference86 - (source-annotation105 (car e456)) - (if (syntax-object?98 value455) - (syntax-object-expression99 value455) - value455) - (if (syntax-object?98 value455) - (syntax-object-module101 value455) - mod460)) - e456 - r457 - w458 - s459 - mod460) - (if (memv type454 (quote (constant))) - (build-data92 - s459 - (strip160 - (source-wrap143 e456 w458 s459 mod460) + (source-annotation2467 (car e2818)) + (car e2818) + value2817) + e2818 + r2819 + w2820 + s2821 + mod2822) + (if (memv type2816 (quote (global-call))) + (chi-application2514 + (build-global-reference2448 + (source-annotation2467 (car e2818)) + (if (syntax-object?2460 value2817) + (syntax-object-expression2461 value2817) + value2817) + (if (syntax-object?2460 value2817) + (syntax-object-module2463 value2817) + mod2822)) + e2818 + r2819 + w2820 + s2821 + mod2822) + (if (memv type2816 (quote (constant))) + (build-data2454 + s2821 + (strip2522 + (source-wrap2505 e2818 w2820 s2821 mod2822) '(()))) - (if (memv type454 (quote (global))) - (build-global-reference86 s459 value455 mod460) - (if (memv type454 (quote (call))) - (chi-application152 - (chi150 (car e456) r457 w458 mod460) - e456 - r457 - w458 - s459 - mod460) - (if (memv type454 (quote (begin-form))) - ((lambda (tmp463) - ((lambda (tmp464) - (if tmp464 - (apply (lambda (_465 e1466 e2467) - (chi-sequence144 - (cons e1466 e2467) - r457 - w458 - s459 - mod460)) - tmp464) + (if (memv type2816 (quote (global))) + (build-global-reference2448 + s2821 + value2817 + mod2822) + (if (memv type2816 (quote (call))) + (chi-application2514 + (chi2512 (car e2818) r2819 w2820 mod2822) + e2818 + r2819 + w2820 + s2821 + mod2822) + (if (memv type2816 (quote (begin-form))) + ((lambda (tmp2825) + ((lambda (tmp2826) + (if tmp2826 + (apply (lambda (_2827 e12828 e22829) + (chi-sequence2506 + (cons e12828 e22829) + r2819 + w2820 + s2821 + mod2822)) + tmp2826) (syntax-violation #f "source expression failed to match any pattern" - tmp463))) + tmp2825))) ($sc-dispatch - tmp463 + tmp2825 '(any any . each-any)))) - e456) - (if (memv type454 (quote (local-syntax-form))) - (chi-local-syntax156 - value455 - e456 - r457 - w458 - s459 - mod460 - chi-sequence144) - (if (memv type454 (quote (eval-when-form))) - ((lambda (tmp469) - ((lambda (tmp470) - (if tmp470 - (apply (lambda (_471 - x472 - e1473 - e2474) - (let ((when-list475 - (chi-when-list147 - e456 - x472 - w458))) + e2818) + (if (memv type2816 + '(local-syntax-form)) + (chi-local-syntax2518 + value2817 + e2818 + r2819 + w2820 + s2821 + mod2822 + chi-sequence2506) + (if (memv type2816 (quote (eval-when-form))) + ((lambda (tmp2831) + ((lambda (tmp2832) + (if tmp2832 + (apply (lambda (_2833 + x2834 + e12835 + e22836) + (let ((when-list2837 + (chi-when-list2509 + e2818 + x2834 + w2820))) (if (memq 'eval - when-list475) - (chi-sequence144 - (cons e1473 e2474) - r457 - w458 - s459 - mod460) - (chi-void158)))) - tmp470) + when-list2837) + (chi-sequence2506 + (cons e12835 + e22836) + r2819 + w2820 + s2821 + mod2822) + (chi-void2520)))) + tmp2832) (syntax-violation #f "source expression failed to match any pattern" - tmp469))) + tmp2831))) ($sc-dispatch - tmp469 + tmp2831 '(any each-any any . each-any)))) - e456) - (if (memv type454 + e2818) + (if (memv type2816 '(define-form define-syntax-form)) (syntax-violation #f "definition in expression context" - e456 - (wrap142 value455 w458 mod460)) - (if (memv type454 (quote (syntax))) + e2818 + (wrap2504 value2817 w2820 mod2822)) + (if (memv type2816 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" - (source-wrap143 - e456 - w458 - s459 - mod460)) - (if (memv type454 + (source-wrap2505 + e2818 + w2820 + s2821 + mod2822)) + (if (memv type2816 '(displaced-lexical)) (syntax-violation #f "reference to identifier outside its scope" - (source-wrap143 - e456 - w458 - s459 - mod460)) + (source-wrap2505 + e2818 + w2820 + s2821 + mod2822)) (syntax-violation #f "unexpected syntax" - (source-wrap143 - e456 - w458 - s459 - mod460)))))))))))))))))) - (chi150 - (lambda (e478 r479 w480 mod481) + (source-wrap2505 + e2818 + w2820 + s2821 + mod2822)))))))))))))))))) + (chi2512 + (lambda (e2840 r2841 w2842 mod2843) (call-with-values (lambda () - (syntax-type148 - e478 - r479 - w480 - (source-annotation105 e478) + (syntax-type2510 + e2840 + r2841 + w2842 + (source-annotation2467 e2840) #f - mod481 + mod2843 #f)) - (lambda (type482 value483 e484 w485 s486 mod487) - (chi-expr151 - type482 - value483 - e484 - r479 - w485 - s486 - mod487))))) - (chi-top149 - (lambda (e488 r489 w490 m491 esew492 mod493) + (lambda (type2844 value2845 e2846 w2847 s2848 mod2849) + (chi-expr2513 + type2844 + value2845 + e2846 + r2841 + w2847 + s2848 + mod2849))))) + (chi-top2511 + (lambda (e2850 r2851 w2852 m2853 esew2854 mod2855) (call-with-values (lambda () - (syntax-type148 - e488 - r489 - w490 - (source-annotation105 e488) + (syntax-type2510 + e2850 + r2851 + w2852 + (source-annotation2467 e2850) #f - mod493 + mod2855 #f)) - (lambda (type501 value502 e503 w504 s505 mod506) - (if (memv type501 (quote (begin-form))) - ((lambda (tmp507) - ((lambda (tmp508) - (if tmp508 - (apply (lambda (_509) (chi-void158)) tmp508) - ((lambda (tmp510) - (if tmp510 - (apply (lambda (_511 e1512 e2513) - (chi-top-sequence145 - (cons e1512 e2513) - r489 - w504 - s505 - m491 - esew492 - mod506)) - tmp510) + (lambda (type2863 value2864 e2865 w2866 s2867 mod2868) + (if (memv type2863 (quote (begin-form))) + ((lambda (tmp2869) + ((lambda (tmp2870) + (if tmp2870 + (apply (lambda (_2871) (chi-void2520)) tmp2870) + ((lambda (tmp2872) + (if tmp2872 + (apply (lambda (_2873 e12874 e22875) + (chi-top-sequence2507 + (cons e12874 e22875) + r2851 + w2866 + s2867 + m2853 + esew2854 + mod2868)) + tmp2872) (syntax-violation #f "source expression failed to match any pattern" - tmp507))) + tmp2869))) ($sc-dispatch - tmp507 + tmp2869 '(any any . each-any))))) - ($sc-dispatch tmp507 (quote (any))))) - e503) - (if (memv type501 (quote (local-syntax-form))) - (chi-local-syntax156 - value502 - e503 - r489 - w504 - s505 - mod506 - (lambda (body515 r516 w517 s518 mod519) - (chi-top-sequence145 - body515 - r516 - w517 - s518 - m491 - esew492 - mod519))) - (if (memv type501 (quote (eval-when-form))) - ((lambda (tmp520) - ((lambda (tmp521) - (if tmp521 - (apply (lambda (_522 x523 e1524 e2525) - (let ((when-list526 - (chi-when-list147 - e503 - x523 - w504)) - (body527 (cons e1524 e2525))) - (if (eq? m491 (quote e)) + ($sc-dispatch tmp2869 (quote (any))))) + e2865) + (if (memv type2863 (quote (local-syntax-form))) + (chi-local-syntax2518 + value2864 + e2865 + r2851 + w2866 + s2867 + mod2868 + (lambda (body2877 r2878 w2879 s2880 mod2881) + (chi-top-sequence2507 + body2877 + r2878 + w2879 + s2880 + m2853 + esew2854 + mod2881))) + (if (memv type2863 (quote (eval-when-form))) + ((lambda (tmp2882) + ((lambda (tmp2883) + (if tmp2883 + (apply (lambda (_2884 x2885 e12886 e22887) + (let ((when-list2888 + (chi-when-list2509 + e2865 + x2885 + w2866)) + (body2889 + (cons e12886 e22887))) + (if (eq? m2853 (quote e)) (if (memq 'eval - when-list526) - (chi-top-sequence145 - body527 - r489 - w504 - s505 + when-list2888) + (chi-top-sequence2507 + body2889 + r2851 + w2866 + s2867 'e '(eval) - mod506) - (chi-void158)) + mod2868) + (chi-void2520)) (if (memq 'load - when-list526) - (if (let ((t530 (memq 'compile - when-list526))) - (if t530 - t530 - (if (eq? m491 + when-list2888) + (if (let ((t2892 (memq 'compile + when-list2888))) + (if t2892 + t2892 + (if (eq? m2853 'c&e) (memq 'eval - when-list526) + when-list2888) #f))) - (chi-top-sequence145 - body527 - r489 - w504 - s505 + (chi-top-sequence2507 + body2889 + r2851 + w2866 + s2867 'c&e '(compile load) - mod506) - (if (memq m491 + mod2868) + (if (memq m2853 '(c c&e)) - (chi-top-sequence145 - body527 - r489 - w504 - s505 + (chi-top-sequence2507 + body2889 + r2851 + w2866 + s2867 'c '(load) - mod506) - (chi-void158))) - (if (let ((t531 (memq 'compile - when-list526))) - (if t531 - t531 - (if (eq? m491 + mod2868) + (chi-void2520))) + (if (let ((t2893 (memq 'compile + when-list2888))) + (if t2893 + t2893 + (if (eq? m2853 'c&e) (memq 'eval - when-list526) + when-list2888) #f))) (begin - (top-level-eval-hook76 - (chi-top-sequence145 - body527 - r489 - w504 - s505 + (top-level-eval-hook2437 + (chi-top-sequence2507 + body2889 + r2851 + w2866 + s2867 'e '(eval) - mod506) - mod506) - (chi-void158)) - (chi-void158)))))) - tmp521) + mod2868) + mod2868) + (chi-void2520)) + (chi-void2520)))))) + tmp2883) (syntax-violation #f "source expression failed to match any pattern" - tmp520))) + tmp2882))) ($sc-dispatch - tmp520 + tmp2882 '(any each-any any . each-any)))) - e503) - (if (memv type501 (quote (define-syntax-form))) - (let ((n532 (id-var-name136 value502 w504)) - (r533 (macros-only-env110 r489))) - (if (memv m491 (quote (c))) - (if (memq (quote compile) esew492) - (let ((e534 (chi-install-global146 - n532 - (chi150 - e503 - r533 - w504 - mod506)))) + e2865) + (if (memv type2863 (quote (define-syntax-form))) + (let ((n2894 (id-var-name2498 value2864 w2866)) + (r2895 (macros-only-env2472 r2851))) + (if (memv m2853 (quote (c))) + (if (memq (quote compile) esew2854) + (let ((e2896 (chi-install-global2508 + n2894 + (chi2512 + e2865 + r2895 + w2866 + mod2868)))) (begin - (top-level-eval-hook76 e534 mod506) - (if (memq (quote load) esew492) - e534 - (chi-void158)))) - (if (memq (quote load) esew492) - (chi-install-global146 - n532 - (chi150 e503 r533 w504 mod506)) - (chi-void158))) - (if (memv m491 (quote (c&e))) - (let ((e535 (chi-install-global146 - n532 - (chi150 - e503 - r533 - w504 - mod506)))) + (top-level-eval-hook2437 e2896 mod2868) + (if (memq (quote load) esew2854) + e2896 + (chi-void2520)))) + (if (memq (quote load) esew2854) + (chi-install-global2508 + n2894 + (chi2512 e2865 r2895 w2866 mod2868)) + (chi-void2520))) + (if (memv m2853 (quote (c&e))) + (let ((e2897 (chi-install-global2508 + n2894 + (chi2512 + e2865 + r2895 + w2866 + mod2868)))) (begin - (top-level-eval-hook76 e535 mod506) - e535)) + (top-level-eval-hook2437 e2897 mod2868) + e2897)) (begin - (if (memq (quote eval) esew492) - (top-level-eval-hook76 - (chi-install-global146 - n532 - (chi150 e503 r533 w504 mod506)) - mod506)) - (chi-void158))))) - (if (memv type501 (quote (define-form))) - (let ((n536 (id-var-name136 value502 w504))) - (let ((type537 - (binding-type106 - (lookup111 n536 r489 mod506)))) - (if (memv type537 + (if (memq (quote eval) esew2854) + (top-level-eval-hook2437 + (chi-install-global2508 + n2894 + (chi2512 e2865 r2895 w2866 mod2868)) + mod2868)) + (chi-void2520))))) + (if (memv type2863 (quote (define-form))) + (let ((n2898 (id-var-name2498 value2864 w2866))) + (let ((type2899 + (binding-type2468 + (lookup2473 n2898 r2851 mod2868)))) + (if (memv type2899 '(global core macro module-ref)) (begin (if (if (not (module-local-variable (current-module) - n536)) + n2898)) (current-module) #f) (module-define! (current-module) - n536 + n2898 #f)) - (let ((x538 (build-global-definition89 - s505 - n536 - (chi150 - e503 - r489 - w504 - mod506)))) + (let ((x2900 (build-global-definition2451 + s2867 + n2898 + (chi2512 + e2865 + r2851 + w2866 + mod2868)))) (begin - (if (eq? m491 (quote c&e)) - (top-level-eval-hook76 x538 mod506)) - x538))) - (if (memv type537 + (if (eq? m2853 (quote c&e)) + (top-level-eval-hook2437 + x2900 + mod2868)) + x2900))) + (if (memv type2899 '(displaced-lexical)) (syntax-violation #f "identifier out of context" - e503 - (wrap142 value502 w504 mod506)) + e2865 + (wrap2504 value2864 w2866 mod2868)) (syntax-violation #f "cannot define keyword at top level" - e503 - (wrap142 value502 w504 mod506)))))) - (let ((x539 (chi-expr151 - type501 - value502 - e503 - r489 - w504 - s505 - mod506))) + e2865 + (wrap2504 value2864 w2866 mod2868)))))) + (let ((x2901 (chi-expr2513 + type2863 + value2864 + e2865 + r2851 + w2866 + s2867 + mod2868))) (begin - (if (eq? m491 (quote c&e)) - (top-level-eval-hook76 x539 mod506)) - x539))))))))))) - (syntax-type148 - (lambda (e540 r541 w542 s543 rib544 mod545 for-car?546) - (if (symbol? e540) - (let ((n547 (id-var-name136 e540 w542))) - (let ((b548 (lookup111 n547 r541 mod545))) - (let ((type549 (binding-type106 b548))) - (if (memv type549 (quote (lexical))) + (if (eq? m2853 (quote c&e)) + (top-level-eval-hook2437 x2901 mod2868)) + x2901))))))))))) + (syntax-type2510 + (lambda (e2902 + r2903 + w2904 + s2905 + rib2906 + mod2907 + for-car?2908) + (if (symbol? e2902) + (let ((n2909 (id-var-name2498 e2902 w2904))) + (let ((b2910 (lookup2473 n2909 r2903 mod2907))) + (let ((type2911 (binding-type2468 b2910))) + (if (memv type2911 (quote (lexical))) (values - type549 - (binding-value107 b548) - e540 - w542 - s543 - mod545) - (if (memv type549 (quote (global))) - (values type549 n547 e540 w542 s543 mod545) - (if (memv type549 (quote (macro))) - (if for-car?546 + type2911 + (binding-value2469 b2910) + e2902 + w2904 + s2905 + mod2907) + (if (memv type2911 (quote (global))) + (values type2911 n2909 e2902 w2904 s2905 mod2907) + (if (memv type2911 (quote (macro))) + (if for-car?2908 (values - type549 - (binding-value107 b548) - e540 - w542 - s543 - mod545) - (syntax-type148 - (chi-macro153 - (binding-value107 b548) - e540 - r541 - w542 - rib544 - mod545) - r541 + type2911 + (binding-value2469 b2910) + e2902 + w2904 + s2905 + mod2907) + (syntax-type2510 + (chi-macro2515 + (binding-value2469 b2910) + e2902 + r2903 + w2904 + rib2906 + mod2907) + r2903 '(()) - s543 - rib544 - mod545 + s2905 + rib2906 + mod2907 #f)) (values - type549 - (binding-value107 b548) - e540 - w542 - s543 - mod545))))))) - (if (pair? e540) - (let ((first550 (car e540))) + type2911 + (binding-value2469 b2910) + e2902 + w2904 + s2905 + mod2907))))))) + (if (pair? e2902) + (let ((first2912 (car e2902))) (call-with-values (lambda () - (syntax-type148 - first550 - r541 - w542 - s543 - rib544 - mod545 + (syntax-type2510 + first2912 + r2903 + w2904 + s2905 + rib2906 + mod2907 #t)) - (lambda (ftype551 fval552 fe553 fw554 fs555 fmod556) - (if (memv ftype551 (quote (lexical))) + (lambda (ftype2913 + fval2914 + fe2915 + fw2916 + fs2917 + fmod2918) + (if (memv ftype2913 (quote (lexical))) (values 'lexical-call - fval552 - e540 - w542 - s543 - mod545) - (if (memv ftype551 (quote (global))) + fval2914 + e2902 + w2904 + s2905 + mod2907) + (if (memv ftype2913 (quote (global))) (values 'global-call - (make-syntax-object97 fval552 w542 fmod556) - e540 - w542 - s543 - mod545) - (if (memv ftype551 (quote (macro))) - (syntax-type148 - (chi-macro153 - fval552 - e540 - r541 - w542 - rib544 - mod545) - r541 + (make-syntax-object2459 fval2914 w2904 fmod2918) + e2902 + w2904 + s2905 + mod2907) + (if (memv ftype2913 (quote (macro))) + (syntax-type2510 + (chi-macro2515 + fval2914 + e2902 + r2903 + w2904 + rib2906 + mod2907) + r2903 '(()) - s543 - rib544 - mod545 - for-car?546) - (if (memv ftype551 (quote (module-ref))) + s2905 + rib2906 + mod2907 + for-car?2908) + (if (memv ftype2913 (quote (module-ref))) (call-with-values - (lambda () (fval552 e540)) - (lambda (sym557 mod558) - (syntax-type148 - sym557 - r541 - w542 - s543 - rib544 - mod558 - for-car?546))) - (if (memv ftype551 (quote (core))) + (lambda () (fval2914 e2902)) + (lambda (sym2919 mod2920) + (syntax-type2510 + sym2919 + r2903 + w2904 + s2905 + rib2906 + mod2920 + for-car?2908))) + (if (memv ftype2913 (quote (core))) (values 'core-form - fval552 - e540 - w542 - s543 - mod545) - (if (memv ftype551 (quote (local-syntax))) + fval2914 + e2902 + w2904 + s2905 + mod2907) + (if (memv ftype2913 (quote (local-syntax))) (values 'local-syntax-form - fval552 - e540 - w542 - s543 - mod545) - (if (memv ftype551 (quote (begin))) + fval2914 + e2902 + w2904 + s2905 + mod2907) + (if (memv ftype2913 (quote (begin))) (values 'begin-form #f - e540 - w542 - s543 - mod545) - (if (memv ftype551 (quote (eval-when))) + e2902 + w2904 + s2905 + mod2907) + (if (memv ftype2913 (quote (eval-when))) (values 'eval-when-form #f - e540 - w542 - s543 - mod545) - (if (memv ftype551 (quote (define))) - ((lambda (tmp559) - ((lambda (tmp560) - (if (if tmp560 - (apply (lambda (_561 - name562 - val563) - (id?114 - name562)) - tmp560) + e2902 + w2904 + s2905 + mod2907) + (if (memv ftype2913 (quote (define))) + ((lambda (tmp2921) + ((lambda (tmp2922) + (if (if tmp2922 + (apply (lambda (_2923 + name2924 + val2925) + (id?2476 + name2924)) + tmp2922) #f) - (apply (lambda (_564 - name565 - val566) + (apply (lambda (_2926 + name2927 + val2928) (values 'define-form - name565 - val566 - w542 - s543 - mod545)) - tmp560) - ((lambda (tmp567) - (if (if tmp567 - (apply (lambda (_568 - name569 - args570 - e1571 - e2572) - (if (id?114 - name569) - (valid-bound-ids?139 - (lambda-var-list162 - args570)) + name2927 + val2928 + w2904 + s2905 + mod2907)) + tmp2922) + ((lambda (tmp2929) + (if (if tmp2929 + (apply (lambda (_2930 + name2931 + args2932 + e12933 + e22934) + (if (id?2476 + name2931) + (valid-bound-ids?2501 + (lambda-var-list2524 + args2932)) #f)) - tmp567) + tmp2929) #f) - (apply (lambda (_573 - name574 - args575 - e1576 - e2577) + (apply (lambda (_2935 + name2936 + args2937 + e12938 + e22939) (values 'define-form - (wrap142 - name574 - w542 - mod545) + (wrap2504 + name2936 + w2904 + mod2907) (cons '#(syntax-object lambda ((top) @@ -1742,6 +1796,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -1863,6 +1918,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -1974,6 +2030,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -1984,32 +2041,32 @@ "i"))) (hygiene guile)) - (wrap142 - (cons args575 - (cons e1576 - e2577)) - w542 - mod545)) + (wrap2504 + (cons args2937 + (cons e12938 + e22939)) + w2904 + mod2907)) '(()) - s543 - mod545)) - tmp567) - ((lambda (tmp579) - (if (if tmp579 - (apply (lambda (_580 - name581) - (id?114 - name581)) - tmp579) + s2905 + mod2907)) + tmp2929) + ((lambda (tmp2941) + (if (if tmp2941 + (apply (lambda (_2942 + name2943) + (id?2476 + name2943)) + tmp2941) #f) - (apply (lambda (_582 - name583) + (apply (lambda (_2944 + name2945) (values 'define-form - (wrap142 - name583 - w542 - mod545) + (wrap2504 + name2945 + w2904 + mod2907) '(#(syntax-object if ((top) @@ -2190,6 +2247,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -2311,6 +2369,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -2422,6 +2481,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -2612,6 +2672,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -2733,6 +2794,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -2844,6 +2906,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -3034,6 +3097,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -3155,6 +3219,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -3266,6 +3331,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -3277,463 +3343,102 @@ (hygiene guile))) '(()) - s543 - mod545)) - tmp579) + s2905 + mod2907)) + tmp2941) (syntax-violation #f "source expression failed to match any pattern" - tmp559))) + tmp2921))) ($sc-dispatch - tmp559 + tmp2921 '(any any))))) ($sc-dispatch - tmp559 + tmp2921 '(any (any . any) any . each-any))))) ($sc-dispatch - tmp559 + tmp2921 '(any any any)))) - e540) - (if (memv ftype551 + e2902) + (if (memv ftype2913 '(define-syntax)) - ((lambda (tmp584) - ((lambda (tmp585) - (if (if tmp585 - (apply (lambda (_586 - name587 - val588) - (id?114 - name587)) - tmp585) + ((lambda (tmp2946) + ((lambda (tmp2947) + (if (if tmp2947 + (apply (lambda (_2948 + name2949 + val2950) + (id?2476 + name2949)) + tmp2947) #f) - (apply (lambda (_589 - name590 - val591) + (apply (lambda (_2951 + name2952 + val2953) (values 'define-syntax-form - name590 - val591 - w542 - s543 - mod545)) - tmp585) + name2952 + val2953 + w2904 + s2905 + mod2907)) + tmp2947) (syntax-violation #f "source expression failed to match any pattern" - tmp584))) + tmp2946))) ($sc-dispatch - tmp584 + tmp2946 '(any any any)))) - e540) + e2902) (values 'call #f - e540 - w542 - s543 - mod545)))))))))))))) - (if (syntax-object?98 e540) - (syntax-type148 - (syntax-object-expression99 e540) - r541 - (join-wraps133 w542 (syntax-object-wrap100 e540)) - s543 - rib544 - (let ((t592 (syntax-object-module101 e540))) - (if t592 t592 mod545)) - for-car?546) - (if (self-evaluating? e540) + e2902 + w2904 + s2905 + mod2907)))))))))))))) + (if (syntax-object?2460 e2902) + (syntax-type2510 + (syntax-object-expression2461 e2902) + r2903 + (join-wraps2495 + w2904 + (syntax-object-wrap2462 e2902)) + s2905 + rib2906 + (let ((t2954 (syntax-object-module2463 e2902))) + (if t2954 t2954 mod2907)) + for-car?2908) + (if (self-evaluating? e2902) (values 'constant #f - e540 - w542 - s543 - mod545) - (values (quote other) #f e540 w542 s543 mod545))))))) - (chi-when-list147 - (lambda (e593 when-list594 w595) - (letrec ((f596 (lambda (when-list597 situations598) - (if (null? when-list597) - situations598 - (f596 (cdr when-list597) - (cons (let ((x599 (car when-list597))) - (if (free-id=?137 - x599 - '#(syntax-object - compile - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage - #(f - when-list - situations) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(e when-list w) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - maybe-name-value! - build-global-assignment - build-global-reference - analyze-variable - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-void - get-global-definition-hook - put-global-definition-hook - gensym-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - *mode* - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure - and-map*) - ((top) (top)) - ("i" "i"))) - (hygiene guile))) - 'compile - (if (free-id=?137 - x599 + e2902 + w2904 + s2905 + mod2907) + (values + 'other + #f + e2902 + w2904 + s2905 + mod2907))))))) + (chi-when-list2509 + (lambda (e2955 when-list2956 w2957) + (letrec ((f2958 (lambda (when-list2959 situations2960) + (if (null? when-list2959) + situations2960 + (f2958 (cdr when-list2959) + (cons (let ((x2961 (car when-list2959))) + (if (free-id=?2499 + x2961 '#(syntax-object - load + compile ((top) #(ribcage () () ()) #(ribcage () () ()) @@ -3859,6 +3564,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -3980,6 +3686,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -4091,6 +3798,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -4098,11 +3806,11 @@ ((top) (top)) ("i" "i"))) (hygiene guile))) - 'load - (if (free-id=?137 - x599 + 'compile + (if (free-id=?2499 + x2961 '#(syntax-object - eval + load ((top) #(ribcage () @@ -4245,6 +3953,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -4366,6 +4075,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -4477,6 +4187,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -4484,1570 +4195,2077 @@ ((top) (top)) ("i" "i"))) (hygiene guile))) - 'eval - (syntax-violation - 'eval-when - "invalid situation" - e593 - (wrap142 - x599 - w595 - #f)))))) - situations598)))))) - (f596 when-list594 (quote ()))))) - (chi-install-global146 - (lambda (name600 e601) - (build-global-definition89 + 'load + (if (free-id=?2499 + x2961 + '#(syntax-object + eval + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + when-list + situations) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(e + when-list + w) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + decorate-source + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene + guile))) + 'eval + (syntax-violation + 'eval-when + "invalid situation" + e2955 + (wrap2504 + x2961 + w2957 + #f)))))) + situations2960)))))) + (f2958 when-list2956 (quote ()))))) + (chi-install-global2508 + (lambda (name2962 e2963) + (build-global-definition2451 #f - name600 - (if (let ((v602 (module-variable (current-module) name600))) - (if v602 - (if (variable-bound? v602) - (if (macro? (variable-ref v602)) - (not (eq? (macro-type (variable-ref v602)) + name2962 + (if (let ((v2964 (module-variable (current-module) name2962))) + (if v2964 + (if (variable-bound? v2964) + (if (macro? (variable-ref v2964)) + (not (eq? (macro-type (variable-ref v2964)) 'syncase-macro)) #f) #f) #f)) - (build-application81 + (build-application2443 #f - (build-primref91 + (build-primref2453 #f 'make-extended-syncase-macro) - (list (build-application81 + (list (build-application2443 #f - (build-primref91 #f (quote module-ref)) - (list (build-application81 + (build-primref2453 #f (quote module-ref)) + (list (build-application2443 #f - (build-primref91 + (build-primref2453 #f 'current-module) '()) - (build-data92 #f name600))) - (build-data92 #f (quote macro)) - e601)) - (build-application81 + (build-data2454 #f name2962))) + (build-data2454 #f (quote macro)) + e2963)) + (build-application2443 #f - (build-primref91 #f (quote make-syncase-macro)) - (list (build-data92 #f (quote macro)) e601)))))) - (chi-top-sequence145 - (lambda (body603 r604 w605 s606 m607 esew608 mod609) - (build-sequence93 - s606 - (letrec ((dobody610 - (lambda (body611 r612 w613 m614 esew615 mod616) - (if (null? body611) + (build-primref2453 #f (quote make-syncase-macro)) + (list (build-data2454 #f (quote macro)) e2963)))))) + (chi-top-sequence2507 + (lambda (body2965 + r2966 + w2967 + s2968 + m2969 + esew2970 + mod2971) + (build-sequence2455 + s2968 + (letrec ((dobody2972 + (lambda (body2973 + r2974 + w2975 + m2976 + esew2977 + mod2978) + (if (null? body2973) '() - (let ((first617 - (chi-top149 - (car body611) - r612 - w613 - m614 - esew615 - mod616))) - (cons first617 - (dobody610 - (cdr body611) - r612 - w613 - m614 - esew615 - mod616))))))) - (dobody610 body603 r604 w605 m607 esew608 mod609))))) - (chi-sequence144 - (lambda (body618 r619 w620 s621 mod622) - (build-sequence93 - s621 - (letrec ((dobody623 - (lambda (body624 r625 w626 mod627) - (if (null? body624) + (let ((first2979 + (chi-top2511 + (car body2973) + r2974 + w2975 + m2976 + esew2977 + mod2978))) + (cons first2979 + (dobody2972 + (cdr body2973) + r2974 + w2975 + m2976 + esew2977 + mod2978))))))) + (dobody2972 + body2965 + r2966 + w2967 + m2969 + esew2970 + mod2971))))) + (chi-sequence2506 + (lambda (body2980 r2981 w2982 s2983 mod2984) + (build-sequence2455 + s2983 + (letrec ((dobody2985 + (lambda (body2986 r2987 w2988 mod2989) + (if (null? body2986) '() - (let ((first628 - (chi150 - (car body624) - r625 - w626 - mod627))) - (cons first628 - (dobody623 - (cdr body624) - r625 - w626 - mod627))))))) - (dobody623 body618 r619 w620 mod622))))) - (source-wrap143 - (lambda (x629 w630 s631 defmod632) + (let ((first2990 + (chi2512 + (car body2986) + r2987 + w2988 + mod2989))) + (cons first2990 + (dobody2985 + (cdr body2986) + r2987 + w2988 + mod2989))))))) + (dobody2985 body2980 r2981 w2982 mod2984))))) + (source-wrap2505 + (lambda (x2991 w2992 s2993 defmod2994) (begin - (if (if s631 (pair? x629) #f) - (set-source-properties! x629 s631)) - (wrap142 x629 w630 defmod632)))) - (wrap142 - (lambda (x633 w634 defmod635) - (if (if (null? (wrap-marks117 w634)) - (null? (wrap-subst118 w634)) + (if (if s2993 (pair? x2991) #f) + (set-source-properties! x2991 s2993)) + (wrap2504 x2991 w2992 defmod2994)))) + (wrap2504 + (lambda (x2995 w2996 defmod2997) + (if (if (null? (wrap-marks2479 w2996)) + (null? (wrap-subst2480 w2996)) #f) - x633 - (if (syntax-object?98 x633) - (make-syntax-object97 - (syntax-object-expression99 x633) - (join-wraps133 w634 (syntax-object-wrap100 x633)) - (syntax-object-module101 x633)) - (if (null? x633) - x633 - (make-syntax-object97 x633 w634 defmod635)))))) - (bound-id-member?141 - (lambda (x636 list637) - (if (not (null? list637)) - (let ((t638 (bound-id=?138 x636 (car list637)))) - (if t638 - t638 - (bound-id-member?141 x636 (cdr list637)))) + x2995 + (if (syntax-object?2460 x2995) + (make-syntax-object2459 + (syntax-object-expression2461 x2995) + (join-wraps2495 + w2996 + (syntax-object-wrap2462 x2995)) + (syntax-object-module2463 x2995)) + (if (null? x2995) + x2995 + (make-syntax-object2459 x2995 w2996 defmod2997)))))) + (bound-id-member?2503 + (lambda (x2998 list2999) + (if (not (null? list2999)) + (let ((t3000 (bound-id=?2500 x2998 (car list2999)))) + (if t3000 + t3000 + (bound-id-member?2503 x2998 (cdr list2999)))) #f))) - (distinct-bound-ids?140 - (lambda (ids639) - (letrec ((distinct?640 - (lambda (ids641) - (let ((t642 (null? ids641))) - (if t642 - t642 - (if (not (bound-id-member?141 - (car ids641) - (cdr ids641))) - (distinct?640 (cdr ids641)) + (distinct-bound-ids?2502 + (lambda (ids3001) + (letrec ((distinct?3002 + (lambda (ids3003) + (let ((t3004 (null? ids3003))) + (if t3004 + t3004 + (if (not (bound-id-member?2503 + (car ids3003) + (cdr ids3003))) + (distinct?3002 (cdr ids3003)) #f)))))) - (distinct?640 ids639)))) - (valid-bound-ids?139 - (lambda (ids643) - (if (letrec ((all-ids?644 - (lambda (ids645) - (let ((t646 (null? ids645))) - (if t646 - t646 - (if (id?114 (car ids645)) - (all-ids?644 (cdr ids645)) + (distinct?3002 ids3001)))) + (valid-bound-ids?2501 + (lambda (ids3005) + (if (letrec ((all-ids?3006 + (lambda (ids3007) + (let ((t3008 (null? ids3007))) + (if t3008 + t3008 + (if (id?2476 (car ids3007)) + (all-ids?3006 (cdr ids3007)) #f)))))) - (all-ids?644 ids643)) - (distinct-bound-ids?140 ids643) + (all-ids?3006 ids3005)) + (distinct-bound-ids?2502 ids3005) #f))) - (bound-id=?138 - (lambda (i647 j648) - (if (if (syntax-object?98 i647) - (syntax-object?98 j648) + (bound-id=?2500 + (lambda (i3009 j3010) + (if (if (syntax-object?2460 i3009) + (syntax-object?2460 j3010) #f) - (if (eq? (syntax-object-expression99 i647) - (syntax-object-expression99 j648)) - (same-marks?135 - (wrap-marks117 (syntax-object-wrap100 i647)) - (wrap-marks117 (syntax-object-wrap100 j648))) + (if (eq? (syntax-object-expression2461 i3009) + (syntax-object-expression2461 j3010)) + (same-marks?2497 + (wrap-marks2479 (syntax-object-wrap2462 i3009)) + (wrap-marks2479 (syntax-object-wrap2462 j3010))) #f) - (eq? i647 j648)))) - (free-id=?137 - (lambda (i649 j650) - (if (eq? (let ((x651 i649)) - (if (syntax-object?98 x651) - (syntax-object-expression99 x651) - x651)) - (let ((x652 j650)) - (if (syntax-object?98 x652) - (syntax-object-expression99 x652) - x652))) - (eq? (id-var-name136 i649 (quote (()))) - (id-var-name136 j650 (quote (())))) + (eq? i3009 j3010)))) + (free-id=?2499 + (lambda (i3011 j3012) + (if (eq? (let ((x3013 i3011)) + (if (syntax-object?2460 x3013) + (syntax-object-expression2461 x3013) + x3013)) + (let ((x3014 j3012)) + (if (syntax-object?2460 x3014) + (syntax-object-expression2461 x3014) + x3014))) + (eq? (id-var-name2498 i3011 (quote (()))) + (id-var-name2498 j3012 (quote (())))) #f))) - (id-var-name136 - (lambda (id653 w654) - (letrec ((search-vector-rib657 - (lambda (sym663 - subst664 - marks665 - symnames666 - ribcage667) - (let ((n668 (vector-length symnames666))) - (letrec ((f669 (lambda (i670) - (if (fx=74 i670 n668) - (search655 - sym663 - (cdr subst664) - marks665) - (if (if (eq? (vector-ref - symnames666 - i670) - sym663) - (same-marks?135 - marks665 - (vector-ref - (ribcage-marks124 - ribcage667) - i670)) - #f) - (values - (vector-ref - (ribcage-labels125 - ribcage667) - i670) - marks665) - (f669 (fx+72 i670 1))))))) - (f669 0))))) - (search-list-rib656 - (lambda (sym671 - subst672 - marks673 - symnames674 - ribcage675) - (letrec ((f676 (lambda (symnames677 i678) - (if (null? symnames677) - (search655 - sym671 - (cdr subst672) - marks673) - (if (if (eq? (car symnames677) - sym671) - (same-marks?135 - marks673 - (list-ref - (ribcage-marks124 - ribcage675) - i678)) - #f) - (values - (list-ref - (ribcage-labels125 - ribcage675) - i678) - marks673) - (f676 (cdr symnames677) - (fx+72 i678 1))))))) - (f676 symnames674 0)))) - (search655 - (lambda (sym679 subst680 marks681) - (if (null? subst680) - (values #f marks681) - (let ((fst682 (car subst680))) - (if (eq? fst682 (quote shift)) - (search655 - sym679 - (cdr subst680) - (cdr marks681)) - (let ((symnames683 - (ribcage-symnames123 fst682))) - (if (vector? symnames683) - (search-vector-rib657 - sym679 - subst680 - marks681 - symnames683 - fst682) - (search-list-rib656 - sym679 - subst680 - marks681 - symnames683 - fst682))))))))) - (if (symbol? id653) - (let ((t684 (call-with-values - (lambda () - (search655 - id653 - (wrap-subst118 w654) - (wrap-marks117 w654))) - (lambda (x686 . ignore685) x686)))) - (if t684 t684 id653)) - (if (syntax-object?98 id653) - (let ((id687 (syntax-object-expression99 id653)) - (w1688 (syntax-object-wrap100 id653))) - (let ((marks689 - (join-marks134 - (wrap-marks117 w654) - (wrap-marks117 w1688)))) + (id-var-name2498 + (lambda (id3015 w3016) + (letrec ((search-vector-rib3019 + (lambda (sym3025 + subst3026 + marks3027 + symnames3028 + ribcage3029) + (let ((n3030 (vector-length symnames3028))) + (letrec ((f3031 (lambda (i3032) + (if (fx=2435 i3032 n3030) + (search3017 + sym3025 + (cdr subst3026) + marks3027) + (if (if (eq? (vector-ref + symnames3028 + i3032) + sym3025) + (same-marks?2497 + marks3027 + (vector-ref + (ribcage-marks2486 + ribcage3029) + i3032)) + #f) + (values + (vector-ref + (ribcage-labels2487 + ribcage3029) + i3032) + marks3027) + (f3031 (fx+2433 + i3032 + 1))))))) + (f3031 0))))) + (search-list-rib3018 + (lambda (sym3033 + subst3034 + marks3035 + symnames3036 + ribcage3037) + (letrec ((f3038 (lambda (symnames3039 i3040) + (if (null? symnames3039) + (search3017 + sym3033 + (cdr subst3034) + marks3035) + (if (if (eq? (car symnames3039) + sym3033) + (same-marks?2497 + marks3035 + (list-ref + (ribcage-marks2486 + ribcage3037) + i3040)) + #f) + (values + (list-ref + (ribcage-labels2487 + ribcage3037) + i3040) + marks3035) + (f3038 (cdr symnames3039) + (fx+2433 + i3040 + 1))))))) + (f3038 symnames3036 0)))) + (search3017 + (lambda (sym3041 subst3042 marks3043) + (if (null? subst3042) + (values #f marks3043) + (let ((fst3044 (car subst3042))) + (if (eq? fst3044 (quote shift)) + (search3017 + sym3041 + (cdr subst3042) + (cdr marks3043)) + (let ((symnames3045 + (ribcage-symnames2485 fst3044))) + (if (vector? symnames3045) + (search-vector-rib3019 + sym3041 + subst3042 + marks3043 + symnames3045 + fst3044) + (search-list-rib3018 + sym3041 + subst3042 + marks3043 + symnames3045 + fst3044))))))))) + (if (symbol? id3015) + (let ((t3046 (call-with-values + (lambda () + (search3017 + id3015 + (wrap-subst2480 w3016) + (wrap-marks2479 w3016))) + (lambda (x3048 . ignore3047) x3048)))) + (if t3046 t3046 id3015)) + (if (syntax-object?2460 id3015) + (let ((id3049 (syntax-object-expression2461 id3015)) + (w13050 (syntax-object-wrap2462 id3015))) + (let ((marks3051 + (join-marks2496 + (wrap-marks2479 w3016) + (wrap-marks2479 w13050)))) (call-with-values (lambda () - (search655 id687 (wrap-subst118 w654) marks689)) - (lambda (new-id690 marks691) - (let ((t692 new-id690)) - (if t692 - t692 - (let ((t693 (call-with-values - (lambda () - (search655 - id687 - (wrap-subst118 w1688) - marks691)) - (lambda (x695 . ignore694) - x695)))) - (if t693 t693 id687)))))))) + (search3017 + id3049 + (wrap-subst2480 w3016) + marks3051)) + (lambda (new-id3052 marks3053) + (let ((t3054 new-id3052)) + (if t3054 + t3054 + (let ((t3055 (call-with-values + (lambda () + (search3017 + id3049 + (wrap-subst2480 w13050) + marks3053)) + (lambda (x3057 . ignore3056) + x3057)))) + (if t3055 t3055 id3049)))))))) (syntax-violation 'id-var-name "invalid id" - id653)))))) - (same-marks?135 - (lambda (x696 y697) - (let ((t698 (eq? x696 y697))) - (if t698 - t698 - (if (not (null? x696)) - (if (not (null? y697)) - (if (eq? (car x696) (car y697)) - (same-marks?135 (cdr x696) (cdr y697)) + id3015)))))) + (same-marks?2497 + (lambda (x3058 y3059) + (let ((t3060 (eq? x3058 y3059))) + (if t3060 + t3060 + (if (not (null? x3058)) + (if (not (null? y3059)) + (if (eq? (car x3058) (car y3059)) + (same-marks?2497 (cdr x3058) (cdr y3059)) #f) #f) #f))))) - (join-marks134 - (lambda (m1699 m2700) - (smart-append132 m1699 m2700))) - (join-wraps133 - (lambda (w1701 w2702) - (let ((m1703 (wrap-marks117 w1701)) - (s1704 (wrap-subst118 w1701))) - (if (null? m1703) - (if (null? s1704) - w2702 - (make-wrap116 - (wrap-marks117 w2702) - (smart-append132 s1704 (wrap-subst118 w2702)))) - (make-wrap116 - (smart-append132 m1703 (wrap-marks117 w2702)) - (smart-append132 s1704 (wrap-subst118 w2702))))))) - (smart-append132 - (lambda (m1705 m2706) - (if (null? m2706) m1705 (append m1705 m2706)))) - (make-binding-wrap131 - (lambda (ids707 labels708 w709) - (if (null? ids707) - w709 - (make-wrap116 - (wrap-marks117 w709) - (cons (let ((labelvec710 (list->vector labels708))) - (let ((n711 (vector-length labelvec710))) - (let ((symnamevec712 (make-vector n711)) - (marksvec713 (make-vector n711))) + (join-marks2496 + (lambda (m13061 m23062) + (smart-append2494 m13061 m23062))) + (join-wraps2495 + (lambda (w13063 w23064) + (let ((m13065 (wrap-marks2479 w13063)) + (s13066 (wrap-subst2480 w13063))) + (if (null? m13065) + (if (null? s13066) + w23064 + (make-wrap2478 + (wrap-marks2479 w23064) + (smart-append2494 s13066 (wrap-subst2480 w23064)))) + (make-wrap2478 + (smart-append2494 m13065 (wrap-marks2479 w23064)) + (smart-append2494 s13066 (wrap-subst2480 w23064))))))) + (smart-append2494 + (lambda (m13067 m23068) + (if (null? m23068) m13067 (append m13067 m23068)))) + (make-binding-wrap2493 + (lambda (ids3069 labels3070 w3071) + (if (null? ids3069) + w3071 + (make-wrap2478 + (wrap-marks2479 w3071) + (cons (let ((labelvec3072 (list->vector labels3070))) + (let ((n3073 (vector-length labelvec3072))) + (let ((symnamevec3074 (make-vector n3073)) + (marksvec3075 (make-vector n3073))) (begin - (letrec ((f714 (lambda (ids715 i716) - (if (not (null? ids715)) - (call-with-values - (lambda () - (id-sym-name&marks115 - (car ids715) - w709)) - (lambda (symname717 - marks718) - (begin - (vector-set! - symnamevec712 - i716 - symname717) - (vector-set! - marksvec713 - i716 - marks718) - (f714 (cdr ids715) - (fx+72 i716 - 1))))))))) - (f714 ids707 0)) - (make-ribcage121 - symnamevec712 - marksvec713 - labelvec710))))) - (wrap-subst118 w709)))))) - (extend-ribcage!130 - (lambda (ribcage719 id720 label721) + (letrec ((f3076 (lambda (ids3077 i3078) + (if (not (null? ids3077)) + (call-with-values + (lambda () + (id-sym-name&marks2477 + (car ids3077) + w3071)) + (lambda (symname3079 + marks3080) + (begin + (vector-set! + symnamevec3074 + i3078 + symname3079) + (vector-set! + marksvec3075 + i3078 + marks3080) + (f3076 (cdr ids3077) + (fx+2433 + i3078 + 1))))))))) + (f3076 ids3069 0)) + (make-ribcage2483 + symnamevec3074 + marksvec3075 + labelvec3072))))) + (wrap-subst2480 w3071)))))) + (extend-ribcage!2492 + (lambda (ribcage3081 id3082 label3083) (begin - (set-ribcage-symnames!126 - ribcage719 - (cons (syntax-object-expression99 id720) - (ribcage-symnames123 ribcage719))) - (set-ribcage-marks!127 - ribcage719 - (cons (wrap-marks117 (syntax-object-wrap100 id720)) - (ribcage-marks124 ribcage719))) - (set-ribcage-labels!128 - ribcage719 - (cons label721 (ribcage-labels125 ribcage719)))))) - (anti-mark129 - (lambda (w722) - (make-wrap116 - (cons #f (wrap-marks117 w722)) - (cons (quote shift) (wrap-subst118 w722))))) - (set-ribcage-labels!128 - (lambda (x723 update724) - (vector-set! x723 3 update724))) - (set-ribcage-marks!127 - (lambda (x725 update726) - (vector-set! x725 2 update726))) - (set-ribcage-symnames!126 - (lambda (x727 update728) - (vector-set! x727 1 update728))) - (ribcage-labels125 - (lambda (x729) (vector-ref x729 3))) - (ribcage-marks124 - (lambda (x730) (vector-ref x730 2))) - (ribcage-symnames123 - (lambda (x731) (vector-ref x731 1))) - (ribcage?122 - (lambda (x732) - (if (vector? x732) - (if (= (vector-length x732) 4) - (eq? (vector-ref x732 0) (quote ribcage)) + (set-ribcage-symnames!2488 + ribcage3081 + (cons (syntax-object-expression2461 id3082) + (ribcage-symnames2485 ribcage3081))) + (set-ribcage-marks!2489 + ribcage3081 + (cons (wrap-marks2479 (syntax-object-wrap2462 id3082)) + (ribcage-marks2486 ribcage3081))) + (set-ribcage-labels!2490 + ribcage3081 + (cons label3083 (ribcage-labels2487 ribcage3081)))))) + (anti-mark2491 + (lambda (w3084) + (make-wrap2478 + (cons #f (wrap-marks2479 w3084)) + (cons (quote shift) (wrap-subst2480 w3084))))) + (set-ribcage-labels!2490 + (lambda (x3085 update3086) + (vector-set! x3085 3 update3086))) + (set-ribcage-marks!2489 + (lambda (x3087 update3088) + (vector-set! x3087 2 update3088))) + (set-ribcage-symnames!2488 + (lambda (x3089 update3090) + (vector-set! x3089 1 update3090))) + (ribcage-labels2487 + (lambda (x3091) (vector-ref x3091 3))) + (ribcage-marks2486 + (lambda (x3092) (vector-ref x3092 2))) + (ribcage-symnames2485 + (lambda (x3093) (vector-ref x3093 1))) + (ribcage?2484 + (lambda (x3094) + (if (vector? x3094) + (if (= (vector-length x3094) 4) + (eq? (vector-ref x3094 0) (quote ribcage)) #f) #f))) - (make-ribcage121 - (lambda (symnames733 marks734 labels735) + (make-ribcage2483 + (lambda (symnames3095 marks3096 labels3097) (vector 'ribcage - symnames733 - marks734 - labels735))) - (gen-labels120 - (lambda (ls736) - (if (null? ls736) + symnames3095 + marks3096 + labels3097))) + (gen-labels2482 + (lambda (ls3098) + (if (null? ls3098) '() - (cons (gen-label119) (gen-labels120 (cdr ls736)))))) - (gen-label119 (lambda () (string #\i))) - (wrap-subst118 cdr) - (wrap-marks117 car) - (make-wrap116 cons) - (id-sym-name&marks115 - (lambda (x737 w738) - (if (syntax-object?98 x737) + (cons (gen-label2481) + (gen-labels2482 (cdr ls3098)))))) + (gen-label2481 (lambda () (string #\i))) + (wrap-subst2480 cdr) + (wrap-marks2479 car) + (make-wrap2478 cons) + (id-sym-name&marks2477 + (lambda (x3099 w3100) + (if (syntax-object?2460 x3099) (values - (syntax-object-expression99 x737) - (join-marks134 - (wrap-marks117 w738) - (wrap-marks117 (syntax-object-wrap100 x737)))) - (values x737 (wrap-marks117 w738))))) - (id?114 - (lambda (x739) - (if (symbol? x739) + (syntax-object-expression2461 x3099) + (join-marks2496 + (wrap-marks2479 w3100) + (wrap-marks2479 (syntax-object-wrap2462 x3099)))) + (values x3099 (wrap-marks2479 w3100))))) + (id?2476 + (lambda (x3101) + (if (symbol? x3101) #t - (if (syntax-object?98 x739) - (symbol? (syntax-object-expression99 x739)) + (if (syntax-object?2460 x3101) + (symbol? (syntax-object-expression2461 x3101)) #f)))) - (nonsymbol-id?113 - (lambda (x740) - (if (syntax-object?98 x740) - (symbol? (syntax-object-expression99 x740)) + (nonsymbol-id?2475 + (lambda (x3102) + (if (syntax-object?2460 x3102) + (symbol? (syntax-object-expression2461 x3102)) #f))) - (global-extend112 - (lambda (type741 sym742 val743) - (put-global-definition-hook78 - sym742 - type741 - val743))) - (lookup111 - (lambda (x744 r745 mod746) - (let ((t747 (assq x744 r745))) - (if t747 - (cdr t747) - (if (symbol? x744) - (let ((t748 (get-global-definition-hook79 x744 mod746))) - (if t748 t748 (quote (global)))) + (global-extend2474 + (lambda (type3103 sym3104 val3105) + (put-global-definition-hook2439 + sym3104 + type3103 + val3105))) + (lookup2473 + (lambda (x3106 r3107 mod3108) + (let ((t3109 (assq x3106 r3107))) + (if t3109 + (cdr t3109) + (if (symbol? x3106) + (let ((t3110 (get-global-definition-hook2440 + x3106 + mod3108))) + (if t3110 t3110 (quote (global)))) '(displaced-lexical)))))) - (macros-only-env110 - (lambda (r749) - (if (null? r749) + (macros-only-env2472 + (lambda (r3111) + (if (null? r3111) '() - (let ((a750 (car r749))) - (if (eq? (cadr a750) (quote macro)) - (cons a750 (macros-only-env110 (cdr r749))) - (macros-only-env110 (cdr r749))))))) - (extend-var-env109 - (lambda (labels751 vars752 r753) - (if (null? labels751) - r753 - (extend-var-env109 - (cdr labels751) - (cdr vars752) - (cons (cons (car labels751) - (cons (quote lexical) (car vars752))) - r753))))) - (extend-env108 - (lambda (labels754 bindings755 r756) - (if (null? labels754) - r756 - (extend-env108 - (cdr labels754) - (cdr bindings755) - (cons (cons (car labels754) (car bindings755)) - r756))))) - (binding-value107 cdr) - (binding-type106 car) - (source-annotation105 - (lambda (x757) - (if (syntax-object?98 x757) - (source-annotation105 - (syntax-object-expression99 x757)) - (if (pair? x757) - (let ((props758 (source-properties x757))) - (if (pair? props758) props758 #f)) + (let ((a3112 (car r3111))) + (if (eq? (cadr a3112) (quote macro)) + (cons a3112 (macros-only-env2472 (cdr r3111))) + (macros-only-env2472 (cdr r3111))))))) + (extend-var-env2471 + (lambda (labels3113 vars3114 r3115) + (if (null? labels3113) + r3115 + (extend-var-env2471 + (cdr labels3113) + (cdr vars3114) + (cons (cons (car labels3113) + (cons (quote lexical) (car vars3114))) + r3115))))) + (extend-env2470 + (lambda (labels3116 bindings3117 r3118) + (if (null? labels3116) + r3118 + (extend-env2470 + (cdr labels3116) + (cdr bindings3117) + (cons (cons (car labels3116) (car bindings3117)) + r3118))))) + (binding-value2469 cdr) + (binding-type2468 car) + (source-annotation2467 + (lambda (x3119) + (if (syntax-object?2460 x3119) + (source-annotation2467 + (syntax-object-expression2461 x3119)) + (if (pair? x3119) + (let ((props3120 (source-properties x3119))) + (if (pair? props3120) props3120 #f)) #f)))) - (set-syntax-object-module!104 - (lambda (x759 update760) - (vector-set! x759 3 update760))) - (set-syntax-object-wrap!103 - (lambda (x761 update762) - (vector-set! x761 2 update762))) - (set-syntax-object-expression!102 - (lambda (x763 update764) - (vector-set! x763 1 update764))) - (syntax-object-module101 - (lambda (x765) (vector-ref x765 3))) - (syntax-object-wrap100 - (lambda (x766) (vector-ref x766 2))) - (syntax-object-expression99 - (lambda (x767) (vector-ref x767 1))) - (syntax-object?98 - (lambda (x768) - (if (vector? x768) - (if (= (vector-length x768) 4) - (eq? (vector-ref x768 0) (quote syntax-object)) + (set-syntax-object-module!2466 + (lambda (x3121 update3122) + (vector-set! x3121 3 update3122))) + (set-syntax-object-wrap!2465 + (lambda (x3123 update3124) + (vector-set! x3123 2 update3124))) + (set-syntax-object-expression!2464 + (lambda (x3125 update3126) + (vector-set! x3125 1 update3126))) + (syntax-object-module2463 + (lambda (x3127) (vector-ref x3127 3))) + (syntax-object-wrap2462 + (lambda (x3128) (vector-ref x3128 2))) + (syntax-object-expression2461 + (lambda (x3129) (vector-ref x3129 1))) + (syntax-object?2460 + (lambda (x3130) + (if (vector? x3130) + (if (= (vector-length x3130) 4) + (eq? (vector-ref x3130 0) (quote syntax-object)) #f) #f))) - (make-syntax-object97 - (lambda (expression769 wrap770 module771) + (make-syntax-object2459 + (lambda (expression3131 wrap3132 module3133) (vector 'syntax-object - expression769 - wrap770 - module771))) - (build-letrec96 - (lambda (src772 ids773 vars774 val-exps775 body-exp776) - (if (null? vars774) - body-exp776 - (let ((atom-key777 (fluid-ref *mode*71))) - (if (memv atom-key777 (quote (c))) + expression3131 + wrap3132 + module3133))) + (build-letrec2458 + (lambda (src3134 + ids3135 + vars3136 + val-exps3137 + body-exp3138) + (if (null? vars3136) + body-exp3138 + (let ((atom-key3139 (fluid-ref *mode*2432))) + (if (memv atom-key3139 (quote (c))) (begin - (for-each maybe-name-value!88 ids773 val-exps775) + (for-each + maybe-name-value!2450 + ids3135 + val-exps3137) ((@ (language tree-il) make-letrec) - src772 - ids773 - vars774 - val-exps775 - body-exp776)) - (list 'letrec - (map list vars774 val-exps775) - body-exp776)))))) - (build-named-let95 - (lambda (src778 ids779 vars780 val-exps781 body-exp782) - (let ((f783 (car vars780)) - (f-name784 (car ids779)) - (vars785 (cdr vars780)) - (ids786 (cdr ids779))) - (let ((atom-key787 (fluid-ref *mode*71))) - (if (memv atom-key787 (quote (c))) - (let ((proc788 - (build-lambda90 - src778 - ids786 - vars785 + src3134 + ids3135 + vars3136 + val-exps3137 + body-exp3138)) + (decorate-source2441 + (list 'letrec + (map list vars3136 val-exps3137) + body-exp3138) + src3134)))))) + (build-named-let2457 + (lambda (src3140 + ids3141 + vars3142 + val-exps3143 + body-exp3144) + (let ((f3145 (car vars3142)) + (f-name3146 (car ids3141)) + (vars3147 (cdr vars3142)) + (ids3148 (cdr ids3141))) + (let ((atom-key3149 (fluid-ref *mode*2432))) + (if (memv atom-key3149 (quote (c))) + (let ((proc3150 + (build-lambda2452 + src3140 + ids3148 + vars3147 #f - body-exp782))) + body-exp3144))) (begin - (maybe-name-value!88 f-name784 proc788) - (for-each maybe-name-value!88 ids786 val-exps781) + (maybe-name-value!2450 f-name3146 proc3150) + (for-each + maybe-name-value!2450 + ids3148 + val-exps3143) ((@ (language tree-il) make-letrec) - src778 - (list f-name784) - (list f783) - (list proc788) - (build-application81 - src778 - (build-lexical-reference83 + src3140 + (list f-name3146) + (list f3145) + (list proc3150) + (build-application2443 + src3140 + (build-lexical-reference2445 'fun - src778 - f-name784 - f783) - val-exps781)))) - (list 'let - f783 - (map list vars785 val-exps781) - body-exp782)))))) - (build-let94 - (lambda (src789 ids790 vars791 val-exps792 body-exp793) - (if (null? vars791) - body-exp793 - (let ((atom-key794 (fluid-ref *mode*71))) - (if (memv atom-key794 (quote (c))) + src3140 + f-name3146 + f3145) + val-exps3143)))) + (decorate-source2441 + (list 'let + f3145 + (map list vars3147 val-exps3143) + body-exp3144) + src3140)))))) + (build-let2456 + (lambda (src3151 + ids3152 + vars3153 + val-exps3154 + body-exp3155) + (if (null? vars3153) + body-exp3155 + (let ((atom-key3156 (fluid-ref *mode*2432))) + (if (memv atom-key3156 (quote (c))) (begin - (for-each maybe-name-value!88 ids790 val-exps792) + (for-each + maybe-name-value!2450 + ids3152 + val-exps3154) ((@ (language tree-il) make-let) - src789 - ids790 - vars791 - val-exps792 - body-exp793)) - (list 'let - (map list vars791 val-exps792) - body-exp793)))))) - (build-sequence93 - (lambda (src795 exps796) - (if (null? (cdr exps796)) - (car exps796) - (let ((atom-key797 (fluid-ref *mode*71))) - (if (memv atom-key797 (quote (c))) + src3151 + ids3152 + vars3153 + val-exps3154 + body-exp3155)) + (decorate-source2441 + (list 'let + (map list vars3153 val-exps3154) + body-exp3155) + src3151)))))) + (build-sequence2455 + (lambda (src3157 exps3158) + (if (null? (cdr exps3158)) + (car exps3158) + (let ((atom-key3159 (fluid-ref *mode*2432))) + (if (memv atom-key3159 (quote (c))) ((@ (language tree-il) make-sequence) - src795 - exps796) - (cons (quote begin) exps796)))))) - (build-data92 - (lambda (src798 exp799) - (let ((atom-key800 (fluid-ref *mode*71))) - (if (memv atom-key800 (quote (c))) - ((@ (language tree-il) make-const) src798 exp799) - (if (if (self-evaluating? exp799) - (not (vector? exp799)) - #f) - exp799 - (list (quote quote) exp799)))))) - (build-primref91 - (lambda (src801 name802) + src3157 + exps3158) + (decorate-source2441 + (cons (quote begin) exps3158) + src3157)))))) + (build-data2454 + (lambda (src3160 exp3161) + (let ((atom-key3162 (fluid-ref *mode*2432))) + (if (memv atom-key3162 (quote (c))) + ((@ (language tree-il) make-const) + src3160 + exp3161) + (decorate-source2441 + (if (if (self-evaluating? exp3161) + (not (vector? exp3161)) + #f) + exp3161 + (list (quote quote) exp3161)) + src3160))))) + (build-primref2453 + (lambda (src3163 name3164) (if (equal? (module-name (current-module)) '(guile)) - (let ((atom-key803 (fluid-ref *mode*71))) - (if (memv atom-key803 (quote (c))) + (let ((atom-key3165 (fluid-ref *mode*2432))) + (if (memv atom-key3165 (quote (c))) ((@ (language tree-il) make-toplevel-ref) - src801 - name802) - name802)) - (let ((atom-key804 (fluid-ref *mode*71))) - (if (memv atom-key804 (quote (c))) + src3163 + name3164) + (decorate-source2441 name3164 src3163))) + (let ((atom-key3166 (fluid-ref *mode*2432))) + (if (memv atom-key3166 (quote (c))) ((@ (language tree-il) make-module-ref) - src801 + src3163 '(guile) - name802 + name3164 #f) - (list (quote @@) (quote (guile)) name802)))))) - (build-lambda90 - (lambda (src805 ids806 vars807 docstring808 exp809) - (let ((atom-key810 (fluid-ref *mode*71))) - (if (memv atom-key810 (quote (c))) + (decorate-source2441 + (list (quote @@) (quote (guile)) name3164) + src3163)))))) + (build-lambda2452 + (lambda (src3167 ids3168 vars3169 docstring3170 exp3171) + (let ((atom-key3172 (fluid-ref *mode*2432))) + (if (memv atom-key3172 (quote (c))) ((@ (language tree-il) make-lambda) - src805 - ids806 - vars807 - (if docstring808 - (list (cons (quote documentation) docstring808)) + src3167 + ids3168 + vars3169 + (if docstring3170 + (list (cons (quote documentation) docstring3170)) '()) - exp809) - (cons 'lambda - (cons vars807 - (append - (if docstring808 - (list docstring808) - '()) - (list exp809)))))))) - (build-global-definition89 - (lambda (source811 var812 exp813) - (let ((atom-key814 (fluid-ref *mode*71))) - (if (memv atom-key814 (quote (c))) + exp3171) + (decorate-source2441 + (cons 'lambda + (cons vars3169 + (append + (if docstring3170 + (list docstring3170) + '()) + (list exp3171)))) + src3167))))) + (build-global-definition2451 + (lambda (source3173 var3174 exp3175) + (let ((atom-key3176 (fluid-ref *mode*2432))) + (if (memv atom-key3176 (quote (c))) (begin - (maybe-name-value!88 var812 exp813) + (maybe-name-value!2450 var3174 exp3175) ((@ (language tree-il) make-toplevel-define) - source811 - var812 - exp813)) - (list (quote define) var812 exp813))))) - (maybe-name-value!88 - (lambda (name815 val816) - (if ((@ (language tree-il) lambda?) val816) - (let ((meta817 - ((@ (language tree-il) lambda-meta) val816))) - (if (not (assq (quote name) meta817)) + source3173 + var3174 + exp3175)) + (decorate-source2441 + (list (quote define) var3174 exp3175) + source3173))))) + (maybe-name-value!2450 + (lambda (name3177 val3178) + (if ((@ (language tree-il) lambda?) val3178) + (let ((meta3179 + ((@ (language tree-il) lambda-meta) val3178))) + (if (not (assq (quote name) meta3179)) ((setter (@ (language tree-il) lambda-meta)) - val816 - (acons (quote name) name815 meta817))))))) - (build-global-assignment87 - (lambda (source818 var819 exp820 mod821) - (analyze-variable85 - mod821 - var819 - (lambda (mod822 var823 public?824) - (let ((atom-key825 (fluid-ref *mode*71))) - (if (memv atom-key825 (quote (c))) + val3178 + (acons (quote name) name3177 meta3179))))))) + (build-global-assignment2449 + (lambda (source3180 var3181 exp3182 mod3183) + (analyze-variable2447 + mod3183 + var3181 + (lambda (mod3184 var3185 public?3186) + (let ((atom-key3187 (fluid-ref *mode*2432))) + (if (memv atom-key3187 (quote (c))) ((@ (language tree-il) make-module-set) - source818 - mod822 - var823 - public?824 - exp820) - (list 'set! - (list (if public?824 (quote @) (quote @@)) - mod822 - var823) - exp820)))) - (lambda (var826) - (let ((atom-key827 (fluid-ref *mode*71))) - (if (memv atom-key827 (quote (c))) + source3180 + mod3184 + var3185 + public?3186 + exp3182) + (decorate-source2441 + (list 'set! + (list (if public?3186 (quote @) (quote @@)) + mod3184 + var3185) + exp3182) + source3180)))) + (lambda (var3188) + (let ((atom-key3189 (fluid-ref *mode*2432))) + (if (memv atom-key3189 (quote (c))) ((@ (language tree-il) make-toplevel-set) - source818 - var826 - exp820) - (list (quote set!) var826 exp820))))))) - (build-global-reference86 - (lambda (source828 var829 mod830) - (analyze-variable85 - mod830 - var829 - (lambda (mod831 var832 public?833) - (let ((atom-key834 (fluid-ref *mode*71))) - (if (memv atom-key834 (quote (c))) + source3180 + var3188 + exp3182) + (decorate-source2441 + (list (quote set!) var3188 exp3182) + source3180))))))) + (build-global-reference2448 + (lambda (source3190 var3191 mod3192) + (analyze-variable2447 + mod3192 + var3191 + (lambda (mod3193 var3194 public?3195) + (let ((atom-key3196 (fluid-ref *mode*2432))) + (if (memv atom-key3196 (quote (c))) ((@ (language tree-il) make-module-ref) - source828 - mod831 - var832 - public?833) - (list (if public?833 (quote @) (quote @@)) - mod831 - var832)))) - (lambda (var835) - (let ((atom-key836 (fluid-ref *mode*71))) - (if (memv atom-key836 (quote (c))) + source3190 + mod3193 + var3194 + public?3195) + (decorate-source2441 + (list (if public?3195 (quote @) (quote @@)) + mod3193 + var3194) + source3190)))) + (lambda (var3197) + (let ((atom-key3198 (fluid-ref *mode*2432))) + (if (memv atom-key3198 (quote (c))) ((@ (language tree-il) make-toplevel-ref) - source828 - var835) - var835)))))) - (analyze-variable85 - (lambda (mod837 var838 modref-cont839 bare-cont840) - (if (not mod837) - (bare-cont840 var838) - (let ((kind841 (car mod837)) (mod842 (cdr mod837))) - (if (memv kind841 (quote (public))) - (modref-cont839 mod842 var838 #t) - (if (memv kind841 (quote (private))) - (if (not (equal? mod842 (module-name (current-module)))) - (modref-cont839 mod842 var838 #f) - (bare-cont840 var838)) - (if (memv kind841 (quote (bare))) - (bare-cont840 var838) - (if (memv kind841 (quote (hygiene))) + source3190 + var3197) + (decorate-source2441 var3197 source3190))))))) + (analyze-variable2447 + (lambda (mod3199 var3200 modref-cont3201 bare-cont3202) + (if (not mod3199) + (bare-cont3202 var3200) + (let ((kind3203 (car mod3199)) + (mod3204 (cdr mod3199))) + (if (memv kind3203 (quote (public))) + (modref-cont3201 mod3204 var3200 #t) + (if (memv kind3203 (quote (private))) + (if (not (equal? + mod3204 + (module-name (current-module)))) + (modref-cont3201 mod3204 var3200 #f) + (bare-cont3202 var3200)) + (if (memv kind3203 (quote (bare))) + (bare-cont3202 var3200) + (if (memv kind3203 (quote (hygiene))) (if (if (not (equal? - mod842 + mod3204 (module-name (current-module)))) (module-variable - (resolve-module mod842) - var838) + (resolve-module mod3204) + var3200) #f) - (modref-cont839 mod842 var838 #f) - (bare-cont840 var838)) + (modref-cont3201 mod3204 var3200 #f) + (bare-cont3202 var3200)) (syntax-violation #f "bad module kind" - var838 - mod842))))))))) - (build-lexical-assignment84 - (lambda (source843 name844 var845 exp846) - (let ((atom-key847 (fluid-ref *mode*71))) - (if (memv atom-key847 (quote (c))) + var3200 + mod3204))))))))) + (build-lexical-assignment2446 + (lambda (source3205 name3206 var3207 exp3208) + (let ((atom-key3209 (fluid-ref *mode*2432))) + (if (memv atom-key3209 (quote (c))) ((@ (language tree-il) make-lexical-set) - source843 - name844 - var845 - exp846) - (list (quote set!) var845 exp846))))) - (build-lexical-reference83 - (lambda (type848 source849 name850 var851) - (let ((atom-key852 (fluid-ref *mode*71))) - (if (memv atom-key852 (quote (c))) + source3205 + name3206 + var3207 + exp3208) + (decorate-source2441 + (list (quote set!) var3207 exp3208) + source3205))))) + (build-lexical-reference2445 + (lambda (type3210 source3211 name3212 var3213) + (let ((atom-key3214 (fluid-ref *mode*2432))) + (if (memv atom-key3214 (quote (c))) ((@ (language tree-il) make-lexical-ref) - source849 - name850 - var851) - var851)))) - (build-conditional82 - (lambda (source853 test-exp854 then-exp855 else-exp856) - (let ((atom-key857 (fluid-ref *mode*71))) - (if (memv atom-key857 (quote (c))) + source3211 + name3212 + var3213) + (decorate-source2441 var3213 source3211))))) + (build-conditional2444 + (lambda (source3215 + test-exp3216 + then-exp3217 + else-exp3218) + (let ((atom-key3219 (fluid-ref *mode*2432))) + (if (memv atom-key3219 (quote (c))) ((@ (language tree-il) make-conditional) - source853 - test-exp854 - then-exp855 - else-exp856) - (if (equal? else-exp856 (quote (if #f #f))) - (list (quote if) test-exp854 then-exp855) - (list 'if - test-exp854 - then-exp855 - else-exp856)))))) - (build-application81 - (lambda (source858 fun-exp859 arg-exps860) - (let ((atom-key861 (fluid-ref *mode*71))) - (if (memv atom-key861 (quote (c))) + source3215 + test-exp3216 + then-exp3217 + else-exp3218) + (decorate-source2441 + (if (equal? else-exp3218 (quote (if #f #f))) + (list (quote if) test-exp3216 then-exp3217) + (list 'if + test-exp3216 + then-exp3217 + else-exp3218)) + source3215))))) + (build-application2443 + (lambda (source3220 fun-exp3221 arg-exps3222) + (let ((atom-key3223 (fluid-ref *mode*2432))) + (if (memv atom-key3223 (quote (c))) ((@ (language tree-il) make-application) - source858 - fun-exp859 - arg-exps860) - (cons fun-exp859 arg-exps860))))) - (build-void80 - (lambda (source862) - (let ((atom-key863 (fluid-ref *mode*71))) - (if (memv atom-key863 (quote (c))) - ((@ (language tree-il) make-void) source862) - '(if #f #f))))) - (get-global-definition-hook79 - (lambda (symbol864 module865) + source3220 + fun-exp3221 + arg-exps3222) + (decorate-source2441 + (cons fun-exp3221 arg-exps3222) + source3220))))) + (build-void2442 + (lambda (source3224) + (let ((atom-key3225 (fluid-ref *mode*2432))) + (if (memv atom-key3225 (quote (c))) + ((@ (language tree-il) make-void) source3224) + (decorate-source2441 + '(if #f #f) + source3224))))) + (decorate-source2441 + (lambda (e3226 s3227) (begin - (if (if (not module865) (current-module) #f) + (if (if (pair? e3226) s3227 #f) + (set-source-properties! e3226 s3227)) + e3226))) + (get-global-definition-hook2440 + (lambda (symbol3228 module3229) + (begin + (if (if (not module3229) (current-module) #f) (warn "module system is booted, we should have a module" - symbol864)) - (let ((v866 (module-variable - (if module865 - (resolve-module (cdr module865)) - (current-module)) - symbol864))) - (if v866 - (if (variable-bound? v866) - (let ((val867 (variable-ref v866))) - (if (macro? val867) - (if (syncase-macro-type val867) - (cons (syncase-macro-type val867) - (syncase-macro-binding val867)) + symbol3228)) + (let ((v3230 (module-variable + (if module3229 + (resolve-module (cdr module3229)) + (current-module)) + symbol3228))) + (if v3230 + (if (variable-bound? v3230) + (let ((val3231 (variable-ref v3230))) + (if (macro? val3231) + (if (syncase-macro-type val3231) + (cons (syncase-macro-type val3231) + (syncase-macro-binding val3231)) #f) #f)) #f) #f))))) - (put-global-definition-hook78 - (lambda (symbol868 type869 val870) - (let ((existing871 - (let ((v872 (module-variable - (current-module) - symbol868))) - (if v872 - (if (variable-bound? v872) - (let ((val873 (variable-ref v872))) - (if (macro? val873) - (if (not (syncase-macro-type val873)) - val873 + (put-global-definition-hook2439 + (lambda (symbol3232 type3233 val3234) + (let ((existing3235 + (let ((v3236 (module-variable + (current-module) + symbol3232))) + (if v3236 + (if (variable-bound? v3236) + (let ((val3237 (variable-ref v3236))) + (if (macro? val3237) + (if (not (syncase-macro-type val3237)) + val3237 #f) #f)) #f) #f)))) (module-define! (current-module) - symbol868 - (if existing871 + symbol3232 + (if existing3235 (make-extended-syncase-macro - existing871 - type869 - val870) - (make-syncase-macro type869 val870)))))) - (local-eval-hook77 - (lambda (x874 mod875) + existing3235 + type3233 + val3234) + (make-syncase-macro type3233 val3234)))))) + (local-eval-hook2438 + (lambda (x3238 mod3239) (primitive-eval - (list noexpand70 - (let ((atom-key876 (fluid-ref *mode*71))) - (if (memv atom-key876 (quote (c))) - ((@ (language tree-il) tree-il->scheme) x874) - x874)))))) - (top-level-eval-hook76 - (lambda (x877 mod878) + (list noexpand2431 + (let ((atom-key3240 (fluid-ref *mode*2432))) + (if (memv atom-key3240 (quote (c))) + ((@ (language tree-il) tree-il->scheme) x3238) + x3238)))))) + (top-level-eval-hook2437 + (lambda (x3241 mod3242) (primitive-eval - (list noexpand70 - (let ((atom-key879 (fluid-ref *mode*71))) - (if (memv atom-key879 (quote (c))) - ((@ (language tree-il) tree-il->scheme) x877) - x877)))))) - (fx<75 <) - (fx=74 =) - (fx-73 -) - (fx+72 +) - (*mode*71 (make-fluid)) - (noexpand70 "noexpand")) + (list noexpand2431 + (let ((atom-key3243 (fluid-ref *mode*2432))) + (if (memv atom-key3243 (quote (c))) + ((@ (language tree-il) tree-il->scheme) x3241) + x3241)))))) + (fx<2436 <) + (fx=2435 =) + (fx-2434 -) + (fx+2433 +) + (*mode*2432 (make-fluid)) + (noexpand2431 "noexpand")) (begin - (global-extend112 + (global-extend2474 'local-syntax 'letrec-syntax #t) - (global-extend112 + (global-extend2474 'local-syntax 'let-syntax #f) - (global-extend112 + (global-extend2474 'core 'fluid-let-syntax - (lambda (e880 r881 w882 s883 mod884) - ((lambda (tmp885) - ((lambda (tmp886) - (if (if tmp886 - (apply (lambda (_887 var888 val889 e1890 e2891) - (valid-bound-ids?139 var888)) - tmp886) + (lambda (e3244 r3245 w3246 s3247 mod3248) + ((lambda (tmp3249) + ((lambda (tmp3250) + (if (if tmp3250 + (apply (lambda (_3251 var3252 val3253 e13254 e23255) + (valid-bound-ids?2501 var3252)) + tmp3250) #f) - (apply (lambda (_893 var894 val895 e1896 e2897) - (let ((names898 - (map (lambda (x899) - (id-var-name136 x899 w882)) - var894))) + (apply (lambda (_3257 var3258 val3259 e13260 e23261) + (let ((names3262 + (map (lambda (x3263) + (id-var-name2498 x3263 w3246)) + var3258))) (begin (for-each - (lambda (id901 n902) - (let ((atom-key903 - (binding-type106 - (lookup111 n902 r881 mod884)))) - (if (memv atom-key903 + (lambda (id3265 n3266) + (let ((atom-key3267 + (binding-type2468 + (lookup2473 + n3266 + r3245 + mod3248)))) + (if (memv atom-key3267 '(displaced-lexical)) (syntax-violation 'fluid-let-syntax "identifier out of context" - e880 - (source-wrap143 - id901 - w882 - s883 - mod884))))) - var894 - names898) - (chi-body154 - (cons e1896 e2897) - (source-wrap143 e880 w882 s883 mod884) - (extend-env108 - names898 - (let ((trans-r906 - (macros-only-env110 r881))) - (map (lambda (x907) + e3244 + (source-wrap2505 + id3265 + w3246 + s3247 + mod3248))))) + var3258 + names3262) + (chi-body2516 + (cons e13260 e23261) + (source-wrap2505 e3244 w3246 s3247 mod3248) + (extend-env2470 + names3262 + (let ((trans-r3270 + (macros-only-env2472 r3245))) + (map (lambda (x3271) (cons 'macro - (eval-local-transformer157 - (chi150 - x907 - trans-r906 - w882 - mod884) - mod884))) - val895)) - r881) - w882 - mod884)))) - tmp886) - ((lambda (_909) + (eval-local-transformer2519 + (chi2512 + x3271 + trans-r3270 + w3246 + mod3248) + mod3248))) + val3259)) + r3245) + w3246 + mod3248)))) + tmp3250) + ((lambda (_3273) (syntax-violation 'fluid-let-syntax "bad syntax" - (source-wrap143 e880 w882 s883 mod884))) - tmp885))) + (source-wrap2505 e3244 w3246 s3247 mod3248))) + tmp3249))) ($sc-dispatch - tmp885 + tmp3249 '(any #(each (any any)) any . each-any)))) - e880))) - (global-extend112 + e3244))) + (global-extend2474 'core 'quote - (lambda (e910 r911 w912 s913 mod914) - ((lambda (tmp915) - ((lambda (tmp916) - (if tmp916 - (apply (lambda (_917 e918) - (build-data92 s913 (strip160 e918 w912))) - tmp916) - ((lambda (_919) + (lambda (e3274 r3275 w3276 s3277 mod3278) + ((lambda (tmp3279) + ((lambda (tmp3280) + (if tmp3280 + (apply (lambda (_3281 e3282) + (build-data2454 s3277 (strip2522 e3282 w3276))) + tmp3280) + ((lambda (_3283) (syntax-violation 'quote "bad syntax" - (source-wrap143 e910 w912 s913 mod914))) - tmp915))) - ($sc-dispatch tmp915 (quote (any any))))) - e910))) - (global-extend112 + (source-wrap2505 e3274 w3276 s3277 mod3278))) + tmp3279))) + ($sc-dispatch tmp3279 (quote (any any))))) + e3274))) + (global-extend2474 'core 'syntax - (letrec ((regen927 - (lambda (x928) - (let ((atom-key929 (car x928))) - (if (memv atom-key929 (quote (ref))) - (build-lexical-reference83 + (letrec ((regen3291 + (lambda (x3292) + (let ((atom-key3293 (car x3292))) + (if (memv atom-key3293 (quote (ref))) + (build-lexical-reference2445 'value #f - (cadr x928) - (cadr x928)) - (if (memv atom-key929 (quote (primitive))) - (build-primref91 #f (cadr x928)) - (if (memv atom-key929 (quote (quote))) - (build-data92 #f (cadr x928)) - (if (memv atom-key929 (quote (lambda))) - (build-lambda90 + (cadr x3292) + (cadr x3292)) + (if (memv atom-key3293 (quote (primitive))) + (build-primref2453 #f (cadr x3292)) + (if (memv atom-key3293 (quote (quote))) + (build-data2454 #f (cadr x3292)) + (if (memv atom-key3293 (quote (lambda))) + (build-lambda2452 #f - (cadr x928) - (cadr x928) + (cadr x3292) + (cadr x3292) #f - (regen927 (caddr x928))) - (build-application81 + (regen3291 (caddr x3292))) + (build-application2443 #f - (build-primref91 #f (car x928)) - (map regen927 (cdr x928)))))))))) - (gen-vector926 - (lambda (x930) - (if (eq? (car x930) (quote list)) - (cons (quote vector) (cdr x930)) - (if (eq? (car x930) (quote quote)) - (list (quote quote) (list->vector (cadr x930))) - (list (quote list->vector) x930))))) - (gen-append925 - (lambda (x931 y932) - (if (equal? y932 (quote (quote ()))) - x931 - (list (quote append) x931 y932)))) - (gen-cons924 - (lambda (x933 y934) - (let ((atom-key935 (car y934))) - (if (memv atom-key935 (quote (quote))) - (if (eq? (car x933) (quote quote)) + (build-primref2453 #f (car x3292)) + (map regen3291 (cdr x3292)))))))))) + (gen-vector3290 + (lambda (x3294) + (if (eq? (car x3294) (quote list)) + (cons (quote vector) (cdr x3294)) + (if (eq? (car x3294) (quote quote)) + (list (quote quote) (list->vector (cadr x3294))) + (list (quote list->vector) x3294))))) + (gen-append3289 + (lambda (x3295 y3296) + (if (equal? y3296 (quote (quote ()))) + x3295 + (list (quote append) x3295 y3296)))) + (gen-cons3288 + (lambda (x3297 y3298) + (let ((atom-key3299 (car y3298))) + (if (memv atom-key3299 (quote (quote))) + (if (eq? (car x3297) (quote quote)) (list 'quote - (cons (cadr x933) (cadr y934))) - (if (eq? (cadr y934) (quote ())) - (list (quote list) x933) - (list (quote cons) x933 y934))) - (if (memv atom-key935 (quote (list))) - (cons (quote list) (cons x933 (cdr y934))) - (list (quote cons) x933 y934)))))) - (gen-map923 - (lambda (e936 map-env937) - (let ((formals938 (map cdr map-env937)) - (actuals939 - (map (lambda (x940) (list (quote ref) (car x940))) - map-env937))) - (if (eq? (car e936) (quote ref)) - (car actuals939) + (cons (cadr x3297) (cadr y3298))) + (if (eq? (cadr y3298) (quote ())) + (list (quote list) x3297) + (list (quote cons) x3297 y3298))) + (if (memv atom-key3299 (quote (list))) + (cons (quote list) (cons x3297 (cdr y3298))) + (list (quote cons) x3297 y3298)))))) + (gen-map3287 + (lambda (e3300 map-env3301) + (let ((formals3302 (map cdr map-env3301)) + (actuals3303 + (map (lambda (x3304) + (list (quote ref) (car x3304))) + map-env3301))) + (if (eq? (car e3300) (quote ref)) + (car actuals3303) (if (and-map - (lambda (x941) - (if (eq? (car x941) (quote ref)) - (memq (cadr x941) formals938) + (lambda (x3305) + (if (eq? (car x3305) (quote ref)) + (memq (cadr x3305) formals3302) #f)) - (cdr e936)) + (cdr e3300)) (cons 'map - (cons (list (quote primitive) (car e936)) - (map (let ((r942 (map cons - formals938 - actuals939))) - (lambda (x943) - (cdr (assq (cadr x943) r942)))) - (cdr e936)))) + (cons (list (quote primitive) (car e3300)) + (map (let ((r3306 (map cons + formals3302 + actuals3303))) + (lambda (x3307) + (cdr (assq (cadr x3307) + r3306)))) + (cdr e3300)))) (cons 'map - (cons (list (quote lambda) formals938 e936) - actuals939))))))) - (gen-mappend922 - (lambda (e944 map-env945) + (cons (list (quote lambda) formals3302 e3300) + actuals3303))))))) + (gen-mappend3286 + (lambda (e3308 map-env3309) (list 'apply '(primitive append) - (gen-map923 e944 map-env945)))) - (gen-ref921 - (lambda (src946 var947 level948 maps949) - (if (fx=74 level948 0) - (values var947 maps949) - (if (null? maps949) + (gen-map3287 e3308 map-env3309)))) + (gen-ref3285 + (lambda (src3310 var3311 level3312 maps3313) + (if (fx=2435 level3312 0) + (values var3311 maps3313) + (if (null? maps3313) (syntax-violation 'syntax "missing ellipsis" - src946) + src3310) (call-with-values (lambda () - (gen-ref921 - src946 - var947 - (fx-73 level948 1) - (cdr maps949))) - (lambda (outer-var950 outer-maps951) - (let ((b952 (assq outer-var950 (car maps949)))) - (if b952 - (values (cdr b952) maps949) - (let ((inner-var953 (gen-var161 (quote tmp)))) + (gen-ref3285 + src3310 + var3311 + (fx-2434 level3312 1) + (cdr maps3313))) + (lambda (outer-var3314 outer-maps3315) + (let ((b3316 (assq outer-var3314 (car maps3313)))) + (if b3316 + (values (cdr b3316) maps3313) + (let ((inner-var3317 + (gen-var2523 (quote tmp)))) (values - inner-var953 - (cons (cons (cons outer-var950 - inner-var953) - (car maps949)) - outer-maps951))))))))))) - (gen-syntax920 - (lambda (src954 e955 r956 maps957 ellipsis?958 mod959) - (if (id?114 e955) - (let ((label960 (id-var-name136 e955 (quote (()))))) - (let ((b961 (lookup111 label960 r956 mod959))) - (if (eq? (binding-type106 b961) (quote syntax)) + inner-var3317 + (cons (cons (cons outer-var3314 + inner-var3317) + (car maps3313)) + outer-maps3315))))))))))) + (gen-syntax3284 + (lambda (src3318 + e3319 + r3320 + maps3321 + ellipsis?3322 + mod3323) + (if (id?2476 e3319) + (let ((label3324 (id-var-name2498 e3319 (quote (()))))) + (let ((b3325 (lookup2473 label3324 r3320 mod3323))) + (if (eq? (binding-type2468 b3325) (quote syntax)) (call-with-values (lambda () - (let ((var.lev962 (binding-value107 b961))) - (gen-ref921 - src954 - (car var.lev962) - (cdr var.lev962) - maps957))) - (lambda (var963 maps964) - (values (list (quote ref) var963) maps964))) - (if (ellipsis?958 e955) + (let ((var.lev3326 (binding-value2469 b3325))) + (gen-ref3285 + src3318 + (car var.lev3326) + (cdr var.lev3326) + maps3321))) + (lambda (var3327 maps3328) + (values (list (quote ref) var3327) maps3328))) + (if (ellipsis?3322 e3319) (syntax-violation 'syntax "misplaced ellipsis" - src954) - (values (list (quote quote) e955) maps957))))) - ((lambda (tmp965) - ((lambda (tmp966) - (if (if tmp966 - (apply (lambda (dots967 e968) - (ellipsis?958 dots967)) - tmp966) + src3318) + (values (list (quote quote) e3319) maps3321))))) + ((lambda (tmp3329) + ((lambda (tmp3330) + (if (if tmp3330 + (apply (lambda (dots3331 e3332) + (ellipsis?3322 dots3331)) + tmp3330) #f) - (apply (lambda (dots969 e970) - (gen-syntax920 - src954 - e970 - r956 - maps957 - (lambda (x971) #f) - mod959)) - tmp966) - ((lambda (tmp972) - (if (if tmp972 - (apply (lambda (x973 dots974 y975) - (ellipsis?958 dots974)) - tmp972) + (apply (lambda (dots3333 e3334) + (gen-syntax3284 + src3318 + e3334 + r3320 + maps3321 + (lambda (x3335) #f) + mod3323)) + tmp3330) + ((lambda (tmp3336) + (if (if tmp3336 + (apply (lambda (x3337 dots3338 y3339) + (ellipsis?3322 dots3338)) + tmp3336) #f) - (apply (lambda (x976 dots977 y978) - (letrec ((f979 (lambda (y980 k981) - ((lambda (tmp985) - ((lambda (tmp986) - (if (if tmp986 - (apply (lambda (dots987 - y988) - (ellipsis?958 - dots987)) - tmp986) - #f) - (apply (lambda (dots989 - y990) - (f979 y990 - (lambda (maps991) - (call-with-values - (lambda () - (k981 (cons '() - maps991))) - (lambda (x992 - maps993) - (if (null? (car maps993)) - (syntax-violation - 'syntax - "extra ellipsis" - src954) - (values - (gen-mappend922 - x992 - (car maps993)) - (cdr maps993)))))))) - tmp986) - ((lambda (_994) - (call-with-values - (lambda () - (gen-syntax920 - src954 - y980 - r956 - maps957 - ellipsis?958 - mod959)) - (lambda (y995 - maps996) - (call-with-values - (lambda () - (k981 maps996)) - (lambda (x997 - maps998) - (values - (gen-append925 - x997 - y995) - maps998)))))) - tmp985))) - ($sc-dispatch - tmp985 - '(any . - any)))) - y980)))) - (f979 y978 - (lambda (maps982) - (call-with-values - (lambda () - (gen-syntax920 - src954 - x976 - r956 - (cons '() - maps982) - ellipsis?958 - mod959)) - (lambda (x983 maps984) - (if (null? (car maps984)) - (syntax-violation - 'syntax - "extra ellipsis" - src954) - (values - (gen-map923 - x983 - (car maps984)) - (cdr maps984))))))))) - tmp972) - ((lambda (tmp999) - (if tmp999 - (apply (lambda (x1000 y1001) + (apply (lambda (x3340 dots3341 y3342) + (letrec ((f3343 (lambda (y3344 + k3345) + ((lambda (tmp3349) + ((lambda (tmp3350) + (if (if tmp3350 + (apply (lambda (dots3351 + y3352) + (ellipsis?3322 + dots3351)) + tmp3350) + #f) + (apply (lambda (dots3353 + y3354) + (f3343 y3354 + (lambda (maps3355) + (call-with-values + (lambda () + (k3345 (cons '() + maps3355))) + (lambda (x3356 + maps3357) + (if (null? (car maps3357)) + (syntax-violation + 'syntax + "extra ellipsis" + src3318) + (values + (gen-mappend3286 + x3356 + (car maps3357)) + (cdr maps3357)))))))) + tmp3350) + ((lambda (_3358) + (call-with-values + (lambda () + (gen-syntax3284 + src3318 + y3344 + r3320 + maps3321 + ellipsis?3322 + mod3323)) + (lambda (y3359 + maps3360) + (call-with-values + (lambda () + (k3345 maps3360)) + (lambda (x3361 + maps3362) + (values + (gen-append3289 + x3361 + y3359) + maps3362)))))) + tmp3349))) + ($sc-dispatch + tmp3349 + '(any . + any)))) + y3344)))) + (f3343 y3342 + (lambda (maps3346) + (call-with-values + (lambda () + (gen-syntax3284 + src3318 + x3340 + r3320 + (cons '() + maps3346) + ellipsis?3322 + mod3323)) + (lambda (x3347 + maps3348) + (if (null? (car maps3348)) + (syntax-violation + 'syntax + "extra ellipsis" + src3318) + (values + (gen-map3287 + x3347 + (car maps3348)) + (cdr maps3348))))))))) + tmp3336) + ((lambda (tmp3363) + (if tmp3363 + (apply (lambda (x3364 y3365) (call-with-values (lambda () - (gen-syntax920 - src954 - x1000 - r956 - maps957 - ellipsis?958 - mod959)) - (lambda (x1002 maps1003) + (gen-syntax3284 + src3318 + x3364 + r3320 + maps3321 + ellipsis?3322 + mod3323)) + (lambda (x3366 maps3367) (call-with-values (lambda () - (gen-syntax920 - src954 - y1001 - r956 - maps1003 - ellipsis?958 - mod959)) - (lambda (y1004 - maps1005) + (gen-syntax3284 + src3318 + y3365 + r3320 + maps3367 + ellipsis?3322 + mod3323)) + (lambda (y3368 + maps3369) (values - (gen-cons924 - x1002 - y1004) - maps1005)))))) - tmp999) - ((lambda (tmp1006) - (if tmp1006 - (apply (lambda (e11007 e21008) + (gen-cons3288 + x3366 + y3368) + maps3369)))))) + tmp3363) + ((lambda (tmp3370) + (if tmp3370 + (apply (lambda (e13371 e23372) (call-with-values (lambda () - (gen-syntax920 - src954 - (cons e11007 - e21008) - r956 - maps957 - ellipsis?958 - mod959)) - (lambda (e1010 - maps1011) + (gen-syntax3284 + src3318 + (cons e13371 + e23372) + r3320 + maps3321 + ellipsis?3322 + mod3323)) + (lambda (e3374 + maps3375) (values - (gen-vector926 - e1010) - maps1011)))) - tmp1006) - ((lambda (_1012) + (gen-vector3290 + e3374) + maps3375)))) + tmp3370) + ((lambda (_3376) (values - (list (quote quote) e955) - maps957)) - tmp965))) + (list (quote quote) e3319) + maps3321)) + tmp3329))) ($sc-dispatch - tmp965 + tmp3329 '#(vector (any . each-any)))))) ($sc-dispatch - tmp965 + tmp3329 '(any . any))))) ($sc-dispatch - tmp965 + tmp3329 '(any any . any))))) - ($sc-dispatch tmp965 (quote (any any))))) - e955))))) - (lambda (e1013 r1014 w1015 s1016 mod1017) - (let ((e1018 (source-wrap143 e1013 w1015 s1016 mod1017))) - ((lambda (tmp1019) - ((lambda (tmp1020) - (if tmp1020 - (apply (lambda (_1021 x1022) + ($sc-dispatch tmp3329 (quote (any any))))) + e3319))))) + (lambda (e3377 r3378 w3379 s3380 mod3381) + (let ((e3382 (source-wrap2505 e3377 w3379 s3380 mod3381))) + ((lambda (tmp3383) + ((lambda (tmp3384) + (if tmp3384 + (apply (lambda (_3385 x3386) (call-with-values (lambda () - (gen-syntax920 - e1018 - x1022 - r1014 + (gen-syntax3284 + e3382 + x3386 + r3378 '() - ellipsis?159 - mod1017)) - (lambda (e1023 maps1024) (regen927 e1023)))) - tmp1020) - ((lambda (_1025) + ellipsis?2521 + mod3381)) + (lambda (e3387 maps3388) (regen3291 e3387)))) + tmp3384) + ((lambda (_3389) (syntax-violation 'syntax "bad `syntax' form" - e1018)) - tmp1019))) - ($sc-dispatch tmp1019 (quote (any any))))) - e1018))))) - (global-extend112 + e3382)) + tmp3383))) + ($sc-dispatch tmp3383 (quote (any any))))) + e3382))))) + (global-extend2474 'core 'lambda - (lambda (e1026 r1027 w1028 s1029 mod1030) - ((lambda (tmp1031) - ((lambda (tmp1032) - (if tmp1032 - (apply (lambda (_1033 c1034) - (chi-lambda-clause155 - (source-wrap143 e1026 w1028 s1029 mod1030) + (lambda (e3390 r3391 w3392 s3393 mod3394) + ((lambda (tmp3395) + ((lambda (tmp3396) + (if tmp3396 + (apply (lambda (_3397 c3398) + (chi-lambda-clause2517 + (source-wrap2505 e3390 w3392 s3393 mod3394) #f - c1034 - r1027 - w1028 - mod1030 - (lambda (names1035 - vars1036 - docstring1037 - body1038) - (build-lambda90 - s1029 - names1035 - vars1036 - docstring1037 - body1038)))) - tmp1032) + c3398 + r3391 + w3392 + mod3394 + (lambda (names3399 + vars3400 + docstring3401 + body3402) + (build-lambda2452 + s3393 + names3399 + vars3400 + docstring3401 + body3402)))) + tmp3396) (syntax-violation #f "source expression failed to match any pattern" - tmp1031))) - ($sc-dispatch tmp1031 (quote (any . any))))) - e1026))) - (global-extend112 + tmp3395))) + ($sc-dispatch tmp3395 (quote (any . any))))) + e3390))) + (global-extend2474 'core 'let - (letrec ((chi-let1039 - (lambda (e1040 - r1041 - w1042 - s1043 - mod1044 - constructor1045 - ids1046 - vals1047 - exps1048) - (if (not (valid-bound-ids?139 ids1046)) + (letrec ((chi-let3403 + (lambda (e3404 + r3405 + w3406 + s3407 + mod3408 + constructor3409 + ids3410 + vals3411 + exps3412) + (if (not (valid-bound-ids?2501 ids3410)) (syntax-violation 'let "duplicate bound variable" - e1040) - (let ((labels1049 (gen-labels120 ids1046)) - (new-vars1050 (map gen-var161 ids1046))) - (let ((nw1051 - (make-binding-wrap131 - ids1046 - labels1049 - w1042)) - (nr1052 - (extend-var-env109 - labels1049 - new-vars1050 - r1041))) - (constructor1045 - s1043 - (map syntax->datum ids1046) - new-vars1050 - (map (lambda (x1053) - (chi150 x1053 r1041 w1042 mod1044)) - vals1047) - (chi-body154 - exps1048 - (source-wrap143 e1040 nw1051 s1043 mod1044) - nr1052 - nw1051 - mod1044)))))))) - (lambda (e1054 r1055 w1056 s1057 mod1058) - ((lambda (tmp1059) - ((lambda (tmp1060) - (if (if tmp1060 - (apply (lambda (_1061 id1062 val1063 e11064 e21065) - (and-map id?114 id1062)) - tmp1060) + e3404) + (let ((labels3413 (gen-labels2482 ids3410)) + (new-vars3414 (map gen-var2523 ids3410))) + (let ((nw3415 + (make-binding-wrap2493 + ids3410 + labels3413 + w3406)) + (nr3416 + (extend-var-env2471 + labels3413 + new-vars3414 + r3405))) + (constructor3409 + s3407 + (map syntax->datum ids3410) + new-vars3414 + (map (lambda (x3417) + (chi2512 x3417 r3405 w3406 mod3408)) + vals3411) + (chi-body2516 + exps3412 + (source-wrap2505 e3404 nw3415 s3407 mod3408) + nr3416 + nw3415 + mod3408)))))))) + (lambda (e3418 r3419 w3420 s3421 mod3422) + ((lambda (tmp3423) + ((lambda (tmp3424) + (if (if tmp3424 + (apply (lambda (_3425 id3426 val3427 e13428 e23429) + (and-map id?2476 id3426)) + tmp3424) #f) - (apply (lambda (_1067 id1068 val1069 e11070 e21071) - (chi-let1039 - e1054 - r1055 - w1056 - s1057 - mod1058 - build-let94 - id1068 - val1069 - (cons e11070 e21071))) - tmp1060) - ((lambda (tmp1075) - (if (if tmp1075 - (apply (lambda (_1076 - f1077 - id1078 - val1079 - e11080 - e21081) - (if (id?114 f1077) - (and-map id?114 id1078) + (apply (lambda (_3431 id3432 val3433 e13434 e23435) + (chi-let3403 + e3418 + r3419 + w3420 + s3421 + mod3422 + build-let2456 + id3432 + val3433 + (cons e13434 e23435))) + tmp3424) + ((lambda (tmp3439) + (if (if tmp3439 + (apply (lambda (_3440 + f3441 + id3442 + val3443 + e13444 + e23445) + (if (id?2476 f3441) + (and-map id?2476 id3442) #f)) - tmp1075) + tmp3439) #f) - (apply (lambda (_1083 - f1084 - id1085 - val1086 - e11087 - e21088) - (chi-let1039 - e1054 - r1055 - w1056 - s1057 - mod1058 - build-named-let95 - (cons f1084 id1085) - val1086 - (cons e11087 e21088))) - tmp1075) - ((lambda (_1092) + (apply (lambda (_3447 + f3448 + id3449 + val3450 + e13451 + e23452) + (chi-let3403 + e3418 + r3419 + w3420 + s3421 + mod3422 + build-named-let2457 + (cons f3448 id3449) + val3450 + (cons e13451 e23452))) + tmp3439) + ((lambda (_3456) (syntax-violation 'let "bad let" - (source-wrap143 e1054 w1056 s1057 mod1058))) - tmp1059))) + (source-wrap2505 e3418 w3420 s3421 mod3422))) + tmp3423))) ($sc-dispatch - tmp1059 + tmp3423 '(any any #(each (any any)) any . each-any))))) ($sc-dispatch - tmp1059 + tmp3423 '(any #(each (any any)) any . each-any)))) - e1054)))) - (global-extend112 + e3418)))) + (global-extend2474 'core 'letrec - (lambda (e1093 r1094 w1095 s1096 mod1097) - ((lambda (tmp1098) - ((lambda (tmp1099) - (if (if tmp1099 - (apply (lambda (_1100 id1101 val1102 e11103 e21104) - (and-map id?114 id1101)) - tmp1099) + (lambda (e3457 r3458 w3459 s3460 mod3461) + ((lambda (tmp3462) + ((lambda (tmp3463) + (if (if tmp3463 + (apply (lambda (_3464 id3465 val3466 e13467 e23468) + (and-map id?2476 id3465)) + tmp3463) #f) - (apply (lambda (_1106 id1107 val1108 e11109 e21110) - (let ((ids1111 id1107)) - (if (not (valid-bound-ids?139 ids1111)) + (apply (lambda (_3470 id3471 val3472 e13473 e23474) + (let ((ids3475 id3471)) + (if (not (valid-bound-ids?2501 ids3475)) (syntax-violation 'letrec "duplicate bound variable" - e1093) - (let ((labels1113 (gen-labels120 ids1111)) - (new-vars1114 (map gen-var161 ids1111))) - (let ((w1115 (make-binding-wrap131 - ids1111 - labels1113 - w1095)) - (r1116 (extend-var-env109 - labels1113 - new-vars1114 - r1094))) - (build-letrec96 - s1096 - (map syntax->datum ids1111) - new-vars1114 - (map (lambda (x1117) - (chi150 x1117 r1116 w1115 mod1097)) - val1108) - (chi-body154 - (cons e11109 e21110) - (source-wrap143 - e1093 - w1115 - s1096 - mod1097) - r1116 - w1115 - mod1097))))))) - tmp1099) - ((lambda (_1120) + e3457) + (let ((labels3477 (gen-labels2482 ids3475)) + (new-vars3478 (map gen-var2523 ids3475))) + (let ((w3479 (make-binding-wrap2493 + ids3475 + labels3477 + w3459)) + (r3480 (extend-var-env2471 + labels3477 + new-vars3478 + r3458))) + (build-letrec2458 + s3460 + (map syntax->datum ids3475) + new-vars3478 + (map (lambda (x3481) + (chi2512 + x3481 + r3480 + w3479 + mod3461)) + val3472) + (chi-body2516 + (cons e13473 e23474) + (source-wrap2505 + e3457 + w3479 + s3460 + mod3461) + r3480 + w3479 + mod3461))))))) + tmp3463) + ((lambda (_3484) (syntax-violation 'letrec "bad letrec" - (source-wrap143 e1093 w1095 s1096 mod1097))) - tmp1098))) + (source-wrap2505 e3457 w3459 s3460 mod3461))) + tmp3462))) ($sc-dispatch - tmp1098 + tmp3462 '(any #(each (any any)) any . each-any)))) - e1093))) - (global-extend112 + e3457))) + (global-extend2474 'core 'set! - (lambda (e1121 r1122 w1123 s1124 mod1125) - ((lambda (tmp1126) - ((lambda (tmp1127) - (if (if tmp1127 - (apply (lambda (_1128 id1129 val1130) (id?114 id1129)) - tmp1127) + (lambda (e3485 r3486 w3487 s3488 mod3489) + ((lambda (tmp3490) + ((lambda (tmp3491) + (if (if tmp3491 + (apply (lambda (_3492 id3493 val3494) (id?2476 id3493)) + tmp3491) #f) - (apply (lambda (_1131 id1132 val1133) - (let ((val1134 (chi150 val1133 r1122 w1123 mod1125)) - (n1135 (id-var-name136 id1132 w1123))) - (let ((b1136 (lookup111 n1135 r1122 mod1125))) - (let ((atom-key1137 (binding-type106 b1136))) - (if (memv atom-key1137 (quote (lexical))) - (build-lexical-assignment84 - s1124 - (syntax->datum id1132) - (binding-value107 b1136) - val1134) - (if (memv atom-key1137 (quote (global))) - (build-global-assignment87 - s1124 - n1135 - val1134 - mod1125) - (if (memv atom-key1137 + (apply (lambda (_3495 id3496 val3497) + (let ((val3498 + (chi2512 val3497 r3486 w3487 mod3489)) + (n3499 (id-var-name2498 id3496 w3487))) + (let ((b3500 (lookup2473 n3499 r3486 mod3489))) + (let ((atom-key3501 (binding-type2468 b3500))) + (if (memv atom-key3501 (quote (lexical))) + (build-lexical-assignment2446 + s3488 + (syntax->datum id3496) + (binding-value2469 b3500) + val3498) + (if (memv atom-key3501 (quote (global))) + (build-global-assignment2449 + s3488 + n3499 + val3498 + mod3489) + (if (memv atom-key3501 '(displaced-lexical)) (syntax-violation 'set! "identifier out of context" - (wrap142 id1132 w1123 mod1125)) + (wrap2504 id3496 w3487 mod3489)) (syntax-violation 'set! "bad set!" - (source-wrap143 - e1121 - w1123 - s1124 - mod1125))))))))) - tmp1127) - ((lambda (tmp1138) - (if tmp1138 - (apply (lambda (_1139 head1140 tail1141 val1142) + (source-wrap2505 + e3485 + w3487 + s3488 + mod3489))))))))) + tmp3491) + ((lambda (tmp3502) + (if tmp3502 + (apply (lambda (_3503 head3504 tail3505 val3506) (call-with-values (lambda () - (syntax-type148 - head1140 - r1122 + (syntax-type2510 + head3504 + r3486 '(()) #f #f - mod1125 + mod3489 #t)) - (lambda (type1143 - value1144 - ee1145 - ww1146 - ss1147 - modmod1148) - (if (memv type1143 (quote (module-ref))) - (let ((val1149 - (chi150 - val1142 - r1122 - w1123 - mod1125))) + (lambda (type3507 + value3508 + ee3509 + ww3510 + ss3511 + modmod3512) + (if (memv type3507 (quote (module-ref))) + (let ((val3513 + (chi2512 + val3506 + r3486 + w3487 + mod3489))) (call-with-values (lambda () - (value1144 - (cons head1140 tail1141))) - (lambda (id1151 mod1152) - (build-global-assignment87 - s1124 - id1151 - val1149 - mod1152)))) - (build-application81 - s1124 - (chi150 + (value3508 + (cons head3504 tail3505))) + (lambda (id3515 mod3516) + (build-global-assignment2449 + s3488 + id3515 + val3513 + mod3516)))) + (build-application2443 + s3488 + (chi2512 (list '#(syntax-object setter ((top) @@ -6189,6 +6407,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -6310,6 +6529,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -6421,6 +6641,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -6428,47 +6649,47 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - head1140) - r1122 - w1123 - mod1125) - (map (lambda (e1153) - (chi150 - e1153 - r1122 - w1123 - mod1125)) + head3504) + r3486 + w3487 + mod3489) + (map (lambda (e3517) + (chi2512 + e3517 + r3486 + w3487 + mod3489)) (append - tail1141 - (list val1142)))))))) - tmp1138) - ((lambda (_1155) + tail3505 + (list val3506)))))))) + tmp3502) + ((lambda (_3519) (syntax-violation 'set! "bad set!" - (source-wrap143 e1121 w1123 s1124 mod1125))) - tmp1126))) + (source-wrap2505 e3485 w3487 s3488 mod3489))) + tmp3490))) ($sc-dispatch - tmp1126 + tmp3490 '(any (any . each-any) any))))) - ($sc-dispatch tmp1126 (quote (any any any))))) - e1121))) - (global-extend112 + ($sc-dispatch tmp3490 (quote (any any any))))) + e3485))) + (global-extend2474 'module-ref '@ - (lambda (e1156) - ((lambda (tmp1157) - ((lambda (tmp1158) - (if (if tmp1158 - (apply (lambda (_1159 mod1160 id1161) - (if (and-map id?114 mod1160) - (id?114 id1161) + (lambda (e3520) + ((lambda (tmp3521) + ((lambda (tmp3522) + (if (if tmp3522 + (apply (lambda (_3523 mod3524 id3525) + (if (and-map id?2476 mod3524) + (id?2476 id3525) #f)) - tmp1158) + tmp3522) #f) - (apply (lambda (_1163 mod1164 id1165) + (apply (lambda (_3527 mod3528 id3529) (values - (syntax->datum id1165) + (syntax->datum id3529) (syntax->datum (cons '#(syntax-object public @@ -6580,6 +6801,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -6701,6 +6923,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -6812,36 +7035,37 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) - mod1164)))) - tmp1158) + mod3528)))) + tmp3522) (syntax-violation #f "source expression failed to match any pattern" - tmp1157))) - ($sc-dispatch tmp1157 (quote (any each-any any))))) - e1156))) - (global-extend112 + tmp3521))) + ($sc-dispatch tmp3521 (quote (any each-any any))))) + e3520))) + (global-extend2474 'module-ref '@@ - (lambda (e1167) - ((lambda (tmp1168) - ((lambda (tmp1169) - (if (if tmp1169 - (apply (lambda (_1170 mod1171 id1172) - (if (and-map id?114 mod1171) - (id?114 id1172) + (lambda (e3531) + ((lambda (tmp3532) + ((lambda (tmp3533) + (if (if tmp3533 + (apply (lambda (_3534 mod3535 id3536) + (if (and-map id?2476 mod3535) + (id?2476 id3536) #f)) - tmp1169) + tmp3533) #f) - (apply (lambda (_1174 mod1175 id1176) + (apply (lambda (_3538 mod3539 id3540) (values - (syntax->datum id1176) + (syntax->datum id3540) (syntax->datum (cons '#(syntax-object private @@ -6953,6 +7177,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -7074,6 +7299,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -7185,90 +7411,91 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) - mod1175)))) - tmp1169) + mod3539)))) + tmp3533) (syntax-violation #f "source expression failed to match any pattern" - tmp1168))) - ($sc-dispatch tmp1168 (quote (any each-any any))))) - e1167))) - (global-extend112 + tmp3532))) + ($sc-dispatch tmp3532 (quote (any each-any any))))) + e3531))) + (global-extend2474 'core 'if - (lambda (e1178 r1179 w1180 s1181 mod1182) - ((lambda (tmp1183) - ((lambda (tmp1184) - (if tmp1184 - (apply (lambda (_1185 test1186 then1187) - (build-conditional82 - s1181 - (chi150 test1186 r1179 w1180 mod1182) - (chi150 then1187 r1179 w1180 mod1182) - (build-void80 #f))) - tmp1184) - ((lambda (tmp1188) - (if tmp1188 - (apply (lambda (_1189 test1190 then1191 else1192) - (build-conditional82 - s1181 - (chi150 test1190 r1179 w1180 mod1182) - (chi150 then1191 r1179 w1180 mod1182) - (chi150 else1192 r1179 w1180 mod1182))) - tmp1188) + (lambda (e3542 r3543 w3544 s3545 mod3546) + ((lambda (tmp3547) + ((lambda (tmp3548) + (if tmp3548 + (apply (lambda (_3549 test3550 then3551) + (build-conditional2444 + s3545 + (chi2512 test3550 r3543 w3544 mod3546) + (chi2512 then3551 r3543 w3544 mod3546) + (build-void2442 #f))) + tmp3548) + ((lambda (tmp3552) + (if tmp3552 + (apply (lambda (_3553 test3554 then3555 else3556) + (build-conditional2444 + s3545 + (chi2512 test3554 r3543 w3544 mod3546) + (chi2512 then3555 r3543 w3544 mod3546) + (chi2512 else3556 r3543 w3544 mod3546))) + tmp3552) (syntax-violation #f "source expression failed to match any pattern" - tmp1183))) - ($sc-dispatch tmp1183 (quote (any any any any)))))) - ($sc-dispatch tmp1183 (quote (any any any))))) - e1178))) - (global-extend112 + tmp3547))) + ($sc-dispatch tmp3547 (quote (any any any any)))))) + ($sc-dispatch tmp3547 (quote (any any any))))) + e3542))) + (global-extend2474 'begin 'begin '()) - (global-extend112 + (global-extend2474 'define 'define '()) - (global-extend112 + (global-extend2474 'define-syntax 'define-syntax '()) - (global-extend112 + (global-extend2474 'eval-when 'eval-when '()) - (global-extend112 + (global-extend2474 'core 'syntax-case - (letrec ((gen-syntax-case1196 - (lambda (x1197 keys1198 clauses1199 r1200 mod1201) - (if (null? clauses1199) - (build-application81 + (letrec ((gen-syntax-case3560 + (lambda (x3561 keys3562 clauses3563 r3564 mod3565) + (if (null? clauses3563) + (build-application2443 #f - (build-primref91 #f (quote syntax-violation)) - (list (build-data92 #f #f) - (build-data92 + (build-primref2453 #f (quote syntax-violation)) + (list (build-data2454 #f #f) + (build-data2454 #f "source expression failed to match any pattern") - x1197)) - ((lambda (tmp1202) - ((lambda (tmp1203) - (if tmp1203 - (apply (lambda (pat1204 exp1205) - (if (if (id?114 pat1204) + x3561)) + ((lambda (tmp3566) + ((lambda (tmp3567) + (if tmp3567 + (apply (lambda (pat3568 exp3569) + (if (if (id?2476 pat3568) (and-map - (lambda (x1206) - (not (free-id=?137 - pat1204 - x1206))) + (lambda (x3570) + (not (free-id=?2499 + pat3568 + x3570))) (cons '#(syntax-object ... ((top) @@ -7404,6 +7631,7 @@ build-conditional build-application build-void + decorate-source get-global-definition-hook put-global-definition-hook gensym-hook @@ -7525,6 +7753,7 @@ (top) (top) (top) + (top) (top)) ("i" "i" @@ -7636,6 +7865,7 @@ "i" "i" "i" + "i" "i")) #(ribcage (define-structure @@ -7643,620 +7873,623 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - keys1198)) + keys3562)) #f) - (let ((labels1207 - (list (gen-label119))) - (var1208 (gen-var161 pat1204))) - (build-application81 + (let ((labels3571 + (list (gen-label2481))) + (var3572 + (gen-var2523 pat3568))) + (build-application2443 #f - (build-lambda90 + (build-lambda2452 #f - (list (syntax->datum pat1204)) - (list var1208) + (list (syntax->datum pat3568)) + (list var3572) #f - (chi150 - exp1205 - (extend-env108 - labels1207 + (chi2512 + exp3569 + (extend-env2470 + labels3571 (list (cons 'syntax - (cons var1208 + (cons var3572 0))) - r1200) - (make-binding-wrap131 - (list pat1204) - labels1207 + r3564) + (make-binding-wrap2493 + (list pat3568) + labels3571 '(())) - mod1201)) - (list x1197))) - (gen-clause1195 - x1197 - keys1198 - (cdr clauses1199) - r1200 - pat1204 + mod3565)) + (list x3561))) + (gen-clause3559 + x3561 + keys3562 + (cdr clauses3563) + r3564 + pat3568 #t - exp1205 - mod1201))) - tmp1203) - ((lambda (tmp1209) - (if tmp1209 - (apply (lambda (pat1210 fender1211 exp1212) - (gen-clause1195 - x1197 - keys1198 - (cdr clauses1199) - r1200 - pat1210 - fender1211 - exp1212 - mod1201)) - tmp1209) - ((lambda (_1213) + exp3569 + mod3565))) + tmp3567) + ((lambda (tmp3573) + (if tmp3573 + (apply (lambda (pat3574 fender3575 exp3576) + (gen-clause3559 + x3561 + keys3562 + (cdr clauses3563) + r3564 + pat3574 + fender3575 + exp3576 + mod3565)) + tmp3573) + ((lambda (_3577) (syntax-violation 'syntax-case "invalid clause" - (car clauses1199))) - tmp1202))) - ($sc-dispatch tmp1202 (quote (any any any)))))) - ($sc-dispatch tmp1202 (quote (any any))))) - (car clauses1199))))) - (gen-clause1195 - (lambda (x1214 - keys1215 - clauses1216 - r1217 - pat1218 - fender1219 - exp1220 - mod1221) + (car clauses3563))) + tmp3566))) + ($sc-dispatch tmp3566 (quote (any any any)))))) + ($sc-dispatch tmp3566 (quote (any any))))) + (car clauses3563))))) + (gen-clause3559 + (lambda (x3578 + keys3579 + clauses3580 + r3581 + pat3582 + fender3583 + exp3584 + mod3585) (call-with-values (lambda () - (convert-pattern1193 pat1218 keys1215)) - (lambda (p1222 pvars1223) - (if (not (distinct-bound-ids?140 (map car pvars1223))) + (convert-pattern3557 pat3582 keys3579)) + (lambda (p3586 pvars3587) + (if (not (distinct-bound-ids?2502 + (map car pvars3587))) (syntax-violation 'syntax-case "duplicate pattern variable" - pat1218) + pat3582) (if (not (and-map - (lambda (x1224) - (not (ellipsis?159 (car x1224)))) - pvars1223)) + (lambda (x3588) + (not (ellipsis?2521 (car x3588)))) + pvars3587)) (syntax-violation 'syntax-case "misplaced ellipsis" - pat1218) - (let ((y1225 (gen-var161 (quote tmp)))) - (build-application81 + pat3582) + (let ((y3589 (gen-var2523 (quote tmp)))) + (build-application2443 #f - (build-lambda90 + (build-lambda2452 #f (list (quote tmp)) - (list y1225) + (list y3589) #f - (let ((y1226 (build-lexical-reference83 + (let ((y3590 (build-lexical-reference2445 'value #f 'tmp - y1225))) - (build-conditional82 + y3589))) + (build-conditional2444 #f - ((lambda (tmp1227) - ((lambda (tmp1228) - (if tmp1228 - (apply (lambda () y1226) - tmp1228) - ((lambda (_1229) - (build-conditional82 + ((lambda (tmp3591) + ((lambda (tmp3592) + (if tmp3592 + (apply (lambda () y3590) + tmp3592) + ((lambda (_3593) + (build-conditional2444 #f - y1226 - (build-dispatch-call1194 - pvars1223 - fender1219 - y1226 - r1217 - mod1221) - (build-data92 #f #f))) - tmp1227))) + y3590 + (build-dispatch-call3558 + pvars3587 + fender3583 + y3590 + r3581 + mod3585) + (build-data2454 #f #f))) + tmp3591))) ($sc-dispatch - tmp1227 + tmp3591 '#(atom #t)))) - fender1219) - (build-dispatch-call1194 - pvars1223 - exp1220 - y1226 - r1217 - mod1221) - (gen-syntax-case1196 - x1214 - keys1215 - clauses1216 - r1217 - mod1221)))) - (list (if (eq? p1222 (quote any)) - (build-application81 + fender3583) + (build-dispatch-call3558 + pvars3587 + exp3584 + y3590 + r3581 + mod3585) + (gen-syntax-case3560 + x3578 + keys3579 + clauses3580 + r3581 + mod3585)))) + (list (if (eq? p3586 (quote any)) + (build-application2443 #f - (build-primref91 #f (quote list)) - (list x1214)) - (build-application81 + (build-primref2453 #f (quote list)) + (list x3578)) + (build-application2443 #f - (build-primref91 + (build-primref2453 #f '$sc-dispatch) - (list x1214 - (build-data92 + (list x3578 + (build-data2454 #f - p1222))))))))))))) - (build-dispatch-call1194 - (lambda (pvars1230 exp1231 y1232 r1233 mod1234) - (let ((ids1235 (map car pvars1230)) - (levels1236 (map cdr pvars1230))) - (let ((labels1237 (gen-labels120 ids1235)) - (new-vars1238 (map gen-var161 ids1235))) - (build-application81 + p3586))))))))))))) + (build-dispatch-call3558 + (lambda (pvars3594 exp3595 y3596 r3597 mod3598) + (let ((ids3599 (map car pvars3594)) + (levels3600 (map cdr pvars3594))) + (let ((labels3601 (gen-labels2482 ids3599)) + (new-vars3602 (map gen-var2523 ids3599))) + (build-application2443 #f - (build-primref91 #f (quote apply)) - (list (build-lambda90 + (build-primref2453 #f (quote apply)) + (list (build-lambda2452 #f - (map syntax->datum ids1235) - new-vars1238 + (map syntax->datum ids3599) + new-vars3602 #f - (chi150 - exp1231 - (extend-env108 - labels1237 - (map (lambda (var1239 level1240) + (chi2512 + exp3595 + (extend-env2470 + labels3601 + (map (lambda (var3603 level3604) (cons 'syntax - (cons var1239 level1240))) - new-vars1238 - (map cdr pvars1230)) - r1233) - (make-binding-wrap131 - ids1235 - labels1237 + (cons var3603 level3604))) + new-vars3602 + (map cdr pvars3594)) + r3597) + (make-binding-wrap2493 + ids3599 + labels3601 '(())) - mod1234)) - y1232)))))) - (convert-pattern1193 - (lambda (pattern1241 keys1242) - (letrec ((cvt1243 - (lambda (p1244 n1245 ids1246) - (if (id?114 p1244) - (if (bound-id-member?141 p1244 keys1242) + mod3598)) + y3596)))))) + (convert-pattern3557 + (lambda (pattern3605 keys3606) + (letrec ((cvt3607 + (lambda (p3608 n3609 ids3610) + (if (id?2476 p3608) + (if (bound-id-member?2503 p3608 keys3606) (values - (vector (quote free-id) p1244) - ids1246) + (vector (quote free-id) p3608) + ids3610) (values 'any - (cons (cons p1244 n1245) ids1246))) - ((lambda (tmp1247) - ((lambda (tmp1248) - (if (if tmp1248 - (apply (lambda (x1249 dots1250) - (ellipsis?159 - dots1250)) - tmp1248) + (cons (cons p3608 n3609) ids3610))) + ((lambda (tmp3611) + ((lambda (tmp3612) + (if (if tmp3612 + (apply (lambda (x3613 dots3614) + (ellipsis?2521 + dots3614)) + tmp3612) #f) - (apply (lambda (x1251 dots1252) + (apply (lambda (x3615 dots3616) (call-with-values (lambda () - (cvt1243 - x1251 - (fx+72 n1245 1) - ids1246)) - (lambda (p1253 ids1254) + (cvt3607 + x3615 + (fx+2433 n3609 1) + ids3610)) + (lambda (p3617 ids3618) (values - (if (eq? p1253 + (if (eq? p3617 'any) 'each-any (vector 'each - p1253)) - ids1254)))) - tmp1248) - ((lambda (tmp1255) - (if tmp1255 - (apply (lambda (x1256 y1257) + p3617)) + ids3618)))) + tmp3612) + ((lambda (tmp3619) + (if tmp3619 + (apply (lambda (x3620 y3621) (call-with-values (lambda () - (cvt1243 - y1257 - n1245 - ids1246)) - (lambda (y1258 - ids1259) + (cvt3607 + y3621 + n3609 + ids3610)) + (lambda (y3622 + ids3623) (call-with-values (lambda () - (cvt1243 - x1256 - n1245 - ids1259)) - (lambda (x1260 - ids1261) + (cvt3607 + x3620 + n3609 + ids3623)) + (lambda (x3624 + ids3625) (values - (cons x1260 - y1258) - ids1261)))))) - tmp1255) - ((lambda (tmp1262) - (if tmp1262 + (cons x3624 + y3622) + ids3625)))))) + tmp3619) + ((lambda (tmp3626) + (if tmp3626 (apply (lambda () (values '() - ids1246)) - tmp1262) - ((lambda (tmp1263) - (if tmp1263 - (apply (lambda (x1264) + ids3610)) + tmp3626) + ((lambda (tmp3627) + (if tmp3627 + (apply (lambda (x3628) (call-with-values (lambda () - (cvt1243 - x1264 - n1245 - ids1246)) - (lambda (p1266 - ids1267) + (cvt3607 + x3628 + n3609 + ids3610)) + (lambda (p3630 + ids3631) (values (vector 'vector - p1266) - ids1267)))) - tmp1263) - ((lambda (x1268) + p3630) + ids3631)))) + tmp3627) + ((lambda (x3632) (values (vector 'atom - (strip160 - p1244 + (strip2522 + p3608 '(()))) - ids1246)) - tmp1247))) + ids3610)) + tmp3611))) ($sc-dispatch - tmp1247 + tmp3611 '#(vector each-any))))) ($sc-dispatch - tmp1247 + tmp3611 '())))) ($sc-dispatch - tmp1247 + tmp3611 '(any . any))))) ($sc-dispatch - tmp1247 + tmp3611 '(any any)))) - p1244))))) - (cvt1243 pattern1241 0 (quote ())))))) - (lambda (e1269 r1270 w1271 s1272 mod1273) - (let ((e1274 (source-wrap143 e1269 w1271 s1272 mod1273))) - ((lambda (tmp1275) - ((lambda (tmp1276) - (if tmp1276 - (apply (lambda (_1277 val1278 key1279 m1280) + p3608))))) + (cvt3607 pattern3605 0 (quote ())))))) + (lambda (e3633 r3634 w3635 s3636 mod3637) + (let ((e3638 (source-wrap2505 e3633 w3635 s3636 mod3637))) + ((lambda (tmp3639) + ((lambda (tmp3640) + (if tmp3640 + (apply (lambda (_3641 val3642 key3643 m3644) (if (and-map - (lambda (x1281) - (if (id?114 x1281) - (not (ellipsis?159 x1281)) + (lambda (x3645) + (if (id?2476 x3645) + (not (ellipsis?2521 x3645)) #f)) - key1279) - (let ((x1283 (gen-var161 (quote tmp)))) - (build-application81 - s1272 - (build-lambda90 + key3643) + (let ((x3647 (gen-var2523 (quote tmp)))) + (build-application2443 + s3636 + (build-lambda2452 #f (list (quote tmp)) - (list x1283) + (list x3647) #f - (gen-syntax-case1196 - (build-lexical-reference83 + (gen-syntax-case3560 + (build-lexical-reference2445 'value #f 'tmp - x1283) - key1279 - m1280 - r1270 - mod1273)) - (list (chi150 - val1278 - r1270 + x3647) + key3643 + m3644 + r3634 + mod3637)) + (list (chi2512 + val3642 + r3634 '(()) - mod1273)))) + mod3637)))) (syntax-violation 'syntax-case "invalid literals list" - e1274))) - tmp1276) + e3638))) + tmp3640) (syntax-violation #f "source expression failed to match any pattern" - tmp1275))) + tmp3639))) ($sc-dispatch - tmp1275 + tmp3639 '(any any each-any . each-any)))) - e1274))))) + e3638))))) (set! sc-expand - (lambda (x1287 . rest1286) - (if (if (pair? x1287) - (equal? (car x1287) noexpand70) + (lambda (x3651 . rest3650) + (if (if (pair? x3651) + (equal? (car x3651) noexpand2431) #f) - (cadr x1287) - (let ((m1288 (if (null? rest1286) (quote e) (car rest1286))) - (esew1289 - (if (let ((t1290 (null? rest1286))) - (if t1290 t1290 (null? (cdr rest1286)))) + (cadr x3651) + (let ((m3652 (if (null? rest3650) (quote e) (car rest3650))) + (esew3653 + (if (let ((t3654 (null? rest3650))) + (if t3654 t3654 (null? (cdr rest3650)))) '(eval) - (cadr rest1286)))) + (cadr rest3650)))) (with-fluid* - *mode*71 - m1288 + *mode*2432 + m3652 (lambda () - (chi-top149 - x1287 + (chi-top2511 + x3651 '() '((top)) - m1288 - esew1289 + m3652 + esew3653 (cons 'hygiene (module-name (current-module)))))))))) (set! identifier? - (lambda (x1291) (nonsymbol-id?113 x1291))) + (lambda (x3655) (nonsymbol-id?2475 x3655))) (set! datum->syntax - (lambda (id1292 datum1293) - (make-syntax-object97 - datum1293 - (syntax-object-wrap100 id1292) + (lambda (id3656 datum3657) + (make-syntax-object2459 + datum3657 + (syntax-object-wrap2462 id3656) #f))) (set! syntax->datum - (lambda (x1294) (strip160 x1294 (quote (()))))) + (lambda (x3658) (strip2522 x3658 (quote (()))))) (set! generate-temporaries - (lambda (ls1295) + (lambda (ls3659) (begin - (let ((x1296 ls1295)) - (if (not (list? x1296)) + (let ((x3660 ls3659)) + (if (not (list? x3660)) (syntax-violation 'generate-temporaries "invalid argument" - x1296))) - (map (lambda (x1297) - (wrap142 (gensym) (quote ((top))) #f)) - ls1295)))) + x3660))) + (map (lambda (x3661) + (wrap2504 (gensym) (quote ((top))) #f)) + ls3659)))) (set! free-identifier=? - (lambda (x1298 y1299) + (lambda (x3662 y3663) (begin - (let ((x1300 x1298)) - (if (not (nonsymbol-id?113 x1300)) + (let ((x3664 x3662)) + (if (not (nonsymbol-id?2475 x3664)) (syntax-violation 'free-identifier=? "invalid argument" - x1300))) - (let ((x1301 y1299)) - (if (not (nonsymbol-id?113 x1301)) + x3664))) + (let ((x3665 y3663)) + (if (not (nonsymbol-id?2475 x3665)) (syntax-violation 'free-identifier=? "invalid argument" - x1301))) - (free-id=?137 x1298 y1299)))) + x3665))) + (free-id=?2499 x3662 y3663)))) (set! bound-identifier=? - (lambda (x1302 y1303) + (lambda (x3666 y3667) (begin - (let ((x1304 x1302)) - (if (not (nonsymbol-id?113 x1304)) + (let ((x3668 x3666)) + (if (not (nonsymbol-id?2475 x3668)) (syntax-violation 'bound-identifier=? "invalid argument" - x1304))) - (let ((x1305 y1303)) - (if (not (nonsymbol-id?113 x1305)) + x3668))) + (let ((x3669 y3667)) + (if (not (nonsymbol-id?2475 x3669)) (syntax-violation 'bound-identifier=? "invalid argument" - x1305))) - (bound-id=?138 x1302 y1303)))) + x3669))) + (bound-id=?2500 x3666 y3667)))) (set! syntax-violation - (lambda (who1309 message1308 form1307 . subform1306) + (lambda (who3673 message3672 form3671 . subform3670) (begin - (let ((x1310 who1309)) - (if (not ((lambda (x1311) - (let ((t1312 (not x1311))) - (if t1312 - t1312 - (let ((t1313 (string? x1311))) - (if t1313 t1313 (symbol? x1311)))))) - x1310)) + (let ((x3674 who3673)) + (if (not ((lambda (x3675) + (let ((t3676 (not x3675))) + (if t3676 + t3676 + (let ((t3677 (string? x3675))) + (if t3677 t3677 (symbol? x3675)))))) + x3674)) (syntax-violation 'syntax-violation "invalid argument" - x1310))) - (let ((x1314 message1308)) - (if (not (string? x1314)) + x3674))) + (let ((x3678 message3672)) + (if (not (string? x3678)) (syntax-violation 'syntax-violation "invalid argument" - x1314))) + x3678))) (scm-error 'syntax-error 'sc-expand (string-append - (if who1309 "~a: " "") + (if who3673 "~a: " "") "~a " - (if (null? subform1306) + (if (null? subform3670) "in ~a" "in subform `~s' of `~s'")) - (let ((tail1315 - (cons message1308 - (map (lambda (x1316) (strip160 x1316 (quote (())))) - (append subform1306 (list form1307)))))) - (if who1309 (cons who1309 tail1315) tail1315)) + (let ((tail3679 + (cons message3672 + (map (lambda (x3680) + (strip2522 x3680 (quote (())))) + (append subform3670 (list form3671)))))) + (if who3673 (cons who3673 tail3679) tail3679)) #f)))) - (letrec ((match1321 - (lambda (e1322 p1323 w1324 r1325 mod1326) - (if (not r1325) + (letrec ((match3685 + (lambda (e3686 p3687 w3688 r3689 mod3690) + (if (not r3689) #f - (if (eq? p1323 (quote any)) - (cons (wrap142 e1322 w1324 mod1326) r1325) - (if (syntax-object?98 e1322) - (match*1320 - (syntax-object-expression99 e1322) - p1323 - (join-wraps133 - w1324 - (syntax-object-wrap100 e1322)) - r1325 - (syntax-object-module101 e1322)) - (match*1320 e1322 p1323 w1324 r1325 mod1326)))))) - (match*1320 - (lambda (e1327 p1328 w1329 r1330 mod1331) - (if (null? p1328) - (if (null? e1327) r1330 #f) - (if (pair? p1328) - (if (pair? e1327) - (match1321 - (car e1327) - (car p1328) - w1329 - (match1321 - (cdr e1327) - (cdr p1328) - w1329 - r1330 - mod1331) - mod1331) + (if (eq? p3687 (quote any)) + (cons (wrap2504 e3686 w3688 mod3690) r3689) + (if (syntax-object?2460 e3686) + (match*3684 + (syntax-object-expression2461 e3686) + p3687 + (join-wraps2495 + w3688 + (syntax-object-wrap2462 e3686)) + r3689 + (syntax-object-module2463 e3686)) + (match*3684 e3686 p3687 w3688 r3689 mod3690)))))) + (match*3684 + (lambda (e3691 p3692 w3693 r3694 mod3695) + (if (null? p3692) + (if (null? e3691) r3694 #f) + (if (pair? p3692) + (if (pair? e3691) + (match3685 + (car e3691) + (car p3692) + w3693 + (match3685 + (cdr e3691) + (cdr p3692) + w3693 + r3694 + mod3695) + mod3695) #f) - (if (eq? p1328 (quote each-any)) - (let ((l1332 (match-each-any1318 - e1327 - w1329 - mod1331))) - (if l1332 (cons l1332 r1330) #f)) - (let ((atom-key1333 (vector-ref p1328 0))) - (if (memv atom-key1333 (quote (each))) - (if (null? e1327) - (match-empty1319 (vector-ref p1328 1) r1330) - (let ((l1334 (match-each1317 - e1327 - (vector-ref p1328 1) - w1329 - mod1331))) - (if l1334 - (letrec ((collect1335 - (lambda (l1336) - (if (null? (car l1336)) - r1330 - (cons (map car l1336) - (collect1335 - (map cdr l1336))))))) - (collect1335 l1334)) + (if (eq? p3692 (quote each-any)) + (let ((l3696 (match-each-any3682 + e3691 + w3693 + mod3695))) + (if l3696 (cons l3696 r3694) #f)) + (let ((atom-key3697 (vector-ref p3692 0))) + (if (memv atom-key3697 (quote (each))) + (if (null? e3691) + (match-empty3683 (vector-ref p3692 1) r3694) + (let ((l3698 (match-each3681 + e3691 + (vector-ref p3692 1) + w3693 + mod3695))) + (if l3698 + (letrec ((collect3699 + (lambda (l3700) + (if (null? (car l3700)) + r3694 + (cons (map car l3700) + (collect3699 + (map cdr l3700))))))) + (collect3699 l3698)) #f))) - (if (memv atom-key1333 (quote (free-id))) - (if (id?114 e1327) - (if (free-id=?137 - (wrap142 e1327 w1329 mod1331) - (vector-ref p1328 1)) - r1330 + (if (memv atom-key3697 (quote (free-id))) + (if (id?2476 e3691) + (if (free-id=?2499 + (wrap2504 e3691 w3693 mod3695) + (vector-ref p3692 1)) + r3694 #f) #f) - (if (memv atom-key1333 (quote (atom))) + (if (memv atom-key3697 (quote (atom))) (if (equal? - (vector-ref p1328 1) - (strip160 e1327 w1329)) - r1330 + (vector-ref p3692 1) + (strip2522 e3691 w3693)) + r3694 #f) - (if (memv atom-key1333 (quote (vector))) - (if (vector? e1327) - (match1321 - (vector->list e1327) - (vector-ref p1328 1) - w1329 - r1330 - mod1331) + (if (memv atom-key3697 (quote (vector))) + (if (vector? e3691) + (match3685 + (vector->list e3691) + (vector-ref p3692 1) + w3693 + r3694 + mod3695) #f))))))))))) - (match-empty1319 - (lambda (p1337 r1338) - (if (null? p1337) - r1338 - (if (eq? p1337 (quote any)) - (cons (quote ()) r1338) - (if (pair? p1337) - (match-empty1319 - (car p1337) - (match-empty1319 (cdr p1337) r1338)) - (if (eq? p1337 (quote each-any)) - (cons (quote ()) r1338) - (let ((atom-key1339 (vector-ref p1337 0))) - (if (memv atom-key1339 (quote (each))) - (match-empty1319 (vector-ref p1337 1) r1338) - (if (memv atom-key1339 (quote (free-id atom))) - r1338 - (if (memv atom-key1339 (quote (vector))) - (match-empty1319 - (vector-ref p1337 1) - r1338))))))))))) - (match-each-any1318 - (lambda (e1340 w1341 mod1342) - (if (pair? e1340) - (let ((l1343 (match-each-any1318 - (cdr e1340) - w1341 - mod1342))) - (if l1343 - (cons (wrap142 (car e1340) w1341 mod1342) l1343) + (match-empty3683 + (lambda (p3701 r3702) + (if (null? p3701) + r3702 + (if (eq? p3701 (quote any)) + (cons (quote ()) r3702) + (if (pair? p3701) + (match-empty3683 + (car p3701) + (match-empty3683 (cdr p3701) r3702)) + (if (eq? p3701 (quote each-any)) + (cons (quote ()) r3702) + (let ((atom-key3703 (vector-ref p3701 0))) + (if (memv atom-key3703 (quote (each))) + (match-empty3683 (vector-ref p3701 1) r3702) + (if (memv atom-key3703 (quote (free-id atom))) + r3702 + (if (memv atom-key3703 (quote (vector))) + (match-empty3683 + (vector-ref p3701 1) + r3702))))))))))) + (match-each-any3682 + (lambda (e3704 w3705 mod3706) + (if (pair? e3704) + (let ((l3707 (match-each-any3682 + (cdr e3704) + w3705 + mod3706))) + (if l3707 + (cons (wrap2504 (car e3704) w3705 mod3706) l3707) #f)) - (if (null? e1340) + (if (null? e3704) '() - (if (syntax-object?98 e1340) - (match-each-any1318 - (syntax-object-expression99 e1340) - (join-wraps133 - w1341 - (syntax-object-wrap100 e1340)) - mod1342) + (if (syntax-object?2460 e3704) + (match-each-any3682 + (syntax-object-expression2461 e3704) + (join-wraps2495 + w3705 + (syntax-object-wrap2462 e3704)) + mod3706) #f))))) - (match-each1317 - (lambda (e1344 p1345 w1346 mod1347) - (if (pair? e1344) - (let ((first1348 - (match1321 - (car e1344) - p1345 - w1346 + (match-each3681 + (lambda (e3708 p3709 w3710 mod3711) + (if (pair? e3708) + (let ((first3712 + (match3685 + (car e3708) + p3709 + w3710 '() - mod1347))) - (if first1348 - (let ((rest1349 - (match-each1317 - (cdr e1344) - p1345 - w1346 - mod1347))) - (if rest1349 (cons first1348 rest1349) #f)) + mod3711))) + (if first3712 + (let ((rest3713 + (match-each3681 + (cdr e3708) + p3709 + w3710 + mod3711))) + (if rest3713 (cons first3712 rest3713) #f)) #f)) - (if (null? e1344) + (if (null? e3708) '() - (if (syntax-object?98 e1344) - (match-each1317 - (syntax-object-expression99 e1344) - p1345 - (join-wraps133 - w1346 - (syntax-object-wrap100 e1344)) - (syntax-object-module101 e1344)) + (if (syntax-object?2460 e3708) + (match-each3681 + (syntax-object-expression2461 e3708) + p3709 + (join-wraps2495 + w3710 + (syntax-object-wrap2462 e3708)) + (syntax-object-module2463 e3708)) #f)))))) (set! $sc-dispatch - (lambda (e1350 p1351) - (if (eq? p1351 (quote any)) - (list e1350) - (if (syntax-object?98 e1350) - (match*1320 - (syntax-object-expression99 e1350) - p1351 - (syntax-object-wrap100 e1350) + (lambda (e3714 p3715) + (if (eq? p3715 (quote any)) + (list e3714) + (if (syntax-object?2460 e3714) + (match*3684 + (syntax-object-expression2461 e3714) + p3715 + (syntax-object-wrap2462 e3714) '() - (syntax-object-module101 e1350)) - (match*1320 - e1350 - p1351 + (syntax-object-module2463 e3714)) + (match*3684 + e3714 + p3715 '(()) '() #f))))))))) @@ -8264,11 +8497,11 @@ (define with-syntax (make-syncase-macro 'macro - (lambda (x1352) - ((lambda (tmp1353) - ((lambda (tmp1354) - (if tmp1354 - (apply (lambda (_1355 e11356 e21357) + (lambda (x3716) + ((lambda (tmp3717) + ((lambda (tmp3718) + (if tmp3718 + (apply (lambda (_3719 e13720 e23721) (cons '#(syntax-object begin ((top) @@ -8279,11 +8512,11 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - (cons e11356 e21357))) - tmp1354) - ((lambda (tmp1359) - (if tmp1359 - (apply (lambda (_1360 out1361 in1362 e11363 e21364) + (cons e13720 e23721))) + tmp3718) + ((lambda (tmp3723) + (if tmp3723 + (apply (lambda (_3724 out3725 in3726 e13727 e23728) (list '#(syntax-object syntax-case ((top) @@ -8294,9 +8527,9 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - in1362 + in3726 '() - (list out1361 + (list out3725 (cons '#(syntax-object begin ((top) @@ -8314,11 +8547,11 @@ #((top)) #("i"))) (hygiene guile)) - (cons e11363 e21364))))) - tmp1359) - ((lambda (tmp1366) - (if tmp1366 - (apply (lambda (_1367 out1368 in1369 e11370 e21371) + (cons e13727 e23728))))) + tmp3723) + ((lambda (tmp3730) + (if tmp3730 + (apply (lambda (_3731 out3732 in3733 e13734 e23735) (list '#(syntax-object syntax-case ((top) @@ -8346,9 +8579,9 @@ #((top)) #("i"))) (hygiene guile)) - in1369) + in3733) '() - (list out1368 + (list out3732 (cons '#(syntax-object begin ((top) @@ -8370,35 +8603,35 @@ #((top)) #("i"))) (hygiene guile)) - (cons e11370 e21371))))) - tmp1366) + (cons e13734 e23735))))) + tmp3730) (syntax-violation #f "source expression failed to match any pattern" - tmp1353))) + tmp3717))) ($sc-dispatch - tmp1353 + tmp3717 '(any #(each (any any)) any . each-any))))) ($sc-dispatch - tmp1353 + tmp3717 '(any ((any any)) any . each-any))))) ($sc-dispatch - tmp1353 + tmp3717 '(any () any . each-any)))) - x1352)))) + x3716)))) (define syntax-rules (make-syncase-macro 'macro - (lambda (x1375) - ((lambda (tmp1376) - ((lambda (tmp1377) - (if tmp1377 - (apply (lambda (_1378 - k1379 - keyword1380 - pattern1381 - template1382) + (lambda (x3739) + ((lambda (tmp3740) + ((lambda (tmp3741) + (if tmp3741 + (apply (lambda (_3742 + k3743 + keyword3744 + pattern3745 + template3746) (list '#(syntax-object lambda ((top) @@ -8439,8 +8672,8 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - (cons k1379 - (map (lambda (tmp1385 tmp1384) + (cons k3743 + (map (lambda (tmp3749 tmp3748) (list (cons '#(syntax-object dummy ((top) @@ -8470,7 +8703,7 @@ #("i"))) (hygiene guile)) - tmp1384) + tmp3748) (list '#(syntax-object syntax ((top) @@ -8500,34 +8733,34 @@ #("i"))) (hygiene guile)) - tmp1385))) - template1382 - pattern1381)))))) - tmp1377) + tmp3749))) + template3746 + pattern3745)))))) + tmp3741) (syntax-violation #f "source expression failed to match any pattern" - tmp1376))) + tmp3740))) ($sc-dispatch - tmp1376 + tmp3740 '(any each-any . #(each ((any . any) any)))))) - x1375)))) + x3739)))) (define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) 'macro - (lambda (x1386) - ((lambda (tmp1387) - ((lambda (tmp1388) - (if (if tmp1388 - (apply (lambda (let*1389 x1390 v1391 e11392 e21393) - (and-map identifier? x1390)) - tmp1388) + (lambda (x3750) + ((lambda (tmp3751) + ((lambda (tmp3752) + (if (if tmp3752 + (apply (lambda (let*3753 x3754 v3755 e13756 e23757) + (and-map identifier? x3754)) + tmp3752) #f) - (apply (lambda (let*1395 x1396 v1397 e11398 e21399) - (letrec ((f1400 (lambda (bindings1401) - (if (null? bindings1401) + (apply (lambda (let*3759 x3760 v3761 e13762 e23763) + (letrec ((f3764 (lambda (bindings3765) + (if (null? bindings3765) (cons '#(syntax-object let ((top) @@ -8551,12 +8784,12 @@ #("i"))) (hygiene guile)) (cons '() - (cons e11398 e21399))) - ((lambda (tmp1405) - ((lambda (tmp1406) - (if tmp1406 - (apply (lambda (body1407 - binding1408) + (cons e13762 e23763))) + ((lambda (tmp3769) + ((lambda (tmp3770) + (if tmp3770 + (apply (lambda (body3771 + binding3772) (list '#(syntax-object let ((top) @@ -8604,51 +8837,51 @@ #("i"))) (hygiene guile)) - (list binding1408) - body1407)) - tmp1406) + (list binding3772) + body3771)) + tmp3770) (syntax-violation #f "source expression failed to match any pattern" - tmp1405))) + tmp3769))) ($sc-dispatch - tmp1405 + tmp3769 '(any any)))) - (list (f1400 (cdr bindings1401)) - (car bindings1401))))))) - (f1400 (map list x1396 v1397)))) - tmp1388) + (list (f3764 (cdr bindings3765)) + (car bindings3765))))))) + (f3764 (map list x3760 v3761)))) + tmp3752) (syntax-violation #f "source expression failed to match any pattern" - tmp1387))) + tmp3751))) ($sc-dispatch - tmp1387 + tmp3751 '(any #(each (any any)) any . each-any)))) - x1386)))) + x3750)))) (define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) 'macro - (lambda (orig-x1409) - ((lambda (tmp1410) - ((lambda (tmp1411) - (if tmp1411 - (apply (lambda (_1412 - var1413 - init1414 - step1415 - e01416 - e11417 - c1418) - ((lambda (tmp1419) - ((lambda (tmp1420) - (if tmp1420 - (apply (lambda (step1421) - ((lambda (tmp1422) - ((lambda (tmp1423) - (if tmp1423 + (lambda (orig-x3773) + ((lambda (tmp3774) + ((lambda (tmp3775) + (if tmp3775 + (apply (lambda (_3776 + var3777 + init3778 + step3779 + e03780 + e13781 + c3782) + ((lambda (tmp3783) + ((lambda (tmp3784) + (if tmp3784 + (apply (lambda (step3785) + ((lambda (tmp3786) + ((lambda (tmp3787) + (if tmp3787 (apply (lambda () (list '#(syntax-object let @@ -8729,8 +8962,8 @@ (hygiene guile)) (map list - var1413 - init1414) + var3777 + init3778) (list '#(syntax-object if ((top) @@ -8809,7 +9042,7 @@ #("i"))) (hygiene guile)) - e01416) + e03780) (cons '#(syntax-object begin ((top) @@ -8850,7 +9083,7 @@ (hygiene guile)) (append - c1418 + c3782 (list (cons '#(syntax-object doloop ((top) @@ -8890,12 +9123,12 @@ #("i"))) (hygiene guile)) - step1421))))))) - tmp1423) - ((lambda (tmp1428) - (if tmp1428 - (apply (lambda (e11429 - e21430) + step3785))))))) + tmp3787) + ((lambda (tmp3792) + (if tmp3792 + (apply (lambda (e13793 + e23794) (list '#(syntax-object let ((top) @@ -8989,8 +9222,8 @@ (hygiene guile)) (map list - var1413 - init1414) + var3777 + init3778) (list '#(syntax-object if ((top) @@ -9037,7 +9270,7 @@ #("i"))) (hygiene guile)) - e01416 + e03780 (cons '#(syntax-object begin ((top) @@ -9084,8 +9317,8 @@ #("i"))) (hygiene guile)) - (cons e11429 - e21430)) + (cons e13793 + e23794)) (cons '#(syntax-object begin ((top) @@ -9133,7 +9366,7 @@ (hygiene guile)) (append - c1418 + c3782 (list (cons '#(syntax-object doloop ((top) @@ -9180,75 +9413,75 @@ #("i"))) (hygiene guile)) - step1421))))))) - tmp1428) + step3785))))))) + tmp3792) (syntax-violation #f "source expression failed to match any pattern" - tmp1422))) + tmp3786))) ($sc-dispatch - tmp1422 + tmp3786 '(any . each-any))))) - ($sc-dispatch tmp1422 (quote ())))) - e11417)) - tmp1420) + ($sc-dispatch tmp3786 (quote ())))) + e13781)) + tmp3784) (syntax-violation #f "source expression failed to match any pattern" - tmp1419))) - ($sc-dispatch tmp1419 (quote each-any)))) - (map (lambda (v1437 s1438) - ((lambda (tmp1439) - ((lambda (tmp1440) - (if tmp1440 - (apply (lambda () v1437) tmp1440) - ((lambda (tmp1441) - (if tmp1441 - (apply (lambda (e1442) e1442) - tmp1441) - ((lambda (_1443) + tmp3783))) + ($sc-dispatch tmp3783 (quote each-any)))) + (map (lambda (v3801 s3802) + ((lambda (tmp3803) + ((lambda (tmp3804) + (if tmp3804 + (apply (lambda () v3801) tmp3804) + ((lambda (tmp3805) + (if tmp3805 + (apply (lambda (e3806) e3806) + tmp3805) + ((lambda (_3807) (syntax-violation 'do "bad step expression" - orig-x1409 - s1438)) - tmp1439))) - ($sc-dispatch tmp1439 (quote (any)))))) - ($sc-dispatch tmp1439 (quote ())))) - s1438)) - var1413 - step1415))) - tmp1411) + orig-x3773 + s3802)) + tmp3803))) + ($sc-dispatch tmp3803 (quote (any)))))) + ($sc-dispatch tmp3803 (quote ())))) + s3802)) + var3777 + step3779))) + tmp3775) (syntax-violation #f "source expression failed to match any pattern" - tmp1410))) + tmp3774))) ($sc-dispatch - tmp1410 + tmp3774 '(any #(each (any any . any)) (any . each-any) . each-any)))) - orig-x1409)))) + orig-x3773)))) (define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) 'macro - (letrec ((quasicons1446 - (lambda (x1450 y1451) - ((lambda (tmp1452) - ((lambda (tmp1453) - (if tmp1453 - (apply (lambda (x1454 y1455) - ((lambda (tmp1456) - ((lambda (tmp1457) - (if tmp1457 - (apply (lambda (dy1458) - ((lambda (tmp1459) - ((lambda (tmp1460) - (if tmp1460 - (apply (lambda (dx1461) + (letrec ((quasicons3810 + (lambda (x3814 y3815) + ((lambda (tmp3816) + ((lambda (tmp3817) + (if tmp3817 + (apply (lambda (x3818 y3819) + ((lambda (tmp3820) + ((lambda (tmp3821) + (if tmp3821 + (apply (lambda (dy3822) + ((lambda (tmp3823) + ((lambda (tmp3824) + (if tmp3824 + (apply (lambda (dx3825) (list '#(syntax-object quote ((top) @@ -9297,11 +9530,11 @@ "i"))) (hygiene guile)) - (cons dx1461 - dy1458))) - tmp1460) - ((lambda (_1462) - (if (null? dy1458) + (cons dx3825 + dy3822))) + tmp3824) + ((lambda (_3826) + (if (null? dy3822) (list '#(syntax-object list ((top) @@ -9350,7 +9583,7 @@ "i"))) (hygiene guile)) - x1454) + x3818) (list '#(syntax-object cons ((top) @@ -9399,11 +9632,11 @@ "i"))) (hygiene guile)) - x1454 - y1455))) - tmp1459))) + x3818 + y3819))) + tmp3823))) ($sc-dispatch - tmp1459 + tmp3823 '(#(free-id #(syntax-object quote @@ -9446,11 +9679,11 @@ (hygiene guile))) any)))) - x1454)) - tmp1457) - ((lambda (tmp1463) - (if tmp1463 - (apply (lambda (stuff1464) + x3818)) + tmp3821) + ((lambda (tmp3827) + (if tmp3827 + (apply (lambda (stuff3828) (cons '#(syntax-object list ((top) @@ -9491,10 +9724,10 @@ "i"))) (hygiene guile)) - (cons x1454 - stuff1464))) - tmp1463) - ((lambda (else1465) + (cons x3818 + stuff3828))) + tmp3827) + ((lambda (else3829) (list '#(syntax-object cons ((top) @@ -9526,11 +9759,11 @@ "i" "i"))) (hygiene guile)) - x1454 - y1455)) - tmp1456))) + x3818 + y3819)) + tmp3820))) ($sc-dispatch - tmp1456 + tmp3820 '(#(free-id #(syntax-object list @@ -9559,7 +9792,7 @@ . any))))) ($sc-dispatch - tmp1456 + tmp3820 '(#(free-id #(syntax-object quote @@ -9583,25 +9816,25 @@ #("i" "i" "i" "i"))) (hygiene guile))) any)))) - y1455)) - tmp1453) + y3819)) + tmp3817) (syntax-violation #f "source expression failed to match any pattern" - tmp1452))) - ($sc-dispatch tmp1452 (quote (any any))))) - (list x1450 y1451)))) - (quasiappend1447 - (lambda (x1466 y1467) - ((lambda (tmp1468) - ((lambda (tmp1469) - (if tmp1469 - (apply (lambda (x1470 y1471) - ((lambda (tmp1472) - ((lambda (tmp1473) - (if tmp1473 - (apply (lambda () x1470) tmp1473) - ((lambda (_1474) + tmp3816))) + ($sc-dispatch tmp3816 (quote (any any))))) + (list x3814 y3815)))) + (quasiappend3811 + (lambda (x3830 y3831) + ((lambda (tmp3832) + ((lambda (tmp3833) + (if tmp3833 + (apply (lambda (x3834 y3835) + ((lambda (tmp3836) + ((lambda (tmp3837) + (if tmp3837 + (apply (lambda () x3834) tmp3837) + ((lambda (_3838) (list '#(syntax-object append ((top) @@ -9630,11 +9863,11 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x1470 - y1471)) - tmp1472))) + x3834 + y3835)) + tmp3836))) ($sc-dispatch - tmp1472 + tmp3836 '(#(free-id #(syntax-object quote @@ -9658,22 +9891,22 @@ #("i" "i" "i" "i"))) (hygiene guile))) ())))) - y1471)) - tmp1469) + y3835)) + tmp3833) (syntax-violation #f "source expression failed to match any pattern" - tmp1468))) - ($sc-dispatch tmp1468 (quote (any any))))) - (list x1466 y1467)))) - (quasivector1448 - (lambda (x1475) - ((lambda (tmp1476) - ((lambda (x1477) - ((lambda (tmp1478) - ((lambda (tmp1479) - (if tmp1479 - (apply (lambda (x1480) + tmp3832))) + ($sc-dispatch tmp3832 (quote (any any))))) + (list x3830 y3831)))) + (quasivector3812 + (lambda (x3839) + ((lambda (tmp3840) + ((lambda (x3841) + ((lambda (tmp3842) + ((lambda (tmp3843) + (if tmp3843 + (apply (lambda (x3844) (list '#(syntax-object quote ((top) @@ -9699,11 +9932,11 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - (list->vector x1480))) - tmp1479) - ((lambda (tmp1482) - (if tmp1482 - (apply (lambda (x1483) + (list->vector x3844))) + tmp3843) + ((lambda (tmp3846) + (if tmp3846 + (apply (lambda (x3847) (cons '#(syntax-object vector ((top) @@ -9732,9 +9965,9 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x1483)) - tmp1482) - ((lambda (_1485) + x3847)) + tmp3846) + ((lambda (_3849) (list '#(syntax-object list->vector ((top) @@ -9760,10 +9993,10 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x1477)) - tmp1478))) + x3841)) + tmp3842))) ($sc-dispatch - tmp1478 + tmp3842 '(#(free-id #(syntax-object list @@ -9783,7 +10016,7 @@ . each-any))))) ($sc-dispatch - tmp1478 + tmp3842 '(#(free-id #(syntax-object quote @@ -9801,18 +10034,18 @@ #("i" "i" "i" "i"))) (hygiene guile))) each-any)))) - x1477)) - tmp1476)) - x1475))) - (quasi1449 - (lambda (p1486 lev1487) - ((lambda (tmp1488) - ((lambda (tmp1489) - (if tmp1489 - (apply (lambda (p1490) - (if (= lev1487 0) - p1490 - (quasicons1446 + x3841)) + tmp3840)) + x3839))) + (quasi3813 + (lambda (p3850 lev3851) + ((lambda (tmp3852) + ((lambda (tmp3853) + (if tmp3853 + (apply (lambda (p3854) + (if (= lev3851 0) + p3854 + (quasicons3810 '(#(syntax-object quote ((top) @@ -9847,18 +10080,18 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) - (quasi1449 (list p1490) (- lev1487 1))))) - tmp1489) - ((lambda (tmp1491) - (if (if tmp1491 - (apply (lambda (args1492) (= lev1487 0)) - tmp1491) + (quasi3813 (list p3854) (- lev3851 1))))) + tmp3853) + ((lambda (tmp3855) + (if (if tmp3855 + (apply (lambda (args3856) (= lev3851 0)) + tmp3855) #f) - (apply (lambda (args1493) + (apply (lambda (args3857) (syntax-violation 'unquote "unquote takes exactly one argument" - p1486 + p3850 (cons '#(syntax-object unquote ((top) @@ -9879,17 +10112,17 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - args1493))) - tmp1491) - ((lambda (tmp1494) - (if tmp1494 - (apply (lambda (p1495 q1496) - (if (= lev1487 0) - (quasiappend1447 - p1495 - (quasi1449 q1496 lev1487)) - (quasicons1446 - (quasicons1446 + args3857))) + tmp3855) + ((lambda (tmp3858) + (if tmp3858 + (apply (lambda (p3859 q3860) + (if (= lev3851 0) + (quasiappend3811 + p3859 + (quasi3813 q3860 lev3851)) + (quasicons3810 + (quasicons3810 '(#(syntax-object quote ((top) @@ -9936,22 +10169,22 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile))) - (quasi1449 - (list p1495) - (- lev1487 1))) - (quasi1449 q1496 lev1487)))) - tmp1494) - ((lambda (tmp1497) - (if (if tmp1497 - (apply (lambda (args1498 q1499) - (= lev1487 0)) - tmp1497) + (quasi3813 + (list p3859) + (- lev3851 1))) + (quasi3813 q3860 lev3851)))) + tmp3858) + ((lambda (tmp3861) + (if (if tmp3861 + (apply (lambda (args3862 q3863) + (= lev3851 0)) + tmp3861) #f) - (apply (lambda (args1500 q1501) + (apply (lambda (args3864 q3865) (syntax-violation 'unquote-splicing "unquote-splicing takes exactly one argument" - p1486 + p3850 (cons '#(syntax-object unquote-splicing ((top) @@ -9981,12 +10214,12 @@ "i" "i"))) (hygiene guile)) - args1500))) - tmp1497) - ((lambda (tmp1502) - (if tmp1502 - (apply (lambda (p1503) - (quasicons1446 + args3864))) + tmp3861) + ((lambda (tmp3866) + (if tmp3866 + (apply (lambda (p3867) + (quasicons3810 '(#(syntax-object quote ((top) @@ -10045,30 +10278,30 @@ "i" "i"))) (hygiene guile))) - (quasi1449 - (list p1503) - (+ lev1487 1)))) - tmp1502) - ((lambda (tmp1504) - (if tmp1504 - (apply (lambda (p1505 q1506) - (quasicons1446 - (quasi1449 - p1505 - lev1487) - (quasi1449 - q1506 - lev1487))) - tmp1504) - ((lambda (tmp1507) - (if tmp1507 - (apply (lambda (x1508) - (quasivector1448 - (quasi1449 - x1508 - lev1487))) - tmp1507) - ((lambda (p1510) + (quasi3813 + (list p3867) + (+ lev3851 1)))) + tmp3866) + ((lambda (tmp3868) + (if tmp3868 + (apply (lambda (p3869 q3870) + (quasicons3810 + (quasi3813 + p3869 + lev3851) + (quasi3813 + q3870 + lev3851))) + tmp3868) + ((lambda (tmp3871) + (if tmp3871 + (apply (lambda (x3872) + (quasivector3812 + (quasi3813 + x3872 + lev3851))) + tmp3871) + ((lambda (p3874) (list '#(syntax-object quote ((top) @@ -10101,16 +10334,16 @@ "i"))) (hygiene guile)) - p1510)) - tmp1488))) + p3874)) + tmp3852))) ($sc-dispatch - tmp1488 + tmp3852 '#(vector each-any))))) ($sc-dispatch - tmp1488 + tmp3852 '(any . any))))) ($sc-dispatch - tmp1488 + tmp3852 '(#(free-id #(syntax-object quasiquote @@ -10130,7 +10363,7 @@ (hygiene guile))) any))))) ($sc-dispatch - tmp1488 + tmp3852 '((#(free-id #(syntax-object unquote-splicing @@ -10153,7 +10386,7 @@ . any))))) ($sc-dispatch - tmp1488 + tmp3852 '((#(free-id #(syntax-object unquote-splicing @@ -10175,7 +10408,7 @@ . any))))) ($sc-dispatch - tmp1488 + tmp3852 '(#(free-id #(syntax-object unquote @@ -10193,7 +10426,7 @@ . any))))) ($sc-dispatch - tmp1488 + tmp3852 '(#(free-id #(syntax-object unquote @@ -10206,44 +10439,44 @@ #("i" "i" "i" "i"))) (hygiene guile))) any)))) - p1486)))) - (lambda (x1511) - ((lambda (tmp1512) - ((lambda (tmp1513) - (if tmp1513 - (apply (lambda (_1514 e1515) (quasi1449 e1515 0)) - tmp1513) + p3850)))) + (lambda (x3875) + ((lambda (tmp3876) + ((lambda (tmp3877) + (if tmp3877 + (apply (lambda (_3878 e3879) (quasi3813 e3879 0)) + tmp3877) (syntax-violation #f "source expression failed to match any pattern" - tmp1512))) - ($sc-dispatch tmp1512 (quote (any any))))) - x1511))))) + tmp3876))) + ($sc-dispatch tmp3876 (quote (any any))))) + x3875))))) (define include (make-syncase-macro 'macro - (lambda (x1516) - (letrec ((read-file1517 - (lambda (fn1518 k1519) - (let ((p1520 (open-input-file fn1518))) - (letrec ((f1521 (lambda (x1522) - (if (eof-object? x1522) + (lambda (x3880) + (letrec ((read-file3881 + (lambda (fn3882 k3883) + (let ((p3884 (open-input-file fn3882))) + (letrec ((f3885 (lambda (x3886) + (if (eof-object? x3886) (begin - (close-input-port p1520) + (close-input-port p3884) '()) - (cons (datum->syntax k1519 x1522) - (f1521 (read p1520))))))) - (f1521 (read p1520))))))) - ((lambda (tmp1523) - ((lambda (tmp1524) - (if tmp1524 - (apply (lambda (k1525 filename1526) - (let ((fn1527 (syntax->datum filename1526))) - ((lambda (tmp1528) - ((lambda (tmp1529) - (if tmp1529 - (apply (lambda (exp1530) + (cons (datum->syntax k3883 x3886) + (f3885 (read p3884))))))) + (f3885 (read p3884))))))) + ((lambda (tmp3887) + ((lambda (tmp3888) + (if tmp3888 + (apply (lambda (k3889 filename3890) + (let ((fn3891 (syntax->datum filename3890))) + ((lambda (tmp3892) + ((lambda (tmp3893) + (if tmp3893 + (apply (lambda (exp3894) (cons '#(syntax-object begin ((top) @@ -10270,73 +10503,73 @@ #((top)) #("i"))) (hygiene guile)) - exp1530)) - tmp1529) + exp3894)) + tmp3893) (syntax-violation #f "source expression failed to match any pattern" - tmp1528))) - ($sc-dispatch tmp1528 (quote each-any)))) - (read-file1517 fn1527 k1525)))) - tmp1524) + tmp3892))) + ($sc-dispatch tmp3892 (quote each-any)))) + (read-file3881 fn3891 k3889)))) + tmp3888) (syntax-violation #f "source expression failed to match any pattern" - tmp1523))) - ($sc-dispatch tmp1523 (quote (any any))))) - x1516))))) + tmp3887))) + ($sc-dispatch tmp3887 (quote (any any))))) + x3880))))) (define unquote (make-syncase-macro 'macro - (lambda (x1532) - ((lambda (tmp1533) - ((lambda (tmp1534) - (if tmp1534 - (apply (lambda (_1535 e1536) + (lambda (x3896) + ((lambda (tmp3897) + ((lambda (tmp3898) + (if tmp3898 + (apply (lambda (_3899 e3900) (syntax-violation 'unquote "expression not valid outside of quasiquote" - x1532)) - tmp1534) + x3896)) + tmp3898) (syntax-violation #f "source expression failed to match any pattern" - tmp1533))) - ($sc-dispatch tmp1533 (quote (any any))))) - x1532)))) + tmp3897))) + ($sc-dispatch tmp3897 (quote (any any))))) + x3896)))) (define unquote-splicing (make-syncase-macro 'macro - (lambda (x1537) - ((lambda (tmp1538) - ((lambda (tmp1539) - (if tmp1539 - (apply (lambda (_1540 e1541) + (lambda (x3901) + ((lambda (tmp3902) + ((lambda (tmp3903) + (if tmp3903 + (apply (lambda (_3904 e3905) (syntax-violation 'unquote-splicing "expression not valid outside of quasiquote" - x1537)) - tmp1539) + x3901)) + tmp3903) (syntax-violation #f "source expression failed to match any pattern" - tmp1538))) - ($sc-dispatch tmp1538 (quote (any any))))) - x1537)))) + tmp3902))) + ($sc-dispatch tmp3902 (quote (any any))))) + x3901)))) (define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) 'macro - (lambda (x1542) - ((lambda (tmp1543) - ((lambda (tmp1544) - (if tmp1544 - (apply (lambda (_1545 e1546 m11547 m21548) - ((lambda (tmp1549) - ((lambda (body1550) + (lambda (x3906) + ((lambda (tmp3907) + ((lambda (tmp3908) + (if tmp3908 + (apply (lambda (_3909 e3910 m13911 m23912) + ((lambda (tmp3913) + ((lambda (body3914) (list '#(syntax-object let ((top) @@ -10365,16 +10598,16 @@ #((top)) #("i"))) (hygiene guile)) - e1546)) - body1550)) - tmp1549)) - (letrec ((f1551 (lambda (clause1552 clauses1553) - (if (null? clauses1553) - ((lambda (tmp1555) - ((lambda (tmp1556) - (if tmp1556 - (apply (lambda (e11557 - e21558) + e3910)) + body3914)) + tmp3913)) + (letrec ((f3915 (lambda (clause3916 clauses3917) + (if (null? clauses3917) + ((lambda (tmp3919) + ((lambda (tmp3920) + (if tmp3920 + (apply (lambda (e13921 + e23922) (cons '#(syntax-object begin ((top) @@ -10422,14 +10655,14 @@ #("i"))) (hygiene guile)) - (cons e11557 - e21558))) - tmp1556) - ((lambda (tmp1560) - (if tmp1560 - (apply (lambda (k1561 - e11562 - e21563) + (cons e13921 + e23922))) + tmp3920) + ((lambda (tmp3924) + (if tmp3924 + (apply (lambda (k3925 + e13926 + e23927) (list '#(syntax-object if ((top) @@ -10630,7 +10863,7 @@ #("i"))) (hygiene guile)) - k1561)) + k3925)) (cons '#(syntax-object begin ((top) @@ -10681,24 +10914,24 @@ #("i"))) (hygiene guile)) - (cons e11562 - e21563)))) - tmp1560) - ((lambda (_1566) + (cons e13926 + e23927)))) + tmp3924) + ((lambda (_3930) (syntax-violation 'case "bad clause" - x1542 - clause1552)) - tmp1555))) + x3906 + clause3916)) + tmp3919))) ($sc-dispatch - tmp1555 + tmp3919 '(each-any any . each-any))))) ($sc-dispatch - tmp1555 + tmp3919 '(#(free-id #(syntax-object else @@ -10724,15 +10957,15 @@ any . each-any)))) - clause1552) - ((lambda (tmp1567) - ((lambda (rest1568) - ((lambda (tmp1569) - ((lambda (tmp1570) - (if tmp1570 - (apply (lambda (k1571 - e11572 - e21573) + clause3916) + ((lambda (tmp3931) + ((lambda (rest3932) + ((lambda (tmp3933) + ((lambda (tmp3934) + (if tmp3934 + (apply (lambda (k3935 + e13936 + e23937) (list '#(syntax-object if ((top) @@ -10949,7 +11182,7 @@ #("i"))) (hygiene guile)) - k1571)) + k3935)) (cons '#(syntax-object begin ((top) @@ -11004,46 +11237,46 @@ #("i"))) (hygiene guile)) - (cons e11572 - e21573)) - rest1568)) - tmp1570) - ((lambda (_1576) + (cons e13936 + e23937)) + rest3932)) + tmp3934) + ((lambda (_3940) (syntax-violation 'case "bad clause" - x1542 - clause1552)) - tmp1569))) + x3906 + clause3916)) + tmp3933))) ($sc-dispatch - tmp1569 + tmp3933 '(each-any any . each-any)))) - clause1552)) - tmp1567)) - (f1551 (car clauses1553) - (cdr clauses1553))))))) - (f1551 m11547 m21548)))) - tmp1544) + clause3916)) + tmp3931)) + (f3915 (car clauses3917) + (cdr clauses3917))))))) + (f3915 m13911 m23912)))) + tmp3908) (syntax-violation #f "source expression failed to match any pattern" - tmp1543))) + tmp3907))) ($sc-dispatch - tmp1543 + tmp3907 '(any any any . each-any)))) - x1542)))) + x3906)))) (define identifier-syntax (make-syncase-macro 'macro - (lambda (x1577) - ((lambda (tmp1578) - ((lambda (tmp1579) - (if tmp1579 - (apply (lambda (_1580 e1581) + (lambda (x3941) + ((lambda (tmp3942) + ((lambda (tmp3943) + (if tmp3943 + (apply (lambda (_3944 e3945) (list '#(syntax-object lambda ((top) @@ -11132,8 +11365,8 @@ #((top)) #("i"))) (hygiene guile)) - e1581)) - (list (cons _1580 + e3945)) + (list (cons _3944 '(#(syntax-object x ((top) @@ -11173,7 +11406,7 @@ #((top)) #("i"))) (hygiene guile)) - (cons e1581 + (cons e3945 '(#(syntax-object x ((top) @@ -11201,11 +11434,11 @@ #("i"))) (hygiene guile))))))))) - tmp1579) + tmp3943) (syntax-violation #f "source expression failed to match any pattern" - tmp1578))) - ($sc-dispatch tmp1578 (quote (any any))))) - x1577)))) + tmp3942))) + ($sc-dispatch tmp3942 (quote (any any))))) + x3941)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 5f5e86b0f..cbbcabd72 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -337,39 +337,46 @@ ) +(define (decorate-source e s) + (if (and (pair? e) s) + (set-source-properties! e s)) + e) + ;;; output constructors (define build-void (lambda (source) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-void) source)) - (else '(if #f #f))))) + (else (decorate-source '(if #f #f) source))))) (define build-application (lambda (source fun-exp arg-exps) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps)) - (else `(,fun-exp . ,arg-exps))))) + (else (decorate-source `(,fun-exp . ,arg-exps) source))))) (define build-conditional (lambda (source test-exp then-exp else-exp) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-conditional) source test-exp then-exp else-exp)) - (else (if (equal? else-exp '(if #f #f)) - `(if ,test-exp ,then-exp) - `(if ,test-exp ,then-exp ,else-exp)))))) + (else (decorate-source + (if (equal? else-exp '(if #f #f)) + `(if ,test-exp ,then-exp) + `(if ,test-exp ,then-exp ,else-exp)) + source))))) (define build-lexical-reference (lambda (type source name var) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-lexical-ref) source name var)) - (else var)))) + (else (decorate-source var source))))) (define build-lexical-assignment (lambda (source name var exp) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-lexical-set) source name var exp)) - (else `(set! ,var ,exp))))) + (else (decorate-source `(set! ,var ,exp) source))))) ;; Before modules are booted, we can't expand into data structures from ;; (language tree-il) -- we need to give the evaluator the @@ -403,11 +410,11 @@ (lambda (mod var public?) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-module-ref) source mod var public?)) - (else (list (if public? '@ '@@) mod var)))) + (else (decorate-source (list (if public? '@ '@@) mod var) source)))) (lambda (var) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-toplevel-ref) source var)) - (else var)))))) + (else (decorate-source var source))))))) (define build-global-assignment (lambda (source var exp mod) @@ -416,11 +423,11 @@ (lambda (mod var public?) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-module-set) source mod var public? exp)) - (else `(set! ,(list (if public? '@ '@@) mod var) ,exp)))) + (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source)))) (lambda (var) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-toplevel-set) source var exp)) - (else `(set! ,var ,exp))))))) + (else (decorate-source `(set! ,var ,exp) source))))))) ;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz) ;; from working. Hack around it. @@ -439,7 +446,7 @@ ((c) (maybe-name-value! var exp) ((@ (language tree-il) make-toplevel-define) source var exp)) - (else `(define ,var ,exp))))) + (else (decorate-source `(define ,var ,exp) source))))) (define build-lambda (lambda (src ids vars docstring exp) @@ -447,25 +454,29 @@ ((c) ((@ (language tree-il) make-lambda) src ids vars (if docstring `((documentation . ,docstring)) '()) exp)) - (else `(lambda ,vars ,@(if docstring (list docstring) '()) - ,exp))))) + (else (decorate-source + `(lambda ,vars ,@(if docstring (list docstring) '()) + ,exp) + src))))) (define build-primref (lambda (src name) (if (equal? (module-name (current-module)) '(guile)) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-toplevel-ref) src name)) - (else name)) + (else (decorate-source name src))) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f)) - (else `(@@ (guile) ,name)))))) + (else (decorate-source `(@@ (guile) ,name) src)))))) (define (build-data src exp) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-const) src exp)) - (else (if (and (self-evaluating? exp) (not (vector? exp))) - exp - (list 'quote exp))))) + (else (decorate-source + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp)) + src)))) (define build-sequence (lambda (src exps) @@ -473,7 +484,7 @@ (car exps) (case (fluid-ref *mode*) ((c) ((@ (language tree-il) make-sequence) src exps)) - (else `(begin ,@exps)))))) + (else (decorate-source `(begin ,@exps) src)))))) (define build-let (lambda (src ids vars val-exps body-exp) @@ -483,7 +494,9 @@ ((c) (for-each maybe-name-value! ids val-exps) ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) - (else `(let ,(map list vars val-exps) ,body-exp)))))) + (else (decorate-source + `(let ,(map list vars val-exps) ,body-exp) + src)))))) (define build-named-let (lambda (src ids vars val-exps body-exp) @@ -500,7 +513,9 @@ (list f-name) (list f) (list proc) (build-application src (build-lexical-reference 'fun src f-name f) val-exps)))) - (else `(let ,f ,(map list vars val-exps) ,body-exp)))))) + (else (decorate-source + `(let ,f ,(map list vars val-exps) ,body-exp) + src)))))) (define build-letrec (lambda (src ids vars val-exps body-exp) @@ -510,7 +525,9 @@ ((c) (for-each maybe-name-value! ids val-exps) ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) - (else `(letrec ,(map list vars val-exps) ,body-exp)))))) + (else (decorate-source + `(letrec ,(map list vars val-exps) ,body-exp) + src)))))) ;; FIXME: wingo: use make-lexical ? (define-syntax build-lexical-var From 74fdb02e5eaf31b4af337d8d101300493cc7f281 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 20 Jun 2009 11:41:50 +0200 Subject: [PATCH 239/375] better error in make_objcode_by_mmap * libguile/objcodes.c (make_objcode_by_mmap): Better error when the object header is incorrect. --- libguile/objcodes.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index f8da2d51d..6b69fb77f 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -66,7 +66,9 @@ make_objcode_by_mmap (int fd) SCM_SYSERROR; if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) - SCM_SYSERROR; + scm_misc_error (FUNC_NAME, "bad header on object file: ~s", + scm_list_1 (scm_from_locale_stringn + (addr, strlen (OBJCODE_COOKIE)))); data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE)); From 89cb70a0d5f365ebdfcc0257d6cab4a80a9f6a74 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 20 Jun 2009 12:41:11 +0200 Subject: [PATCH 240/375] fix source information lossage for (define (foo) ...) lambda sugar * module/ice-9/psyntax.scm (source-wrap): Use decorate-source, for clarity. (syntax-type): When turning the RHS of (define (foo) ...) into a lambda, decorate the resulting lambda expression with source information, as the RHS later goes to chi-expr, which receives no source information. Perhaps that is a bug. In any case, fixes some source location lossage, reported by Jao. * module/ice-9/psyntax-pp.scm: Regenerated. --- module/ice-9/psyntax-pp.scm | 8653 +++++++++++++++++------------------ module/ice-9/psyntax.scm | 8 +- 2 files changed, 4250 insertions(+), 4411 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index e2a3d60e3..113269b2e 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,97 +1,90 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*2378 - (lambda (f2418 first2417 . rest2416) - (let ((t2419 (null? first2417))) - (if t2419 - t2419 - (if (null? rest2416) - (letrec ((andmap2420 - (lambda (first2421) - (let ((x2422 (car first2421)) - (first2423 (cdr first2421))) - (if (null? first2423) - (f2418 x2422) - (if (f2418 x2422) - (andmap2420 first2423) +(letrec ((and-map*17 + (lambda (f57 first56 . rest55) + (let ((t58 (null? first56))) + (if t58 + t58 + (if (null? rest55) + (letrec ((andmap59 + (lambda (first60) + (let ((x61 (car first60)) + (first62 (cdr first60))) + (if (null? first62) + (f57 x61) + (if (f57 x61) (andmap59 first62) #f)))))) + (andmap59 first56)) + (letrec ((andmap63 + (lambda (first64 rest65) + (let ((x66 (car first64)) + (xr67 (map car rest65)) + (first68 (cdr first64)) + (rest69 (map cdr rest65))) + (if (null? first68) + (apply f57 (cons x66 xr67)) + (if (apply f57 (cons x66 xr67)) + (andmap63 first68 rest69) #f)))))) - (andmap2420 first2417)) - (letrec ((andmap2424 - (lambda (first2425 rest2426) - (let ((x2427 (car first2425)) - (xr2428 (map car rest2426)) - (first2429 (cdr first2425)) - (rest2430 (map cdr rest2426))) - (if (null? first2429) - (apply f2418 (cons x2427 xr2428)) - (if (apply f2418 (cons x2427 xr2428)) - (andmap2424 first2429 rest2430) - #f)))))) - (andmap2424 first2417 rest2416)))))))) - (letrec ((lambda-var-list2524 - (lambda (vars2648) - (letrec ((lvl2649 - (lambda (vars2650 ls2651 w2652) - (if (pair? vars2650) - (lvl2649 - (cdr vars2650) - (cons (wrap2504 (car vars2650) w2652 #f) - ls2651) - w2652) - (if (id?2476 vars2650) - (cons (wrap2504 vars2650 w2652 #f) ls2651) - (if (null? vars2650) - ls2651 - (if (syntax-object?2460 vars2650) - (lvl2649 - (syntax-object-expression2461 vars2650) - ls2651 - (join-wraps2495 - w2652 - (syntax-object-wrap2462 vars2650))) - (cons vars2650 ls2651)))))))) - (lvl2649 vars2648 (quote ()) (quote (())))))) - (gen-var2523 - (lambda (id2653) - (let ((id2654 - (if (syntax-object?2460 id2653) - (syntax-object-expression2461 id2653) - id2653))) - (gensym (symbol->string id2654))))) - (strip2522 - (lambda (x2655 w2656) - (if (memq (quote top) (wrap-marks2479 w2656)) - x2655 - (letrec ((f2657 (lambda (x2658) - (if (syntax-object?2460 x2658) - (strip2522 - (syntax-object-expression2461 x2658) - (syntax-object-wrap2462 x2658)) - (if (pair? x2658) - (let ((a2659 (f2657 (car x2658))) - (d2660 (f2657 (cdr x2658)))) - (if (if (eq? a2659 (car x2658)) - (eq? d2660 (cdr x2658)) - #f) - x2658 - (cons a2659 d2660))) - (if (vector? x2658) - (let ((old2661 (vector->list x2658))) - (let ((new2662 (map f2657 old2661))) - (if (and-map*2378 - eq? - old2661 - new2662) - x2658 - (list->vector new2662)))) - x2658)))))) - (f2657 x2655))))) - (ellipsis?2521 - (lambda (x2663) - (if (nonsymbol-id?2475 x2663) - (free-id=?2499 - x2663 + (andmap63 first56 rest55)))))))) + (letrec ((lambda-var-list163 + (lambda (vars287) + (letrec ((lvl288 + (lambda (vars289 ls290 w291) + (if (pair? vars289) + (lvl288 + (cdr vars289) + (cons (wrap143 (car vars289) w291 #f) ls290) + w291) + (if (id?115 vars289) + (cons (wrap143 vars289 w291 #f) ls290) + (if (null? vars289) + ls290 + (if (syntax-object?99 vars289) + (lvl288 + (syntax-object-expression100 vars289) + ls290 + (join-wraps134 + w291 + (syntax-object-wrap101 vars289))) + (cons vars289 ls290)))))))) + (lvl288 vars287 (quote ()) (quote (())))))) + (gen-var162 + (lambda (id292) + (let ((id293 (if (syntax-object?99 id292) + (syntax-object-expression100 id292) + id292))) + (gensym (symbol->string id293))))) + (strip161 + (lambda (x294 w295) + (if (memq (quote top) (wrap-marks118 w295)) + x294 + (letrec ((f296 (lambda (x297) + (if (syntax-object?99 x297) + (strip161 + (syntax-object-expression100 x297) + (syntax-object-wrap101 x297)) + (if (pair? x297) + (let ((a298 (f296 (car x297))) + (d299 (f296 (cdr x297)))) + (if (if (eq? a298 (car x297)) + (eq? d299 (cdr x297)) + #f) + x297 + (cons a298 d299))) + (if (vector? x297) + (let ((old300 (vector->list x297))) + (let ((new301 (map f296 old300))) + (if (and-map*17 eq? old300 new301) + x297 + (list->vector new301)))) + x297)))))) + (f296 x294))))) + (ellipsis?160 + (lambda (x302) + (if (nonsymbol-id?114 x302) + (free-id=?138 + x302 '#(syntax-object ... ((top) @@ -441,1632 +434,1590 @@ ("i" "i"))) (hygiene guile))) #f))) - (chi-void2520 (lambda () (build-void2442 #f))) - (eval-local-transformer2519 - (lambda (expanded2664 mod2665) - (let ((p2666 (local-eval-hook2438 expanded2664 mod2665))) - (if (procedure? p2666) - p2666 + (chi-void159 (lambda () (build-void81 #f))) + (eval-local-transformer158 + (lambda (expanded303 mod304) + (let ((p305 (local-eval-hook77 expanded303 mod304))) + (if (procedure? p305) + p305 (syntax-violation #f "nonprocedure transformer" - p2666))))) - (chi-local-syntax2518 - (lambda (rec?2667 e2668 r2669 w2670 s2671 mod2672 k2673) - ((lambda (tmp2674) - ((lambda (tmp2675) - (if tmp2675 - (apply (lambda (_2676 id2677 val2678 e12679 e22680) - (let ((ids2681 id2677)) - (if (not (valid-bound-ids?2501 ids2681)) + p305))))) + (chi-local-syntax157 + (lambda (rec?306 e307 r308 w309 s310 mod311 k312) + ((lambda (tmp313) + ((lambda (tmp314) + (if tmp314 + (apply (lambda (_315 id316 val317 e1318 e2319) + (let ((ids320 id316)) + (if (not (valid-bound-ids?140 ids320)) (syntax-violation #f "duplicate bound keyword" - e2668) - (let ((labels2683 - (gen-labels2482 ids2681))) - (let ((new-w2684 - (make-binding-wrap2493 - ids2681 - labels2683 - w2670))) - (k2673 (cons e12679 e22680) - (extend-env2470 - labels2683 - (let ((w2686 (if rec?2667 - new-w2684 - w2670)) - (trans-r2687 - (macros-only-env2472 - r2669))) - (map (lambda (x2688) - (cons 'macro - (eval-local-transformer2519 - (chi2512 - x2688 - trans-r2687 - w2686 - mod2672) - mod2672))) - val2678)) - r2669) - new-w2684 - s2671 - mod2672)))))) - tmp2675) - ((lambda (_2690) + e307) + (let ((labels322 (gen-labels121 ids320))) + (let ((new-w323 + (make-binding-wrap132 + ids320 + labels322 + w309))) + (k312 (cons e1318 e2319) + (extend-env109 + labels322 + (let ((w325 (if rec?306 + new-w323 + w309)) + (trans-r326 + (macros-only-env111 + r308))) + (map (lambda (x327) + (cons 'macro + (eval-local-transformer158 + (chi151 + x327 + trans-r326 + w325 + mod311) + mod311))) + val317)) + r308) + new-w323 + s310 + mod311)))))) + tmp314) + ((lambda (_329) (syntax-violation #f "bad local syntax definition" - (source-wrap2505 e2668 w2670 s2671 mod2672))) - tmp2674))) + (source-wrap144 e307 w309 s310 mod311))) + tmp313))) ($sc-dispatch - tmp2674 + tmp313 '(any #(each (any any)) any . each-any)))) - e2668))) - (chi-lambda-clause2517 - (lambda (e2691 - docstring2692 - c2693 - r2694 - w2695 - mod2696 - k2697) - ((lambda (tmp2698) - ((lambda (tmp2699) - (if (if tmp2699 - (apply (lambda (args2700 doc2701 e12702 e22703) - (if (string? (syntax->datum doc2701)) - (not docstring2692) + e307))) + (chi-lambda-clause156 + (lambda (e330 docstring331 c332 r333 w334 mod335 k336) + ((lambda (tmp337) + ((lambda (tmp338) + (if (if tmp338 + (apply (lambda (args339 doc340 e1341 e2342) + (if (string? (syntax->datum doc340)) + (not docstring331) #f)) - tmp2699) + tmp338) #f) - (apply (lambda (args2704 doc2705 e12706 e22707) - (chi-lambda-clause2517 - e2691 - doc2705 - (cons args2704 (cons e12706 e22707)) - r2694 - w2695 - mod2696 - k2697)) - tmp2699) - ((lambda (tmp2709) - (if tmp2709 - (apply (lambda (id2710 e12711 e22712) - (let ((ids2713 id2710)) - (if (not (valid-bound-ids?2501 ids2713)) + (apply (lambda (args343 doc344 e1345 e2346) + (chi-lambda-clause156 + e330 + doc344 + (cons args343 (cons e1345 e2346)) + r333 + w334 + mod335 + k336)) + tmp338) + ((lambda (tmp348) + (if tmp348 + (apply (lambda (id349 e1350 e2351) + (let ((ids352 id349)) + (if (not (valid-bound-ids?140 ids352)) (syntax-violation 'lambda "invalid parameter list" - e2691) - (let ((labels2715 - (gen-labels2482 ids2713)) - (new-vars2716 - (map gen-var2523 ids2713))) - (k2697 (map syntax->datum ids2713) - new-vars2716 - (if docstring2692 - (syntax->datum - docstring2692) - #f) - (chi-body2516 - (cons e12711 e22712) - e2691 - (extend-var-env2471 - labels2715 - new-vars2716 - r2694) - (make-binding-wrap2493 - ids2713 - labels2715 - w2695) - mod2696)))))) - tmp2709) - ((lambda (tmp2718) - (if tmp2718 - (apply (lambda (ids2719 e12720 e22721) - (let ((old-ids2722 - (lambda-var-list2524 - ids2719))) - (if (not (valid-bound-ids?2501 - old-ids2722)) + e330) + (let ((labels354 + (gen-labels121 ids352)) + (new-vars355 + (map gen-var162 ids352))) + (k336 (map syntax->datum ids352) + new-vars355 + (if docstring331 + (syntax->datum docstring331) + #f) + (chi-body155 + (cons e1350 e2351) + e330 + (extend-var-env110 + labels354 + new-vars355 + r333) + (make-binding-wrap132 + ids352 + labels354 + w334) + mod335)))))) + tmp348) + ((lambda (tmp357) + (if tmp357 + (apply (lambda (ids358 e1359 e2360) + (let ((old-ids361 + (lambda-var-list163 ids358))) + (if (not (valid-bound-ids?140 + old-ids361)) (syntax-violation 'lambda "invalid parameter list" - e2691) - (let ((labels2723 - (gen-labels2482 - old-ids2722)) - (new-vars2724 - (map gen-var2523 - old-ids2722))) - (k2697 (letrec ((f2725 (lambda (ls12726 - ls22727) - (if (null? ls12726) - (syntax->datum - ls22727) - (f2725 (cdr ls12726) - (cons (syntax->datum - (car ls12726)) - ls22727)))))) - (f2725 (cdr old-ids2722) - (car old-ids2722))) - (letrec ((f2728 (lambda (ls12729 - ls22730) - (if (null? ls12729) - ls22730 - (f2728 (cdr ls12729) - (cons (car ls12729) - ls22730)))))) - (f2728 (cdr new-vars2724) - (car new-vars2724))) - (if docstring2692 - (syntax->datum - docstring2692) - #f) - (chi-body2516 - (cons e12720 e22721) - e2691 - (extend-var-env2471 - labels2723 - new-vars2724 - r2694) - (make-binding-wrap2493 - old-ids2722 - labels2723 - w2695) - mod2696)))))) - tmp2718) - ((lambda (_2732) + e330) + (let ((labels362 + (gen-labels121 + old-ids361)) + (new-vars363 + (map gen-var162 + old-ids361))) + (k336 (letrec ((f364 (lambda (ls1365 + ls2366) + (if (null? ls1365) + (syntax->datum + ls2366) + (f364 (cdr ls1365) + (cons (syntax->datum + (car ls1365)) + ls2366)))))) + (f364 (cdr old-ids361) + (car old-ids361))) + (letrec ((f367 (lambda (ls1368 + ls2369) + (if (null? ls1368) + ls2369 + (f367 (cdr ls1368) + (cons (car ls1368) + ls2369)))))) + (f367 (cdr new-vars363) + (car new-vars363))) + (if docstring331 + (syntax->datum + docstring331) + #f) + (chi-body155 + (cons e1359 e2360) + e330 + (extend-var-env110 + labels362 + new-vars363 + r333) + (make-binding-wrap132 + old-ids361 + labels362 + w334) + mod335)))))) + tmp357) + ((lambda (_371) (syntax-violation 'lambda "bad lambda" - e2691)) - tmp2698))) + e330)) + tmp337))) ($sc-dispatch - tmp2698 + tmp337 '(any any . each-any))))) ($sc-dispatch - tmp2698 + tmp337 '(each-any any . each-any))))) ($sc-dispatch - tmp2698 + tmp337 '(any any any . each-any)))) - c2693))) - (chi-body2516 - (lambda (body2733 outer-form2734 r2735 w2736 mod2737) - (let ((r2738 (cons (quote ("placeholder" placeholder)) r2735))) - (let ((ribcage2739 - (make-ribcage2483 + c332))) + (chi-body155 + (lambda (body372 outer-form373 r374 w375 mod376) + (let ((r377 (cons (quote ("placeholder" placeholder)) r374))) + (let ((ribcage378 + (make-ribcage122 '() '() '()))) - (let ((w2740 (make-wrap2478 - (wrap-marks2479 w2736) - (cons ribcage2739 (wrap-subst2480 w2736))))) - (letrec ((parse2741 - (lambda (body2742 - ids2743 - labels2744 - var-ids2745 - vars2746 - vals2747 - bindings2748) - (if (null? body2742) + (let ((w379 (make-wrap117 + (wrap-marks118 w375) + (cons ribcage378 (wrap-subst119 w375))))) + (letrec ((parse380 + (lambda (body381 + ids382 + labels383 + var-ids384 + vars385 + vals386 + bindings387) + (if (null? body381) (syntax-violation #f "no expressions in body" - outer-form2734) - (let ((e2750 (cdar body2742)) - (er2751 (caar body2742))) + outer-form373) + (let ((e389 (cdar body381)) + (er390 (caar body381))) (call-with-values (lambda () - (syntax-type2510 - e2750 - er2751 + (syntax-type149 + e389 + er390 '(()) - (source-annotation2467 er2751) - ribcage2739 - mod2737 + (source-annotation106 er390) + ribcage378 + mod376 #f)) - (lambda (type2752 - value2753 - e2754 - w2755 - s2756 - mod2757) - (if (memv type2752 + (lambda (type391 + value392 + e393 + w394 + s395 + mod396) + (if (memv type391 '(define-form)) - (let ((id2758 - (wrap2504 - value2753 - w2755 - mod2757)) - (label2759 (gen-label2481))) - (let ((var2760 - (gen-var2523 id2758))) + (let ((id397 (wrap143 + value392 + w394 + mod396)) + (label398 (gen-label120))) + (let ((var399 + (gen-var162 id397))) (begin - (extend-ribcage!2492 - ribcage2739 - id2758 - label2759) - (parse2741 - (cdr body2742) - (cons id2758 ids2743) - (cons label2759 labels2744) - (cons id2758 var-ids2745) - (cons var2760 vars2746) - (cons (cons er2751 - (wrap2504 - e2754 - w2755 - mod2757)) - vals2747) + (extend-ribcage!131 + ribcage378 + id397 + label398) + (parse380 + (cdr body381) + (cons id397 ids382) + (cons label398 labels383) + (cons id397 var-ids384) + (cons var399 vars385) + (cons (cons er390 + (wrap143 + e393 + w394 + mod396)) + vals386) (cons (cons 'lexical - var2760) - bindings2748))))) - (if (memv type2752 + var399) + bindings387))))) + (if (memv type391 '(define-syntax-form)) - (let ((id2761 - (wrap2504 - value2753 - w2755 - mod2757)) - (label2762 - (gen-label2481))) + (let ((id400 (wrap143 + value392 + w394 + mod396)) + (label401 (gen-label120))) (begin - (extend-ribcage!2492 - ribcage2739 - id2761 - label2762) - (parse2741 - (cdr body2742) - (cons id2761 ids2743) - (cons label2762 labels2744) - var-ids2745 - vars2746 - vals2747 + (extend-ribcage!131 + ribcage378 + id400 + label401) + (parse380 + (cdr body381) + (cons id400 ids382) + (cons label401 labels383) + var-ids384 + vars385 + vals386 (cons (cons 'macro - (cons er2751 - (wrap2504 - e2754 - w2755 - mod2757))) - bindings2748)))) - (if (memv type2752 + (cons er390 + (wrap143 + e393 + w394 + mod396))) + bindings387)))) + (if (memv type391 '(begin-form)) - ((lambda (tmp2763) - ((lambda (tmp2764) - (if tmp2764 - (apply (lambda (_2765 - e12766) - (parse2741 - (letrec ((f2767 (lambda (forms2768) - (if (null? forms2768) - (cdr body2742) - (cons (cons er2751 - (wrap2504 - (car forms2768) - w2755 - mod2757)) - (f2767 (cdr forms2768))))))) - (f2767 e12766)) - ids2743 - labels2744 - var-ids2745 - vars2746 - vals2747 - bindings2748)) - tmp2764) + ((lambda (tmp402) + ((lambda (tmp403) + (if tmp403 + (apply (lambda (_404 + e1405) + (parse380 + (letrec ((f406 (lambda (forms407) + (if (null? forms407) + (cdr body381) + (cons (cons er390 + (wrap143 + (car forms407) + w394 + mod396)) + (f406 (cdr forms407))))))) + (f406 e1405)) + ids382 + labels383 + var-ids384 + vars385 + vals386 + bindings387)) + tmp403) (syntax-violation #f "source expression failed to match any pattern" - tmp2763))) + tmp402))) ($sc-dispatch - tmp2763 + tmp402 '(any . each-any)))) - e2754) - (if (memv type2752 + e393) + (if (memv type391 '(local-syntax-form)) - (chi-local-syntax2518 - value2753 - e2754 - er2751 - w2755 - s2756 - mod2757 - (lambda (forms2770 - er2771 - w2772 - s2773 - mod2774) - (parse2741 - (letrec ((f2775 (lambda (forms2776) - (if (null? forms2776) - (cdr body2742) - (cons (cons er2771 - (wrap2504 - (car forms2776) - w2772 - mod2774)) - (f2775 (cdr forms2776))))))) - (f2775 forms2770)) - ids2743 - labels2744 - var-ids2745 - vars2746 - vals2747 - bindings2748))) - (if (null? ids2743) - (build-sequence2455 + (chi-local-syntax157 + value392 + e393 + er390 + w394 + s395 + mod396 + (lambda (forms409 + er410 + w411 + s412 + mod413) + (parse380 + (letrec ((f414 (lambda (forms415) + (if (null? forms415) + (cdr body381) + (cons (cons er410 + (wrap143 + (car forms415) + w411 + mod413)) + (f414 (cdr forms415))))))) + (f414 forms409)) + ids382 + labels383 + var-ids384 + vars385 + vals386 + bindings387))) + (if (null? ids382) + (build-sequence94 #f - (map (lambda (x2777) - (chi2512 - (cdr x2777) - (car x2777) + (map (lambda (x416) + (chi151 + (cdr x416) + (car x416) '(()) - mod2757)) - (cons (cons er2751 - (source-wrap2505 - e2754 - w2755 - s2756 - mod2757)) - (cdr body2742)))) + mod396)) + (cons (cons er390 + (source-wrap144 + e393 + w394 + s395 + mod396)) + (cdr body381)))) (begin - (if (not (valid-bound-ids?2501 - ids2743)) + (if (not (valid-bound-ids?140 + ids382)) (syntax-violation #f "invalid or duplicate identifier in definition" - outer-form2734)) - (letrec ((loop2778 - (lambda (bs2779 - er-cache2780 - r-cache2781) - (if (not (null? bs2779)) - (let ((b2782 (car bs2779))) - (if (eq? (car b2782) + outer-form373)) + (letrec ((loop417 + (lambda (bs418 + er-cache419 + r-cache420) + (if (not (null? bs418)) + (let ((b421 (car bs418))) + (if (eq? (car b421) 'macro) - (let ((er2783 - (cadr b2782))) - (let ((r-cache2784 - (if (eq? er2783 - er-cache2780) - r-cache2781 - (macros-only-env2472 - er2783)))) + (let ((er422 (cadr b421))) + (let ((r-cache423 + (if (eq? er422 + er-cache419) + r-cache420 + (macros-only-env111 + er422)))) (begin (set-cdr! - b2782 - (eval-local-transformer2519 - (chi2512 - (cddr b2782) - r-cache2784 + b421 + (eval-local-transformer158 + (chi151 + (cddr b421) + r-cache423 '(()) - mod2757) - mod2757)) - (loop2778 - (cdr bs2779) - er2783 - r-cache2784)))) - (loop2778 - (cdr bs2779) - er-cache2780 - r-cache2781))))))) - (loop2778 - bindings2748 + mod396) + mod396)) + (loop417 + (cdr bs418) + er422 + r-cache423)))) + (loop417 + (cdr bs418) + er-cache419 + r-cache420))))))) + (loop417 + bindings387 #f #f)) (set-cdr! - r2738 - (extend-env2470 - labels2744 - bindings2748 - (cdr r2738))) - (build-letrec2458 + r377 + (extend-env109 + labels383 + bindings387 + (cdr r377))) + (build-letrec97 #f (map syntax->datum - var-ids2745) - vars2746 - (map (lambda (x2785) - (chi2512 - (cdr x2785) - (car x2785) + var-ids384) + vars385 + (map (lambda (x424) + (chi151 + (cdr x424) + (car x424) '(()) - mod2757)) - vals2747) - (build-sequence2455 + mod396)) + vals386) + (build-sequence94 #f - (map (lambda (x2786) - (chi2512 - (cdr x2786) - (car x2786) + (map (lambda (x425) + (chi151 + (cdr x425) + (car x425) '(()) - mod2757)) - (cons (cons er2751 - (source-wrap2505 - e2754 - w2755 - s2756 - mod2757)) - (cdr body2742)))))))))))))))))) - (parse2741 - (map (lambda (x2749) - (cons r2738 (wrap2504 x2749 w2740 mod2737))) - body2733) + mod396)) + (cons (cons er390 + (source-wrap144 + e393 + w394 + s395 + mod396)) + (cdr body381)))))))))))))))))) + (parse380 + (map (lambda (x388) + (cons r377 (wrap143 x388 w379 mod376))) + body372) '() '() '() '() '() '()))))))) - (chi-macro2515 - (lambda (p2787 e2788 r2789 w2790 rib2791 mod2792) - (letrec ((rebuild-macro-output2793 - (lambda (x2794 m2795) - (if (pair? x2794) - (cons (rebuild-macro-output2793 - (car x2794) - m2795) - (rebuild-macro-output2793 - (cdr x2794) - m2795)) - (if (syntax-object?2460 x2794) - (let ((w2796 (syntax-object-wrap2462 x2794))) - (let ((ms2797 (wrap-marks2479 w2796)) - (s2798 (wrap-subst2480 w2796))) - (if (if (pair? ms2797) - (eq? (car ms2797) #f) + (chi-macro154 + (lambda (p426 e427 r428 w429 rib430 mod431) + (letrec ((rebuild-macro-output432 + (lambda (x433 m434) + (if (pair? x433) + (cons (rebuild-macro-output432 (car x433) m434) + (rebuild-macro-output432 (cdr x433) m434)) + (if (syntax-object?99 x433) + (let ((w435 (syntax-object-wrap101 x433))) + (let ((ms436 (wrap-marks118 w435)) + (s437 (wrap-subst119 w435))) + (if (if (pair? ms436) + (eq? (car ms436) #f) #f) - (make-syntax-object2459 - (syntax-object-expression2461 x2794) - (make-wrap2478 - (cdr ms2797) - (if rib2791 - (cons rib2791 (cdr s2798)) - (cdr s2798))) - (syntax-object-module2463 x2794)) - (make-syntax-object2459 - (syntax-object-expression2461 x2794) - (make-wrap2478 - (cons m2795 ms2797) - (if rib2791 - (cons rib2791 - (cons (quote shift) s2798)) - (cons (quote shift) s2798))) - (let ((pmod2799 - (procedure-module p2787))) - (if pmod2799 + (make-syntax-object98 + (syntax-object-expression100 x433) + (make-wrap117 + (cdr ms436) + (if rib430 + (cons rib430 (cdr s437)) + (cdr s437))) + (syntax-object-module102 x433)) + (make-syntax-object98 + (syntax-object-expression100 x433) + (make-wrap117 + (cons m434 ms436) + (if rib430 + (cons rib430 + (cons (quote shift) s437)) + (cons (quote shift) s437))) + (let ((pmod438 + (procedure-module p426))) + (if pmod438 (cons 'hygiene - (module-name pmod2799)) + (module-name pmod438)) '(hygiene guile))))))) - (if (vector? x2794) - (let ((n2800 (vector-length x2794))) - (let ((v2801 (make-vector n2800))) - (letrec ((loop2802 - (lambda (i2803) - (if (fx=2435 i2803 n2800) - (begin (if #f #f) v2801) + (if (vector? x433) + (let ((n439 (vector-length x433))) + (let ((v440 (make-vector n439))) + (letrec ((loop441 + (lambda (i442) + (if (fx=74 i442 n439) + (begin (if #f #f) v440) (begin (vector-set! - v2801 - i2803 - (rebuild-macro-output2793 + v440 + i442 + (rebuild-macro-output432 (vector-ref - x2794 - i2803) - m2795)) - (loop2802 - (fx+2433 - i2803 - 1))))))) - (loop2802 0)))) - (if (symbol? x2794) + x433 + i442) + m434)) + (loop441 + (fx+72 i442 1))))))) + (loop441 0)))) + (if (symbol? x433) (syntax-violation #f "encountered raw symbol in macro output" - (source-wrap2505 e2788 w2790 s mod2792) - x2794) - x2794))))))) - (rebuild-macro-output2793 - (p2787 (wrap2504 e2788 (anti-mark2491 w2790) mod2792)) + (source-wrap144 e427 w429 s mod431) + x433) + x433))))))) + (rebuild-macro-output432 + (p426 (wrap143 e427 (anti-mark130 w429) mod431)) (string #\m))))) - (chi-application2514 - (lambda (x2804 e2805 r2806 w2807 s2808 mod2809) - ((lambda (tmp2810) - ((lambda (tmp2811) - (if tmp2811 - (apply (lambda (e02812 e12813) - (build-application2443 - s2808 - x2804 - (map (lambda (e2814) - (chi2512 e2814 r2806 w2807 mod2809)) - e12813))) - tmp2811) + (chi-application153 + (lambda (x443 e444 r445 w446 s447 mod448) + ((lambda (tmp449) + ((lambda (tmp450) + (if tmp450 + (apply (lambda (e0451 e1452) + (build-application82 + s447 + x443 + (map (lambda (e453) + (chi151 e453 r445 w446 mod448)) + e1452))) + tmp450) (syntax-violation #f "source expression failed to match any pattern" - tmp2810))) - ($sc-dispatch tmp2810 (quote (any . each-any))))) - e2805))) - (chi-expr2513 - (lambda (type2816 - value2817 - e2818 - r2819 - w2820 - s2821 - mod2822) - (if (memv type2816 (quote (lexical))) - (build-lexical-reference2445 + tmp449))) + ($sc-dispatch tmp449 (quote (any . each-any))))) + e444))) + (chi-expr152 + (lambda (type455 value456 e457 r458 w459 s460 mod461) + (if (memv type455 (quote (lexical))) + (build-lexical-reference84 'value - s2821 - e2818 - value2817) - (if (memv type2816 (quote (core core-form))) - (value2817 e2818 r2819 w2820 s2821 mod2822) - (if (memv type2816 (quote (module-ref))) + s460 + e457 + value456) + (if (memv type455 (quote (core core-form))) + (value456 e457 r458 w459 s460 mod461) + (if (memv type455 (quote (module-ref))) (call-with-values - (lambda () (value2817 e2818)) - (lambda (id2823 mod2824) - (build-global-reference2448 s2821 id2823 mod2824))) - (if (memv type2816 (quote (lexical-call))) - (chi-application2514 - (build-lexical-reference2445 + (lambda () (value456 e457)) + (lambda (id462 mod463) + (build-global-reference87 s460 id462 mod463))) + (if (memv type455 (quote (lexical-call))) + (chi-application153 + (build-lexical-reference84 'fun - (source-annotation2467 (car e2818)) - (car e2818) - value2817) - e2818 - r2819 - w2820 - s2821 - mod2822) - (if (memv type2816 (quote (global-call))) - (chi-application2514 - (build-global-reference2448 - (source-annotation2467 (car e2818)) - (if (syntax-object?2460 value2817) - (syntax-object-expression2461 value2817) - value2817) - (if (syntax-object?2460 value2817) - (syntax-object-module2463 value2817) - mod2822)) - e2818 - r2819 - w2820 - s2821 - mod2822) - (if (memv type2816 (quote (constant))) - (build-data2454 - s2821 - (strip2522 - (source-wrap2505 e2818 w2820 s2821 mod2822) + (source-annotation106 (car e457)) + (car e457) + value456) + e457 + r458 + w459 + s460 + mod461) + (if (memv type455 (quote (global-call))) + (chi-application153 + (build-global-reference87 + (source-annotation106 (car e457)) + (if (syntax-object?99 value456) + (syntax-object-expression100 value456) + value456) + (if (syntax-object?99 value456) + (syntax-object-module102 value456) + mod461)) + e457 + r458 + w459 + s460 + mod461) + (if (memv type455 (quote (constant))) + (build-data93 + s460 + (strip161 + (source-wrap144 e457 w459 s460 mod461) '(()))) - (if (memv type2816 (quote (global))) - (build-global-reference2448 - s2821 - value2817 - mod2822) - (if (memv type2816 (quote (call))) - (chi-application2514 - (chi2512 (car e2818) r2819 w2820 mod2822) - e2818 - r2819 - w2820 - s2821 - mod2822) - (if (memv type2816 (quote (begin-form))) - ((lambda (tmp2825) - ((lambda (tmp2826) - (if tmp2826 - (apply (lambda (_2827 e12828 e22829) - (chi-sequence2506 - (cons e12828 e22829) - r2819 - w2820 - s2821 - mod2822)) - tmp2826) + (if (memv type455 (quote (global))) + (build-global-reference87 s460 value456 mod461) + (if (memv type455 (quote (call))) + (chi-application153 + (chi151 (car e457) r458 w459 mod461) + e457 + r458 + w459 + s460 + mod461) + (if (memv type455 (quote (begin-form))) + ((lambda (tmp464) + ((lambda (tmp465) + (if tmp465 + (apply (lambda (_466 e1467 e2468) + (chi-sequence145 + (cons e1467 e2468) + r458 + w459 + s460 + mod461)) + tmp465) (syntax-violation #f "source expression failed to match any pattern" - tmp2825))) + tmp464))) ($sc-dispatch - tmp2825 + tmp464 '(any any . each-any)))) - e2818) - (if (memv type2816 - '(local-syntax-form)) - (chi-local-syntax2518 - value2817 - e2818 - r2819 - w2820 - s2821 - mod2822 - chi-sequence2506) - (if (memv type2816 (quote (eval-when-form))) - ((lambda (tmp2831) - ((lambda (tmp2832) - (if tmp2832 - (apply (lambda (_2833 - x2834 - e12835 - e22836) - (let ((when-list2837 - (chi-when-list2509 - e2818 - x2834 - w2820))) + e457) + (if (memv type455 (quote (local-syntax-form))) + (chi-local-syntax157 + value456 + e457 + r458 + w459 + s460 + mod461 + chi-sequence145) + (if (memv type455 (quote (eval-when-form))) + ((lambda (tmp470) + ((lambda (tmp471) + (if tmp471 + (apply (lambda (_472 + x473 + e1474 + e2475) + (let ((when-list476 + (chi-when-list148 + e457 + x473 + w459))) (if (memq 'eval - when-list2837) - (chi-sequence2506 - (cons e12835 - e22836) - r2819 - w2820 - s2821 - mod2822) - (chi-void2520)))) - tmp2832) + when-list476) + (chi-sequence145 + (cons e1474 e2475) + r458 + w459 + s460 + mod461) + (chi-void159)))) + tmp471) (syntax-violation #f "source expression failed to match any pattern" - tmp2831))) + tmp470))) ($sc-dispatch - tmp2831 + tmp470 '(any each-any any . each-any)))) - e2818) - (if (memv type2816 + e457) + (if (memv type455 '(define-form define-syntax-form)) (syntax-violation #f "definition in expression context" - e2818 - (wrap2504 value2817 w2820 mod2822)) - (if (memv type2816 (quote (syntax))) + e457 + (wrap143 value456 w459 mod461)) + (if (memv type455 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" - (source-wrap2505 - e2818 - w2820 - s2821 - mod2822)) - (if (memv type2816 + (source-wrap144 + e457 + w459 + s460 + mod461)) + (if (memv type455 '(displaced-lexical)) (syntax-violation #f "reference to identifier outside its scope" - (source-wrap2505 - e2818 - w2820 - s2821 - mod2822)) + (source-wrap144 + e457 + w459 + s460 + mod461)) (syntax-violation #f "unexpected syntax" - (source-wrap2505 - e2818 - w2820 - s2821 - mod2822)))))))))))))))))) - (chi2512 - (lambda (e2840 r2841 w2842 mod2843) + (source-wrap144 + e457 + w459 + s460 + mod461)))))))))))))))))) + (chi151 + (lambda (e479 r480 w481 mod482) (call-with-values (lambda () - (syntax-type2510 - e2840 - r2841 - w2842 - (source-annotation2467 e2840) + (syntax-type149 + e479 + r480 + w481 + (source-annotation106 e479) #f - mod2843 + mod482 #f)) - (lambda (type2844 value2845 e2846 w2847 s2848 mod2849) - (chi-expr2513 - type2844 - value2845 - e2846 - r2841 - w2847 - s2848 - mod2849))))) - (chi-top2511 - (lambda (e2850 r2851 w2852 m2853 esew2854 mod2855) + (lambda (type483 value484 e485 w486 s487 mod488) + (chi-expr152 + type483 + value484 + e485 + r480 + w486 + s487 + mod488))))) + (chi-top150 + (lambda (e489 r490 w491 m492 esew493 mod494) (call-with-values (lambda () - (syntax-type2510 - e2850 - r2851 - w2852 - (source-annotation2467 e2850) + (syntax-type149 + e489 + r490 + w491 + (source-annotation106 e489) #f - mod2855 + mod494 #f)) - (lambda (type2863 value2864 e2865 w2866 s2867 mod2868) - (if (memv type2863 (quote (begin-form))) - ((lambda (tmp2869) - ((lambda (tmp2870) - (if tmp2870 - (apply (lambda (_2871) (chi-void2520)) tmp2870) - ((lambda (tmp2872) - (if tmp2872 - (apply (lambda (_2873 e12874 e22875) - (chi-top-sequence2507 - (cons e12874 e22875) - r2851 - w2866 - s2867 - m2853 - esew2854 - mod2868)) - tmp2872) + (lambda (type502 value503 e504 w505 s506 mod507) + (if (memv type502 (quote (begin-form))) + ((lambda (tmp508) + ((lambda (tmp509) + (if tmp509 + (apply (lambda (_510) (chi-void159)) tmp509) + ((lambda (tmp511) + (if tmp511 + (apply (lambda (_512 e1513 e2514) + (chi-top-sequence146 + (cons e1513 e2514) + r490 + w505 + s506 + m492 + esew493 + mod507)) + tmp511) (syntax-violation #f "source expression failed to match any pattern" - tmp2869))) + tmp508))) ($sc-dispatch - tmp2869 + tmp508 '(any any . each-any))))) - ($sc-dispatch tmp2869 (quote (any))))) - e2865) - (if (memv type2863 (quote (local-syntax-form))) - (chi-local-syntax2518 - value2864 - e2865 - r2851 - w2866 - s2867 - mod2868 - (lambda (body2877 r2878 w2879 s2880 mod2881) - (chi-top-sequence2507 - body2877 - r2878 - w2879 - s2880 - m2853 - esew2854 - mod2881))) - (if (memv type2863 (quote (eval-when-form))) - ((lambda (tmp2882) - ((lambda (tmp2883) - (if tmp2883 - (apply (lambda (_2884 x2885 e12886 e22887) - (let ((when-list2888 - (chi-when-list2509 - e2865 - x2885 - w2866)) - (body2889 - (cons e12886 e22887))) - (if (eq? m2853 (quote e)) + ($sc-dispatch tmp508 (quote (any))))) + e504) + (if (memv type502 (quote (local-syntax-form))) + (chi-local-syntax157 + value503 + e504 + r490 + w505 + s506 + mod507 + (lambda (body516 r517 w518 s519 mod520) + (chi-top-sequence146 + body516 + r517 + w518 + s519 + m492 + esew493 + mod520))) + (if (memv type502 (quote (eval-when-form))) + ((lambda (tmp521) + ((lambda (tmp522) + (if tmp522 + (apply (lambda (_523 x524 e1525 e2526) + (let ((when-list527 + (chi-when-list148 + e504 + x524 + w505)) + (body528 (cons e1525 e2526))) + (if (eq? m492 (quote e)) (if (memq 'eval - when-list2888) - (chi-top-sequence2507 - body2889 - r2851 - w2866 - s2867 + when-list527) + (chi-top-sequence146 + body528 + r490 + w505 + s506 'e '(eval) - mod2868) - (chi-void2520)) + mod507) + (chi-void159)) (if (memq 'load - when-list2888) - (if (let ((t2892 (memq 'compile - when-list2888))) - (if t2892 - t2892 - (if (eq? m2853 + when-list527) + (if (let ((t531 (memq 'compile + when-list527))) + (if t531 + t531 + (if (eq? m492 'c&e) (memq 'eval - when-list2888) + when-list527) #f))) - (chi-top-sequence2507 - body2889 - r2851 - w2866 - s2867 + (chi-top-sequence146 + body528 + r490 + w505 + s506 'c&e '(compile load) - mod2868) - (if (memq m2853 + mod507) + (if (memq m492 '(c c&e)) - (chi-top-sequence2507 - body2889 - r2851 - w2866 - s2867 + (chi-top-sequence146 + body528 + r490 + w505 + s506 'c '(load) - mod2868) - (chi-void2520))) - (if (let ((t2893 (memq 'compile - when-list2888))) - (if t2893 - t2893 - (if (eq? m2853 + mod507) + (chi-void159))) + (if (let ((t532 (memq 'compile + when-list527))) + (if t532 + t532 + (if (eq? m492 'c&e) (memq 'eval - when-list2888) + when-list527) #f))) (begin - (top-level-eval-hook2437 - (chi-top-sequence2507 - body2889 - r2851 - w2866 - s2867 + (top-level-eval-hook76 + (chi-top-sequence146 + body528 + r490 + w505 + s506 'e '(eval) - mod2868) - mod2868) - (chi-void2520)) - (chi-void2520)))))) - tmp2883) + mod507) + mod507) + (chi-void159)) + (chi-void159)))))) + tmp522) (syntax-violation #f "source expression failed to match any pattern" - tmp2882))) + tmp521))) ($sc-dispatch - tmp2882 + tmp521 '(any each-any any . each-any)))) - e2865) - (if (memv type2863 (quote (define-syntax-form))) - (let ((n2894 (id-var-name2498 value2864 w2866)) - (r2895 (macros-only-env2472 r2851))) - (if (memv m2853 (quote (c))) - (if (memq (quote compile) esew2854) - (let ((e2896 (chi-install-global2508 - n2894 - (chi2512 - e2865 - r2895 - w2866 - mod2868)))) + e504) + (if (memv type502 (quote (define-syntax-form))) + (let ((n533 (id-var-name137 value503 w505)) + (r534 (macros-only-env111 r490))) + (if (memv m492 (quote (c))) + (if (memq (quote compile) esew493) + (let ((e535 (chi-install-global147 + n533 + (chi151 + e504 + r534 + w505 + mod507)))) (begin - (top-level-eval-hook2437 e2896 mod2868) - (if (memq (quote load) esew2854) - e2896 - (chi-void2520)))) - (if (memq (quote load) esew2854) - (chi-install-global2508 - n2894 - (chi2512 e2865 r2895 w2866 mod2868)) - (chi-void2520))) - (if (memv m2853 (quote (c&e))) - (let ((e2897 (chi-install-global2508 - n2894 - (chi2512 - e2865 - r2895 - w2866 - mod2868)))) + (top-level-eval-hook76 e535 mod507) + (if (memq (quote load) esew493) + e535 + (chi-void159)))) + (if (memq (quote load) esew493) + (chi-install-global147 + n533 + (chi151 e504 r534 w505 mod507)) + (chi-void159))) + (if (memv m492 (quote (c&e))) + (let ((e536 (chi-install-global147 + n533 + (chi151 + e504 + r534 + w505 + mod507)))) (begin - (top-level-eval-hook2437 e2897 mod2868) - e2897)) + (top-level-eval-hook76 e536 mod507) + e536)) (begin - (if (memq (quote eval) esew2854) - (top-level-eval-hook2437 - (chi-install-global2508 - n2894 - (chi2512 e2865 r2895 w2866 mod2868)) - mod2868)) - (chi-void2520))))) - (if (memv type2863 (quote (define-form))) - (let ((n2898 (id-var-name2498 value2864 w2866))) - (let ((type2899 - (binding-type2468 - (lookup2473 n2898 r2851 mod2868)))) - (if (memv type2899 + (if (memq (quote eval) esew493) + (top-level-eval-hook76 + (chi-install-global147 + n533 + (chi151 e504 r534 w505 mod507)) + mod507)) + (chi-void159))))) + (if (memv type502 (quote (define-form))) + (let ((n537 (id-var-name137 value503 w505))) + (let ((type538 + (binding-type107 + (lookup112 n537 r490 mod507)))) + (if (memv type538 '(global core macro module-ref)) (begin (if (if (not (module-local-variable (current-module) - n2898)) + n537)) (current-module) #f) (module-define! (current-module) - n2898 + n537 #f)) - (let ((x2900 (build-global-definition2451 - s2867 - n2898 - (chi2512 - e2865 - r2851 - w2866 - mod2868)))) + (let ((x539 (build-global-definition90 + s506 + n537 + (chi151 + e504 + r490 + w505 + mod507)))) (begin - (if (eq? m2853 (quote c&e)) - (top-level-eval-hook2437 - x2900 - mod2868)) - x2900))) - (if (memv type2899 + (if (eq? m492 (quote c&e)) + (top-level-eval-hook76 x539 mod507)) + x539))) + (if (memv type538 '(displaced-lexical)) (syntax-violation #f "identifier out of context" - e2865 - (wrap2504 value2864 w2866 mod2868)) + e504 + (wrap143 value503 w505 mod507)) (syntax-violation #f "cannot define keyword at top level" - e2865 - (wrap2504 value2864 w2866 mod2868)))))) - (let ((x2901 (chi-expr2513 - type2863 - value2864 - e2865 - r2851 - w2866 - s2867 - mod2868))) + e504 + (wrap143 value503 w505 mod507)))))) + (let ((x540 (chi-expr152 + type502 + value503 + e504 + r490 + w505 + s506 + mod507))) (begin - (if (eq? m2853 (quote c&e)) - (top-level-eval-hook2437 x2901 mod2868)) - x2901))))))))))) - (syntax-type2510 - (lambda (e2902 - r2903 - w2904 - s2905 - rib2906 - mod2907 - for-car?2908) - (if (symbol? e2902) - (let ((n2909 (id-var-name2498 e2902 w2904))) - (let ((b2910 (lookup2473 n2909 r2903 mod2907))) - (let ((type2911 (binding-type2468 b2910))) - (if (memv type2911 (quote (lexical))) + (if (eq? m492 (quote c&e)) + (top-level-eval-hook76 x540 mod507)) + x540))))))))))) + (syntax-type149 + (lambda (e541 r542 w543 s544 rib545 mod546 for-car?547) + (if (symbol? e541) + (let ((n548 (id-var-name137 e541 w543))) + (let ((b549 (lookup112 n548 r542 mod546))) + (let ((type550 (binding-type107 b549))) + (if (memv type550 (quote (lexical))) (values - type2911 - (binding-value2469 b2910) - e2902 - w2904 - s2905 - mod2907) - (if (memv type2911 (quote (global))) - (values type2911 n2909 e2902 w2904 s2905 mod2907) - (if (memv type2911 (quote (macro))) - (if for-car?2908 + type550 + (binding-value108 b549) + e541 + w543 + s544 + mod546) + (if (memv type550 (quote (global))) + (values type550 n548 e541 w543 s544 mod546) + (if (memv type550 (quote (macro))) + (if for-car?547 (values - type2911 - (binding-value2469 b2910) - e2902 - w2904 - s2905 - mod2907) - (syntax-type2510 - (chi-macro2515 - (binding-value2469 b2910) - e2902 - r2903 - w2904 - rib2906 - mod2907) - r2903 + type550 + (binding-value108 b549) + e541 + w543 + s544 + mod546) + (syntax-type149 + (chi-macro154 + (binding-value108 b549) + e541 + r542 + w543 + rib545 + mod546) + r542 '(()) - s2905 - rib2906 - mod2907 + s544 + rib545 + mod546 #f)) (values - type2911 - (binding-value2469 b2910) - e2902 - w2904 - s2905 - mod2907))))))) - (if (pair? e2902) - (let ((first2912 (car e2902))) + type550 + (binding-value108 b549) + e541 + w543 + s544 + mod546))))))) + (if (pair? e541) + (let ((first551 (car e541))) (call-with-values (lambda () - (syntax-type2510 - first2912 - r2903 - w2904 - s2905 - rib2906 - mod2907 + (syntax-type149 + first551 + r542 + w543 + s544 + rib545 + mod546 #t)) - (lambda (ftype2913 - fval2914 - fe2915 - fw2916 - fs2917 - fmod2918) - (if (memv ftype2913 (quote (lexical))) + (lambda (ftype552 fval553 fe554 fw555 fs556 fmod557) + (if (memv ftype552 (quote (lexical))) (values 'lexical-call - fval2914 - e2902 - w2904 - s2905 - mod2907) - (if (memv ftype2913 (quote (global))) + fval553 + e541 + w543 + s544 + mod546) + (if (memv ftype552 (quote (global))) (values 'global-call - (make-syntax-object2459 fval2914 w2904 fmod2918) - e2902 - w2904 - s2905 - mod2907) - (if (memv ftype2913 (quote (macro))) - (syntax-type2510 - (chi-macro2515 - fval2914 - e2902 - r2903 - w2904 - rib2906 - mod2907) - r2903 + (make-syntax-object98 fval553 w543 fmod557) + e541 + w543 + s544 + mod546) + (if (memv ftype552 (quote (macro))) + (syntax-type149 + (chi-macro154 + fval553 + e541 + r542 + w543 + rib545 + mod546) + r542 '(()) - s2905 - rib2906 - mod2907 - for-car?2908) - (if (memv ftype2913 (quote (module-ref))) + s544 + rib545 + mod546 + for-car?547) + (if (memv ftype552 (quote (module-ref))) (call-with-values - (lambda () (fval2914 e2902)) - (lambda (sym2919 mod2920) - (syntax-type2510 - sym2919 - r2903 - w2904 - s2905 - rib2906 - mod2920 - for-car?2908))) - (if (memv ftype2913 (quote (core))) + (lambda () (fval553 e541)) + (lambda (sym558 mod559) + (syntax-type149 + sym558 + r542 + w543 + s544 + rib545 + mod559 + for-car?547))) + (if (memv ftype552 (quote (core))) (values 'core-form - fval2914 - e2902 - w2904 - s2905 - mod2907) - (if (memv ftype2913 (quote (local-syntax))) + fval553 + e541 + w543 + s544 + mod546) + (if (memv ftype552 (quote (local-syntax))) (values 'local-syntax-form - fval2914 - e2902 - w2904 - s2905 - mod2907) - (if (memv ftype2913 (quote (begin))) + fval553 + e541 + w543 + s544 + mod546) + (if (memv ftype552 (quote (begin))) (values 'begin-form #f - e2902 - w2904 - s2905 - mod2907) - (if (memv ftype2913 (quote (eval-when))) + e541 + w543 + s544 + mod546) + (if (memv ftype552 (quote (eval-when))) (values 'eval-when-form #f - e2902 - w2904 - s2905 - mod2907) - (if (memv ftype2913 (quote (define))) - ((lambda (tmp2921) - ((lambda (tmp2922) - (if (if tmp2922 - (apply (lambda (_2923 - name2924 - val2925) - (id?2476 - name2924)) - tmp2922) + e541 + w543 + s544 + mod546) + (if (memv ftype552 (quote (define))) + ((lambda (tmp560) + ((lambda (tmp561) + (if (if tmp561 + (apply (lambda (_562 + name563 + val564) + (id?115 + name563)) + tmp561) #f) - (apply (lambda (_2926 - name2927 - val2928) + (apply (lambda (_565 + name566 + val567) (values 'define-form - name2927 - val2928 - w2904 - s2905 - mod2907)) - tmp2922) - ((lambda (tmp2929) - (if (if tmp2929 - (apply (lambda (_2930 - name2931 - args2932 - e12933 - e22934) - (if (id?2476 - name2931) - (valid-bound-ids?2501 - (lambda-var-list2524 - args2932)) + name566 + val567 + w543 + s544 + mod546)) + tmp561) + ((lambda (tmp568) + (if (if tmp568 + (apply (lambda (_569 + name570 + args571 + e1572 + e2573) + (if (id?115 + name570) + (valid-bound-ids?140 + (lambda-var-list163 + args571)) #f)) - tmp2929) + tmp568) #f) - (apply (lambda (_2935 - name2936 - args2937 - e12938 - e22939) + (apply (lambda (_574 + name575 + args576 + e1577 + e2578) (values 'define-form - (wrap2504 - name2936 - w2904 - mod2907) - (cons '#(syntax-object - lambda - ((top) - #(ribcage - #(_ - name - args - e1 - e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(ftype - fval - fe - fw - fs - fmod) - #((top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(first) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(e - r - w - s - rib - mod - for-car?) - #((top) - (top) - (top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (lambda-var-list - gen-var - strip - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - maybe-name-value! - build-global-assignment - build-global-reference - analyze-variable - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-void - decorate-source - get-global-definition-hook - put-global-definition-hook - gensym-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - *mode* - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure - and-map*) - ((top) - (top)) - ("i" - "i"))) - (hygiene - guile)) - (wrap2504 - (cons args2937 - (cons e12938 - e22939)) - w2904 - mod2907)) + (wrap143 + name575 + w543 + mod546) + (decorate-source80 + (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ + name + args + e1 + e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(ftype + fval + fe + fw + fs + fmod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(first) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib + mod + for-car?) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + decorate-source + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) + (top)) + ("i" + "i"))) + (hygiene + guile)) + (wrap143 + (cons args576 + (cons e1577 + e2578)) + w543 + mod546)) + s544) '(()) - s2905 - mod2907)) - tmp2929) - ((lambda (tmp2941) - (if (if tmp2941 - (apply (lambda (_2942 - name2943) - (id?2476 - name2943)) - tmp2941) + s544 + mod546)) + tmp568) + ((lambda (tmp580) + (if (if tmp580 + (apply (lambda (_581 + name582) + (id?115 + name582)) + tmp580) #f) - (apply (lambda (_2944 - name2945) + (apply (lambda (_583 + name584) (values 'define-form - (wrap2504 - name2945 - w2904 - mod2907) + (wrap143 + name584 + w543 + mod546) '(#(syntax-object if ((top) @@ -3343,102 +3294,466 @@ (hygiene guile))) '(()) - s2905 - mod2907)) - tmp2941) + s544 + mod546)) + tmp580) (syntax-violation #f "source expression failed to match any pattern" - tmp2921))) + tmp560))) ($sc-dispatch - tmp2921 + tmp560 '(any any))))) ($sc-dispatch - tmp2921 + tmp560 '(any (any . any) any . each-any))))) ($sc-dispatch - tmp2921 + tmp560 '(any any any)))) - e2902) - (if (memv ftype2913 + e541) + (if (memv ftype552 '(define-syntax)) - ((lambda (tmp2946) - ((lambda (tmp2947) - (if (if tmp2947 - (apply (lambda (_2948 - name2949 - val2950) - (id?2476 - name2949)) - tmp2947) + ((lambda (tmp585) + ((lambda (tmp586) + (if (if tmp586 + (apply (lambda (_587 + name588 + val589) + (id?115 + name588)) + tmp586) #f) - (apply (lambda (_2951 - name2952 - val2953) + (apply (lambda (_590 + name591 + val592) (values 'define-syntax-form - name2952 - val2953 - w2904 - s2905 - mod2907)) - tmp2947) + name591 + val592 + w543 + s544 + mod546)) + tmp586) (syntax-violation #f "source expression failed to match any pattern" - tmp2946))) + tmp585))) ($sc-dispatch - tmp2946 + tmp585 '(any any any)))) - e2902) + e541) (values 'call #f - e2902 - w2904 - s2905 - mod2907)))))))))))))) - (if (syntax-object?2460 e2902) - (syntax-type2510 - (syntax-object-expression2461 e2902) - r2903 - (join-wraps2495 - w2904 - (syntax-object-wrap2462 e2902)) - s2905 - rib2906 - (let ((t2954 (syntax-object-module2463 e2902))) - (if t2954 t2954 mod2907)) - for-car?2908) - (if (self-evaluating? e2902) + e541 + w543 + s544 + mod546)))))))))))))) + (if (syntax-object?99 e541) + (syntax-type149 + (syntax-object-expression100 e541) + r542 + (join-wraps134 w543 (syntax-object-wrap101 e541)) + s544 + rib545 + (let ((t593 (syntax-object-module102 e541))) + (if t593 t593 mod546)) + for-car?547) + (if (self-evaluating? e541) (values 'constant #f - e2902 - w2904 - s2905 - mod2907) - (values - 'other - #f - e2902 - w2904 - s2905 - mod2907))))))) - (chi-when-list2509 - (lambda (e2955 when-list2956 w2957) - (letrec ((f2958 (lambda (when-list2959 situations2960) - (if (null? when-list2959) - situations2960 - (f2958 (cdr when-list2959) - (cons (let ((x2961 (car when-list2959))) - (if (free-id=?2499 - x2961 + e541 + w543 + s544 + mod546) + (values (quote other) #f e541 w543 s544 mod546))))))) + (chi-when-list148 + (lambda (e594 when-list595 w596) + (letrec ((f597 (lambda (when-list598 situations599) + (if (null? when-list598) + situations599 + (f597 (cdr when-list598) + (cons (let ((x600 (car when-list598))) + (if (free-id=?138 + x600 + '#(syntax-object + compile + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(f + when-list + situations) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + decorate-source + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + 'compile + (if (free-id=?138 + x600 '#(syntax-object - compile + load ((top) #(ribcage () () ()) #(ribcage () () ()) @@ -3806,11 +4121,11 @@ ((top) (top)) ("i" "i"))) (hygiene guile))) - 'compile - (if (free-id=?2499 - x2961 + 'load + (if (free-id=?138 + x600 '#(syntax-object - load + eval ((top) #(ribcage () @@ -4195,2077 +4510,1604 @@ ((top) (top)) ("i" "i"))) (hygiene guile))) - 'load - (if (free-id=?2499 - x2961 - '#(syntax-object - eval - ((top) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - when-list - situations) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(e - when-list - w) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - (lambda-var-list - gen-var - strip - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - maybe-name-value! - build-global-assignment - build-global-reference - analyze-variable - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-void - decorate-source - get-global-definition-hook - put-global-definition-hook - gensym-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - *mode* - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure - and-map*) - ((top) (top)) - ("i" "i"))) - (hygiene - guile))) - 'eval - (syntax-violation - 'eval-when - "invalid situation" - e2955 - (wrap2504 - x2961 - w2957 - #f)))))) - situations2960)))))) - (f2958 when-list2956 (quote ()))))) - (chi-install-global2508 - (lambda (name2962 e2963) - (build-global-definition2451 + 'eval + (syntax-violation + 'eval-when + "invalid situation" + e594 + (wrap143 + x600 + w596 + #f)))))) + situations599)))))) + (f597 when-list595 (quote ()))))) + (chi-install-global147 + (lambda (name601 e602) + (build-global-definition90 #f - name2962 - (if (let ((v2964 (module-variable (current-module) name2962))) - (if v2964 - (if (variable-bound? v2964) - (if (macro? (variable-ref v2964)) - (not (eq? (macro-type (variable-ref v2964)) + name601 + (if (let ((v603 (module-variable (current-module) name601))) + (if v603 + (if (variable-bound? v603) + (if (macro? (variable-ref v603)) + (not (eq? (macro-type (variable-ref v603)) 'syncase-macro)) #f) #f) #f)) - (build-application2443 + (build-application82 #f - (build-primref2453 + (build-primref92 #f 'make-extended-syncase-macro) - (list (build-application2443 + (list (build-application82 #f - (build-primref2453 #f (quote module-ref)) - (list (build-application2443 + (build-primref92 #f (quote module-ref)) + (list (build-application82 #f - (build-primref2453 + (build-primref92 #f 'current-module) '()) - (build-data2454 #f name2962))) - (build-data2454 #f (quote macro)) - e2963)) - (build-application2443 + (build-data93 #f name601))) + (build-data93 #f (quote macro)) + e602)) + (build-application82 #f - (build-primref2453 #f (quote make-syncase-macro)) - (list (build-data2454 #f (quote macro)) e2963)))))) - (chi-top-sequence2507 - (lambda (body2965 - r2966 - w2967 - s2968 - m2969 - esew2970 - mod2971) - (build-sequence2455 - s2968 - (letrec ((dobody2972 - (lambda (body2973 - r2974 - w2975 - m2976 - esew2977 - mod2978) - (if (null? body2973) + (build-primref92 #f (quote make-syncase-macro)) + (list (build-data93 #f (quote macro)) e602)))))) + (chi-top-sequence146 + (lambda (body604 r605 w606 s607 m608 esew609 mod610) + (build-sequence94 + s607 + (letrec ((dobody611 + (lambda (body612 r613 w614 m615 esew616 mod617) + (if (null? body612) '() - (let ((first2979 - (chi-top2511 - (car body2973) - r2974 - w2975 - m2976 - esew2977 - mod2978))) - (cons first2979 - (dobody2972 - (cdr body2973) - r2974 - w2975 - m2976 - esew2977 - mod2978))))))) - (dobody2972 - body2965 - r2966 - w2967 - m2969 - esew2970 - mod2971))))) - (chi-sequence2506 - (lambda (body2980 r2981 w2982 s2983 mod2984) - (build-sequence2455 - s2983 - (letrec ((dobody2985 - (lambda (body2986 r2987 w2988 mod2989) - (if (null? body2986) + (let ((first618 + (chi-top150 + (car body612) + r613 + w614 + m615 + esew616 + mod617))) + (cons first618 + (dobody611 + (cdr body612) + r613 + w614 + m615 + esew616 + mod617))))))) + (dobody611 body604 r605 w606 m608 esew609 mod610))))) + (chi-sequence145 + (lambda (body619 r620 w621 s622 mod623) + (build-sequence94 + s622 + (letrec ((dobody624 + (lambda (body625 r626 w627 mod628) + (if (null? body625) '() - (let ((first2990 - (chi2512 - (car body2986) - r2987 - w2988 - mod2989))) - (cons first2990 - (dobody2985 - (cdr body2986) - r2987 - w2988 - mod2989))))))) - (dobody2985 body2980 r2981 w2982 mod2984))))) - (source-wrap2505 - (lambda (x2991 w2992 s2993 defmod2994) - (begin - (if (if s2993 (pair? x2991) #f) - (set-source-properties! x2991 s2993)) - (wrap2504 x2991 w2992 defmod2994)))) - (wrap2504 - (lambda (x2995 w2996 defmod2997) - (if (if (null? (wrap-marks2479 w2996)) - (null? (wrap-subst2480 w2996)) + (let ((first629 + (chi151 + (car body625) + r626 + w627 + mod628))) + (cons first629 + (dobody624 + (cdr body625) + r626 + w627 + mod628))))))) + (dobody624 body619 r620 w621 mod623))))) + (source-wrap144 + (lambda (x630 w631 s632 defmod633) + (wrap143 + (decorate-source80 x630 s632) + w631 + defmod633))) + (wrap143 + (lambda (x634 w635 defmod636) + (if (if (null? (wrap-marks118 w635)) + (null? (wrap-subst119 w635)) #f) - x2995 - (if (syntax-object?2460 x2995) - (make-syntax-object2459 - (syntax-object-expression2461 x2995) - (join-wraps2495 - w2996 - (syntax-object-wrap2462 x2995)) - (syntax-object-module2463 x2995)) - (if (null? x2995) - x2995 - (make-syntax-object2459 x2995 w2996 defmod2997)))))) - (bound-id-member?2503 - (lambda (x2998 list2999) - (if (not (null? list2999)) - (let ((t3000 (bound-id=?2500 x2998 (car list2999)))) - (if t3000 - t3000 - (bound-id-member?2503 x2998 (cdr list2999)))) + x634 + (if (syntax-object?99 x634) + (make-syntax-object98 + (syntax-object-expression100 x634) + (join-wraps134 w635 (syntax-object-wrap101 x634)) + (syntax-object-module102 x634)) + (if (null? x634) + x634 + (make-syntax-object98 x634 w635 defmod636)))))) + (bound-id-member?142 + (lambda (x637 list638) + (if (not (null? list638)) + (let ((t639 (bound-id=?139 x637 (car list638)))) + (if t639 + t639 + (bound-id-member?142 x637 (cdr list638)))) #f))) - (distinct-bound-ids?2502 - (lambda (ids3001) - (letrec ((distinct?3002 - (lambda (ids3003) - (let ((t3004 (null? ids3003))) - (if t3004 - t3004 - (if (not (bound-id-member?2503 - (car ids3003) - (cdr ids3003))) - (distinct?3002 (cdr ids3003)) + (distinct-bound-ids?141 + (lambda (ids640) + (letrec ((distinct?641 + (lambda (ids642) + (let ((t643 (null? ids642))) + (if t643 + t643 + (if (not (bound-id-member?142 + (car ids642) + (cdr ids642))) + (distinct?641 (cdr ids642)) #f)))))) - (distinct?3002 ids3001)))) - (valid-bound-ids?2501 - (lambda (ids3005) - (if (letrec ((all-ids?3006 - (lambda (ids3007) - (let ((t3008 (null? ids3007))) - (if t3008 - t3008 - (if (id?2476 (car ids3007)) - (all-ids?3006 (cdr ids3007)) + (distinct?641 ids640)))) + (valid-bound-ids?140 + (lambda (ids644) + (if (letrec ((all-ids?645 + (lambda (ids646) + (let ((t647 (null? ids646))) + (if t647 + t647 + (if (id?115 (car ids646)) + (all-ids?645 (cdr ids646)) #f)))))) - (all-ids?3006 ids3005)) - (distinct-bound-ids?2502 ids3005) + (all-ids?645 ids644)) + (distinct-bound-ids?141 ids644) #f))) - (bound-id=?2500 - (lambda (i3009 j3010) - (if (if (syntax-object?2460 i3009) - (syntax-object?2460 j3010) + (bound-id=?139 + (lambda (i648 j649) + (if (if (syntax-object?99 i648) + (syntax-object?99 j649) #f) - (if (eq? (syntax-object-expression2461 i3009) - (syntax-object-expression2461 j3010)) - (same-marks?2497 - (wrap-marks2479 (syntax-object-wrap2462 i3009)) - (wrap-marks2479 (syntax-object-wrap2462 j3010))) + (if (eq? (syntax-object-expression100 i648) + (syntax-object-expression100 j649)) + (same-marks?136 + (wrap-marks118 (syntax-object-wrap101 i648)) + (wrap-marks118 (syntax-object-wrap101 j649))) #f) - (eq? i3009 j3010)))) - (free-id=?2499 - (lambda (i3011 j3012) - (if (eq? (let ((x3013 i3011)) - (if (syntax-object?2460 x3013) - (syntax-object-expression2461 x3013) - x3013)) - (let ((x3014 j3012)) - (if (syntax-object?2460 x3014) - (syntax-object-expression2461 x3014) - x3014))) - (eq? (id-var-name2498 i3011 (quote (()))) - (id-var-name2498 j3012 (quote (())))) + (eq? i648 j649)))) + (free-id=?138 + (lambda (i650 j651) + (if (eq? (let ((x652 i650)) + (if (syntax-object?99 x652) + (syntax-object-expression100 x652) + x652)) + (let ((x653 j651)) + (if (syntax-object?99 x653) + (syntax-object-expression100 x653) + x653))) + (eq? (id-var-name137 i650 (quote (()))) + (id-var-name137 j651 (quote (())))) #f))) - (id-var-name2498 - (lambda (id3015 w3016) - (letrec ((search-vector-rib3019 - (lambda (sym3025 - subst3026 - marks3027 - symnames3028 - ribcage3029) - (let ((n3030 (vector-length symnames3028))) - (letrec ((f3031 (lambda (i3032) - (if (fx=2435 i3032 n3030) - (search3017 - sym3025 - (cdr subst3026) - marks3027) - (if (if (eq? (vector-ref - symnames3028 - i3032) - sym3025) - (same-marks?2497 - marks3027 - (vector-ref - (ribcage-marks2486 - ribcage3029) - i3032)) - #f) - (values - (vector-ref - (ribcage-labels2487 - ribcage3029) - i3032) - marks3027) - (f3031 (fx+2433 - i3032 - 1))))))) - (f3031 0))))) - (search-list-rib3018 - (lambda (sym3033 - subst3034 - marks3035 - symnames3036 - ribcage3037) - (letrec ((f3038 (lambda (symnames3039 i3040) - (if (null? symnames3039) - (search3017 - sym3033 - (cdr subst3034) - marks3035) - (if (if (eq? (car symnames3039) - sym3033) - (same-marks?2497 - marks3035 - (list-ref - (ribcage-marks2486 - ribcage3037) - i3040)) - #f) - (values - (list-ref - (ribcage-labels2487 - ribcage3037) - i3040) - marks3035) - (f3038 (cdr symnames3039) - (fx+2433 - i3040 - 1))))))) - (f3038 symnames3036 0)))) - (search3017 - (lambda (sym3041 subst3042 marks3043) - (if (null? subst3042) - (values #f marks3043) - (let ((fst3044 (car subst3042))) - (if (eq? fst3044 (quote shift)) - (search3017 - sym3041 - (cdr subst3042) - (cdr marks3043)) - (let ((symnames3045 - (ribcage-symnames2485 fst3044))) - (if (vector? symnames3045) - (search-vector-rib3019 - sym3041 - subst3042 - marks3043 - symnames3045 - fst3044) - (search-list-rib3018 - sym3041 - subst3042 - marks3043 - symnames3045 - fst3044))))))))) - (if (symbol? id3015) - (let ((t3046 (call-with-values - (lambda () - (search3017 - id3015 - (wrap-subst2480 w3016) - (wrap-marks2479 w3016))) - (lambda (x3048 . ignore3047) x3048)))) - (if t3046 t3046 id3015)) - (if (syntax-object?2460 id3015) - (let ((id3049 (syntax-object-expression2461 id3015)) - (w13050 (syntax-object-wrap2462 id3015))) - (let ((marks3051 - (join-marks2496 - (wrap-marks2479 w3016) - (wrap-marks2479 w13050)))) + (id-var-name137 + (lambda (id654 w655) + (letrec ((search-vector-rib658 + (lambda (sym664 + subst665 + marks666 + symnames667 + ribcage668) + (let ((n669 (vector-length symnames667))) + (letrec ((f670 (lambda (i671) + (if (fx=74 i671 n669) + (search656 + sym664 + (cdr subst665) + marks666) + (if (if (eq? (vector-ref + symnames667 + i671) + sym664) + (same-marks?136 + marks666 + (vector-ref + (ribcage-marks125 + ribcage668) + i671)) + #f) + (values + (vector-ref + (ribcage-labels126 + ribcage668) + i671) + marks666) + (f670 (fx+72 i671 1))))))) + (f670 0))))) + (search-list-rib657 + (lambda (sym672 + subst673 + marks674 + symnames675 + ribcage676) + (letrec ((f677 (lambda (symnames678 i679) + (if (null? symnames678) + (search656 + sym672 + (cdr subst673) + marks674) + (if (if (eq? (car symnames678) + sym672) + (same-marks?136 + marks674 + (list-ref + (ribcage-marks125 + ribcage676) + i679)) + #f) + (values + (list-ref + (ribcage-labels126 + ribcage676) + i679) + marks674) + (f677 (cdr symnames678) + (fx+72 i679 1))))))) + (f677 symnames675 0)))) + (search656 + (lambda (sym680 subst681 marks682) + (if (null? subst681) + (values #f marks682) + (let ((fst683 (car subst681))) + (if (eq? fst683 (quote shift)) + (search656 + sym680 + (cdr subst681) + (cdr marks682)) + (let ((symnames684 + (ribcage-symnames124 fst683))) + (if (vector? symnames684) + (search-vector-rib658 + sym680 + subst681 + marks682 + symnames684 + fst683) + (search-list-rib657 + sym680 + subst681 + marks682 + symnames684 + fst683))))))))) + (if (symbol? id654) + (let ((t685 (call-with-values + (lambda () + (search656 + id654 + (wrap-subst119 w655) + (wrap-marks118 w655))) + (lambda (x687 . ignore686) x687)))) + (if t685 t685 id654)) + (if (syntax-object?99 id654) + (let ((id688 (syntax-object-expression100 id654)) + (w1689 (syntax-object-wrap101 id654))) + (let ((marks690 + (join-marks135 + (wrap-marks118 w655) + (wrap-marks118 w1689)))) (call-with-values (lambda () - (search3017 - id3049 - (wrap-subst2480 w3016) - marks3051)) - (lambda (new-id3052 marks3053) - (let ((t3054 new-id3052)) - (if t3054 - t3054 - (let ((t3055 (call-with-values - (lambda () - (search3017 - id3049 - (wrap-subst2480 w13050) - marks3053)) - (lambda (x3057 . ignore3056) - x3057)))) - (if t3055 t3055 id3049)))))))) + (search656 id688 (wrap-subst119 w655) marks690)) + (lambda (new-id691 marks692) + (let ((t693 new-id691)) + (if t693 + t693 + (let ((t694 (call-with-values + (lambda () + (search656 + id688 + (wrap-subst119 w1689) + marks692)) + (lambda (x696 . ignore695) + x696)))) + (if t694 t694 id688)))))))) (syntax-violation 'id-var-name "invalid id" - id3015)))))) - (same-marks?2497 - (lambda (x3058 y3059) - (let ((t3060 (eq? x3058 y3059))) - (if t3060 - t3060 - (if (not (null? x3058)) - (if (not (null? y3059)) - (if (eq? (car x3058) (car y3059)) - (same-marks?2497 (cdr x3058) (cdr y3059)) + id654)))))) + (same-marks?136 + (lambda (x697 y698) + (let ((t699 (eq? x697 y698))) + (if t699 + t699 + (if (not (null? x697)) + (if (not (null? y698)) + (if (eq? (car x697) (car y698)) + (same-marks?136 (cdr x697) (cdr y698)) #f) #f) #f))))) - (join-marks2496 - (lambda (m13061 m23062) - (smart-append2494 m13061 m23062))) - (join-wraps2495 - (lambda (w13063 w23064) - (let ((m13065 (wrap-marks2479 w13063)) - (s13066 (wrap-subst2480 w13063))) - (if (null? m13065) - (if (null? s13066) - w23064 - (make-wrap2478 - (wrap-marks2479 w23064) - (smart-append2494 s13066 (wrap-subst2480 w23064)))) - (make-wrap2478 - (smart-append2494 m13065 (wrap-marks2479 w23064)) - (smart-append2494 s13066 (wrap-subst2480 w23064))))))) - (smart-append2494 - (lambda (m13067 m23068) - (if (null? m23068) m13067 (append m13067 m23068)))) - (make-binding-wrap2493 - (lambda (ids3069 labels3070 w3071) - (if (null? ids3069) - w3071 - (make-wrap2478 - (wrap-marks2479 w3071) - (cons (let ((labelvec3072 (list->vector labels3070))) - (let ((n3073 (vector-length labelvec3072))) - (let ((symnamevec3074 (make-vector n3073)) - (marksvec3075 (make-vector n3073))) + (join-marks135 + (lambda (m1700 m2701) + (smart-append133 m1700 m2701))) + (join-wraps134 + (lambda (w1702 w2703) + (let ((m1704 (wrap-marks118 w1702)) + (s1705 (wrap-subst119 w1702))) + (if (null? m1704) + (if (null? s1705) + w2703 + (make-wrap117 + (wrap-marks118 w2703) + (smart-append133 s1705 (wrap-subst119 w2703)))) + (make-wrap117 + (smart-append133 m1704 (wrap-marks118 w2703)) + (smart-append133 s1705 (wrap-subst119 w2703))))))) + (smart-append133 + (lambda (m1706 m2707) + (if (null? m2707) m1706 (append m1706 m2707)))) + (make-binding-wrap132 + (lambda (ids708 labels709 w710) + (if (null? ids708) + w710 + (make-wrap117 + (wrap-marks118 w710) + (cons (let ((labelvec711 (list->vector labels709))) + (let ((n712 (vector-length labelvec711))) + (let ((symnamevec713 (make-vector n712)) + (marksvec714 (make-vector n712))) (begin - (letrec ((f3076 (lambda (ids3077 i3078) - (if (not (null? ids3077)) - (call-with-values - (lambda () - (id-sym-name&marks2477 - (car ids3077) - w3071)) - (lambda (symname3079 - marks3080) - (begin - (vector-set! - symnamevec3074 - i3078 - symname3079) - (vector-set! - marksvec3075 - i3078 - marks3080) - (f3076 (cdr ids3077) - (fx+2433 - i3078 - 1))))))))) - (f3076 ids3069 0)) - (make-ribcage2483 - symnamevec3074 - marksvec3075 - labelvec3072))))) - (wrap-subst2480 w3071)))))) - (extend-ribcage!2492 - (lambda (ribcage3081 id3082 label3083) + (letrec ((f715 (lambda (ids716 i717) + (if (not (null? ids716)) + (call-with-values + (lambda () + (id-sym-name&marks116 + (car ids716) + w710)) + (lambda (symname718 + marks719) + (begin + (vector-set! + symnamevec713 + i717 + symname718) + (vector-set! + marksvec714 + i717 + marks719) + (f715 (cdr ids716) + (fx+72 i717 + 1))))))))) + (f715 ids708 0)) + (make-ribcage122 + symnamevec713 + marksvec714 + labelvec711))))) + (wrap-subst119 w710)))))) + (extend-ribcage!131 + (lambda (ribcage720 id721 label722) (begin - (set-ribcage-symnames!2488 - ribcage3081 - (cons (syntax-object-expression2461 id3082) - (ribcage-symnames2485 ribcage3081))) - (set-ribcage-marks!2489 - ribcage3081 - (cons (wrap-marks2479 (syntax-object-wrap2462 id3082)) - (ribcage-marks2486 ribcage3081))) - (set-ribcage-labels!2490 - ribcage3081 - (cons label3083 (ribcage-labels2487 ribcage3081)))))) - (anti-mark2491 - (lambda (w3084) - (make-wrap2478 - (cons #f (wrap-marks2479 w3084)) - (cons (quote shift) (wrap-subst2480 w3084))))) - (set-ribcage-labels!2490 - (lambda (x3085 update3086) - (vector-set! x3085 3 update3086))) - (set-ribcage-marks!2489 - (lambda (x3087 update3088) - (vector-set! x3087 2 update3088))) - (set-ribcage-symnames!2488 - (lambda (x3089 update3090) - (vector-set! x3089 1 update3090))) - (ribcage-labels2487 - (lambda (x3091) (vector-ref x3091 3))) - (ribcage-marks2486 - (lambda (x3092) (vector-ref x3092 2))) - (ribcage-symnames2485 - (lambda (x3093) (vector-ref x3093 1))) - (ribcage?2484 - (lambda (x3094) - (if (vector? x3094) - (if (= (vector-length x3094) 4) - (eq? (vector-ref x3094 0) (quote ribcage)) + (set-ribcage-symnames!127 + ribcage720 + (cons (syntax-object-expression100 id721) + (ribcage-symnames124 ribcage720))) + (set-ribcage-marks!128 + ribcage720 + (cons (wrap-marks118 (syntax-object-wrap101 id721)) + (ribcage-marks125 ribcage720))) + (set-ribcage-labels!129 + ribcage720 + (cons label722 (ribcage-labels126 ribcage720)))))) + (anti-mark130 + (lambda (w723) + (make-wrap117 + (cons #f (wrap-marks118 w723)) + (cons (quote shift) (wrap-subst119 w723))))) + (set-ribcage-labels!129 + (lambda (x724 update725) + (vector-set! x724 3 update725))) + (set-ribcage-marks!128 + (lambda (x726 update727) + (vector-set! x726 2 update727))) + (set-ribcage-symnames!127 + (lambda (x728 update729) + (vector-set! x728 1 update729))) + (ribcage-labels126 + (lambda (x730) (vector-ref x730 3))) + (ribcage-marks125 + (lambda (x731) (vector-ref x731 2))) + (ribcage-symnames124 + (lambda (x732) (vector-ref x732 1))) + (ribcage?123 + (lambda (x733) + (if (vector? x733) + (if (= (vector-length x733) 4) + (eq? (vector-ref x733 0) (quote ribcage)) #f) #f))) - (make-ribcage2483 - (lambda (symnames3095 marks3096 labels3097) + (make-ribcage122 + (lambda (symnames734 marks735 labels736) (vector 'ribcage - symnames3095 - marks3096 - labels3097))) - (gen-labels2482 - (lambda (ls3098) - (if (null? ls3098) + symnames734 + marks735 + labels736))) + (gen-labels121 + (lambda (ls737) + (if (null? ls737) '() - (cons (gen-label2481) - (gen-labels2482 (cdr ls3098)))))) - (gen-label2481 (lambda () (string #\i))) - (wrap-subst2480 cdr) - (wrap-marks2479 car) - (make-wrap2478 cons) - (id-sym-name&marks2477 - (lambda (x3099 w3100) - (if (syntax-object?2460 x3099) + (cons (gen-label120) (gen-labels121 (cdr ls737)))))) + (gen-label120 (lambda () (string #\i))) + (wrap-subst119 cdr) + (wrap-marks118 car) + (make-wrap117 cons) + (id-sym-name&marks116 + (lambda (x738 w739) + (if (syntax-object?99 x738) (values - (syntax-object-expression2461 x3099) - (join-marks2496 - (wrap-marks2479 w3100) - (wrap-marks2479 (syntax-object-wrap2462 x3099)))) - (values x3099 (wrap-marks2479 w3100))))) - (id?2476 - (lambda (x3101) - (if (symbol? x3101) + (syntax-object-expression100 x738) + (join-marks135 + (wrap-marks118 w739) + (wrap-marks118 (syntax-object-wrap101 x738)))) + (values x738 (wrap-marks118 w739))))) + (id?115 + (lambda (x740) + (if (symbol? x740) #t - (if (syntax-object?2460 x3101) - (symbol? (syntax-object-expression2461 x3101)) + (if (syntax-object?99 x740) + (symbol? (syntax-object-expression100 x740)) #f)))) - (nonsymbol-id?2475 - (lambda (x3102) - (if (syntax-object?2460 x3102) - (symbol? (syntax-object-expression2461 x3102)) + (nonsymbol-id?114 + (lambda (x741) + (if (syntax-object?99 x741) + (symbol? (syntax-object-expression100 x741)) #f))) - (global-extend2474 - (lambda (type3103 sym3104 val3105) - (put-global-definition-hook2439 - sym3104 - type3103 - val3105))) - (lookup2473 - (lambda (x3106 r3107 mod3108) - (let ((t3109 (assq x3106 r3107))) - (if t3109 - (cdr t3109) - (if (symbol? x3106) - (let ((t3110 (get-global-definition-hook2440 - x3106 - mod3108))) - (if t3110 t3110 (quote (global)))) + (global-extend113 + (lambda (type742 sym743 val744) + (put-global-definition-hook78 + sym743 + type742 + val744))) + (lookup112 + (lambda (x745 r746 mod747) + (let ((t748 (assq x745 r746))) + (if t748 + (cdr t748) + (if (symbol? x745) + (let ((t749 (get-global-definition-hook79 x745 mod747))) + (if t749 t749 (quote (global)))) '(displaced-lexical)))))) - (macros-only-env2472 - (lambda (r3111) - (if (null? r3111) + (macros-only-env111 + (lambda (r750) + (if (null? r750) '() - (let ((a3112 (car r3111))) - (if (eq? (cadr a3112) (quote macro)) - (cons a3112 (macros-only-env2472 (cdr r3111))) - (macros-only-env2472 (cdr r3111))))))) - (extend-var-env2471 - (lambda (labels3113 vars3114 r3115) - (if (null? labels3113) - r3115 - (extend-var-env2471 - (cdr labels3113) - (cdr vars3114) - (cons (cons (car labels3113) - (cons (quote lexical) (car vars3114))) - r3115))))) - (extend-env2470 - (lambda (labels3116 bindings3117 r3118) - (if (null? labels3116) - r3118 - (extend-env2470 - (cdr labels3116) - (cdr bindings3117) - (cons (cons (car labels3116) (car bindings3117)) - r3118))))) - (binding-value2469 cdr) - (binding-type2468 car) - (source-annotation2467 - (lambda (x3119) - (if (syntax-object?2460 x3119) - (source-annotation2467 - (syntax-object-expression2461 x3119)) - (if (pair? x3119) - (let ((props3120 (source-properties x3119))) - (if (pair? props3120) props3120 #f)) + (let ((a751 (car r750))) + (if (eq? (cadr a751) (quote macro)) + (cons a751 (macros-only-env111 (cdr r750))) + (macros-only-env111 (cdr r750))))))) + (extend-var-env110 + (lambda (labels752 vars753 r754) + (if (null? labels752) + r754 + (extend-var-env110 + (cdr labels752) + (cdr vars753) + (cons (cons (car labels752) + (cons (quote lexical) (car vars753))) + r754))))) + (extend-env109 + (lambda (labels755 bindings756 r757) + (if (null? labels755) + r757 + (extend-env109 + (cdr labels755) + (cdr bindings756) + (cons (cons (car labels755) (car bindings756)) + r757))))) + (binding-value108 cdr) + (binding-type107 car) + (source-annotation106 + (lambda (x758) + (if (syntax-object?99 x758) + (source-annotation106 + (syntax-object-expression100 x758)) + (if (pair? x758) + (let ((props759 (source-properties x758))) + (if (pair? props759) props759 #f)) #f)))) - (set-syntax-object-module!2466 - (lambda (x3121 update3122) - (vector-set! x3121 3 update3122))) - (set-syntax-object-wrap!2465 - (lambda (x3123 update3124) - (vector-set! x3123 2 update3124))) - (set-syntax-object-expression!2464 - (lambda (x3125 update3126) - (vector-set! x3125 1 update3126))) - (syntax-object-module2463 - (lambda (x3127) (vector-ref x3127 3))) - (syntax-object-wrap2462 - (lambda (x3128) (vector-ref x3128 2))) - (syntax-object-expression2461 - (lambda (x3129) (vector-ref x3129 1))) - (syntax-object?2460 - (lambda (x3130) - (if (vector? x3130) - (if (= (vector-length x3130) 4) - (eq? (vector-ref x3130 0) (quote syntax-object)) + (set-syntax-object-module!105 + (lambda (x760 update761) + (vector-set! x760 3 update761))) + (set-syntax-object-wrap!104 + (lambda (x762 update763) + (vector-set! x762 2 update763))) + (set-syntax-object-expression!103 + (lambda (x764 update765) + (vector-set! x764 1 update765))) + (syntax-object-module102 + (lambda (x766) (vector-ref x766 3))) + (syntax-object-wrap101 + (lambda (x767) (vector-ref x767 2))) + (syntax-object-expression100 + (lambda (x768) (vector-ref x768 1))) + (syntax-object?99 + (lambda (x769) + (if (vector? x769) + (if (= (vector-length x769) 4) + (eq? (vector-ref x769 0) (quote syntax-object)) #f) #f))) - (make-syntax-object2459 - (lambda (expression3131 wrap3132 module3133) + (make-syntax-object98 + (lambda (expression770 wrap771 module772) (vector 'syntax-object - expression3131 - wrap3132 - module3133))) - (build-letrec2458 - (lambda (src3134 - ids3135 - vars3136 - val-exps3137 - body-exp3138) - (if (null? vars3136) - body-exp3138 - (let ((atom-key3139 (fluid-ref *mode*2432))) - (if (memv atom-key3139 (quote (c))) + expression770 + wrap771 + module772))) + (build-letrec97 + (lambda (src773 ids774 vars775 val-exps776 body-exp777) + (if (null? vars775) + body-exp777 + (let ((atom-key778 (fluid-ref *mode*71))) + (if (memv atom-key778 (quote (c))) (begin - (for-each - maybe-name-value!2450 - ids3135 - val-exps3137) + (for-each maybe-name-value!89 ids774 val-exps776) ((@ (language tree-il) make-letrec) - src3134 - ids3135 - vars3136 - val-exps3137 - body-exp3138)) - (decorate-source2441 + src773 + ids774 + vars775 + val-exps776 + body-exp777)) + (decorate-source80 (list 'letrec - (map list vars3136 val-exps3137) - body-exp3138) - src3134)))))) - (build-named-let2457 - (lambda (src3140 - ids3141 - vars3142 - val-exps3143 - body-exp3144) - (let ((f3145 (car vars3142)) - (f-name3146 (car ids3141)) - (vars3147 (cdr vars3142)) - (ids3148 (cdr ids3141))) - (let ((atom-key3149 (fluid-ref *mode*2432))) - (if (memv atom-key3149 (quote (c))) - (let ((proc3150 - (build-lambda2452 - src3140 - ids3148 - vars3147 + (map list vars775 val-exps776) + body-exp777) + src773)))))) + (build-named-let96 + (lambda (src779 ids780 vars781 val-exps782 body-exp783) + (let ((f784 (car vars781)) + (f-name785 (car ids780)) + (vars786 (cdr vars781)) + (ids787 (cdr ids780))) + (let ((atom-key788 (fluid-ref *mode*71))) + (if (memv atom-key788 (quote (c))) + (let ((proc789 + (build-lambda91 + src779 + ids787 + vars786 #f - body-exp3144))) + body-exp783))) (begin - (maybe-name-value!2450 f-name3146 proc3150) - (for-each - maybe-name-value!2450 - ids3148 - val-exps3143) + (maybe-name-value!89 f-name785 proc789) + (for-each maybe-name-value!89 ids787 val-exps782) ((@ (language tree-il) make-letrec) - src3140 - (list f-name3146) - (list f3145) - (list proc3150) - (build-application2443 - src3140 - (build-lexical-reference2445 + src779 + (list f-name785) + (list f784) + (list proc789) + (build-application82 + src779 + (build-lexical-reference84 'fun - src3140 - f-name3146 - f3145) - val-exps3143)))) - (decorate-source2441 + src779 + f-name785 + f784) + val-exps782)))) + (decorate-source80 (list 'let - f3145 - (map list vars3147 val-exps3143) - body-exp3144) - src3140)))))) - (build-let2456 - (lambda (src3151 - ids3152 - vars3153 - val-exps3154 - body-exp3155) - (if (null? vars3153) - body-exp3155 - (let ((atom-key3156 (fluid-ref *mode*2432))) - (if (memv atom-key3156 (quote (c))) + f784 + (map list vars786 val-exps782) + body-exp783) + src779)))))) + (build-let95 + (lambda (src790 ids791 vars792 val-exps793 body-exp794) + (if (null? vars792) + body-exp794 + (let ((atom-key795 (fluid-ref *mode*71))) + (if (memv atom-key795 (quote (c))) (begin - (for-each - maybe-name-value!2450 - ids3152 - val-exps3154) + (for-each maybe-name-value!89 ids791 val-exps793) ((@ (language tree-il) make-let) - src3151 - ids3152 - vars3153 - val-exps3154 - body-exp3155)) - (decorate-source2441 + src790 + ids791 + vars792 + val-exps793 + body-exp794)) + (decorate-source80 (list 'let - (map list vars3153 val-exps3154) - body-exp3155) - src3151)))))) - (build-sequence2455 - (lambda (src3157 exps3158) - (if (null? (cdr exps3158)) - (car exps3158) - (let ((atom-key3159 (fluid-ref *mode*2432))) - (if (memv atom-key3159 (quote (c))) + (map list vars792 val-exps793) + body-exp794) + src790)))))) + (build-sequence94 + (lambda (src796 exps797) + (if (null? (cdr exps797)) + (car exps797) + (let ((atom-key798 (fluid-ref *mode*71))) + (if (memv atom-key798 (quote (c))) ((@ (language tree-il) make-sequence) - src3157 - exps3158) - (decorate-source2441 - (cons (quote begin) exps3158) - src3157)))))) - (build-data2454 - (lambda (src3160 exp3161) - (let ((atom-key3162 (fluid-ref *mode*2432))) - (if (memv atom-key3162 (quote (c))) - ((@ (language tree-il) make-const) - src3160 - exp3161) - (decorate-source2441 - (if (if (self-evaluating? exp3161) - (not (vector? exp3161)) + src796 + exps797) + (decorate-source80 + (cons (quote begin) exps797) + src796)))))) + (build-data93 + (lambda (src799 exp800) + (let ((atom-key801 (fluid-ref *mode*71))) + (if (memv atom-key801 (quote (c))) + ((@ (language tree-il) make-const) src799 exp800) + (decorate-source80 + (if (if (self-evaluating? exp800) + (not (vector? exp800)) #f) - exp3161 - (list (quote quote) exp3161)) - src3160))))) - (build-primref2453 - (lambda (src3163 name3164) + exp800 + (list (quote quote) exp800)) + src799))))) + (build-primref92 + (lambda (src802 name803) (if (equal? (module-name (current-module)) '(guile)) - (let ((atom-key3165 (fluid-ref *mode*2432))) - (if (memv atom-key3165 (quote (c))) + (let ((atom-key804 (fluid-ref *mode*71))) + (if (memv atom-key804 (quote (c))) ((@ (language tree-il) make-toplevel-ref) - src3163 - name3164) - (decorate-source2441 name3164 src3163))) - (let ((atom-key3166 (fluid-ref *mode*2432))) - (if (memv atom-key3166 (quote (c))) + src802 + name803) + (decorate-source80 name803 src802))) + (let ((atom-key805 (fluid-ref *mode*71))) + (if (memv atom-key805 (quote (c))) ((@ (language tree-il) make-module-ref) - src3163 + src802 '(guile) - name3164 + name803 #f) - (decorate-source2441 - (list (quote @@) (quote (guile)) name3164) - src3163)))))) - (build-lambda2452 - (lambda (src3167 ids3168 vars3169 docstring3170 exp3171) - (let ((atom-key3172 (fluid-ref *mode*2432))) - (if (memv atom-key3172 (quote (c))) + (decorate-source80 + (list (quote @@) (quote (guile)) name803) + src802)))))) + (build-lambda91 + (lambda (src806 ids807 vars808 docstring809 exp810) + (let ((atom-key811 (fluid-ref *mode*71))) + (if (memv atom-key811 (quote (c))) ((@ (language tree-il) make-lambda) - src3167 - ids3168 - vars3169 - (if docstring3170 - (list (cons (quote documentation) docstring3170)) + src806 + ids807 + vars808 + (if docstring809 + (list (cons (quote documentation) docstring809)) '()) - exp3171) - (decorate-source2441 + exp810) + (decorate-source80 (cons 'lambda - (cons vars3169 + (cons vars808 (append - (if docstring3170 - (list docstring3170) + (if docstring809 + (list docstring809) '()) - (list exp3171)))) - src3167))))) - (build-global-definition2451 - (lambda (source3173 var3174 exp3175) - (let ((atom-key3176 (fluid-ref *mode*2432))) - (if (memv atom-key3176 (quote (c))) + (list exp810)))) + src806))))) + (build-global-definition90 + (lambda (source812 var813 exp814) + (let ((atom-key815 (fluid-ref *mode*71))) + (if (memv atom-key815 (quote (c))) (begin - (maybe-name-value!2450 var3174 exp3175) + (maybe-name-value!89 var813 exp814) ((@ (language tree-il) make-toplevel-define) - source3173 - var3174 - exp3175)) - (decorate-source2441 - (list (quote define) var3174 exp3175) - source3173))))) - (maybe-name-value!2450 - (lambda (name3177 val3178) - (if ((@ (language tree-il) lambda?) val3178) - (let ((meta3179 - ((@ (language tree-il) lambda-meta) val3178))) - (if (not (assq (quote name) meta3179)) + source812 + var813 + exp814)) + (decorate-source80 + (list (quote define) var813 exp814) + source812))))) + (maybe-name-value!89 + (lambda (name816 val817) + (if ((@ (language tree-il) lambda?) val817) + (let ((meta818 + ((@ (language tree-il) lambda-meta) val817))) + (if (not (assq (quote name) meta818)) ((setter (@ (language tree-il) lambda-meta)) - val3178 - (acons (quote name) name3177 meta3179))))))) - (build-global-assignment2449 - (lambda (source3180 var3181 exp3182 mod3183) - (analyze-variable2447 - mod3183 - var3181 - (lambda (mod3184 var3185 public?3186) - (let ((atom-key3187 (fluid-ref *mode*2432))) - (if (memv atom-key3187 (quote (c))) + val817 + (acons (quote name) name816 meta818))))))) + (build-global-assignment88 + (lambda (source819 var820 exp821 mod822) + (analyze-variable86 + mod822 + var820 + (lambda (mod823 var824 public?825) + (let ((atom-key826 (fluid-ref *mode*71))) + (if (memv atom-key826 (quote (c))) ((@ (language tree-il) make-module-set) - source3180 - mod3184 - var3185 - public?3186 - exp3182) - (decorate-source2441 + source819 + mod823 + var824 + public?825 + exp821) + (decorate-source80 (list 'set! - (list (if public?3186 (quote @) (quote @@)) - mod3184 - var3185) - exp3182) - source3180)))) - (lambda (var3188) - (let ((atom-key3189 (fluid-ref *mode*2432))) - (if (memv atom-key3189 (quote (c))) + (list (if public?825 (quote @) (quote @@)) + mod823 + var824) + exp821) + source819)))) + (lambda (var827) + (let ((atom-key828 (fluid-ref *mode*71))) + (if (memv atom-key828 (quote (c))) ((@ (language tree-il) make-toplevel-set) - source3180 - var3188 - exp3182) - (decorate-source2441 - (list (quote set!) var3188 exp3182) - source3180))))))) - (build-global-reference2448 - (lambda (source3190 var3191 mod3192) - (analyze-variable2447 - mod3192 - var3191 - (lambda (mod3193 var3194 public?3195) - (let ((atom-key3196 (fluid-ref *mode*2432))) - (if (memv atom-key3196 (quote (c))) + source819 + var827 + exp821) + (decorate-source80 + (list (quote set!) var827 exp821) + source819))))))) + (build-global-reference87 + (lambda (source829 var830 mod831) + (analyze-variable86 + mod831 + var830 + (lambda (mod832 var833 public?834) + (let ((atom-key835 (fluid-ref *mode*71))) + (if (memv atom-key835 (quote (c))) ((@ (language tree-il) make-module-ref) - source3190 - mod3193 - var3194 - public?3195) - (decorate-source2441 - (list (if public?3195 (quote @) (quote @@)) - mod3193 - var3194) - source3190)))) - (lambda (var3197) - (let ((atom-key3198 (fluid-ref *mode*2432))) - (if (memv atom-key3198 (quote (c))) + source829 + mod832 + var833 + public?834) + (decorate-source80 + (list (if public?834 (quote @) (quote @@)) + mod832 + var833) + source829)))) + (lambda (var836) + (let ((atom-key837 (fluid-ref *mode*71))) + (if (memv atom-key837 (quote (c))) ((@ (language tree-il) make-toplevel-ref) - source3190 - var3197) - (decorate-source2441 var3197 source3190))))))) - (analyze-variable2447 - (lambda (mod3199 var3200 modref-cont3201 bare-cont3202) - (if (not mod3199) - (bare-cont3202 var3200) - (let ((kind3203 (car mod3199)) - (mod3204 (cdr mod3199))) - (if (memv kind3203 (quote (public))) - (modref-cont3201 mod3204 var3200 #t) - (if (memv kind3203 (quote (private))) - (if (not (equal? - mod3204 - (module-name (current-module)))) - (modref-cont3201 mod3204 var3200 #f) - (bare-cont3202 var3200)) - (if (memv kind3203 (quote (bare))) - (bare-cont3202 var3200) - (if (memv kind3203 (quote (hygiene))) + source829 + var836) + (decorate-source80 var836 source829))))))) + (analyze-variable86 + (lambda (mod838 var839 modref-cont840 bare-cont841) + (if (not mod838) + (bare-cont841 var839) + (let ((kind842 (car mod838)) (mod843 (cdr mod838))) + (if (memv kind842 (quote (public))) + (modref-cont840 mod843 var839 #t) + (if (memv kind842 (quote (private))) + (if (not (equal? mod843 (module-name (current-module)))) + (modref-cont840 mod843 var839 #f) + (bare-cont841 var839)) + (if (memv kind842 (quote (bare))) + (bare-cont841 var839) + (if (memv kind842 (quote (hygiene))) (if (if (not (equal? - mod3204 + mod843 (module-name (current-module)))) (module-variable - (resolve-module mod3204) - var3200) + (resolve-module mod843) + var839) #f) - (modref-cont3201 mod3204 var3200 #f) - (bare-cont3202 var3200)) + (modref-cont840 mod843 var839 #f) + (bare-cont841 var839)) (syntax-violation #f "bad module kind" - var3200 - mod3204))))))))) - (build-lexical-assignment2446 - (lambda (source3205 name3206 var3207 exp3208) - (let ((atom-key3209 (fluid-ref *mode*2432))) - (if (memv atom-key3209 (quote (c))) + var839 + mod843))))))))) + (build-lexical-assignment85 + (lambda (source844 name845 var846 exp847) + (let ((atom-key848 (fluid-ref *mode*71))) + (if (memv atom-key848 (quote (c))) ((@ (language tree-il) make-lexical-set) - source3205 - name3206 - var3207 - exp3208) - (decorate-source2441 - (list (quote set!) var3207 exp3208) - source3205))))) - (build-lexical-reference2445 - (lambda (type3210 source3211 name3212 var3213) - (let ((atom-key3214 (fluid-ref *mode*2432))) - (if (memv atom-key3214 (quote (c))) + source844 + name845 + var846 + exp847) + (decorate-source80 + (list (quote set!) var846 exp847) + source844))))) + (build-lexical-reference84 + (lambda (type849 source850 name851 var852) + (let ((atom-key853 (fluid-ref *mode*71))) + (if (memv atom-key853 (quote (c))) ((@ (language tree-il) make-lexical-ref) - source3211 - name3212 - var3213) - (decorate-source2441 var3213 source3211))))) - (build-conditional2444 - (lambda (source3215 - test-exp3216 - then-exp3217 - else-exp3218) - (let ((atom-key3219 (fluid-ref *mode*2432))) - (if (memv atom-key3219 (quote (c))) + source850 + name851 + var852) + (decorate-source80 var852 source850))))) + (build-conditional83 + (lambda (source854 test-exp855 then-exp856 else-exp857) + (let ((atom-key858 (fluid-ref *mode*71))) + (if (memv atom-key858 (quote (c))) ((@ (language tree-il) make-conditional) - source3215 - test-exp3216 - then-exp3217 - else-exp3218) - (decorate-source2441 - (if (equal? else-exp3218 (quote (if #f #f))) - (list (quote if) test-exp3216 then-exp3217) + source854 + test-exp855 + then-exp856 + else-exp857) + (decorate-source80 + (if (equal? else-exp857 (quote (if #f #f))) + (list (quote if) test-exp855 then-exp856) (list 'if - test-exp3216 - then-exp3217 - else-exp3218)) - source3215))))) - (build-application2443 - (lambda (source3220 fun-exp3221 arg-exps3222) - (let ((atom-key3223 (fluid-ref *mode*2432))) - (if (memv atom-key3223 (quote (c))) + test-exp855 + then-exp856 + else-exp857)) + source854))))) + (build-application82 + (lambda (source859 fun-exp860 arg-exps861) + (let ((atom-key862 (fluid-ref *mode*71))) + (if (memv atom-key862 (quote (c))) ((@ (language tree-il) make-application) - source3220 - fun-exp3221 - arg-exps3222) - (decorate-source2441 - (cons fun-exp3221 arg-exps3222) - source3220))))) - (build-void2442 - (lambda (source3224) - (let ((atom-key3225 (fluid-ref *mode*2432))) - (if (memv atom-key3225 (quote (c))) - ((@ (language tree-il) make-void) source3224) - (decorate-source2441 - '(if #f #f) - source3224))))) - (decorate-source2441 - (lambda (e3226 s3227) + source859 + fun-exp860 + arg-exps861) + (decorate-source80 + (cons fun-exp860 arg-exps861) + source859))))) + (build-void81 + (lambda (source863) + (let ((atom-key864 (fluid-ref *mode*71))) + (if (memv atom-key864 (quote (c))) + ((@ (language tree-il) make-void) source863) + (decorate-source80 (quote (if #f #f)) source863))))) + (decorate-source80 + (lambda (e865 s866) (begin - (if (if (pair? e3226) s3227 #f) - (set-source-properties! e3226 s3227)) - e3226))) - (get-global-definition-hook2440 - (lambda (symbol3228 module3229) + (if (if (pair? e865) s866 #f) + (set-source-properties! e865 s866)) + e865))) + (get-global-definition-hook79 + (lambda (symbol867 module868) (begin - (if (if (not module3229) (current-module) #f) + (if (if (not module868) (current-module) #f) (warn "module system is booted, we should have a module" - symbol3228)) - (let ((v3230 (module-variable - (if module3229 - (resolve-module (cdr module3229)) - (current-module)) - symbol3228))) - (if v3230 - (if (variable-bound? v3230) - (let ((val3231 (variable-ref v3230))) - (if (macro? val3231) - (if (syncase-macro-type val3231) - (cons (syncase-macro-type val3231) - (syncase-macro-binding val3231)) + symbol867)) + (let ((v869 (module-variable + (if module868 + (resolve-module (cdr module868)) + (current-module)) + symbol867))) + (if v869 + (if (variable-bound? v869) + (let ((val870 (variable-ref v869))) + (if (macro? val870) + (if (syncase-macro-type val870) + (cons (syncase-macro-type val870) + (syncase-macro-binding val870)) #f) #f)) #f) #f))))) - (put-global-definition-hook2439 - (lambda (symbol3232 type3233 val3234) - (let ((existing3235 - (let ((v3236 (module-variable - (current-module) - symbol3232))) - (if v3236 - (if (variable-bound? v3236) - (let ((val3237 (variable-ref v3236))) - (if (macro? val3237) - (if (not (syncase-macro-type val3237)) - val3237 + (put-global-definition-hook78 + (lambda (symbol871 type872 val873) + (let ((existing874 + (let ((v875 (module-variable + (current-module) + symbol871))) + (if v875 + (if (variable-bound? v875) + (let ((val876 (variable-ref v875))) + (if (macro? val876) + (if (not (syncase-macro-type val876)) + val876 #f) #f)) #f) #f)))) (module-define! (current-module) - symbol3232 - (if existing3235 + symbol871 + (if existing874 (make-extended-syncase-macro - existing3235 - type3233 - val3234) - (make-syncase-macro type3233 val3234)))))) - (local-eval-hook2438 - (lambda (x3238 mod3239) + existing874 + type872 + val873) + (make-syncase-macro type872 val873)))))) + (local-eval-hook77 + (lambda (x877 mod878) (primitive-eval - (list noexpand2431 - (let ((atom-key3240 (fluid-ref *mode*2432))) - (if (memv atom-key3240 (quote (c))) - ((@ (language tree-il) tree-il->scheme) x3238) - x3238)))))) - (top-level-eval-hook2437 - (lambda (x3241 mod3242) + (list noexpand70 + (let ((atom-key879 (fluid-ref *mode*71))) + (if (memv atom-key879 (quote (c))) + ((@ (language tree-il) tree-il->scheme) x877) + x877)))))) + (top-level-eval-hook76 + (lambda (x880 mod881) (primitive-eval - (list noexpand2431 - (let ((atom-key3243 (fluid-ref *mode*2432))) - (if (memv atom-key3243 (quote (c))) - ((@ (language tree-il) tree-il->scheme) x3241) - x3241)))))) - (fx<2436 <) - (fx=2435 =) - (fx-2434 -) - (fx+2433 +) - (*mode*2432 (make-fluid)) - (noexpand2431 "noexpand")) + (list noexpand70 + (let ((atom-key882 (fluid-ref *mode*71))) + (if (memv atom-key882 (quote (c))) + ((@ (language tree-il) tree-il->scheme) x880) + x880)))))) + (fx<75 <) + (fx=74 =) + (fx-73 -) + (fx+72 +) + (*mode*71 (make-fluid)) + (noexpand70 "noexpand")) (begin - (global-extend2474 + (global-extend113 'local-syntax 'letrec-syntax #t) - (global-extend2474 + (global-extend113 'local-syntax 'let-syntax #f) - (global-extend2474 + (global-extend113 'core 'fluid-let-syntax - (lambda (e3244 r3245 w3246 s3247 mod3248) - ((lambda (tmp3249) - ((lambda (tmp3250) - (if (if tmp3250 - (apply (lambda (_3251 var3252 val3253 e13254 e23255) - (valid-bound-ids?2501 var3252)) - tmp3250) + (lambda (e883 r884 w885 s886 mod887) + ((lambda (tmp888) + ((lambda (tmp889) + (if (if tmp889 + (apply (lambda (_890 var891 val892 e1893 e2894) + (valid-bound-ids?140 var891)) + tmp889) #f) - (apply (lambda (_3257 var3258 val3259 e13260 e23261) - (let ((names3262 - (map (lambda (x3263) - (id-var-name2498 x3263 w3246)) - var3258))) + (apply (lambda (_896 var897 val898 e1899 e2900) + (let ((names901 + (map (lambda (x902) + (id-var-name137 x902 w885)) + var897))) (begin (for-each - (lambda (id3265 n3266) - (let ((atom-key3267 - (binding-type2468 - (lookup2473 - n3266 - r3245 - mod3248)))) - (if (memv atom-key3267 + (lambda (id904 n905) + (let ((atom-key906 + (binding-type107 + (lookup112 n905 r884 mod887)))) + (if (memv atom-key906 '(displaced-lexical)) (syntax-violation 'fluid-let-syntax "identifier out of context" - e3244 - (source-wrap2505 - id3265 - w3246 - s3247 - mod3248))))) - var3258 - names3262) - (chi-body2516 - (cons e13260 e23261) - (source-wrap2505 e3244 w3246 s3247 mod3248) - (extend-env2470 - names3262 - (let ((trans-r3270 - (macros-only-env2472 r3245))) - (map (lambda (x3271) + e883 + (source-wrap144 + id904 + w885 + s886 + mod887))))) + var897 + names901) + (chi-body155 + (cons e1899 e2900) + (source-wrap144 e883 w885 s886 mod887) + (extend-env109 + names901 + (let ((trans-r909 + (macros-only-env111 r884))) + (map (lambda (x910) (cons 'macro - (eval-local-transformer2519 - (chi2512 - x3271 - trans-r3270 - w3246 - mod3248) - mod3248))) - val3259)) - r3245) - w3246 - mod3248)))) - tmp3250) - ((lambda (_3273) + (eval-local-transformer158 + (chi151 + x910 + trans-r909 + w885 + mod887) + mod887))) + val898)) + r884) + w885 + mod887)))) + tmp889) + ((lambda (_912) (syntax-violation 'fluid-let-syntax "bad syntax" - (source-wrap2505 e3244 w3246 s3247 mod3248))) - tmp3249))) + (source-wrap144 e883 w885 s886 mod887))) + tmp888))) ($sc-dispatch - tmp3249 + tmp888 '(any #(each (any any)) any . each-any)))) - e3244))) - (global-extend2474 + e883))) + (global-extend113 'core 'quote - (lambda (e3274 r3275 w3276 s3277 mod3278) - ((lambda (tmp3279) - ((lambda (tmp3280) - (if tmp3280 - (apply (lambda (_3281 e3282) - (build-data2454 s3277 (strip2522 e3282 w3276))) - tmp3280) - ((lambda (_3283) + (lambda (e913 r914 w915 s916 mod917) + ((lambda (tmp918) + ((lambda (tmp919) + (if tmp919 + (apply (lambda (_920 e921) + (build-data93 s916 (strip161 e921 w915))) + tmp919) + ((lambda (_922) (syntax-violation 'quote "bad syntax" - (source-wrap2505 e3274 w3276 s3277 mod3278))) - tmp3279))) - ($sc-dispatch tmp3279 (quote (any any))))) - e3274))) - (global-extend2474 + (source-wrap144 e913 w915 s916 mod917))) + tmp918))) + ($sc-dispatch tmp918 (quote (any any))))) + e913))) + (global-extend113 'core 'syntax - (letrec ((regen3291 - (lambda (x3292) - (let ((atom-key3293 (car x3292))) - (if (memv atom-key3293 (quote (ref))) - (build-lexical-reference2445 + (letrec ((regen930 + (lambda (x931) + (let ((atom-key932 (car x931))) + (if (memv atom-key932 (quote (ref))) + (build-lexical-reference84 'value #f - (cadr x3292) - (cadr x3292)) - (if (memv atom-key3293 (quote (primitive))) - (build-primref2453 #f (cadr x3292)) - (if (memv atom-key3293 (quote (quote))) - (build-data2454 #f (cadr x3292)) - (if (memv atom-key3293 (quote (lambda))) - (build-lambda2452 + (cadr x931) + (cadr x931)) + (if (memv atom-key932 (quote (primitive))) + (build-primref92 #f (cadr x931)) + (if (memv atom-key932 (quote (quote))) + (build-data93 #f (cadr x931)) + (if (memv atom-key932 (quote (lambda))) + (build-lambda91 #f - (cadr x3292) - (cadr x3292) + (cadr x931) + (cadr x931) #f - (regen3291 (caddr x3292))) - (build-application2443 + (regen930 (caddr x931))) + (build-application82 #f - (build-primref2453 #f (car x3292)) - (map regen3291 (cdr x3292)))))))))) - (gen-vector3290 - (lambda (x3294) - (if (eq? (car x3294) (quote list)) - (cons (quote vector) (cdr x3294)) - (if (eq? (car x3294) (quote quote)) - (list (quote quote) (list->vector (cadr x3294))) - (list (quote list->vector) x3294))))) - (gen-append3289 - (lambda (x3295 y3296) - (if (equal? y3296 (quote (quote ()))) - x3295 - (list (quote append) x3295 y3296)))) - (gen-cons3288 - (lambda (x3297 y3298) - (let ((atom-key3299 (car y3298))) - (if (memv atom-key3299 (quote (quote))) - (if (eq? (car x3297) (quote quote)) + (build-primref92 #f (car x931)) + (map regen930 (cdr x931)))))))))) + (gen-vector929 + (lambda (x933) + (if (eq? (car x933) (quote list)) + (cons (quote vector) (cdr x933)) + (if (eq? (car x933) (quote quote)) + (list (quote quote) (list->vector (cadr x933))) + (list (quote list->vector) x933))))) + (gen-append928 + (lambda (x934 y935) + (if (equal? y935 (quote (quote ()))) + x934 + (list (quote append) x934 y935)))) + (gen-cons927 + (lambda (x936 y937) + (let ((atom-key938 (car y937))) + (if (memv atom-key938 (quote (quote))) + (if (eq? (car x936) (quote quote)) (list 'quote - (cons (cadr x3297) (cadr y3298))) - (if (eq? (cadr y3298) (quote ())) - (list (quote list) x3297) - (list (quote cons) x3297 y3298))) - (if (memv atom-key3299 (quote (list))) - (cons (quote list) (cons x3297 (cdr y3298))) - (list (quote cons) x3297 y3298)))))) - (gen-map3287 - (lambda (e3300 map-env3301) - (let ((formals3302 (map cdr map-env3301)) - (actuals3303 - (map (lambda (x3304) - (list (quote ref) (car x3304))) - map-env3301))) - (if (eq? (car e3300) (quote ref)) - (car actuals3303) + (cons (cadr x936) (cadr y937))) + (if (eq? (cadr y937) (quote ())) + (list (quote list) x936) + (list (quote cons) x936 y937))) + (if (memv atom-key938 (quote (list))) + (cons (quote list) (cons x936 (cdr y937))) + (list (quote cons) x936 y937)))))) + (gen-map926 + (lambda (e939 map-env940) + (let ((formals941 (map cdr map-env940)) + (actuals942 + (map (lambda (x943) (list (quote ref) (car x943))) + map-env940))) + (if (eq? (car e939) (quote ref)) + (car actuals942) (if (and-map - (lambda (x3305) - (if (eq? (car x3305) (quote ref)) - (memq (cadr x3305) formals3302) + (lambda (x944) + (if (eq? (car x944) (quote ref)) + (memq (cadr x944) formals941) #f)) - (cdr e3300)) + (cdr e939)) (cons 'map - (cons (list (quote primitive) (car e3300)) - (map (let ((r3306 (map cons - formals3302 - actuals3303))) - (lambda (x3307) - (cdr (assq (cadr x3307) - r3306)))) - (cdr e3300)))) + (cons (list (quote primitive) (car e939)) + (map (let ((r945 (map cons + formals941 + actuals942))) + (lambda (x946) + (cdr (assq (cadr x946) r945)))) + (cdr e939)))) (cons 'map - (cons (list (quote lambda) formals3302 e3300) - actuals3303))))))) - (gen-mappend3286 - (lambda (e3308 map-env3309) + (cons (list (quote lambda) formals941 e939) + actuals942))))))) + (gen-mappend925 + (lambda (e947 map-env948) (list 'apply '(primitive append) - (gen-map3287 e3308 map-env3309)))) - (gen-ref3285 - (lambda (src3310 var3311 level3312 maps3313) - (if (fx=2435 level3312 0) - (values var3311 maps3313) - (if (null? maps3313) + (gen-map926 e947 map-env948)))) + (gen-ref924 + (lambda (src949 var950 level951 maps952) + (if (fx=74 level951 0) + (values var950 maps952) + (if (null? maps952) (syntax-violation 'syntax "missing ellipsis" - src3310) + src949) (call-with-values (lambda () - (gen-ref3285 - src3310 - var3311 - (fx-2434 level3312 1) - (cdr maps3313))) - (lambda (outer-var3314 outer-maps3315) - (let ((b3316 (assq outer-var3314 (car maps3313)))) - (if b3316 - (values (cdr b3316) maps3313) - (let ((inner-var3317 - (gen-var2523 (quote tmp)))) + (gen-ref924 + src949 + var950 + (fx-73 level951 1) + (cdr maps952))) + (lambda (outer-var953 outer-maps954) + (let ((b955 (assq outer-var953 (car maps952)))) + (if b955 + (values (cdr b955) maps952) + (let ((inner-var956 (gen-var162 (quote tmp)))) (values - inner-var3317 - (cons (cons (cons outer-var3314 - inner-var3317) - (car maps3313)) - outer-maps3315))))))))))) - (gen-syntax3284 - (lambda (src3318 - e3319 - r3320 - maps3321 - ellipsis?3322 - mod3323) - (if (id?2476 e3319) - (let ((label3324 (id-var-name2498 e3319 (quote (()))))) - (let ((b3325 (lookup2473 label3324 r3320 mod3323))) - (if (eq? (binding-type2468 b3325) (quote syntax)) + inner-var956 + (cons (cons (cons outer-var953 + inner-var956) + (car maps952)) + outer-maps954))))))))))) + (gen-syntax923 + (lambda (src957 e958 r959 maps960 ellipsis?961 mod962) + (if (id?115 e958) + (let ((label963 (id-var-name137 e958 (quote (()))))) + (let ((b964 (lookup112 label963 r959 mod962))) + (if (eq? (binding-type107 b964) (quote syntax)) (call-with-values (lambda () - (let ((var.lev3326 (binding-value2469 b3325))) - (gen-ref3285 - src3318 - (car var.lev3326) - (cdr var.lev3326) - maps3321))) - (lambda (var3327 maps3328) - (values (list (quote ref) var3327) maps3328))) - (if (ellipsis?3322 e3319) + (let ((var.lev965 (binding-value108 b964))) + (gen-ref924 + src957 + (car var.lev965) + (cdr var.lev965) + maps960))) + (lambda (var966 maps967) + (values (list (quote ref) var966) maps967))) + (if (ellipsis?961 e958) (syntax-violation 'syntax "misplaced ellipsis" - src3318) - (values (list (quote quote) e3319) maps3321))))) - ((lambda (tmp3329) - ((lambda (tmp3330) - (if (if tmp3330 - (apply (lambda (dots3331 e3332) - (ellipsis?3322 dots3331)) - tmp3330) + src957) + (values (list (quote quote) e958) maps960))))) + ((lambda (tmp968) + ((lambda (tmp969) + (if (if tmp969 + (apply (lambda (dots970 e971) + (ellipsis?961 dots970)) + tmp969) #f) - (apply (lambda (dots3333 e3334) - (gen-syntax3284 - src3318 - e3334 - r3320 - maps3321 - (lambda (x3335) #f) - mod3323)) - tmp3330) - ((lambda (tmp3336) - (if (if tmp3336 - (apply (lambda (x3337 dots3338 y3339) - (ellipsis?3322 dots3338)) - tmp3336) + (apply (lambda (dots972 e973) + (gen-syntax923 + src957 + e973 + r959 + maps960 + (lambda (x974) #f) + mod962)) + tmp969) + ((lambda (tmp975) + (if (if tmp975 + (apply (lambda (x976 dots977 y978) + (ellipsis?961 dots977)) + tmp975) #f) - (apply (lambda (x3340 dots3341 y3342) - (letrec ((f3343 (lambda (y3344 - k3345) - ((lambda (tmp3349) - ((lambda (tmp3350) - (if (if tmp3350 - (apply (lambda (dots3351 - y3352) - (ellipsis?3322 - dots3351)) - tmp3350) - #f) - (apply (lambda (dots3353 - y3354) - (f3343 y3354 - (lambda (maps3355) - (call-with-values - (lambda () - (k3345 (cons '() - maps3355))) - (lambda (x3356 - maps3357) - (if (null? (car maps3357)) - (syntax-violation - 'syntax - "extra ellipsis" - src3318) - (values - (gen-mappend3286 - x3356 - (car maps3357)) - (cdr maps3357)))))))) - tmp3350) - ((lambda (_3358) - (call-with-values - (lambda () - (gen-syntax3284 - src3318 - y3344 - r3320 - maps3321 - ellipsis?3322 - mod3323)) - (lambda (y3359 - maps3360) - (call-with-values - (lambda () - (k3345 maps3360)) - (lambda (x3361 - maps3362) - (values - (gen-append3289 - x3361 - y3359) - maps3362)))))) - tmp3349))) - ($sc-dispatch - tmp3349 - '(any . - any)))) - y3344)))) - (f3343 y3342 - (lambda (maps3346) - (call-with-values - (lambda () - (gen-syntax3284 - src3318 - x3340 - r3320 - (cons '() - maps3346) - ellipsis?3322 - mod3323)) - (lambda (x3347 - maps3348) - (if (null? (car maps3348)) - (syntax-violation - 'syntax - "extra ellipsis" - src3318) - (values - (gen-map3287 - x3347 - (car maps3348)) - (cdr maps3348))))))))) - tmp3336) - ((lambda (tmp3363) - (if tmp3363 - (apply (lambda (x3364 y3365) - (call-with-values - (lambda () - (gen-syntax3284 - src3318 - x3364 - r3320 - maps3321 - ellipsis?3322 - mod3323)) - (lambda (x3366 maps3367) - (call-with-values - (lambda () - (gen-syntax3284 - src3318 - y3365 - r3320 - maps3367 - ellipsis?3322 - mod3323)) - (lambda (y3368 - maps3369) - (values - (gen-cons3288 - x3366 - y3368) - maps3369)))))) - tmp3363) - ((lambda (tmp3370) - (if tmp3370 - (apply (lambda (e13371 e23372) + (apply (lambda (x979 dots980 y981) + (letrec ((f982 (lambda (y983 k984) + ((lambda (tmp988) + ((lambda (tmp989) + (if (if tmp989 + (apply (lambda (dots990 + y991) + (ellipsis?961 + dots990)) + tmp989) + #f) + (apply (lambda (dots992 + y993) + (f982 y993 + (lambda (maps994) + (call-with-values + (lambda () + (k984 (cons '() + maps994))) + (lambda (x995 + maps996) + (if (null? (car maps996)) + (syntax-violation + 'syntax + "extra ellipsis" + src957) + (values + (gen-mappend925 + x995 + (car maps996)) + (cdr maps996)))))))) + tmp989) + ((lambda (_997) + (call-with-values + (lambda () + (gen-syntax923 + src957 + y983 + r959 + maps960 + ellipsis?961 + mod962)) + (lambda (y998 + maps999) + (call-with-values + (lambda () + (k984 maps999)) + (lambda (x1000 + maps1001) + (values + (gen-append928 + x1000 + y998) + maps1001)))))) + tmp988))) + ($sc-dispatch + tmp988 + '(any . + any)))) + y983)))) + (f982 y981 + (lambda (maps985) (call-with-values (lambda () - (gen-syntax3284 - src3318 - (cons e13371 - e23372) - r3320 - maps3321 - ellipsis?3322 - mod3323)) - (lambda (e3374 - maps3375) + (gen-syntax923 + src957 + x979 + r959 + (cons '() + maps985) + ellipsis?961 + mod962)) + (lambda (x986 maps987) + (if (null? (car maps987)) + (syntax-violation + 'syntax + "extra ellipsis" + src957) + (values + (gen-map926 + x986 + (car maps987)) + (cdr maps987))))))))) + tmp975) + ((lambda (tmp1002) + (if tmp1002 + (apply (lambda (x1003 y1004) + (call-with-values + (lambda () + (gen-syntax923 + src957 + x1003 + r959 + maps960 + ellipsis?961 + mod962)) + (lambda (x1005 maps1006) + (call-with-values + (lambda () + (gen-syntax923 + src957 + y1004 + r959 + maps1006 + ellipsis?961 + mod962)) + (lambda (y1007 + maps1008) + (values + (gen-cons927 + x1005 + y1007) + maps1008)))))) + tmp1002) + ((lambda (tmp1009) + (if tmp1009 + (apply (lambda (e11010 e21011) + (call-with-values + (lambda () + (gen-syntax923 + src957 + (cons e11010 + e21011) + r959 + maps960 + ellipsis?961 + mod962)) + (lambda (e1013 + maps1014) (values - (gen-vector3290 - e3374) - maps3375)))) - tmp3370) - ((lambda (_3376) + (gen-vector929 + e1013) + maps1014)))) + tmp1009) + ((lambda (_1015) (values - (list (quote quote) e3319) - maps3321)) - tmp3329))) + (list (quote quote) e958) + maps960)) + tmp968))) ($sc-dispatch - tmp3329 + tmp968 '#(vector (any . each-any)))))) ($sc-dispatch - tmp3329 + tmp968 '(any . any))))) ($sc-dispatch - tmp3329 + tmp968 '(any any . any))))) - ($sc-dispatch tmp3329 (quote (any any))))) - e3319))))) - (lambda (e3377 r3378 w3379 s3380 mod3381) - (let ((e3382 (source-wrap2505 e3377 w3379 s3380 mod3381))) - ((lambda (tmp3383) - ((lambda (tmp3384) - (if tmp3384 - (apply (lambda (_3385 x3386) + ($sc-dispatch tmp968 (quote (any any))))) + e958))))) + (lambda (e1016 r1017 w1018 s1019 mod1020) + (let ((e1021 (source-wrap144 e1016 w1018 s1019 mod1020))) + ((lambda (tmp1022) + ((lambda (tmp1023) + (if tmp1023 + (apply (lambda (_1024 x1025) (call-with-values (lambda () - (gen-syntax3284 - e3382 - x3386 - r3378 + (gen-syntax923 + e1021 + x1025 + r1017 '() - ellipsis?2521 - mod3381)) - (lambda (e3387 maps3388) (regen3291 e3387)))) - tmp3384) - ((lambda (_3389) + ellipsis?160 + mod1020)) + (lambda (e1026 maps1027) (regen930 e1026)))) + tmp1023) + ((lambda (_1028) (syntax-violation 'syntax "bad `syntax' form" - e3382)) - tmp3383))) - ($sc-dispatch tmp3383 (quote (any any))))) - e3382))))) - (global-extend2474 + e1021)) + tmp1022))) + ($sc-dispatch tmp1022 (quote (any any))))) + e1021))))) + (global-extend113 'core 'lambda - (lambda (e3390 r3391 w3392 s3393 mod3394) - ((lambda (tmp3395) - ((lambda (tmp3396) - (if tmp3396 - (apply (lambda (_3397 c3398) - (chi-lambda-clause2517 - (source-wrap2505 e3390 w3392 s3393 mod3394) + (lambda (e1029 r1030 w1031 s1032 mod1033) + ((lambda (tmp1034) + ((lambda (tmp1035) + (if tmp1035 + (apply (lambda (_1036 c1037) + (chi-lambda-clause156 + (source-wrap144 e1029 w1031 s1032 mod1033) #f - c3398 - r3391 - w3392 - mod3394 - (lambda (names3399 - vars3400 - docstring3401 - body3402) - (build-lambda2452 - s3393 - names3399 - vars3400 - docstring3401 - body3402)))) - tmp3396) + c1037 + r1030 + w1031 + mod1033 + (lambda (names1038 + vars1039 + docstring1040 + body1041) + (build-lambda91 + s1032 + names1038 + vars1039 + docstring1040 + body1041)))) + tmp1035) (syntax-violation #f "source expression failed to match any pattern" - tmp3395))) - ($sc-dispatch tmp3395 (quote (any . any))))) - e3390))) - (global-extend2474 + tmp1034))) + ($sc-dispatch tmp1034 (quote (any . any))))) + e1029))) + (global-extend113 'core 'let - (letrec ((chi-let3403 - (lambda (e3404 - r3405 - w3406 - s3407 - mod3408 - constructor3409 - ids3410 - vals3411 - exps3412) - (if (not (valid-bound-ids?2501 ids3410)) + (letrec ((chi-let1042 + (lambda (e1043 + r1044 + w1045 + s1046 + mod1047 + constructor1048 + ids1049 + vals1050 + exps1051) + (if (not (valid-bound-ids?140 ids1049)) (syntax-violation 'let "duplicate bound variable" - e3404) - (let ((labels3413 (gen-labels2482 ids3410)) - (new-vars3414 (map gen-var2523 ids3410))) - (let ((nw3415 - (make-binding-wrap2493 - ids3410 - labels3413 - w3406)) - (nr3416 - (extend-var-env2471 - labels3413 - new-vars3414 - r3405))) - (constructor3409 - s3407 - (map syntax->datum ids3410) - new-vars3414 - (map (lambda (x3417) - (chi2512 x3417 r3405 w3406 mod3408)) - vals3411) - (chi-body2516 - exps3412 - (source-wrap2505 e3404 nw3415 s3407 mod3408) - nr3416 - nw3415 - mod3408)))))))) - (lambda (e3418 r3419 w3420 s3421 mod3422) - ((lambda (tmp3423) - ((lambda (tmp3424) - (if (if tmp3424 - (apply (lambda (_3425 id3426 val3427 e13428 e23429) - (and-map id?2476 id3426)) - tmp3424) + e1043) + (let ((labels1052 (gen-labels121 ids1049)) + (new-vars1053 (map gen-var162 ids1049))) + (let ((nw1054 + (make-binding-wrap132 + ids1049 + labels1052 + w1045)) + (nr1055 + (extend-var-env110 + labels1052 + new-vars1053 + r1044))) + (constructor1048 + s1046 + (map syntax->datum ids1049) + new-vars1053 + (map (lambda (x1056) + (chi151 x1056 r1044 w1045 mod1047)) + vals1050) + (chi-body155 + exps1051 + (source-wrap144 e1043 nw1054 s1046 mod1047) + nr1055 + nw1054 + mod1047)))))))) + (lambda (e1057 r1058 w1059 s1060 mod1061) + ((lambda (tmp1062) + ((lambda (tmp1063) + (if (if tmp1063 + (apply (lambda (_1064 id1065 val1066 e11067 e21068) + (and-map id?115 id1065)) + tmp1063) #f) - (apply (lambda (_3431 id3432 val3433 e13434 e23435) - (chi-let3403 - e3418 - r3419 - w3420 - s3421 - mod3422 - build-let2456 - id3432 - val3433 - (cons e13434 e23435))) - tmp3424) - ((lambda (tmp3439) - (if (if tmp3439 - (apply (lambda (_3440 - f3441 - id3442 - val3443 - e13444 - e23445) - (if (id?2476 f3441) - (and-map id?2476 id3442) + (apply (lambda (_1070 id1071 val1072 e11073 e21074) + (chi-let1042 + e1057 + r1058 + w1059 + s1060 + mod1061 + build-let95 + id1071 + val1072 + (cons e11073 e21074))) + tmp1063) + ((lambda (tmp1078) + (if (if tmp1078 + (apply (lambda (_1079 + f1080 + id1081 + val1082 + e11083 + e21084) + (if (id?115 f1080) + (and-map id?115 id1081) #f)) - tmp3439) + tmp1078) #f) - (apply (lambda (_3447 - f3448 - id3449 - val3450 - e13451 - e23452) - (chi-let3403 - e3418 - r3419 - w3420 - s3421 - mod3422 - build-named-let2457 - (cons f3448 id3449) - val3450 - (cons e13451 e23452))) - tmp3439) - ((lambda (_3456) + (apply (lambda (_1086 + f1087 + id1088 + val1089 + e11090 + e21091) + (chi-let1042 + e1057 + r1058 + w1059 + s1060 + mod1061 + build-named-let96 + (cons f1087 id1088) + val1089 + (cons e11090 e21091))) + tmp1078) + ((lambda (_1095) (syntax-violation 'let "bad let" - (source-wrap2505 e3418 w3420 s3421 mod3422))) - tmp3423))) + (source-wrap144 e1057 w1059 s1060 mod1061))) + tmp1062))) ($sc-dispatch - tmp3423 + tmp1062 '(any any #(each (any any)) any . each-any))))) ($sc-dispatch - tmp3423 + tmp1062 '(any #(each (any any)) any . each-any)))) - e3418)))) - (global-extend2474 + e1057)))) + (global-extend113 'core 'letrec - (lambda (e3457 r3458 w3459 s3460 mod3461) - ((lambda (tmp3462) - ((lambda (tmp3463) - (if (if tmp3463 - (apply (lambda (_3464 id3465 val3466 e13467 e23468) - (and-map id?2476 id3465)) - tmp3463) + (lambda (e1096 r1097 w1098 s1099 mod1100) + ((lambda (tmp1101) + ((lambda (tmp1102) + (if (if tmp1102 + (apply (lambda (_1103 id1104 val1105 e11106 e21107) + (and-map id?115 id1104)) + tmp1102) #f) - (apply (lambda (_3470 id3471 val3472 e13473 e23474) - (let ((ids3475 id3471)) - (if (not (valid-bound-ids?2501 ids3475)) + (apply (lambda (_1109 id1110 val1111 e11112 e21113) + (let ((ids1114 id1110)) + (if (not (valid-bound-ids?140 ids1114)) (syntax-violation 'letrec "duplicate bound variable" - e3457) - (let ((labels3477 (gen-labels2482 ids3475)) - (new-vars3478 (map gen-var2523 ids3475))) - (let ((w3479 (make-binding-wrap2493 - ids3475 - labels3477 - w3459)) - (r3480 (extend-var-env2471 - labels3477 - new-vars3478 - r3458))) - (build-letrec2458 - s3460 - (map syntax->datum ids3475) - new-vars3478 - (map (lambda (x3481) - (chi2512 - x3481 - r3480 - w3479 - mod3461)) - val3472) - (chi-body2516 - (cons e13473 e23474) - (source-wrap2505 - e3457 - w3479 - s3460 - mod3461) - r3480 - w3479 - mod3461))))))) - tmp3463) - ((lambda (_3484) + e1096) + (let ((labels1116 (gen-labels121 ids1114)) + (new-vars1117 (map gen-var162 ids1114))) + (let ((w1118 (make-binding-wrap132 + ids1114 + labels1116 + w1098)) + (r1119 (extend-var-env110 + labels1116 + new-vars1117 + r1097))) + (build-letrec97 + s1099 + (map syntax->datum ids1114) + new-vars1117 + (map (lambda (x1120) + (chi151 x1120 r1119 w1118 mod1100)) + val1111) + (chi-body155 + (cons e11112 e21113) + (source-wrap144 + e1096 + w1118 + s1099 + mod1100) + r1119 + w1118 + mod1100))))))) + tmp1102) + ((lambda (_1123) (syntax-violation 'letrec "bad letrec" - (source-wrap2505 e3457 w3459 s3460 mod3461))) - tmp3462))) + (source-wrap144 e1096 w1098 s1099 mod1100))) + tmp1101))) ($sc-dispatch - tmp3462 + tmp1101 '(any #(each (any any)) any . each-any)))) - e3457))) - (global-extend2474 + e1096))) + (global-extend113 'core 'set! - (lambda (e3485 r3486 w3487 s3488 mod3489) - ((lambda (tmp3490) - ((lambda (tmp3491) - (if (if tmp3491 - (apply (lambda (_3492 id3493 val3494) (id?2476 id3493)) - tmp3491) + (lambda (e1124 r1125 w1126 s1127 mod1128) + ((lambda (tmp1129) + ((lambda (tmp1130) + (if (if tmp1130 + (apply (lambda (_1131 id1132 val1133) (id?115 id1132)) + tmp1130) #f) - (apply (lambda (_3495 id3496 val3497) - (let ((val3498 - (chi2512 val3497 r3486 w3487 mod3489)) - (n3499 (id-var-name2498 id3496 w3487))) - (let ((b3500 (lookup2473 n3499 r3486 mod3489))) - (let ((atom-key3501 (binding-type2468 b3500))) - (if (memv atom-key3501 (quote (lexical))) - (build-lexical-assignment2446 - s3488 - (syntax->datum id3496) - (binding-value2469 b3500) - val3498) - (if (memv atom-key3501 (quote (global))) - (build-global-assignment2449 - s3488 - n3499 - val3498 - mod3489) - (if (memv atom-key3501 + (apply (lambda (_1134 id1135 val1136) + (let ((val1137 (chi151 val1136 r1125 w1126 mod1128)) + (n1138 (id-var-name137 id1135 w1126))) + (let ((b1139 (lookup112 n1138 r1125 mod1128))) + (let ((atom-key1140 (binding-type107 b1139))) + (if (memv atom-key1140 (quote (lexical))) + (build-lexical-assignment85 + s1127 + (syntax->datum id1135) + (binding-value108 b1139) + val1137) + (if (memv atom-key1140 (quote (global))) + (build-global-assignment88 + s1127 + n1138 + val1137 + mod1128) + (if (memv atom-key1140 '(displaced-lexical)) (syntax-violation 'set! "identifier out of context" - (wrap2504 id3496 w3487 mod3489)) + (wrap143 id1135 w1126 mod1128)) (syntax-violation 'set! "bad set!" - (source-wrap2505 - e3485 - w3487 - s3488 - mod3489))))))))) - tmp3491) - ((lambda (tmp3502) - (if tmp3502 - (apply (lambda (_3503 head3504 tail3505 val3506) + (source-wrap144 + e1124 + w1126 + s1127 + mod1128))))))))) + tmp1130) + ((lambda (tmp1141) + (if tmp1141 + (apply (lambda (_1142 head1143 tail1144 val1145) (call-with-values (lambda () - (syntax-type2510 - head3504 - r3486 + (syntax-type149 + head1143 + r1125 '(()) #f #f - mod3489 + mod1128 #t)) - (lambda (type3507 - value3508 - ee3509 - ww3510 - ss3511 - modmod3512) - (if (memv type3507 (quote (module-ref))) - (let ((val3513 - (chi2512 - val3506 - r3486 - w3487 - mod3489))) + (lambda (type1146 + value1147 + ee1148 + ww1149 + ss1150 + modmod1151) + (if (memv type1146 (quote (module-ref))) + (let ((val1152 + (chi151 + val1145 + r1125 + w1126 + mod1128))) (call-with-values (lambda () - (value3508 - (cons head3504 tail3505))) - (lambda (id3515 mod3516) - (build-global-assignment2449 - s3488 - id3515 - val3513 - mod3516)))) - (build-application2443 - s3488 - (chi2512 + (value1147 + (cons head1143 tail1144))) + (lambda (id1154 mod1155) + (build-global-assignment88 + s1127 + id1154 + val1152 + mod1155)))) + (build-application82 + s1127 + (chi151 (list '#(syntax-object setter ((top) @@ -6649,47 +6491,47 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - head3504) - r3486 - w3487 - mod3489) - (map (lambda (e3517) - (chi2512 - e3517 - r3486 - w3487 - mod3489)) + head1143) + r1125 + w1126 + mod1128) + (map (lambda (e1156) + (chi151 + e1156 + r1125 + w1126 + mod1128)) (append - tail3505 - (list val3506)))))))) - tmp3502) - ((lambda (_3519) + tail1144 + (list val1145)))))))) + tmp1141) + ((lambda (_1158) (syntax-violation 'set! "bad set!" - (source-wrap2505 e3485 w3487 s3488 mod3489))) - tmp3490))) + (source-wrap144 e1124 w1126 s1127 mod1128))) + tmp1129))) ($sc-dispatch - tmp3490 + tmp1129 '(any (any . each-any) any))))) - ($sc-dispatch tmp3490 (quote (any any any))))) - e3485))) - (global-extend2474 + ($sc-dispatch tmp1129 (quote (any any any))))) + e1124))) + (global-extend113 'module-ref '@ - (lambda (e3520) - ((lambda (tmp3521) - ((lambda (tmp3522) - (if (if tmp3522 - (apply (lambda (_3523 mod3524 id3525) - (if (and-map id?2476 mod3524) - (id?2476 id3525) + (lambda (e1159) + ((lambda (tmp1160) + ((lambda (tmp1161) + (if (if tmp1161 + (apply (lambda (_1162 mod1163 id1164) + (if (and-map id?115 mod1163) + (id?115 id1164) #f)) - tmp3522) + tmp1161) #f) - (apply (lambda (_3527 mod3528 id3529) + (apply (lambda (_1166 mod1167 id1168) (values - (syntax->datum id3529) + (syntax->datum id1168) (syntax->datum (cons '#(syntax-object public @@ -7042,30 +6884,30 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - mod3528)))) - tmp3522) + mod1167)))) + tmp1161) (syntax-violation #f "source expression failed to match any pattern" - tmp3521))) - ($sc-dispatch tmp3521 (quote (any each-any any))))) - e3520))) - (global-extend2474 + tmp1160))) + ($sc-dispatch tmp1160 (quote (any each-any any))))) + e1159))) + (global-extend113 'module-ref '@@ - (lambda (e3531) - ((lambda (tmp3532) - ((lambda (tmp3533) - (if (if tmp3533 - (apply (lambda (_3534 mod3535 id3536) - (if (and-map id?2476 mod3535) - (id?2476 id3536) + (lambda (e1170) + ((lambda (tmp1171) + ((lambda (tmp1172) + (if (if tmp1172 + (apply (lambda (_1173 mod1174 id1175) + (if (and-map id?115 mod1174) + (id?115 id1175) #f)) - tmp3533) + tmp1172) #f) - (apply (lambda (_3538 mod3539 id3540) + (apply (lambda (_1177 mod1178 id1179) (values - (syntax->datum id3540) + (syntax->datum id1179) (syntax->datum (cons '#(syntax-object private @@ -7418,84 +7260,84 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - mod3539)))) - tmp3533) + mod1178)))) + tmp1172) (syntax-violation #f "source expression failed to match any pattern" - tmp3532))) - ($sc-dispatch tmp3532 (quote (any each-any any))))) - e3531))) - (global-extend2474 + tmp1171))) + ($sc-dispatch tmp1171 (quote (any each-any any))))) + e1170))) + (global-extend113 'core 'if - (lambda (e3542 r3543 w3544 s3545 mod3546) - ((lambda (tmp3547) - ((lambda (tmp3548) - (if tmp3548 - (apply (lambda (_3549 test3550 then3551) - (build-conditional2444 - s3545 - (chi2512 test3550 r3543 w3544 mod3546) - (chi2512 then3551 r3543 w3544 mod3546) - (build-void2442 #f))) - tmp3548) - ((lambda (tmp3552) - (if tmp3552 - (apply (lambda (_3553 test3554 then3555 else3556) - (build-conditional2444 - s3545 - (chi2512 test3554 r3543 w3544 mod3546) - (chi2512 then3555 r3543 w3544 mod3546) - (chi2512 else3556 r3543 w3544 mod3546))) - tmp3552) + (lambda (e1181 r1182 w1183 s1184 mod1185) + ((lambda (tmp1186) + ((lambda (tmp1187) + (if tmp1187 + (apply (lambda (_1188 test1189 then1190) + (build-conditional83 + s1184 + (chi151 test1189 r1182 w1183 mod1185) + (chi151 then1190 r1182 w1183 mod1185) + (build-void81 #f))) + tmp1187) + ((lambda (tmp1191) + (if tmp1191 + (apply (lambda (_1192 test1193 then1194 else1195) + (build-conditional83 + s1184 + (chi151 test1193 r1182 w1183 mod1185) + (chi151 then1194 r1182 w1183 mod1185) + (chi151 else1195 r1182 w1183 mod1185))) + tmp1191) (syntax-violation #f "source expression failed to match any pattern" - tmp3547))) - ($sc-dispatch tmp3547 (quote (any any any any)))))) - ($sc-dispatch tmp3547 (quote (any any any))))) - e3542))) - (global-extend2474 + tmp1186))) + ($sc-dispatch tmp1186 (quote (any any any any)))))) + ($sc-dispatch tmp1186 (quote (any any any))))) + e1181))) + (global-extend113 'begin 'begin '()) - (global-extend2474 + (global-extend113 'define 'define '()) - (global-extend2474 + (global-extend113 'define-syntax 'define-syntax '()) - (global-extend2474 + (global-extend113 'eval-when 'eval-when '()) - (global-extend2474 + (global-extend113 'core 'syntax-case - (letrec ((gen-syntax-case3560 - (lambda (x3561 keys3562 clauses3563 r3564 mod3565) - (if (null? clauses3563) - (build-application2443 + (letrec ((gen-syntax-case1199 + (lambda (x1200 keys1201 clauses1202 r1203 mod1204) + (if (null? clauses1202) + (build-application82 #f - (build-primref2453 #f (quote syntax-violation)) - (list (build-data2454 #f #f) - (build-data2454 + (build-primref92 #f (quote syntax-violation)) + (list (build-data93 #f #f) + (build-data93 #f "source expression failed to match any pattern") - x3561)) - ((lambda (tmp3566) - ((lambda (tmp3567) - (if tmp3567 - (apply (lambda (pat3568 exp3569) - (if (if (id?2476 pat3568) + x1200)) + ((lambda (tmp1205) + ((lambda (tmp1206) + (if tmp1206 + (apply (lambda (pat1207 exp1208) + (if (if (id?115 pat1207) (and-map - (lambda (x3570) - (not (free-id=?2499 - pat3568 - x3570))) + (lambda (x1209) + (not (free-id=?138 + pat1207 + x1209))) (cons '#(syntax-object ... ((top) @@ -7873,623 +7715,620 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - keys3562)) + keys1201)) #f) - (let ((labels3571 - (list (gen-label2481))) - (var3572 - (gen-var2523 pat3568))) - (build-application2443 + (let ((labels1210 + (list (gen-label120))) + (var1211 (gen-var162 pat1207))) + (build-application82 #f - (build-lambda2452 + (build-lambda91 #f - (list (syntax->datum pat3568)) - (list var3572) + (list (syntax->datum pat1207)) + (list var1211) #f - (chi2512 - exp3569 - (extend-env2470 - labels3571 + (chi151 + exp1208 + (extend-env109 + labels1210 (list (cons 'syntax - (cons var3572 + (cons var1211 0))) - r3564) - (make-binding-wrap2493 - (list pat3568) - labels3571 + r1203) + (make-binding-wrap132 + (list pat1207) + labels1210 '(())) - mod3565)) - (list x3561))) - (gen-clause3559 - x3561 - keys3562 - (cdr clauses3563) - r3564 - pat3568 + mod1204)) + (list x1200))) + (gen-clause1198 + x1200 + keys1201 + (cdr clauses1202) + r1203 + pat1207 #t - exp3569 - mod3565))) - tmp3567) - ((lambda (tmp3573) - (if tmp3573 - (apply (lambda (pat3574 fender3575 exp3576) - (gen-clause3559 - x3561 - keys3562 - (cdr clauses3563) - r3564 - pat3574 - fender3575 - exp3576 - mod3565)) - tmp3573) - ((lambda (_3577) + exp1208 + mod1204))) + tmp1206) + ((lambda (tmp1212) + (if tmp1212 + (apply (lambda (pat1213 fender1214 exp1215) + (gen-clause1198 + x1200 + keys1201 + (cdr clauses1202) + r1203 + pat1213 + fender1214 + exp1215 + mod1204)) + tmp1212) + ((lambda (_1216) (syntax-violation 'syntax-case "invalid clause" - (car clauses3563))) - tmp3566))) - ($sc-dispatch tmp3566 (quote (any any any)))))) - ($sc-dispatch tmp3566 (quote (any any))))) - (car clauses3563))))) - (gen-clause3559 - (lambda (x3578 - keys3579 - clauses3580 - r3581 - pat3582 - fender3583 - exp3584 - mod3585) + (car clauses1202))) + tmp1205))) + ($sc-dispatch tmp1205 (quote (any any any)))))) + ($sc-dispatch tmp1205 (quote (any any))))) + (car clauses1202))))) + (gen-clause1198 + (lambda (x1217 + keys1218 + clauses1219 + r1220 + pat1221 + fender1222 + exp1223 + mod1224) (call-with-values (lambda () - (convert-pattern3557 pat3582 keys3579)) - (lambda (p3586 pvars3587) - (if (not (distinct-bound-ids?2502 - (map car pvars3587))) + (convert-pattern1196 pat1221 keys1218)) + (lambda (p1225 pvars1226) + (if (not (distinct-bound-ids?141 (map car pvars1226))) (syntax-violation 'syntax-case "duplicate pattern variable" - pat3582) + pat1221) (if (not (and-map - (lambda (x3588) - (not (ellipsis?2521 (car x3588)))) - pvars3587)) + (lambda (x1227) + (not (ellipsis?160 (car x1227)))) + pvars1226)) (syntax-violation 'syntax-case "misplaced ellipsis" - pat3582) - (let ((y3589 (gen-var2523 (quote tmp)))) - (build-application2443 + pat1221) + (let ((y1228 (gen-var162 (quote tmp)))) + (build-application82 #f - (build-lambda2452 + (build-lambda91 #f (list (quote tmp)) - (list y3589) + (list y1228) #f - (let ((y3590 (build-lexical-reference2445 + (let ((y1229 (build-lexical-reference84 'value #f 'tmp - y3589))) - (build-conditional2444 + y1228))) + (build-conditional83 #f - ((lambda (tmp3591) - ((lambda (tmp3592) - (if tmp3592 - (apply (lambda () y3590) - tmp3592) - ((lambda (_3593) - (build-conditional2444 + ((lambda (tmp1230) + ((lambda (tmp1231) + (if tmp1231 + (apply (lambda () y1229) + tmp1231) + ((lambda (_1232) + (build-conditional83 #f - y3590 - (build-dispatch-call3558 - pvars3587 - fender3583 - y3590 - r3581 - mod3585) - (build-data2454 #f #f))) - tmp3591))) + y1229 + (build-dispatch-call1197 + pvars1226 + fender1222 + y1229 + r1220 + mod1224) + (build-data93 #f #f))) + tmp1230))) ($sc-dispatch - tmp3591 + tmp1230 '#(atom #t)))) - fender3583) - (build-dispatch-call3558 - pvars3587 - exp3584 - y3590 - r3581 - mod3585) - (gen-syntax-case3560 - x3578 - keys3579 - clauses3580 - r3581 - mod3585)))) - (list (if (eq? p3586 (quote any)) - (build-application2443 + fender1222) + (build-dispatch-call1197 + pvars1226 + exp1223 + y1229 + r1220 + mod1224) + (gen-syntax-case1199 + x1217 + keys1218 + clauses1219 + r1220 + mod1224)))) + (list (if (eq? p1225 (quote any)) + (build-application82 #f - (build-primref2453 #f (quote list)) - (list x3578)) - (build-application2443 + (build-primref92 #f (quote list)) + (list x1217)) + (build-application82 #f - (build-primref2453 + (build-primref92 #f '$sc-dispatch) - (list x3578 - (build-data2454 + (list x1217 + (build-data93 #f - p3586))))))))))))) - (build-dispatch-call3558 - (lambda (pvars3594 exp3595 y3596 r3597 mod3598) - (let ((ids3599 (map car pvars3594)) - (levels3600 (map cdr pvars3594))) - (let ((labels3601 (gen-labels2482 ids3599)) - (new-vars3602 (map gen-var2523 ids3599))) - (build-application2443 + p1225))))))))))))) + (build-dispatch-call1197 + (lambda (pvars1233 exp1234 y1235 r1236 mod1237) + (let ((ids1238 (map car pvars1233)) + (levels1239 (map cdr pvars1233))) + (let ((labels1240 (gen-labels121 ids1238)) + (new-vars1241 (map gen-var162 ids1238))) + (build-application82 #f - (build-primref2453 #f (quote apply)) - (list (build-lambda2452 + (build-primref92 #f (quote apply)) + (list (build-lambda91 #f - (map syntax->datum ids3599) - new-vars3602 + (map syntax->datum ids1238) + new-vars1241 #f - (chi2512 - exp3595 - (extend-env2470 - labels3601 - (map (lambda (var3603 level3604) + (chi151 + exp1234 + (extend-env109 + labels1240 + (map (lambda (var1242 level1243) (cons 'syntax - (cons var3603 level3604))) - new-vars3602 - (map cdr pvars3594)) - r3597) - (make-binding-wrap2493 - ids3599 - labels3601 + (cons var1242 level1243))) + new-vars1241 + (map cdr pvars1233)) + r1236) + (make-binding-wrap132 + ids1238 + labels1240 '(())) - mod3598)) - y3596)))))) - (convert-pattern3557 - (lambda (pattern3605 keys3606) - (letrec ((cvt3607 - (lambda (p3608 n3609 ids3610) - (if (id?2476 p3608) - (if (bound-id-member?2503 p3608 keys3606) + mod1237)) + y1235)))))) + (convert-pattern1196 + (lambda (pattern1244 keys1245) + (letrec ((cvt1246 + (lambda (p1247 n1248 ids1249) + (if (id?115 p1247) + (if (bound-id-member?142 p1247 keys1245) (values - (vector (quote free-id) p3608) - ids3610) + (vector (quote free-id) p1247) + ids1249) (values 'any - (cons (cons p3608 n3609) ids3610))) - ((lambda (tmp3611) - ((lambda (tmp3612) - (if (if tmp3612 - (apply (lambda (x3613 dots3614) - (ellipsis?2521 - dots3614)) - tmp3612) + (cons (cons p1247 n1248) ids1249))) + ((lambda (tmp1250) + ((lambda (tmp1251) + (if (if tmp1251 + (apply (lambda (x1252 dots1253) + (ellipsis?160 + dots1253)) + tmp1251) #f) - (apply (lambda (x3615 dots3616) + (apply (lambda (x1254 dots1255) (call-with-values (lambda () - (cvt3607 - x3615 - (fx+2433 n3609 1) - ids3610)) - (lambda (p3617 ids3618) + (cvt1246 + x1254 + (fx+72 n1248 1) + ids1249)) + (lambda (p1256 ids1257) (values - (if (eq? p3617 + (if (eq? p1256 'any) 'each-any (vector 'each - p3617)) - ids3618)))) - tmp3612) - ((lambda (tmp3619) - (if tmp3619 - (apply (lambda (x3620 y3621) + p1256)) + ids1257)))) + tmp1251) + ((lambda (tmp1258) + (if tmp1258 + (apply (lambda (x1259 y1260) (call-with-values (lambda () - (cvt3607 - y3621 - n3609 - ids3610)) - (lambda (y3622 - ids3623) + (cvt1246 + y1260 + n1248 + ids1249)) + (lambda (y1261 + ids1262) (call-with-values (lambda () - (cvt3607 - x3620 - n3609 - ids3623)) - (lambda (x3624 - ids3625) + (cvt1246 + x1259 + n1248 + ids1262)) + (lambda (x1263 + ids1264) (values - (cons x3624 - y3622) - ids3625)))))) - tmp3619) - ((lambda (tmp3626) - (if tmp3626 + (cons x1263 + y1261) + ids1264)))))) + tmp1258) + ((lambda (tmp1265) + (if tmp1265 (apply (lambda () (values '() - ids3610)) - tmp3626) - ((lambda (tmp3627) - (if tmp3627 - (apply (lambda (x3628) + ids1249)) + tmp1265) + ((lambda (tmp1266) + (if tmp1266 + (apply (lambda (x1267) (call-with-values (lambda () - (cvt3607 - x3628 - n3609 - ids3610)) - (lambda (p3630 - ids3631) + (cvt1246 + x1267 + n1248 + ids1249)) + (lambda (p1269 + ids1270) (values (vector 'vector - p3630) - ids3631)))) - tmp3627) - ((lambda (x3632) + p1269) + ids1270)))) + tmp1266) + ((lambda (x1271) (values (vector 'atom - (strip2522 - p3608 + (strip161 + p1247 '(()))) - ids3610)) - tmp3611))) + ids1249)) + tmp1250))) ($sc-dispatch - tmp3611 + tmp1250 '#(vector each-any))))) ($sc-dispatch - tmp3611 + tmp1250 '())))) ($sc-dispatch - tmp3611 + tmp1250 '(any . any))))) ($sc-dispatch - tmp3611 + tmp1250 '(any any)))) - p3608))))) - (cvt3607 pattern3605 0 (quote ())))))) - (lambda (e3633 r3634 w3635 s3636 mod3637) - (let ((e3638 (source-wrap2505 e3633 w3635 s3636 mod3637))) - ((lambda (tmp3639) - ((lambda (tmp3640) - (if tmp3640 - (apply (lambda (_3641 val3642 key3643 m3644) + p1247))))) + (cvt1246 pattern1244 0 (quote ())))))) + (lambda (e1272 r1273 w1274 s1275 mod1276) + (let ((e1277 (source-wrap144 e1272 w1274 s1275 mod1276))) + ((lambda (tmp1278) + ((lambda (tmp1279) + (if tmp1279 + (apply (lambda (_1280 val1281 key1282 m1283) (if (and-map - (lambda (x3645) - (if (id?2476 x3645) - (not (ellipsis?2521 x3645)) + (lambda (x1284) + (if (id?115 x1284) + (not (ellipsis?160 x1284)) #f)) - key3643) - (let ((x3647 (gen-var2523 (quote tmp)))) - (build-application2443 - s3636 - (build-lambda2452 + key1282) + (let ((x1286 (gen-var162 (quote tmp)))) + (build-application82 + s1275 + (build-lambda91 #f (list (quote tmp)) - (list x3647) + (list x1286) #f - (gen-syntax-case3560 - (build-lexical-reference2445 + (gen-syntax-case1199 + (build-lexical-reference84 'value #f 'tmp - x3647) - key3643 - m3644 - r3634 - mod3637)) - (list (chi2512 - val3642 - r3634 + x1286) + key1282 + m1283 + r1273 + mod1276)) + (list (chi151 + val1281 + r1273 '(()) - mod3637)))) + mod1276)))) (syntax-violation 'syntax-case "invalid literals list" - e3638))) - tmp3640) + e1277))) + tmp1279) (syntax-violation #f "source expression failed to match any pattern" - tmp3639))) + tmp1278))) ($sc-dispatch - tmp3639 + tmp1278 '(any any each-any . each-any)))) - e3638))))) + e1277))))) (set! sc-expand - (lambda (x3651 . rest3650) - (if (if (pair? x3651) - (equal? (car x3651) noexpand2431) + (lambda (x1290 . rest1289) + (if (if (pair? x1290) + (equal? (car x1290) noexpand70) #f) - (cadr x3651) - (let ((m3652 (if (null? rest3650) (quote e) (car rest3650))) - (esew3653 - (if (let ((t3654 (null? rest3650))) - (if t3654 t3654 (null? (cdr rest3650)))) + (cadr x1290) + (let ((m1291 (if (null? rest1289) (quote e) (car rest1289))) + (esew1292 + (if (let ((t1293 (null? rest1289))) + (if t1293 t1293 (null? (cdr rest1289)))) '(eval) - (cadr rest3650)))) + (cadr rest1289)))) (with-fluid* - *mode*2432 - m3652 + *mode*71 + m1291 (lambda () - (chi-top2511 - x3651 + (chi-top150 + x1290 '() '((top)) - m3652 - esew3653 + m1291 + esew1292 (cons 'hygiene (module-name (current-module)))))))))) (set! identifier? - (lambda (x3655) (nonsymbol-id?2475 x3655))) + (lambda (x1294) (nonsymbol-id?114 x1294))) (set! datum->syntax - (lambda (id3656 datum3657) - (make-syntax-object2459 - datum3657 - (syntax-object-wrap2462 id3656) + (lambda (id1295 datum1296) + (make-syntax-object98 + datum1296 + (syntax-object-wrap101 id1295) #f))) (set! syntax->datum - (lambda (x3658) (strip2522 x3658 (quote (()))))) + (lambda (x1297) (strip161 x1297 (quote (()))))) (set! generate-temporaries - (lambda (ls3659) + (lambda (ls1298) (begin - (let ((x3660 ls3659)) - (if (not (list? x3660)) + (let ((x1299 ls1298)) + (if (not (list? x1299)) (syntax-violation 'generate-temporaries "invalid argument" - x3660))) - (map (lambda (x3661) - (wrap2504 (gensym) (quote ((top))) #f)) - ls3659)))) + x1299))) + (map (lambda (x1300) + (wrap143 (gensym) (quote ((top))) #f)) + ls1298)))) (set! free-identifier=? - (lambda (x3662 y3663) + (lambda (x1301 y1302) (begin - (let ((x3664 x3662)) - (if (not (nonsymbol-id?2475 x3664)) + (let ((x1303 x1301)) + (if (not (nonsymbol-id?114 x1303)) (syntax-violation 'free-identifier=? "invalid argument" - x3664))) - (let ((x3665 y3663)) - (if (not (nonsymbol-id?2475 x3665)) + x1303))) + (let ((x1304 y1302)) + (if (not (nonsymbol-id?114 x1304)) (syntax-violation 'free-identifier=? "invalid argument" - x3665))) - (free-id=?2499 x3662 y3663)))) + x1304))) + (free-id=?138 x1301 y1302)))) (set! bound-identifier=? - (lambda (x3666 y3667) + (lambda (x1305 y1306) (begin - (let ((x3668 x3666)) - (if (not (nonsymbol-id?2475 x3668)) + (let ((x1307 x1305)) + (if (not (nonsymbol-id?114 x1307)) (syntax-violation 'bound-identifier=? "invalid argument" - x3668))) - (let ((x3669 y3667)) - (if (not (nonsymbol-id?2475 x3669)) + x1307))) + (let ((x1308 y1306)) + (if (not (nonsymbol-id?114 x1308)) (syntax-violation 'bound-identifier=? "invalid argument" - x3669))) - (bound-id=?2500 x3666 y3667)))) + x1308))) + (bound-id=?139 x1305 y1306)))) (set! syntax-violation - (lambda (who3673 message3672 form3671 . subform3670) + (lambda (who1312 message1311 form1310 . subform1309) (begin - (let ((x3674 who3673)) - (if (not ((lambda (x3675) - (let ((t3676 (not x3675))) - (if t3676 - t3676 - (let ((t3677 (string? x3675))) - (if t3677 t3677 (symbol? x3675)))))) - x3674)) + (let ((x1313 who1312)) + (if (not ((lambda (x1314) + (let ((t1315 (not x1314))) + (if t1315 + t1315 + (let ((t1316 (string? x1314))) + (if t1316 t1316 (symbol? x1314)))))) + x1313)) (syntax-violation 'syntax-violation "invalid argument" - x3674))) - (let ((x3678 message3672)) - (if (not (string? x3678)) + x1313))) + (let ((x1317 message1311)) + (if (not (string? x1317)) (syntax-violation 'syntax-violation "invalid argument" - x3678))) + x1317))) (scm-error 'syntax-error 'sc-expand (string-append - (if who3673 "~a: " "") + (if who1312 "~a: " "") "~a " - (if (null? subform3670) + (if (null? subform1309) "in ~a" "in subform `~s' of `~s'")) - (let ((tail3679 - (cons message3672 - (map (lambda (x3680) - (strip2522 x3680 (quote (())))) - (append subform3670 (list form3671)))))) - (if who3673 (cons who3673 tail3679) tail3679)) + (let ((tail1318 + (cons message1311 + (map (lambda (x1319) (strip161 x1319 (quote (())))) + (append subform1309 (list form1310)))))) + (if who1312 (cons who1312 tail1318) tail1318)) #f)))) - (letrec ((match3685 - (lambda (e3686 p3687 w3688 r3689 mod3690) - (if (not r3689) + (letrec ((match1324 + (lambda (e1325 p1326 w1327 r1328 mod1329) + (if (not r1328) #f - (if (eq? p3687 (quote any)) - (cons (wrap2504 e3686 w3688 mod3690) r3689) - (if (syntax-object?2460 e3686) - (match*3684 - (syntax-object-expression2461 e3686) - p3687 - (join-wraps2495 - w3688 - (syntax-object-wrap2462 e3686)) - r3689 - (syntax-object-module2463 e3686)) - (match*3684 e3686 p3687 w3688 r3689 mod3690)))))) - (match*3684 - (lambda (e3691 p3692 w3693 r3694 mod3695) - (if (null? p3692) - (if (null? e3691) r3694 #f) - (if (pair? p3692) - (if (pair? e3691) - (match3685 - (car e3691) - (car p3692) - w3693 - (match3685 - (cdr e3691) - (cdr p3692) - w3693 - r3694 - mod3695) - mod3695) + (if (eq? p1326 (quote any)) + (cons (wrap143 e1325 w1327 mod1329) r1328) + (if (syntax-object?99 e1325) + (match*1323 + (syntax-object-expression100 e1325) + p1326 + (join-wraps134 + w1327 + (syntax-object-wrap101 e1325)) + r1328 + (syntax-object-module102 e1325)) + (match*1323 e1325 p1326 w1327 r1328 mod1329)))))) + (match*1323 + (lambda (e1330 p1331 w1332 r1333 mod1334) + (if (null? p1331) + (if (null? e1330) r1333 #f) + (if (pair? p1331) + (if (pair? e1330) + (match1324 + (car e1330) + (car p1331) + w1332 + (match1324 + (cdr e1330) + (cdr p1331) + w1332 + r1333 + mod1334) + mod1334) #f) - (if (eq? p3692 (quote each-any)) - (let ((l3696 (match-each-any3682 - e3691 - w3693 - mod3695))) - (if l3696 (cons l3696 r3694) #f)) - (let ((atom-key3697 (vector-ref p3692 0))) - (if (memv atom-key3697 (quote (each))) - (if (null? e3691) - (match-empty3683 (vector-ref p3692 1) r3694) - (let ((l3698 (match-each3681 - e3691 - (vector-ref p3692 1) - w3693 - mod3695))) - (if l3698 - (letrec ((collect3699 - (lambda (l3700) - (if (null? (car l3700)) - r3694 - (cons (map car l3700) - (collect3699 - (map cdr l3700))))))) - (collect3699 l3698)) + (if (eq? p1331 (quote each-any)) + (let ((l1335 (match-each-any1321 + e1330 + w1332 + mod1334))) + (if l1335 (cons l1335 r1333) #f)) + (let ((atom-key1336 (vector-ref p1331 0))) + (if (memv atom-key1336 (quote (each))) + (if (null? e1330) + (match-empty1322 (vector-ref p1331 1) r1333) + (let ((l1337 (match-each1320 + e1330 + (vector-ref p1331 1) + w1332 + mod1334))) + (if l1337 + (letrec ((collect1338 + (lambda (l1339) + (if (null? (car l1339)) + r1333 + (cons (map car l1339) + (collect1338 + (map cdr l1339))))))) + (collect1338 l1337)) #f))) - (if (memv atom-key3697 (quote (free-id))) - (if (id?2476 e3691) - (if (free-id=?2499 - (wrap2504 e3691 w3693 mod3695) - (vector-ref p3692 1)) - r3694 + (if (memv atom-key1336 (quote (free-id))) + (if (id?115 e1330) + (if (free-id=?138 + (wrap143 e1330 w1332 mod1334) + (vector-ref p1331 1)) + r1333 #f) #f) - (if (memv atom-key3697 (quote (atom))) + (if (memv atom-key1336 (quote (atom))) (if (equal? - (vector-ref p3692 1) - (strip2522 e3691 w3693)) - r3694 + (vector-ref p1331 1) + (strip161 e1330 w1332)) + r1333 #f) - (if (memv atom-key3697 (quote (vector))) - (if (vector? e3691) - (match3685 - (vector->list e3691) - (vector-ref p3692 1) - w3693 - r3694 - mod3695) + (if (memv atom-key1336 (quote (vector))) + (if (vector? e1330) + (match1324 + (vector->list e1330) + (vector-ref p1331 1) + w1332 + r1333 + mod1334) #f))))))))))) - (match-empty3683 - (lambda (p3701 r3702) - (if (null? p3701) - r3702 - (if (eq? p3701 (quote any)) - (cons (quote ()) r3702) - (if (pair? p3701) - (match-empty3683 - (car p3701) - (match-empty3683 (cdr p3701) r3702)) - (if (eq? p3701 (quote each-any)) - (cons (quote ()) r3702) - (let ((atom-key3703 (vector-ref p3701 0))) - (if (memv atom-key3703 (quote (each))) - (match-empty3683 (vector-ref p3701 1) r3702) - (if (memv atom-key3703 (quote (free-id atom))) - r3702 - (if (memv atom-key3703 (quote (vector))) - (match-empty3683 - (vector-ref p3701 1) - r3702))))))))))) - (match-each-any3682 - (lambda (e3704 w3705 mod3706) - (if (pair? e3704) - (let ((l3707 (match-each-any3682 - (cdr e3704) - w3705 - mod3706))) - (if l3707 - (cons (wrap2504 (car e3704) w3705 mod3706) l3707) + (match-empty1322 + (lambda (p1340 r1341) + (if (null? p1340) + r1341 + (if (eq? p1340 (quote any)) + (cons (quote ()) r1341) + (if (pair? p1340) + (match-empty1322 + (car p1340) + (match-empty1322 (cdr p1340) r1341)) + (if (eq? p1340 (quote each-any)) + (cons (quote ()) r1341) + (let ((atom-key1342 (vector-ref p1340 0))) + (if (memv atom-key1342 (quote (each))) + (match-empty1322 (vector-ref p1340 1) r1341) + (if (memv atom-key1342 (quote (free-id atom))) + r1341 + (if (memv atom-key1342 (quote (vector))) + (match-empty1322 + (vector-ref p1340 1) + r1341))))))))))) + (match-each-any1321 + (lambda (e1343 w1344 mod1345) + (if (pair? e1343) + (let ((l1346 (match-each-any1321 + (cdr e1343) + w1344 + mod1345))) + (if l1346 + (cons (wrap143 (car e1343) w1344 mod1345) l1346) #f)) - (if (null? e3704) + (if (null? e1343) '() - (if (syntax-object?2460 e3704) - (match-each-any3682 - (syntax-object-expression2461 e3704) - (join-wraps2495 - w3705 - (syntax-object-wrap2462 e3704)) - mod3706) + (if (syntax-object?99 e1343) + (match-each-any1321 + (syntax-object-expression100 e1343) + (join-wraps134 + w1344 + (syntax-object-wrap101 e1343)) + mod1345) #f))))) - (match-each3681 - (lambda (e3708 p3709 w3710 mod3711) - (if (pair? e3708) - (let ((first3712 - (match3685 - (car e3708) - p3709 - w3710 + (match-each1320 + (lambda (e1347 p1348 w1349 mod1350) + (if (pair? e1347) + (let ((first1351 + (match1324 + (car e1347) + p1348 + w1349 '() - mod3711))) - (if first3712 - (let ((rest3713 - (match-each3681 - (cdr e3708) - p3709 - w3710 - mod3711))) - (if rest3713 (cons first3712 rest3713) #f)) + mod1350))) + (if first1351 + (let ((rest1352 + (match-each1320 + (cdr e1347) + p1348 + w1349 + mod1350))) + (if rest1352 (cons first1351 rest1352) #f)) #f)) - (if (null? e3708) + (if (null? e1347) '() - (if (syntax-object?2460 e3708) - (match-each3681 - (syntax-object-expression2461 e3708) - p3709 - (join-wraps2495 - w3710 - (syntax-object-wrap2462 e3708)) - (syntax-object-module2463 e3708)) + (if (syntax-object?99 e1347) + (match-each1320 + (syntax-object-expression100 e1347) + p1348 + (join-wraps134 + w1349 + (syntax-object-wrap101 e1347)) + (syntax-object-module102 e1347)) #f)))))) (set! $sc-dispatch - (lambda (e3714 p3715) - (if (eq? p3715 (quote any)) - (list e3714) - (if (syntax-object?2460 e3714) - (match*3684 - (syntax-object-expression2461 e3714) - p3715 - (syntax-object-wrap2462 e3714) + (lambda (e1353 p1354) + (if (eq? p1354 (quote any)) + (list e1353) + (if (syntax-object?99 e1353) + (match*1323 + (syntax-object-expression100 e1353) + p1354 + (syntax-object-wrap101 e1353) '() - (syntax-object-module2463 e3714)) - (match*3684 - e3714 - p3715 + (syntax-object-module102 e1353)) + (match*1323 + e1353 + p1354 '(()) '() #f))))))))) @@ -8497,11 +8336,11 @@ (define with-syntax (make-syncase-macro 'macro - (lambda (x3716) - ((lambda (tmp3717) - ((lambda (tmp3718) - (if tmp3718 - (apply (lambda (_3719 e13720 e23721) + (lambda (x1355) + ((lambda (tmp1356) + ((lambda (tmp1357) + (if tmp1357 + (apply (lambda (_1358 e11359 e21360) (cons '#(syntax-object begin ((top) @@ -8512,11 +8351,11 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - (cons e13720 e23721))) - tmp3718) - ((lambda (tmp3723) - (if tmp3723 - (apply (lambda (_3724 out3725 in3726 e13727 e23728) + (cons e11359 e21360))) + tmp1357) + ((lambda (tmp1362) + (if tmp1362 + (apply (lambda (_1363 out1364 in1365 e11366 e21367) (list '#(syntax-object syntax-case ((top) @@ -8527,9 +8366,9 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - in3726 + in1365 '() - (list out3725 + (list out1364 (cons '#(syntax-object begin ((top) @@ -8547,11 +8386,11 @@ #((top)) #("i"))) (hygiene guile)) - (cons e13727 e23728))))) - tmp3723) - ((lambda (tmp3730) - (if tmp3730 - (apply (lambda (_3731 out3732 in3733 e13734 e23735) + (cons e11366 e21367))))) + tmp1362) + ((lambda (tmp1369) + (if tmp1369 + (apply (lambda (_1370 out1371 in1372 e11373 e21374) (list '#(syntax-object syntax-case ((top) @@ -8579,9 +8418,9 @@ #((top)) #("i"))) (hygiene guile)) - in3733) + in1372) '() - (list out3732 + (list out1371 (cons '#(syntax-object begin ((top) @@ -8603,35 +8442,35 @@ #((top)) #("i"))) (hygiene guile)) - (cons e13734 e23735))))) - tmp3730) + (cons e11373 e21374))))) + tmp1369) (syntax-violation #f "source expression failed to match any pattern" - tmp3717))) + tmp1356))) ($sc-dispatch - tmp3717 + tmp1356 '(any #(each (any any)) any . each-any))))) ($sc-dispatch - tmp3717 + tmp1356 '(any ((any any)) any . each-any))))) ($sc-dispatch - tmp3717 + tmp1356 '(any () any . each-any)))) - x3716)))) + x1355)))) (define syntax-rules (make-syncase-macro 'macro - (lambda (x3739) - ((lambda (tmp3740) - ((lambda (tmp3741) - (if tmp3741 - (apply (lambda (_3742 - k3743 - keyword3744 - pattern3745 - template3746) + (lambda (x1378) + ((lambda (tmp1379) + ((lambda (tmp1380) + (if tmp1380 + (apply (lambda (_1381 + k1382 + keyword1383 + pattern1384 + template1385) (list '#(syntax-object lambda ((top) @@ -8672,8 +8511,8 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - (cons k3743 - (map (lambda (tmp3749 tmp3748) + (cons k1382 + (map (lambda (tmp1388 tmp1387) (list (cons '#(syntax-object dummy ((top) @@ -8703,7 +8542,7 @@ #("i"))) (hygiene guile)) - tmp3748) + tmp1387) (list '#(syntax-object syntax ((top) @@ -8733,34 +8572,34 @@ #("i"))) (hygiene guile)) - tmp3749))) - template3746 - pattern3745)))))) - tmp3741) + tmp1388))) + template1385 + pattern1384)))))) + tmp1380) (syntax-violation #f "source expression failed to match any pattern" - tmp3740))) + tmp1379))) ($sc-dispatch - tmp3740 + tmp1379 '(any each-any . #(each ((any . any) any)))))) - x3739)))) + x1378)))) (define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) 'macro - (lambda (x3750) - ((lambda (tmp3751) - ((lambda (tmp3752) - (if (if tmp3752 - (apply (lambda (let*3753 x3754 v3755 e13756 e23757) - (and-map identifier? x3754)) - tmp3752) + (lambda (x1389) + ((lambda (tmp1390) + ((lambda (tmp1391) + (if (if tmp1391 + (apply (lambda (let*1392 x1393 v1394 e11395 e21396) + (and-map identifier? x1393)) + tmp1391) #f) - (apply (lambda (let*3759 x3760 v3761 e13762 e23763) - (letrec ((f3764 (lambda (bindings3765) - (if (null? bindings3765) + (apply (lambda (let*1398 x1399 v1400 e11401 e21402) + (letrec ((f1403 (lambda (bindings1404) + (if (null? bindings1404) (cons '#(syntax-object let ((top) @@ -8784,12 +8623,12 @@ #("i"))) (hygiene guile)) (cons '() - (cons e13762 e23763))) - ((lambda (tmp3769) - ((lambda (tmp3770) - (if tmp3770 - (apply (lambda (body3771 - binding3772) + (cons e11401 e21402))) + ((lambda (tmp1408) + ((lambda (tmp1409) + (if tmp1409 + (apply (lambda (body1410 + binding1411) (list '#(syntax-object let ((top) @@ -8837,51 +8676,51 @@ #("i"))) (hygiene guile)) - (list binding3772) - body3771)) - tmp3770) + (list binding1411) + body1410)) + tmp1409) (syntax-violation #f "source expression failed to match any pattern" - tmp3769))) + tmp1408))) ($sc-dispatch - tmp3769 + tmp1408 '(any any)))) - (list (f3764 (cdr bindings3765)) - (car bindings3765))))))) - (f3764 (map list x3760 v3761)))) - tmp3752) + (list (f1403 (cdr bindings1404)) + (car bindings1404))))))) + (f1403 (map list x1399 v1400)))) + tmp1391) (syntax-violation #f "source expression failed to match any pattern" - tmp3751))) + tmp1390))) ($sc-dispatch - tmp3751 + tmp1390 '(any #(each (any any)) any . each-any)))) - x3750)))) + x1389)))) (define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) 'macro - (lambda (orig-x3773) - ((lambda (tmp3774) - ((lambda (tmp3775) - (if tmp3775 - (apply (lambda (_3776 - var3777 - init3778 - step3779 - e03780 - e13781 - c3782) - ((lambda (tmp3783) - ((lambda (tmp3784) - (if tmp3784 - (apply (lambda (step3785) - ((lambda (tmp3786) - ((lambda (tmp3787) - (if tmp3787 + (lambda (orig-x1412) + ((lambda (tmp1413) + ((lambda (tmp1414) + (if tmp1414 + (apply (lambda (_1415 + var1416 + init1417 + step1418 + e01419 + e11420 + c1421) + ((lambda (tmp1422) + ((lambda (tmp1423) + (if tmp1423 + (apply (lambda (step1424) + ((lambda (tmp1425) + ((lambda (tmp1426) + (if tmp1426 (apply (lambda () (list '#(syntax-object let @@ -8962,8 +8801,8 @@ (hygiene guile)) (map list - var3777 - init3778) + var1416 + init1417) (list '#(syntax-object if ((top) @@ -9042,7 +8881,7 @@ #("i"))) (hygiene guile)) - e03780) + e01419) (cons '#(syntax-object begin ((top) @@ -9083,7 +8922,7 @@ (hygiene guile)) (append - c3782 + c1421 (list (cons '#(syntax-object doloop ((top) @@ -9123,12 +8962,12 @@ #("i"))) (hygiene guile)) - step3785))))))) - tmp3787) - ((lambda (tmp3792) - (if tmp3792 - (apply (lambda (e13793 - e23794) + step1424))))))) + tmp1426) + ((lambda (tmp1431) + (if tmp1431 + (apply (lambda (e11432 + e21433) (list '#(syntax-object let ((top) @@ -9222,8 +9061,8 @@ (hygiene guile)) (map list - var3777 - init3778) + var1416 + init1417) (list '#(syntax-object if ((top) @@ -9270,7 +9109,7 @@ #("i"))) (hygiene guile)) - e03780 + e01419 (cons '#(syntax-object begin ((top) @@ -9317,8 +9156,8 @@ #("i"))) (hygiene guile)) - (cons e13793 - e23794)) + (cons e11432 + e21433)) (cons '#(syntax-object begin ((top) @@ -9366,7 +9205,7 @@ (hygiene guile)) (append - c3782 + c1421 (list (cons '#(syntax-object doloop ((top) @@ -9413,75 +9252,75 @@ #("i"))) (hygiene guile)) - step3785))))))) - tmp3792) + step1424))))))) + tmp1431) (syntax-violation #f "source expression failed to match any pattern" - tmp3786))) + tmp1425))) ($sc-dispatch - tmp3786 + tmp1425 '(any . each-any))))) - ($sc-dispatch tmp3786 (quote ())))) - e13781)) - tmp3784) + ($sc-dispatch tmp1425 (quote ())))) + e11420)) + tmp1423) (syntax-violation #f "source expression failed to match any pattern" - tmp3783))) - ($sc-dispatch tmp3783 (quote each-any)))) - (map (lambda (v3801 s3802) - ((lambda (tmp3803) - ((lambda (tmp3804) - (if tmp3804 - (apply (lambda () v3801) tmp3804) - ((lambda (tmp3805) - (if tmp3805 - (apply (lambda (e3806) e3806) - tmp3805) - ((lambda (_3807) + tmp1422))) + ($sc-dispatch tmp1422 (quote each-any)))) + (map (lambda (v1440 s1441) + ((lambda (tmp1442) + ((lambda (tmp1443) + (if tmp1443 + (apply (lambda () v1440) tmp1443) + ((lambda (tmp1444) + (if tmp1444 + (apply (lambda (e1445) e1445) + tmp1444) + ((lambda (_1446) (syntax-violation 'do "bad step expression" - orig-x3773 - s3802)) - tmp3803))) - ($sc-dispatch tmp3803 (quote (any)))))) - ($sc-dispatch tmp3803 (quote ())))) - s3802)) - var3777 - step3779))) - tmp3775) + orig-x1412 + s1441)) + tmp1442))) + ($sc-dispatch tmp1442 (quote (any)))))) + ($sc-dispatch tmp1442 (quote ())))) + s1441)) + var1416 + step1418))) + tmp1414) (syntax-violation #f "source expression failed to match any pattern" - tmp3774))) + tmp1413))) ($sc-dispatch - tmp3774 + tmp1413 '(any #(each (any any . any)) (any . each-any) . each-any)))) - orig-x3773)))) + orig-x1412)))) (define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) 'macro - (letrec ((quasicons3810 - (lambda (x3814 y3815) - ((lambda (tmp3816) - ((lambda (tmp3817) - (if tmp3817 - (apply (lambda (x3818 y3819) - ((lambda (tmp3820) - ((lambda (tmp3821) - (if tmp3821 - (apply (lambda (dy3822) - ((lambda (tmp3823) - ((lambda (tmp3824) - (if tmp3824 - (apply (lambda (dx3825) + (letrec ((quasicons1449 + (lambda (x1453 y1454) + ((lambda (tmp1455) + ((lambda (tmp1456) + (if tmp1456 + (apply (lambda (x1457 y1458) + ((lambda (tmp1459) + ((lambda (tmp1460) + (if tmp1460 + (apply (lambda (dy1461) + ((lambda (tmp1462) + ((lambda (tmp1463) + (if tmp1463 + (apply (lambda (dx1464) (list '#(syntax-object quote ((top) @@ -9530,11 +9369,11 @@ "i"))) (hygiene guile)) - (cons dx3825 - dy3822))) - tmp3824) - ((lambda (_3826) - (if (null? dy3822) + (cons dx1464 + dy1461))) + tmp1463) + ((lambda (_1465) + (if (null? dy1461) (list '#(syntax-object list ((top) @@ -9583,7 +9422,7 @@ "i"))) (hygiene guile)) - x3818) + x1457) (list '#(syntax-object cons ((top) @@ -9632,11 +9471,11 @@ "i"))) (hygiene guile)) - x3818 - y3819))) - tmp3823))) + x1457 + y1458))) + tmp1462))) ($sc-dispatch - tmp3823 + tmp1462 '(#(free-id #(syntax-object quote @@ -9679,11 +9518,11 @@ (hygiene guile))) any)))) - x3818)) - tmp3821) - ((lambda (tmp3827) - (if tmp3827 - (apply (lambda (stuff3828) + x1457)) + tmp1460) + ((lambda (tmp1466) + (if tmp1466 + (apply (lambda (stuff1467) (cons '#(syntax-object list ((top) @@ -9724,10 +9563,10 @@ "i"))) (hygiene guile)) - (cons x3818 - stuff3828))) - tmp3827) - ((lambda (else3829) + (cons x1457 + stuff1467))) + tmp1466) + ((lambda (else1468) (list '#(syntax-object cons ((top) @@ -9759,11 +9598,11 @@ "i" "i"))) (hygiene guile)) - x3818 - y3819)) - tmp3820))) + x1457 + y1458)) + tmp1459))) ($sc-dispatch - tmp3820 + tmp1459 '(#(free-id #(syntax-object list @@ -9792,7 +9631,7 @@ . any))))) ($sc-dispatch - tmp3820 + tmp1459 '(#(free-id #(syntax-object quote @@ -9816,25 +9655,25 @@ #("i" "i" "i" "i"))) (hygiene guile))) any)))) - y3819)) - tmp3817) + y1458)) + tmp1456) (syntax-violation #f "source expression failed to match any pattern" - tmp3816))) - ($sc-dispatch tmp3816 (quote (any any))))) - (list x3814 y3815)))) - (quasiappend3811 - (lambda (x3830 y3831) - ((lambda (tmp3832) - ((lambda (tmp3833) - (if tmp3833 - (apply (lambda (x3834 y3835) - ((lambda (tmp3836) - ((lambda (tmp3837) - (if tmp3837 - (apply (lambda () x3834) tmp3837) - ((lambda (_3838) + tmp1455))) + ($sc-dispatch tmp1455 (quote (any any))))) + (list x1453 y1454)))) + (quasiappend1450 + (lambda (x1469 y1470) + ((lambda (tmp1471) + ((lambda (tmp1472) + (if tmp1472 + (apply (lambda (x1473 y1474) + ((lambda (tmp1475) + ((lambda (tmp1476) + (if tmp1476 + (apply (lambda () x1473) tmp1476) + ((lambda (_1477) (list '#(syntax-object append ((top) @@ -9863,11 +9702,11 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x3834 - y3835)) - tmp3836))) + x1473 + y1474)) + tmp1475))) ($sc-dispatch - tmp3836 + tmp1475 '(#(free-id #(syntax-object quote @@ -9891,22 +9730,22 @@ #("i" "i" "i" "i"))) (hygiene guile))) ())))) - y3835)) - tmp3833) + y1474)) + tmp1472) (syntax-violation #f "source expression failed to match any pattern" - tmp3832))) - ($sc-dispatch tmp3832 (quote (any any))))) - (list x3830 y3831)))) - (quasivector3812 - (lambda (x3839) - ((lambda (tmp3840) - ((lambda (x3841) - ((lambda (tmp3842) - ((lambda (tmp3843) - (if tmp3843 - (apply (lambda (x3844) + tmp1471))) + ($sc-dispatch tmp1471 (quote (any any))))) + (list x1469 y1470)))) + (quasivector1451 + (lambda (x1478) + ((lambda (tmp1479) + ((lambda (x1480) + ((lambda (tmp1481) + ((lambda (tmp1482) + (if tmp1482 + (apply (lambda (x1483) (list '#(syntax-object quote ((top) @@ -9932,11 +9771,11 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - (list->vector x3844))) - tmp3843) - ((lambda (tmp3846) - (if tmp3846 - (apply (lambda (x3847) + (list->vector x1483))) + tmp1482) + ((lambda (tmp1485) + (if tmp1485 + (apply (lambda (x1486) (cons '#(syntax-object vector ((top) @@ -9965,9 +9804,9 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x3847)) - tmp3846) - ((lambda (_3849) + x1486)) + tmp1485) + ((lambda (_1488) (list '#(syntax-object list->vector ((top) @@ -9993,10 +9832,10 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x3841)) - tmp3842))) + x1480)) + tmp1481))) ($sc-dispatch - tmp3842 + tmp1481 '(#(free-id #(syntax-object list @@ -10016,7 +9855,7 @@ . each-any))))) ($sc-dispatch - tmp3842 + tmp1481 '(#(free-id #(syntax-object quote @@ -10034,18 +9873,18 @@ #("i" "i" "i" "i"))) (hygiene guile))) each-any)))) - x3841)) - tmp3840)) - x3839))) - (quasi3813 - (lambda (p3850 lev3851) - ((lambda (tmp3852) - ((lambda (tmp3853) - (if tmp3853 - (apply (lambda (p3854) - (if (= lev3851 0) - p3854 - (quasicons3810 + x1480)) + tmp1479)) + x1478))) + (quasi1452 + (lambda (p1489 lev1490) + ((lambda (tmp1491) + ((lambda (tmp1492) + (if tmp1492 + (apply (lambda (p1493) + (if (= lev1490 0) + p1493 + (quasicons1449 '(#(syntax-object quote ((top) @@ -10080,18 +9919,18 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) - (quasi3813 (list p3854) (- lev3851 1))))) - tmp3853) - ((lambda (tmp3855) - (if (if tmp3855 - (apply (lambda (args3856) (= lev3851 0)) - tmp3855) + (quasi1452 (list p1493) (- lev1490 1))))) + tmp1492) + ((lambda (tmp1494) + (if (if tmp1494 + (apply (lambda (args1495) (= lev1490 0)) + tmp1494) #f) - (apply (lambda (args3857) + (apply (lambda (args1496) (syntax-violation 'unquote "unquote takes exactly one argument" - p3850 + p1489 (cons '#(syntax-object unquote ((top) @@ -10112,17 +9951,17 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - args3857))) - tmp3855) - ((lambda (tmp3858) - (if tmp3858 - (apply (lambda (p3859 q3860) - (if (= lev3851 0) - (quasiappend3811 - p3859 - (quasi3813 q3860 lev3851)) - (quasicons3810 - (quasicons3810 + args1496))) + tmp1494) + ((lambda (tmp1497) + (if tmp1497 + (apply (lambda (p1498 q1499) + (if (= lev1490 0) + (quasiappend1450 + p1498 + (quasi1452 q1499 lev1490)) + (quasicons1449 + (quasicons1449 '(#(syntax-object quote ((top) @@ -10169,22 +10008,22 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile))) - (quasi3813 - (list p3859) - (- lev3851 1))) - (quasi3813 q3860 lev3851)))) - tmp3858) - ((lambda (tmp3861) - (if (if tmp3861 - (apply (lambda (args3862 q3863) - (= lev3851 0)) - tmp3861) + (quasi1452 + (list p1498) + (- lev1490 1))) + (quasi1452 q1499 lev1490)))) + tmp1497) + ((lambda (tmp1500) + (if (if tmp1500 + (apply (lambda (args1501 q1502) + (= lev1490 0)) + tmp1500) #f) - (apply (lambda (args3864 q3865) + (apply (lambda (args1503 q1504) (syntax-violation 'unquote-splicing "unquote-splicing takes exactly one argument" - p3850 + p1489 (cons '#(syntax-object unquote-splicing ((top) @@ -10214,12 +10053,12 @@ "i" "i"))) (hygiene guile)) - args3864))) - tmp3861) - ((lambda (tmp3866) - (if tmp3866 - (apply (lambda (p3867) - (quasicons3810 + args1503))) + tmp1500) + ((lambda (tmp1505) + (if tmp1505 + (apply (lambda (p1506) + (quasicons1449 '(#(syntax-object quote ((top) @@ -10278,30 +10117,30 @@ "i" "i"))) (hygiene guile))) - (quasi3813 - (list p3867) - (+ lev3851 1)))) - tmp3866) - ((lambda (tmp3868) - (if tmp3868 - (apply (lambda (p3869 q3870) - (quasicons3810 - (quasi3813 - p3869 - lev3851) - (quasi3813 - q3870 - lev3851))) - tmp3868) - ((lambda (tmp3871) - (if tmp3871 - (apply (lambda (x3872) - (quasivector3812 - (quasi3813 - x3872 - lev3851))) - tmp3871) - ((lambda (p3874) + (quasi1452 + (list p1506) + (+ lev1490 1)))) + tmp1505) + ((lambda (tmp1507) + (if tmp1507 + (apply (lambda (p1508 q1509) + (quasicons1449 + (quasi1452 + p1508 + lev1490) + (quasi1452 + q1509 + lev1490))) + tmp1507) + ((lambda (tmp1510) + (if tmp1510 + (apply (lambda (x1511) + (quasivector1451 + (quasi1452 + x1511 + lev1490))) + tmp1510) + ((lambda (p1513) (list '#(syntax-object quote ((top) @@ -10334,16 +10173,16 @@ "i"))) (hygiene guile)) - p3874)) - tmp3852))) + p1513)) + tmp1491))) ($sc-dispatch - tmp3852 + tmp1491 '#(vector each-any))))) ($sc-dispatch - tmp3852 + tmp1491 '(any . any))))) ($sc-dispatch - tmp3852 + tmp1491 '(#(free-id #(syntax-object quasiquote @@ -10363,7 +10202,7 @@ (hygiene guile))) any))))) ($sc-dispatch - tmp3852 + tmp1491 '((#(free-id #(syntax-object unquote-splicing @@ -10386,7 +10225,7 @@ . any))))) ($sc-dispatch - tmp3852 + tmp1491 '((#(free-id #(syntax-object unquote-splicing @@ -10408,7 +10247,7 @@ . any))))) ($sc-dispatch - tmp3852 + tmp1491 '(#(free-id #(syntax-object unquote @@ -10426,7 +10265,7 @@ . any))))) ($sc-dispatch - tmp3852 + tmp1491 '(#(free-id #(syntax-object unquote @@ -10439,44 +10278,44 @@ #("i" "i" "i" "i"))) (hygiene guile))) any)))) - p3850)))) - (lambda (x3875) - ((lambda (tmp3876) - ((lambda (tmp3877) - (if tmp3877 - (apply (lambda (_3878 e3879) (quasi3813 e3879 0)) - tmp3877) + p1489)))) + (lambda (x1514) + ((lambda (tmp1515) + ((lambda (tmp1516) + (if tmp1516 + (apply (lambda (_1517 e1518) (quasi1452 e1518 0)) + tmp1516) (syntax-violation #f "source expression failed to match any pattern" - tmp3876))) - ($sc-dispatch tmp3876 (quote (any any))))) - x3875))))) + tmp1515))) + ($sc-dispatch tmp1515 (quote (any any))))) + x1514))))) (define include (make-syncase-macro 'macro - (lambda (x3880) - (letrec ((read-file3881 - (lambda (fn3882 k3883) - (let ((p3884 (open-input-file fn3882))) - (letrec ((f3885 (lambda (x3886) - (if (eof-object? x3886) + (lambda (x1519) + (letrec ((read-file1520 + (lambda (fn1521 k1522) + (let ((p1523 (open-input-file fn1521))) + (letrec ((f1524 (lambda (x1525) + (if (eof-object? x1525) (begin - (close-input-port p3884) + (close-input-port p1523) '()) - (cons (datum->syntax k3883 x3886) - (f3885 (read p3884))))))) - (f3885 (read p3884))))))) - ((lambda (tmp3887) - ((lambda (tmp3888) - (if tmp3888 - (apply (lambda (k3889 filename3890) - (let ((fn3891 (syntax->datum filename3890))) - ((lambda (tmp3892) - ((lambda (tmp3893) - (if tmp3893 - (apply (lambda (exp3894) + (cons (datum->syntax k1522 x1525) + (f1524 (read p1523))))))) + (f1524 (read p1523))))))) + ((lambda (tmp1526) + ((lambda (tmp1527) + (if tmp1527 + (apply (lambda (k1528 filename1529) + (let ((fn1530 (syntax->datum filename1529))) + ((lambda (tmp1531) + ((lambda (tmp1532) + (if tmp1532 + (apply (lambda (exp1533) (cons '#(syntax-object begin ((top) @@ -10503,73 +10342,73 @@ #((top)) #("i"))) (hygiene guile)) - exp3894)) - tmp3893) + exp1533)) + tmp1532) (syntax-violation #f "source expression failed to match any pattern" - tmp3892))) - ($sc-dispatch tmp3892 (quote each-any)))) - (read-file3881 fn3891 k3889)))) - tmp3888) + tmp1531))) + ($sc-dispatch tmp1531 (quote each-any)))) + (read-file1520 fn1530 k1528)))) + tmp1527) (syntax-violation #f "source expression failed to match any pattern" - tmp3887))) - ($sc-dispatch tmp3887 (quote (any any))))) - x3880))))) + tmp1526))) + ($sc-dispatch tmp1526 (quote (any any))))) + x1519))))) (define unquote (make-syncase-macro 'macro - (lambda (x3896) - ((lambda (tmp3897) - ((lambda (tmp3898) - (if tmp3898 - (apply (lambda (_3899 e3900) + (lambda (x1535) + ((lambda (tmp1536) + ((lambda (tmp1537) + (if tmp1537 + (apply (lambda (_1538 e1539) (syntax-violation 'unquote "expression not valid outside of quasiquote" - x3896)) - tmp3898) + x1535)) + tmp1537) (syntax-violation #f "source expression failed to match any pattern" - tmp3897))) - ($sc-dispatch tmp3897 (quote (any any))))) - x3896)))) + tmp1536))) + ($sc-dispatch tmp1536 (quote (any any))))) + x1535)))) (define unquote-splicing (make-syncase-macro 'macro - (lambda (x3901) - ((lambda (tmp3902) - ((lambda (tmp3903) - (if tmp3903 - (apply (lambda (_3904 e3905) + (lambda (x1540) + ((lambda (tmp1541) + ((lambda (tmp1542) + (if tmp1542 + (apply (lambda (_1543 e1544) (syntax-violation 'unquote-splicing "expression not valid outside of quasiquote" - x3901)) - tmp3903) + x1540)) + tmp1542) (syntax-violation #f "source expression failed to match any pattern" - tmp3902))) - ($sc-dispatch tmp3902 (quote (any any))))) - x3901)))) + tmp1541))) + ($sc-dispatch tmp1541 (quote (any any))))) + x1540)))) (define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) 'macro - (lambda (x3906) - ((lambda (tmp3907) - ((lambda (tmp3908) - (if tmp3908 - (apply (lambda (_3909 e3910 m13911 m23912) - ((lambda (tmp3913) - ((lambda (body3914) + (lambda (x1545) + ((lambda (tmp1546) + ((lambda (tmp1547) + (if tmp1547 + (apply (lambda (_1548 e1549 m11550 m21551) + ((lambda (tmp1552) + ((lambda (body1553) (list '#(syntax-object let ((top) @@ -10598,16 +10437,16 @@ #((top)) #("i"))) (hygiene guile)) - e3910)) - body3914)) - tmp3913)) - (letrec ((f3915 (lambda (clause3916 clauses3917) - (if (null? clauses3917) - ((lambda (tmp3919) - ((lambda (tmp3920) - (if tmp3920 - (apply (lambda (e13921 - e23922) + e1549)) + body1553)) + tmp1552)) + (letrec ((f1554 (lambda (clause1555 clauses1556) + (if (null? clauses1556) + ((lambda (tmp1558) + ((lambda (tmp1559) + (if tmp1559 + (apply (lambda (e11560 + e21561) (cons '#(syntax-object begin ((top) @@ -10655,14 +10494,14 @@ #("i"))) (hygiene guile)) - (cons e13921 - e23922))) - tmp3920) - ((lambda (tmp3924) - (if tmp3924 - (apply (lambda (k3925 - e13926 - e23927) + (cons e11560 + e21561))) + tmp1559) + ((lambda (tmp1563) + (if tmp1563 + (apply (lambda (k1564 + e11565 + e21566) (list '#(syntax-object if ((top) @@ -10863,7 +10702,7 @@ #("i"))) (hygiene guile)) - k3925)) + k1564)) (cons '#(syntax-object begin ((top) @@ -10914,24 +10753,24 @@ #("i"))) (hygiene guile)) - (cons e13926 - e23927)))) - tmp3924) - ((lambda (_3930) + (cons e11565 + e21566)))) + tmp1563) + ((lambda (_1569) (syntax-violation 'case "bad clause" - x3906 - clause3916)) - tmp3919))) + x1545 + clause1555)) + tmp1558))) ($sc-dispatch - tmp3919 + tmp1558 '(each-any any . each-any))))) ($sc-dispatch - tmp3919 + tmp1558 '(#(free-id #(syntax-object else @@ -10957,15 +10796,15 @@ any . each-any)))) - clause3916) - ((lambda (tmp3931) - ((lambda (rest3932) - ((lambda (tmp3933) - ((lambda (tmp3934) - (if tmp3934 - (apply (lambda (k3935 - e13936 - e23937) + clause1555) + ((lambda (tmp1570) + ((lambda (rest1571) + ((lambda (tmp1572) + ((lambda (tmp1573) + (if tmp1573 + (apply (lambda (k1574 + e11575 + e21576) (list '#(syntax-object if ((top) @@ -11182,7 +11021,7 @@ #("i"))) (hygiene guile)) - k3935)) + k1574)) (cons '#(syntax-object begin ((top) @@ -11237,46 +11076,46 @@ #("i"))) (hygiene guile)) - (cons e13936 - e23937)) - rest3932)) - tmp3934) - ((lambda (_3940) + (cons e11575 + e21576)) + rest1571)) + tmp1573) + ((lambda (_1579) (syntax-violation 'case "bad clause" - x3906 - clause3916)) - tmp3933))) + x1545 + clause1555)) + tmp1572))) ($sc-dispatch - tmp3933 + tmp1572 '(each-any any . each-any)))) - clause3916)) - tmp3931)) - (f3915 (car clauses3917) - (cdr clauses3917))))))) - (f3915 m13911 m23912)))) - tmp3908) + clause1555)) + tmp1570)) + (f1554 (car clauses1556) + (cdr clauses1556))))))) + (f1554 m11550 m21551)))) + tmp1547) (syntax-violation #f "source expression failed to match any pattern" - tmp3907))) + tmp1546))) ($sc-dispatch - tmp3907 + tmp1546 '(any any any . each-any)))) - x3906)))) + x1545)))) (define identifier-syntax (make-syncase-macro 'macro - (lambda (x3941) - ((lambda (tmp3942) - ((lambda (tmp3943) - (if tmp3943 - (apply (lambda (_3944 e3945) + (lambda (x1580) + ((lambda (tmp1581) + ((lambda (tmp1582) + (if tmp1582 + (apply (lambda (_1583 e1584) (list '#(syntax-object lambda ((top) @@ -11365,8 +11204,8 @@ #((top)) #("i"))) (hygiene guile)) - e3945)) - (list (cons _3944 + e1584)) + (list (cons _1583 '(#(syntax-object x ((top) @@ -11406,7 +11245,7 @@ #((top)) #("i"))) (hygiene guile)) - (cons e3945 + (cons e1584 '(#(syntax-object x ((top) @@ -11434,11 +11273,11 @@ #("i"))) (hygiene guile))))))))) - tmp3943) + tmp1582) (syntax-violation #f "source expression failed to match any pattern" - tmp3942))) - ($sc-dispatch tmp3942 (quote (any any))))) - x3941)))) + tmp1581))) + ($sc-dispatch tmp1581 (quote (any any))))) + x1580)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index cbbcabd72..f1f6e9ae0 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -941,9 +941,7 @@ (define source-wrap (lambda (x w s defmod) - (if (and s (pair? x)) - (set-source-properties! x s)) - (wrap x w defmod))) + (wrap (decorate-source x s) w defmod))) ;;; expanding @@ -1101,7 +1099,9 @@ (valid-bound-ids? (lambda-var-list (syntax args)))) ; need lambda here... (values 'define-form (wrap (syntax name) w mod) - (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) + (decorate-source + (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) + s) empty-wrap s mod)) ((_ name) (id? (syntax name)) From 179fe3363241ea1aeb48f1f63d13d2dd12196dcf Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 20 Jun 2009 14:26:54 +0200 Subject: [PATCH 241/375] put autocompiled files into ~/.cache or $XDG_CACHE_HOME * module/system/base/compile.scm (compiled-file-name): Remove unneeded path separator. * libguile/load.c (scm_init_load_path): Change so the default cache path is ~/.cache/guile/ccache/1.9, and respect $XDG_CACHE_HOME. --- libguile/load.c | 38 +++++++++++++++++++--------------- module/system/base/compile.scm | 5 ++++- 2 files changed, 25 insertions(+), 18 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index d8139e657..890b0f824 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -247,24 +247,28 @@ scm_init_load_path () #endif /* SCM_LIBRARY_DIR */ { - char *home; - - home = getenv ("HOME"); + char cachedir[1024]; + char *e; #ifdef HAVE_GETPWENT - if (!home) - { - struct passwd *pwd; - pwd = getpwuid (getuid ()); - if (pwd) - home = pwd->pw_dir; - } + struct passwd *pwd; +#endif + +#define FALLBACK_DIR "guile/ccache/"SCM_EFFECTIVE_VERSION + + if ((e = getenv ("XDG_CACHE_HOME"))) + snprintf (cachedir, sizeof(cachedir), "%s" FALLBACK_DIR, e); + else if ((e = getenv ("HOME"))) + snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR, e); +#ifdef HAVE_GETPWENT + else if ((pwd = getpwuid (getuid ())) && pwd->pw_dir) + snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR, + pwd->pw_dir); #endif /* HAVE_GETPWENT */ - if (home) - { char buf[1024]; - snprintf (buf, sizeof(buf), - "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home); - *scm_loc_compile_fallback_path = scm_from_locale_string (buf); - } + else + cachedir[0] = 0; + + if (cachedir[0]) + *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir); } env = getenv ("GUILE_LOAD_PATH"); diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index dfe8823be..22f8e04f1 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -131,7 +131,10 @@ (else (car %load-compiled-extensions)))) (and %compile-fallback-path (let ((f (string-append - %compile-fallback-path "/" (canonicalize-path file) + %compile-fallback-path + ;; no need for '/' separator here, canonicalize-path + ;; will give us an absolute path + (canonicalize-path file) (compiled-extension)))) (and (false-if-exception (ensure-writable-dir (dirname f))) f)))) From 8806afa7dd0582f774daadafbe6ec8163b2deea8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 21 Jun 2009 12:41:46 +0200 Subject: [PATCH 242/375] Fix crash when marking closed custom bytevector port * libguile/r6rs-ports.c (cbp_mark): A closed port will have had its stream destroyed, so don't dereference the stream in that case. Patch by Mike Gran. --- libguile/r6rs-ports.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index f10afe6d5..d77c2147a 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -211,7 +211,10 @@ static SCM cbp_mark (SCM port) { /* Mark the underlying method and object vector. */ - return (SCM_PACK (SCM_STREAM (port))); + if (SCM_OPENP (port)) + return SCM_PACK (SCM_STREAM (port)); + else + return SCM_BOOL_F; } static off_t From 4574ec212aad4df9571463ee4d45beb2607e51ad Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 21 Jun 2009 13:31:20 +0100 Subject: [PATCH 243/375] Deterministic test for the r6rs-ports.test segmentation fault * test-suite/tests/r6rs-ports.test ("7.2.7 Input Ports"): Add (gc), to test the (ex-)bug in cbp_mark () when marking a closed port. --- test-suite/tests/r6rs-ports.test | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 829258f87..df12e5cbc 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -342,6 +342,7 @@ close!))) (close-port port) + (gc) ; Test for marking a closed port. closed?))) From c60be0404dd07fb9e9747c02fabc45d38380ed17 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 21 Jun 2009 12:51:16 +0200 Subject: [PATCH 244/375] update .gitignore * .gitignore: Update. --- .gitignore | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/.gitignore b/.gitignore index ec59e5e70..29f29be5f 100644 --- a/.gitignore +++ b/.gitignore @@ -91,3 +91,20 @@ INSTALL *.pgs *.rn *.rns +/meta/gdb-uninstalled-guile +/meta/guile +/meta/uninstalled-env +/examples/box-module/box +/examples/box/box +/lib/alloca.h +/lib/charset.alias +/lib/configmake.h +/lib/ref-add.sed +/lib/ref-del.sed +/lib/stdlib.h +/lib/string.h +/lib/strings.h +/lib/sys/file.h +/lib/time.h +/lib/unistd.h +/lib/unistr/.dirstamp From cf6d8d344c8717629279f01acbb785e0d35a12a5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 21 Jun 2009 12:57:55 +0200 Subject: [PATCH 245/375] remove obsolete guile-vm.texi * doc/guile-vm.texi: Remove, has been folded into the Guile manual for a while now. * doc/Makefile.am: Remove guile-vm.texi. --- doc/Makefile.am | 4 +- doc/guile-vm.texi | 1042 --------------------------------------------- 2 files changed, 1 insertion(+), 1045 deletions(-) delete mode 100644 doc/guile-vm.texi diff --git a/doc/Makefile.am b/doc/Makefile.am index 712ece34a..0a6b14ed5 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 1998, 2002, 2006, 2008 Free Software Foundation, Inc. +## Copyright (C) 1998, 2002, 2006, 2008, 2009 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -43,5 +43,3 @@ include $(top_srcdir)/am/maintainer-dirs guile-api.alist: guile-api.alist-FORCE ( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist ) guile-api.alist-FORCE: - -info_TEXINFOS = guile-vm.texi diff --git a/doc/guile-vm.texi b/doc/guile-vm.texi deleted file mode 100644 index 927c09e88..000000000 --- a/doc/guile-vm.texi +++ /dev/null @@ -1,1042 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename guile-vm.info -@settitle Guile VM Specification -@footnotestyle end -@setchapternewpage odd -@c %**end of header - -@set EDITION 0.6 -@set VERSION 0.6 -@set UPDATED 2005-04-26 - -@c Macro for instruction definitions. -@macro insn{} -Instruction -@end macro - -@c For Scheme procedure definitions. -@macro scmproc{} -Scheme Procedure -@end macro - -@c Scheme records. -@macro scmrec{} -Record -@end macro - -@ifinfo -@dircategory Scheme Programming -@direntry -* Guile VM: (guile-vm). Guile's Virtual Machine. -@end direntry - -This file documents Guile VM. - -Copyright @copyright{} 2000 Keisuke Nishida -Copyright @copyright{} 2005 Ludovic Court`es - -Permission is granted to make and distribute verbatim copies of this -manual provided the copyright notice and this permission notice are -preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries a copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the -entire resulting derived work is distributed under the terms of a -permission notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation -approved by the Free Software Foundation. -@end ifinfo - -@titlepage -@title Guile VM Specification -@subtitle for Guile VM @value{VERSION} -@author Keisuke Nishida - -@page -@vskip 0pt plus 1filll -Edition @value{EDITION} @* -Updated for Guile VM @value{VERSION} @* -@value{UPDATED} @* - -Copyright @copyright{} 2000 Keisuke Nishida -Copyright @copyright{} 2005 Ludovic Court`es - -Permission is granted to make and distribute verbatim copies of this -manual provided the copyright notice and this permission notice are -preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the -entire resulting derived work is distributed under the terms of a -permission notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation -approved by the Free Software Foundation. -@end titlepage - -@contents - -@c ********************************************************************* -@node Top, Introduction, (dir), (dir) -@top Guile VM Specification - -This document would like to correspond to Guile VM @value{VERSION}. -However, be warned that important parts still correspond to version -0.0 and are not valid anymore. - -@menu -* Introduction:: -* Variable Management:: -* Instruction Set:: -* The Compiler:: -* Concept Index:: -* Function and Instruction Index:: -* Command and Variable Index:: - -@detailmenu - --- The Detailed Node Listing --- - -Instruction Set - -* Environment Control Instructions:: -* Branch Instructions:: -* Subprogram Control Instructions:: -* Data Control Instructions:: - -The Compiler - -* Overview:: -* The Language Front-Ends:: -* GHIL:: -* Compiling Scheme Code:: -* GLIL:: -* The Assembler:: - -@end detailmenu -@end menu - -@c ********************************************************************* -@node Introduction, Variable Management, Top, Top -@chapter What is Guile VM? - -A Guile VM has a set of registers and its own stack memory. Guile may -have more than one VM's. Each VM may execute at most one program at a -time. Guile VM is a CISC system so designed as to execute Scheme and -other languages efficiently. - -@unnumberedsubsec Registers - -@itemize -@item pc - Program counter ;; ip (instruction poiner) is better? -@item sp - Stack pointer -@item bp - Base pointer -@item ac - Accumulator -@end itemize - -@unnumberedsubsec Engine - -A VM may have one of three engines: reckless, regular, or debugging. -Reckless engine is fastest but dangerous. Regular engine is normally -fail-safe and reasonably fast. Debugging engine is safest and -functional but very slow. - -@unnumberedsubsec Memory - -Stack is the only memory that each VM owns. The other memory is shared -memory that is shared among every VM and other part of Guile. - -@unnumberedsubsec Program - -A VM program consists of a bytecode that is executed and an environment -in which execution is done. Each program is allocated in the shared -memory and may be executed by any VM. A program may call other programs -within a VM. - -@unnumberedsubsec Instruction - -Guile VM has dozens of system instructions and (possibly) hundreds of -functional instructions. Some Scheme procedures such as cons and car -are implemented as VM's builtin functions, which are very efficient. -Other procedures defined outside of the VM are also considered as VM's -functional features, since they do not change the state of VM. -Procedures defined within the VM are called subprograms. - -Most instructions deal with the accumulator (ac). The VM stores all -results from functions in ac, instead of pushing them into the stack. -I'm not sure whether this is a good thing or not. - -@node Variable Management, Instruction Set, Introduction, Top -@chapter Variable Management - -FIXME: This chapter needs to be reviewed so that it matches reality. -A more up-to-date description of the mechanisms described in this -section is given in @ref{Instruction Set}. - -A program may have access to local variables, external variables, and -top-level variables. - -@section Local/external variables - -A stack is logically divided into several blocks during execution. A -"block" is such a unit that maintains local variables and dynamic chain. -A "frame" is an upper level unit that maintains subprogram calls. - -@example - Stack - dynamic | | | | - chain +==========+ - = - | |local vars| | | - `-|block data| | block | - /|frame data| | | - | +----------+ - | - | |local vars| | | frame - `-|block data| | | - /+----------+ - | - | |local vars| | | - `-|block data| | | - /+==========+ - = - | |local vars| | | - `-|block data| | | - /|frame data| | | - | +----------+ - | - | | | | | -@end example - -The first block of each frame may look like this: - -@example - Address Data - ------- ---- - xxx0028 Local variable 2 - xxx0024 Local variable 1 - bp ->xxx0020 Local variable 0 - xxx001c Local link (block data) - xxx0018 External link (block data) - xxx0014 Stack pointer (block data) - xxx0010 Return address (frame data) - xxx000c Parent program (frame data) -@end example - -The base pointer (bp) always points to the lowest address of local -variables of the recent block. Local variables are referred as "bp[n]". -The local link field has a pointer to the dynamic parent of the block. -The parent's variables are referred as "bp[-1][n]", and grandparent's -are "bp[-1][-1][n]". Thus, any local variable is represented by its -depth and offset from the current bp. - -A variable may be "external", which is allocated in the shared memory. -The external link field of a block has a pointer to such a variable set, -which I call "fragment" (what should I call?). A fragment has a set of -variables and its own chain. - -@example - local external - chain| | chain - | +-----+ .--------, | - `-|block|--+->|external|-' - /+-----+ | `--------'\, - `-|block|--' | - /+-----+ .--------, | - `-|block|---->|external|-' - +-----+ `--------' - | | -@end example - -An external variable is referred as "bp[-2]->variables[n]" or -"bp[-2]->link->...->variables[n]". This is also represented by a pair -of depth and offset. At any point of execution, the value of bp -determines the current local link and external link, and thus the -current environment of a program. - -Other data fields are described later. - -@section Top-level variables - -Guile VM uses the same top-level variables as the regular Guile. A -program may have direct access to vcells. Currently this is done by -calling scm_intern0, but a program is possible to have any top-level -environment defined by the current module. - -@section Scheme and VM variable - -Let's think about the following Scheme code as an example: - -@example - (define (foo a) - (lambda (b) (list foo a b))) -@end example - -In the lambda expression, "foo" is a top-level variable, "a" is an -external variable, and "b" is a local variable. - -When a VM executes foo, it allocates a block for "a". Since "a" may be -externally referred from the closure, the VM creates a fragment with a -copy of "a" in it. When the VM evaluates the lambda expression, it -creates a subprogram (closure), associating the fragment with the -subprogram as its external environment. When the closure is executed, -its environment will look like this: - -@example - block Top-level: foo - +-------------+ - |local var: b | fragment - +-------------+ .-----------, - |external link|---->|variable: a| - +-------------+ `-----------' -@end example - -The fragment remains as long as the closure exists. - -@section Addressing mode - -Guile VM has five addressing modes: - -@itemize -@item Real address -@item Local position -@item External position -@item Top-level location -@item Constant object -@end itemize - -Real address points to the address in the real program and is only used -with the program counter (pc). - -Local position and external position are represented as a pair of depth -and offset from bp, as described above. These are base relative -addresses, and the real address may vary during execution. - -Top-level location is represented as a Guile's vcell. This location is -determined at loading time, so the use of this address is efficient. - -Constant object is not an address but gives an instruction an Scheme -object directly. - -[ We'll also need dynamic scope addressing to support Emacs Lisp? ] - - -Overall procedure: - -@enumerate -@item A source program is compiled into a bytecode. -@item A bytecode is given an environment and becomes a program. -@item A VM starts execution, creating a frame for it. -@item Whenever a program calls a subprogram, a new frame is created for it. -@item When a program finishes execution, it returns a value, and the VM - continues execution of the parent program. -@item When all programs terminated, the VM returns the final value and stops. -@end enumerate - - -@node Instruction Set, The Compiler, Variable Management, Top -@chapter Instruction Set - -The Guile VM instruction set is roughly divided two groups: system -instructions and functional instructions. System instructions control -the execution of programs, while functional instructions provide many -useful calculations. - -@menu -* Environment Control Instructions:: -* Branch Instructions:: -* Subprogram Control Instructions:: -* Data Control Instructions:: -@end menu - -@node Environment Control Instructions, Branch Instructions, Instruction Set, Instruction Set -@section Environment Control Instructions - -@deffn @insn{} link binding-name -Look up @var{binding-name} (a string) in the current environment and -push the corresponding variable object onto the stack. If -@var{binding-name} is not bound yet, then create a new binding and -push its variable object. -@end deffn - -@deffn @insn{} variable-ref -Dereference the variable object which is on top of the stack and -replace it by the value of the variable it represents. -@end deffn - -@deffn @insn{} variable-set -Set the value of the variable on top of the stack (at @code{sp[0]}) to -the object located immediately before (at @code{sp[-1]}). -@end deffn - -As an example, let us look at what a simple function call looks like: - -@example -(+ 2 3) -@end example - -This call yields the following sequence of instructions: - -@example -(link "+") ;; lookup binding "+" -(variable-ref) ;; dereference it -(make-int8 2) ;; push immediate value `2' -(make-int8 3) ;; push immediate value `3' -(tail-call 2) ;; call the proc at sp[-3] with two args -@end example - -@deffn @insn{} local-ref offset -Push onto the stack the value of the local variable located at -@var{offset} within the current stack frame. -@end deffn - -@deffn @insn{} local-set offset -Pop the Scheme object located on top of the stack and make it the new -value of the local variable located at @var{offset} within the current -stack frame. -@end deffn - -@deffn @insn{} external-ref offset -Push the value of the closure variable located at position -@var{offset} within the program's list of external variables. -@end deffn - -@deffn @insn{} external-set offset -Pop the Scheme object located on top of the stack and make it the new -value of the closure variable located at @var{offset} within the -program's list of external variables. -@end deffn - -@deffn @insn{} make-closure -Pop the program object from the stack and assign it the current -closure variable list as its closure. Push the result program -object. -@end deffn - -Let's illustrate this: - -@example -(let ((x 2)) - (lambda () - (let ((x++ (+ 1 x))) - (set! x x++) - x++))) -@end example - -The resulting program has one external (closure) variable, i.e. its -@var{nexts} is set to 1 (@pxref{Subprogram Control Instructions}). -This yields the following code: - -@example - ;; the traditional program prologue with NLOCS = 0 and NEXTS = 1 - - 0 (make-int8 2) - 2 (external-set 0) - 4 (make-int8 4) - 6 (link "+") ;; lookup `+' - 9 (vector 1) ;; create the external variable vector for - ;; later use by `object-ref' and `object-set' - ... - 40 (load-program ##34#) - 59 (make-closure) ;; assign the current closure to the program - ;; just pushed by `load-program' - 60 (return) -@end example - -The program loaded here by @var{load-program} contains the following -sequence of instructions: - -@example - 0 (object-ref 0) ;; push the variable for `+' - 2 (variable-ref) ;; dereference `+' - 3 (make-int8:1) ;; push 1 - 4 (external-ref 0) ;; push the value of `x' - 6 (call 2) ;; call `+' and push the result - 8 (local-set 0) ;; make it the new value of `x++' - 10 (local-ref 0) ;; push the value of `x++' - 12 (external-set 0) ;; make it the new value of `x' - 14 (local-ref 0) ;; push the value of `x++' - 16 (return) ;; return it -@end example - -At this point, you should know pretty much everything about the three -types of variables a program may need to access. - - -@node Branch Instructions, Subprogram Control Instructions, Environment Control Instructions, Instruction Set -@section Branch Instructions - -All the conditional branch instructions described below work in the -same way: - -@itemize -@item They take the Scheme object located on the stack and use it as -the branch condition; -@item If the condition if false, then program execution continues with -the next instruction; -@item If the condition is true, then the instruction pointer is -increased by the offset passed as an argument to the branch -instruction; -@item Finally, when the instruction finished, the condition object is -removed from the stack. -@end itemize - -Note that the offset passed to the instruction is encoded on two 8-bit -integers which are then combined by the VM as one 16-bit integer. - -@deffn @insn{} br offset -Jump to @var{offset}. -@end deffn - -@deffn @insn{} br-if offset -Jump to @var{offset} if the condition on the stack is not false. -@end deffn - -@deffn @insn{} br-if-not offset -Jump to @var{offset} if the condition on the stack is false. -@end deffn - -@deffn @insn{} br-if-eq offset -Jump to @var{offset} if the two objects located on the stack are -equal in the sense of @var{eq?}. Note that, for this instruction, the -stack pointer is decremented by two Scheme objects instead of only -one. -@end deffn - -@deffn @insn{} br-if-not-eq offset -Same as @var{br-if-eq} for non-equal objects. -@end deffn - -@deffn @insn{} br-if-null offset -Jump to @var{offset} if the object on the stack is @code{'()}. -@end deffn - -@deffn @insn{} br-if-not-null offset -Jump to @var{offset} if the object on the stack is not @code{'()}. -@end deffn - - -@node Subprogram Control Instructions, Data Control Instructions, Branch Instructions, Instruction Set -@section Subprogram Control Instructions - -Programs (read: ``compiled procedure'') may refer to external -bindings, like variables or functions defined outside the program -itself, in the environment in which it will evaluate at run-time. In -a sense, a program's environment and its bindings are an implicit -parameter of every program. - -@cindex object table -In order to handle such bindings, each program has an @dfn{object -table} associated to it. This table (actually a Scheme vector) -contains all constant objects referenced by the program. The object -table of a program is initialized right before a program is loaded -with @var{load-program}. - -Variable objects are one such type of constant object: when a global -binding is defined, a variable object is associated to it and that -object will remain constant over time, even if the value bound to it -changes. Therefore, external bindings only need to be looked up once -when the program is loaded. References to the corresponding external -variables from within the program are then performed via the -@var{object-ref} instruction and are almost as fast as local variable -references. - -Let us consider the following program (procedure) which references -external bindings @code{frob} and @var{%magic}: - -@example -(lambda (x) - (frob x %magic)) -@end example - -This yields the following assembly code: - -@example -(make-int8 64) ;; number of args, vars, etc. (see below) -(link "frob") -(link "%magic") -(vector 2) ;; object table (external bindings) -... -(load-program #u8(20 0 23 21 0 20 1 23 36 2)) -(return) -@end example - -All the instructions occurring before @var{load-program} (some were -omitted for simplicity) form a @dfn{prologue} which, among other -things, pushed an object table (a vector) that contains the variable -objects for the variables bound to @var{frob} and @var{%magic}. This -vector and other data pushed onto the stack are then popped by the -@var{load-program} instruction. - -Besides, the @var{load-program} instruction takes one explicit -argument which is the bytecode of the program itself. Disassembled, -this bytecode looks like: - -@example -(object-ref 0) ;; push the variable object of `frob' -(variable-ref) ;; dereference it -(local-ref 0) ;; push the value of `x' -(object-ref 1) ;; push the variable object of `%magic' -(variable-ref) ;; dereference it -(tail-call 2) ;; call `frob' with two parameters -@end example - -This clearly shows that there is little difference between references -to local variables and references to externally bound variables since -lookup of externally bound variables if performed only once before the -program is run. - -@deffn @insn{} load-program bytecode -Load the program whose bytecode is @var{bytecode} (a u8vector), pop -its meta-information from the stack, and push a corresponding program -object onto the stack. The program's meta-information may consist of -(in the order in which it should be pushed onto the stack): - -@itemize -@item optionally, a pair representing meta-data (see the -@var{program-meta} procedure); [FIXME: explain their meaning] -@item optionally, a vector which is the program's object table (a -program that does not reference external bindings does not need an -object table); -@item either one immediate integer or four immediate integers -representing respectively the number of arguments taken by the -function (@var{nargs}), the number of @dfn{rest arguments} -(@var{nrest}, 0 or 1), the number of local variables (@var{nlocs}) and -the number of external variables (@var{nexts}) (@pxref{Environment -Control Instructions}). -@end itemize - -@end deffn - -@deffn @insn{} object-ref offset -Push the variable object for the external variable located at -@var{offset} within the program's object table. -@end deffn - -@deffn @insn{} return -Free the program's frame. -@end deffn - -@deffn @insn{} call nargs -Call the procedure, continuation or program located at -@code{sp[-nargs]} with the @var{nargs} arguments located from -@code{sp[0]} to @code{sp[-nargs + 1]}. The -procedure/continuation/program and its arguments are dropped from the -stack and the result is pushed. When calling a program, the -@code{call} instruction reserves room for its local variables on the -stack, and initializes its list of closure variables and its vector of -externally bound variables. -@end deffn - -@deffn @insn{} tail-call nargs -Same as @code{call} except that, for tail-recursive calls to a -program, the current stack frame is re-used, as required by RnRS. -This instruction is otherwise similar to @code{call}. -@end deffn - - -@node Data Control Instructions, , Subprogram Control Instructions, Instruction Set -@section Data Control Instructions - -@deffn @insn{} make-int8 value -Push @var{value}, an 8-bit integer, onto the stack. -@end deffn - -@deffn @insn{} make-int8:0 -Push the immediate value @code{0} onto the stack. -@end deffn - -@deffn @insn{} make-int8:1 -Push the immediate value @code{1} onto the stack. -@end deffn - -@deffn @insn{} make-false -Push @code{#f} onto the stack. -@end deffn - -@deffn @insn{} make-true -Push @code{#t} onto the stack. -@end deffn - -@itemize -@item %push -@item %pushi -@item %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3 -@item %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3 -@item %pusht -@end itemize - -@itemize -@item %loadi -@item %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3 -@item %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3 -@item %loadt -@end itemize - -@itemize -@item %savei -@item %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3 -@item %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3 -@item %savet -@end itemize - -@section Flow control instructions - -@itemize -@item %br-if -@item %br-if-not -@item %jump -@end itemize - -@section Function call instructions - -@itemize -@item %func, %func0, %func1, %func2 -@end itemize - -@section Scheme built-in functions - -@itemize -@item cons -@item car -@item cdr -@end itemize - -@section Mathematical buitin functions - -@itemize -@item 1+ -@item 1- -@item add, add2 -@item sub, sub2, minus -@item mul2 -@item div2 -@item lt2 -@item gt2 -@item le2 -@item ge2 -@item num-eq2 -@end itemize - - - -@node The Compiler, Concept Index, Instruction Set, Top -@chapter The Compiler - -This section describes Guile-VM's compiler and the compilation process -to produce bytecode executable by the VM itself (@pxref{Instruction -Set}). - -@menu -* Overview:: -* The Language Front-Ends:: -* GHIL:: -* Compiling Scheme Code:: -* GLIL:: -* The Assembler:: -@end menu - -@node Overview, The Language Front-Ends, The Compiler, The Compiler -@section Overview - -Compilation in Guile-VM is a three-stage process: - -@cindex intermediate language -@cindex assembler -@cindex compiler -@cindex GHIL -@cindex GLIL -@cindex bytecode - -@enumerate -@item the source programming language (e.g. R5RS Scheme) is read and -translated into GHIL, @dfn{Guile's High-Level Intermediate Language}; -@item GHIL code is then translated into a lower-level intermediate -language call GLIL, @dfn{Guile's Low-Level Intermediate Language}; -@item finally, GLIL is @dfn{assembled} into the VM's assembly language -(@pxref{Instruction Set}) and bytecode. -@end enumerate - -The use of two separate intermediate languages eases the -implementation of front-ends since the gap between high-level -languages like Scheme and GHIL is relatively small. - -@vindex guilec -From an end-user viewpoint, compiling a Guile program into bytecode -can be done either by using the @command{guilec} command-line tool, or -by using the @code{compile-file} procedure exported by the -@code{(system base compile)} module. - -@deffn @scmproc{} compile-file file . opts -Compile Scheme source code from file @var{file} using compilation -options @var{opts}. The resulting file, a Guile object file, will be -name according the application of the @code{compiled-file-name} -procedure to @var{file}. The possible values for @var{opts} are the -same as for the @code{compile-in} procedure (see below, @pxref{The Language -Front-Ends}). -@end deffn - -@deffn @scmproc{} compiled-file-name file -Given source file name @var{file} (a string), return a string that -denotes the name of the Guile object file corresponding to -@var{file}. By default, the file name returned is @var{file} minus -its extension and plus the @code{.go} file extension. -@end deffn - -@cindex self-hosting -It is worth noting, as you might have already guessed, that Guile-VM's -compiler is written in Guile Scheme and is @dfn{self-hosted}: it can -compile itself. - -@node The Language Front-Ends, GHIL, Overview, The Compiler -@section The Language Front-Ends - -Guile-VM comes with a number of @dfn{language front-ends}, that is, -code that can read a given high-level programming language like R5RS -Scheme, and translate it into a lower-level representation suitable to -the compiler. - -Each language front-end provides a @dfn{specification} and a -@dfn{translator} to GHIL. Both of them come in the @code{language} -module hierarchy. As an example, the front-end for Scheme is located -in the @code{(language scheme spec)} and @code{(language scheme -translate)} modules. Language front-ends can then be retrieved using -the @code{lookup-language} procedure of the @code{(system base -language)} module. - -@deftp @scmrec{} name title version reader printer read-file expander translator evaluator environment -Denotes a language front-end specification a various methods used by -the compiler to handle source written in that language. Of particular -interest is the @code{translator} slot (@pxref{GHIL}). -@end deftp - -@deffn @scmproc{} lookup-language lang -Look for a language front-end named @var{lang}, a symbol (e.g, -@code{scheme}), and return the @code{} record describing it -if found. If @var{lang} does not denote a language front-end, an -error is raised. Note that this procedure assumes that language -@var{lang} exists if there exist a @code{(language @var{lang} spec)} -module. -@end deffn - -The @code{(system base compile)} module defines a procedure similar to -@code{compile-file} but that is not limited to the Scheme language: - -@deffn @scmproc{} compile-in expr env lang . opts -Compile expression @var{expr}, which is written in language @var{lang} -(a @code{} object), using compilation options @var{opts}, -and return bytecode as produced by the assembler (@pxref{The -Assembler}). - -Options @var{opts} may contain the following keywords: - -@table @code -@item :e -compilation will stop after the code expansion phase. -@item :t -compilation will stop after the code translation phase, i.e. after -code in the source language @var{lang} has been translated into GHIL -(@pxref{GHIL}). -@item :c -compilation will stop after the compilation phase and before the -assembly phase, i.e. once GHIL has been translated into GLIL -(@pxref{GLIL}). -@end table - -Additionally, @var{opts} may contain any option understood by the -GHIL-to-GLIL compiler described in @xref{GLIL}. -@end deffn - - -@node GHIL, Compiling Scheme Code, The Language Front-Ends, The Compiler -@section Guile's High-Level Intermediate Language - -GHIL has constructs almost equivalent to those found in Scheme. -However, unlike Scheme, it is meant to be read only by the compiler -itself. Therefore, a sequence of GHIL code is only a sequence of GHIL -@emph{objects} (records), as opposed to symbols, each of which -represents a particular language feature. These records are all -defined in the @code{(system il ghil)} module and are named -@code{}. - -Each GHIL record has at least two fields: one containing the -environment (Guile module) in which it is considered, and one -containing its location [FIXME: currently seems to be unused]. Below -is a list of the main GHIL object types and their fields: - -@example -;; Objects -( env loc) -( env loc obj) -( env loc exp) -( env loc exp) -( env loc exp) -;; Variables -( env loc var) -( env loc var val) -( env loc var val) -;; Controls -( env loc test then else) -( env loc exps) -( env loc exps) -( env loc exps) -( env loc vars vals body) -( env loc vars rest body) -( env loc proc args) -( env loc inline args) -@end example - -As can be seen from this examples, the constructs in GHIL are pretty -close to the fundamental primitives of Scheme. - -It is the role of front-end language translators (@pxref{The Language -Front-Ends}) to produce a sequence of GHIL objects from the -human-readable, source programming language. The next section -describes the translator for the Scheme language. - -@node Compiling Scheme Code, GLIL, GHIL, The Compiler -@section Compiling Scheme Code - -The language object for Scheme, as returned by @code{(lookup-language -'scheme)} (@pxref{The Language Front-Ends}), defines a translator -procedure that returns a sequence of GHIL objects given Scheme code. -Before actually performing this operation, the Scheme translator -expands macros in the original source code. - -The macros that may be expanded can come from different sources: - -@itemize -@item core Guile macros, such as @code{false-if-exception}; -@item macros defined in modules used by the module being compiled, -e.g., @code{receive} in @code{(ice-9 receive)}; -@item macros defined within the module being compiled. -@end itemize - -@cindex macro -@cindex syntax transformer -@findex define-macro -@findex defmacro -The main complexity in handling macros at compilation time is that -Guile's macros are first-class objects. For instance, when using -@code{define-macro}, one actually defines a @emph{procedure} that -returns code; of course, unlike a ``regular'' procedure, it is -executed when an S-exp is @dfn{memoized} by the evaluator, i.e., -before the actual evaluation takes place. Worse, it is possible to -turn a procedure into a macro, or @dfn{syntax transformer}, thus -removing, to some extent, the boundary between the macro expansion and -evaluation phases, @inforef{Internal Macros, , guile}. - -[FIXME: explain limitations, etc.] - - -@node GLIL, The Assembler, Compiling Scheme Code, The Compiler -@section Guile's Low-Level Intermediate Language - -A GHIL instruction sequence can be compiled into GLIL using the -@code{compile} procedure exported by the @code{(system il compile)} -module. During this translation process, various optimizations may -also be performed. - -The module @code{(system il glil)} defines record types representing -various low-level abstractions. Compared to GHIL, the flow control -primitives in GLIL are much more low-level: only @code{}, -@code{} and @code{} are available, no -@code{lambda}, @code{if}, etc. - - -@deffn @scmproc{} compile ghil environment . opts -Compile @var{ghil}, a GHIL instruction sequence, within -environment/module @var{environment}, and return the resulting GLIL -instruction sequence. The option list @var{opts} may be either the -empty list or a list containing the @code{:O} keyword in which case -@code{compile} will first go through an optimization stage of -@var{ghil}. - -Note that the @code{:O} option may be passed at a higher-level to the -@code{compile-file} and @code{compile-in} procedures (@pxref{The -Language Front-Ends}). -@end deffn - -@deffn @scmproc{} pprint-glil glil . port -Print @var{glil}, a GLIL sequence instructions, in a human-readable -form. If @var{port} is passed, it will be used as the output port. -@end deffn - - -Let's consider the following Scheme expression: - -@example -(lambda (x) (+ x 1)) -@end example - -The corresponding (unoptimized) GLIL code, as shown by -@code{pprint-glil}, looks like this: - -@example -(@@asm (0 0 0 0) - (@@asm (1 0 0 0) ;; expect one arg. - (@@bind (x argument 0)) ;; debugging info - (module-ref #f +) ;; lookup `+' - (argument-ref 0) ;; push the argument onto - ;; the stack - (const 1) ;; push `1' - (tail-call 2) ;; call `+', with 2 args, - ;; using the same stack frame - (@@source 15 33)) ;; additional debugging info - (return 0)) -@end example - -This is not unlike the VM's assembly language described in -@ref{Instruction Set}. - -@node The Assembler, , GLIL, The Compiler -@section The Assembler - -@findex code->bytes - -The final compilation step consists in converting the GLIL instruction -sequence into VM bytecode. This is what the @code{assemble} procedure -defined in the @code{(system vm assemble)} module is for. It relies -on the @code{code->bytes} procedure of the @code{(system vm conv)} -module to convert instructions (represented as lists whose @code{car} -is a symbol naming the instruction, e.g. @code{object-ref}, -@pxref{Instruction Set}) into binary code, or @dfn{bytecode}. -Bytecode itself is represented using SRFI-4 byte vectors, -@inforef{SRFI-4, SRFI-4 homogeneous numeric vectors, guile}. - - -@deffn @scmproc{} assemble glil environment . opts -Return a binary representation of @var{glil} (bytecode), either in the -form of an SRFI-4 @code{u8vector} or a @code{} object. -[FIXME: Why is that?] -@end deffn - - - -@c ********************************************************************* -@node Concept Index, Function and Instruction Index, The Compiler, Top -@unnumbered Concept Index -@printindex cp - -@node Function and Instruction Index, Command and Variable Index, Concept Index, Top -@unnumbered Function and Instruction Index -@printindex fn - -@node Command and Variable Index, , Function and Instruction Index, Top -@unnumbered Command and Variable Index -@printindex vr - -@bye - -@c Local Variables: -@c ispell-local-dictionary: "american"; -@c End: - -@c LocalWords: bytecode From 6370a6ad25ab0bc47e2f165937db8c7955b2b595 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Sat, 23 May 2009 09:58:54 +0200 Subject: [PATCH 246/375] basic brainfuck -> scheme example compiler. * module/Makefile.am: Install the brainfuck compiler modules. * module/language/brainfuck/spec.scm: New file. * module/language/brainfuck/parse.scm: New file. * module/language/brainfuck/compile-scheme.scm: New file. --- module/Makefile.am | 6 ++ module/language/brainfuck/compile-scheme.scm | 71 ++++++++++++++++++++ module/language/brainfuck/parse.scm | 55 +++++++++++++++ module/language/brainfuck/spec.scm | 34 ++++++++++ 4 files changed, 166 insertions(+) create mode 100644 module/language/brainfuck/compile-scheme.scm create mode 100644 module/language/brainfuck/parse.scm create mode 100644 module/language/brainfuck/spec.scm diff --git a/module/Makefile.am b/module/Makefile.am index 2df0232fb..10ff5eaa1 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -41,6 +41,7 @@ SOURCES = \ $(SCHEME_LANG_SOURCES) \ $(TREE_IL_LANG_SOURCES) \ $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ + $(BRAINFUCK_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ \ @@ -112,6 +113,11 @@ ECMASCRIPT_LANG_SOURCES = \ language/ecmascript/compile-ghil.scm \ language/ecmascript/spec.scm +BRAINFUCK_LANG_SOURCES = \ + language/brainfuck/spec.scm \ + language/brainfuck/parse.scm \ + language/brainfuck/compile-scheme.scm + SCRIPTS_SOURCES = \ scripts/PROGRAM.scm \ scripts/autofrisk.scm \ diff --git a/module/language/brainfuck/compile-scheme.scm b/module/language/brainfuck/compile-scheme.scm new file mode 100644 index 000000000..1b37076ff --- /dev/null +++ b/module/language/brainfuck/compile-scheme.scm @@ -0,0 +1,71 @@ +;;; Brainfuck for GNU Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language brainfuck compile-scheme) + #:export (compile-scheme)) + +(define tape-size 30000) + +(define (compile-scheme exp env opts) + (values + `(let ((pointer 0) + (tape (make-vector ,tape-size 0))) + ,@(if (not (eq? ' (car exp))) + (error "expected brainfuck program") + `(begin + ,@(compile-body (cdr exp)) + (write-char #\newline)))) + env + env)) + +(define (compile-body instructions) + (let iterate ((cur instructions) + (result '())) + (if (null? cur) + (reverse result) + (let ((compiled (compile-instruction (car cur)))) + (iterate (cdr cur) (cons compiled result)))))) + +(define (compile-instruction ins) + (case (car ins) + + (() + (let ((dir (cadr ins))) + `(set! pointer (+ pointer ,dir)))) + + (() + (let ((inc (cadr ins))) + `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc)))) + + (() + '(write-char (integer->char (vector-ref tape pointer)))) + + (() + '(vector-set! tape pointer (char->integer (read-char)))) + + (() + `(let iter () + (if (not (= (vector-ref tape pointer) 0)) + (begin + ,@(compile-body (cdr ins)) + (iter))))) + + (else (error "unknown brainfuck instruction " (car ins))))) diff --git a/module/language/brainfuck/parse.scm b/module/language/brainfuck/parse.scm new file mode 100644 index 000000000..e272b61ac --- /dev/null +++ b/module/language/brainfuck/parse.scm @@ -0,0 +1,55 @@ +;;; Brainfuck for GNU Guile. + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language brainfuck parse) + #:export (read-brainfuck)) + +(define (read-brainfuck p) + `( ,@(read-body p))) + +(define (reverse-without-nops lst) + (let iterate ((cur lst) + (result '())) + (if (null? cur) + result + (let ((head (car cur)) + (tail (cdr cur))) + (if (eq? (car head) ') + (iterate tail result) + (iterate tail (cons head result))))))) + +(define (read-body p) + (let iterate ((parsed '())) + (let ((chr (read-char p))) + (if (or (eof-object? chr) (eq? #\] chr)) + (reverse-without-nops parsed) + (iterate (cons (process-input-char chr p) parsed)))))) + +(define (process-input-char chr p) + (case chr + ((#\>) '( 1)) + ((#\<) '( -1)) + ((#\+) '( 1)) + ((#\-) '( -1)) + ((#\.) '()) + ((#\,) '()) + ((#\[) `( ,@(read-body p))) + (else '()))) diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm new file mode 100644 index 000000000..9df1df699 --- /dev/null +++ b/module/language/brainfuck/spec.scm @@ -0,0 +1,34 @@ +;;; Brainfuck for GNU Guile. + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language brainfuck spec) + #:use-module (language brainfuck compile-scheme) + #:use-module (language brainfuck parse) + #:use-module (system base language) + #:export (brainfuck)) + +(define-language brainfuck + #:title "Guile Brainfuck" + #:version "1.0" + #:reader (lambda () (read-brainfuck (current-input-port))) + #:compilers `((scheme . ,compile-scheme)) + #:printer write + ) From e63d888ef64c9c96177d841fa9a1ee4e697db81d Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Sat, 23 May 2009 09:58:54 +0200 Subject: [PATCH 247/375] added documenting comments to the brainfuck compiler and mention it in the VM documentation. * doc/ref/compiler.texi: Mention the new brainfuck compiler as an example. * module/language/brainfuck/compile-scheme.scm: Add a lot of documentation comments. * module/language/brainfuck/parse.scm: Ditto. * module/language/brainfuck/spec.scm: Ditto. --- doc/ref/compiler.texi | 14 ++++- module/language/brainfuck/compile-scheme.scm | 60 +++++++++++++++++++- module/language/brainfuck/parse.scm | 43 ++++++++++++++ module/language/brainfuck/spec.scm | 12 +++- 4 files changed, 124 insertions(+), 5 deletions(-) diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 0d68abfc6..06262b95a 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2008 +@c Copyright (C) 2008, 2009 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -26,6 +26,7 @@ know how to compile your .scm file. * GLIL:: * Assembly:: * Bytecode and Objcode:: +* Writing New High-Level Languages:: * Extending the Compiler:: @end menu @@ -712,6 +713,17 @@ module, and @var{externals} should be a list of external variables. @code{#f} is also a valid object code environment. @end deffn +@node Writing New High-Level Languages +@subsection Writing New High-Level Languages + +In order to integrate a new language @var{lang} into Guile's compiler +system, one has to create the module @code{(language @var{lang} spec)} +containing the language definition and referencing the parser, +compiler and other routines processing it. The module hierarchy in +@code{(language brainfuck)} defines a very basic Brainfuck +implementation meant to serve as easy-to-understand example on how to +do this. + @node Extending the Compiler @subsection Extending the Compiler diff --git a/module/language/brainfuck/compile-scheme.scm b/module/language/brainfuck/compile-scheme.scm index 1b37076ff..97c32d0b7 100644 --- a/module/language/brainfuck/compile-scheme.scm +++ b/module/language/brainfuck/compile-scheme.scm @@ -22,8 +22,36 @@ (define-module (language brainfuck compile-scheme) #:export (compile-scheme)) +; Compilation of Brainfuck to Scheme is pretty straight-forward. For all of +; brainfuck's instructions, there are basic representations in Scheme we +; only have to generate. +; +; Brainfuck's pointer and data-tape are stored in the variables pointer and +; tape, where tape is a vector of integer values initially set to zero. Pointer +; starts out at position 0. +; Our tape is thus of finite length, with an address range of 0..n for +; some defined upper bound n depending on the length of our tape. + + +; Define the length to use for the tape. + (define tape-size 30000) + +; This compiles a whole brainfuck program. This constructs a Scheme code like: +; (let ((pointer 0) +; (tape (make-vector tape-size 0))) +; (begin +; +; (write-char #\newline))) +; +; So first the pointer and tape variables are set up correctly, then the +; program's body is executed in this context, and finally we output an +; additional newline character in case the program does not output one. +; +; TODO: Find out and explain the details about env, the three return values and +; how to use the options. Implement options to set the tape-size, maybe. + (define (compile-scheme exp env opts) (values `(let ((pointer 0) @@ -36,6 +64,12 @@ env env)) + +; Compile a list of instructions to get a list of Scheme codes. As we always +; strip off the car of the instructions-list and cons the result onto the +; result-list, it will get out in reversed order first; so we have to (reverse) +; it on return. + (define (compile-body instructions) (let iterate ((cur instructions) (result '())) @@ -44,28 +78,50 @@ (let ((compiled (compile-instruction (car cur)))) (iterate (cdr cur) (cons compiled result)))))) + +; Compile a single instruction to Scheme, using the direct representations +; all of Brainfuck's instructions have. + (define (compile-instruction ins) (case (car ins) + ; Pointer moval >< is done simply by something like: + ; (set! pointer (+ pointer +-1)) (() (let ((dir (cadr ins))) `(set! pointer (+ pointer ,dir)))) + ; Cell increment +- is done as: + ; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1)) (() (let ((inc (cadr ins))) `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc)))) + ; Output . is done by converting the cell's integer value to a character + ; first and then printing out this character: + ; (write-char (integer->char (vector-ref tape pointer))) (() '(write-char (integer->char (vector-ref tape pointer)))) + ; Input , is done similarly, read in a character, get its ASCII code and + ; store it into the current cell: + ; (vector-set! tape pointer (char->integer (read-char))) (() '(vector-set! tape pointer (char->integer (read-char)))) + ; For loops [...] we use a named let construction to execute the body until + ; the current cell gets zero. The body is compiled via a recursive call + ; back to (compile-body). + ; (let iterate () + ; (if (not (= (vector-ref! tape pointer) 0)) + ; (begin + ; + ; (iterate)))) (() - `(let iter () + `(let iterate () (if (not (= (vector-ref tape pointer) 0)) (begin ,@(compile-body (cdr ins)) - (iter))))) + (iterate))))) (else (error "unknown brainfuck instruction " (car ins))))) diff --git a/module/language/brainfuck/parse.scm b/module/language/brainfuck/parse.scm index e272b61ac..54dbaeecc 100644 --- a/module/language/brainfuck/parse.scm +++ b/module/language/brainfuck/parse.scm @@ -22,9 +22,34 @@ (define-module (language brainfuck parse) #:export (read-brainfuck)) +; Purpose of the parse module is to read in brainfuck in text form and produce +; the corresponding tree representing the brainfuck code. +; +; Each object (representing basically a single instruction) is structured like: +; ( [arguments]) +; where is a symbolic name representing the type of instruction +; and the optional arguments represent further data (for instance, the body of +; a [...] loop as a number of nested instructions). +; +; A full brainfuck program is represented by the ( instructions) +; object. + + +; Read a brainfuck program from an input port. We construct the +; program and read in the instructions using (read-body). + (define (read-brainfuck p) `( ,@(read-body p))) + +; While reading a number of instructions in sequence, all of them are cons'ed +; onto a list of instructions; thus this list gets out in reverse order. +; Additionally, for "comment characters" (everything not an instruction) we +; generate NOP instructions. +; +; This routine reverses a list of instructions and removes all 's on the +; way to fix these two issues for a read-in list. + (define (reverse-without-nops lst) (let iterate ((cur lst) (result '())) @@ -36,6 +61,15 @@ (iterate tail result) (iterate tail (cons head result))))))) + +; Read in a set of instructions until a terminating ] character is found (or +; end of file is reached). This is used both for loop bodies and whole +; programs, so that a program has to be either terminated by EOF or an +; additional ], too. +; +; For instance, the basic program so just echo one character would be: +; ,.] + (define (read-body p) (let iterate ((parsed '())) (let ((chr (read-char p))) @@ -43,6 +77,15 @@ (reverse-without-nops parsed) (iterate (cons (process-input-char chr p) parsed)))))) + +; This routine processes a single character of input and builds the +; corresponding instruction. Loop bodies are read by recursively calling +; back (read-body). +; +; For the poiner movement commands >< and the cell increment/decrement +- +; commands, we only use one instruction form each and specify the direction of +; the pointer/value increment using an argument to the instruction form. + (define (process-input-char chr p) (case chr ((#\>) '( 1)) diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm index 9df1df699..a303984b2 100644 --- a/module/language/brainfuck/spec.scm +++ b/module/language/brainfuck/spec.scm @@ -25,10 +25,18 @@ #:use-module (system base language) #:export (brainfuck)) + +; The new language is integrated into Guile via this (define-language) +; specification in the special module (language [lang] spec). +; Provided is a parser-routine in #:reader, a output routine in #:printer +; and one or more compiler routines (as target-language - routine pairs) +; in #:compilers. This is the basic set of fields needed to specify a new +; language. + (define-language brainfuck #:title "Guile Brainfuck" #:version "1.0" #:reader (lambda () (read-brainfuck (current-input-port))) - #:compilers `((scheme . ,compile-scheme)) - #:printer write + #:compilers `((scheme . ,compile-scheme)) + #:printer write ) From 4e432dab1f02f5d497a352c1ea9392fc6db0f1f2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 21 Jun 2009 13:10:56 +0200 Subject: [PATCH 248/375] link to brainfuck wikipedia page * doc/ref/compiler.texi: Point to more info on Brainfuck. Patch by Daniel Kraft. --- doc/ref/compiler.texi | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 06262b95a..f8d0895d9 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -722,7 +722,9 @@ containing the language definition and referencing the parser, compiler and other routines processing it. The module hierarchy in @code{(language brainfuck)} defines a very basic Brainfuck implementation meant to serve as easy-to-understand example on how to -do this. +do this. See for instance @url{http://en.wikipedia.org/wiki/Brainfuck} +for more information about the Brainfuck language itself. + @node Extending the Compiler @subsection Extending the Compiler From fe2400b2141fbde17eab517794773203fc19f952 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 21 Jun 2009 13:36:39 +0200 Subject: [PATCH 249/375] formatting changes to (language brainfuck compile-scheme) * module/language/brainfuck/compile-scheme.scm: Standalone comments should have more than one semicolon, and update copyright to LGPLv3+. --- module/language/brainfuck/compile-scheme.scm | 115 +++++++++---------- 1 file changed, 57 insertions(+), 58 deletions(-) diff --git a/module/language/brainfuck/compile-scheme.scm b/module/language/brainfuck/compile-scheme.scm index 97c32d0b7..86bc35fdd 100644 --- a/module/language/brainfuck/compile-scheme.scm +++ b/module/language/brainfuck/compile-scheme.scm @@ -2,55 +2,54 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, +;; This library 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. +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language brainfuck compile-scheme) #:export (compile-scheme)) -; Compilation of Brainfuck to Scheme is pretty straight-forward. For all of -; brainfuck's instructions, there are basic representations in Scheme we -; only have to generate. -; -; Brainfuck's pointer and data-tape are stored in the variables pointer and -; tape, where tape is a vector of integer values initially set to zero. Pointer -; starts out at position 0. -; Our tape is thus of finite length, with an address range of 0..n for -; some defined upper bound n depending on the length of our tape. +;; Compilation of Brainfuck to Scheme is pretty straight-forward. For all of +;; brainfuck's instructions, there are basic representations in Scheme we +;; only have to generate. +;; +;; Brainfuck's pointer and data-tape are stored in the variables pointer and +;; tape, where tape is a vector of integer values initially set to zero. Pointer +;; starts out at position 0. +;; Our tape is thus of finite length, with an address range of 0..n for +;; some defined upper bound n depending on the length of our tape. -; Define the length to use for the tape. +;; Define the length to use for the tape. (define tape-size 30000) -; This compiles a whole brainfuck program. This constructs a Scheme code like: -; (let ((pointer 0) -; (tape (make-vector tape-size 0))) -; (begin -; -; (write-char #\newline))) -; -; So first the pointer and tape variables are set up correctly, then the -; program's body is executed in this context, and finally we output an -; additional newline character in case the program does not output one. -; -; TODO: Find out and explain the details about env, the three return values and -; how to use the options. Implement options to set the tape-size, maybe. +;; This compiles a whole brainfuck program. This constructs a Scheme code like: +;; (let ((pointer 0) +;; (tape (make-vector tape-size 0))) +;; (begin +;; +;; (write-char #\newline))) +;; +;; So first the pointer and tape variables are set up correctly, then the +;; program's body is executed in this context, and finally we output an +;; additional newline character in case the program does not output one. +;; +;; TODO: Find out and explain the details about env, the three return values and +;; how to use the options. Implement options to set the tape-size, maybe. (define (compile-scheme exp env opts) (values @@ -65,10 +64,10 @@ env)) -; Compile a list of instructions to get a list of Scheme codes. As we always -; strip off the car of the instructions-list and cons the result onto the -; result-list, it will get out in reversed order first; so we have to (reverse) -; it on return. +;; Compile a list of instructions to get a list of Scheme codes. As we always +;; strip off the car of the instructions-list and cons the result onto the +;; result-list, it will get out in reversed order first; so we have to (reverse) +;; it on return. (define (compile-body instructions) (let iterate ((cur instructions) @@ -79,44 +78,44 @@ (iterate (cdr cur) (cons compiled result)))))) -; Compile a single instruction to Scheme, using the direct representations -; all of Brainfuck's instructions have. +;; Compile a single instruction to Scheme, using the direct representations +;; all of Brainfuck's instructions have. (define (compile-instruction ins) (case (car ins) - ; Pointer moval >< is done simply by something like: - ; (set! pointer (+ pointer +-1)) + ;; Pointer moval >< is done simply by something like: + ;; (set! pointer (+ pointer +-1)) (() (let ((dir (cadr ins))) `(set! pointer (+ pointer ,dir)))) - ; Cell increment +- is done as: - ; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1)) + ;; Cell increment +- is done as: + ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1)) (() (let ((inc (cadr ins))) `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc)))) - ; Output . is done by converting the cell's integer value to a character - ; first and then printing out this character: - ; (write-char (integer->char (vector-ref tape pointer))) + ;; Output . is done by converting the cell's integer value to a character + ;; first and then printing out this character: + ;; (write-char (integer->char (vector-ref tape pointer))) (() '(write-char (integer->char (vector-ref tape pointer)))) - ; Input , is done similarly, read in a character, get its ASCII code and - ; store it into the current cell: - ; (vector-set! tape pointer (char->integer (read-char))) + ;; Input , is done similarly, read in a character, get its ASCII code and + ;; store it into the current cell: + ;; (vector-set! tape pointer (char->integer (read-char))) (() '(vector-set! tape pointer (char->integer (read-char)))) - ; For loops [...] we use a named let construction to execute the body until - ; the current cell gets zero. The body is compiled via a recursive call - ; back to (compile-body). - ; (let iterate () - ; (if (not (= (vector-ref! tape pointer) 0)) - ; (begin - ; - ; (iterate)))) + ;; For loops [...] we use a named let construction to execute the body until + ;; the current cell gets zero. The body is compiled via a recursive call + ;; back to (compile-body). + ;; (let iterate () + ;; (if (not (= (vector-ref! tape pointer) 0)) + ;; (begin + ;; + ;; (iterate)))) (() `(let iterate () (if (not (= (vector-ref tape pointer) 0)) From 5c27902e5e01a94b22ebc51288500a3d36253293 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 21 Jun 2009 14:53:33 +0200 Subject: [PATCH 250/375] add brainfuck->tree-il compiler * module/Makefile.am (BRAINFUCK_LANG_SOURCES): Compile at the end. Add compile-tree-il.scm. * module/language/brainfuck/compile-tree-il.scm: New compiler, compiles to tree-il instead of scheme. I thought it would be more illustrative, though there are some uncommented bits. * module/language/brainfuck/parse.scm: Modify not to put a header on the scheme representation. After all, we don't put before scheme code, do we? :) * module/language/brainfuck/spec.scm: Add tree-il compiler. * module/language/tree-il.scm: Understand (set! (lexical foo) ...). * module/system/base/language.scm: Update license. Actually, updates licenses on all these. --- module/Makefile.am | 7 +- module/language/brainfuck/compile-tree-il.scm | 153 ++++++++++++++++++ module/language/brainfuck/parse.scm | 35 ++-- module/language/brainfuck/spec.scm | 26 +-- module/language/tree-il.scm | 3 + module/system/base/language.scm | 24 +-- 6 files changed, 200 insertions(+), 48 deletions(-) create mode 100644 module/language/brainfuck/compile-tree-il.scm diff --git a/module/Makefile.am b/module/Makefile.am index 10ff5eaa1..a904a8f8e 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -41,7 +41,6 @@ SOURCES = \ $(SCHEME_LANG_SOURCES) \ $(TREE_IL_LANG_SOURCES) \ $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ - $(BRAINFUCK_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ \ @@ -51,6 +50,7 @@ SOURCES = \ $(OOP_SOURCES) \ $(SYSTEM_SOURCES) \ $(ECMASCRIPT_LANG_SOURCES) \ + $(BRAINFUCK_LANG_SOURCES) \ $(SCRIPTS_SOURCES) ## test.scm is not currently installed. @@ -114,9 +114,10 @@ ECMASCRIPT_LANG_SOURCES = \ language/ecmascript/spec.scm BRAINFUCK_LANG_SOURCES = \ - language/brainfuck/spec.scm \ language/brainfuck/parse.scm \ - language/brainfuck/compile-scheme.scm + language/brainfuck/compile-scheme.scm \ + language/brainfuck/compile-tree-il.scm \ + language/brainfuck/spec.scm SCRIPTS_SOURCES = \ scripts/PROGRAM.scm \ diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm new file mode 100644 index 000000000..c9916310c --- /dev/null +++ b/module/language/brainfuck/compile-tree-il.scm @@ -0,0 +1,153 @@ +;;; Brainfuck for GNU Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; Brainfuck is a simple language that mostly mimics the operations of a +;; Turing machine. This file implements a compiler from Brainfuck to +;; Guile's Tree-IL. + +;;; Code: + +(define-module (language brainfuck compile-tree-il) + #:use-module (system base pmatch) + #:use-module (language tree-il) + #:export (compile-tree-il)) + +;; Compilation of Brainfuck is pretty straight-forward. For all of +;; brainfuck's instructions, there are basic representations in Tree-IL +;; we only have to generate. +;; +;; Brainfuck's pointer and data-tape are stored in the variables pointer and +;; tape, where tape is a vector of integer values initially set to zero. Pointer +;; starts out at position 0. +;; Our tape is thus of finite length, with an address range of 0..n for +;; some defined upper bound n depending on the length of our tape. + + +;; Define the length to use for the tape. + +(define tape-size 30000) + + +;; This compiles a whole brainfuck program. This constructs a Tree-IL +;; code equivalent to Scheme code like this: +;; +;; (let ((pointer 0) +;; (tape (make-vector tape-size 0))) +;; (begin +;; +;; (write-char #\newline))) +;; +;; So first the pointer and tape variables are set up correctly, then the +;; program's body is executed in this context, and finally we output an +;; additional newline character in case the program does not output one. +;; +;; Note that we're generating the S-expression representation of +;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL +;; data structures. This makes the compiler more pleasant to look at, +;; but we do lose is the ability to propagate source information. Since +;; Brainfuck is so obtuse anyway, this shouldn't matter ;-) +;; +;; TODO: Find out and explain the details about env, the three return values and +;; how to use the options. Implement options to set the tape-size, maybe. + +(define (compile-tree-il exp env opts) + (values + (parse-tree-il + `(let (pointer tape) (pointer tape) + ((const 0) + (apply (primitive make-vector) (const ,tape-size) (const 0))) + ,(compile-body exp))) + env + env)) + + +;; Compile a list of instructions to a Tree-IL expression. + +(define (compile-body instructions) + (let lp ((in instructions) (out '())) + (define (emit x) + (lp (cdr in) (cons x out))) + (cond + ((null? in) + ;; No more input, build our output. + (cond + ((null? out) '(void)) ; no output + ((null? (cdr out)) (car out)) ; single expression + (else `(begin ,@(reverse out)))) ; sequence + ) + (else + (pmatch (car in) + + ;; Pointer moves >< are done simply by something like: + ;; (set! pointer (+ pointer +-1)) + (( ,dir) + (emit `(set! (lexical pointer) + (apply (primitive +) (lexical pointer) (const ,dir))))) + + ;; Cell increment +- is done as: + ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1)) + (( ,inc) + (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer) + (apply (primitive +) + (apply (primitive vector-ref) + (lexical tape) (lexical pointer)) + (const ,inc))))) + + ;; Output . is done by converting the cell's integer value to a + ;; character first and then printing out this character: + ;; (write-char (integer->char (vector-ref tape pointer))) + (() + (emit `(apply (primitive write-char) + (apply (primitive integer->char) + (apply (primitive vector-ref) + (lexical tape) (lexical pointer)))))) + + ;; Input , is done similarly, read in a character, get its ASCII + ;; code and store it into the current cell: + ;; (vector-set! tape pointer (char->integer (read-char))) + (() + (emit `(apply (primitive vector-set!) + (lexical tape) (lexical pointer) + (apply (primitive char->integer) + (apply (primitive read-char)))))) + + ;; For loops [...] we use a letrec construction to execute the body until + ;; the current cell gets zero. The body is compiled via a recursive call + ;; back to (compile-body). + ;; (let iterate () + ;; (if (not (= (vector-ref! tape pointer) 0)) + ;; (begin + ;; + ;; (iterate)))) + (( . ,body) + (let ((iterate (gensym))) + (emit `(letrec (iterate) (,iterate) + ((lambda () () + (if (apply (primitive =) + (apply (primitive vector-ref) + (lexical tape) (lexical pointer)) + (const 0)) + (void) + (begin ,(compile-body body) + (apply (lexical ,iterate)))))) + (apply (lexical ,iterate)))))) + + (else (error "unknown brainfuck instruction" (car in)))))))) diff --git a/module/language/brainfuck/parse.scm b/module/language/brainfuck/parse.scm index 54dbaeecc..0a71638d8 100644 --- a/module/language/brainfuck/parse.scm +++ b/module/language/brainfuck/parse.scm @@ -2,20 +2,20 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, +;; This library 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. +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA ;;; Code: @@ -35,13 +35,6 @@ ; object. -; Read a brainfuck program from an input port. We construct the -; program and read in the instructions using (read-body). - -(define (read-brainfuck p) - `( ,@(read-body p))) - - ; While reading a number of instructions in sequence, all of them are cons'ed ; onto a list of instructions; thus this list gets out in reverse order. ; Additionally, for "comment characters" (everything not an instruction) we @@ -70,7 +63,7 @@ ; For instance, the basic program so just echo one character would be: ; ,.] -(define (read-body p) +(define (read-brainfuck p) (let iterate ((parsed '())) (let ((chr (read-char p))) (if (or (eof-object? chr) (eq? #\] chr)) @@ -80,7 +73,7 @@ ; This routine processes a single character of input and builds the ; corresponding instruction. Loop bodies are read by recursively calling -; back (read-body). +; back (read-brainfuck). ; ; For the poiner movement commands >< and the cell increment/decrement +- ; commands, we only use one instruction form each and specify the direction of @@ -94,5 +87,5 @@ ((#\-) '( -1)) ((#\.) '()) ((#\,) '()) - ((#\[) `( ,@(read-body p))) + ((#\[) `( ,@(read-brainfuck p))) (else '()))) diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm index a303984b2..a4ba60f82 100644 --- a/module/language/brainfuck/spec.scm +++ b/module/language/brainfuck/spec.scm @@ -2,24 +2,25 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, +;; This library 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. +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA ;;; Code: (define-module (language brainfuck spec) + #:use-module (language brainfuck compile-tree-il) #:use-module (language brainfuck compile-scheme) #:use-module (language brainfuck parse) #:use-module (system base language) @@ -37,6 +38,7 @@ #:title "Guile Brainfuck" #:version "1.0" #:reader (lambda () (read-brainfuck (current-input-port))) - #:compilers `((scheme . ,compile-scheme)) + #:compilers `((tree-il . ,compile-tree-il) + (scheme . ,compile-scheme)) #:printer write ) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index da483b3cc..0f8448a44 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -94,6 +94,9 @@ ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) (make-lexical-ref loc name sym)) + ((set! (lexical ,name) ,exp) (guard (symbol? name)) + (make-lexical-set loc name name (retrans exp))) + ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) (make-lexical-set loc name sym (retrans exp))) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 8ae4d9667..3670c53d9 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -1,21 +1,21 @@ ;;; Multi-language support -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, +;; This library 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. +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA ;;; Code: From d64fc8b039fd686a5f8f33458ba1193dc584b2a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 21 Jun 2009 23:32:19 +0200 Subject: [PATCH 251/375] Fix documentation of `make-bytevector'. * doc/ref/api-data.texi (Bytevector Manipulation): Fix documentation of the FILL argument of `make-bytevector'. --- doc/ref/api-data.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 8dbad385b..78d4ea27b 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -3839,8 +3839,8 @@ procedures. @deffnx {C Function} scm_make_bytevector (len, fill) @deffnx {C Function} scm_c_make_bytevector (unsigned len) Return a new bytevector of @var{len} bytes. Optionally, if @var{fill} -is given, fill it with @var{fill}; @var{fill} must be an 8-bit signed -integer, i.e., in the range [-128,127]. +is given, fill it with @var{fill}; @var{fill} must be in the range +[-128,255]. @end deffn @deffn {Scheme Procedure} bytevector? obj From 2d34e9244b8b35f62d086a88db749718a2a1a3b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 21 Jun 2009 16:55:58 +0200 Subject: [PATCH 252/375] bytevectors: Use `size_t' rather than `unsigned' for sizes. * doc/ref/api-data.texi (Bytevector Manipulation): Update. * libguile/bytevectors.c (INTEGER_ACCESSOR_PROLOGUE, make_bytevector_from_buffer, scm_c_make_bytevector, scm_c_take_bytevector, scm_i_shrink_bytevector): Use `size_t' for bytevector lengths. --- doc/ref/api-data.texi | 2 +- libguile/bytevectors.c | 14 +++++++------- libguile/bytevectors.h | 8 ++++---- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 78d4ea27b..eb059d329 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -3837,7 +3837,7 @@ procedures. @deffn {Scheme Procedure} make-bytevector len [fill] @deffnx {C Function} scm_make_bytevector (len, fill) -@deffnx {C Function} scm_c_make_bytevector (unsigned len) +@deffnx {C Function} scm_c_make_bytevector (size_t len) Return a new bytevector of @var{len} bytes. Optionally, if @var{fill} is given, fill it with @var{fill}; @var{fill} must be in the range [-128,255]. diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 2484a64a4..83058ba0b 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -74,7 +74,7 @@ #define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \ - unsigned c_len, c_index; \ + size_t c_len, c_index; \ _sign char *c_bv; \ \ SCM_VALIDATE_BYTEVECTOR (1, bv); \ @@ -184,14 +184,14 @@ SCM scm_null_bytevector = SCM_UNSPECIFIED; static inline SCM -make_bytevector_from_buffer (unsigned len, signed char *contents) +make_bytevector_from_buffer (size_t len, signed char *contents) { /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */ SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents); } static inline SCM -make_bytevector (unsigned len) +make_bytevector (size_t len) { SCM bv; @@ -212,7 +212,7 @@ make_bytevector (unsigned len) /* Return a new bytevector of size LEN octets. */ SCM -scm_c_make_bytevector (unsigned len) +scm_c_make_bytevector (size_t len) { return (make_bytevector (len)); } @@ -220,7 +220,7 @@ scm_c_make_bytevector (unsigned len) /* Return a bytevector of size LEN made up of CONTENTS. The area pointed to by CONTENTS must have been allocated using `scm_gc_malloc ()'. */ SCM -scm_c_take_bytevector (signed char *contents, unsigned len) +scm_c_take_bytevector (signed char *contents, size_t len) { SCM bv; @@ -243,11 +243,11 @@ scm_c_take_bytevector (signed char *contents, unsigned len) /* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current size) and return BV. */ SCM -scm_i_shrink_bytevector (SCM bv, unsigned c_new_len) +scm_i_shrink_bytevector (SCM bv, size_t c_new_len) { if (!SCM_BYTEVECTOR_INLINE_P (bv)) { - unsigned c_len; + size_t c_len; signed char *c_bv, *c_new_bv; c_len = SCM_BYTEVECTOR_LENGTH (bv); diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index 4b1b60660..208147627 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -27,7 +27,7 @@ /* R6RS bytevectors. */ #define SCM_BYTEVECTOR_LENGTH(_bv) \ - ((unsigned) SCM_SMOB_DATA (_bv)) + ((size_t) SCM_SMOB_DATA (_bv)) #define SCM_BYTEVECTOR_CONTENTS(_bv) \ (SCM_BYTEVECTOR_INLINE_P (_bv) \ ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \ @@ -38,7 +38,7 @@ SCM_API SCM scm_endianness_big; SCM_API SCM scm_endianness_little; SCM_API SCM scm_make_bytevector (SCM, SCM); -SCM_API SCM scm_c_make_bytevector (unsigned); +SCM_API SCM scm_c_make_bytevector (size_t); SCM_API SCM scm_native_endianness (void); SCM_API SCM scm_bytevector_p (SCM); SCM_API SCM scm_bytevector_length (SCM); @@ -123,14 +123,14 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM); SCM_API void scm_init_bytevectors (void); SCM_INTERNAL scm_t_bits scm_tc16_bytevector; -SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, unsigned); +SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t); #define scm_c_shrink_bytevector(_bv, _len) \ (SCM_BYTEVECTOR_INLINE_P (_bv) \ ? (_bv) \ : scm_i_shrink_bytevector ((_bv), (_len))) -SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, unsigned); +SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, size_t); SCM_INTERNAL SCM scm_null_bytevector; #endif /* SCM_BYTEVECTORS_H */ From 404bb5f87b66709206507acdf7b899101185a7a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 21 Jun 2009 23:16:57 +0200 Subject: [PATCH 253/375] bytevectors: Add a C-friendly API. * doc/ref/api-data.texi (Bytevector Manipulation): Add `scm_is_bytevector ()', `scm_c_bytevector_length ()', `scm_c_bytevector_length ()', and `scm_c_bytevector_set_x ()'. * libguile/bytevectors.c (scm_is_bytevector, scm_c_bytevector_length, scm_c_bytevector_ref, scm_c_bytevector_set_x): New functions. (scm_bytevector_p): Use `scm_is_bytevector ()'. (scm_bytevector_length): Use `scm_c_bytevector_length ()'. * libguile/bytevectors.h (scm_is_bytevector, scm_c_bytevector_length, scm_c_bytevector_ref, scm_c_bytevector_set_x): New declarations. --- doc/ref/api-data.texi | 18 ++++++++++++- libguile/bytevectors.c | 61 ++++++++++++++++++++++++++++++++++++++---- libguile/bytevectors.h | 7 ++++- 3 files changed, 79 insertions(+), 7 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index eb059d329..4ff738c6b 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -3833,7 +3833,7 @@ The objects denoting big (resp. little) endianness. @subsubsection Manipulating Bytevectors Bytevectors can be created, copied, and analyzed with the following -procedures. +procedures and C functions. @deffn {Scheme Procedure} make-bytevector len [fill] @deffnx {C Function} scm_make_bytevector (len, fill) @@ -3848,11 +3848,19 @@ is given, fill it with @var{fill}; @var{fill} must be in the range Return true if @var{obj} is a bytevector. @end deffn +@deftypefn {C Function} int scm_is_bytevector (SCM obj) +Equivalent to @code{scm_is_true (scm_bytevector_p (obj))}. +@end deftypefn + @deffn {Scheme Procedure} bytevector-length bv @deffnx {C Function} scm_bytevector_length (bv) Return the length in bytes of bytevector @var{bv}. @end deffn +@deftypefn {C Function} size_t scm_c_bytevector_length (SCM bv) +Likewise, return the length in bytes of bytevector @var{bv}. +@end deftypefn + @deffn {Scheme Procedure} bytevector=? bv1 bv2 @deffnx {C Function} scm_bytevector_eq_p (bv1, bv2) Return is @var{bv1} equals to @var{bv2}---i.e., if they have the same @@ -3876,6 +3884,14 @@ and start writing at @var{target-start}. Return a newly allocated copy of @var{bv}. @end deffn +@deftypefn {C Function} scm_t_uint8 scm_c_bytevector_ref (SCM bv, size_t index) +Return the byte at @var{index} in bytevector @var{bv}. +@end deftypefn + +@deftypefn {C Function} void scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value) +Set the byte at @var{index} in @var{bv} to @var{value}. +@end deftypefn + Low-level C macros are available. They do not perform any type-checking; as such they should be used with care. diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 83058ba0b..4dd66970d 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -274,6 +274,60 @@ scm_i_shrink_bytevector (SCM bv, size_t c_new_len) return bv; } +int +scm_is_bytevector (SCM obj) +{ + return SCM_SMOB_PREDICATE (scm_tc16_bytevector, obj); +} + +size_t +scm_c_bytevector_length (SCM bv) +#define FUNC_NAME "scm_c_bytevector_length" +{ + SCM_VALIDATE_BYTEVECTOR (1, bv); + + return SCM_BYTEVECTOR_LENGTH (bv); +} +#undef FUNC_NAME + +scm_t_uint8 +scm_c_bytevector_ref (SCM bv, size_t index) +#define FUNC_NAME "scm_c_bytevector_ref" +{ + size_t c_len; + const scm_t_uint8 *c_bv; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv); + + if (SCM_UNLIKELY (index >= c_len)) + scm_out_of_range (FUNC_NAME, scm_from_size_t (index)); + + return c_bv[index]; +} +#undef FUNC_NAME + +void +scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value) +#define FUNC_NAME "scm_c_bytevector_set_x" +{ + size_t c_len; + scm_t_uint8 *c_bv; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv); + + if (SCM_UNLIKELY (index >= c_len)) + scm_out_of_range (FUNC_NAME, scm_from_size_t (index)); + + c_bv[index] = value; +} +#undef FUNC_NAME + SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, bv, port, pstate) { @@ -357,8 +411,7 @@ SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0, "Return true if @var{obj} is a bytevector.") #define FUNC_NAME s_scm_bytevector_p { - return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector, - obj))); + return scm_from_bool (scm_is_bytevector (obj)); } #undef FUNC_NAME @@ -403,9 +456,7 @@ SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0, "Return the length (in bytes) of @var{bv}.") #define FUNC_NAME s_scm_bytevector_length { - SCM_VALIDATE_BYTEVECTOR (1, bv); - - return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv))); + return scm_from_uint (scm_c_bytevector_length (bv)); } #undef FUNC_NAME diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index 208147627..df1ad2dfe 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -37,8 +37,13 @@ SCM_API SCM scm_endianness_big; SCM_API SCM scm_endianness_little; -SCM_API SCM scm_make_bytevector (SCM, SCM); SCM_API SCM scm_c_make_bytevector (size_t); +SCM_API int scm_is_bytevector (SCM); +SCM_API size_t scm_c_bytevector_length (SCM); +SCM_API scm_t_uint8 scm_c_bytevector_ref (SCM, size_t); +SCM_API void scm_c_bytevector_set_x (SCM, size_t, scm_t_uint8); + +SCM_API SCM scm_make_bytevector (SCM, SCM); SCM_API SCM scm_native_endianness (void); SCM_API SCM scm_bytevector_p (SCM); SCM_API SCM scm_bytevector_length (SCM); From 438974d08dcb96a01fe62ea9b0446b8420e703c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 22 Jun 2009 00:51:08 +0200 Subject: [PATCH 254/375] Make bytevectors accessible using the generalized-vector API. As a side effect, this allows compilation of literal bytevectors ("#vu8(...)"), which gets done by the generic array handling of the GLIL->assembly compiler. * doc/ref/api-compound.texi (Generalized Vectors): Mention bytevectors. (Arrays, Array Syntax): Likewise. * doc/ref/api-data.texi (Bytevectors as Generalized Vectors): New node. * libguile/bytevectors.c (scm_i_bytevector_generalized_set_x): New. * libguile/bytevectors.h (scm_i_bytevector_generalized_set_x): New declaration. * libguile/srfi-4.c (scm_i_generalized_vector_type, scm_array_handle_uniform_element_size, scm_array_handle_uniform_writable_elements): Add support for bytevectors. * libguile/unif.c (type_creator_table): Add `vu8'. (bytevector_ref, bytevector_set): New functions. (memoize_ref, memoize_set): Add support for bytevectors. * libguile/vectors.c (scm_is_generalized_vector, scm_c_generalized_vector_length, scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x): Add support for bytevectors. * test-suite/tests/bytevectors.test ("Generalized Vectors"): New test set. --- doc/ref/api-compound.texi | 22 +++++++--- doc/ref/api-data.texi | 27 ++++++++++++ libguile/bytevectors.c | 9 ++++ libguile/bytevectors.h | 1 + libguile/srfi-4.c | 9 +++- libguile/unif.c | 31 +++++++++++++- libguile/vectors.c | 14 ++++-- test-suite/tests/bytevectors.test | 71 +++++++++++++++++++++++++++++++ 8 files changed, 173 insertions(+), 11 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 2811ee4f2..8d0e02f20 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1649,9 +1649,9 @@ and writing. @subsection Generalized Vectors Guile has a number of data types that are generally vector-like: -strings, uniform numeric vectors, bitvectors, and of course ordinary -vectors of arbitrary Scheme values. These types are disjoint: a -Scheme value belongs to at most one of the four types listed above. +strings, uniform numeric vectors, bytevectors, bitvectors, and of course +ordinary vectors of arbitrary Scheme values. These types are disjoint: +a Scheme value belongs to at most one of the four types listed above. If you want to gloss over this distinction and want to treat all four types with common code, you can use the procedures in this section. @@ -1749,9 +1749,9 @@ matrix with zero columns and 3 rows is different from a matrix with 3 columns and zero rows, which again is different from a vector of length zero. -Generalized vectors, such as strings, uniform numeric vectors, bit -vectors and ordinary vectors, are the special case of one dimensional -arrays. +Generalized vectors, such as strings, uniform numeric vectors, +bytevectors, bit vectors and ordinary vectors, are the special case of +one dimensional arrays. @menu * Array Syntax:: @@ -1834,6 +1834,16 @@ is a rank-zero array with contents 12. @end table +In addition, bytevectors are also arrays, but use a different syntax +(@pxref{Bytevectors}): + +@table @code + +@item #vu8(1 2 3) +is a 3-byte long bytevector, with contents 1, 2, 3. + +@end table + @node Array Procedures @subsubsection Array Procedures diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 4ff738c6b..4401ef1cf 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -3789,6 +3789,7 @@ R6RS (@pxref{R6RS I/O Ports}). * Bytevectors and Integer Lists:: Converting to/from an integer list. * Bytevectors as Floats:: Interpreting bytes as real numbers. * Bytevectors as Strings:: Interpreting bytes as Unicode strings. +* Bytevectors as Generalized Vectors:: Guile extension to the bytevector API. @end menu @node Bytevector Endianness @@ -4156,6 +4157,32 @@ Return a newly allocated string that contains from the UTF-8-, UTF-16-, or UTF-32-decoded contents of bytevector @var{utf}. @end deffn +@node Bytevectors as Generalized Vectors +@subsubsection Accessing Bytevectors with the Generalized Vector API + +As an extension to the R6RS, Guile allows bytevectors to be manipulated +with the @dfn{generalized vector} procedures (@pxref{Generalized +Vectors}). This also allows bytevectors to be accessed using the +generic @dfn{array} procedures (@pxref{Array Procedures}). When using +these APIs, bytes are accessed one at a time as 8-bit unsigned integers: + +@example +(define bv #vu8(0 1 2 3)) + +(generalized-vector? bv) +@result{} #t + +(generalized-vector-ref bv 2) +@result{} 2 + +(generalized-vector-set! bv 2 77) +(array-ref bv 2) +@result{} 77 + +(array-type bv) +@result{} vu8 +@end example + @node Regular Expressions @subsection Regular Expressions diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 4dd66970d..2060192c6 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -328,6 +328,15 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value) } #undef FUNC_NAME +/* This procedure is used by `scm_c_generalized_vector_set_x ()'. */ +void +scm_i_bytevector_generalized_set_x (SCM bv, size_t index, SCM value) +#define FUNC_NAME "scm_i_bytevector_generalized_set_x" +{ + scm_c_bytevector_set_x (bv, index, scm_to_uint8 (value)); +} +#undef FUNC_NAME + SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, bv, port, pstate) { diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index df1ad2dfe..ccab27522 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -136,6 +136,7 @@ SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t); : scm_i_shrink_bytevector ((_bv), (_len))) SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, size_t); +SCM_INTERNAL void scm_i_bytevector_generalized_set_x (SCM, size_t, SCM); SCM_INTERNAL SCM scm_null_bytevector; #endif /* SCM_BYTEVECTORS_H */ diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index ac31fdc10..da571b0b8 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -1,6 +1,6 @@ /* srfi-4.c --- Uniform numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -29,6 +29,7 @@ #include "libguile/_scm.h" #include "libguile/__scm.h" #include "libguile/srfi-4.h" +#include "libguile/bytevectors.h" #include "libguile/error.h" #include "libguile/read.h" #include "libguile/ports.h" @@ -609,6 +610,8 @@ scm_i_generalized_vector_type (SCM v) return scm_sym_b; else if (scm_is_uniform_vector (v)) return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]); + else if (scm_is_bytevector (v)) + return scm_from_locale_symbol ("vu8"); else return SCM_BOOL_F; } @@ -750,6 +753,8 @@ scm_array_handle_uniform_element_size (scm_t_array_handle *h) vec = SCM_I_ARRAY_V (vec); if (scm_is_uniform_vector (vec)) return uvec_sizes[SCM_UVEC_TYPE(vec)]; + if (scm_is_bytevector (vec)) + return 1U; scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); } @@ -790,6 +795,8 @@ scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) char *elts = SCM_UVEC_BASE (vec); return (void *) (elts + size*h->base); } + if (scm_is_bytevector (vec)) + return SCM_BYTEVECTOR_CONTENTS (vec); scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); } diff --git a/libguile/unif.c b/libguile/unif.c index d393e8a1a..84b532347 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -47,6 +47,7 @@ #include "libguile/srfi-13.h" #include "libguile/srfi-4.h" #include "libguile/vectors.h" +#include "libguile/bytevectors.h" #include "libguile/list.h" #include "libguile/deprecation.h" #include "libguile/dynwind.h" @@ -109,6 +110,7 @@ struct { { "f64", SCM_UNSPECIFIED, scm_make_f64vector }, { "c32", SCM_UNSPECIFIED, scm_make_c32vector }, { "c64", SCM_UNSPECIFIED, scm_make_c64vector }, + { "vu8", SCM_UNSPECIFIED, scm_make_bytevector }, { NULL } }; @@ -313,6 +315,12 @@ bitvector_ref (scm_t_array_handle *h, ssize_t pos) scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32))); } +static SCM +bytevector_ref (scm_t_array_handle *h, ssize_t pos) +{ + return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]); +} + static SCM memoize_ref (scm_t_array_handle *h, ssize_t pos) { @@ -346,6 +354,11 @@ memoize_ref (scm_t_array_handle *h, ssize_t pos) h->elements = scm_array_handle_bit_elements (h); h->ref = bitvector_ref; } + else if (scm_is_bytevector (v)) + { + h->elements = scm_array_handle_uniform_elements (h); + h->ref = bytevector_ref; + } else scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); @@ -386,6 +399,17 @@ bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val) ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask; } +static void +bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val) +{ + scm_t_uint8 c_value; + scm_t_uint8 *elements; + + c_value = scm_to_uint8 (val); + elements = (scm_t_uint8 *) h->elements; + elements[pos] = (scm_t_uint8) c_value; +} + static void memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val) { @@ -420,6 +444,11 @@ memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val) h->writable_elements = scm_array_handle_bit_writable_elements (h); h->set = bitvector_set; } + else if (scm_is_bytevector (v)) + { + h->elements = scm_array_handle_uniform_writable_elements (h); + h->set = bytevector_set; + } else scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); diff --git a/libguile/vectors.c b/libguile/vectors.c index ae0fc319f..6dc994f55 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -31,6 +31,7 @@ #include "libguile/validate.h" #include "libguile/vectors.h" #include "libguile/unif.h" +#include "libguile/bytevectors.h" #include "libguile/ramap.h" #include "libguile/srfi-4.h" #include "libguile/strings.h" @@ -523,7 +524,7 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, } #undef FUNC_NAME - + /* Generalized vectors. */ int @@ -532,7 +533,8 @@ scm_is_generalized_vector (SCM obj) return (scm_is_vector (obj) || scm_is_string (obj) || scm_is_bitvector (obj) - || scm_is_uniform_vector (obj)); + || scm_is_uniform_vector (obj) + || scm_is_bytevector (obj)); } SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0, @@ -564,6 +566,8 @@ scm_c_generalized_vector_length (SCM v) return scm_c_bitvector_length (v); else if (scm_is_uniform_vector (v)) return scm_c_uniform_vector_length (v); + else if (scm_is_bytevector (v)) + return scm_c_bytevector_length (v); else scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); } @@ -588,6 +592,8 @@ scm_c_generalized_vector_ref (SCM v, size_t idx) return scm_c_bitvector_ref (v, idx); else if (scm_is_uniform_vector (v)) return scm_c_uniform_vector_ref (v, idx); + else if (scm_is_bytevector (v)) + return scm_from_uint8 (scm_c_bytevector_ref (v, idx)); else scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); } @@ -613,6 +619,8 @@ scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) scm_c_bitvector_set_x (v, idx, val); else if (scm_is_uniform_vector (v)) scm_c_uniform_vector_set_x (v, idx, val); + else if (scm_is_bytevector (v)) + scm_i_bytevector_generalized_set_x (v, idx, val); else scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); } diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 342f08a24..45f11ec77 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -583,6 +583,77 @@ exception:wrong-type-arg (with-input-from-string "#vu8(0 256)" read))) + +(with-test-prefix "Generalized Vectors" + + (pass-if "generalized-vector?" + (generalized-vector? #vu8(1 2 3))) + + (pass-if "generalized-vector-length" + (equal? (iota 16) + (map generalized-vector-length + (map make-bytevector (iota 16))))) + + (pass-if "generalized-vector-ref" + (let ((bv #vu8(255 127))) + (and (= 255 (generalized-vector-ref bv 0)) + (= 127 (generalized-vector-ref bv 1))))) + + (pass-if-exception "generalized-vector-ref [index out-of-range]" + exception:out-of-range + (let ((bv #vu8(1 2))) + (generalized-vector-ref bv 2))) + + (pass-if "generalized-vector-set!" + (let ((bv (make-bytevector 2))) + (generalized-vector-set! bv 0 255) + (generalized-vector-set! bv 1 77) + (equal? '(255 77) + (bytevector->u8-list bv)))) + + (pass-if-exception "generalized-vector-set! [index out-of-range]" + exception:out-of-range + (let ((bv (make-bytevector 2))) + (generalized-vector-set! bv 2 0))) + + (pass-if-exception "generalized-vector-set! [value out-of-range]" + exception:out-of-range + (let ((bv (make-bytevector 2))) + (generalized-vector-set! bv 0 256))) + + (pass-if "array-type" + (eq? 'vu8 (array-type #vu8()))) + + (pass-if "array-contents" + (let ((bv (u8-list->bytevector (iota 10)))) + (eq? bv (array-contents bv)))) + + (pass-if "array-ref" + (let ((bv (u8-list->bytevector (iota 10)))) + (equal? (iota 10) + (map (lambda (i) (array-ref bv i)) + (iota 10))))) + + (pass-if "array-set!" + (let ((bv (make-bytevector 10))) + (for-each (lambda (i) + (array-set! bv i i)) + (iota 10)) + (equal? (iota 10) + (bytevector->u8-list bv)))) + + (pass-if "make-typed-array" + (let ((bv (make-typed-array 'vu8 77 33))) + (equal? bv (u8-list->bytevector (make-list 33 77))))) + + (pass-if-exception "make-typed-array [out-of-range]" + exception:out-of-range + (make-typed-array 'vu8 256 77)) + + (pass-if "uniform-array->bytevector" + (let ((bv #vu8(0 1 128 255))) + (equal? bv (uniform-array->bytevector bv))))) + ;;; Local Variables: ;;; coding: latin-1 From cfb4702f5886f2df197521cc47b6ca86547b165e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 22 Jun 2009 00:56:00 +0200 Subject: [PATCH 255/375] Always create the bytevector SMOB type. * libguile/bytevectors.c (scm_tc16_bytevector, print_bytevector, bytevector_equal_p, free_bytevector): Don't use the snarfing macros. (scm_bootstrap_bytevectors): New. (scm_init_bytevectors): No longer initialize SCM_NULL_BYTEVECTOR, which is done by `scm_bootstrap_bytevectors ()'. * libguile/bytevectors.h (scm_bootstrap_bytevectors): New declaration. (scm_init_bytevectors): Made internal. This can be done because we explicitly register it with `scm_c_register_extension ()' in `scm_bootstrap_bytevectors ()'. * libguile/init.c (scm_i_init_guile): Call `scm_bootstrap_bytevectors ()'. This is so that expressions like "(generalized-vector-length #vu8())" work even when `(rnrs bytevector)' hasn't been loaded. --- libguile/bytevectors.c | 35 +++++++++++++++++++++++++++-------- libguile/bytevectors.h | 3 ++- libguile/init.c | 2 ++ 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 2060192c6..fd9043ad1 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -26,6 +26,7 @@ #include #include "libguile/_scm.h" +#include "libguile/extensions.h" #include "libguile/bytevectors.h" #include "libguile/strings.h" #include "libguile/validate.h" @@ -172,7 +173,7 @@ /* Bytevector type. */ -SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0); +scm_t_bits scm_tc16_bytevector; #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \ SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len)) @@ -337,8 +338,8 @@ scm_i_bytevector_generalized_set_x (SCM bv, size_t index, SCM value) } #undef FUNC_NAME -SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, - bv, port, pstate) +static int +print_bytevector (SCM bv, SCM port, scm_print_state *pstate) { unsigned c_len, i; unsigned char *c_bv; @@ -363,12 +364,14 @@ SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, return 1; } -SCM_SMOB_EQUALP (scm_tc16_bytevector, bytevector_equal_p, bv1, bv2) +static SCM +bytevector_equal_p (SCM bv1, SCM bv2) { return scm_bytevector_eq_p (bv1, bv2); } -SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv) +static size_t +free_bytevector (SCM bv) { if (!SCM_BYTEVECTOR_INLINE_P (bv)) @@ -2058,6 +2061,25 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", /* Initialization. */ +void +scm_bootstrap_bytevectors (void) +{ + /* The SMOB type must be instantiated here because the + generalized-vector API may want to access bytevectors even though + `(rnrs bytevector)' hasn't been loaded. */ + scm_tc16_bytevector = scm_make_smob_type ("bytevector", 0); + scm_set_smob_free (scm_tc16_bytevector, free_bytevector); + scm_set_smob_print (scm_tc16_bytevector, print_bytevector); + scm_set_smob_equalp (scm_tc16_bytevector, bytevector_equal_p); + + scm_null_bytevector = + scm_gc_protect_object (make_bytevector_from_buffer (0, NULL)); + + scm_c_register_extension ("libguile", "scm_init_bytevectors", + (scm_t_extension_init_func) scm_init_bytevectors, + NULL); +} + void scm_init_bytevectors (void) { @@ -2071,7 +2093,4 @@ scm_init_bytevectors (void) scm_endianness_big = scm_sym_big; scm_endianness_little = scm_sym_little; - - scm_null_bytevector = - scm_gc_protect_object (make_bytevector_from_buffer (0, NULL)); } diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index ccab27522..903ce7ae3 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -125,7 +125,8 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM); /* Hint that is passed to `scm_gc_malloc ()' and friends. */ #define SCM_GC_BYTEVECTOR "bytevector" -SCM_API void scm_init_bytevectors (void); +SCM_INTERNAL void scm_bootstrap_bytevectors (void); +SCM_INTERNAL void scm_init_bytevectors (void); SCM_INTERNAL scm_t_bits scm_tc16_bytevector; SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t); diff --git a/libguile/init.c b/libguile/init.c index 2b500ac3a..5ece01fb0 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -38,6 +38,7 @@ #include "libguile/async.h" #include "libguile/backtrace.h" #include "libguile/boolean.h" +#include "libguile/bytevectors.h" #include "libguile/chars.h" #include "libguile/continuations.h" #include "libguile/debug.h" @@ -573,6 +574,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_rw (); scm_init_extensions (); + scm_bootstrap_bytevectors (); scm_bootstrap_vm (); atexit (cleanup_for_exit); From eb72179985966493f452c7be8b9b048341d2f9c5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 Jun 2009 20:45:01 +0200 Subject: [PATCH 256/375] meta-commands read off their own arguments * module/system/repl/command.scm: Update copyright. (meta-command): Rework so that it's the various meta-commands that do the reading for their arguments. This way you can compile forms that span more than one line, and forms that need to be read with another language's reader. (define-meta-command): New helper macro. Update commands to use it. (help): Allow ,help on commands too. * module/system/repl/repl.scm: Update copyright. (start-repl): Adjust to give meta-command what it wants. --- module/system/repl/command.scm | 157 +++++++++++++++++++++------------ module/system/repl/repl.scm | 27 +++--- 2 files changed, 112 insertions(+), 72 deletions(-) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index e6b492996..6f45bd7f6 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -1,21 +1,21 @@ ;;; Repl commands -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, +;; This library 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. +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA ;;; Code: @@ -27,7 +27,7 @@ #:use-module (system vm objcode) #:use-module (system vm program) #:use-module (system vm vm) - #:autoload (system base language) (lookup-language) + #:autoload (system base language) (lookup-language language-reader) #:autoload (system vm debug) (vm-debugger vm-backtrace) #:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off) #:autoload (system vm profile) (vm-profile) @@ -35,6 +35,7 @@ #:use-module (ice-9 session) #:use-module (ice-9 documentation) #:use-module (ice-9 and-let-star) + #:use-module (ice-9 rdelim) #:export (meta-command)) @@ -109,33 +110,66 @@ (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) ""))) (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary))) -(define (meta-command repl line) - (let ((input (call-with-input-string (string-append "(" line ")") read))) - (if (not (null? input)) - (do ((key (car input)) - (args (cdr input) (cdr args)) - (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts))) - ((or (null? args) - (not (symbol? (car args))) - (not (eq? (string-ref (symbol->string (car args)) 0) #\-))) - (let ((c (lookup-command key))) - (if c - (cond ((memq #:h opts) (display-command c)) - (else (apply (command-procedure c) - repl (append! args (reverse! opts))))) - (user-error "Unknown meta command: ~A" key)))))))) +(define (read-datum repl) + (read)) + +(define read-line + (let ((orig-read-line read-line)) + (lambda (repl) + (orig-read-line)))) + +(define (meta-command repl) + (let ((command (read-datum repl))) + (if (not (symbol? command)) + (user-error "Meta-command not a symbol: ~s" command)) + (let ((c (lookup-command command))) + (if c + ((command-procedure c) repl) + (user-error "Unknown meta command: ~A" command))))) + +(define-syntax define-meta-command + (syntax-rules () + ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...) + (define (name repl) + docstring + (let* ((expression0 + (with-fluid* current-reader + (language-reader (repl-language repl)) + (lambda () (repl-reader "")))) + ...) + (apply (lambda datums b0 b1 ...) + (let ((port (open-input-string (read-line repl)))) + (let lp ((out '())) + (let ((x (read port))) + (if (eof-object? x) + (reverse out) + (lp (cons x out)))))))))) + ((_ (name repl . datums) docstring b0 b1 ...) + (define-meta-command (name repl () . datums) + docstring b0 b1 ...)))) + ;;; ;;; Help commands ;;; -(define (help repl . args) - "help [GROUP] -List available meta commands. -A command group name can be given as an optional argument. +(define-meta-command (help repl . args) + "help +help GROUP +help [-c] COMMAND + +Gives help on the meta-commands available at the REPL. + +With one argument, tries to look up the argument as a group name, giving +help on that group if successful. Otherwise tries to look up the +argument as a command, giving help on the command. + +If there is a command whose name is also a group name, use the ,help +-c COMMAND form to give help on the command instead of the group. + Without any argument, a list of help commands and command groups -are displayed, as you have already seen ;)" +are displayed." (pmatch args (() (display-group (lookup-group 'help)) @@ -154,23 +188,30 @@ are displayed, as you have already seen ;)" (for-each display-group *command-table*)) ((,group) (guard (lookup-group group)) (display-group (lookup-group group))) + ((,command) (guard (lookup-command command)) + (display-command (lookup-command command))) + ((-c ,command) (guard (lookup-command command)) + (display-command (lookup-command command))) + ((,command) + (user-error "Unknown command or group: ~A" command)) + ((-c ,command) + (user-error "Unknown command: ~A" command)) (else - (user-error "Unknown command group: ~A" (car args))))) + (user-error "Bad arguments: ~A" args)))) (define guile:apropos apropos) -(define (apropos repl regexp) +(define-meta-command (apropos repl regexp) "apropos REGEXP Find bindings/modules/packages." (guile:apropos (->string regexp))) -(define (describe repl obj) +(define-meta-command (describe repl (form)) "describe OBJ Show description/documentation." - (display (object-documentation - (repl-eval repl (repl-parse repl obj)))) + (display (object-documentation (repl-eval repl (repl-parse repl form)))) (newline)) -(define (option repl . args) +(define-meta-command (option repl . args) "option [KEY VALUE] List/show/set options." (pmatch args @@ -190,7 +231,7 @@ List/show/set options." (apply vm-trace-on vm val) (vm-trace-off vm)))))))) -(define (quit repl) +(define-meta-command (quit repl) "quit Quit this session." (throw 'quit)) @@ -200,7 +241,7 @@ Quit this session." ;;; Module commands ;;; -(define (module repl . args) +(define-meta-command (module repl . args) "module [MODULE] Change modules / Show current module." (pmatch args @@ -209,7 +250,7 @@ Change modules / Show current module." (set-current-module (resolve-module mod-name))) (,mod-name (set-current-module (resolve-module mod-name))))) -(define (import repl . args) +(define-meta-command (import repl . args) "import [MODULE ...] Import modules / List those imported." (let () @@ -222,7 +263,7 @@ Import modules / List those imported." (for-each puts (map module-name (module-uses (current-module)))) (for-each use args)))) -(define (load repl file . opts) +(define-meta-command (load repl file . opts) "load FILE Load a file in the current module. @@ -233,7 +274,7 @@ Load a file in the current module. (apply load-file file opts)))) (vm-load (repl-vm repl) objcode))) -(define (binding repl . opts) +(define-meta-command (binding repl) "binding List current bindings." (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) @@ -244,7 +285,7 @@ List current bindings." ;;; Language commands ;;; -(define (language repl name) +(define-meta-command (language repl name) "language LANGUAGE Change languages." (set! (repl-language repl) (lookup-language name)) @@ -255,7 +296,7 @@ Change languages." ;;; Compile commands ;;; -(define (compile repl form . opts) +(define-meta-command (compile repl (form) . opts) "compile FORM Generate compiled code. @@ -270,7 +311,7 @@ Generate compiled code. (else (repl-print repl x))))) (define guile:compile-file compile-file) -(define (compile-file repl file . opts) +(define-meta-command (compile-file repl file . opts) "compile-file FILE Compile a file." (guile:compile-file (->string file) #:opts opts)) @@ -278,12 +319,12 @@ Compile a file." (define (guile:disassemble x) ((@ (language assembly disassemble) disassemble) x)) -(define (disassemble repl prog) +(define-meta-command (disassemble repl (form)) "disassemble PROGRAM Disassemble a program." - (guile:disassemble (repl-eval repl (repl-parse repl prog)))) + (guile:disassemble (repl-eval repl (repl-parse repl form)))) -(define (disassemble-file repl file) +(define-meta-command (disassemble-file repl file) "disassemble-file FILE Disassemble a file." (guile:disassemble (load-objcode (->string file)))) @@ -293,7 +334,7 @@ Disassemble a file." ;;; Profile commands ;;; -(define (time repl form) +(define-meta-command (time repl (form)) "time FORM Time execution." (let* ((vms-start (vm-stats (repl-vm repl))) @@ -316,7 +357,7 @@ Time execution." (get identity gc-start gc-end)) result)) -(define (profile repl form . opts) +(define-meta-command (profile repl form . opts) "profile FORM Profile execution." (apply vm-profile @@ -329,17 +370,17 @@ Profile execution." ;;; Debug commands ;;; -(define (backtrace repl) +(define-meta-command (backtrace repl) "backtrace Display backtrace." (vm-backtrace (repl-vm repl))) -(define (debugger repl) +(define-meta-command (debugger repl) "debugger Start debugger." (vm-debugger (repl-vm repl))) -(define (trace repl form . opts) +(define-meta-command (trace repl form . opts) "trace FORM Trace execution. @@ -351,7 +392,7 @@ Trace execution. (repl-compile repl (repl-parse repl form)) opts)) -(define (step repl) +(define-meta-command (step repl) "step FORM Step execution." (display "Not implemented yet\n")) @@ -362,12 +403,12 @@ Step execution." ;;; (define guile:gc gc) -(define (gc repl) +(define-meta-command (gc repl) "gc Garbage collection." (guile:gc)) -(define (statistics repl) +(define-meta-command (statistics repl) "statistics Display statistics." (let ((this-tms (times)) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 0a06e3dd0..86fb56fd2 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -1,21 +1,21 @@ ;;; Read-Eval-Print Loop -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, +;; This library 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. +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. ;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA ;;; Code: @@ -28,7 +28,6 @@ #:use-module (system repl command) #:use-module (system vm vm) #:use-module (system vm debug) - #:use-module (ice-9 rdelim) #:export (start-repl call-with-backtrace)) (define meta-command-token (cons 'meta 'command)) @@ -103,7 +102,7 @@ (cond ((eqv? exp (if #f #f))) ; read error, pass ((eq? exp meta-command-token) - (with-backtrace (meta-command repl (read-line)))) + (with-backtrace (meta-command repl))) ((eof-object? exp) (newline) (set! status '())) From b674d4716abe775e648445795f02bece8a3396e0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 Jun 2009 22:44:34 +0200 Subject: [PATCH 257/375] more docs to brainfuck->tree-il compiler * module/language/brainfuck/compile-tree-il.scm (compile-tree-il): Wrap the result in a ((lambda () ...)), so we can use toplevel-ref. Add lots more comments. --- module/language/brainfuck/compile-tree-il.scm | 63 +++++++++++++++---- 1 file changed, 52 insertions(+), 11 deletions(-) diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm index c9916310c..62987fc63 100644 --- a/module/language/brainfuck/compile-tree-il.scm +++ b/module/language/brainfuck/compile-tree-il.scm @@ -49,32 +49,66 @@ ;; This compiles a whole brainfuck program. This constructs a Tree-IL ;; code equivalent to Scheme code like this: ;; -;; (let ((pointer 0) -;; (tape (make-vector tape-size 0))) -;; (begin -;; -;; (write-char #\newline))) +;; ((lambda () +;; (let ((pointer 0) +;; (tape (make-vector tape-size 0))) +;; (begin +;; +;; (write-char #\newline))))) ;; ;; So first the pointer and tape variables are set up correctly, then the ;; program's body is executed in this context, and finally we output an ;; additional newline character in case the program does not output one. ;; +;; The fact that we are compiling to Guile primitives gives this +;; implementation a number of interesting characteristics. First, the +;; values of the tape cells do not underflow or overflow. We could make +;; them do otherwise via compiling calls to "modulo" at certain points. +;; +;; In addition, tape overruns or underruns will be detected, and will +;; throw an error, whereas a number of Brainfuck compilers do not detect +;; this. +;; +;; We wrap the code in a lambda so that the body has a place to cache +;; the looked-up locations of the primitive functions: vector-ref et al. +;; This way we can use toplevel-ref instead of link-now + variable-ref. +;; See the VM documentation for more info on those instructions. +;; +;; Normally when compiling you don't have to think about this at all, +;; because the usual pattern is a bunch of definitions, then you call +;; those definitions -- so the real work is in the functions anyway, +;; which can use toplevel-ref. Here we just force that pattern into +;; effect. +;; ;; Note that we're generating the S-expression representation of ;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL ;; data structures. This makes the compiler more pleasant to look at, ;; but we do lose is the ability to propagate source information. Since ;; Brainfuck is so obtuse anyway, this shouldn't matter ;-) ;; -;; TODO: Find out and explain the details about env, the three return values and -;; how to use the options. Implement options to set the tape-size, maybe. +;; `compile-tree-il' takes as its input the read expression, the +;; environment, and some compile options. It returns the compiled +;; expression, the environment appropriate for the next pass of the +;; compiler -- in our case, just the environment unchanged -- and the +;; continuation environment. +;; +;; The normal use of a continuation environment is if compiling one +;; expression changes the environment, and that changed environment +;; should be passed to the next compiled expression -- for example, +;; changing the current module. But Brainfuck is incapable of that, so +;; for us, the continuation environment is just the same environment we +;; got in. +;; +;; FIXME: perhaps use options or the env to set the tape-size? (define (compile-tree-il exp env opts) (values (parse-tree-il - `(let (pointer tape) (pointer tape) - ((const 0) - (apply (primitive make-vector) (const ,tape-size) (const 0))) - ,(compile-body exp))) + `(apply (lambda () () + (let (pointer tape) (pointer tape) + ((const 0) + (apply (primitive make-vector) (const ,tape-size) (const 0))) + ,(compile-body exp))))) env env)) @@ -137,6 +171,13 @@ ;; (begin ;; ;; (iterate)))) + ;; + ;; Indeed, letrec is the only way we have to loop in Tree-IL. + ;; Note that this does not mean that the closure must actually + ;; be created; later passes can compile tail-recursive letrec + ;; calls into inline code with gotos. Admittedly, that part of + ;; the compiler is not yet in place, but it will be, and in the + ;; meantime the code is still reasonably efficient. (( . ,body) (let ((iterate (gensym))) (emit `(letrec (iterate) (,iterate) From 0d646345f477f0ffced6f602370fc8c607f7d32f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 Jun 2009 22:57:48 +0200 Subject: [PATCH 258/375] flush whitespace from the repl input buffer *before* evaluation * module/system/repl/repl.scm (start-repl): Given that the input port of the repl is line-buffered, it's likely we have #\newline in the input that is strictly extraneous, an in-band indicator to the repl that it should begin reading now. So flush out that newline, so that you can (read-char) at the repl, and it actually does wait for you to type in a char instead of just returning #\newline. While it's not an overriding concern, this does fix some brainfuck programs that want to input from the user. --- module/system/repl/repl.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 86fb56fd2..2f4a3783a 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -107,6 +107,9 @@ (newline) (set! status '())) (else + ;; since the input port is line-buffered, consume up to the + ;; newline + (flush-to-newline) (with-backtrace (catch 'quit (lambda () @@ -134,3 +137,14 @@ ((char-whitespace? ch) (read-char) (next-char wait)) (else ch))) #f)) + +(define (flush-to-newline) + (if (char-ready?) + (let ((ch (peek-char))) + (if (and (not (eof-object? ch)) (char-whitespace? ch)) + (begin + (read-char) + (if (not (char=? ch #\newline)) + (flush-to-newline))))))) + + \ No newline at end of file From 0ebbcf43c45892afcec199bde0ca1ecaea0077da Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 18 Jun 2009 20:35:45 +0100 Subject: [PATCH 259/375] Remove AC_SYS_RESTARTABLE_SYSCALLS and related code As the Autoconf documentation says, "These days portable programs [...] should not rely on `HAVE_RESTARTABLE_SYSCALLS', since nowadays whether a system call is restartable is a dynamic issue, not a configuration-time issue." In other words, if we ever rely on HAVE_RESTARTABLE_SYSCALLS, we are at the mercy of any code that Guile happens to be linked with, because that code could install a signal handler without the SA_RESTART flag, and then a Guile system call could unexpectedly return EINTR. The readline part of this goes back to this problem report: http://sources.redhat.com/ml/guile/2000-05/msg00177.html; and is an excellent example of the above paragraph. It was noted during the discussion that undefining HAVE_RESTARTABLE_SYSCALLS would fix the problem, but that solution wasn't adopted - I guess because Guile was still using cooperative threads then (not pthreads) and so there was a significant concern (whether founded or not) that not using restartable syscalls (where available) could lead to a loss of performance. Now Guile's default mode of operation is with pthreads, where we already don't assume that HAVE_RESTARTABLE_SYSCALLS is reliable, so there is no possible further performance loss. And in any case we really have no choice, if we want correct operation. Thanks to Sylvain Beucler for reporting this and suggesting the fix. * configure.in (AC_SYS_RESTARTABLE_SYSCALLS): Removed. * doc/ref/posix.texi (Signals): Remove statement that Guile always sets SA_RESTART flag. * guile-readline/configure.in (GUILE_SIGWINCH_SA_RESTART_CLEARED): Remove this setting, together with its test code. (HAVE_RL_PRE_INPUT_HOOK): Remove this setting and its code, as no longer needed. * guile-readline/readline.c (sigwinch_enable_restart): Removed. (scm_init_readline): Remove setting of rl_pre_input_hook. * libguile/_scm.h (SCM_SYSCALL): Remove the definition that relies on HAVE_RESTARTABLE_SYSCALLS. * libguile/scmsigs.c (scm_sigaction_for_thread): Don't always set the SA_RESTART flag if available. Update docstring accordingly. (scm_init_scmsigs): Remove code that sets SA_RESTART flag for all signals. * THANKS: Add Sylvain. --- THANKS | 1 + configure.in | 12 ------- doc/ref/posix.texi | 4 --- guile-readline/configure.in | 71 ------------------------------------- guile-readline/readline.c | 23 ------------ libguile/_scm.h | 14 -------- libguile/scmsigs.c | 36 ++----------------- 7 files changed, 3 insertions(+), 158 deletions(-) diff --git a/THANKS b/THANKS index 90ccd8797..47aa93cc7 100644 --- a/THANKS +++ b/THANKS @@ -24,6 +24,7 @@ For fixes or providing information which led to a fix: David Allouche Martin Baulig Fabrice Bauzac + Sylvain Beucler Carlo Bramini Rob Browning Adrian Bunk diff --git a/configure.in b/configure.in index 1c4cf5f8b..73fc15321 100644 --- a/configure.in +++ b/configure.in @@ -1054,18 +1054,6 @@ if test $guile_cv_localtime_cache = yes; then AC_DEFINE(LOCALTIME_CACHE, 1, [Define if localtime caches the TZ setting.]) fi -dnl Test whether system calls are restartable by default on the -dnl current system. If they are not, we put a loop around every system -dnl call to check for EINTR (see SCM_SYSCALL) and do not attempt to -dnl change from the default behaviour. On the other hand, if signals -dnl are restartable then the loop is not installed and when libguile -dnl initialises it also resets the behaviour of each signal to cause a -dnl restart (in case a different runtime had a different default -dnl behaviour for some reason: e.g., different versions of linux seem -dnl to behave differently.) - -AC_SYS_RESTARTABLE_SYSCALLS - if test "$enable_regex" = yes; then if test "$ac_cv_header_regex_h" = yes || test "$ac_cv_header_rxposix_h" = yes || diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index cb19a7af8..2d64919a5 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1909,10 +1909,6 @@ for termination, not stopping. If a signal occurs while in a system call, deliver the signal then restart the system call (as opposed to returning an @code{EINTR} error from that call). - -Guile always enables this flag where available, no matter what -@var{flags} are specified. This avoids spurious error returns in low -level operations. @end defvar The return value is a pair with information about the old handler as diff --git a/guile-readline/configure.in b/guile-readline/configure.in index d05356618..f24fc9418 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -54,77 +54,6 @@ dnl install paren matching on the Guile command line (when using dnl readline for input), so it's completely optional. AC_CHECK_FUNCS(rl_get_keymap) -dnl Check for rl_pre_input_hook. This is more complicated because on -dnl some systems (HP/UX), the linker wont let us treat -dnl rl_pre_input_hook as a function when it really is a function -dnl pointer. - -AC_MSG_CHECKING([for rl_pre_input_hook]) -AC_CACHE_VAL(ac_cv_var_rl_pre_input_hook, -[AC_TRY_LINK([ -#include -#include -], [ -rl_pre_input_hook = 0; -], -ac_cv_var_rl_pre_input_hook=yes, -ac_cv_var_rl_pre_input_hook=no)]) -AC_MSG_RESULT($ac_cv_var_rl_pre_input_hook) -if test $ac_cv_var_rl_pre_input_hook = yes; then - AC_DEFINE(HAVE_RL_PRE_INPUT_HOOK,1, - [Define if rl_pre_input_hook is available.]) -fi - - -AC_MSG_CHECKING(if readline clears SA_RESTART flag for SIGWINCH) -AC_CACHE_VAL(guile_cv_sigwinch_sa_restart_cleared, -AC_TRY_RUN([#include -#include -#include - -int -hook () -{ - struct sigaction action; - - sigaction (SIGWINCH, NULL, &action); - rl_cleanup_after_signal(); - - /* exit with 0 if readline disabled SA_RESTART */ - exit (action.sa_flags & SA_RESTART); -} - -int -main () -{ - struct sigaction action; - - sigaction (SIGWINCH, NULL, &action); - action.sa_flags |= SA_RESTART; - sigaction (SIGWINCH, &action, NULL); - - /* Give readline something to read. Otherwise, it might hang, for - example when run as a background process with job control. - */ - rl_instream = fopen ("/dev/null", "r"); - if (rl_instream == NULL) - { - perror ("/dev/null"); - exit (1); - } - - rl_pre_input_hook = hook; - readline (""); -}], -guile_cv_sigwinch_sa_restart_cleared=yes, -guile_cv_sigwinch_sa_restart_cleared=no, -guile_cv_sigwinch_sa_restart_cleared=yes)) -AC_MSG_RESULT($guile_cv_sigwinch_sa_restart_cleared) -if test $guile_cv_sigwinch_sa_restart_cleared = yes; then - AC_DEFINE(GUILE_SIGWINCH_SA_RESTART_CLEARED, 1, - [Define if readline disables SA_RESTART.]) -fi - AC_CACHE_CHECK([for rl_getc_function pointer in readline], ac_cv_var_rl_getc_function, [AC_TRY_LINK([ diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 84ae62260..7f86ceb3d 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -530,26 +530,6 @@ match_paren (int x, int k) } #endif /* HAVE_RL_GET_KEYMAP */ -#if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED) -/* Readline disables SA_RESTART on SIGWINCH. - * This code turns it back on. - */ -static int -sigwinch_enable_restart (void) -{ -#ifdef HAVE_SIGINTERRUPT - siginterrupt (SIGWINCH, 0); -#else - struct sigaction action; - - sigaction (SIGWINCH, NULL, &action); - action.sa_flags |= SA_RESTART; - sigaction (SIGWINCH, &action, NULL); -#endif - return 0; -} -#endif - #endif /* HAVE_RL_GETC_FUNCTION */ void @@ -569,9 +549,6 @@ scm_init_readline () #endif rl_basic_word_break_characters = "\t\n\"'`;()"; rl_readline_name = "Guile"; -#if defined (HAVE_RL_PRE_INPUT_HOOK) && defined (GUILE_SIGWINCH_SA_RESTART_CLEARED) - rl_pre_input_hook = sigwinch_enable_restart; -#endif reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ()); scm_init_opts (scm_readline_options, diff --git a/libguile/_scm.h b/libguile/_scm.h index 1a0a98603..429e87b7d 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -79,20 +79,6 @@ #include "libguile/modules.h" #include "libguile/inline.h" -/* SCM_SYSCALL retries system calls that have been interrupted (EINTR). - However this can be avoided if the operating system can restart - system calls automatically. We assume this is the case if - sigaction is available and SA_RESTART is defined; they will be used - when installing signal handlers. - */ - -#ifdef HAVE_RESTARTABLE_SYSCALLS -#if ! SCM_USE_PTHREAD_THREADS /* However, don't assume SA_RESTART - works with pthreads... */ -#define SCM_SYSCALL(line) line -#endif -#endif - #ifndef SCM_SYSCALL #ifdef vms # ifndef __GNUC__ diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 258710e51..f4772b7a2 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -306,10 +306,8 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, "a scheme procedure has been specified, that procedure will run\n" "in the given @var{thread}. When no thread has been given, the\n" "thread that made this call to @code{sigaction} is used.\n" - "Flags can " - "optionally be specified for the new handler (@code{SA_RESTART} will\n" - "always be added if it's available and the system is using restartable\n" - "system calls.) The return value is a pair with information about the\n" + "Flags can optionally be specified for the new handler.\n" + "The return value is a pair with information about the\n" "old handler as described above.\n\n" "This interface does not provide access to the \"signal blocking\"\n" "facility. Maybe this is not needed, since the thread support may\n" @@ -333,14 +331,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, csig = scm_to_signed_integer (signum, 0, NSIG-1); #if defined(HAVE_SIGACTION) -#if defined(SA_RESTART) && defined(HAVE_RESTARTABLE_SYSCALLS) - /* don't allow SA_RESTART to be omitted if HAVE_RESTARTABLE_SYSCALLS - is defined, since libguile would be likely to produce spurious - EINTR errors. */ - action.sa_flags = SA_RESTART; -#else action.sa_flags = 0; -#endif if (!SCM_UNBNDP (flags)) action.sa_flags |= scm_to_int (flags); sigemptyset (&action.sa_mask); @@ -713,29 +704,6 @@ scm_init_scmsigs () #else orig_handlers[i] = SIG_ERR; #endif - -#ifdef HAVE_RESTARTABLE_SYSCALLS - /* If HAVE_RESTARTABLE_SYSCALLS is defined, it's important that - signals really are restartable. don't rely on the same - run-time that configure got: reset the default for every signal. - */ -#ifdef HAVE_SIGINTERRUPT - siginterrupt (i, 0); -#elif defined(SA_RESTART) - { - struct sigaction action; - - sigaction (i, NULL, &action); - if (!(action.sa_flags & SA_RESTART)) - { - action.sa_flags |= SA_RESTART; - sigaction (i, &action, NULL); - } - } -#endif - /* if neither siginterrupt nor SA_RESTART are available we may - as well assume that signals are always restartable. */ -#endif } scm_c_define ("NSIG", scm_from_long (NSIG)); From a84673a68bfdb6f46235fc6aa1d60c418c28a2e5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 24 Jun 2009 13:42:59 +0200 Subject: [PATCH 260/375] remove lambda wrap hack of brainfuck tree-il compiler * module/language/brainfuck/compile-tree-il.scm (compile-tree-il): Remove the hack where we wrapped the compiled code in a `lambda', because not only should the tree-il compiler optimize that away, it was really papering around other inefficiencies, and obtuse to boot. --- module/language/brainfuck/compile-tree-il.scm | 23 ++++--------------- 1 file changed, 5 insertions(+), 18 deletions(-) diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm index 62987fc63..0aaa11274 100644 --- a/module/language/brainfuck/compile-tree-il.scm +++ b/module/language/brainfuck/compile-tree-il.scm @@ -49,12 +49,11 @@ ;; This compiles a whole brainfuck program. This constructs a Tree-IL ;; code equivalent to Scheme code like this: ;; -;; ((lambda () ;; (let ((pointer 0) ;; (tape (make-vector tape-size 0))) ;; (begin ;; -;; (write-char #\newline))))) +;; (write-char #\newline))) ;; ;; So first the pointer and tape variables are set up correctly, then the ;; program's body is executed in this context, and finally we output an @@ -69,17 +68,6 @@ ;; throw an error, whereas a number of Brainfuck compilers do not detect ;; this. ;; -;; We wrap the code in a lambda so that the body has a place to cache -;; the looked-up locations of the primitive functions: vector-ref et al. -;; This way we can use toplevel-ref instead of link-now + variable-ref. -;; See the VM documentation for more info on those instructions. -;; -;; Normally when compiling you don't have to think about this at all, -;; because the usual pattern is a bunch of definitions, then you call -;; those definitions -- so the real work is in the functions anyway, -;; which can use toplevel-ref. Here we just force that pattern into -;; effect. -;; ;; Note that we're generating the S-expression representation of ;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL ;; data structures. This makes the compiler more pleasant to look at, @@ -104,11 +92,10 @@ (define (compile-tree-il exp env opts) (values (parse-tree-il - `(apply (lambda () () - (let (pointer tape) (pointer tape) - ((const 0) - (apply (primitive make-vector) (const ,tape-size) (const 0))) - ,(compile-body exp))))) + `(let (pointer tape) (pointer tape) + ((const 0) + (apply (primitive make-vector) (const ,tape-size) (const 0))) + ,(compile-body exp))) env env)) From 60ed31d28bd2d27efd98bf25556b7c785c46da52 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 24 Jun 2009 15:14:00 +0200 Subject: [PATCH 261/375] allow primcall ops to push 0 values * libguile/objcodes.c (OBJCODE_COOKIE): Bump the objcode cookie. We'll be doing this on incompatible changes until 2.0. * libguile/vm-i-scheme.c (set_car, set_cdr, slot_set): These instructions don't have natural return values -- so declare them that way, that they push 0 values. * module/language/tree-il/compile-glil.scm (flatten): When compiling primitive calls, check `(instruction-pushes op)' to see how many values that instruction will push, and do something appropriate, instead of just assuming that all primcall ops push 1 value. --- libguile/objcodes.c | 4 ++-- libguile/vm-i-scheme.c | 27 +++++++++++++++--------- module/language/tree-il/compile-glil.scm | 19 +++++++++++++---- 3 files changed, 34 insertions(+), 16 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 6b69fb77f..fc59c09a4 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -34,7 +34,7 @@ #include "objcodes.h" /* nb, the length of the header should be a multiple of 8 bytes */ -#define OBJCODE_COOKIE "GOOF-0.5" +#define OBJCODE_COOKIE "GOOF-0.6" /* diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 02139c073..4fc026c48 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -131,20 +131,24 @@ VM_DEFINE_FUNCTION (92, cdr, "cdr", 1) RETURN (SCM_CDR (x)); } -VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2) +VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0) { - ARGS2 (x, y); + SCM x, y; + POP (y); + POP (x); VM_VALIDATE_CONS (x); SCM_SETCAR (x, y); - RETURN (SCM_UNSPECIFIED); + NEXT; } -VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2) +VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0) { - ARGS2 (x, y); + SCM x, y; + POP (y); + POP (x); VM_VALIDATE_CONS (x); SCM_SETCDR (x, y); - RETURN (SCM_UNSPECIFIED); + NEXT; } @@ -263,13 +267,16 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2) RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); } -VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3) +VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) { + SCM instance, idx, val; size_t slot; - ARGS3 (instance, idx, val); + POP (val); + POP (idx); + POP (instance); slot = SCM_I_INUM (idx); SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val); - RETURN (SCM_UNSPECIFIED); + NEXT; } /* diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 6dade3592..a75843d2f 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -22,6 +22,7 @@ #:use-module (system base syntax) #:use-module (ice-9 receive) #:use-module (language glil) + #:use-module (system vm instruction) #:use-module (language tree-il) #:use-module (language tree-il optimize) #:use-module (language tree-il analyze) @@ -305,10 +306,20 @@ => (lambda (op) (for-each comp-push args) (emit-code src (make-glil-call op (length args))) - (case context - ((tail) (emit-code #f (make-glil-call 'return 1))) - ((drop) (emit-code #f (make-glil-call 'drop 1)))))) - + (case (instruction-pushes op) + ((0) + (case context + ((tail) (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))) + ((push vals) (emit-code #f (make-glil-void))))) + ((1) + (case context + ((tail) (emit-code #f (make-glil-call 'return 1))) + ((drop) (emit-code #f (make-glil-call 'drop 1))))) + (else + (error "bad primitive op: too many pushes" + op (instruction-pushes op)))))) + (else (comp-push proc) (for-each comp-push args) From 376b6bd7a2d2484f5579645becc26c40a97c31a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 25 Jun 2009 22:45:12 +0200 Subject: [PATCH 262/375] Fix `load-objcode' FD/mapping leak occurring upon failure. * libguile/objcodes.c (make_objcode_by_mmap): Close FD and unmap ADDR upon failure. --- libguile/objcodes.c | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index fc59c09a4..03ea0b8d8 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -63,19 +63,31 @@ make_objcode_by_mmap (int fd) addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); if (addr == MAP_FAILED) - SCM_SYSERROR; + { + (void) close (fd); + SCM_SYSERROR; + } if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) - scm_misc_error (FUNC_NAME, "bad header on object file: ~s", - scm_list_1 (scm_from_locale_stringn - (addr, strlen (OBJCODE_COOKIE)))); + { + (void) close (fd); + (void) munmap (addr, st.st_size); + scm_misc_error (FUNC_NAME, "bad header on object file: ~s", + scm_list_1 (scm_from_locale_stringn + (addr, strlen (OBJCODE_COOKIE)))); + } data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE)); if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE))) - scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)", - scm_list_2 (scm_from_size_t (st.st_size), - scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); + { + (void) close (fd); + (void) munmap (addr, st.st_size); + scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)", + scm_list_2 (scm_from_size_t (st.st_size), + scm_from_uint32 (sizeof (*data) + data->len + + data->metalen))); + } SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE), SCM_PACK (SCM_BOOL_F), fd); From f1ce9199335bebab1a62286ac965f33dc91ca97f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 25 Jun 2009 23:32:44 +0200 Subject: [PATCH 263/375] Add `scm_t_off' type so that `scm_t_port' has a fixed layout. * libguile/gen-scmconfig.c (main): Produce a definition for `scm_t_off'. * libguile/ports.h (scm_t_port)[read_buf_size, saved_read_buf_size, write_buf_size, seek, truncate]: Use `scm_t_off' instead of `off_t' so that the layout and size of the structure does not depend on the application's `_FILE_OFFSET_BITS' value. Reported by Bill Schottstaedt, see http://lists.gnu.org/archive/html/bug-guile/2009-06/msg00018.html. (scm_set_port_seek, scm_set_port_truncate): Update. * libguile/ports.c (scm_set_port_seek, scm_set_port_truncate): Use `scm_t_off' and `off_t_or_off64_t'. * libguile/fports.c (fport_seek, fport_truncate): Use `scm_t_off' instead of `off_t'. * libguile/r6rs-ports.c (bip_seek, cbp_seek, bop_seek): Use `scm_t_off' instead of `off_t'. * libguile/rw.c (scm_write_string_partial): Likewise. * libguile/strports.c (st_resize_port, st_seek, st_truncate): Likewise. * doc/ref/api-io.texi (Port Implementation): Update prototype of `scm_set_port_seek ()' and `scm_set_port_truncate ()'. * NEWS: Update. --- NEWS | 5 +++++ doc/ref/api-io.texi | 4 ++-- libguile/fports.c | 12 ++++++------ libguile/gen-scmconfig.c | 18 ++++++++++++++++++ libguile/ports.c | 15 +++++++-------- libguile/ports.h | 20 +++++++++----------- libguile/r6rs-ports.c | 18 +++++++++--------- libguile/rw.c | 6 +++--- libguile/strports.c | 14 +++++++------- 9 files changed, 66 insertions(+), 46 deletions(-) diff --git a/NEWS b/NEWS index 5175a0900..a5980836e 100644 --- a/NEWS +++ b/NEWS @@ -511,6 +511,11 @@ This procedure corresponds to Scheme's `module-public-interface'. ** `scm_stat' has an additional argument, `exception_on_error' ** `scm_primitive_load_path' has an additional argument `exception_on_not_found' +** `scm_set_port_seek' and `scm_set_port_truncate' use the `scm_t_off' type + +Previously they would use the `off_t' type, which is fragile since its +definition depends on the application's value for `_FILE_OFFSET_BITS'. + * Changes to the distribution ** Guile's license is now LGPLv3+ diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 12c19b7dc..b0b57412a 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1531,7 +1531,7 @@ implementations take care to avoid this problem. The procedure is set using -@deftypefun void scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port, off_t offset, int whence)) +@deftypefun void scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM port, scm_t_off offset, int whence)) @end deftypefun @item truncate @@ -1539,7 +1539,7 @@ Truncate the port data to be specified length. It can be assumed that the current state of @code{rw_active} is @code{SCM_PORT_NEITHER}. Set using -@deftypefun void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length)) +@deftypefun void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, scm_t_off length)) @end deftypefun @end table diff --git a/libguile/fports.c b/libguile/fports.c index de788c928..f6e05566b 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -671,8 +671,8 @@ fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence) fport_seek already. */ #if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T -static off_t -fport_seek (SCM port, off_t offset, int whence) +static scm_t_off +fport_seek (SCM port, scm_t_off offset, int whence) { off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence); if (rv > OFF_T_MAX || rv < OFF_T_MIN) @@ -680,7 +680,7 @@ fport_seek (SCM port, off_t offset, int whence) errno = EOVERFLOW; scm_syserror ("fport_seek"); } - return (off_t) rv; + return (scm_t_off) rv; } #else @@ -696,7 +696,7 @@ scm_i_fport_seek (SCM port, SCM offset, int how) } static void -fport_truncate (SCM port, off_t length) +fport_truncate (SCM port, scm_t_off length) { scm_t_fport *fp = SCM_FSTREAM (port); @@ -748,7 +748,7 @@ fport_write (SCM port, const void *data, size_t size) } { - off_t space = pt->write_end - pt->write_pos; + scm_t_off space = pt->write_end - pt->write_pos; if (size <= space) { diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 85ebfaed7..98fcc885e 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -400,6 +400,24 @@ main (int argc, char *argv[]) pf ("#define SCM_HAVE_READDIR64_R 0 /* 0 or 1 */\n"); #endif + /* Arrange so that we have a file offset type that reflects the one + used when compiling Guile, regardless of what the application's + `_FILE_OFFSET_BITS' says. See + http://lists.gnu.org/archive/html/bug-guile/2009-06/msg00018.html + for the original bug report. + + Note that we can't define `scm_t_off' in terms of `off_t' or + `off64_t' because they may or may not be available depending on + how the application that uses Guile is compiled. */ + +#if defined GUILE_USE_64_CALLS && defined HAVE_STAT64 + pf ("typedef scm_t_int64 scm_t_off;\n"); +#elif SIZEOF_OFF_T == SIZEOF_INT + pf ("typedef int scm_t_off;\n"); +#else + pf ("typedef long int scm_t_off;\n"); +#endif + #if USE_DLL_IMPORT pf ("\n"); pf ("/* Define some additional CPP macros on Win32 platforms. */\n"); diff --git a/libguile/ports.c b/libguile/ports.c index 248e0a49c..98207b0dc 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -222,15 +222,14 @@ scm_set_port_close (scm_t_bits tc, int (*close) (SCM)) } void -scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port, - off_t OFFSET, - int WHENCE)) +scm_set_port_seek (scm_t_bits tc, + scm_t_off (*seek) (SCM, scm_t_off, int)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].seek = seek; } void -scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length)) +scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM, scm_t_off)) { scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate; } @@ -1399,15 +1398,15 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, else if (SCM_OPPORTP (fd_port)) { scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); - off_t off = scm_to_off_t (offset); - off_t rv; + off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); + off_t_or_off64_t rv; if (!ptob->seek) SCM_MISC_ERROR ("port is not seekable", scm_cons (fd_port, SCM_EOL)); else rv = ptob->seek (fd_port, off, how); - return scm_from_off_t (rv); + return scm_from_off_t_or_off64_t (rv); } else /* file descriptor?. */ { @@ -1496,7 +1495,7 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, } else if (SCM_OPOUTPORTP (object)) { - off_t c_length = scm_to_off_t (length); + off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); scm_t_port *pt = SCM_PTAB_ENTRY (object); scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); diff --git a/libguile/ports.h b/libguile/ports.h index 64a0a89c7..8a21b09f9 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -29,8 +29,6 @@ #include "libguile/struct.h" #include "libguile/threads.h" -/* Not sure if this is a good idea. We need it for off_t. */ -#include @@ -70,7 +68,7 @@ typedef struct unsigned char *read_buf; /* buffer start. */ const unsigned char *read_pos;/* the next unread char. */ unsigned char *read_end; /* pointer to last buffered char + 1. */ - off_t read_buf_size; /* size of the buffer. */ + scm_t_off read_buf_size; /* size of the buffer. */ /* when chars are put back into the buffer, e.g., using peek-char or unread-string, the read-buffer pointers are switched to cbuf. @@ -79,7 +77,7 @@ typedef struct unsigned char *saved_read_buf; const unsigned char *saved_read_pos; unsigned char *saved_read_end; - off_t saved_read_buf_size; + scm_t_off saved_read_buf_size; /* write requests are saved into this buffer at write_pos until it reaches write_buf + write_buf_size, then the ptob flush is @@ -88,7 +86,7 @@ typedef struct unsigned char *write_buf; /* buffer start. */ unsigned char *write_pos; /* pointer to last buffered char + 1. */ unsigned char *write_end; /* pointer to end of buffer + 1. */ - off_t write_buf_size; /* size of the buffer. */ + scm_t_off write_buf_size; /* size of the buffer. */ unsigned char shortbuf; /* buffer for "unbuffered" streams. */ @@ -185,8 +183,8 @@ typedef struct scm_t_ptob_descriptor int (*fill_input) (SCM port); int (*input_waiting) (SCM port); - off_t (*seek) (SCM port, off_t OFFSET, int WHENCE); - void (*truncate) (SCM port, off_t length); + scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); + void (*truncate) (SCM port, scm_t_off length); } scm_t_ptob_descriptor; @@ -224,12 +222,12 @@ SCM_API void scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset)); SCM_API void scm_set_port_seek (scm_t_bits tc, - off_t (*seek) (SCM port, - off_t OFFSET, - int WHENCE)); + scm_t_off (*seek) (SCM port, + scm_t_off OFFSET, + int WHENCE)); SCM_API void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, - off_t length)); + scm_t_off length)); SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)); SCM_API SCM scm_char_ready_p (SCM port); size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index d77c2147a..e3aa99e16 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -125,11 +125,11 @@ bip_fill_input (SCM port) return result; } -static off_t -bip_seek (SCM port, off_t offset, int whence) +static scm_t_off +bip_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "bip_seek" { - off_t c_result = 0; + scm_t_off c_result = 0; scm_t_port *c_port = SCM_PTAB_ENTRY (port); switch (whence) @@ -217,12 +217,12 @@ cbp_mark (SCM port) return SCM_BOOL_F; } -static off_t -cbp_seek (SCM port, off_t offset, int whence) +static scm_t_off +cbp_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "cbp_seek" { SCM result; - off_t c_result = 0; + scm_t_off c_result = 0; switch (whence) { @@ -885,8 +885,8 @@ bop_write (SCM port, const void *data, size_t size) buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; } -static off_t -bop_seek (SCM port, off_t offset, int whence) +static scm_t_off +bop_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "bop_seek" { scm_t_bop_buffer *buf; @@ -895,7 +895,7 @@ bop_seek (SCM port, off_t offset, int whence) switch (whence) { case SEEK_CUR: - offset += (off_t) buf->pos; + offset += (scm_t_off) buf->pos; /* Fall through. */ case SEEK_SET: diff --git a/libguile/rw.c b/libguile/rw.c index f6d314275..cb62b79b9 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -207,7 +207,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, #define FUNC_NAME s_scm_write_string_partial { const char *src; - long write_len; + scm_t_off write_len; int fdes; { @@ -232,7 +232,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, SCM port = (SCM_UNBNDP (port_or_fdes)? scm_current_output_port () : port_or_fdes); scm_t_port *pt; - off_t space; + scm_t_off space; SCM_VALIDATE_OPFPORT (2, port); SCM_VALIDATE_OUTPUT_PORT (2, port); diff --git a/libguile/strports.c b/libguile/strports.c index 3f8a22e7d..5c67bf9a8 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -108,7 +108,7 @@ stfill_buffer (SCM port) /* change the size of a port's string to new_size. this doesn't change read_buf_size. */ static void -st_resize_port (scm_t_port *pt, off_t new_size) +st_resize_port (scm_t_port *pt, scm_t_off new_size) { SCM old_stream = SCM_PACK (pt->stream); const char *src = scm_i_string_chars (old_stream); @@ -118,7 +118,7 @@ st_resize_port (scm_t_port *pt, off_t new_size) unsigned long int min_size = min (old_size, new_size); unsigned long int i; - off_t index = pt->write_pos - pt->write_buf; + scm_t_off index = pt->write_pos - pt->write_buf; pt->write_buf_size = new_size; @@ -199,11 +199,11 @@ st_end_input (SCM port, int offset) pt->rw_active = SCM_PORT_NEITHER; } -static off_t -st_seek (SCM port, off_t offset, int whence) +static scm_t_off +st_seek (SCM port, scm_t_off offset, int whence) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - off_t target; + scm_t_off target; if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR) /* special case to avoid disturbing the unread-char buffer. */ @@ -272,7 +272,7 @@ st_seek (SCM port, off_t offset, int whence) } static void -st_truncate (SCM port, off_t length) +st_truncate (SCM port, scm_t_off length) { scm_t_port *pt = SCM_PTAB_ENTRY (port); From e33779e3b84b4822b4d51562d7c4f1e65408151d Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 25 Jun 2009 23:24:57 +0100 Subject: [PATCH 264/375] Revert "* FAQ: New file." This reverts commit d53f85dd859fa69af8a0b67482774d2a88aaf407. It was a confusing mistake to create an FAQ file in the Guile repository/distribution, because there was already an FAQ page on the Guile web site. The information that was in the FAQ file is now in the FAQ web page. --- FAQ | 19 ------------------- Makefile.am | 2 +- NEWS | 7 ------- 3 files changed, 1 insertion(+), 27 deletions(-) delete mode 100644 FAQ diff --git a/FAQ b/FAQ deleted file mode 100644 index 2ff6cad50..000000000 --- a/FAQ +++ /dev/null @@ -1,19 +0,0 @@ -Guile FAQ -*- outline -*- - -* Build problems - -** readline.c: error: `rl_pending_input' undeclared - -This occurs if the Readline library detected by Guile's configure -script is actually the BSD Editline project's supposedly -Readline-compatible library. The immediate fix is to uninstall -Editline and install the real GNU Readline instead. When you do this, -please note that it probably won't work to keep Editline in /usr and -install GNU Readline in /usr/local (or some similar arrangement), -because the Editline library will then still be picked up at link and -run time; it's best (subject to other constraints) to remove Editline -completely. - -For the longer term, please also report this problem to the Editline -project, to encourage them to fix it in the next release of their -Readline compatibility library. diff --git a/Makefile.am b/Makefile.am index c0fd8c337..4562dddf3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -31,7 +31,7 @@ SUBDIRS = lib meta libguile guile-readline emacs \ include_HEADERS = libguile.h EXTRA_DIST = LICENSE HACKING GUILE-VERSION \ - m4/ChangeLog-2008 FAQ \ + m4/ChangeLog-2008 \ m4/autobuild.m4 ChangeLog-2008 TESTS = check-guile diff --git a/NEWS b/NEWS index a5980836e..593d6c27a 100644 --- a/NEWS +++ b/NEWS @@ -688,13 +688,6 @@ lead to a stack overflow. ** Fixed shadowing of libc's on Tru64, which broke compilation ** Make sure all tests honor `$TMPDIR' -* Changes to the distribution - -** New FAQ - -We've started collecting Frequently Asked Questions (FAQ), and will -distribute these (with answers!) in future Guile releases. - Changes in 1.8.4 (since 1.8.3) From 5fa2deb3f715502866775a7e912dc66e3b6571ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 24 Jun 2009 23:44:03 +0200 Subject: [PATCH 265/375] minor doc tweaks * doc/ref/api-compound.texi: Generalized vector doc fixups. * doc/ref/api-data.texi: Minor fixes to bytevector docs. --- doc/ref/api-compound.texi | 6 +++--- doc/ref/api-data.texi | 34 ++++++++++++++++++---------------- 2 files changed, 21 insertions(+), 19 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 8d0e02f20..b3997efd7 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1651,16 +1651,16 @@ and writing. Guile has a number of data types that are generally vector-like: strings, uniform numeric vectors, bytevectors, bitvectors, and of course ordinary vectors of arbitrary Scheme values. These types are disjoint: -a Scheme value belongs to at most one of the four types listed above. +a Scheme value belongs to at most one of the five types listed above. If you want to gloss over this distinction and want to treat all four types with common code, you can use the procedures in this section. They work with the @emph{generalized vector} type, which is the union -of the four vector-like types. +of the five vector-like types. @deffn {Scheme Procedure} generalized-vector? obj @deffnx {C Function} scm_generalized_vector_p (obj) -Return @code{#t} if @var{obj} is a vector, string, +Return @code{#t} if @var{obj} is a vector, bytevector, string, bitvector, or uniform numeric vector. @end deffn diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 4401ef1cf..6e1a67ae1 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -3755,7 +3755,7 @@ stored and you probably need to try again with a larger buffer. A @dfn{bytevector} is a raw bit string. The @code{(rnrs bytevector)} module provides the programming interface specified by the -@uref{http://www.r6rs.org/, Revised Report^6 on the Algorithmic Language +@uref{http://www.r6rs.org/, Revised^6 Report on the Algorithmic Language Scheme (R6RS)}. It contains procedures to manipulate bytevectors and interpret their contents in a number of ways: bytevector contents can be accessed as signed or unsigned integer of various sizes and endianness, @@ -3800,18 +3800,20 @@ R6RS (@pxref{R6RS I/O Ports}). @cindex word order Some of the following procedures take an @var{endianness} parameter. -The @dfn{endianness} is defined is defined as the order of bytes in -multi-byte numbers: numbers encoded in @dfn{big endian} have their most -significant bytes written first, whereas numbers encoded in @dfn{little -endian} have their least significant bytes first@footnote{Big and little -endian are the most common ``endiannesses'' but others exist. For -instance, the GNU MP library allows @dfn{word order} to be specified -independently of @dfn{byte order} (@pxref{Integer Import and Export,,, -gmp, The GNU Multiple Precision Arithmetic Library Manual}).} Little -endian is the native endianness of the IA32 architecture and its -derivatives, while big endian is native to SPARC and PowerPC, among -others. The @code{native-endianness} procedure returns the native -endianness of the machine it runs on. +The @dfn{endianness} is defined as the order of bytes in multi-byte +numbers: numbers encoded in @dfn{big endian} have their most +significant bytes written first, whereas numbers encoded in +@dfn{little endian} have their least significant bytes +first@footnote{Big-endian and little-endian are the most common +``endiannesses'', but others do exist. For instance, the GNU MP +library allows @dfn{word order} to be specified independently of +@dfn{byte order} (@pxref{Integer Import and Export,,, gmp, The GNU +Multiple Precision Arithmetic Library Manual}).}. + +Little-endian is the native endianness of the IA32 architecture and +its derivatives, while big-endian is native to SPARC and PowerPC, +among others. The @code{native-endianness} procedure returns the +native endianness of the machine it runs on. @deffn {Scheme Procedure} native-endianness @deffnx {C Function} scm_native_endianness () @@ -3820,13 +3822,13 @@ Return a value denoting the native endianness of the host machine. @deffn {Scheme Macro} endianness symbol Return an object denoting the endianness specified by @var{symbol}. If -@var{symbol} is neither @code{big} nor @code{little} then a compile-time -error is raised. +@var{symbol} is neither @code{big} nor @code{little} then an error is +raised at expand-time. @end deffn @defvr {C Variable} scm_endianness_big @defvrx {C Variable} scm_endianness_little -The objects denoting big (resp. little) endianness. +The objects denoting big- and little-endianness, respectively. @end defvr From caa92f5e951528c1ea31b2eea8b388e9888fa19e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 24 Jun 2009 23:46:42 +0200 Subject: [PATCH 266/375] bytevectors provide scm_i_native_endianness to the vm * libguile/bytevectors.h (scm_i_native_endianness): Allow the VM to use scm_i_native_endianness, but still keep it marked as internal. * libguile/bytevectors.c: Adjust to use scm_i_native_endianness instead of native_endianness. Define it at bootstrap time. --- libguile/bytevectors.c | 62 +++++++++++++++++++++--------------------- libguile/bytevectors.h | 3 ++ 2 files changed, 34 insertions(+), 31 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index fd9043ad1..24afd2414 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -88,22 +88,22 @@ scm_out_of_range (FUNC_NAME, index); /* Template for fixed-size integer access (only 8, 16 or 32-bit). */ -#define INTEGER_REF(_len, _sign) \ - SCM result; \ - \ - INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ - SCM_VALIDATE_SYMBOL (3, endianness); \ - \ - { \ - INT_TYPE (_len, _sign) c_result; \ - \ - memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ - if (!scm_is_eq (endianness, native_endianness)) \ - c_result = INT_SWAP (_len) (c_result); \ - \ - result = SCM_I_MAKINUM (c_result); \ - } \ - \ +#define INTEGER_REF(_len, _sign) \ + SCM result; \ + \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + { \ + INT_TYPE (_len, _sign) c_result; \ + \ + memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ + if (!scm_is_eq (endianness, scm_i_native_endianness)) \ + c_result = INT_SWAP (_len) (c_result); \ + \ + result = SCM_I_MAKINUM (c_result); \ + } \ + \ return result; /* Template for fixed-size integer access using the native endianness. */ @@ -138,7 +138,7 @@ scm_out_of_range (FUNC_NAME, value); \ \ c_value_short = (INT_TYPE (_len, _sign)) c_value; \ - if (!scm_is_eq (endianness, native_endianness)) \ + if (!scm_is_eq (endianness, scm_i_native_endianness)) \ c_value_short = INT_SWAP (_len) (c_value_short); \ \ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ @@ -398,7 +398,7 @@ SCM_SYMBOL (scm_sym_little, "little"); SCM scm_endianness_big, scm_endianness_little; /* Host endianness (a symbol). */ -static SCM native_endianness = SCM_UNSPECIFIED; +SCM scm_i_native_endianness = SCM_UNSPECIFIED; /* Byte-swapping. */ #ifndef bswap_24 @@ -414,7 +414,7 @@ SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0, "Return a symbol denoting the machine's native endianness.") #define FUNC_NAME s_scm_native_endianness { - return native_endianness; + return scm_i_native_endianness; } #undef FUNC_NAME @@ -868,7 +868,7 @@ bytevector_large_set (char *c_bv, size_t c_size, int signed_p, int swap; \ _sign int value; \ \ - swap = !scm_is_eq (endianness, native_endianness); \ + swap = !scm_is_eq (endianness, scm_i_native_endianness); \ switch (c_size) \ { \ case 1: \ @@ -943,7 +943,7 @@ bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness) int swap; \ INT_TYPE (16, _sign) c_value16; \ \ - swap = !scm_is_eq (endianness, native_endianness); \ + swap = !scm_is_eq (endianness, scm_i_native_endianness); \ \ if (swap) \ c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \ @@ -1293,7 +1293,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ - SIGNEDNESS (_sign), native_endianness)); + SIGNEDNESS (_sign), scm_i_native_endianness)); #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \ int err; \ @@ -1301,7 +1301,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", \ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ SIGNEDNESS (_sign), value, \ - native_endianness); \ + scm_i_native_endianness); \ if (SCM_UNLIKELY (err)) \ scm_out_of_range (FUNC_NAME, value); \ \ @@ -1640,7 +1640,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) IEEE754_ACCESSOR_PROLOGUE (_type); \ SCM_VALIDATE_SYMBOL (3, endianness); \ \ - if (scm_is_eq (endianness, native_endianness)) \ + if (scm_is_eq (endianness, scm_i_native_endianness)) \ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ else \ { \ @@ -1669,7 +1669,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) SCM_VALIDATE_SYMBOL (4, endianness); \ c_value = IEEE754_FROM_SCM (_type) (value); \ \ - if (scm_is_eq (endianness, native_endianness)) \ + if (scm_is_eq (endianness, scm_i_native_endianness)) \ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \ else \ { \ @@ -2075,6 +2075,12 @@ scm_bootstrap_bytevectors (void) scm_null_bytevector = scm_gc_protect_object (make_bytevector_from_buffer (0, NULL)); +#ifdef WORDS_BIGENDIAN + scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("big")); +#else + scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("little")); +#endif + scm_c_register_extension ("libguile", "scm_init_bytevectors", (scm_t_extension_init_func) scm_init_bytevectors, NULL); @@ -2085,12 +2091,6 @@ scm_init_bytevectors (void) { #include "libguile/bytevectors.x" -#ifdef WORDS_BIGENDIAN - native_endianness = scm_sym_big; -#else - native_endianness = scm_sym_little; -#endif - scm_endianness_big = scm_sym_big; scm_endianness_little = scm_sym_little; } diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index 903ce7ae3..cb2726251 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -116,6 +116,8 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM); i.e., without allocating memory beside the SMOB itself (a double cell). This optimization is necessary since small bytevectors are expected to be common. */ +#define SCM_BYTEVECTOR_P(_bv) \ + SCM_SMOB_PREDICATE (scm_tc16_bytevector, _bv) #define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM)) #define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \ ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD) @@ -129,6 +131,7 @@ SCM_INTERNAL void scm_bootstrap_bytevectors (void); SCM_INTERNAL void scm_init_bytevectors (void); SCM_INTERNAL scm_t_bits scm_tc16_bytevector; +SCM_INTERNAL SCM scm_i_native_endianness; SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t); #define scm_c_shrink_bytevector(_bv, _len) \ From e6eb2467164de264c313af92d488144d2cdae94c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 24 Jun 2009 23:49:11 +0200 Subject: [PATCH 267/375] add bytevector ops to the vm * libguile/instructions.h (SCM_VM_NUM_INSTRUCTIONS): Enlarge to 255. Not sure what performance effects this will have. * libguile/vm-engine.c: Add new error case, vm_error_not_a_bytevector. * libguile/vm-engine.h: Don't assign specific registers for i386. Having added the new VM vector ops, GCC 4.4 is erroring for me now. * libguile/vm-i-scheme.c: Add bytevector-specific ops to the VM. We don't actually use them yet, though. --- libguile/instructions.h | 4 +- libguile/vm-engine.c | 8 +- libguile/vm-engine.h | 12 +-- libguile/vm-i-scheme.c | 217 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 230 insertions(+), 11 deletions(-) diff --git a/libguile/instructions.h b/libguile/instructions.h index c9fe6e995..d081b3efb 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -21,7 +21,7 @@ #include -#define SCM_VM_NUM_INSTRUCTIONS (1<<7) +#define SCM_VM_NUM_INSTRUCTIONS (1<<8) #define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1) enum scm_opcode { diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 978d4079b..90cf697f8 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -203,6 +203,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* shouldn't get here */ goto vm_error; + vm_error_not_a_bytevector: + SYNC_ALL (); + scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "bytevector"); + /* shouldn't get here */ + goto vm_error; + vm_error_no_values: err_msg = scm_from_locale_string ("VM: 0-valued return"); finish_args = SCM_EOL; diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index c98dfdd78..d6849799c 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -54,13 +54,9 @@ #endif #endif #ifdef __i386__ -/* gcc on lenny actually crashes if we allocate these variables in registers. - hopefully this is the only one of these. */ -#if !(__GNUC__==4 && __GNUC_MINOR__==1 && __GNUC_PATCHLEVEL__==2) -#define IP_REG asm("%esi") -#define SP_REG asm("%edi") -#define FP_REG -#endif +/* too few registers! because of register allocation errors with various gcs, + just punt on explicit assignments on i386, hoping that the "register" + declaration will be sufficient. */ #endif #if defined(PPC) || defined(_POWER) || defined(_IBMR2) #define IP_REG asm("26") diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 4fc026c48..e074d36a0 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -279,6 +279,223 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) NEXT; } +#define VM_VALIDATE_BYTEVECTOR(x) \ + if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \ + { finish_args = x; \ + goto vm_error_not_a_bytevector; \ + } + +#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \ +{ \ + SCM endianness; \ + POP (endianness); \ + if (scm_is_eq (endianness, scm_i_native_endianness)) \ + goto VM_LABEL (bv_##stem##_native_ref); \ + { \ + ARGS2 (bv, idx); \ + RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \ + } \ +} + +VM_DEFINE_FUNCTION (109, bv_u16_ref, "bv-u16-ref", 3) +BV_REF_WITH_ENDIANNESS (u16, u16) +VM_DEFINE_FUNCTION (110, bv_s16_ref, "bv-s16-ref", 3) +BV_REF_WITH_ENDIANNESS (s16, s16) +VM_DEFINE_FUNCTION (111, bv_u32_ref, "bv-u32-ref", 3) +BV_REF_WITH_ENDIANNESS (u32, u32) +VM_DEFINE_FUNCTION (112, bv_s32_ref, "bv-s32-ref", 3) +BV_REF_WITH_ENDIANNESS (s32, s32) +VM_DEFINE_FUNCTION (113, bv_u64_ref, "bv-u64-ref", 3) +BV_REF_WITH_ENDIANNESS (u64, u64) +VM_DEFINE_FUNCTION (114, bv_s64_ref, "bv-s64-ref", 3) +BV_REF_WITH_ENDIANNESS (s64, s64) +VM_DEFINE_FUNCTION (115, bv_f32_ref, "bv-f32-ref", 3) +BV_REF_WITH_ENDIANNESS (f32, ieee_single) +VM_DEFINE_FUNCTION (116, bv_f64_ref, "bv-f64-ref", 3) +BV_REF_WITH_ENDIANNESS (f64, ieee_double) + +#undef BV_REF_WITH_ENDIANNESS + +#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \ +{ \ + long i; \ + ARGS2 (bv, idx); \ + VM_VALIDATE_BYTEVECTOR (bv); \ + if (SCM_LIKELY (SCM_I_INUMP (idx) \ + && ((i = SCM_INUM (idx)) >= 0) \ + && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i % size == 0))) \ + RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \ + (SCM_BYTEVECTOR_CONTENTS (bv) + i))); \ + else \ + RETURN (scm_bytevector_##fn_stem##_ref (bv, idx)); \ +} + +#define BV_INT_REF(stem, type, size) \ +{ \ + long i; \ + ARGS2 (bv, idx); \ + VM_VALIDATE_BYTEVECTOR (bv); \ + if (SCM_LIKELY (SCM_I_INUMP (idx) \ + && ((i = SCM_INUM (idx)) >= 0) \ + && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i % size == 0))) \ + { scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \ + if (SCM_FIXABLE (x)) \ + RETURN (SCM_I_MAKINUM (x)); \ + else \ + RETURN (scm_from_##type (x)); \ + } \ + else \ + RETURN (scm_bytevector_##stem##_native_ref (bv, idx)); \ +} + +#define BV_FLOAT_REF(stem, fn_stem, type, size) \ +{ \ + long i; \ + ARGS2 (bv, idx); \ + VM_VALIDATE_BYTEVECTOR (bv); \ + if (SCM_LIKELY (SCM_I_INUMP (idx) \ + && ((i = SCM_INUM (idx)) >= 0) \ + && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i % size == 0))) \ + RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \ + else \ + RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \ +} + +VM_DEFINE_FUNCTION (117, bv_u8_ref, "bv-u8-ref", 2) +BV_FIXABLE_INT_REF (u8, u8, uint8, 1) +VM_DEFINE_FUNCTION (118, bv_s8_ref, "bv-s8-ref", 2) +BV_FIXABLE_INT_REF (s8, s8, int8, 1) +VM_DEFINE_FUNCTION (119, bv_u16_native_ref, "bv-u16-native-ref", 2) +BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) +VM_DEFINE_FUNCTION (120, bv_s16_native_ref, "bv-s16-native-ref", 2) +BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) +VM_DEFINE_FUNCTION (121, bv_u32_native_ref, "bv-u32-native-ref", 2) +/* FIXME: u32 is always a fixnum on 64-bit builds */ +BV_INT_REF (u32, uint32, 4) +VM_DEFINE_FUNCTION (122, bv_s32_native_ref, "bv-s32-native-ref", 2) +BV_INT_REF (s32, int32, 4) +VM_DEFINE_FUNCTION (123, bv_u64_native_ref, "bv-u64-native-ref", 2) +BV_INT_REF (u64, uint64, 8) +VM_DEFINE_FUNCTION (124, bv_s64_native_ref, "bv-s64-native-ref", 2) +BV_INT_REF (s64, int64, 8) +VM_DEFINE_FUNCTION (125, bv_f32_native_ref, "bv-f32-native-ref", 2) +BV_FLOAT_REF (f32, ieee_single, float, 4) +VM_DEFINE_FUNCTION (126, bv_f64_native_ref, "bv-f64-native-ref", 2) +BV_FLOAT_REF (f64, ieee_double, double, 8) + +#undef BV_FIXABLE_INT_REF +#undef BV_INT_REF +#undef BV_FLOAT_REF + + + +#define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \ +{ \ + SCM endianness; \ + POP (endianness); \ + if (scm_is_eq (endianness, scm_i_native_endianness)) \ + goto VM_LABEL (bv_##stem##_native_set); \ + { \ + ARGS3 (bv, idx, val); \ + RETURN (scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness)); \ + } \ +} + +VM_DEFINE_FUNCTION (127, bv_u16_set, "bv-u16-set", 4) +BV_SET_WITH_ENDIANNESS (u16, u16) +VM_DEFINE_FUNCTION (128, bv_s16_set, "bv-s16-set", 4) +BV_SET_WITH_ENDIANNESS (s16, s16) +VM_DEFINE_FUNCTION (129, bv_u32_set, "bv-u32-set", 4) +BV_SET_WITH_ENDIANNESS (u32, u32) +VM_DEFINE_FUNCTION (130, bv_s32_set, "bv-s32-set", 4) +BV_SET_WITH_ENDIANNESS (s32, s32) +VM_DEFINE_FUNCTION (131, bv_u64_set, "bv-u64-set", 4) +BV_SET_WITH_ENDIANNESS (u64, u64) +VM_DEFINE_FUNCTION (132, bv_s64_set, "bv-s64-set", 4) +BV_SET_WITH_ENDIANNESS (s64, s64) +VM_DEFINE_FUNCTION (133, bv_f32_set, "bv-f32-set", 4) +BV_SET_WITH_ENDIANNESS (f32, ieee_single) +VM_DEFINE_FUNCTION (134, bv_f64_set, "bv-f64-set", 4) +BV_SET_WITH_ENDIANNESS (f64, ieee_double) + +#undef BV_SET_WITH_ENDIANNESS + +#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \ +{ \ + long i, j; \ + ARGS3 (bv, idx, val); \ + VM_VALIDATE_BYTEVECTOR (bv); \ + if (SCM_LIKELY (SCM_I_INUMP (idx) \ + && ((i = SCM_INUM (idx)) >= 0) \ + && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i % size == 0) \ + && (SCM_I_INUMP (val)) \ + && ((j = SCM_INUM (val)) >= min) \ + && (j <= max))) \ + *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = (scm_t_##type)j; \ + else \ + scm_bytevector_##fn_stem##_set_x (bv, idx, val); \ + NEXT; \ +} + +#define BV_INT_SET(stem, type, size) \ +{ \ + long i; \ + ARGS3 (bv, idx, val); \ + VM_VALIDATE_BYTEVECTOR (bv); \ + if (SCM_LIKELY (SCM_I_INUMP (idx) \ + && ((i = SCM_INUM (idx)) >= 0) \ + && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i % size == 0))) \ + *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_##type (val); \ + else \ + scm_bytevector_##stem##_native_set_x (bv, idx, val); \ + NEXT; \ +} + +#define BV_FLOAT_SET(stem, fn_stem, type, size) \ +{ \ + long i; \ + ARGS3 (bv, idx, val); \ + VM_VALIDATE_BYTEVECTOR (bv); \ + if (SCM_LIKELY (SCM_I_INUMP (idx) \ + && ((i = SCM_INUM (idx)) >= 0) \ + && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i % size == 0))) \ + *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val); \ + else \ + scm_bytevector_##fn_stem##_native_set_x (bv, idx, val); \ +} + +VM_DEFINE_FUNCTION (135, bv_u8_set, "bv-u8-set", 3) +BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) +VM_DEFINE_FUNCTION (136, bv_s8_set, "bv-s8-set", 3) +BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) +VM_DEFINE_FUNCTION (137, bv_u16_native_set, "bv-u16-native-set", 3) +BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 3) +VM_DEFINE_FUNCTION (138, bv_s16_native_set, "bv-s16-native-set", 3) +BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 3) +VM_DEFINE_FUNCTION (139, bv_u32_native_set, "bv-u32-native-set", 3) +/* FIXME: u32 is always a fixnum on 64-bit builds */ +BV_INT_SET (u32, uint32, 4) +VM_DEFINE_FUNCTION (140, bv_s32_native_set, "bv-s32-native-set", 3) +BV_INT_SET (s32, int32, 4) +VM_DEFINE_FUNCTION (141, bv_u64_native_set, "bv-u64-native-set", 3) +BV_INT_SET (u64, uint64, 8) +VM_DEFINE_FUNCTION (142, bv_s64_native_set, "bv-s64-native-set", 3) +BV_INT_SET (s64, int64, 8) +VM_DEFINE_FUNCTION (143, bv_f32_native_set, "bv-f32-native-set", 3) +BV_FLOAT_SET (f32, ieee_single, float, 4) +VM_DEFINE_FUNCTION (144, bv_f64_native_set, "bv-f64-native-set", 3) +BV_FLOAT_SET (f64, ieee_double, double, 8) + +#undef BV_FIXABLE_INT_SET +#undef BV_INT_SET +#undef BV_FLOAT_SET + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" From d6f1ce3d1627e27c2262cb8da15828d515050fd6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 26 Jun 2009 00:15:37 +0200 Subject: [PATCH 268/375] vector-ref and vector-set! now have opcodes * module/language/tree-il/primitives.scm (*interesting-primitive-names*): Resolve vector-ref and vector-set!. * module/language/tree-il/compile-glil.scm (*primcall-ops*): And compile vector-ref and vector-set! to their opcodes. * libguile/vm-i-scheme.c (vector-ref, vector-set): New opcodes, placed before the bytevector ops. The renumbering shouldn't affect anyone, given that the bytevector ops were not yet used. Fix a few bugs in the bytevector ops. --- libguile/vm-i-scheme.c | 123 ++++++++++++++--------- module/language/tree-il/compile-glil.scm | 5 +- module/language/tree-il/primitives.scm | 4 +- 3 files changed, 83 insertions(+), 49 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index e074d36a0..0039d92cd 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -279,6 +279,34 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) NEXT; } +VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) +{ + long i; + ARGS2 (vect, idx); + if (SCM_LIKELY (SCM_I_IS_VECTOR (vect) + && SCM_I_INUMP (idx) + && ((i = SCM_I_INUM (idx)) >= 0) + && i < SCM_I_VECTOR_LENGTH (vect))) + RETURN (SCM_I_VECTOR_ELTS (vect)[i]); + else + RETURN (scm_vector_ref (vect, idx)); +} + +VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0) +{ + long i; + SCM vect, idx, val; + POP (val); POP (idx); POP (vect); + if (SCM_LIKELY (SCM_I_IS_VECTOR (vect) + && SCM_I_INUMP (idx) + && ((i = SCM_I_INUM (idx)) >= 0) + && i < SCM_I_VECTOR_LENGTH (vect))) + SCM_I_VECTOR_WELTS (vect)[i] = val; + else + scm_vector_set_x (vect, idx, val); + NEXT; +} + #define VM_VALIDATE_BYTEVECTOR(x) \ if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \ { finish_args = x; \ @@ -297,21 +325,21 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) } \ } -VM_DEFINE_FUNCTION (109, bv_u16_ref, "bv-u16-ref", 3) +VM_DEFINE_FUNCTION (111, bv_u16_ref, "bv-u16-ref", 3) BV_REF_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (110, bv_s16_ref, "bv-s16-ref", 3) +VM_DEFINE_FUNCTION (112, bv_s16_ref, "bv-s16-ref", 3) BV_REF_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (111, bv_u32_ref, "bv-u32-ref", 3) +VM_DEFINE_FUNCTION (113, bv_u32_ref, "bv-u32-ref", 3) BV_REF_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (112, bv_s32_ref, "bv-s32-ref", 3) +VM_DEFINE_FUNCTION (114, bv_s32_ref, "bv-s32-ref", 3) BV_REF_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (113, bv_u64_ref, "bv-u64-ref", 3) +VM_DEFINE_FUNCTION (115, bv_u64_ref, "bv-u64-ref", 3) BV_REF_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (114, bv_s64_ref, "bv-s64-ref", 3) +VM_DEFINE_FUNCTION (116, bv_s64_ref, "bv-s64-ref", 3) BV_REF_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (115, bv_f32_ref, "bv-f32-ref", 3) +VM_DEFINE_FUNCTION (117, bv_f32_ref, "bv-f32-ref", 3) BV_REF_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (116, bv_f64_ref, "bv-f64-ref", 3) +VM_DEFINE_FUNCTION (118, bv_f64_ref, "bv-f64-ref", 3) BV_REF_WITH_ENDIANNESS (f64, ieee_double) #undef BV_REF_WITH_ENDIANNESS @@ -322,7 +350,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \ @@ -337,7 +365,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ { scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \ @@ -356,7 +384,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \ @@ -364,26 +392,26 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \ } -VM_DEFINE_FUNCTION (117, bv_u8_ref, "bv-u8-ref", 2) +VM_DEFINE_FUNCTION (119, bv_u8_ref, "bv-u8-ref", 2) BV_FIXABLE_INT_REF (u8, u8, uint8, 1) -VM_DEFINE_FUNCTION (118, bv_s8_ref, "bv-s8-ref", 2) +VM_DEFINE_FUNCTION (120, bv_s8_ref, "bv-s8-ref", 2) BV_FIXABLE_INT_REF (s8, s8, int8, 1) -VM_DEFINE_FUNCTION (119, bv_u16_native_ref, "bv-u16-native-ref", 2) +VM_DEFINE_FUNCTION (121, bv_u16_native_ref, "bv-u16-native-ref", 2) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) -VM_DEFINE_FUNCTION (120, bv_s16_native_ref, "bv-s16-native-ref", 2) +VM_DEFINE_FUNCTION (122, bv_s16_native_ref, "bv-s16-native-ref", 2) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) -VM_DEFINE_FUNCTION (121, bv_u32_native_ref, "bv-u32-native-ref", 2) +VM_DEFINE_FUNCTION (123, bv_u32_native_ref, "bv-u32-native-ref", 2) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_REF (u32, uint32, 4) -VM_DEFINE_FUNCTION (122, bv_s32_native_ref, "bv-s32-native-ref", 2) +VM_DEFINE_FUNCTION (124, bv_s32_native_ref, "bv-s32-native-ref", 2) BV_INT_REF (s32, int32, 4) -VM_DEFINE_FUNCTION (123, bv_u64_native_ref, "bv-u64-native-ref", 2) +VM_DEFINE_FUNCTION (125, bv_u64_native_ref, "bv-u64-native-ref", 2) BV_INT_REF (u64, uint64, 8) -VM_DEFINE_FUNCTION (124, bv_s64_native_ref, "bv-s64-native-ref", 2) +VM_DEFINE_FUNCTION (126, bv_s64_native_ref, "bv-s64-native-ref", 2) BV_INT_REF (s64, int64, 8) -VM_DEFINE_FUNCTION (125, bv_f32_native_ref, "bv-f32-native-ref", 2) +VM_DEFINE_FUNCTION (127, bv_f32_native_ref, "bv-f32-native-ref", 2) BV_FLOAT_REF (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (126, bv_f64_native_ref, "bv-f64-native-ref", 2) +VM_DEFINE_FUNCTION (128, bv_f64_native_ref, "bv-f64-native-ref", 2) BV_FLOAT_REF (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_REF @@ -399,26 +427,27 @@ BV_FLOAT_REF (f64, ieee_double, double, 8) if (scm_is_eq (endianness, scm_i_native_endianness)) \ goto VM_LABEL (bv_##stem##_native_set); \ { \ - ARGS3 (bv, idx, val); \ - RETURN (scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness)); \ + SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ + scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \ + NEXT; \ } \ } -VM_DEFINE_FUNCTION (127, bv_u16_set, "bv-u16-set", 4) +VM_DEFINE_INSTRUCTION (129, bv_u16_set, "bv-u16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (128, bv_s16_set, "bv-s16-set", 4) +VM_DEFINE_INSTRUCTION (130, bv_s16_set, "bv-s16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (129, bv_u32_set, "bv-u32-set", 4) +VM_DEFINE_INSTRUCTION (131, bv_u32_set, "bv-u32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (130, bv_s32_set, "bv-s32-set", 4) +VM_DEFINE_INSTRUCTION (132, bv_s32_set, "bv-s32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (131, bv_u64_set, "bv-u64-set", 4) +VM_DEFINE_INSTRUCTION (133, bv_u64_set, "bv-u64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (132, bv_s64_set, "bv-s64-set", 4) +VM_DEFINE_INSTRUCTION (134, bv_s64_set, "bv-s64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (133, bv_f32_set, "bv-f32-set", 4) +VM_DEFINE_INSTRUCTION (135, bv_f32_set, "bv-f32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (134, bv_f64_set, "bv-f64-set", 4) +VM_DEFINE_INSTRUCTION (136, bv_f64_set, "bv-f64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f64, ieee_double) #undef BV_SET_WITH_ENDIANNESS @@ -429,11 +458,11 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) ARGS3 (bv, idx, val); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0) \ && (SCM_I_INUMP (val)) \ - && ((j = SCM_INUM (val)) >= min) \ + && ((j = SCM_I_INUM (val)) >= min) \ && (j <= max))) \ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = (scm_t_##type)j; \ else \ @@ -447,7 +476,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) ARGS3 (bv, idx, val); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_##type (val); \ @@ -462,7 +491,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) ARGS3 (bv, idx, val); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val); \ @@ -470,26 +499,26 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) scm_bytevector_##fn_stem##_native_set_x (bv, idx, val); \ } -VM_DEFINE_FUNCTION (135, bv_u8_set, "bv-u8-set", 3) +VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) -VM_DEFINE_FUNCTION (136, bv_s8_set, "bv-s8-set", 3) +VM_DEFINE_INSTRUCTION (138, bv_s8_set, "bv-s8-set", 0, 3, 0) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) -VM_DEFINE_FUNCTION (137, bv_u16_native_set, "bv-u16-native-set", 3) -BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 3) -VM_DEFINE_FUNCTION (138, bv_s16_native_set, "bv-s16-native-set", 3) -BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 3) -VM_DEFINE_FUNCTION (139, bv_u32_native_set, "bv-u32-native-set", 3) +VM_DEFINE_INSTRUCTION (139, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) +BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2) +VM_DEFINE_INSTRUCTION (140, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) +BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2) +VM_DEFINE_INSTRUCTION (141, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_SET (u32, uint32, 4) -VM_DEFINE_FUNCTION (140, bv_s32_native_set, "bv-s32-native-set", 3) +VM_DEFINE_INSTRUCTION (142, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) BV_INT_SET (s32, int32, 4) -VM_DEFINE_FUNCTION (141, bv_u64_native_set, "bv-u64-native-set", 3) +VM_DEFINE_INSTRUCTION (143, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) BV_INT_SET (u64, uint64, 8) -VM_DEFINE_FUNCTION (142, bv_s64_native_set, "bv-s64-native-set", 3) +VM_DEFINE_INSTRUCTION (144, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) BV_INT_SET (s64, int64, 8) -VM_DEFINE_FUNCTION (143, bv_f32_native_set, "bv-f32-native-set", 3) +VM_DEFINE_INSTRUCTION (145, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) BV_FLOAT_SET (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (144, bv_f64_native_set, "bv-f64-native-set", 3) +VM_DEFINE_INSTRUCTION (146, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) BV_FLOAT_SET (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_SET diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index a75843d2f..fcfdf1c09 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -81,7 +81,10 @@ (list . list) (vector . vector) ((@slot-ref . 2) . slot-ref) - ((@slot-set! . 3) . slot-set))) + ((@slot-set! . 3) . slot-set) + ((vector-ref . 2) . vector-ref) + ((vector-set! . 3) . vector-set) + )) (define (make-label) (gensym ":L")) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 7daae0c62..cde3bbef3 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -47,7 +47,9 @@ caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + + vector-ref vector-set!)) (define (add-interesting-primitive! name) (hashq-set! *interesting-primitive-vars* From a98f422ed61d36d2a0feca3d662ddc64067466f3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 26 Jun 2009 11:12:37 +0200 Subject: [PATCH 269/375] run bytevectors tests under the compiler and evaluator * test-suite/tests/bytevectors.test: Run a number of tests under the compiler/vm and the evaluator. --- test-suite/tests/bytevectors.test | 34 ++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 45f11ec77..8b336bb5b 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -19,13 +19,33 @@ (define-module (test-bytevector) :use-module (test-suite lib) + :use-module (system base compile) :use-module (rnrs bytevector)) ;;; Some of the tests in here are examples taken from the R6RS Standard ;;; Libraries document. +(define-syntax c&e + (syntax-rules (pass-if pass-if-exception) + ((_ (pass-if test-name exp)) + (begin (pass-if (string-append test-name " (eval)") + (primitive-eval 'exp)) + (pass-if (string-append test-name " (compile)") + (compile 'exp #:to 'value)))) + ((_ (pass-if-exception test-name exc exp)) + (begin (pass-if-exception (string-append test-name " (eval)") + exc (primitive-eval 'exp)) + (pass-if-exception (string-append test-name " (compile)") + exc (compile 'exp #:to 'value)))))) + +(define-syntax with-test-prefix/c&e + (syntax-rules () + ((_ section-name exp ...) + (with-test-prefix section-name (c&e exp) ...)))) + + -(with-test-prefix "2.2 General Operations" +(with-test-prefix/c&e "2.2 General Operations" (pass-if "native-endianness" (not (not (memq (native-endianness) '(big little))))) @@ -44,7 +64,7 @@ (make-bytevector 20 0)))))) -(with-test-prefix "2.3 Operations on Bytes and Octets" +(with-test-prefix/c&e "2.3 Operations on Bytes and Octets" (pass-if "bytevector-{u8,s8}-ref" (equal? '(-127 129 -1 255) @@ -131,7 +151,7 @@ (equal? bv1 bv2)))) -(with-test-prefix "2.4 Operations on Integers of Arbitrary Size" +(with-test-prefix/c&e "2.4 Operations on Integers of Arbitrary Size" (pass-if "bytevector->sint-list" (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) @@ -185,7 +205,7 @@ (uint-list->bytevector '(0 -1) (endianness big) 2))) -(with-test-prefix "2.5 Operations on 16-Bit Integers" +(with-test-prefix/c&e "2.5 Operations on 16-Bit Integers" (pass-if "bytevector-u16-ref" (let ((b (u8-list->bytevector @@ -233,7 +253,7 @@ -77)))) -(with-test-prefix "2.6 Operations on 32-bit Integers" +(with-test-prefix/c&e "2.6 Operations on 32-bit Integers" (pass-if "bytevector-u32-ref" (let ((b (u8-list->bytevector @@ -270,7 +290,7 @@ (- 2222222222 (expt 2 32))))))) -(with-test-prefix "2.7 Operations on 64-bit Integers" +(with-test-prefix/c&e "2.7 Operations on 64-bit Integers" (pass-if "bytevector-u64-ref" (let ((b (u8-list->bytevector @@ -315,7 +335,7 @@ (= 0 (bytevector-u64-ref b 0 (endianness big)))))) -(with-test-prefix "2.8 Operations on IEEE-754 Representations" +(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations" (pass-if "bytevector-ieee-single-native-{ref,set!}" (let ((b (make-bytevector 4)) From 39141c876b36431caa6bd0c84472de61fbc0a8e0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 26 Jun 2009 12:41:34 +0200 Subject: [PATCH 270/375] bytevector ops now compile down to low-level VM ops * libguile/instructions.c (scm_instruction_list): Fix a longstanding bug in this humble function. * libguile/vm-i-scheme.c (BV_FIXABLE_INT_SET, BV_INT_SET, BV_FLOAT_SET): Fix some bugs in these macros -- now the bytevector ops work. * module/language/tree-il/compile-glil.scm (*primcall-ops*): Compile bytevector calls to VM ops. * module/language/tree-il/primitives.scm (*interesting-primitive-names*): Resolve bytevector calls to primitive calls. --- libguile/instructions.c | 11 +++--- libguile/vm-i-scheme.c | 11 +++--- module/language/tree-il/compile-glil.scm | 45 +++++++++++++++++++++++- module/language/tree-il/primitives.scm | 29 +++++++++++++-- 4 files changed, 83 insertions(+), 13 deletions(-) diff --git a/libguile/instructions.c b/libguile/instructions.c index a67684e71..8e6d16993 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -109,10 +109,11 @@ SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, #define FUNC_NAME s_scm_instruction_list { SCM list = SCM_EOL; - struct scm_instruction *ip; - for (ip = fetch_instruction_table (); ip->opcode != scm_op_last; ip++) - if (ip->name) - list = scm_cons (ip->symname, list); + int i; + struct scm_instruction *ip = fetch_instruction_table (); + for (i = 0; i < scm_op_last; i++) + if (ip[i].name) + list = scm_cons (ip[i].symname, list); return scm_reverse_x (list, SCM_EOL); } #undef FUNC_NAME diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 0039d92cd..5de39a23d 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -455,14 +455,14 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \ { \ long i, j; \ - ARGS3 (bv, idx, val); \ + SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_I_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0) \ && (SCM_I_INUMP (val)) \ - && ((j = SCM_I_INUM (val)) >= min) \ + && ((j = SCM_I_INUM (val)) >= min) \ && (j <= max))) \ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = (scm_t_##type)j; \ else \ @@ -473,7 +473,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) #define BV_INT_SET(stem, type, size) \ { \ long i; \ - ARGS3 (bv, idx, val); \ + SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && ((i = SCM_I_INUM (idx)) >= 0) \ @@ -488,7 +488,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) #define BV_FLOAT_SET(stem, fn_stem, type, size) \ { \ long i; \ - ARGS3 (bv, idx, val); \ + SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && ((i = SCM_I_INUM (idx)) >= 0) \ @@ -497,6 +497,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val); \ else \ scm_bytevector_##fn_stem##_native_set_x (bv, idx, val); \ + NEXT; \ } VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index fcfdf1c09..e0df038d8 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -84,7 +84,50 @@ ((@slot-set! . 3) . slot-set) ((vector-ref . 2) . vector-ref) ((vector-set! . 3) . vector-set) - )) + + ((bytevector-u8-ref . 2) . bv-u8-ref) + ((bytevector-u8-set! . 3) . bv-u8-set) + ((bytevector-s8-ref . 2) . bv-s8-ref) + ((bytevector-s8-set! . 3) . bv-s8-set) + + ((bytevector-u16-ref . 3) . bv-u16-ref) + ((bytevector-u16-set! . 4) . bv-u16-set) + ((bytevector-u16-native-ref . 2) . bv-u16-native-ref) + ((bytevector-u16-native-set! . 3) . bv-u16-native-set) + ((bytevector-s16-ref . 3) . bv-s16-ref) + ((bytevector-s16-set! . 4) . bv-s16-set) + ((bytevector-s16-native-ref . 2) . bv-s16-native-ref) + ((bytevector-s16-native-set! . 3) . bv-s16-native-set) + + ((bytevector-u32-ref . 3) . bv-u32-ref) + ((bytevector-u32-set! . 4) . bv-u32-set) + ((bytevector-u32-native-ref . 2) . bv-u32-native-ref) + ((bytevector-u32-native-set! . 3) . bv-u32-native-set) + ((bytevector-s32-ref . 3) . bv-s32-ref) + ((bytevector-s32-set! . 4) . bv-s32-set) + ((bytevector-s32-native-ref . 2) . bv-s32-native-ref) + ((bytevector-s32-native-set! . 3) . bv-s32-native-set) + + ((bytevector-u64-ref . 3) . bv-u64-ref) + ((bytevector-u64-set! . 4) . bv-u64-set) + ((bytevector-u64-native-ref . 2) . bv-u64-native-ref) + ((bytevector-u64-native-set! . 3) . bv-u64-native-set) + ((bytevector-s64-ref . 3) . bv-s64-ref) + ((bytevector-s64-set! . 4) . bv-s64-set) + ((bytevector-s64-native-ref . 2) . bv-s64-native-ref) + ((bytevector-s64-native-set! . 3) . bv-s64-native-set) + + ((bytevector-ieee-single-ref . 3) . bv-f32-ref) + ((bytevector-ieee-single-set! . 4) . bv-f32-set) + ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref) + ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set) + ((bytevector-ieee-double-ref . 3) . bv-f64-ref) + ((bytevector-ieee-double-set! . 4) . bv-f64-set) + ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref) + ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set))) + + + (define (make-label) (gensym ":L")) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index cde3bbef3..9ccd2720d 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -19,6 +19,7 @@ ;;; Code: (define-module (language tree-il primitives) + #:use-module (rnrs bytevector) #:use-module (system base syntax) #:use-module (language tree-il) #:use-module (srfi srfi-16) @@ -49,11 +50,35 @@ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - vector-ref vector-set!)) + vector-ref vector-set! + + bytevector-u8-ref bytevector-u8-set! + bytevector-s8-ref bytevector-s8-set! + + bytevector-u16-ref bytevector-u16-set! + bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-s16-ref bytevector-s16-set! + bytevector-s16-native-ref bytevector-s16-native-set! + + bytevector-u32-ref bytevector-u32-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-ref bytevector-s32-set! + bytevector-s32-native-ref bytevector-s32-native-set! + + bytevector-u64-ref bytevector-u64-set! + bytevector-u64-native-ref bytevector-u64-native-set! + bytevector-s64-ref bytevector-s64-set! + bytevector-s64-native-ref bytevector-s64-native-set! + + bytevector-ieee-single-ref bytevector-ieee-single-set! + bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! + bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)) (define (add-interesting-primitive! name) (hashq-set! *interesting-primitive-vars* - (module-variable (current-module) name) name)) + (module-variable (current-module) name) + name)) (define *interesting-primitive-vars* (make-hash-table)) From 0a94eb002eba6539879f2cddf3e45fb25976af8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 28 Jun 2009 23:33:17 +0200 Subject: [PATCH 271/375] Remove seek/truncate shortcuts to file ports. Suggested by Neil. * libguile/fports.c (fport_seek_or_seek64): Rename to `fport_seek ()'. (fport_seek, scm_i_fport_seek, scm_i_fport_truncate): Remove. * libguile/fports.h (scm_i_fport_seek, scm_i_fport_truncate): Remove declarations. * libguile/ports.c (scm_seek): Remove shortcut that would call out to `scm_i_fport_seek ()'. (scm_truncate_file): Likewise. --- libguile/fports.c | 44 ++------------------------------------------ libguile/fports.h | 4 +--- libguile/ports.c | 12 +----------- 3 files changed, 4 insertions(+), 56 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index f6e05566b..cfb8b25b6 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -610,8 +610,8 @@ fport_fill_input (SCM port) } } -static off_t_or_off64_t -fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence) +static scm_t_off +fport_seek (SCM port, scm_t_off offset, int whence) { scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_fport *fp = SCM_FSTREAM (port); @@ -662,39 +662,6 @@ fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence) return result; } -/* If we've got largefile and off_t isn't already off64_t then - fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in - the port descriptor. - - Otherwise if no largefile, or off_t is the same as off64_t (which is the - case on NetBSD apparently), then fport_seek_or_seek64 is right to be - fport_seek already. */ - -#if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T -static scm_t_off -fport_seek (SCM port, scm_t_off offset, int whence) -{ - off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence); - if (rv > OFF_T_MAX || rv < OFF_T_MIN) - { - errno = EOVERFLOW; - scm_syserror ("fport_seek"); - } - return (scm_t_off) rv; - -} -#else -#define fport_seek fport_seek_or_seek64 -#endif - -/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */ -SCM -scm_i_fport_seek (SCM port, SCM offset, int how) -{ - return scm_from_off_t_or_off64_t - (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how)); -} - static void fport_truncate (SCM port, scm_t_off length) { @@ -704,13 +671,6 @@ fport_truncate (SCM port, scm_t_off length) scm_syserror ("ftruncate"); } -int -scm_i_fport_truncate (SCM port, SCM length) -{ - scm_t_fport *fp = SCM_FSTREAM (port); - return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length)); -} - /* helper for fport_write: try to write data, using multiple system calls if required. */ #define FUNC_NAME "write_all" diff --git a/libguile/fports.h b/libguile/fports.h index 2687504bb..cbef0f8ec 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -3,7 +3,7 @@ #ifndef SCM_FPORTS_H #define SCM_FPORTS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -59,8 +59,6 @@ SCM_INTERNAL void scm_init_fports (void); /* internal functions */ SCM_INTERNAL SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name); -SCM_INTERNAL int scm_i_fport_truncate (SCM, SCM); -SCM_INTERNAL SCM scm_i_fport_seek (SCM, SCM, int); #endif /* SCM_FPORTS_H */ diff --git a/libguile/ports.c b/libguile/ports.c index 98207b0dc..627fd3f00 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1390,12 +1390,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) SCM_OUT_OF_RANGE (3, whence); - if (SCM_OPFPORTP (fd_port)) - { - /* go direct to fport code to allow 64-bit offsets */ - return scm_i_fport_seek (fd_port, offset, how); - } - else if (SCM_OPPORTP (fd_port)) + if (SCM_OPPORTP (fd_port)) { scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port); off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); @@ -1488,11 +1483,6 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object), c_length)); } - else if (SCM_OPOUTFPORTP (object)) - { - /* go direct to fport code to allow 64-bit offsets */ - rv = scm_i_fport_truncate (object, length); - } else if (SCM_OPOUTPORTP (object)) { off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); From dd57ddd5ede6d3d9a736b2b48455fbd87da51e3a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 30 Jun 2009 23:56:40 +0100 Subject: [PATCH 272/375] Correction to doc on Accessing Arrays from C Thanks to Ludovic for the new wording! * doc/ref/api-compound.texi (Accessing Arrays from C): Correct text to reflect the current implementation of scm_array_get_handle and scm_array_handle_release - which don't actuall do any dynwind stuff. --- doc/ref/api-compound.texi | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index b3997efd7..7eccb8690 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -2358,21 +2358,13 @@ the danger of a deadlock. In a multi-threaded program, you will need additional synchronization to avoid modifying reserved arrays.) You must take care to always unreserve an array after reserving it, -also in the presence of non-local exits. To simplify this, reserving -and unreserving work like a dynwind context (@pxref{Dynamic Wind}): a -call to @code{scm_array_get_handle} can be thought of as beginning a -dynwind context and @code{scm_array_handle_release} as ending it. -When a non-local exit happens between these two calls, the array is -implicitely unreserved. +even in the presence of non-local exits. If a non-local exit can +happen between these two calls, you should install a dynwind context +that releases the array when it is left (@pxref{Dynamic Wind}). -That is, you need to properly pair reserving and unreserving in your -code, but you don't need to worry about non-local exits. - -These calls and other pairs of calls that establish dynwind contexts -need to be properly nested. If you begin a context prior to reserving -an array, you need to unreserve the array before ending the context. -Likewise, when reserving two or more arrays in a certain order, you -need to unreserve them in the opposite order. +In addition, array reserving and unreserving must be properly +paired. For instance, when reserving two or more arrays in a certain +order, you need to unreserve them in the opposite order. Once you have reserved an array and have retrieved the pointer to its elements, you must figure out the layout of the elements in memory. From 40f892156acba9cac990d2a53333fc41cefcd507 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 1 Jul 2009 01:39:24 +0100 Subject: [PATCH 273/375] Read complex numbers where both parts are inexact decimals Thanks to Bill Schottstaedt for reporting this problem! * libguile/numbers.c (mem2ureal): Don't be misled by *p_exactness being INEXACT on entry (as is possible when reading a complex number): use local exactness variable x which starts as EXACT. Call mem2decimal_from_point () with &x instead of p_exactness. * test-suite/tests/numbers.test ("string->number"): Add complex number tests suggested by Bill. --- NEWS | 1 + libguile/numbers.c | 19 +++++++++++++------ test-suite/tests/numbers.test | 9 ++++++++- 3 files changed, 22 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index 593d6c27a..a33c490ce 100644 --- a/NEWS +++ b/NEWS @@ -560,6 +560,7 @@ Changes in 1.8.7 (since 1.8.6) ** With GCC, always compile with `-mieee' on `alpha*' and `sh*' ** Better diagnose broken `(strftime "%z" ...)' in `time.test' (bug #24130) ** Fix parsing of SRFI-88/postfix keywords longer than 128 characters +** Fix reading of complex numbers where both parts are inexact decimals ** Allow @ macro to work with (ice-9 syncase) diff --git a/libguile/numbers.c b/libguile/numbers.c index 83b3f7cb1..c7e098151 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2733,6 +2733,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, unsigned int idx = *p_idx; SCM result; + /* Start off believing that the number will be exact. This changes + to INEXACT if we see a decimal point or a hash. */ + enum t_exactness x = EXACT; + if (idx == len) return SCM_BOOL_F; @@ -2744,8 +2748,6 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, if (idx+4 < len && !strncmp (mem+idx, "nan.", 4)) { - enum t_exactness x = EXACT; - /* Cobble up the fractional part. We might want to set the NaN's mantissa from it. */ idx += 4; @@ -2764,11 +2766,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, return SCM_BOOL_F; else result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len, - p_idx, p_exactness); + p_idx, &x); } else { - enum t_exactness x = EXACT; SCM uinteger; uinteger = mem2uinteger (mem, len, &idx, radix, &x); @@ -2800,10 +2801,16 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, result = uinteger; *p_idx = idx; - if (x == INEXACT) - *p_exactness = x; } + /* Update *p_exactness if the number just read was inexact. This is + important for complex numbers, so that a complex number is + treated as inexact overall if either its real or imaginary part + is inexact. + */ + if (x == INEXACT) + *p_exactness = x; + /* When returning an inexact zero, make sure it is represented as a floating point value so that we can change its sign. */ diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 57e2f9b28..4a9476a52 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1365,7 +1365,14 @@ ("1@0" 1.0) ("1@+0" 1.0) ("1@-0" 1.0) ("2+3i" ,(+ 2 (* 3 +i))) ("4-5i" ,(- 4 (* 5 +i))) ("1+i" 1+1i) ("1-i" 1-1i) ("+1i" 0+1i) ("-1i" 0-1i) - ("+i" +1i) ("-i" -1i))) + ("+i" +1i) ("-i" -1i) + ("1.0+.1i" 1.0+0.1i) + ("1.0-.1i" 1.0-0.1i) + (".1+.0i" 0.1) + ("1.+.0i" 1.0) + (".1+.1i" 0.1+0.1i) + ("1e1+.1i" 10+0.1i) + )) #t) (pass-if-exception "exponent too big" From 7c957b8657a510395fc451ae4a8e7e3fe5a643ad Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Jul 2009 21:55:28 +0200 Subject: [PATCH 274/375] fix error message for bad objcode cookie * libguile/objcodes.c: Whoop-dee :) --- libguile/objcodes.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 03ea0b8d8..4f219717a 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -70,11 +70,11 @@ make_objcode_by_mmap (int fd) if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) { + SCM args = scm_list_1 (scm_from_locale_stringn + (addr, strlen (OBJCODE_COOKIE))); (void) close (fd); (void) munmap (addr, st.st_size); - scm_misc_error (FUNC_NAME, "bad header on object file: ~s", - scm_list_1 (scm_from_locale_stringn - (addr, strlen (OBJCODE_COOKIE)))); + scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args); } data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE)); From 345b17e911a136775a901c234b8cee95d490845c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 5 Jul 2009 21:10:35 +0200 Subject: [PATCH 275/375] Fix the `BUILD_PTHREAD_SUPPORT' Automake conditional when not using pthread. * configure.in: Set $build_pthread_support to "no" when thread support isn't built. This fixes the `BUILD_PTHREAD_SUPPORT' Automake conditional. --- configure.in | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/configure.in b/configure.in index 73fc15321..53049eb79 100644 --- a/configure.in +++ b/configure.in @@ -1246,11 +1246,12 @@ case "$with_threads" in build_pthread_support="yes" - ACX_PTHREAD(CC="$PTHREAD_CC" - LIBS="$PTHREAD_LIBS $LIBS" - SCM_I_GSC_USE_PTHREAD_THREADS=1 - with_threads="pthreads", - with_threads="null") + ACX_PTHREAD([CC="$PTHREAD_CC" + LIBS="$PTHREAD_LIBS $LIBS" + SCM_I_GSC_USE_PTHREAD_THREADS=1 + with_threads="pthreads"], + [with_threads="null" + build_pthread_support="no"]) old_CFLAGS="$CFLAGS" CFLAGS="$PTHREAD_CFLAGS $CFLAGS" From 9120012f74a798064dd296d99afdc02608e305e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 5 Jul 2009 21:13:51 +0200 Subject: [PATCH 276/375] Enclose `bit-operations.test' in its own module. * test-suite/tests/bit-operations.test: Use the `define-module' clause. --- test-suite/tests/bit-operations.test | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index 8815dc65b..0e9df7d09 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -1,5 +1,5 @@ ;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -15,8 +15,9 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(use-modules (test-suite lib) - (ice-9 documentation)) +(define-module (test-bit-operations) + :use-module (test-suite lib) + :use-module (ice-9 documentation)) ;;; From 5374ec9c281c2e77c283f60afd55e47d86e3b898 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 5 Jul 2009 22:19:30 +0200 Subject: [PATCH 277/375] Update `NEWS'. * NEWS: Update. --- NEWS | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS b/NEWS index a33c490ce..36d36cbd5 100644 --- a/NEWS +++ b/NEWS @@ -557,6 +557,7 @@ Changes in 1.8.7 (since 1.8.6) ** Fix build problem when scm_t_timespec is different from struct timespec ** Fix build when compiled with -Wundef -Werror ** More build fixes for `alphaev56-dec-osf5.1b' (Tru64) +** Build fixes for `powerpc-ibm-aix5.3.0.0' (AIX 5.3) ** With GCC, always compile with `-mieee' on `alpha*' and `sh*' ** Better diagnose broken `(strftime "%z" ...)' in `time.test' (bug #24130) ** Fix parsing of SRFI-88/postfix keywords longer than 128 characters From c4b681fdacc57de0b2a9584c1f6a195cf2629b32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 5 Jul 2009 23:57:37 +0200 Subject: [PATCH 278/375] Use Gnulib's `vsnprintf' module. * m4/gnulib-cache.m4: Use `vsnprintf', needed by `deprecation.c'. --- lib/Makefile.am | 191 +- lib/asnprintf.c | 35 + lib/errno.in.h | 160 ++ lib/float+.h | 148 ++ lib/float.in.h | 62 + lib/getpagesize.c | 39 + lib/memchr.c | 172 ++ lib/memchr.valgrind | 14 + lib/printf-args.c | 187 ++ lib/printf-args.h | 154 ++ lib/printf-parse.c | 627 +++++ lib/printf-parse.h | 179 ++ lib/size_max.h | 31 + lib/stdio-write.c | 148 ++ lib/stdio.in.h | 542 +++++ lib/vasnprintf.c | 5487 +++++++++++++++++++++++++++++++++++++++++++ lib/vasnprintf.h | 81 + lib/vsnprintf.c | 71 + lib/xsize.h | 108 + m4/errno_h.m4 | 115 + m4/float_h.m4 | 19 + m4/getpagesize.m4 | 29 + m4/gnulib-cache.m4 | 3 +- m4/gnulib-comp.m4 | 45 + m4/intmax_t.m4 | 61 + m4/inttypes_h.m4 | 26 + m4/lib-link.m4 | 7 +- m4/mbrtowc.m4 | 3 +- m4/memchr.m4 | 86 + m4/mmap-anon.m4 | 59 + m4/printf.m4 | 1416 +++++++++++ m4/size_max.m4 | 75 + m4/stdint_h.m4 | 26 + m4/stdio_h.m4 | 136 ++ m4/vasnprintf.m4 | 276 +++ m4/vsnprintf.m4 | 40 + m4/wchar_t.m4 | 20 + m4/xsize.m4 | 13 + 38 files changed, 10886 insertions(+), 5 deletions(-) create mode 100644 lib/asnprintf.c create mode 100644 lib/errno.in.h create mode 100644 lib/float+.h create mode 100644 lib/float.in.h create mode 100644 lib/getpagesize.c create mode 100644 lib/memchr.c create mode 100644 lib/memchr.valgrind create mode 100644 lib/printf-args.c create mode 100644 lib/printf-args.h create mode 100644 lib/printf-parse.c create mode 100644 lib/printf-parse.h create mode 100644 lib/size_max.h create mode 100644 lib/stdio-write.c create mode 100644 lib/stdio.in.h create mode 100644 lib/vasnprintf.c create mode 100644 lib/vasnprintf.h create mode 100644 lib/vsnprintf.c create mode 100644 lib/xsize.h create mode 100644 m4/errno_h.m4 create mode 100644 m4/float_h.m4 create mode 100644 m4/getpagesize.m4 create mode 100644 m4/intmax_t.m4 create mode 100644 m4/inttypes_h.m4 create mode 100644 m4/memchr.m4 create mode 100644 m4/mmap-anon.m4 create mode 100644 m4/printf.m4 create mode 100644 m4/size_max.m4 create mode 100644 m4/stdint_h.m4 create mode 100644 m4/stdio_h.m4 create mode 100644 m4/vasnprintf.m4 create mode 100644 m4/vsnprintf.m4 create mode 100644 m4/wchar_t.m4 create mode 100644 m4/xsize.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index f488fa188..197320eca 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string vsnprintf AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -167,6 +167,54 @@ EXTRA_DIST += count-one-bits.h ## end gnulib module count-one-bits +## begin gnulib module errno + +BUILT_SOURCES += $(ERRNO_H) + +# We need the following in order to create when the system +# doesn't have one that is POSIX compliant. +errno.h: errno.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_ERRNO_H''@|$(NEXT_ERRNO_H)|g' \ + -e 's|@''EMULTIHOP_HIDDEN''@|$(EMULTIHOP_HIDDEN)|g' \ + -e 's|@''EMULTIHOP_VALUE''@|$(EMULTIHOP_VALUE)|g' \ + -e 's|@''ENOLINK_HIDDEN''@|$(ENOLINK_HIDDEN)|g' \ + -e 's|@''ENOLINK_VALUE''@|$(ENOLINK_VALUE)|g' \ + -e 's|@''EOVERFLOW_HIDDEN''@|$(EOVERFLOW_HIDDEN)|g' \ + -e 's|@''EOVERFLOW_VALUE''@|$(EOVERFLOW_VALUE)|g' \ + < $(srcdir)/errno.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += errno.h errno.h-t + +EXTRA_DIST += errno.in.h + +## end gnulib module errno + +## begin gnulib module float + +BUILT_SOURCES += $(FLOAT_H) + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +float.h: float.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_FLOAT_H''@|$(NEXT_FLOAT_H)|g' \ + < $(srcdir)/float.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += float.h float.h-t + +EXTRA_DIST += float.in.h + +## end gnulib module float + ## begin gnulib module flock @@ -188,6 +236,15 @@ libgnu_la_SOURCES += full-write.h full-write.c ## end gnulib module full-write +## begin gnulib module getpagesize + + +EXTRA_DIST += getpagesize.c + +EXTRA_libgnu_la_SOURCES += getpagesize.c + +## end gnulib module getpagesize + ## begin gnulib module gperf GPERF = gperf @@ -390,6 +447,15 @@ EXTRA_libgnu_la_SOURCES += mbsinit.c ## end gnulib module mbsinit +## begin gnulib module memchr + + +EXTRA_DIST += memchr.c memchr.valgrind + +EXTRA_libgnu_la_SOURCES += memchr.c + +## end gnulib module memchr + ## begin gnulib module pathmax @@ -433,6 +499,12 @@ EXTRA_libgnu_la_SOURCES += safe-write.c ## end gnulib module safe-write +## begin gnulib module size_max + +libgnu_la_SOURCES += size_max.h + +## end gnulib module size_max + ## begin gnulib module stdbool BUILT_SOURCES += $(STDBOOL_H) @@ -493,6 +565,99 @@ EXTRA_DIST += stdint.in.h ## end gnulib module stdint +## begin gnulib module stdio + +BUILT_SOURCES += stdio.h + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +stdio.h: stdio.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_STDIO_H''@|$(NEXT_STDIO_H)|g' \ + -e 's|@''GNULIB_FPRINTF''@|$(GNULIB_FPRINTF)|g' \ + -e 's|@''GNULIB_FPRINTF_POSIX''@|$(GNULIB_FPRINTF_POSIX)|g' \ + -e 's|@''GNULIB_PRINTF''@|$(GNULIB_PRINTF)|g' \ + -e 's|@''GNULIB_PRINTF_POSIX''@|$(GNULIB_PRINTF_POSIX)|g' \ + -e 's|@''GNULIB_SNPRINTF''@|$(GNULIB_SNPRINTF)|g' \ + -e 's|@''GNULIB_SPRINTF_POSIX''@|$(GNULIB_SPRINTF_POSIX)|g' \ + -e 's|@''GNULIB_VFPRINTF''@|$(GNULIB_VFPRINTF)|g' \ + -e 's|@''GNULIB_VFPRINTF_POSIX''@|$(GNULIB_VFPRINTF_POSIX)|g' \ + -e 's|@''GNULIB_VPRINTF''@|$(GNULIB_VPRINTF)|g' \ + -e 's|@''GNULIB_VPRINTF_POSIX''@|$(GNULIB_VPRINTF_POSIX)|g' \ + -e 's|@''GNULIB_VSNPRINTF''@|$(GNULIB_VSNPRINTF)|g' \ + -e 's|@''GNULIB_VSPRINTF_POSIX''@|$(GNULIB_VSPRINTF_POSIX)|g' \ + -e 's|@''GNULIB_DPRINTF''@|$(GNULIB_DPRINTF)|g' \ + -e 's|@''GNULIB_VDPRINTF''@|$(GNULIB_VDPRINTF)|g' \ + -e 's|@''GNULIB_VASPRINTF''@|$(GNULIB_VASPRINTF)|g' \ + -e 's|@''GNULIB_OBSTACK_PRINTF''@|$(GNULIB_OBSTACK_PRINTF)|g' \ + -e 's|@''GNULIB_OBSTACK_PRINTF_POSIX''@|$(GNULIB_OBSTACK_PRINTF_POSIX)|g' \ + -e 's|@''GNULIB_FOPEN''@|$(GNULIB_FOPEN)|g' \ + -e 's|@''GNULIB_FREOPEN''@|$(GNULIB_FREOPEN)|g' \ + -e 's|@''GNULIB_FSEEK''@|$(GNULIB_FSEEK)|g' \ + -e 's|@''GNULIB_FSEEKO''@|$(GNULIB_FSEEKO)|g' \ + -e 's|@''GNULIB_FTELL''@|$(GNULIB_FTELL)|g' \ + -e 's|@''GNULIB_FTELLO''@|$(GNULIB_FTELLO)|g' \ + -e 's|@''GNULIB_FFLUSH''@|$(GNULIB_FFLUSH)|g' \ + -e 's|@''GNULIB_FPURGE''@|$(GNULIB_FPURGE)|g' \ + -e 's|@''GNULIB_FCLOSE''@|$(GNULIB_FCLOSE)|g' \ + -e 's|@''GNULIB_FPUTC''@|$(GNULIB_FPUTC)|g' \ + -e 's|@''GNULIB_PUTC''@|$(GNULIB_PUTC)|g' \ + -e 's|@''GNULIB_PUTCHAR''@|$(GNULIB_PUTCHAR)|g' \ + -e 's|@''GNULIB_FPUTS''@|$(GNULIB_FPUTS)|g' \ + -e 's|@''GNULIB_PUTS''@|$(GNULIB_PUTS)|g' \ + -e 's|@''GNULIB_FWRITE''@|$(GNULIB_FWRITE)|g' \ + -e 's|@''GNULIB_GETDELIM''@|$(GNULIB_GETDELIM)|g' \ + -e 's|@''GNULIB_GETLINE''@|$(GNULIB_GETLINE)|g' \ + -e 's|@''GNULIB_PERROR''@|$(GNULIB_PERROR)|g' \ + -e 's|@''GNULIB_STDIO_H_SIGPIPE''@|$(GNULIB_STDIO_H_SIGPIPE)|g' \ + -e 's|@''REPLACE_STDIO_WRITE_FUNCS''@|$(REPLACE_STDIO_WRITE_FUNCS)|g' \ + -e 's|@''REPLACE_FPRINTF''@|$(REPLACE_FPRINTF)|g' \ + -e 's|@''REPLACE_VFPRINTF''@|$(REPLACE_VFPRINTF)|g' \ + -e 's|@''REPLACE_PRINTF''@|$(REPLACE_PRINTF)|g' \ + -e 's|@''REPLACE_VPRINTF''@|$(REPLACE_VPRINTF)|g' \ + -e 's|@''REPLACE_SNPRINTF''@|$(REPLACE_SNPRINTF)|g' \ + -e 's|@''HAVE_DECL_SNPRINTF''@|$(HAVE_DECL_SNPRINTF)|g' \ + -e 's|@''REPLACE_VSNPRINTF''@|$(REPLACE_VSNPRINTF)|g' \ + -e 's|@''HAVE_DECL_VSNPRINTF''@|$(HAVE_DECL_VSNPRINTF)|g' \ + -e 's|@''REPLACE_SPRINTF''@|$(REPLACE_SPRINTF)|g' \ + -e 's|@''REPLACE_VSPRINTF''@|$(REPLACE_VSPRINTF)|g' \ + -e 's|@''HAVE_DPRINTF''@|$(HAVE_DPRINTF)|g' \ + -e 's|@''REPLACE_DPRINTF''@|$(REPLACE_DPRINTF)|g' \ + -e 's|@''HAVE_VDPRINTF''@|$(HAVE_VDPRINTF)|g' \ + -e 's|@''REPLACE_VDPRINTF''@|$(REPLACE_VDPRINTF)|g' \ + -e 's|@''HAVE_VASPRINTF''@|$(HAVE_VASPRINTF)|g' \ + -e 's|@''REPLACE_VASPRINTF''@|$(REPLACE_VASPRINTF)|g' \ + -e 's|@''HAVE_DECL_OBSTACK_PRINTF''@|$(HAVE_DECL_OBSTACK_PRINTF)|g' \ + -e 's|@''REPLACE_OBSTACK_PRINTF''@|$(REPLACE_OBSTACK_PRINTF)|g' \ + -e 's|@''REPLACE_FOPEN''@|$(REPLACE_FOPEN)|g' \ + -e 's|@''REPLACE_FREOPEN''@|$(REPLACE_FREOPEN)|g' \ + -e 's|@''REPLACE_FSEEKO''@|$(REPLACE_FSEEKO)|g' \ + -e 's|@''REPLACE_FSEEK''@|$(REPLACE_FSEEK)|g' \ + -e 's|@''REPLACE_FTELLO''@|$(REPLACE_FTELLO)|g' \ + -e 's|@''REPLACE_FTELL''@|$(REPLACE_FTELL)|g' \ + -e 's|@''REPLACE_FFLUSH''@|$(REPLACE_FFLUSH)|g' \ + -e 's|@''REPLACE_FPURGE''@|$(REPLACE_FPURGE)|g' \ + -e 's|@''HAVE_DECL_FPURGE''@|$(HAVE_DECL_FPURGE)|g' \ + -e 's|@''REPLACE_FCLOSE''@|$(REPLACE_FCLOSE)|g' \ + -e 's|@''HAVE_DECL_GETDELIM''@|$(HAVE_DECL_GETDELIM)|g' \ + -e 's|@''HAVE_DECL_GETLINE''@|$(HAVE_DECL_GETLINE)|g' \ + -e 's|@''REPLACE_GETLINE''@|$(REPLACE_GETLINE)|g' \ + -e 's|@''REPLACE_PERROR''@|$(REPLACE_PERROR)|g' \ + -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \ + < $(srcdir)/stdio.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += stdio.h stdio.h-t + +EXTRA_DIST += stdio-write.c stdio.in.h + +EXTRA_libgnu_la_SOURCES += stdio-write.c + +## end gnulib module stdio + ## begin gnulib module stdlib BUILT_SOURCES += stdlib.h @@ -868,12 +1033,30 @@ EXTRA_DIST += unitypes.h ## end gnulib module unitypes +## begin gnulib module vasnprintf + + +EXTRA_DIST += asnprintf.c float+.h printf-args.c printf-args.h printf-parse.c printf-parse.h vasnprintf.c vasnprintf.h + +EXTRA_libgnu_la_SOURCES += asnprintf.c printf-args.c printf-parse.c vasnprintf.c + +## end gnulib module vasnprintf + ## begin gnulib module verify libgnu_la_SOURCES += verify.h ## end gnulib module verify +## begin gnulib module vsnprintf + + +EXTRA_DIST += vsnprintf.c + +EXTRA_libgnu_la_SOURCES += vsnprintf.c + +## end gnulib module vsnprintf + ## begin gnulib module wchar BUILT_SOURCES += $(WCHAR_H) @@ -941,6 +1124,12 @@ EXTRA_libgnu_la_SOURCES += write.c ## end gnulib module write +## begin gnulib module xsize + +libgnu_la_SOURCES += xsize.h + +## end gnulib module xsize + mostlyclean-local: mostlyclean-generic @for dir in '' $(MOSTLYCLEANDIRS); do \ diff --git a/lib/asnprintf.c b/lib/asnprintf.c new file mode 100644 index 000000000..3b374a2a4 --- /dev/null +++ b/lib/asnprintf.c @@ -0,0 +1,35 @@ +/* Formatted output to strings. + Copyright (C) 1999, 2002, 2006 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include "vasnprintf.h" + +#include + +char * +asnprintf (char *resultbuf, size_t *lengthp, const char *format, ...) +{ + va_list args; + char *result; + + va_start (args, format); + result = vasnprintf (resultbuf, lengthp, format, args); + va_end (args); + return result; +} diff --git a/lib/errno.in.h b/lib/errno.in.h new file mode 100644 index 000000000..a9b81d5df --- /dev/null +++ b/lib/errno.in.h @@ -0,0 +1,160 @@ +/* A POSIX-like . + + Copyright (C) 2008-2009 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _GL_ERRNO_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_ERRNO_H@ + +#ifndef _GL_ERRNO_H +#define _GL_ERRNO_H + + +/* On native Windows platforms, many macros are not defined. */ +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +/* POSIX says that EAGAIN and EWOULDBLOCK may have the same value. */ +# define EWOULDBLOCK EAGAIN + +/* Values >= 100 seem safe to use. */ +# define ETXTBSY 100 +# define GNULIB_defined_ETXTBSY 1 + +/* These are intentionally the same values as the WSA* error numbers, defined + in . */ +# define EINPROGRESS 10036 +# define EALREADY 10037 +# define ENOTSOCK 10038 +# define EDESTADDRREQ 10039 +# define EMSGSIZE 10040 +# define EPROTOTYPE 10041 +# define ENOPROTOOPT 10042 +# define EPROTONOSUPPORT 10043 +# define ESOCKTNOSUPPORT 10044 /* not required by POSIX */ +# define EOPNOTSUPP 10045 +# define EPFNOSUPPORT 10046 /* not required by POSIX */ +# define EAFNOSUPPORT 10047 +# define EADDRINUSE 10048 +# define EADDRNOTAVAIL 10049 +# define ENETDOWN 10050 +# define ENETUNREACH 10051 +# define ENETRESET 10052 +# define ECONNABORTED 10053 +# define ECONNRESET 10054 +# define ENOBUFS 10055 +# define EISCONN 10056 +# define ENOTCONN 10057 +# define ESHUTDOWN 10058 /* not required by POSIX */ +# define ETOOMANYREFS 10059 /* not required by POSIX */ +# define ETIMEDOUT 10060 +# define ECONNREFUSED 10061 +# define ELOOP 10062 +# define EHOSTDOWN 10064 /* not required by POSIX */ +# define EHOSTUNREACH 10065 +# define EPROCLIM 10067 /* not required by POSIX */ +# define EUSERS 10068 /* not required by POSIX */ +# define EDQUOT 10069 +# define ESTALE 10070 +# define EREMOTE 10071 /* not required by POSIX */ +# define GNULIB_defined_ESOCK 1 + +# endif + + +/* On OSF/1 5.1, when _XOPEN_SOURCE_EXTENDED is not defined, the macros + EMULTIHOP, ENOLINK, EOVERFLOW are not defined. */ +# if @EMULTIHOP_HIDDEN@ +# define EMULTIHOP @EMULTIHOP_VALUE@ +# define GNULIB_defined_EMULTIHOP 1 +# endif +# if @ENOLINK_HIDDEN@ +# define ENOLINK @ENOLINK_VALUE@ +# define GNULIB_defined_ENOLINK 1 +# endif +# if @EOVERFLOW_HIDDEN@ +# define EOVERFLOW @EOVERFLOW_VALUE@ +# define GNULIB_defined_EOVERFLOW 1 +# endif + + +/* On OpenBSD 4.0 and on native Windows, the macros ENOMSG, EIDRM, ENOLINK, + EPROTO, EMULTIHOP, EBADMSG, EOVERFLOW, ENOTSUP, ECANCELED are not defined. + Define them here. Values >= 2000 seem safe to use: Solaris ESTALE = 151, + HP-UX EWOULDBLOCK = 246, IRIX EDQUOT = 1133. + + Note: When one of these systems defines some of these macros some day, + binaries will have to be recompiled so that they recognizes the new + errno values from the system. */ + +# ifndef ENOMSG +# define ENOMSG 2000 +# define GNULIB_defined_ENOMSG 1 +# endif + +# ifndef EIDRM +# define EIDRM 2001 +# define GNULIB_defined_EIDRM 1 +# endif + +# ifndef ENOLINK +# define ENOLINK 2002 +# define GNULIB_defined_ENOLINK 1 +# endif + +# ifndef EPROTO +# define EPROTO 2003 +# define GNULIB_defined_EPROTO 1 +# endif + +# ifndef EMULTIHOP +# define EMULTIHOP 2004 +# define GNULIB_defined_EMULTIHOP 1 +# endif + +# ifndef EBADMSG +# define EBADMSG 2005 +# define GNULIB_defined_EBADMSG 1 +# endif + +# ifndef EOVERFLOW +# define EOVERFLOW 2006 +# define GNULIB_defined_EOVERFLOW 1 +# endif + +# ifndef ENOTSUP +# define ENOTSUP 2007 +# define GNULIB_defined_ENOTSUP 1 +# endif + +# ifndef ESTALE +# define ESTALE 2009 +# define GNULIB_defined_ESTALE 1 +# endif + +# ifndef ECANCELED +# define ECANCELED 2008 +# define GNULIB_defined_ECANCELED 1 +# endif + + +#endif /* _GL_ERRNO_H */ +#endif /* _GL_ERRNO_H */ diff --git a/lib/float+.h b/lib/float+.h new file mode 100644 index 000000000..2288e3d34 --- /dev/null +++ b/lib/float+.h @@ -0,0 +1,148 @@ +/* Supplemental information about the floating-point formats. + Copyright (C) 2007 Free Software Foundation, Inc. + Written by Bruno Haible , 2007. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _FLOATPLUS_H +#define _FLOATPLUS_H + +#include +#include + +/* Number of bits in the mantissa of a floating-point number, including the + "hidden bit". */ +#if FLT_RADIX == 2 +# define FLT_MANT_BIT FLT_MANT_DIG +# define DBL_MANT_BIT DBL_MANT_DIG +# define LDBL_MANT_BIT LDBL_MANT_DIG +#elif FLT_RADIX == 4 +# define FLT_MANT_BIT (FLT_MANT_DIG * 2) +# define DBL_MANT_BIT (DBL_MANT_DIG * 2) +# define LDBL_MANT_BIT (LDBL_MANT_DIG * 2) +#elif FLT_RADIX == 16 +# define FLT_MANT_BIT (FLT_MANT_DIG * 4) +# define DBL_MANT_BIT (DBL_MANT_DIG * 4) +# define LDBL_MANT_BIT (LDBL_MANT_DIG * 4) +#endif + +/* Bit mask that can be used to mask the exponent, as an unsigned number. */ +#define FLT_EXP_MASK ((FLT_MAX_EXP - FLT_MIN_EXP) | 7) +#define DBL_EXP_MASK ((DBL_MAX_EXP - DBL_MIN_EXP) | 7) +#define LDBL_EXP_MASK ((LDBL_MAX_EXP - LDBL_MIN_EXP) | 7) + +/* Number of bits used for the exponent of a floating-point number, including + the exponent's sign. */ +#define FLT_EXP_BIT \ + (FLT_EXP_MASK < 0x100 ? 8 : \ + FLT_EXP_MASK < 0x200 ? 9 : \ + FLT_EXP_MASK < 0x400 ? 10 : \ + FLT_EXP_MASK < 0x800 ? 11 : \ + FLT_EXP_MASK < 0x1000 ? 12 : \ + FLT_EXP_MASK < 0x2000 ? 13 : \ + FLT_EXP_MASK < 0x4000 ? 14 : \ + FLT_EXP_MASK < 0x8000 ? 15 : \ + FLT_EXP_MASK < 0x10000 ? 16 : \ + FLT_EXP_MASK < 0x20000 ? 17 : \ + FLT_EXP_MASK < 0x40000 ? 18 : \ + FLT_EXP_MASK < 0x80000 ? 19 : \ + FLT_EXP_MASK < 0x100000 ? 20 : \ + FLT_EXP_MASK < 0x200000 ? 21 : \ + FLT_EXP_MASK < 0x400000 ? 22 : \ + FLT_EXP_MASK < 0x800000 ? 23 : \ + FLT_EXP_MASK < 0x1000000 ? 24 : \ + FLT_EXP_MASK < 0x2000000 ? 25 : \ + FLT_EXP_MASK < 0x4000000 ? 26 : \ + FLT_EXP_MASK < 0x8000000 ? 27 : \ + FLT_EXP_MASK < 0x10000000 ? 28 : \ + FLT_EXP_MASK < 0x20000000 ? 29 : \ + FLT_EXP_MASK < 0x40000000 ? 30 : \ + FLT_EXP_MASK <= 0x7fffffff ? 31 : \ + 32) +#define DBL_EXP_BIT \ + (DBL_EXP_MASK < 0x100 ? 8 : \ + DBL_EXP_MASK < 0x200 ? 9 : \ + DBL_EXP_MASK < 0x400 ? 10 : \ + DBL_EXP_MASK < 0x800 ? 11 : \ + DBL_EXP_MASK < 0x1000 ? 12 : \ + DBL_EXP_MASK < 0x2000 ? 13 : \ + DBL_EXP_MASK < 0x4000 ? 14 : \ + DBL_EXP_MASK < 0x8000 ? 15 : \ + DBL_EXP_MASK < 0x10000 ? 16 : \ + DBL_EXP_MASK < 0x20000 ? 17 : \ + DBL_EXP_MASK < 0x40000 ? 18 : \ + DBL_EXP_MASK < 0x80000 ? 19 : \ + DBL_EXP_MASK < 0x100000 ? 20 : \ + DBL_EXP_MASK < 0x200000 ? 21 : \ + DBL_EXP_MASK < 0x400000 ? 22 : \ + DBL_EXP_MASK < 0x800000 ? 23 : \ + DBL_EXP_MASK < 0x1000000 ? 24 : \ + DBL_EXP_MASK < 0x2000000 ? 25 : \ + DBL_EXP_MASK < 0x4000000 ? 26 : \ + DBL_EXP_MASK < 0x8000000 ? 27 : \ + DBL_EXP_MASK < 0x10000000 ? 28 : \ + DBL_EXP_MASK < 0x20000000 ? 29 : \ + DBL_EXP_MASK < 0x40000000 ? 30 : \ + DBL_EXP_MASK <= 0x7fffffff ? 31 : \ + 32) +#define LDBL_EXP_BIT \ + (LDBL_EXP_MASK < 0x100 ? 8 : \ + LDBL_EXP_MASK < 0x200 ? 9 : \ + LDBL_EXP_MASK < 0x400 ? 10 : \ + LDBL_EXP_MASK < 0x800 ? 11 : \ + LDBL_EXP_MASK < 0x1000 ? 12 : \ + LDBL_EXP_MASK < 0x2000 ? 13 : \ + LDBL_EXP_MASK < 0x4000 ? 14 : \ + LDBL_EXP_MASK < 0x8000 ? 15 : \ + LDBL_EXP_MASK < 0x10000 ? 16 : \ + LDBL_EXP_MASK < 0x20000 ? 17 : \ + LDBL_EXP_MASK < 0x40000 ? 18 : \ + LDBL_EXP_MASK < 0x80000 ? 19 : \ + LDBL_EXP_MASK < 0x100000 ? 20 : \ + LDBL_EXP_MASK < 0x200000 ? 21 : \ + LDBL_EXP_MASK < 0x400000 ? 22 : \ + LDBL_EXP_MASK < 0x800000 ? 23 : \ + LDBL_EXP_MASK < 0x1000000 ? 24 : \ + LDBL_EXP_MASK < 0x2000000 ? 25 : \ + LDBL_EXP_MASK < 0x4000000 ? 26 : \ + LDBL_EXP_MASK < 0x8000000 ? 27 : \ + LDBL_EXP_MASK < 0x10000000 ? 28 : \ + LDBL_EXP_MASK < 0x20000000 ? 29 : \ + LDBL_EXP_MASK < 0x40000000 ? 30 : \ + LDBL_EXP_MASK <= 0x7fffffff ? 31 : \ + 32) + +/* Number of bits used for a floating-point number: the mantissa (not + counting the "hidden bit", since it may or may not be explicit), the + exponent, and the sign. */ +#define FLT_TOTAL_BIT ((FLT_MANT_BIT - 1) + FLT_EXP_BIT + 1) +#define DBL_TOTAL_BIT ((DBL_MANT_BIT - 1) + DBL_EXP_BIT + 1) +#define LDBL_TOTAL_BIT ((LDBL_MANT_BIT - 1) + LDBL_EXP_BIT + 1) + +/* Number of bytes used for a floating-point number. + This can be smaller than the 'sizeof'. For example, on i386 systems, + 'long double' most often have LDBL_MANT_BIT = 64, LDBL_EXP_BIT = 16, hence + LDBL_TOTAL_BIT = 80 bits, i.e. 10 bytes of consecutive memory, but + sizeof (long double) = 12 or = 16. */ +#define SIZEOF_FLT ((FLT_TOTAL_BIT + CHAR_BIT - 1) / CHAR_BIT) +#define SIZEOF_DBL ((DBL_TOTAL_BIT + CHAR_BIT - 1) / CHAR_BIT) +#define SIZEOF_LDBL ((LDBL_TOTAL_BIT + CHAR_BIT - 1) / CHAR_BIT) + +/* Verify that SIZEOF_FLT <= sizeof (float) etc. */ +typedef int verify_sizeof_flt[2 * (SIZEOF_FLT <= sizeof (float)) - 1]; +typedef int verify_sizeof_dbl[2 * (SIZEOF_DBL <= sizeof (double)) - 1]; +typedef int verify_sizeof_ldbl[2 * (SIZEOF_LDBL <= sizeof (long double)) - 1]; + +#endif /* _FLOATPLUS_H */ diff --git a/lib/float.in.h b/lib/float.in.h new file mode 100644 index 000000000..63d55f879 --- /dev/null +++ b/lib/float.in.h @@ -0,0 +1,62 @@ +/* A correct . + + Copyright (C) 2007-2008 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef _GL_FLOAT_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_FLOAT_H@ + +#ifndef _GL_FLOAT_H +#define _GL_FLOAT_H + +/* 'long double' properties. */ +#if defined __i386__ && (defined __BEOS__ || defined __OpenBSD__) +/* Number of mantissa units, in base FLT_RADIX. */ +# undef LDBL_MANT_DIG +# define LDBL_MANT_DIG 64 +/* Number of decimal digits that is sufficient for representing a number. */ +# undef LDBL_DIG +# define LDBL_DIG 18 +/* x-1 where x is the smallest representable number > 1. */ +# undef LDBL_EPSILON +# define LDBL_EPSILON 1.0842021724855044340E-19L +/* Minimum e such that FLT_RADIX^(e-1) is a normalized number. */ +# undef LDBL_MIN_EXP +# define LDBL_MIN_EXP (-16381) +/* Maximum e such that FLT_RADIX^(e-1) is a representable finite number. */ +# undef LDBL_MAX_EXP +# define LDBL_MAX_EXP 16384 +/* Minimum positive normalized number. */ +# undef LDBL_MIN +# define LDBL_MIN 3.3621031431120935063E-4932L +/* Maximum representable finite number. */ +# undef LDBL_MAX +# define LDBL_MAX 1.1897314953572317650E+4932L +/* Minimum e such that 10^e is in the range of normalized numbers. */ +# undef LDBL_MIN_10_EXP +# define LDBL_MIN_10_EXP (-4931) +/* Maximum e such that 10^e is in the range of representable finite numbers. */ +# undef LDBL_MAX_10_EXP +# define LDBL_MAX_10_EXP 4932 +#endif + +#endif /* _GL_FLOAT_H */ +#endif /* _GL_FLOAT_H */ diff --git a/lib/getpagesize.c b/lib/getpagesize.c new file mode 100644 index 000000000..82238df19 --- /dev/null +++ b/lib/getpagesize.c @@ -0,0 +1,39 @@ +/* getpagesize emulation for systems where it cannot be done in a C macro. + + Copyright (C) 2007 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Written by Bruno Haible and Martin Lambers. */ + +#include + +/* Specification. */ +#include + +/* This implementation is only for native Win32 systems. */ +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +# define WIN32_LEAN_AND_MEAN +# include + +int +getpagesize (void) +{ + SYSTEM_INFO system_info; + GetSystemInfo (&system_info); + return system_info.dwPageSize; +} + +#endif diff --git a/lib/memchr.c b/lib/memchr.c new file mode 100644 index 000000000..3ea1d5bac --- /dev/null +++ b/lib/memchr.c @@ -0,0 +1,172 @@ +/* Copyright (C) 1991, 1993, 1996, 1997, 1999, 2000, 2003, 2004, 2006, 2008 + Free Software Foundation, Inc. + + Based on strlen implementation by Torbjorn Granlund (tege@sics.se), + with help from Dan Sahlin (dan@sics.se) and + commentary by Jim Blandy (jimb@ai.mit.edu); + adaptation to memchr suggested by Dick Karpinski (dick@cca.ucsf.edu), + and implemented by Roland McGrath (roland@ai.mit.edu). + +NOTE: The canonical source of this file is maintained with the GNU C Library. +Bugs can be reported to bug-glibc@prep.ai.mit.edu. + +This program is free software: you can redistribute it and/or modify it +under the terms of the GNU Lesser General Public License as published by the +Free Software Foundation; either version 3 of the License, or any +later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with this program. If not, see . */ + +#ifndef _LIBC +# include +#endif + +#include + +#include + +#if defined _LIBC +# include +#else +# define reg_char char +#endif + +#include + +#if HAVE_BP_SYM_H || defined _LIBC +# include +#else +# define BP_SYM(sym) sym +#endif + +#undef __memchr +#ifdef _LIBC +# undef memchr +#endif + +#ifndef weak_alias +# define __memchr memchr +#endif + +/* Search no more than N bytes of S for C. */ +void * +__memchr (void const *s, int c_in, size_t n) +{ + /* On 32-bit hardware, choosing longword to be a 32-bit unsigned + long instead of a 64-bit uintmax_t tends to give better + performance. On 64-bit hardware, unsigned long is generally 64 + bits already. Change this typedef to experiment with + performance. */ + typedef unsigned long int longword; + + const unsigned char *char_ptr; + const longword *longword_ptr; + longword repeated_one; + longword repeated_c; + unsigned reg_char c; + + c = (unsigned char) c_in; + + /* Handle the first few bytes by reading one byte at a time. + Do this until CHAR_PTR is aligned on a longword boundary. */ + for (char_ptr = (const unsigned char *) s; + n > 0 && (size_t) char_ptr % sizeof (longword) != 0; + --n, ++char_ptr) + if (*char_ptr == c) + return (void *) char_ptr; + + longword_ptr = (const longword *) char_ptr; + + /* All these elucidatory comments refer to 4-byte longwords, + but the theory applies equally well to any size longwords. */ + + /* Compute auxiliary longword values: + repeated_one is a value which has a 1 in every byte. + repeated_c has c in every byte. */ + repeated_one = 0x01010101; + repeated_c = c | (c << 8); + repeated_c |= repeated_c << 16; + if (0xffffffffU < (longword) -1) + { + repeated_one |= repeated_one << 31 << 1; + repeated_c |= repeated_c << 31 << 1; + if (8 < sizeof (longword)) + { + size_t i; + + for (i = 64; i < sizeof (longword) * 8; i *= 2) + { + repeated_one |= repeated_one << i; + repeated_c |= repeated_c << i; + } + } + } + + /* Instead of the traditional loop which tests each byte, we will test a + longword at a time. The tricky part is testing if *any of the four* + bytes in the longword in question are equal to c. We first use an xor + with repeated_c. This reduces the task to testing whether *any of the + four* bytes in longword1 is zero. + + We compute tmp = + ((longword1 - repeated_one) & ~longword1) & (repeated_one << 7). + That is, we perform the following operations: + 1. Subtract repeated_one. + 2. & ~longword1. + 3. & a mask consisting of 0x80 in every byte. + Consider what happens in each byte: + - If a byte of longword1 is zero, step 1 and 2 transform it into 0xff, + and step 3 transforms it into 0x80. A carry can also be propagated + to more significant bytes. + - If a byte of longword1 is nonzero, let its lowest 1 bit be at + position k (0 <= k <= 7); so the lowest k bits are 0. After step 1, + the byte ends in a single bit of value 0 and k bits of value 1. + After step 2, the result is just k bits of value 1: 2^k - 1. After + step 3, the result is 0. And no carry is produced. + So, if longword1 has only non-zero bytes, tmp is zero. + Whereas if longword1 has a zero byte, call j the position of the least + significant zero byte. Then the result has a zero at positions 0, ..., + j-1 and a 0x80 at position j. We cannot predict the result at the more + significant bytes (positions j+1..3), but it does not matter since we + already have a non-zero bit at position 8*j+7. + + So, the test whether any byte in longword1 is zero is equivalent to + testing whether tmp is nonzero. */ + + while (n >= sizeof (longword)) + { + longword longword1 = *longword_ptr ^ repeated_c; + + if ((((longword1 - repeated_one) & ~longword1) + & (repeated_one << 7)) != 0) + break; + longword_ptr++; + n -= sizeof (longword); + } + + char_ptr = (const unsigned char *) longword_ptr; + + /* At this point, we know that either n < sizeof (longword), or one of the + sizeof (longword) bytes starting at char_ptr is == c. On little-endian + machines, we could determine the first such byte without any further + memory accesses, just by looking at the tmp result from the last loop + iteration. But this does not work on big-endian machines. Choose code + that works in both cases. */ + + for (; n > 0; --n, ++char_ptr) + { + if (*char_ptr == c) + return (void *) char_ptr; + } + + return NULL; +} +#ifdef weak_alias +weak_alias (__memchr, BP_SYM (memchr)) +#endif diff --git a/lib/memchr.valgrind b/lib/memchr.valgrind new file mode 100644 index 000000000..60f247e10 --- /dev/null +++ b/lib/memchr.valgrind @@ -0,0 +1,14 @@ +# Suppress a valgrind message about use of uninitialized memory in memchr(). +# POSIX states that when the character is found, memchr must not read extra +# bytes in an overestimated length (for example, where memchr is used to +# implement strnlen). However, we use a safe word read to provide a speedup. +{ + memchr-value4 + Memcheck:Value4 + fun:rpl_memchr +} +{ + memchr-value8 + Memcheck:Value8 + fun:rpl_memchr +} diff --git a/lib/printf-args.c b/lib/printf-args.c new file mode 100644 index 000000000..c31d2042e --- /dev/null +++ b/lib/printf-args.c @@ -0,0 +1,187 @@ +/* Decomposed printf argument list. + Copyright (C) 1999, 2002-2003, 2005-2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +/* This file can be parametrized with the following macros: + ENABLE_UNISTDIO Set to 1 to enable the unistdio extensions. + PRINTF_FETCHARGS Name of the function to be defined. + STATIC Set to 'static' to declare the function static. */ + +#ifndef PRINTF_FETCHARGS +# include +#endif + +/* Specification. */ +#ifndef PRINTF_FETCHARGS +# include "printf-args.h" +#endif + +#ifdef STATIC +STATIC +#endif +int +PRINTF_FETCHARGS (va_list args, arguments *a) +{ + size_t i; + argument *ap; + + for (i = 0, ap = &a->arg[0]; i < a->count; i++, ap++) + switch (ap->type) + { + case TYPE_SCHAR: + ap->a.a_schar = va_arg (args, /*signed char*/ int); + break; + case TYPE_UCHAR: + ap->a.a_uchar = va_arg (args, /*unsigned char*/ int); + break; + case TYPE_SHORT: + ap->a.a_short = va_arg (args, /*short*/ int); + break; + case TYPE_USHORT: + ap->a.a_ushort = va_arg (args, /*unsigned short*/ int); + break; + case TYPE_INT: + ap->a.a_int = va_arg (args, int); + break; + case TYPE_UINT: + ap->a.a_uint = va_arg (args, unsigned int); + break; + case TYPE_LONGINT: + ap->a.a_longint = va_arg (args, long int); + break; + case TYPE_ULONGINT: + ap->a.a_ulongint = va_arg (args, unsigned long int); + break; +#if HAVE_LONG_LONG_INT + case TYPE_LONGLONGINT: + ap->a.a_longlongint = va_arg (args, long long int); + break; + case TYPE_ULONGLONGINT: + ap->a.a_ulonglongint = va_arg (args, unsigned long long int); + break; +#endif + case TYPE_DOUBLE: + ap->a.a_double = va_arg (args, double); + break; + case TYPE_LONGDOUBLE: + ap->a.a_longdouble = va_arg (args, long double); + break; + case TYPE_CHAR: + ap->a.a_char = va_arg (args, int); + break; +#if HAVE_WINT_T + case TYPE_WIDE_CHAR: + /* Although ISO C 99 7.24.1.(2) says that wint_t is "unchanged by + default argument promotions", this is not the case in mingw32, + where wint_t is 'unsigned short'. */ + ap->a.a_wide_char = + (sizeof (wint_t) < sizeof (int) + ? va_arg (args, int) + : va_arg (args, wint_t)); + break; +#endif + case TYPE_STRING: + ap->a.a_string = va_arg (args, const char *); + /* A null pointer is an invalid argument for "%s", but in practice + it occurs quite frequently in printf statements that produce + debug output. Use a fallback in this case. */ + if (ap->a.a_string == NULL) + ap->a.a_string = "(NULL)"; + break; +#if HAVE_WCHAR_T + case TYPE_WIDE_STRING: + ap->a.a_wide_string = va_arg (args, const wchar_t *); + /* A null pointer is an invalid argument for "%ls", but in practice + it occurs quite frequently in printf statements that produce + debug output. Use a fallback in this case. */ + if (ap->a.a_wide_string == NULL) + { + static const wchar_t wide_null_string[] = + { + (wchar_t)'(', + (wchar_t)'N', (wchar_t)'U', (wchar_t)'L', (wchar_t)'L', + (wchar_t)')', + (wchar_t)0 + }; + ap->a.a_wide_string = wide_null_string; + } + break; +#endif + case TYPE_POINTER: + ap->a.a_pointer = va_arg (args, void *); + break; + case TYPE_COUNT_SCHAR_POINTER: + ap->a.a_count_schar_pointer = va_arg (args, signed char *); + break; + case TYPE_COUNT_SHORT_POINTER: + ap->a.a_count_short_pointer = va_arg (args, short *); + break; + case TYPE_COUNT_INT_POINTER: + ap->a.a_count_int_pointer = va_arg (args, int *); + break; + case TYPE_COUNT_LONGINT_POINTER: + ap->a.a_count_longint_pointer = va_arg (args, long int *); + break; +#if HAVE_LONG_LONG_INT + case TYPE_COUNT_LONGLONGINT_POINTER: + ap->a.a_count_longlongint_pointer = va_arg (args, long long int *); + break; +#endif +#if ENABLE_UNISTDIO + /* The unistdio extensions. */ + case TYPE_U8_STRING: + ap->a.a_u8_string = va_arg (args, const uint8_t *); + /* A null pointer is an invalid argument for "%U", but in practice + it occurs quite frequently in printf statements that produce + debug output. Use a fallback in this case. */ + if (ap->a.a_u8_string == NULL) + { + static const uint8_t u8_null_string[] = + { '(', 'N', 'U', 'L', 'L', ')', 0 }; + ap->a.a_u8_string = u8_null_string; + } + break; + case TYPE_U16_STRING: + ap->a.a_u16_string = va_arg (args, const uint16_t *); + /* A null pointer is an invalid argument for "%lU", but in practice + it occurs quite frequently in printf statements that produce + debug output. Use a fallback in this case. */ + if (ap->a.a_u16_string == NULL) + { + static const uint16_t u16_null_string[] = + { '(', 'N', 'U', 'L', 'L', ')', 0 }; + ap->a.a_u16_string = u16_null_string; + } + break; + case TYPE_U32_STRING: + ap->a.a_u32_string = va_arg (args, const uint32_t *); + /* A null pointer is an invalid argument for "%llU", but in practice + it occurs quite frequently in printf statements that produce + debug output. Use a fallback in this case. */ + if (ap->a.a_u32_string == NULL) + { + static const uint32_t u32_null_string[] = + { '(', 'N', 'U', 'L', 'L', ')', 0 }; + ap->a.a_u32_string = u32_null_string; + } + break; +#endif + default: + /* Unknown type. */ + return -1; + } + return 0; +} diff --git a/lib/printf-args.h b/lib/printf-args.h new file mode 100644 index 000000000..4c68f115f --- /dev/null +++ b/lib/printf-args.h @@ -0,0 +1,154 @@ +/* Decomposed printf argument list. + Copyright (C) 1999, 2002-2003, 2006-2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _PRINTF_ARGS_H +#define _PRINTF_ARGS_H + +/* This file can be parametrized with the following macros: + ENABLE_UNISTDIO Set to 1 to enable the unistdio extensions. + PRINTF_FETCHARGS Name of the function to be declared. + STATIC Set to 'static' to declare the function static. */ + +/* Default parameters. */ +#ifndef PRINTF_FETCHARGS +# define PRINTF_FETCHARGS printf_fetchargs +#endif + +/* Get size_t. */ +#include + +/* Get wchar_t. */ +#if HAVE_WCHAR_T +# include +#endif + +/* Get wint_t. */ +#if HAVE_WINT_T +# include +#endif + +/* Get va_list. */ +#include + + +/* Argument types */ +typedef enum +{ + TYPE_NONE, + TYPE_SCHAR, + TYPE_UCHAR, + TYPE_SHORT, + TYPE_USHORT, + TYPE_INT, + TYPE_UINT, + TYPE_LONGINT, + TYPE_ULONGINT, +#if HAVE_LONG_LONG_INT + TYPE_LONGLONGINT, + TYPE_ULONGLONGINT, +#endif + TYPE_DOUBLE, + TYPE_LONGDOUBLE, + TYPE_CHAR, +#if HAVE_WINT_T + TYPE_WIDE_CHAR, +#endif + TYPE_STRING, +#if HAVE_WCHAR_T + TYPE_WIDE_STRING, +#endif + TYPE_POINTER, + TYPE_COUNT_SCHAR_POINTER, + TYPE_COUNT_SHORT_POINTER, + TYPE_COUNT_INT_POINTER, + TYPE_COUNT_LONGINT_POINTER +#if HAVE_LONG_LONG_INT +, TYPE_COUNT_LONGLONGINT_POINTER +#endif +#if ENABLE_UNISTDIO + /* The unistdio extensions. */ +, TYPE_U8_STRING +, TYPE_U16_STRING +, TYPE_U32_STRING +#endif +} arg_type; + +/* Polymorphic argument */ +typedef struct +{ + arg_type type; + union + { + signed char a_schar; + unsigned char a_uchar; + short a_short; + unsigned short a_ushort; + int a_int; + unsigned int a_uint; + long int a_longint; + unsigned long int a_ulongint; +#if HAVE_LONG_LONG_INT + long long int a_longlongint; + unsigned long long int a_ulonglongint; +#endif + float a_float; + double a_double; + long double a_longdouble; + int a_char; +#if HAVE_WINT_T + wint_t a_wide_char; +#endif + const char* a_string; +#if HAVE_WCHAR_T + const wchar_t* a_wide_string; +#endif + void* a_pointer; + signed char * a_count_schar_pointer; + short * a_count_short_pointer; + int * a_count_int_pointer; + long int * a_count_longint_pointer; +#if HAVE_LONG_LONG_INT + long long int * a_count_longlongint_pointer; +#endif +#if ENABLE_UNISTDIO + /* The unistdio extensions. */ + const uint8_t * a_u8_string; + const uint16_t * a_u16_string; + const uint32_t * a_u32_string; +#endif + } + a; +} +argument; + +typedef struct +{ + size_t count; + argument *arg; +} +arguments; + + +/* Fetch the arguments, putting them into a. */ +#ifdef STATIC +STATIC +#else +extern +#endif +int PRINTF_FETCHARGS (va_list args, arguments *a); + +#endif /* _PRINTF_ARGS_H */ diff --git a/lib/printf-parse.c b/lib/printf-parse.c new file mode 100644 index 000000000..85c454b22 --- /dev/null +++ b/lib/printf-parse.c @@ -0,0 +1,627 @@ +/* Formatted output to strings. + Copyright (C) 1999-2000, 2002-2003, 2006-2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +/* This file can be parametrized with the following macros: + CHAR_T The element type of the format string. + CHAR_T_ONLY_ASCII Set to 1 to enable verification that all characters + in the format string are ASCII. + DIRECTIVE Structure denoting a format directive. + Depends on CHAR_T. + DIRECTIVES Structure denoting the set of format directives of a + format string. Depends on CHAR_T. + PRINTF_PARSE Function that parses a format string. + Depends on CHAR_T. + STATIC Set to 'static' to declare the function static. + ENABLE_UNISTDIO Set to 1 to enable the unistdio extensions. */ + +#ifndef PRINTF_PARSE +# include +#endif + +/* Specification. */ +#ifndef PRINTF_PARSE +# include "printf-parse.h" +#endif + +/* Default parameters. */ +#ifndef PRINTF_PARSE +# define PRINTF_PARSE printf_parse +# define CHAR_T char +# define DIRECTIVE char_directive +# define DIRECTIVES char_directives +#endif + +/* Get size_t, NULL. */ +#include + +/* Get intmax_t. */ +#if defined IN_LIBINTL || defined IN_LIBASPRINTF +# if HAVE_STDINT_H_WITH_UINTMAX +# include +# endif +# if HAVE_INTTYPES_H_WITH_UINTMAX +# include +# endif +#else +# include +#endif + +/* malloc(), realloc(), free(). */ +#include + +/* errno. */ +#include + +/* Checked size_t computations. */ +#include "xsize.h" + +#if CHAR_T_ONLY_ASCII +/* c_isascii(). */ +# include "c-ctype.h" +#endif + +#ifdef STATIC +STATIC +#endif +int +PRINTF_PARSE (const CHAR_T *format, DIRECTIVES *d, arguments *a) +{ + const CHAR_T *cp = format; /* pointer into format */ + size_t arg_posn = 0; /* number of regular arguments consumed */ + size_t d_allocated; /* allocated elements of d->dir */ + size_t a_allocated; /* allocated elements of a->arg */ + size_t max_width_length = 0; + size_t max_precision_length = 0; + + d->count = 0; + d_allocated = 1; + d->dir = (DIRECTIVE *) malloc (d_allocated * sizeof (DIRECTIVE)); + if (d->dir == NULL) + /* Out of memory. */ + goto out_of_memory_1; + + a->count = 0; + a_allocated = 0; + a->arg = NULL; + +#define REGISTER_ARG(_index_,_type_) \ + { \ + size_t n = (_index_); \ + if (n >= a_allocated) \ + { \ + size_t memory_size; \ + argument *memory; \ + \ + a_allocated = xtimes (a_allocated, 2); \ + if (a_allocated <= n) \ + a_allocated = xsum (n, 1); \ + memory_size = xtimes (a_allocated, sizeof (argument)); \ + if (size_overflow_p (memory_size)) \ + /* Overflow, would lead to out of memory. */ \ + goto out_of_memory; \ + memory = (argument *) (a->arg \ + ? realloc (a->arg, memory_size) \ + : malloc (memory_size)); \ + if (memory == NULL) \ + /* Out of memory. */ \ + goto out_of_memory; \ + a->arg = memory; \ + } \ + while (a->count <= n) \ + a->arg[a->count++].type = TYPE_NONE; \ + if (a->arg[n].type == TYPE_NONE) \ + a->arg[n].type = (_type_); \ + else if (a->arg[n].type != (_type_)) \ + /* Ambiguous type for positional argument. */ \ + goto error; \ + } + + while (*cp != '\0') + { + CHAR_T c = *cp++; + if (c == '%') + { + size_t arg_index = ARG_NONE; + DIRECTIVE *dp = &d->dir[d->count]; /* pointer to next directive */ + + /* Initialize the next directive. */ + dp->dir_start = cp - 1; + dp->flags = 0; + dp->width_start = NULL; + dp->width_end = NULL; + dp->width_arg_index = ARG_NONE; + dp->precision_start = NULL; + dp->precision_end = NULL; + dp->precision_arg_index = ARG_NONE; + dp->arg_index = ARG_NONE; + + /* Test for positional argument. */ + if (*cp >= '0' && *cp <= '9') + { + const CHAR_T *np; + + for (np = cp; *np >= '0' && *np <= '9'; np++) + ; + if (*np == '$') + { + size_t n = 0; + + for (np = cp; *np >= '0' && *np <= '9'; np++) + n = xsum (xtimes (n, 10), *np - '0'); + if (n == 0) + /* Positional argument 0. */ + goto error; + if (size_overflow_p (n)) + /* n too large, would lead to out of memory later. */ + goto error; + arg_index = n - 1; + cp = np + 1; + } + } + + /* Read the flags. */ + for (;;) + { + if (*cp == '\'') + { + dp->flags |= FLAG_GROUP; + cp++; + } + else if (*cp == '-') + { + dp->flags |= FLAG_LEFT; + cp++; + } + else if (*cp == '+') + { + dp->flags |= FLAG_SHOWSIGN; + cp++; + } + else if (*cp == ' ') + { + dp->flags |= FLAG_SPACE; + cp++; + } + else if (*cp == '#') + { + dp->flags |= FLAG_ALT; + cp++; + } + else if (*cp == '0') + { + dp->flags |= FLAG_ZERO; + cp++; + } + else + break; + } + + /* Parse the field width. */ + if (*cp == '*') + { + dp->width_start = cp; + cp++; + dp->width_end = cp; + if (max_width_length < 1) + max_width_length = 1; + + /* Test for positional argument. */ + if (*cp >= '0' && *cp <= '9') + { + const CHAR_T *np; + + for (np = cp; *np >= '0' && *np <= '9'; np++) + ; + if (*np == '$') + { + size_t n = 0; + + for (np = cp; *np >= '0' && *np <= '9'; np++) + n = xsum (xtimes (n, 10), *np - '0'); + if (n == 0) + /* Positional argument 0. */ + goto error; + if (size_overflow_p (n)) + /* n too large, would lead to out of memory later. */ + goto error; + dp->width_arg_index = n - 1; + cp = np + 1; + } + } + if (dp->width_arg_index == ARG_NONE) + { + dp->width_arg_index = arg_posn++; + if (dp->width_arg_index == ARG_NONE) + /* arg_posn wrapped around. */ + goto error; + } + REGISTER_ARG (dp->width_arg_index, TYPE_INT); + } + else if (*cp >= '0' && *cp <= '9') + { + size_t width_length; + + dp->width_start = cp; + for (; *cp >= '0' && *cp <= '9'; cp++) + ; + dp->width_end = cp; + width_length = dp->width_end - dp->width_start; + if (max_width_length < width_length) + max_width_length = width_length; + } + + /* Parse the precision. */ + if (*cp == '.') + { + cp++; + if (*cp == '*') + { + dp->precision_start = cp - 1; + cp++; + dp->precision_end = cp; + if (max_precision_length < 2) + max_precision_length = 2; + + /* Test for positional argument. */ + if (*cp >= '0' && *cp <= '9') + { + const CHAR_T *np; + + for (np = cp; *np >= '0' && *np <= '9'; np++) + ; + if (*np == '$') + { + size_t n = 0; + + for (np = cp; *np >= '0' && *np <= '9'; np++) + n = xsum (xtimes (n, 10), *np - '0'); + if (n == 0) + /* Positional argument 0. */ + goto error; + if (size_overflow_p (n)) + /* n too large, would lead to out of memory + later. */ + goto error; + dp->precision_arg_index = n - 1; + cp = np + 1; + } + } + if (dp->precision_arg_index == ARG_NONE) + { + dp->precision_arg_index = arg_posn++; + if (dp->precision_arg_index == ARG_NONE) + /* arg_posn wrapped around. */ + goto error; + } + REGISTER_ARG (dp->precision_arg_index, TYPE_INT); + } + else + { + size_t precision_length; + + dp->precision_start = cp - 1; + for (; *cp >= '0' && *cp <= '9'; cp++) + ; + dp->precision_end = cp; + precision_length = dp->precision_end - dp->precision_start; + if (max_precision_length < precision_length) + max_precision_length = precision_length; + } + } + + { + arg_type type; + + /* Parse argument type/size specifiers. */ + { + int flags = 0; + + for (;;) + { + if (*cp == 'h') + { + flags |= (1 << (flags & 1)); + cp++; + } + else if (*cp == 'L') + { + flags |= 4; + cp++; + } + else if (*cp == 'l') + { + flags += 8; + cp++; + } + else if (*cp == 'j') + { + if (sizeof (intmax_t) > sizeof (long)) + { + /* intmax_t = long long */ + flags += 16; + } + else if (sizeof (intmax_t) > sizeof (int)) + { + /* intmax_t = long */ + flags += 8; + } + cp++; + } + else if (*cp == 'z' || *cp == 'Z') + { + /* 'z' is standardized in ISO C 99, but glibc uses 'Z' + because the warning facility in gcc-2.95.2 understands + only 'Z' (see gcc-2.95.2/gcc/c-common.c:1784). */ + if (sizeof (size_t) > sizeof (long)) + { + /* size_t = long long */ + flags += 16; + } + else if (sizeof (size_t) > sizeof (int)) + { + /* size_t = long */ + flags += 8; + } + cp++; + } + else if (*cp == 't') + { + if (sizeof (ptrdiff_t) > sizeof (long)) + { + /* ptrdiff_t = long long */ + flags += 16; + } + else if (sizeof (ptrdiff_t) > sizeof (int)) + { + /* ptrdiff_t = long */ + flags += 8; + } + cp++; + } +#if defined __APPLE__ && defined __MACH__ + /* On MacOS X 10.3, PRIdMAX is defined as "qd". + We cannot change it to "lld" because PRIdMAX must also + be understood by the system's printf routines. */ + else if (*cp == 'q') + { + if (64 / 8 > sizeof (long)) + { + /* int64_t = long long */ + flags += 16; + } + else + { + /* int64_t = long */ + flags += 8; + } + cp++; + } +#endif +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + /* On native Win32, PRIdMAX is defined as "I64d". + We cannot change it to "lld" because PRIdMAX must also + be understood by the system's printf routines. */ + else if (*cp == 'I' && cp[1] == '6' && cp[2] == '4') + { + if (64 / 8 > sizeof (long)) + { + /* __int64 = long long */ + flags += 16; + } + else + { + /* __int64 = long */ + flags += 8; + } + cp += 3; + } +#endif + else + break; + } + + /* Read the conversion character. */ + c = *cp++; + switch (c) + { + case 'd': case 'i': +#if HAVE_LONG_LONG_INT + /* If 'long long' exists and is larger than 'long': */ + if (flags >= 16 || (flags & 4)) + type = TYPE_LONGLONGINT; + else +#endif + /* If 'long long' exists and is the same as 'long', we parse + "lld" into TYPE_LONGINT. */ + if (flags >= 8) + type = TYPE_LONGINT; + else if (flags & 2) + type = TYPE_SCHAR; + else if (flags & 1) + type = TYPE_SHORT; + else + type = TYPE_INT; + break; + case 'o': case 'u': case 'x': case 'X': +#if HAVE_LONG_LONG_INT + /* If 'long long' exists and is larger than 'long': */ + if (flags >= 16 || (flags & 4)) + type = TYPE_ULONGLONGINT; + else +#endif + /* If 'unsigned long long' exists and is the same as + 'unsigned long', we parse "llu" into TYPE_ULONGINT. */ + if (flags >= 8) + type = TYPE_ULONGINT; + else if (flags & 2) + type = TYPE_UCHAR; + else if (flags & 1) + type = TYPE_USHORT; + else + type = TYPE_UINT; + break; + case 'f': case 'F': case 'e': case 'E': case 'g': case 'G': + case 'a': case 'A': + if (flags >= 16 || (flags & 4)) + type = TYPE_LONGDOUBLE; + else + type = TYPE_DOUBLE; + break; + case 'c': + if (flags >= 8) +#if HAVE_WINT_T + type = TYPE_WIDE_CHAR; +#else + goto error; +#endif + else + type = TYPE_CHAR; + break; +#if HAVE_WINT_T + case 'C': + type = TYPE_WIDE_CHAR; + c = 'c'; + break; +#endif + case 's': + if (flags >= 8) +#if HAVE_WCHAR_T + type = TYPE_WIDE_STRING; +#else + goto error; +#endif + else + type = TYPE_STRING; + break; +#if HAVE_WCHAR_T + case 'S': + type = TYPE_WIDE_STRING; + c = 's'; + break; +#endif + case 'p': + type = TYPE_POINTER; + break; + case 'n': +#if HAVE_LONG_LONG_INT + /* If 'long long' exists and is larger than 'long': */ + if (flags >= 16 || (flags & 4)) + type = TYPE_COUNT_LONGLONGINT_POINTER; + else +#endif + /* If 'long long' exists and is the same as 'long', we parse + "lln" into TYPE_COUNT_LONGINT_POINTER. */ + if (flags >= 8) + type = TYPE_COUNT_LONGINT_POINTER; + else if (flags & 2) + type = TYPE_COUNT_SCHAR_POINTER; + else if (flags & 1) + type = TYPE_COUNT_SHORT_POINTER; + else + type = TYPE_COUNT_INT_POINTER; + break; +#if ENABLE_UNISTDIO + /* The unistdio extensions. */ + case 'U': + if (flags >= 16) + type = TYPE_U32_STRING; + else if (flags >= 8) + type = TYPE_U16_STRING; + else + type = TYPE_U8_STRING; + break; +#endif + case '%': + type = TYPE_NONE; + break; + default: + /* Unknown conversion character. */ + goto error; + } + } + + if (type != TYPE_NONE) + { + dp->arg_index = arg_index; + if (dp->arg_index == ARG_NONE) + { + dp->arg_index = arg_posn++; + if (dp->arg_index == ARG_NONE) + /* arg_posn wrapped around. */ + goto error; + } + REGISTER_ARG (dp->arg_index, type); + } + dp->conversion = c; + dp->dir_end = cp; + } + + d->count++; + if (d->count >= d_allocated) + { + size_t memory_size; + DIRECTIVE *memory; + + d_allocated = xtimes (d_allocated, 2); + memory_size = xtimes (d_allocated, sizeof (DIRECTIVE)); + if (size_overflow_p (memory_size)) + /* Overflow, would lead to out of memory. */ + goto out_of_memory; + memory = (DIRECTIVE *) realloc (d->dir, memory_size); + if (memory == NULL) + /* Out of memory. */ + goto out_of_memory; + d->dir = memory; + } + } +#if CHAR_T_ONLY_ASCII + else if (!c_isascii (c)) + { + /* Non-ASCII character. Not supported. */ + goto error; + } +#endif + } + d->dir[d->count].dir_start = cp; + + d->max_width_length = max_width_length; + d->max_precision_length = max_precision_length; + return 0; + +error: + if (a->arg) + free (a->arg); + if (d->dir) + free (d->dir); + errno = EINVAL; + return -1; + +out_of_memory: + if (a->arg) + free (a->arg); + if (d->dir) + free (d->dir); +out_of_memory_1: + errno = ENOMEM; + return -1; +} + +#undef PRINTF_PARSE +#undef DIRECTIVES +#undef DIRECTIVE +#undef CHAR_T_ONLY_ASCII +#undef CHAR_T diff --git a/lib/printf-parse.h b/lib/printf-parse.h new file mode 100644 index 000000000..0a496cbda --- /dev/null +++ b/lib/printf-parse.h @@ -0,0 +1,179 @@ +/* Parse printf format string. + Copyright (C) 1999, 2002-2003, 2005, 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _PRINTF_PARSE_H +#define _PRINTF_PARSE_H + +/* This file can be parametrized with the following macros: + ENABLE_UNISTDIO Set to 1 to enable the unistdio extensions. + STATIC Set to 'static' to declare the function static. */ + +#include "printf-args.h" + + +/* Flags */ +#define FLAG_GROUP 1 /* ' flag */ +#define FLAG_LEFT 2 /* - flag */ +#define FLAG_SHOWSIGN 4 /* + flag */ +#define FLAG_SPACE 8 /* space flag */ +#define FLAG_ALT 16 /* # flag */ +#define FLAG_ZERO 32 + +/* arg_index value indicating that no argument is consumed. */ +#define ARG_NONE (~(size_t)0) + +/* xxx_directive: A parsed directive. + xxx_directives: A parsed format string. */ + +/* A parsed directive. */ +typedef struct +{ + const char* dir_start; + const char* dir_end; + int flags; + const char* width_start; + const char* width_end; + size_t width_arg_index; + const char* precision_start; + const char* precision_end; + size_t precision_arg_index; + char conversion; /* d i o u x X f F e E g G a A c s p n U % but not C S */ + size_t arg_index; +} +char_directive; + +/* A parsed format string. */ +typedef struct +{ + size_t count; + char_directive *dir; + size_t max_width_length; + size_t max_precision_length; +} +char_directives; + +#if ENABLE_UNISTDIO + +/* A parsed directive. */ +typedef struct +{ + const uint8_t* dir_start; + const uint8_t* dir_end; + int flags; + const uint8_t* width_start; + const uint8_t* width_end; + size_t width_arg_index; + const uint8_t* precision_start; + const uint8_t* precision_end; + size_t precision_arg_index; + uint8_t conversion; /* d i o u x X f F e E g G a A c s p n U % but not C S */ + size_t arg_index; +} +u8_directive; + +/* A parsed format string. */ +typedef struct +{ + size_t count; + u8_directive *dir; + size_t max_width_length; + size_t max_precision_length; +} +u8_directives; + +/* A parsed directive. */ +typedef struct +{ + const uint16_t* dir_start; + const uint16_t* dir_end; + int flags; + const uint16_t* width_start; + const uint16_t* width_end; + size_t width_arg_index; + const uint16_t* precision_start; + const uint16_t* precision_end; + size_t precision_arg_index; + uint16_t conversion; /* d i o u x X f F e E g G a A c s p n U % but not C S */ + size_t arg_index; +} +u16_directive; + +/* A parsed format string. */ +typedef struct +{ + size_t count; + u16_directive *dir; + size_t max_width_length; + size_t max_precision_length; +} +u16_directives; + +/* A parsed directive. */ +typedef struct +{ + const uint32_t* dir_start; + const uint32_t* dir_end; + int flags; + const uint32_t* width_start; + const uint32_t* width_end; + size_t width_arg_index; + const uint32_t* precision_start; + const uint32_t* precision_end; + size_t precision_arg_index; + uint32_t conversion; /* d i o u x X f F e E g G a A c s p n U % but not C S */ + size_t arg_index; +} +u32_directive; + +/* A parsed format string. */ +typedef struct +{ + size_t count; + u32_directive *dir; + size_t max_width_length; + size_t max_precision_length; +} +u32_directives; + +#endif + + +/* Parses the format string. Fills in the number N of directives, and fills + in directives[0], ..., directives[N-1], and sets directives[N].dir_start + to the end of the format string. Also fills in the arg_type fields of the + arguments and the needed count of arguments. */ +#if ENABLE_UNISTDIO +extern int + ulc_printf_parse (const char *format, char_directives *d, arguments *a); +extern int + u8_printf_parse (const uint8_t *format, u8_directives *d, arguments *a); +extern int + u16_printf_parse (const uint16_t *format, u16_directives *d, + arguments *a); +extern int + u32_printf_parse (const uint32_t *format, u32_directives *d, + arguments *a); +#else +# ifdef STATIC +STATIC +# else +extern +# endif +int printf_parse (const char *format, char_directives *d, arguments *a); +#endif + +#endif /* _PRINTF_PARSE_H */ diff --git a/lib/size_max.h b/lib/size_max.h new file mode 100644 index 000000000..419d73a18 --- /dev/null +++ b/lib/size_max.h @@ -0,0 +1,31 @@ +/* size_max.h -- declare SIZE_MAX through system headers + Copyright (C) 2005-2006 Free Software Foundation, Inc. + Written by Simon Josefsson. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef GNULIB_SIZE_MAX_H +#define GNULIB_SIZE_MAX_H + +/* Get SIZE_MAX declaration on systems like Solaris 7/8/9. */ +# include +/* Get SIZE_MAX declaration on systems like glibc 2. */ +# if HAVE_STDINT_H +# include +# endif +/* On systems where these include files don't define it, SIZE_MAX is defined + in config.h. */ + +#endif /* GNULIB_SIZE_MAX_H */ diff --git a/lib/stdio-write.c b/lib/stdio-write.c new file mode 100644 index 000000000..8f275ffb2 --- /dev/null +++ b/lib/stdio-write.c @@ -0,0 +1,148 @@ +/* POSIX compatible FILE stream write function. + Copyright (C) 2008 Free Software Foundation, Inc. + Written by Bruno Haible , 2008. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include + +/* Replace these functions only if module 'sigpipe' is requested. */ +#if GNULIB_SIGPIPE + +/* On native Windows platforms, SIGPIPE does not exist. When write() is + called on a pipe with no readers, WriteFile() fails with error + GetLastError() = ERROR_NO_DATA, and write() in consequence fails with + error EINVAL. This write() function is at the basis of the function + which flushes the buffer of a FILE stream. */ + +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +# include +# include +# include + +# define WIN32_LEAN_AND_MEAN /* avoid including junk */ +# include + +# define CALL_WITH_SIGPIPE_EMULATION(RETTYPE, EXPRESSION, FAILED) \ + if (ferror (stream)) \ + return (EXPRESSION); \ + else \ + { \ + RETTYPE ret; \ + SetLastError (0); \ + ret = (EXPRESSION); \ + if (FAILED && GetLastError () == ERROR_NO_DATA && ferror (stream)) \ + { \ + int fd = fileno (stream); \ + if (fd >= 0 \ + && GetFileType ((HANDLE) _get_osfhandle (fd)) == FILE_TYPE_PIPE)\ + { \ + /* Try to raise signal SIGPIPE. */ \ + raise (SIGPIPE); \ + /* If it is currently blocked or ignored, change errno from \ + EINVAL to EPIPE. */ \ + errno = EPIPE; \ + } \ + } \ + return ret; \ + } + +# if !REPLACE_PRINTF_POSIX /* avoid collision with printf.c */ +int +printf (const char *format, ...) +{ + int retval; + va_list args; + + va_start (args, format); + retval = vfprintf (stdout, format, args); + va_end (args); + + return retval; +} +# endif + +# if !REPLACE_FPRINTF_POSIX /* avoid collision with fprintf.c */ +int +fprintf (FILE *stream, const char *format, ...) +{ + int retval; + va_list args; + + va_start (args, format); + retval = vfprintf (stream, format, args); + va_end (args); + + return retval; +} +# endif + +# if !REPLACE_VFPRINTF_POSIX /* avoid collision with vprintf.c */ +int +vprintf (const char *format, va_list args) +{ + return vfprintf (stdout, format, args); +} +# endif + +# if !REPLACE_VPRINTF_POSIX /* avoid collision with vfprintf.c */ +int +vfprintf (FILE *stream, const char *format, va_list args) +#undef vfprintf +{ + CALL_WITH_SIGPIPE_EMULATION (int, vfprintf (stream, format, args), ret == EOF) +} +# endif + +int +putchar (int c) +{ + return fputc (c, stdout); +} + +int +fputc (int c, FILE *stream) +#undef fputc +{ + CALL_WITH_SIGPIPE_EMULATION (int, fputc (c, stream), ret == EOF) +} + +int +fputs (const char *string, FILE *stream) +#undef fputs +{ + CALL_WITH_SIGPIPE_EMULATION (int, fputs (string, stream), ret == EOF) +} + +int +puts (const char *string) +#undef puts +{ + FILE *stream = stdout; + CALL_WITH_SIGPIPE_EMULATION (int, puts (string), ret == EOF) +} + +size_t +fwrite (const void *ptr, size_t s, size_t n, FILE *stream) +#undef fwrite +{ + CALL_WITH_SIGPIPE_EMULATION (size_t, fwrite (ptr, s, n, stream), ret < n) +} + +# endif +#endif diff --git a/lib/stdio.in.h b/lib/stdio.in.h new file mode 100644 index 000000000..ae681fccc --- /dev/null +++ b/lib/stdio.in.h @@ -0,0 +1,542 @@ +/* A GNU-like . + + Copyright (C) 2004, 2007-2009 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +#if defined __need_FILE || defined __need___FILE +/* Special invocation convention inside glibc header files. */ + +#@INCLUDE_NEXT@ @NEXT_STDIO_H@ + +#else +/* Normal invocation convention. */ + +#ifndef _GL_STDIO_H + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_STDIO_H@ + +#ifndef _GL_STDIO_H +#define _GL_STDIO_H + +#include +#include + +#if (@GNULIB_FSEEKO@ && @REPLACE_FSEEKO@) \ + || (@GNULIB_FTELLO@ && @REPLACE_FTELLO@) \ + || (@GNULIB_GETDELIM@ && !@HAVE_DECL_GETDELIM@) \ + || (@GNULIB_GETLINE@ && (!@HAVE_DECL_GETLINE@ || @REPLACE_GETLINE@)) +/* Get off_t and ssize_t. */ +# include +#endif + +#ifndef __attribute__ +/* This feature is available in gcc versions 2.5 and later. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5) +# define __attribute__(Spec) /* empty */ +# endif +/* The __-protected variants of `format' and `printf' attributes + are accepted by gcc versions 2.6.4 (effectively 2.7) and later. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 7) +# define __format__ format +# define __printf__ printf +# endif +#endif + + +/* The definition of GL_LINK_WARNING is copied here. */ + + +#ifdef __cplusplus +extern "C" { +#endif + + +#if @GNULIB_FPRINTF_POSIX@ +# if @REPLACE_FPRINTF@ +# define fprintf rpl_fprintf +extern int fprintf (FILE *fp, const char *format, ...) + __attribute__ ((__format__ (__printf__, 2, 3))); +# endif +#elif @GNULIB_FPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# define fprintf rpl_fprintf +extern int fprintf (FILE *fp, const char *format, ...) + __attribute__ ((__format__ (__printf__, 2, 3))); +#elif defined GNULIB_POSIXCHECK +# undef fprintf +# define fprintf \ + (GL_LINK_WARNING ("fprintf is not always POSIX compliant - " \ + "use gnulib module fprintf-posix for portable " \ + "POSIX compliance"), \ + fprintf) +#endif + +#if @GNULIB_VFPRINTF_POSIX@ +# if @REPLACE_VFPRINTF@ +# define vfprintf rpl_vfprintf +extern int vfprintf (FILE *fp, const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 2, 0))); +# endif +#elif @GNULIB_VFPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# define vfprintf rpl_vfprintf +extern int vfprintf (FILE *fp, const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 2, 0))); +#elif defined GNULIB_POSIXCHECK +# undef vfprintf +# define vfprintf(s,f,a) \ + (GL_LINK_WARNING ("vfprintf is not always POSIX compliant - " \ + "use gnulib module vfprintf-posix for portable " \ + "POSIX compliance"), \ + vfprintf (s, f, a)) +#endif + +#if @GNULIB_PRINTF_POSIX@ +# if @REPLACE_PRINTF@ +/* Don't break __attribute__((format(printf,M,N))). */ +# define printf __printf__ +extern int printf (const char *format, ...) + __attribute__ ((__format__ (__printf__, 1, 2))); +# endif +#elif @GNULIB_PRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +/* Don't break __attribute__((format(printf,M,N))). */ +# define printf __printf__ +extern int printf (const char *format, ...) + __attribute__ ((__format__ (__printf__, 1, 2))); +#elif defined GNULIB_POSIXCHECK +# undef printf +# define printf \ + (GL_LINK_WARNING ("printf is not always POSIX compliant - " \ + "use gnulib module printf-posix for portable " \ + "POSIX compliance"), \ + printf) +/* Don't break __attribute__((format(printf,M,N))). */ +# define format(kind,m,n) format (__##kind##__, m, n) +# define __format__(kind,m,n) __format__ (__##kind##__, m, n) +# define ____printf____ __printf__ +# define ____scanf____ __scanf__ +# define ____strftime____ __strftime__ +# define ____strfmon____ __strfmon__ +#endif + +#if @GNULIB_VPRINTF_POSIX@ +# if @REPLACE_VPRINTF@ +# define vprintf rpl_vprintf +extern int vprintf (const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 1, 0))); +# endif +#elif @GNULIB_VPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# define vprintf rpl_vprintf +extern int vprintf (const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 1, 0))); +#elif defined GNULIB_POSIXCHECK +# undef vprintf +# define vprintf(f,a) \ + (GL_LINK_WARNING ("vprintf is not always POSIX compliant - " \ + "use gnulib module vprintf-posix for portable " \ + "POSIX compliance"), \ + vprintf (f, a)) +#endif + +#if @GNULIB_SNPRINTF@ +# if @REPLACE_SNPRINTF@ +# define snprintf rpl_snprintf +# endif +# if @REPLACE_SNPRINTF@ || !@HAVE_DECL_SNPRINTF@ +extern int snprintf (char *str, size_t size, const char *format, ...) + __attribute__ ((__format__ (__printf__, 3, 4))); +# endif +#elif defined GNULIB_POSIXCHECK +# undef snprintf +# define snprintf \ + (GL_LINK_WARNING ("snprintf is unportable - " \ + "use gnulib module snprintf for portability"), \ + snprintf) +#endif + +#if @GNULIB_VSNPRINTF@ +# if @REPLACE_VSNPRINTF@ +# define vsnprintf rpl_vsnprintf +# endif +# if @REPLACE_VSNPRINTF@ || !@HAVE_DECL_VSNPRINTF@ +extern int vsnprintf (char *str, size_t size, const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 3, 0))); +# endif +#elif defined GNULIB_POSIXCHECK +# undef vsnprintf +# define vsnprintf(b,s,f,a) \ + (GL_LINK_WARNING ("vsnprintf is unportable - " \ + "use gnulib module vsnprintf for portability"), \ + vsnprintf (b, s, f, a)) +#endif + +#if @GNULIB_SPRINTF_POSIX@ +# if @REPLACE_SPRINTF@ +# define sprintf rpl_sprintf +extern int sprintf (char *str, const char *format, ...) + __attribute__ ((__format__ (__printf__, 2, 3))); +# endif +#elif defined GNULIB_POSIXCHECK +# undef sprintf +# define sprintf \ + (GL_LINK_WARNING ("sprintf is not always POSIX compliant - " \ + "use gnulib module sprintf-posix for portable " \ + "POSIX compliance"), \ + sprintf) +#endif + +#if @GNULIB_VSPRINTF_POSIX@ +# if @REPLACE_VSPRINTF@ +# define vsprintf rpl_vsprintf +extern int vsprintf (char *str, const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 2, 0))); +# endif +#elif defined GNULIB_POSIXCHECK +# undef vsprintf +# define vsprintf(b,f,a) \ + (GL_LINK_WARNING ("vsprintf is not always POSIX compliant - " \ + "use gnulib module vsprintf-posix for portable " \ + "POSIX compliance"), \ + vsprintf (b, f, a)) +#endif + +#if @GNULIB_DPRINTF@ +# if @REPLACE_DPRINTF@ +# define dprintf rpl_dprintf +# endif +# if @REPLACE_DPRINTF@ || !@HAVE_DPRINTF@ +extern int dprintf (int fd, const char *format, ...) + __attribute__ ((__format__ (__printf__, 2, 3))); +# endif +#elif defined GNULIB_POSIXCHECK +# undef dprintf +# define dprintf(d,f,a) \ + (GL_LINK_WARNING ("dprintf is unportable - " \ + "use gnulib module dprintf for portability"), \ + dprintf (d, f, a)) +#endif + +#if @GNULIB_VDPRINTF@ +# if @REPLACE_VDPRINTF@ +# define vdprintf rpl_vdprintf +# endif +# if @REPLACE_VDPRINTF@ || !@HAVE_VDPRINTF@ +extern int vdprintf (int fd, const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 2, 0))); +# endif +#elif defined GNULIB_POSIXCHECK +# undef vdprintf +# define vdprintf(d,f,a) \ + (GL_LINK_WARNING ("vdprintf is unportable - " \ + "use gnulib module vdprintf for portability"), \ + vdprintf (d, f, a)) +#endif + +#if @GNULIB_VASPRINTF@ +# if @REPLACE_VASPRINTF@ +# define asprintf rpl_asprintf +# define vasprintf rpl_vasprintf +# endif +# if @REPLACE_VASPRINTF@ || !@HAVE_VASPRINTF@ + /* Write formatted output to a string dynamically allocated with malloc(). + If the memory allocation succeeds, store the address of the string in + *RESULT and return the number of resulting bytes, excluding the trailing + NUL. Upon memory allocation error, or some other error, return -1. */ + extern int asprintf (char **result, const char *format, ...) + __attribute__ ((__format__ (__printf__, 2, 3))); + extern int vasprintf (char **result, const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 2, 0))); +# endif +#endif + +#if @GNULIB_OBSTACK_PRINTF@ +# if @REPLACE_OBSTACK_PRINTF@ +# define obstack_printf rpl_osbtack_printf +# define obstack_vprintf rpl_obstack_vprintf +# endif +# if @REPLACE_OBSTACK_PRINTF@ || !@HAVE_DECL_OBSTACK_PRINTF@ + struct obstack; + /* Grow an obstack with formatted output. Return the number of + bytes added to OBS. No trailing nul byte is added, and the + object should be closed with obstack_finish before use. Upon + memory allocation error, call obstack_alloc_failed_handler. Upon + other error, return -1. */ + extern int obstack_printf (struct obstack *obs, const char *format, ...) + __attribute__ ((__format__ (__printf__, 2, 3))); + extern int obstack_vprintf (struct obstack *obs, const char *format, + va_list args) + __attribute__ ((__format__ (__printf__, 2, 0))); +# endif +#endif + +#if @GNULIB_FOPEN@ +# if @REPLACE_FOPEN@ +# undef fopen +# define fopen rpl_fopen +extern FILE * fopen (const char *filename, const char *mode); +# endif +#elif defined GNULIB_POSIXCHECK +# undef fopen +# define fopen(f,m) \ + (GL_LINK_WARNING ("fopen on Win32 platforms is not POSIX compatible - " \ + "use gnulib module fopen for portability"), \ + fopen (f, m)) +#endif + +#if @GNULIB_FREOPEN@ +# if @REPLACE_FREOPEN@ +# undef freopen +# define freopen rpl_freopen +extern FILE * freopen (const char *filename, const char *mode, FILE *stream); +# endif +#elif defined GNULIB_POSIXCHECK +# undef freopen +# define freopen(f,m,s) \ + (GL_LINK_WARNING ("freopen on Win32 platforms is not POSIX compatible - " \ + "use gnulib module freopen for portability"), \ + freopen (f, m, s)) +#endif + +#if @GNULIB_FSEEKO@ +# if @REPLACE_FSEEKO@ +/* Provide fseek, fseeko functions that are aware of a preceding + fflush(), and which detect pipes. */ +# define fseeko rpl_fseeko +extern int fseeko (FILE *fp, off_t offset, int whence); +# define fseek(fp, offset, whence) fseeko (fp, (off_t)(offset), whence) +# endif +#elif defined GNULIB_POSIXCHECK +# undef fseeko +# define fseeko(f,o,w) \ + (GL_LINK_WARNING ("fseeko is unportable - " \ + "use gnulib module fseeko for portability"), \ + fseeko (f, o, w)) +#endif + +#if @GNULIB_FSEEK@ && @REPLACE_FSEEK@ +extern int rpl_fseek (FILE *fp, long offset, int whence); +# undef fseek +# if defined GNULIB_POSIXCHECK +# define fseek(f,o,w) \ + (GL_LINK_WARNING ("fseek cannot handle files larger than 4 GB " \ + "on 32-bit platforms - " \ + "use fseeko function for handling of large files"), \ + rpl_fseek (f, o, w)) +# else +# define fseek rpl_fseek +# endif +#elif defined GNULIB_POSIXCHECK +# ifndef fseek +# define fseek(f,o,w) \ + (GL_LINK_WARNING ("fseek cannot handle files larger than 4 GB " \ + "on 32-bit platforms - " \ + "use fseeko function for handling of large files"), \ + fseek (f, o, w)) +# endif +#endif + +#if @GNULIB_FTELLO@ +# if @REPLACE_FTELLO@ +# define ftello rpl_ftello +extern off_t ftello (FILE *fp); +# define ftell(fp) ftello (fp) +# endif +#elif defined GNULIB_POSIXCHECK +# undef ftello +# define ftello(f) \ + (GL_LINK_WARNING ("ftello is unportable - " \ + "use gnulib module ftello for portability"), \ + ftello (f)) +#endif + +#if @GNULIB_FTELL@ && @REPLACE_FTELL@ +extern long rpl_ftell (FILE *fp); +# undef ftell +# if GNULIB_POSIXCHECK +# define ftell(f) \ + (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \ + "on 32-bit platforms - " \ + "use ftello function for handling of large files"), \ + rpl_ftell (f)) +# else +# define ftell rpl_ftell +# endif +#elif defined GNULIB_POSIXCHECK +# ifndef ftell +# define ftell(f) \ + (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \ + "on 32-bit platforms - " \ + "use ftello function for handling of large files"), \ + ftell (f)) +# endif +#endif + +#if @GNULIB_FFLUSH@ +# if @REPLACE_FFLUSH@ +# define fflush rpl_fflush + /* Flush all pending data on STREAM according to POSIX rules. Both + output and seekable input streams are supported. + Note! LOSS OF DATA can occur if fflush is applied on an input stream + that is _not_seekable_ or on an update stream that is _not_seekable_ + and in which the most recent operation was input. Seekability can + be tested with lseek(fileno(fp),0,SEEK_CUR). */ + extern int fflush (FILE *gl_stream); +# endif +#elif defined GNULIB_POSIXCHECK +# undef fflush +# define fflush(f) \ + (GL_LINK_WARNING ("fflush is not always POSIX compliant - " \ + "use gnulib module fflush for portable " \ + "POSIX compliance"), \ + fflush (f)) +#endif + +#if @GNULIB_FPURGE@ +# if @REPLACE_FPURGE@ +# define fpurge rpl_fpurge +# endif +# if @REPLACE_FPURGE@ || !@HAVE_DECL_FPURGE@ + /* Discard all pending buffered I/O data on STREAM. + STREAM must not be wide-character oriented. + Return 0 if successful. Upon error, return -1 and set errno. */ + extern int fpurge (FILE *gl_stream); +# endif +#elif defined GNULIB_POSIXCHECK +# undef fpurge +# define fpurge(f) \ + (GL_LINK_WARNING ("fpurge is not always present - " \ + "use gnulib module fpurge for portability"), \ + fpurge (f)) +#endif + +#if @GNULIB_FCLOSE@ +# if @REPLACE_FCLOSE@ +# define fclose rpl_fclose + /* Close STREAM and its underlying file descriptor. */ +extern int fclose (FILE *stream); +# endif +#elif defined GNULIB_POSIXCHECK +# undef fclose +# define fclose(f) \ + (GL_LINK_WARNING ("fclose is not always POSIX compliant - " \ + "use gnulib module fclose for portable " \ + "POSIX compliance"), \ + fclose (f)) +#endif + +#if @GNULIB_FPUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# undef fputc +# define fputc rpl_fputc +extern int fputc (int c, FILE *stream); +#endif + +#if @GNULIB_PUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# undef putc +# define putc rpl_fputc +extern int putc (int c, FILE *stream); +#endif + +#if @GNULIB_PUTCHAR@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# undef putchar +# define putchar rpl_putchar +extern int putchar (int c); +#endif + +#if @GNULIB_FPUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# undef fputs +# define fputs rpl_fputs +extern int fputs (const char *string, FILE *stream); +#endif + +#if @GNULIB_PUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# undef puts +# define puts rpl_puts +extern int puts (const char *string); +#endif + +#if @GNULIB_FWRITE@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@ +# undef fwrite +# define fwrite rpl_fwrite +extern size_t fwrite (const void *ptr, size_t s, size_t n, FILE *stream); +#endif + +#if @GNULIB_GETDELIM@ +# if !@HAVE_DECL_GETDELIM@ +/* Read input, up to (and including) the next occurrence of DELIMITER, from + STREAM, store it in *LINEPTR (and NUL-terminate it). + *LINEPTR is a pointer returned from malloc (or NULL), pointing to *LINESIZE + bytes of space. It is realloc'd as necessary. + Return the number of bytes read and stored at *LINEPTR (not including the + NUL terminator), or -1 on error or EOF. */ +extern ssize_t getdelim (char **lineptr, size_t *linesize, int delimiter, + FILE *stream); +# endif +#elif defined GNULIB_POSIXCHECK +# undef getdelim +# define getdelim(l, s, d, f) \ + (GL_LINK_WARNING ("getdelim is unportable - " \ + "use gnulib module getdelim for portability"), \ + getdelim (l, s, d, f)) +#endif + +#if @GNULIB_GETLINE@ +# if @REPLACE_GETLINE@ +# undef getline +# define getline rpl_getline +# endif +# if !@HAVE_DECL_GETLINE@ || @REPLACE_GETLINE@ +/* Read a line, up to (and including) the next newline, from STREAM, store it + in *LINEPTR (and NUL-terminate it). + *LINEPTR is a pointer returned from malloc (or NULL), pointing to *LINESIZE + bytes of space. It is realloc'd as necessary. + Return the number of bytes read and stored at *LINEPTR (not including the + NUL terminator), or -1 on error or EOF. */ +extern ssize_t getline (char **lineptr, size_t *linesize, FILE *stream); +# endif +#elif defined GNULIB_POSIXCHECK +# undef getline +# define getline(l, s, f) \ + (GL_LINK_WARNING ("getline is unportable - " \ + "use gnulib module getline for portability"), \ + getline (l, s, f)) +#endif + +#if @GNULIB_PERROR@ +# if @REPLACE_PERROR@ +# define perror rpl_perror +/* Print a message to standard error, describing the value of ERRNO, + (if STRING is not NULL and not empty) prefixed with STRING and ": ", + and terminated with a newline. */ +extern void perror (const char *string); +# endif +#elif defined GNULIB_POSIXCHECK +# undef perror +# define perror(s) \ + (GL_LINK_WARNING ("perror is not always POSIX compliant - " \ + "use gnulib module perror for portability"), \ + perror (s)) +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* _GL_STDIO_H */ +#endif /* _GL_STDIO_H */ +#endif diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c new file mode 100644 index 000000000..c620b4c06 --- /dev/null +++ b/lib/vasnprintf.c @@ -0,0 +1,5487 @@ +/* vsprintf with automatic memory allocation. + Copyright (C) 1999, 2002-2009 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +/* This file can be parametrized with the following macros: + VASNPRINTF The name of the function being defined. + FCHAR_T The element type of the format string. + DCHAR_T The element type of the destination (result) string. + FCHAR_T_ONLY_ASCII Set to 1 to enable verification that all characters + in the format string are ASCII. MUST be set if + FCHAR_T and DCHAR_T are not the same type. + DIRECTIVE Structure denoting a format directive. + Depends on FCHAR_T. + DIRECTIVES Structure denoting the set of format directives of a + format string. Depends on FCHAR_T. + PRINTF_PARSE Function that parses a format string. + Depends on FCHAR_T. + DCHAR_CPY memcpy like function for DCHAR_T[] arrays. + DCHAR_SET memset like function for DCHAR_T[] arrays. + DCHAR_MBSNLEN mbsnlen like function for DCHAR_T[] arrays. + SNPRINTF The system's snprintf (or similar) function. + This may be either snprintf or swprintf. + TCHAR_T The element type of the argument and result string + of the said SNPRINTF function. This may be either + char or wchar_t. The code exploits that + sizeof (TCHAR_T) | sizeof (DCHAR_T) and + alignof (TCHAR_T) <= alignof (DCHAR_T). + DCHAR_IS_TCHAR Set to 1 if DCHAR_T and TCHAR_T are the same type. + DCHAR_CONV_FROM_ENCODING A function to convert from char[] to DCHAR[]. + DCHAR_IS_UINT8_T Set to 1 if DCHAR_T is uint8_t. + DCHAR_IS_UINT16_T Set to 1 if DCHAR_T is uint16_t. + DCHAR_IS_UINT32_T Set to 1 if DCHAR_T is uint32_t. */ + +/* Tell glibc's to provide a prototype for snprintf(). + This must come before because may include + , and once has been included, it's too late. */ +#ifndef _GNU_SOURCE +# define _GNU_SOURCE 1 +#endif + +#ifndef VASNPRINTF +# include +#endif +#ifndef IN_LIBINTL +# include +#endif + +/* Specification. */ +#ifndef VASNPRINTF +# if WIDE_CHAR_VERSION +# include "vasnwprintf.h" +# else +# include "vasnprintf.h" +# endif +#endif + +#include /* localeconv() */ +#include /* snprintf(), sprintf() */ +#include /* abort(), malloc(), realloc(), free() */ +#include /* memcpy(), strlen() */ +#include /* errno */ +#include /* CHAR_BIT */ +#include /* DBL_MAX_EXP, LDBL_MAX_EXP */ +#if HAVE_NL_LANGINFO +# include +#endif +#ifndef VASNPRINTF +# if WIDE_CHAR_VERSION +# include "wprintf-parse.h" +# else +# include "printf-parse.h" +# endif +#endif + +/* Checked size_t computations. */ +#include "xsize.h" + +#if (NEED_PRINTF_DOUBLE || NEED_PRINTF_LONG_DOUBLE) && !defined IN_LIBINTL +# include +# include "float+.h" +#endif + +#if (NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_DOUBLE) && !defined IN_LIBINTL +# include +# include "isnand-nolibm.h" +#endif + +#if (NEED_PRINTF_LONG_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE) && !defined IN_LIBINTL +# include +# include "isnanl-nolibm.h" +# include "fpucw.h" +#endif + +#if (NEED_PRINTF_DIRECTIVE_A || NEED_PRINTF_DOUBLE) && !defined IN_LIBINTL +# include +# include "isnand-nolibm.h" +# include "printf-frexp.h" +#endif + +#if (NEED_PRINTF_DIRECTIVE_A || NEED_PRINTF_LONG_DOUBLE) && !defined IN_LIBINTL +# include +# include "isnanl-nolibm.h" +# include "printf-frexpl.h" +# include "fpucw.h" +#endif + +/* Default parameters. */ +#ifndef VASNPRINTF +# if WIDE_CHAR_VERSION +# define VASNPRINTF vasnwprintf +# define FCHAR_T wchar_t +# define DCHAR_T wchar_t +# define TCHAR_T wchar_t +# define DCHAR_IS_TCHAR 1 +# define DIRECTIVE wchar_t_directive +# define DIRECTIVES wchar_t_directives +# define PRINTF_PARSE wprintf_parse +# define DCHAR_CPY wmemcpy +# define DCHAR_SET wmemset +# else +# define VASNPRINTF vasnprintf +# define FCHAR_T char +# define DCHAR_T char +# define TCHAR_T char +# define DCHAR_IS_TCHAR 1 +# define DIRECTIVE char_directive +# define DIRECTIVES char_directives +# define PRINTF_PARSE printf_parse +# define DCHAR_CPY memcpy +# define DCHAR_SET memset +# endif +#endif +#if WIDE_CHAR_VERSION + /* TCHAR_T is wchar_t. */ +# define USE_SNPRINTF 1 +# if HAVE_DECL__SNWPRINTF + /* On Windows, the function swprintf() has a different signature than + on Unix; we use the _snwprintf() function instead. */ +# define SNPRINTF _snwprintf +# else + /* Unix. */ +# define SNPRINTF swprintf +# endif +#else + /* TCHAR_T is char. */ + /* Use snprintf if it exists under the name 'snprintf' or '_snprintf'. + But don't use it on BeOS, since BeOS snprintf produces no output if the + size argument is >= 0x3000000. + Also don't use it on Linux libc5, since there snprintf with size = 1 + writes any output without bounds, like sprintf. */ +# if (HAVE_DECL__SNPRINTF || HAVE_SNPRINTF) && !defined __BEOS__ && !(__GNU_LIBRARY__ == 1) +# define USE_SNPRINTF 1 +# else +# define USE_SNPRINTF 0 +# endif +# if HAVE_DECL__SNPRINTF + /* Windows. */ +# define SNPRINTF _snprintf +# else + /* Unix. */ +# define SNPRINTF snprintf + /* Here we need to call the native snprintf, not rpl_snprintf. */ +# undef snprintf +# endif +#endif +/* Here we need to call the native sprintf, not rpl_sprintf. */ +#undef sprintf + +/* GCC >= 4.0 with -Wall emits unjustified "... may be used uninitialized" + warnings in this file. Use -Dlint to suppress them. */ +#ifdef lint +# define IF_LINT(Code) Code +#else +# define IF_LINT(Code) /* empty */ +#endif + +/* Avoid some warnings from "gcc -Wshadow". + This file doesn't use the exp() and remainder() functions. */ +#undef exp +#define exp expo +#undef remainder +#define remainder rem + +#if !USE_SNPRINTF && !WIDE_CHAR_VERSION +# if (HAVE_STRNLEN && !defined _AIX) +# define local_strnlen strnlen +# else +# ifndef local_strnlen_defined +# define local_strnlen_defined 1 +static size_t +local_strnlen (const char *string, size_t maxlen) +{ + const char *end = memchr (string, '\0', maxlen); + return end ? (size_t) (end - string) : maxlen; +} +# endif +# endif +#endif + +#if (!USE_SNPRINTF || (NEED_PRINTF_DIRECTIVE_LS && !defined IN_LIBINTL)) && HAVE_WCHAR_T && (WIDE_CHAR_VERSION || DCHAR_IS_TCHAR) +# if HAVE_WCSLEN +# define local_wcslen wcslen +# else + /* Solaris 2.5.1 has wcslen() in a separate library libw.so. To avoid + a dependency towards this library, here is a local substitute. + Define this substitute only once, even if this file is included + twice in the same compilation unit. */ +# ifndef local_wcslen_defined +# define local_wcslen_defined 1 +static size_t +local_wcslen (const wchar_t *s) +{ + const wchar_t *ptr; + + for (ptr = s; *ptr != (wchar_t) 0; ptr++) + ; + return ptr - s; +} +# endif +# endif +#endif + +#if !USE_SNPRINTF && HAVE_WCHAR_T && WIDE_CHAR_VERSION +# if HAVE_WCSNLEN +# define local_wcsnlen wcsnlen +# else +# ifndef local_wcsnlen_defined +# define local_wcsnlen_defined 1 +static size_t +local_wcsnlen (const wchar_t *s, size_t maxlen) +{ + const wchar_t *ptr; + + for (ptr = s; maxlen > 0 && *ptr != (wchar_t) 0; ptr++, maxlen--) + ; + return ptr - s; +} +# endif +# endif +#endif + +#if (NEED_PRINTF_DIRECTIVE_A || NEED_PRINTF_LONG_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE || NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_DOUBLE) && !defined IN_LIBINTL +/* Determine the decimal-point character according to the current locale. */ +# ifndef decimal_point_char_defined +# define decimal_point_char_defined 1 +static char +decimal_point_char () +{ + const char *point; + /* Determine it in a multithread-safe way. We know nl_langinfo is + multithread-safe on glibc systems, but is not required to be multithread- + safe by POSIX. sprintf(), however, is multithread-safe. localeconv() + is rarely multithread-safe. */ +# if HAVE_NL_LANGINFO && __GLIBC__ + point = nl_langinfo (RADIXCHAR); +# elif 1 + char pointbuf[5]; + sprintf (pointbuf, "%#.0f", 1.0); + point = &pointbuf[1]; +# else + point = localeconv () -> decimal_point; +# endif + /* The decimal point is always a single byte: either '.' or ','. */ + return (point[0] != '\0' ? point[0] : '.'); +} +# endif +#endif + +#if NEED_PRINTF_INFINITE_DOUBLE && !NEED_PRINTF_DOUBLE && !defined IN_LIBINTL + +/* Equivalent to !isfinite(x) || x == 0, but does not require libm. */ +static int +is_infinite_or_zero (double x) +{ + return isnand (x) || x + x == x; +} + +#endif + +#if NEED_PRINTF_INFINITE_LONG_DOUBLE && !NEED_PRINTF_LONG_DOUBLE && !defined IN_LIBINTL + +/* Equivalent to !isfinite(x) || x == 0, but does not require libm. */ +static int +is_infinite_or_zerol (long double x) +{ + return isnanl (x) || x + x == x; +} + +#endif + +#if (NEED_PRINTF_LONG_DOUBLE || NEED_PRINTF_DOUBLE) && !defined IN_LIBINTL + +/* Converting 'long double' to decimal without rare rounding bugs requires + real bignums. We use the naming conventions of GNU gmp, but vastly simpler + (and slower) algorithms. */ + +typedef unsigned int mp_limb_t; +# define GMP_LIMB_BITS 32 +typedef int mp_limb_verify[2 * (sizeof (mp_limb_t) * CHAR_BIT == GMP_LIMB_BITS) - 1]; + +typedef unsigned long long mp_twolimb_t; +# define GMP_TWOLIMB_BITS 64 +typedef int mp_twolimb_verify[2 * (sizeof (mp_twolimb_t) * CHAR_BIT == GMP_TWOLIMB_BITS) - 1]; + +/* Representation of a bignum >= 0. */ +typedef struct +{ + size_t nlimbs; + mp_limb_t *limbs; /* Bits in little-endian order, allocated with malloc(). */ +} mpn_t; + +/* Compute the product of two bignums >= 0. + Return the allocated memory in case of success, NULL in case of memory + allocation failure. */ +static void * +multiply (mpn_t src1, mpn_t src2, mpn_t *dest) +{ + const mp_limb_t *p1; + const mp_limb_t *p2; + size_t len1; + size_t len2; + + if (src1.nlimbs <= src2.nlimbs) + { + len1 = src1.nlimbs; + p1 = src1.limbs; + len2 = src2.nlimbs; + p2 = src2.limbs; + } + else + { + len1 = src2.nlimbs; + p1 = src2.limbs; + len2 = src1.nlimbs; + p2 = src1.limbs; + } + /* Now 0 <= len1 <= len2. */ + if (len1 == 0) + { + /* src1 or src2 is zero. */ + dest->nlimbs = 0; + dest->limbs = (mp_limb_t *) malloc (1); + } + else + { + /* Here 1 <= len1 <= len2. */ + size_t dlen; + mp_limb_t *dp; + size_t k, i, j; + + dlen = len1 + len2; + dp = (mp_limb_t *) malloc (dlen * sizeof (mp_limb_t)); + if (dp == NULL) + return NULL; + for (k = len2; k > 0; ) + dp[--k] = 0; + for (i = 0; i < len1; i++) + { + mp_limb_t digit1 = p1[i]; + mp_twolimb_t carry = 0; + for (j = 0; j < len2; j++) + { + mp_limb_t digit2 = p2[j]; + carry += (mp_twolimb_t) digit1 * (mp_twolimb_t) digit2; + carry += dp[i + j]; + dp[i + j] = (mp_limb_t) carry; + carry = carry >> GMP_LIMB_BITS; + } + dp[i + len2] = (mp_limb_t) carry; + } + /* Normalise. */ + while (dlen > 0 && dp[dlen - 1] == 0) + dlen--; + dest->nlimbs = dlen; + dest->limbs = dp; + } + return dest->limbs; +} + +/* Compute the quotient of a bignum a >= 0 and a bignum b > 0. + a is written as a = q * b + r with 0 <= r < b. q is the quotient, r + the remainder. + Finally, round-to-even is performed: If r > b/2 or if r = b/2 and q is odd, + q is incremented. + Return the allocated memory in case of success, NULL in case of memory + allocation failure. */ +static void * +divide (mpn_t a, mpn_t b, mpn_t *q) +{ + /* Algorithm: + First normalise a and b: a=[a[m-1],...,a[0]], b=[b[n-1],...,b[0]] + with m>=0 and n>0 (in base beta = 2^GMP_LIMB_BITS). + If m=n=1, perform a single-precision division: + r:=0, j:=m, + while j>0 do + {Here (q[m-1]*beta^(m-1)+...+q[j]*beta^j) * b[0] + r*beta^j = + = a[m-1]*beta^(m-1)+...+a[j]*beta^j und 0<=r=n>1, perform a multiple-precision division: + We have a/b < beta^(m-n+1). + s:=intDsize-1-(highest bit in b[n-1]), 0<=s=beta/2. + For j=m-n,...,0: {Here 0 <= r < b*beta^(j+1).} + Compute q* : + q* := floor((r[j+n]*beta+r[j+n-1])/b[n-1]). + In case of overflow (q* >= beta) set q* := beta-1. + Compute c2 := ((r[j+n]*beta+r[j+n-1]) - q* * b[n-1])*beta + r[j+n-2] + and c3 := b[n-2] * q*. + {We have 0 <= c2 < 2*beta^2, even 0 <= c2 < beta^2 if no overflow + occurred. Furthermore 0 <= c3 < beta^2. + If there was overflow and + r[j+n]*beta+r[j+n-1] - q* * b[n-1] >= beta, i.e. c2 >= beta^2, + the next test can be skipped.} + While c3 > c2, {Here 0 <= c2 < c3 < beta^2} + Put q* := q* - 1, c2 := c2 + b[n-1]*beta, c3 := c3 - b[n-2]. + If q* > 0: + Put r := r - b * q* * beta^j. In detail: + [r[n+j],...,r[j]] := [r[n+j],...,r[j]] - q* * [b[n-1],...,b[0]]. + hence: u:=0, for i:=0 to n-1 do + u := u + q* * b[i], + r[j+i]:=r[j+i]-(u mod beta) (+ beta, if carry), + u:=u div beta (+ 1, if carry in subtraction) + r[n+j]:=r[n+j]-u. + {Since always u = (q* * [b[i-1],...,b[0]] div beta^i) + 1 + < q* + 1 <= beta, + the carry u does not overflow.} + If a negative carry occurs, put q* := q* - 1 + and [r[n+j],...,r[j]] := [r[n+j],...,r[j]] + [0,b[n-1],...,b[0]]. + Set q[j] := q*. + Normalise [q[m-n],..,q[0]]; this yields the quotient q. + Shift [r[n-1],...,r[0]] right by s bits and normalise; this yields the + rest r. + The room for q[j] can be allocated at the memory location of r[n+j]. + Finally, round-to-even: + Shift r left by 1 bit. + If r > b or if r = b and q[0] is odd, q := q+1. + */ + const mp_limb_t *a_ptr = a.limbs; + size_t a_len = a.nlimbs; + const mp_limb_t *b_ptr = b.limbs; + size_t b_len = b.nlimbs; + mp_limb_t *roomptr; + mp_limb_t *tmp_roomptr = NULL; + mp_limb_t *q_ptr; + size_t q_len; + mp_limb_t *r_ptr; + size_t r_len; + + /* Allocate room for a_len+2 digits. + (Need a_len+1 digits for the real division and 1 more digit for the + final rounding of q.) */ + roomptr = (mp_limb_t *) malloc ((a_len + 2) * sizeof (mp_limb_t)); + if (roomptr == NULL) + return NULL; + + /* Normalise a. */ + while (a_len > 0 && a_ptr[a_len - 1] == 0) + a_len--; + + /* Normalise b. */ + for (;;) + { + if (b_len == 0) + /* Division by zero. */ + abort (); + if (b_ptr[b_len - 1] == 0) + b_len--; + else + break; + } + + /* Here m = a_len >= 0 and n = b_len > 0. */ + + if (a_len < b_len) + { + /* m beta^(m-2) <= a/b < beta^m */ + r_ptr = roomptr; + q_ptr = roomptr + 1; + { + mp_limb_t den = b_ptr[0]; + mp_limb_t remainder = 0; + const mp_limb_t *sourceptr = a_ptr + a_len; + mp_limb_t *destptr = q_ptr + a_len; + size_t count; + for (count = a_len; count > 0; count--) + { + mp_twolimb_t num = + ((mp_twolimb_t) remainder << GMP_LIMB_BITS) | *--sourceptr; + *--destptr = num / den; + remainder = num % den; + } + /* Normalise and store r. */ + if (remainder > 0) + { + r_ptr[0] = remainder; + r_len = 1; + } + else + r_len = 0; + /* Normalise q. */ + q_len = a_len; + if (q_ptr[q_len - 1] == 0) + q_len--; + } + } + else + { + /* n>1: multiple precision division. + beta^(m-1) <= a < beta^m, beta^(n-1) <= b < beta^n ==> + beta^(m-n-1) <= a/b < beta^(m-n+1). */ + /* Determine s. */ + size_t s; + { + mp_limb_t msd = b_ptr[b_len - 1]; /* = b[n-1], > 0 */ + s = 31; + if (msd >= 0x10000) + { + msd = msd >> 16; + s -= 16; + } + if (msd >= 0x100) + { + msd = msd >> 8; + s -= 8; + } + if (msd >= 0x10) + { + msd = msd >> 4; + s -= 4; + } + if (msd >= 0x4) + { + msd = msd >> 2; + s -= 2; + } + if (msd >= 0x2) + { + msd = msd >> 1; + s -= 1; + } + } + /* 0 <= s < GMP_LIMB_BITS. + Copy b, shifting it left by s bits. */ + if (s > 0) + { + tmp_roomptr = (mp_limb_t *) malloc (b_len * sizeof (mp_limb_t)); + if (tmp_roomptr == NULL) + { + free (roomptr); + return NULL; + } + { + const mp_limb_t *sourceptr = b_ptr; + mp_limb_t *destptr = tmp_roomptr; + mp_twolimb_t accu = 0; + size_t count; + for (count = b_len; count > 0; count--) + { + accu += (mp_twolimb_t) *sourceptr++ << s; + *destptr++ = (mp_limb_t) accu; + accu = accu >> GMP_LIMB_BITS; + } + /* accu must be zero, since that was how s was determined. */ + if (accu != 0) + abort (); + } + b_ptr = tmp_roomptr; + } + /* Copy a, shifting it left by s bits, yields r. + Memory layout: + At the beginning: r = roomptr[0..a_len], + at the end: r = roomptr[0..b_len-1], q = roomptr[b_len..a_len] */ + r_ptr = roomptr; + if (s == 0) + { + memcpy (r_ptr, a_ptr, a_len * sizeof (mp_limb_t)); + r_ptr[a_len] = 0; + } + else + { + const mp_limb_t *sourceptr = a_ptr; + mp_limb_t *destptr = r_ptr; + mp_twolimb_t accu = 0; + size_t count; + for (count = a_len; count > 0; count--) + { + accu += (mp_twolimb_t) *sourceptr++ << s; + *destptr++ = (mp_limb_t) accu; + accu = accu >> GMP_LIMB_BITS; + } + *destptr++ = (mp_limb_t) accu; + } + q_ptr = roomptr + b_len; + q_len = a_len - b_len + 1; /* q will have m-n+1 limbs */ + { + size_t j = a_len - b_len; /* m-n */ + mp_limb_t b_msd = b_ptr[b_len - 1]; /* b[n-1] */ + mp_limb_t b_2msd = b_ptr[b_len - 2]; /* b[n-2] */ + mp_twolimb_t b_msdd = /* b[n-1]*beta+b[n-2] */ + ((mp_twolimb_t) b_msd << GMP_LIMB_BITS) | b_2msd; + /* Division loop, traversed m-n+1 times. + j counts down, b is unchanged, beta/2 <= b[n-1] < beta. */ + for (;;) + { + mp_limb_t q_star; + mp_limb_t c1; + if (r_ptr[j + b_len] < b_msd) /* r[j+n] < b[n-1] ? */ + { + /* Divide r[j+n]*beta+r[j+n-1] by b[n-1], no overflow. */ + mp_twolimb_t num = + ((mp_twolimb_t) r_ptr[j + b_len] << GMP_LIMB_BITS) + | r_ptr[j + b_len - 1]; + q_star = num / b_msd; + c1 = num % b_msd; + } + else + { + /* Overflow, hence r[j+n]*beta+r[j+n-1] >= beta*b[n-1]. */ + q_star = (mp_limb_t)~(mp_limb_t)0; /* q* = beta-1 */ + /* Test whether r[j+n]*beta+r[j+n-1] - (beta-1)*b[n-1] >= beta + <==> r[j+n]*beta+r[j+n-1] + b[n-1] >= beta*b[n-1]+beta + <==> b[n-1] < floor((r[j+n]*beta+r[j+n-1]+b[n-1])/beta) + {<= beta !}. + If yes, jump directly to the subtraction loop. + (Otherwise, r[j+n]*beta+r[j+n-1] - (beta-1)*b[n-1] < beta + <==> floor((r[j+n]*beta+r[j+n-1]+b[n-1])/beta) = b[n-1] ) */ + if (r_ptr[j + b_len] > b_msd + || (c1 = r_ptr[j + b_len - 1] + b_msd) < b_msd) + /* r[j+n] >= b[n-1]+1 or + r[j+n] = b[n-1] and the addition r[j+n-1]+b[n-1] gives a + carry. */ + goto subtract; + } + /* q_star = q*, + c1 = (r[j+n]*beta+r[j+n-1]) - q* * b[n-1] (>=0, 0, decrease it by + b[n-1]*beta+b[n-2]. Because of b[n-1]*beta+b[n-2] >= beta^2/2 + this can happen only twice. */ + if (c3 > c2) + { + q_star = q_star - 1; /* q* := q* - 1 */ + if (c3 - c2 > b_msdd) + q_star = q_star - 1; /* q* := q* - 1 */ + } + } + if (q_star > 0) + subtract: + { + /* Subtract r := r - b * q* * beta^j. */ + mp_limb_t cr; + { + const mp_limb_t *sourceptr = b_ptr; + mp_limb_t *destptr = r_ptr + j; + mp_twolimb_t carry = 0; + size_t count; + for (count = b_len; count > 0; count--) + { + /* Here 0 <= carry <= q*. */ + carry = + carry + + (mp_twolimb_t) q_star * (mp_twolimb_t) *sourceptr++ + + (mp_limb_t) ~(*destptr); + /* Here 0 <= carry <= beta*q* + beta-1. */ + *destptr++ = ~(mp_limb_t) carry; + carry = carry >> GMP_LIMB_BITS; /* <= q* */ + } + cr = (mp_limb_t) carry; + } + /* Subtract cr from r_ptr[j + b_len], then forget about + r_ptr[j + b_len]. */ + if (cr > r_ptr[j + b_len]) + { + /* Subtraction gave a carry. */ + q_star = q_star - 1; /* q* := q* - 1 */ + /* Add b back. */ + { + const mp_limb_t *sourceptr = b_ptr; + mp_limb_t *destptr = r_ptr + j; + mp_limb_t carry = 0; + size_t count; + for (count = b_len; count > 0; count--) + { + mp_limb_t source1 = *sourceptr++; + mp_limb_t source2 = *destptr; + *destptr++ = source1 + source2 + carry; + carry = + (carry + ? source1 >= (mp_limb_t) ~source2 + : source1 > (mp_limb_t) ~source2); + } + } + /* Forget about the carry and about r[j+n]. */ + } + } + /* q* is determined. Store it as q[j]. */ + q_ptr[j] = q_star; + if (j == 0) + break; + j--; + } + } + r_len = b_len; + /* Normalise q. */ + if (q_ptr[q_len - 1] == 0) + q_len--; +# if 0 /* Not needed here, since we need r only to compare it with b/2, and + b is shifted left by s bits. */ + /* Shift r right by s bits. */ + if (s > 0) + { + mp_limb_t ptr = r_ptr + r_len; + mp_twolimb_t accu = 0; + size_t count; + for (count = r_len; count > 0; count--) + { + accu = (mp_twolimb_t) (mp_limb_t) accu << GMP_LIMB_BITS; + accu += (mp_twolimb_t) *--ptr << (GMP_LIMB_BITS - s); + *ptr = (mp_limb_t) (accu >> GMP_LIMB_BITS); + } + } +# endif + /* Normalise r. */ + while (r_len > 0 && r_ptr[r_len - 1] == 0) + r_len--; + } + /* Compare r << 1 with b. */ + if (r_len > b_len) + goto increment_q; + { + size_t i; + for (i = b_len;;) + { + mp_limb_t r_i = + (i <= r_len && i > 0 ? r_ptr[i - 1] >> (GMP_LIMB_BITS - 1) : 0) + | (i < r_len ? r_ptr[i] << 1 : 0); + mp_limb_t b_i = (i < b_len ? b_ptr[i] : 0); + if (r_i > b_i) + goto increment_q; + if (r_i < b_i) + goto keep_q; + if (i == 0) + break; + i--; + } + } + if (q_len > 0 && ((q_ptr[0] & 1) != 0)) + /* q is odd. */ + increment_q: + { + size_t i; + for (i = 0; i < q_len; i++) + if (++(q_ptr[i]) != 0) + goto keep_q; + q_ptr[q_len++] = 1; + } + keep_q: + if (tmp_roomptr != NULL) + free (tmp_roomptr); + q->limbs = q_ptr; + q->nlimbs = q_len; + return roomptr; +} + +/* Convert a bignum a >= 0, multiplied with 10^extra_zeroes, to decimal + representation. + Destroys the contents of a. + Return the allocated memory - containing the decimal digits in low-to-high + order, terminated with a NUL character - in case of success, NULL in case + of memory allocation failure. */ +static char * +convert_to_decimal (mpn_t a, size_t extra_zeroes) +{ + mp_limb_t *a_ptr = a.limbs; + size_t a_len = a.nlimbs; + /* 0.03345 is slightly larger than log(2)/(9*log(10)). */ + size_t c_len = 9 * ((size_t)(a_len * (GMP_LIMB_BITS * 0.03345f)) + 1); + char *c_ptr = (char *) malloc (xsum (c_len, extra_zeroes)); + if (c_ptr != NULL) + { + char *d_ptr = c_ptr; + for (; extra_zeroes > 0; extra_zeroes--) + *d_ptr++ = '0'; + while (a_len > 0) + { + /* Divide a by 10^9, in-place. */ + mp_limb_t remainder = 0; + mp_limb_t *ptr = a_ptr + a_len; + size_t count; + for (count = a_len; count > 0; count--) + { + mp_twolimb_t num = + ((mp_twolimb_t) remainder << GMP_LIMB_BITS) | *--ptr; + *ptr = num / 1000000000; + remainder = num % 1000000000; + } + /* Store the remainder as 9 decimal digits. */ + for (count = 9; count > 0; count--) + { + *d_ptr++ = '0' + (remainder % 10); + remainder = remainder / 10; + } + /* Normalize a. */ + if (a_ptr[a_len - 1] == 0) + a_len--; + } + /* Remove leading zeroes. */ + while (d_ptr > c_ptr && d_ptr[-1] == '0') + d_ptr--; + /* But keep at least one zero. */ + if (d_ptr == c_ptr) + *d_ptr++ = '0'; + /* Terminate the string. */ + *d_ptr = '\0'; + } + return c_ptr; +} + +# if NEED_PRINTF_LONG_DOUBLE + +/* Assuming x is finite and >= 0: + write x as x = 2^e * m, where m is a bignum. + Return the allocated memory in case of success, NULL in case of memory + allocation failure. */ +static void * +decode_long_double (long double x, int *ep, mpn_t *mp) +{ + mpn_t m; + int exp; + long double y; + size_t i; + + /* Allocate memory for result. */ + m.nlimbs = (LDBL_MANT_BIT + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + m.limbs = (mp_limb_t *) malloc (m.nlimbs * sizeof (mp_limb_t)); + if (m.limbs == NULL) + return NULL; + /* Split into exponential part and mantissa. */ + y = frexpl (x, &exp); + if (!(y >= 0.0L && y < 1.0L)) + abort (); + /* x = 2^exp * y = 2^(exp - LDBL_MANT_BIT) * (y * LDBL_MANT_BIT), and the + latter is an integer. */ + /* Convert the mantissa (y * LDBL_MANT_BIT) to a sequence of limbs. + I'm not sure whether it's safe to cast a 'long double' value between + 2^31 and 2^32 to 'unsigned int', therefore play safe and cast only + 'long double' values between 0 and 2^16 (to 'unsigned int' or 'int', + doesn't matter). */ +# if (LDBL_MANT_BIT % GMP_LIMB_BITS) != 0 +# if (LDBL_MANT_BIT % GMP_LIMB_BITS) > GMP_LIMB_BITS / 2 + { + mp_limb_t hi, lo; + y *= (mp_limb_t) 1 << (LDBL_MANT_BIT % (GMP_LIMB_BITS / 2)); + hi = (int) y; + y -= hi; + if (!(y >= 0.0L && y < 1.0L)) + abort (); + y *= (mp_limb_t) 1 << (GMP_LIMB_BITS / 2); + lo = (int) y; + y -= lo; + if (!(y >= 0.0L && y < 1.0L)) + abort (); + m.limbs[LDBL_MANT_BIT / GMP_LIMB_BITS] = (hi << (GMP_LIMB_BITS / 2)) | lo; + } +# else + { + mp_limb_t d; + y *= (mp_limb_t) 1 << (LDBL_MANT_BIT % GMP_LIMB_BITS); + d = (int) y; + y -= d; + if (!(y >= 0.0L && y < 1.0L)) + abort (); + m.limbs[LDBL_MANT_BIT / GMP_LIMB_BITS] = d; + } +# endif +# endif + for (i = LDBL_MANT_BIT / GMP_LIMB_BITS; i > 0; ) + { + mp_limb_t hi, lo; + y *= (mp_limb_t) 1 << (GMP_LIMB_BITS / 2); + hi = (int) y; + y -= hi; + if (!(y >= 0.0L && y < 1.0L)) + abort (); + y *= (mp_limb_t) 1 << (GMP_LIMB_BITS / 2); + lo = (int) y; + y -= lo; + if (!(y >= 0.0L && y < 1.0L)) + abort (); + m.limbs[--i] = (hi << (GMP_LIMB_BITS / 2)) | lo; + } +#if 0 /* On FreeBSD 6.1/x86, 'long double' numbers sometimes have excess + precision. */ + if (!(y == 0.0L)) + abort (); +#endif + /* Normalise. */ + while (m.nlimbs > 0 && m.limbs[m.nlimbs - 1] == 0) + m.nlimbs--; + *mp = m; + *ep = exp - LDBL_MANT_BIT; + return m.limbs; +} + +# endif + +# if NEED_PRINTF_DOUBLE + +/* Assuming x is finite and >= 0: + write x as x = 2^e * m, where m is a bignum. + Return the allocated memory in case of success, NULL in case of memory + allocation failure. */ +static void * +decode_double (double x, int *ep, mpn_t *mp) +{ + mpn_t m; + int exp; + double y; + size_t i; + + /* Allocate memory for result. */ + m.nlimbs = (DBL_MANT_BIT + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + m.limbs = (mp_limb_t *) malloc (m.nlimbs * sizeof (mp_limb_t)); + if (m.limbs == NULL) + return NULL; + /* Split into exponential part and mantissa. */ + y = frexp (x, &exp); + if (!(y >= 0.0 && y < 1.0)) + abort (); + /* x = 2^exp * y = 2^(exp - DBL_MANT_BIT) * (y * DBL_MANT_BIT), and the + latter is an integer. */ + /* Convert the mantissa (y * DBL_MANT_BIT) to a sequence of limbs. + I'm not sure whether it's safe to cast a 'double' value between + 2^31 and 2^32 to 'unsigned int', therefore play safe and cast only + 'double' values between 0 and 2^16 (to 'unsigned int' or 'int', + doesn't matter). */ +# if (DBL_MANT_BIT % GMP_LIMB_BITS) != 0 +# if (DBL_MANT_BIT % GMP_LIMB_BITS) > GMP_LIMB_BITS / 2 + { + mp_limb_t hi, lo; + y *= (mp_limb_t) 1 << (DBL_MANT_BIT % (GMP_LIMB_BITS / 2)); + hi = (int) y; + y -= hi; + if (!(y >= 0.0 && y < 1.0)) + abort (); + y *= (mp_limb_t) 1 << (GMP_LIMB_BITS / 2); + lo = (int) y; + y -= lo; + if (!(y >= 0.0 && y < 1.0)) + abort (); + m.limbs[DBL_MANT_BIT / GMP_LIMB_BITS] = (hi << (GMP_LIMB_BITS / 2)) | lo; + } +# else + { + mp_limb_t d; + y *= (mp_limb_t) 1 << (DBL_MANT_BIT % GMP_LIMB_BITS); + d = (int) y; + y -= d; + if (!(y >= 0.0 && y < 1.0)) + abort (); + m.limbs[DBL_MANT_BIT / GMP_LIMB_BITS] = d; + } +# endif +# endif + for (i = DBL_MANT_BIT / GMP_LIMB_BITS; i > 0; ) + { + mp_limb_t hi, lo; + y *= (mp_limb_t) 1 << (GMP_LIMB_BITS / 2); + hi = (int) y; + y -= hi; + if (!(y >= 0.0 && y < 1.0)) + abort (); + y *= (mp_limb_t) 1 << (GMP_LIMB_BITS / 2); + lo = (int) y; + y -= lo; + if (!(y >= 0.0 && y < 1.0)) + abort (); + m.limbs[--i] = (hi << (GMP_LIMB_BITS / 2)) | lo; + } + if (!(y == 0.0)) + abort (); + /* Normalise. */ + while (m.nlimbs > 0 && m.limbs[m.nlimbs - 1] == 0) + m.nlimbs--; + *mp = m; + *ep = exp - DBL_MANT_BIT; + return m.limbs; +} + +# endif + +/* Assuming x = 2^e * m is finite and >= 0, and n is an integer: + Returns the decimal representation of round (x * 10^n). + Return the allocated memory - containing the decimal digits in low-to-high + order, terminated with a NUL character - in case of success, NULL in case + of memory allocation failure. */ +static char * +scale10_round_decimal_decoded (int e, mpn_t m, void *memory, int n) +{ + int s; + size_t extra_zeroes; + unsigned int abs_n; + unsigned int abs_s; + mp_limb_t *pow5_ptr; + size_t pow5_len; + unsigned int s_limbs; + unsigned int s_bits; + mpn_t pow5; + mpn_t z; + void *z_memory; + char *digits; + + if (memory == NULL) + return NULL; + /* x = 2^e * m, hence + y = round (2^e * 10^n * m) = round (2^(e+n) * 5^n * m) + = round (2^s * 5^n * m). */ + s = e + n; + extra_zeroes = 0; + /* Factor out a common power of 10 if possible. */ + if (s > 0 && n > 0) + { + extra_zeroes = (s < n ? s : n); + s -= extra_zeroes; + n -= extra_zeroes; + } + /* Here y = round (2^s * 5^n * m) * 10^extra_zeroes. + Before converting to decimal, we need to compute + z = round (2^s * 5^n * m). */ + /* Compute 5^|n|, possibly shifted by |s| bits if n and s have the same + sign. 2.322 is slightly larger than log(5)/log(2). */ + abs_n = (n >= 0 ? n : -n); + abs_s = (s >= 0 ? s : -s); + pow5_ptr = (mp_limb_t *) malloc (((int)(abs_n * (2.322f / GMP_LIMB_BITS)) + 1 + + abs_s / GMP_LIMB_BITS + 1) + * sizeof (mp_limb_t)); + if (pow5_ptr == NULL) + { + free (memory); + return NULL; + } + /* Initialize with 1. */ + pow5_ptr[0] = 1; + pow5_len = 1; + /* Multiply with 5^|n|. */ + if (abs_n > 0) + { + static mp_limb_t const small_pow5[13 + 1] = + { + 1, 5, 25, 125, 625, 3125, 15625, 78125, 390625, 1953125, 9765625, + 48828125, 244140625, 1220703125 + }; + unsigned int n13; + for (n13 = 0; n13 <= abs_n; n13 += 13) + { + mp_limb_t digit1 = small_pow5[n13 + 13 <= abs_n ? 13 : abs_n - n13]; + size_t j; + mp_twolimb_t carry = 0; + for (j = 0; j < pow5_len; j++) + { + mp_limb_t digit2 = pow5_ptr[j]; + carry += (mp_twolimb_t) digit1 * (mp_twolimb_t) digit2; + pow5_ptr[j] = (mp_limb_t) carry; + carry = carry >> GMP_LIMB_BITS; + } + if (carry > 0) + pow5_ptr[pow5_len++] = (mp_limb_t) carry; + } + } + s_limbs = abs_s / GMP_LIMB_BITS; + s_bits = abs_s % GMP_LIMB_BITS; + if (n >= 0 ? s >= 0 : s <= 0) + { + /* Multiply with 2^|s|. */ + if (s_bits > 0) + { + mp_limb_t *ptr = pow5_ptr; + mp_twolimb_t accu = 0; + size_t count; + for (count = pow5_len; count > 0; count--) + { + accu += (mp_twolimb_t) *ptr << s_bits; + *ptr++ = (mp_limb_t) accu; + accu = accu >> GMP_LIMB_BITS; + } + if (accu > 0) + { + *ptr = (mp_limb_t) accu; + pow5_len++; + } + } + if (s_limbs > 0) + { + size_t count; + for (count = pow5_len; count > 0;) + { + count--; + pow5_ptr[s_limbs + count] = pow5_ptr[count]; + } + for (count = s_limbs; count > 0;) + { + count--; + pow5_ptr[count] = 0; + } + pow5_len += s_limbs; + } + pow5.limbs = pow5_ptr; + pow5.nlimbs = pow5_len; + if (n >= 0) + { + /* Multiply m with pow5. No division needed. */ + z_memory = multiply (m, pow5, &z); + } + else + { + /* Divide m by pow5 and round. */ + z_memory = divide (m, pow5, &z); + } + } + else + { + pow5.limbs = pow5_ptr; + pow5.nlimbs = pow5_len; + if (n >= 0) + { + /* n >= 0, s < 0. + Multiply m with pow5, then divide by 2^|s|. */ + mpn_t numerator; + mpn_t denominator; + void *tmp_memory; + tmp_memory = multiply (m, pow5, &numerator); + if (tmp_memory == NULL) + { + free (pow5_ptr); + free (memory); + return NULL; + } + /* Construct 2^|s|. */ + { + mp_limb_t *ptr = pow5_ptr + pow5_len; + size_t i; + for (i = 0; i < s_limbs; i++) + ptr[i] = 0; + ptr[s_limbs] = (mp_limb_t) 1 << s_bits; + denominator.limbs = ptr; + denominator.nlimbs = s_limbs + 1; + } + z_memory = divide (numerator, denominator, &z); + free (tmp_memory); + } + else + { + /* n < 0, s > 0. + Multiply m with 2^s, then divide by pow5. */ + mpn_t numerator; + mp_limb_t *num_ptr; + num_ptr = (mp_limb_t *) malloc ((m.nlimbs + s_limbs + 1) + * sizeof (mp_limb_t)); + if (num_ptr == NULL) + { + free (pow5_ptr); + free (memory); + return NULL; + } + { + mp_limb_t *destptr = num_ptr; + { + size_t i; + for (i = 0; i < s_limbs; i++) + *destptr++ = 0; + } + if (s_bits > 0) + { + const mp_limb_t *sourceptr = m.limbs; + mp_twolimb_t accu = 0; + size_t count; + for (count = m.nlimbs; count > 0; count--) + { + accu += (mp_twolimb_t) *sourceptr++ << s_bits; + *destptr++ = (mp_limb_t) accu; + accu = accu >> GMP_LIMB_BITS; + } + if (accu > 0) + *destptr++ = (mp_limb_t) accu; + } + else + { + const mp_limb_t *sourceptr = m.limbs; + size_t count; + for (count = m.nlimbs; count > 0; count--) + *destptr++ = *sourceptr++; + } + numerator.limbs = num_ptr; + numerator.nlimbs = destptr - num_ptr; + } + z_memory = divide (numerator, pow5, &z); + free (num_ptr); + } + } + free (pow5_ptr); + free (memory); + + /* Here y = round (x * 10^n) = z * 10^extra_zeroes. */ + + if (z_memory == NULL) + return NULL; + digits = convert_to_decimal (z, extra_zeroes); + free (z_memory); + return digits; +} + +# if NEED_PRINTF_LONG_DOUBLE + +/* Assuming x is finite and >= 0, and n is an integer: + Returns the decimal representation of round (x * 10^n). + Return the allocated memory - containing the decimal digits in low-to-high + order, terminated with a NUL character - in case of success, NULL in case + of memory allocation failure. */ +static char * +scale10_round_decimal_long_double (long double x, int n) +{ + int e IF_LINT(= 0); + mpn_t m; + void *memory = decode_long_double (x, &e, &m); + return scale10_round_decimal_decoded (e, m, memory, n); +} + +# endif + +# if NEED_PRINTF_DOUBLE + +/* Assuming x is finite and >= 0, and n is an integer: + Returns the decimal representation of round (x * 10^n). + Return the allocated memory - containing the decimal digits in low-to-high + order, terminated with a NUL character - in case of success, NULL in case + of memory allocation failure. */ +static char * +scale10_round_decimal_double (double x, int n) +{ + int e IF_LINT(= 0); + mpn_t m; + void *memory = decode_double (x, &e, &m); + return scale10_round_decimal_decoded (e, m, memory, n); +} + +# endif + +# if NEED_PRINTF_LONG_DOUBLE + +/* Assuming x is finite and > 0: + Return an approximation for n with 10^n <= x < 10^(n+1). + The approximation is usually the right n, but may be off by 1 sometimes. */ +static int +floorlog10l (long double x) +{ + int exp; + long double y; + double z; + double l; + + /* Split into exponential part and mantissa. */ + y = frexpl (x, &exp); + if (!(y >= 0.0L && y < 1.0L)) + abort (); + if (y == 0.0L) + return INT_MIN; + if (y < 0.5L) + { + while (y < (1.0L / (1 << (GMP_LIMB_BITS / 2)) / (1 << (GMP_LIMB_BITS / 2)))) + { + y *= 1.0L * (1 << (GMP_LIMB_BITS / 2)) * (1 << (GMP_LIMB_BITS / 2)); + exp -= GMP_LIMB_BITS; + } + if (y < (1.0L / (1 << 16))) + { + y *= 1.0L * (1 << 16); + exp -= 16; + } + if (y < (1.0L / (1 << 8))) + { + y *= 1.0L * (1 << 8); + exp -= 8; + } + if (y < (1.0L / (1 << 4))) + { + y *= 1.0L * (1 << 4); + exp -= 4; + } + if (y < (1.0L / (1 << 2))) + { + y *= 1.0L * (1 << 2); + exp -= 2; + } + if (y < (1.0L / (1 << 1))) + { + y *= 1.0L * (1 << 1); + exp -= 1; + } + } + if (!(y >= 0.5L && y < 1.0L)) + abort (); + /* Compute an approximation for l = log2(x) = exp + log2(y). */ + l = exp; + z = y; + if (z < 0.70710678118654752444) + { + z *= 1.4142135623730950488; + l -= 0.5; + } + if (z < 0.8408964152537145431) + { + z *= 1.1892071150027210667; + l -= 0.25; + } + if (z < 0.91700404320467123175) + { + z *= 1.0905077326652576592; + l -= 0.125; + } + if (z < 0.9576032806985736469) + { + z *= 1.0442737824274138403; + l -= 0.0625; + } + /* Now 0.95 <= z <= 1.01. */ + z = 1 - z; + /* log2(1-z) = 1/log(2) * (- z - z^2/2 - z^3/3 - z^4/4 - ...) + Four terms are enough to get an approximation with error < 10^-7. */ + l -= 1.4426950408889634074 * z * (1.0 + z * (0.5 + z * ((1.0 / 3) + z * 0.25))); + /* Finally multiply with log(2)/log(10), yields an approximation for + log10(x). */ + l *= 0.30102999566398119523; + /* Round down to the next integer. */ + return (int) l + (l < 0 ? -1 : 0); +} + +# endif + +# if NEED_PRINTF_DOUBLE + +/* Assuming x is finite and > 0: + Return an approximation for n with 10^n <= x < 10^(n+1). + The approximation is usually the right n, but may be off by 1 sometimes. */ +static int +floorlog10 (double x) +{ + int exp; + double y; + double z; + double l; + + /* Split into exponential part and mantissa. */ + y = frexp (x, &exp); + if (!(y >= 0.0 && y < 1.0)) + abort (); + if (y == 0.0) + return INT_MIN; + if (y < 0.5) + { + while (y < (1.0 / (1 << (GMP_LIMB_BITS / 2)) / (1 << (GMP_LIMB_BITS / 2)))) + { + y *= 1.0 * (1 << (GMP_LIMB_BITS / 2)) * (1 << (GMP_LIMB_BITS / 2)); + exp -= GMP_LIMB_BITS; + } + if (y < (1.0 / (1 << 16))) + { + y *= 1.0 * (1 << 16); + exp -= 16; + } + if (y < (1.0 / (1 << 8))) + { + y *= 1.0 * (1 << 8); + exp -= 8; + } + if (y < (1.0 / (1 << 4))) + { + y *= 1.0 * (1 << 4); + exp -= 4; + } + if (y < (1.0 / (1 << 2))) + { + y *= 1.0 * (1 << 2); + exp -= 2; + } + if (y < (1.0 / (1 << 1))) + { + y *= 1.0 * (1 << 1); + exp -= 1; + } + } + if (!(y >= 0.5 && y < 1.0)) + abort (); + /* Compute an approximation for l = log2(x) = exp + log2(y). */ + l = exp; + z = y; + if (z < 0.70710678118654752444) + { + z *= 1.4142135623730950488; + l -= 0.5; + } + if (z < 0.8408964152537145431) + { + z *= 1.1892071150027210667; + l -= 0.25; + } + if (z < 0.91700404320467123175) + { + z *= 1.0905077326652576592; + l -= 0.125; + } + if (z < 0.9576032806985736469) + { + z *= 1.0442737824274138403; + l -= 0.0625; + } + /* Now 0.95 <= z <= 1.01. */ + z = 1 - z; + /* log2(1-z) = 1/log(2) * (- z - z^2/2 - z^3/3 - z^4/4 - ...) + Four terms are enough to get an approximation with error < 10^-7. */ + l -= 1.4426950408889634074 * z * (1.0 + z * (0.5 + z * ((1.0 / 3) + z * 0.25))); + /* Finally multiply with log(2)/log(10), yields an approximation for + log10(x). */ + l *= 0.30102999566398119523; + /* Round down to the next integer. */ + return (int) l + (l < 0 ? -1 : 0); +} + +# endif + +/* Tests whether a string of digits consists of exactly PRECISION zeroes and + a single '1' digit. */ +static int +is_borderline (const char *digits, size_t precision) +{ + for (; precision > 0; precision--, digits++) + if (*digits != '0') + return 0; + if (*digits != '1') + return 0; + digits++; + return *digits == '\0'; +} + +#endif + +DCHAR_T * +VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, + const FCHAR_T *format, va_list args) +{ + DIRECTIVES d; + arguments a; + + if (PRINTF_PARSE (format, &d, &a) < 0) + /* errno is already set. */ + return NULL; + +#define CLEANUP() \ + free (d.dir); \ + if (a.arg) \ + free (a.arg); + + if (PRINTF_FETCHARGS (args, &a) < 0) + { + CLEANUP (); + errno = EINVAL; + return NULL; + } + + { + size_t buf_neededlength; + TCHAR_T *buf; + TCHAR_T *buf_malloced; + const FCHAR_T *cp; + size_t i; + DIRECTIVE *dp; + /* Output string accumulator. */ + DCHAR_T *result; + size_t allocated; + size_t length; + + /* Allocate a small buffer that will hold a directive passed to + sprintf or snprintf. */ + buf_neededlength = + xsum4 (7, d.max_width_length, d.max_precision_length, 6); +#if HAVE_ALLOCA + if (buf_neededlength < 4000 / sizeof (TCHAR_T)) + { + buf = (TCHAR_T *) alloca (buf_neededlength * sizeof (TCHAR_T)); + buf_malloced = NULL; + } + else +#endif + { + size_t buf_memsize = xtimes (buf_neededlength, sizeof (TCHAR_T)); + if (size_overflow_p (buf_memsize)) + goto out_of_memory_1; + buf = (TCHAR_T *) malloc (buf_memsize); + if (buf == NULL) + goto out_of_memory_1; + buf_malloced = buf; + } + + if (resultbuf != NULL) + { + result = resultbuf; + allocated = *lengthp; + } + else + { + result = NULL; + allocated = 0; + } + length = 0; + /* Invariants: + result is either == resultbuf or == NULL or malloc-allocated. + If length > 0, then result != NULL. */ + + /* Ensures that allocated >= needed. Aborts through a jump to + out_of_memory if needed is SIZE_MAX or otherwise too big. */ +#define ENSURE_ALLOCATION(needed) \ + if ((needed) > allocated) \ + { \ + size_t memory_size; \ + DCHAR_T *memory; \ + \ + allocated = (allocated > 0 ? xtimes (allocated, 2) : 12); \ + if ((needed) > allocated) \ + allocated = (needed); \ + memory_size = xtimes (allocated, sizeof (DCHAR_T)); \ + if (size_overflow_p (memory_size)) \ + goto out_of_memory; \ + if (result == resultbuf || result == NULL) \ + memory = (DCHAR_T *) malloc (memory_size); \ + else \ + memory = (DCHAR_T *) realloc (result, memory_size); \ + if (memory == NULL) \ + goto out_of_memory; \ + if (result == resultbuf && length > 0) \ + DCHAR_CPY (memory, result, length); \ + result = memory; \ + } + + for (cp = format, i = 0, dp = &d.dir[0]; ; cp = dp->dir_end, i++, dp++) + { + if (cp != dp->dir_start) + { + size_t n = dp->dir_start - cp; + size_t augmented_length = xsum (length, n); + + ENSURE_ALLOCATION (augmented_length); + /* This copies a piece of FCHAR_T[] into a DCHAR_T[]. Here we + need that the format string contains only ASCII characters + if FCHAR_T and DCHAR_T are not the same type. */ + if (sizeof (FCHAR_T) == sizeof (DCHAR_T)) + { + DCHAR_CPY (result + length, (const DCHAR_T *) cp, n); + length = augmented_length; + } + else + { + do + result[length++] = (unsigned char) *cp++; + while (--n > 0); + } + } + if (i == d.count) + break; + + /* Execute a single directive. */ + if (dp->conversion == '%') + { + size_t augmented_length; + + if (!(dp->arg_index == ARG_NONE)) + abort (); + augmented_length = xsum (length, 1); + ENSURE_ALLOCATION (augmented_length); + result[length] = '%'; + length = augmented_length; + } + else + { + if (!(dp->arg_index != ARG_NONE)) + abort (); + + if (dp->conversion == 'n') + { + switch (a.arg[dp->arg_index].type) + { + case TYPE_COUNT_SCHAR_POINTER: + *a.arg[dp->arg_index].a.a_count_schar_pointer = length; + break; + case TYPE_COUNT_SHORT_POINTER: + *a.arg[dp->arg_index].a.a_count_short_pointer = length; + break; + case TYPE_COUNT_INT_POINTER: + *a.arg[dp->arg_index].a.a_count_int_pointer = length; + break; + case TYPE_COUNT_LONGINT_POINTER: + *a.arg[dp->arg_index].a.a_count_longint_pointer = length; + break; +#if HAVE_LONG_LONG_INT + case TYPE_COUNT_LONGLONGINT_POINTER: + *a.arg[dp->arg_index].a.a_count_longlongint_pointer = length; + break; +#endif + default: + abort (); + } + } +#if ENABLE_UNISTDIO + /* The unistdio extensions. */ + else if (dp->conversion == 'U') + { + arg_type type = a.arg[dp->arg_index].type; + int flags = dp->flags; + int has_width; + size_t width; + int has_precision; + size_t precision; + + has_width = 0; + width = 0; + if (dp->width_start != dp->width_end) + { + if (dp->width_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->width_arg_index].a.a_int; + if (arg < 0) + { + /* "A negative field width is taken as a '-' flag + followed by a positive field width." */ + flags |= FLAG_LEFT; + width = (unsigned int) (-arg); + } + else + width = arg; + } + else + { + const FCHAR_T *digitp = dp->width_start; + + do + width = xsum (xtimes (width, 10), *digitp++ - '0'); + while (digitp != dp->width_end); + } + has_width = 1; + } + + has_precision = 0; + precision = 0; + if (dp->precision_start != dp->precision_end) + { + if (dp->precision_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->precision_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->precision_arg_index].a.a_int; + /* "A negative precision is taken as if the precision + were omitted." */ + if (arg >= 0) + { + precision = arg; + has_precision = 1; + } + } + else + { + const FCHAR_T *digitp = dp->precision_start + 1; + + precision = 0; + while (digitp != dp->precision_end) + precision = xsum (xtimes (precision, 10), *digitp++ - '0'); + has_precision = 1; + } + } + + switch (type) + { + case TYPE_U8_STRING: + { + const uint8_t *arg = a.arg[dp->arg_index].a.a_u8_string; + const uint8_t *arg_end; + size_t characters; + + if (has_precision) + { + /* Use only PRECISION characters, from the left. */ + arg_end = arg; + characters = 0; + for (; precision > 0; precision--) + { + int count = u8_strmblen (arg_end); + if (count == 0) + break; + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else if (has_width) + { + /* Use the entire string, and count the number of + characters. */ + arg_end = arg; + characters = 0; + for (;;) + { + int count = u8_strmblen (arg_end); + if (count == 0) + break; + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else + { + /* Use the entire string. */ + arg_end = arg + u8_strlen (arg); + /* The number of characters doesn't matter. */ + characters = 0; + } + + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + +# if DCHAR_IS_UINT8_T + { + size_t n = arg_end - arg; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_CPY (result + length, arg, n); + length += n; + } +# else + { /* Convert. */ + DCHAR_T *converted = result + length; + size_t converted_len = allocated - length; +# if DCHAR_IS_TCHAR + /* Convert from UTF-8 to locale encoding. */ + converted = + u8_conv_to_encoding (locale_charset (), + iconveh_question_mark, + arg, arg_end - arg, NULL, + converted, &converted_len); +# else + /* Convert from UTF-8 to UTF-16/UTF-32. */ + converted = + U8_TO_DCHAR (arg, arg_end - arg, + converted, &converted_len); +# endif + if (converted == NULL) + { + int saved_errno = errno; + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = saved_errno; + return NULL; + } + if (converted != result + length) + { + ENSURE_ALLOCATION (xsum (length, converted_len)); + DCHAR_CPY (result + length, converted, converted_len); + free (converted); + } + length += converted_len; + } +# endif + + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + } + break; + + case TYPE_U16_STRING: + { + const uint16_t *arg = a.arg[dp->arg_index].a.a_u16_string; + const uint16_t *arg_end; + size_t characters; + + if (has_precision) + { + /* Use only PRECISION characters, from the left. */ + arg_end = arg; + characters = 0; + for (; precision > 0; precision--) + { + int count = u16_strmblen (arg_end); + if (count == 0) + break; + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else if (has_width) + { + /* Use the entire string, and count the number of + characters. */ + arg_end = arg; + characters = 0; + for (;;) + { + int count = u16_strmblen (arg_end); + if (count == 0) + break; + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else + { + /* Use the entire string. */ + arg_end = arg + u16_strlen (arg); + /* The number of characters doesn't matter. */ + characters = 0; + } + + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + +# if DCHAR_IS_UINT16_T + { + size_t n = arg_end - arg; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_CPY (result + length, arg, n); + length += n; + } +# else + { /* Convert. */ + DCHAR_T *converted = result + length; + size_t converted_len = allocated - length; +# if DCHAR_IS_TCHAR + /* Convert from UTF-16 to locale encoding. */ + converted = + u16_conv_to_encoding (locale_charset (), + iconveh_question_mark, + arg, arg_end - arg, NULL, + converted, &converted_len); +# else + /* Convert from UTF-16 to UTF-8/UTF-32. */ + converted = + U16_TO_DCHAR (arg, arg_end - arg, + converted, &converted_len); +# endif + if (converted == NULL) + { + int saved_errno = errno; + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = saved_errno; + return NULL; + } + if (converted != result + length) + { + ENSURE_ALLOCATION (xsum (length, converted_len)); + DCHAR_CPY (result + length, converted, converted_len); + free (converted); + } + length += converted_len; + } +# endif + + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + } + break; + + case TYPE_U32_STRING: + { + const uint32_t *arg = a.arg[dp->arg_index].a.a_u32_string; + const uint32_t *arg_end; + size_t characters; + + if (has_precision) + { + /* Use only PRECISION characters, from the left. */ + arg_end = arg; + characters = 0; + for (; precision > 0; precision--) + { + int count = u32_strmblen (arg_end); + if (count == 0) + break; + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else if (has_width) + { + /* Use the entire string, and count the number of + characters. */ + arg_end = arg; + characters = 0; + for (;;) + { + int count = u32_strmblen (arg_end); + if (count == 0) + break; + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else + { + /* Use the entire string. */ + arg_end = arg + u32_strlen (arg); + /* The number of characters doesn't matter. */ + characters = 0; + } + + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + +# if DCHAR_IS_UINT32_T + { + size_t n = arg_end - arg; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_CPY (result + length, arg, n); + length += n; + } +# else + { /* Convert. */ + DCHAR_T *converted = result + length; + size_t converted_len = allocated - length; +# if DCHAR_IS_TCHAR + /* Convert from UTF-32 to locale encoding. */ + converted = + u32_conv_to_encoding (locale_charset (), + iconveh_question_mark, + arg, arg_end - arg, NULL, + converted, &converted_len); +# else + /* Convert from UTF-32 to UTF-8/UTF-16. */ + converted = + U32_TO_DCHAR (arg, arg_end - arg, + converted, &converted_len); +# endif + if (converted == NULL) + { + int saved_errno = errno; + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = saved_errno; + return NULL; + } + if (converted != result + length) + { + ENSURE_ALLOCATION (xsum (length, converted_len)); + DCHAR_CPY (result + length, converted, converted_len); + free (converted); + } + length += converted_len; + } +# endif + + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + } + break; + + default: + abort (); + } + } +#endif +#if (!USE_SNPRINTF || (NEED_PRINTF_DIRECTIVE_LS && !defined IN_LIBINTL)) && HAVE_WCHAR_T + else if (dp->conversion == 's' +# if WIDE_CHAR_VERSION + && a.arg[dp->arg_index].type != TYPE_WIDE_STRING +# else + && a.arg[dp->arg_index].type == TYPE_WIDE_STRING +# endif + ) + { + /* The normal handling of the 's' directive below requires + allocating a temporary buffer. The determination of its + length (tmp_length), in the case when a precision is + specified, below requires a conversion between a char[] + string and a wchar_t[] wide string. It could be done, but + we have no guarantee that the implementation of sprintf will + use the exactly same algorithm. Without this guarantee, it + is possible to have buffer overrun bugs. In order to avoid + such bugs, we implement the entire processing of the 's' + directive ourselves. */ + int flags = dp->flags; + int has_width; + size_t width; + int has_precision; + size_t precision; + + has_width = 0; + width = 0; + if (dp->width_start != dp->width_end) + { + if (dp->width_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->width_arg_index].a.a_int; + if (arg < 0) + { + /* "A negative field width is taken as a '-' flag + followed by a positive field width." */ + flags |= FLAG_LEFT; + width = (unsigned int) (-arg); + } + else + width = arg; + } + else + { + const FCHAR_T *digitp = dp->width_start; + + do + width = xsum (xtimes (width, 10), *digitp++ - '0'); + while (digitp != dp->width_end); + } + has_width = 1; + } + + has_precision = 0; + precision = 6; + if (dp->precision_start != dp->precision_end) + { + if (dp->precision_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->precision_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->precision_arg_index].a.a_int; + /* "A negative precision is taken as if the precision + were omitted." */ + if (arg >= 0) + { + precision = arg; + has_precision = 1; + } + } + else + { + const FCHAR_T *digitp = dp->precision_start + 1; + + precision = 0; + while (digitp != dp->precision_end) + precision = xsum (xtimes (precision, 10), *digitp++ - '0'); + has_precision = 1; + } + } + +# if WIDE_CHAR_VERSION + /* %s in vasnwprintf. See the specification of fwprintf. */ + { + const char *arg = a.arg[dp->arg_index].a.a_string; + const char *arg_end; + size_t characters; + + if (has_precision) + { + /* Use only as many bytes as needed to produce PRECISION + wide characters, from the left. */ +# if HAVE_MBRTOWC + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + arg_end = arg; + characters = 0; + for (; precision > 0; precision--) + { + int count; +# if HAVE_MBRTOWC + count = mbrlen (arg_end, MB_CUR_MAX, &state); +# else + count = mblen (arg_end, MB_CUR_MAX); +# endif + if (count == 0) + /* Found the terminating NUL. */ + break; + if (count < 0) + { + /* Invalid or incomplete multibyte character. */ + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else if (has_width) + { + /* Use the entire string, and count the number of wide + characters. */ +# if HAVE_MBRTOWC + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + arg_end = arg; + characters = 0; + for (;;) + { + int count; +# if HAVE_MBRTOWC + count = mbrlen (arg_end, MB_CUR_MAX, &state); +# else + count = mblen (arg_end, MB_CUR_MAX); +# endif + if (count == 0) + /* Found the terminating NUL. */ + break; + if (count < 0) + { + /* Invalid or incomplete multibyte character. */ + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end += count; + characters++; + } + } + else + { + /* Use the entire string. */ + arg_end = arg + strlen (arg); + /* The number of characters doesn't matter. */ + characters = 0; + } + + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + + if (has_precision || has_width) + { + /* We know the number of wide characters in advance. */ + size_t remaining; +# if HAVE_MBRTOWC + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + ENSURE_ALLOCATION (xsum (length, characters)); + for (remaining = characters; remaining > 0; remaining--) + { + wchar_t wc; + int count; +# if HAVE_MBRTOWC + count = mbrtowc (&wc, arg, arg_end - arg, &state); +# else + count = mbtowc (&wc, arg, arg_end - arg); +# endif + if (count <= 0) + /* mbrtowc not consistent with mbrlen, or mbtowc + not consistent with mblen. */ + abort (); + result[length++] = wc; + arg += count; + } + if (!(arg == arg_end)) + abort (); + } + else + { +# if HAVE_MBRTOWC + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + while (arg < arg_end) + { + wchar_t wc; + int count; +# if HAVE_MBRTOWC + count = mbrtowc (&wc, arg, arg_end - arg, &state); +# else + count = mbtowc (&wc, arg, arg_end - arg); +# endif + if (count <= 0) + /* mbrtowc not consistent with mbrlen, or mbtowc + not consistent with mblen. */ + abort (); + ENSURE_ALLOCATION (xsum (length, 1)); + result[length++] = wc; + arg += count; + } + } + + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) + { + size_t n = width - characters; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + } +# else + /* %ls in vasnprintf. See the specification of fprintf. */ + { + const wchar_t *arg = a.arg[dp->arg_index].a.a_wide_string; + const wchar_t *arg_end; + size_t characters; +# if !DCHAR_IS_TCHAR + /* This code assumes that TCHAR_T is 'char'. */ + typedef int TCHAR_T_verify[2 * (sizeof (TCHAR_T) == 1) - 1]; + TCHAR_T *tmpsrc; + DCHAR_T *tmpdst; + size_t tmpdst_len; +# endif + size_t w; + + if (has_precision) + { + /* Use only as many wide characters as needed to produce + at most PRECISION bytes, from the left. */ +# if HAVE_WCRTOMB + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + arg_end = arg; + characters = 0; + while (precision > 0) + { + char buf[64]; /* Assume MB_CUR_MAX <= 64. */ + int count; + + if (*arg_end == 0) + /* Found the terminating null wide character. */ + break; +# if HAVE_WCRTOMB + count = wcrtomb (buf, *arg_end, &state); +# else + count = wctomb (buf, *arg_end); +# endif + if (count < 0) + { + /* Cannot convert. */ + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + if (precision < count) + break; + arg_end++; + characters += count; + precision -= count; + } + } +# if DCHAR_IS_TCHAR + else if (has_width) +# else + else +# endif + { + /* Use the entire string, and count the number of + bytes. */ +# if HAVE_WCRTOMB + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + arg_end = arg; + characters = 0; + for (;;) + { + char buf[64]; /* Assume MB_CUR_MAX <= 64. */ + int count; + + if (*arg_end == 0) + /* Found the terminating null wide character. */ + break; +# if HAVE_WCRTOMB + count = wcrtomb (buf, *arg_end, &state); +# else + count = wctomb (buf, *arg_end); +# endif + if (count < 0) + { + /* Cannot convert. */ + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EILSEQ; + return NULL; + } + arg_end++; + characters += count; + } + } +# if DCHAR_IS_TCHAR + else + { + /* Use the entire string. */ + arg_end = arg + local_wcslen (arg); + /* The number of bytes doesn't matter. */ + characters = 0; + } +# endif + +# if !DCHAR_IS_TCHAR + /* Convert the string into a piece of temporary memory. */ + tmpsrc = (TCHAR_T *) malloc (characters * sizeof (TCHAR_T)); + if (tmpsrc == NULL) + goto out_of_memory; + { + TCHAR_T *tmpptr = tmpsrc; + size_t remaining; +# if HAVE_WCRTOMB + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + for (remaining = characters; remaining > 0; ) + { + char buf[64]; /* Assume MB_CUR_MAX <= 64. */ + int count; + + if (*arg == 0) + abort (); +# if HAVE_WCRTOMB + count = wcrtomb (buf, *arg, &state); +# else + count = wctomb (buf, *arg); +# endif + if (count <= 0) + /* Inconsistency. */ + abort (); + memcpy (tmpptr, buf, count); + tmpptr += count; + arg++; + remaining -= count; + } + if (!(arg == arg_end)) + abort (); + } + + /* Convert from TCHAR_T[] to DCHAR_T[]. */ + tmpdst = + DCHAR_CONV_FROM_ENCODING (locale_charset (), + iconveh_question_mark, + tmpsrc, characters, + NULL, + NULL, &tmpdst_len); + if (tmpdst == NULL) + { + int saved_errno = errno; + free (tmpsrc); + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = saved_errno; + return NULL; + } + free (tmpsrc); +# endif + + if (has_width) + { +# if ENABLE_UNISTDIO + /* Outside POSIX, it's preferrable to compare the width + against the number of _characters_ of the converted + value. */ + w = DCHAR_MBSNLEN (result + length, characters); +# else + /* The width is compared against the number of _bytes_ + of the converted value, says POSIX. */ + w = characters; +# endif + } + else + /* w doesn't matter. */ + w = 0; + + if (has_width && width > w + && !(dp->flags & FLAG_LEFT)) + { + size_t n = width - w; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + +# if DCHAR_IS_TCHAR + if (has_precision || has_width) + { + /* We know the number of bytes in advance. */ + size_t remaining; +# if HAVE_WCRTOMB + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + ENSURE_ALLOCATION (xsum (length, characters)); + for (remaining = characters; remaining > 0; ) + { + char buf[64]; /* Assume MB_CUR_MAX <= 64. */ + int count; + + if (*arg == 0) + abort (); +# if HAVE_WCRTOMB + count = wcrtomb (buf, *arg, &state); +# else + count = wctomb (buf, *arg); +# endif + if (count <= 0) + /* Inconsistency. */ + abort (); + memcpy (result + length, buf, count); + length += count; + arg++; + remaining -= count; + } + if (!(arg == arg_end)) + abort (); + } + else + { +# if HAVE_WCRTOMB + mbstate_t state; + memset (&state, '\0', sizeof (mbstate_t)); +# endif + while (arg < arg_end) + { + char buf[64]; /* Assume MB_CUR_MAX <= 64. */ + int count; + + if (*arg == 0) + abort (); +# if HAVE_WCRTOMB + count = wcrtomb (buf, *arg, &state); +# else + count = wctomb (buf, *arg); +# endif + if (count <= 0) + /* Inconsistency. */ + abort (); + ENSURE_ALLOCATION (xsum (length, count)); + memcpy (result + length, buf, count); + length += count; + arg++; + } + } +# else + ENSURE_ALLOCATION (xsum (length, tmpdst_len)); + DCHAR_CPY (result + length, tmpdst, tmpdst_len); + free (tmpdst); + length += tmpdst_len; +# endif + + if (has_width && width > w + && (dp->flags & FLAG_LEFT)) + { + size_t n = width - w; + ENSURE_ALLOCATION (xsum (length, n)); + DCHAR_SET (result + length, ' ', n); + length += n; + } + } + } +# endif +#endif +#if (NEED_PRINTF_DIRECTIVE_A || NEED_PRINTF_LONG_DOUBLE || NEED_PRINTF_DOUBLE) && !defined IN_LIBINTL + else if ((dp->conversion == 'a' || dp->conversion == 'A') +# if !(NEED_PRINTF_DIRECTIVE_A || (NEED_PRINTF_LONG_DOUBLE && NEED_PRINTF_DOUBLE)) + && (0 +# if NEED_PRINTF_DOUBLE + || a.arg[dp->arg_index].type == TYPE_DOUBLE +# endif +# if NEED_PRINTF_LONG_DOUBLE + || a.arg[dp->arg_index].type == TYPE_LONGDOUBLE +# endif + ) +# endif + ) + { + arg_type type = a.arg[dp->arg_index].type; + int flags = dp->flags; + int has_width; + size_t width; + int has_precision; + size_t precision; + size_t tmp_length; + DCHAR_T tmpbuf[700]; + DCHAR_T *tmp; + DCHAR_T *pad_ptr; + DCHAR_T *p; + + has_width = 0; + width = 0; + if (dp->width_start != dp->width_end) + { + if (dp->width_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->width_arg_index].a.a_int; + if (arg < 0) + { + /* "A negative field width is taken as a '-' flag + followed by a positive field width." */ + flags |= FLAG_LEFT; + width = (unsigned int) (-arg); + } + else + width = arg; + } + else + { + const FCHAR_T *digitp = dp->width_start; + + do + width = xsum (xtimes (width, 10), *digitp++ - '0'); + while (digitp != dp->width_end); + } + has_width = 1; + } + + has_precision = 0; + precision = 0; + if (dp->precision_start != dp->precision_end) + { + if (dp->precision_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->precision_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->precision_arg_index].a.a_int; + /* "A negative precision is taken as if the precision + were omitted." */ + if (arg >= 0) + { + precision = arg; + has_precision = 1; + } + } + else + { + const FCHAR_T *digitp = dp->precision_start + 1; + + precision = 0; + while (digitp != dp->precision_end) + precision = xsum (xtimes (precision, 10), *digitp++ - '0'); + has_precision = 1; + } + } + + /* Allocate a temporary buffer of sufficient size. */ + if (type == TYPE_LONGDOUBLE) + tmp_length = + (unsigned int) ((LDBL_DIG + 1) + * 0.831 /* decimal -> hexadecimal */ + ) + + 1; /* turn floor into ceil */ + else + tmp_length = + (unsigned int) ((DBL_DIG + 1) + * 0.831 /* decimal -> hexadecimal */ + ) + + 1; /* turn floor into ceil */ + if (tmp_length < precision) + tmp_length = precision; + /* Account for sign, decimal point etc. */ + tmp_length = xsum (tmp_length, 12); + + if (tmp_length < width) + tmp_length = width; + + tmp_length = xsum (tmp_length, 1); /* account for trailing NUL */ + + if (tmp_length <= sizeof (tmpbuf) / sizeof (DCHAR_T)) + tmp = tmpbuf; + else + { + size_t tmp_memsize = xtimes (tmp_length, sizeof (DCHAR_T)); + + if (size_overflow_p (tmp_memsize)) + /* Overflow, would lead to out of memory. */ + goto out_of_memory; + tmp = (DCHAR_T *) malloc (tmp_memsize); + if (tmp == NULL) + /* Out of memory. */ + goto out_of_memory; + } + + pad_ptr = NULL; + p = tmp; + if (type == TYPE_LONGDOUBLE) + { +# if NEED_PRINTF_DIRECTIVE_A || NEED_PRINTF_LONG_DOUBLE + long double arg = a.arg[dp->arg_index].a.a_longdouble; + + if (isnanl (arg)) + { + if (dp->conversion == 'A') + { + *p++ = 'N'; *p++ = 'A'; *p++ = 'N'; + } + else + { + *p++ = 'n'; *p++ = 'a'; *p++ = 'n'; + } + } + else + { + int sign = 0; + DECL_LONG_DOUBLE_ROUNDING + + BEGIN_LONG_DOUBLE_ROUNDING (); + + if (signbit (arg)) /* arg < 0.0L or negative zero */ + { + sign = -1; + arg = -arg; + } + + if (sign < 0) + *p++ = '-'; + else if (flags & FLAG_SHOWSIGN) + *p++ = '+'; + else if (flags & FLAG_SPACE) + *p++ = ' '; + + if (arg > 0.0L && arg + arg == arg) + { + if (dp->conversion == 'A') + { + *p++ = 'I'; *p++ = 'N'; *p++ = 'F'; + } + else + { + *p++ = 'i'; *p++ = 'n'; *p++ = 'f'; + } + } + else + { + int exponent; + long double mantissa; + + if (arg > 0.0L) + mantissa = printf_frexpl (arg, &exponent); + else + { + exponent = 0; + mantissa = 0.0L; + } + + if (has_precision + && precision < (unsigned int) ((LDBL_DIG + 1) * 0.831) + 1) + { + /* Round the mantissa. */ + long double tail = mantissa; + size_t q; + + for (q = precision; ; q--) + { + int digit = (int) tail; + tail -= digit; + if (q == 0) + { + if (digit & 1 ? tail >= 0.5L : tail > 0.5L) + tail = 1 - tail; + else + tail = - tail; + break; + } + tail *= 16.0L; + } + if (tail != 0.0L) + for (q = precision; q > 0; q--) + tail *= 0.0625L; + mantissa += tail; + } + + *p++ = '0'; + *p++ = dp->conversion - 'A' + 'X'; + pad_ptr = p; + { + int digit; + + digit = (int) mantissa; + mantissa -= digit; + *p++ = '0' + digit; + if ((flags & FLAG_ALT) + || mantissa > 0.0L || precision > 0) + { + *p++ = decimal_point_char (); + /* This loop terminates because we assume + that FLT_RADIX is a power of 2. */ + while (mantissa > 0.0L) + { + mantissa *= 16.0L; + digit = (int) mantissa; + mantissa -= digit; + *p++ = digit + + (digit < 10 + ? '0' + : dp->conversion - 10); + if (precision > 0) + precision--; + } + while (precision > 0) + { + *p++ = '0'; + precision--; + } + } + } + *p++ = dp->conversion - 'A' + 'P'; +# if WIDE_CHAR_VERSION + { + static const wchar_t decimal_format[] = + { '%', '+', 'd', '\0' }; + SNPRINTF (p, 6 + 1, decimal_format, exponent); + } + while (*p != '\0') + p++; +# else + if (sizeof (DCHAR_T) == 1) + { + sprintf ((char *) p, "%+d", exponent); + while (*p != '\0') + p++; + } + else + { + char expbuf[6 + 1]; + const char *ep; + sprintf (expbuf, "%+d", exponent); + for (ep = expbuf; (*p = *ep) != '\0'; ep++) + p++; + } +# endif + } + + END_LONG_DOUBLE_ROUNDING (); + } +# else + abort (); +# endif + } + else + { +# if NEED_PRINTF_DIRECTIVE_A || NEED_PRINTF_DOUBLE + double arg = a.arg[dp->arg_index].a.a_double; + + if (isnand (arg)) + { + if (dp->conversion == 'A') + { + *p++ = 'N'; *p++ = 'A'; *p++ = 'N'; + } + else + { + *p++ = 'n'; *p++ = 'a'; *p++ = 'n'; + } + } + else + { + int sign = 0; + + if (signbit (arg)) /* arg < 0.0 or negative zero */ + { + sign = -1; + arg = -arg; + } + + if (sign < 0) + *p++ = '-'; + else if (flags & FLAG_SHOWSIGN) + *p++ = '+'; + else if (flags & FLAG_SPACE) + *p++ = ' '; + + if (arg > 0.0 && arg + arg == arg) + { + if (dp->conversion == 'A') + { + *p++ = 'I'; *p++ = 'N'; *p++ = 'F'; + } + else + { + *p++ = 'i'; *p++ = 'n'; *p++ = 'f'; + } + } + else + { + int exponent; + double mantissa; + + if (arg > 0.0) + mantissa = printf_frexp (arg, &exponent); + else + { + exponent = 0; + mantissa = 0.0; + } + + if (has_precision + && precision < (unsigned int) ((DBL_DIG + 1) * 0.831) + 1) + { + /* Round the mantissa. */ + double tail = mantissa; + size_t q; + + for (q = precision; ; q--) + { + int digit = (int) tail; + tail -= digit; + if (q == 0) + { + if (digit & 1 ? tail >= 0.5 : tail > 0.5) + tail = 1 - tail; + else + tail = - tail; + break; + } + tail *= 16.0; + } + if (tail != 0.0) + for (q = precision; q > 0; q--) + tail *= 0.0625; + mantissa += tail; + } + + *p++ = '0'; + *p++ = dp->conversion - 'A' + 'X'; + pad_ptr = p; + { + int digit; + + digit = (int) mantissa; + mantissa -= digit; + *p++ = '0' + digit; + if ((flags & FLAG_ALT) + || mantissa > 0.0 || precision > 0) + { + *p++ = decimal_point_char (); + /* This loop terminates because we assume + that FLT_RADIX is a power of 2. */ + while (mantissa > 0.0) + { + mantissa *= 16.0; + digit = (int) mantissa; + mantissa -= digit; + *p++ = digit + + (digit < 10 + ? '0' + : dp->conversion - 10); + if (precision > 0) + precision--; + } + while (precision > 0) + { + *p++ = '0'; + precision--; + } + } + } + *p++ = dp->conversion - 'A' + 'P'; +# if WIDE_CHAR_VERSION + { + static const wchar_t decimal_format[] = + { '%', '+', 'd', '\0' }; + SNPRINTF (p, 6 + 1, decimal_format, exponent); + } + while (*p != '\0') + p++; +# else + if (sizeof (DCHAR_T) == 1) + { + sprintf ((char *) p, "%+d", exponent); + while (*p != '\0') + p++; + } + else + { + char expbuf[6 + 1]; + const char *ep; + sprintf (expbuf, "%+d", exponent); + for (ep = expbuf; (*p = *ep) != '\0'; ep++) + p++; + } +# endif + } + } +# else + abort (); +# endif + } + /* The generated string now extends from tmp to p, with the + zero padding insertion point being at pad_ptr. */ + if (has_width && p - tmp < width) + { + size_t pad = width - (p - tmp); + DCHAR_T *end = p + pad; + + if (flags & FLAG_LEFT) + { + /* Pad with spaces on the right. */ + for (; pad > 0; pad--) + *p++ = ' '; + } + else if ((flags & FLAG_ZERO) && pad_ptr != NULL) + { + /* Pad with zeroes. */ + DCHAR_T *q = end; + + while (p > pad_ptr) + *--q = *--p; + for (; pad > 0; pad--) + *p++ = '0'; + } + else + { + /* Pad with spaces on the left. */ + DCHAR_T *q = end; + + while (p > tmp) + *--q = *--p; + for (; pad > 0; pad--) + *p++ = ' '; + } + + p = end; + } + + { + size_t count = p - tmp; + + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); + + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); + + ENSURE_ALLOCATION (n); + } + + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; + } + } +#endif +#if (NEED_PRINTF_INFINITE_DOUBLE || NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE || NEED_PRINTF_LONG_DOUBLE) && !defined IN_LIBINTL + else if ((dp->conversion == 'f' || dp->conversion == 'F' + || dp->conversion == 'e' || dp->conversion == 'E' + || dp->conversion == 'g' || dp->conversion == 'G' + || dp->conversion == 'a' || dp->conversion == 'A') + && (0 +# if NEED_PRINTF_DOUBLE + || a.arg[dp->arg_index].type == TYPE_DOUBLE +# elif NEED_PRINTF_INFINITE_DOUBLE + || (a.arg[dp->arg_index].type == TYPE_DOUBLE + /* The systems (mingw) which produce wrong output + for Inf, -Inf, and NaN also do so for -0.0. + Therefore we treat this case here as well. */ + && is_infinite_or_zero (a.arg[dp->arg_index].a.a_double)) +# endif +# if NEED_PRINTF_LONG_DOUBLE + || a.arg[dp->arg_index].type == TYPE_LONGDOUBLE +# elif NEED_PRINTF_INFINITE_LONG_DOUBLE + || (a.arg[dp->arg_index].type == TYPE_LONGDOUBLE + /* Some systems produce wrong output for Inf, + -Inf, and NaN. Some systems in this category + (IRIX 5.3) also do so for -0.0. Therefore we + treat this case here as well. */ + && is_infinite_or_zerol (a.arg[dp->arg_index].a.a_longdouble)) +# endif + )) + { +# if (NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_DOUBLE) && (NEED_PRINTF_LONG_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE) + arg_type type = a.arg[dp->arg_index].type; +# endif + int flags = dp->flags; + int has_width; + size_t width; + int has_precision; + size_t precision; + size_t tmp_length; + DCHAR_T tmpbuf[700]; + DCHAR_T *tmp; + DCHAR_T *pad_ptr; + DCHAR_T *p; + + has_width = 0; + width = 0; + if (dp->width_start != dp->width_end) + { + if (dp->width_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->width_arg_index].a.a_int; + if (arg < 0) + { + /* "A negative field width is taken as a '-' flag + followed by a positive field width." */ + flags |= FLAG_LEFT; + width = (unsigned int) (-arg); + } + else + width = arg; + } + else + { + const FCHAR_T *digitp = dp->width_start; + + do + width = xsum (xtimes (width, 10), *digitp++ - '0'); + while (digitp != dp->width_end); + } + has_width = 1; + } + + has_precision = 0; + precision = 0; + if (dp->precision_start != dp->precision_end) + { + if (dp->precision_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->precision_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->precision_arg_index].a.a_int; + /* "A negative precision is taken as if the precision + were omitted." */ + if (arg >= 0) + { + precision = arg; + has_precision = 1; + } + } + else + { + const FCHAR_T *digitp = dp->precision_start + 1; + + precision = 0; + while (digitp != dp->precision_end) + precision = xsum (xtimes (precision, 10), *digitp++ - '0'); + has_precision = 1; + } + } + + /* POSIX specifies the default precision to be 6 for %f, %F, + %e, %E, but not for %g, %G. Implementations appear to use + the same default precision also for %g, %G. But for %a, %A, + the default precision is 0. */ + if (!has_precision) + if (!(dp->conversion == 'a' || dp->conversion == 'A')) + precision = 6; + + /* Allocate a temporary buffer of sufficient size. */ +# if NEED_PRINTF_DOUBLE && NEED_PRINTF_LONG_DOUBLE + tmp_length = (type == TYPE_LONGDOUBLE ? LDBL_DIG + 1 : DBL_DIG + 1); +# elif NEED_PRINTF_INFINITE_DOUBLE && NEED_PRINTF_LONG_DOUBLE + tmp_length = (type == TYPE_LONGDOUBLE ? LDBL_DIG + 1 : 0); +# elif NEED_PRINTF_LONG_DOUBLE + tmp_length = LDBL_DIG + 1; +# elif NEED_PRINTF_DOUBLE + tmp_length = DBL_DIG + 1; +# else + tmp_length = 0; +# endif + if (tmp_length < precision) + tmp_length = precision; +# if NEED_PRINTF_LONG_DOUBLE +# if NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_DOUBLE + if (type == TYPE_LONGDOUBLE) +# endif + if (dp->conversion == 'f' || dp->conversion == 'F') + { + long double arg = a.arg[dp->arg_index].a.a_longdouble; + if (!(isnanl (arg) || arg + arg == arg)) + { + /* arg is finite and nonzero. */ + int exponent = floorlog10l (arg < 0 ? -arg : arg); + if (exponent >= 0 && tmp_length < exponent + precision) + tmp_length = exponent + precision; + } + } +# endif +# if NEED_PRINTF_DOUBLE +# if NEED_PRINTF_LONG_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE + if (type == TYPE_DOUBLE) +# endif + if (dp->conversion == 'f' || dp->conversion == 'F') + { + double arg = a.arg[dp->arg_index].a.a_double; + if (!(isnand (arg) || arg + arg == arg)) + { + /* arg is finite and nonzero. */ + int exponent = floorlog10 (arg < 0 ? -arg : arg); + if (exponent >= 0 && tmp_length < exponent + precision) + tmp_length = exponent + precision; + } + } +# endif + /* Account for sign, decimal point etc. */ + tmp_length = xsum (tmp_length, 12); + + if (tmp_length < width) + tmp_length = width; + + tmp_length = xsum (tmp_length, 1); /* account for trailing NUL */ + + if (tmp_length <= sizeof (tmpbuf) / sizeof (DCHAR_T)) + tmp = tmpbuf; + else + { + size_t tmp_memsize = xtimes (tmp_length, sizeof (DCHAR_T)); + + if (size_overflow_p (tmp_memsize)) + /* Overflow, would lead to out of memory. */ + goto out_of_memory; + tmp = (DCHAR_T *) malloc (tmp_memsize); + if (tmp == NULL) + /* Out of memory. */ + goto out_of_memory; + } + + pad_ptr = NULL; + p = tmp; + +# if NEED_PRINTF_LONG_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE +# if NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_DOUBLE + if (type == TYPE_LONGDOUBLE) +# endif + { + long double arg = a.arg[dp->arg_index].a.a_longdouble; + + if (isnanl (arg)) + { + if (dp->conversion >= 'A' && dp->conversion <= 'Z') + { + *p++ = 'N'; *p++ = 'A'; *p++ = 'N'; + } + else + { + *p++ = 'n'; *p++ = 'a'; *p++ = 'n'; + } + } + else + { + int sign = 0; + DECL_LONG_DOUBLE_ROUNDING + + BEGIN_LONG_DOUBLE_ROUNDING (); + + if (signbit (arg)) /* arg < 0.0L or negative zero */ + { + sign = -1; + arg = -arg; + } + + if (sign < 0) + *p++ = '-'; + else if (flags & FLAG_SHOWSIGN) + *p++ = '+'; + else if (flags & FLAG_SPACE) + *p++ = ' '; + + if (arg > 0.0L && arg + arg == arg) + { + if (dp->conversion >= 'A' && dp->conversion <= 'Z') + { + *p++ = 'I'; *p++ = 'N'; *p++ = 'F'; + } + else + { + *p++ = 'i'; *p++ = 'n'; *p++ = 'f'; + } + } + else + { +# if NEED_PRINTF_LONG_DOUBLE + pad_ptr = p; + + if (dp->conversion == 'f' || dp->conversion == 'F') + { + char *digits; + size_t ndigits; + + digits = + scale10_round_decimal_long_double (arg, precision); + if (digits == NULL) + { + END_LONG_DOUBLE_ROUNDING (); + goto out_of_memory; + } + ndigits = strlen (digits); + + if (ndigits > precision) + do + { + --ndigits; + *p++ = digits[ndigits]; + } + while (ndigits > precision); + else + *p++ = '0'; + /* Here ndigits <= precision. */ + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > ndigits; precision--) + *p++ = '0'; + while (ndigits > 0) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + + free (digits); + } + else if (dp->conversion == 'e' || dp->conversion == 'E') + { + int exponent; + + if (arg == 0.0L) + { + exponent = 0; + *p++ = '0'; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > 0; precision--) + *p++ = '0'; + } + } + else + { + /* arg > 0.0L. */ + int adjusted; + char *digits; + size_t ndigits; + + exponent = floorlog10l (arg); + adjusted = 0; + for (;;) + { + digits = + scale10_round_decimal_long_double (arg, + (int)precision - exponent); + if (digits == NULL) + { + END_LONG_DOUBLE_ROUNDING (); + goto out_of_memory; + } + ndigits = strlen (digits); + + if (ndigits == precision + 1) + break; + if (ndigits < precision + || ndigits > precision + 2) + /* The exponent was not guessed + precisely enough. */ + abort (); + if (adjusted) + /* None of two values of exponent is + the right one. Prevent an endless + loop. */ + abort (); + free (digits); + if (ndigits == precision) + exponent -= 1; + else + exponent += 1; + adjusted = 1; + } + /* Here ndigits = precision+1. */ + if (is_borderline (digits, precision)) + { + /* Maybe the exponent guess was too high + and a smaller exponent can be reached + by turning a 10...0 into 9...9x. */ + char *digits2 = + scale10_round_decimal_long_double (arg, + (int)precision - exponent + 1); + if (digits2 == NULL) + { + free (digits); + END_LONG_DOUBLE_ROUNDING (); + goto out_of_memory; + } + if (strlen (digits2) == precision + 1) + { + free (digits); + digits = digits2; + exponent -= 1; + } + else + free (digits2); + } + /* Here ndigits = precision+1. */ + + *p++ = digits[--ndigits]; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + while (ndigits > 0) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + + free (digits); + } + + *p++ = dp->conversion; /* 'e' or 'E' */ +# if WIDE_CHAR_VERSION + { + static const wchar_t decimal_format[] = + { '%', '+', '.', '2', 'd', '\0' }; + SNPRINTF (p, 6 + 1, decimal_format, exponent); + } + while (*p != '\0') + p++; +# else + if (sizeof (DCHAR_T) == 1) + { + sprintf ((char *) p, "%+.2d", exponent); + while (*p != '\0') + p++; + } + else + { + char expbuf[6 + 1]; + const char *ep; + sprintf (expbuf, "%+.2d", exponent); + for (ep = expbuf; (*p = *ep) != '\0'; ep++) + p++; + } +# endif + } + else if (dp->conversion == 'g' || dp->conversion == 'G') + { + if (precision == 0) + precision = 1; + /* precision >= 1. */ + + if (arg == 0.0L) + /* The exponent is 0, >= -4, < precision. + Use fixed-point notation. */ + { + size_t ndigits = precision; + /* Number of trailing zeroes that have to be + dropped. */ + size_t nzeroes = + (flags & FLAG_ALT ? 0 : precision - 1); + + --ndigits; + *p++ = '0'; + if ((flags & FLAG_ALT) || ndigits > nzeroes) + { + *p++ = decimal_point_char (); + while (ndigits > nzeroes) + { + --ndigits; + *p++ = '0'; + } + } + } + else + { + /* arg > 0.0L. */ + int exponent; + int adjusted; + char *digits; + size_t ndigits; + size_t nzeroes; + + exponent = floorlog10l (arg); + adjusted = 0; + for (;;) + { + digits = + scale10_round_decimal_long_double (arg, + (int)(precision - 1) - exponent); + if (digits == NULL) + { + END_LONG_DOUBLE_ROUNDING (); + goto out_of_memory; + } + ndigits = strlen (digits); + + if (ndigits == precision) + break; + if (ndigits < precision - 1 + || ndigits > precision + 1) + /* The exponent was not guessed + precisely enough. */ + abort (); + if (adjusted) + /* None of two values of exponent is + the right one. Prevent an endless + loop. */ + abort (); + free (digits); + if (ndigits < precision) + exponent -= 1; + else + exponent += 1; + adjusted = 1; + } + /* Here ndigits = precision. */ + if (is_borderline (digits, precision - 1)) + { + /* Maybe the exponent guess was too high + and a smaller exponent can be reached + by turning a 10...0 into 9...9x. */ + char *digits2 = + scale10_round_decimal_long_double (arg, + (int)(precision - 1) - exponent + 1); + if (digits2 == NULL) + { + free (digits); + END_LONG_DOUBLE_ROUNDING (); + goto out_of_memory; + } + if (strlen (digits2) == precision) + { + free (digits); + digits = digits2; + exponent -= 1; + } + else + free (digits2); + } + /* Here ndigits = precision. */ + + /* Determine the number of trailing zeroes + that have to be dropped. */ + nzeroes = 0; + if ((flags & FLAG_ALT) == 0) + while (nzeroes < ndigits + && digits[nzeroes] == '0') + nzeroes++; + + /* The exponent is now determined. */ + if (exponent >= -4 + && exponent < (long)precision) + { + /* Fixed-point notation: + max(exponent,0)+1 digits, then the + decimal point, then the remaining + digits without trailing zeroes. */ + if (exponent >= 0) + { + size_t count = exponent + 1; + /* Note: count <= precision = ndigits. */ + for (; count > 0; count--) + *p++ = digits[--ndigits]; + if ((flags & FLAG_ALT) || ndigits > nzeroes) + { + *p++ = decimal_point_char (); + while (ndigits > nzeroes) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + } + else + { + size_t count = -exponent - 1; + *p++ = '0'; + *p++ = decimal_point_char (); + for (; count > 0; count--) + *p++ = '0'; + while (ndigits > nzeroes) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + } + else + { + /* Exponential notation. */ + *p++ = digits[--ndigits]; + if ((flags & FLAG_ALT) || ndigits > nzeroes) + { + *p++ = decimal_point_char (); + while (ndigits > nzeroes) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + *p++ = dp->conversion - 'G' + 'E'; /* 'e' or 'E' */ +# if WIDE_CHAR_VERSION + { + static const wchar_t decimal_format[] = + { '%', '+', '.', '2', 'd', '\0' }; + SNPRINTF (p, 6 + 1, decimal_format, exponent); + } + while (*p != '\0') + p++; +# else + if (sizeof (DCHAR_T) == 1) + { + sprintf ((char *) p, "%+.2d", exponent); + while (*p != '\0') + p++; + } + else + { + char expbuf[6 + 1]; + const char *ep; + sprintf (expbuf, "%+.2d", exponent); + for (ep = expbuf; (*p = *ep) != '\0'; ep++) + p++; + } +# endif + } + + free (digits); + } + } + else + abort (); +# else + /* arg is finite. */ + if (!(arg == 0.0L)) + abort (); + + pad_ptr = p; + + if (dp->conversion == 'f' || dp->conversion == 'F') + { + *p++ = '0'; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > 0; precision--) + *p++ = '0'; + } + } + else if (dp->conversion == 'e' || dp->conversion == 'E') + { + *p++ = '0'; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > 0; precision--) + *p++ = '0'; + } + *p++ = dp->conversion; /* 'e' or 'E' */ + *p++ = '+'; + *p++ = '0'; + *p++ = '0'; + } + else if (dp->conversion == 'g' || dp->conversion == 'G') + { + *p++ = '0'; + if (flags & FLAG_ALT) + { + size_t ndigits = + (precision > 0 ? precision - 1 : 0); + *p++ = decimal_point_char (); + for (; ndigits > 0; --ndigits) + *p++ = '0'; + } + } + else if (dp->conversion == 'a' || dp->conversion == 'A') + { + *p++ = '0'; + *p++ = dp->conversion - 'A' + 'X'; + pad_ptr = p; + *p++ = '0'; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > 0; precision--) + *p++ = '0'; + } + *p++ = dp->conversion - 'A' + 'P'; + *p++ = '+'; + *p++ = '0'; + } + else + abort (); +# endif + } + + END_LONG_DOUBLE_ROUNDING (); + } + } +# if NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_DOUBLE + else +# endif +# endif +# if NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_DOUBLE + { + double arg = a.arg[dp->arg_index].a.a_double; + + if (isnand (arg)) + { + if (dp->conversion >= 'A' && dp->conversion <= 'Z') + { + *p++ = 'N'; *p++ = 'A'; *p++ = 'N'; + } + else + { + *p++ = 'n'; *p++ = 'a'; *p++ = 'n'; + } + } + else + { + int sign = 0; + + if (signbit (arg)) /* arg < 0.0 or negative zero */ + { + sign = -1; + arg = -arg; + } + + if (sign < 0) + *p++ = '-'; + else if (flags & FLAG_SHOWSIGN) + *p++ = '+'; + else if (flags & FLAG_SPACE) + *p++ = ' '; + + if (arg > 0.0 && arg + arg == arg) + { + if (dp->conversion >= 'A' && dp->conversion <= 'Z') + { + *p++ = 'I'; *p++ = 'N'; *p++ = 'F'; + } + else + { + *p++ = 'i'; *p++ = 'n'; *p++ = 'f'; + } + } + else + { +# if NEED_PRINTF_DOUBLE + pad_ptr = p; + + if (dp->conversion == 'f' || dp->conversion == 'F') + { + char *digits; + size_t ndigits; + + digits = + scale10_round_decimal_double (arg, precision); + if (digits == NULL) + goto out_of_memory; + ndigits = strlen (digits); + + if (ndigits > precision) + do + { + --ndigits; + *p++ = digits[ndigits]; + } + while (ndigits > precision); + else + *p++ = '0'; + /* Here ndigits <= precision. */ + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > ndigits; precision--) + *p++ = '0'; + while (ndigits > 0) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + + free (digits); + } + else if (dp->conversion == 'e' || dp->conversion == 'E') + { + int exponent; + + if (arg == 0.0) + { + exponent = 0; + *p++ = '0'; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > 0; precision--) + *p++ = '0'; + } + } + else + { + /* arg > 0.0. */ + int adjusted; + char *digits; + size_t ndigits; + + exponent = floorlog10 (arg); + adjusted = 0; + for (;;) + { + digits = + scale10_round_decimal_double (arg, + (int)precision - exponent); + if (digits == NULL) + goto out_of_memory; + ndigits = strlen (digits); + + if (ndigits == precision + 1) + break; + if (ndigits < precision + || ndigits > precision + 2) + /* The exponent was not guessed + precisely enough. */ + abort (); + if (adjusted) + /* None of two values of exponent is + the right one. Prevent an endless + loop. */ + abort (); + free (digits); + if (ndigits == precision) + exponent -= 1; + else + exponent += 1; + adjusted = 1; + } + /* Here ndigits = precision+1. */ + if (is_borderline (digits, precision)) + { + /* Maybe the exponent guess was too high + and a smaller exponent can be reached + by turning a 10...0 into 9...9x. */ + char *digits2 = + scale10_round_decimal_double (arg, + (int)precision - exponent + 1); + if (digits2 == NULL) + { + free (digits); + goto out_of_memory; + } + if (strlen (digits2) == precision + 1) + { + free (digits); + digits = digits2; + exponent -= 1; + } + else + free (digits2); + } + /* Here ndigits = precision+1. */ + + *p++ = digits[--ndigits]; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + while (ndigits > 0) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + + free (digits); + } + + *p++ = dp->conversion; /* 'e' or 'E' */ +# if WIDE_CHAR_VERSION + { + static const wchar_t decimal_format[] = + /* Produce the same number of exponent digits + as the native printf implementation. */ +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + { '%', '+', '.', '3', 'd', '\0' }; +# else + { '%', '+', '.', '2', 'd', '\0' }; +# endif + SNPRINTF (p, 6 + 1, decimal_format, exponent); + } + while (*p != '\0') + p++; +# else + { + static const char decimal_format[] = + /* Produce the same number of exponent digits + as the native printf implementation. */ +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + "%+.3d"; +# else + "%+.2d"; +# endif + if (sizeof (DCHAR_T) == 1) + { + sprintf ((char *) p, decimal_format, exponent); + while (*p != '\0') + p++; + } + else + { + char expbuf[6 + 1]; + const char *ep; + sprintf (expbuf, decimal_format, exponent); + for (ep = expbuf; (*p = *ep) != '\0'; ep++) + p++; + } + } +# endif + } + else if (dp->conversion == 'g' || dp->conversion == 'G') + { + if (precision == 0) + precision = 1; + /* precision >= 1. */ + + if (arg == 0.0) + /* The exponent is 0, >= -4, < precision. + Use fixed-point notation. */ + { + size_t ndigits = precision; + /* Number of trailing zeroes that have to be + dropped. */ + size_t nzeroes = + (flags & FLAG_ALT ? 0 : precision - 1); + + --ndigits; + *p++ = '0'; + if ((flags & FLAG_ALT) || ndigits > nzeroes) + { + *p++ = decimal_point_char (); + while (ndigits > nzeroes) + { + --ndigits; + *p++ = '0'; + } + } + } + else + { + /* arg > 0.0. */ + int exponent; + int adjusted; + char *digits; + size_t ndigits; + size_t nzeroes; + + exponent = floorlog10 (arg); + adjusted = 0; + for (;;) + { + digits = + scale10_round_decimal_double (arg, + (int)(precision - 1) - exponent); + if (digits == NULL) + goto out_of_memory; + ndigits = strlen (digits); + + if (ndigits == precision) + break; + if (ndigits < precision - 1 + || ndigits > precision + 1) + /* The exponent was not guessed + precisely enough. */ + abort (); + if (adjusted) + /* None of two values of exponent is + the right one. Prevent an endless + loop. */ + abort (); + free (digits); + if (ndigits < precision) + exponent -= 1; + else + exponent += 1; + adjusted = 1; + } + /* Here ndigits = precision. */ + if (is_borderline (digits, precision - 1)) + { + /* Maybe the exponent guess was too high + and a smaller exponent can be reached + by turning a 10...0 into 9...9x. */ + char *digits2 = + scale10_round_decimal_double (arg, + (int)(precision - 1) - exponent + 1); + if (digits2 == NULL) + { + free (digits); + goto out_of_memory; + } + if (strlen (digits2) == precision) + { + free (digits); + digits = digits2; + exponent -= 1; + } + else + free (digits2); + } + /* Here ndigits = precision. */ + + /* Determine the number of trailing zeroes + that have to be dropped. */ + nzeroes = 0; + if ((flags & FLAG_ALT) == 0) + while (nzeroes < ndigits + && digits[nzeroes] == '0') + nzeroes++; + + /* The exponent is now determined. */ + if (exponent >= -4 + && exponent < (long)precision) + { + /* Fixed-point notation: + max(exponent,0)+1 digits, then the + decimal point, then the remaining + digits without trailing zeroes. */ + if (exponent >= 0) + { + size_t count = exponent + 1; + /* Note: count <= precision = ndigits. */ + for (; count > 0; count--) + *p++ = digits[--ndigits]; + if ((flags & FLAG_ALT) || ndigits > nzeroes) + { + *p++ = decimal_point_char (); + while (ndigits > nzeroes) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + } + else + { + size_t count = -exponent - 1; + *p++ = '0'; + *p++ = decimal_point_char (); + for (; count > 0; count--) + *p++ = '0'; + while (ndigits > nzeroes) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + } + else + { + /* Exponential notation. */ + *p++ = digits[--ndigits]; + if ((flags & FLAG_ALT) || ndigits > nzeroes) + { + *p++ = decimal_point_char (); + while (ndigits > nzeroes) + { + --ndigits; + *p++ = digits[ndigits]; + } + } + *p++ = dp->conversion - 'G' + 'E'; /* 'e' or 'E' */ +# if WIDE_CHAR_VERSION + { + static const wchar_t decimal_format[] = + /* Produce the same number of exponent digits + as the native printf implementation. */ +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + { '%', '+', '.', '3', 'd', '\0' }; +# else + { '%', '+', '.', '2', 'd', '\0' }; +# endif + SNPRINTF (p, 6 + 1, decimal_format, exponent); + } + while (*p != '\0') + p++; +# else + { + static const char decimal_format[] = + /* Produce the same number of exponent digits + as the native printf implementation. */ +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + "%+.3d"; +# else + "%+.2d"; +# endif + if (sizeof (DCHAR_T) == 1) + { + sprintf ((char *) p, decimal_format, exponent); + while (*p != '\0') + p++; + } + else + { + char expbuf[6 + 1]; + const char *ep; + sprintf (expbuf, decimal_format, exponent); + for (ep = expbuf; (*p = *ep) != '\0'; ep++) + p++; + } + } +# endif + } + + free (digits); + } + } + else + abort (); +# else + /* arg is finite. */ + if (!(arg == 0.0)) + abort (); + + pad_ptr = p; + + if (dp->conversion == 'f' || dp->conversion == 'F') + { + *p++ = '0'; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > 0; precision--) + *p++ = '0'; + } + } + else if (dp->conversion == 'e' || dp->conversion == 'E') + { + *p++ = '0'; + if ((flags & FLAG_ALT) || precision > 0) + { + *p++ = decimal_point_char (); + for (; precision > 0; precision--) + *p++ = '0'; + } + *p++ = dp->conversion; /* 'e' or 'E' */ + *p++ = '+'; + /* Produce the same number of exponent digits as + the native printf implementation. */ +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + *p++ = '0'; +# endif + *p++ = '0'; + *p++ = '0'; + } + else if (dp->conversion == 'g' || dp->conversion == 'G') + { + *p++ = '0'; + if (flags & FLAG_ALT) + { + size_t ndigits = + (precision > 0 ? precision - 1 : 0); + *p++ = decimal_point_char (); + for (; ndigits > 0; --ndigits) + *p++ = '0'; + } + } + else + abort (); +# endif + } + } + } +# endif + + /* The generated string now extends from tmp to p, with the + zero padding insertion point being at pad_ptr. */ + if (has_width && p - tmp < width) + { + size_t pad = width - (p - tmp); + DCHAR_T *end = p + pad; + + if (flags & FLAG_LEFT) + { + /* Pad with spaces on the right. */ + for (; pad > 0; pad--) + *p++ = ' '; + } + else if ((flags & FLAG_ZERO) && pad_ptr != NULL) + { + /* Pad with zeroes. */ + DCHAR_T *q = end; + + while (p > pad_ptr) + *--q = *--p; + for (; pad > 0; pad--) + *p++ = '0'; + } + else + { + /* Pad with spaces on the left. */ + DCHAR_T *q = end; + + while (p > tmp) + *--q = *--p; + for (; pad > 0; pad--) + *p++ = ' '; + } + + p = end; + } + + { + size_t count = p - tmp; + + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); + + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); + + ENSURE_ALLOCATION (n); + } + + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; + } + } +#endif + else + { + arg_type type = a.arg[dp->arg_index].type; + int flags = dp->flags; +#if !USE_SNPRINTF || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION + int has_width; + size_t width; +#endif +#if !USE_SNPRINTF || NEED_PRINTF_UNBOUNDED_PRECISION + int has_precision; + size_t precision; +#endif +#if NEED_PRINTF_UNBOUNDED_PRECISION + int prec_ourselves; +#else +# define prec_ourselves 0 +#endif +#if NEED_PRINTF_FLAG_LEFTADJUST +# define pad_ourselves 1 +#elif !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION + int pad_ourselves; +#else +# define pad_ourselves 0 +#endif + TCHAR_T *fbp; + unsigned int prefix_count; + int prefixes[2] IF_LINT (= { 0 }); +#if !USE_SNPRINTF + size_t tmp_length; + TCHAR_T tmpbuf[700]; + TCHAR_T *tmp; +#endif + +#if !USE_SNPRINTF || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION + has_width = 0; + width = 0; + if (dp->width_start != dp->width_end) + { + if (dp->width_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->width_arg_index].a.a_int; + if (arg < 0) + { + /* "A negative field width is taken as a '-' flag + followed by a positive field width." */ + flags |= FLAG_LEFT; + width = (unsigned int) (-arg); + } + else + width = arg; + } + else + { + const FCHAR_T *digitp = dp->width_start; + + do + width = xsum (xtimes (width, 10), *digitp++ - '0'); + while (digitp != dp->width_end); + } + has_width = 1; + } +#endif + +#if !USE_SNPRINTF || NEED_PRINTF_UNBOUNDED_PRECISION + has_precision = 0; + precision = 6; + if (dp->precision_start != dp->precision_end) + { + if (dp->precision_arg_index != ARG_NONE) + { + int arg; + + if (!(a.arg[dp->precision_arg_index].type == TYPE_INT)) + abort (); + arg = a.arg[dp->precision_arg_index].a.a_int; + /* "A negative precision is taken as if the precision + were omitted." */ + if (arg >= 0) + { + precision = arg; + has_precision = 1; + } + } + else + { + const FCHAR_T *digitp = dp->precision_start + 1; + + precision = 0; + while (digitp != dp->precision_end) + precision = xsum (xtimes (precision, 10), *digitp++ - '0'); + has_precision = 1; + } + } +#endif + + /* Decide whether to handle the precision ourselves. */ +#if NEED_PRINTF_UNBOUNDED_PRECISION + switch (dp->conversion) + { + case 'd': case 'i': case 'u': + case 'o': + case 'x': case 'X': case 'p': + prec_ourselves = has_precision && (precision > 0); + break; + default: + prec_ourselves = 0; + break; + } +#endif + + /* Decide whether to perform the padding ourselves. */ +#if !NEED_PRINTF_FLAG_LEFTADJUST && (!DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION) + switch (dp->conversion) + { +# if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO + /* If we need conversion from TCHAR_T[] to DCHAR_T[], we need + to perform the padding after this conversion. Functions + with unistdio extensions perform the padding based on + character count rather than element count. */ + case 'c': case 's': +# endif +# if NEED_PRINTF_FLAG_ZERO + case 'f': case 'F': case 'e': case 'E': case 'g': case 'G': + case 'a': case 'A': +# endif + pad_ourselves = 1; + break; + default: + pad_ourselves = prec_ourselves; + break; + } +#endif + +#if !USE_SNPRINTF + /* Allocate a temporary buffer of sufficient size for calling + sprintf. */ + { + switch (dp->conversion) + { + + case 'd': case 'i': case 'u': +# if HAVE_LONG_LONG_INT + if (type == TYPE_LONGLONGINT || type == TYPE_ULONGLONGINT) + tmp_length = + (unsigned int) (sizeof (unsigned long long) * CHAR_BIT + * 0.30103 /* binary -> decimal */ + ) + + 1; /* turn floor into ceil */ + else +# endif + if (type == TYPE_LONGINT || type == TYPE_ULONGINT) + tmp_length = + (unsigned int) (sizeof (unsigned long) * CHAR_BIT + * 0.30103 /* binary -> decimal */ + ) + + 1; /* turn floor into ceil */ + else + tmp_length = + (unsigned int) (sizeof (unsigned int) * CHAR_BIT + * 0.30103 /* binary -> decimal */ + ) + + 1; /* turn floor into ceil */ + if (tmp_length < precision) + tmp_length = precision; + /* Multiply by 2, as an estimate for FLAG_GROUP. */ + tmp_length = xsum (tmp_length, tmp_length); + /* Add 1, to account for a leading sign. */ + tmp_length = xsum (tmp_length, 1); + break; + + case 'o': +# if HAVE_LONG_LONG_INT + if (type == TYPE_LONGLONGINT || type == TYPE_ULONGLONGINT) + tmp_length = + (unsigned int) (sizeof (unsigned long long) * CHAR_BIT + * 0.333334 /* binary -> octal */ + ) + + 1; /* turn floor into ceil */ + else +# endif + if (type == TYPE_LONGINT || type == TYPE_ULONGINT) + tmp_length = + (unsigned int) (sizeof (unsigned long) * CHAR_BIT + * 0.333334 /* binary -> octal */ + ) + + 1; /* turn floor into ceil */ + else + tmp_length = + (unsigned int) (sizeof (unsigned int) * CHAR_BIT + * 0.333334 /* binary -> octal */ + ) + + 1; /* turn floor into ceil */ + if (tmp_length < precision) + tmp_length = precision; + /* Add 1, to account for a leading sign. */ + tmp_length = xsum (tmp_length, 1); + break; + + case 'x': case 'X': +# if HAVE_LONG_LONG_INT + if (type == TYPE_LONGLONGINT || type == TYPE_ULONGLONGINT) + tmp_length = + (unsigned int) (sizeof (unsigned long long) * CHAR_BIT + * 0.25 /* binary -> hexadecimal */ + ) + + 1; /* turn floor into ceil */ + else +# endif + if (type == TYPE_LONGINT || type == TYPE_ULONGINT) + tmp_length = + (unsigned int) (sizeof (unsigned long) * CHAR_BIT + * 0.25 /* binary -> hexadecimal */ + ) + + 1; /* turn floor into ceil */ + else + tmp_length = + (unsigned int) (sizeof (unsigned int) * CHAR_BIT + * 0.25 /* binary -> hexadecimal */ + ) + + 1; /* turn floor into ceil */ + if (tmp_length < precision) + tmp_length = precision; + /* Add 2, to account for a leading sign or alternate form. */ + tmp_length = xsum (tmp_length, 2); + break; + + case 'f': case 'F': + if (type == TYPE_LONGDOUBLE) + tmp_length = + (unsigned int) (LDBL_MAX_EXP + * 0.30103 /* binary -> decimal */ + * 2 /* estimate for FLAG_GROUP */ + ) + + 1 /* turn floor into ceil */ + + 10; /* sign, decimal point etc. */ + else + tmp_length = + (unsigned int) (DBL_MAX_EXP + * 0.30103 /* binary -> decimal */ + * 2 /* estimate for FLAG_GROUP */ + ) + + 1 /* turn floor into ceil */ + + 10; /* sign, decimal point etc. */ + tmp_length = xsum (tmp_length, precision); + break; + + case 'e': case 'E': case 'g': case 'G': + tmp_length = + 12; /* sign, decimal point, exponent etc. */ + tmp_length = xsum (tmp_length, precision); + break; + + case 'a': case 'A': + if (type == TYPE_LONGDOUBLE) + tmp_length = + (unsigned int) (LDBL_DIG + * 0.831 /* decimal -> hexadecimal */ + ) + + 1; /* turn floor into ceil */ + else + tmp_length = + (unsigned int) (DBL_DIG + * 0.831 /* decimal -> hexadecimal */ + ) + + 1; /* turn floor into ceil */ + if (tmp_length < precision) + tmp_length = precision; + /* Account for sign, decimal point etc. */ + tmp_length = xsum (tmp_length, 12); + break; + + case 'c': +# if HAVE_WINT_T && !WIDE_CHAR_VERSION + if (type == TYPE_WIDE_CHAR) + tmp_length = MB_CUR_MAX; + else +# endif + tmp_length = 1; + break; + + case 's': +# if HAVE_WCHAR_T + if (type == TYPE_WIDE_STRING) + { +# if WIDE_CHAR_VERSION + /* ISO C says about %ls in fwprintf: + "If the precision is not specified or is greater + than the size of the array, the array shall + contain a null wide character." + So if there is a precision, we must not use + wcslen. */ + const wchar_t *arg = + a.arg[dp->arg_index].a.a_wide_string; + + if (has_precision) + tmp_length = local_wcsnlen (arg, precision); + else + tmp_length = local_wcslen (arg); +# else + /* ISO C says about %ls in fprintf: + "If a precision is specified, no more than that + many bytes are written (including shift + sequences, if any), and the array shall contain + a null wide character if, to equal the + multibyte character sequence length given by + the precision, the function would need to + access a wide character one past the end of the + array." + So if there is a precision, we must not use + wcslen. */ + /* This case has already been handled above. */ + abort (); +# endif + } + else +# endif + { +# if WIDE_CHAR_VERSION + /* ISO C says about %s in fwprintf: + "If the precision is not specified or is greater + than the size of the converted array, the + converted array shall contain a null wide + character." + So if there is a precision, we must not use + strlen. */ + /* This case has already been handled above. */ + abort (); +# else + /* ISO C says about %s in fprintf: + "If the precision is not specified or greater + than the size of the array, the array shall + contain a null character." + So if there is a precision, we must not use + strlen. */ + const char *arg = a.arg[dp->arg_index].a.a_string; + + if (has_precision) + tmp_length = local_strnlen (arg, precision); + else + tmp_length = strlen (arg); +# endif + } + break; + + case 'p': + tmp_length = + (unsigned int) (sizeof (void *) * CHAR_BIT + * 0.25 /* binary -> hexadecimal */ + ) + + 1 /* turn floor into ceil */ + + 2; /* account for leading 0x */ + break; + + default: + abort (); + } + + if (!pad_ourselves) + { +# if ENABLE_UNISTDIO + /* Padding considers the number of characters, therefore + the number of elements after padding may be + > max (tmp_length, width) + but is certainly + <= tmp_length + width. */ + tmp_length = xsum (tmp_length, width); +# else + /* Padding considers the number of elements, + says POSIX. */ + if (tmp_length < width) + tmp_length = width; +# endif + } + + tmp_length = xsum (tmp_length, 1); /* account for trailing NUL */ + } + + if (tmp_length <= sizeof (tmpbuf) / sizeof (TCHAR_T)) + tmp = tmpbuf; + else + { + size_t tmp_memsize = xtimes (tmp_length, sizeof (TCHAR_T)); + + if (size_overflow_p (tmp_memsize)) + /* Overflow, would lead to out of memory. */ + goto out_of_memory; + tmp = (TCHAR_T *) malloc (tmp_memsize); + if (tmp == NULL) + /* Out of memory. */ + goto out_of_memory; + } +#endif + + /* Construct the format string for calling snprintf or + sprintf. */ + fbp = buf; + *fbp++ = '%'; +#if NEED_PRINTF_FLAG_GROUPING + /* The underlying implementation doesn't support the ' flag. + Produce no grouping characters in this case; this is + acceptable because the grouping is locale dependent. */ +#else + if (flags & FLAG_GROUP) + *fbp++ = '\''; +#endif + if (flags & FLAG_LEFT) + *fbp++ = '-'; + if (flags & FLAG_SHOWSIGN) + *fbp++ = '+'; + if (flags & FLAG_SPACE) + *fbp++ = ' '; + if (flags & FLAG_ALT) + *fbp++ = '#'; + if (!pad_ourselves) + { + if (flags & FLAG_ZERO) + *fbp++ = '0'; + if (dp->width_start != dp->width_end) + { + size_t n = dp->width_end - dp->width_start; + /* The width specification is known to consist only + of standard ASCII characters. */ + if (sizeof (FCHAR_T) == sizeof (TCHAR_T)) + { + memcpy (fbp, dp->width_start, n * sizeof (TCHAR_T)); + fbp += n; + } + else + { + const FCHAR_T *mp = dp->width_start; + do + *fbp++ = (unsigned char) *mp++; + while (--n > 0); + } + } + } + if (!prec_ourselves) + { + if (dp->precision_start != dp->precision_end) + { + size_t n = dp->precision_end - dp->precision_start; + /* The precision specification is known to consist only + of standard ASCII characters. */ + if (sizeof (FCHAR_T) == sizeof (TCHAR_T)) + { + memcpy (fbp, dp->precision_start, n * sizeof (TCHAR_T)); + fbp += n; + } + else + { + const FCHAR_T *mp = dp->precision_start; + do + *fbp++ = (unsigned char) *mp++; + while (--n > 0); + } + } + } + + switch (type) + { +#if HAVE_LONG_LONG_INT + case TYPE_LONGLONGINT: + case TYPE_ULONGLONGINT: +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + *fbp++ = 'I'; + *fbp++ = '6'; + *fbp++ = '4'; + break; +# else + *fbp++ = 'l'; + /*FALLTHROUGH*/ +# endif +#endif + case TYPE_LONGINT: + case TYPE_ULONGINT: +#if HAVE_WINT_T + case TYPE_WIDE_CHAR: +#endif +#if HAVE_WCHAR_T + case TYPE_WIDE_STRING: +#endif + *fbp++ = 'l'; + break; + case TYPE_LONGDOUBLE: + *fbp++ = 'L'; + break; + default: + break; + } +#if NEED_PRINTF_DIRECTIVE_F + if (dp->conversion == 'F') + *fbp = 'f'; + else +#endif + *fbp = dp->conversion; +#if USE_SNPRINTF +# if !(__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)) + fbp[1] = '%'; + fbp[2] = 'n'; + fbp[3] = '\0'; +# else + /* On glibc2 systems from glibc >= 2.3 - probably also older + ones - we know that snprintf's returns value conforms to + ISO C 99: the gl_SNPRINTF_DIRECTIVE_N test passes. + Therefore we can avoid using %n in this situation. + On glibc2 systems from 2004-10-18 or newer, the use of %n + in format strings in writable memory may crash the program + (if compiled with _FORTIFY_SOURCE=2), so we should avoid it + in this situation. */ + /* On native Win32 systems (such as mingw), we can avoid using + %n because: + - Although the gl_SNPRINTF_TRUNCATION_C99 test fails, + snprintf does not write more than the specified number + of bytes. (snprintf (buf, 3, "%d %d", 4567, 89) writes + '4', '5', '6' into buf, not '4', '5', '\0'.) + - Although the gl_SNPRINTF_RETVAL_C99 test fails, snprintf + allows us to recognize the case of an insufficient + buffer size: it returns -1 in this case. + On native Win32 systems (such as mingw) where the OS is + Windows Vista, the use of %n in format strings by default + crashes the program. See + and + + So we should avoid %n in this situation. */ + fbp[1] = '\0'; +# endif +#else + fbp[1] = '\0'; +#endif + + /* Construct the arguments for calling snprintf or sprintf. */ + prefix_count = 0; + if (!pad_ourselves && dp->width_arg_index != ARG_NONE) + { + if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) + abort (); + prefixes[prefix_count++] = a.arg[dp->width_arg_index].a.a_int; + } + if (!prec_ourselves && dp->precision_arg_index != ARG_NONE) + { + if (!(a.arg[dp->precision_arg_index].type == TYPE_INT)) + abort (); + prefixes[prefix_count++] = a.arg[dp->precision_arg_index].a.a_int; + } + +#if USE_SNPRINTF + /* The SNPRINTF result is appended after result[0..length]. + The latter is an array of DCHAR_T; SNPRINTF appends an + array of TCHAR_T to it. This is possible because + sizeof (TCHAR_T) divides sizeof (DCHAR_T) and + alignof (TCHAR_T) <= alignof (DCHAR_T). */ +# define TCHARS_PER_DCHAR (sizeof (DCHAR_T) / sizeof (TCHAR_T)) + /* Ensure that maxlen below will be >= 2. Needed on BeOS, + where an snprintf() with maxlen==1 acts like sprintf(). */ + ENSURE_ALLOCATION (xsum (length, + (2 + TCHARS_PER_DCHAR - 1) + / TCHARS_PER_DCHAR)); + /* Prepare checking whether snprintf returns the count + via %n. */ + *(TCHAR_T *) (result + length) = '\0'; +#endif + + for (;;) + { + int count = -1; + +#if USE_SNPRINTF + int retcount = 0; + size_t maxlen = allocated - length; + /* SNPRINTF can fail if its second argument is + > INT_MAX. */ + if (maxlen > INT_MAX / TCHARS_PER_DCHAR) + maxlen = INT_MAX / TCHARS_PER_DCHAR; + maxlen = maxlen * TCHARS_PER_DCHAR; +# define SNPRINTF_BUF(arg) \ + switch (prefix_count) \ + { \ + case 0: \ + retcount = SNPRINTF ((TCHAR_T *) (result + length), \ + maxlen, buf, \ + arg, &count); \ + break; \ + case 1: \ + retcount = SNPRINTF ((TCHAR_T *) (result + length), \ + maxlen, buf, \ + prefixes[0], arg, &count); \ + break; \ + case 2: \ + retcount = SNPRINTF ((TCHAR_T *) (result + length), \ + maxlen, buf, \ + prefixes[0], prefixes[1], arg, \ + &count); \ + break; \ + default: \ + abort (); \ + } +#else +# define SNPRINTF_BUF(arg) \ + switch (prefix_count) \ + { \ + case 0: \ + count = sprintf (tmp, buf, arg); \ + break; \ + case 1: \ + count = sprintf (tmp, buf, prefixes[0], arg); \ + break; \ + case 2: \ + count = sprintf (tmp, buf, prefixes[0], prefixes[1],\ + arg); \ + break; \ + default: \ + abort (); \ + } +#endif + + switch (type) + { + case TYPE_SCHAR: + { + int arg = a.arg[dp->arg_index].a.a_schar; + SNPRINTF_BUF (arg); + } + break; + case TYPE_UCHAR: + { + unsigned int arg = a.arg[dp->arg_index].a.a_uchar; + SNPRINTF_BUF (arg); + } + break; + case TYPE_SHORT: + { + int arg = a.arg[dp->arg_index].a.a_short; + SNPRINTF_BUF (arg); + } + break; + case TYPE_USHORT: + { + unsigned int arg = a.arg[dp->arg_index].a.a_ushort; + SNPRINTF_BUF (arg); + } + break; + case TYPE_INT: + { + int arg = a.arg[dp->arg_index].a.a_int; + SNPRINTF_BUF (arg); + } + break; + case TYPE_UINT: + { + unsigned int arg = a.arg[dp->arg_index].a.a_uint; + SNPRINTF_BUF (arg); + } + break; + case TYPE_LONGINT: + { + long int arg = a.arg[dp->arg_index].a.a_longint; + SNPRINTF_BUF (arg); + } + break; + case TYPE_ULONGINT: + { + unsigned long int arg = a.arg[dp->arg_index].a.a_ulongint; + SNPRINTF_BUF (arg); + } + break; +#if HAVE_LONG_LONG_INT + case TYPE_LONGLONGINT: + { + long long int arg = a.arg[dp->arg_index].a.a_longlongint; + SNPRINTF_BUF (arg); + } + break; + case TYPE_ULONGLONGINT: + { + unsigned long long int arg = a.arg[dp->arg_index].a.a_ulonglongint; + SNPRINTF_BUF (arg); + } + break; +#endif + case TYPE_DOUBLE: + { + double arg = a.arg[dp->arg_index].a.a_double; + SNPRINTF_BUF (arg); + } + break; + case TYPE_LONGDOUBLE: + { + long double arg = a.arg[dp->arg_index].a.a_longdouble; + SNPRINTF_BUF (arg); + } + break; + case TYPE_CHAR: + { + int arg = a.arg[dp->arg_index].a.a_char; + SNPRINTF_BUF (arg); + } + break; +#if HAVE_WINT_T + case TYPE_WIDE_CHAR: + { + wint_t arg = a.arg[dp->arg_index].a.a_wide_char; + SNPRINTF_BUF (arg); + } + break; +#endif + case TYPE_STRING: + { + const char *arg = a.arg[dp->arg_index].a.a_string; + SNPRINTF_BUF (arg); + } + break; +#if HAVE_WCHAR_T + case TYPE_WIDE_STRING: + { + const wchar_t *arg = a.arg[dp->arg_index].a.a_wide_string; + SNPRINTF_BUF (arg); + } + break; +#endif + case TYPE_POINTER: + { + void *arg = a.arg[dp->arg_index].a.a_pointer; + SNPRINTF_BUF (arg); + } + break; + default: + abort (); + } + +#if USE_SNPRINTF + /* Portability: Not all implementations of snprintf() + are ISO C 99 compliant. Determine the number of + bytes that snprintf() has produced or would have + produced. */ + if (count >= 0) + { + /* Verify that snprintf() has NUL-terminated its + result. */ + if (count < maxlen + && ((TCHAR_T *) (result + length)) [count] != '\0') + abort (); + /* Portability hack. */ + if (retcount > count) + count = retcount; + } + else + { + /* snprintf() doesn't understand the '%n' + directive. */ + if (fbp[1] != '\0') + { + /* Don't use the '%n' directive; instead, look + at the snprintf() return value. */ + fbp[1] = '\0'; + continue; + } + else + { + /* Look at the snprintf() return value. */ + if (retcount < 0) + { + /* HP-UX 10.20 snprintf() is doubly deficient: + It doesn't understand the '%n' directive, + *and* it returns -1 (rather than the length + that would have been required) when the + buffer is too small. */ + size_t bigger_need = + xsum (xtimes (allocated, 2), 12); + ENSURE_ALLOCATION (bigger_need); + continue; + } + else + count = retcount; + } + } +#endif + + /* Attempt to handle failure. */ + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EINVAL; + return NULL; + } + +#if USE_SNPRINTF + /* Handle overflow of the allocated buffer. + If such an overflow occurs, a C99 compliant snprintf() + returns a count >= maxlen. However, a non-compliant + snprintf() function returns only count = maxlen - 1. To + cover both cases, test whether count >= maxlen - 1. */ + if ((unsigned int) count + 1 >= maxlen) + { + /* If maxlen already has attained its allowed maximum, + allocating more memory will not increase maxlen. + Instead of looping, bail out. */ + if (maxlen == INT_MAX / TCHARS_PER_DCHAR) + goto overflow; + else + { + /* Need at least (count + 1) * sizeof (TCHAR_T) + bytes. (The +1 is for the trailing NUL.) + But ask for (count + 2) * sizeof (TCHAR_T) + bytes, so that in the next round, we likely get + maxlen > (unsigned int) count + 1 + and so we don't get here again. + And allocate proportionally, to avoid looping + eternally if snprintf() reports a too small + count. */ + size_t n = + xmax (xsum (length, + ((unsigned int) count + 2 + + TCHARS_PER_DCHAR - 1) + / TCHARS_PER_DCHAR), + xtimes (allocated, 2)); + + ENSURE_ALLOCATION (n); + continue; + } + } +#endif + +#if NEED_PRINTF_UNBOUNDED_PRECISION + if (prec_ourselves) + { + /* Handle the precision. */ + TCHAR_T *prec_ptr = +# if USE_SNPRINTF + (TCHAR_T *) (result + length); +# else + tmp; +# endif + size_t prefix_count; + size_t move; + + prefix_count = 0; + /* Put the additional zeroes after the sign. */ + if (count >= 1 + && (*prec_ptr == '-' || *prec_ptr == '+' + || *prec_ptr == ' ')) + prefix_count = 1; + /* Put the additional zeroes after the 0x prefix if + (flags & FLAG_ALT) || (dp->conversion == 'p'). */ + else if (count >= 2 + && prec_ptr[0] == '0' + && (prec_ptr[1] == 'x' || prec_ptr[1] == 'X')) + prefix_count = 2; + + move = count - prefix_count; + if (precision > move) + { + /* Insert zeroes. */ + size_t insert = precision - move; + TCHAR_T *prec_end; + +# if USE_SNPRINTF + size_t n = + xsum (length, + (count + insert + TCHARS_PER_DCHAR - 1) + / TCHARS_PER_DCHAR); + length += (count + TCHARS_PER_DCHAR - 1) / TCHARS_PER_DCHAR; + ENSURE_ALLOCATION (n); + length -= (count + TCHARS_PER_DCHAR - 1) / TCHARS_PER_DCHAR; + prec_ptr = (TCHAR_T *) (result + length); +# endif + + prec_end = prec_ptr + count; + prec_ptr += prefix_count; + + while (prec_end > prec_ptr) + { + prec_end--; + prec_end[insert] = prec_end[0]; + } + + prec_end += insert; + do + *--prec_end = '0'; + while (prec_end > prec_ptr); + + count += insert; + } + } +#endif + +#if !USE_SNPRINTF + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); +#endif + +#if !DCHAR_IS_TCHAR + /* Convert from TCHAR_T[] to DCHAR_T[]. */ + if (dp->conversion == 'c' || dp->conversion == 's') + { + /* type = TYPE_CHAR or TYPE_WIDE_CHAR or TYPE_STRING + TYPE_WIDE_STRING. + The result string is not certainly ASCII. */ + const TCHAR_T *tmpsrc; + DCHAR_T *tmpdst; + size_t tmpdst_len; + /* This code assumes that TCHAR_T is 'char'. */ + typedef int TCHAR_T_verify + [2 * (sizeof (TCHAR_T) == 1) - 1]; +# if USE_SNPRINTF + tmpsrc = (TCHAR_T *) (result + length); +# else + tmpsrc = tmp; +# endif + tmpdst = + DCHAR_CONV_FROM_ENCODING (locale_charset (), + iconveh_question_mark, + tmpsrc, count, + NULL, + NULL, &tmpdst_len); + if (tmpdst == NULL) + { + int saved_errno = errno; + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = saved_errno; + return NULL; + } + ENSURE_ALLOCATION (xsum (length, tmpdst_len)); + DCHAR_CPY (result + length, tmpdst, tmpdst_len); + free (tmpdst); + count = tmpdst_len; + } + else + { + /* The result string is ASCII. + Simple 1:1 conversion. */ +# if USE_SNPRINTF + /* If sizeof (DCHAR_T) == sizeof (TCHAR_T), it's a + no-op conversion, in-place on the array starting + at (result + length). */ + if (sizeof (DCHAR_T) != sizeof (TCHAR_T)) +# endif + { + const TCHAR_T *tmpsrc; + DCHAR_T *tmpdst; + size_t n; + +# if USE_SNPRINTF + if (result == resultbuf) + { + tmpsrc = (TCHAR_T *) (result + length); + /* ENSURE_ALLOCATION will not move tmpsrc + (because it's part of resultbuf). */ + ENSURE_ALLOCATION (xsum (length, count)); + } + else + { + /* ENSURE_ALLOCATION will move the array + (because it uses realloc(). */ + ENSURE_ALLOCATION (xsum (length, count)); + tmpsrc = (TCHAR_T *) (result + length); + } +# else + tmpsrc = tmp; + ENSURE_ALLOCATION (xsum (length, count)); +# endif + tmpdst = result + length; + /* Copy backwards, because of overlapping. */ + tmpsrc += count; + tmpdst += count; + for (n = count; n > 0; n--) + *--tmpdst = (unsigned char) *--tmpsrc; + } + } +#endif + +#if DCHAR_IS_TCHAR && !USE_SNPRINTF + /* Make room for the result. */ + if (count > allocated - length) + { + /* Need at least count elements. But allocate + proportionally. */ + size_t n = + xmax (xsum (length, count), xtimes (allocated, 2)); + + ENSURE_ALLOCATION (n); + } +#endif + + /* Here count <= allocated - length. */ + + /* Perform padding. */ +#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION + if (pad_ourselves && has_width) + { + size_t w; +# if ENABLE_UNISTDIO + /* Outside POSIX, it's preferrable to compare the width + against the number of _characters_ of the converted + value. */ + w = DCHAR_MBSNLEN (result + length, count); +# else + /* The width is compared against the number of _bytes_ + of the converted value, says POSIX. */ + w = count; +# endif + if (w < width) + { + size_t pad = width - w; + + /* Make room for the result. */ + if (xsum (count, pad) > allocated - length) + { + /* Need at least count + pad elements. But + allocate proportionally. */ + size_t n = + xmax (xsum3 (length, count, pad), + xtimes (allocated, 2)); + +# if USE_SNPRINTF + length += count; + ENSURE_ALLOCATION (n); + length -= count; +# else + ENSURE_ALLOCATION (n); +# endif + } + /* Here count + pad <= allocated - length. */ + + { +# if !DCHAR_IS_TCHAR || USE_SNPRINTF + DCHAR_T * const rp = result + length; +# else + DCHAR_T * const rp = tmp; +# endif + DCHAR_T *p = rp + count; + DCHAR_T *end = p + pad; + DCHAR_T *pad_ptr; +# if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO + if (dp->conversion == 'c' + || dp->conversion == 's') + /* No zero-padding for string directives. */ + pad_ptr = NULL; + else +# endif + { + pad_ptr = (*rp == '-' ? rp + 1 : rp); + /* No zero-padding of "inf" and "nan". */ + if ((*pad_ptr >= 'A' && *pad_ptr <= 'Z') + || (*pad_ptr >= 'a' && *pad_ptr <= 'z')) + pad_ptr = NULL; + } + /* The generated string now extends from rp to p, + with the zero padding insertion point being at + pad_ptr. */ + + count = count + pad; /* = end - rp */ + + if (flags & FLAG_LEFT) + { + /* Pad with spaces on the right. */ + for (; pad > 0; pad--) + *p++ = ' '; + } + else if ((flags & FLAG_ZERO) && pad_ptr != NULL) + { + /* Pad with zeroes. */ + DCHAR_T *q = end; + + while (p > pad_ptr) + *--q = *--p; + for (; pad > 0; pad--) + *p++ = '0'; + } + else + { + /* Pad with spaces on the left. */ + DCHAR_T *q = end; + + while (p > rp) + *--q = *--p; + for (; pad > 0; pad--) + *p++ = ' '; + } + } + } + } +#endif + + /* Here still count <= allocated - length. */ + +#if !DCHAR_IS_TCHAR || USE_SNPRINTF + /* The snprintf() result did fit. */ +#else + /* Append the sprintf() result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); +#endif +#if !USE_SNPRINTF + if (tmp != tmpbuf) + free (tmp); +#endif + +#if NEED_PRINTF_DIRECTIVE_F + if (dp->conversion == 'F') + { + /* Convert the %f result to upper case for %F. */ + DCHAR_T *rp = result + length; + size_t rc; + for (rc = count; rc > 0; rc--, rp++) + if (*rp >= 'a' && *rp <= 'z') + *rp = *rp - 'a' + 'A'; + } +#endif + + length += count; + break; + } + } + } + } + + /* Add the final NUL. */ + ENSURE_ALLOCATION (xsum (length, 1)); + result[length] = '\0'; + + if (result != resultbuf && length + 1 < allocated) + { + /* Shrink the allocated memory if possible. */ + DCHAR_T *memory; + + memory = (DCHAR_T *) realloc (result, (length + 1) * sizeof (DCHAR_T)); + if (memory != NULL) + result = memory; + } + + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + *lengthp = length; + /* Note that we can produce a big string of a length > INT_MAX. POSIX + says that snprintf() fails with errno = EOVERFLOW in this case, but + that's only because snprintf() returns an 'int'. This function does + not have this limitation. */ + return result; + +#if USE_SNPRINTF + overflow: + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + CLEANUP (); + errno = EOVERFLOW; + return NULL; +#endif + + out_of_memory: + if (!(result == resultbuf || result == NULL)) + free (result); + if (buf_malloced != NULL) + free (buf_malloced); + out_of_memory_1: + CLEANUP (); + errno = ENOMEM; + return NULL; + } +} + +#undef TCHARS_PER_DCHAR +#undef SNPRINTF +#undef USE_SNPRINTF +#undef DCHAR_CPY +#undef PRINTF_PARSE +#undef DIRECTIVES +#undef DIRECTIVE +#undef DCHAR_IS_TCHAR +#undef TCHAR_T +#undef DCHAR_T +#undef FCHAR_T +#undef VASNPRINTF diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h new file mode 100644 index 000000000..5ceab4475 --- /dev/null +++ b/lib/vasnprintf.h @@ -0,0 +1,81 @@ +/* vsprintf with automatic memory allocation. + Copyright (C) 2002-2004, 2007-2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _VASNPRINTF_H +#define _VASNPRINTF_H + +/* Get va_list. */ +#include + +/* Get size_t. */ +#include + +#ifndef __attribute__ +/* This feature is available in gcc versions 2.5 and later. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5) +# define __attribute__(Spec) /* empty */ +# endif +/* The __-protected variants of `format' and `printf' attributes + are accepted by gcc versions 2.6.4 (effectively 2.7) and later. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 7) +# define __format__ format +# define __printf__ printf +# endif +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/* Write formatted output to a string dynamically allocated with malloc(). + You can pass a preallocated buffer for the result in RESULTBUF and its + size in *LENGTHP; otherwise you pass RESULTBUF = NULL. + If successful, return the address of the string (this may be = RESULTBUF + if no dynamic memory allocation was necessary) and set *LENGTHP to the + number of resulting bytes, excluding the trailing NUL. Upon error, set + errno and return NULL. + + When dynamic memory allocation occurs, the preallocated buffer is left + alone (with possibly modified contents). This makes it possible to use + a statically allocated or stack-allocated buffer, like this: + + char buf[100]; + size_t len = sizeof (buf); + char *output = vasnprintf (buf, &len, format, args); + if (output == NULL) + ... error handling ...; + else + { + ... use the output string ...; + if (output != buf) + free (output); + } + */ +#if REPLACE_VASNPRINTF +# define asnprintf rpl_asnprintf +# define vasnprintf rpl_vasnprintf +#endif +extern char * asnprintf (char *resultbuf, size_t *lengthp, const char *format, ...) + __attribute__ ((__format__ (__printf__, 3, 4))); +extern char * vasnprintf (char *resultbuf, size_t *lengthp, const char *format, va_list args) + __attribute__ ((__format__ (__printf__, 3, 0))); + +#ifdef __cplusplus +} +#endif + +#endif /* _VASNPRINTF_H */ diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c new file mode 100644 index 000000000..1fdfb6bc8 --- /dev/null +++ b/lib/vsnprintf.c @@ -0,0 +1,71 @@ +/* Formatted output to strings. + Copyright (C) 2004, 2006-2008 Free Software Foundation, Inc. + Written by Simon Josefsson and Yoann Vandoorselaere . + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +/* Specification. */ +#include + +#include +#include +#include +#include +#include + +#include "vasnprintf.h" + +/* Print formatted output to string STR. Similar to vsprintf, but + additional length SIZE limit how much is written into STR. Returns + string length of formatted string (which may be larger than SIZE). + STR may be NULL, in which case nothing will be written. On error, + return a negative value. */ +int +vsnprintf (char *str, size_t size, const char *format, va_list args) +{ + char *output; + size_t len; + size_t lenbuf = size; + + output = vasnprintf (str, &lenbuf, format, args); + len = lenbuf; + + if (!output) + return -1; + + if (output != str) + { + if (size) + { + size_t pruned_len = (len < size ? len : size - 1); + memcpy (str, output, pruned_len); + str[pruned_len] = '\0'; + } + + free (output); + } + + if (len > INT_MAX) + { + errno = EOVERFLOW; + return -1; + } + + return len; +} diff --git a/lib/xsize.h b/lib/xsize.h new file mode 100644 index 000000000..0b30045e8 --- /dev/null +++ b/lib/xsize.h @@ -0,0 +1,108 @@ +/* xsize.h -- Checked size_t computations. + + Copyright (C) 2003, 2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _XSIZE_H +#define _XSIZE_H + +/* Get size_t. */ +#include + +/* Get SIZE_MAX. */ +#include +#if HAVE_STDINT_H +# include +#endif + +/* The size of memory objects is often computed through expressions of + type size_t. Example: + void* p = malloc (header_size + n * element_size). + These computations can lead to overflow. When this happens, malloc() + returns a piece of memory that is way too small, and the program then + crashes while attempting to fill the memory. + To avoid this, the functions and macros in this file check for overflow. + The convention is that SIZE_MAX represents overflow. + malloc (SIZE_MAX) is not guaranteed to fail -- think of a malloc + implementation that uses mmap --, it's recommended to use size_overflow_p() + or size_in_bounds_p() before invoking malloc(). + The example thus becomes: + size_t size = xsum (header_size, xtimes (n, element_size)); + void *p = (size_in_bounds_p (size) ? malloc (size) : NULL); +*/ + +/* Convert an arbitrary value >= 0 to type size_t. */ +#define xcast_size_t(N) \ + ((N) <= SIZE_MAX ? (size_t) (N) : SIZE_MAX) + +/* Sum of two sizes, with overflow check. */ +static inline size_t +#if __GNUC__ >= 3 +__attribute__ ((__pure__)) +#endif +xsum (size_t size1, size_t size2) +{ + size_t sum = size1 + size2; + return (sum >= size1 ? sum : SIZE_MAX); +} + +/* Sum of three sizes, with overflow check. */ +static inline size_t +#if __GNUC__ >= 3 +__attribute__ ((__pure__)) +#endif +xsum3 (size_t size1, size_t size2, size_t size3) +{ + return xsum (xsum (size1, size2), size3); +} + +/* Sum of four sizes, with overflow check. */ +static inline size_t +#if __GNUC__ >= 3 +__attribute__ ((__pure__)) +#endif +xsum4 (size_t size1, size_t size2, size_t size3, size_t size4) +{ + return xsum (xsum (xsum (size1, size2), size3), size4); +} + +/* Maximum of two sizes, with overflow check. */ +static inline size_t +#if __GNUC__ >= 3 +__attribute__ ((__pure__)) +#endif +xmax (size_t size1, size_t size2) +{ + /* No explicit check is needed here, because for any n: + max (SIZE_MAX, n) == SIZE_MAX and max (n, SIZE_MAX) == SIZE_MAX. */ + return (size1 >= size2 ? size1 : size2); +} + +/* Multiplication of a count with an element size, with overflow check. + The count must be >= 0 and the element size must be > 0. + This is a macro, not an inline function, so that it works correctly even + when N is of a wider type and N > SIZE_MAX. */ +#define xtimes(N, ELSIZE) \ + ((N) <= SIZE_MAX / (ELSIZE) ? (size_t) (N) * (ELSIZE) : SIZE_MAX) + +/* Check for overflow. */ +#define size_overflow_p(SIZE) \ + ((SIZE) == SIZE_MAX) +/* Check against overflow. */ +#define size_in_bounds_p(SIZE) \ + ((SIZE) != SIZE_MAX) + +#endif /* _XSIZE_H */ diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 new file mode 100644 index 000000000..4ce1ccbd9 --- /dev/null +++ b/m4/errno_h.m4 @@ -0,0 +1,115 @@ +# errno_h.m4 serial 6 +dnl Copyright (C) 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN_ONCE([gl_HEADER_ERRNO_H], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_CACHE_CHECK([for complete errno.h], [gl_cv_header_errno_h_complete], [ + AC_EGREP_CPP([booboo],[ +#include +#if !defined ENOMSG +booboo +#endif +#if !defined EIDRM +booboo +#endif +#if !defined ENOLINK +booboo +#endif +#if !defined EPROTO +booboo +#endif +#if !defined EMULTIHOP +booboo +#endif +#if !defined EBADMSG +booboo +#endif +#if !defined EOVERFLOW +booboo +#endif +#if !defined ENOTSUP +booboo +#endif +#if !defined ESTALE +booboo +#endif +#if !defined ECANCELED +booboo +#endif + ], + [gl_cv_header_errno_h_complete=no], + [gl_cv_header_errno_h_complete=yes]) + ]) + if test $gl_cv_header_errno_h_complete = yes; then + ERRNO_H='' + else + gl_CHECK_NEXT_HEADERS([errno.h]) + ERRNO_H='errno.h' + fi + AC_SUBST([ERRNO_H]) + gl_REPLACE_ERRNO_VALUE([EMULTIHOP]) + gl_REPLACE_ERRNO_VALUE([ENOLINK]) + gl_REPLACE_ERRNO_VALUE([EOVERFLOW]) +]) + +# Assuming $1 = EOVERFLOW. +# The EOVERFLOW errno value ought to be defined in , according to +# POSIX. But some systems (like OpenBSD 4.0 or AIX 3) don't define it, and +# some systems (like OSF/1) define it when _XOPEN_SOURCE_EXTENDED is defined. +# Check for the value of EOVERFLOW. +# Set the variables EOVERFLOW_HIDDEN and EOVERFLOW_VALUE. +AC_DEFUN([gl_REPLACE_ERRNO_VALUE], +[ + if test -n "$ERRNO_H"; then + AC_CACHE_CHECK([for ]$1[ value], [gl_cv_header_errno_h_]$1, [ + AC_EGREP_CPP([yes],[ +#include +#ifdef ]$1[ +yes +#endif + ], + [gl_cv_header_errno_h_]$1[=yes], + [gl_cv_header_errno_h_]$1[=no]) + if test $gl_cv_header_errno_h_]$1[ = no; then + AC_EGREP_CPP([yes],[ +#define _XOPEN_SOURCE_EXTENDED 1 +#include +#ifdef ]$1[ +yes +#endif + ], [gl_cv_header_errno_h_]$1[=hidden]) + if test $gl_cv_header_errno_h_]$1[ = hidden; then + dnl The macro exists but is hidden. + dnl Define it to the same value. + AC_COMPUTE_INT([gl_cv_header_errno_h_]$1, $1, [ +#define _XOPEN_SOURCE_EXTENDED 1 +#include +/* The following two lines are a workaround against an autoconf-2.52 bug. */ +#include +#include +]) + fi + fi + ]) + case $gl_cv_header_errno_h_]$1[ in + yes | no) + ]$1[_HIDDEN=0; ]$1[_VALUE= + ;; + *) + ]$1[_HIDDEN=1; ]$1[_VALUE="$gl_cv_header_errno_h_]$1[" + ;; + esac + AC_SUBST($1[_HIDDEN]) + AC_SUBST($1[_VALUE]) + fi +]) + +dnl Autoconf >= 2.61 has AC_COMPUTE_INT built-in. +dnl Remove this when we can assume autoconf >= 2.61. +m4_ifdef([AC_COMPUTE_INT], [], [ + AC_DEFUN([AC_COMPUTE_INT], [_AC_COMPUTE_INT([$2],[$1],[$3],[$4])]) +]) diff --git a/m4/float_h.m4 b/m4/float_h.m4 new file mode 100644 index 000000000..d36e3a46c --- /dev/null +++ b/m4/float_h.m4 @@ -0,0 +1,19 @@ +# float_h.m4 serial 3 +dnl Copyright (C) 2007 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FLOAT_H], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) + FLOAT_H= + case "$host_os" in + beos* | openbsd*) + FLOAT_H=float.h + gl_CHECK_NEXT_HEADERS([float.h]) + ;; + esac + AC_SUBST([FLOAT_H]) +]) diff --git a/m4/getpagesize.m4 b/m4/getpagesize.m4 new file mode 100644 index 000000000..0d07a3a53 --- /dev/null +++ b/m4/getpagesize.m4 @@ -0,0 +1,29 @@ +# getpagesize.m4 serial 7 +dnl Copyright (C) 2002, 2004-2005, 2007 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_GETPAGESIZE], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) + AC_CHECK_FUNCS([getpagesize]) + if test $ac_cv_func_getpagesize = no; then + HAVE_GETPAGESIZE=0 + AC_CHECK_HEADERS([OS.h]) + if test $ac_cv_header_OS_h = yes; then + HAVE_OS_H=1 + fi + AC_CHECK_HEADERS([sys/param.h]) + if test $ac_cv_header_sys_param_h = yes; then + HAVE_SYS_PARAM_H=1 + fi + fi + case "$host_os" in + mingw*) + REPLACE_GETPAGESIZE=1 + AC_LIBOBJ([getpagesize]) + ;; + esac +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index e70283f41..aad4999e1 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string vsnprintf # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -41,6 +41,7 @@ gl_MODULES([ strftime striconveh string + vsnprintf ]) gl_AVOID([]) gl_SOURCE_BASE([lib]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index ef0534ef8..0c2b968ef 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -51,8 +51,12 @@ AC_DEFUN([gl_INIT], gl_COUNT_ONE_BITS gl_ENVIRON gl_UNISTD_MODULE_INDICATOR([environ]) + gl_HEADER_ERRNO_H + gl_FLOAT_H gl_FUNC_FLOCK gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) + gl_FUNC_GETPAGESIZE + gl_UNISTD_MODULE_INDICATOR([getpagesize]) AM_ICONV gl_ICONV_H gl_FUNC_ICONV_OPEN @@ -72,6 +76,8 @@ AC_DEFUN([gl_INIT], gl_WCHAR_MODULE_INDICATOR([mbrtowc]) gl_FUNC_MBSINIT gl_WCHAR_MODULE_INDICATOR([mbsinit]) + gl_FUNC_MEMCHR + gl_STRING_MODULE_INDICATOR([memchr]) gl_MULTIARCH gl_PATHMAX gl_FUNC_PUTENV @@ -80,9 +86,11 @@ AC_DEFUN([gl_INIT], gl_UNISTD_MODULE_INDICATOR([readlink]) gl_SAFE_READ gl_SAFE_WRITE + gl_SIZE_MAX gt_TYPE_SSIZE_T AM_STDBOOL_H gl_STDINT_H + gl_STDIO_H gl_STDLIB_H gl_STRCASE gl_FUNC_GNU_STRFTIME @@ -101,9 +109,13 @@ AC_DEFUN([gl_INIT], gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) gl_MODULE_INDICATOR([unistr/u8-mbtoucr]) gl_MODULE_INDICATOR([unistr/u8-uctomb]) + gl_FUNC_VASNPRINTF + gl_FUNC_VSNPRINTF + gl_STDIO_MODULE_INDICATOR([vsnprintf]) gl_WCHAR_H gl_FUNC_WRITE gl_UNISTD_MODULE_INDICATOR([write]) + gl_XSIZE m4_ifval(gl_LIBSOURCES_LIST, [ m4_syscmd([test ! -d ]m4_defn([gl_LIBSOURCES_DIR])[ || for gl_file in ]gl_LIBSOURCES_LIST[ ; do @@ -235,6 +247,7 @@ AC_DEFUN([gl_FILE_LIST], [ build-aux/config.rpath build-aux/link-warning.h lib/alloca.in.h + lib/asnprintf.c lib/byteswap.in.h lib/c-ctype.c lib/c-ctype.h @@ -246,11 +259,15 @@ AC_DEFUN([gl_FILE_LIST], [ lib/canonicalize.h lib/config.charset lib/count-one-bits.h + lib/errno.in.h + lib/float+.h + lib/float.in.h lib/flock.c lib/full-read.c lib/full-read.h lib/full-write.c lib/full-write.h + lib/getpagesize.c lib/iconv.c lib/iconv.in.h lib/iconv_close.c @@ -269,7 +286,13 @@ AC_DEFUN([gl_FILE_LIST], [ lib/mbrlen.c lib/mbrtowc.c lib/mbsinit.c + lib/memchr.c + lib/memchr.valgrind lib/pathmax.h + lib/printf-args.c + lib/printf-args.h + lib/printf-parse.c + lib/printf-parse.h lib/putenv.c lib/readlink.c lib/ref-add.sin @@ -278,8 +301,11 @@ AC_DEFUN([gl_FILE_LIST], [ lib/safe-read.h lib/safe-write.c lib/safe-write.h + lib/size_max.h lib/stdbool.in.h lib/stdint.in.h + lib/stdio-write.c + lib/stdio.in.h lib/stdlib.in.h lib/strcasecmp.c lib/streq.h @@ -304,9 +330,13 @@ AC_DEFUN([gl_FILE_LIST], [ lib/unistr/u8-uctomb-aux.c lib/unistr/u8-uctomb.c lib/unitypes.h + lib/vasnprintf.c + lib/vasnprintf.h lib/verify.h + lib/vsnprintf.c lib/wchar.in.h lib/write.c + lib/xsize.h m4/00gnulib.m4 m4/alloca.m4 m4/autobuild.m4 @@ -316,9 +346,12 @@ AC_DEFUN([gl_FILE_LIST], [ m4/count-one-bits.m4 m4/eealloc.m4 m4/environ.m4 + m4/errno_h.m4 m4/extensions.m4 + m4/float_h.m4 m4/flock.m4 m4/fpieee.m4 + m4/getpagesize.m4 m4/glibc21.m4 m4/gnulib-common.m4 m4/iconv.m4 @@ -326,6 +359,8 @@ AC_DEFUN([gl_FILE_LIST], [ m4/iconv_open.m4 m4/include_next.m4 m4/inline.m4 + m4/intmax_t.m4 + m4/inttypes_h.m4 m4/lib-ld.m4 m4/lib-link.m4 m4/lib-prefix.m4 @@ -341,15 +376,21 @@ AC_DEFUN([gl_FILE_LIST], [ m4/mbrtowc.m4 m4/mbsinit.m4 m4/mbstate_t.m4 + m4/memchr.m4 + m4/mmap-anon.m4 m4/multiarch.m4 m4/pathmax.m4 + m4/printf.m4 m4/putenv.m4 m4/readlink.m4 m4/safe-read.m4 m4/safe-write.m4 + m4/size_max.m4 m4/ssize_t.m4 m4/stdbool.m4 m4/stdint.m4 + m4/stdint_h.m4 + m4/stdio_h.m4 m4/stdlib_h.m4 m4/strcase.m4 m4/strftime.m4 @@ -360,8 +401,12 @@ AC_DEFUN([gl_FILE_LIST], [ m4/time_r.m4 m4/tm_gmtoff.m4 m4/unistd_h.m4 + m4/vasnprintf.m4 m4/visibility.m4 + m4/vsnprintf.m4 m4/wchar.m4 + m4/wchar_t.m4 m4/wint_t.m4 m4/write.m4 + m4/xsize.m4 ]) diff --git a/m4/intmax_t.m4 b/m4/intmax_t.m4 new file mode 100644 index 000000000..264cb5718 --- /dev/null +++ b/m4/intmax_t.m4 @@ -0,0 +1,61 @@ +# intmax_t.m4 serial 7 +dnl Copyright (C) 1997-2004, 2006-2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Paul Eggert. + +AC_PREREQ([2.13]) + +# Define intmax_t to 'long' or 'long long' +# if it is not already defined in or . + +AC_DEFUN([gl_AC_TYPE_INTMAX_T], +[ + dnl For simplicity, we assume that a header file defines 'intmax_t' if and + dnl only if it defines 'uintmax_t'. + AC_REQUIRE([gl_AC_HEADER_INTTYPES_H]) + AC_REQUIRE([gl_AC_HEADER_STDINT_H]) + if test $gl_cv_header_inttypes_h = no && test $gl_cv_header_stdint_h = no; then + AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) + test $ac_cv_type_long_long_int = yes \ + && ac_type='long long' \ + || ac_type='long' + AC_DEFINE_UNQUOTED([intmax_t], [$ac_type], + [Define to long or long long if and don't define.]) + else + AC_DEFINE([HAVE_INTMAX_T], [1], + [Define if you have the 'intmax_t' type in or .]) + fi +]) + +dnl An alternative would be to explicitly test for 'intmax_t'. + +AC_DEFUN([gt_AC_TYPE_INTMAX_T], +[ + AC_REQUIRE([gl_AC_HEADER_INTTYPES_H]) + AC_REQUIRE([gl_AC_HEADER_STDINT_H]) + AC_CACHE_CHECK([for intmax_t], [gt_cv_c_intmax_t], + [AC_TRY_COMPILE([ +#include +#include +#if HAVE_STDINT_H_WITH_UINTMAX +#include +#endif +#if HAVE_INTTYPES_H_WITH_UINTMAX +#include +#endif +], [intmax_t x = -1; return !x;], gt_cv_c_intmax_t=yes, gt_cv_c_intmax_t=no)]) + if test $gt_cv_c_intmax_t = yes; then + AC_DEFINE([HAVE_INTMAX_T], [1], + [Define if you have the 'intmax_t' type in or .]) + else + AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) + test $ac_cv_type_long_long_int = yes \ + && ac_type='long long' \ + || ac_type='long' + AC_DEFINE_UNQUOTED([intmax_t], [$ac_type], + [Define to long or long long if and don't define.]) + fi +]) diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4 new file mode 100644 index 000000000..f4ca16021 --- /dev/null +++ b/m4/inttypes_h.m4 @@ -0,0 +1,26 @@ +# inttypes_h.m4 serial 9 +dnl Copyright (C) 1997-2004, 2006, 2008, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Paul Eggert. + +# Define HAVE_INTTYPES_H_WITH_UINTMAX if exists, +# doesn't clash with , and declares uintmax_t. + +AC_DEFUN([gl_AC_HEADER_INTTYPES_H], +[ + AC_CACHE_CHECK([for inttypes.h], [gl_cv_header_inttypes_h], + [AC_TRY_COMPILE( + [#include +#include ], + [uintmax_t i = (uintmax_t) -1; return !i;], + [gl_cv_header_inttypes_h=yes], + [gl_cv_header_inttypes_h=no])]) + if test $gl_cv_header_inttypes_h = yes; then + AC_DEFINE_UNQUOTED([HAVE_INTTYPES_H_WITH_UINTMAX], [1], + [Define if exists, doesn't clash with , + and declares uintmax_t. ]) + fi +]) diff --git a/m4/lib-link.m4 b/m4/lib-link.m4 index 21442033c..2f8b7ff38 100644 --- a/m4/lib-link.m4 +++ b/m4/lib-link.m4 @@ -1,4 +1,4 @@ -# lib-link.m4 serial 19 (gettext-0.18) +# lib-link.m4 serial 20 (gettext-0.18) dnl Copyright (C) 2001-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -82,7 +82,7 @@ AC_DEFUN([AC_LIB_HAVE_LINKFLAGS], ]) if test "$ac_cv_lib[]Name" = yes; then HAVE_LIB[]NAME=yes - AC_DEFINE([HAVE_LIB]NAME, 1, [Define if you have the lib[]$1 library.]) + AC_DEFINE([HAVE_LIB]NAME, 1, [Define if you have the lib][$1 library.]) AC_MSG_CHECKING([how to link with lib[]$1]) AC_MSG_RESULT([$LIB[]NAME]) else @@ -210,6 +210,9 @@ AC_DEFUN([AC_LIB_LINKFLAGS_BODY], LTLIB[]NAME= INC[]NAME= LIB[]NAME[]_PREFIX= + dnl HAVE_LIB${NAME} is an indicator that LIB${NAME}, LTLIB${NAME} have been + dnl computed. So it has to be reset here. + HAVE_LIB[]NAME= rpathdirs= ltrpathdirs= names_already_handled= diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4 index 11d7d23e7..2fddcc8a1 100644 --- a/m4/mbrtowc.m4 +++ b/m4/mbrtowc.m4 @@ -1,4 +1,4 @@ -# mbrtowc.m4 serial 15 +# mbrtowc.m4 serial 16 dnl Copyright (C) 2001-2002, 2004-2005, 2008, 2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -156,6 +156,7 @@ changequote([,])dnl if test $LOCALE_ZH_CN != none; then AC_TRY_RUN([ #include +#include #include #include int main () diff --git a/m4/memchr.m4 b/m4/memchr.m4 new file mode 100644 index 000000000..1194bac2e --- /dev/null +++ b/m4/memchr.m4 @@ -0,0 +1,86 @@ +# memchr.m4 serial 7 +dnl Copyright (C) 2002, 2003, 2004, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN_ONCE([gl_FUNC_MEMCHR], +[ + dnl Check for prerequisites for memory fence checks. + gl_FUNC_MMAP_ANON + AC_CHECK_HEADERS_ONCE([sys/mman.h]) + AC_CHECK_FUNCS_ONCE([mprotect]) + + dnl These days, we assume memchr is present. But just in case... + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + AC_REPLACE_FUNCS([memchr]) + if test $ac_cv_func_memchr = no; then + gl_PREREQ_MEMCHR + REPLACE_MEMCHR=1 + fi + + if test $ac_cv_func_memchr = yes; then + # Detect platform-specific bugs in some versions of glibc: + # memchr should not dereference anything with length 0 + # http://bugzilla.redhat.com/499689 + # memchr should not dereference overestimated length after a match + # http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=521737 + # http://sourceware.org/bugzilla/show_bug.cgi?id=10162 + # Assume that memchr works on platforms that lack mprotect. + AC_CACHE_CHECK([whether memchr works], [gl_cv_func_memchr_works], + [AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +#include +#if HAVE_SYS_MMAN_H +# include +# include +# include +# include +# ifndef MAP_FILE +# define MAP_FILE 0 +# endif +#endif +]], [[ + char *fence = NULL; +#if HAVE_SYS_MMAN_H && HAVE_MPROTECT +# if HAVE_MAP_ANONYMOUS + const int flags = MAP_ANONYMOUS | MAP_PRIVATE; + const int fd = -1; +# else /* !HAVE_MAP_ANONYMOUS */ + const int flags = MAP_FILE | MAP_PRIVATE; + int fd = open ("/dev/zero", O_RDONLY, 0666); + if (fd >= 0) +# endif + { + int pagesize = getpagesize (); + char *two_pages = + (char *) mmap (NULL, 2 * pagesize, PROT_READ | PROT_WRITE, + flags, fd, 0); + if (two_pages != (char *)(-1) + && mprotect (two_pages + pagesize, pagesize, PROT_NONE) == 0) + fence = two_pages + pagesize; + } +#endif + if (fence) + { + if (memchr (fence, 0, 0)) + return 1; + strcpy (fence - 9, "12345678"); + if (memchr (fence - 9, 0, 79) != fence - 1) + return 2; + } + return 0; +]])], [gl_cv_func_memchr_works=yes], [gl_cv_func_memchr_works=no], + [dnl Be pessimistic for now. + gl_cv_func_memchr_works="guessing no"])]) + if test "$gl_cv_func_memchr_works" != yes; then + gl_PREREQ_MEMCHR + REPLACE_MEMCHR=1 + AC_LIBOBJ([memchr]) + fi + fi +]) + +# Prerequisites of lib/memchr.c. +AC_DEFUN([gl_PREREQ_MEMCHR], [ + AC_CHECK_HEADERS([bp-sym.h]) +]) diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4 new file mode 100644 index 000000000..14b6270d2 --- /dev/null +++ b/m4/mmap-anon.m4 @@ -0,0 +1,59 @@ +# mmap-anon.m4 serial 8 +dnl Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +# Detect how mmap can be used to create anonymous (not file-backed) memory +# mappings. +# - On Linux, AIX, OSF/1, Solaris, Cygwin, Interix, Haiku, both MAP_ANONYMOUS +# and MAP_ANON exist and have the same value. +# - On HP-UX, only MAP_ANONYMOUS exists. +# - On MacOS X, FreeBSD, NetBSD, OpenBSD, only MAP_ANON exists. +# - On IRIX, neither exists, and a file descriptor opened to /dev/zero must be +# used. + +AC_DEFUN([gl_FUNC_MMAP_ANON], +[ + dnl Work around a bug of AC_EGREP_CPP in autoconf-2.57. + AC_REQUIRE([AC_PROG_CPP]) + AC_REQUIRE([AC_PROG_EGREP]) + + dnl Persuade glibc to define MAP_ANONYMOUS. + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + + # Check for mmap(). Don't use AC_FUNC_MMAP, because it checks too much: it + # fails on HP-UX 11, because MAP_FIXED mappings do not work. But this is + # irrelevant for anonymous mappings. + AC_CHECK_FUNC([mmap], [gl_have_mmap=yes], [gl_have_mmap=no]) + + # Try to allow MAP_ANONYMOUS. + gl_have_mmap_anonymous=no + if test $gl_have_mmap = yes; then + AC_MSG_CHECKING([for MAP_ANONYMOUS]) + AC_EGREP_CPP([I cant identify this map.], [ +#include +#ifdef MAP_ANONYMOUS + I cant identify this map. +#endif +], + [gl_have_mmap_anonymous=yes]) + if test $gl_have_mmap_anonymous != yes; then + AC_EGREP_CPP([I cant identify this map.], [ +#include +#ifdef MAP_ANON + I cant identify this map. +#endif +], + [AC_DEFINE([MAP_ANONYMOUS], [MAP_ANON], + [Define to a substitute value for mmap()'s MAP_ANONYMOUS flag.]) + gl_have_mmap_anonymous=yes]) + fi + AC_MSG_RESULT([$gl_have_mmap_anonymous]) + if test $gl_have_mmap_anonymous = yes; then + AC_DEFINE([HAVE_MAP_ANONYMOUS], [1], + [Define to 1 if mmap()'s MAP_ANONYMOUS flag is available after including + config.h and .]) + fi + fi +]) diff --git a/m4/printf.m4 b/m4/printf.m4 new file mode 100644 index 000000000..87aa45c5e --- /dev/null +++ b/m4/printf.m4 @@ -0,0 +1,1416 @@ +# printf.m4 serial 33 +dnl Copyright (C) 2003, 2007-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl Test whether the *printf family of functions supports the 'j', 'z', 't', +dnl 'L' size specifiers. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_printf_sizes_c99. + +AC_DEFUN([gl_PRINTF_SIZES_C99], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([gl_AC_HEADER_STDINT_H]) + AC_REQUIRE([gl_AC_HEADER_INTTYPES_H]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports size specifiers as in C99], + [gl_cv_func_printf_sizes_c99], + [ + AC_TRY_RUN([ +#include +#include +#include +#include +#if HAVE_STDINT_H_WITH_UINTMAX +# include +#endif +#if HAVE_INTTYPES_H_WITH_UINTMAX +# include +#endif +static char buf[100]; +int main () +{ +#if HAVE_STDINT_H_WITH_UINTMAX || HAVE_INTTYPES_H_WITH_UINTMAX + buf[0] = '\0'; + if (sprintf (buf, "%ju %d", (uintmax_t) 12345671, 33, 44, 55) < 0 + || strcmp (buf, "12345671 33") != 0) + return 1; +#endif + buf[0] = '\0'; + if (sprintf (buf, "%zu %d", (size_t) 12345672, 33, 44, 55) < 0 + || strcmp (buf, "12345672 33") != 0) + return 1; + buf[0] = '\0'; + if (sprintf (buf, "%tu %d", (ptrdiff_t) 12345673, 33, 44, 55) < 0 + || strcmp (buf, "12345673 33") != 0) + return 1; + buf[0] = '\0'; + if (sprintf (buf, "%Lg %d", (long double) 1.5, 33, 44, 55) < 0 + || strcmp (buf, "1.5 33") != 0) + return 1; + return 0; +}], [gl_cv_func_printf_sizes_c99=yes], [gl_cv_func_printf_sizes_c99=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_printf_sizes_c99="guessing yes";; + # Guess yes on FreeBSD >= 5. + freebsd[1-4]*) gl_cv_func_printf_sizes_c99="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_printf_sizes_c99="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_printf_sizes_c99="guessing no";; + darwin*) gl_cv_func_printf_sizes_c99="guessing yes";; + # Guess yes on OpenBSD >= 3.9. + openbsd[1-2].* | openbsd3.[0-8] | openbsd3.[0-8].*) + gl_cv_func_printf_sizes_c99="guessing no";; + openbsd*) gl_cv_func_printf_sizes_c99="guessing yes";; + # Guess yes on Solaris >= 2.10. + solaris2.[0-9]*) gl_cv_func_printf_sizes_c99="guessing no";; + solaris*) gl_cv_func_printf_sizes_c99="guessing yes";; + # Guess yes on NetBSD >= 3. + netbsd[1-2]* | netbsdelf[1-2]* | netbsdaout[1-2]* | netbsdcoff[1-2]*) + gl_cv_func_printf_sizes_c99="guessing no";; + netbsd*) gl_cv_func_printf_sizes_c99="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_printf_sizes_c99="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports 'long double' +dnl arguments together with the 'L' size specifier. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_printf_long_double. + +AC_DEFUN([gl_PRINTF_LONG_DOUBLE], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports 'long double' arguments], + [gl_cv_func_printf_long_double], + [ + AC_TRY_RUN([ +#include +#include +static char buf[10000]; +int main () +{ + buf[0] = '\0'; + if (sprintf (buf, "%Lf %d", 1.75L, 33, 44, 55) < 0 + || strcmp (buf, "1.750000 33") != 0) + return 1; + buf[0] = '\0'; + if (sprintf (buf, "%Le %d", 1.75L, 33, 44, 55) < 0 + || strcmp (buf, "1.750000e+00 33") != 0) + return 1; + buf[0] = '\0'; + if (sprintf (buf, "%Lg %d", 1.75L, 33, 44, 55) < 0 + || strcmp (buf, "1.75 33") != 0) + return 1; + return 0; +}], [gl_cv_func_printf_long_double=yes], [gl_cv_func_printf_long_double=no], + [ +changequote(,)dnl + case "$host_os" in + beos*) gl_cv_func_printf_long_double="guessing no";; + mingw* | pw*) gl_cv_func_printf_long_double="guessing no";; + *) gl_cv_func_printf_long_double="guessing yes";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports infinite and NaN +dnl 'double' arguments and negative zero arguments in the %f, %e, %g +dnl directives. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_printf_infinite. + +AC_DEFUN([gl_PRINTF_INFINITE], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports infinite 'double' arguments], + [gl_cv_func_printf_infinite], + [ + AC_TRY_RUN([ +#include +#include +static int +strisnan (const char *string, size_t start_index, size_t end_index) +{ + if (start_index < end_index) + { + if (string[start_index] == '-') + start_index++; + if (start_index + 3 <= end_index + && memcmp (string + start_index, "nan", 3) == 0) + { + start_index += 3; + if (start_index == end_index + || (string[start_index] == '(' && string[end_index - 1] == ')')) + return 1; + } + } + return 0; +} +static int +have_minus_zero () +{ + static double plus_zero = 0.0; + double minus_zero = - plus_zero; + return memcmp (&plus_zero, &minus_zero, sizeof (double)) != 0; +} +static char buf[10000]; +static double zero = 0.0; +int main () +{ + if (sprintf (buf, "%f", 1.0 / 0.0) < 0 + || (strcmp (buf, "inf") != 0 && strcmp (buf, "infinity") != 0)) + return 1; + if (sprintf (buf, "%f", -1.0 / 0.0) < 0 + || (strcmp (buf, "-inf") != 0 && strcmp (buf, "-infinity") != 0)) + return 1; + if (sprintf (buf, "%f", zero / zero) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%e", 1.0 / 0.0) < 0 + || (strcmp (buf, "inf") != 0 && strcmp (buf, "infinity") != 0)) + return 1; + if (sprintf (buf, "%e", -1.0 / 0.0) < 0 + || (strcmp (buf, "-inf") != 0 && strcmp (buf, "-infinity") != 0)) + return 1; + if (sprintf (buf, "%e", zero / zero) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%g", 1.0 / 0.0) < 0 + || (strcmp (buf, "inf") != 0 && strcmp (buf, "infinity") != 0)) + return 1; + if (sprintf (buf, "%g", -1.0 / 0.0) < 0 + || (strcmp (buf, "-inf") != 0 && strcmp (buf, "-infinity") != 0)) + return 1; + if (sprintf (buf, "%g", zero / zero) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + /* This test fails on HP-UX 10.20. */ + if (have_minus_zero ()) + if (sprintf (buf, "%g", - zero) < 0 + || strcmp (buf, "-0") != 0) + return 1; + return 0; +}], [gl_cv_func_printf_infinite=yes], [gl_cv_func_printf_infinite=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_printf_infinite="guessing yes";; + # Guess yes on FreeBSD >= 6. + freebsd[1-5]*) gl_cv_func_printf_infinite="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_printf_infinite="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_printf_infinite="guessing no";; + darwin*) gl_cv_func_printf_infinite="guessing yes";; + # Guess yes on HP-UX >= 11. + hpux[7-9]* | hpux10*) gl_cv_func_printf_infinite="guessing no";; + hpux*) gl_cv_func_printf_infinite="guessing yes";; + # Guess yes on NetBSD >= 3. + netbsd[1-2]* | netbsdelf[1-2]* | netbsdaout[1-2]* | netbsdcoff[1-2]*) + gl_cv_func_printf_infinite="guessing no";; + netbsd*) gl_cv_func_printf_infinite="guessing yes";; + # Guess yes on BeOS. + beos*) gl_cv_func_printf_infinite="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_printf_infinite="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports infinite and NaN +dnl 'long double' arguments in the %f, %e, %g directives. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_printf_infinite_long_double. + +AC_DEFUN([gl_PRINTF_INFINITE_LONG_DOUBLE], +[ + AC_REQUIRE([gl_PRINTF_LONG_DOUBLE]) + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([gl_BIGENDIAN]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + dnl The user can set or unset the variable gl_printf_safe to indicate + dnl that he wishes a safe handling of non-IEEE-754 'long double' values. + if test -n "$gl_printf_safe"; then + AC_DEFINE([CHECK_PRINTF_SAFE], [1], + [Define if you wish *printf() functions that have a safe handling of + non-IEEE-754 'long double' values.]) + fi + case "$gl_cv_func_printf_long_double" in + *yes) + AC_CACHE_CHECK([whether printf supports infinite 'long double' arguments], + [gl_cv_func_printf_infinite_long_double], + [ + AC_TRY_RUN([ +]GL_NOCRASH[ +#include +#include +#include +static int +strisnan (const char *string, size_t start_index, size_t end_index) +{ + if (start_index < end_index) + { + if (string[start_index] == '-') + start_index++; + if (start_index + 3 <= end_index + && memcmp (string + start_index, "nan", 3) == 0) + { + start_index += 3; + if (start_index == end_index + || (string[start_index] == '(' && string[end_index - 1] == ')')) + return 1; + } + } + return 0; +} +static char buf[10000]; +static long double zeroL = 0.0L; +int main () +{ + nocrash_init(); + if (sprintf (buf, "%Lf", 1.0L / 0.0L) < 0 + || (strcmp (buf, "inf") != 0 && strcmp (buf, "infinity") != 0)) + return 1; + if (sprintf (buf, "%Lf", -1.0L / 0.0L) < 0 + || (strcmp (buf, "-inf") != 0 && strcmp (buf, "-infinity") != 0)) + return 1; + if (sprintf (buf, "%Lf", zeroL / zeroL) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", 1.0L / 0.0L) < 0 + || (strcmp (buf, "inf") != 0 && strcmp (buf, "infinity") != 0)) + return 1; + if (sprintf (buf, "%Le", -1.0L / 0.0L) < 0 + || (strcmp (buf, "-inf") != 0 && strcmp (buf, "-infinity") != 0)) + return 1; + if (sprintf (buf, "%Le", zeroL / zeroL) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", 1.0L / 0.0L) < 0 + || (strcmp (buf, "inf") != 0 && strcmp (buf, "infinity") != 0)) + return 1; + if (sprintf (buf, "%Lg", -1.0L / 0.0L) < 0 + || (strcmp (buf, "-inf") != 0 && strcmp (buf, "-infinity") != 0)) + return 1; + if (sprintf (buf, "%Lg", zeroL / zeroL) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; +#if CHECK_PRINTF_SAFE && ((defined __ia64 && LDBL_MANT_DIG == 64) || (defined __x86_64__ || defined __amd64__) || (defined __i386 || defined __i386__ || defined _I386 || defined _M_IX86 || defined _X86_)) +/* Representation of an 80-bit 'long double' as an initializer for a sequence + of 'unsigned int' words. */ +# ifdef WORDS_BIGENDIAN +# define LDBL80_WORDS(exponent,manthi,mantlo) \ + { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ + ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + (unsigned int) (mantlo) << 16 \ + } +# else +# define LDBL80_WORDS(exponent,manthi,mantlo) \ + { mantlo, manthi, exponent } +# endif + { /* Quiet NaN. */ + static union { unsigned int word[4]; long double value; } x = + { LDBL80_WORDS (0xFFFF, 0xC3333333, 0x00000000) }; + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + } + { + /* Signalling NaN. */ + static union { unsigned int word[4]; long double value; } x = + { LDBL80_WORDS (0xFFFF, 0x83333333, 0x00000000) }; + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + } + { /* Pseudo-NaN. */ + static union { unsigned int word[4]; long double value; } x = + { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + } + { /* Pseudo-Infinity. */ + static union { unsigned int word[4]; long double value; } x = + { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + } + { /* Pseudo-Zero. */ + static union { unsigned int word[4]; long double value; } x = + { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + } + { /* Unnormalized number. */ + static union { unsigned int word[4]; long double value; } x = + { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + } + { /* Pseudo-Denormal. */ + static union { unsigned int word[4]; long double value; } x = + { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) + return 1; + } +#endif + return 0; +}], + [gl_cv_func_printf_infinite_long_double=yes], + [gl_cv_func_printf_infinite_long_double=no], + [ +changequote(,)dnl + case "$host_cpu" in + # Guess no on ia64, x86_64, i386. + ia64 | x86_64 | i*86) gl_cv_func_printf_infinite_long_double="guessing no";; + *) + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_printf_infinite_long_double="guessing yes";; + # Guess yes on FreeBSD >= 6. + freebsd[1-5]*) gl_cv_func_printf_infinite_long_double="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_printf_infinite_long_double="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_printf_infinite_long_double="guessing no";; + darwin*) gl_cv_func_printf_infinite_long_double="guessing yes";; + # Guess yes on HP-UX >= 11. + hpux[7-9]* | hpux10*) gl_cv_func_printf_infinite_long_double="guessing no";; + hpux*) gl_cv_func_printf_infinite_long_double="guessing yes";; + # Guess yes on NetBSD >= 3. + netbsd[1-2]* | netbsdelf[1-2]* | netbsdaout[1-2]* | netbsdcoff[1-2]*) + gl_cv_func_printf_infinite_long_double="guessing no";; + netbsd*) gl_cv_func_printf_infinite_long_double="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_printf_infinite_long_double="guessing no";; + esac + ;; + esac +changequote([,])dnl + ]) + ]) + ;; + *) + gl_cv_func_printf_infinite_long_double="irrelevant" + ;; + esac +]) + +dnl Test whether the *printf family of functions supports the 'a' and 'A' +dnl conversion specifier for hexadecimal output of floating-point numbers. +dnl (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_printf_directive_a. + +AC_DEFUN([gl_PRINTF_DIRECTIVE_A], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports the 'a' and 'A' directives], + [gl_cv_func_printf_directive_a], + [ + AC_TRY_RUN([ +#include +#include +static char buf[100]; +int main () +{ + if (sprintf (buf, "%a %d", 3.1416015625, 33, 44, 55) < 0 + || (strcmp (buf, "0x1.922p+1 33") != 0 + && strcmp (buf, "0x3.244p+0 33") != 0 + && strcmp (buf, "0x6.488p-1 33") != 0 + && strcmp (buf, "0xc.91p-2 33") != 0)) + return 1; + if (sprintf (buf, "%A %d", -3.1416015625, 33, 44, 55) < 0 + || (strcmp (buf, "-0X1.922P+1 33") != 0 + && strcmp (buf, "-0X3.244P+0 33") != 0 + && strcmp (buf, "-0X6.488P-1 33") != 0 + && strcmp (buf, "-0XC.91P-2 33") != 0)) + return 1; + /* This catches a FreeBSD 6.1 bug: it doesn't round. */ + if (sprintf (buf, "%.2a %d", 1.51, 33, 44, 55) < 0 + || (strcmp (buf, "0x1.83p+0 33") != 0 + && strcmp (buf, "0x3.05p-1 33") != 0 + && strcmp (buf, "0x6.0ap-2 33") != 0 + && strcmp (buf, "0xc.14p-3 33") != 0)) + return 1; + /* This catches a FreeBSD 6.1 bug. See + */ + if (sprintf (buf, "%010a %d", 1.0 / 0.0, 33, 44, 55) < 0 + || buf[0] == '0') + return 1; + /* This catches a MacOS X 10.3.9 (Darwin 7.9) bug. */ + if (sprintf (buf, "%.1a", 1.999) < 0 + || (strcmp (buf, "0x1.0p+1") != 0 + && strcmp (buf, "0x2.0p+0") != 0 + && strcmp (buf, "0x4.0p-1") != 0 + && strcmp (buf, "0x8.0p-2") != 0)) + return 1; + /* This catches the same MacOS X 10.3.9 (Darwin 7.9) bug and also a + glibc 2.4 bug . */ + if (sprintf (buf, "%.1La", 1.999L) < 0 + || (strcmp (buf, "0x1.0p+1") != 0 + && strcmp (buf, "0x2.0p+0") != 0 + && strcmp (buf, "0x4.0p-1") != 0 + && strcmp (buf, "0x8.0p-2") != 0)) + return 1; + return 0; +}], [gl_cv_func_printf_directive_a=yes], [gl_cv_func_printf_directive_a=no], + [ + case "$host_os" in + # Guess yes on glibc >= 2.5 systems. + *-gnu*) + AC_EGREP_CPP([BZ2908], [ + #include + #ifdef __GNU_LIBRARY__ + #if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 5) || (__GLIBC__ > 2) + BZ2908 + #endif + #endif + ], + [gl_cv_func_printf_directive_a="guessing yes"], + [gl_cv_func_printf_directive_a="guessing no"]) + ;; + # If we don't know, assume the worst. + *) gl_cv_func_printf_directive_a="guessing no";; + esac + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports the %F format +dnl directive. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_printf_directive_f. + +AC_DEFUN([gl_PRINTF_DIRECTIVE_F], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports the 'F' directive], + [gl_cv_func_printf_directive_f], + [ + AC_TRY_RUN([ +#include +#include +static char buf[100]; +int main () +{ + if (sprintf (buf, "%F %d", 1234567.0, 33, 44, 55) < 0 + || strcmp (buf, "1234567.000000 33") != 0) + return 1; + if (sprintf (buf, "%F", 1.0 / 0.0) < 0 + || (strcmp (buf, "INF") != 0 && strcmp (buf, "INFINITY") != 0)) + return 1; + /* This catches a Cygwin 1.5.x bug. */ + if (sprintf (buf, "%.F", 1234.0) < 0 + || strcmp (buf, "1234") != 0) + return 1; + return 0; +}], [gl_cv_func_printf_directive_f=yes], [gl_cv_func_printf_directive_f=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_printf_directive_f="guessing yes";; + # Guess yes on FreeBSD >= 6. + freebsd[1-5]*) gl_cv_func_printf_directive_f="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_printf_directive_f="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_printf_directive_f="guessing no";; + darwin*) gl_cv_func_printf_directive_f="guessing yes";; + # Guess yes on Solaris >= 2.10. + solaris2.[0-9]*) gl_cv_func_printf_directive_f="guessing no";; + solaris*) gl_cv_func_printf_directive_f="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_printf_directive_f="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports the %n format +dnl directive. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_printf_directive_n. + +AC_DEFUN([gl_PRINTF_DIRECTIVE_N], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports the 'n' directive], + [gl_cv_func_printf_directive_n], + [ + AC_TRY_RUN([ +#include +#include +static char fmtstring[10]; +static char buf[100]; +int main () +{ + int count = -1; + /* Copy the format string. Some systems (glibc with _FORTIFY_SOURCE=2) + support %n in format strings in read-only memory but not in writable + memory. */ + strcpy (fmtstring, "%d %n"); + if (sprintf (buf, fmtstring, 123, &count, 33, 44, 55) < 0 + || strcmp (buf, "123 ") != 0 + || count != 4) + return 1; + return 0; +}], [gl_cv_func_printf_directive_n=yes], [gl_cv_func_printf_directive_n=no], + [ +changequote(,)dnl + case "$host_os" in + *) gl_cv_func_printf_directive_n="guessing yes";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports the %ls format +dnl directive and in particular, when a precision is specified, whether +dnl the functions stop converting the wide string argument when the number +dnl of bytes that have been produced by this conversion equals or exceeds +dnl the precision. +dnl Result is gl_cv_func_printf_directive_ls. + +AC_DEFUN([gl_PRINTF_DIRECTIVE_LS], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports the 'ls' directive], + [gl_cv_func_printf_directive_ls], + [ + AC_TRY_RUN([ +/* Tru64 with Desktop Toolkit C has a bug: must be included before + . + BSD/OS 4.0.1 has a bug: , and must be + included before . */ +#include +#include +#include +#include +#include +int main () +{ + char buf[100]; + /* Test whether %ls works at all. + This test fails on OpenBSD 4.0, IRIX 6.5, Solaris 2.6, Haiku, but not on + Cygwin 1.5. */ + { + static const wchar_t wstring[] = { 'a', 'b', 'c', 0 }; + buf[0] = '\0'; + if (sprintf (buf, "%ls", wstring) < 0 + || strcmp (buf, "abc") != 0) + return 1; + } + /* This test fails on IRIX 6.5, Solaris 2.6, Cygwin 1.5, Haiku (with an + assertion failure inside libc), but not on OpenBSD 4.0. */ + { + static const wchar_t wstring[] = { 'a', 0 }; + buf[0] = '\0'; + if (sprintf (buf, "%ls", wstring) < 0 + || strcmp (buf, "a") != 0) + return 1; + } + /* Test whether precisions in %ls are supported as specified in ISO C 99 + section 7.19.6.1: + "If a precision is specified, no more than that many bytes are written + (including shift sequences, if any), and the array shall contain a + null wide character if, to equal the multibyte character sequence + length given by the precision, the function would need to access a + wide character one past the end of the array." + This test fails on Solaris 10. */ + { + static const wchar_t wstring[] = { 'a', 'b', (wchar_t) 0xfdfdfdfd, 0 }; + buf[0] = '\0'; + if (sprintf (buf, "%.2ls", wstring) < 0 + || strcmp (buf, "ab") != 0) + return 1; + } + return 0; +}], [gl_cv_func_printf_directive_ls=yes], [gl_cv_func_printf_directive_ls=no], + [ +changequote(,)dnl + case "$host_os" in + openbsd*) gl_cv_func_printf_directive_ls="guessing no";; + irix*) gl_cv_func_printf_directive_ls="guessing no";; + solaris*) gl_cv_func_printf_directive_ls="guessing no";; + cygwin*) gl_cv_func_printf_directive_ls="guessing no";; + beos* | haiku*) gl_cv_func_printf_directive_ls="guessing no";; + *) gl_cv_func_printf_directive_ls="guessing yes";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports POSIX/XSI format +dnl strings with positions. (POSIX:2001) +dnl Result is gl_cv_func_printf_positions. + +AC_DEFUN([gl_PRINTF_POSITIONS], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports POSIX/XSI format strings with positions], + [gl_cv_func_printf_positions], + [ + AC_TRY_RUN([ +#include +#include +/* The string "%2$d %1$d", with dollar characters protected from the shell's + dollar expansion (possibly an autoconf bug). */ +static char format[] = { '%', '2', '$', 'd', ' ', '%', '1', '$', 'd', '\0' }; +static char buf[100]; +int main () +{ + sprintf (buf, format, 33, 55); + return (strcmp (buf, "55 33") != 0); +}], [gl_cv_func_printf_positions=yes], [gl_cv_func_printf_positions=no], + [ +changequote(,)dnl + case "$host_os" in + netbsd[1-3]* | netbsdelf[1-3]* | netbsdaout[1-3]* | netbsdcoff[1-3]*) + gl_cv_func_printf_positions="guessing no";; + beos*) gl_cv_func_printf_positions="guessing no";; + mingw* | pw*) gl_cv_func_printf_positions="guessing no";; + *) gl_cv_func_printf_positions="guessing yes";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports POSIX/XSI format +dnl strings with the ' flag for grouping of decimal digits. (POSIX:2001) +dnl Result is gl_cv_func_printf_flag_grouping. + +AC_DEFUN([gl_PRINTF_FLAG_GROUPING], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports the grouping flag], + [gl_cv_func_printf_flag_grouping], + [ + AC_TRY_RUN([ +#include +#include +static char buf[100]; +int main () +{ + if (sprintf (buf, "%'d %d", 1234567, 99) < 0 + || buf[strlen (buf) - 1] != '9') + return 1; + return 0; +}], [gl_cv_func_printf_flag_grouping=yes], [gl_cv_func_printf_flag_grouping=no], + [ +changequote(,)dnl + case "$host_os" in + cygwin*) gl_cv_func_printf_flag_grouping="guessing no";; + netbsd*) gl_cv_func_printf_flag_grouping="guessing no";; + mingw* | pw*) gl_cv_func_printf_flag_grouping="guessing no";; + *) gl_cv_func_printf_flag_grouping="guessing yes";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports the - flag correctly. +dnl (ISO C99.) See +dnl +dnl Result is gl_cv_func_printf_flag_leftadjust. + +AC_DEFUN([gl_PRINTF_FLAG_LEFTADJUST], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports the left-adjust flag correctly], + [gl_cv_func_printf_flag_leftadjust], + [ + AC_TRY_RUN([ +#include +#include +static char buf[100]; +int main () +{ + /* Check that a '-' flag is not annihilated by a negative width. */ + if (sprintf (buf, "a%-*sc", -3, "b") < 0 + || strcmp (buf, "ab c") != 0) + return 1; + return 0; +}], + [gl_cv_func_printf_flag_leftadjust=yes], + [gl_cv_func_printf_flag_leftadjust=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on HP-UX 11. + hpux11*) gl_cv_func_printf_flag_leftadjust="guessing yes";; + # Guess no on HP-UX 10 and older. + hpux*) gl_cv_func_printf_flag_leftadjust="guessing no";; + # Guess yes otherwise. + *) gl_cv_func_printf_flag_leftadjust="guessing yes";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports padding of non-finite +dnl values with the 0 flag correctly. (ISO C99 + TC1 + TC2.) See +dnl +dnl Result is gl_cv_func_printf_flag_zero. + +AC_DEFUN([gl_PRINTF_FLAG_ZERO], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports the zero flag correctly], + [gl_cv_func_printf_flag_zero], + [ + AC_TRY_RUN([ +#include +#include +static char buf[100]; +int main () +{ + if (sprintf (buf, "%010f", 1.0 / 0.0, 33, 44, 55) < 0 + || (strcmp (buf, " inf") != 0 + && strcmp (buf, " infinity") != 0)) + return 1; + return 0; +}], [gl_cv_func_printf_flag_zero=yes], [gl_cv_func_printf_flag_zero=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_printf_flag_zero="guessing yes";; + # Guess yes on BeOS. + beos*) gl_cv_func_printf_flag_zero="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_printf_flag_zero="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions supports large precisions. +dnl On mingw, precisions larger than 512 are treated like 512, in integer, +dnl floating-point or pointer output. On BeOS, precisions larger than 1044 +dnl crash the program. +dnl Result is gl_cv_func_printf_precision. + +AC_DEFUN([gl_PRINTF_PRECISION], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf supports large precisions], + [gl_cv_func_printf_precision], + [ + AC_TRY_RUN([ +#include +#include +static char buf[5000]; +int main () +{ +#ifdef __BEOS__ + /* On BeOS, this would crash and show a dialog box. Avoid the crash. */ + return 1; +#endif + if (sprintf (buf, "%.4000d %d", 1, 33, 44) < 4000 + 3) + return 1; + return 0; +}], [gl_cv_func_printf_precision=yes], [gl_cv_func_printf_precision=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess no only on native Win32 and BeOS systems. + mingw* | pw*) gl_cv_func_printf_precision="guessing no" ;; + beos*) gl_cv_func_printf_precision="guessing no" ;; + *) gl_cv_func_printf_precision="guessing yes" ;; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the *printf family of functions recovers gracefully in case +dnl of an out-of-memory condition, or whether it crashes the entire program. +dnl Result is gl_cv_func_printf_enomem. + +AC_DEFUN([gl_PRINTF_ENOMEM], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([gl_MULTIARCH]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether printf survives out-of-memory conditions], + [gl_cv_func_printf_enomem], + [ + gl_cv_func_printf_enomem="guessing no" + if test "$cross_compiling" = no; then + if test $APPLE_UNIVERSAL_BUILD = 0; then + AC_LANG_CONFTEST([AC_LANG_SOURCE([ +]GL_NOCRASH[ +changequote(,)dnl +#include +#include +#include +#include +#include +int main() +{ + struct rlimit limit; + int ret; + nocrash_init (); + /* Some printf implementations allocate temporary space with malloc. */ + /* On BSD systems, malloc() is limited by RLIMIT_DATA. */ +#ifdef RLIMIT_DATA + if (getrlimit (RLIMIT_DATA, &limit) < 0) + return 77; + if (limit.rlim_max == RLIM_INFINITY || limit.rlim_max > 5000000) + limit.rlim_max = 5000000; + limit.rlim_cur = limit.rlim_max; + if (setrlimit (RLIMIT_DATA, &limit) < 0) + return 77; +#endif + /* On Linux systems, malloc() is limited by RLIMIT_AS. */ +#ifdef RLIMIT_AS + if (getrlimit (RLIMIT_AS, &limit) < 0) + return 77; + if (limit.rlim_max == RLIM_INFINITY || limit.rlim_max > 5000000) + limit.rlim_max = 5000000; + limit.rlim_cur = limit.rlim_max; + if (setrlimit (RLIMIT_AS, &limit) < 0) + return 77; +#endif + /* Some printf implementations allocate temporary space on the stack. */ +#ifdef RLIMIT_STACK + if (getrlimit (RLIMIT_STACK, &limit) < 0) + return 77; + if (limit.rlim_max == RLIM_INFINITY || limit.rlim_max > 5000000) + limit.rlim_max = 5000000; + limit.rlim_cur = limit.rlim_max; + if (setrlimit (RLIMIT_STACK, &limit) < 0) + return 77; +#endif + ret = printf ("%.5000000f", 1.0); + return !(ret == 5000002 || (ret < 0 && errno == ENOMEM)); +} +changequote([,])dnl + ])]) + if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then + (./conftest + result=$? + if test $result != 0 && test $result != 77; then result=1; fi + exit $result + ) >/dev/null 2>/dev/null + case $? in + 0) gl_cv_func_printf_enomem="yes" ;; + 77) gl_cv_func_printf_enomem="guessing no" ;; + *) gl_cv_func_printf_enomem="no" ;; + esac + else + gl_cv_func_printf_enomem="guessing no" + fi + rm -fr conftest* + else + dnl A universal build on Apple MacOS X platforms. + dnl The result would be 'no' in 32-bit mode and 'yes' in 64-bit mode. + dnl But we need a configuration result that is valid in both modes. + gl_cv_func_printf_enomem="guessing no" + fi + fi + if test "$gl_cv_func_printf_enomem" = "guessing no"; then +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_printf_enomem="guessing yes";; + # Guess yes on Solaris. + solaris*) gl_cv_func_printf_enomem="guessing yes";; + # Guess yes on AIX. + aix*) gl_cv_func_printf_enomem="guessing yes";; + # Guess yes on HP-UX/hppa. + hpux*) case "$host_cpu" in + hppa*) gl_cv_func_printf_enomem="guessing yes";; + *) gl_cv_func_printf_enomem="guessing no";; + esac + ;; + # Guess yes on IRIX. + irix*) gl_cv_func_printf_enomem="guessing yes";; + # Guess yes on OSF/1. + osf*) gl_cv_func_printf_enomem="guessing yes";; + # Guess yes on BeOS. + beos*) gl_cv_func_printf_enomem="guessing yes";; + # Guess yes on Haiku. + haiku*) gl_cv_func_printf_enomem="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_printf_enomem="guessing no";; + esac +changequote([,])dnl + fi + ]) +]) + +dnl Test whether the snprintf function exists. (ISO C99, POSIX:2001) +dnl Result is ac_cv_func_snprintf. + +AC_DEFUN([gl_SNPRINTF_PRESENCE], +[ + AC_CHECK_FUNCS_ONCE([snprintf]) +]) + +dnl Test whether the string produced by the snprintf function is always NUL +dnl terminated. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_snprintf_truncation_c99. + +AC_DEFUN([gl_SNPRINTF_TRUNCATION_C99], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether snprintf truncates the result as in C99], + [gl_cv_func_snprintf_truncation_c99], + [ + AC_TRY_RUN([ +#include +#include +static char buf[100]; +int main () +{ + strcpy (buf, "ABCDEF"); + snprintf (buf, 3, "%d %d", 4567, 89); + if (memcmp (buf, "45\0DEF", 6) != 0) + return 1; + return 0; +}], [gl_cv_func_snprintf_truncation_c99=yes], [gl_cv_func_snprintf_truncation_c99=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on FreeBSD >= 5. + freebsd[1-4]*) gl_cv_func_snprintf_truncation_c99="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_snprintf_truncation_c99="guessing no";; + darwin*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on OpenBSD >= 3.9. + openbsd[1-2].* | openbsd3.[0-8] | openbsd3.[0-8].*) + gl_cv_func_snprintf_truncation_c99="guessing no";; + openbsd*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on Solaris >= 2.6. + solaris2.[0-5]*) gl_cv_func_snprintf_truncation_c99="guessing no";; + solaris*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on AIX >= 4. + aix[1-3]*) gl_cv_func_snprintf_truncation_c99="guessing no";; + aix*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on HP-UX >= 11. + hpux[7-9]* | hpux10*) gl_cv_func_snprintf_truncation_c99="guessing no";; + hpux*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on IRIX >= 6.5. + irix6.5) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on OSF/1 >= 5. + osf[3-4]*) gl_cv_func_snprintf_truncation_c99="guessing no";; + osf*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on NetBSD >= 3. + netbsd[1-2]* | netbsdelf[1-2]* | netbsdaout[1-2]* | netbsdcoff[1-2]*) + gl_cv_func_snprintf_truncation_c99="guessing no";; + netbsd*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # Guess yes on BeOS. + beos*) gl_cv_func_snprintf_truncation_c99="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_snprintf_truncation_c99="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the return value of the snprintf function is the number +dnl of bytes (excluding the terminating NUL) that would have been produced +dnl if the buffer had been large enough. (ISO C99, POSIX:2001) +dnl For example, this test program fails on IRIX 6.5: +dnl --------------------------------------------------------------------- +dnl #include +dnl int main() +dnl { +dnl static char buf[8]; +dnl int retval = snprintf (buf, 3, "%d", 12345); +dnl return retval >= 0 && retval < 3; +dnl } +dnl --------------------------------------------------------------------- +dnl Result is gl_cv_func_snprintf_retval_c99. + +AC_DEFUN([gl_SNPRINTF_RETVAL_C99], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether snprintf returns a byte count as in C99], + [gl_cv_func_snprintf_retval_c99], + [ + AC_TRY_RUN([ +#include +#include +static char buf[100]; +int main () +{ + strcpy (buf, "ABCDEF"); + if (snprintf (buf, 3, "%d %d", 4567, 89) != 7) + return 1; + return 0; +}], [gl_cv_func_snprintf_retval_c99=yes], [gl_cv_func_snprintf_retval_c99=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # Guess yes on FreeBSD >= 5. + freebsd[1-4]*) gl_cv_func_snprintf_retval_c99="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_snprintf_retval_c99="guessing no";; + darwin*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # Guess yes on OpenBSD >= 3.9. + openbsd[1-2].* | openbsd3.[0-8] | openbsd3.[0-8].*) + gl_cv_func_snprintf_retval_c99="guessing no";; + openbsd*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # Guess yes on Solaris >= 2.6. + solaris2.[0-5]*) gl_cv_func_snprintf_retval_c99="guessing no";; + solaris*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # Guess yes on AIX >= 4. + aix[1-3]*) gl_cv_func_snprintf_retval_c99="guessing no";; + aix*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # Guess yes on NetBSD >= 3. + netbsd[1-2]* | netbsdelf[1-2]* | netbsdaout[1-2]* | netbsdcoff[1-2]*) + gl_cv_func_snprintf_retval_c99="guessing no";; + netbsd*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # Guess yes on BeOS. + beos*) gl_cv_func_snprintf_retval_c99="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_snprintf_retval_c99="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the snprintf function supports the %n format directive +dnl also in truncated portions of the format string. (ISO C99, POSIX:2001) +dnl Result is gl_cv_func_snprintf_directive_n. + +AC_DEFUN([gl_SNPRINTF_DIRECTIVE_N], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether snprintf fully supports the 'n' directive], + [gl_cv_func_snprintf_directive_n], + [ + AC_TRY_RUN([ +#include +#include +static char fmtstring[10]; +static char buf[100]; +int main () +{ + int count = -1; + /* Copy the format string. Some systems (glibc with _FORTIFY_SOURCE=2) + support %n in format strings in read-only memory but not in writable + memory. */ + strcpy (fmtstring, "%d %n"); + snprintf (buf, 4, fmtstring, 12345, &count, 33, 44, 55); + if (count != 6) + return 1; + return 0; +}], [gl_cv_func_snprintf_directive_n=yes], [gl_cv_func_snprintf_directive_n=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on FreeBSD >= 5. + freebsd[1-4]*) gl_cv_func_snprintf_directive_n="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_snprintf_directive_n="guessing no";; + darwin*) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on Solaris >= 2.6. + solaris2.[0-5]*) gl_cv_func_snprintf_directive_n="guessing no";; + solaris*) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on AIX >= 4. + aix[1-3]*) gl_cv_func_snprintf_directive_n="guessing no";; + aix*) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on IRIX >= 6.5. + irix6.5) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on OSF/1 >= 5. + osf[3-4]*) gl_cv_func_snprintf_directive_n="guessing no";; + osf*) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on NetBSD >= 3. + netbsd[1-2]* | netbsdelf[1-2]* | netbsdaout[1-2]* | netbsdcoff[1-2]*) + gl_cv_func_snprintf_directive_n="guessing no";; + netbsd*) gl_cv_func_snprintf_directive_n="guessing yes";; + # Guess yes on BeOS. + beos*) gl_cv_func_snprintf_directive_n="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_snprintf_directive_n="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl Test whether the snprintf function, when passed a size = 1, writes any +dnl output without bounds in this case, behaving like sprintf. This is the +dnl case on Linux libc5. +dnl Result is gl_cv_func_snprintf_size1. + +AC_DEFUN([gl_SNPRINTF_SIZE1], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_CACHE_CHECK([whether snprintf respects a size of 1], + [gl_cv_func_snprintf_size1], + [ + AC_TRY_RUN([ +#include +int main() +{ + static char buf[8] = { 'D', 'E', 'A', 'D', 'B', 'E', 'E', 'F' }; + snprintf (buf, 1, "%d", 12345); + return buf[1] != 'E'; +}], + [gl_cv_func_snprintf_size1=yes], + [gl_cv_func_snprintf_size1=no], + [gl_cv_func_snprintf_size1="guessing yes"]) + ]) +]) + +dnl Test whether the vsnprintf function, when passed a zero size, produces no +dnl output. (ISO C99, POSIX:2001) +dnl For example, snprintf nevertheless writes a NUL byte in this case +dnl on OSF/1 5.1: +dnl --------------------------------------------------------------------- +dnl #include +dnl int main() +dnl { +dnl static char buf[8] = { 'D', 'E', 'A', 'D', 'B', 'E', 'E', 'F' }; +dnl snprintf (buf, 0, "%d", 12345); +dnl return buf[0] != 'D'; +dnl } +dnl --------------------------------------------------------------------- +dnl And vsnprintf writes any output without bounds in this case, behaving like +dnl vsprintf, on HP-UX 11 and OSF/1 5.1: +dnl --------------------------------------------------------------------- +dnl #include +dnl #include +dnl static int my_snprintf (char *buf, int size, const char *format, ...) +dnl { +dnl va_list args; +dnl int ret; +dnl va_start (args, format); +dnl ret = vsnprintf (buf, size, format, args); +dnl va_end (args); +dnl return ret; +dnl } +dnl int main() +dnl { +dnl static char buf[8] = { 'D', 'E', 'A', 'D', 'B', 'E', 'E', 'F' }; +dnl my_snprintf (buf, 0, "%d", 12345); +dnl return buf[0] != 'D'; +dnl } +dnl --------------------------------------------------------------------- +dnl Result is gl_cv_func_vsnprintf_zerosize_c99. + +AC_DEFUN([gl_VSNPRINTF_ZEROSIZE_C99], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether vsnprintf respects a zero size as in C99], + [gl_cv_func_vsnprintf_zerosize_c99], + [ + AC_TRY_RUN([ +#include +#include +static int my_snprintf (char *buf, int size, const char *format, ...) +{ + va_list args; + int ret; + va_start (args, format); + ret = vsnprintf (buf, size, format, args); + va_end (args); + return ret; +} +int main() +{ + static char buf[8] = { 'D', 'E', 'A', 'D', 'B', 'E', 'E', 'F' }; + my_snprintf (buf, 0, "%d", 12345); + return buf[0] != 'D'; +}], + [gl_cv_func_vsnprintf_zerosize_c99=yes], + [gl_cv_func_vsnprintf_zerosize_c99=no], + [ +changequote(,)dnl + case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on FreeBSD >= 5. + freebsd[1-4]*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + freebsd* | kfreebsd*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on MacOS X >= 10.3. + darwin[1-6].*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + darwin*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on Cygwin. + cygwin*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on Solaris >= 2.6. + solaris2.[0-5]*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + solaris*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on AIX >= 4. + aix[1-3]*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + aix*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on IRIX >= 6.5. + irix6.5) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on NetBSD >= 3. + netbsd[1-2]* | netbsdelf[1-2]* | netbsdaout[1-2]* | netbsdcoff[1-2]*) + gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + netbsd*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on BeOS. + beos*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # Guess yes on mingw. + mingw* | pw*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; + # If we don't know, assume the worst. + *) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + esac +changequote([,])dnl + ]) + ]) +]) + +dnl The results of these tests on various platforms are: +dnl +dnl 1 = gl_PRINTF_SIZES_C99 +dnl 2 = gl_PRINTF_LONG_DOUBLE +dnl 3 = gl_PRINTF_INFINITE +dnl 4 = gl_PRINTF_INFINITE_LONG_DOUBLE +dnl 5 = gl_PRINTF_DIRECTIVE_A +dnl 6 = gl_PRINTF_DIRECTIVE_F +dnl 7 = gl_PRINTF_DIRECTIVE_N +dnl 8 = gl_PRINTF_DIRECTIVE_LS +dnl 9 = gl_PRINTF_POSITIONS +dnl 10 = gl_PRINTF_FLAG_GROUPING +dnl 11 = gl_PRINTF_FLAG_LEFTADJUST +dnl 12 = gl_PRINTF_FLAG_ZERO +dnl 13 = gl_PRINTF_PRECISION +dnl 14 = gl_PRINTF_ENOMEM +dnl 15 = gl_SNPRINTF_PRESENCE +dnl 16 = gl_SNPRINTF_TRUNCATION_C99 +dnl 17 = gl_SNPRINTF_RETVAL_C99 +dnl 18 = gl_SNPRINTF_DIRECTIVE_N +dnl 19 = gl_SNPRINTF_SIZE1 +dnl 20 = gl_VSNPRINTF_ZEROSIZE_C99 +dnl +dnl 1 = checking whether printf supports size specifiers as in C99... +dnl 2 = checking whether printf supports 'long double' arguments... +dnl 3 = checking whether printf supports infinite 'double' arguments... +dnl 4 = checking whether printf supports infinite 'long double' arguments... +dnl 5 = checking whether printf supports the 'a' and 'A' directives... +dnl 6 = checking whether printf supports the 'F' directive... +dnl 7 = checking whether printf supports the 'n' directive... +dnl 8 = checking whether printf supports the 'ls' directive... +dnl 9 = checking whether printf supports POSIX/XSI format strings with positions... +dnl 10 = checking whether printf supports the grouping flag... +dnl 11 = checking whether printf supports the left-adjust flag correctly... +dnl 12 = checking whether printf supports the zero flag correctly... +dnl 13 = checking whether printf supports large precisions... +dnl 14 = checking whether printf survives out-of-memory conditions... +dnl 15 = checking for snprintf... +dnl 16 = checking whether snprintf truncates the result as in C99... +dnl 17 = checking whether snprintf returns a byte count as in C99... +dnl 18 = checking whether snprintf fully supports the 'n' directive... +dnl 19 = checking whether snprintf respects a size of 1... +dnl 20 = checking whether vsnprintf respects a zero size as in C99... +dnl +dnl . = yes, # = no. +dnl +dnl 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 +dnl glibc 2.5 . . . . . . . . . . . . . . . . . . . . +dnl glibc 2.3.6 . . . . # . . . . . . . . . . . . . . . +dnl FreeBSD 5.4, 6.1 . . . . # . . . . . . # . # . . . . . . +dnl MacOS X 10.3.9 . . . . # . . . . . . # . # . . . . . . +dnl OpenBSD 3.9, 4.0 . . # # # # . # . # . # . # . . . . . . +dnl Cygwin 1.7.0 (2009) . . . # . . . ? . . . . . ? . . . . . . +dnl Cygwin 1.5.25 (2008) . . . # # . . # . . . . . # . . . . . . +dnl Cygwin 1.5.19 (2006) # . . # # # . # . # . # # # . . . . . . +dnl Solaris 10 . . # # # . . # . . . # . . . . . . . . +dnl Solaris 2.6 ... 9 # . # # # # . # . . . # . . . . . . . . +dnl Solaris 2.5.1 # . # # # # . # . . . # . . # # # # # # +dnl AIX 5.2 . . # # # . . . . . . # . . . . . . . . +dnl AIX 4.3.2, 5.1 # . # # # # . . . . . # . . . . . . . . +dnl HP-UX 11.31 . . . . # . . . . . . # . . . . # # . . +dnl HP-UX 11.{00,11,23} # . . . # # . . . . . # . . . . # # . # +dnl HP-UX 10.20 # . # . # # . ? . . # # . . . . # # ? # +dnl IRIX 6.5 # . # # # # . # . . . # . . . . # . . . +dnl OSF/1 5.1 # . # # # # . . . . . # . . . . # . . # +dnl OSF/1 4.0d # . # # # # . . . . . # . . # # # # # # +dnl NetBSD 4.0 . ? ? ? ? ? . ? . ? ? ? ? ? . . . ? ? ? +dnl NetBSD 3.0 . . . . # # . ? # # ? # . # . . . . . . +dnl Haiku . . . # # # . # . . . . . ? . . . . . . +dnl BeOS # # . # # # . ? # . ? . # ? . . . . . . +dnl mingw # # # # # # . . # # . # # ? . # # # . . diff --git a/m4/size_max.m4 b/m4/size_max.m4 new file mode 100644 index 000000000..35bd3d6ae --- /dev/null +++ b/m4/size_max.m4 @@ -0,0 +1,75 @@ +# size_max.m4 serial 9 +dnl Copyright (C) 2003, 2005-2006, 2008-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Bruno Haible. + +AC_DEFUN([gl_SIZE_MAX], +[ + AC_CHECK_HEADERS([stdint.h]) + dnl First test whether the system already has SIZE_MAX. + AC_CACHE_CHECK([for SIZE_MAX], [gl_cv_size_max], [ + gl_cv_size_max= + AC_EGREP_CPP([Found it], [ +#include +#if HAVE_STDINT_H +#include +#endif +#ifdef SIZE_MAX +Found it +#endif +], [gl_cv_size_max=yes]) + if test -z "$gl_cv_size_max"; then + dnl Define it ourselves. Here we assume that the type 'size_t' is not wider + dnl than the type 'unsigned long'. Try hard to find a definition that can + dnl be used in a preprocessor #if, i.e. doesn't contain a cast. + AC_COMPUTE_INT([size_t_bits_minus_1], [sizeof (size_t) * CHAR_BIT - 1], + [#include +#include ], [size_t_bits_minus_1=]) + AC_COMPUTE_INT([fits_in_uint], [sizeof (size_t) <= sizeof (unsigned int)], + [#include ], [fits_in_uint=]) + if test -n "$size_t_bits_minus_1" && test -n "$fits_in_uint"; then + if test $fits_in_uint = 1; then + dnl Even though SIZE_MAX fits in an unsigned int, it must be of type + dnl 'unsigned long' if the type 'size_t' is the same as 'unsigned long'. + AC_TRY_COMPILE([#include + extern size_t foo; + extern unsigned long foo; + ], [], [fits_in_uint=0]) + fi + dnl We cannot use 'expr' to simplify this expression, because 'expr' + dnl works only with 'long' integers in the host environment, while we + dnl might be cross-compiling from a 32-bit platform to a 64-bit platform. + if test $fits_in_uint = 1; then + gl_cv_size_max="(((1U << $size_t_bits_minus_1) - 1) * 2 + 1)" + else + gl_cv_size_max="(((1UL << $size_t_bits_minus_1) - 1) * 2 + 1)" + fi + else + dnl Shouldn't happen, but who knows... + gl_cv_size_max='((size_t)~(size_t)0)' + fi + fi + ]) + if test "$gl_cv_size_max" != yes; then + AC_DEFINE_UNQUOTED([SIZE_MAX], [$gl_cv_size_max], + [Define as the maximum value of type 'size_t', if the system doesn't define it.]) + fi + dnl Don't redefine SIZE_MAX in config.h if config.h is re-included after + dnl . Remember that the #undef in AH_VERBATIM gets replaced with + dnl #define by AC_DEFINE_UNQUOTED. + AH_VERBATIM([SIZE_MAX], +[/* Define as the maximum value of type 'size_t', if the system doesn't define + it. */ +#ifndef SIZE_MAX +# undef SIZE_MAX +#endif]) +]) + +dnl Autoconf >= 2.61 has AC_COMPUTE_INT built-in. +dnl Remove this when we can assume autoconf >= 2.61. +m4_ifdef([AC_COMPUTE_INT], [], [ + AC_DEFUN([AC_COMPUTE_INT], [_AC_COMPUTE_INT([$2],[$1],[$3],[$4])]) +]) diff --git a/m4/stdint_h.m4 b/m4/stdint_h.m4 new file mode 100644 index 000000000..82f0c244c --- /dev/null +++ b/m4/stdint_h.m4 @@ -0,0 +1,26 @@ +# stdint_h.m4 serial 8 +dnl Copyright (C) 1997-2004, 2006, 2008, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Paul Eggert. + +# Define HAVE_STDINT_H_WITH_UINTMAX if exists, +# doesn't clash with , and declares uintmax_t. + +AC_DEFUN([gl_AC_HEADER_STDINT_H], +[ + AC_CACHE_CHECK([for stdint.h], [gl_cv_header_stdint_h], + [AC_TRY_COMPILE( + [#include +#include ], + [uintmax_t i = (uintmax_t) -1; return !i;], + [gl_cv_header_stdint_h=yes], + [gl_cv_header_stdint_h=no])]) + if test $gl_cv_header_stdint_h = yes; then + AC_DEFINE_UNQUOTED([HAVE_STDINT_H_WITH_UINTMAX], [1], + [Define if exists, doesn't clash with , + and declares uintmax_t. ]) + fi +]) diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4 new file mode 100644 index 000000000..fcbe68f6b --- /dev/null +++ b/m4/stdio_h.m4 @@ -0,0 +1,136 @@ +# stdio_h.m4 serial 16 +dnl Copyright (C) 2007-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_STDIO_H], +[ + AC_REQUIRE([gl_STDIO_H_DEFAULTS]) + gl_CHECK_NEXT_HEADERS([stdio.h]) + dnl No need to create extra modules for these functions. Everyone who uses + dnl likely needs them. + GNULIB_FPRINTF=1 + GNULIB_PRINTF=1 + GNULIB_VFPRINTF=1 + GNULIB_VPRINTF=1 + GNULIB_FPUTC=1 + GNULIB_PUTC=1 + GNULIB_PUTCHAR=1 + GNULIB_FPUTS=1 + GNULIB_PUTS=1 + GNULIB_FWRITE=1 + dnl This ifdef is just an optimization, to avoid performing a configure + dnl check whose result is not used. It does not make the test of + dnl GNULIB_STDIO_H_SIGPIPE or GNULIB_SIGPIPE redundant. + m4_ifdef([gl_SIGNAL_SIGPIPE], [ + gl_SIGNAL_SIGPIPE + if test $gl_cv_header_signal_h_SIGPIPE != yes; then + REPLACE_STDIO_WRITE_FUNCS=1 + AC_LIBOBJ([stdio-write]) + fi + ]) +]) + +AC_DEFUN([gl_STDIO_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_STDIO_H_DEFAULTS]) + GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1 +]) + +AC_DEFUN([gl_STDIO_H_DEFAULTS], +[ + GNULIB_FPRINTF=0; AC_SUBST([GNULIB_FPRINTF]) + GNULIB_FPRINTF_POSIX=0; AC_SUBST([GNULIB_FPRINTF_POSIX]) + GNULIB_PRINTF=0; AC_SUBST([GNULIB_PRINTF]) + GNULIB_PRINTF_POSIX=0; AC_SUBST([GNULIB_PRINTF_POSIX]) + GNULIB_SNPRINTF=0; AC_SUBST([GNULIB_SNPRINTF]) + GNULIB_SPRINTF_POSIX=0; AC_SUBST([GNULIB_SPRINTF_POSIX]) + GNULIB_VFPRINTF=0; AC_SUBST([GNULIB_VFPRINTF]) + GNULIB_VFPRINTF_POSIX=0; AC_SUBST([GNULIB_VFPRINTF_POSIX]) + GNULIB_VPRINTF=0; AC_SUBST([GNULIB_VPRINTF]) + GNULIB_VPRINTF_POSIX=0; AC_SUBST([GNULIB_VPRINTF_POSIX]) + GNULIB_VSNPRINTF=0; AC_SUBST([GNULIB_VSNPRINTF]) + GNULIB_VSPRINTF_POSIX=0; AC_SUBST([GNULIB_VSPRINTF_POSIX]) + GNULIB_DPRINTF=0; AC_SUBST([GNULIB_DPRINTF]) + GNULIB_VDPRINTF=0; AC_SUBST([GNULIB_VDPRINTF]) + GNULIB_VASPRINTF=0; AC_SUBST([GNULIB_VASPRINTF]) + GNULIB_OBSTACK_PRINTF=0; AC_SUBST([GNULIB_OBSTACK_PRINTF]) + GNULIB_OBSTACK_PRINTF_POSIX=0; AC_SUBST([GNULIB_OBSTACK_PRINTF_POSIX]) + GNULIB_FOPEN=0; AC_SUBST([GNULIB_FOPEN]) + GNULIB_FREOPEN=0; AC_SUBST([GNULIB_FREOPEN]) + GNULIB_FSEEK=0; AC_SUBST([GNULIB_FSEEK]) + GNULIB_FSEEKO=0; AC_SUBST([GNULIB_FSEEKO]) + GNULIB_FTELL=0; AC_SUBST([GNULIB_FTELL]) + GNULIB_FTELLO=0; AC_SUBST([GNULIB_FTELLO]) + GNULIB_FFLUSH=0; AC_SUBST([GNULIB_FFLUSH]) + GNULIB_FPURGE=0; AC_SUBST([GNULIB_FPURGE]) + GNULIB_FCLOSE=0; AC_SUBST([GNULIB_FCLOSE]) + GNULIB_FPUTC=0; AC_SUBST([GNULIB_FPUTC]) + GNULIB_PUTC=0; AC_SUBST([GNULIB_PUTC]) + GNULIB_PUTCHAR=0; AC_SUBST([GNULIB_PUTCHAR]) + GNULIB_FPUTS=0; AC_SUBST([GNULIB_FPUTS]) + GNULIB_PUTS=0; AC_SUBST([GNULIB_PUTS]) + GNULIB_FWRITE=0; AC_SUBST([GNULIB_FWRITE]) + GNULIB_GETDELIM=0; AC_SUBST([GNULIB_GETDELIM]) + GNULIB_GETLINE=0; AC_SUBST([GNULIB_GETLINE]) + GNULIB_PERROR=0; AC_SUBST([GNULIB_PERROR]) + GNULIB_STDIO_H_SIGPIPE=0; AC_SUBST([GNULIB_STDIO_H_SIGPIPE]) + dnl Assume proper GNU behavior unless another module says otherwise. + REPLACE_STDIO_WRITE_FUNCS=0; AC_SUBST([REPLACE_STDIO_WRITE_FUNCS]) + REPLACE_FPRINTF=0; AC_SUBST([REPLACE_FPRINTF]) + REPLACE_VFPRINTF=0; AC_SUBST([REPLACE_VFPRINTF]) + REPLACE_PRINTF=0; AC_SUBST([REPLACE_PRINTF]) + REPLACE_VPRINTF=0; AC_SUBST([REPLACE_VPRINTF]) + REPLACE_SNPRINTF=0; AC_SUBST([REPLACE_SNPRINTF]) + HAVE_DECL_SNPRINTF=1; AC_SUBST([HAVE_DECL_SNPRINTF]) + REPLACE_VSNPRINTF=0; AC_SUBST([REPLACE_VSNPRINTF]) + HAVE_DECL_VSNPRINTF=1; AC_SUBST([HAVE_DECL_VSNPRINTF]) + REPLACE_SPRINTF=0; AC_SUBST([REPLACE_SPRINTF]) + REPLACE_VSPRINTF=0; AC_SUBST([REPLACE_VSPRINTF]) + HAVE_DPRINTF=1; AC_SUBST([HAVE_DPRINTF]) + REPLACE_DPRINTF=0; AC_SUBST([REPLACE_DPRINTF]) + HAVE_VDPRINTF=1; AC_SUBST([HAVE_VDPRINTF]) + REPLACE_VDPRINTF=0; AC_SUBST([REPLACE_VDPRINTF]) + HAVE_VASPRINTF=1; AC_SUBST([HAVE_VASPRINTF]) + REPLACE_VASPRINTF=0; AC_SUBST([REPLACE_VASPRINTF]) + HAVE_DECL_OBSTACK_PRINTF=1; AC_SUBST([HAVE_DECL_OBSTACK_PRINTF]) + REPLACE_OBSTACK_PRINTF=0; AC_SUBST([REPLACE_OBSTACK_PRINTF]) + REPLACE_FOPEN=0; AC_SUBST([REPLACE_FOPEN]) + REPLACE_FREOPEN=0; AC_SUBST([REPLACE_FREOPEN]) + HAVE_FSEEKO=1; AC_SUBST([HAVE_FSEEKO]) + REPLACE_FSEEKO=0; AC_SUBST([REPLACE_FSEEKO]) + REPLACE_FSEEK=0; AC_SUBST([REPLACE_FSEEK]) + HAVE_FTELLO=1; AC_SUBST([HAVE_FTELLO]) + REPLACE_FTELLO=0; AC_SUBST([REPLACE_FTELLO]) + REPLACE_FTELL=0; AC_SUBST([REPLACE_FTELL]) + REPLACE_FFLUSH=0; AC_SUBST([REPLACE_FFLUSH]) + REPLACE_FPURGE=0; AC_SUBST([REPLACE_FPURGE]) + HAVE_DECL_FPURGE=1; AC_SUBST([HAVE_DECL_FPURGE]) + REPLACE_FCLOSE=0; AC_SUBST([REPLACE_FCLOSE]) + HAVE_DECL_GETDELIM=1; AC_SUBST([HAVE_DECL_GETDELIM]) + HAVE_DECL_GETLINE=1; AC_SUBST([HAVE_DECL_GETLINE]) + REPLACE_GETLINE=0; AC_SUBST([REPLACE_GETLINE]) + REPLACE_PERROR=0; AC_SUBST([REPLACE_PERROR]) +]) + +dnl Code shared by fseeko and ftello. Determine if large files are supported, +dnl but stdin does not start as a large file by default. +AC_DEFUN([gl_STDIN_LARGE_OFFSET], + [ + AC_CACHE_CHECK([whether stdin defaults to large file offsets], + [gl_cv_var_stdin_large_offset], + [AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], +[[#if defined __SL64 && defined __SCLE /* cygwin */ + /* Cygwin 1.5.24 and earlier fail to put stdin in 64-bit mode, making + fseeko/ftello needlessly fail. This bug was fixed in 1.5.25, and + it is easier to do a version check than building a runtime test. */ +# include +# if CYGWIN_VERSION_DLL_COMBINED < CYGWIN_VERSION_DLL_MAKE_COMBINED (1005, 25) + choke me +# endif +#endif]])], + [gl_cv_var_stdin_large_offset=yes], + [gl_cv_var_stdin_large_offset=no])]) +]) diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4 new file mode 100644 index 000000000..3a1d1e010 --- /dev/null +++ b/m4/vasnprintf.m4 @@ -0,0 +1,276 @@ +# vasnprintf.m4 serial 29 +dnl Copyright (C) 2002-2004, 2006-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_VASNPRINTF], +[ + AC_CHECK_FUNCS_ONCE([vasnprintf]) + if test $ac_cv_func_vasnprintf = no; then + gl_REPLACE_VASNPRINTF + fi +]) + +AC_DEFUN([gl_REPLACE_VASNPRINTF], +[ + AC_CHECK_FUNCS_ONCE([vasnprintf]) + AC_LIBOBJ([vasnprintf]) + AC_LIBOBJ([printf-args]) + AC_LIBOBJ([printf-parse]) + AC_LIBOBJ([asnprintf]) + if test $ac_cv_func_vasnprintf = yes; then + AC_DEFINE([REPLACE_VASNPRINTF], [1], + [Define if vasnprintf exists but is overridden by gnulib.]) + fi + gl_PREREQ_PRINTF_ARGS + gl_PREREQ_PRINTF_PARSE + gl_PREREQ_VASNPRINTF + gl_PREREQ_ASNPRINTF +]) + +# Prequisites of lib/printf-args.h, lib/printf-args.c. +AC_DEFUN([gl_PREREQ_PRINTF_ARGS], +[ + AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) + AC_REQUIRE([gt_TYPE_WCHAR_T]) + AC_REQUIRE([gt_TYPE_WINT_T]) +]) + +# Prequisites of lib/printf-parse.h, lib/printf-parse.c. +AC_DEFUN([gl_PREREQ_PRINTF_PARSE], +[ + AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) + AC_REQUIRE([gt_TYPE_WCHAR_T]) + AC_REQUIRE([gt_TYPE_WINT_T]) + AC_REQUIRE([AC_TYPE_SIZE_T]) + AC_CHECK_TYPE([ptrdiff_t], , + [AC_DEFINE([ptrdiff_t], [long], + [Define as the type of the result of subtracting two pointers, if the system doesn't define it.]) + ]) + AC_REQUIRE([gt_AC_TYPE_INTMAX_T]) +]) + +# Prerequisites of lib/vasnprintf.c. +AC_DEFUN_ONCE([gl_PREREQ_VASNPRINTF], +[ + AC_REQUIRE([AC_FUNC_ALLOCA]) + AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) + AC_REQUIRE([gt_TYPE_WCHAR_T]) + AC_REQUIRE([gt_TYPE_WINT_T]) + AC_CHECK_FUNCS([snprintf strnlen wcslen wcsnlen mbrtowc wcrtomb]) + dnl Use the _snprintf function only if it is declared (because on NetBSD it + dnl is defined as a weak alias of snprintf; we prefer to use the latter). + AC_CHECK_DECLS([_snprintf], , , [#include ]) +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting 'long double' +# arguments. +AC_DEFUN_ONCE([gl_PREREQ_VASNPRINTF_LONG_DOUBLE], +[ + AC_REQUIRE([gl_PRINTF_LONG_DOUBLE]) + case "$gl_cv_func_printf_long_double" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_LONG_DOUBLE], [1], + [Define if the vasnprintf implementation needs special code for + 'long double' arguments.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting infinite 'double' +# arguments. +AC_DEFUN([gl_PREREQ_VASNPRINTF_INFINITE_DOUBLE], +[ + AC_REQUIRE([gl_PRINTF_INFINITE]) + case "$gl_cv_func_printf_infinite" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_INFINITE_DOUBLE], [1], + [Define if the vasnprintf implementation needs special code for + infinite 'double' arguments.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting infinite 'long double' +# arguments. +AC_DEFUN([gl_PREREQ_VASNPRINTF_INFINITE_LONG_DOUBLE], +[ + AC_REQUIRE([gl_PRINTF_INFINITE_LONG_DOUBLE]) + dnl There is no need to set NEED_PRINTF_INFINITE_LONG_DOUBLE if + dnl NEED_PRINTF_LONG_DOUBLE is already set. + AC_REQUIRE([gl_PREREQ_VASNPRINTF_LONG_DOUBLE]) + case "$gl_cv_func_printf_long_double" in + *yes) + case "$gl_cv_func_printf_infinite_long_double" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_INFINITE_LONG_DOUBLE], [1], + [Define if the vasnprintf implementation needs special code for + infinite 'long double' arguments.]) + ;; + esac + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting the 'a' directive. +AC_DEFUN([gl_PREREQ_VASNPRINTF_DIRECTIVE_A], +[ + AC_REQUIRE([gl_PRINTF_DIRECTIVE_A]) + case "$gl_cv_func_printf_directive_a" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_DIRECTIVE_A], [1], + [Define if the vasnprintf implementation needs special code for + the 'a' and 'A' directives.]) + AC_CHECK_FUNCS([nl_langinfo]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting the 'F' directive. +AC_DEFUN([gl_PREREQ_VASNPRINTF_DIRECTIVE_F], +[ + AC_REQUIRE([gl_PRINTF_DIRECTIVE_F]) + case "$gl_cv_func_printf_directive_f" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_DIRECTIVE_F], [1], + [Define if the vasnprintf implementation needs special code for + the 'F' directive.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting the 'ls' directive. +AC_DEFUN([gl_PREREQ_VASNPRINTF_DIRECTIVE_LS], +[ + AC_REQUIRE([gl_PRINTF_DIRECTIVE_LS]) + case "$gl_cv_func_printf_directive_ls" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_DIRECTIVE_LS], [1], + [Define if the vasnprintf implementation needs special code for + the 'ls' directive.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting the ' flag. +AC_DEFUN([gl_PREREQ_VASNPRINTF_FLAG_GROUPING], +[ + AC_REQUIRE([gl_PRINTF_FLAG_GROUPING]) + case "$gl_cv_func_printf_flag_grouping" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_FLAG_GROUPING], [1], + [Define if the vasnprintf implementation needs special code for the + ' flag.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting the '-' flag. +AC_DEFUN([gl_PREREQ_VASNPRINTF_FLAG_LEFTADJUST], +[ + AC_REQUIRE([gl_PRINTF_FLAG_LEFTADJUST]) + case "$gl_cv_func_printf_flag_leftadjust" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_FLAG_LEFTADJUST], [1], + [Define if the vasnprintf implementation needs special code for the + '-' flag.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting the 0 flag. +AC_DEFUN([gl_PREREQ_VASNPRINTF_FLAG_ZERO], +[ + AC_REQUIRE([gl_PRINTF_FLAG_ZERO]) + case "$gl_cv_func_printf_flag_zero" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_FLAG_ZERO], [1], + [Define if the vasnprintf implementation needs special code for the + 0 flag.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for supporting large precisions. +AC_DEFUN([gl_PREREQ_VASNPRINTF_PRECISION], +[ + AC_REQUIRE([gl_PRINTF_PRECISION]) + case "$gl_cv_func_printf_precision" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_UNBOUNDED_PRECISION], [1], + [Define if the vasnprintf implementation needs special code for + supporting large precisions without arbitrary bounds.]) + AC_DEFINE([NEED_PRINTF_DOUBLE], [1], + [Define if the vasnprintf implementation needs special code for + 'double' arguments.]) + AC_DEFINE([NEED_PRINTF_LONG_DOUBLE], [1], + [Define if the vasnprintf implementation needs special code for + 'long double' arguments.]) + ;; + esac +]) + +# Extra prerequisites of lib/vasnprintf.c for surviving out-of-memory +# conditions. +AC_DEFUN([gl_PREREQ_VASNPRINTF_ENOMEM], +[ + AC_REQUIRE([gl_PRINTF_ENOMEM]) + case "$gl_cv_func_printf_enomem" in + *yes) + ;; + *) + AC_DEFINE([NEED_PRINTF_ENOMEM], [1], + [Define if the vasnprintf implementation needs special code for + surviving out-of-memory conditions.]) + AC_DEFINE([NEED_PRINTF_DOUBLE], [1], + [Define if the vasnprintf implementation needs special code for + 'double' arguments.]) + AC_DEFINE([NEED_PRINTF_LONG_DOUBLE], [1], + [Define if the vasnprintf implementation needs special code for + 'long double' arguments.]) + ;; + esac +]) + +# Prerequisites of lib/vasnprintf.c including all extras for POSIX compliance. +AC_DEFUN([gl_PREREQ_VASNPRINTF_WITH_EXTRAS], +[ + AC_REQUIRE([gl_PREREQ_VASNPRINTF]) + gl_PREREQ_VASNPRINTF_LONG_DOUBLE + gl_PREREQ_VASNPRINTF_INFINITE_DOUBLE + gl_PREREQ_VASNPRINTF_INFINITE_LONG_DOUBLE + gl_PREREQ_VASNPRINTF_DIRECTIVE_A + gl_PREREQ_VASNPRINTF_DIRECTIVE_F + gl_PREREQ_VASNPRINTF_DIRECTIVE_LS + gl_PREREQ_VASNPRINTF_FLAG_GROUPING + gl_PREREQ_VASNPRINTF_FLAG_LEFTADJUST + gl_PREREQ_VASNPRINTF_FLAG_ZERO + gl_PREREQ_VASNPRINTF_PRECISION + gl_PREREQ_VASNPRINTF_ENOMEM +]) + +# Prerequisites of lib/asnprintf.c. +AC_DEFUN([gl_PREREQ_ASNPRINTF], +[ +]) diff --git a/m4/vsnprintf.m4 b/m4/vsnprintf.m4 new file mode 100644 index 000000000..3b37d460b --- /dev/null +++ b/m4/vsnprintf.m4 @@ -0,0 +1,40 @@ +# vsnprintf.m4 serial 5 +dnl Copyright (C) 2002-2004, 2007-2008 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_VSNPRINTF], +[ + AC_REQUIRE([gl_STDIO_H_DEFAULTS]) + gl_cv_func_vsnprintf_usable=no + AC_CHECK_FUNCS([vsnprintf]) + if test $ac_cv_func_vsnprintf = yes; then + gl_SNPRINTF_SIZE1 + case "$gl_cv_func_snprintf_size1" in + *yes) + gl_cv_func_vsnprintf_usable=yes + ;; + esac + fi + if test $gl_cv_func_vsnprintf_usable = no; then + gl_REPLACE_VSNPRINTF + fi + AC_CHECK_DECLS_ONCE([vsnprintf]) + if test $ac_cv_have_decl_vsnprintf = no; then + HAVE_DECL_VSNPRINTF=0 + fi +]) + +AC_DEFUN([gl_REPLACE_VSNPRINTF], +[ + AC_REQUIRE([gl_STDIO_H_DEFAULTS]) + AC_LIBOBJ([vsnprintf]) + if test $ac_cv_func_vsnprintf = yes; then + REPLACE_VSNPRINTF=1 + fi + gl_PREREQ_VSNPRINTF +]) + +# Prerequisites of lib/vsnprintf.c. +AC_DEFUN([gl_PREREQ_VSNPRINTF], [:]) diff --git a/m4/wchar_t.m4 b/m4/wchar_t.m4 new file mode 100644 index 000000000..fb27a7f65 --- /dev/null +++ b/m4/wchar_t.m4 @@ -0,0 +1,20 @@ +# wchar_t.m4 serial 3 (gettext-0.18) +dnl Copyright (C) 2002-2003, 2008, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Bruno Haible. +dnl Test whether has the 'wchar_t' type. +dnl Prerequisite: AC_PROG_CC + +AC_DEFUN([gt_TYPE_WCHAR_T], +[ + AC_CACHE_CHECK([for wchar_t], [gt_cv_c_wchar_t], + [AC_TRY_COMPILE([#include + wchar_t foo = (wchar_t)'\0';], , + [gt_cv_c_wchar_t=yes], [gt_cv_c_wchar_t=no])]) + if test $gt_cv_c_wchar_t = yes; then + AC_DEFINE([HAVE_WCHAR_T], [1], [Define if you have the 'wchar_t' type.]) + fi +]) diff --git a/m4/xsize.m4 b/m4/xsize.m4 new file mode 100644 index 000000000..631893cf5 --- /dev/null +++ b/m4/xsize.m4 @@ -0,0 +1,13 @@ +# xsize.m4 serial 4 +dnl Copyright (C) 2003-2004, 2008 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_XSIZE], +[ + dnl Prerequisites of lib/xsize.h. + AC_REQUIRE([gl_SIZE_MAX]) + AC_REQUIRE([AC_C_INLINE]) + AC_CHECK_HEADERS([stdint.h]) +]) From 44362a1086b778efb47b7c64a8ed38db5f82d0ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 14 Jul 2009 16:07:13 +0200 Subject: [PATCH 279/375] Fix tests that assumed little endian. * test-suite/tests/asm-to-bytecode.test (u32->u8-list): New procedure. ("compiler")[(load-program 3 2 1 0 () 3 #f (make-int8 3) (return)), (load-program 3 2 1 0 () 3 (load-program 3 2 1 0 ...))]: Make these tests work on hosts whose endianness is not little endian. --- test-suite/tests/asm-to-bytecode.test | 43 +++++++++++++++++++-------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 1c2a5994b..01ba84687 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -15,6 +15,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite tests asm-to-bytecode) + #:use-module (rnrs bytevector) #:use-module (test-suite lib) #:use-module (system vm instruction) #:use-module (language assembly compile-bytecode)) @@ -45,6 +46,14 @@ (lambda () (equal? v y))))) +(define (u32->u8-list x) + ;; Return a 4 uint8 list corresponding to the host's native representation + ;; of X, a uint32. + (let ((bv (make-bytevector 4))) + (bytevector-u32-native-set! bv 0 x) + (bytevector->u8-list bv))) + + (with-test-prefix "compiler" (with-test-prefix "asm-to-bytecode" @@ -75,22 +84,30 @@ (comp-test '(load-keyword "qux") (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u) (char->integer #\x))) - - ;; fixme: little-endian test. - (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return)) - (vector 'load-program 3 2 1 0 3 0 0 0 0 0 0 0 - (instruction->opcode 'make-int8) 3 - (instruction->opcode 'return))) - ;; fixme: little-endian test. + (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return)) + (list->vector + `(load-program + 3 2 1 0 ;; nargs, nrest, nlocs, nexts + ,@(u32->u8-list 3) ;; len + ,@(u32->u8-list 0) ;; metalen + make-int8 3 + return))) + (comp-test '(load-program 3 2 1 0 () 3 (load-program 3 2 1 0 () 3 #f (make-int8 3) (return)) (make-int8 3) (return)) - (vector 'load-program 3 2 1 0 3 0 0 0 (+ 3 12) 0 0 0 - (instruction->opcode 'make-int8) 3 - (instruction->opcode 'return) - 3 2 1 0 3 0 0 0 0 0 0 0 - (instruction->opcode 'make-int8) 3 - (instruction->opcode 'return))))) + (list->vector + `(load-program + 3 2 1 0 ;; nargs, nrest, nlocs, nexts + ,@(u32->u8-list 3) ;; len + ,@(u32->u8-list (+ 3 12)) ;; metalen + make-int8 3 + return + 3 2 1 0 ;; nargs, nrest, nlocs, nexts + ,@(u32->u8-list 3) ;; len + ,@(u32->u8-list 0) ;; metalen + make-int8 3 + return))))) From d10c572e38a888e4f999c7f3229781e53b9a74ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 14 Jul 2009 17:12:04 +0200 Subject: [PATCH 280/375] Remove potential "uninitialized variable" GCC warnings. * libguile/vm-i-scheme.c (vector_ref, vector_set, BV_FIXABLE_INT_REF, BV_INT_REF, BV_FLOAT_REF, BV_FIXABLE_INT_SET, BV_INT_SET, BV_FLOAT_SET): Explicitly initialize all locals, to make some versions of GCC happier. Patch by Dale P. Smith . --- libguile/vm-i-scheme.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 5de39a23d..7fd35e7b2 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -281,7 +281,7 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) { - long i; + long i = 0; ARGS2 (vect, idx); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect) && SCM_I_INUMP (idx) @@ -294,7 +294,7 @@ VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0) { - long i; + long i = 0; SCM vect, idx, val; POP (val); POP (idx); POP (vect); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect) @@ -346,7 +346,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \ { \ - long i; \ + long i = 0; \ ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ @@ -361,7 +361,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) #define BV_INT_REF(stem, type, size) \ { \ - long i; \ + long i = 0; \ ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ @@ -380,7 +380,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) #define BV_FLOAT_REF(stem, fn_stem, type, size) \ { \ - long i; \ + long i = 0; \ ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ @@ -454,7 +454,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \ { \ - long i, j; \ + long i = 0, j = 0; \ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ @@ -472,7 +472,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) #define BV_INT_SET(stem, type, size) \ { \ - long i; \ + long i = 0; \ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ @@ -487,7 +487,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) #define BV_FLOAT_SET(stem, fn_stem, type, size) \ { \ - long i; \ + long i = 0; \ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ From cec1d4e33f1485985df9877330729c964f38cc2f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Jul 2009 17:43:07 +0200 Subject: [PATCH 281/375] fix bounds checks for the last element of bv-*-{ref,set} * libguile/vm-i-scheme.c (BV_FIXABLE_INT_REF, BV_INT_REF): (BV_FLOAT_REF, BV_FIXABLE_INT_SET, BV_INT_SET, BV_FLOAT_SET): Fix the bounds check for the last element. --- libguile/vm-i-scheme.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 7fd35e7b2..42f8bac35 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -351,7 +351,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && ((i = SCM_I_INUM (idx)) >= 0) \ - && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \ (SCM_BYTEVECTOR_CONTENTS (bv) + i))); \ @@ -365,8 +365,8 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_I_INUM (idx)) >= 0) \ - && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ + && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ { scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \ if (SCM_FIXABLE (x)) \ @@ -385,7 +385,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && ((i = SCM_I_INUM (idx)) >= 0) \ - && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \ else \ @@ -459,7 +459,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && ((i = SCM_I_INUM (idx)) >= 0) \ - && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0) \ && (SCM_I_INUMP (val)) \ && ((j = SCM_I_INUM (val)) >= min) \ @@ -477,7 +477,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && ((i = SCM_I_INUM (idx)) >= 0) \ - && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_##type (val); \ else \ @@ -492,7 +492,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && ((i = SCM_I_INUM (idx)) >= 0) \ - && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ + && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val); \ else \ From ad47e35939ef86a031af68d5875de4180f2517cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Jul 2009 17:46:23 +0200 Subject: [PATCH 282/375] fix race in which some instruction name symbols could go unmarked * libguile/instructions.c: In loops, replace scm_op_last with SCM_VM_NUM_INSTRUCTIONS. (fetch_instruction_table): Protect the instruction symbols from collection. Before they were only marked by the name->opcode hash table, leading to races in which they could be collected. (scm_lookup_instruction_by_name): Protect the hash table earlier, as it's not actually a stack variable, since it's static. --- libguile/instructions.c | 17 +++++++++-------- libguile/instructions.h | 1 - 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/libguile/instructions.c b/libguile/instructions.c index 8e6d16993..04180e5e3 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -53,7 +53,7 @@ fetch_instruction_table () if (SCM_UNLIKELY (!table)) { - size_t bytes = scm_op_last * sizeof(struct scm_instruction); + size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction); int i; table = malloc (bytes); memset (table, 0, bytes); @@ -63,11 +63,12 @@ fetch_instruction_table () #include #include #undef VM_INSTRUCTION_TO_TABLE - for (i = 0; i < scm_op_last; i++) + for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) { table[i].opcode = i; if (table[i].name) - table[i].symname = scm_from_locale_symbol (table[i].name); + table[i].symname = + scm_permanent_object (scm_from_locale_symbol (table[i].name)); else table[i].symname = SCM_BOOL_F; } @@ -85,12 +86,12 @@ scm_lookup_instruction_by_name (SCM name) if (SCM_UNLIKELY (SCM_FALSEP (instructions_by_name))) { int i; - instructions_by_name = scm_make_hash_table (SCM_I_MAKINUM (scm_op_last)); - for (i = 0; i < scm_op_last; i++) + instructions_by_name = scm_permanent_object + (scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS))); + for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) if (scm_is_true (table[i].symname)) scm_hashq_set_x (instructions_by_name, table[i].symname, SCM_I_MAKINUM (i)); - instructions_by_name = scm_permanent_object (instructions_by_name); } op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED); @@ -111,7 +112,7 @@ SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, SCM list = SCM_EOL; int i; struct scm_instruction *ip = fetch_instruction_table (); - for (i = 0; i < scm_op_last; i++) + for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) if (ip[i].name) list = scm_cons (ip[i].symname, list); return scm_reverse_x (list, SCM_EOL); @@ -182,7 +183,7 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0, SCM_MAKE_VALIDATE (1, op, I_INUMP); opcode = SCM_I_INUM (op); - if (opcode < scm_op_last) + if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS) ret = fetch_instruction_table ()[opcode].symname; if (scm_is_false (ret)) diff --git a/libguile/instructions.h b/libguile/instructions.h index d081b3efb..a2263228f 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -31,7 +31,6 @@ enum scm_opcode { #include #include #undef VM_INSTRUCTION_TO_OPCODE - scm_op_last = SCM_VM_NUM_INSTRUCTIONS }; SCM_API SCM scm_instruction_list (void); From ef283979cf2fe9aca3854da0aae2cf7db4d86418 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Jul 2009 17:46:23 +0200 Subject: [PATCH 283/375] NEWS has info on 1.9.N to 1.9.N+1 in addition to 1.8 to 2.0 * NEWS: Update to have an incremental section in addition to a comprehensive 1.8->2.0 section. --- NEWS | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 36d36cbd5..4b3d3df53 100644 --- a/NEWS +++ b/NEWS @@ -5,7 +5,17 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. -Changes in 1.9.0 (changes since the 1.8.x series): +(During the 1.9 series, we will keep an incremental NEWS for the latest +prerelease, and a full NEWS corresponding to 1.8 -> 2.0.) + +Changes in 1.9.1 (since the 1.9.0 prerelease): + +** `scm_set_port_seek' and `scm_set_port_truncate' use the `scm_t_off' type + +Previously they would use the `off_t' type, which is fragile since its +definition depends on the application's value for `_FILE_OFFSET_BITS'. + +Changes in 1.9.x (since the 1.8.x series): * New modules (see the manual for details) From 19fef497f09c7ddd9e91e3da2e86bcdfb7f303d0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Jul 2009 22:55:35 +0200 Subject: [PATCH 284/375] update NEWS * NEWS: Update. --- NEWS | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 70 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 4b3d3df53..52092c033 100644 --- a/NEWS +++ b/NEWS @@ -15,6 +15,65 @@ Changes in 1.9.1 (since the 1.9.0 prerelease): Previously they would use the `off_t' type, which is fragile since its definition depends on the application's value for `_FILE_OFFSET_BITS'. +** Automatically compiled files will be placed in ~/.cache, not ~/.guile-ccache. + +Actually, they will be placed in $XDG_CACHE_HOME/guile/ccache/1.9, +defaulting to XDG_CACHE_HOME=~/.cache. Users may remove their +~/.guile-ccache directories. + +** New language: Brainfuck. + +Brainfuck is a toy language that closely models Turing machines. Guile's +brainfuck compiler is meant to be an example of implementing other +languages. See the manual for details, or +http://en.wikipedia.org/wiki/Brainfuck for more information about the +Brainfuck language itself. + +** A number of Scheme files were corrected to be LGPLv3+. + +Some Scheme files imported for the compiler were erroneously labeled as +being LGPLv2+ or GPLv2+. This oversight has been fixed. + +** Bytevectors may now be accessed with a C-friendly API. + +New functions: `scm_is_bytevector ()', `scm_c_bytevector_length ()', +`scm_c_bytevector_length ()', and `scm_c_bytevector_set_x ()'. See the +manual for details. + +** Bytevectors are now accessible using the generalized-vector API. + +As a side effect, this change allows compilation of literal bytevectors +(`#vu8(...)'). + +** Meta-commands to the REPL work better with strange languages. + +Specifically, meta-commands that take expressions as arguments will use +the current language's reader to read those expressions, which may span +multiple lines, with readline integration if the user has that enabled. + +** The object code file format has changed. + +The objcode loader will complain about a "bad header cookie" if it +happens to find an old file. The workaround for that is currently to +find all stale .go files and remove them. This is likely to affect users +who have checked out Guile's git repository, not those that build from +tarballs. + +** Vector access has been sped up considerably. + +Guile's virtual machine now has vector and bytevector operations. Using +Guile to process large amounts of data is now easier. This is because +`vector-ref' and `vector-set!' now have fast opcodes. In addition, there +are opcodes for `ref' and `set' operations on bytevectors for everything +from 8-bit integers to 64-bit floating-point values. + +In the next release, we hope to extend this speedup to other kinds of +uniform vectors. + +** And of course, the usual collection of bugfixes. + +Interested users should see the ChangeLog for more information. + Changes in 1.9.x (since the 1.8.x series): * New modules (see the manual for details) @@ -76,9 +135,9 @@ modification times; if the .scm or .go files are moved after installation, care should be taken to preserve their original timestamps. -Autocompiled files will be stored in the user's ~/.guile-ccache -directory, which will be created if needed. This is analogous to -ccache's behavior for C files. +Autocompiled files will be stored in the $XDG_CACHE_HOME/guile/ccache +directory, where $XDG_CACHE_HOME defaults to ~/.cache. This directory +will be created if needed. To inhibit autocompilation, set the GUILE_AUTO_COMPILE environment variable to 0, or pass --no-autocompile on the Guile command line. @@ -133,6 +192,14 @@ ECMAScript. The goal is to support all of version 3.1 of the standard, but not all of the libraries are there yet. This support is not yet documented; ask on the mailing list if you are interested. +** New language: Brainfuck + +Brainfuck is a toy language that closely models Turing machines. Guile's +brainfuck compiler is meant to be an example of implementing other +languages. See the manual for details, or +http://en.wikipedia.org/wiki/Brainfuck for more information about the +Brainfuck language itself. + ** Defmacros may now have docstrings. Indeed, any macro may have a docstring. `object-documentation' from From ba4c43dc3b6c4bb3b65883283e00228df6029371 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 00:32:05 +0200 Subject: [PATCH 285/375] Remove the `long_long' and `ulong_long' types. * libguile/gen-scmconfig.c (main): Don't emit typedefs for `long_long' and `ulong_long'. This was already deprecated in 1.8 and known to cause conflicts with other libraries such as HDF5, as reported by Mark Patterson (http://lists.gnu.org/archive/html/bug-guile/2009-02/msg00003.html). --- NEWS | 4 ++++ libguile/gen-scmconfig.c | 15 --------------- 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index 52092c033..445bb1cb5 100644 --- a/NEWS +++ b/NEWS @@ -70,6 +70,8 @@ from 8-bit integers to 64-bit floating-point values. In the next release, we hope to extend this speedup to other kinds of uniform vectors. +** The `long_long' C type, deprecated in 1.8, has been removed. + ** And of course, the usual collection of bugfixes. Interested users should see the ChangeLog for more information. @@ -593,6 +595,8 @@ This procedure corresponds to Scheme's `module-public-interface'. Previously they would use the `off_t' type, which is fragile since its definition depends on the application's value for `_FILE_OFFSET_BITS'. +** The `long_long' C type, deprecated in 1.8, has been removed + * Changes to the distribution ** Guile's license is now LGPLv3+ diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 98fcc885e..d5696381b 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -279,21 +279,6 @@ main (int argc, char *argv[]) pf ("#define SCM_SIZEOF_LONG_LONG %d\n", SIZEOF_LONG_LONG); pf ("#define SCM_SIZEOF_UNSIGNED_LONG_LONG %d\n", SIZEOF_UNSIGNED_LONG_LONG); - pf("\n"); - pf("/* handling for the deprecated long_long and ulong_long types */\n"); - pf("/* If anything suitable is available, it'll be defined here. */\n"); - pf("#if (SCM_ENABLE_DEPRECATED == 1)\n"); - if (SIZEOF_LONG_LONG != 0) - pf ("typedef long long long_long;\n"); - else if (SIZEOF___INT64 != 0) - pf ("typedef __int64 long_long;\n"); - - if (SIZEOF_UNSIGNED_LONG_LONG != 0) - pf ("typedef unsigned long long ulong_long;\n"); - else if (SIZEOF_UNSIGNED___INT64 != 0) - pf ("typedef unsigned __int64 ulong_long;\n"); - pf("#endif /* SCM_ENABLE_DEPRECATED == 1 */\n"); - pf ("\n"); pf ("/* These are always defined. */\n"); pf ("typedef %s scm_t_int8;\n", SCM_I_GSC_T_INT8); From 9e1a18db9fd34a6156007c7db563f46095989b62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 00:55:33 +0200 Subject: [PATCH 286/375] Augment `OBJCODE_COOKIE' to detect wrong endianness or word size. * libguile/objcodes.c (OBJCODE_ENDIANNESS, _OBJCODE_STRINGIFY, OBJCODE_STRINGIFY, OBJCODE_WORD_SIZE): New macros. (OBJCODE_COOKIE): Use them. The intent is that `.go' files compiled for a different endianness or word size are detected. --- libguile/objcodes.c | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 4f219717a..d5d66952c 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -33,8 +33,22 @@ #include "programs.h" #include "objcodes.h" +/* The endianness marker in objcode. */ +#ifdef WORDS_BIGENDIAN +# define OBJCODE_ENDIANNESS "BE" +#else +# define OBJCODE_ENDIANNESS "LE" +#endif + +#define _OBJCODE_STRINGIFY(x) # x +#define OBJCODE_STRINGIFY(x) _OBJCODE_STRINGIFY (x) + +/* The word size marker in objcode. */ +#define OBJCODE_WORD_SIZE OBJCODE_STRINGIFY (SIZEOF_VOID_P) + /* nb, the length of the header should be a multiple of 8 bytes */ -#define OBJCODE_COOKIE "GOOF-0.6" +#define OBJCODE_COOKIE \ + "GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" /* From 99c7d3caf622b8ed355562359b445396dee1532c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 00:58:01 +0200 Subject: [PATCH 287/375] Explicitly use Gnulib's `verify' module. * m4/gnulib-cache.m4: Add `verify'. --- lib/Makefile.am | 2 +- m4/gnulib-cache.m4 | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Makefile.am b/lib/Makefile.am index 197320eca..424e5906a 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string vsnprintf +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index aad4999e1..7f64af27c 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string vsnprintf +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -41,6 +41,7 @@ gl_MODULES([ strftime striconveh string + verify vsnprintf ]) gl_AVOID([]) From 07f99e1c6a74017f41bdc1355cf8645392f433c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 01:03:35 +0200 Subject: [PATCH 288/375] Make sure at compile-time that `OBJCODE_COOKIE' has the right size. * libguile/objcodes.c: Use `verify' to assert that the size of `OBJCODE_COOKIE' is a multiple of 8. --- libguile/objcodes.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index d5d66952c..c758e939b 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -28,6 +28,8 @@ #include #include +#include + #include "_scm.h" #include "vm-bootstrap.h" #include "programs.h" @@ -46,10 +48,14 @@ /* The word size marker in objcode. */ #define OBJCODE_WORD_SIZE OBJCODE_STRINGIFY (SIZEOF_VOID_P) -/* nb, the length of the header should be a multiple of 8 bytes */ +/* The objcode magic header. */ #define OBJCODE_COOKIE \ "GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" +/* The length of the header must be a multiple of 8 bytes. */ +verify ((sizeof (OBJCODE_COOKIE) & 7) != 0); + + /* * Objcode type From a823e7272e7e2800491704a342c6853bc5d95d4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 01:17:32 +0200 Subject: [PATCH 289/375] Fix typo in the compile-type verification of `OBJCODE_COOKIE'. * libguile/objcodes.c: Fix `sizeof (OBJCODE_COOKIE)' assertion: the trailing 0 must not be taken into account, and multiple of 8 means the 3 LSBs are clear. --- libguile/objcodes.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index c758e939b..038c4c7a1 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -53,7 +53,7 @@ "GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" /* The length of the header must be a multiple of 8 bytes. */ -verify ((sizeof (OBJCODE_COOKIE) & 7) != 0); +verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0); From e1203ea00f033954e385a0f2f6aa8b886778dab1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 22:46:54 +0200 Subject: [PATCH 290/375] Switch remaining GPLv2+ Guile-VM headers to LGPLv3+. * module/system/base/compile.scm, module/system/base/syntax.scm, module/system/repl/common.scm, module/system/repl/describe.scm, module/system/vm/instruction.scm, module/system/vm/objcode.scm, module/system/vm/profile.scm, module/system/vm/program.scm, module/system/vm/trace.scm: Switch header from GPLv2+ to LGPLv3+. --- module/system/base/compile.scm | 27 +++++++++++++-------------- module/system/base/syntax.scm | 27 +++++++++++++-------------- module/system/repl/common.scm | 27 +++++++++++++-------------- module/system/repl/describe.scm | 27 +++++++++++++-------------- module/system/vm/instruction.scm | 27 +++++++++++++-------------- module/system/vm/objcode.scm | 27 +++++++++++++-------------- module/system/vm/profile.scm | 27 +++++++++++++-------------- module/system/vm/program.scm | 21 ++++++++++----------- module/system/vm/trace.scm | 27 +++++++++++++-------------- 9 files changed, 114 insertions(+), 123 deletions(-) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 22f8e04f1..7e26609b9 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index d968bdff8..cc73f38d1 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 1978255f7..2db4518ad 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm index 0563def90..590d2235a 100644 --- a/module/system/repl/describe.scm +++ b/module/system/repl/describe.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm index 3ad718ea8..403e9cdc7 100644 --- a/module/system/vm/instruction.scm +++ b/module/system/vm/instruction.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm index ab6bb4bae..7c0490da6 100644 --- a/module/system/vm/objcode.scm +++ b/module/system/vm/objcode.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm index 2c17fc7a6..6ab418ac3 100644 --- a/module/system/vm/profile.scm +++ b/module/system/vm/profile.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 5a490b9d9..9db4a754b 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -1,21 +1,20 @@ ;;; Guile VM program functions ;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;; Copyright (C) 2005 Ludovic Courtès ;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. ;;; -;;; This program is distributed in the hope that it will be useful, +;;; This library 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. +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 2ba528052..6ff09a779 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: From b67cb2864e0de124bd7c4f9b0fda442329e09f3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 23:12:43 +0200 Subject: [PATCH 291/375] Const-qualify buffers passed to `scm_c_make_objcode_slice ()'. * libguile/objcodes.c (scm_c_make_objcode_slice): Add `const' qualifier for PTR and DATA. * libguile/objcodes.h: Update accordingly. --- libguile/objcodes.c | 4 ++-- libguile/objcodes.h | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 038c4c7a1..69e464c3b 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -120,10 +120,10 @@ make_objcode_by_mmap (int fd) #undef FUNC_NAME SCM -scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr) +scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) #define FUNC_NAME "make-objcode-slice" { - struct scm_objcode *data, *parent_data; + const struct scm_objcode *data, *parent_data; SCM ret; SCM_VALIDATE_OBJCODE (1, parent); diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 21e4add89..e9b1cdbff 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -56,7 +56,7 @@ SCM_API scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_U8VECTOR) #define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE) -SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr); +SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr); SCM_API SCM scm_load_objcode (SCM file); SCM_API SCM scm_objcode_p (SCM obj); SCM_API SCM scm_objcode_meta (SCM objcode); From 5bd047cefa9ffcf17751dbeda1fa56ae56f45199 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 23:51:42 +0200 Subject: [PATCH 292/375] Fix unaligned access in the VM code. * libguile/vm.c (struct t_32bit_aligned): New. (really_make_boot_program)[bytes]: Use it. This fixes possibly unaligned accesses, which cause a "bus error" on some platforms (e.g., sparc-*). --- libguile/vm.c | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/libguile/vm.c b/libguile/vm.c index 514ff8d4e..f753ea251 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -227,21 +227,41 @@ static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len) return scm_take_u8vector (new_bytes, len); } +/* Dummy structure to guarantee 32-bit alignment. */ +struct t_32bit_aligned +{ + scm_t_int32 dummy; + scm_t_uint8 bytes[18]; +}; + static SCM really_make_boot_program (long nargs) { - scm_byte_t bytes[] = {0, 0, 0, 0, - 0, 0, 0, 0, - 0, 0, 0, 0, - scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt}; + SCM u8vec; + struct t_32bit_aligned bytes = + { + .dummy = 0, + .bytes = { 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + scm_op_mv_call, 0, 0, 1, + scm_op_make_int8_1, scm_op_halt } + }; + SCM ret; - ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness, no meta */ + + /* Set length in current endianness, no meta. */ + ((scm_t_uint32 *) bytes.bytes)[1] = 6; + if (SCM_UNLIKELY (nargs > 255 || nargs < 0)) abort (); - bytes[13] = (scm_byte_t)nargs; - ret = scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))), + bytes.bytes[13] = (scm_byte_t) nargs; + + u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes)); + ret = scm_make_program (scm_bytecode_to_objcode (u8vec), SCM_BOOL_F, SCM_EOL); SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT); + return ret; } #define NUM_BOOT_PROGS 8 From ec99fe8ecb412e49e8e981246eb62ca46b32754b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 23:53:22 +0200 Subject: [PATCH 293/375] Add FIXMEs about misaligned objcode-metas. * libguile/objcodes.c (scm_c_make_objcode_slice): Add comment about misaligned `objcode-meta'. * module/language/assembly/compile-bytecode.scm (write-bytecode): Likewise. --- libguile/objcodes.c | 6 ++++++ module/language/assembly/compile-bytecode.scm | 3 +++ 2 files changed, 9 insertions(+) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 69e464c3b..a2105530f 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -138,6 +138,12 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) scm_from_uint32 (parent_data->len), scm_from_uint32 (parent_data->metalen))); +#if 0 + /* FIXME: We currently generate bytecode where the objcode-meta isn't + suitable aligned, which is an issue on some arches (e.g., SPARC). */ + assert ((((uintptr_t) ptr) & (__alignof__ (struct scm_objcode) - 1UL)) == 0); +#endif + data = (struct scm_objcode*)ptr; if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen) abort (); diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 73ed620d6..4b9f7b701 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -110,6 +110,9 @@ (set! i (1+ i)) (if (> i 0) (write-byte x)))) (get-addr (lambda () i))) + ;; FIXME: We should add padding here so that META's bytecode + ;; meets the alignment requirements of `scm_objcode'. See + ;; `scm_c_make_objcode_slice ()'. (write-bytecode meta write get-addr '())))) ((load-unsigned-integer ,str) (write-loader str)) ((load-integer ,str) (write-loader str)) From 10331eac7e3c7b802718af515d17e50dca525b3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 23:56:27 +0200 Subject: [PATCH 294/375] Make the non-integrated VM test-suite less verbose. * testsuite/run-vm-tests.scm (run-vm-tests): Don't display the number of tests passed since it's always 1 or 0. --- testsuite/run-vm-tests.scm | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm index c6c7a5dfe..f7eba40bb 100644 --- a/testsuite/run-vm-tests.scm +++ b/testsuite/run-vm-tests.scm @@ -1,7 +1,6 @@ ;;; run-vm-tests.scm -- Run Guile-VM's test suite. ;;; -;;; Copyright 2005 Ludovic Courtès -;;; +;;; Copyright 2005, 2009 Free Software Foundation, Inc. ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public License @@ -85,9 +84,7 @@ equal in the sense of @var{equal?}." (failed (length (filter not res)))) (if (= 0 failed) - (begin - (format #t "~%All ~a tests passed~%" total) - (exit 0)) + (exit 0) (begin (format #t "~%~a tests failed out of ~a~%" failed total) From 3b0b6bc1dd2eb24405ad8e75889df0874f879892 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 15 Jul 2009 23:57:18 +0200 Subject: [PATCH 295/375] Bump version number for 1.9.1. * GUILE-VERSION (GUILE_MICRO_VERSION): Increment. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index c23f8f6f9..fa96ed95a 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -2,7 +2,7 @@ GUILE_MAJOR_VERSION=1 GUILE_MINOR_VERSION=9 -GUILE_MICRO_VERSION=0 +GUILE_MICRO_VERSION=1 GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION} GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION} From a5cfddd560ca21205c8b0417413253d94f3e9b93 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 19 Jul 2009 19:02:30 +0200 Subject: [PATCH 296/375] renumber vm ops (objcode cookie bumped) * libguile/objcodes.c (OBJCODE_COOKIE): Bump. * libguile/vm-i-loader.c: * libguile/vm-i-scheme.c: * libguile/vm-i-system.c: Renumber instructions, so I can have a bit more space to work. --- libguile/objcodes.c | 2 +- libguile/vm-i-loader.c | 22 ++--- libguile/vm-i-scheme.c | 136 ++++++++++++++--------------- libguile/vm-i-system.c | 191 +++++++++++++++++++++-------------------- 4 files changed, 176 insertions(+), 175 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index a2105530f..5a43edb67 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -50,7 +50,7 @@ /* The objcode magic header. */ #define OBJCODE_COOKIE \ - "GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" + "GOOF-0.7-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" /* The length of the header must be a multiple of 8 bytes. */ verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0); diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 86d0fc443..4edadb37f 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -20,7 +20,7 @@ /* This file is included in vm_engine.c */ -VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer") +VM_DEFINE_LOADER (80, load_unsigned_integer, "load-unsigned-integer") { size_t len; @@ -38,7 +38,7 @@ VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer") SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL); } -VM_DEFINE_LOADER (60, load_integer, "load-integer") +VM_DEFINE_LOADER (81, load_integer, "load-integer") { size_t len; @@ -56,7 +56,7 @@ VM_DEFINE_LOADER (60, load_integer, "load-integer") SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL); } -VM_DEFINE_LOADER (61, load_number, "load-number") +VM_DEFINE_LOADER (82, load_number, "load-number") { size_t len; @@ -69,7 +69,7 @@ VM_DEFINE_LOADER (61, load_number, "load-number") NEXT; } -VM_DEFINE_LOADER (62, load_string, "load-string") +VM_DEFINE_LOADER (83, load_string, "load-string") { size_t len; FETCH_LENGTH (len); @@ -80,7 +80,7 @@ VM_DEFINE_LOADER (62, load_string, "load-string") NEXT; } -VM_DEFINE_LOADER (63, load_symbol, "load-symbol") +VM_DEFINE_LOADER (84, load_symbol, "load-symbol") { size_t len; FETCH_LENGTH (len); @@ -90,7 +90,7 @@ VM_DEFINE_LOADER (63, load_symbol, "load-symbol") NEXT; } -VM_DEFINE_LOADER (64, load_keyword, "load-keyword") +VM_DEFINE_LOADER (85, load_keyword, "load-keyword") { size_t len; FETCH_LENGTH (len); @@ -100,7 +100,7 @@ VM_DEFINE_LOADER (64, load_keyword, "load-keyword") NEXT; } -VM_DEFINE_LOADER (65, load_program, "load-program") +VM_DEFINE_LOADER (86, load_program, "load-program") { scm_t_uint32 len; SCM objs, objcode; @@ -121,7 +121,7 @@ VM_DEFINE_LOADER (65, load_program, "load-program") NEXT; } -VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1) +VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1) { SCM what; POP (what); @@ -130,7 +130,7 @@ VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1) NEXT; } -VM_DEFINE_LOADER (67, define, "define") +VM_DEFINE_LOADER (88, define, "define") { SCM sym; size_t len; @@ -145,7 +145,7 @@ VM_DEFINE_LOADER (67, define, "define") NEXT; } -VM_DEFINE_LOADER (68, load_array, "load-array") +VM_DEFINE_LOADER (89, load_array, "load-array") { SCM type, shape; size_t len; @@ -163,7 +163,7 @@ VM_DEFINE_LOADER (68, load_array, "load-array") "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" (interactive "") (save-excursion - (let ((counter 59)) (goto-char (point-min)) + (let ((counter 79)) (goto-char (point-min)) (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) (replace-match (number-to-string (setq counter (1+ counter))) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 42f8bac35..dce9b5fbc 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -29,43 +29,43 @@ #define RETURN(x) do { *sp = x; NEXT; } while (0) -VM_DEFINE_FUNCTION (80, not, "not", 1) +VM_DEFINE_FUNCTION (100, not, "not", 1) { ARGS1 (x); RETURN (SCM_BOOL (SCM_FALSEP (x))); } -VM_DEFINE_FUNCTION (81, not_not, "not-not", 1) +VM_DEFINE_FUNCTION (101, not_not, "not-not", 1) { ARGS1 (x); RETURN (SCM_BOOL (!SCM_FALSEP (x))); } -VM_DEFINE_FUNCTION (82, eq, "eq?", 2) +VM_DEFINE_FUNCTION (102, eq, "eq?", 2) { ARGS2 (x, y); RETURN (SCM_BOOL (SCM_EQ_P (x, y))); } -VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2) +VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2) { ARGS2 (x, y); RETURN (SCM_BOOL (!SCM_EQ_P (x, y))); } -VM_DEFINE_FUNCTION (84, nullp, "null?", 1) +VM_DEFINE_FUNCTION (104, nullp, "null?", 1) { ARGS1 (x); RETURN (SCM_BOOL (SCM_NULLP (x))); } -VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1) +VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1) { ARGS1 (x); RETURN (SCM_BOOL (!SCM_NULLP (x))); } -VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2) +VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2) { ARGS2 (x, y); if (SCM_EQ_P (x, y)) @@ -76,7 +76,7 @@ VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2) RETURN (scm_eqv_p (x, y)); } -VM_DEFINE_FUNCTION (87, equal, "equal?", 2) +VM_DEFINE_FUNCTION (107, equal, "equal?", 2) { ARGS2 (x, y); if (SCM_EQ_P (x, y)) @@ -87,13 +87,13 @@ VM_DEFINE_FUNCTION (87, equal, "equal?", 2) RETURN (scm_equal_p (x, y)); } -VM_DEFINE_FUNCTION (88, pairp, "pair?", 1) +VM_DEFINE_FUNCTION (108, pairp, "pair?", 1) { ARGS1 (x); RETURN (SCM_BOOL (SCM_CONSP (x))); } -VM_DEFINE_FUNCTION (89, listp, "list?", 1) +VM_DEFINE_FUNCTION (109, listp, "list?", 1) { ARGS1 (x); RETURN (SCM_BOOL (scm_ilength (x) >= 0)); @@ -104,7 +104,7 @@ VM_DEFINE_FUNCTION (89, listp, "list?", 1) * Basic data */ -VM_DEFINE_FUNCTION (90, cons, "cons", 2) +VM_DEFINE_FUNCTION (110, cons, "cons", 2) { ARGS2 (x, y); CONS (x, x, y); @@ -117,21 +117,21 @@ VM_DEFINE_FUNCTION (90, cons, "cons", 2) goto vm_error_not_a_pair; \ } -VM_DEFINE_FUNCTION (91, car, "car", 1) +VM_DEFINE_FUNCTION (111, car, "car", 1) { ARGS1 (x); VM_VALIDATE_CONS (x); RETURN (SCM_CAR (x)); } -VM_DEFINE_FUNCTION (92, cdr, "cdr", 1) +VM_DEFINE_FUNCTION (112, cdr, "cdr", 1) { ARGS1 (x); VM_VALIDATE_CONS (x); RETURN (SCM_CDR (x)); } -VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0) +VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0) { SCM x, y; POP (y); @@ -141,7 +141,7 @@ VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0) NEXT; } -VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0) +VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0) { SCM x, y; POP (y); @@ -166,27 +166,27 @@ VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0) RETURN (srel (x, y)); \ } -VM_DEFINE_FUNCTION (95, ee, "ee?", 2) +VM_DEFINE_FUNCTION (115, ee, "ee?", 2) { REL (==, scm_num_eq_p); } -VM_DEFINE_FUNCTION (96, lt, "lt?", 2) +VM_DEFINE_FUNCTION (116, lt, "lt?", 2) { REL (<, scm_less_p); } -VM_DEFINE_FUNCTION (97, le, "le?", 2) +VM_DEFINE_FUNCTION (117, le, "le?", 2) { REL (<=, scm_leq_p); } -VM_DEFINE_FUNCTION (98, gt, "gt?", 2) +VM_DEFINE_FUNCTION (118, gt, "gt?", 2) { REL (>, scm_gr_p); } -VM_DEFINE_FUNCTION (99, ge, "ge?", 2) +VM_DEFINE_FUNCTION (119, ge, "ge?", 2) { REL (>=, scm_geq_p); } @@ -210,45 +210,45 @@ VM_DEFINE_FUNCTION (99, ge, "ge?", 2) RETURN (SFUNC (x, y)); \ } -VM_DEFINE_FUNCTION (100, add, "add", 2) +VM_DEFINE_FUNCTION (120, add, "add", 2) { FUNC2 (+, scm_sum); } -VM_DEFINE_FUNCTION (101, sub, "sub", 2) +VM_DEFINE_FUNCTION (121, sub, "sub", 2) { FUNC2 (-, scm_difference); } -VM_DEFINE_FUNCTION (102, mul, "mul", 2) +VM_DEFINE_FUNCTION (122, mul, "mul", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_product (x, y)); } -VM_DEFINE_FUNCTION (103, div, "div", 2) +VM_DEFINE_FUNCTION (123, div, "div", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_divide (x, y)); } -VM_DEFINE_FUNCTION (104, quo, "quo", 2) +VM_DEFINE_FUNCTION (124, quo, "quo", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_quotient (x, y)); } -VM_DEFINE_FUNCTION (105, rem, "rem", 2) +VM_DEFINE_FUNCTION (125, rem, "rem", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_remainder (x, y)); } -VM_DEFINE_FUNCTION (106, mod, "mod", 2) +VM_DEFINE_FUNCTION (126, mod, "mod", 2) { ARGS2 (x, y); SYNC_REGISTER (); @@ -259,7 +259,7 @@ VM_DEFINE_FUNCTION (106, mod, "mod", 2) /* * GOOPS support */ -VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2) +VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2) { size_t slot; ARGS2 (instance, idx); @@ -267,7 +267,7 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2) RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); } -VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0) { SCM instance, idx, val; size_t slot; @@ -279,7 +279,7 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) NEXT; } -VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) +VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2) { long i = 0; ARGS2 (vect, idx); @@ -292,7 +292,7 @@ VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) RETURN (scm_vector_ref (vect, idx)); } -VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0) { long i = 0; SCM vect, idx, val; @@ -325,21 +325,21 @@ VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0) } \ } -VM_DEFINE_FUNCTION (111, bv_u16_ref, "bv-u16-ref", 3) +VM_DEFINE_FUNCTION (131, bv_u16_ref, "bv-u16-ref", 3) BV_REF_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (112, bv_s16_ref, "bv-s16-ref", 3) +VM_DEFINE_FUNCTION (132, bv_s16_ref, "bv-s16-ref", 3) BV_REF_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (113, bv_u32_ref, "bv-u32-ref", 3) +VM_DEFINE_FUNCTION (133, bv_u32_ref, "bv-u32-ref", 3) BV_REF_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (114, bv_s32_ref, "bv-s32-ref", 3) +VM_DEFINE_FUNCTION (134, bv_s32_ref, "bv-s32-ref", 3) BV_REF_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (115, bv_u64_ref, "bv-u64-ref", 3) +VM_DEFINE_FUNCTION (135, bv_u64_ref, "bv-u64-ref", 3) BV_REF_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (116, bv_s64_ref, "bv-s64-ref", 3) +VM_DEFINE_FUNCTION (136, bv_s64_ref, "bv-s64-ref", 3) BV_REF_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (117, bv_f32_ref, "bv-f32-ref", 3) +VM_DEFINE_FUNCTION (137, bv_f32_ref, "bv-f32-ref", 3) BV_REF_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (118, bv_f64_ref, "bv-f64-ref", 3) +VM_DEFINE_FUNCTION (138, bv_f64_ref, "bv-f64-ref", 3) BV_REF_WITH_ENDIANNESS (f64, ieee_double) #undef BV_REF_WITH_ENDIANNESS @@ -392,26 +392,26 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \ } -VM_DEFINE_FUNCTION (119, bv_u8_ref, "bv-u8-ref", 2) +VM_DEFINE_FUNCTION (139, bv_u8_ref, "bv-u8-ref", 2) BV_FIXABLE_INT_REF (u8, u8, uint8, 1) -VM_DEFINE_FUNCTION (120, bv_s8_ref, "bv-s8-ref", 2) +VM_DEFINE_FUNCTION (140, bv_s8_ref, "bv-s8-ref", 2) BV_FIXABLE_INT_REF (s8, s8, int8, 1) -VM_DEFINE_FUNCTION (121, bv_u16_native_ref, "bv-u16-native-ref", 2) +VM_DEFINE_FUNCTION (141, bv_u16_native_ref, "bv-u16-native-ref", 2) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) -VM_DEFINE_FUNCTION (122, bv_s16_native_ref, "bv-s16-native-ref", 2) +VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) -VM_DEFINE_FUNCTION (123, bv_u32_native_ref, "bv-u32-native-ref", 2) +VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_REF (u32, uint32, 4) -VM_DEFINE_FUNCTION (124, bv_s32_native_ref, "bv-s32-native-ref", 2) +VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2) BV_INT_REF (s32, int32, 4) -VM_DEFINE_FUNCTION (125, bv_u64_native_ref, "bv-u64-native-ref", 2) +VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2) BV_INT_REF (u64, uint64, 8) -VM_DEFINE_FUNCTION (126, bv_s64_native_ref, "bv-s64-native-ref", 2) +VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2) BV_INT_REF (s64, int64, 8) -VM_DEFINE_FUNCTION (127, bv_f32_native_ref, "bv-f32-native-ref", 2) +VM_DEFINE_FUNCTION (147, bv_f32_native_ref, "bv-f32-native-ref", 2) BV_FLOAT_REF (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (128, bv_f64_native_ref, "bv-f64-native-ref", 2) +VM_DEFINE_FUNCTION (148, bv_f64_native_ref, "bv-f64-native-ref", 2) BV_FLOAT_REF (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_REF @@ -433,21 +433,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8) } \ } -VM_DEFINE_INSTRUCTION (129, bv_u16_set, "bv-u16-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (149, bv_u16_set, "bv-u16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_INSTRUCTION (130, bv_s16_set, "bv-s16-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (150, bv_s16_set, "bv-s16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_INSTRUCTION (131, bv_u32_set, "bv-u32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (151, bv_u32_set, "bv-u32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_INSTRUCTION (132, bv_s32_set, "bv-s32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (152, bv_s32_set, "bv-s32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_INSTRUCTION (133, bv_u64_set, "bv-u64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (153, bv_u64_set, "bv-u64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_INSTRUCTION (134, bv_s64_set, "bv-s64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (154, bv_s64_set, "bv-s64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_INSTRUCTION (135, bv_f32_set, "bv-f32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (155, bv_f32_set, "bv-f32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_INSTRUCTION (136, bv_f64_set, "bv-f64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (156, bv_f64_set, "bv-f64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f64, ieee_double) #undef BV_SET_WITH_ENDIANNESS @@ -500,26 +500,26 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) NEXT; \ } -VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (157, bv_u8_set, "bv-u8-set", 0, 3, 0) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) -VM_DEFINE_INSTRUCTION (138, bv_s8_set, "bv-s8-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (158, bv_s8_set, "bv-s8-set", 0, 3, 0) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) -VM_DEFINE_INSTRUCTION (139, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (159, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2) -VM_DEFINE_INSTRUCTION (140, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2) -VM_DEFINE_INSTRUCTION (141, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_SET (u32, uint32, 4) -VM_DEFINE_INSTRUCTION (142, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) BV_INT_SET (s32, int32, 4) -VM_DEFINE_INSTRUCTION (143, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) BV_INT_SET (u64, uint64, 8) -VM_DEFINE_INSTRUCTION (144, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) BV_INT_SET (s64, int64, 8) -VM_DEFINE_INSTRUCTION (145, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (165, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) BV_FLOAT_SET (f32, ieee_single, float, 4) -VM_DEFINE_INSTRUCTION (146, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (166, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) BV_FLOAT_SET (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_SET @@ -531,7 +531,7 @@ BV_FLOAT_SET (f64, ieee_double, double, 8) "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" (interactive "") (save-excursion - (let ((counter 79)) (goto-char (point-min)) + (let ((counter 99)) (goto-char (point-min)) (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) (replace-match (number-to-string (setq counter (1+ counter))) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index d55d6e218..d884557e1 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -139,7 +139,7 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@ -154,7 +154,7 @@ VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@ -169,13 +169,13 @@ VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (14, make_char8, "make-char8", 1, 0, 1) +VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1) { PUSH (SCM_MAKE_CHAR (FETCH ())); NEXT; } -VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1) +VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@ -184,7 +184,7 @@ VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1) +VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@ -202,19 +202,19 @@ VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (17, list_mark, "list-mark", 0, 0, 0) +VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0) { POP_LIST_MARK (); NEXT; } -VM_DEFINE_INSTRUCTION (18, cons_mark, "cons-mark", 0, 0, 0) +VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0) { POP_CONS_MARK (); NEXT; } -VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0) +VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0) { POP_LIST_MARK (); SYNC_REGISTER (); @@ -222,7 +222,7 @@ VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0) +VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0) { SCM l; POP (l); @@ -250,7 +250,7 @@ VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0) /* ref */ -VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1) { register unsigned objnum = FETCH (); CHECK_OBJECT (objnum); @@ -258,14 +258,25 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) +/* FIXME: necessary? elt 255 of the vector could be a vector... */ +VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1) +{ + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + PUSH (OBJECT_REF (objnum)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); ASSERT_BOUND (*sp); NEXT; } -VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (26, external_ref, "external-ref", 1, 0, 1) { unsigned int i; SCM e = external; @@ -280,7 +291,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1) +VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1) { SCM x = *sp; @@ -299,7 +310,7 @@ VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1) { unsigned objnum = FETCH (); SCM what; @@ -322,16 +333,41 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) +{ + SCM what; + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_REGISTER (); + what = resolve_variable (what, scm_program_module (program)); + if (!VARIABLE_BOUNDP (what)) + { + finish_args = scm_list_1 (what); + goto vm_error_unbound; + } + OBJECT_SET (objnum, what); + } + + PUSH (VARIABLE_REF (what)); + NEXT; +} + /* set */ -VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0) { LOCAL_SET (FETCH (), *sp); DROP (); NEXT; } -VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (31, external_set, "external-set", 1, 1, 0) { unsigned int i; SCM e = external; @@ -346,14 +382,14 @@ VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0) +VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0) { VARIABLE_SET (sp[0], sp[-1]); DROPN (2); NEXT; } -VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0) { unsigned objnum = FETCH (); SCM what; @@ -372,6 +408,27 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; } +VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0) +{ + SCM what; + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_BEFORE_GC (); + what = resolve_variable (what, scm_program_module (program)); + OBJECT_SET (objnum, what); + } + + VARIABLE_SET (what, *sp); + DROP (); + NEXT; +} + /* * branch and jump @@ -396,7 +453,7 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; \ } -VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0) +VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0) { int h = FETCH (); int l = FETCH (); @@ -404,34 +461,34 @@ VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0) +VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0) { BR (!SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0) +VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0) { BR (SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0) +VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0) { sp--; /* underflow? */ BR (SCM_EQ_P (sp[0], sp[1])); } -VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0) +VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0) { sp--; /* underflow? */ BR (!SCM_EQ_P (sp[0], sp[1])); } -VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0) +VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0) { BR (SCM_NULLP (*sp)); } -VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0) +VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0) { BR (!SCM_NULLP (*sp)); } @@ -441,7 +498,7 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0) * Subprogram call */ -VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1) +VM_DEFINE_INSTRUCTION (42, make_closure, "make-closure", 0, 1, 1) { SYNC_BEFORE_GC (); SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp), @@ -449,7 +506,7 @@ VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1) +VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1) { SCM x; nargs = FETCH (); @@ -570,7 +627,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) +VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1) { register SCM x; nargs = FETCH (); @@ -764,7 +821,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1) { SCM x; POP (x); @@ -773,7 +830,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1) goto vm_goto_args; } -VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1) { SCM x; POP (x); @@ -782,7 +839,7 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1) +VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1) { SCM x; signed short offset; @@ -843,7 +900,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1) { int len; SCM ls; @@ -862,7 +919,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1) { int len; SCM ls; @@ -881,7 +938,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1) goto vm_goto_args; } -VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1) { int first; SCM proc, cont; @@ -915,7 +972,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1) { int first; SCM proc, cont; @@ -947,7 +1004,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1) +VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1) { vm_return: EXIT_HOOK (); @@ -986,7 +1043,7 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1) +VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1) { /* nvalues declared at top level, because for some reason gcc seems to think that perhaps it might be used without declaration. Fooey to that, I say. */ @@ -1047,7 +1104,7 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1) +VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1) { SCM l; @@ -1070,7 +1127,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1) goto vm_return_values; } -VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1) +VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1) { SCM x; int nbinds, rest; @@ -1093,62 +1150,6 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (52, long_object_ref, "long-object-ref", 2, 0, 1) -{ - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - PUSH (OBJECT_REF (objnum)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (53, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) -{ - SCM what; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_REGISTER (); - what = resolve_variable (what, scm_program_module (program)); - if (!VARIABLE_BOUNDP (what)) - { - finish_args = scm_list_1 (what); - goto vm_error_unbound; - } - OBJECT_SET (objnum, what); - } - - PUSH (VARIABLE_REF (what)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (54, long_toplevel_set, "long-toplevel-set", 2, 1, 0) -{ - SCM what; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_BEFORE_GC (); - what = resolve_variable (what, scm_program_module (program)); - OBJECT_SET (objnum, what); - } - - VARIABLE_SET (what, *sp); - DROP (); - NEXT; -} - /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" From 8d90b356560b9cf54300ff9eabf4675acb650e03 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 19 Jul 2009 19:48:26 +0200 Subject: [PATCH 297/375] vm support for display closures * libguile/vm-i-system.c (box, empty-box): Boxing values and storing them in local variables. (local-boxed-ref, local-boxed-set): A combination of local-ref then variable-ref/set. (make-closure2, closure-ref, closure-boxed-ref, closure-boxed-set): New ops. The idea is to migrate Guile over to using flat dispay closures. See the paper "Three Implementation Models for Scheme" by Kent Dybvig for more details; this is the "stack-based" model. * libguile/vm-engine.c: * libguile/vm-engine.h: Add the necessary infrastructure to keep track of a "closure" variable, like our "externals" in semantics, but minimal, flat, and O(1) in implementation. --- libguile/vm-engine.c | 13 ++++++- libguile/vm-engine.h | 30 ++++++++++++++ libguile/vm-i-system.c | 88 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 130 insertions(+), 1 deletion(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 90cf697f8..7a98a8a62 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -23,12 +23,14 @@ #define VM_USE_CLOCK 0 /* Bogoclock */ #define VM_CHECK_EXTERNAL 1 /* Check external link */ #define VM_CHECK_OBJECT 1 /* Check object table */ +#define VM_CHECK_CLOSURE 1 /* Check closure vars */ #define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 #define VM_USE_CLOCK 1 #define VM_CHECK_EXTERNAL 1 #define VM_CHECK_OBJECT 1 +#define VM_CHECK_CLOSURE 1 #define VM_PUSH_DEBUG_FRAMES 1 #else #error unknown debug engine VM_ENGINE @@ -47,7 +49,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* Cache variables */ struct scm_objcode *bp = NULL; /* program base pointer */ - SCM external = SCM_EOL; /* external environment */ + SCM external = SCM_EOL; /* external environment REMOVEME */ + SCM *closure = NULL; /* closure variables */ + size_t closure_count = 0; /* length of CLOSURE */ SCM *objects = NULL; /* constant objects */ size_t object_count = 0; /* length of OBJECTS */ SCM *stack_base = vp->stack_base; /* stack base address */ @@ -240,6 +244,13 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) goto vm_error; #endif +#if VM_CHECK_CLOSURE + vm_error_closure: + err_msg = scm_from_locale_string ("VM: Invalid closure variable access"); + finish_args = SCM_EOL; + goto vm_error; +#endif + vm_error: SYNC_ALL (); diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index d6849799c..a2c1effd3 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -117,6 +117,16 @@ vp->fp = fp; \ } +/* FIXME */ +#define ASSERT_VARIABLE(x) \ + do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); } \ + } while (0) +#define ASSERT_BOUND_VARIABLE(x) \ + do { ASSERT_VARIABLE (x); \ + if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED) \ + { SYNC_REGISTER (); abort(); } \ + } while (0) + #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) @@ -145,6 +155,19 @@ object_count = 0; \ } \ } \ + { \ + SCM c = SCM_PROGRAM_EXTERNALS (program); \ + if (SCM_I_IS_VECTOR (c)) \ + { \ + closure = SCM_I_VECTOR_WELTS (c); \ + closure_count = SCM_I_VECTOR_LENGTH (c); \ + } \ + else \ + { \ + closure = NULL; \ + closure_count = 0; \ + } \ + } \ } #define SYNC_BEFORE_GC() \ @@ -178,6 +201,13 @@ #define CHECK_OBJECT(_num) #endif +#if VM_CHECK_CLOSURE +#define CHECK_CLOSURE(_num) \ + do { if (SCM_UNLIKELY ((_num) >= closure_count)) goto vm_error_closure; } while (0) +#else +#define CHECK_CLOSURE(_num) +#endif + /* * Hooks diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index d884557e1..5e850a1a6 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -248,6 +248,8 @@ VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED) +#define CLOSURE_REF(i) closure[i] + /* ref */ VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1) @@ -1150,6 +1152,92 @@ VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1) NEXT; } +VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0) +{ + SCM val; + POP (val); + SYNC_BEFORE_GC (); + LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val))); + NEXT; +} + +/* for letrec: + (let ((a *undef*) (b *undef*) ...) + (set! a (lambda () (b ...))) + ...) + */ +VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0) +{ + SYNC_BEFORE_GC (); + LOCAL_SET (FETCH (), + scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); + NEXT; +} + +VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1) +{ + SCM v = LOCAL_REF (FETCH ()); + ASSERT_BOUND_VARIABLE (v); + PUSH (VARIABLE_REF (v)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0) +{ + SCM v, val; + v = LOCAL_REF (FETCH ()); + POP (val); + ASSERT_VARIABLE (v); + VARIABLE_SET (v, val); + NEXT; +} + +VM_DEFINE_INSTRUCTION (60, closure_ref, "closure-ref", 1, 0, 1) +{ + scm_t_uint8 idx = FETCH (); + + CHECK_CLOSURE (idx); + PUSH (CLOSURE_REF (idx)); + NEXT; +} + +/* no closure-set -- if a var is assigned, it should be in a box */ + +VM_DEFINE_INSTRUCTION (61, closure_boxed_ref, "closure-boxed-ref", 1, 0, 1) +{ + SCM v; + scm_t_uint8 idx = FETCH (); + CHECK_CLOSURE (idx); + v = CLOSURE_REF (idx); + ASSERT_BOUND_VARIABLE (v); + PUSH (VARIABLE_REF (v)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (62, closure_boxed_set, "closure-boxed-set", 1, 1, 0) +{ + SCM v, val; + scm_t_uint8 idx = FETCH (); + POP (val); + CHECK_CLOSURE (idx); + v = CLOSURE_REF (idx); + ASSERT_BOUND_VARIABLE (v); + VARIABLE_SET (v, val); + NEXT; +} + +VM_DEFINE_INSTRUCTION (63, make_closure2, "make-closure2", 0, 2, 1) +{ + SCM vect; + POP (vect); + SYNC_BEFORE_GC (); + /* fixme underflow */ + SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp), + SCM_PROGRAM_OBJTABLE (*sp), vect); + NEXT; +} + + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" From 66d3e9a32c2da4eedb3f316e0dcffe92e6631f87 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jul 2009 17:00:56 +0200 Subject: [PATCH 298/375] compile lexical variable access and closure creation to the new ops * module/language/glil.scm (): New GLIL type, , which will subsume other lexical types. * module/language/glil/compile-assembly.scm: Compile . (make-open-binding): Change the interpretation of the second argument -- instead of indicating an "external" var, it now indicates a boxed var. (open-binding): Adapt to new glil-bind format. * module/language/tree-il/analyze.scm: Add a lot more docs. (analyze-lexicals): Change the allocation algorithm and output format to allow the tree-il->glil compiler to capture free variables appropriately and to reference bound variables in boxes if necessary. Amply documented. * module/language/tree-il/compile-glil.scm (compile-glil): Compile lexical variable access to . Emit variable capture and closure creation code here, instead of leaving that task to the GLIL->assembly compiler. * test-suite/tests/tree-il.test: Update expected code emission. --- module/language/glil.scm | 11 +- module/language/glil/compile-assembly.scm | 23 +- module/language/tree-il/analyze.scm | 392 ++++++++++++---------- module/language/tree-il/compile-glil.scm | 166 ++++----- test-suite/tests/tree-il.test | 76 +++-- 5 files changed, 374 insertions(+), 294 deletions(-) diff --git a/module/language/glil.scm b/module/language/glil.scm index 38b915f9e..4dff8178b 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -1,6 +1,6 @@ ;;; Guile Low Intermediate Language -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -49,6 +49,9 @@ make-glil-external glil-external? glil-external-op glil-external-depth glil-external-index + make-glil-lexical glil-lexical? + glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index + make-glil-toplevel glil-toplevel? glil-toplevel-op glil-toplevel-name @@ -85,6 +88,7 @@ ;; Variables ( op index) ( op depth index) + ( local? boxed? op index) ( op name) ( op mod name public?) ;; Controls @@ -122,6 +126,7 @@ ((const ,obj) (make-glil-const obj)) ((local ,op ,index) (make-glil-local op index)) ((external ,op ,depth ,index) (make-glil-external op depth index)) + ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) @@ -144,10 +149,10 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op index) - `(local ,op ,index)) (( op depth index) `(external ,op ,depth ,index)) + (( local? boxed? op index) + `(lexical ,local? ,boxed? ,op ,index)) (( op name) `(toplevel ,op ,name)) (( op mod name public?) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 0b92a4e7d..b2ea8dcab 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -78,8 +78,8 @@ (make-glil-call 'return 1)))))) ;; A functional stack of names of live variables. -(define (make-open-binding name ext? index) - (list name ext? index)) +(define (make-open-binding name boxed? index) + (list name boxed? index)) (define (make-closed-binding open-binding start end) (make-binding (car open-binding) (cadr open-binding) (caddr open-binding) start end)) @@ -89,8 +89,8 @@ (map (lambda (v) (pmatch v - ((,name local ,i) (make-open-binding name #f i)) - ((,name external ,i) (make-open-binding name #t i)) + ((,name ,boxed? ,i) + (make-open-binding name boxed? i)) (else (error "unknown binding type" v)))) vars) (car bindings)) @@ -257,6 +257,21 @@ `((external-ref ,(+ n index))) `((external-set ,(+ n index)))))))) + (( local? boxed? op index) + (emit-code + `((,(if local? + (case op + ((ref) (if boxed? 'local-boxed-ref 'local-ref)) + ((set) (if boxed? 'local-boxed-set 'local-set)) + ((box) 'box) + ((empty-box) 'empty-box) + (else (error "what" op))) + (case op + ((ref) (if boxed? 'closure-boxed-ref 'closure-ref)) + ((set) (if boxed? 'closure-boxed-set (error "what." glil))) + (else (error "what" op)))) + ,index)))) + (( op name) (case op ((ref set) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 976807718..4ed796c03 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -19,14 +19,37 @@ ;;; Code: (define-module (language tree-il analyze) + #:use-module (srfi srfi-1) #:use-module (system base syntax) #:use-module (language tree-il) #:export (analyze-lexicals)) -;; allocation: the process of assigning a type and index to each var -;; a var is external if it is heaps; assigning index is easy -;; args are assigned in order -;; locals are indexed as their linear position in the binding path +;; Allocation is the process of assigning storage locations for lexical +;; variables. A lexical variable has a distinct "address", or storage +;; location, for each procedure in which it is referenced. +;; +;; A variable is "local", i.e., allocated on the stack, if it is +;; referenced from within the procedure that defined it. Otherwise it is +;; a "closure" variable. For example: +;; +;; (lambda (a) a) ; a will be local +;; `a' is local to the procedure. +;; +;; (lambda (a) (lambda () a)) +;; `a' is local to the outer procedure, but a closure variable with +;; respect to the inner procedure. +;; +;; If a variable is ever assigned, it needs to be heap-allocated +;; ("boxed"). This is so that closures and continuations capture the +;; variable's identity, not just one of the values it may have over the +;; course of program execution. If the variable is never assigned, there +;; is no distinction between value and identity, so closing over its +;; identity (whether through closures or continuations) can make a copy +;; of its value instead. +;; +;; Local variables are stored on the stack within a procedure's call +;; frame. Their index into the stack is determined from their linear +;; postion within a procedure's binding path: ;; (let (0 1) ;; (let (2 3) ...) ;; (let (2) ...)) @@ -48,49 +71,67 @@ ;; case. A proper solution would be some sort of liveness analysis, and ;; not our linear allocation algorithm. ;; -;; allocation: -;; sym -> (local . index) | (heap level . index) -;; lambda -> (nlocs . nexts) +;; Closure variables are captured when a closure is created, and stored +;; in a vector. Each closure variable has a unique index into that +;; vector. +;; +;; +;; The return value of `analyze-lexicals' is a hash table, the +;; "allocation". +;; +;; The allocation maps gensyms -- recall that each lexically bound +;; variable has a unique gensym -- to storage locations ("addresses"). +;; Since one gensym may have many storage locations, if it is referenced +;; in many procedures, it is a two-level map. +;; +;; The allocation also stored information on how many local variables +;; need to be allocated for each procedure, and information on what free +;; variables to capture from its lexical parent procedure. +;; +;; That is: +;; +;; sym -> {lambda -> address} +;; lambda -> (nlocs . free-locs) +;; +;; address := (local? boxed? . index) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. + +(define (make-hashq k v) + (let ((res (make-hash-table))) + (hashq-set! res k v) + res)) (define (analyze-lexicals x) - ;; parents: lambda -> parent - ;; useful when we see a closed-over var, so we can calculate its - ;; coordinates (depth and index). - ;; bindings: lambda -> (sym ...) - ;; useful for two reasons: one, so we know how much space to allocate - ;; when we go into a lambda; and two, so that we know when to stop, - ;; when looking for closed-over vars. - ;; heaps: sym -> lambda - ;; allows us to heapify vars in an O(1) fashion + ;; bound-vars: lambda -> (sym ...) + ;; all identifiers bound within a lambda + ;; free-vars: lambda -> (sym ...) + ;; all identifiers referenced in a lambda, but not bound + ;; NB, this includes identifiers referenced by contained lambdas + ;; assigned: sym -> #t + ;; variables that are assigned ;; refcounts: sym -> count - ;; allows us to detect the or-expansion an O(1) time - - (define (find-heap sym parent) - ;; fixme: check displaced lexicals here? - (if (memq sym (hashq-ref bindings parent)) - parent - (find-heap sym (hashq-ref parents parent)))) - - (define (analyze! x parent level) - (define (step y) (analyze! y parent level)) - (define (recur x parent) (analyze! x parent (1+ level))) + ;; allows us to detect the or-expansion in O(1) time + + ;; returns variables referenced in expr + (define (analyze! x proc) + (define (step y) (analyze! y proc)) + (define (recur x new-proc) (analyze! x new-proc)) (record-case x (( proc args) - (step proc) (for-each step args)) + (apply lset-union eq? (step proc) (map step args))) (( test then else) - (step test) (step then) (step else)) + (lset-union eq? (step test) (step then) (step else))) (( name gensym) (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) - (if (and (not (memq gensym (hashq-ref bindings parent))) - (not (hashq-ref heaps gensym))) - (hashq-set! heaps gensym (find-heap gensym parent)))) + (list gensym)) (( name gensym exp) - (step exp) - (if (not (hashq-ref heaps gensym)) - (hashq-set! heaps gensym (find-heap gensym parent)))) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (hashq-set! assigned gensym #t) + (lset-adjoin eq? (step exp) gensym)) (( mod name public? exp) (step exp)) @@ -102,157 +143,168 @@ (step exp)) (( exps) - (for-each step exps)) + (apply lset-union eq? (map step exps))) (( vars meta body) - (hashq-set! parents x parent) - (hashq-set! bindings x - (let rev* ((vars vars) (out '())) - (cond ((null? vars) out) - ((pair? vars) (rev* (cdr vars) - (cons (car vars) out))) - (else (cons vars out))))) - (recur body x) - (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) - + (let ((locally-bound (let rev* ((vars vars) (out '())) + (cond ((null? vars) out) + ((pair? vars) (rev* (cdr vars) + (cons (car vars) out))) + (else (cons vars out)))))) + (hashq-set! bound-vars x locally-bound) + (let* ((referenced (recur body x)) + (free (lset-difference eq? referenced locally-bound)) + (all-bound (reverse! (hashq-ref bound-vars x)))) + (hashq-set! bound-vars x all-bound) + (hashq-set! free-vars x free) + free))) + (( vars vals body) - (for-each step vals) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (step body)) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (lset-difference eq? + (apply lset-union eq? (step body) (map step vals)) + vars)) (( vars vals body) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (for-each step vals) - (step body)) - + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) + (lset-difference eq? + (apply lset-union eq? (step body) (map step vals)) + vars)) + (( vars exp body) - (hashq-set! bindings parent - (let lp ((out (hashq-ref bindings parent)) (in vars)) + (hashq-set! bound-vars proc + (let lp ((out (hashq-ref bound-vars proc)) (in vars)) (if (pair? in) (lp (cons (car in) out) (cdr in)) (if (null? in) out (cons in out))))) - (step exp) - (step body)) + (lset-difference eq? + (lset-union eq? (step exp) (step body)) + vars)) + + (else '()))) + + (define (allocate! x proc n) + (define (recur y) (allocate! y proc n)) + (record-case x + (( proc args) + (apply max (recur proc) (map recur args))) - (else #f))) + (( test then else) + (max (recur test) (recur then) (recur else))) - (define (allocate-heap! binder) - (hashq-set! heap-indexes binder - (1+ (hashq-ref heap-indexes binder -1)))) + (( name gensym exp) + (recur exp)) + + (( mod name public? exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( exps) + (apply max (map recur exps))) + + (( vars meta body) + ;; allocate closure vars in order + (let lp ((c (hashq-ref free-vars x)) (n 0)) + (if (pair? c) + (begin + (hashq-set! (hashq-ref allocation (car c)) + x + `(#f ,(hashq-ref assigned (car c)) . ,n)) + (lp (cdr c) (1+ n))))) + + (let ((nlocs + (let lp ((vars vars) (n 0)) + (if (not (null? vars)) + ;; allocate args + (let ((v (if (pair? vars) (car vars) vars))) + (hashq-set! allocation v + (make-hashq + x `(#t ,(hashq-ref assigned v) . ,n))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))) + ;; allocate body, return number of additional locals + (- (allocate! body x n) n)))) + (free-addresses + (map (lambda (v) + (hashq-ref (hashq-ref allocation v) proc)) + (hashq-ref free-vars x)))) + ;; set procedure allocations + (hashq-set! allocation x (cons nlocs free-addresses))) + n) - (define (allocate! x level n) - (define (recur y) (allocate! y level n)) - (record-case x - (( proc args) - (apply max (recur proc) (map recur args))) - - (( test then else) - (max (recur test) (recur then) (recur else))) - - (( name gensym exp) - (recur exp)) - - (( mod name public? exp) - (recur exp)) - - (( name exp) - (recur exp)) - - (( name exp) - (recur exp)) - - (( exps) - (apply max (map recur exps))) - - (( vars meta body) - (let lp ((vars vars) (n 0)) - (if (null? vars) - (hashq-set! allocation x - (let ((nlocs (- (allocate! body (1+ level) n) n))) - (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) - (let ((v (if (pair? vars) (car vars) vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap (1+ level) (allocate-heap! binder)) - (cons 'stack n)))) - (lp (if (pair? vars) (cdr vars) '()) (1+ n))))) - n) - - (( vars vals body) - (let ((nmax (apply max (map recur vals)))) - (cond - ;; the `or' hack - ((and (conditional? body) - (= (length vars) 1) - (let ((v (car vars))) - (and (not (hashq-ref heaps v)) - (= (hashq-ref refcounts v 0) 2) - (lexical-ref? (conditional-test body)) - (eq? (lexical-ref-gensym (conditional-test body)) v) - (lexical-ref? (conditional-then body)) - (eq? (lexical-ref-gensym (conditional-then body)) v)))) - (hashq-set! allocation (car vars) (cons 'stack n)) - ;; the 1+ for this var - (max nmax (1+ n) (allocate! (conditional-else body) level n))) - (else - (let lp ((vars vars) (n n)) - (if (null? vars) - (max nmax (allocate! body level n)) - (let ((v (car vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n))) - (lp (cdr vars) (if binder n (1+ n))))))))))) - - (( vars vals body) - (let lp ((vars vars) (n n)) - (if (null? vars) - (let ((nmax (apply max - (map (lambda (x) - (allocate! x level n)) - vals)))) - (max nmax (allocate! body level n))) - (let ((v (car vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n))) - (lp (cdr vars) (if binder n (1+ n)))))))) - - (( vars exp body) - (let ((nmax (recur exp))) + (( vars vals body) + (let ((nmax (apply max (map recur vals)))) + (cond + ;; the `or' hack + ((and (conditional? body) + (= (length vars) 1) + (let ((v (car vars))) + (and (not (hashq-ref assigned v)) + (= (hashq-ref refcounts v 0) 2) + (lexical-ref? (conditional-test body)) + (eq? (lexical-ref-gensym (conditional-test body)) v) + (lexical-ref? (conditional-then body)) + (eq? (lexical-ref-gensym (conditional-then body)) v)))) + (hashq-set! allocation (car vars) + (make-hashq proc `(#t #f . ,n))) + ;; the 1+ for this var + (max nmax (1+ n) (allocate! (conditional-else body) proc n))) + (else (let lp ((vars vars) (n n)) (if (null? vars) - (max nmax (allocate! body level n)) - (let ((v (if (pair? vars) (car vars) vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n))) - (lp (if (pair? vars) (cdr vars) '()) - (if binder n (1+ n))))))))) - - (else n))) + (max nmax (allocate! body proc n)) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n))))))))) + + (( vars vals body) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x proc n)) + vals)))) + (max nmax (allocate! body proc n))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))) - (define parents (make-hash-table)) - (define bindings (make-hash-table)) - (define heaps (make-hash-table)) + (( vars exp body) + (let ((nmax (recur exp))) + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! body proc n)) + (let ((v (if (pair? vars) (car vars) vars))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))))) + + (else n))) + + (define bound-vars (make-hash-table)) + (define free-vars (make-hash-table)) + (define assigned (make-hash-table)) (define refcounts (make-hash-table)) + (define allocation (make-hash-table)) - (define heap-indexes (make-hash-table)) - - (analyze! x #f -1) - (allocate! x -1 0) + + (analyze! x #f) + (allocate! x #f 0) allocation) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e0df038d8..29f4683c1 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -20,6 +20,7 @@ (define-module (language tree-il compile-glil) #:use-module (system base syntax) + #:use-module (system base pmatch) #:use-module (ice-9 receive) #:use-module (language glil) #:use-module (system vm instruction) @@ -34,8 +35,12 @@ ;; basic degenerate-case reduction ;; allocation: -;; sym -> (local . index) | (heap level . index) -;; lambda -> (nlocs . nexts) +;; sym -> {lambda -> address} +;; lambda -> (nlocs . closure-vars) +;; +;; address := (local? boxed? . index) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. (define *comp-module* (make-fluid)) @@ -45,7 +50,7 @@ (allocation (analyze-lexicals x))) (with-fluid* *comp-module* (or (and e (car e)) (current-module)) (lambda () - (values (flatten-lambda x -1 allocation) + (values (flatten-lambda x allocation) (and e (cons (car e) (cddr e))) e))))) @@ -131,20 +136,19 @@ (define (make-label) (gensym ":L")) -(define (vars->bind-list ids vars allocation) +(define (vars->bind-list ids vars allocation proc) (map (lambda (id v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) (list id 'local (cdr loc))) - ((heap) (list id 'external (cddr loc))) - (else (error "badness" id v loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t ,boxed? . ,n) + (list id boxed? n)) + (,x (error "badness" x)))) ids vars)) -(define (emit-bindings src ids vars allocation emit-code) +(define (emit-bindings src ids vars allocation proc emit-code) (if (pair? vars) (emit-code src (make-glil-bind - (vars->bind-list ids vars allocation))))) + (vars->bind-list ids vars allocation proc))))) (define (with-output-to-code proc) (let ((out '())) @@ -155,7 +159,7 @@ (proc emit-code) (reverse out))) -(define (flatten-lambda x level allocation) +(define (flatten-lambda x allocation) (receive (ids vars nargs nrest) (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) (oids '()) (ovars '()) (n 0)) @@ -166,31 +170,27 @@ (else (values (reverse (cons ids oids)) (reverse (cons vars ovars)) (1+ n) 1)))) - (let ((nlocs (car (hashq-ref allocation x))) - (nexts (cdr (hashq-ref allocation x)))) + (let ((nlocs (car (hashq-ref allocation x)))) (make-glil-program - nargs nrest nlocs nexts (lambda-meta x) + nargs nrest nlocs 0 (lambda-meta x) (with-output-to-code (lambda (emit-code) ;; write bindings and source debugging info - (emit-bindings #f ids vars allocation emit-code) + (emit-bindings #f ids vars allocation x emit-code) (if (lambda-src x) (emit-code #f (make-glil-source (lambda-src x)))) - - ;; copy args to the heap if necessary - (let lp ((in vars) (n 0)) - (if (not (null? in)) - (let ((loc (hashq-ref allocation (car in)))) - (case (car loc) - ((heap) - (emit-code #f (make-glil-local 'ref n)) - (emit-code #f (make-glil-external 'set 0 (cddr loc))))) - (lp (cdr in) (1+ n))))) - + ;; box args if necessary + (for-each + (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) x) + ((#t #t . ,n) + (emit-code #f (make-glil-lexical #t #f 'ref n)) + (emit-code #f (make-glil-lexical #t #t 'box n))))) + vars) ;; and here, here, dear reader: we compile. - (flatten (lambda-body x) (1+ level) allocation emit-code))))))) + (flatten (lambda-body x) allocation x emit-code))))))) -(define (flatten x level allocation emit-code) +(define (flatten x allocation proc emit-code) (define (emit-label label) (emit-code #f (make-glil-label label))) (define (emit-branch src inst label) @@ -424,27 +424,21 @@ (( src name gensym) (case context ((push vals tail) - (let ((loc (hashq-ref allocation gensym))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'ref (cdr loc)))) - ((heap) - (emit-code src (make-glil-external - 'ref (- level (cadr loc)) (cddr loc)))) - (else (error "badness" x loc))) - (if (eq? context 'tail) - (emit-code #f (make-glil-call 'return 1))))))) - + (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'ref index))) + (,loc + (error "badness" x loc))))) + (case context + ((tail) (emit-code #f (make-glil-call 'return 1))))) + (( src name gensym exp) (comp-push exp) - (let ((loc (hashq-ref allocation gensym))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external - 'set (- level (cadr loc)) (cddr loc)))) - (else (error "badness" x loc)))) + (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'set index))) + (,loc + (error "badness" x loc))) (case context ((push vals) (emit-code #f (make-glil-void))) @@ -495,39 +489,52 @@ (emit-code #f (make-glil-call 'return 1))))) (() - (case context - ((push vals) - (emit-code #f (flatten-lambda x level allocation))) - ((tail) - (emit-code #f (flatten-lambda x level allocation)) - (emit-code #f (make-glil-call 'return 1))))) - + (let ((free-locs (cdr (hashq-ref allocation x)))) + (case context + ((push vals tail) + (emit-code #f (flatten-lambda x allocation)) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (emit-code #f (make-glil-call 'make-closure2 2)))) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))))) + (( src names vars vals body) (for-each comp-push vals) - (emit-bindings src names vars allocation emit-code) + (emit-bindings src names vars allocation proc emit-code) (for-each (lambda (v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external 'set 0 (cddr loc)))) - (else (error "badness" x loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) (reverse vars)) (comp-tail body) (emit-code #f (make-glil-unbind))) (( src names vars vals body) - (for-each comp-push vals) - (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external 'set 0 (cddr loc)))) - (else (error "badness" x loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'empty-box n))) + (,loc (error "badness" x loc)))) + vars) + (for-each comp-push vals) + (emit-bindings src names vars allocation proc emit-code) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'set n))) + (,loc (error "badness" x loc)))) (reverse vars)) (comp-tail body) (emit-code #f (make-glil-unbind))) @@ -548,16 +555,15 @@ (emit-code #f (make-glil-const 1)) (emit-label MV) (emit-code src (make-glil-mv-bind - (vars->bind-list names vars allocation) + (vars->bind-list names vars allocation proc) rest?)) (for-each (lambda (v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external 'set 0 (cddr loc)))) - (else (error "badness" x loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) (reverse vars)) (comp-tail body) (emit-code #f (make-glil-unbind)))))))))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index ec410b52b..21efa8e31 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -129,45 +129,45 @@ (assert-tree-il->glil (let (x) (y) ((const 1)) (lexical x y)) (program 0 0 1 0 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (call return 1) + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) (program 0 0 1 0 () - (const 1) (bind (x local 0)) (local set 0) + (const 1) (bind (x #f 0)) (lexical #t #f set 0) (const #f) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) (program 0 0 1 0 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (call null? 1) (call return 1) + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (call null? 1) (call return 1) (unbind)))) (with-test-prefix "lexical sets" (assert-tree-il->glil (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) - (program 0 0 0 1 () - (const 1) (bind (x external 0)) (external set 0 0) - (const 2) (external set 0 0) (void) (call return 1) + (program 0 0 1 0 () + (const 1) (bind (x #t 0)) (lexical #t #t box 0) + (const 2) (lexical #t #t set 0) (void) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) - (program 0 0 0 1 () - (const 1) (bind (x external 0)) (external set 0 0) - (const 2) (external set 0 0) (const #f) (call return 1) + (program 0 0 1 0 () + (const 1) (bind (x #t 0)) (lexical #t #t box 0) + (const 2) (lexical #t #t set 0) (const #f) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (apply (primitive null?) (set! (lexical x y) (const 2)))) - (program 0 0 0 1 () - (const 1) (bind (x external 0)) (external set 0 0) - (const 2) (external set 0 0) (void) (call null? 1) (call return 1) + (program 0 0 1 0 () + (const 1) (bind (x #t 0)) (lexical #t #t box 0) + (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1) (unbind)))) (with-test-prefix "module refs" @@ -322,7 +322,7 @@ (lambda (x) (y) () (const 2)) (program 0 0 0 0 () (program 1 0 0 0 () - (bind (x local 0)) + (bind (x #f 0)) (const 2) (call return 1)) (call return 1))) @@ -330,7 +330,7 @@ (lambda (x x1) (y y1) () (const 2)) (program 0 0 0 0 () (program 2 0 0 0 () - (bind (x local 0) (x1 local 1)) + (bind (x #f 0) (x1 #f 1)) (const 2) (call return 1)) (call return 1))) @@ -338,7 +338,7 @@ (lambda x y () (const 2)) (program 0 0 0 0 () (program 1 1 0 0 () - (bind (x local 0)) + (bind (x #f 0)) (const 2) (call return 1)) (call return 1))) @@ -346,7 +346,7 @@ (lambda (x . x1) (y . y1) () (const 2)) (program 0 0 0 0 () (program 2 1 0 0 () - (bind (x local 0) (x1 local 1)) + (bind (x #f 0) (x1 #f 1)) (const 2) (call return 1)) (call return 1))) @@ -354,27 +354,29 @@ (lambda (x . x1) (y . y1) () (lexical x y)) (program 0 0 0 0 () (program 2 1 0 0 () - (bind (x local 0) (x1 local 1)) - (local ref 0) (call return 1)) + (bind (x #f 0) (x1 #f 1)) + (lexical #t #f ref 0) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x1 y1)) (program 0 0 0 0 () (program 2 1 0 0 () - (bind (x local 0) (x1 local 1)) - (local ref 1) (call return 1)) + (bind (x #f 0) (x1 #f 1)) + (lexical #t #f ref 1) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) (program 0 0 0 0 () - (program 1 0 0 1 () - (bind (x external 0)) - (local ref 0) (external set 0 0) + (program 1 0 0 0 () + (bind (x #f 0)) (program 1 0 0 0 () - (bind (y local 0)) - (external ref 1 0) (call return 1)) + (bind (y #f 0)) + (lexical #f #f ref 0) (call return 1)) + (lexical #t #f ref 0) + (call vector 1) + (call make-closure2 2) (call return 1)) (call return 1)))) @@ -399,12 +401,12 @@ (let (a) (b) ((const 2)) (lexical a b)))) (program 0 0 1 0 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (branch br-if-not ,l1) - (local ref 0) (call return 1) + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (branch br-if-not ,l1) + (lexical #t #f ref 0) (call return 1) (label ,l2) - (const 2) (bind (a local 0)) (local set 0) - (local ref 0) (call return 1) + (const 2) (bind (a #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (call return 1) (unbind) (unbind)) (eq? l1 l2)) @@ -416,12 +418,12 @@ (let (a) (b) ((const 2)) (lexical x y)))) (program 0 0 2 0 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (branch br-if-not ,l1) - (local ref 0) (call return 1) + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (branch br-if-not ,l1) + (lexical #t #f ref 0) (call return 1) (label ,l2) - (const 2) (bind (a local 1)) (local set 1) - (local ref 0) (call return 1) + (const 2) (bind (a #f 1)) (lexical #t #f set 1) + (lexical #t #f ref 0) (call return 1) (unbind) (unbind)) (eq? l1 l2))) From 20d47c3915c1b910e683d4b010b91c48047d6251 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jul 2009 17:12:10 +0200 Subject: [PATCH 299/375] remove "externals" from the vm * libguile/frames.c (scm_frame_external_link): Removed. * libguile/frames.h: No need to have the "external link" in the stack frame -- update macros to take the new situation into account. * libguile/objcodes.h (struct scm_objcode): Rename the nexts field to "unused". In the future we can use it for nlocs, I think. (SCM_OBJCODE_NEXTS): removed. * libguile/programs.h: * libguile/programs.c (scm_make_program): Expect the third argument to be a vector of free variables, not a list of free variables. SCM_BOOL_F indicates no free variables, not SCM_EOL. (program_mark): Adapt. (scm_program_arity): No more nexts. (scm_program_free_vars): Replaces scm_program_externals. * libguile/vm-engine.c (VM_CHECK_EXTERNAL) (vm_engine): No need for the "external" var. * libguile/vm-engine.h (CACHE_PROGRAM): Update for SCM_PROGRAM_FREE_VARS instead of SCM_PROGRAM_EXTERNALS. (NEW_FRAME): Update for new frame size, and no need to cons up externals. Yay :) * libguile/vm-i-loader.c (load-program): Update for scm_make_program. * libguile/vm-i-system.c (external-ref, external-set): No more. (make-closure): No more. (goto/args): No need to re-cons externals here. Update for new stack frame size. (mv-call, return, return/values): Update for new frame size. No need to reinstate externals on return. * libguile/vm.c (really_make_boot_program, scm_load_compiled_with_vm): Update for scm_make_program. * module/language/objcode/spec.scm (objcode-env-externals): Treat '() as #f, for the externals. Need to clean this up later... * module/system/vm/program.scm (arity:nexts): Remove. Rename program-external to program-free-vars. --- libguile/frames.c | 12 +---- libguile/frames.h | 17 +++---- libguile/objcodes.h | 3 +- libguile/programs.c | 50 ++++++------------- libguile/programs.h | 9 ++-- libguile/vm-engine.c | 12 +---- libguile/vm-engine.h | 36 +++----------- libguile/vm-i-loader.c | 2 +- libguile/vm-i-system.c | 84 ++++++-------------------------- libguile/vm.c | 6 +-- module/language/objcode/spec.scm | 4 +- module/system/vm/program.scm | 7 ++- 12 files changed, 59 insertions(+), 183 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index 76552f54f..e89184d79 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -222,16 +222,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0, - (SCM frame), - "") -#define FUNC_NAME s_scm_vm_frame_external_link -{ - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0, (SCM frame), "") diff --git a/libguile/frames.h b/libguile/frames.h index 99623fb16..1d8a30f8e 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -30,12 +30,11 @@ /* VM Frame Layout --------------- - | | <- fp + bp->nargs + bp->nlocs + 4 + | | <- fp + bp->nargs + bp->nlocs + 3 +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp) | Return address | | MV return address| - | Dynamic link | - | External link | <- fp + bp->nargs + bp->nlocs + | Dynamic link | <- fp + bp->nargs + bp->blocs | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp) | Local variable 0 | <- fp + bp->nargs | Argument 1 | @@ -51,21 +50,20 @@ #define SCM_FRAME_DATA_ADDRESS(fp) \ (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \ + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs) -#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4) +#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 3) #define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1) #define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x)) #define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x)) #define SCM_FRAME_RETURN_ADDRESS(fp) \ - (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3])) -#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2])) +#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \ + (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1])) #define SCM_FRAME_DYNAMIC_LINK(fp) \ - (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1])) + (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0])) #define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \ ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl); -#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0]) #define SCM_FRAME_VARIABLE(fp,i) fp[i] #define SCM_FRAME_PROGRAM(fp) fp[-1] @@ -106,7 +104,6 @@ SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); SCM_API SCM scm_vm_frame_return_address (SCM frame); SCM_API SCM scm_vm_frame_mv_return_address (SCM frame); SCM_API SCM scm_vm_frame_dynamic_link (SCM frame); -SCM_API SCM scm_vm_frame_external_link (SCM frame); SCM_API SCM scm_vm_frame_stack (SCM frame); SCM_API SCM scm_c_vm_frame_prev (SCM frame); diff --git a/libguile/objcodes.h b/libguile/objcodes.h index e9b1cdbff..6727e23e8 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -26,7 +26,7 @@ struct scm_objcode { scm_t_uint8 nargs; scm_t_uint8 nrest; scm_t_uint8 nlocs; - scm_t_uint8 nexts; + scm_t_uint8 unused; scm_t_uint32 len; /* the maximum index of base[] */ scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of base[] for metadata */ @@ -49,7 +49,6 @@ SCM_API scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs) #define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest) #define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs) -#define SCM_OBJCODE_NEXTS(x) (SCM_OBJCODE_DATA (x)->nexts) #define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base) #define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP) diff --git a/libguile/programs.c b/libguile/programs.c index 892b6770f..9e74f98e3 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -36,7 +36,7 @@ scm_t_bits scm_tc16_program; static SCM write_program = SCM_BOOL_F; SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, - (SCM objcode, SCM objtable, SCM external), + (SCM objcode, SCM objtable, SCM free_vars), "") #define FUNC_NAME s_scm_make_program { @@ -45,18 +45,12 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, objtable = SCM_BOOL_F; else if (scm_is_true (objtable)) SCM_VALIDATE_VECTOR (2, objtable); - if (SCM_UNLIKELY (SCM_UNBNDP (external))) - external = SCM_EOL; - else - /* FIXME: currently this test is quite expensive (can be 2-3% of total - execution time in programs that make many closures). We could remove it, - yes, but we'd get much better gains if we used some other method, like - just capturing the variables that we need instead of all heap-allocated - variables. Dunno. Keeping the check for now, as it's a user-callable - function, and inlining the op in the vm's make-closure operation. */ - SCM_VALIDATE_LIST (3, external); + if (SCM_UNLIKELY (SCM_UNBNDP (free_vars))) + free_vars = SCM_BOOL_F; + else if (free_vars != SCM_BOOL_F) + SCM_VALIDATE_VECTOR (3, free_vars); - SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external); + SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_vars); } #undef FUNC_NAME @@ -65,8 +59,8 @@ program_mark (SCM obj) { if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj))) scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj)); - if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj))) - scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj)); + if (scm_is_true (SCM_PROGRAM_FREE_VARS (obj))) + scm_gc_mark (SCM_PROGRAM_FREE_VARS (obj)); return SCM_PROGRAM_OBJCODE (obj); } @@ -151,10 +145,9 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0, SCM_VALIDATE_PROGRAM (1, program); p = SCM_PROGRAM_DATA (program); - return scm_list_4 (SCM_I_MAKINUM (p->nargs), + return scm_list_3 (SCM_I_MAKINUM (p->nargs), SCM_I_MAKINUM (p->nrest), - SCM_I_MAKINUM (p->nlocs), - SCM_I_MAKINUM (p->nexts)); + SCM_I_MAKINUM (p->nlocs)); } #undef FUNC_NAME @@ -191,7 +184,7 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); if (scm_is_true (metaobj)) - return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL); + return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F); else return SCM_BOOL_F; } @@ -300,26 +293,13 @@ scm_c_program_source (SCM program, size_t ip) return source; /* (addr . (filename . (line . column))) */ } -SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0, +SCM_DEFINE (scm_program_free_vars, "program-free-vars", 1, 0, 0, (SCM program), "") -#define FUNC_NAME s_scm_program_external +#define FUNC_NAME s_scm_program_free_vars { SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_EXTERNALS (program); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0, - (SCM program, SCM external), - "Modify the list of closure variables of @var{program} (for " - "debugging purposes).") -#define FUNC_NAME s_scm_program_external_set_x -{ - SCM_VALIDATE_PROGRAM (1, program); - SCM_VALIDATE_LIST (2, external); - SCM_PROGRAM_EXTERNALS (program) = external; - return SCM_UNSPECIFIED; + return SCM_PROGRAM_FREE_VARS (program); } #undef FUNC_NAME diff --git a/libguile/programs.h b/libguile/programs.h index 16a15500f..0564139f7 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -35,12 +35,12 @@ SCM_API scm_t_bits scm_tc16_program; #define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x)) #define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x)) #define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x)) -#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x)) +#define SCM_PROGRAM_FREE_VARS(x) (SCM_SMOB_OBJECT_3 (x)) #define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x))) #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT) -SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_vars); SCM_API SCM scm_program_p (SCM obj); SCM_API SCM scm_program_base (SCM program); @@ -53,8 +53,7 @@ SCM_API SCM scm_program_properties (SCM program); SCM_API SCM scm_program_name (SCM program); SCM_API SCM scm_program_objects (SCM program); SCM_API SCM scm_program_module (SCM program); -SCM_API SCM scm_program_external (SCM program); -SCM_API SCM scm_program_external_set_x (SCM program, SCM external); +SCM_API SCM scm_program_free_vars (SCM program); SCM_API SCM scm_program_objcode (SCM program); SCM_API SCM scm_c_program_source (SCM program, size_t ip); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 7a98a8a62..8a0c92d24 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -21,14 +21,12 @@ #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE) #define VM_USE_HOOKS 0 /* Various hooks */ #define VM_USE_CLOCK 0 /* Bogoclock */ -#define VM_CHECK_EXTERNAL 1 /* Check external link */ #define VM_CHECK_OBJECT 1 /* Check object table */ #define VM_CHECK_CLOSURE 1 /* Check closure vars */ #define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 #define VM_USE_CLOCK 1 -#define VM_CHECK_EXTERNAL 1 #define VM_CHECK_OBJECT 1 #define VM_CHECK_CLOSURE 1 #define VM_PUSH_DEBUG_FRAMES 1 @@ -49,7 +47,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* Cache variables */ struct scm_objcode *bp = NULL; /* program base pointer */ - SCM external = SCM_EOL; /* external environment REMOVEME */ SCM *closure = NULL; /* closure variables */ size_t closure_count = 0; /* length of CLOSURE */ SCM *objects = NULL; /* constant objects */ @@ -230,13 +227,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) goto vm_error; #endif -#if VM_CHECK_EXTERNAL - vm_error_external: - err_msg = scm_from_locale_string ("VM: Invalid external access"); - finish_args = SCM_EOL; - goto vm_error; -#endif - #if VM_CHECK_OBJECT vm_error_object: err_msg = scm_from_locale_string ("VM: Invalid object table access"); @@ -263,8 +253,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) #undef VM_USE_HOOKS #undef VM_USE_CLOCK -#undef VM_CHECK_EXTERNAL #undef VM_CHECK_OBJECT +#undef VM_CHECK_CLOSURE #undef VM_PUSH_DEBUG_FRAMES /* diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index a2c1effd3..b860bf151 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -138,11 +138,7 @@ #define ASSERT_BOUND(x) #endif -/* Get a local copy of the program's "object table" (i.e. the vector of - external bindings that are referenced by the program), initialized by - `load-program'. */ -/* XXX: We could instead use the "simple vector macros", thus not having to - call `scm_vector_writable_elements ()' and the likes. */ +/* Cache the object table and free variables. */ #define CACHE_PROGRAM() \ { \ if (bp != SCM_PROGRAM_DATA (program)) { \ @@ -156,7 +152,7 @@ } \ } \ { \ - SCM c = SCM_PROGRAM_EXTERNALS (program); \ + SCM c = SCM_PROGRAM_FREE_VARS (program); \ if (SCM_I_IS_VECTOR (c)) \ { \ closure = SCM_I_VECTOR_WELTS (c); \ @@ -185,14 +181,6 @@ * Error check */ -#undef CHECK_EXTERNAL -#if VM_CHECK_EXTERNAL -#define CHECK_EXTERNAL(e) \ - do { if (SCM_UNLIKELY (!SCM_CONSP (e))) goto vm_error_external; } while (0) -#else -#define CHECK_EXTERNAL(e) -#endif - /* Accesses to a program's object table. */ #if VM_CHECK_OBJECT #define CHECK_OBJECT(_num) \ @@ -406,7 +394,7 @@ do { \ /* New registers */ \ fp = sp - bp->nargs + 1; \ data = SCM_FRAME_DATA_ADDRESS (fp); \ - sp = data + 3; \ + sp = data + 2; \ CHECK_OVERFLOW (); \ stack_base = sp; \ ip = bp->base; \ @@ -416,23 +404,11 @@ do { \ data[-i] = SCM_UNDEFINED; \ \ /* Set frame data */ \ - data[3] = (SCM)ra; \ - data[2] = 0x0; \ - data[1] = (SCM)dl; \ - \ - /* Postpone initializing external vars, \ - because if the CONS causes a GC, we \ - want the stack marker to see the data \ - array formatted as expected. */ \ - data[0] = SCM_UNDEFINED; \ - external = SCM_PROGRAM_EXTERNALS (fp[-1]); \ - for (i = 0; i < bp->nexts; i++) \ - CONS (external, SCM_UNDEFINED, external); \ - data[0] = external; \ + data[2] = (SCM)ra; \ + data[1] = 0x0; \ + data[0] = (SCM)dl; \ } -#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs] - /* Local Variables: c-file-style: "gnu" diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 4edadb37f..9ae49ed65 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -114,7 +114,7 @@ VM_DEFINE_LOADER (86, load_program, "load-program") objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip); len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); - PUSH (scm_make_program (objcode, objs, SCM_EOL)); + PUSH (scm_make_program (objcode, objs, SCM_BOOL_F)); ip += len; diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 5e850a1a6..a7e05c83b 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -278,21 +278,6 @@ VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (26, external_ref, "external-ref", 1, 0, 1) -{ - unsigned int i; - SCM e = external; - for (i = FETCH (); i; i--) - { - CHECK_EXTERNAL(e); - e = SCM_CDR (e); - } - CHECK_EXTERNAL(e); - PUSH (SCM_CAR (e)); - ASSERT_BOUND (*sp); - NEXT; -} - VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1) { SCM x = *sp; @@ -369,21 +354,6 @@ VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (31, external_set, "external-set", 1, 1, 0) -{ - unsigned int i; - SCM e = external; - for (i = FETCH (); i; i--) - { - CHECK_EXTERNAL(e); - e = SCM_CDR (e); - } - CHECK_EXTERNAL(e); - SCM_SETCAR (e, *sp); - DROP (); - NEXT; -} - VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0) { VARIABLE_SET (sp[0], sp[-1]); @@ -500,14 +470,6 @@ VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0) * Subprogram call */ -VM_DEFINE_INSTRUCTION (42, make_closure, "make-closure", 0, 1, 1) -{ - SYNC_BEFORE_GC (); - SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp), - SCM_PROGRAM_OBJTABLE (*sp), external); - NEXT; -} - VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1) { SCM x; @@ -656,12 +618,6 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1) sp -= 2; NULLSTACK (bp->nargs + 1); - /* Freshen the externals */ - external = SCM_PROGRAM_EXTERNALS (x); - for (i = 0; i < bp->nexts; i++) - CONS (external, SCM_UNDEFINED, external); - SCM_FRAME_DATA_ADDRESS (fp)[0] = external; - /* Init locals to valid SCM values */ for (i = 0; i < bp->nlocs; i++) LOCAL_SET (i + bp->nargs, SCM_UNDEFINED); @@ -710,7 +666,7 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1) sure we have space for the locals now */ data = SCM_FRAME_DATA_ADDRESS (fp); ip = bp->base; - stack_base = data + 3; + stack_base = data + 2; sp = stack_base; CHECK_OVERFLOW (); @@ -725,17 +681,9 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1) data[-i] = SCM_UNDEFINED; /* Set frame data */ - data[3] = (SCM)ra; - data[2] = (SCM)mvra; - data[1] = (SCM)dl; - - /* Postpone initializing external vars, because if the CONS causes a GC, - we want the stack marker to see the data array formatted as expected. */ - data[0] = SCM_UNDEFINED; - external = SCM_PROGRAM_EXTERNALS (fp[-1]); - for (i = 0; i < bp->nexts; i++) - CONS (external, SCM_UNDEFINED, external); - data[0] = external; + data[2] = (SCM)ra; + data[1] = (SCM)mvra; + data[0] = (SCM)dl; ENTER_HOOK (); APPLY_HOOK (); @@ -860,7 +808,7 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1) CACHE_PROGRAM (); INIT_ARGS (); NEW_FRAME (); - SCM_FRAME_DATA_ADDRESS (fp)[2] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset); + SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset); ENTER_HOOK (); APPLY_HOOK (); NEXT; @@ -1019,12 +967,12 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1) POP (ret); ASSERT (sp == stack_base); - ASSERT (stack_base == data + 3); + ASSERT (stack_base == data + 2); /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp); - ip = SCM_FRAME_BYTE_CAST (data[3]); - fp = SCM_FRAME_STACK_CAST (data[1]); + ip = SCM_FRAME_BYTE_CAST (data[2]); + fp = SCM_FRAME_STACK_CAST (data[0]); { #ifdef VM_ENABLE_STACK_NULLING int nullcount = stack_base - sp; @@ -1040,7 +988,6 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1) /* Restore the last program */ program = SCM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); - CACHE_EXTERNAL (); CHECK_IP (); NEXT; } @@ -1057,16 +1004,16 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1) RETURN_HOOK (); data = SCM_FRAME_DATA_ADDRESS (fp); - ASSERT (stack_base == data + 3); + ASSERT (stack_base == data + 2); - /* data[2] is the mv return address */ - if (nvalues != 1 && data[2]) + /* data[1] is the mv return address */ + if (nvalues != 1 && data[1]) { int i; /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */ - fp = SCM_FRAME_STACK_CAST (data[1]); + ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */ + fp = SCM_FRAME_STACK_CAST (data[0]); /* Push return values, and the number of values */ for (i = 0; i < nvalues; i++) @@ -1085,8 +1032,8 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1) continuation.) */ /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */ - fp = SCM_FRAME_STACK_CAST (data[1]); + ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */ + fp = SCM_FRAME_STACK_CAST (data[0]); /* Push first value */ *++sp = stack_base[1]; @@ -1101,7 +1048,6 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1) /* Restore the last program */ program = SCM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); - CACHE_EXTERNAL (); CHECK_IP (); NEXT; } diff --git a/libguile/vm.c b/libguile/vm.c index f753ea251..957baf6fe 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -259,7 +259,7 @@ really_make_boot_program (long nargs) u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes)); ret = scm_make_program (scm_bytecode_to_objcode (u8vec), - SCM_BOOL_F, SCM_EOL); + SCM_BOOL_F, SCM_BOOL_F); SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT); return ret; @@ -663,7 +663,7 @@ SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0, SCM scm_load_compiled_with_vm (SCM file) { SCM program = scm_make_program (scm_load_objcode (file), - SCM_BOOL_F, SCM_EOL); + SCM_BOOL_F, SCM_BOOL_F); return scm_c_vm_run (scm_the_vm (), program, NULL, 0); } diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm index 76c1cbcb9..a783a4e5e 100644 --- a/module/language/objcode/spec.scm +++ b/module/language/objcode/spec.scm @@ -1,6 +1,6 @@ ;;; Guile Lowlevel Intermediate Language -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -31,7 +31,7 @@ (if env (car env) (current-module))) (define (objcode-env-externals env) - (if env (cdr env) '())) + (and env (vector? (cdr env)) (cdr env))) (define (objcode->value x e opts) (let ((thunk (make-program x #f (objcode-env-externals e)))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 9db4a754b..99021ed05 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -1,6 +1,6 @@ ;;; Guile VM program functions -;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -31,16 +31,15 @@ program-properties program-property program-documentation program-name program-arguments - program-arity program-external-set! program-meta + program-arity program-meta program-objcode program? program-objects - program-module program-base program-external)) + program-module program-base program-free-vars)) (load-extension "libguile" "scm_init_programs") (define arity:nargs car) (define arity:nrest cadr) (define arity:nlocs caddr) -(define arity:nexts cadddr) (define (make-binding name extp index start end) (list name extp index start end)) From 57ab0671d71bd6e485784f46b6dea4708661082d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jul 2009 14:36:22 +0200 Subject: [PATCH 300/375] rename "closure-ref" to "free-ref"; s/vars/variables/ in some names * libguile/programs.h: * libguile/programs.c: (SCM_PROGRAM_FREE_VARIABLES): Rename from SCM_PROGRAM_FREE_VARS. Callers changed. * libguile/programs.c (scm_make_program): Rename arg to "free_variables". (scm_program_free_variables): Rename from program-free-vars. * libguile/vm-engine.h: * libguile/vm-engine.c (VM_CHECK_FREE_VARIABLES): Rename from VM_CHECK_CLOSURE. (vm_engine, CACHE_PROGRAM): Rename closure and closure_count to free_vars and free_vars_vount. * libguile/vm-i-system.c (FREE_VARIABLE_REF): Rename from CLOSURE_REF. (free-ref, free-boxed-ref, free-boxed-set): Rename from closure-ref, closure-boxed-ref, closure-boxed-set. (make-closure): Renamed from make-closure2. * module/language/glil/compile-assembly.scm (glil->assembly): Hack to never write out the the old "make-closure" instruction. Will fix better later. Change to emit free-ref etc instead of closure-ref. * module/language/tree-il/compile-glil.scm (flatten): Emit make-closure instead of make-closure2, now that the old make-closure is gone. * module/system/vm/program.scm (system): Rename program-free-vars to program-free-variables. * test-suite/tests/tree-il.test ("lambda"): Update for make-closure. --- libguile/programs.c | 22 ++++++++++----------- libguile/programs.h | 6 +++--- libguile/vm-engine.c | 16 +++++++-------- libguile/vm-engine.h | 18 ++++++++--------- libguile/vm-i-system.c | 24 +++++++++++------------ module/language/glil/compile-assembly.scm | 6 +++--- module/language/tree-il/compile-glil.scm | 2 +- module/system/vm/program.scm | 2 +- test-suite/tests/tree-il.test | 2 +- 9 files changed, 49 insertions(+), 49 deletions(-) diff --git a/libguile/programs.c b/libguile/programs.c index 9e74f98e3..5c43ac525 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -36,7 +36,7 @@ scm_t_bits scm_tc16_program; static SCM write_program = SCM_BOOL_F; SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, - (SCM objcode, SCM objtable, SCM free_vars), + (SCM objcode, SCM objtable, SCM free_variables), "") #define FUNC_NAME s_scm_make_program { @@ -45,12 +45,12 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, objtable = SCM_BOOL_F; else if (scm_is_true (objtable)) SCM_VALIDATE_VECTOR (2, objtable); - if (SCM_UNLIKELY (SCM_UNBNDP (free_vars))) - free_vars = SCM_BOOL_F; - else if (free_vars != SCM_BOOL_F) - SCM_VALIDATE_VECTOR (3, free_vars); + if (SCM_UNLIKELY (SCM_UNBNDP (free_variables))) + free_variables = SCM_BOOL_F; + else if (free_variables != SCM_BOOL_F) + SCM_VALIDATE_VECTOR (3, free_variables); - SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_vars); + SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables); } #undef FUNC_NAME @@ -59,8 +59,8 @@ program_mark (SCM obj) { if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj))) scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj)); - if (scm_is_true (SCM_PROGRAM_FREE_VARS (obj))) - scm_gc_mark (SCM_PROGRAM_FREE_VARS (obj)); + if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj))) + scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj)); return SCM_PROGRAM_OBJCODE (obj); } @@ -293,13 +293,13 @@ scm_c_program_source (SCM program, size_t ip) return source; /* (addr . (filename . (line . column))) */ } -SCM_DEFINE (scm_program_free_vars, "program-free-vars", 1, 0, 0, +SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0, (SCM program), "") -#define FUNC_NAME s_scm_program_free_vars +#define FUNC_NAME s_scm_program_free_variables { SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_FREE_VARS (program); + return SCM_PROGRAM_FREE_VARIABLES (program); } #undef FUNC_NAME diff --git a/libguile/programs.h b/libguile/programs.h index 0564139f7..040e8ea2c 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -35,12 +35,12 @@ SCM_API scm_t_bits scm_tc16_program; #define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x)) #define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x)) #define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x)) -#define SCM_PROGRAM_FREE_VARS(x) (SCM_SMOB_OBJECT_3 (x)) +#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x)) #define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x))) #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT) -SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_vars); +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables); SCM_API SCM scm_program_p (SCM obj); SCM_API SCM scm_program_base (SCM program); @@ -53,7 +53,7 @@ SCM_API SCM scm_program_properties (SCM program); SCM_API SCM scm_program_name (SCM program); SCM_API SCM scm_program_objects (SCM program); SCM_API SCM scm_program_module (SCM program); -SCM_API SCM scm_program_free_vars (SCM program); +SCM_API SCM scm_program_free_variables (SCM program); SCM_API SCM scm_program_objcode (SCM program); SCM_API SCM scm_c_program_source (SCM program, size_t ip); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 8a0c92d24..98a6e491b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -22,13 +22,13 @@ #define VM_USE_HOOKS 0 /* Various hooks */ #define VM_USE_CLOCK 0 /* Bogoclock */ #define VM_CHECK_OBJECT 1 /* Check object table */ -#define VM_CHECK_CLOSURE 1 /* Check closure vars */ +#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */ #define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 #define VM_USE_CLOCK 1 #define VM_CHECK_OBJECT 1 -#define VM_CHECK_CLOSURE 1 +#define VM_CHECK_FREE_VARIABLES 1 #define VM_PUSH_DEBUG_FRAMES 1 #else #error unknown debug engine VM_ENGINE @@ -47,8 +47,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* Cache variables */ struct scm_objcode *bp = NULL; /* program base pointer */ - SCM *closure = NULL; /* closure variables */ - size_t closure_count = 0; /* length of CLOSURE */ + SCM *free_vars = NULL; /* free variables */ + size_t free_vars_count = 0; /* length of FREE_VARS */ SCM *objects = NULL; /* constant objects */ size_t object_count = 0; /* length of OBJECTS */ SCM *stack_base = vp->stack_base; /* stack base address */ @@ -234,9 +234,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) goto vm_error; #endif -#if VM_CHECK_CLOSURE - vm_error_closure: - err_msg = scm_from_locale_string ("VM: Invalid closure variable access"); +#if VM_CHECK_FREE_VARIABLES + vm_error_free_variable: + err_msg = scm_from_locale_string ("VM: Invalid free variable access"); finish_args = SCM_EOL; goto vm_error; #endif @@ -254,7 +254,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) #undef VM_USE_HOOKS #undef VM_USE_CLOCK #undef VM_CHECK_OBJECT -#undef VM_CHECK_CLOSURE +#undef VM_CHECK_FREE_VARIABLE #undef VM_PUSH_DEBUG_FRAMES /* diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index b860bf151..15ebb539e 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -152,16 +152,16 @@ } \ } \ { \ - SCM c = SCM_PROGRAM_FREE_VARS (program); \ + SCM c = SCM_PROGRAM_FREE_VARIABLES (program); \ if (SCM_I_IS_VECTOR (c)) \ { \ - closure = SCM_I_VECTOR_WELTS (c); \ - closure_count = SCM_I_VECTOR_LENGTH (c); \ + free_vars = SCM_I_VECTOR_WELTS (c); \ + free_vars_count = SCM_I_VECTOR_LENGTH (c); \ } \ else \ { \ - closure = NULL; \ - closure_count = 0; \ + free_vars = NULL; \ + free_vars_count = 0; \ } \ } \ } @@ -189,11 +189,11 @@ #define CHECK_OBJECT(_num) #endif -#if VM_CHECK_CLOSURE -#define CHECK_CLOSURE(_num) \ - do { if (SCM_UNLIKELY ((_num) >= closure_count)) goto vm_error_closure; } while (0) +#if VM_CHECK_FREE_VARIABLES +#define CHECK_FREE_VARIABLE(_num) \ + do { if (SCM_UNLIKELY ((_num) >= free_vars_count)) goto vm_error_free_variable; } while (0) #else -#define CHECK_CLOSURE(_num) +#define CHECK_FREE_VARIABLE(_num) #endif diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index a7e05c83b..e12217ecc 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -248,7 +248,7 @@ VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED) -#define CLOSURE_REF(i) closure[i] +#define FREE_VARIABLE_REF(i) free_vars[i] /* ref */ @@ -1138,41 +1138,41 @@ VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (60, closure_ref, "closure-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1) { scm_t_uint8 idx = FETCH (); - CHECK_CLOSURE (idx); - PUSH (CLOSURE_REF (idx)); + CHECK_FREE_VARIABLE (idx); + PUSH (FREE_VARIABLE_REF (idx)); NEXT; } -/* no closure-set -- if a var is assigned, it should be in a box */ +/* no free-set -- if a var is assigned, it should be in a box */ -VM_DEFINE_INSTRUCTION (61, closure_boxed_ref, "closure-boxed-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1) { SCM v; scm_t_uint8 idx = FETCH (); - CHECK_CLOSURE (idx); - v = CLOSURE_REF (idx); + CHECK_FREE_VARIABLE (idx); + v = FREE_VARIABLE_REF (idx); ASSERT_BOUND_VARIABLE (v); PUSH (VARIABLE_REF (v)); NEXT; } -VM_DEFINE_INSTRUCTION (62, closure_boxed_set, "closure-boxed-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0) { SCM v, val; scm_t_uint8 idx = FETCH (); POP (val); - CHECK_CLOSURE (idx); - v = CLOSURE_REF (idx); + CHECK_FREE_VARIABLE (idx); + v = FREE_VARIABLE_REF (idx); ASSERT_BOUND_VARIABLE (v); VARIABLE_SET (v, val); NEXT; } -VM_DEFINE_INSTRUCTION (63, make_closure2, "make-closure2", 0, 2, 1) +VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1) { SCM vect; POP (vect); diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index b2ea8dcab..cecfd86b4 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -178,7 +178,7 @@ (emit-code (align-program prog addr))) (else (let ((table (dump-object (make-object-table objects) addr)) - (closure (if (> closure-level 0) '((make-closure)) '()))) + (closure '())) (cond (object-alist ;; if we are being compiled from something with an object @@ -267,8 +267,8 @@ ((empty-box) 'empty-box) (else (error "what" op))) (case op - ((ref) (if boxed? 'closure-boxed-ref 'closure-ref)) - ((set) (if boxed? 'closure-boxed-set (error "what." glil))) + ((ref) (if boxed? 'free-boxed-ref 'free-ref)) + ((set) (if boxed? 'free-boxed-set (error "what." glil))) (else (error "what" op)))) ,index)))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 29f4683c1..f8410a51d 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -503,7 +503,7 @@ (else (error "what" x loc)))) free-locs) (emit-code #f (make-glil-call 'vector (length free-locs))) - (emit-code #f (make-glil-call 'make-closure2 2)))) + (emit-code #f (make-glil-call 'make-closure 2)))) (if (eq? context 'tail) (emit-code #f (make-glil-call 'return 1))))))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 99021ed05..5fd81b4a6 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -33,7 +33,7 @@ program-arity program-meta program-objcode program? program-objects - program-module program-base program-free-vars)) + program-module program-base program-free-variables)) (load-extension "libguile" "scm_init_programs") diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 21efa8e31..e4979c15d 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -376,7 +376,7 @@ (lexical #f #f ref 0) (call return 1)) (lexical #t #f ref 0) (call vector 1) - (call make-closure2 2) + (call make-closure 2) (call return 1)) (call return 1)))) From 476e35728136b2d504855f3e2e4922ed72a41101 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jul 2009 16:50:47 +0200 Subject: [PATCH 301/375] remove all mentions of "external" from the compiler and related code With this, GHIL is effectively bitrotten. I need to port the ECMAScript compiler to tree-il, then I'll remove it. * module/language/assembly.scm (byte-length): * module/language/assembly/compile-bytecode.scm (write-bytecode): * module/language/assembly/decompile-bytecode.scm (decode-load-program): * module/language/assembly/disassemble.scm (disassemble-load-program): (disassemble-free-vars, code-annotation): * module/language/glil.scm (, ) (, parse-glil, unparse-glil): * module/language/glil/compile-assembly.scm (make-meta): (compile-assembly, glil->assembly): * module/language/glil/decompile-assembly.scm (decompile-toplevel): (decompile-load-program): * module/language/objcode/spec.scm (decompile-value): * module/language/tree-il/compile-glil.scm (flatten-lambda): * module/system/vm/frame.scm (frame-binding-ref): (frame-binding-set!): * module/system/vm/program.scm (binding:boxed?): * module/system/vm/trace.scm (trace-next): * test-suite/tests/asm-to-bytecode.test ("compiler"): * test-suite/tests/tree-il.test: Remove all mentions of "external", and of . Docs updates will come soon. --- module/language/assembly.scm | 4 +- module/language/assembly/compile-bytecode.scm | 5 +- .../language/assembly/decompile-bytecode.scm | 6 +- module/language/assembly/disassemble.scm | 40 +++--- module/language/glil.scm | 45 ++---- module/language/glil/compile-assembly.scm | 121 +++++++--------- module/language/glil/decompile-assembly.scm | 20 +-- module/language/objcode/spec.scm | 13 +- module/language/tree-il/compile-glil.scm | 2 +- module/system/repl/command.scm | 1 - module/system/vm/frame.scm | 47 +++--- module/system/vm/program.scm | 10 +- module/system/vm/trace.scm | 5 +- test-suite/tests/asm-to-bytecode.test | 12 +- test-suite/tests/tree-il.test | 134 +++++++++--------- 15 files changed, 196 insertions(+), 269 deletions(-) diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 3a0b3873e..0ad94be84 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -28,7 +28,7 @@ assembly-pack assembly-unpack object->assembly assembly->object)) -;; nargs, nrest, nlocs, nexts, len, metalen +;; nargs, nrest, nlocs, , len, metalen (define *program-header-len* (+ 1 1 1 1 4 4)) ;; lengths are encoded in 3 bytes @@ -54,7 +54,7 @@ (+ 1 *len-len* (bytevector-length bv))) ((define ,str) (+ 1 *len-len* (string-length str))) - ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code) + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) ((,inst . _) (guard (>= (instruction-length inst) 0)) (+ 1 (instruction-length inst))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 4b9f7b701..0a1489845 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -89,12 +89,11 @@ (len (instruction-length inst))) (write-byte opcode) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,nexts - ,labels ,length ,meta . ,code) + ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code) (write-byte nargs) (write-byte nrest) (write-byte nlocs) - (write-byte nexts) + (write-byte 0) ;; what used to be nexts (write-uint32 length) (write-uint32 (if meta (1- (byte-length meta)) 0)) (letrec ((i 0) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index fdf27ec62..56f58f750 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -1,6 +1,6 @@ ;;; Guile VM code converters -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -49,7 +49,7 @@ (- x (ash 1 16))))) (define (decode-load-program pop) - (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop)) + (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (unused (pop)) (a (pop)) (b (pop)) (c (pop)) (d (pop)) (e (pop)) (f (pop)) (g (pop)) (h (pop)) (len (+ a (ash b 8) (ash c 16) (ash d 24))) @@ -74,7 +74,7 @@ (cond ((> i len) (error "error decoding program -- read too many bytes" out)) ((= i len) - `(load-program ,nargs ,nrest ,nlocs ,nexts + `(load-program ,nargs ,nrest ,nlocs ,(map (lambda (x) (cons (cdr x) (car x))) (reverse labels)) ,len diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index 0a35050b3..d41c8161d 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -1,6 +1,6 @@ ;;; Guile VM code converters -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -35,12 +35,11 @@ (define (disassemble-load-program asm env) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code) + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) (let ((objs (and env (assq-ref env 'objects))) + (free-vars (and env (assq-ref env 'free-vars))) (meta (and env (assq-ref env 'meta))) - (exts (and env (assq-ref env 'exts))) (blocs (and env (assq-ref env 'blocs))) - (bexts (and env (assq-ref env 'bexts))) (srcs (and env (assq-ref env 'sources)))) (let lp ((pos 0) (code code) (programs '())) (cond @@ -63,13 +62,13 @@ (acons sym asm programs)))) (else (print-info pos asm - (code-annotation end asm objs nargs blocs bexts + (code-annotation end asm objs nargs blocs labels) (and=> (and srcs (assq end srcs)) source->string)) (lp (+ pos (byte-length asm)) (cdr code) programs))))))) - (if (pair? exts) - (disassemble-externals exts)) + (if (pair? free-vars) + (disassemble-free-vars free-vars)) (if meta (disassemble-meta meta)) @@ -92,13 +91,12 @@ ((= n len) (newline)) (print-info n (vector-ref objs n) #f #f)))) -(define (disassemble-externals exts) - (display "Externals:\n\n") - (let ((len (length exts))) - (do ((n 0 (1+ n)) - (l exts (cdr l))) - ((null? l) (newline)) - (print-info n (car l) #f #f)))) +(define (disassemble-free-vars free-vars) + (display "Free variables:\n\n") + (let ((i 0)) + (cond ((< i (vector-length free-vars)) + (print-info i (vector-ref free-vars i) #f #f) + (lp (1+ i)))))) (define-macro (unless test . body) `(if (not ,test) (begin ,@body))) @@ -122,7 +120,7 @@ (define (make-int16 byte1 byte2) (+ (* byte1 256) byte2)) -(define (code-annotation end-addr code objs nargs blocs bexts labels) +(define (code-annotation end-addr code objs nargs blocs labels) (let* ((code (assembly-unpack code)) (inst (car code)) (args (cdr code))) @@ -133,7 +131,7 @@ (list "-> ~A" (assq-ref labels (car args)))) ((object-ref) (and objs (list "~s" (vector-ref objs (car args))))) - ((local-ref local-set) + ((local-ref local-boxed-ref local-set local-boxed-set) (and blocs (let lp ((bindings (list-ref blocs (car args)))) (and (pair? bindings) @@ -143,13 +141,9 @@ (list "`~a'~@[ (arg)~]" (binding:name b) (< (binding:index b) nargs)) (lp (cdr bindings)))))))) - ((external-ref external-set) - (and bexts - (if (< (car args) (length bexts)) - (let ((b (list-ref bexts (car args)))) - (list "`~a'~@[ (arg)~]" - (binding:name b) (< (binding:index b) nargs))) - (list "(closure variable)")))) + ((free-ref free-boxed-ref free-boxed-set) + ;; FIXME: we can do better than this + (list "(closure variable)")) ((toplevel-ref toplevel-set) (and objs (let ((v (vector-ref objs (car args)))) diff --git a/module/language/glil.scm b/module/language/glil.scm index 4dff8178b..0777073f6 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -24,9 +24,9 @@ #:use-module ((srfi srfi-1) #:select (fold)) #:export ( make-glil-program glil-program? - glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts - glil-program-meta glil-program-body glil-program-closure-level - + glil-program-nargs glil-program-nrest glil-program-nlocs + glil-program-meta glil-program-body + make-glil-bind glil-bind? glil-bind-vars @@ -43,12 +43,6 @@ make-glil-const glil-const? glil-const-obj - make-glil-local glil-local? - glil-local-op glil-local-index - - make-glil-external glil-external? - glil-external-op glil-external-depth glil-external-index - make-glil-lexical glil-lexical? glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index @@ -77,7 +71,7 @@ (define-type ( #:printer print-glil) ;; Meta operations - ( nargs nrest nlocs nexts meta body (closure-level #f)) + ( nargs nrest nlocs meta body) ( vars) ( vars rest) () @@ -86,8 +80,6 @@ () ( obj) ;; Variables - ( op index) - ( op depth index) ( local? boxed? op index) ( op name) ( op mod name public?) @@ -97,35 +89,18 @@ ( inst nargs) ( nargs ra)) -(define (compute-closure-level body) - (fold (lambda (x ret) - (record-case x - (( closure-level) (max ret closure-level)) - (( depth) (max ret depth)) - (else ret))) - 0 body)) - -(define %make-glil-program make-glil-program) -(define (make-glil-program . args) - (let ((prog (apply %make-glil-program args))) - (if (not (glil-program-closure-level prog)) - (set! (glil-program-closure-level prog) - (compute-closure-level (glil-program-body prog)))) - prog)) - + (define (parse-glil x) (pmatch x - ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body) - (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body))) + ((program ,nargs ,nrest ,nlocs ,meta . ,body) + (make-glil-program nargs nrest nlocs meta (map parse-glil body))) ((bind . ,vars) (make-glil-bind vars)) ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) ((unbind) (make-glil-unbind)) ((source ,props) (make-glil-source props)) ((void) (make-glil-void)) ((const ,obj) (make-glil-const obj)) - ((local ,op ,index) (make-glil-local op index)) - ((external ,op ,depth ,index) (make-glil-external op depth index)) ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) @@ -139,8 +114,8 @@ (define (unparse-glil glil) (record-case glil ;; meta - (( nargs nrest nlocs nexts meta body) - `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body))) + (( nargs nrest nlocs meta body) + `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body))) (( vars) `(bind ,@vars)) (( vars rest) `(mv-bind ,vars ,rest)) (() `(unbind)) @@ -149,8 +124,6 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op depth index) - `(external ,op ,depth ,index)) (( local? boxed? op index) `(lexical ,local? ,boxed? ,op ,index)) (( op name) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index cecfd86b4..c7e26a825 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -72,7 +72,7 @@ (if (and (null? bindings) (null? sources) (null? tail)) #f (compile-assembly - (make-glil-program 0 0 0 0 '() + (make-glil-program 0 0 0 '() (list (make-glil-const `(,bindings ,sources ,@tail)) (make-glil-call 'return 1)))))) @@ -128,13 +128,13 @@ (define (compile-assembly glil) (receive (code . _) - (glil->assembly glil '() '(()) '() '() #f -1) + (glil->assembly glil #t '(()) '() '() #f -1) (car code))) (define (make-object-table objects) (and (not (null? objects)) (list->vector (cons #f objects)))) -(define (glil->assembly glil nexts-stack bindings +(define (glil->assembly glil toplevel? bindings source-alist label-alist object-alist addr) (define (emit-code x) (values (map assembly-pack x) bindings source-alist label-alist object-alist)) @@ -142,60 +142,56 @@ (values (map assembly-pack x) bindings source-alist label-alist object-alist)) (record-case glil - (( nargs nrest nlocs nexts meta body closure-level) - (let ((toplevel? (null? nexts-stack))) - (define (process-body) - (let ((nexts-stack (cons nexts nexts-stack))) - (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) - (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) - (cond - ((null? body) - (values (reverse code) - (close-all-bindings bindings addr) - (limn-sources (reverse! source-alist)) - (reverse label-alist) - (and object-alist (map car (reverse object-alist))) - addr)) - (else - (receive (subcode bindings source-alist label-alist object-alist) - (glil->assembly (car body) nexts-stack bindings - source-alist label-alist object-alist addr) - (lp (cdr body) (append (reverse subcode) code) - bindings source-alist label-alist object-alist - (addr+ addr subcode)))))))) + (( nargs nrest nlocs meta body) + (define (process-body) + (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) + (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) + (cond + ((null? body) + (values (reverse code) + (close-all-bindings bindings addr) + (limn-sources (reverse! source-alist)) + (reverse label-alist) + (and object-alist (map car (reverse object-alist))) + addr)) + (else + (receive (subcode bindings source-alist label-alist object-alist) + (glil->assembly (car body) #f bindings + source-alist label-alist object-alist addr) + (lp (cdr body) (append (reverse subcode) code) + bindings source-alist label-alist object-alist + (addr+ addr subcode))))))) - (receive (code bindings sources labels objects len) - (process-body) - (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels - ,len - ,(make-meta bindings sources meta) - . ,code))) - (cond - (toplevel? - ;; toplevel bytecode isn't loaded by the vm, no way to do - ;; object table or closure capture (not in the bytecode, - ;; anyway) - (emit-code (align-program prog addr))) - (else - (let ((table (dump-object (make-object-table objects) addr)) - (closure '())) - (cond - (object-alist - ;; if we are being compiled from something with an object - ;; table, cache the program there - (receive (i object-alist) - (object-index-and-alist (make-subprogram table prog) - object-alist) - (emit-code/object `(,(if (< i 256) - `(object-ref ,i) - `(long-object-ref ,(quotient i 256) - ,(modulo i 256))) - ,@closure) - object-alist))) - (else - ;; otherwise emit a load directly - (emit-code `(,@table ,@(align-program prog (addr+ addr table)) - ,@closure))))))))))) + (receive (code bindings sources labels objects len) + (process-body) + (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels + ,len + ,(make-meta bindings sources meta) + . ,code))) + (cond + (toplevel? + ;; toplevel bytecode isn't loaded by the vm, no way to do + ;; object table or closure capture (not in the bytecode, + ;; anyway) + (emit-code (align-program prog addr))) + (else + (let ((table (dump-object (make-object-table objects) addr))) + (cond + (object-alist + ;; if we are being compiled from something with an object + ;; table, cache the program there + (receive (i object-alist) + (object-index-and-alist (make-subprogram table prog) + object-alist) + (emit-code/object `(,(if (< i 256) + `(object-ref ,i) + `(long-object-ref ,(quotient i 256) + ,(modulo i 256)))) + object-alist))) + (else + ;; otherwise emit a load directly + (emit-code `(,@table ,@(align-program prog (addr+ addr table)))))))))))) + (( vars) (values '() @@ -244,19 +240,6 @@ ,(modulo i 256)))) object-alist))))) - (( op index) - (emit-code (if (eq? op 'ref) - `((local-ref ,index)) - `((local-set ,index))))) - - (( op depth index) - (emit-code (let lp ((d depth) (n 0) (stack nexts-stack)) - (if (> d 0) - (lp (1- d) (+ n (car stack)) (cdr stack)) - (if (eq? op 'ref) - `((external-ref ,(+ n index))) - `((external-set ,(+ n index)))))))) - (( local? boxed? op index) (emit-code `((,(if local? diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index 502ef8034..3cb887d44 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@ -1,6 +1,6 @@ ;;; Guile VM code converters -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -31,8 +31,8 @@ (define (decompile-toplevel x) (pmatch x - ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body) - (decompile-load-program nargs nrest nlocs nexts + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body) + (decompile-load-program nargs nrest nlocs (decompile-meta meta) body labels #f)) (else @@ -56,7 +56,7 @@ ((glil-program? (car in)) (lp (cdr in) (cons (car in) out))) (else (lp (cdr in) (cons (make-glil-const (car l)) out)))))) -(define (decompile-load-program nargs nrest nlocs nexts meta body labels +(define (decompile-load-program nargs nrest nlocs meta body labels objects) (let ((glil-labels (sort (map (lambda (x) (cons (cdr x) (make-glil-label (car x)))) @@ -100,19 +100,11 @@ (cond ((null? in) (or (null? stack) (error "leftover stack insts" stack body)) - (make-glil-program nargs nrest nlocs nexts props (reverse out) #f)) + (make-glil-program nargs nrest nlocs props (reverse out) #f)) ((pop-bindings! pos) => (lambda (bindings) (lp in stack - (cons (make-glil-bind - (map (lambda (x) - (let ((name (binding:name x)) - (i (binding:index x))) - (cond - ((binding:extp x) `(,name external ,i)) - ((< i nargs) `(,name argument ,i)) - (else `(,name local ,(- i nargs)))))) - bindings)) + (cons (make-glil-bind bindings) out) pos))) ((pop-unbindings! pos) diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm index a783a4e5e..4cb600f1d 100644 --- a/module/language/objcode/spec.scm +++ b/module/language/objcode/spec.scm @@ -66,23 +66,16 @@ ((program? x) (let ((objs (program-objects x)) (meta (program-meta x)) - (exts (program-external x)) + (free-vars (program-free-variables x)) (binds (program-bindings x)) (srcs (program-sources x)) (nargs (arity:nargs (program-arity x)))) - (let ((blocs (and binds - (collapse-locals - (append (list-head binds nargs) - (filter (lambda (x) (not (binding:extp x))) - (list-tail binds nargs)))))) - (bexts (and binds - (filter binding:extp binds)))) + (let ((blocs (and binds (collapse-locals binds)))) (values (program-objcode x) `((objects . ,objs) (meta . ,(and meta (meta))) - (exts . ,exts) + (free-vars . ,free-vars) (blocs . ,blocs) - (bexts . ,bexts) (sources . ,srcs)))))) ((objcode? x) (values x #f)) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index f8410a51d..f1d86e3f9 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -172,7 +172,7 @@ (1+ n) 1)))) (let ((nlocs (car (hashq-ref allocation x)))) (make-glil-program - nargs nrest nlocs 0 (lambda-meta x) + nargs nrest nlocs (lambda-meta x) (with-output-to-code (lambda (emit-code) ;; write bindings and source debugging info diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 6f45bd7f6..a99e1bae9 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -386,7 +386,6 @@ Trace execution. -s Display stack -l Display local variables - -e Display external variables -b Bytecode level trace" (apply vm-trace (repl-vm repl) (repl-compile repl (repl-parse repl form)) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 33a1e1b60..332cd6172 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -1,6 +1,6 @@ ;;; Guile VM frame functions -;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;; Copyright (C) 2005 Ludovic Courtès ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -27,20 +27,20 @@ vm-frame-program vm-frame-local-ref vm-frame-local-set! vm-frame-return-address vm-frame-mv-return-address - vm-frame-dynamic-link vm-frame-external-link + vm-frame-dynamic-link vm-frame-stack vm-frame-number vm-frame-address - make-frame-chain - print-frame print-frame-chain-as-backtrace - frame-arguments frame-local-variables frame-external-variables - frame-environment - frame-variable-exists? frame-variable-ref frame-variable-set! - frame-object-name - frame-local-ref frame-external-link frame-local-set! - frame-return-address frame-program - frame-dynamic-link heap-frame?)) + make-frame-chain + print-frame print-frame-chain-as-backtrace + frame-arguments frame-local-variables + frame-environment + frame-variable-exists? frame-variable-ref frame-variable-set! + frame-object-name + frame-local-ref frame-local-set! + frame-return-address frame-program + frame-dynamic-link heap-frame?)) (load-extension "libguile" "scm_init_frames") @@ -158,24 +158,19 @@ (l '() (cons (frame-local-ref frame n) l))) ((< n 0) l)))) -(define (frame-external-variables frame) - (frame-external-link frame)) - -(define (frame-external-ref frame index) - (list-ref (frame-external-link frame) index)) - -(define (frame-external-set! frame index val) - (list-set! (frame-external-link frame) index val)) - (define (frame-binding-ref frame binding) - (if (binding:extp binding) - (frame-external-ref frame (binding:index binding)) - (frame-local-ref frame (binding:index binding)))) + (let ((x (frame-local-ref frame (binding:index binding)))) + (if (and (binding:boxed? binding) (variable? x)) + (variable-ref x) + x))) (define (frame-binding-set! frame binding val) - (if (binding:extp binding) - (frame-external-set! frame (binding:index binding) val) - (frame-local-set! frame (binding:index binding) val))) + (if (binding:boxed? binding) + (let ((v (frame-local-ref frame binding))) + (if (variable? v) + (variable-set! v val) + (frame-local-set! frame binding (make-variable val)))) + (frame-local-set! frame binding val))) ;; FIXME handle #f program-bindings return (define (frame-bindings frame addr) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 5fd81b4a6..755c606e2 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -21,9 +21,9 @@ (define-module (system vm program) #:export (make-program - arity:nargs arity:nrest arity:nlocs arity:nexts + arity:nargs arity:nrest arity:nlocs - make-binding binding:name binding:extp binding:index + make-binding binding:name binding:boxed? binding:index binding:start binding:end source:addr source:line source:column source:file @@ -41,10 +41,10 @@ (define arity:nrest cadr) (define arity:nlocs caddr) -(define (make-binding name extp index start end) - (list name extp index start end)) +(define (make-binding name boxed? index start end) + (list name boxed? index start end)) (define (binding:name b) (list-ref b 0)) -(define (binding:extp b) (list-ref b 1)) +(define (binding:boxed? b) (list-ref b 1)) (define (binding:index b) (list-ref b 2)) (define (binding:start b) (list-ref b 3)) (define (binding:end b) (list-ref b 4)) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 6ff09a779..d8165f202 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -1,6 +1,6 @@ ;;; Guile VM tracer -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -54,8 +54,7 @@ ((null? opts) (newline)) (case (car opts) ((:s) (puts (truncate! (vm-fetch-stack vm) 3))) - ((:l) (puts (vm-fetch-locals vm))) - ((:e) (puts (vm-fetch-externals vm)))))) + ((:l) (puts (vm-fetch-locals vm)))))) (define (trace-apply vm) (if (vm-option vm 'trace-first) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 01ba84687..d819a3b1b 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -85,28 +85,28 @@ (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u) (char->integer #\x))) - (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return)) + (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) (list->vector `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, nexts + 3 2 1 0 ;; nargs, nrest, nlocs, unused ,@(u32->u8-list 3) ;; len ,@(u32->u8-list 0) ;; metalen make-int8 3 return))) - (comp-test '(load-program 3 2 1 0 () 3 - (load-program 3 2 1 0 () 3 + (comp-test '(load-program 3 2 1 () 3 + (load-program 3 2 1 () 3 #f (make-int8 3) (return)) (make-int8 3) (return)) (list->vector `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, nexts + 3 2 1 0 ;; nargs, nrest, nlocs, unused ,@(u32->u8-list 3) ;; len ,@(u32->u8-list (+ 3 12)) ;; metalen make-int8 3 return - 3 2 1 0 ;; nargs, nrest, nlocs, nexts + 3 2 1 0 ;; nargs, nrest, nlocs, unused ,@(u32->u8-list 3) ;; len ,@(u32->u8-list 0) ;; metalen make-int8 3 diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index e4979c15d..6634dcdd7 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -64,21 +64,21 @@ (with-test-prefix "void" (assert-tree-il->glil (void) - (program 0 0 0 0 () (void) (call return 1))) + (program 0 0 0 () (void) (call return 1))) (assert-tree-il->glil (begin (void) (const 1)) - (program 0 0 0 0 () (const 1) (call return 1))) + (program 0 0 0 () (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive +) (void) (const 1)) - (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + (program 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil (apply (toplevel foo) (const 1)) - (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) + (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) (assert-tree-il->glil/pmatch (begin (apply (toplevel foo) (const 1)) (void)) - (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) + (program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (label ,l4) @@ -86,26 +86,26 @@ (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel bar))) - (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) (call goto/args 1)))) (with-test-prefix "conditional" (assert-tree-il->glil/pmatch (if (const #t) (const 1) (const 2)) - (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) (const 1) (call return 1) (label ,l2) (const 2) (call return 1)) (eq? l1 l2)) (assert-tree-il->glil/pmatch (begin (if (const #t) (const 1) (const 2)) (const #f)) - (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) (label ,l3) (label ,l4) (const #f) (call return 1)) (eq? l1 l3) (eq? l2 l4)) (assert-tree-il->glil/pmatch (apply (primitive null?) (if (const #t) (const 1) (const 2))) - (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) (const 1) (branch br ,l2) (label ,l3) (const 2) (label ,l4) (call null? 1) (call return 1)) @@ -114,35 +114,35 @@ (with-test-prefix "primitive-ref" (assert-tree-il->glil (primitive +) - (program 0 0 0 0 () (toplevel ref +) (call return 1))) + (program 0 0 0 () (toplevel ref +) (call return 1))) (assert-tree-il->glil (begin (primitive +) (const #f)) - (program 0 0 0 0 () (const #f) (call return 1))) + (program 0 0 0 () (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (primitive +)) - (program 0 0 0 0 () (toplevel ref +) (call null? 1) + (program 0 0 0 () (toplevel ref +) (call null? 1) (call return 1)))) (with-test-prefix "lexical refs" (assert-tree-il->glil (let (x) (y) ((const 1)) (lexical x y)) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (const #f) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call null? 1) (call return 1) (unbind)))) @@ -150,14 +150,14 @@ (with-test-prefix "lexical sets" (assert-tree-il->glil (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 2) (lexical #t #t set 0) (void) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 2) (lexical #t #t set 0) (const #f) (call return 1) (unbind))) @@ -165,7 +165,7 @@ (assert-tree-il->glil (let (x) (y) ((const 1)) (apply (primitive null?) (set! (lexical x y) (const 2)))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1) (unbind)))) @@ -173,205 +173,205 @@ (with-test-prefix "module refs" (assert-tree-il->glil (@ (foo) bar) - (program 0 0 0 0 () + (program 0 0 0 () (module public ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@ (foo) bar) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (module public ref (foo) bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (@ (foo) bar)) - (program 0 0 0 0 () + (program 0 0 0 () (module public ref (foo) bar) (call null? 1) (call return 1))) (assert-tree-il->glil (@@ (foo) bar) - (program 0 0 0 0 () + (program 0 0 0 () (module private ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@@ (foo) bar) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (module private ref (foo) bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (@@ (foo) bar)) - (program 0 0 0 0 () + (program 0 0 0 () (module private ref (foo) bar) (call null? 1) (call return 1)))) (with-test-prefix "module sets" (assert-tree-il->glil (set! (@ (foo) bar) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module public set (foo) bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (@ (foo) bar) (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module public set (foo) bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (@ (foo) bar) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module public set (foo) bar) (void) (call null? 1) (call return 1))) (assert-tree-il->glil (set! (@@ (foo) bar) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module private set (foo) bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (@@ (foo) bar) (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module private set (foo) bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (module private set (foo) bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "toplevel refs" (assert-tree-il->glil (toplevel bar) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref bar) (call return 1))) (assert-tree-il->glil (begin (toplevel bar) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (toplevel bar)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref bar) (call null? 1) (call return 1)))) (with-test-prefix "toplevel sets" (assert-tree-il->glil (set! (toplevel bar) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel set bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (toplevel bar) (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel set bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (toplevel bar) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel set bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "toplevel defines" (assert-tree-il->glil (define bar (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel define bar) (void) (call return 1))) (assert-tree-il->glil (begin (define bar (const 2)) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel define bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (define bar (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (toplevel define bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "constants" (assert-tree-il->glil (const 2) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (call return 1))) (assert-tree-il->glil (begin (const 2) (const #f)) - (program 0 0 0 0 () + (program 0 0 0 () (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (const 2)) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (call null? 1) (call return 1)))) (with-test-prefix "lambda" (assert-tree-il->glil (lambda (x) (y) () (const 2)) - (program 0 0 0 0 () - (program 1 0 0 0 () + (program 0 0 0 () + (program 1 0 0 () (bind (x #f 0)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x x1) (y y1) () (const 2)) - (program 0 0 0 0 () - (program 2 0 0 0 () + (program 0 0 0 () + (program 2 0 0 () (bind (x #f 0) (x1 #f 1)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda x y () (const 2)) - (program 0 0 0 0 () - (program 1 1 0 0 () + (program 0 0 0 () + (program 1 1 0 () (bind (x #f 0)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x . x1) (y . y1) () (const 2)) - (program 0 0 0 0 () - (program 2 1 0 0 () + (program 0 0 0 () + (program 2 1 0 () (bind (x #f 0) (x1 #f 1)) (const 2) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x y)) - (program 0 0 0 0 () - (program 2 1 0 0 () + (program 0 0 0 () + (program 2 1 0 () (bind (x #f 0) (x1 #f 1)) (lexical #t #f ref 0) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x1 y1)) - (program 0 0 0 0 () - (program 2 1 0 0 () + (program 0 0 0 () + (program 2 1 0 () (bind (x #f 0) (x1 #f 1)) (lexical #t #f ref 1) (call return 1)) (call return 1))) (assert-tree-il->glil (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) - (program 0 0 0 0 () - (program 1 0 0 0 () + (program 0 0 0 () + (program 1 0 0 () (bind (x #f 0)) - (program 1 0 0 0 () + (program 1 0 0 () (bind (y #f 0)) (lexical #f #f ref 0) (call return 1)) (lexical #t #f ref 0) @@ -383,12 +383,12 @@ (with-test-prefix "sequence" (assert-tree-il->glil (begin (begin (const 2) (const #f)) (const #t)) - (program 0 0 0 0 () + (program 0 0 0 () (const #t) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (begin (const #f) (const 2))) - (program 0 0 0 0 () + (program 0 0 0 () (const 2) (call null? 1) (call return 1)))) ;; FIXME: binding info for or-hacked locals might bork the disassembler, @@ -400,7 +400,7 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical a b)))) - (program 0 0 1 0 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (call return 1) @@ -417,7 +417,7 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical x y)))) - (program 0 0 2 0 () + (program 0 0 2 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (call return 1) @@ -431,10 +431,10 @@ (with-test-prefix "apply" (assert-tree-il->glil (apply (primitive @apply) (toplevel foo) (toplevel bar)) - (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) (assert-tree-il->glil/pmatch (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (label ,l4) @@ -442,7 +442,7 @@ (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (toplevel ref baz) (call apply 2) (call goto/args 1)))) @@ -450,10 +450,10 @@ (with-test-prefix "call/cc" (assert-tree-il->glil (apply (primitive @call-with-current-continuation) (toplevel foo)) - (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1))) + (program 0 0 0 () (toplevel ref foo) (call goto/cc 1))) (assert-tree-il->glil/pmatch (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (label ,l4) @@ -462,7 +462,7 @@ (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel @call-with-current-continuation) (toplevel bar))) - (program 0 0 0 0 () + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call/cc 1) (call goto/args 1)))) From ccf77d955c875ce95473098af96da9e1bec0b7eb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2009 10:12:01 +0200 Subject: [PATCH 302/375] nlocs is now 16 bits wide * libguile/objcodes.h (struct scm_objcode): Remove the "unused" field -- the old "nexts" -- and expand nlocs to 16 bits. * module/language/assembly/compile-bytecode.scm (write-bytecode): Write the nlocs as a uint16. * module/language/assembly/decompile-bytecode.scm (decode-load-program): Decompile 16-bit nlocs. It seems this decompilation is little-endian :-/ * test-suite/tests/asm-to-bytecode.test: Fix up to understand nlocs as a little-endian value. The test does the right thing regarding endianness. --- libguile/objcodes.h | 3 +- module/language/assembly/compile-bytecode.scm | 7 +- .../language/assembly/decompile-bytecode.scm | 4 +- test-suite/tests/asm-to-bytecode.test | 73 ++++++++++--------- 4 files changed, 47 insertions(+), 40 deletions(-) diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 6727e23e8..d50f6dc94 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -25,8 +25,7 @@ struct scm_objcode { scm_t_uint8 nargs; scm_t_uint8 nrest; - scm_t_uint8 nlocs; - scm_t_uint8 unused; + scm_t_uint16 nlocs; scm_t_uint32 len; /* the maximum index of base[] */ scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of base[] for metadata */ diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 0a1489845..d17e00f2f 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -81,6 +81,10 @@ (let ((inst (car asm)) (args (cdr asm)) + (write-uint16 (case byte-order + ((1234) write-uint16-le) + ((4321) write-uint16-be) + (else (error "unknown endianness" byte-order)))) (write-uint32 (case byte-order ((1234) write-uint32-le) ((4321) write-uint32-be) @@ -92,8 +96,7 @@ ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code) (write-byte nargs) (write-byte nrest) - (write-byte nlocs) - (write-byte 0) ;; what used to be nexts + (write-uint16 nlocs) (write-uint32 length) (write-uint32 (if meta (1- (byte-length meta)) 0)) (letrec ((i 0) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index 56f58f750..231205d08 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -48,8 +48,10 @@ x (- x (ash 1 16))))) +;; FIXME: this is a little-endian disassembly!!! (define (decode-load-program pop) - (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (unused (pop)) + (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop)) + (nlocs (+ nlocs0 (ash nlocs1 8))) (a (pop)) (b (pop)) (c (pop)) (d (pop)) (e (pop)) (f (pop)) (g (pop)) (h (pop)) (len (+ a (ash b 8) (ash c 16) (ash d 24))) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index d819a3b1b..fb598a64b 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -20,16 +20,28 @@ #:use-module (system vm instruction) #:use-module (language assembly compile-bytecode)) +(define (->u8-list sym val) + (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) + (uint32 4 ,bytevector-u32-native-set!)) + sym))) + (or entry (error "unknown sym" sym)) + (let ((bv (make-bytevector (car entry)))) + ((cadr entry) bv 0 val) + (bytevector->u8-list bv)))) + (define (munge-bytecode v) - (let ((newv (make-u8vector (vector-length v)))) - (let lp ((i 0)) - (if (= i (vector-length v)) - newv - (let ((x (vector-ref v i))) - (u8vector-set! newv i (if (symbol? x) - (instruction->opcode x) - x)) - (lp (1+ i))))))) + (let lp ((i 0) (out '())) + (if (= i (vector-length v)) + (list->u8vector (reverse out)) + (let ((x (vector-ref v i))) + (cond + ((symbol? x) + (lp (1+ i) (cons (instruction->opcode x) out))) + ((integer? x) + (lp (1+ i) (cons x out))) + ((pair? x) + (lp (1+ i) (append (reverse (apply ->u8-list x)) out))) + (else (error "bad test bytecode" x))))))) (define (comp-test x y) (let* ((y (munge-bytecode y)) @@ -46,13 +58,6 @@ (lambda () (equal? v y))))) -(define (u32->u8-list x) - ;; Return a 4 uint8 list corresponding to the host's native representation - ;; of X, a uint32. - (let ((bv (make-bytevector 4))) - (bytevector-u32-native-set! bv 0 x) - (bytevector->u8-list bv))) - (with-test-prefix "compiler" (with-test-prefix "asm-to-bytecode" @@ -86,28 +91,26 @@ (char->integer #\x))) (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) - (list->vector - `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, unused - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list 0) ;; metalen - make-int8 3 - return))) + #(load-program + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 0) ;; metalen + make-int8 3 + return)) (comp-test '(load-program 3 2 1 () 3 (load-program 3 2 1 () 3 #f (make-int8 3) (return)) (make-int8 3) (return)) - (list->vector - `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, unused - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list (+ 3 12)) ;; metalen - make-int8 3 - return - 3 2 1 0 ;; nargs, nrest, nlocs, unused - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list 0) ;; metalen - make-int8 3 - return))))) + #(load-program + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 15) ;; metalen + make-int8 3 + return + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 0) ;; metalen + make-int8 3 + return)))) From 80545853d544f347ae991a476d78ccbf4d305ec7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2009 11:00:32 +0200 Subject: [PATCH 303/375] compiler support for nlocs >= 256 * libguile/vm-i-system.c (long-local-ref, long-local-set) (make-variable): New intructions, for handling nlocs >= 256. * module/language/glil/compile-assembly.scm (glil->assembly): Compile with support for nlocs >= 256. --- libguile/vm-i-system.c | 28 +++++++++++++++ module/language/glil/compile-assembly.scm | 44 +++++++++++++++++------ 2 files changed, 62 insertions(+), 10 deletions(-) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index e12217ecc..c2c674d27 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -278,6 +278,16 @@ VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1) +{ + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + PUSH (LOCAL_REF (i)) + ASSERT_BOUND (*sp); + NEXT; +} + VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1) { SCM x = *sp; @@ -354,6 +364,16 @@ VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0) NEXT; } +VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0) +{ + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + LOCAL_SET (i, *sp); + DROP (); + NEXT; +} + VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0) { VARIABLE_SET (sp[0], sp[-1]); @@ -1183,6 +1203,14 @@ VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1) NEXT; } +VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1) +{ + SYNC_BEFORE_GC (); + /* fixme underflow */ + PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); + NEXT; +} + /* (defun renumber-ops () diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index c7e26a825..9a5cae04f 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -242,18 +242,42 @@ (( local? boxed? op index) (emit-code - `((,(if local? - (case op - ((ref) (if boxed? 'local-boxed-ref 'local-ref)) - ((set) (if boxed? 'local-boxed-set 'local-set)) - ((box) 'box) - ((empty-box) 'empty-box) - (else (error "what" op))) - (case op + (if local? + (if (< index 256) + `((,(case op + ((ref) (if boxed? 'local-boxed-ref 'local-ref)) + ((set) (if boxed? 'local-boxed-set 'local-set)) + ((box) 'box) + ((empty-box) 'empty-box) + (else (error "what" op))) + ,index)) + (let ((a (quotient i 256)) + (b (modulo i 256))) + `((,(case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + (else (error "what" op))) + ,index)))) + `((,(case op ((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((set) (if boxed? 'free-boxed-set (error "what." glil))) - (else (error "what" op)))) - ,index)))) + (else (error "what" op))) + ,index))))) (( op name) (case op From 51e9ba2f38675ce5fd161b7df15470abaaf60e0e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2009 12:05:54 +0200 Subject: [PATCH 304/375] increase default stack size to 64 kilowords * libguile/vm.c (VM_DEFAULT_STACK_SIZE): Increase to 64 kilowords. Really, we should simply add overflow handlers, but in the meantime, this will do. --- libguile/vm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/vm.c b/libguile/vm.c index 957baf6fe..41eacd79f 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -325,7 +325,7 @@ resolve_variable (SCM what, SCM program_module) } -#define VM_DEFAULT_STACK_SIZE (16 * 1024) +#define VM_DEFAULT_STACK_SIZE (64 * 1024) #define VM_NAME vm_regular_engine #define FUNC_NAME "vm-regular-engine" From d95eb7f49f721306ffeb0020724093929cb0e206 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2009 12:06:19 +0200 Subject: [PATCH 305/375] fix gensym creation in psyntax * module/ice-9/psyntax.scm (build-lexical-var): Make our gensyms really unique. Before, there was a chance that different lexicals could result in the same gensym. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 3 ++- module/ice-9/psyntax.scm | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 113269b2e..de0db95de 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -54,7 +54,8 @@ (let ((id293 (if (syntax-object?99 id292) (syntax-object-expression100 id292) id292))) - (gensym (symbol->string id293))))) + (gensym + (string-append (symbol->string id293) " "))))) (strip161 (lambda (x294 w295) (if (memq (quote top) (wrap-marks118 w295)) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index f1f6e9ae0..6ecf24ee6 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,6 +1,6 @@ ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2006, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -529,10 +529,10 @@ `(letrec ,(map list vars val-exps) ,body-exp) src)))))) -;; FIXME: wingo: use make-lexical ? +;; FIXME: use a faster gensym (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (gensym (symbol->string id))))) + ((_ src id) (gensym (string-append (symbol->string id) " "))))) (define-structure (syntax-object expression wrap module)) From 74deff3c431245b282903d46eb7e571ace8759f3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2009 12:06:40 +0200 Subject: [PATCH 306/375] check that jumps are within the range of a signed 16-bit int * module/language/assembly/compile-bytecode.scm (write-bytecode): Check that the offset is within the range of a signed int16 value. --- module/language/assembly/compile-bytecode.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index d17e00f2f..80dee833a 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -77,7 +77,10 @@ ;; Ew! (for-each write-byte (bytevector->u8-list bv))) (define (write-break label) - (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2)))) + (let ((offset (- (assq-ref labels label) (+ (get-addr) 2)))) + (cond ((>= offset (ash 1 15)) (error "jump too big" offset)) + ((< offset (- (ash 1 15))) (error "reverse jump too big" offset)) + (else (write-uint16-be offset))))) (let ((inst (car asm)) (args (cdr asm)) From cb8ab66c6657a61797399e5f63c7942ae7cd20e3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Jul 2009 11:20:39 +0200 Subject: [PATCH 307/375] fix vmstack gdb macro for new stack frame layout * gdbinit (vmstack): No more external link. --- gdbinit | 5 ----- 1 file changed, 5 deletions(-) diff --git a/gdbinit b/gdbinit index 381cf8477..b66e3e249 100644 --- a/gdbinit +++ b/gdbinit @@ -148,11 +148,6 @@ define nextframe output $vmdl newline set $vmsp=$vmsp-1 - sputs "el:\t" - output $vmsp - sputs "\t" - gwrite *$vmsp - set $vmsp=$vmsp-1 set $vmnlocs=(int)$vmbp->nlocs while $vmnlocs > 0 sputs "loc #" From 9557ecc6620c83a9254649e63248ce997d749cde Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Jul 2009 11:21:18 +0200 Subject: [PATCH 308/375] fix unused SCM_FRAME_SET_DYNAMIC_LINK macro * libguile/frames.h (SCM_FRAME_SET_DYNAMIC_LINK): Fix for new stack layout, though this macro is not used. --- libguile/frames.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/frames.h b/libguile/frames.h index 1d8a30f8e..1b3153a3e 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -63,7 +63,7 @@ #define SCM_FRAME_DYNAMIC_LINK(fp) \ (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0])) #define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \ - ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl); + ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl); #define SCM_FRAME_VARIABLE(fp,i) fp[i] #define SCM_FRAME_PROGRAM(fp) fp[-1] From 9efc2d1404aa7705f38aa1ceaebf4c4893e68b83 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Jul 2009 11:54:05 +0200 Subject: [PATCH 309/375] fix alignment of subprograms of subprograms * module/language/glil/compile-assembly.scm (glil->assembly) (dump-object): Fix an exciting bug! Subprograms of subprograms were not being aligned correctly, because the code was generated too early. So instead delay dumping the object table until the proper time. --- module/language/glil/compile-assembly.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 9a5cae04f..c4725e27c 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -175,7 +175,7 @@ ;; anyway) (emit-code (align-program prog addr))) (else - (let ((table (dump-object (make-object-table objects) addr))) + (let ((table (make-object-table objects))) (cond (object-alist ;; if we are being compiled from something with an object @@ -190,8 +190,10 @@ object-alist))) (else ;; otherwise emit a load directly - (emit-code `(,@table ,@(align-program prog (addr+ addr table)))))))))))) - + (let ((table-code (dump-object table addr))) + (emit-code + `(,@table-code + ,@(align-program prog (addr+ addr table-code))))))))))))) (( vars) (values '() @@ -370,9 +372,10 @@ ((object->assembly x) => list) ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr)) ((subprogram? x) - `(,@(subprogram-table x) - ,@(align-program (subprogram-prog x) - (addr+ addr (subprogram-table x))))) + (let ((table-code (dump-object (subprogram-table x) addr))) + `(,@table-code + ,@(align-program (subprogram-prog x) + (addr+ addr table-code))))) ((number? x) `((load-number ,(number->string x)))) ((string? x) From 28b119ee3da0f4b14cb87e638794d22843778cda Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Jul 2009 12:56:11 +0200 Subject: [PATCH 310/375] make sure all programs are 8-byte aligned * libguile/objcodes.c (OBJCODE_COOKIE): Bump objcode cookie, as we added to struct scm_objcode. * libguile/objcodes.h (struct scm_objcode): Add a uint32 after metalen and before base, so that if the structure has 8-byte alignment, base will have 8-byte alignment too. (Before, base was 12 bytes from the start of the structure, now it's 16 bytes.) * libguile/vm-engine.h (ASSERT_ALIGNED_PROCEDURE): Add a check that can be turned on with VM_ENABLE_PARANOID_ASSERTIONS. (CACHE_PROGRAM): Call ASSERT_ALIGNED_PROCEDURE. * libguile/vm-i-system.c (long-local-ref): Add a missing semicolon. * libguile/vm.c (really_make_boot_program): Rework to operate directly on a malloc'd buffer, so that the program will be 8-byte aligned. * module/language/assembly.scm (*program-header-len*): Add another 4 for the padding. (object->assembly): Fix case in which we would return (make-int8 0) instead of (make-int8:0). This would throw off compile-assembly.scm's use of addr+. * module/language/assembly/compile-bytecode.scm (write-bytecode): Write out the padding int. * module/language/assembly/decompile-bytecode.scm (decode-load-program): And pop off the padding int too. * module/language/glil/compile-assembly.scm (glil->assembly): Don't pack the assembly, assume that assembly.scm has done it for us. If a program has a meta, pad out the program so that meta will be aligned. * test-suite/tests/asm-to-bytecode.test: Adapt to expect programs to have the extra 4-byte padding int. --- libguile/objcodes.c | 2 +- libguile/objcodes.h | 1 + libguile/vm-engine.h | 4 ++ libguile/vm-i-system.c | 2 +- libguile/vm.c | 47 +++++++------------ module/language/assembly.scm | 6 +-- module/language/assembly/compile-bytecode.scm | 1 + .../language/assembly/decompile-bytecode.scm | 1 + module/language/glil/compile-assembly.scm | 17 ++++--- test-suite/tests/asm-to-bytecode.test | 15 ++++-- 10 files changed, 52 insertions(+), 44 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 5a43edb67..728dd8d13 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -50,7 +50,7 @@ /* The objcode magic header. */ #define OBJCODE_COOKIE \ - "GOOF-0.7-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" + "GOOF-0.8-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" /* The length of the header must be a multiple of 8 bytes. */ verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0); diff --git a/libguile/objcodes.h b/libguile/objcodes.h index d50f6dc94..2bb4e6040 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -29,6 +29,7 @@ struct scm_objcode { scm_t_uint32 len; /* the maximum index of base[] */ scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of base[] for metadata */ + scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */ scm_t_uint8 base[0]; }; diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 15ebb539e..c0f772fb8 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -130,11 +130,14 @@ #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) +#define ASSERT_ALIGNED_PROCEDURE() \ + do { if ((scm_t_bits)bp % 8) abort (); } while (0) #define ASSERT_BOUND(x) \ do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \ } while (0) #else #define CHECK_IP() +#define ASSERT_ALIGNED_PROCEDURE() #define ASSERT_BOUND(x) #endif @@ -143,6 +146,7 @@ { \ if (bp != SCM_PROGRAM_DATA (program)) { \ bp = SCM_PROGRAM_DATA (program); \ + ASSERT_ALIGNED_PROCEDURE (); \ if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \ objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \ object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index c2c674d27..b2cdca5be 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -283,7 +283,7 @@ VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1) unsigned int i = FETCH (); i <<= 8; i += FETCH (); - PUSH (LOCAL_REF (i)) + PUSH (LOCAL_REF (i)); ASSERT_BOUND (*sp); NEXT; } diff --git a/libguile/vm.c b/libguile/vm.c index 41eacd79f..527598b86 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -220,44 +220,33 @@ static SCM sym_vm_run; static SCM sym_vm_error; static SCM sym_debug; -static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len) -{ - scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector"); - memcpy (new_bytes, bytes, len); - return scm_take_u8vector (new_bytes, len); -} - -/* Dummy structure to guarantee 32-bit alignment. */ -struct t_32bit_aligned -{ - scm_t_int32 dummy; - scm_t_uint8 bytes[18]; -}; - static SCM really_make_boot_program (long nargs) { SCM u8vec; - struct t_32bit_aligned bytes = - { - .dummy = 0, - .bytes = { 0, 0, 0, 0, - 0, 0, 0, 0, - 0, 0, 0, 0, - scm_op_mv_call, 0, 0, 1, - scm_op_make_int8_1, scm_op_halt } - }; - + /* Make sure "bytes" is 64-bit aligned. */ + scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1, + scm_op_make_int8_1, + scm_op_halt }; + struct scm_objcode *bp; SCM ret; - /* Set length in current endianness, no meta. */ - ((scm_t_uint32 *) bytes.bytes)[1] = 6; - if (SCM_UNLIKELY (nargs > 255 || nargs < 0)) abort (); - bytes.bytes[13] = (scm_byte_t) nargs; + text[1] = (scm_t_uint8)nargs; - u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes)); + bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text), + "make-u8vector"); + memcpy (bp->base, text, sizeof (text)); + bp->nargs = 0; + bp->nrest = 0; + bp->nlocs = 0; + bp->len = sizeof(text); + bp->metalen = 0; + bp->unused = 0; + + u8vec = scm_take_u8vector ((scm_t_uint8*)bp, + sizeof (struct scm_objcode) + sizeof (text)); ret = scm_make_program (scm_bytecode_to_objcode (u8vec), SCM_BOOL_F, SCM_BOOL_F); SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT); diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 0ad94be84..90b2acc03 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -28,8 +28,8 @@ assembly-pack assembly-unpack object->assembly assembly->object)) -;; nargs, nrest, nlocs, , len, metalen -(define *program-header-len* (+ 1 1 1 1 4 4)) +;; nargs, nrest, nlocs, len, metalen, padding +(define *program-header-len* (+ 1 1 2 4 4 4)) ;; lengths are encoded in 3 bytes (define *len-len* 3) @@ -109,7 +109,7 @@ ((null? x) `(make-eol)) ((and (integer? x) (exact? x)) (cond ((and (<= -128 x) (< x 128)) - `(make-int8 ,(modulo x 256))) + (assembly-pack `(make-int8 ,(modulo x 256)))) ((and (<= -32768 x) (< x 32768)) (let ((n (if (< x 0) (+ x 65536) x))) `(make-int16 ,(quotient n 256) ,(modulo n 256)))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 80dee833a..58afddde0 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -102,6 +102,7 @@ (write-uint16 nlocs) (write-uint32 length) (write-uint32 (if meta (1- (byte-length meta)) 0)) + (write-uint32 0) ; padding (letrec ((i 0) (write (lambda (x) (set! i (1+ i)) (write-byte x))) (get-addr (lambda () i))) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index 231205d08..82459fc6f 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -57,6 +57,7 @@ (len (+ a (ash b 8) (ash c 16) (ash d 24))) (metalen (+ e (ash f 8) (ash g 16) (ash h 24))) (totlen (+ len metalen)) + (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop)) (labels '()) (i 0)) (define (ensure-label rel1 rel2) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index c4725e27c..2e586ec5e 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -137,9 +137,9 @@ (define (glil->assembly glil toplevel? bindings source-alist label-alist object-alist addr) (define (emit-code x) - (values (map assembly-pack x) bindings source-alist label-alist object-alist)) + (values x bindings source-alist label-alist object-alist)) (define (emit-code/object x object-alist) - (values (map assembly-pack x) bindings source-alist label-alist object-alist)) + (values x bindings source-alist label-alist object-alist)) (record-case glil (( nargs nrest nlocs meta body) @@ -164,10 +164,15 @@ (receive (code bindings sources labels objects len) (process-body) - (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels - ,len - ,(make-meta bindings sources meta) - . ,code))) + (let* ((meta (make-meta bindings sources meta)) + (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)) + (prog `(load-program ,nargs ,nrest ,nlocs ,labels + ,(+ len meta-pad) + ,meta + ,@code + ,@(if meta + (make-list meta-pad '(nop)) + '())))) (cond (toplevel? ;; toplevel bytecode isn't loaded by the vm, no way to do diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index fb598a64b..33a2a45f0 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -95,22 +95,29 @@ 3 2 (uint16 1) ;; nargs, nrest, nlocs (uint32 3) ;; len (uint32 0) ;; metalen + (uint32 0) ;; padding make-int8 3 return)) - (comp-test '(load-program 3 2 1 () 3 + ;; the nops are to pad meta to an 8-byte alignment. not strictly + ;; necessary for this test, but representative of the common case. + (comp-test '(load-program 3 2 1 () 8 (load-program 3 2 1 () 3 #f (make-int8 3) (return)) - (make-int8 3) (return)) + (make-int8 3) (return) + (nop) (nop) (nop) (nop) (nop)) #(load-program 3 2 (uint16 1) ;; nargs, nrest, nlocs - (uint32 3) ;; len - (uint32 15) ;; metalen + (uint32 8) ;; len + (uint32 19) ;; metalen + (uint32 0) ;; padding make-int8 3 return + nop nop nop nop nop 3 2 (uint16 1) ;; nargs, nrest, nlocs (uint32 3) ;; len (uint32 0) ;; metalen + (uint32 0) ;; padding make-int8 3 return)))) From e5dc27b86d0eaa470f92cdaa9f4ed2a961338c49 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Jul 2009 14:01:56 +0200 Subject: [PATCH 311/375] increase range of relative jumps by aligning blocks to 8-byte boundaries * libguile/objcodes.c (OBJCODE_COOKIE): Bump again, as our jump offsets are now multiplied by 8. * libguile/vm-i-system.c (BR): Interpret the 16-bit offset as a relative jump to the nearest 8-byte-aligned block -- increasing relative jump range from +/-32K to +/-240K. (mvra): Do the same for the mvra jump. * libguile/vm.c (really_make_boot_program): Align the mvra. * module/language/assembly.scm (align-block): New export, for aligning blocks. * module/language/assembly/compile-bytecode.scm (write-bytecode): Emit jumps to the nearest 8-byte-aligned block. Effectively our range is 18 bits in either direction. I would like to do this differently -- have long-br and long-br-if, and all the other br instructions go to 8 bits only. But the assembler doesn't have an appropriate representation to allow me to do this yet, so for now this is what we have. * module/language/assembly/decompile-bytecode.scm (decode-load-program): Decode the 19-bit jumps. --- libguile/objcodes.c | 2 +- libguile/vm-i-system.c | 20 ++++++++++--------- libguile/vm.c | 2 +- module/language/assembly.scm | 17 +++++++++++----- module/language/assembly/compile-bytecode.scm | 10 ++++++---- .../language/assembly/decompile-bytecode.scm | 3 ++- module/language/glil/compile-assembly.scm | 11 +++++----- 7 files changed, 39 insertions(+), 26 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 728dd8d13..91691a70a 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -50,7 +50,7 @@ /* The objcode magic header. */ #define OBJCODE_COOKIE \ - "GOOF-0.8-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" + "GOOF-0.9-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" /* The length of the header must be a multiple of 8 bytes. */ verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index b2cdca5be..726112c8a 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -426,7 +426,7 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0) * branch and jump */ -/* offset must be a signed short!!! */ +/* offset must be a signed 16 bit int!!! */ #define FETCH_OFFSET(offset) \ { \ int h = FETCH (); \ @@ -436,10 +436,10 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0) #define BR(p) \ { \ - signed short offset; \ + scm_t_int16 offset; \ FETCH_OFFSET (offset); \ if (p) \ - ip += offset; \ + ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \ NULLSTACK (1); \ DROP (); \ NEXT; \ @@ -447,9 +447,9 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0) VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0) { - int h = FETCH (); - int l = FETCH (); - ip += (signed short) (h << 8) + l; + scm_t_int16 offset; + FETCH_OFFSET (offset); + ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); NEXT; } @@ -812,10 +812,12 @@ VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1) VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1) { SCM x; - signed short offset; + scm_t_int16 offset; + scm_t_uint8 *mvra; nargs = FETCH (); FETCH_OFFSET (offset); + mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8; x = sp[-nargs]; @@ -828,7 +830,7 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1) CACHE_PROGRAM (); INIT_ARGS (); NEW_FRAME (); - SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset); + SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra; ENTER_HOOK (); APPLY_HOOK (); NEXT; @@ -853,7 +855,7 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1) len = scm_length (values); PUSH_LIST (values, SCM_NULLP); PUSH (len); - ip += offset; + ip = mvra; } NEXT; } diff --git a/libguile/vm.c b/libguile/vm.c index 527598b86..cc5e4f924 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -226,7 +226,7 @@ really_make_boot_program (long nargs) SCM u8vec; /* Make sure "bytes" is 64-bit aligned. */ scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1, - scm_op_make_int8_1, + scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop, scm_op_halt }; struct scm_objcode *bp; SCM ret; diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 90b2acc03..e7308ac6f 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -24,7 +24,7 @@ #:use-module (system vm instruction) #:use-module ((srfi srfi-1) #:select (fold)) #:export (byte-length - addr+ align-program align-code + addr+ align-program align-code align-block assembly-pack assembly-unpack object->assembly assembly->object)) @@ -63,17 +63,24 @@ (define *program-alignment* 8) +(define *block-alignment* 8) + (define (addr+ addr code) (fold (lambda (x len) (+ (byte-length x) len)) addr code)) +(define (code-alignment addr alignment header-len) + (make-list (modulo (- alignment + (modulo (+ addr header-len) alignment)) + alignment) + '(nop))) + +(define (align-block addr) + (code-alignment addr *block-alignment* 0)) (define (align-code code addr alignment header-len) - `(,@(make-list (modulo (- alignment - (modulo (+ addr header-len) alignment)) - alignment) - '(nop)) + `(,@(code-alignment addr alignment header-len) ,code)) (define (align-program prog addr) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 58afddde0..bf6c5f7b5 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -77,10 +77,12 @@ ;; Ew! (for-each write-byte (bytevector->u8-list bv))) (define (write-break label) - (let ((offset (- (assq-ref labels label) (+ (get-addr) 2)))) - (cond ((>= offset (ash 1 15)) (error "jump too big" offset)) - ((< offset (- (ash 1 15))) (error "reverse jump too big" offset)) - (else (write-uint16-be offset))))) + (let ((offset (- (assq-ref labels label) + (logand (+ (get-addr) 2) (lognot #x7))))) + (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset)) + ((>= offset (ash 1 18)) (error "jump too far forward" offset)) + ((< offset (- (ash 1 18))) (error "jump too far backwards" offset)) + (else (write-uint16-be (ash offset -3)))))) (let ((inst (car asm)) (args (cdr asm)) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index 82459fc6f..0e34ab4a2 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -61,7 +61,8 @@ (labels '()) (i 0)) (define (ensure-label rel1 rel2) - (let ((where (+ i (bytes->s16 rel1 rel2)))) + (let ((where (+ (logand i (lognot #x7)) + (* (bytes->s16 rel1 rel2) 8)))) (or (assv-ref labels where) (begin (let ((l (gensym ":L"))) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 2e586ec5e..fa5805757 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -340,11 +340,12 @@ (error "unknown module var kind" op key))))) (( label) - (values '() - bindings - source-alist - (acons label addr label-alist) - object-alist)) + (let ((code (align-block addr))) + (values code + bindings + source-alist + (acons label (addr+ addr code) label-alist) + object-alist))) (( inst label) (emit-code `((,inst ,label)))) From 77332b21a01fac906ae4707426e00f01e62c0415 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Mon, 27 Jul 2009 21:02:23 -0700 Subject: [PATCH 312/375] Replace global charnames variables with accessors The global variables scm_charnames and scm_charnums are replaced with the accessor functions scm_i_charname and scm_i_charname_to_num. Also, the incomplete and broken EBCDIC support is removed. * libguile/print.c (iprin1): use new func scm_i_charname * libguile/read.c (scm_read_character): use new func scm_i_charname_to_num * libguile/chars.c (scm_i_charname): new function (scm_i_charname_to_char): new function (scm_charnames, scm_charnums): removed * libguile/chars.h: new declarations --- libguile/chars.c | 141 +++++++++++++++++++++++++++++++---------------- libguile/chars.h | 9 +-- libguile/print.c | 10 ++-- libguile/read.c | 9 ++- 4 files changed, 105 insertions(+), 64 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index ca47c0d82..511ffc7c8 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -298,61 +298,108 @@ scm_c_downcase (unsigned int c) return c; } + -#ifdef _DCC -# define ASCII -#else -# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) -# define EBCDIC -# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */ -# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) -# define ASCII -# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */ -#endif /* def _DCC */ +/* There are a few sets of character names: R5RS, Guile + extensions for control characters, and leftover Guile extensions. + They are listed in order of precedence. */ +const char *const scm_r5rs_charnames[] = + { + "space", "newline" + }; -#ifdef EBCDIC -char *const scm_charnames[] = +const scm_t_uint32 const scm_r5rs_charnums[] = + { + 0x20, 0x0A + }; + +const int scm_n_r5rs_charnames = sizeof (scm_r5rs_charnames) / sizeof (char *); + +/* The abbreviated names for control characters. */ +const char *const scm_C0_control_charnames[] = + { + /* C0 controls */ + "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", + "bs", "ht", "lf", "vt", "ff", "cr", "so", "si", + "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", + "can", "em", "sub", "esc", "fs", "gs", "rs", "us", + "sp", "del" + }; + +const scm_t_uint32 const scm_C0_control_charnums[] = + { + 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, + 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, + 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, + 0x20, 0x7f + }; + +int scm_n_C0_control_charnames = sizeof (scm_C0_control_charnames) / sizeof (char *); + +const char *const scm_alt_charnames[] = + { + "null", "backspace", "tab", "nl", "newline", "np", "page", "return", + }; + +const scm_t_uint32 const scm_alt_charnums[] = + { + 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d + }; + +const int scm_n_alt_charnames = sizeof (scm_alt_charnames) / sizeof (char *); + +/* Returns the string charname for a character if it exists, or NULL + otherwise. */ +const char * +scm_i_charname (SCM chr) { - "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del", - 0 , 0 , "smm", "vt", "ff", "cr", "so", "si", - "dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il", - "can", "em", "cc", 0 , "ifs", "igs", "irs", "ius", - "ds", "sos", "fs", 0 , "byp", "lf", "eob", "pre", - 0 , 0 , "sm", 0 , 0 , "enq", "ack", "bel", - 0 , 0 , "syn", 0 , "pn", "rs", "uc", "eot", - 0 , 0 , 0 , 0 , "dc4", "nak", 0 , "sub", - "space", scm_s_newline, "tab", "backspace", "return", "page", "null"}; + int c; + scm_t_uint32 i = SCM_CHAR (chr); -const char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ -\040\041\042\043\044\045\046\047\ -\050\051\052\053\054\055\056\057\ -\060\061\062\063\064\065\066\067\ -\070\071\072\073\074\075\076\077\ - \n\t\b\r\f\0"; -#endif /* def EBCDIC */ -#ifdef ASCII -char *const scm_charnames[] = + for (c = 0; c < scm_n_r5rs_charnames; c++) + if (scm_r5rs_charnums[c] == i) + return scm_r5rs_charnames[c]; + + for (c = 0; c < scm_n_C0_control_charnames; c++) + if (scm_C0_control_charnums[c] == i) + return scm_C0_control_charnames[c]; + + for (c = 0; c < scm_n_alt_charnames; c++) + if (scm_alt_charnums[c] == i) + return scm_alt_charnames[i]; + + return NULL; +} + +/* Return a character from a string charname. */ +SCM +scm_i_charname_to_char (const char *charname, size_t charname_len) { - "nul","soh","stx","etx","eot","enq","ack","bel", - "bs", "ht", "newline", "vt", "np", "cr", "so", "si", - "dle","dc1","dc2","dc3","dc4","nak","syn","etb", - "can", "em","sub","esc", "fs", "gs", "rs", "us", - "space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"}; -const char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ - \n\t\b\r\f\0\177"; -#endif /* def ASCII */ + int c; -int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *); + /* The R5RS charnames. These are supposed to be case + insensitive. */ + for (c = 0; c < scm_n_r5rs_charnames; c++) + if ((strlen (scm_r5rs_charnames[c]) == charname_len) + && (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len))) + return SCM_MAKE_CHAR (scm_r5rs_charnums[c]); + /* Then come the controls. These are not case sensitive. */ + for (c = 0; c < scm_n_C0_control_charnames; c++) + if ((strlen (scm_C0_control_charnames[c]) == charname_len) + && (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len))) + return SCM_MAKE_CHAR (scm_C0_control_charnums[c]); + + /* Lastly are some old names carried over for compatibility. */ + for (c = 0; c < scm_n_alt_charnames; c++) + if ((strlen (scm_alt_charnames[c]) == charname_len) + && (!strncasecmp (scm_alt_charnames[c], charname, charname_len))) + return SCM_MAKE_CHAR (scm_alt_charnums[c]); + + return SCM_BOOL_F; +} diff --git a/libguile/chars.h b/libguile/chars.h index 88dde4bd9..5bceea533 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -34,12 +34,6 @@ -SCM_API char *const scm_charnames[]; -SCM_API int scm_n_charnames; -SCM_API const char scm_charnums[]; - - - SCM_API SCM scm_char_p (SCM x); SCM_API SCM scm_char_eq_p (SCM x, SCM y); SCM_API SCM scm_char_less_p (SCM x, SCM y); @@ -63,6 +57,9 @@ SCM_API SCM scm_char_upcase (SCM chr); SCM_API SCM scm_char_downcase (SCM chr); SCM_API int scm_c_upcase (unsigned int c); SCM_API int scm_c_downcase (unsigned int c); +SCM_INTERNAL const char * scm_i_charname (SCM chr); +SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname, + size_t charname_len); SCM_INTERNAL void scm_init_chars (void); #endif /* SCM_CHARS_H */ diff --git a/libguile/print.c b/libguile/print.c index 6c44d59db..604571820 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -437,16 +437,14 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) if (SCM_CHARP (exp)) { long i = SCM_CHAR (exp); + const char *name; if (SCM_WRITINGP (pstate)) { scm_puts ("#\\", port); - if ((i >= 0) && (i <= ' ') && scm_charnames[i]) - scm_puts (scm_charnames[i], port); -#ifndef EBCDIC - else if (i == '\177') - scm_puts (scm_charnames[scm_n_charnames - 1], port); -#endif + name = scm_i_charname (exp); + if (name != NULL) + scm_puts (name, port); else if (i < 0 || i > '\177') scm_intprint (i, 8, port); else diff --git a/libguile/read.c b/libguile/read.c index bd028ea52..2140fed25 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -801,7 +801,7 @@ static SCM scm_read_character (int chr, SCM port) #define FUNC_NAME "scm_lreadr" { - unsigned c; + SCM ch; char charname[READER_CHAR_NAME_MAX_SIZE]; size_t charname_len; @@ -834,10 +834,9 @@ scm_read_character (int chr, SCM port) return SCM_MAKE_CHAR (SCM_I_INUM (p)); } - for (c = 0; c < scm_n_charnames; c++) - if (scm_charnames[c] - && (!strncasecmp (scm_charnames[c], charname, charname_len))) - return SCM_MAKE_CHAR (scm_charnums[c]); + ch = scm_i_charname_to_char (charname, charname_len); + if (scm_is_true (ch)) + return ch; char_error: scm_i_input_error (FUNC_NAME, port, "unknown character name ~a", From 904a78f11d2d11a58d5df365a44c4fbbd4c96df3 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Wed, 29 Jul 2009 06:38:32 -0700 Subject: [PATCH 313/375] Add 32-bit characters This adds the 32-bit standalone characters. Strings are still 8-bit. Characters larger than 8-bit can only be entered or displayed in octal format at this point. At this point, the terminal's display encoding is expected to be Latin-1. * module/language/assembly/compile-bytecode.scm (write-bytecode): add 32-bit char * module/language/assembly.scm (object->assembly): add 32-bit char (assembly->object): add 32-bit char * libguile/vm-i-system.c (make-char32): new op * libguile/print.c (iprin1): print 32-bit char * libguile/numbers.h: add type scm_t_wchar * libguile/numbers.c: add type scm_t_wchar * libguile/chars.h: new type scm_t_wchar (SCM_CODEPOINT_MAX): new (SCM_IS_UNICODE_CHAR): new (SCM_MAKE_CHAR): operate on 32-bit char * libguile/chars.c: comparison operators now use Unicode codepoints (scm_c_upcase): now receives and returns scm_t_wchar (scm_c_downcase): now receives and returns scm_t_wchar --- libguile/chars.c | 68 +++++++++++-------- libguile/chars.h | 27 ++++++-- libguile/numbers.c | 8 +++ libguile/numbers.h | 10 ++- libguile/print.c | 31 +++++++-- libguile/vm-i-system.c | 13 ++++ module/language/assembly.scm | 11 ++- module/language/assembly/compile-bytecode.scm | 1 + 8 files changed, 126 insertions(+), 43 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index 511ffc7c8..5a53c456a 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -24,6 +24,8 @@ #include #include +#include + #include "libguile/_scm.h" #include "libguile/validate.h" @@ -55,7 +57,7 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_less_p, "char?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n" + "Return @code{#t} iff @var{x} is greater than @var{y} in the Unicode\n" "sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_gr_p { @@ -92,7 +94,7 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, (SCM x, SCM y), "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n" - "ASCII sequence, else @code{#f}.") + "Unicode sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_geq_p { SCM_VALIDATE_CHAR (1, x); @@ -104,7 +106,7 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, (SCM x, SCM y), "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n" - "case, else @code{#f}.") + "case, else @code{#f}. Case is locale free and not context sensitive.") #define FUNC_NAME s_scm_char_ci_eq_p { SCM_VALIDATE_CHAR (1, x); @@ -115,8 +117,9 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_less_p, "char-ci?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n" - "sequence ignoring case, else @code{#f}.") + "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n" + "than the Unicode uppercase form of @var{y} in the Unicode\n" + "sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_ci_gr_p { SCM_VALIDATE_CHAR (1, x); @@ -151,8 +156,9 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n" - "ASCII sequence ignoring case, else @code{#f}.") + "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n" + "than or equal to the Unicode uppercase form of @var{y} in the\n" + "Unicode sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_ci_geq_p { SCM_VALIDATE_CHAR (1, x); @@ -233,7 +239,7 @@ SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0, #define FUNC_NAME s_scm_char_to_integer { SCM_VALIDATE_CHAR (1, chr); - return scm_from_ulong (SCM_CHAR(chr)); + return scm_from_uint32 (SCM_CHAR(chr)); } #undef FUNC_NAME @@ -244,7 +250,15 @@ SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0, "Return the character at position @var{n} in the ASCII sequence.") #define FUNC_NAME s_scm_integer_to_char { - return SCM_MAKE_CHAR (scm_to_uchar (n)); + scm_t_wchar cn; + + cn = scm_to_wchar (n); + + /* Avoid the surrogates. */ + if (!SCM_IS_UNICODE_CHAR (cn)) + scm_out_of_range (FUNC_NAME, n); + + return SCM_MAKE_CHAR (cn); } #undef FUNC_NAME @@ -255,7 +269,7 @@ SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0, #define FUNC_NAME s_scm_char_upcase { SCM_VALIDATE_CHAR (1, chr); - return SCM_MAKE_CHAR (toupper (SCM_CHAR (chr))); + return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr))); } #undef FUNC_NAME @@ -266,7 +280,7 @@ SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0, #define FUNC_NAME s_scm_char_downcase { SCM_VALIDATE_CHAR (1, chr); - return SCM_MAKE_CHAR (tolower (SCM_CHAR(chr))); + return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr))); } #undef FUNC_NAME @@ -279,23 +293,17 @@ TODO: change name to scm_i_.. ? --hwn */ -int -scm_c_upcase (unsigned int c) +scm_t_wchar +scm_c_upcase (scm_t_wchar c) { - if (c <= UCHAR_MAX) - return toupper (c); - else - return c; + return uc_toupper (c); } -int -scm_c_downcase (unsigned int c) +scm_t_wchar +scm_c_downcase (scm_t_wchar c) { - if (c <= UCHAR_MAX) - return tolower (c); - else - return c; + return uc_tolower (c); } diff --git a/libguile/chars.h b/libguile/chars.h index 5bceea533..e68f06d21 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -3,7 +3,7 @@ #ifndef SCM_CHARS_H #define SCM_CHARS_H -/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -28,9 +28,24 @@ /* Immediate Characters */ + +#ifndef SCM_WCHAR_DEFINED +typedef scm_t_int32 scm_t_wchar; +#define SCM_WCHAR_DEFINED +#endif + #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char) -#define SCM_CHAR(x) ((unsigned int)SCM_ITAG8_DATA(x)) -#define SCM_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), scm_tc8_char) +#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x)) + +#define SCM_MAKE_CHAR(x) ({scm_t_int32 _x = (x); \ + _x < 0 \ + ? SCM_MAKE_ITAG8((scm_t_bits)(unsigned char)_x, scm_tc8_char) \ + : SCM_MAKE_ITAG8((scm_t_bits)_x, scm_tc8_char);}) + +#define SCM_CODEPOINT_MAX (0x10ffff) +#define SCM_IS_UNICODE_CHAR(c) \ + ((scm_t_wchar)(c)<=0xd7ff || \ + ((scm_t_wchar)(c)>=0xe000 && (scm_t_wchar)(c)<=SCM_CODEPOINT_MAX)) @@ -55,9 +70,9 @@ SCM_API SCM scm_char_to_integer (SCM chr); SCM_API SCM scm_integer_to_char (SCM n); SCM_API SCM scm_char_upcase (SCM chr); SCM_API SCM scm_char_downcase (SCM chr); -SCM_API int scm_c_upcase (unsigned int c); -SCM_API int scm_c_downcase (unsigned int c); -SCM_INTERNAL const char * scm_i_charname (SCM chr); +SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c); +SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c); +SCM_INTERNAL const char *scm_i_charname (SCM chr); SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname, size_t charname_len); SCM_INTERNAL void scm_init_chars (void); diff --git a/libguile/numbers.c b/libguile/numbers.c index c7e098151..5f56b7a29 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5863,6 +5863,14 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max) #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg) #include "libguile/conv-uinteger.i.c" +#define TYPE scm_t_wchar +#define TYPE_MIN (scm_t_int32)-1 +#define TYPE_MAX (scm_t_int32)0x10ffff +#define SIZEOF_TYPE 4 +#define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg) +#include "libguile/conv-integer.i.c" + #if SCM_HAVE_T_INT64 #define TYPE scm_t_int64 diff --git a/libguile/numbers.h b/libguile/numbers.h index 5bad4478b..f30f7d061 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -3,7 +3,7 @@ #ifndef SCM_NUMBERS_H #define SCM_NUMBERS_H -/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -174,6 +174,11 @@ typedef struct scm_t_complex double imag; } scm_t_complex; +#ifndef SCM_WCHAR_DEFINED +typedef scm_t_int32 scm_t_wchar; +#define SCM_WCHAR_DEFINED +#endif + SCM_API SCM scm_exact_p (SCM x); @@ -322,6 +327,9 @@ SCM_API SCM scm_from_int32 (scm_t_int32 x); SCM_API scm_t_uint32 scm_to_uint32 (SCM x); SCM_API SCM scm_from_uint32 (scm_t_uint32 x); +SCM_API scm_t_wchar scm_to_wchar (SCM x); +SCM_API SCM scm_from_wchar (scm_t_wchar x); + #if SCM_HAVE_T_INT64 SCM_API scm_t_int64 scm_to_int64 (SCM x); diff --git a/libguile/print.c b/libguile/print.c index 604571820..1a5aebe1b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -23,6 +23,7 @@ #endif #include +#include #include "libguile/_scm.h" #include "libguile/chars.h" @@ -436,7 +437,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc3_imm24: if (SCM_CHARP (exp)) { - long i = SCM_CHAR (exp); + scm_t_wchar i = SCM_CHAR (exp); const char *name; if (SCM_WRITINGP (pstate)) @@ -445,10 +446,30 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) name = scm_i_charname (exp); if (name != NULL) scm_puts (name, port); - else if (i < 0 || i > '\177') - scm_intprint (i, 8, port); - else - scm_putc (i, port); + else if (uc_is_general_category_withtable (i, UC_CATEGORY_MASK_L + | UC_CATEGORY_MASK_M + | UC_CATEGORY_MASK_N + | UC_CATEGORY_MASK_P + | UC_CATEGORY_MASK_S)) + /* Print the character if is graphic character. */ + { + if (i<256) + { + /* Character is graphic. Print it. */ + scm_putc (i, port); + } + else + { + /* Character is graphic but unrepresentable in + this port's encoding. */ + scm_intprint (i, 8, port); + } + } + else + { + /* Character is a non-graphical character. */ + scm_intprint (i, 8, port); + } } else scm_putc (i, port); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 726112c8a..ecafbebdd 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -175,6 +175,19 @@ VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1) +{ + scm_t_wchar v = 0; + v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + PUSH (SCM_MAKE_CHAR (v)); + NEXT; +} + + + VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) { unsigned h = FETCH (); diff --git a/module/language/assembly.scm b/module/language/assembly.scm index e7308ac6f..3a1da4fe3 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -131,7 +131,11 @@ (bytevector-s64-set! bv 0 x (endianness big)) bv)))) (else #f))) - ((char? x) `(make-char8 ,(char->integer x))) + ((char? x) + (cond ((<= (char->integer x) #xff) + `(make-char8 ,(char->integer x))) + (else + `(make-char32 ,(char->integer x))))) (else #f))) (define (assembly->object code) @@ -156,6 +160,11 @@ (endianness big))) ((make-char8 ,n) (integer->char n)) + ((make-char32 ,n1 ,n2 ,n3 ,n4) + (integer->char (+ (* n1 #x1000000) + (* n2 #x10000) + (* n3 #x100) + n4))) ((load-string ,s) s) ((load-symbol ,s) (string->symbol s)) ((load-keyword ,s) (symbol->keyword (string->symbol s))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index bf6c5f7b5..bed0fb2dc 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -122,6 +122,7 @@ ;; meets the alignment requirements of `scm_objcode'. See ;; `scm_c_make_objcode_slice ()'. (write-bytecode meta write get-addr '())))) + ((make-char32 ,x) (write-uint32-be x)) ((load-unsigned-integer ,str) (write-loader str)) ((load-integer ,str) (write-loader str)) ((load-number ,str) (write-loader str)) From f4aa0f104b3347c21093b837046022fb7bb6a2ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 30 Jul 2009 00:48:04 +0200 Subject: [PATCH 314/375] Add `tree-il-fold', a purely functional iterator on `tree-il'. * module/language/tree-il.scm (tree-il-fold): New procedure. * test-suite/tests/tree-il.test ("tree-il-fold"): New test prefix. --- module/language/tree-il.scm | 49 ++++++++++++++++++++++++++++++++++- test-suite/tests/tree-il.test | 39 ++++++++++++++++++++++++++++ 2 files changed, 87 insertions(+), 1 deletion(-) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 0f8448a44..aec4eedb9 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -17,6 +17,7 @@ (define-module (language tree-il) + #:use-module (srfi srfi-1) #:use-module (system base pmatch) #:use-module (system base syntax) #:export (tree-il-src @@ -38,11 +39,12 @@ let? make-let let-src let-names let-vars let-vals let-body letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body - + parse-tree-il unparse-tree-il tree-il->scheme + tree-il-fold post-order! pre-order!)) @@ -258,6 +260,51 @@ `(call-with-values (lambda () ,(tree-il->scheme exp)) (lambda ,vars ,(tree-il->scheme body)))))) + +(define (tree-il-fold leaf down up seed tree) + "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent +into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is +invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered +and SEED is the current result, intially seeded with SEED. + +This is an implementation of `foldts' as described by Andy Wingo in +``Applications of fold to XML transformation''." + (let loop ((tree tree) + (result seed)) + (if (or (null? tree) (pair? tree)) + (fold loop result tree) + (record-case tree + (( exp) + (up tree (loop exp (down tree result)))) + (( exp) + (up tree (loop exp (down tree result)))) + (( exp) + (up tree (loop exp (down tree result)))) + (( exp) + (up tree (loop exp (down tree result)))) + (( test then else) + (up tree (loop else + (loop then + (loop test (down tree result)))))) + (( proc args) + (up tree (loop (cons proc args) (down tree result)))) + (( exps) + (up tree (loop exps (down tree result)))) + (( body) + (up tree (loop body (down tree result)))) + (( vals body) + (up tree (loop body + (loop vals + (down tree result))))) + (( vals body) + (up tree (loop body + (loop vals + (down tree result))))) + (( body) + (up tree (loop body (down tree result)))) + (else + (leaf tree result)))))) + (define (post-order! f x) (let lp ((x x)) (record-case x diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 6634dcdd7..8b8f1238d 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -467,3 +467,42 @@ (toplevel ref bar) (call call/cc 1) (call goto/args 1)))) + +(with-test-prefix "tree-il-fold" + + (pass-if "empty tree" + (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark))) + (and (eq? mark + (tree-il-fold (lambda (x y) (set! leaf? #t) y) + (lambda (x y) (set! down? #t) y) + (lambda (x y) (set! up? #t) y) + mark + '())) + (not leaf?) + (not up?) + (not down?)))) + + (pass-if "lambda and application" + (let* ((leaves '()) (ups '()) (downs '()) + (result (tree-il-fold (lambda (x y) + (set! leaves (cons x leaves)) + (1+ y)) + (lambda (x y) + (set! downs (cons x downs)) + (1+ y)) + (lambda (x y) + (set! ups (cons x ups)) + (1+ y)) + 0 + (parse-tree-il + '(lambda (x y) (x1 y1) + (apply (toplevel +) + (lexical x x1) + (lexical y y1))))))) + (and (equal? (map strip-source leaves) + (list (make-lexical-ref #f 'y 'y1) + (make-lexical-ref #f 'x 'x1) + (make-toplevel-ref #f '+))) + (= (length downs) 2) + (equal? (reverse (map strip-source ups)) + (map strip-source downs)))))) From 2e4c3227ce1374dd53abd3c7c5797cc64329de91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 31 Jul 2009 00:06:59 +0200 Subject: [PATCH 315/375] Add `(system base message)', a simple warning framework. * module/Makefile.am (SOURCES): Add `system/base/message.scm'. * module/scripts/compile.scm (%options): Add `--warn'. (parse-args): Update default value for `warnings'. (show-warning-help): New procedure. (compile)[compile-opts]: Add `#:warnings'. Update help message. * module/system/base/compile.scm (compile): Sanity-check the requested warnings. * module/system/base/message.scm: New file. --- module/Makefile.am | 1 + module/scripts/compile.scm | 34 ++++++++++- module/system/base/compile.scm | 11 ++++ module/system/base/message.scm | 102 +++++++++++++++++++++++++++++++++ 4 files changed, 146 insertions(+), 2 deletions(-) create mode 100644 module/system/base/message.scm diff --git a/module/Makefile.am b/module/Makefile.am index a904a8f8e..2971fc6b5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -34,6 +34,7 @@ SOURCES = \ ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ + system/base/message.scm \ \ language/tree-il.scm \ language/ghil.scm language/glil.scm language/assembly.scm \ diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 311e35bad..89d35bcb5 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -30,9 +30,11 @@ (define-module (scripts compile) #:use-module ((system base compile) #:select (compile-file)) + #:use-module (system base message) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:use-module (srfi srfi-37) + #:use-module (ice-9 format) #:export (compile)) @@ -58,6 +60,17 @@ (fail "`-o' option cannot be specified more than once") (alist-cons 'output-file arg result)))) + (option '(#\W "warn") #t #f + (lambda (opt name arg result) + (if (string=? arg "help") + (begin + (show-warning-help) + (exit 0)) + (let ((warnings (assoc-ref result 'warnings))) + (alist-cons 'warnings + (cons (string->symbol arg) warnings) + (alist-delete 'warnings result)))))) + (option '(#\O "optimize") #f #f (lambda (opt name arg result) (alist-cons 'optimize? #t result))) @@ -86,13 +99,27 @@ options." ;; default option values '((input-files) - (load-path)))) + (load-path) + (warnings unsupported-warning)))) + +(define (show-warning-help) + (format #t "The available warning types are:~%~%") + (for-each (lambda (wt) + (format #t " ~22A ~A~%" + (format #f "`~A'" (warning-type-name wt)) + (warning-type-description wt))) + %warning-types) + (format #t "~%")) (define (compile . args) (let* ((options (parse-args args)) (help? (assoc-ref options 'help?)) - (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '())) + (compile-opts (let ((o `(#:warnings + ,(assoc-ref options 'warnings)))) + (if (assoc-ref options 'optimize?) + (cons #:O o) + o))) (from (or (assoc-ref options 'from) 'scheme)) (to (or (assoc-ref options 'to) 'objcode)) (input-files (assoc-ref options 'input-files)) @@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object. -L, --load-path=DIR add DIR to the front of the module load path -o, --output=OFILE write output to OFILE + -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help' + for a list of available warnings + -f, --from=LANG specify a source language other than `scheme' -t, --to=LANG specify a target language other than `objcode' diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 7e26609b9..8470f39e2 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -21,6 +21,7 @@ (define-module (system base compile) #:use-module (system base syntax) #:use-module (system base language) + #:use-module (system base message) #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho #:use-module (ice-9 regex) #:use-module (ice-9 optargs) @@ -213,6 +214,16 @@ (from (current-language)) (to 'value) (opts '())) + + (let ((warnings (memq #:warnings opts))) + (if (pair? warnings) + (let ((warnings (cadr warnings))) + ;; Sanity-check the requested warnings. + (for-each (lambda (w) + (or (lookup-warning-type w) + (warning 'unsupported-warning #f w))) + warnings)))) + (receive (exp env cenv) (compile-fold (compile-passes from to opts) x env opts) exp)) diff --git a/module/system/base/message.scm b/module/system/base/message.scm new file mode 100644 index 000000000..6b68c5639 --- /dev/null +++ b/module/system/base/message.scm @@ -0,0 +1,102 @@ +;;; User interface messages + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This module provide a simple interface to send messages to the user. +;;; TODO: Internationalize messages. +;;; +;;; Code: + +(define-module (system base message) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (*current-warning-port* warning + + warning-type? warning-type-name warning-type-description + warning-type-printer lookup-warning-type + + %warning-types)) + + +;;; +;;; Source location +;;; + +(define (location-string loc) + (if (pair? loc) + (format #f "~a:~a:~a" + (or (assoc-ref loc 'filename) "") + (1+ (assoc-ref loc 'line)) + (assoc-ref loc 'column)) + "")) + + +;;; +;;; Warnings +;;; + +(define *current-warning-port* + ;; The port where warnings are sent. + (make-fluid)) + +(fluid-set! *current-warning-port* (current-error-port)) + +(define-record-type + (make-warning-type name description printer) + warning-type? + (name warning-type-name) + (description warning-type-description) + (printer warning-type-printer)) + +(define %warning-types + ;; List of know warning types. + (map (lambda (args) + (apply make-warning-type args)) + + `((unsupported-warning ;; a "meta warning" + "warn about unknown warning types" + ,(lambda (port unused name) + (format port "warning: unknown warning type `~A'~%" + name))) + + (unused-variable + "report unused variables" + ,(lambda (port loc name) + (format port "~A: warning: unused variable `~A'~%" + loc name)))))) + +(define (lookup-warning-type name) + "Return the warning type NAME or `#f' if not found." + (find (lambda (wt) + (eq? name (warning-type-name wt))) + %warning-types)) + +(define (warning type location . args) + "Emit a warning of type TYPE for source location LOCATION (a source +property alist) using the data in ARGS." + (let ((wt (lookup-warning-type type)) + (port (fluid-ref *current-warning-port*))) + (if (warning-type? wt) + (apply (warning-type-printer wt) + port (location-string location) + args) + (format port "~A: unknown warning type `~A': ~A~%" + (location-string location) type args)))) + +;;; message.scm ends here From 4b856371b3e85cd82f6d637f72bc610d0158b5de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 31 Jul 2009 00:42:58 +0200 Subject: [PATCH 316/375] Add unused variable analysis in the tree-il->glil compiler. * module/language/tree-il/analyze.scm (): New record type. (report-unused-variables): New procedure. * module/language/tree-il/compile-glil.scm (%warning-passes): New variable. (compile-glil): Honor `#:warnings' from OPTS. * test-suite/tests/tree-il.test (call-with-warnings): New procedure. (%opts-w-unused): New variable. ("warnings"): New test prefix. --- module/language/tree-il/analyze.scm | 129 ++++++++++++++++++++++- module/language/tree-il/compile-glil.scm | 16 +++ test-suite/tests/tree-il.test | 78 +++++++++++++- 3 files changed, 221 insertions(+), 2 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 4ed796c03..1b39b2dd4 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -20,9 +20,12 @@ (define-module (language tree-il analyze) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (system base syntax) + #:use-module (system base message) #:use-module (language tree-il) - #:export (analyze-lexicals)) + #:export (analyze-lexicals + report-unused-variables)) ;; Allocation is the process of assigning storage locations for lexical ;; variables. A lexical variable has a distinct "address", or storage @@ -308,3 +311,127 @@ (allocate! x #f 0) allocation) + + +;;; +;;; Unused variable analysis. +;;; + +;; records are used during tree traversals in +;; `report-unused-variables'. They contain a list of the local vars +;; currently in scope, a list of locals vars that have been referenced, and a +;; "location stack" (the stack of `tree-il-src' values for each parent tree). +(define-record-type + (make-binding-info vars refs locs) + binding-info? + (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...) + (refs binding-info-refs) ;; (GENSYM ...) + (locs binding-info-locs)) ;; (LOCATION ...) + +(define (report-unused-variables tree) + "Report about unused variables in TREE. Return TREE." + + (define (dotless-list lst) + ;; If LST is a dotted list, return a proper list equal to LST except that + ;; the very last element is a pair; otherwise return LST. + (let loop ((lst lst) + (result '())) + (cond ((null? lst) + (reverse result)) + ((pair? lst) + (loop (cdr lst) (cons (car lst) result))) + (else + (loop '() (cons lst result)))))) + + (tree-il-fold (lambda (x info) + ;; X is a leaf: extend INFO's refs accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (record-case x + (( gensym) + (make-binding-info vars (cons gensym refs) locs)) + (else info)))) + + (lambda (x info) + ;; Going down into X: extend INFO's variable list + ;; accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info)) + (src (tree-il-src x))) + (define (extend inner-vars inner-names) + (append (map (lambda (var name) + (list var name src)) + inner-vars + inner-names) + vars)) + (record-case x + (( gensym) + (make-binding-info vars (cons gensym refs) + (cons src locs))) + (( vars names) + (let ((vars (dotless-list vars)) + (names (dotless-list names))) + (make-binding-info (extend vars names) refs + (cons src locs)))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (else info)))) + + (lambda (x info) + ;; Leaving X's scope: shrink INFO's variable list + ;; accordingly and reported unused nested variables. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (define (shrink inner-vars refs) + (for-each (lambda (var) + (let ((gensym (car var))) + ;; Don't report lambda parameters as + ;; unused. + (if (and (not (memq gensym refs)) + (not (and (lambda? x) + (memq gensym + inner-vars)))) + (let ((name (cadr var)) + ;; We can get approximate + ;; source location by going up + ;; the LOCS location stack. + (loc (or (caddr var) + (find pair? locs)))) + (warning 'unused-variable loc name))))) + (filter (lambda (var) + (memq (car var) inner-vars)) + vars)) + (fold alist-delete vars inner-vars)) + + ;; For simplicity, we leave REFS untouched, i.e., with + ;; names of variables that are now going out of scope. + ;; It doesn't hurt as these are unique names, it just + ;; makes REFS unnecessarily fat. + (record-case x + (( vars) + (let ((vars (dotless-list vars))) + (make-binding-info (shrink vars refs) refs + (cdr locs)))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (else info)))) + (make-binding-info '() '() '()) + tree) + tree) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index f1d86e3f9..bf4699797 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -21,6 +21,7 @@ (define-module (language tree-il compile-glil) #:use-module (system base syntax) #:use-module (system base pmatch) + #:use-module (system base message) #:use-module (ice-9 receive) #:use-module (language glil) #:use-module (system vm instruction) @@ -44,10 +45,25 @@ (define *comp-module* (make-fluid)) +(define %warning-passes + `((unused-variable . ,report-unused-variables))) + (define (compile-glil x e opts) + (define warnings + (or (and=> (memq #:warnings opts) cadr) + '())) + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) (x (optimize! x e opts)) (allocation (analyze-lexicals x))) + + ;; Go throught the warning passes. + (for-each (lambda (kind) + (let ((warn (assoc-ref %warning-passes kind))) + (and (procedure? warn) + (warn x)))) + warnings) + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) (lambda () (values (flatten-lambda x allocation) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 8b8f1238d..896206b1f 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -21,8 +21,10 @@ #:use-module (test-suite lib) #:use-module (system base compile) #:use-module (system base pmatch) + #:use-module (system base message) #:use-module (language tree-il) - #:use-module (language glil)) + #:use-module (language glil) + #:use-module (srfi srfi-13)) ;; Of course, the GLIL that is emitted depends on the source info of the ;; input. Here we're not concerned about that, so we strip source @@ -506,3 +508,77 @@ (= (length downs) 2) (equal? (reverse (map strip-source ups)) (map strip-source downs)))))) + + +;;; +;;; Warnings. +;;; + +;; Make sure we get English messages. +(setlocale LC_ALL "C") + +(define (call-with-warnings thunk) + (let ((port (open-output-string))) + (with-fluid* *current-warning-port* port + thunk) + (let ((warnings (get-output-string port))) + (string-tokenize warnings + (char-set-complement (char-set #\newline)))))) + +(define %opts-w-unused + '(#:warnings (unused-variable))) + + +(with-test-prefix "warnings" + + (pass-if "unknown warning type" + (let ((w (call-with-warnings + (lambda () + (compile #t #:opts '(#:warnings (does-not-exist))))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unknown warning"))))) + + (with-test-prefix "unused-variable" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (compile '(lambda (x y) (+ x y)) + #:opts %opts-w-unused))))) + + (pass-if "let/unused" + (let ((w (call-with-warnings + (lambda () + (compile '(lambda (x) + (let ((y (+ x 2))) + x)) + #:opts %opts-w-unused))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unused variable `y'"))))) + + (pass-if "shadowed variable" + (let ((w (call-with-warnings + (lambda () + (compile '(lambda (x) + (let ((y x)) + (let ((y (+ x 2))) + (+ x y)))) + #:opts %opts-w-unused))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unused variable `y'"))))) + + (pass-if "letrec" + (null? (call-with-warnings + (lambda () + (compile '(lambda () + (letrec ((x (lambda () (y))) + (y (lambda () (x)))) + y)) + #:opts %opts-w-unused))))) + + (pass-if "unused argument" + ;; Unused arguments should not be reported. + (null? (call-with-warnings + (lambda () + (compile '(lambda (x y z) #t) + #:opts %opts-w-unused))))))) From 5adcdb65192ba6e654ab2d1dd8b0840a33136a8a Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sat, 1 Aug 2009 08:05:55 -0700 Subject: [PATCH 317/375] Update NEWS for charname changes * NEWS: updated --- NEWS | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/NEWS b/NEWS index 445bb1cb5..96c3a9b1d 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,21 @@ Please send Guile bug reports to bug-guile@gnu.org. (During the 1.9 series, we will keep an incremental NEWS for the latest prerelease, and a full NEWS corresponding to 1.8 -> 2.0.) +Changes in 1.9.2 (since the 1.9.1 prerelease): + +** Global variables `scm_charnames' and `scm_charnums' are removed. + +These variables contained the names of control characters and were +used when writing characters. While these were global, they were +never intended to be public API. They have been replaced with private +functions. + +** EBCDIC support is removed. + +There was an EBCDIC compile flag that altered some of the character +processing. It appeared that full EBCDIC support was never completed +and was unmaintained. + Changes in 1.9.1 (since the 1.9.0 prerelease): ** `scm_set_port_seek' and `scm_set_port_truncate' use the `scm_t_off' type From 64bad3f5a8d7351a41a5b9ccb1df5c393a48b4a9 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sat, 1 Aug 2009 08:12:15 -0700 Subject: [PATCH 318/375] Make charname declarations module-level and GCS Charname array declarations are corrected for style and are made module-level. Array list length variables are replaced with macros. * libguile/chars.c: variable declaration fixes --- libguile/chars.c | 82 ++++++++++++++++++++++-------------------------- 1 file changed, 38 insertions(+), 44 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index 5a53c456a..2103c540c 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -312,51 +312,45 @@ scm_c_downcase (scm_t_wchar c) extensions for control characters, and leftover Guile extensions. They are listed in order of precedence. */ -const char *const scm_r5rs_charnames[] = - { - "space", "newline" - }; +static const char *const scm_r5rs_charnames[] = { + "space", "newline" +}; -const scm_t_uint32 const scm_r5rs_charnums[] = - { - 0x20, 0x0A - }; +static const scm_t_uint32 const scm_r5rs_charnums[] = { + 0x20, 0x0A +}; -const int scm_n_r5rs_charnames = sizeof (scm_r5rs_charnames) / sizeof (char *); +#define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *)) /* The abbreviated names for control characters. */ -const char *const scm_C0_control_charnames[] = - { - /* C0 controls */ - "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", - "bs", "ht", "lf", "vt", "ff", "cr", "so", "si", - "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", - "can", "em", "sub", "esc", "fs", "gs", "rs", "us", - "sp", "del" - }; +static const char *const scm_C0_control_charnames[] = { + /* C0 controls */ + "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", + "bs", "ht", "lf", "vt", "ff", "cr", "so", "si", + "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", + "can", "em", "sub", "esc", "fs", "gs", "rs", "us", + "sp", "del" +}; -const scm_t_uint32 const scm_C0_control_charnums[] = - { - 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, - 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, - 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, - 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, - 0x20, 0x7f - }; +static const scm_t_uint32 const scm_C0_control_charnums[] = { + 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, + 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, + 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, + 0x20, 0x7f +}; -int scm_n_C0_control_charnames = sizeof (scm_C0_control_charnames) / sizeof (char *); +#define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof (char *)) -const char *const scm_alt_charnames[] = - { - "null", "backspace", "tab", "nl", "newline", "np", "page", "return", - }; - -const scm_t_uint32 const scm_alt_charnums[] = - { - 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d - }; +static const char *const scm_alt_charnames[] = { + "null", "backspace", "tab", "nl", "newline", "np", "page", "return", +}; -const int scm_n_alt_charnames = sizeof (scm_alt_charnames) / sizeof (char *); +static const scm_t_uint32 const scm_alt_charnums[] = { + 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d +}; + +#define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *)) /* Returns the string charname for a character if it exists, or NULL otherwise. */ @@ -366,15 +360,15 @@ scm_i_charname (SCM chr) int c; scm_t_uint32 i = SCM_CHAR (chr); - for (c = 0; c < scm_n_r5rs_charnames; c++) + for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++) if (scm_r5rs_charnums[c] == i) return scm_r5rs_charnames[c]; - for (c = 0; c < scm_n_C0_control_charnames; c++) + for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++) if (scm_C0_control_charnums[c] == i) return scm_C0_control_charnames[c]; - for (c = 0; c < scm_n_alt_charnames; c++) + for (c = 0; c < SCM_N_ALT_CHARNAMES; c++) if (scm_alt_charnums[c] == i) return scm_alt_charnames[i]; @@ -389,23 +383,23 @@ scm_i_charname_to_char (const char *charname, size_t charname_len) /* The R5RS charnames. These are supposed to be case insensitive. */ - for (c = 0; c < scm_n_r5rs_charnames; c++) + for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++) if ((strlen (scm_r5rs_charnames[c]) == charname_len) && (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len))) return SCM_MAKE_CHAR (scm_r5rs_charnums[c]); /* Then come the controls. These are not case sensitive. */ - for (c = 0; c < scm_n_C0_control_charnames; c++) + for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++) if ((strlen (scm_C0_control_charnames[c]) == charname_len) && (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len))) return SCM_MAKE_CHAR (scm_C0_control_charnums[c]); /* Lastly are some old names carried over for compatibility. */ - for (c = 0; c < scm_n_alt_charnames; c++) + for (c = 0; c < SCM_N_ALT_CHARNAMES; c++) if ((strlen (scm_alt_charnames[c]) == charname_len) && (!strncasecmp (scm_alt_charnames[c], charname, charname_len))) return SCM_MAKE_CHAR (scm_alt_charnums[c]); - + return SCM_BOOL_F; } From 4c402b889eecaa7ffc61da6656f415c8c983507a Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sat, 1 Aug 2009 10:15:20 -0700 Subject: [PATCH 319/375] Don't use GNU extensions for SCM_MAKE_CHAR macro Since the contents of SCM_MAKE_CHAR are evaluated more than once, don't use it in situations where this could cause side-effects. * libguile/vm-i-system.c (make-char8): avoid side-effects with SCM_MAKE_CHAR call * libguile/chars.h (SCM_MAKE_CHAR): modified --- libguile/chars.h | 8 ++++---- libguile/vm-i-system.c | 8 +++++++- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/libguile/chars.h b/libguile/chars.h index e68f06d21..8e1bc64b4 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -37,10 +37,10 @@ typedef scm_t_int32 scm_t_wchar; #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char) #define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x)) -#define SCM_MAKE_CHAR(x) ({scm_t_int32 _x = (x); \ - _x < 0 \ - ? SCM_MAKE_ITAG8((scm_t_bits)(unsigned char)_x, scm_tc8_char) \ - : SCM_MAKE_ITAG8((scm_t_bits)_x, scm_tc8_char);}) +#define SCM_MAKE_CHAR(x) \ + (x < 0 \ + ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) x, scm_tc8_char) \ + : SCM_MAKE_ITAG8 ((scm_t_bits) x, scm_tc8_char)) #define SCM_CODEPOINT_MAX (0x10ffff) #define SCM_IS_UNICODE_CHAR(c) \ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index ecafbebdd..4536b91da 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -171,7 +171,13 @@ VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1) VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1) { - PUSH (SCM_MAKE_CHAR (FETCH ())); + scm_t_uint8 v = 0; + v = FETCH (); + + PUSH (SCM_MAKE_CHAR (v)); + /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The + contents of SCM_MAKE_CHAR may be evaluated more than once, + resulting in a double fetch. */ NEXT; } From f7118e35525e1c137f2fb96619233610549fae12 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sat, 1 Aug 2009 11:04:43 -0700 Subject: [PATCH 320/375] Fix coding style compliance for recent 32-bit char changes * libguile/print.c (iprin1): extra braces * libguile/chars.h (SCM_IS_UNICODE_CHAR): coding style --- libguile/chars.h | 4 ++-- libguile/print.c | 20 +++++++------------- 2 files changed, 9 insertions(+), 15 deletions(-) diff --git a/libguile/chars.h b/libguile/chars.h index 8e1bc64b4..97fa0cd95 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -44,8 +44,8 @@ typedef scm_t_int32 scm_t_wchar; #define SCM_CODEPOINT_MAX (0x10ffff) #define SCM_IS_UNICODE_CHAR(c) \ - ((scm_t_wchar)(c)<=0xd7ff || \ - ((scm_t_wchar)(c)>=0xe000 && (scm_t_wchar)(c)<=SCM_CODEPOINT_MAX)) + ((scm_t_wchar) (c) <= 0xd7ff \ + || ((scm_t_wchar) (c) >= 0xe000 && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX)) diff --git a/libguile/print.c b/libguile/print.c index 1a5aebe1b..f43856bbe 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -454,22 +454,16 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) /* Print the character if is graphic character. */ { if (i<256) - { - /* Character is graphic. Print it. */ - scm_putc (i, port); - } + /* Character is graphic. Print it. */ + scm_putc (i, port); else - { - /* Character is graphic but unrepresentable in - this port's encoding. */ - scm_intprint (i, 8, port); - } + /* Character is graphic but unrepresentable in + this port's encoding. */ + scm_intprint (i, 8, port); } else - { - /* Character is a non-graphical character. */ - scm_intprint (i, 8, port); - } + /* Character is a non-graphical character. */ + scm_intprint (i, 8, port); } else scm_putc (i, port); From a876e7dcea78e770bedba40017fbb225cf88bff5 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sat, 1 Aug 2009 11:21:46 -0700 Subject: [PATCH 321/375] Don't doubly define scm_t_wchar * libguile/chars.h: don't define scm_t_wchar * libguile/numbers.h: define scm_t_wchar here --- libguile/chars.h | 7 +------ libguile/numbers.h | 3 --- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/libguile/chars.h b/libguile/chars.h index 97fa0cd95..4d1be1db9 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -24,16 +24,11 @@ #include "libguile/__scm.h" +#include "libguile/numbers.h" /* Immediate Characters */ - -#ifndef SCM_WCHAR_DEFINED -typedef scm_t_int32 scm_t_wchar; -#define SCM_WCHAR_DEFINED -#endif - #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char) #define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x)) diff --git a/libguile/numbers.h b/libguile/numbers.h index f30f7d061..bb72d7ac8 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -174,10 +174,7 @@ typedef struct scm_t_complex double imag; } scm_t_complex; -#ifndef SCM_WCHAR_DEFINED typedef scm_t_int32 scm_t_wchar; -#define SCM_WCHAR_DEFINED -#endif From ee0ddd21211757664092eaec631c4c76f4aae74f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 4 Aug 2009 20:29:09 +0200 Subject: [PATCH 322/375] fix buffer overrun reading partial numbers: 1.0f, 1.0/, and 1.0+ * libguile/numbers.c (mem2decimal_from_point, mem2ureal, mem2complex): Fix a number of cases where, for invalid numbers, we could read past the end of the buffer. This happened in e.g. "1.0+", "1/" and "1.0f". But I couldn't figure out how to test for these, given that the behavior depended on the contents of uninitialized memory in the reader buffer. We'll just have to be happy with this. Thanks to Kjetil S. Matheussen for the report. --- libguile/numbers.c | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 5f56b7a29..b4bff8142 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2657,17 +2657,26 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, case 'l': case 'L': case 's': case 'S': idx++; + if (idx == len) + return SCM_BOOL_F; + start = idx; c = mem[idx]; if (c == '-') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = -1; c = mem[idx]; } else if (c == '+') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = 1; c = mem[idx]; } @@ -2783,8 +2792,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, SCM divisor; idx++; + if (idx == len) + return SCM_BOOL_F; - divisor = mem2uinteger (mem, len, &idx, radix, &x); + divisor = mem2uinteger (mem, len, &idx, radix, &x); if (scm_is_false (divisor)) return SCM_BOOL_F; @@ -2905,11 +2916,15 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (c == '+') { idx++; + if (idx == len) + return SCM_BOOL_F; sign = 1; } else if (c == '-') { idx++; + if (idx == len) + return SCM_BOOL_F; sign = -1; } else From 45cc8a38777c9f971b6aae4895311fcc9e15ce3e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 4 Aug 2009 20:46:20 +0200 Subject: [PATCH 323/375] rename configure.in to configure.ac * configure.ac: * guile-readline/configure.ac: Rename from configure.in, as recommended by the autoconf manual. --- configure.in => configure.ac | 0 guile-readline/{configure.in => configure.ac} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename configure.in => configure.ac (100%) rename guile-readline/{configure.in => configure.ac} (100%) diff --git a/configure.in b/configure.ac similarity index 100% rename from configure.in rename to configure.ac diff --git a/guile-readline/configure.in b/guile-readline/configure.ac similarity index 100% rename from guile-readline/configure.in rename to guile-readline/configure.ac From f4863880f5ef539cb545999c19b6b5c0eec9382d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 4 Aug 2009 21:16:32 +0200 Subject: [PATCH 324/375] perform gmp/unistring compile checks with AC_LIB_HAVE_LINKFLAGS * configure.ac: Rework gmp and unistring checks to use AC_LIB_HAVE_LINKFLAGS, so that the compilation checks run with the right -L/-l flags. * libguile/Makefile.am (libguile_la_LIBADD): Adapt to need to add $(LIBGMP) and $(LIBUNISTRING) here. Hopefully this solves http://article.gmane.org/gmane.lisp.guile.bugs/4288. --- configure.ac | 23 ++++++++++------------- libguile/Makefile.am | 2 +- 2 files changed, 11 insertions(+), 14 deletions(-) diff --git a/configure.ac b/configure.ac index 53049eb79..dae82954a 100644 --- a/configure.ac +++ b/configure.ac @@ -827,22 +827,19 @@ fi dnl GMP tests -AC_LIB_LINKFLAGS(gmp) -AC_CHECK_LIB([gmp], [__gmpz_init], , - [AC_MSG_ERROR([GNU MP not found, see README])]) - -# mpz_import is a macro so we need to include -AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], - [[mpz_import (0, 0, 0, 0, 0, 0, 0); ]])], +AC_LIB_HAVE_LINKFLAGS(gmp, [], - [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])]) + [#include ], + [mpz_import (0, 0, 0, 0, 0, 0, 0);], + AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README])) dnl GNU libunistring tests. -if test "x$LTLIBUNISTRING" != "x"; then - LIBS="$LTLIBUNISTRING $LIBS" -else - AC_MSG_ERROR([GNU libunistring is required, please install it.]) -fi +AC_LIB_HAVE_LINKFLAGS(unistring, + [], + [#include ], + [u8_check ("foo", 3)] + AC_MSG_ERROR([GNU libunistring not found, see README])) + dnl i18n tests #AC_CHECK_HEADERS([libintl.h]) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8c9c598bf..dfaa65a8f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -220,7 +220,7 @@ noinst_HEADERS = convert.i.c \ noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c libguile_la_DEPENDENCIES = @LIBLOBJS@ -libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) +libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING) libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined # These are headers visible as From 7382f23e58725eef2f7a374ec101a42c0192527e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 11:55:42 +0200 Subject: [PATCH 325/375] add1 and sub1 instructions * libguile/vm-i-scheme.c: Add add1 and sub1 instructions. * module/language/tree-il/compile-glil.scm: Compile 1+ and 1- to add1 and sub1. * module/language/tree-il/primitives.scm (define-primitive-expander): Add support for `if' statements in the consequent. (+, -): Compile (- x 1), (+ x 1), and (+ 1 x) to 1- or 1+ as appropriate. (1-): Remove this one. Seems we forgot 1+ before, but we weren't compiling it nicely anyway. * test-suite/tests/tree-il.test ("void"): Fix expected compilation of (+ (void) 1) to allow for add1. --- libguile/vm-i-scheme.c | 26 ++++++++++++++++++++++ module/language/tree-il/compile-glil.scm | 2 ++ module/language/tree-il/primitives.scm | 28 +++++++++++++++++++----- test-suite/tests/tree-il.test | 2 +- 4 files changed, 52 insertions(+), 6 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index dce9b5fbc..675ec1a0a 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -215,11 +215,37 @@ VM_DEFINE_FUNCTION (120, add, "add", 2) FUNC2 (+, scm_sum); } +VM_DEFINE_FUNCTION (167, add1, "add1", 1) +{ + ARGS1 (x); + if (SCM_I_INUMP (x)) + { + scm_t_int64 n = SCM_I_INUM (x) + 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_I_MAKINUM (n)); + } + SYNC_REGISTER (); + RETURN (scm_sum (x, SCM_I_MAKINUM (1))); +} + VM_DEFINE_FUNCTION (121, sub, "sub", 2) { FUNC2 (-, scm_difference); } +VM_DEFINE_FUNCTION (168, sub1, "sub1", 1) +{ + ARGS1 (x); + if (SCM_I_INUMP (x)) + { + scm_t_int64 n = SCM_I_INUM (x) - 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_I_MAKINUM (n)); + } + SYNC_REGISTER (); + RETURN (scm_difference (x, SCM_I_MAKINUM (1))); +} + VM_DEFINE_FUNCTION (122, mul, "mul", 2) { ARGS2 (x, y); diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index bf4699797..975cbf02a 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -85,6 +85,8 @@ ((>= . 2) . ge?) ((+ . 2) . add) ((- . 2) . sub) + ((1+ . 1) . add1) + ((1- . 1) . sub1) ((* . 2) . mul) ((/ . 2) . div) ((quotient . 2) . quo) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 9ccd2720d..0f58e22fb 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -19,6 +19,7 @@ ;;; Code: (define-module (language tree-il primitives) + #:use-module (system base pmatch) #:use-module (rnrs bytevector) #:use-module (system base syntax) #:use-module (language tree-il) @@ -142,8 +143,14 @@ (define (consequent exp) (cond ((pair? exp) - `(make-application src (make-primitive-ref src ',(car exp)) - ,(inline-args (cdr exp)))) + (pmatch exp + ((if ,test ,then ,else) + `(if ,test + ,(consequent then) + ,(consequent else))) + (else + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))))) ((symbol? exp) ;; assume locally bound exp) @@ -163,6 +170,15 @@ (define-primitive-expander + () 0 (x) x + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1+ x) + (if (and (const? x) + (let ((x (const-exp x))) + (and (exact? x) (= x 1)))) + (1+ y) + (+ x y))) (x y z . rest) (+ x (+ y z . rest))) (define-primitive-expander * @@ -172,11 +188,13 @@ (define-primitive-expander - (x) (- 0 x) + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1- x) + (- x y)) (x y z . rest) (- x (+ y z . rest))) -(define-primitive-expander 1- - (x) (- x 1)) - (define-primitive-expander / (x) (/ 1 x) (x y z . rest) (/ x (* y z . rest))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 896206b1f..d993e4ff2 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -72,7 +72,7 @@ (program 0 0 0 () (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive +) (void) (const 1)) - (program 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + (program 0 0 0 () (void) (call add1 1) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil From dab0f9d55db2e2f4251265443ab0599e424a02c9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 16:17:20 +0200 Subject: [PATCH 326/375] add a brain-dead inliner * module/Makefile.am (TREE_IL_LANG_SOURCES): * module/language/tree-il/inline.scm: Add a brain-dead inliner, to inline ((lambda () x)) => x. * module/language/tree-il/optimize.scm (optimize!): Invoke the inliner. --- module/Makefile.am | 1 + module/language/tree-il/inline.scm | 44 ++++++++++++++++++++++++++++ module/language/tree-il/optimize.scm | 15 +++------- 3 files changed, 49 insertions(+), 11 deletions(-) create mode 100644 module/language/tree-il/inline.scm diff --git a/module/Makefile.am b/module/Makefile.am index 2971fc6b5..b6bd341d6 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -77,6 +77,7 @@ SCHEME_LANG_SOURCES = \ TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ language/tree-il/optimize.scm \ + language/tree-il/inline.scm \ language/tree-il/analyze.scm \ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm new file mode 100644 index 000000000..10ec51c08 --- /dev/null +++ b/module/language/tree-il/inline.scm @@ -0,0 +1,44 @@ +;;; a simple inliner + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 2.1 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (language tree-il inline) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (inline!)) + +;; Possible optimizations: +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations +;; * "fixing letrec" + +;; This is a completely brain-dead optimization pass whose sole claim to +;; fame is ((lambda () x)) => x. +(define (inline! x) + (post-order! + (lambda (x) + (record-case x + (( proc args) + (and (lambda? proc) (null? args) + (lambda-body proc))) + (else #f))) + x)) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index ac16a9e39..9820f9417 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -21,21 +21,14 @@ (define-module (language tree-il optimize) #:use-module (language tree-il) #:use-module (language tree-il primitives) + #:use-module (language tree-il inline) #:export (optimize!)) (define (env-module e) (if e (car e) (current-module))) (define (optimize! x env opts) - (expand-primitives! (resolve-primitives! x (env-module env)))) - -;; Possible optimizations: -;; * constant folding, propagation -;; * procedure inlining -;; * always when single call site -;; * always for "trivial" procs -;; * otherwise who knows -;; * dead code elimination -;; * degenerate case optimizations -;; * "fixing letrec" + (inline! + (expand-primitives! + (resolve-primitives! x (env-module env))))) From c21c89b1384415313cd4bc03e76d6e1507e48d7a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 17:51:40 +0200 Subject: [PATCH 327/375] add tree-il construct, and compile it * libguile/vm-i-system.c (fix-closure): New instruction, for wiring together fixpoint procedures. * module/Makefile.am (TREE_IL_LANG_SOURCES): Add fix-letrec.scm. * module/language/glil/compile-assembly.scm (glil->assembly): Reindent the case, and handle 'fix for locally-bound vars. * module/language/tree-il.scm (): Add the tree-il type and accessors, for fixed-point bindings. This IL construct is taken from the Waddell paper. (parse-tree-il, unparse-tree-il, tree-il->scheme, tree-il-fold) (pre-order!, post-order!): Update for . * module/language/tree-il/analyze.scm (analyze-lexicals): Update for . The difference here is that the bindings may not be assigned, and are not marked as such. They are not boxed. (report-unused-variables): Update for . * module/language/tree-il/compile-glil.scm (flatten): Compile to GLIL. * module/language/tree-il/fix-letrec.scm: A stub implementation of fixing letrec -- will flesh out in a separate commit. * module/language/tree-il/inline.scm: Fix license, it was mistakenly added with LGPL v2.1+. * module/language/tree-il/optimize.scm (optimize!): Run the fix-letrec! pass. --- libguile/vm-i-system.c | 14 ++++++ module/Makefile.am | 1 + module/language/glil/compile-assembly.scm | 60 +++++++++++++---------- module/language/tree-il.scm | 24 +++++++++ module/language/tree-il/analyze.scm | 27 ++++++++++ module/language/tree-il/compile-glil.scm | 43 ++++++++++++++++ module/language/tree-il/fix-letrec.scm | 29 +++++++++++ module/language/tree-il/inline.scm | 26 +++++----- module/language/tree-il/optimize.scm | 9 ++-- 9 files changed, 189 insertions(+), 44 deletions(-) create mode 100644 module/language/tree-il/fix-letrec.scm diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 4536b91da..9604ce55a 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1232,6 +1232,20 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1) +{ + SCM x, vect; + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + POP (vect); + /* FIXME CHECK_LOCAL (i) */ + x = LOCAL_REF (i); + /* FIXME ASSERT_PROGRAM (x); */ + SCM_SET_CELL_WORD_3 (x, vect); + NEXT; +} + /* (defun renumber-ops () diff --git a/module/Makefile.am b/module/Makefile.am index b6bd341d6..f3b7e62d5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -78,6 +78,7 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ language/tree-il/optimize.scm \ language/tree-il/inline.scm \ + language/tree-il/fix-letrec.scm \ language/tree-il/analyze.scm \ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index fa5805757..4bd6c4f04 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -251,35 +251,41 @@ (emit-code (if local? (if (< index 256) - `((,(case op - ((ref) (if boxed? 'local-boxed-ref 'local-ref)) - ((set) (if boxed? 'local-boxed-set 'local-set)) - ((box) 'box) - ((empty-box) 'empty-box) - (else (error "what" op))) - ,index)) + (case op + ((ref) (if boxed? + `((local-boxed-ref ,index)) + `((local-ref ,index)))) + ((set) (if boxed? + `((local-boxed-set ,index)) + `((local-set ,index)))) + ((box) `((box ,index))) + ((empty-box) `((empty-box ,index))) + ((fix) `((fix-closure 0 ,index))) + (else (error "what" op))) (let ((a (quotient i 256)) (b (modulo i 256))) - `((,(case op - ((ref) - (if boxed? - `((long-local-ref ,a ,b) - (variable-ref)) - `((long-local-ref ,a ,b)))) - ((set) - (if boxed? - `((long-local-ref ,a ,b) - (variable-set)) - `((long-local-set ,a ,b)))) - ((box) - `((make-variable) - (variable-set) - (long-local-set ,a ,b))) - ((empty-box) - `((make-variable) - (long-local-set ,a ,b))) - (else (error "what" op))) - ,index)))) + `((,(case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + ((fix) + `((fix-closure ,a ,b))) + (else (error "what" op))) + ,index)))) `((,(case op ((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((set) (if boxed? 'free-boxed-set (error "what." glil))) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index aec4eedb9..01d52f181 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -38,6 +38,7 @@ lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body let? make-let let-src let-names let-vars let-vals let-body letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body + fix? make-fix fix-src fix-names fix-vars fix-vals fix-body let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body parse-tree-il @@ -65,6 +66,7 @@ ( names vars meta body) ( names vars vals body) ( names vars vals body) + ( names vars vals body) ( names vars exp body)) @@ -141,6 +143,9 @@ ((letrec ,names ,vars ,vals ,body) (make-letrec loc names vars (map retrans vals) (retrans body))) + ((fix ,names ,vars ,vals ,body) + (make-fix loc names vars (map retrans vals) (retrans body))) + ((let-values ,names ,vars ,exp ,body) (make-let-values loc names vars (retrans exp) (retrans body))) @@ -197,6 +202,9 @@ (( names vars vals body) `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (( names vars vals body) + `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (( names vars exp body) `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) @@ -256,6 +264,10 @@ (( vars vals body) `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + (( vars vals body) + ;; not a typo, we really do translate back to letrec + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + (( vars exp body) `(call-with-values (lambda () ,(tree-il->scheme exp)) (lambda ,vars ,(tree-il->scheme body)))))) @@ -300,6 +312,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (up tree (loop body (loop vals (down tree result))))) + (( vals body) + (up tree (loop body + (loop vals + (down tree result))))) (( body) (up tree (loop body (down tree result)))) (else @@ -343,6 +359,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (letrec-vals x) (map lp vals)) (set! (letrec-body x) (lp body))) + (( vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + (( vars exp body) (set! (let-values-exp x) (lp exp)) (set! (let-values-body x) (lp body))) @@ -390,6 +410,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (letrec-vals x) (map lp vals)) (set! (letrec-body x) (lp body))) + (( vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + (( vars exp body) (set! (let-values-exp x) (lp exp)) (set! (let-values-body x) (lp body))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1b39b2dd4..35ddfaa3b 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -177,6 +177,13 @@ (apply lset-union eq? (step body) (map step vals)) vars)) + (( vars vals body) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (lset-difference eq? + (apply lset-union eq? (step body) (map step vals)) + vars)) + (( vars exp body) (hashq-set! bound-vars proc (let lp ((out (hashq-ref bound-vars proc)) (in vars)) @@ -285,6 +292,20 @@ `(#t ,(hashq-ref assigned v) . ,n))) (lp (cdr vars) (1+ n)))))) + (( vars vals body) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x proc n)) + vals)))) + (max nmax (allocate! body proc n))) + (let ((v (car vars))) + (if (hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr vars) (1+ n)))))) + (( vars exp body) (let ((nmax (recur exp))) (let lp ((vars vars) (n n)) @@ -381,6 +402,9 @@ (( vars names) (make-binding-info (extend vars names) refs (cons src locs))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) (( vars names) (make-binding-info (extend vars names) refs (cons src locs))) @@ -428,6 +452,9 @@ (( vars) (make-binding-info (shrink vars refs) refs (cdr locs))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) (( vars) (make-binding-info (shrink vars refs) refs (cdr locs))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 975cbf02a..e3e45f56c 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -557,6 +557,49 @@ (comp-tail body) (emit-code #f (make-glil-unbind))) + (( src names vars vals body) + ;; For fixpoint procedures, we can do some tricks to avoid + ;; heap-allocation. Since we know the vals are lambdas, we can + ;; set them to their local var slots first, then capture their + ;; bindings, mutating them in place. + (for-each (lambda (x v) + (emit-code #f (flatten-lambda x allocation)) + (if (not (null? (cdr (hashq-ref allocation x)))) + ;; But we do have to make-closure them first, so + ;; we are mutating fresh closures on the heap. + (begin + (emit-code #f (make-glil-const #f)) + (emit-code #f (make-glil-call 'make-closure 2)))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + (,loc (error "badness" x loc)))) + vals + vars) + (emit-bindings src names vars allocation proc emit-code) + ;; Now go back and fix up the bindings. + (for-each + (lambda (x v) + (let ((free-locs (cdr (hashq-ref allocation x)))) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code #f (make-glil-lexical #t #f 'fix n))) + (,loc (error "badness" x loc))))))) + vals + vars) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + (( src names vars exp body) (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) (cond diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm new file mode 100644 index 000000000..61504f6f1 --- /dev/null +++ b/module/language/tree-il/fix-letrec.scm @@ -0,0 +1,29 @@ +;;; transformation of letrec into simpler forms + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (language tree-il fix-letrec) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (fix-letrec!)) + +;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet +;; Efficient Implementation of Scheme’s Recursive Binding Construct", by +;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig. + +(define (fix-letrec! x) + x) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index 10ec51c08..c534f195b 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -2,19 +2,19 @@ ;; Copyright (C) 2009 Free Software Foundation, Inc. -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (language tree-il inline) #:use-module (system base syntax) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 9820f9417..23505201c 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -22,13 +22,14 @@ #:use-module (language tree-il) #:use-module (language tree-il primitives) #:use-module (language tree-il inline) + #:use-module (language tree-il fix-letrec) #:export (optimize!)) (define (env-module e) (if e (car e) (current-module))) (define (optimize! x env opts) - (inline! - (expand-primitives! - (resolve-primitives! x (env-module env))))) - + (fix-letrec! + (inline! + (expand-primitives! + (resolve-primitives! x (env-module env)))))) From 4dcd84998fc61e15920aea83c4420c7357b9be46 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 5 Aug 2009 21:25:35 +0200 Subject: [PATCH 328/375] let-values in terms of syntax-case, add make-tree-il-folder * module/language/tree-il.scm (tree-il-fold): Fix for let-values case. (make-tree-il-folder): New public macro, makes a multi-valued folder specific to the number of seeds that the user wants. * module/language/tree-il/optimize.scm (optimize!): Reverse the order of inline! and fix-letrec!, as the latter might expose opportunities for the former. * module/srfi/srfi-11.scm (let-values): Reimplement in terms of syntax-case, so that its expressions may reference hygienically bound variables. See the NEWS for the rationale. (let*-values): An empty let*-values still introduces a local `let' binding contour. * module/system/base/syntax.scm (record-case): Yukkkk. Reimplement in terms of syntax-case. Ug-ly, but see the NEWS again: "Lexical bindings introduced by hygienic macros may not be referenced by nonhygienic macros." --- module/language/tree-il.scm | 78 +++++++++- module/language/tree-il/optimize.scm | 4 +- module/srfi/srfi-11.scm | 212 +++++++-------------------- module/system/base/syntax.scm | 89 ++++++++--- 4 files changed, 194 insertions(+), 189 deletions(-) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 01d52f181..8ad7065c6 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -18,6 +18,7 @@ (define-module (language tree-il) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (system base pmatch) #:use-module (system base syntax) #:export (tree-il-src @@ -46,6 +47,7 @@ tree-il->scheme tree-il-fold + make-tree-il-folder post-order! pre-order!)) @@ -316,11 +318,83 @@ This is an implementation of `foldts' as described by Andy Wingo in (up tree (loop body (loop vals (down tree result))))) - (( body) - (up tree (loop body (down tree result)))) + (( exp body) + (up tree (loop body (loop exp (down tree result))))) (else (leaf tree result)))))) + +(define-syntax make-tree-il-folder + (syntax-rules () + ((_ seed ...) + (lambda (tree down up leaf seed ...) + (define (fold-values proc exps seed ...) + (if (null? exps) + (values seed ...) + (let-values (((seed ...) (proc (car exps) seed ...))) + (fold-values proc (cdr exps) seed ...)))) + (let foldts ((tree tree) (seed seed) ...) + (record-case tree + (( exp) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (foldts exp seed ...))) + (up tree seed ...))) + (( exp) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (foldts exp seed ...))) + (up tree seed ...))) + (( exp) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (foldts exp seed ...))) + (up tree seed ...))) + (( exp) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (foldts exp seed ...))) + (up tree seed ...))) + (( test then else) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (foldts test seed ...)) + ((seed ...) (foldts then seed ...)) + ((seed ...) (foldts else seed ...))) + (up tree seed ...))) + (( proc args) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (foldts proc seed ...)) + ((seed ...) (fold-values foldts args seed ...))) + (up tree seed ...))) + (( exps) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (fold-values foldts exps seed ...))) + (up tree seed ...))) + (( body) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (foldts body seed ...))) + (up tree seed ...))) + (( vals body) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (fold-values foldts vals seed ...)) + ((seed ...) (foldts body seed ...))) + (up tree seed ...))) + (( vals body) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (fold-values foldts vals seed ...)) + ((seed ...) (foldts body seed ...))) + (up tree seed ...))) + + (( vals body) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (fold-values foldts vals seed ...)) + ((seed ...) (foldts body seed ...))) + (up tree seed ...))) + (( exp body) + (let*-values (((seed ...) (down tree seed ...)) + ((seed ...) (fold-values foldts vals seed ...)) + ((seed ...) (foldts body seed ...))) + (up tree seed ...))) + (else + (leaf tree seed ...)))))))) + + (define (post-order! f x) (let lp ((x x)) (record-case x diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 23505201c..0e490a636 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -29,7 +29,7 @@ (if e (car e) (current-module))) (define (optimize! x env opts) - (fix-letrec! - (inline! + (inline! + (fix-letrec! (expand-primitives! (resolve-primitives! x (env-module env)))))) diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index c8422eeaf..8a41d00f7 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -1,6 +1,6 @@ ;;; srfi-11.scm --- let-values and let*-values -;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -63,148 +63,55 @@ ;; (q )) ;; (baz x y z p q)))))) -;; I originally wrote this as a define-macro, but then I found out -;; that guile's gensym/gentemp was broken, so I tried rewriting it as -;; a syntax-rules statement. -;; [make-symbol now fixes gensym/gentemp problems.] -;; -;; Since syntax-rules didn't seem powerful enough to implement -;; let-values in one definition without exposing illegal syntax (or -;; perhaps my brain's just not powerful enough :>). I tried writing -;; it using a private helper, but that didn't work because the -;; let-values expands outside the scope of this module. I wonder why -;; syntax-rules wasn't designed to allow "private" patterns or -;; similar... -;; -;; So in the end, I dumped the syntax-rules implementation, reproduced -;; here for posterity, and went with the define-macro one below -- -;; gensym/gentemp's got to be fixed anyhow... -; -; (define-syntax let-values-helper -; (syntax-rules () -; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y -; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda -; ;; ( ) ...) from above, keeping track of the -; ;; temps you create so you can use them later... -; ;; -; ;; I really don't fully understand why the (var-1 var-1) trick -; ;; works below, but basically, when all those (x x) bindings show -; ;; up in the final "let", syntax-rules forces a renaming. - -; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings -; body ...) -; (lambda lambda-tmps -; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) - -; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings -; body ...) -; (let-values-helper "consumer" -; (var-2 ...) -; (lambda-tmp ... var-1) -; ((var-1 var-1) . final-let-bindings) -; lv-bindings -; body ...)) - -; ((_ "cwv" () final-let-bindings body ...) -; (let final-let-bindings -; body ...)) - -; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings -; body ...) -; (call-with-values (lambda () binding-1) -; (let-values-helper "consumer" -; vars-1 -; () -; final-let-bindings -; (other-bindings ...) -; body ...))))) -; -; (define-syntax let-values -; (syntax-rules () -; ((let-values () body ...) -; (begin body ...)) -; ((let-values (binding ...) body ...) -; (let-values-helper "cwv" (binding ...) () body ...)))) -; -; -; (define-syntax let-values -; (letrec-syntax ((build-consumer -; ;; Take the vars from one let binding (i.e. the (x -; ;; y z) from ((x y z) (values 1 2 3)) and turn it -; ;; in to the corresponding (lambda ( -; ;; ) ...) from above. -; (syntax-rules () -; ((_ () new-tmps tmp-vars () body ...) -; (lambda new-tmps -; body ...)) -; ((_ () new-tmps tmp-vars vars body ...) -; (lambda new-tmps -; (lv-builder vars tmp-vars body ...))) -; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) -; (build-consumer (var-2 ...) -; (tmp-1 . new-tmps) -; ((var-1 tmp-1) . tmp-vars) -; bindings -; body ...)))) -; (lv-builder -; (syntax-rules () -; ((_ () tmp-vars body ...) -; (let tmp-vars -; body ...)) -; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) -; tmp-vars -; body ...) -; (call-with-values (lambda () binding-1) -; (build-consumer vars-1 -; () -; tmp-vars -; ((vars-2 binding-2) ...) -; body ...)))))) -; -; (syntax-rules () -; ((_ () body ...) -; (begin body ...)) -; ((_ ((vars binding) ...) body ...) -; (lv-builder ((vars binding) ...) () body ...))))) - -(define-macro (let-values vars . body) - - (define (map-1-dot proc elts) - ;; map over one optionally dotted (a b c . d) list, producing an - ;; optionally dotted result. - (cond - ((null? elts) '()) - ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) - (else (proc elts)))) - - (define (undot-list lst) - ;; produce a non-dotted list from a possibly dotted list. - (cond - ((null? lst) '()) - ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) - (else (list lst)))) - - (define (let-values-helper vars body prev-let-vars) - (let* ((var-binding (car vars)) - (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var")) - (car var-binding))) - (let-vars (map (lambda (sym tmp) (list sym tmp)) - (undot-list (car var-binding)) - (undot-list new-tmps)))) - - (if (null? (cdr vars)) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - (let ,(apply append let-vars prev-let-vars) - ,@body))) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - ,(let-values-helper (cdr vars) body - (cons let-vars prev-let-vars))))))) - - (if (null? vars) - `(begin ,@body) - (let-values-helper vars body '()))) +;; We could really use quasisyntax here... +(define-syntax let-values + (lambda (x) + (syntax-case x () + ((_ (clause ...) b0 b1 ...) + (let lp ((clauses (syntax (clause ...))) + (ids '()) + (tmps '())) + (if (null? clauses) + (with-syntax (((id ...) ids) + ((tmp ...) tmps)) + (syntax (let ((id tmp) ...) + b0 b1 ...))) + (syntax-case (car clauses) () + (((var ...) exp) + (with-syntax (((new-tmp ...) (generate-temporaries + (syntax (var ...)))) + ((id ...) ids) + ((tmp ...) tmps)) + (with-syntax ((inner (lp (cdr clauses) + (syntax (var ... id ...)) + (syntax (new-tmp ... tmp ...))))) + (syntax (call-with-values (lambda () exp) + (lambda (new-tmp ...) inner)))))) + ((vars exp) + (with-syntax ((((new-tmp . new-var) ...) + (let lp ((vars (syntax vars))) + (syntax-case vars () + ((id . rest) + (acons (syntax id) + (car + (generate-temporaries (syntax (id)))) + (lp (syntax rest)))) + (id (acons (syntax id) + (car + (generate-temporaries (syntax (id)))) + '()))))) + ((id ...) ids) + ((tmp ...) tmps)) + (with-syntax ((inner (lp (cdr clauses) + (syntax (new-var ... id ...)) + (syntax (new-tmp ... tmp ...)))) + (args (let lp ((tmps (syntax (new-tmp ...)))) + (syntax-case tmps () + ((id) (syntax id)) + ((id . rest) (cons (syntax id) + (lp (syntax rest)))))))) + (syntax (call-with-values (lambda () exp) + (lambda args inner))))))))))))) ;;;;;;;;;;;;;; ;; let*-values @@ -226,28 +133,11 @@ (define-syntax let*-values (syntax-rules () ((let*-values () body ...) - (begin body ...)) + (let () body ...)) ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) (call-with-values (lambda () binding-1) (lambda vars-1 (let*-values ((vars-2 binding-2) ...) body ...)))))) -; Alternate define-macro implementation... -; -; (define-macro (let*-values vars . body) -; (define (let-values-helper vars body) -; (let ((var-binding (car vars))) -; (if (null? (cdr vars)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,@body)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,(let-values-helper (cdr vars) body)))))) - -; (if (null? vars) -; `(begin ,@body) -; (let-values-helper vars body))) - ;;; srfi-11.scm ends here diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index cc73f38d1..249961d79 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -1,6 +1,6 @@ ;;; Guile VM specific syntaxes and utilities -;; Copyright (C) 2001 Free Software Foundation, Inc +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -174,29 +174,70 @@ ;; 5.88 0.01 0.01 list-index -(define-macro (record-case record . clauses) - (let ((r (gensym)) - (rtd (gensym))) - (define (process-clause clause) - (if (eq? (car clause) 'else) - clause - (let ((record-type (caar clause)) - (slots (cdar clause)) - (body (cdr clause))) - (let ((stem (trim-brackets record-type))) - `((eq? ,rtd ,record-type) - (let ,(map (lambda (slot) - (if (pair? slot) - `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r)) - `(,slot (,(symbol-append stem '- slot) ,r)))) - slots) - ,@(if (pair? body) body '((if #f #f))))))))) - `(let* ((,r ,record) - (,rtd (struct-vtable ,r))) - (cond ,@(let ((clauses (map process-clause clauses))) - (if (assq 'else clauses) - clauses - (append clauses `((else (error "unhandled record" ,r)))))))))) +;;; So ugly... but I am too ignorant to know how to make it better. +(define-syntax record-case + (lambda (x) + (syntax-case x () + ((_ record clause ...) + (let ((r (syntax r)) + (rtd (syntax rtd))) + (define (process-clause tag fields exprs) + (let ((infix (trim-brackets (syntax->datum tag)))) + (with-syntax ((tag tag) + (((f . accessor) ...) + (let lp ((fields fields)) + (syntax-case fields () + (() (syntax ())) + (((v0 f0) f1 ...) + (acons (syntax v0) + (datum->syntax x + (symbol-append infix '- (syntax->datum + (syntax f0)))) + (lp (syntax (f1 ...))))) + ((f0 f1 ...) + (acons (syntax f0) + (datum->syntax x + (symbol-append infix '- (syntax->datum + (syntax f0)))) + (lp (syntax (f1 ...)))))))) + ((e0 e1 ...) + (syntax-case exprs () + (() (syntax (#t))) + ((e0 e1 ...) (syntax (e0 e1 ...)))))) + (syntax + ((eq? rtd tag) + (let ((f (accessor r)) + ...) + e0 e1 ...)))))) + (with-syntax + ((r r) + (rtd rtd) + ((processed ...) + (let lp ((clauses (syntax (clause ...))) + (out '())) + (syntax-case clauses (else) + (() + (reverse! (cons (syntax + (else (error "unhandled record" r))) + out))) + (((else e0 e1 ...)) + (reverse! (cons (syntax (else e0 e1 ...)) out))) + (((else e0 e1 ...) . rest) + (syntax-violation 'record-case + "bad else clause placement" + (syntax x) + (syntax (else e0 e1 ...)))) + (((( f0 ...) e0 ...) . rest) + (lp (syntax rest) + (cons (process-clause (syntax ) + (syntax (f0 ...)) + (syntax (e0 ...))) + out))))))) + (syntax + (let* ((r record) + (rtd (struct-vtable r))) + (cond processed ...))))))))) + ;; Here we take the terrorism to another level. Nasty, but the client ;; code looks good. From bca488f186ce662e8c41b8ac1675fa2f03bb3fc2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 6 Aug 2009 11:48:16 +0200 Subject: [PATCH 329/375] actually inline call-with-values to tree-il's * module/srfi/srfi-11.scm (let-values): In the one-clause case, avoid going through temporary variables. * module/language/tree-il/inline.scm (inline!): Add another case: (call-with-values (lambda () ...) (lambda ... ...) -> let-values. * module/language/tree-il/compile-glil.scm (flatten): Fix a bug compiling applications in "vals" context. * module/language/tree-il/analyze.scm (analyze-lexicals): Fix a couple bugs with let-values and rest arguments. --- module/language/tree-il/analyze.scm | 42 ++++++++++++++---------- module/language/tree-il/compile-glil.scm | 2 +- module/language/tree-il/inline.scm | 33 +++++++++++++++++-- module/srfi/srfi-11.scm | 3 ++ 4 files changed, 59 insertions(+), 21 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 35ddfaa3b..73ef8ba21 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -185,14 +185,14 @@ vars)) (( vars exp body) - (hashq-set! bound-vars proc - (let lp ((out (hashq-ref bound-vars proc)) (in vars)) - (if (pair? in) - (lp (cons (car in) out) (cdr in)) - (if (null? in) out (cons in out))))) - (lset-difference eq? - (lset-union eq? (step exp) (step body)) - vars)) + (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars)) + (if (pair? in) + (lp (cons (car in) out) (cdr in)) + (if (null? in) out (cons in out)))))) + (hashq-set! bound-vars proc bound) + (lset-difference eq? + (lset-union eq? (step exp) (step body)) + bound))) (else '()))) @@ -309,15 +309,23 @@ (( vars exp body) (let ((nmax (recur exp))) (let lp ((vars vars) (n n)) - (if (null? vars) - (max nmax (allocate! body proc n)) - (let ((v (if (pair? vars) (car vars) vars))) - (let ((v (car vars))) - (hashq-set! - allocation v - (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) - (lp (cdr vars) (1+ n)))))))) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((not (pair? vars)) + (hashq-set! allocation vars + (make-hashq proc + `(#t ,(hashq-ref assigned vars) . ,n))) + ;; the 1+ for this var + (max nmax (allocate! body proc (1+ n)))) + (else + (let ((v (if (pair? vars) (car vars) vars))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n))))))))) (else n))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e3e45f56c..3d25dd181 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -391,7 +391,7 @@ (case context ((tail) (emit-code src (make-glil-call 'goto/args len))) ((push) (emit-code src (make-glil-call 'call len))) - ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA))) + ((vals) (emit-code src (make-glil-mv-call len LMVRA))) ((drop) (let ((MV (make-label)) (POST (make-label))) (emit-code src (make-glil-mv-call len MV)) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index c534f195b..fd3fbc921 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -37,8 +37,35 @@ (post-order! (lambda (x) (record-case x - (( proc args) - (and (lambda? proc) (null? args) - (lambda-body proc))) + (( src proc args) + (cond + + ;; ((lambda () x)) => x + ((and (lambda? proc) (null? args)) + (lambda-body proc)) + + ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) + ;; => (let-values (((a b . c) foo)) bar) + ;; + ;; Note that this is a singly-binding form of let-values. Also + ;; note that Scheme's let-values expands into call-with-values, + ;; then here we reduce it to tree-il's let-values. + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2) + (lambda? (cadr args))) + (let ((producer (car args)) + (consumer (cadr args))) + (make-let-values src + (lambda-names consumer) + (lambda-vars consumer) + (if (and (lambda? producer) + (null? (lambda-names producer))) + (lambda-body producer) + (make-application src producer '())) + (lambda-body consumer)))) + + (else #f))) + (else #f))) x)) diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index 8a41d00f7..22bda21a2 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -67,6 +67,9 @@ (define-syntax let-values (lambda (x) (syntax-case x () + ((_ ((binds exp)) b0 b1 ...) + (syntax (call-with-values (lambda () exp) + (lambda binds b0 b1 ...)))) ((_ (clause ...) b0 b1 ...) (let lp ((clauses (syntax (clause ...))) (ids '()) From 80af1168751e59a3ee5c4a79febb2da23d36112d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 6 Aug 2009 16:01:24 +0200 Subject: [PATCH 330/375] actually implement "fixing letrec" * module/Makefile.am (SOURCES): Reorganize so GHIL is compiled last, along with ecmascript. * module/language/scheme/spec.scm: Remove references to GHIL, as it's bitrotten and obsolete.. * module/language/tree-il.scm (make-tree-il-folder): Rework so that we only have down and up procs, and call down and up on each element. * module/language/tree-il/analyze.scm (analyze-lexicals): Fix a thinko handling let-values. * module/language/tree-il/fix-letrec.scm: Actually implement fixing letrec. The resulting code will perform better, but violations of the letrec restriction are not detected. This behavior is allowed by the spec, but it is undesirable. Perhaps that will be fixed later. * module/language/tree-il/inline.scm (inline!): Fix a case in which ((lambda args foo)) would be erroneously inlined to foo. Remove empty let, letrec, and fix statements. * module/language/tree-il/primitives.scm (effect-free-primitive?): New public predicate. --- module/Makefile.am | 13 ++- module/language/scheme/spec.scm | 6 +- module/language/tree-il.scm | 100 +++++++--------- module/language/tree-il/analyze.scm | 13 +-- module/language/tree-il/fix-letrec.scm | 153 ++++++++++++++++++++++++- module/language/tree-il/inline.scm | 14 ++- module/language/tree-il/primitives.scm | 35 +++++- 7 files changed, 252 insertions(+), 82 deletions(-) diff --git a/module/Makefile.am b/module/Makefile.am index f3b7e62d5..5eec063c2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -37,11 +37,11 @@ SOURCES = \ system/base/message.scm \ \ language/tree-il.scm \ - language/ghil.scm language/glil.scm language/assembly.scm \ + language/glil.scm language/assembly.scm \ \ $(SCHEME_LANG_SOURCES) \ $(TREE_IL_LANG_SOURCES) \ - $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ + $(GLIL_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ \ @@ -50,9 +50,10 @@ SOURCES = \ $(RNRS_SOURCES) \ $(OOP_SOURCES) \ $(SYSTEM_SOURCES) \ + $(SCRIPTS_SOURCES) \ + $(GHIL_LANG_SOURCES) \ $(ECMASCRIPT_LANG_SOURCES) \ - $(BRAINFUCK_LANG_SOURCES) \ - $(SCRIPTS_SOURCES) + $(BRAINFUCK_LANG_SOURCES) ## test.scm is not currently installed. EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008 @@ -83,8 +84,8 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm -GHIL_LANG_SOURCES = \ - language/ghil/spec.scm language/ghil/compile-glil.scm +GHIL_LANG_SOURCES = \ + language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm GLIL_LANG_SOURCES = \ language/glil/spec.scm language/glil/compile-assembly.scm \ diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 21aa023a5..df618581f 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -1,6 +1,6 @@ ;;; Guile Scheme specification -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -20,7 +20,6 @@ (define-module (language scheme spec) #:use-module (system base language) - #:use-module (language scheme compile-ghil) #:use-module (language scheme compile-tree-il) #:use-module (language scheme decompile-tree-il) #:export (scheme)) @@ -39,8 +38,7 @@ #:title "Guile Scheme" #:version "0.5" #:reader read - #:compilers `((tree-il . ,compile-tree-il) - (ghil . ,compile-ghil)) + #:compilers `((tree-il . ,compile-tree-il)) #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 8ad7065c6..ad8b73176 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -327,73 +327,51 @@ This is an implementation of `foldts' as described by Andy Wingo in (define-syntax make-tree-il-folder (syntax-rules () ((_ seed ...) - (lambda (tree down up leaf seed ...) + (lambda (tree down up seed ...) (define (fold-values proc exps seed ...) (if (null? exps) (values seed ...) (let-values (((seed ...) (proc (car exps) seed ...))) (fold-values proc (cdr exps) seed ...)))) (let foldts ((tree tree) (seed seed) ...) - (record-case tree - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( exp) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts exp seed ...))) - (up tree seed ...))) - (( test then else) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts test seed ...)) - ((seed ...) (foldts then seed ...)) - ((seed ...) (foldts else seed ...))) - (up tree seed ...))) - (( proc args) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts proc seed ...)) - ((seed ...) (fold-values foldts args seed ...))) - (up tree seed ...))) - (( exps) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts exps seed ...))) - (up tree seed ...))) - (( body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - (( vals body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts vals seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - (( vals body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts vals seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - - (( vals body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts vals seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - (( exp body) - (let*-values (((seed ...) (down tree seed ...)) - ((seed ...) (fold-values foldts vals seed ...)) - ((seed ...) (foldts body seed ...))) - (up tree seed ...))) - (else - (leaf tree seed ...)))))))) - + (let*-values + (((seed ...) (down tree seed ...)) + ((seed ...) + (record-case tree + (( exp) + (foldts exp seed ...)) + (( exp) + (foldts exp seed ...)) + (( exp) + (foldts exp seed ...)) + (( exp) + (foldts exp seed ...)) + (( test then else) + (let*-values (((seed ...) (foldts test seed ...)) + ((seed ...) (foldts then seed ...))) + (foldts else seed ...))) + (( proc args) + (let-values (((seed ...) (foldts proc seed ...))) + (fold-values foldts args seed ...))) + (( exps) + (fold-values foldts exps seed ...)) + (( body) + (foldts body seed ...)) + (( vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + (( vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + (( vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + (( exp body) + (let*-values (((seed ...) (foldts exp seed ...))) + (foldts body seed ...))) + (else + (values seed ...))))) + (up tree seed ...))))))) (define (post-order! f x) (let lp ((x x)) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 73ef8ba21..49633aa28 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -319,13 +319,12 @@ ;; the 1+ for this var (max nmax (allocate! body proc (1+ n)))) (else - (let ((v (if (pair? vars) (car vars) vars))) - (let ((v (car vars))) - (hashq-set! - allocation v - (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) - (lp (cdr vars) (1+ n))))))))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))))) (else n))) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 61504f6f1..0ed7b6bab 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -18,12 +18,163 @@ (define-module (language tree-il fix-letrec) #:use-module (system base syntax) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (language tree-il) + #:use-module (language tree-il primitives) #:export (fix-letrec!)) ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet ;; Efficient Implementation of Scheme’s Recursive Binding Construct", by ;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig. +(define fix-fold + (make-tree-il-folder unref ref set simple lambda complex)) + +(define (simple-expression? x bound-vars) + (record-case x + (() #t) + (() #t) + (( gensym) + (not (memq gensym bound-vars))) + (( test then else) + (and (simple-expression? test bound-vars) + (simple-expression? then bound-vars) + (simple-expression? else bound-vars))) + (( exps) + (and-map (lambda (x) (simple-expression? x bound-vars)) + exps)) + (( proc args) + (and (primitive-ref? proc) + (effect-free-primitive? (primitive-ref-name proc)) + (and-map (lambda (x) (simple-expression? x bound-vars)) + args))) + (else #f))) + +(define (partition-vars x) + (let-values + (((unref ref set simple lambda* complex) + (fix-fold x + (lambda (x unref ref set simple lambda* complex) + (record-case x + (( gensym) + (values (delq gensym unref) + (lset-adjoin eq? ref gensym) + set + simple + lambda* + complex)) + (( gensym) + (values unref + ref + (lset-adjoin eq? set gensym) + simple + lambda* + complex)) + (( vars) + (values (append vars unref) + ref + set + simple + lambda* + complex)) + (else + (values unref ref set simple lambda* complex)))) + (lambda (x unref ref set simple lambda* complex) + (record-case x + (( (orig-vars vars) vals) + (let lp ((vars orig-vars) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? vars) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car vars) unref) + (lp (cdr vars) (cdr vals) + s l c)) + ((memq (car vars) set) + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c))) + ((lambda? (car vals)) + (lp (cdr vars) (cdr vals) + s (cons (car vars) l) c)) + ((simple-expression? (car vals) orig-vars) + (lp (cdr vars) (cdr vals) + (cons (car vars) s) l c)) + (else + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c)))))) + (else + (values unref ref set simple lambda* complex)))) + '() + '() + '() + '() + '() + '()))) + (values unref simple lambda* complex))) + (define (fix-letrec! x) - x) + (let-values (((unref simple lambda* complex) (partition-vars x))) + (post-order! + (lambda (x) + (record-case x + + ;; Sets to unreferenced variables may be replaced by their + ;; expression, called for effect. + (( gensym exp) + (if (memq gensym unref) + (make-sequence #f (list (make-void #f) exp)) + x)) + + (( src names vars vals body) + (let ((binds (map list vars names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? vars set))) + (let ((u (lookup unref)) + (s (lookup simple)) + (l (lookup lambda*)) + (c (lookup complex))) + ;; Bind "simple" bindings, and locations for complex + ;; bindings. + (make-let + src + (append (map cadr s) (map cadr c)) + (append (map car s) (map car c)) + (append (map caddr s) (map (lambda (x) (make-void #f)) c)) + ;; Bind lambdas using the fixpoint operator. + (make-fix + src (map cadr l) (map car l) (map caddr l) + (make-sequence + src + (append + ;; The right-hand-sides of the unreferenced + ;; bindings, for effect. + (map caddr u) + (if (null? c) + ;; No complex bindings, just emit the body. + (list body) + (list + ;; Evaluate the the "complex" bindings, in a `let' to + ;; indicate that order doesn't matter, and bind to + ;; their variables. + (let ((tmps (map (lambda (x) (gensym)) c))) + (make-let + #f (map cadr c) tmps (map caddr c) + (make-sequence + #f + (map (lambda (x tmp) + (make-lexical-set + #f (cadr x) (car x) + (make-lexical-ref #f (cadr x) tmp))) + c tmps)))) + ;; Finally, the body. + body))))))))) + + (else x))) + x))) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index fd3fbc921..adc3f18bd 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -41,7 +41,8 @@ (cond ;; ((lambda () x)) => x - ((and (lambda? proc) (null? args)) + ((and (lambda? proc) (null? (lambda-vars proc)) + (null? args)) (lambda-body proc)) ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) @@ -66,6 +67,15 @@ (lambda-body consumer)))) (else #f))) - + + (( vars body) + (if (null? vars) body x)) + + (( vars body) + (if (null? vars) body x)) + + (( vars body) + (if (null? vars) body x)) + (else #f))) x)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 0f58e22fb..24900c64d 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -25,7 +25,7 @@ #:use-module (language tree-il) #:use-module (srfi srfi-16) #:export (resolve-primitives! add-interesting-primitive! - expand-primitives!)) + expand-primitives! effect-free-primitive?)) (define *interesting-primitive-names* '(apply @apply @@ -85,6 +85,39 @@ (for-each add-interesting-primitive! *interesting-primitive-names*) +(define *effect-free-primitives* + '(values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + list vector + car cdr + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + vector-ref + bytevector-u8-ref bytevector-s8-ref + bytevector-u16-ref bytevector-u16-native-ref + bytevector-s16-ref bytevector-s16-native-ref + bytevector-u32-ref bytevector-u32-native-ref + bytevector-s32-ref bytevector-s32-native-ref + bytevector-u64-ref bytevector-u64-native-ref + bytevector-s64-ref bytevector-s64-native-ref + bytevector-ieee-single-ref bytevector-ieee-single-native-ref + bytevector-ieee-double-ref bytevector-ieee-double-native-ref)) + + +(define *effect-free-primitive-table* (make-hash-table)) + +(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t)) + *effect-free-primitives*) + +(define (effect-free-primitive? prim) + (hashq-ref *effect-free-primitive-table* prim)) + (define (resolve-primitives! x mod) (post-order! (lambda (x) From 9b29d6079184d2d92fef5a1b7eba79f39fa3ef82 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 6 Aug 2009 17:46:38 +0200 Subject: [PATCH 331/375] loop detection in the house * libguile/vm-i-scheme.c (vector-ref, vector-set): Sync registers if we call out to C. * module/language/tree-il/compile-glil.scm (flatten-lambda): Add an extra argument, the self-label, which should be the gensym under which the procedure is bound in a expression. (flatten): If we see a call to a lexical ref to the self-label in a tail position, rename and goto instead of goto/args, which will tear down the frame -- or will, in the future. It's a primitive form of loop detection. * module/language/tree-il/primitives.scm (zero?): Expand to (= x 0). --- libguile/vm-i-scheme.c | 10 +++- module/language/tree-il/compile-glil.scm | 64 ++++++++++++++++-------- module/language/tree-il/primitives.scm | 3 ++ 3 files changed, 54 insertions(+), 23 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 675ec1a0a..0cace147d 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -315,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2) && i < SCM_I_VECTOR_LENGTH (vect))) RETURN (SCM_I_VECTOR_ELTS (vect)[i]); else - RETURN (scm_vector_ref (vect, idx)); + { + SYNC_REGISTER (); + RETURN (scm_vector_ref (vect, idx)); + } } VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0) @@ -329,7 +332,10 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0) && i < SCM_I_VECTOR_LENGTH (vect))) SCM_I_VECTOR_WELTS (vect)[i] = val; else - scm_vector_set_x (vect, idx, val); + { + SYNC_REGISTER (); + scm_vector_set_x (vect, idx, val); + } NEXT; } diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 3d25dd181..7c2764236 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -66,7 +66,7 @@ (with-fluid* *comp-module* (or (and e (car e)) (current-module)) (lambda () - (values (flatten-lambda x allocation) + (values (flatten-lambda x #f allocation) (and e (cons (car e) (cddr e))) e))))) @@ -177,7 +177,7 @@ (proc emit-code) (reverse out))) -(define (flatten-lambda x allocation) +(define (flatten-lambda x self-label allocation) (receive (ids vars nargs nrest) (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) (oids '()) (ovars '()) (n 0)) @@ -193,6 +193,9 @@ nargs nrest nlocs (lambda-meta x) (with-output-to-code (lambda (emit-code) + ;; emit label for self tail calls + (if self-label + (emit-code #f (make-glil-label self-label))) ;; write bindings and source debugging info (emit-bindings #f ids vars allocation x emit-code) (if (lambda-src x) @@ -201,14 +204,14 @@ (for-each (lambda (v) (pmatch (hashq-ref (hashq-ref allocation v) x) - ((#t #t . ,n) - (emit-code #f (make-glil-lexical #t #f 'ref n)) - (emit-code #f (make-glil-lexical #t #t 'box n))))) + ((#t #t . ,n) + (emit-code #f (make-glil-lexical #t #f 'ref n)) + (emit-code #f (make-glil-lexical #t #t 'box n))))) vars) ;; and here, here, dear reader: we compile. - (flatten (lambda-body x) allocation x emit-code))))))) + (flatten (lambda-body x) allocation x self-label emit-code))))))) -(define (flatten x allocation proc emit-code) +(define (flatten x allocation self self-label emit-code) (define (emit-label label) (emit-code #f (make-glil-label label))) (define (emit-branch src inst label) @@ -384,6 +387,25 @@ (error "bad primitive op: too many pushes" op (instruction-pushes op)))))) + ;; da capo al fine + ((and (lexical-ref? proc) + self-label (eq? (lexical-ref-gensym proc) self-label) + ;; self-call in tail position is a goto + (eq? context 'tail) + ;; make sure the arity is right + (list? (lambda-vars self)) + (= (length args) (length (lambda-vars self)))) + ;; evaluate new values + (for-each comp-push args) + ;; rename & goto + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t ,boxed? . ,index) + (emit-code #f (make-glil-lexical #t #f 'set index))) + (,x (error "what" x)))) + (reverse (lambda-vars self))) + (emit-branch src 'br self-label)) + (else (comp-push proc) (for-each comp-push args) @@ -442,7 +464,7 @@ (( src name gensym) (case context ((push vals tail) - (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) ((,local? ,boxed? . ,index) (emit-code src (make-glil-lexical local? boxed? 'ref index))) (,loc @@ -452,7 +474,7 @@ (( src name gensym exp) (comp-push exp) - (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) ((,local? ,boxed? . ,index) (emit-code src (make-glil-lexical local? boxed? 'set index))) (,loc @@ -510,7 +532,7 @@ (let ((free-locs (cdr (hashq-ref allocation x)))) (case context ((push vals tail) - (emit-code #f (flatten-lambda x allocation)) + (emit-code #f (flatten-lambda x #f allocation)) (if (not (null? free-locs)) (begin (for-each @@ -527,9 +549,9 @@ (( src names vars vals body) (for-each comp-push vals) - (emit-bindings src names vars allocation proc emit-code) + (emit-bindings src names vars allocation self emit-code) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code src (make-glil-lexical #t #f 'set n))) ((#t #t . ,n) @@ -541,15 +563,15 @@ (( src names vars vals body) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'empty-box n))) (,loc (error "badness" x loc)))) vars) (for-each comp-push vals) - (emit-bindings src names vars allocation proc emit-code) + (emit-bindings src names vars allocation self emit-code) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'set n))) (,loc (error "badness" x loc)))) @@ -563,20 +585,20 @@ ;; set them to their local var slots first, then capture their ;; bindings, mutating them in place. (for-each (lambda (x v) - (emit-code #f (flatten-lambda x allocation)) + (emit-code #f (flatten-lambda x v allocation)) (if (not (null? (cdr (hashq-ref allocation x)))) ;; But we do have to make-closure them first, so ;; we are mutating fresh closures on the heap. (begin (emit-code #f (make-glil-const #f)) (emit-code #f (make-glil-call 'make-closure 2)))) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code src (make-glil-lexical #t #f 'set n))) (,loc (error "badness" x loc)))) vals vars) - (emit-bindings src names vars allocation proc emit-code) + (emit-bindings src names vars allocation self emit-code) ;; Now go back and fix up the bindings. (for-each (lambda (x v) @@ -591,7 +613,7 @@ (else (error "what" x loc)))) free-locs) (emit-code #f (make-glil-call 'vector (length free-locs))) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code #f (make-glil-lexical #t #f 'fix n))) (,loc (error "badness" x loc))))))) @@ -616,10 +638,10 @@ (emit-code #f (make-glil-const 1)) (emit-label MV) (emit-code src (make-glil-mv-bind - (vars->bind-list names vars allocation proc) + (vars->bind-list names vars allocation self) rest?)) (for-each (lambda (v) - (pmatch (hashq-ref (hashq-ref allocation v) proc) + (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) (emit-code src (make-glil-lexical #t #f 'set n))) ((#t #t . ,n) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 24900c64d..955c7bf25 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -200,6 +200,9 @@ (cons `((src . ,(car in)) ,(consequent (cadr in))) out))))))) +(define-primitive-expander zero? (x) + (= x 0)) + (define-primitive-expander + () 0 (x) x From 9059993fe0bf38045ae52552c68d985a3e3c5344 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 7 Aug 2009 15:35:53 +0200 Subject: [PATCH 332/375] add label alist to lambda allocations in tree-il->glil compiler * module/language/tree-il/analyze.scm: Add some more comments about something that will land in a future commit: compiling fixpoint lambdas as labels. (analyze-lexicals): Reorder a bit, and add a label alist to procedure allocations. Empty for now. * module/language/tree-il/compile-glil.scm (flatten): Adapt to the free variables being in the cddr of the allocation, not the cdr. --- module/language/tree-il/analyze.scm | 58 ++++++++++++++++++------ module/language/tree-il/compile-glil.scm | 6 +-- 2 files changed, 47 insertions(+), 17 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 49633aa28..70778f34d 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -78,6 +78,25 @@ ;; in a vector. Each closure variable has a unique index into that ;; vector. ;; +;; There is one more complication. Procedures bound by may, in +;; some cases, be rendered inline to their parent procedure. That is to +;; say, +;; +;; (letrec ((lp (lambda () (lp)))) (lp)) +;; => (fix ((lp (lambda () (lp)))) (lp)) +;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP; +;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop +;; +;; The upshot is that we don't have to allocate any space for the `lp' +;; closure at all, as it can be rendered inline as a loop. So there is +;; another kind of allocation, "label allocation", in which the +;; procedure is simply a label, placed at the start of the lambda body. +;; The label is the gensym under which the lambda expression is bound. +;; +;; The analyzer checks to see that the label is called with the correct +;; number of arguments. Calls to labels compile to rename + goto. +;; Lambda, the ultimate goto! +;; ;; ;; The return value of `analyze-lexicals' is a hash table, the ;; "allocation". @@ -88,15 +107,17 @@ ;; in many procedures, it is a two-level map. ;; ;; The allocation also stored information on how many local variables -;; need to be allocated for each procedure, and information on what free -;; variables to capture from its lexical parent procedure. +;; need to be allocated for each procedure, lexicals that have been +;; translated into labels, and information on what free variables to +;; capture from its lexical parent procedure. ;; ;; That is: ;; ;; sym -> {lambda -> address} -;; lambda -> (nlocs . free-locs) +;; lambda -> (nlocs labels . free-locs) ;; -;; address := (local? boxed? . index) +;; address ::= (local? boxed? . index) +;; labels ::= ((sym . lambda-vars) ...) ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) ;; free variable addresses are relative to parent proc. @@ -108,14 +129,22 @@ (define (analyze-lexicals x) ;; bound-vars: lambda -> (sym ...) ;; all identifiers bound within a lambda + (define bound-vars (make-hash-table)) ;; free-vars: lambda -> (sym ...) ;; all identifiers referenced in a lambda, but not bound ;; NB, this includes identifiers referenced by contained lambdas + (define free-vars (make-hash-table)) ;; assigned: sym -> #t + (define assigned (make-hash-table)) ;; variables that are assigned ;; refcounts: sym -> count ;; allows us to detect the or-expansion in O(1) time - + (define refcounts (make-hash-table)) + ;; labels: sym -> lambda-vars + ;; for determining if fixed-point procedures can be rendered as + ;; labels. lambda-vars may be an improper list. + (define labels (make-hash-table)) + ;; returns variables referenced in expr (define (analyze! x proc) (define (step y) (analyze! y proc)) @@ -196,6 +225,10 @@ (else '()))) + ;; allocation: sym -> {lambda -> address} + ;; lambda -> (nlocs labels . free-locs) + (define allocation (make-hash-table)) + (define (allocate! x proc n) (define (recur y) (allocate! y proc n)) (record-case x @@ -244,9 +277,13 @@ (free-addresses (map (lambda (v) (hashq-ref (hashq-ref allocation v) proc)) - (hashq-ref free-vars x)))) + (hashq-ref free-vars x))) + (labels (filter cdr + (map (lambda (sym) + (cons sym (hashq-ref labels sym))) + (hashq-ref bound-vars x))))) ;; set procedure allocations - (hashq-set! allocation x (cons nlocs free-addresses))) + (hashq-set! allocation x (cons* nlocs labels free-addresses))) n) (( vars vals body) @@ -328,13 +365,6 @@ (else n))) - (define bound-vars (make-hash-table)) - (define free-vars (make-hash-table)) - (define assigned (make-hash-table)) - (define refcounts (make-hash-table)) - - (define allocation (make-hash-table)) - (analyze! x #f) (allocate! x #f 0) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 7c2764236..3ee5c881d 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -529,7 +529,7 @@ (emit-code #f (make-glil-call 'return 1))))) (() - (let ((free-locs (cdr (hashq-ref allocation x)))) + (let ((free-locs (cddr (hashq-ref allocation x)))) (case context ((push vals tail) (emit-code #f (flatten-lambda x #f allocation)) @@ -586,7 +586,7 @@ ;; bindings, mutating them in place. (for-each (lambda (x v) (emit-code #f (flatten-lambda x v allocation)) - (if (not (null? (cdr (hashq-ref allocation x)))) + (if (not (null? (cddr (hashq-ref allocation x)))) ;; But we do have to make-closure them first, so ;; we are mutating fresh closures on the heap. (begin @@ -602,7 +602,7 @@ ;; Now go back and fix up the bindings. (for-each (lambda (x v) - (let ((free-locs (cdr (hashq-ref allocation x)))) + (let ((free-locs (cddr (hashq-ref allocation x)))) (if (not (null? free-locs)) (begin (for-each From 230cfcfb3e3558a6981487042cc5358d0da1f8bb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 7 Aug 2009 17:44:02 +0200 Subject: [PATCH 333/375] implement compilation of label-allocated lambda expressions * module/language/tree-il/compile-glil.scm (flatten-lambda, flatten): Implement compilation of label-allocated lambda expressions. Quite tricky, we'll see if this works when the new analyzer lands. --- module/language/tree-il/compile-glil.scm | 322 ++++++++++++++--------- 1 file changed, 194 insertions(+), 128 deletions(-) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 3ee5c881d..4880f4754 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -37,7 +37,7 @@ ;; allocation: ;; sym -> {lambda -> address} -;; lambda -> (nlocs . closure-vars) +;; lambda -> (nlocs labels . free-locs) ;; ;; address := (local? boxed? . index) ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) @@ -163,6 +163,7 @@ ids vars)) +;; FIXME: always emit? otherwise it's hard to pair bind with unbind (define (emit-bindings src ids vars allocation proc emit-code) (if (pair? vars) (emit-code src (make-glil-bind @@ -188,7 +189,8 @@ (else (values (reverse (cons ids oids)) (reverse (cons vars ovars)) (1+ n) 1)))) - (let ((nlocs (car (hashq-ref allocation x)))) + (let ((nlocs (car (hashq-ref allocation x))) + (labels (cadr (hashq-ref allocation x)))) (make-glil-program nargs nrest nlocs (lambda-meta x) (with-output-to-code @@ -209,35 +211,44 @@ (emit-code #f (make-glil-lexical #t #t 'box n))))) vars) ;; and here, here, dear reader: we compile. - (flatten (lambda-body x) allocation x self-label emit-code))))))) + (flatten (lambda-body x) allocation x self-label + labels emit-code))))))) -(define (flatten x allocation self self-label emit-code) +(define (flatten x allocation self self-label fix-labels emit-code) (define (emit-label label) (emit-code #f (make-glil-label label))) (define (emit-branch src inst label) (emit-code src (make-glil-branch inst label))) - ;; LMVRA == "let-values MV return address" - (let comp ((x x) (context 'tail) (LMVRA #f)) - (define (comp-tail tree) (comp tree context LMVRA)) - (define (comp-push tree) (comp tree 'push #f)) - (define (comp-drop tree) (comp tree 'drop #f)) - (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA)) + ;; RA: "return address"; #f unless we're in a non-tail fix with labels + ;; MVRA: "multiple-values return address"; #f unless we're in a let-values + (let comp ((x x) (context 'tail) (RA #f) (MVRA #f)) + (define (comp-tail tree) (comp tree context RA MVRA)) + (define (comp-push tree) (comp tree 'push #f #f)) + (define (comp-drop tree) (comp tree 'drop #f #f)) + (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) + (define (comp-fix tree RA) (comp tree context RA MVRA)) + ;; A couple of helpers. Note that if we are in tail context, we + ;; won't have an RA. + (define (maybe-emit-return) + (if RA + (emit-branch #f 'br RA) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))) + (record-case x (() (case context - ((push vals) (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((push vals tail) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src exp) (case context - ((push vals) (emit-code src (make-glil-const exp))) - ((tail) - (emit-code src (make-glil-const exp)) - (emit-code #f (make-glil-call 'return 1))))) + ((push vals tail) + (emit-code src (make-glil-const exp)))) + (maybe-emit-return)) ;; FIXME: should represent sequence as exps tail (( src exps) @@ -263,7 +274,7 @@ ;; drop: (lambda () (apply values '(1 2)) 3) ;; push: (lambda () (list (apply values '(10 12)) 1)) (case context - ((drop) (for-each comp-drop args)) + ((drop) (for-each comp-drop args) (maybe-emit-return)) ((tail) (for-each comp-push args) (emit-code src (make-glil-call 'return/values* (length args)))))) @@ -277,12 +288,14 @@ ((push) (comp-push proc) (for-each comp-push args) - (emit-code src (make-glil-call 'apply (1+ (length args))))) + (emit-code src (make-glil-call 'apply (1+ (length args)))) + (maybe-emit-return)) ((vals) (comp-vals (make-application src (make-primitive-ref #f 'apply) (cons proc args)) - LMVRA)) + MVRA) + (maybe-emit-return)) ((drop) ;; Well, shit. The proc might return any number of ;; values (including 0), since it's in a drop context, @@ -290,8 +303,9 @@ ;; mv-call out to our trampoline instead. (comp-drop (make-application src (make-primitive-ref #f 'apply) - (cons proc args))))))))) - + (cons proc args))) + (maybe-emit-return))))))) + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) (not (eq? context 'push))) ;; tail: (lambda () (values '(1 2))) @@ -299,11 +313,11 @@ ;; push: (lambda () (list (values '(10 12)) 1)) ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) (case context - ((drop) (for-each comp-drop args)) + ((drop) (for-each comp-drop args) (maybe-emit-return)) ((vals) (for-each comp-push args) (emit-code #f (make-glil-const (length args))) - (emit-branch src 'br LMVRA)) + (emit-branch src 'br MVRA)) ((tail) (for-each comp-push args) (emit-code src (make-glil-call 'return/values (length args)))))) @@ -324,7 +338,8 @@ (comp-vals (make-application src (make-primitive-ref #f 'call-with-values) args) - LMVRA)) + MVRA) + (maybe-emit-return)) (else (let ((MV (make-label)) (POST (make-label)) (producer (car args)) (consumer (cadr args))) @@ -341,7 +356,8 @@ (else (emit-code src (make-glil-call 'call/nargs 0)) (emit-label POST) (if (eq? context 'drop) - (emit-code #f (make-glil-call 'drop 1))))))))) + (emit-code #f (make-glil-call 'drop 1))) + (maybe-emit-return))))))) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-current-continuation) @@ -355,16 +371,19 @@ (make-application src (make-primitive-ref #f 'call-with-current-continuation) args) - LMVRA)) + MVRA) + (maybe-emit-return)) ((push) (comp-push (car args)) - (emit-code src (make-glil-call 'call/cc 1))) + (emit-code src (make-glil-call 'call/cc 1)) + (maybe-emit-return)) ((drop) ;; Crap. Just like `apply' in drop context. (comp-drop (make-application src (make-primitive-ref #f 'call-with-current-continuation) - args))))) + args)) + (maybe-emit-return)))) ((and (primitive-ref? proc) (or (hash-ref *primcall-ops* @@ -376,13 +395,12 @@ (case (instruction-pushes op) ((0) (case context - ((tail) (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))) - ((push vals) (emit-code #f (make-glil-void))))) + ((tail push vals) (emit-code #f (make-glil-void)))) + (maybe-emit-return)) ((1) (case context - ((tail) (emit-code #f (make-glil-call 'return 1))) - ((drop) (emit-code #f (make-glil-call 'drop 1))))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) (else (error "bad primitive op: too many pushes" op (instruction-pushes op)))))) @@ -401,28 +419,50 @@ (for-each (lambda (sym) (pmatch (hashq-ref (hashq-ref allocation sym) self) ((#t ,boxed? . ,index) + ;; set unboxed, as the proc prelude will box if needed (emit-code #f (make-glil-lexical #t #f 'set index))) (,x (error "what" x)))) (reverse (lambda-vars self))) (emit-branch src 'br self-label)) + ;; lambda, the ultimate goto + ((and (lexical-ref? proc) + (assq (lexical-ref-gensym proc) fix-labels)) + ;; evaluate new values, assuming that analyze-lexicals did its + ;; job, and that the arity was right + (for-each comp-push args) + ;; rename + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t #f . ,index) + (emit-code #f (make-glil-lexical #t #f 'set index))) + ((#t #t . ,index) + (emit-code #f (make-glil-lexical #t #t 'box index))) + (,x (error "what" x)))) + (reverse (assq-ref fix-labels (lexical-ref-gensym proc)))) + ;; goto! + (emit-branch src 'br (lexical-ref-gensym proc))) + (else (comp-push proc) (for-each comp-push args) (let ((len (length args))) (case context ((tail) (emit-code src (make-glil-call 'goto/args len))) - ((push) (emit-code src (make-glil-call 'call len))) - ((vals) (emit-code src (make-glil-mv-call len LMVRA))) - ((drop) - (let ((MV (make-label)) (POST (make-label))) - (emit-code src (make-glil-mv-call len MV)) - (emit-code #f (make-glil-call 'drop 1)) - (emit-branch #f 'br POST) - (emit-label MV) - (emit-code #f (make-glil-mv-bind '() #f)) - (emit-code #f (make-glil-unbind)) - (emit-label POST)))))))) + ((push) (emit-code src (make-glil-call 'call len)) + (maybe-emit-return)) + ((vals) (emit-code src (make-glil-mv-call len MVRA)) + (maybe-emit-return)) + ((drop) (let ((MV (make-label)) (POST (make-label))) + (emit-code src (make-glil-mv-call len MV)) + (emit-code #f (make-glil-call 'drop 1)) + (emit-branch #f 'br (or RA POST)) + (emit-label MV) + (emit-code #f (make-glil-mv-bind '() #f)) + (emit-code #f (make-glil-unbind)) + (if RA + (emit-branch #f 'br RA) + (emit-label POST))))))))) (( src test then else) ;; TEST @@ -436,30 +476,28 @@ (emit-branch src 'br-if-not L1) (comp-tail then) (if (not (eq? context 'tail)) - (emit-branch #f 'br L2)) + (emit-branch #f 'br (or RA L2))) (emit-label L1) (comp-tail else) (if (not (eq? context 'tail)) - (emit-label L2)))) + (if RA + (emit-branch #f 'br RA) + (emit-label L2))))) (( src name) (cond ((eq? (module-variable (fluid-ref *comp-module*) name) (module-variable the-root-module name)) (case context - ((push vals) - (emit-code src (make-glil-toplevel 'ref name))) - ((tail) - (emit-code src (make-glil-toplevel 'ref name)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code src (make-glil-toplevel 'ref name)))) + (maybe-emit-return)) (else (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) (case context - ((push vals) - (emit-code src (make-glil-module 'ref '(guile) name #f))) - ((tail) - (emit-code src (make-glil-module 'ref '(guile) name #f)) - (emit-code #f (make-glil-call 'return 1))))))) + ((tail push vals) + (emit-code src (make-glil-module 'ref '(guile) name #f)))) + (maybe-emit-return)))) (( src name gensym) (case context @@ -469,8 +507,7 @@ (emit-code src (make-glil-lexical local? boxed? 'ref index))) (,loc (error "badness" x loc))))) - (case context - ((tail) (emit-code #f (make-glil-call 'return 1))))) + (maybe-emit-return)) (( src name gensym exp) (comp-push exp) @@ -480,53 +517,45 @@ (,loc (error "badness" x loc))) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src mod name public?) (emit-code src (make-glil-module 'ref mod name public?)) (case context - ((drop) (emit-code #f (make-glil-call 'drop 1))) - ((tail) (emit-code #f (make-glil-call 'return 1))))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) (( src mod name public? exp) (comp-push exp) (emit-code src (make-glil-module 'set mod name public?)) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src name) (emit-code src (make-glil-toplevel 'ref name)) (case context - ((drop) (emit-code #f (make-glil-call 'drop 1))) - ((tail) (emit-code #f (make-glil-call 'return 1))))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) (( src name exp) (comp-push exp) (emit-code src (make-glil-toplevel 'set name)) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (( src name exp) (comp-push exp) (emit-code src (make-glil-toplevel 'define name)) (case context - ((push vals) - (emit-code #f (make-glil-void))) - ((tail) - (emit-code #f (make-glil-void)) - (emit-code #f (make-glil-call 'return 1))))) + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) (() (let ((free-locs (cddr (hashq-ref allocation x)))) @@ -543,9 +572,8 @@ (else (error "what" x loc)))) free-locs) (emit-code #f (make-glil-call 'vector (length free-locs))) - (emit-code #f (make-glil-call 'make-closure 2)))) - (if (eq? context 'tail) - (emit-code #f (make-glil-call 'return 1))))))) + (emit-code #f (make-glil-call 'make-closure 2))))))) + (maybe-emit-return)) (( src names vars vals body) (for-each comp-push vals) @@ -580,47 +608,85 @@ (emit-code #f (make-glil-unbind))) (( src names vars vals body) - ;; For fixpoint procedures, we can do some tricks to avoid - ;; heap-allocation. Since we know the vals are lambdas, we can - ;; set them to their local var slots first, then capture their - ;; bindings, mutating them in place. - (for-each (lambda (x v) - (emit-code #f (flatten-lambda x v allocation)) - (if (not (null? (cddr (hashq-ref allocation x)))) - ;; But we do have to make-closure them first, so - ;; we are mutating fresh closures on the heap. - (begin - (emit-code #f (make-glil-const #f)) - (emit-code #f (make-glil-call 'make-closure 2)))) - (pmatch (hashq-ref (hashq-ref allocation v) self) - ((#t #f . ,n) - (emit-code src (make-glil-lexical #t #f 'set n))) - (,loc (error "badness" x loc)))) - vals - vars) - (emit-bindings src names vars allocation self emit-code) - ;; Now go back and fix up the bindings. - (for-each - (lambda (x v) - (let ((free-locs (cddr (hashq-ref allocation x)))) - (if (not (null? free-locs)) - (begin - (for-each - (lambda (loc) - (pmatch loc - ((,local? ,boxed? . ,n) - (emit-code #f (make-glil-lexical local? #f 'ref n))) - (else (error "what" x loc)))) - free-locs) - (emit-code #f (make-glil-call 'vector (length free-locs))) - (pmatch (hashq-ref (hashq-ref allocation v) self) - ((#t #f . ,n) - (emit-code #f (make-glil-lexical #t #f 'fix n))) - (,loc (error "badness" x loc))))))) - vals - vars) - (comp-tail body) - (emit-code #f (make-glil-unbind))) + ;; The ideal here is to just render the lambda bodies inline, and + ;; wire the code together with gotos. We can do that if + ;; analyze-lexicals has determined that a given var has "label" + ;; allocation -- which is the case if it is in `fix-labels'. + ;; + ;; But even for closures that we can't inline, we can do some + ;; tricks to avoid heap-allocation for the binding itself. Since + ;; we know the vals are lambdas, we can set them to their local + ;; var slots first, then capture their bindings, mutating them in + ;; place. + (let ((RA (if (eq? context 'tail) #f (make-label)))) + (for-each + (lambda (x v) + (cond + ((hashq-ref allocation x) + ;; allocating a closure + (emit-code #f (flatten-lambda x v allocation)) + (if (not (null? (cddr (hashq-ref allocation x)))) + ;; Need to make-closure first, but with a temporary #f + ;; free-variables vector, so we are mutating fresh + ;; closures on the heap. + (begin + (emit-code #f (make-glil-const #f)) + (emit-code #f (make-glil-call 'make-closure 2)))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + (,loc (error "badness" x loc)))) + (else + ;; labels allocation: emit label & body, but jump over it + (let ((POST (make-label))) + (emit-branch #f 'br POST) + (emit-label v) + ;; we know the lambda vars are a list + (emit-bindings #f (lambda-names x) (lambda-vars x) + allocation self emit-code) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + (comp-fix (lambda-body x) RA) + (emit-code #f (make-glil-unbind)) + (emit-label POST))))) + vals + vars) + ;; Emit bindings metadata for closures + (let ((binds (let lp ((out '()) (vars vars) (names names)) + (cond ((null? vars) (reverse! out)) + ((memq (car vars) fix-labels) + (lp out (cdr vars) (cdr names))) + (else + (lp (acons (car vars) (car names) out) + (cdr vars) (cdr names))))))) + (emit-bindings src (map cdr binds) (map car binds) + allocation self emit-code)) + ;; Now go back and fix up the bindings for closures. + (for-each + (lambda (x v) + (let ((free-locs (if (hashq-ref allocation x) + (cddr (hashq-ref allocation x)) + ;; can hit this latter case for labels allocation + '()))) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code #f (make-glil-lexical #t #f 'fix n))) + (,loc (error "badness" x loc))))))) + vals + vars) + (comp-tail body) + (emit-label RA) + (emit-code #f (make-glil-unbind)))) (( src names vars exp body) (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) From d97b69d9cd7207e947d22b2417defc58560e6457 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 7 Aug 2009 19:06:15 +0200 Subject: [PATCH 334/375] lambda, the ultimate goto * module/language/tree-il/analyze.scm (analyze-lexicals): Rework to actually determine when a fixed-point procedure may be allocated as a label. * module/language/tree-il/compile-glil.scm (emit-bindings): Always emit a . Otherwise it's too hard to pair with unbindings. (flatten-lambda): Consequently, here we only `bind' if there are any vars to bind. This doesn't make any difference, given that lambdas don't have trailing unbind instructions, but it does keep the GLIL output the same for thunks -- no extraneous (bind) instructions. Keeps tree-il.test happy. (flatten): Some bugfixes. Yaaay, it works!!! --- module/language/tree-il/analyze.scm | 170 +++++++++++++++++++---- module/language/tree-il/compile-glil.scm | 24 ++-- 2 files changed, 155 insertions(+), 39 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 70778f34d..b93a0bd7e 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -135,8 +135,8 @@ ;; NB, this includes identifiers referenced by contained lambdas (define free-vars (make-hash-table)) ;; assigned: sym -> #t - (define assigned (make-hash-table)) ;; variables that are assigned + (define assigned (make-hash-table)) ;; refcounts: sym -> count ;; allows us to detect the or-expansion in O(1) time (define refcounts (make-hash-table)) @@ -146,23 +146,35 @@ (define labels (make-hash-table)) ;; returns variables referenced in expr - (define (analyze! x proc) - (define (step y) (analyze! y proc)) - (define (recur x new-proc) (analyze! x new-proc)) + (define (analyze! x proc labels-in-proc tail? tail-call-args) + (define (step y) (analyze! y proc labels-in-proc #f #f)) + (define (step-tail y) (analyze! y proc labels-in-proc tail? #f)) + (define (step-tail-call y args) (analyze! y proc labels-in-proc #f + (and tail? args))) + (define (recur/labels x new-proc labels) + (analyze! x new-proc (append labels labels-in-proc) #t #f)) + (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) (record-case x (( proc args) - (apply lset-union eq? (step proc) (map step args))) + (apply lset-union eq? (step-tail-call proc args) + (map step args))) (( test then else) - (lset-union eq? (step test) (step then) (step else))) + (lset-union eq? (step test) (step-tail then) (step-tail else))) (( name gensym) (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (if (not (and tail-call-args + (memq gensym labels-in-proc) + (let ((args (hashq-ref labels gensym))) + (and (list? args) + (= (length args) (length tail-call-args)))))) + (hashq-set! labels gensym #f)) (list gensym)) (( name gensym exp) - (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) (hashq-set! assigned gensym #t) + (hashq-set! labels gensym #f) (lset-adjoin eq? (step exp) gensym)) (( mod name public? exp) @@ -175,7 +187,12 @@ (step exp)) (( exps) - (apply lset-union eq? (map step exps))) + (let lp ((exps exps) (ret '())) + (cond ((null? exps) '()) + ((null? (cdr exps)) + (lset-union eq? ret (step-tail (car exps)))) + (else + (lp (cdr exps) (lset-union eq? ret (step (car exps)))))))) (( vars meta body) (let ((locally-bound (let rev* ((vars vars) (out '())) @@ -195,7 +212,7 @@ (hashq-set! bound-vars proc (append (reverse vars) (hashq-ref bound-vars proc))) (lset-difference eq? - (apply lset-union eq? (step body) (map step vals)) + (apply lset-union eq? (step-tail body) (map step vals)) vars)) (( vars vals body) @@ -203,15 +220,86 @@ (append (reverse vars) (hashq-ref bound-vars proc))) (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) (lset-difference eq? - (apply lset-union eq? (step body) (map step vals)) + (apply lset-union eq? (step-tail body) (map step vals)) vars)) (( vars vals body) + ;; Try to allocate these procedures as labels. + (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val))) + vars vals) (hashq-set! bound-vars proc (append (reverse vars) (hashq-ref bound-vars proc))) - (lset-difference eq? - (apply lset-union eq? (step body) (map step vals)) - vars)) + ;; Step into subexpressions. + (let* ((var-refs + (map + ;; Since we're trying to label-allocate the lambda, + ;; pretend it's not a closure, and just recurse into its + ;; body directly. (Otherwise, recursing on a closure + ;; that references one of the fix's bound vars would + ;; prevent label allocation.) + (lambda (x) + (record-case x + (( (lvars vars) body) + (let ((locally-bound + (let rev* ((lvars lvars) (out '())) + (cond ((null? lvars) out) + ((pair? lvars) (rev* (cdr lvars) + (cons (car lvars) out))) + (else (cons lvars out)))))) + (hashq-set! bound-vars x locally-bound) + ;; recur/labels, the difference from the closure case + (let* ((referenced (recur/labels body x vars)) + (free (lset-difference eq? referenced locally-bound)) + (all-bound (reverse! (hashq-ref bound-vars x)))) + (hashq-set! bound-vars x all-bound) + (hashq-set! free-vars x free) + free))))) + vals)) + (vars-with-refs (map cons vars var-refs)) + (body-refs (recur/labels body proc vars))) + (define (delabel-dependents! sym) + (let ((refs (assq-ref vars-with-refs sym))) + (if refs + (for-each (lambda (sym) + (if (hashq-ref labels sym) + (begin + (hashq-set! labels sym #f) + (delabel-dependents! sym)))) + refs)))) + ;; Stepping into the lambdas and the body might have made some + ;; procedures not label-allocatable -- which might have + ;; knock-on effects. For example: + ;; (fix ((a (lambda () (b))) + ;; (b (lambda () a))) + ;; (a)) + ;; As far as `a' is concerned, both `a' and `b' are + ;; label-allocatable. But `b' references `a' not in a proc-tail + ;; position, which makes `a' not label-allocatable. The + ;; knock-on effect is that, when back-propagating this + ;; information to `a', `b' will also become not + ;; label-allocatable, as it is referenced within `a', which is + ;; allocated as a closure. This is a transitive relationship. + (for-each (lambda (sym) + (if (not (hashq-ref labels sym)) + (delabel-dependents! sym))) + vars) + ;; Now lift bound variables with label-allocated lambdas to the + ;; parent procedure. + (for-each + (lambda (sym val) + (if (hashq-ref labels sym) + ;; Remove traces of the label-bound lambda. The free + ;; vars will propagate up via the return val. + (begin + (hashq-set! bound-vars proc + (append (hashq-ref bound-vars val) + (hashq-ref bound-vars proc))) + (hashq-remove! bound-vars val) + (hashq-remove! free-vars val)))) + vars vals) + (lset-difference eq? + (apply lset-union eq? body-refs var-refs) + vars))) (( vars exp body) (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars)) @@ -220,7 +308,7 @@ (if (null? in) out (cons in out)))))) (hashq-set! bound-vars proc bound) (lset-difference eq? - (lset-union eq? (step exp) (step body)) + (lset-union eq? (step exp) (step-tail body)) bound))) (else '()))) @@ -330,18 +418,46 @@ (lp (cdr vars) (1+ n)))))) (( vars vals body) - (let lp ((vars vars) (n n)) - (if (null? vars) - (let ((nmax (apply max - (map (lambda (x) - (allocate! x proc n)) - vals)))) - (max nmax (allocate! body proc n))) - (let ((v (car vars))) - (if (hashq-ref assigned v) - (error "fixpoint procedures may not be assigned" x)) - (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) - (lp (cdr vars) (1+ n)))))) + (let lp ((in vars) (n n)) + (if (null? in) + (let lp ((vars vars) (vals vals) (nmax n)) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((hashq-ref labels (car vars)) + ;; allocate label bindings & body inline to proc + (lp (cdr vars) + (cdr vals) + (record-case (car vals) + (( vars body) + (let lp ((vars vars) (n n)) + (if (not (null? vars)) + ;; allocate bindings + (let ((v (if (pair? vars) (car vars) vars))) + (hashq-set! + allocation v + (make-hashq + proc `(#t ,(hashq-ref assigned v) . ,n))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))) + ;; allocate body + (max nmax (allocate! body proc n)))))))) + (else + ;; allocate closure + (lp (cdr vars) + (cdr vals) + (max nmax (allocate! (car vals) proc n)))))) + + (let ((v (car in))) + (cond + ((hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + ((hashq-ref labels v) + ;; no binding, it's a label + (lp (cdr in) n)) + (else + ;; allocate closure binding + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr in) (1+ n)))))))) (( vars exp body) (let ((nmax (recur exp))) @@ -365,7 +481,7 @@ (else n))) - (analyze! x #f) + (analyze! x #f '() #t #f) (allocate! x #f 0) allocation) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 4880f4754..48db6f6c4 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -165,9 +165,8 @@ ;; FIXME: always emit? otherwise it's hard to pair bind with unbind (define (emit-bindings src ids vars allocation proc emit-code) - (if (pair? vars) - (emit-code src (make-glil-bind - (vars->bind-list ids vars allocation proc))))) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation proc)))) (define (with-output-to-code proc) (let ((out '())) @@ -199,7 +198,8 @@ (if self-label (emit-code #f (make-glil-label self-label))) ;; write bindings and source debugging info - (emit-bindings #f ids vars allocation x emit-code) + (if (not (null? ids)) + (emit-bindings #f ids vars allocation x emit-code)) (if (lambda-src x) (emit-code #f (make-glil-source (lambda-src x)))) ;; box args if necessary @@ -475,15 +475,15 @@ (comp-push test) (emit-branch src 'br-if-not L1) (comp-tail then) - (if (not (eq? context 'tail)) - (emit-branch #f 'br (or RA L2))) + ;; if there is an RA, comp-tail will cause a jump to it -- just + ;; have to clean up here if there is no RA. + (if (and (not RA) (not (eq? context 'tail))) + (emit-branch #f 'br L2)) (emit-label L1) (comp-tail else) - (if (not (eq? context 'tail)) - (if RA - (emit-branch #f 'br RA) - (emit-label L2))))) - + (if (and (not RA) (not (eq? context 'tail))) + (emit-label L2)))) + (( src name) (cond ((eq? (module-variable (fluid-ref *comp-module*) name) @@ -654,7 +654,7 @@ ;; Emit bindings metadata for closures (let ((binds (let lp ((out '()) (vars vars) (names names)) (cond ((null? vars) (reverse! out)) - ((memq (car vars) fix-labels) + ((assq (car vars) fix-labels) (lp out (cdr vars) (cdr names))) (else (lp (acons (car vars) (car names) out) From 9c44cd4559a5d04ba70bbd9ff47f41bfdfebd09d Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sat, 8 Aug 2009 02:35:00 -0700 Subject: [PATCH 335/375] Add Unicode strings and symbols This adds full Unicode strings as a datatype, and it adds some minimal functionality. The terminal and port encoding is assumed to be ISO-8859-1. Non-ISO-8859-1 characters are written or input as string character escapes. The string character escapes now have 3 forms: \xXX \uXXXX and \UXXXXXX, for unprintable characters that have 2, 4 or 6 hex digits. The process for writing to strings has been modified. There is now a function scm_i_string_start_writing that does the copy-on-write conversion if necessary. To compile strings that may be wide, the VM storage of strings and string-likes has changed. Most string-using functions have not yet been updated and may break when used with wide strings. * module/language/assembly/compile-bytecode.scm (write-bytecode): use variable width string bytecode format * module/language/assembly.scm (byte-length): use variable width bytecode format * libguile/vm-i-loader.c (load-string, load-symbol): (load-keyword, define): use variable-width bytecode format * libguile/vm-engine.h (FETCH_WIDTH): new macro * libguile/strings.h: new declarations * libguile/strings.c (make_wide_stringbuf): new function (widen_stringbuf): new function (scm_i_make_wide_string): new function (scm_i_is_narrow_string): new function (scm_i_string_wide_chars): new function (scm_i_string_start_writing): new function (scm_i_string_ref): new function (scm_i_string_set_x): new function (scm_i_is_narrow_symbol): new function (scm_i_symbol_wide_chars, scm_i_symbol_ref): new function (scm_string_width): new function (unistring_escapes_to_guile_escapes): new function (scm_to_stringn): new function (scm_i_stringbuf_free): modify for wide strings (scm_i_substring_copy): modify for wide strings (scm_i_string_chars, scm_string_append): modify for wide strings (scm_i_make_symbol, scm_to_locale_stringn): modify for wide strings (scm_string_dump, scm_symbol_dump, scm_to_locale_stringbuf): (scm_string, scm_i_deprecated_string_chars): modify for wide strings (scm_from_locale_string, scm_from_locale_stringn): add null test * libguile/srfi-13.c: add calls for scm_i_string_start_writing for each call of scm_i_string_stop_writing (scm_string_for_each): modify for wide strings * libguile/socket.c: add calls for scm_i_string_start_writing for each call of scm_i_string_stop_writing * libguile/rw.c: add calls for scm_i_string_start_writing for each call of scm_i_string_stop_writing * libguile/read.c (scm_read_string): allow reading of wide strings * libguile/print.h: add declaration for scm_charprint * libguile/print.c (iprin1): print wide strings and add new string escapes (scm_charprint): new function * libguile/ports.h: new declarations for scm_lfwrite_substr and scm_lfwrite_str * libguile/ports.c (update_port_lf): new function (scm_lfwrite): use update_port_lf (scm_lfwrite_substr): new function (scm_lfwrite_str): new function * test-suite/tests/asm-to-bytecode.test ("compiler"): add string width byte to sting-like asm tests --- libguile/ports.c | 92 ++- libguile/ports.h | 3 + libguile/print.c | 155 +++-- libguile/print.h | 1 + libguile/read.c | 233 ++++--- libguile/rw.c | 2 + libguile/socket.c | 3 + libguile/srfi-13.c | 23 +- libguile/strings.c | 651 +++++++++++++++--- libguile/strings.h | 57 +- libguile/vm-engine.h | 1 + libguile/vm-i-loader.c | 87 ++- module/language/assembly.scm | 12 +- module/language/assembly/compile-bytecode.scm | 26 +- test-suite/tests/asm-to-bytecode.test | 6 +- 15 files changed, 1046 insertions(+), 306 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 627fd3f00..2c1a3898f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -969,7 +969,35 @@ scm_fill_input (SCM port) * This function differs from scm_c_write; it updates port line and * column. */ -void +static void +update_port_lf (scm_t_wchar c, SCM port) +{ + if (c == '\a') + { + } + else if (c == '\b') + { + SCM_DECCOL (port); + } + else if (c == '\n') + { + SCM_INCLINE (port); + } + else if (c == '\r') + { + SCM_ZEROCOL (port); + } + else if (c == '\t') + { + SCM_TABCOL (port); + } + else + { + SCM_INCCOL (port); + } +} + +void scm_lfwrite (const char *ptr, size_t size, SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); @@ -980,30 +1008,54 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) ptob->write (port, ptr, size); - for (; size; ptr++, size--) { - if (*ptr == '\a') { - } - else if (*ptr == '\b') { - SCM_DECCOL(port); - } - else if (*ptr == '\n') { - SCM_INCLINE(port); - } - else if (*ptr == '\r') { - SCM_ZEROCOL(port); - } - else if (*ptr == '\t') { - SCM_TABCOL(port); - } - else { - SCM_INCCOL(port); - } - } + for (; size; ptr++, size--) + update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port); if (pt->rw_random) pt->rw_active = SCM_PORT_WRITE; } +/* Write a scheme string STR to PORT from START inclusive to END + exclusive. */ +void +scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) +{ + size_t i, size = scm_i_string_length (str); + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; + scm_t_wchar p; + char *buf; + size_t len; + + if (pt->rw_active == SCM_PORT_READ) + scm_end_input (port); + + if (end == -1) + end = size; + size = end - start; + + buf = scm_to_stringn (scm_c_substring (str, start, end), &len, + NULL, iconveh_escape_sequence); + ptob->write (port, buf, len); + free (buf); + + for (i = 0; i < size; i++) + { + p = scm_i_string_ref (str, i + start); + update_port_lf (p, port); + } + + if (pt->rw_random) + pt->rw_active = SCM_PORT_WRITE; +} + +/* Write a scheme string STR to PORT. */ +void +scm_lfwrite_str (SCM str, SCM port) +{ + scm_lfwrite_substr (str, 0, -1, port); +} + /* scm_c_read * * Used by an application to read arbitrary number of bytes from an diff --git a/libguile/ports.h b/libguile/ports.h index 8a21b09f9..d427fecb1 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -269,6 +269,9 @@ SCM_API SCM scm_read_char (SCM port); SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size); SCM_API void scm_c_write (SCM port, const void *buffer, size_t size); SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port); +SCM_INTERNAL void scm_lfwrite_str (SCM str, SCM port); +SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end, + SCM port); SCM_API void scm_flush (SCM port); SCM_API void scm_end_input (SCM port); SCM_API int scm_fill_input (SCM port); diff --git a/libguile/print.c b/libguile/print.c index f43856bbe..6f31fcf4a 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -559,55 +559,113 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; } break; - case scm_tc7_string: - if (SCM_WRITINGP (pstate)) - { - size_t i, j, len; - const char *data; + case scm_tc7_string: + if (SCM_WRITINGP (pstate)) + { + size_t i, j, len; + static char const hex[] = "0123456789abcdef"; + char buf[8]; - scm_putc ('"', port); - len = scm_i_string_length (exp); - data = scm_i_string_chars (exp); - for (i = 0, j = 0; i < len; ++i) - { - unsigned char ch = data[i]; - if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148)) - { - static char const hex[]="0123456789abcdef"; - char buf[4]; - scm_lfwrite (data+j, i-j, port); - buf[0] = '\\'; - buf[1] = 'x'; - buf[2] = hex [ch / 16]; - buf[3] = hex [ch % 16]; - scm_lfwrite (buf, 4, port); - data = scm_i_string_chars (exp); - j = i+1; - } - else if (ch == '"' || ch == '\\') - { - scm_lfwrite (data+j, i-j, port); - scm_putc ('\\', port); - data = scm_i_string_chars (exp); - j = i; - } - } - scm_lfwrite (data+j, i-j, port); - scm_putc ('"', port); - scm_remember_upto_here_1 (exp); - } - else - scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp), - port); - scm_remember_upto_here_1 (exp); - break; + scm_putc ('"', port); + len = scm_i_string_length (exp); + for (i = 0; i < len; ++i) + { + scm_t_wchar ch = scm_i_string_ref (exp, i); + int printed = 0; + + if (ch == ' ' || ch == '\n') + { + scm_putc (ch, port); + printed = 1; + } + else if (ch == '"' || ch == '\\') + { + scm_putc ('\\', port); + scm_charprint (ch, port); + printed = 1; + } + else + if (uc_is_general_category_withtable + (ch, + UC_CATEGORY_MASK_L | UC_CATEGORY_MASK_M | + UC_CATEGORY_MASK_N | UC_CATEGORY_MASK_P | + UC_CATEGORY_MASK_S)) + { + /* Print the character since it is a graphic + character. */ + scm_t_wchar *wbuf; + SCM wstr = scm_i_make_wide_string (1, &wbuf); + char *buf; + size_t len; + + wbuf[0] = ch; + + buf = u32_conv_to_encoding ("ISO-8859-1", + iconveh_error, + (scm_t_uint32 *) wbuf, + 1, NULL, NULL, &len); + if (buf != NULL) + { + /* Character is graphic and representable in + this encoding. Print it. */ + scm_lfwrite_str (wstr, port); + free (buf); + printed = 1; + } + } + + if (!printed) + { + /* Character is graphic but unrepresentable in + this port's encoding or is not graphic. */ + if (ch <= 0xFF) + { + buf[0] = '\\'; + buf[1] = 'x'; + buf[2] = hex[ch / 16]; + buf[3] = hex[ch % 16]; + scm_lfwrite (buf, 4, port); + } + else if (ch <= 0xFFFF) + { + buf[0] = '\\'; + buf[1] = 'u'; + buf[2] = hex[(ch & 0xF000) >> 12]; + buf[3] = hex[(ch & 0xF00) >> 8]; + buf[4] = hex[(ch & 0xF0) >> 4]; + buf[5] = hex[(ch & 0xF)]; + scm_lfwrite (buf, 6, port); + j = i + 1; + } + else if (ch > 0xFFFF) + { + buf[0] = '\\'; + buf[1] = 'U'; + buf[2] = hex[(ch & 0xF00000) >> 20]; + buf[3] = hex[(ch & 0xF0000) >> 16]; + buf[4] = hex[(ch & 0xF000) >> 12]; + buf[5] = hex[(ch & 0xF00) >> 8]; + buf[6] = hex[(ch & 0xF0) >> 4]; + buf[7] = hex[(ch & 0xF)]; + scm_lfwrite (buf, 8, port); + j = i + 1; + } + } + } + scm_putc ('"', port); + scm_remember_upto_here_1 (exp); + } + else + scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp), + port); + scm_remember_upto_here_1 (exp); + break; case scm_tc7_symbol: if (scm_i_symbol_is_interned (exp)) { scm_print_symbol_name (scm_i_symbol_chars (exp), - scm_i_symbol_length (exp), - port); + scm_i_symbol_length (exp), port); scm_remember_upto_here_1 (exp); } else @@ -763,6 +821,17 @@ scm_prin1 (SCM exp, SCM port, int writingp) } } +/* Print a character. + */ +void +scm_charprint (scm_t_uint32 ch, SCM port) +{ + scm_t_wchar *wbuf; + SCM wstr = scm_i_make_wide_string (1, &wbuf); + + wbuf[0] = ch; + scm_lfwrite_str (wstr, port); +} /* Print an integer. */ diff --git a/libguile/print.h b/libguile/print.h index d817a6fc3..1df29522c 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -77,6 +77,7 @@ SCM_API SCM scm_print_options (SCM setting); SCM_API SCM scm_make_print_state (void); SCM_API void scm_free_print_state (SCM print_state); SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state); +SCM_API void scm_charprint (scm_t_uint32 c, SCM port); SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port); SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port); SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port); diff --git a/libguile/read.c b/libguile/read.c index 2140fed25..577a73e58 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -387,110 +387,167 @@ scm_read_string (int chr, SCM port) object (the string returned). */ SCM str = SCM_BOOL_F; - char c_str[READER_STRING_BUFFER_SIZE]; unsigned c_str_len = 0; - int c; + scm_t_wchar c; + str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL); while ('"' != (c = scm_getc (port))) { if (c == EOF) - str_eof: scm_i_input_error (FUNC_NAME, port, - "end of file in string constant", - SCM_EOL); + { + str_eof: + scm_i_input_error (FUNC_NAME, port, + "end of file in string constant", SCM_EOL); + } - if (c_str_len + 1 >= sizeof (c_str)) - { - /* Flush the C buffer onto a Scheme string. */ - SCM addy; + if (c_str_len + 1 >= scm_i_string_length (str)) + { + SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL); - if (str == SCM_BOOL_F) - str = scm_c_make_string (0, SCM_MAKE_CHAR ('X')); - - addy = scm_from_locale_stringn (c_str, c_str_len); - str = scm_string_append_shared (scm_list_2 (str, addy)); - - c_str_len = 0; - } + str = scm_string_append (scm_list_2 (str, addy)); + } if (c == '\\') - switch (c = scm_getc (port)) - { - case EOF: - goto str_eof; - case '"': - case '\\': - break; + { + switch (c = scm_getc (port)) + { + case EOF: + goto str_eof; + case '"': + case '\\': + break; #if SCM_ENABLE_ELISP - case '(': - case ')': - if (SCM_ESCAPED_PARENS_P) - break; - goto bad_escaped; + case '(': + case ')': + if (SCM_ESCAPED_PARENS_P) + break; + goto bad_escaped; #endif - case '\n': - continue; - case '0': - c = '\0'; - break; - case 'f': - c = '\f'; - break; - case 'n': - c = '\n'; - break; - case 'r': - c = '\r'; - break; - case 't': - c = '\t'; - break; - case 'a': - c = '\007'; - break; - case 'v': - c = '\v'; - break; - case 'x': - { - int a, b; - a = scm_getc (port); - if (a == EOF) goto str_eof; - b = scm_getc (port); - if (b == EOF) goto str_eof; - if ('0' <= a && a <= '9') a -= '0'; - else if ('A' <= a && a <= 'F') a = a - 'A' + 10; - else if ('a' <= a && a <= 'f') a = a - 'a' + 10; - else goto bad_escaped; - if ('0' <= b && b <= '9') b -= '0'; - else if ('A' <= b && b <= 'F') b = b - 'A' + 10; - else if ('a' <= b && b <= 'f') b = b - 'a' + 10; - else goto bad_escaped; - c = a * 16 + b; - break; - } - default: - bad_escaped: - scm_i_input_error (FUNC_NAME, port, - "illegal character in escape sequence: ~S", - scm_list_1 (SCM_MAKE_CHAR (c))); - } - c_str[c_str_len++] = c; + case '\n': + continue; + case '0': + c = '\0'; + break; + case 'f': + c = '\f'; + break; + case 'n': + c = '\n'; + break; + case 'r': + c = '\r'; + break; + case 't': + c = '\t'; + break; + case 'a': + c = '\007'; + break; + case 'v': + c = '\v'; + break; + case 'x': + { + scm_t_wchar a, b; + a = scm_getc (port); + if (a == EOF) + goto str_eof; + b = scm_getc (port); + if (b == EOF) + goto str_eof; + if ('0' <= a && a <= '9') + a -= '0'; + else if ('A' <= a && a <= 'F') + a = a - 'A' + 10; + else if ('a' <= a && a <= 'f') + a = a - 'a' + 10; + else + { + c = a; + goto bad_escaped; + } + if ('0' <= b && b <= '9') + b -= '0'; + else if ('A' <= b && b <= 'F') + b = b - 'A' + 10; + else if ('a' <= b && b <= 'f') + b = b - 'a' + 10; + else + { + c = b; + goto bad_escaped; + } + c = a * 16 + b; + break; + } + case 'u': + { + scm_t_wchar a; + int i; + c = 0; + for (i = 0; i < 4; i++) + { + a = scm_getc (port); + if (a == EOF) + goto str_eof; + if ('0' <= a && a <= '9') + a -= '0'; + else if ('A' <= a && a <= 'F') + a = a - 'A' + 10; + else if ('a' <= a && a <= 'f') + a = a - 'a' + 10; + else + { + c = a; + goto bad_escaped; + } + c = c * 16 + a; + } + break; + } + case 'U': + { + scm_t_wchar a; + int i; + c = 0; + for (i = 0; i < 6; i++) + { + a = scm_getc (port); + if (a == EOF) + goto str_eof; + if ('0' <= a && a <= '9') + a -= '0'; + else if ('A' <= a && a <= 'F') + a = a - 'A' + 10; + else if ('a' <= a && a <= 'f') + a = a - 'a' + 10; + else + { + c = a; + goto bad_escaped; + } + c = c * 16 + a; + } + break; + } + default: + bad_escaped: + scm_i_input_error (FUNC_NAME, port, + "illegal character in escape sequence: ~S", + scm_list_1 (SCM_MAKE_CHAR (c))); + } + } + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, c_str_len++, c); + scm_i_string_stop_writing (); } if (c_str_len > 0) { - SCM addy; - - addy = scm_from_locale_stringn (c_str, c_str_len); - if (str == SCM_BOOL_F) - str = addy; - else - str = scm_string_append_shared (scm_list_2 (str, addy)); + return scm_i_substring_copy (str, 0, c_str_len); } - else - str = (str == SCM_BOOL_F) ? scm_nullstr : str; - - return str; + + return scm_nullstr; } #undef FUNC_NAME diff --git a/libguile/rw.c b/libguile/rw.c index cb62b79b9..a9b4a329a 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -131,6 +131,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, don't touch the file descriptor. otherwise the "return immediately if something is available" rule may be violated. */ + str = scm_i_string_start_writing (str); dest = scm_i_string_writable_chars (str) + offset; chars_read = scm_take_from_input_buffers (port, dest, read_len); scm_i_string_stop_writing (); @@ -140,6 +141,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with EOF. */ { + str = scm_i_string_start_writing (str); dest = scm_i_string_writable_chars (str) + offset; SCM_SYSCALL (chars_read = read (fdes, dest, read_len)); scm_i_string_stop_writing (); diff --git a/libguile/socket.c b/libguile/socket.c index 553a1a185..2e02e9082 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1438,6 +1438,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, fd = SCM_FPORT_FDES (sock); len = scm_i_string_length (buf); + buf = scm_i_string_start_writing (buf); dest = scm_i_string_writable_chars (buf); SCM_SYSCALL (rv = recv (fd, dest, len, flg)); scm_i_string_stop_writing (); @@ -1482,6 +1483,7 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, fd = SCM_FPORT_FDES (sock); len = scm_i_string_length (message); + message = scm_i_string_start_writing (message); src = scm_i_string_writable_chars (message); SCM_SYSCALL (rv = send (fd, src, len, flg)); scm_i_string_stop_writing (); @@ -1550,6 +1552,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, /* recvfrom will not necessarily return an address. usually nothing is returned for stream sockets. */ + str = scm_i_string_start_writing (str); buf = scm_i_string_writable_chars (str); ((struct sockaddr *) &addr)->sa_family = AF_UNSPEC; SCM_SYSCALL (rv = recvfrom (fd, buf + offset, diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index f3863d355..781fe6893 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -549,6 +549,7 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, len = cend - cstart; SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart); + target = scm_i_string_start_writing (target); ctarget = scm_i_string_writable_chars (target); memmove (ctarget + ctstart, cstr + cstart, len); scm_i_string_stop_writing (); @@ -985,6 +986,7 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0, 4, end, cend); SCM_VALIDATE_CHAR_COPY (2, chr, c); + str = scm_i_string_start_writing (str); cstr = scm_i_string_writable_chars (str); for (k = cstart; k < cend; k++) cstr[k] = c; @@ -2376,6 +2378,7 @@ string_upcase_x (SCM v, size_t start, size_t end) size_t k; char *dst; + v = scm_i_string_start_writing (v); dst = scm_i_string_writable_chars (v); for (k = start; k < end; ++k) dst[k] = scm_c_upcase (dst[k]); @@ -2442,6 +2445,7 @@ string_downcase_x (SCM v, size_t start, size_t end) size_t k; char *dst; + v = scm_i_string_start_writing (v); dst = scm_i_string_writable_chars (v); for (k = start; k < end; ++k) dst[k] = scm_c_downcase (dst[k]); @@ -2511,6 +2515,7 @@ string_titlecase_x (SCM str, size_t start, size_t end) size_t i; int in_word = 0; + str = scm_i_string_start_writing (str); sz = (unsigned char *) scm_i_string_writable_chars (str); for(i = start; i < end; i++) { @@ -2635,6 +2640,7 @@ SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, 2, start, cstart, 3, end, cend); result = scm_string_copy (str); + result = scm_i_string_start_writing (result); ctarget = scm_i_string_writable_chars (result); string_reverse_x (ctarget, cstart, cend); scm_i_string_stop_writing (); @@ -2658,6 +2664,7 @@ SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, 2, start, cstart, 3, end, cend); + str = scm_i_string_start_writing (str); cstr = scm_i_string_writable_chars (str); string_reverse_x (cstr, cstart, cend); scm_i_string_stop_writing (); @@ -3018,19 +3025,16 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, "return value is not specified.") #define FUNC_NAME s_scm_string_for_each { - const char *cstr; size_t cstart, cend; scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc); SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (2, s, + 3, start, cstart, + 4, end, cend); while (cstart < cend) { - unsigned int c = (unsigned char) cstr[cstart]; - proc_tramp (proc, SCM_MAKE_CHAR (c)); - cstr = scm_i_string_chars (s); + proc_tramp (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); cstart++; } @@ -3162,6 +3166,7 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, SCM_ASSERT_RANGE (1, tstart, ctstart + (csto - csfrom) <= scm_i_string_length (target)); + target = scm_i_string_start_writing (target); p = scm_i_string_writable_chars (target) + ctstart; cs = scm_i_string_chars (s); while (csfrom < csto) @@ -3200,8 +3205,8 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, MY_VALIDATE_SUBSTRING_SPEC (2, s2, 5, start2, cstart2, 6, end2, cend2); - result = scm_i_make_string (cstart1 + (cend2 - cstart2) + - scm_i_string_length (s1) - cend1, &p); + result = scm_i_make_string ((cstart1 + cend2 - cstart2 + + scm_i_string_length (s1) - cend1), &p); cstr1 = scm_i_string_chars (s1); cstr2 = scm_i_string_chars (s2); memmove (p, cstr1, cstart1 * sizeof (char)); diff --git a/libguile/strings.c b/libguile/strings.c index 4e21f3e28..fc92fd233 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -24,6 +24,8 @@ #include #include +#include +#include #include "libguile/_scm.h" #include "libguile/chars.h" @@ -69,10 +71,12 @@ #define STRINGBUF_F_SHARED 0x100 #define STRINGBUF_F_INLINE 0x200 +#define STRINGBUF_F_WIDE 0x400 #define STRINGBUF_TAG scm_tc7_stringbuf #define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED) #define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE) +#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE) #define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf)) #define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf)) @@ -82,6 +86,7 @@ #define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \ ? STRINGBUF_INLINE_CHARS (buf) \ : STRINGBUF_OUTLINE_CHARS (buf)) +#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *)SCM_CELL_WORD_1(buf)) #define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \ ? STRINGBUF_INLINE_LENGTH (buf) \ : STRINGBUF_OUTLINE_LENGTH (buf)) @@ -126,6 +131,23 @@ make_stringbuf (size_t len) } } +static SCM +make_wide_stringbuf (size_t len) +{ + scm_t_wchar *mem; +#if SCM_DEBUG + if (len < 1000) + lenhist[len]++; + else + lenhist[1000]++; +#endif + + mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string"); + mem[len] = 0; + return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_WIDE, (scm_t_bits) mem, + (scm_t_bits) len, (scm_t_bits) 0); +} + /* Return a new stringbuf whose underlying storage consists of the LEN+1 octets pointed to by STR (the last octet is zero). */ SCM @@ -147,8 +169,58 @@ void scm_i_stringbuf_free (SCM buf) { if (!STRINGBUF_INLINE (buf)) - scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), - STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string"); + { + if (!STRINGBUF_WIDE (buf)) + scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), + STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string"); + else + scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), + sizeof (scm_t_wchar) * (STRINGBUF_OUTLINE_LENGTH (buf) + + 1), "string"); + } + +} + +static void +widen_stringbuf (SCM buf) +{ + size_t i, len; + scm_t_wchar *mem; + + if (STRINGBUF_WIDE (buf)) + return; + + if (STRINGBUF_INLINE (buf)) + { + len = STRINGBUF_INLINE_LENGTH (buf); + + mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string"); + for (i = 0; i < len; i++) + mem[i] = + (scm_t_wchar) (unsigned char) STRINGBUF_INLINE_CHARS (buf)[i]; + mem[len] = 0; + + SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_INLINE); + SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE); + SCM_SET_CELL_WORD_1 (buf, mem); + SCM_SET_CELL_WORD_2 (buf, len); + } + else + { + len = STRINGBUF_OUTLINE_LENGTH (buf); + + mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string"); + for (i = 0; i < len; i++) + mem[i] = + (scm_t_wchar) (unsigned char) STRINGBUF_OUTLINE_CHARS (buf)[i]; + mem[len] = 0; + + scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), len + 1, "string"); + + SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE); + SCM_SET_CELL_WORD_1 (buf, mem); + SCM_SET_CELL_WORD_2 (buf, len); + } } scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; @@ -195,6 +267,18 @@ scm_i_make_string (size_t len, char **charsp) return res; } +SCM +scm_i_make_wide_string (size_t len, scm_t_wchar ** charsp) +{ + SCM buf = make_wide_stringbuf (len); + SCM res; + if (charsp) + *charsp = STRINGBUF_WIDE_CHARS (buf); + res = scm_double_cell (STRING_TAG, SCM_UNPACK (buf), + (scm_t_bits) 0, (scm_t_bits) len); + return res; +} + static void validate_substring_args (SCM str, size_t start, size_t end) { @@ -253,12 +337,24 @@ scm_i_substring_copy (SCM str, size_t start, size_t end) SCM buf, my_buf; size_t str_start; get_str_buf_start (&str, &buf, &str_start); - my_buf = make_stringbuf (len); - memcpy (STRINGBUF_CHARS (my_buf), - STRINGBUF_CHARS (buf) + str_start + start, len); + if (scm_i_is_narrow_string (str)) + { + my_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (my_buf), + STRINGBUF_CHARS (buf) + str_start + start, len); + } + else + { + my_buf = make_wide_stringbuf (len); + u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf), + (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start + + start), len); + /* Even though this string is wide, the substring may be narrow. + Consider adding code to narrow string. */ + } scm_remember_upto_here_1 (buf); - return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf), - (scm_t_bits)0, (scm_t_bits) len); + return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf), + (scm_t_bits) 0, (scm_t_bits) len); } SCM @@ -330,17 +426,45 @@ scm_i_string_length (SCM str) return STRING_LENGTH (str); } +int +scm_i_is_narrow_string (SCM str) +{ + return !STRINGBUF_WIDE (STRING_STRINGBUF (str)); +} + const char * scm_i_string_chars (SCM str) { SCM buf; size_t start; get_str_buf_start (&str, &buf, &start); - return STRINGBUF_CHARS (buf) + start; + if (scm_i_is_narrow_string (str)) + return STRINGBUF_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid read access of chars of wide string: ~s", + scm_list_1 (str)); + return NULL; } -char * -scm_i_string_writable_chars (SCM orig_str) +const scm_t_wchar * +scm_i_string_wide_chars (SCM str) +{ + SCM buf; + size_t start; + + get_str_buf_start (&str, &buf, &start); + if (!scm_i_is_narrow_string (str)) + return STRINGBUF_WIDE_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s", + scm_list_1 (str)); +} + +/* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to + a new string buffer, so that it can be modified without modifying + other strings. */ +SCM +scm_i_string_start_writing (SCM orig_str) { SCM buf, str = orig_str; size_t start; @@ -352,18 +476,26 @@ scm_i_string_writable_chars (SCM orig_str) scm_i_pthread_mutex_lock (&stringbuf_write_mutex); if (STRINGBUF_SHARED (buf)) { - /* Clone stringbuf. For this, we put all threads to sleep. - */ - + /* Clone the stringbuf. */ size_t len = STRING_LENGTH (str); SCM new_buf; scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - new_buf = make_stringbuf (len); - memcpy (STRINGBUF_CHARS (new_buf), - STRINGBUF_CHARS (buf) + STRING_START (str), len); + if (scm_i_is_narrow_string (str)) + { + new_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (new_buf), + STRINGBUF_CHARS (buf) + STRING_START (str), len); + } + else + { + new_buf = make_wide_stringbuf (len); + u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf), + (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + + STRING_START (str)), len); + } scm_i_thread_put_to_sleep (); SET_STRING_STRINGBUF (str, new_buf); start -= STRING_START (str); @@ -374,8 +506,39 @@ scm_i_string_writable_chars (SCM orig_str) scm_i_pthread_mutex_lock (&stringbuf_write_mutex); } + return orig_str; +} - return STRINGBUF_CHARS (buf) + start; +/* Return a pointer to the chars of a string that fits in a Latin-1 + encoding. */ +char * +scm_i_string_writable_chars (SCM str) +{ + SCM buf; + size_t start; + + get_str_buf_start (&str, &buf, &start); + if (scm_i_is_narrow_string (str)) + return STRINGBUF_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid write access of chars of wide string: ~s", + scm_list_1 (str)); + return NULL; +} + +/* Return a pointer to the Unicode codepoints of a string. */ +static scm_t_wchar * +scm_i_string_writable_wide_chars (SCM str) +{ + SCM buf; + size_t start; + + get_str_buf_start (&str, &buf, &start); + if (!scm_i_is_narrow_string (str)) + return STRINGBUF_WIDE_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s", + scm_list_1 (str)); } void @@ -384,6 +547,34 @@ scm_i_string_stop_writing (void) scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); } +/* Return the Xth character is C. */ +scm_t_wchar +scm_i_string_ref (SCM str, size_t x) +{ + if (scm_i_is_narrow_string (str)) + return (scm_t_wchar) (unsigned char) (scm_i_string_chars (str)[x]); + else + return scm_i_string_wide_chars (str)[x]; +} + +void +scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr) +{ + if (chr > 0xFF && scm_i_is_narrow_string (str)) + widen_stringbuf (STRING_STRINGBUF (str)); + + if (scm_i_is_narrow_string (str)) + { + char *dst = scm_i_string_writable_chars (str); + dst[p] = (char) (unsigned char) chr; + } + else + { + scm_t_wchar *dst = scm_i_string_writable_wide_chars (str); + dst[p] = chr; + } +} + /* Symbols. Basic symbol creation and accessing is done here, the rest is in @@ -418,10 +609,21 @@ scm_i_make_symbol (SCM name, scm_t_bits flags, else { /* make new buf. */ - SCM new_buf = make_stringbuf (length); - memcpy (STRINGBUF_CHARS (new_buf), - STRINGBUF_CHARS (buf) + start, length); - buf = new_buf; + if (scm_i_is_narrow_string (name)) + { + SCM new_buf = make_stringbuf (length); + memcpy (STRINGBUF_CHARS (new_buf), + STRINGBUF_CHARS (buf) + start, length); + buf = new_buf; + } + else + { + SCM new_buf = make_wide_stringbuf (length); + u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf), + (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start, + length); + buf = new_buf; + } } return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf), (scm_t_bits) hash, SCM_UNPACK (props)); @@ -466,11 +668,40 @@ scm_c_symbol_length (SCM sym) } #undef FUNC_NAME +int +scm_i_is_narrow_symbol (SCM sym) +{ + SCM buf; + + buf = SYMBOL_STRINGBUF (sym); + return !STRINGBUF_WIDE (buf); +} + const char * scm_i_symbol_chars (SCM sym) { - SCM buf = SYMBOL_STRINGBUF (sym); - return STRINGBUF_CHARS (buf); + SCM buf; + + buf = SYMBOL_STRINGBUF (sym); + if (!STRINGBUF_WIDE (buf)) + return STRINGBUF_CHARS (buf); + else + scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S", + scm_list_1 (sym)); +} + +/* Return a pointer to the Unicode codepoints of a symbol's name. */ +const scm_t_wchar * +scm_i_symbol_wide_chars (SCM sym) +{ + SCM buf; + + buf = SYMBOL_STRINGBUF (sym); + if (STRINGBUF_WIDE (buf)) + return STRINGBUF_WIDE_CHARS (buf); + else + scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S", + scm_list_1 (sym)); } SCM @@ -496,6 +727,15 @@ scm_i_symbol_substring (SCM sym, size_t start, size_t end) (scm_t_bits)start, (scm_t_bits) end - start); } +scm_t_wchar +scm_i_symbol_ref (SCM sym, size_t x) +{ + if (scm_i_is_narrow_symbol (sym)) + return (scm_t_wchar) (unsigned char) (scm_i_symbol_chars (sym)[x]); + else + return scm_i_symbol_wide_chars (sym)[x]; +} + /* Debugging */ @@ -505,15 +745,17 @@ SCM scm_sys_string_dump (SCM); SCM scm_sys_symbol_dump (SCM); SCM scm_sys_stringbuf_hist (void); -SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, - (SCM str), - "") +SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), "") #define FUNC_NAME s_scm_sys_string_dump { SCM_VALIDATE_STRING (1, str); fprintf (stderr, "%p:\n", str); fprintf (stderr, " start: %u\n", STRING_START (str)); fprintf (stderr, " len: %u\n", STRING_LENGTH (str)); + if (scm_i_is_narrow_string (str)) + fprintf (stderr, " format: narrow\n"); + else + fprintf (stderr, " format: wide\n"); if (IS_SH_STRING (str)) { fprintf (stderr, " string: %p\n", SH_STRING_STRING (str)); @@ -524,36 +766,54 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, { SCM buf = STRING_STRINGBUF (str); fprintf (stderr, " buf: %p\n", buf); - fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); + if (scm_i_is_narrow_string (str)) + fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); + else + fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf)); fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf)); - fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300)); + if (STRINGBUF_SHARED (buf)) + fprintf (stderr, " shared: true\n"); + else + fprintf (stderr, " shared: false\n"); + if (STRINGBUF_INLINE (buf)) + fprintf (stderr, " inline: true\n"); + else + fprintf (stderr, " inline: false\n"); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME -SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, - (SCM sym), - "") +SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), "") #define FUNC_NAME s_scm_sys_symbol_dump { SCM_VALIDATE_SYMBOL (1, sym); fprintf (stderr, "%p:\n", sym); fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym)); + if (scm_i_is_narrow_symbol (sym)) + fprintf (stderr, " format: narrow\n"); + else + fprintf (stderr, " format: wide\n"); { SCM buf = SYMBOL_STRINGBUF (sym); fprintf (stderr, " buf: %p\n", buf); - fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); + if (scm_i_is_narrow_symbol (sym)) + fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); + else + fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf)); fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf)); - fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf)); + if (STRINGBUF_SHARED (buf)) + fprintf (stderr, " shared: true\n"); + else + fprintf (stderr, " shared: false\n"); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME -SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, - (void), - "") +SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "") #define FUNC_NAME s_scm_sys_stringbuf_hist { int i; @@ -589,29 +849,46 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, #define FUNC_NAME s_scm_string { SCM result; + SCM rest; size_t len; - char *data; + size_t p = 0; + long i; - { - long i = scm_ilength (chrs); + /* Verify that this is a list of chars. */ + i = scm_ilength (chrs); + len = (size_t) i; + rest = chrs; - SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME); - len = i; - } - - result = scm_i_make_string (len, &data); - while (len > 0 && scm_is_pair (chrs)) + SCM_ASSERT (len >= 0, chrs, SCM_ARG1, FUNC_NAME); + while (len > 0 && scm_is_pair (rest)) { - SCM elt = SCM_CAR (chrs); - + SCM elt = SCM_CAR (rest); SCM_VALIDATE_CHAR (SCM_ARGn, elt); - *data++ = SCM_CHAR (elt); - chrs = SCM_CDR (chrs); + rest = SCM_CDR (rest); len--; + scm_remember_upto_here_1 (elt); } + + /* Construct a string containing this list of chars. */ + len = (size_t) i; + rest = chrs; + + result = scm_i_make_string (len, NULL); + result = scm_i_string_start_writing (result); + while (len > 0 && scm_is_pair (rest)) + { + SCM elt = SCM_CAR (rest); + scm_i_string_set_x (result, p, SCM_CHAR (elt)); + p++; + rest = SCM_CDR (rest); + len--; + scm_remember_upto_here_1 (elt); + } + scm_i_string_stop_writing (); + if (len > 0) scm_misc_error (NULL, "list changed while constructing string", SCM_EOL); - if (!scm_is_null (chrs)) + if (!scm_is_null (rest)) scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list"); return result; @@ -634,13 +911,16 @@ SCM scm_c_make_string (size_t len, SCM chr) #define FUNC_NAME NULL { - char *dst; - SCM res = scm_i_make_string (len, &dst); + size_t p; + SCM res = scm_i_make_string (len, NULL); if (!SCM_UNBNDP (chr)) { SCM_VALIDATE_CHAR (0, chr); - memset (dst, SCM_CHAR (chr), len); + res = scm_i_string_start_writing (res); + for (p = 0; p < len; p++) + scm_i_string_set_x (res, p, SCM_CHAR (chr)); + scm_i_string_stop_writing (); } return res; @@ -657,6 +937,20 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_string_width, "string-width", 1, 0, 0, + (SCM string), + "Return the bytes used to represent a character in @var{string}." + "This will return 1 or 4.") +#define FUNC_NAME s_scm_string_width +{ + SCM_VALIDATE_STRING (1, string); + if (!scm_i_is_narrow_string (string)) + return scm_from_int (4); + + return scm_from_int (1); +} +#undef FUNC_NAME + size_t scm_c_string_length (SCM string) { @@ -667,8 +961,8 @@ scm_c_string_length (SCM string) SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, (SCM str, SCM k), - "Return character @var{k} of @var{str} using zero-origin\n" - "indexing. @var{k} must be a valid index of @var{str}.") + "Return character @var{k} of @var{str} using zero-origin\n" + "indexing. @var{k} must be a valid index of @var{str}.") #define FUNC_NAME s_scm_string_ref { size_t len; @@ -682,7 +976,10 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, else scm_out_of_range (NULL, k); - return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]); + if (scm_i_is_narrow_string (str)) + return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]); + else + return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[idx]); } #undef FUNC_NAME @@ -691,14 +988,18 @@ scm_c_string_ref (SCM str, size_t p) { if (p >= scm_i_string_length (str)) scm_out_of_range (NULL, scm_from_size_t (p)); - return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]); + if (scm_i_is_narrow_string (str)) + return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]); + else + return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[p]); + } SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, (SCM str, SCM k, SCM chr), - "Store @var{chr} in element @var{k} of @var{str} and return\n" - "an unspecified value. @var{k} must be a valid index of\n" - "@var{str}.") + "Store @var{chr} in element @var{k} of @var{str} and return\n" + "an unspecified value. @var{k} must be a valid index of\n" + "@var{str}.") #define FUNC_NAME s_scm_string_set_x { size_t len; @@ -713,11 +1014,10 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, scm_out_of_range (NULL, k); SCM_VALIDATE_CHAR (3, chr); - { - char *dst = scm_i_string_writable_chars (str); - dst[idx] = SCM_CHAR (chr); - scm_i_string_stop_writing (); - } + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, idx, SCM_CHAR (chr)); + scm_i_string_stop_writing (); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -727,11 +1027,9 @@ scm_c_string_set_x (SCM str, size_t p, SCM chr) { if (p >= scm_i_string_length (str)) scm_out_of_range (NULL, scm_from_size_t (p)); - { - char *dst = scm_i_string_writable_chars (str); - dst[p] = SCM_CHAR (chr); - scm_i_string_stop_writing (); - } + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, p, SCM_CHAR (chr)); + scm_i_string_stop_writing (); } SCM_DEFINE (scm_substring, "substring", 2, 1, 0, @@ -832,31 +1130,55 @@ SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0, SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, (SCM args), - "Return a newly allocated string whose characters form the\n" + "Return a newly allocated string whose characters form the\n" "concatenation of the given strings, @var{args}.") #define FUNC_NAME s_scm_string_append { SCM res; - size_t i = 0; + size_t len = 0; + int wide = 0; SCM l, s; char *data; + scm_t_wchar *wdata; + int i; SCM_VALIDATE_REST_ARGUMENT (args); - for (l = args; !scm_is_null (l); l = SCM_CDR (l)) + for (l = args; !scm_is_null (l); l = SCM_CDR (l)) { s = SCM_CAR (l); SCM_VALIDATE_STRING (SCM_ARGn, s); - i += scm_i_string_length (s); + len += scm_i_string_length (s); + if (!scm_i_is_narrow_string (s)) + wide = 1; } - res = scm_i_make_string (i, &data); - for (l = args; !scm_is_null (l); l = SCM_CDR (l)) + if (!wide) + res = scm_i_make_string (len, &data); + else + res = scm_i_make_wide_string (len, &wdata); + + for (l = args; !scm_is_null (l); l = SCM_CDR (l)) { size_t len; s = SCM_CAR (l); SCM_VALIDATE_STRING (SCM_ARGn, s); len = scm_i_string_length (s); - memcpy (data, scm_i_string_chars (s), len); - data += len; + if (!wide) + { + memcpy (data, scm_i_string_chars (s), len); + data += len; + } + else + { + if (scm_i_is_narrow_string (s)) + { + for (i = 0; i < scm_i_string_length (s); i++) + wdata[i] = (unsigned char) scm_i_string_chars (s)[i]; + } + else + u32_cpy ((scm_t_uint32 *) wdata, + (scm_t_uint32 *) scm_i_string_wide_chars (s), len); + wdata += len; + } scm_remember_upto_here_1 (s); } return res; @@ -875,8 +1197,11 @@ scm_from_locale_stringn (const char *str, size_t len) SCM res; char *dst; - if (len == (size_t)-1) + if (len == (size_t) -1) len = strlen (str); + if (len == 0) + return scm_nullstr; + res = scm_i_make_string (len, &dst); memcpy (dst, str, len); return res; @@ -885,6 +1210,9 @@ scm_from_locale_stringn (const char *str, size_t len) SCM scm_from_locale_string (const char *str) { + if (str == NULL) + return scm_nullstr; + return scm_from_locale_stringn (str, -1); } @@ -893,21 +1221,20 @@ scm_take_locale_stringn (char *str, size_t len) { SCM buf, res; - if (len == (size_t)-1) + if (len == (size_t) -1) len = strlen (str); else { /* Ensure STR is null terminated. A realloc for 1 extra byte should often be satisfied from the alignment padding after the block, with no actual data movement. */ - str = scm_realloc (str, len+1); + str = scm_realloc (str, len + 1); str[len] = '\0'; } buf = scm_i_take_stringbufn (str, len); res = scm_double_cell (STRING_TAG, - SCM_UNPACK (buf), - (scm_t_bits) 0, (scm_t_bits) len); + SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len); return res; } @@ -917,33 +1244,143 @@ scm_take_locale_string (char *str) return scm_take_locale_stringn (str, -1); } -char * -scm_to_locale_stringn (SCM str, size_t *lenp) +/* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXX \uXXXX + and \UXXXXXX. */ +static void +unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp) { - char *res; - size_t len; + char *before, *after; + size_t i, j; + + before = *bufp; + after = *bufp; + i = 0; + j = 0; + while (i < *lenp) + { + if ((i <= *lenp - 6) + && before[i] == '\\' + && before[i + 1] == 'u' + && before[i + 2] == '0' && before[i + 3] == '0') + { + /* Convert \u00NN to \xNN */ + after[j] = '\\'; + after[j + 1] = 'x'; + after[j + 2] = tolower (before[i + 4]); + after[j + 3] = tolower (before[i + 5]); + i += 6; + j += 4; + } + else if ((i <= *lenp - 10) + && before[i] == '\\' + && before[i + 1] == 'U' + && before[i + 2] == '0' && before[i + 3] == '0') + { + /* Convert \U00NNNNNN to \UNNNNNN */ + after[j] = '\\'; + after[j + 1] = 'U'; + after[j + 2] = tolower (before[i + 4]); + after[j + 3] = tolower (before[i + 5]); + after[j + 4] = tolower (before[i + 6]); + after[j + 5] = tolower (before[i + 7]); + after[j + 6] = tolower (before[i + 8]); + after[j + 7] = tolower (before[i + 9]); + i += 10; + j += 8; + } + else + { + after[j] = before[i]; + i++; + j++; + } + } + *lenp = j; + after = scm_realloc (after, j); +} + +char * +scm_to_locale_stringn (SCM str, size_t * lenp) +{ + const char *enc; + + /* In the future, enc will hold the port's encoding. */ + enc = NULL; + + return scm_to_stringn (str, lenp, enc, iconveh_escape_sequence); +} + +/* Low-level scheme to C string conversion function. */ +char * +scm_to_stringn (SCM str, size_t * lenp, const char *encoding, + enum iconv_ilseq_handler handler) +{ + static const char iso[11] = "ISO-8859-1"; + char *buf; + size_t ilen, len, i; if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); - len = scm_i_string_length (str); - res = scm_malloc (len + ((lenp==NULL)? 1 : 0)); - memcpy (res, scm_i_string_chars (str), len); - if (lenp == NULL) + ilen = scm_i_string_length (str); + + if (ilen == 0) { - res[len] = '\0'; - if (strlen (res) != len) - { - free (res); - scm_misc_error (NULL, - "string contains #\\nul character: ~S", - scm_list_1 (str)); - } + buf = scm_malloc (1); + buf[0] = '\0'; + if (lenp) + *lenp = 0; + return buf; } - else + + if (lenp == NULL) + for (i = 0; i < ilen; i++) + if (scm_i_string_ref (str, i) == '\0') + scm_misc_error (NULL, + "string contains #\\nul character: ~S", + scm_list_1 (str)); + + if (scm_i_is_narrow_string (str)) + { + if (lenp) + { + buf = scm_malloc (ilen); + memcpy (buf, scm_i_string_chars (str), ilen); + *lenp = ilen; + return buf; + } + else + { + buf = scm_malloc (ilen + 1); + memcpy (buf, scm_i_string_chars (str), ilen); + buf[ilen] = '\0'; + return buf; + } + } + + + buf = NULL; + len = 0; + buf = u32_conv_to_encoding (iso, + handler, + (scm_t_uint32 *) scm_i_string_wide_chars (str), + ilen, NULL, NULL, &len); + if (buf == NULL) + scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"", + scm_list_2 (scm_from_locale_string (iso), str)); + + if (handler == iconveh_escape_sequence) + unistring_escapes_to_guile_escapes (&buf, &len); + + if (lenp) *lenp = len; + else + { + buf = scm_realloc (buf, len + 1); + buf[len] = '\0'; + } scm_remember_upto_here_1 (str); - return res; + return buf; } char * @@ -956,18 +1393,21 @@ size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len) { size_t len; - + char *result = NULL; if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); - len = scm_i_string_length (str); - memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len); + result = scm_to_locale_stringn (str, &len); + + memcpy (buf, result, (len > max_len) ? max_len : len); + free (result); + scm_remember_upto_here_1 (str); return len; } /* converts C scm_array of strings to SCM scm_list of strings. */ /* If argc < 0, a null terminated scm_array is assumed. */ -SCM +SCM scm_makfromstrs (int argc, char **argv) { int i = argc; @@ -1081,6 +1521,7 @@ scm_i_deprecated_string_chars (SCM str) /* The following is still wrong, of course... */ + str = scm_i_string_start_writing (str); chars = scm_i_string_writable_chars (str); scm_i_string_stop_writing (); return chars; diff --git a/libguile/strings.h b/libguile/strings.h index 9e028d82e..5c09d587a 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -23,6 +23,7 @@ +#include #include "libguile/__scm.h" @@ -46,26 +47,37 @@ Internal, low level interface to the character arrays - - Use scm_i_string_chars to get a pointer to the byte array of a - string for reading. Use scm_i_string_length to get the number of - bytes in that array. The array is not null-terminated. + - Use scm_is_narrow_string to determine is the string is narrow or + wide. + + - Use scm_i_string_chars or scm_i_string_wide_chars to get a + pointer to the byte or scm_t_wchar array of a string for reading. + Use scm_i_string_length to get the number of characters in that + array. The array is not null-terminated. - The array is valid as long as the corresponding SCM object is protected but only until the next SCM_TICK. During such a 'safe point', strings might change their representation. - - Use scm_i_string_writable_chars to get the same pointer as with - scm_i_string_chars, but for reading and writing. This is a - potentially costly operation since it implements the - copy-on-write behavior. When done with the writing, call - scm_i_string_stop_writing. You must do this before the next - SCM_TICK. (This means, before calling almost any other scm_ - function and you can't allow throws, of course.) + - Use scm_i_string_start_writing to get a version of the string + ready for reading and writing. This is a potentially costly + operation since it implements the copy-on-write behavior. When + done with the writing, call scm_i_string_stop_writing. You must + do this before the next SCM_TICK. (This means, before calling + almost any other scm_ function and you can't allow throws, of + course.) - - New strings can be created with scm_i_make_string. This gives - access to a writable pointer that remains valid as long as nobody - else makes a copy-on-write substring of the string. Do not call - scm_i_string_stop_writing for this pointer. + - New strings can be created with scm_i_make_string or + scm_i_make_wide_string. This gives access to a writable pointer + that remains valid as long as nobody else makes a copy-on-write + substring of the string. Do not call scm_i_string_stop_writing + for this pointer. + + - Alternately, scm_i_string_ref and scm_i_string_set_x can be used + to read and write strings without worrying about whether the + string is narrow or wide. scm_i_string_set_x still needs to be + bracketed by scm_i_string_start_writing and + scm_i_string_stop_writing. Legacy interface @@ -74,13 +86,15 @@ - SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH is the same as scm_i_string_length. SCM_STRING_CHARS will throw - an error for for strings that are not null-terminated. + an error for for strings that are not null-terminated. There is + no wide version of this interface. */ SCM_API SCM scm_string_p (SCM x); SCM_API SCM scm_string (SCM chrs); SCM_API SCM scm_make_string (SCM k, SCM chr); SCM_API SCM scm_string_length (SCM str); +SCM_API SCM scm_string_width (SCM str); SCM_API SCM scm_string_ref (SCM str, SCM k); SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr); SCM_API SCM scm_substring (SCM str, SCM start, SCM end); @@ -106,6 +120,9 @@ SCM_API SCM scm_take_locale_string (char *str); SCM_API SCM scm_take_locale_stringn (char *str, size_t len); SCM_API char *scm_to_locale_string (SCM str); SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp); +SCM_INTERNAL char *scm_to_stringn (SCM str, size_t *lenp, + const char *encoding, + enum iconv_ilseq_handler handler); SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len); SCM_API SCM scm_makfromstrs (int argc, char **argv); @@ -113,15 +130,20 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv); /* internal accessor functions. Arguments must be valid. */ SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap); +SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap); SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end); SCM_INTERNAL size_t scm_i_string_length (SCM str); SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str); +SCM_API const scm_t_wchar *scm_i_string_wide_chars (SCM str); SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str); +SCM_INTERNAL SCM scm_i_string_start_writing (SCM str); SCM_INTERNAL void scm_i_string_stop_writing (void); - +SCM_INTERNAL int scm_i_is_narrow_string (SCM str); +SCM_INTERNAL scm_t_wchar scm_i_string_ref (SCM str, size_t x); +SCM_INTERNAL void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr); /* internal functions related to symbols. */ SCM_INTERNAL SCM scm_i_make_symbol (SCM name, scm_t_bits flags, @@ -133,8 +155,11 @@ SCM_INTERNAL SCM scm_i_c_take_symbol (char *name, size_t len, scm_t_bits flags, unsigned long hash, SCM props); SCM_INTERNAL const char *scm_i_symbol_chars (SCM sym); +SCM_INTERNAL const scm_t_wchar *scm_i_symbol_wide_chars (SCM sym); SCM_INTERNAL size_t scm_i_symbol_length (SCM sym); +SCM_INTERNAL int scm_i_is_narrow_symbol (SCM str); SCM_INTERNAL SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end); +SCM_INTERNAL scm_t_wchar scm_i_symbol_ref (SCM sym, size_t x); /* internal GC functions. */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index c0f772fb8..240969c37 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -336,6 +336,7 @@ do { \ #define FETCH() (*ip++) #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0) +#define FETCH_WIDTH(width) do { width=*ip++; } while (0) #undef CLOCK #if VM_USE_CLOCK diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 9ae49ed65..8de7f0036 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -72,31 +72,82 @@ VM_DEFINE_LOADER (82, load_number, "load-number") VM_DEFINE_LOADER (83, load_string, "load-string") { size_t len; + int width; + SCM str; + FETCH_LENGTH (len); + FETCH_WIDTH (width); SYNC_REGISTER (); - PUSH (scm_from_locale_stringn ((char *)ip, len)); - /* Was: scm_makfromstr (ip, len, 0) */ - ip += len; + if (width == 1) + { + char *buf; + str = scm_i_make_string (len, &buf); + memcpy (buf, (char *) ip, len); + } + else if (width == 4) + { + scm_t_wchar *wbuf; + str = scm_i_make_wide_string (len, &wbuf); + memcpy ((char *) wbuf, (char *) ip, len * width); + } + else + SCM_MISC_ERROR ("load-string: invalid character width", SCM_EOL); + PUSH (str); + ip += len * width; NEXT; } VM_DEFINE_LOADER (84, load_symbol, "load-symbol") { size_t len; + int width; + SCM str; FETCH_LENGTH (len); + FETCH_WIDTH (width); SYNC_REGISTER (); - PUSH (scm_from_locale_symboln ((char *)ip, len)); - ip += len; + if (width == 1) + { + char *buf; + str = scm_i_make_string (len, &buf); + memcpy (buf, (char *) ip, len); + } + else if (width == 4) + { + scm_t_wchar *wbuf; + str = scm_i_make_wide_string (len, &wbuf); + memcpy ((char *) wbuf, (char *) ip, len * width); + } + else + SCM_MISC_ERROR ("load-symbol: invalid character width", SCM_EOL); + PUSH (scm_string_to_symbol (str)); + ip += len * width; NEXT; } VM_DEFINE_LOADER (85, load_keyword, "load-keyword") { size_t len; + int width; + SCM str; FETCH_LENGTH (len); + FETCH_WIDTH (width); SYNC_REGISTER (); - PUSH (scm_from_locale_keywordn ((char *)ip, len)); - ip += len; + if (width == 1) + { + char *buf; + str = scm_i_make_string (len, &buf); + memcpy (buf, (char *) ip, len); + } + else if (width == 4) + { + scm_t_wchar *wbuf; + str = scm_i_make_wide_string (len, &wbuf); + memcpy ((char *) wbuf, (char *) ip, len * width); + } + else + SCM_MISC_ERROR ("load-keyword: invalid character width", SCM_EOL); + PUSH (scm_symbol_to_keyword (scm_string_to_symbol (str))); + ip += len * width; NEXT; } @@ -132,13 +183,29 @@ VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1) VM_DEFINE_LOADER (88, define, "define") { - SCM sym; + SCM str, sym; size_t len; + int width; FETCH_LENGTH (len); + FETCH_WIDTH (width); SYNC_REGISTER (); - sym = scm_from_locale_symboln ((char *)ip, len); - ip += len; + if (width == 1) + { + char *buf; + str = scm_i_make_string (len, &buf); + memcpy (buf, (char *) ip, len); + } + else if (width == 4) + { + scm_t_wchar *wbuf; + str = scm_i_make_wide_string (len, &wbuf); + memcpy ((char *) wbuf, (char *) ip, len * width); + } + else + SCM_MISC_ERROR ("load define: invalid character width", SCM_EOL); + sym = scm_string_to_symbol (str); + ip += len * width; SYNC_REGISTER (); PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T)); diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 3a1da4fe3..5571bee61 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -34,6 +34,10 @@ ;; lengths are encoded in 3 bytes (define *len-len* 3) +;; the number of bytes per string character is encoded in 1 byte +(define *width-len* 1) + + (define (byte-length assembly) (pmatch assembly (,label (guard (not (pair? label))) @@ -45,15 +49,15 @@ ((load-number ,str) (+ 1 *len-len* (string-length str))) ((load-string ,str) - (+ 1 *len-len* (string-length str))) + (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) ((load-symbol ,str) - (+ 1 *len-len* (string-length str))) + (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) ((load-keyword ,str) - (+ 1 *len-len* (string-length str))) + (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) ((load-array ,bv) (+ 1 *len-len* (bytevector-length bv))) ((define ,str) - (+ 1 *len-len* (string-length str))) + (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) ((,inst . _) (guard (>= (instruction-length inst) 0)) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index bed0fb2dc..840c73b3a 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -65,6 +65,12 @@ (write-byte (logand (ash x -8) 255)) (write-byte (logand (ash x -16) 255)) (write-byte (logand (ash x -24) 255))) + (define (write-uint32 x) (case byte-order + ((1234) (write-uint32-le x)) + ((4321) (write-uint32-be x)) + (else (error "unknown endianness" byte-order)))) + (define (write-wide-string s) + (string-for-each (lambda (c) (write-uint32 (char->integer c))) s)) (define (write-loader-len len) (write-byte (ash len -16)) (write-byte (logand (ash len -8) 255)) @@ -72,6 +78,14 @@ (define (write-loader str) (write-loader-len (string-length str)) (write-string str)) + (define (write-sized-loader str) + (let ((len (string-length str)) + (wid (string-width str))) + (write-loader-len len) + (write-byte wid) + (if (= wid 4) + (write-wide-string str) + (write-string str)))) (define (write-bytevector bv) (write-loader-len (bytevector-length bv)) ;; Ew! @@ -89,10 +103,6 @@ (write-uint16 (case byte-order ((1234) write-uint16-le) ((4321) write-uint16-be) - (else (error "unknown endianness" byte-order)))) - (write-uint32 (case byte-order - ((1234) write-uint32-le) - ((4321) write-uint32-be) (else (error "unknown endianness" byte-order))))) (let ((opcode (instruction->opcode inst)) (len (instruction-length inst))) @@ -126,11 +136,11 @@ ((load-unsigned-integer ,str) (write-loader str)) ((load-integer ,str) (write-loader str)) ((load-number ,str) (write-loader str)) - ((load-string ,str) (write-loader str)) - ((load-symbol ,str) (write-loader str)) - ((load-keyword ,str) (write-loader str)) + ((load-string ,str) (write-sized-loader str)) + ((load-symbol ,str) (write-sized-loader str)) + ((load-keyword ,str) (write-sized-loader str)) ((load-array ,bv) (write-bytevector bv)) - ((define ,str) (write-loader str)) + ((define ,str) (write-sized-loader str)) ((br ,l) (write-break l)) ((br-if ,l) (write-break l)) ((br-if-not ,l) (write-break l)) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 33a2a45f0..d01e93c43 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -79,15 +79,15 @@ (char->integer #\1) (char->integer #\4))) (comp-test '(load-string "foo") - (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o) + (vector 'load-string 0 0 3 1 (char->integer #\f) (char->integer #\o) (char->integer #\o))) (comp-test '(load-symbol "foo") - (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o) + (vector 'load-symbol 0 0 3 1 (char->integer #\f) (char->integer #\o) (char->integer #\o))) (comp-test '(load-keyword "qux") - (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u) + (vector 'load-keyword 0 0 3 1 (char->integer #\q) (char->integer #\u) (char->integer #\x))) (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) From 18c73f8e2bc4a184db62a975fa5bf2fdf43453e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 9 Aug 2009 20:21:41 +0200 Subject: [PATCH 336/375] Remove bogus `configure' test for GNU libunistring. * configure.ac: Remove explicit test for libunistring, which conflicted with Gnulib's own test. This fixes commit f4863880f5ef539cb545999c19b6b5c0eec9382d. --- configure.ac | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/configure.ac b/configure.ac index dae82954a..7f6df87ef 100644 --- a/configure.ac +++ b/configure.ac @@ -833,13 +833,7 @@ AC_LIB_HAVE_LINKFLAGS(gmp, [mpz_import (0, 0, 0, 0, 0, 0, 0);], AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README])) -dnl GNU libunistring tests. -AC_LIB_HAVE_LINKFLAGS(unistring, - [], - [#include ], - [u8_check ("foo", 3)] - AC_MSG_ERROR([GNU libunistring not found, see README])) - +dnl GNU libunistring is checked for by Gnulib's `libunistring' module. dnl i18n tests #AC_CHECK_HEADERS([libintl.h]) From 25361e4b2564623f57a5b338912b2f656bfc8d94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 9 Aug 2009 23:05:37 +0200 Subject: [PATCH 337/375] Use Gnulib's `lib-symbol-versions' module. * m4/gnulib-cache.m4: Add `lib-symbol-versions'. --- lib/Makefile.am | 4 +++- lib/time.in.h | 8 +++++++- lib/unistd.in.h | 13 +++++++++--- m4/gnulib-cache.m4 | 3 ++- m4/gnulib-comp.m4 | 6 ++++-- m4/iconv.m4 | 6 +++--- m4/ld-version-script.m4 | 44 +++++++++++++++++++++++++++++++++++++++++ m4/time_h.m4 | 4 ++-- m4/unistd_h.m4 | 3 ++- 9 files changed, 77 insertions(+), 14 deletions(-) create mode 100644 m4/ld-version-script.m4 diff --git a/lib/Makefile.am b/lib/Makefile.am index 424e5906a..0f74b5170 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-versions lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects @@ -896,6 +896,7 @@ time.h: time.in.h -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ -e 's|@NEXT_TIME_H''@|$(NEXT_TIME_H)|g' \ -e 's|@REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \ + -e 's|@REPLACE_MKTIME''@|$(REPLACE_MKTIME)|g' \ -e 's|@REPLACE_NANOSLEEP''@|$(REPLACE_NANOSLEEP)|g' \ -e 's|@REPLACE_STRPTIME''@|$(REPLACE_STRPTIME)|g' \ -e 's|@REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \ @@ -972,6 +973,7 @@ unistd.h: unistd.in.h -e 's|@''HAVE_SYS_PARAM_H''@|$(HAVE_SYS_PARAM_H)|g' \ -e 's|@''REPLACE_CHOWN''@|$(REPLACE_CHOWN)|g' \ -e 's|@''REPLACE_CLOSE''@|$(REPLACE_CLOSE)|g' \ + -e 's|@''REPLACE_DUP2''@|$(REPLACE_DUP2)|g' \ -e 's|@''REPLACE_FCHDIR''@|$(REPLACE_FCHDIR)|g' \ -e 's|@''REPLACE_GETCWD''@|$(REPLACE_GETCWD)|g' \ -e 's|@''REPLACE_GETPAGESIZE''@|$(REPLACE_GETPAGESIZE)|g' \ diff --git a/lib/time.in.h b/lib/time.in.h index 7da429a54..cef4e0546 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -1,6 +1,6 @@ /* A more-standard . - Copyright (C) 2007-2008 Free Software Foundation, Inc. + Copyright (C) 2007-2009 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -66,6 +66,12 @@ struct timespec int nanosleep (struct timespec const *__rqtp, struct timespec *__rmtp); # endif +/* Return the 'time_t' representation of TP and normalize TP. */ +# if @REPLACE_MKTIME@ +# define mktime rpl_mktime +extern time_t mktime (struct tm *__tp); +# endif + /* Convert TIMER to RESULT, assuming local time and UTC respectively. See and . */ diff --git a/lib/unistd.in.h b/lib/unistd.in.h index 2e42c0b89..e2545cbca 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -150,10 +150,13 @@ extern int close (int); #if @GNULIB_DUP2@ -# if !@HAVE_DUP2@ +# if @REPLACE_DUP2@ +# define dup2 rpl_dup2 +# endif +# if !@HAVE_DUP2@ || @REPLACE_DUP2@ /* Copy the file descriptor OLDFD into file descriptor NEWFD. Do nothing if NEWFD = OLDFD, otherwise close NEWFD first if it is open. - Return 0 if successful, otherwise -1 and errno set. + Return newfd if successful, otherwise -1 and errno set. See the POSIX:2001 specification . */ extern int dup2 (int oldfd, int newfd); @@ -214,7 +217,11 @@ extern int fchdir (int /*fd*/); # define dup rpl_dup extern int dup (int); -# define dup2 rpl_dup2 + +# if @REPLACE_DUP2@ +# undef dup2 +# endif +# define dup2 rpl_dup2_fchdir extern int dup2 (int, int); # endif diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 7f64af27c..930cce6cd 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-versions lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -33,6 +33,7 @@ gl_MODULES([ full-write havelib iconv_open-utf + lib-symbol-versions lib-symbol-visibility libunistring putenv diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 0c2b968ef..00b3f3ff7 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -15,7 +15,7 @@ # In projects using CVS, this file can be treated like other built files. -# This macro should be invoked from ./configure.in, in the section +# This macro should be invoked from ./configure.ac, in the section # "Checks for programs", right after AC_PROG_CC, and certainly before # any checks for libraries, header files, types and library functions. AC_DEFUN([gl_EARLY], @@ -31,7 +31,7 @@ AC_DEFUN([gl_EARLY], AC_REQUIRE([gl_FP_IEEE]) ]) -# This macro should be invoked from ./configure.in, in the section +# This macro should be invoked from ./configure.ac, in the section # "Check for header files, types and library functions". AC_DEFUN([gl_INIT], [ @@ -62,6 +62,7 @@ AC_DEFUN([gl_INIT], gl_FUNC_ICONV_OPEN gl_FUNC_ICONV_OPEN_UTF gl_INLINE + gl_LD_VERSION_SCRIPT gl_VISIBILITY gl_LIBUNISTRING gl_LOCALCHARSET @@ -361,6 +362,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/inline.m4 m4/intmax_t.m4 m4/inttypes_h.m4 + m4/ld-version-script.m4 m4/lib-ld.m4 m4/lib-link.m4 m4/lib-prefix.m4 diff --git a/m4/iconv.m4 b/m4/iconv.m4 index 3cc626829..ce21b0b87 100644 --- a/m4/iconv.m4 +++ b/m4/iconv.m4 @@ -1,4 +1,4 @@ -# iconv.m4 serial AM7 (gettext-0.18) +# iconv.m4 serial AM8 (gettext-0.18) dnl Copyright (C) 2000-2002, 2007-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -172,8 +172,8 @@ size_t iconv(); ], [], [am_cv_proto_iconv_arg1=""], [am_cv_proto_iconv_arg1="const"]) am_cv_proto_iconv="extern size_t iconv (iconv_t cd, $am_cv_proto_iconv_arg1 char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft);"]) am_cv_proto_iconv=`echo "[$]am_cv_proto_iconv" | tr -s ' ' | sed -e 's/( /(/'` - AC_MSG_RESULT([${ac_t:- - }$am_cv_proto_iconv]) + AC_MSG_RESULT([ + $am_cv_proto_iconv]) AC_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1], [Define as const if the declaration of iconv() needs const.]) fi diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4 new file mode 100644 index 000000000..a97888f24 --- /dev/null +++ b/m4/ld-version-script.m4 @@ -0,0 +1,44 @@ +# ld-version-script.m4 serial 1 +dnl Copyright (C) 2008, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Simon Josefsson + +# FIXME: The test below returns a false positive for mingw +# cross-compiles, 'local:' statements does not reduce number of +# exported symbols in a DLL. Use --disable-ld-version-script to work +# around the problem. + +# gl_LD_VERSION_SCRIPT +# -------------------- +# Check if LD supports linker scripts, and define automake conditional +# HAVE_LD_VERSION_SCRIPT if so. +AC_DEFUN([gl_LD_VERSION_SCRIPT], +[ + AC_ARG_ENABLE([ld-version-script], + AS_HELP_STRING([--enable-ld-version-script], + [enable linker version script (default is enabled when possible)]), + [have_ld_version_script=$enableval], []) + if test -z "$have_ld_version_script"; then + AC_MSG_CHECKING([if LD -Wl,--version-script works]) + save_LDFLAGS="$LDFLAGS" + LDFLAGS="$LDFLAGS -Wl,--version-script=conftest.map" + cat > conftest.map <. -# Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2007 Free Software -# Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -30,6 +29,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], dnl Otherwise, replace only if someone compiles with -DGNULIB_PORTCHECK; dnl this lets maintainers check for portability. REPLACE_LOCALTIME_R=GNULIB_PORTCHECK; AC_SUBST([REPLACE_LOCALTIME_R]) + REPLACE_MKTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_MKTIME]) REPLACE_NANOSLEEP=GNULIB_PORTCHECK; AC_SUBST([REPLACE_NANOSLEEP]) REPLACE_STRPTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_STRPTIME]) REPLACE_TIMEGM=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TIMEGM]) diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index ff9a4ea0a..96fddba7f 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,4 +1,4 @@ -# unistd_h.m4 serial 17 +# unistd_h.m4 serial 18 dnl Copyright (C) 2006-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -73,6 +73,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], HAVE_SYS_PARAM_H=0; AC_SUBST([HAVE_SYS_PARAM_H]) REPLACE_CHOWN=0; AC_SUBST([REPLACE_CHOWN]) REPLACE_CLOSE=0; AC_SUBST([REPLACE_CLOSE]) + REPLACE_DUP2=0; AC_SUBST([REPLACE_DUP2]) REPLACE_FCHDIR=0; AC_SUBST([REPLACE_FCHDIR]) REPLACE_GETCWD=0; AC_SUBST([REPLACE_GETCWD]) REPLACE_GETPAGESIZE=0; AC_SUBST([REPLACE_GETPAGESIZE]) From 9af080f7206dccffb91409529fff74e6554f2385 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 9 Aug 2009 23:40:11 +0200 Subject: [PATCH 338/375] Use a linker version script for libguile. * libguile/Makefile.am (libguile_la_LDFLAGS)[HAVE_LD_VERSION_SCRIPT]: Use `libguile.map'. (EXTRA_DIST): Add `libguile.map'. * libguile/libguile.map: New file. --- libguile/Makefile.am | 9 ++++++++- libguile/libguile.map | 44 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+), 1 deletion(-) create mode 100644 libguile/libguile.map diff --git a/libguile/Makefile.am b/libguile/Makefile.am index dfaa65a8f..09be8785f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -223,6 +223,13 @@ libguile_la_DEPENDENCIES = @LIBLOBJS@ libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING) libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined +if HAVE_LD_VERSION_SCRIPT + +libguile_la_LDFLAGS += -Wl,--version-script="$(srcdir)/libguile.map" + +endif HAVE_LD_VERSION_SCRIPT + + # These are headers visible as pkginclude_HEADERS = @@ -264,7 +271,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ c-tokenize.lex version.h.in \ - scmconfig.h.top libgettext.h + scmconfig.h.top libgettext.h libguile.map # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi diff --git a/libguile/libguile.map b/libguile/libguile.map new file mode 100644 index 000000000..2586e0abf --- /dev/null +++ b/libguile/libguile.map @@ -0,0 +1,44 @@ +# Linker version script for libguile. -*- ld-script -*- +# +# Copyright (C) 2009 Free Software Foundation, Inc. +# +# This file is part of GUILE. +# +# GUILE is free software; you can redistribute it and/or modify it +# under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3, or +# (at your option) any later version. +# +# GUILE 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 Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with GUILE; see the file COPYING.LESSER. If not, +# write to the Free Software Foundation, Inc., 51 Franklin Street, +# Fifth Floor, Boston, MA 02110-1301 USA + +GUILE_2.0 +{ + global: + # Note: This includes `scm_i_' symbols declared as `SCM_API' (e.g., + # symbols from `deprecated.c' or symbols used by public inline + # functions or macros). + scm_*; + + # GDB interface. + gdb_options; + gdb_language; + gdb_result; + gdb_output; + gdb_output_length; + gdb_maybe_valid_type_p; + gdb_read; + gdb_eval; + gdb_print; + gdb_binding; + + local: + *; +}; From b07992900bef24596532018d7939384f8632cd0f Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sun, 9 Aug 2009 15:58:49 -0700 Subject: [PATCH 339/375] Port position macros shouldn't require enclosing braces The port position macros incorrectly required enclosing braces when used within if statements. * libguile/ports.h (SCM_INCLINE, SCM_ZEROCOL, SCM_INCCOL) (SCM_DECCOL, SCM_TABCOL): enclose macro in do/while * libguile/ports.c (update_port_lf): remove extra braces --- libguile/ports.c | 23 ++++++----------------- libguile/ports.h | 10 +++++----- 2 files changed, 11 insertions(+), 22 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 2c1a3898f..4ed5f76d7 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -973,28 +973,17 @@ static void update_port_lf (scm_t_wchar c, SCM port) { if (c == '\a') - { - } + ; /* Do nothing. */ else if (c == '\b') - { - SCM_DECCOL (port); - } + SCM_DECCOL (port); else if (c == '\n') - { - SCM_INCLINE (port); - } + SCM_INCLINE (port); else if (c == '\r') - { - SCM_ZEROCOL (port); - } + SCM_ZEROCOL (port); else if (c == '\t') - { - SCM_TABCOL (port); - } + SCM_TABCOL (port); else - { - SCM_INCCOL (port); - } + SCM_INCCOL (port); } void diff --git a/libguile/ports.h b/libguile/ports.h index d427fecb1..e5c0ffd84 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -155,11 +155,11 @@ SCM_INTERNAL SCM scm_i_port_weak_hash; #define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed) #define SCM_SETREVEALED(x, s) (SCM_PTAB_ENTRY(x)->revealed = (s)) -#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} -#define SCM_ZEROCOL(port) {SCM_COL (port) = 0;} -#define SCM_INCCOL(port) {SCM_COL (port) += 1;} -#define SCM_DECCOL(port) {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} -#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;} +#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0) +#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0) +#define SCM_INCCOL(port) do {SCM_COL (port) += 1;} while (0) +#define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0) +#define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0) /* Maximum number of port types. */ #define SCM_I_MAX_PORT_TYPE_COUNT 256 From 4847dc172f4086152987d5f9c353cf14db17d554 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sun, 9 Aug 2009 16:01:20 -0700 Subject: [PATCH 340/375] Missing parentheses in SCM_MAKE_CHAR macro * libguile/chars.h (SCM_MAKE_CHAR): missing parentheses --- libguile/chars.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/chars.h b/libguile/chars.h index 4d1be1db9..e016cb28e 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -33,9 +33,9 @@ #define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x)) #define SCM_MAKE_CHAR(x) \ - (x < 0 \ - ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) x, scm_tc8_char) \ - : SCM_MAKE_ITAG8 ((scm_t_bits) x, scm_tc8_char)) + ((x) < 0 \ + ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \ + : SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char)) #define SCM_CODEPOINT_MAX (0x10ffff) #define SCM_IS_UNICODE_CHAR(c) \ From 50b1996f1b229889f088aa01f4c1c5fcd5dd0d63 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Sun, 9 Aug 2009 18:06:59 -0700 Subject: [PATCH 341/375] More comments for string functions * libguile/strings.c: comments --- libguile/strings.c | 75 ++++++++++++++++++++++++++++++++++++---------- 1 file changed, 59 insertions(+), 16 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index fc92fd233..90d13028b 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -45,7 +45,7 @@ * * XXX - keeping an accurate refcount during GC seems to be quite * tricky, so we just keep score of whether a stringbuf might be - * shared, not wether it definitely is. + * shared, not whether it definitely is. * * The scheme I (mvo) tried to keep an accurate reference count would * recount all strings that point to a stringbuf during the mark-phase @@ -62,16 +62,24 @@ * A stringbuf needs to know its length, but only so that it can be * reported when the stringbuf is freed. * - * Stringbufs (and strings) are not stored very compactly: a stringbuf - * has room for about 2*sizeof(scm_t_bits)-1 bytes additional - * information. As a compensation, the code below is made more - * complicated by storing small strings inline in the double cell of a - * stringbuf. So we have fixstrings and bigstrings... + * There are 3 storage strategies for stringbufs: inline, outline, and + * wide. + * + * Inline strings are small 8-bit strings stored within the double + * cell itself. Outline strings are larger 8-bit strings with GC + * allocated storage. Wide strings are 32-bit strings with allocated + * storage. + * + * There was little value in making wide string inlineable, since + * there is only room for three inlined 32-bit characters. Thus wide + * stringbufs are never inlined. */ #define STRINGBUF_F_SHARED 0x100 #define STRINGBUF_F_INLINE 0x200 -#define STRINGBUF_F_WIDE 0x400 +#define STRINGBUF_F_WIDE 0x400 /* If true, strings have UCS-4 + encoding. Otherwise, strings + are Latin-1. */ #define STRINGBUF_TAG scm_tc7_stringbuf #define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED) @@ -86,6 +94,7 @@ #define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \ ? STRINGBUF_INLINE_CHARS (buf) \ : STRINGBUF_OUTLINE_CHARS (buf)) + #define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *)SCM_CELL_WORD_1(buf)) #define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \ ? STRINGBUF_INLINE_LENGTH (buf) \ @@ -100,6 +109,8 @@ static size_t lenhist[1001]; #endif +/* Make a stringbuf with space for LEN 8-bit Latin-1-encoded + characters. */ static SCM make_stringbuf (size_t len) { @@ -131,6 +142,8 @@ make_stringbuf (size_t len) } } +/* Make a stringbuf with space for LEN 32-bit UCS-4-encoded + characters. */ static SCM make_wide_stringbuf (size_t len) { @@ -181,6 +194,8 @@ scm_i_stringbuf_free (SCM buf) } +/* Convert a stringbuf containing 8-bit Latin-1-encoded characters to + one containing 32-bit UCS-4-encoded characters. */ static void widen_stringbuf (SCM buf) { @@ -255,6 +270,9 @@ scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; #define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG) +/* Create a scheme string with space for LEN 8-bit Latin-1-encoded + characters. CHARSP, if not NULL, will be set to location of the + char array. */ SCM scm_i_make_string (size_t len, char **charsp) { @@ -267,8 +285,11 @@ scm_i_make_string (size_t len, char **charsp) return res; } +/* Create a scheme string with space for LEN 32-bit UCS-4-encoded + characters. CHARSP, if not NULL, will be set to location of the + character array. */ SCM -scm_i_make_wide_string (size_t len, scm_t_wchar ** charsp) +scm_i_make_wide_string (size_t len, scm_t_wchar **charsp) { SCM buf = make_wide_stringbuf (len); SCM res; @@ -350,7 +371,7 @@ scm_i_substring_copy (SCM str, size_t start, size_t end) (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start + start), len); /* Even though this string is wide, the substring may be narrow. - Consider adding code to narrow string. */ + Consider adding code to narrow the string. */ } scm_remember_upto_here_1 (buf); return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf), @@ -420,18 +441,25 @@ scm_i_string_free (SCM str) /* Internal accessors */ +/* Returns the number of characters in STR. This may be different + than the memory size of the string storage. */ size_t scm_i_string_length (SCM str) { return STRING_LENGTH (str); } +/* True if the string is 'narrow', meaning it has a 8-bit Latin-1 + encoding. False if it is 'wide', having a 32-bit UCS-4 + encoding. */ int scm_i_is_narrow_string (SCM str) { return !STRINGBUF_WIDE (STRING_STRINGBUF (str)); } +/* Returns a pointer to the 8-bit Latin-1 encoded character array of + STR. */ const char * scm_i_string_chars (SCM str) { @@ -446,6 +474,8 @@ scm_i_string_chars (SCM str) return NULL; } +/* Returns a pointer to the 32-bit UCS-4 encoded character array of + STR. */ const scm_t_wchar * scm_i_string_wide_chars (SCM str) { @@ -462,7 +492,8 @@ scm_i_string_wide_chars (SCM str) /* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to a new string buffer, so that it can be modified without modifying - other strings. */ + other strings. Also, lock the string mutex. Later, one must call + scm_i_string_stop_writing to unlock the mutex. */ SCM scm_i_string_start_writing (SCM orig_str) { @@ -509,8 +540,7 @@ scm_i_string_start_writing (SCM orig_str) return orig_str; } -/* Return a pointer to the chars of a string that fits in a Latin-1 - encoding. */ +/* Return a pointer to the 8-bit Latin-1 chars of a string. */ char * scm_i_string_writable_chars (SCM str) { @@ -526,7 +556,7 @@ scm_i_string_writable_chars (SCM str) return NULL; } -/* Return a pointer to the Unicode codepoints of a string. */ +/* Return a pointer to the UCS-4 codepoints of a string. */ static scm_t_wchar * scm_i_string_writable_wide_chars (SCM str) { @@ -541,13 +571,15 @@ scm_i_string_writable_wide_chars (SCM str) scm_list_1 (str)); } +/* Unlock the string mutex that was locked when + scm_i_string_start_writing was called. */ void scm_i_string_stop_writing (void) { scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); } -/* Return the Xth character is C. */ +/* Return the Xth character of STR as a UCS-4 codepoint. */ scm_t_wchar scm_i_string_ref (SCM str, size_t x) { @@ -557,6 +589,7 @@ scm_i_string_ref (SCM str, size_t x) return scm_i_string_wide_chars (str)[x]; } +/* Set the Pth character of STR to UCS-4 codepoint CHR. */ void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr) { @@ -652,6 +685,8 @@ scm_i_c_take_symbol (char *name, size_t len, (scm_t_bits) hash, SCM_UNPACK (props)); } +/* Returns the number of characters in SYM. This may be different + from the memory size of SYM. */ size_t scm_i_symbol_length (SCM sym) { @@ -668,6 +703,8 @@ scm_c_symbol_length (SCM sym) } #undef FUNC_NAME +/* True if the name of SYM is stored as a Latin-1 encoded string. + False if it is stored as a 32-bit UCS-4-encoded string. */ int scm_i_is_narrow_symbol (SCM sym) { @@ -677,6 +714,8 @@ scm_i_is_narrow_symbol (SCM sym) return !STRINGBUF_WIDE (buf); } +/* Returns a pointer to the 8-bit Latin-1 encoded character array that + contains the name of SYM. */ const char * scm_i_symbol_chars (SCM sym) { @@ -690,7 +729,8 @@ scm_i_symbol_chars (SCM sym) scm_list_1 (sym)); } -/* Return a pointer to the Unicode codepoints of a symbol's name. */ +/* Return a pointer to the 32-bit UCS-4-encoded character array of a + symbol's name. */ const scm_t_wchar * scm_i_symbol_wide_chars (SCM sym) { @@ -727,6 +767,7 @@ scm_i_symbol_substring (SCM sym, size_t start, size_t end) (scm_t_bits)start, (scm_t_bits) end - start); } +/* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */ scm_t_wchar scm_i_symbol_ref (SCM sym, size_t x) { @@ -1216,6 +1257,8 @@ scm_from_locale_string (const char *str) return scm_from_locale_stringn (str, -1); } +/* Create a new scheme string from the C string STR. The memory of + STR may be used directly as storage for the new string. */ SCM scm_take_locale_stringn (char *str, size_t len) { From 6ce6923b6826db2f2ddc8a5f787ab57d7072f0e8 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Mon, 10 Aug 2009 00:09:33 -0700 Subject: [PATCH 342/375] Improve %string-dump and %symbol-dump %string-dump and %symbol-dump are modified to return assocation lists of string and symbol attributes instead of printing to stderr. They are no longer conditional on SCM_DEBUG. * libguile/strings.c (scm_sys_string_dump) (scm_sys_symbol_dump): now returns alist of properties. No longer require that SCM_DEBUG be defined. (scm_sys_stringbuf_hist): now conditional on SCM_STRING_LENGTH_HISTOGRAM * libguile/strings.h: scm_sys_string_dump and scm_sys_symbol dump are now declared as API --- libguile/strings.c | 232 +++++++++++++++++++++++++++++++++------------ libguile/strings.h | 8 ++ 2 files changed, 182 insertions(+), 58 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index 90d13028b..f10c9ebce 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -105,7 +105,7 @@ #define SET_STRINGBUF_SHARED(buf) \ (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED)) -#if SCM_DEBUG +#if SCM_STRING_LENGTH_HISTOGRAM static size_t lenhist[1001]; #endif @@ -121,7 +121,7 @@ make_stringbuf (size_t len) can be dropped. */ -#if SCM_DEBUG +#if SCM_STRING_LENGTH_HISTOGRAM if (len < 1000) lenhist[len]++; else @@ -148,7 +148,7 @@ static SCM make_wide_stringbuf (size_t len) { scm_t_wchar *mem; -#if SCM_DEBUG +#if SCM_STRING_LENGTH_HISTOGRAM if (len < 1000) lenhist[len]++; else @@ -780,80 +780,196 @@ scm_i_symbol_ref (SCM sym, size_t x) /* Debugging */ -#if SCM_DEBUG - -SCM scm_sys_string_dump (SCM); -SCM scm_sys_symbol_dump (SCM); -SCM scm_sys_stringbuf_hist (void); - -SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), "") +SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), + "Returns an association list containing debugging information\n" + "for @var{str}. The association list has the following entries." + "@table @code\n" + "@item string\n" + "The string itself.\n" + "@item start\n" + "The start index of the string into its stringbuf\n" + "@item length\n" + "The length of the string\n" + "@item shared\n" + "If this string is a substring, it returns its parent string.\n" + "Otherwise, it returns @code{#f}\n" + "@item stringbuf\n" + "The string buffer that contains this string's characters\n" + "@item stringbuf-chars\n" + "A new string containing this string's stringbuf's characters\n" + "@item stringbuf-length\n" + "The number of characters in this stringbuf\n" + "@item stringbuf-shared\n" + "@code{#t} if this stringbuf is shared\n" + "@item stringbuf-inline\n" + "@code{#t} if this stringbuf's characters are stored in the\n" + "cell itself, or @code{#f} if they were allocated in memory\n" + "@item stringbuf-wide\n" + "@code{#t} if this stringbuf's characters are stored in a\n" + "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n" + "buffer\n" + "@end table") #define FUNC_NAME s_scm_sys_string_dump { + SCM e1, e2, e3, e4, e5, e6, e7, e8, e9, e10; + SCM buf; SCM_VALIDATE_STRING (1, str); - fprintf (stderr, "%p:\n", str); - fprintf (stderr, " start: %u\n", STRING_START (str)); - fprintf (stderr, " len: %u\n", STRING_LENGTH (str)); - if (scm_i_is_narrow_string (str)) - fprintf (stderr, " format: narrow\n"); - else - fprintf (stderr, " format: wide\n"); + + /* String info */ + e1 = scm_cons (scm_from_locale_symbol ("string"), + str); + e2 = scm_cons (scm_from_locale_symbol ("start"), + scm_from_size_t (STRING_START (str))); + e3 = scm_cons (scm_from_locale_symbol ("length"), + scm_from_size_t (STRING_LENGTH (str))); + if (IS_SH_STRING (str)) { - fprintf (stderr, " string: %p\n", SH_STRING_STRING (str)); - fprintf (stderr, "\n"); - scm_sys_string_dump (SH_STRING_STRING (str)); + e4 = scm_cons (scm_from_locale_symbol ("shared"), + SH_STRING_STRING (str)); + buf = STRING_STRINGBUF (SH_STRING_STRING (str)); } else { - SCM buf = STRING_STRINGBUF (str); - fprintf (stderr, " buf: %p\n", buf); - if (scm_i_is_narrow_string (str)) - fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); - else - fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf)); - fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf)); - if (STRINGBUF_SHARED (buf)) - fprintf (stderr, " shared: true\n"); - else - fprintf (stderr, " shared: false\n"); - if (STRINGBUF_INLINE (buf)) - fprintf (stderr, " inline: true\n"); - else - fprintf (stderr, " inline: false\n"); - + e4 = scm_cons (scm_from_locale_symbol ("shared"), + SCM_BOOL_F); + buf = STRING_STRINGBUF (str); } - return SCM_UNSPECIFIED; + + /* Stringbuf info */ + e5 = scm_cons (scm_from_locale_symbol ("stringbuf"), + buf); + + if (!STRINGBUF_WIDE (buf)) + { + size_t len = STRINGBUF_LENGTH (buf); + char *cbuf; + SCM sbc = scm_i_make_string (len, &cbuf); + memcpy (cbuf, STRINGBUF_CHARS (buf), len); + e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"), + sbc); + } + else + { + size_t len = STRINGBUF_LENGTH (buf); + scm_t_wchar *cbuf; + SCM sbc = scm_i_make_wide_string (len, &cbuf); + u32_cpy ((scm_t_uint32 *) cbuf, + (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len); + e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"), + sbc); + } + e7 = scm_cons (scm_from_locale_symbol ("stringbuf-length"), + scm_from_size_t (STRINGBUF_LENGTH (buf))); + if (STRINGBUF_SHARED (buf)) + e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"), + SCM_BOOL_T); + else + e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"), + SCM_BOOL_F); + if (STRINGBUF_INLINE (buf)) + e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"), + SCM_BOOL_T); + else + e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"), + SCM_BOOL_F); + if (STRINGBUF_WIDE (buf)) + e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_T); + else + e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_F); + + return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, SCM_UNDEFINED); } #undef FUNC_NAME -SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), "") +SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), + "Returns an association list containing debugging information\n" + "for @var{sym}. The association list has the following entries." + "@table @code\n" + "@item symbol\n" + "The symbol itself\n" + "@item hash\n" + "Its hash value\n" + "@item stringbuf\n" + "The string buffer that contains this symbol's characters\n" + "@item stringbuf-chars\n" + "A new string containing this symbols's stringbuf's characters\n" + "@item stringbuf-length\n" + "The number of characters in this stringbuf\n" + "@item stringbuf-shared\n" + "@code{#t} if this stringbuf is shared\n" + "@item stringbuf-inline\n" + "@code{#t} if this stringbuf's characters are stored in the\n" + "cell itself, or @code{#f} if they were allocated in memory\n" + "@item stringbuf-wide\n" + "@code{#t} if this stringbuf's characters are stored in a\n" + "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n" + "buffer\n" + "@end table") #define FUNC_NAME s_scm_sys_symbol_dump { + SCM e1, e2, e3, e4, e5, e6, e7, e8; + SCM buf; SCM_VALIDATE_SYMBOL (1, sym); - fprintf (stderr, "%p:\n", sym); - fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym)); - if (scm_i_is_narrow_symbol (sym)) - fprintf (stderr, " format: narrow\n"); + e1 = scm_cons (scm_from_locale_symbol ("symbol"), + sym); + e2 = scm_cons (scm_from_locale_symbol ("hash"), + scm_from_ulong (scm_i_symbol_hash (sym))); + + buf = SYMBOL_STRINGBUF (sym); + + /* Stringbuf info */ + e3 = scm_cons (scm_from_locale_symbol ("stringbuf"), + buf); + + if (!STRINGBUF_WIDE (buf)) + { + size_t len = STRINGBUF_LENGTH (buf); + char *cbuf; + SCM sbc = scm_i_make_string (len, &cbuf); + memcpy (cbuf, STRINGBUF_CHARS (buf), len); + e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"), + sbc); + } else - fprintf (stderr, " format: wide\n"); - { - SCM buf = SYMBOL_STRINGBUF (sym); - fprintf (stderr, " buf: %p\n", buf); - if (scm_i_is_narrow_symbol (sym)) - fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); - else - fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf)); - fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf)); - if (STRINGBUF_SHARED (buf)) - fprintf (stderr, " shared: true\n"); - else - fprintf (stderr, " shared: false\n"); - - } - return SCM_UNSPECIFIED; + { + size_t len = STRINGBUF_LENGTH (buf); + scm_t_wchar *cbuf; + SCM sbc = scm_i_make_wide_string (len, &cbuf); + u32_cpy ((scm_t_uint32 *) cbuf, + (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len); + e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"), + sbc); + } + e5 = scm_cons (scm_from_locale_symbol ("stringbuf-length"), + scm_from_size_t (STRINGBUF_LENGTH (buf))); + if (STRINGBUF_SHARED (buf)) + e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"), + SCM_BOOL_T); + else + e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"), + SCM_BOOL_F); + if (STRINGBUF_INLINE (buf)) + e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"), + SCM_BOOL_T); + else + e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"), + SCM_BOOL_F); + if (STRINGBUF_WIDE (buf)) + e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_T); + else + e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_F); + return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, SCM_UNDEFINED); + } #undef FUNC_NAME +#if SCM_STRING_LENGTH_HISTOGRAM + SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "") #define FUNC_NAME s_scm_sys_stringbuf_hist { diff --git a/libguile/strings.h b/libguile/strings.h index 5c09d587a..2bbab3a16 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -179,6 +179,14 @@ SCM_INTERNAL void scm_i_get_substring_spec (size_t len, SCM end, size_t *cend); SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len); +/* Debugging functions */ + +SCM_API SCM scm_sys_string_dump (SCM); +SCM_API SCM scm_sys_symbol_dump (SCM); +#if SCM_STRING_LENGTH_HISTOGRAM +SCM_API SCM scm_sys_stringbuf_hist (void); +#endif + /* deprecated stuff */ #if SCM_ENABLE_DEPRECATED From 32be5735cd89931048f12283f3977c72cd292f77 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Mon, 10 Aug 2009 05:51:05 -0700 Subject: [PATCH 343/375] Make scm_charprint and scm_i_string_wide_chars SCM_INTERNAL. Also, scm_charprint is renamed to scm_i_charprint. * libguile/strings.h: make scm_i_string_wide_chars internal. * libguile/print.h: rename scm_charprint to scm_i_charprint. Make internal. * libguile/print.c (scm_i_charprint): renamed from scm_charprint (scm_charprint): renamed to scm_i_charprint. All callers changed. --- libguile/print.c | 4 ++-- libguile/print.h | 2 +- libguile/strings.h | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 6f31fcf4a..85f030e36 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -582,7 +582,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) else if (ch == '"' || ch == '\\') { scm_putc ('\\', port); - scm_charprint (ch, port); + scm_i_charprint (ch, port); printed = 1; } else @@ -824,7 +824,7 @@ scm_prin1 (SCM exp, SCM port, int writingp) /* Print a character. */ void -scm_charprint (scm_t_uint32 ch, SCM port) +scm_i_charprint (scm_t_uint32 ch, SCM port) { scm_t_wchar *wbuf; SCM wstr = scm_i_make_wide_string (1, &wbuf); diff --git a/libguile/print.h b/libguile/print.h index 1df29522c..00648efc1 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -77,7 +77,7 @@ SCM_API SCM scm_print_options (SCM setting); SCM_API SCM scm_make_print_state (void); SCM_API void scm_free_print_state (SCM print_state); SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state); -SCM_API void scm_charprint (scm_t_uint32 c, SCM port); +SCM_INTERNAL void scm_i_charprint (scm_t_uint32 c, SCM port); SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port); SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port); SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port); diff --git a/libguile/strings.h b/libguile/strings.h index 2bbab3a16..8c06e4725 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -137,8 +137,8 @@ SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end); SCM_INTERNAL size_t scm_i_string_length (SCM str); SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str); -SCM_API const scm_t_wchar *scm_i_string_wide_chars (SCM str); SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str); +SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str); SCM_INTERNAL SCM scm_i_string_start_writing (SCM str); SCM_INTERNAL void scm_i_string_stop_writing (void); SCM_INTERNAL int scm_i_is_narrow_string (SCM str); From dab1ed3767c4fb8840401624e6c5a315e5cb5692 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 10 Aug 2009 19:24:34 +0200 Subject: [PATCH 344/375] Change `defined?' to accept a module as its second argument. Reported by Daniel Kraft . * doc/ref/api-binding.texi (Binding Reflection): Update documentation of `defined?'. * libguile/evalext.c (scm_defined_p): Expect a module as the second argument, not a lexical environment. --- doc/ref/api-binding.texi | 16 +++++++++----- libguile/evalext.c | 46 +++++++++------------------------------- 2 files changed, 21 insertions(+), 41 deletions(-) diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi index b42f5567f..e53c48040 100644 --- a/doc/ref/api-binding.texi +++ b/doc/ref/api-binding.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -271,10 +271,16 @@ with duplicate bindings. Guile provides a procedure for checking whether a symbol is bound in the top level environment. -@c NJFIXME explain [env] -@deffn {Scheme Procedure} defined? sym [env] -@deffnx {C Function} scm_defined_p (sym, env) -Return @code{#t} if @var{sym} is defined in the lexical environment @var{env}. When @var{env} is not specified, look in the top-level environment as defined by the current module. +@deffn {Scheme Procedure} defined? sym [module] +@deffnx {C Function} scm_defined_p (sym, module) +Return @code{#t} if @var{sym} is defined in the module @var{module} or +the current module when @var{module} is not specified; otherwise return +@code{#f}. + +Up to Guile 1.8, the second optional argument had to be @dfn{lexical +environment} as returned by @code{the-environment}, for example. The +behavior of this function remains unchanged when the second argument is +omitted. @end deffn diff --git a/libguile/evalext.c b/libguile/evalext.c index 56f74e213..19d8f2e02 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -31,49 +31,23 @@ #include "libguile/evalext.h" SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0, - (SCM sym, SCM env), - "Return @code{#t} if @var{sym} is defined in the lexical " - "environment @var{env}. When @var{env} is not specified, " - "look in the top-level environment as defined by the " - "current module.") + (SCM sym, SCM module), + "Return @code{#t} if @var{sym} is defined in the module " + "@var{module} or the current module when @var{module} is not" + "specified.") #define FUNC_NAME s_scm_defined_p { SCM var; SCM_VALIDATE_SYMBOL (1, sym); - if (SCM_UNBNDP (env)) - var = scm_sym2var (sym, scm_current_module_lookup_closure (), - SCM_BOOL_F); + if (SCM_UNBNDP (module)) + module = scm_current_module (); else - { - SCM frames = env; - register SCM b; - for (; SCM_NIMP (frames); frames = SCM_CDR (frames)) - { - SCM_ASSERT (scm_is_pair (frames), env, SCM_ARG2, FUNC_NAME); - b = SCM_CAR (frames); - if (scm_is_true (scm_procedure_p (b))) - break; - SCM_ASSERT (scm_is_pair (b), env, SCM_ARG2, FUNC_NAME); - for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b)) - { - if (!scm_is_pair (b)) - { - if (scm_is_eq (b, sym)) - return SCM_BOOL_T; - else - break; - } - if (scm_is_eq (SCM_CAR (b), sym)) - return SCM_BOOL_T; - } - } - var = scm_sym2var (sym, - SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F, - SCM_BOOL_F); - } - + SCM_VALIDATE_MODULE (2, module); + + var = scm_module_variable (module, sym); + return (scm_is_false (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var)) ? SCM_BOOL_F : SCM_BOOL_T); From 88ed5759cd257f412aa1955c10c3fcea49ccade5 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Mon, 10 Aug 2009 22:18:47 -0700 Subject: [PATCH 345/375] Fix %string-dump and %symbol-dump fields * libguile/strings.c (scm_sys_string_dump): don't print stringbuf. Print read-only status. (scm_sys_symbol_dump): don't print stringbuf. Print interned status. --- libguile/strings.c | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index f10c9ebce..c3ea8b8de 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -793,8 +793,8 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), "@item shared\n" "If this string is a substring, it returns its parent string.\n" "Otherwise, it returns @code{#f}\n" - "@item stringbuf\n" - "The string buffer that contains this string's characters\n" + "@item read-only\n" + "@code{#t} if the string is read-only\n" "@item stringbuf-chars\n" "A new string containing this string's stringbuf's characters\n" "@item stringbuf-length\n" @@ -836,10 +836,14 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), buf = STRING_STRINGBUF (str); } + if (IS_RO_STRING (str)) + e5 = scm_cons (scm_from_locale_symbol ("read-only"), + SCM_BOOL_T); + else + e5 = scm_cons (scm_from_locale_symbol ("read-only"), + SCM_BOOL_F); + /* Stringbuf info */ - e5 = scm_cons (scm_from_locale_symbol ("stringbuf"), - buf); - if (!STRINGBUF_WIDE (buf)) { size_t len = STRINGBUF_LENGTH (buf); @@ -892,8 +896,8 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), "The symbol itself\n" "@item hash\n" "Its hash value\n" - "@item stringbuf\n" - "The string buffer that contains this symbol's characters\n" + "@item interned\n" + "@code{#t} if it is an interned symbol\n" "@item stringbuf-chars\n" "A new string containing this symbols's stringbuf's characters\n" "@item stringbuf-length\n" @@ -917,13 +921,11 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), sym); e2 = scm_cons (scm_from_locale_symbol ("hash"), scm_from_ulong (scm_i_symbol_hash (sym))); - + e3 = scm_cons (scm_from_locale_symbol ("interned"), + scm_symbol_interned_p (sym)); buf = SYMBOL_STRINGBUF (sym); /* Stringbuf info */ - e3 = scm_cons (scm_from_locale_symbol ("stringbuf"), - buf); - if (!STRINGBUF_WIDE (buf)) { size_t len = STRINGBUF_LENGTH (buf); From f5d7662fc86462fef68477fbfed994d2cf228e3e Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Mon, 10 Aug 2009 22:55:29 -0700 Subject: [PATCH 346/375] More string and symbol tests * test-suite/tests/strings.test: more tests * test-suite/tests/symbols.test: more tests --- test-suite/tests/strings.test | 244 +++++++++++++++++++++++++++++++++- test-suite/tests/symbols.test | 80 ++++++++++- 2 files changed, 317 insertions(+), 7 deletions(-) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index ffc6955ca..d82a4723d 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,7 +1,7 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy --- August 1999 ;;;; -;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -20,14 +20,219 @@ (define-module (test-strings) #:use-module (test-suite lib)) - (define exception:read-only-string (cons 'misc-error "^string is read-only")) +(define exception:illegal-escape + (cons 'read-error "illegal character in escape sequence")) ;; Create a string from integer char values, eg. (string-ints 65) => "A" (define (string-ints . args) (apply string (map integer->char args))) +;; +;; string internals +;; + +;; Some abbreviations +;; BMP - Basic Multilingual Plane (codepoints below U+FFFF) +;; SMP - Suplementary Multilingual Plane (codebpoints from U+10000 to U+1FFFF) + +(with-test-prefix "string internals" + + (pass-if "new string starts at 1st char in stringbuf" + (let ((s "abc")) + (= 0 (assq-ref (%string-dump s) 'start)))) + + (pass-if "length of new string same as stringbuf" + (let ((s "def")) + (= (string-length s) (assq-ref (%string-dump s) 'stringbuf-length)))) + + (pass-if "contents of new string same as stringbuf" + (let ((s "ghi")) + (string=? s (assq-ref (%string-dump s) 'stringbuf-chars)))) + + (pass-if "writable strings are not read-only" + (let ((s "zyx")) + (not (assq-ref (%string-dump s) 'read-only)))) + + (pass-if "read-only strings are read-only" + (let ((s (substring/read-only "zyx" 0))) + (assq-ref (%string-dump s) 'read-only))) + + (pass-if "null strings are inlined" + (let ((s "")) + (assq-ref (%string-dump s) 'stringbuf-inline))) + + (pass-if "short Latin-1 encoded strings are inlined" + (let ((s "m")) + (assq-ref (%string-dump s) 'stringbuf-inline))) + + (pass-if "long Latin-1 encoded strings are not inlined" + (let ((s "0123456789012345678901234567890123456789")) + (not (assq-ref (%string-dump s) 'stringbuf-inline)))) + + (pass-if "short UCS-4 encoded strings are not inlined" + (let ((s "\u0100")) + (not (assq-ref (%string-dump s) 'stringbuf-inline)))) + + (pass-if "long UCS-4 encoded strings are not inlined" + (let ((s "\u010012345678901234567890123456789")) + (not (assq-ref (%string-dump s) 'stringbuf-inline)))) + + (pass-if "new Latin-1 encoded strings are not shared" + (let ((s "abc")) + (not (assq-ref (%string-dump s) 'stringbuf-shared)))) + + (pass-if "new UCS-4 encoded strings are not shared" + (let ((s "\u0100bc")) + (not (assq-ref (%string-dump s) 'stringbuf-shared)))) + + ;; Should this be true? It isn't currently true. + (pass-if "null shared substrings are shared" + (let* ((s1 "") + (s2 (substring/shared s1 0 0))) + (throw 'untested) + (eq? (assq-ref (%string-dump s2) 'shared) + s1))) + + (pass-if "ASCII shared substrings are shared" + (let* ((s1 "foobar") + (s2 (substring/shared s1 0 3))) + (eq? (assq-ref (%string-dump s2) 'shared) + s1))) + + (pass-if "BMP shared substrings are shared" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring/shared s1 0 3))) + (eq? (assq-ref (%string-dump s2) 'shared) + s1))) + + (pass-if "null substrings are not shared" + (let* ((s1 "") + (s2 (substring s1 0 0))) + (not (eq? (assq-ref (%string-dump s2) 'shared) + s1)))) + + (pass-if "ASCII substrings are not shared" + (let* ((s1 "foobar") + (s2 (substring s1 0 3))) + (not (eq? (assq-ref (%string-dump s2) 'shared) + s1)))) + + (pass-if "BMP substrings are not shared" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring s1 0 3))) + (not (eq? (assq-ref (%string-dump s2) 'shared) + s1)))) + + (pass-if "ASCII substrings share stringbufs before copy-on-write" + (let* ((s1 "foobar") + (s2 (substring s1 0 3))) + (assq-ref (%string-dump s1) 'stringbuf-shared))) + + (pass-if "BMP substrings share stringbufs before copy-on-write" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring s1 0 3))) + (assq-ref (%string-dump s1) 'stringbuf-shared))) + + (pass-if "ASCII substrings don't share stringbufs after copy-on-write" + (let* ((s1 "foobar") + (s2 (substring s1 0 3))) + (string-set! s2 0 #\F) + (not (assq-ref (%string-dump s2) 'stringbuf-shared)))) + + (pass-if "BMP substrings don't share stringbufs after copy-on-write" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring s1 0 3))) + (string-set! s2 0 #\F) + (not (assq-ref (%string-dump s2) 'stringbuf-shared)))) + + (with-test-prefix "encodings" + + (pass-if "null strings are Latin-1 encoded" + (let ((s "")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "ASCII strings are Latin-1 encoded" + (let ((s "jkl")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "Latin-1 strings are Latin-1 encoded" + (let ((s "\xC0\xC1\xC2")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "BMP strings are UCS-4 encoded" + (let ((s "\u0100\u0101\x0102")) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "SMP strings are UCS-4 encoded" + (let ((s "\U010300\u010301\x010302")) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "null list->string is Latin-1 encoded" + (let ((s (string-ints))) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "ASCII list->string is Latin-1 encoded" + (let ((s (string-ints 65 66 67))) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "Latin-1 list->string is Latin-1 encoded" + (let ((s (string-ints #xc0 #xc1 #xc2))) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "BMP list->string is UCS-4 encoded" + (let ((s (string-ints #x0100 #x0101 #x0102))) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "SMP list->string is UCS-4 encoded" + (let ((s (string-ints #x010300 #x010301 #x010302))) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "encoding of string not based on escape style" + (let ((s "\U000040")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))))) + +(with-test-prefix "hex escapes" + + (pass-if-exception "non-hex char in two-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\x0g\"" read)) + + (pass-if-exception "non-hex char in four-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\u000g\"" read)) + + (pass-if-exception "non-hex char in six-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\U00000g\"" read)) + + (pass-if-exception "premature termination of two-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\x0\"" read)) + + (pass-if-exception "premature termination of four-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\u000\"" read)) + + (pass-if-exception "premature termination of six-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\U00000\"" read)) + + (pass-if "extra hex digits ignored for two-digit hex escape" + (eqv? (string-ref "--\xfff--" 2) + (integer->char #xff))) + + (pass-if "extra hex digits ignored for four-digit hex escape" + (eqv? (string-ref "--\u0100f--" 2) + (integer->char #x0100))) + + (pass-if "extra hex digits ignored for six-digit hex escape" + (eqv? (string-ref "--\U010300f--" 2) + (integer->char #x010300))) + + (pass-if "escaped characters match non-escaped ASCII characters" + (string=? "ABC" "\x41\u0042\U000043"))) ;; ;; string=? @@ -181,8 +386,20 @@ exception:out-of-range (string-ref "hello" -1)) - (pass-if "regular string" - (char=? (string-ref "GNU Guile" 4) #\G))) + (pass-if "regular string, ASCII char" + (char=? (string-ref "GNU Guile" 4) #\G)) + + (pass-if "regular string, hex escaped Latin-1 char" + (char=? (string-ref "--\xff--" 2) + (integer->char #xff))) + + (pass-if "regular string, hex escaped BMP char" + (char=? (string-ref "--\u0100--" 2) + (integer->char #x0100))) + + (pass-if "regular string, hex escaped SMP char" + (char=? (string-ref "--\U010300--" 2) + (integer->char #x010300)))) ;; ;; string-set! @@ -210,10 +427,25 @@ exception:read-only-string (string-set! (substring/read-only "abc" 0) 1 #\space)) - (pass-if "regular string" + (pass-if "regular string, ASCII char" (let ((s (string-copy "GNU guile"))) (string-set! s 4 #\G) - (char=? (string-ref s 4) #\G)))) + (char=? (string-ref s 4) #\G))) + + (pass-if "regular string, Latin-1 char" + (let ((s (string-copy "GNU guile"))) + (string-set! s 4 (integer->char #xfe)) + (char=? (string-ref s 4) (integer->char #xfe)))) + + (pass-if "regular string, BMP char" + (let ((s (string-copy "GNU guile"))) + (string-set! s 4 (integer->char #x0100)) + (char=? (string-ref s 4) (integer->char #x0100)))) + + (pass-if "regular string, SMP char" + (let ((s (string-copy "GNU guile"))) + (string-set! s 4 (integer->char #x010300)) + (char=? (string-ref s 4) (integer->char #x010300))))) (with-test-prefix "string-split" diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test index 5be2743b2..3b1abe1e9 100644 --- a/test-suite/tests/symbols.test +++ b/test-suite/tests/symbols.test @@ -1,6 +1,6 @@ ;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*- ;;;; -;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -31,6 +31,84 @@ (define (documented? object) (not (not (object-documentation object)))) +(define (symbol-length s) + (string-length (symbol->string s))) + +;; +;; symbol internals +;; + +(with-test-prefix "symbol internals" + + (pass-if "length of new symbol same as stringbuf" + (let ((s 'def)) + (= (symbol-length s) (assq-ref (%symbol-dump s) 'stringbuf-length)))) + + (pass-if "contents of new symbol same as stringbuf" + (let ((s 'ghi)) + (string=? (symbol->string s) + (assq-ref (%symbol-dump s) 'stringbuf-chars)))) + + (pass-if "the null symbol is inlined" + (let ((s '#{}#)) + (assq-ref (%symbol-dump s) 'stringbuf-inline))) + + (pass-if "short Latin-1-encoded symbols are inlined" + (let ((s 'm)) + (assq-ref (%symbol-dump s) 'stringbuf-inline))) + + (pass-if "long Latin-1-encoded symbols are not inlined" + (let ((s 'x0123456789012345678901234567890123456789)) + (not (assq-ref (%symbol-dump s) 'stringbuf-inline)))) + + ;; symbol->string isn't ready for UCS-4 yet + + ;;(pass-if "short UCS-4-encoded symbols are not inlined" + ;; (let ((s (string->symbol "\u0100"))) + ;; (not (assq-ref (%symbol-dump s) 'stringbuf-inline)))) + + ;;(pass-if "long UCS-4-encoded symbols are not inlined" + ;; (let ((s (string->symbol "\u010012345678901234567890123456789"))) + ;; (not (assq-ref (%symbol-dump s) 'stringbuf-inline)))) + + (with-test-prefix "hashes" + + (pass-if "equal symbols have equal hashes" + (let ((s1 'mux) + (s2 'mux)) + (= (assq-ref (%symbol-dump s1) 'hash) + (assq-ref (%symbol-dump s2) 'hash)))) + + (pass-if "different symbols have different hashes" + (let ((s1 'mux) + (s2 'muy)) + (not (= (assq-ref (%symbol-dump s1) 'hash) + (assq-ref (%symbol-dump s2) 'hash)))))) + + (with-test-prefix "encodings" + + (pass-if "the null symbol is Latin-1 encoded" + (let ((s '#{}#)) + (not (assq-ref (%symbol-dump s) 'stringbuf-wide)))) + + (pass-if "ASCII symbols are Latin-1 encoded" + (let ((s 'jkl)) + (not (assq-ref (%symbol-dump s) 'stringbuf-wide)))) + + (pass-if "Latin-1 symbols are Latin-1 encoded" + (let ((s (string->symbol "\xC0\xC1\xC2"))) + (not (assq-ref (%symbol-dump s) 'stringbuf-wide)))) + + ;; symbol->string isn't ready for UCS-4 yet + + ;;(pass-if "BMP symbols are UCS-4 encoded" + ;; (let ((s (string->symbol "\u0100\u0101\x0102"))) + ;; (assq-ref (%symbol-dump s) 'stringbuf-wide))) + + ;;(pass-if "SMP symbols are UCS-4 encoded" + ;; (let ((s (string->symbol "\U010300\u010301\x010302"))) + ;; (assq-ref (%symbol-dump s) 'stringbuf-wide))) + )) ;;; ;;; symbol? From 86cfb42d56907c77e557b760328bfcee0d3be20c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 11 Aug 2009 20:25:19 +0200 Subject: [PATCH 347/375] include objcode cookie in the fallback path * libguile/_scm.h (SCM_OBJCODE_COOKIE): Move the objcode cookie define here, so that load.c can use it. This is a private header. * libguile/load.c (FALLBACK_DIR): Include the objcode cookie in the fallback path. Should fix problems when objcode changes incompatibly during the 1.9 series. * libguile/objcodes.c: Adapt to SCM_OBJCODE_COOKIE move. This should fix http://article.gmane.org/gmane.lisp.guile.devel/9059. --- libguile/_scm.h | 21 ++++++++++++++++++++- libguile/load.c | 2 +- libguile/objcodes.c | 37 +++++++++---------------------------- 3 files changed, 30 insertions(+), 30 deletions(-) diff --git a/libguile/_scm.h b/libguile/_scm.h index 429e87b7d..693ec1d9d 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -3,7 +3,7 @@ #ifndef SCM__SCM_H #define SCM__SCM_H -/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -59,6 +59,7 @@ #endif #include +#include #include "libguile/__scm.h" /* Include headers for those files central to the implementation. The @@ -156,6 +157,24 @@ #define scm_from_off64_t scm_from_int64 +/* The endianness marker in objcode. */ +#ifdef WORDS_BIGENDIAN +# define SCM_OBJCODE_ENDIANNESS "BE" +#else +# define SCM_OBJCODE_ENDIANNESS "LE" +#endif + +#define _SCM_CPP_STRINGIFY(x) # x +#define SCM_CPP_STRINGIFY(x) _SCM_CPP_STRINGIFY (x) + +/* The word size marker in objcode. */ +#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P) + +/* The objcode magic header. */ +#define SCM_OBJCODE_COOKIE \ + "GOOF-0.9-" SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE "---" + + #endif /* SCM__SCM_H */ /* diff --git a/libguile/load.c b/libguile/load.c index 890b0f824..b27bb8241 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -253,7 +253,7 @@ scm_init_load_path () struct passwd *pwd; #endif -#define FALLBACK_DIR "guile/ccache/"SCM_EFFECTIVE_VERSION +#define FALLBACK_DIR "guile/ccache/"SCM_EFFECTIVE_VERSION"/"SCM_OBJCODE_COOKIE if ((e = getenv ("XDG_CACHE_HOME"))) snprintf (cachedir, sizeof(cachedir), "%s" FALLBACK_DIR, e); diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 91691a70a..19c2406b1 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -28,33 +28,14 @@ #include #include -#include - #include "_scm.h" #include "vm-bootstrap.h" #include "programs.h" #include "objcodes.h" -/* The endianness marker in objcode. */ -#ifdef WORDS_BIGENDIAN -# define OBJCODE_ENDIANNESS "BE" -#else -# define OBJCODE_ENDIANNESS "LE" -#endif - -#define _OBJCODE_STRINGIFY(x) # x -#define OBJCODE_STRINGIFY(x) _OBJCODE_STRINGIFY (x) - -/* The word size marker in objcode. */ -#define OBJCODE_WORD_SIZE OBJCODE_STRINGIFY (SIZEOF_VOID_P) - -/* The objcode magic header. */ -#define OBJCODE_COOKIE \ - "GOOF-0.9-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" - +/* SCM_OBJCODE_COOKIE is defined in _scm.h */ /* The length of the header must be a multiple of 8 bytes. */ -verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0); - +verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0); /* @@ -77,7 +58,7 @@ make_objcode_by_mmap (int fd) if (ret < 0) SCM_SYSERROR; - if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE)) + if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE)) scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", scm_list_1 (SCM_I_MAKINUM (st.st_size))); @@ -88,18 +69,18 @@ make_objcode_by_mmap (int fd) SCM_SYSERROR; } - if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) + if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE))) { SCM args = scm_list_1 (scm_from_locale_stringn - (addr, strlen (OBJCODE_COOKIE))); + (addr, strlen (SCM_OBJCODE_COOKIE))); (void) close (fd); (void) munmap (addr, st.st_size); scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args); } - data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE)); + data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE)); - if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE))) + if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE))) { (void) close (fd); (void) munmap (addr, st.st_size); @@ -109,7 +90,7 @@ make_objcode_by_mmap (int fd) + data->metalen))); } - SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE), + SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE), SCM_PACK (SCM_BOOL_F), fd); SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP); @@ -270,7 +251,7 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0, SCM_VALIDATE_OBJCODE (1, objcode); SCM_VALIDATE_OUTPUT_PORT (2, port); - scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)); + scm_c_write (port, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)); scm_c_write (port, SCM_OBJCODE_DATA (objcode), sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode)); From 6e5c02b8a3d8783e6093e8147bec169e844c4d99 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 11 Aug 2009 21:16:05 +0200 Subject: [PATCH 348/375] make the fallback path look less like line noise * libguile/_scm.h: * libguile/load.c: Rework to only include the relevant pieces in the fallback path. --- libguile/_scm.h | 16 ++++++++++++++-- libguile/load.c | 3 ++- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/libguile/_scm.h b/libguile/_scm.h index 693ec1d9d..ff16a8587 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -170,9 +170,21 @@ /* The word size marker in objcode. */ #define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P) +// major and minor versions must be single characters +#define SCM_OBJCODE_MAJOR_VERSION 0 +#define SCM_OBJCODE_MINOR_VERSION A +#define SCM_OBJCODE_MAJOR_VERSION_STRING \ + SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) +#define SCM_OBJCODE_MINOR_VERSION_STRING \ + SCM_CPP_STRINGIFY(SCM_OBJCODE_MINOR_VERSION) +#define SCM_OBJCODE_VERSION_STRING \ + SCM_OBJCODE_MAJOR_VERSION_STRING "." SCM_OBJCODE_MINOR_VERSION_STRING +#define SCM_OBJCODE_MACHINE_VERSION_STRING \ + SCM_OBJCODE_VERSION_STRING "-" SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE + /* The objcode magic header. */ -#define SCM_OBJCODE_COOKIE \ - "GOOF-0.9-" SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE "---" +#define SCM_OBJCODE_COOKIE \ + "GOOF-" SCM_OBJCODE_MACHINE_VERSION_STRING "---" #endif /* SCM__SCM_H */ diff --git a/libguile/load.c b/libguile/load.c index b27bb8241..08324c587 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -253,7 +253,8 @@ scm_init_load_path () struct passwd *pwd; #endif -#define FALLBACK_DIR "guile/ccache/"SCM_EFFECTIVE_VERSION"/"SCM_OBJCODE_COOKIE +#define FALLBACK_DIR \ + "guile/ccache/" SCM_EFFECTIVE_VERSION "-" SCM_OBJCODE_MACHINE_VERSION_STRING if ((e = getenv ("XDG_CACHE_HOME"))) snprintf (cachedir, sizeof(cachedir), "%s" FALLBACK_DIR, e); From eb1482ac464433be51716cf9a2e0516810bda571 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 12 Aug 2009 00:14:44 +0200 Subject: [PATCH 349/375] debitrot the ecmascript compiler * module/Makefile.am (ECMASCRIPT_LANG_SOURCES): * module/language/ecmascript/compile-ghil.scm: * module/language/ecmascript/compile-tree-il.scm: SOURCES): Replace the GHIL compiler with a ->tree-il compiler. Not fully functional, but the basics work. * module/language/ecmascript/spec.scm: Only include the tree-il compiler. * module/language/ecmascript/tokenize.scm (read-punctuation): Avoid mutating a constant. --- module/Makefile.am | 2 +- module/language/ecmascript/compile-ghil.scm | 561 ------------------ .../language/ecmascript/compile-tree-il.scm | 549 +++++++++++++++++ module/language/ecmascript/spec.scm | 4 +- module/language/ecmascript/tokenize.scm | 2 +- 5 files changed, 553 insertions(+), 565 deletions(-) delete mode 100644 module/language/ecmascript/compile-ghil.scm create mode 100644 module/language/ecmascript/compile-tree-il.scm diff --git a/module/Makefile.am b/module/Makefile.am index 5eec063c2..5ef00be37 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -114,7 +114,7 @@ ECMASCRIPT_LANG_SOURCES = \ language/ecmascript/base.scm \ language/ecmascript/function.scm \ language/ecmascript/array.scm \ - language/ecmascript/compile-ghil.scm \ + language/ecmascript/compile-tree-il.scm \ language/ecmascript/spec.scm BRAINFUCK_LANG_SOURCES = \ diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm deleted file mode 100644 index ab04ba80c..000000000 --- a/module/language/ecmascript/compile-ghil.scm +++ /dev/null @@ -1,561 +0,0 @@ -;;; ECMAScript for Guile - -;; Copyright (C) 2009 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language ecmascript compile-ghil) - #:use-module (language ghil) - #:use-module (ice-9 receive) - #:use-module (system base pmatch) - #:export (compile-ghil)) - -(define-macro (-> form) - `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form))) - -(define-macro (@implv sym) - `(-> (ref (ghil-var-at-module! e '(language ecmascript impl) ',sym #t)))) -(define-macro (@impl sym args) - `(-> (call (@implv ,sym) ,args))) - -(define (compile-ghil exp env opts) - (values - (call-with-ghil-environment (make-ghil-toplevel-env) '() - (lambda (e vars) - (let ((l #f)) - (-> (lambda vars #f '() - (-> (begin (list (@impl js-init '()) - (comp exp e))))))))) - env - env)) - -(define (location x) - (and (pair? x) - (let ((props (source-properties x))) - (and (not (null? props)) - props)))) - -(define (comp x e) - (let ((l (location x))) - (define (let1 what proc) - (call-with-ghil-bindings e '(%tmp) - (lambda (vars) - (-> (bind vars (list what) - (proc (car vars))))))) - (define (begin1 what proc) - (call-with-ghil-bindings e '(%tmp) - (lambda (vars) - (-> (bind vars (list what) - (-> (begin (list (proc (car vars)) - (-> (ref (car vars))))))))))) - (pmatch x - (null - ;; FIXME, null doesn't have much relation to EOL... - (-> (quote '()))) - (true - (-> (quote #t))) - (false - (-> (quote #f))) - ((number ,num) - (-> (quote num))) - ((string ,str) - (-> (quote str))) - (this - (@impl get-this '())) - ((+ ,a) - (-> (inline 'add - (list (@impl ->number (list (comp a e))) - (-> (quote 0)))))) - ((- ,a) - (-> (inline 'sub (list (-> (quote 0)) (comp a e))))) - ((~ ,a) - (@impl bitwise-not (list (comp a e)))) - ((! ,a) - (@impl logical-not (list (comp a e)))) - ((+ ,a ,b) - (-> (inline 'add (list (comp a e) (comp b e))))) - ((- ,a ,b) - (-> (inline 'sub (list (comp a e) (comp b e))))) - ((/ ,a ,b) - (-> (inline 'div (list (comp a e) (comp b e))))) - ((* ,a ,b) - (-> (inline 'mul (list (comp a e) (comp b e))))) - ((% ,a ,b) - (@impl mod (list (comp a e) (comp b e)))) - ((<< ,a ,b) - (@impl shift (list (comp a e) (comp b e)))) - ((>> ,a ,b) - (@impl shift (list (comp a e) (comp `(- ,b) e)))) - ((< ,a ,b) - (-> (inline 'lt? (list (comp a e) (comp b e))))) - ((<= ,a ,b) - (-> (inline 'le? (list (comp a e) (comp b e))))) - ((> ,a ,b) - (-> (inline 'gt? (list (comp a e) (comp b e))))) - ((>= ,a ,b) - (-> (inline 'ge? (list (comp a e) (comp b e))))) - ((in ,a ,b) - (@impl has-property? (list (comp a e) (comp b e)))) - ((== ,a ,b) - (-> (inline 'equal? (list (comp a e) (comp b e))))) - ((!= ,a ,b) - (-> (inline 'not - (list (-> (inline 'equal? - (list (comp a e) (comp b e)))))))) - ((=== ,a ,b) - (-> (inline 'eqv? (list (comp a e) (comp b e))))) - ((!== ,a ,b) - (-> (inline 'not - (list (-> (inline 'eqv? - (list (comp a e) (comp b e)))))))) - ((& ,a ,b) - (@impl band (list (comp a e) (comp b e)))) - ((^ ,a ,b) - (@impl bxor (list (comp a e) (comp b e)))) - ((bor ,a ,b) - (@impl bior (list (comp a e) (comp b e)))) - ((and ,a ,b) - (-> (and (list (comp a e) (comp b e))))) - ((or ,a ,b) - (-> (or (list (comp a e) (comp b e))))) - ((if ,test ,then ,else) - (-> (if (@impl ->boolean (list (comp test e))) - (comp then e) - (comp else e)))) - ((if ,test ,then ,else) - (-> (if (@impl ->boolean (list (comp test e))) - (comp then e) - (@implv *undefined*)))) - ((postinc (ref ,foo)) - (begin1 (comp `(ref ,foo) e) - (lambda (var) - (-> (set (ghil-var-for-set! e foo) - (-> (inline 'add - (list (-> (ref var)) - (-> (quote 1)))))))))) - ((postinc (pref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (begin1 (@impl pget - (list (-> (ref objvar)) - (-> (quote prop)))) - (lambda (tmpvar) - (@impl pput - (list (-> (ref objvar)) - (-> (quote prop)) - (-> (inline 'add - (list (-> (ref tmpvar)) - (-> (quote 1)))))))))))) - ((postinc (aref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (let1 (comp prop e) - (lambda (propvar) - (begin1 (@impl pget - (list (-> (ref objvar)) - (-> (ref propvar)))) - (lambda (tmpvar) - (@impl pput - (list (-> (ref objvar)) - (-> (ref propvar)) - (-> (inline 'add - (list (-> (ref tmpvar)) - (-> (quote 1)))))))))))))) - ((postdec (ref ,foo)) - (begin1 (comp `(ref ,foo) e) - (lambda (var) - (-> (set (ghil-var-for-set! e foo) - (-> (inline 'sub - (list (-> (ref var)) - (-> (quote 1)))))))))) - ((postdec (pref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (begin1 (@impl pget - (list (-> (ref objvar)) - (-> (quote prop)))) - (lambda (tmpvar) - (@impl pput - (list (-> (ref objvar)) - (-> (quote prop)) - (-> (inline 'sub - (list (-> (ref tmpvar)) - (-> (quote 1)))))))))))) - ((postdec (aref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (let1 (comp prop e) - (lambda (propvar) - (begin1 (@impl pget - (list (-> (ref objvar)) - (-> (ref propvar)))) - (lambda (tmpvar) - (@impl pput - (list (-> (ref objvar)) - (-> (ref propvar)) - (-> (inline - 'sub (list (-> (ref tmpvar)) - (-> (quote 1)))))))))))))) - ((preinc (ref ,foo)) - (let ((v (ghil-var-for-set! e foo))) - (-> (begin - (list - (-> (set v - (-> (inline 'add - (list (-> (ref v)) - (-> (quote 1))))))) - (-> (ref v))))))) - ((preinc (pref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (begin1 (-> (inline 'add - (list (@impl pget - (list (-> (ref objvar)) - (-> (quote prop)))) - (-> (quote 1))))) - (lambda (tmpvar) - (@impl pput (list (-> (ref objvar)) - (-> (quote prop)) - (-> (ref tmpvar))))))))) - ((preinc (aref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (let1 (comp prop e) - (lambda (propvar) - (begin1 (-> (inline 'add - (list (@impl pget - (list (-> (ref objvar)) - (-> (ref propvar)))) - (-> (quote 1))))) - (lambda (tmpvar) - (@impl pput - (list (-> (ref objvar)) - (-> (ref propvar)) - (-> (ref tmpvar))))))))))) - ((predec (ref ,foo)) - (let ((v (ghil-var-for-set! e foo))) - (-> (begin - (list - (-> (set v - (-> (inline 'sub - (list (-> (ref v)) - (-> (quote 1))))))) - (-> (ref v))))))) - ((predec (pref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (begin1 (-> (inline 'sub - (list (@impl pget - (list (-> (ref objvar)) - (-> (quote prop)))) - (-> (quote 1))))) - (lambda (tmpvar) - (@impl pput - (list (-> (ref objvar)) - (-> (quote prop)) - (-> (ref tmpvar))))))))) - ((predec (aref ,obj ,prop)) - (let1 (comp obj e) - (lambda (objvar) - (let1 (comp prop e) - (lambda (propvar) - (begin1 (-> (inline 'sub - (list (@impl pget - (list (-> (ref objvar)) - (-> (ref propvar)))) - (-> (quote 1))))) - (lambda (tmpvar) - (@impl pput - (list (-> (ref objvar)) - (-> (ref propvar)) - (-> (ref tmpvar))))))))))) - ((ref ,id) - (-> (ref (ghil-var-for-ref! e id)))) - ((var . ,forms) - (-> (begin - (map (lambda (form) - (pmatch form - ((,x ,y) - (-> (define (ghil-var-define! (ghil-env-parent e) x) - (comp y e)))) - ((,x) - (-> (define (ghil-var-define! (ghil-env-parent e) x) - (@implv *undefined*)))) - (else (error "bad var form" form)))) - forms)))) - ((begin . ,forms) - (-> (begin - (map (lambda (x) (comp x e)) forms)))) - ((lambda ,formals ,body) - (call-with-ghil-environment e '(%args) - (lambda (e vars) - (-> (lambda vars #t '() - (comp-body env l body formals '%args)))))) - ((call/this ,obj ,prop ,args) - (@impl call/this* - (list obj - (-> (lambda '() #f '() - (-> (call (@impl pget (list obj prop)) - args))))))) - ((call (pref ,obj ,prop) ,args) - (comp `(call/this ,(comp obj e) - ,(-> (quote prop)) - ,(map (lambda (x) (comp x e)) args)) - e)) - ((call (aref ,obj ,prop) ,args) - (comp `(call/this ,(comp obj e) - ,(comp prop e) - ,(map (lambda (x) (comp x e)) args)) - e)) - ((call ,proc ,args) - (-> (call (comp proc e) - (map (lambda (x) (comp x e)) args)))) - ((return ,expr) - (-> (inline 'return - (list (comp expr e))))) - ((array . ,args) - (@impl new-array - (map (lambda (x) (comp x e)) args))) - ((object . ,args) - (@impl new-object - (map (lambda (x) - (pmatch x - ((,prop ,val) - (-> (inline 'cons - (list (-> (quote prop)) - (comp val e))))) - (else - (error "bad prop-val pair" x)))) - args))) - ((pref ,obj ,prop) - (@impl pget - (list (comp obj e) - (-> (quote prop))))) - ((aref ,obj ,index) - (@impl pget - (list (comp obj e) - (comp index e)))) - ((= (ref ,name) ,val) - (let ((v (ghil-var-for-set! e name))) - (-> (begin - (list (-> (set v (comp val e))) - (-> (ref v))))))) - ((= (pref ,obj ,prop) ,val) - (@impl pput - (list (comp obj e) - (-> (quote prop)) - (comp val e)))) - ((= (aref ,obj ,prop) ,val) - (@impl pput - (list (comp obj e) - (comp prop e) - (comp val e)))) - ((+= ,what ,val) - (comp `(= ,what (+ ,what ,val)) e)) - ((-= ,what ,val) - (comp `(= ,what (- ,what ,val)) e)) - ((/= ,what ,val) - (comp `(= ,what (/ ,what ,val)) e)) - ((*= ,what ,val) - (comp `(= ,what (* ,what ,val)) e)) - ((%= ,what ,val) - (comp `(= ,what (% ,what ,val)) e)) - ((>>= ,what ,val) - (comp `(= ,what (>> ,what ,val)) e)) - ((<<= ,what ,val) - (comp `(= ,what (<< ,what ,val)) e)) - ((>>>= ,what ,val) - (comp `(= ,what (>>> ,what ,val)) e)) - ((&= ,what ,val) - (comp `(= ,what (& ,what ,val)) e)) - ((bor= ,what ,val) - (comp `(= ,what (bor ,what ,val)) e)) - ((^= ,what ,val) - (comp `(= ,what (^ ,what ,val)) e)) - ((new ,what ,args) - (@impl new - (map (lambda (x) (comp x e)) - (cons what args)))) - ((delete (pref ,obj ,prop)) - (@impl pdel - (list (comp obj e) - (-> (quote prop))))) - ((delete (aref ,obj ,prop)) - (@impl pdel - (list (comp obj e) - (comp prop e)))) - ((void ,expr) - (-> (begin - (list (comp expr e) - (@implv *undefined*))))) - ((typeof ,expr) - (@impl typeof - (list (comp expr e)))) - ((do ,statement ,test) - (call-with-ghil-bindings e '(%loop %continue) - (lambda (vars) - (-> (bind vars - (list (call-with-ghil-environment e '() - (lambda (e _) - (-> (lambda '() #f '() - (-> (begin - (list (comp statement e) - (-> (call - (-> (ref (ghil-var-for-ref! e '%continue))) - '()))))))))) - (call-with-ghil-environment e '() - (lambda (e _) - (-> (lambda '() #f '() - (-> (if (@impl ->boolean (list (comp test e))) - (-> (call - (-> (ref (ghil-var-for-ref! e '%loop))) - '())) - (@implv *undefined*)))))))) - (-> (call (-> (ref (car vars))) '()))))))) - ((while ,test ,statement) - (call-with-ghil-bindings e '(%continue) - (lambda (vars) - (-> (begin - (list - (-> (set (car vars) - (call-with-ghil-environment e '() - (lambda (e _) - (-> (lambda '() #f '() - (-> (if (@impl ->boolean (list (comp test e))) - (-> (begin - (list (comp statement e) - (-> (call - (-> (ref (ghil-var-for-ref! e '%continue))) - '()))))) - (@implv *undefined*))))))))) - (-> (call (-> (ref (car vars))) '())))))))) - ((for ,init ,test ,inc ,statement) - (call-with-ghil-bindings e '(%continue) - (lambda (vars) - (-> (begin - (list - (comp (or init '(begin)) e) - (-> (set (car vars) - (call-with-ghil-environment e '() - (lambda (e _) - (-> (lambda '() #f '() - (-> (if (if test - (@impl ->boolean (list (comp test e))) - (comp 'true e)) - (-> (begin - (list (comp statement e) - (comp (or inc '(begin)) e) - (-> (call - (-> (ref (ghil-var-for-ref! e '%continue))) - '()))))) - (@implv *undefined*))))))))) - (-> (call (-> (ref (car vars))) '())))))))) - ((for-in ,var ,object ,statement) - (call-with-ghil-bindings e '(%continue %enum) - (lambda (vars) - (-> (begin - (list - (-> (set (car vars) - (call-with-ghil-environment e '() - (lambda (e _) - (-> (lambda '() #f '() - (-> (if (@impl ->boolean - (list (@impl pget - (list (-> (ref (ghil-var-for-ref! e '%enum))) - (-> (quote 'length)))))) - (-> (begin - (list - (comp `(= ,var (call/this ,(-> (ref (ghil-var-for-ref! e '%enum))) - ,(-> (quote 'pop)) - ())) - e) - (comp statement e) - (-> (call (-> (ref (ghil-var-for-ref! e '%continue))) - '()))))) - (@implv *undefined*))))))))) - (-> (set (cadr vars) - (@impl make-enumerator (list (comp object e))))) - (-> (call (-> (ref (car vars))) '())))))))) - ((break) - (let ((var (ghil-var-for-ref! e '%continue))) - (if (and (ghil-env? (ghil-var-env var)) - (eq? (ghil-var-env var) (ghil-env-parent e))) - (-> (inline 'return (@implv *undefined*))) - (error "bad break, yo")))) - ((continue) - (let ((var (ghil-var-for-ref! e '%continue))) - (if (and (ghil-env? (ghil-var-env var)) - (eq? (ghil-var-env var) (ghil-env-parent e))) - (-> (inline 'goto/args (list (-> (ref var))))) - (error "bad continue, yo")))) - ((block ,x) - (comp x e)) - (else - (error "compilation not yet implemented:" x))))) - -(define (comp-body e l body formals %args) - (define (process) - (let lp ((in body) (out '()) (rvars (reverse formals))) - (pmatch in - (((var (,x) . ,morevars) . ,rest) - (lp `((var . ,morevars) . ,rest) - out - (if (memq x rvars) rvars (cons x rvars)))) - (((var (,x ,y) . ,morevars) . ,rest) - (lp `((var . ,morevars) . ,rest) - `((= (ref ,x) ,y) . ,out) - (if (memq x rvars) rvars (cons x rvars)))) - (((var) . ,rest) - (lp rest out rvars)) - ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda))) - (lp rest - (cons x out) - rvars)) - ((,x . ,rest) (guard (pair? x)) - (receive (sub-out rvars) - (lp x '() rvars) - (lp rest - (cons sub-out out) - rvars))) - ((,x . ,rest) - (lp rest - (cons x out) - rvars)) - (() - (values (reverse! out) - rvars))))) - (receive (out rvars) - (process) - (call-with-ghil-bindings e (reverse rvars) - (lambda (vars) - (let ((%argv (assq-ref (ghil-env-table e) %args))) - (-> (begin - `(,@(map - (lambda (f) - (-> (if (-> (inline 'null? - (list (-> (ref %argv))))) - (-> (begin '())) - (-> (begin - (list (-> (set (ghil-var-for-ref! e f) - (-> (inline 'car - (list (-> (ref %argv))))))) - (-> (set %argv - (-> (inline 'cdr - (list (-> (ref %argv))))))))))))) - formals) - ;; fixme: here check for too many args - ,(comp out e))))))))) diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm new file mode 100644 index 000000000..88f3db76f --- /dev/null +++ b/module/language/ecmascript/compile-tree-il.scm @@ -0,0 +1,549 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript compile-tree-il) + #:use-module (language tree-il) + #:use-module (ice-9 receive) + #:use-module (system base pmatch) + #:use-module (srfi srfi-1) + #:export (compile-tree-il)) + +(define-syntax -> + (syntax-rules () + ((_ (type arg ...)) + `(type ,arg ...)))) + +(define-syntax @implv + (syntax-rules () + ((_ sym) + (-> (module-ref '(language ecmascript impl) 'sym #t))))) + +(define-syntax @impl + (syntax-rules () + ((_ sym arg ...) + (-> (apply (@implv sym) arg ...))))) + +(define (empty-lexical-environment) + '()) + +(define (econs name gensym env) + (acons name gensym env)) + +(define (lookup name env) + (or (assq-ref env name) + (-> (toplevel name)))) + +(define (compile-tree-il exp env opts) + (values + (parse-tree-il (comp exp (empty-lexical-environment))) + env + env)) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + +;; for emacs: +;; (put 'pmatch/source 'scheme-indent-function 1) + +(define-syntax pmatch/source + (syntax-rules () + ((_ x clause ...) + (let ((x x)) + (let ((res (pmatch x + clause ...))) + (let ((loc (location x))) + (if loc + (set-source-properties! res (location x)))) + res))))) + +(define (comp x e) + (let ((l (location x))) + (define (let1 what proc) + (let ((sym (gensym))) + (-> (let (list sym) (list sym) (list what) + (proc sym))))) + (define (begin1 what proc) + (let1 what (lambda (v) + (-> (begin (proc v) + (-> (lexical v v))))))) + (pmatch/source x + (null + ;; FIXME, null doesn't have much relation to EOL... + (-> (const '()))) + (true + (-> (const #t))) + (false + (-> (const #f))) + ((number ,num) + (-> (const num))) + ((string ,str) + (-> (const str))) + (this + (@impl get-this '())) + ((+ ,a) + (-> (apply (-> (primitive '+)) + (@impl ->number (comp a e)) + (-> (const 0))))) + ((- ,a) + (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e)))) + ((~ ,a) + (@impl bitwise-not (comp a e))) + ((! ,a) + (@impl logical-not (comp a e))) + ((+ ,a ,b) + (-> (apply (-> (primitive '+)) (comp a e) (comp b e)))) + ((- ,a ,b) + (-> (apply (-> (primitive '-)) (comp a e) (comp b e)))) + ((/ ,a ,b) + (-> (apply (-> (primitive '/)) (comp a e) (comp b e)))) + ((* ,a ,b) + (-> (apply (-> (primitive '*)) (comp a e) (comp b e)))) + ((% ,a ,b) + (@impl mod (comp a e) (comp b e))) + ((<< ,a ,b) + (@impl shift (comp a e) (comp b e))) + ((>> ,a ,b) + (@impl shift (comp a e) (comp `(- ,b) e))) + ((< ,a ,b) + (-> (apply (-> (primitive '<)) (comp a e) (comp b e)))) + ((<= ,a ,b) + (-> (apply (-> (primitive '<=)) (comp a e) (comp b e)))) + ((> ,a ,b) + (-> (apply (-> (primitive '>)) (comp a e) (comp b e)))) + ((>= ,a ,b) + (-> (apply (-> (primitive '>=)) (comp a e) (comp b e)))) + ((in ,a ,b) + (@impl has-property? (comp a e) (comp b e))) + ((== ,a ,b) + (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e)))) + ((!= ,a ,b) + (-> (apply (-> (primitive 'not)) + (-> (apply (-> (primitive 'equal?)) + (comp a e) (comp b e)))))) + ((=== ,a ,b) + (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e)))) + ((!== ,a ,b) + (-> (apply (-> (primitive 'not)) + (-> (apply (-> (primitive 'eqv?)) + (comp a e) (comp b e)))))) + ((& ,a ,b) + (@impl band (comp a e) (comp b e))) + ((^ ,a ,b) + (@impl bxor (comp a e) (comp b e))) + ((bor ,a ,b) + (@impl bior (comp a e) (comp b e))) + ((and ,a ,b) + (-> (if (@impl ->boolean (comp a e)) + (comp b e) + (-> (const #f))))) + ((or ,a ,b) + (let1 (comp a e) + (lambda (v) + (-> (if (@impl ->boolean (-> (lexical v v))) + (-> (lexical v v)) + (comp b e)))))) + ((if ,test ,then ,else) + (-> (if (@impl ->boolean (comp test e)) + (comp then e) + (comp else e)))) + ((if ,test ,then ,else) + (-> (if (@impl ->boolean (comp test e)) + (comp then e) + (@implv *undefined*)))) + ((postinc (ref ,foo)) + (begin1 (comp `(ref ,foo) e) + (lambda (var) + (-> (set! (lookup foo e) + (-> (apply (-> (primitive '+)) + (-> (lexical var var)) + (-> (const 1))))))))) + ((postinc (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (apply (-> (primitive '+)) + (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))) + ((postinc (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (apply (-> (primitive '+)) + (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))))) + ((postdec (ref ,foo)) + (begin1 (comp `(ref ,foo) e) + (lambda (var) + (-> (set (lookup foo e) + (-> (apply (-> (primitive '-)) + (-> (lexical var var)) + (-> (const 1))))))))) + ((postdec (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (apply (-> (primitive '-)) + (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))) + ((postdec (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (inline + '- (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))))) + ((preinc (ref ,foo)) + (let ((v (lookup foo e))) + (-> (begin + (-> (set! v + (-> (apply (-> (primitive '+)) + v + (-> (const 1)))))) + v)))) + ((preinc (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (-> (apply (-> (primitive '+)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (lexical tmpvar tmpvar)))))))) + ((preinc (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (-> (apply (-> (primitive '+)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (lexical tmpvar tmpvar)))))))))) + ((predec (ref ,foo)) + (let ((v (lookup foo e))) + (-> (begin + (-> (set! v + (-> (apply (-> (primitive '-)) + v + (-> (const 1)))))) + v)))) + ((predec (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (-> (apply (-> (primitive '-)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (lexical tmpvar tmpvar)))))))) + ((predec (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (-> (apply (-> (primitive '-)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (lexical tmpvar tmpvar)))))))))) + ((ref ,id) + (lookup id e)) + ((var . ,forms) + (-> (begin + (map (lambda (form) + (pmatch form + ((,x ,y) + (-> (define x (comp y e)))) + ((,x) + (-> (define x (@implv *undefined*)))) + (else (error "bad var form" form)))) + forms)))) + ((begin . ,forms) + `(begin ,@(map (lambda (x) (comp x e)) forms))) + ((lambda ,formals ,body) + (let ((%args (gensym "%args "))) + (-> (lambda '%args %args '() + (comp-body (econs '%args %args e) body formals '%args))))) + ((call/this ,obj ,prop . ,args) + (@impl call/this* + obj + (-> (lambda '() '() '() + `(apply ,(@impl pget obj prop) ,@args))))) + ((call (pref ,obj ,prop) ,args) + (comp `(call/this ,(comp obj e) + ,(-> (const prop)) + ,@(map (lambda (x) (comp x e)) args)) + e)) + ((call (aref ,obj ,prop) ,args) + (comp `(call/this ,(comp obj e) + ,(comp prop e) + ,@(map (lambda (x) (comp x e)) args)) + e)) + ((call ,proc ,args) + `(apply ,(comp proc e) + ,@(map (lambda (x) (comp x e)) args))) + ((return ,expr) + (-> (apply (-> (primitive 'return)) + (comp expr e)))) + ((array . ,args) + `(apply ,(@implv new-array) + ,@(map (lambda (x) (comp x e)) args))) + ((object . ,args) + (@impl new-object + (map (lambda (x) + (pmatch x + ((,prop ,val) + (-> (apply (-> (primitive 'cons)) + (-> (const prop)) + (comp val e)))) + (else + (error "bad prop-val pair" x)))) + args))) + ((pref ,obj ,prop) + (@impl pget + (comp obj e) + (-> (const prop)))) + ((aref ,obj ,index) + (@impl pget + (comp obj e) + (comp index e))) + ((= (ref ,name) ,val) + (let ((v (lookup name e))) + (-> (begin + (-> (set! v (comp val e))) + v)))) + ((= (pref ,obj ,prop) ,val) + (@impl pput + (comp obj e) + (-> (const prop)) + (comp val e))) + ((= (aref ,obj ,prop) ,val) + (@impl pput + (comp obj e) + (comp prop e) + (comp val e))) + ((+= ,what ,val) + (comp `(= ,what (+ ,what ,val)) e)) + ((-= ,what ,val) + (comp `(= ,what (- ,what ,val)) e)) + ((/= ,what ,val) + (comp `(= ,what (/ ,what ,val)) e)) + ((*= ,what ,val) + (comp `(= ,what (* ,what ,val)) e)) + ((%= ,what ,val) + (comp `(= ,what (% ,what ,val)) e)) + ((>>= ,what ,val) + (comp `(= ,what (>> ,what ,val)) e)) + ((<<= ,what ,val) + (comp `(= ,what (<< ,what ,val)) e)) + ((>>>= ,what ,val) + (comp `(= ,what (>>> ,what ,val)) e)) + ((&= ,what ,val) + (comp `(= ,what (& ,what ,val)) e)) + ((bor= ,what ,val) + (comp `(= ,what (bor ,what ,val)) e)) + ((^= ,what ,val) + (comp `(= ,what (^ ,what ,val)) e)) + ((new ,what ,args) + (@impl new + (map (lambda (x) (comp x e)) + (cons what args)))) + ((delete (pref ,obj ,prop)) + (@impl pdel + (comp obj e) + (-> (const prop)))) + ((delete (aref ,obj ,prop)) + (@impl pdel + (comp obj e) + (comp prop e))) + ((void ,expr) + (-> (begin + (comp expr e) + (@implv *undefined*)))) + ((typeof ,expr) + (@impl typeof + (comp expr e))) + ((do ,statement ,test) + (let ((%loop (gensym "%loop ")) + (%continue (gensym "%continue "))) + (let ((e (econs '%loop %loop (econs '%continue %continue e)))) + (-> (letrec '(%loop %continue) (list %loop %continue) + (list (-> (lambda '() '() '() + (-> (begin + (comp statement e) + (-> (apply (-> (lexical '%continue %continue))) + ))))) + + (-> (lambda '() '() '() + (-> (if (@impl ->boolean (comp test e)) + (-> (apply (-> (lexical '%loop %loop)))) + (@implv *undefined*)))))) + (-> (apply (-> (lexical '%loop %loop))))))))) + ((while ,test ,statement) + (let ((%continue (gensym "%continue "))) + (let ((e (econs '%continue %continue e))) + (-> (letrec '(%continue) (list %continue) + (list (-> (lambda '() '() '() + (-> (if (@impl ->boolean (comp test e)) + (-> (begin (comp statement e) + (-> (apply (-> (lexical '%continue %continue)))))) + (@implv *undefined*)))))) + (-> (apply (-> (lexical '%continue %continue))))))))) + + ((for ,init ,test ,inc ,statement) + (let ((%continue (gensym "%continue "))) + (let ((e (econs '%continue %continue e))) + (-> (letrec '(%continue) (list %continue) + (list (-> (lambda '() '() '() + (-> (if (if test + (@impl ->boolean (comp test e)) + (comp 'true e)) + (-> (begin (comp statement e) + (comp (or inc '(begin)) e) + (-> (apply (-> (lexical '%continue %continue)))))) + (@implv *undefined*)))))) + (-> (begin (comp (or init '(begin)) e) + (-> (apply (-> (lexical '%continue %continue))))))))))) + + ((for-in ,var ,object ,statement) + (let ((%enum (gensym "%enum ")) + (%continue (gensym "%continue "))) + (let ((e (econs '%enum %enum (econs '%continue %continue e)))) + (-> (letrec '(%enum %continue) (list %enum %continue) + (list (@impl make-enumerator (comp object e)) + (-> (lambda '() '() '() + (-> (if (@impl ->boolean + (@impl pget + (-> (lexical '%enum %enum)) + (-> (const 'length)))) + (-> (begin + (comp `(= ,var (call/this ,(-> (lexical '%enum %enum)) + ,(-> (const 'pop)))) + e) + (comp statement e) + (-> (apply (-> (lexical '%continue %continue)))))) + (@implv *undefined*)))))) + (-> (apply (-> (lexical '%continue %continue))))))))) + + ((block ,x) + (comp x e)) + (else + (error "compilation not yet implemented:" x))))) + +(define (comp-body e body formals %args) + (define (process) + (let lp ((in body) (out '()) (rvars (reverse formals))) + (pmatch in + (((var (,x) . ,morevars) . ,rest) + (lp `((var . ,morevars) . ,rest) + out + (if (memq x rvars) rvars (cons x rvars)))) + (((var (,x ,y) . ,morevars) . ,rest) + (lp `((var . ,morevars) . ,rest) + `((= (ref ,x) ,y) . ,out) + (if (memq x rvars) rvars (cons x rvars)))) + (((var) . ,rest) + (lp rest out rvars)) + ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda))) + (lp rest + (cons x out) + rvars)) + ((,x . ,rest) (guard (pair? x)) + (receive (sub-out rvars) + (lp x '() rvars) + (lp rest + (cons sub-out out) + rvars))) + ((,x . ,rest) + (lp rest + (cons x out) + rvars)) + (() + (values (reverse! out) + rvars))))) + (receive (out rvars) + (process) + (let* ((names (reverse rvars)) + (syms (map (lambda (x) + (gensym (string-append (symbol->string x) " "))) + names)) + (e (fold acons e names syms))) + (let ((%argv (lookup %args e))) + (let lp ((names names) (syms syms)) + (if (null? names) + ;; fixme: here check for too many args + (comp out e) + (-> (let (list (car names)) (list (car syms)) + (list (-> (if (-> (apply (-> (primitive 'null?)) %argv)) + (-> (@implv *undefined*)) + (-> (let1 (-> (apply (-> (primitive 'car)) %argv)) + (lambda (v) + (-> (set! %argv + (-> (apply (-> (primitive 'cdr)) %argv)))) + (-> (lexical v v)))))))) + (lp (cdr names) (cdr syms)))))))))) diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm index 6e9470f38..7a1ea465c 100644 --- a/module/language/ecmascript/spec.scm +++ b/module/language/ecmascript/spec.scm @@ -21,7 +21,7 @@ (define-module (language ecmascript spec) #:use-module (system base language) #:use-module (language ecmascript parse) - #:use-module (language ecmascript compile-ghil) + #:use-module (language ecmascript compile-tree-il) #:export (ecmascript)) ;;; @@ -32,7 +32,7 @@ #:title "Guile ECMAScript" #:version "3.0" #:reader (lambda () (read-ecmascript/1 (current-input-port))) - #:compilers `((ghil . ,compile-ghil)) + #:compilers `((tree-il . ,compile-tree-il)) ;; a pretty-printer would be interesting. #:printer write ) diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm index 63f180b14..1b6a7eeaf 100644 --- a/module/language/ecmascript/tokenize.scm +++ b/module/language/ecmascript/tokenize.scm @@ -365,7 +365,7 @@ . ,(cdar puncs)))))) (lp nodes (cdr puncs)))) (else - (lp (cons `(,(string-ref (caar puncs) 0) #f) nodes) + (lp (cons (list (string-ref (caar puncs) 0) #f) nodes) puncs)))))) (lambda (port) (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f)) From 30a6b9caa909841526bde84584173fb16f4c7e05 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Tue, 11 Aug 2009 21:12:52 -0700 Subject: [PATCH 350/375] Only pass ints to tolower and toupper * libguile/strings.c (unistring_escapes_to_guile_escapes): cast tolower's parameter to int * libguile/read.c (CHAR_DOWNCASE): cast tolower's parameter to int --- libguile/read.c | 2 +- libguile/strings.c | 16 ++++++++-------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 577a73e58..8efac67af 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -179,7 +179,7 @@ static SCM *scm_read_hash_procedures; /* An inlinable version of `scm_c_downcase ()'. */ #define CHAR_DOWNCASE(_chr) \ - (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr)) + (((_chr) <= UCHAR_MAX) ? tolower ((int) (_chr)) : (_chr)) /* Read an SCSH block comment. */ diff --git a/libguile/strings.c b/libguile/strings.c index c3ea8b8de..437cedcac 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1427,8 +1427,8 @@ unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp) /* Convert \u00NN to \xNN */ after[j] = '\\'; after[j + 1] = 'x'; - after[j + 2] = tolower (before[i + 4]); - after[j + 3] = tolower (before[i + 5]); + after[j + 2] = tolower ((int) before[i + 4]); + after[j + 3] = tolower ((int) before[i + 5]); i += 6; j += 4; } @@ -1440,12 +1440,12 @@ unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp) /* Convert \U00NNNNNN to \UNNNNNN */ after[j] = '\\'; after[j + 1] = 'U'; - after[j + 2] = tolower (before[i + 4]); - after[j + 3] = tolower (before[i + 5]); - after[j + 4] = tolower (before[i + 6]); - after[j + 5] = tolower (before[i + 7]); - after[j + 6] = tolower (before[i + 8]); - after[j + 7] = tolower (before[i + 9]); + after[j + 2] = tolower ((int) before[i + 4]); + after[j + 3] = tolower ((int) before[i + 5]); + after[j + 4] = tolower ((int) before[i + 6]); + after[j + 5] = tolower ((int) before[i + 7]); + after[j + 6] = tolower ((int) before[i + 8]); + after[j + 7] = tolower ((int) before[i + 9]); i += 10; j += 8; } From 4cd00cc6b2ae47f39b8470325aecb776801b57df Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Tue, 11 Aug 2009 21:27:20 -0700 Subject: [PATCH 351/375] Revert to locale-dependent toupper and tolower To avoid leaving Guile in a broken state, the conversion from locale-dependent case modification to Unicode case modification should be an atomic commit * libguile/chars.c (scm_c_upcase): revert to locale-dependent toupper and tolower --- libguile/chars.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index 2103c540c..56239f597 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -296,14 +296,20 @@ TODO: change name to scm_i_.. ? --hwn scm_t_wchar scm_c_upcase (scm_t_wchar c) { - return uc_toupper (c); + if (c > 255) + return c; + + return toupper ((int) c); } scm_t_wchar scm_c_downcase (scm_t_wchar c) { - return uc_tolower (c); + if (c > 255) + return c; + + return tolower ((int) c); } From 9909c3956ae653488657c5909547dfd4b97557cc Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Tue, 11 Aug 2009 22:01:20 -0700 Subject: [PATCH 352/375] Avoid unitialized and unused warnings in scm_string_append * libguile/strings.c (scm_string_append): avoid warnings --- libguile/strings.c | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index 437cedcac..74cebd69b 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1297,9 +1297,12 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, size_t len = 0; int wide = 0; SCM l, s; - char *data; - scm_t_wchar *wdata; int i; + union + { + char *narrow; + scm_t_wchar *wide; + } data; SCM_VALIDATE_REST_ARGUMENT (args); for (l = args; !scm_is_null (l); l = SCM_CDR (l)) @@ -1310,10 +1313,11 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, if (!scm_i_is_narrow_string (s)) wide = 1; } + data.narrow = NULL; if (!wide) - res = scm_i_make_string (len, &data); + res = scm_i_make_string (len, &data.narrow); else - res = scm_i_make_wide_string (len, &wdata); + res = scm_i_make_wide_string (len, &data.wide); for (l = args; !scm_is_null (l); l = SCM_CDR (l)) { @@ -1323,20 +1327,20 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, len = scm_i_string_length (s); if (!wide) { - memcpy (data, scm_i_string_chars (s), len); - data += len; + memcpy (data.narrow, scm_i_string_chars (s), len); + data.narrow += len; } else { if (scm_i_is_narrow_string (s)) { for (i = 0; i < scm_i_string_length (s); i++) - wdata[i] = (unsigned char) scm_i_string_chars (s)[i]; + data.wide[i] = (unsigned char) scm_i_string_chars (s)[i]; } else - u32_cpy ((scm_t_uint32 *) wdata, + u32_cpy ((scm_t_uint32 *) data.wide, (scm_t_uint32 *) scm_i_string_wide_chars (s), len); - wdata += len; + data.wide += len; } scm_remember_upto_here_1 (s); } From 744c8724a7060abb7ad749f4db7eadb342184572 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Tue, 11 Aug 2009 22:52:49 -0700 Subject: [PATCH 353/375] Quiet signed/unsigned comparison warnings in chars.[ch] * libguile/chars.h (SCM_MAKE_CHAR): quiet signed/unsigned comparison warnings * libguile/chars.c (scm_i_charname): (scm_i_charname_to_char): quiet signed/unsigned comparison warnings --- libguile/chars.c | 4 ++-- libguile/chars.h | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index 56239f597..552a2d9c1 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -363,7 +363,7 @@ static const scm_t_uint32 const scm_alt_charnums[] = { const char * scm_i_charname (SCM chr) { - int c; + size_t c; scm_t_uint32 i = SCM_CHAR (chr); for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++) @@ -385,7 +385,7 @@ scm_i_charname (SCM chr) SCM scm_i_charname_to_char (const char *charname, size_t charname_len) { - int c; + size_t c; /* The R5RS charnames. These are supposed to be case insensitive. */ diff --git a/libguile/chars.h b/libguile/chars.h index e016cb28e..51adc21e5 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -32,9 +32,9 @@ #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char) #define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x)) -#define SCM_MAKE_CHAR(x) \ - ((x) < 0 \ - ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \ +#define SCM_MAKE_CHAR(x) \ + ((scm_t_int32) (x) < 0 \ + ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \ : SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char)) #define SCM_CODEPOINT_MAX (0x10ffff) From 6cf48307989d2552f2215ef8406ea92745d2d3e9 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Wed, 12 Aug 2009 00:26:12 -0700 Subject: [PATCH 354/375] Fix disassembly of strings and symbols * module/language/assembly/decompile-bytecode.scm (decode-bytecode): fix disassembly of strings, symbols, keywords, and defines --- .../language/assembly/decompile-bytecode.scm | 24 +++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index 0e34ab4a2..a05db537d 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -24,6 +24,7 @@ #:use-module (srfi srfi-4) #:use-module (rnrs bytevector) #:use-module (language assembly) + #:use-module ((system vm objcode) #:select (byte-order)) #:export (decompile-bytecode)) (define (decompile-bytecode x env opts) @@ -95,13 +96,26 @@ (lp (cons exp out)))))))))) (define (decode-bytecode pop) + (define (get1 bytes-per-char) + (if (= bytes-per-char 1) + (pop) + (let* ((a (pop)) + (b (pop)) + (c (pop)) + (d (pop))) + (if (= byte-order 1234) + (+ (ash d 24) (ash c 16) (ash b 8) a) + (+ (ash a 24) (ash b 16) (ash c 8) d))))) (and=> (pop) (lambda (opcode) (let ((inst (opcode->instruction opcode))) (cond ((eq? inst 'load-program) (decode-load-program pop)) + ((< (instruction-length inst) 0) + ;; the negative length indicates a variable length + ;; instruction (let* ((make-sequence (if (eq? inst 'load-array) make-bytevector @@ -111,15 +125,21 @@ bytevector-u8-set! (lambda (str pos value) (string-set! str pos (integer->char value))))) - (len (let* ((a (pop)) (b (pop)) (c (pop))) (+ (ash a 16) (ash b 8) c))) + (bytes-per-count + (if (or (eq? inst 'load-string) + (eq? inst 'load-symbol) + (eq? inst 'load-keyword) + (eq? inst 'define)) + (pop) + 1)) (seq (make-sequence len))) (let lp ((i 0)) (if (= i len) `(,inst ,seq) (begin - (sequence-set! seq i (pop)) + (sequence-set! seq i (get1 bytes-per-count)) (lp (1+ i))))))) (else ;; fixed length From 94ff26b96b555f0263fab2221cd55801119ffddd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 12 Aug 2009 16:33:49 +0200 Subject: [PATCH 355/375] rework the vm support for wide strings * libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump. * libguile/vm-engine.c (vm_error_bad_wide_string_length): New error case. * libguile/vm-i-loader.c (load-unsigned-integer, load-integer) (load-keyword): Remove these instructions. The former two are obsoleted by make-int64/make-uint64, the latter via make-keyword. (load-string): Only handle narrow strings. (load-symbol): Only handle narrow symbols. The wide case is handled via make-symbol. (load-wide-string): New instruction, for wide strings. * libguile/vm-i-system.c (define): Move here from loaders.c, as now it just takes a sym on the stack. (make-keyword, make-symbol): New instructions. * module/language/assembly.scm: Remove removed instructions. No more width byte in load-string etc. * module/language/assembly/compile-bytecode.scm (write-bytecode): Adapt to change in instruction set. * module/language/glil/compile-assembly.scm (glil->assembly): Compile define by pushing the sym then emitting (define). (dump-object): Dump narrow and wide strings differently. Use make-keyword and make-symbol as appropriate. * module/language/tree-il/compile-glil.scm (flatten): When compiling a ref to a primitive (not a call), first see if the primitive is actually bound in the root module. (That's not the case with e.g. bytevector-u8-ref). * module/system/xref.scm (program-callee-rev-vars): Don't parse out "nexts". * test-suite/tests/asm-to-bytecode.test ("compiler"): Adapt to bytecode format change. --- libguile/_scm.h | 2 +- libguile/vm-engine.c | 4 + libguile/vm-i-loader.c | 157 +++--------------- libguile/vm-i-system.c | 28 ++++ module/language/assembly.scm | 18 +- module/language/assembly/compile-bytecode.scm | 19 +-- .../language/assembly/decompile-bytecode.scm | 27 +-- module/language/glil/compile-assembly.scm | 19 ++- module/language/tree-il/compile-glil.scm | 9 +- module/system/xref.scm | 2 +- test-suite/tests/asm-to-bytecode.test | 17 +- 11 files changed, 101 insertions(+), 201 deletions(-) diff --git a/libguile/_scm.h b/libguile/_scm.h index ff16a8587..737e01edd 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -172,7 +172,7 @@ // major and minor versions must be single characters #define SCM_OBJCODE_MAJOR_VERSION 0 -#define SCM_OBJCODE_MINOR_VERSION A +#define SCM_OBJCODE_MINOR_VERSION B #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 98a6e491b..b0888c1ec 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -220,6 +220,10 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) finish_args = SCM_EOL; goto vm_error; + vm_error_bad_wide_string_length: + err_msg = scm_from_locale_string ("VM: Bad wide string length: ~S"); + goto vm_error; + #if VM_CHECK_IP vm_error_invalid_address: err_msg = scm_from_locale_string ("VM: Invalid program address"); diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 8de7f0036..e242ef9bf 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -20,42 +20,6 @@ /* This file is included in vm_engine.c */ -VM_DEFINE_LOADER (80, load_unsigned_integer, "load-unsigned-integer") -{ - size_t len; - - FETCH_LENGTH (len); - if (SCM_LIKELY (len <= 8)) - { - scm_t_uint64 val = 0; - while (len-- > 0) - val = (val << 8U) + FETCH (); - SYNC_REGISTER (); - PUSH (scm_from_uint64 (val)); - NEXT; - } - else - SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL); -} - -VM_DEFINE_LOADER (81, load_integer, "load-integer") -{ - size_t len; - - FETCH_LENGTH (len); - if (SCM_LIKELY (len <= 4)) - { - int val = 0; - while (len-- > 0) - val = (val << 8) + FETCH (); - SYNC_REGISTER (); - PUSH (scm_from_int (val)); - NEXT; - } - else - SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL); -} - VM_DEFINE_LOADER (82, load_number, "load-number") { size_t len; @@ -72,82 +36,24 @@ VM_DEFINE_LOADER (82, load_number, "load-number") VM_DEFINE_LOADER (83, load_string, "load-string") { size_t len; - int width; - SCM str; + char *buf; FETCH_LENGTH (len); - FETCH_WIDTH (width); SYNC_REGISTER (); - if (width == 1) - { - char *buf; - str = scm_i_make_string (len, &buf); - memcpy (buf, (char *) ip, len); - } - else if (width == 4) - { - scm_t_wchar *wbuf; - str = scm_i_make_wide_string (len, &wbuf); - memcpy ((char *) wbuf, (char *) ip, len * width); - } - else - SCM_MISC_ERROR ("load-string: invalid character width", SCM_EOL); - PUSH (str); - ip += len * width; + PUSH (scm_i_make_string (len, &buf)); + memcpy (buf, (char *) ip, len); + ip += len; NEXT; } VM_DEFINE_LOADER (84, load_symbol, "load-symbol") { size_t len; - int width; - SCM str; FETCH_LENGTH (len); - FETCH_WIDTH (width); SYNC_REGISTER (); - if (width == 1) - { - char *buf; - str = scm_i_make_string (len, &buf); - memcpy (buf, (char *) ip, len); - } - else if (width == 4) - { - scm_t_wchar *wbuf; - str = scm_i_make_wide_string (len, &wbuf); - memcpy ((char *) wbuf, (char *) ip, len * width); - } - else - SCM_MISC_ERROR ("load-symbol: invalid character width", SCM_EOL); - PUSH (scm_string_to_symbol (str)); - ip += len * width; - NEXT; -} - -VM_DEFINE_LOADER (85, load_keyword, "load-keyword") -{ - size_t len; - int width; - SCM str; - FETCH_LENGTH (len); - FETCH_WIDTH (width); - SYNC_REGISTER (); - if (width == 1) - { - char *buf; - str = scm_i_make_string (len, &buf); - memcpy (buf, (char *) ip, len); - } - else if (width == 4) - { - scm_t_wchar *wbuf; - str = scm_i_make_wide_string (len, &wbuf); - memcpy ((char *) wbuf, (char *) ip, len * width); - } - else - SCM_MISC_ERROR ("load-keyword: invalid character width", SCM_EOL); - PUSH (scm_symbol_to_keyword (scm_string_to_symbol (str))); - ip += len * width; + /* FIXME: should be scm_from_latin1_symboln */ + PUSH (scm_from_locale_symboln ((const char*)ip, len)); + ip += len; NEXT; } @@ -181,37 +87,6 @@ VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1) NEXT; } -VM_DEFINE_LOADER (88, define, "define") -{ - SCM str, sym; - size_t len; - - int width; - FETCH_LENGTH (len); - FETCH_WIDTH (width); - SYNC_REGISTER (); - if (width == 1) - { - char *buf; - str = scm_i_make_string (len, &buf); - memcpy (buf, (char *) ip, len); - } - else if (width == 4) - { - scm_t_wchar *wbuf; - str = scm_i_make_wide_string (len, &wbuf); - memcpy ((char *) wbuf, (char *) ip, len * width); - } - else - SCM_MISC_ERROR ("load define: invalid character width", SCM_EOL); - sym = scm_string_to_symbol (str); - ip += len * width; - - SYNC_REGISTER (); - PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T)); - NEXT; -} - VM_DEFINE_LOADER (89, load_array, "load-array") { SCM type, shape; @@ -225,6 +100,24 @@ VM_DEFINE_LOADER (89, load_array, "load-array") NEXT; } +VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string") +{ + size_t len; + scm_t_wchar *wbuf; + + FETCH_LENGTH (len); + if (SCM_UNLIKELY (len % 4)) + { finish_args = scm_list_1 (scm_from_size_t (len)); + goto vm_error_bad_wide_string_length; + } + + SYNC_REGISTER (); + PUSH (scm_i_make_wide_string (len / 4, &wbuf)); + memcpy ((char *) wbuf, (char *) ip, len); + ip += len; + NEXT; +} + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 9604ce55a..b298c88a6 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1246,6 +1246,34 @@ VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (66, define, "define", 0, 0, 2) +{ + SCM sym, val; + POP (sym); + POP (val); + SYNC_REGISTER (); + VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (), + SCM_BOOL_T), + val); + NEXT; +} + +VM_DEFINE_INSTRUCTION (67, make_keyword, "make-keyword", 0, 1, 1) +{ + CHECK_UNDERFLOW (); + SYNC_REGISTER (); + *sp = scm_symbol_to_keyword (*sp); + NEXT; +} + +VM_DEFINE_INSTRUCTION (68, make_symbol, "make-symbol", 0, 1, 1) +{ + CHECK_UNDERFLOW (); + SYNC_REGISTER (); + *sp = scm_string_to_symbol (*sp); + NEXT; +} + /* (defun renumber-ops () diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 5571bee61..683da6cc1 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -34,30 +34,21 @@ ;; lengths are encoded in 3 bytes (define *len-len* 3) -;; the number of bytes per string character is encoded in 1 byte -(define *width-len* 1) - (define (byte-length assembly) (pmatch assembly (,label (guard (not (pair? label))) 0) - ((load-unsigned-integer ,str) - (+ 1 *len-len* (string-length str))) - ((load-integer ,str) - (+ 1 *len-len* (string-length str))) ((load-number ,str) (+ 1 *len-len* (string-length str))) ((load-string ,str) - (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) + (+ 1 *len-len* (string-length str))) + ((load-wide-string ,str) + (+ 1 *len-len* (* 4 (string-length str)))) ((load-symbol ,str) - (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) - ((load-keyword ,str) - (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) + (+ 1 *len-len* (string-length str))) ((load-array ,bv) (+ 1 *len-len* (bytevector-length bv))) - ((define ,str) - (+ 1 *len-len* *width-len* (* (string-width str) (string-length str)))) ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) ((,inst . _) (guard (>= (instruction-length inst) 0)) @@ -171,5 +162,4 @@ n4))) ((load-string ,s) s) ((load-symbol ,s) (string->symbol s)) - ((load-keyword ,s) (symbol->keyword (string->symbol s))) (else #f))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 840c73b3a..c49c20081 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -65,11 +65,13 @@ (write-byte (logand (ash x -8) 255)) (write-byte (logand (ash x -16) 255)) (write-byte (logand (ash x -24) 255))) - (define (write-uint32 x) (case byte-order - ((1234) (write-uint32-le x)) - ((4321) (write-uint32-be x)) - (else (error "unknown endianness" byte-order)))) + (define (write-uint32 x) + (case byte-order + ((1234) (write-uint32-le x)) + ((4321) (write-uint32-be x)) + (else (error "unknown endianness" byte-order)))) (define (write-wide-string s) + (write-loader-len (* 4 (string-length s))) (string-for-each (lambda (c) (write-uint32 (char->integer c))) s)) (define (write-loader-len len) (write-byte (ash len -16)) @@ -133,14 +135,11 @@ ;; `scm_c_make_objcode_slice ()'. (write-bytecode meta write get-addr '())))) ((make-char32 ,x) (write-uint32-be x)) - ((load-unsigned-integer ,str) (write-loader str)) - ((load-integer ,str) (write-loader str)) ((load-number ,str) (write-loader str)) - ((load-string ,str) (write-sized-loader str)) - ((load-symbol ,str) (write-sized-loader str)) - ((load-keyword ,str) (write-sized-loader str)) + ((load-string ,str) (write-loader str)) + ((load-wide-string ,str) (write-wide-string str)) + ((load-symbol ,str) (write-loader str)) ((load-array ,bv) (write-bytevector bv)) - ((define ,str) (write-sized-loader str)) ((br ,l) (write-break l)) ((br-if ,l) (write-break l)) ((br-if-not ,l) (write-break l)) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index a05db537d..8cdebcfd0 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -96,16 +96,6 @@ (lp (cons exp out)))))))))) (define (decode-bytecode pop) - (define (get1 bytes-per-char) - (if (= bytes-per-char 1) - (pop) - (let* ((a (pop)) - (b (pop)) - (c (pop)) - (d (pop))) - (if (= byte-order 1234) - (+ (ash d 24) (ash c 16) (ash b 8) a) - (+ (ash a 24) (ash b 16) (ash c 8) d))))) (and=> (pop) (lambda (opcode) (let ((inst (opcode->instruction opcode))) @@ -117,29 +107,24 @@ ;; the negative length indicates a variable length ;; instruction (let* ((make-sequence - (if (eq? inst 'load-array) + (if (or (memq inst '(load-array load-wide-string))) make-bytevector make-string)) (sequence-set! - (if (eq? inst 'load-array) + (if (or (memq inst '(load-array load-wide-string))) bytevector-u8-set! (lambda (str pos value) (string-set! str pos (integer->char value))))) (len (let* ((a (pop)) (b (pop)) (c (pop))) (+ (ash a 16) (ash b 8) c))) - (bytes-per-count - (if (or (eq? inst 'load-string) - (eq? inst 'load-symbol) - (eq? inst 'load-keyword) - (eq? inst 'define)) - (pop) - 1)) (seq (make-sequence len))) (let lp ((i 0)) (if (= i len) - `(,inst ,seq) + `(,inst ,(if (eq? inst 'load-wide-string) + (utf32->string seq) + seq)) (begin - (sequence-set! seq i (get1 bytes-per-count)) + (sequence-set! seq i (pop)) (lp (1+ i))))))) (else ;; fixed length diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 4bd6c4f04..c67ef694b 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -318,8 +318,8 @@ ,(modulo i 256)))) object-alist))))) ((define) - (emit-code `((define ,(symbol->string name)) - (variable-set)))) + (emit-code `(,@(dump-object name addr) + (define)))) (else (error "unknown toplevel var kind" op name)))) @@ -391,11 +391,20 @@ ((number? x) `((load-number ,(number->string x)))) ((string? x) - `((load-string ,x))) + (case (string-width x) + ((1) `((load-string ,x))) + ((4) (align-code `(load-wide-string ,x) addr 4 4)) + (else (error "bad string width" x)))) ((symbol? x) - `((load-symbol ,(symbol->string x)))) + (let ((str (symbol->string x))) + (case (string-width str) + ((1) `((load-symbol ,str))) + ((4) `(,@(dump-object str addr) + (make-symbol))) + (else (error "bad string width" str))))) ((keyword? x) - `((load-keyword ,(symbol->string (keyword->symbol x))))) + `(,@(dump-object (keyword->symbol x) addr) + (make-keyword))) ((list? x) (let ((tail (let ((len (length x))) (if (>= len 65536) (too-long "list")) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 48db6f6c4..503e0a44f 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -492,11 +492,16 @@ ((tail push vals) (emit-code src (make-glil-toplevel 'ref name)))) (maybe-emit-return)) - (else - (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) + ((module-variable the-root-module name) (case context ((tail push vals) (emit-code src (make-glil-module 'ref '(guile) name #f)))) + (maybe-emit-return)) + (else + (case context + ((tail push vals) + (emit-code src (make-glil-module + 'ref (module-name (fluid-ref *comp-module*)) name #f)))) (maybe-emit-return)))) (( src name gensym) diff --git a/module/system/xref.scm b/module/system/xref.scm index 0613754ab..906ec8e4a 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -35,7 +35,7 @@ (progv (make-vector (vector-length objects) #f)) (asm (decompile (program-objcode prog) #:to 'assembly))) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,next ,labels ,len . ,body) + ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body) (for-each (lambda (x) (pmatch x diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index d01e93c43..a8e251b83 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -65,31 +65,18 @@ (comp-test '(make-int8 3) #(make-int8 3)) - (comp-test `(load-integer ,(string (integer->char 0))) - #(load-integer 0 0 1 0)) - - (comp-test `(load-integer ,(string (integer->char 255))) - #(load-integer 0 0 1 255)) - - (comp-test `(load-integer ,(string (integer->char 1) (integer->char 0))) - #(load-integer 0 0 2 1 0)) - (comp-test '(load-number "3.14") (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.) (char->integer #\1) (char->integer #\4))) (comp-test '(load-string "foo") - (vector 'load-string 0 0 3 1 (char->integer #\f) (char->integer #\o) + (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o) (char->integer #\o))) (comp-test '(load-symbol "foo") - (vector 'load-symbol 0 0 3 1 (char->integer #\f) (char->integer #\o) + (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o) (char->integer #\o))) - (comp-test '(load-keyword "qux") - (vector 'load-keyword 0 0 3 1 (char->integer #\q) (char->integer #\u) - (char->integer #\x))) - (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) #(load-program 3 2 (uint16 1) ;; nargs, nrest, nlocs From bd4911efd239a0a09d3deb5c8dec0b727fff86ef Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Wed, 12 Aug 2009 08:50:12 -0700 Subject: [PATCH 356/375] Some signed/unsigned comparison and conversions * libguile/ports.c (scm_lfwrite_str, scm_lfwrite_substr): signed/unsigned conversion and comparison * libguile/strings.c (scm_string_append): signed/unsigned comparison --- libguile/ports.c | 4 ++-- libguile/strings.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 4ed5f76d7..f51ab0032 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1019,7 +1019,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) if (pt->rw_active == SCM_PORT_READ) scm_end_input (port); - if (end == -1) + if (end == (size_t) (-1)) end = size; size = end - start; @@ -1042,7 +1042,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) void scm_lfwrite_str (SCM str, SCM port) { - scm_lfwrite_substr (str, 0, -1, port); + scm_lfwrite_substr (str, 0, (size_t) (-1), port); } /* scm_c_read diff --git a/libguile/strings.c b/libguile/strings.c index 74cebd69b..2e766c28c 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1297,7 +1297,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, size_t len = 0; int wide = 0; SCM l, s; - int i; + size_t i; union { char *narrow; From 3c7cf7f5c04bf93222c133d5939badd75e627f6e Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Wed, 12 Aug 2009 09:21:37 -0700 Subject: [PATCH 357/375] Regression, scm_string fails to test for circular lists * libguile/string.c (scm_string): Restores the functionality where scm_string tests for circular lists * test-suite/tests/strings.test: add test for circular lists --- libguile/strings.c | 3 ++- test-suite/tests/strings.test | 10 ++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/libguile/strings.c b/libguile/strings.c index 2e766c28c..7bb277daf 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1015,10 +1015,11 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, /* Verify that this is a list of chars. */ i = scm_ilength (chrs); + SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME); + len = (size_t) i; rest = chrs; - SCM_ASSERT (len >= 0, chrs, SCM_ARG1, FUNC_NAME); while (len > 0 && scm_is_pair (rest)) { SCM elt = SCM_CAR (rest); diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index d82a4723d..a35dd20d8 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -447,7 +447,17 @@ (string-set! s 4 (integer->char #x010300)) (char=? (string-ref s 4) (integer->char #x010300))))) +;; +;; list->string +;; +(with-test-prefix "string" + (pass-if-exception "convert circular list to string" + exception:wrong-type-arg + (let ((foo (list #\a #\b #\c))) + (set-cdr! (cddr foo) (cdr foo)) + (apply string foo)))) + (with-test-prefix "string-split" ;; in guile 1.6.7 and earlier, character >=128 wasn't matched in the string From eca29b020267c477bddc3f9df6f087f461f7c8b9 Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Wed, 12 Aug 2009 08:30:59 -0700 Subject: [PATCH 358/375] Don't include libunistring headers in Guile public headers This requres the creation of a new type scm_t_string_failed_conversion_handler to replace libunistring's enum iconveh_ilseq_handler. * libguile/strings.h: don't include (scm_t_string_failed_conversion_handler): new enum type (SCM_FAILED_CONVERSION_ERROR, SCM_FAILED_CONVERSION_QUESTION_MARK): (SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE): new enum type values * libguile/strings.c (scm_to_stringn): now takes type scm_t_string_failed_conversion_handler. All callers changed. * libguile/print.c: include * libguile/ports.c (scm_lfwrite_substr): use scm_t_string_conversion_handler's constants * libguile/gen-scmconfig.c (SCM_ICONVEH_ERROR): (SCM_ICONVEH_QUESTION_MARK, SCM_ICONVEH_ESCAPE_SEQUENCE): store iconveh_ilseq_hander constants as #define's --- libguile/gen-scmconfig.c | 9 +++++++++ libguile/ports.c | 2 +- libguile/print.c | 1 + libguile/strings.c | 10 ++++++---- libguile/strings.h | 15 ++++++++++++--- 5 files changed, 29 insertions(+), 8 deletions(-) diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index d5696381b..0e897ca8c 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -125,6 +125,7 @@ #include #include +#include #define pf printf @@ -424,6 +425,14 @@ main (int argc, char *argv[]) pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n"); + pf ("\n"); + pf ("/* Constants from uniconv.h. */\n"); + pf ("#define SCM_ICONVEH_ERROR %d\n", (int) iconveh_error); + pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n", + (int) iconveh_question_mark); + pf ("#define SCM_ICONVEH_ESCAPE_SEQUENCE %d\n", + (int) iconveh_escape_sequence); + printf ("#endif\n"); return 0; diff --git a/libguile/ports.c b/libguile/ports.c index f51ab0032..60b21dd41 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1024,7 +1024,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) size = end - start; buf = scm_to_stringn (scm_c_substring (str, start, end), &len, - NULL, iconveh_escape_sequence); + NULL, SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE); ptob->write (port, buf, len); free (buf); diff --git a/libguile/print.c b/libguile/print.c index 85f030e36..c398572ab 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -23,6 +23,7 @@ #endif #include +#include #include #include "libguile/_scm.h" diff --git a/libguile/strings.c b/libguile/strings.c index 7bb277daf..03fb4b4b8 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -26,6 +26,7 @@ #include #include #include +#include #include "libguile/_scm.h" #include "libguile/chars.h" @@ -1473,13 +1474,14 @@ scm_to_locale_stringn (SCM str, size_t * lenp) /* In the future, enc will hold the port's encoding. */ enc = NULL; - return scm_to_stringn (str, lenp, enc, iconveh_escape_sequence); + return scm_to_stringn (str, lenp, enc, + SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE); } /* Low-level scheme to C string conversion function. */ char * scm_to_stringn (SCM str, size_t * lenp, const char *encoding, - enum iconv_ilseq_handler handler) + scm_t_string_failed_conversion_handler handler) { static const char iso[11] = "ISO-8859-1"; char *buf; @@ -1527,14 +1529,14 @@ scm_to_stringn (SCM str, size_t * lenp, const char *encoding, buf = NULL; len = 0; buf = u32_conv_to_encoding (iso, - handler, + (enum iconv_ilseq_handler) handler, (scm_t_uint32 *) scm_i_string_wide_chars (str), ilen, NULL, NULL, &len); if (buf == NULL) scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"", scm_list_2 (scm_from_locale_string (iso), str)); - if (handler == iconveh_escape_sequence) + if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) unistring_escapes_to_guile_escapes (&buf, &len); if (lenp) diff --git a/libguile/strings.h b/libguile/strings.h index 8c06e4725..fe9162d25 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -3,7 +3,7 @@ #ifndef SCM_STRINGS_H #define SCM_STRINGS_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -23,7 +23,6 @@ -#include #include "libguile/__scm.h" @@ -90,6 +89,15 @@ no wide version of this interface. */ +/* A type indicating what strategy to take when string locale + conversion is unsuccessful. */ +typedef enum +{ + SCM_FAILED_CONVERSION_ERROR = SCM_ICONVEH_ERROR, + SCM_FAILED_CONVERSION_QUESTION_MARK = SCM_ICONVEH_QUESTION_MARK, + SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE = SCM_ICONVEH_ESCAPE_SEQUENCE +} scm_t_string_failed_conversion_handler; + SCM_API SCM scm_string_p (SCM x); SCM_API SCM scm_string (SCM chrs); SCM_API SCM scm_make_string (SCM k, SCM chr); @@ -122,7 +130,8 @@ SCM_API char *scm_to_locale_string (SCM str); SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp); SCM_INTERNAL char *scm_to_stringn (SCM str, size_t *lenp, const char *encoding, - enum iconv_ilseq_handler handler); + scm_t_string_failed_conversion_handler + handler); SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len); SCM_API SCM scm_makfromstrs (int argc, char **argv); From aaae0d5ab3d0a867b7005d1a6bf38dc345195a93 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 12 Aug 2009 20:44:30 +0200 Subject: [PATCH 359/375] "fix" -bound lambda expressions too * module/language/tree-il/compile-glil.scm (compile-glil): Compute warnings before optimizing, as unreferenced variables will be optimized out. * libguile/_scm.h: Fix C99 comment. * module/language/tree-il/fix-letrec.scm (partition-vars): Also analyze let-bound vars. (fix-letrec!): Fix a bug whereby a set! to an unreffed var would be called for value, not effect. Also "fix" -bound lambda expressions -- really speeds up pmatch. * test-suite/tests/tree-il.test ("lexical sets", "the or hack"): Update to take into account the new optimizations. --- libguile/_scm.h | 2 +- module/language/tree-il/compile-glil.scm | 14 +++--- module/language/tree-il/fix-letrec.scm | 62 +++++++++++++++++++++++- test-suite/tests/tree-il.test | 35 +++++++------ 4 files changed, 90 insertions(+), 23 deletions(-) diff --git a/libguile/_scm.h b/libguile/_scm.h index 737e01edd..627c51e03 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -170,7 +170,7 @@ /* The word size marker in objcode. */ #define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P) -// major and minor versions must be single characters +/* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 0 #define SCM_OBJCODE_MINOR_VERSION B #define SCM_OBJCODE_MAJOR_VERSION_STRING \ diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 503e0a44f..8886fa352 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -53,16 +53,16 @@ (or (and=> (memq #:warnings opts) cadr) '())) - (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) - (x (optimize! x e opts)) - (allocation (analyze-lexicals x))) - - ;; Go throught the warning passes. - (for-each (lambda (kind) + ;; Go throught the warning passes. + (for-each (lambda (kind) (let ((warn (assoc-ref %warning-passes kind))) (and (procedure? warn) (warn x)))) - warnings) + warnings) + + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) + (x (optimize! x e opts)) + (allocation (analyze-lexicals x))) (with-fluid* *comp-module* (or (and e (car e)) (current-module)) (lambda () diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 0ed7b6bab..9b66d9ed5 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -78,6 +78,13 @@ simple lambda* complex)) + (( vars) + (values (append vars unref) + ref + set + simple + lambda* + complex)) (else (values unref ref set simple lambda* complex)))) (lambda (x unref ref set simple lambda* complex) @@ -108,6 +115,39 @@ (else (lp (cdr vars) (cdr vals) s l (cons (car vars) c)))))) + (( (orig-vars vars) vals) + ;; The point is to compile let-bound lambdas as + ;; efficiently as we do letrec-bound lambdas, so + ;; we use the same algorithm for analyzing the + ;; vars. There is no problem recursing into the + ;; bindings after the let, because all variables + ;; have been renamed. + (let lp ((vars orig-vars) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? vars) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car vars) unref) + (lp (cdr vars) (cdr vals) + s l c)) + ((memq (car vars) set) + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c))) + ((and (lambda? (car vals)) + (not (memq (car vars) set))) + (lp (cdr vars) (cdr vals) + s (cons (car vars) l) c)) + ;; There is no difference between simple and + ;; complex, for the purposes of let. Just lump + ;; them all into complex. + (else + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c)))))) (else (values unref ref set simple lambda* complex)))) '() @@ -128,7 +168,7 @@ ;; expression, called for effect. (( gensym exp) (if (memq gensym unref) - (make-sequence #f (list (make-void #f) exp)) + (make-sequence #f (list exp (make-void #f))) x)) (( src names vars vals body) @@ -176,5 +216,25 @@ ;; Finally, the body. body))))))))) + (( src names vars vals body) + (let ((binds (map list vars names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? vars set))) + (let ((u (lookup unref)) + (l (lookup lambda*)) + (c (lookup complex))) + (make-sequence + src + (append + ;; unreferenced bindings, called for effect. + (map caddr u) + (list + ;; unassigned lambdas use fix. + (make-fix src (map cadr l) (map car l) (map caddr l) + ;; and the "complex" bindings. + (make-let src (map cadr c) (map car c) (map caddr c) + body)))))))) + (else x))) x))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index d993e4ff2..73ea9c1a7 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -151,25 +151,33 @@ (with-test-prefix "lexical sets" (assert-tree-il->glil - (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) + ;; unreferenced sets may be optimized away -- make sure they are ref'd + (let (x) (y) ((const 1)) + (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) - (const 2) (lexical #t #t set 0) (void) (call return 1) - (unbind))) - - (assert-tree-il->glil - (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) - (program 0 0 1 () - (const 1) (bind (x #t 0)) (lexical #t #t box 0) - (const 2) (lexical #t #t set 0) (const #f) (call return 1) + (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) + (void) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) - (apply (primitive null?) (set! (lexical x y) (const 2)))) + (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) + (lexical x y))) (program 0 0 1 () (const 1) (bind (x #t 0)) (lexical #t #t box 0) - (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1) + (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) + (lexical #t #t ref 0) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) + (apply (primitive null?) + (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) + (program 0 0 1 () + (const 1) (bind (x #t 0)) (lexical #t #t box 0) + (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) + (call null? 1) (call return 1) (unbind)))) (with-test-prefix "module refs" @@ -413,20 +421,19 @@ (unbind)) (eq? l1 l2)) + ;; second bound var is unreferenced (assert-tree-il->glil/pmatch (let (x) (y) ((const 1)) (if (lexical x y) (lexical x y) (let (a) (b) ((const 2)) (lexical x y)))) - (program 0 0 2 () + (program 0 0 1 () (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (call return 1) (label ,l2) - (const 2) (bind (a #f 1)) (lexical #t #f set 1) (lexical #t #f ref 0) (call return 1) - (unbind) (unbind)) (eq? l1 l2))) From 98850fd727ad6b31ce2c4fe710935bbe9da9d966 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 12 Aug 2009 23:38:05 +0200 Subject: [PATCH 360/375] update docs for recent vm/compiler work * doc/ref/compiler.texi: * doc/ref/vm.texi: Update for recent changes. * module/language/assembly/disassemble.scm (disassemble-load-program): Don't print nops, they are distracting. --- doc/ref/compiler.texi | 165 +++++++----- doc/ref/vm.texi | 311 ++++++++++++++++------- module/language/assembly/disassemble.scm | 2 + 3 files changed, 313 insertions(+), 165 deletions(-) diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index f8d0895d9..0aea4e754 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -17,7 +17,7 @@ This section aims to pay attention to the small man behind the curtain. @xref{Read/Load/Eval/Compile}, if you're lost and you just wanted to -know how to compile your .scm file. +know how to compile your @code{.scm} file. @menu * Compiler Tower:: @@ -67,8 +67,7 @@ for Scheme: #:title "Guile Scheme" #:version "0.5" #:reader read - #:compilers `((tree-il . ,compile-tree-il) - (ghil . ,compile-ghil)) + #:compilers `((tree-il . ,compile-tree-il)) #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write) @@ -220,13 +219,13 @@ Note however that @code{sc-expand} does not have the same signature as around @code{sc-expand}, to make it conform to the general form of compiler procedures in Guile's language tower. -Compiler procedures take two arguments, an expression and an -environment. They return three values: the compiled expression, the -corresponding environment for the target language, and a -``continuation environment''. The compiled expression and environment -will serve as input to the next language's compiler. The -``continuation environment'' can be used to compile another expression -from the same source language within the same module. +Compiler procedures take three arguments: an expression, an +environment, and a keyword list of options. They return three values: +the compiled expression, the corresponding environment for the target +language, and a ``continuation environment''. The compiled expression +and environment will serve as input to the next language's compiler. +The ``continuation environment'' can be used to compile another +expression from the same source language within the same module. For example, you might compile the expression, @code{(define-module (foo))}. This will result in a Tree-IL expression and environment. But @@ -292,6 +291,14 @@ tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10)) The @code{src} fields are left out of the external representation. +One may create Tree-IL objects from their external representations via +calling @code{parse-tree-il}, the reader for Tree-IL. If any source +information is attached to the input S-expression, it will be +propagated to the resulting Tree-IL expressions. This is probably the +easiest way to compile to Tree-IL: just make the appropriate external +representations in S-expression format, and let @code{parse-tree-il} +take care of the rest. + @deftp {Scheme Variable} src @deftpx {External Representation} (void) An empty expression. In practice, equivalent to Scheme's @code{(if #f @@ -384,12 +391,29 @@ A version of @code{} that creates recursive bindings, like Scheme's @code{letrec}. @end deftp -@c FIXME -- need to revive this one -@c @deftp {Scheme Variable} src vars rest producer . body -@c Like Scheme's @code{receive} -- binds the values returned by -@c applying @code{producer}, which should be a thunk, to the -@c @code{lambda}-like bindings described by @var{vars} and @var{rest}. -@c @end deftp +There are two Tree-IL constructs that are not normally produced by +higher-level compilers, but instead are generated during the +source-to-source optimization and analysis passes that the Tree-IL +compiler does. Users should not generate these expressions directly, +unless they feel very clever, as the default analysis pass will +generate them as necessary. + +@deftp {Scheme Variable} src names vars exp body +@deftpx {External Representation} (let-values @var{names} @var{vars} @var{exp} @var{body}) +Like Scheme's @code{receive} -- binds the values returned by +evaluating @code{exp} to the @code{lambda}-like bindings described by +@var{vars}. That is to say, @var{vars} may be an improper list. + +@code{} is an optimization of @code{} of the +primitive, @code{call-with-values}. +@end deftp +@deftp {Scheme Variable} src names vars vals body +@deftpx {External Representation} (fix @var{names} @var{vars} @var{vals} @var{body}) +Like @code{}, but only for @var{vals} that are unset +@code{lambda} expressions. + +@code{fix} is an optimization of @code{letrec} (and @code{let}). +@end deftp Tree-IL implements a compiler to GLIL that recursively traverses Tree-IL expressions, writing out GLIL expressions into a linear list. @@ -399,9 +423,9 @@ future computations. This state allows the compiler not to emit code for constant expressions that will not be used (e.g. docstrings), and to perform tail calls when in tail position. -In the future, there will be a pass at the beginning of the -Tree-IL->GLIL compilation step to perform inlining, copy propagation, -dead code elimination, and constant folding. +Most optimization, such as it currently is, is performed on Tree-IL +expressions as source-to-source transformations. There will be more +optimizations added in the future. Interested readers are encouraged to read the implementation in @code{(language tree-il compile-glil)} for more details. @@ -411,18 +435,16 @@ Interested readers are encouraged to read the implementation in Guile Low Intermediate Language (GLIL) is a structured intermediate language whose expressions more closely approximate Guile's VM -instruction set. +instruction set. Its expression types are defined in @code{(language +glil)}. -Its expression types are defined in @code{(language glil)}, and as -with GHIL, some of its fields parse as rest arguments. - -@deftp {Scheme Variable} nargs nrest nlocs nexts meta . body +@deftp {Scheme Variable} nargs nrest nlocs meta . body A unit of code that at run-time will correspond to a compiled -procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts} -collectively define the program's arity; see @ref{Compiled -Procedures}, for more information. @var{meta} should be an alist of -properties, as in Tree IL's @code{}. @var{body} is a list of -GLIL expressions. +procedure. @var{nargs} @var{nrest} and @var{nlocs} collectively define +the program's arity; see @ref{Compiled Procedures}, for more +information. @var{meta} should be an alist of properties, as in +Tree-IL's @code{}. @var{body} is an ordered list of GLIL +expressions. @end deftp @deftp {Scheme Variable} . vars An advisory expression that notes a liveness extent for a set of @@ -461,23 +483,21 @@ and @code{filename} keys, e.g. as returned by @code{source-properties}. @end deftp @deftp {Scheme Variable} -Pushes the unspecified value on the stack. +Pushes ``the unspecified value'' on the stack. @end deftp @deftp {Scheme Variable} obj Pushes a constant value onto the stack. @var{obj} must be a number, -string, symbol, keyword, boolean, character, the empty list, or a pair -or vector of constants. +string, symbol, keyword, boolean, character, uniform array, the empty +list, or a pair or vector of constants. @end deftp -@deftp {Scheme Variable} op index -Accesses a lexically bound variable from the stack. If @var{op} is -@code{ref}, the value is pushed onto the stack; if it is @code{set}, -the variable is set from the top value on the stack, which is popped -off. @xref{Stack Layout}, for more information. -@end deftp -@deftp {Scheme Variable} op depth index -Accesses a heap-allocated variable, addressed by @var{depth}, the nth -enclosing environment, and @var{index}, the variable's position within -the environment. @var{op} is @code{ref} or @code{set}. +@deftp {Scheme Variable} local? boxed? op index +Accesses a lexically bound variable. If the variable is not +@var{local?} it is free. All variables may have @code{ref} and +@code{set} as their @var{op}. Boxed variables may also have the +@var{op}s @code{box}, @code{empty-box}, and @code{fix}, which +correspond in semantics to the VM instructions @code{box}, +@code{empty-box}, and @code{fix-closure}. @xref{Stack Layout}, for +more information. @end deftp @deftp {Scheme Variable} op name Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set}, @@ -520,7 +540,7 @@ Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -glil@@(guile-user)> (program 0 0 0 0 () (const 3) (call return 0)) +glil@@(guile-user)> (program 0 0 0 () (const 3) (call return 1)) @result{} 3 @end example @@ -542,12 +562,12 @@ differs from GLIL in four main ways: @itemize @item Labels have been resolved to byte offsets in the program. @item Constants inside procedures have either been expressed as inline -instructions, and possibly cached in object arrays. +instructions or cached in object arrays. @item Procedures with metadata (source location information, liveness extents, procedure names, generic properties, etc) have had their metadata serialized out to thunks. @item All expressions correspond directly to VM instructions -- i.e., -there is no @code{} which can be a ref or a set. +there is no @code{} which can be a ref or a set. @end itemize Assembly is isomorphic to the bytecode that it compiles to. You can @@ -567,10 +587,11 @@ example: @example scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly) -(load-program 0 0 0 0 +(load-program 0 0 0 () ; Labels - 60 ; Length + 70 ; Length #f ; Metadata + (make-false) (make-false) ; object table for the returned lambda (nop) (nop) ; Alignment. Since assembly has already resolved its labels @@ -578,11 +599,12 @@ scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly) (nop) ; object code is mmap'd directly to structures, assembly (nop) ; has to have the alignment embedded in it. (nop) - (load-program 1 0 0 0 + (load-program + 1 + 0 () - 6 - ; This is the metadata thunk for the returned procedure. - (load-program 0 0 0 0 () 21 #f + 8 + (load-program 0 0 0 () 21 #f (load-symbol "x") ; Name and liveness extent for @code{x}. (make-false) (make-int8:0) ; Some instruction+arg combinations @@ -597,7 +619,9 @@ scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly) (local-ref 0) (local-ref 0) (add) - (return)) + (return) + (nop) + (nop)) ; Return our new procedure. (return)) @end example @@ -618,10 +642,10 @@ the next step down from assembly: @example scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly) -@result{} (load-program 0 0 0 0 () 6 #f +@result{} (load-program 0 0 0 () 6 #f (make-int8 32) (make-int8 10) (add) (return)) scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode) -@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48) +@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 10 32 10 10 120 52) @end example ``Objcode'' is bytecode, but mapped directly to a C structure, @@ -631,8 +655,7 @@ scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode) struct scm_objcode @{ scm_t_uint8 nargs; scm_t_uint8 nrest; - scm_t_uint8 nlocs; - scm_t_uint8 nexts; + scm_t_uint16 nlocs; scm_t_uint32 len; scm_t_uint32 metalen; scm_t_uint8 base[0]; @@ -642,7 +665,7 @@ struct scm_objcode @{ As one might imagine, objcode imposes a minimum length on the bytecode. Also, the multibyte fields are in native endianness, which makes objcode (and bytecode) system-dependent. Indeed, in the short -example above, all but the last 5 bytes were the program's header. +example above, all but the last 6 bytes were the program's header. Objcode also has a couple of important efficiency hacks. First, objcode may be mapped directly from disk, allowing compiled code to be @@ -672,7 +695,7 @@ Makes a bytecode object from @var{bytecode}, which should be a Load object code from a file named @var{file}. The file will be mapped into memory via @code{mmap}, so this is a very fast operation. -On disk, object code has an eight-byte cookie prepended to it, to +On disk, object code has an sixteen-byte cookie prepended to it, to prevent accidental loading of arbitrary garbage. @end deffn @@ -689,11 +712,11 @@ Copy object code out to a @code{u8vector} for analysis by Scheme. The following procedure is actually in @code{(system vm program)}, but we'll mention it here: -@deffn {Scheme Variable} make-program objcode objtable [external='()] -@deffnx {C Function} scm_make_program (objcode, objtable, external) +@deffn {Scheme Variable} make-program objcode objtable [free-vars=#f] +@deffnx {C Function} scm_make_program (objcode, objtable, free_vars) Load up object code into a Scheme program. The resulting program will have @var{objtable} as its object table, which should be a vector or -@code{#f}, and will capture the closure variables from @var{external}. +@code{#f}, and will capture the free variables from @var{free-vars}. @end deffn Object code from a file may be disassembled at the REPL via the @@ -707,9 +730,9 @@ respect to the compilation environment. Normally the environment propagates through the compiler transparently, but users may specify the compilation environment manually as well: -@deffn {Scheme Procedure} make-objcode-env module externals +@deffn {Scheme Procedure} make-objcode-env module free-vars Make an object code environment. @var{module} should be a Scheme -module, and @var{externals} should be a list of external variables. +module, and @var{free-vars} should be a vector of free variables. @code{#f} is also a valid object code environment. @end deffn @@ -748,12 +771,14 @@ procedure is called a certain number of times. The name of the game is a profiling-based harvest of the low-hanging fruit, running programs of interest under a system-level profiler and determining which improvements would give the most bang for the buck. -There are many well-known efficiency hacks in the literature: Dybvig's -letrec optimization, individual boxing of heap-allocated values (and -then store the boxes on the stack directly), optimized case-lambda -expressions, stack underflow and overflow handlers, etc. Highly -recommended papers: Dybvig's HOCS, Ghuloum's compiler paper. +It's really getting to the point though that native compilation is the +next step. The compiler also needs help at the top end, enhancing the Scheme that -it knows to also understand R6RS, and adding new high-level compilers: -Emacs Lisp, Lua, JavaScript... +it knows to also understand R6RS, and adding new high-level compilers. +We have JavaScript and Emacs Lisp mostly complete, but they could use +some love; Lua would be nice as well, butq whatever language it is +that strikes your fancy would be welcome too. + +Compilers are for hacking, not for admiring or for complaining about. +Get to it! diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index fa655238f..59798d881 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -13,8 +13,8 @@ procedures can call each other as they please. The difference is that the compiler creates and interprets bytecode for a custom virtual machine, instead of interpreting the -S-expressions directly. Running compiled code is faster than running -interpreted code. +S-expressions directly. Loading and running compiled code is faster +than loading and running source code. The virtual machine that does the bytecode interpretation is a part of Guile itself. This section describes the nature of Guile's virtual @@ -134,7 +134,7 @@ compiled to object code, one might never leave the virtual machine. @subsection Stack Layout While not strictly necessary to understand how to work with the VM, it -is instructive and sometimes entertaining to consider the struture of +is instructive and sometimes entertaining to consider the structure of the VM stack. Logically speaking, a VM stack is composed of ``frames''. Each frame @@ -159,12 +159,11 @@ The structure of the fixed part of an application frame is as follows: @example Stack - | | <- fp + bp->nargs + bp->nlocs + 4 + | | <- fp + bp->nargs + bp->nlocs + 3 +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp) | Return address | | MV return address| - | Dynamic link | - | External link | <- fp + bp->nargs + bp->nlocs + | Dynamic link | <- fp + bp->nargs + bp->nlocs | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp) | Local variable 0 | <- fp + bp->nargs | Argument 1 | @@ -201,25 +200,17 @@ values being returned. @item Dynamic link This is the @code{fp} in effect before this program was applied. In effect, this and the return address are the registers that are always -``saved''. - -@item External link -This field is a reference to the list of heap-allocated variables -associated with this frame. For a discussion of heap versus stack -allocation, @xref{Variables and the VM}. +``saved''. The dynamic link links the current frame to the previous +frame; computing a stack trace involves traversing these frames. @item Local variable @var{n} -Lambda-local variables that are allocated on the stack are all -allocated as part of the frame. This makes access to non-captured, -non-mutated variables very cheap. +Lambda-local variables that are all allocated as part of the frame. +This makes access to variables very cheap. @item Argument @var{n} The calling convention of the VM requires arguments of a function -application to be pushed on the stack, and here they are. Normally -references to arguments dispatch to these locations on the stack. -However if an argument has to be stored on the heap, it will be copied -from its initial value here onto a location in the heap, and -thereafter only referenced on the heap. +application to be pushed on the stack, and here they are. References +to arguments dispatch to these locations on the stack. @item Program This is the program being applied. For more information on how @@ -236,26 +227,44 @@ Consider the following Scheme code as an example: (lambda (b) (list foo a b))) @end example -Within the lambda expression, "foo" is a top-level variable, "a" is a -lexically captured variable, and "b" is a local variable. +Within the lambda expression, @code{foo} is a top-level variable, @code{a} is a +lexically captured variable, and @code{b} is a local variable. -@code{b} may safely be allocated on the stack, as there is no enclosed -procedure that references it, nor is it ever mutated. +Another way to refer to @code{a} and @code{b} is to say that @code{a} +is a ``free'' variable, since it is not defined within the lambda, and +@code{b} is a ``bound'' variable. These are the terms used in the +@dfn{lambda calculus}, a mathematical notation for describing +functions. The lambda calculus is useful because it allows one to +prove statements about functions. It is especially good at describing +scope relations, and it is for that reason that we mention it here. -@code{a}, on the other hand, is referenced by an enclosed procedure, -that of the lambda. Thus it must be allocated on the heap, as it may -(and will) outlive the dynamic extent of the invocation of @code{foo}. +Guile allocates all variables on the stack. When a lexically enclosed +procedure with free variables---a @dfn{closure}---is created, it +copies those variables its free variable vector. References to free +variables are then redirected through the free variable vector. -@code{foo} is a top-level variable, because it names the procedure -@code{foo}, which is here defined at the top-level. +If a variable is ever @code{set!}, however, it will need to be +heap-allocated instead of stack-allocated, so that different closures +that capture the same variable can see the same value. Also, this +allows continuations to capture a reference to the variable, instead +of to its value at one point in time. For these reasons, @code{set!} +variables are allocated in ``boxes''---actually, in variable cells. +@xref{Variables}, for more information. References to @code{set!} +variables are indirected through the boxes. -Note that variables that are mutated (via @code{set!}) must be -allocated on the heap, even if they are local variables. This is -because any called subprocedure might capture the continuation, which -would need to capture locations instead of values. Thus perhaps -counterintuitively, what would seem ``closer to the metal'', viz -@code{set!}, actually forces heap allocation instead of stack -allocation. +Thus perhaps counterintuitively, what would seem ``closer to the +metal'', viz @code{set!}, actually forces an extra memory allocation +and indirection. + +Going back to our example, @code{b} may be allocated on the stack, as +it is never mutated. + +@code{a} may also be allocated on the stack, as it too is never +mutated. Within the enclosed lambda, its value will be copied into +(and referenced from) the free variables vector. + +@code{foo} is a top-level variable, because @code{foo} is not +lexically bound in this example. @node VM Programs @subsection Compiled Procedures are VM Programs @@ -297,27 +306,26 @@ scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b))) scheme@@(guile-user)> ,x foo Disassembly of #: - 0 (local-ref 0) ;; `a' (arg) - 2 (external-set 0) ;; `a' (arg) - 4 (object-ref 1) ;; #:0:16 (b)> - 6 (make-closure) - 7 (return) + 0 (object-ref 1) ;; #:0:16 (b)> + 2 (local-ref 0) ;; `a' (arg) + 4 (vector 0 1) ;; 1 element + 7 (make-closure) + 8 (return) ---------------------------------------- -Disassembly of #:0:16 (b)>: +Disassembly of #:0:16 (b)>: 0 (toplevel-ref 1) ;; `foo' - 2 (external-ref 0) ;; (closure variable) + 2 (free-ref 0) ;; (closure variable) 4 (local-ref 0) ;; `b' (arg) 6 (list 0 3) ;; 3 elements at (unknown file):0:28 9 (return) @end smallexample -At @code{ip} 0 and 2, we do the copy from argument to heap for -@code{a}. @code{Ip} 4 loads up the compiled lambda, and then at -@code{ip} 6 we make a closure---binding code (from the compiled -lambda) with data (the heap-allocated variables). Finally we return -the closure. +At @code{ip} 0, we load up the compiled lambda. @code{Ip} 2 and 4 +create the free variables vector, and @code{ip} 7 makes the +closure---binding code (from the compiled lambda) with data (the +free-variable vector). Finally we return the closure. The second stanza disassembles the compiled lambda. Toplevel variables are resolved relative to the module that was current when the @@ -336,7 +344,7 @@ routine. @node Instruction Set @subsection Instruction Set -There are about 100 instructions in Guile's virtual machine. These +There are about 150 instructions in Guile's virtual machine. These instructions represent atomic units of a program's execution. Ideally, they perform one task without conditional branches, then dispatch to the next instruction in the stream. @@ -376,16 +384,22 @@ instructions. More instructions may be added over time. * Miscellaneous Instructions:: * Inlined Scheme Instructions:: * Inlined Mathematical Instructions:: +* Inlined Bytevector Instructions:: @end menu @node Environment Control Instructions @subsubsection Environment Control Instructions These instructions access and mutate the environment of a compiled -procedure---the local bindings, the ``external'' bindings, and the +procedure---the local bindings, the free (captured) bindings, and the toplevel bindings. +Some of these instructions have @code{long-} variants, the difference +being that they take 16-bit arguments, encoded in big-endianness, +instead of the normal 8-bit range. + @deffn Instruction local-ref index +@deffnx Instruction long-local-ref index Push onto the stack the value of the local variable located at @var{index} within the current stack frame. @@ -395,26 +409,62 @@ arguments. @end deffn @deffn Instruction local-set index +@deffnx Instruction long-local-ref index Pop the Scheme object located on top of the stack and make it the new value of the local variable located at @var{index} within the current stack frame. @end deffn -@deffn Instruction external-ref index -Push the value of the closure variable located at position -@var{index} within the program's list of external variables. +@deffn Instruction free-ref index +Push the value of the captured variable located at position +@var{index} within the program's vector of captured variables. @end deffn -@deffn Instruction external-set index -Pop the Scheme object located on top of the stack and make it the new -value of the closure variable located at @var{index} within the -program's list of external variables. +@deffn Instruction free-boxed-ref index +@deffnx Instruction free-boxed-set index +Get or set a boxed free variable. Note that there is no free-set +instruction, as variables that are @code{set!} must be boxed. + +These instructions assume that the value at position @var{index} in +the free variables vector is a variable. @end deffn -The external variable lookup algorithm should probably be made more -efficient in the future via addressing by frame and index. Currently, -external variables are all consed onto a list, which results in O(N) -lookup time. +@deffn Instruction make-closure +Pop a vector and a program object off the stack, in that order, and +push a new program object with the given free variables vector. The +new program object shares state with the original program. + +At the time of this writing, the space overhead of closures is 4 words +per closure. +@end deffn + +@deffn Instruction fix-closure index +Pop a vector off the stack, and set it as the @var{index}th local +variable's free variable vector. The @var{index}th local variable is +assumed to be a procedure. + +This instruction is part of a hack for allocating mutually recursive +procedures. The hack is to first perform a @code{local-set} for all of +the recursive procedures, then fix up the procedures' free variable +bindings in place. This allows most @code{letrec}-bound procedures to +be allocated unboxed on the stack. + +One could of course do a @code{local-ref}, then @code{make-closure}, +then @code{local-set}, but this macroinstruction helps to speed up the +common case. +@end deffn + +@deffn Instruction box index +Pop a value off the stack, and set the @var{index}nth local variable +to a box containing that value. A shortcut for @code{make-variable} +then @code{local-set}, used when binding boxed variables. +@end deffn + +@deffn Instruction empty-box index +Set the @var{indext}h local variable to a box containing a variable +whose value is unbound. Used when compiling some @code{letrec} +expressions. +@end deffn @deffn Instruction toplevel-ref index @deffnx Instruction long-toplevel-ref index @@ -442,9 +492,6 @@ in-place mutation of the object table. This mechanism provides for lazy variable resolution, and an important cached fast-path once the variable has been successfully resolved. -The ``long'' variant has a 16-bit index instead of an 8-bit index, -with the most significant byte first. - This instruction pushes the value of the variable onto the stack. @end deffn @@ -453,8 +500,13 @@ This instruction pushes the value of the variable onto the stack. Pop a value off the stack, and set it as the value of the toplevel variable stored at @var{index} in the object table. If the variable has not yet been looked up, we do the lookup as in -@code{toplevel-ref}. The ``long'' variant has a 16-bit index instead -of an 8-bit index. +@code{toplevel-ref}. +@end deffn + +@deffn Instruction define +Pop a symbol and a value from the stack, in that order. Look up its +binding in the current toplevel environment, creating the binding if +necessary. Set the variable to the value. @end deffn @deffn Instruction link-now @@ -476,6 +528,11 @@ Pop off two objects from the stack, a variable and a value, and set the variable to the value. @end deffn +@deffn Instruction make-variable +Replace the top object on the stack with a variable containing it. +Used in some circumstances when compiling @code{letrec} expressions. +@end deffn + @deffn Instruction object-ref n @deffnx Instruction long-object-ref n Push @var{n}th value from the current program's object vector. The @@ -499,7 +556,10 @@ the one to which the instruction pointer points). @end itemize Note that the offset passed to the instruction is encoded on two 8-bit -integers which are then combined by the VM as one 16-bit integer. +integers which are then combined by the VM as one 16-bit integer. Note +also that jump targets in Guile are aligned on 8-byte boundaries, and +that the offset refers to the @var{n}th 8-byte boundary, effectively +giving Guile a 19-bit relative address space. @deffn Instruction br offset Jump to @var{offset}. @@ -550,19 +610,21 @@ Load an arbitrary number from the instruction stream. The number is embedded in the stream as a string. @end deffn @deffn Instruction load-string length -Load a string from the instruction stream. +Load a string from the instruction stream. The string is assumed to be +encoded in the ``latin1'' locale. +@end deffn +@deffn Instruction load-wide-string length +Load a UTF-32 string from the instruction stream. @var{length} is the +length in bytes, not in codepoints @end deffn @deffn Instruction load-symbol length -Load a symbol from the instruction stream. +Load a symbol from the instruction stream. The symbol is assumed to be +encoded in the ``latin1'' locale. Symbols backed by wide strings may +be loaded via @code{load-wide-string} then @code{make-symbol}. @end deffn -@deffn Instruction load-keyword length -Load a keyword from the instruction stream. -@end deffn - -@deffn Instruction define length -Load a symbol from the instruction stream, and look up its binding in -the current toplevel environment, creating the binding if necessary. -Push the variable corresponding to the binding. +@deffn Instruction load-array length +Load a uniform array from the instruction stream. The shape and type +of the array are popped off the stack, in that order. @end deffn @deffn Instruction load-program @@ -579,23 +641,9 @@ because instead of parsing its data, it directly maps the instruction stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode and Objcode}, for more information. -The resulting compiled procedure will not have any ``external'' -variables captured, so it may be loaded only once but used many times -to create closures. -@end deffn - -Finally, while this instruction is not strictly a ``loading'' -instruction, it's useful to wind up the @code{load-program} discussion -here: - -@deffn Instruction make-closure -Pop the program object from the stack, capture the current set of -``external'' variables, and assign those external variables to a copy -of the program. Push the new program object, which shares state with -the original program. - -At the time of this writing, the space overhead of closures is 4 words -per closure. +The resulting compiled procedure will not have any free variables +captured, so it may be loaded only once but used many times to create +closures. @end deffn @node Procedural Instructions @@ -764,6 +812,19 @@ Push @code{'()} onto the stack. Push @var{value}, an 8-bit character, onto the stack. @end deffn +@deffn Instruction make-char32 value +Push @var{value}, an 32-bit character, onto the stack. The value is +encoded in big-endian order. +@end deffn + +@deffn Instruction make-symbol +Pops a string off the stack, and pushes a symbol. +@end deffn + +@deffn Instruction make-keyword value +Pops a symbol off the stack, and pushes a keyword. +@end deffn + @deffn Instruction list n Pops off the top @var{n} values off of the stack, consing them up into a list, then pushes that list on the stack. What was the topmost value @@ -807,7 +868,8 @@ pushes its elements on the stack. @subsubsection Miscellaneous Instructions @deffn Instruction nop -Does nothing! +Does nothing! Used for padding other instructions to certain +alignments. @end deffn @deffn Instruction halt @@ -873,6 +935,8 @@ stream. @deffnx Instruction cons x y @deffnx Instruction car x @deffnx Instruction cdr x +@deffnx Instruction vector-ref x y +@deffnx Instruction vector-set x n y Inlined implementations of their Scheme equivalents. @end deffn @@ -893,7 +957,9 @@ As in the previous section, the definitions below show stack parameters instead of instruction stream parameters. @deffn Instruction add x y +@deffnx Instruction add1 x @deffnx Instruction sub x y +@deffnx Instruction sub1 x @deffnx Instruction mul x y @deffnx Instruction div x y @deffnx Instruction quo x y @@ -906,3 +972,58 @@ parameters instead of instruction stream parameters. @deffnx Instruction ge? x y Inlined implementations of the corresponding mathematical operations. @end deffn + +@node Inlined Bytevector Instructions +@subsubsection Inlined Bytevector Instructions + +Bytevector operations correspond closely to what the current hardware +can do, so it makes sense to inline them to VM instructions, providing +a clear path for eventual native compilation. Without this, Scheme +programs would need other primitives for accessing raw bytes -- but +these primitives are as good as any. + +As in the previous section, the definitions below show stack +parameters instead of instruction stream parameters. + +The multibyte formats (@code{u16}, @code{f64}, etc) take an extra +endianness argument. Only aligned native accesses are currently +fast-pathed in Guile's VM. + +@deffn Instruction bv-u8-ref bv n +@deffnx Instruction bv-s8-ref bv n +@deffnx Instruction bv-u16-native-ref bv n +@deffnx Instruction bv-s16-native-ref bv n +@deffnx Instruction bv-u32-native-ref bv n +@deffnx Instruction bv-s32-native-ref bv n +@deffnx Instruction bv-u64-native-ref bv n +@deffnx Instruction bv-s64-native-ref bv n +@deffnx Instruction bv-f32-native-ref bv n +@deffnx Instruction bv-f64-native-ref bv n +@deffnx Instruction bv-u16-ref bv n endianness +@deffnx Instruction bv-s16-ref bv n endianness +@deffnx Instruction bv-u32-ref bv n endianness +@deffnx Instruction bv-s32-ref bv n endianness +@deffnx Instruction bv-u64-ref bv n endianness +@deffnx Instruction bv-s64-ref bv n endianness +@deffnx Instruction bv-f32-ref bv n endianness +@deffnx Instruction bv-f64-ref bv n endianness +@deffnx Instruction bv-u8-set bv n val +@deffnx Instruction bv-s8-set bv n val +@deffnx Instruction bv-u16-native-set bv n val +@deffnx Instruction bv-s16-native-set bv n val +@deffnx Instruction bv-u32-native-set bv n val +@deffnx Instruction bv-s32-native-set bv n val +@deffnx Instruction bv-u64-native-set bv n val +@deffnx Instruction bv-s64-native-set bv n val +@deffnx Instruction bv-f32-native-set bv n val +@deffnx Instruction bv-f64-native-set bv n val +@deffnx Instruction bv-u16-set bv n val endianness +@deffnx Instruction bv-s16-set bv n val endianness +@deffnx Instruction bv-u32-set bv n val endianness +@deffnx Instruction bv-s32-set bv n val endianness +@deffnx Instruction bv-u64-set bv n val endianness +@deffnx Instruction bv-s64-set bv n val endianness +@deffnx Instruction bv-f32-set bv n val endianness +@deffnx Instruction bv-f64-set bv n val endianness +Inlined implementations of the corresponding bytevector operations. +@end deffn diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index d41c8161d..492acb7e5 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -60,6 +60,8 @@ (print-info pos `(load-program ,sym) #f #f) (lp (+ pos (byte-length asm)) (cdr code) (acons sym asm programs)))) + ((nop) + (lp (+ pos (byte-length asm)) (cdr code) programs)) (else (print-info pos asm (code-annotation end asm objs nargs blocs From b9434165b67fa66aae58511c78508580bf7bd353 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 13 Aug 2009 15:39:12 +0200 Subject: [PATCH 361/375] Allow redefinitions in compiled code as in `(define round round)'. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/psyntax.scm (chi-top)[define-form]: If a same-named imported variable exists, take its value instead of `#f'. * test-suite/tests/compiler.test ("psyntax")["redefinition"]: New tests. --- module/ice-9/psyntax-pp.scm | 11074 +++++++++++++++++-------------- module/ice-9/psyntax.scm | 8 +- test-suite/tests/compiler.test | 10 + 3 files changed, 5987 insertions(+), 5105 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index de0db95de..fecd2b25d 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,91 +1,122 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 - (lambda (f57 first56 . rest55) - (let ((t58 (null? first56))) - (if t58 - t58 - (if (null? rest55) - (letrec ((andmap59 - (lambda (first60) - (let ((x61 (car first60)) - (first62 (cdr first60))) - (if (null? first62) - (f57 x61) - (if (f57 x61) (andmap59 first62) #f)))))) - (andmap59 first56)) - (letrec ((andmap63 - (lambda (first64 rest65) - (let ((x66 (car first64)) - (xr67 (map car rest65)) - (first68 (cdr first64)) - (rest69 (map cdr rest65))) - (if (null? first68) - (apply f57 (cons x66 xr67)) - (if (apply f57 (cons x66 xr67)) - (andmap63 first68 rest69) +(letrec ((#{and-map*\ 1199}# + (lambda (#{f\ 1239}# #{first\ 1238}# . #{rest\ 1237}#) + (let ((#{t\ 1240}# (null? #{first\ 1238}#))) + (if #{t\ 1240}# + #{t\ 1240}# + (if (null? #{rest\ 1237}#) + (letrec ((#{andmap\ 1241}# + (lambda (#{first\ 1242}#) + (let ((#{x\ 1243}# (car #{first\ 1242}#)) + (#{first\ 1244}# (cdr #{first\ 1242}#))) + (if (null? #{first\ 1244}#) + (#{f\ 1239}# #{x\ 1243}#) + (if (#{f\ 1239}# #{x\ 1243}#) + (#{andmap\ 1241}# #{first\ 1244}#) #f)))))) - (andmap63 first56 rest55)))))))) - (letrec ((lambda-var-list163 - (lambda (vars287) - (letrec ((lvl288 - (lambda (vars289 ls290 w291) - (if (pair? vars289) - (lvl288 - (cdr vars289) - (cons (wrap143 (car vars289) w291 #f) ls290) - w291) - (if (id?115 vars289) - (cons (wrap143 vars289 w291 #f) ls290) - (if (null? vars289) - ls290 - (if (syntax-object?99 vars289) - (lvl288 - (syntax-object-expression100 vars289) - ls290 - (join-wraps134 - w291 - (syntax-object-wrap101 vars289))) - (cons vars289 ls290)))))))) - (lvl288 vars287 (quote ()) (quote (())))))) - (gen-var162 - (lambda (id292) - (let ((id293 (if (syntax-object?99 id292) - (syntax-object-expression100 id292) - id292))) + (#{andmap\ 1241}# #{first\ 1238}#)) + (letrec ((#{andmap\ 1245}# + (lambda (#{first\ 1246}# #{rest\ 1247}#) + (let ((#{x\ 1248}# (car #{first\ 1246}#)) + (#{xr\ 1249}# (map car #{rest\ 1247}#)) + (#{first\ 1250}# (cdr #{first\ 1246}#)) + (#{rest\ 1251}# + (map cdr #{rest\ 1247}#))) + (if (null? #{first\ 1250}#) + (apply #{f\ 1239}# + (cons #{x\ 1248}# #{xr\ 1249}#)) + (if (apply #{f\ 1239}# + (cons #{x\ 1248}# #{xr\ 1249}#)) + (#{andmap\ 1245}# + #{first\ 1250}# + #{rest\ 1251}#) + #f)))))) + (#{andmap\ 1245}# #{first\ 1238}# #{rest\ 1237}#)))))))) + (letrec ((#{lambda-var-list\ 1345}# + (lambda (#{vars\ 1469}#) + (letrec ((#{lvl\ 1470}# + (lambda (#{vars\ 1471}# #{ls\ 1472}# #{w\ 1473}#) + (if (pair? #{vars\ 1471}#) + (#{lvl\ 1470}# + (cdr #{vars\ 1471}#) + (cons (#{wrap\ 1325}# + (car #{vars\ 1471}#) + #{w\ 1473}# + #f) + #{ls\ 1472}#) + #{w\ 1473}#) + (if (#{id?\ 1297}# #{vars\ 1471}#) + (cons (#{wrap\ 1325}# + #{vars\ 1471}# + #{w\ 1473}# + #f) + #{ls\ 1472}#) + (if (null? #{vars\ 1471}#) + #{ls\ 1472}# + (if (#{syntax-object?\ 1281}# #{vars\ 1471}#) + (#{lvl\ 1470}# + (#{syntax-object-expression\ 1282}# + #{vars\ 1471}#) + #{ls\ 1472}# + (#{join-wraps\ 1316}# + #{w\ 1473}# + (#{syntax-object-wrap\ 1283}# + #{vars\ 1471}#))) + (cons #{vars\ 1471}# #{ls\ 1472}#)))))))) + (#{lvl\ 1470}# + #{vars\ 1469}# + '() + '(()))))) + (#{gen-var\ 1344}# + (lambda (#{id\ 1474}#) + (let ((#{id\ 1475}# + (if (#{syntax-object?\ 1281}# #{id\ 1474}#) + (#{syntax-object-expression\ 1282}# #{id\ 1474}#) + #{id\ 1474}#))) (gensym - (string-append (symbol->string id293) " "))))) - (strip161 - (lambda (x294 w295) - (if (memq (quote top) (wrap-marks118 w295)) - x294 - (letrec ((f296 (lambda (x297) - (if (syntax-object?99 x297) - (strip161 - (syntax-object-expression100 x297) - (syntax-object-wrap101 x297)) - (if (pair? x297) - (let ((a298 (f296 (car x297))) - (d299 (f296 (cdr x297)))) - (if (if (eq? a298 (car x297)) - (eq? d299 (cdr x297)) - #f) - x297 - (cons a298 d299))) - (if (vector? x297) - (let ((old300 (vector->list x297))) - (let ((new301 (map f296 old300))) - (if (and-map*17 eq? old300 new301) - x297 - (list->vector new301)))) - x297)))))) - (f296 x294))))) - (ellipsis?160 - (lambda (x302) - (if (nonsymbol-id?114 x302) - (free-id=?138 - x302 + (string-append (symbol->string #{id\ 1475}#) " "))))) + (#{strip\ 1343}# + (lambda (#{x\ 1476}# #{w\ 1477}#) + (if (memq 'top + (#{wrap-marks\ 1300}# #{w\ 1477}#)) + #{x\ 1476}# + (letrec ((#{f\ 1478}# + (lambda (#{x\ 1479}#) + (if (#{syntax-object?\ 1281}# #{x\ 1479}#) + (#{strip\ 1343}# + (#{syntax-object-expression\ 1282}# + #{x\ 1479}#) + (#{syntax-object-wrap\ 1283}# #{x\ 1479}#)) + (if (pair? #{x\ 1479}#) + (let ((#{a\ 1480}# + (#{f\ 1478}# (car #{x\ 1479}#))) + (#{d\ 1481}# + (#{f\ 1478}# (cdr #{x\ 1479}#)))) + (if (if (eq? #{a\ 1480}# (car #{x\ 1479}#)) + (eq? #{d\ 1481}# (cdr #{x\ 1479}#)) + #f) + #{x\ 1479}# + (cons #{a\ 1480}# #{d\ 1481}#))) + (if (vector? #{x\ 1479}#) + (let ((#{old\ 1482}# + (vector->list #{x\ 1479}#))) + (let ((#{new\ 1483}# + (map #{f\ 1478}# #{old\ 1482}#))) + (if (#{and-map*\ 1199}# + eq? + #{old\ 1482}# + #{new\ 1483}#) + #{x\ 1479}# + (list->vector #{new\ 1483}#)))) + #{x\ 1479}#)))))) + (#{f\ 1478}# #{x\ 1476}#))))) + (#{ellipsis?\ 1342}# + (lambda (#{x\ 1484}#) + (if (#{nonsymbol-id?\ 1296}# #{x\ 1484}#) + (#{free-id=?\ 1320}# + #{x\ 1484}# '#(syntax-object ... ((top) @@ -435,1129 +466,1401 @@ ("i" "i"))) (hygiene guile))) #f))) - (chi-void159 (lambda () (build-void81 #f))) - (eval-local-transformer158 - (lambda (expanded303 mod304) - (let ((p305 (local-eval-hook77 expanded303 mod304))) - (if (procedure? p305) - p305 + (#{chi-void\ 1341}# + (lambda () (#{build-void\ 1263}# #f))) + (#{eval-local-transformer\ 1340}# + (lambda (#{expanded\ 1485}# #{mod\ 1486}#) + (let ((#{p\ 1487}# + (#{local-eval-hook\ 1259}# + #{expanded\ 1485}# + #{mod\ 1486}#))) + (if (procedure? #{p\ 1487}#) + #{p\ 1487}# (syntax-violation #f "nonprocedure transformer" - p305))))) - (chi-local-syntax157 - (lambda (rec?306 e307 r308 w309 s310 mod311 k312) - ((lambda (tmp313) - ((lambda (tmp314) - (if tmp314 - (apply (lambda (_315 id316 val317 e1318 e2319) - (let ((ids320 id316)) - (if (not (valid-bound-ids?140 ids320)) + #{p\ 1487}#))))) + (#{chi-local-syntax\ 1339}# + (lambda (#{rec?\ 1488}# + #{e\ 1489}# + #{r\ 1490}# + #{w\ 1491}# + #{s\ 1492}# + #{mod\ 1493}# + #{k\ 1494}#) + ((lambda (#{tmp\ 1495}#) + ((lambda (#{tmp\ 1496}#) + (if #{tmp\ 1496}# + (apply (lambda (#{_\ 1497}# + #{id\ 1498}# + #{val\ 1499}# + #{e1\ 1500}# + #{e2\ 1501}#) + (let ((#{ids\ 1502}# #{id\ 1498}#)) + (if (not (#{valid-bound-ids?\ 1322}# + #{ids\ 1502}#)) (syntax-violation #f "duplicate bound keyword" - e307) - (let ((labels322 (gen-labels121 ids320))) - (let ((new-w323 - (make-binding-wrap132 - ids320 - labels322 - w309))) - (k312 (cons e1318 e2319) - (extend-env109 - labels322 - (let ((w325 (if rec?306 - new-w323 - w309)) - (trans-r326 - (macros-only-env111 - r308))) - (map (lambda (x327) - (cons 'macro - (eval-local-transformer158 - (chi151 - x327 - trans-r326 - w325 - mod311) - mod311))) - val317)) - r308) - new-w323 - s310 - mod311)))))) - tmp314) - ((lambda (_329) + #{e\ 1489}#) + (let ((#{labels\ 1504}# + (#{gen-labels\ 1303}# + #{ids\ 1502}#))) + (let ((#{new-w\ 1505}# + (#{make-binding-wrap\ 1314}# + #{ids\ 1502}# + #{labels\ 1504}# + #{w\ 1491}#))) + (#{k\ 1494}# + (cons #{e1\ 1500}# #{e2\ 1501}#) + (#{extend-env\ 1291}# + #{labels\ 1504}# + (let ((#{w\ 1507}# + (if #{rec?\ 1488}# + #{new-w\ 1505}# + #{w\ 1491}#)) + (#{trans-r\ 1508}# + (#{macros-only-env\ 1293}# + #{r\ 1490}#))) + (map (lambda (#{x\ 1509}#) + (cons 'macro + (#{eval-local-transformer\ 1340}# + (#{chi\ 1333}# + #{x\ 1509}# + #{trans-r\ 1508}# + #{w\ 1507}# + #{mod\ 1493}#) + #{mod\ 1493}#))) + #{val\ 1499}#)) + #{r\ 1490}#) + #{new-w\ 1505}# + #{s\ 1492}# + #{mod\ 1493}#)))))) + #{tmp\ 1496}#) + ((lambda (#{_\ 1511}#) (syntax-violation #f "bad local syntax definition" - (source-wrap144 e307 w309 s310 mod311))) - tmp313))) + (#{source-wrap\ 1326}# + #{e\ 1489}# + #{w\ 1491}# + #{s\ 1492}# + #{mod\ 1493}#))) + #{tmp\ 1495}#))) ($sc-dispatch - tmp313 + #{tmp\ 1495}# '(any #(each (any any)) any . each-any)))) - e307))) - (chi-lambda-clause156 - (lambda (e330 docstring331 c332 r333 w334 mod335 k336) - ((lambda (tmp337) - ((lambda (tmp338) - (if (if tmp338 - (apply (lambda (args339 doc340 e1341 e2342) - (if (string? (syntax->datum doc340)) - (not docstring331) + #{e\ 1489}#))) + (#{chi-lambda-clause\ 1338}# + (lambda (#{e\ 1512}# + #{docstring\ 1513}# + #{c\ 1514}# + #{r\ 1515}# + #{w\ 1516}# + #{mod\ 1517}# + #{k\ 1518}#) + ((lambda (#{tmp\ 1519}#) + ((lambda (#{tmp\ 1520}#) + (if (if #{tmp\ 1520}# + (apply (lambda (#{args\ 1521}# + #{doc\ 1522}# + #{e1\ 1523}# + #{e2\ 1524}#) + (if (string? (syntax->datum #{doc\ 1522}#)) + (not #{docstring\ 1513}#) #f)) - tmp338) + #{tmp\ 1520}#) #f) - (apply (lambda (args343 doc344 e1345 e2346) - (chi-lambda-clause156 - e330 - doc344 - (cons args343 (cons e1345 e2346)) - r333 - w334 - mod335 - k336)) - tmp338) - ((lambda (tmp348) - (if tmp348 - (apply (lambda (id349 e1350 e2351) - (let ((ids352 id349)) - (if (not (valid-bound-ids?140 ids352)) + (apply (lambda (#{args\ 1525}# + #{doc\ 1526}# + #{e1\ 1527}# + #{e2\ 1528}#) + (#{chi-lambda-clause\ 1338}# + #{e\ 1512}# + #{doc\ 1526}# + (cons #{args\ 1525}# + (cons #{e1\ 1527}# #{e2\ 1528}#)) + #{r\ 1515}# + #{w\ 1516}# + #{mod\ 1517}# + #{k\ 1518}#)) + #{tmp\ 1520}#) + ((lambda (#{tmp\ 1530}#) + (if #{tmp\ 1530}# + (apply (lambda (#{id\ 1531}# + #{e1\ 1532}# + #{e2\ 1533}#) + (let ((#{ids\ 1534}# #{id\ 1531}#)) + (if (not (#{valid-bound-ids?\ 1322}# + #{ids\ 1534}#)) (syntax-violation 'lambda "invalid parameter list" - e330) - (let ((labels354 - (gen-labels121 ids352)) - (new-vars355 - (map gen-var162 ids352))) - (k336 (map syntax->datum ids352) - new-vars355 - (if docstring331 - (syntax->datum docstring331) - #f) - (chi-body155 - (cons e1350 e2351) - e330 - (extend-var-env110 - labels354 - new-vars355 - r333) - (make-binding-wrap132 - ids352 - labels354 - w334) - mod335)))))) - tmp348) - ((lambda (tmp357) - (if tmp357 - (apply (lambda (ids358 e1359 e2360) - (let ((old-ids361 - (lambda-var-list163 ids358))) - (if (not (valid-bound-ids?140 - old-ids361)) + #{e\ 1512}#) + (let ((#{labels\ 1536}# + (#{gen-labels\ 1303}# + #{ids\ 1534}#)) + (#{new-vars\ 1537}# + (map #{gen-var\ 1344}# + #{ids\ 1534}#))) + (#{k\ 1518}# + (map syntax->datum #{ids\ 1534}#) + #{new-vars\ 1537}# + (if #{docstring\ 1513}# + (syntax->datum + #{docstring\ 1513}#) + #f) + (#{chi-body\ 1337}# + (cons #{e1\ 1532}# #{e2\ 1533}#) + #{e\ 1512}# + (#{extend-var-env\ 1292}# + #{labels\ 1536}# + #{new-vars\ 1537}# + #{r\ 1515}#) + (#{make-binding-wrap\ 1314}# + #{ids\ 1534}# + #{labels\ 1536}# + #{w\ 1516}#) + #{mod\ 1517}#)))))) + #{tmp\ 1530}#) + ((lambda (#{tmp\ 1539}#) + (if #{tmp\ 1539}# + (apply (lambda (#{ids\ 1540}# + #{e1\ 1541}# + #{e2\ 1542}#) + (let ((#{old-ids\ 1543}# + (#{lambda-var-list\ 1345}# + #{ids\ 1540}#))) + (if (not (#{valid-bound-ids?\ 1322}# + #{old-ids\ 1543}#)) (syntax-violation 'lambda "invalid parameter list" - e330) - (let ((labels362 - (gen-labels121 - old-ids361)) - (new-vars363 - (map gen-var162 - old-ids361))) - (k336 (letrec ((f364 (lambda (ls1365 - ls2366) - (if (null? ls1365) - (syntax->datum - ls2366) - (f364 (cdr ls1365) - (cons (syntax->datum - (car ls1365)) - ls2366)))))) - (f364 (cdr old-ids361) - (car old-ids361))) - (letrec ((f367 (lambda (ls1368 - ls2369) - (if (null? ls1368) - ls2369 - (f367 (cdr ls1368) - (cons (car ls1368) - ls2369)))))) - (f367 (cdr new-vars363) - (car new-vars363))) - (if docstring331 - (syntax->datum - docstring331) - #f) - (chi-body155 - (cons e1359 e2360) - e330 - (extend-var-env110 - labels362 - new-vars363 - r333) - (make-binding-wrap132 - old-ids361 - labels362 - w334) - mod335)))))) - tmp357) - ((lambda (_371) + #{e\ 1512}#) + (let ((#{labels\ 1544}# + (#{gen-labels\ 1303}# + #{old-ids\ 1543}#)) + (#{new-vars\ 1545}# + (map #{gen-var\ 1344}# + #{old-ids\ 1543}#))) + (#{k\ 1518}# + (letrec ((#{f\ 1546}# + (lambda (#{ls1\ 1547}# + #{ls2\ 1548}#) + (if (null? #{ls1\ 1547}#) + (syntax->datum + #{ls2\ 1548}#) + (#{f\ 1546}# + (cdr #{ls1\ 1547}#) + (cons (syntax->datum + (car #{ls1\ 1547}#)) + #{ls2\ 1548}#)))))) + (#{f\ 1546}# + (cdr #{old-ids\ 1543}#) + (car #{old-ids\ 1543}#))) + (letrec ((#{f\ 1549}# + (lambda (#{ls1\ 1550}# + #{ls2\ 1551}#) + (if (null? #{ls1\ 1550}#) + #{ls2\ 1551}# + (#{f\ 1549}# + (cdr #{ls1\ 1550}#) + (cons (car #{ls1\ 1550}#) + #{ls2\ 1551}#)))))) + (#{f\ 1549}# + (cdr #{new-vars\ 1545}#) + (car #{new-vars\ 1545}#))) + (if #{docstring\ 1513}# + (syntax->datum + #{docstring\ 1513}#) + #f) + (#{chi-body\ 1337}# + (cons #{e1\ 1541}# + #{e2\ 1542}#) + #{e\ 1512}# + (#{extend-var-env\ 1292}# + #{labels\ 1544}# + #{new-vars\ 1545}# + #{r\ 1515}#) + (#{make-binding-wrap\ 1314}# + #{old-ids\ 1543}# + #{labels\ 1544}# + #{w\ 1516}#) + #{mod\ 1517}#)))))) + #{tmp\ 1539}#) + ((lambda (#{_\ 1553}#) (syntax-violation 'lambda "bad lambda" - e330)) - tmp337))) + #{e\ 1512}#)) + #{tmp\ 1519}#))) ($sc-dispatch - tmp337 + #{tmp\ 1519}# '(any any . each-any))))) ($sc-dispatch - tmp337 + #{tmp\ 1519}# '(each-any any . each-any))))) ($sc-dispatch - tmp337 + #{tmp\ 1519}# '(any any any . each-any)))) - c332))) - (chi-body155 - (lambda (body372 outer-form373 r374 w375 mod376) - (let ((r377 (cons (quote ("placeholder" placeholder)) r374))) - (let ((ribcage378 - (make-ribcage122 + #{c\ 1514}#))) + (#{chi-body\ 1337}# + (lambda (#{body\ 1554}# + #{outer-form\ 1555}# + #{r\ 1556}# + #{w\ 1557}# + #{mod\ 1558}#) + (let ((#{r\ 1559}# + (cons '("placeholder" placeholder) + #{r\ 1556}#))) + (let ((#{ribcage\ 1560}# + (#{make-ribcage\ 1304}# '() '() '()))) - (let ((w379 (make-wrap117 - (wrap-marks118 w375) - (cons ribcage378 (wrap-subst119 w375))))) - (letrec ((parse380 - (lambda (body381 - ids382 - labels383 - var-ids384 - vars385 - vals386 - bindings387) - (if (null? body381) + (let ((#{w\ 1561}# + (#{make-wrap\ 1299}# + (#{wrap-marks\ 1300}# #{w\ 1557}#) + (cons #{ribcage\ 1560}# + (#{wrap-subst\ 1301}# #{w\ 1557}#))))) + (letrec ((#{parse\ 1562}# + (lambda (#{body\ 1563}# + #{ids\ 1564}# + #{labels\ 1565}# + #{var-ids\ 1566}# + #{vars\ 1567}# + #{vals\ 1568}# + #{bindings\ 1569}#) + (if (null? #{body\ 1563}#) (syntax-violation #f "no expressions in body" - outer-form373) - (let ((e389 (cdar body381)) - (er390 (caar body381))) + #{outer-form\ 1555}#) + (let ((#{e\ 1571}# (cdar #{body\ 1563}#)) + (#{er\ 1572}# (caar #{body\ 1563}#))) (call-with-values (lambda () - (syntax-type149 - e389 - er390 + (#{syntax-type\ 1331}# + #{e\ 1571}# + #{er\ 1572}# '(()) - (source-annotation106 er390) - ribcage378 - mod376 + (#{source-annotation\ 1288}# + #{er\ 1572}#) + #{ribcage\ 1560}# + #{mod\ 1558}# #f)) - (lambda (type391 - value392 - e393 - w394 - s395 - mod396) - (if (memv type391 + (lambda (#{type\ 1573}# + #{value\ 1574}# + #{e\ 1575}# + #{w\ 1576}# + #{s\ 1577}# + #{mod\ 1578}#) + (if (memv #{type\ 1573}# '(define-form)) - (let ((id397 (wrap143 - value392 - w394 - mod396)) - (label398 (gen-label120))) - (let ((var399 - (gen-var162 id397))) + (let ((#{id\ 1579}# + (#{wrap\ 1325}# + #{value\ 1574}# + #{w\ 1576}# + #{mod\ 1578}#)) + (#{label\ 1580}# + (#{gen-label\ 1302}#))) + (let ((#{var\ 1581}# + (#{gen-var\ 1344}# + #{id\ 1579}#))) (begin - (extend-ribcage!131 - ribcage378 - id397 - label398) - (parse380 - (cdr body381) - (cons id397 ids382) - (cons label398 labels383) - (cons id397 var-ids384) - (cons var399 vars385) - (cons (cons er390 - (wrap143 - e393 - w394 - mod396)) - vals386) + (#{extend-ribcage!\ 1313}# + #{ribcage\ 1560}# + #{id\ 1579}# + #{label\ 1580}#) + (#{parse\ 1562}# + (cdr #{body\ 1563}#) + (cons #{id\ 1579}# + #{ids\ 1564}#) + (cons #{label\ 1580}# + #{labels\ 1565}#) + (cons #{id\ 1579}# + #{var-ids\ 1566}#) + (cons #{var\ 1581}# + #{vars\ 1567}#) + (cons (cons #{er\ 1572}# + (#{wrap\ 1325}# + #{e\ 1575}# + #{w\ 1576}# + #{mod\ 1578}#)) + #{vals\ 1568}#) (cons (cons 'lexical - var399) - bindings387))))) - (if (memv type391 + #{var\ 1581}#) + #{bindings\ 1569}#))))) + (if (memv #{type\ 1573}# '(define-syntax-form)) - (let ((id400 (wrap143 - value392 - w394 - mod396)) - (label401 (gen-label120))) + (let ((#{id\ 1582}# + (#{wrap\ 1325}# + #{value\ 1574}# + #{w\ 1576}# + #{mod\ 1578}#)) + (#{label\ 1583}# + (#{gen-label\ 1302}#))) (begin - (extend-ribcage!131 - ribcage378 - id400 - label401) - (parse380 - (cdr body381) - (cons id400 ids382) - (cons label401 labels383) - var-ids384 - vars385 - vals386 + (#{extend-ribcage!\ 1313}# + #{ribcage\ 1560}# + #{id\ 1582}# + #{label\ 1583}#) + (#{parse\ 1562}# + (cdr #{body\ 1563}#) + (cons #{id\ 1582}# + #{ids\ 1564}#) + (cons #{label\ 1583}# + #{labels\ 1565}#) + #{var-ids\ 1566}# + #{vars\ 1567}# + #{vals\ 1568}# (cons (cons 'macro - (cons er390 - (wrap143 - e393 - w394 - mod396))) - bindings387)))) - (if (memv type391 + (cons #{er\ 1572}# + (#{wrap\ 1325}# + #{e\ 1575}# + #{w\ 1576}# + #{mod\ 1578}#))) + #{bindings\ 1569}#)))) + (if (memv #{type\ 1573}# '(begin-form)) - ((lambda (tmp402) - ((lambda (tmp403) - (if tmp403 - (apply (lambda (_404 - e1405) - (parse380 - (letrec ((f406 (lambda (forms407) - (if (null? forms407) - (cdr body381) - (cons (cons er390 - (wrap143 - (car forms407) - w394 - mod396)) - (f406 (cdr forms407))))))) - (f406 e1405)) - ids382 - labels383 - var-ids384 - vars385 - vals386 - bindings387)) - tmp403) + ((lambda (#{tmp\ 1584}#) + ((lambda (#{tmp\ 1585}#) + (if #{tmp\ 1585}# + (apply (lambda (#{_\ 1586}# + #{e1\ 1587}#) + (#{parse\ 1562}# + (letrec ((#{f\ 1588}# + (lambda (#{forms\ 1589}#) + (if (null? #{forms\ 1589}#) + (cdr #{body\ 1563}#) + (cons (cons #{er\ 1572}# + (#{wrap\ 1325}# + (car #{forms\ 1589}#) + #{w\ 1576}# + #{mod\ 1578}#)) + (#{f\ 1588}# + (cdr #{forms\ 1589}#))))))) + (#{f\ 1588}# + #{e1\ 1587}#)) + #{ids\ 1564}# + #{labels\ 1565}# + #{var-ids\ 1566}# + #{vars\ 1567}# + #{vals\ 1568}# + #{bindings\ 1569}#)) + #{tmp\ 1585}#) (syntax-violation #f "source expression failed to match any pattern" - tmp402))) + #{tmp\ 1584}#))) ($sc-dispatch - tmp402 + #{tmp\ 1584}# '(any . each-any)))) - e393) - (if (memv type391 + #{e\ 1575}#) + (if (memv #{type\ 1573}# '(local-syntax-form)) - (chi-local-syntax157 - value392 - e393 - er390 - w394 - s395 - mod396 - (lambda (forms409 - er410 - w411 - s412 - mod413) - (parse380 - (letrec ((f414 (lambda (forms415) - (if (null? forms415) - (cdr body381) - (cons (cons er410 - (wrap143 - (car forms415) - w411 - mod413)) - (f414 (cdr forms415))))))) - (f414 forms409)) - ids382 - labels383 - var-ids384 - vars385 - vals386 - bindings387))) - (if (null? ids382) - (build-sequence94 + (#{chi-local-syntax\ 1339}# + #{value\ 1574}# + #{e\ 1575}# + #{er\ 1572}# + #{w\ 1576}# + #{s\ 1577}# + #{mod\ 1578}# + (lambda (#{forms\ 1591}# + #{er\ 1592}# + #{w\ 1593}# + #{s\ 1594}# + #{mod\ 1595}#) + (#{parse\ 1562}# + (letrec ((#{f\ 1596}# + (lambda (#{forms\ 1597}#) + (if (null? #{forms\ 1597}#) + (cdr #{body\ 1563}#) + (cons (cons #{er\ 1592}# + (#{wrap\ 1325}# + (car #{forms\ 1597}#) + #{w\ 1593}# + #{mod\ 1595}#)) + (#{f\ 1596}# + (cdr #{forms\ 1597}#))))))) + (#{f\ 1596}# + #{forms\ 1591}#)) + #{ids\ 1564}# + #{labels\ 1565}# + #{var-ids\ 1566}# + #{vars\ 1567}# + #{vals\ 1568}# + #{bindings\ 1569}#))) + (if (null? #{ids\ 1564}#) + (#{build-sequence\ 1276}# #f - (map (lambda (x416) - (chi151 - (cdr x416) - (car x416) + (map (lambda (#{x\ 1598}#) + (#{chi\ 1333}# + (cdr #{x\ 1598}#) + (car #{x\ 1598}#) '(()) - mod396)) - (cons (cons er390 - (source-wrap144 - e393 - w394 - s395 - mod396)) - (cdr body381)))) + #{mod\ 1578}#)) + (cons (cons #{er\ 1572}# + (#{source-wrap\ 1326}# + #{e\ 1575}# + #{w\ 1576}# + #{s\ 1577}# + #{mod\ 1578}#)) + (cdr #{body\ 1563}#)))) (begin - (if (not (valid-bound-ids?140 - ids382)) + (if (not (#{valid-bound-ids?\ 1322}# + #{ids\ 1564}#)) (syntax-violation #f "invalid or duplicate identifier in definition" - outer-form373)) - (letrec ((loop417 - (lambda (bs418 - er-cache419 - r-cache420) - (if (not (null? bs418)) - (let ((b421 (car bs418))) - (if (eq? (car b421) + #{outer-form\ 1555}#)) + (letrec ((#{loop\ 1599}# + (lambda (#{bs\ 1600}# + #{er-cache\ 1601}# + #{r-cache\ 1602}#) + (if (not (null? #{bs\ 1600}#)) + (let ((#{b\ 1603}# + (car #{bs\ 1600}#))) + (if (eq? (car #{b\ 1603}#) 'macro) - (let ((er422 (cadr b421))) - (let ((r-cache423 - (if (eq? er422 - er-cache419) - r-cache420 - (macros-only-env111 - er422)))) + (let ((#{er\ 1604}# + (cadr #{b\ 1603}#))) + (let ((#{r-cache\ 1605}# + (if (eq? #{er\ 1604}# + #{er-cache\ 1601}#) + #{r-cache\ 1602}# + (#{macros-only-env\ 1293}# + #{er\ 1604}#)))) (begin (set-cdr! - b421 - (eval-local-transformer158 - (chi151 - (cddr b421) - r-cache423 + #{b\ 1603}# + (#{eval-local-transformer\ 1340}# + (#{chi\ 1333}# + (cddr #{b\ 1603}#) + #{r-cache\ 1605}# '(()) - mod396) - mod396)) - (loop417 - (cdr bs418) - er422 - r-cache423)))) - (loop417 - (cdr bs418) - er-cache419 - r-cache420))))))) - (loop417 - bindings387 + #{mod\ 1578}#) + #{mod\ 1578}#)) + (#{loop\ 1599}# + (cdr #{bs\ 1600}#) + #{er\ 1604}# + #{r-cache\ 1605}#)))) + (#{loop\ 1599}# + (cdr #{bs\ 1600}#) + #{er-cache\ 1601}# + #{r-cache\ 1602}#))))))) + (#{loop\ 1599}# + #{bindings\ 1569}# #f #f)) (set-cdr! - r377 - (extend-env109 - labels383 - bindings387 - (cdr r377))) - (build-letrec97 + #{r\ 1559}# + (#{extend-env\ 1291}# + #{labels\ 1565}# + #{bindings\ 1569}# + (cdr #{r\ 1559}#))) + (#{build-letrec\ 1279}# #f (map syntax->datum - var-ids384) - vars385 - (map (lambda (x424) - (chi151 - (cdr x424) - (car x424) + #{var-ids\ 1566}#) + #{vars\ 1567}# + (map (lambda (#{x\ 1606}#) + (#{chi\ 1333}# + (cdr #{x\ 1606}#) + (car #{x\ 1606}#) '(()) - mod396)) - vals386) - (build-sequence94 + #{mod\ 1578}#)) + #{vals\ 1568}#) + (#{build-sequence\ 1276}# #f - (map (lambda (x425) - (chi151 - (cdr x425) - (car x425) + (map (lambda (#{x\ 1607}#) + (#{chi\ 1333}# + (cdr #{x\ 1607}#) + (car #{x\ 1607}#) '(()) - mod396)) - (cons (cons er390 - (source-wrap144 - e393 - w394 - s395 - mod396)) - (cdr body381)))))))))))))))))) - (parse380 - (map (lambda (x388) - (cons r377 (wrap143 x388 w379 mod376))) - body372) + #{mod\ 1578}#)) + (cons (cons #{er\ 1572}# + (#{source-wrap\ 1326}# + #{e\ 1575}# + #{w\ 1576}# + #{s\ 1577}# + #{mod\ 1578}#)) + (cdr #{body\ 1563}#)))))))))))))))))) + (#{parse\ 1562}# + (map (lambda (#{x\ 1570}#) + (cons #{r\ 1559}# + (#{wrap\ 1325}# + #{x\ 1570}# + #{w\ 1561}# + #{mod\ 1558}#))) + #{body\ 1554}#) '() '() '() '() '() '()))))))) - (chi-macro154 - (lambda (p426 e427 r428 w429 rib430 mod431) - (letrec ((rebuild-macro-output432 - (lambda (x433 m434) - (if (pair? x433) - (cons (rebuild-macro-output432 (car x433) m434) - (rebuild-macro-output432 (cdr x433) m434)) - (if (syntax-object?99 x433) - (let ((w435 (syntax-object-wrap101 x433))) - (let ((ms436 (wrap-marks118 w435)) - (s437 (wrap-subst119 w435))) - (if (if (pair? ms436) - (eq? (car ms436) #f) + (#{chi-macro\ 1336}# + (lambda (#{p\ 1608}# + #{e\ 1609}# + #{r\ 1610}# + #{w\ 1611}# + #{rib\ 1612}# + #{mod\ 1613}#) + (letrec ((#{rebuild-macro-output\ 1614}# + (lambda (#{x\ 1615}# #{m\ 1616}#) + (if (pair? #{x\ 1615}#) + (cons (#{rebuild-macro-output\ 1614}# + (car #{x\ 1615}#) + #{m\ 1616}#) + (#{rebuild-macro-output\ 1614}# + (cdr #{x\ 1615}#) + #{m\ 1616}#)) + (if (#{syntax-object?\ 1281}# #{x\ 1615}#) + (let ((#{w\ 1617}# + (#{syntax-object-wrap\ 1283}# + #{x\ 1615}#))) + (let ((#{ms\ 1618}# + (#{wrap-marks\ 1300}# #{w\ 1617}#)) + (#{s\ 1619}# + (#{wrap-subst\ 1301}# #{w\ 1617}#))) + (if (if (pair? #{ms\ 1618}#) + (eq? (car #{ms\ 1618}#) #f) #f) - (make-syntax-object98 - (syntax-object-expression100 x433) - (make-wrap117 - (cdr ms436) - (if rib430 - (cons rib430 (cdr s437)) - (cdr s437))) - (syntax-object-module102 x433)) - (make-syntax-object98 - (syntax-object-expression100 x433) - (make-wrap117 - (cons m434 ms436) - (if rib430 - (cons rib430 - (cons (quote shift) s437)) - (cons (quote shift) s437))) - (let ((pmod438 - (procedure-module p426))) - (if pmod438 + (#{make-syntax-object\ 1280}# + (#{syntax-object-expression\ 1282}# + #{x\ 1615}#) + (#{make-wrap\ 1299}# + (cdr #{ms\ 1618}#) + (if #{rib\ 1612}# + (cons #{rib\ 1612}# + (cdr #{s\ 1619}#)) + (cdr #{s\ 1619}#))) + (#{syntax-object-module\ 1284}# + #{x\ 1615}#)) + (#{make-syntax-object\ 1280}# + (#{syntax-object-expression\ 1282}# + #{x\ 1615}#) + (#{make-wrap\ 1299}# + (cons #{m\ 1616}# #{ms\ 1618}#) + (if #{rib\ 1612}# + (cons #{rib\ 1612}# + (cons 'shift + #{s\ 1619}#)) + (cons (quote shift) #{s\ 1619}#))) + (let ((#{pmod\ 1620}# + (procedure-module + #{p\ 1608}#))) + (if #{pmod\ 1620}# (cons 'hygiene - (module-name pmod438)) + (module-name #{pmod\ 1620}#)) '(hygiene guile))))))) - (if (vector? x433) - (let ((n439 (vector-length x433))) - (let ((v440 (make-vector n439))) - (letrec ((loop441 - (lambda (i442) - (if (fx=74 i442 n439) - (begin (if #f #f) v440) + (if (vector? #{x\ 1615}#) + (let ((#{n\ 1621}# + (vector-length #{x\ 1615}#))) + (let ((#{v\ 1622}# + (make-vector #{n\ 1621}#))) + (letrec ((#{loop\ 1623}# + (lambda (#{i\ 1624}#) + (if (#{fx=\ 1256}# + #{i\ 1624}# + #{n\ 1621}#) + (begin + (if #f #f) + #{v\ 1622}#) (begin (vector-set! - v440 - i442 - (rebuild-macro-output432 + #{v\ 1622}# + #{i\ 1624}# + (#{rebuild-macro-output\ 1614}# (vector-ref - x433 - i442) - m434)) - (loop441 - (fx+72 i442 1))))))) - (loop441 0)))) - (if (symbol? x433) + #{x\ 1615}# + #{i\ 1624}#) + #{m\ 1616}#)) + (#{loop\ 1623}# + (#{fx+\ 1254}# + #{i\ 1624}# + 1))))))) + (#{loop\ 1623}# 0)))) + (if (symbol? #{x\ 1615}#) (syntax-violation #f "encountered raw symbol in macro output" - (source-wrap144 e427 w429 s mod431) - x433) - x433))))))) - (rebuild-macro-output432 - (p426 (wrap143 e427 (anti-mark130 w429) mod431)) + (#{source-wrap\ 1326}# + #{e\ 1609}# + #{w\ 1611}# + s + #{mod\ 1613}#) + #{x\ 1615}#) + #{x\ 1615}#))))))) + (#{rebuild-macro-output\ 1614}# + (#{p\ 1608}# + (#{wrap\ 1325}# + #{e\ 1609}# + (#{anti-mark\ 1312}# #{w\ 1611}#) + #{mod\ 1613}#)) (string #\m))))) - (chi-application153 - (lambda (x443 e444 r445 w446 s447 mod448) - ((lambda (tmp449) - ((lambda (tmp450) - (if tmp450 - (apply (lambda (e0451 e1452) - (build-application82 - s447 - x443 - (map (lambda (e453) - (chi151 e453 r445 w446 mod448)) - e1452))) - tmp450) + (#{chi-application\ 1335}# + (lambda (#{x\ 1625}# + #{e\ 1626}# + #{r\ 1627}# + #{w\ 1628}# + #{s\ 1629}# + #{mod\ 1630}#) + ((lambda (#{tmp\ 1631}#) + ((lambda (#{tmp\ 1632}#) + (if #{tmp\ 1632}# + (apply (lambda (#{e0\ 1633}# #{e1\ 1634}#) + (#{build-application\ 1264}# + #{s\ 1629}# + #{x\ 1625}# + (map (lambda (#{e\ 1635}#) + (#{chi\ 1333}# + #{e\ 1635}# + #{r\ 1627}# + #{w\ 1628}# + #{mod\ 1630}#)) + #{e1\ 1634}#))) + #{tmp\ 1632}#) (syntax-violation #f "source expression failed to match any pattern" - tmp449))) - ($sc-dispatch tmp449 (quote (any . each-any))))) - e444))) - (chi-expr152 - (lambda (type455 value456 e457 r458 w459 s460 mod461) - (if (memv type455 (quote (lexical))) - (build-lexical-reference84 + #{tmp\ 1631}#))) + ($sc-dispatch + #{tmp\ 1631}# + '(any . each-any)))) + #{e\ 1626}#))) + (#{chi-expr\ 1334}# + (lambda (#{type\ 1637}# + #{value\ 1638}# + #{e\ 1639}# + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#) + (if (memv #{type\ 1637}# (quote (lexical))) + (#{build-lexical-reference\ 1266}# 'value - s460 - e457 - value456) - (if (memv type455 (quote (core core-form))) - (value456 e457 r458 w459 s460 mod461) - (if (memv type455 (quote (module-ref))) + #{s\ 1642}# + #{e\ 1639}# + #{value\ 1638}#) + (if (memv #{type\ 1637}# (quote (core core-form))) + (#{value\ 1638}# + #{e\ 1639}# + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#) + (if (memv #{type\ 1637}# (quote (module-ref))) (call-with-values - (lambda () (value456 e457)) - (lambda (id462 mod463) - (build-global-reference87 s460 id462 mod463))) - (if (memv type455 (quote (lexical-call))) - (chi-application153 - (build-lexical-reference84 + (lambda () (#{value\ 1638}# #{e\ 1639}#)) + (lambda (#{id\ 1644}# #{mod\ 1645}#) + (#{build-global-reference\ 1269}# + #{s\ 1642}# + #{id\ 1644}# + #{mod\ 1645}#))) + (if (memv #{type\ 1637}# (quote (lexical-call))) + (#{chi-application\ 1335}# + (#{build-lexical-reference\ 1266}# 'fun - (source-annotation106 (car e457)) - (car e457) - value456) - e457 - r458 - w459 - s460 - mod461) - (if (memv type455 (quote (global-call))) - (chi-application153 - (build-global-reference87 - (source-annotation106 (car e457)) - (if (syntax-object?99 value456) - (syntax-object-expression100 value456) - value456) - (if (syntax-object?99 value456) - (syntax-object-module102 value456) - mod461)) - e457 - r458 - w459 - s460 - mod461) - (if (memv type455 (quote (constant))) - (build-data93 - s460 - (strip161 - (source-wrap144 e457 w459 s460 mod461) + (#{source-annotation\ 1288}# (car #{e\ 1639}#)) + (car #{e\ 1639}#) + #{value\ 1638}#) + #{e\ 1639}# + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#) + (if (memv #{type\ 1637}# (quote (global-call))) + (#{chi-application\ 1335}# + (#{build-global-reference\ 1269}# + (#{source-annotation\ 1288}# (car #{e\ 1639}#)) + (if (#{syntax-object?\ 1281}# #{value\ 1638}#) + (#{syntax-object-expression\ 1282}# + #{value\ 1638}#) + #{value\ 1638}#) + (if (#{syntax-object?\ 1281}# #{value\ 1638}#) + (#{syntax-object-module\ 1284}# #{value\ 1638}#) + #{mod\ 1643}#)) + #{e\ 1639}# + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#) + (if (memv #{type\ 1637}# (quote (constant))) + (#{build-data\ 1275}# + #{s\ 1642}# + (#{strip\ 1343}# + (#{source-wrap\ 1326}# + #{e\ 1639}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#) '(()))) - (if (memv type455 (quote (global))) - (build-global-reference87 s460 value456 mod461) - (if (memv type455 (quote (call))) - (chi-application153 - (chi151 (car e457) r458 w459 mod461) - e457 - r458 - w459 - s460 - mod461) - (if (memv type455 (quote (begin-form))) - ((lambda (tmp464) - ((lambda (tmp465) - (if tmp465 - (apply (lambda (_466 e1467 e2468) - (chi-sequence145 - (cons e1467 e2468) - r458 - w459 - s460 - mod461)) - tmp465) + (if (memv #{type\ 1637}# (quote (global))) + (#{build-global-reference\ 1269}# + #{s\ 1642}# + #{value\ 1638}# + #{mod\ 1643}#) + (if (memv #{type\ 1637}# (quote (call))) + (#{chi-application\ 1335}# + (#{chi\ 1333}# + (car #{e\ 1639}#) + #{r\ 1640}# + #{w\ 1641}# + #{mod\ 1643}#) + #{e\ 1639}# + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#) + (if (memv #{type\ 1637}# (quote (begin-form))) + ((lambda (#{tmp\ 1646}#) + ((lambda (#{tmp\ 1647}#) + (if #{tmp\ 1647}# + (apply (lambda (#{_\ 1648}# + #{e1\ 1649}# + #{e2\ 1650}#) + (#{chi-sequence\ 1327}# + (cons #{e1\ 1649}# + #{e2\ 1650}#) + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#)) + #{tmp\ 1647}#) (syntax-violation #f "source expression failed to match any pattern" - tmp464))) + #{tmp\ 1646}#))) ($sc-dispatch - tmp464 + #{tmp\ 1646}# '(any any . each-any)))) - e457) - (if (memv type455 (quote (local-syntax-form))) - (chi-local-syntax157 - value456 - e457 - r458 - w459 - s460 - mod461 - chi-sequence145) - (if (memv type455 (quote (eval-when-form))) - ((lambda (tmp470) - ((lambda (tmp471) - (if tmp471 - (apply (lambda (_472 - x473 - e1474 - e2475) - (let ((when-list476 - (chi-when-list148 - e457 - x473 - w459))) + #{e\ 1639}#) + (if (memv #{type\ 1637}# + '(local-syntax-form)) + (#{chi-local-syntax\ 1339}# + #{value\ 1638}# + #{e\ 1639}# + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}# + #{chi-sequence\ 1327}#) + (if (memv #{type\ 1637}# + '(eval-when-form)) + ((lambda (#{tmp\ 1652}#) + ((lambda (#{tmp\ 1653}#) + (if #{tmp\ 1653}# + (apply (lambda (#{_\ 1654}# + #{x\ 1655}# + #{e1\ 1656}# + #{e2\ 1657}#) + (let ((#{when-list\ 1658}# + (#{chi-when-list\ 1330}# + #{e\ 1639}# + #{x\ 1655}# + #{w\ 1641}#))) (if (memq 'eval - when-list476) - (chi-sequence145 - (cons e1474 e2475) - r458 - w459 - s460 - mod461) - (chi-void159)))) - tmp471) + #{when-list\ 1658}#) + (#{chi-sequence\ 1327}# + (cons #{e1\ 1656}# + #{e2\ 1657}#) + #{r\ 1640}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#) + (#{chi-void\ 1341}#)))) + #{tmp\ 1653}#) (syntax-violation #f "source expression failed to match any pattern" - tmp470))) + #{tmp\ 1652}#))) ($sc-dispatch - tmp470 + #{tmp\ 1652}# '(any each-any any . each-any)))) - e457) - (if (memv type455 + #{e\ 1639}#) + (if (memv #{type\ 1637}# '(define-form define-syntax-form)) (syntax-violation #f "definition in expression context" - e457 - (wrap143 value456 w459 mod461)) - (if (memv type455 (quote (syntax))) + #{e\ 1639}# + (#{wrap\ 1325}# + #{value\ 1638}# + #{w\ 1641}# + #{mod\ 1643}#)) + (if (memv #{type\ 1637}# + '(syntax)) (syntax-violation #f "reference to pattern variable outside syntax form" - (source-wrap144 - e457 - w459 - s460 - mod461)) - (if (memv type455 + (#{source-wrap\ 1326}# + #{e\ 1639}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#)) + (if (memv #{type\ 1637}# '(displaced-lexical)) (syntax-violation #f "reference to identifier outside its scope" - (source-wrap144 - e457 - w459 - s460 - mod461)) + (#{source-wrap\ 1326}# + #{e\ 1639}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#)) (syntax-violation #f "unexpected syntax" - (source-wrap144 - e457 - w459 - s460 - mod461)))))))))))))))))) - (chi151 - (lambda (e479 r480 w481 mod482) + (#{source-wrap\ 1326}# + #{e\ 1639}# + #{w\ 1641}# + #{s\ 1642}# + #{mod\ 1643}#)))))))))))))))))) + (#{chi\ 1333}# + (lambda (#{e\ 1661}# + #{r\ 1662}# + #{w\ 1663}# + #{mod\ 1664}#) (call-with-values (lambda () - (syntax-type149 - e479 - r480 - w481 - (source-annotation106 e479) + (#{syntax-type\ 1331}# + #{e\ 1661}# + #{r\ 1662}# + #{w\ 1663}# + (#{source-annotation\ 1288}# #{e\ 1661}#) #f - mod482 + #{mod\ 1664}# #f)) - (lambda (type483 value484 e485 w486 s487 mod488) - (chi-expr152 - type483 - value484 - e485 - r480 - w486 - s487 - mod488))))) - (chi-top150 - (lambda (e489 r490 w491 m492 esew493 mod494) + (lambda (#{type\ 1665}# + #{value\ 1666}# + #{e\ 1667}# + #{w\ 1668}# + #{s\ 1669}# + #{mod\ 1670}#) + (#{chi-expr\ 1334}# + #{type\ 1665}# + #{value\ 1666}# + #{e\ 1667}# + #{r\ 1662}# + #{w\ 1668}# + #{s\ 1669}# + #{mod\ 1670}#))))) + (#{chi-top\ 1332}# + (lambda (#{e\ 1671}# + #{r\ 1672}# + #{w\ 1673}# + #{m\ 1674}# + #{esew\ 1675}# + #{mod\ 1676}#) (call-with-values (lambda () - (syntax-type149 - e489 - r490 - w491 - (source-annotation106 e489) + (#{syntax-type\ 1331}# + #{e\ 1671}# + #{r\ 1672}# + #{w\ 1673}# + (#{source-annotation\ 1288}# #{e\ 1671}#) #f - mod494 + #{mod\ 1676}# #f)) - (lambda (type502 value503 e504 w505 s506 mod507) - (if (memv type502 (quote (begin-form))) - ((lambda (tmp508) - ((lambda (tmp509) - (if tmp509 - (apply (lambda (_510) (chi-void159)) tmp509) - ((lambda (tmp511) - (if tmp511 - (apply (lambda (_512 e1513 e2514) - (chi-top-sequence146 - (cons e1513 e2514) - r490 - w505 - s506 - m492 - esew493 - mod507)) - tmp511) + (lambda (#{type\ 1684}# + #{value\ 1685}# + #{e\ 1686}# + #{w\ 1687}# + #{s\ 1688}# + #{mod\ 1689}#) + (if (memv #{type\ 1684}# (quote (begin-form))) + ((lambda (#{tmp\ 1690}#) + ((lambda (#{tmp\ 1691}#) + (if #{tmp\ 1691}# + (apply (lambda (#{_\ 1692}#) (#{chi-void\ 1341}#)) + #{tmp\ 1691}#) + ((lambda (#{tmp\ 1693}#) + (if #{tmp\ 1693}# + (apply (lambda (#{_\ 1694}# + #{e1\ 1695}# + #{e2\ 1696}#) + (#{chi-top-sequence\ 1328}# + (cons #{e1\ 1695}# #{e2\ 1696}#) + #{r\ 1672}# + #{w\ 1687}# + #{s\ 1688}# + #{m\ 1674}# + #{esew\ 1675}# + #{mod\ 1689}#)) + #{tmp\ 1693}#) (syntax-violation #f "source expression failed to match any pattern" - tmp508))) + #{tmp\ 1690}#))) ($sc-dispatch - tmp508 + #{tmp\ 1690}# '(any any . each-any))))) - ($sc-dispatch tmp508 (quote (any))))) - e504) - (if (memv type502 (quote (local-syntax-form))) - (chi-local-syntax157 - value503 - e504 - r490 - w505 - s506 - mod507 - (lambda (body516 r517 w518 s519 mod520) - (chi-top-sequence146 - body516 - r517 - w518 - s519 - m492 - esew493 - mod520))) - (if (memv type502 (quote (eval-when-form))) - ((lambda (tmp521) - ((lambda (tmp522) - (if tmp522 - (apply (lambda (_523 x524 e1525 e2526) - (let ((when-list527 - (chi-when-list148 - e504 - x524 - w505)) - (body528 (cons e1525 e2526))) - (if (eq? m492 (quote e)) + ($sc-dispatch #{tmp\ 1690}# (quote (any))))) + #{e\ 1686}#) + (if (memv #{type\ 1684}# (quote (local-syntax-form))) + (#{chi-local-syntax\ 1339}# + #{value\ 1685}# + #{e\ 1686}# + #{r\ 1672}# + #{w\ 1687}# + #{s\ 1688}# + #{mod\ 1689}# + (lambda (#{body\ 1698}# + #{r\ 1699}# + #{w\ 1700}# + #{s\ 1701}# + #{mod\ 1702}#) + (#{chi-top-sequence\ 1328}# + #{body\ 1698}# + #{r\ 1699}# + #{w\ 1700}# + #{s\ 1701}# + #{m\ 1674}# + #{esew\ 1675}# + #{mod\ 1702}#))) + (if (memv #{type\ 1684}# (quote (eval-when-form))) + ((lambda (#{tmp\ 1703}#) + ((lambda (#{tmp\ 1704}#) + (if #{tmp\ 1704}# + (apply (lambda (#{_\ 1705}# + #{x\ 1706}# + #{e1\ 1707}# + #{e2\ 1708}#) + (let ((#{when-list\ 1709}# + (#{chi-when-list\ 1330}# + #{e\ 1686}# + #{x\ 1706}# + #{w\ 1687}#)) + (#{body\ 1710}# + (cons #{e1\ 1707}# + #{e2\ 1708}#))) + (if (eq? #{m\ 1674}# (quote e)) (if (memq 'eval - when-list527) - (chi-top-sequence146 - body528 - r490 - w505 - s506 + #{when-list\ 1709}#) + (#{chi-top-sequence\ 1328}# + #{body\ 1710}# + #{r\ 1672}# + #{w\ 1687}# + #{s\ 1688}# 'e '(eval) - mod507) - (chi-void159)) + #{mod\ 1689}#) + (#{chi-void\ 1341}#)) (if (memq 'load - when-list527) - (if (let ((t531 (memq 'compile - when-list527))) - (if t531 - t531 - (if (eq? m492 + #{when-list\ 1709}#) + (if (let ((#{t\ 1713}# + (memq 'compile + #{when-list\ 1709}#))) + (if #{t\ 1713}# + #{t\ 1713}# + (if (eq? #{m\ 1674}# 'c&e) (memq 'eval - when-list527) + #{when-list\ 1709}#) #f))) - (chi-top-sequence146 - body528 - r490 - w505 - s506 + (#{chi-top-sequence\ 1328}# + #{body\ 1710}# + #{r\ 1672}# + #{w\ 1687}# + #{s\ 1688}# 'c&e '(compile load) - mod507) - (if (memq m492 + #{mod\ 1689}#) + (if (memq #{m\ 1674}# '(c c&e)) - (chi-top-sequence146 - body528 - r490 - w505 - s506 + (#{chi-top-sequence\ 1328}# + #{body\ 1710}# + #{r\ 1672}# + #{w\ 1687}# + #{s\ 1688}# 'c '(load) - mod507) - (chi-void159))) - (if (let ((t532 (memq 'compile - when-list527))) - (if t532 - t532 - (if (eq? m492 + #{mod\ 1689}#) + (#{chi-void\ 1341}#))) + (if (let ((#{t\ 1714}# + (memq 'compile + #{when-list\ 1709}#))) + (if #{t\ 1714}# + #{t\ 1714}# + (if (eq? #{m\ 1674}# 'c&e) (memq 'eval - when-list527) + #{when-list\ 1709}#) #f))) (begin - (top-level-eval-hook76 - (chi-top-sequence146 - body528 - r490 - w505 - s506 + (#{top-level-eval-hook\ 1258}# + (#{chi-top-sequence\ 1328}# + #{body\ 1710}# + #{r\ 1672}# + #{w\ 1687}# + #{s\ 1688}# 'e '(eval) - mod507) - mod507) - (chi-void159)) - (chi-void159)))))) - tmp522) + #{mod\ 1689}#) + #{mod\ 1689}#) + (#{chi-void\ 1341}#)) + (#{chi-void\ 1341}#)))))) + #{tmp\ 1704}#) (syntax-violation #f "source expression failed to match any pattern" - tmp521))) + #{tmp\ 1703}#))) ($sc-dispatch - tmp521 + #{tmp\ 1703}# '(any each-any any . each-any)))) - e504) - (if (memv type502 (quote (define-syntax-form))) - (let ((n533 (id-var-name137 value503 w505)) - (r534 (macros-only-env111 r490))) - (if (memv m492 (quote (c))) - (if (memq (quote compile) esew493) - (let ((e535 (chi-install-global147 - n533 - (chi151 - e504 - r534 - w505 - mod507)))) + #{e\ 1686}#) + (if (memv #{type\ 1684}# + '(define-syntax-form)) + (let ((#{n\ 1715}# + (#{id-var-name\ 1319}# + #{value\ 1685}# + #{w\ 1687}#)) + (#{r\ 1716}# + (#{macros-only-env\ 1293}# #{r\ 1672}#))) + (if (memv #{m\ 1674}# (quote (c))) + (if (memq (quote compile) #{esew\ 1675}#) + (let ((#{e\ 1717}# + (#{chi-install-global\ 1329}# + #{n\ 1715}# + (#{chi\ 1333}# + #{e\ 1686}# + #{r\ 1716}# + #{w\ 1687}# + #{mod\ 1689}#)))) (begin - (top-level-eval-hook76 e535 mod507) - (if (memq (quote load) esew493) - e535 - (chi-void159)))) - (if (memq (quote load) esew493) - (chi-install-global147 - n533 - (chi151 e504 r534 w505 mod507)) - (chi-void159))) - (if (memv m492 (quote (c&e))) - (let ((e536 (chi-install-global147 - n533 - (chi151 - e504 - r534 - w505 - mod507)))) + (#{top-level-eval-hook\ 1258}# + #{e\ 1717}# + #{mod\ 1689}#) + (if (memq (quote load) #{esew\ 1675}#) + #{e\ 1717}# + (#{chi-void\ 1341}#)))) + (if (memq (quote load) #{esew\ 1675}#) + (#{chi-install-global\ 1329}# + #{n\ 1715}# + (#{chi\ 1333}# + #{e\ 1686}# + #{r\ 1716}# + #{w\ 1687}# + #{mod\ 1689}#)) + (#{chi-void\ 1341}#))) + (if (memv #{m\ 1674}# (quote (c&e))) + (let ((#{e\ 1718}# + (#{chi-install-global\ 1329}# + #{n\ 1715}# + (#{chi\ 1333}# + #{e\ 1686}# + #{r\ 1716}# + #{w\ 1687}# + #{mod\ 1689}#)))) (begin - (top-level-eval-hook76 e536 mod507) - e536)) + (#{top-level-eval-hook\ 1258}# + #{e\ 1718}# + #{mod\ 1689}#) + #{e\ 1718}#)) (begin - (if (memq (quote eval) esew493) - (top-level-eval-hook76 - (chi-install-global147 - n533 - (chi151 e504 r534 w505 mod507)) - mod507)) - (chi-void159))))) - (if (memv type502 (quote (define-form))) - (let ((n537 (id-var-name137 value503 w505))) - (let ((type538 - (binding-type107 - (lookup112 n537 r490 mod507)))) - (if (memv type538 + (if (memq (quote eval) #{esew\ 1675}#) + (#{top-level-eval-hook\ 1258}# + (#{chi-install-global\ 1329}# + #{n\ 1715}# + (#{chi\ 1333}# + #{e\ 1686}# + #{r\ 1716}# + #{w\ 1687}# + #{mod\ 1689}#)) + #{mod\ 1689}#)) + (#{chi-void\ 1341}#))))) + (if (memv #{type\ 1684}# (quote (define-form))) + (let ((#{n\ 1719}# + (#{id-var-name\ 1319}# + #{value\ 1685}# + #{w\ 1687}#))) + (let ((#{type\ 1720}# + (#{binding-type\ 1289}# + (#{lookup\ 1294}# + #{n\ 1719}# + #{r\ 1672}# + #{mod\ 1689}#)))) + (if (memv #{type\ 1720}# '(global core macro module-ref)) (begin (if (if (not (module-local-variable (current-module) - n537)) + #{n\ 1719}#)) (current-module) #f) - (module-define! - (current-module) - n537 - #f)) - (let ((x539 (build-global-definition90 - s506 - n537 - (chi151 - e504 - r490 - w505 - mod507)))) + (let ((#{old\ 1721}# + (module-variable + (current-module) + #{n\ 1719}#))) + (module-define! + (current-module) + #{n\ 1719}# + (if (variable? #{old\ 1721}#) + (variable-ref #{old\ 1721}#) + #f)))) + (let ((#{x\ 1722}# + (#{build-global-definition\ 1272}# + #{s\ 1688}# + #{n\ 1719}# + (#{chi\ 1333}# + #{e\ 1686}# + #{r\ 1672}# + #{w\ 1687}# + #{mod\ 1689}#)))) (begin - (if (eq? m492 (quote c&e)) - (top-level-eval-hook76 x539 mod507)) - x539))) - (if (memv type538 + (if (eq? #{m\ 1674}# (quote c&e)) + (#{top-level-eval-hook\ 1258}# + #{x\ 1722}# + #{mod\ 1689}#)) + #{x\ 1722}#))) + (if (memv #{type\ 1720}# '(displaced-lexical)) (syntax-violation #f "identifier out of context" - e504 - (wrap143 value503 w505 mod507)) + #{e\ 1686}# + (#{wrap\ 1325}# + #{value\ 1685}# + #{w\ 1687}# + #{mod\ 1689}#)) (syntax-violation #f "cannot define keyword at top level" - e504 - (wrap143 value503 w505 mod507)))))) - (let ((x540 (chi-expr152 - type502 - value503 - e504 - r490 - w505 - s506 - mod507))) + #{e\ 1686}# + (#{wrap\ 1325}# + #{value\ 1685}# + #{w\ 1687}# + #{mod\ 1689}#)))))) + (let ((#{x\ 1723}# + (#{chi-expr\ 1334}# + #{type\ 1684}# + #{value\ 1685}# + #{e\ 1686}# + #{r\ 1672}# + #{w\ 1687}# + #{s\ 1688}# + #{mod\ 1689}#))) (begin - (if (eq? m492 (quote c&e)) - (top-level-eval-hook76 x540 mod507)) - x540))))))))))) - (syntax-type149 - (lambda (e541 r542 w543 s544 rib545 mod546 for-car?547) - (if (symbol? e541) - (let ((n548 (id-var-name137 e541 w543))) - (let ((b549 (lookup112 n548 r542 mod546))) - (let ((type550 (binding-type107 b549))) - (if (memv type550 (quote (lexical))) + (if (eq? #{m\ 1674}# (quote c&e)) + (#{top-level-eval-hook\ 1258}# + #{x\ 1723}# + #{mod\ 1689}#)) + #{x\ 1723}#))))))))))) + (#{syntax-type\ 1331}# + (lambda (#{e\ 1724}# + #{r\ 1725}# + #{w\ 1726}# + #{s\ 1727}# + #{rib\ 1728}# + #{mod\ 1729}# + #{for-car?\ 1730}#) + (if (symbol? #{e\ 1724}#) + (let ((#{n\ 1731}# + (#{id-var-name\ 1319}# #{e\ 1724}# #{w\ 1726}#))) + (let ((#{b\ 1732}# + (#{lookup\ 1294}# + #{n\ 1731}# + #{r\ 1725}# + #{mod\ 1729}#))) + (let ((#{type\ 1733}# + (#{binding-type\ 1289}# #{b\ 1732}#))) + (if (memv #{type\ 1733}# (quote (lexical))) (values - type550 - (binding-value108 b549) - e541 - w543 - s544 - mod546) - (if (memv type550 (quote (global))) - (values type550 n548 e541 w543 s544 mod546) - (if (memv type550 (quote (macro))) - (if for-car?547 + #{type\ 1733}# + (#{binding-value\ 1290}# #{b\ 1732}#) + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{type\ 1733}# (quote (global))) + (values + #{type\ 1733}# + #{n\ 1731}# + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{type\ 1733}# (quote (macro))) + (if #{for-car?\ 1730}# (values - type550 - (binding-value108 b549) - e541 - w543 - s544 - mod546) - (syntax-type149 - (chi-macro154 - (binding-value108 b549) - e541 - r542 - w543 - rib545 - mod546) - r542 + #{type\ 1733}# + (#{binding-value\ 1290}# #{b\ 1732}#) + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (#{syntax-type\ 1331}# + (#{chi-macro\ 1336}# + (#{binding-value\ 1290}# #{b\ 1732}#) + #{e\ 1724}# + #{r\ 1725}# + #{w\ 1726}# + #{rib\ 1728}# + #{mod\ 1729}#) + #{r\ 1725}# '(()) - s544 - rib545 - mod546 + #{s\ 1727}# + #{rib\ 1728}# + #{mod\ 1729}# #f)) (values - type550 - (binding-value108 b549) - e541 - w543 - s544 - mod546))))))) - (if (pair? e541) - (let ((first551 (car e541))) + #{type\ 1733}# + (#{binding-value\ 1290}# #{b\ 1732}#) + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#))))))) + (if (pair? #{e\ 1724}#) + (let ((#{first\ 1734}# (car #{e\ 1724}#))) (call-with-values (lambda () - (syntax-type149 - first551 - r542 - w543 - s544 - rib545 - mod546 + (#{syntax-type\ 1331}# + #{first\ 1734}# + #{r\ 1725}# + #{w\ 1726}# + #{s\ 1727}# + #{rib\ 1728}# + #{mod\ 1729}# #t)) - (lambda (ftype552 fval553 fe554 fw555 fs556 fmod557) - (if (memv ftype552 (quote (lexical))) + (lambda (#{ftype\ 1735}# + #{fval\ 1736}# + #{fe\ 1737}# + #{fw\ 1738}# + #{fs\ 1739}# + #{fmod\ 1740}#) + (if (memv #{ftype\ 1735}# (quote (lexical))) (values 'lexical-call - fval553 - e541 - w543 - s544 - mod546) - (if (memv ftype552 (quote (global))) + #{fval\ 1736}# + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{ftype\ 1735}# (quote (global))) (values 'global-call - (make-syntax-object98 fval553 w543 fmod557) - e541 - w543 - s544 - mod546) - (if (memv ftype552 (quote (macro))) - (syntax-type149 - (chi-macro154 - fval553 - e541 - r542 - w543 - rib545 - mod546) - r542 + (#{make-syntax-object\ 1280}# + #{fval\ 1736}# + #{w\ 1726}# + #{fmod\ 1740}#) + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{ftype\ 1735}# (quote (macro))) + (#{syntax-type\ 1331}# + (#{chi-macro\ 1336}# + #{fval\ 1736}# + #{e\ 1724}# + #{r\ 1725}# + #{w\ 1726}# + #{rib\ 1728}# + #{mod\ 1729}#) + #{r\ 1725}# '(()) - s544 - rib545 - mod546 - for-car?547) - (if (memv ftype552 (quote (module-ref))) + #{s\ 1727}# + #{rib\ 1728}# + #{mod\ 1729}# + #{for-car?\ 1730}#) + (if (memv #{ftype\ 1735}# (quote (module-ref))) (call-with-values - (lambda () (fval553 e541)) - (lambda (sym558 mod559) - (syntax-type149 - sym558 - r542 - w543 - s544 - rib545 - mod559 - for-car?547))) - (if (memv ftype552 (quote (core))) + (lambda () (#{fval\ 1736}# #{e\ 1724}#)) + (lambda (#{sym\ 1741}# #{mod\ 1742}#) + (#{syntax-type\ 1331}# + #{sym\ 1741}# + #{r\ 1725}# + #{w\ 1726}# + #{s\ 1727}# + #{rib\ 1728}# + #{mod\ 1742}# + #{for-car?\ 1730}#))) + (if (memv #{ftype\ 1735}# (quote (core))) (values 'core-form - fval553 - e541 - w543 - s544 - mod546) - (if (memv ftype552 (quote (local-syntax))) + #{fval\ 1736}# + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{ftype\ 1735}# + '(local-syntax)) (values 'local-syntax-form - fval553 - e541 - w543 - s544 - mod546) - (if (memv ftype552 (quote (begin))) + #{fval\ 1736}# + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{ftype\ 1735}# (quote (begin))) (values 'begin-form #f - e541 - w543 - s544 - mod546) - (if (memv ftype552 (quote (eval-when))) + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{ftype\ 1735}# + '(eval-when)) (values 'eval-when-form #f - e541 - w543 - s544 - mod546) - (if (memv ftype552 (quote (define))) - ((lambda (tmp560) - ((lambda (tmp561) - (if (if tmp561 - (apply (lambda (_562 - name563 - val564) - (id?115 - name563)) - tmp561) + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (if (memv #{ftype\ 1735}# + '(define)) + ((lambda (#{tmp\ 1743}#) + ((lambda (#{tmp\ 1744}#) + (if (if #{tmp\ 1744}# + (apply (lambda (#{_\ 1745}# + #{name\ 1746}# + #{val\ 1747}#) + (#{id?\ 1297}# + #{name\ 1746}#)) + #{tmp\ 1744}#) #f) - (apply (lambda (_565 - name566 - val567) + (apply (lambda (#{_\ 1748}# + #{name\ 1749}# + #{val\ 1750}#) (values 'define-form - name566 - val567 - w543 - s544 - mod546)) - tmp561) - ((lambda (tmp568) - (if (if tmp568 - (apply (lambda (_569 - name570 - args571 - e1572 - e2573) - (if (id?115 - name570) - (valid-bound-ids?140 - (lambda-var-list163 - args571)) + #{name\ 1749}# + #{val\ 1750}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#)) + #{tmp\ 1744}#) + ((lambda (#{tmp\ 1751}#) + (if (if #{tmp\ 1751}# + (apply (lambda (#{_\ 1752}# + #{name\ 1753}# + #{args\ 1754}# + #{e1\ 1755}# + #{e2\ 1756}#) + (if (#{id?\ 1297}# + #{name\ 1753}#) + (#{valid-bound-ids?\ 1322}# + (#{lambda-var-list\ 1345}# + #{args\ 1754}#)) #f)) - tmp568) + #{tmp\ 1751}#) #f) - (apply (lambda (_574 - name575 - args576 - e1577 - e2578) + (apply (lambda (#{_\ 1757}# + #{name\ 1758}# + #{args\ 1759}# + #{e1\ 1760}# + #{e2\ 1761}#) (values 'define-form - (wrap143 - name575 - w543 - mod546) - (decorate-source80 + (#{wrap\ 1325}# + #{name\ 1758}# + #{w\ 1726}# + #{mod\ 1729}#) + (#{decorate-source\ 1262}# (cons '#(syntax-object lambda ((top) @@ -1992,33 +2295,33 @@ "i"))) (hygiene guile)) - (wrap143 - (cons args576 - (cons e1577 - e2578)) - w543 - mod546)) - s544) + (#{wrap\ 1325}# + (cons #{args\ 1759}# + (cons #{e1\ 1760}# + #{e2\ 1761}#)) + #{w\ 1726}# + #{mod\ 1729}#)) + #{s\ 1727}#) '(()) - s544 - mod546)) - tmp568) - ((lambda (tmp580) - (if (if tmp580 - (apply (lambda (_581 - name582) - (id?115 - name582)) - tmp580) + #{s\ 1727}# + #{mod\ 1729}#)) + #{tmp\ 1751}#) + ((lambda (#{tmp\ 1763}#) + (if (if #{tmp\ 1763}# + (apply (lambda (#{_\ 1764}# + #{name\ 1765}#) + (#{id?\ 1297}# + #{name\ 1765}#)) + #{tmp\ 1763}#) #f) - (apply (lambda (_583 - name584) + (apply (lambda (#{_\ 1766}# + #{name\ 1767}#) (values 'define-form - (wrap143 - name584 - w543 - mod546) + (#{wrap\ 1325}# + #{name\ 1767}# + #{w\ 1726}# + #{mod\ 1729}#) '(#(syntax-object if ((top) @@ -3295,2820 +3598,3179 @@ (hygiene guile))) '(()) - s544 - mod546)) - tmp580) + #{s\ 1727}# + #{mod\ 1729}#)) + #{tmp\ 1763}#) (syntax-violation #f "source expression failed to match any pattern" - tmp560))) + #{tmp\ 1743}#))) ($sc-dispatch - tmp560 + #{tmp\ 1743}# '(any any))))) ($sc-dispatch - tmp560 + #{tmp\ 1743}# '(any (any . any) any . each-any))))) ($sc-dispatch - tmp560 + #{tmp\ 1743}# '(any any any)))) - e541) - (if (memv ftype552 + #{e\ 1724}#) + (if (memv #{ftype\ 1735}# '(define-syntax)) - ((lambda (tmp585) - ((lambda (tmp586) - (if (if tmp586 - (apply (lambda (_587 - name588 - val589) - (id?115 - name588)) - tmp586) + ((lambda (#{tmp\ 1768}#) + ((lambda (#{tmp\ 1769}#) + (if (if #{tmp\ 1769}# + (apply (lambda (#{_\ 1770}# + #{name\ 1771}# + #{val\ 1772}#) + (#{id?\ 1297}# + #{name\ 1771}#)) + #{tmp\ 1769}#) #f) - (apply (lambda (_590 - name591 - val592) + (apply (lambda (#{_\ 1773}# + #{name\ 1774}# + #{val\ 1775}#) (values 'define-syntax-form - name591 - val592 - w543 - s544 - mod546)) - tmp586) + #{name\ 1774}# + #{val\ 1775}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#)) + #{tmp\ 1769}#) (syntax-violation #f "source expression failed to match any pattern" - tmp585))) + #{tmp\ 1768}#))) ($sc-dispatch - tmp585 + #{tmp\ 1768}# '(any any any)))) - e541) + #{e\ 1724}#) (values 'call #f - e541 - w543 - s544 - mod546)))))))))))))) - (if (syntax-object?99 e541) - (syntax-type149 - (syntax-object-expression100 e541) - r542 - (join-wraps134 w543 (syntax-object-wrap101 e541)) - s544 - rib545 - (let ((t593 (syntax-object-module102 e541))) - (if t593 t593 mod546)) - for-car?547) - (if (self-evaluating? e541) + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#)))))))))))))) + (if (#{syntax-object?\ 1281}# #{e\ 1724}#) + (#{syntax-type\ 1331}# + (#{syntax-object-expression\ 1282}# #{e\ 1724}#) + #{r\ 1725}# + (#{join-wraps\ 1316}# + #{w\ 1726}# + (#{syntax-object-wrap\ 1283}# #{e\ 1724}#)) + #{s\ 1727}# + #{rib\ 1728}# + (let ((#{t\ 1776}# + (#{syntax-object-module\ 1284}# #{e\ 1724}#))) + (if #{t\ 1776}# #{t\ 1776}# #{mod\ 1729}#)) + #{for-car?\ 1730}#) + (if (self-evaluating? #{e\ 1724}#) (values 'constant #f - e541 - w543 - s544 - mod546) - (values (quote other) #f e541 w543 s544 mod546))))))) - (chi-when-list148 - (lambda (e594 when-list595 w596) - (letrec ((f597 (lambda (when-list598 situations599) - (if (null? when-list598) - situations599 - (f597 (cdr when-list598) - (cons (let ((x600 (car when-list598))) - (if (free-id=?138 - x600 - '#(syntax-object - compile - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage - #(f - when-list - situations) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(e when-list w) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - maybe-name-value! - build-global-assignment - build-global-reference - analyze-variable - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-void - decorate-source - get-global-definition-hook - put-global-definition-hook - gensym-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - *mode* - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure - and-map*) - ((top) (top)) - ("i" "i"))) - (hygiene guile))) - 'compile - (if (free-id=?138 - x600 - '#(syntax-object - load - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage () () ()) - #(ribcage - #(f - when-list - situations) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(e when-list w) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - maybe-name-value! - build-global-assignment - build-global-reference - analyze-variable - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-void - decorate-source - get-global-definition-hook - put-global-definition-hook - gensym-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - *mode* - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure - and-map*) - ((top) (top)) - ("i" "i"))) - (hygiene guile))) - 'load - (if (free-id=?138 - x600 - '#(syntax-object - eval - ((top) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - when-list - situations) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - () - () - ()) - #(ribcage - #(e - when-list - w) - #((top) - (top) - (top)) - #("i" "i" "i")) - #(ribcage - (lambda-var-list - gen-var - strip - ellipsis? - chi-void - eval-local-transformer - chi-local-syntax - chi-lambda-clause - chi-body - chi-macro - chi-application - chi-expr - chi - chi-top - syntax-type - chi-when-list - chi-install-global - chi-top-sequence - chi-sequence - source-wrap - wrap - bound-id-member? - distinct-bound-ids? - valid-bound-ids? - bound-id=? - free-id=? - id-var-name - same-marks? - join-marks - join-wraps - smart-append - make-binding-wrap - extend-ribcage! - make-empty-ribcage - new-mark - anti-mark - the-anti-mark - top-marked? - top-wrap - empty-wrap - set-ribcage-labels! - set-ribcage-marks! - set-ribcage-symnames! - ribcage-labels - ribcage-marks - ribcage-symnames - ribcage? - make-ribcage - gen-labels - gen-label - make-rename - rename-marks - rename-new - rename-old - subst-rename? - wrap-subst - wrap-marks - make-wrap - id-sym-name&marks - id-sym-name - id? - nonsymbol-id? - global-extend - lookup - macros-only-env - extend-var-env - extend-env - null-env - binding-value - binding-type - make-binding - arg-check - source-annotation - no-source - set-syntax-object-module! - set-syntax-object-wrap! - set-syntax-object-expression! - syntax-object-module - syntax-object-wrap - syntax-object-expression - syntax-object? - make-syntax-object - build-lexical-var - build-letrec - build-named-let - build-let - build-sequence - build-data - build-primref - build-lambda - build-global-definition - maybe-name-value! - build-global-assignment - build-global-reference - analyze-variable - build-lexical-assignment - build-lexical-reference - build-conditional - build-application - build-void - decorate-source - get-global-definition-hook - put-global-definition-hook - gensym-hook - local-eval-hook - top-level-eval-hook - fx< - fx= - fx- - fx+ - *mode* - noexpand) - ((top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top) - (top)) - ("i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i" - "i")) - #(ribcage - (define-structure - and-map*) - ((top) (top)) - ("i" "i"))) - (hygiene guile))) - 'eval - (syntax-violation - 'eval-when - "invalid situation" - e594 - (wrap143 - x600 - w596 - #f)))))) - situations599)))))) - (f597 when-list595 (quote ()))))) - (chi-install-global147 - (lambda (name601 e602) - (build-global-definition90 + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#) + (values + 'other + #f + #{e\ 1724}# + #{w\ 1726}# + #{s\ 1727}# + #{mod\ 1729}#))))))) + (#{chi-when-list\ 1330}# + (lambda (#{e\ 1777}# #{when-list\ 1778}# #{w\ 1779}#) + (letrec ((#{f\ 1780}# + (lambda (#{when-list\ 1781}# #{situations\ 1782}#) + (if (null? #{when-list\ 1781}#) + #{situations\ 1782}# + (#{f\ 1780}# + (cdr #{when-list\ 1781}#) + (cons (let ((#{x\ 1783}# + (car #{when-list\ 1781}#))) + (if (#{free-id=?\ 1320}# + #{x\ 1783}# + '#(syntax-object + compile + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(f when-list situations) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + decorate-source + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + 'compile + (if (#{free-id=?\ 1320}# + #{x\ 1783}# + '#(syntax-object + load + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(f when-list situations) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + decorate-source + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + 'load + (if (#{free-id=?\ 1320}# + #{x\ 1783}# + '#(syntax-object + eval + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(f + when-list + situations) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e when-list w) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + ellipsis? + chi-void + eval-local-transformer + chi-local-syntax + chi-lambda-clause + chi-body + chi-macro + chi-application + chi-expr + chi + chi-top + syntax-type + chi-when-list + chi-install-global + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + distinct-bound-ids? + valid-bound-ids? + bound-id=? + free-id=? + id-var-name + same-marks? + join-marks + join-wraps + smart-append + make-binding-wrap + extend-ribcage! + make-empty-ribcage + new-mark + anti-mark + the-anti-mark + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + gen-labels + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + macros-only-env + extend-var-env + extend-env + null-env + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + set-syntax-object-module! + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-module + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + build-lexical-var + build-letrec + build-named-let + build-let + build-sequence + build-data + build-primref + build-lambda + build-global-definition + maybe-name-value! + build-global-assignment + build-global-reference + analyze-variable + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + build-void + decorate-source + get-global-definition-hook + put-global-definition-hook + gensym-hook + local-eval-hook + top-level-eval-hook + fx< + fx= + fx- + fx+ + *mode* + noexpand) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + (define-structure + and-map*) + ((top) (top)) + ("i" "i"))) + (hygiene guile))) + 'eval + (syntax-violation + 'eval-when + "invalid situation" + #{e\ 1777}# + (#{wrap\ 1325}# + #{x\ 1783}# + #{w\ 1779}# + #f)))))) + #{situations\ 1782}#)))))) + (#{f\ 1780}# #{when-list\ 1778}# (quote ()))))) + (#{chi-install-global\ 1329}# + (lambda (#{name\ 1784}# #{e\ 1785}#) + (#{build-global-definition\ 1272}# #f - name601 - (if (let ((v603 (module-variable (current-module) name601))) - (if v603 - (if (variable-bound? v603) - (if (macro? (variable-ref v603)) - (not (eq? (macro-type (variable-ref v603)) + #{name\ 1784}# + (if (let ((#{v\ 1786}# + (module-variable + (current-module) + #{name\ 1784}#))) + (if #{v\ 1786}# + (if (variable-bound? #{v\ 1786}#) + (if (macro? (variable-ref #{v\ 1786}#)) + (not (eq? (macro-type (variable-ref #{v\ 1786}#)) 'syncase-macro)) #f) #f) #f)) - (build-application82 + (#{build-application\ 1264}# #f - (build-primref92 + (#{build-primref\ 1274}# #f 'make-extended-syncase-macro) - (list (build-application82 + (list (#{build-application\ 1264}# #f - (build-primref92 #f (quote module-ref)) - (list (build-application82 + (#{build-primref\ 1274}# #f (quote module-ref)) + (list (#{build-application\ 1264}# #f - (build-primref92 + (#{build-primref\ 1274}# #f 'current-module) '()) - (build-data93 #f name601))) - (build-data93 #f (quote macro)) - e602)) - (build-application82 + (#{build-data\ 1275}# #f #{name\ 1784}#))) + (#{build-data\ 1275}# #f (quote macro)) + #{e\ 1785}#)) + (#{build-application\ 1264}# #f - (build-primref92 #f (quote make-syncase-macro)) - (list (build-data93 #f (quote macro)) e602)))))) - (chi-top-sequence146 - (lambda (body604 r605 w606 s607 m608 esew609 mod610) - (build-sequence94 - s607 - (letrec ((dobody611 - (lambda (body612 r613 w614 m615 esew616 mod617) - (if (null? body612) + (#{build-primref\ 1274}# + #f + 'make-syncase-macro) + (list (#{build-data\ 1275}# #f (quote macro)) + #{e\ 1785}#)))))) + (#{chi-top-sequence\ 1328}# + (lambda (#{body\ 1787}# + #{r\ 1788}# + #{w\ 1789}# + #{s\ 1790}# + #{m\ 1791}# + #{esew\ 1792}# + #{mod\ 1793}#) + (#{build-sequence\ 1276}# + #{s\ 1790}# + (letrec ((#{dobody\ 1794}# + (lambda (#{body\ 1795}# + #{r\ 1796}# + #{w\ 1797}# + #{m\ 1798}# + #{esew\ 1799}# + #{mod\ 1800}#) + (if (null? #{body\ 1795}#) '() - (let ((first618 - (chi-top150 - (car body612) - r613 - w614 - m615 - esew616 - mod617))) - (cons first618 - (dobody611 - (cdr body612) - r613 - w614 - m615 - esew616 - mod617))))))) - (dobody611 body604 r605 w606 m608 esew609 mod610))))) - (chi-sequence145 - (lambda (body619 r620 w621 s622 mod623) - (build-sequence94 - s622 - (letrec ((dobody624 - (lambda (body625 r626 w627 mod628) - (if (null? body625) + (let ((#{first\ 1801}# + (#{chi-top\ 1332}# + (car #{body\ 1795}#) + #{r\ 1796}# + #{w\ 1797}# + #{m\ 1798}# + #{esew\ 1799}# + #{mod\ 1800}#))) + (cons #{first\ 1801}# + (#{dobody\ 1794}# + (cdr #{body\ 1795}#) + #{r\ 1796}# + #{w\ 1797}# + #{m\ 1798}# + #{esew\ 1799}# + #{mod\ 1800}#))))))) + (#{dobody\ 1794}# + #{body\ 1787}# + #{r\ 1788}# + #{w\ 1789}# + #{m\ 1791}# + #{esew\ 1792}# + #{mod\ 1793}#))))) + (#{chi-sequence\ 1327}# + (lambda (#{body\ 1802}# + #{r\ 1803}# + #{w\ 1804}# + #{s\ 1805}# + #{mod\ 1806}#) + (#{build-sequence\ 1276}# + #{s\ 1805}# + (letrec ((#{dobody\ 1807}# + (lambda (#{body\ 1808}# + #{r\ 1809}# + #{w\ 1810}# + #{mod\ 1811}#) + (if (null? #{body\ 1808}#) '() - (let ((first629 - (chi151 - (car body625) - r626 - w627 - mod628))) - (cons first629 - (dobody624 - (cdr body625) - r626 - w627 - mod628))))))) - (dobody624 body619 r620 w621 mod623))))) - (source-wrap144 - (lambda (x630 w631 s632 defmod633) - (wrap143 - (decorate-source80 x630 s632) - w631 - defmod633))) - (wrap143 - (lambda (x634 w635 defmod636) - (if (if (null? (wrap-marks118 w635)) - (null? (wrap-subst119 w635)) + (let ((#{first\ 1812}# + (#{chi\ 1333}# + (car #{body\ 1808}#) + #{r\ 1809}# + #{w\ 1810}# + #{mod\ 1811}#))) + (cons #{first\ 1812}# + (#{dobody\ 1807}# + (cdr #{body\ 1808}#) + #{r\ 1809}# + #{w\ 1810}# + #{mod\ 1811}#))))))) + (#{dobody\ 1807}# + #{body\ 1802}# + #{r\ 1803}# + #{w\ 1804}# + #{mod\ 1806}#))))) + (#{source-wrap\ 1326}# + (lambda (#{x\ 1813}# + #{w\ 1814}# + #{s\ 1815}# + #{defmod\ 1816}#) + (#{wrap\ 1325}# + (#{decorate-source\ 1262}# + #{x\ 1813}# + #{s\ 1815}#) + #{w\ 1814}# + #{defmod\ 1816}#))) + (#{wrap\ 1325}# + (lambda (#{x\ 1817}# #{w\ 1818}# #{defmod\ 1819}#) + (if (if (null? (#{wrap-marks\ 1300}# #{w\ 1818}#)) + (null? (#{wrap-subst\ 1301}# #{w\ 1818}#)) #f) - x634 - (if (syntax-object?99 x634) - (make-syntax-object98 - (syntax-object-expression100 x634) - (join-wraps134 w635 (syntax-object-wrap101 x634)) - (syntax-object-module102 x634)) - (if (null? x634) - x634 - (make-syntax-object98 x634 w635 defmod636)))))) - (bound-id-member?142 - (lambda (x637 list638) - (if (not (null? list638)) - (let ((t639 (bound-id=?139 x637 (car list638)))) - (if t639 - t639 - (bound-id-member?142 x637 (cdr list638)))) + #{x\ 1817}# + (if (#{syntax-object?\ 1281}# #{x\ 1817}#) + (#{make-syntax-object\ 1280}# + (#{syntax-object-expression\ 1282}# #{x\ 1817}#) + (#{join-wraps\ 1316}# + #{w\ 1818}# + (#{syntax-object-wrap\ 1283}# #{x\ 1817}#)) + (#{syntax-object-module\ 1284}# #{x\ 1817}#)) + (if (null? #{x\ 1817}#) + #{x\ 1817}# + (#{make-syntax-object\ 1280}# + #{x\ 1817}# + #{w\ 1818}# + #{defmod\ 1819}#)))))) + (#{bound-id-member?\ 1324}# + (lambda (#{x\ 1820}# #{list\ 1821}#) + (if (not (null? #{list\ 1821}#)) + (let ((#{t\ 1822}# + (#{bound-id=?\ 1321}# + #{x\ 1820}# + (car #{list\ 1821}#)))) + (if #{t\ 1822}# + #{t\ 1822}# + (#{bound-id-member?\ 1324}# + #{x\ 1820}# + (cdr #{list\ 1821}#)))) #f))) - (distinct-bound-ids?141 - (lambda (ids640) - (letrec ((distinct?641 - (lambda (ids642) - (let ((t643 (null? ids642))) - (if t643 - t643 - (if (not (bound-id-member?142 - (car ids642) - (cdr ids642))) - (distinct?641 (cdr ids642)) + (#{distinct-bound-ids?\ 1323}# + (lambda (#{ids\ 1823}#) + (letrec ((#{distinct?\ 1824}# + (lambda (#{ids\ 1825}#) + (let ((#{t\ 1826}# (null? #{ids\ 1825}#))) + (if #{t\ 1826}# + #{t\ 1826}# + (if (not (#{bound-id-member?\ 1324}# + (car #{ids\ 1825}#) + (cdr #{ids\ 1825}#))) + (#{distinct?\ 1824}# (cdr #{ids\ 1825}#)) #f)))))) - (distinct?641 ids640)))) - (valid-bound-ids?140 - (lambda (ids644) - (if (letrec ((all-ids?645 - (lambda (ids646) - (let ((t647 (null? ids646))) - (if t647 - t647 - (if (id?115 (car ids646)) - (all-ids?645 (cdr ids646)) + (#{distinct?\ 1824}# #{ids\ 1823}#)))) + (#{valid-bound-ids?\ 1322}# + (lambda (#{ids\ 1827}#) + (if (letrec ((#{all-ids?\ 1828}# + (lambda (#{ids\ 1829}#) + (let ((#{t\ 1830}# (null? #{ids\ 1829}#))) + (if #{t\ 1830}# + #{t\ 1830}# + (if (#{id?\ 1297}# (car #{ids\ 1829}#)) + (#{all-ids?\ 1828}# (cdr #{ids\ 1829}#)) #f)))))) - (all-ids?645 ids644)) - (distinct-bound-ids?141 ids644) + (#{all-ids?\ 1828}# #{ids\ 1827}#)) + (#{distinct-bound-ids?\ 1323}# #{ids\ 1827}#) #f))) - (bound-id=?139 - (lambda (i648 j649) - (if (if (syntax-object?99 i648) - (syntax-object?99 j649) + (#{bound-id=?\ 1321}# + (lambda (#{i\ 1831}# #{j\ 1832}#) + (if (if (#{syntax-object?\ 1281}# #{i\ 1831}#) + (#{syntax-object?\ 1281}# #{j\ 1832}#) #f) - (if (eq? (syntax-object-expression100 i648) - (syntax-object-expression100 j649)) - (same-marks?136 - (wrap-marks118 (syntax-object-wrap101 i648)) - (wrap-marks118 (syntax-object-wrap101 j649))) + (if (eq? (#{syntax-object-expression\ 1282}# #{i\ 1831}#) + (#{syntax-object-expression\ 1282}# #{j\ 1832}#)) + (#{same-marks?\ 1318}# + (#{wrap-marks\ 1300}# + (#{syntax-object-wrap\ 1283}# #{i\ 1831}#)) + (#{wrap-marks\ 1300}# + (#{syntax-object-wrap\ 1283}# #{j\ 1832}#))) #f) - (eq? i648 j649)))) - (free-id=?138 - (lambda (i650 j651) - (if (eq? (let ((x652 i650)) - (if (syntax-object?99 x652) - (syntax-object-expression100 x652) - x652)) - (let ((x653 j651)) - (if (syntax-object?99 x653) - (syntax-object-expression100 x653) - x653))) - (eq? (id-var-name137 i650 (quote (()))) - (id-var-name137 j651 (quote (())))) + (eq? #{i\ 1831}# #{j\ 1832}#)))) + (#{free-id=?\ 1320}# + (lambda (#{i\ 1833}# #{j\ 1834}#) + (if (eq? (let ((#{x\ 1835}# #{i\ 1833}#)) + (if (#{syntax-object?\ 1281}# #{x\ 1835}#) + (#{syntax-object-expression\ 1282}# #{x\ 1835}#) + #{x\ 1835}#)) + (let ((#{x\ 1836}# #{j\ 1834}#)) + (if (#{syntax-object?\ 1281}# #{x\ 1836}#) + (#{syntax-object-expression\ 1282}# #{x\ 1836}#) + #{x\ 1836}#))) + (eq? (#{id-var-name\ 1319}# #{i\ 1833}# (quote (()))) + (#{id-var-name\ 1319}# #{j\ 1834}# (quote (())))) #f))) - (id-var-name137 - (lambda (id654 w655) - (letrec ((search-vector-rib658 - (lambda (sym664 - subst665 - marks666 - symnames667 - ribcage668) - (let ((n669 (vector-length symnames667))) - (letrec ((f670 (lambda (i671) - (if (fx=74 i671 n669) - (search656 - sym664 - (cdr subst665) - marks666) - (if (if (eq? (vector-ref - symnames667 - i671) - sym664) - (same-marks?136 - marks666 - (vector-ref - (ribcage-marks125 - ribcage668) - i671)) - #f) - (values + (#{id-var-name\ 1319}# + (lambda (#{id\ 1837}# #{w\ 1838}#) + (letrec ((#{search-vector-rib\ 1841}# + (lambda (#{sym\ 1847}# + #{subst\ 1848}# + #{marks\ 1849}# + #{symnames\ 1850}# + #{ribcage\ 1851}#) + (let ((#{n\ 1852}# + (vector-length #{symnames\ 1850}#))) + (letrec ((#{f\ 1853}# + (lambda (#{i\ 1854}#) + (if (#{fx=\ 1256}# + #{i\ 1854}# + #{n\ 1852}#) + (#{search\ 1839}# + #{sym\ 1847}# + (cdr #{subst\ 1848}#) + #{marks\ 1849}#) + (if (if (eq? (vector-ref + #{symnames\ 1850}# + #{i\ 1854}#) + #{sym\ 1847}#) + (#{same-marks?\ 1318}# + #{marks\ 1849}# (vector-ref - (ribcage-labels126 - ribcage668) - i671) - marks666) - (f670 (fx+72 i671 1))))))) - (f670 0))))) - (search-list-rib657 - (lambda (sym672 - subst673 - marks674 - symnames675 - ribcage676) - (letrec ((f677 (lambda (symnames678 i679) - (if (null? symnames678) - (search656 - sym672 - (cdr subst673) - marks674) - (if (if (eq? (car symnames678) - sym672) - (same-marks?136 - marks674 - (list-ref - (ribcage-marks125 - ribcage676) - i679)) - #f) - (values + (#{ribcage-marks\ 1307}# + #{ribcage\ 1851}#) + #{i\ 1854}#)) + #f) + (values + (vector-ref + (#{ribcage-labels\ 1308}# + #{ribcage\ 1851}#) + #{i\ 1854}#) + #{marks\ 1849}#) + (#{f\ 1853}# + (#{fx+\ 1254}# + #{i\ 1854}# + 1))))))) + (#{f\ 1853}# 0))))) + (#{search-list-rib\ 1840}# + (lambda (#{sym\ 1855}# + #{subst\ 1856}# + #{marks\ 1857}# + #{symnames\ 1858}# + #{ribcage\ 1859}#) + (letrec ((#{f\ 1860}# + (lambda (#{symnames\ 1861}# #{i\ 1862}#) + (if (null? #{symnames\ 1861}#) + (#{search\ 1839}# + #{sym\ 1855}# + (cdr #{subst\ 1856}#) + #{marks\ 1857}#) + (if (if (eq? (car #{symnames\ 1861}#) + #{sym\ 1855}#) + (#{same-marks?\ 1318}# + #{marks\ 1857}# (list-ref - (ribcage-labels126 - ribcage676) - i679) - marks674) - (f677 (cdr symnames678) - (fx+72 i679 1))))))) - (f677 symnames675 0)))) - (search656 - (lambda (sym680 subst681 marks682) - (if (null? subst681) - (values #f marks682) - (let ((fst683 (car subst681))) - (if (eq? fst683 (quote shift)) - (search656 - sym680 - (cdr subst681) - (cdr marks682)) - (let ((symnames684 - (ribcage-symnames124 fst683))) - (if (vector? symnames684) - (search-vector-rib658 - sym680 - subst681 - marks682 - symnames684 - fst683) - (search-list-rib657 - sym680 - subst681 - marks682 - symnames684 - fst683))))))))) - (if (symbol? id654) - (let ((t685 (call-with-values - (lambda () - (search656 - id654 - (wrap-subst119 w655) - (wrap-marks118 w655))) - (lambda (x687 . ignore686) x687)))) - (if t685 t685 id654)) - (if (syntax-object?99 id654) - (let ((id688 (syntax-object-expression100 id654)) - (w1689 (syntax-object-wrap101 id654))) - (let ((marks690 - (join-marks135 - (wrap-marks118 w655) - (wrap-marks118 w1689)))) + (#{ribcage-marks\ 1307}# + #{ribcage\ 1859}#) + #{i\ 1862}#)) + #f) + (values + (list-ref + (#{ribcage-labels\ 1308}# + #{ribcage\ 1859}#) + #{i\ 1862}#) + #{marks\ 1857}#) + (#{f\ 1860}# + (cdr #{symnames\ 1861}#) + (#{fx+\ 1254}# + #{i\ 1862}# + 1))))))) + (#{f\ 1860}# #{symnames\ 1858}# 0)))) + (#{search\ 1839}# + (lambda (#{sym\ 1863}# + #{subst\ 1864}# + #{marks\ 1865}#) + (if (null? #{subst\ 1864}#) + (values #f #{marks\ 1865}#) + (let ((#{fst\ 1866}# (car #{subst\ 1864}#))) + (if (eq? #{fst\ 1866}# (quote shift)) + (#{search\ 1839}# + #{sym\ 1863}# + (cdr #{subst\ 1864}#) + (cdr #{marks\ 1865}#)) + (let ((#{symnames\ 1867}# + (#{ribcage-symnames\ 1306}# + #{fst\ 1866}#))) + (if (vector? #{symnames\ 1867}#) + (#{search-vector-rib\ 1841}# + #{sym\ 1863}# + #{subst\ 1864}# + #{marks\ 1865}# + #{symnames\ 1867}# + #{fst\ 1866}#) + (#{search-list-rib\ 1840}# + #{sym\ 1863}# + #{subst\ 1864}# + #{marks\ 1865}# + #{symnames\ 1867}# + #{fst\ 1866}#))))))))) + (if (symbol? #{id\ 1837}#) + (let ((#{t\ 1868}# + (call-with-values + (lambda () + (#{search\ 1839}# + #{id\ 1837}# + (#{wrap-subst\ 1301}# #{w\ 1838}#) + (#{wrap-marks\ 1300}# #{w\ 1838}#))) + (lambda (#{x\ 1870}# . #{ignore\ 1869}#) + #{x\ 1870}#)))) + (if #{t\ 1868}# #{t\ 1868}# #{id\ 1837}#)) + (if (#{syntax-object?\ 1281}# #{id\ 1837}#) + (let ((#{id\ 1871}# + (#{syntax-object-expression\ 1282}# #{id\ 1837}#)) + (#{w1\ 1872}# + (#{syntax-object-wrap\ 1283}# #{id\ 1837}#))) + (let ((#{marks\ 1873}# + (#{join-marks\ 1317}# + (#{wrap-marks\ 1300}# #{w\ 1838}#) + (#{wrap-marks\ 1300}# #{w1\ 1872}#)))) (call-with-values (lambda () - (search656 id688 (wrap-subst119 w655) marks690)) - (lambda (new-id691 marks692) - (let ((t693 new-id691)) - (if t693 - t693 - (let ((t694 (call-with-values - (lambda () - (search656 - id688 - (wrap-subst119 w1689) - marks692)) - (lambda (x696 . ignore695) - x696)))) - (if t694 t694 id688)))))))) + (#{search\ 1839}# + #{id\ 1871}# + (#{wrap-subst\ 1301}# #{w\ 1838}#) + #{marks\ 1873}#)) + (lambda (#{new-id\ 1874}# #{marks\ 1875}#) + (let ((#{t\ 1876}# #{new-id\ 1874}#)) + (if #{t\ 1876}# + #{t\ 1876}# + (let ((#{t\ 1877}# + (call-with-values + (lambda () + (#{search\ 1839}# + #{id\ 1871}# + (#{wrap-subst\ 1301}# + #{w1\ 1872}#) + #{marks\ 1875}#)) + (lambda (#{x\ 1879}# + . + #{ignore\ 1878}#) + #{x\ 1879}#)))) + (if #{t\ 1877}# + #{t\ 1877}# + #{id\ 1871}#)))))))) (syntax-violation 'id-var-name "invalid id" - id654)))))) - (same-marks?136 - (lambda (x697 y698) - (let ((t699 (eq? x697 y698))) - (if t699 - t699 - (if (not (null? x697)) - (if (not (null? y698)) - (if (eq? (car x697) (car y698)) - (same-marks?136 (cdr x697) (cdr y698)) + #{id\ 1837}#)))))) + (#{same-marks?\ 1318}# + (lambda (#{x\ 1880}# #{y\ 1881}#) + (let ((#{t\ 1882}# (eq? #{x\ 1880}# #{y\ 1881}#))) + (if #{t\ 1882}# + #{t\ 1882}# + (if (not (null? #{x\ 1880}#)) + (if (not (null? #{y\ 1881}#)) + (if (eq? (car #{x\ 1880}#) (car #{y\ 1881}#)) + (#{same-marks?\ 1318}# + (cdr #{x\ 1880}#) + (cdr #{y\ 1881}#)) #f) #f) #f))))) - (join-marks135 - (lambda (m1700 m2701) - (smart-append133 m1700 m2701))) - (join-wraps134 - (lambda (w1702 w2703) - (let ((m1704 (wrap-marks118 w1702)) - (s1705 (wrap-subst119 w1702))) - (if (null? m1704) - (if (null? s1705) - w2703 - (make-wrap117 - (wrap-marks118 w2703) - (smart-append133 s1705 (wrap-subst119 w2703)))) - (make-wrap117 - (smart-append133 m1704 (wrap-marks118 w2703)) - (smart-append133 s1705 (wrap-subst119 w2703))))))) - (smart-append133 - (lambda (m1706 m2707) - (if (null? m2707) m1706 (append m1706 m2707)))) - (make-binding-wrap132 - (lambda (ids708 labels709 w710) - (if (null? ids708) - w710 - (make-wrap117 - (wrap-marks118 w710) - (cons (let ((labelvec711 (list->vector labels709))) - (let ((n712 (vector-length labelvec711))) - (let ((symnamevec713 (make-vector n712)) - (marksvec714 (make-vector n712))) + (#{join-marks\ 1317}# + (lambda (#{m1\ 1883}# #{m2\ 1884}#) + (#{smart-append\ 1315}# + #{m1\ 1883}# + #{m2\ 1884}#))) + (#{join-wraps\ 1316}# + (lambda (#{w1\ 1885}# #{w2\ 1886}#) + (let ((#{m1\ 1887}# + (#{wrap-marks\ 1300}# #{w1\ 1885}#)) + (#{s1\ 1888}# + (#{wrap-subst\ 1301}# #{w1\ 1885}#))) + (if (null? #{m1\ 1887}#) + (if (null? #{s1\ 1888}#) + #{w2\ 1886}# + (#{make-wrap\ 1299}# + (#{wrap-marks\ 1300}# #{w2\ 1886}#) + (#{smart-append\ 1315}# + #{s1\ 1888}# + (#{wrap-subst\ 1301}# #{w2\ 1886}#)))) + (#{make-wrap\ 1299}# + (#{smart-append\ 1315}# + #{m1\ 1887}# + (#{wrap-marks\ 1300}# #{w2\ 1886}#)) + (#{smart-append\ 1315}# + #{s1\ 1888}# + (#{wrap-subst\ 1301}# #{w2\ 1886}#))))))) + (#{smart-append\ 1315}# + (lambda (#{m1\ 1889}# #{m2\ 1890}#) + (if (null? #{m2\ 1890}#) + #{m1\ 1889}# + (append #{m1\ 1889}# #{m2\ 1890}#)))) + (#{make-binding-wrap\ 1314}# + (lambda (#{ids\ 1891}# #{labels\ 1892}# #{w\ 1893}#) + (if (null? #{ids\ 1891}#) + #{w\ 1893}# + (#{make-wrap\ 1299}# + (#{wrap-marks\ 1300}# #{w\ 1893}#) + (cons (let ((#{labelvec\ 1894}# + (list->vector #{labels\ 1892}#))) + (let ((#{n\ 1895}# + (vector-length #{labelvec\ 1894}#))) + (let ((#{symnamevec\ 1896}# + (make-vector #{n\ 1895}#)) + (#{marksvec\ 1897}# + (make-vector #{n\ 1895}#))) (begin - (letrec ((f715 (lambda (ids716 i717) - (if (not (null? ids716)) - (call-with-values - (lambda () - (id-sym-name&marks116 - (car ids716) - w710)) - (lambda (symname718 - marks719) - (begin - (vector-set! - symnamevec713 - i717 - symname718) - (vector-set! - marksvec714 - i717 - marks719) - (f715 (cdr ids716) - (fx+72 i717 - 1))))))))) - (f715 ids708 0)) - (make-ribcage122 - symnamevec713 - marksvec714 - labelvec711))))) - (wrap-subst119 w710)))))) - (extend-ribcage!131 - (lambda (ribcage720 id721 label722) + (letrec ((#{f\ 1898}# + (lambda (#{ids\ 1899}# #{i\ 1900}#) + (if (not (null? #{ids\ 1899}#)) + (call-with-values + (lambda () + (#{id-sym-name&marks\ 1298}# + (car #{ids\ 1899}#) + #{w\ 1893}#)) + (lambda (#{symname\ 1901}# + #{marks\ 1902}#) + (begin + (vector-set! + #{symnamevec\ 1896}# + #{i\ 1900}# + #{symname\ 1901}#) + (vector-set! + #{marksvec\ 1897}# + #{i\ 1900}# + #{marks\ 1902}#) + (#{f\ 1898}# + (cdr #{ids\ 1899}#) + (#{fx+\ 1254}# + #{i\ 1900}# + 1))))))))) + (#{f\ 1898}# #{ids\ 1891}# 0)) + (#{make-ribcage\ 1304}# + #{symnamevec\ 1896}# + #{marksvec\ 1897}# + #{labelvec\ 1894}#))))) + (#{wrap-subst\ 1301}# #{w\ 1893}#)))))) + (#{extend-ribcage!\ 1313}# + (lambda (#{ribcage\ 1903}# #{id\ 1904}# #{label\ 1905}#) (begin - (set-ribcage-symnames!127 - ribcage720 - (cons (syntax-object-expression100 id721) - (ribcage-symnames124 ribcage720))) - (set-ribcage-marks!128 - ribcage720 - (cons (wrap-marks118 (syntax-object-wrap101 id721)) - (ribcage-marks125 ribcage720))) - (set-ribcage-labels!129 - ribcage720 - (cons label722 (ribcage-labels126 ribcage720)))))) - (anti-mark130 - (lambda (w723) - (make-wrap117 - (cons #f (wrap-marks118 w723)) - (cons (quote shift) (wrap-subst119 w723))))) - (set-ribcage-labels!129 - (lambda (x724 update725) - (vector-set! x724 3 update725))) - (set-ribcage-marks!128 - (lambda (x726 update727) - (vector-set! x726 2 update727))) - (set-ribcage-symnames!127 - (lambda (x728 update729) - (vector-set! x728 1 update729))) - (ribcage-labels126 - (lambda (x730) (vector-ref x730 3))) - (ribcage-marks125 - (lambda (x731) (vector-ref x731 2))) - (ribcage-symnames124 - (lambda (x732) (vector-ref x732 1))) - (ribcage?123 - (lambda (x733) - (if (vector? x733) - (if (= (vector-length x733) 4) - (eq? (vector-ref x733 0) (quote ribcage)) + (#{set-ribcage-symnames!\ 1309}# + #{ribcage\ 1903}# + (cons (#{syntax-object-expression\ 1282}# #{id\ 1904}#) + (#{ribcage-symnames\ 1306}# #{ribcage\ 1903}#))) + (#{set-ribcage-marks!\ 1310}# + #{ribcage\ 1903}# + (cons (#{wrap-marks\ 1300}# + (#{syntax-object-wrap\ 1283}# #{id\ 1904}#)) + (#{ribcage-marks\ 1307}# #{ribcage\ 1903}#))) + (#{set-ribcage-labels!\ 1311}# + #{ribcage\ 1903}# + (cons #{label\ 1905}# + (#{ribcage-labels\ 1308}# #{ribcage\ 1903}#)))))) + (#{anti-mark\ 1312}# + (lambda (#{w\ 1906}#) + (#{make-wrap\ 1299}# + (cons #f (#{wrap-marks\ 1300}# #{w\ 1906}#)) + (cons 'shift + (#{wrap-subst\ 1301}# #{w\ 1906}#))))) + (#{set-ribcage-labels!\ 1311}# + (lambda (#{x\ 1907}# #{update\ 1908}#) + (vector-set! #{x\ 1907}# 3 #{update\ 1908}#))) + (#{set-ribcage-marks!\ 1310}# + (lambda (#{x\ 1909}# #{update\ 1910}#) + (vector-set! #{x\ 1909}# 2 #{update\ 1910}#))) + (#{set-ribcage-symnames!\ 1309}# + (lambda (#{x\ 1911}# #{update\ 1912}#) + (vector-set! #{x\ 1911}# 1 #{update\ 1912}#))) + (#{ribcage-labels\ 1308}# + (lambda (#{x\ 1913}#) (vector-ref #{x\ 1913}# 3))) + (#{ribcage-marks\ 1307}# + (lambda (#{x\ 1914}#) (vector-ref #{x\ 1914}# 2))) + (#{ribcage-symnames\ 1306}# + (lambda (#{x\ 1915}#) (vector-ref #{x\ 1915}# 1))) + (#{ribcage?\ 1305}# + (lambda (#{x\ 1916}#) + (if (vector? #{x\ 1916}#) + (if (= (vector-length #{x\ 1916}#) 4) + (eq? (vector-ref #{x\ 1916}# 0) (quote ribcage)) #f) #f))) - (make-ribcage122 - (lambda (symnames734 marks735 labels736) + (#{make-ribcage\ 1304}# + (lambda (#{symnames\ 1917}# + #{marks\ 1918}# + #{labels\ 1919}#) (vector 'ribcage - symnames734 - marks735 - labels736))) - (gen-labels121 - (lambda (ls737) - (if (null? ls737) + #{symnames\ 1917}# + #{marks\ 1918}# + #{labels\ 1919}#))) + (#{gen-labels\ 1303}# + (lambda (#{ls\ 1920}#) + (if (null? #{ls\ 1920}#) '() - (cons (gen-label120) (gen-labels121 (cdr ls737)))))) - (gen-label120 (lambda () (string #\i))) - (wrap-subst119 cdr) - (wrap-marks118 car) - (make-wrap117 cons) - (id-sym-name&marks116 - (lambda (x738 w739) - (if (syntax-object?99 x738) + (cons (#{gen-label\ 1302}#) + (#{gen-labels\ 1303}# (cdr #{ls\ 1920}#)))))) + (#{gen-label\ 1302}# (lambda () (string #\i))) + (#{wrap-subst\ 1301}# cdr) + (#{wrap-marks\ 1300}# car) + (#{make-wrap\ 1299}# cons) + (#{id-sym-name&marks\ 1298}# + (lambda (#{x\ 1921}# #{w\ 1922}#) + (if (#{syntax-object?\ 1281}# #{x\ 1921}#) (values - (syntax-object-expression100 x738) - (join-marks135 - (wrap-marks118 w739) - (wrap-marks118 (syntax-object-wrap101 x738)))) - (values x738 (wrap-marks118 w739))))) - (id?115 - (lambda (x740) - (if (symbol? x740) + (#{syntax-object-expression\ 1282}# #{x\ 1921}#) + (#{join-marks\ 1317}# + (#{wrap-marks\ 1300}# #{w\ 1922}#) + (#{wrap-marks\ 1300}# + (#{syntax-object-wrap\ 1283}# #{x\ 1921}#)))) + (values + #{x\ 1921}# + (#{wrap-marks\ 1300}# #{w\ 1922}#))))) + (#{id?\ 1297}# + (lambda (#{x\ 1923}#) + (if (symbol? #{x\ 1923}#) #t - (if (syntax-object?99 x740) - (symbol? (syntax-object-expression100 x740)) + (if (#{syntax-object?\ 1281}# #{x\ 1923}#) + (symbol? + (#{syntax-object-expression\ 1282}# #{x\ 1923}#)) #f)))) - (nonsymbol-id?114 - (lambda (x741) - (if (syntax-object?99 x741) - (symbol? (syntax-object-expression100 x741)) + (#{nonsymbol-id?\ 1296}# + (lambda (#{x\ 1924}#) + (if (#{syntax-object?\ 1281}# #{x\ 1924}#) + (symbol? + (#{syntax-object-expression\ 1282}# #{x\ 1924}#)) #f))) - (global-extend113 - (lambda (type742 sym743 val744) - (put-global-definition-hook78 - sym743 - type742 - val744))) - (lookup112 - (lambda (x745 r746 mod747) - (let ((t748 (assq x745 r746))) - (if t748 - (cdr t748) - (if (symbol? x745) - (let ((t749 (get-global-definition-hook79 x745 mod747))) - (if t749 t749 (quote (global)))) + (#{global-extend\ 1295}# + (lambda (#{type\ 1925}# #{sym\ 1926}# #{val\ 1927}#) + (#{put-global-definition-hook\ 1260}# + #{sym\ 1926}# + #{type\ 1925}# + #{val\ 1927}#))) + (#{lookup\ 1294}# + (lambda (#{x\ 1928}# #{r\ 1929}# #{mod\ 1930}#) + (let ((#{t\ 1931}# (assq #{x\ 1928}# #{r\ 1929}#))) + (if #{t\ 1931}# + (cdr #{t\ 1931}#) + (if (symbol? #{x\ 1928}#) + (let ((#{t\ 1932}# + (#{get-global-definition-hook\ 1261}# + #{x\ 1928}# + #{mod\ 1930}#))) + (if #{t\ 1932}# #{t\ 1932}# (quote (global)))) '(displaced-lexical)))))) - (macros-only-env111 - (lambda (r750) - (if (null? r750) + (#{macros-only-env\ 1293}# + (lambda (#{r\ 1933}#) + (if (null? #{r\ 1933}#) '() - (let ((a751 (car r750))) - (if (eq? (cadr a751) (quote macro)) - (cons a751 (macros-only-env111 (cdr r750))) - (macros-only-env111 (cdr r750))))))) - (extend-var-env110 - (lambda (labels752 vars753 r754) - (if (null? labels752) - r754 - (extend-var-env110 - (cdr labels752) - (cdr vars753) - (cons (cons (car labels752) - (cons (quote lexical) (car vars753))) - r754))))) - (extend-env109 - (lambda (labels755 bindings756 r757) - (if (null? labels755) - r757 - (extend-env109 - (cdr labels755) - (cdr bindings756) - (cons (cons (car labels755) (car bindings756)) - r757))))) - (binding-value108 cdr) - (binding-type107 car) - (source-annotation106 - (lambda (x758) - (if (syntax-object?99 x758) - (source-annotation106 - (syntax-object-expression100 x758)) - (if (pair? x758) - (let ((props759 (source-properties x758))) - (if (pair? props759) props759 #f)) + (let ((#{a\ 1934}# (car #{r\ 1933}#))) + (if (eq? (cadr #{a\ 1934}#) (quote macro)) + (cons #{a\ 1934}# + (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#))) + (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#))))))) + (#{extend-var-env\ 1292}# + (lambda (#{labels\ 1935}# #{vars\ 1936}# #{r\ 1937}#) + (if (null? #{labels\ 1935}#) + #{r\ 1937}# + (#{extend-var-env\ 1292}# + (cdr #{labels\ 1935}#) + (cdr #{vars\ 1936}#) + (cons (cons (car #{labels\ 1935}#) + (cons (quote lexical) (car #{vars\ 1936}#))) + #{r\ 1937}#))))) + (#{extend-env\ 1291}# + (lambda (#{labels\ 1938}# #{bindings\ 1939}# #{r\ 1940}#) + (if (null? #{labels\ 1938}#) + #{r\ 1940}# + (#{extend-env\ 1291}# + (cdr #{labels\ 1938}#) + (cdr #{bindings\ 1939}#) + (cons (cons (car #{labels\ 1938}#) + (car #{bindings\ 1939}#)) + #{r\ 1940}#))))) + (#{binding-value\ 1290}# cdr) + (#{binding-type\ 1289}# car) + (#{source-annotation\ 1288}# + (lambda (#{x\ 1941}#) + (if (#{syntax-object?\ 1281}# #{x\ 1941}#) + (#{source-annotation\ 1288}# + (#{syntax-object-expression\ 1282}# #{x\ 1941}#)) + (if (pair? #{x\ 1941}#) + (let ((#{props\ 1942}# (source-properties #{x\ 1941}#))) + (if (pair? #{props\ 1942}#) #{props\ 1942}# #f)) #f)))) - (set-syntax-object-module!105 - (lambda (x760 update761) - (vector-set! x760 3 update761))) - (set-syntax-object-wrap!104 - (lambda (x762 update763) - (vector-set! x762 2 update763))) - (set-syntax-object-expression!103 - (lambda (x764 update765) - (vector-set! x764 1 update765))) - (syntax-object-module102 - (lambda (x766) (vector-ref x766 3))) - (syntax-object-wrap101 - (lambda (x767) (vector-ref x767 2))) - (syntax-object-expression100 - (lambda (x768) (vector-ref x768 1))) - (syntax-object?99 - (lambda (x769) - (if (vector? x769) - (if (= (vector-length x769) 4) - (eq? (vector-ref x769 0) (quote syntax-object)) + (#{set-syntax-object-module!\ 1287}# + (lambda (#{x\ 1943}# #{update\ 1944}#) + (vector-set! #{x\ 1943}# 3 #{update\ 1944}#))) + (#{set-syntax-object-wrap!\ 1286}# + (lambda (#{x\ 1945}# #{update\ 1946}#) + (vector-set! #{x\ 1945}# 2 #{update\ 1946}#))) + (#{set-syntax-object-expression!\ 1285}# + (lambda (#{x\ 1947}# #{update\ 1948}#) + (vector-set! #{x\ 1947}# 1 #{update\ 1948}#))) + (#{syntax-object-module\ 1284}# + (lambda (#{x\ 1949}#) (vector-ref #{x\ 1949}# 3))) + (#{syntax-object-wrap\ 1283}# + (lambda (#{x\ 1950}#) (vector-ref #{x\ 1950}# 2))) + (#{syntax-object-expression\ 1282}# + (lambda (#{x\ 1951}#) (vector-ref #{x\ 1951}# 1))) + (#{syntax-object?\ 1281}# + (lambda (#{x\ 1952}#) + (if (vector? #{x\ 1952}#) + (if (= (vector-length #{x\ 1952}#) 4) + (eq? (vector-ref #{x\ 1952}# 0) + 'syntax-object) #f) #f))) - (make-syntax-object98 - (lambda (expression770 wrap771 module772) + (#{make-syntax-object\ 1280}# + (lambda (#{expression\ 1953}# + #{wrap\ 1954}# + #{module\ 1955}#) (vector 'syntax-object - expression770 - wrap771 - module772))) - (build-letrec97 - (lambda (src773 ids774 vars775 val-exps776 body-exp777) - (if (null? vars775) - body-exp777 - (let ((atom-key778 (fluid-ref *mode*71))) - (if (memv atom-key778 (quote (c))) + #{expression\ 1953}# + #{wrap\ 1954}# + #{module\ 1955}#))) + (#{build-letrec\ 1279}# + (lambda (#{src\ 1956}# + #{ids\ 1957}# + #{vars\ 1958}# + #{val-exps\ 1959}# + #{body-exp\ 1960}#) + (if (null? #{vars\ 1958}#) + #{body-exp\ 1960}# + (let ((#{atom-key\ 1961}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1961}# (quote (c))) (begin - (for-each maybe-name-value!89 ids774 val-exps776) + (for-each + #{maybe-name-value!\ 1271}# + #{ids\ 1957}# + #{val-exps\ 1959}#) ((@ (language tree-il) make-letrec) - src773 - ids774 - vars775 - val-exps776 - body-exp777)) - (decorate-source80 + #{src\ 1956}# + #{ids\ 1957}# + #{vars\ 1958}# + #{val-exps\ 1959}# + #{body-exp\ 1960}#)) + (#{decorate-source\ 1262}# (list 'letrec - (map list vars775 val-exps776) - body-exp777) - src773)))))) - (build-named-let96 - (lambda (src779 ids780 vars781 val-exps782 body-exp783) - (let ((f784 (car vars781)) - (f-name785 (car ids780)) - (vars786 (cdr vars781)) - (ids787 (cdr ids780))) - (let ((atom-key788 (fluid-ref *mode*71))) - (if (memv atom-key788 (quote (c))) - (let ((proc789 - (build-lambda91 - src779 - ids787 - vars786 + (map list #{vars\ 1958}# #{val-exps\ 1959}#) + #{body-exp\ 1960}#) + #{src\ 1956}#)))))) + (#{build-named-let\ 1278}# + (lambda (#{src\ 1962}# + #{ids\ 1963}# + #{vars\ 1964}# + #{val-exps\ 1965}# + #{body-exp\ 1966}#) + (let ((#{f\ 1967}# (car #{vars\ 1964}#)) + (#{f-name\ 1968}# (car #{ids\ 1963}#)) + (#{vars\ 1969}# (cdr #{vars\ 1964}#)) + (#{ids\ 1970}# (cdr #{ids\ 1963}#))) + (let ((#{atom-key\ 1971}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1971}# (quote (c))) + (let ((#{proc\ 1972}# + (#{build-lambda\ 1273}# + #{src\ 1962}# + #{ids\ 1970}# + #{vars\ 1969}# #f - body-exp783))) + #{body-exp\ 1966}#))) (begin - (maybe-name-value!89 f-name785 proc789) - (for-each maybe-name-value!89 ids787 val-exps782) + (#{maybe-name-value!\ 1271}# + #{f-name\ 1968}# + #{proc\ 1972}#) + (for-each + #{maybe-name-value!\ 1271}# + #{ids\ 1970}# + #{val-exps\ 1965}#) ((@ (language tree-il) make-letrec) - src779 - (list f-name785) - (list f784) - (list proc789) - (build-application82 - src779 - (build-lexical-reference84 + #{src\ 1962}# + (list #{f-name\ 1968}#) + (list #{f\ 1967}#) + (list #{proc\ 1972}#) + (#{build-application\ 1264}# + #{src\ 1962}# + (#{build-lexical-reference\ 1266}# 'fun - src779 - f-name785 - f784) - val-exps782)))) - (decorate-source80 + #{src\ 1962}# + #{f-name\ 1968}# + #{f\ 1967}#) + #{val-exps\ 1965}#)))) + (#{decorate-source\ 1262}# (list 'let - f784 - (map list vars786 val-exps782) - body-exp783) - src779)))))) - (build-let95 - (lambda (src790 ids791 vars792 val-exps793 body-exp794) - (if (null? vars792) - body-exp794 - (let ((atom-key795 (fluid-ref *mode*71))) - (if (memv atom-key795 (quote (c))) + #{f\ 1967}# + (map list #{vars\ 1969}# #{val-exps\ 1965}#) + #{body-exp\ 1966}#) + #{src\ 1962}#)))))) + (#{build-let\ 1277}# + (lambda (#{src\ 1973}# + #{ids\ 1974}# + #{vars\ 1975}# + #{val-exps\ 1976}# + #{body-exp\ 1977}#) + (if (null? #{vars\ 1975}#) + #{body-exp\ 1977}# + (let ((#{atom-key\ 1978}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1978}# (quote (c))) (begin - (for-each maybe-name-value!89 ids791 val-exps793) + (for-each + #{maybe-name-value!\ 1271}# + #{ids\ 1974}# + #{val-exps\ 1976}#) ((@ (language tree-il) make-let) - src790 - ids791 - vars792 - val-exps793 - body-exp794)) - (decorate-source80 + #{src\ 1973}# + #{ids\ 1974}# + #{vars\ 1975}# + #{val-exps\ 1976}# + #{body-exp\ 1977}#)) + (#{decorate-source\ 1262}# (list 'let - (map list vars792 val-exps793) - body-exp794) - src790)))))) - (build-sequence94 - (lambda (src796 exps797) - (if (null? (cdr exps797)) - (car exps797) - (let ((atom-key798 (fluid-ref *mode*71))) - (if (memv atom-key798 (quote (c))) + (map list #{vars\ 1975}# #{val-exps\ 1976}#) + #{body-exp\ 1977}#) + #{src\ 1973}#)))))) + (#{build-sequence\ 1276}# + (lambda (#{src\ 1979}# #{exps\ 1980}#) + (if (null? (cdr #{exps\ 1980}#)) + (car #{exps\ 1980}#) + (let ((#{atom-key\ 1981}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1981}# (quote (c))) ((@ (language tree-il) make-sequence) - src796 - exps797) - (decorate-source80 - (cons (quote begin) exps797) - src796)))))) - (build-data93 - (lambda (src799 exp800) - (let ((atom-key801 (fluid-ref *mode*71))) - (if (memv atom-key801 (quote (c))) - ((@ (language tree-il) make-const) src799 exp800) - (decorate-source80 - (if (if (self-evaluating? exp800) - (not (vector? exp800)) + #{src\ 1979}# + #{exps\ 1980}#) + (#{decorate-source\ 1262}# + (cons (quote begin) #{exps\ 1980}#) + #{src\ 1979}#)))))) + (#{build-data\ 1275}# + (lambda (#{src\ 1982}# #{exp\ 1983}#) + (let ((#{atom-key\ 1984}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1984}# (quote (c))) + ((@ (language tree-il) make-const) + #{src\ 1982}# + #{exp\ 1983}#) + (#{decorate-source\ 1262}# + (if (if (self-evaluating? #{exp\ 1983}#) + (not (vector? #{exp\ 1983}#)) #f) - exp800 - (list (quote quote) exp800)) - src799))))) - (build-primref92 - (lambda (src802 name803) + #{exp\ 1983}# + (list (quote quote) #{exp\ 1983}#)) + #{src\ 1982}#))))) + (#{build-primref\ 1274}# + (lambda (#{src\ 1985}# #{name\ 1986}#) (if (equal? (module-name (current-module)) '(guile)) - (let ((atom-key804 (fluid-ref *mode*71))) - (if (memv atom-key804 (quote (c))) + (let ((#{atom-key\ 1987}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1987}# (quote (c))) ((@ (language tree-il) make-toplevel-ref) - src802 - name803) - (decorate-source80 name803 src802))) - (let ((atom-key805 (fluid-ref *mode*71))) - (if (memv atom-key805 (quote (c))) + #{src\ 1985}# + #{name\ 1986}#) + (#{decorate-source\ 1262}# + #{name\ 1986}# + #{src\ 1985}#))) + (let ((#{atom-key\ 1988}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1988}# (quote (c))) ((@ (language tree-il) make-module-ref) - src802 + #{src\ 1985}# '(guile) - name803 + #{name\ 1986}# #f) - (decorate-source80 - (list (quote @@) (quote (guile)) name803) - src802)))))) - (build-lambda91 - (lambda (src806 ids807 vars808 docstring809 exp810) - (let ((atom-key811 (fluid-ref *mode*71))) - (if (memv atom-key811 (quote (c))) + (#{decorate-source\ 1262}# + (list (quote @@) (quote (guile)) #{name\ 1986}#) + #{src\ 1985}#)))))) + (#{build-lambda\ 1273}# + (lambda (#{src\ 1989}# + #{ids\ 1990}# + #{vars\ 1991}# + #{docstring\ 1992}# + #{exp\ 1993}#) + (let ((#{atom-key\ 1994}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1994}# (quote (c))) ((@ (language tree-il) make-lambda) - src806 - ids807 - vars808 - (if docstring809 - (list (cons (quote documentation) docstring809)) + #{src\ 1989}# + #{ids\ 1990}# + #{vars\ 1991}# + (if #{docstring\ 1992}# + (list (cons (quote documentation) #{docstring\ 1992}#)) '()) - exp810) - (decorate-source80 + #{exp\ 1993}#) + (#{decorate-source\ 1262}# (cons 'lambda - (cons vars808 + (cons #{vars\ 1991}# (append - (if docstring809 - (list docstring809) + (if #{docstring\ 1992}# + (list #{docstring\ 1992}#) '()) - (list exp810)))) - src806))))) - (build-global-definition90 - (lambda (source812 var813 exp814) - (let ((atom-key815 (fluid-ref *mode*71))) - (if (memv atom-key815 (quote (c))) + (list #{exp\ 1993}#)))) + #{src\ 1989}#))))) + (#{build-global-definition\ 1272}# + (lambda (#{source\ 1995}# #{var\ 1996}# #{exp\ 1997}#) + (let ((#{atom-key\ 1998}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 1998}# (quote (c))) (begin - (maybe-name-value!89 var813 exp814) + (#{maybe-name-value!\ 1271}# + #{var\ 1996}# + #{exp\ 1997}#) ((@ (language tree-il) make-toplevel-define) - source812 - var813 - exp814)) - (decorate-source80 - (list (quote define) var813 exp814) - source812))))) - (maybe-name-value!89 - (lambda (name816 val817) - (if ((@ (language tree-il) lambda?) val817) - (let ((meta818 - ((@ (language tree-il) lambda-meta) val817))) - (if (not (assq (quote name) meta818)) + #{source\ 1995}# + #{var\ 1996}# + #{exp\ 1997}#)) + (#{decorate-source\ 1262}# + (list (quote define) #{var\ 1996}# #{exp\ 1997}#) + #{source\ 1995}#))))) + (#{maybe-name-value!\ 1271}# + (lambda (#{name\ 1999}# #{val\ 2000}#) + (if ((@ (language tree-il) lambda?) #{val\ 2000}#) + (let ((#{meta\ 2001}# + ((@ (language tree-il) lambda-meta) + #{val\ 2000}#))) + (if (not (assq (quote name) #{meta\ 2001}#)) ((setter (@ (language tree-il) lambda-meta)) - val817 - (acons (quote name) name816 meta818))))))) - (build-global-assignment88 - (lambda (source819 var820 exp821 mod822) - (analyze-variable86 - mod822 - var820 - (lambda (mod823 var824 public?825) - (let ((atom-key826 (fluid-ref *mode*71))) - (if (memv atom-key826 (quote (c))) + #{val\ 2000}# + (acons 'name + #{name\ 1999}# + #{meta\ 2001}#))))))) + (#{build-global-assignment\ 1270}# + (lambda (#{source\ 2002}# + #{var\ 2003}# + #{exp\ 2004}# + #{mod\ 2005}#) + (#{analyze-variable\ 1268}# + #{mod\ 2005}# + #{var\ 2003}# + (lambda (#{mod\ 2006}# #{var\ 2007}# #{public?\ 2008}#) + (let ((#{atom-key\ 2009}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2009}# (quote (c))) ((@ (language tree-il) make-module-set) - source819 - mod823 - var824 - public?825 - exp821) - (decorate-source80 + #{source\ 2002}# + #{mod\ 2006}# + #{var\ 2007}# + #{public?\ 2008}# + #{exp\ 2004}#) + (#{decorate-source\ 1262}# (list 'set! - (list (if public?825 (quote @) (quote @@)) - mod823 - var824) - exp821) - source819)))) - (lambda (var827) - (let ((atom-key828 (fluid-ref *mode*71))) - (if (memv atom-key828 (quote (c))) + (list (if #{public?\ 2008}# + '@ + '@@) + #{mod\ 2006}# + #{var\ 2007}#) + #{exp\ 2004}#) + #{source\ 2002}#)))) + (lambda (#{var\ 2010}#) + (let ((#{atom-key\ 2011}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2011}# (quote (c))) ((@ (language tree-il) make-toplevel-set) - source819 - var827 - exp821) - (decorate-source80 - (list (quote set!) var827 exp821) - source819))))))) - (build-global-reference87 - (lambda (source829 var830 mod831) - (analyze-variable86 - mod831 - var830 - (lambda (mod832 var833 public?834) - (let ((atom-key835 (fluid-ref *mode*71))) - (if (memv atom-key835 (quote (c))) + #{source\ 2002}# + #{var\ 2010}# + #{exp\ 2004}#) + (#{decorate-source\ 1262}# + (list (quote set!) #{var\ 2010}# #{exp\ 2004}#) + #{source\ 2002}#))))))) + (#{build-global-reference\ 1269}# + (lambda (#{source\ 2012}# #{var\ 2013}# #{mod\ 2014}#) + (#{analyze-variable\ 1268}# + #{mod\ 2014}# + #{var\ 2013}# + (lambda (#{mod\ 2015}# #{var\ 2016}# #{public?\ 2017}#) + (let ((#{atom-key\ 2018}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2018}# (quote (c))) ((@ (language tree-il) make-module-ref) - source829 - mod832 - var833 - public?834) - (decorate-source80 - (list (if public?834 (quote @) (quote @@)) - mod832 - var833) - source829)))) - (lambda (var836) - (let ((atom-key837 (fluid-ref *mode*71))) - (if (memv atom-key837 (quote (c))) + #{source\ 2012}# + #{mod\ 2015}# + #{var\ 2016}# + #{public?\ 2017}#) + (#{decorate-source\ 1262}# + (list (if #{public?\ 2017}# (quote @) (quote @@)) + #{mod\ 2015}# + #{var\ 2016}#) + #{source\ 2012}#)))) + (lambda (#{var\ 2019}#) + (let ((#{atom-key\ 2020}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2020}# (quote (c))) ((@ (language tree-il) make-toplevel-ref) - source829 - var836) - (decorate-source80 var836 source829))))))) - (analyze-variable86 - (lambda (mod838 var839 modref-cont840 bare-cont841) - (if (not mod838) - (bare-cont841 var839) - (let ((kind842 (car mod838)) (mod843 (cdr mod838))) - (if (memv kind842 (quote (public))) - (modref-cont840 mod843 var839 #t) - (if (memv kind842 (quote (private))) - (if (not (equal? mod843 (module-name (current-module)))) - (modref-cont840 mod843 var839 #f) - (bare-cont841 var839)) - (if (memv kind842 (quote (bare))) - (bare-cont841 var839) - (if (memv kind842 (quote (hygiene))) + #{source\ 2012}# + #{var\ 2019}#) + (#{decorate-source\ 1262}# + #{var\ 2019}# + #{source\ 2012}#))))))) + (#{analyze-variable\ 1268}# + (lambda (#{mod\ 2021}# + #{var\ 2022}# + #{modref-cont\ 2023}# + #{bare-cont\ 2024}#) + (if (not #{mod\ 2021}#) + (#{bare-cont\ 2024}# #{var\ 2022}#) + (let ((#{kind\ 2025}# (car #{mod\ 2021}#)) + (#{mod\ 2026}# (cdr #{mod\ 2021}#))) + (if (memv #{kind\ 2025}# (quote (public))) + (#{modref-cont\ 2023}# + #{mod\ 2026}# + #{var\ 2022}# + #t) + (if (memv #{kind\ 2025}# (quote (private))) + (if (not (equal? + #{mod\ 2026}# + (module-name (current-module)))) + (#{modref-cont\ 2023}# + #{mod\ 2026}# + #{var\ 2022}# + #f) + (#{bare-cont\ 2024}# #{var\ 2022}#)) + (if (memv #{kind\ 2025}# (quote (bare))) + (#{bare-cont\ 2024}# #{var\ 2022}#) + (if (memv #{kind\ 2025}# (quote (hygiene))) (if (if (not (equal? - mod843 + #{mod\ 2026}# (module-name (current-module)))) (module-variable - (resolve-module mod843) - var839) + (resolve-module #{mod\ 2026}#) + #{var\ 2022}#) #f) - (modref-cont840 mod843 var839 #f) - (bare-cont841 var839)) + (#{modref-cont\ 2023}# + #{mod\ 2026}# + #{var\ 2022}# + #f) + (#{bare-cont\ 2024}# #{var\ 2022}#)) (syntax-violation #f "bad module kind" - var839 - mod843))))))))) - (build-lexical-assignment85 - (lambda (source844 name845 var846 exp847) - (let ((atom-key848 (fluid-ref *mode*71))) - (if (memv atom-key848 (quote (c))) + #{var\ 2022}# + #{mod\ 2026}#))))))))) + (#{build-lexical-assignment\ 1267}# + (lambda (#{source\ 2027}# + #{name\ 2028}# + #{var\ 2029}# + #{exp\ 2030}#) + (let ((#{atom-key\ 2031}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2031}# (quote (c))) ((@ (language tree-il) make-lexical-set) - source844 - name845 - var846 - exp847) - (decorate-source80 - (list (quote set!) var846 exp847) - source844))))) - (build-lexical-reference84 - (lambda (type849 source850 name851 var852) - (let ((atom-key853 (fluid-ref *mode*71))) - (if (memv atom-key853 (quote (c))) + #{source\ 2027}# + #{name\ 2028}# + #{var\ 2029}# + #{exp\ 2030}#) + (#{decorate-source\ 1262}# + (list (quote set!) #{var\ 2029}# #{exp\ 2030}#) + #{source\ 2027}#))))) + (#{build-lexical-reference\ 1266}# + (lambda (#{type\ 2032}# + #{source\ 2033}# + #{name\ 2034}# + #{var\ 2035}#) + (let ((#{atom-key\ 2036}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2036}# (quote (c))) ((@ (language tree-il) make-lexical-ref) - source850 - name851 - var852) - (decorate-source80 var852 source850))))) - (build-conditional83 - (lambda (source854 test-exp855 then-exp856 else-exp857) - (let ((atom-key858 (fluid-ref *mode*71))) - (if (memv atom-key858 (quote (c))) + #{source\ 2033}# + #{name\ 2034}# + #{var\ 2035}#) + (#{decorate-source\ 1262}# + #{var\ 2035}# + #{source\ 2033}#))))) + (#{build-conditional\ 1265}# + (lambda (#{source\ 2037}# + #{test-exp\ 2038}# + #{then-exp\ 2039}# + #{else-exp\ 2040}#) + (let ((#{atom-key\ 2041}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2041}# (quote (c))) ((@ (language tree-il) make-conditional) - source854 - test-exp855 - then-exp856 - else-exp857) - (decorate-source80 - (if (equal? else-exp857 (quote (if #f #f))) - (list (quote if) test-exp855 then-exp856) + #{source\ 2037}# + #{test-exp\ 2038}# + #{then-exp\ 2039}# + #{else-exp\ 2040}#) + (#{decorate-source\ 1262}# + (if (equal? #{else-exp\ 2040}# (quote (if #f #f))) (list 'if - test-exp855 - then-exp856 - else-exp857)) - source854))))) - (build-application82 - (lambda (source859 fun-exp860 arg-exps861) - (let ((atom-key862 (fluid-ref *mode*71))) - (if (memv atom-key862 (quote (c))) + #{test-exp\ 2038}# + #{then-exp\ 2039}#) + (list 'if + #{test-exp\ 2038}# + #{then-exp\ 2039}# + #{else-exp\ 2040}#)) + #{source\ 2037}#))))) + (#{build-application\ 1264}# + (lambda (#{source\ 2042}# + #{fun-exp\ 2043}# + #{arg-exps\ 2044}#) + (let ((#{atom-key\ 2045}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2045}# (quote (c))) ((@ (language tree-il) make-application) - source859 - fun-exp860 - arg-exps861) - (decorate-source80 - (cons fun-exp860 arg-exps861) - source859))))) - (build-void81 - (lambda (source863) - (let ((atom-key864 (fluid-ref *mode*71))) - (if (memv atom-key864 (quote (c))) - ((@ (language tree-il) make-void) source863) - (decorate-source80 (quote (if #f #f)) source863))))) - (decorate-source80 - (lambda (e865 s866) + #{source\ 2042}# + #{fun-exp\ 2043}# + #{arg-exps\ 2044}#) + (#{decorate-source\ 1262}# + (cons #{fun-exp\ 2043}# #{arg-exps\ 2044}#) + #{source\ 2042}#))))) + (#{build-void\ 1263}# + (lambda (#{source\ 2046}#) + (let ((#{atom-key\ 2047}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2047}# (quote (c))) + ((@ (language tree-il) make-void) + #{source\ 2046}#) + (#{decorate-source\ 1262}# + '(if #f #f) + #{source\ 2046}#))))) + (#{decorate-source\ 1262}# + (lambda (#{e\ 2048}# #{s\ 2049}#) (begin - (if (if (pair? e865) s866 #f) - (set-source-properties! e865 s866)) - e865))) - (get-global-definition-hook79 - (lambda (symbol867 module868) + (if (if (pair? #{e\ 2048}#) #{s\ 2049}# #f) + (set-source-properties! #{e\ 2048}# #{s\ 2049}#)) + #{e\ 2048}#))) + (#{get-global-definition-hook\ 1261}# + (lambda (#{symbol\ 2050}# #{module\ 2051}#) (begin - (if (if (not module868) (current-module) #f) + (if (if (not #{module\ 2051}#) (current-module) #f) (warn "module system is booted, we should have a module" - symbol867)) - (let ((v869 (module-variable - (if module868 - (resolve-module (cdr module868)) - (current-module)) - symbol867))) - (if v869 - (if (variable-bound? v869) - (let ((val870 (variable-ref v869))) - (if (macro? val870) - (if (syncase-macro-type val870) - (cons (syncase-macro-type val870) - (syncase-macro-binding val870)) + #{symbol\ 2050}#)) + (let ((#{v\ 2052}# + (module-variable + (if #{module\ 2051}# + (resolve-module (cdr #{module\ 2051}#)) + (current-module)) + #{symbol\ 2050}#))) + (if #{v\ 2052}# + (if (variable-bound? #{v\ 2052}#) + (let ((#{val\ 2053}# (variable-ref #{v\ 2052}#))) + (if (macro? #{val\ 2053}#) + (if (syncase-macro-type #{val\ 2053}#) + (cons (syncase-macro-type #{val\ 2053}#) + (syncase-macro-binding #{val\ 2053}#)) #f) #f)) #f) #f))))) - (put-global-definition-hook78 - (lambda (symbol871 type872 val873) - (let ((existing874 - (let ((v875 (module-variable - (current-module) - symbol871))) - (if v875 - (if (variable-bound? v875) - (let ((val876 (variable-ref v875))) - (if (macro? val876) - (if (not (syncase-macro-type val876)) - val876 + (#{put-global-definition-hook\ 1260}# + (lambda (#{symbol\ 2054}# #{type\ 2055}# #{val\ 2056}#) + (let ((#{existing\ 2057}# + (let ((#{v\ 2058}# + (module-variable + (current-module) + #{symbol\ 2054}#))) + (if #{v\ 2058}# + (if (variable-bound? #{v\ 2058}#) + (let ((#{val\ 2059}# (variable-ref #{v\ 2058}#))) + (if (macro? #{val\ 2059}#) + (if (not (syncase-macro-type #{val\ 2059}#)) + #{val\ 2059}# #f) #f)) #f) #f)))) (module-define! (current-module) - symbol871 - (if existing874 + #{symbol\ 2054}# + (if #{existing\ 2057}# (make-extended-syncase-macro - existing874 - type872 - val873) - (make-syncase-macro type872 val873)))))) - (local-eval-hook77 - (lambda (x877 mod878) + #{existing\ 2057}# + #{type\ 2055}# + #{val\ 2056}#) + (make-syncase-macro #{type\ 2055}# #{val\ 2056}#)))))) + (#{local-eval-hook\ 1259}# + (lambda (#{x\ 2060}# #{mod\ 2061}#) (primitive-eval - (list noexpand70 - (let ((atom-key879 (fluid-ref *mode*71))) - (if (memv atom-key879 (quote (c))) - ((@ (language tree-il) tree-il->scheme) x877) - x877)))))) - (top-level-eval-hook76 - (lambda (x880 mod881) + (list #{noexpand\ 1252}# + (let ((#{atom-key\ 2062}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2062}# (quote (c))) + ((@ (language tree-il) tree-il->scheme) + #{x\ 2060}#) + #{x\ 2060}#)))))) + (#{top-level-eval-hook\ 1258}# + (lambda (#{x\ 2063}# #{mod\ 2064}#) (primitive-eval - (list noexpand70 - (let ((atom-key882 (fluid-ref *mode*71))) - (if (memv atom-key882 (quote (c))) - ((@ (language tree-il) tree-il->scheme) x880) - x880)))))) - (fx<75 <) - (fx=74 =) - (fx-73 -) - (fx+72 +) - (*mode*71 (make-fluid)) - (noexpand70 "noexpand")) + (list #{noexpand\ 1252}# + (let ((#{atom-key\ 2065}# (fluid-ref #{*mode*\ 1253}#))) + (if (memv #{atom-key\ 2065}# (quote (c))) + ((@ (language tree-il) tree-il->scheme) + #{x\ 2063}#) + #{x\ 2063}#)))))) + (#{fx<\ 1257}# <) + (#{fx=\ 1256}# =) + (#{fx-\ 1255}# -) + (#{fx+\ 1254}# +) + (#{*mode*\ 1253}# (make-fluid)) + (#{noexpand\ 1252}# "noexpand")) (begin - (global-extend113 + (#{global-extend\ 1295}# 'local-syntax 'letrec-syntax #t) - (global-extend113 + (#{global-extend\ 1295}# 'local-syntax 'let-syntax #f) - (global-extend113 + (#{global-extend\ 1295}# 'core 'fluid-let-syntax - (lambda (e883 r884 w885 s886 mod887) - ((lambda (tmp888) - ((lambda (tmp889) - (if (if tmp889 - (apply (lambda (_890 var891 val892 e1893 e2894) - (valid-bound-ids?140 var891)) - tmp889) + (lambda (#{e\ 2066}# + #{r\ 2067}# + #{w\ 2068}# + #{s\ 2069}# + #{mod\ 2070}#) + ((lambda (#{tmp\ 2071}#) + ((lambda (#{tmp\ 2072}#) + (if (if #{tmp\ 2072}# + (apply (lambda (#{_\ 2073}# + #{var\ 2074}# + #{val\ 2075}# + #{e1\ 2076}# + #{e2\ 2077}#) + (#{valid-bound-ids?\ 1322}# #{var\ 2074}#)) + #{tmp\ 2072}#) #f) - (apply (lambda (_896 var897 val898 e1899 e2900) - (let ((names901 - (map (lambda (x902) - (id-var-name137 x902 w885)) - var897))) + (apply (lambda (#{_\ 2079}# + #{var\ 2080}# + #{val\ 2081}# + #{e1\ 2082}# + #{e2\ 2083}#) + (let ((#{names\ 2084}# + (map (lambda (#{x\ 2085}#) + (#{id-var-name\ 1319}# + #{x\ 2085}# + #{w\ 2068}#)) + #{var\ 2080}#))) (begin (for-each - (lambda (id904 n905) - (let ((atom-key906 - (binding-type107 - (lookup112 n905 r884 mod887)))) - (if (memv atom-key906 + (lambda (#{id\ 2087}# #{n\ 2088}#) + (let ((#{atom-key\ 2089}# + (#{binding-type\ 1289}# + (#{lookup\ 1294}# + #{n\ 2088}# + #{r\ 2067}# + #{mod\ 2070}#)))) + (if (memv #{atom-key\ 2089}# '(displaced-lexical)) (syntax-violation 'fluid-let-syntax "identifier out of context" - e883 - (source-wrap144 - id904 - w885 - s886 - mod887))))) - var897 - names901) - (chi-body155 - (cons e1899 e2900) - (source-wrap144 e883 w885 s886 mod887) - (extend-env109 - names901 - (let ((trans-r909 - (macros-only-env111 r884))) - (map (lambda (x910) + #{e\ 2066}# + (#{source-wrap\ 1326}# + #{id\ 2087}# + #{w\ 2068}# + #{s\ 2069}# + #{mod\ 2070}#))))) + #{var\ 2080}# + #{names\ 2084}#) + (#{chi-body\ 1337}# + (cons #{e1\ 2082}# #{e2\ 2083}#) + (#{source-wrap\ 1326}# + #{e\ 2066}# + #{w\ 2068}# + #{s\ 2069}# + #{mod\ 2070}#) + (#{extend-env\ 1291}# + #{names\ 2084}# + (let ((#{trans-r\ 2092}# + (#{macros-only-env\ 1293}# + #{r\ 2067}#))) + (map (lambda (#{x\ 2093}#) (cons 'macro - (eval-local-transformer158 - (chi151 - x910 - trans-r909 - w885 - mod887) - mod887))) - val898)) - r884) - w885 - mod887)))) - tmp889) - ((lambda (_912) + (#{eval-local-transformer\ 1340}# + (#{chi\ 1333}# + #{x\ 2093}# + #{trans-r\ 2092}# + #{w\ 2068}# + #{mod\ 2070}#) + #{mod\ 2070}#))) + #{val\ 2081}#)) + #{r\ 2067}#) + #{w\ 2068}# + #{mod\ 2070}#)))) + #{tmp\ 2072}#) + ((lambda (#{_\ 2095}#) (syntax-violation 'fluid-let-syntax "bad syntax" - (source-wrap144 e883 w885 s886 mod887))) - tmp888))) + (#{source-wrap\ 1326}# + #{e\ 2066}# + #{w\ 2068}# + #{s\ 2069}# + #{mod\ 2070}#))) + #{tmp\ 2071}#))) ($sc-dispatch - tmp888 + #{tmp\ 2071}# '(any #(each (any any)) any . each-any)))) - e883))) - (global-extend113 + #{e\ 2066}#))) + (#{global-extend\ 1295}# 'core 'quote - (lambda (e913 r914 w915 s916 mod917) - ((lambda (tmp918) - ((lambda (tmp919) - (if tmp919 - (apply (lambda (_920 e921) - (build-data93 s916 (strip161 e921 w915))) - tmp919) - ((lambda (_922) + (lambda (#{e\ 2096}# + #{r\ 2097}# + #{w\ 2098}# + #{s\ 2099}# + #{mod\ 2100}#) + ((lambda (#{tmp\ 2101}#) + ((lambda (#{tmp\ 2102}#) + (if #{tmp\ 2102}# + (apply (lambda (#{_\ 2103}# #{e\ 2104}#) + (#{build-data\ 1275}# + #{s\ 2099}# + (#{strip\ 1343}# #{e\ 2104}# #{w\ 2098}#))) + #{tmp\ 2102}#) + ((lambda (#{_\ 2105}#) (syntax-violation 'quote "bad syntax" - (source-wrap144 e913 w915 s916 mod917))) - tmp918))) - ($sc-dispatch tmp918 (quote (any any))))) - e913))) - (global-extend113 + (#{source-wrap\ 1326}# + #{e\ 2096}# + #{w\ 2098}# + #{s\ 2099}# + #{mod\ 2100}#))) + #{tmp\ 2101}#))) + ($sc-dispatch #{tmp\ 2101}# (quote (any any))))) + #{e\ 2096}#))) + (#{global-extend\ 1295}# 'core 'syntax - (letrec ((regen930 - (lambda (x931) - (let ((atom-key932 (car x931))) - (if (memv atom-key932 (quote (ref))) - (build-lexical-reference84 + (letrec ((#{regen\ 2113}# + (lambda (#{x\ 2114}#) + (let ((#{atom-key\ 2115}# (car #{x\ 2114}#))) + (if (memv #{atom-key\ 2115}# (quote (ref))) + (#{build-lexical-reference\ 1266}# 'value #f - (cadr x931) - (cadr x931)) - (if (memv atom-key932 (quote (primitive))) - (build-primref92 #f (cadr x931)) - (if (memv atom-key932 (quote (quote))) - (build-data93 #f (cadr x931)) - (if (memv atom-key932 (quote (lambda))) - (build-lambda91 + (cadr #{x\ 2114}#) + (cadr #{x\ 2114}#)) + (if (memv #{atom-key\ 2115}# (quote (primitive))) + (#{build-primref\ 1274}# #f (cadr #{x\ 2114}#)) + (if (memv #{atom-key\ 2115}# (quote (quote))) + (#{build-data\ 1275}# #f (cadr #{x\ 2114}#)) + (if (memv #{atom-key\ 2115}# (quote (lambda))) + (#{build-lambda\ 1273}# #f - (cadr x931) - (cadr x931) + (cadr #{x\ 2114}#) + (cadr #{x\ 2114}#) #f - (regen930 (caddr x931))) - (build-application82 + (#{regen\ 2113}# (caddr #{x\ 2114}#))) + (#{build-application\ 1264}# #f - (build-primref92 #f (car x931)) - (map regen930 (cdr x931)))))))))) - (gen-vector929 - (lambda (x933) - (if (eq? (car x933) (quote list)) - (cons (quote vector) (cdr x933)) - (if (eq? (car x933) (quote quote)) - (list (quote quote) (list->vector (cadr x933))) - (list (quote list->vector) x933))))) - (gen-append928 - (lambda (x934 y935) - (if (equal? y935 (quote (quote ()))) - x934 - (list (quote append) x934 y935)))) - (gen-cons927 - (lambda (x936 y937) - (let ((atom-key938 (car y937))) - (if (memv atom-key938 (quote (quote))) - (if (eq? (car x936) (quote quote)) + (#{build-primref\ 1274}# #f (car #{x\ 2114}#)) + (map #{regen\ 2113}# + (cdr #{x\ 2114}#)))))))))) + (#{gen-vector\ 2112}# + (lambda (#{x\ 2116}#) + (if (eq? (car #{x\ 2116}#) (quote list)) + (cons (quote vector) (cdr #{x\ 2116}#)) + (if (eq? (car #{x\ 2116}#) (quote quote)) + (list 'quote + (list->vector (cadr #{x\ 2116}#))) + (list (quote list->vector) #{x\ 2116}#))))) + (#{gen-append\ 2111}# + (lambda (#{x\ 2117}# #{y\ 2118}#) + (if (equal? #{y\ 2118}# (quote (quote ()))) + #{x\ 2117}# + (list (quote append) #{x\ 2117}# #{y\ 2118}#)))) + (#{gen-cons\ 2110}# + (lambda (#{x\ 2119}# #{y\ 2120}#) + (let ((#{atom-key\ 2121}# (car #{y\ 2120}#))) + (if (memv #{atom-key\ 2121}# (quote (quote))) + (if (eq? (car #{x\ 2119}#) (quote quote)) (list 'quote - (cons (cadr x936) (cadr y937))) - (if (eq? (cadr y937) (quote ())) - (list (quote list) x936) - (list (quote cons) x936 y937))) - (if (memv atom-key938 (quote (list))) - (cons (quote list) (cons x936 (cdr y937))) - (list (quote cons) x936 y937)))))) - (gen-map926 - (lambda (e939 map-env940) - (let ((formals941 (map cdr map-env940)) - (actuals942 - (map (lambda (x943) (list (quote ref) (car x943))) - map-env940))) - (if (eq? (car e939) (quote ref)) - (car actuals942) + (cons (cadr #{x\ 2119}#) (cadr #{y\ 2120}#))) + (if (eq? (cadr #{y\ 2120}#) (quote ())) + (list (quote list) #{x\ 2119}#) + (list (quote cons) #{x\ 2119}# #{y\ 2120}#))) + (if (memv #{atom-key\ 2121}# (quote (list))) + (cons 'list + (cons #{x\ 2119}# (cdr #{y\ 2120}#))) + (list (quote cons) #{x\ 2119}# #{y\ 2120}#)))))) + (#{gen-map\ 2109}# + (lambda (#{e\ 2122}# #{map-env\ 2123}#) + (let ((#{formals\ 2124}# (map cdr #{map-env\ 2123}#)) + (#{actuals\ 2125}# + (map (lambda (#{x\ 2126}#) + (list (quote ref) (car #{x\ 2126}#))) + #{map-env\ 2123}#))) + (if (eq? (car #{e\ 2122}#) (quote ref)) + (car #{actuals\ 2125}#) (if (and-map - (lambda (x944) - (if (eq? (car x944) (quote ref)) - (memq (cadr x944) formals941) + (lambda (#{x\ 2127}#) + (if (eq? (car #{x\ 2127}#) (quote ref)) + (memq (cadr #{x\ 2127}#) #{formals\ 2124}#) #f)) - (cdr e939)) + (cdr #{e\ 2122}#)) (cons 'map - (cons (list (quote primitive) (car e939)) - (map (let ((r945 (map cons - formals941 - actuals942))) - (lambda (x946) - (cdr (assq (cadr x946) r945)))) - (cdr e939)))) + (cons (list 'primitive + (car #{e\ 2122}#)) + (map (let ((#{r\ 2128}# + (map cons + #{formals\ 2124}# + #{actuals\ 2125}#))) + (lambda (#{x\ 2129}#) + (cdr (assq (cadr #{x\ 2129}#) + #{r\ 2128}#)))) + (cdr #{e\ 2122}#)))) (cons 'map - (cons (list (quote lambda) formals941 e939) - actuals942))))))) - (gen-mappend925 - (lambda (e947 map-env948) + (cons (list 'lambda + #{formals\ 2124}# + #{e\ 2122}#) + #{actuals\ 2125}#))))))) + (#{gen-mappend\ 2108}# + (lambda (#{e\ 2130}# #{map-env\ 2131}#) (list 'apply '(primitive append) - (gen-map926 e947 map-env948)))) - (gen-ref924 - (lambda (src949 var950 level951 maps952) - (if (fx=74 level951 0) - (values var950 maps952) - (if (null? maps952) + (#{gen-map\ 2109}# #{e\ 2130}# #{map-env\ 2131}#)))) + (#{gen-ref\ 2107}# + (lambda (#{src\ 2132}# + #{var\ 2133}# + #{level\ 2134}# + #{maps\ 2135}#) + (if (#{fx=\ 1256}# #{level\ 2134}# 0) + (values #{var\ 2133}# #{maps\ 2135}#) + (if (null? #{maps\ 2135}#) (syntax-violation 'syntax "missing ellipsis" - src949) + #{src\ 2132}#) (call-with-values (lambda () - (gen-ref924 - src949 - var950 - (fx-73 level951 1) - (cdr maps952))) - (lambda (outer-var953 outer-maps954) - (let ((b955 (assq outer-var953 (car maps952)))) - (if b955 - (values (cdr b955) maps952) - (let ((inner-var956 (gen-var162 (quote tmp)))) + (#{gen-ref\ 2107}# + #{src\ 2132}# + #{var\ 2133}# + (#{fx-\ 1255}# #{level\ 2134}# 1) + (cdr #{maps\ 2135}#))) + (lambda (#{outer-var\ 2136}# #{outer-maps\ 2137}#) + (let ((#{b\ 2138}# + (assq #{outer-var\ 2136}# + (car #{maps\ 2135}#)))) + (if #{b\ 2138}# + (values (cdr #{b\ 2138}#) #{maps\ 2135}#) + (let ((#{inner-var\ 2139}# + (#{gen-var\ 1344}# (quote tmp)))) (values - inner-var956 - (cons (cons (cons outer-var953 - inner-var956) - (car maps952)) - outer-maps954))))))))))) - (gen-syntax923 - (lambda (src957 e958 r959 maps960 ellipsis?961 mod962) - (if (id?115 e958) - (let ((label963 (id-var-name137 e958 (quote (()))))) - (let ((b964 (lookup112 label963 r959 mod962))) - (if (eq? (binding-type107 b964) (quote syntax)) + #{inner-var\ 2139}# + (cons (cons (cons #{outer-var\ 2136}# + #{inner-var\ 2139}#) + (car #{maps\ 2135}#)) + #{outer-maps\ 2137}#))))))))))) + (#{gen-syntax\ 2106}# + (lambda (#{src\ 2140}# + #{e\ 2141}# + #{r\ 2142}# + #{maps\ 2143}# + #{ellipsis?\ 2144}# + #{mod\ 2145}#) + (if (#{id?\ 1297}# #{e\ 2141}#) + (let ((#{label\ 2146}# + (#{id-var-name\ 1319}# + #{e\ 2141}# + '(())))) + (let ((#{b\ 2147}# + (#{lookup\ 1294}# + #{label\ 2146}# + #{r\ 2142}# + #{mod\ 2145}#))) + (if (eq? (#{binding-type\ 1289}# #{b\ 2147}#) + 'syntax) (call-with-values (lambda () - (let ((var.lev965 (binding-value108 b964))) - (gen-ref924 - src957 - (car var.lev965) - (cdr var.lev965) - maps960))) - (lambda (var966 maps967) - (values (list (quote ref) var966) maps967))) - (if (ellipsis?961 e958) + (let ((#{var.lev\ 2148}# + (#{binding-value\ 1290}# + #{b\ 2147}#))) + (#{gen-ref\ 2107}# + #{src\ 2140}# + (car #{var.lev\ 2148}#) + (cdr #{var.lev\ 2148}#) + #{maps\ 2143}#))) + (lambda (#{var\ 2149}# #{maps\ 2150}#) + (values + (list (quote ref) #{var\ 2149}#) + #{maps\ 2150}#))) + (if (#{ellipsis?\ 2144}# #{e\ 2141}#) (syntax-violation 'syntax "misplaced ellipsis" - src957) - (values (list (quote quote) e958) maps960))))) - ((lambda (tmp968) - ((lambda (tmp969) - (if (if tmp969 - (apply (lambda (dots970 e971) - (ellipsis?961 dots970)) - tmp969) + #{src\ 2140}#) + (values + (list (quote quote) #{e\ 2141}#) + #{maps\ 2143}#))))) + ((lambda (#{tmp\ 2151}#) + ((lambda (#{tmp\ 2152}#) + (if (if #{tmp\ 2152}# + (apply (lambda (#{dots\ 2153}# #{e\ 2154}#) + (#{ellipsis?\ 2144}# + #{dots\ 2153}#)) + #{tmp\ 2152}#) #f) - (apply (lambda (dots972 e973) - (gen-syntax923 - src957 - e973 - r959 - maps960 - (lambda (x974) #f) - mod962)) - tmp969) - ((lambda (tmp975) - (if (if tmp975 - (apply (lambda (x976 dots977 y978) - (ellipsis?961 dots977)) - tmp975) + (apply (lambda (#{dots\ 2155}# #{e\ 2156}#) + (#{gen-syntax\ 2106}# + #{src\ 2140}# + #{e\ 2156}# + #{r\ 2142}# + #{maps\ 2143}# + (lambda (#{x\ 2157}#) #f) + #{mod\ 2145}#)) + #{tmp\ 2152}#) + ((lambda (#{tmp\ 2158}#) + (if (if #{tmp\ 2158}# + (apply (lambda (#{x\ 2159}# + #{dots\ 2160}# + #{y\ 2161}#) + (#{ellipsis?\ 2144}# + #{dots\ 2160}#)) + #{tmp\ 2158}#) #f) - (apply (lambda (x979 dots980 y981) - (letrec ((f982 (lambda (y983 k984) - ((lambda (tmp988) - ((lambda (tmp989) - (if (if tmp989 - (apply (lambda (dots990 - y991) - (ellipsis?961 - dots990)) - tmp989) - #f) - (apply (lambda (dots992 - y993) - (f982 y993 - (lambda (maps994) - (call-with-values - (lambda () - (k984 (cons '() - maps994))) - (lambda (x995 - maps996) - (if (null? (car maps996)) - (syntax-violation - 'syntax - "extra ellipsis" - src957) - (values - (gen-mappend925 - x995 - (car maps996)) - (cdr maps996)))))))) - tmp989) - ((lambda (_997) + (apply (lambda (#{x\ 2162}# + #{dots\ 2163}# + #{y\ 2164}#) + (letrec ((#{f\ 2165}# + (lambda (#{y\ 2166}# + #{k\ 2167}#) + ((lambda (#{tmp\ 2171}#) + ((lambda (#{tmp\ 2172}#) + (if (if #{tmp\ 2172}# + (apply (lambda (#{dots\ 2173}# + #{y\ 2174}#) + (#{ellipsis?\ 2144}# + #{dots\ 2173}#)) + #{tmp\ 2172}#) + #f) + (apply (lambda (#{dots\ 2175}# + #{y\ 2176}#) + (#{f\ 2165}# + #{y\ 2176}# + (lambda (#{maps\ 2177}#) + (call-with-values + (lambda () + (#{k\ 2167}# + (cons '() + #{maps\ 2177}#))) + (lambda (#{x\ 2178}# + #{maps\ 2179}#) + (if (null? (car #{maps\ 2179}#)) + (syntax-violation + 'syntax + "extra ellipsis" + #{src\ 2140}#) + (values + (#{gen-mappend\ 2108}# + #{x\ 2178}# + (car #{maps\ 2179}#)) + (cdr #{maps\ 2179}#)))))))) + #{tmp\ 2172}#) + ((lambda (#{_\ 2180}#) + (call-with-values + (lambda () + (#{gen-syntax\ 2106}# + #{src\ 2140}# + #{y\ 2166}# + #{r\ 2142}# + #{maps\ 2143}# + #{ellipsis?\ 2144}# + #{mod\ 2145}#)) + (lambda (#{y\ 2181}# + #{maps\ 2182}#) (call-with-values (lambda () - (gen-syntax923 - src957 - y983 - r959 - maps960 - ellipsis?961 - mod962)) - (lambda (y998 - maps999) - (call-with-values - (lambda () - (k984 maps999)) - (lambda (x1000 - maps1001) - (values - (gen-append928 - x1000 - y998) - maps1001)))))) - tmp988))) - ($sc-dispatch - tmp988 - '(any . - any)))) - y983)))) - (f982 y981 - (lambda (maps985) - (call-with-values - (lambda () - (gen-syntax923 - src957 - x979 - r959 - (cons '() - maps985) - ellipsis?961 - mod962)) - (lambda (x986 maps987) - (if (null? (car maps987)) - (syntax-violation - 'syntax - "extra ellipsis" - src957) - (values - (gen-map926 - x986 - (car maps987)) - (cdr maps987))))))))) - tmp975) - ((lambda (tmp1002) - (if tmp1002 - (apply (lambda (x1003 y1004) + (#{k\ 2167}# + #{maps\ 2182}#)) + (lambda (#{x\ 2183}# + #{maps\ 2184}#) + (values + (#{gen-append\ 2111}# + #{x\ 2183}# + #{y\ 2181}#) + #{maps\ 2184}#)))))) + #{tmp\ 2171}#))) + ($sc-dispatch + #{tmp\ 2171}# + '(any . any)))) + #{y\ 2166}#)))) + (#{f\ 2165}# + #{y\ 2164}# + (lambda (#{maps\ 2168}#) + (call-with-values + (lambda () + (#{gen-syntax\ 2106}# + #{src\ 2140}# + #{x\ 2162}# + #{r\ 2142}# + (cons '() + #{maps\ 2168}#) + #{ellipsis?\ 2144}# + #{mod\ 2145}#)) + (lambda (#{x\ 2169}# + #{maps\ 2170}#) + (if (null? (car #{maps\ 2170}#)) + (syntax-violation + 'syntax + "extra ellipsis" + #{src\ 2140}#) + (values + (#{gen-map\ 2109}# + #{x\ 2169}# + (car #{maps\ 2170}#)) + (cdr #{maps\ 2170}#))))))))) + #{tmp\ 2158}#) + ((lambda (#{tmp\ 2185}#) + (if #{tmp\ 2185}# + (apply (lambda (#{x\ 2186}# + #{y\ 2187}#) (call-with-values (lambda () - (gen-syntax923 - src957 - x1003 - r959 - maps960 - ellipsis?961 - mod962)) - (lambda (x1005 maps1006) + (#{gen-syntax\ 2106}# + #{src\ 2140}# + #{x\ 2186}# + #{r\ 2142}# + #{maps\ 2143}# + #{ellipsis?\ 2144}# + #{mod\ 2145}#)) + (lambda (#{x\ 2188}# + #{maps\ 2189}#) (call-with-values (lambda () - (gen-syntax923 - src957 - y1004 - r959 - maps1006 - ellipsis?961 - mod962)) - (lambda (y1007 - maps1008) + (#{gen-syntax\ 2106}# + #{src\ 2140}# + #{y\ 2187}# + #{r\ 2142}# + #{maps\ 2189}# + #{ellipsis?\ 2144}# + #{mod\ 2145}#)) + (lambda (#{y\ 2190}# + #{maps\ 2191}#) (values - (gen-cons927 - x1005 - y1007) - maps1008)))))) - tmp1002) - ((lambda (tmp1009) - (if tmp1009 - (apply (lambda (e11010 e21011) + (#{gen-cons\ 2110}# + #{x\ 2188}# + #{y\ 2190}#) + #{maps\ 2191}#)))))) + #{tmp\ 2185}#) + ((lambda (#{tmp\ 2192}#) + (if #{tmp\ 2192}# + (apply (lambda (#{e1\ 2193}# + #{e2\ 2194}#) (call-with-values (lambda () - (gen-syntax923 - src957 - (cons e11010 - e21011) - r959 - maps960 - ellipsis?961 - mod962)) - (lambda (e1013 - maps1014) + (#{gen-syntax\ 2106}# + #{src\ 2140}# + (cons #{e1\ 2193}# + #{e2\ 2194}#) + #{r\ 2142}# + #{maps\ 2143}# + #{ellipsis?\ 2144}# + #{mod\ 2145}#)) + (lambda (#{e\ 2196}# + #{maps\ 2197}#) (values - (gen-vector929 - e1013) - maps1014)))) - tmp1009) - ((lambda (_1015) + (#{gen-vector\ 2112}# + #{e\ 2196}#) + #{maps\ 2197}#)))) + #{tmp\ 2192}#) + ((lambda (#{_\ 2198}#) (values - (list (quote quote) e958) - maps960)) - tmp968))) + (list 'quote + #{e\ 2141}#) + #{maps\ 2143}#)) + #{tmp\ 2151}#))) ($sc-dispatch - tmp968 + #{tmp\ 2151}# '#(vector (any . each-any)))))) ($sc-dispatch - tmp968 + #{tmp\ 2151}# '(any . any))))) ($sc-dispatch - tmp968 + #{tmp\ 2151}# '(any any . any))))) - ($sc-dispatch tmp968 (quote (any any))))) - e958))))) - (lambda (e1016 r1017 w1018 s1019 mod1020) - (let ((e1021 (source-wrap144 e1016 w1018 s1019 mod1020))) - ((lambda (tmp1022) - ((lambda (tmp1023) - (if tmp1023 - (apply (lambda (_1024 x1025) + ($sc-dispatch #{tmp\ 2151}# (quote (any any))))) + #{e\ 2141}#))))) + (lambda (#{e\ 2199}# + #{r\ 2200}# + #{w\ 2201}# + #{s\ 2202}# + #{mod\ 2203}#) + (let ((#{e\ 2204}# + (#{source-wrap\ 1326}# + #{e\ 2199}# + #{w\ 2201}# + #{s\ 2202}# + #{mod\ 2203}#))) + ((lambda (#{tmp\ 2205}#) + ((lambda (#{tmp\ 2206}#) + (if #{tmp\ 2206}# + (apply (lambda (#{_\ 2207}# #{x\ 2208}#) (call-with-values (lambda () - (gen-syntax923 - e1021 - x1025 - r1017 + (#{gen-syntax\ 2106}# + #{e\ 2204}# + #{x\ 2208}# + #{r\ 2200}# '() - ellipsis?160 - mod1020)) - (lambda (e1026 maps1027) (regen930 e1026)))) - tmp1023) - ((lambda (_1028) + #{ellipsis?\ 1342}# + #{mod\ 2203}#)) + (lambda (#{e\ 2209}# #{maps\ 2210}#) + (#{regen\ 2113}# #{e\ 2209}#)))) + #{tmp\ 2206}#) + ((lambda (#{_\ 2211}#) (syntax-violation 'syntax "bad `syntax' form" - e1021)) - tmp1022))) - ($sc-dispatch tmp1022 (quote (any any))))) - e1021))))) - (global-extend113 + #{e\ 2204}#)) + #{tmp\ 2205}#))) + ($sc-dispatch #{tmp\ 2205}# (quote (any any))))) + #{e\ 2204}#))))) + (#{global-extend\ 1295}# 'core 'lambda - (lambda (e1029 r1030 w1031 s1032 mod1033) - ((lambda (tmp1034) - ((lambda (tmp1035) - (if tmp1035 - (apply (lambda (_1036 c1037) - (chi-lambda-clause156 - (source-wrap144 e1029 w1031 s1032 mod1033) + (lambda (#{e\ 2212}# + #{r\ 2213}# + #{w\ 2214}# + #{s\ 2215}# + #{mod\ 2216}#) + ((lambda (#{tmp\ 2217}#) + ((lambda (#{tmp\ 2218}#) + (if #{tmp\ 2218}# + (apply (lambda (#{_\ 2219}# #{c\ 2220}#) + (#{chi-lambda-clause\ 1338}# + (#{source-wrap\ 1326}# + #{e\ 2212}# + #{w\ 2214}# + #{s\ 2215}# + #{mod\ 2216}#) #f - c1037 - r1030 - w1031 - mod1033 - (lambda (names1038 - vars1039 - docstring1040 - body1041) - (build-lambda91 - s1032 - names1038 - vars1039 - docstring1040 - body1041)))) - tmp1035) + #{c\ 2220}# + #{r\ 2213}# + #{w\ 2214}# + #{mod\ 2216}# + (lambda (#{names\ 2221}# + #{vars\ 2222}# + #{docstring\ 2223}# + #{body\ 2224}#) + (#{build-lambda\ 1273}# + #{s\ 2215}# + #{names\ 2221}# + #{vars\ 2222}# + #{docstring\ 2223}# + #{body\ 2224}#)))) + #{tmp\ 2218}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1034))) - ($sc-dispatch tmp1034 (quote (any . any))))) - e1029))) - (global-extend113 + #{tmp\ 2217}#))) + ($sc-dispatch #{tmp\ 2217}# (quote (any . any))))) + #{e\ 2212}#))) + (#{global-extend\ 1295}# 'core 'let - (letrec ((chi-let1042 - (lambda (e1043 - r1044 - w1045 - s1046 - mod1047 - constructor1048 - ids1049 - vals1050 - exps1051) - (if (not (valid-bound-ids?140 ids1049)) + (letrec ((#{chi-let\ 2225}# + (lambda (#{e\ 2226}# + #{r\ 2227}# + #{w\ 2228}# + #{s\ 2229}# + #{mod\ 2230}# + #{constructor\ 2231}# + #{ids\ 2232}# + #{vals\ 2233}# + #{exps\ 2234}#) + (if (not (#{valid-bound-ids?\ 1322}# #{ids\ 2232}#)) (syntax-violation 'let "duplicate bound variable" - e1043) - (let ((labels1052 (gen-labels121 ids1049)) - (new-vars1053 (map gen-var162 ids1049))) - (let ((nw1054 - (make-binding-wrap132 - ids1049 - labels1052 - w1045)) - (nr1055 - (extend-var-env110 - labels1052 - new-vars1053 - r1044))) - (constructor1048 - s1046 - (map syntax->datum ids1049) - new-vars1053 - (map (lambda (x1056) - (chi151 x1056 r1044 w1045 mod1047)) - vals1050) - (chi-body155 - exps1051 - (source-wrap144 e1043 nw1054 s1046 mod1047) - nr1055 - nw1054 - mod1047)))))))) - (lambda (e1057 r1058 w1059 s1060 mod1061) - ((lambda (tmp1062) - ((lambda (tmp1063) - (if (if tmp1063 - (apply (lambda (_1064 id1065 val1066 e11067 e21068) - (and-map id?115 id1065)) - tmp1063) + #{e\ 2226}#) + (let ((#{labels\ 2235}# + (#{gen-labels\ 1303}# #{ids\ 2232}#)) + (#{new-vars\ 2236}# + (map #{gen-var\ 1344}# #{ids\ 2232}#))) + (let ((#{nw\ 2237}# + (#{make-binding-wrap\ 1314}# + #{ids\ 2232}# + #{labels\ 2235}# + #{w\ 2228}#)) + (#{nr\ 2238}# + (#{extend-var-env\ 1292}# + #{labels\ 2235}# + #{new-vars\ 2236}# + #{r\ 2227}#))) + (#{constructor\ 2231}# + #{s\ 2229}# + (map syntax->datum #{ids\ 2232}#) + #{new-vars\ 2236}# + (map (lambda (#{x\ 2239}#) + (#{chi\ 1333}# + #{x\ 2239}# + #{r\ 2227}# + #{w\ 2228}# + #{mod\ 2230}#)) + #{vals\ 2233}#) + (#{chi-body\ 1337}# + #{exps\ 2234}# + (#{source-wrap\ 1326}# + #{e\ 2226}# + #{nw\ 2237}# + #{s\ 2229}# + #{mod\ 2230}#) + #{nr\ 2238}# + #{nw\ 2237}# + #{mod\ 2230}#)))))))) + (lambda (#{e\ 2240}# + #{r\ 2241}# + #{w\ 2242}# + #{s\ 2243}# + #{mod\ 2244}#) + ((lambda (#{tmp\ 2245}#) + ((lambda (#{tmp\ 2246}#) + (if (if #{tmp\ 2246}# + (apply (lambda (#{_\ 2247}# + #{id\ 2248}# + #{val\ 2249}# + #{e1\ 2250}# + #{e2\ 2251}#) + (and-map #{id?\ 1297}# #{id\ 2248}#)) + #{tmp\ 2246}#) #f) - (apply (lambda (_1070 id1071 val1072 e11073 e21074) - (chi-let1042 - e1057 - r1058 - w1059 - s1060 - mod1061 - build-let95 - id1071 - val1072 - (cons e11073 e21074))) - tmp1063) - ((lambda (tmp1078) - (if (if tmp1078 - (apply (lambda (_1079 - f1080 - id1081 - val1082 - e11083 - e21084) - (if (id?115 f1080) - (and-map id?115 id1081) + (apply (lambda (#{_\ 2253}# + #{id\ 2254}# + #{val\ 2255}# + #{e1\ 2256}# + #{e2\ 2257}#) + (#{chi-let\ 2225}# + #{e\ 2240}# + #{r\ 2241}# + #{w\ 2242}# + #{s\ 2243}# + #{mod\ 2244}# + #{build-let\ 1277}# + #{id\ 2254}# + #{val\ 2255}# + (cons #{e1\ 2256}# #{e2\ 2257}#))) + #{tmp\ 2246}#) + ((lambda (#{tmp\ 2261}#) + (if (if #{tmp\ 2261}# + (apply (lambda (#{_\ 2262}# + #{f\ 2263}# + #{id\ 2264}# + #{val\ 2265}# + #{e1\ 2266}# + #{e2\ 2267}#) + (if (#{id?\ 1297}# #{f\ 2263}#) + (and-map #{id?\ 1297}# #{id\ 2264}#) #f)) - tmp1078) + #{tmp\ 2261}#) #f) - (apply (lambda (_1086 - f1087 - id1088 - val1089 - e11090 - e21091) - (chi-let1042 - e1057 - r1058 - w1059 - s1060 - mod1061 - build-named-let96 - (cons f1087 id1088) - val1089 - (cons e11090 e21091))) - tmp1078) - ((lambda (_1095) + (apply (lambda (#{_\ 2269}# + #{f\ 2270}# + #{id\ 2271}# + #{val\ 2272}# + #{e1\ 2273}# + #{e2\ 2274}#) + (#{chi-let\ 2225}# + #{e\ 2240}# + #{r\ 2241}# + #{w\ 2242}# + #{s\ 2243}# + #{mod\ 2244}# + #{build-named-let\ 1278}# + (cons #{f\ 2270}# #{id\ 2271}#) + #{val\ 2272}# + (cons #{e1\ 2273}# #{e2\ 2274}#))) + #{tmp\ 2261}#) + ((lambda (#{_\ 2278}#) (syntax-violation 'let "bad let" - (source-wrap144 e1057 w1059 s1060 mod1061))) - tmp1062))) + (#{source-wrap\ 1326}# + #{e\ 2240}# + #{w\ 2242}# + #{s\ 2243}# + #{mod\ 2244}#))) + #{tmp\ 2245}#))) ($sc-dispatch - tmp1062 + #{tmp\ 2245}# '(any any #(each (any any)) any . each-any))))) ($sc-dispatch - tmp1062 + #{tmp\ 2245}# '(any #(each (any any)) any . each-any)))) - e1057)))) - (global-extend113 + #{e\ 2240}#)))) + (#{global-extend\ 1295}# 'core 'letrec - (lambda (e1096 r1097 w1098 s1099 mod1100) - ((lambda (tmp1101) - ((lambda (tmp1102) - (if (if tmp1102 - (apply (lambda (_1103 id1104 val1105 e11106 e21107) - (and-map id?115 id1104)) - tmp1102) + (lambda (#{e\ 2279}# + #{r\ 2280}# + #{w\ 2281}# + #{s\ 2282}# + #{mod\ 2283}#) + ((lambda (#{tmp\ 2284}#) + ((lambda (#{tmp\ 2285}#) + (if (if #{tmp\ 2285}# + (apply (lambda (#{_\ 2286}# + #{id\ 2287}# + #{val\ 2288}# + #{e1\ 2289}# + #{e2\ 2290}#) + (and-map #{id?\ 1297}# #{id\ 2287}#)) + #{tmp\ 2285}#) #f) - (apply (lambda (_1109 id1110 val1111 e11112 e21113) - (let ((ids1114 id1110)) - (if (not (valid-bound-ids?140 ids1114)) + (apply (lambda (#{_\ 2292}# + #{id\ 2293}# + #{val\ 2294}# + #{e1\ 2295}# + #{e2\ 2296}#) + (let ((#{ids\ 2297}# #{id\ 2293}#)) + (if (not (#{valid-bound-ids?\ 1322}# + #{ids\ 2297}#)) (syntax-violation 'letrec "duplicate bound variable" - e1096) - (let ((labels1116 (gen-labels121 ids1114)) - (new-vars1117 (map gen-var162 ids1114))) - (let ((w1118 (make-binding-wrap132 - ids1114 - labels1116 - w1098)) - (r1119 (extend-var-env110 - labels1116 - new-vars1117 - r1097))) - (build-letrec97 - s1099 - (map syntax->datum ids1114) - new-vars1117 - (map (lambda (x1120) - (chi151 x1120 r1119 w1118 mod1100)) - val1111) - (chi-body155 - (cons e11112 e21113) - (source-wrap144 - e1096 - w1118 - s1099 - mod1100) - r1119 - w1118 - mod1100))))))) - tmp1102) - ((lambda (_1123) + #{e\ 2279}#) + (let ((#{labels\ 2299}# + (#{gen-labels\ 1303}# #{ids\ 2297}#)) + (#{new-vars\ 2300}# + (map #{gen-var\ 1344}# #{ids\ 2297}#))) + (let ((#{w\ 2301}# + (#{make-binding-wrap\ 1314}# + #{ids\ 2297}# + #{labels\ 2299}# + #{w\ 2281}#)) + (#{r\ 2302}# + (#{extend-var-env\ 1292}# + #{labels\ 2299}# + #{new-vars\ 2300}# + #{r\ 2280}#))) + (#{build-letrec\ 1279}# + #{s\ 2282}# + (map syntax->datum #{ids\ 2297}#) + #{new-vars\ 2300}# + (map (lambda (#{x\ 2303}#) + (#{chi\ 1333}# + #{x\ 2303}# + #{r\ 2302}# + #{w\ 2301}# + #{mod\ 2283}#)) + #{val\ 2294}#) + (#{chi-body\ 1337}# + (cons #{e1\ 2295}# #{e2\ 2296}#) + (#{source-wrap\ 1326}# + #{e\ 2279}# + #{w\ 2301}# + #{s\ 2282}# + #{mod\ 2283}#) + #{r\ 2302}# + #{w\ 2301}# + #{mod\ 2283}#))))))) + #{tmp\ 2285}#) + ((lambda (#{_\ 2306}#) (syntax-violation 'letrec "bad letrec" - (source-wrap144 e1096 w1098 s1099 mod1100))) - tmp1101))) + (#{source-wrap\ 1326}# + #{e\ 2279}# + #{w\ 2281}# + #{s\ 2282}# + #{mod\ 2283}#))) + #{tmp\ 2284}#))) ($sc-dispatch - tmp1101 + #{tmp\ 2284}# '(any #(each (any any)) any . each-any)))) - e1096))) - (global-extend113 + #{e\ 2279}#))) + (#{global-extend\ 1295}# 'core 'set! - (lambda (e1124 r1125 w1126 s1127 mod1128) - ((lambda (tmp1129) - ((lambda (tmp1130) - (if (if tmp1130 - (apply (lambda (_1131 id1132 val1133) (id?115 id1132)) - tmp1130) + (lambda (#{e\ 2307}# + #{r\ 2308}# + #{w\ 2309}# + #{s\ 2310}# + #{mod\ 2311}#) + ((lambda (#{tmp\ 2312}#) + ((lambda (#{tmp\ 2313}#) + (if (if #{tmp\ 2313}# + (apply (lambda (#{_\ 2314}# #{id\ 2315}# #{val\ 2316}#) + (#{id?\ 1297}# #{id\ 2315}#)) + #{tmp\ 2313}#) #f) - (apply (lambda (_1134 id1135 val1136) - (let ((val1137 (chi151 val1136 r1125 w1126 mod1128)) - (n1138 (id-var-name137 id1135 w1126))) - (let ((b1139 (lookup112 n1138 r1125 mod1128))) - (let ((atom-key1140 (binding-type107 b1139))) - (if (memv atom-key1140 (quote (lexical))) - (build-lexical-assignment85 - s1127 - (syntax->datum id1135) - (binding-value108 b1139) - val1137) - (if (memv atom-key1140 (quote (global))) - (build-global-assignment88 - s1127 - n1138 - val1137 - mod1128) - (if (memv atom-key1140 + (apply (lambda (#{_\ 2317}# #{id\ 2318}# #{val\ 2319}#) + (let ((#{val\ 2320}# + (#{chi\ 1333}# + #{val\ 2319}# + #{r\ 2308}# + #{w\ 2309}# + #{mod\ 2311}#)) + (#{n\ 2321}# + (#{id-var-name\ 1319}# + #{id\ 2318}# + #{w\ 2309}#))) + (let ((#{b\ 2322}# + (#{lookup\ 1294}# + #{n\ 2321}# + #{r\ 2308}# + #{mod\ 2311}#))) + (let ((#{atom-key\ 2323}# + (#{binding-type\ 1289}# #{b\ 2322}#))) + (if (memv #{atom-key\ 2323}# + '(lexical)) + (#{build-lexical-assignment\ 1267}# + #{s\ 2310}# + (syntax->datum #{id\ 2318}#) + (#{binding-value\ 1290}# #{b\ 2322}#) + #{val\ 2320}#) + (if (memv #{atom-key\ 2323}# + '(global)) + (#{build-global-assignment\ 1270}# + #{s\ 2310}# + #{n\ 2321}# + #{val\ 2320}# + #{mod\ 2311}#) + (if (memv #{atom-key\ 2323}# '(displaced-lexical)) (syntax-violation 'set! "identifier out of context" - (wrap143 id1135 w1126 mod1128)) + (#{wrap\ 1325}# + #{id\ 2318}# + #{w\ 2309}# + #{mod\ 2311}#)) (syntax-violation 'set! "bad set!" - (source-wrap144 - e1124 - w1126 - s1127 - mod1128))))))))) - tmp1130) - ((lambda (tmp1141) - (if tmp1141 - (apply (lambda (_1142 head1143 tail1144 val1145) + (#{source-wrap\ 1326}# + #{e\ 2307}# + #{w\ 2309}# + #{s\ 2310}# + #{mod\ 2311}#))))))))) + #{tmp\ 2313}#) + ((lambda (#{tmp\ 2324}#) + (if #{tmp\ 2324}# + (apply (lambda (#{_\ 2325}# + #{head\ 2326}# + #{tail\ 2327}# + #{val\ 2328}#) (call-with-values (lambda () - (syntax-type149 - head1143 - r1125 + (#{syntax-type\ 1331}# + #{head\ 2326}# + #{r\ 2308}# '(()) #f #f - mod1128 + #{mod\ 2311}# #t)) - (lambda (type1146 - value1147 - ee1148 - ww1149 - ss1150 - modmod1151) - (if (memv type1146 (quote (module-ref))) - (let ((val1152 - (chi151 - val1145 - r1125 - w1126 - mod1128))) + (lambda (#{type\ 2329}# + #{value\ 2330}# + #{ee\ 2331}# + #{ww\ 2332}# + #{ss\ 2333}# + #{modmod\ 2334}#) + (if (memv #{type\ 2329}# + '(module-ref)) + (let ((#{val\ 2335}# + (#{chi\ 1333}# + #{val\ 2328}# + #{r\ 2308}# + #{w\ 2309}# + #{mod\ 2311}#))) (call-with-values (lambda () - (value1147 - (cons head1143 tail1144))) - (lambda (id1154 mod1155) - (build-global-assignment88 - s1127 - id1154 - val1152 - mod1155)))) - (build-application82 - s1127 - (chi151 + (#{value\ 2330}# + (cons #{head\ 2326}# + #{tail\ 2327}#))) + (lambda (#{id\ 2337}# #{mod\ 2338}#) + (#{build-global-assignment\ 1270}# + #{s\ 2310}# + #{id\ 2337}# + #{val\ 2335}# + #{mod\ 2338}#)))) + (#{build-application\ 1264}# + #{s\ 2310}# + (#{chi\ 1333}# (list '#(syntax-object setter ((top) @@ -6492,47 +7154,53 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - head1143) - r1125 - w1126 - mod1128) - (map (lambda (e1156) - (chi151 - e1156 - r1125 - w1126 - mod1128)) + #{head\ 2326}#) + #{r\ 2308}# + #{w\ 2309}# + #{mod\ 2311}#) + (map (lambda (#{e\ 2339}#) + (#{chi\ 1333}# + #{e\ 2339}# + #{r\ 2308}# + #{w\ 2309}# + #{mod\ 2311}#)) (append - tail1144 - (list val1145)))))))) - tmp1141) - ((lambda (_1158) + #{tail\ 2327}# + (list #{val\ 2328}#)))))))) + #{tmp\ 2324}#) + ((lambda (#{_\ 2341}#) (syntax-violation 'set! "bad set!" - (source-wrap144 e1124 w1126 s1127 mod1128))) - tmp1129))) + (#{source-wrap\ 1326}# + #{e\ 2307}# + #{w\ 2309}# + #{s\ 2310}# + #{mod\ 2311}#))) + #{tmp\ 2312}#))) ($sc-dispatch - tmp1129 + #{tmp\ 2312}# '(any (any . each-any) any))))) - ($sc-dispatch tmp1129 (quote (any any any))))) - e1124))) - (global-extend113 + ($sc-dispatch + #{tmp\ 2312}# + '(any any any)))) + #{e\ 2307}#))) + (#{global-extend\ 1295}# 'module-ref '@ - (lambda (e1159) - ((lambda (tmp1160) - ((lambda (tmp1161) - (if (if tmp1161 - (apply (lambda (_1162 mod1163 id1164) - (if (and-map id?115 mod1163) - (id?115 id1164) + (lambda (#{e\ 2342}#) + ((lambda (#{tmp\ 2343}#) + ((lambda (#{tmp\ 2344}#) + (if (if #{tmp\ 2344}# + (apply (lambda (#{_\ 2345}# #{mod\ 2346}# #{id\ 2347}#) + (if (and-map #{id?\ 1297}# #{mod\ 2346}#) + (#{id?\ 1297}# #{id\ 2347}#) #f)) - tmp1161) + #{tmp\ 2344}#) #f) - (apply (lambda (_1166 mod1167 id1168) + (apply (lambda (#{_\ 2349}# #{mod\ 2350}# #{id\ 2351}#) (values - (syntax->datum id1168) + (syntax->datum #{id\ 2351}#) (syntax->datum (cons '#(syntax-object public @@ -6885,30 +7553,32 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - mod1167)))) - tmp1161) + #{mod\ 2350}#)))) + #{tmp\ 2344}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1160))) - ($sc-dispatch tmp1160 (quote (any each-any any))))) - e1159))) - (global-extend113 + #{tmp\ 2343}#))) + ($sc-dispatch + #{tmp\ 2343}# + '(any each-any any)))) + #{e\ 2342}#))) + (#{global-extend\ 1295}# 'module-ref '@@ - (lambda (e1170) - ((lambda (tmp1171) - ((lambda (tmp1172) - (if (if tmp1172 - (apply (lambda (_1173 mod1174 id1175) - (if (and-map id?115 mod1174) - (id?115 id1175) + (lambda (#{e\ 2353}#) + ((lambda (#{tmp\ 2354}#) + ((lambda (#{tmp\ 2355}#) + (if (if #{tmp\ 2355}# + (apply (lambda (#{_\ 2356}# #{mod\ 2357}# #{id\ 2358}#) + (if (and-map #{id?\ 1297}# #{mod\ 2357}#) + (#{id?\ 1297}# #{id\ 2358}#) #f)) - tmp1172) + #{tmp\ 2355}#) #f) - (apply (lambda (_1177 mod1178 id1179) + (apply (lambda (#{_\ 2360}# #{mod\ 2361}# #{id\ 2362}#) (values - (syntax->datum id1179) + (syntax->datum #{id\ 2362}#) (syntax->datum (cons '#(syntax-object private @@ -7261,84 +7931,123 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - mod1178)))) - tmp1172) + #{mod\ 2361}#)))) + #{tmp\ 2355}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1171))) - ($sc-dispatch tmp1171 (quote (any each-any any))))) - e1170))) - (global-extend113 + #{tmp\ 2354}#))) + ($sc-dispatch + #{tmp\ 2354}# + '(any each-any any)))) + #{e\ 2353}#))) + (#{global-extend\ 1295}# 'core 'if - (lambda (e1181 r1182 w1183 s1184 mod1185) - ((lambda (tmp1186) - ((lambda (tmp1187) - (if tmp1187 - (apply (lambda (_1188 test1189 then1190) - (build-conditional83 - s1184 - (chi151 test1189 r1182 w1183 mod1185) - (chi151 then1190 r1182 w1183 mod1185) - (build-void81 #f))) - tmp1187) - ((lambda (tmp1191) - (if tmp1191 - (apply (lambda (_1192 test1193 then1194 else1195) - (build-conditional83 - s1184 - (chi151 test1193 r1182 w1183 mod1185) - (chi151 then1194 r1182 w1183 mod1185) - (chi151 else1195 r1182 w1183 mod1185))) - tmp1191) + (lambda (#{e\ 2364}# + #{r\ 2365}# + #{w\ 2366}# + #{s\ 2367}# + #{mod\ 2368}#) + ((lambda (#{tmp\ 2369}#) + ((lambda (#{tmp\ 2370}#) + (if #{tmp\ 2370}# + (apply (lambda (#{_\ 2371}# #{test\ 2372}# #{then\ 2373}#) + (#{build-conditional\ 1265}# + #{s\ 2367}# + (#{chi\ 1333}# + #{test\ 2372}# + #{r\ 2365}# + #{w\ 2366}# + #{mod\ 2368}#) + (#{chi\ 1333}# + #{then\ 2373}# + #{r\ 2365}# + #{w\ 2366}# + #{mod\ 2368}#) + (#{build-void\ 1263}# #f))) + #{tmp\ 2370}#) + ((lambda (#{tmp\ 2374}#) + (if #{tmp\ 2374}# + (apply (lambda (#{_\ 2375}# + #{test\ 2376}# + #{then\ 2377}# + #{else\ 2378}#) + (#{build-conditional\ 1265}# + #{s\ 2367}# + (#{chi\ 1333}# + #{test\ 2376}# + #{r\ 2365}# + #{w\ 2366}# + #{mod\ 2368}#) + (#{chi\ 1333}# + #{then\ 2377}# + #{r\ 2365}# + #{w\ 2366}# + #{mod\ 2368}#) + (#{chi\ 1333}# + #{else\ 2378}# + #{r\ 2365}# + #{w\ 2366}# + #{mod\ 2368}#))) + #{tmp\ 2374}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1186))) - ($sc-dispatch tmp1186 (quote (any any any any)))))) - ($sc-dispatch tmp1186 (quote (any any any))))) - e1181))) - (global-extend113 + #{tmp\ 2369}#))) + ($sc-dispatch + #{tmp\ 2369}# + '(any any any any))))) + ($sc-dispatch + #{tmp\ 2369}# + '(any any any)))) + #{e\ 2364}#))) + (#{global-extend\ 1295}# 'begin 'begin '()) - (global-extend113 + (#{global-extend\ 1295}# 'define 'define '()) - (global-extend113 + (#{global-extend\ 1295}# 'define-syntax 'define-syntax '()) - (global-extend113 + (#{global-extend\ 1295}# 'eval-when 'eval-when '()) - (global-extend113 + (#{global-extend\ 1295}# 'core 'syntax-case - (letrec ((gen-syntax-case1199 - (lambda (x1200 keys1201 clauses1202 r1203 mod1204) - (if (null? clauses1202) - (build-application82 + (letrec ((#{gen-syntax-case\ 2382}# + (lambda (#{x\ 2383}# + #{keys\ 2384}# + #{clauses\ 2385}# + #{r\ 2386}# + #{mod\ 2387}#) + (if (null? #{clauses\ 2385}#) + (#{build-application\ 1264}# #f - (build-primref92 #f (quote syntax-violation)) - (list (build-data93 #f #f) - (build-data93 + (#{build-primref\ 1274}# + #f + 'syntax-violation) + (list (#{build-data\ 1275}# #f #f) + (#{build-data\ 1275}# #f "source expression failed to match any pattern") - x1200)) - ((lambda (tmp1205) - ((lambda (tmp1206) - (if tmp1206 - (apply (lambda (pat1207 exp1208) - (if (if (id?115 pat1207) + #{x\ 2383}#)) + ((lambda (#{tmp\ 2388}#) + ((lambda (#{tmp\ 2389}#) + (if #{tmp\ 2389}# + (apply (lambda (#{pat\ 2390}# #{exp\ 2391}#) + (if (if (#{id?\ 1297}# #{pat\ 2390}#) (and-map - (lambda (x1209) - (not (free-id=?138 - pat1207 - x1209))) + (lambda (#{x\ 2392}#) + (not (#{free-id=?\ 1320}# + #{pat\ 2390}# + #{x\ 2392}#))) (cons '#(syntax-object ... ((top) @@ -7716,620 +8425,731 @@ ((top) (top)) ("i" "i"))) (hygiene guile)) - keys1201)) + #{keys\ 2384}#)) #f) - (let ((labels1210 - (list (gen-label120))) - (var1211 (gen-var162 pat1207))) - (build-application82 + (let ((#{labels\ 2393}# + (list (#{gen-label\ 1302}#))) + (#{var\ 2394}# + (#{gen-var\ 1344}# + #{pat\ 2390}#))) + (#{build-application\ 1264}# #f - (build-lambda91 + (#{build-lambda\ 1273}# #f - (list (syntax->datum pat1207)) - (list var1211) + (list (syntax->datum + #{pat\ 2390}#)) + (list #{var\ 2394}#) #f - (chi151 - exp1208 - (extend-env109 - labels1210 + (#{chi\ 1333}# + #{exp\ 2391}# + (#{extend-env\ 1291}# + #{labels\ 2393}# (list (cons 'syntax - (cons var1211 + (cons #{var\ 2394}# 0))) - r1203) - (make-binding-wrap132 - (list pat1207) - labels1210 + #{r\ 2386}#) + (#{make-binding-wrap\ 1314}# + (list #{pat\ 2390}#) + #{labels\ 2393}# '(())) - mod1204)) - (list x1200))) - (gen-clause1198 - x1200 - keys1201 - (cdr clauses1202) - r1203 - pat1207 + #{mod\ 2387}#)) + (list #{x\ 2383}#))) + (#{gen-clause\ 2381}# + #{x\ 2383}# + #{keys\ 2384}# + (cdr #{clauses\ 2385}#) + #{r\ 2386}# + #{pat\ 2390}# #t - exp1208 - mod1204))) - tmp1206) - ((lambda (tmp1212) - (if tmp1212 - (apply (lambda (pat1213 fender1214 exp1215) - (gen-clause1198 - x1200 - keys1201 - (cdr clauses1202) - r1203 - pat1213 - fender1214 - exp1215 - mod1204)) - tmp1212) - ((lambda (_1216) + #{exp\ 2391}# + #{mod\ 2387}#))) + #{tmp\ 2389}#) + ((lambda (#{tmp\ 2395}#) + (if #{tmp\ 2395}# + (apply (lambda (#{pat\ 2396}# + #{fender\ 2397}# + #{exp\ 2398}#) + (#{gen-clause\ 2381}# + #{x\ 2383}# + #{keys\ 2384}# + (cdr #{clauses\ 2385}#) + #{r\ 2386}# + #{pat\ 2396}# + #{fender\ 2397}# + #{exp\ 2398}# + #{mod\ 2387}#)) + #{tmp\ 2395}#) + ((lambda (#{_\ 2399}#) (syntax-violation 'syntax-case "invalid clause" - (car clauses1202))) - tmp1205))) - ($sc-dispatch tmp1205 (quote (any any any)))))) - ($sc-dispatch tmp1205 (quote (any any))))) - (car clauses1202))))) - (gen-clause1198 - (lambda (x1217 - keys1218 - clauses1219 - r1220 - pat1221 - fender1222 - exp1223 - mod1224) + (car #{clauses\ 2385}#))) + #{tmp\ 2388}#))) + ($sc-dispatch + #{tmp\ 2388}# + '(any any any))))) + ($sc-dispatch #{tmp\ 2388}# (quote (any any))))) + (car #{clauses\ 2385}#))))) + (#{gen-clause\ 2381}# + (lambda (#{x\ 2400}# + #{keys\ 2401}# + #{clauses\ 2402}# + #{r\ 2403}# + #{pat\ 2404}# + #{fender\ 2405}# + #{exp\ 2406}# + #{mod\ 2407}#) (call-with-values (lambda () - (convert-pattern1196 pat1221 keys1218)) - (lambda (p1225 pvars1226) - (if (not (distinct-bound-ids?141 (map car pvars1226))) + (#{convert-pattern\ 2379}# + #{pat\ 2404}# + #{keys\ 2401}#)) + (lambda (#{p\ 2408}# #{pvars\ 2409}#) + (if (not (#{distinct-bound-ids?\ 1323}# + (map car #{pvars\ 2409}#))) (syntax-violation 'syntax-case "duplicate pattern variable" - pat1221) + #{pat\ 2404}#) (if (not (and-map - (lambda (x1227) - (not (ellipsis?160 (car x1227)))) - pvars1226)) + (lambda (#{x\ 2410}#) + (not (#{ellipsis?\ 1342}# + (car #{x\ 2410}#)))) + #{pvars\ 2409}#)) (syntax-violation 'syntax-case "misplaced ellipsis" - pat1221) - (let ((y1228 (gen-var162 (quote tmp)))) - (build-application82 + #{pat\ 2404}#) + (let ((#{y\ 2411}# + (#{gen-var\ 1344}# (quote tmp)))) + (#{build-application\ 1264}# #f - (build-lambda91 + (#{build-lambda\ 1273}# #f (list (quote tmp)) - (list y1228) + (list #{y\ 2411}#) #f - (let ((y1229 (build-lexical-reference84 - 'value - #f - 'tmp - y1228))) - (build-conditional83 + (let ((#{y\ 2412}# + (#{build-lexical-reference\ 1266}# + 'value + #f + 'tmp + #{y\ 2411}#))) + (#{build-conditional\ 1265}# #f - ((lambda (tmp1230) - ((lambda (tmp1231) - (if tmp1231 - (apply (lambda () y1229) - tmp1231) - ((lambda (_1232) - (build-conditional83 + ((lambda (#{tmp\ 2413}#) + ((lambda (#{tmp\ 2414}#) + (if #{tmp\ 2414}# + (apply (lambda () #{y\ 2412}#) + #{tmp\ 2414}#) + ((lambda (#{_\ 2415}#) + (#{build-conditional\ 1265}# #f - y1229 - (build-dispatch-call1197 - pvars1226 - fender1222 - y1229 - r1220 - mod1224) - (build-data93 #f #f))) - tmp1230))) + #{y\ 2412}# + (#{build-dispatch-call\ 2380}# + #{pvars\ 2409}# + #{fender\ 2405}# + #{y\ 2412}# + #{r\ 2403}# + #{mod\ 2407}#) + (#{build-data\ 1275}# + #f + #f))) + #{tmp\ 2413}#))) ($sc-dispatch - tmp1230 + #{tmp\ 2413}# '#(atom #t)))) - fender1222) - (build-dispatch-call1197 - pvars1226 - exp1223 - y1229 - r1220 - mod1224) - (gen-syntax-case1199 - x1217 - keys1218 - clauses1219 - r1220 - mod1224)))) - (list (if (eq? p1225 (quote any)) - (build-application82 + #{fender\ 2405}#) + (#{build-dispatch-call\ 2380}# + #{pvars\ 2409}# + #{exp\ 2406}# + #{y\ 2412}# + #{r\ 2403}# + #{mod\ 2407}#) + (#{gen-syntax-case\ 2382}# + #{x\ 2400}# + #{keys\ 2401}# + #{clauses\ 2402}# + #{r\ 2403}# + #{mod\ 2407}#)))) + (list (if (eq? #{p\ 2408}# (quote any)) + (#{build-application\ 1264}# #f - (build-primref92 #f (quote list)) - (list x1217)) - (build-application82 + (#{build-primref\ 1274}# + #f + 'list) + (list #{x\ 2400}#)) + (#{build-application\ 1264}# #f - (build-primref92 + (#{build-primref\ 1274}# #f '$sc-dispatch) - (list x1217 - (build-data93 + (list #{x\ 2400}# + (#{build-data\ 1275}# #f - p1225))))))))))))) - (build-dispatch-call1197 - (lambda (pvars1233 exp1234 y1235 r1236 mod1237) - (let ((ids1238 (map car pvars1233)) - (levels1239 (map cdr pvars1233))) - (let ((labels1240 (gen-labels121 ids1238)) - (new-vars1241 (map gen-var162 ids1238))) - (build-application82 + #{p\ 2408}#))))))))))))) + (#{build-dispatch-call\ 2380}# + (lambda (#{pvars\ 2416}# + #{exp\ 2417}# + #{y\ 2418}# + #{r\ 2419}# + #{mod\ 2420}#) + (let ((#{ids\ 2421}# (map car #{pvars\ 2416}#)) + (#{levels\ 2422}# (map cdr #{pvars\ 2416}#))) + (let ((#{labels\ 2423}# + (#{gen-labels\ 1303}# #{ids\ 2421}#)) + (#{new-vars\ 2424}# + (map #{gen-var\ 1344}# #{ids\ 2421}#))) + (#{build-application\ 1264}# #f - (build-primref92 #f (quote apply)) - (list (build-lambda91 + (#{build-primref\ 1274}# #f (quote apply)) + (list (#{build-lambda\ 1273}# #f - (map syntax->datum ids1238) - new-vars1241 + (map syntax->datum #{ids\ 2421}#) + #{new-vars\ 2424}# #f - (chi151 - exp1234 - (extend-env109 - labels1240 - (map (lambda (var1242 level1243) + (#{chi\ 1333}# + #{exp\ 2417}# + (#{extend-env\ 1291}# + #{labels\ 2423}# + (map (lambda (#{var\ 2425}# + #{level\ 2426}#) (cons 'syntax - (cons var1242 level1243))) - new-vars1241 - (map cdr pvars1233)) - r1236) - (make-binding-wrap132 - ids1238 - labels1240 + (cons #{var\ 2425}# + #{level\ 2426}#))) + #{new-vars\ 2424}# + (map cdr #{pvars\ 2416}#)) + #{r\ 2419}#) + (#{make-binding-wrap\ 1314}# + #{ids\ 2421}# + #{labels\ 2423}# '(())) - mod1237)) - y1235)))))) - (convert-pattern1196 - (lambda (pattern1244 keys1245) - (letrec ((cvt1246 - (lambda (p1247 n1248 ids1249) - (if (id?115 p1247) - (if (bound-id-member?142 p1247 keys1245) + #{mod\ 2420}#)) + #{y\ 2418}#)))))) + (#{convert-pattern\ 2379}# + (lambda (#{pattern\ 2427}# #{keys\ 2428}#) + (letrec ((#{cvt\ 2429}# + (lambda (#{p\ 2430}# #{n\ 2431}# #{ids\ 2432}#) + (if (#{id?\ 1297}# #{p\ 2430}#) + (if (#{bound-id-member?\ 1324}# + #{p\ 2430}# + #{keys\ 2428}#) (values - (vector (quote free-id) p1247) - ids1249) + (vector (quote free-id) #{p\ 2430}#) + #{ids\ 2432}#) (values 'any - (cons (cons p1247 n1248) ids1249))) - ((lambda (tmp1250) - ((lambda (tmp1251) - (if (if tmp1251 - (apply (lambda (x1252 dots1253) - (ellipsis?160 - dots1253)) - tmp1251) + (cons (cons #{p\ 2430}# #{n\ 2431}#) + #{ids\ 2432}#))) + ((lambda (#{tmp\ 2433}#) + ((lambda (#{tmp\ 2434}#) + (if (if #{tmp\ 2434}# + (apply (lambda (#{x\ 2435}# + #{dots\ 2436}#) + (#{ellipsis?\ 1342}# + #{dots\ 2436}#)) + #{tmp\ 2434}#) #f) - (apply (lambda (x1254 dots1255) + (apply (lambda (#{x\ 2437}# + #{dots\ 2438}#) (call-with-values (lambda () - (cvt1246 - x1254 - (fx+72 n1248 1) - ids1249)) - (lambda (p1256 ids1257) + (#{cvt\ 2429}# + #{x\ 2437}# + (#{fx+\ 1254}# + #{n\ 2431}# + 1) + #{ids\ 2432}#)) + (lambda (#{p\ 2439}# + #{ids\ 2440}#) (values - (if (eq? p1256 + (if (eq? #{p\ 2439}# 'any) 'each-any (vector 'each - p1256)) - ids1257)))) - tmp1251) - ((lambda (tmp1258) - (if tmp1258 - (apply (lambda (x1259 y1260) + #{p\ 2439}#)) + #{ids\ 2440}#)))) + #{tmp\ 2434}#) + ((lambda (#{tmp\ 2441}#) + (if #{tmp\ 2441}# + (apply (lambda (#{x\ 2442}# + #{y\ 2443}#) (call-with-values (lambda () - (cvt1246 - y1260 - n1248 - ids1249)) - (lambda (y1261 - ids1262) + (#{cvt\ 2429}# + #{y\ 2443}# + #{n\ 2431}# + #{ids\ 2432}#)) + (lambda (#{y\ 2444}# + #{ids\ 2445}#) (call-with-values (lambda () - (cvt1246 - x1259 - n1248 - ids1262)) - (lambda (x1263 - ids1264) + (#{cvt\ 2429}# + #{x\ 2442}# + #{n\ 2431}# + #{ids\ 2445}#)) + (lambda (#{x\ 2446}# + #{ids\ 2447}#) (values - (cons x1263 - y1261) - ids1264)))))) - tmp1258) - ((lambda (tmp1265) - (if tmp1265 + (cons #{x\ 2446}# + #{y\ 2444}#) + #{ids\ 2447}#)))))) + #{tmp\ 2441}#) + ((lambda (#{tmp\ 2448}#) + (if #{tmp\ 2448}# (apply (lambda () (values '() - ids1249)) - tmp1265) - ((lambda (tmp1266) - (if tmp1266 - (apply (lambda (x1267) + #{ids\ 2432}#)) + #{tmp\ 2448}#) + ((lambda (#{tmp\ 2449}#) + (if #{tmp\ 2449}# + (apply (lambda (#{x\ 2450}#) (call-with-values (lambda () - (cvt1246 - x1267 - n1248 - ids1249)) - (lambda (p1269 - ids1270) + (#{cvt\ 2429}# + #{x\ 2450}# + #{n\ 2431}# + #{ids\ 2432}#)) + (lambda (#{p\ 2452}# + #{ids\ 2453}#) (values (vector 'vector - p1269) - ids1270)))) - tmp1266) - ((lambda (x1271) + #{p\ 2452}#) + #{ids\ 2453}#)))) + #{tmp\ 2449}#) + ((lambda (#{x\ 2454}#) (values (vector 'atom - (strip161 - p1247 + (#{strip\ 1343}# + #{p\ 2430}# '(()))) - ids1249)) - tmp1250))) + #{ids\ 2432}#)) + #{tmp\ 2433}#))) ($sc-dispatch - tmp1250 + #{tmp\ 2433}# '#(vector each-any))))) ($sc-dispatch - tmp1250 + #{tmp\ 2433}# '())))) ($sc-dispatch - tmp1250 + #{tmp\ 2433}# '(any . any))))) ($sc-dispatch - tmp1250 + #{tmp\ 2433}# '(any any)))) - p1247))))) - (cvt1246 pattern1244 0 (quote ())))))) - (lambda (e1272 r1273 w1274 s1275 mod1276) - (let ((e1277 (source-wrap144 e1272 w1274 s1275 mod1276))) - ((lambda (tmp1278) - ((lambda (tmp1279) - (if tmp1279 - (apply (lambda (_1280 val1281 key1282 m1283) + #{p\ 2430}#))))) + (#{cvt\ 2429}# #{pattern\ 2427}# 0 (quote ())))))) + (lambda (#{e\ 2455}# + #{r\ 2456}# + #{w\ 2457}# + #{s\ 2458}# + #{mod\ 2459}#) + (let ((#{e\ 2460}# + (#{source-wrap\ 1326}# + #{e\ 2455}# + #{w\ 2457}# + #{s\ 2458}# + #{mod\ 2459}#))) + ((lambda (#{tmp\ 2461}#) + ((lambda (#{tmp\ 2462}#) + (if #{tmp\ 2462}# + (apply (lambda (#{_\ 2463}# + #{val\ 2464}# + #{key\ 2465}# + #{m\ 2466}#) (if (and-map - (lambda (x1284) - (if (id?115 x1284) - (not (ellipsis?160 x1284)) + (lambda (#{x\ 2467}#) + (if (#{id?\ 1297}# #{x\ 2467}#) + (not (#{ellipsis?\ 1342}# + #{x\ 2467}#)) #f)) - key1282) - (let ((x1286 (gen-var162 (quote tmp)))) - (build-application82 - s1275 - (build-lambda91 + #{key\ 2465}#) + (let ((#{x\ 2469}# + (#{gen-var\ 1344}# (quote tmp)))) + (#{build-application\ 1264}# + #{s\ 2458}# + (#{build-lambda\ 1273}# #f (list (quote tmp)) - (list x1286) + (list #{x\ 2469}#) #f - (gen-syntax-case1199 - (build-lexical-reference84 + (#{gen-syntax-case\ 2382}# + (#{build-lexical-reference\ 1266}# 'value #f 'tmp - x1286) - key1282 - m1283 - r1273 - mod1276)) - (list (chi151 - val1281 - r1273 + #{x\ 2469}#) + #{key\ 2465}# + #{m\ 2466}# + #{r\ 2456}# + #{mod\ 2459}#)) + (list (#{chi\ 1333}# + #{val\ 2464}# + #{r\ 2456}# '(()) - mod1276)))) + #{mod\ 2459}#)))) (syntax-violation 'syntax-case "invalid literals list" - e1277))) - tmp1279) + #{e\ 2460}#))) + #{tmp\ 2462}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1278))) + #{tmp\ 2461}#))) ($sc-dispatch - tmp1278 + #{tmp\ 2461}# '(any any each-any . each-any)))) - e1277))))) + #{e\ 2460}#))))) (set! sc-expand - (lambda (x1290 . rest1289) - (if (if (pair? x1290) - (equal? (car x1290) noexpand70) + (lambda (#{x\ 2473}# . #{rest\ 2472}#) + (if (if (pair? #{x\ 2473}#) + (equal? (car #{x\ 2473}#) #{noexpand\ 1252}#) #f) - (cadr x1290) - (let ((m1291 (if (null? rest1289) (quote e) (car rest1289))) - (esew1292 - (if (let ((t1293 (null? rest1289))) - (if t1293 t1293 (null? (cdr rest1289)))) + (cadr #{x\ 2473}#) + (let ((#{m\ 2474}# + (if (null? #{rest\ 2472}#) + 'e + (car #{rest\ 2472}#))) + (#{esew\ 2475}# + (if (let ((#{t\ 2476}# (null? #{rest\ 2472}#))) + (if #{t\ 2476}# + #{t\ 2476}# + (null? (cdr #{rest\ 2472}#)))) '(eval) - (cadr rest1289)))) + (cadr #{rest\ 2472}#)))) (with-fluid* - *mode*71 - m1291 + #{*mode*\ 1253}# + #{m\ 2474}# (lambda () - (chi-top150 - x1290 + (#{chi-top\ 1332}# + #{x\ 2473}# '() '((top)) - m1291 - esew1292 + #{m\ 2474}# + #{esew\ 2475}# (cons 'hygiene (module-name (current-module)))))))))) (set! identifier? - (lambda (x1294) (nonsymbol-id?114 x1294))) + (lambda (#{x\ 2477}#) + (#{nonsymbol-id?\ 1296}# #{x\ 2477}#))) (set! datum->syntax - (lambda (id1295 datum1296) - (make-syntax-object98 - datum1296 - (syntax-object-wrap101 id1295) + (lambda (#{id\ 2478}# #{datum\ 2479}#) + (#{make-syntax-object\ 1280}# + #{datum\ 2479}# + (#{syntax-object-wrap\ 1283}# #{id\ 2478}#) #f))) (set! syntax->datum - (lambda (x1297) (strip161 x1297 (quote (()))))) + (lambda (#{x\ 2480}#) + (#{strip\ 1343}# #{x\ 2480}# (quote (()))))) (set! generate-temporaries - (lambda (ls1298) + (lambda (#{ls\ 2481}#) (begin - (let ((x1299 ls1298)) - (if (not (list? x1299)) + (let ((#{x\ 2482}# #{ls\ 2481}#)) + (if (not (list? #{x\ 2482}#)) (syntax-violation 'generate-temporaries "invalid argument" - x1299))) - (map (lambda (x1300) - (wrap143 (gensym) (quote ((top))) #f)) - ls1298)))) + #{x\ 2482}#))) + (map (lambda (#{x\ 2483}#) + (#{wrap\ 1325}# (gensym) (quote ((top))) #f)) + #{ls\ 2481}#)))) (set! free-identifier=? - (lambda (x1301 y1302) + (lambda (#{x\ 2484}# #{y\ 2485}#) (begin - (let ((x1303 x1301)) - (if (not (nonsymbol-id?114 x1303)) + (let ((#{x\ 2486}# #{x\ 2484}#)) + (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2486}#)) (syntax-violation 'free-identifier=? "invalid argument" - x1303))) - (let ((x1304 y1302)) - (if (not (nonsymbol-id?114 x1304)) + #{x\ 2486}#))) + (let ((#{x\ 2487}# #{y\ 2485}#)) + (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2487}#)) (syntax-violation 'free-identifier=? "invalid argument" - x1304))) - (free-id=?138 x1301 y1302)))) + #{x\ 2487}#))) + (#{free-id=?\ 1320}# #{x\ 2484}# #{y\ 2485}#)))) (set! bound-identifier=? - (lambda (x1305 y1306) + (lambda (#{x\ 2488}# #{y\ 2489}#) (begin - (let ((x1307 x1305)) - (if (not (nonsymbol-id?114 x1307)) + (let ((#{x\ 2490}# #{x\ 2488}#)) + (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2490}#)) (syntax-violation 'bound-identifier=? "invalid argument" - x1307))) - (let ((x1308 y1306)) - (if (not (nonsymbol-id?114 x1308)) + #{x\ 2490}#))) + (let ((#{x\ 2491}# #{y\ 2489}#)) + (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2491}#)) (syntax-violation 'bound-identifier=? "invalid argument" - x1308))) - (bound-id=?139 x1305 y1306)))) + #{x\ 2491}#))) + (#{bound-id=?\ 1321}# #{x\ 2488}# #{y\ 2489}#)))) (set! syntax-violation - (lambda (who1312 message1311 form1310 . subform1309) + (lambda (#{who\ 2495}# + #{message\ 2494}# + #{form\ 2493}# + . + #{subform\ 2492}#) (begin - (let ((x1313 who1312)) - (if (not ((lambda (x1314) - (let ((t1315 (not x1314))) - (if t1315 - t1315 - (let ((t1316 (string? x1314))) - (if t1316 t1316 (symbol? x1314)))))) - x1313)) + (let ((#{x\ 2496}# #{who\ 2495}#)) + (if (not ((lambda (#{x\ 2497}#) + (let ((#{t\ 2498}# (not #{x\ 2497}#))) + (if #{t\ 2498}# + #{t\ 2498}# + (let ((#{t\ 2499}# (string? #{x\ 2497}#))) + (if #{t\ 2499}# + #{t\ 2499}# + (symbol? #{x\ 2497}#)))))) + #{x\ 2496}#)) (syntax-violation 'syntax-violation "invalid argument" - x1313))) - (let ((x1317 message1311)) - (if (not (string? x1317)) + #{x\ 2496}#))) + (let ((#{x\ 2500}# #{message\ 2494}#)) + (if (not (string? #{x\ 2500}#)) (syntax-violation 'syntax-violation "invalid argument" - x1317))) + #{x\ 2500}#))) (scm-error 'syntax-error 'sc-expand (string-append - (if who1312 "~a: " "") + (if #{who\ 2495}# "~a: " "") "~a " - (if (null? subform1309) + (if (null? #{subform\ 2492}#) "in ~a" "in subform `~s' of `~s'")) - (let ((tail1318 - (cons message1311 - (map (lambda (x1319) (strip161 x1319 (quote (())))) - (append subform1309 (list form1310)))))) - (if who1312 (cons who1312 tail1318) tail1318)) + (let ((#{tail\ 2501}# + (cons #{message\ 2494}# + (map (lambda (#{x\ 2502}#) + (#{strip\ 1343}# #{x\ 2502}# (quote (())))) + (append + #{subform\ 2492}# + (list #{form\ 2493}#)))))) + (if #{who\ 2495}# + (cons #{who\ 2495}# #{tail\ 2501}#) + #{tail\ 2501}#)) #f)))) - (letrec ((match1324 - (lambda (e1325 p1326 w1327 r1328 mod1329) - (if (not r1328) + (letrec ((#{match\ 2507}# + (lambda (#{e\ 2508}# + #{p\ 2509}# + #{w\ 2510}# + #{r\ 2511}# + #{mod\ 2512}#) + (if (not #{r\ 2511}#) #f - (if (eq? p1326 (quote any)) - (cons (wrap143 e1325 w1327 mod1329) r1328) - (if (syntax-object?99 e1325) - (match*1323 - (syntax-object-expression100 e1325) - p1326 - (join-wraps134 - w1327 - (syntax-object-wrap101 e1325)) - r1328 - (syntax-object-module102 e1325)) - (match*1323 e1325 p1326 w1327 r1328 mod1329)))))) - (match*1323 - (lambda (e1330 p1331 w1332 r1333 mod1334) - (if (null? p1331) - (if (null? e1330) r1333 #f) - (if (pair? p1331) - (if (pair? e1330) - (match1324 - (car e1330) - (car p1331) - w1332 - (match1324 - (cdr e1330) - (cdr p1331) - w1332 - r1333 - mod1334) - mod1334) + (if (eq? #{p\ 2509}# (quote any)) + (cons (#{wrap\ 1325}# + #{e\ 2508}# + #{w\ 2510}# + #{mod\ 2512}#) + #{r\ 2511}#) + (if (#{syntax-object?\ 1281}# #{e\ 2508}#) + (#{match*\ 2506}# + (#{syntax-object-expression\ 1282}# #{e\ 2508}#) + #{p\ 2509}# + (#{join-wraps\ 1316}# + #{w\ 2510}# + (#{syntax-object-wrap\ 1283}# #{e\ 2508}#)) + #{r\ 2511}# + (#{syntax-object-module\ 1284}# #{e\ 2508}#)) + (#{match*\ 2506}# + #{e\ 2508}# + #{p\ 2509}# + #{w\ 2510}# + #{r\ 2511}# + #{mod\ 2512}#)))))) + (#{match*\ 2506}# + (lambda (#{e\ 2513}# + #{p\ 2514}# + #{w\ 2515}# + #{r\ 2516}# + #{mod\ 2517}#) + (if (null? #{p\ 2514}#) + (if (null? #{e\ 2513}#) #{r\ 2516}# #f) + (if (pair? #{p\ 2514}#) + (if (pair? #{e\ 2513}#) + (#{match\ 2507}# + (car #{e\ 2513}#) + (car #{p\ 2514}#) + #{w\ 2515}# + (#{match\ 2507}# + (cdr #{e\ 2513}#) + (cdr #{p\ 2514}#) + #{w\ 2515}# + #{r\ 2516}# + #{mod\ 2517}#) + #{mod\ 2517}#) #f) - (if (eq? p1331 (quote each-any)) - (let ((l1335 (match-each-any1321 - e1330 - w1332 - mod1334))) - (if l1335 (cons l1335 r1333) #f)) - (let ((atom-key1336 (vector-ref p1331 0))) - (if (memv atom-key1336 (quote (each))) - (if (null? e1330) - (match-empty1322 (vector-ref p1331 1) r1333) - (let ((l1337 (match-each1320 - e1330 - (vector-ref p1331 1) - w1332 - mod1334))) - (if l1337 - (letrec ((collect1338 - (lambda (l1339) - (if (null? (car l1339)) - r1333 - (cons (map car l1339) - (collect1338 - (map cdr l1339))))))) - (collect1338 l1337)) + (if (eq? #{p\ 2514}# (quote each-any)) + (let ((#{l\ 2518}# + (#{match-each-any\ 2504}# + #{e\ 2513}# + #{w\ 2515}# + #{mod\ 2517}#))) + (if #{l\ 2518}# + (cons #{l\ 2518}# #{r\ 2516}#) + #f)) + (let ((#{atom-key\ 2519}# (vector-ref #{p\ 2514}# 0))) + (if (memv #{atom-key\ 2519}# (quote (each))) + (if (null? #{e\ 2513}#) + (#{match-empty\ 2505}# + (vector-ref #{p\ 2514}# 1) + #{r\ 2516}#) + (let ((#{l\ 2520}# + (#{match-each\ 2503}# + #{e\ 2513}# + (vector-ref #{p\ 2514}# 1) + #{w\ 2515}# + #{mod\ 2517}#))) + (if #{l\ 2520}# + (letrec ((#{collect\ 2521}# + (lambda (#{l\ 2522}#) + (if (null? (car #{l\ 2522}#)) + #{r\ 2516}# + (cons (map car #{l\ 2522}#) + (#{collect\ 2521}# + (map cdr + #{l\ 2522}#))))))) + (#{collect\ 2521}# #{l\ 2520}#)) #f))) - (if (memv atom-key1336 (quote (free-id))) - (if (id?115 e1330) - (if (free-id=?138 - (wrap143 e1330 w1332 mod1334) - (vector-ref p1331 1)) - r1333 + (if (memv #{atom-key\ 2519}# (quote (free-id))) + (if (#{id?\ 1297}# #{e\ 2513}#) + (if (#{free-id=?\ 1320}# + (#{wrap\ 1325}# + #{e\ 2513}# + #{w\ 2515}# + #{mod\ 2517}#) + (vector-ref #{p\ 2514}# 1)) + #{r\ 2516}# #f) #f) - (if (memv atom-key1336 (quote (atom))) + (if (memv #{atom-key\ 2519}# (quote (atom))) (if (equal? - (vector-ref p1331 1) - (strip161 e1330 w1332)) - r1333 + (vector-ref #{p\ 2514}# 1) + (#{strip\ 1343}# + #{e\ 2513}# + #{w\ 2515}#)) + #{r\ 2516}# #f) - (if (memv atom-key1336 (quote (vector))) - (if (vector? e1330) - (match1324 - (vector->list e1330) - (vector-ref p1331 1) - w1332 - r1333 - mod1334) + (if (memv #{atom-key\ 2519}# (quote (vector))) + (if (vector? #{e\ 2513}#) + (#{match\ 2507}# + (vector->list #{e\ 2513}#) + (vector-ref #{p\ 2514}# 1) + #{w\ 2515}# + #{r\ 2516}# + #{mod\ 2517}#) #f))))))))))) - (match-empty1322 - (lambda (p1340 r1341) - (if (null? p1340) - r1341 - (if (eq? p1340 (quote any)) - (cons (quote ()) r1341) - (if (pair? p1340) - (match-empty1322 - (car p1340) - (match-empty1322 (cdr p1340) r1341)) - (if (eq? p1340 (quote each-any)) - (cons (quote ()) r1341) - (let ((atom-key1342 (vector-ref p1340 0))) - (if (memv atom-key1342 (quote (each))) - (match-empty1322 (vector-ref p1340 1) r1341) - (if (memv atom-key1342 (quote (free-id atom))) - r1341 - (if (memv atom-key1342 (quote (vector))) - (match-empty1322 - (vector-ref p1340 1) - r1341))))))))))) - (match-each-any1321 - (lambda (e1343 w1344 mod1345) - (if (pair? e1343) - (let ((l1346 (match-each-any1321 - (cdr e1343) - w1344 - mod1345))) - (if l1346 - (cons (wrap143 (car e1343) w1344 mod1345) l1346) + (#{match-empty\ 2505}# + (lambda (#{p\ 2523}# #{r\ 2524}#) + (if (null? #{p\ 2523}#) + #{r\ 2524}# + (if (eq? #{p\ 2523}# (quote any)) + (cons (quote ()) #{r\ 2524}#) + (if (pair? #{p\ 2523}#) + (#{match-empty\ 2505}# + (car #{p\ 2523}#) + (#{match-empty\ 2505}# + (cdr #{p\ 2523}#) + #{r\ 2524}#)) + (if (eq? #{p\ 2523}# (quote each-any)) + (cons (quote ()) #{r\ 2524}#) + (let ((#{atom-key\ 2525}# + (vector-ref #{p\ 2523}# 0))) + (if (memv #{atom-key\ 2525}# (quote (each))) + (#{match-empty\ 2505}# + (vector-ref #{p\ 2523}# 1) + #{r\ 2524}#) + (if (memv #{atom-key\ 2525}# + '(free-id atom)) + #{r\ 2524}# + (if (memv #{atom-key\ 2525}# (quote (vector))) + (#{match-empty\ 2505}# + (vector-ref #{p\ 2523}# 1) + #{r\ 2524}#))))))))))) + (#{match-each-any\ 2504}# + (lambda (#{e\ 2526}# #{w\ 2527}# #{mod\ 2528}#) + (if (pair? #{e\ 2526}#) + (let ((#{l\ 2529}# + (#{match-each-any\ 2504}# + (cdr #{e\ 2526}#) + #{w\ 2527}# + #{mod\ 2528}#))) + (if #{l\ 2529}# + (cons (#{wrap\ 1325}# + (car #{e\ 2526}#) + #{w\ 2527}# + #{mod\ 2528}#) + #{l\ 2529}#) #f)) - (if (null? e1343) + (if (null? #{e\ 2526}#) '() - (if (syntax-object?99 e1343) - (match-each-any1321 - (syntax-object-expression100 e1343) - (join-wraps134 - w1344 - (syntax-object-wrap101 e1343)) - mod1345) + (if (#{syntax-object?\ 1281}# #{e\ 2526}#) + (#{match-each-any\ 2504}# + (#{syntax-object-expression\ 1282}# #{e\ 2526}#) + (#{join-wraps\ 1316}# + #{w\ 2527}# + (#{syntax-object-wrap\ 1283}# #{e\ 2526}#)) + #{mod\ 2528}#) #f))))) - (match-each1320 - (lambda (e1347 p1348 w1349 mod1350) - (if (pair? e1347) - (let ((first1351 - (match1324 - (car e1347) - p1348 - w1349 + (#{match-each\ 2503}# + (lambda (#{e\ 2530}# + #{p\ 2531}# + #{w\ 2532}# + #{mod\ 2533}#) + (if (pair? #{e\ 2530}#) + (let ((#{first\ 2534}# + (#{match\ 2507}# + (car #{e\ 2530}#) + #{p\ 2531}# + #{w\ 2532}# '() - mod1350))) - (if first1351 - (let ((rest1352 - (match-each1320 - (cdr e1347) - p1348 - w1349 - mod1350))) - (if rest1352 (cons first1351 rest1352) #f)) + #{mod\ 2533}#))) + (if #{first\ 2534}# + (let ((#{rest\ 2535}# + (#{match-each\ 2503}# + (cdr #{e\ 2530}#) + #{p\ 2531}# + #{w\ 2532}# + #{mod\ 2533}#))) + (if #{rest\ 2535}# + (cons #{first\ 2534}# #{rest\ 2535}#) + #f)) #f)) - (if (null? e1347) + (if (null? #{e\ 2530}#) '() - (if (syntax-object?99 e1347) - (match-each1320 - (syntax-object-expression100 e1347) - p1348 - (join-wraps134 - w1349 - (syntax-object-wrap101 e1347)) - (syntax-object-module102 e1347)) + (if (#{syntax-object?\ 1281}# #{e\ 2530}#) + (#{match-each\ 2503}# + (#{syntax-object-expression\ 1282}# #{e\ 2530}#) + #{p\ 2531}# + (#{join-wraps\ 1316}# + #{w\ 2532}# + (#{syntax-object-wrap\ 1283}# #{e\ 2530}#)) + (#{syntax-object-module\ 1284}# #{e\ 2530}#)) #f)))))) (set! $sc-dispatch - (lambda (e1353 p1354) - (if (eq? p1354 (quote any)) - (list e1353) - (if (syntax-object?99 e1353) - (match*1323 - (syntax-object-expression100 e1353) - p1354 - (syntax-object-wrap101 e1353) + (lambda (#{e\ 2536}# #{p\ 2537}#) + (if (eq? #{p\ 2537}# (quote any)) + (list #{e\ 2536}#) + (if (#{syntax-object?\ 1281}# #{e\ 2536}#) + (#{match*\ 2506}# + (#{syntax-object-expression\ 1282}# #{e\ 2536}#) + #{p\ 2537}# + (#{syntax-object-wrap\ 1283}# #{e\ 2536}#) '() - (syntax-object-module102 e1353)) - (match*1323 - e1353 - p1354 + (#{syntax-object-module\ 1284}# #{e\ 2536}#)) + (#{match*\ 2506}# + #{e\ 2536}# + #{p\ 2537}# '(()) '() #f))))))))) @@ -8337,11 +9157,11 @@ (define with-syntax (make-syncase-macro 'macro - (lambda (x1355) - ((lambda (tmp1356) - ((lambda (tmp1357) - (if tmp1357 - (apply (lambda (_1358 e11359 e21360) + (lambda (#{x\ 2538}#) + ((lambda (#{tmp\ 2539}#) + ((lambda (#{tmp\ 2540}#) + (if #{tmp\ 2540}# + (apply (lambda (#{_\ 2541}# #{e1\ 2542}# #{e2\ 2543}#) (cons '#(syntax-object begin ((top) @@ -8352,11 +9172,15 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - (cons e11359 e21360))) - tmp1357) - ((lambda (tmp1362) - (if tmp1362 - (apply (lambda (_1363 out1364 in1365 e11366 e21367) + (cons #{e1\ 2542}# #{e2\ 2543}#))) + #{tmp\ 2540}#) + ((lambda (#{tmp\ 2545}#) + (if #{tmp\ 2545}# + (apply (lambda (#{_\ 2546}# + #{out\ 2547}# + #{in\ 2548}# + #{e1\ 2549}# + #{e2\ 2550}#) (list '#(syntax-object syntax-case ((top) @@ -8367,9 +9191,9 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - in1365 + #{in\ 2548}# '() - (list out1364 + (list #{out\ 2547}# (cons '#(syntax-object begin ((top) @@ -8387,11 +9211,16 @@ #((top)) #("i"))) (hygiene guile)) - (cons e11366 e21367))))) - tmp1362) - ((lambda (tmp1369) - (if tmp1369 - (apply (lambda (_1370 out1371 in1372 e11373 e21374) + (cons #{e1\ 2549}# + #{e2\ 2550}#))))) + #{tmp\ 2545}#) + ((lambda (#{tmp\ 2552}#) + (if #{tmp\ 2552}# + (apply (lambda (#{_\ 2553}# + #{out\ 2554}# + #{in\ 2555}# + #{e1\ 2556}# + #{e2\ 2557}#) (list '#(syntax-object syntax-case ((top) @@ -8419,9 +9248,9 @@ #((top)) #("i"))) (hygiene guile)) - in1372) + #{in\ 2555}#) '() - (list out1371 + (list #{out\ 2554}# (cons '#(syntax-object begin ((top) @@ -8443,35 +9272,36 @@ #((top)) #("i"))) (hygiene guile)) - (cons e11373 e21374))))) - tmp1369) + (cons #{e1\ 2556}# + #{e2\ 2557}#))))) + #{tmp\ 2552}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1356))) + #{tmp\ 2539}#))) ($sc-dispatch - tmp1356 + #{tmp\ 2539}# '(any #(each (any any)) any . each-any))))) ($sc-dispatch - tmp1356 + #{tmp\ 2539}# '(any ((any any)) any . each-any))))) ($sc-dispatch - tmp1356 + #{tmp\ 2539}# '(any () any . each-any)))) - x1355)))) + #{x\ 2538}#)))) (define syntax-rules (make-syncase-macro 'macro - (lambda (x1378) - ((lambda (tmp1379) - ((lambda (tmp1380) - (if tmp1380 - (apply (lambda (_1381 - k1382 - keyword1383 - pattern1384 - template1385) + (lambda (#{x\ 2561}#) + ((lambda (#{tmp\ 2562}#) + ((lambda (#{tmp\ 2563}#) + (if #{tmp\ 2563}# + (apply (lambda (#{_\ 2564}# + #{k\ 2565}# + #{keyword\ 2566}# + #{pattern\ 2567}# + #{template\ 2568}#) (list '#(syntax-object lambda ((top) @@ -8512,8 +9342,9 @@ #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) - (cons k1382 - (map (lambda (tmp1388 tmp1387) + (cons #{k\ 2565}# + (map (lambda (#{tmp\ 2571}# + #{tmp\ 2570}#) (list (cons '#(syntax-object dummy ((top) @@ -8543,7 +9374,7 @@ #("i"))) (hygiene guile)) - tmp1387) + #{tmp\ 2570}#) (list '#(syntax-object syntax ((top) @@ -8573,155 +9404,164 @@ #("i"))) (hygiene guile)) - tmp1388))) - template1385 - pattern1384)))))) - tmp1380) + #{tmp\ 2571}#))) + #{template\ 2568}# + #{pattern\ 2567}#)))))) + #{tmp\ 2563}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1379))) + #{tmp\ 2562}#))) ($sc-dispatch - tmp1379 + #{tmp\ 2562}# '(any each-any . #(each ((any . any) any)))))) - x1378)))) + #{x\ 2561}#)))) (define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) 'macro - (lambda (x1389) - ((lambda (tmp1390) - ((lambda (tmp1391) - (if (if tmp1391 - (apply (lambda (let*1392 x1393 v1394 e11395 e21396) - (and-map identifier? x1393)) - tmp1391) + (lambda (#{x\ 2572}#) + ((lambda (#{tmp\ 2573}#) + ((lambda (#{tmp\ 2574}#) + (if (if #{tmp\ 2574}# + (apply (lambda (#{let*\ 2575}# + #{x\ 2576}# + #{v\ 2577}# + #{e1\ 2578}# + #{e2\ 2579}#) + (and-map identifier? #{x\ 2576}#)) + #{tmp\ 2574}#) #f) - (apply (lambda (let*1398 x1399 v1400 e11401 e21402) - (letrec ((f1403 (lambda (bindings1404) - (if (null? bindings1404) - (cons '#(syntax-object - let - ((top) - #(ribcage () () ()) - #(ribcage - #(f bindings) - #((top) (top)) - #("i" "i")) - #(ribcage - #(let* x v e1 e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" "i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene guile)) - (cons '() - (cons e11401 e21402))) - ((lambda (tmp1408) - ((lambda (tmp1409) - (if tmp1409 - (apply (lambda (body1410 - binding1411) - (list '#(syntax-object - let - ((top) - #(ribcage - #(body - binding) - #((top) - (top)) - #("i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - bindings) - #((top) - (top)) - #("i" - "i")) - #(ribcage - #(let* - x - v - e1 - e2) - #((top) - (top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - (list binding1411) - body1410)) - tmp1409) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp1408))) - ($sc-dispatch - tmp1408 - '(any any)))) - (list (f1403 (cdr bindings1404)) - (car bindings1404))))))) - (f1403 (map list x1399 v1400)))) - tmp1391) + (apply (lambda (#{let*\ 2581}# + #{x\ 2582}# + #{v\ 2583}# + #{e1\ 2584}# + #{e2\ 2585}#) + (letrec ((#{f\ 2586}# + (lambda (#{bindings\ 2587}#) + (if (null? #{bindings\ 2587}#) + (cons '#(syntax-object + let + ((top) + #(ribcage () () ()) + #(ribcage + #(f bindings) + #((top) (top)) + #("i" "i")) + #(ribcage + #(let* x v e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile)) + (cons '() + (cons #{e1\ 2584}# + #{e2\ 2585}#))) + ((lambda (#{tmp\ 2591}#) + ((lambda (#{tmp\ 2592}#) + (if #{tmp\ 2592}# + (apply (lambda (#{body\ 2593}# + #{binding\ 2594}#) + (list '#(syntax-object + let + ((top) + #(ribcage + #(body + binding) + #((top) + (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + bindings) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(let* + x + v + e1 + e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list #{binding\ 2594}#) + #{body\ 2593}#)) + #{tmp\ 2592}#) + (syntax-violation + #f + "source expression failed to match any pattern" + #{tmp\ 2591}#))) + ($sc-dispatch + #{tmp\ 2591}# + '(any any)))) + (list (#{f\ 2586}# + (cdr #{bindings\ 2587}#)) + (car #{bindings\ 2587}#))))))) + (#{f\ 2586}# (map list #{x\ 2582}# #{v\ 2583}#)))) + #{tmp\ 2574}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1390))) + #{tmp\ 2573}#))) ($sc-dispatch - tmp1390 + #{tmp\ 2573}# '(any #(each (any any)) any . each-any)))) - x1389)))) + #{x\ 2572}#)))) (define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) 'macro - (lambda (orig-x1412) - ((lambda (tmp1413) - ((lambda (tmp1414) - (if tmp1414 - (apply (lambda (_1415 - var1416 - init1417 - step1418 - e01419 - e11420 - c1421) - ((lambda (tmp1422) - ((lambda (tmp1423) - (if tmp1423 - (apply (lambda (step1424) - ((lambda (tmp1425) - ((lambda (tmp1426) - (if tmp1426 + (lambda (#{orig-x\ 2595}#) + ((lambda (#{tmp\ 2596}#) + ((lambda (#{tmp\ 2597}#) + (if #{tmp\ 2597}# + (apply (lambda (#{_\ 2598}# + #{var\ 2599}# + #{init\ 2600}# + #{step\ 2601}# + #{e0\ 2602}# + #{e1\ 2603}# + #{c\ 2604}#) + ((lambda (#{tmp\ 2605}#) + ((lambda (#{tmp\ 2606}#) + (if #{tmp\ 2606}# + (apply (lambda (#{step\ 2607}#) + ((lambda (#{tmp\ 2608}#) + ((lambda (#{tmp\ 2609}#) + (if #{tmp\ 2609}# (apply (lambda () (list '#(syntax-object let @@ -8802,8 +9642,8 @@ (hygiene guile)) (map list - var1416 - init1417) + #{var\ 2599}# + #{init\ 2600}#) (list '#(syntax-object if ((top) @@ -8882,7 +9722,7 @@ #("i"))) (hygiene guile)) - e01419) + #{e0\ 2602}#) (cons '#(syntax-object begin ((top) @@ -8923,7 +9763,7 @@ (hygiene guile)) (append - c1421 + #{c\ 2604}# (list (cons '#(syntax-object doloop ((top) @@ -8963,12 +9803,12 @@ #("i"))) (hygiene guile)) - step1424))))))) - tmp1426) - ((lambda (tmp1431) - (if tmp1431 - (apply (lambda (e11432 - e21433) + #{step\ 2607}#))))))) + #{tmp\ 2609}#) + ((lambda (#{tmp\ 2614}#) + (if #{tmp\ 2614}# + (apply (lambda (#{e1\ 2615}# + #{e2\ 2616}#) (list '#(syntax-object let ((top) @@ -9062,8 +9902,8 @@ (hygiene guile)) (map list - var1416 - init1417) + #{var\ 2599}# + #{init\ 2600}#) (list '#(syntax-object if ((top) @@ -9110,7 +9950,7 @@ #("i"))) (hygiene guile)) - e01419 + #{e0\ 2602}# (cons '#(syntax-object begin ((top) @@ -9157,8 +9997,8 @@ #("i"))) (hygiene guile)) - (cons e11432 - e21433)) + (cons #{e1\ 2615}# + #{e2\ 2616}#)) (cons '#(syntax-object begin ((top) @@ -9206,7 +10046,7 @@ (hygiene guile)) (append - c1421 + #{c\ 2604}# (list (cons '#(syntax-object doloop ((top) @@ -9253,75 +10093,81 @@ #("i"))) (hygiene guile)) - step1424))))))) - tmp1431) + #{step\ 2607}#))))))) + #{tmp\ 2614}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1425))) + #{tmp\ 2608}#))) ($sc-dispatch - tmp1425 + #{tmp\ 2608}# '(any . each-any))))) - ($sc-dispatch tmp1425 (quote ())))) - e11420)) - tmp1423) + ($sc-dispatch + #{tmp\ 2608}# + '()))) + #{e1\ 2603}#)) + #{tmp\ 2606}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1422))) - ($sc-dispatch tmp1422 (quote each-any)))) - (map (lambda (v1440 s1441) - ((lambda (tmp1442) - ((lambda (tmp1443) - (if tmp1443 - (apply (lambda () v1440) tmp1443) - ((lambda (tmp1444) - (if tmp1444 - (apply (lambda (e1445) e1445) - tmp1444) - ((lambda (_1446) + #{tmp\ 2605}#))) + ($sc-dispatch #{tmp\ 2605}# (quote each-any)))) + (map (lambda (#{v\ 2623}# #{s\ 2624}#) + ((lambda (#{tmp\ 2625}#) + ((lambda (#{tmp\ 2626}#) + (if #{tmp\ 2626}# + (apply (lambda () #{v\ 2623}#) + #{tmp\ 2626}#) + ((lambda (#{tmp\ 2627}#) + (if #{tmp\ 2627}# + (apply (lambda (#{e\ 2628}#) + #{e\ 2628}#) + #{tmp\ 2627}#) + ((lambda (#{_\ 2629}#) (syntax-violation 'do "bad step expression" - orig-x1412 - s1441)) - tmp1442))) - ($sc-dispatch tmp1442 (quote (any)))))) - ($sc-dispatch tmp1442 (quote ())))) - s1441)) - var1416 - step1418))) - tmp1414) + #{orig-x\ 2595}# + #{s\ 2624}#)) + #{tmp\ 2625}#))) + ($sc-dispatch + #{tmp\ 2625}# + '(any))))) + ($sc-dispatch #{tmp\ 2625}# (quote ())))) + #{s\ 2624}#)) + #{var\ 2599}# + #{step\ 2601}#))) + #{tmp\ 2597}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1413))) + #{tmp\ 2596}#))) ($sc-dispatch - tmp1413 + #{tmp\ 2596}# '(any #(each (any any . any)) (any . each-any) . each-any)))) - orig-x1412)))) + #{orig-x\ 2595}#)))) (define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) 'macro - (letrec ((quasicons1449 - (lambda (x1453 y1454) - ((lambda (tmp1455) - ((lambda (tmp1456) - (if tmp1456 - (apply (lambda (x1457 y1458) - ((lambda (tmp1459) - ((lambda (tmp1460) - (if tmp1460 - (apply (lambda (dy1461) - ((lambda (tmp1462) - ((lambda (tmp1463) - (if tmp1463 - (apply (lambda (dx1464) + (letrec ((#{quasicons\ 2632}# + (lambda (#{x\ 2636}# #{y\ 2637}#) + ((lambda (#{tmp\ 2638}#) + ((lambda (#{tmp\ 2639}#) + (if #{tmp\ 2639}# + (apply (lambda (#{x\ 2640}# #{y\ 2641}#) + ((lambda (#{tmp\ 2642}#) + ((lambda (#{tmp\ 2643}#) + (if #{tmp\ 2643}# + (apply (lambda (#{dy\ 2644}#) + ((lambda (#{tmp\ 2645}#) + ((lambda (#{tmp\ 2646}#) + (if #{tmp\ 2646}# + (apply (lambda (#{dx\ 2647}#) (list '#(syntax-object quote ((top) @@ -9370,11 +10216,11 @@ "i"))) (hygiene guile)) - (cons dx1464 - dy1461))) - tmp1463) - ((lambda (_1465) - (if (null? dy1461) + (cons #{dx\ 2647}# + #{dy\ 2644}#))) + #{tmp\ 2646}#) + ((lambda (#{_\ 2648}#) + (if (null? #{dy\ 2644}#) (list '#(syntax-object list ((top) @@ -9423,7 +10269,7 @@ "i"))) (hygiene guile)) - x1457) + #{x\ 2640}#) (list '#(syntax-object cons ((top) @@ -9472,11 +10318,11 @@ "i"))) (hygiene guile)) - x1457 - y1458))) - tmp1462))) + #{x\ 2640}# + #{y\ 2641}#))) + #{tmp\ 2645}#))) ($sc-dispatch - tmp1462 + #{tmp\ 2645}# '(#(free-id #(syntax-object quote @@ -9519,11 +10365,11 @@ (hygiene guile))) any)))) - x1457)) - tmp1460) - ((lambda (tmp1466) - (if tmp1466 - (apply (lambda (stuff1467) + #{x\ 2640}#)) + #{tmp\ 2643}#) + ((lambda (#{tmp\ 2649}#) + (if #{tmp\ 2649}# + (apply (lambda (#{stuff\ 2650}#) (cons '#(syntax-object list ((top) @@ -9564,10 +10410,10 @@ "i"))) (hygiene guile)) - (cons x1457 - stuff1467))) - tmp1466) - ((lambda (else1468) + (cons #{x\ 2640}# + #{stuff\ 2650}#))) + #{tmp\ 2649}#) + ((lambda (#{else\ 2651}#) (list '#(syntax-object cons ((top) @@ -9599,11 +10445,11 @@ "i" "i"))) (hygiene guile)) - x1457 - y1458)) - tmp1459))) + #{x\ 2640}# + #{y\ 2641}#)) + #{tmp\ 2642}#))) ($sc-dispatch - tmp1459 + #{tmp\ 2642}# '(#(free-id #(syntax-object list @@ -9632,7 +10478,7 @@ . any))))) ($sc-dispatch - tmp1459 + #{tmp\ 2642}# '(#(free-id #(syntax-object quote @@ -9656,25 +10502,26 @@ #("i" "i" "i" "i"))) (hygiene guile))) any)))) - y1458)) - tmp1456) + #{y\ 2641}#)) + #{tmp\ 2639}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1455))) - ($sc-dispatch tmp1455 (quote (any any))))) - (list x1453 y1454)))) - (quasiappend1450 - (lambda (x1469 y1470) - ((lambda (tmp1471) - ((lambda (tmp1472) - (if tmp1472 - (apply (lambda (x1473 y1474) - ((lambda (tmp1475) - ((lambda (tmp1476) - (if tmp1476 - (apply (lambda () x1473) tmp1476) - ((lambda (_1477) + #{tmp\ 2638}#))) + ($sc-dispatch #{tmp\ 2638}# (quote (any any))))) + (list #{x\ 2636}# #{y\ 2637}#)))) + (#{quasiappend\ 2633}# + (lambda (#{x\ 2652}# #{y\ 2653}#) + ((lambda (#{tmp\ 2654}#) + ((lambda (#{tmp\ 2655}#) + (if #{tmp\ 2655}# + (apply (lambda (#{x\ 2656}# #{y\ 2657}#) + ((lambda (#{tmp\ 2658}#) + ((lambda (#{tmp\ 2659}#) + (if #{tmp\ 2659}# + (apply (lambda () #{x\ 2656}#) + #{tmp\ 2659}#) + ((lambda (#{_\ 2660}#) (list '#(syntax-object append ((top) @@ -9703,11 +10550,11 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x1473 - y1474)) - tmp1475))) + #{x\ 2656}# + #{y\ 2657}#)) + #{tmp\ 2658}#))) ($sc-dispatch - tmp1475 + #{tmp\ 2658}# '(#(free-id #(syntax-object quote @@ -9731,22 +10578,22 @@ #("i" "i" "i" "i"))) (hygiene guile))) ())))) - y1474)) - tmp1472) + #{y\ 2657}#)) + #{tmp\ 2655}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1471))) - ($sc-dispatch tmp1471 (quote (any any))))) - (list x1469 y1470)))) - (quasivector1451 - (lambda (x1478) - ((lambda (tmp1479) - ((lambda (x1480) - ((lambda (tmp1481) - ((lambda (tmp1482) - (if tmp1482 - (apply (lambda (x1483) + #{tmp\ 2654}#))) + ($sc-dispatch #{tmp\ 2654}# (quote (any any))))) + (list #{x\ 2652}# #{y\ 2653}#)))) + (#{quasivector\ 2634}# + (lambda (#{x\ 2661}#) + ((lambda (#{tmp\ 2662}#) + ((lambda (#{x\ 2663}#) + ((lambda (#{tmp\ 2664}#) + ((lambda (#{tmp\ 2665}#) + (if #{tmp\ 2665}# + (apply (lambda (#{x\ 2666}#) (list '#(syntax-object quote ((top) @@ -9772,11 +10619,11 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - (list->vector x1483))) - tmp1482) - ((lambda (tmp1485) - (if tmp1485 - (apply (lambda (x1486) + (list->vector #{x\ 2666}#))) + #{tmp\ 2665}#) + ((lambda (#{tmp\ 2668}#) + (if #{tmp\ 2668}# + (apply (lambda (#{x\ 2669}#) (cons '#(syntax-object vector ((top) @@ -9805,9 +10652,9 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x1486)) - tmp1485) - ((lambda (_1488) + #{x\ 2669}#)) + #{tmp\ 2668}#) + ((lambda (#{_\ 2671}#) (list '#(syntax-object list->vector ((top) @@ -9833,10 +10680,10 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - x1480)) - tmp1481))) + #{x\ 2663}#)) + #{tmp\ 2664}#))) ($sc-dispatch - tmp1481 + #{tmp\ 2664}# '(#(free-id #(syntax-object list @@ -9856,7 +10703,7 @@ . each-any))))) ($sc-dispatch - tmp1481 + #{tmp\ 2664}# '(#(free-id #(syntax-object quote @@ -9874,18 +10721,18 @@ #("i" "i" "i" "i"))) (hygiene guile))) each-any)))) - x1480)) - tmp1479)) - x1478))) - (quasi1452 - (lambda (p1489 lev1490) - ((lambda (tmp1491) - ((lambda (tmp1492) - (if tmp1492 - (apply (lambda (p1493) - (if (= lev1490 0) - p1493 - (quasicons1449 + #{x\ 2663}#)) + #{tmp\ 2662}#)) + #{x\ 2661}#))) + (#{quasi\ 2635}# + (lambda (#{p\ 2672}# #{lev\ 2673}#) + ((lambda (#{tmp\ 2674}#) + ((lambda (#{tmp\ 2675}#) + (if #{tmp\ 2675}# + (apply (lambda (#{p\ 2676}#) + (if (= #{lev\ 2673}# 0) + #{p\ 2676}# + (#{quasicons\ 2632}# '(#(syntax-object quote ((top) @@ -9920,18 +10767,21 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) - (quasi1452 (list p1493) (- lev1490 1))))) - tmp1492) - ((lambda (tmp1494) - (if (if tmp1494 - (apply (lambda (args1495) (= lev1490 0)) - tmp1494) + (#{quasi\ 2635}# + (list #{p\ 2676}#) + (- #{lev\ 2673}# 1))))) + #{tmp\ 2675}#) + ((lambda (#{tmp\ 2677}#) + (if (if #{tmp\ 2677}# + (apply (lambda (#{args\ 2678}#) + (= #{lev\ 2673}# 0)) + #{tmp\ 2677}#) #f) - (apply (lambda (args1496) + (apply (lambda (#{args\ 2679}#) (syntax-violation 'unquote "unquote takes exactly one argument" - p1489 + #{p\ 2672}# (cons '#(syntax-object unquote ((top) @@ -9952,17 +10802,19 @@ #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) - args1496))) - tmp1494) - ((lambda (tmp1497) - (if tmp1497 - (apply (lambda (p1498 q1499) - (if (= lev1490 0) - (quasiappend1450 - p1498 - (quasi1452 q1499 lev1490)) - (quasicons1449 - (quasicons1449 + #{args\ 2679}#))) + #{tmp\ 2677}#) + ((lambda (#{tmp\ 2680}#) + (if #{tmp\ 2680}# + (apply (lambda (#{p\ 2681}# #{q\ 2682}#) + (if (= #{lev\ 2673}# 0) + (#{quasiappend\ 2633}# + #{p\ 2681}# + (#{quasi\ 2635}# + #{q\ 2682}# + #{lev\ 2673}#)) + (#{quasicons\ 2632}# + (#{quasicons\ 2632}# '(#(syntax-object quote ((top) @@ -10009,22 +10861,26 @@ (top)) #("i" "i" "i" "i"))) (hygiene guile))) - (quasi1452 - (list p1498) - (- lev1490 1))) - (quasi1452 q1499 lev1490)))) - tmp1497) - ((lambda (tmp1500) - (if (if tmp1500 - (apply (lambda (args1501 q1502) - (= lev1490 0)) - tmp1500) + (#{quasi\ 2635}# + (list #{p\ 2681}#) + (- #{lev\ 2673}# 1))) + (#{quasi\ 2635}# + #{q\ 2682}# + #{lev\ 2673}#)))) + #{tmp\ 2680}#) + ((lambda (#{tmp\ 2683}#) + (if (if #{tmp\ 2683}# + (apply (lambda (#{args\ 2684}# + #{q\ 2685}#) + (= #{lev\ 2673}# 0)) + #{tmp\ 2683}#) #f) - (apply (lambda (args1503 q1504) + (apply (lambda (#{args\ 2686}# + #{q\ 2687}#) (syntax-violation 'unquote-splicing "unquote-splicing takes exactly one argument" - p1489 + #{p\ 2672}# (cons '#(syntax-object unquote-splicing ((top) @@ -10054,12 +10910,12 @@ "i" "i"))) (hygiene guile)) - args1503))) - tmp1500) - ((lambda (tmp1505) - (if tmp1505 - (apply (lambda (p1506) - (quasicons1449 + #{args\ 2686}#))) + #{tmp\ 2683}#) + ((lambda (#{tmp\ 2688}#) + (if #{tmp\ 2688}# + (apply (lambda (#{p\ 2689}#) + (#{quasicons\ 2632}# '(#(syntax-object quote ((top) @@ -10118,30 +10974,32 @@ "i" "i"))) (hygiene guile))) - (quasi1452 - (list p1506) - (+ lev1490 1)))) - tmp1505) - ((lambda (tmp1507) - (if tmp1507 - (apply (lambda (p1508 q1509) - (quasicons1449 - (quasi1452 - p1508 - lev1490) - (quasi1452 - q1509 - lev1490))) - tmp1507) - ((lambda (tmp1510) - (if tmp1510 - (apply (lambda (x1511) - (quasivector1451 - (quasi1452 - x1511 - lev1490))) - tmp1510) - ((lambda (p1513) + (#{quasi\ 2635}# + (list #{p\ 2689}#) + (+ #{lev\ 2673}# + 1)))) + #{tmp\ 2688}#) + ((lambda (#{tmp\ 2690}#) + (if #{tmp\ 2690}# + (apply (lambda (#{p\ 2691}# + #{q\ 2692}#) + (#{quasicons\ 2632}# + (#{quasi\ 2635}# + #{p\ 2691}# + #{lev\ 2673}#) + (#{quasi\ 2635}# + #{q\ 2692}# + #{lev\ 2673}#))) + #{tmp\ 2690}#) + ((lambda (#{tmp\ 2693}#) + (if #{tmp\ 2693}# + (apply (lambda (#{x\ 2694}#) + (#{quasivector\ 2634}# + (#{quasi\ 2635}# + #{x\ 2694}# + #{lev\ 2673}#))) + #{tmp\ 2693}#) + ((lambda (#{p\ 2696}#) (list '#(syntax-object quote ((top) @@ -10174,16 +11032,16 @@ "i"))) (hygiene guile)) - p1513)) - tmp1491))) + #{p\ 2696}#)) + #{tmp\ 2674}#))) ($sc-dispatch - tmp1491 + #{tmp\ 2674}# '#(vector each-any))))) ($sc-dispatch - tmp1491 + #{tmp\ 2674}# '(any . any))))) ($sc-dispatch - tmp1491 + #{tmp\ 2674}# '(#(free-id #(syntax-object quasiquote @@ -10203,7 +11061,7 @@ (hygiene guile))) any))))) ($sc-dispatch - tmp1491 + #{tmp\ 2674}# '((#(free-id #(syntax-object unquote-splicing @@ -10226,7 +11084,7 @@ . any))))) ($sc-dispatch - tmp1491 + #{tmp\ 2674}# '((#(free-id #(syntax-object unquote-splicing @@ -10248,7 +11106,7 @@ . any))))) ($sc-dispatch - tmp1491 + #{tmp\ 2674}# '(#(free-id #(syntax-object unquote @@ -10266,7 +11124,7 @@ . any))))) ($sc-dispatch - tmp1491 + #{tmp\ 2674}# '(#(free-id #(syntax-object unquote @@ -10279,44 +11137,49 @@ #("i" "i" "i" "i"))) (hygiene guile))) any)))) - p1489)))) - (lambda (x1514) - ((lambda (tmp1515) - ((lambda (tmp1516) - (if tmp1516 - (apply (lambda (_1517 e1518) (quasi1452 e1518 0)) - tmp1516) + #{p\ 2672}#)))) + (lambda (#{x\ 2697}#) + ((lambda (#{tmp\ 2698}#) + ((lambda (#{tmp\ 2699}#) + (if #{tmp\ 2699}# + (apply (lambda (#{_\ 2700}# #{e\ 2701}#) + (#{quasi\ 2635}# #{e\ 2701}# 0)) + #{tmp\ 2699}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1515))) - ($sc-dispatch tmp1515 (quote (any any))))) - x1514))))) + #{tmp\ 2698}#))) + ($sc-dispatch #{tmp\ 2698}# (quote (any any))))) + #{x\ 2697}#))))) (define include (make-syncase-macro 'macro - (lambda (x1519) - (letrec ((read-file1520 - (lambda (fn1521 k1522) - (let ((p1523 (open-input-file fn1521))) - (letrec ((f1524 (lambda (x1525) - (if (eof-object? x1525) - (begin - (close-input-port p1523) - '()) - (cons (datum->syntax k1522 x1525) - (f1524 (read p1523))))))) - (f1524 (read p1523))))))) - ((lambda (tmp1526) - ((lambda (tmp1527) - (if tmp1527 - (apply (lambda (k1528 filename1529) - (let ((fn1530 (syntax->datum filename1529))) - ((lambda (tmp1531) - ((lambda (tmp1532) - (if tmp1532 - (apply (lambda (exp1533) + (lambda (#{x\ 2702}#) + (letrec ((#{read-file\ 2703}# + (lambda (#{fn\ 2704}# #{k\ 2705}#) + (let ((#{p\ 2706}# (open-input-file #{fn\ 2704}#))) + (letrec ((#{f\ 2707}# + (lambda (#{x\ 2708}#) + (if (eof-object? #{x\ 2708}#) + (begin + (close-input-port #{p\ 2706}#) + '()) + (cons (datum->syntax + #{k\ 2705}# + #{x\ 2708}#) + (#{f\ 2707}# (read #{p\ 2706}#))))))) + (#{f\ 2707}# (read #{p\ 2706}#))))))) + ((lambda (#{tmp\ 2709}#) + ((lambda (#{tmp\ 2710}#) + (if #{tmp\ 2710}# + (apply (lambda (#{k\ 2711}# #{filename\ 2712}#) + (let ((#{fn\ 2713}# + (syntax->datum #{filename\ 2712}#))) + ((lambda (#{tmp\ 2714}#) + ((lambda (#{tmp\ 2715}#) + (if #{tmp\ 2715}# + (apply (lambda (#{exp\ 2716}#) (cons '#(syntax-object begin ((top) @@ -10343,73 +11206,76 @@ #((top)) #("i"))) (hygiene guile)) - exp1533)) - tmp1532) + #{exp\ 2716}#)) + #{tmp\ 2715}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1531))) - ($sc-dispatch tmp1531 (quote each-any)))) - (read-file1520 fn1530 k1528)))) - tmp1527) + #{tmp\ 2714}#))) + ($sc-dispatch #{tmp\ 2714}# (quote each-any)))) + (#{read-file\ 2703}# #{fn\ 2713}# #{k\ 2711}#)))) + #{tmp\ 2710}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1526))) - ($sc-dispatch tmp1526 (quote (any any))))) - x1519))))) + #{tmp\ 2709}#))) + ($sc-dispatch #{tmp\ 2709}# (quote (any any))))) + #{x\ 2702}#))))) (define unquote (make-syncase-macro 'macro - (lambda (x1535) - ((lambda (tmp1536) - ((lambda (tmp1537) - (if tmp1537 - (apply (lambda (_1538 e1539) + (lambda (#{x\ 2718}#) + ((lambda (#{tmp\ 2719}#) + ((lambda (#{tmp\ 2720}#) + (if #{tmp\ 2720}# + (apply (lambda (#{_\ 2721}# #{e\ 2722}#) (syntax-violation 'unquote "expression not valid outside of quasiquote" - x1535)) - tmp1537) + #{x\ 2718}#)) + #{tmp\ 2720}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1536))) - ($sc-dispatch tmp1536 (quote (any any))))) - x1535)))) + #{tmp\ 2719}#))) + ($sc-dispatch #{tmp\ 2719}# (quote (any any))))) + #{x\ 2718}#)))) (define unquote-splicing (make-syncase-macro 'macro - (lambda (x1540) - ((lambda (tmp1541) - ((lambda (tmp1542) - (if tmp1542 - (apply (lambda (_1543 e1544) + (lambda (#{x\ 2723}#) + ((lambda (#{tmp\ 2724}#) + ((lambda (#{tmp\ 2725}#) + (if #{tmp\ 2725}# + (apply (lambda (#{_\ 2726}# #{e\ 2727}#) (syntax-violation 'unquote-splicing "expression not valid outside of quasiquote" - x1540)) - tmp1542) + #{x\ 2723}#)) + #{tmp\ 2725}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1541))) - ($sc-dispatch tmp1541 (quote (any any))))) - x1540)))) + #{tmp\ 2724}#))) + ($sc-dispatch #{tmp\ 2724}# (quote (any any))))) + #{x\ 2723}#)))) (define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) 'macro - (lambda (x1545) - ((lambda (tmp1546) - ((lambda (tmp1547) - (if tmp1547 - (apply (lambda (_1548 e1549 m11550 m21551) - ((lambda (tmp1552) - ((lambda (body1553) + (lambda (#{x\ 2728}#) + ((lambda (#{tmp\ 2729}#) + ((lambda (#{tmp\ 2730}#) + (if #{tmp\ 2730}# + (apply (lambda (#{_\ 2731}# + #{e\ 2732}# + #{m1\ 2733}# + #{m2\ 2734}#) + ((lambda (#{tmp\ 2735}#) + ((lambda (#{body\ 2736}#) (list '#(syntax-object let ((top) @@ -10438,25 +11304,82 @@ #((top)) #("i"))) (hygiene guile)) - e1549)) - body1553)) - tmp1552)) - (letrec ((f1554 (lambda (clause1555 clauses1556) - (if (null? clauses1556) - ((lambda (tmp1558) - ((lambda (tmp1559) - (if tmp1559 - (apply (lambda (e11560 - e21561) - (cons '#(syntax-object - begin + #{e\ 2732}#)) + #{body\ 2736}#)) + #{tmp\ 2735}#)) + (letrec ((#{f\ 2737}# + (lambda (#{clause\ 2738}# #{clauses\ 2739}#) + (if (null? #{clauses\ 2739}#) + ((lambda (#{tmp\ 2741}#) + ((lambda (#{tmp\ 2742}#) + (if #{tmp\ 2742}# + (apply (lambda (#{e1\ 2743}# + #{e2\ 2744}#) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 e2) + #((top) + (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (cons #{e1\ 2743}# + #{e2\ 2744}#))) + #{tmp\ 2742}#) + ((lambda (#{tmp\ 2746}#) + (if #{tmp\ 2746}# + (apply (lambda (#{k\ 2747}# + #{e1\ 2748}# + #{e2\ 2749}#) + (list '#(syntax-object + if ((top) #(ribcage - #(e1 + #(k + e1 e2) #((top) + (top) (top)) #("i" + "i" "i")) #(ribcage () @@ -10495,319 +11418,8 @@ #("i"))) (hygiene guile)) - (cons e11560 - e21561))) - tmp1559) - ((lambda (tmp1563) - (if tmp1563 - (apply (lambda (k1564 - e11565 - e21566) - (list '#(syntax-object - if - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - (list '#(syntax-object - memv - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - '#(syntax-object - t - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - (list '#(syntax-object - quote - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - k1564)) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - (cons e11565 - e21566)))) - tmp1563) - ((lambda (_1569) - (syntax-violation - 'case - "bad clause" - x1545 - clause1555)) - tmp1558))) - ($sc-dispatch - tmp1558 - '(each-any - any - . - each-any))))) - ($sc-dispatch - tmp1558 - '(#(free-id - #(syntax-object - else - ((top) - #(ribcage () () ()) - #(ribcage - #(f clause clauses) - #((top) (top) (top)) - #("i" "i" "i")) - #(ribcage - #(_ e m1 m2) - #((top) - (top) - (top) - (top)) - #("i" "i" "i" "i")) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene guile))) - any - . - each-any)))) - clause1555) - ((lambda (tmp1570) - ((lambda (rest1571) - ((lambda (tmp1572) - ((lambda (tmp1573) - (if tmp1573 - (apply (lambda (k1574 - e11575 - e21576) (list '#(syntax-object - if + memv ((top) #(ribcage #(k @@ -10820,9 +11432,55 @@ "i" "i")) #(ribcage - #(rest) + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) #((top)) - #("i")) + #("i"))) + (hygiene + guile)) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) #(ribcage () () @@ -10861,7 +11519,7 @@ (hygiene guile)) (list '#(syntax-object - memv + quote ((top) #(ribcage #(k @@ -10873,10 +11531,6 @@ #("i" "i" "i")) - #(ribcage - #(rest) - #((top)) - #("i")) #(ribcage () () @@ -10914,209 +11568,421 @@ #("i"))) (hygiene guile)) - '#(syntax-object - t - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - (list '#(syntax-object - quote - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - k1574)) - (cons '#(syntax-object - begin - ((top) - #(ribcage - #(k - e1 - e2) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(rest) - #((top)) - #("i")) - #(ribcage - () - () - ()) - #(ribcage - #(f - clause - clauses) - #((top) - (top) - (top)) - #("i" - "i" - "i")) - #(ribcage - #(_ - e - m1 - m2) - #((top) - (top) - (top) - (top)) - #("i" - "i" - "i" - "i")) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i"))) - (hygiene - guile)) - (cons e11575 - e21576)) - rest1571)) - tmp1573) - ((lambda (_1579) - (syntax-violation - 'case - "bad clause" - x1545 - clause1555)) - tmp1572))) - ($sc-dispatch - tmp1572 - '(each-any - any - . - each-any)))) - clause1555)) - tmp1570)) - (f1554 (car clauses1556) - (cdr clauses1556))))))) - (f1554 m11550 m21551)))) - tmp1547) + #{k\ 2747}#)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (cons #{e1\ 2748}# + #{e2\ 2749}#)))) + #{tmp\ 2746}#) + ((lambda (#{_\ 2752}#) + (syntax-violation + 'case + "bad clause" + #{x\ 2728}# + #{clause\ 2738}#)) + #{tmp\ 2741}#))) + ($sc-dispatch + #{tmp\ 2741}# + '(each-any + any + . + each-any))))) + ($sc-dispatch + #{tmp\ 2741}# + '(#(free-id + #(syntax-object + else + ((top) + #(ribcage () () ()) + #(ribcage + #(f clause clauses) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene guile))) + any + . + each-any)))) + #{clause\ 2738}#) + ((lambda (#{tmp\ 2753}#) + ((lambda (#{rest\ 2754}#) + ((lambda (#{tmp\ 2755}#) + ((lambda (#{tmp\ 2756}#) + (if #{tmp\ 2756}# + (apply (lambda (#{k\ 2757}# + #{e1\ 2758}# + #{e2\ 2759}#) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + #{k\ 2757}#)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(f + clause + clauses) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i"))) + (hygiene + guile)) + (cons #{e1\ 2758}# + #{e2\ 2759}#)) + #{rest\ 2754}#)) + #{tmp\ 2756}#) + ((lambda (#{_\ 2762}#) + (syntax-violation + 'case + "bad clause" + #{x\ 2728}# + #{clause\ 2738}#)) + #{tmp\ 2755}#))) + ($sc-dispatch + #{tmp\ 2755}# + '(each-any + any + . + each-any)))) + #{clause\ 2738}#)) + #{tmp\ 2753}#)) + (#{f\ 2737}# + (car #{clauses\ 2739}#) + (cdr #{clauses\ 2739}#))))))) + (#{f\ 2737}# #{m1\ 2733}# #{m2\ 2734}#)))) + #{tmp\ 2730}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1546))) + #{tmp\ 2729}#))) ($sc-dispatch - tmp1546 + #{tmp\ 2729}# '(any any any . each-any)))) - x1545)))) + #{x\ 2728}#)))) (define identifier-syntax (make-syncase-macro 'macro - (lambda (x1580) - ((lambda (tmp1581) - ((lambda (tmp1582) - (if tmp1582 - (apply (lambda (_1583 e1584) + (lambda (#{x\ 2763}#) + ((lambda (#{tmp\ 2764}#) + ((lambda (#{tmp\ 2765}#) + (if #{tmp\ 2765}# + (apply (lambda (#{_\ 2766}# #{e\ 2767}#) (list '#(syntax-object lambda ((top) @@ -11205,8 +12071,8 @@ #((top)) #("i"))) (hygiene guile)) - e1584)) - (list (cons _1583 + #{e\ 2767}#)) + (list (cons #{_\ 2766}# '(#(syntax-object x ((top) @@ -11246,7 +12112,7 @@ #((top)) #("i"))) (hygiene guile)) - (cons e1584 + (cons #{e\ 2767}# '(#(syntax-object x ((top) @@ -11274,11 +12140,11 @@ #("i"))) (hygiene guile))))))))) - tmp1582) + #{tmp\ 2765}#) (syntax-violation #f "source expression failed to match any pattern" - tmp1581))) - ($sc-dispatch tmp1581 (quote (any any))))) - x1580)))) + #{tmp\ 2764}#))) + ($sc-dispatch #{tmp\ 2764}# (quote (any any))))) + #{x\ 2763}#)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 6ecf24ee6..cb90fcc17 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1198,7 +1198,13 @@ ;; affect compile-time environment (once we have booted) (if (and (not (module-local-variable (current-module) n)) (current-module)) - (module-define! (current-module) n #f)) + (let ((old (module-variable (current-module) n))) + ;; use value of the same-named imported variable, if + ;; any + (module-define! (current-module) n + (if (variable? old) + (variable-ref old) + #f)))) (eval-if-c&e m (build-global-definition s n (chi e r w mod)) mod)) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 1252c2881..fe9d7765f 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -25,3 +25,13 @@ (pass-if "compile to value" (equal? (compile 1) 1))) + + +(with-test-prefix "psyntax" + + (pass-if "redefinition" + ;; In this case the locally-bound `round' must have the same value as the + ;; imported `round'. See the same test in `syntax.test' for details. + (let ((o1 (compile '(define round round))) + (o2 (compile '(eq? round (@@ (guile) round))))) + o2))) From 16f451f308cd79168d2b1d1314b324dff96fde0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 12 Aug 2009 19:22:19 +0200 Subject: [PATCH 362/375] Allow fresh modules to be passed to `compile'. * module/ice-9/boot-9.scm (module-name): When making MOD non-anonymous, bind it in the `(%app modules)' name space. * test-suite/tests/compiler.test ("psyntax")["compile in current module", "compile in fresh module"]: New tests. * test-suite/tests/modules.test ("foundations")["modules don't remain anonymous"]: New test. --- module/ice-9/boot-9.scm | 9 +++++++-- test-suite/tests/compiler.test | 22 +++++++++++++++++++--- test-suite/tests/modules.test | 9 ++++++++- 3 files changed, 34 insertions(+), 6 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 36a463ad3..01569cbf9 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1982,8 +1982,13 @@ (let ((accessor (record-accessor module-type 'name))) (lambda (mod) (or (accessor mod) - (begin - (set-module-name! mod (list (gensym))) + (let ((name (list (gensym)))) + ;; Name MOD and bind it in THE-ROOT-MODULE so that it's visible + ;; to `resolve-module'. This is important as `psyntax' stores + ;; module names and relies on being able to `resolve-module' + ;; them. + (set-module-name! mod name) + (nested-define! the-root-module `(%app modules ,@name) mod) (accessor mod)))))) ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index fe9d7765f..9c84fd7b4 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -1,5 +1,5 @@ ;;;; compiler.test --- tests for the compiler -*- scheme -*- -;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -19,8 +19,9 @@ :use-module (test-suite lib) :use-module (test-suite guile-test) :use-module (system base compile)) - + + (with-test-prefix "basic" (pass-if "compile to value" @@ -34,4 +35,19 @@ ;; imported `round'. See the same test in `syntax.test' for details. (let ((o1 (compile '(define round round))) (o2 (compile '(eq? round (@@ (guile) round))))) - o2))) + o2)) + + (pass-if "compile in current module" + (let ((o1 (compile '(define-macro (foo) 'bar))) + (o2 (compile '(let ((bar 'ok)) (foo))))) + (and (module-ref (current-module) 'foo) + (eq? o2 'ok)))) + + (pass-if "compile in fresh module" + (let* ((m (let ((m (make-module))) + (beautify-user-module! m) + m)) + (o1 (compile '(define-macro (foo) 'bar) #:env m)) + (o2 (compile '(let ((bar 'ok)) (foo)) #:env m))) + (and (module-ref m 'foo) + (eq? o2 'ok))))) diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index 696c35ca2..f22cfe9c1 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -1,6 +1,6 @@ ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- -;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -34,6 +34,13 @@ (with-test-prefix "foundations" + (pass-if "modules don't remain anonymous" + ;; This is a requirement for `psyntax': it stores module names and relies + ;; on being able to `resolve-module' them. + (let ((m (make-module))) + (and (module-name m) + (eq? m (resolve-module (module-name m)))))) + (pass-if "module-add!" (let ((m (make-module)) (value (cons 'x 'y))) From d785171115bb35c6e3cc3663a0023ff4e88536d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 13 Aug 2009 16:16:08 +0200 Subject: [PATCH 363/375] compiler.test: Enforce evaluation order. * test-suite/tests/compiler.test ("psyntax")["redefinition", "compile in current module", "compile in fresh module"]: Use `begin' to enforce evaluation order. Thanks Andy! --- test-suite/tests/compiler.test | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 9c84fd7b4..f9fabd7bc 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -33,21 +33,23 @@ (pass-if "redefinition" ;; In this case the locally-bound `round' must have the same value as the ;; imported `round'. See the same test in `syntax.test' for details. - (let ((o1 (compile '(define round round))) - (o2 (compile '(eq? round (@@ (guile) round))))) - o2)) + (begin + (compile '(define round round)) + (compile '(eq? round (@@ (guile) round))))) (pass-if "compile in current module" - (let ((o1 (compile '(define-macro (foo) 'bar))) - (o2 (compile '(let ((bar 'ok)) (foo))))) + (let ((o (begin + (compile '(define-macro (foo) 'bar)) + (compile '(let ((bar 'ok)) (foo)))))) (and (module-ref (current-module) 'foo) - (eq? o2 'ok)))) + (eq? o 'ok)))) (pass-if "compile in fresh module" (let* ((m (let ((m (make-module))) (beautify-user-module! m) m)) - (o1 (compile '(define-macro (foo) 'bar) #:env m)) - (o2 (compile '(let ((bar 'ok)) (foo)) #:env m))) + (o (begin + (compile '(define-macro (foo) 'bar) #:env m) + (compile '(let ((bar 'ok)) (foo)) #:env m)))) (and (module-ref m 'foo) - (eq? o2 'ok))))) + (eq? o 'ok))))) From 4d0949ea45c46dd13e767a8a3342d02caef1b483 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 13 Aug 2009 23:08:35 +0200 Subject: [PATCH 364/375] Make the evaluator's memoizers private. * libguile/eval.c (macroexp): Move upwards. (scm_m_quote, scm_m_begin, scm_m_if, scm_m_set_x, scm_m_and, scm_m_or, scm_m_case, scm_m_cond, scm_m_lambda, scm_m_letstar, scm_m_do, scm_m_quasiquote, scm_m_delay, scm_m_generalized_set_x, scm_m_define, scm_m_letrec, scm_m_let, scm_m_at, scm_m_atat, scm_m_apply, scm_m_cont, scm_m_nil_cond, scm_m_atfop, scm_m_atbind, scm_m_atslot_ref, scm_m_atslot_set_x, scm_m_at_call_with_values, scm_m_eval_when): New static declarations; definitions made static. (s_atslot_ref, s_atslot_set_x): New, from `goops.c'. * libguile/eval.h (scm_m_quote, scm_m_begin, scm_m_if, scm_m_set_x, scm_m_vref, scm_m_vset, scm_m_and, scm_m_or, scm_m_case, scm_m_cond, scm_m_lambda, scm_m_letstar, scm_m_do, scm_m_quasiquote, scm_m_delay, scm_m_generalized_set_x, scm_m_future, scm_m_define, scm_m_letrec, scm_m_let, scm_m_at, scm_m_atat, scm_m_apply, scm_m_cont, scm_m_nil_cond, scm_m_atfop, scm_m_atbind, scm_m_atslot_ref, scm_m_atslot_set_x, scm_m_atdispatch, scm_m_at_call_with_values, scm_m_eval_when): Remove public declarations. * libguile/goops.c (s_atslot_ref, s_atslot_set_x): Remove. --- libguile/eval.c | 216 ++++++++++++++++++++++++++++------------------- libguile/eval.h | 36 +------- libguile/goops.c | 5 +- 3 files changed, 129 insertions(+), 128 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index f7f3f27df..4640ea5f9 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -710,6 +710,101 @@ is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) return 0; } +static SCM +macroexp (SCM x, SCM env) +{ + SCM res, proc, orig_sym; + + /* Don't bother to produce error messages here. We get them when we + eventually execute the code for real. */ + + macro_tail: + orig_sym = SCM_CAR (x); + if (!scm_is_symbol (orig_sym)) + return x; + + { + SCM *proc_ptr = scm_lookupcar1 (x, env, 0); + if (proc_ptr == NULL) + { + /* We have lost the race. */ + goto macro_tail; + } + proc = *proc_ptr; + } + + /* Only handle memoizing macros. `Acros' and `macros' are really + special forms and should not be evaluated here. */ + + if (!SCM_MACROP (proc) + || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc))) + return x; + + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ + res = scm_call_2 (SCM_MACRO_CODE (proc), x, env); + + if (scm_ilength (res) <= 0) + /* Result of expansion is not a list. */ + return (scm_list_2 (SCM_IM_BEGIN, res)); + else + { + /* njrev: Several queries here: (1) I don't see how it can be + correct that the SCM_SETCAR 2 lines below this comment needs + protection, but the SCM_SETCAR 6 lines above does not, so + something here is probably wrong. (2) macroexp() is now only + used in one place - scm_m_generalized_set_x - whereas all other + macro expansion happens through expand_user_macros. Therefore + (2.1) perhaps macroexp() could be eliminated completely now? + (2.2) Does expand_user_macros need any critical section + protection? */ + + SCM_CRITICAL_SECTION_START; + SCM_SETCAR (x, SCM_CAR (res)); + SCM_SETCDR (x, SCM_CDR (res)); + SCM_CRITICAL_SECTION_END; + + goto macro_tail; + } +} + + +/* Start of the memoizers for the standard R5RS builtin macros. */ + +static SCM scm_m_quote (SCM xorig, SCM env); +static SCM scm_m_begin (SCM xorig, SCM env); +static SCM scm_m_if (SCM xorig, SCM env); +static SCM scm_m_set_x (SCM xorig, SCM env); +static SCM scm_m_and (SCM xorig, SCM env); +static SCM scm_m_or (SCM xorig, SCM env); +static SCM scm_m_case (SCM xorig, SCM env); +static SCM scm_m_cond (SCM xorig, SCM env); +static SCM scm_m_lambda (SCM xorig, SCM env); +static SCM scm_m_letstar (SCM xorig, SCM env); +static SCM scm_m_do (SCM xorig, SCM env); +static SCM scm_m_quasiquote (SCM xorig, SCM env); +static SCM scm_m_delay (SCM xorig, SCM env); +static SCM scm_m_generalized_set_x (SCM xorig, SCM env); +#if 0 /* Futures are disabled, see "futures.h". */ +static SCM scm_m_future (SCM xorig, SCM env); +#endif +static SCM scm_m_define (SCM x, SCM env); +static SCM scm_m_letrec (SCM xorig, SCM env); +static SCM scm_m_let (SCM xorig, SCM env); +static SCM scm_m_at (SCM xorig, SCM env); +static SCM scm_m_atat (SCM xorig, SCM env); +static SCM scm_m_atslot_ref (SCM xorig, SCM env); +static SCM scm_m_atslot_set_x (SCM xorig, SCM env); +static SCM scm_m_apply (SCM xorig, SCM env); +static SCM scm_m_cont (SCM xorig, SCM env); +#if SCM_ENABLE_ELISP +static SCM scm_m_nil_cond (SCM xorig, SCM env); +static SCM scm_m_atfop (SCM xorig, SCM env); +#endif /* SCM_ENABLE_ELISP */ +static SCM scm_m_atbind (SCM xorig, SCM env); +static SCM scm_m_at_call_with_values (SCM xorig, SCM env); +static SCM scm_m_eval_when (SCM xorig, SCM env); + + static void m_expand_body (const SCM forms, const SCM env) { @@ -832,70 +927,10 @@ m_expand_body (const SCM forms, const SCM env) } } -static SCM -macroexp (SCM x, SCM env) -{ - SCM res, proc, orig_sym; - - /* Don't bother to produce error messages here. We get them when we - eventually execute the code for real. */ - - macro_tail: - orig_sym = SCM_CAR (x); - if (!scm_is_symbol (orig_sym)) - return x; - - { - SCM *proc_ptr = scm_lookupcar1 (x, env, 0); - if (proc_ptr == NULL) - { - /* We have lost the race. */ - goto macro_tail; - } - proc = *proc_ptr; - } - - /* Only handle memoizing macros. `Acros' and `macros' are really - special forms and should not be evaluated here. */ - - if (!SCM_MACROP (proc) - || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc))) - return x; - - SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ - res = scm_call_2 (SCM_MACRO_CODE (proc), x, env); - - if (scm_ilength (res) <= 0) - /* Result of expansion is not a list. */ - return (scm_list_2 (SCM_IM_BEGIN, res)); - else - { - /* njrev: Several queries here: (1) I don't see how it can be - correct that the SCM_SETCAR 2 lines below this comment needs - protection, but the SCM_SETCAR 6 lines above does not, so - something here is probably wrong. (2) macroexp() is now only - used in one place - scm_m_generalized_set_x - whereas all other - macro expansion happens through expand_user_macros. Therefore - (2.1) perhaps macroexp() could be eliminated completely now? - (2.2) Does expand_user_macros need any critical section - protection? */ - - SCM_CRITICAL_SECTION_START; - SCM_SETCAR (x, SCM_CAR (res)); - SCM_SETCDR (x, SCM_CDR (res)); - SCM_CRITICAL_SECTION_END; - - goto macro_tail; - } -} - -/* Start of the memoizers for the standard R5RS builtin macros. */ - - SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and); SCM_GLOBAL_SYMBOL (scm_sym_and, s_and); -SCM +static SCM scm_m_and (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -925,7 +960,7 @@ unmemoize_and (const SCM expr, const SCM env) SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin); SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); -SCM +static SCM scm_m_begin (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -949,7 +984,7 @@ SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case); SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); -SCM +static SCM scm_m_case (SCM expr, SCM env) { SCM clauses; @@ -1045,7 +1080,7 @@ SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond); SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond); SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); -SCM +static SCM scm_m_cond (SCM expr, SCM env) { /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */ @@ -1207,7 +1242,7 @@ canonicalize_define (const SCM expr) operation. However, EXPRESSION _can_ be evaluated before VARIABLE is bound. This means that EXPRESSION won't necessarily be able to assign values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */ -SCM +static SCM scm_m_define (SCM expr, SCM env) { ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr); @@ -1262,7 +1297,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); * (delay ) is transformed into (#@delay '() ), where * the empty list represents the empty parameter list. This representation * allows for easy creation of the closure during evaluation. */ -SCM +static SCM scm_m_delay (SCM expr, SCM env) { const SCM new_expr = memoize_as_thunk_prototype (expr, env); @@ -1305,7 +1340,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); () ... ) ;; missing steps replaced by var */ -SCM +static SCM scm_m_do (SCM expr, SCM env SCM_UNUSED) { SCM variables = SCM_EOL; @@ -1403,7 +1438,7 @@ unmemoize_do (const SCM expr, const SCM env) SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if); SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); -SCM +static SCM scm_m_if (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -1453,7 +1488,7 @@ c_improper_memq (SCM obj, SCM list) return scm_is_eq (list, obj); } -SCM +static SCM scm_m_lambda (SCM expr, SCM env SCM_UNUSED) { SCM formals; @@ -1623,7 +1658,7 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED) /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */ -SCM +static SCM scm_m_let (SCM expr, SCM env) { SCM bindings; @@ -1697,7 +1732,7 @@ unmemoize_let (const SCM expr, const SCM env) SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec); SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); -SCM +static SCM scm_m_letrec (SCM expr, SCM env) { SCM bindings; @@ -1748,7 +1783,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */ -SCM +static SCM scm_m_letstar (SCM expr, SCM env SCM_UNUSED) { SCM binding_idx; @@ -1821,7 +1856,7 @@ unmemoize_letstar (const SCM expr, const SCM env) SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or); SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); -SCM +static SCM scm_m_or (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -1905,7 +1940,7 @@ iqq (SCM form, SCM env, unsigned long int depth) return form; } -SCM +static SCM scm_m_quasiquote (SCM expr, SCM env) { const SCM cdr_expr = SCM_CDR (expr); @@ -1918,7 +1953,7 @@ scm_m_quasiquote (SCM expr, SCM env) SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote); SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); -SCM +static SCM scm_m_quote (SCM expr, SCM env SCM_UNUSED) { SCM quotee; @@ -1947,7 +1982,7 @@ SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */ static const char s_set_x[] = "set!"; SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); -SCM +static SCM scm_m_set_x (SCM expr, SCM env SCM_UNUSED) { SCM variable; @@ -1977,13 +2012,14 @@ unmemoize_set_x (const SCM expr, const SCM env) } + /* Start of the memoizers for non-R5RS builtin macros. */ SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at); SCM_GLOBAL_SYMBOL (scm_sym_at, s_at); -SCM +static SCM scm_m_at (SCM expr, SCM env SCM_UNUSED) { SCM mod, var; @@ -2004,7 +2040,7 @@ scm_m_at (SCM expr, SCM env SCM_UNUSED) SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat); SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat); -SCM +static SCM scm_m_atat (SCM expr, SCM env SCM_UNUSED) { SCM mod, var; @@ -2026,7 +2062,7 @@ SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply); SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); -SCM +static SCM scm_m_apply (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -2063,7 +2099,7 @@ SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind); * * FIXME - also implement `@bind*'. */ -SCM +static SCM scm_m_atbind (SCM expr, SCM env) { SCM bindings; @@ -2102,7 +2138,7 @@ scm_m_atbind (SCM expr, SCM env) SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont); SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc); -SCM +static SCM scm_m_cont (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -2123,7 +2159,7 @@ unmemoize_atcall_cc (const SCM expr, const SCM env) SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values); SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); -SCM +static SCM scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -2147,7 +2183,7 @@ SCM_SYMBOL (sym_eval, "eval"); SCM_SYMBOL (sym_load, "load"); -SCM +static SCM scm_m_eval_when (SCM expr, SCM env SCM_UNUSED) { ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); @@ -2173,7 +2209,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); * (#@future '() ), where the empty list represents the * empty parameter list. This representation allows for easy creation * of the closure during evaluation. */ -SCM +static SCM scm_m_future (SCM expr, SCM env) { const SCM new_expr = memoize_as_thunk_prototype (expr, env); @@ -2193,7 +2229,7 @@ unmemoize_future (const SCM expr, const SCM env) SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x); SCM_SYMBOL (scm_sym_setter, "setter"); -SCM +static SCM scm_m_generalized_set_x (SCM expr, SCM env) { SCM target, exp_target; @@ -2250,9 +2286,11 @@ scm_m_generalized_set_x (SCM expr, SCM env) * arbitrary modules during the startup phase, the code from goops.c should be * moved here. */ +SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref); +SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x); SCM_SYMBOL (sym_atslot_ref, "@slot-ref"); -SCM +static SCM scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED) { SCM slot_nr; @@ -2285,7 +2323,7 @@ unmemoize_atslot_ref (const SCM expr, const SCM env) SCM_SYMBOL (sym_atslot_set_x, "@slot-set!"); -SCM +static SCM scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) { SCM slot_nr; @@ -2323,7 +2361,7 @@ SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond); /* nil-cond expressions have the form * (nil-cond COND VAL COND VAL ... ELSEVAL) */ -SCM +static SCM scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED) { const long length = scm_ilength (SCM_CDR (expr)); @@ -2346,7 +2384,7 @@ SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop); * if the value of var (across all aliasing) is not a macro, or * ( ...) * if var is a macro. */ -SCM +static SCM scm_m_atfop (SCM expr, SCM env SCM_UNUSED) { SCM location; diff --git a/libguile/eval.h b/libguile/eval.h index 0d4223837..e02e767a1 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -3,7 +3,7 @@ #ifndef SCM_EVAL_H #define SCM_EVAL_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008 +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -115,40 +115,6 @@ SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check); SCM_API SCM scm_eval_car (SCM pair, SCM env); SCM_API SCM scm_eval_body (SCM code, SCM env); SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc); -SCM_API SCM scm_m_quote (SCM xorig, SCM env); -SCM_API SCM scm_m_begin (SCM xorig, SCM env); -SCM_API SCM scm_m_if (SCM xorig, SCM env); -SCM_API SCM scm_m_set_x (SCM xorig, SCM env); -SCM_API SCM scm_m_vref (SCM xorig, SCM env); -SCM_API SCM scm_m_vset (SCM xorig, SCM env); -SCM_API SCM scm_m_and (SCM xorig, SCM env); -SCM_API SCM scm_m_or (SCM xorig, SCM env); -SCM_API SCM scm_m_case (SCM xorig, SCM env); -SCM_API SCM scm_m_cond (SCM xorig, SCM env); -SCM_API SCM scm_m_lambda (SCM xorig, SCM env); -SCM_API SCM scm_m_letstar (SCM xorig, SCM env); -SCM_API SCM scm_m_do (SCM xorig, SCM env); -SCM_API SCM scm_m_quasiquote (SCM xorig, SCM env); -SCM_API SCM scm_m_delay (SCM xorig, SCM env); -SCM_API SCM scm_m_generalized_set_x (SCM xorig, SCM env); -SCM_API SCM scm_m_future (SCM xorig, SCM env); -SCM_API SCM scm_m_define (SCM x, SCM env); -SCM_API SCM scm_m_letrec (SCM xorig, SCM env); -SCM_API SCM scm_m_let (SCM xorig, SCM env); -SCM_API SCM scm_m_at (SCM xorig, SCM env); -SCM_API SCM scm_m_atat (SCM xorig, SCM env); -SCM_API SCM scm_m_apply (SCM xorig, SCM env); -SCM_API SCM scm_m_cont (SCM xorig, SCM env); -#if SCM_ENABLE_ELISP -SCM_API SCM scm_m_nil_cond (SCM xorig, SCM env); -SCM_API SCM scm_m_atfop (SCM xorig, SCM env); -#endif /* SCM_ENABLE_ELISP */ -SCM_API SCM scm_m_atbind (SCM xorig, SCM env); -SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env); -SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env); -SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env); -SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env); -SCM_API SCM scm_m_eval_when (SCM xorig, SCM env); SCM_API int scm_badargsp (SCM formals, SCM args); SCM_API SCM scm_call_0 (SCM proc); SCM_API SCM scm_call_1 (SCM proc, SCM arg1); diff --git a/libguile/goops.c b/libguile/goops.c index 1548472cb..c286dbe4c 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1256,10 +1256,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, #undef FUNC_NAME -SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref); -SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x); - - + /** Utilities **/ /* In the future, this function will return the effective slot From b3ce13b667634be30ab2d74b8ccb1de190d7aeeb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 13 Aug 2009 23:36:46 +0200 Subject: [PATCH 365/375] Remove deprecated semi-public memoizers. * libguile/eval.c (scm_m_expand_body, scm_macroexp, scm_unmemocar): Remove. (scm_m_undefine): Make `static'. * libguile/eval.h (scm_m_undefine, scm_m_expand_body, scm_unmemocar, scm_macroexp): Remove declarations. --- libguile/eval.c | 62 ++++--------------------------------------------- libguile/eval.h | 9 ------- 2 files changed, 4 insertions(+), 67 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 4640ea5f9..6a6a0ce7b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2555,20 +2555,11 @@ scm_i_unmemocopy_body (SCM forms, SCM env) #if (SCM_ENABLE_DEPRECATED == 1) -/* Deprecated in guile 1.7.0 on 2003-11-09. */ -SCM -scm_m_expand_body (SCM exprs, SCM env) -{ - scm_c_issue_deprecation_warning - ("`scm_m_expand_body' is deprecated."); - m_expand_body (exprs, env); - return exprs; -} - +static SCM scm_m_undefine (SCM expr, SCM env); SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine); -SCM +static SCM scm_m_undefine (SCM expr, SCM env) { SCM variable; @@ -2592,55 +2583,10 @@ scm_m_undefine (SCM expr, SCM env) return SCM_UNSPECIFIED; } -SCM -scm_macroexp (SCM x, SCM env) -{ - scm_c_issue_deprecation_warning - ("`scm_macroexp' is deprecated."); - return macroexp (x, env); -} - -#endif +#endif /* SCM_ENABLE_DEPRECATED */ -#if (SCM_ENABLE_DEPRECATED == 1) - -SCM -scm_unmemocar (SCM form, SCM env) -{ - scm_c_issue_deprecation_warning - ("`scm_unmemocar' is deprecated."); - - if (!scm_is_pair (form)) - return form; - else - { - SCM c = SCM_CAR (form); - if (SCM_VARIABLEP (c)) - { - SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); - if (scm_is_false (sym)) - sym = sym_three_question_marks; - SCM_SETCAR (form, sym); - } - else if (SCM_ILOCP (c)) - { - unsigned long int ir; - - for (ir = SCM_IFRAME (c); ir != 0; --ir) - env = SCM_CDR (env); - env = SCM_CAAR (env); - for (ir = SCM_IDIST (c); ir != 0; --ir) - env = SCM_CDR (env); - - SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); - } - return form; - } -} - -#endif - + /*****************************************************************************/ /*****************************************************************************/ /* The definitions for execution start here. */ diff --git a/libguile/eval.h b/libguile/eval.h index e02e767a1..4467358f5 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -156,15 +156,6 @@ SCM_INTERNAL void scm_init_eval (void); #if (SCM_ENABLE_DEPRECATED == 1) -SCM_API SCM scm_m_undefine (SCM x, SCM env); - -/* Deprecated in guile 1.7.0 on 2003-11-09. */ -SCM_API SCM scm_m_expand_body (SCM xorig, SCM env); - -/* Deprecated in guile 1.7.0 on 2003-11-16. */ -SCM_API SCM scm_unmemocar (SCM form, SCM env); -SCM_API SCM scm_macroexp (SCM x, SCM env); - /* Deprecated in guile 1.7.0 on 2004-03-29. */ SCM_API SCM scm_ceval (SCM x, SCM env); SCM_API SCM scm_deval (SCM x, SCM env); From e3c9c676ae8b45ab98296532ac9756566dc46631 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 13 Aug 2009 23:59:51 +0200 Subject: [PATCH 366/375] Uncomment run-time objcode alignment check. This should now work thanks to the changes in 28b119ee3da0f4b14cb87e638794d22843778cda ("make sure all programs are 8-byte aligned"). This commit is a follow-up to ec99fe8ecb412e49e8e981246eb62ca46b32754b ("Add FIXMEs about misaligned objcode-metas."). * libguile/objcodes.c (scm_c_make_objcode_slice): Uncomment assertion that checks for proper alignment of PTR. * module/language/assembly/compile-bytecode.scm (write-bytecode): Update comment about META's alignment. --- libguile/objcodes.c | 8 ++++---- module/language/assembly/compile-bytecode.scm | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 19c2406b1..5466ecc2c 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -119,10 +119,10 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) scm_from_uint32 (parent_data->len), scm_from_uint32 (parent_data->metalen))); -#if 0 - /* FIXME: We currently generate bytecode where the objcode-meta isn't - suitable aligned, which is an issue on some arches (e.g., SPARC). */ - assert ((((uintptr_t) ptr) & (__alignof__ (struct scm_objcode) - 1UL)) == 0); +#ifdef __GNUC__ /* we need `__alignof__' */ + /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to + do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */ + assert ((((scm_t_bits) ptr) & (__alignof__ (struct scm_objcode) - 1UL)) == 0); #endif data = (struct scm_objcode*)ptr; diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index c49c20081..4706cce64 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -130,9 +130,9 @@ (set! i (1+ i)) (if (> i 0) (write-byte x)))) (get-addr (lambda () i))) - ;; FIXME: We should add padding here so that META's bytecode - ;; meets the alignment requirements of `scm_objcode'. See - ;; `scm_c_make_objcode_slice ()'. + ;; META's bytecode meets the alignment requirements of + ;; `scm_objcode', thanks to the alignment computed in + ;; `(language assembly)'. (write-bytecode meta write get-addr '())))) ((make-char32 ,x) (write-uint32-be x)) ((load-number ,str) (write-loader str)) From c1a15f3dd7788e391db2f6eea9562a3fd9f7a7e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 15 Aug 2009 12:05:36 +0200 Subject: [PATCH 367/375] Switch from `guile-1.8.pc' to `guile-2.0.pc'. * configure.ac: Produce guile-2.0*.pc. * meta/Makefile.am (EXTRA_DIST): Rename guile-1.8*.pc.in to guile-2.0*.pc.in. (pkgconfig_DATA): Update accordingly. * meta/guile-config (guile-module): Likewise. --- .gitignore | 3 ++- configure.ac | 4 ++-- meta/Makefile.am | 6 +++--- ...le-1.8-uninstalled.pc.in => guile-2.0-uninstalled.pc.in} | 0 meta/{guile-1.8.pc.in => guile-2.0.pc.in} | 0 meta/guile-config | 4 ++-- 6 files changed, 9 insertions(+), 8 deletions(-) rename meta/{guile-1.8-uninstalled.pc.in => guile-2.0-uninstalled.pc.in} (100%) rename meta/{guile-1.8.pc.in => guile-2.0.pc.in} (100%) diff --git a/.gitignore b/.gitignore index 29f29be5f..9c145efe9 100644 --- a/.gitignore +++ b/.gitignore @@ -69,7 +69,8 @@ guile-readline/guile-readline-config.h guile-readline/guile-readline-config.h.in *.go TAGS -guile-1.8.pc +/meta/guile-2.0.pc +/meta/guile-2.0-uninstalled.pc gdb-pre-inst-guile cscope.out cscope.files diff --git a/configure.ac b/configure.ac index 7f6df87ef..ddc092ee9 100644 --- a/configure.ac +++ b/configure.ac @@ -1539,8 +1539,8 @@ AC_CONFIG_FILES([ testsuite/Makefile ]) -AC_CONFIG_FILES([meta/guile-1.8.pc]) -AC_CONFIG_FILES([meta/guile-1.8-uninstalled.pc]) +AC_CONFIG_FILES([meta/guile-2.0.pc]) +AC_CONFIG_FILES([meta/guile-2.0-uninstalled.pc]) AC_CONFIG_FILES([check-guile], [chmod +x check-guile]) AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile]) AC_CONFIG_FILES([meta/guile], [chmod +x meta/guile]) diff --git a/meta/Makefile.am b/meta/Makefile.am index e047038aa..ba79794cf 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## Jim Blandy --- September 1997 ## -## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -23,10 +23,10 @@ bin_SCRIPTS=guile-config guile-tools EXTRA_DIST= $(bin_SCRIPTS) \ guile.m4 ChangeLog-2008 \ - guile-1.8.pc.in guile-1.8-uninstalled.pc.in + guile-2.0.pc.in guile-2.0-uninstalled.pc.in pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = guile-1.8.pc +pkgconfig_DATA = guile-2.0.pc ## FIXME: in the future there will be direct automake support for ## doing this. When that happens, switch over. diff --git a/meta/guile-1.8-uninstalled.pc.in b/meta/guile-2.0-uninstalled.pc.in similarity index 100% rename from meta/guile-1.8-uninstalled.pc.in rename to meta/guile-2.0-uninstalled.pc.in diff --git a/meta/guile-1.8.pc.in b/meta/guile-2.0.pc.in similarity index 100% rename from meta/guile-1.8.pc.in rename to meta/guile-2.0.pc.in diff --git a/meta/guile-config b/meta/guile-config index 7304ae2a8..6c640c40c 100755 --- a/meta/guile-config +++ b/meta/guile-config @@ -4,7 +4,7 @@ exec guile -e main -s $0 "$@" ;;;; guile-config --- utility for linking programs with Guile ;;;; Jim Blandy --- September 1997 ;;;; -;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -71,7 +71,7 @@ exec guile -e main -s $0 "$@" (dle " " p " --help - show usage info (this message)") (dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND"))) -(define guile-module "guile-1.8") +(define guile-module "guile-2.0") (define (pkg-config . args) (let* ((real-args (cons "pkg-config" args)) From 7577d1c4bac443a6cf220cbdbf0d637b6d388431 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 15 Aug 2009 12:06:28 +0200 Subject: [PATCH 368/375] Update `.gitignore' for GNU Global. --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 9c145efe9..004c7f37d 100644 --- a/.gitignore +++ b/.gitignore @@ -109,3 +109,7 @@ INSTALL /lib/time.h /lib/unistd.h /lib/unistr/.dirstamp +/GPATH +/GRTAGS +/GSYMS +/GTAGS From acf04ab4621d9b558f0c403897d36ef9369d1dfc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 15 Aug 2009 12:49:44 +0200 Subject: [PATCH 369/375] update NEWS for 1.9.2 * NEWS: Update. --- NEWS | 148 ++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 80 insertions(+), 68 deletions(-) diff --git a/NEWS b/NEWS index 96c3a9b1d..f8aea59ec 100644 --- a/NEWS +++ b/NEWS @@ -10,87 +10,99 @@ prerelease, and a full NEWS corresponding to 1.8 -> 2.0.) Changes in 1.9.2 (since the 1.9.1 prerelease): -** Global variables `scm_charnames' and `scm_charnums' are removed. +** VM speed improvements + +Closures now copy the free variables that they need into a flat vector +instead of capturing all heap-allocated variables. This speeds up access +to free variables, avoids unnecessary garbage retention, and allows all +variables to be allocated on the stack. + +Variables which are `set!' are now allocated on the stack, but in +"boxes". This allows a more uniform local variable allocation +discipline, and allows faster access to these variables. + +The VM has new special-case operations, `add1' and `sub1'. + +** VM robustness improvements + +The maximum number of live local variables has been increased from 256 +to 65535. + +The default VM stack size is 64 kilo-words, up from 16 kilo-words. This +allows more programs to execute in the default stack space. In the +future we will probably implement extensible stacks via overflow +handlers. + +Some lingering cases in which the VM could perform unaligned accesses +have been fixed. + +The address range for relative jumps has been expanded from 16-bit +addresses to 19-bit addresses via 8-byte alignment of jump targets. This +will probably change to a 24-bit byte-addressable strategy before Guile +2.0. + +** Compiler optimizations + +Procedures bound by `letrec' are no longer allocated on the heap, +subject to a few constraints. In many cases, procedures bound by +`letrec' and `let' can be rendered inline to their parent function, with +loop detection for mutually tail-recursive procedures. + +Unreferenced variables are now optimized away. + +** Compiler robustness + +Guile may now warn about unused lexically-bound variables. Pass +`-Wunused-variable' to `guile-tools compile', or `#:warnings +(unused-variable)' within the #:opts argument to the `compile' procedure +from `(system base compile)'. + +** Incomplete support for Unicode characters and strings + +Preliminary support for Unicode has landed. Characters may be entered in +octal format via e.g. `#\454', or created via (integer->char 300). A hex +external representation will probably be introduced at some point. + +Internally, strings are now represented either in the `latin-1' +encoding, one byte per character, or in UTF-32, with four bytes per +character. Strings manage their own allocation, switching if needed. + +Currently no locale conversion is performed. Extended characters may be +written in a string using the hexadecimal escapes `\xXX', `\uXXXX', or +`\UXXXXXX', for 8-bit, 16-bit, or 24-bit codepoints, respectively. + +This support is obviously incomplete. Many C functions have not yet been +updated to deal with the new representations. Users are advised to wait +for the next release for more serious use of Unicode strings. + +** `defined?' may accept a module as its second argument + +Previously it only accepted internal structures from the evaluator. + +** `let-values' is now implemented with a hygienic macro + +This could have implications discussed below in the NEWS entry titled, +"Lexical bindings introduced by hygienic macros may not be referenced by +nonhygienic macros". + +** Global variables `scm_charnames' and `scm_charnums' are removed These variables contained the names of control characters and were used when writing characters. While these were global, they were never intended to be public API. They have been replaced with private functions. -** EBCDIC support is removed. +** EBCDIC support is removed There was an EBCDIC compile flag that altered some of the character processing. It appeared that full EBCDIC support was never completed and was unmaintained. -Changes in 1.9.1 (since the 1.9.0 prerelease): - -** `scm_set_port_seek' and `scm_set_port_truncate' use the `scm_t_off' type - -Previously they would use the `off_t' type, which is fragile since its -definition depends on the application's value for `_FILE_OFFSET_BITS'. - -** Automatically compiled files will be placed in ~/.cache, not ~/.guile-ccache. - -Actually, they will be placed in $XDG_CACHE_HOME/guile/ccache/1.9, -defaulting to XDG_CACHE_HOME=~/.cache. Users may remove their -~/.guile-ccache directories. - -** New language: Brainfuck. - -Brainfuck is a toy language that closely models Turing machines. Guile's -brainfuck compiler is meant to be an example of implementing other -languages. See the manual for details, or -http://en.wikipedia.org/wiki/Brainfuck for more information about the -Brainfuck language itself. - -** A number of Scheme files were corrected to be LGPLv3+. - -Some Scheme files imported for the compiler were erroneously labeled as -being LGPLv2+ or GPLv2+. This oversight has been fixed. - -** Bytevectors may now be accessed with a C-friendly API. - -New functions: `scm_is_bytevector ()', `scm_c_bytevector_length ()', -`scm_c_bytevector_length ()', and `scm_c_bytevector_set_x ()'. See the -manual for details. - -** Bytevectors are now accessible using the generalized-vector API. - -As a side effect, this change allows compilation of literal bytevectors -(`#vu8(...)'). - -** Meta-commands to the REPL work better with strange languages. - -Specifically, meta-commands that take expressions as arguments will use -the current language's reader to read those expressions, which may span -multiple lines, with readline integration if the user has that enabled. - -** The object code file format has changed. - -The objcode loader will complain about a "bad header cookie" if it -happens to find an old file. The workaround for that is currently to -find all stale .go files and remove them. This is likely to affect users -who have checked out Guile's git repository, not those that build from -tarballs. - -** Vector access has been sped up considerably. - -Guile's virtual machine now has vector and bytevector operations. Using -Guile to process large amounts of data is now easier. This is because -`vector-ref' and `vector-set!' now have fast opcodes. In addition, there -are opcodes for `ref' and `set' operations on bytevectors for everything -from 8-bit integers to 64-bit floating-point values. - -In the next release, we hope to extend this speedup to other kinds of -uniform vectors. - -** The `long_long' C type, deprecated in 1.8, has been removed. - -** And of course, the usual collection of bugfixes. - +** And of course, the usual collection of bugfixes + Interested users should see the ChangeLog for more information. + Changes in 1.9.x (since the 1.8.x series): * New modules (see the manual for details) From 54b38caf19deb0e5a6e8146c65b3e176e7fffa60 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 15 Aug 2009 12:53:59 +0200 Subject: [PATCH 370/375] Add proper `--help' and `--version' for `guile-tools compile'. * configure.ac: Produce `meta/guile-tools'. * meta/Makefile.am (EXTRA_DIST): Add `guile-tools.in'. (bin_SCRIPTS): Remove `guile-tools'. * meta/uninstalled-env.in (PATH): Add "${top_builddir}/meta". * module/scripts/compile.scm (%options): Add `--version'. (parse-args): Show the offending option name upon error. (show-version): New. (compile): Use `%guile-bug-report-address'. --- .gitignore | 1 + configure.ac | 1 + meta/Makefile.am | 9 +++++---- meta/{guile-tools => guile-tools.in} | 6 ++++++ meta/uninstalled-env.in | 3 ++- module/scripts/compile.scm | 16 ++++++++++++++-- 6 files changed, 29 insertions(+), 7 deletions(-) rename meta/{guile-tools => guile-tools.in} (95%) diff --git a/.gitignore b/.gitignore index 004c7f37d..2a7e69496 100644 --- a/.gitignore +++ b/.gitignore @@ -113,3 +113,4 @@ INSTALL /GRTAGS /GSYMS /GTAGS +/meta/guile-tools diff --git a/configure.ac b/configure.ac index ddc092ee9..da71529c6 100644 --- a/configure.ac +++ b/configure.ac @@ -1546,6 +1546,7 @@ AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile]) AC_CONFIG_FILES([meta/guile], [chmod +x meta/guile]) AC_CONFIG_FILES([meta/uninstalled-env], [chmod +x meta/uninstalled-env]) AC_CONFIG_FILES([meta/gdb-uninstalled-guile], [chmod +x meta/gdb-uninstalled-guile]) +AC_CONFIG_FILES([meta/guile-tools], [chmod +x meta/guile-tools]) AC_CONFIG_FILES([libguile/guile-snarf], [chmod +x libguile/guile-snarf]) AC_CONFIG_FILES([libguile/guile-doc-snarf], diff --git a/meta/Makefile.am b/meta/Makefile.am index ba79794cf..c8bdacc92 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -20,10 +20,11 @@ ## write to the Free Software Foundation, Inc., 51 Franklin Street, ## Fifth Floor, Boston, MA 02110-1301 USA -bin_SCRIPTS=guile-config guile-tools -EXTRA_DIST= $(bin_SCRIPTS) \ - guile.m4 ChangeLog-2008 \ - guile-2.0.pc.in guile-2.0-uninstalled.pc.in +bin_SCRIPTS = guile-config +EXTRA_DIST= $(bin_SCRIPTS) \ + guile.m4 ChangeLog-2008 \ + guile-2.0.pc.in guile-2.0-uninstalled.pc.in \ + guile-tools.in pkgconfigdir = $(libdir)/pkgconfig pkgconfig_DATA = guile-2.0.pc diff --git a/meta/guile-tools b/meta/guile-tools.in similarity index 95% rename from meta/guile-tools rename to meta/guile-tools.in index 0c66c7200..51d103fe8 100755 --- a/meta/guile-tools +++ b/meta/guile-tools.in @@ -25,6 +25,12 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" (define-module (guile-tools)) +;; Hack to provide scripts with the bug-report address. +(module-define! the-scm-module + '%guile-bug-report-address + "@PACKAGE_BUGREPORT@") + + ;; We can't import srfi-1, unfortunately, as we are used early in the ;; boot process, before the srfi-1 shlib is built. diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 8ee690ccf..9a6227230 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -1,6 +1,6 @@ #!/bin/sh -# Copyright (C) 2003, 2006, 2008 Free Software Foundation +# Copyright (C) 2003, 2006, 2008, 2009 Free Software Foundation # # This file is part of GUILE. # @@ -112,6 +112,7 @@ export PKG_CONFIG_PATH # handle PATH (no clobber) PATH="${top_builddir}/libguile:${PATH}" PATH="${top_srcdir}/meta:${PATH}" +PATH="${top_builddir}/meta:${PATH}" export PATH exec "$@" diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 89d35bcb5..9b14f2fca 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -48,6 +48,10 @@ (list (option '(#\h "help") #f #f (lambda (opt name arg result) (alist-cons 'help? #t result))) + (option '("version") #f #f + (lambda (opt name arg result) + (show-version) + (exit 0))) (option '(#\L "load-path") #t #f (lambda (opt name arg result) @@ -90,7 +94,7 @@ options." (args-fold args %options (lambda (opt name arg result) - (format (current-error-port) "~A: unrecognized option" opt) + (format (current-error-port) "~A: unrecognized option" name) (exit 1)) (lambda (file result) (let ((input-files (assoc-ref result 'input-files))) @@ -102,6 +106,13 @@ options." (load-path) (warnings unsupported-warning)))) +(define (show-version) + (format #t "compile (GNU Guile) ~A~%" (version)) + (format #t "Copyright (C) 2009 Free Software Foundation, Inc. +License LGPLv3+: GNU LGPL version 3 or later . +This is free software: you are free to change and redistribute it. +There is NO WARRANTY, to the extent permitted by law.~%")) + (define (show-warning-help) (format #t "The available warning types are:~%~%") (for-each (lambda (wt) @@ -143,7 +154,8 @@ Compile each Guile source file FILE into a Guile object. Note that autocompilation will be turned off. -Report bugs to .~%") +Report bugs to <~A>.~%" + %guile-bug-report-address) (exit 0))) (set! %load-path (append load-path %load-path)) From 54dd0ca509bb9c5c549d58893834a2150421f76d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 15 Aug 2009 14:26:17 +0200 Subject: [PATCH 371/375] Update the manual and `NEWS' regarding `guile-2.0.pc'. * NEWS: Mention `guile-2.0.pc'. * doc/ref/autoconf.texi (Autoconf Macros): Update to `guile-2.0'. --- NEWS | 10 ++++++++++ doc/ref/autoconf.texi | 10 +++++----- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index f8aea59ec..e05f3b4d6 100644 --- a/NEWS +++ b/NEWS @@ -98,6 +98,11 @@ There was an EBCDIC compile flag that altered some of the character processing. It appeared that full EBCDIC support was never completed and was unmaintained. +** Packaging changes + +Guile now provides `guile-2.0.pc' (used by pkg-config) instead of +`guile-1.8.pc'. + ** And of course, the usual collection of bugfixes Interested users should see the ChangeLog for more information. @@ -639,6 +644,11 @@ part of Guile). guile.m4 has yet to be modified to call pkg-config instead of guile-config. +** Guile now provides `guile-2.0.pc' instead of `guile-1.8.pc' + +Programs that use `pkg-config' to find Guile or one of its Autoconf +macros should now require `guile-2.0' instead of `guile-1.8'. + ** New installation directory: $(pkglibdir)/1.9/ccache If $(libdir) is /usr/lib, for example, Guile will install its .go files diff --git a/doc/ref/autoconf.texi b/doc/ref/autoconf.texi index 83686dada..ba5800fc0 100644 --- a/doc/ref/autoconf.texi +++ b/doc/ref/autoconf.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -49,7 +49,7 @@ checks. @cindex autoconf GNU Guile provides a @dfn{pkg-config} description file, installed as -@file{@var{prefix}/lib/pkgconfig/guile-1.8.pc}, which contains all the +@file{@var{prefix}/lib/pkgconfig/guile-2.0.pc}, which contains all the information necessary to compile and link C applications that use Guile. The @code{pkg-config} program is able to read this file and provide this information to application programmers; it can be obtained at @@ -59,8 +59,8 @@ The following command lines give respectively the C compilation and link flags needed to build Guile-using programs: @example -pkg-config guile-1.8 --cflags -pkg-config guile-1.8 --libs +pkg-config guile-2.0 --cflags +pkg-config guile-2.0 --libs @end example To ease use of pkg-config with Autoconf, pkg-config comes with a @@ -71,7 +71,7 @@ accordingly, or prints an error and exits if Guile was not found: @findex PKG_CHECK_MODULES @example -PKG_CHECK_MODULES([GUILE], [guile-1.8]) +PKG_CHECK_MODULES([GUILE], [guile-2.0]) @end example Guile comes with additional Autoconf macros providing more information, From e4ca305f247c919cf50da25e2515bf400d6389c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 15 Aug 2009 14:35:29 +0200 Subject: [PATCH 372/375] Turn off auto-compilation to stand-alone tests. * test-suite/standalone/Makefile.am (TESTS_ENVIRONMENT): Add "GUILE_AUTO_COMPILE=0". --- test-suite/standalone/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 37b9cb5e6..a9905324e 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -28,7 +28,8 @@ check_SCRIPTS = BUILT_SOURCES = EXTRA_DIST = -TESTS_ENVIRONMENT = "${top_builddir}/meta/uninstalled-env" +TESTS_ENVIRONMENT = \ + GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env" test_cflags = \ -I$(top_srcdir)/test-suite/standalone \ From a9b8b7b02fc0492627f9e5785147f0cf007e7008 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 15 Aug 2009 14:41:46 +0200 Subject: [PATCH 373/375] Bump version number for 1.9.2. * GUILE-VERSION (GUILE_MICRO_VERSION): Increment. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index fa96ed95a..6d86dd8dd 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -2,7 +2,7 @@ GUILE_MAJOR_VERSION=1 GUILE_MINOR_VERSION=9 -GUILE_MICRO_VERSION=1 +GUILE_MICRO_VERSION=2 GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION} GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION} From 9957b1c70777fd1e62ee869eed9047d7df821a05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 17 Aug 2009 23:05:50 +0200 Subject: [PATCH 374/375] Update `NEWS' for commit d8dd381fa781c236ae777ca1ac55b73d3ca91c2a. --- NEWS | 7 +++++++ THANKS | 1 + 2 files changed, 8 insertions(+) diff --git a/NEWS b/NEWS index e05f3b4d6..353412021 100644 --- a/NEWS +++ b/NEWS @@ -660,6 +660,13 @@ See http://www.gnu.org/software/libunistring/. We hope to merge in Unicode support in the next prerelease. + +Changes in 1.8.8 (since 1.8.7) + +* Bugs fixed + +** Fix possible buffer overruns when parsing numbers + Changes in 1.8.7 (since 1.8.6) diff --git a/THANKS b/THANKS index 47aa93cc7..9fdc092a0 100644 --- a/THANKS +++ b/THANKS @@ -69,6 +69,7 @@ For fixes or providing information which led to a fix: Jeff Long Marco Maggi Gregory Marton + Kjetil S. Matheussen Antoine Mathys Dan McMahill Roger Mc Murtrie From e33a910dd0f430f34c32fe6846899aee33fc2cf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 17 Aug 2009 23:06:49 +0200 Subject: [PATCH 375/375] Thanks, Mike. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index 9fdc092a0..e458a7625 100644 --- a/THANKS +++ b/THANKS @@ -3,6 +3,7 @@ Contributors since the last release: Rob Browning Ludovic Courtès Julian Graham + Mike Gran Stefan Jahn Neil Jerram Gregory Marton